Commit 1f589858 authored by Robbert Krebbers's avatar Robbert Krebbers
Browse files

Iris 3.0: invariants and weakest preconditions encoded in the logic.

This commit features:

- A simpler model. The recursive domain equation no longer involves a triple
  containing invariants, physical state and ghost state, but just ghost state.
  Invariants and physical state are encoded using (higher-order) ghost state.

- (Primitive) view shifts are formalized in the logic and all properties about
  it are proven in the logic instead of the model. Instead, the core logic
  features only a notion of raw view shifts which internalizing performing frame
  preserving updates.

- A better behaved notion of mask changing view shifts. In particular, we no
  longer have side-conditions on transitivity of view shifts, and we have a
  rule for introduction of mask changing view shifts |={E1,E2}=> P with
  E2 ⊆ E1 which allows to postpone performing a view shift.

- The weakest precondition connective is formalized in the logic using Banach's
  fixpoint. All properties about the connective are proven in the logic instead
  of directly in the model.

- Adequacy is proven in the logic and uses a primitive form of adequacy for
  uPred that only involves raw views shifts and laters.

Some remarks:

- I have removed binary view shifts. I did not see a way to describe all rules
  of the new mask changing view shifts using those.
- There is no longer the need for the notion of "frame shifting assertions" and
  these are thus removed. The rules for Hoare triples are thus also stated in
  terms of primitive view shifts.

TODO:

- Maybe rename primitive view shift into something more sensible
- Figure out a way to deal with closed proofs (see the commented out stuff in
  tests/heap_lang and tests/barrier_client).
