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
Paolo G. Giarrusso
examples
Commits
916f8b66
Commit
916f8b66
authored
Apr 01, 2018
by
Dan Frumin
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Add the fine-grained bag implementation
parent
b92b197b
Changes
5
Hide whitespace changes
Inline
Side-by-side
Showing
5 changed files
with
290 additions
and
45 deletions
+290
-45
_CoqProject
_CoqProject
+1
-0
theories/hocap/abstract_bag.v
theories/hocap/abstract_bag.v
+3
-3
theories/hocap/cg_bag.v
theories/hocap/cg_bag.v
+36
-33
theories/hocap/fg_bag.v
theories/hocap/fg_bag.v
+240
-0
theories/hocap/shared_bag.v
theories/hocap/shared_bag.v
+10
-9
No files found.
_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