Commit 5b4cd196 authored by David Swasey's avatar David Swasey

Add progress bit to wp (and slightly generalize wp_step, wp_safe).

parent 726366bb
...@@ -14,7 +14,7 @@ l ...@@ -14,7 +14,7 @@ l
m : iGst = ghost state m : iGst = ghost state
n n
o o
p p : progress bits
q q
r : iRes = resources r : iRes = resources
s : state (STSs) s : state (STSs)
......
...@@ -16,7 +16,7 @@ Proof. solve_inG. Qed. ...@@ -16,7 +16,7 @@ Proof. solve_inG. Qed.
Definition heap_adequacy Σ `{heapPreG Σ} e σ φ : Definition heap_adequacy Σ `{heapPreG Σ} e σ φ :
( `{heapG Σ}, WP e {{ v, ⌜φ v }}%I) ( `{heapG Σ}, WP e {{ v, ⌜φ v }}%I)
adequate e σ φ. adequate true e σ φ.
Proof. Proof.
intros Hwp; eapply (wp_adequacy _ _); iIntros (?) "". intros Hwp; eapply (wp_adequacy _ _); iIntros (?) "".
iMod (own_alloc ( to_gen_heap σ)) as (γ) "Hh". iMod (own_alloc ( to_gen_heap σ)) as (γ) "Hh".
......
...@@ -76,7 +76,7 @@ Lemma wp_fork E e Φ : ...@@ -76,7 +76,7 @@ Lemma wp_fork E e Φ :
Φ (LitV LitUnit) WP e {{ _, True }} WP Fork e @ E {{ Φ }}. Φ (LitV LitUnit) WP e {{ _, True }} WP Fork e @ E {{ Φ }}.
Proof. Proof.
rewrite -(wp_lift_pure_det_head_step (Fork e) (Lit LitUnit) [e]) //=; eauto. rewrite -(wp_lift_pure_det_head_step (Fork e) (Lit LitUnit) [e]) //=; eauto.
- by rewrite -step_fupd_intro // later_sep -(wp_value _ _ (Lit _)) // right_id. - by rewrite -step_fupd_intro // later_sep -(wp_value _ _ _ (Lit _)) // right_id.
- intros; inv_head_step; eauto. - intros; inv_head_step; eauto.
Qed. Qed.
......
...@@ -27,7 +27,7 @@ Ltac wp_value_head := eapply tac_wp_value; [apply _|lazy beta]. ...@@ -27,7 +27,7 @@ Ltac wp_value_head := eapply tac_wp_value; [apply _|lazy beta].
Tactic Notation "wp_pure" open_constr(efoc) := Tactic Notation "wp_pure" open_constr(efoc) :=
iStartProof; iStartProof;
lazymatch goal with lazymatch goal with
| |- envs_entails _ (wp ?E ?e ?Q) => reshape_expr e ltac:(fun K e' => | |- envs_entails _ (wp true ?E ?e ?Q) => reshape_expr e ltac:(fun K e' =>
unify e' efoc; unify e' efoc;
eapply (tac_wp_pure K); eapply (tac_wp_pure K);
[simpl; apply _ (* PureExec *) [simpl; apply _ (* PureExec *)
...@@ -66,7 +66,7 @@ Ltac wp_bind_core K := ...@@ -66,7 +66,7 @@ Ltac wp_bind_core K :=
Tactic Notation "wp_bind" open_constr(efoc) := Tactic Notation "wp_bind" open_constr(efoc) :=
iStartProof; iStartProof;
lazymatch goal with lazymatch goal with
| |- envs_entails _ (wp ?E ?e ?Q) => | |- envs_entails _ (wp true ?E ?e ?Q) =>
reshape_expr e ltac:(fun K e' => unify e' efoc; wp_bind_core K) reshape_expr e ltac:(fun K e' => unify e' efoc; wp_bind_core K)
|| fail "wp_bind: cannot find" efoc "in" e || fail "wp_bind: cannot find" efoc "in" e
| _ => fail "wp_bind: not a 'wp'" | _ => fail "wp_bind: not a 'wp'"
...@@ -151,7 +151,7 @@ End heap. ...@@ -151,7 +151,7 @@ End heap.
Tactic Notation "wp_apply" open_constr(lem) := Tactic Notation "wp_apply" open_constr(lem) :=
iPoseProofCore lem as false true (fun H => iPoseProofCore lem as false true (fun H =>
lazymatch goal with lazymatch goal with
| |- envs_entails _ (wp ?E ?e ?Q) => | |- envs_entails _ (wp true ?E ?e ?Q) =>
reshape_expr e ltac:(fun K e' => reshape_expr e ltac:(fun K e' =>
wp_bind_core K; iApplyHyp H; try iNext; simpl) || wp_bind_core K; iApplyHyp H; try iNext; simpl) ||
lazymatch iTypeOf H with lazymatch iTypeOf H with
...@@ -163,7 +163,7 @@ Tactic Notation "wp_apply" open_constr(lem) := ...@@ -163,7 +163,7 @@ Tactic Notation "wp_apply" open_constr(lem) :=
Tactic Notation "wp_alloc" ident(l) "as" constr(H) := Tactic Notation "wp_alloc" ident(l) "as" constr(H) :=
iStartProof; iStartProof;
lazymatch goal with lazymatch goal with
| |- envs_entails _ (wp ?E ?e ?Q) => | |- envs_entails _ (wp true ?E ?e ?Q) =>
first first
[reshape_expr e ltac:(fun K e' => [reshape_expr e ltac:(fun K e' =>
eapply (tac_wp_alloc _ _ _ H K); [apply _|..]) eapply (tac_wp_alloc _ _ _ H K); [apply _|..])
...@@ -182,7 +182,7 @@ Tactic Notation "wp_alloc" ident(l) := ...@@ -182,7 +182,7 @@ Tactic Notation "wp_alloc" ident(l) :=
Tactic Notation "wp_load" := Tactic Notation "wp_load" :=
iStartProof; iStartProof;
lazymatch goal with lazymatch goal with
| |- envs_entails _ (wp ?E ?e ?Q) => | |- envs_entails _ (wp true ?E ?e ?Q) =>
first first
[reshape_expr e ltac:(fun K e' => eapply (tac_wp_load _ _ _ _ K)) [reshape_expr e ltac:(fun K e' => eapply (tac_wp_load _ _ _ _ K))
|fail 1 "wp_load: cannot find 'Load' in" e]; |fail 1 "wp_load: cannot find 'Load' in" e];
...@@ -196,7 +196,7 @@ Tactic Notation "wp_load" := ...@@ -196,7 +196,7 @@ Tactic Notation "wp_load" :=
Tactic Notation "wp_store" := Tactic Notation "wp_store" :=
iStartProof; iStartProof;
lazymatch goal with lazymatch goal with
| |- envs_entails _ (wp ?E ?e ?Q) => | |- envs_entails _ (wp true ?E ?e ?Q) =>
first first
[reshape_expr e ltac:(fun K e' => [reshape_expr e ltac:(fun K e' =>
eapply (tac_wp_store _ _ _ _ _ K); [apply _|..]) eapply (tac_wp_store _ _ _ _ _ K); [apply _|..])
...@@ -212,7 +212,7 @@ Tactic Notation "wp_store" := ...@@ -212,7 +212,7 @@ Tactic Notation "wp_store" :=
Tactic Notation "wp_cas_fail" := Tactic Notation "wp_cas_fail" :=
iStartProof; iStartProof;
lazymatch goal with lazymatch goal with
| |- envs_entails _ (wp ?E ?e ?Q) => | |- envs_entails _ (wp true ?E ?e ?Q) =>
first first
[reshape_expr e ltac:(fun K e' => [reshape_expr e ltac:(fun K e' =>
eapply (tac_wp_cas_fail _ _ _ _ K); [apply _|apply _|..]) eapply (tac_wp_cas_fail _ _ _ _ K); [apply _|apply _|..])
...@@ -228,7 +228,7 @@ Tactic Notation "wp_cas_fail" := ...@@ -228,7 +228,7 @@ Tactic Notation "wp_cas_fail" :=
Tactic Notation "wp_cas_suc" := Tactic Notation "wp_cas_suc" :=
iStartProof; iStartProof;
lazymatch goal with lazymatch goal with
| |- envs_entails _ (wp ?E ?e ?Q) => | |- envs_entails _ (wp true ?E ?e ?Q) =>
first first
[reshape_expr e ltac:(fun K e' => [reshape_expr e ltac:(fun K e' =>
eapply (tac_wp_cas_suc _ _ _ _ _ K); [apply _|apply _|..]) eapply (tac_wp_cas_suc _ _ _ _ _ K); [apply _|apply _|..])
......
...@@ -187,11 +187,10 @@ Definition is_atomic (e : expr) := ...@@ -187,11 +187,10 @@ Definition is_atomic (e : expr) :=
| App (Rec _ _ (Lit _)) (Lit _) => true | App (Rec _ _ (Lit _)) (Lit _) => true
| _ => false | _ => false
end. end.
Lemma is_atomic_correct e : is_atomic e Atomic (to_expr e). Lemma is_atomic_correct e : is_atomic e StronglyAtomic (to_expr e).
Proof. Proof.
intros He. apply ectx_language_atomic. intros He. apply ectx_language_strongly_atomic.
- intros σ e' σ' ef Hstep; simpl in *. - intros σ e' σ' ef Hstep; simpl in *. revert Hstep.
apply language.val_irreducible; revert Hstep.
destruct e=> //=; repeat (simplify_eq/=; case_match=>//); destruct e=> //=; repeat (simplify_eq/=; case_match=>//);
inversion 1; simplify_eq/=; rewrite ?to_of_val; eauto. inversion 1; simplify_eq/=; rewrite ?to_of_val; eauto.
unfold subst'; repeat (simplify_eq/=; case_match=>//); eauto. unfold subst'; repeat (simplify_eq/=; case_match=>//); eauto.
...@@ -227,11 +226,11 @@ Hint Extern 10 (AsVal _) => solve_as_val : typeclass_instances. ...@@ -227,11 +226,11 @@ Hint Extern 10 (AsVal _) => solve_as_val : typeclass_instances.
Ltac solve_atomic := Ltac solve_atomic :=
match goal with match goal with
| |- Atomic ?e => | |- StronglyAtomic ?e =>
let e' := W.of_expr e in change (Atomic (W.to_expr e')); let e' := W.of_expr e in change (StronglyAtomic (W.to_expr e'));
apply W.is_atomic_correct; vm_compute; exact I apply W.is_atomic_correct; vm_compute; exact I
end. end.
Hint Extern 10 (Atomic _) => solve_atomic : typeclass_instances. Hint Extern 10 (StronglyAtomic _) => solve_atomic : typeclass_instances.
(** Substitution *) (** Substitution *)
Ltac simpl_subst := Ltac simpl_subst :=
......
...@@ -34,23 +34,24 @@ Proof. ...@@ -34,23 +34,24 @@ Proof.
Qed. Qed.
(* Program logic adequacy *) (* Program logic adequacy *)
Record adequate {Λ} (e1 : expr Λ) (σ1 : state Λ) (φ : val Λ Prop) := { Record adequate {Λ} (p : bool) (e1 : expr Λ) (σ1 : state Λ) (φ : val Λ Prop) := {
adequate_result t2 σ2 v2 : adequate_result t2 σ2 v2 :
rtc step ([e1], σ1) (of_val v2 :: t2, σ2) φ v2; rtc step ([e1], σ1) (of_val v2 :: t2, σ2) φ v2;
adequate_safe t2 σ2 e2 : adequate_safe t2 σ2 e2 :
p
rtc step ([e1], σ1) (t2, σ2) rtc step ([e1], σ1) (t2, σ2)
e2 t2 (is_Some (to_val e2) reducible e2 σ2) e2 t2 progressive e2 σ2
}. }.
Theorem adequate_tp_safe {Λ} (e1 : expr Λ) t2 σ1 σ2 φ : Theorem adequate_tp_safe {Λ} (e1 : expr Λ) t2 σ1 σ2 φ :
adequate e1 σ1 φ adequate true e1 σ1 φ
rtc step ([e1], σ1) (t2, σ2) rtc step ([e1], σ1) (t2, σ2)
Forall (λ e, is_Some (to_val e)) t2 t3 σ3, step (t2, σ2) (t3, σ3). Forall (λ e, is_Some (to_val e)) t2 t3 σ3, step (t2, σ2) (t3, σ3).
Proof. Proof.
intros Had ?. intros Had ?.
destruct (decide (Forall (λ e, is_Some (to_val e)) t2)) as [|Ht2]; [by left|]. destruct (decide (Forall (λ e, is_Some (to_val e)) t2)) as [|Ht2]; [by left|].
apply (not_Forall_Exists _), Exists_exists in Ht2; destruct Ht2 as (e2&?&He2). apply (not_Forall_Exists _), Exists_exists in Ht2; destruct Ht2 as (e2&?&He2).
destruct (adequate_safe e1 σ1 φ Had t2 σ2 e2) as [?|(e3&σ3&efs&?)]; destruct (adequate_safe true e1 σ1 φ Had t2 σ2 e2) as [?|(e3&σ3&efs&?)];
rewrite ?eq_None_not_Some; auto. rewrite ?eq_None_not_Some; auto.
{ exfalso. eauto. } { exfalso. eauto. }
destruct (elem_of_list_split t2 e2) as (t2'&t2''&->); auto. destruct (elem_of_list_split t2 e2) as (t2'&t2''&->); auto.
...@@ -58,19 +59,22 @@ Proof. ...@@ -58,19 +59,22 @@ Proof.
Qed. Qed.
Section adequacy. Section adequacy.
Context `{irisG Λ Σ}. Context `{irisG Λ Σ} (p : bool).
Implicit Types e : expr Λ. Implicit Types e : expr Λ.
Implicit Types P Q : iProp Σ. 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 σ := (wsat ownE state_interp σ)%I. Notation world' E σ := (wsat ownE E state_interp σ)%I.
Notation world σ := (world' σ).
Notation wptp t := ([ list] ef t, WP ef {{ _, True }})%I. Notation wp' E e Φ := (WP e @ p; E {{ Φ }})%I.
Notation wp e Φ := (wp' e Φ).
Notation wptp t := ([ list] ef t, WP ef @ p; {{ _, True }})%I.
Lemma wp_step e1 σ1 e2 σ2 efs Φ : Lemma wp_step E e1 σ1 e2 σ2 efs Φ :
prim_step e1 σ1 e2 σ2 efs prim_step e1 σ1 e2 σ2 efs
world σ1 WP e1 {{ Φ }} == |==> (world σ2 WP e2 {{ Φ }} wptp efs). world' E σ1 wp' E e1 Φ == |==> (world' E σ2 wp' E e2 Φ wptp efs).
Proof. Proof.
rewrite {1}wp_unfold /wp_pre. iIntros (?) "[(Hw & HE & Hσ) H]". rewrite {1}wp_unfold /wp_pre. iIntros (?) "[(Hw & HE & Hσ) H]".
rewrite (val_stuck e1 σ1 e2 σ2 efs) // fupd_eq /fupd_def. rewrite (val_stuck e1 σ1 e2 σ2 efs) // fupd_eq /fupd_def.
...@@ -81,8 +85,8 @@ Qed. ...@@ -81,8 +85,8 @@ Qed.
Lemma wptp_step e1 t1 t2 σ1 σ2 Φ : Lemma wptp_step e1 t1 t2 σ1 σ2 Φ :
step (e1 :: t1,σ1) (t2, σ2) step (e1 :: t1,σ1) (t2, σ2)
world σ1 WP e1 {{ Φ }} wptp t1 world σ1 wp e1 Φ wptp t1
== e2 t2', t2 = e2 :: t2' |==> (world σ2 WP e2 {{ Φ }} wptp t2'). == e2 t2', t2 = e2 :: t2' |==> (world σ2 wp e2 Φ wptp 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/=.
...@@ -95,9 +99,9 @@ Qed. ...@@ -95,9 +99,9 @@ Qed.
Lemma wptp_steps n e1 t1 t2 σ1 σ2 Φ : Lemma wptp_steps n e1 t1 t2 σ1 σ2 Φ :
nsteps step n (e1 :: t1, σ1) (t2, σ2) nsteps step n (e1 :: t1, σ1) (t2, σ2)
world σ1 WP e1 {{ Φ }} wptp t1 world σ1 wp e1 Φ wptp t1
Nat.iter (S n) (λ P, |==> P) ( e2 t2', Nat.iter (S n) (λ P, |==> P) ( e2 t2',
t2 = e2 :: t2' world σ2 WP e2 {{ Φ }} wptp t2'). t2 = e2 :: t2' world σ2 wp e2 Φ wptp t2').
Proof. Proof.
revert e1 t1 t2 σ1 σ2; simpl; induction n as [|n IH]=> e1 t1 t2 σ1 σ2 /=. revert e1 t1 t2 σ1 σ2; simpl; induction n as [|n IH]=> e1 t1 t2 σ1 σ2 /=.
{ inversion_clear 1; iIntros "?"; eauto 10. } { inversion_clear 1; iIntros "?"; eauto 10. }
...@@ -121,7 +125,7 @@ Qed. ...@@ -121,7 +125,7 @@ Qed.
Lemma wptp_result n e1 t1 v2 t2 σ1 σ2 φ : Lemma wptp_result n e1 t1 v2 t2 σ1 σ2 φ :
nsteps step n (e1 :: t1, σ1) (of_val v2 :: t2, σ2) nsteps step n (e1 :: t1, σ1) (of_val v2 :: t2, σ2)
world σ1 WP e1 {{ v, ⌜φ v }} wptp t1 ^(S (S n)) ⌜φ v2. world σ1 wp e1 (λ v, ⌜φ v ) wptp t1 ^(S (S n)) ⌜φ v2.
Proof. Proof.
intros. rewrite wptp_steps // laterN_later. apply: bupd_iter_laterN_mono. intros. rewrite wptp_steps // laterN_later. apply: bupd_iter_laterN_mono.
iDestruct 1 as (e2 t2' ?) "((Hw & HE & _) & H & _)"; simplify_eq. iDestruct 1 as (e2 t2' ?) "((Hw & HE & _) & H & _)"; simplify_eq.
...@@ -129,18 +133,20 @@ Proof. ...@@ -129,18 +133,20 @@ Proof.
iMod ("H" with "[Hw HE]") as ">(_ & _ & $)"; iFrame; auto. iMod ("H" with "[Hw HE]") as ">(_ & _ & $)"; iFrame; auto.
Qed. Qed.
Lemma wp_safe e σ Φ : Lemma wp_safe E e σ Φ :
world σ - WP e {{ Φ }} == is_Some (to_val e) reducible e σ. world' E σ - wp' E e Φ == if p then progressive e σ else True.
Proof. Proof.
rewrite wp_unfold /wp_pre. iIntros "(Hw&HE&Hσ) H". rewrite wp_unfold /wp_pre. iIntros "(Hw&HE&Hσ) H".
destruct (to_val e) as [v|] eqn:?; [eauto 10|]. destruct (to_val e) as [v|] eqn:?.
rewrite fupd_eq. iMod ("H" with "Hσ [-]") as ">(?&?&%&?)"; eauto 10 with iFrame. { destruct p; last done. iIntros "!> !> !%". left. by exists v. }
rewrite fupd_eq. iMod ("H" with "Hσ [-]") as ">(?&?&%&?)"; first by iFrame.
destruct p; last done. iIntros "!> !> !%". by right.
Qed. Qed.
Lemma wptp_safe n e1 e2 t1 t2 σ1 σ2 Φ : Lemma wptp_safe n e1 e2 t1 t2 σ1 σ2 Φ :
nsteps step n (e1 :: t1, σ1) (t2, σ2) e2 t2 nsteps step n (e1 :: t1, σ1) (t2, σ2) e2 t2
world σ1 WP e1 {{ Φ }} wptp t1 world σ1 wp e1 Φ wptp t1
^(S (S n)) is_Some (to_val e2) reducible e2 σ2. ^(S (S n)) if p then progressive e2 σ2 else True.
Proof. Proof.
intros ? He2. rewrite wptp_steps // laterN_later. apply: bupd_iter_laterN_mono. intros ? He2. rewrite wptp_steps // laterN_later. apply: bupd_iter_laterN_mono.
iDestruct 1 as (e2' t2' ?) "(Hw & H & Htp)"; simplify_eq. iDestruct 1 as (e2' t2' ?) "(Hw & H & Htp)"; simplify_eq.
...@@ -151,7 +157,7 @@ Qed. ...@@ -151,7 +157,7 @@ Qed.
Lemma wptp_invariance n e1 e2 t1 t2 σ1 σ2 φ Φ : Lemma wptp_invariance n e1 e2 t1 t2 σ1 σ2 φ Φ :
nsteps step n (e1 :: t1, σ1) (t2, σ2) nsteps step n (e1 :: t1, σ1) (t2, σ2)
(state_interp σ2 ={,}= ⌜φ⌝) world σ1 WP e1 {{ Φ }} wptp t1 (state_interp σ2 ={,}= ⌜φ⌝) world σ1 wp e1 Φ wptp t1
^(S (S n)) ⌜φ⌝. ^(S (S n)) ⌜φ⌝.
Proof. Proof.
intros ?. rewrite wptp_steps // bupd_iter_frame_l laterN_later. intros ?. rewrite wptp_steps // bupd_iter_frame_l laterN_later.
...@@ -162,12 +168,12 @@ Proof. ...@@ -162,12 +168,12 @@ Proof.
Qed. Qed.
End adequacy. End adequacy.
Theorem wp_adequacy Σ Λ `{invPreG Σ} e σ φ : Theorem wp_adequacy Σ Λ `{invPreG Σ} p e σ φ :
( `{Hinv : invG Σ}, ( `{Hinv : invG Σ},
(|={}=> stateI : state Λ iProp Σ, (|={}=> stateI : state Λ iProp Σ,
let _ : irisG Λ Σ := IrisG _ _ Hinv stateI in let _ : irisG Λ Σ := IrisG _ _ Hinv stateI in
stateI σ WP e {{ v, ⌜φ v }})%I) stateI σ WP e @ p; {{ v, ⌜φ v }})%I)
adequate e σ φ. adequate p e σ φ.
Proof. Proof.
intros Hwp; split. intros Hwp; split.
- intros t2 σ2 v2 [n ?]%rtc_nsteps. - intros t2 σ2 v2 [n ?]%rtc_nsteps.
...@@ -176,19 +182,19 @@ Proof. ...@@ -176,19 +182,19 @@ Proof.
rewrite fupd_eq in Hwp; iMod (Hwp with "[$Hw $HE]") as ">(Hw & HE & Hwp)". rewrite fupd_eq in Hwp; iMod (Hwp with "[$Hw $HE]") as ">(Hw & HE & Hwp)".
iDestruct "Hwp" as (Istate) "[HI Hwp]". iDestruct "Hwp" as (Istate) "[HI Hwp]".
iApply (@wptp_result _ _ (IrisG _ _ Hinv Istate)); eauto with iFrame. iApply (@wptp_result _ _ (IrisG _ _ Hinv Istate)); eauto with iFrame.
- intros t2 σ2 e2 [n ?]%rtc_nsteps ?. - destruct p; last done. intros t2 σ2 e2 _ [n ?]%rtc_nsteps ?.
eapply (soundness (M:=iResUR Σ) _ (S (S n))). eapply (soundness (M:=iResUR Σ) _ (S (S n))).
iMod wsat_alloc as (Hinv) "[Hw HE]". iMod wsat_alloc as (Hinv) "[Hw HE]".
rewrite fupd_eq in Hwp; iMod (Hwp with "[$Hw $HE]") as ">(Hw & HE & Hwp)". rewrite fupd_eq in Hwp; iMod (Hwp with "[$Hw $HE]") as ">(Hw & HE & Hwp)".
iDestruct "Hwp" as (Istate) "[HI Hwp]". iDestruct "Hwp" as (Istate) "[HI Hwp]".
iApply (@wptp_safe _ _ (IrisG _ _ Hinv Istate)); eauto with iFrame. iApply (@wptp_safe _ _ (IrisG _ _ Hinv Istate) true); eauto with iFrame.
Qed. Qed.
Theorem wp_invariance Σ Λ `{invPreG Σ} e σ1 t2 σ2 φ : Theorem wp_invariance Σ Λ `{invPreG Σ} p e σ1 t2 σ2 φ :
( `{Hinv : invG Σ}, ( `{Hinv : invG Σ},
(|={}=> stateI : state Λ iProp Σ, (|={}=> stateI : state Λ iProp Σ,
let _ : irisG Λ Σ := IrisG _ _ Hinv stateI in let _ : irisG Λ Σ := IrisG _ _ Hinv stateI in
stateI σ1 WP e {{ _, True }} (stateI σ2 ={,}= ⌜φ⌝))%I) stateI σ1 WP e @ p; {{ _, True }} (stateI σ2 ={,}= ⌜φ⌝))%I)
rtc step ([e], σ1) (t2, σ2) rtc step ([e], σ1) (t2, σ2)
φ. φ.
Proof. Proof.
......
...@@ -127,6 +127,16 @@ Section ectx_language. ...@@ -127,6 +127,16 @@ Section ectx_language.
rewrite fill_empty. eapply Hatomic_step. by rewrite fill_empty. rewrite fill_empty. eapply Hatomic_step. by rewrite fill_empty.
Qed. Qed.
Lemma ectx_language_strongly_atomic e :
( σ e' σ' efs, head_step e σ e' σ' efs is_Some (to_val e'))
sub_values e
StronglyAtomic e.
Proof.
intros Hatomic_step Hatomic_fill σ e' σ' efs [K e1' e2' -> -> Hstep].
assert (K = empty_ectx) as -> by eauto 10 using val_stuck.
rewrite fill_empty. eapply Hatomic_step. by rewrite fill_empty.
Qed.
Lemma head_reducible_prim_step e1 σ1 e2 σ2 efs : Lemma head_reducible_prim_step e1 σ1 e2 σ2 efs :
head_reducible e1 σ1 head_reducible e1 σ1
prim_step e1 σ1 e2 σ2 efs prim_step e1 σ1 e2 σ2 efs
......
...@@ -12,61 +12,93 @@ Implicit Types v : val. ...@@ -12,61 +12,93 @@ Implicit Types v : val.
Implicit Types e : expr. Implicit Types e : expr.
Hint Resolve head_prim_reducible head_reducible_prim_step. Hint Resolve head_prim_reducible head_reducible_prim_step.
Lemma wp_ectx_bind {E Φ} K e : Definition head_progressive (e : expr) (σ : state) :=
WP e @ E {{ v, WP fill K (of_val v) @ E {{ Φ }} }} WP fill K e @ E {{ Φ }}. is_Some(to_val e) K e', e = fill K e' head_reducible e' σ.
Lemma progressive_head_progressive e σ :
progressive e σ head_progressive e σ.
Proof.
case=>[?|Hred]; first by left.
right. move: Hred=> [] e' [] σ' [] efs [] K e1' e2' EQ EQ' Hstep. subst.
exists K, e1'. split; first done. by exists e2', σ', efs.
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 {{ Φ }}.
Proof. apply: weakestpre.wp_bind. Qed. Proof. apply: weakestpre.wp_bind. Qed.
Lemma wp_ectx_bind_inv {E Φ} K e : Lemma wp_ectx_bind_inv {p E Φ} K e :
WP fill K e @ E {{ Φ }} WP e @ E {{ v, WP fill K (of_val v) @ 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. Proof. apply: weakestpre.wp_bind_inv. Qed.
Lemma wp_lift_head_step {E Φ} e1 : Lemma wp_lift_head_step {p E Φ} e1 :
to_val e1 = None to_val e1 = None
( σ1, state_interp σ1 ={E,}= ( σ1, state_interp σ1 ={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 WP e2 @ E {{ Φ }} [ list] ef efs, WP ef {{ _, True }}) state_interp σ2 WP e2 @ p; E {{ Φ }} [ list] ef efs, WP ef @ p; {{ _, True }})
WP e1 @ E {{ Φ }}. WP e1 @ p; E {{ Φ }}.
Proof. Proof.
iIntros (?) "H". iApply (wp_lift_step E)=>//. iIntros (σ1) "Hσ". iIntros (?) "H". iApply wp_lift_step=>//. iIntros (σ1) "Hσ".
iMod ("H" $! σ1 with "Hσ") as "[% H]"; iModIntro. iMod ("H" $! σ1 with "Hσ") as "[% H]"; iModIntro.
iSplit; first by eauto. iNext. iIntros (e2 σ2 efs) "%". iSplit; first by eauto. iNext. iIntros (e2 σ2 efs) "%".
iApply "H". by eauto. iApply "H". by eauto.
Qed. Qed.
Lemma wp_lift_pure_head_step {E E' Φ} e1 : Lemma wp_lift_head_stuck E Φ e :
to_val e = None
( σ, state_interp σ ={E,}= ¬ head_progressive e σ⌝)
WP e @ E ?{{ Φ }}.
Proof.
iIntros (?) "H". iApply wp_lift_stuck; first done.
iIntros (σ) "Hσ". iMod ("H" $! _ with "Hσ") as "%". iModIntro. by auto.
Qed.
Lemma wp_lift_pure_head_step {p E E' Φ} e1 :
( σ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 @ E {{ Φ }} [ list] ef efs, WP ef {{ _, True }}) WP e2 @ p; E {{ Φ }} [ list] ef efs, WP ef @ p; {{ _, True }})
WP e1 @ E {{ Φ }}. WP e1 @ p; E {{ Φ }}.
Proof using Hinh. Proof using Hinh.
iIntros (??) "H". iApply wp_lift_pure_step; eauto. iIntros (??) "H". iApply wp_lift_pure_step; eauto.
iApply (step_fupd_wand with "H"); iIntros "H". iApply (step_fupd_wand with "H"); iIntros "H".