Commit 6b37b21d authored by Robbert Krebbers's avatar Robbert Krebbers

Merge branch 'robbert/fork_postcondition' into 'master'

Fine-grained post-conditions for forked-off threads

See merge request FP/iris-coq!182
parents b0e4b6fa 678b75da
...@@ -34,10 +34,14 @@ Changes in and extensions of the theory: ...@@ -34,10 +34,14 @@ Changes in and extensions of the theory:
* [#] heap_lang values are now injected in heap_lang expressions via a specific * [#] heap_lang values are now injected in heap_lang expressions via a specific
constructor of the expr inductive type. This simplifies much the tactical constructor of the expr inductive type. This simplifies much the tactical
infrastructure around the language. In particular, this allow us to get rid infrastructure around the language. In particular, this allow us to get rid
the reflexion mechanism that was needed for proving closedness, atomicity and the reflection mechanism that was needed for proving closedness, atomicity and
"valueness" of a term. The price to pay is the addition of new "valueness" of a term. The price to pay is the addition of new
"administrative" reductions in the operational semantics of the language. "administrative" reductions in the operational semantics of the language.
* [#] Extend the state interpretation with a natural number that keeps track of
the number of forked-off threads, and have a global fixed proposition that
describes the postcondition of each forked-off thread (instead of it being
`True`). Additionally, there is a stronger variant of the adequacy theorem
that allows to make use of the postconditions of the forked-off threads.
Changes in Coq: Changes in Coq:
......
...@@ -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 *)
...@@ -161,17 +162,17 @@ Implicit Types σ : state. ...@@ -161,17 +162,17 @@ Implicit Types σ : state.
Lemma wp_fork s E e Φ : 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_atomic_head_step; [done|].
iApply wp_lift_pure_det_head_step; [by eauto|intros; inv_head_step; by eauto|]. iIntros (σ1 κ κs n) "Hσ !>"; iSplit; first by eauto.
iModIntro; iNext; iIntros "!> /= {$He}". by iApply wp_value. iNext; iIntros (v2 σ2 efs Hstep); inv_head_step. by iFrame.
Qed. Qed.
Lemma twp_fork s E e Φ : 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_atomic_head_step; [done|].
iApply twp_lift_pure_det_head_step; [eauto|intros; inv_head_step; eauto|]. iIntros (σ1 κs n) "Hσ !>"; iSplit; first by eauto.
iIntros "!> /= {$He}". by iApply twp_value. iIntros (κ v2 σ2 efs Hstep); inv_head_step. by iFrame.
Qed. Qed.
(** Heap *) (** Heap *)
...@@ -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.
...@@ -39,14 +39,14 @@ Implicit Types P Q : iProp Σ. ...@@ -39,14 +39,14 @@ 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 wptp s t := ([ list] ef t, WP ef @ s; {{ _, True }})%I. Notation wptp s t := ([ list] ef t, WP ef @ s; {{ fork_post }})%I.
Lemma wp_step s E e1 σ1 κ κs e2 σ2 efs Φ : Lemma wp_step s e1 σ1 κ κs e2 σ2 efs m Φ :
prim_step e1 σ1 κ e2 σ2 efs prim_step e1 σ1 κ e2 σ2 efs
state_interp σ1 (κ ++ κs) WP e1 @ s; E {{ Φ }} state_interp σ1 (κ ++ κs) m - WP e1 @ s; {{ Φ }} ={,}=
={E,}= (state_interp σ2 κs WP e2 @ s; E {{ Φ }} wptp s efs). state_interp σ2 κs (length efs + m) WP e2 @ s; {{ Φ }} wptp s efs.
Proof. Proof.
rewrite {1}wp_unfold /wp_pre. iIntros (?) "[Hσ H]". rewrite {1}wp_unfold /wp_pre. iIntros (?) "Hσ H".
rewrite (val_stuck e1 σ1 κ e2 σ2 efs) //. rewrite (val_stuck e1 σ1 κ e2 σ2 efs) //.
iMod ("H" $! σ1 with "Hσ") as "(_ & H)". iMod ("H" $! σ1 with "Hσ") as "(_ & H)".
iMod ("H" $! e2 σ2 efs with "[//]") as "H". iMod ("H" $! e2 σ2 efs with "[//]") as "H".
...@@ -55,43 +55,52 @@ Qed. ...@@ -55,43 +55,52 @@ 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)
state_interp σ1 (κ ++ κs) WP e1 @ s; {{ Φ }} wptp s t1 state_interp σ1 (κ ++ κs) (length t1) - WP e1 @ s; {{ Φ }} - wptp s t1 ==
== e2 t2', e2 t2', t2 = e2 :: t2'
t2 = e2 :: t2' |={,}=> (state_interp σ2 κs WP e2 @ s; {{ Φ }} wptp s t2'). |={,}=> state_interp σ2 κs (pred (length t2)) WP e2 @ s; {{ Φ }} wptp s t2'.
Proof. Proof.
iIntros (Hstep) "(HW & He & Ht)". iIntros (Hstep) " 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/=.
- iExists e2', (t2' ++ efs). iSplitR; first by eauto. - iExists e2', (t2' ++ efs). iModIntro. iSplitR; first by eauto.
iFrame "Ht". iApply wp_step; eauto with iFrame. iMod (wp_step with "Hσ He") as "H"; first done.
iIntros "!> !>". iMod "H" as "(Hσ & He2 & Hefs)".
iIntros "!>". rewrite Nat.add_comm app_length. iFrame.
- iExists e, (t1' ++ e2' :: t2' ++ efs); iSplitR; first eauto. - iExists e, (t1' ++ e2' :: t2' ++ efs); iSplitR; first eauto.
iDestruct "Ht" as "($ & He' & $)". iFrame "He". iFrame "He". iDestruct "Ht" as "(Ht1 & He1 & Ht2)".
iApply wp_step; eauto with iFrame. iModIntro. iMod (wp_step with "Hσ He1") as "H"; first done.
iIntros "!> !>". iMod "H" as "(Hσ & He2 & Hefs)". iIntros "!>".
rewrite !app_length /= !app_length.
replace (length t1' + S (length t2' + length efs))
with (length efs + (length t1' + S (length t2'))) by omega. iFrame.
Qed. 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)
state_interp σ1 (κs ++ κs') WP e1 @ s; {{ Φ }} wptp s t1 state_interp σ1 (κs ++ κs') (length t1) - WP e1 @ s; {{ Φ }} - wptp s t1
|={,}=>^n ( e2 t2', ={,}=^n e2 t2',
t2 = e2 :: t2' state_interp σ2 κs' WP e2 @ s; {{ Φ }} wptp s t2'). t2 = e2 :: t2'
state_interp σ2 κs' (pred (length t2))
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.
{ inversion_clear 1; iIntros "(?&?&?)"; iExists e1, t1; iFrame; eauto 10. } induction n as [|n IH]=> e1 t1 κs κs' t2 σ1 σ2 /=.
iIntros (Hsteps) "H". inversion_clear Hsteps as [|?? [t1' σ1']]. { inversion_clear 1; iIntros "???"; iExists e1, t1; iFrame; eauto 10. }
rewrite <- app_assoc. iIntros (Hsteps) "Hσ He Ht". inversion_clear Hsteps as [|?? [t1' σ1']].
iMod (wptp_step with "H") as (e1' t1'') "[% H]"; first eauto; simplify_eq. rewrite -(assoc_L (++)).
iMod "H". iModIntro; iNext. iMod "H". iModIntro. iMod (wptp_step with "Hσ He Ht") as (e1' t1'' ?) ">H"; first eauto; simplify_eq.
by iApply IH. iIntros "!> !>". iMod "H" as "(Hσ & He & Ht)". iModIntro.
by iApply (IH with "Hσ He Ht").
Qed. Qed.
Lemma wptp_result s n e1 t1 κs κs' v2 t2 σ1 σ2 φ : Lemma wptp_result φ κs' s n e1 t1 κ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)
state_interp σ1 (κs ++ κs') state_interp σ1 (κs ++ κs') (length t1) -
WP e1 @ s; {{ v, σ, state_interp σ κs' ={,}= ⌜φ v σ⌝ }} WP e1 @ s; {{ v, σ, state_interp σ κs' (length t2) ={,}= ⌜φ v σ⌝ }} -
wptp s t1 wptp s t1 ={,}=^(S n) ⌜φ v2 σ2.
|={,}=>^(S n) ⌜φ v2 σ2.
Proof. Proof.
intros. rewrite Nat_iter_S_r wptp_steps //. iIntros (?) "Hσ He Ht". rewrite Nat_iter_S_r.
apply step_fupdN_mono. iDestruct (wptp_steps with "Hσ He Ht") as "H"; first done.
iApply (step_fupdN_wand with "H").
iDestruct 1 as (e2 t2' ?) "(Hσ & H & _)"; simplify_eq. iDestruct 1 as (e2 t2' ?) "(Hσ & H & _)"; simplify_eq.
iMod (wp_value_inv' with "H") as "H". iMod (wp_value_inv' with "H") as "H".
iMod (fupd_plain_mask_empty _ ⌜φ v2 σ2%I with "[H Hσ]") as %?. iMod (fupd_plain_mask_empty _ ⌜φ v2 σ2%I with "[H Hσ]") as %?.
...@@ -99,109 +108,166 @@ Proof. ...@@ -99,109 +108,166 @@ Proof.
by iApply step_fupd_intro. by iApply step_fupd_intro.
Qed. Qed.
Lemma wp_safe E e σ κs Φ : Lemma wptp_all_result φ κs' s n e1 t1 κs v2 vs2 σ1 σ2 :
state_interp σ κs - WP e @ E {{ Φ }} ={E, }= is_Some (to_val e) reducible e σ⌝. nsteps n (e1 :: t1, σ1) κs (of_val <$> v2 :: vs2, σ2)
state_interp σ1 (κs ++ κs') (length t1) -
WP e1 @ s; {{ v,
state_interp σ2 κs' (length vs2) -
([ list] v vs2, fork_post v) ={,}= ⌜φ v }} -
wptp s t1
={,}=^(S n) ⌜φ v2 .
Proof.
iIntros (Hstep) "Hσ He Ht". rewrite Nat_iter_S_r.
iDestruct (wptp_steps with "Hσ He Ht") as "H"; first done.
iApply (step_fupdN_wand with "H").
iDestruct 1 as (e2 t2' ?) "(Hσ & H & Hvs)"; simplify_eq/=.
rewrite fmap_length. iMod (wp_value_inv' with "H") as "H".
iAssert ([ list] v vs2, fork_post v)%I with "[> Hvs]" as "Hm".
{ clear Hstep. iInduction vs2 as [|v vs] "IH"; csimpl; first by iFrame.
iDestruct "Hvs" as "[Hv Hvs]".
iMod (wp_value_inv' with "Hv") as "$". by iApply "IH". }
iMod (fupd_plain_mask_empty _ ⌜φ v2%I with "[H Hm Hσ]") as %?.
{ iApply ("H" with "Hσ Hm"). }
by iApply step_fupd_intro.
Qed.
Lemma wp_safe κs m e σ Φ :
state_interp σ κs m -
WP e {{ Φ }} ={,}= is_Some (to_val e) reducible e σ⌝.
Proof. Proof.
rewrite wp_unfold /wp_pre. iIntros "Hσ H". rewrite wp_unfold /wp_pre. iIntros "Hσ H".
destruct (to_val e) as [v|] eqn:?. destruct (to_val e) as [v|] eqn:?.
{ iApply (step_fupd_mask_mono _ _ ); eauto. set_solver. } { iApply step_fupd_intro. set_solver. eauto. }
iMod (fupd_plain_mask_empty _ reducible e σ⌝%I with "[H Hσ]") as %?. iMod (fupd_plain_mask_empty _ reducible e σ⌝%I with "[H Hσ]") as %?.
{ by iMod ("H" $! σ [] κs with "Hσ") as "($&H)". } { by iMod ("H" $! σ [] κs with "Hσ") as "[$ H]". }
iApply step_fupd_intro; first by set_solver+. iApply step_fupd_intro; first by set_solver+.
iIntros "!> !%". by right. iIntros "!> !%". by right.
Qed. Qed.
Lemma wptp_safe n e1 κs κs' e2 t1 t2 σ1 σ2 Φ : Lemma wptp_safe κs' n e1 κ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
state_interp σ1 (κs ++ κs') WP e1 {{ Φ }} wptp NotStuck t1 state_interp σ1 (κs ++ κs') (length t1) - WP e1 {{ Φ }} - wptp NotStuck t1
|={,}=>^(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 Nat_iter_S_r wptp_steps //. iIntros (? He2) "Hσ He Ht". rewrite Nat_iter_S_r.
apply step_fupdN_mono. iDestruct (wptp_steps with "Hσ He Ht") as "H"; first done.
iDestruct 1 as (e2' t2' ?) "(Hw & H & Htp)"; simplify_eq. iApply (step_fupdN_wand with "H").
apply elem_of_cons in He2 as [<-|?]. iDestruct 1 as (e2' t2' ?) "(Hσ & H & Ht)"; simplify_eq.
- iMod (wp_safe with "Hw H") as "$"; auto. apply elem_of_cons in He2 as [<-|(t1''&t2''&->)%elem_of_list_split].
- iMod (wp_safe with "Hw [Htp]") as "$"; auto. by iApply (big_sepL_elem_of with "Htp"). - iMod (wp_safe with "Hσ H") as "$"; auto.
- iDestruct "Ht" as "(_ & He2 & _)". by iMod (wp_safe with "Hσ He2").
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' ={,}= ⌜φ⌝) (state_interp σ2 κs' (pred (length t2)) ={,}= ⌜φ⌝) -
state_interp σ1 (κs ++ κs') WP e1 @ s; {{ Φ }} wptp s t1 state_interp σ1 (κs ++ κs') (length t1) -
|={,}=>^(S n) |={,}=> ⌜φ⌝. WP e1 @ s; {{ Φ }} - wptp s t1
={,}=^(S n) ⌜φ⌝.
Proof. Proof.
intros ?. rewrite Nat_iter_S_r wptp_steps // step_fupdN_frame_l. iIntros (?) "Hφ Hσ He Ht". rewrite Nat_iter_S_r.
apply step_fupdN_mono. iDestruct (wptp_steps _ n with "Hσ He Ht") as "H"; first done.
iIntros "[Hback H]"; iDestruct "H" as (e2' t2' ->) "[Hσ _]". iApply (step_fupdN_wand with "H"). iDestruct 1 as (e2' t2' ->) "[Hσ _]".
iSpecialize ("Hback" with "Hσ"). by iApply step_fupd_intro. iSpecialize ("Hφ" with "Hσ").
iMod (fupd_plain_mask_empty _ ⌜φ⌝%I with "Hφ") as %?.
by iApply step_fupd_intro.