Commit ebf06f91 authored by Robbert Krebbers's avatar Robbert Krebbers

Fine-grained post-conditions for forked-off threads.

This commit extends the state interpretation with an additional parameter to
talk about the number of forked-off threads, and a fixed postcondition for each
forked-off thread:

    state_interp : Λstate → list Λobservation → nat → iProp Σ;
    fork_post : iProp Σ;

This way, instead of having `True` as the post-condition of `Fork`, one can
have any post-condition, which is then recorded in the state interpretation.
The point of keeping track of the postconditions of forked-off threads, is that
we get an (additional) stronger adequacy theorem:

    Theorem wp_strong_all_adequacy Σ Λ `{invPreG Σ} s e σ1 v vs σ2 φ :
       (∀ `{Hinv : invG Σ} κs,
         (|={⊤}=> ∃
             (stateI : state Λ → list (observation Λ) → nat → iProp Σ)
             (fork_post : iProp Σ),
           let _ : irisG Λ Σ := IrisG _ _ _ Hinv stateI fork_post in
           stateI σ1 κs 0 ∗ WP e @ s; ⊤ {{ v,
             let m := length vs in
             stateI σ2 [] m -∗ [∗] replicate m fork_post ={⊤,∅}=∗ ⌜ φ v ⌝ }})%I) →
      rtc erased_step ([e], σ1) (of_val <$> v :: vs, σ2) →
      φ v.

The difference with the ordinary adequacy theorem is that this one only applies
once all threads terminated. In this case, one gets back the post-conditions
`[∗] replicate m fork_post` of all forked-off threads.

