Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
AVA
FloVer
Commits
7bd27dc4
Commit
7bd27dc4
authored
Apr 02, 2019
by
Heiko Becker
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Fix errors introduced by merge with subdivision checks
parent
36ce0269
Changes
6
Show whitespace changes
Inline
Side-by-side
Showing
6 changed files
with
199 additions
and
1244 deletions
+199
-1244
coq/AffineValidation.v
coq/AffineValidation.v
+5
-1
coq/CertificateChecker.v
coq/CertificateChecker.v
+2
-2
coq/Checker_extraction.v
coq/Checker_extraction.v
+5
-2
coq/ErrorValidationAA.v
coq/ErrorValidationAA.v
+50
-32
coq/ErrorValidationAAutil.v
coq/ErrorValidationAAutil.v
+5
-5
coq/IEEE_connection.v
coq/IEEE_connection.v
+132
-1202
No files found.
coq/AffineValidation.v
View file @
7bd27dc4
...
...
@@ -110,6 +110,7 @@ Fixpoint validAffineBounds (e: expr Q) (A: analysisResult) P (validVars: NatSet.
if
(
isSupersetIntv
intv
iv
)
&&
(
isSupersetIntv
iv
intv
)
then
Some
(
FloverMap
.
add
e
af
'
exprsAf
'
,
n
'
)
else
None
|
Let
_
_
_
_
=>
None
end
end
.
...
...
@@ -522,7 +523,8 @@ Qed.
Definition
checked_expressions
(
A
:
analysisResult
)
E
Gamma
fVars
dVars
e
iexpmap
inoise
map1
:=
exists
af
vR
aiv
aerr
,
NatSet
.
Subset
(
usedVars
e
)
(
NatSet
.
union
fVars
dVars
)
/
\
(
*
WAS
:
usedVars
e
*
)
NatSet
.
Subset
(
freeVars
e
)
(
NatSet
.
union
fVars
dVars
)
/
\
FloverMap
.
find
e
A
=
Some
(
aiv
,
aerr
)
/
\
isSupersetIntv
(
toIntv
af
)
aiv
=
true
/
\
FloverMap
.
find
e
iexpmap
=
Some
af
/
\
...
...
@@ -677,6 +679,7 @@ Proof.
lra
.
Qed
.
(
*
Lemma
validAffineBounds_sound_var
A
P
E
Gamma
fVars
dVars
n
:
forall
(
noise
:
nat
)
(
exprAfs
:
expressionsAffine
)
(
inoise
:
nat
)
(
iexpmap
:
FloverMap
.
t
(
affine_form
Q
))
(
map1
:
nat
->
option
noise_type
),
...
...
@@ -2597,3 +2600,4 @@ Proof.
split
;
eauto
using
Rle_trans
.
+
destruct
vtyped
;
auto
.
Qed
.
*
)
\ No newline at end of file
coq/CertificateChecker.v
View file @
7bd27dc4
...
...
@@ -30,7 +30,6 @@ Theorem Certificate_checking_is_sound_general (e:expr Q) (absenv:analysisResult)
forall
(
E1
E2
:
env
)
DeltaMap
,
(
forall
(
v
:
R
)
(
m
'
:
mType
),
exists
d
:
R
,
DeltaMap
v
m
'
=
Some
d
/
\
(
Rabs
d
<=
mTypeToR
m
'
)
%
R
)
->
eval_precond
E1
P
->
unsat_queries
Qmap
->
(
forall
Qmap
,
In
Qmap
(
queriesInSubdivs
subdivs
)
->
unsat_queries
Qmap
)
->
...
...
@@ -45,6 +44,7 @@ Theorem Certificate_checking_is_sound_general (e:expr Q) (absenv:analysisResult)
eval_expr
E2
(
toRExpMap
Gamma
)
DeltaMap
(
toRExp
e
)
vF
m
->
(
Rabs
(
vR
-
vF
)
<=
Q2R
err
))
%
R
/
\
validTypes
e
Gamma
/
\
getValidMap
defVars
e
(
FloverMap
.
empty
mType
)
=
Succes
Gamma
/
\
validRanges
e
absenv
E1
(
toRTMap
(
toRExpMap
Gamma
))
/
\
validErrorBounds
e
E1
E2
absenv
Gamma
/
\
validFPRanges
e
E2
Gamma
absenv
.
...
...
coq/Checker_extraction.v
View file @
7bd27dc4
Require
Import
Flover
.
CertificateChecker
Flover
.
floverParser
.
Require
Import
Coq
.
extraction
.
ExtrOcamlString
Coq
.
extraction
.
ExtrOcamlBasic
Coq
.
extraction
.
ExtrOcamlNatBigInt
Coq
.
extraction
.
ExtrOcamlZBigInt
.
Require
Import
Coq
.
extraction
.
ExtrOcamlString
Coq
.
extraction
.
ExtrOcamlBasic
Coq
.
extraction
.
ExtrOcamlNatBigInt
Coq
.
extraction
.
ExtrOcamlZBigInt
.
Extraction
Language
O
c
aml
.
Extraction
Language
O
C
aml
.
(
*
Extraction
"./binary/CoqChecker.ml"
runChecker
.
*
)
coq/ErrorValidationAA.v
View file @
7bd27dc4
...
...
@@ -12,9 +12,9 @@ From Coq
From
Flover
Require
Import
Infra
.
Abbrevs
Infra
.
RationalSimps
Infra
.
RealRationalProps
Infra
.
RealSimps
Infra
.
Ltacs
Commands
Environments
ErrorAnalysis
ErrorValidationAAutil
Infra
.
RealSimps
Infra
.
Ltacs
Environments
ErrorAnalysis
ErrorValidationAAutil
ExpressionSemantics
IntervalValidation
TypeValidator
RealRangeValidator
ErrorBounds
ErrorValidation
AffineForm
AffineArithQ
AffineArith
.
ErrorValidation
AffineForm
AffineArithQ
AffineArith
AffineValidation
.
(
**
Error
bound
validator
**
)
Fixpoint
validErrorboundAA
(
e
:
expr
Q
)
(
*
analyzed
expression
*
)
...
...
@@ -206,9 +206,11 @@ Fixpoint validErrorboundAA (e:expr Q) (* analyzed expression *)
Some
(
FloverMap
.
add
e
errPoly
newErrorMap1
,
(
maxNoise1
+
1
)
%
nat
)
else
None
|
Let
_
_
_
_
=>
None
end
.
(
**
Error
bound
command
validator
**
)
(
*
Fixpoint
validErrorboundAACmd
(
f
:
cmd
Q
)
(
*
analyzed
cmd
with
let
'
s
*
)
(
typeMap
:
FloverMap
.
t
mType
)
(
*
derived
types
for
e
*
)
(
A
:
analysisResult
)
(
*
encoded
result
of
Flover
*
)
...
...
@@ -235,6 +237,7 @@ Fixpoint validErrorboundAACmd (f: cmd Q) (* analyzed cmd with let's *)
end
|
Ret
e
=>
validErrorboundAA
e
typeMap
A
dVars
currNoise
errMap
end
.
*
)
(
*
Notation
for
the
universal
case
of
the
soundness
statement
,
to
help
reason
about
memoization
cases
.
This
allows
us
to
show
several
monotonicity
lemmas
...
...
@@ -313,6 +316,7 @@ Fixpoint contained_subexpr (e: expr Q) (expr_map: FloverMap.t (affine_form Q)):
|
Fma
e1
e2
e3
=>
contained_subexpr
e1
expr_map
/
\
contained_subexpr
e2
expr_map
/
\
contained_subexpr
e3
expr_map
|
Downcast
m
e
'
=>
contained_subexpr
e
'
expr_map
|
Let
_
_
_
_
=>
False
(
*
FIXME
*
)
end
/
\
FloverMap
.
In
e
expr_map
.
Lemma
contained_subexpr_map_extension
e
expr_map1
expr_map2
:
...
...
@@ -415,6 +419,8 @@ Proof.
rewrite
andb_true_l
in
e5
.
apply
Ndec
.
Ncompare_Neqb
in
Hexpeq
.
now
rewrite
Hexpeq
in
e5
.
-
simpl
in
*
.
destruct
Hcont
;
contradiction
.
-
simpl
in
*
.
destruct
Hcont
;
contradiction
.
Qed
.
Lemma
validErrorboundAA_contained_subexpr
e
Gamma
A
dVars
noise1
noise2
expr_map1
expr_map2
:
...
...
@@ -780,6 +786,11 @@ Proof.
intuition
.
*
apply
contained_subexpr_add_compat
;
auto
.
*
apply
flover_map_in_add
.
-
destruct
(
FloverMap
.
mem
(
elt
:=
affine_form
Q
)
(
Let
m
n
e1
e2
)
expr_map1
)
eqn
:
Hmem
.
+
inversion
Hvalidbounds
;
subst
.
apply
FloverMap
.
mem_2
in
Hmem
.
intuition
.
+
Flover_compute
.
destruct
(
negb
(
Qleb
0
e
))
eqn
:?
;
congruence
.
Qed
.
(
*
The
soundness
statements
starts
off
with
assumption
that
the
checking
...
...
@@ -797,7 +808,8 @@ Definition validErrorboundAA_sound_statement e E1 E2 A Gamma DeltaMap fVars dVar
eval_expr
E1
(
toRTMap
(
toRExpMap
Gamma
))
DeltaMapR
(
toREval
(
toRExp
e
))
v__R
REAL
->
validRanges
e
A
E1
(
toRTMap
(
toRExpMap
Gamma
))
->
validErrorboundAA
e
Gamma
A
dVars
noise1
expr_map1
=
Some
(
expr_map2
,
noise2
)
->
NatSet
.
Subset
(
usedVars
e
--
dVars
)
fVars
->
(
*
WAS
:
usedVars
*
)
NatSet
.
Subset
(
freeVars
e
--
dVars
)
fVars
->
validTypes
e
Gamma
->
FloverMap
.
find
e
A
=
Some
(
iv__A
,
err__A
)
->
(
*
Starting
noise
index
is
greater
than
0
and
the
noise
mapping
doesn
'
t
...
...
@@ -813,7 +825,8 @@ Definition validErrorboundAA_sound_statement e E1 E2 A Gamma DeltaMap fVars dVar
(
forall
e
'
:
FloverMap
.
key
,
FloverMap
.
In
e
'
expr_map1
->
(
*
Assumption
needed
for
Cmd_sound
proof
*
)
NatSet
.
Subset
(
usedVars
e
'
)
(
NatSet
.
union
fVars
dVars
)
/
\
(
*
WAS
:
usedVars
*
)
NatSet
.
Subset
(
freeVars
e
'
)
(
NatSet
.
union
fVars
dVars
)
/
\
(
exists
iv__A
'
err__A
'
,
FloverMap
.
find
e
'
A
=
Some
(
iv__A
'
,
err__A
'
))
/
\
exists
(
v__FP
'
:
R
)
(
m__FP
'
:
mType
),
eval_expr
E2
(
toRExpMap
Gamma
)
DeltaMap
(
toRExp
e
'
)
v__FP
'
m__FP
'
)
->
...
...
@@ -834,7 +847,8 @@ Definition validErrorboundAA_sound_statement e E1 E2 A Gamma DeltaMap fVars dVar
the
existential
part
holds
*
)
(
forall
e
'
:
FloverMap
.
key
,
~
FloverMap
.
In
e
'
expr_map1
->
FloverMap
.
In
e
'
expr_map2
->
NatSet
.
Subset
(
usedVars
e
'
)
(
NatSet
.
union
fVars
dVars
)
/
\
(
*
WAS
:
usedVars
*
)
NatSet
.
Subset
(
freeVars
e
'
)
(
NatSet
.
union
fVars
dVars
)
/
\
(
exists
iv__A
'
err__A
'
,
FloverMap
.
find
e
'
A
=
Some
(
iv__A
'
,
err__A
'
))
/
\
exists
(
v__FP
'
:
R
)
(
m__FP
'
:
mType
),
eval_expr
E2
(
toRExpMap
Gamma
)
DeltaMap
(
toRExp
e
'
)
v__FP
'
m__FP
'
))
/
\
...
...
@@ -933,10 +947,10 @@ Proof.
intros
e
'
Hnin
Hin
.
destruct
(
flover_map_el_eq_extension
Hnin
Hin
)
as
[
Heq
Hexpeq
].
split
;
[
|
split
;
[
|
now
rewrite
Hexpeq
]].
1
:
rewrite
used
Vars_eq_compat
;
unfold
Q_orderedExps
.
eq
;
*
rewrite
free
Vars_eq_compat
;
try
eapply
Q_orderedExps
.
exprCompare_eq_sym
;
eauto
.
1
:
now
ap
pl
y
s
ubset_diff_to_subset_union
.
erewrite
FloverMapFacts
.
P
.
F
.
find_o
in
Hcert
;
eauto
.
sim
pl
.
s
et_tac
.
subst
;
auto
.
*
erewrite
FloverMapFacts
.
P
.
F
.
find_o
in
Hcert
;
eauto
.
+
intros
v__FP
m__FP
Heval__FP
.
rewrite
Qle_bool_iff
in
Herrle
.
apply
Qle_Rle
in
Herrle
.
...
...
@@ -1062,10 +1076,10 @@ Proof.
intros
e
'
Hnin
Hin
.
destruct
(
flover_map_el_eq_extension
Hnin
Hin
)
as
[
Heq
Hexpeq
].
split
;
[
|
split
;
[
|
now
rewrite
Hexpeq
]].
1
:
rewrite
used
Vars_eq_compat
;
unfold
Q_orderedExps
.
eq
;
*
rewrite
free
Vars_eq_compat
;
try
eapply
Q_orderedExps
.
exprCompare_eq_sym
;
eauto
.
1
:
now
ap
pl
y
s
ubset_diff_to_subset_union
.
erewrite
FloverMapFacts
.
P
.
F
.
find_o
in
Hcert
;
eauto
.
sim
pl
.
s
et_tac
.
*
erewrite
FloverMapFacts
.
P
.
F
.
find_o
in
Hcert
;
eauto
.
-
rewrite
Qle_bool_iff
in
Herrle
.
apply
Qle_Rle
in
Herrle
.
intros
*
Heval__FP
.
...
...
@@ -1216,10 +1230,10 @@ Proof.
+
edestruct
IHcheckedex
as
(
?
&
?
&
?
);
eauto
.
+
destruct
(
flover_map_el_eq_extension
Hnin1
Hin
)
as
[
Heq
Hexpeq
];
auto
.
split
;
[
|
split
;
[
|
now
rewrite
Hexpeq
]].
1
:
rewrite
used
Vars_eq_compat
;
unfold
Q_orderedExps
.
eq
;
*
rewrite
free
Vars_eq_compat
;
unfold
Q_orderedExps
.
eq
;
try
eapply
Q_orderedExps
.
exprCompare_eq_sym
;
eauto
.
1
:
now
apply
subset_diff_to_subset_union
.
erewrite
FloverMapFacts
.
P
.
F
.
find_o
in
Hcert
;
eauto
.
now
apply
subset_diff_to_subset_union
.
*
erewrite
FloverMapFacts
.
P
.
F
.
find_o
in
Hcert
;
eauto
.
-
intros
v__FP
m__FP
Heval__FPdet
.
inversion
Heval__FPdet
;
subst
.
pose
proof
H5
as
H5det
.
...
...
@@ -1417,10 +1431,10 @@ Proof.
[
specialize
(
IHchecked2
e
'
Hnin1
Hin2
);
intuition
|
].
destruct
(
flover_map_el_eq_extension
Hnin2
Hin
)
as
[
Heq
Hexpeq
];
auto
.
split
;
[
|
split
;
[
|
now
rewrite
Hexpeq
]].
1
:
rewrite
used
Vars_eq_compat
;
unfold
Q_orderedExps
.
eq
;
{
rewrite
free
Vars_eq_compat
;
unfold
Q_orderedExps
.
eq
;
try
eapply
Q_orderedExps
.
exprCompare_eq_sym
;
eauto
.
1
:
now
apply
subset_diff_to_subset_union
.
erewrite
FloverMapFacts
.
P
.
F
.
find_o
in
Hcert
;
eauto
.
now
apply
subset_diff_to_subset_union
.
}
{
erewrite
FloverMapFacts
.
P
.
F
.
find_o
in
Hcert
;
eauto
.
}
*
intros
*
Heval__FPdet
.
inversion
Heval__R
;
subst
.
rename
v1
into
v__R1
;
rename
v2
into
v__R2
.
...
...
@@ -1674,9 +1688,9 @@ Proof.
destruct
(
flover_map_in_dec
e
'
subexpr_map2
)
as
[
Hin2
|
Hnin2
];
[
apply
IHchecked2
;
auto
|
].
destruct
(
flover_map_el_eq_extension
Hnin2
Hin
)
as
[
Heq
Hexpeq
];
auto
.
split
;
[
|
split
;
[
|
now
rewrite
Hexpeq
]].
1
:
rewrite
used
Vars_eq_compat
;
unfold
Q_orderedExps
.
eq
;
{
rewrite
free
Vars_eq_compat
;
unfold
Q_orderedExps
.
eq
;
try
eapply
Q_orderedExps
.
exprCompare_eq_sym
;
eauto
.
1
:
now
apply
subset_diff_to_subset_union
.
now
apply
subset_diff_to_subset_union
.
}
erewrite
FloverMapFacts
.
P
.
F
.
find_o
in
Hcert
;
eauto
.
*
intros
*
Heval__FPdet
.
inversion
Heval__R
;
subst
.
...
...
@@ -1926,7 +1940,7 @@ Proof.
destruct
(
flover_map_in_dec
e
'
subexpr_map2
)
as
[
Hin2
|
Hnin2
];
[
apply
IHchecked2
;
auto
|
].
destruct
(
flover_map_el_eq_extension
Hnin2
Hin
)
as
[
Heq
Hexpeq
];
auto
.
split
;
[
|
split
;
[
|
now
rewrite
Hexpeq
]].
1
:
rewrite
used
Vars_eq_compat
;
unfold
Q_orderedExps
.
eq
;
1
:
rewrite
free
Vars_eq_compat
;
unfold
Q_orderedExps
.
eq
;
try
eapply
Q_orderedExps
.
exprCompare_eq_sym
;
eauto
.
1
:
now
apply
subset_diff_to_subset_union
.
erewrite
FloverMapFacts
.
P
.
F
.
find_o
in
Hcert
;
eauto
.
...
...
@@ -2251,7 +2265,7 @@ Proof.
destruct
(
flover_map_in_dec
e
'
subexpr_map2
)
as
[
Hin2
|
Hnin2
];
[
apply
IHchecked2
;
auto
|
].
destruct
(
flover_map_el_eq_extension
Hnin2
Hin
)
as
[
Heq
Hexpeq
];
auto
.
split
;
[
|
split
;
[
|
now
rewrite
Hexpeq
]].
1
:
rewrite
used
Vars_eq_compat
;
unfold
Q_orderedExps
.
eq
;
1
:
rewrite
free
Vars_eq_compat
;
unfold
Q_orderedExps
.
eq
;
try
eapply
Q_orderedExps
.
exprCompare_eq_sym
;
eauto
.
1
:
now
apply
subset_diff_to_subset_union
.
erewrite
FloverMapFacts
.
P
.
F
.
find_o
in
Hcert
;
eauto
.
...
...
@@ -2639,7 +2653,7 @@ Proof.
destruct
(
flover_map_in_dec
e
'
subexpr_map3
)
as
[
Hin3
|
Hnin3
];
[
apply
IHchecked3
;
auto
|
].
destruct
(
flover_map_el_eq_extension
Hnin3
Hin
)
as
[
Heq
Hexpeq
];
auto
.
split
;
[
|
split
;
[
|
now
rewrite
Hexpeq
]].
1
:
rewrite
used
Vars_eq_compat
;
unfold
Q_orderedExps
.
eq
;
1
:
rewrite
free
Vars_eq_compat
;
unfold
Q_orderedExps
.
eq
;
try
eapply
Q_orderedExps
.
exprCompare_eq_sym
;
eauto
.
1
:
now
apply
subset_diff_to_subset_union
.
erewrite
FloverMapFacts
.
P
.
F
.
find_o
in
Hcert
;
eauto
.
...
...
@@ -2942,7 +2956,7 @@ Proof.
destruct
(
flover_map_in_dec
e
'
subexpr_map
)
as
[
Hin1
|
Hnin1
];
[
apply
IHchecked
;
auto
|
].
destruct
(
flover_map_el_eq_extension
Hnin1
Hin
)
as
[
Heq
Hexpeq
];
auto
.
split
;
[
|
split
;
[
|
now
rewrite
Hexpeq
]].
1
:
rewrite
used
Vars_eq_compat
;
unfold
Q_orderedExps
.
eq
;
1
:
rewrite
free
Vars_eq_compat
;
unfold
Q_orderedExps
.
eq
;
try
eapply
Q_orderedExps
.
exprCompare_eq_sym
;
eauto
.
1
:
now
apply
subset_diff_to_subset_union
.
erewrite
FloverMapFacts
.
P
.
F
.
find_o
in
Hcert
;
eauto
.
...
...
@@ -3059,7 +3073,8 @@ Proof.
-
apply
validErrorboundAA_sound_binop
;
auto
.
-
apply
validErrorboundAA_sound_fma
;
auto
.
-
apply
validErrorboundAA_sound_downcast
;
auto
.
Qed
.
-
admit
.
Admitted
.
Corollary
validErrorbound_sound_validErrorBounds
e
E1
E2
A
Gamma
DeltaMap
expr_map
noise
noise_map
:
(
forall
e
'
:
FloverMap
.
key
,
...
...
@@ -3182,8 +3197,10 @@ Proof.
end
.
cbn
in
Hiv
.
now
rewrite
Rabs_Rle_condition
.
Qed
.
-
admit
.
Admitted
.
(
*
Definition
checked_error_commands
c
E1
E2
A
Gamma
DeltaMap
noise_map
noise
expr_map
:=
match
c
with
|
Let
m
x
e
k
=>
...
...
@@ -3512,7 +3529,7 @@ Proof.
specialize
(
flover_map_el_eq_extension
Hvarnew
Hin
)
as
[
Heq
Heqexp
].
rewrite
Heqexp
.
split
.
+
rewrite
used
Vars_eq_compat
;
unfold
Q_orderedExps
.
eq
;
+
rewrite
free
Vars_eq_compat
;
unfold
Q_orderedExps
.
eq
;
try
eapply
Q_orderedExps
.
exprCompare_eq_sym
;
eauto
.
cbn
;
set_tac
.
+
split
.
...
...
@@ -3798,3 +3815,4 @@ Proof.
cbn
in
H12
.
now
rewrite
Rabs_Rle_condition
.
Qed
.
*
)
\ No newline at end of file
coq/ErrorValidationAAutil.v
View file @
7bd27dc4
...
...
@@ -4,9 +4,9 @@ From Coq
From
Flover
Require
Import
Infra
.
Abbrevs
Infra
.
RationalSimps
Infra
.
RealRationalProps
Infra
.
RealSimps
Infra
.
Ltacs
Commands
Environments
ErrorAnalysis
Infra
.
RealSimps
Infra
.
Ltacs
Environments
ErrorAnalysis
ExpressionSemantics
IntervalValidation
TypeValidator
RealRangeValidator
ErrorBounds
ErrorValidation
AffineForm
AffineArithQ
AffineArith
.
ErrorValidation
AffineForm
AffineArithQ
AffineArith
AffineValidation
.
Definition
mkErrorPolyQ
(
err
:
Q
)
noise
:=
if
Qeq_bool
err
0
then
...
...
coq/IEEE_connection.v
View file @
7bd27dc4
...
...
@@ -14,13 +14,17 @@ From Flocq
From
Flocq
.
Prop
Require
Import
Relative
.
(
*
Appli
.
Fappli_IEEE_bits
Appli
.
Fappli_IEEE
Core
.
Fcore_Raux
Fprop_relative
Fcore_generic_fmt
.
*
)
(
**
Definitions
of
static
values
.
dmode
is
the
rounding
mode
used
for
the
proofs
;
fl64
specifies
the
type
of
binary
,
64
-
bit
floating
-
point
words
;
flt_exp_64
is
the
Flocq
library
function
FLT_exp
for
64
-
bit
floats
**
)
Definition
dmode
:=
mode_NE
.
Definition
fl64
:
Type
:=
binary_float
53
1024.
Definition
flt_exp_64
:=
FLT_exp
(
3
-
1024
-
53
)
53.
(
*
Additional
assumptions
necessary
to
obtain
relative
error
later
*
)
Lemma
valid_flt_64
:
Valid_exp
flt_exp_64
.
Proof
.
...
...
@@ -38,12 +42,18 @@ Proof.
destruct
(
Z
.
max_spec_le
(
k
-
53
)
(
-
1074
));
omega
.
Qed
.
(
**
Flocq
relative
error
theorem
instantiated
for
64
-
bit
floats
*
)
Definition
relative_error_64_ex
:=
@
relative_error_N_ex
radix2
flt_exp_64
valid_flt_64
(
-
1022
)
53
valid_flt_64_assum
(
fun
x
=>
negb
(
Z
.
even
x
)).
(
**
Our
deterministic
semantics
uses
a
map
to
define
roundoff
errors
.
We
define
an
IEEE
-
754
correct
delta
map
and
show
that
it
correctly
provides
a
roundoff
error
**
)
Definition
IeeeDeltaMap
(
x
:
R
)
(
m
:
mType
)
:
option
R
:=
match
m
with
|
M64
=>
if
(
Raux
.
Rle_bool
(
Raux
.
bpow
radix2
(
-
1022
))
(
Rabs
x
))
...
...
@@ -104,6 +114,9 @@ Definition updFlEnv x v E :=
then
Some
(
A
:=
(
binary_float
53
1024
))
v
else
E
y
.
(
**
Definition
of
IEEE
754
evaluation
for
FloVer
expressions
**
)
Fixpoint
eval_expr_float
(
e
:
expr
(
binary_float
53
1024
))
(
E
:
nat
->
option
fl64
)
:=
match
e
with
|
Var
_
x
=>
E
x
...
...
@@ -136,16 +149,6 @@ Fixpoint eval_expr_float (e:expr (binary_float 53 1024)) (E:nat -> option fl64):
|
_
=>
None
end
.
(
*
Fixpoint
bstep_float
f
E
:
option
fl64
:=
match
f
with
|
Let
m
x
e
g
=>
olet
res
:=
eval_expr_float
e
E
in
bstep_float
g
(
updFlEnv
x
res
E
)
|
Ret
e
=>
eval_expr_float
e
E
end
.
*
)
Definition
isValid
e
:=
plet
v
:=
e
in
normal_or_zero
(
B2R
53
1024
v
).
...
...
@@ -153,7 +156,8 @@ Definition isValid e :=
Fixpoint
eval_expr_valid
(
e
:
expr
fl64
)
E
:=
match
e
with
|
Var
_
x
=>
True
(
*
isValid
(
eval_expr_float
(
Var
n
)
E
)
*
)
|
Const
m
v
=>
True
(
*
isValid
(
eval_expr_float
(
Const
m
v
)
E
)
*
)
|
Const
m
v
=>
plet
v
:=
eval_expr_float
(
Const
m
v
)
E
in
if
is_finite
53
1024
v
then
True
else
False
|
Unop
u
e
=>
eval_expr_valid
e
E
|
Binop
b
e1
e2
=>
(
eval_expr_valid
e1
E
)
/
\
(
eval_expr_valid
e2
E
)
/
\
...
...
@@ -265,78 +269,6 @@ Fixpoint B2Qexpr (e: expr fl64) :=
(
*
|
Cond
e1
e2
e3
=>
Cond
(
B2Qexpr
e1
)
(
B2Qexpr
e2
)
(
B2Qexpr
e3
)
*
)
end
.
(
*
Fixpoint
B2Qcmd
(
f
:
cmd
fl64
)
:=
match
f
with
|
Let
m
x
e
g
=>
Let
m
x
(
B2Qexpr
e
)
(
B2Qcmd
g
)
|
Ret
e
=>
Ret
(
B2Qexpr
e
)
end
.
*
)
Definition
isValid
e
:=
plet
v
:=
e
in
normal_or_zero
(
B2R
53
1024
v
).
Fixpoint
eval_expr_valid
(
e
:
expr
fl64
)
E
:=
match
e
with
|
Var
_
x
=>
True
(
*
isValid
(
eval_expr_float
(
Var
n
)
E
)
*
)
(
*
We
need
this
assumption
here
otherwise
we
cannot
prove
constants
having
0
roundoff
error
*
)
|
Const
m
v
=>
plet
v
:=
eval_expr_float
(
Const
m
v
)
E
in
if
is_finite
53
1024
v
then
True
else
False
|
Unop
u
e
=>
eval_expr_valid
e
E
|
Binop
b
e1
e2
=>
(
eval_expr_valid
e1
E
)
/
\
(
eval_expr_valid
e2
E
)
/
\
(
let
e1_res
:=
eval_expr_float
e1
E
in
let
e2_res
:=
eval_expr_float
e2
E
in
match
e1_res
with
|
None
=>
True
|
Some
v1
=>
let
v1_real
:=
B2R
53
1024
v1
in
match
e2_res
with
|
None
=>
True
|
Some
v2
=>
let
v2_real
:=
B2R
53
1024
v2
in
let
op_real
:=
evalBinop
b
v1_real
v2_real
in
(
*
plet
delta
:=
IeeeDeltaMap
op_real
M64
in
normal_or_zero
(
perturb
op_real
M64
delta
)
*
)
normal_or_zero
op_real
end
end
)
|
Fma
e1
e2
e3
=>
(
eval_expr_valid
e1
E
)
/
\
(
eval_expr_valid
e2
E
)
/
\
(
eval_expr_valid
e3
E
)
/
\
(
let
e1_res
:=
eval_expr_float
e1
E
in
let
e2_res
:=
eval_expr_float
e2
E
in
let
e3_res
:=
eval_expr_float
e3
E
in
match
e1_res
with
|
None
=>
True
|
Some
v1
=>
let
v1_real
:=
B2R
53
1024
v1
in
match
e2_res
with
|
None
=>
True
|
Some
v2
=>
let
v2_real
:=
B2R
53
1024
v2
in
match
e3_res
with
|
None
=>
True
|
Some
v3
=>
let
v3_real
:=
B2R
53
1024
v3
in
False
(
*
No
support
for
fma
yet
;
ideally
this
would
be
normal_or_zero
(
evalFma
v1_real
v2_real
v3_real
)
*
)
end
end
end
)
|
Downcast
m
e
=>
eval_expr_valid
e
E
end
.
Fixpoint
bstep_valid
f
E
:=
match
f
with
|
Let
m
x
e
g
=>
eval_expr_valid
e
E
/
\
(
optionBind
(
eval_expr_float
e
E
)
(
fun
v_e
=>
bstep_valid
g
(
updFlEnv
x
v_e
E
))
True
)
|
Ret
e
=>
eval_expr_valid
e
E
end
.
Definition
toREnv
(
E
:
nat
->
option
fl64
)
(
x
:
nat
)
:
option
R
:=
match
E
x
with
|
Some
v
=>
Some
(
Q2R
(
B2Q
v
))
...
...
@@ -360,14 +292,6 @@ Fixpoint is64BitEval (V:Type) (e:expr V) :=
(
*
|
Cond
e1
e2
e3
=>
is64BitEval
e1
/
\
is64BitEval
e2
/
\
is64BitEval
e3
*
)
end
.
(
*
Fixpoint
is64BitBstep
(
V
:
Type
)
(
f
:
cmd
V
)
:=
match
f
with
|
Let
m
x
e
g
=>
is64BitEval
e
/
\
m
=
M64
/
\
is64BitBstep
g
|
Ret
e
=>
is64BitEval
e
end
.
*
)
Fixpoint
noDowncast
(
V
:
Type
)
(
e
:
expr
V
)
:=
match
e
with
|
Var
_
x
=>
True
...
...
@@ -380,14 +304,6 @@ Fixpoint noDowncast (V:Type) (e:expr V) :=
(
*
|
Cond
e1
e2
e3
=>
noDowncast
e1
/
\
noDowncast
e2
/
\
noDowncast
e3
*
)
end
.
(
*
Fixpoint
noDowncastFun
(
V
:
Type
)
(
f
:
cmd
V
)
:=
match
f
with
|
Let
m
x
e
g
=>
noDowncast
e
/
\
noDowncastFun
g
|
Ret
e
=>
noDowncast
e
end
.
*
)
Opaque
mTypeToQ
.
Lemma
validValue_is_finite
v
:
...
...
@@ -454,20 +370,6 @@ Proof.
erewrite
<-
Gamma_64Bit
;
eauto
.
Qed
.
(
*
Lemma
typing_cmd_64_bit
f
:
forall
Gamma
,
is64BitEnv
Gamma
->
validTypesCmd
f
Gamma
->
FloverMap
.
find
(
getRetExp
f
)
Gamma
=
Some
M64
.
Proof
.
induction
f
;
intros
*
Gamma_64BitEnv
valid_f
.
-
destruct
valid_f
as
[(
?
&
?
&
?
&
?
&
?
&
?
)
?
].
eapply
IHf
;
eauto
.
-
destruct
valid_f
;
simpl
in
*
;
eapply
typing_expr_64_bit
;
eauto
.
Qed
.
*
)
Lemma
round_0_zero
:
(
round
radix2
flt_exp_64
(
round_mode
mode_NE
)
0
)
=
0
%
R
.
Proof
.
...
...
@@ -620,8 +522,45 @@ Proof.
+
Flover_compute
;
inversion
getMap_succeeds
;
subst
.
find_cases
;
try
(
eapply
IHe
with
(
akk
:=
akk
);
eauto
).
congruence
.
-
destruct
(
getValidMap
defVars
e1
akk
)
eqn
:?
;
simpl
in
*
;
try
congruence
.
destruct
(
FloverMap
.
find
e1
t
)
eqn
:?
;
[
|
congruence
].
destruct
is64Bit_e
as
(
?
&
?
&
?
);
subst
.
assert
(
m1
=
M64
).
{
eapply
IHe1
with
(
akk
:=
akk
);
eauto
.
}
subst
.
cbn
in
getMap_succeeds
.
unfold
addMono
,
isMonotone
in
*
.
destruct
(
FloverMap
.
find
(
Var
Q
n
)
t
)
eqn
:?
;
simpl
in
*
;
[
congruence
|
].
destruct
(
getValidMap
defVars
e2
(
FloverMap
.
add
(
Var
Q
n
)
M64
t
))
eqn
:?
;
simpl
in
*
;
try
congruence
.
destruct
(
FloverMap
.
find
e2
t0
)
eqn
:?
;
try
congruence
.
assert
(
forall
e
m
,
FloverMap
.
find
e
t
=
Some
m
->
m
=
M64
)
as
valid_t
by
(
eapply
IHe1
with
(
akk
:=
akk
);
eauto
).
assert
(
forall
e
m
,
FloverMap
.
find
e
t0
=
Some
m
->
m
=
M64
)
as
valid_t0
.
{
eapply
IHe2
with
(
akk
:=
(
FloverMap
.
add
(
Var
Q
n
)
M64
t
));
try
eauto
.
intros
.
rewrite
map_find_add
in
H0
.
destruct
(
Q_orderedExps
.
compare
(
Var
Q
n
)
e0
)
eqn
:?
;
[
congruence
|
|
];
eapply
valid_t
;
eauto
.
}
clear
IHe1
IHe2
.
assert
(
m
=
M64
)
by
(
eapply
valid_t0
;
eauto
).
subst
.
destruct
(
FloverMap
.
find
(
Let
M64
n
e1
e2
)
defVars
)
eqn
:?
.
+
destruct
(
mTypeEq
m
M64
)
eqn
:?
;
try
congruence
;
type_conv
;
subst
.
Flover_compute
.
inversion
getMap_succeeds
;
subst
.
find_cases
;
try
(
eapply
valid_t0
;
now
eauto
).
congruence
.
+
Flover_compute
.
inversion
getMap_succeeds
;
subst
.
find_cases
;
try
(
eapply
valid_t0
;
now
eauto
).
congruence
.
Qed
.
(
*
Lemma
getValidMapCmd_preserving
f
:
forall
defVars
akk
res
,
(
forall
e
m
,
FloverMap
.
find
e
akk
=
Some
m
->
m
=
M64
)
->
...
...
@@ -644,6 +583,7 @@ Proof.
destruct
(
mTypeEq
M64
m1
)
eqn
:?
;
congruence
.
-
eapply
getValidMap_preserving
with
(
akk
:=
akk
);
eauto
.
Qed
.
*
)
Lemma
validValue_bounded
v
delta
:
(
Normal
v
M64
\
/
(
v
=
0
)
%
R
)
->
...
...
@@ -769,24 +709,10 @@ Lemma eval_expr_gives_IEEE (e:expr fl64) :
validTypes
(
B2Qexpr
e
)
Gamma
->
approxEnv
E1
(
toRExpMap
Gamma
)
A
fVars
dVars
E2_real
->
validRanges
(
B2Qexpr
e
)
A
E1
(
toRTMap
(
toRExpMap
Gamma
))
->
(
*
<<<<<<<
HEAD
validErrorBoundsRec
(
B2Qexpr
e
)
E1
E2_real
A
Gamma
IeeeDeltaMap
->
validFPRanges
(
B2Qexpr
e
)
E2_real
Gamma
A
->
eval_expr
(
toREnv
E2
)
(
toRExpMap
Gamma
)
IeeeDeltaMap
(
toRExp
(
B2Qexpr
e
))
vR
M64
->
NatSet
.
Subset
((
usedVars
(
B2Qexpr
e
))
--
dVars
)
fVars
->
|||||||
merged
common
ancestors
validErrorBounds
(
B2Qexpr
e
)
E1
E2_real
A
Gamma
DeltaMap
->
FPRangeValidator
(
B2Qexpr
e
)
A
Gamma
dVars
=
true
->
eval_expr
(
toREnv
E2
)
(
toRExpMap
Gamma
)
DeltaMap
(
toRExp
(
B2Qexpr
e
))
vR
M64
->
NatSet
.
Subset
((
usedVars
(
B2Qexpr
e
))
--
dVars
)
fVars
->
=======
validErrorBounds
(
B2Qexpr
e
)
E1
E2_real
A
Gamma
DeltaMap
->
FPRangeValidator
(
B2Qexpr
e
)
A
Gamma
dVars
=
true
->
eval_expr
(
toREnv
E2
)
(
toRExpMap
Gamma
)
DeltaMap
(
toRExp
(
B2Qexpr
e
))
vR
M64
->
NatSet
.
Subset
((
freeVars
(
B2Qexpr
e
))
--
dVars
)
fVars
->
>>>>>>>
exprMerge
*
)
is64BitEval
(
B2Qexpr
e
)
->
is64BitEnv
Gamma
->
noDowncast
(
B2Qexpr
e
)
->
...
...
@@ -799,8 +725,7 @@ Lemma eval_expr_gives_IEEE (e:expr fl64) :
exists
(
v
:
binary_float
53
1024
),
eval_expr_float
e
E2
=
Some
v
/
\
is_finite
53
1024
v
=
true
/
\
(
B2R
53
1024
v
=
vR
).
(
*
/
\
*
)
(
*
eval_expr
(
toREnv
E2
)
(
toRExpMap
Gamma
)
IeeeDeltaMap
(
toRExp
(
B2Qexpr
e
))
(
Q2R
(
B2Q
v
))
M64
*
)
(
B2R
53
1024
v
=
vR
).
Proof
.
Opaque
validTypes
mTypeToQ
mTypeToR
.
induction
e
;
simpl
in
*
;
...
...
@@ -813,10 +738,8 @@ Proof.
Flover_compute_asm
;
try
congruence
;
type_conv
;
subst
;
unfold
optionBind
;
intros
eval_IEEE_valid_e
.
(
*
<<<<<<<
HEAD
Transparent
validTypes
.
all:
validTypes_split
.
all:
try
validTypes_split
.
-
unfold
toREnv
in
*
.
destruct
(
E2
n
)
eqn
:
HE2
;
try
congruence
.
exists
f
;
split
;
try
eauto
.
...
...
@@ -828,16 +751,18 @@ Proof.
inversion
H1
;
subst
.
unfold
toREnv
;
auto
.
}
split
;
[
auto
|
].
rewrite
B2Q_B2R_eq
;
auto
.
-
destruct
(
is_finite
53
1024
v
)
eqn
:
v_finite
;
try
contradiction
.
-
destruct
(
is_finite
53
1024
v
)
eqn
:
v_finite
;
[
|
contradiction
]
.
rewrite
B2Q_B2R_eq
in
*
;
auto
.