Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
AVA
FloVer
Commits
98d9efcf
Commit
98d9efcf
authored
Mar 21, 2017
by
Heiko Becker
Browse files
Merge branch 'master' into 'certificates'
Finish porting proofs to new semantics See merge request !86
parents
f759880f
1147fdb5
Changes
34
Expand all
Hide whitespace changes
Inline
Side-by-side
.gitignore
View file @
98d9efcf
...
...
@@ -29,6 +29,7 @@ hol4/*/*.uo
hol4/*/.*
hol4/heap
hol4/output/heap
hol4/output/certificate_*
daisy
rawdata/*
.ensime*
...
...
.gitmodules
0 → 100644
View file @
98d9efcf
[submodule "hol4/cakeml"]
branch = daisy
path = hol4/cakeml
url = https://github.com/CakeML/cakeml.git
coq/CertificateChecker.v
View file @
98d9efcf
...
...
@@ -9,7 +9,7 @@ Require Import Daisy.Infra.RealSimps Daisy.Infra.RationalSimps Daisy.Infra.RealR
Require
Import
Daisy
.
IntervalValidation
Daisy
.
ErrorValidation
Daisy
.
Environments
.
Require
Export
Coq
.
QArith
.
QArith
.
Require
Export
Daisy
.
Infra
.
ExpressionAbbrevs
.
Require
Export
Daisy
.
Infra
.
ExpressionAbbrevs
Daisy
.
Commands
.
(
**
Certificate
checking
function
**
)
Definition
CertificateChecker
(
e
:
exp
Q
)
(
absenv
:
analysisResult
)
(
P
:
precond
)
:=
...
...
@@ -104,4 +104,4 @@ Proof.
-
intros
v
v_in_empty
.
rewrite
NatSet
.
mem_spec
in
v_in_empty
.
inversion
v_in_empty
.
Qed
.
\ No newline at end of file
Qed
.
coq/Commands.v
View file @
98d9efcf
...
...
@@ -43,4 +43,14 @@ Fixpoint definedVars V (f:cmd V) :NatSet.t :=
match
f
with
|
Let
x
_
g
=>
NatSet
.
add
x
(
definedVars
g
)
|
Ret
_
=>
NatSet
.
empty
end
.
(
**
The
live
variables
of
a
command
are
all
variables
which
occur
on
the
right
hand
side
of
an
assignment
or
at
a
return
statement
**
)
Fixpoint
liveVars
V
(
f
:
cmd
V
)
:
NatSet
.
t
:=
match
f
with
|
Let
_
e
g
=>
NatSet
.
union
(
usedVars
e
)
(
liveVars
g
)
|
Ret
e
=>
usedVars
e
end
.
\ No newline at end of file
coq/ErrorBounds.v
View file @
98d9efcf
...
...
@@ -60,21 +60,21 @@ Proof.
rewrite
(
delta_0_deterministic
(
evalBinop
Plus
v1
v2
)
delta
);
auto
.
unfold
evalBinop
in
*
;
simpl
in
*
.
clear
delta
H2
.
rewrite
(
meps_0_deterministic
H
4
e1_real
);
rewrite
(
meps_0_deterministic
H
3
e1_real
);
rewrite
(
meps_0_deterministic
H5
e2_real
).
rewrite
(
meps_0_deterministic
H
4
e1_real
)
in
plus_real
.
rewrite
(
meps_0_deterministic
H
3
e1_real
)
in
plus_real
.
rewrite
(
meps_0_deterministic
H5
e2_real
)
in
plus_real
.
clear
H
4
H5
v1
v2
.
clear
H
3
H5
H6
v1
v2
.
(
*
Now
unfold
the
float
valued
evaluation
to
get
the
deltas
we
need
for
the
inequality
*
)
inversion
plus_float
;
subst
.
unfold
perturb
;
simpl
.
inversion
H
4
;
subst
;
inversion
H5
;
subst
.
inversion
H
3
;
subst
;
inversion
H5
;
subst
.
unfold
updEnv
;
simpl
.
unfold
updEnv
in
H0
,
H1
;
simpl
in
*
.
symmetry
in
H0
,
H1
.
inversion
H0
;
inversion
H1
;
subst
.
(
*
We
have
now
obtained
all
necessary
values
from
the
evaluations
-->
remove
them
for
readability
*
)
clear
plus_float
H
4
H5
plus_real
e1_real
e1_float
e2_real
e2_float
H0
H1
.
clear
plus_float
H
3
H5
plus_real
e1_real
e1_float
e2_real
e2_float
H0
H1
.
repeat
rewrite
Rmult_plus_distr_l
.
rewrite
Rmult_1_r
.
rewrite
Rsub_eq_Ropp_Rplus
.
...
...
@@ -123,21 +123,21 @@ Proof.
rewrite
delta_0_deterministic
;
auto
.
unfold
evalBinop
in
*
;
simpl
in
*
.
clear
delta
H2
.
rewrite
(
meps_0_deterministic
H
4
e1_real
);
rewrite
(
meps_0_deterministic
H
3
e1_real
);
rewrite
(
meps_0_deterministic
H5
e2_real
).
rewrite
(
meps_0_deterministic
H
4
e1_real
)
in
sub_real
.
rewrite
(
meps_0_deterministic
H
3
e1_real
)
in
sub_real
.
rewrite
(
meps_0_deterministic
H5
e2_real
)
in
sub_real
.
clear
H
4
H5
v1
v2
.
clear
H
3
H5
H6
v1
v2
.
(
*
Now
unfold
the
float
valued
evaluation
to
get
the
deltas
we
need
for
the
inequality
*
)
inversion
sub_float
;
subst
.
unfold
perturb
;
simpl
.
inversion
H
4
;
subst
;
inversion
H5
;
subst
.
inversion
H
3
;
subst
;
inversion
H5
;
subst
.
unfold
updEnv
;
simpl
.
symmetry
in
H0
,
H1
.
unfold
updEnv
in
H0
,
H1
;
simpl
in
H0
,
H1
.
inversion
H0
;
inversion
H1
;
subst
.
(
*
We
have
now
obtained
all
necessary
values
from
the
evaluations
-->
remove
them
for
readability
*
)
clear
sub_float
H
4
H5
sub_real
e1_real
e1_float
e2_real
e2_float
H0
H1
.
clear
sub_float
H
3
H5
sub_real
e1_real
e1_float
e2_real
e2_float
H0
H1
.
repeat
rewrite
Rmult_plus_distr_l
.
rewrite
Rmult_1_r
.
repeat
rewrite
Rsub_eq_Ropp_Rplus
.
...
...
@@ -177,20 +177,20 @@ Proof.
rewrite
delta_0_deterministic
;
auto
.
unfold
evalBinop
in
*
;
simpl
in
*
.
clear
delta
H2
.
rewrite
(
meps_0_deterministic
H
4
e1_real
);
rewrite
(
meps_0_deterministic
H
3
e1_real
);
rewrite
(
meps_0_deterministic
H5
e2_real
).
rewrite
(
meps_0_deterministic
H
4
e1_real
)
in
mult_real
.
rewrite
(
meps_0_deterministic
H
3
e1_real
)
in
mult_real
.
rewrite
(
meps_0_deterministic
H5
e2_real
)
in
mult_real
.
clear
H
4
H5
v1
v2
.
clear
H
3
H5
H6
v1
v2
.
(
*
Now
unfold
the
float
valued
evaluation
to
get
the
deltas
we
need
for
the
inequality
*
)
inversion
mult_float
;
subst
.
unfold
perturb
;
simpl
.
inversion
H
4
;
subst
;
inversion
H5
;
subst
.
inversion
H
3
;
subst
;
inversion
H5
;
subst
.
symmetry
in
H0
,
H1
;
unfold
updEnv
in
*
;
simpl
in
*
.
inversion
H0
;
inversion
H1
;
subst
.
(
*
We
have
now
obtained
all
necessary
values
from
the
evaluations
-->
remove
them
for
readability
*
)
clear
mult_float
H
4
H5
mult_real
e1_real
e1_float
e2_real
e2_float
H0
H1
.
clear
mult_float
H
3
H5
mult_real
e1_real
e1_float
e2_real
e2_float
H0
H1
.
repeat
rewrite
Rmult_plus_distr_l
.
rewrite
Rmult_1_r
.
rewrite
Rsub_eq_Ropp_Rplus
.
...
...
@@ -224,20 +224,20 @@ Proof.
rewrite
delta_0_deterministic
;
auto
.
unfold
evalBinop
in
*
;
simpl
in
*
.
clear
delta
H2
.
rewrite
(
meps_0_deterministic
H
4
e1_real
);
rewrite
(
meps_0_deterministic
H
3
e1_real
);
rewrite
(
meps_0_deterministic
H5
e2_real
).
rewrite
(
meps_0_deterministic
H
4
e1_real
)
in
div_real
.
rewrite
(
meps_0_deterministic
H
3
e1_real
)
in
div_real
.
rewrite
(
meps_0_deterministic
H5
e2_real
)
in
div_real
.
clear
H
4
H5
v1
v2
.
clear
H
3
H5
H6
v1
v2
.
(
*
Now
unfold
the
float
valued
evaluation
to
get
the
deltas
we
need
for
the
inequality
*
)
inversion
div_float
;
subst
.
unfold
perturb
;
simpl
.
inversion
H
4
;
subst
;
inversion
H5
;
subst
.
inversion
H
3
;
subst
;
inversion
H5
;
subst
.
symmetry
in
H0
,
H1
;
unfold
updEnv
in
*
;
simpl
in
*
.
inversion
H0
;
inversion
H1
;
subst
.
(
*
We
have
now
obtained
all
necessary
values
from
the
evaluations
-->
remove
them
for
readability
*
)
clear
div_float
H
4
H5
div_real
e1_real
e1_float
e2_real
e2_float
H0
H1
.
clear
div_float
H
3
H5
div_real
e1_real
e1_float
e2_real
e2_float
H0
H1
.
repeat
rewrite
Rmult_plus_distr_l
.
rewrite
Rmult_1_r
.
rewrite
Rsub_eq_Ropp_Rplus
.
...
...
coq/ErrorValidation.v
View file @
98d9efcf
...
...
@@ -23,7 +23,11 @@ Fixpoint validErrorbound (e:exp Q) (absenv:analysisResult) (dVars:NatSet.t):=
else
(
Qleb
(
maxAbs
intv
*
RationalSimps
.
machineEpsilon
)
err
)
|
Const
n
=>
Qleb
(
maxAbs
intv
*
RationalSimps
.
machineEpsilon
)
err
|
Unop
_
_
=>
false
|
Unop
Neg
e
=>
if
(
validErrorbound
e
absenv
dVars
)
then
Qeq_bool
err
(
snd
(
absenv
e
))
else
false
|
Unop
Inv
e
=>
false
|
Binop
b
e1
e2
=>
if
((
validErrorbound
e1
absenv
dVars
)
&&
(
validErrorbound
e2
absenv
dVars
))
then
...
...
@@ -80,7 +84,9 @@ Proof.
andb_to_prop
validErrorbound_e
.
-
apply
Qle_bool_iff
in
L
;
apply
Qle_Rle
in
L
;
rewrite
Q2R0_is_0
in
L
;
auto
.
-
apply
Qle_bool_iff
in
L
;
apply
Qle_Rle
in
L
;
rewrite
Q2R0_is_0
in
L
;
auto
.
-
inversion
R
.
-
destruct
u
;
simpl
in
*
;
try
congruence
.
andb_to_prop
R
.
apply
Qle_bool_iff
in
L
;
apply
Qle_Rle
in
L
;
rewrite
Q2R0_is_0
in
L
;
auto
.
-
apply
Qle_bool_iff
in
L
;
apply
Qle_Rle
in
L
;
rewrite
Q2R0_is_0
in
L
;
auto
.
Qed
.
...
...
@@ -1961,7 +1967,26 @@ Proof.
-
unfold
validErrorbound
in
valid_error
.
rewrite
absenv_eq
in
valid_error
.
andb_to_prop
valid_error
.
inversion
R
.
destruct
u
;
try
congruence
.
env_assert
absenv
e
absenv_e
.
destruct
absenv_e
as
[
iv
[
err_e
absenv_e
]].
rename
R
into
valid_error
.
andb_to_prop
valid_error
.
apply
Qeq_bool_iff
in
R
.
apply
Qeq_eqR
in
R
.
rewrite
R
.
destruct
iv
as
[
e_lo
e_hi
].
inversion
eval_real
;
subst
.
inversion
eval_float
;
subst
.
unfold
evalUnop
.
apply
bound_flip_sub
.
eapply
IHe
;
eauto
.
simpl
in
valid_intv
.
rewrite
absenv_eq
in
valid_intv
;
andb_to_prop
valid_intv
.
auto
.
instantiate
(
1
:=
e_hi
).
instantiate
(
1
:=
e_lo
).
rewrite
absenv_e
;
auto
.
-
pose
proof
(
ivbounds_approximatesPrecond_sound
(
Binop
b
e1
e2
)
absenv
P
valid_intv
)
as
env_approx_p
.
simpl
in
valid_error
.
env_assert
absenv
e1
absenv_e1
.
...
...
@@ -2079,36 +2104,6 @@ Proof.
-
andb_to_prop
R1
;
auto
.
}
Qed
.
Lemma
validErrorbound_subset
e
absenv
dVars
dVars
'
:
validErrorbound
e
absenv
dVars
=
true
->
NatSet
.
Subset
dVars
dVars
'
->
validErrorbound
e
absenv
dVars
'
=
true
.
Proof
.
induction
e
;
intros
validBound_e_dV
subset_dV
;
simpl
in
*
;
try
auto
.
-
destruct
(
absenv
(
Var
Q
n
));
simpl
in
*
.
andb_to_prop
validBound_e_dV
.
apply
Is_true_eq_true
;
apply
andb_prop_intro
;
split
.
+
apply
Is_true_eq_left
in
L
;
auto
.
+
case_eq
(
NatSet
.
mem
n
dVars
);
intros
case_mem
;
rewrite
case_mem
in
*
;
simpl
in
*
.
*
hnf
in
subset_dV
.
rewrite
NatSet
.
mem_spec
in
case_mem
.
specialize
(
subset_dV
n
case_mem
).
rewrite
<-
NatSet
.
mem_spec
in
subset_dV
.
rewrite
subset_dV
.
apply
Is_true_eq_left
;
auto
.
*
case_eq
(
NatSet
.
mem
n
dVars
'
);
intros
case_mem
'
;
apply
Is_true_eq_left
;
auto
.
-
destruct
(
absenv
(
Binop
b
e1
e2
));
simpl
in
*
.
rewrite
<-
andb_lazy_alt
in
*
.
andb_to_prop
validBound_e_dV
.
rewrite
andb_true_iff
;
split
;
try
auto
.
destruct
(
absenv
e1
);
destruct
(
absenv
e2
).
rewrite
<-
andb_lazy_alt
.
rewrite
andb_true_iff
;
split
;
try
auto
.
repeat
(
rewrite
andb_true_iff
;
split
);
auto
.
Qed
.
Theorem
validErrorboundCmd_sound
(
f
:
cmd
Q
)
(
absenv
:
analysisResult
)
:
forall
E1
E2
outVars
fVars
dVars
vR
vF
elo
ehi
err
P
,
approxEnv
E1
absenv
fVars
dVars
E2
->
...
...
coq/Expressions.v
View file @
98d9efcf
(
**
Formalization
of
the
base
expression
language
for
the
daisy
framework
**
)
...
...
@@ -120,6 +121,7 @@ Inductive eval_exp (eps:R) (E:env) :(exp R) -> R -> Prop :=
Rle
(
Rabs
delta
)
eps
->
eval_exp
eps
E
f1
v1
->
eval_exp
eps
E
f2
v2
->
((
op
=
Div
)
->
(
~
v2
=
0
)
%
R
)
->
eval_exp
eps
E
(
Binop
op
f1
f2
)
(
perturb
(
evalBinop
op
v1
v2
)
delta
).
(
**
...
...
coq/IntervalValidation.v
View file @
98d9efcf
...
...
@@ -137,32 +137,6 @@ Qed.
Ltac
env_assert
absenv
e
name
:=
assert
(
exists
iv
err
,
absenv
e
=
(
iv
,
err
))
as
name
by
(
destruct
(
absenv
e
);
repeat
eexists
;
auto
).
Lemma
validBoundsDiv_uneq_zero
e1
e2
absenv
P
V
ivlo_e2
ivhi_e2
err
:
absenv
e2
=
((
ivlo_e2
,
ivhi_e2
),
err
)
->
validIntervalbounds
(
Binop
Div
e1
e2
)
absenv
P
V
=
true
->
(
ivhi_e2
<
0
)
\
/
(
0
<
ivlo_e2
).
Proof
.
intros
absenv_eq
validBounds
.
unfold
validIntervalbounds
in
validBounds
.
env_assert
absenv
(
Binop
Div
e1
e2
)
abs_div
;
destruct
abs_div
as
[
iv_div
[
err_div
abs_div
]].
env_assert
absenv
e1
abs_e1
;
destruct
abs_e1
as
[
iv_e1
[
err_e1
abs_e1
]].
rewrite
abs_div
,
abs_e1
,
absenv_eq
in
validBounds
.
repeat
(
rewrite
<-
andb_lazy_alt
in
validBounds
).
apply
Is_true_eq_left
in
validBounds
.
apply
andb_prop_elim
in
validBounds
.
destruct
validBounds
as
[
_
validBounds
];
apply
andb_prop_elim
in
validBounds
.
destruct
validBounds
as
[
nodiv0
_
].
apply
Is_true_eq_true
in
nodiv0
.
unfold
isSupersetIntv
in
*
;
simpl
in
*
.
apply
le_neq_bool_to_lt_prop
;
auto
.
Qed
.
Fixpoint
getRetExp
(
V
:
Type
)
(
f
:
cmd
V
)
:=
match
f
with
|
Let
x
e
g
=>
getRetExp
g
|
Ret
e
=>
e
end
.
Theorem
validIntervalbounds_sound
(
f
:
exp
Q
)
(
absenv
:
analysisResult
)
(
P
:
precond
)
fVars
dVars
E
:
forall
vR
,
validIntervalbounds
f
absenv
P
dVars
=
true
->
...
...
@@ -490,6 +464,12 @@ Proof.
rewrite
<-
Q2R_max4
in
valid_div_hi
;
auto
.
}
}
Qed
.
Fixpoint
getRetExp
(
V
:
Type
)
(
f
:
cmd
V
)
:=
match
f
with
|
Let
x
e
g
=>
getRetExp
g
|
Ret
e
=>
e
end
.
Theorem
validIntervalboundsCmd_sound
(
f
:
cmd
Q
)
(
absenv
:
analysisResult
)
:
forall
E
vR
fVars
dVars
outVars
elo
ehi
err
P
,
ssa
f
(
NatSet
.
union
fVars
dVars
)
outVars
->
...
...
@@ -502,7 +482,7 @@ Theorem validIntervalboundsCmd_sound (f:cmd Q) (absenv:analysisResult):
exists
vR
,
E
v
=
Some
vR
/
\
(
Q2R
(
fst
(
P
v
))
<=
vR
<=
Q2R
(
snd
(
P
v
)))
%
R
)
->
NatSet
.
Subset
(
NatSet
.
diff
(
Commands
.
freeVars
f
)
dVars
)
fVars
->
NatSet
.
Subset
(
NatSet
.
diff
(
freeVars
f
)
dVars
)
fVars
->
validIntervalboundsCmd
f
absenv
P
dVars
=
true
->
absenv
(
getRetExp
f
)
=
((
elo
,
ehi
),
err
)
->
(
Q2R
elo
<=
vR
<=
Q2R
ehi
)
%
R
.
...
...
coq/ssaPrgs.v
View file @
98d9efcf
...
...
@@ -37,6 +37,7 @@ Proof.
rewrite
NatSet
.
union_spec
;
auto
.
Qed
.
(
*
Lemma
validVars_non_stuck
(
e
:
exp
Q
)
inVars
E
:
NatSet
.
Subset
(
usedVars
e
)
inVars
->
(
forall
v
,
NatSet
.
In
v
(
usedVars
e
)
->
...
...
@@ -80,7 +81,7 @@ Proof.
destruct
eval_e2_def
as
[
vR2
eval_e2_def
].
exists
(
perturb
(
evalBinop
b
vR1
vR2
)
0
);
constructor
;
auto
.
rewrite
Rabs_R0
;
lra
.
Qed
.
Qed
.
*
)
Inductive
ssa
(
V
:
Type
)
:
(
cmd
V
)
->
(
NatSet
.
t
)
->
(
NatSet
.
t
)
->
Prop
:=
ssaLet
x
e
s
inVars
Vterm
:
...
...
@@ -95,7 +96,7 @@ Inductive ssa (V:Type): (cmd V) -> (NatSet.t) -> (NatSet.t) -> Prop :=
Lemma
ssa_subset_freeVars
V
(
f
:
cmd
V
)
inVars
outVars
:
ssa
f
inVars
outVars
->
NatSet
.
Subset
(
Commands
.
freeVars
f
)
inVars
.
NatSet
.
Subset
(
freeVars
f
)
inVars
.
Proof
.
intros
ssa_f
;
induction
ssa_f
.
-
simpl
in
*
.
hnf
;
intros
a
in_fVars
.
...
...
@@ -392,17 +393,135 @@ Qed.
Fixpoint
let_subst
(
f
:
cmd
Q
)
:=
match
f
with
|
Let
x
e1
g
=>
match
(
let_subst
g
)
with
|
Some
e
'
=>
Some
(
exp_subst
e
'
x
e1
)
|
None
=>
None
end
|
Ret
e1
=>
Some
e1
exp_subst
(
let_subst
g
)
x
e1
|
Ret
e1
=>
e1
end
.
Lemma
eval_subst_subexp
E
e
'
n
e
vR
:
NatSet
.
In
n
(
usedVars
e
)
->
eval_exp
0
E
(
toRExp
(
exp_subst
e
n
e
'
))
vR
->
exists
v
,
eval_exp
0
E
(
toRExp
e
'
)
v
.
Proof
.
revert
E
e
'
n
vR
.
induction
e
;
intros
E
e
'
n
'
vR
n_fVar
eval_subst
;
simpl
in
*
;
try
eauto
.
-
case_eq
(
n
=?
n
'
);
intros
case_n
;
rewrite
case_n
in
*
;
eauto
.
rewrite
NatSet
.
singleton_spec
in
n_fVar
.
exfalso
.
rewrite
Nat
.
eqb_neq
in
case_n
.
apply
case_n
;
auto
.
-
inversion
n_fVar
.
-
inversion
eval_subst
;
subst
;
eapply
IHe
;
eauto
.
-
inversion
eval_subst
;
subst
.
rewrite
NatSet
.
union_spec
in
n_fVar
.
destruct
n_fVar
as
[
n_fVar_e1
|
n_fVare2
];
[
eapply
IHe1
;
eauto
|
eapply
IHe2
;
eauto
].
Qed
.
Lemma
bstep_subst_subexp_any
E
e
x
f
vR
:
NatSet
.
In
x
(
liveVars
f
)
->
bstep
(
toRCmd
(
map_subst
f
x
e
))
E
0
vR
->
exists
E
'
v
,
eval_exp
0
E
'
(
toRExp
e
)
v
.
Proof
.
revert
E
e
x
vR
;
induction
f
;
intros
E
e
'
x
vR
x_live
eval_f
.
-
inversion
eval_f
;
subst
.
simpl
in
x_live
.
rewrite
NatSet
.
union_spec
in
x_live
.
destruct
x_live
as
[
x_used
|
x_live
].
+
exists
E
.
eapply
eval_subst_subexp
;
eauto
.
+
eapply
IHf
;
eauto
.
-
simpl
in
*
.
inversion
eval_f
;
subst
.
exists
E
.
eapply
eval_subst_subexp
;
eauto
.
Qed
.
Lemma
bstep_subst_subexp_ret
E
e
x
e
'
vR
:
NatSet
.
In
x
(
liveVars
(
Ret
e
'
))
->
bstep
(
toRCmd
(
map_subst
(
Ret
e
'
)
x
e
))
E
0
vR
->
exists
v
,
eval_exp
0
E
(
toRExp
e
)
v
.
Proof
.
simpl
;
intros
x_live
bstep_ret
.
inversion
bstep_ret
;
subst
.
eapply
eval_subst_subexp
;
eauto
.
Qed
.
Lemma
no_forward_refs
V
(
f
:
cmd
V
)
inVars
outVars
:
ssa
f
inVars
outVars
->
forall
v
,
NatSet
.
In
v
(
definedVars
f
)
->
NatSet
.
mem
v
inVars
=
false
.
Proof
.
intros
ssa_f
;
induction
ssa_f
;
simpl
.
-
intros
v
v_defVar
.
rewrite
NatSet
.
add_spec
in
v_defVar
.
destruct
v_defVar
as
[
v_x
|
v_defVar
].
+
subst
;
auto
.
+
specialize
(
IHssa_f
v
v_defVar
).
case_eq
(
NatSet
.
mem
v
inVars
);
intros
mem_inVars
;
try
auto
.
assert
(
NatSet
.
mem
v
(
NatSet
.
add
x
inVars
)
=
true
)
by
(
rewrite
NatSet
.
mem_spec
,
NatSet
.
add_spec
,
<-
NatSet
.
mem_spec
;
auto
).
congruence
.
-
intros
v
v_in_empty
;
inversion
v_in_empty
.
Qed
.
Lemma
bstep_subst_subexp_let
E
e
x
y
e
'
g
vR
:
NatSet
.
In
x
(
liveVars
(
Let
y
e
'
g
))
->
(
forall
x
,
NatSet
.
In
x
(
usedVars
e
)
->
exists
v
,
E
x
=
v
)
->
bstep
(
toRCmd
(
map_subst
(
Let
y
e
'
g
)
x
e
))
E
0
vR
->
exists
v
,
eval_exp
0
E
(
toRExp
e
)
v
.
Proof
.
revert
E
e
x
y
e
'
vR
;
induction
g
;
intros
E
e0
x
y
e
'
vR
x_live
uedVars_def
bstep_f
.
-
simpl
in
*
.
inversion
bstep_f
;
subst
.
specialize
(
IHg
(
updEnv
y
v
E
)
e0
x
n
e
).
rewrite
NatSet
.
union_spec
in
x_live
.
destruct
x_live
as
[
x_used
|
x_live
].
+
eapply
eval_subst_subexp
;
eauto
.
+
edestruct
IHg
as
[
v0
eval_v0
];
eauto
.
Admitted
.
Theorem
let_free_agree
f
E
vR
inVars
outVars
e
:
ssa
f
inVars
outVars
->
(
forall
v
,
NatSet
.
In
v
(
definedVars
f
)
->
NatSet
.
In
v
(
liveVars
f
))
->
let_subst
f
=
e
->
bstep
(
toRCmd
(
Ret
e
))
E
0
vR
->
bstep
(
toRCmd
f
)
E
0
vR
.
Proof
.
intros
ssa_f
.
revert
E
vR
e
;
induction
ssa_f
;
intros
E
vR
e_subst
dVars_live
subst_step
bstep_e
;
simpl
in
*
.
(
*
Let
Case
,
prove
that
the
value
of
the
let
binding
must
be
used
somewhere
*
)
-
case_eq
(
let_subst
s
).
+
intros
e0
subst_s
;
rewrite
subst_s
in
*
.
Admitted
.
(
*
inversion
subst_step
;
subst
.
clear
subst_s
subst_step
.
inversion
bstep_e
;
subst
.
specialize
(
dVars_live
x
).
rewrite
NatSet
.
add_spec
in
dVars_live
.
assert
(
NatSet
.
In
x
(
NatSet
.
union
(
usedVars
e
)
(
liveVars
s
)))
as
x_used_or_live
by
(
apply
dVars_live
;
auto
).
rewrite
NatSet
.
union_spec
in
x_used_or_live
.
destruct
x_used_or_live
as
[
x_used
|
x_live
].
*
specialize
(
H
x
x_used
).
rewrite
<-
NatSet
.
mem_spec
in
H
;
congruence
.
*
eapply
let_b
.
Focus
2.
eapply
IHssa_f
;
try
auto
.
*
)
Theorem
let_free_form
f
E
vR
inVars
outVars
e
:
ssa
f
inVars
outVars
->
bstep
(
toRCmd
f
)
E
0
vR
->
let_subst
f
=
Some
e
->
let_subst
f
=
e
->
bstep
(
toRCmd
(
Ret
e
))
E
0
vR
.
Proof
.
revert
E
vR
inVars
outVars
e
;
...
...
@@ -411,8 +530,8 @@ Proof.
-
simpl
.
inversion
bstep_f
;
subst
.
inversion
ssa_f
;
subst
.
simpl
in
subst_s
te
p
.
case_eq
(
let_subst
f
).
Admit
te
d
.
(
*
case_eq
(
let_subst
f
).
+
intros
f_subst
subst_f_eq
.
specialize
(
IHf
(
updEnv
n
v
E
)
vR
(
NatSet
.
add
n
inVars
)
outVars
f_subst
H8
H6
subst_f_eq
).
rewrite
subst_f_eq
in
subst_step
.
...
...
@@ -428,6 +547,7 @@ Proof.
inversion
subst_step
;
subst
.
assumption
.
Qed
.
*
)
(
*
Lemma
ssa_non_stuck
(
f
:
cmd
Q
)
(
inVars
outVars
:
NatSet
.
t
)
(
VarEnv
:
var_env
)
...
...
hol4/AbbrevsScript.sml
View file @
98d9efcf
...
...
@@ -36,9 +36,4 @@ val emptyEnv_def = Define `
val
updEnv_def
=
Define
`
updEnv
(
x
:
num
)
(
v
:
real
)
(
E
:
env
)
(
y
:
num
)
:
real
option
=
if
y
=
x
then
SOME
v
else
E
y`
;
(*
*
Abbreviation for insertion into "num_set" type
**)
val
Insert_def
=
Define
`Insert
x
V
=
insert
x
()
V`
;
val
-
=
export_theory
();
hol4/CertificateCheckerScript.sml
View file @
98d9efcf
...
...
@@ -6,7 +6,7 @@
**)
open
preamble
open
simpLib
realTheory
realLib
RealArith
open
AbbrevsTheory
ExpressionsTheory
RealSimpsTheory
open
AbbrevsTheory
ExpressionsTheory
RealSimpsTheory
DaisyTactics
open
ExpressionAbbrevsTheory
ErrorBoundsTheory
IntervalArithTheory
open
IntervalValidationTheory
ErrorValidationTheory
...
...
@@ -15,11 +15,15 @@ val _ = new_theory "CertificateChecker";
(*
* Certificate checking function **)
val
CertificateChecker_def
=
Define
`CertificateChecker
(
e
:
real
exp
)
(
absenv
:
analysisResult
)
(
P
:
precond
)
=
((
validIntervalbounds
e
absenv
P
EMPTY
)
/\
(
validErrorbound
e
absenv
))
`
;
if
(
validIntervalbounds
e
absenv
P
LN
)
then
(
validErrorbound
e
absenv
LN
)
else
F`
;
val
CertificateCheckerCmd_def
=
Define
`CertificateCheckerCmd
(
f
:
real
cmd
)
(
absenv
:
analysisResult
)
(
P
:
precond
)
=
((
validIntervalboundsCmd
f
absenv
P
EMPTY
)
/\
(
validErrorboundCmd
f
absenv
))
`
;
if
(
validIntervalboundsCmd
f
absenv
P
LN
)
then
(
validErrorboundCmd
f
absenv
LN
)
else
F`
;
(*
*
Soundness proof for the certificate checker.
...
...
@@ -27,44 +31,56 @@ val CertificateCheckerCmd_def = Define
the real valued execution respects the precondition.
**)
val
Certificate_checking_is_sound
=
store_thm
(
"Certificate_checking_is_sound"
,
``!
(
e
:
real
exp
)
(
absenv
:
analysisResult
)
P
(
VarEnv1
VarEnv2
ParamEnv
:
env
)
(
vR
:
real
)
(
vF
:
real
)
.
approxEnv
VarEnv1
absenv
VarEnv2
/\
eval_exp
0
VarEnv1
ParamEnv
P
e
vR
/\
eval_exp
machineEpsilon
VarEnv2
ParamEnv
P
e
vF
/\
``!
(
e
:
real
exp
)
(
absenv
:
analysisResult
)
(
P
:
precond
)
(
E1
E2
:
env
)
(
vR
:
real
)
(
vF
:
real
)
fVars
.
approxEnv
E1
absenv
fVars
LN
E2
/\
(
!
v
.
v
IN
(
domain
fVars
)
==>
?
vR
.
(
E1
v
=
SOME
vR
)
/\
FST
(
P
v
)
<=
vR
/\
vR
<=
SND
(
P
v
))
/\
(
domain
(
usedVars
e
))
SUBSET
(
domain
fVars
)
/\
eval_exp
0
E1
e
vR
/\
eval_exp
machineEpsilon
E2
e
vF
/\
CertificateChecker
e
absenv
P
==>
abs
(
vR
-
vF
)
<=
(
SND
(
absenv
e
))
``
,
(*
*
The proofs is a simple composition of the soundness proofs for the range
validator and the error bound validator.
**)
simp
[
CertificateChecker_def
]
\\
rpt
strip_tac
\\
Cases_on
`absenv
e`
\\
rename1
`absenv
e
=
(
iv
,
err
)
`
\\
Cases_on
`iv`
\\
rename1
`absenv
e
=
((
elo
,
ehi
),
err
)
`
\\
match_mp_tac
validErrorbound_sound
\\
qexistsl_tac
[
`e`
,
`
VarEnv1`
,
`VarEnv2`
,
`ParamEnv
`
,
`absenv`
,
`P`
,
`elo`
,
`ehi`
,
`
EMPTY`
]
\\
fs
[]);
simp
[
CertificateChecker_def
]
\\
rpt
strip_tac
\\
Cases_on
`absenv
e`
\\
rename1
`absenv
e
=
(
iv
,
err
)
`
\\
Cases_on
`iv`
\\
rename1
`absenv
e
=
((
elo
,
ehi
),
err
)
`
\\
match_mp_tac
validErrorbound_sound
\\
qexistsl_tac
[
`e`
,
`
E1`
,
`E2
`
,
`absenv`
,
`P`
,
`elo`
,
`ehi`
,
`
fVars`
,
`LN`
]
\\
fs
[]);
val
CertificateCmd_checking_is_sound
=
store_thm
(
"CertificateCmd_checking_is_sound"
,
``!
(
f
:
real
cmd
)
(
absenv
:
analysisResult
)
(
P
:
precond
)
(
VarEnv1
VarEnv2
ParamEnv
:
env
)
(
outVars
:
num
set
)
(
envR
envF
:
env
)
.
approxEnv
VarEnv1
absenv
VarEnv2
/\
ssaPrg
f
EMPTY
outVars
/\
bstep
f
VarEnv1
ParamEnv
P
0
Nop
envR
/\
bstep
f
VarEnv2
ParamEnv
P
machineEpsilon
Nop
envF
/\
(
E1
E2
:
env
)
(
outVars
:
num_set
)
(
vR
vF
:
real
)
fVars
.
approxEnv
E1
absenv
fVars
LN
E2
/\
(
!
v
.
v
IN
(
domain
fVars
)
==>
?
vR
.
(
E1
v
=
SOME
vR
)
/\
FST
(
P
v
)
<=
vR
/\
vR
<=
SND
(
P
v
))
/\
domain
(
freeVars
f
)
SUBSET
(
domain
fVars
)
/\
ssa
f
fVars
outVars
/\
bstep
f
E1
0
vR
/\
bstep
f
E2
machineEpsilon
vF
/\
CertificateCheckerCmd
f
absenv
P
==>