Commit e091fc4f authored by Robbert's avatar Robbert

Merge branch 'pureexec' into 'master'

Common tactic machinery for symbolic execution of pure reductions

See merge request FP/iris-coq!64
parents ecbeddd1 3a5c5045
From iris.program_logic Require Export ectx_language ectxi_language. From iris.program_logic Require Export language ectx_language ectxi_language.
From iris.algebra Require Export ofe. From iris.algebra Require Export ofe.
From stdpp Require Export strings. From stdpp Require Export strings.
From stdpp Require Import gmap. From stdpp Require Import gmap.
...@@ -109,6 +109,14 @@ Fixpoint to_val (e : expr) : option val := ...@@ -109,6 +109,14 @@ Fixpoint to_val (e : expr) : option val :=
| _ => None | _ => None
end. end.
Class AsRec (e : expr) (f x : binder) (erec : expr) :=
as_rec : e = Rec f x erec.
Instance AsRec_rec f x e : AsRec (Rec f x e) f x e := eq_refl.
Instance AsRec_rec_locked_val v f x e :
AsRec (of_val v) f x e AsRec (of_val (locked v)) f x e.
Proof. by unlock. Qed.
(** The state: heaps of vals. *) (** The state: heaps of vals. *)
Definition state := gmap loc val. Definition state := gmap loc val.
...@@ -411,6 +419,9 @@ Proof. intros. by apply is_closed_weaken with [], list_subseteq_nil. Qed. ...@@ -411,6 +419,9 @@ Proof. intros. by apply is_closed_weaken with [], list_subseteq_nil. Qed.
Lemma is_closed_of_val X v : is_closed X (of_val v). Lemma is_closed_of_val X v : is_closed X (of_val v).
Proof. apply is_closed_weaken_nil. induction v; simpl; auto. Qed. Proof. apply is_closed_weaken_nil. induction v; simpl; auto. Qed.
Lemma is_closed_to_val X e v : to_val e = Some v is_closed X e.
Proof. intros Hev; rewrite -(of_to_val e v Hev); apply is_closed_of_val. Qed.
Lemma is_closed_subst X e x es : Lemma is_closed_subst X e x es :
is_closed [] es is_closed (x :: X) e is_closed X (subst x es e). is_closed [] es is_closed (x :: X) e is_closed X (subst x es e).
Proof. Proof.
......
...@@ -13,5 +13,5 @@ Lemma wp_assert `{heapG Σ} E (Φ : val → iProp Σ) e `{!Closed [] e} : ...@@ -13,5 +13,5 @@ Lemma wp_assert `{heapG Σ} E (Φ : val → iProp Σ) e `{!Closed [] e} :
WP e @ E {{ v, v = #true Φ #() }} - WP assert: e @ E {{ Φ }}. WP e @ E {{ v, v = #true Φ #() }} - WP assert: e @ E {{ Φ }}.
Proof. Proof.
iIntros "HΦ". rewrite /assert. wp_let. wp_seq. iIntros "HΦ". rewrite /assert. wp_let. wp_seq.
iApply (wp_wand with "HΦ"). iIntros (v) "[% ?]"; subst. by wp_if. wp_apply (wp_wand with "HΦ"). iIntros (v) "[% ?]"; subst. by wp_if.
Qed. Qed.
...@@ -21,15 +21,15 @@ Context `{!heapG Σ, !spawnG Σ}. ...@@ -21,15 +21,15 @@ Context `{!heapG Σ, !spawnG Σ}.
brought together. That is strictly stronger than first stripping a later brought together. That is strictly stronger than first stripping a later
and then merging them, as demonstrated by [tests/joining_existentials.v]. and then merging them, as demonstrated by [tests/joining_existentials.v].
This is why these are not Texan triples. *) This is why these are not Texan triples. *)
Lemma par_spec (Ψ1 Ψ2 : val iProp Σ) e (f1 f2 : val) (Φ : val iProp Σ) : Lemma par_spec (Ψ1 Ψ2 : val iProp Σ) e (f1 f2 : val) (Φ : val iProp Σ)
to_val e = Some (f1,f2)%V `{Hef : !IntoVal e (f1,f2)} :
WP f1 #() {{ Ψ1 }} - WP f2 #() {{ Ψ2 }} - WP f1 #() {{ Ψ1 }} - WP f2 #() {{ Ψ2 }} -
( v1 v2, Ψ1 v1 Ψ2 v2 - Φ (v1,v2)%V) - ( v1 v2, Ψ1 v1 Ψ2 v2 - Φ (v1,v2)%V) -
WP par e {{ Φ }}. WP par e {{ Φ }}.
Proof. Proof.
iIntros (?) "Hf1 Hf2 HΦ". apply of_to_val in Hef as <-. iIntros "Hf1 Hf2 HΦ".
rewrite /par. wp_value. wp_let. wp_proj. rewrite /par /=. wp_let. wp_proj.
wp_apply (spawn_spec parN with "Hf1"); try wp_done; try solve_ndisj. wp_apply (spawn_spec parN with "Hf1").
iIntros (l) "Hl". wp_let. wp_proj. wp_bind (f2 _). iIntros (l) "Hl". wp_let. wp_proj. wp_bind (f2 _).
iApply (wp_wand with "Hf2"); iIntros (v) "H2". wp_let. iApply (wp_wand with "Hf2"); iIntros (v) "H2". wp_let.
wp_apply (join_spec with "[$Hl]"). iIntros (w) "H1". wp_apply (join_spec with "[$Hl]"). iIntros (w) "H1".
...@@ -42,7 +42,7 @@ Lemma wp_par (Ψ1 Ψ2 : val → iProp Σ) ...@@ -42,7 +42,7 @@ Lemma wp_par (Ψ1 Ψ2 : val → iProp Σ)
( v1 v2, Ψ1 v1 Ψ2 v2 - Φ (v1,v2)%V) - ( v1 v2, Ψ1 v1 Ψ2 v2 - Φ (v1,v2)%V) -
WP e1 ||| e2 {{ Φ }}. WP e1 ||| e2 {{ Φ }}.
Proof. Proof.
iIntros "H1 H2 H". iApply (par_spec Ψ1 Ψ2 with "[H1] [H2] [H]"); try wp_done. iIntros "H1 H2 H". iApply (par_spec Ψ1 Ψ2 with "[H1] [H2] [H]").
by wp_let. by wp_let. auto. by wp_let. by wp_let. auto.
Qed. Qed.
End proof. End proof.
...@@ -44,11 +44,10 @@ Global Instance join_handle_ne n l : ...@@ -44,11 +44,10 @@ Global Instance join_handle_ne n l :
Proof. solve_proper. Qed. Proof. solve_proper. Qed.
(** The main proofs. *) (** The main proofs. *)
Lemma spawn_spec (Ψ : val iProp Σ) e (f : val) : Lemma spawn_spec (Ψ : val iProp Σ) e (f : val) `{Hef : !IntoVal e f} :
to_val e = Some f
{{{ WP f #() {{ Ψ }} }}} spawn e {{{ l, RET #l; join_handle l Ψ }}}. {{{ WP f #() {{ Ψ }} }}} spawn e {{{ l, RET #l; join_handle l Ψ }}}.
Proof. Proof.
iIntros (<-%of_to_val Φ) "Hf HΦ". rewrite /spawn /=. apply of_to_val in Hef as <-. iIntros (Φ) "Hf HΦ". rewrite /spawn /=.
wp_let. wp_alloc l as "Hl". wp_let. wp_let. wp_alloc l as "Hl". wp_let.
iMod (own_alloc (Excl ())) as (γ) "Hγ"; first done. iMod (own_alloc (Excl ())) as (γ) "Hγ"; first done.
iMod (inv_alloc N _ (spawn_inv γ l Ψ) with "[Hl]") as "#?". iMod (inv_alloc N _ (spawn_inv γ l Ψ) with "[Hl]") as "#?".
......
...@@ -93,14 +93,15 @@ Section proof. ...@@ -93,14 +93,15 @@ Section proof.
- iDestruct "Ha" as "[Hainv [[Ho HR] | Haown]]". - iDestruct "Ha" as "[Hainv [[Ho HR] | Haown]]".
+ iMod ("Hclose" with "[Hlo Hln Hainv Ht]") as "_". + iMod ("Hclose" with "[Hlo Hln Hainv Ht]") as "_".
{ iNext. iExists o, n. iFrame. eauto. } { iNext. iExists o, n. iFrame. eauto. }
iModIntro. wp_let. wp_op=>[_|[]] //. iModIntro. wp_let. wp_op. case_bool_decide; [|done].
wp_if. wp_if.
iApply ("HΦ" with "[-]"). rewrite /locked. iFrame. eauto. iApply ("HΦ" with "[-]"). rewrite /locked. iFrame. eauto.
+ iDestruct (own_valid_2 with "Ht Haown") as % [_ ?%gset_disj_valid_op]. + iDestruct (own_valid_2 with "Ht Haown") as % [_ ?%gset_disj_valid_op].
set_solver. set_solver.
- iMod ("Hclose" with "[Hlo Hln Ha]"). - iMod ("Hclose" with "[Hlo Hln Ha]").
{ iNext. iExists o, n. by iFrame. } { iNext. iExists o, n. by iFrame. }
iModIntro. wp_let. wp_op=>[[/Nat2Z.inj //]|?]. iModIntro. wp_let.
wp_op. case_bool_decide; [simplify_eq |].
wp_if. iApply ("IH" with "Ht"). iNext. by iExact "HΦ". wp_if. iApply ("IH" with "Ht"). iNext. by iExact "HΦ".
Qed. Qed.
......
From iris.base_logic Require Export gen_heap. From iris.base_logic Require Export gen_heap.
From iris.program_logic Require Export weakestpre. From iris.program_logic Require Export weakestpre lifting.
From iris.program_logic Require Import ectx_lifting. From iris.program_logic Require Import ectx_lifting.
From iris.heap_lang Require Export lang. From iris.heap_lang Require Export lang.
From iris.heap_lang Require Import tactics. From iris.heap_lang Require Import tactics.
...@@ -80,86 +80,52 @@ Proof. ...@@ -80,86 +80,52 @@ Proof.
- intros; inv_head_step; eauto. - intros; inv_head_step; eauto.
Qed. Qed.
Lemma wp_rec E f x erec e1 e2 Φ : Local Ltac solve_exec_safe := intros; subst; do 3 eexists; econstructor; eauto.
e1 = Rec f x erec Local Ltac solve_exec_puredet := simpl; intros; by inv_head_step.
is_Some (to_val e2) Local Ltac solve_pureexec :=
Closed (f :b: x :b: []) erec repeat lazymatch goal with
WP subst' x e2 (subst' f e1 erec) @ E {{ Φ }} WP App e1 e2 @ E {{ Φ }}. | H: IntoVal ?e _ |- _ => rewrite -(of_to_val e _ into_val); clear H
Proof. | H: AsRec _ _ _ _ |- _ => rewrite H; clear H
intros -> [v2 ?] ?. rewrite -(wp_lift_pure_det_head_step_no_fork' (App _ _) end;
(subst' x e2 (subst' f (Rec f x erec) erec))); eauto. apply hoist_pred_pureexec; intros; destruct_and?;
intros; inv_head_step; eauto. apply det_head_step_pureexec; [ solve_exec_safe | solve_exec_puredet ].
Qed.
Lemma wp_un_op E op e v v' Φ : Global Instance pure_rec f x (erec e1 e2 : expr) (v2 : val)
to_val e = Some v `{!IntoVal e2 v2, AsRec e1 f x erec, Closed (f :b: x :b: []) erec} :
un_op_eval op v = Some v' PureExec True (App e1 e2) (subst' x e2 (subst' f e1 erec)).
Φ v' WP UnOp op e @ E {{ Φ }}. Proof. solve_pureexec. Qed.
Proof.
intros. rewrite -(wp_lift_pure_det_head_step_no_fork' (UnOp op _) (of_val v'))
-?wp_value'; eauto.
intros; inv_head_step; eauto.
Qed.
Lemma wp_bin_op E op e1 e2 v1 v2 v' Φ : Global Instance pure_unop op e v v' `{!IntoVal e v} :
to_val e1 = Some v1 to_val e2 = Some v2 PureExec (un_op_eval op v = Some v') (UnOp op e) (of_val v').
bin_op_eval op v1 v2 = Some v' Proof. solve_pureexec. Qed.
(Φ v') WP BinOp op e1 e2 @ E {{ Φ }}.
Proof.
intros. rewrite -(wp_lift_pure_det_head_step_no_fork' (BinOp op _ _) (of_val v'))
-?wp_value'; eauto.
intros; inv_head_step; eauto.
Qed.
Lemma wp_if_true E e1 e2 Φ : Global Instance pure_binop op e1 e2 v1 v2 v' `{!IntoVal e1 v1, !IntoVal e2 v2} :
WP e1 @ E {{ Φ }} WP If (Lit (LitBool true)) e1 e2 @ E {{ Φ }}. PureExec (bin_op_eval op v1 v2 = Some v') (BinOp op e1 e2) (of_val v').
Proof. Proof. solve_pureexec. Qed.
apply wp_lift_pure_det_head_step_no_fork'; eauto.
intros; inv_head_step; eauto.
Qed.
Lemma wp_if_false E e1 e2 Φ : Global Instance pure_if_true e1 e2 :
WP e2 @ E {{ Φ }} WP If (Lit (LitBool false)) e1 e2 @ E {{ Φ }}. PureExec True (If (Lit (LitBool true)) e1 e2) e1.
Proof. Proof. solve_pureexec. Qed.
apply wp_lift_pure_det_head_step_no_fork'; eauto.
intros; inv_head_step; eauto.
Qed.
Lemma wp_fst E e1 v1 e2 Φ : Global Instance pure_if_false e1 e2 :
to_val e1 = Some v1 is_Some (to_val e2) PureExec True (If (Lit (LitBool false)) e1 e2) e2.
Φ v1 WP Fst (Pair e1 e2) @ E {{ Φ }}. Proof. solve_pureexec. Qed.
Proof.
intros ? [v2 ?].
rewrite -(wp_lift_pure_det_head_step_no_fork' (Fst _) e1) -?wp_value; eauto.
intros; inv_head_step; eauto.
Qed.
Lemma wp_snd E e1 e2 v2 Φ : Global Instance pure_fst e1 e2 v1 v2 `{!IntoVal e1 v1, !IntoVal e2 v2} :
is_Some (to_val e1) to_val e2 = Some v2 PureExec True (Fst (Pair e1 e2)) e1.
Φ v2 WP Snd (Pair e1 e2) @ E {{ Φ }}. Proof. solve_pureexec. Qed.
Proof.
intros [v1 ?] ?.
rewrite -(wp_lift_pure_det_head_step_no_fork' (Snd _) e2) -?wp_value; eauto.
intros; inv_head_step; eauto.
Qed.
Lemma wp_case_inl E e0 e1 e2 Φ : Global Instance pure_snd e1 e2 v1 v2 `{!IntoVal e1 v1, !IntoVal e2 v2} :
is_Some (to_val e0) PureExec True (Snd (Pair e1 e2)) e2.
WP App e1 e0 @ E {{ Φ }} WP Case (InjL e0) e1 e2 @ E {{ Φ }}. Proof. solve_pureexec. Qed.
Proof.
intros [v0 ?].
rewrite -(wp_lift_pure_det_head_step_no_fork' (Case _ _ _) (App e1 e0)); eauto.
intros; inv_head_step; eauto.
Qed.
Lemma wp_case_inr E e0 e1 e2 Φ : Global Instance pure_case_inl e0 v e1 e2 `{!IntoVal e0 v} :
is_Some (to_val e0) PureExec True (Case (InjL e0) e1 e2) (App e1 e0).
WP App e2 e0 @ E {{ Φ }} WP Case (InjR e0) e1 e2 @ E {{ Φ }}. Proof. solve_pureexec. Qed.
Proof.
intros [v0 ?]. Global Instance pure_case_inr e0 v e1 e2 `{!IntoVal e0 v} :
rewrite -(wp_lift_pure_det_head_step_no_fork' (Case _ _ _) (App e2 e0)); eauto. PureExec True (Case (InjR e0) e1 e2) (App e2 e0).
intros; inv_head_step; eauto. Proof. solve_pureexec. Qed.
Qed.
(** Heap *) (** Heap *)
Lemma wp_alloc E e v : Lemma wp_alloc E e v :
...@@ -221,22 +187,10 @@ Proof. ...@@ -221,22 +187,10 @@ Proof.
Qed. Qed.
(** Proof rules for derived constructs *) (** Proof rules for derived constructs *)
Lemma wp_lam E x elam e1 e2 Φ :
e1 = Lam x elam
is_Some (to_val e2)
Closed (x :b: []) elam
WP subst' x e2 elam @ E {{ Φ }} WP App e1 e2 @ E {{ Φ }}.
Proof. intros. by rewrite -(wp_rec _ BAnon) //. Qed.
Lemma wp_let E x e1 e2 Φ :
is_Some (to_val e1) Closed (x :b: []) e2
WP subst' x e1 e2 @ E {{ Φ }} WP Let x e1 e2 @ E {{ Φ }}.
Proof. by apply wp_lam. Qed.
Lemma wp_seq E e1 e2 Φ : Lemma wp_seq E e1 e2 Φ :
is_Some (to_val e1) Closed [] e2 is_Some (to_val e1) Closed [] e2
WP e2 @ E {{ Φ }} WP Seq e1 e2 @ E {{ Φ }}. WP e2 @ E {{ Φ }} WP Seq e1 e2 @ E {{ Φ }}.
Proof. intros ??. by rewrite -wp_let. Qed. Proof. iIntros ([? ?] ?). rewrite -wp_pure_step_later; by eauto. Qed.
Lemma wp_skip E Φ : Φ (LitV LitUnit) WP Skip @ E {{ Φ }}. Lemma wp_skip E Φ : Φ (LitV LitUnit) WP Skip @ E {{ Φ }}.
Proof. rewrite -wp_seq; last eauto. by rewrite -wp_value. Qed. Proof. rewrite -wp_seq; last eauto. by rewrite -wp_value. Qed.
...@@ -244,38 +198,10 @@ Proof. rewrite -wp_seq; last eauto. by rewrite -wp_value. Qed. ...@@ -244,38 +198,10 @@ Proof. rewrite -wp_seq; last eauto. by rewrite -wp_value. Qed.
Lemma wp_match_inl E e0 x1 e1 x2 e2 Φ : Lemma wp_match_inl E e0 x1 e1 x2 e2 Φ :
is_Some (to_val e0) Closed (x1 :b: []) e1 is_Some (to_val e0) Closed (x1 :b: []) e1
WP subst' x1 e0 e1 @ E {{ Φ }} WP Match (InjL e0) x1 e1 x2 e2 @ E {{ Φ }}. WP subst' x1 e0 e1 @ E {{ Φ }} WP Match (InjL e0) x1 e1 x2 e2 @ E {{ Φ }}.
Proof. intros. by rewrite -wp_case_inl // -[X in _ X]later_intro -wp_let. Qed. Proof. iIntros ([? ?] ?) "?". rewrite -!wp_pure_step_later; by eauto. Qed.
Lemma wp_match_inr E e0 x1 e1 x2 e2 Φ : Lemma wp_match_inr E e0 x1 e1 x2 e2 Φ :
is_Some (to_val e0) Closed (x2 :b: []) e2 is_Some (to_val e0) Closed (x2 :b: []) e2
WP subst' x2 e0 e2 @ E {{ Φ }} WP Match (InjR e0) x1 e1 x2 e2 @ E {{ Φ }}. WP subst' x2 e0 e2 @ E {{ Φ }} WP Match (InjR e0) x1 e1 x2 e2 @ E {{ Φ }}.
Proof. intros. by rewrite -wp_case_inr // -[X in _ X]later_intro -wp_let. Qed. Proof. iIntros ([? ?] ?) "?". rewrite -!wp_pure_step_later; by eauto. Qed.
Lemma wp_le E (n1 n2 : Z) P Φ :
(n1 n2 P Φ (LitV (LitBool true)))
(n2 < n1 P Φ (LitV (LitBool false)))
P WP BinOp LeOp (Lit (LitInt n1)) (Lit (LitInt n2)) @ E {{ Φ }}.
Proof.
intros. rewrite -wp_bin_op //; [].
destruct (bool_decide_reflect (n1 n2)); by eauto with omega.
Qed.
Lemma wp_lt E (n1 n2 : Z) P Φ :
(n1 < n2 P Φ (LitV (LitBool true)))
(n2 n1 P Φ (LitV (LitBool false)))
P WP BinOp LtOp (Lit (LitInt n1)) (Lit (LitInt n2)) @ E {{ Φ }}.
Proof.
intros. rewrite -wp_bin_op //; [].
destruct (bool_decide_reflect (n1 < n2)); by eauto with omega.
Qed.
Lemma wp_eq E e1 e2 v1 v2 P Φ :
to_val e1 = Some v1 to_val e2 = Some v2
(v1 = v2 P Φ (LitV (LitBool true)))
(v1 v2 P Φ (LitV (LitBool false)))
P WP BinOp EqOp e1 e2 @ E {{ Φ }}.
Proof.
intros. rewrite -wp_bin_op //; [].
destruct (bool_decide_reflect (v1 = v2)); by eauto.
Qed.
End lifting. End lifting.
This diff is collapsed.
...@@ -8,7 +8,8 @@ expressions into this type we can implementation substitution, closedness ...@@ -8,7 +8,8 @@ expressions into this type we can implementation substitution, closedness
checking, atomic checking, and conversion into values, by computation. *) checking, atomic checking, and conversion into values, by computation. *)
Module W. Module W.
Inductive expr := Inductive expr :=
| Val (v : val) (* Value together with the original expression *)
| Val (v : val) (e : heap_lang.expr) (H : to_val e = Some v)
| ClosedExpr (e : heap_lang.expr) `{!Closed [] e} | ClosedExpr (e : heap_lang.expr) `{!Closed [] e}
(* Base lambda calculus *) (* Base lambda calculus *)
| Var (x : string) | Var (x : string)
...@@ -37,7 +38,7 @@ Inductive expr := ...@@ -37,7 +38,7 @@ Inductive expr :=
Fixpoint to_expr (e : expr) : heap_lang.expr := Fixpoint to_expr (e : expr) : heap_lang.expr :=
match e with match e with
| Val v => of_val v | Val v e' _ => e'
| ClosedExpr e _ => e | ClosedExpr e _ => e
| Var x => heap_lang.Var x | Var x => heap_lang.Var x
| Rec f x e => heap_lang.Rec f x (to_expr e) | Rec f x e => heap_lang.Rec f x (to_expr e)
...@@ -90,13 +91,16 @@ Ltac of_expr e := ...@@ -90,13 +91,16 @@ Ltac of_expr e :=
let e0 := of_expr e0 in let e1 := of_expr e1 in let e2 := of_expr e2 in let e0 := of_expr e0 in let e1 := of_expr e1 in let e2 := of_expr e2 in
constr:(CAS e0 e1 e2) constr:(CAS e0 e1 e2)
| to_expr ?e => e | to_expr ?e => e
| of_val ?v => constr:(Val v) | of_val ?v => constr:(Val v (of_val v) (to_of_val v))
| _ => match goal with H : Closed [] e |- _ => constr:(@ClosedExpr e H) end | _ => match goal with
| H : to_val e = Some ?v |- _ => constr:(Val v e H)
| H : Closed [] e |- _ => constr:(@ClosedExpr e H)
end
end. end.
Fixpoint is_closed (X : list string) (e : expr) : bool := Fixpoint is_closed (X : list string) (e : expr) : bool :=
match e with match e with
| Val _ | ClosedExpr _ _ => true | Val _ _ _ | ClosedExpr _ _ => true
| Var x => bool_decide (x X) | Var x => bool_decide (x X)
| Rec f x e => is_closed (f :b: x :b: X) e | Rec f x e => is_closed (f :b: x :b: X) e
| Lit _ => true | Lit _ => true
...@@ -110,7 +114,7 @@ Fixpoint is_closed (X : list string) (e : expr) : bool := ...@@ -110,7 +114,7 @@ Fixpoint is_closed (X : list string) (e : expr) : bool :=
Lemma is_closed_correct X e : is_closed X e heap_lang.is_closed X (to_expr e). Lemma is_closed_correct X e : is_closed X e heap_lang.is_closed X (to_expr e).
Proof. Proof.
revert X. revert X.
induction e; naive_solver eauto using is_closed_of_val, is_closed_weaken_nil. induction e; naive_solver eauto using is_closed_of_val, is_closed_to_val, is_closed_weaken_nil.
Qed. Qed.
(* We define [to_val (ClosedExpr _)] to be [None] since [ClosedExpr] (* We define [to_val (ClosedExpr _)] to be [None] since [ClosedExpr]
...@@ -119,7 +123,7 @@ about apart from being closed. Notice that the reverse implication of ...@@ -119,7 +123,7 @@ about apart from being closed. Notice that the reverse implication of
[to_val_Some] thus does not hold. *) [to_val_Some] thus does not hold. *)
Fixpoint to_val (e : expr) : option val := Fixpoint to_val (e : expr) : option val :=
match e with match e with
| Val v => Some v | Val v _ _ => Some v
| Rec f x e => | Rec f x e =>
if decide (is_closed (f :b: x :b: []) e) is left H if decide (is_closed (f :b: x :b: []) e) is left H
then Some (@RecV f x (to_expr e) (is_closed_correct _ _ H)) else None then Some (@RecV f x (to_expr e) (is_closed_correct _ _ H)) else None
...@@ -142,7 +146,7 @@ Proof. intros [v ?]; exists v; eauto using to_val_Some. Qed. ...@@ -142,7 +146,7 @@ Proof. intros [v ?]; exists v; eauto using to_val_Some. Qed.
Fixpoint subst (x : string) (es : expr) (e : expr) : expr := Fixpoint subst (x : string) (es : expr) (e : expr) : expr :=
match e with match e with
| Val v => Val v | Val v e H => Val v e H
| ClosedExpr e H => @ClosedExpr e H | ClosedExpr e H => @ClosedExpr e H
| Var y => if decide (x = y) then es else Var y | Var y => if decide (x = y) then es else Var y
| Rec f y e => | Rec f y e =>
...@@ -168,7 +172,7 @@ Lemma to_expr_subst x er e : ...@@ -168,7 +172,7 @@ Lemma to_expr_subst x er e :
to_expr (subst x er e) = heap_lang.subst x (to_expr er) (to_expr e). to_expr (subst x er e) = heap_lang.subst x (to_expr er) (to_expr e).
Proof. Proof.
induction e; simpl; repeat case_decide; induction e; simpl; repeat case_decide;
f_equal; auto using subst_is_closed_nil, is_closed_of_val, eq_sym. f_equal; eauto using subst_is_closed_nil, is_closed_of_val, is_closed_to_val, eq_sym.
Qed. Qed.
Definition atomic (e : expr) := Definition atomic (e : expr) :=
...@@ -213,11 +217,15 @@ Ltac solve_to_val := ...@@ -213,11 +217,15 @@ Ltac solve_to_val :=
match goal with match goal with
| |- to_val ?e = Some ?v => | |- to_val ?e = Some ?v =>
let e' := W.of_expr e in change (to_val (W.to_expr e') = Some v); let e' := W.of_expr e in change (to_val (W.to_expr e') = Some v);
apply W.to_val_Some; simpl; unfold W.to_expr; unlock; reflexivity apply W.to_val_Some; simpl; unfold W.to_expr; reflexivity
| |- IntoVal ?e ?v =>
let e' := W.of_expr e in change (to_val (W.to_expr e') = Some v);
apply W.to_val_Some; simpl; unfold W.to_expr; reflexivity
| |- is_Some (to_val ?e) => | |- is_Some (to_val ?e) =>
let e' := W.of_expr e in change (is_Some (to_val (W.to_expr e'))); let e' := W.of_expr e in change (is_Some (to_val (W.to_expr e')));
apply W.to_val_is_Some, (bool_decide_unpack _); vm_compute; exact I apply W.to_val_is_Some, (bool_decide_unpack _); vm_compute; exact I
end. end.
Hint Extern 10 (IntoVal _ _) => solve_to_val : typeclass_instances.
Ltac solve_atomic := Ltac solve_atomic :=
match goal with match goal with
......
...@@ -150,6 +150,18 @@ Section ectx_language. ...@@ -150,6 +150,18 @@ Section ectx_language.
exists (fill K' e2''); rewrite -fill_comp; split; auto. exists (fill K' e2''); rewrite -fill_comp; split; auto.
econstructor; eauto. econstructor; eauto.
Qed. Qed.
Lemma det_head_step_pureexec e1 e2 :
( σ, head_reducible e1 σ)
( σ1 e2' σ2 efs, head_step e1 σ1 e2' σ2 efs σ1 = σ2 e2=e2' efs = [])
PureExec True e1 e2.
Proof.
intros Hp1 Hp2. split.
- intros σ _. destruct (Hp1 σ) as (e2' & σ2 & efs & ?).
eexists e2', σ2, efs.
eapply (Ectx_step _ _ _ _ _ empty_ectx); eauto using fill_empty.
- intros σ1 e2' σ2 efs _ ?%head_reducible_prim_step; eauto.
Qed.
End ectx_language. End ectx_language.
Arguments ectx_lang _ {_ _ _ _}. Arguments ectx_lang _ {_ _ _ _}.
...@@ -16,6 +16,10 @@ Lemma wp_ectx_bind {E Φ} K e : ...@@ -16,6 +16,10 @@ Lemma wp_ectx_bind {E Φ} K e :
WP e @ E {{ v, WP fill K (of_val v) @ E {{ Φ }} }} WP fill K e @ E {{ Φ }}. WP e @ E {{ v, WP fill K (of_val v) @ E {{ Φ }} }} WP fill K e @ E {{ Φ }}.
Proof. apply: weakestpre.wp_bind. Qed. Proof. apply: weakestpre.wp_bind. Qed.
Lemma wp_ectx_bind_inv {E Φ} K e :
WP fill K e @ E {{ Φ }} WP e @ E {{ v, WP fill K (of_val v) @ E {{ Φ }} }}.
Proof. apply: weakestpre.wp_bind_inv. Qed.
Lemma wp_lift_head_step {E Φ} e1 : Lemma wp_lift_head_step {E Φ} e1 :
to_val e1 = None to_val e1 = None
( σ1, state_interp σ1 ={E,}= ( σ1, state_interp σ1 ={E,}=
......
...@@ -93,4 +93,20 @@ Section language. ...@@ -93,4 +93,20 @@ Section language.
exists (tl' ++ e2 :: tr' ++ efs); split; [|by econstructor]. exists (tl' ++ e2 :: tr' ++ efs); split; [|by econstructor].
by rewrite -!Permutation_middle !assoc_L Ht. by rewrite -!Permutation_middle !assoc_L Ht.
Qed. Qed.
Class PureExec (P : Prop) (e1 e2 : expr Λ) := </