Commit 6b37b21d authored by Robbert's avatar Robbert

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:
* [#] heap_lang values are now injected in heap_lang expressions via a specific
constructor of the expr inductive type. This simplifies much the tactical
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
"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:
......
......@@ -16,8 +16,9 @@ Class heapG Σ := HeapG {
Instance heapG_irisG `{heapG Σ} : irisG heap_lang Σ := {
iris_invG := heapG_invG;
state_interp σ κs :=
(gen_heap_ctx σ.(heap) proph_map_ctx κs σ.(used_proph_id))%I
state_interp σ κs _ :=
(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 *)
......@@ -161,17 +162,17 @@ Implicit Types σ : state.
Lemma wp_fork s E e Φ :
WP e @ s; {{ _, True }} - Φ (LitV LitUnit) - WP Fork e @ s; E {{ Φ }}.
Proof.
iIntros "He HΦ".
iApply wp_lift_pure_det_head_step; [by eauto|intros; inv_head_step; by eauto|].
iModIntro; iNext; iIntros "!> /= {$He}". by iApply wp_value.
iIntros "He HΦ". iApply wp_lift_atomic_head_step; [done|].
iIntros (σ1 κ κs n) "Hσ !>"; iSplit; first by eauto.
iNext; iIntros (v2 σ2 efs Hstep); inv_head_step. by iFrame.
Qed.
Lemma twp_fork s E e Φ :
WP e @ s; [{ _, True }] - Φ (LitV LitUnit) - WP Fork e @ s; E [{ Φ }].
Proof.
iIntros "He HΦ".
iApply twp_lift_pure_det_head_step; [eauto|intros; inv_head_step; eauto|].
iIntros "!> /= {$He}". by iApply twp_value.
iIntros "He HΦ". iApply twp_lift_atomic_head_step; [done|].
iIntros (σ1 κs n) "Hσ !>"; iSplit; first by eauto.
iIntros (κ v2 σ2 efs Hstep); inv_head_step. by iFrame.
Qed.
(** Heap *)
......@@ -179,7 +180,7 @@ Lemma wp_alloc s E v :
{{{ True }}} Alloc (Val v) @ s; E {{{ l, RET LitV (LitLoc l); l v }}}.
Proof.
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.
iMod (@gen_heap_alloc with "Hσ") as "[Hσ Hl]"; first done.
iModIntro; iSplit=> //. iFrame. by iApply "HΦ".
......@@ -188,7 +189,7 @@ Lemma twp_alloc s E v :
[[{ True }]] Alloc (Val v) @ s; E [[{ l, RET LitV (LitLoc l); l v }]].
Proof.
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.
iMod (@gen_heap_alloc with "Hσ") as "[Hσ Hl]"; first done.
iModIntro; iSplit=> //. iSplit; first done. iFrame. by iApply "HΦ".
......@@ -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 }}}.
Proof.
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.
iModIntro; iSplit=> //. iFrame. by iApply "HΦ".
Qed.
......@@ -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 }]].
Proof.
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.
iModIntro; iSplit=> //. iSplit; first done. iFrame. by iApply "HΦ".
Qed.
......@@ -217,7 +218,7 @@ Lemma wp_store s E l v' v :
Proof.
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.
iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
iModIntro. iSplit=>//. iFrame. by iApply "HΦ".
......@@ -228,7 +229,7 @@ Lemma twp_store s E l v' v :
Proof.
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.
iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
iModIntro. iSplit=>//. iSplit; first done. iFrame. by iApply "HΦ".
......@@ -240,7 +241,7 @@ Lemma wp_cas_fail s E l q v' v1 v2 :
{{{ RET LitV (LitBool false); l {q} v' }}}.
Proof.
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.
iModIntro; iSplit=> //. iFrame. by iApply "HΦ".
Qed.
......@@ -250,7 +251,7 @@ Lemma twp_cas_fail s E l q v' v1 v2 :
[[{ RET LitV (LitBool false); l {q} v' }]].
Proof.
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.
iModIntro; iSplit=> //. iSplit; first done. iFrame. by iApply "HΦ".
Qed.
......@@ -261,7 +262,7 @@ Lemma wp_cas_suc s E l v1 v2 :
{{{ RET LitV (LitBool true); l v2 }}}.
Proof.
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.
iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
iModIntro. iSplit=>//. iFrame. by iApply "HΦ".
......@@ -272,7 +273,7 @@ Lemma twp_cas_suc s E l v1 v2 :
[[{ RET LitV (LitBool true); l v2 }]].
Proof.
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.
iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
iModIntro. iSplit=>//. iSplit; first done. iFrame. by iApply "HΦ".
......@@ -283,7 +284,7 @@ Lemma wp_faa s E l i1 i2 :
{{{ RET LitV (LitInt i1); l LitV (LitInt (i1 + i2)) }}}.
Proof.
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.
iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
iModIntro. iSplit=>//. iFrame. by iApply "HΦ".
......@@ -293,7 +294,7 @@ Lemma twp_faa s E l i1 i2 :
[[{ RET LitV (LitInt i1); l LitV (LitInt (i1 + i2)) }]].
Proof.
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.
iMod (@gen_heap_update with "Hσ Hl") as "[$ Hl]".
iModIntro. iSplit=>//. iSplit; first done. iFrame. by iApply "HΦ".
......@@ -304,7 +305,7 @@ Lemma wp_new_proph :
{{{ True }}} NewProph {{{ v (p : proph_id), RET (LitV (LitProphecy p)); proph p v }}}.
Proof.
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.
iNext; iIntros (v2 σ2 efs Hstep). inv_head_step.
iMod (@proph_map_alloc with "HR") as "[HR Hp]".
......@@ -323,7 +324,7 @@ Lemma wp_resolve_proph p v w:
{{{ RET (LitV LitUnit); v = Some w }}}.
Proof.
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.
iSplit; first by eauto.
iNext; iIntros (v2 σ2 efs Hstep); inv_head_step. iApply fupd_frame_l.
......@@ -331,8 +332,7 @@ Proof.
iMod (@proph_map_remove with "HR Hp") as "Hp". iModIntro.
iSplitR "HΦ".
- 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.
Qed.
End lifting.
......@@ -12,6 +12,8 @@ Proof.
iMod (gen_heap_init σ.(heap)) as (?) "Hh".
iMod (proph_map_init [] σ.(used_proph_id)) as (?) "Hp".
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 _ _ _ _)).
Qed.
This diff is collapsed.
......@@ -217,7 +217,7 @@ Section ectx_language.
Record pure_head_step (e1 e2 : expr Λ) := {
pure_head_step_safe σ1 : head_reducible_no_obs e1 σ1;
pure_head_step_det σ1 κ e2' σ2 efs :
head_step e1 σ1 κ e2' σ2 efs κ = [] σ1 = σ2 e2 = e2' efs = []
head_step e1 σ1 κ e2' σ2 efs κ = [] σ2 = σ1 e2' = e2 efs = []
}.
Lemma pure_head_step_pure_step e1 e2 : pure_head_step e1 e2 pure_step e1 e2.
......
......@@ -16,51 +16,42 @@ Hint Resolve head_stuck_stuck.
Lemma wp_lift_head_step_fupd {s E Φ} e1 :
to_val e1 = None
( σ1 κ κs, state_interp σ1 (κ ++ κs) ={E,}=
( σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E,}=
head_reducible e1 σ1
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 {{ Φ }}.
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.
iSplit; first by destruct s; eauto. iIntros (e2 σ2 efs Hstep).
iSplit; first by destruct s; eauto. iIntros (e2 σ2 efs ?).
iApply "H"; eauto.
Qed.
Lemma wp_lift_head_step {s E Φ} e1 :
to_val e1 = None
( σ1 κ κs, state_interp σ1 (κ ++ κs) ={E,}=
( σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E,}=
head_reducible e1 σ1
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 {{ Φ }}.
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".
Qed.
Lemma wp_lift_head_stuck E Φ e :
to_val e = None
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 ?{{ Φ }}.
Proof.
iIntros (??) "H". iApply wp_lift_stuck; first done.
iIntros (σ κs) "Hσ". iMod ("H" with "Hσ") as "%". by auto.
Qed.
Lemma wp_lift_pure_head_step {s E E' Φ} e1 :
( σ1, head_reducible e1 σ1)
( σ1 κ e2 σ2 efs, head_step e1 σ1 κ e2 σ2 efs κ = [] σ1 = σ2)
(|={E,E'}=> κ e2 efs σ, head_step e1 σ κ e2 σ efs
WP e2 @ s; E {{ Φ }} [ list] ef efs, WP ef @ s; {{ _, True }})
WP e1 @ s; E {{ Φ }}.
Proof using Hinh.
iIntros (??) "H". iApply wp_lift_pure_step; [|by eauto|].
{ by destruct s; auto. }
iApply (step_fupd_wand with "H"); iIntros "H".
iIntros (?????). iApply "H"; eauto.
iIntros (σ κs n) "Hσ". iMod ("H" with "Hσ") as "%". by auto.
Qed.
Lemma wp_lift_pure_head_stuck E Φ e :
......@@ -70,88 +61,79 @@ Lemma wp_lift_pure_head_stuck E Φ e :
WP e @ E ?{{ Φ }}%I.
Proof using Hinh.
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.
Qed.
Lemma wp_lift_atomic_head_step_fupd {s E1 E2 Φ} e1 :
to_val e1 = None
( σ1 κ κs, state_interp σ1 (κ ++ κs) ={E1}=
( σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E1}=
head_reducible e1 σ1
e2 σ2 efs, head_step e1 σ1 κ e2 σ2 efs ={E1,E2}=
state_interp σ2 κs
from_option Φ False (to_val e2) [ list] ef efs, WP ef @ s; {{ _, True }})
state_interp σ2 κs (length efs + n)
from_option Φ False (to_val e2)
[ list] ef efs, WP ef @ s; {{ fork_post }})
WP e1 @ s; E1 {{ Φ }}.
Proof.
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).
iApply "H"; eauto.
Qed.
Lemma wp_lift_atomic_head_step {s E Φ} e1 :
to_val e1 = None
( σ1 κ κs, state_interp σ1 (κ ++ κs) ={E}=
( σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E}=
head_reducible e1 σ1
e2 σ2 efs, head_step e1 σ1 κ e2 σ2 efs ={E}=
state_interp σ2 κs
from_option Φ False (to_val e2) [ list] ef efs, WP ef @ s; {{ _, True }})
state_interp σ2 κs (length efs + n)
from_option Φ False (to_val e2)
[ list] ef efs, WP ef @ s; {{ fork_post }})
WP e1 @ s; E {{ Φ }}.
Proof.
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).
iApply "H"; eauto.
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
( σ1 κ κs, state_interp σ1 (κ ++ κs) ={E1}=
( σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E1}=
head_reducible e1 σ1
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 {{ Φ }}.
Proof.
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).
iMod ("H" $! v2 σ2 efs with "[# //]") as "H".
iIntros "!> !>". iMod "H" as "(% & $ & $)"; subst; auto.
iIntros "!> !>". iMod "H" as "(-> & ? & ?) /=". by iFrame.
Qed.
Lemma wp_lift_atomic_head_step_no_fork {s E Φ} e1 :
to_val e1 = None
( σ1 κ κs, state_interp σ1 (κ ++ κs) ={E}=
( σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E}=
head_reducible e1 σ1
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 {{ Φ }}.
Proof.
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).
iMod ("H" $! v2 σ2 efs with "[# //]") as "(% & $ & $)". subst; auto.
Qed.
Lemma wp_lift_pure_det_head_step {s 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 @ s; E {{ Φ }} [ list] ef efs, WP ef @ s; {{ _, True }})
WP e1 @ s; E {{ Φ }}.
Proof using Hinh.
intros. rewrite -(wp_lift_pure_det_step e1 e2 efs); eauto.
destruct s; by auto.
iMod ("H" $! v2 σ2 efs with "[//]") as "(-> & ? & ?) /=". by iFrame.
Qed.
Lemma wp_lift_pure_det_head_step_no_fork {s E E' Φ} e1 e2 :
to_val e1 = None
( σ1, head_reducible e1 σ1)
( σ1 κ e2' σ2 efs',
head_step e1 σ1 κ e2' σ2 efs' κ = [] σ1 = σ2 e2 = e2' [] = efs')
head_step e1 σ1 κ e2' σ2 efs' κ = [] σ2 = σ1 e2' = e2 efs' = [])
(|={E,E'}=> WP e2 @ s; E {{ Φ }}) WP e1 @ s; E {{ Φ }}.
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.
Qed.
......@@ -159,7 +141,7 @@ Lemma wp_lift_pure_det_head_step_no_fork' {s E Φ} e1 e2 :
to_val e1 = None
( σ1, head_reducible e1 σ1)
( σ1 κ e2' σ2 efs',
head_step e1 σ1 κ e2' σ2 efs' κ = [] σ1 = σ2 e2 = e2' [] = efs')
head_step e1 σ1 κ e2' σ2 efs' κ = [] σ2 = σ1 e2' = e2 efs' = [])
WP e2 @ s; E {{ Φ }} WP e1 @ s; E {{ Φ }}.
Proof using Hinh.
intros. rewrite -[(WP e1 @ s; _ {{ _ }})%I]wp_lift_pure_det_head_step_no_fork //.
......
......@@ -177,7 +177,7 @@ Section language.
Record pure_step (e1 e2 : expr Λ) := {
pure_step_safe σ1 : reducible_no_obs e1 σ1;
pure_step_det σ1 κ e2' σ2 efs :
prim_step e1 σ1 κ e2' σ2 efs κ = [] σ1 = σ2 e2 = e2' efs = []
prim_step e1 σ1 κ e2' σ2 efs κ = [] σ2 = σ1 e2' = e2 efs = []
}.
(* TODO: Exclude the case of [n=0], either here, or in [wp_pure] to avoid it
......
......@@ -15,23 +15,25 @@ Hint Resolve reducible_no_obs_reducible.
Lemma wp_lift_step_fupd s E Φ e1 :
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
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 {{ Φ }}.
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.
iIntros (????). iApply "H". eauto.
Qed.
Lemma wp_lift_stuck E Φ e :
to_val e = None
( σ κs, state_interp σ κs ={E,}= stuck e σ⌝)
( σ κs n, state_interp σ κs n ={E,}= stuck e σ⌝)
WP e @ E ?{{ Φ }}.
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.
iIntros (e2 σ2 efs ?). by case: (Hirr κ e2 σ2 efs).
Qed.
......@@ -39,32 +41,33 @@ Qed.
(** Derived lifting lemmas. *)
Lemma wp_lift_step s E Φ e1 :
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
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 {{ Φ }}.
Proof.
iIntros (?) "H". iApply wp_lift_step_fupd; [done|]. iIntros (???) "Hσ".
iMod ("H" with "Hσ") as "[$ H]". iIntros "!> * % !>". by iApply "H".
iIntros (?) "H". iApply wp_lift_step_fupd; [done|]. iIntros (????) "Hσ".
iMod ("H" with "Hσ") as "[$ H]". iIntros "!> * % !> !>". by iApply "H".
Qed.
Lemma wp_lift_pure_step `{Inhabited (state Λ)} s E E' Φ e1 :
Lemma wp_lift_pure_step_no_fork `{Inhabited (state Λ)} s E E' Φ e1 :
( σ1, if s is NotStuck then reducible e1 σ1 else to_val e1 = None)
( κ σ1 e2 σ2 efs, prim_step e1 σ1 κ e2 σ2 efs κ = [] σ1 = σ2)
(|={E,E'}=> κ e2 efs σ, prim_step e1 σ κ e2 σ efs
WP e2 @ s; E {{ Φ }} [ list] ef efs, WP ef @ s; {{ _, True }})
( κ σ1 e2 σ2 efs, prim_step e1 σ1 κ e2 σ2 efs κ = [] σ2 = σ1 efs = [])
(|={E,E'}=> κ e2 efs σ, prim_step e1 σ κ e2 σ efs WP e2 @ s; E {{ Φ }})
WP e1 @ s; E {{ Φ }}.
Proof.
iIntros (Hsafe Hstep) "H". iApply wp_lift_step.
{ specialize (Hsafe inhabitant). destruct s; last done.
by eapply reducible_not_val. }
iIntros (σ1 κ κs) "Hσ". iMod "H".
{ specialize (Hsafe inhabitant). destruct s; eauto using reducible_not_val. }
iIntros (σ1 κ κs n) "Hσ". iMod "H".
iMod fupd_intro_mask' as "Hclose"; last iModIntro; first by set_solver. iSplit.
{ iPureIntro. destruct s; done. }
iNext. iIntros (e2 σ2 efs Hstep').
destruct (Hstep κ σ1 e2 σ2 efs); auto; subst; clear Hstep.
iMod "Hclose" as "_". iFrame "Hσ". iMod "H". iApply "H"; auto.
iNext. iIntros (e2 σ2 efs ?).
destruct (Hstep κ σ1 e2 σ2 efs) as (-> & <- & ->); auto.
iMod "Hclose" as "_". iMod "H". iModIntro.
iDestruct ("H" with "[//]") as "H". simpl. iFrame.
Qed.
Lemma wp_lift_pure_stuck `{Inhabited (state Λ)} E Φ e :
......@@ -74,57 +77,59 @@ Proof.
iIntros (Hstuck) "_". iApply wp_lift_stuck.
- destruct(to_val e) as [v|] eqn:He; last done.
rewrite -He. by case: (Hstuck inhabitant).
- iIntros (σ κs) "_". iMod (fupd_intro_mask' E ) as "_".
by set_solver. by auto.
- iIntros (σ κs n) "_". by iMod (fupd_intro_mask' E ) as "_"; first set_solver.
Qed.
(* Atomic steps don't need any mask-changing business here, one can
use the generic lemmas here. *)
Lemma wp_lift_atomic_step_fupd {s E1 E2 Φ} e1 :
to_val e1 = None
( σ1 κ κs, state_interp σ1 (κ ++ κs) ={E1}=
( σ1 κ κs n, state_interp σ1 (κ ++ κs) n ={E1}=
if s is NotStuck then reducible e1 σ1 else True
e2 σ2 efs, prim_step e1 σ1 κ e2 σ2 efs ={E1,E2}=
state_interp σ2 κs
from_option Φ False (to_val e2) [ list] ef efs, WP ef @ s; {{ _, True }})
state_interp σ2 κs (length efs + n)
from_option Φ False (to_val e2)
[ list] ef efs, WP ef @ s; {{ fork_post }})
WP e1 @ s; E1 {{ Φ }}.
Proof.
iIntros (?) "H". iApply (wp_lift_step_fupd s E1 _ e1)=>//; iIntros (σ1 κ κs) "Hσ1".
iIntros (?) "H".
iApply (wp_lift_step_fupd s E1 _ e1)=>//; iIntros (σ1 κ κs n) "Hσ1".
iMod ("H" $! σ1 with "Hσ1") as "[$ H]".
iMod (fupd_intro_mask' E1 ) as "Hclose"; first set_solver.
iIntros "!>" (e2 σ2 efs ?). iMod "Hclose" as "_".
iMod ("H" $! e2 σ2 efs with "[#]") as "H"; [done|].
iMod (fupd_intro_mask' E2 ) as "Hclose"; [set_solver|]. iIntros "!> !>".
iMod "Hclose" as "_". iMod "H" as "($ & HΦ & $)".
iMod "Hclose" as "_". iMod "H" as "($ & HQ & $)".
destruct (to_val e2) eqn:?; last by iExFalso.
iApply wp_value; last done. by apply of_to_val.
Qed.