Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
F
FloVer
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
5
Issues
5
List
Boards
Labels
Service Desk
Milestones
Operations
Operations
Incidents
Analytics
Analytics
Repository
Value Stream
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Commits
Issue Boards
Open sidebar
AVA
FloVer
Commits
61171aef
Commit
61171aef
authored
Dec 18, 2017
by
Heiko Becker
Browse files
Options
Browse Files
Download
Plain Diff
Merge branch 'fma_proofs_merge' into 'certificates'
Fma proofs merge See merge request AVA/daisy!170
parents
13ae6d87
c14fe5f4
Changes
21
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
21 changed files
with
2432 additions
and
1069 deletions
+2432
-1069
coq/ErrorBounds.v
coq/ErrorBounds.v
+69
-0
coq/ErrorValidation.v
coq/ErrorValidation.v
+663
-455
coq/Expressions.v
coq/Expressions.v
+207
-10
coq/FPRangeValidator.v
coq/FPRangeValidator.v
+8
-1
coq/IEEE_connection.v
coq/IEEE_connection.v
+92
-5
coq/Infra/Ltacs.v
coq/Infra/Ltacs.v
+0
-1
coq/Infra/MachineType.v
coq/Infra/MachineType.v
+4
-1
coq/IntervalArith.v
coq/IntervalArith.v
+1
-1
coq/IntervalValidation.v
coq/IntervalValidation.v
+46
-1
coq/Typing.v
coq/Typing.v
+41
-4
coq/ssaPrgs.v
coq/ssaPrgs.v
+5
-1
hol4/ErrorBoundsScript.sml
hol4/ErrorBoundsScript.sml
+46
-0
hol4/ErrorValidationScript.sml
hol4/ErrorValidationScript.sml
+851
-577
hol4/ExpressionsScript.sml
hol4/ExpressionsScript.sml
+70
-6
hol4/FPRangeValidatorScript.sml
hol4/FPRangeValidatorScript.sml
+4
-0
hol4/IEEE_connectionScript.sml
hol4/IEEE_connectionScript.sml
+141
-2
hol4/Infra/MachineTypeScript.sml
hol4/Infra/MachineTypeScript.sml
+3
-0
hol4/IntervalValidationScript.sml
hol4/IntervalValidationScript.sml
+147
-1
hol4/TypingScript.sml
hol4/TypingScript.sml
+28
-0
hol4/cakeml
hol4/cakeml
+1
-1
hol4/transScript.sml
hol4/transScript.sml
+5
-2
No files found.
coq/ErrorBounds.v
View file @
61171aef
...
...
@@ -258,6 +258,75 @@ Proof.
apply
Rabs_pos
.
Qed
.
Lemma
fma_abs_err_bounded
(
e1
:
exp
Q
)
(
e1R
:
R
)
(
e1F
:
R
)
(
e2
:
exp
Q
)
(
e2R
:
R
)
(
e2F
:
R
)
(
e3
:
exp
Q
)
(
e3R
:
R
)
(
e3F
:
R
)
(
vR
:
R
)
(
vF
:
R
)
(
E1
E2
:
env
)
(
m
m1
m2
m3
:
mType
)
defVars
:
eval_exp
E1
(
toRMap
defVars
)
(
toREval
(
toRExp
e1
))
e1R
M0
->
eval_exp
E2
defVars
(
toRExp
e1
)
e1F
m1
->
eval_exp
E1
(
toRMap
defVars
)
(
toREval
(
toRExp
e2
))
e2R
M0
->
eval_exp
E2
defVars
(
toRExp
e2
)
e2F
m2
->
eval_exp
E1
(
toRMap
defVars
)
(
toREval
(
toRExp
e3
))
e3R
M0
->
eval_exp
E2
defVars
(
toRExp
e3
)
e3F
m3
->
eval_exp
E1
(
toRMap
defVars
)
(
toREval
(
Fma
(
toRExp
e1
)
(
toRExp
e2
)
(
toRExp
e3
)))
vR
M0
->
eval_exp
(
updEnv
3
e3F
(
updEnv
2
e2F
(
updEnv
1
e1F
emptyEnv
)))
(
updDefVars
3
m3
(
updDefVars
2
m2
(
updDefVars
1
m1
defVars
)))
(
Fma
(
Var
R
1
)
(
Var
R
2
)
(
Var
R
3
))
vF
m
->
(
Rabs
(
vR
-
vF
)
<=
Rabs
((
e1R
-
e1F
)
+
(
e2R
*
e3R
-
e2F
*
e3F
))
+
Rabs
(
e1F
+
e2F
*
e3F
)
*
(
Q2R
(
mTypeToQ
m
)))
%
R
.
Proof
.
intros
e1_real
e1_float
e2_real
e2_float
e3_real
e3_float
fma_real
fma_float
.
inversion
fma_real
;
subst
;
assert
(
m0
=
M0
)
by
(
eapply
toRMap_eval_M0
;
eauto
).
assert
(
m4
=
M0
)
by
(
eapply
toRMap_eval_M0
;
eauto
).
assert
(
m5
=
M0
)
by
(
eapply
toRMap_eval_M0
;
eauto
).
subst
;
simpl
in
H3
;
rewrite
Q2R0_is_0
in
H3
;
auto
.
rewrite
delta_0_deterministic
in
fma_real
;
auto
.
rewrite
delta_0_deterministic
;
auto
.
unfold
evalFma
in
*
;
simpl
in
*
.
clear
delta
H3
.
rewrite
(
meps_0_deterministic
(
toRExp
e1
)
H5
e1_real
);
rewrite
(
meps_0_deterministic
(
toRExp
e2
)
H6
e2_real
);
rewrite
(
meps_0_deterministic
(
toRExp
e3
)
H7
e3_real
).
rewrite
(
meps_0_deterministic
(
toRExp
e1
)
H5
e1_real
)
in
fma_real
.
rewrite
(
meps_0_deterministic
(
toRExp
e2
)
H6
e2_real
)
in
fma_real
.
rewrite
(
meps_0_deterministic
(
toRExp
e3
)
H7
e3_real
)
in
fma_real
.
clear
H5
H6
v1
v2
v3
H7
H2
.
inversion
fma_float
;
subst
.
unfold
evalFma
in
*
.
unfold
perturb
;
simpl
.
inversion
H3
;
subst
;
inversion
H6
;
subst
;
inversion
H7
;
subst
.
unfold
updEnv
in
*
;
simpl
in
*
.
inversion
H5
;
inversion
H1
;
inversion
H9
;
subst
.
clear
fma_float
H7
fma_real
e1_real
e1_float
e2_real
e2_float
e3_real
e3_float
H6
H1
H5
H9
H3
H0
H4
H8
.
repeat
rewrite
Rmult_plus_distr_l
.
rewrite
Rmult_1_r
.
rewrite
Rsub_eq_Ropp_Rplus
.
rewrite
Ropp_plus_distr
.
rewrite
<-
Rplus_assoc
.
setoid_rewrite
<-
Rsub_eq_Ropp_Rplus
at
2.
rewrite
Rsub_eq_Ropp_Rplus
.
rewrite
Rsub_eq_Ropp_Rplus
.
rewrite
Rsub_eq_Ropp_Rplus
.
rewrite
<-
Rplus_assoc
.
setoid_rewrite
Rplus_comm
at
8.
rewrite
<-
Rplus_assoc
.
setoid_rewrite
Rplus_comm
at
9.
rewrite
Rplus_assoc
.
setoid_rewrite
Rplus_assoc
at
2.
rewrite
<-
Rplus_assoc
.
rewrite
<-
Rsub_eq_Ropp_Rplus
.
rewrite
<-
Rsub_eq_Ropp_Rplus
.
rewrite
<-
Ropp_plus_distr
.
rewrite
<-
Rsub_eq_Ropp_Rplus
.
eapply
Rle_trans
.
eapply
Rabs_triang
.
eapply
Rplus_le_compat_l
.
rewrite
Rabs_Ropp
.
repeat
rewrite
Rabs_mult
.
eapply
Rmult_le_compat_l
;
auto
.
apply
Rabs_pos
.
Qed
.
Lemma
err_prop_inversion_pos_real
nF
nR
err
elo
ehi
(
float_iv_pos
:
(
0
<
elo
-
err
)
%
R
)
(
real_iv_pos
:
(
0
<
elo
)
%
R
)
...
...
coq/ErrorValidation.v
View file @
61171aef
This diff is collapsed.
Click to expand it.
coq/Expressions.v
View file @
61171aef
...
...
@@ -98,6 +98,9 @@ Definition evalUnop (o:unop) (v:R):=
|
Inv
=>
(
/
v
)
%
R
end
.
Definition
evalFma
(
v1
:
R
)
(
v2
:
R
)
(
v3
:
R
)
:=
evalBinop
Plus
v1
(
evalBinop
Mult
v2
v3
).
(
**
Define
expressions
parametric
over
some
value
type
V
.
Will
ease
reasoning
about
different
instantiations
later
.
...
...
@@ -107,6 +110,7 @@ Inductive exp (V:Type): Type :=
|
Const
:
mType
->
V
->
exp
V
|
Unop
:
unop
->
exp
V
->
exp
V
|
Binop
:
binop
->
exp
V
->
exp
V
->
exp
V
|
Fma
:
exp
V
->
exp
V
->
exp
V
->
exp
V
|
Downcast
:
mType
->
exp
V
->
exp
V
.
(
**
...
...
@@ -122,6 +126,8 @@ Fixpoint expEq (e1:exp Q) (e2:exp Q) :=
(
unopEq
o1
o2
)
&&
(
expEq
e11
e22
)
|
Binop
o1
e11
e12
,
Binop
o2
e21
e22
=>
(
binopEq
o1
o2
)
&&
(
expEq
e11
e21
)
&&
(
expEq
e12
e22
)
|
Fma
e11
e12
e13
,
Fma
e21
e22
e23
=>
(
expEq
e11
e21
)
&&
(
expEq
e12
e22
)
&&
(
expEq
e13
e23
)
|
Downcast
m1
f1
,
Downcast
m2
f2
=>
(
mTypeEq
m1
m2
)
&&
(
expEq
f1
f2
)
|
_
,
_
=>
false
...
...
@@ -136,6 +142,7 @@ Proof.
-
apply
Qeq_bool_iff
;
lra
.
-
case
u
;
auto
.
-
case
b
;
auto
.
-
firstorder
.
-
apply
mTypeEq_refl
.
Qed
.
...
...
@@ -156,6 +163,9 @@ Proof.
*
destruct
b
;
auto
.
*
apply
IHe1
.
+
apply
IHe2
.
-
f_equal
.
+
f_equal
;
auto
.
+
auto
.
-
f_equal
.
+
apply
mTypeEq_sym
;
auto
.
+
apply
IHe
.
...
...
@@ -180,6 +190,9 @@ Proof.
rewrite
binopEq_refl
;
simpl
.
apply
andb_true_iff
.
split
;
[
eapply
IHe1
;
eauto
|
eapply
IHe2
;
eauto
].
-
rewrite
andb_true_iff
.
rewrite
andb_true_iff
.
split
;
[
split
;
[
eapply
IHe1
;
eauto
|
eapply
IHe2
;
eauto
]
|
eapply
IHe3
;
eauto
].
-
rewrite
mTypeEq_refl
;
simpl
.
eapply
IHe
;
eauto
.
Qed
.
...
...
@@ -206,6 +219,7 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
if
unopEq
u1
u2
then
expCompare
e1
e2
else
(
if
unopEq
u1
Neg
then
Lt
else
Gt
)
|
Unop
_
_
,
Fma
_
_
_
=>
Lt
|
Unop
_
_
,
Binop
_
_
_
=>
Lt
|
Unop
_
_
,
Downcast
_
_
=>
Lt
|
Unop
_
_
,
_
=>
Gt
...
...
@@ -213,6 +227,7 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
if
mTypeEq
m1
m2
then
expCompare
e1
e2
else
(
if
morePrecise
m1
m2
then
Lt
else
Gt
)
|
Downcast
_
_
,
Fma
_
_
_
=>
Lt
|
Downcast
_
_
,
Binop
_
_
_
=>
Lt
|
Downcast
_
_
,
_
=>
Gt
|
Binop
b1
e11
e12
,
Binop
b2
e21
e22
=>
...
...
@@ -238,7 +253,19 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
end
|
_
=>
res
end
|
_
,
_
=>
Gt
|
Binop
_
_
_
,
Fma
_
_
_
=>
Lt
|
Binop
_
_
_
,
_
=>
Gt
|
Fma
e11
e12
e13
,
Fma
e21
e22
e23
=>
match
expCompare
e11
e21
with
|
Eq
=>
match
expCompare
e12
e22
with
|
Eq
=>
expCompare
e13
e23
|
Lt
=>
Lt
|
Gt
=>
Gt
end
|
Lt
=>
Lt
|
Gt
=>
Gt
end
|
Fma
_
_
_
,
_
=>
Gt
end
.
Lemma
expCompare_refl
e
:
expCompare
e
e
=
Eq
.
...
...
@@ -248,6 +275,7 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
-
rewrite
mTypeEq_refl
.
apply
V_orderedFacts
.
compare_refl
.
-
rewrite
unopEq_refl
;
auto
.
-
rewrite
IHe1
,
IHe2
.
destruct
b
;
auto
.
-
now
rewrite
IHe1
,
IHe2
,
IHe3
.
-
rewrite
mTypeEq_refl
;
auto
.
Qed
.
...
...
@@ -295,6 +323,11 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
destruct
(
expCompare
e1_1
e2_1
)
eqn
:?
;
destruct
(
expCompare
e2_1
e3_1
)
eqn
:?
;
try
congruence
;
try
erewrite
IHe1_1
;
eauto
.
-
destruct
(
expCompare
e1_1
e2_1
)
eqn
:?
;
destruct
(
expCompare
e2_1
e3_1
)
eqn
:?
;
destruct
(
expCompare
e1_2
e2_2
)
eqn
:?
;
destruct
(
expCompare
e2_2
e3_2
)
eqn
:?
;
try
congruence
;
try
erewrite
IHe1_1
,
IHe1_2
;
eauto
.
-
destruct
(
mTypeEq
m
m0
)
eqn
:?
;
destruct
(
mTypeEq
m0
m1
)
eqn
:?
;
type_conv
;
...
...
@@ -334,6 +367,13 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
rewrite
IHe1_1
in
*
;
simpl
in
*
;
rewrite
CompOpp_iff
in
first_comp
;
rewrite
first_comp
;
simpl
;
try
auto
.
-
destruct
(
expCompare
e1_1
e2_1
)
eqn
:
first_comp
;
destruct
(
expCompare
e1_2
e2_2
)
eqn
:
second_comp
;
rewrite
IHe1_1
,
IHe1_2
in
*
;
simpl
in
*
;
rewrite
CompOpp_iff
in
first_comp
;
rewrite
CompOpp_iff
in
second_comp
;
rewrite
first_comp
,
second_comp
;
simpl
;
try
auto
.
-
rewrite
mTypeEq_sym
.
destruct
(
mTypeEq
m0
m
)
eqn
:?
;
type_conv
;
try
auto
.
...
...
@@ -345,6 +385,12 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
*
destruct
m
,
m0
;
unfold
morePrecise
in
*
;
cbv
;
congruence
.
Qed
.
Lemma
expCompare_eq_sym
e1
e2
:
expCompare
e1
e2
=
Eq
<->
expCompare
e2
e1
=
Eq
.
Proof
.
now
split
;
intros
H
;
rewrite
expCompare_antisym
;
rewrite
H
.
Qed
.
Lemma
expCompare_lt_eq_is_lt
e1
:
forall
e2
e3
,
expCompare
e1
e2
=
Lt
->
expCompare
e2
e3
=
Eq
->
expCompare
e1
e3
=
Lt
.
...
...
@@ -377,6 +423,16 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
try
congruence
;
try
(
erewrite
IHe1_1
;
eauto
;
fail
""
);
try
erewrite
expCompare_eq_trans
;
eauto
.
-
destruct
(
expCompare
e1_1
e2_1
)
eqn
:?
;
destruct
(
expCompare
e2_1
e3_1
)
eqn
:?
;
try
congruence
;
try
(
erewrite
IHe1_1
;
eauto
;
fail
""
);
try
erewrite
expCompare_eq_trans
;
eauto
.
destruct
(
expCompare
e1_2
e2_2
)
eqn
:?
;
destruct
(
expCompare
e2_2
e3_2
)
eqn
:?
;
try
congruence
;
try
(
erewrite
IHe1_2
;
eauto
;
fail
""
);
try
erewrite
expCompare_eq_trans
;
eauto
.
-
destruct
(
mTypeEq
m
m0
)
eqn
:?
;
destruct
(
mTypeEq
m0
m1
)
eqn
:?
.
+
type_conv
;
subst
.
rewrite
mTypeEq_refl
.
eapply
IHe1
;
eauto
.
...
...
@@ -417,6 +473,16 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
try
congruence
;
try
(
erewrite
IHe1_1
;
eauto
;
fail
""
);
try
erewrite
expCompare_eq_trans
;
eauto
.
-
destruct
(
expCompare
e1_1
e2_1
)
eqn
:?
;
destruct
(
expCompare
e2_1
e3_1
)
eqn
:?
;
try
congruence
;
try
(
erewrite
IHe1_1
;
eauto
;
fail
""
);
try
erewrite
expCompare_eq_trans
;
eauto
.
destruct
(
expCompare
e1_2
e2_2
)
eqn
:?
;
destruct
(
expCompare
e2_2
e3_2
)
eqn
:?
;
try
congruence
;
try
(
erewrite
IHe1_2
;
eauto
;
fail
""
);
try
erewrite
expCompare_eq_trans
;
eauto
.
-
destruct
(
mTypeEq
m
m0
)
eqn
:?
;
destruct
(
mTypeEq
m0
m1
)
eqn
:?
.
+
type_conv
;
subst
.
rewrite
mTypeEq_refl
.
eapply
IHe1
;
eauto
.
...
...
@@ -449,6 +515,7 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
apply
IHx
;
auto
.
+
destruct
b
;
destruct
(
expCompare
x1
x1
)
eqn
:?
;
try
congruence
.
+
destruct
(
expCompare
x1
x1
)
eqn
:?
;
destruct
(
expCompare
x2
x2
)
eqn
:?
;
try
congruence
.
+
rewrite
mTypeEq_refl
in
lt_x
.
apply
IHx
;
auto
.
-
unfold
Transitive
.
...
...
@@ -502,6 +569,19 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
try
(
erewrite
expCompare_eq_lt_is_lt
;
eauto
;
fail
);
try
(
erewrite
expCompare_lt_eq_is_lt
;
eauto
;
fail
);
try
(
erewrite
IHe1_1
;
eauto
).
+
destruct
(
expCompare
e1_1
y1
)
eqn
:?
;
try
congruence
;
destruct
(
expCompare
y1
z1
)
eqn
:?
;
try
congruence
;
try
(
erewrite
expCompare_eq_lt_is_lt
;
eauto
;
fail
);
try
(
erewrite
expCompare_lt_eq_is_lt
;
eauto
;
fail
);
try
(
erewrite
IHe1_1
;
eauto
;
fail
).
apply
(
expCompare_eq_trans
_
_
_
Heqc
)
in
Heqc0
;
rewrite
Heqc0
.
destruct
(
expCompare
e1_2
y2
)
eqn
:?
;
try
congruence
;
destruct
(
expCompare
y2
z2
)
eqn
:?
;
try
congruence
;
try
(
erewrite
expCompare_eq_trans
;
eauto
;
fail
);
try
(
erewrite
expCompare_eq_lt_is_lt
;
eauto
;
fail
);
try
(
erewrite
expCompare_lt_eq_is_lt
;
eauto
;
fail
);
try
(
erewrite
IHe1_2
;
eauto
).
+
destruct
(
mTypeEq
m
m0
)
eqn
:?
;
destruct
(
mTypeEq
m0
m1
)
eqn
:?
;
[
type_conv
;
subst
;
rewrite
mTypeEq_refl
|
|
|
].
...
...
@@ -558,6 +638,32 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
try
(
split
;
try
congruence
;
intros
);
try
(
specialize
(
IHe1_1
_
Heqc
_
_
Heqc0
);
simpl
in
*
;
rewrite
IHe1_1
in
*
;
congruence
);
try
(
specialize
(
IHe1_1
_
Heqc
_
_
Heqc0
);
simpl
in
*
;
rewrite
<-
IHe1_1
in
*
;
congruence
).
-
try
(
split
;
auto
;
fail
);
destruct
(
expCompare
e1_1
e2_1
)
eqn
:?
;
destruct
(
expCompare
e3_1
e4_1
)
eqn
:?
;
try
congruence
;
destruct
(
expCompare
e1_1
e3_1
)
eqn
:?
;
destruct
(
expCompare
e2_1
e4_1
)
eqn
:?
;
try
(
split
;
congruence
);
try
(
specialize
(
IHe1_2
_
e1_eq_e2
_
_
e3_eq_e4
);
simpl
in
*
;
rewrite
IHe1_2
in
*
;
split
;
auto
;
fail
);
try
(
split
;
try
congruence
;
intros
);
try
(
specialize
(
IHe1_1
_
Heqc
_
_
Heqc0
);
simpl
in
*
;
rewrite
IHe1_1
in
*
;
congruence
);
try
(
specialize
(
IHe1_1
_
Heqc
_
_
Heqc0
);
simpl
in
*
;
rewrite
<-
IHe1_1
in
*
;
congruence
);
try
(
split
;
auto
;
fail
);
destruct
(
expCompare
e1_2
e2_2
)
eqn
:?
;
destruct
(
expCompare
e3_2
e4_2
)
eqn
:?
;
try
congruence
;
destruct
(
expCompare
e1_2
e3_2
)
eqn
:?
;
destruct
(
expCompare
e2_2
e4_2
)
eqn
:?
;
try
(
split
;
congruence
);
try
(
split
;
try
congruence
;
intros
);
try
(
specialize
(
IHe1_2
_
Heqc3
_
_
Heqc4
);
simpl
in
*
;
rewrite
IHe1_2
in
*
;
congruence
);
try
(
specialize
(
IHe1_2
_
Heqc3
_
_
Heqc4
);
simpl
in
*
;
rewrite
<-
IHe1_2
in
*
;
congruence
);
try
congruence
;
erewrite
expCompare_eq_trans
;
eauto
;
erewrite
expCompare_eq_trans
;
eauto
;
rewrite
expCompare_antisym
;
now
(
try
rewrite
e3_eq_e4
;
try
rewrite
e1_eq_e2
).
-
destruct
(
mTypeEq
m
m0
)
eqn
:?
;
destruct
(
mTypeEq
m1
m2
)
eqn
:?
;
[
type_conv
|
|
|
].
+
specialize
(
IHe1
_
e1_eq_e2
_
_
e3_eq_e4
);
simpl
in
*
.
...
...
@@ -606,6 +712,38 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
try
(
specialize
(
IHe1_1
_
Heqc
_
_
Heqc0
);
simpl
in
*
;
rewrite
<-
IHe1_1
in
*
;
congruence
);
try
(
rewrite
(
eq_comp
_
_
Heqc
_
_
Heqc0
)
in
*
;
congruence
);
try
(
rewrite
<-
(
eq_comp
_
_
Heqc
_
_
Heqc0
)
in
*
;
congruence
).
-
pose
proof
eq_compat
as
eq_comp
.
unfold
Proper
,
eq
in
eq_comp
.
destruct
(
expCompare
e1_1
e2_1
)
eqn
:?
;
destruct
(
expCompare
e3_1
e4_1
)
eqn
:?
;
try
congruence
;
destruct
(
expCompare
e1_1
e3_1
)
eqn
:?
;
destruct
(
expCompare
e2_1
e4_1
)
eqn
:?
;
try
(
split
;
congruence
);
try
(
specialize
(
IHe1_2
_
e1_eq_e2
_
_
e3_eq_e4
);
simpl
in
*
;
rewrite
IHe1_2
in
*
;
split
;
auto
;
fail
);
try
(
split
;
try
congruence
;
intros
);
try
(
specialize
(
IHe1_1
_
Heqc
_
_
Heqc0
);
simpl
in
*
;
rewrite
IHe1_1
in
*
;
congruence
);
try
(
specialize
(
IHe1_1
_
Heqc
_
_
Heqc0
);
simpl
in
*
;
rewrite
<-
IHe1_1
in
*
;
congruence
);
try
(
rewrite
(
eq_comp
_
_
Heqc
_
_
Heqc0
)
in
*
;
congruence
);
try
(
rewrite
<-
(
eq_comp
_
_
Heqc
_
_
Heqc0
)
in
*
;
congruence
);
destruct
(
expCompare
e1_2
e2_2
)
eqn
:?
;
destruct
(
expCompare
e3_2
e4_2
)
eqn
:?
;
try
congruence
;
destruct
(
expCompare
e1_2
e3_2
)
eqn
:?
;
destruct
(
expCompare
e2_2
e4_2
)
eqn
:?
;
try
(
split
;
congruence
);
try
(
specialize
(
IHe1_3
_
e1_eq_e2
_
_
e3_eq_e4
);
simpl
in
*
;
rewrite
IHe1_3
in
*
;
split
;
auto
;
fail
);
try
(
split
;
try
congruence
;
intros
);
try
(
specialize
(
IHe1_2
_
Heqc3
_
_
Heqc4
);
simpl
in
*
;
rewrite
IHe1_2
in
*
;
congruence
);
try
(
specialize
(
IHe1_2
_
Heqc3
_
_
Heqc4
);
simpl
in
*
;
rewrite
<-
IHe1_2
in
*
;
congruence
);
try
(
rewrite
(
eq_comp
_
_
Heqc3
_
_
Heqc4
)
in
*
;
congruence
);
try
(
rewrite
<-
(
eq_comp
_
_
Heqc3
_
_
Heqc4
)
in
*
;
congruence
);
try
congruence
.
+
apply
(
expCompare_lt_eq_is_lt
_
_
_
H
)
in
e3_eq_e4
;
rewrite
expCompare_eq_sym
in
e1_eq_e2
;
now
apply
(
expCompare_eq_lt_is_lt
_
_
_
e1_eq_e2
).
+
rewrite
expCompare_eq_sym
in
e3_eq_e4
;
apply
(
expCompare_lt_eq_is_lt
_
_
_
H
)
in
e3_eq_e4
;
now
apply
(
expCompare_eq_lt_is_lt
_
_
_
e1_eq_e2
).
-
destruct
(
mTypeEq
m
m0
)
eqn
:?
;
destruct
(
mTypeEq
m1
m2
)
eqn
:?
;
[
type_conv
|
|
|
].
+
specialize
(
IHe1
_
e1_eq_e2
_
_
e3_eq_e4
);
simpl
in
*
.
...
...
@@ -614,7 +752,7 @@ Module ExpOrderedType (V_ordered:OrderType) <: OrderType.
+
destruct
(
morePrecise
m1
m2
);
congruence
.
+
destruct
(
morePrecise
m
m0
);
congruence
.
+
destruct
(
morePrecise
m
m0
);
congruence
.
Defin
ed
.
Q
ed
.
Lemma
compare_spec
:
forall
x
y
,
CompSpec
eq
lt
x
y
(
expCompare
x
y
).
Proof
.
...
...
@@ -685,11 +823,12 @@ End ExpOrderedType.
Fixpoint
toRExp
(
e
:
exp
Q
)
:=
match
e
with
|
Var
_
v
=>
Var
R
v
|
Const
m
n
=>
Const
m
(
Q2R
n
)
|
Unop
o
e1
=>
Unop
o
(
toRExp
e1
)
|
Binop
o
e1
e2
=>
Binop
o
(
toRExp
e1
)
(
toRExp
e2
)
|
Downcast
m
e1
=>
Downcast
m
(
toRExp
e1
)
|
Var
_
v
=>
Var
R
v
|
Const
m
n
=>
Const
m
(
Q2R
n
)
|
Unop
o
e1
=>
Unop
o
(
toRExp
e1
)
|
Binop
o
e1
e2
=>
Binop
o
(
toRExp
e1
)
(
toRExp
e2
)
|
Fma
e1
e2
e3
=>
Fma
(
toRExp
e1
)
(
toRExp
e2
)
(
toRExp
e3
)
|
Downcast
m
e1
=>
Downcast
m
(
toRExp
e1
)
end
.
Fixpoint
toREval
(
e
:
exp
R
)
:=
...
...
@@ -698,6 +837,7 @@ Fixpoint toREval (e:exp R) :=
|
Const
_
n
=>
Const
M0
n
|
Unop
o
e1
=>
Unop
o
(
toREval
e1
)
|
Binop
o
e1
e2
=>
Binop
o
(
toREval
e1
)
(
toREval
e2
)
|
Fma
e1
e2
e3
=>
Fma
(
toREval
e1
)
(
toREval
e2
)
(
toREval
e3
)
|
Downcast
_
e1
=>
Downcast
M0
(
toREval
e1
)
end
.
...
...
@@ -750,7 +890,15 @@ Inductive eval_exp (E:env) (Gamma: nat -> option mType) :(exp R) -> R -> mType -
eval_exp
E
Gamma
f1
v1
m1
->
eval_exp
E
Gamma
f2
v2
m2
->
((
op
=
Div
)
->
(
~
v2
=
0
)
%
R
)
->
eval_exp
E
Gamma
(
Binop
op
f1
f2
)
(
perturb
(
evalBinop
op
v1
v2
)
delta
)
(
join
m1
m2
).
eval_exp
E
Gamma
(
Binop
op
f1
f2
)
(
perturb
(
evalBinop
op
v1
v2
)
delta
)
(
join
m1
m2
)
|
Fma_dist
m1
m2
m3
f1
f2
f3
v1
v2
v3
delta
:
Rle
(
Rabs
delta
)
(
Q2R
(
mTypeToQ
(
join3
m1
m2
m3
)))
->
eval_exp
E
Gamma
f1
v1
m1
->
eval_exp
E
Gamma
f2
v2
m2
->
eval_exp
E
Gamma
f3
v3
m3
->
eval_exp
E
Gamma
(
Fma
f1
f2
f3
)
(
perturb
(
evalFma
v1
v2
v3
)
delta
)
(
join3
m1
m2
m3
).
Hint
Constructors
eval_exp
.
...
...
@@ -819,6 +967,20 @@ Qed.
Hint
Resolve
Binop_dist
'
.
Lemma
Fma_dist
'
m1
m2
m3
f1
f2
f3
v1
v2
v3
delta
v
m
'
E
Gamma
:
Rle
(
Rabs
delta
)
(
Q2R
(
mTypeToQ
m
'
))
->
eval_exp
E
Gamma
f1
v1
m1
->
eval_exp
E
Gamma
f2
v2
m2
->
eval_exp
E
Gamma
f3
v3
m3
->
v
=
perturb
(
evalFma
v1
v2
v3
)
delta
->
m
'
=
join3
m1
m2
m3
->
eval_exp
E
Gamma
(
Fma
f1
f2
f3
)
v
m
'
.
Proof
.
intros
;
subst
;
auto
.
Qed
.
Hint
Resolve
Fma_dist
'
.
(
**
Define
the
set
of
"used"
variables
of
an
expression
to
be
the
set
of
variables
occuring
in
it
...
...
@@ -828,6 +990,7 @@ Fixpoint usedVars (V:Type) (e:exp V) :NatSet.t :=
|
Var
_
x
=>
NatSet
.
singleton
x
|
Unop
u
e1
=>
usedVars
e1
|
Binop
b
e1
e2
=>
NatSet
.
union
(
usedVars
e1
)
(
usedVars
e2
)
|
Fma
e1
e2
e3
=>
NatSet
.
union
(
usedVars
e1
)
(
NatSet
.
union
(
usedVars
e2
)
(
usedVars
e3
))
|
Downcast
_
e1
=>
usedVars
e1
|
_
=>
NatSet
.
empty
end
.
...
...
@@ -851,6 +1014,13 @@ Proof.
assert
(
m2
=
M0
)
by
(
eapply
IHf2
;
eauto
);
subst
;
auto
.
-
assert
(
m1
=
M0
)
by
(
eapply
IHf1
;
eauto
).
assert
(
m2
=
M0
)
by
(
eapply
IHf2
;
eauto
).
assert
(
m3
=
M0
)
by
(
eapply
IHf3
;
eauto
);
subst
;
auto
.
Qed
.
(
**
...
...
@@ -899,6 +1069,20 @@ Proof.
simpl
in
*
.
rewrite
Q2R0_is_0
in
*
.
repeat
(
rewrite
delta_0_deterministic
;
try
auto
).
-
inversion
ev1
;
inversion
ev2
;
subst
.
assert
(
m0
=
M0
)
by
(
eapply
toRMap_eval_M0
;
eauto
).
assert
(
m1
=
M0
)
by
(
eapply
toRMap_eval_M0
;
eauto
).
assert
(
m2
=
M0
)
by
(
eapply
toRMap_eval_M0
;
eauto
).
assert
(
m3
=
M0
)
by
(
eapply
toRMap_eval_M0
;
eauto
).
assert
(
m4
=
M0
)
by
(
eapply
toRMap_eval_M0
;
eauto
).
assert
(
m5
=
M0
)
by
(
eapply
toRMap_eval_M0
;
eauto
).
subst
.
rewrite
(
IHf1
v0
v5
);
try
auto
.
rewrite
(
IHf2
v3
v6
);
try
auto
.
rewrite
(
IHf3
v4
v7
);
try
auto
.
simpl
in
*
.
rewrite
Q2R0_is_0
in
*
.
repeat
(
rewrite
delta_0_deterministic
;
try
auto
).
-
inversion
ev1
;
inversion
ev2
;
subst
.
apply
M0_least_precision
in
H1
;
apply
M0_least_precision
in
H7
;
subst
.
...
...
@@ -909,7 +1093,7 @@ Proof.
Qed
.
(
**
Helping
lemma
.
Needed
in
soundness
proof
.
Helping
lemma
s
.
Needed
in
soundness
proof
.
For
each
evaluation
of
using
an
arbitrary
epsilon
,
we
can
replace
it
by
evaluating
the
subexpressions
and
then
binding
the
result
values
to
different
variables
in
the
Environment
.
...
...
@@ -928,6 +1112,19 @@ Proof.
econstructor
;
try
auto
.
Qed
.
Lemma
fma_unfolding
f1
f2
f3
E
v1
v2
v3
m1
m2
m3
Gamma
delta
:
(
Rabs
delta
<=
Q2R
(
mTypeToQ
(
join3
m1
m2
m3
)))
%
R
->
eval_exp
E
Gamma
f1
v1
m1
->
eval_exp
E
Gamma
f2
v2
m2
->
eval_exp
E
Gamma
f3
v3
m3
->
eval_exp
E
Gamma
(
Fma
f1
f2
f3
)
(
perturb
(
evalFma
v1
v2
v3
)
delta
)
(
join3
m1
m2
m3
)
->
eval_exp
(
updEnv
3
v3
(
updEnv
2
v2
(
updEnv
1
v1
emptyEnv
)))
(
updDefVars
3
m3
(
updDefVars
2
m2
(
updDefVars
1
m1
Gamma
)))
(
Fma
(
Var
R
1
)
(
Var
R
2
)
(
Var
R
3
))
(
perturb
(
evalFma
v1
v2
v3
)
delta
)
(
join3
m1
m2
m3
).
Proof
.
econstructor
;
try
auto
.
Qed
.
Lemma
eval_eq_env
e
:
forall
E1
E2
Gamma
v
m
,
(
forall
x
,
E1
x
=
E2
x
)
->
...
...
@@ -989,4 +1186,4 @@ Qed. *)
(
*
Simplify
arithmetic
later
by
making
>
>=
only
abbreviations
*
)
(
*
**
)
*
)
(
*
Definition
gr
:=
fun
(
V
:
Type
)
(
f1
:
exp
V
)
(
f2
:
exp
V
)
=>
less
f2
f1
.
*
)
(
*
Definition
greq
:=
fun
(
V
:
Type
)
(
f1
:
exp
V
)
(
f2
:
exp
V
)
=>
leq
f2
f1
.
*
)
\ No newline at end of file
(
*
Definition
greq
:=
fun
(
V
:
Type
)
(
f1
:
exp
V
)
(
f2
:
exp
V
)
=>
leq
f2
f1
.
*
)
coq/FPRangeValidator.v
View file @
61171aef
...
...
@@ -14,6 +14,10 @@ Fixpoint FPRangeValidator (e:exp Q) (A:analysisResult) typeMap dVars {struct e}
|
Binop
b
e1
e2
=>
FPRangeValidator
e1
A
typeMap
dVars
&&
FPRangeValidator
e2
A
typeMap
dVars
|
Fma
e1
e2
e3
=>
FPRangeValidator
e1
A
typeMap
dVars
&&
FPRangeValidator
e2
A
typeMap
dVars
&&
FPRangeValidator
e3
A
typeMap
dVars
|
Unop
u
e
=>
FPRangeValidator
e
A
typeMap
dVars
|
Downcast
m
e
=>
FPRangeValidator
e
A
typeMap
dVars
...
...
@@ -123,6 +127,9 @@ Proof.
-
Daisy_compute
;
try
congruence
.
type_conv
;
subst
.
prove_fprangeval
(
join
m0
m1
)
v
L1
R
.
-
Daisy_compute
;
try
congruence
.
type_conv
;
subst
.
prove_fprangeval
(
join3
m0
m1
m2
)
v
L1
R
.
-
Daisy_compute
;
try
congruence
.
type_conv
;
subst
.
prove_fprangeval
m
v
L1
R
.
...
...
@@ -238,4 +245,4 @@ Proof.
rewrite
NatSet
.
add_spec
in
H4
;
destruct
H4
;
auto
;
subst
;
congruence
.
}
-
eapply
FPRangeValidator_sound
;
eauto
.
Qed
.
\ No newline at end of file
Qed
.
coq/IEEE_connection.v
View file @
61171aef
...
...
@@ -45,6 +45,11 @@ Fixpoint eval_exp_float (e:exp (binary_float 53 1024)) (E:nat -> option fl64):=
end
|
_
,
_
=>
None
end
|
Fma
e1
e2
e3
=>
match
eval_exp_float
e1
E
,
eval_exp_float
e2
E
,
eval_exp_float
e3
E
with
(
*
|
Some
f1
,
Some
f2
,
Some
f3
=>
Some
(
b64_plus
dmode
f1
(
b64_mult
dmode
f2
f3
))
*
)
|
_
,
_
,
_
=>
None
end
|
_
=>
None
end
.
...
...
@@ -78,6 +83,26 @@ Fixpoint eval_exp_valid (e:exp fl64) E :=
normal_or_zero
(
evalBinop
b
v1_real
v2_real
))
True
)
True
)
|
Fma
e1
e2
e3
=>
(
eval_exp_valid
e1
E
)
/
\
(
eval_exp_valid
e2
E
)
/
\
(
eval_exp_valid
e3
E
)
/
\
(
let
e1_res
:=
eval_exp_float
e1
E
in
let
e2_res
:=
eval_exp_float
e2
E
in
let
e3_res
:=
eval_exp_float
e3
E
in
optionLift
e1_res
(
fun
v1
=>
let
v1_real
:=
B2R
53
1024
v1
in
optionLift
e2_res
(
fun
v2
=>
let
v2_real
:=
B2R
53
1024
v2
in
optionLift
e3_res
(
fun
v3
=>
let
v3_real
:=
B2R
53
1024
v3
in
(
*
No
support
for
fma
yet
*
)
(
*
normal_or_zero
(
evalFma
v1_real
v2_real
v3_real
))
*
)
False
)
True
)
True
)
True
)
|
Downcast
m
e
=>
eval_exp_valid
e
E
end
.
...
...
@@ -153,6 +178,7 @@ Fixpoint B2Qexp (e: exp fl64) :=
|
Const
m
v
=>
Const
m
(
B2Q
v
)
|
Unop
u
e
=>
Unop
u
(
B2Qexp
e
)
|
Binop
b
e1
e2
=>
Binop
b
(
B2Qexp
e1
)
(
B2Qexp
e2
)
|
Fma
e1
e2
e3
=>
Fma
(
B2Qexp
e1
)
(
B2Qexp
e2
)
(
B2Qexp
e3
)
|
Downcast
m
e
=>
Downcast
m
(
B2Qexp
e
)
end
.
...
...
@@ -174,6 +200,7 @@ Fixpoint is64BitEval (V:Type) (e:exp V) :=
|
Const
m
e
=>
m
=
M64
|
Unop
u
e
=>
is64BitEval
e
|
Binop
b
e1
e2
=>
is64BitEval
e1
/
\
is64BitEval
e2
|
Fma
e1
e2
e3
=>
is64BitEval
e1
/
\
is64BitEval
e2
/
\
is64BitEval
e3
|
Downcast
m
e
=>
m
=
M64
/
\
is64BitEval
e
end
.
...
...
@@ -189,6 +216,7 @@ Fixpoint noDowncast (V:Type) (e:exp V) :=
|
Const
m
e
=>
True
|
Unop
u
e
=>
noDowncast
e
|
Binop
b
e1
e2
=>
noDowncast
e1
/
\
noDowncast
e2
|
Fma
e1
e2
e3
=>
noDowncast
e1
/
\
noDowncast
e2
/
\
noDowncast
e3
|
Downcast
m
e
=>
False
end
.
...
...
@@ -286,6 +314,17 @@ Proof.
*
intros
.
apply
types_valid
.
set_tac
.
+
intros
;
apply
types_valid
;
set_tac
.
-
repeat
(
match
goal
with
|
H
:
_
/
\
_
|-
_
=>
destruct
H
end
).
erewrite
IHe1
in
*
;
eauto
;
try
(
intros
;
apply
types_valid
;
set_tac
;
fail
).
erewrite
IHe2
in
*
;
eauto
;
try
(
intros
;
apply
types_valid
;
set_tac
;
fail
).
unfold
join3
,
join
in
*
.
erewrite
IHe3
in
*
;
eauto
;
try
(
intros
;
apply
types_valid
;
set_tac
;
fail
).
repeat
destr_factorize
.
repeat
rewrite
<-
isMorePrecise_morePrecise
.
repeat
rewrite
isMorePrecise_refl
;
type_conv
;
subst
;
auto
.
Qed
.
Lemma
typing_cmd_64_bit
f
:
...
...
@@ -326,10 +365,12 @@ Proof.
Daisy_compute
;
try
congruence
;
type_conv
;
subst
;
try
auto
.
-
eapply
IHe
;
eauto
.
-
eapply
IHe
;
eauto
.
-
assert
(
m0
=
m
).
{
eapply
IHe1
;
eauto
.
}
assert
(
m3
=
m1
).
{
eapply
IHe2
;
eauto
.
}
-
assert
(
m0
=
m
)
by
eauto
using
IHe1
.
assert
(
m3
=
m1
)
by
eauto
using
IHe2
.
subst
;
auto
.
-
assert
(
m0
=
m
)
by
eauto
using
IHe1
.
assert
(
m3
=
m1
)
by
eauto
using
IHe2
.
assert
(
m4
=
m5
)
by
eauto
using
IHe3
.
subst
;
auto
.
Qed
.
...
...
@@ -458,6 +499,7 @@ Lemma eval_exp_gives_IEEE (e:exp fl64) :
exists
v
,
eval_exp_float
e
E2
=
Some
v
/
\
eval_exp
(
toREnv
E2
)
Gamma
(
toRExp
(
B2Qexp
e
))
(
Q2R
(
B2Q
v
))
M64
.
Proof
.
induction
e
;
simpl
in
*
;