Updated semantics and worked on rules

parent 4f51005a
Pipeline #6998 canceled with stages
......@@ -66,22 +66,22 @@ Inductive expr :=
| CAS (e0 : expr) (e1 : expr) (e2 : expr)
| FAA (e1 : expr) (e2 : expr)
(* Process *)
| Start (c e : expr)
| Start (e : expr)
(* Channels *)
| NewChan
| Send (c e : expr)
| Recv (c : expr).
(* | NewChan. *)
(* Bind Scope expr_scope with expr. *)
Fixpoint is_closed (X : list string) (e : expr) : bool :=
match e with
| Var x => bool_decide (x X)
| Rec f x e => is_closed (f :b: x :b: X) e
| Lit _ | NewChan => true
| UnOp _ e | Fst e | Snd e | InjL e | InjR e | Fork e | Alloc e | Load e | Recv e =>
| Lit _ (* | NewChan *) => true
| UnOp _ e | Fst e | Snd e | InjL e | InjR e | Fork e | Alloc e | Load e | Recv e | Start e =>
is_closed X e
| App e1 e2 | BinOp _ e1 e2 | Pair e1 e2 | Store e1 e2 | FAA e1 e2 | Send e1 e2 | Start e1 e2 =>
| App e1 e2 | BinOp _ e1 e2 | Pair e1 e2 | Store e1 e2 | FAA e1 e2 | Send e1 e2 =>
is_closed X e1 && is_closed X e2
| If e0 e1 e2 | Case e0 e1 e2 | CAS e0 e1 e2 =>
is_closed X e0 && is_closed X e1 && is_closed X e2
......@@ -221,10 +221,11 @@ Proof.
| Store e1 e2 => GenNode 14 [go e1; go e2]
| CAS e0 e1 e2 => GenNode 15 [go e0; go e1; go e2]
| FAA e1 e2 => GenNode 16 [go e1; go e2]
| Start e1 e2 => GenNode 17 [go e1; go e2] (* Added *)
| NewChan => GenNode 18 []
| Send e1 e2 => GenNode 19 [go e1; go e2]
| Recv e => GenNode 20 [go e]
| Start e => GenNode 17 [go e]
(* | Start e1 e2 => GenNode 17 [go e1; go e2] *)
| Send e1 e2 => GenNode 18 [go e1; go e2]
| Recv e => GenNode 19 [go e]
(* | NewChan => GenNode 20 [] *)
end).
set (dec := fix go e :=
match e with
......@@ -247,10 +248,11 @@ Proof.
| GenNode 14 [e1; e2] => Store (go e1) (go e2)
| GenNode 15 [e0; e1; e2] => CAS (go e0) (go e1) (go e2)
| GenNode 16 [e1; e2] => FAA (go e1) (go e2)
| GenNode 17 [e1; e2] => Start (go e1) (go e2) (* Added *)
| GenNode 18 [] => NewChan
| GenNode 19 [e1; e2] => Send (go e1) (go e2)
| GenNode 20 [e] => Recv (go e)
| GenNode 17 [e] => Start (go e)
(* | GenNode 17 [e1; e2] => Start (go e1) (go e2) *)
| GenNode 18 [e1; e2] => Send (go e1) (go e2)
| GenNode 19 [e] => Recv (go e)
(* | GenNode 20 [] => NewChan *)
| _ => Lit LitUnit (* dummy *)
end).
refine (inj_countable' enc dec _). intros e. induction e; f_equal/=; auto.
......@@ -289,7 +291,8 @@ Inductive ectx_item :=
| CasRCtx (v0 : val) (v1 : val)
| FaaLCtx (e2 : expr)
| FaaRCtx (v1 : val)
| StartCtx (e2 : expr)
| StartCtx
(* | StartCtx (e2 : expr) *)
(* | StartLCtx (e2 : expr) *)
(* | StartRCtx (v1 : val) *)
| SendLCtx (e2 : expr)
......@@ -320,7 +323,8 @@ Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
| CasRCtx v0 v1 => CAS (of_val v0) (of_val v1) e
| FaaLCtx e2 => FAA e e2
| FaaRCtx v1 => FAA (of_val v1) e
| StartCtx e2 => Start e e2
| StartCtx => Start e
(* | StartCtx e2 => Start e e2 *)
(* | StartLCtx e2 => Start e e2 *)
(* | StartRCtx v1 => Start (of_val v1) e *)
| SendLCtx e2 => Send e e2
......@@ -351,10 +355,10 @@ Fixpoint subst (x : string) (es : expr) (e : expr) : expr :=
| Store e1 e2 => Store (subst x es e1) (subst x es e2)
| CAS e0 e1 e2 => CAS (subst x es e0) (subst x es e1) (subst x es e2)
| FAA e1 e2 => FAA (subst x es e1) (subst x es e2)
| Start e1 e2 => Start (subst x es e1) (subst x es e2)
| NewChan => NewChan
| Start e => Start (subst x es e)
| Send e1 e2 => Send (subst x es e1) (subst x es e2)
| Recv e => Recv (subst x es e)
(* | NewChan => NewChan *)
end.
Definition subst' (mx : binder) (es : expr) : expr expr :=
......@@ -472,12 +476,12 @@ Definition channels := gmap loc buffer.
Definition state' := prod heap channels.
Inductive head_step' : expr state' expr state' list (expr) Prop :=
| ExprS e σs σc e' σs' σc' es :
| ExprS e σs σc e' σs' es :
head_step e σs e' σs' es
head_step' e (σs,σc) e' (σs',σc') es
| NewChanS l σs σc :
σc !! l = None
head_step' NewChan (σs, σc) (Pair (Lit $ LitChan l Left) (Lit $ LitChan l Right)) (σs, <[l:=([],[])]>σc) []
head_step' e (σs,σc) e' (σs',σc) es
(* | NewChanS l σs σc : *)
(* σc !! l = None → *)
(* head_step' NewChan (σs, σc) (Pair (Lit $ LitChan l Left) (Lit $ LitChan l Right)) (σs, <[l:=([],[])]>σc) [] *)
| SendLS σs σc l l' r' e v:
σc !! l = Some $ (l',r')
to_val e = Some $ v
......@@ -535,6 +539,16 @@ Proof.
unfold to_val''; destruct (to_val (pexpr_to_expr e)); split; intros; inversion H; reflexivity.
Qed.
Lemma to_val''_Some p e l v : to_val'' (p,e) = Some (l, v) (p, to_val e) = (l, Some (v)).
Proof.
intros.
unfold to_val'' in H.
simpl in *.
destruct (to_val e).
- inversion H. subst. reflexivity.
- inversion H.
Qed.
Lemma to_of_val'' v : to_val'' (of_val'' v) = Some v.
Proof.
destruct v. unfold to_val''. unfold of_val''. simpl. rewrite to_of_val. reflexivity.
......@@ -565,28 +579,168 @@ Proof.
unfold pexpr_to_expr. simpl. reflexivity.
Qed.
Fixpoint forPairs (i : loc) (pes : list pexpr) (es : list expr) : Prop :=
match (pes, es) with
| (pe::pes, e::es) => pe = (i, e) /\ forPairs i pes es
| ([],[]) => True
| (_,_) => False
end.
Definition state_eq (pσ : state'') (p : loc) (σ : state) :=
pσ.1 !! p = Some(σ).
Definition expr_eq (p : loc) (pe : pexpr) (e : expr) :=
pe = (p,e).
(* Fixpoint forPairs (i : loc) (pes : list pexpr) (es : list expr) : Prop := *)
(* match (pes, es) with *)
(* | (pe::pes, e::es) => pe = (i, e) /\ forPairs i pes es *)
(* | ([],[]) => True *)
(* | (_,_) => False *)
(* end. *)
Definition state_change (σ : state'') (σ' : state'') (p : loc) (σ'' : state) :=
σ'.1 = <[p:=σ'']>σ.1.
Inductive exprs_eq : loc list pexpr list expr Prop :=
| ExprsEqNil p : exprs_eq p [] []
| ExprsEqCons p pes pe es e : expr_eq p pe e exprs_eq p pes es exprs_eq p (cons pe pes) (cons e es).
(* Fixpoint exprs_eq (p : loc) (pes : list pexpr) (es : list expr) : Prop := *)
(* match (pes, es) with *)
(* | (pe::pes, e::es) => pe = (p, e) /\ exprs_eq p pes es *)
(* | ([],[]) => True *)
(* | (_,_) => False *)
(* end. *)
Lemma exprs_eq_r_empty p pes : exprs_eq p pes [] -> pes = [].
Proof.
intro.
destruct pes.
- reflexivity.
- inversion H.
Qed.
Lemma exprs_eq_l_empty p es : exprs_eq p [] es -> es = [].
Proof.
intro.
destruct es.
- reflexivity.
- inversion H.
Qed.
Definition state_match (p:loc) (pσs:gmap loc state) (σ:state) : Prop :=
σ = match pσs !! p with
| Some(σ) => σ
| None =>
end.
Definition inv_side (s : side) : side := match s with Left => Right | Right => Left end.
(* Definition myDef (σ : gmap loc (gmap loc val)) (l : loc) := σ = <[l := ∅ ]>σ. *)
(* Compute (myDef (∅) (Pos.of_nat O)). *)
Inductive head_step'' : pexpr state'' pexpr state'' list (pexpr) Prop :=
| ExprS' p pσs pσc e σ
pσs' pσc' e' σ'
(* | ExprS' p pσs pσc e σ *)
(* pσc' e' σ' *)
(* pes es : *)
(* pσs !! p = Some(σ) → *)
(* forPairs p pes es → *)
(* head_step' e (σ,pσc) e' (σ',pσc') es → *)
(* head_step'' (p,e) (pσs, pσc) (p,e') (<[p:=σ']>pσs, pσc') pes *)
| ExprPS' p pσs pσc e σ
(* pσc' *) e' (* σ' *)
pes es :
state_match p pσs σ
exprs_eq p pes es
head_step' e (σ,pσc) e' (σ,pσc) es
head_step'' (p,e) (pσs, pσc) (p,e') (pσs, pσc) pes
| ExprS' p pσs pσc e σ
pσc' e' σ'
pes es :
pσs !! p = Some(σ)
pσs' !! p = Some(σ')
forPairs p pes es
state_match p pσs σ
exprs_eq p pes es
σ' <> σ
head_step' e (σ,pσc) e' (σ',pσc') es
head_step'' (p,e) (pσs, pσc) (p,e') (pσs', pσc') pes
| StartS p l s e x σp σc p' :
head_step'' (p,e) (pσs, pσc) (p,e') (<[p:=σ']>pσs, pσc') pes
(* | ExprS' p pσs pσc e σ *)
(* pσc' e' σ' *)
(* pes es : *)
(* σ = match pσs !! p with *)
(* | Some(σ) => σ *)
(* | None => ∅ *)
(* end → *)
(* forPairs p pes es → *)
(* head_step' e (σ,pσc) e' (σ',pσc') es → *)
(* σ' <> σ → *)
(* head_step'' (p,e) (pσs, pσc) (p,e') (<[p:=σ']>pσs, pσc') pes *)
(* | ExprPS' p pσs pσc e σ *)
(* (* pσs' *) pσc' e' *)
(* pes es : *)
(* σ = match pσs !! p with *)
(* | Some(σ) => σ *)
(* | None => ∅ *)
(* end → *)
(* forPairs p pes es → *)
(* head_step' e (σ,pσc) e' (σ,pσc') es → *)
(* head_step'' (p,e) (pσs, pσc) (p,e') (pσs, pσc') pes *)
| StartS p e x c σp σc p' :
σp !! p' = None
σc !! c = None
Closed (BAnon :b: x :b: []) e
head_step'' (p, Start (Lit $ LitChan l s) (Rec BAnon x e)) (σp,σc) (p, Lit LitUnit) (<[p':=]>σp, σc) [(p', App (Rec BAnon x e) (Lit $ LitChan l (inv_side s)))].
head_step'' (p, Start (Rec BAnon x e)) (σp,σc) (p, Lit $ LitChan c Left) (σp, <[c:=([],[])]>σc) [(p', App (Rec BAnon x e) (Lit $ LitChan c Right))].
(* head_step'' (p, Start (Rec BAnon x e)) (σp,σc) (p, Lit $ LitChan c Left) (<[p':=∅]>σp, <[c:=([],[])]>σc) [(p', App (Rec BAnon x e) (Lit $ LitChan c Right))]. *)
(* Definition contains_process_heap (σ:state'') (p:loc) := exists (σ':state), σ.1 !! p = Some(σ'). *)
(* Definition is_pure (pe:pexpr) : Prop := *)
(* match pe with *)
(* | (p, e) => match e with *)
(* | Var y => False *)
(* | Rec f y e => True *)
(* | App e1 e2 => True *)
(* | Lit l => True *)
(* | UnOp op e => True *)
(* | BinOp op e1 e2 => True *)
(* | If e0 e1 e2 => True *)
(* | Pair e1 e2 => True *)
(* | Fst e => True *)
(* | Snd e => True *)
(* | InjL e => True *)
(* | InjR e => True *)
(* | Case e0 e1 e2 => True *)
(* | Fork e => True *)
(* | Alloc e => False *)
(* | Load e => True *)
(* | Store e1 e2 => False *)
(* | CAS e0 e1 e2 => True *)
(* | FAA e1 e2 => False *)
(* | Start e => False *)
(* | Send e1 e2 => False *)
(* | Recv e => False *)
(* end *)
(* end. *)
(* Theorem purity (pe:pexpr) : is_pure pe → forall σ, exists pe' pes, head_step'' pe σ pe' σ pes. *)
(* Proof. *)
(* intros. *)
(* destruct pe. *)
(* destruct e; unfold is_pure in H; try inversion H. *)
(* - exists (subst' x (of_val v2) (subst' f (Rec f x e1) e1)). *)
Ltac inverse_head := match goal with
| [H : head_step ?e ?σ ?e' ?σ' ?pe |- _] => inversion H; subst; eauto
end.
Ltac inverse_head' := match goal with
(* | [H : head_step' ?e (?σs,?σc) ?e' (?σs',?σc') ?pe |- _] => inversion H *)
| [H : head_step' ?e ?σ ?e' ?σ' ?pe |- _] => inversion H as [???????Hstep| | | | | |]; subst; try inverse_head; eauto
end.
Ltac inverse_head'' :=
match goal with
| [H : head_step'' ?e ?σ ?e' ?σ' ?pe |- _] =>
inversion H as
[???????? state_contains pfork Hstep'|
?????????? state_contains pfork state_changed Hstep'|]; subst; try inverse_head'; eauto
end.
Hint Extern 10 (head_step'' _ _ _ _ _) => inverse_head'' : typeclass_instances.
(** Basic properties about the language *)
Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki).
......@@ -613,12 +767,13 @@ Proof. destruct 1; naive_solver. Qed.
Lemma val_head_stuck' e1 σ1 e2 σ2 efs : head_step' e1 σ1 e2 σ2 efs to_val e1 = None.
Proof.
destruct 1; try naive_solver. generalize H. apply val_head_stuck.
destruct 1; try naive_solver. revert H. apply val_head_stuck.
Qed.
Lemma val_head_stuck'' e1 σ1 e2 σ2 efs : head_step'' e1 σ1 e2 σ2 efs to_val'' e1 = None.
Proof.
destruct 1; try naive_solver. apply val_head_stuck' in H2. unfold to_val''. subst. simpl. rewrite H2. reflexivity. Qed.
destruct 1 as [???????????Hstep|??????????????Hstep|]; try naive_solver; apply val_head_stuck' in Hstep; unfold to_val''; subst; simpl; rewrite Hstep; reflexivity.
Qed.
Lemma head_ctx_step_val Ki e σ1 e2 σ2 efs :
head_step (fill_item Ki e) σ1 e2 σ2 efs is_Some (to_val e).
......@@ -635,9 +790,9 @@ Qed.
Lemma head_ctx_step_val'' Ki e σ1 e2 σ2 efs :
head_step'' (fill_item'' Ki e) σ1 e2 σ2 efs is_Some (to_val'' e).
Proof.
inversion 1.
- apply to_val_val''. generalize dependent H9. apply head_ctx_step_val'.
- apply to_val_val''. generalize dependent H; destruct Ki; inversion_clear 1; unfold pexpr_to_expr; destruct e; simplify_option_eq; by eauto.
inversion 1 as [???????????Hstep|??????????????Hstep|];
try(apply to_val_val''; revert Hstep; apply head_ctx_step_val').
apply to_val_val''; revert H; destruct Ki; inversion_clear 1; unfold pexpr_to_expr; destruct e; simplify_option_eq; by eauto.
Qed.
Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 :
......@@ -668,12 +823,48 @@ Qed.
Lemma alloc_fresh e v σ :
let l := fresh (dom (gset loc) σ) in
to_val e = Some v head_step (Alloc e) σ (Lit (LitLoc l)) (<[l:=v]>σ) [].
Proof. by intros; apply AllocS, (not_elem_of_dom (D:=gset loc)), is_fresh. Qed.
Proof.
(* intros. apply AllocS. apply H. apply (not_elem_of_dom (D:=gset loc)). apply is_fresh. *)
by intros; apply AllocS, (not_elem_of_dom (D:=gset loc)), is_fresh. Qed.
(* Lemma alloc_fresh' σs σc : *)
(* let l := fresh (dom (gset loc) σc) in *)
(* head_step' NewChan (σs, σc) (Pair (Lit $ LitChan l Left) (Lit $ LitChan l Right)) (σs, <[l:=([],[])]>σc) []. *)
(* Proof. by intros; apply NewChanS, (not_elem_of_dom (D:=gset loc)), is_fresh. Qed. *)
Lemma alloc_fresh' e v σs σc :
let l := fresh (dom (gset loc) σs) in
to_val e = Some v head_step' (Alloc e) (σs,σc) (Lit (LitLoc l)) (<[l:=v]>σs,σc) [].
Proof. by intros; apply ExprS; apply alloc_fresh; apply H. Qed.
Lemma alloc_fresh' σs σc :
let l := fresh (dom (gset loc) σc) in
head_step' NewChan (σs, σc) (Pair (Lit $ LitChan l Left) (Lit $ LitChan l Right)) (σs, <[l:=([],[])]>σc) [].
Proof. by intros; apply NewChanS, (not_elem_of_dom (D:=gset loc)), is_fresh. Qed.
Lemma insert_not_in (σ : heap) l x :
σ !! l = None -> <[l:=x]>σ <> σ.
Proof.
unfold not. intros. apply insert_subset with σ l x in H. rewrite H0 in H. destruct H. contradiction.
Qed.
Lemma insert_fresh (σ : heap) x :
<[(fresh (dom (gset loc) σ)):=x]>σ <> σ.
Proof.
apply insert_not_in. apply (not_elem_of_dom (D:=gset loc)). apply is_fresh.
Qed.
Lemma alloc_fresh'' p e v σs σc σ :
(* σ = match σs !! p with *)
(* | Some(σ) => σ *)
(* | None => ∅ *)
(* end → *)
σs !! p = Some(σ)
let l := fresh (dom (gset loc) σ) in
to_val e = Some v
head_step'' (p, Alloc e) (σs,σc) (p, Lit (LitLoc l)) (<[p:=<[l:=v]>σ]>σs,σc) [].
Proof.
intros. apply ExprS' with σ [].
- unfold state_match. rewrite H. reflexivity.
- apply ExprsEqNil.
- apply insert_fresh.
- revert H0. apply alloc_fresh'.
Qed.
(* Misc *)
Lemma to_val_rec f x e `{!Closed (f :b: x :b: []) e} :
......@@ -794,4 +985,4 @@ Notation LetCtx x e2 := (AppRCtx (LamV x e2)).
Notation SeqCtx e2 := (LetCtx BAnon e2).
Notation Skip := (Seq (Lit LitUnit) (Lit LitUnit)).
Notation Match e0 x1 e1 x2 e2 := (Case e0 (Lam x1 e1) (Lam x2 e2)).
Notation StartC e := (Let (BNamed "c") NewChan (Seq (Start (Snd (BNamed "c")) e) ((Fst (BNamed "c"))))).
\ No newline at end of file
(* Notation StartC e := (Let (BNamed "c") NewChan (Seq (Start (Snd (BNamed "c")) e) ((Fst (BNamed "c"))))). *)
\ No newline at end of file
......@@ -73,12 +73,11 @@ Definition gen_distUR (L V : Type) `{Countable L} : ucmraT :=
Definition to_gen_dist {L V} `{Countable L} (σ : ((gmap L (gmap L V)) * (gmap L (list V * list V)))) : gen_distUR L V :=
((fmap (λ v, (1%Qp, to_agree (to_gen_heap v))) σ.1),
(to_gen_heap σ.2)).
Class gen_distG (L V : Type) (Σ :gFunctors) `{Countable L} := Gen_DistG {
gen_dist_inG :> inG Σ (authR (gen_distUR L V)); (* Why authR? *)
gen_dist_name : gname
}.
Arguments gen_dist_name {_ _ _ _ _} _ : assert.
Arguments gen_dist_name {_ _ _ _ _} _ : assert.
Section definitions.
Context `{dG : gen_distG L V Σ}.
......@@ -119,48 +118,113 @@ Ltac inv_head_step :=
| H : _ = of_val ?v |- _ =>
is_var v; destruct v; first[discriminate H|injection H as H]
| H : head_step ?e _ _ _ _ |- _ =>
try (is_var e; fail 1); (* inversion yields many goals if [e] is a variable *)
(* and can thus better be avoided. *)
inversion H; subst; clear H
end.
Ltac inv_head_step' :=
repeat match goal with
| _ => progress simplify_map_eq/= (* simplify memory stuff *)
| H : to_val _ = Some _ |- _ => apply of_to_val in H
| H : _ = of_val ?v |- _ =>
is_var v; destruct v; first[discriminate H|injection H as H]
| H : head_step' ?e _ _ _ _ |- _ =>
try (is_var e; fail 1); (* inversion yields many goals if [e] is a variable *)
(* and can thus better be avoided. *)
inversion H; inv_head_step; subst; clear H
end.
Ltac inv_head_step'' :=
repeat match goal with
| _ => progress simplify_map_eq/= (* simplify memory stuff *)
| H : to_val'' _ = Some _ |- _ => apply of_to_val'' in H
| H : _ = of_val'' ?v |- _ =>
is_var v; destruct v; first[discriminate H|injection H as H]
| H : of_val'' ?v = _ |- _ =>
is_var v; destruct v; first[discriminate H|injection H as H]
| H : head_step'' ?e _ _ _ _ |- _ =>
try (is_var e; fail 1); (* inversion yields many goals if [e] is a variable
and can thus better be avoided. *)
inversion H; subst; clear H
inversion H; inv_head_step'; subst; clear H
end.
Local Hint Extern 0 (atomic _ _) => solve_atomic.
Local Hint Extern 0 (head_reducible _ _) => eexists _, _, _; simpl.
Local Hint Constructors head_step.
Local Hint Constructors head_step'.
Local Hint Constructors head_step''.
Local Hint Resolve alloc_fresh.
Local Hint Resolve alloc_fresh'.
Local Hint Resolve alloc_fresh''.
Local Hint Resolve to_of_val.
Local Hint Resolve to_of_val''.
Section lifting.
Context `{distG Σ}.
Implicit Types P Q : iProp Σ.
Implicit Types Φ : val iProp Σ.
Implicit Types efs : list expr.
Implicit Types σ : state.
(* Implicit Types Φ : pval → iProp Σ. *)
(* Implicit Types efs : list pexpr. *)
(* Implicit Types σ : state''. *)
(* Implicit Types Φ : val → iProp Σ. *)
(* Implicit Types efs : list expr. *)
(* Implicit Types σ : state. *)
Implicit Types Φ : pval iProp Σ.
Implicit Types efs : list pexpr.
Implicit Types σ : state''.
(** Base axioms for core primitives of the language: Stateless reductions *)
Lemma wp_fork s E e Φ :
Lemma wp_fork s E (e:pexpr) Φ :
(* ▷ Φ (p, LitV LitUnit) ∗ ▷ WP (p,e) @ s; ⊤ {{ _, True }} ⊢ WP (p, Fork e) @ s; E {{ Φ }}. *)
Φ (LitV LitUnit) WP e @ s; {{ _, True }} WP Fork e @ s; E {{ Φ }}.
Proof.
rewrite -(wp_lift_pure_det_head_step ((p, Fork e):pexpr) (p, Lit LitUnit) [(p,e)]) //=; eauto.
- by rewrite -step_fupd_intro // later_sep -(wp_value _ _ _ ((p, Lit _):pexpr)) // right_id.
- intros; inv_head_step; eauto.
Qed.
(** Base axioms for core primitives of the language: Stateless reductions *)
Lemma wp_fork s E e Φ :
Φ (LitV LitUnit) WP e @ s; {{ _, True }} WP Fork e @ s; E {{ Φ }}.
Φ (e.1, LitV LitUnit) WP e @ s; {{ _, True }} WP (e.1, Fork e.2) @ s; E {{ Φ }}.
Proof.
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.
- intros; inv_head_step; eauto.
rewrite -(wp_lift_pure_det_head_step ((e.1, Fork e.2):pexpr) (e.1, Lit LitUnit) [e]) //=; eauto.
- rewrite -step_fupd_intro //. rewrite later_sep.
(* rewrite <-(@wp_value dist_lang Σ _ s E Φ ((e.1, (Lit LitUnit)):pexpr) (e.1, (LitV LitUnit))). *)
rewrite <- (wp_value _ _ _ ((e.1, Lit _):pexpr)). rewrite right_id //. reflexivity.
- intros. unfold head_reducible. simpl. exists (e.1, Lit LitUnit). exists σ1. exists [e]. destruct e. destruct σ1. simpl. apply ExprPS' with (match p !! l with Some (σ) => σ | None => end) [e]. unfold state_match. eauto. repeat econstructor. (* unfold exprs_eq. split; reflexivity. *) apply ExprS. apply ForkS.
- intros. inv_head_step''. destruct e. inversion H4. inversion H6. inversion H7. eauto.
Qed.
(* contradiction. contradiction. *)
(* destruct e. simpl in *. contradiction. *)
(* inversion H0. *)
(* + inversion H9. inversion H16. rewrite H22 in H10. contradiction. *)
(* + inversion H9. inversion H17. split. *)
(* * reflexivity. *)
(* * split. *)
(* -- reflexivity. *)
(* -- destruct (pσs !! e.1). destruct e. subst. simpl in *. *)
(* destruct efs'. *)
(* ++ inversion H4. *)
(* ++ inversion H4. subst. destruct efs'. *)
(* ** reflexivity. *)
(* ** inversion H2. *)
(* ++ destruct e. subst. simpl in H4. destruct efs'. *)
(* ** inversion H4. *)
(* ** inversion H4. destruct efs'. *)
(* --- subst. reflexivity. *)
(* --- inversion H2. *)
(* Qed. *)
(* (** Base axioms for core primitives of the language: Stateless reductions *) *)
(* Lemma wp_fork s E p e Φ : *)
(* (* ▷ Φ (p, LitV LitUnit) ∗ ▷ WP (p,e) @ s; ⊤ {{ _, True }} ⊢ WP (p, Fork e) @ s; E {{ Φ }}. *) *)
(* ▷ Φ (p, LitV LitUnit) ∗ ▷ WP ((p, e):pexpr) @ s; ⊤ {{ _, True }} ⊢ WP ((p, Fork e):pexpr) @ s; E {{ Φ }}. *)
(* Proof. *)
(* rewrite -(wp_lift_pure_det_head_step ((p, Fork e):pexpr) ((p, Lit LitUnit):pexpr) [((p,e):pexpr)]) //=; eauto. *)
(* - rewrite -step_fupd_intro //. rewrite later_sep. rewrite -(wp_value _ _ _ ((p, (Lit _)):pexpr)). by rewrite -step_fupd_intro // later_sep -(wp_value _ _ _ ((p, Lit LitUnit):pexpr)) // right_id. *)
(* - intros; inv_head_step; eauto. *)
(* Qed. *)
(* (** Base axioms for core primitives of the language: Stateless reductions *) *)
(* Lemma wp_fork s E e Φ : *)
(* ▷ Φ (LitV LitUnit) ∗ ▷ WP e @ s; ⊤ {{ _, True }} ⊢ WP Fork e @ s; E {{ Φ }}. *)
(* Proof. *)
(* 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. *)
(* - intros; inv_head_step; eauto. *)
(* Qed. *)
Local Ltac solve_exec_safe := intros; subst; do 3 eexists; econstructor; eauto.
Local Ltac solve_exec_puredet := simpl; intros; by inv_head_step.
......@@ -176,10 +240,63 @@ Global 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.
Global Instance pure_rec f x (erec e1 e2 : expr)
`{!AsVal e2, AsRec e1 f x erec, Closed (f :b: x :b: []) erec} :
PureExec True (App e1 e2) (subst' x e2 (subst' f e1 erec)).
Proof. unfold AsRec in *; solve_pure_exec. Qed.
Class AsPRec (pe : pexpr) (f x : binder) (perec : pexpr) :=
as_prec : pe = match perec with
| (p,e) => (p, Rec f x e)
end.
Global Instance AsPRec_rec p f x e : AsPRec (p,(Rec f x e)) f x (p,e) := eq_refl.
Global Instance AsPRec_rec_locked_val p v f x e :
AsPRec (of_val'' (p,v)) f x (p,e) AsPRec (of_val'' (locked (p,v))) f x (p,e).
Proof. by unlock. Qed.