In Iron we showed that we can use this mechanism to make sure that all
resources are disposed of properly in the presence of fork-based concurrency.
parent b0e4b6fa
...@@ -16,8 +16,9 @@ Class heapG Σ := HeapG { ...@@ -16,8 +16,9 @@ Class heapG Σ := HeapG {
Instance heapG_irisG `{heapG Σ} : irisG heap_lang Σ := { Instance heapG_irisG `{heapG Σ} : irisG heap_lang Σ := {
iris_invG := heapG_invG; iris_invG := heapG_invG;
state_interp σ κs := state_interp σ κs _ :=
(gen_heap_ctx σ.(heap) proph_map_ctx κs σ.(used_proph_id))%I (gen_heap_ctx σ.(heap) proph_map_ctx κs σ.(used_proph_id))%I;
fork_post := True%I;
}. }.
(** Override the notations so that scopes and coercions work out *) (** Override the notations so that scopes and coercions work out *)
...@@ -162,7 +163,7 @@ Lemma wp_fork s E e Φ : ...@@ -162,7 +163,7 @@ Lemma wp_fork s E e Φ :
WP e @ s; {{ _, True }} - Φ (LitV LitUnit) - WP Fork e @ s; E {{ Φ }}. WP e @ s; {{ _, True }} - Φ (LitV LitUnit) - WP Fork e @ s; E {{ Φ }}.
Proof. Proof.
iIntros "He HΦ". iIntros "He HΦ".
iApply wp_lift_pure_det_head_step; [by eauto|intros; inv_head_step; by eauto|]. iApply wp_lift_pure_det_head_step; [done|auto|intros; inv_head_step; eauto|].
iModIntro; iNext; iIntros "!> /= {$He}". by iApply wp_value. iModIntro; iNext; iIntros "!> /= {$He}". by iApply wp_value.
Qed. Qed.
...@@ -170,7 +171,7 @@ Lemma twp_fork s E e Φ : ...@@ -170,7 +171,7 @@ Lemma twp_fork s E e Φ :
WP e @ s; [{ _, True }] - Φ (LitV LitUnit) - WP Fork e @ s; E [{ Φ }]. WP e @ s; [{ _, True }] - Φ (LitV LitUnit) - WP Fork e @ s; E [{ Φ }].
Proof. Proof.
iIntros "He HΦ". iIntros "He HΦ".
iApply twp_lift_pure_det_head_step; [eauto|intros; inv_head_step; eauto|]. iApply twp_lift_pure_det_head_step; [done|auto|intros; inv_head_step; eauto|].
iIntros "!> /= {$He}". by iApply twp_value. iIntros "!> /= {$He}". by iApply twp_value.
Qed. Qed.
...@@ -179,7 +180,7 @@ Lemma wp_alloc s E v : ...@@ -179,7 +180,7 @@ Lemma wp_alloc s E v :
{{{ True }}} Alloc (Val v) @ s; E {{{ l, RET LitV (LitLoc l); l v }}}. {{{ True }}} Alloc (Val v) @ s; E {{{ l, RET LitV (LitLoc l); l v }}}.
Proof. Proof.
iIntros (Φ) "_ HΦ". iApply wp_lift_atomic_head_step_no_fork; auto. iIntros (Φ) "_ HΦ". iApply wp_lift_atomic_head_step_no_fork; auto.
iIntros (σ1 κ κs) "[Hσ Hκs] !>"; iSplit; first by auto. iIntros (σ1 κ κs n) "[Hσ Hκs] !>"; iSplit; first by auto.
iNext; iIntros (v2 σ2 efs Hstep); inv_head_step. iNext; iIntros (v2 σ2 efs Hstep); inv_head_step.
iMod (@gen_heap_alloc with "Hσ") as "[Hσ Hl]"; first done. iMod (@gen_heap_alloc with "Hσ") as "[Hσ Hl]"; first done.
iModIntro; iSplit=> //. iFrame. by iApply "HΦ". iModIntro; iSplit=> //. iFrame. by iApply "HΦ".
...@@ -188,7 +189,7 @@ Lemma twp_alloc s E v : ...@@ -188,7 +189,7 @@ Lemma twp_alloc s E v :
[[{ True }]] Alloc (Val v) @ s; E [[{ l, RET LitV (LitLoc l); l v }]]. [[{ True }]] Alloc (Val v) @ s; E [[{ l, RET LitV (LitLoc l); l v }]].
Proof. Proof.
iIntros (Φ) "_ HΦ". iApply twp_lift_atomic_head_step_no_fork; auto. iIntros (Φ) "_ HΦ". iApply twp_lift_atomic_head_step_no_fork; auto.
iIntros (σ1 κs) "[Hσ Hκs] !>"; iSplit; first by eauto. iIntros (σ1 κs n) "[Hσ Hκs] !>"; iSplit; first by auto.
iIntros (κ v2 σ2 efs Hstep); inv_head_step. iIntros (κ v2 σ2 efs Hstep); inv_head_step.
iMod (@gen_heap_alloc with "Hσ") as "[Hσ Hl]"; first done. iMod (@gen_heap_alloc with "Hσ") as "[Hσ Hl]"; first done.
iModIntro; iSplit=> //. iSplit; first done. iFrame. by iApply "HΦ". iModIntro; iSplit=> //. iSplit; first done. iFrame. by iApply "HΦ".
...@@ -198,7 +199,7 @@ Lemma wp_load s E l q v : ...@@ -198,7 +199,7 @@ Lemma wp_load s E l q v :
{{{ l {q} v }}} Load (Val $ LitV $ LitLoc l) @ s; E {{{ RET v; l {q} v }}}. {{{ l {q} v }}} Load (Val $ LitV $ LitLoc l) @ s; E {{{ RET v; l {q} v }}}.
Proof. Proof.
iIntros (Φ) ">Hl HΦ". iApply wp_lift_atomic_head_step_no_fork; auto. iIntros (Φ) ">Hl HΦ". iApply wp_lift_atomic_head_step_no_fork; auto.
iIntros (σ1 κ κs) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?. iIntros (σ1 κ κs n) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
iSplit; first by eauto. iNext; iIntros (v2 σ2 efs Hstep); inv_head_step. iSplit; first by eauto. iNext; iIntros (v2 σ2 efs Hstep); inv_head_step.
iModIntro; iSplit=> //. iFrame. by iApply "HΦ". iModIntro; iSplit=> //. iFrame. by iApply "HΦ".
Qed. Qed.
...@@ -206,7 +207,7 @@ Lemma twp_load s E l q v : ...@@ -206,7 +207,7 @@ Lemma twp_load s E l q v :
[[{ l {q} v }]] Load (Val $ LitV $ LitLoc l) @ s; E [[{ RET v; l {q} v }]]. [[{ l {q} v }]] Load (Val $ LitV $ LitLoc l) @ s; E [[{ RET v; l {q} v }]].
Proof. Proof.
iIntros (Φ) "Hl HΦ". iApply twp_lift_atomic_head_step_no_fork; auto. iIntros (Φ) "Hl HΦ". iApply twp_lift_atomic_head_step_no_fork; auto.
iIntros (σ1 κs) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?. iIntros (σ1 κs n) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
iSplit; first by eauto. iIntros (κ v2 σ2 efs Hstep); inv_head_step. iSplit; first by eauto. iIntros (κ v2 σ2 efs Hstep); inv_head_step.
iModIntro; iSplit=> //. iSplit; first done. iFrame. by iApply "HΦ". iModIntro; iSplit=> //. iSplit; first done. iFrame. by iApply "HΦ".
Qed. Qed.
...@@ -217,7 +218,7 @@ Lemma wp_store s E l v' v : ...@@ -217,7 +218,7 @@ Lemma wp_store s E l v' v :
Proof. Proof.
iIntros (Φ) ">Hl HΦ". iIntros (Φ) ">Hl HΦ".
iApply wp_lift_atomic_head_step_no_fork; auto. iApply wp_lift_atomic_head_step_no_fork; auto.
iIntros (σ1 κ κs) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?. iIntros (σ1 κ κs n) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
iSplit; first by eauto. iNext; iIntros (v2 σ2 efs Hstep); inv_head_step. iSplit; first by eauto. iNext; iIntros (v2 σ2 efs Hstep); inv_head_step.
iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]". iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
iModIntro. iSplit=>//. iFrame. by iApply "HΦ". iModIntro. iSplit=>//. iFrame. by iApply "HΦ".
...@@ -228,7 +229,7 @@ Lemma twp_store s E l v' v : ...@@ -228,7 +229,7 @@ Lemma twp_store s E l v' v :
Proof. Proof.
iIntros (Φ) "Hl HΦ". iIntros (Φ) "Hl HΦ".
iApply twp_lift_atomic_head_step_no_fork; auto. iApply twp_lift_atomic_head_step_no_fork; auto.
iIntros (σ1 κs) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?. iIntros (σ1 κs n) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
iSplit; first by eauto. iIntros (κ v2 σ2 efs Hstep); inv_head_step. iSplit; first by eauto. iIntros (κ v2 σ2 efs Hstep); inv_head_step.
iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]". iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
iModIntro. iSplit=>//. iSplit; first done. iFrame. by iApply "HΦ". iModIntro. iSplit=>//. iSplit; first done. iFrame. by iApply "HΦ".
...@@ -240,7 +241,7 @@ Lemma wp_cas_fail s E l q v' v1 v2 : ...@@ -240,7 +241,7 @@ Lemma wp_cas_fail s E l q v' v1 v2 :
{{{ RET LitV (LitBool false); l {q} v' }}}. {{{ RET LitV (LitBool false); l {q} v' }}}.
Proof. Proof.
iIntros (?? Φ) ">Hl HΦ". iApply wp_lift_atomic_head_step_no_fork; auto. iIntros (?? Φ) ">Hl HΦ". iApply wp_lift_atomic_head_step_no_fork; auto.
iIntros (σ1 κ κs) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?. iIntros (σ1 κ κs n) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
iSplit; first by eauto. iNext; iIntros (v2' σ2 efs Hstep); inv_head_step. iSplit; first by eauto. iNext; iIntros (v2' σ2 efs Hstep); inv_head_step.
iModIntro; iSplit=> //. iFrame. by iApply "HΦ". iModIntro; iSplit=> //. iFrame. by iApply "HΦ".
Qed. Qed.
...@@ -250,7 +251,7 @@ Lemma twp_cas_fail s E l q v' v1 v2 : ...@@ -250,7 +251,7 @@ Lemma twp_cas_fail s E l q v' v1 v2 :
[[{ RET LitV (LitBool false); l {q} v' }]]. [[{ RET LitV (LitBool false); l {q} v' }]].
Proof. Proof.
iIntros (?? Φ) "Hl HΦ". iApply twp_lift_atomic_head_step_no_fork; auto. iIntros (?? Φ) "Hl HΦ". iApply twp_lift_atomic_head_step_no_fork; auto.
iIntros (σ1 κs) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?. iIntros (σ1 κs n) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
iSplit; first by eauto. iIntros (κ v2' σ2 efs Hstep); inv_head_step. iSplit; first by eauto. iIntros (κ v2' σ2 efs Hstep); inv_head_step.
iModIntro; iSplit=> //. iSplit; first done. iFrame. by iApply "HΦ". iModIntro; iSplit=> //. iSplit; first done. iFrame. by iApply "HΦ".
Qed. Qed.
...@@ -261,7 +262,7 @@ Lemma wp_cas_suc s E l v1 v2 : ...@@ -261,7 +262,7 @@ Lemma wp_cas_suc s E l v1 v2 :
{{{ RET LitV (LitBool true); l v2 }}}. {{{ RET LitV (LitBool true); l v2 }}}.
Proof. Proof.
iIntros (? Φ) ">Hl HΦ". iApply wp_lift_atomic_head_step_no_fork; auto. iIntros (? Φ) ">Hl HΦ". iApply wp_lift_atomic_head_step_no_fork; auto.
iIntros (σ1 κ κs) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?. iIntros (σ1 κ κs n) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
iSplit; first by eauto. iNext; iIntros (v2' σ2 efs Hstep); inv_head_step. iSplit; first by eauto. iNext; iIntros (v2' σ2 efs Hstep); inv_head_step.
iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]". iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
iModIntro. iSplit=>//. iFrame. by iApply "HΦ". iModIntro. iSplit=>//. iFrame. by iApply "HΦ".
...@@ -272,7 +273,7 @@ Lemma twp_cas_suc s E l v1 v2 : ...@@ -272,7 +273,7 @@ Lemma twp_cas_suc s E l v1 v2 :
[[{ RET LitV (LitBool true); l v2 }]]. [[{ RET LitV (LitBool true); l v2 }]].
Proof. Proof.
iIntros (? Φ) "Hl HΦ". iApply twp_lift_atomic_head_step_no_fork; auto. iIntros (? Φ) "Hl HΦ". iApply twp_lift_atomic_head_step_no_fork; auto.
iIntros (σ1 κs) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?. iIntros (σ1 κs n) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
iSplit; first by eauto. iIntros (κ v2' σ2 efs Hstep); inv_head_step. iSplit; first by eauto. iIntros (κ v2' σ2 efs Hstep); inv_head_step.
iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]". iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
iModIntro. iSplit=>//. iSplit; first done. iFrame. by iApply "HΦ". iModIntro. iSplit=>//. iSplit; first done. iFrame. by iApply "HΦ".
...@@ -283,7 +284,7 @@ Lemma wp_faa s E l i1 i2 : ...@@ -283,7 +284,7 @@ Lemma wp_faa s E l i1 i2 :
{{{ RET LitV (LitInt i1); l LitV (LitInt (i1 + i2)) }}}. {{{ RET LitV (LitInt i1); l LitV (LitInt (i1 + i2)) }}}.
Proof. Proof.
iIntros (Φ) ">Hl HΦ". iApply wp_lift_atomic_head_step_no_fork; auto. iIntros (Φ) ">Hl HΦ". iApply wp_lift_atomic_head_step_no_fork; auto.
iIntros (σ1 κ κs) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?. iIntros (σ1 κ κs n) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
iSplit; first by eauto. iNext; iIntros (v2' σ2 efs Hstep); inv_head_step. iSplit; first by eauto. iNext; iIntros (v2' σ2 efs Hstep); inv_head_step.
iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]". iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
iModIntro. iSplit=>//. iFrame. by iApply "HΦ". iModIntro. iSplit=>//. iFrame. by iApply "HΦ".
...@@ -293,7 +294,7 @@ Lemma twp_faa s E l i1 i2 : ...@@ -293,7 +294,7 @@ Lemma twp_faa s E l i1 i2 :
[[{ RET LitV (LitInt i1); l LitV (LitInt (i1 + i2)) }]]. [[{ RET LitV (LitInt i1); l LitV (LitInt (i1 + i2)) }]].
Proof. Proof.
iIntros (Φ) "Hl HΦ". iApply twp_lift_atomic_head_step_no_fork; auto. iIntros (Φ) "Hl HΦ". iApply twp_lift_atomic_head_step_no_fork; auto.
iIntros (σ1 κs) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?. iIntros (σ1 κs n) "[Hσ Hκs] !>". iDestruct (@gen_heap_valid with "Hσ Hl") as %?.
iSplit; first by eauto. iIntros (κ e2 σ2 efs Hstep); inv_head_step. iSplit; first by eauto. iIntros (κ e2 σ2 efs Hstep); inv_head_step.
iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]". iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
iModIntro. iSplit=>//. iSplit; first done. iFrame. by iApply "HΦ". iModIntro. iSplit=>//. iSplit; first done. iFrame. by iApply "HΦ".
...@@ -304,7 +305,7 @@ Lemma wp_new_proph : ...@@ -304,7 +305,7 @@ Lemma wp_new_proph :
{{{ True }}} NewProph {{{ v (p : proph_id), RET (LitV (LitProphecy p)); proph p v }}}. {{{ True }}} NewProph {{{ v (p : proph_id), RET (LitV (LitProphecy p)); proph p v }}}.
Proof. Proof.
iIntros (Φ) "_ HΦ". iApply wp_lift_atomic_head_step_no_fork; auto. iIntros (Φ) "_ HΦ". iApply wp_lift_atomic_head_step_no_fork; auto.
iIntros (σ1 κ κs) "[Hσ HR] !>". iDestruct "HR" as (R [Hfr Hdom]) "HR". iIntros (σ1 κ κs n) "[Hσ HR] !>". iDestruct "HR" as (R [Hfr Hdom]) "HR".
iSplit; first by eauto. iSplit; first by eauto.
iNext; iIntros (v2 σ2 efs Hstep). inv_head_step. iNext; iIntros (v2 σ2 efs Hstep). inv_head_step.
iMod (@proph_map_alloc with "HR") as "[HR Hp]". iMod (@proph_map_alloc with "HR") as "[HR Hp]".
...@@ -323,7 +324,7 @@ Lemma wp_resolve_proph p v w: ...@@ -323,7 +324,7 @@ Lemma wp_resolve_proph p v w:
{{{ RET (LitV LitUnit); v = Some w }}}. {{{ RET (LitV LitUnit); v = Some w }}}.
Proof. Proof.
iIntros (Φ) "Hp HΦ". iApply wp_lift_atomic_head_step_no_fork; auto. iIntros (Φ) "Hp HΦ". iApply wp_lift_atomic_head_step_no_fork; auto.
iIntros (σ1 κ κs) "[Hσ HR] !>". iDestruct "HR" as (R [Hfr Hdom]) "HR". iIntros (σ1 κ κs n) "[Hσ HR] !>". iDestruct "HR" as (R [Hfr Hdom]) "HR".
iDestruct (@proph_map_valid with "HR Hp") as %Hlookup. iDestruct (@proph_map_valid with "HR Hp") as %Hlookup.
iSplit; first by eauto. iSplit; first by eauto.
iNext; iIntros (v2 σ2 efs Hstep); inv_head_step. iApply fupd_frame_l. iNext; iIntros (v2 σ2 efs Hstep); inv_head_step. iApply fupd_frame_l.
...@@ -331,8 +332,7 @@ Proof. ...@@ -331,8 +332,7 @@ Proof.
iMod (@proph_map_remove with "HR Hp") as "Hp". iModIntro. iMod (@proph_map_remove with "HR Hp") as "Hp". iModIntro.
iSplitR "HΦ". iSplitR "HΦ".
- iExists _. iFrame. iPureIntro. split; first by eapply first_resolve_delete. - iExists _. iFrame. iPureIntro. split; first by eapply first_resolve_delete.
rewrite dom_delete. rewrite <- difference_empty_L. by eapply difference_mono. rewrite dom_delete. set_solver.
- iApply "HΦ". iPureIntro. by eapply first_resolve_eq. - iApply "HΦ". iPureIntro. by eapply first_resolve_eq.
Qed. Qed.
End lifting. End lifting.
...@@ -12,6 +12,8 @@ Proof. ...@@ -12,6 +12,8 @@ Proof.
iMod (gen_heap_init σ.(heap)) as (?) "Hh". iMod (gen_heap_init σ.(heap)) as (?) "Hh".
iMod (proph_map_init [] σ.(used_proph_id)) as (?) "Hp". iMod (proph_map_init [] σ.(used_proph_id)) as (?) "Hp".
iModIntro. iModIntro.
iExists (λ σ κs, (gen_heap_ctx σ.(heap) proph_map_ctx κs σ.(used_proph_id))%I). iFrame. iExists
(λ σ κs _, (gen_heap_ctx σ.(heap) proph_map_ctx κs σ.(used_proph_id))%I),
True%I; iFrame.
iApply (Hwp (HeapG _ _ _ _)). iApply (Hwp (HeapG _ _ _ _)).
Qed. Qed.
This diff is collapsed.
...@@ -16,48 +16,53 @@ Hint Resolve head_stuck_stuck. ...@@ -16,48 +16,53 @@ Hint Resolve head_stuck_stuck.
Lemma wp_lift_head_step_fupd {s E Φ} e1 : Lemma wp_lift_head_step_fupd {s E Φ} e1 :
to_val e1 = None to_val e1 = None
( σ1 κ κs, state_interp σ1 (κ ++ κs) ={E,}= ( σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E,}=
head_reducible e1 σ1 head_reducible e1 σ1
e2 σ2 efs, head_step e1 σ1 κ e2 σ2 efs ={,,E}= e2 σ2 efs, head_step e1 σ1 κ e2 σ2 efs ={,,E}=
state_interp σ2 κs WP e2 @ s; E {{ Φ }} [ list] ef efs, WP ef @ s; {{ _, True }}) state_interp σ2 κs (length efs + n)
WP e2 @ s; E {{ Φ }}
[ list] ef efs, WP ef @ s; {{ _, fork_post }})
WP e1 @ s; E {{ Φ }}. WP e1 @ s; E {{ Φ }}.
Proof. Proof.
iIntros (?) "H". iApply wp_lift_step_fupd=>//. iIntros (σ1 κ κs) "Hσ". iIntros (?) "H". iApply wp_lift_step_fupd=>//. iIntros (σ1 κ κs Qs) "Hσ".
iMod ("H" with "Hσ") as "[% H]"; iModIntro. iMod ("H" with "Hσ") as "[% H]"; iModIntro.
iSplit; first by destruct s; eauto. iIntros (e2 σ2 efs Hstep). iSplit; first by destruct s; eauto. iIntros (e2 σ2 efs ?).
iApply "H"; eauto. iApply "H"; eauto.
Qed. Qed.
Lemma wp_lift_head_step {s E Φ} e1 : Lemma wp_lift_head_step {s E Φ} e1 :
to_val e1 = None to_val e1 = None
( σ1 κ κs, state_interp σ1 (κ ++ κs) ={E,}= ( σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E,}=
head_reducible e1 σ1 head_reducible e1 σ1
e2 σ2 efs, head_step e1 σ1 κ e2 σ2 efs ={,E}= e2 σ2 efs, head_step e1 σ1 κ e2 σ2 efs ={,E}=
state_interp σ2 κs WP e2 @ s; E {{ Φ }} [ list] ef efs, WP ef @ s; {{ _, True }}) state_interp σ2 κs (length efs + n)
WP e2 @ s; E {{ Φ }}
[ list] ef efs, WP ef @ s; {{ _, fork_post }})
WP e1 @ s; E {{ Φ }}. WP e1 @ s; E {{ Φ }}.
Proof. Proof.
iIntros (?) "H". iApply wp_lift_head_step_fupd; [done|]. iIntros (???) "?". iIntros (?) "H". iApply wp_lift_head_step_fupd; [done|]. iIntros (????) "?".
iMod ("H" with "[$]") as "[$ H]". iIntros "!>" (e2 σ2 efs ?) "!> !>". by iApply "H". iMod ("H" with "[$]") as "[$ H]". iIntros "!>" (e2 σ2 efs ?) "!> !>". by iApply "H".
Qed. Qed.
Lemma wp_lift_head_stuck E Φ e : Lemma wp_lift_head_stuck E Φ e :
to_val e = None to_val e = None
sub_redexes_are_values e sub_redexes_are_values e
( σ κs, state_interp σ κs ={E,}= head_stuck e σ⌝) ( σ κs n, state_interp σ κs n ={E,}= head_stuck e σ⌝)
WP e @ E ?{{ Φ }}. WP e @ E ?{{ Φ }}.
Proof. Proof.
iIntros (??) "H". iApply wp_lift_stuck; first done. iIntros (??) "H". iApply wp_lift_stuck; first done.
iIntros (σ κs) "Hσ". iMod ("H" with "Hσ") as "%". by auto. iIntros (σ κs n) "Hσ". iMod ("H" with "Hσ") as "%". by auto.
Qed. Qed.
Lemma wp_lift_pure_head_step {s E E' Φ} e1 : Lemma wp_lift_pure_head_step {s E E' Φ} e1 :
state_interp_fork_indep
( σ1, head_reducible e1 σ1) ( σ1, head_reducible e1 σ1)
( σ1 κ e2 σ2 efs, head_step e1 σ1 κ e2 σ2 efs κ = [] σ1 = σ2) ( σ1 κ e2 σ2 efs, head_step e1 σ1 κ e2 σ2 efs κ = [] σ1 = σ2)
(|={E,E'}=> κ e2 efs σ, head_step e1 σ κ e2 σ efs (|={E,E'}=> κ e2 efs σ, head_step e1 σ κ e2 σ efs
WP e2 @ s; E {{ Φ }} [ list] ef efs, WP ef @ s; {{ _, True }}) WP e2 @ s; E {{ Φ }} [ list] ef efs, WP ef @ s; {{ _, fork_post }})
WP e1 @ s; E {{ Φ }}. WP e1 @ s; E {{ Φ }}.
Proof using Hinh. Proof using Hinh.
iIntros (??) "H". iApply wp_lift_pure_step; [|by eauto|]. iIntros (???) "H". iApply wp_lift_pure_step; [done| |by eauto|].
{ by destruct s; auto. } { by destruct s; auto. }
iApply (step_fupd_wand with "H"); iIntros "H". iApply (step_fupd_wand with "H"); iIntros "H".
iIntros (?????). iApply "H"; eauto. iIntros (?????). iApply "H"; eauto.
...@@ -70,74 +75,77 @@ Lemma wp_lift_pure_head_stuck E Φ e : ...@@ -70,74 +75,77 @@ Lemma wp_lift_pure_head_stuck E Φ e :
WP e @ E ?{{ Φ }}%I. WP e @ E ?{{ Φ }}%I.
Proof using Hinh. Proof using Hinh.
iIntros (?? Hstuck). iApply wp_lift_head_stuck; [done|done|]. iIntros (?? Hstuck). iApply wp_lift_head_stuck; [done|done|].
iIntros (σ κs) "_". iMod (fupd_intro_mask' E ) as "_"; first set_solver. iIntros (σ κs n) "_". iMod (fupd_intro_mask' E ) as "_"; first set_solver.
by auto. by auto.
Qed. Qed.
Lemma wp_lift_atomic_head_step_fupd {s E1 E2 Φ} e1 : Lemma wp_lift_atomic_head_step_fupd {s E1 E2 Φ} e1 :
to_val e1 = None to_val e1 = None
( σ1 κ κs, state_interp σ1 (κ ++ κs) ={E1}= ( σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E1}=
head_reducible e1 σ1 head_reducible e1 σ1
e2 σ2 efs, head_step e1 σ1 κ e2 σ2 efs ={E1,E2}= e2 σ2 efs, head_step e1 σ1 κ e2 σ2 efs ={E1,E2}=
state_interp σ2 κs state_interp σ2 κs (length efs + n)
from_option Φ False (to_val e2) [ list] ef efs, WP ef @ s; {{ _, True }}) from_option Φ False (to_val e2)
[ list] ef efs, WP ef @ s; {{ _, fork_post }})
WP e1 @ s; E1 {{ Φ }}. WP e1 @ s; E1 {{ Φ }}.
Proof. Proof.
iIntros (?) "H". iApply wp_lift_atomic_step_fupd; [done|]. iIntros (?) "H". iApply wp_lift_atomic_step_fupd; [done|].
iIntros (σ1 κ κs) "Hσ1". iMod ("H" with "Hσ1") as "[% H]"; iModIntro. iIntros (σ1 κ κs Qs) "Hσ1". iMod ("H" with "Hσ1") as "[% H]"; iModIntro.
iSplit; first by destruct s; auto. iIntros (e2 σ2 efs Hstep). iSplit; first by destruct s; auto. iIntros (e2 σ2 efs Hstep).
iApply "H"; eauto. iApply "H"; eauto.
Qed. Qed.
Lemma wp_lift_atomic_head_step {s E Φ} e1 : Lemma wp_lift_atomic_head_step {s E Φ} e1 :
to_val e1 = None to_val e1 = None
( σ1 κ κs, state_interp σ1 (κ ++ κs) ={E}= ( σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E}=
head_reducible e1 σ1 head_reducible e1 σ1
e2 σ2 efs, head_step e1 σ1 κ e2 σ2 efs ={E}= e2 σ2 efs, head_step e1 σ1 κ e2 σ2 efs ={E}=
state_interp σ2 κs state_interp σ2 κs (length efs + n)
from_option Φ False (to_val e2) [ list] ef efs, WP ef @ s; {{ _, True }}) from_option Φ False (to_val e2)
[ list] ef efs, WP ef @ s; {{ _, fork_post }})
WP e1 @ s; E {{ Φ }}. WP e1 @ s; E {{ Φ }}.
Proof. Proof.
iIntros (?) "H". iApply wp_lift_atomic_step; eauto. iIntros (?) "H". iApply wp_lift_atomic_step; eauto.
iIntros (σ1 κ κs) "Hσ1". iMod ("H" with "Hσ1") as "[% H]"; iModIntro. iIntros (σ1 κ κs Qs) "Hσ1". iMod ("H" with "Hσ1") as "[% H]"; iModIntro.
iSplit; first by destruct s; auto. iNext. iIntros (e2 σ2 efs Hstep). iSplit; first by destruct s; auto. iNext. iIntros (e2 σ2 efs Hstep).
iApply "H"; eauto. iApply "H"; eauto.
Qed. Qed.
Lemma wp_lift_atomic__head_step_no_fork_fupd {s E1 E2 Φ} e1 : Lemma wp_lift_atomic_head_step_no_fork_fupd {s E1 E2 Φ} e1 :
to_val e1 = None to_val e1 = None
( σ1 κ κs, state_interp σ1 (κ ++ κs) ={E1}= ( σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E1}=
head_reducible e1 σ1 head_reducible e1 σ1
e2 σ2 efs, head_step e1 σ1 κ e2 σ2 efs ={E1,E2}= e2 σ2 efs, head_step e1 σ1 κ e2 σ2 efs ={E1,E2}=
efs = [] state_interp σ2 κs from_option Φ False (to_val e2)) efs = [] state_interp σ2 κs n from_option Φ False (to_val e2))
WP e1 @ s; E1 {{ Φ }}. WP e1 @ s; E1 {{ Φ }}.
Proof. Proof.
iIntros (?) "H". iApply wp_lift_atomic_head_step_fupd; [done|]. iIntros (?) "H". iApply wp_lift_atomic_head_step_fupd; [done|].
iIntros (σ1 κ κs) "Hσ1". iMod ("H" $! σ1 with "Hσ1") as "[$ H]"; iModIntro. iIntros (σ1 κ κs Qs) "Hσ1". iMod ("H" $! σ1 with "Hσ1") as "[$ H]"; iModIntro.
iIntros (v2 σ2 efs Hstep). iIntros (v2 σ2 efs Hstep).
iMod ("H" $! v2 σ2 efs with "[# //]") as "H". iMod ("H" $! v2 σ2 efs with "[# //]") as "H".
iIntros "!> !>". iMod "H" as "(% & $ & $)"; subst; auto. iIntros "!> !>". iMod "H" as "(-> & ? & ?) /=". by iFrame.
Qed. Qed.
Lemma wp_lift_atomic_head_step_no_fork {s E Φ} e1 : Lemma wp_lift_atomic_head_step_no_fork {s E Φ} e1 :
to_val e1 = None to_val e1 = None
( σ1 κ κs, state_interp σ1 (κ ++ κs) ={E}= ( σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E}=
head_reducible e1 σ1 head_reducible e1 σ1
e2 σ2 efs, head_step e1 σ1 κ e2 σ2 efs ={E}= e2 σ2 efs, head_step e1 σ1 κ e2 σ2 efs ={E}=
efs = [] state_interp σ2 κs from_option Φ False (to_val e2)) efs = [] state_interp σ2 κs n from_option Φ False (to_val e2))
WP e1 @ s; E {{ Φ }}. WP e1 @ s; E {{ Φ }}.
Proof. Proof.
iIntros (?) "H". iApply wp_lift_atomic_head_step; eauto. iIntros (?) "H". iApply wp_lift_atomic_head_step; eauto.
iIntros (σ1 κ κs) "Hσ1". iMod ("H" $! σ1 with "Hσ1") as "[$ H]"; iModIntro. iIntros (σ1 κ κs Qs) "Hσ1". iMod ("H" $! σ1 with "Hσ1") as "[$ H]"; iModIntro.
iNext; iIntros (v2 σ2 efs Hstep). iNext; iIntros (v2 σ2 efs Hstep).
iMod ("H" $! v2 σ2 efs with "[# //]") as "(% & $ & $)". subst; auto. iMod ("H" $! v2 σ2 efs with "[//]") as "(-> & ? & ?) /=". by iFrame.
Qed. Qed.
Lemma wp_lift_pure_det_head_step {s E E' Φ} e1 e2 efs : Lemma wp_lift_pure_det_head_step {s E E' Φ} e1 e2 efs :
state_interp_fork_indep
( σ1, head_reducible e1 σ1) ( σ1, head_reducible e1 σ1)
( σ1 κ e2' σ2 efs', ( σ1 κ e2' σ2 efs',
head_step e1 σ1 κ e2' σ2 efs' κ = [] σ1 = σ2 e2 = e2' efs = efs') head_step e1 σ1 κ e2' σ2 efs' κ = [] σ1 = σ2 e2 = e2' efs = efs')
(|={E,E'}=> WP e2 @ s; E {{ Φ }} [ list] ef efs, WP ef @ s; {{ _, True }}) (|={E,E'}=> WP e2 @ s; E {{ Φ }} [ list] ef efs, WP ef @ s; {{ _, fork_post }})
WP e1 @ s; E {{ Φ }}. WP e1 @ s; E {{ Φ }}.
Proof using Hinh. Proof using Hinh.
intros. rewrite -(wp_lift_pure_det_step e1 e2 efs); eauto. intros. rewrite -(wp_lift_pure_det_step e1 e2 efs); eauto.
...@@ -148,10 +156,10 @@ Lemma wp_lift_pure_det_head_step_no_fork {s E E' Φ} e1 e2 : ...@@ -148,10 +156,10 @@ Lemma wp_lift_pure_det_head_step_no_fork {s E E' Φ} e1 e2 :
to_val e1 = None to_val e1 = None
( σ1, head_reducible e1 σ1) ( σ1, head_reducible e1 σ1)
( σ1 κ e2' σ2 efs', ( σ1 κ e2' σ2 efs',
head_step e1 σ1 κ e2' σ2 efs' κ = [] σ1 = σ2 e2 = e2' [] = efs') head_step e1 σ1 κ e2' σ2 efs' κ = [] σ1 = σ2 e2 = e2' efs' = [])
(|={E,E'}=> WP e2 @ s; E {{ Φ }}) WP e1 @ s; E {{ Φ }}. (|={E,E'}=> WP e2 @ s; E {{ Φ }}) WP e1 @ s; E {{ Φ }}.
Proof using Hinh. Proof using Hinh.
intros. rewrite -(wp_lift_pure_det_step e1 e2 []) /= ?right_id; eauto. intros. rewrite -(wp_lift_pure_det_step_no_fork e1 e2); eauto.
destruct s; by auto. destruct s; by auto.
Qed. Qed.
...@@ -159,7 +167,7 @@ Lemma wp_lift_pure_det_head_step_no_fork' {s E Φ} e1 e2 : ...@@ -159,7 +167,7 @@ Lemma wp_lift_pure_det_head_step_no_fork' {s E Φ} e1 e2 :
to_val e1 = None to_val e1 = None
( σ1, head_reducible e1 σ1) ( σ1, head_reducible e1 σ1)
( σ1 κ e2' σ2 efs', ( σ1 κ e2' σ2 efs',
head_step e1 σ1 κ e2' σ2 efs' κ = [] σ1 = σ2 e2 = e2' [] = efs') head_step e1 σ1 κ e2' σ2 efs' κ = [] σ1 = σ2 e2 = e2' efs' = [])
WP e2 @ s; E {{ Φ }} WP e1 @ s; E {{ Φ }}. WP e2 @ s; E {{ Φ }} WP e1 @ s; E {{ Φ }}.
Proof using Hinh. Proof using Hinh.
intros. rewrite -[(WP e1 @ s; _ {{ _ }})%I]wp_lift_pure_det_head_step_no_fork //. intros. rewrite -[(WP e1 @ s; _ {{ _ }})%I]wp_lift_pure_det_head_step_no_fork //.
......
...@@ -15,23 +15,25 @@ Hint Resolve reducible_no_obs_reducible. ...@@ -15,23 +15,25 @@ Hint Resolve reducible_no_obs_reducible.
Lemma wp_lift_step_fupd s E Φ e1 : Lemma wp_lift_step_fupd s E Φ e1 :
to_val e1 = None to_val e1 = None
( σ1 κ κs, state_interp σ1 (κ ++ κs) ={E,}= ( σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E,}=
if s is NotStuck then reducible e1 σ1 else True if s is NotStuck then reducible e1 σ1 else True
e2 σ2 efs, prim_step e1 σ1 κ e2 σ2 efs ={,,E}= e2 σ2 efs, prim_step e1 σ1 κ e2 σ2 efs ={,,E}=
state_interp σ2 κs WP e2 @ s; E {{ Φ }} [ list] ef efs, WP ef @ s; {{ _, True }}) state_interp σ2 κs (length efs + n)
WP e2 @ s; E {{ Φ }}
[ list] ef efs, WP ef @ s; {{ _, fork_post }})
WP e1 @ s; E {{ Φ }}. WP e1 @ s; E {{ Φ }}.
Proof. Proof.
rewrite wp_unfold /wp_pre=>->. iIntros "H" (σ1 κ κs) "Hσ". rewrite wp_unfold /wp_pre=>->. iIntros "H" (σ1 κ κs n) "Hσ".
iMod ("H" with "Hσ") as "(%&H)". iModIntro. iSplit. by destruct s. iMod ("H" with "Hσ") as "(%&H)". iModIntro. iSplit. by destruct s.
iIntros (????). iApply "H". eauto. iIntros (????). iApply "H". eauto.
Qed. Qed.
Lemma wp_lift_stuck E Φ e : Lemma wp_lift_stuck E Φ e :
to_val e = None to_val e = None
( σ κs, state_interp σ κs ={E,}= stuck e σ⌝) ( σ κs n, state_interp σ κs n ={E,}= stuck e σ⌝)
WP e @ E ?{{ Φ }}. WP e @ E ?{{ Φ }}.
Proof. Proof.
rewrite wp_unfold /wp_pre=>->. iIntros "H" (σ1 κ κs) "Hσ". rewrite wp_unfold /wp_pre=>->. iIntros "H" (σ1 κ κs n) "Hσ".
iMod ("H" with "Hσ") as %[? Hirr]. iModIntro. iSplit; first done. iMod ("H" with "Hσ") as %[? Hirr]. iModIntro. iSplit; first done.
iIntros (e2 σ2 efs ?). by case: (Hirr κ e2 σ2 efs). iIntros (e2 σ2 efs ?). by case: (Hirr κ e2 σ2 efs).
Qed. Qed.
...@@ -39,32 +41,53 @@ Qed. ...@@ -39,32 +41,53 @@ Qed.
(** Derived lifting lemmas. *) (** Derived lifting lemmas. *)
Lemma wp_lift_step s E Φ e1 : Lemma wp_lift_step s E Φ e1 :
to_val e1 = None to_val e1 = None
( σ1 κ κs, state_interp σ1 (κ ++ κs) ={E,}=