Commit 36f0e548 authored by Ralf Jung's avatar Ralf Jung

Merge branch 'master' into 'master'

Master

See merge request !13
parents 73e3afad 14821493
Pipeline #15272 passed with stage
in 6 minutes and 25 seconds
......@@ -23,11 +23,11 @@ theories/spanning_tree/mon.v
theories/spanning_tree/spanning.v
theories/spanning_tree/proof.v
theories/concurrent_stacks/specs.v
theories/concurrent_stacks/concurrent_stack1.v
#theories/concurrent_stacks/concurrent_stack2.v
theories/concurrent_stacks/concurrent_stack2.v
theories/concurrent_stacks/concurrent_stack3.v
#theories/concurrent_stacks/concurrent_stack4.v
theories/concurrent_stacks/spec.v
theories/concurrent_stacks/concurrent_stack4.v
theories/logrel/prelude/base.v
theories/logrel/stlc/lang.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.
From iris_examples.concurrent_stacks Require Import spec.
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Import notation proofmode.
From iris_examples.concurrent_stacks Require Import specs.
Set Default Proof Using "Type".
(** Stack 1: No helping, bag spec. *)
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 (Alloc ("n", "r'")) in
if: CAS "r" "r'" "r''"
then #()
else "push" "n").
Definition new_stack : val := λ: "_", ref NONEV.
Definition push : val :=
rec: "push" "s" "v" :=
let: "tail" := ! "s" in
let: "new" := SOME (ref ("v", "tail")) in
if: CAS "s" "tail" "new" then #() else "push" "s" "v".
Definition pop : val :=
rec: "pop" "s" :=
match: !"s" with
NONE => NONEV
| SOME "l" =>
let: "pair" := !"l" in
if: CAS "s" (SOME "l") (Snd "pair")
then SOME (Fst "pair")
else "pop" "s"
end.
Section stacks.
Context `{!heapG Σ}.
Context `{!heapG Σ} (N : namespace).
Implicit Types l : loc.
Definition oloc_to_val (h : option loc) : val :=
match h with
| None => NONEV
| Some l => SOMEV #l
end.
Local Instance oloc_to_val_inj : Inj (=) (=) oloc_to_val.
Proof. rewrite /Inj /oloc_to_val=>??. repeat case_match; congruence. Qed.
Local Notation "l ↦{-} v" := ( q, l {q} v)%I
(at level 20, format "l ↦{-} v") : bi_scope.
Definition is_stack_pre (P : val iProp Σ) (F : option loc -c> iProp Σ) :
option loc -c> iProp Σ := λ v,
(match v with
| None => True
| Some l => q h t, l {q} (h, oloc_to_val t) P h F t
end)%I.
Lemma partial_mapsto_duplicable l v :
l {-} v - l {-} v l {-} v.
Proof.
iIntros "H"; iDestruct "H" as (?) "[Hl Hl']"; iSplitL "Hl"; eauto.
Qed.
Local Instance is_stack_contr (P : val iProp Σ): Contractive (is_stack_pre P).
Definition is_list_pre (P : val iProp Σ) (F : val -c> iProp Σ) :
val -c> iProp Σ := λ v,
(v NONEV (l : loc) (h t : val), v SOMEV #l l {-} (h, t)%V P h F t)%I.
Local Instance is_list_contr (P : val iProp Σ) : Contractive (is_list_pre P).
Proof.
rewrite /is_stack_pre => n f f' Hf v.
rewrite /is_list_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 l :=
( ol, l oloc_to_val ol is_stack P ol)%I.
Definition is_list_def (P : val -> iProp Σ) := fixpoint (is_list_pre P).
Definition is_list_aux P : seal (@is_list_def P). by eexists. Qed.
Definition is_list P := unseal (is_list_aux P).
Definition is_list_eq P : @is_list P = @is_list_def P := seal_eq (is_list_aux P).
Lemma is_list_unfold (P : val iProp Σ) v :
is_list P v is_list_pre P (is_list P) v.
Proof.
rewrite is_list_eq. apply (fixpoint_unfold (is_list_pre P)).
Qed.
Lemma is_stack_unfold (P : val iProp Σ) v :
is_stack P v is_stack_pre P (is_stack P) v.
(* TODO: shouldn't have to explicitly return is_list *)
Lemma is_list_unboxed (P : val iProp Σ) v :
is_list P v - val_is_unboxed v is_list P v.
Proof.
rewrite is_stack_eq. apply (fixpoint_unfold (is_stack_pre P)).
iIntros "Hstack"; iSplit; last done;
iDestruct (is_list_unfold with "Hstack") as "[->|Hstack]";
last iDestruct "Hstack" as (l h t) "(-> & _)"; done.
Qed.
Lemma is_stack_copy (P : val iProp Σ) ol :
is_stack P ol - is_stack P ol
(match ol with None => True | Some l => q h t, l {q} (h, oloc_to_val t) end).
Lemma is_list_disj (P : val iProp Σ) v :
is_list P v - is_list P v (v NONEV (l : loc) h t, v SOMEV #l%V l {-} (h, t)%V).
Proof.
iIntros "Hstack".
iDestruct (is_stack_unfold with "Hstack") as "Hstack". destruct ol; last first.
- iSplitL; try iApply is_stack_unfold; auto.
- iDestruct "Hstack" as (q h t) "[[Hl1 Hl2] [HP Hrest]]".
iSplitR "Hl2"; try iApply is_stack_unfold; simpl; eauto 10 with iFrame.
iDestruct (is_list_unfold with "Hstack") as "[%|Hstack]"; simplify_eq.
- rewrite is_list_unfold; iSplitR; [iLeft|]; eauto.
- iDestruct "Hstack" as (l h t) "(% & Hl & Hlist)".
iDestruct (partial_mapsto_duplicable with "Hl") as "[Hl1 Hl2]"; simplify_eq.
rewrite (is_list_unfold _ (InjRV _)); iSplitR "Hl2"; iRight; iExists _, _, _; by iFrame.
Qed.
(* Per-element invariant (i.e., bag spec). *)
Theorem stack_works P Φ :
( (f f : val),
( WP f #() {{ v, ( v', v SOMEV v' P v') v NONEV }})
- ( (v : val), (P v - WP f v {{ v, True }}))
- Φ (f, f)%V)%I
- WP mk_stack #() {{ Φ }}.
Definition stack_inv P v :=
( l v', v = #l l v' is_list P v')%I.
Definition is_stack (P : val iProp Σ) v :=
inv N (stack_inv P v).
Theorem new_stack_spec P :
{{{ True }}} new_stack #() {{{ s, RET s; is_stack P s }}}.
Proof.
iIntros "HΦ".
iIntros (ϕ) "_ Hpost".
iApply wp_fupd.
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 None; iFrame; auto.
iApply is_stack_unfold. auto. }
wp_pures.
wp_alloc as "Hl".
iMod (inv_alloc N (stack_inv P #) with "[Hl]") as "Hinv".
{ iNext; iExists , NONEV; iFrame;
by iSplit; last (iApply is_list_unfold; iLeft). }
by iApply "Hpost".
Qed.
Theorem push_spec P s v :
{{{ is_stack P s P v }}} push s v {{{ RET #(); True }}}.
Proof.
iIntros (Φ) "[#Hstack HP] HΦ".
iLöb as "IH".
wp_lam. wp_let. wp_bind (Load _).
iInv N as ( v') "(>% & Hl & Hlist)" "Hclose"; subst.
wp_load.
iMod ("Hclose" with "[Hl Hlist]") as "_".
{ iNext; iExists _, _; by iFrame. }
iModIntro. wp_let. wp_alloc ' as "Hl'". wp_pures. wp_bind (CAS _ _ _).
iInv N as ('' v'') "(>% & >Hl & Hlist)" "Hclose"; simplify_eq.
destruct (decide (v' = v'')) as [ -> |].
- iDestruct (is_list_unboxed with "Hlist") as "[>% Hlist]".
wp_cas_suc.
iMod ("Hclose" with "[HP Hl Hl' Hlist]") as "_".
{ iNext; iExists _, (InjRV #'); iFrame; iSplit; first done;
rewrite (is_list_unfold _ (InjRV _)). iRight; iExists _, _, _; iFrame; eauto. }
iModIntro.
wp_if.
by iApply "HΦ".
- iDestruct (is_list_unboxed with "Hlist") as "[>% Hlist]".
wp_cas_fail.
iMod ("Hclose" with "[Hl Hlist]") as "_".
{ iNext; iExists _, _; by iFrame. }
iModIntro.
wp_if.
iApply ("IH" with "HP HΦ").
Qed.
Theorem pop_spec P s :
{{{ is_stack P s }}} pop s {{{ ov, RET ov; ov = NONEV v, ov = SOMEV v P v }}}.
Proof.
iIntros (Φ) "#Hstack HΦ".
iLöb as "IH".
wp_lam. wp_bind (Load _).
iInv N as ( v') "(>% & Hl & Hlist)" "Hclose"; subst.
wp_load.
iDestruct (is_list_disj with "Hlist") as "[Hlist Hdisj]".
iMod ("Hclose" with "[Hl Hlist]") as "_".
{ iNext; iExists _, _; by iFrame. }
iModIntro.
iApply "HΦ".
- iIntros "!#".
iLöb as "IH".
wp_rec.
wp_bind (! #l)%E.
iInv N as "Hstack" "Hclose".
iDestruct "Hstack" as (v') "[Hl' Hstack]".
iDestruct "Hdisj" as "[-> | Heq]".
- wp_match.
iApply "HΦ"; by iLeft.
- iDestruct "Heq" as (l h t) "[-> Hl]".
wp_match. wp_bind (Load _).
iInv N as (' v') "(>% & Hl' & Hlist)" "Hclose". simplify_eq.
iDestruct "Hl" as (q) "Hl".
wp_load.
destruct v' as [l'|]; simpl; last first.
+ iMod ("Hclose" with "[Hl' Hstack]") as "_".
{ rewrite /stack_inv. eauto with iFrame. }
iModIntro. wp_match. wp_pures. by iRight.
+ iDestruct (is_stack_copy with "Hstack") as "[Hstack Hmy]".
iDestruct "Hmy" as (q h t) "Hl".
iMod ("Hclose" with "[Hl' Hstack]") as "_".
{ rewrite /stack_inv. eauto with iFrame. }
iModIntro. wp_match.
wp_load. wp_pures.
wp_bind (CAS _ _ _).
iInv N as "Hstack" "Hclose".
iDestruct "Hstack" as (v'') "[Hl'' Hstack]".
destruct (decide (oloc_to_val v'' = oloc_to_val (Some l'))) as [->%oloc_to_val_inj|Hne].
* simpl. wp_cas_suc.
iDestruct (is_stack_unfold with "Hstack") as "Hstack".
iDestruct "Hstack" as (q' h' t') "[Hl' [HP Hstack]]".
iDestruct (mapsto_agree with "Hl Hl'") as %[= <- <-%oloc_to_val_inj].
iMod ("Hclose" with "[Hl'' Hstack]").
{ iExists _. auto with iFrame. }
iModIntro.
wp_if.
wp_load.
wp_pures.
eauto.
* simpl in Hne. wp_cas_fail.
iMod ("Hclose" with "[Hl'' Hstack]").
{ iExists 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 (v') "[Hl' Hstack]".
wp_load.
iMod ("Hclose" with "[Hl' Hstack]").
{ iExists v'. iFrame. }
iMod ("Hclose" with "[Hl' Hlist]") as "_".
{ iNext; iExists _, _; by iFrame. }
iModIntro.
wp_let.
wp_alloc r'' as "Hr''".
wp_pures. wp_bind (CAS _ _ _).
iInv N as "Hstack" "Hclose".
iDestruct "Hstack" as (v'') "[Hl'' Hstack]".
wp_cas as ->%oloc_to_val_inj|_.
+ destruct v'; by right.
+ iMod ("Hclose" with "[Hl'' Hr'' HP Hstack]").
iExists (Some r'').
iFrame; auto.
iNext.
iApply is_stack_unfold.
simpl.
iExists _, _, v'. iFrame.
iInv N as ('' v'') "(>% & Hl' & Hlist)" "Hclose". simplify_eq.
destruct (decide (v'' = InjRV #l)) as [-> |].
* rewrite is_list_unfold.
iDestruct "Hlist" as "[>% | H]"; first done.
iDestruct "H" as (''' h' t') "(>% & Hl'' & HP & Hlist)"; simplify_eq.
iDestruct "Hl''" as (q') "Hl''".
wp_cas_suc.
iDestruct (mapsto_agree with "Hl'' Hl") as "%"; simplify_eq.
iMod ("Hclose" with "[Hl' Hlist]") as "_".
{ iNext; iExists '', _; by iFrame. }
iModIntro.
wp_if.
done.
+ iMod ("Hclose" with "[Hl'' Hstack]").
iExists v''; iFrame; auto.
wp_pures.
iApply ("HΦ" with "[HP]"); iRight; iExists h; by iFrame.
* wp_cas_fail.
iMod ("Hclose" with "[Hl' Hlist]") as "_".
{ iNext; iExists '', _; by iFrame. }
iModIntro.
wp_if.
iApply "IH".
done.
iApply ("IH" with "HΦ").
Qed.
End stacks.
Program Definition is_concurrent_bag `{!heapG Σ} : concurrent_bag Σ :=
{| spec.mk_bag := mk_stack |}.
Next Obligation.
iIntros (??? P Φ) "_ HΦ". iApply stack_works.
iNext. iIntros (f f) "Hpop Hpush". iApply "HΦ". iFrame.
Qed.
Program Definition spec {Σ} N `{heapG Σ} : concurrent_bag Σ :=
{| is_bag := is_stack N; new_bag := new_stack; bag_push := push; bag_pop := pop |} .
Solve Obligations of spec with eauto using pop_spec, push_spec, new_stack_spec.
(** THIS FILE CURRENTLY DOES NOT COMPILE because it has not been ported to the
stricter CAS requirements yet. *)
From iris.program_logic Require Export weakestpre hoare.
From iris.heap_lang Require Export lang proofmode notation.
From iris.heap_lang Require Import notation proofmode.
From iris.algebra Require Import excl.
From iris_examples.concurrent_stacks Require Import spec.
From iris.base_logic.lib Require Import invariants.
From iris.program_logic Require Export weakestpre.
From iris_examples.concurrent_stacks Require Import specs.
Set Default Proof Using "Type".
(** Stack 2: With helping, bag spec. *)
(** Stack 2: Helping, bag spec. *)
Definition mk_offer : val :=
λ: "v", ("v", ref #0).
......@@ -17,49 +14,49 @@ Definition revoke_offer : val :=
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 mk_mailbox : val := λ: "_", ref NONEV.
Definition put : val :=
λ: "r" "v",
let: "off" := mk_offer "v" in
"r" <- SOME "off";;
revoke_offer "off".
Definition get : val :=
λ: "r",
let: "offopt" := !"r" in
match: "offopt" with
NONE => NONE
| SOME "x" => take_offer "x"
end.
Definition new_stack : val := λ: "_", (mk_mailbox #(), ref NONEV).
Definition push : val :=
rec: "push" "p" "v" :=
let: "mailbox" := Fst "p" in
let: "s" := Snd "p" in
match: put "mailbox" "v" with
NONE => #()
| SOME "v'" =>
let: "tail" := ! "s" in
let: "new" := SOME (ref ("v'", "tail")) in
if: CAS "s" "tail" "new" then #() else "push" "p" "v'"
end.
Definition pop : val :=
rec: "pop" "p" :=
let: "mailbox" := Fst "p" in
let: "s" := Snd "p" in
match: get "mailbox" with
NONE =>
match: !"s" with
NONE => NONEV
| SOME "l" =>
let: "pair" := !"l" in
if: CAS "s" (SOME "l") (Snd "pair")
then SOME (Fst "pair")
else "pop" "p"
end
| SOME "x" => SOME "x"
end.
Definition channelR := exclR unitR.
Class channelG Σ := { channel_inG :> inG Σ channelR }.
......@@ -68,350 +65,337 @@ Instance subG_channelΣ {Σ} : subG channelΣ Σ → channelG Σ.
Proof. solve_inG. Qed.
Section side_channel.
Context `{!heapG Σ, !channelG Σ}.
Context `{!heapG Σ, !channelG Σ} (N : namespace).
Implicit Types l : loc.
Definition revoke_tok γ := own γ (Excl ()).
Definition stages γ (P : val iProp Σ) l v :=
((l #0 P v)
(l #1)
(l #2 own γ (Excl ())))%I.
(l #2 revoke_tok γ))%I.
Definition is_offer γ (P : val iProp Σ) (v : val) : iProp Σ :=
( v' l, v = (v', #l)%V ι, inv ι (stages γ P l v'))%I.
( v' l, v = (v', #l)%V inv N (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.
Lemma mk_offer_works P v :
{{{ P v }}} mk_offer v {{{ o γ, RET o; is_offer γ P o revoke_tok γ }}}.
Proof.
iIntros (Φ) "HP HΦ".
rewrite -wp_fupd.
wp_lam. wp_alloc l as "Hl".
iMod (own_alloc (Excl ())) as (γ) "Hγ"; first done.
iMod (inv_alloc N _ (stages γ P l v) with "[Hl HP]") as "#Hinv".
{ iNext; iLeft; iFrame. }
wp_pures; iModIntro; iApply "HΦ"; iFrame; iExists _, _; auto.
Qed.
(* 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 #() }}.
Lemma revoke_works γ P v :
{{{ is_offer γ P v revoke_tok γ }}}
revoke_offer v
{{{ v', RET v'; ( v'' : val, v' = InjRV v'' P v'') v' = InjLV #() }}}.
Proof.
iIntros "[#Hinv Hγ]".
wp_let.
wp_proj.
wp_bind (CAS _ _ _).
iIntros (Φ) "[Hinv Hγ] HΦ". iDestruct "Hinv" as (v' l) "[-> #Hinv]".
wp_lam. wp_bind (CAS _ _ _). wp_pures.
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.
iDestruct "Hstages" as "[[Hl HP] | [H | [Hl H]]]".
- wp_cas_suc.
iMod ("Hclose" with "[Hl Hγ]") as "_".
{ iRight; iRight; iFrame. }
iModIntro.
wp_if.
wp_proj.
iLeft.
iExists v; iSplit; auto.
wp_pures.
by iApply "HΦ"; iLeft; iExists _; iSplit.
- wp_cas_fail.
iMod ("Hclose" with "[H]").
iRight; iLeft; auto.
iMod ("Hclose" with "[H]") as "_".
{ 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 %?.
wp_pures.
by iApply "HΦ"; iRight.
- wp_cas_fail.
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 #() }}.
Lemma take_works γ P o :
{{{ is_offer γ P o }}}