Commit 916f8b66 authored by Dan Frumin's avatar Dan Frumin

Add the fine-grained bag implementation

parent b92b197b
......@@ -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
......@@ -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 }}};
......
......@@ -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 isBag (γb : gname) (x : val) :=
Definition is_bag (γb : gname) (x : val) :=
( (lk : val) (b : loc) (γ : gname),
x = PairV #b lk is_lock N γ lk (bag_inv γb b))%I.
Definition bagContents (γb : gname) (X : gmultiset val) : iProp Σ :=
Definition bag_contents (γb : gname) (X : gmultiset val) : iProp Σ :=
own γb ((1/2)%Qp, to_agree X).
Global Instance isBag_persistent γb x : Persistent (isBag γb x).
Global Instance is_bag_persistent γb x : Persistent (is_bag γb x).
Proof. apply _. Qed.
Global Instance bagContents_timeless γb X : Timeless (bagContents γb X).
Global Instance bag_contents_timeless γb X : Timeless (bag_contents γb X).
Proof. apply _. Qed.
Lemma bagContents_agree γb X Y :
bagContents γb X - bagContents γb Y - X = Y.
Lemma bag_contents_agree γb X Y :
bag_contents γb X - bag_contents γb Y - X = Y.
Proof.
rewrite /bagContents. apply uPred.wand_intro_r.
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 bagContents_update γb X X' Y :
bagContents γb X bagContents γb X' == bagContents γb Y bagContents γb Y.
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 (bagContents_agree with "Hb1 Hb2") as %<-.
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 /bagContents. by iFrame.
rewrite /bag_contents. by iFrame.
Qed.
Lemma newBag_spec :
{{{ True }}}
newBag #()
{{{ x γ, RET x; isBag γ x bagContents γ }}}.
{{{ x γ, RET x; is_bag γ x bag_contents γ }}}.
Proof.
iIntros (Φ) "_ HΦ".
unfold newBag. wp_rec.
......@@ -108,30 +108,31 @@ Section proof.
{ iExists []. iFrame. }
iIntros (lk γ) "#Hlk".
iApply wp_value. iApply "HΦ".
rewrite /isBag /bagContents. iFrame.
rewrite /is_bag /bag_contents. 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), bagContents γ X P
={}= (bagContents γ ({[v]} X) Q)) -
{{{ isBag γ x P }}}
( (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. do 2 wp_rec.
rewrite /isBag /bag_inv.
rewrite /is_bag /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),
bagContents γ ({[y]} X) P
={}= (bagContents γ X Q (SOMEV y))) -
(bagContents γ P ={}= (bagContents γ Q NONEV)) -
{{{ isBag γ x P }}}
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. wp_rec.
rewrite /isBag /bag_inv.
rewrite /is_bag /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 bagContents isBag.
Typeclasses Opaque bag_contents is_bag.
Canonical Structure cg_bag `{!heapG Σ, !bagG Σ} : bag Σ :=
{| is_bag := isBag;
is_bag_persistent := isBag_persistent;
bag_contents_timeless := bagContents_timeless;
bag_contents_agree := bagContents_agree;
bag_contents_update := bagContents_update;
{| 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 |}.
......
(** 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 |}.
......@@ -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 N2 ( X, bag_contents b γ X [ mset] x X, P x)%I.
inv NI ( 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 NB γ 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 NB); eauto.
iNext. iIntros (v γ) "[#Hbag Hcntn]".
iMod (inv_alloc N2 _ ( X, bag_contents b γ X [ mset] x X, P x)%I with "[Hcntn]") as "#Hinv".
iMod (inv_alloc NI _ ( 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 NB (P v)%I (True)%I with "[] [Hbag HP]"); eauto.
{ iAlways. iIntros (Y) "[Hb1 HP]".
iInv N2 as (X) "[>Hb2 HPs]" "Hcl".
iInv NI 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 NB (True)%I (fun v => (v = NONEV ( y, v = SOMEV y P y)))%I with "[] [] [Hbag]"); eauto.
{ iAlways. iIntros (Y y) "[Hb1 _]".
iInv N2 as (X) "[>Hb2 HPs]" "Hcl".
iInv NI 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.
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment