Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
FP
Stacked Borrows Coq
Commits
4be2ffb7
Commit
4be2ffb7
authored
Jul 07, 2019
by
Ralf Jung
Browse files
towards refl induction
parent
7d18706e
Changes
4
Hide whitespace changes
Inline
Side-by-side
_CoqProject
View file @
4be2ffb7
...
...
@@ -16,6 +16,7 @@ theories/lang/steps_progress.v
theories/lang/steps_inversion.v
theories/lang/steps_retag.v
theories/lang/examples.v
theories/lang/subst_map.v
theories/sim/behavior.v
theories/sim/global.v
...
...
theories/lang/subst_map.v
0 → 100644
View file @
4be2ffb7
From
stbor
.
lang
Require
Import
expr_semantics
.
(
**
Substitution
with
a
*
map
*
,
for
the
reflexivity
proof
.
*
)
Fixpoint
subst_map
(
xs
:
gmap
string
result
)
(
e
:
expr
)
:
expr
:=
match
e
with
|
Var
y
=>
if
xs
!!
y
is
Some
v
then
of_result
v
else
Var
y
|
Val
v
=>
Val
v
(
*
|
Rec
f
xl
e
=>
Rec
f
xl
$
if
bool_decide
(
BNamed
x
≠
f
∧
BNamed
x
∉
xl
)
then
subst_map
xs
e
else
e
*
)
|
Call
e
el
=>
Call
(
subst_map
xs
e
)
(
map
(
subst_map
xs
)
el
)
|
InitCall
e
=>
InitCall
(
subst_map
xs
e
)
|
EndCall
e
=>
EndCall
(
subst_map
xs
e
)
|
Place
l
tag
T
=>
Place
l
tag
T
(
*
|
App
e1
el
=>
App
(
subst_map
xs
e1
)
(
map
(
subst_map
xs
)
el
)
*
)
|
BinOp
op
e1
e2
=>
BinOp
op
(
subst_map
xs
e1
)
(
subst_map
xs
e2
)
|
Proj
e1
e2
=>
Proj
(
subst_map
xs
e1
)
(
subst_map
xs
e2
)
|
Conc
e1
e2
=>
Conc
(
subst_map
xs
e1
)
(
subst_map
xs
e2
)
|
Copy
e
=>
Copy
(
subst_map
xs
e
)
|
Write
e1
e2
=>
Write
(
subst_map
xs
e1
)
(
subst_map
xs
e2
)
|
Alloc
T
=>
Alloc
T
|
Free
e
=>
Free
(
subst_map
xs
e
)
|
Deref
e
T
=>
Deref
(
subst_map
xs
e
)
T
|
Ref
e
=>
Ref
(
subst_map
xs
e
)
|
Retag
e
kind
=>
Retag
(
subst_map
xs
e
)
kind
|
Let
x1
e1
e2
=>
Let
x1
(
subst_map
xs
e1
)
(
subst_map
(
if
x1
is
BNamed
s
then
delete
s
xs
else
xs
)
e2
)
|
Case
e
el
=>
Case
(
subst_map
xs
e
)
(
map
(
subst_map
xs
)
el
)
end
.
theories/sim/refl.v
View file @
4be2ffb7
From
stbor
.
lang
Require
Import
lang
.
From
stbor
.
sim
Require
Import
refl_step
.
From
stbor
.
lang
Require
Import
lang
subst_map
.
From
stbor
.
sim
Require
Import
refl_step
simple
tactics
.
Set
Default
Proof
Using
"Type"
.
...
...
@@ -40,10 +40,91 @@ Definition prog_wf (prog: fn_env) :=
has_main
prog
∧
map_Forall
(
λ
_
f
,
expr_wf
f
.(
fun_body
))
prog
.
Section
sem
.
Context
(
fs
ft
:
fn_env
)
`
{!
sim_local_funs_lookup
fs
ft
}
.
Context
(
css
cst
:
call_id_stack
).
Definition
sem_steps
:=
10
%
nat
.
Definition
rrel
(
r
:
resUR
)
rs
rt
:
Prop
:=
match
rs
,
rt
with
|
ValR
vs
,
ValR
vt
=>
vrel
r
vs
vt
|
PlaceR
ls
ts
Ts
,
PlaceR
lt
t_t
Tt
=>
(
*
Places
are
related
like
pointers
,
and
the
types
must
be
equal
.
*
)
vrel
r
[
ScPtr
ls
ts
]
[
ScPtr
lt
t_t
]
∧
Ts
=
Tt
|
_
,
_
=>
False
end
.
Definition
sem_post
(
r
:
resUR
)
(
n
:
nat
)
rs
css
'
rt
cst
'
:
Prop
:=
n
=
sem_steps
∧
css
'
=
css
∧
cst
'
=
cst
∧
rrel
r
rs
rt
.
(
**
We
define
a
"semantic well-formedness"
,
in
some
context
.
*
)
Definition
sem_wf
(
r
:
resUR
)
es
et
:=
∀
xs
:
gmap
string
(
result
*
result
),
map_Forall
(
λ
_
'
(
rs
,
rt
),
rrel
r
rs
rt
)
xs
→
r
⊨ˢ
{
sem_steps
,
fs
,
ft
}
(
subst_map
(
fst
<
$
>
xs
)
es
,
css
)
≥
(
subst_map
(
snd
<
$
>
xs
)
et
,
cst
)
:
sem_post
.
Lemma
value_wf_soundness
r
v
:
value_wf
v
→
vrel
r
v
v
.
Proof
.
intros
Hwf
.
induction
v
.
-
constructor
.
-
apply
Forall_cons_1
in
Hwf
as
[
??
].
constructor
.
+
destruct
a
;
done
.
+
apply
IHv
.
done
.
Qed
.
Lemma
expr_wf_soundness
r
e
:
expr_wf
e
→
sem_wf
r
e
e
.
Proof
.
intros
Hwf
.
induction
e
;
simpl
in
Hwf
.
-
(
*
Value
*
)
move
=>
_
_
/=
.
apply
sim_simple_val
.
split
;
first
admit
.
split
;
first
done
.
split
;
first
done
.
apply
value_wf_soundness
.
done
.
-
(
*
Variable
*
)
move
=>{
Hwf
}
xs
Hxswf
/=
.
rewrite
!
lookup_fmap
.
specialize
(
Hxswf
x
).
destruct
(
xs
!!
x
).
+
simpl
.
intros
σ
s
σ
t
??
.
eapply
sim_body_result
=>
_.
split
;
first
admit
.
split
;
first
done
.
split
;
first
done
.
specialize
(
Hxswf
p
).
destruct
p
.
auto
.
+
simpl
.
(
*
FIXME
:
need
lemma
for
when
both
sides
are
stuck
on
an
unbound
var
.
*
)
admit
.
-
(
*
Call
*
)
move
=>
xs
Hxswf
/=
.
sim_bind
(
subst_map
_
e
)
(
subst_map
_
e
).
eapply
sim_simple_post_mono
,
IHe
;
[
|
by
apply
Hwf
|
done
].
intros
r
'
n
'
rs
css
'
rt
cst
'
(
->
&
->
&
->
&
Hrel
).
simpl
.
admit
.
Admitted
.
End
sem
.
Theorem
sim_mod_fun_refl
f
:
expr_wf
f
.(
fun_body
)
→
⊨ᶠ
f
≥
f
.
Proof
.
intros
Hwf
fs
ft
Hlk
r
es
et
.
intros
vs
vt
σ
s
σ
t
Hrel
Hsubst1
Hsubst2
.
exists
sem_steps
.
apply
sim_body_init_call
=>/=
.
set
css
:=
snc
σ
s
::
scs
σ
s
.
set
cst
:=
snc
σ
t
::
scs
σ
t
.
move
=>
Hstacks
.
(
*
FIXME
:
viewshift
to
public
call
ID
,
use
framing
or
something
to
get
it
to
fun_post
.
*
)
eapply
sim_local_body_post_mono
with
(
Φ
:=
(
λ
r
n
vs
'
σ
s
'
vt
'
σ
t
'
,
sem_post
css
cst
r
n
vs
'
σ
s
'
.(
scs
)
vt
'
σ
t
'
.(
scs
))).
{
intros
r
'
n
'
rs
css
'
rt
cst
'
(
->
&
?
&
?
&
Hrrel
).
split
.
-
eexists
.
split
.
subst
cst
css
.
rewrite
<-
Hstacks
.
congruence
.
admit
.
(
*
end_call_sat
*
)
-
admit
.
(
*
need
to
show
they
are
values
?!?
*
)
}
Admitted
.
Lemma
sim_mod_funs_refl
prog
:
...
...
theories/sim/simple.v
View file @
4be2ffb7
...
...
@@ -42,6 +42,16 @@ Proof.
apply
H
Φ
.
Qed
.
Lemma
sim_simple_post_mono
Φ
1
Φ
2
r
n
fs
ft
es
css
et
cst
:
Φ
1
<
6
=
Φ
2
→
r
⊨ˢ
{
n
,
fs
,
ft
}
(
es
,
css
)
≥
(
et
,
cst
)
:
Φ
1
→
r
⊨ˢ
{
n
,
fs
,
ft
}
(
es
,
css
)
≥
(
et
,
cst
)
:
Φ
2.
Proof
.
intros
H
Φ
Hold
σ
s
σ
t
<-<-
.
eapply
sim_local_body_post_mono
;
last
exact
:
Hold
.
auto
.
Qed
.
(
**
Simple
proof
for
a
function
taking
one
argument
.
*
)
(
*
TODO
:
make
the
two
call
stacks
the
same
.
*
)
Lemma
sim_fun_simple1
n
(
esf
etf
:
function
)
:
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new 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