Commit fd89aa52 authored by Robbert Krebbers's avatar Robbert Krebbers

Invariants over states in WP and get rid of heap_ctx.

The WP construction now takes an invariant on states as a parameter
(part of the irisG class) and no longer builds in the authoritative
ownership of the entire state. When instantiating WP with a concrete
language on can choose its state invariant. For example, for heap_lang
we directly use `auth (gmap loc (frac * dec_agree val))`, and avoid
the indirection through invariants entirely.

As a result, we no longer have to carry `heap_ctx` around.
parent 617a69b4
From iris.program_logic Require Export weakestpre adequacy. From iris.program_logic Require Export weakestpre adequacy.
From iris.heap_lang Require Export heap. From iris.heap_lang Require Export heap.
From iris.algebra Require Import auth. From iris.algebra Require Import auth.
From iris.base_logic.lib Require Import wsat auth.
From iris.heap_lang Require Import proofmode notation. From iris.heap_lang Require Import proofmode notation.
From iris.proofmode Require Import tactics. From iris.proofmode Require Import tactics.
Class heapPreG Σ := HeapPreG { Class heapPreG Σ := HeapPreG {
heap_preG_iris :> irisPreG heap_lang Σ; heap_preG_iris :> invPreG Σ;
heap_preG_heap :> authG Σ heapUR heap_preG_heap :> inG Σ (authR heapUR)
}. }.
Definition heapΣ : gFunctors := Definition heapΣ : gFunctors := #[invΣ; GFunctor (constRF (authR heapUR))].
#[irisΣ state; authΣ heapUR].
Instance subG_heapPreG {Σ} : subG heapΣ Σ heapPreG Σ. Instance subG_heapPreG {Σ} : subG heapΣ Σ heapPreG Σ.
Proof. intros [? ?]%subG_inv. split; apply _. Qed. Proof. intros [? ?%subG_inG]%subG_inv. split; apply _. Qed.
Definition heap_adequacy Σ `{heapPreG Σ} e σ φ : Definition heap_adequacy Σ `{heapPreG Σ} e σ φ :
( `{heapG Σ}, heap_ctx WP e {{ v, ⌜φ v }}) ( `{heapG Σ}, True WP e {{ v, ⌜φ v }})
adequate e σ φ. adequate e σ φ.
Proof. Proof.
intros Hwp; eapply (wp_adequacy Σ); iIntros (?) "". intros Hwp; eapply (wp_adequacy _ _); iIntros (?) "".
iMod (auth_alloc to_heap _ heapN _ σ with "[Hσ]") as (γ) "[Hh _]";[|by iNext|]. iMod (own_alloc ( to_heap σ)) as (γ) "Hh".
{ exact: to_heap_valid. } { apply: auth_auth_valid. exact: to_heap_valid. }
set (Hheap := HeapG _ _ _ γ). iModIntro. iExists (λ σ, own γ ( to_heap σ)); iFrame.
iApply (Hwp _). by rewrite /heap_ctx. set (Hheap := HeapG _ _ _ γ). iApply (Hwp _).
Qed. Qed.
From iris.heap_lang Require Export lifting. From iris.heap_lang Require Export lifting.
From iris.algebra Require Import auth gmap frac dec_agree. From iris.algebra Require Import auth gmap frac dec_agree.
From iris.base_logic.lib Require Export invariants. From iris.base_logic.lib Require Export invariants.
From iris.base_logic.lib Require Import wsat auth fractional. From iris.base_logic.lib Require Import fractional.
From iris.program_logic Require Import ectx_lifting.
From iris.proofmode Require Import tactics. From iris.proofmode Require Import tactics.
Import uPred. Import uPred.
(* TODO: The entire construction could be generalized to arbitrary languages that have (* TODO: The entire construction could be generalized to arbitrary languages that have
a finmap as their state. Or maybe even beyond "as their state", i.e. arbitrary a finmap as their state. Or maybe even beyond "as their state", i.e. arbitrary
predicates over finmaps instead of just ownP. *) predicates over finmaps instead of just ownP. *)
Definition heapN : namespace := nroot .@ "heap".
Definition heapUR : ucmraT := gmapUR loc (prodR fracR (dec_agreeR val)). Definition heapUR : ucmraT := gmapUR loc (prodR fracR (dec_agreeR val)).
Definition to_heap : state heapUR := fmap (λ v, (1%Qp, DecAgree v)).
(** The CMRA we need. *) (** The CMRA we need. *)
Class heapG Σ := HeapG { Class heapG Σ := HeapG {
heapG_iris_inG :> irisG heap_lang Σ; heapG_invG : invG Σ;
heap_inG :> authG Σ heapUR; heap_inG :> inG Σ (authR heapUR);
heap_name : gname heap_name : gname
}. }.
Instance heapG_irisG `{heapG Σ} : irisG heap_lang Σ := {
Definition to_heap : state heapUR := fmap (λ v, (1%Qp, DecAgree v)). iris_invG := heapG_invG;
state_interp σ := own heap_name ( to_heap σ)
}.
Section definitions. Section definitions.
Context `{heapG Σ}. Context `{heapG Σ}.
Definition heap_mapsto_def (l : loc) (q : Qp) (v: val) : iProp Σ := Definition heap_mapsto_def (l : loc) (q : Qp) (v: val) : iProp Σ :=
auth_own heap_name ({[ l := (q, DecAgree v) ]}). own heap_name ( {[ l := (q, DecAgree v) ]}).
Definition heap_mapsto_aux : { x | x = @heap_mapsto_def }. by eexists. Qed. Definition heap_mapsto_aux : { x | x = @heap_mapsto_def }. by eexists. Qed.
Definition heap_mapsto := proj1_sig heap_mapsto_aux. Definition heap_mapsto := proj1_sig heap_mapsto_aux.
Definition heap_mapsto_eq : @heap_mapsto = @heap_mapsto_def := Definition heap_mapsto_eq : @heap_mapsto = @heap_mapsto_def :=
proj2_sig heap_mapsto_aux. proj2_sig heap_mapsto_aux.
Definition heap_ctx : iProp Σ := auth_ctx heap_name heapN to_heap ownP.
End definitions. End definitions.
Typeclasses Opaque heap_ctx heap_mapsto. Typeclasses Opaque heap_mapsto.
Notation "l ↦{ q } v" := (heap_mapsto l q v) Notation "l ↦{ q } v" := (heap_mapsto l q v)
(at level 20, q at level 50, format "l ↦{ q } v") : uPred_scope. (at level 20, q at level 50, format "l ↦{ q } v") : uPred_scope.
...@@ -43,6 +44,11 @@ Notation "l ↦{ q } -" := (∃ v, l ↦{q} v)%I ...@@ -43,6 +44,11 @@ Notation "l ↦{ q } -" := (∃ v, l ↦{q} v)%I
(at level 20, q at level 50, format "l ↦{ q } -") : uPred_scope. (at level 20, q at level 50, format "l ↦{ q } -") : uPred_scope.
Notation "l ↦ -" := (l {1} -)%I (at level 20) : uPred_scope. Notation "l ↦ -" := (l {1} -)%I (at level 20) : uPred_scope.
Local Hint Extern 0 (head_reducible _ _) => eexists _, _, _; simpl.
Local Hint Constructors head_step.
Local Hint Resolve alloc_fresh.
Local Hint Resolve to_of_val.
Section heap. Section heap.
Context {Σ : gFunctors}. Context {Σ : gFunctors}.
Implicit Types P Q : iProp Σ. Implicit Types P Q : iProp Σ.
...@@ -62,11 +68,6 @@ Section heap. ...@@ -62,11 +68,6 @@ Section heap.
move: Hl. rewrite /to_heap lookup_fmap fmap_Some=> -[v' [Hl [??]]]; subst. move: Hl. rewrite /to_heap lookup_fmap fmap_Some=> -[v' [Hl [??]]]; subst.
by move: Hqv=> /Some_pair_included_total_2 [_ /DecAgree_included ->]. by move: Hqv=> /Some_pair_included_total_2 [_ /DecAgree_included ->].
Qed. Qed.
Lemma heap_singleton_included' σ l q v :
{[l := (q, DecAgree v)]} to_heap σ to_heap σ !! l = Some (1%Qp,DecAgree v).
Proof.
intros Hl%heap_singleton_included. by rewrite /to_heap lookup_fmap Hl.
Qed.
Lemma to_heap_insert l v σ : Lemma to_heap_insert l v σ :
to_heap (<[l:=v]> σ) = <[l:=(1%Qp, DecAgree v)]> (to_heap σ). to_heap (<[l:=v]> σ) = <[l:=(1%Qp, DecAgree v)]> (to_heap σ).
Proof. by rewrite /to_heap fmap_insert. Qed. Proof. by rewrite /to_heap fmap_insert. Qed.
...@@ -74,26 +75,22 @@ Section heap. ...@@ -74,26 +75,22 @@ Section heap.
Context `{heapG Σ}. Context `{heapG Σ}.
(** General properties of mapsto *) (** General properties of mapsto *)
Global Instance heap_ctx_persistent : PersistentP heap_ctx.
Proof. rewrite /heap_ctx. apply _. Qed.
Global Instance heap_mapsto_timeless l q v : TimelessP (l {q} v). Global Instance heap_mapsto_timeless l q v : TimelessP (l {q} v).
Proof. rewrite heap_mapsto_eq /heap_mapsto_def. apply _. Qed. Proof. rewrite heap_mapsto_eq /heap_mapsto_def. apply _. Qed.
Global Instance heap_mapsto_fractional l v : Fractional (λ q, l {q} v)%I. Global Instance heap_mapsto_fractional l v : Fractional (λ q, l {q} v)%I.
Proof. Proof.
unfold Fractional; intros. intros p q. by rewrite heap_mapsto_eq -own_op -auth_frag_op
by rewrite heap_mapsto_eq -auth_own_op op_singleton pair_op dec_agree_idemp. op_singleton pair_op dec_agree_idemp.
Qed. Qed.
Global Instance heap_mapsto_as_fractional l q v : Global Instance heap_mapsto_as_fractional l q v :
AsFractional (l {q} v) (λ q, l {q} v)%I q. AsFractional (l {q} v) (λ q, l {q} v)%I q.
Proof. done. Qed. Proof. done. Qed.
Lemma heap_mapsto_agree l q1 q2 v1 v2 : Lemma heap_mapsto_agree l q1 q2 v1 v2 : l {q1} v1 l {q2} v2 v1 = v2.
l {q1} v1 l {q2} v2 v1 = v2.
Proof. Proof.
rewrite heap_mapsto_eq -auth_own_op auth_own_valid discrete_valid rewrite heap_mapsto_eq -own_op -auth_frag_op own_valid discrete_valid.
op_singleton singleton_valid. f_equiv=> /auth_own_valid /=. rewrite op_singleton singleton_valid pair_op.
f_equiv. move=>[_ ] /=. by move=> [_ /= /dec_agree_op_inv [?]].
destruct (decide (v1 = v2)) as [->|?]; first done. by rewrite dec_agree_ne.
Qed. Qed.
Global Instance heap_ex_mapsto_fractional l : Fractional (λ q, l {q} -)%I. Global Instance heap_ex_mapsto_fractional l : Fractional (λ q, l {q} -)%I.
...@@ -109,8 +106,8 @@ Section heap. ...@@ -109,8 +106,8 @@ Section heap.
Lemma heap_mapsto_valid l q v : l {q} v q. Lemma heap_mapsto_valid l q v : l {q} v q.
Proof. Proof.
rewrite heap_mapsto_eq /heap_mapsto_def auth_own_valid !discrete_valid. rewrite heap_mapsto_eq /heap_mapsto_def own_valid !discrete_valid.
by apply pure_mono=> /singleton_valid [??]. by apply pure_mono=> /auth_own_valid /singleton_valid [??].
Qed. Qed.
Lemma heap_mapsto_valid_2 l q1 q2 v1 v2 : Lemma heap_mapsto_valid_2 l q1 q2 v1 v2 :
l {q1} v1 l {q2} v2 (q1 + q2)%Qp. l {q1} v1 l {q2} v2 (q1 + q2)%Qp.
...@@ -121,74 +118,80 @@ Section heap. ...@@ -121,74 +118,80 @@ Section heap.
(** Weakest precondition *) (** Weakest precondition *)
Lemma wp_alloc E e v : Lemma wp_alloc E e v :
to_val e = Some v heapN E to_val e = Some v
{{{ heap_ctx }}} Alloc e @ E {{{ l, RET LitV (LitLoc l); l v }}}. {{{ True }}} Alloc e @ E {{{ l, RET LitV (LitLoc l); l v }}}.
Proof. Proof.
iIntros (<-%of_to_val ? Φ) "#Hinv HΦ". rewrite /heap_ctx. iIntros (<-%of_to_val Φ) "HΦ". iApply wp_lift_atomic_head_step_no_fork; auto.
iMod (auth_empty heap_name) as "Ha". iIntros (σ1) "Hσ !>"; iSplit; first by auto.
iMod (auth_open with "[$Hinv $Ha]") as (σ) "(%&Hσ&Hcl)"; first done. iNext; iIntros (v2 σ2 efs Hstep); inv_head_step.
iApply (wp_alloc_pst with "Hσ"). iNext. iIntros (l) "[% Hσ]". iMod (own_update with "Hσ") as "[Hσ Hl]".
iMod ("Hcl" with "* [Hσ]") as "Ha". { eapply auth_update_alloc,
{ iFrame. iPureIntro. rewrite to_heap_insert. (alloc_singleton_local_update _ _ (1%Qp, DecAgree _))=> //.
eapply alloc_singleton_local_update; by auto using lookup_to_heap_None. } by apply lookup_to_heap_None. }
iModIntro; iSplit=> //. rewrite to_heap_insert. iFrame.
iApply "HΦ". by rewrite heap_mapsto_eq /heap_mapsto_def. iApply "HΦ". by rewrite heap_mapsto_eq /heap_mapsto_def.
Qed. Qed.
Lemma wp_load E l q v : Lemma wp_load E l q v :
heapN E {{{ l {q} v }}} Load (Lit (LitLoc l)) @ E {{{ RET v; l {q} v }}}.
{{{ heap_ctx l {q} v }}} Load (Lit (LitLoc l)) @ E
{{{ RET v; l {q} v }}}.
Proof. Proof.
iIntros (? Φ) "[#Hinv >Hl] HΦ". iIntros (Φ) ">Hl HΦ". rewrite heap_mapsto_eq /heap_mapsto_def.
rewrite /heap_ctx heap_mapsto_eq /heap_mapsto_def. iApply wp_lift_atomic_head_step_no_fork; auto.
iMod (auth_open with "[$Hinv $Hl]") as (σ) "(%&Hσ&Hcl)"; first done. iIntros (σ1) "Hσ !>". iDestruct (own_valid_2 with "Hσ Hl")
iApply (wp_load_pst _ σ with "Hσ"); first eauto using heap_singleton_included. as %[?%heap_singleton_included _]%auth_valid_discrete_2.
iNext; iIntros "Hσ". iSplit; first by eauto.
iMod ("Hcl" with "* [Hσ]") as "Ha"; first eauto. by iApply "HΦ". iNext; iIntros (v2 σ2 efs Hstep); inv_head_step.
iModIntro; iSplit=> //. iFrame. by iApply "HΦ".
Qed. Qed.
Lemma wp_store E l v' e v : Lemma wp_store E l v' e v :
to_val e = Some v heapN E to_val e = Some v
{{{ heap_ctx l v' }}} Store (Lit (LitLoc l)) e @ E {{{ l v' }}} Store (Lit (LitLoc l)) e @ E {{{ RET LitV LitUnit; l v }}}.
{{{ RET LitV LitUnit; l v }}}.
Proof. Proof.
iIntros (<-%of_to_val ? Φ) "[#Hinv >Hl] HΦ". iIntros (<-%of_to_val Φ) ">Hl HΦ". rewrite heap_mapsto_eq /heap_mapsto_def.
rewrite /heap_ctx heap_mapsto_eq /heap_mapsto_def. iApply wp_lift_atomic_head_step_no_fork; auto.
iMod (auth_open with "[$Hinv $Hl]") as (σ) "(%&Hσ&Hcl)"; first done. iIntros (σ1) "Hσ !>". iDestruct (own_valid_2 with "Hσ Hl")
iApply (wp_store_pst _ σ with "Hσ"); first eauto using heap_singleton_included. as %[Hl%heap_singleton_included _]%auth_valid_discrete_2.
iNext; iIntros "Hσ". iMod ("Hcl" with "* [Hσ]") as "Ha". iSplit; first by eauto.
{ iFrame. iPureIntro. rewrite to_heap_insert. iNext; iIntros (v2 σ2 efs Hstep); inv_head_step.
eapply singleton_local_update, exclusive_local_update; last done. iMod (own_update_2 with "Hσ Hl") as "[Hσ1 Hl]".
by eapply heap_singleton_included'. } { eapply auth_update, singleton_local_update,
by iApply "HΦ". (exclusive_local_update _ (1%Qp, DecAgree _))=> //.
by rewrite /to_heap lookup_fmap Hl. }
iModIntro. iSplit=>//. rewrite to_heap_insert. iFrame. by iApply "HΦ".
Qed. Qed.
Lemma wp_cas_fail E l q v' e1 v1 e2 v2 : Lemma wp_cas_fail E l q v' e1 v1 e2 v2 :
to_val e1 = Some v1 to_val e2 = Some v2 v' v1 heapN E to_val e1 = Some v1 to_val e2 = Some v2 v' v1
{{{ heap_ctx l {q} v' }}} CAS (Lit (LitLoc l)) e1 e2 @ E {{{ l {q} v' }}} CAS (Lit (LitLoc l)) e1 e2 @ E
{{{ RET LitV (LitBool false); l {q} v' }}}. {{{ RET LitV (LitBool false); l {q} v' }}}.
Proof. Proof.
iIntros (<-%of_to_val <-%of_to_val ?? Φ) "[#Hinv >Hl] HΦ". iIntros (<-%of_to_val <-%of_to_val ? Φ) ">Hl HΦ".
rewrite /heap_ctx heap_mapsto_eq /heap_mapsto_def. rewrite heap_mapsto_eq /heap_mapsto_def.
iMod (auth_open with "[$Hinv $Hl]") as (σ) "(%&Hσ&Hcl)"; first done. iApply wp_lift_atomic_head_step_no_fork; auto.
iApply (wp_cas_fail_pst _ σ with "Hσ"); [eauto using heap_singleton_included|done|]. iIntros (σ1) "Hσ !>". iDestruct (own_valid_2 with "Hσ Hl")
iNext; iIntros "Hσ". as %[?%heap_singleton_included _]%auth_valid_discrete_2.
iMod ("Hcl" with "* [Hσ]") as "Ha"; first eauto. by iApply "HΦ". iSplit; first by eauto.
iNext; iIntros (v2' σ2 efs Hstep); inv_head_step. (* FIXME: this inversion is slow *)
iModIntro; iSplit=> //. iFrame. by iApply "HΦ".
Qed. Qed.
Lemma wp_cas_suc E l e1 v1 e2 v2 : Lemma wp_cas_suc E l e1 v1 e2 v2 :
to_val e1 = Some v1 to_val e2 = Some v2 heapN E to_val e1 = Some v1 to_val e2 = Some v2
{{{ heap_ctx l v1 }}} CAS (Lit (LitLoc l)) e1 e2 @ E {{{ l v1 }}} CAS (Lit (LitLoc l)) e1 e2 @ E
{{{ RET LitV (LitBool true); l v2 }}}. {{{ RET LitV (LitBool true); l v2 }}}.
Proof. Proof.
iIntros (<-%of_to_val <-%of_to_val ? Φ) "[#Hinv >Hl] HΦ". iIntros (<-%of_to_val <-%of_to_val Φ) ">Hl HΦ".
rewrite /heap_ctx heap_mapsto_eq /heap_mapsto_def. rewrite heap_mapsto_eq /heap_mapsto_def.
iMod (auth_open with "[$Hinv $Hl]") as (σ) "(%&Hσ&Hcl)"; first done. iApply wp_lift_atomic_head_step_no_fork; auto.
iApply (wp_cas_suc_pst _ σ with "Hσ"); first by eauto using heap_singleton_included. iIntros (σ1) "Hσ !>". iDestruct (own_valid_2 with "Hσ Hl")
iNext. iIntros "Hσ". iMod ("Hcl" with "* [Hσ]") as "Ha". as %[Hl%heap_singleton_included _]%auth_valid_discrete_2.
{ iFrame. iPureIntro. rewrite to_heap_insert. iSplit; first by eauto.
eapply singleton_local_update, exclusive_local_update; last done. iNext; iIntros (v2' σ2 efs Hstep); inv_head_step.
by eapply heap_singleton_included'. } iMod (own_update_2 with "Hσ Hl") as "[Hσ1 Hl]".
by iApply "HΦ". { eapply auth_update, singleton_local_update,
(exclusive_local_update _ (1%Qp, DecAgree _))=> //.
by rewrite /to_heap lookup_fmap Hl. }
iModIntro. iSplit=>//. rewrite to_heap_insert. iFrame. by iApply "HΦ".
Qed. Qed.
End heap. End heap.
...@@ -38,7 +38,7 @@ Definition barrier_inv (l : loc) (P : iProp Σ) (s : state) : iProp Σ := ...@@ -38,7 +38,7 @@ Definition barrier_inv (l : loc) (P : iProp Σ) (s : state) : iProp Σ :=
(l s ress (state_to_prop s P) (state_I s))%I. (l s ress (state_to_prop s P) (state_I s))%I.
Definition barrier_ctx (γ : gname) (l : loc) (P : iProp Σ) : iProp Σ := Definition barrier_ctx (γ : gname) (l : loc) (P : iProp Σ) : iProp Σ :=
(heapN N heap_ctx sts_ctx γ N (barrier_inv l P))%I. sts_ctx γ N (barrier_inv l P).
Definition send (l : loc) (P : iProp Σ) : iProp Σ := Definition send (l : loc) (P : iProp Σ) : iProp Σ :=
( γ, barrier_ctx γ l P sts_ownS γ low_states {[ Send ]})%I. ( γ, barrier_ctx γ l P sts_ownS γ low_states {[ Send ]})%I.
...@@ -91,10 +91,9 @@ Qed. ...@@ -91,10 +91,9 @@ Qed.
(** Actual proofs *) (** Actual proofs *)
Lemma newbarrier_spec (P : iProp Σ) : Lemma newbarrier_spec (P : iProp Σ) :
heapN N {{{ True }}} newbarrier #() {{{ l, RET #l; recv l P send l P }}}.
{{{ heap_ctx }}} newbarrier #() {{{ l, RET #l; recv l P send l P }}}.
Proof. Proof.
iIntros (HN Φ) "#? HΦ". iIntros (Φ) "HΦ".
rewrite -wp_fupd /newbarrier /=. wp_seq. wp_alloc l as "Hl". rewrite -wp_fupd /newbarrier /=. wp_seq. wp_alloc l as "Hl".
iApply ("HΦ" with ">[-]"). iApply ("HΦ" with ">[-]").
iMod (saved_prop_alloc (F:=idCF) P) as (γ) "#?". iMod (saved_prop_alloc (F:=idCF) P) as (γ) "#?".
...@@ -120,7 +119,7 @@ Lemma signal_spec l P : ...@@ -120,7 +119,7 @@ Lemma signal_spec l P :
{{{ send l P P }}} signal #l {{{ RET #(); True }}}. {{{ send l P P }}} signal #l {{{ RET #(); True }}}.
Proof. Proof.
rewrite /signal /send /barrier_ctx /=. rewrite /signal /send /barrier_ctx /=.
iIntros (Φ) "(Hs&HP) HΦ"; iDestruct "Hs" as (γ) "[#(%&Hh&Hsts) Hγ]". wp_let. iIntros (Φ) "[Hs HP] HΦ". iDestruct "Hs" as (γ) "[#Hsts Hγ]". wp_let.
iMod (sts_openS (barrier_inv l P) _ _ γ with "[Hγ]") iMod (sts_openS (barrier_inv l P) _ _ γ with "[Hγ]")
as ([p I]) "(% & [Hl Hr] & Hclose)"; eauto. as ([p I]) "(% & [Hl Hr] & Hclose)"; eauto.
destruct p; [|done]. wp_store. destruct p; [|done]. wp_store.
...@@ -136,7 +135,7 @@ Lemma wait_spec l P: ...@@ -136,7 +135,7 @@ Lemma wait_spec l P:
{{{ recv l P }}} wait #l {{{ RET #(); P }}}. {{{ recv l P }}} wait #l {{{ RET #(); P }}}.
Proof. Proof.
rename P into R; rewrite /recv /barrier_ctx. rename P into R; rewrite /recv /barrier_ctx.
iIntros (Φ) "Hr HΦ"; iDestruct "Hr" as (γ P Q i) "(#(%&Hh&Hsts)&Hγ&#HQ&HQR)". iIntros (Φ) "Hr HΦ"; iDestruct "Hr" as (γ P Q i) "(#Hsts & Hγ & #HQ & HQR)".
iLöb as "IH". wp_rec. wp_bind (! _)%E. iLöb as "IH". wp_rec. wp_bind (! _)%E.
iMod (sts_openS (barrier_inv l P) _ _ γ with "[Hγ]") iMod (sts_openS (barrier_inv l P) _ _ γ with "[Hγ]")
as ([p I]) "(% & [Hl Hr] & Hclose)"; eauto. as ([p I]) "(% & [Hl Hr] & Hclose)"; eauto.
...@@ -165,7 +164,7 @@ Lemma recv_split E l P1 P2 : ...@@ -165,7 +164,7 @@ Lemma recv_split E l P1 P2 :
N E recv l (P1 P2) ={E}= recv l P1 recv l P2. N E recv l (P1 P2) ={E}= recv l P1 recv l P2.
Proof. Proof.
rename P1 into R1; rename P2 into R2. rewrite {1}/recv /barrier_ctx. rename P1 into R1; rename P2 into R2. rewrite {1}/recv /barrier_ctx.
iIntros (?). iDestruct 1 as (γ P Q i) "(#(%&Hh&Hsts)&Hγ&#HQ&HQR)". iIntros (?). iDestruct 1 as (γ P Q i) "(#Hsts & Hγ & #HQ & HQR)".
iMod (sts_openS (barrier_inv l P) _ _ γ with "[Hγ]") iMod (sts_openS (barrier_inv l P) _ _ γ with "[Hγ]")
as ([p I]) "(% & [Hl Hr] & Hclose)"; eauto. as ([p I]) "(% & [Hl Hr] & Hclose)"; eauto.
iMod (saved_prop_alloc_strong (R1: %CF (iProp Σ)) I) as (i1) "[% #Hi1]". iMod (saved_prop_alloc_strong (R1: %CF (iProp Σ)) I) as (i1) "[% #Hi1]".
......
...@@ -8,19 +8,17 @@ Section spec. ...@@ -8,19 +8,17 @@ Section spec.
Context `{!heapG Σ} `{!barrierG Σ}. Context `{!heapG Σ} `{!barrierG Σ}.
Lemma barrier_spec (N : namespace) : Lemma barrier_spec (N : namespace) :
heapN N
recv send : loc iProp Σ -n> iProp Σ, recv send : loc iProp Σ -n> iProp Σ,
( P, heap_ctx {{ True }} newbarrier #() ( P, {{ True }} newbarrier #()
{{ v, l : loc, v = #l recv l P send l P }}) {{ v, l : loc, v = #l recv l P send l P }})
( l P, {{ send l P P }} signal #l {{ _, True }}) ( l P, {{ send l P P }} signal #l {{ _, True }})
( l P, {{ recv l P }} wait #l {{ _, P }}) ( l P, {{ recv l P }} wait #l {{ _, P }})
( l P Q, recv l (P Q) ={N}=> recv l P recv l Q) ( l P Q, recv l (P Q) ={N}=> recv l P recv l Q)
( l P Q, (P - Q) recv l P - recv l Q). ( l P Q, (P - Q) recv l P - recv l Q).
Proof. Proof.
intros HN.
exists (λ l, CofeMor (recv N l)), (λ l, CofeMor (send N l)). exists (λ l, CofeMor (recv N l)), (λ l, CofeMor (send N l)).
split_and?; simpl. split_and?; simpl.
- iIntros (P) "#? !# _". iApply (newbarrier_spec _ P with "[]"); [done..|]. - iIntros (P) "!# _". iApply (newbarrier_spec _ P with "[]"); [done..|].
iNext. eauto. iNext. eauto.
- iIntros (l P) "!# [Hl HP]". iApply (signal_spec with "[$Hl $HP]"). by eauto. - iIntros (l P) "!# [Hl HP]". iApply (signal_spec with "[$Hl $HP]"). by eauto.
- iIntros (l P) "!# Hl". iApply (wait_spec with "Hl"). eauto. - iIntros (l P) "!# Hl". iApply (wait_spec with "Hl"). eauto.
......
...@@ -24,18 +24,16 @@ Section mono_proof. ...@@ -24,18 +24,16 @@ Section mono_proof.
( n, own γ ( (n : mnat)) l #n)%I. ( n, own γ ( (n : mnat)) l #n)%I.
Definition mcounter (l : loc) (n : nat) : iProp Σ := Definition mcounter (l : loc) (n : nat) : iProp Σ :=
( γ, heapN N heap_ctx ( γ, inv N (mcounter_inv γ l) own γ ( (n : mnat)))%I.
inv N (mcounter_inv γ l) own γ ( (n : mnat)))%I.
(** The main proofs. *) (** The main proofs. *)
Global Instance mcounter_persistent l n : PersistentP (mcounter l n). Global Instance mcounter_persistent l n : PersistentP (mcounter l n).
Proof. apply _. Qed. Proof. apply _. Qed.
Lemma newcounter_mono_spec (R : iProp Σ) : Lemma newcounter_mono_spec (R : iProp Σ) :
heapN N {{{ True }}} newcounter #() {{{ l, RET #l; mcounter l 0 }}}.
{{{ heap_ctx }}} newcounter #() {{{ l, RET #l; mcounter l 0 }}}.
Proof. Proof.
iIntros (? Φ) "#Hh HΦ". rewrite -wp_fupd /newcounter. wp_seq. wp_alloc l as "Hl". iIntros (Φ) "HΦ". rewrite -wp_fupd /newcounter /=. wp_seq. wp_alloc l as "Hl".
iMod (own_alloc ( (O:mnat) (O:mnat))) as (γ) "[Hγ Hγ']"; first done. iMod (own_alloc ( (O:mnat) (O:mnat))) as (γ) "[Hγ Hγ']"; first done.
iMod (inv_alloc N _ (mcounter_inv γ l) with "[Hl Hγ]"). iMod (inv_alloc N _ (mcounter_inv γ l) with "[Hl Hγ]").
{ iNext. iExists 0%nat. by iFrame. } { iNext. iExists 0%nat. by iFrame. }
...@@ -46,7 +44,7 @@ Section mono_proof. ...@@ -46,7 +44,7 @@ Section mono_proof.
{{{ mcounter l n }}} incr #l {{{ RET #(); mcounter l (S n) }}}. {{{ mcounter l n }}} incr #l {{{ RET #(); mcounter l (S n) }}}.
Proof. Proof.
iIntros (Φ) "Hl HΦ". iLöb as "IH". wp_rec. iIntros (Φ) "Hl HΦ". iLöb as "IH". wp_rec.
iDestruct "Hl" as (γ) "(% & #? & #Hinv & Hγf)". iDestruct "Hl" as (γ) "[#Hinv Hγf]".
wp_bind (! _)%E. iInv N as (c) ">[Hγ Hl]" "Hclose". wp_bind (! _)%E. iInv N as (c) ">[Hγ Hl]" "Hclose".
wp_load. iMod ("Hclose" with "[Hl Hγ]") as "_"; [iNext; iExists c; by iFrame|]. wp_load. iMod ("Hclose" with "[Hl Hγ]") as "_"; [iNext; iExists c; by iFrame|].
iModIntro. wp_let. wp_op. iModIntro. wp_let. wp_op.
...@@ -70,7 +68,7 @@ Section mono_proof. ...@@ -70,7 +68,7 @@ Section mono_proof.
Lemma read_mono_spec l j : Lemma read_mono_spec l j :
{{{ mcounter l j }}} read #l {{{ i, RET #i; j i%nat mcounter l i }}}. {{{ mcounter l j }}} read #l {{{ i, RET #i; j i%nat mcounter l i }}}.
Proof. Proof.
iIntros (ϕ) "Hc HΦ". iDestruct "Hc" as (γ) "(% & #? & #Hinv & Hγf)". iIntros (ϕ) "Hc HΦ". iDestruct "Hc" as (γ) "[#Hinv Hγf]".
rewrite /read /=. wp_let. iInv N as (c) ">[Hγ Hl]" "Hclose". wp_load.