Commit 7c32c1ac authored by Joseph Tassarotti's avatar Joseph Tassarotti

Modify adequacy proof to not break the 'fancy update' abstraction. Modify fupd...

Modify adequacy proof to not break the 'fancy update' abstraction. Modify fupd plainly interface and add new derived results.
parent 1d34bda8
From iris.base_logic.lib Require Export own. From iris.base_logic.lib Require Export own.
From stdpp Require Export coPset. From stdpp Require Export coPset.
From iris.base_logic.lib Require Import wsat. From iris.base_logic.lib Require Import wsat.
From iris.algebra Require Import gmap auth agree gset coPset.
From iris.proofmode Require Import tactics. From iris.proofmode Require Import tactics.
Set Default Proof Using "Type". Set Default Proof Using "Type".
Export invG. Export invG.
...@@ -40,13 +41,50 @@ Proof. rewrite /BiBUpdFUpd uPred_fupd_eq. by iIntros (E P) ">? [$ $] !> !>". Qed ...@@ -40,13 +41,50 @@ Proof. rewrite /BiBUpdFUpd uPred_fupd_eq. by iIntros (E P) ">? [$ $] !> !>". Qed
Instance uPred_bi_fupd_plainly `{invG Σ} : BiFUpdPlainly (uPredSI (iResUR Σ)). Instance uPred_bi_fupd_plainly `{invG Σ} : BiFUpdPlainly (uPredSI (iResUR Σ)).
Proof. Proof.
split. split.
- iIntros (E1 E2 E2' P Q ? (E3&->&HE)%subseteq_disjoint_union_L) "HQP HQ". - rewrite uPred_fupd_eq /uPred_fupd_def. iIntros (E P Q ?) "HQP HQ [Hw HE]".
rewrite uPred_fupd_eq /uPred_fupd_def ownE_op //. iIntros "H". iAssert ( P)%I as "#>$".
iMod ("HQ" with "H") as ">(Hws & [HE1 HE3] & HQ)"; iModIntro.
iAssert ( P)%I as "#HP".
{ by iMod ("HQP" with "HQ [$]") as "(_ & _ & HP)". } { by iMod ("HQP" with "HQ [$]") as "(_ & _ & HP)". }
iMod "HP". iFrame. auto. by iFrame.
- rewrite uPred_fupd_eq /uPred_fupd_def. iIntros (E P ?) "HP [Hw HE]". - rewrite uPred_fupd_eq /uPred_fupd_def. iIntros (p E1 E2 P ?) "HP [Hw HE]".
iAssert ( P)%I with "[-]" as "#$"; last by iFrame. iAssert (?p P)%I with "[-]" as "#$"; last by iFrame.
iNext. by iMod ("HP" with "[$]") as "(_ & _ & HP)". iNext. by iMod ("HP" with "[$]") as "(_ & _ & HP)".
Qed. Qed.
Lemma fupd_plain_soundness `{invPreG Σ} E (P: iPropSI Σ) `{!Plain P}:
( `{Hinv: invG Σ}, (|={, E}=> P)%I) ( P)%I.
Proof.
iIntros (Hfupd). iMod wsat_alloc as (Hinv) "[Hw HE]".
iPoseProof (Hfupd Hinv) as "H".
rewrite uPred_fupd_eq /uPred_fupd_def.
iMod ("H" with "[$]") as "[Hw [HE >H']]"; iFrame.
Qed.
Lemma step_fupdN_soundness `{invPreG Σ} φ n :
( `{Hinv: invG Σ}, (|={, }=>^n |={, }=> φ : iProp Σ)%I)
φ.
Proof.
iIntros (Hiter).
eapply (soundness (M:=iResUR Σ) _ (S (S n))).
eapply (fupd_plain_soundness ); first by apply _.
intros Hinv. rewrite -/sbi_laterN.
iPoseProof (Hiter Hinv) as "H".
destruct n.
- rewrite //=. iPoseProof (fupd_plain_strong with "H") as "H'".
do 2 iMod "H'"; iModIntro; auto.
- iPoseProof (step_fupdN_mono _ _ _ _ (|={}=> ⌜φ⌝)%I with "H") as "H'".
{ iIntros "H". iMod (fupd_plain_strong with "H"); auto. }
rewrite -step_fupdN_S_fupd.
iMod (step_fupdN_plain with "H'") as "Hφ". iModIntro. iNext.
rewrite -later_laterN laterN_later.
iNext. by do 2 iMod "Hφ".
Qed.
Lemma step_fupdN_soundness' `{invPreG Σ} φ n :
( `{Hinv: invG Σ}, (|={, }=>^n φ : iProp Σ)%I)
φ.
Proof.
iIntros (Hiter). eapply (step_fupdN_soundness _ n).
iIntros (Hinv). iPoseProof (Hiter Hinv) as "Hiter".
iApply (step_fupdN_mono with "Hiter").
iIntros (?). iMod (fupd_intro_mask' _ ) as "_"; auto.
Qed.
...@@ -16,6 +16,20 @@ Module invG. ...@@ -16,6 +16,20 @@ Module invG.
End invG. End invG.
Import invG. Import invG.
Definition invΣ : gFunctors :=
#[GFunctor (authRF (gmapURF positive (agreeRF (laterCF idCF))));
GFunctor coPset_disjUR;
GFunctor (gset_disjUR positive)].
Class invPreG (Σ : gFunctors) : Set := WsatPreG {
inv_inPreG :> inG Σ (authR (gmapUR positive (agreeR (laterC (iPreProp Σ)))));
enabled_inPreG :> inG Σ coPset_disjR;
disabled_inPreG :> inG Σ (gset_disjR positive);
}.
Instance subG_invΣ {Σ} : subG invΣ Σ invPreG Σ.
Proof. solve_inG. Qed.
Definition invariant_unfold {Σ} (P : iProp Σ) : agree (later (iPreProp Σ)) := Definition invariant_unfold {Σ} (P : iProp Σ) : agree (later (iPreProp Σ)) :=
to_agree (Next (iProp_unfold P)). to_agree (Next (iProp_unfold P)).
Definition ownI `{invG Σ} (i : positive) (P : iProp Σ) : iProp Σ := Definition ownI `{invG Σ} (i : positive) (P : iProp Σ) : iProp Σ :=
...@@ -175,3 +189,15 @@ Proof. ...@@ -175,3 +189,15 @@ Proof.
iFrame "HI". by iRight. iFrame "HI". by iRight.
Qed. Qed.
End wsat. End wsat.
(* Allocation of an initial world *)
Lemma wsat_alloc `{invPreG Σ} : (|==> _ : invG Σ, wsat ownE )%I.
Proof.
iIntros.
iMod (own_alloc ( ( : gmap _ _))) as (γI) "HI"; first done.
iMod (own_alloc (CoPset )) as (γE) "HE"; first done.
iMod (own_alloc (GSet )) as (γD) "HD"; first done.
iModIntro; iExists (WsatG _ _ _ _ γI γE γD).
rewrite /wsat /ownE -lock; iFrame.
iExists . rewrite fmap_empty big_opM_empty. by iFrame.
Qed.
...@@ -957,9 +957,10 @@ Proof. move => [] /(_ i). rewrite /Plain monPred_at_plainly bi.forall_elim //. Q ...@@ -957,9 +957,10 @@ Proof. move => [] /(_ i). rewrite /Plain monPred_at_plainly bi.forall_elim //. Q
Global Instance monPred_bi_fupd_plainly `{BiFUpdPlainly PROP} : BiFUpdPlainly monPredSI. Global Instance monPred_bi_fupd_plainly `{BiFUpdPlainly PROP} : BiFUpdPlainly monPredSI.
Proof. Proof.
split; rewrite monPred_fupd_eq; unseal. split; rewrite monPred_fupd_eq; unseal.
- intros E1 E2 E2' P Q ? HE12. split=>/= i. do 3 f_equiv. - intros E P Q ?. split=>/= i. do 3 f_equiv.
apply fupd_plain'; [apply _|done]. apply fupd_plain_weak; apply _.
- intros E P ?. split=>/= i. apply later_fupd_plain, _. - intros p E1 E2 P ?. split=>/= i. specialize (later_fupd_plain p) => HFP.
destruct p; simpl; [ unseal | ]; apply HFP, _.
Qed. Qed.
Global Instance plainly_objective `{BiPlainly PROP} P : Objective ( P). Global Instance plainly_objective `{BiPlainly PROP} P : Objective ( P).
......
...@@ -87,6 +87,8 @@ Reserved Notation "|={ E }▷=> Q" ...@@ -87,6 +87,8 @@ Reserved Notation "|={ E }▷=> Q"
Reserved Notation "P ={ E }▷=∗ Q" Reserved Notation "P ={ E }▷=∗ Q"
(at level 99, E at level 50, Q at level 200, (at level 99, E at level 50, Q at level 200,
format "'[' P '/' ={ E }▷=∗ Q ']'"). format "'[' P '/' ={ E }▷=∗ Q ']'").
Reserved Notation "|={ E1 , E2 }▷=>^ n Q"
(at level 99, E1, E2 at level 50, n at level 9, Q at level 200).
(** Big Ops *) (** Big Ops *)
Reserved Notation "'[∗' 'list]' k ↦ x ∈ l , P" Reserved Notation "'[∗' 'list]' k ↦ x ∈ l , P"
......
...@@ -28,9 +28,11 @@ Notation "P ={ E }=∗ Q" := (P -∗ |={E}=> Q) : stdpp_scope. ...@@ -28,9 +28,11 @@ Notation "P ={ E }=∗ Q" := (P -∗ |={E}=> Q) : stdpp_scope.
Notation "|={ E1 , E2 , E3 }▷=> Q" := (|={E1,E2}=> ( |={E2,E3}=> Q))%I : bi_scope. Notation "|={ E1 , E2 , E3 }▷=> Q" := (|={E1,E2}=> ( |={E2,E3}=> Q))%I : bi_scope.
Notation "P ={ E1 , E2 , E3 }▷=∗ Q" := (P - |={ E1,E2,E3 }=> Q)%I : bi_scope. Notation "P ={ E1 , E2 , E3 }▷=∗ Q" := (P - |={ E1,E2,E3 }=> Q)%I : bi_scope.
Notation "|={ E1 , E2 }▷=> Q" := (|={E1,E2,E1}=> Q)%I : bi_scope. Notation "|={ E1 , E2 }▷=> Q" := (|={E1,E2,E1}=> Q)%I : bi_scope.
Notation "P ={ E1 , E2 }▷=∗ Q" := (P |={ E1 , E2, E1 }=> Q) (only parsing) : stdpp_scope.
Notation "P ={ E1 , E2 }▷=∗ Q" := (P - |={ E1 , E2, E1 }=> Q)%I : bi_scope. Notation "P ={ E1 , E2 }▷=∗ Q" := (P - |={ E1 , E2, E1 }=> Q)%I : bi_scope.
Notation "|={ E }▷=> Q" := (|={E,E}=> Q)%I : bi_scope. Notation "|={ E }▷=> Q" := (|={E,E}=> Q)%I : bi_scope.
Notation "P ={ E }▷=∗ Q" := (P ={E,E}= Q)%I : bi_scope. Notation "P ={ E }▷=∗ Q" := (P ={E,E}= Q)%I : bi_scope.
Notation "|={ E1 , E2 }▷=>^ n Q" := (Nat.iter n (λ P, |={E1,E2}=> P) Q)%I : bi_scope.
(** Bundled versions *) (** Bundled versions *)
(* Mixins allow us to create instances easily without having to use Program *) (* Mixins allow us to create instances easily without having to use Program *)
...@@ -76,11 +78,10 @@ Class BiBUpdPlainly (PROP : sbi) `{!BiBUpd PROP, !BiPlainly PROP} := ...@@ -76,11 +78,10 @@ Class BiBUpdPlainly (PROP : sbi) `{!BiBUpd PROP, !BiPlainly PROP} :=
Hint Mode BiBUpdPlainly ! - - : typeclass_instances. Hint Mode BiBUpdPlainly ! - - : typeclass_instances.
Class BiFUpdPlainly (PROP : sbi) `{!BiFUpd PROP, !BiPlainly PROP} := { Class BiFUpdPlainly (PROP : sbi) `{!BiFUpd PROP, !BiPlainly PROP} := {
fupd_plain' E1 E2 E2' (P Q : PROP) `{!Plain P} : fupd_plain_weak E (P Q : PROP) `{!Plain P} :
E1 E2 (Q ={E}= P) - Q ={E}= Q P;
(Q ={E1, E2'}= P) - (|={E1, E2}=> Q) ={E1}= (|={E1, E2}=> Q) P; later_fupd_plain p E1 E2 (P : PROP) `{!Plain P} :
later_fupd_plain E (P : PROP) `{!Plain P} : (?p |={E1, E2}=> P) ={E1}= ?p P;
( |={E}=> P) ={E}= P;
}. }.
Hint Mode BiBUpdFUpd ! - - : typeclass_instances. Hint Mode BiBUpdFUpd ! - - : typeclass_instances.
...@@ -271,6 +272,23 @@ Section fupd_derived. ...@@ -271,6 +272,23 @@ Section fupd_derived.
intros P1 P2 HP Q1 Q2 HQ. by rewrite HP HQ -fupd_sep. intros P1 P2 HP Q1 Q2 HQ. by rewrite HP HQ -fupd_sep.
Qed. Qed.
Lemma fupd_plain_strong `{BiPlainly PROP, !BiFUpdPlainly PROP} E1 E2 P `{!Plain P} :
(|={E1, E2}=> P) ={E1}= P.
Proof. by apply (later_fupd_plain false). Qed.
Lemma fupd_plain' `{BiPlainly PROP, !BiFUpdPlainly PROP} E1 E2 E2' P Q `{!Plain P} :
E1 E2
(Q ={E1, E2'}= P) - (|={E1, E2}=> Q) ={E1}= (|={E1, E2}=> Q) P.
Proof.
intros (E3&->&HE)%subseteq_disjoint_union_L.
apply wand_intro_l. rewrite fupd_frame_r.
rewrite fupd_plain_strong fupd_except_0 fupd_plain_weak wand_elim_r.
rewrite (fupd_mask_mono E1 (E1 E3)); last by set_solver+.
rewrite fupd_trans -(fupd_trans E1 (E1 E3) E1).
apply fupd_mono. rewrite -fupd_frame_r.
apply sep_mono; auto. apply fupd_intro_mask; set_solver+.
Qed.
Lemma fupd_plain `{BiPlainly PROP, !BiFUpdPlainly PROP} E1 E2 P Q `{!Plain P} : Lemma fupd_plain `{BiPlainly PROP, !BiFUpdPlainly PROP} E1 E2 P Q `{!Plain P} :
E1 E2 (Q - P) - (|={E1, E2}=> Q) ={E1}= (|={E1, E2}=> Q) P. E1 E2 (Q - P) - (|={E1, E2}=> Q) ={E1}= (|={E1, E2}=> Q) P.
Proof. Proof.
...@@ -309,4 +327,60 @@ Section fupd_derived. ...@@ -309,4 +327,60 @@ Section fupd_derived.
Lemma step_fupd_intro E1 E2 P : E2 E1 P - |={E1,E2}=> P. Lemma step_fupd_intro E1 E2 P : E2 E1 P - |={E1,E2}=> P.
Proof. intros. by rewrite -(step_fupd_mask_mono E2 _ _ E2) // -!fupd_intro. Qed. Proof. intros. by rewrite -(step_fupd_mask_mono E2 _ _ E2) // -!fupd_intro. Qed.
Lemma step_fupd_frame_l E1 E2 R Q :
(R |={E1, E2}=> Q) - |={E1, E2}=> (R Q).
Proof.
rewrite fupd_frame_l.
apply fupd_mono.
rewrite [P in P _ _](later_intro R) -later_sep fupd_frame_l.
by apply later_mono, fupd_mono.
Qed.
Lemma step_fupd_plain `{BiPlainly PROP, !BiFUpdPlainly PROP} E P `{!Plain P} :
(|={E, }=> P) ={E}= P.
Proof.
specialize (later_fupd_plain true E P) => //= ->.
rewrite fupd_trans fupd_plain_strong. apply fupd_mono, except_0_later.
Qed.
Lemma step_fupd_fupd E P:
(|={E, }=> P) (|={E, }=> |={E}=> P).
Proof.
apply (anti_symm ()).
- by rewrite -fupd_intro.
- by rewrite fupd_trans.
Qed.
Lemma step_fupdN_mono E1 E2 n P Q :
(P Q) (|={E1, E2}=>^n P) (|={E1, E2}=>^n Q).
Proof.
intros HPQ. induction n as [|n IH]=> //=. rewrite IH //.
Qed.
Lemma step_fupdN_S_fupd n E P:
(|={E, }=>^(S n) P) (|={E, }=>^(S n) |={E}=> P).
Proof.
apply (anti_symm ()); rewrite !Nat_iter_S_r; apply step_fupdN_mono;
rewrite -step_fupd_fupd //.
Qed.
Lemma step_fupdN_frame_l E1 E2 n R Q :
(R |={E1, E2}=>^n Q) - |={E1, E2}=>^n (R Q).
Proof.
induction n as [|n IH]; simpl; [done|].
rewrite step_fupd_frame_l IH //=.
Qed.
Lemma step_fupdN_plain `{BiPlainly PROP, !BiFUpdPlainly PROP} E n P `{!Plain P}:
(|={E, }=>^n P) ={E}= ^n P.
Proof.
induction n as [| n].
- rewrite -fupd_intro. apply except_0_intro.
- rewrite Nat_iter_S step_fupd_fupd IHn ?fupd_trans step_fupd_plain.
apply fupd_mono. destruct n; simpl.
* by rewrite except_0_idemp.
* by rewrite except_0_later.
Qed.
End fupd_derived. End fupd_derived.
From stdpp Require Import namespaces. From stdpp Require Import namespaces.
From iris.program_logic Require Export weakestpre. From iris.program_logic Require Export weakestpre.
From iris.algebra Require Import gmap auth agree gset coPset. From iris.algebra Require Import gmap auth agree gset coPset.
From iris.base_logic.lib Require Import wsat. From iris.base_logic.lib Require Export wsat.
From iris.proofmode Require Import tactics. From iris.proofmode Require Import tactics.
Set Default Proof Using "Type". Set Default Proof Using "Type".
Import uPred. Import uPred.
(* Global functor setup *)
Definition invΣ : gFunctors :=
#[GFunctor (authRF (gmapURF positive (agreeRF (laterCF idCF))));
GFunctor coPset_disjUR;
GFunctor (gset_disjUR positive)].
Class invPreG (Σ : gFunctors) : Set := WsatPreG {
inv_inPreG :> inG Σ (authR (gmapUR positive (agreeR (laterC (iPreProp Σ)))));
enabled_inPreG :> inG Σ coPset_disjR;
disabled_inPreG :> inG Σ (gset_disjR positive);
}.
Instance subG_invΣ {Σ} : subG invΣ Σ invPreG Σ.
Proof. solve_inG. Qed.
(* Allocation *)
Lemma wsat_alloc `{invPreG Σ} : (|==> _ : invG Σ, wsat ownE )%I.
Proof.
iIntros.
iMod (own_alloc ( ( : gmap _ _))) as (γI) "HI"; first done.
iMod (own_alloc (CoPset )) as (γE) "HE"; first done.
iMod (own_alloc (GSet )) as (γD) "HD"; first done.
iModIntro; iExists (WsatG _ _ _ _ γI γE γD).
rewrite /wsat /ownE -lock; iFrame.
iExists . rewrite fmap_empty big_opM_empty. by iFrame.
Qed.
(* Program logic adequacy *) (* Program logic adequacy *)
Record adequate {Λ} (s : stuckness) (e1 : expr Λ) (σ1 : state Λ) Record adequate {Λ} (s : stuckness) (e1 : expr Λ) (σ1 : state Λ)
(φ : val Λ state Λ Prop) := { (φ : val Λ state Λ Prop) := {
...@@ -66,28 +39,25 @@ Implicit Types P Q : iProp Σ. ...@@ -66,28 +39,25 @@ Implicit Types P Q : iProp Σ.
Implicit Types Φ : val Λ iProp Σ. Implicit Types Φ : val Λ iProp Σ.
Implicit Types Φs : list (val Λ iProp Σ). Implicit Types Φs : list (val Λ iProp Σ).
Notation world' E σ κs := (wsat ownE E state_interp σ κs)%I (only parsing).
Notation world σ κs := (world' σ κs) (only parsing).
Notation wptp s t := ([ list] ef t, WP ef @ s; {{ _, True }})%I. Notation wptp s t := ([ list] ef t, WP ef @ s; {{ _, True }})%I.
Lemma wp_step s E e1 σ1 κ κs e2 σ2 efs Φ : Lemma wp_step s E e1 σ1 κ κs e2 σ2 efs Φ :
prim_step e1 σ1 κ e2 σ2 efs prim_step e1 σ1 κ e2 σ2 efs
world' E σ1 (κ ++ κs) WP e1 @ s; E {{ Φ }} state_interp σ1 (κ ++ κs) WP e1 @ s; E {{ Φ }}
== |==> (world' E σ2 κs WP e2 @ s; E {{ Φ }} wptp s efs). ={E, }= (state_interp σ2 κs WP e2 @ s; E {{ Φ }} wptp s efs).
Proof. Proof.
rewrite {1}wp_unfold /wp_pre. iIntros (?) "[(Hw & HE & Hσ) H]". rewrite {1}wp_unfold /wp_pre. iIntros (?) "[ H]".
rewrite (val_stuck e1 σ1 κ e2 σ2 efs) // uPred_fupd_eq. rewrite (val_stuck e1 σ1 κ e2 σ2 efs) //.
iMod ("H" $! σ1 with "Hσ [Hw HE]") as ">(Hw & HE & _ & H)"; first by iFrame. iMod ("H" $! σ1 with "Hσ") as "(_ & H)".
iMod ("H" $! e2 σ2 efs with "[//] [$Hw $HE]") as ">(Hw & HE & H)". iMod ("H" $! e2 σ2 efs with "[//]") as "H".
iIntros "!> !>". by iMod ("H" with "[$Hw $HE]") as ">($ & $ & $)". by iIntros "!> !>".
Qed. Qed.
Lemma wptp_step s e1 t1 t2 κ κs σ1 σ2 Φ : Lemma wptp_step s e1 t1 t2 κ κs σ1 σ2 Φ :
step (e1 :: t1,σ1) κ (t2, σ2) step (e1 :: t1,σ1) κ (t2, σ2)
world σ1 (κ ++ κs) WP e1 @ s; {{ Φ }} wptp s t1 state_interp σ1 (κ ++ κs) WP e1 @ s; {{ Φ }} wptp s t1
== e2 t2', == e2 t2',
t2 = e2 :: t2' |==> (world σ2 κs WP e2 @ s; {{ Φ }} wptp s t2'). t2 = e2 :: t2' |={, }=> (state_interp σ2 κs WP e2 @ s; {{ Φ }} wptp s t2').
Proof. Proof.
iIntros (Hstep) "(HW & He & Ht)". iIntros (Hstep) "(HW & He & Ht)".
destruct Hstep as [e1' σ1' e2' σ2' efs [|? t1'] t2' ?? Hstep]; simplify_eq/=. destruct Hstep as [e1' σ1' e2' σ2' efs [|? t1'] t2' ?? Hstep]; simplify_eq/=.
...@@ -100,77 +70,70 @@ Qed. ...@@ -100,77 +70,70 @@ Qed.
Lemma wptp_steps s n e1 t1 κs κs' t2 σ1 σ2 Φ : Lemma wptp_steps s n e1 t1 κs κs' t2 σ1 σ2 Φ :
nsteps n (e1 :: t1, σ1) κs (t2, σ2) nsteps n (e1 :: t1, σ1) κs (t2, σ2)
world σ1 (κs ++ κs') WP e1 @ s; {{ Φ }} wptp s t1 state_interp σ1 (κs ++ κs') WP e1 @ s; {{ Φ }} wptp s t1
Nat.iter (S n) (λ P, |==> P) ( e2 t2', |={, }=>^n ( e2 t2',
t2 = e2 :: t2' world σ2 κs' WP e2 @ s; {{ Φ }} wptp s t2'). t2 = e2 :: t2' state_interp σ2 κs' WP e2 @ s; {{ Φ }} wptp s t2').
Proof. Proof.
revert e1 t1 κs κs' t2 σ1 σ2; simpl; induction n as [|n IH]=> e1 t1 κs κs' t2 σ1 σ2 /=. revert e1 t1 κs κs' t2 σ1 σ2; simpl; induction n as [|n IH]=> e1 t1 κs κs' t2 σ1 σ2 /=.
{ inversion_clear 1; iIntros "?"; eauto 10. } { inversion_clear 1; iIntros "(?&?&?)"; iExists e1, t1; iFrame; eauto 10. }
iIntros (Hsteps) "H". inversion_clear Hsteps as [|?? [t1' σ1']]. iIntros (Hsteps) "H". inversion_clear Hsteps as [|?? [t1' σ1']].
rewrite <- app_assoc. rewrite <- app_assoc.
iMod (wptp_step with "H") as (e1' t1'') "[% H]"; first by eauto; simplify_eq. iMod (wptp_step with "H") as (e1' t1'') "[% H]"; first eauto; simplify_eq.
subst. iModIntro; iNext; iMod "H" as ">H". by iApply IH. iMod "H". iModIntro; iNext. iMod "H". iModIntro.
Qed. by iApply IH.
Lemma bupd_iter_laterN_mono n P Q `{!Plain Q} :
(P Q) Nat.iter n (λ P, |==> P)%I P ^n Q.
Proof.
intros HPQ. induction n as [|n IH]=> //=. by rewrite IH bupd_plain.
Qed.
Lemma bupd_iter_frame_l n R Q :
R Nat.iter n (λ P, |==> P) Q Nat.iter n (λ P, |==> P) (R Q).
Proof.
induction n as [|n IH]; simpl; [done|].
by rewrite bupd_frame_l {1}(later_intro R) -later_sep IH.
Qed. Qed.
Lemma wptp_result s n e1 t1 κs κs' v2 t2 σ1 σ2 φ : Lemma wptp_result s n e1 t1 κs κs' v2 t2 σ1 σ2 φ :
nsteps n (e1 :: t1, σ1) κs (of_val v2 :: t2, σ2) nsteps n (e1 :: t1, σ1) κs (of_val v2 :: t2, σ2)
world σ1 (κs ++ κs') state_interp σ1 (κs ++ κs')
WP e1 @ s; {{ v, σ, state_interp σ κs' ={,}= ⌜φ v σ⌝ }} WP e1 @ s; {{ v, σ, state_interp σ κs' ={,}= ⌜φ v σ⌝ }}
wptp s t1 wptp s t1
^(S (S n)) ⌜φ v2 σ2. |={, }=>^(S n) ⌜φ v2 σ2.
Proof. Proof.
intros. rewrite wptp_steps // laterN_later. apply: bupd_iter_laterN_mono. intros. rewrite Nat_iter_S_r wptp_steps //.
iDestruct 1 as (e2 t2' ?) "((Hw & HE & Hσ) & H & _)"; simplify_eq. apply step_fupdN_mono.
iDestruct (wp_value_inv' with "H") as "H". rewrite uPred_fupd_eq. iDestruct 1 as (e2 t2' ?) "(Hσ & H & _)"; simplify_eq.
iMod ("H" with "[$]") as ">(Hw & HE & H)". iMod (wp_value_inv' with "H") as "H".
iMod ("H" with "Hσ [$]") as ">(_ & _ & $)". iMod (later_fupd_plain false (⌜φ v2 σ2)%I with "[H Hσ]") as ">#%".
{ rewrite //=. by iMod ("H" with "Hσ") as "$". }
iApply (step_fupd_mask_mono _ _ ); auto.
Qed. Qed.
Lemma wp_safe E e σ κs Φ : Lemma wp_safe E e σ κs Φ :
world' E σ κs - WP e @ E {{ Φ }} == is_Some (to_val e) reducible e σ⌝. state_interp σ κs - WP e @ E {{ Φ }} ={E, }= is_Some (to_val e) reducible e σ⌝.
Proof. Proof.
rewrite wp_unfold /wp_pre. iIntros "(Hw&HE&Hσ) H". rewrite wp_unfold /wp_pre. iIntros " H".
destruct (to_val e) as [v|] eqn:?. destruct (to_val e) as [v|] eqn:?.
{ iIntros "!> !> !%". left. by exists v. } { iApply (step_fupd_mask_mono _ _ ); eauto. set_solver. }
rewrite uPred_fupd_eq. iMod ("H" $! _ [] with "Hσ [-]") as ">(?&?&%&?)"; first by iFrame. iMod (later_fupd_plain false E (reducible e σ⌝)%I with "[H Hσ]") as ">#%".
iIntros "!> !> !%". by right. { rewrite //=. by iMod ("H" $! σ [] κs with "Hσ") as "($&H)". }
iApply step_fupd_intro; first by set_solver+.
iIntros "!> !%". by right.
Qed. Qed.
Lemma wptp_safe n e1 κs κs' e2 t1 t2 σ1 σ2 Φ : Lemma wptp_safe n e1 κs κs' e2 t1 t2 σ1 σ2 Φ :
nsteps n (e1 :: t1, σ1) κs (t2, σ2) e2 t2 nsteps n (e1 :: t1, σ1) κs (t2, σ2) e2 t2
world σ1 (κs ++ κs') WP e1 {{ Φ }} wptp NotStuck t1 state_interp σ1 (κs ++ κs') WP e1 {{ Φ }} wptp NotStuck t1
^(S (S n)) is_Some (to_val e2) reducible e2 σ2. |={, }=>^(S n) is_Some (to_val e2) reducible e2 σ2.
Proof. Proof.
intros ? He2. rewrite wptp_steps // laterN_later. apply: bupd_iter_laterN_mono. intros ? He2. rewrite Nat_iter_S_r wptp_steps //.
apply step_fupdN_mono.
iDestruct 1 as (e2' t2' ?) "(Hw & H & Htp)"; simplify_eq. iDestruct 1 as (e2' t2' ?) "(Hw & H & Htp)"; simplify_eq.
apply elem_of_cons in He2 as [<-|?]. apply elem_of_cons in He2 as [<-|?].
- iMod (wp_safe with "Hw H") as "$". - iMod (wp_safe with "Hw H") as "$"; auto.
- iMod (wp_safe with "Hw [Htp]") as "$". by iApply (big_sepL_elem_of with "Htp"). - iMod (wp_safe with "Hw [Htp]") as "$"; auto. by iApply (big_sepL_elem_of with "Htp").
Qed. Qed.
Lemma wptp_invariance s n e1 κs κs' e2 t1 t2 σ1 σ2 φ Φ : Lemma wptp_invariance s n e1 κs κs' e2 t1 t2 σ1 σ2 φ Φ :
nsteps n (e1 :: t1, σ1) κs (t2, σ2) nsteps n (e1 :: t1, σ1) κs (t2, σ2)
(state_interp σ2 κs' ={,}= ⌜φ⌝) world σ1 (κs ++ κs') WP e1 @ s; {{ Φ }} wptp s t1 (state_interp σ2 κs' ={,}= ⌜φ⌝) state_interp σ1 (κs ++ κs') WP e1 @ s; {{ Φ }} wptp s t1
^(S (S n)) ⌜φ⌝. |={, }=>^(S n) |={,}=> ⌜φ⌝.
Proof. Proof.
intros ?. rewrite wptp_steps // bupd_iter_frame_l laterN_later. intros ?. rewrite Nat_iter_S_r wptp_steps // step_fupdN_frame_l.
apply: bupd_iter_laterN_mono. apply step_fupdN_mono.
iIntros "[Hback H]"; iDestruct "H" as (e2' t2' ->) "[(Hw&HE&Hσ) _]". iIntros "[Hback H]"; iDestruct "H" as (e2' t2' ->) "[ _]".
rewrite uPred_fupd_eq. iSpecialize ("Hback" with "Hσ").
iMod ("Hback" with "Hσ [$Hw $HE]") as "> (_ & _ & $)"; auto. iApply (step_fupd_mask_mono _ _ ); auto.
Qed. Qed.
End adequacy. End adequacy.
...@@ -183,17 +146,18 @@ Theorem wp_strong_adequacy Σ Λ `{invPreG Σ} s e σ φ : ...@@ -183,17 +146,18 @@ Theorem wp_strong_adequacy Σ Λ `{invPreG Σ} s e σ φ :
Proof. Proof.
intros Hwp; split. intros Hwp; split.
- intros t2 σ2 v2 [n [κs ?]]%erased_steps_nsteps. - intros t2 σ2 v2 [n [κs ?]]%erased_steps_nsteps.
eapply (soundness (M:=iResUR Σ) _ (S (S n))). eapply (step_fupdN_soundness' _ (S (S n))).
iMod wsat_alloc as (Hinv) "[Hw HE]". specialize (Hwp _ κs). iIntros (Hinv).
rewrite {1}uPred_fupd_eq in Hwp; iMod (Hwp with "[$Hw $HE]") as ">(Hw & HE & Hwp)". rewrite Nat_iter_S.
iDestruct "Hwp" as (Istate) "[HI Hwp]". iMod Hwp as (Istate) "[HI Hwp]".
iApply (@wptp_result _ _ (IrisG _ _ _ Hinv Istate) _ _ _ _ _ []); first by eauto. iApply (step_fupd_mask_mono _ _ ); auto. iModIntro. iNext; iModIntro.