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
iris-atomic
Commits
ade8f525
Commit
ade8f525
authored
Oct 11, 2016
by
Zhen Zhang
Browse files
Unfix f in flat combiner; Unifies atomic_triple
parent
3038f1ca
Changes
6
Hide whitespace changes
Inline
Side-by-side
atomic.v
View file @
ade8f525
...
...
@@ -5,38 +5,21 @@ From iris.proofmode Require Import tactics.
Import
uPred
.
Section
atomic
.
Context
`
{
irisG
Λ
Σ
}
{
A
:
Type
}
.
Context
`
{
irisG
Λ
Σ
}
(
A
:
Type
)
.
(
*
logically
atomic
triple
:
<
x
,
α
>
e
@
E_i
,
E_o
<
v
,
β
x
v
>
*
)
Definition
atomic_triple
(
α
:
A
→
iProp
Σ
)
(
β
:
A
→
val
_
→
iProp
Σ
)
(
Ei
Eo
:
coPset
)
(
e
:
expr
_
)
:
iProp
Σ
:=
(
∀
P
Q
,
(
P
={
Eo
,
Ei
}=>
∃
x
:
A
,
α
x
★
((
α
x
={
Ei
,
Eo
}=
★
P
)
∧
(
∀
v
,
β
x
v
={
Ei
,
Eo
}=
★
Q
x
v
))
)
-
★
{{
P
}}
e
@
⊤
{{
v
,
(
∃
x
:
A
,
Q
x
v
)
}}
)
%
I
.
(
*
Weakest
-
pre
version
of
the
above
one
.
Also
weaker
in
some
sense
*
)
Definition
atomic_triple_wp
Definition
atomic_triple_base
(
α
:
A
→
iProp
Σ
)
(
β
:
A
→
val
_
→
iProp
Σ
)
(
Ei
Eo
:
coPset
)
(
e
:
expr
_
)
:
iProp
Σ
:=
(
∀
P
Q
,
(
P
={
Eo
,
Ei
}=>
∃
x
,
α
x
★
((
α
x
={
Ei
,
Eo
}=
★
P
)
∧
(
∀
v
,
β
x
v
={
Ei
,
Eo
}=
★
Q
x
v
))
)
-
★
P
-
★
WP
e
@
⊤
{{
v
,
(
∃
x
,
Q
x
v
)
}}
)
%
I
.
(
e
:
expr
_
)
P
Q
:
iProp
Σ
:=
((
P
={
Eo
,
Ei
}=>
∃
x
:
A
,
α
x
★
((
α
x
={
Ei
,
Eo
}=
★
P
)
∧
(
∀
v
,
β
x
v
={
Ei
,
Eo
}=
★
Q
x
v
))
)
-
★
{{
P
}}
e
@
⊤
{{
v
,
(
∃
x
:
A
,
Q
x
v
)
}}
)
%
I
.
Lemma
atomic_triple_weaken
α
β
Ei
Eo
e
:
atomic_triple
α
β
Ei
Eo
e
⊢
atomic_triple_wp
α
β
Ei
Eo
e
.
Proof
.
iIntros
"H"
.
iIntros
(
P
Q
)
"Hvs Hp"
.
by
iApply
(
"H"
$
!
P
Q
with
"Hvs"
).
Qed
.
(
*
logically
atomic
triple
:
<
x
,
α
>
e
@
E_i
,
E_o
<
v
,
β
x
v
>
*
)
Definition
atomic_triple
α
β
Ei
Eo
e
:=
(
∀
P
Q
,
atomic_triple_base
α
β
Ei
Eo
e
P
Q
)
%
I
.
Arguments
atomic_triple
{
_
}
_
_
_
_.
End
atomic
.
...
...
@@ -57,11 +40,11 @@ Section incr.
(
*
TODO
:
Can
we
have
a
more
WP
-
style
definition
and
avoid
the
equality
?
*
)
Definition
incr_triple
(
l
:
loc
)
:=
atomic_triple
(
fun
(
v
:
Z
)
=>
l
↦
#
v
)
%
I
(
fun
v
ret
=>
ret
=
#
v
★
l
↦
#(
v
+
1
))
%
I
(
nclose
heapN
)
⊤
(
incr
#
l
).
atomic_triple
_
(
fun
(
v
:
Z
)
=>
l
↦
#
v
)
%
I
(
fun
v
ret
=>
ret
=
#
v
★
l
↦
#(
v
+
1
))
%
I
(
nclose
heapN
)
⊤
(
incr
#
l
).
Lemma
incr_atomic_spec
:
∀
(
l
:
loc
),
heapN
⊥
N
→
heap_ctx
⊢
incr_triple
l
.
Proof
.
...
...
atomic_sync.v
View file @
ade8f525
...
...
@@ -13,9 +13,7 @@ Instance subG_syncΣ {Σ} : subG syncΣ Σ → syncG Σ.
Proof
.
by
intros
?%
subG_inG
.
Qed
.
Section
atomic_sync
.
Context
`
{!
heapG
Σ
,
!
lockG
Σ
,
!
inG
Σ
(
prodR
fracR
(
dec_agreeR
val
))
}
(
N
:
namespace
).
Definition
A
:=
val
.
(
*
FIXME
:
can
'
t
use
a
general
A
instead
of
val
*
)
Context
`
{
EqDecision
A
,
!
heapG
Σ
,
!
lockG
Σ
,
!
inG
Σ
(
prodR
fracR
(
dec_agreeR
A
))
}
(
N
:
namespace
).
Definition
gHalf
(
γ
:
gname
)
g
:
iProp
Σ
:=
own
γ
((
1
/
2
)
%
Qp
,
DecAgree
g
).
...
...
@@ -24,15 +22,16 @@ Section atomic_sync.
(
β
:
val
→
A
→
A
→
val
→
iProp
Σ
)
(
Ei
Eo
:
coPset
)
(
f
x
:
val
)
γ
:
iProp
Σ
:=
(
∀
P
Q
,
(
∀
g
,
(
P
x
={
Eo
,
Ei
}
=>
gHalf
γ
g
★
□
α
x
)
★
(
gHalf
γ
g
★
□
α
x
={
Ei
,
Eo
}=>
P
x
)
★
(
∀
g
'
r
,
gHalf
γ
g
'
★
β
x
g
g
'
r
={
Ei
,
Eo
}=>
Q
x
r
))
-
★
{{
P
x
}}
f
x
{{
v
,
Q
x
v
}}
)
%
I
.
Definition
sync
(
syncer
:
val
)
:
val
:=
(
∀
P
Q
,
atomic_triple_base
A
(
fun
g
=>
gHalf
γ
g
★
□
α
x
)
(
fun
g
v
=>
∃
g
'
:
A
,
gHalf
γ
g
'
★
β
x
g
g
'
v
)
Ei
Eo
(
f
x
)
(
P
x
)
(
fun
_
=>
Q
x
)
)
%
I
.
Definition
sync
(
mk_
syncer
:
val
)
:
val
:=
λ
:
"f_cons"
"f_seq"
,
let:
"l"
:=
"f_cons"
#()
in
syncer
(
"f_seq"
"l"
).
let:
"l"
:=
"f_cons"
#()
in
let:
"s"
:=
mk_syncer
#()
in
"s"
(
"f_seq"
"l"
).
Definition
seq_spec
(
f
:
val
)
(
ϕ
:
val
→
A
→
iProp
Σ
)
α
β
(
E
:
coPset
)
:=
∀
(
Φ
:
val
→
iProp
Σ
)
(
l
:
val
),
...
...
@@ -48,55 +47,66 @@ Section atomic_sync.
⊢
WP
f
#()
{{
Φ
}}
.
Definition
synced
R
(
f
'
f
:
val
)
:=
(
∀
P
Q
(
x
:
val
),
(
{{
R
★
P
x
}}
f
x
{{
v
,
R
★
Q
x
v
}}
)
→
(
{{
P
x
}}
f
'
x
{{
v
,
Q
x
v
}}
))
%
I
.
(
□
∀
P
Q
(
x
:
val
),
(
{{
R
★
P
x
}}
f
x
{{
v
,
R
★
Q
x
v
}}
)
→
(
{{
P
x
}}
f
'
x
{{
v
,
Q
x
v
}}
))
%
I
.
Definition
is_syncer
(
R
:
iProp
Σ
)
(
s
:
val
)
:=
(
∀
(
f
:
val
),
WP
s
f
{{
f
'
,
synced
R
f
'
f
}}
)
%
I
.
Definition
mk_sync_spec
(
syncer
:
val
)
:=
∀
f
R
(
Φ
:
val
→
iProp
Σ
),
heapN
⊥
N
→
heap_ctx
★
R
★
(
∀
f
'
,
□
synce
d
R
f
'
f
-
★
Φ
f
'
)
⊢
WP
syncer
f
{{
Φ
}}
.
Definition
mk_sync
er
_spec
(
mk_
syncer
:
val
)
:=
∀
(
R
:
iProp
Σ
)
(
Φ
:
val
->
iProp
Σ
),
heapN
⊥
N
→
heap_ctx
★
R
★
(
∀
s
,
□
(
is_
synce
r
R
s
)
-
★
Φ
s
)
⊢
WP
mk_
syncer
#()
{{
Φ
}}
.
Lemma
atomic_spec
(
syncer
f_cons
f_seq
:
val
)
(
ϕ
:
val
→
A
→
iProp
Σ
)
α
β
Ei
:
Lemma
atomic_spec
(
mk_
syncer
f_cons
f_seq
:
val
)
(
ϕ
:
val
→
A
→
iProp
Σ
)
α
β
Ei
:
∀
(
g0
:
A
),
heapN
⊥
N
→
seq_spec
f_seq
ϕ
α
β
⊤
→
cons_spec
f_cons
g0
ϕ
→
mk_sync_spec
syncer
→
mk_sync
er
_spec
mk_
syncer
→
heap_ctx
⊢
WP
(
sync
syncer
)
f_cons
f_seq
{{
f
,
∃
γ
,
gHalf
γ
g0
★
∀
x
,
□
atomic_triple
'
α
β
Ei
⊤
f
x
γ
}}
.
⊢
WP
(
sync
mk_
syncer
)
f_cons
f_seq
{{
f
,
∃
γ
,
gHalf
γ
g0
★
∀
x
,
□
atomic_triple
'
α
β
Ei
⊤
f
x
γ
}}
.
Proof
.
iIntros
(
g0
HN
Hseq
Hcons
Hsync
)
"#Hh"
.
repeat
wp_let
.
wp_bind
(
f_cons
_
).
iApply
Hcons
=>
//. iFrame "Hh".
iIntros
(
l
γ
)
"Hϕ HFull HFrag"
.
wp_let
.
wp_bind
(
f_seq
_
)
%
E
.
iApply
wp_wand_r
.
iSplitR
;
first
by
iApply
(
Hseq
with
"[]"
)
=>
//.
iIntros
(
f
Hf
).
iApply
(
Hsync
f
(
∃
g
:
A
,
ϕ
l
g
★
gHalf
γ
g
)
%
I
)
=>
//.
iFrame
"#"
.
iSplitL
"HFull Hϕ"
.
wp_let
.
wp_bind
(
mk_syncer
_
).
iApply
(
Hsync
(
∃
g
:
A
,
ϕ
l
g
★
gHalf
γ
g
)
%
I
)
=>
//. iFrame "Hh".
iSplitL
"HFull Hϕ"
.
{
iExists
g0
.
by
iFrame
.
}
iIntros
(
f
'
)
"#Hflatten"
.
iIntros
(
s
)
"#Hsyncer"
.
wp_let
.
wp_bind
(
f_seq
_
).
iApply
wp_wand_r
.
iSplitR
;
first
by
iApply
(
Hseq
with
"[]"
)
=>
//.
iIntros
(
f
)
"%"
.
iApply
wp_wand_r
.
iSplitR
;
first
iApply
"Hsyncer"
.
iIntros
(
f
'
)
"#Hsynced"
.
iExists
γ
.
iFrame
.
iIntros
(
x
).
iAlways
.
rewrite
/
atomic_triple
'
.
iIntros
(
P
Q
)
"#Hvss"
.
rewrite
/
synced
.
iSpecialize
(
"Hflatten"
$
!
P
Q
).
iApply
(
"Hflatten"
with
"[]"
).
iAlways
.
iIntros
"[HR HP]"
.
iDestruct
"HR"
as
(
g
)
"[Hϕ HgFull]"
.
(
*
we
should
view
shift
at
this
point
*
)
iDestruct
(
"Hvss"
$
!
g
)
as
"[Hvs1 [Hvs2 Hvs3]]"
.
iApply
pvs_wp
.
iVs
(
"Hvs1"
with
"HP"
)
as
"[HgFrag #Hα]"
.
iVs
(
"Hvs2"
with
"[HgFrag]"
)
as
"HP"
;
first
by
iFrame
.
iVsIntro
.
iApply
Hf
=>
//.
iFrame
"Hh Hϕ"
.
iSplitR
;
first
done
.
iIntros
(
ret
g
'
)
"Hϕ' Hβ"
.
iVs
(
"Hvs1"
with
"HP"
)
as
"[HgFrag _]"
.
iCombine
"HgFull"
"HgFrag"
as
"Hg"
.
rewrite
/
gHalf
.
iAssert
(
|=
r
=>
own
γ
(((
1
/
2
)
%
Qp
,
DecAgree
g
'
)
⋅
((
1
/
2
)
%
Qp
,
DecAgree
g
'
)))
%
I
with
"[Hg]"
as
"Hupd"
.
{
iApply
(
own_update
);
last
by
iAssumption
.
apply
pair_l_frac_update
.
}
iVs
"Hupd"
as
"[HgFull HgFrag]"
.
iVs
(
"Hvs3"
$
!
g
'
ret
with
"[HgFrag Hβ]"
);
first
by
iFrame
.
iVsIntro
.
iSplitL
"HgFull Hϕ'"
.
-
iExists
g
'
.
by
iFrame
.
-
done
.
iSpecialize
(
"Hsynced"
$
!
P
Q
x
).
iIntros
"!# HP"
.
iApply
wp_wand_r
.
iSplitL
"HP"
.
-
iApply
(
"Hsynced"
with
"[]"
)
=>
//.
iAlways
.
iIntros
"[HR HP]"
.
iDestruct
"HR"
as
(
g
)
"[Hϕ Hg1]"
.
(
*
we
should
view
shift
at
this
point
*
)
iDestruct
(
"Hvss"
with
"HP"
)
as
"Hvss'"
.
iApply
pvs_wp
.
iVs
"Hvss'"
.
iDestruct
"Hvss'"
as
(
?
)
"[[Hg2 #Hα] [Hvs1 _]]"
.
iVs
(
"Hvs1"
with
"[Hg2]"
)
as
"HP"
;
first
by
iFrame
.
iVsIntro
.
iApply
H
=>
//.
iFrame
"Hh Hϕ"
.
iSplitR
;
first
done
.
iIntros
(
ret
g
'
)
"Hϕ' Hβ"
.
iVs
(
"Hvss"
with
"HP"
)
as
(
g
''
)
"[[Hg'' _] [_ Hvs2]]"
.
iSpecialize
(
"Hvs2"
$
!
ret
).
iDestruct
(
m_frag_agree
'
with
"[Hg'' Hg1]"
)
as
"[Hg %]"
;
first
iFrame
.
subst
.
rewrite
Qp_div_2
.
iAssert
(
|=
r
=>
own
γ
(((
1
/
2
)
%
Qp
,
DecAgree
g
'
)
⋅
((
1
/
2
)
%
Qp
,
DecAgree
g
'
)))
%
I
with
"[Hg]"
as
"==>[Hg1 Hg2]"
.
{
iApply
own_update
;
last
by
iAssumption
.
apply
cmra_update_exclusive
.
by
rewrite
pair_op
dec_agree_idemp
.
}
iVs
(
"Hvs2"
with
"[Hg1 Hβ]"
).
{
iExists
g
'
.
iFrame
.
}
iVsIntro
.
iSplitL
"Hg2 Hϕ'"
.
*
iExists
g
'
.
by
iFrame
.
*
done
.
-
iIntros
(
?
)
"?"
.
by
iExists
g0
.
Qed
.
End
atomic_sync
.
flat.v
View file @
ade8f525
...
...
@@ -6,50 +6,42 @@ From iris.algebra Require Import auth upred frac agree excl dec_agree upred_big_
From
iris_atomic
Require
Import
misc
atomic
treiber
atomic_sync
evmap
.
Definition
doOp
:
val
:=
λ
:
"f"
"p"
,
match:
!
"p"
with
InjL
"x"
=>
"p"
<-
InjR
(
"f"
"x"
)
|
InjR
"_"
=>
#()
end
.
Definition
doOp
'
(
f
:
val
)
:
val
:=
λ
:
"p"
,
match:
!
"p"
with
InjL
"
x
"
=>
"p"
<-
InjR
(
f
"x
"
)
InjL
"
req
"
=>
"p"
<-
InjR
(
(
Fst
"req"
)
(
Snd
"req
"
)
)
|
InjR
"_"
=>
#()
end
.
Definition
try_srv
:
val
:=
λ
:
"lk"
"s"
"f"
,
λ
:
"lk"
"s"
,
if:
try_acquire
"lk"
then
let
:
"hd"
:=
!
"s"
in
let:
"f'"
:=
doOp
"f"
in
iter
"hd"
"f'"
;;
iter
"hd"
doOp
;;
release
"lk"
else
#().
Definition
loop
:
val
:=
rec:
"loop"
"f"
"p"
"s"
"lk"
:=
rec:
"loop"
"p"
"s"
"lk"
:=
match:
!
"p"
with
InjL
"_"
=>
try_srv
"lk"
"s"
"f"
;;
"loop"
"f"
"p"
"s"
"lk"
try_srv
"lk"
"s"
;;
"loop"
"p"
"s"
"lk"
|
InjR
"r"
=>
"r"
end
.
Definition
install
:
val
:=
λ
:
"x"
"s"
,
let:
"p"
:=
ref
(
InjL
"x"
)
in
λ
:
"f"
"x"
"s"
,
let:
"p"
:=
ref
(
InjL
(
"f"
,
"x"
)
)
in
push
"s"
"p"
;;
"p"
.
Definition
mk_flat
:
val
:=
λ
:
"f"
,
λ
:
<>
,
let:
"lk"
:=
newlock
#()
in
let:
"s"
:=
new_stack
#()
in
λ
:
"x"
,
let:
"p"
:=
install
"x"
"s"
in
let:
"r"
:=
loop
"f"
"p"
"s"
"lk"
in
λ
:
"f"
"x"
,
let:
"p"
:=
install
"f"
"x"
"s"
in
let:
"r"
:=
loop
"p"
"s"
"lk"
in
"r"
.
Global
Opaque
doOp
try_srv
install
loop
mk_flat
.
...
...
@@ -74,15 +66,15 @@ Proof. intros [?%subG_inG [?%subG_inG [? _]%subG_inv]%subG_inv]%subG_inv. split;
Section
proof
.
Context
`
{!
heapG
Σ
,
!
lockG
Σ
,
!
evidenceG
loc
val
unitR
Σ
,
!
flatG
Σ
}
(
N
:
namespace
).
Context
(
R
:
iProp
Σ
).
Definition
init_s
(
ts
:
toks
)
:=
let
'
(
_
,
γ
1
,
γ
3
,
_
,
_
)
:=
ts
in
(
own
γ
1
(
Excl
())
★
own
γ
3
(
Excl
()))
%
I
.
Definition
installed_s
(
ts
:
toks
)
(
f
x
:
val
)
:=
Definition
installed_s
R
(
ts
:
toks
)
(
f
x
:
val
)
:=
let
'
(
γ
x
,
γ
1
,
_
,
γ
4
,
γ
q
)
:=
ts
in
(
∃
(
P
:
val
→
iProp
Σ
)
Q
,
own
γ
x
((
1
/
2
)
%
Qp
,
DecAgree
x
)
★
P
x
★
(
{{
R
★
P
x
}}
f
x
{{
v
,
R
★
Q
x
v
}}
)
★
saved_prop_own
γ
q
(
Q
x
)
★
own
γ
1
(
Excl
())
★
own
γ
4
(
Excl
()))
%
I
.
(
∃
(
P
:
val
→
iProp
Σ
)
Q
,
own
γ
x
((
1
/
2
)
%
Qp
,
DecAgree
x
)
★
P
x
★
(
{{
R
★
P
x
}}
f
x
{{
v
,
R
★
Q
x
v
}}
)
★
saved_prop_own
γ
q
(
Q
x
)
★
own
γ
1
(
Excl
())
★
own
γ
4
(
Excl
()))
%
I
.
Definition
received_s
(
ts
:
toks
)
(
x
:
val
)
γ
r
:=
let
'
(
γ
x
,
_
,
_
,
γ
4
,
_
)
:=
ts
in
...
...
@@ -97,39 +89,38 @@ Section proof.
Definition
evm
:=
ev
loc
toks
.
(
*
p
slot
invariant
*
)
Definition
p_inv
(
γ
m
γ
r
:
gname
)
(
f
v
:
val
)
:=
Definition
p_inv
R
(
γ
m
γ
r
:
gname
)
(
v
:
val
)
:=
(
∃
(
ts
:
toks
)
(
p
:
loc
),
v
=
#
p
★
evm
γ
m
p
ts
★
((
*
INIT
*
)
(
∃
y
:
val
,
p
↦
{
1
/
2
}
InjRV
y
★
init_s
ts
)
∨
(
*
INSTALLED
*
)
(
∃
x
:
val
,
p
↦
{
1
/
2
}
InjLV
x
★
installed_s
ts
f
x
)
∨
(
∃
f
x
:
val
,
p
↦
{
1
/
2
}
InjLV
(
f
,
x
)
★
installed_s
R
ts
f
x
)
∨
(
*
RECEIVED
*
)
(
∃
x
:
val
,
p
↦
{
1
/
2
}
InjLV
x
★
received_s
ts
x
γ
r
)
∨
(
∃
f
x
:
val
,
p
↦
{
1
/
2
}
InjLV
(
f
,
x
)
★
received_s
ts
x
γ
r
)
∨
(
*
FINISHED
*
)
(
∃
x
y
:
val
,
p
↦
{
1
/
2
}
InjRV
y
★
finished_s
ts
x
y
)))
%
I
.
Definition
srv_stack_inv
γ
s
γ
m
γ
r
s
f
:=
(
∃
xs
,
is_stack
'
(
p_inv
γ
m
γ
r
f
)
γ
s
xs
s
)
%
I
.
Definition
srv_stack_inv
R
γ
s
γ
m
γ
r
s
:=
(
∃
xs
,
is_stack
'
(
p_inv
R
γ
m
γ
r
)
γ
s
xs
s
)
%
I
.
Definition
srv_tokm_inv
γ
m
:=
(
∃
m
:
tokmR
,
own
γ
m
(
●
m
)
★
[
★
map
]
p
↦
_
∈
m
,
∃
v
,
p
↦
{
1
/
2
}
v
)
%
I
.
Lemma
install_push_spec
(
Φ
:
val
→
iProp
Σ
)
Lemma
install_push_spec
R
(
p
:
loc
)
(
γ
s
γ
m
γ
r
:
gname
)
(
ts
:
toks
)
(
s
:
loc
)
(
f
x
:
val
)
:
(
s
:
loc
)
(
f
x
:
val
)
(
Φ
:
val
→
iProp
Σ
)
:
heapN
⊥
N
→
heap_ctx
★
inv
N
(
srv_stack_inv
γ
s
γ
m
γ
r
s
f
★
srv_tokm_inv
γ
m
)
★
evm
γ
m
p
ts
★
installed_s
ts
f
x
★
p
↦
{
1
/
2
}
InjLV
x
★
((
∃
hd
,
evs
γ
s
hd
#
p
)
-
★
Φ
#())
heap_ctx
★
inv
N
(
srv_stack_inv
R
γ
s
γ
m
γ
r
s
★
srv_tokm_inv
γ
m
)
★
evm
γ
m
p
ts
★
installed_s
R
ts
f
x
★
p
↦
{
1
/
2
}
InjLV
(
f
,
x
)
★
((
∃
hd
,
evs
γ
s
hd
#
p
)
-
★
Φ
#())
⊢
WP
push
#
s
#
p
{{
Φ
}}
.
Proof
.
iIntros
(
HN
)
"(#Hh & #? & Hpm & Hs & Hp & HΦ)"
.
rewrite
/
srv_stack_inv
.
iDestruct
(
push_spec
N
(
p_inv
γ
m
γ
r
f
)
(
fun
v
=>
(
∃
hd
,
evs
γ
s
hd
#
p
)
★
v
=
#())
%
I
iDestruct
(
push_spec
N
(
p_inv
R
γ
m
γ
r
)
(
fun
v
=>
(
∃
hd
,
evs
γ
s
hd
#
p
)
★
v
=
#())
%
I
with
"[-HΦ]"
)
as
"Hpush"
=>
//.
-
iFrame
"Hh"
.
iSplitL
"Hp Hs Hpm"
;
last
eauto
.
iExists
ts
.
iExists
p
.
iSplit
=>
//. iFrame "Hpm".
iRight
.
iLeft
.
iExists
x
.
iFrame
.
iRight
.
iLeft
.
iExists
f
,
x
.
iFrame
.
-
iApply
wp_wand_r
.
iSplitL
"Hpush"
;
first
done
.
iIntros
(
?
)
"[? %]"
.
subst
.
...
...
@@ -141,15 +132,17 @@ Section proof.
(
own
γ
3
(
Excl
())
★
own
γ
x
((
1
/
2
)
%
Qp
,
DecAgree
x
)
★
saved_prop_own
γ
q
(
Q
x
))
%
I
.
Lemma
install_spec
(
Φ
:
val
→
iProp
Σ
)
P
Q
(
f
x
:
val
)
(
γ
s
γ
m
γ
r
:
gname
)
(
s
:
loc
)
:
R
P
Q
(
f
x
:
val
)
(
γ
s
γ
m
γ
r
:
gname
)
(
s
:
loc
)
(
Φ
:
val
→
iProp
Σ
)
:
heapN
⊥
N
→
heap_ctx
★
inv
N
(
srv_stack_inv
γ
s
γ
m
γ
r
s
f
★
srv_tokm_inv
γ
m
)
★
P
x
★
(
{{
R
★
P
x
}}
f
x
{{
v
,
R
★
Q
x
v
}}
)
★
heap_ctx
★
inv
N
(
srv_stack_inv
R
γ
s
γ
m
γ
r
s
★
srv_tokm_inv
γ
m
)
★
P
x
★
(
{{
R
★
P
x
}}
f
x
{{
v
,
R
★
Q
x
v
}}
)
★
(
∀
(
p
:
loc
)
(
ts
:
toks
),
installed_recp
ts
x
Q
-
★
evm
γ
m
p
ts
-
★
(
∃
hd
,
evs
γ
s
hd
#
p
)
-
★
Φ
#
p
)
⊢
WP
install
x
#
s
{{
Φ
}}
.
⊢
WP
install
f
x
#
s
{{
Φ
}}
.
Proof
.
iIntros
(
HN
)
"(#Hh & #? & Hpx & Hf & HΦ)"
.
wp_seq
.
wp_let
.
wp_alloc
p
as
"Hl"
.
wp_seq
.
wp_let
.
wp_let
.
wp_alloc
p
as
"Hl"
.
iApply
pvs_wp
.
iVs
(
own_alloc
(
Excl
()))
as
(
γ
1
)
"Ho1"
;
first
done
.
iVs
(
own_alloc
(
Excl
()))
as
(
γ
3
)
"Ho3"
;
first
done
.
...
...
@@ -181,20 +174,20 @@ Section proof.
by
iApply
(
"HΦ"
with
"[]"
).
Qed
.
Lemma
loop_iter_
list
_spec
Φ
(
f
:
val
)
(
s
hd
:
loc
)
(
γ
s
γ
m
γ
r
:
gname
)
xs
:
Lemma
loop_iter_
doOp
_spec
R
(
s
hd
:
loc
)
(
γ
s
γ
m
γ
r
:
gname
)
xs
Φ
:
heapN
⊥
N
→
heap_ctx
★
inv
N
(
srv_stack_inv
γ
s
γ
m
γ
r
s
f
★
srv_tokm_inv
γ
m
)
★
own
γ
r
(
Excl
())
★
R
★
heap_ctx
★
inv
N
(
srv_stack_inv
R
γ
s
γ
m
γ
r
s
★
srv_tokm_inv
γ
m
)
★
own
γ
r
(
Excl
())
★
R
★
is_list
'
γ
s
hd
xs
★
(
own
γ
r
(
Excl
())
-
★
R
-
★
Φ
#())
⊢
WP
doOp
f
{{
f
'
,
WP
iter
#
hd
f
'
{{
Φ
}}
}}
.
⊢
WP
iter
#
hd
doOp
{{
Φ
}}
.
Proof
.
iIntros
(
HN
)
"(#Hf & #? & Ho2 & HR & Hlist' & HΦ)"
.
iApply
pvs_wp
.
iDestruct
(
dup_is_list
'
with
"[Hlist']"
)
as
"==>[Hl1 Hl2]"
;
first
by
iFrame
.
iDestruct
(
dup_is_list
'
with
"[Hl2]"
)
as
"==>[Hl2 Hl3]"
;
first
by
iFrame
.
iVsIntro
.
wp_seq
.
iDestruct
(
iter_spec
_
(
p_inv
γ
m
γ
r
f
)
(
fun
v
=>
v
=
#()
★
own
γ
r
(
Excl
())
★
R
)
%
I
γ
s
s
iVsIntro
.
iDestruct
(
iter_spec
_
(
p_inv
R
γ
m
γ
r
)
(
fun
v
=>
v
=
#()
★
own
γ
r
(
Excl
())
★
R
)
%
I
γ
s
s
(
is_list
'
γ
s
hd
xs
★
own
γ
r
(
Excl
())
★
R
)
%
I
(
srv_tokm_inv
γ
m
)
xs
hd
(
doOp
'
f
)
(
doOp
'
f
)
doOp
doOp
with
"[-Hl1 HΦ]"
)
as
"Hiter"
=>
//.
-
rewrite
/
f_spec
.
iIntros
(
Φ'
p
_
Hin
)
"(#Hh & #? & (Hls & Ho2 & HR) & HΦ')"
.
...
...
@@ -214,9 +207,9 @@ Section proof.
iFrame
.
iExists
#
p
''
.
iSplitR
;
first
done
.
iExists
ts
,
p
''
.
iSplitR
;
first
done
.
iFrame
"#"
.
iLeft
.
iExists
y
.
iFrame
.
}
iVsIntro
.
wp_match
.
iApply
"HΦ'"
.
by
iFrame
.
+
iDestruct
"Hp"
as
(
x
'
)
"(Hp & Hs)"
.
+
iDestruct
"Hp"
as
(
f
'
x
'
)
"(Hp & Hs)"
.
wp_load
.
destruct
ts
as
[[[[
γ
x
γ
1
]
γ
3
]
γ
4
]
γ
q
].
iDestruct
"Hs"
as
(
P
Q
)
"(Hx & Hpx & Hf & HoQ& Ho1 & Ho4)"
.
iDestruct
"Hs"
as
(
P
Q
)
"(Hx & Hpx & Hf & HoQ& Ho1 & Ho4)"
.
iAssert
(
|=
r
=>
own
γ
x
(((
1
/
2
/
2
)
%
Qp
,
DecAgree
x
'
)
⋅
((
1
/
2
/
2
)
%
Qp
,
DecAgree
x
'
)))
%
I
with
"[Hx]"
as
"==>[Hx1 Hx2]"
.
{
iDestruct
(
own_update
with
"Hx"
)
as
"?"
;
last
by
iAssumption
.
...
...
@@ -228,9 +221,10 @@ Section proof.
iFrame
"Hom"
.
iDestruct
(
big_sepM_delete
_
m
with
"[-]"
)
as
"?"
=>
//.
simpl
.
iFrame
.
iExists
#
p
''
.
iSplitR
;
auto
.
rewrite
/
allocated
.
iExists
(
γ
x
,
γ
1
,
γ
3
,
γ
4
,
γ
q
),
p
''
.
iSplitR
;
auto
.
iFrame
"#"
.
iRight
.
iRight
.
iLeft
.
iExists
x
'
.
iFrame
.
}
iFrame
"#"
.
iRight
.
iRight
.
iLeft
.
iExists
f
'
,
x
'
.
iFrame
.
}
iVsIntro
.
wp_match
.
wp_bind
(
f
_
).
iApply
wp_wand_r
.
iSplitL
"Hpx Hf HR"
.
wp_proj
.
wp_proj
.
wp_bind
(
f
'
_
).
iApply
wp_wand_r
.
iSplitL
"Hpx Hf HR"
.
{
iApply
"Hf"
.
iFrame
.
}
iIntros
(
v
)
"[HR HQ]"
.
wp_value
.
iVsIntro
.
iInv
N
as
"[Hs >Hm]"
"Hclose"
.
...
...
@@ -246,9 +240,9 @@ Section proof.
iDestruct
"Hps"
as
"[Hp | [Hp | [Hp | Hp]]]"
.
*
iDestruct
"Hp"
as
(
?
)
"(_ & >Ho1' & _)"
.
iApply
excl_falso
.
iFrame
.
*
iDestruct
"Hp"
as
(
?
)
"[>? Hs]"
.
iDestruct
"Hs"
as
(
?
?
)
"(_ & _ & _ & _ & >Ho1' & _)"
.
*
iDestruct
"Hp"
as
(
?
?
)
"[>? Hs]"
.
iDestruct
"Hs"
as
(
?
?
)
"(_ & _ & _ & _ & >Ho1' & _)"
.
iApply
excl_falso
.
iFrame
.
*
iDestruct
"Hp"
as
(
x5
)
">(Hp & Hx & Ho2 & Ho4)"
.
*
iDestruct
"Hp"
as
(
?
x5
)
">(Hp & Hx & Ho2 & Ho4)"
.
iDestruct
"Hm"
as
(
m2
)
"[Hom2 HRm]"
.
destruct
(
m2
!!
p
''''
)
eqn
:
Heqn
.
{
...
...
@@ -257,7 +251,7 @@ Section proof.
iDestruct
(
heap_mapsto_op_1
with
"[HRk Hp]"
)
as
"[% Hp]"
;
first
by
iFrame
.
rewrite
Qp_div_2
.
wp_store
.
(
*
now
close
the
invariant
*
)
iDestruct
(
m_frag_agree
with
"[Hx Hx2]"
)
as
"
==>
[Hx %]"
;
first
iFrame
.
iDestruct
(
m_frag_agree
'
with
"[Hx Hx2]"
)
as
"[Hx %]"
;
first
iFrame
.
subst
.
rewrite
Qp_div_2
.
iVs
(
"Hclose"
with
"[-HΦ' Ho2 HR Hls3]"
).
{
iNext
.
iDestruct
"Hp"
as
"[Hp1 Hp2]"
.
iAssert
(
srv_tokm_inv
γ
m
)
with
"[Hp1 HRm Hom2]"
as
"HRm"
.
...
...
@@ -281,7 +275,7 @@ Section proof.
}
{
iDestruct
(
evmap_frag_agree_split
with
"[]"
)
as
"%"
;
first
iFrame
"Hevm Hevm2"
.
inversion
H4
.
subst
.
by
contradiction
Hneq
.
}
+
destruct
ts
as
[[[[
γ
x
γ
1
]
γ
3
]
γ
4
]
γ
q
].
iDestruct
"Hp"
as
(
y
)
"(_ & _ & >Ho2' & _)"
.
+
destruct
ts
as
[[[[
γ
x
γ
1
]
γ
3
]
γ
4
]
γ
q
].
iDestruct
"Hp"
as
(
?
x
)
"(_ & _ & >Ho2' & _)"
.
iApply
excl_falso
.
iFrame
.
+
destruct
ts
as
[[[[
γ
x
γ
1
]
γ
3
]
γ
4
]
γ
q
].
iDestruct
"Hp"
as
(
x
'
y
)
"[Hp Hs]"
.
iDestruct
"Hs"
as
(
Q
)
"(>Hx & HoQ & HQxy & >Ho1 & >Ho4)"
.
...
...
@@ -304,15 +298,14 @@ Section proof.
let
'
(
γ
x
,
_
,
_
,
_
,
γ
q
)
:=
ts
in
(
∃
Q
,
own
γ
x
((
1
/
2
)
%
Qp
,
DecAgree
x
)
★
saved_prop_own
γ
q
(
Q
x
)
★
Q
x
y
)
%
I
.
Lemma
try_srv_spec
Φ
(
s
:
loc
)
(
lk
:
val
)
(
f
:
val
)
(
γ
s
γ
r
γ
m
γ
lk
:
gname
)
:
Lemma
try_srv_spec
R
(
s
:
loc
)
(
lk
:
val
)
(
γ
s
γ
r
γ
m
γ
lk
:
gname
)
Φ
:
heapN
⊥
N
→
heap_ctx
★
inv
N
(
srv_stack_inv
γ
s
γ
m
γ
r
s
f
★
srv_tokm_inv
γ
m
)
★
heap_ctx
★
inv
N
(
srv_stack_inv
R
γ
s
γ
m
γ
r
s
★
srv_tokm_inv
γ
m
)
★
is_lock
N
γ
lk
lk
(
own
γ
r
(
Excl
())
★
R
)
★
Φ
#()
⊢
WP
try_srv
lk
#
s
f
{{
Φ
}}
.
⊢
WP
try_srv
lk
#
s
{{
Φ
}}
.
Proof
.
iIntros
(
?
)
"(#? & #? & #? & HΦ)"
.
wp_seq
.
wp_let
.
wp_let
.
wp_seq
.
wp_let
.
wp_bind
(
try_acquire
_
).
iApply
try_acquire_spec
.
iFrame
"#"
.
iSplit
;
last
by
wp_if
.
(
*
acquired
the
lock
*
)
...
...
@@ -323,26 +316,24 @@ Section proof.
wp_load
.
iDestruct
(
dup_is_list
'
with
"[Hxs]"
)
as
"==>[Hxs1 Hxs2]"
;
first
by
iFrame
.
iVs
(
"Hclose"
with
"[Hs Hxs1 HRs Hm]"
).
{
iNext
.
iFrame
.
iExists
xs
'
,
hd
'
.
by
iFrame
.
}
iVsIntro
.
wp_let
.
wp_bind
(
doOp
f
).
iVsIntro
.
wp_let
.
wp_bind
(
iter
_
_
).
iApply
wp_wand_r
.
iSplitL
"HR Ho2 Hxs2"
.
{
iApply
(
loop_iter_
list
_spec
(
fun
v
=>
own
γ
r
(
Excl
())
★
R
★
v
=
#()))
%
I
=>
//.
{
iApply
(
loop_iter_
doOp
_spec
R
_
_
_
_
_
_
(
fun
v
=>
own
γ
r
(
Excl
())
★
R
★
v
=
#()))
%
I
=>
//.
iFrame
"#"
.
iFrame
.
iIntros
"? ?"
.
by
iFrame
.
}
iIntros
(
f
'
)
"Hf'"
.
wp_let
.
wp_bind
((
iter
_
)
_
).
iApply
wp_wand_r
.
iSplitL
"Hf'"
;
first
iApply
"Hf'"
.
iIntros
(
?
)
"[Ho2 [HR %]]"
.
subst
.
wp_seq
.
iApply
release_spec
.
iFrame
"#"
.
iFrame
.
iIntros
(
f
'
)
"[Ho [HR %]]"
.
subst
.
wp_let
.
iApply
release_spec
.
iFrame
"#"
.
iFrame
.
Qed
.
Lemma
loop_spec
Φ
(
p
s
:
loc
)
(
lk
:
val
)
(
f
:
val
)
(
γ
s
γ
r
γ
m
γ
lk
:
gname
)
(
ts
:
toks
)
:
Lemma
loop_spec
R
(
p
s
:
loc
)
(
lk
:
val
)
(
γ
s
γ
r
γ
m
γ
lk
:
gname
)
(
ts
:
toks
)
Φ
:
heapN
⊥
N
→
heap_ctx
★
inv
N
(
srv_stack_inv
γ
s
γ
m
γ
r
s
f
★
srv_tokm_inv
γ
m
)
★
heap_ctx
★
inv
N
(
srv_stack_inv
R
γ
s
γ
m
γ
r
s
★
srv_tokm_inv
γ
m
)
★
is_lock
N
γ
lk
lk
(
own
γ
r
(
Excl
())
★
R
)
★
own_
γ
3
ts
★
evm
γ
m
p
ts
★
(
∃
hd
,
evs
γ
s
hd
#
p
)
★
(
∀
x
y
,
finished_recp
ts
x
y
-
★
Φ
y
)
⊢
WP
loop
f
#
p
#
s
lk
{{
Φ
}}
.
⊢
WP
loop
#
p
#
s
lk
{{
Φ
}}
.
Proof
.
iIntros
(
HN
)
"(#Hh & #? & #? & Ho3 & #Hev & Hhd & HΦ)"
.
iL
ö
b
as
"IH"
.
wp_rec
.
repeat
wp_let
.
...
...
@@ -361,28 +352,28 @@ Section proof.
iDestruct
"Hp"
as
"[Hp | [Hp | [ Hp | Hp]]]"
.
+
iDestruct
"Hp"
as
(
?
)
"(_ & _ & >Ho3')"
.
iApply
excl_falso
.
iFrame
.
+
iDestruct
"Hp"
as
(
x
)
"(>Hp & Hs')"
.
+
iDestruct
"Hp"
as
(
f
x
)
"(>Hp & Hs')"
.
wp_load
.
iVs
(
"Hclose"
with
"[-Ho3 HΦ Hhd]"
).
{
iNext
.
iFrame
.
iExists
xs
,
hd
.
iFrame
.
iExists
m
.
iFrame
.
iDestruct
(
big_sepM_delete
_
m
with
"[-]"
)
as
"?"
=>
//.
iFrame
.
iExists
#
p
'
.
iSplitR
;
first
auto
.
iExists
(
γ
x
,
γ
1
,
γ
3
,
γ
4
,
γ
q
),
p
'
.
iSplitR
;
first
auto
.
iFrame
.
iRight
.
iLeft
.
iExists
x
.
iFrame
.
}
iRight
.
iLeft
.
iExists
f
,
x
.
iFrame
.
}
iVsIntro
.
wp_match
.
wp_bind
(
try_srv
_
_
_
).
iApply
try_srv_spec
=>
//.
wp_bind
(
try_srv
_
_
).
iApply
try_srv_spec
=>
//.
iFrame
"#"
.
wp_seq
.
iAssert
(
∃
hd
,
evs
γ
s
hd
#
p
'
)
%
I
with
"[Hhd]"
as
"Hhd"
;
eauto
.
by
iApply
(
"IH"
with
"Ho3 Hhd"
).
+
iDestruct
"Hp"
as
(
x
)
"(Hp & Hx & Ho2 & Ho4)"
.
+
iDestruct
"Hp"
as
(
f
x
)
"(Hp & Hx & Ho2 & Ho4)"
.
wp_load
.
iVs
(
"Hclose"
with
"[-Ho3 HΦ Hhd]"
).
{
iNext
.
iFrame
.
iExists
xs
,
hd
.
iFrame
.
iExists
m
.
iFrame
.
iDestruct
(
big_sepM_delete
_
m
with
"[-]"
)
as
"?"
=>
//.
iFrame
.
iExists
#
p
'
.
iSplitR
;
auto
.
iExists
(
γ
x
,
γ
1
,
γ
3
,
γ
4
,
γ
q
),
p
'
.
iSplitR
;
first
auto
.
iFrame
.
iRight
.
iRight
.
iLeft
.
iExists
x
.
iFrame
.
}
iRight
.
iRight
.
iLeft
.
iExists
f
,
x
.
iFrame
.
}
iVsIntro
.
wp_match
.
wp_bind
(
try_srv
_
_
_
).
iApply
try_srv_spec
=>
//.
wp_bind
(
try_srv
_
_
).
iApply
try_srv_spec
=>
//.
iFrame
"#"
.
wp_seq
.
iAssert
(
∃
hd
,
evs
γ
s
hd
#
p
'
)
%
I
with
"[Hhd]"
as
"Hhd"
;
eauto
.
by
iApply
(
"IH"
with
"Ho3 Hhd"
).
...
...
@@ -399,12 +390,9 @@ Section proof.
rewrite
/
ev
.
eauto
.
Qed
.
Lemma
mk_flat_spec
(
f
:
val
)
:
∀
(
Φ
:
val
→
iProp
Σ
),
heapN
⊥
N
→
heap_ctx
★
R
★
(
∀
f
'
,
□
synced
R
f
'
f
-
★
Φ
f
'
)
⊢
WP
mk_flat
f
{{
Φ
}}
.
Lemma
mk_flat_spec
:
mk_syncer_spec
N
mk_flat
.
Proof
.
iIntros
(
Φ
HN
)
"(#Hh & HR & HΦ)"
.
iIntros
(
R
Φ
HN
)
"(#Hh & HR & HΦ)"
.
iVs
(
own_alloc
(
Excl
()))
as
(
γ
r
)
"Ho2"
;
first
done
.
iVs
(
own_alloc
(
●
(
∅
:
tokmR
)
⋅
◯
∅
))
as
(
γ
m
)
"[Hm _]"
;
first
by
rewrite
-
auth_both_op
.
iAssert
(
srv_tokm_inv
γ
m
)
with
"[Hm]"
as
"Hm"
;
first
eauto
.
...
...
@@ -413,16 +401,18 @@ Section proof.
iApply
(
newlock_spec
_
(
own
γ
r
(
Excl
())
★
R
))
%
I
=>
//.
iFrame
"Hh Ho2 HR"
.
iIntros
(
lk
γ
lk
)
"#Hlk"
.
wp_let
.
wp_bind
(
new_stack
_
).
iApply
(
new_stack_spec
'
_
(
p_inv
γ
m
γ
r
f
))
=>
//.
iApply
(
new_stack_spec
'
_
(
p_inv
_
γ
m
γ
r
))
=>
//.
iFrame
"Hh Hm"
.
iIntros
(
γ
s
)
"#Hss"
.
wp_let
.
iVsIntro
.
iApply
"HΦ"
.
rewrite
/
synced
.
iAlways
.
iIntros
(
P
Q
x
)
"#Hf"
.
iAlways
.
iIntros
(
f
).
wp_let
.
iVsIntro
.
iAlways
.
iIntros
(
P
Q
x
)
"#Hf"
.
iIntros
"!# Hp"
.
wp_let
.
wp_bind
(
(
install
_
)
_
).
iApply
(
install_spec
_
P
Q
)
=>
//.
wp_bind
(
install
_
_
_
).
iApply
(
install_spec
R
P
Q
)
=>
//.
iFrame
"#"
.
iFrame
"Hp"
.
iSplitR
;
first
iApply
"Hf"
.
iIntros
(
p
[[[[
γ
x
γ
1
]
γ
3
]
γ
4
]
γ
q
])
"(Ho3 & Hx & HoQ) Hev Hhd"
.
wp_let
.
wp_bind
(
loop
_
_
_
_
).
wp_let
.
wp_bind
(
loop
_
_
_
).
iApply
loop_spec
=>
//.
iFrame
"#"
.
iFrame
.