parent 6b6381fe
...@@ -66,13 +66,9 @@ program_logic/model.v ...@@ -66,13 +66,9 @@ program_logic/model.v
program_logic/adequacy.v program_logic/adequacy.v
program_logic/lifting.v program_logic/lifting.v
program_logic/invariants.v program_logic/invariants.v
program_logic/viewshifts.v
program_logic/wsat.v
program_logic/ownership.v program_logic/ownership.v
program_logic/weakestpre.v program_logic/weakestpre.v
program_logic/weakestpre_fix.v
program_logic/pviewshifts.v program_logic/pviewshifts.v
program_logic/resources.v
program_logic/hoare.v program_logic/hoare.v
program_logic/language.v program_logic/language.v
program_logic/ectx_language.v program_logic/ectx_language.v
...@@ -86,6 +82,7 @@ program_logic/sts.v ...@@ -86,6 +82,7 @@ program_logic/sts.v
program_logic/namespaces.v program_logic/namespaces.v
program_logic/boxes.v program_logic/boxes.v
program_logic/counter_examples.v program_logic/counter_examples.v
program_logic/iris.v
heap_lang/lang.v heap_lang/lang.v
heap_lang/tactics.v heap_lang/tactics.v
heap_lang/wp_tactics.v heap_lang/wp_tactics.v
...@@ -105,7 +102,6 @@ heap_lang/lib/barrier/protocol.v ...@@ -105,7 +102,6 @@ heap_lang/lib/barrier/protocol.v
heap_lang/lib/barrier/proof.v heap_lang/lib/barrier/proof.v
heap_lang/proofmode.v heap_lang/proofmode.v
tests/heap_lang.v tests/heap_lang.v
tests/program_logic.v
tests/one_shot.v tests/one_shot.v
tests/joining_existentials.v tests/joining_existentials.v
tests/proofmode.v tests/proofmode.v
...@@ -122,6 +118,5 @@ proofmode/notation.v ...@@ -122,6 +118,5 @@ proofmode/notation.v
proofmode/invariants.v proofmode/invariants.v
proofmode/weakestpre.v proofmode/weakestpre.v
proofmode/ghost_ownership.v proofmode/ghost_ownership.v
proofmode/sts.v
proofmode/classes.v proofmode/classes.v
proofmode/class_instances.v proofmode/class_instances.v
...@@ -12,9 +12,9 @@ Notation Skip := (Seq (Lit LitUnit) (Lit LitUnit)). ...@@ -12,9 +12,9 @@ Notation Skip := (Seq (Lit LitUnit) (Lit LitUnit)).
Notation Match e0 x1 e1 x2 e2 := (Case e0 (Lam x1 e1) (Lam x2 e2)). Notation Match e0 x1 e1 x2 e2 := (Case e0 (Lam x1 e1) (Lam x2 e2)).
Section derived. Section derived.
Context {Σ : iFunctor}. Context `{irisG heap_lang Σ}.
Implicit Types P Q : iProp heap_lang Σ. Implicit Types P Q : iProp Σ.
Implicit Types Φ : val iProp heap_lang Σ. Implicit Types Φ : val iProp Σ.
(** Proof rules for the sugar *) (** Proof rules for the sugar *)
Lemma wp_lam E x ef e Φ : Lemma wp_lam E x ef e Φ :
......
From iris.heap_lang Require Export lifting. From iris.heap_lang Require Export lifting.
From iris.algebra Require Import upred_big_op frac dec_agree. From iris.algebra Require Import upred_big_op gmap frac dec_agree.
From iris.program_logic Require Export invariants ghost_ownership. From iris.program_logic Require Export invariants ghost_ownership.
From iris.program_logic Require Import ownership auth. From iris.program_logic Require Import ownership auth.
From iris.proofmode Require Import weakestpre. From iris.proofmode Require Import weakestpre.
...@@ -13,7 +13,8 @@ Definition heapUR : ucmraT := gmapUR loc (prodR fracR (dec_agreeR val)). ...@@ -13,7 +13,8 @@ Definition heapUR : ucmraT := gmapUR loc (prodR fracR (dec_agreeR val)).
(** The CMRA we need. *) (** The CMRA we need. *)
Class heapG Σ := HeapG { Class heapG Σ := HeapG {
heap_inG :> authG heap_lang Σ heapUR; heapG_iris_inG :> irisG heap_lang Σ;
heap_inG :> authG Σ heapUR;
heap_name : gname heap_name : gname
}. }.
(** The Functor we need. *) (** The Functor we need. *)
...@@ -25,16 +26,16 @@ Definition of_heap : heapUR → state := omap (maybe DecAgree ∘ snd). ...@@ -25,16 +26,16 @@ Definition of_heap : heapUR → state := omap (maybe DecAgree ∘ snd).
Section definitions. Section definitions.
Context `{heapG Σ}. Context `{heapG Σ}.
Definition heap_mapsto_def (l : loc) (q : Qp) (v: val) : iPropG heap_lang Σ := Definition heap_mapsto_def (l : loc) (q : Qp) (v: val) : iProp Σ :=
auth_own heap_name {[ l := (q, DecAgree v) ]}. auth_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_inv (h : heapUR) : iPropG heap_lang Σ := Definition heap_inv (h : heapUR) : iProp Σ :=
ownP (of_heap h). ownP (of_heap h).
Definition heap_ctx : iPropG heap_lang Σ := Definition heap_ctx : iProp Σ :=
auth_ctx heap_name heapN heap_inv. auth_ctx heap_name heapN heap_inv.
Global Instance heap_inv_proper : Proper (() ==> ()) heap_inv. Global Instance heap_inv_proper : Proper (() ==> ()) heap_inv.
...@@ -44,9 +45,7 @@ Section definitions. ...@@ -44,9 +45,7 @@ Section definitions.
End definitions. End definitions.
Typeclasses Opaque heap_ctx heap_mapsto. Typeclasses Opaque heap_ctx heap_mapsto.
Instance: Params (@heap_inv) 1. Instance: Params (@heap_inv) 2.
Instance: Params (@heap_mapsto) 4.
Instance: Params (@heap_ctx) 2.
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.
...@@ -54,8 +53,8 @@ Notation "l ↦ v" := (heap_mapsto l 1 v) (at level 20) : uPred_scope. ...@@ -54,8 +53,8 @@ Notation "l ↦ v" := (heap_mapsto l 1 v) (at level 20) : uPred_scope.
Section heap. Section heap.
Context {Σ : gFunctors}. Context {Σ : gFunctors}.
Implicit Types P Q : iPropG heap_lang Σ. Implicit Types P Q : iProp Σ.
Implicit Types Φ : val iPropG heap_lang Σ. Implicit Types Φ : val iProp Σ.
Implicit Types σ : state. Implicit Types σ : state.
Implicit Types h g : heapUR. Implicit Types h g : heapUR.
...@@ -103,15 +102,14 @@ Section heap. ...@@ -103,15 +102,14 @@ Section heap.
Hint Resolve heap_store_valid. Hint Resolve heap_store_valid.
(** Allocation *) (** Allocation *)
Lemma heap_alloc E σ : Lemma heap_alloc `{irisG heap_lang Σ, authG Σ heapUR} E σ :
authG heap_lang Σ heapUR nclose heapN E
ownP σ ={E}=> _ : heapG Σ, heap_ctx [ map] lv σ, l v. ownP σ ={E}=> _ : heapG Σ, heap_ctx [ map] lv σ, l v.
Proof. Proof.
intros. rewrite -{1}(from_to_heap σ). etrans. intros. rewrite -{1}(from_to_heap σ). etrans.
{ rewrite [ownP _]later_intro. { rewrite [ownP _]later_intro.
apply (auth_alloc (ownP of_heap) heapN E); auto using to_heap_valid. } apply (auth_alloc (ownP of_heap) heapN E); auto using to_heap_valid. }
apply pvs_mono, exist_elim=> γ. apply pvs_mono, exist_elim=> γ.
rewrite -(exist_intro (HeapG _ _ γ)) /heap_ctx; apply and_mono_r. rewrite -(exist_intro (HeapG _ _ _ γ)) /heap_ctx; apply and_mono_r.
rewrite heap_mapsto_eq /heap_mapsto_def /heap_name. rewrite heap_mapsto_eq /heap_mapsto_def /heap_name.
induction σ as [|l v σ Hl IH] using map_ind. induction σ as [|l v σ Hl IH] using map_ind.
{ rewrite big_sepM_empty; apply True_intro. } { rewrite big_sepM_empty; apply True_intro. }
...@@ -157,22 +155,21 @@ Section heap. ...@@ -157,22 +155,21 @@ Section heap.
Proof. by rewrite heap_mapsto_op_half. Qed. Proof. by rewrite heap_mapsto_op_half. Qed.
(** Weakest precondition *) (** Weakest precondition *)
(* FIXME: try to reduce usage of wp_pvs. We're losing view shifts here. *)
Lemma wp_alloc E e v Φ : Lemma wp_alloc E e v Φ :
to_val e = Some v nclose heapN E to_val e = Some v nclose heapN E
heap_ctx ( l, l v ={E}= Φ (LitV (LitLoc l))) WP Alloc e @ E {{ Φ }}. heap_ctx ( l, l v ={E}= Φ (LitV (LitLoc l))) WP Alloc e @ E {{ Φ }}.
Proof. Proof.
iIntros (<-%of_to_val ?) "[#Hinv HΦ]". rewrite /heap_ctx. iIntros (<-%of_to_val ?) "[#Hinv HΦ]". rewrite /heap_ctx.
iPvs (auth_empty heap_name) as "Hheap". iVs (auth_empty heap_name) as "Hh".
iApply wp_pvs; iApply (auth_fsa heap_inv (wp_fsa _)); eauto with fsaV. iVs (auth_open with "[Hh]") as (h) "[Hv [Hh Hclose]]"; eauto.
iFrame "Hinv Hheap". iIntros (h). rewrite left_id. rewrite left_id /heap_inv. iDestruct "Hv" as %?.
iIntros "[% Hheap]". rewrite /heap_inv. iApply wp_alloc_pst. iFrame "Hh". iNext.
iApply wp_alloc_pst. iFrame "Hheap". iNext. iIntros (l) "[% Hh]"; iVsIntro.
iIntros (l) "[% Hheap]"; iPvsIntro; iExists {[ l := (1%Qp, DecAgree v) ]}. iVs ("Hclose" $! {[ l := (1%Qp, DecAgree v) ]} with "[Hh]").
rewrite -of_heap_insert -(insert_singleton_op h); last by apply of_heap_None. { rewrite -of_heap_insert -(insert_singleton_op h); last by apply of_heap_None.
iFrame "Hheap". iSplitR; first iPureIntro. iFrame "Hh". iPureIntro.
{ by apply alloc_unit_singleton_local_update; first apply of_heap_None. } by apply alloc_unit_singleton_local_update; first apply of_heap_None. }
iIntros "Hheap". 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 Φ :
...@@ -180,14 +177,15 @@ Section heap. ...@@ -180,14 +177,15 @@ Section heap.
heap_ctx l {q} v (l {q} v ={E}= Φ v) heap_ctx l {q} v (l {q} v ={E}= Φ v)
WP Load (Lit (LitLoc l)) @ E {{ Φ }}. WP Load (Lit (LitLoc l)) @ E {{ Φ }}.
Proof. Proof.
iIntros (?) "[#Hh [Hl HΦ]]". iIntros (?) "[#Hinv [Hl HΦ]]".
rewrite /heap_ctx heap_mapsto_eq /heap_mapsto_def. rewrite /heap_ctx heap_mapsto_eq /heap_mapsto_def.
iApply wp_pvs; iApply (auth_fsa heap_inv (wp_fsa _)); eauto with fsaV. iVs (auth_open with "[Hl]") as (h) "[% [Hl Hclose]]"; eauto.
iFrame "Hh Hl". iIntros (h) "[% Hl]". rewrite /heap_inv. rewrite /heap_inv.
iApply (wp_load_pst _ (<[l:=v]>(of_heap h)));first by rewrite lookup_insert. iApply (wp_load_pst _ (<[l:=v]>(of_heap h)));first by rewrite lookup_insert.
rewrite of_heap_singleton_op //. iFrame "Hl". rewrite of_heap_singleton_op //. iFrame "Hl".
iIntros "> Hown". iPvsIntro. iExists _; iSplit; first done. iIntros "> Hown". iVsIntro. iVs ("Hclose" with "* [Hown]").
rewrite of_heap_singleton_op //. by iFrame. { iSplit; first done. rewrite of_heap_singleton_op //. by iFrame. }
by iApply "HΦ".
Qed. Qed.
Lemma wp_store E l v' e v Φ : Lemma wp_store E l v' e v Φ :
...@@ -195,15 +193,18 @@ Section heap. ...@@ -195,15 +193,18 @@ Section heap.
heap_ctx l v' (l v ={E}= Φ (LitV LitUnit)) heap_ctx l v' (l v ={E}= Φ (LitV LitUnit))
WP Store (Lit (LitLoc l)) e @ E {{ Φ }}. WP Store (Lit (LitLoc l)) e @ E {{ Φ }}.
Proof. Proof.
iIntros (<-%of_to_val ?) "[#Hh [Hl HΦ]]". iIntros (<-%of_to_val ?) "[#Hinv [Hl HΦ]]".
rewrite /heap_ctx heap_mapsto_eq /heap_mapsto_def. rewrite /heap_ctx heap_mapsto_eq /heap_mapsto_def.
iApply wp_pvs; iApply (auth_fsa heap_inv (wp_fsa _)); eauto with fsaV. iVs (auth_open with "[Hl]") as (h) "[% [Hl Hclose]]"; eauto.
iFrame "Hh Hl". iIntros (h) "[% Hl]". rewrite /heap_inv. rewrite /heap_inv.
iApply (wp_store_pst _ (<[l:=v']>(of_heap h))); rewrite ?lookup_insert //. iApply (wp_store_pst _ (<[l:=v']>(of_heap h))); rewrite ?lookup_insert //.
rewrite insert_insert !of_heap_singleton_op; eauto. iFrame "Hl". rewrite insert_insert !of_heap_singleton_op; eauto. iFrame "Hl".
iIntros "> Hown". iPvsIntro. iExists {[l := (1%Qp, DecAgree v)]}; iSplit. iIntros "> Hl". iVsIntro.
{ iPureIntro; by apply singleton_local_update, exclusive_local_update. } iVs ("Hclose" $! {[l := (1%Qp, DecAgree v)]} with "[Hl]").
rewrite of_heap_singleton_op //; eauto. by iFrame. { iSplit.
- iPureIntro; by apply singleton_local_update, exclusive_local_update.
- rewrite of_heap_singleton_op //; eauto. }
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 Φ :
...@@ -213,12 +214,13 @@ Section heap. ...@@ -213,12 +214,13 @@ Section heap.
Proof. Proof.
iIntros (<-%of_to_val <-%of_to_val ??) "[#Hh [Hl HΦ]]". iIntros (<-%of_to_val <-%of_to_val ??) "[#Hh [Hl HΦ]]".
rewrite /heap_ctx heap_mapsto_eq /heap_mapsto_def. rewrite /heap_ctx heap_mapsto_eq /heap_mapsto_def.
iApply wp_pvs; iApply (auth_fsa heap_inv (wp_fsa _)); eauto with fsaV. iVs (auth_open with "[Hl]") as (h) "[% [Hl Hclose]]"; eauto.
iFrame "Hh Hl". iIntros (h) "[% Hl]". rewrite /heap_inv. rewrite /heap_inv.
iApply (wp_cas_fail_pst _ (<[l:=v']>(of_heap h))); rewrite ?lookup_insert //. iApply (wp_cas_fail_pst _ (<[l:=v']>(of_heap h))); rewrite ?lookup_insert //.
rewrite of_heap_singleton_op //. iFrame "Hl". rewrite of_heap_singleton_op //. iFrame "Hl".
iIntros "> Hown". iPvsIntro. iExists _; iSplit; first done. iIntros "> Hown". iVsIntro. iVs ("Hclose" with "* [Hown]").
rewrite of_heap_singleton_op //. by iFrame. { iSplit; first done. rewrite of_heap_singleton_op //. by 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 Φ :
...@@ -228,12 +230,15 @@ Section heap. ...@@ -228,12 +230,15 @@ Section heap.
Proof. Proof.
iIntros (<-%of_to_val <-%of_to_val ?) "[#Hh [Hl HΦ]]". iIntros (<-%of_to_val <-%of_to_val ?) "[#Hh [Hl HΦ]]".
rewrite /heap_ctx heap_mapsto_eq /heap_mapsto_def. rewrite /heap_ctx heap_mapsto_eq /heap_mapsto_def.
iApply wp_pvs; iApply (auth_fsa heap_inv (wp_fsa _)); eauto with fsaV. iVs (auth_open with "[Hl]") as (h) "[% [Hl Hclose]]"; eauto.
iFrame "Hh Hl". iIntros (h) "[% Hl]". rewrite /heap_inv. rewrite /heap_inv.
iApply (wp_cas_suc_pst _ (<[l:=v1]>(of_heap h))); rewrite ?lookup_insert //. iApply (wp_cas_suc_pst _ (<[l:=v1]>(of_heap h))); rewrite ?lookup_insert //.
rewrite insert_insert !of_heap_singleton_op; eauto. iFrame "Hl". rewrite insert_insert !of_heap_singleton_op; eauto. iFrame "Hl".
iIntros "> Hown". iPvsIntro. iExists {[l := (1%Qp, DecAgree v2)]}; iSplit. iIntros "> Hl". iVsIntro.
{ iPureIntro; by apply singleton_local_update, exclusive_local_update. } iVs ("Hclose" $! {[l := (1%Qp, DecAgree v2)]} with "[Hl]").
rewrite of_heap_singleton_op //; eauto. by iFrame. { iSplit.
- iPureIntro; by apply singleton_local_update, exclusive_local_update.
- rewrite of_heap_singleton_op //; eauto. }
by iApply "HΦ".
Qed. Qed.
End heap. End heap.
...@@ -7,7 +7,7 @@ Definition assert : val := ...@@ -7,7 +7,7 @@ Definition assert : val :=
Notation "'assert:' e" := (assert (λ: <>, e))%E (at level 99) : expr_scope. Notation "'assert:' e" := (assert (λ: <>, e))%E (at level 99) : expr_scope.
Global Opaque assert. Global Opaque assert.
Lemma wp_assert {Σ} E (Φ : val iProp heap_lang Σ) e `{!Closed [] e} : Lemma wp_assert `{heapG Σ} E (Φ : val iProp Σ) e `{!Closed [] e} :
WP e @ E {{ v, v = #true Φ #() }} WP assert: e @ E {{ Φ }}. WP e @ E {{ v, v = #true Φ #() }} WP assert: e @ E {{ Φ }}.
Proof. Proof.
iIntros "HΦ". rewrite /assert. wp_let. wp_seq. iIntros "HΦ". rewrite /assert. wp_let. wp_seq.
......
From iris.prelude Require Import functions. From iris.prelude Require Import functions.
From iris.algebra Require Import upred_big_op. From iris.algebra Require Import upred_big_op.
From iris.program_logic Require Import saved_prop. From iris.program_logic Require Import saved_prop sts.
From iris.heap_lang Require Import proofmode. From iris.heap_lang Require Import proofmode.
From iris.proofmode Require Import sts.
From iris.heap_lang.lib.barrier Require Export barrier. From iris.heap_lang.lib.barrier Require Export barrier.
From iris.heap_lang.lib.barrier Require Import protocol. From iris.heap_lang.lib.barrier Require Import protocol.
Import uPred.
(** The CMRAs we need. *) (** The CMRAs we need. *)
(* Not bundling heapG, as it may be shared with other users. *) (* Not bundling heapG, as it may be shared with other users. *)
Class barrierG Σ := BarrierG { Class barrierG Σ := BarrierG {
barrier_stsG :> stsG heap_lang Σ sts; barrier_stsG :> stsG Σ sts;
barrier_savedPropG :> savedPropG heap_lang Σ idCF; barrier_savedPropG :> savedPropG Σ idCF;
}. }.
(** The Functors we need. *) (** The Functors we need. *)
Definition barrierGF : gFunctorList := [stsGF sts; savedPropGF idCF]. Definition barrierGF : gFunctorList := [stsGF sts; savedPropGF idCF].
(* Show and register that they match. *) (* Show and register that they match. *)
Instance inGF_barrierG `{H : inGFs heap_lang Σ barrierGF} : barrierG Σ. Instance inGF_barrierG `{H : inGFs Σ barrierGF} : barrierG Σ.
Proof. destruct H as (?&?&?). split; apply _. Qed. Proof. destruct H as (?&?&?). split; apply _. Qed.
(** Now we come to the Iris part of the proof. *) (** Now we come to the Iris part of the proof. *)
Section proof. Section proof.
Context `{!heapG Σ, !barrierG Σ} (N : namespace). Context `{!heapG Σ, !barrierG Σ} (N : namespace).
Implicit Types I : gset gname. Implicit Types I : gset gname.
Local Notation iProp := (iPropG heap_lang Σ).
Definition ress (P : iProp) (I : gset gname) : iProp := Definition ress (P : iProp Σ) (I : gset gname) : iProp Σ :=
( Ψ : gname iProp, ( Ψ : gname iProp Σ,
(P - [ set] i I, Ψ i) [ set] i I, saved_prop_own i (Ψ i))%I. (P - [ set] i I, Ψ i) [ set] i I, saved_prop_own i (Ψ i))%I.
Coercion state_to_val (s : state) : val := Coercion state_to_val (s : state) : val :=
match s with State Low _ => #0 | State High _ => #1 end. match s with State Low _ => #0 | State High _ => #1 end.
Arguments state_to_val !_ / : simpl nomatch. Arguments state_to_val !_ / : simpl nomatch.
Definition state_to_prop (s : state) (P : iProp) : iProp := Definition state_to_prop (s : state) (P : iProp Σ) : iProp Σ :=
match s with State Low _ => P | State High _ => True%I end. match s with State Low _ => P | State High _ => True%I end.
Arguments state_to_prop !_ _ / : simpl nomatch. Arguments state_to_prop !_ _ / : simpl nomatch.
Definition barrier_inv (l : loc) (P : iProp) (s : state) : iProp := 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. ( (heapN N) heap_ctx sts_ctx γ N (barrier_inv l P))%I.
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.
Definition recv (l : loc) (R : iProp) : iProp := Definition recv (l : loc) (R : iProp Σ) : iProp Σ :=
( γ P Q i, ( γ P Q i,
barrier_ctx γ l P sts_ownS γ (i_states i) {[ Change i ]} barrier_ctx γ l P sts_ownS γ (i_states i) {[ Change i ]}
saved_prop_own i Q (Q - R))%I. saved_prop_own i Q (Q - R))%I.
Global Instance barrier_ctx_persistent (γ : gname) (l : loc) (P : iProp) : Global Instance barrier_ctx_persistent (γ : gname) (l : loc) (P : iProp Σ) :
PersistentP (barrier_ctx γ l P). PersistentP (barrier_ctx γ l P).
Proof. apply _. Qed. Proof. apply _. Qed.
...@@ -93,15 +90,15 @@ Proof. ...@@ -93,15 +90,15 @@ Proof.
Qed. Qed.
(** Actual proofs *) (** Actual proofs *)
Lemma newbarrier_spec (P : iProp) (Φ : val iProp) : Lemma newbarrier_spec (P : iProp Σ) (Φ : val iProp Σ) :
heapN N heapN N
heap_ctx ( l, recv l P send l P - Φ #l) WP newbarrier #() {{ Φ }}. heap_ctx ( l, recv l P send l P - Φ #l) WP newbarrier #() {{ Φ }}.
Proof. Proof.
iIntros (HN) "[#? HΦ]". iIntros (HN) "[#? HΦ]".
rewrite /newbarrier. wp_seq. wp_alloc l as "Hl". rewrite /newbarrier. wp_seq. wp_alloc l as "Hl".
iApply ("HΦ" with "|==>[-]"). iApply ("HΦ" with "|==>[-]").
iPvs (saved_prop_alloc (F:=idCF) _ P) as (γ) "#?". iVs (saved_prop_alloc (F:=idCF) P) as (γ) "#?".
iPvs (sts_alloc (barrier_inv l P) _ N (State Low {[ γ ]}) with "[-]") iVs (sts_alloc (barrier_inv l P) _ N (State Low {[ γ ]}) with "[-]")
as (γ') "[#? Hγ']"; eauto. as (γ') "[#? Hγ']"; eauto.
{ iNext. rewrite /barrier_inv /=. iFrame. { iNext. rewrite /barrier_inv /=. iFrame.
iExists (const P). rewrite !big_sepS_singleton /=. eauto. } iExists (const P). rewrite !big_sepS_singleton /=. eauto. }
...@@ -110,59 +107,57 @@ Proof. ...@@ -110,59 +107,57 @@ Proof.
iAssert (sts_ownS γ' (i_states γ) {[Change γ]} iAssert (sts_ownS γ' (i_states γ) {[Change γ]}
sts_ownS γ' low_states {[Send]})%I with "|==>[-]" as "[Hr Hs]". sts_ownS γ' low_states {[Send]})%I with "|==>[-]" as "[Hr Hs]".
{ iApply sts_ownS_op; eauto using i_states_closed, low_states_closed. { iApply sts_ownS_op; eauto using i_states_closed, low_states_closed.
+ set_solver. - set_solver.
+ iApply (sts_own_weaken with "Hγ'"); - iApply (sts_own_weaken with "Hγ'");
auto using sts.closed_op, i_states_closed, low_states_closed; auto using sts.closed_op, i_states_closed, low_states_closed;
abstract set_solver. } abstract set_solver. }
iPvsIntro. rewrite /recv /send. iSplitL "Hr". iVsIntro. rewrite /recv /send. iSplitL "Hr".
- iExists γ', P, P, γ. iFrame. auto. - iExists γ', P, P, γ. iFrame. auto.
- auto. - auto.
Qed. Qed.
Lemma signal_spec l P (Φ : val iProp) : Lemma signal_spec l P (Φ : val iProp Σ) :
send l P P Φ #() WP signal #l {{ Φ }}. send l P P Φ #() WP signal #l {{ Φ }}.
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 (γ) "[#(%&Hh&Hsts) Hγ]". wp_let.
iSts γ as [p I]; iDestruct "Hγ" as "[Hl Hr]". iVs (sts_openS (barrier_inv l P) _ _ γ with "[Hγ]")
wp_store. iPvsIntro. destruct p; [|done]. as ([p I]) "(% & [Hl Hr] & Hclose)"; eauto.
iExists (State High I), ( : set token). destruct p; [|done]. wp_store. iFrame "HΦ".
iVs ("Hclose" $! (State High I) ( : set token) with "[-]"); last done.
iSplit; [iPureIntro; by eauto using signal_step|]. iSplit; [iPureIntro; by eauto using signal_step|].
iSplitR "HΦ"; [iNext|by auto]. iNext. rewrite {2}/barrier_inv /ress /=; iFrame "Hl".
rewrite {2}/barrier_inv /ress /=; iFrame "Hl".
iDestruct "Hr" as (Ψ) "[Hr Hsp]"; iExists Ψ; iFrame "Hsp". iDestruct "Hr" as (Ψ) "[Hr Hsp]"; iExists Ψ; iFrame "Hsp".
iIntros "> _"; by iApply "Hr". iIntros "> _"; by iApply "Hr".
Qed.