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.heap_lang Require Export heap.
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.proofmode Require Import tactics.
Class heapPreG Σ := HeapPreG {
heap_preG_iris :> irisPreG heap_lang Σ;
heap_preG_heap :> authG Σ heapUR
heap_preG_iris :> invPreG Σ;
heap_preG_heap :> inG Σ (authR heapUR)
}.
Definition heapΣ : gFunctors :=
#[irisΣ state; authΣ heapUR].
Definition heapΣ : gFunctors := #[invΣ; GFunctor (constRF (authR heapUR))].
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 σ φ :
( `{heapG Σ}, heap_ctx WP e {{ v, ⌜φ v }})
( `{heapG Σ}, True WP e {{ v, ⌜φ v }})
adequate e σ φ.
Proof.
intros Hwp; eapply (wp_adequacy Σ); iIntros (?) "Hσ".
iMod (auth_alloc to_heap _ heapN _ σ with "[Hσ]") as (γ) "[Hh _]";[|by iNext|].
{ exact: to_heap_valid. }
set (Hheap := HeapG _ _ _ γ).
iApply (Hwp _). by rewrite /heap_ctx.
intros Hwp; eapply (wp_adequacy _ _); iIntros (?) "".
iMod (own_alloc ( to_heap σ)) as (γ) "Hh".
{ apply: auth_auth_valid. exact: to_heap_valid. }
iModIntro. iExists (λ σ, own γ ( to_heap σ)); iFrame.
set (Hheap := HeapG _ _ _ γ). iApply (Hwp _).
Qed.
This diff is collapsed.
......@@ -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.
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 Σ :=
( γ, barrier_ctx γ l P sts_ownS γ low_states {[ Send ]})%I.
......@@ -91,10 +91,9 @@ Qed.
(** Actual proofs *)
Lemma newbarrier_spec (P : iProp Σ) :
heapN N
{{{ heap_ctx }}} newbarrier #() {{{ l, RET #l; recv l P send l P }}}.
{{{ True }}} newbarrier #() {{{ l, RET #l; recv l P send l P }}}.
Proof.
iIntros (HN Φ) "#? HΦ".
iIntros (Φ) "HΦ".
rewrite -wp_fupd /newbarrier /=. wp_seq. wp_alloc l as "Hl".
iApply ("HΦ" with ">[-]").
iMod (saved_prop_alloc (F:=idCF) P) as (γ) "#?".
......@@ -120,7 +119,7 @@ Lemma signal_spec l P :
{{{ send l P P }}} signal #l {{{ RET #(); True }}}.
Proof.
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γ]")
as ([p I]) "(% & [Hl Hr] & Hclose)"; eauto.
destruct p; [|done]. wp_store.
......@@ -136,7 +135,7 @@ Lemma wait_spec l P:
{{{ recv l P }}} wait #l {{{ RET #(); P }}}.
Proof.
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.
iMod (sts_openS (barrier_inv l P) _ _ γ with "[Hγ]")
as ([p I]) "(% & [Hl Hr] & Hclose)"; eauto.
......@@ -165,7 +164,7 @@ Lemma recv_split E l P1 P2 :
N E recv l (P1 P2) ={E}= recv l P1 recv l P2.
Proof.
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γ]")
as ([p I]) "(% & [Hl Hr] & Hclose)"; eauto.
iMod (saved_prop_alloc_strong (R1: %CF (iProp Σ)) I) as (i1) "[% #Hi1]".
......
......@@ -8,19 +8,17 @@ Section spec.
Context `{!heapG Σ} `{!barrierG Σ}.
Lemma barrier_spec (N : namespace) :
heapN N
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 }})
( l P, {{ send l P P }} signal #l {{ _, True }})
( 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, (P - Q) recv l P - recv l Q).
Proof.
intros HN.
exists (λ l, CofeMor (recv N l)), (λ l, CofeMor (send N l)).
split_and?; simpl.
- iIntros (P) "#? !# _". iApply (newbarrier_spec _ P with "[]"); [done..|].
- iIntros (P) "!# _". iApply (newbarrier_spec _ P with "[]"); [done..|].
iNext. eauto.
- iIntros (l P) "!# [Hl HP]". iApply (signal_spec with "[$Hl $HP]"). by eauto.
- iIntros (l P) "!# Hl". iApply (wait_spec with "Hl"). eauto.
......
......@@ -24,18 +24,16 @@ Section mono_proof.
( n, own γ ( (n : mnat)) l #n)%I.
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. *)
Global Instance mcounter_persistent l n : PersistentP (mcounter l n).
Proof. apply _. Qed.
Lemma newcounter_mono_spec (R : iProp Σ) :
heapN N
{{{ heap_ctx }}} newcounter #() {{{ l, RET #l; mcounter l 0 }}}.
{{{ True }}} newcounter #() {{{ l, RET #l; mcounter l 0 }}}.
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 (inv_alloc N _ (mcounter_inv γ l) with "[Hl Hγ]").
{ iNext. iExists 0%nat. by iFrame. }
......@@ -46,7 +44,7 @@ Section mono_proof.
{{{ mcounter l n }}} incr #l {{{ RET #(); mcounter l (S n) }}}.
Proof.
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_load. iMod ("Hclose" with "[Hl Hγ]") as "_"; [iNext; iExists c; by iFrame|].
iModIntro. wp_let. wp_op.
......@@ -70,7 +68,7 @@ Section mono_proof.
Lemma read_mono_spec l j :
{{{ mcounter l j }}} read #l {{{ i, RET #i; j i%nat mcounter l i }}}.
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.
iDestruct (own_valid_2 with "Hγ Hγf")
as %[?%mnat_included _]%auth_valid_discrete_2.
......@@ -97,7 +95,7 @@ Section contrib_spec.
( n, own γ ( Some (1%Qp, n)) l #n)%I.
Definition ccounter_ctx (γ : gname) (l : loc) : iProp Σ :=
(heapN N heap_ctx inv N (ccounter_inv γ l))%I.
inv N (ccounter_inv γ l).
Definition ccounter (γ : gname) (q : frac) (n : nat) : iProp Σ :=
own γ ( Some (q, n)).
......@@ -108,11 +106,10 @@ Section contrib_spec.
Proof. by rewrite /ccounter -own_op -auth_frag_op. Qed.
Lemma newcounter_contrib_spec (R : iProp Σ) :
heapN N
{{{ heap_ctx }}} newcounter #()
{{{ True }}} newcounter #()
{{{ γ l, RET #l; ccounter_ctx γ l ccounter γ 1 0 }}}.
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 ( (Some (1%Qp, O%nat)) (Some (1%Qp, 0%nat))))
as (γ) "[Hγ Hγ']"; first done.
iMod (inv_alloc N _ (ccounter_inv γ l) with "[Hl Hγ]").
......@@ -124,7 +121,7 @@ Section contrib_spec.
{{{ ccounter_ctx γ l ccounter γ q n }}} incr #l
{{{ RET #(); ccounter γ q (S n) }}}.
Proof.
iIntros (Φ) "(#(%&?&?) & Hγf) HΦ". iLöb as "IH". wp_rec.
iIntros (Φ) "[#? Hγf] HΦ". iLöb as "IH". wp_rec.
wp_bind (! _)%E. iInv N as (c) ">[Hγ Hl]" "Hclose".
wp_load. iMod ("Hclose" with "[Hl Hγ]") as "_"; [iNext; iExists c; by iFrame|].
iModIntro. wp_let. wp_op.
......@@ -145,7 +142,7 @@ Section contrib_spec.
{{{ ccounter_ctx γ l ccounter γ q n }}} read #l
{{{ c, RET #c; n c%nat ccounter γ q n }}}.
Proof.
iIntros (Φ) "(#(%&?&?) & Hγf) HΦ".
iIntros (Φ) "[#? Hγf] HΦ".
rewrite /read /=. wp_let. iInv N as (c) ">[Hγ Hl]" "Hclose". wp_load.
iDestruct (own_valid_2 with "Hγ Hγf")
as %[[? ?%nat_included]%Some_pair_included_total_2 _]%auth_valid_discrete_2.
......@@ -157,7 +154,7 @@ Section contrib_spec.
{{{ ccounter_ctx γ l ccounter γ 1 n }}} read #l
{{{ n, RET #n; ccounter γ 1 n }}}.
Proof.
iIntros (Φ) "(#(%&?&?) & Hγf) HΦ".
iIntros (Φ) "[#? Hγf] HΦ".
rewrite /read /=. wp_let. iInv N as (c) ">[Hγ Hl]" "Hclose". wp_load.
iDestruct (own_valid_2 with "Hγ Hγf") as %[Hn _]%auth_valid_discrete_2.
apply (Some_included_exclusive _) in Hn as [= ->]%leibniz_equiv; last done.
......
......@@ -17,8 +17,7 @@ Structure lock Σ `{!heapG Σ} := Lock {
locked_exclusive γ : locked γ locked γ False;
(* -- operation specs -- *)
newlock_spec N (R : iProp Σ) :
heapN N
{{{ heap_ctx R }}} newlock #() {{{ lk γ, RET lk; is_lock N γ lk R }}};
{{{ R }}} newlock #() {{{ lk γ, RET lk; is_lock N γ lk R }}};
acquire_spec N γ lk R :
{{{ is_lock N γ lk R }}} acquire lk {{{ RET #(); locked γ R }}};
release_spec N γ lk R :
......
......@@ -21,13 +21,13 @@ Context `{!heapG Σ, !spawnG Σ}.
This is why these are not Texan triples. *)
Lemma par_spec (Ψ1 Ψ2 : val iProp Σ) e (f1 f2 : val) (Φ : val iProp Σ) :
to_val e = Some (f1,f2)%V
(heap_ctx WP f1 #() {{ Ψ1 }} WP f2 #() {{ Ψ2 }}
(WP f1 #() {{ Ψ1 }} WP f2 #() {{ Ψ2 }}
v1 v2, Ψ1 v1 Ψ2 v2 - Φ (v1,v2)%V)
WP par e {{ Φ }}.
Proof.
iIntros (?) "(#Hh&Hf1&Hf2&HΦ)".
iIntros (?) "(Hf1 & Hf2 & HΦ)".
rewrite /par. wp_value. wp_let. wp_proj.
wp_apply (spawn_spec parN with "[$Hh $Hf1]"); try wp_done; try solve_ndisj.
wp_apply (spawn_spec parN with "Hf1"); try wp_done; try solve_ndisj.
iIntros (l) "Hl". wp_let. wp_proj. wp_bind (f2 _).
iApply (wp_wand with "Hf2"); iIntros (v) "H2". wp_let.
wp_apply (join_spec with "[$Hl]"). iIntros (w) "H1".
......@@ -36,11 +36,11 @@ Qed.
Lemma wp_par (Ψ1 Ψ2 : val iProp Σ)
(e1 e2 : expr) `{!Closed [] e1, Closed [] e2} (Φ : val iProp Σ) :
(heap_ctx WP e1 {{ Ψ1 }} WP e2 {{ Ψ2 }}
(WP e1 {{ Ψ1 }} WP e2 {{ Ψ2 }}
v1 v2, Ψ1 v1 Ψ2 v2 - Φ (v1,v2)%V)
WP e1 ||| e2 {{ Φ }}.
Proof.
iIntros "(#Hh&H1&H2&H)". iApply (par_spec Ψ1 Ψ2 with "[- $Hh $H]"); try wp_done.
iIntros "(H1 & H2 & H)". iApply (par_spec Ψ1 Ψ2 with "[- $H]"); try wp_done.
iSplitL "H1"; by wp_let.
Qed.
End proof.
......@@ -32,8 +32,7 @@ Definition spawn_inv (γ : gname) (l : loc) (Ψ : val → iProp Σ) : iProp Σ :
v, lv = SOMEV v (Ψ v own γ (Excl ()))))%I.
Definition join_handle (l : loc) (Ψ : val iProp Σ) : iProp Σ :=
(heapN N γ, heap_ctx own γ (Excl ())
inv N (spawn_inv γ l Ψ))%I.
( γ, own γ (Excl ()) inv N (spawn_inv γ l Ψ))%I.
Typeclasses Opaque join_handle.
......@@ -47,10 +46,9 @@ Proof. solve_proper. Qed.
(** The main proofs. *)
Lemma spawn_spec (Ψ : val iProp Σ) e (f : val) :
to_val e = Some f
heapN N
{{{ heap_ctx WP f #() {{ Ψ }} }}} spawn e {{{ l, RET #l; join_handle l Ψ }}}.
{{{ WP f #() {{ Ψ }} }}} spawn e {{{ l, RET #l; join_handle l Ψ }}}.
Proof.
iIntros (<-%of_to_val ? Φ) "(#Hh & Hf) HΦ". rewrite /spawn /=.
iIntros (<-%of_to_val Φ) "Hf HΦ". rewrite /spawn /=.
wp_let. wp_alloc l as "Hl". wp_let.
iMod (own_alloc (Excl ())) as (γ) "Hγ"; first done.
iMod (inv_alloc N _ (spawn_inv γ l Ψ) with "[Hl]") as "#?".
......@@ -65,7 +63,7 @@ Qed.
Lemma join_spec (Ψ : val iProp Σ) l :
{{{ join_handle l Ψ }}} join #l {{{ v, RET v; Ψ v }}}.
Proof.
rewrite /join_handle; iIntros (Φ) "[% H] HΦ". iDestruct "H" as (γ) "(#?&Hγ&#?)".
rewrite /join_handle; iIntros (Φ) "H HΦ". iDestruct "H" as (γ) "[Hγ #?]".
iLöb as "IH". wp_rec. wp_bind (! _)%E. iInv N as (v) "[Hl Hinv]" "Hclose".
wp_load. iDestruct "Hinv" as "[%|Hinv]"; subst.
- iMod ("Hclose" with "[Hl]"); [iNext; iExists _; iFrame; eauto|].
......
......@@ -26,7 +26,7 @@ Section proof.
( b : bool, l #b if b then True else own γ (Excl ()) R)%I.
Definition is_lock (γ : gname) (lk : val) (R : iProp Σ) : iProp Σ :=
( l: loc, heapN N heap_ctx lk = #l inv N (lock_inv γ l R))%I.
( l: loc, lk = #l inv N (lock_inv γ l R))%I.
Definition locked (γ : gname): iProp Σ := own γ (Excl ()).
......@@ -45,10 +45,9 @@ Section proof.
Proof. apply _. Qed.
Lemma newlock_spec (R : iProp Σ):
heapN N
{{{ heap_ctx R }}} newlock #() {{{ lk γ, RET lk; is_lock γ lk R }}}.
{{{ R }}} newlock #() {{{ lk γ, RET lk; is_lock γ lk R }}}.
Proof.
iIntros (? Φ) "[#Hh HR] HΦ". rewrite -wp_fupd /newlock /=.
iIntros (Φ) "HR HΦ". rewrite -wp_fupd /newlock /=.
wp_seq. wp_alloc l as "Hl".
iMod (own_alloc (Excl ())) as (γ) "Hγ"; first done.
iMod (inv_alloc N _ (lock_inv γ l R) with "[-HΦ]") as "#?".
......@@ -60,7 +59,7 @@ Section proof.
{{{ is_lock γ lk R }}} try_acquire lk
{{{ b, RET #b; if b is true then locked γ R else True }}}.
Proof.
iIntros (Φ) "#Hl HΦ". iDestruct "Hl" as (l) "(% & #? & % & #?)". subst.
iIntros (Φ) "#Hl HΦ". iDestruct "Hl" as (l) "[% #?]"; subst.
wp_rec. iInv N as ([]) "[Hl HR]" "Hclose".
- wp_cas_fail. iMod ("Hclose" with "[Hl]"); first (iNext; iExists true; eauto).
iModIntro. iApply ("HΦ" $! false). done.
......@@ -82,7 +81,7 @@ Section proof.
{{{ is_lock γ lk R locked γ R }}} release lk {{{ RET #(); True }}}.
Proof.
iIntros (Φ) "(Hlock & Hlocked & HR) HΦ".
iDestruct "Hlock" as (l) "(% & #? & % & #?)". subst.
iDestruct "Hlock" as (l) "[% #?]"; subst.
rewrite /release /=. wp_let. iInv N as (b) "[Hl _]" "Hclose".
wp_store. iApply "HΦ". iApply "Hclose". iNext. iExists false. by iFrame.
Qed.
......
......@@ -46,12 +46,10 @@ Section proof.
Definition is_lock (γ : gname) (lk : val) (R : iProp Σ) : iProp Σ :=
( lo ln : loc,
heapN N heap_ctx
lk = (#lo, #ln)%V inv N (lock_inv γ lo ln R))%I.
Definition issued (γ : gname) (lk : val) (x : nat) (R : iProp Σ) : iProp Σ :=
( lo ln: loc,
heapN N heap_ctx
lk = (#lo, #ln)%V inv N (lock_inv γ lo ln R)
own γ ( (, GSet {[ x ]})))%I.
......@@ -74,10 +72,9 @@ Section proof.
Qed.
Lemma newlock_spec (R : iProp Σ) :
heapN N
{{{ heap_ctx R }}} newlock #() {{{ lk γ, RET lk; is_lock γ lk R }}}.
{{{ R }}} newlock #() {{{ lk γ, RET lk; is_lock γ lk R }}}.
Proof.
iIntros (HN Φ) "(#Hh & HR) HΦ". rewrite -wp_fupd /newlock.
iIntros (Φ) "HR HΦ". rewrite -wp_fupd /newlock /=.
wp_seq. wp_alloc lo as "Hlo". wp_alloc ln as "Hln".
iMod (own_alloc ( (Excl' 0%nat, ) (Excl' 0%nat, ))) as (γ) "[Hγ Hγ']".
{ by rewrite -auth_both_op. }
......@@ -90,7 +87,7 @@ Section proof.
Lemma wait_loop_spec γ lk x R :
{{{ issued γ lk x R }}} wait_loop #x lk {{{ RET #(); locked γ R }}}.
Proof.
iIntros (Φ) "Hl HΦ". iDestruct "Hl" as (lo ln) "(% & #? & % & #? & Ht)".
iIntros (Φ) "Hl HΦ". iDestruct "Hl" as (lo ln) "(% & #? & Ht)".
iLöb as "IH". wp_rec. subst. wp_let. wp_proj. wp_bind (! _)%E.
iInv N as (o n) "(Hlo & Hln & Ha)" "Hclose".
wp_load. destruct (decide (x = o)) as [->|Hneq].
......@@ -111,7 +108,7 @@ Section proof.
Lemma acquire_spec γ lk R :
{{{ is_lock γ lk R }}} acquire lk {{{ RET #(); locked γ R }}}.
Proof.
iIntros (ϕ) "Hl HΦ". iDestruct "Hl" as (lo ln) "(% & #? & % & #?)".
iIntros (ϕ) "Hl HΦ". iDestruct "Hl" as (lo ln) "[% #?]".
iLöb as "IH". wp_rec. wp_bind (! _)%E. subst. wp_proj.
iInv N as (o n) "[Hlo [Hln Ha]]" "Hclose".
wp_load. iMod ("Hclose" with "[Hlo Hln Ha]") as "_".
......@@ -142,8 +139,7 @@ Section proof.
Lemma release_spec γ lk R :
{{{ is_lock γ lk R locked γ R }}} release lk {{{ RET #(); True }}}.
Proof.
iIntros (Φ) "(Hl & Hγ & HR) HΦ".
iDestruct "Hl" as (lo ln) "(% & #? & % & #?)"; subst.
iIntros (Φ) "(Hl & Hγ & HR) HΦ". iDestruct "Hl" as (lo ln) "[% #?]"; subst.
iDestruct "Hγ" as (o) "Hγo".
rewrite /release. wp_let. wp_proj. wp_proj. wp_bind (! _)%E.
iInv N as (o' n) "(>Hlo & >Hln & >Hauth & Haown)" "Hclose".
......
......@@ -45,52 +45,6 @@ Lemma wp_bind_ctxi {E e} Ki Φ :
WP fill_item Ki e @ E {{ Φ }}.
Proof. exact: weakestpre.wp_bind. Qed.
(** Base axioms for core primitives of the language: Stateful reductions. *)
Lemma wp_alloc_pst E σ v :
{{{ ownP σ }}} Alloc (of_val v) @ E
{{{ l, RET LitV (LitLoc l); ⌜σ !! l = None ownP (<[l:=v]>σ) }}}.
Proof.
iIntros (Φ) "HP HΦ".
iApply (wp_lift_atomic_head_step (Alloc (of_val v)) σ); eauto.
iFrame "HP". iNext. iIntros (v2 σ2 ef) "% HP". inv_head_step.
iSplitL; last by iApply big_sepL_nil. iApply "HΦ". by iSplit.
Qed.
Lemma wp_load_pst E σ l v :
σ !! l = Some v
{{{ ownP σ }}} Load (Lit (LitLoc l)) @ E {{{ RET v; ownP σ }}}.
Proof.
intros ? Φ. apply wp_lift_atomic_det_head_step'; eauto.
intros; inv_head_step; eauto.
Qed.
Lemma wp_store_pst E σ l v v' :
σ !! l = Some v'
{{{ ownP σ }}} Store (Lit (LitLoc l)) (of_val v) @ E
{{{ RET LitV LitUnit; ownP (<[l:=v]>σ) }}}.
Proof.
intros. apply wp_lift_atomic_det_head_step'; eauto.
intros; inv_head_step; eauto.
Qed.
Lemma wp_cas_fail_pst E σ l v1 v2 v' :
σ !! l = Some v' v' v1
{{{ ownP σ }}} CAS (Lit (LitLoc l)) (of_val v1) (of_val v2) @ E
{{{ RET LitV $ LitBool false; ownP σ }}}.
Proof.
intros. apply wp_lift_atomic_det_head_step'; eauto.
intros; inv_head_step; eauto.
Qed.
Lemma wp_cas_suc_pst E σ l v1 v2 :
σ !! l = Some v1
{{{ ownP σ }}} CAS (Lit (LitLoc l)) (of_val v1) (of_val v2) @ E
{{{ RET LitV $ LitBool true; ownP (<[l:=v2]>σ) }}}.
Proof.
intros. apply wp_lift_atomic_det_head_step'; eauto.
intros; inv_head_step; eauto.
Qed.
(** Base axioms for core primitives of the language: Stateless reductions *)
Lemma wp_fork E e Φ :
Φ (LitV LitUnit) WP e {{ _, True }} WP Fork e @ E {{ Φ }}.
......@@ -106,7 +60,7 @@ Lemma wp_rec E f x erec e1 e2 Φ :
Closed (f :b: x :b: []) erec
WP subst' x e2 (subst' f e1 erec) @ E {{ Φ }} WP App e1 e2 @ E {{ Φ }}.
Proof.
intros -> [v2 ?] ?. rewrite -(wp_lift_pure_det_head_step' (App _ _)
intros -> [v2 ?] ?. rewrite -(wp_lift_pure_det_head_step_no_fork (App _ _)
(subst' x e2 (subst' f (Rec f x erec) erec))); eauto.
intros; inv_head_step; eauto.
Qed.
......@@ -116,7 +70,7 @@ Lemma wp_un_op E op e v v' Φ :
un_op_eval op v = Some v'
Φ v' WP UnOp op e @ E {{ Φ }}.
Proof.
intros. rewrite -(wp_lift_pure_det_head_step' (UnOp op _) (of_val v'))
intros. rewrite -(wp_lift_pure_det_head_step_no_fork (UnOp op _) (of_val v'))
-?wp_value'; eauto.
intros; inv_head_step; eauto.
Qed.
......@@ -126,7 +80,7 @@ Lemma wp_bin_op E op e1 e2 v1 v2 v' Φ :
bin_op_eval op v1 v2 = Some v'
(Φ v') WP BinOp op e1 e2 @ E {{ Φ }}.
Proof.
intros. rewrite -(wp_lift_pure_det_head_step' (BinOp op _ _) (of_val v'))
intros. rewrite -(wp_lift_pure_det_head_step_no_fork (BinOp op _ _) (of_val v'))
-?wp_value'; eauto.
intros; inv_head_step; eauto.
Qed.
......@@ -134,14 +88,14 @@ Qed.
Lemma wp_if_true E e1 e2 Φ :
WP e1 @ E {{ Φ }} WP If (Lit (LitBool true)) e1 e2 @ E {{ Φ }}.
Proof.
apply wp_lift_pure_det_head_step'; eauto.
apply wp_lift_pure_det_head_step_no_fork; eauto.
intros; inv_head_step; eauto.
Qed.
Lemma wp_if_false E e1 e2 Φ :
WP e2 @ E {{ Φ }} WP If (Lit (LitBool false)) e1 e2 @ E {{ Φ }}.
Proof.
apply wp_lift_pure_det_head_step'; eauto.
apply wp_lift_pure_det_head_step_no_fork; eauto.
intros; inv_head_step; eauto.
Qed.
......@@ -150,7 +104,7 @@ Lemma wp_fst E e1 v1 e2 Φ :
Φ v1 WP Fst (Pair e1 e2) @ E {{ Φ }}.
Proof.
intros ? [v2 ?].
rewrite -(wp_lift_pure_det_head_step' (Fst _) e1) -?wp_value; eauto.
rewrite -(wp_lift_pure_det_head_step_no_fork (Fst _) e1) -?wp_value; eauto.
intros; inv_head_step; eauto.
Qed.
......@@ -159,7 +113,7 @@ Lemma wp_snd E e1 e2 v2 Φ :
Φ v2 WP Snd (Pair e1 e2) @ E {{ Φ }}.
Proof.
intros [v1 ?] ?.
rewrite -(wp_lift_pure_det_head_step' (Snd _) e2) -?wp_value; eauto.
rewrite -(wp_lift_pure_det_head_step_no_fork (Snd _) e2) -?wp_value; eauto.
intros; inv_head_step; eauto.
Qed.
......@@ -168,7 +122,7 @@ Lemma wp_case_inl E e0 e1 e2 Φ :
WP App e1 e0 @ E {{ Φ }} WP Case (InjL e0) e1 e2 @ E {{ Φ }}.
Proof.
intros [v0 ?].
rewrite -(wp_lift_pure_det_head_step' (Case _ _ _) (App e1 e0)); eauto.
rewrite -(wp_lift_pure_det_head_step_no_fork (Case _ _ _) (App e1 e0)); eauto.
intros; inv_head_step; eauto.
Qed.
......@@ -177,7 +131,7 @@ Lemma wp_case_inr E e0 e1 e2 Φ :
WP App e2 e0 @ E {{ Φ }} WP Case (InjR e0) e1 e2 @ E {{ Φ }}.
Proof.
intros [v0 ?].
rewrite -(wp_lift_pure_det_head_step' (Case _ _ _) (App e2 e0)); eauto.
rewrite -(wp_lift_pure_det_head_step_no_fork (Case _ _ _) (App e2 e0)); eauto.
intros; inv_head_step; eauto.
Qed.
End lifting.
......@@ -14,73 +14,63 @@ Implicit Types Δ : envs (iResUR Σ).
Lemma tac_wp_alloc Δ Δ' E j e v Φ :
to_val e = Some v
(Δ heap_ctx) heapN E
IntoLaterNEnvs 1 Δ Δ'
( l, Δ'',
envs_app false (Esnoc Enil j (l v)) Δ' = Some Δ''
(Δ'' Φ (LitV (LitLoc l))))
Δ WP Alloc e @ E {{ Φ }}.
Proof.
intros ???? HΔ. eapply wand_apply; first exact:wp_alloc. rewrite -always_and_sep_l.
apply and_intro; first done.
rewrite into_laterN_env_sound; apply later_mono, forall_intro=> l.
intros ?? HΔ. eapply wand_apply; first exact: wp_alloc.
rewrite left_id into_laterN_env_sound; apply later_mono, forall_intro=> l.
destruct (HΔ l) as (Δ''&?&HΔ'). rewrite envs_app_sound //; simpl.
by rewrite right_id HΔ'.
Qed.
Lemma tac_wp_load Δ Δ' E i l q v Φ :
(Δ heap_ctx) heapN E
IntoLaterNEnvs 1 Δ Δ'
envs_lookup i Δ' = Some (false, l {q} v)%I
(Δ' Φ v)
Δ WP Load (Lit (LitLoc l)) @ E {{ Φ }}.
Proof.
intros. eapply wand_apply; first exact:wp_load. rewrite -assoc -always_and_sep_l.
apply and_intro; first done.
intros. eapply wand_apply; first exact: wp_load.
rewrite into_laterN_env_sound -later_sep envs_lookup_split //; simpl.
by apply later_mono, sep_mono_r, wand_mono.
Qed.
Lemma tac_wp_store Δ Δ' Δ'' E i l v e v' Φ :
to_val e = Some v'
(Δ heap_ctx) heapN E
IntoLaterNEnvs 1 Δ Δ'
envs_lookup i Δ' = Some (false, l v)%I
envs_simple_replace i false (Esnoc Enil i (l v')) Δ' = Some Δ''
(Δ'' Φ (LitV LitUnit))
Δ WP Store (Lit (LitLoc l)) e @ E {{ Φ }}.
Proof.
intros. eapply wand_apply; first by eapply wp_store. rewrite -assoc -always_and_sep_l.
apply and_intro; first done.
intros. eapply wand_apply; first by eapply wp_store.
rewrite into_laterN_env_sound -later_sep envs_simple_replace_sound //; simpl.
rewrite right_id. by apply later_mono, sep_mono_r, wand_mono.
Qed.
Lemma tac_wp_cas_fail Δ Δ' E i l q v e1 v1 e2 v2 Φ :
to_val e1 = Some v1 to_val e2 = Some v2
(Δ heap_ctx) heapN E
IntoLaterNEnvs 1 Δ Δ'
envs_lookup i Δ' = Some (false, l {q} v)%I v v1
(Δ' Φ (LitV (LitBool false)))
Δ WP CAS (Lit (LitLoc l)) e1 e2 @ E {{ Φ }}.
Proof.
intros. eapply wand_apply; first exact:wp_cas_fail. rewrite -assoc -always_and_sep_l.
apply and_intro; first done.
intros. eapply wand_apply; first exact: wp_cas_fail.
rewrite into_laterN_env_sound -later_sep envs_lookup_split //; simpl.
by apply later_mono, sep_mono_r, wand_mono.
Qed.
Lemma tac_wp_cas_suc Δ Δ' Δ'' E i l v e1 v1 e2 v2 Φ :
to_val e1 = Some v1 to_val e2 = Some v2
(Δ heap_ctx) heapN E
IntoLaterNEnvs 1 Δ Δ'
envs_lookup i Δ' = Some (false, l v)%I v = v1
envs_simple_replace i false (Esnoc Enil i (l v2)) Δ' = Some Δ''
(Δ'' Φ (LitV (LitBool true)))
Δ WP CAS (Lit (LitLoc l)) e1 e2 @ E {{ Φ }}.
Proof.
intros; subst. eapply wand_apply; first exact:wp_cas_suc. rewrite -assoc -always_and_sep_l.
apply and_intro; first done.
intros; subst. eapply wand_apply; first exact: wp_cas_suc.
rewrite into_laterN_env_sound -later_sep envs_simple_replace_sound //; simpl.
rewrite right_id. by apply later_mono, sep_mono_r, wand_mono.
Qed.
......@@ -103,8 +93,6 @@ Tactic Notation "wp_alloc" ident(l) "as" constr(H) :=
eapply tac_wp_alloc with _ H _;
[let e' := match goal with |- to_val ?e' = _ => e' end in
wp_done || fail "wp_alloc:" e' "not a value"
|iAssumption || fail "wp_alloc: cannot find heap_ctx"
|solve_ndisj || fail "wp_alloc: cannot open heap invariant"
|apply _
|first [intros l | fail 1 "wp_alloc:" l "not fresh"];
eexists; split;
......@@ -124,9 +112,7 @@ Tactic Notation "wp_load" :=
match eval hnf in e' with Load _ => wp_bind_core K end)
|fail 1 "wp_load: cannot find 'Load' in" e];
eapply tac_wp_load;
[iAssumption || fail "wp_load: cannot find heap_ctx"
|solve_ndisj || fail "wp_load: cannot open heap invariant"
|apply _
[apply _
|let l := match goal with |- _ = Some (_, (?l {_} _)%I) => l end in
iAssumptionCore || fail "wp_load: cannot find" l "↦ ?"
|wp_finish]
......@@ -143,8 +129,6 @@ Tactic Notation "wp_store" :=
eapply tac_wp_store;
[let e' := match goal with |- to_val ?e' = _ => e' end in
wp_done || fail "wp_store:" e' "not a value"
|iAssumption || fail "wp_store: cannot find heap_ctx"
|solve_ndisj || fail "wp_store: cannot open heap invariant"
|apply _
|let l := match goal with |- _ = Some (_, (?l {_} _)%I) => l end in
iAssumptionCore || fail "wp_store: cannot find" l "↦ ?"
......@@ -165,8 +149,6 @@ Tactic Notation "wp_cas_fail" :=
wp_done || fail "wp_cas_fail:" e' "not a value"
|let e' := match goal with |- to_val ?e' = _ => e' end in
wp_done || fail "wp_cas_fail:" e' "not a value"
|iAssumption || fail "wp_cas_fail: cannot find heap_ctx"
|solve_ndisj || fail "wp_cas_fail: cannot open heap invariant"