Adjust lifting lemmas for progress bits.

theories/program_logic/ectx_language.v

@@ -4,7 +4,7 @@ From iris.algebra Require Export base.
 From iris.program_logic Require Import language.
 Set Default Proof Using "Type".
 
-(* We need to make thos arguments indices that we want canonical structure
+(* We need to make those arguments indices that we want canonical structure
    inference to use a keys. *)
 Class EctxLanguage (expr val ectx state : Type) := {
   of_val : val → expr;

theories/program_logic/ectx_lifting.v

@@ -6,11 +6,13 @@ Set Default Proof Using "Type".
 Section wp.
 Context {expr val ectx state} {Λ : EctxLanguage expr val ectx state}.
 Context `{irisG (ectx_lang expr) Σ} {Hinh : Inhabited state}.
+Implicit Types p : bool.
 Implicit Types P : iProp Σ.
 Implicit Types Φ : val → iProp Σ.
 Implicit Types v : val.
 Implicit Types e : expr.
 Hint Resolve head_prim_reducible head_reducible_prim_step.
+Hint Resolve (reducible_not_val _ inhabitant).
 
 Definition head_progressive (e : expr) (σ : state) :=
   is_Some(to_val e) ∨ ∃ K e', e = fill K e' ∧ head_reducible e' σ.
@@ -25,11 +27,13 @@ Qed.
 Hint Resolve progressive_head_progressive.
 
 Lemma wp_ectx_bind {p E e} K Φ :
-  WP e @ p; E {{ v, WP fill K (of_val v) @ p; E {{ Φ }} }} ⊢ WP fill K e @ p; E {{ Φ }}.
+  WP e @ p; E {{ v, WP fill K (of_val v) @ p; E {{ Φ }} }}
+  ⊢ WP fill K e @ p; E {{ Φ }}.
 Proof. apply: weakestpre.wp_bind. Qed.
 
 Lemma wp_ectx_bind_inv {p E Φ} K e :
-  WP fill K e @ p; E {{ Φ }} ⊢ WP e @ p; E {{ v, WP fill K (of_val v) @ p; E {{ Φ }} }}.
+  WP fill K e @ p; E {{ Φ }}
+  ⊢ WP e @ p; E {{ v, WP fill K (of_val v) @ p; E {{ Φ }} }}.
 Proof. apply: weakestpre.wp_bind_inv. Qed.
 
 Lemma wp_lift_head_step {p E Φ} e1 :
@@ -41,9 +45,28 @@ Lemma wp_lift_head_step {p E Φ} e1 :
   ⊢ WP e1 @ p; E {{ Φ }}.
 Proof.
   iIntros (?) "H". iApply wp_lift_step=>//. iIntros (σ1) "Hσ".
-  iMod ("H" $! σ1 with "Hσ") as "[% H]"; iModIntro.
-  iSplit; first by eauto. iNext. iIntros (e2 σ2 efs) "%".
-  iApply "H". by eauto.
+  iMod ("H" with "Hσ") as "[% H]"; iModIntro.
+  iSplit; first by destruct p; eauto. iNext. iIntros (e2 σ2 efs) "%".
+  iApply "H"; eauto.
+Qed.
+
+(*
+  PDS: Discard. It's confusing. In practice, we just need rules
+  like wp_lift_head_{step,stuck}.
+*)
+Lemma wp_strong_lift_head_step p E Φ e1 :
+  to_val e1 = None →
+  (∀ σ1, state_interp σ1 ={E,∅}=∗
+    ⌜if p then head_reducible e1 σ1 else True⌝ ∗
+    ▷ ∀ e2 σ2 efs, ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={∅,E}=∗
+      state_interp σ2 ∗ WP e2 @ p; E {{ Φ }}
+      ∗ [∗ list] ef ∈ efs, WP ef @ p; ⊤ {{ _, True }})
+  ⊢ WP e1 @ p; E {{ Φ }}.
+Proof.
+  iIntros (?) "H". iApply wp_lift_step=>//. iIntros (σ1) "Hσ".
+  iMod ("H" with "Hσ") as "[% H]"; iModIntro.
+  iSplit; first by destruct p; eauto. iNext. iIntros (e2 σ2 efs) "%".
+  iApply "H"; eauto.
 Qed.
 
 Lemma wp_lift_head_stuck E Φ e :
@@ -52,7 +75,7 @@ Lemma wp_lift_head_stuck E Φ e :
   ⊢ WP e @ E ?{{ Φ }}.
 Proof.
   iIntros (?) "H". iApply wp_lift_stuck; first done.
-  iIntros (σ) "Hσ". iMod ("H" $! _ with "Hσ") as "%". iModIntro. by auto.
+  iIntros (σ) "Hσ". iMod ("H" with "Hσ") as "%". by auto. 
 Qed.
 
 Lemma wp_lift_pure_head_step {p E E' Φ} e1 :
@@ -63,42 +86,71 @@ Lemma wp_lift_pure_head_step {p E E' Φ} e1 :
   ⊢ WP e1 @ p; E {{ Φ }}.
 Proof using Hinh.
   iIntros (??) "H". iApply wp_lift_pure_step; eauto.
+  { by destruct p; auto. }
   iApply (step_fupd_wand with "H"); iIntros "H".
   iIntros (????). iApply "H"; eauto.
 Qed.
 
-Lemma wp_lift_pure_head_stuck `{Inhabited state} E Φ e :
+(* PDS: Discard. *)
+Lemma wp_strong_lift_pure_head_step p E Φ e1 :
+  to_val e1 = None →
+  (∀ σ1, if p then head_reducible e1 σ1 else True) →
+  (∀ σ1 e2 σ2 efs, prim_step e1 σ1 e2 σ2 efs → σ1 = σ2) →
+  (▷ ∀ e2 efs σ, ⌜prim_step e1 σ e2 σ efs⌝ →
+    WP e2 @ p; E {{ Φ }} ∗ [∗ list] ef ∈ efs, WP ef @ p; ⊤ {{ _, True }})
+  ⊢ WP e1 @ p; E {{ Φ }}.
+Proof using Hinh.
+  iIntros (???) "H". iApply wp_lift_pure_step; eauto. by destruct p; auto.
+Qed.
+
+Lemma wp_lift_pure_head_stuck E Φ e :
   to_val e = None →
   (∀ K e1 σ1 e2 σ2 efs, e = fill K e1 → ¬ head_step e1 σ1 e2 σ2 efs) →
   WP e @ E ?{{ Φ }}%I.
-Proof.
+Proof using Hinh.
   iIntros (Hnv Hnstep). iApply wp_lift_head_stuck; first done.
   iIntros (σ) "_". iMod (fupd_intro_mask' E ∅) as "_"; first set_solver.
   iModIntro. iPureIntro. case; first by rewrite Hnv; case.
   move=>[] K [] e1 [] Hfill [] e2 [] σ2 [] efs /= Hstep. exact: Hnstep.
 Qed.
 
-Lemma wp_lift_atomic_head_step {p E Φ} e1 :
+Lemma wp_lift_atomic_head_step {E Φ} e1 :
   to_val e1 = None →
   (∀ σ1, state_interp σ1 ={E}=∗
     ⌜head_reducible e1 σ1⌝ ∗
     ▷ ∀ e2 σ2 efs, ⌜head_step e1 σ1 e2 σ2 efs⌝ ={E}=∗
       state_interp σ2 ∗
-      default False (to_val e2) Φ ∗ [∗ list] ef ∈ efs, WP ef @ p; ⊤ {{ _, True }})
-  ⊢ WP e1 @ p; E {{ Φ }}.
+      default False (to_val e2) Φ ∗ [∗ list] ef ∈ efs, WP ef {{ _, True }})
+  ⊢ WP e1 @ E {{ Φ }}.
 Proof.
   iIntros (?) "H". iApply wp_lift_atomic_step; eauto.
   iIntros (σ1) "Hσ1". iMod ("H" $! σ1 with "Hσ1") as "[% H]"; iModIntro.
   iSplit; first by eauto. iNext. iIntros (e2 σ2 efs) "%". iApply "H"; auto.
 Qed.
 
-Lemma wp_lift_atomic_head_step_no_fork {p E Φ} e1 :
+(* PDS: Discard. *)
+Lemma wp_strong_lift_atomic_head_step {p E Φ} e1 :
+  to_val e1 = None →
+  (∀ σ1, state_interp σ1 ={E}=∗
+    ⌜if p then head_reducible e1 σ1 else True⌝ ∗
+    ▷ ∀ e2 σ2 efs, ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={E}=∗
+      state_interp σ2 ∗ default False (to_val e2) Φ
+      ∗ [∗ list] ef ∈ efs, WP ef @ p; ⊤ {{ _, True }})
+  ⊢ WP e1 @ p; E {{ Φ }}.
+Proof.
+  iIntros (?) "H". iApply wp_lift_atomic_step; eauto.
+  iIntros (σ1) "Hσ1". iMod ("H" $! σ1 with "Hσ1") as "[% H]"; iModIntro.
+  iSplit; first by destruct p; eauto.
+  by iNext; iIntros (e2 σ2 efs ?); iApply "H"; eauto.
+Qed.
+
+Lemma wp_lift_atomic_head_step_no_fork {E Φ} e1 :
   to_val e1 = None →
   (∀ σ1, state_interp σ1 ={E}=∗
     ⌜head_reducible e1 σ1⌝ ∗
     ▷ ∀ e2 σ2 efs, ⌜head_step e1 σ1 e2 σ2 efs⌝ ={E}=∗
       ⌜efs = []⌝ ∗ state_interp σ2 ∗ default False (to_val e2) Φ)
-  ⊢ WP e1 @ p; E {{ Φ }}.
+  ⊢ WP e1 @ E {{ Φ }}.
 Proof.
   iIntros (?) "H". iApply wp_lift_atomic_head_step; eauto.
   iIntros (σ1) "Hσ1". iMod ("H" $! σ1 with "Hσ1") as "[$ H]"; iModIntro.
@@ -106,13 +158,45 @@ Proof.
   iMod ("H" $! v2 σ2 efs with "[# //]") as "(% & $ & $)"; subst; auto.
 Qed.
 
+(* PDS: Discard. *)
+Lemma wp_strong_lift_atomic_head_step_no_fork {p E Φ} e1 :
+  to_val e1 = None →
+  (∀ σ1, state_interp σ1 ={E}=∗
+    ⌜if p then head_reducible e1 σ1 else True⌝ ∗
+    ▷ ∀ e2 σ2 efs, ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={E}=∗
+      ⌜efs = []⌝ ∗ state_interp σ2 ∗ default False (to_val e2) Φ)
+  ⊢ WP e1 @ p; E {{ Φ }}.
+Proof.
+  iIntros (?) "H". iApply wp_strong_lift_atomic_head_step; eauto.
+  iIntros (σ1) "Hσ1". iMod ("H" with "Hσ1") as "[$ H]"; iModIntro.
+  iNext; iIntros (v2 σ2 efs) "%".
+  iMod ("H" with "[#]") as "(% & $ & $)"=>//; subst.
+  by iApply big_sepL_nil.
+Qed.
+
 Lemma wp_lift_pure_det_head_step {p E E' Φ} e1 e2 efs :
   (∀ σ1, head_reducible e1 σ1) →
   (∀ σ1 e2' σ2 efs',
     head_step e1 σ1 e2' σ2 efs' → σ1 = σ2 ∧ e2 = e2' ∧ efs = efs') →
   (|={E,E'}▷=> WP e2 @ p; E {{ Φ }} ∗ [∗ list] ef ∈ efs, WP ef @ p; ⊤ {{ _, True }})
   ⊢ WP e1 @ p; E {{ Φ }}.
-Proof using Hinh. eauto using wp_lift_pure_det_step. Qed.
+Proof using Hinh.
+  intros. rewrite -(wp_lift_pure_det_step e1 e2 efs); eauto.
+  destruct p; by auto.
+Qed.
+
+(* PDS: Discard. *)
+Lemma wp_strong_lift_pure_det_head_step {p E Φ} e1 e2 efs :
+  to_val e1 = None →
+  (∀ σ1, if p then head_reducible e1 σ1 else True) →
+  (∀ σ1 e2' σ2 efs',
+    prim_step e1 σ1 e2' σ2 efs' → σ1 = σ2 ∧ e2 = e2' ∧ efs = efs') →
+  ▷ (WP e2 @ p; E {{ Φ }} ∗ [∗ list] ef ∈ efs, WP ef @ p; ⊤ {{ _, True }})
+  ⊢ WP e1 @ p; E {{ Φ }}.
+Proof using Hinh.
+  iIntros (???) "H"; iApply wp_lift_pure_det_step; eauto.
+  by destruct p; eauto.
+Qed.
 
 Lemma wp_lift_pure_det_head_step_no_fork {p E E' Φ} e1 e2 :
   to_val e1 = None →
@@ -122,6 +206,7 @@ Lemma wp_lift_pure_det_head_step_no_fork {p E E' Φ} e1 e2 :
   (|={E,E'}▷=> WP e2 @ p; E {{ Φ }}) ⊢ WP e1 @ p; E {{ Φ }}.
 Proof using Hinh.
   intros. rewrite -(wp_lift_pure_det_step e1 e2 []) /= ?right_id; eauto.
+  destruct p; by auto.
 Qed.
 
 Lemma wp_lift_pure_det_head_step_no_fork' {p E Φ} e1 e2 :
@@ -129,9 +214,21 @@ Lemma wp_lift_pure_det_head_step_no_fork' {p E Φ} e1 e2 :
   (∀ σ1, head_reducible e1 σ1) →
   (∀ σ1 e2' σ2 efs',
     head_step e1 σ1 e2' σ2 efs' → σ1 = σ2 ∧ e2 = e2' ∧ [] = efs') →
-  ▷ WP e2 @ p; E {{ Φ }} ⊢ WP e1 @ p; E {{ Φ }}.
+  ▷ WP e2 @ E {{ Φ }} ⊢ WP e1 @ E {{ Φ }}.
 Proof using Hinh.
-  intros. rewrite -[(WP e1 @ _; _ {{ _ }})%I]wp_lift_pure_det_head_step_no_fork //.
+  intros. rewrite -[(WP e1 @ _ {{ _ }})%I]wp_lift_pure_det_head_step_no_fork //.
   rewrite -step_fupd_intro //.
 Qed.
+
+(* PDS: Discard. *)
+Lemma wp_strong_lift_pure_det_head_step_no_fork {p E Φ} e1 e2 :
+  to_val e1 = None →
+  (∀ σ1, if p then head_reducible e1 σ1 else True) →
+  (∀ σ1 e2' σ2 efs',
+    prim_step e1 σ1 e2' σ2 efs' → σ1 = σ2 ∧ e2 = e2' ∧ [] = efs') →
+  ▷ WP e2 @ p; E {{ Φ }} ⊢ WP e1 @ p; E {{ Φ }}.
+Proof using Hinh.
+  intros. rewrite -(wp_lift_pure_det_step e1 e2 []) ?big_sepL_nil ?right_id; eauto.
+  by destruct p; eauto.
+Qed.
 End wp.

theories/program_logic/ectxi_language.v

@@ -4,7 +4,7 @@ From iris.algebra Require Export base.
 From iris.program_logic Require Import language ectx_language.
 Set Default Proof Using "Type".
 
-(* We need to make thos arguments indices that we want canonical structure
+(* We need to make those arguments indices that we want canonical structure
    inference to use a keys. *)
 Class EctxiLanguage (expr val ectx_item state : Type) := {
   of_val : val → expr;

theories/program_logic/lifting.v

@@ -5,6 +5,7 @@ Set Default Proof Using "Type".
 
 Section lifting.
 Context `{irisG Λ Σ}.
+Implicit Types p : bool.
 Implicit Types v : val Λ.
 Implicit Types e : expr Λ.
 Implicit Types σ : state Λ.
@@ -14,7 +15,7 @@ Implicit Types Φ : val Λ → iProp Σ.
 Lemma wp_lift_step p E Φ e1 :
   to_val e1 = None →
   (∀ σ1, state_interp σ1 ={E,∅}=∗
-    ⌜reducible e1 σ1⌝ ∗
+    ⌜if p then reducible e1 σ1 else True⌝ ∗
     ▷ ∀ e2 σ2 efs, ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={∅,E}=∗
       state_interp σ2 ∗ WP e2 @ p; E {{ Φ }} ∗ [∗ list] ef ∈ efs, WP ef @ p; ⊤ {{ _, True }})
   ⊢ WP e1 @ p; E {{ Φ }}.
@@ -36,17 +37,17 @@ Qed.
 
 (** Derived lifting lemmas. *)
 Lemma wp_lift_pure_step `{Inhabited (state Λ)} p E E' Φ e1 :
-  (∀ σ1, reducible e1 σ1) →
+  to_val e1 = None →
+  (∀ σ1, if p then reducible e1 σ1 else True) →
   (∀ σ1 e2 σ2 efs, prim_step e1 σ1 e2 σ2 efs → σ1 = σ2) →
   (|={E,E'}▷=> ∀ e2 efs σ, ⌜prim_step e1 σ e2 σ efs⌝ →
     WP e2 @ p; E {{ Φ }} ∗ [∗ list] ef ∈ efs, WP ef @ p; ⊤ {{ _, True }})
   ⊢ WP e1 @ p; E {{ Φ }}.
 Proof.
-  iIntros (Hsafe Hstep) "H". iApply wp_lift_step.
-  { eapply reducible_not_val, (Hsafe inhabitant). }
+  iIntros (? Hsafe Hstep) "H". iApply wp_lift_step; first done.
   iIntros (σ1) "Hσ". iMod "H".
-  iMod fupd_intro_mask' as "Hclose"; last iModIntro; first set_solver.
-  iSplit; [done|]; iNext; iIntros (e2 σ2 efs ?).
+  iMod fupd_intro_mask' as "Hclose"; last iModIntro; first by set_solver.
+  iSplit; first by iPureIntro; apply Hsafe. iNext. iIntros (e2 σ2 efs ?).
   destruct (Hstep σ1 e2 σ2 efs); auto; subst.
   iMod "Hclose" as "_". iFrame "Hσ". iMod "H". iApply "H"; auto.
 Qed.
@@ -67,7 +68,7 @@ Qed.
 Lemma wp_lift_atomic_step {p E Φ} e1 :
   to_val e1 = None →
   (∀ σ1, state_interp σ1 ={E}=∗
-    ⌜reducible e1 σ1⌝ ∗
+    ⌜if p then reducible e1 σ1 else True⌝ ∗
     ▷ ∀ e2 σ2 efs, ⌜prim_step e1 σ1 e2 σ2 efs⌝ ={E}=∗
       state_interp σ2 ∗
       default False (to_val e2) Φ ∗ [∗ list] ef ∈ efs, WP ef @ p; ⊤ {{ _, True }})
@@ -83,12 +84,13 @@ Proof.
 Qed.
 
 Lemma wp_lift_pure_det_step `{Inhabited (state Λ)} {p E E' Φ} e1 e2 efs :
-  (∀ σ1, reducible e1 σ1) →
+  to_val e1 = None →
+  (∀ σ1, if p then reducible e1 σ1 else true) →
   (∀ σ1 e2' σ2 efs', prim_step e1 σ1 e2' σ2 efs' → σ1 = σ2 ∧ e2 = e2' ∧ efs = efs')→
   (|={E,E'}▷=> WP e2 @ p; E {{ Φ }} ∗ [∗ list] ef ∈ efs, WP ef @ p; ⊤ {{ _, True }})
   ⊢ WP e1 @ p; E {{ Φ }}.
 Proof.
-  iIntros (? Hpuredet) "H". iApply (wp_lift_pure_step p E); try done.
+  iIntros (?? Hpuredet) "H". iApply (wp_lift_pure_step p E E'); try done.
   { by intros; eapply Hpuredet. }
   iApply (step_fupd_wand with "H"); iIntros "H".
   by iIntros (e' efs' σ (_&->&->)%Hpuredet).
@@ -100,8 +102,9 @@ Lemma wp_pure_step_fupd `{Inhabited (state Λ)} E E' e1 e2 φ Φ :
   (|={E,E'}▷=> WP e2 @ E {{ Φ }}) ⊢ WP e1 @ E {{ Φ }}.
 Proof.
   iIntros ([??] Hφ) "HWP".
-  iApply (wp_lift_pure_det_step with "[HWP]"); [eauto|naive_solver|].
-  rewrite big_sepL_nil right_id //.
+  iApply (wp_lift_pure_det_step with "[HWP]"); [|naive_solver|naive_solver|].
+  - apply (reducible_not_val _ inhabitant). by auto.
+  - by rewrite big_sepL_nil right_id.
 Qed.
 
 Lemma wp_pure_step_later `{Inhabited (state Λ)} E e1 e2 φ Φ :