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
Dan Frumin
ReLoC-v1
Commits
545272f2
Commit
545272f2
authored
Sep 12, 2017
by
Dan Frumin
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[stack] Initial work on the module refinement
parent
28dcb4a3
Changes
4
Hide whitespace changes
Inline
Side-by-side
Showing
4 changed files
with
279 additions
and
11 deletions
+279
-11
theories/examples/stack/CG_stack.v
theories/examples/stack/CG_stack.v
+70
-6
theories/examples/stack/FG_stack.v
theories/examples/stack/FG_stack.v
+64
-0
theories/examples/stack/module_refinement.v
theories/examples/stack/module_refinement.v
+127
-0
theories/examples/stack/refinement.v
theories/examples/stack/refinement.v
+18
-5
No files found.
theories/examples/stack/CG_stack.v
View file @
545272f2
...
...
@@ -54,16 +54,81 @@ Definition CG_snap_iter : val := λ: "st" "l" "f",
Definition
CG_stack_body
:
val
:=
λ
:
"st"
"l"
,
(
CG_locked_push
"st"
"l"
,
CG_locked_pop
"st"
"l"
,
CG_snap_iter
"st"
"l"
).
(
*
stack
:=
Λα
.
(
λ
(
l
:
lock
)
(
s
:
stack
α
).
stack_body
s
l
)
(
ref
nil
)
newlock
*
)
(
*
TODO
:
I
want
`solve_closed
`
to
solve
this
so
that
I
can
use
newlock
in
the
program
*
)
(
*
Instance
:
Closed
∅
((
λ
:
"l"
,
#())
newlock
).
*
)
(
*
Proof
.
solve_closed
.
Qed
*
)
Definition
CG_stack
:
val
:=
Λ
:
let
:
"l"
:=
ref
#
♭
false
in
let:
"st"
:=
ref
Nile
in
CG_stack_body
"st"
"l"
.
(
**
Coarse
-
grained
stack
presented
as
a
module
*
)
(
*
type
s
α
:=
(
ref
(
list
α
),
lock
τ
)
*
)
Definition
s
τ
α
:=
TProd
(
Tref
(
CG_StackType
α
))
LockType
.
(
*
newStack
:
∀
α
,
s
α
*
)
Definition
newStack
:
val
:=
Λ
:
λ
:
<>
,
(
ref
Nile
,
ref
#
false
)
%
E
.
(
*
popStack
:
∀
α
,
s
α
→
MAYBE
α
*
)
Definition
popStack
:
val
:=
Λ
:
λ
:
"x"
,
CG_locked_pop
(
Fst
"x"
)
(
Snd
"x"
)
#().
(
*
pushStack
:
∀
α
,
s
α
→
α
→
()
*
)
Definition
pushStack
:
val
:=
Λ
:
λ
:
"x"
"a"
,
CG_locked_push
(
Fst
"x"
)
(
Snd
"x"
)
"a"
.
Definition
stackmod
:
val
:=
Λ
:
Pack
(
TApp
newStack
,
TApp
popStack
,
TApp
pushStack
).
Section
typing
.
Hint
Unfold
s
τ
:
typeable
.
Lemma
newStack_typed
Γ
:
Γ
⊢ₜ
newStack
:
TForall
(
TArrow
TUnit
(
s
τ
(
TVar
0
))).
Proof
.
unlock
s
τ
newStack
.
(
*
TODO
need
to
explicitly
unlock
newStack
here
*
)
solve_typed
.
Qed
.
Hint
Resolve
newStack_typed
:
typeable
.
Lemma
popStack_typed
Γ
:
Γ
⊢ₜ
popStack
:
TForall
$
TArrow
(
s
τ
(
TVar
0
))
(
TSum
TUnit
(
TVar
0
)).
Proof
.
unlock
s
τ
popStack
.
(
*
TODO
need
to
explicitly
unlock
newStack
here
*
)
unlock
CG_locked_pop
CG_pop
.
repeat
(
econstructor
;
solve_typed
).
Qed
.
Hint
Resolve
popStack_typed
:
typeable
.
Lemma
pushStack_typed
Γ
:
Γ
⊢ₜ
pushStack
:
TForall
$
TArrow
(
s
τ
(
TVar
0
))
(
TArrow
(
TVar
0
)
TUnit
).
Proof
.
unlock
s
τ
pushStack
.
(
*
TODO
need
to
explicitly
unlock
newStack
here
*
)
unlock
CG_locked_push
CG_push
.
repeat
(
econstructor
;
solve_typed
).
Qed
.
Hint
Resolve
pushStack_typed
:
typeable
.
Lemma
stackmod_typed
Γ
:
Γ
⊢ₜ
stackmod
:
TForall
$
TExists
$
TProd
(
TProd
(
TArrow
TUnit
(
TVar
0
))
(
TArrow
(
TVar
0
)
(
TSum
TUnit
(
TVar
1
))))
(
TArrow
(
TVar
0
)
(
TArrow
(
TVar
1
)
TUnit
)).
Proof
.
unlock
stackmod
.
econstructor
.
eapply
TPack
with
(
s
τ
(
TVar
0
)).
econstructor
;
[
econstructor
|
].
-
simpl
.
replace
(
TArrow
TUnit
(
s
τ
(
TVar
0
)))
with
(
TArrow
TUnit
(
s
τ
(
TVar
0
))).[
TVar
0
/
];
last
first
.
{
autosubst
.
}
solve_typed
.
-
simpl
.
replace
(
TArrow
(
s
τ
(
TVar
0
))
(
TSum
TUnit
(
ids
0
)))
with
(
TArrow
(
s
τ
(
TVar
0
))
(
TSum
TUnit
(
TVar
0
))).[
TVar
0
/
];
last
first
.
{
autosubst
.
}
solve_typed
.
-
simpl
.
replace
(
TArrow
(
s
τ
(
TVar
0
))
(
TArrow
(
ids
0
)
TUnit
))
with
(
TArrow
(
s
τ
(
TVar
0
))
(
TArrow
(
ids
0
)
TUnit
)).[
TVar
0
/
]
by
autosubst
.
solve_typed
.
Qed
.
Hint
Resolve
stackmod_typed
.
End
typing
.
Section
CG_Stack
.
Context
`
{
logrelG
Σ
}
.
...
...
@@ -78,7 +143,6 @@ Section CG_Stack.
Hint
Resolve
CG_push_type
:
typeable
.
(
*
Lemma
steps_CG_push
E
ρ
j
K
st
v
w
:
*
)
(
*
nclose
specN
⊆
E
→
*
)
(
*
spec_ctx
ρ
-
∗
st
↦ₛ
v
-
∗
j
⤇
fill
K
(
App
(
CG_push
(
Loc
st
))
(
of_val
w
))
*
)
...
...
theories/examples/stack/FG_stack.v
View file @
545272f2
...
...
@@ -59,6 +59,70 @@ Definition FG_stack : val :=
Λ
:
let
:
"st"
:=
ref
Nile
in
FG_stack_body
"st"
.
Definition
s
τ
(
α
:
type
)
:
type
:=
Tref
(
FG_StackType
α
).
Definition
newStack
:
val
:=
Λ
:
λ
:
<>
,
ref
Nile
.
Definition
popStack
:
val
:=
Λ
:
λ
:
"st"
,
FG_pop
"st"
#().
Definition
pushStack
:
val
:=
Λ
:
FG_push
.
Definition
stackmod
:
val
:=
Λ
:
Pack
(
TApp
newStack
,
TApp
popStack
,
TApp
pushStack
).
Section
typing
.
Context
(
HEQTP
:
∀
τ
,
EqType
(
FG_StackType
τ
)).
Hint
Unfold
s
τ
:
typeable
.
Lemma
newStack_typed
Γ
:
Γ
⊢ₜ
newStack
:
TForall
(
TArrow
TUnit
(
s
τ
(
TVar
0
))).
Proof
.
unlock
s
τ
newStack
.
(
*
TODO
need
to
explicitly
unlock
newStack
here
*
)
solve_typed
.
Qed
.
Hint
Resolve
newStack_typed
:
typeable
.
Lemma
popStack_typed
Γ
:
Γ
⊢ₜ
popStack
:
TForall
$
TArrow
(
s
τ
(
TVar
0
))
(
TSum
TUnit
(
TVar
0
)).
Proof
.
unlock
s
τ
popStack
.
(
*
TODO
need
to
explicitly
unlock
newStack
here
*
)
unlock
FG_pop
.
repeat
(
econstructor
;
eauto
10
with
typeable
).
Qed
.
Hint
Resolve
popStack_typed
:
typeable
.
Lemma
pushStack_typed
Γ
:
Γ
⊢ₜ
pushStack
:
TForall
$
TArrow
(
s
τ
(
TVar
0
))
(
TArrow
(
TVar
0
)
TUnit
).
Proof
.
unlock
s
τ
pushStack
.
(
*
TODO
need
to
explicitly
unlock
newStack
here
*
)
unlock
FG_push
.
solve_typed
.
Qed
.
Hint
Resolve
pushStack_typed
:
typeable
.
Lemma
stackmod_typed
Γ
:
Γ
⊢ₜ
stackmod
:
TForall
$
TExists
$
TProd
(
TProd
(
TArrow
TUnit
(
TVar
0
))
(
TArrow
(
TVar
0
)
(
TSum
TUnit
(
TVar
1
))))
(
TArrow
(
TVar
0
)
(
TArrow
(
TVar
1
)
TUnit
)).
Proof
.
unlock
stackmod
.
econstructor
.
eapply
TPack
with
(
s
τ
(
TVar
0
)).
econstructor
;
[
econstructor
|
].
-
simpl
.
replace
(
TArrow
TUnit
(
s
τ
(
TVar
0
)))
with
((
TArrow
TUnit
(
s
τ
(
TVar
0
))).[
TVar
0
/
]);
last
first
.
{
autosubst
.
}
solve_typed
.
-
simpl
.
replace
(
TArrow
(
s
τ
(
TVar
0
))
(
TSum
TUnit
(
ids
0
)))
with
(
TArrow
(
s
τ
(
TVar
0
))
(
TSum
TUnit
(
TVar
0
))).[
TVar
0
/
];
last
first
.
{
autosubst
.
}
solve_typed
.
-
simpl
.
replace
(
TArrow
(
s
τ
(
TVar
0
))
(
TArrow
(
ids
0
)
TUnit
))
with
(
TArrow
(
s
τ
(
TVar
0
))
(
TArrow
(
ids
0
)
TUnit
)).[
TVar
0
/
]
by
autosubst
.
solve_typed
.
Qed
.
Hint
Resolve
stackmod_typed
.
End
typing
.
Section
FG_stack
.
(
*
Fine
-
grained
push
*
)
...
...
theories/examples/stack/module_refinement.v
0 → 100644
View file @
545272f2
From
iris
.
proofmode
Require
Import
tactics
.
From
iris_logrel
Require
Import
logrel
.
From
iris_logrel
.
examples
.
stack
Require
Import
CG_stack
FG_stack
stack_rules
refinement
.
Section
Mod_refinement
.
Context
`
{
logrelG
Σ
,
stackG
Σ
}
.
Notation
D
:=
(
prodC
valC
valC
-
n
>
iProp
Σ
).
Implicit
Types
Δ
:
listC
D
.
Import
lang
.
Program
Definition
sint
`
{
logrelG
Σ
,
stackG
Σ
}
τ
i
:
prodC
valC
valC
-
n
>
iProp
Σ
:=
λ
ne
vv
,
(
∃
(
l
stk
stk
'
:
loc
),
⌜
(
vv
.2
)
=
(#
stk
'
,
#
l
)
%
V
⌝
∗
⌜
(
vv
.1
)
=
#
stk
⌝
∗
inv
stackN
(
sinv
τ
i
stk
stk
'
l
))
%
I
.
Next
Obligation
.
solve_proper
.
Qed
.
Instance
sint_persistent
τ
i
vv
:
PersistentP
(
sint
τ
i
vv
).
Proof
.
apply
_.
Qed
.
Lemma
interp_subst_up_2
Δ
1
Δ
2
τ
τ
i
:
⟦
τ
⟧
(
Δ
1
++
Δ
2
)
≡
⟦
τ
.[
upn
(
length
Δ
1
)
(
ren
(
+
1
))]
⟧
(
Δ
1
++
τ
i
::
Δ
2
).
Proof
.
revert
Δ
1
Δ
2.
induction
τ
=>
Δ
1
Δ
2
;
simpl
;
eauto
.
-
intros
vv
;
simpl
;
properness
;
eauto
.
by
apply
IH
τ
1.
by
apply
IH
τ
2.
-
intros
vv
;
simpl
;
properness
;
eauto
.
by
apply
IH
τ
1.
by
apply
IH
τ
2.
-
unfold
interp_expr
.
intros
vv
;
simpl
;
properness
;
eauto
.
by
apply
IH
τ
1.
by
apply
IH
τ
2.
-
apply
fixpoint_proper
=>
τ'
ww
/=
.
properness
;
auto
.
apply
(
IH
τ
(
_
::
_
)).
-
intros
vv
;
simpl
.
rewrite
iter_up
;
destruct
lt_dec
as
[
Hl
|
Hl
];
simpl
;
properness
.
{
by
rewrite
!
lookup_app_l
.
}
rewrite
!
lookup_app_r
;
[
|
lia
..].
assert
((
length
Δ
1
+
S
(
x
-
length
Δ
1
)
-
length
Δ
1
)
=
S
(
x
-
length
Δ
1
))
as
Hwat
.
{
lia
.
}
rewrite
Hwat
.
simpl
.
done
.
-
unfold
interp_expr
.
intros
vv
;
simpl
;
properness
;
auto
.
apply
(
IH
τ
(
_
::
_
)).
-
intros
vv
;
simpl
;
properness
;
auto
.
apply
(
IH
τ
(
_
::
_
)).
-
intros
vv
;
simpl
;
properness
;
auto
.
by
apply
IH
τ
.
Qed
.
Lemma
interp_subst_2
τ
τ
i
Δ
:
⟦
τ
⟧
Δ
≡
⟦
τ
.[
ren
(
+
1
)]
⟧
(
τ
i
::
Δ
).
Proof
.
by
apply
(
interp_subst_up_2
[]).
Qed
.
Lemma
bin_log_weaken_2
τ
i
Δ
Γ
e1
e2
τ
:
{
⊤
,
⊤
;
Δ
;
Γ
}
⊨
e1
≤
log
≤
e2
:
τ
-
∗
{
⊤
,
⊤
;
τ
i
::
Δ
;
Autosubst_Classes
.
subst
(
ren
(
+
1
))
<
$
>
Γ
}
⊨
e1
≤
log
≤
e2
:
τ
.[
ren
(
+
1
)].
Proof
.
rewrite
bin_log_related_eq
/
bin_log_related_def
.
iIntros
"Hlog"
(
vvs
ρ
)
"#Hs #HΓ"
.
iSpecialize
(
"Hlog"
$
!
vvs
with
"Hs [HΓ]"
).
{
by
rewrite
interp_env_ren
.
}
unfold
interp_expr
.
iIntros
(
j
K
)
"Hj /="
.
iMod
(
"Hlog"
with
"Hj"
)
as
"Hlog"
.
iApply
(
wp_mono
with
"Hlog"
).
iIntros
(
v
).
simpl
.
iDestruct
1
as
(
v
'
)
"[Hj Hτ]"
.
iExists
v
'
.
iFrame
.
by
rewrite
-
interp_subst_2
.
Qed
.
Lemma
module_refinmenet
Δ
Γ
:
{
⊤
,
⊤
;
Δ
;
Γ
}
⊨
FG_stack
.
stackmod
≤
log
≤
CG_stack
.
stackmod
:
TForall
$
TExists
$
TProd
(
TProd
(
TArrow
TUnit
(
TVar
0
))
(
TArrow
(
TVar
0
)
(
TSum
TUnit
(
TVar
1
))))
(
TArrow
(
TVar
0
)
(
TArrow
(
TVar
1
)
TUnit
)).
Proof
.
unlock
FG_stack
.
stackmod
CG_stack
.
stackmod
.
iApply
bin_log_related_tlam
;
auto
.
iIntros
(
τ
i
H
τ
i
)
"!#"
.
iApply
(
bin_log_related_pack
_
(
sint
τ
i
)).
do
3
rel_tlam_l
.
do
3
rel_tlam_r
.
repeat
iApply
bin_log_related_pair
.
-
iApply
bin_log_related_arrow
;
eauto
.
iAlways
.
iIntros
(
?
?
)
"_"
.
rel_seq_l
.
rel_seq_r
.
rel_alloc_l
as
istk
"Histk"
.
simpl
.
rel_alloc_l
as
stk
"Hstk"
.
rel_alloc_r
as
stl
'
"Hstk'"
.
rel_alloc_r
as
l
"Hl"
.
rel_vals
.
admit
.
-
iApply
bin_log_related_arrow_val
;
eauto
.
iAlways
.
iIntros
(
?
?
)
"#Hvv /="
.
iDestruct
"Hvv"
as
(
l
stk
stk
'
)
"(% & % & #Hinv)"
.
simplify_eq
/=
.
rel_let_l
.
rel_let_r
.
Transparent
FG_pop
CG_locked_pop
.
rel_rec_l
.
rel_proj_r
;
rel_rec_r
.
unlock
CG_locked_pop
.
simpl_subst
/=
.
rel_proj_r
.
rel_let_r
.
replace
(#();;
acquire
#
l
;;
let
:
"v"
:=
(
CG_pop
#
stk
'
)
#()
in
release
#
l
;;
"v"
)
%
E
with
((
CG_locked_pop
$
/
LitV
(
Loc
stk
'
)
$
/
LitV
(
Loc
l
))
#())
%
E
;
last
first
.
{
unlock
CG_locked_pop
.
simpl_subst
/=
.
reflexivity
.
}
replace
(
TSum
TUnit
(
TVar
1
))
with
(
TSum
TUnit
(
TVar
0
)).[
ren
(
+
1
)]
by
done
.
iApply
bin_log_weaken_2
.
by
iApply
FG_CG_pop_refinement
'
.
-
iApply
bin_log_related_arrow_val
;
eauto
.
{
unlock
FG_push
.
done
.
}
iAlways
.
iIntros
(
?
?
)
"#Hvv /="
.
iDestruct
"Hvv"
as
(
l
stk
stk
'
)
"(% & % & #Hinv)"
.
simplify_eq
/=
.
rel_let_r
.
Transparent
FG_push
.
rel_rec_l
.
iApply
bin_log_related_arrow_val
;
eauto
.
{
unlock
FG_push
.
simpl_subst
/=
.
done
.
}
{
unlock
FG_push
.
simpl_subst
/=
.
solve_closed
.
}
iAlways
.
iIntros
(
v
v
'
)
"#Hτi /="
.
rel_let_r
.
rel_proj_r
;
rel_rec_r
.
unlock
CG_locked_push
.
simpl_subst
/=
.
rel_proj_r
;
rel_let_r
.
replace
(
let
:
"x"
:=
v
'
in
acquire
#
l
;;
(
CG_push
#
stk
'
)
"x"
;;
release
#
l
)
%
E
with
((
CG_locked_push
$
/
LitV
stk
'
$
/
LitV
l
)
v
'
)
%
E
;
last
first
.
{
unlock
CG_locked_push
.
simpl_subst
/=
.
done
.
}
change
TUnit
with
(
TUnit
.[
ren
(
+
1
)]).
iApply
(
FG_CG_push_refinement
with
"Hinv Hτi"
).
Admitted
.
End
Mod_refinement
.
theories/examples/stack/refinement.v
View file @
545272f2
...
...
@@ -80,18 +80,16 @@ Section Stack_refinement.
by
iApply
"IH"
.
Qed
.
Lemma
FG_CG_pop_refinement
st
st
'
(
τ
i
:
D
)
l
{
τ
P
:
∀
ww
,
PersistentP
(
τ
i
ww
)
}
Δ
Γ
:
Lemma
FG_CG_pop_refinement
'
st
st
'
(
τ
i
:
D
)
l
{
τ
P
:
∀
ww
,
PersistentP
(
τ
i
ww
)
}
Δ
Γ
:
inv
stackN
(
sinv
τ
i
st
st
'
l
)
-
∗
{
⊤
,
⊤
;
τ
i
::
Δ
;
Γ
}
⊨
(
FG_pop
$
/
LitV
(
Loc
st
))
%
E
≤
log
≤
(
CG_locked_pop
$
/
LitV
(
Loc
st
'
)
$
/
LitV
(
Loc
l
))
%
E
:
TArrow
TUnit
(
TSum
TUnit
(
TVar
0
)
)
.
{
⊤
,
⊤
;
τ
i
::
Δ
;
Γ
}
⊨
(
FG_pop
$
/
LitV
(
Loc
st
))
#()
≤
log
≤
(
CG_locked_pop
$
/
LitV
(
Loc
st
'
)
$
/
LitV
(
Loc
l
))
#()
:
TSum
TUnit
(
TVar
0
).
Proof
.
iIntros
"#Hinv"
.
Transparent
CG_locked_pop
FG_pop
CG_pop
.
unfold
FG_pop
,
CG_locked_pop
.
unlock
.
simpl_subst
/=
.
iApply
bin_log_related_arrow
;
eauto
.
iAlways
.
iIntros
(
?
?
)
"ZZ"
.
simplify_eq
/=
.
iClear
"ZZ"
.
rel_rec_r
.
rel_rec_l
.
rel_rec_r
.
iL
ö
b
as
"IH"
.
rel_load_l_atomic
.
iInv
stackN
as
(
istk
v
h
)
"[Hoe [Hst' [Hst [#HLK Hl]]]]"
"Hclose"
.
...
...
@@ -197,6 +195,20 @@ Section Stack_refinement.
by
iApply
"IH"
.
Qed
.
Lemma
FG_CG_pop_refinement
st
st
'
(
τ
i
:
D
)
l
{
τ
P
:
∀
ww
,
PersistentP
(
τ
i
ww
)
}
Δ
Γ
:
inv
stackN
(
sinv
τ
i
st
st
'
l
)
-
∗
{
⊤
,
⊤
;
τ
i
::
Δ
;
Γ
}
⊨
(
FG_pop
$
/
LitV
(
Loc
st
))
%
E
≤
log
≤
(
CG_locked_pop
$
/
LitV
(
Loc
st
'
)
$
/
LitV
(
Loc
l
))
%
E
:
TArrow
TUnit
(
TSum
TUnit
(
TVar
0
)).
Proof
.
iIntros
"#Hinv"
.
iApply
bin_log_related_arrow_val
;
eauto
.
{
unlock
FG_pop
CG_locked_pop
.
reflexivity
.
}
{
unlock
FG_pop
CG_locked_pop
.
reflexivity
.
}
{
unlock
FG_pop
CG_locked_pop
.
simpl_subst
/=
.
solve_closed
.
}
{
unlock
FG_pop
CG_locked_pop
.
simpl_subst
/=
.
solve_closed
.
}
iAlways
.
iIntros
(
?
?
)
"[% %]"
.
simplify_eq
/=
.
by
iApply
FG_CG_pop_refinement
'
.
Qed
.
Lemma
FG_CG_iter_refinement
st
st
'
(
τ
i
:
D
)
l
Δ
{
τ
P
:
∀
ww
,
PersistentP
(
τ
i
ww
)
}
{
SH
:
stackG
Σ
}
Γ
:
inv
stackN
(
sinv
τ
i
st
st
'
l
)
-
∗
{
⊤
,
⊤
;
τ
i
::
Δ
;
Γ
}
⊨
(
FG_read_iter
$
/
LitV
(
Loc
st
))
%
E
≤
log
≤
(
CG_snap_iter
$
/
LitV
(
Loc
st
'
)
$
/
LitV
(
Loc
l
))
%
E
:
TArrow
(
TArrow
(
TVar
0
)
TUnit
)
TUnit
.
...
...
@@ -298,6 +310,7 @@ Section Stack_refinement.
iApply
(
related_ret
with
"[Hff]"
).
done
.
Qed
.
End
Stack_refinement
.
Section
Full_refinement
.
...
...
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