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
0816e06e
Commit
0816e06e
authored
Mar 14, 2017
by
Raphaël Monat
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
new typing done with heiko
/ ! \ not compiling
parent
1ace1fdf
Changes
5
Hide whitespace changes
Inline
Side-by-side
Showing
5 changed files
with
194 additions
and
77 deletions
+194
-77
coq/Commands.v
coq/Commands.v
+21
-3
coq/ErrorValidation.v
coq/ErrorValidation.v
+42
-9
coq/IntervalValidation.v
coq/IntervalValidation.v
+0
-6
coq/Typing.v
coq/Typing.v
+121
-49
coq/ssaPrgs.v
coq/ssaPrgs.v
+10
-10
No files found.
coq/Commands.v
View file @
0816e06e
...
@@ -14,6 +14,12 @@ Inductive cmd (V:Type) :Type :=
...
@@ -14,6 +14,12 @@ Inductive cmd (V:Type) :Type :=
Let:
mType
->
nat
->
exp
V
->
cmd
V
->
cmd
V
Let:
mType
->
nat
->
exp
V
->
cmd
V
->
cmd
V
|
Ret
:
exp
V
->
cmd
V
.
|
Ret
:
exp
V
->
cmd
V
.
Fixpoint
getRetExp
(
V
:
Type
)
(
f
:
cmd
V
)
:=
match
f
with
|
Let
m
x
e
g
=>
getRetExp
g
|
Ret
e
=>
e
end
.
Fixpoint
toRCmd
(
f
:
cmd
Q
)
:=
Fixpoint
toRCmd
(
f
:
cmd
Q
)
:=
match
f
with
match
f
with
...
@@ -46,15 +52,27 @@ Inductive sstep : cmd R -> env -> R -> cmd R -> env -> Prop :=
...
@@ -46,15 +52,27 @@ Inductive sstep : cmd R -> env -> R -> cmd R -> env -> Prop :=
Define
big
step
semantics
for
the
Daisy
language
,
terminating
on
a
"returned"
Define
big
step
semantics
for
the
Daisy
language
,
terminating
on
a
"returned"
result
value
result
value
**
)
**
)
(
*
meaning
of
this
->
mType
???
*
)
(
*
Inductive
bstep
:
cmd
R
->
env
->
R
->
mType
->
Prop
:=
*
)
(
*
let_b
m
x
e
s
E
v
res
:
*
)
(
*
eval_exp
E
e
v
m
->
*
)
(
*
bstep
s
(
updEnv
x
m
v
E
)
res
m
->
*
)
(
*
bstep
(
Let
m
x
e
s
)
E
res
m
*
)
(
*
|
ret_b
m
e
E
v
:
*
)
(
*
eval_exp
E
e
v
m
->
*
)
(
*
bstep
(
Ret
e
)
E
v
m
.
*
)
Inductive
bstep
:
cmd
R
->
env
->
R
->
mType
->
Prop
:=
Inductive
bstep
:
cmd
R
->
env
->
R
->
mType
->
Prop
:=
let_b
m
x
e
s
E
v
res
:
let_b
m
m
'
x
e
s
E
v
res
:
eval_exp
E
e
v
m
->
eval_exp
E
e
v
m
->
bstep
s
(
updEnv
x
m
v
E
)
res
m
->
bstep
s
(
updEnv
x
m
v
E
)
res
m
'
->
bstep
(
Let
m
x
e
s
)
E
res
m
bstep
(
Let
m
x
e
s
)
E
res
m
'
|
ret_b
m
e
E
v
:
|
ret_b
m
e
E
v
:
eval_exp
E
e
v
m
->
eval_exp
E
e
v
m
->
bstep
(
Ret
e
)
E
v
m
.
bstep
(
Ret
e
)
E
v
m
.
(
**
(
**
The
free
variables
of
a
command
are
all
used
variables
of
expressions
The
free
variables
of
a
command
are
all
used
variables
of
expressions
without
the
let
bound
variables
without
the
let
bound
variables
...
...
coq/ErrorValidation.v
View file @
0816e06e
...
@@ -2665,7 +2665,10 @@ Qed.
...
@@ -2665,7 +2665,10 @@ Qed.
Fixpoint
typeExpressionCmd
(
f
:
cmd
Q
)
(
f
'
:
exp
Q
)
:
option
mType
:=
Fixpoint
typeExpressionCmd
(
f
:
cmd
Q
)
(
f
'
:
exp
Q
)
:
option
mType
:=
match
f
with
match
f
with
|
Let
m
n
e
c
=>
if
expEqBool
f
'
(
Var
Q
m
n
)
then
|
Let
m
n
e
c
=>
if
expEqBool
f
'
(
Var
Q
m
n
)
then
Some
m
match
typeExpression
e
f
'
with
|
None
=>
None
|
Some
m1
=>
if
mTypeEqBool
m1
m
then
Some
m
else
None
end
else
else
let
te
:=
typeExpression
e
in
let
te
:=
typeExpression
e
in
let
tc
:=
typeExpressionCmd
c
in
let
tc
:=
typeExpressionCmd
c
in
...
@@ -2678,6 +2681,29 @@ Fixpoint typeExpressionCmd (f:cmd Q) (f':exp Q) : option mType :=
...
@@ -2678,6 +2681,29 @@ Fixpoint typeExpressionCmd (f:cmd Q) (f':exp Q) : option mType :=
|
Ret
e
=>
(
typeExpression
e
)
f
'
|
Ret
e
=>
(
typeExpression
e
)
f
'
end
.
end
.
(
*
Lemma
soundnessTypeCmd
f
n
m0
m1
fV
dV
oV
:
*
)
(
*
ssaPrg
f
(
NatSet
.
union
fV
dV
)
oV
->
*
)
(
*
(
typeExpressionCmd
f
)
(
Var
Q
m1
n
)
=
Some
m1
->
*
)
(
*
(
typeExpressionCmd
f
)
(
Var
Q
m0
n
)
=
Some
m0
->
*
)
(
*
m1
=
m0
.
*
)
(
*
Proof
.
*
)
(
*
revert
f
;
induction
f
;
intros
.
*
)
(
*
-
simpl
in
H0
,
H1
.
*
)
(
*
case_eq
(
n
=?
n0
);
intros
;
rewrite
H2
in
H0
,
H1
.
*
)
(
*
+
admit
.
*
)
(
*
+
rewrite
andb_false_r
in
H0
,
H1
.
*
)
(
*
case_eq
(
typeExpression
e
(
Var
Q
m1
n
));
intros
;
case_eq
(
typeExpression
e
(
Var
Q
m0
n
));
intros
;
rewrite
H3
in
H0
;
rewrite
H4
in
H1
.
*
)
(
*
*
case_eq
(
typeExpressionCmd
f
(
Var
Q
m1
n
));
intros
;
case_eq
(
typeExpressionCmd
f
(
Var
Q
m0
n
));
intros
;
rewrite
H5
in
H0
;
rewrite
H6
in
H1
.
*
)
(
*
{
*
)
(
*
}
*
)
(
*
case_eq
(
mTypeEqBool
m1
m
);
intros
;
case_eq
(
mTypeEqBool
m0
m
);
intros
;
rewrite
H3
in
H0
;
rewrite
H
in
H1
.
*
)
(
*
+
*
)
Fixpoint
cmdEqBool
(
f
f
'
:
cmd
Q
)
:
bool
:=
Fixpoint
cmdEqBool
(
f
f
'
:
cmd
Q
)
:
bool
:=
match
f
,
f
'
with
match
f
,
f
'
with
|
Let
m1
n1
e1
c1
,
Let
m2
n2
e2
c2
=>
|
Let
m1
n1
e1
c1
,
Let
m2
n2
e2
c2
=>
...
@@ -2696,7 +2722,8 @@ Fixpoint isSubCmd (f':cmd Q) (f:cmd Q): bool :=
...
@@ -2696,7 +2722,8 @@ Fixpoint isSubCmd (f':cmd Q) (f:cmd Q): bool :=
Theorem
validErrorboundCmd_sound
(
f
:
cmd
Q
)
(
absenv
:
analysisResult
)
:
Theorem
validErrorboundCmd_sound
(
f
:
cmd
Q
)
(
absenv
:
analysisResult
)
:
forall
E1
E2
outVars
fVars
dVars
vR
vF
elo
ehi
err
P
m
,
forall
E1
E2
outVars
fVars
dVars
vR
vF
elo
ehi
err
P
m
tEnv
,
tEnv
=
typeExpressionCmd
f
->
approxEnv
E1
absenv
fVars
dVars
E2
->
approxEnv
E1
absenv
fVars
dVars
E2
->
ssaPrg
f
(
NatSet
.
union
fVars
dVars
)
outVars
->
ssaPrg
f
(
NatSet
.
union
fVars
dVars
)
outVars
->
NatSet
.
Subset
(
NatSet
.
diff
(
Commands
.
freeVars
f
)
dVars
)
fVars
->
NatSet
.
Subset
(
NatSet
.
diff
(
Commands
.
freeVars
f
)
dVars
)
fVars
->
...
@@ -2704,8 +2731,8 @@ Theorem validErrorboundCmd_sound (f:cmd Q) (absenv:analysisResult):
...
@@ -2704,8 +2731,8 @@ Theorem validErrorboundCmd_sound (f:cmd Q) (absenv:analysisResult):
bstep
(
toRCmd
f
)
E2
vF
m
->
bstep
(
toRCmd
f
)
E2
vF
m
->
validErrorboundCmd
f
(
*
(
typeExpressionCmd
f
)
*
)
absenv
dVars
=
true
->
validErrorboundCmd
f
(
*
(
typeExpressionCmd
f
)
*
)
absenv
dVars
=
true
->
validIntervalboundsCmd
f
absenv
P
dVars
=
true
->
validIntervalboundsCmd
f
absenv
P
dVars
=
true
->
(
forall
e1
v1
m1
,
NatSet
.
mem
v1
dVars
=
true
->
(
forall
v1
m1
,
NatSet
.
mem
v1
dVars
=
true
->
(
typeExpressionCmd
e1
)
(
Var
Q
m1
v1
)
=
Some
m1
->
tEnv
(
Var
Q
m1
v1
)
=
Some
m1
->
exists
vR
,
E1
v1
=
Some
(
vR
,
M0
)
/
\
exists
vR
,
E1
v1
=
Some
(
vR
,
M0
)
/
\
(
Q2R
(
fst
(
fst
(
absenv
(
Var
Q
m1
v1
))))
<=
vR
<=
Q2R
(
snd
(
fst
(
absenv
(
Var
Q
m1
v1
)))))
%
R
)
->
(
Q2R
(
fst
(
fst
(
absenv
(
Var
Q
m1
v1
))))
<=
vR
<=
Q2R
(
snd
(
fst
(
absenv
(
Var
Q
m1
v1
)))))
%
R
)
->
(
forall
v
,
NatSet
.
mem
v
fVars
=
true
->
(
forall
v
,
NatSet
.
mem
v
fVars
=
true
->
...
@@ -2715,7 +2742,7 @@ Theorem validErrorboundCmd_sound (f:cmd Q) (absenv:analysisResult):
...
@@ -2715,7 +2742,7 @@ Theorem validErrorboundCmd_sound (f:cmd Q) (absenv:analysisResult):
(
Rabs
(
vR
-
vF
)
<=
(
Q2R
err
))
%
R
.
(
Rabs
(
vR
-
vF
)
<=
(
Q2R
err
))
%
R
.
Proof
.
Proof
.
induction
f
;
induction
f
;
intros
*
(
*
type_f
*
)
approxc1c2
ssa_f
freeVars_subset
eval_real
eval_float
(
*
issubcmd_ok
*
)
valid_bounds
valid_intv
fVars_sound
P_valid
absenv_res
.
intros
*
type_f
approxc1c2
ssa_f
freeVars_subset
eval_real
eval_float
(
*
issubcmd_ok
*
)
valid_bounds
valid_intv
fVars_sound
P_valid
absenv_res
.
-
simpl
in
eval_real
,
eval_float
.
-
simpl
in
eval_real
,
eval_float
.
inversion
eval_float
;
inversion
eval_real
;
subst
.
inversion
eval_float
;
inversion
eval_real
;
subst
.
inversion
ssa_f
;
subst
.
inversion
ssa_f
;
subst
.
...
@@ -2761,9 +2788,10 @@ Proof.
...
@@ -2761,9 +2788,10 @@ Proof.
-
-
intros
e0
v1
m2
natset
typeexpr
.
intros
e0
v1
m2
natset
typeexpr
.
specialize
(
fVars_sound
(
Ret
e0
)
v1
m2
natset
).
specialize
(
fVars_sound
v1
m2
natset
).
assert
(
typeExpressionCmd
(
Ret
e0
)
(
Var
Q
m2
v1
)
=
Some
m2
)
by
(
simpl
;
auto
).
admit
.
apply
fVars_sound
;
auto
.
(
*
assert
(
typeExpressionCmd
(
Ret
e0
)
(
Var
Q
m2
v1
)
=
Some
m2
)
by
(
simpl
;
auto
).
apply
fVars_sound
;
auto
.
*
)
-
instantiate
(
1
:=
q0
).
instantiate
(
1
:=
q
).
-
instantiate
(
1
:=
q0
).
instantiate
(
1
:=
q
).
rewrite
absenv_e
;
auto
.
}
rewrite
absenv_e
;
auto
.
}
(
*
*
inversion
ssa_f
;
subst
.
(
*
*
inversion
ssa_f
;
subst
.
...
@@ -2805,7 +2833,7 @@ Proof.
...
@@ -2805,7 +2833,7 @@ Proof.
simpl
.
simpl
.
rewrite
NatSet
.
diff_spec
,
NatSet
.
remove_spec
,
NatSet
.
union_spec
.
rewrite
NatSet
.
diff_spec
,
NatSet
.
remove_spec
,
NatSet
.
union_spec
.
split
;
try
auto
.
split
;
try
auto
.
*
intros
e1
v1
m1
v1_mem
typing_e1
.
*
intros
v1
m1
v1_mem
typing_e1
.
unfold
updEnv
.
unfold
updEnv
.
case_eq
(
v1
=?
n
);
intros
v1_eq
.
case_eq
(
v1
=?
n
);
intros
v1_eq
.
{
rename
R1
into
eq_lo
;
{
rename
R1
into
eq_lo
;
...
@@ -2817,6 +2845,11 @@ Proof.
...
@@ -2817,6 +2845,11 @@ Proof.
apply
Nat
.
eqb_eq
in
v1_eq
;
subst
.
apply
Nat
.
eqb_eq
in
v1_eq
;
subst
.
exists
v0
;
split
;
try
auto
.
exists
v0
;
split
;
try
auto
.
(
*
Let
n
:
m0
=
e
in
f
*
)
(
*
typeExpressionCmd
f
(
Var
Q
m1
n
)
=
Some
m1
*
)
(
*
Want
to
prove
:
typeExpressionCmd
f
(
Var
Q
m0
n
)
=
Some
m0
/
\
m1
=
m0
.
(
because
variable
n
is
used
in
f
).
*
)
admit
.
admit
.
...
...
coq/IntervalValidation.v
View file @
0816e06e
...
@@ -195,12 +195,6 @@ Proof.
...
@@ -195,12 +195,6 @@ Proof.
apply
le_neq_bool_to_lt_prop
;
auto
.
apply
le_neq_bool_to_lt_prop
;
auto
.
Qed
.
Qed
.
Fixpoint
getRetExp
(
V
:
Type
)
(
f
:
cmd
V
)
:=
match
f
with
|
Let
m
x
e
g
=>
getRetExp
g
|
Ret
e
=>
e
end
.
Lemma
validVarsUnfolding_l
(
E
:
env
)
(
absenv
:
analysisResult
)
(
f1
f2
:
exp
Q
)
dVars
(
b
:
binop
)
m0
:
Lemma
validVarsUnfolding_l
(
E
:
env
)
(
absenv
:
analysisResult
)
(
f1
f2
:
exp
Q
)
dVars
(
b
:
binop
)
m0
:
(
typeExpression
(
Binop
b
f1
f2
))
(
Binop
b
f1
f2
)
=
Some
m0
->
(
typeExpression
(
Binop
b
f1
f2
))
(
Binop
b
f1
f2
)
=
Some
m0
->
(
forall
(
v
:
NatSet
.
elt
)
(
m
:
mType
),
(
forall
(
v
:
NatSet
.
elt
)
(
m
:
mType
),
...
...
coq/Typing.v
View file @
0816e06e
Require
Import
Coq
.
Reals
.
Reals
Coq
.
micromega
.
Psatz
Coq
.
QArith
.
QArith
Coq
.
QArith
.
Qreals
Coq
.
MSets
.
MSets
.
Require
Import
Coq
.
Reals
.
Reals
Coq
.
micromega
.
Psatz
Coq
.
QArith
.
QArith
Coq
.
QArith
.
Qreals
Coq
.
MSets
.
MSets
.
Require
Import
Daisy
.
Infra
.
RealRationalProps
Daisy
.
Expressions
Daisy
.
Infra
.
Ltacs
.
Require
Import
Daisy
.
Infra
.
RealRationalProps
Daisy
.
Expressions
Daisy
.
Infra
.
Ltacs
Daisy
.
Commands
Daisy
.
ssaPrgs
.
Require
Export
Daisy
.
Infra
.
Abbrevs
Daisy
.
Infra
.
RealSimps
Daisy
.
Infra
.
NatSet
Daisy
.
IntervalArithQ
Daisy
.
IntervalArith
Daisy
.
Infra
.
MachineType
.
Require
Export
Daisy
.
Infra
.
Abbrevs
Daisy
.
Infra
.
RealSimps
Daisy
.
Infra
.
NatSet
Daisy
.
IntervalArithQ
Daisy
.
IntervalArith
Daisy
.
Infra
.
MachineType
.
(
**
(
**
Now
we
want
a
TypeEnv
function
,
taking
an
expression
and
returning
a
exp
->
option
mType
Now
we
want
a
TypeEnv
function
,
taking
an
expression
and
returning
a
exp
->
option
mType
Soundness
property
is
:
TypeEnv
e
=
T
->
eval_exp
e
E
v
m
->
T
e
=
m
.
Soundness
property
is
:
TypeEnv
e
=
T
->
eval_exp
e
E
v
m
->
T
e
=
m
.
**
)
**
)
(
**
A
good
function
computing
a
map
of
expression
types
**
)
Definition
updTEnv
(
e
:
exp
Q
)
(
t
:
mType
)
(
cont
:
exp
Q
->
option
mType
)
:=
Fixpoint
typeExpression
(
e
:
exp
Q
)
(
e
'
:
exp
Q
)
:
option
mType
:=
(
fun
e
'
=>
if
expEqBool
e
e
'
then
Some
t
else
cont
e
'
).
Definition
emptyTEnv
:
exp
Q
->
option
mType
:=
fun
e
=>
None
.
Fixpoint
typeExpression_trec
e
(
cont
:
exp
Q
->
option
mType
)
:
exp
Q
->
option
mType
:=
match
e
with
match
e
with
|
Var
_
m
n
=>
if
expEqBool
e
e
'
then
Some
m
else
N
on
e
|
Var
_
m
v
=>
updTEnv
e
m
c
on
t
|
Const
m
n
=>
if
expEqBool
e
e
'
then
Some
m
else
N
on
e
|
Const
m
n
=>
updTEnv
e
m
c
on
t
|
Unop
u
e1
=>
|
Unop
u
e1
=>
let
tE1
:=
typeExpression
e1
in
let
tEnv
:=
typeExpression_trec
e1
cont
in
if
expEqBool
e
e
'
then
(
tE1
e1
)
let
t
:=
tEnv
e1
in
else
(
tE1
e
'
)
match
t
with
|
Some
m
=>
updTEnv
e
m
tEnv
|
None
=>
emptyTEnv
end
|
Binop
b
e1
e2
=>
|
Binop
b
e1
e2
=>
let
tE1
:=
typeExpression
e1
in
let
tEnv_e1
:=
typeExpression_trec
e1
cont
in
let
tE2
:=
typeExpression
e2
in
let
tEnv_e2
:=
typeExpression_trec
e2
tEnv_e1
in
(
*
TODO
:
This
may
cause
trouble
e
.
g
.
in
(
x
:
F
)
+
(
x
:
D
)
*
)
let
m
:=
match
(
tE1
e1
),
(
tE2
e2
)
with
let
(
t_e1
,
t_e2
)
:=
(
tEnv_e2
e1
,
tEnv_e2
e2
)
in
|
Some
m1
,
Some
m2
=>
Some
(
computeJoin
m1
m2
)
match
t_e1
,
t_e2
with
|
_
,
_
=>
None
|
Some
m
,
Some
m
'
=>
updTEnv
e
(
computeJoin
m
m
'
)
tEnv_e2
end
in
|
_
,
_
=>
emptyTEnv
if
expEqBool
e
e
'
then
m
end
else
match
(
tE1
e
'
),
(
tE2
e
'
)
with
|
Some
m1
,
Some
m2
=>
if
(
mTypeEqBool
m1
m2
)
then
Some
m1
else
None
|
Some
m1
,
None
=>
Some
m1
|
None
,
Some
m2
=>
Some
m2
|
None
,
None
=>
None
end
|
Downcast
m
e1
=>
|
Downcast
m
e1
=>
let
tE1
:=
typeExpression
e1
in
let
tEnv_e1
:=
typeExpression_trec
e1
cont
in
let
m
:=
match
(
tE1
e1
)
with
let
t
:=
tEnv_e1
e1
in
|
Some
m1
=>
if
(
isMorePrecise
m1
m
)
then
Some
m
else
None
match
t
with
|
_
=>
None
|
Some
m1
=>
if
(
isMorePrecise
m1
m
)
then
updTEnv
e
m
tEnv_e1
end
in
else
emptyTEnv
if
expEqBool
e
e
'
then
m
|
_
=>
emptyTEnv
else
(
tE1
e
'
)
end
end
.
Definition
typeExpression
e
:=
typeExpression_trec
e
emptyTEnv
.
Definition
updNatEnv
(
x
:
nat
)
(
m
:
mType
)
(
env
:
nat
->
option
mType
)
:=
(
fun
n
=>
if
(
n
=?
x
)
then
Some
m
else
(
env
n
)).
Definition
emptyNatEnv
:
nat
->
option
mType
:=
fun
n
=>
None
.
Fixpoint
typeCmd_trec1
(
f
:
cmd
Q
)
(
cont
:
exp
Q
->
option
mType
)
(
env
:
nat
->
option
mType
)
:=
match
f
with
|
Let
m
x
e
g
=>
(
*
check
that
env
x
=
None
?
or
this
is
already
done
by
ssa
?
*
)
let
gamma
:=
typeExpression_trec
e
cont
in
match
(
gamma
e
)
with
|
Some
m
'
=>
if
mTypeEqBool
m
m
'
then
(
*
hum
.
Should
we
just
return
tEnv_g
?
*
)
typeCmd_trec1
g
gamma
(
updNatEnv
x
m
'
env
)
else
emptyTEnv
|
None
=>
emptyTEnv
end
|
Ret
e
=>
typeExpression_trec
e
cont
end
.
end
.
(
*
Definition
typeCmd
f
:=
typeCmd_trec1
f
emptyTEnv
emptyNatEnv
.
*
)
(
*
Eval
compute
in
typeCmd
(
Let
M32
1
(
Const
M32
(
1
#
1
))
(
Ret
(
Binop
Plus
(
Var
Q
M32
1
)
(
Const
M64
(
2
#
1
))))).
*
)
(
*
Eval
compute
in
typeCmd
(
Let
M64
1
(
Const
M32
(
1
#
1
))
(
Ret
(
Binop
Plus
(
Var
Q
M64
1
)
(
Const
M64
(
2
#
1
))))).
*
)
(
*
Eval
compute
in
typeCmd
(
Let
M64
1
(
Const
M32
(
1
#
1
))
(
Ret
(
Binop
Plus
(
Var
Q
M32
1
)
(
Const
M32
(
2
#
1
))))).
*
)
(
*
do
we
need
this
env
:
nat
->
option
mType
?
The
updTEnv
does
the
same
kind
of
thing
I
guess
...
*
)
(
*
issue
here
is
that
we
may
have
(
Var
Q
m
x
)
and
(
Var
Q
m
'
x
).
But
this
should
not
happen
...
*
)
Fixpoint
typeCmd_trec2
(
f
:
cmd
Q
)
(
cont
:
exp
Q
->
option
mType
)
:=
match
f
with
|
Let
m
x
e
g
=>
let
gamma
:=
typeExpression_trec
e
cont
in
match
(
gamma
e
)
with
|
Some
m
'
=>
if
mTypeEqBool
m
m
'
then
let
newCont
:=
updTEnv
(
Var
Q
m
x
)
m
gamma
in
typeCmd_trec2
g
newCont
else
emptyTEnv
|
None
=>
emptyTEnv
end
|
Ret
e
=>
typeExpression_trec
e
cont
end
.
Definition
typeCmd
f
:=
typeCmd_trec2
f
emptyTEnv
.
Eval
compute
in
typeCmd
(
Let
M32
1
(
Const
M32
(
1
#
1
))
(
Ret
(
Binop
Plus
(
Var
Q
M32
1
)
(
Const
M64
(
2
#
1
))))).
Eval
compute
in
typeCmd
(
Let
M64
1
(
Const
M32
(
1
#
1
))
(
Ret
(
Binop
Plus
(
Var
Q
M64
1
)
(
Const
M64
(
2
#
1
))))).
Eval
compute
in
typeCmd
(
Let
M64
1
(
Const
M32
(
1
#
1
))
(
Ret
(
Binop
Plus
(
Var
Q
M32
1
)
(
Const
M32
(
2
#
1
))))).
Eval
compute
in
typeCmd
(
Let
M32
1
(
Const
M32
(
1
#
1
))
(
Let
M64
1
(
Const
M64
(
1
#
1
))
(
Ret
(
Binop
Plus
(
Var
Q
M32
1
)
(
Var
Q
M64
1
))))).
Theorem
typeCmd_sound
(
f
:
cmd
Q
)
inVars
E
v
m
:
validSSA
f
inVars
=
true
->
bstep
(
toRCmd
f
)
E
v
m
->
typeCmd
f
(
getRetExp
f
)
=
Some
m
.
Proof
.
Admitted
.
(
*
NB
:
one
might
be
tempted
to
prove
the
following
lemma
:
*
)
(
*
NB
:
one
might
be
tempted
to
prove
the
following
lemma
:
*
)
(
*
Lemma
typeExpressionPropagatesNone
e
e0
:
*
)
(
*
Lemma
typeExpressionPropagatesNone
e
e0
:
*
)
...
@@ -83,7 +156,7 @@ Proof.
...
@@ -83,7 +156,7 @@ Proof.
-
assert
(
mTypeEqBool
m0
m0
&&
(
n
=?
n
)
=
true
)
by
(
apply
andb_true_iff
;
split
;
[
apply
EquivEqBoolEq
|
rewrite
<-
beq_nat_refl
];
auto
).
-
assert
(
mTypeEqBool
m0
m0
&&
(
n
=?
n
)
=
true
)
by
(
apply
andb_true_iff
;
split
;
[
apply
EquivEqBoolEq
|
rewrite
<-
beq_nat_refl
];
auto
).
rewrite
H0
.
rewrite
H0
.
trivial
.
trivial
.
-
assert
(
mTypeEqBool
m0
m0
&&
Qeq_bool
v
v
=
true
).
-
assert
(
mTypeEqBool
m0
m0
&&
Qeq_bool
v
v
=
true
).
apply
andb_true_iff
;
split
;
[
apply
EquivEqBoolEq
;
auto
|
apply
Qeq_bool_iff
;
lra
].
apply
andb_true_iff
;
split
;
[
apply
EquivEqBoolEq
;
auto
|
apply
Qeq_bool_iff
;
lra
].
rewrite
H0
.
rewrite
H0
.
auto
.
auto
.
...
@@ -131,7 +204,7 @@ Proof.
...
@@ -131,7 +204,7 @@ Proof.
-
apply
IHe
.
-
apply
IHe
.
simpl
in
H
.
simpl
in
H
.
auto
.
auto
.
Qed
.
Qed
.
Lemma
typingConstDet
(
e
:
exp
Q
)
m
m0
v
:
Lemma
typingConstDet
(
e
:
exp
Q
)
m
m0
v
:
typeExpression
e
(
Const
m
v
)
=
Some
m0
->
typeExpression
e
(
Const
m
v
)
=
Some
m0
->
...
@@ -157,18 +230,18 @@ Proof.
...
@@ -157,18 +230,18 @@ Proof.
-
apply
IHe
.
-
apply
IHe
.
simpl
in
H
.
simpl
in
H
.
auto
.
auto
.
Qed
.
Qed
.
Fixpoint
isSubExpression
(
e
'
:
exp
Q
)
(
e
:
exp
Q
)
:=
Fixpoint
isSubExpression
(
e
'
:
exp
Q
)
(
e
:
exp
Q
)
:=
orb
(
expEqBool
e
e
'
)
(
orb
(
expEqBool
e
e
'
)
(
match
e
with
match
e
with
|
Var
_
_
_
=>
false
|
Var
_
_
_
=>
false
|
Const
_
_
=>
false
|
Const
_
_
=>
false
|
Unop
o1
e1
=>
isSubExpression
e
'
e1
|
Unop
o1
e1
=>
isSubExpression
e
'
e1
|
Binop
b
e1
e2
=>
orb
(
isSubExpression
e
'
e1
)
(
isSubExpression
e
'
e2
)
|
Binop
b
e1
e2
=>
orb
(
isSubExpression
e
'
e1
)
(
isSubExpression
e
'
e2
)
|
Downcast
m
e1
=>
isSubExpression
e
'
e1
|
Downcast
m
e1
=>
isSubExpression
e
'
e1
end
).
end
).
Lemma
typeNotSubExpr
e
e1
:
Lemma
typeNotSubExpr
e
e1
:
isSubExpression
e1
e
=
false
->
typeExpression
e
e1
=
None
.
isSubExpression
e1
e
=
false
->
typeExpression
e
e1
=
None
.
Proof
.
Proof
.
...
@@ -216,9 +289,9 @@ Proof.
...
@@ -216,9 +289,9 @@ Proof.
specialize
(
IHe1
H0
).
specialize
(
IHe1
H0
).
simpl
;
rewrite
IHe1
;
auto
.
simpl
;
rewrite
IHe1
;
auto
.
+
specialize
(
IHe1
H0
);
simpl
;
rewrite
IHe1
;
auto
.
+
specialize
(
IHe1
H0
);
simpl
;
rewrite
IHe1
;
auto
.
+
specialize
(
IHe2
H1
);
simpl
;
rewrite
IHe2
.
apply
orb_true_r
.
+
specialize
(
IHe2
H1
);
simpl
;
rewrite
IHe2
.
apply
orb_true_r
.
-
simpl
;
apply
IHe
;
auto
.
-
simpl
;
apply
IHe
;
auto
.
Qed
.
Qed
.
Lemma
typedIsSubExpr
e
f
m
:
Lemma
typedIsSubExpr
e
f
m
:
typeExpression
e
f
=
Some
m
->
typeExpression
e
f
=
Some
m
->
...
@@ -261,13 +334,13 @@ Proof.
...
@@ -261,13 +334,13 @@ Proof.
simpl
.
simpl
.
rewrite
IHe
.
rewrite
IHe
.
apply
orb_true_r
.
apply
orb_true_r
.
Qed
.
Qed
.
Lemma
typedVarIsUsed
e
m
m0
v
:
Lemma
typedVarIsUsed
e
m
m0
v
:
typeExpression
e
(
Var
Q
m0
v
)
=
Some
m
->
typeExpression
e
(
Var
Q
m0
v
)
=
Some
m
->
NatSet
.
In
v
(
usedVars
e
).
NatSet
.
In
v
(
usedVars
e
).
Proof
.
Proof
.
intros
;
induction
e
.
intros
;
induction
e
.
-
simpl
in
*
.
-
simpl
in
*
.
case_eq
(
mTypeEqBool
m1
m0
&&
(
n
=?
v
));
intros
;
auto
;
rewrite
H0
in
H
.
case_eq
(
mTypeEqBool
m1
m0
&&
(
n
=?
v
));
intros
;
auto
;
rewrite
H0
in
H
.
+
andb_to_prop
H0
.
+
andb_to_prop
H0
.
...
@@ -290,7 +363,7 @@ Proof.
...
@@ -290,7 +363,7 @@ Proof.
+
simpl
in
H
;
rewrite
H1
,
H2
in
H
.
+
simpl
in
H
;
rewrite
H1
,
H2
in
H
.
inversion
H
.
inversion
H
.
-
apply
IHe
;
auto
.
-
apply
IHe
;
auto
.
Qed
.
Qed
.
Lemma
binop_type_unfolding
b
f1
f2
mf
:
Lemma
binop_type_unfolding
b
f1
f2
mf
:
...
@@ -312,7 +385,7 @@ Lemma binary_type_unfolding b e1 e2 f m:
...
@@ -312,7 +385,7 @@ Lemma binary_type_unfolding b e1 e2 f m:
(
typeExpression
e1
f
=
Some
m
\
/
typeExpression
e2
f
=
Some
m
).
(
typeExpression
e1
f
=
Some
m
\
/
typeExpression
e2
f
=
Some
m
).
Proof
.
Proof
.
intros
notEq
typeBinop
.
intros
notEq
typeBinop
.
assert
(
isSubExpression
f
(
Binop
b
e1
e2
)
=
true
)
as
isSubExpr
by
(
eapply
typedIsSubExpr
;
eauto
).
assert
(
isSubExpression
f
(
Binop
b
e1
e2
)
=
true
)
as
isSubExpr
by
(
eapply
typedIsSubExpr
;
eauto
).
simpl
in
*
.
rewrite
notEq
in
*
.
simpl
in
*
.
rewrite
notEq
in
*
.
case_eq
(
typeExpression
e1
f
);
intros
;
rewrite
H
in
typeBinop
.
case_eq
(
typeExpression
e1
f
);
intros
;
rewrite
H
in
typeBinop
.
-
case_eq
(
typeExpression
e2
f
);
intros
;
rewrite
H0
in
typeBinop
.
-
case_eq
(
typeExpression
e2
f
);
intros
;
rewrite
H0
in
typeBinop
.
...
@@ -361,7 +434,7 @@ Proof.
...
@@ -361,7 +434,7 @@ Proof.
case_eq
(
typeExpression
e
'
e
'
);
intros
;
rewrite
H0
in
H1
;
inversion
H1
;
clear
H5
.
case_eq
(
typeExpression
e
'
e
'
);
intros
;
rewrite
H0
in
H1
;
inversion
H1
;
clear
H5
.
case_eq
(
isMorePrecise
m0
m1
);
intros
;
rewrite
H4
in
H1
;
inversion
H1
;
subst
;
clear
H1
;
case_eq
(
isMorePrecise
m0
m1
);
intros
;
rewrite
H4
in
H1
;
inversion
H1
;
subst
;
clear
H1
;
auto
.
auto
.
Qed
.
Qed
.
(
*
Lemma
subExprRewriting
e
f1
f2
:
*
)
(
*
Lemma
subExprRewriting
e
f1
f2
:
*
)
(
*
expEqBool
f1
f2
=
true
->
*
)
(
*
expEqBool
f1
f2
=
true
->
*
)
...
@@ -447,14 +520,14 @@ Qed.
...
@@ -447,14 +520,14 @@ Qed.
(
*
-
admit
.
*
)
(
*
-
admit
.
*
)
(
*
-
simpl
;
auto
.
*
)
(
*
-
simpl
;
auto
.
*
)
(
*
Admitted
.
*
)
(
*
Admitted
.
*
)
(
*
Lemma
unary_type_unfolding
u
e
f
m
:
*
)
(
*
Lemma
unary_type_unfolding
u
e
f
m
:
*
)
(
*
isSubExpression
f
e
=
true
->
*
)
(
*
isSubExpression
f
e
=
true
->
*
)
(
*
typeExpression
(
Unop
u
e
)
f
=
Some
m
->
*
)
(
*
typeExpression
(
Unop
u
e
)
f
=
Some
m
->
*
)
(
*
typeExpression
e
f
=
Some
m
.
*
)
(
*
typeExpression
e
f
=
Some
m
.
*
)
(
*
Proof
.
*
)
(
*
Proof
.
*
)
(
*
Admitted
.
*
)
(
*
Admitted
.
*
)
(
*
Lemma
weakRewritingInTypeExpr
e
e
'
f
m
m
'
:
*
)
(
*
Lemma
weakRewritingInTypeExpr
e
e
'
f
m
m
'
:
*
)
(
*
expEqBool
e
e
'
=
true
->
*
)
(
*
expEqBool
e
e
'
=
true
->
*
)
...
@@ -546,7 +619,7 @@ Proof.
...
@@ -546,7 +619,7 @@ Proof.
*
case_eq
(
typeExpression
f2
(
Binop
b
e1
e2
));
intros
;
rewrite
H3
in
H0
;
inversion
H0
;
subst
.
*
case_eq
(
typeExpression
f2
(
Binop
b
e1
e2
));
intros
;
rewrite
H3
in
H0
;
inversion
H0
;
subst
.
apply
IHf2
;
auto
.
apply
IHf2
;
auto
.
-
apply
IHf
;
auto
.
-
apply
IHf
;
auto
.
Qed
.
Qed
.
...
@@ -609,4 +682,3 @@ Proof.
...
@@ -609,4 +682,3 @@ Proof.
rewrite
(
stupid
_
_
H1
).
rewrite
(
stupid
_
_
H1
).
apply
orb_true_r
.
apply
orb_true_r
.
Qed
.
Qed
.
\ No newline at end of file
coq/ssaPrgs.v
View file @
0816e06e
...
@@ -235,16 +235,16 @@ Proof.
...
@@ -235,16 +235,16 @@ Proof.
revert
E1
E2
vR
.
revert
E1
E2
vR
.
induction
f
;
intros
E1
E2
vR
agree_on_vars
.
induction
f
;
intros
E1
E2
vR
agree_on_vars
.
-
split
;
intros
bstep_Let
;
inversion
bstep_Let
;
subst
.
-
split
;
intros
bstep_Let
;
inversion
bstep_Let
;
subst
.
+
erewrite
shadowing_free_rewriting_exp
in
H
5
;
auto
.
+
erewrite
shadowing_free_rewriting_exp
in
H
6
;
auto
.
econstructor
;
eauto
.
econstructor
;
eauto
.
rewrite
<-
IHf
.
rewrite
<-
IHf
.
apply
H
6
.
apply
H
7
.
intros
n
'
;
unfold
updEnv
.
intros
n
'
;
unfold
updEnv
.
case_eq
(
n
'
=?
n
);
auto
.
case_eq
(
n
'
=?
n
);
auto
.
+
erewrite
<-
shadowing_free_rewriting_exp
in
H
5
;
auto
.
+
erewrite
<-
shadowing_free_rewriting_exp
in
H
6
;
auto
.
econstructor
;
eauto
.
econstructor
;
eauto
.
rewrite
IHf
.
rewrite
IHf
.
apply
H
6
.
apply
H
7
.
intros
n
'
;
unfold
updEnv
.
intros
n
'
;
unfold
updEnv
.