Add concurrent stacks with helping case study by Danny.

Fix #5.

README.md

@@ -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).
 

theories/concurrent_stacks/concurrent_stack1.v

+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.

theories/concurrent_stacks/concurrent_stack3.v

+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".
+    destruct xs.
+    - iSplit; try iLeft; auto.
+    - iSplit; auto; iRight; iDestruct "Hstack" as (t) "[% Hstack]";
+      iExists v0, t; auto.
+  Qed.
+
+  Lemma is_stack_uniq : ∀ xs ys v,
+      is_stack xs v ∗ is_stack ys v -∗ ⌜xs = ys⌝.
+  Proof.
+    induction xs, ys; iIntros (v') "[Hstack1 Hstack2]"; auto.
+    - iDestruct "Hstack1" as "%".
+      iDestruct "Hstack2" as (t) "[% Hstack2]".
+      subst.
+      discriminate.
+    - iDestruct "Hstack2" as "%".
+      iDestruct "Hstack1" as (t) "[% Hstack1]".
+      subst.
+      discriminate.
+    - iDestruct "Hstack1" as (t) "[% Hstack1]".
+      iDestruct "Hstack2" as (t') "[% Hstack2]".
+      subst; injection H0; intros; subst.
+      iDestruct (IHxs with "[Hstack1 Hstack2]") as "%".
+        by iSplitL "Hstack1".
+      subst; auto.
+  Qed.
+
+  Lemma is_stack_empty : ∀ xs,
+      is_stack xs (InjLV #()) -∗ ⌜xs = []⌝.
+  Proof.
+    iIntros (xs) "Hstack".
+    destruct xs; auto.
+    iDestruct "Hstack" as (t) "[% rest]".
+    discriminate.
+  Qed.
+  Lemma is_stack_cons : ∀ xs h t,
+      is_stack xs (InjRV (h, t)%V) -∗
+               is_stack xs (InjRV (h, t)%V) ∗ ∃ ys, ⌜xs = h :: ys⌝.
+  Proof.
+    destruct xs; iIntros (h t) "Hstack".
+    - iDestruct "Hstack" as "%"; discriminate.
+    - iSplit; [auto | iExists xs].
+      iDestruct "Hstack" as (t') "[% Hstack]".
+      injection H; intros; subst; auto.
+  Qed.
+
+  Theorem stack_works P Q Q' Q'' Φ :
+    (∀ (f₁ f₂ : val) ι,
+        (□((∀ v vs, P (v :: vs) ={⊤∖↑ι}=∗ Q v ∗ P vs) -∗
+            (P [] ={⊤∖↑ι}=∗ Q' ∗ P []) -∗
+            WP f₁ #() {{ v, (∃ (v' : val), v ≡ SOMEV v' ∗ Q v') ∨ (v ≡ NONEV ∗ Q')}}))
+         -∗ (∀ (v : val),
+               □ ((∀ vs, P vs ={⊤∖↑ι}=∗ P (v :: vs) ∗ Q'') -∗
+                  WP f₂ v {{ v, Q'' }}))
+         -∗ Φ (f₁, f₂)%V)%I
+    -∗ P []
+    -∗ WP mk_stack #()  {{ Φ }}.
+  Proof.
+    iIntros "HΦ HP".
+    pose proof (nroot .@ "N") as N.
+    wp_let.
+    wp_alloc l as "Hl".
+    iMod (inv_alloc N _ (stack_inv P #l) with "[Hl HP]") as "#Istack".
+    { iNext; iExists l, (InjLV #()), []; iSplit; iFrame; auto. }
+    wp_let.
+    iApply "HΦ".
+    - iIntros "!# Hsucc Hfail".
+      iLöb as "IH".
+      wp_rec.
+      wp_bind (! _)%E.
+      iInv N as "Hstack" "Hclose".
+      iDestruct "Hstack" as (l' v' xs) "[>% [Hl' [Hstack HP]]]".
+      injection H; intros; subst.
+      wp_load.
+      iDestruct (is_stack_disj with "[Hstack]") as "[Hstack H]"; auto.
+      iDestruct "H" as "[% | H]".
+      * subst.
+        iDestruct (is_stack_empty with "Hstack") as "%".
+        subst.
+        iMod ("Hfail" with "HP") as "[HQ' HP]".
+        iMod ("Hclose" with "[Hl' Hstack HP]").
+        { iExists l', (InjLV #()), []; iSplit; iFrame; auto. }
+        iModIntro.
+        wp_match.
+        iRight; auto.
+      * iDestruct "H" as (h t) "%".
+        subst.
+        iMod ("Hclose" with "[Hl' Hstack HP]").
+        { iExists l', (InjRV (h, t)), xs; iSplit; iFrame; auto. }
+        iModIntro.
+
+        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.
+        unfold subst; simpl; fold of_val.
+
+        wp_proj.
+        wp_bind (CAS _ _ _).
+        iInv N as "Hstack" "Hclose".
+        iDestruct "Hstack" as (l'' v' ys) "[>% [Hl'' [Hstack HP]]]".
+        injection H2; intros; subst.
+        assert (Decision (v' = InjRV (h, t)%V)) as Heq by apply val_eq_dec.
+        destruct Heq.
+      + wp_cas_suc.
+        subst.
+        iDestruct (is_stack_cons with "Hstack") as "[Hstack H]".
+        iDestruct "H" as (ys') "%"; subst.
+        iDestruct "Hstack" as (t') "[% Hstack]".
+        injection H3; intros; subst.
+        iDestruct ("Hsucc" with "[HP]") as "> [HQ HP]"; auto.
+        iMod ("Hclose" with "[Hl'' Hstack HP]").
+        { iExists l'', t', ys'; iSplit; iFrame; auto. }
+        iModIntro.
+        wp_if.
+        wp_proj.
+        iLeft; iExists h; auto.
+      + wp_cas_fail.
+        iMod ("Hclose" with "[Hl'' Hstack HP]").
+        { iExists l'', v', ys; iSplit; iFrame; auto. }
+        iModIntro.
+        wp_if.
+        iApply ("IH" with "Hsucc Hfail").
+    - iIntros (v) "!# Hpush".
+      iLöb as "IH".
+      wp_rec.
+      wp_bind (! _)%E.
+      iInv N as "Hstack" "Hclose".
+      iDestruct "Hstack" as (l' v' ys) "[>% [Hl' [Hstack HP]]]".
+      injection H; intros; subst.
+      wp_load.
+      iMod ("Hclose" with "[Hl' Hstack HP]").
+      { iExists l', v', ys; iSplit; iFrame; auto. }
+      iModIntro.
+      wp_let.
+      wp_let.
+      wp_bind (CAS _ _ _).
+      iInv N as "Hstack" "Hclose".
+      iDestruct "Hstack" as (l'' v'' xs) "[>% [Hl'' [Hstack HP]]]".
+      injection H0; intros; subst.
+      assert (Decision (v' = v''%V)) as Heq by apply val_eq_dec.
+      destruct Heq.
+      + wp_cas_suc.
+        iDestruct ("Hpush" with "[HP]") as "> [HP HQ]"; auto.
+        iMod ("Hclose" with "[Hl'' Hstack HP]").
+        { iExists l'', (InjRV (v, v')), (v :: xs); iSplit; iFrame; auto.
+          iExists v'; iSplit; subst; auto. }
+        iModIntro.
+        wp_if.
+        done.
+      + wp_cas_fail.
+        iMod ("Hclose" with "[Hl'' Hstack HP]").
+        { iExists l'', v'', xs; iSplit; iFrame; auto. }
+        iModIntro.
+        wp_if.
+        iApply ("IH" with "Hpush").
+  Qed.
+End stack_works.

[Ralf Jung]

Could we have some documentation (like, comments in the code -- which this is generally lacking) for why there are 4 stacks?

[Aleš Bizjak]

I believe the report which is linked in the README makes the 4 versions clear.

With regards to comments I would agree, but I do not have the time to write them. In any case, other files in this repository have the same amount of comments, so I don't see why this one should be an exception.

[Ralf Jung]

That report was indeed very helpful, sorry for not looking at it before asking. I added a few comments concerning the basic structure of the files, and some remarks based on meditating over the specs a little.

I may have some more questions, but I think that's easier done via email.

[Ralf Jung]

Also, I just noticed you forget to add these files to _CoqProject, so they were not actually built (e.g. by the CI). The files are still compatible with current Iris though :)