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
Simon Spies
examples
Commits
916f8b66
Commit
916f8b66
authored
Apr 01, 2018
by
Dan Frumin
Browse files
Add the fine-grained bag implementation
parent
b92b197b
Changes
5
Hide whitespace changes
Inline
Side-by-side
_CoqProject
View file @
916f8b66
...
...
@@ -72,5 +72,6 @@ theories/logrel/F_mu_ref_conc/examples/stack/refinement.v
theories/hocap/abstract_bag.v
theories/hocap/cg_bag.v
theories/hocap/fg_bag.v
theories/hocap/exclusive_bag.v
theories/hocap/shared_bag.v
theories/hocap/abstract_bag.v
View file @
916f8b66
...
...
@@ -31,15 +31,15 @@ Structure bag Σ `{!heapG Σ} := Bag {
{{{
True
}}}
newBag
#()
{{{
x
γ
,
RET
x
;
is_bag
N
γ
x
∗
bag_contents
γ
∅
}}}
;
pushBag_spec
N
P
Q
γ
b
v
:
□
(
∀
(
X
:
gmultiset
val
),
bag_contents
γ
X
∗
P
={
⊤
}=
∗
▷
(
bag_contents
γ
({[
v
]}
∪
X
)
∗
Q
))
-
∗
={
⊤
∖↑
N
}=
∗
▷
(
bag_contents
γ
({[
v
]}
∪
X
)
∗
Q
))
-
∗
{{{
is_bag
N
γ
b
∗
P
}}}
pushBag
b
(
of_val
v
)
{{{
RET
#()
;
Q
}}}
;
popBag_spec
N
P
Q
γ
b
:
□
(
∀
(
X
:
gmultiset
val
)
(
y
:
val
),
bag_contents
γ
({[
y
]}
∪
X
)
∗
P
={
⊤
}=
∗
▷
(
bag_contents
γ
X
∗
Q
(
SOMEV
y
)))
-
∗
□
(
bag_contents
γ
∅
∗
P
={
⊤
}=
∗
▷
(
bag_contents
γ
∅
∗
Q
NONEV
))
-
∗
={
⊤
∖↑
N
}=
∗
▷
(
bag_contents
γ
X
∗
Q
(
SOMEV
y
)))
-
∗
□
(
bag_contents
γ
∅
∗
P
={
⊤
∖↑
N
}=
∗
▷
(
bag_contents
γ
∅
∗
Q
NONEV
))
-
∗
{{{
is_bag
N
γ
b
∗
P
}}}
popBag
b
{{{
v
,
RET
v
;
Q
v
}}}
;
...
...
theories/hocap/cg_bag.v
View file @
916f8b66
...
...
@@ -61,44 +61,44 @@ Section proof.
Definition
bag_inv
(
γ
b
:
gname
)
(
b
:
loc
)
:
iProp
Σ
:
=
(
∃
ls
:
list
val
,
b
↦
(
val_of_list
ls
)
∗
own
γ
b
((
1
/
2
)%
Qp
,
to_agree
(
of_list
ls
)))%
I
.
Definition
is
B
ag
(
γ
b
:
gname
)
(
x
:
val
)
:
=
Definition
is
_b
ag
(
γ
b
:
gname
)
(
x
:
val
)
:
=
(
∃
(
lk
:
val
)
(
b
:
loc
)
(
γ
:
gname
),
⌜
x
=
PairV
#
b
lk
⌝
∗
is_lock
N
γ
lk
(
bag_inv
γ
b
b
))%
I
.
Definition
bag
C
ontents
(
γ
b
:
gname
)
(
X
:
gmultiset
val
)
:
iProp
Σ
:
=
Definition
bag
_c
ontents
(
γ
b
:
gname
)
(
X
:
gmultiset
val
)
:
iProp
Σ
:
=
own
γ
b
((
1
/
2
)%
Qp
,
to_agree
X
).
Global
Instance
is
B
ag_persistent
γ
b
x
:
Persistent
(
is
B
ag
γ
b
x
).
Global
Instance
is
_b
ag_persistent
γ
b
x
:
Persistent
(
is
_b
ag
γ
b
x
).
Proof
.
apply
_
.
Qed
.
Global
Instance
bag
C
ontents_timeless
γ
b
X
:
Timeless
(
bag
C
ontents
γ
b
X
).
Global
Instance
bag
_c
ontents_timeless
γ
b
X
:
Timeless
(
bag
_c
ontents
γ
b
X
).
Proof
.
apply
_
.
Qed
.
Lemma
bag
C
ontents_agree
γ
b
X
Y
:
bag
C
ontents
γ
b
X
-
∗
bag
C
ontents
γ
b
Y
-
∗
⌜
X
=
Y
⌝
.
Lemma
bag
_c
ontents_agree
γ
b
X
Y
:
bag
_c
ontents
γ
b
X
-
∗
bag
_c
ontents
γ
b
Y
-
∗
⌜
X
=
Y
⌝
.
Proof
.
rewrite
/
bag
C
ontents
.
apply
uPred
.
wand_intro_r
.
rewrite
/
bag
_c
ontents
.
apply
uPred
.
wand_intro_r
.
rewrite
-
own_op
own_valid
uPred
.
discrete_valid
.
f_equiv
=>
/=.
rewrite
pair_op
.
by
intros
[
_
?%
agree_op_invL'
].
Qed
.
Lemma
bag
C
ontents_update
γ
b
X
X'
Y
:
bag
C
ontents
γ
b
X
∗
bag
C
ontents
γ
b
X'
==
∗
bag
C
ontents
γ
b
Y
∗
bag
C
ontents
γ
b
Y
.
Lemma
bag
_c
ontents_update
γ
b
X
X'
Y
:
bag
_c
ontents
γ
b
X
∗
bag
_c
ontents
γ
b
X'
==
∗
bag
_c
ontents
γ
b
Y
∗
bag
_c
ontents
γ
b
Y
.
Proof
.
iIntros
"[Hb1 Hb2]"
.
iDestruct
(
bag
C
ontents_agree
with
"Hb1 Hb2"
)
as
%<-.
iDestruct
(
bag
_c
ontents_agree
with
"Hb1 Hb2"
)
as
%<-.
iMod
(
own_update_2
with
"Hb1 Hb2"
)
as
"Hb"
.
{
rewrite
pair_op
frac_op'
.
assert
((
1
/
2
+
1
/
2
)%
Qp
=
1
%
Qp
)
as
->
by
apply
Qp_div_2
.
by
apply
(
cmra_update_exclusive
(
1
%
Qp
,
to_agree
Y
)).
}
iDestruct
"Hb"
as
"[Hb1 Hb2]"
.
rewrite
/
bag
C
ontents
.
by
iFrame
.
rewrite
/
bag
_c
ontents
.
by
iFrame
.
Qed
.
Lemma
newBag_spec
:
{{{
True
}}}
newBag
#()
{{{
x
γ
,
RET
x
;
is
B
ag
γ
x
∗
bag
C
ontents
γ
∅
}}}.
{{{
x
γ
,
RET
x
;
is
_b
ag
γ
x
∗
bag
_c
ontents
γ
∅
}}}.
Proof
.
iIntros
(
Φ
)
"_ HΦ"
.
unfold
newBag
.
wp_rec
.
...
...
@@ -108,30 +108,31 @@ Section proof.
{
iExists
[].
iFrame
.
}
iIntros
(
lk
γ
)
"#Hlk"
.
iApply
wp_value
.
iApply
"HΦ"
.
rewrite
/
is
B
ag
/
bag
C
ontents
.
iFrame
.
rewrite
/
is
_b
ag
/
bag
_c
ontents
.
iFrame
.
iExists
_
,
_
,
_
.
by
iFrame
"Hlk"
.
Qed
.
Local
Opaque
acquire
release
.
(* so that wp_pure doesn't stumble *)
Lemma
pushBag_spec
(
P
Q
:
iProp
Σ
)
γ
(
x
v
:
val
)
:
□
(
∀
(
X
:
gmultiset
val
),
bag
C
ontents
γ
X
∗
P
={
⊤
}=
∗
▷
(
bag
C
ontents
γ
({[
v
]}
∪
X
)
∗
Q
))
-
∗
{{{
is
B
ag
γ
x
∗
P
}}}
□
(
∀
(
X
:
gmultiset
val
),
bag
_c
ontents
γ
X
∗
P
={
⊤
∖↑
N
}=
∗
▷
(
bag
_c
ontents
γ
({[
v
]}
∪
X
)
∗
Q
))
-
∗
{{{
is
_b
ag
γ
x
∗
P
}}}
pushBag
x
(
of_val
v
)
{{{
RET
#()
;
Q
}}}.
Proof
.
iIntros
"#Hvs"
.
iIntros
(
Φ
).
iAlways
.
iIntros
"[#Hbag HP] HΦ"
.
unfold
pushBag
.
do
2
wp_rec
.
rewrite
/
is
B
ag
/
bag_inv
.
rewrite
/
is
_b
ag
/
bag_inv
.
iDestruct
"Hbag"
as
(
lk
b
γ
l
)
"[% #Hlk]"
;
simplify_eq
/=.
repeat
wp_pure
_
.
wp_apply
(
acquire_spec
with
"Hlk"
).
iIntros
"[Htok Hb1]"
.
iDestruct
"Hb1"
as
(
ls
)
"[Hb Ha]"
.
wp_seq
.
wp_load
.
wp_let
.
(* iApply (wp_mask_mono _ (⊤∖↑N)); first done. *)
wp_bind
(
_
<-
_
)%
E
.
iApply
(
wp_mask_mono
_
(
⊤
∖↑
N
))
;
first
done
.
iMod
(
"Hvs"
with
"[$Ha $HP]"
)
as
"[Hbc HQ]"
.
wp_store
.
wp_store
.
wp_let
.
wp_apply
(
release_spec
with
"[$Hlk $Htok Hbc Hb]"
).
{
iExists
(
v
::
ls
)
;
iFrame
.
}
iIntros
"_"
.
by
iApply
"HΦ"
.
...
...
@@ -139,29 +140,31 @@ Section proof.
Lemma
popBag_spec
(
P
:
iProp
Σ
)
(
Q
:
val
→
iProp
Σ
)
γ
x
:
□
(
∀
(
X
:
gmultiset
val
)
(
y
:
val
),
bag
C
ontents
γ
({[
y
]}
∪
X
)
∗
P
={
⊤
}=
∗
▷
(
bag
C
ontents
γ
X
∗
Q
(
SOMEV
y
)))
-
∗
□
(
bag
C
ontents
γ
∅
∗
P
={
⊤
}=
∗
▷
(
bag
C
ontents
γ
∅
∗
Q
NONEV
))
-
∗
{{{
is
B
ag
γ
x
∗
P
}}}
bag
_c
ontents
γ
({[
y
]}
∪
X
)
∗
P
={
⊤
∖↑
N
}=
∗
▷
(
bag
_c
ontents
γ
X
∗
Q
(
SOMEV
y
)))
-
∗
□
(
bag
_c
ontents
γ
∅
∗
P
={
⊤
∖↑
N
}=
∗
▷
(
bag
_c
ontents
γ
∅
∗
Q
NONEV
))
-
∗
{{{
is
_b
ag
γ
x
∗
P
}}}
popBag
x
{{{
v
,
RET
v
;
Q
v
}}}.
Proof
.
iIntros
"#Hvs1 #Hvs2"
.
iIntros
(
Φ
).
iAlways
.
iIntros
"[#Hbag HP] HΦ"
.
unfold
popBag
.
wp_rec
.
rewrite
/
is
B
ag
/
bag_inv
.
rewrite
/
is
_b
ag
/
bag_inv
.
iDestruct
"Hbag"
as
(
lk
b
γ
l
)
"[% #Hlk]"
;
simplify_eq
/=.
repeat
wp_pure
_
.
wp_apply
(
acquire_spec
with
"Hlk"
).
iIntros
"[Htok Hb1]"
.
iDestruct
"Hb1"
as
(
ls
)
"[Hb Ha]"
.
wp_seq
.
wp_load
.
destruct
ls
as
[|
v
ls
]
;
simpl
.
wp_seq
.
wp_bind
(!#
b
)%
E
.
iApply
(
wp_mask_mono
_
(
⊤
∖↑
N
))
;
first
done
.
destruct
ls
as
[|
v
ls
]
;
simpl
.
-
iMod
(
"Hvs2"
with
"[$Ha $HP]"
)
as
"[Hbc HQ]"
.
repeat
wp_pure
_
.
wp_load
.
repeat
wp_pure
_
.
wp_apply
(
release_spec
with
"[$Hlk $Htok Hbc Hb]"
).
{
iExists
[]
;
iFrame
.
}
iIntros
"_"
.
repeat
wp_pure
_
.
by
iApply
"HΦ"
.
-
iMod
(
"Hvs1"
with
"[$Ha $HP]"
)
as
"[Hbc HQ]"
.
repeat
wp_pure
_
.
wp_store
.
do
2
wp_pure
_
.
wp_load
.
repeat
wp_pure
_
.
wp_store
.
do
2
wp_pure
_
.
wp_apply
(
release_spec
with
"[$Hlk $Htok Hbc Hb]"
).
{
iExists
ls
;
iFrame
.
}
iIntros
"_"
.
repeat
wp_pure
_
.
by
iApply
"HΦ"
.
...
...
@@ -169,14 +172,14 @@ Section proof.
End
proof
.
Typeclasses
Opaque
bag
C
ontents
is
B
ag
.
Typeclasses
Opaque
bag
_c
ontents
is
_b
ag
.
Canonical
Structure
cg_bag
`
{!
heapG
Σ
,
!
bagG
Σ
}
:
bag
Σ
:
=
{|
is_bag
:
=
is
B
ag
;
is_bag_persistent
:
=
is
B
ag_persistent
;
bag_contents_timeless
:
=
bag
C
ontents_timeless
;
bag_contents_agree
:
=
bag
C
ontents_agree
;
bag_contents_update
:
=
bag
C
ontents_update
;
{|
abstract_bag
.
is_bag
:
=
is
_b
ag
;
abstract_bag
.
is_bag_persistent
:
=
is
_b
ag_persistent
;
abstract_bag
.
bag_contents_timeless
:
=
bag
_c
ontents_timeless
;
abstract_bag
.
bag_contents_agree
:
=
bag
_c
ontents_agree
;
abstract_bag
.
bag_contents_update
:
=
bag
_c
ontents_update
;
abstract_bag
.
newBag_spec
:
=
newBag_spec
;
abstract_bag
.
pushBag_spec
:
=
pushBag_spec
;
abstract_bag
.
popBag_spec
:
=
popBag_spec
|}.
...
...
theories/hocap/fg_bag.v
0 → 100644
View file @
916f8b66
(** Concurrent bag specification from the HOCAP paper.
"Modular Reasoning about Separation of Concurrent Data Structures"
<http://www.kasv.dk/articles/hocap-ext.pdf>
Fine-grained implementation of a bag
*)
From
iris
.
program_logic
Require
Export
weakestpre
.
From
iris
.
heap_lang
Require
Export
lang
.
From
iris
.
proofmode
Require
Import
tactics
.
From
iris
.
heap_lang
Require
Import
proofmode
notation
.
From
iris
.
algebra
Require
Import
cmra
agree
frac
.
From
iris
.
heap_lang
.
lib
Require
Import
lock
spin_lock
.
From
iris_examples
.
hocap
Require
Import
abstract_bag
.
Set
Default
Proof
Using
"Type"
.
(** Coarse-grained bag implementation using a spin lock *)
Definition
newBag
:
val
:
=
λ
:
<>,
ref
NONE
.
Definition
pushBag
:
val
:
=
rec
:
"push"
"b"
"v"
:
=
let
:
"oHead"
:
=
!
"b"
in
if
:
CAS
"b"
"oHead"
(
SOME
(
ref
(
"v"
,
"oHead"
)))
then
#()
else
"push"
"b"
"v"
.
Definition
popBag
:
val
:
=
rec
:
"pop"
"b"
:
=
match
:
!
"b"
with
NONE
=>
NONE
|
SOME
"l"
=>
let
:
"hd"
:
=
!
"l"
in
let
:
"v"
:
=
Fst
"hd"
in
let
:
"tl"
:
=
Snd
"hd"
in
if
:
CAS
"b"
(
SOME
"l"
)
"tl"
then
SOME
"v"
else
"pop"
"b"
end
.
Canonical
Structure
valmultisetC
:
=
leibnizC
(
gmultiset
valC
).
Class
bagG
Σ
:
=
BagG
{
bag_bagG
:
>
inG
Σ
(
prodR
fracR
(
agreeR
valmultisetC
))
;
}.
(** Generic specification for the bag, using view shifts. *)
Section
proof
.
Context
`
{
heapG
Σ
,
bagG
Σ
}.
Variable
N
:
namespace
.
Definition
rown
(
l
:
loc
)
(
v
:
val
)
:
=
(
∃
q
,
l
↦
{
q
}
v
)%
I
.
Lemma
rown_duplicate
l
v
:
rown
l
v
-
∗
rown
l
v
∗
rown
l
v
.
Proof
.
iDestruct
1
as
(
q
)
"[Hl Hl']"
.
iSplitL
"Hl"
;
iExists
_;
eauto
.
Qed
.
Fixpoint
is_list
(
hd
:
val
)
(
xs
:
list
val
)
:
iProp
Σ
:
=
match
xs
with
|
[]
=>
⌜
hd
=
NONEV
⌝
%
I
|
x
::
xs
=>
(
∃
(
l
:
loc
)
(
tl
:
val
),
⌜
hd
=
SOMEV
#
l
⌝
∗
rown
l
(
x
,
tl
)
∗
is_list
tl
xs
)%
I
end
.
Lemma
is_list_duplicate
hd
xs
:
is_list
hd
xs
-
∗
is_list
hd
xs
∗
is_list
hd
xs
.
Proof
.
iInduction
xs
as
[
|
x
xs
]
"IH"
forall
(
hd
)
;
simpl
;
eauto
.
iDestruct
1
as
(
l
tl
)
"[% [Hro Htl]]"
;
simplify_eq
.
rewrite
rown_duplicate
.
iDestruct
"Hro"
as
"[Hro Hro']"
.
iDestruct
(
"IH"
with
"Htl"
)
as
"[Htl Htl']"
.
iSplitL
"Hro Htl"
;
iExists
_
,
_;
iFrame
;
eauto
.
Qed
.
Lemma
is_list_agree
hd
xs
ys
:
is_list
hd
xs
-
∗
is_list
hd
ys
-
∗
⌜
xs
=
ys
⌝
.
Proof
.
iInduction
xs
as
[
|
x
xs
]
"IH"
forall
(
hd
ys
)
;
simpl
;
eauto
.
-
iIntros
"%"
;
subst
.
destruct
ys
;
eauto
.
simpl
.
iDestruct
1
as
(?
?)
"[% ?]"
.
simplify_eq
.
-
iDestruct
1
as
(
l
tl
)
"(% & Hro & Hls)"
;
simplify_eq
.
destruct
ys
as
[|
y
ys
]
;
eauto
.
simpl
.
iDestruct
1
as
(
l'
tl'
)
"(% & Hro' & Hls')"
;
simplify_eq
.
iDestruct
"Hro"
as
(
q
)
"Hro"
.
iDestruct
"Hro'"
as
(
q'
)
"Hro'"
.
iDestruct
(
mapsto_agree
l'
q
q'
(
PairV
x
tl
)
(
PairV
y
tl'
)
with
"Hro Hro'"
)
as
%?.
simplify_eq
/=.
iDestruct
(
"IH"
with
"Hls Hls'"
)
as
%->.
done
.
Qed
.
Definition
bag_inv
(
γ
b
:
gname
)
(
b
:
loc
)
:
iProp
Σ
:
=
(
∃
(
hd
:
val
)
(
ls
:
list
val
),
b
↦
hd
∗
is_list
hd
ls
∗
own
γ
b
((
1
/
2
)%
Qp
,
to_agree
(
of_list
ls
)))%
I
.
Definition
is_bag
(
γ
b
:
gname
)
(
x
:
val
)
:
=
(
∃
(
b
:
loc
),
⌜
x
=
#
b
⌝
∗
inv
N
(
bag_inv
γ
b
b
))%
I
.
Definition
bag_contents
(
γ
b
:
gname
)
(
X
:
gmultiset
val
)
:
iProp
Σ
:
=
own
γ
b
((
1
/
2
)%
Qp
,
to_agree
X
).
Global
Instance
is_bag_persistent
γ
b
x
:
Persistent
(
is_bag
γ
b
x
).
Proof
.
apply
_
.
Qed
.
Global
Instance
bag_contents_timeless
γ
b
X
:
Timeless
(
bag_contents
γ
b
X
).
Proof
.
apply
_
.
Qed
.
Lemma
bag_contents_agree
γ
b
X
Y
:
bag_contents
γ
b
X
-
∗
bag_contents
γ
b
Y
-
∗
⌜
X
=
Y
⌝
.
Proof
.
rewrite
/
bag_contents
.
apply
uPred
.
wand_intro_r
.
rewrite
-
own_op
own_valid
uPred
.
discrete_valid
.
f_equiv
=>
/=.
rewrite
pair_op
.
by
intros
[
_
?%
agree_op_invL'
].
Qed
.
Lemma
bag_contents_update
γ
b
X
X'
Y
:
bag_contents
γ
b
X
∗
bag_contents
γ
b
X'
==
∗
bag_contents
γ
b
Y
∗
bag_contents
γ
b
Y
.
Proof
.
iIntros
"[Hb1 Hb2]"
.
iDestruct
(
bag_contents_agree
with
"Hb1 Hb2"
)
as
%<-.
iMod
(
own_update_2
with
"Hb1 Hb2"
)
as
"Hb"
.
{
rewrite
pair_op
frac_op'
.
assert
((
1
/
2
+
1
/
2
)%
Qp
=
1
%
Qp
)
as
->
by
apply
Qp_div_2
.
by
apply
(
cmra_update_exclusive
(
1
%
Qp
,
to_agree
Y
)).
}
iDestruct
"Hb"
as
"[Hb1 Hb2]"
.
rewrite
/
bag_contents
.
by
iFrame
.
Qed
.
Lemma
newBag_spec
:
{{{
True
}}}
newBag
#()
{{{
x
γ
,
RET
x
;
is_bag
γ
x
∗
bag_contents
γ
∅
}}}.
Proof
.
iIntros
(
Φ
)
"_ HΦ"
.
unfold
newBag
.
wp_rec
.
iApply
wp_fupd
.
wp_alloc
r
as
"Hr"
.
iMod
(
own_alloc
(
1
%
Qp
,
to_agree
∅
))
as
(
γ
b
)
"[Ha Hf]"
;
first
done
.
iMod
(
inv_alloc
N
_
(
bag_inv
γ
b
r
)
with
"[Ha Hr]"
)
as
"#Hinv"
.
{
iNext
.
iExists
_
,[].
simpl
.
iFrame
.
eauto
.
}
iModIntro
.
iApply
"HΦ"
.
rewrite
/
is_bag
/
bag_contents
.
iFrame
.
iExists
_
.
by
iFrame
"Hinv"
.
Qed
.
Lemma
pushBag_spec
(
P
Q
:
iProp
Σ
)
γ
(
x
v
:
val
)
:
□
(
∀
(
X
:
gmultiset
val
),
bag_contents
γ
X
∗
P
={
⊤
∖↑
N
}=
∗
▷
(
bag_contents
γ
({[
v
]}
∪
X
)
∗
Q
))
-
∗
{{{
is_bag
γ
x
∗
P
}}}
pushBag
x
(
of_val
v
)
{{{
RET
#()
;
Q
}}}.
Proof
.
iIntros
"#Hvs"
.
iIntros
(
Φ
).
iAlways
.
iIntros
"[#Hbag HP] HΦ"
.
unfold
pushBag
.
iL
ö
b
as
"IH"
.
do
2
wp_rec
.
rewrite
/
is_bag
.
iDestruct
"Hbag"
as
(
b
)
"[% #Hinv]"
;
simplify_eq
/=.
repeat
wp_pure
_
.
wp_bind
(!
#
b
)%
E
.
iInv
N
as
(
o
ls
)
"[Ho [Hls >Hb]]"
"Hcl"
.
wp_load
.
iMod
(
"Hcl"
with
"[Ho Hls Hb]"
)
as
"_"
.
{
iNext
.
iExists
_
,
_
.
iFrame
.
}
clear
ls
.
iModIntro
.
repeat
wp_pure
_
.
wp_alloc
n
as
"Hn"
.
wp_bind
(
CAS
_
_
_
).
iInv
N
as
(
o'
ls
)
"[Ho [Hls >Hb]]"
"Hcl"
.
destruct
(
decide
(
o
=
o'
))
as
[->|?].
-
wp_cas_suc
.
iMod
(
"Hvs"
with
"[$Hb $HP]"
)
as
"[Hb HQ]"
.
iMod
(
"Hcl"
with
"[Ho Hn Hls Hb]"
)
as
"_"
.
{
iNext
.
iExists
_
,(
v
::
ls
).
iFrame
"Ho Hb"
.
simpl
.
iExists
_
,
_
.
iFrame
.
iSplit
;
eauto
.
by
iExists
1
%
Qp
.
}
iModIntro
.
wp_if_true
.
by
iApply
"HΦ"
.
-
wp_cas_fail
.
iMod
(
"Hcl"
with
"[Ho Hls Hb]"
)
as
"_"
.
{
iNext
.
iExists
_
,
ls
.
by
iFrame
"Ho Hb"
.
}
iModIntro
.
wp_if_false
.
by
iApply
(
"IH"
with
"HP [HΦ]"
).
Qed
.
Lemma
popBag_spec
(
P
:
iProp
Σ
)
(
Q
:
val
→
iProp
Σ
)
γ
x
:
□
(
∀
(
X
:
gmultiset
val
)
(
y
:
val
),
bag_contents
γ
({[
y
]}
∪
X
)
∗
P
={
⊤
∖↑
N
}=
∗
▷
(
bag_contents
γ
X
∗
Q
(
SOMEV
y
)))
-
∗
□
(
bag_contents
γ
∅
∗
P
={
⊤
∖↑
N
}=
∗
▷
(
bag_contents
γ
∅
∗
Q
NONEV
))
-
∗
{{{
is_bag
γ
x
∗
P
}}}
popBag
x
{{{
v
,
RET
v
;
Q
v
}}}.
Proof
.
iIntros
"#Hvs1 #Hvs2"
.
iIntros
(
Φ
).
iAlways
.
iIntros
"[#Hbag HP] HΦ"
.
unfold
popBag
.
iL
ö
b
as
"IH"
.
wp_rec
.
rewrite
/
is_bag
.
iDestruct
"Hbag"
as
(
b
)
"[% #Hinv]"
;
simplify_eq
/=.
wp_bind
(!#
b
)%
E
.
iInv
N
as
(
o
ls
)
"[Ho [Hls >Hb]]"
"Hcl"
.
wp_load
.
destruct
ls
as
[|
x
ls
]
;
simpl
.
-
iDestruct
"Hls"
as
%->.
iMod
(
"Hvs2"
with
"[$Hb $HP]"
)
as
"[Hb HQ]"
.
iMod
(
"Hcl"
with
"[Ho Hb]"
)
as
"_"
.
{
iNext
.
iExists
_
,[].
by
iFrame
.
}
iModIntro
.
repeat
wp_pure
_
.
by
iApply
"HΦ"
.
-
iDestruct
"Hls"
as
(
hd
tl
)
"(% & Hhd & Hls)"
;
simplify_eq
/=.
rewrite
rown_duplicate
.
iDestruct
"Hhd"
as
"[Hhd Hhd']"
.
rewrite
is_list_duplicate
.
iDestruct
"Hls"
as
"[Hls Hls']"
.
iMod
(
"Hcl"
with
"[Ho Hb Hhd Hls]"
)
as
"_"
.
{
iNext
.
iExists
_
,(
x
::
ls
).
simpl
;
iFrame
;
eauto
.
iExists
_
,
_;
eauto
.
by
iFrame
.
}
iModIntro
.
repeat
wp_pure
_
.
iDestruct
"Hhd'"
as
(
q
)
"Hhd"
.
wp_load
.
repeat
wp_pure
_
.
wp_bind
(
CAS
_
_
_
).
iInv
N
as
(
o'
ls'
)
"[Ho [Hls >Hb]]"
"Hcl"
.
destruct
(
decide
(
o'
=
(
InjRV
#
hd
)))
as
[->|?].
+
wp_cas_suc
.
(* The list is still the same *)
rewrite
(
is_list_duplicate
tl
).
iDestruct
"Hls'"
as
"[Hls' Htl]"
.
iAssert
(
is_list
(
InjRV
#
hd
)
(
x
::
ls
))
with
"[Hhd Hls']"
as
"Hls'"
.
{
simpl
.
iExists
hd
,
tl
.
iFrame
;
iSplit
;
eauto
.
iExists
q
.
iFrame
.
}
iDestruct
(
is_list_agree
with
"Hls Hls'"
)
as
%?.
simplify_eq
.
iClear
"Hls'"
.
iDestruct
"Hls"
as
(
hd'
tl'
)
"(% & Hro' & Htl')"
.
simplify_eq
.
iMod
(
"Hvs1"
with
"[$Hb $HP]"
)
as
"[Hb HQ]"
.
iMod
(
"Hcl"
with
"[Ho Htl Hb]"
)
as
"_"
.
{
iNext
.
iExists
_
,
ls
.
by
iFrame
"Ho Hb"
.
}
iModIntro
.
wp_if_true
.
by
iApply
"HΦ"
.
+
wp_cas_fail
.
iMod
(
"Hcl"
with
"[Ho Hls Hb]"
)
as
"_"
.
{
iNext
.
iExists
_
,
ls'
.
by
iFrame
"Ho Hb"
.
}
iModIntro
.
wp_if_false
.
by
iApply
(
"IH"
with
"HP [HΦ]"
).
Qed
.
End
proof
.
Typeclasses
Opaque
bag_contents
is_bag
.
Canonical
Structure
cg_bag
`
{!
heapG
Σ
,
!
bagG
Σ
}
:
bag
Σ
:
=
{|
abstract_bag
.
is_bag
:
=
is_bag
;
abstract_bag
.
is_bag_persistent
:
=
is_bag_persistent
;
abstract_bag
.
bag_contents_timeless
:
=
bag_contents_timeless
;
abstract_bag
.
bag_contents_agree
:
=
bag_contents_agree
;
abstract_bag
.
bag_contents_update
:
=
bag_contents_update
;
abstract_bag
.
newBag_spec
:
=
newBag_spec
;
abstract_bag
.
pushBag_spec
:
=
pushBag_spec
;
abstract_bag
.
popBag_spec
:
=
popBag_spec
|}.
theories/hocap/shared_bag.v
View file @
916f8b66
...
...
@@ -15,13 +15,14 @@ Section proof.
Context
`
{
heapG
Σ
}.
Variable
b
:
bag
Σ
.
Variable
N
:
namespace
.
Variable
N2
:
namespace
.
Definition
NB
:
=
N
.@
"bag"
.
Definition
NI
:
=
N
.@
"inv"
.
Variable
P
:
val
→
iProp
Σ
.
(* Predicate that will be satisfied by all the elements in the bag *)
Definition
bagS_inv
(
γ
:
name
Σ
b
)
:
iProp
Σ
:
=
inv
N
2
(
∃
X
,
bag_contents
b
γ
X
∗
[
∗
mset
]
x
∈
X
,
P
x
)%
I
.
inv
N
I
(
∃
X
,
bag_contents
b
γ
X
∗
[
∗
mset
]
x
∈
X
,
P
x
)%
I
.
Definition
bagS
(
γ
:
name
Σ
b
)
(
x
:
val
)
:
iProp
Σ
:
=
(
is_bag
b
N
γ
x
∗
bagS_inv
γ
)%
I
.
(
is_bag
b
N
B
γ
x
∗
bagS_inv
γ
)%
I
.
Global
Instance
bagS_persistent
γ
x
:
Persistent
(
bagS
γ
x
).
Proof
.
apply
_
.
Qed
.
...
...
@@ -32,9 +33,9 @@ Section proof.
{{{
x
,
RET
x
;
∃
γ
,
bagS
γ
x
}}}.
Proof
.
iIntros
(
Φ
)
"_ HΦ"
.
iApply
wp_fupd
.
iApply
(
newBag_spec
b
N
)
;
eauto
.
iApply
(
newBag_spec
b
N
B
)
;
eauto
.
iNext
.
iIntros
(
v
γ
)
"[#Hbag Hcntn]"
.
iMod
(
inv_alloc
N
2
_
(
∃
X
,
bag_contents
b
γ
X
∗
[
∗
mset
]
x
∈
X
,
P
x
)%
I
with
"[Hcntn]"
)
as
"#Hinv"
.
iMod
(
inv_alloc
N
I
_
(
∃
X
,
bag_contents
b
γ
X
∗
[
∗
mset
]
x
∈
X
,
P
x
)%
I
with
"[Hcntn]"
)
as
"#Hinv"
.
{
iNext
.
iExists
_
.
iFrame
.
by
rewrite
big_sepMS_empty
.
}
iApply
"HΦ"
.
iModIntro
.
iExists
_;
by
iFrame
"Hinv"
.
Qed
.
...
...
@@ -45,9 +46,9 @@ Section proof.
{{{
RET
#()
;
bagS
γ
x
}}}.
Proof
.
iIntros
(
Φ
)
"[#[Hbag Hinv] HP] HΦ"
.
rewrite
/
bagS_inv
.
iApply
(
pushBag_spec
b
N
(
P
v
)%
I
(
True
)%
I
with
"[] [Hbag HP]"
)
;
eauto
.
iApply
(
pushBag_spec
b
N
B
(
P
v
)%
I
(
True
)%
I
with
"[] [Hbag HP]"
)
;
eauto
.
{
iAlways
.
iIntros
(
Y
)
"[Hb1 HP]"
.
iInv
N
2
as
(
X
)
"[>Hb2 HPs]"
"Hcl"
.
iInv
N
I
as
(
X
)
"[>Hb2 HPs]"
"Hcl"
.
iDestruct
(
bag_contents_agree
with
"Hb1 Hb2"
)
as
%<-.
iMod
(
bag_contents_update
b
({[
v
]}
∪
Y
)
with
"[$Hb1 $Hb2]"
)
as
"[Hb1 Hb2]"
.
iFrame
.
iApply
"Hcl"
.
...
...
@@ -62,9 +63,9 @@ Section proof.
{{{
v
,
RET
v
;
bagS
γ
x
∗
(
⌜
v
=
NONEV
⌝
∨
(
∃
y
,
⌜
v
=
SOMEV
y
⌝
∧
P
y
))
}}}.
Proof
.
iIntros
(
Φ
)
"[#Hbag #Hinv] HΦ"
.
iApply
(
popBag_spec
b
N
(
True
)%
I
(
fun
v
=>
(
⌜
v
=
NONEV
⌝
∨
(
∃
y
,
⌜
v
=
SOMEV
y
⌝
∧
P
y
)))%
I
with
"[] [] [Hbag]"
)
;
eauto
.
iApply
(
popBag_spec
b
N
B
(
True
)%
I
(
fun
v
=>
(
⌜
v
=
NONEV
⌝
∨
(
∃
y
,
⌜
v
=
SOMEV
y
⌝
∧
P
y
)))%
I
with
"[] [] [Hbag]"
)
;
eauto
.
{
iAlways
.
iIntros
(
Y
y
)
"[Hb1 _]"
.
iInv
N
2
as
(
X
)
"[>Hb2 HPs]"
"Hcl"
.
iInv
N
I
as
(
X
)
"[>Hb2 HPs]"
"Hcl"
.
iDestruct
(
bag_contents_agree
with
"Hb1 Hb2"
)
as
%<-.
iMod
(
bag_contents_update
b
Y
with
"[$Hb1 $Hb2]"
)
as
"[Hb1 Hb2]"
.
rewrite
big_sepMS_union
uPred
.
later_sep
big_sepMS_singleton
.
...
...
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