Commit 5fc8c715 authored by Aleš Bizjak's avatar Aleš Bizjak

Add concurrent stacks with helping case study by Danny.

Fix #5.
parent 85d365c5
Pipeline #6308 passed with stage
in 6 minutes and 20 seconds
......@@ -53,6 +53,8 @@ This repository contains the following case studies:
concurrent stack implementations
* [spanning-tree](theories/spanning_tree): Proof of a concurrent spanning tree
algorithm.
* [concurrent-stacks](theories/concurrent_stacks): Proof of an implementation of
concurrent stacks with helping, as described in the [report](http://iris-project.org/pdfs/2017-case-study-concurrent-stacks-with-helping.pdf).
* [lecture-notes](theories/lecture_notes): Coq examples for the
[Iris lecture notes](http://iris-project.org/tutorial-material.html).
......
From iris.base_logic Require Import base_logic.
From iris.proofmode Require Import tactics.
From iris.base_logic.lib Require Import invariants.
From iris.program_logic Require Export weakestpre hoare.
From iris.heap_lang Require Export lang.
From iris.algebra Require Import agree list.
From iris.heap_lang Require Import assert proofmode notation.
Set Default Proof Using "Type".
Definition mk_stack : val :=
λ: "_",
let: "r" := ref NONEV in
(rec: "pop" "n" :=
match: !"r" with
NONE => #-1
| SOME "hd" =>
if: CAS "r" (SOME "hd") (Snd "hd")
then Fst "hd"
else "pop" "n"
end,
rec: "push" "n" :=
let: "r'" := !"r" in
let: "r''" := SOME ("n", "r'") in
if: CAS "r" "r'" "r''"
then #()
else "push" "n").
Section stacks.
Context `{!heapG Σ}.
Implicit Types l : loc.
Definition is_stack_pre (P : val iProp Σ) (F : val -c> iProp Σ) :
val -c> iProp Σ := λ v,
(v NONEV (h t : val), v SOMEV (h, t)%V P h F t)%I.
Local Instance is_stack_contr (P : val iProp Σ): Contractive (is_stack_pre P).
Proof.
rewrite /is_stack_pre => n f f' Hf v.
repeat (f_contractive || f_equiv).
apply Hf.
Qed.
Definition is_stack_def (P : val -> iProp Σ) := fixpoint (is_stack_pre P).
Definition is_stack_aux P : seal (@is_stack_def P). by eexists. Qed.
Definition is_stack P := unseal (is_stack_aux P).
Definition is_stack_eq P : @is_stack P = @is_stack_def P := seal_eq (is_stack_aux P).
Definition stack_inv P v :=
( l v', v = #l l v' is_stack P v')%I.
Lemma is_stack_unfold (P : val iProp Σ) v :
is_stack P v is_stack_pre P (is_stack P) v.
Proof.
rewrite is_stack_eq. apply (fixpoint_unfold (is_stack_pre P)).
Qed.
Lemma is_stack_disj (P : val iProp Σ) v :
is_stack P v - is_stack P v (v NONEV (h t : val), v SOMEV (h, t)%V).
Proof.
iIntros "Hstack".
iDestruct (is_stack_unfold with "Hstack") as "[#Hstack|Hstack]".
- iSplit; try iApply is_stack_unfold; iLeft; auto.
- iDestruct "Hstack" as (h t) "[#Heq rest]".
iSplitL; try iApply is_stack_unfold; iRight; auto.
Qed.
Theorem stack_works P Φ :
( (f f : val),
( (v : val), WP f #() {{ v, P v v #-1 }})
- ( (v : val), (P v - WP f v {{ v, True }}))
- Φ (f, f)%V)%I
- WP mk_stack #() {{ Φ }}.
Proof.
iIntros "HΦ".
wp_lam.
wp_alloc l as "Hl".
pose proof (nroot .@ "N") as N.
rewrite -wp_fupd.
iMod (inv_alloc N _ (stack_inv P #l) with "[Hl]") as "#Hisstack".
iExists l, NONEV; iSplit; iFrame; auto.
{ iApply is_stack_unfold. iLeft; auto. }
wp_let.
iModIntro.
iApply "HΦ".
- iIntros (v) "!#".
iLöb as "IH".
wp_rec.
wp_bind (! #l)%E.
iInv N as "Hstack" "Hclose".
iDestruct "Hstack" as (l' v') "[>% [Hl' Hstack]]".
injection H; intros; subst.
wp_load.
iDestruct (is_stack_disj with "Hstack") as "[Hstack #Heq]".
iMod ("Hclose" with "[Hl' Hstack]").
iExists l', v'; iFrame; auto.
iModIntro.
iDestruct "Heq" as "[H | H]".
+ iRewrite "H".
wp_match.
iRight; auto.
+ iDestruct "H" as (h t) "H".
iRewrite "H".
assert (to_val (h, t)%V = Some (h, t)%V) by apply to_of_val.
assert (is_Some (to_val (h, t)%V)) by (exists (h, t)%V; auto).
wp_match. fold of_val.
unfold subst; simpl; fold subst.
wp_bind (CAS _ _ _).
wp_proj.
iInv N as "Hstack" "Hclose".
iDestruct "Hstack" as (l'' v'') "[>% [Hl'' Hstack]]".
injection H2; intros; subst.
assert (Decision (v'' = InjRV (h, t)%V)) as Heq by apply val_eq_dec.
destruct Heq.
* wp_cas_suc.
iDestruct (is_stack_unfold with "Hstack") as "[Hstack | Hstack]".
subst.
iDestruct "Hstack" as "%"; discriminate.
iDestruct "Hstack" as (h' t') "[% [HP Hstack]]".
subst.
injection H3.
intros.
subst.
iMod ("Hclose" with "[Hl'' Hstack]").
iExists l'', t'; iFrame; auto.
iModIntro.
wp_if.
wp_proj.
iLeft; auto.
* wp_cas_fail.
iMod ("Hclose" with "[Hl'' Hstack]").
iExists l'', v''; iFrame; auto.
iModIntro.
wp_if.
iApply "IH".
- iIntros (v) "!# HP".
iLöb as "IH".
wp_rec.
wp_bind (! _)%E.
iInv N as "Hstack" "Hclose".
iDestruct "Hstack" as (l' v') "[>% [Hl' Hstack]]".
injection H; intros; subst.
wp_load.
iMod ("Hclose" with "[Hl' Hstack]").
by (iExists l', v'; iFrame).
iModIntro.
wp_let.
wp_let.
wp_bind (CAS _ _ _).
iInv N as "Hstack" "Hclose".
iDestruct "Hstack" as (l'' v'') "[>% [Hl'' Hstack]]".
injection H0; intros; subst.
assert (Decision (v'' = v'%V)) as Heq by apply val_eq_dec.
destruct Heq.
+ wp_cas_suc.
iMod ("Hclose" with "[Hl'' HP Hstack]").
iExists l'', (InjRV (v, v')%V).
iFrame; auto.
iSplit; auto.
iApply is_stack_unfold.
iRight.
iExists v, v'.
iSplit; auto.
subst; iFrame.
iModIntro.
wp_if.
done.
+ wp_cas_fail.
iMod ("Hclose" with "[Hl'' Hstack]").
iExists l'', v''; iFrame; auto.
iModIntro.
wp_if.
iApply "IH".
done.
Qed.
End stacks.
From iris.program_logic Require Export weakestpre hoare.
From iris.heap_lang Require Export lang proofmode notation.
From iris.algebra Require Import excl.
Set Default Proof Using "Type".
Definition mk_offer : val :=
λ: "v", ("v", ref #0).
Definition revoke_offer : val :=
λ: "v", if: CAS (Snd "v") #0 #2 then SOME (Fst "v") else NONE.
Definition take_offer : val :=
λ: "v", if: CAS (Snd "v") #0 #1 then SOME (Fst "v") else NONE.
Definition mailbox : val :=
λ: "_",
let: "r" := ref NONEV in
(rec: "put" "v" :=
let: "off" := mk_offer "v" in
"r" <- SOME "off";;
revoke_offer "off",
rec: "get" "n" :=
let: "offopt" := !"r" in
match: "offopt" with
NONE => NONE
| SOME "x" => take_offer "x"
end
).
Definition mk_stack : val :=
λ: "_",
let: "mailbox" := mailbox #() in
let: "put" := Fst "mailbox" in
let: "get" := Snd "mailbox" in
let: "r" := ref NONEV in
(rec: "pop" "n" :=
match: "get" #() with
NONE =>
(match: !"r" with
NONE => NONE
| SOME "hd" =>
if: CAS "r" (SOME "hd") (Snd "hd")
then SOME (Fst "hd")
else "pop" "n"
end)
| SOME "x" => SOME "x"
end,
rec: "push" "n" :=
match: "put" "n" with
NONE => #()
| SOME "n" =>
let: "r'" := !"r" in
let: "r''" := SOME ("n", "r'") in
if: CAS "r" "r'" "r''"
then #()
else "push" "n"
end).
Definition channelR := exclR unitR.
Class channelG Σ := { channel_inG :> inG Σ channelR }.
Definition channelΣ : gFunctors := #[GFunctor channelR].
Instance subG_channelΣ {Σ} : subG channelΣ Σ channelG Σ.
Proof. solve_inG. Qed.
Section side_channel.
Context `{!heapG Σ, !channelG Σ}.
Implicit Types l : loc.
Definition stages γ (P : val iProp Σ) l v :=
((l #0 P v)
(l #1)
(l #2 own γ (Excl ())))%I.
Definition is_offer γ (P : val iProp Σ) (v : val) : iProp Σ :=
( v' l, v = (v', #l)%V ι, inv ι (stages γ P l v'))%I.
Definition mailbox_inv (P : val iProp Σ) (v : val) : iProp Σ :=
( l, v = #l (l NONEV ( v' γ, l SOMEV v' is_offer γ P v')))%I.
(* A partial specification for revoke that will be useful later *)
Lemma revoke_works N γ P l v :
inv N (stages γ P l v) own γ (Excl ()) -
WP revoke_offer (v, #l)
{{ v', ( v'' : val, v' = InjRV v'' P v'') v' = InjLV #() }}.
Proof.
iIntros "[#Hinv Hγ]".
wp_let.
wp_proj.
wp_bind (CAS _ _ _).
iInv N as "Hstages" "Hclose".
iDestruct "Hstages" as "[H | [H | H]]".
- iDestruct "H" as "[Hl HP]".
wp_cas_suc.
iMod ("Hclose" with "[Hl Hγ]").
iRight; iRight; iFrame.
iModIntro.
wp_if.
wp_proj.
iLeft.
iExists v; iSplit; auto.
- wp_cas_fail.
iMod ("Hclose" with "[H]").
iRight; iLeft; auto.
iModIntro.
wp_if.
iRight; auto.
- iDestruct "H" as "[Hl H]".
wp_cas_fail.
by iDestruct (own_valid_2 with "H Hγ") as %?.
Qed.
(* A partial specification for take that will be useful later *)
Lemma take_works γ N P v l :
inv N (stages γ P l v) -
WP take_offer (v, LitV l)%V
{{ v', ( v'' : val, v' = InjRV v'' P v'') v' = InjLV #() }}.
Proof.
iIntros "#Hinv".
wp_lam.
wp_proj.
wp_bind (CAS _ _ _).
iInv N as "Hstages" "Hclose".
iDestruct "Hstages" as "[H | [H | H]]".
- iDestruct "H" as "[H HP]".
wp_cas_suc.
iMod ("Hclose" with "[H]").
iRight; iLeft; done.
iModIntro.
wp_if.
wp_proj.
iLeft.
auto.
- wp_cas_fail.
iMod ("Hclose" with "[H]").
iRight; iLeft; done.
iModIntro.
wp_if.
auto.
- iDestruct "H" as "[Hl Hγ]".
wp_cas_fail.
iMod ("Hclose" with "[Hl Hγ]").
iRight; iRight; iFrame.
iModIntro.
wp_if.
auto.
Qed.
End side_channel.
Section mailbox.
Context `{!heapG Σ}.
Implicit Types l : loc.
Theorem mailbox_works {channelG0 : channelG Σ} (P : val iProp Σ) (Φ : val iProp Σ) :
( (v v : val),
Closed [] v₁⌝
Closed [] v₂⌝
( (v : val), (P v - WP v v {{v',
( v'', v' = SOMEV v'' P v'') v' = NONEV}}))
( (WP v #() {{v', ( v'', v' = SOMEV v'' P v'') v' = NONEV}}))
- Φ (v, v)%V)
- WP mailbox #() {{ Φ }}.
Proof.
iIntros "HΦ".
pose proof (nroot .@ "N") as N.
rewrite -wp_fupd.
wp_lam.
wp_alloc l as "Hl".
wp_let.
iMod (inv_alloc N _ (mailbox_inv P #l) with "[Hl]") as "#Hinv".
iExists l; iSplit; try iLeft; auto.
iModIntro.
iApply "HΦ"; repeat iSplit; try (iPureIntro; apply _).
* iIntros (v) "!# HP".
wp_rec.
wp_bind (mk_offer v).
pose proof (nroot .@ "N'") as N'.
rewrite -wp_fupd.
wp_lam.
iMod (own_alloc (Excl ())) as (γ) "Hγ". done.
wp_alloc l' as "Hl'".
iMod (inv_alloc N' _ (stages γ P l' v) with "[HP Hl']") as "#Hinv'".
iLeft; iFrame.
iModIntro.
wp_let.
wp_bind (#l <- _)%E.
iInv N as "Hmailbox" "Hclose".
iDestruct "Hmailbox" as (l'') "[>% H]".
injection H; intros; subst.
iDestruct "H" as "[H | H]";
[idtac | iDestruct "H" as (v' γ') "[Hl H]"];
wp_store;
[iMod ("Hclose" with "[H]") | iMod ("Hclose" with "[Hl H]")];
try (iExists l''; iSplit; try iRight; auto;
iExists (v, #l')%V, γ; iFrame;
iExists v, l'; auto);
iModIntro;
wp_let;
iApply (revoke_works with "[Hγ Hinv]"); auto.
* iIntros "!#".
wp_rec.
wp_bind (! _)%E.
iInv N as "Hmailbox" "Hclose".
iDestruct "Hmailbox" as (l') "[>% H]".
injection H; intros; subst.
iDestruct "H" as "[H | H]".
+ wp_load.
iMod ("Hclose" with "[H]").
iExists l'; iSplit; auto.
iModIntro.
wp_let.
wp_match.
iRight; auto.
+ iDestruct "H" as (v' γ) "[Hl' #Hoffer]".
wp_load.
iMod ("Hclose" with "[Hl' Hoffer]").
{ iExists l'; iSplit; auto.
iRight; iExists v', γ; by iSplit. }
iModIntro.
wp_let.
wp_match.
iDestruct "Hoffer" as (v'' l'') "[% Hoffer]".
iDestruct "Hoffer" as (ι) "Hinv'".
subst.
iApply take_works; auto.
Qed.
End mailbox.
Section stack_works.
Context `{!heapG Σ}.
Implicit Types l : loc.
Definition is_stack_pre (P : val iProp Σ) (F : val -c> iProp Σ) :
val -c> iProp Σ := λ v,
(v NONEV (h t : val), v SOMEV (h, t)%V P h F t)%I.
Local Instance is_stack_contr (P : val iProp Σ): Contractive (is_stack_pre P).
Proof.
rewrite /is_stack_pre => n f f' Hf v.
repeat (f_contractive || f_equiv).
apply Hf.
Qed.
Definition is_stack_def (P : val -> iProp Σ) := fixpoint (is_stack_pre P).
Definition is_stack_aux P : seal (@is_stack_def P). by eexists. Qed.
Definition is_stack P := unseal (is_stack_aux P).
Definition is_stack_eq P : @is_stack P = @is_stack_def P := seal_eq (is_stack_aux P).
Definition stack_inv P v :=
( l v', v = #l l v' is_stack P v')%I.
Lemma is_stack_unfold (P : val iProp Σ) v :
is_stack P v is_stack_pre P (is_stack P) v.
Proof.
rewrite is_stack_eq. apply (fixpoint_unfold (is_stack_pre P)).
Qed.
Lemma is_stack_disj (P : val iProp Σ) v :
is_stack P v - is_stack P v (v NONEV (h t : val), v SOMEV (h, t)%V).
Proof.
iIntros "Hstack".
iDestruct (is_stack_unfold with "Hstack") as "[#Hstack|Hstack]".
- iSplit; try iApply is_stack_unfold; iLeft; auto.
- iDestruct "Hstack" as (h t) "[#Heq rest]".
iSplitL; try iApply is_stack_unfold; iRight; auto.
Qed.
Theorem stack_works {channelG0 : channelG Σ} P Φ :
( (f f : val),
( WP f #() {{ v, ( (v' : val), v SOMEV v' P v') v NONEV }})
- ( (v : val), (P v - WP f v {{ v, True }}))
- Φ (f, f)%V)%I
- WP mk_stack #() {{ Φ }}.
Proof.
iIntros "HΦ".
wp_lam.
wp_bind (mailbox _).
iApply (mailbox_works P).
iIntros (put get) "[% [% [#Hput #Hget]]]".
wp_let; wp_proj; wp_let; wp_proj; wp_let; wp_alloc l' as "Hl'".
pose proof (nroot .@ "N") as N.
iMod (inv_alloc N _ (stack_inv P #l') with "[Hl']") as "#Hisstack".
{ iExists l', NONEV; iFrame; iSplit; auto. iApply is_stack_unfold; iLeft; done. }
wp_let.
iApply "HΦ".
(* The verification of pop *)
- iIntros "!#".
iLöb as "IH".
wp_rec; wp_bind (get _).
(* Switch from proving WP put #() {{ P }} to
* Q -∗ P where Q is the spec we have already assumed for P
*)
iApply wp_wand; auto.
iIntros (v) "Hv".
iDestruct "Hv" as "[H | H]".
* iDestruct "H" as (v') "[% HP]".
subst.
(* This is just some technical fidgetting to get wp_match to behave.
* It is safe to ignore
*)
assert (to_val v' = Some v') by apply to_of_val.
assert (is_Some (to_val v')) by (exists v'; auto).
assert (to_val (InjRV v') = Some (InjRV v')) by apply to_of_val.
assert (is_Some (to_val (InjRV v'))) by (exists (InjRV v'); auto).
wp_match.
iLeft; iExists v'; auto.
* iDestruct "H" as "%"; subst.
wp_match; wp_bind (! #l')%E.
iInv N as "Hstack" "Hclose".
iDestruct "Hstack" as (l'' v'') "[>% [Hl' Hstack]]".
injection H1; intros; subst.
wp_load.
iDestruct (is_stack_disj with "Hstack") as "[Hstack #Heq]".
iMod ("Hclose" with "[Hl' Hstack]").
{ iExists l'', v''; iFrame; auto. }
iModIntro.
iDestruct "Heq" as "[H | H]".
+ iRewrite "H"; wp_match; iRight; auto.
+ iDestruct "H" as (h t) "H"; iRewrite "H".
(* For technical reasons, wp_match gets confused by this
* position. Hence the assertions. They can be safely ignored
*)
assert (to_val (h, t)%V = Some (h, t)%V) by apply to_of_val.
assert (is_Some (to_val (h, t)%V)) by (exists (h, t)%V; auto).
wp_match. fold of_val.
(* Now back to our regularly scheduled verification *)
wp_bind (CAS _ _ _); wp_proj.
iInv N as "Hstack" "Hclose".
iDestruct "Hstack" as (l''' v''') "[>% [Hl'' Hstack]]".
injection H4; intros; subst.
(* Case on whether or not the stack has been updated *)
destruct (decide (v''' = InjRV (h, t)%V)).
++ (* If nothing has changed, the cas succeeds *)
wp_cas_suc.
iDestruct (is_stack_unfold with "Hstack") as "[Hstack | Hstack]".
subst.
iDestruct "Hstack" as "%"; discriminate.
iDestruct "Hstack" as (h' t') "[% [HP Hstack]]".
subst.
injection H5.
intros.
subst.
iMod ("Hclose" with "[Hl'' Hstack]").
{ iExists l''', t'; iFrame; auto. }
iModIntro.
wp_if; wp_proj; iLeft; auto.
++ (* The case in which we fail *)
wp_cas_fail.
iMod ("Hclose" with "[Hl'' Hstack]").
iExists l''', v'''; iFrame; auto.
iModIntro.
wp_if.
(* Now we use our IH to loop *)
iApply "IH".
(* The verification of push. This is actually markedly simpler. *)
- iIntros (v) "!# HP".
simpl in *.
fold of_val in *.
(* We grab an IH to be used in the case that we loop *)
iLöb as "IH" forall (v).
wp_rec.
wp_bind (put _).
(* Switch from proving WP put #() {{ P }} to
* Q -∗ P where Q is the spec we have already assumed for put
*)
iApply (wp_wand with "[HP]").
iApply "Hput"; auto.
iIntros (v') "Hv'".
iDestruct "Hv'" as "[H | H]".
* iDestruct "H" as (v'') "[% HP]"; subst.
wp_match.
(* Push the substitution through the term *)
wp_bind (! _)%E.
iInv N as "Hstack" "Hclose".
iDestruct "Hstack" as (l'' v') "[>% [Hl' Hstack]]"; simplify_eq.
wp_load.
iMod ("Hclose" with "[Hl' Hstack]").
{ by (iExists l'', v'; iFrame). }
iModIntro.
wp_let; wp_let; wp_bind (CAS _ _ _).
iInv N as "Hstack" "Hclose".
iDestruct "Hstack" as (l''' v''') "[>% [Hl'' Hstack]]"; simplify_eq.
(* Now we case to see if the stack is unchanged *)
destruct (decide (v''' = v'%V)).
+ wp_cas_suc.
iMod ("Hclose" with "[Hl'' HP Hstack]").
{ iExists l''', (InjRV (v'', v')%V).
iSplit; iFrame; auto.
iApply is_stack_unfold; iRight.
iExists v'', v'; iFrame; iSplit; subst; auto. }
iModIntro.
wp_if.
done.
+ wp_cas_fail.
iMod ("Hclose" with "[Hl'' Hstack]").
iExists l''', v'''; iFrame; auto.
iModIntro.
wp_if.
iApply ("IH" with "HP").
* (* This is the case that our sidechannel offer succeeded *)
iDestruct "H" as "%"; subst.
wp_match.
done.
Qed.
End stack_works.
From iris.program_logic Require Export weakestpre hoare.
From iris.heap_lang Require Export lang proofmode notation.
From iris.algebra Require Import excl.
Set Default Proof Using "Type".
Definition mk_stack : val :=
λ: "_",
let: "r" := ref NONEV in
(rec: "pop" "n" :=
(match: !"r" with
NONE => NONE
| SOME "hd" =>
if: CAS "r" (SOME "hd") (Snd "hd")
then SOME (Fst "hd")
else "pop" "n"
end),
rec: "push" "n" :=
let: "r'" := !"r" in
let: "r''" := SOME ("n", "r'") in
if: CAS "r" "r'" "r''"
then #()
else "push" "n").
Section stack_works.
Context `{!heapG Σ}.
Implicit Types l : loc.
Fixpoint is_stack xs v : iProp Σ :=
(match xs with
| [] => v = NONEV
| x :: xs => (t : val), v = SOMEV (x, t)%V is_stack xs t
end)%I.
Definition stack_inv P v :=
( l v' xs, v = #l l v' is_stack xs v' P xs)%I.
Lemma is_stack_disj xs v :
is_stack xs v - is_stack xs v (v = NONEV (h t : val), v = SOMEV (h, t)%V).
Proof.
iIntros "Hstack".