Commit 162c2f80 authored by Robbert Krebbers's avatar Robbert Krebbers

Expressions as dependent type.

parent c1f41d83
From heap_lang Require Export substitution notation.
From heap_lang Require Export notation.
Definition newbarrier : val := λ: <>, ref #0.
Definition signal : val := λ: "x", "x" <- #1.
Definition signal : val := λ: "x", '"x" <- #1.
Definition wait : val :=
rec: "wait" "x" := if: !"x" = #1 then #() else "wait" "x".
Instance newbarrier_closed : Closed newbarrier. Proof. solve_closed. Qed.
Instance signal_closed : Closed signal. Proof. solve_closed. Qed.
Instance wait_closed : Closed wait. Proof. solve_closed. Qed.
rec: "wait" "x" := if: !'"x" = #1 then #() else '"wait" '"x".
......@@ -3,12 +3,12 @@ From program_logic Require Import auth sts saved_prop hoare ownership.
Import uPred.
Definition worker (n : Z) : val :=
λ: "b" "y", wait "b" ;; !"y" #n.
Definition client : expr :=
λ: "b" "y", ^wait '"b" ;; !'"y" #n.
Definition client : expr [] :=
let: "y" := ref #0 in
let: "b" := newbarrier #() in
Fork (Fork (worker 12 "b" "y") ;; worker 17 "b" "y") ;;
"y" <- (λ: "z", "z" + #42) ;; signal "b".
let: "b" := ^newbarrier #() in
Fork (Fork (^(worker 12) '"b" '"y") ;; ^(worker 17) '"b" '"y") ;;
'"y" <- (λ: "z", '"z" + #42) ;; ^signal '"b".
Section client.
Context {Σ : rFunctorG} `{!heapG Σ, !barrierG Σ} (heapN N : namespace).
......@@ -16,7 +16,7 @@ Section client.
Definition y_inv q y : iProp :=
( f : val, y {q} f n : Z, || f #n {{ λ v, v = #(n + 42) }})%I.
Lemma y_inv_split q y :
y_inv q y (y_inv (q/2) y y_inv (q/2) y).
Proof.
......@@ -56,7 +56,7 @@ Section client.
wp_seq. (ewp eapply wp_store); eauto with I. strip_later.
rewrite assoc [(_ y _)%I]comm. apply sep_mono_r, wand_intro_l.
wp_seq. rewrite -signal_spec right_id assoc sep_elim_l comm.
apply sep_mono_r. rewrite /y_inv -(exist_intro (λ: "z", "z" + #42)%V).
apply sep_mono_r. rewrite /y_inv -(exist_intro (λ: "z", '"z" + #42)%V).
apply sep_intro_True_r; first done. apply: always_intro.
apply forall_intro=>n. wp_let. wp_op. by apply const_intro. }
(* The two spawned threads, the waiters. *)
......
......@@ -19,12 +19,12 @@ Implicit Types Φ : val → iProp heap_lang Σ.
(** Proof rules for the sugar *)
Lemma wp_lam E x ef e v Φ :
to_val e = Some v
|| subst' ef x v @ E {{ Φ }} || App (Lam x ef) e @ E {{ Φ }}.
|| subst' x e ef @ E {{ Φ }} || App (Lam x ef) e @ E {{ Φ }}.
Proof. intros. by rewrite -wp_rec. Qed.
Lemma wp_let E x e1 e2 v Φ :
to_val e1 = Some v
|| subst' e2 x v @ E {{ Φ }} || Let x e1 e2 @ E {{ Φ }}.
|| subst' x e1 e2 @ E {{ Φ }} || Let x e1 e2 @ E {{ Φ }}.
Proof. apply wp_lam. Qed.
Lemma wp_seq E e1 e2 v Φ :
......@@ -37,17 +37,13 @@ Proof. rewrite -wp_seq // -wp_value //. Qed.
Lemma wp_match_inl E e0 v0 x1 e1 x2 e2 Φ :
to_val e0 = Some v0
|| subst' e1 x1 v0 @ E {{ Φ }} || Match (InjL e0) x1 e1 x2 e2 @ E {{ Φ }}.
Proof.
intros. rewrite -wp_case_inl // -[X in _ X]later_intro. by apply wp_let.
Qed.
|| subst' x1 e0 e1 @ E {{ Φ }} || Match (InjL e0) x1 e1 x2 e2 @ E {{ Φ }}.
Proof. intros. by rewrite -wp_case_inl // -[X in _ X]later_intro -wp_let. Qed.
Lemma wp_match_inr E e0 v0 x1 e1 x2 e2 Φ :
to_val e0 = Some v0
|| subst' e2 x2 v0 @ E {{ Φ }} || Match (InjR e0) x1 e1 x2 e2 @ E {{ Φ }}.
Proof.
intros. rewrite -wp_case_inr // -[X in _ X]later_intro. by apply wp_let.
Qed.
|| subst' x2 e0 e2 @ E {{ Φ }} || Match (InjR e0) x1 e1 x2 e2 @ E {{ Φ }}.
Proof. intros. by rewrite -wp_case_inr // -[X in _ X]later_intro -wp_let. Qed.
Lemma wp_le E (n1 n2 : Z) P Φ :
(n1 n2 P Φ (LitV (LitBool true)))
......
From program_logic Require Export language.
From prelude Require Export stringmap.
From prelude Require Export strings.
From prelude Require Import gmap.
Module heap_lang.
......@@ -17,41 +17,84 @@ Inductive bin_op : Set :=
Inductive binder := BAnon | BNamed : string binder.
Definition cons_binder (mx : binder) (X : list string) : list string :=
match mx with BAnon => X | BNamed x => x :: X end.
Infix ":b:" := cons_binder (at level 60, right associativity).
Delimit Scope binder_scope with binder.
Bind Scope binder_scope with binder.
Instance binder_dec_eq (x1 x2 : binder) : Decision (x1 = x2).
Proof. solve_decision. Defined.
Instance set_unfold_cons_binder x mx X P :
SetUnfold (x X) P SetUnfold (x mx :b: X) (BNamed x = mx P).
Proof.
constructor. rewrite -(set_unfold (x X) P).
destruct mx; rewrite /= ?elem_of_cons; naive_solver.
Qed.
Class VarBound (x : string) (X : list string) :=
var_bound : bool_decide (x X).
Hint Extern 0 (VarBound _ _) => vm_compute; exact I : typeclass_instances.
Instance var_bound_proof_irrel x X : ProofIrrel (VarBound x X).
Proof. rewrite /VarBound. apply _. Qed.
Instance set_unfold_var_bound x X P :
SetUnfold (x X) P SetUnfold (VarBound x X) P.
Proof.
constructor. by rewrite /VarBound bool_decide_spec (set_unfold (x X) P).
Qed.
Inductive expr :=
Inductive expr (X : list string) :=
(* Base lambda calculus *)
| Var (x : string)
| Rec (f x : binder) (e : expr)
| App (e1 e2 : expr)
| Var (x : string) `{VarBound x X}
| Rec (f x : binder) (e : expr (f :b: x :b: X))
| App (e1 e2 : expr X)
(* Base types and their operations *)
| Lit (l : base_lit)
| UnOp (op : un_op) (e : expr)
| BinOp (op : bin_op) (e1 e2 : expr)
| If (e0 e1 e2 : expr)
| UnOp (op : un_op) (e : expr X)
| BinOp (op : bin_op) (e1 e2 : expr X)
| If (e0 e1 e2 : expr X)
(* Products *)
| Pair (e1 e2 : expr)
| Fst (e : expr)
| Snd (e : expr)
| Pair (e1 e2 : expr X)
| Fst (e : expr X)
| Snd (e : expr X)
(* Sums *)
| InjL (e : expr)
| InjR (e : expr)
| Case (e0 : expr) (e1 : expr) (e2 : expr)
| InjL (e : expr X)
| InjR (e : expr X)
| Case (e0 : expr X) (e1 : expr X) (e2 : expr X)
(* Concurrency *)
| Fork (e : expr)
| Fork (e : expr X)
(* Heap *)
| Loc (l : loc)
| Alloc (e : expr)
| Load (e : expr)
| Store (e1 : expr) (e2 : expr)
| Cas (e0 : expr) (e1 : expr) (e2 : expr).
| Alloc (e : expr X)
| Load (e : expr X)
| Store (e1 : expr X) (e2 : expr X)
| Cas (e0 : expr X) (e1 : expr X) (e2 : expr X).
Bind Scope expr_scope with expr.
Delimit Scope expr_scope with E.
Arguments Var {_} _ {_}.
Arguments Rec {_} _ _ _%E.
Arguments App {_} _%E _%E.
Arguments Lit {_} _.
Arguments UnOp {_} _ _%E.
Arguments BinOp {_} _ _%E _%E.
Arguments If {_} _%E _%E _%E.
Arguments Pair {_} _%E _%E.
Arguments Fst {_} _%E.
Arguments Snd {_} _%E.
Arguments InjL {_} _%E.
Arguments InjR {_} _%E.
Arguments Case {_} _%E _%E _%E.
Arguments Fork {_} _%E.
Arguments Loc {_} _.
Arguments Alloc {_} _%E.
Arguments Load {_} _%E.
Arguments Store {_} _%E _%E.
Arguments Cas {_} _%E _%E _%E.
Inductive val :=
| RecV (f x : binder) (e : expr) (* e should be closed *)
| RecV (f x : binder) (e : expr (f :b: x :b: []))
| LitV (l : base_lit)
| PairV (v1 v2 : val)
| InjLV (v : val)
......@@ -60,21 +103,13 @@ Inductive val :=
Bind Scope val_scope with val.
Delimit Scope val_scope with V.
Arguments PairV _%V _%V.
Arguments InjLV _%V.
Arguments InjRV _%V.
Global Instance base_lit_dec_eq (l1 l2 : base_lit) : Decision (l1 = l2).
Proof. solve_decision. Defined.
Global Instance un_op_dec_eq (op1 op2 : un_op) : Decision (op1 = op2).
Proof. solve_decision. Defined.
Global Instance bin_op_dec_eq (op1 op2 : bin_op) : Decision (op1 = op2).
Proof. solve_decision. Defined.
Global Instance binder_dec_eq (x1 x2 : binder) : Decision (x1 = x2).
Proof. solve_decision. Defined.
Global Instance expr_dec_eq (e1 e2 : expr) : Decision (e1 = e2).
Proof. solve_decision. Defined.
Global Instance val_dec_eq (v1 v2 : val) : Decision (v1 = v2).
Proof. solve_decision. Defined.
Definition signal : val := RecV BAnon (BNamed "x") (Store (Var "x") (Lit (LitInt 1))).
Fixpoint of_val (v : val) : expr :=
Fixpoint of_val (v : val) : expr [] :=
match v with
| RecV f x e => Rec f x e
| LitV l => Lit l
......@@ -83,7 +118,8 @@ Fixpoint of_val (v : val) : expr :=
| InjRV v => InjR (of_val v)
| LocV l => Loc l
end.
Fixpoint to_val (e : expr) : option val :=
Fixpoint to_val (e : expr []) : option val :=
match e with
| Rec f x e => Some (RecV f x e)
| Lit l => Some (LitV l)
......@@ -99,30 +135,30 @@ Definition state := gmap loc val.
(** Evaluation contexts *)
Inductive ectx_item :=
| AppLCtx (e2 : expr)
| AppLCtx (e2 : expr [])
| AppRCtx (v1 : val)
| UnOpCtx (op : un_op)
| BinOpLCtx (op : bin_op) (e2 : expr)
| BinOpLCtx (op : bin_op) (e2 : expr [])
| BinOpRCtx (op : bin_op) (v1 : val)
| IfCtx (e1 e2 : expr)
| PairLCtx (e2 : expr)
| IfCtx (e1 e2 : expr [])
| PairLCtx (e2 : expr [])
| PairRCtx (v1 : val)
| FstCtx
| SndCtx
| InjLCtx
| InjRCtx
| CaseCtx (e1 : expr) (e2 : expr)
| CaseCtx (e1 : expr []) (e2 : expr [])
| AllocCtx
| LoadCtx
| StoreLCtx (e2 : expr)
| StoreLCtx (e2 : expr [])
| StoreRCtx (v1 : val)
| CasLCtx (e1 : expr) (e2 : expr)
| CasMCtx (v0 : val) (e2 : expr)
| CasLCtx (e1 : expr []) (e2 : expr [])
| CasMCtx (v0 : val) (e2 : expr [])
| CasRCtx (v0 : val) (v1 : val).
Notation ectx := (list ectx_item).
Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
Definition fill_item (Ki : ectx_item) (e : expr []) : expr [] :=
match Ki with
| AppLCtx e2 => App e e2
| AppRCtx v1 => App (of_val v1) e
......@@ -145,36 +181,83 @@ Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
| CasMCtx v0 e2 => Cas (of_val v0) e e2
| CasRCtx v0 v1 => Cas (of_val v0) (of_val v1) e
end.
Definition fill (K : ectx) (e : expr) : expr := fold_right fill_item e K.
Definition fill (K : ectx) (e : expr []) : expr [] := fold_right fill_item e K.
(** Substitution *)
(** We have [subst' e BAnon v = e] to deal with anonymous binders *)
Fixpoint subst (e : expr) (x : string) (v : val) : expr :=
match e with
| Var y => if decide (x = y) then of_val v else Var y
Lemma wexpr_rec_prf {X Y} (H : X `included` Y) {f x} :
f :b: x :b: X `included` f :b: x :b: Y.
Proof. set_solver. Qed.
Program Fixpoint wexpr {X Y} (H : X `included` Y) (e : expr X) : expr Y :=
match e return expr Y with
| Var x _ => @Var _ x _
| Rec f x e => Rec f x (wexpr (wexpr_rec_prf H) e)
| App e1 e2 => App (wexpr H e1) (wexpr H e2)
| Lit l => Lit l
| UnOp op e => UnOp op (wexpr H e)
| BinOp op e1 e2 => BinOp op (wexpr H e1) (wexpr H e2)
| If e0 e1 e2 => If (wexpr H e0) (wexpr H e1) (wexpr H e2)
| Pair e1 e2 => Pair (wexpr H e1) (wexpr H e2)
| Fst e => Fst (wexpr H e)
| Snd e => Snd (wexpr H e)
| InjL e => InjL (wexpr H e)
| InjR e => InjR (wexpr H e)
| Case e0 e1 e2 => Case (wexpr H e0) (wexpr H e1) (wexpr H e2)
| Fork e => Fork (wexpr H e)
| Loc l => Loc l
| Alloc e => Alloc (wexpr H e)
| Load e => Load (wexpr H e)
| Store e1 e2 => Store (wexpr H e1) (wexpr H e2)
| Cas e0 e1 e2 => Cas (wexpr H e0) (wexpr H e1) (wexpr H e2)
end.
Solve Obligations with set_solver.
Definition of_val' {X} (v : val) : expr X := wexpr (included_nil _) (of_val v).
Lemma wsubst_rec_true_prf {X Y x} (H : X `included` x :: Y) {f y}
(Hfy :BNamed x f BNamed x y) :
f :b: y :b: X `included` x :: f :b: y :b: Y.
Proof. set_solver. Qed.
Lemma wsubst_rec_false_prf {X Y x} (H : X `included` x :: Y) {f y}
(Hfy : ¬(BNamed x f BNamed x y)) :
f :b: y :b: X `included` f :b: y :b: Y.
Proof. move: Hfy=>/not_and_l [/dec_stable|/dec_stable]; set_solver. Qed.
Program Fixpoint wsubst {X Y} (x : string) (es : expr [])
(H : X `included` x :: Y) (e : expr X) : expr Y :=
match e return expr Y with
| Var y _ => if decide (x = y) then wexpr _ es else @Var _ y _
| Rec f y e =>
Rec f y (if decide (BNamed x f BNamed x y) then subst e x v else e)
| App e1 e2 => App (subst e1 x v) (subst e2 x v)
Rec f y $ match decide (BNamed x f BNamed x y) return _ with
| left Hfy => wsubst x es (wsubst_rec_true_prf H Hfy) e
| right Hfy => wexpr (wsubst_rec_false_prf H Hfy) e
end
| App e1 e2 => App (wsubst x es H e1) (wsubst x es H e2)
| Lit l => Lit l
| UnOp op e => UnOp op (subst e x v)
| BinOp op e1 e2 => BinOp op (subst e1 x v) (subst e2 x v)
| If e0 e1 e2 => If (subst e0 x v) (subst e1 x v) (subst e2 x v)
| Pair e1 e2 => Pair (subst e1 x v) (subst e2 x v)
| Fst e => Fst (subst e x v)
| Snd e => Snd (subst e x v)
| InjL e => InjL (subst e x v)
| InjR e => InjR (subst e x v)
| UnOp op e => UnOp op (wsubst x es H e)
| BinOp op e1 e2 => BinOp op (wsubst x es H e1) (wsubst x es H e2)
| If e0 e1 e2 => If (wsubst x es H e0) (wsubst x es H e1) (wsubst x es H e2)
| Pair e1 e2 => Pair (wsubst x es H e1) (wsubst x es H e2)
| Fst e => Fst (wsubst x es H e)
| Snd e => Snd (wsubst x es H e)
| InjL e => InjL (wsubst x es H e)
| InjR e => InjR (wsubst x es H e)
| Case e0 e1 e2 =>
Case (subst e0 x v) (subst e1 x v) (subst e2 x v)
| Fork e => Fork (subst e x v)
Case (wsubst x es H e0) (wsubst x es H e1) (wsubst x es H e2)
| Fork e => Fork (wsubst x es H e)
| Loc l => Loc l
| Alloc e => Alloc (subst e x v)
| Load e => Load (subst e x v)
| Store e1 e2 => Store (subst e1 x v) (subst e2 x v)
| Cas e0 e1 e2 => Cas (subst e0 x v) (subst e1 x v) (subst e2 x v)
| Alloc e => Alloc (wsubst x es H e)
| Load e => Load (wsubst x es H e)
| Store e1 e2 => Store (wsubst x es H e1) (wsubst x es H e2)
| Cas e0 e1 e2 => Cas (wsubst x es H e0) (wsubst x es H e1) (wsubst x es H e2)
end.
Definition subst' (e : expr) (mx : binder) (v : val) : expr :=
match mx with BNamed x => subst e x v | BAnon => e end.
Solve Obligations with set_solver.
Definition subst {X} (x : string) (es : expr []) (e : expr (x :: X)) : expr X :=
wsubst x es (λ z, id) e.
Definition subst' {X} (mx : binder) (es : expr []) : expr (mx :b: X) expr X :=
match mx with BNamed x => subst x es | BAnon => id end.
(** The stepping relation *)
Definition un_op_eval (op : un_op) (l : base_lit) : option base_lit :=
......@@ -194,11 +277,11 @@ Definition bin_op_eval (op : bin_op) (l1 l2 : base_lit) : option base_lit :=
| _, _, _ => None
end.
Inductive head_step : expr state expr state option expr Prop :=
| BetaS f x e1 e2 v2 σ :
Inductive head_step : expr [] state expr [] state option (expr []) Prop :=
| BetaS f x e1 e2 v2 e' σ :
to_val e2 = Some v2
head_step (App (Rec f x e1) e2) σ
(subst' (subst' e1 f (RecV f x e1)) x v2) σ None
e' = subst' x (of_val v2) (subst' f (Rec f x e1) e1)
head_step (App (Rec f x e1) e2) σ e' σ None
| UnOpS op l l' σ :
un_op_eval op l = Some l'
head_step (UnOp op (Lit l)) σ (Lit l') σ None
......@@ -242,7 +325,7 @@ Inductive head_step : expr → state → expr → state → option expr → Prop
head_step (Cas (Loc l) e1 e2) σ (Lit $ LitBool true) (<[l:=v2]>σ) None.
(** Atomic expressions *)
Definition atomic (e: expr) : Prop :=
Definition atomic (e: expr []) : Prop :=
match e with
| Alloc e => is_Some (to_val e)
| Load e => is_Some (to_val e)
......@@ -255,19 +338,83 @@ Definition atomic (e: expr) : Prop :=
(** Close reduction under evaluation contexts.
We could potentially make this a generic construction. *)
Inductive prim_step
(e1 : expr) (σ1 : state) (e2 : expr) (σ2: state) (ef: option expr) : Prop :=
Inductive prim_step (e1 : expr []) (σ1 : state)
(e2 : expr []) (σ2: state) (ef: option (expr [])) : Prop :=
Ectx_step K e1' e2' :
e1 = fill K e1' e2 = fill K e2'
head_step e1' σ1 e2' σ2 ef prim_step e1 σ1 e2 σ2 ef.
(** Substitution *)
Lemma var_proof_irrel X x H1 H2 : @Var X x H1 = @Var X x H2.
Proof. f_equal. by apply (proof_irrel _). Qed.
Lemma wexpr_id X (H : X `included` X) e : wexpr H e = e.
Proof. induction e; f_equal/=; auto. by apply (proof_irrel _). Qed.
Lemma wexpr_proof_irrel X Y (H1 H2 : X `included` Y) e : wexpr H1 e = wexpr H2 e.
Proof.
revert Y H1 H2; induction e; simpl; auto using var_proof_irrel with f_equal.
Qed.
Lemma wexpr_wexpr X Y Z (H1 : X `included` Y) (H2 : Y `included` Z) H3 e :
wexpr H2 (wexpr H1 e) = wexpr H3 e.
Proof.
revert Y Z H1 H2 H3.
induction e; simpl; auto using var_proof_irrel with f_equal.
Qed.
Lemma wexpr_wexpr' X Y Z (H1 : X `included` Y) (H2 : Y `included` Z) e :
wexpr H2 (wexpr H1 e) = wexpr (transitivity H1 H2) e.
Proof. apply wexpr_wexpr. Qed.
Lemma wsubst_proof_irrel X Y x es (H1 H2 : X `included` x :: Y) e :
wsubst x es H1 e = wsubst x es H2 e.
Proof.
revert Y H1 H2; induction e; simpl; intros; repeat case_decide;
auto using var_proof_irrel, wexpr_proof_irrel with f_equal.
Qed.
Lemma wexpr_wsubst X Y Z x es (H1: X `included` x::Y) (H2: Y `included` Z) H3 e:
wexpr H2 (wsubst x es H1 e) = wsubst x es H3 e.
Proof.
revert Y Z H1 H2 H3.
induction e; intros; repeat (case_decide || simplify_eq/=);
auto using var_proof_irrel, wexpr_wexpr with f_equal.
Qed.
Lemma wsubst_wexpr X Y Z x es (H1: X `included` Y) (H2: Y `included` x::Z) H3 e:
wsubst x es H2 (wexpr H1 e) = wsubst x es H3 e.
Proof.
revert Y Z H1 H2 H3.
induction e; intros; repeat (case_decide || simplify_eq/=);
auto using var_proof_irrel, wexpr_wexpr with f_equal.
Qed.
Lemma wsubst_wexpr' X Y Z x es (H1: X `included` Y) (H2: Y `included` x::Z) e:
wsubst x es H2 (wexpr H1 e) = wsubst x es (transitivity H1 H2) e.
Proof. apply wsubst_wexpr. Qed.
Lemma wsubst_closed X Y x es (H1 : X `included` x :: Y) H2 (e : expr X) :
x X wsubst x es H1 e = wexpr H2 e.
Proof.
revert Y H1 H2.
induction e; intros; repeat (case_decide || simplify_eq/=);
auto using var_proof_irrel, wexpr_proof_irrel with f_equal set_solver.
exfalso; set_solver.
Qed.
Lemma wsubst_closed_nil x es H (e : expr []) : wsubst x es H e = e.
Proof.
rewrite -{2}(wexpr_id _ (reflexivity []) e).
apply wsubst_closed, not_elem_of_nil.
Qed.
(** Basic properties about the language *)
Lemma to_of_val v : to_val (of_val v) = Some v.
Proof. by induction v; simplify_option_eq. Qed.
Lemma of_to_val e v : to_val e = Some v of_val v = e.
Proof.
revert v; induction e; intros; simplify_option_eq; auto with f_equal.
revert e v. cut ( X (e : expr X) (H : X = ) v,
to_val (eq_rect _ expr e _ H) = Some v of_val v = eq_rect _ expr e _ H).
{ intros help e v. apply (help e eq_refl). }
intros X e; induction e; intros HX ??; simplify_option_eq;
repeat match goal with
| IH : _ : = , _ |- _ => specialize (IH eq_refl); simpl in IH
end; auto with f_equal.
Qed.
Instance: Inj (=) (=) of_val.
......@@ -316,7 +463,7 @@ Qed.
Lemma atomic_head_step e1 σ1 e2 σ2 ef :
atomic e1 head_step e1 σ1 e2 σ2 ef is_Some (to_val e2).
Proof.
destruct 2; simpl; rewrite ?to_of_val; try by eauto.
destruct 2; simpl; rewrite ?to_of_val; try by eauto. subst.
unfold subst'; repeat (case_match || contradiction || simplify_eq/=); eauto.
Qed.
......@@ -363,92 +510,53 @@ Lemma alloc_fresh e v σ :
to_val e = Some v head_step (Alloc e) σ (Loc l) (<[l:=v]>σ) None.
Proof. by intros; apply AllocS, (not_elem_of_dom (D:=gset _)), is_fresh. Qed.
(** Closed expressions *)
Definition of_binder (mx : binder) : stringset :=
match mx with BAnon => | BNamed x => {[ x ]} end.
Lemma elem_of_of_binder x mx: x of_binder mx mx = BNamed x.
Proof. destruct mx; set_solver. Qed.
Global Instance set_unfold_of_binder (mx : binder) x :
SetUnfold (x of_binder mx) (mx = BNamed x).
Proof. constructor; destruct mx; set_solver. Qed.
(** Equality stuff *)
Instance base_lit_dec_eq (l1 l2 : base_lit) : Decision (l1 = l2).
Proof. solve_decision. Defined.
Instance un_op_dec_eq (op1 op2 : un_op) : Decision (op1 = op2).
Proof. solve_decision. Defined.
Instance bin_op_dec_eq (op1 op2 : bin_op) : Decision (op1 = op2).
Proof. solve_decision. Defined.
Fixpoint is_closed (X : stringset) (e : expr) : bool :=
match e with
| Var x => bool_decide (x X)
| Rec f y e => is_closed (of_binder f of_binder y X) e
| App e1 e2 => is_closed X e1 && is_closed X e2
| Lit l => true
| UnOp _ e => is_closed X e
| BinOp _ e1 e2 => is_closed X e1 && is_closed X e2
| If e0 e1 e2 => is_closed X e0 && is_closed X e1 && is_closed X e2
| Pair e1 e2 => is_closed X e1 && is_closed X e2
| Fst e => is_closed X e
| Snd e => is_closed X e
| InjL e => is_closed X e
| InjR e => is_closed X e
| Case e0 e1 e2 => is_closed X e0 && is_closed X e1 && is_closed X e2
| Fork e => is_closed X e
| Loc l => true
| Alloc e => is_closed X e
| Load e => is_closed X e
| Store e1 e2 => is_closed X e1 && is_closed X e2
| Cas e0 e1 e2 => is_closed X e0 && is_closed X e1 && is_closed X e2
Fixpoint expr_beq {X Y} (e : expr X) (e' : expr Y) : bool :=
match e, e' with
| Var x _, Var x' _ => bool_decide (x = x')
| Rec f x e, Rec f' x' e' =>
bool_decide (f = f') && bool_decide (x = x') && expr_beq e e'
| App e1 e2, App e1' e2' | Pair e1 e2, Pair e1' e2' |
Store e1 e2, Store e1' e2' => expr_beq e1 e1' && expr_beq e2 e2'
| Lit l, Lit l' => bool_decide (l = l')
| UnOp op e, UnOp op' e' => bool_decide (op = op') && expr_beq e e'
| BinOp op e1 e2, BinOp op' e1' e2' =>
bool_decide (op = op') && expr_beq e1 e1' && expr_beq e2 e2'
| If e0 e1 e2, If e0' e1' e2' | Case e0 e1 e2, Case e0' e1' e2' |
Cas e0 e1 e2, Cas e0' e1' e2' =>
expr_beq e0 e0' && expr_beq e1 e1' && expr_beq e2 e2'
| Fst e, Fst e' | Snd e, Snd e' | InjL e, InjL e' | InjR e, InjR e' |
Fork e, Fork e' | Alloc e, Alloc e' | Load e, Load e' => expr_beq e e'
| Loc l,