Commit df4574f2 authored by Robbert Krebbers's avatar Robbert Krebbers

Iris Proofmode.

parent 631c8260
......@@ -79,7 +79,6 @@ program_logic/saved_one_shot.v
program_logic/auth.v
program_logic/sts.v
program_logic/namespaces.v
program_logic/tactics.v
heap_lang/lang.v
heap_lang/tactics.v
heap_lang/wp_tactics.v
......@@ -96,7 +95,20 @@ heap_lang/lib/barrier/specification.v
heap_lang/lib/barrier/protocol.v
heap_lang/lib/barrier/proof.v
heap_lang/lib/barrier/client.v
heap_lang/proofmode.v
tests/heap_lang.v
tests/program_logic.v
tests/one_shot.v
tests/joining_existentials.v
tests/proofmode.v
proofmode/coq_tactics.v
proofmode/pviewshifts.v
proofmode/environments.v
proofmode/intro_patterns.v
proofmode/spec_patterns.v
proofmode/tactics.v
proofmode/notation.v
proofmode/invariants.v
proofmode/weakestpre.v
proofmode/ghost_ownership.v
proofmode/sts.v
......@@ -974,19 +974,6 @@ Lemma later_wand P Q : ▷ (P -★ Q) ⊢ (▷ P -★ ▷ Q).
Proof. apply wand_intro_r;rewrite -later_sep; apply later_mono,wand_elim_l. Qed.
Lemma later_iff P Q : (P Q) ( P Q).
Proof. by rewrite /uPred_iff later_and !later_impl. Qed.
Lemma löb_strong P Q : (P Q) Q P Q.
Proof.
intros Hlöb. apply impl_entails. rewrite -(löb (P Q)).
apply entails_impl, impl_intro_l. rewrite -{2}Hlöb.
apply and_intro; first by eauto.
by rewrite {1}(later_intro P) later_impl impl_elim_r.
Qed.
Lemma löb_strong_sep P Q : (P (P - Q)) Q P Q.
Proof.
move/wand_intro_l=>Hlöb. apply impl_entails.
rewrite -[(_ _)%I]always_elim. apply löb_strong.
by rewrite left_id -always_wand_impl -always_later Hlöb.
Qed.
(* Own *)
Lemma ownM_op (a1 a2 : M) :
......
......@@ -248,50 +248,3 @@ Ltac strip_later :=
intros_revert ltac:(
etrans; [apply: strip_later_r|];
etrans; [|apply: strip_later_l]; apply later_mono).
(** Transforms a goal of the form ..., ?0... ?1 ?2
into True ..., ?0... ?1 ?2, applies tac, and
the moves all the assumptions back. *)
(* TODO: this name may be a big too general *)
Ltac revert_all :=
lazymatch goal with
| |- _, _ =>
let H := fresh in intro H; revert_all;
(* TODO: Really, we should distinguish based on whether this is a
dependent function type or not. Right now, we distinguish based
on the sort of the argument, which is suboptimal. *)
first [ apply (const_intro_impl _ _ _ H); clear H
| revert H; apply forall_elim']
| |- _ _ => apply impl_entails
end.
(** This starts on a goal of the form ..., ?0... ?1 ?2.
It applies löb where all the Coq assumptions have been turned into logical
assumptions, then moves all the Coq assumptions back out to the context,
applies [tac] on the goal (now of the form _ _), and then reverts the
Coq assumption so that we end up with the same shape as where we started,
but with an additional assumption -ed to the context *)
Ltac löb tac :=
revert_all;
(* Add a box *)
etrans; last (eapply always_elim; reflexivity);
(* We now have a goal for the form True P, with the "original" conclusion
being locked. *)
apply löb_strong; etransitivity;
first (apply equiv_entails, left_id, _; reflexivity);
apply: always_intro;
(* Now introduce again all the things that we reverted, and at the bottom,
do the work *)
let rec go :=
lazymatch goal with
| |- _ ( _, _) =>
apply forall_intro; let H := fresh in intro H; go; revert H
| |- _ ( _ _) =>
apply impl_intro_l, const_elim_l; let H := fresh in intro H; go; revert H
(* This is the "bottom" of the goal, where we see the impl introduced
by uPred_revert_all as well as the from löb_strong and the we added. *)
| |- ?R (?L _) => apply impl_intro_l;
trans (L R)%I;
[eapply equiv_entails, always_and_sep_r, _; reflexivity | tac]
end
in go.
From iris.heap_lang.lib.barrier Require Import proof.
From iris.heap_lang Require Import par.
From iris.program_logic Require Import auth sts saved_prop hoare ownership.
From iris.heap_lang Require Import proofmode.
Import uPred.
Definition worker (n : Z) : val :=
......@@ -15,63 +16,44 @@ Section client.
Context {Σ : gFunctors} `{!heapG Σ, !barrierG Σ, !spawnG Σ} (heapN N : namespace).
Local Notation iProp := (iPropG heap_lang Σ).
Definition y_inv q y : iProp :=
( f : val, y {q} f n : Z, WP f #n {{ λ v, v = #(n + 42) }})%I.
Definition y_inv (q : Qp) (l : loc) : iProp :=
( f : val, l {q} f n : Z, WP f #n {{ λ v, v = #(n + 42) }})%I.
Lemma y_inv_split q y :
y_inv q y (y_inv (q/2) y y_inv (q/2) y).
Lemma y_inv_split q l : y_inv q l (y_inv (q/2) l y_inv (q/2) l).
Proof.
rewrite /y_inv. apply exist_elim=>f.
rewrite -!(exist_intro f). rewrite heap_mapsto_op_split.
ecancel [y {_} _; y {_} _]%I. by rewrite [X in X _]always_sep_dup.
iIntros "Hl"; iDestruct "Hl" as {f} "[[Hl1 Hl2] #Hf]".
iSplitL "Hl1"; iExists f; by iSplitL; try iAlways.
Qed.
Lemma worker_safe q (n : Z) (b y : loc) :
(heap_ctx heapN recv heapN N b (y_inv q y))
WP worker n (%b) (%y) {{ λ _, True }}.
WP worker n (%b) (%y) {{ λ _, True }}.
Proof.
rewrite /worker. wp_lam. wp_let. ewp apply wait_spec.
rewrite comm. apply sep_mono_r. apply wand_intro_l.
rewrite sep_exist_r. apply exist_elim=>f. wp_seq.
(* TODO these parenthesis are rather surprising. *)
(ewp apply: (wp_load heapN _ _ q f)); eauto with I.
strip_later. (* hu, shouldn't it do that? *)
rewrite -assoc. apply sep_mono_r. apply wand_intro_l.
rewrite always_elim (forall_elim n) sep_elim_r sep_elim_l.
apply wp_mono=>?. eauto with I.
iIntros "[#Hh Hrecv]". wp_lam. wp_let.
wp_apply wait_spec; iFrame "Hrecv".
iIntros "Hy"; iDestruct "Hy" as {f} "[Hy #Hf]".
wp_seq. wp_load.
iApply wp_wand_r; iSplitR; [iApply "Hf"|by iIntros {v} "_"].
Qed.
Lemma client_safe :
heapN N heap_ctx heapN WP client {{ λ _, True }}.
Lemma client_safe : heapN N heap_ctx heapN WP client {{ λ _, True }}.
Proof.
intros ?. rewrite /client.
(ewp eapply wp_alloc); eauto with I. strip_later. apply forall_intro=>y.
apply wand_intro_l. wp_let.
ewp eapply (newbarrier_spec heapN N (y_inv 1 y)); last done.
rewrite comm. rewrite {1}[heap_ctx _]always_sep_dup -!assoc.
apply sep_mono_r. apply forall_intro=>b. apply wand_intro_l.
wp_let. (ewp eapply (wp_par heapN N (λ _, True%I) (λ _, True%I))); eauto.
rewrite 2!{1}[heap_ctx _]always_sep_dup !assoc [(_ heap_ctx _)%I]comm.
ecancel [heap_ctx _]. sep_split right: []; last first.
{ do 2 apply forall_intro=>_. apply wand_intro_l.
eauto using later_intro with I. }
sep_split left: [send heapN _ _ _; heap_ctx _; y _]%I.
iIntros {?} "#Hh"; rewrite /client. wp_alloc y as "Hy". wp_let.
wp_apply (newbarrier_spec heapN N (y_inv 1 y)); first done.
iFrame "Hh". iIntros {l} "[Hr Hs]". wp_let.
iApply (wp_par heapN N (λ _, True%I) (λ _, True%I)); first done.
iFrame "Hh". iSplitL "Hy Hs".
- (* The original thread, the sender. *)
(ewp eapply wp_store); eauto with I. strip_later.
ecancel [y _]%I. apply wand_intro_l.
wp_seq. rewrite -signal_spec right_id assoc sep_elim_l comm.
apply sep_mono_r. rewrite /y_inv -(exist_intro (λ: "z", '"z" + #42)%V).
apply sep_intro_True_r; first done. apply: always_intro.
apply forall_intro=>n. wp_let. wp_op. by apply const_intro.
wp_store. wp_seq. iApply signal_spec; iFrame "Hs"; iSplit; [|done].
iExists _; iSplitL; [done|]. iAlways; iIntros {n}. wp_let. by wp_op.
- (* The two spawned threads, the waiters. *)
rewrite recv_mono; last exact: y_inv_split.
rewrite (recv_split _ _ ) // pvs_frame_r. apply wp_strip_pvs.
(ewp eapply (wp_par heapN N (λ _, True%I) (λ _, True%I))); eauto.
do 2 rewrite {1}[heap_ctx _]always_sep_dup.
ecancel [heap_ctx _]. rewrite !assoc. sep_split right: []; last first.
{ do 2 apply forall_intro=>_. apply wand_intro_l.
eauto using later_intro with I. }
sep_split left: [recv heapN _ _ _; heap_ctx _]%I; by rewrite -worker_safe comm.
iSplitL; [|iIntros {_ _} "_"; by iNext].
iDestruct recv_weaken "[] Hr" as "Hr".
{ iIntros "?". by iApply y_inv_split "-". }
iPvs recv_split "Hr" as "[H1 H2]"; first done.
iApply (wp_par heapN N (λ _, True%I) (λ _, True%I)); eauto.
iFrame "Hh"; iSplitL "H1"; [|iSplitL "H2"; [|iIntros {_ _} "_"; by iNext]];
iApply worker_safe; by iSplit.
Qed.
End client.
......@@ -81,11 +63,9 @@ Section ClosedProofs.
Lemma client_safe_closed σ : {{ ownP σ : iProp }} client {{ λ v, True }}.
Proof.
apply ht_alt. rewrite (heap_alloc (nroot .@ "Barrier")); last done.
apply wp_strip_pvs, exist_elim=> ?. rewrite and_elim_l.
rewrite -(client_safe (nroot .@ "Barrier") (nroot .@ "Heap")) //.
(* This, too, should be automated. *)
by apply ndot_ne_disjoint.
iIntros "! Hσ".
iPvs (heap_alloc (nroot .@ "Barrier")) "Hσ" as {h} "[#Hh _]"; first done.
iApply (client_safe (nroot .@ "Barrier") (nroot .@ "Heap")); auto with ndisj.
Qed.
Print Assumptions client_safe_closed.
......
This diff is collapsed.
From iris.program_logic Require Export hoare.
From iris.heap_lang.lib.barrier Require Export barrier.
From iris.heap_lang.lib.barrier Require Import proof.
From iris.heap_lang Require Import proofmode.
Import uPred.
Section spec.
......@@ -22,14 +23,11 @@ Proof.
intros HN.
exists (λ l, CofeMor (recv heapN N l)), (λ l, CofeMor (send heapN N l)).
split_and?; simpl.
- intros P. apply: always_intro. apply impl_intro_r.
rewrite -(newbarrier_spec heapN N P) // always_and_sep_r.
apply sep_mono_r, forall_intro=>l; apply wand_intro_l.
by rewrite right_id -(exist_intro l) const_equiv // left_id.
- intros l P. apply ht_alt. by rewrite -signal_spec right_id.
- intros l P. apply ht_alt.
by rewrite -(wait_spec heapN N l P) wand_diag right_id.
- intros l P Q. apply vs_alt. rewrite -(recv_split heapN N N l P Q) //.
- intros l P Q. apply recv_weaken.
- iIntros {P} "#? ! _". iApply (newbarrier_spec _ _ P); first done.
iSplit; [done|]; iIntros {l} "?"; iExists l; by iSplit.
- iIntros {l P} "! [Hl HP]". by iApply signal_spec; iFrame "Hl HP".
- iIntros {l P} "! Hl". iApply wait_spec; iFrame "Hl". by iIntros "?".
- iIntros {l P Q} "! Hl". by iApply recv_split.
- apply recv_weaken.
Qed.
End spec.
From iris.heap_lang Require Export heap spawn.
From iris.heap_lang Require Import wp_tactics notation.
From iris.heap_lang Require Import proofmode notation.
Import uPred.
Definition par : val :=
......@@ -25,15 +25,12 @@ Lemma par_spec (Ψ1 Ψ2 : val → iProp) e (f1 f2 : val) (Φ : val → iProp) :
v1 v2, Ψ1 v1 Ψ2 v2 - Φ (v1,v2)%V)
WP par e {{ Φ }}.
Proof.
intros. rewrite /par. ewp (by eapply wp_value). wp_let. wp_proj.
ewp (eapply spawn_spec; wp_done).
apply sep_mono_r, sep_mono_r.
apply forall_intro=>h. apply wand_intro_l. wp_let. wp_proj.
wp_focus (f2 _). rewrite wp_frame_r wp_frame_l. apply wp_mono=>v2. wp_let.
ewp (by eapply join_spec).
apply sep_mono_r, forall_intro=>v1; apply wand_intro_l.
rewrite (forall_elim v1) (forall_elim v2). rewrite assoc wand_elim_r.
wp_let. apply wp_value; wp_done.
iIntros {??} "(#Hh&Hf1&Hf2&HΦ)". wp_value. wp_let. wp_proj.
wp_apply spawn_spec; try wp_done. iFrame "Hf1 Hh".
iIntros {l} "Hl". wp_let. wp_proj. wp_focus (f2 _).
iApply wp_wand_l; iFrame "Hf2"; iIntros {v} "H2". wp_let.
wp_apply join_spec; iFrame "Hl". iIntros {w} "H1".
iSpecialize "HΦ" "-"; first by iSplitL "H1". wp_let. by iPvsIntro.
Qed.
Lemma wp_par (Ψ1 Ψ2 : val iProp) (e1 e2 : expr []) (Φ : val iProp) :
......@@ -42,6 +39,7 @@ Lemma wp_par (Ψ1 Ψ2 : val → iProp) (e1 e2 : expr []) (Φ : val → iProp) :
v1 v2, Ψ1 v1 Ψ2 v2 - Φ (v1,v2)%V)
WP ParV e1 e2 {{ Φ }}.
Proof.
intros. rewrite -par_spec //. repeat apply sep_mono; done || by wp_seq.
iIntros {?} "(#Hh&H1&H2&H)". iApply par_spec; auto.
iFrame "Hh H". iSplitL "H1"; by wp_let.
Qed.
End proof.
From iris.program_logic Require Export global_functor.
From iris.heap_lang Require Export heap.
From iris.heap_lang Require Import wp_tactics notation.
From iris.proofmode Require Import invariants ghost_ownership.
From iris.heap_lang Require Import proofmode notation.
Import uPred.
Definition spawn : val :=
......@@ -33,12 +34,15 @@ Context (heapN N : namespace).
Local Notation iProp := (iPropG heap_lang Σ).
Definition spawn_inv (γ : gname) (l : loc) (Ψ : val iProp) : iProp :=
( lv, l lv (lv = InjLV #0 v, lv = InjRV v (Ψ v own γ (Excl ()))))%I.
( lv, l lv (lv = InjLV #0
v, lv = InjRV v (Ψ v own γ (Excl ()))))%I.
Definition join_handle (l : loc) (Ψ : val iProp) : iProp :=
( (heapN N) γ, heap_ctx heapN own γ (Excl ())
inv N (spawn_inv γ l Ψ))%I.
Typeclasses Opaque join_handle.
Global Instance spawn_inv_ne n γ l :
Proper (pointwise_relation val (dist n) ==> dist n) (spawn_inv γ l).
Proof. solve_proper. Qed.
......@@ -53,65 +57,36 @@ Lemma spawn_spec (Ψ : val → iProp) e (f : val) (Φ : val → iProp) :
(heap_ctx heapN WP f #() {{ Ψ }} l, join_handle l Ψ - Φ (%l))
WP spawn e {{ Φ }}.
Proof.
intros Hval Hdisj. rewrite /spawn. ewp (by eapply wp_value). wp_let.
wp eapply wp_alloc; eauto with I.
apply forall_intro=>l. apply wand_intro_l. wp_let.
rewrite (forall_elim l). eapply sep_elim_True_l.
{ by eapply (own_alloc (Excl ())). }
rewrite !pvs_frame_r. eapply wp_strip_pvs. rewrite !sep_exist_r.
apply exist_elim=>γ.
(* TODO: Figure out a better way to say "I want to establish ▷ spawn_inv". *)
trans (heap_ctx heapN WP f #() {{ Ψ }} (join_handle l Ψ - Φ (%l)%V)
own γ (Excl ()) (spawn_inv γ l Ψ))%I.
{ ecancel [ WP _ {{ _ }}; _ - _; heap_ctx _; own _ _]%I.
rewrite -later_intro /spawn_inv -(exist_intro (InjLV #0)).
cancel [l InjLV #0]%I. by apply or_intro_l', const_intro. }
rewrite (inv_alloc N) // !pvs_frame_l. eapply wp_strip_pvs.
ewp eapply wp_fork. rewrite [heap_ctx _]always_sep_dup [inv _ _]always_sep_dup.
sep_split left: [_ - _; inv _ _; own _ _; heap_ctx _]%I.
- wp_seq. rewrite -pvs_intro. eapply wand_apply_l; [done..|].
rewrite /join_handle. rewrite const_equiv // left_id -(exist_intro γ).
solve_sep_entails.
- wp_focus (f _). rewrite wp_frame_r wp_frame_l.
rewrite (of_to_val e) //. apply wp_mono=>v.
eapply (inv_fsa (wp_fsa _)) with (N0:=N);
rewrite /= ?to_of_val; eauto with I ndisj.
apply wand_intro_l. rewrite /spawn_inv {1}later_exist !sep_exist_r.
apply exist_elim=>lv. rewrite later_sep.
eapply wp_store; rewrite /= ?to_of_val; eauto with I ndisj.
cancel [ (l lv)]%I. strip_later. apply wand_intro_l.
rewrite right_id -later_intro -{2}[( _, _ _ _)%I](exist_intro (InjRV v)).
ecancel [l _]%I. apply or_intro_r'. rewrite sep_elim_r sep_elim_r sep_elim_l.
rewrite -(exist_intro v). rewrite const_equiv // left_id. apply or_intro_l.
iIntros {<-%of_to_val ?} "(#Hh&Hf&HΦ)". rewrite /spawn.
wp_let; wp_alloc l as "Hl"; wp_let.
iPvs (own_alloc (Excl ())) as {γ} "Hγ"; first done.
iPvs (inv_alloc N _ (spawn_inv γ l Ψ)) "[Hl]" as "#?"; first done.
{ iNext. iExists (InjLV #0). iFrame "Hl". by iLeft. }
wp_apply wp_fork. iSplitR "Hf".
- wp_seq. iPvsIntro. iApply "HΦ"; rewrite /join_handle. iSplit; first done.
iExists γ. iFrame "Hγ"; by iSplit.
- wp_focus (f _). iApply wp_wand_l; iFrame "Hf"; iIntros {v} "Hv".
iInv N as "Hinv"; first wp_done; iDestruct "Hinv" as {v'} "[Hl _]".
wp_store. iSplit; [iNext|done].
iExists (InjRV v); iFrame "Hl"; iRight; iExists v; iSplit; [done|by iLeft].
Qed.
Lemma join_spec (Ψ : val iProp) l (Φ : val iProp) :
(join_handle l Ψ v, Ψ v - Φ v)
WP join (%l) {{ Φ }}.
(join_handle l Ψ v, Ψ v - Φ v) WP join (%l) {{ Φ }}.
Proof.
wp_rec. wp_focus (! _)%E.
rewrite {1}/join_handle sep_exist_l !sep_exist_r. apply exist_elim=>γ.
rewrite -!assoc. apply const_elim_sep_l=>Hdisj.
eapply (inv_fsa (wp_fsa _)) with (N0:=N); simpl; eauto with I ndisj.
apply wand_intro_l. rewrite /spawn_inv {1}later_exist !sep_exist_r.
apply exist_elim=>lv.
wp eapply wp_load; eauto with I ndisj. cancel [l lv]%I.
apply wand_intro_l. rewrite -later_intro -[X in _ (X _)](exist_intro lv).
cancel [l lv]%I. rewrite sep_or_r. apply or_elim.
- (* Case 1 : nothing sent yet, we wait. *)
rewrite -or_intro_l. apply const_elim_sep_l=>-> {lv}.
rewrite (const_equiv (_ = _)) // left_id. wp_case.
wp_seq. rewrite -always_wand_impl always_elim.
rewrite !assoc. eapply wand_apply_r'; first done.
rewrite -(exist_intro γ) const_equiv //. solve_sep_entails.
- rewrite [(_ _)%I]sep_elim_l -or_intro_r !sep_exist_r. apply exist_mono=>v.
rewrite -!assoc. apply const_elim_sep_l=>->{lv}. rewrite const_equiv // left_id.
rewrite sep_or_r. apply or_elim; last first.
{ (* contradiction: we have the token twice. *)
rewrite [(heap_ctx _ _)%I]sep_elim_r !assoc. rewrite -own_op own_valid_l.
rewrite -!assoc discrete_valid. apply const_elim_sep_l=>-[]. }
rewrite -or_intro_r. ecancel [own _ _].
wp_case. wp_let. ewp (eapply wp_value; wp_done).
rewrite (forall_elim v). rewrite !assoc. eapply wand_apply_r'; eauto with I.
rewrite /join_handle; iIntros "[[% H] Hv]"; iDestruct "H" as {γ} "(#?&Hγ&#?)".
iLöb "Hγ Hv" as "IH". wp_rec. wp_focus (! _)%E.
iInv N as "Hinv"; iDestruct "Hinv" as {v} "[Hl Hinv]".
wp_load. iDestruct "Hinv" as "[%|Hinv]"; subst.
- iSplitL "Hl"; [iNext; iExists _; iFrame "Hl"; by iLeft|].
wp_case. wp_seq. iApply "IH" "Hγ Hv".
- iDestruct "Hinv" as {v'} "[% [HΨ|Hγ']]"; subst.
+ iSplitL "Hl Hγ".
{ iNext. iExists _; iFrame "Hl"; iRight.
iExists _; iSplit; [done|by iRight]. }
wp_case. wp_let. iPvsIntro. by iApply "Hv".
+ iCombine "Hγ" "Hγ'" as "Hγ". by iDestruct own_valid "Hγ" as "%".
Qed.
End proof.
Typeclasses Opaque join_handle.
From iris.proofmode Require Import coq_tactics.
From iris.proofmode Require Export weakestpre.
From iris.heap_lang Require Export wp_tactics heap.
Import uPred.
Ltac strip_later ::= iNext.
Section heap.
Context {Σ : gFunctors} `{heapG Σ}.
Implicit Types N : namespace.
Implicit Types P Q : iPropG heap_lang Σ.
Implicit Types Φ : val iPropG heap_lang Σ.
Implicit Types Δ : envs (iResR heap_lang (globalF Σ)).
Global Instance sep_destruct_mapsto l q v :
SepDestruct false (l {q} v) (l {q/2} v) (l {q/2} v).
Proof. by rewrite /SepDestruct heap_mapsto_op_split. Qed.
Lemma tac_wp_alloc Δ Δ' N E j e v Φ :
to_val e = Some v
Δ heap_ctx N nclose N E
StripLaterEnvs Δ Δ'
( l, Δ'',
envs_app false (Esnoc Enil j (l v)) Δ' = Some Δ'' Δ'' Φ (LocV l))
Δ WP Alloc e @ E {{ Φ }}.
Proof.
intros ???? HΔ; eapply wp_alloc; eauto.
rewrite strip_later_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 Δ Δ' N E i l q v Φ :
Δ heap_ctx N nclose N E
StripLaterEnvs Δ Δ'
envs_lookup i Δ' = Some (false, l {q} v)%I
Δ' Φ v
Δ WP Load (Loc l) @ E {{ Φ }}.
Proof.
intros. eapply wp_load; eauto.
rewrite strip_later_env_sound -later_sep envs_lookup_split //; simpl.
by apply later_mono, sep_mono_r, wand_mono.
Qed.
Lemma tac_wp_store Δ Δ' Δ'' N E i l v e v' Φ :
to_val e = Some v'
Δ heap_ctx N nclose N E
StripLaterEnvs Δ Δ'
envs_lookup i Δ' = Some (false, l v)%I
envs_simple_replace i false (Esnoc Enil i (l v')) Δ' = Some Δ''
Δ'' Φ (LitV LitUnit) Δ WP Store (Loc l) e @ E {{ Φ }}.
Proof.
intros. eapply wp_store; eauto.
rewrite strip_later_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 Δ Δ' N E i l q v e1 v1 e2 v2 Φ :
to_val e1 = Some v1 to_val e2 = Some v2
Δ heap_ctx N nclose N E
StripLaterEnvs Δ Δ'
envs_lookup i Δ' = Some (false, l {q} v)%I v v1
Δ' Φ (LitV (LitBool false))
Δ WP CAS (Loc l) e1 e2 @ E {{ Φ }}.
Proof.
intros. eapply wp_cas_fail; eauto.
rewrite strip_later_env_sound -later_sep envs_lookup_split //; simpl.
by apply later_mono, sep_mono_r, wand_mono.
Qed.
Lemma tac_wp_cas_suc Δ Δ' Δ'' N E i l e1 v1 e2 v2 Φ :
to_val e1 = Some v1 to_val e2 = Some v2
Δ heap_ctx N nclose N E
StripLaterEnvs Δ Δ'
envs_lookup i Δ' = Some (false, l v1)%I
envs_simple_replace i false (Esnoc Enil i (l v2)) Δ' = Some Δ''
Δ'' Φ (LitV (LitBool true)) Δ WP CAS (Loc l) e1 e2 @ E {{ Φ }}.
Proof.
intros. eapply wp_cas_suc; eauto.
rewrite strip_later_env_sound -later_sep envs_simple_replace_sound //; simpl.
rewrite right_id. by apply later_mono, sep_mono_r, wand_mono.
Qed.
End heap.
Tactic Notation "wp_apply" open_constr(lem) :=
match goal with
| |- _ wp ?E ?e ?Q => reshape_expr e ltac:(fun K e' =>
wp_bind K; iApply lem; try iNext)
end.
Tactic Notation "wp_apply" open_constr(lem) constr(Hs) :=
match goal with
| |- _ wp ?E ?e ?Q => reshape_expr e ltac:(fun K e' =>
wp_bind K; iApply lem Hs; try iNext)
end.
Tactic Notation "wp_alloc" ident(l) "as" constr(H) :=
match goal with
| |- _ wp ?E ?e ?Q => reshape_expr e ltac:(fun K e' =>
match eval hnf in e' with
| Alloc ?e =>
wp_bind K; eapply tac_wp_alloc with _ _ H _;
[wp_done || fail 2 "wp_alloc:" e "not a value"
|iAssumption || fail 2 "wp_alloc: cannot find heap_ctx"
|done || eauto with ndisj
|apply _
|intros l; eexists; split;
[env_cbv; reflexivity || fail 2 "wp_alloc:" H "not fresh"
|wp_finish]]
end)
end.
Tactic Notation "wp_alloc" ident(l) := let H := iFresh in wp_alloc l as H.
Tactic Notation "wp_load" :=
match goal with
| |- _ wp ?E ?e ?Q => reshape_expr e ltac:(fun K e' =>
match eval hnf in e' with
| Load (Loc ?l) =>
wp_bind K; eapply tac_wp_load;
[iAssumption || fail 2 "wp_load: cannot find heap_ctx"
|done || eauto with ndisj
|apply _
|iAssumptionCore || fail 2 "wp_cas_fail: cannot find" l "↦ ?"
|wp_finish]
end)
end.
Tactic Notation "wp_store" :=
match goal with
| |- _ wp ?E ?e ?Q => reshape_expr e ltac:(fun K e' =>
match eval hnf in e' with
| Store ?l ?e =>
wp_bind K; eapply tac_wp_store;
[wp_done || fail 2 "wp_store:" e "not a value"
|iAssumption || fail 2 "wp_store: cannot find heap_ctx"
|done || eauto with ndisj
|apply _
|iAssumptionCore || fail 2 "wp_store: cannot find" l "↦ ?"
|env_cbv; reflexivity
|wp_finish]
end)
end.
Tactic Notation "wp_cas_fail" :=
match goal with
| |- _ wp ?E ?e ?Q => reshape_expr e ltac:(fun K e' =>
match eval hnf in e' with
| CAS (Loc ?l) ?e1 ?e2 =>
wp_bind K; eapply tac_wp_cas_fail;
[wp_done || fail 2 "wp_cas_fail:" e1 "not a value"
|wp_done || fail 2 "wp_cas_fail:" e2 "not a value"
|iAssumption || fail 2 "wp_cas_fail: cannot find heap_ctx"
|done || eauto with ndisj
|apply _
|iAssumptionCore || fail 2 "wp_cas_fail: cannot find" l "↦ ?"
|try discriminate
|wp_finish]
end)
end.
Tactic Notation "wp_cas_suc" :=
match goal with
| |- _ wp ?E ?e ?Q => reshape_expr e ltac:(fun K e' =>
match eval hnf in e' with
| CAS (Loc ?l) ?e1 ?e2 =>
wp_bind K; eapply tac_wp_cas_suc;
[wp_done || fail 2 "wp_cas_suc:" e1 "not a value"
|wp_done || fail 2 "wp_cas_suc:" e1 "not a value"
|iAssumption || fail 2 "wp_cas_suc: cannot find heap_ctx"
|done || eauto with ndisj
|apply _
|iAssumptionCore || fail 2 "wp_cas_suc: cannot find" l "↦ ?"
|env_cbv; reflexivity
|wp_finish]
end)
end.
......@@ -9,33 +9,37 @@ Ltac wp_bind K :=
| _ => etrans; [|fast_by apply (wp_bind K)]; simpl
end.
Ltac wp_finish :=
intros_revert ltac:(
try strip_later;
match goal with
| |- _ wp _ _ _ =>
etrans; [|eapply wp_value_pvs; fast_done]; lazy beta;
(* sometimes, we will have to do a final view shift, so only apply
pvs_intro if we obtain a consecutive wp *)