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
1186f241
Commit
1186f241
authored
Feb 13, 2019
by
Joachim Bard
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
making IEEE_connection compile
parent
bc7e855e
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
with
111 additions
and
14 deletions
+111
-14
coq/FPRangeValidator.v
coq/FPRangeValidator.v
+2
-2
coq/IEEE_connection.v
coq/IEEE_connection.v
+109
-12
No files found.
coq/FPRangeValidator.v
View file @
1186f241
...
...
@@ -153,7 +153,7 @@ Proof.
prove_fprangeval
m
v
L1
R
.
-
inversion
H1
;
subst
.
destruct
H2
as
[
mE
[
find_mE
[[
validt_e1
[
validt_e2
[
m_e2
[
find_e1
[
find_var
[
find_m2
join_valid
]]]]]]
_
]]].
assert
(
m_e2
=
m
)
by
(
eapply
validTypes_exec
in
find_m2
;
eauto
).
assert
(
m_e2
=
m
2
)
by
(
eapply
validTypes_exec
in
find_m2
;
eauto
).
subst
.
Flover_compute
;
try
congruence
.
prove_fprangeval
m
v
L1
R
.
...
...
@@ -273,5 +273,5 @@ Proof.
rewrite
NatSet
.
add_spec
in
H5
;
destruct
H5
;
auto
;
subst
;
congruence
.
}
-
destruct
H5
.
destruct
H4
.
destruct
H6
.
eapply
FPRangeValidator_sound
;
eauto
.
A
dmitted
.
A
bort
.
*
)
coq/IEEE_connection.v
View file @
1186f241
...
...
@@ -5,7 +5,7 @@ From Coq
From
Flover
Require
Import
Expressions
Infra
.
RationalSimps
TypeValidator
IntervalValidation
ErrorAnalysis
CertificateChecker
FPRangeValidator
RoundoffErrorValidator
Environments
Infra
.
RealRationalProps
Commands
Infra
.
Ltacs
.
Environments
Infra
.
RealRationalProps
Infra
.
Ltacs
.
From
Flocq
Require
Import
Appli
.
Fappli_IEEE_bits
Appli
.
Fappli_IEEE
Core
.
Fcore_Raux
...
...
@@ -48,9 +48,13 @@ Fixpoint eval_expr_float (e:expr (binary_float 53 1024)) (E:nat -> option fl64):
(
*
|
Some
f1
,
Some
f2
,
Some
f3
=>
Some
(
b64_plus
dmode
f1
(
b64_mult
dmode
f2
f3
))
*
)
|
_
,
_
,
_
=>
None
end
|
Let
m
x
e1
e2
=>
olet
res
:=
eval_expr_float
e1
E
in
eval_expr_float
e2
(
updFlEnv
x
res
E
)
|
_
=>
None
end
.
(
*
Fixpoint
bstep_float
f
E
:
option
fl64
:=
match
f
with
|
Let
m
x
e
g
=>
...
...
@@ -58,6 +62,7 @@ Fixpoint bstep_float f E :option fl64 :=
bstep_float
g
(
updFlEnv
x
res
E
)
|
Ret
e
=>
eval_expr_float
e
E
end
.
*
)
Definition
isValid
e
:=
plet
v
:=
e
in
...
...
@@ -102,8 +107,15 @@ Fixpoint eval_expr_valid (e:expr fl64) E :=
True
)
True
)
|
Downcast
m
e
=>
eval_expr_valid
e
E
|
Let
m
x
e1
e2
=>
eval_expr_valid
e1
E
/
\
(
optionBind
(
eval_expr_float
e1
E
)
(
fun
v_e
=>
eval_expr_valid
e2
(
updFlEnv
x
v_e
E
))
True
)
|
Cond
e1
e2
e3
=>
False
end
.
(
*
Fixpoint
bstep_valid
f
E
:=
match
f
with
|
Let
m
x
e
g
=>
...
...
@@ -113,6 +125,7 @@ Fixpoint bstep_valid f E :=
True
)
|
Ret
e
=>
eval_expr_valid
e
E
end
.
*
)
Definition
bpowQ
(
r
:
radix
)
(
e
:
Z
)
:=
match
e
with
...
...
@@ -181,13 +194,17 @@ Fixpoint B2Qexpr (e: expr fl64) :=
|
Binop
b
e1
e2
=>
Binop
b
(
B2Qexpr
e1
)
(
B2Qexpr
e2
)
|
Fma
e1
e2
e3
=>
Fma
(
B2Qexpr
e1
)
(
B2Qexpr
e2
)
(
B2Qexpr
e3
)
|
Downcast
m
e
=>
Downcast
m
(
B2Qexpr
e
)
|
Let
m
x
e1
e2
=>
Let
m
x
(
B2Qexpr
e1
)
(
B2Qexpr
e2
)
|
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
toREnv
(
E
:
nat
->
option
fl64
)
(
x
:
nat
)
:
option
R
:=
match
E
x
with
...
...
@@ -208,13 +225,17 @@ Fixpoint is64BitEval (V:Type) (e:expr V) :=
|
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
|
Let
m
x
e
g
=>
is64BitEval
e
/
\
m
=
M64
/
\
is64BitEval
g
|
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
...
...
@@ -224,13 +245,17 @@ Fixpoint noDowncast (V:Type) (e:expr V) :=
|
Binop
b
e1
e2
=>
noDowncast
e1
/
\
noDowncast
e2
|
Fma
e1
e2
e3
=>
noDowncast
e1
/
\
noDowncast
e2
/
\
noDowncast
e3
|
Downcast
m
e
=>
False
|
Let
m
x
e1
e2
=>
noDowncast
e1
/
\
noDowncast
e2
|
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
.
...
...
@@ -297,6 +322,7 @@ Proof.
erewrite
<-
Gamma_64Bit
;
eauto
.
Qed
.
(
*
Lemma
typing_cmd_64_bit
f
:
forall
Gamma
,
is64BitEnv
Gamma
->
...
...
@@ -308,6 +334,7 @@ Proof.
eapply
IHf
;
eauto
.
-
destruct
valid_f
;
simpl
in
*
;
eapply
typing_expr_64_bit
;
eauto
.
Qed
.
*
)
Lemma
round_0_zero
:
(
Fcore_generic_fmt
.
round
radix2
(
Fcore_FLT
.
FLT_exp
(
3
-
1024
-
53
)
53
)
...
...
@@ -410,7 +437,7 @@ Lemma eval_expr_gives_IEEE (e:expr fl64) :
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
((
used
Vars
(
B2Qexpr
e
))
--
dVars
)
fVars
->
NatSet
.
Subset
((
free
Vars
(
B2Qexpr
e
))
--
dVars
)
fVars
->
is64BitEval
(
B2Qexpr
e
)
->
is64BitEnv
Gamma
->
noDowncast
(
B2Qexpr
e
)
->
...
...
@@ -436,6 +463,7 @@ Proof.
unfold
optionBind
;
intros
eval_IEEE_valid_e
.
Transparent
validTypes
.
(
*
all:
validTypes_split
.
-
unfold
toREnv
in
*
.
destruct
(
E2
n
)
eqn
:
HE2
;
try
congruence
.
...
...
@@ -818,8 +846,10 @@ Proof.
rewrite
eval_float_e1
,
eval_float_e2
,
eval_float_e3
in
H7
.
contradiction
H7
.
-
inversion
noDowncast_e
.
*
)
Admitted
.
(
*
Lemma
bstep_gives_IEEE
(
f
:
cmd
fl64
)
:
forall
E1
E2
E2_real
Gamma
DeltaMap
vR
vF
A
fVars
dVars
outVars
,
(
forall
(
e
'
:
expr
R
)
(
m
'
:
mType
),
...
...
@@ -973,7 +1003,8 @@ Proof.
edestruct
(
eval_expr_gives_IEEE
)
as
[
v_res
[
eval_float
eval_e
]];
eauto
.
exists
v_res
;
split
;
try
auto
.
apply
ret_b
;
auto
.
Admitted
.
Abort
.
*
)
Ltac
find_cases
:=
rewrite
map_find_add
;
...
...
@@ -1107,8 +1138,58 @@ Proof.
+
Flover_compute
;
inversion
getMap_succeeds
;
subst
.
find_cases
;
try
(
eapply
IHe
with
(
akk
:=
akk
);
eauto
).
congruence
.
-
unfold
addMono
in
*
.
Flover_compute
.
+
destruct
(
mTypeEq
m
m1
)
eqn
:?
;
try
congruence
.
type_conv
;
subst
.
destruct
is64Bit_e
as
(
?
&
?
&
?
);
subst
.
eapply
IHe2
with
(
akk
:=
t0
);
eauto
.
inversion
Heqr0
;
subst
.
intros
*
.
find_cases
;
try
(
eapply
IHe1
with
(
akk
:=
akk
);
now
eauto
).
congruence
.
+
destruct
is64Bit_e
as
(
?
&
?
&
?
);
subst
.
destruct
(
mTypeEq
M64
m1
)
eqn
:?
;
congruence
.
-
destruct
(
getValidMap
defVars
e1
akk
)
eqn
:?
;
simpl
in
*
;
try
congruence
.
destruct
(
getValidMap
defVars
e2
t
)
eqn
:?
;
simpl
in
*
;
try
congruence
.
destruct
(
getValidMap
defVars
e3
t0
)
eqn
:?
;
simpl
in
*
;
try
congruence
.
destruct
(
FloverMap
.
find
e1
t1
)
eqn
:?
;
try
congruence
.
destruct
(
FloverMap
.
find
e2
t1
)
eqn
:?
;
try
congruence
.
destruct
(
FloverMap
.
find
e3
t1
)
eqn
:?
;
try
congruence
.
destruct
is64Bit_e
as
(
?
&
?
&
?
).
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
by
(
eapply
IHe2
with
(
akk
:=
t
);
eauto
).
assert
(
forall
e
m
,
FloverMap
.
find
e
t1
=
Some
m
->
m
=
M64
)
as
valid_t1
by
(
eapply
IHe3
with
(
akk
:=
t0
);
eauto
).
clear
IHe1
IHe2
IHe3
.
assert
(
m0
=
M64
/
\
m1
=
M64
/
\
m2
=
M64
)
as
(
?
&
?
&
?
)
by
(
repeat
split
;
eapply
valid_t1
;
eauto
).
subst
;
cbn
in
*
.
unfold
isMonotone
,
addMono
in
*
.
destruct
(
FloverMap
.
find
(
Cond
e1
e2
e3
)
defVars
)
eqn
:?
.
+
destruct
(
mTypeEq
m0
M64
)
eqn
:?
;
try
congruence
;
type_conv
;
subst
.
Flover_compute
.
inversion
getMap_succeeds
;
subst
.
find_cases
;
try
(
eapply
valid_t1
;
now
eauto
).
congruence
.
+
Flover_compute
.
inversion
getMap_succeeds
;
subst
.
find_cases
;
try
(
eapply
valid_t1
;
now
eauto
).
congruence
.
Qed
.
(
*
Lemma
getValidMapCmd_preserving
f
:
forall
defVars
akk
res
,
(
forall
e
m
,
FloverMap
.
find
e
akk
=
Some
m
->
m
=
M64
)
->
...
...
@@ -1131,6 +1212,7 @@ Proof.
destruct
(
mTypeEq
M64
m1
)
eqn
:?
;
congruence
.
-
eapply
getValidMap_preserving
with
(
akk
:=
akk
);
eauto
.
Qed
.
*
)
Theorem
IEEE_connection_expr
e
A
P
qMap
E1
E2
defVars
DeltaMap
:
(
forall
(
e
'
:
expr
R
)
(
m
'
:
mType
),
...
...
@@ -1143,7 +1225,7 @@ Theorem IEEE_connection_expr e A P qMap E1 E2 defVars DeltaMap:
eval_precond
E1
P
->
CertificateChecker
(
B2Qexpr
e
)
A
P
qMap
defVars
=
true
->
exists
Gamma
,
(
*
m
,
currently
=
M64
*
)
approxEnv
E1
Gamma
A
(
used
Vars
(
B2Qexpr
e
))
(
NatSet
.
empty
)
(
toREnv
E2
)
->
approxEnv
E1
Gamma
A
(
free
Vars
(
B2Qexpr
e
))
(
NatSet
.
empty
)
(
toREnv
E2
)
->
exists
iv
err
vR
vF
,
FloverMap
.
find
(
B2Qexpr
e
)
A
=
Some
(
iv
,
err
)
/
\
eval_expr
E1
(
toRTMap
Gamma
)
DeltaMapR
(
toREval
(
toRExp
(
B2Qexpr
e
)))
vR
REAL
/
\
...
...
@@ -1163,31 +1245,44 @@ Proof.
assert
(
validTypes
(
B2Qexpr
e
)
Gamma
).
{
eapply
getValidMap_top_correct
;
eauto
.
intros
.
cbn
in
*
;
congruence
.
}
rewrite
<-
andb_lazy_alt
in
certificate_valid
.
(
*
rewrite
<-
andb_lazy_alt
in
certificate_valid
.
*
)
andb_to_prop
certificate_valid
.
pose
proof
(
NatSetProps
.
empty_union_2
(
Expressions
.
used
Vars
e
)
NatSet
.
empty_spec
)
as
union_empty
.
pose
proof
(
NatSetProps
.
empty_union_2
(
free
Vars
e
)
NatSet
.
empty_spec
)
as
union_empty
.
hnf
in
union_empty
.
assert
(
dVars_range_valid
NatSet
.
empty
E1
A
).
{
unfold
dVars_range_valid
.
intros
;
set_tac
.
}
(
*
assert
(
AffineValidation
.
affine_dVars_range_valid
NatSet
.
empty
E1
A
1
(
FloverMap
.
empty
_
)
(
fun
_
=>
None
))
as
affine_dvars_valid
.
{
unfold
AffineValidation
.
affine_dVars_range_valid
.
intros
;
set_tac
.
}
assert
(
NatSet
.
Subset
(
usedVars
(
B2Qexpr
e
)
--
NatSet
.
empty
)
(
Expressions
.
usedVars
(
B2Qexpr
e
))).
*
)
assert
(
NatSet
.
Subset
(
freeVars
(
B2Qexpr
e
)
--
NatSet
.
empty
)
(
freeVars
(
B2Qexpr
e
))).
{
hnf
;
intros
a
in_empty
.
set_tac
.
}
pose
proof
(
validSSA_checks_freeVars
_
_
L
)
as
sub
.
rename
R0
into
validFPRanges
.
destruct
(
validSSA_sound
(
B2Qexpr
e
)
(
preVars
P
))
as
[
outVars
ssa_e
];
auto
.
assert
(
validSSA
(
B2Qexpr
e
)
(
freeVars
(
B2Qexpr
e
))
=
true
)
as
ssa_valid
by
(
eapply
validSSA_downward_closed
;
eauto
using
NatSetProps
.
subset_refl
).
destruct
(
validSSA_sound
(
B2Qexpr
e
)
(
freeVars
(
B2Qexpr
e
)))
as
[
outVars2
ssa_e2
];
auto
.
assert
(
validRanges
(
B2Qexpr
e
)
A
E1
(
toRTMap
(
toRExpMap
Gamma
)))
as
valid_e
.
{
eapply
(
RealRangeValidator
.
RangeValidator_sound
(
B2Qexpr
e
)
(
dVars
:=
NatSet
.
empty
)
(
A
:=
A
)
(
P
:=
P
)
(
Qmap
:=
qMap
));
auto
.
}
{
eapply
(
RealRangeValidator
.
RangeValidator_sound
(
dVars
:=
NatSet
.
empty
)
(
A
:=
A
)
(
P
:=
P
)
(
fVars
:=
preVars
P
)
(
Qmap
:=
qMap
));
eauto
using
NatSetProps
.
subset_refl
;
set_tac
.
clear
ssa_e2
.
eapply
ssa_equal_set
;
eauto
.
intros
n
.
split
;
set_tac
.
intros
[
?|?
];
auto
.
set_tac
.
}
pose
proof
(
validRanges_single
_
_
_
_
valid_e
)
as
valid_single
;
destruct
valid_single
as
[
iv_e
[
err_e
[
vR
[
map_e
[
eval_real
real_bounds_e
]]]]].
destruct
iv_e
as
[
elo
ehi
].
exists
(
toRExpMap
Gamma
);
intros
approxE1E2
.
pose
proof
RoundoffErrorValidator_sound
as
Hsound
.
eapply
validErrorBounds_single
in
Hsound
;
eauto
.
2
:
intros
v
'
Hin
;
set_tac
.
assert
(
ssa
(
B2Qexpr
e
)
(
freeVars
(
B2Qexpr
e
)
∪
NatSet
.
empty
)
outVars2
).
{
eapply
ssa_equal_set
;
eauto
.
split
;
set_tac
.
intros
[
?|?
];
auto
.
set_tac
.
}
eapply
validErrorBounds_single
in
Hsound
;
try
exact
approxE1E2
;
eauto
.
(
*
2
:
intros
v
'
Hin
;
set_tac
.
*
)
specialize
Hsound
as
((
v__FP
&
m__FP
&
Hbstepex
)
&
Hsound
).
assert
(
FloverMap
.
find
(
B2Qexpr
e
)
Gamma
=
Some
M64
).
{
eapply
typing_expr_64_bit
;
eauto
.
}
...
...
@@ -1195,12 +1290,13 @@ Proof.
{
eapply
validTypes_exec
;
try
exact
Hbstepex
;
eauto
.
}
subst
.
edestruct
eval_expr_gives_IEEE
;
eauto
.
-
eapply
RoundoffErrorValidator_sound
;
eauto
.
intros
?
?
;
set_tac
.
-
eapply
RoundoffErrorValidator_sound
;
try
exact
approxE1E2
;
eauto
.
-
intros
?
?
;
set_tac
.
-
exists
(
elo
,
ehi
),
err_e
,
vR
,
x
.
intuition
.
eapply
Hsound
;
eauto
.
Qed
.
(
*
Theorem
IEEE_connection_cmd
(
f
:
cmd
fl64
)
(
A
:
analysisResult
)
P
qMap
defVars
E1
E2
DeltaMap
:
(
forall
(
e
'
:
expr
R
)
(
m
'
:
mType
),
...
...
@@ -1278,3 +1374,4 @@ Proof.
-
exists
(
f_lo
,
f_hi
),
err
,
vR
,
x
,
M64
.
intuition
.
Qed
.
*
)
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment