From program_logic Require Export language.
From prelude Require Export strings.
From prelude Require Import gmap.

Module heap_lang.
Open Scope Z_scope.

(** Expressions and vals. *)
Definition loc := positive. (* Really, any countable type. *)

Inductive base_lit : Set :=
  | LitInt (n : Z) | LitBool (b : bool) | LitUnit.
Inductive un_op : Set :=
  | NegOp | MinusUnOp.
Inductive bin_op : Set :=
  | PlusOp | MinusOp | LeOp | LtOp | EqOp.

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 bind.
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.

(** A typeclass for whether a variable is bound in a given
   context. Making this a typeclass means we can use tpeclass search
   to program solving these constraints, so this becomes extensible.
   Also, since typeclass search runs *after* unification, Coq has already
   inferred the X for us; if we were to go for embedded proof terms ot
   tactics, Coq would do things in the wrong order. *)
Class VarBound (x : string) (X : list string) :=
  var_bound : bool_decide (x ∈ X).
(* There is no need to restrict this hint to terms without evars, [vm_compute]
will fail in case evars are arround. *)
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 (X : list string) :=
  (* Base lambda calculus *)
      (* Var is the only place where the terms contain a proof. The fact that they
       contain a proof at all is suboptimal, since this means two seeminlgy
       convertible terms could differ in their proofs. However, this also has
       some advantages:
       * We can make the [X] an index, so we can do non-dependent match.
       * In expr_weaken, we can push the proof all the way into Var, making
         sure that proofs never block computation. *)
  | 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 X)
  | BinOp (op : bin_op) (e1 e2 : expr X)
  | If (e0 e1 e2 : expr X)
  (* Products *)
  | Pair (e1 e2 : expr X)
  | Fst (e : expr X)
  | Snd (e : expr X)
  (* Sums *)
  | InjL (e : expr X)
  | InjR (e : expr X)
  | Case (e0 : expr X) (e1 : expr X) (e2 : expr X)
  (* Concurrency *)
  | Fork (e : expr X)
  (* Heap *)
  | Loc (l : loc)
  | 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 (f :b: x :b: []))
  | LitV (l : base_lit)
  | PairV (v1 v2 : val)
  | InjLV (v : val)
  | InjRV (v : val)
  | LocV (l : loc).

Bind Scope val_scope with val.
Delimit Scope val_scope with V.
Arguments PairV _%V _%V.
Arguments InjLV _%V.
Arguments InjRV _%V.

Definition signal : val := RecV BAnon (BNamed "x") (Store (Var "x") (Lit (LitInt 1))).

Fixpoint of_val (v : val) : expr [] :=
  match v with
  | RecV f x e => Rec f x e
  | LitV l => Lit l
  | PairV v1 v2 => Pair (of_val v1) (of_val v2)
  | InjLV v => InjL (of_val v)
  | InjRV v => InjR (of_val v)
  | LocV l => Loc l
  end.

Fixpoint to_val (e : expr []) : option val :=
  match e with
  | Rec f x e => Some (RecV f x e)
  | Lit l => Some (LitV l)
  | Pair e1 e2 => v1 ← to_val e1; v2 ← to_val e2; Some (PairV v1 v2)
  | InjL e => InjLV <$> to_val e
  | InjR e => InjRV <$> to_val e
  | Loc l => Some (LocV l)
  | _ => None
  end.

(** The state: heaps of vals. *)
Definition state := gmap loc val.

(** Evaluation contexts *)
Inductive ectx_item :=
  | AppLCtx (e2 : expr [])
  | AppRCtx (v1 : val)
  | UnOpCtx (op : un_op)
  | BinOpLCtx (op : bin_op) (e2 : expr [])
  | BinOpRCtx (op : bin_op) (v1 : val)
  | IfCtx (e1 e2 : expr [])
  | PairLCtx (e2 : expr [])
  | PairRCtx (v1 : val)
  | FstCtx
  | SndCtx
  | InjLCtx
  | InjRCtx
  | CaseCtx (e1 : expr []) (e2 : expr [])
  | AllocCtx
  | LoadCtx
  | StoreLCtx (e2 : expr [])
  | StoreRCtx (v1 : val)
  | 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 [] :=
  match Ki with
  | AppLCtx e2 => App e e2
  | AppRCtx v1 => App (of_val v1) e
  | UnOpCtx op => UnOp op e
  | BinOpLCtx op e2 => BinOp op e e2
  | BinOpRCtx op v1 => BinOp op (of_val v1) e
  | IfCtx e1 e2 => If e e1 e2
  | PairLCtx e2 => Pair e e2
  | PairRCtx v1 => Pair (of_val v1) e
  | FstCtx => Fst e
  | SndCtx => Snd e
  | InjLCtx => InjL e
  | InjRCtx => InjR e
  | CaseCtx e1 e2 => Case e e1 e2
  | AllocCtx => Alloc e
  | LoadCtx => Load e
  | StoreLCtx e2 => Store e e2
  | StoreRCtx v1 => Store (of_val v1) e
  | CasLCtx e1 e2 => CAS e e1 e2
  | 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.

(** Substitution *)
(** We have [subst' e BAnon v = e] to deal with anonymous binders *)
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 $ 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 (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 (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 (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.
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 :=
  match op, l with
  | NegOp, LitBool b => Some (LitBool (negb b))
  | MinusUnOp, LitInt n => Some (LitInt (- n))
  | _, _ => None
  end.

Definition bin_op_eval (op : bin_op) (l1 l2 : base_lit) : option base_lit :=
  match op, l1, l2 with
  | PlusOp, LitInt n1, LitInt n2 => Some $ LitInt (n1 + n2)
  | MinusOp, LitInt n1, LitInt n2 => Some $ LitInt (n1 - n2)
  | LeOp, LitInt n1, LitInt n2 => Some $ LitBool $ bool_decide (n1 ≤ n2)
  | LtOp, LitInt n1, LitInt n2 => Some $ LitBool $ bool_decide (n1 < n2)
  | EqOp, LitInt n1, LitInt n2 => Some $ LitBool $ bool_decide (n1 = n2)
  | _, _, _ => None
  end.

Inductive head_step : expr [] → state → expr [] → state → option (expr []) → Prop :=
  | BetaS f x e1 e2 v2 e' σ :
     to_val e2 = Some v2 →
     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
  | BinOpS op l1 l2 l' σ :
     bin_op_eval op l1 l2 = Some l' →
     head_step (BinOp op (Lit l1) (Lit l2)) σ (Lit l') σ None
  | IfTrueS e1 e2 σ :
     head_step (If (Lit $ LitBool true) e1 e2) σ e1 σ None
  | IfFalseS e1 e2 σ :
     head_step (If (Lit $ LitBool false) e1 e2) σ e2 σ None
  | FstS e1 v1 e2 v2 σ :
     to_val e1 = Some v1 → to_val e2 = Some v2 →
     head_step (Fst (Pair e1 e2)) σ e1 σ None
  | SndS e1 v1 e2 v2 σ :
     to_val e1 = Some v1 → to_val e2 = Some v2 →
     head_step (Snd (Pair e1 e2)) σ e2 σ None
  | CaseLS e0 v0 e1 e2 σ :
     to_val e0 = Some v0 →
     head_step (Case (InjL e0) e1 e2) σ (App e1 e0) σ None
  | CaseRS e0 v0 e1 e2 σ :
     to_val e0 = Some v0 →
     head_step (Case (InjR e0) e1 e2) σ (App e2 e0) σ None
  | ForkS e σ:
     head_step (Fork e) σ (Lit LitUnit) σ (Some e)
  | AllocS e v σ l :
     to_val e = Some v → σ !! l = None →
     head_step (Alloc e) σ (Loc l) (<[l:=v]>σ) None
  | LoadS l v σ :
     σ !! l = Some v →
     head_step (Load (Loc l)) σ (of_val v) σ None
  | StoreS l e v σ :
     to_val e = Some v → is_Some (σ !! l) →
     head_step (Store (Loc l) e) σ (Lit LitUnit) (<[l:=v]>σ) None
  | CasFailS l e1 v1 e2 v2 vl σ :
     to_val e1 = Some v1 → to_val e2 = Some v2 →
     σ !! l = Some vl → vl ≠ v1 →
     head_step (CAS (Loc l) e1 e2) σ (Lit $ LitBool false) σ None
  | CasSucS l e1 v1 e2 v2 σ :
     to_val e1 = Some v1 → to_val e2 = Some v2 →
     σ !! l = Some v1 →
     head_step (CAS (Loc l) e1 e2) σ (Lit $ LitBool true) (<[l:=v2]>σ) None.

(** Atomic expressions *)
Definition atomic (e: expr []) : Prop :=
  match e with
  | Alloc e => is_Some (to_val e)
  | Load e => is_Some (to_val e)
  | Store e1 e2 => is_Some (to_val e1) ∧ is_Some (to_val e2)
  | CAS e0 e1 e2 => is_Some (to_val e0) ∧ is_Some (to_val e1) ∧ is_Some (to_val e2)
  (* Make "skip" atomic *)
  | App (Rec _ _ (Lit _)) (Lit _) => True
  | _ => False
  end.

(** 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 :=
  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.

Lemma of_val'_closed (v : val) :
  of_val' v = of_val v.
Proof. by rewrite /of_val' wexpr_id. Qed.

(** to_val propagation.
    TODO: automatically appliy in wp_tactics? *)
Lemma to_val_InjL e v : to_val e = Some v → to_val (InjL e) = Some (InjLV v).
Proof. move=>H. simpl. by rewrite H. Qed.
Lemma to_val_InjR e v : to_val e = Some v → to_val (InjR e) = Some (InjRV v).
Proof. move=>H. simpl. by rewrite H. Qed.
Lemma to_val_Pair e1 e2 v1 v2 :
  to_val e1 = Some v1 → to_val e2 = Some v2 →
  to_val (Pair e1 e2) = Some (PairV v1 v2).
Proof. move=>H1 H2. simpl. by rewrite H1 H2. 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 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.
Proof. by intros ?? Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed.

Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki).
Proof. destruct Ki; intros ???; simplify_eq/=; auto with f_equal. Qed.

Instance ectx_fill_inj K : Inj (=) (=) (fill K).
Proof. red; induction K as [|Ki K IH]; naive_solver. Qed.

Lemma fill_app K1 K2 e : fill (K1 ++ K2) e = fill K1 (fill K2 e).
Proof. revert e; induction K1; simpl; auto with f_equal. Qed.

Lemma fill_val K e : is_Some (to_val (fill K e)) → is_Some (to_val e).
Proof.
  intros [v' Hv']; revert v' Hv'.
  induction K as [|[]]; intros; simplify_option_eq; eauto.
Qed.

Lemma fill_not_val K e : to_val e = None → to_val (fill K e) = None.
Proof. rewrite !eq_None_not_Some; eauto using fill_val. Qed.

Lemma val_head_stuck e1 σ1 e2 σ2 ef :
  head_step e1 σ1 e2 σ2 ef → to_val e1 = None.
Proof. destruct 1; naive_solver. Qed.

Lemma val_stuck e1 σ1 e2 σ2 ef : prim_step e1 σ1 e2 σ2 ef → to_val e1 = None.
Proof. intros [??? -> -> ?]; eauto using fill_not_val, val_head_stuck. Qed.

Lemma atomic_not_val e : atomic e → to_val e = None.
Proof. destruct e; naive_solver. Qed.

Lemma atomic_fill_item Ki e : atomic (fill_item Ki e) → is_Some (to_val e).
Proof.
  intros. destruct Ki; simplify_eq/=; destruct_and?;
    repeat (case_match || contradiction); eauto.
Qed.

Lemma atomic_fill K e : atomic (fill K e) → to_val e = None → K = [].
Proof.
  destruct K as [|Ki K]; [done|].
  rewrite eq_None_not_Some=> /= ? []; eauto using atomic_fill_item, fill_val.
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. subst.
  unfold subst'; repeat (case_match || contradiction || simplify_eq/=); eauto.
Qed.

Lemma atomic_step e1 σ1 e2 σ2 ef :
  atomic e1 → prim_step e1 σ1 e2 σ2 ef → is_Some (to_val e2).
Proof.
  intros Hatomic [K e1' e2' -> -> Hstep].
  assert (K = []) as -> by eauto 10 using atomic_fill, val_head_stuck.
  naive_solver eauto using atomic_head_step.
Qed.

Lemma head_ctx_step_val Ki e σ1 e2 σ2 ef :
  head_step (fill_item Ki e) σ1 e2 σ2 ef → is_Some (to_val e).
Proof. destruct Ki; inversion_clear 1; simplify_option_eq; eauto. Qed.

Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 :
  to_val e1 = None → to_val e2 = None →
  fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2.
Proof.
  destruct Ki1, Ki2; intros; try discriminate; simplify_eq/=;
    repeat match goal with
    | H : to_val (of_val _) = None |- _ => by rewrite to_of_val in H
    end; auto.
Qed.

(* When something does a step, and another decomposition of the same expression
has a non-val [e] in the hole, then [K] is a left sub-context of [K'] - in
other words, [e] also contains the reducible expression *)
Lemma step_by_val K K' e1 e1' σ1 e2 σ2 ef :
  fill K e1 = fill K' e1' → to_val e1 = None → head_step e1' σ1 e2 σ2 ef →
  K `prefix_of` K'.
Proof.
  intros Hfill Hred Hnval; revert K' Hfill.
  induction K as [|Ki K IH]; simpl; intros K' Hfill; auto using prefix_of_nil.
  destruct K' as [|Ki' K']; simplify_eq/=.
  { exfalso; apply (eq_None_not_Some (to_val (fill K e1)));
      eauto using fill_not_val, head_ctx_step_val. }
  cut (Ki = Ki'); [naive_solver eauto using prefix_of_cons|].
  eauto using fill_item_no_val_inj, val_head_stuck, fill_not_val.
Qed.

Lemma alloc_fresh e v σ :
  let l := fresh (dom _ σ) in
  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.

(** Equality and other typeclass 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 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, Loc l' => bool_decide (l = l')
  | _, _ => false
  end.
Lemma expr_beq_correct {X} (e1 e2 : expr X) : expr_beq e1 e2 ↔ e1 = e2.
Proof.
  split.
  * revert e2; induction e1; intros [] * ?; simpl in *;
      destruct_and?; subst; repeat f_equal/=; auto; try apply proof_irrel.
  * intros ->. induction e2; naive_solver.
Qed.
Instance expr_dec_eq {X} (e1 e2 : expr X) : Decision (e1 = e2).
Proof.
 refine (cast_if (decide (expr_beq e1 e2))); by rewrite -expr_beq_correct.
Defined.
Instance val_dec_eq (v1 v2 : val) : Decision (v1 = v2).
Proof.
 refine (cast_if (decide (of_val v1 = of_val v2))); abstract naive_solver.
Defined.

Instance expr_inhabited X : Inhabited (expr X) := populate (Lit LitUnit).
Instance val_inhabited : Inhabited val := populate (LitV LitUnit).
End heap_lang.

(** Language *)
Program Canonical Structure heap_lang : language := {|
  expr := heap_lang.expr []; val := heap_lang.val; state := heap_lang.state;
  of_val := heap_lang.of_val; to_val := heap_lang.to_val;
  atomic := heap_lang.atomic; prim_step := heap_lang.prim_step;
|}.
Solve Obligations with eauto using heap_lang.to_of_val, heap_lang.of_to_val,
  heap_lang.val_stuck, heap_lang.atomic_not_val, heap_lang.atomic_step.

Global Instance heap_lang_ctx K : LanguageCtx heap_lang (heap_lang.fill K).
Proof.
  split.
  - eauto using heap_lang.fill_not_val.
  - intros ????? [K' e1' e2' Heq1 Heq2 Hstep].
    by exists (K ++ K') e1' e2'; rewrite ?heap_lang.fill_app ?Heq1 ?Heq2.
  - intros e1 σ1 e2 σ2 ? Hnval [K'' e1'' e2'' Heq1 -> Hstep].
    destruct (heap_lang.step_by_val
      K K'' e1 e1'' σ1 e2'' σ2 ef) as [K' ->]; eauto.
    rewrite heap_lang.fill_app in Heq1; apply (inj _) in Heq1.
    exists (heap_lang.fill K' e2''); rewrite heap_lang.fill_app; split; auto.
    econstructor; eauto.
Qed.

Global Instance heap_lang_ctx_item Ki :
  LanguageCtx heap_lang (heap_lang.fill_item Ki).
Proof. change (LanguageCtx heap_lang (heap_lang.fill [Ki])). apply _. Qed.

(* Prefer heap_lang names over language names. *)
Export heap_lang.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import Bool.
Require Import Sumbool.
Require Import Arith.
Require Import ZArith NArith Nnat Ndec Ndigits.
From IntMap Require Import Map.
From IntMap Require Import Allmaps.
Require Import List.
Require Import Wf_nat.

Require Import misc.
Require Import bool_fun.
Require Import myMap.
Require Import config.
Require Import alloc.
Require Import make.
Require Import op.

Section BDDuniv_sec.

Variable gc : BDDconfig -> list ad -> BDDconfig.
Hypothesis gc_is_OK : gc_OK gc.

Fixpoint BDDuniv_1 (cfg : BDDconfig) (ul : list ad)
 (node : ad) (y : BDDvar) (bound : nat) {struct bound} :
 BDDconfig * ad :=
  match bound with
  | O => (* Error *)  (initBDDconfig, BDDzero)
  | S bound' =>
      match MapGet2 _ (um_of_cfg cfg) node y with
      | Some node' => (cfg, node')
      | None =>
          match MapGet _ (fst cfg) node with
          | None => (cfg, node)
          | Some (x, (l, r)) =>
              match BDDcompare x y with
              | Datatypes.Lt => (cfg, node)
              | Datatypes.Eq => BDDand gc cfg ul l r
              | Datatypes.Gt =>
                  match BDDuniv_1 cfg ul l y bound' with
                  | (cfgl, nodel) =>
                      match BDDuniv_1 cfgl (nodel :: ul) r y bound' with
                      | (cfgr, noder) =>
                          match
                            BDDmake gc cfgr x nodel noder
                              (noder :: nodel :: ul)
                          with
                          | (cfg', node') =>
                              (BDDuniv_memo_put cfg' y node node', node')
                          end
                      end
                  end
              end
          end
      end
  end.

Lemma BDDuniv_1_lemma :
 forall (bound : nat) (cfg : BDDconfig) (ul : list ad)
   (u : BDDvar) (node : ad),
 nat_of_N (node_height cfg node) < bound ->
 BDDconfig_OK cfg ->
 used_list_OK cfg ul ->
 used_node' cfg ul node ->
 BDDconfig_OK (fst (BDDuniv_1 cfg ul node u bound)) /\
 config_node_OK (fst (BDDuniv_1 cfg ul node u bound))
   (snd (BDDuniv_1 cfg ul node u bound)) /\
 used_nodes_preserved cfg (fst (BDDuniv_1 cfg ul node u bound)) ul /\
 Nleb
   (node_height (fst (BDDuniv_1 cfg ul node u bound))
      (snd (BDDuniv_1 cfg ul node u bound))) (node_height cfg node) = true /\
 bool_fun_eq
   (bool_fun_of_BDD (fst (BDDuniv_1 cfg ul node u bound))
      (snd (BDDuniv_1 cfg ul node u bound)))
   (bool_fun_forall u (bool_fun_of_BDD cfg node)).
Proof.
  simple induction bound.  intros.  absurd (nat_of_N (node_height cfg node) < 0).
  apply lt_n_O.  assumption.  simpl in |- *.  intros.
  elim (option_sum _ (MapGet2 ad (um_of_cfg cfg) node u)).  intro y.
  elim y; clear y; intros node' H4.  rewrite H4.  simpl in |- *.
  elim (um_of_cfg_OK _ H1 u node node' H4).  intros.  split.  assumption.
  split.  inversion H6.  inversion H8.  assumption.  split.
  apply used_nodes_preserved_refl.  split.  exact (proj1 (proj2 H6)).
  exact (proj2 (proj2 H6)).  intro y.  rewrite y.
  elim (option_sum _ (MapGet (BDDvar * (ad * ad)) (fst cfg) node)).  intro y0.
  elim y0; clear y0.
  intro x; elim x; clear x; intros x x0; elim x0; clear x0; intros l r H4.
  rewrite H4.  cut (used_node' cfg ul l).  cut (used_node' cfg ul r).
  elim (relation_sum (BDDcompare x u)).  intro y0.  elim y0; clear y0.
  intros y0.  rewrite y0.  split.  apply BDDand_config_OK.  assumption.
  assumption.  assumption.  assumption.  assumption.  split.
  apply BDDand_node_OK.  assumption.  assumption.  assumption.  assumption.
  assumption.  split.  apply BDDand_used_nodes_preserved.  assumption.
  assumption.  assumption.  assumption.  assumption.  split.
  apply
   Nleb_trans with (b := BDDvar_max (node_height cfg l) (node_height cfg r)).
  apply BDDand_var_le.  assumption.  assumption.  assumption.  assumption.
  assumption.  unfold Nleb in |- *.
  rewrite (BDDvar_max_max (node_height cfg l) (node_height cfg r)).
  apply leb_correct.  apply lt_le_weak.  apply
   lt_le_trans
    with
      (m := max (nat_of_N (node_height cfg node))
              (nat_of_N (node_height cfg node))).
  apply lt_max_1_2.  apply BDDcompare_lt.  unfold node_height in |- *.
  apply bs_node_height_left with (x := x) (r := r).  exact (proj1 H1).  assumption.
  apply BDDcompare_lt.  unfold node_height in |- *.
  apply bs_node_height_right with (x := x) (l := l).  exact (proj1 H1).  assumption.
  rewrite (max_x_x_eq_x (nat_of_N (node_height cfg node))).  apply le_n.
  rewrite <- (BDD_EGAL_complete _ _ y0).
  apply
   bool_fun_eq_trans
    with
      (bf2 := bool_fun_forall u
                (bool_fun_if x (bool_fun_of_BDD cfg r)
                   (bool_fun_of_BDD cfg l))).
  apply
   bool_fun_eq_trans
    with
      (bf2 := bool_fun_and (bool_fun_of_BDD cfg r) (bool_fun_of_BDD cfg l)).
  apply
   bool_fun_eq_trans
    with
      (bf2 := bool_fun_and (bool_fun_of_BDD cfg l) (bool_fun_of_BDD cfg r)).
  apply BDDand_is_and.  assumption.  assumption.  assumption.  assumption.
  assumption.  apply bool_fun_and_comm.  apply bool_fun_eq_sym.
  rewrite (BDD_EGAL_complete _ _ y0).  apply bool_fun_forall_if_egal.
  unfold bool_fun_of_BDD in |- *.  rewrite <- (BDD_EGAL_complete _ _ y0).
  apply BDDvar_independent_high with (x := x) (l := l) (node := node).
  exact (proj1 H1).  assumption.  unfold bool_fun_of_BDD in |- *.
  rewrite <- (BDD_EGAL_complete _ _ y0).
  apply BDDvar_independent_low with (x := x) (r := r) (node := node).  exact (proj1 H1).
  assumption.  rewrite <- (BDD_EGAL_complete _ _ y0).
  apply bool_fun_forall_preserves_eq.  apply bool_fun_eq_sym.
  apply bool_fun_of_BDD_int.  assumption.  assumption.  intros y0.  rewrite y0.
  split.  assumption.  split.  apply used_node'_OK with (ul := ul).  assumption.
  assumption.  assumption.  split.  apply used_nodes_preserved_refl.  split.
  apply Nleb_refl.  simpl in |- *.  apply bool_fun_eq_sym.
  apply bool_fun_forall_independent.  unfold bool_fun_of_BDD in |- *.
  apply BDDvar_independent_bs.  exact (proj1 H1).
  fold (node_OK (fst cfg) node) in |- *.  fold (config_node_OK cfg node) in |- *.
  apply used_node'_OK with (ul := ul).  assumption.  assumption.  assumption.
  unfold bs_node_height in |- *.  rewrite H4.  unfold Nleb in |- *.  rewrite (ad_S_is_S x).
  apply leb_correct.  fold lt in |- *.  fold (nat_of_N x < nat_of_N u) in |- *.
  apply BDDcompare_lt.  assumption.  intros y0 H5 H6.  rewrite y0.
  elim (prod_sum _ _ (BDDuniv_1 cfg ul l u n)).  intros cfgl H7.
  elim H7; clear H7.  intros nodel H7.  rewrite H7.
  elim (prod_sum _ _ (BDDuniv_1 cfgl (nodel :: ul) r u n)).  intros cfgr H8.
  elim H8; clear H8.  intros noder H8.  rewrite H8.  elim (prod_sum _ _ (BDDmake gc cfgr x nodel noder (noder :: nodel :: ul))).
  intros cfg' H9.  elim H9; clear H9.  intros node' H9.  rewrite H9.  simpl in |- *.
  cut
   (BDDconfig_OK cfgl /\
    config_node_OK cfgl nodel /\
    used_nodes_preserved cfg cfgl ul /\
    Nleb (node_height cfgl nodel) (node_height cfg l) = true /\
    bool_fun_eq (bool_fun_of_BDD cfgl nodel)
      (bool_fun_forall u (bool_fun_of_BDD cfg l))).
  intro.  elim H10; clear H10; intros.  elim H11; clear H11; intros.
  elim H12; clear H12; intros.  elim H13; clear H13; intros.
  cut (config_node_OK cfg l).  cut (config_node_OK cfg r).  intros.
  cut (used_list_OK cfgl ul).  intro.  cut (used_list_OK cfgl (nodel :: ul)).
  intro.  cut (used_node' cfgl ul r).  intro.
  cut (used_node' cfgl (nodel :: ul) r).  intro.
  cut
   (BDDconfig_OK cfgr /\
    config_node_OK cfgr noder /\
    used_nodes_preserved cfgl cfgr (nodel :: ul) /\
    Nleb (node_height cfgr noder) (node_height cfgl r) = true /\
    bool_fun_eq (bool_fun_of_BDD cfgr noder)
      (bool_fun_forall u (bool_fun_of_BDD cfgl r))).
  intro.  elim H21; clear H21; intros.  elim H22; clear H22; intros.
  elim H23; clear H23; intros.  elim H24; clear H24; intros.
  cut (used_list_OK cfgr (nodel :: ul)).  intro.
  cut (used_list_OK cfgr (noder :: nodel :: ul)).  intro.
  cut (used_node' cfgr (noder :: nodel :: ul) nodel).
  cut (used_node' cfgr (noder :: nodel :: ul) noder).  intros.
  cut
   (forall (xl : BDDvar) (ll rl : ad),
    MapGet _ (fst cfgr) nodel = Some (xl, (ll, rl)) ->
    BDDcompare xl x = Datatypes.Lt).
  cut
   (forall (xr : BDDvar) (lr rr : ad),
    MapGet _ (fst cfgr) noder = Some (xr, (lr, rr)) ->
    BDDcompare xr x = Datatypes.Lt).
  intros.  cut (BDDconfig_OK cfg').
  cut (used_nodes_preserved cfgr cfg' (noder :: nodel :: ul)).
  cut (config_node_OK cfg' node').

  cut
   (bool_fun_eq (bool_fun_of_BDD cfg' node')
      (bool_fun_if x (bool_fun_of_BDD cfgr noder)
         (bool_fun_of_BDD cfgr nodel))).
  cut (Nleb (node_height cfg' node') (ad_S x) = true).  intros.
  cut (config_node_OK cfg' node).  intro.
  cut (nodes_preserved cfg' (BDDuniv_memo_put cfg' u node node')).  intro.
  cut (BDDconfig_OK (BDDuniv_memo_put cfg' u node node')).  intro.  split.
  assumption.  split.  apply nodes_preserved_config_node_OK with (cfg1 := cfg').
  assumption.  assumption.  split.
  apply used_nodes_preserved_trans with (cfg2 := cfgr).  assumption.
  apply used_nodes_preserved_trans with (cfg2 := cfgl).  assumption.  assumption.
  apply used_nodes_preserved_cons with (node := nodel).  assumption.
  apply used_nodes_preserved_trans with (cfg2 := cfg').  assumption.
  apply used_nodes_preserved_cons with (node := nodel).
  apply used_nodes_preserved_cons with (node := noder).
  assumption.  apply nodes_preserved_used_nodes_preserved.  assumption.
  rewrite
   (Neqb_complete (node_height (BDDuniv_memo_put cfg' u node node') node')
      (node_height cfg' node')).
  split.  apply Nleb_trans with (b := ad_S x).  assumption.
  unfold node_height in |- *.  unfold bs_node_height in |- *.
  rewrite H4.  apply Nleb_refl.
  apply bool_fun_eq_trans with (bf2 := bool_fun_of_BDD cfg' node').
  apply nodes_preserved_bool_fun.  assumption.  assumption.  assumption.
  assumption.  apply
   bool_fun_eq_trans
    with
      (bf2 := bool_fun_if x (bool_fun_of_BDD cfgr noder)
                (bool_fun_of_BDD cfgr nodel)).
  assumption.
  apply
   bool_fun_eq_trans
    with
      (bf2 := bool_fun_if x (bool_fun_forall u (bool_fun_of_BDD cfg r))
                (bool_fun_forall u (bool_fun_of_BDD cfg l))).
  apply bool_fun_if_preserves_eq.  apply
   bool_fun_eq_trans with (bf2 := bool_fun_forall u (bool_fun_of_BDD cfgl r)).
  assumption.  apply bool_fun_forall_preserves_eq.
  apply used_nodes_preserved'_bool_fun with (ul := ul).
  assumption.  assumption.  assumption.  assumption.  assumption.
  apply bool_fun_eq_trans with (bf2 := bool_fun_of_BDD cfgl nodel).
  apply used_nodes_preserved'_bool_fun with (ul := nodel :: ul).  assumption.
  assumption.  assumption.  assumption.  apply used_node'_cons_node_ul.
  assumption.  apply bool_fun_eq_sym.
  apply
   bool_fun_eq_trans
    with
      (bf2 := bool_fun_forall u
                (bool_fun_if x (bool_fun_of_BDD cfg r)
                   (bool_fun_of_BDD cfg l))).
  apply bool_fun_forall_preserves_eq.  apply bool_fun_of_BDD_int.  assumption.
  assumption.  apply bool_fun_forall_orthogonal.  apply not_true_is_false.
  unfold not in |- *; intro.  rewrite (Neqb_complete _ _ H40) in y0.
  rewrite (BDD_EGAL_correct u) in y0.  discriminate y0.
  apply nodes_preserved_node_height_eq.
  assumption.  assumption.  assumption.  assumption.  apply BDDum_put_OK.
  assumption.  assumption.  assumption.
  rewrite (Neqb_complete (node_height cfg' node) (node_height cfg node)).
  unfold node_height at 2 in |- *.  unfold bs_node_height in |- *.  rewrite H4.  assumption.
  apply used_nodes_preserved'_node_height_eq with (ul := ul).  assumption.
  assumption.  apply used_nodes_preserved_trans with (cfg2 := cfgl).  assumption.
  assumption.  apply used_nodes_preserved_cons with (node := nodel).
  apply used_nodes_preserved_trans with (cfg2 := cfgr).  assumption.  assumption.
  apply used_nodes_preserved_cons with (node := noder).  assumption.  assumption.
  assumption.
  apply
   bool_fun_eq_trans
    with
      (bf2 := bool_fun_if x (bool_fun_of_BDD cfgr noder)
                (bool_fun_of_BDD cfgr nodel)).
  assumption.
  apply
   bool_fun_eq_trans
    with (bf2 := bool_fun_forall u (bool_fun_of_BDD cfg node)).
  apply
   bool_fun_eq_trans
    with
      (bf2 := bool_fun_if x (bool_fun_forall u (bool_fun_of_BDD cfg r))
                (bool_fun_forall u (bool_fun_of_BDD cfg l))).
  apply bool_fun_if_preserves_eq.
  apply
   bool_fun_eq_trans with (bf2 := bool_fun_forall u (bool_fun_of_BDD cfgl r)).
  assumption.  apply bool_fun_forall_preserves_eq.
  apply used_nodes_preserved'_bool_fun with (ul := ul).  assumption.  assumption.
  assumption.  assumption.  assumption.
  apply bool_fun_eq_trans with (bf2 := bool_fun_of_BDD cfgl nodel).
  apply used_nodes_preserved'_bool_fun with (ul := nodel :: ul).  assumption.
  assumption.  assumption.  assumption.  apply used_node'_cons_node_ul.
  assumption.
  apply
   bool_fun_eq_trans
    with
      (bf2 := bool_fun_forall u
                (bool_fun_if x (bool_fun_of_BDD cfg r)
                   (bool_fun_of_BDD cfg l))).
  apply bool_fun_eq_sym.  apply bool_fun_forall_orthogonal.
  apply not_true_is_false.  unfold not in |- *; intro.
  rewrite (Neqb_complete _ _ H39) in y0.  rewrite (BDD_EGAL_correct u) in y0.
  discriminate y0.
  apply bool_fun_forall_preserves_eq.  apply bool_fun_eq_sym.
  apply bool_fun_of_BDD_int.  assumption.  assumption.
  apply bool_fun_forall_preserves_eq.  apply bool_fun_eq_sym.
  apply used_nodes_preserved'_bool_fun with (ul := ul).  assumption.  assumption.
  apply used_nodes_preserved_trans with (cfg2 := cfgl).  assumption.  assumption.
  apply used_nodes_preserved_trans with (cfg2 := cfgr).  assumption.
  apply used_nodes_preserved_cons with (node := nodel).  assumption.
  apply used_nodes_preserved_cons with (node := nodel).
  apply used_nodes_preserved_cons with (node := noder).  assumption.  assumption.
  assumption.  apply BDDum_put_nodes_preserved.
  apply used_nodes_preserved_node_OK' with (ul := ul) (cfg := cfg).  assumption.
  assumption.  assumption.  apply used_nodes_preserved_trans with (cfg2 := cfgl).
  assumption.  assumption.  apply used_nodes_preserved_trans with (cfg2 := cfgr).
  assumption.  apply used_nodes_preserved_cons with (node := nodel).  assumption.
  apply used_nodes_preserved_cons with (node := nodel).
  apply used_nodes_preserved_cons with (node := noder).  assumption.
  replace cfg' with
   (fst (BDDmake gc cfgr x nodel noder (noder :: nodel :: ul))).
  replace node' with
   (snd (BDDmake gc cfgr x nodel noder (noder :: nodel :: ul))).
  apply BDDmake_node_height_le.  assumption.
  assumption.  rewrite H9; reflexivity.  rewrite H9; reflexivity.
  replace cfg' with
   (fst (BDDmake gc cfgr x nodel noder (noder :: nodel :: ul))).
  replace node' with
   (snd (BDDmake gc cfgr x nodel noder (noder :: nodel :: ul))).
  apply BDDmake_bool_fun.  assumption.  assumption.  assumption.  assumption.
  assumption.  assumption.  assumption.  rewrite H9.  reflexivity.  rewrite H9.
reflexivity.
  replace cfg' with
   (fst (BDDmake gc cfgr x nodel noder (noder :: nodel :: ul))).
  replace node' with
   (snd (BDDmake gc cfgr x nodel noder (noder :: nodel :: ul))).
  apply BDDmake_node_OK.  assumption.  assumption.  assumption.  assumption.
  assumption.  assumption.  assumption.  rewrite H9.  reflexivity.  rewrite H9.
reflexivity.
 replace cfg' with
  (fst (BDDmake gc cfgr x nodel noder (noder :: nodel :: ul))).
  replace node' with
   (snd (BDDmake gc cfgr x nodel noder (noder :: nodel :: ul))).
  apply BDDmake_preserves_used_nodes.  assumption.  assumption.  assumption.

  rewrite H9.  reflexivity.  rewrite H9.  reflexivity.
  replace cfg' with
   (fst (BDDmake gc cfgr x nodel noder (noder :: nodel :: ul))).
  apply BDDmake_keeps_config_OK.  assumption.  assumption.  assumption.
  assumption.  assumption.  assumption.   assumption.
  rewrite H9.  reflexivity.
  intros.  rewrite (ad_S_compare xr x).
  replace (ad_S xr) with (node_height cfgr noder).
  replace (ad_S x) with (node_height cfg node).   (* Unfold node_height in H24.*)
  apply BDDlt_compare.  apply le_lt_trans with (m := nat_of_N (node_height cfgl r)).
  apply leb_complete.  assumption.
  rewrite (Neqb_complete (node_height cfgl r) (node_height cfg r)).
  apply BDDcompare_lt.  unfold node_height in |- *.  apply bs_node_height_right with (x := x) (l := l).
  exact (proj1 H1).  assumption.
  apply used_nodes_preserved'_node_height_eq with (ul := ul).  assumption.
  assumption.  assumption.  assumption.  assumption.
  unfold node_height in |- *.  unfold bs_node_height in |- *.  rewrite H4.  reflexivity.
  unfold node_height in |- *.  unfold bs_node_height in |- *.  rewrite H30.  reflexivity.
  intros.  rewrite (ad_S_compare xl x).
  replace (ad_S xl) with (node_height cfgr nodel).
  replace (ad_S x) with (node_height cfg node). (*  Unfold node_height in H24.*)
  rewrite (Neqb_complete (node_height cfgr nodel) (node_height cfgl nodel)).
  apply BDDlt_compare.  apply le_lt_trans with (m := nat_of_N (node_height cfg l)).
  apply leb_complete.  assumption.
  apply BDDcompare_lt.  unfold node_height in |- *.  apply bs_node_height_left with (x := x) (r := r).
  exact (proj1 H1).  assumption.
  apply used_nodes_preserved'_node_height_eq with (ul := nodel :: ul).  assumption.
  assumption.  assumption.  assumption.
  apply used_node'_cons_node_ul.
  unfold node_height in |- *.  unfold bs_node_height in |- *.  rewrite H4.  reflexivity.
  unfold node_height in |- *.  unfold bs_node_height in |- *.  rewrite H30.  reflexivity.
  apply used_node'_cons_node_ul.  apply used_node'_cons_node'_ul.
  apply used_node'_cons_node_ul.  apply node_OK_list_OK.  assumption.
  assumption.  apply used_nodes_preserved_list_OK with (cfg := cfgl).  assumption.
  assumption.
  replace cfgr with (fst (BDDuniv_1 cfgl (nodel :: ul) r u n)).
  replace noder with (snd (BDDuniv_1 cfgl (nodel :: ul) r u n)).  apply H.
  apply lt_trans_1 with (y := nat_of_N (node_height cfg node)).
  rewrite (Neqb_complete (node_height cfgl r) (node_height cfg r)).  apply BDDcompare_lt.
  unfold node_height in |- *.  apply bs_node_height_right with (x := x) (l := l).  exact (proj1 H1).
  assumption.  apply used_nodes_preserved'_node_height_eq with (ul := ul).  assumption.
  assumption.  assumption.  assumption.  assumption.  assumption.
  assumption.  assumption.  assumption.  rewrite H8.  reflexivity.
  rewrite H8.  reflexivity.  apply used_node'_cons_node'_ul.
  apply used_nodes_preserved_used_node' with (cfg := cfg).  assumption.
  assumption.  apply high_used' with (node := node) (x := x) (l := l).  assumption.
  assumption.  assumption.
  apply used_nodes_preserved_used_node' with (cfg := cfg).  assumption.
  assumption.  assumption.  apply node_OK_list_OK.  assumption.  assumption.
  apply used_nodes_preserved_list_OK with (cfg := cfg).  assumption.  assumption.
  apply used_node'_OK with (ul := ul).  assumption.  assumption.  assumption.
  apply used_node'_OK with (ul := ul).  assumption.  assumption.  assumption.
  replace cfgl with (fst (BDDuniv_1 cfg ul l u n)).
  replace nodel with (snd (BDDuniv_1 cfg ul l u n)).  apply H.
  apply lt_trans_1 with (y := nat_of_N (node_height cfg node)).
  apply BDDcompare_lt.  unfold node_height in |- *.
  apply bs_node_height_left with (x := x) (r := r).  exact (proj1 H1).
  assumption.  assumption.  assumption.  assumption.  assumption.
  rewrite H7.  reflexivity.  rewrite H7.  reflexivity.
  apply high_used' with (node := node) (x := x) (l := l).  assumption.  assumption.
  assumption.  apply low_used' with (node := node) (x := x) (r := r).  assumption.
  assumption.  assumption.  intro y0.  rewrite y0.  simpl in |- *.  split.  assumption.
  split.  apply used_node'_OK with (ul := ul).  assumption.  assumption.
  assumption.  split.  apply used_nodes_preserved_refl.  split.
  apply Nleb_refl.  cut (config_node_OK cfg node).  intro.
  unfold config_node_OK in H4.  elim H4.  intro.  rewrite H5.
  apply bool_fun_eq_trans with bool_fun_zero.  apply bool_fun_of_BDD_zero.
  assumption.
  apply bool_fun_eq_trans with (bf2 := bool_fun_forall u bool_fun_zero).
  apply bool_fun_eq_sym.  apply bool_fun_forall_zero.
  apply bool_fun_forall_preserves_eq.  apply bool_fun_eq_sym.
  apply bool_fun_of_BDD_zero.  assumption.  intro.  elim H5.  intro.
  rewrite H6.  apply bool_fun_eq_trans with bool_fun_one.
  apply bool_fun_of_BDD_one.  assumption.
  apply bool_fun_eq_trans with (bf2 := bool_fun_forall u bool_fun_one).
  apply bool_fun_eq_sym.  apply bool_fun_forall_one.
  apply bool_fun_forall_preserves_eq.  apply bool_fun_eq_sym.
  apply bool_fun_of_BDD_one.  assumption.  unfold in_dom in |- *.  rewrite y0.
  intro; discriminate.  apply used_node'_OK with (ul := ul).  assumption.
  assumption.  assumption.
Qed.

End BDDuniv_sec.


From cap_machine Require Import rules_base.
From iris.base_logic Require Export invariants gen_heap.
From iris.program_logic Require Export weakestpre ectx_lifting.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import frac.

Section cap_lang_rules.
  Context `{memG Σ, regG Σ}.
  Context `{MachineParameters}.
  Implicit Types P Q : iProp Σ.
  Implicit Types σ : ExecConf.
  Implicit Types c : cap_lang.expr.
  Implicit Types a b : Addr.
  Implicit Types r : RegName.
  Implicit Types v : cap_lang.val.
  Implicit Types w : Word.
  Implicit Types reg : gmap RegName Word.
  Implicit Types ms : gmap Addr Word.

  (* TODO: Move somewhere *)
  Ltac destruct_cap c :=
    let p := fresh "p" in
    let g := fresh "g" in
    let b := fresh "b" in
    let e := fresh "e" in
    let a := fresh "a" in
    destruct c as ((((p & g) & b) & e) & a).

  Inductive Restrict_failure (regs: Reg) (dst: RegName) (src: Z + RegName) :=
  | Restrict_fail_dst_noncap z:
      regs !! dst = Some (inl z) →
      Restrict_failure regs dst src
  | Restrict_fail_pE p g b e a:
      regs !! dst = Some (inr (p, g, b, e, a)) →
      p = E →
      Restrict_failure regs dst src
  | Restrict_fail_src_nonz:
      z_of_argument regs src = None →
      Restrict_failure regs dst src
  | Restrict_fail_invalid_perm p g b e a n:
      regs !! dst = Some (inr (p, g, b, e, a)) →
      p ≠ E →
      z_of_argument regs src = Some n →
      PermPairFlowsTo (decodePermPair n) (p, g) = false →
      Restrict_failure regs dst src
  | Restrict_fail_PC_overflow p g b e a n:
      regs !! dst = Some (inr (p, g, b, e, a)) →
      p ≠ E →
      z_of_argument regs src = Some n →
      PermPairFlowsTo (decodePermPair n) (p, g) = true →
      incrementPC (<[ dst := inr (decodePermPair n, b, e, a) ]> regs) = None →
      Restrict_failure regs dst src.

  Inductive Restrict_spec (regs: Reg) (dst: RegName) (src: Z + RegName) (regs': Reg): cap_lang.val -> Prop :=
  | Restrict_spec_success p g b e a n:
      regs !! dst = Some (inr (p, g, b, e, a)) →
      p ≠ E ->
      z_of_argument regs src = Some n →
      PermPairFlowsTo (decodePermPair n) (p, g) = true →
      incrementPC (<[ dst := inr (decodePermPair n, b, e, a) ]> regs) = Some regs' →
      Restrict_spec regs dst src regs' NextIV
  | Restrict_spec_failure:
      Restrict_failure regs dst src →
      Restrict_spec regs dst src regs' FailedV.

  Lemma wp_Restrict Ep pc_p pc_g pc_b pc_e pc_a w dst src regs :
    decodeInstrW w = Restrict dst src ->

    isCorrectPC (inr ((pc_p, pc_g), pc_b, pc_e, pc_a)) →
    regs !! PC = Some (inr ((pc_p, pc_g), pc_b, pc_e, pc_a)) →
    regs_of (Restrict dst src) ⊆ dom _ regs →
    {{{ ▷ pc_a ↦ₐ w ∗
        ▷ [∗ map] k↦y ∈ regs, k ↦ᵣ y }}}
      Instr Executable @ Ep
    {{{ regs' retv, RET retv;
        ⌜ Restrict_spec regs dst src regs' retv ⌝ ∗
        pc_a ↦ₐ w ∗
        [∗ map] k↦y ∈ regs', k ↦ᵣ y }}}.
  Proof.
    iIntros (Hinstr Hvpc HPC Dregs φ) "(>Hpc_a & >Hmap) Hφ".
    iApply wp_lift_atomic_head_step_no_fork; auto.
    iIntros (σ1 l1 l2 n) "Hσ1 /=". destruct σ1 as [r m]; simpl.
    iDestruct "Hσ1" as "[Hr Hm]".
    iDestruct (gen_heap_valid_inclSepM with "Hr Hmap") as %Hregs.
    have HPC' := regs_lookup_eq _ _ _ HPC.
    have ? := lookup_weaken _ _ _ _ HPC Hregs.
    iDestruct (@gen_heap_valid with "Hm Hpc_a") as %Hpc_a; auto.
    iModIntro. iSplitR. by iPureIntro; apply normal_always_head_reducible.
    iNext. iIntros (e2 σ2 efs Hpstep).
    apply prim_step_exec_inv in Hpstep as (-> & -> & (c & -> & Hstep)).
    iSplitR; auto. eapply step_exec_inv in Hstep; eauto.

    specialize (indom_regs_incl _ _ _ Dregs Hregs) as Hri.
    unfold regs_of in Hri, Dregs.
    destruct (Hri dst) as [wdst [H'dst Hdst]]. by set_solver+.
    destruct wdst as [| cdst]; [| destruct_cap cdst].
    { rewrite /= /RegLocate Hdst in Hstep. destruct src; inv Hstep; simplify_pair_eq.
      all: iFailWP "Hφ" Restrict_fail_dst_noncap. }

    destruct (z_of_argument regs src) as [wsrc|] eqn:Hwsrc;
      pose proof Hwsrc as H'wsrc; cycle 1.
    { destruct src as [| r0]; cbn in Hwsrc; [ congruence |].
      destruct (Hri r0) as [r0v [Hr'0 Hr0]]. by unfold regs_of_argument; set_solver+.
      rewrite Hr'0 in Hwsrc. destruct r0v as [| cc]; [ congruence | destruct_cap cc].
      assert (c = Failed ∧ σ2 = (r, m)) as (-> & ->).
      { rewrite /= /RegLocate Hdst Hr0 in Hstep. by simplify_pair_eq. }
      iFailWP "Hφ" Restrict_fail_src_nonz. }
    eapply z_of_argument_Some_inv' in Hwsrc; eauto.

    destruct (decide (p = E)).
    { subst p. cbn in Hstep. rewrite /RegLocate Hdst in Hstep.
      repeat case_match; inv Hstep; iFailWP "Hφ" Restrict_fail_pE. }

    destruct (PermPairFlowsTo (decodePermPair wsrc) (p, g)) eqn:Hflows; cycle 1.
    { rewrite /= /RegLocate Hdst in Hstep.
      destruct Hwsrc as [ -> | (r0 & -> & Hr0 & Hr0') ].
      all: rewrite ?Hr0' Hflows in Hstep.
      all: repeat case_match; inv Hstep; iFailWP "Hφ" Restrict_fail_invalid_perm. }

    assert ((c, σ2) = updatePC (update_reg (r, m) dst (inr (decodePermPair wsrc, b, e, a)))) as HH.
    { rewrite /= /RegLocate Hdst in Hstep.
      destruct Hwsrc as [ -> | (r0 & -> & Hr0 & Hr0') ].
      all: rewrite ?Hr0' Hflows in Hstep.
      all: repeat case_match; inv Hstep; eauto; congruence. }
    clear Hstep. rewrite /update_reg /= in HH.

    destruct (incrementPC (<[ dst := inr (decodePermPair wsrc, b, e, a) ]> regs)) eqn:Hregs';
      pose proof Hregs' as H'regs'; cycle 1.
    { apply incrementPC_fail_updatePC with (m:=m) in Hregs'.
      eapply updatePC_fail_incl with (m':=m) in Hregs'.
      2: by apply lookup_insert_is_Some'; eauto.
      2: by apply insert_mono; eauto.
      simplify_pair_eq.
      iMod ((gen_heap_update_inSepM _ _ dst) with "Hr Hmap") as "[Hr Hmap]"; eauto.
      iFailWP "Hφ" Restrict_fail_PC_overflow. }

    eapply (incrementPC_success_updatePC _ m) in Hregs'
      as (p' & g' & b' & e' & a'' & a_pc' & HPC'' & Ha_pc' & HuPC & -> & ?).
    eapply updatePC_success_incl with (m':=m) in HuPC. 2: by eapply insert_mono; eauto.
    simplify_pair_eq. iFrame.
    iMod ((gen_heap_update_inSepM _ _ dst) with "Hr Hmap") as "[Hr Hmap]"; eauto.
    iMod ((gen_heap_update_inSepM _ _ PC) with "Hr Hmap") as "[Hr Hmap]"; eauto.
    iFrame. iApply "Hφ". iFrame. iPureIntro. econstructor; eauto.
  Qed.

  (*
  Lemma wp_restrict_success_reg_PC Ep pc_p pc_g pc_b pc_e pc_a pc_a' w rv z a'  :
    decodeInstrW w = Restrict PC (inr rv) →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →
    (pc_a + 1)%a = Some pc_a' →
    PermPairFlowsTo (decodePermPair z) (pc_p,pc_g) = true →

     {{{ ▷ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
         ∗ ▷ pc_a ↦ₐ w
         ∗ ▷ rv ↦ᵣ inl z }}}
       Instr Executable @ Ep
       {{{ RET NextIV;
           PC ↦ᵣ inr (decodePermPair z,pc_b,pc_e,pc_a')
           ∗ pc_a ↦ₐ w
           ∗ rv ↦ᵣ inl z }}}.
   Proof.
     iIntros (Hinstr Hvpc Hpca' Hflows ϕ) "(>HPC & >Hpc_a & >Hrv) Hφ".
     iDestruct (map_of_regs_2 with "HPC Hrv") as "[Hmap %]".
     iApply (wp_Restrict with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
     by unfold regs_of; rewrite !dom_insert; set_solver+.
     iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.
     assert (pc_p ≠ E).
     { intros ->. inversion Hvpc; subst. naive_solver. }

     destruct Hspec as [| * Hfail].
     { (* Success *)
       iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
       destruct (decodePermPair n); simplify_eq. rewrite !insert_insert.
       iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
     { (* Failure (contradiction) *)
       destruct Hfail; simplify_map_eq; eauto; try congruence.
       incrementPC_inv; simplify_map_eq; eauto. destruct e3; try congruence. }
   Qed.*)

   Lemma wp_restrict_success_reg Ep pc_p pc_g pc_b pc_e pc_a pc_a' w r1 rv p g b e a z  :
     decodeInstrW w = Restrict r1 (inr rv) →
     isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →
     (pc_a + 1)%a = Some pc_a' →
     PermPairFlowsTo (decodePermPair z) (p,g) = true →
     r1 ≠ PC → p ≠ E →

     {{{ ▷ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
         ∗ ▷ pc_a ↦ₐ w
         ∗ ▷ r1 ↦ᵣ inr ((p,g),b,e,a)
         ∗ ▷ rv ↦ᵣ inl z }}}
       Instr Executable @ Ep
       {{{ RET NextIV;
           PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e, pc_a')
           ∗ pc_a ↦ₐ w
           ∗ rv ↦ᵣ inl z
           ∗ r1 ↦ᵣ inr (decodePermPair z,b,e,a) }}}.
   Proof.
     iIntros (Hinstr Hvpc Hpca' Hflows Hne1 Hnp ϕ) "(>HPC & >Hpc_a & >Hr1 & >Hrv) Hφ".
     iDestruct (map_of_regs_3 with "HPC Hr1 Hrv") as "[Hmap (%&%&%)]".
     iApply (wp_Restrict with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
     by unfold regs_of; rewrite !dom_insert; set_solver+.
     iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC r1) // insert_insert
              (insert_commute _ PC r1) // insert_insert.
      iDestruct (regs_of_map_3 with "Hmap") as "(?&?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; simplify_map_eq; eauto; try congruence.
      incrementPC_inv; simplify_map_eq; eauto. destruct e4; try congruence.
      inv Hvpc. naive_solver. }
   Qed.

   (*
   Lemma wp_restrict_success_z_PC Ep pc_p pc_g pc_b pc_e pc_a pc_a' w z :
     decodeInstrW w = Restrict PC (inl z) →
     isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →
     (pc_a + 1)%a = Some pc_a' →
     PermPairFlowsTo (decodePermPair z) (pc_p,pc_g) = true →

     {{{ ▷ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
         ∗ ▷ pc_a ↦ₐ w }}}
       Instr Executable @ Ep
     {{{ RET NextIV;
         PC ↦ᵣ inr (decodePermPair z,pc_b,pc_e,pc_a')
         ∗ pc_a ↦ₐ w }}}.
   Proof.
     iIntros (Hinstr Hvpc Hpca' Hflows ϕ) "(>HPC & >Hpc_a) Hφ".
     iDestruct (map_of_regs_1 with "HPC") as "Hmap".
     iApply (wp_Restrict with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
     by rewrite !dom_insert; set_solver+.
     iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)".
     iDestruct "Hspec" as %Hspec.
     assert (pc_p ≠ E).
     { intros ->. inversion Hvpc; subst. naive_solver. }

     destruct Hspec as [ | * Hfail ].
     { (* Success *)
       iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
       rewrite !insert_insert. destruct (decodePermPair n); simplify_eq.
       iApply (regs_of_map_1 with "Hmap"). }
     { (* Failure (contradiction) *)
       destruct Hfail; simplify_map_eq; eauto. congruence.
       incrementPC_inv; simplify_map_eq; eauto. congruence. }
   Qed.*)

   Lemma wp_restrict_success_z Ep pc_p pc_g pc_b pc_e pc_a pc_a' w r1 p g b e a z :
     decodeInstrW w = Restrict r1 (inl z) →
     isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →
     (pc_a + 1)%a = Some pc_a' →
     PermPairFlowsTo (decodePermPair z) (p,g) = true →
     r1 ≠ PC → p ≠ E →

     {{{ ▷ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
         ∗ ▷ pc_a ↦ₐ w
         ∗ ▷ r1 ↦ᵣ inr ((p,g),b,e,a) }}}
       Instr Executable @ Ep
     {{{ RET NextIV;
         PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a')
         ∗ pc_a ↦ₐ w
         ∗ r1 ↦ᵣ inr (decodePermPair z,b,e,a) }}}.
   Proof.
     iIntros (Hinstr Hvpc Hpca' Hflows Hne1 HpE ϕ) "(>HPC & >Hpc_a & >Hr1) Hφ".
     iDestruct (map_of_regs_2 with "HPC Hr1") as "[Hmap %]".
     iApply (wp_Restrict with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
     by unfold regs_of; rewrite !dom_insert; set_solver+.
     iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.
     assert (pc_p ≠ E).
     { intros ->. inversion Hvpc; subst. naive_solver. }

     destruct Hspec as [| * Hfail].
     { (* Success *)
       iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
       destruct (decodePermPair n); simplify_eq.
       rewrite (insert_commute _ PC r1) // insert_insert
               (insert_commute _ PC r1) // insert_insert.
       iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
     { (* Failure (contradiction) *)
       destruct Hfail; simplify_map_eq; eauto; try congruence.
       incrementPC_inv; simplify_map_eq; eauto.
       destruct e4; try congruence. inv Hvpc. naive_solver. }
   Qed.

End cap_lang_rules.


(* Copyright (c) 2017, the Dart project authors.  Please see the AUTHORS file
 * for details. All rights reserved. Use of this source code is governed by a
 * BSD-style license that can be found in the LICENSE file. *)

Require Import Utf8.
Require Import ClassTestTypes.
Require Import VoidnessPreservation.

(* Works with multiple parameters, with no changes: Uncomment one of them. *)
Module MyDynamics :=
  Dynamics.NormalDynamics.

Module MyVoidnessPreservation :=
  VoidnessPreservation.VoidnessPreservationBase MyDynamics.
Import MyVoidnessPreservation.

(* ---------- Voidness Types ---------- *)

(* B<A<1>, Object> *)
Definition ct_B_A1_Object :=
  ndts_cons (B, dts_cons dt_A_void (dts_cons dt_Object dts_nil)) ct_Object.
Definition dt_B_A1_Object := dt_class ct_B_A1_Object.

(* B<Object, Object> *)
Definition ct_B_ObjectObject :=
  ndts_cons (B, dts_cons dt_Object (dts_cons dt_Object dts_nil)) ct_Object.
Definition dt_B_ObjectObject := dt_class ct_B_ObjectObject.

(* A<A<void>> *)
Definition ct_A_A_void :=
  ndts_cons (A, dts_cons dt_A_void dts_nil) ct_Object.
Definition dt_A_A_void := dt_class ct_A_A_void.

Hint Unfold
  ct_Object dt_Object ct_A_Object dt_A_Object ct_A_void dt_A_void
  ct_A_dynamic dt_A_dynamic ct_Iterable_Object dt_Iterable_Object
  ct_Iterable_void dt_Iterable_void ct_List_Object dt_List_Object
  ct_List_void dt_List_void ct_A_A_void dt_A_A_void
  ct_B_A1_Object dt_B_A1_Object ct_B_ObjectObject dt_B_ObjectObject.

(* ---------- Trying out existing examples ---------- *)

(* dynamic <:: dynamic *)
Goal VoidnessPreserves dt_dynamic dt_dynamic.
 auto.
Qed.

(* dynamic <:: void *)
Goal VoidnessPreserves dt_dynamic dt_void.
  auto.
Qed.

(* dynamic <:: variable n *)
Goal forall n, VoidnessPreserves dt_dynamic (dt_variable n).
  auto.
Qed.

(* A<Object> <:: A<void> *)
Goal VoidnessPreserves dt_A_Object dt_A_void.
  apply vp_class; apply vctsp_cons.
    apply vctp_some; apply vctps_first; auto.
  apply vctsp_cons; auto.
  apply vctp_some. apply vctps_rest. apply vctps_first. auto.
Qed.

(* A<A<void>> <:: A<void> *)
Goal VoidnessPreserves dt_A_A_void dt_A_void.
  apply vp_class; apply vctsp_cons; auto.
    apply vctp_some. apply vctps_first. apply vpp_cons; auto.
  apply vctsp_cons; auto. apply vctp_some. apply vctps_rest. apply vctps_first. auto.
Qed.

(* Not A<void> <:: A<Object> *)
Goal ~(VoidnessPreserves dt_A_void dt_A_Object).
  unfold not. intro H. inversion H. inversion H2. inversion H5.
    inversion H8. apply H14. reflexivity.
  inversion H8.
    inversion H12. inversion H19.
  inversion H13. inversion H17.
Qed.


Require Import Axioms.

Require Import VST.concurrency.sepcomp. Import SepComp.

Require Import VST.concurrency.pos.
Require Import VST.concurrency.stack.

Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq fintype finfun.
Set Implicit Arguments.

(*NOTE: because of redefinition of [val], these imports must appear
  after Ssreflect eqtype.*)
Require Import AST.    (*for typ*)
Require Import Values. (*for val*)
Require Import Globalenvs.
Require Import Integers.

Require Import ZArith.

(* This file is a parametric version of [compcert_linking.v].  See that   *)
(* file for more information.                                             *)

(* The [CoreLinker] module gives the operational semantics of linking.    *)
(* It is parameterized by the type of core semantics [Csem] (e.g., effect *)
(* semantics, coop semantics, vanilla core semantics) used to the dynamic *)
(* semantics of each translation unit.  Note that each module may still   *)
(* have its own core type C, function definition type F, etc.             *)

(* Semantics of translation units *)

Module Modsem.

Record t (M : Type) := mk
  { F   : Type
  ; V   : Type
  ; ge  : Genv.t F V
  ; C   : Type
  ; sem : @CoreSemantics (Genv.t F V) C M }.

End Modsem.

(* [Cores] are runtime execution units. *)

Module Core. Section core.

Variable M : Type.
Variable N : pos.
Variable cores : 'I_N -> Modsem.t M.

Import Modsem.

Record t := mk
  { i  : 'I_N
  ; c  :> (cores i).(C)
  ; sg : signature }.

Definition upd (core : t) (newC : (cores core.(i)).(C)) :=
  {| i := core.(i)
   ; c := newC
   ; sg := core.(sg) |}.

End core. End Core.

Arguments Core.t {M N} cores.

Arguments Core.i {M N cores} !t /.

Arguments Core.c {M N cores} !t /.

Arguments Core.sg {M N cores} !t /.

Arguments Core.upd {M N cores} !core _ /.

(* Linking semantics invariants:                                          *)
(*  -All cores except the topmost one are at_external.                    *)
(*  -The call stack always contains at least one core.                    *)

Section coreDefs.

Import Modsem.

Variable M : Type.
Variable N : pos.
Variable cores : 'I_N -> Modsem.t M.

Definition atExternal (c: Core.t cores) :=
  let: (Core.mk i c sg) := c in
  let: F := (cores i).(F) in
  let: V := (cores i).(V) in
  let: C := (cores i).(C) in
  let: sem := (cores i).(sem) in
  if @at_external (Genv.t F V) C M sem c is
    Some (ef, dep_sig, args) then true
  else false.

Definition wf_callStack (stk : Stack.t (Core.t cores)) :=
  [&& all atExternal (STACK.pop stk) & size stk > 0].

End coreDefs.

Arguments atExternal {M N} cores c.

(** Call stacks are [stack]s satisfying the [wf_callStack] invariant. *)

Module CallStack. Section callStack.

Context {M : Type} {N : pos} (cores : 'I_N -> Modsem.t M).

Record t : Type := mk
  { callStack :> Stack.t (Core.t cores)
  ; _         :  wf_callStack callStack }.

Program Definition singl (core: Core.t cores) := mk [:: core] _.

Section callStackDefs.

Context (stack : t).

Definition callStackSize := size stack.(callStack).

Lemma callStack_wf : wf_callStack stack.
Proof. by case: stack. Qed.

Lemma callStack_ext : all (atExternal cores) (STACK.pop stack).
Proof. by move: callStack_wf; move/andP=> [H1 H2]. Qed.

Lemma callStack_size : callStackSize > 0.
Proof. by move: callStack_wf; move/andP=> [H1 H2]. Qed.

Lemma callStack_nonempty : STACK.nonempty stack.
Proof. by case: stack=> //; case. Qed.

End callStackDefs.

End callStack. End CallStack.

(* [Linker.t]                                                             *)
(*                                                                        *)
(*  The first two fields of this record are static configuration data:    *)
(*                                                                        *)
(*    -[cores] is a function from module id's ('I_n, or integers in the   *)
(*     range [0..n-1]) to genvs and core semantics, with existentially    *)
(*     quantified core type [C].                                          *)
(*                                                                        *)
(*    -[fn_tbl] maps external function id's to module id's                *)
(*                                                                        *)
(*  [stack] is used to maintain a stack of cores, at runtime.             *)
(*  Parameter [N] is the number of static modules in the program.         *)

Module Linker. Section linker.

Variable M : Type.
Variable N : pos.
Variable cores : 'I_N  -> Modsem.t M.

Record t := mkLinker
  { fn_tbl : ident -> option 'I_N
  ; stack  :> CallStack.t cores }.

End linker. End Linker.

Import Linker.

Notation linker := Linker.t.

Section linkerDefs.

Context {M : Type} {N : pos} (my_cores : 'I_N -> Modsem.t M) (l : linker N my_cores).

Import CallStack. (*for coercion [callStack]*)

Definition updStack (newStack : CallStack.t my_cores) :=
  {| fn_tbl := l.(fn_tbl)
   ; stack  := newStack |}.

(* [inContext]: The top core on the call stack has a return context  *)

Definition inContext (l0 : linker N my_cores) := callStackSize l0.(stack) > 1.

(* [updCore]: Replace the top core on the call stack with [newCore]  *)

Program Definition updCore (newCore: Core.t my_cores) :=
  updStack (CallStack.mk (STACK.push (STACK.pop l.(stack)) newCore) _).
Next Obligation. apply/andP; split=>/=; last by []; by apply: callStack_ext. Qed.

Lemma updCore_inj newCore newCore' :
  updCore newCore = updCore newCore' -> newCore=newCore'.
Proof. by case. Qed.

Lemma updCore_inj_upd c c1 c2 :
  updCore (Core.upd c c1) = updCore (Core.upd c c2) -> c1=c2.
Proof.
case=> H1; move: (EqdepFacts.eq_sigT_snd H1); move=> <-.
by rewrite -Eqdep.Eq_rect_eq.eq_rect_eq.
Qed.

(* [pushCore]: Push a new core onto the call stack.                       *)
(* Succeeds only if all cores are currently at_external.                  *)

Lemma stack_push_wf newCore :
  all (atExternal my_cores) l.(stack).(callStack) ->
  wf_callStack (SeqStack.updStack (newCore :: l.(stack).(callStack))).
Proof.
by rewrite/wf_callStack=> H; apply/andP; split.
Qed.

Definition pushCore
  (newCore: Core.t my_cores)
  (pf : all (atExternal my_cores) l.(stack).(callStack)) :=
  updStack (CallStack.mk (STACK.push l.(stack) newCore) (stack_push_wf _ pf)).

(* [popCore]: Pop the top core on the call stack.                         *)
(* Succeeds only if the top core is running in a return context.          *)

Lemma inContext_wf (stk : Stack.t (Core.t my_cores)) :
  size stk > 1 -> wf_callStack stk -> wf_callStack (STACK.pop stk).
Proof.
rewrite/wf_callStack=> H1; move/andP=> [H2 H3]; apply/andP; split.
- by apply: STACK.all_pop.
- by move: H1 H2 H3; case: stk.
Qed.

Program Definition popCore : option (linker N my_cores) :=
  (match inContext l as pf
         return (pf = inContext l -> option (linker N my_cores)) with
    | true => fun pf =>
        Some (updStack (CallStack.mk (STACK.pop l.(stack))
                                     (inContext_wf _ _ _)))
    | false => fun pf => None
  end) Logic.eq_refl.
Next Obligation. by apply: callStack_wf. Qed.

Definition peekCore := STACK.head l.(stack) (callStack_nonempty l.(stack)).

Definition emptyStack := if l.(stack).(callStack) is [::] then true else false.

Import Modsem.

Definition initCore (sg: signature) (ix: 'I_N) (v: val) (args: list val)
  : option (Core.t my_cores):=
  if @initial_core _ _ _
       (my_cores ix).(sem)
       (my_cores ix).(Modsem.ge)
       v args
  is Some c then Some (Core.mk _ my_cores ix c sg)
  else None.

End linkerDefs.

Notation ge_ty := (Genv.t unit unit).

Arguments updStack {M N} {my_cores} !_ _ /.

Arguments updCore {M N} {my_cores} !_ _ /.

Arguments pushCore {M N} {my_cores} !l _ _ /.

Arguments peekCore {M N} {my_cores} !l /.

Arguments emptyStack {M N} {my_cores} !l /.

Lemma popCoreI M N my_cores l l' pf :
  inContext l ->
  l' = updStack l (CallStack.mk (STACK.pop (CallStack.callStack l)) pf) ->
  @popCore M N my_cores l = Some l'.
Proof.
rewrite /popCore.
move: (popCore_obligation_1 l); move: (popCore_obligation_2 l).
case: (inContext l)=> pf1 pf2 // _ ->.
f_equal=> //.
f_equal=> //.
f_equal=> //.
by apply: proof_irr.
Qed.

Lemma popCoreE M N my_cores l l' :
  @popCore M N my_cores l = Some l' ->
  exists pf,
  [/\ inContext l
    & l' = updStack l (CallStack.mk (STACK.pop (CallStack.callStack l)) pf)].
Proof.
rewrite /popCore.
move: (popCore_obligation_1 l); move: (popCore_obligation_2 l).
case: (inContext l)=> pf1 pf2 //; case=> <-.
have pf: wf_callStack (STACK.pop (CallStack.callStack l)).
{ case: (andP (pf1 erefl))=> A B; apply/andP; split=> //.
  by apply: SeqStack.all_pop.
  by move: (pf2 erefl); clear pf1 pf2 A B; case: l=> /= ?; case; elim. }
exists pf; split=> //.
by f_equal; f_equal; apply: proof_irr.
Qed.

(** The linking semantics *)

Module LinkerSem. Section linkerSem.

Variable M : Type.
Variable N : pos.  (* Number of (compile-time) modules *)
Variable my_cores : 'I_N  -> Modsem.t M.
Variable my_fn_tbl: ident -> option 'I_N.

(* [handle id l args] looks up function id [id] in function table         *)
(* [l.fn_tbl], producing an optional module index [ix : 'I_N].  The index *)
(* is used to construct a new core to handle the call to function         *)
(* [id]. The new core is pushed onto the call stack.                      *)

Section handle.

Variables (sg: signature) (id: ident) (l: linker N my_cores) (args: list val).

Import CallStack.

Definition handle :=
  (match all (atExternal my_cores) l.(stack).(callStack) as pf
        return (pf = all (atExternal my_cores) l.(stack).(callStack)
               -> option (linker N my_cores)) with
    | true => fun pf =>
        if l.(fn_tbl) id is Some ix then
        if Genv.find_symbol (my_cores ix).(Modsem.ge) id is Some bf then
        if initCore my_cores sg ix (Vptr bf Int.zero) args is Some c
          then Some (pushCore l c (Logic.eq_sym pf))
        else None else None else None
    | false => fun _ => None
  end) erefl.

End handle.

Section handle_lems.

Import CallStack.

Lemma handleP sg id l args l' :
  handle sg id l args = Some l' <->
  (exists (pf : all (atExternal my_cores) l.(stack).(callStack)) ix bf c,
     [/\ l.(fn_tbl) id = Some ix
       , Genv.find_symbol (my_cores ix).(Modsem.ge) id = Some bf
       , initCore my_cores sg ix (Vptr bf Int.zero) args = Some c
       & l' = pushCore l c pf]).
Proof.
rewrite/handle.
rewrite /pushCore.
generalize (stack_push_wf l).
pattern (all (atExternal my_cores) (CallStack.callStack (stack l)))
 at 1 2 3 4 5 6 7 8 9.
case f: (all _ _); move=> pf.
case g: (fn_tbl l id)=> [ix|].
case fnd: (Genv.find_symbol _ _)=> [bf|].
case h: (initCore _ _ _)=> [c|].
split=> H.
exists (erefl true),ix,bf,c; split=> //; first by case: H=> <-.
case: H=> pf0 []ix0 []bf0 []c0 []; case=> <-.
rewrite fnd; case=> <-; rewrite h; case=> <- ->.
by repeat f_equal; apply: proof_irr.
split=> //; case=> pf0 []ix0 []bf0 []c0 [].
by case=> <-; rewrite fnd; case=> <-; rewrite h.
split=> //; case=> pf0 []ix0 []bf0 []c0 [].
by case=> <-; rewrite fnd; discriminate.
split=> //.
by case=> pf0 []ix0 []bf0 []c0 []; discriminate.
split=> //.
by case=> pf0 []ix0 []bf0 []c0 []; discriminate.
Qed.

End handle_lems.

Definition main_sig := mksignature nil (Some Tint) cc_default.

Definition initial_core (ge: ge_ty) (v: val) (args: list val)
  : option (linker N my_cores) :=
  if v is Vptr bf ofs then
  if Int.eq ofs Int.zero then
  if Genv.invert_symbol ge bf is Some id then
  if my_fn_tbl id is Some ix then
  if initCore my_cores main_sig ix (Vptr bf Int.zero) args is Some c
  then Some (mkLinker my_fn_tbl (CallStack.singl c))
  else None else None else None else None else None.

(* Functions suffixed w/ 0 always operate on the running core on the (top *)
(* of the) call stack.                                                    *)

Definition at_external0 (l: linker N my_cores) :=
  let: c   := peekCore l in
  let: ix  := c.(Core.i) in
  let: sem := (my_cores ix).(Modsem.sem) in
  let: F   := (my_cores ix).(Modsem.F) in
  let: V   := (my_cores ix).(Modsem.V) in
    @at_external (Genv.t F V) _ _ sem (Core.c c).

Arguments at_external0 !l.

Require Import VST.concurrency.val_casted. (*for val_has_type_func*)

Definition halted0 (l: linker N my_cores) :=
  let: c   := peekCore l in
  let: ix  := c.(Core.i) in
  let: sg  := c.(Core.sg) in
  let: sem := (my_cores ix).(Modsem.sem) in
  let: F   := (my_cores ix).(Modsem.F) in
  let: V   := (my_cores ix).(Modsem.V) in
    if @halted (Genv.t F V) _ _ sem (Core.c c) is Some v then
      if val_casted.val_has_type_func v (proj_sig_res sg) then Some v
      else None
    else None.

Arguments halted0 !l.

(* [corestep0] lifts a corestep of the runing core to a corestep of the   *)
(* whole program semantics.                                               *)

Definition corestep0
  (l: linker N my_cores) (m: M) (l': linker N my_cores) (m': M) :=
  let: c   := peekCore l in
  let: ix  := c.(Core.i) in
  let: sem := (my_cores ix).(Modsem.sem) in
  let: F   := (my_cores ix).(Modsem.F) in
  let: V   := (my_cores ix).(Modsem.V) in
  let: ge  := (my_cores ix).(Modsem.ge) in
    exists c',
      @corestep (Genv.t F V) _ _ sem ge (Core.c c) m c' m'
   /\ l' = updCore l (Core.upd c c').

Arguments corestep0 !l m l' m'.

Definition fun_id (ef: external_function) : option ident :=
  if ef is (EF_external id sig) then Some id else None.

(* The linker is [at_external] whenever the top core is [at_external] and *)
(* the [id] of the called external function isn't handleable by any       *)
(* compilation unit.                                                      *)

Definition at_external (l: linker N my_cores) :=
  if at_external0 l is Some (ef, dep_sig, args)
    then if fun_id ef is Some id then
         if fn_tbl l id is None then Some (ef, dep_sig, args) else None
         else Some (ef, dep_sig, args)
  else at_external0 l.

Definition after_external (mv: option val) (l: linker N my_cores) :=
  let: c   := peekCore l in
  let: ix  := c.(Core.i) in
  let: sem := (my_cores ix).(Modsem.sem) in
  let: F   := (my_cores ix).(Modsem.F) in
  let: V   := (my_cores ix).(Modsem.V) in
  let: ge  := (my_cores ix).(Modsem.ge) in
    if @after_external (Genv.t F V) _ _ sem mv (Core.c c)
      is Some c' then Some (updCore l (Core.upd c c'))
    else None.

(* The linker is [halted] when the last core on the call stack is halted. *)

Definition halted (l: linker N my_cores) :=
  if ~~inContext l then
  if halted0 l is Some rv then Some rv
  else None else None.

(* Corestep relation of linking semantics *)

Definition corestep
  (l: linker N my_cores) (m: M)
  (l': linker N my_cores) (m': M) :=

  (** 1- The running core takes a step, or *)
  corestep0 l m l' m' \/

  (** 2- We're in a function call context. In this case, the running core is either *)
  (m=m'
   /\ ~corestep0 l m l' m'
   /\
      (** 3- at_external, in which case we push a core onto the stack to handle
         the external function call (or this is not possible because no module
         handles the external function id, in which case the entire linker is
         at_external) *)

      if at_external0 l is Some (ef, dep_sig, args) then
      if fun_id ef is Some id then
      if handle (ef_sig ef) id l args is Some l'' then l'=l'' else False else False
      else

      (** 4- or halted, in which case we pop the halted core from the call stack
         and inject its return value into the caller's corestate. *)

      if inContext l then
      if halted0 l is Some rv then
      if popCore l is Some l0 then
      if after_external (Some rv) l0 is Some l'' then l'=l''
      else False else False else False

     else False).

Inductive Corestep : linker N my_cores -> M
                  -> linker N my_cores -> M -> Prop :=
| Corestep_step :
  forall l m c' m',
  let: c     := peekCore l in
  let: c_ix  := Core.i c in
  let: c_ge  := Modsem.ge (my_cores c_ix) in
  let: c_sem := Modsem.sem (my_cores c_ix) in
    semantics.corestep c_sem c_ge (Core.c c) m c' m' ->
    Corestep l m (updCore l (Core.upd (peekCore l) c')) m'

| Corestep_call :
  forall (l : linker N my_cores) m ef dep_sig args id bf d_ix d
         (pf : all (atExternal my_cores) (CallStack.callStack l)),

  let: c := peekCore l in
  let: c_ix  := Core.i c in
  let: c_ge  := Modsem.ge (my_cores c_ix) in
  let: c_sem := Modsem.sem (my_cores c_ix) in

  semantics.at_external c_sem (Core.c c) = Some (ef,dep_sig,args) ->
  fun_id ef = Some id ->
  fn_tbl l id = Some d_ix ->
  Genv.find_symbol (my_cores d_ix).(Modsem.ge) id = Some bf ->

  let: d_ge  := Modsem.ge (my_cores d_ix) in
  let: d_sem := Modsem.sem (my_cores d_ix) in

  semantics.initial_core d_sem d_ge (Vptr bf Int.zero) args = Some d ->
  Corestep l m (pushCore l (Core.mk _ _ _ d (ef_sig ef)) pf) m

| Corestep_return :
  forall (l : linker N my_cores) l'' m rv d',

  1 < CallStack.callStackSize (stack l) ->

  let: c  := peekCore l in
  let: c_ix  := Core.i c in
  let: c_sg  := Core.sg c in
  let: c_ge  := Modsem.ge (my_cores c_ix) in
  let: c_sem := Modsem.sem (my_cores c_ix) in

  popCore l = Some l'' ->

  let: d  := peekCore l'' in
  let: d_ix  := Core.i d in
  let: d_ge  := Modsem.ge (my_cores d_ix) in
  let: d_sem := Modsem.sem (my_cores d_ix) in

  semantics.halted c_sem (Core.c c) = Some rv ->
  val_has_type_func rv (proj_sig_res c_sg)=true ->
  semantics.after_external d_sem (Some rv) (Core.c d) = Some d' ->
  Corestep l m (updCore l'' (Core.upd d d')) m.

Lemma CorestepE l m l' m' :
  Corestep l m l' m' ->
  corestep l m l' m'.
Proof.
inversion 1; subst; rename H0 into A; rename H into B.
by left; exists c'; split.
right; split=> //.
split=> //.
rewrite /corestep0=> [][]c' []step.
by rewrite /= (corestep_not_at_external _ _ _ _ _ _ step) in A.
rewrite /= in A.
rewrite /inContext /at_external0 A H1.
case e: (handle _ _ _)=> //[l'|].
move: e; case/handleP=> pf' []ix' []bf' []c []C G D ->.
move: D; rewrite /initCore.
rewrite H2 in C; case: C=> eq; subst ix'.
rewrite G in H3; case: H3=> ->.
by rewrite /= in H4; rewrite H4; case=> <-; f_equal; apply: proof_irr.
move: e; rewrite/handle /pushCore.
generalize (stack_push_wf l).
pattern (all (atExternal my_cores) (CallStack.callStack (stack l)))
 at 1 2 3 4 5 6 7.
case f: (all _ _)=> pf'.
rewrite /= in H4; rewrite H2 H3 /initCore H4; discriminate.
by rewrite pf in f.
right; split=> //.
split=> //.
rewrite /corestep0=> [][]c' []step.
by rewrite /= (corestep_not_halted _ _ _ _ _ _ step) in H2.
have at_ext:
  semantics.at_external
    (Modsem.sem (my_cores (Core.i (peekCore l))))
    (Core.c (peekCore l)) = None.
{ case: (@at_external_halted_excl _ _ _
         (Modsem.sem (my_cores (Core.i (peekCore l))))
         (Core.c (peekCore l)))=> //.
  by rewrite /= in H2; rewrite H2. }
rewrite /= in at_ext; rewrite /inContext A /at_external0 H1 at_ext.
by rewrite /= in H2 H4; rewrite /halted0 H2 /after_external H3 H4.
Qed.

Lemma CorestepI l m l' m' :
  corestep l m l' m' ->
  Corestep l m l' m'.
Proof.
case.
case=> c []step ->.
by apply: Corestep_step.
case=> <-.
case=> nstep.
case atext: (at_external0 _)=> [[[ef dep_sig] args]|//].
case funid: (fun_id ef)=> [id|//].
case hdl:   (handle (ef_sig ef) id l args)=> [l''|//] ->.
move: hdl; case/handleP=> pf []ix []bf []c []fntbl genv init ->.
move: init; rewrite /initCore.
case init: (semantics.initial_core _ _ _)=> [c'|//]; case=> <-.
by apply: (@Corestep_call _ _ ef dep_sig args id bf).
case inCtx: (inContext _)=> //.
case hlt: (halted0 _)=> [rv|//].
case pop: (popCore _)=> [c|//].
case aft: (after_external _ _)=> [l''|//] ->.
move: aft; rewrite /after_external.
case aft: (semantics.after_external _ _)=> [c''|//].
rewrite /halted0 in hlt; move: hlt.
case hlt: (semantics.halted _)=> //.
case oval: (val_has_type_func _ _)=> //; case=> Heq. subst. case=> <-.
by apply: (@Corestep_return _ _ _ rv c'').
Qed.

Lemma CorestepP l m l' m' :
  corestep l m l' m' <-> Corestep l m l' m'.
Proof. by split; [apply: CorestepI | apply: CorestepE]. Qed.

Lemma corestep_not_at_external0 m c m' c' :
  corestep0 c m c' m' -> at_external0 c = None.
Proof. by move=>[]newCore []H1 H2; apply corestep_not_at_external in H1. Qed.

Lemma at_external_halted_excl0 c : at_external0 c = None \/ halted0 c = None.
Proof.
case: (@at_external_halted_excl _ _ _
        (Modsem.sem (my_cores (Core.i (peekCore c))))
        (Core.c (peekCore c))).
by rewrite /at_external0=> ->; left.
by rewrite /halted0=> ->; right.
Qed.

Lemma corestep_not_halted0 m c m' c' : corestep0 c m c' m' -> halted c = None.
Proof.
move=> []newCore []H1 H2; rewrite/halted.
case Hcx: (~~ inContext _)=>//; case Hht: (halted0 _)=>//.
by move: Hht; rewrite/halted0; apply corestep_not_halted in H1; rewrite /= H1.
Qed.

Lemma corestep_not_halted0' m c m' c' : corestep0 c m c' m' -> halted0 c = None.
Proof.
move=> []newCore []H1 H2; rewrite/halted.
case Hht: (halted0 _)=>//.
by move: Hht; rewrite/halted0; apply corestep_not_halted in H1; rewrite /= H1.
Qed.

Lemma corestep_not_at_external (ge : ge_ty) m c m' c' :
  corestep c m c' m' -> at_external c = None.
Proof.
rewrite/corestep/at_external.
move=> [H|[_ [_ H]]]; first by move: H; move/corestep_not_at_external0=> /= ->.
move: H; case Heq: (at_external0 c)=>[[[ef sig] args]|//].
move: Heq; case: (at_external_halted_excl0 c)=> [H|H]; first by rewrite H.
move=> H2; case: (fun_id ef)=>// id; case hdl: (handle _ _ _)=> [a|].
by move: hdl; case/handleP=> ? []? []? []? []->.
by [].
Qed.

Lemma at_external0_not_halted c x :
  at_external0 c = Some x -> halted c = None.
Proof.
case: (at_external_halted_excl0 c); rewrite/at_external0/halted.
by case Heq: (peekCore c)=>//[a] ->.
move=> H; case Heq: (peekCore c)=>//[a].
by case Hcx: (~~ inContext _)=>//; rewrite H.
Qed.

Lemma corestep_not_halted (ge : ge_ty) m c m' c' :
  corestep c m c' m' -> halted c = None.
Proof.
rewrite/corestep.
move=> [H|[_ [_ H]]]; first by move: H; move/corestep_not_halted0.
move: H; case Hat: (at_external0 _)=> [x|//].
by rewrite (at_external0_not_halted _ Hat).
by rewrite /halted; case Hcx: (inContext _).
Qed.

Lemma at_external_halted_excl c :
  at_external c = None \/ halted c = None.
Proof.
rewrite/at_external/halted; case Hat: (at_external0 c)=>//;
first by right; apply: (at_external0_not_halted _ Hat).
by left.
Qed.

Definition coresem : CoreSemantics ge_ty (linker N my_cores) M :=
  Build_CoreSemantics ge_ty (linker N my_cores) M
    initial_core
    at_external
    after_external
    halted
    (fun _ : ge_ty => corestep)
    corestep_not_at_external
    corestep_not_halted
    at_external_halted_excl.

End linkerSem. End LinkerSem.


Require Import Coq.Setoids.Setoid Coq.Classes.Morphisms.
Definition f (v : option nat) := match v with
                                 | Some k => Some k
                                 | None => None
                                 end.

Axioms F G : (option nat -> option nat) -> Prop.
Axiom FG : forall f, f None = None -> F f = G f.

Axiom admit : forall {T}, T.

Existing Instance eq_Reflexive.

Global Instance foo (A := nat)
  : Proper ((pointwise_relation _ eq)
              ==> eq ==> forall_relation (fun _ => Basics.flip Basics.impl))
           (@option_rect A (fun _ => Prop)) | 0.
exact admit.
Qed.

Global Instance bar (A := nat)
  : Proper ((pointwise_relation _ eq)
              ==> eq ==> eq ==> Basics.flip Basics.impl)
           (@option_rect A (fun _ => Prop)) | 0.
exact admit.
Qed.

Goal forall k, option_rect (fun _ => Prop) (fun v : nat => v = v /\ F f) True k.
Proof.
  intro.
  pose proof (_ : (Proper (_ ==> eq ==> _) and)).
  setoid_rewrite (FG _ _); [ | reflexivity.. ].
  Undo.
  setoid_rewrite (FG _ eq_refl). (* Error: Tactic failure: setoid rewrite failed: Nothing to rewrite. in 8.5 *) Admitted.


Require Import Lia.
Require Import RelationClasses.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Language.

From PromisingLib Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.

Require Import PromiseConsistent.
Require Import ReorderPromise.
Require Import ReorderPromises.
Require Import MemoryReorder.
Require Import MemoryFacts.
Require Import Pred.
Require Import MemoryProps.

Set Implicit Arguments.

Lemma reorder_read_cancel
      lc0 mem0
      lc1 mem1
      lc2
      loc1 from1 to1 msg1
      loc2 to2 val2 released2 ord2
      (STEP1: Local.read_step lc0 mem0 loc2 to2 val2 released2 ord2 lc1)
      (STEP2: Local.promise_step lc1 mem0 loc1 from1 to1 msg1 lc2 mem1 Memory.op_kind_cancel)
  :
    exists lc1',
      (<<STEP1: Local.promise_step lc0 mem0 loc1 from1 to1 msg1 lc1' mem1 Memory.op_kind_cancel>>) /\
      (<<STEP2: Local.read_step lc1' mem1 loc2 to2 val2 released2 ord2 lc2>>).
Proof.
  inv STEP1. inv STEP2.
  hexploit MemoryFacts.promise_get1_diff; eauto.
  { ii. clarify. ss. inv PROMISE.
    eapply Memory.remove_get0 in MEM. des. clarify. }
  i. des. esplits; eauto.
Qed.

Lemma remove_non_synch_loc loc0 prom0 loc1 from to msg prom1
      (NONSYNCH: Memory.nonsynch_loc loc0 prom0)
      (REMOVE: Memory.remove prom0 loc1 from to msg prom1)
  :
    Memory.nonsynch_loc loc0 prom1.
Proof.
  ii. erewrite Memory.remove_o in GET; eauto.
  des_ifs. exploit NONSYNCH; eauto.
Qed.

Lemma remove_non_synch prom0 loc from to msg prom1
      (NONSYNCH: Memory.nonsynch prom0)
      (REMOVE: Memory.remove prom0 loc from to msg prom1)
  :
    Memory.nonsynch prom1.
Proof.
  ii. erewrite Memory.remove_o in GET; eauto.
  des_ifs. exploit NONSYNCH; eauto.
Qed.

Lemma reorder_write_cancel
      lc0 sc0 mem0
      lc1 mem1
      lc2 sc2 mem2
      loc1 from1 to1 msg1
      loc2 from2 to2 val2 releasedm2 released2 ord2 kind2
      (STEP1: Local.write_step lc0 sc0 mem0 loc2 from2 to2 val2 releasedm2 released2 ord2 lc1 sc2 mem1 kind2)
      (STEP2: Local.promise_step lc1 mem1 loc1 from1 to1 msg1 lc2 mem2 Memory.op_kind_cancel)
  :
    exists lc1' mem1',
      (<<STEP1: Local.promise_step lc0 mem0 loc1 from1 to1 msg1 lc1' mem1' Memory.op_kind_cancel>>) /\
      (<<STEP2: Local.write_step lc1' sc0 mem1' loc2 from2 to2 val2 releasedm2 released2 ord2 lc2 sc2 mem2 kind2>>).
Proof.
  inv STEP1. inv STEP2. ss.
  exploit MemoryReorder.write_cancel; [exact WRITE| exact PROMISE|]. i. des.
  esplits.
  - econs; eauto.
    inv CANCEL1. eapply Memory.cancel_closed_message; eauto.
  - econs; eauto.
    i. hexploit RELEASE; eauto. i. inv CANCEL1.
    eapply remove_non_synch_loc; eauto.
Qed.

Lemma reorder_write_na_cancel
      lc0 sc0 mem0
      lc1 mem1
      lc2 sc2 mem2
      loc1 from1 to1 msg1
      loc2 from2 to2 val2 ord2 msgs2 kinds2 kind2
      (STEP1: Local.write_na_step lc0 sc0 mem0 loc2 from2 to2 val2 ord2 lc1 sc2 mem1 msgs2 kinds2 kind2)
      (STEP2: Local.promise_step lc1 mem1 loc1 from1 to1 msg1 lc2 mem2 Memory.op_kind_cancel)
  :
    exists lc1' mem1',
      (<<STEP1: Local.promise_step lc0 mem0 loc1 from1 to1 msg1 lc1' mem1' Memory.op_kind_cancel>>) /\
      (<<STEP2: Local.write_na_step lc1' sc0 mem1' loc2 from2 to2 val2 ord2 lc2 sc2 mem2 msgs2 kinds2 kind2>>).
Proof.
  inv STEP1. inv STEP2. ss.
  exploit MemoryReorder.write_na_cancel; [exact WRITE|exact PROMISE|]. i. des.
  esplits.
  - econs; eauto.
    inv CANCEL1. eapply Memory.cancel_closed_message; eauto.
  - econs; eauto.
Qed.

Lemma reorder_fence_cancel
      lc0 mem0
      lc1 mem1
      lc2
      loc1 from1 to1 msg1
      ord1 ord2 sc0 sc1
      (STEP1: Local.fence_step lc0 sc0 ord1 ord2 lc1 sc1)
      (STEP2: Local.promise_step lc1 mem0 loc1 from1 to1 msg1 lc2 mem1 Memory.op_kind_cancel)
  :
    exists lc1',
      (<<STEP1: Local.promise_step lc0 mem0 loc1 from1 to1 msg1 lc1' mem1 Memory.op_kind_cancel>>) /\
      (<<STEP2: Local.fence_step lc1' sc0 ord1 ord2 lc2 sc1>>).
Proof.
  inv STEP1. inv STEP2. ss. esplits.
  - econs; eauto.
  - econs; eauto.
    + inv PROMISE. i. eapply remove_non_synch; eauto.
    + i. ss. subst. erewrite PROMISES in *; auto.
      inv PROMISE. eapply Memory.remove_get0 in PROMISES0. des.
      erewrite Memory.bot_get in *. ss.
Qed.

Lemma reorder_promise_consistent_cancel
      lc1 mem1 loc from to msg lc2 mem2
      (CONS: Local.promise_consistent lc1)
      (STEP: Local.promise_step lc1 mem1 loc from to msg lc2 mem2 Memory.op_kind_cancel):
  (<<CONS: Local.promise_consistent lc2>>).
Proof.
  inv STEP. inv PROMISE. ii. ss.
  revert PROMISE. erewrite Memory.remove_o; eauto. condtac; ss. eauto.
Qed.

Lemma reorder_failure_cancel
      lc1 mem1
      lc2 mem2
      loc1 from1 to1 msg1
      (STEP1: Local.failure_step lc1)
      (STEP2: Local.promise_step lc1 mem1 loc1 from1 to1 msg1 lc2 mem2 Memory.op_kind_cancel):
  (<<STEP2: Local.failure_step lc2>>).
Proof.
  inv STEP1. econs.
  eapply reorder_promise_consistent_cancel; eauto.
Qed.

Lemma reorder_is_racy_cancel
      lc1 mem1
      lc2 mem2
      loc2 to2 ord2
      loc1 from1 to1 msg1
      (RACY: Local.is_racy lc1 mem1 loc2 to2 ord2)
      (STEP: Local.promise_step lc1 mem1 loc1 from1 to1 msg1 lc2 mem2 Memory.op_kind_cancel):
  (<<RACY: Local.is_racy lc2 mem2 loc2 to2 ord2>>).
Proof.
  inv RACY. inv STEP. inv PROMISE.
  exploit Memory.remove_get1; try exact GET; eauto. i. des.
  { subst.
    exploit Memory.remove_get0; try exact PROMISES. i. des. congr.
  }
  econs; eauto. s.
  erewrite Memory.remove_o; eauto. condtac; ss.
Qed.

Lemma reorder_racy_read_cancel
      lc1 mem1
      lc2 mem2
      loc2 to2 val2 ord2
      loc1 from1 to1 msg1
      (STEP1: Local.racy_read_step lc1 mem1 loc2 to2 val2 ord2)
      (STEP2: Local.promise_step lc1 mem1 loc1 from1 to1 msg1 lc2 mem2 Memory.op_kind_cancel):
  (<<STEP2: Local.racy_read_step lc2 mem2 loc2 to2 val2 ord2>>).
Proof.
  inv STEP1. econs.
  eapply reorder_is_racy_cancel; eauto.
Qed.

Lemma reorder_racy_write_cancel
      lc1 mem1
      lc2 mem2
      loc2 to2 ord2
      loc1 from1 to1 msg1
      (STEP1: Local.racy_write_step lc1 mem1 loc2 to2 ord2)
      (STEP2: Local.promise_step lc1 mem1 loc1 from1 to1 msg1 lc2 mem2 Memory.op_kind_cancel):
  (<<STEP2: Local.racy_write_step lc2 mem2 loc2 to2 ord2>>).
Proof.
  inv STEP1. econs.
  - eapply reorder_is_racy_cancel; eauto.
  - eapply reorder_promise_consistent_cancel; eauto.
Qed.

Lemma reorder_racy_update_cancel
      lc1 mem1
      lc2 mem2
      loc2 to2 ordr2 ordw2
      loc1 from1 to1 msg1
      (STEP1: Local.racy_update_step lc1 mem1 loc2 to2 ordr2 ordw2)
      (STEP2: Local.promise_step lc1 mem1 loc1 from1 to1 msg1 lc2 mem2 Memory.op_kind_cancel):
  (<<STEP2: Local.racy_update_step lc2 mem2 loc2 to2 ordr2 ordw2>>).
Proof.
  inv STEP1.
  - econs 1; eauto.
    eapply reorder_promise_consistent_cancel; eauto.
  - econs 2; eauto.
    eapply reorder_promise_consistent_cancel; eauto.
  - econs 3; eauto.
    + eapply reorder_is_racy_cancel; eauto.
    + eapply reorder_promise_consistent_cancel; eauto.
Qed.

Lemma reorder_step_cancel
      lang
      pf1 pf2 e1 e2 th0 th1 th2
      (STEP1: @Thread.step lang pf1 e1 th0 th1)
      (STEP2: Thread.step pf2 e2 th1 th2)
      (CANCEL: ThreadEvent.is_cancel e2):
  (exists th1',
    (<<STEP1: Thread.step pf2 e2 th0 th1'>>) /\
    (<<STEP2: Thread.step pf1 e1 th1' th2>>)) \/
  (th2 = th0 /\ <<RESERVE: ThreadEvent.is_reserve e1>>)
.
Proof.
  unfold ThreadEvent.is_cancel in *. des_ifs.
  inv STEP2; inv STEP; [|inv LOCAL]. ss.
  inv STEP1; ss.
  - inv STEP. ss. exploit reorder_promise_promise_cancel; eauto.
    i. des; clarify; eauto.
    left. esplits.
    + econs 1. econs; eauto.
    + econs 1. econs; eauto.
  - left. inv STEP. ss. inv LOCAL0; ss.
    + esplits.
      * econs 1. econs; eauto.
      * econs 2. econs; eauto; ss.
    + exploit reorder_read_cancel; eauto. i. des. esplits.
      * econs 1. econs; eauto.
      * econs 2. econs; eauto; ss.
    + exploit reorder_write_cancel; eauto. i. des. esplits.
      * econs 1. econs; eauto.
      * econs 2. econs; eauto; ss.
    + exploit reorder_write_cancel; eauto. i. des.
      exploit reorder_read_cancel; eauto. i. des.
      esplits.
      * econs 1. econs; eauto.
      * econs 2. econs; eauto; ss.
    + exploit reorder_fence_cancel; eauto. i. des. esplits.
      * econs 1. econs; eauto.
      * econs 2. econs; eauto; ss.
    + exploit reorder_fence_cancel; eauto. i. des. esplits.
      * econs 1. econs; eauto.
      * econs 2. econs; eauto; ss.
    + exploit reorder_failure_cancel; eauto. i. des. esplits.
      * econs 1. econs; eauto.
      * econs 2. econs; eauto.
    + exploit reorder_write_na_cancel; eauto. i. des. esplits.
      * econs 1. econs; eauto.
      * econs 2. econs; eauto.
    + exploit reorder_racy_read_cancel; eauto. i. des. esplits.
      * econs 1. econs; eauto.
      * econs 2. econs; eauto.
    + exploit reorder_racy_write_cancel; eauto. i. des. esplits.
      * econs 1. econs; eauto.
      * econs 2. econs; eauto.
    + exploit reorder_racy_update_cancel; eauto. i. des. esplits.
      * econs 1. econs; eauto.
      * econs 2. econs; eauto.
Qed.

Lemma reorder_step_cancels
      lang
      pf e1 th0 th1 th2
      (STEP1: Thread.step pf e1 th0 th1)
      (STEPS2: rtc (@Thread.cancel_step lang) th1 th2)
  :
    (exists th1',
        (<<STEPS1: rtc (@Thread.cancel_step lang) th0 th1'>>) /\
        (<<STEP2: Thread.step pf e1 th1' th2>>)) \/
    ((<<STEPS1: rtc (@Thread.cancel_step lang) th0 th2>>) /\ (<<RESERVE: ThreadEvent.is_reserve e1>>))
.
Proof.
  ginduction STEPS2; i.
  - esplits; eauto.
  - inv H. exploit reorder_step_cancel.
    { eapply STEP1. }
    { eapply STEP. }
    { ss. }
    i. des.
    { exploit IHSTEPS2; eauto. i. des.
      - left. esplits.
        + econs 2.
          * splits; auto. econs; eauto.
          * eauto.
        + eauto.
      - right. splits; auto. econs 2; eauto. econs; eauto.
    }
    { subst. right. esplits; eauto. }
Qed.

Lemma reorder_opt_step_cancels
      lang
      e1 th0 th1 th2
      (STEP1: Thread.opt_step e1 th0 th1)
      (STEPS2: rtc (@Thread.cancel_step lang) th1 th2)
  :
    (exists th1',
        (<<STEPS1: rtc (@Thread.cancel_step lang) th0 th1'>>) /\
        (<<STEP2: Thread.opt_step e1 th1' th2>>)) \/
    ((<<STEPS1: rtc (@Thread.cancel_step lang) th0 th2>>) /\ (<<RESERVE: ThreadEvent.is_reserve e1>>)).
Proof.
  inv STEP1.
  { left. esplits; eauto. econs 1. }
  { exploit reorder_step_cancels; eauto. i. des.
    { left. esplits; eauto. econs 2; eauto. }
    { right. esplits; eauto. }
  }
Qed.

Lemma reorder_opt_step_cancels2
      lang
      e1 th0 th1 th2
      (STEP1: Thread.opt_step e1 th0 th1)
      (STEPS2: rtc (@Thread.cancel_step lang) th1 th2)
  :
    exists th1' e1',
      (<<STEPS1: rtc (@Thread.cancel_step lang) th0 th1'>>) /\
      (<<STEP2: Thread.opt_step e1' th1' th2>>) /\
      __guard__(e1' = e1 \/ e1' = ThreadEvent.silent /\ <<RESERVE: ThreadEvent.is_reserve e1>>).
Proof.
  unguard. inv STEP1.
  { esplits.
    { eauto. }
    { econs 1. }
    { auto. }
  }
  { exploit reorder_step_cancels; eauto. i. des.
    { esplits; eauto. econs 2; eauto. }
    { esplits; eauto. econs 1; eauto. }
  }
Qed.

Lemma steps_cancels_not_cancels
      P lang th0 th2
      (STEPS: rtc (tau (@pred_step P lang)) th0 th2)
  :
    exists th1,
      (<<STEPS1: rtc (@Thread.cancel_step _) th0 th1>>) /\
      (<<STEPS2: rtc (tau (@pred_step (P /1\ fun e => ~ ThreadEvent.is_cancel e) _)) th1 th2>>)
.
Proof.
  ginduction STEPS; i.
  - esplits; eauto.
  - inv H. inv TSTEP. inv STEP.
    hexploit IHSTEPS; eauto. i. des.
    destruct (classic (ThreadEvent.is_cancel e)).
    + unfold ThreadEvent.is_cancel in H. des_ifs. esplits.
      * econs 2.
        { econs; eauto. }
        { eapply STEPS1. }
      * eapply STEPS2.
    + exploit reorder_step_cancels.
      { eapply STEP0. }
      { eapply STEPS1. }
      i. des; eauto. esplits.
      * eauto.
      * econs 2.
        { econs; eauto. econs; eauto. econs; eauto. }
        { eauto. }
Qed.