Require Import CodeProofDeps.
Require Import Ident.
Require Import Constants.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import CommonLib.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsIntro.Layer.
Require Import TableDataOpsRef1.Code.table_destroy1.

Require Import TableDataOpsRef1.LowSpecs.table_destroy1.

Local Open Scope Z_scope.

Section CodeProof.

  Context `{real_params: RealParams}.
  Context {memb} `{Hmemx: Mem.MemoryModelX memb}.
  Context `{Hmwd: UseMemWithData memb}.

  Let mem := mwd (cdata RData).

  Context `{Hstencil: Stencil}.
  Context `{make_program_ops: !MakeProgramOps Clight.function type Clight.fundef type}.
  Context `{Hmake_program: !MakeProgram Clight.function type Clight.fundef type}.

  Let L : compatlayer (cdata RData) :=
    _table_destroy ↦ gensem table_destroy_spec
  .

  Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.
  Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

  Section BodyProof.

    Context `{Hwb: WritableBlockOps}.
    Variable (sc: stencil).
    Variables (ge: genv) (STENCIL_MATCHES: stencil_matches sc ge).

    Variable b_table_destroy: block.
    Hypothesis h_table_destroy_s : Genv.find_symbol ge _table_destroy = Some b_table_destroy.
    Hypothesis h_table_destroy_p : Genv.find_funct_ptr ge b_table_destroy
                                   = Some (External (EF_external _table_destroy
                                                    (signature_of_type (Tcons Tptr (Tcons tulong (Tcons tulong (Tcons tulong Tnil)))) tulong cc_default))
                                          (Tcons Tptr (Tcons tulong (Tcons tulong (Tcons tulong Tnil)))) tulong cc_default).
    Local Opaque table_destroy_spec.

    Lemma table_destroy1_body_correct:
      forall m d d' env le g_rd_base g_rd_offset map_addr rtt_addr level res
             (Henv: env = PTree.empty _)
             (Hinv: high_level_invariant d)
             (HPTg_rd: PTree.get _g_rd le = Some (Vptr g_rd_base (Int.repr g_rd_offset)))
             (HPTmap_addr: PTree.get _map_addr le = Some (Vlong map_addr))
             (HPTrtt_addr: PTree.get _rtt_addr le = Some (Vlong rtt_addr))
             (HPTlevel: PTree.get _level le = Some (Vlong level))
             (Hspec: table_destroy1_spec0 (g_rd_base, g_rd_offset) (VZ64 (Int64.unsigned map_addr)) (VZ64 (Int64.unsigned rtt_addr)) (VZ64 (Int64.unsigned level)) d = Some (d', VZ64 (Int64.unsigned res))),
           exists le', (exec_stmt ge env le ((m, d): mem) table_destroy1_body E0 le' (m, d') (Out_return (Some (Vlong res, tulong)))).
    Proof.
      solve_code_proof Hspec table_destroy1_body; eexists; solve_proof_low.
    Qed.

  End BodyProof.

End CodeProof.


Require Import Coq.Classes.Morphisms.
Require Import Coq.Relations.Relations.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Structures.Monad.
Require Import ExtLib.Structures.Traversable.
Require Import ExtLib.Data.Option.
Require Import ExtLib.Data.Prop.
Require Import ExtLib.Data.Pair.
Require Import ExtLib.Data.List.
Require Import ExtLib.Data.HList.
Require Import ExtLib.Data.Monads.OptionMonad.
Require Import ExtLib.Tactics.
Require Import MirrorCore.ExprI.
Require Import MirrorCore.SubstI.
Require Import MirrorCore.ExprDAs.
Require Import MirrorCore.RTac.Core.

Require Import MirrorCore.Util.Quant.
Require Import MirrorCore.Util.Forwardy.

Set Implicit Arguments.
Set Strict Implicit.

Section parameterized.
  Variable typ : Set.
  Variable expr : Set.

  Context {RType_typ : RType typ}.
  Context {RTypeOk_typ : RTypeOk}.
  Context {Typ0_Prop : Typ0 _ Prop}.
  Context {Expr_expr : Expr typ expr}.
  Context {ExprOk_expr : ExprOk Expr_expr}.

(*
  (** TODO(gmalecha): These should go somewhere more useful *)
  Fixpoint forgets (from : nat) (ts : list typ) (s : subst)
  : list (option expr) :=
    match ts with
      | nil => nil
      | t :: ts =>
        let rr := forgets (S from) ts s in
        let ne := subst_lookup from s in
        ne :: rr
    end.

  Fixpoint remembers (from : nat) (tes : list (typ * option expr)) (s : subst)
  : option subst :=
    match tes with
      | nil => Some s
      | (_,None) :: tes' => remembers (S from) tes' s
      | (_,Some e) :: tes' =>
        (* This should not be necessary but to eliminate it, we must have a
         * syntactic soundness condition for [set] *)
        match subst_lookup from s with
          | None =>
            match subst_set from e s with
              | None => None
              | Some s' => remembers (S from) tes' s'
            end
          | Some _ => None
        end
    end.
*)

  Definition rtacK_spec ctx (s : ctx_subst ctx) (g : Goal _ _)
             (r : Result ctx) : Prop :=
    match r with
      | Fail => True
      | Solved s' =>
        WellFormed_Goal (getUVars ctx) (getVars ctx) g ->
        WellFormed_ctx_subst s ->
        WellFormed_ctx_subst s' /\
        match pctxD s
            , goalD _ _ g
            , pctxD s'
        with
          | None , _ , _
          | Some _ , None , _ => True
          | Some _ , Some _ , None => False
          | Some cD , Some gD , Some cD' =>
            SubstMorphism s s' /\
            forall us vs, cD' gD us vs
        end
      | More_ s' g' =>
        WellFormed_Goal (getUVars ctx) (getVars ctx) g ->
        WellFormed_ctx_subst s ->
        WellFormed_ctx_subst s' /\
        WellFormed_Goal (getUVars ctx) (getVars ctx) g' /\
        match pctxD s
            , goalD _ _ g
            , pctxD s'
            , goalD _ _ g'
        with
          | None , _ , _ , _
          | Some _ , None , _ , _ => True
          | Some _ , Some _ , None , _
          | Some _ , Some _ , Some _ , None => False
          | Some cD , Some gD , Some cD' , Some gD' =>
            SubstMorphism s s' /\
            forall us vs,
              cD' (fun us vs => gD' us vs -> gD us vs) us vs
        end
    end.

  Definition rtacK_spec_wf ctx (s : ctx_subst ctx) (g : Goal _ _)
             (r : Result ctx) : Prop :=
    match r with
      | Fail => True
      | Solved s' =>
        WellFormed_Goal (getUVars ctx) (getVars ctx) g ->
        WellFormed_ctx_subst s ->
        WellFormed_ctx_subst s'
      | More_ s' g' =>
        WellFormed_Goal (getUVars ctx) (getVars ctx) g ->
        WellFormed_ctx_subst s ->
        WellFormed_ctx_subst (c:=ctx) s' /\
        WellFormed_Goal (getUVars ctx) (getVars ctx) g'
    end.

  Theorem rtacK_spec_rtacK_spec_wf : forall ctx s g r,
      @rtacK_spec ctx s g r ->
      @rtacK_spec_wf ctx s g r.
  Proof.
    unfold rtacK_spec, rtacK_spec_wf; destruct r; tauto.
  Qed.

  Theorem Proper_rtacK_spec ctx s
  : Proper (EqGoal (getUVars ctx) (getVars ctx) ==>
            @EqResult _ _ _ _ _ ctx ==> iff)
           (@rtacK_spec ctx s).
  Proof.
    red. red. red.
    unfold rtacK_spec.
    inversion 2.
    { destruct x0; destruct y0; simpl in *; try congruence.
      reflexivity. }
    { destruct x0; destruct y0; simpl in *;
      try solve [ reflexivity | congruence ]; inv_all; subst; inv_all;
      repeat match goal with
               | H : ?X , H' : ?X |- _ => clear H'
               | H : EqGoal _ _ _ _ |- _ => destruct H
               | |- (_ -> _) <-> (_ -> _) =>
                 eapply impl_iff; [ solve [ eauto | reflexivity ] | ]; intros
               | |- (_ /\ _) <-> (_ /\ _) =>
                 eapply and_iff; [ solve [ eauto | reflexivity ] | ]; intros
               | H : Roption _ _ _ |- _ => inversion H; clear H
               | |- context [ match ?X with _ => _ end ] =>
                 consider X; intros; try reflexivity; [ ]
               | |- context [ match ?X with _ => _ end ] =>
                 consider X; intros; reflexivity
               | |- (forall x, _) <-> (forall y, _) =>
                 eapply forall_iff; intro
               | |- _ =>
                 eapply left_side; [ match goal with
                                       | H : _ <-> _ |- _ => apply H; constructor
                                     end | ]
               | |- _ =>
                 eapply right_side; [ match goal with
                                       | H : _ <-> _ |- _ => apply H; constructor
                                     end | ]
               | |- ?X _ _ _ <-> ?X _ _ _ =>
                 (eapply Fmap_pctxD_iff; try reflexivity; eauto);
                   [  ]
             end.
      { do 5 red; intros; equivs.
        apply impl_iff; [ eapply H10; try reflexivity; eauto | intro ].
        apply H12; reflexivity. }
      { subst. do 5 red; intros; equivs.
        do 5 red in H9.
        rewrite H9; try reflexivity.
        rewrite impl_True_iff.
        eapply H11; reflexivity. }
      { subst. do 5 red in H9.
        do 5 red; intros; equivs.
        rewrite <- H9; try reflexivity.
        rewrite impl_True_iff.
        eapply H11; reflexivity. }
      { eapply Fmap_pctxD_iff; try reflexivity; eauto. } }
  Qed.

  (** Treat this as opaque! **)
  Definition rtacK : Type :=
    forall c : Ctx typ expr, ctx_subst c -> Goal typ expr -> Result c.

  Definition rtacK_sound (tac : rtacK)
  : Prop :=
    forall ctx s g result,
      tac ctx s g = result ->
      @rtacK_spec ctx s g result.

  Definition WellFormed_rtacK (tac : rtacK)
  : Prop :=
    forall ctx s g result,
      tac ctx s g = result ->
      @rtacK_spec_wf ctx s g result.

  Theorem rtacK_sound_WellFormed_rtacK : forall tac,
      rtacK_sound tac -> WellFormed_rtacK tac.
  Proof.
    intros. red. intros.
    eapply rtacK_spec_rtacK_spec_wf. eauto.
  Qed.

End parameterized.

Delimit Scope rtacK_scope with rtacK.

Arguments rtacK_sound {typ expr _ _ _} tac%rtacK : rename.
Arguments WellFormed_rtacK {typ expr _ _} tac%rtacK : rename.

Delimit Scope or_rtacK_scope with or_rtacK.

Notation " [ ] " := (@nil (rtacK _ _)) : or_rtacK_scope.
Notation " [  x ] " := (@cons (rtacK _ _) x%rtacK (@nil (rtacK _ _))) : or_rtacK_scope.
Notation " [  x  | ..  | y  ] " := (@cons (rtacK _ _) x%rtacK .. (@cons (rtacK _ _) y%rtacK (@nil (rtacK _ _))) ..) : or_rtacK_scope.

Export MirrorCore.ExprI.
Export MirrorCore.SubstI.
Export MirrorCore.ExprDAs.
Export MirrorCore.RTac.Core.


(* *********************************************************************)
(*                                                                     *)
(*              The L2C verified compiler                              *)
(*                                                                     *)
(*            L2C Group, Tsinghua University                           *)
(*                                                                     *)
(*  Copyright Tsinghua University.  All rights reserved.  This file is *)
(*  distributed under the terms of the GNU General Public License as   *)
(*  published by the Free Software Foundation, either version 2 of the *)
(*  License, or (at your option) any later version.  This file is also *)
(*  distributed under the terms of the INRIA Non-Commercial License    *)
(*  Agreement.                                                         *)
(*                                                                     *)
(* *********************************************************************)

Require Import Coqlib.
Require Import Integers.
Require Import Floats.
Require Import AST.
Require Import Lop.
Require Import Lustre.

(** * Global Declares *)

(** * Types *)

(** Types include short (signed 16 bits), ushort (unsigned 16 bits),int(signed 32 bits),
  uint(unsigned 32 bits), float (32 bits), real (64 bits), bool(true or false), char,
  array, struct and enum. *)

(** The syntax of type expressions.  Some points to note:
- struct type, e.g type s1 = { n : int, m : real } is expressed by syntax as below:
       Tstruct "s1" (Fcons "n" (Tint)
                    (Fcons "m" (Treal)
                    Fnil))
- no recursive type, e.g type s = { m : s } is not allowed, although it canbe expressed by syntax.
*)

Inductive typeL : Type :=
  | Tshort : typeL                          (**r integer types, signed 16 bits *)
  | Tushort : typeL                         (**r integer types, unsigned 16 bits  *)
  | Tint : typeL                            (**r integer types, signed 32 bits *)
  | Tuint : typeL                           (**r integer types, unsigned 32 bits *)
  | Tfloat : typeL                          (**r floating-point types, 32 bits *)
  | Treal : typeL                           (**r floating-point types, 64 bits *)
  | Tbool : typeL                           (**r bool types *)
  | Tchar : typeL                           (**r char types *)
  | Tarray : ident -> typeL -> Z -> typeL   (**r array types: array_type_id(ty^len) *)
  | Tstruct : ident -> fieldlistL -> typeL  (**r struct types: struct_type_id {label1_id: type1; ...} *)
  | Tenum : list ident -> typeL    (**r enum types: enum_type_id {value1_id, ...} *)

with fieldlistL : Type :=
  | Fnil : fieldlistL
  | Fcons : ident -> typeL -> fieldlistL -> fieldlistL.

Lemma type_eqL: forall (ty1 ty2: typeL), {ty1=ty2} + {ty1<>ty2}
with fieldlist_eqL: forall (fld1 fld2: fieldlistL), {fld1=fld2} + {fld1<>fld2}.
Proof.
  repeat (decide equality).
  generalize ident_eq zeq. intros E1 E2.
  decide equality.
Defined.

Opaque type_eqL fieldlist_eqL.

(** const_block
     Const block consisting of all character constants *)

Inductive constL : Type :=
  | ShortConstL: int -> constL
  | UshortConstL: int -> constL
  | IntConstL: int -> constL
  | UintConstL: int -> constL
  | CharConstL: int -> constL
  | FloatConstL: float32 -> constL
  | RealConstL: float -> constL
  | BoolConstL: bool -> constL
  | ConstructConstL : const_listL -> constL     (**r E.g struct {label1 : 1, label2 : 2}, or array [1, 2] *)
  | ID : ident -> constL               (**r to define other constant by character constant *)

with const_listL : Type :=
  | ConstNilL : const_listL
  | ConstConL : constL -> const_listL -> const_listL.

(** * Expressions *)

Definition vars := list (ident * typeL * clock).

Inductive suboperator : Type :=
  | Nodehandler : ident -> bool -> list typeL -> suboperator
  | PrefixL_unary : unary_operationL -> suboperator
  | PrefixL_binary : binary_operationL -> suboperator.

Inductive exprT : Type :=
  | EconstT : const -> typeL -> exprT
  | EvarT : ident -> typeL -> clock -> exprT
  | ListExprT : expr_listT -> exprT                                           (**r list expression *)
  | ApplyExprT : operatorT -> expr_listT ->  exprT 	              (**r operator application *)
  | EconstructT : struct_listT -> exprT                                      (**r construct a struct, e.g {label1 : 3, label2 : false} *)
  | EarrayaccT : exprT -> int -> exprT                                     (**r expr[i], access to (i+1)th member of an array "expr" *)
  | EarraydefT :  exprT -> int -> exprT                               (**r expr ^ i, an array of size "i" with every element "expr" *)
  | EarraydiffT : expr_listT ->  exprT                                      (**r [list expression], build an array with elements "list expression", e.g [1,2]*)
  | EarrayprojT: exprT -> expr_listT -> exprT ->  exprT                     (**r dynamic projection, e.g (2^3^4.[7] default 100^3), value is 100^3 *)
  | EarraysliceT : exprT -> int -> int -> exprT                            (**r a [i..j] is the sliced array [a_i, a_i+1, ... , a_j]*)
  | EmixT : exprT -> label_index_listT -> exprT -> exprT                   (**r construct a new array or struct, e.g {label1:2^3} with label1.[0] = 7, value is {label1:[7,2]} *)
  | EunopT : unary_operationL -> exprT -> exprT                            (**r unary operation *)
  | EbinopT : binary_operationL -> exprT -> exprT -> exprT                 (**r binary operation *)
  | EfieldT : exprT -> ident -> exprT                                      (**r access to a member of a struct *)
  | EpreT : exprT -> exprT                              (**r pre : shift flows on the last instant backward, producing an undefined value at first instant*)
  | EfbyT : expr_listT -> int -> expr_listT -> exprT  (**r fby : fby(b; n; a) = a -> pre fby(b; n-1; a) *)
  | EarrowT : exprT -> exprT -> exprT                                         (**r -> : fix the inital value of flows*)
  | EwhenT : exprT -> clock -> exprT                                          (**r x when h: if h=false, then no value; otherwise x *)
  | EcurrentT: exprT ->  exprT
  | EmergeT: ident -> pattern_listT -> exprT
  | EifT : exprT -> exprT -> exprT -> exprT                                   (**r conditional*)
  | EcaseT : exprT -> pattern_listT -> exprT                                  (**r case *)
  | EboolredT: int -> int -> exprT -> exprT
  | EdieseT: exprT -> exprT  (**r #(a1, ..., an) -> boolred(0,1,n)[a1, ..., an] *)
  | EnorT: exprT ->  exprT  (**r nor(a1, ..., an) boolred(0,0,n)[a1, ..., an] *)

with expr_listT : Type :=
  | Enil: expr_listT
  | Econs: exprT -> expr_listT -> expr_listT

with struct_listT: Type :=
  | EstructNil: struct_listT
  | EstructCons: ident -> exprT -> struct_listT -> struct_listT

with label_index_listT: Type :=
  | Lnil: label_index_listT
  | LconsLabelT: ident -> label_index_listT -> label_index_listT
  | LconsIndexT: exprT -> label_index_listT -> label_index_listT

with pattern_listT : Type :=
  | PatternNilT : pattern_listT
  | PatternConT : patn -> exprT -> pattern_listT -> pattern_listT

with operatorT : Type :=
  | SuboperatorT : suboperator -> operatorT
  | IteratorT : iterator_operation -> suboperator -> int -> operatorT.

(** * Equation *)

Inductive equationT : Type :=
  | EquationT: vars -> exprT -> equationT.

(** * Node *)

(** Node : kind -> ID -> parameters -> returns -> locals -> body *)

Record nodeT : Type :=
  | NodeT : bool -> ident -> vars -> vars -> vars -> list equationT -> nodeT.

(** * Program *)

Inductive programT : Type := mkprogramT{
  type_blockT : list (ident*typeL);
  const_blockT : list (ident*typeL*constL);
  node_blockT : list nodeT;
  node_mainT : ident
}.


From iris.program_logic Require Export language ectx_language ectxi_language.
From iris.algebra Require Export ofe.
From stdpp Require Export strings.
From stdpp Require Import gmap.
Set Default Proof Using "Type".

(** heap_lang.  A fairly simple language used for common Iris examples.

- This is a right-to-left evaluated language, like CakeML and OCaml.  The reason
  for this is that it makes curried functions usable: Given a WP for [f a b], we
  know that any effects [f] might have to not matter until after *both* [a] and
  [b] are evaluated.  With left-to-right evaluation, that triple is basically
  useless unless the user let-expands [b].

- Iris-time specific: We added support for bounded integers, with a signed
  semantics. Overflows have undefined semantics.

*)

Delimit Scope expr_scope with E.
Delimit Scope val_scope with V.

(* FIXME : we would like to parameterize the whole language with
   respect to a typeclass containing the following, but then coercions
   for LitInt, LitBool, Var and BNamed stop working because we break
   the uniform inheritance condition. *)
Parameter word_size : nat.
Axiom word_size_gt_1 : word_size > 1.

Definition max_mach_int : Z := 1 ≪ (word_size-1).
Definition min_mach_int : Z := - max_mach_int.
Definition mod_mach_int : Z := 2 * max_mach_int.
Definition mach_int_bounded (n : Z) := (min_mach_int ≤ n < max_mach_int)%Z.

Lemma max_mach_int_1_lt : (1 < max_mach_int)%Z.
Proof.
  pose proof word_size_gt_1. rewrite /max_mach_int Z.shiftl_1_l.
  apply (Z.pow_lt_mono_r 2 0 _); lia.
Qed.

Definition mach_int :=
  {n : Z | bool_decide (mach_int_bounded n) }%Z.

Definition to_mach_int (n : Z) : option mach_int :=
  match decide (bool_decide (mach_int_bounded n)) with
  | left H => Some (n ↾ H)
  | right _ => None
  end.

Program Definition mach_int_0 : mach_int := 0 ↾ _.
Next Obligation.
  pose proof max_mach_int_1_lt. apply bool_decide_pack.
  split; unfold min_mach_int; lia.
Qed.

Program Definition mach_int_1 : mach_int := 1 ↾ _.
Next Obligation.
  pose proof max_mach_int_1_lt. apply bool_decide_pack.
  split; unfold min_mach_int; lia.
Qed.

Instance mach_int_dec_eq :
  EqDecision mach_int.
Proof. apply sig_eq_dec; by apply _. Qed.

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 | LitLoc (l : loc)
  | LitMachInt (n : mach_int).
Inductive un_op : Set :=
  | NegOp | MinusUnOp.
Inductive bin_op : Set :=
  | PlusOp | MinusOp | MultOp | QuotOp | RemOp (* Arithmetic *)
  | AndOp | OrOp | XorOp (* Bitwise *)
  | ShiftLOp | ShiftROp (* Shifts *)
  | LeOp | LtOp | EqOp. (* Relations *)

Inductive binder := BAnon | BNamed : string → binder.
Declare Scope binder_scope.
Delimit Scope binder_scope with bind.
Bind Scope binder_scope with 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).
Instance binder_eq_dec_eq : EqDecision binder.
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.

Inductive expr :=
  (* Values *)
  | Val (v : val)
  (* Base lambda calculus *)
  | Var (x : string)
  | Rec (f x : binder) (e : expr)
  | App (e1 e2 : expr)
  (* Base types and their operations *)
  | UnOp (op : un_op) (e : expr)
  | BinOp (op : bin_op) (e1 e2 : expr)
  | If (e0 e1 e2 : expr)
  (* Products *)
  | Pair (e1 e2 : expr)
  | Fst (e : expr)
  | Snd (e : expr)
  (* Sums *)
  | InjL (e : expr)
  | InjR (e : expr)
  | Case (e0 : expr) (e1 : expr) (e2 : expr)
  (* Concurrency *)
  | Fork (e : expr)
  (* Heap *)
  | Alloc (e : expr)
  | Load (e : expr)
  | Store (e1 : expr) (e2 : expr)
  | CAS (e0 : expr) (e1 : expr) (e2 : expr)
  | FAA (e1 : expr) (e2 : expr)
with val :=
  | LitV (l : base_lit)
  | RecV (f x : binder) (e : expr)
  | PairV (v1 v2 : val)
  | InjLV (v : val)
  | InjRV (v : val).

Bind Scope expr_scope with expr.
Bind Scope val_scope with val.

Notation of_val := Val (only parsing).

Definition to_val (e : expr) : option val :=
  match e with
  | Val v => Some v
  | _ => None
  end.

(** We assume the following encoding of values to 64-bit words: The least 3
significant bits of every word are a "tag", and we have 61 bits of payload,
which is enough if all pointers are 8-byte-aligned (common on 64bit
architectures). The tags have the following meaning:

0: Payload is the data for a LitV (LitInt _).
1: Payload is the data for a InjLV (LitV (LitInt _)).
2: Payload is the data for a InjRV (LitV (LitInt _)).
3: Payload is the data for a LitV (LitLoc _).
4: Payload is the data for a InjLV (LitV (LitLoc _)).
4: Payload is the data for a InjRV (LitV (LitLoc _)).
6: Payload is one of the following finitely many values, which 61 bits are more
   than enough to encode:
   LitV LitUnit, InjLV (LitV LitUnit), InjRV (LitV LitUnit),
   LitV (LitBool _), InjLV (LitV (LitBool _)), InjRV (LitV (LitBool _)).
7: Value is boxed, i.e., payload is a pointer to some read-only memory area on
   the heap which stores whether this is a RecV, PairV, InjLV or InjRV and the
   relevant data for those cases. However, the boxed representation is never
   used if any of the above representations could be used.

Ignoring (as usual) the fact that we have to fit the infinite Z/loc into 61
bits, this means every value is machine-word-sized and can hence be atomically
read and written.  Also notice that the sets of boxed and unboxed values are
disjoint. *)
Definition val_is_unboxed (v : val) : Prop :=
  match v with
  | LitV _ => True
  | InjLV (LitV _) => True
  | InjRV (LitV _) => True
  | _ => False
  end.

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

(** Equality and other typeclass stuff *)
Lemma to_of_val v : to_val (of_val v) = Some v.
Proof. by destruct v. Qed.

Lemma of_to_val e v : to_val e = Some v → of_val v = e.
Proof. destruct e=>//=. by intros [= <-]. Qed.

Global Instance of_val_inj : Inj (=) (=) of_val.
Proof. intros ??. congruence. Qed.

Global Instance base_lit_eq_dec : EqDecision base_lit.
Proof. solve_decision. Defined.
Global Instance un_op_eq_dec : EqDecision un_op.
Proof. solve_decision. Defined.
Global Instance bin_op_eq_dec : EqDecision bin_op.
Proof. solve_decision. Defined.
Global Instance expr_eq_dec : EqDecision expr.
Proof.
  refine (
   fix go (e1 e2 : expr) {struct e1} : Decision (e1 = e2) :=
     match e1, e2 with
     | Val v, Val v' => cast_if (decide (v = v'))
     | Var x, Var x' => cast_if (decide (x = x'))
     | Rec f x e, Rec f' x' e' =>
        cast_if_and3 (decide (f = f')) (decide (x = x')) (decide (e = e'))
     | App e1 e2, App e1' e2' => cast_if_and (decide (e1 = e1')) (decide (e2 = e2'))
     | UnOp o e, UnOp o' e' => cast_if_and (decide (o = o')) (decide (e = e'))
     | BinOp o e1 e2, BinOp o' e1' e2' =>
        cast_if_and3 (decide (o = o')) (decide (e1 = e1')) (decide (e2 = e2'))
     | If e0 e1 e2, If e0' e1' e2' =>
        cast_if_and3 (decide (e0 = e0')) (decide (e1 = e1')) (decide (e2 = e2'))
     | Pair e1 e2, Pair e1' e2' =>
        cast_if_and (decide (e1 = e1')) (decide (e2 = e2'))
     | Fst e, Fst e' => cast_if (decide (e = e'))
     | Snd e, Snd e' => cast_if (decide (e = e'))
     | InjL e, InjL e' => cast_if (decide (e = e'))
     | InjR e, InjR e' => cast_if (decide (e = e'))
     | Case e0 e1 e2, Case e0' e1' e2' =>
        cast_if_and3 (decide (e0 = e0')) (decide (e1 = e1')) (decide (e2 = e2'))
     | Fork e, Fork e' => cast_if (decide (e = e'))
     | Alloc e, Alloc e' => cast_if (decide (e = e'))
     | Load e, Load e' => cast_if (decide (e = e'))
     | Store e1 e2, Store e1' e2' =>
        cast_if_and (decide (e1 = e1')) (decide (e2 = e2'))
     | CAS e0 e1 e2, CAS e0' e1' e2' =>
        cast_if_and3 (decide (e0 = e0')) (decide (e1 = e1')) (decide (e2 = e2'))
     | FAA e1 e2, FAA e1' e2' =>
        cast_if_and (decide (e1 = e1')) (decide (e2 = e2'))
     | _, _ => right _
     end
   with gov (v1 v2 : val) {struct v1} : Decision (v1 = v2) :=
     match v1, v2 with
     | LitV l, LitV l' => cast_if (decide (l = l'))
     | RecV f x e, RecV f' x' e' =>
        cast_if_and3 (decide (f = f')) (decide (x = x')) (decide (e = e'))
     | PairV e1 e2, PairV e1' e2' =>
        cast_if_and (decide (e1 = e1')) (decide (e2 = e2'))
     | InjLV e, InjLV e' => cast_if (decide (e = e'))
     | InjRV e, InjRV e' => cast_if (decide (e = e'))
     | _, _ => right _
     end
   for go); try (clear go gov; abstract intuition congruence).
Defined.
Global Instance val_eq_dec : EqDecision val.
Proof. solve_decision. Defined.

Global Instance base_lit_countable : Countable base_lit.
Proof.
 refine (inj_countable' (λ l, match l with
  | LitInt n => inl (inl (true, n)) | LitBool b => inl (inr b)
  | LitUnit => inr (inl ()) | LitLoc l => inr (inr l)
  | LitMachInt n => inl (inl (false, `n))
  end) (λ l, match l with
  | inl (inl (true, n)) => LitInt n | inl (inr b) => LitBool b
  | inr (inl ()) => LitUnit | inr (inr l) => LitLoc l
  | inl (inl (false, n)) =>
    match decide _ with
    | left H => LitMachInt (n ↾ H)
    | right H => LitUnit        (* Dummy *)
    end
  end) _); intros []; try done.
 (* Machine integers. *)
 case_match; [by rewrite exists_proj1_pi|by destruct n].
Qed.
Global Instance un_op_finite : Countable un_op.
Proof.
 refine (inj_countable' (λ op, match op with NegOp => 0 | MinusUnOp => 1 end)
  (λ n, match n with 0 => NegOp | _ => MinusUnOp end) _); by intros [].
Qed.
Global Instance bin_op_countable : Countable bin_op.
Proof.
 refine (inj_countable' (λ op, match op with
  | PlusOp => 0 | MinusOp => 1 | MultOp => 2 | QuotOp => 3 | RemOp => 4
  | AndOp => 5 | OrOp => 6 | XorOp => 7 | ShiftLOp => 8 | ShiftROp => 9
  | LeOp => 10 | LtOp => 11 | EqOp => 12
  end) (λ n, match n with
  | 0 => PlusOp | 1 => MinusOp | 2 => MultOp | 3 => QuotOp | 4 => RemOp
  | 5 => AndOp | 6 => OrOp | 7 => XorOp | 8 => ShiftLOp | 9 => ShiftROp
  | 10 => LeOp | 11 => LtOp | _ => EqOp
  end) _); by intros [].
Qed.
Global Instance binder_countable : Countable binder.
Proof.
 refine (inj_countable' (λ b, match b with BNamed s => Some s | BAnon => None end)
  (λ b, match b with Some s => BNamed s | None => BAnon end) _); by intros [].
Qed.
Global Instance expr_countable : Countable expr.
Proof.
 set (enc :=
   fix go e :=
     match e with
     | Val v => GenNode 0 [gov v]
     | Var x => GenLeaf (inl (inl x))
     | Rec f x e => GenNode 1 [GenLeaf (inl (inr f)); GenLeaf (inl (inr x)); go e]
     | App e1 e2 => GenNode 2 [go e1; go e2]
     | UnOp op e => GenNode 3 [GenLeaf (inr (inr (inl op))); go e]
     | BinOp op e1 e2 => GenNode 4 [GenLeaf (inr (inr (inr op))); go e1; go e2]
     | If e0 e1 e2 => GenNode 5 [go e0; go e1; go e2]
     | Pair e1 e2 => GenNode 6 [go e1; go e2]
     | Fst e => GenNode 7 [go e]
     | Snd e => GenNode 8 [go e]
     | InjL e => GenNode 9 [go e]
     | InjR e => GenNode 10 [go e]
     | Case e0 e1 e2 => GenNode 11 [go e0; go e1; go e2]
     | Fork e => GenNode 12 [go e]
     | Alloc e => GenNode 13 [go e]
     | Load e => GenNode 14 [go e]
     | Store e1 e2 => GenNode 15 [go e1; go e2]
     | CAS e0 e1 e2 => GenNode 16 [go e0; go e1; go e2]
     | FAA e1 e2 => GenNode 17 [go e1; go e2]
     end
   with gov v :=
     match v with
     | LitV l => GenLeaf (inr (inl l))
     | RecV f x e =>
        GenNode 0 [GenLeaf (inl (inr f)); GenLeaf (inl (inr x)); go e]
     | PairV v1 v2 => GenNode 1 [gov v1; gov v2]
     | InjLV v => GenNode 2 [gov v]
     | InjRV v => GenNode 3 [gov v]
     end
   for go).
 set (dec :=
   fix go e :=
     match e with
     | GenNode 0 [v] => Val (gov v)
     | GenLeaf (inl (inl x)) => Var x
     | GenNode 1 [GenLeaf (inl (inr f)); GenLeaf (inl (inr x)); e] => Rec f x (go e)
     | GenNode 2 [e1; e2] => App (go e1) (go e2)
     | GenNode 3 [GenLeaf (inr (inr (inl op))); e] => UnOp op (go e)
     | GenNode 4 [GenLeaf (inr (inr (inr op))); e1; e2] => BinOp op (go e1) (go e2)
     | GenNode 5 [e0; e1; e2] => If (go e0) (go e1) (go e2)
     | GenNode 6 [e1; e2] => Pair (go e1) (go e2)
     | GenNode 7 [e] => Fst (go e)
     | GenNode 8 [e] => Snd (go e)
     | GenNode 9 [e] => InjL (go e)
     | GenNode 10 [e] => InjR (go e)
     | GenNode 11 [e0; e1; e2] => Case (go e0) (go e1) (go e2)
     | GenNode 12 [e] => Fork (go e)
     | GenNode 13 [e] => Alloc (go e)
     | GenNode 14 [e] => Load (go e)
     | GenNode 15 [e1; e2] => Store (go e1) (go e2)
     | GenNode 16 [e0; e1; e2] => CAS (go e0) (go e1) (go e2)
     | GenNode 17 [e1; e2] => FAA (go e1) (go e2)
     | _ => Val $ LitV LitUnit (* dummy *)
     end
   with gov v :=
     match v with
     | GenLeaf (inr (inl l)) => LitV l
     | GenNode 0 [GenLeaf (inl (inr f)); GenLeaf (inl (inr x)); e] => RecV f x (go e)
     | GenNode 1 [v1; v2] => PairV (gov v1) (gov v2)
     | GenNode 2 [v] => InjLV (gov v)
     | GenNode 3 [v] => InjRV (gov v)
     | _ => LitV LitUnit (* dummy *)
     end
   for go).
 refine (inj_countable' enc dec _).
 refine (fix go (e : expr) {struct e} := _ with gov (v : val) {struct v} := _ for go).
 - destruct e as [v| | | | | | | | | | | | | | | | | |]; simpl; f_equal;
     [exact (gov v)|done..].
 - destruct v; by f_equal.
Qed.
Global Instance val_countable : Countable val.
Proof. refine (inj_countable of_val to_val _); auto using to_of_val. Qed.

Global Instance val_inhabited : Inhabited val := populate (LitV LitUnit).
Global Instance expr_inhabited : Inhabited expr := populate (Val inhabitant).

Canonical Structure valC := leibnizO val.
Canonical Structure exprC := leibnizO expr.

(** Evaluation contexts *)
Inductive ectx_item :=
  | AppLCtx (v2 : val)
  | AppRCtx (e1 : expr)
  | UnOpCtx (op : un_op)
  | BinOpLCtx (op : bin_op) (v2 : val)
  | BinOpRCtx (op : bin_op) (e1 : expr)
  | IfCtx (e1 e2 : expr)
  | PairLCtx (v2 : val)
  | PairRCtx (e1 : expr)
  | FstCtx
  | SndCtx
  | InjLCtx
  | InjRCtx
  | CaseCtx (e1 : expr) (e2 : expr)
  | AllocCtx
  | LoadCtx
  | StoreLCtx (v2 : val)
  | StoreRCtx (e1 : expr)
  | CasLCtx (v1 : val) (v2 : val)
  | CasMCtx (e0 : expr) (v2 : val)
  | CasRCtx (e0 : expr) (e1 : expr)
  | FaaLCtx (v2 : val)
  | FaaRCtx (e1 : expr).

Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
  match Ki with
  | AppLCtx v2 => App e (Val v2)
  | AppRCtx e1 => App e1 e
  | UnOpCtx op => UnOp op e
  | BinOpLCtx op v2 => BinOp op e (Val v2)
  | BinOpRCtx op e1 => BinOp op e1 e
  | IfCtx e1 e2 => If e e1 e2
  | PairLCtx v2 => Pair e (Val v2)
  | PairRCtx e1 => Pair e1 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 v2 => Store e (Val v2)
  | StoreRCtx e1 => Store e1 e
  | CasLCtx v1 v2 => CAS e (Val v1) (Val v2)
  | CasMCtx e0 v2 => CAS e0 e (Val v2)
  | CasRCtx e0 e1 => CAS e0 e1 e
  | FaaLCtx v2 => FAA e (Val v2)
  | FaaRCtx e1 => FAA e1 e
  end.

(** Substitution *)
Fixpoint subst (x : string) (v : val) (e : expr)  : expr :=
  match e with
  | Val _ => e
  | Var y => if decide (x = y) then Val v else Var y
  | Rec f y e =>
     Rec f y $ if decide (BNamed x ≠ f ∧ BNamed x ≠ y) then subst x v e else e
  | App e1 e2 => App (subst x v e1) (subst x v e2)
  | UnOp op e => UnOp op (subst x v e)
  | BinOp op e1 e2 => BinOp op (subst x v e1) (subst x v e2)
  | If e0 e1 e2 => If (subst x v e0) (subst x v e1) (subst x v e2)
  | Pair e1 e2 => Pair (subst x v e1) (subst x v e2)
  | Fst e => Fst (subst x v e)
  | Snd e => Snd (subst x v e)
  | InjL e => InjL (subst x v e)
  | InjR e => InjR (subst x v e)
  | Case e0 e1 e2 => Case (subst x v e0) (subst x v e1) (subst x v e2)
  | Fork e => Fork (subst x v e)
  | Alloc e => Alloc (subst x v e)
  | Load e => Load (subst x v e)
  | Store e1 e2 => Store (subst x v e1) (subst x v e2)
  | CAS e0 e1 e2 => CAS (subst x v e0) (subst x v e1) (subst x v e2)
  | FAA e1 e2 => FAA (subst x v e1) (subst x v e2)
  end.

Definition subst' (mx : binder) (v : val) : expr → expr :=
  match mx with BNamed x => subst x v | BAnon => id end.

(** The stepping relation *)
Definition un_op_eval (op : un_op) (v : val) : option val :=
  match op, v with
  | NegOp, LitV (LitBool b) => Some $ LitV $ LitBool (negb b)
  | NegOp, LitV (LitInt n) => Some $ LitV $ LitInt (Z.lnot n)
  | MinusUnOp, LitV (LitInt n) => Some $ LitV $ LitInt (- n)
  | NegOp, LitV (LitMachInt n) =>
    LitV <$> (LitMachInt <$> to_mach_int (Z.lnot (`n)))
  | MinusUnOp, LitV (LitMachInt n) =>
    LitV <$> (LitMachInt <$> to_mach_int (- (`n)))
  | _, _ => None
  end.

Definition bin_op_eval_int (op : bin_op) (n1 n2 : Z) : base_lit :=
  match op with
  | PlusOp => LitInt (n1 + n2)
  | MinusOp => LitInt (n1 - n2)
  | MultOp => LitInt (n1 * n2)
  | QuotOp => LitInt (n1 `quot` n2)
  | RemOp => LitInt (n1 `rem` n2)
  | AndOp => LitInt (Z.land n1 n2)
  | OrOp => LitInt (Z.lor n1 n2)
  | XorOp => LitInt (Z.lxor n1 n2)
  | ShiftLOp => LitInt (n1 ≪ n2)
  | ShiftROp => LitInt (n1 ≫ n2)
  | LeOp => LitBool (bool_decide (n1 ≤ n2))
  | LtOp => LitBool (bool_decide (n1 < n2))
  | EqOp => LitBool (bool_decide (n1 = n2))
  end.

Definition bin_op_eval_mach_int (op : bin_op) (n1 n2 : mach_int) : option base_lit :=
  match op with
  | PlusOp =>  LitMachInt <$> to_mach_int (`n1 + `n2)
  | MinusOp => LitMachInt <$> to_mach_int (`n1 - `n2)
  | MultOp => LitMachInt <$> to_mach_int (`n1 * `n2)
  | QuotOp => LitMachInt <$> to_mach_int (`n1 `quot` `n2)
  | RemOp => LitMachInt <$> to_mach_int (`n1 `rem` `n2)
  | AndOp => LitMachInt <$> to_mach_int (Z.land (`n1) (`n2))
  | OrOp => LitMachInt <$> to_mach_int (Z.lor (`n1) (`n2))
  | XorOp => LitMachInt <$> to_mach_int (Z.lxor (`n1) (`n2))
  | ShiftLOp => LitMachInt <$> to_mach_int (`n1 ≪ `n2)
  | ShiftROp => LitMachInt <$> to_mach_int (`n1 ≫ `n2)
  | LeOp => Some $ LitBool (bool_decide (`n1 ≤ `n2))
  | LtOp => Some $ LitBool (bool_decide (`n1 < `n2))
  | EqOp => Some $ LitBool (bool_decide (`n1 = `n2))
  end.

Definition bin_op_eval_bool (op : bin_op) (b1 b2 : bool) : option base_lit :=
  match op with
  | PlusOp | MinusOp | MultOp | QuotOp | RemOp => None (* Arithmetic *)
  | AndOp => Some (LitBool (b1 && b2))
  | OrOp => Some (LitBool (b1 || b2))
  | XorOp => Some (LitBool (xorb b1 b2))
  | ShiftLOp | ShiftROp => None (* Shifts *)
  | LeOp | LtOp => None (* InEquality *)
  | EqOp => Some (LitBool (bool_decide (b1 = b2)))
  end.

Definition bin_op_eval (op : bin_op) (v1 v2 : val) : option val :=
  if decide (op = EqOp) then Some $ LitV $ LitBool $ bool_decide (v1 = v2) else
  match v1, v2 with
  | LitV (LitInt n1), LitV (LitInt n2) => Some $ LitV $ bin_op_eval_int op n1 n2
  | LitV (LitMachInt n1), LitV (LitMachInt n2) => LitV <$> bin_op_eval_mach_int op n1 n2
  | LitV (LitBool b1), LitV (LitBool b2) => LitV <$> bin_op_eval_bool op b1 b2
  | _, _ => None
  end.

(** CAS just compares the word-sized representation of the two values, it cannot
look into boxed data.  This works out fine if at least one of the to-be-compared
values is unboxed (exploiting the fact that an unboxed and a boxed value can
never be equal because these are disjoint sets).  *)
Definition vals_cas_compare_safe (vl v1 : val) : Prop :=
  val_is_unboxed vl ∨ val_is_unboxed v1.
Arguments vals_cas_compare_safe !_ !_ /.

Inductive head_step : expr → state → list Empty_set → expr → state → list (expr) → Prop :=
  | RecS f x e σ :
     head_step (Rec f x e) σ [] (Val $ RecV f x e) σ []
  | PairS v1 v2 σ :
     head_step (Pair (Val v1) (Val v2)) σ [] (Val $ PairV v1 v2) σ []
  | InjLS v σ :
     head_step (InjL $ Val v) σ [] (Val $ InjLV v) σ []
  | InjRS v σ :
     head_step (InjR $ Val v) σ [] (Val $ InjRV v) σ []
  | BetaS f x e1 v2 e' σ :
     e' = subst' x v2 (subst' f (RecV f x e1) e1) →
     head_step (App (Val $ RecV f x e1) (Val v2)) σ [] e' σ []
  | UnOpS op v v' σ :
     un_op_eval op v = Some v' →
     head_step (UnOp op (Val v)) σ [] (Val v') σ []
  | BinOpS op v1 v2 v' σ :
     bin_op_eval op v1 v2 = Some v' →
     head_step (BinOp op (Val v1) (Val v2)) σ [] (Val v') σ []
  | IfTrueS e1 e2 σ :
     head_step (If (Val $ LitV $ LitBool true) e1 e2) σ [] e1 σ []
  | IfFalseS e1 e2 σ :
     head_step (If (Val $ LitV $ LitBool false) e1 e2) σ [] e2 σ []
  | FstS v1 v2 σ :
     head_step (Fst (Val $ PairV v1 v2)) σ [] (Val v1) σ []
  | SndS v1 v2 σ :
     head_step (Snd (Val $ PairV v1 v2)) σ [] (Val v2) σ []
  | CaseLS v e1 e2 σ :
     head_step (Case (Val $ InjLV v) e1 e2) σ [] (App e1 (Val v)) σ []
  | CaseRS v e1 e2 σ :
     head_step (Case (Val $ InjRV v) e1 e2) σ [] (App e2 (Val v)) σ []
  | ForkS e σ:
     head_step (Fork e) σ [] (Val $ LitV LitUnit) σ [e]
  | AllocS v σ l :
     σ !! l = None →
     head_step (Alloc $ Val v) σ []
               (Val $ LitV $ LitLoc l) (<[l:=v]> σ)
               []
  | LoadS l v σ :
     σ !! l = Some v →
     head_step (Load (Val $ LitV $ LitLoc l)) σ [] (Val v) σ []
  | StoreS l v σ :
     is_Some (σ !! l) →
     head_step (Store (Val $ LitV $ LitLoc l) (Val v)) σ []
               (Val $ LitV LitUnit) (<[l:=v]> σ)
               []
  | CasFailS l v1 v2 vl σ :
     σ !! l = Some vl → vl ≠ v1 →
     vals_cas_compare_safe vl v1 →
     head_step (CAS (Val $ LitV $ LitLoc l) (Val v1) (Val v2)) σ []
               (Val $ LitV $ LitBool false) σ []
  | CasSucS l v1 v2 σ :
     σ !! l = Some v1 →
     vals_cas_compare_safe v1 v1 →
     head_step (CAS (Val $ LitV $ LitLoc l) (Val v1) (Val v2)) σ []
               (Val $ LitV $ LitBool true) (<[l:=v2]> σ)
               []
  | FaaS l i1 i2 σ :
     σ !! l = Some (LitV (LitInt i1)) →
     head_step (FAA (Val $ LitV $ LitLoc l) (Val $ LitV $ LitInt i2)) σ []
               (Val $ LitV $ LitInt i1) (<[l:=LitV (LitInt (i1 + i2))]> σ)
               [].

(** Basic properties about the language *)
Global Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki).
Proof. destruct Ki; intros ???; simplify_eq/=; auto with f_equal. Qed.

Lemma fill_item_val Ki e :
  is_Some (to_val (fill_item Ki e)) → is_Some (to_val e).
Proof. intros [v ?]. destruct Ki; simplify_option_eq; eauto. Qed.

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

Lemma head_ctx_step_val Ki e σ1 κ e2 σ2 efs :
  head_step (fill_item Ki e) σ1 κ e2 σ2 efs → is_Some (to_val e).
Proof. destruct Ki; inversion_clear 1; simplify_option_eq; by 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; by simplify_eq. Qed.

Lemma alloc_fresh v σ :
  let l := fresh (dom (gset loc) σ) in
  head_step (Alloc $ Val v) σ [] (Val $ LitV $ LitLoc l) (<[l:=v]> σ) [].
Proof. by intros; apply AllocS, (not_elem_of_dom (D:=gset loc)), is_fresh. Qed.

Lemma heap_lang_mixin : EctxiLanguageMixin of_val to_val fill_item head_step.
Proof.
  split; apply _ || eauto using to_of_val, of_to_val, val_head_stuck,
    fill_item_val, fill_item_no_val_inj, head_ctx_step_val.
Qed.
End heap_lang.

(** Language *)
Canonical Structure heap_ectxi_lang := EctxiLanguage heap_lang.heap_lang_mixin.
Canonical Structure heap_ectx_lang := EctxLanguageOfEctxi heap_ectxi_lang.
Canonical Structure heap_lang := LanguageOfEctx heap_ectx_lang.

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

(** Define some derived forms. *)
Notation Lam x e := (Rec BAnon x e) (only parsing).
Notation Let x e1 e2 := (App (Lam x e2) e1) (only parsing).
Notation Seq e1 e2 := (Let BAnon e1 e2) (only parsing).
Notation LamV x e := (RecV BAnon x e) (only parsing).
Notation LetCtx x e2 := (AppRCtx (LamV x e2)) (only parsing).
Notation SeqCtx e2 := (LetCtx BAnon e2) (only parsing).
Notation Match e0 x1 e1 x2 e2 := (Case e0 (Lam x1 e1) (Lam x2 e2)) (only parsing).

(* Skip should be atomic, we sometimes open invariants around
   it. Hence, we need to explicitly use LamV instead of e.g., Seq. *)
Notation Skip := (App (Val $ LamV BAnon (Val $ LitV LitUnit)) (Val $ LitV LitUnit)).


(* This file is part of the LLIR Semantics project. *)
(* Licensing information is available in the LICENSE file. *)
(* (C) 2020 Nandor Licker. All rights reserved. *)

Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.

Require Import LLIR.Maps.
Require Export LLIR.Values.
Require Export LLIR.Types.

Import ListNotations.

Record object := mkobject
  { obj_sizre : positive
  ; obj_align: positive
  }.

Inductive unop : Type :=
  | LLSext
  | LLZext
  | LLFext
  | LLXext
  | LLTrunc
  | LLNeg
  | LLBitcast
  .

Inductive binop : Type :=
  | LLAdd
  | LLSub
  | LLMul
  | LLUDiv
  | LLSDiv
  | LLURem
  | LLSRem
  | LLCmp
  | LLSll
  | LLSra
  | LLSrl
  | LLXor
  | LLAnd
  | LLOr
  | LLRotl
  | LLUAddO
  | LLUMulO
  .

Inductive inst : Type :=
  | LLLd (dst: (ty * reg)) (next: node) (addr: reg)
  | LLArg (dst: (ty * reg)) (next: node) (index: nat)
  | LLInt (dst: reg) (next: node) (value: INT.t)
  | LLSelect (dst: (ty * reg)) (next: node) (cond: reg) (vt: reg) (vf: reg)
  | LLFrame (dst: reg) (next: node) (object: positive) (offset: nat)
  | LLGlobal (dst: reg) (next: node) (segment: positive) (object: positive) (offset: nat)
  | LLFunc (dst: reg) (next: node) (func: name)
  | LLUndef (dst: (ty * reg)) (next: node)
  | LLUnop (dst: (ty * reg)) (next: node) (op: unop) (arg: reg)
  | LLBinop (dst: (ty * reg)) (next: node) (op: binop) (lhs: reg) (rhs: reg)
  | LLMov (dst: (ty * reg)) (next: node) (src: reg)
  | LLSyscall (dst: reg) (next: node) (sno: reg) (args: list reg)
  | LLCall (dst: option (ty * reg)) (next: node) (callee: reg) (args: list reg)
  | LLInvoke (dst: option (ty * reg)) (next: node) (callee: reg) (args: list reg) (exn: node)
  | LLTCall (callee: reg) (args: list reg)
  | LLTInvoke (callee: reg) (args: list reg) (exn: node)
  | LLSt (next: node) (addr: reg) (value: reg)
  | LLRet (value: option reg)
  | LLJcc (cond: reg) (bt: node) (bf: node)
  | LLJmp (target: node)
  | LLTrap
  .

Inductive phi : Type :=
  | LLPhi (dst: (ty * reg)) (ins: list (node * reg))
  .

Definition inst_map := PTrie.t inst.
Definition phi_map := PTrie.t (list phi).

Record func : Type := mkfunc
  { fn_stack: PTrie.t object
  ; fn_insts: inst_map
  ; fn_phis: phi_map
  ; fn_entry: node
  }.

Definition prog : Type := PTrie.t func.

Inductive InstDefs: inst -> reg -> Prop :=
  | defs_ld:
    forall (t: ty) (dst: reg) (next: node) (addr: reg),
      InstDefs (LLLd (t, dst) next addr) dst
  | defs_arg:
    forall (t: ty) (dst: reg) (next: node) (index: nat),
      InstDefs (LLArg (t, dst) next index) dst
  | defs_int:
    forall (dst: reg) (next: node) (value: INT.t),
      InstDefs (LLInt dst next value) dst
  | defs_mov:
    forall (t: ty) (dst: reg) (next: node) (src: reg),
      InstDefs (LLMov (t, dst) next src) dst
  | defs_select:
    forall (t: ty) (dst: reg) (next: node) (cond: reg) (vt: reg) (vf: reg),
      InstDefs (LLSelect (t, dst) next cond vt vf) dst
  | defs_frame:
    forall (dst: reg) (next: node) (object: positive) (offset: nat),
      InstDefs (LLFrame dst next object offset) dst
  | defs_global:
    forall (dst: reg) (next: node) (segment: positive) (object: positive) (offset: nat),
      InstDefs (LLGlobal dst next segment object offset) dst
  | defs_func:
    forall (dst: reg) (next: node) (id: name),
      InstDefs (LLFunc dst next id) dst
  | defs_undef:
    forall (t: ty) (dst: reg) (next: node),
      InstDefs (LLUndef (t, dst) next) dst
  | defs_unop:
    forall (t: ty) (dst: reg) (next: node) (op: unop) (arg: reg),
      InstDefs (LLUnop (t, dst) next op arg) dst
  | defs_binop:
    forall (t: ty) (dst: reg) (next: node) (op: binop) (lhs: reg) (rhs: reg),
      InstDefs (LLBinop (t, dst) next op lhs rhs) dst
  | defs_syscall:
    forall (dst: reg) (next: node) (sno: reg) (args: list reg),
      InstDefs (LLSyscall dst next sno args) dst
  | defs_call:
    forall (t: ty) (dst: reg) (next: node) (callee: reg) (args: list reg),
      InstDefs (LLCall (Some (t, dst)) next callee args) dst
  | defs_invoke:
    forall (t: ty) (dst: reg) (next: node) (callee: reg) (args: list reg) (exn: node),
      InstDefs (LLInvoke (Some (t, dst)) next callee args exn) dst
  .

(* Returns the register defined by an instruction and its type. *)
Definition get_inst_ty_def (i: inst): option (ty * reg) :=
  match i with
  | LLSyscall dst _ _ _ => Some (sys_ret_ty, dst)
  | LLCall dst _ _ _ => dst
  | LLTCall _ _ => None
  | LLInvoke dst _ _ _ _ => dst
  | LLTInvoke _ _ _ => None

  | LLArg dst _ _ => Some dst
  | LLInt dst _ v =>
    let t := match v with
      | INT.Int8 _ => I8
      | INT.Int16 _ => I16
      | INT.Int32 _ => I32
      | INT.Int64 _ => I64
      end
    in Some (TInt t, dst)
  | LLMov dst _ _ => Some dst

  | LLFrame dst _ _ _ => Some (ptr_ty, dst)
  | LLGlobal dst _ _ _ _ => Some (ptr_ty, dst)
  | LLFunc dst _ _ => Some (ptr_ty, dst)

  | LLLd dst _ _ => Some dst
  | LLUndef dst _ => Some dst
  | LLUnop dst _ _ _ => Some dst
  | LLBinop dst _ _ _ _ => Some dst
  | LLSelect dst _ _ _ _ => Some dst

  | LLSt _ _ _ => None
  | LLRet _ => None
  | LLJcc _ _ _ => None
  | LLJmp _ => None
  | LLTrap => None
  end.

Definition get_inst_def (i: inst): option reg :=
  option_map snd (get_inst_ty_def i).

Lemma get_inst_def_defs:
  forall (i: inst) (r: reg),
    get_inst_def i = Some r <-> InstDefs i r.
Proof.
  intros i r; split; intros H.
  {
    destruct i;
      try match goal with
      | [ dst: option (ty * reg) |- _ ] => destruct dst
      end;
      try match goal with
      | [ dst: ty * reg |- _ ] => destruct dst
      end;
      inversion H as [Hr];
      try constructor.
  }
  {
    inversion H; simpl; reflexivity.
  }
Qed.

Inductive PhiDefs: phi -> reg -> Prop :=
  | defs_phi:
    forall (t: ty) (dst: reg) (ins: list (node * reg)),
      PhiDefs (LLPhi (t, dst) ins) dst
  .

Inductive InstUses: inst -> reg -> Prop :=
  | uses_ld:
    forall (dst: (ty * reg)) (next: node) (addr: reg),
      InstUses (LLLd dst next addr) addr
  | uses_mov:
    forall (dst: (ty * reg)) (next: node) (src: reg),
      InstUses (LLMov dst next src) src
  | uses_select_cond:
    forall (dst: (ty * reg)) (next: node) (cond: reg) (vt: reg) (vf: reg),
      InstUses (LLSelect dst next cond vt vf) cond
  | uses_select_true:
    forall (dst: (ty * reg)) (next: node) (cond: reg) (vt: reg) (vf: reg),
      InstUses (LLSelect dst next cond vt vf) vt
  | uses_select_false:
    forall (dst: (ty * reg)) (next: node) (cond: reg) (vt: reg) (vf: reg),
      InstUses (LLSelect dst next cond vt vf) vf
  | uses_unop:
    forall (dst: (ty * reg)) (next: node) (op: unop) (arg: reg),
      InstUses (LLUnop dst next op arg) arg
  | uses_binop_lhs:
    forall (dst: (ty * reg)) (next: node) (op: binop) (lhs: reg) (rhs: reg),
      InstUses (LLBinop dst next op lhs rhs) lhs
  | uses_binop_rhs:
    forall (dst: (ty * reg)) (next: node) (op: binop) (lhs: reg) (rhs: reg),
      InstUses (LLBinop dst next op lhs rhs) rhs
  | uses_syscall_sno:
    forall (dst: reg) (next: node) (sno: reg) (args: list reg),
      InstUses (LLSyscall dst next sno args) sno
  | uses_syscall_arg:
    forall (dst: reg) (next: node) (sno: reg) (arg: reg) (args: list reg)
      (ARG: In arg args),
      InstUses (LLSyscall dst next sno args) arg
  | uses_call_callee:
    forall (dst: option (ty * reg)) (next: node) (callee: reg) (args: list reg),
      InstUses (LLCall dst next callee args) callee
  | uses_call_arg:
    forall (dst: option (ty * reg)) (next: node) (callee: reg) (arg: reg) (args: list reg)
      (ARG: In arg args),
      InstUses (LLCall dst next callee args) arg
  | uses_invoke_callee:
    forall (dst: option (ty * reg)) (next: node) (callee: reg) (args: list reg) (exn: node),
      InstUses (LLInvoke dst next callee args exn) callee
  | uses_invoke_arg:
    forall (dst: option (ty * reg)) (next: node) (callee: reg) (arg: reg) (args: list reg) (exn: node)
      (ARG: In arg args),
      InstUses (LLInvoke dst next callee args exn) arg
  | uses_tcall_callee:
    forall (callee: reg) (args: list reg),
      InstUses (LLTCall callee args) callee
  | uses_tcall_arg:
    forall (callee: reg) (arg: reg) (args: list reg)
      (ARG: In arg args),
      InstUses (LLTCall callee args) arg
  | uses_tinvoke_callee:
    forall (callee: reg) (args: list reg) (exn: node),
      InstUses (LLTInvoke callee args exn) callee
  | uses_tinvoke_arg:
    forall (callee: reg) (arg: reg) (args: list reg) (exn: node)
      (ARG: In arg args),
      InstUses (LLTInvoke callee args exn) arg
  | uses_st_addr:
    forall (next: node) (addr: reg) (val: reg),
      InstUses (LLSt next addr val) addr
  | uses_st_val:
    forall (next: node) (addr: reg) (val: reg),
      InstUses (LLSt next addr val) val
  | uses_ret:
    forall (value: reg),
      InstUses (LLRet (Some value)) value
  | uses_jcc:
    forall (cond: reg) (bt: node) (bf: node),
      InstUses (LLJcc cond bt bf) cond
  .

(* Returns the list of registers used by an instruction. *)
Definition get_inst_uses (i: inst): list reg :=
  match i with
  | LLLd _ _ addr => [addr]
  | LLArg _ _ _ => []
  | LLInt _ _ _ => []
  | LLSelect _ _ cond vt vf => [cond; vt; vf]
  | LLFrame _ _ _ _ => []
  | LLGlobal _ _ _ _ _ => []
  | LLFunc _ _ _ => []
  | LLUndef _ _ => []
  | LLUnop _ _ _ arg => [arg]
  | LLBinop _ _ _ lhs rhs => [lhs; rhs]
  | LLMov _ _ src => [src]
  | LLSyscall _ _ sno args => sno :: args
  | LLCall _ _ callee args => callee :: args
  | LLInvoke _ _ callee args _ => callee :: args
  | LLTCall callee args => callee :: args
  | LLTInvoke callee args _ => callee :: args
  | LLSt _ addr value => [addr; value]
  | LLRet value =>
    match value with
    | None => []
    | Some reg => [reg]
    end
  | LLJcc cond _ _ => [cond]
  | LLJmp _ => []
  | LLTrap => []
  end.

Lemma get_inst_uses_uses:
  forall (i: inst) (r: reg),
    In r (get_inst_uses i) <-> InstUses i r.
Proof.
  intros i r; split; intros H.
  {
    destruct i; simpl in H;
      repeat match goal with
      | [ H: False |- _ ] => inversion H
      | [ H: _ \/ _ |- _ ] => destruct H
      end;
      subst; try constructor; auto;
      destruct value; inversion H; subst; try constructor; inversion H0.
  }
  {
    inversion H; subst; simpl; auto.
  }
Qed.

Inductive PhiUses: phi -> node -> reg -> Prop :=
  | phi_uses:
    forall (dst: (ty * reg)) (ins: list (node * reg)) (n: node) (r: reg)
      (ARG: In (n, r) ins),
      PhiUses (LLPhi dst ins) n r
  .

Definition PhiBlockUses (phis: list phi) (n: node) (r: reg): Prop :=
  Exists (fun phi => PhiUses phi n r) phis.

Inductive Succeeds: inst -> node -> Prop :=
  | succ_arg:
    forall (dst: (ty * reg)) (next: node) (index: nat),
      Succeeds (LLArg dst next index) next
  | succ_int:
    forall (dst: reg) (next: node) (value: INT.t),
      Succeeds (LLInt dst next value) next
  | succ_frame:
    forall (dst: reg) (next: node) (object: positive) (offset: nat),
      Succeeds (LLFrame dst next object offset) next
  | succ_global:
    forall (dst: reg) (next: node) (segment: positive) (object: positive) (offset: nat),
      Succeeds (LLGlobal dst next segment object offset) next
  | succ_func:
    forall (dst: reg) (next: node) (id: name),
      Succeeds (LLFunc dst next id) next
  | succ_undef:
    forall (dst: (ty * reg)) (next: node),
      Succeeds (LLUndef dst next) next
  | succ_ld:
    forall (dst: (ty * reg)) (next: node) (addr: reg),
      Succeeds (LLLd dst next addr) next
  | succ_mov:
    forall (dst: (ty * reg)) (next: node) (src: reg),
      Succeeds (LLMov dst next src) next
  | succ_select:
    forall (dst: (ty * reg)) (next: node) (cond: reg) (vt: reg) (vf: reg),
      Succeeds (LLSelect dst next cond vt vf) next
  | succ_unop:
    forall (dst: (ty * reg)) (next: node) (op: unop) (arg: reg),
      Succeeds (LLUnop dst next op arg) next
  | succ_binop:
    forall (dst: (ty * reg)) (next: node) (op: binop) (lhs: reg) (rhs: reg),
      Succeeds (LLBinop dst next op lhs rhs) next
  | succ_syscall:
    forall (dst: reg) (next: node) (sno: reg) (args: list reg),
      Succeeds (LLSyscall dst next sno args) next
  | succ_call:
    forall (dst: option (ty * reg)) (next: node) (callee: reg) (args: list reg),
      Succeeds (LLCall dst next callee args) next
  | succ_invoke_next:
    forall (dst: option (ty * reg)) (next: node) (callee: reg) (args: list reg) (exn: node),
      Succeeds (LLInvoke dst next callee args exn) next
  | succ_invoke_exn:
    forall (dst: option (ty * reg)) (next: node) (callee: reg) (args: list reg) (exn: node),
      Succeeds (LLInvoke dst next callee args exn) exn
  | succ_tinvoke:
    forall (callee: reg) (args: list reg) (exn: node),
      Succeeds (LLTInvoke callee args exn) exn
  | succ_st:
    forall (next: node) (addr: reg) (val: reg),
      Succeeds (LLSt next addr val) next
  | succ_jcc_true:
    forall (cond: reg) (bt: node) (bf: node),
      Succeeds (LLJcc cond bt bf) bt
  | succ_jcc_false:
    forall (cond: reg) (bt: node) (bf: node),
      Succeeds (LLJcc cond bt bf) bf
  | succ_jmp:
    forall (target: node),
      Succeeds (LLJmp target) target
  .

Definition is_terminator (i: inst): bool :=
  match i with
  | LLLd _ _ _ => false
  | LLArg _ _ _ => false
  | LLInt _ _ _ => false
  | LLMov _ _ _ => false
  | LLFrame _ _ _ _ => false
  | LLFunc _ _ _ => false
  | LLGlobal _ _ _ _ _ => false
  | LLUndef _ _ => false
  | LLUnop _ _ _ _ => false
  | LLBinop _ _ _ _ _ => false
  | LLSelect _ _ _ _ _ => false
  | LLSyscall _ _ _ _ => true
  | LLCall _ _ _ _ => true
  | LLInvoke _ _ _ _ _ => true
  | LLTCall _ _ => true
  | LLTInvoke _ _ _ => true
  | LLSt next _ _ => false
  | LLRet _ => true
  | LLJcc _ _ _ => true
  | LLJmp _ => true
  | LLTrap => true
  end.

Definition has_effect (i: inst): bool :=
  match i with
  | LLLd _ _ _ => false
  | LLArg _ _ _ => false
  | LLInt _ _ _ => false
  | LLMov _ _ _ => false
  | LLFrame _ _ _ _ => false
  | LLFunc _ _ _ => false
  | LLGlobal _ _ _ _ _ => false
  | LLUndef _ _ => false
  | LLUnop _ _ _ _ => false
  | LLBinop _ _ _ _ _ => false
  | LLSelect _ _ _ _ _ => false
  | LLSyscall _ _ _ _ => true
  | LLCall _ _ _ _ => true
  | LLInvoke _ _ _ _ _ => true
  | LLTCall _ _ => true
  | LLTInvoke _ _ _ => true
  | LLSt next _ _ => true
  | LLRet _ => false
  | LLJcc _ _ _ => false
  | LLJmp _ => false
  | LLTrap => true
  end.

Inductive Terminator: inst -> Prop :=
  | term_ret:
    forall (ret: option reg),
      Terminator (LLRet ret)
  | term_jcc:
    forall (cond: reg) (bt: node) (bf: node),
      Terminator (LLJcc cond bt bf)
  | term_jmp:
    forall (target: node),
      Terminator (LLJmp target)
  | term_trap:
    Terminator LLTrap
  | term_syscall:
    forall (dst: reg) (next: node) (sno: reg) (args: list reg),
      Terminator (LLSyscall dst next sno args)
  | term_call:
    forall (dst: option (ty * reg)) (next: node) (callee: reg) (args: list reg),
      Terminator (LLCall dst next callee args)
  | term_tcall:
    forall (callee: reg) (args: list reg),
      Terminator (LLTCall callee args)
  | term_tinvoke:
    forall (callee: reg) (args: list reg) (exn: node),
      Terminator (LLTInvoke callee args exn)
  | term_invoke:
    forall (dst: option (ty * reg)) (next: node) (callee: reg) (args: list reg) (exn: node),
      Terminator (LLInvoke dst next callee args exn)
  .

Inductive Callee: inst -> reg -> Prop :=
  | callee_call:
    forall (dst: option (ty * reg)) (next: node) (callee: reg) (args: list reg),
      Callee (LLCall dst next callee args) callee
  | callee_invoke:
    forall (dst: option (ty * reg)) (next: node) (callee: reg) (args: list reg) (exn: node),
      Callee (LLInvoke dst next callee args exn) callee
  | callee_tcall:
    forall (callee: reg) (args: list reg),
      Callee (LLTCall callee args) callee
  | callee_tinvoke:
    forall (callee: reg) (args: list reg) (exn: node),
      Callee (LLTInvoke callee args exn) callee
  .

Inductive VoidCallSite: inst -> Prop :=
  | void_site_call:
    forall (next: node) (callee: reg) (args: list reg),
      VoidCallSite (LLCall None next callee args)
  | void_site_invoke:
    forall (next: node) (callee: reg) (args: list reg) (exn: node),
      VoidCallSite (LLInvoke None next callee args exn)
  .

Inductive CallSite: inst -> ty -> reg -> Prop :=
  | call_site_call:
    forall (t: ty) (dst: reg) (next: node) (callee: reg) (args: list reg),
      CallSite (LLCall (Some (t, dst)) next callee args) t dst
  | call_site_invoke:
    forall (t: ty) (dst: reg) (next: node) (callee: reg) (args: list reg) (exn: node),
      CallSite (LLInvoke (Some (t, dst)) next callee args exn) t dst
  .

Inductive ReturnAddress: inst -> node -> Prop :=
  | ret_addr_call:
    forall (dst: option (ty * reg)) (next: node) (callee: reg) (args: list reg),
      ReturnAddress (LLCall dst next callee args) next
  | ret_addr_invoke:
    forall (dst: option (ty * reg)) (next: node) (callee: reg) (args: list reg) (exn: node),
      ReturnAddress (LLInvoke dst next callee args exn) next
  .

Lemma is_terminator_terminator:
  forall (i: inst),
    is_terminator i = true <-> Terminator i.
Proof.
  intros i. split; intros H; destruct i; try inversion H; constructor.
Qed.

Definition is_exit (i: inst): bool :=
  match i with
  | LLLd _ _ _ => false
  | LLArg _ _ _ => false
  | LLInt _ _ _ => false
  | LLMov _ _ _ => false
  | LLFrame _ _ _ _ => false
  | LLFunc _ _ _ => false
  | LLGlobal _ _ _ _ _ => false
  | LLUndef _ _ => false
  | LLUnop _ _ _ _ => false
  | LLBinop _ _ _ _ _ => false
  | LLSelect _ _ _ _ _ => false
  | LLSyscall _ _ _ _ => false
  | LLCall _ _ _ _ => false
  | LLInvoke _ _ _ _ _ => false
  | LLTCall _ _ => true
  | LLTInvoke _ _ _ => false
  | LLSt next _ _ => false
  | LLRet _ => true
  | LLJcc _ _ _ => false
  | LLJmp _ => false
  | LLTrap => true
  end.

Inductive Exit: inst -> Prop :=
  | exit_ret:
    forall (ret: option reg),
      Exit (LLRet ret)
  | exit_trap:
    Exit LLTrap
  | exit_tcall:
    forall (callee: reg) (args: list reg),
      Exit (LLTCall callee args)
  .

Lemma is_exit_exit:
  forall (i: inst),
    is_exit i = true <-> Exit i.
Proof.
  intros i.
  split; intros H.
  + destruct i; simpl in H; inversion H; constructor.
  + inversion H; simpl; reflexivity.
Qed.

Definition get_successors (i: inst) :=
  match i with
  | LLLd _ next _ => [next]
  | LLArg _ next _ => [next]
  | LLInt _ next _ => [next]
  | LLMov _ next _ => [next]
  | LLFrame _ next _ _ => [next]
  | LLFunc _ next _ => [next]
  | LLGlobal _ next _ _ _ => [next]
  | LLUndef _ next => [next]
  | LLUnop _ next _ _ => [next]
  | LLBinop _ next _ _ _ => [next]
  | LLSelect _ next _ _ _ => [next]
  | LLSyscall _ next _ _ => [next]
  | LLCall _ next _ _ => [next]
  | LLInvoke _ next _ _ exn => [next; exn]
  | LLTCall _ _ => []
  | LLTInvoke _ _ exn => [exn]
  | LLSt next _ _ => [next]
  | LLRet _ => []
  | LLJcc _ bt bf => [bt;bf]
  | LLJmp target => [target]
  | LLTrap => []
  end.

Lemma get_successors_correct:
  forall (i: inst) (succ: node),
    In succ (get_successors i) <-> Succeeds i succ.
Proof.
  split; intros H.
  {
    unfold get_successors in H.
    destruct i; repeat destruct H as [H|H];
    subst; try inversion H; constructor.
  }
  {
    inversion H; simpl; auto.
  }
Qed.

Section FUNCTION.
  Variable f: func.

  Inductive SuccOf: node -> node -> Prop :=
    | succ_of:
        forall (n: node) (m: node) (i: inst)
          (HN: Some i = f.(fn_insts) ! n)
          (HM: None <> f.(fn_insts) ! m)
          (SUCC: Succeeds i m),
          SuccOf n m.

  Lemma SuccOf_succ_dec:
    forall (n: node),
      {exists m, SuccOf n m} + {~exists m, SuccOf n m}.
  Proof.
    intros n.
    destruct (f.(fn_insts) ! n) as [inst|] eqn:Einst.
    {
      remember (get_successors inst) as succs eqn:Esuccs.
      destruct inst; simpl in Esuccs;
        try match goal with
        | [ Esuccs: succs = [?succ]
          , Einst: (fn_insts f) ! n = Some ?inst
          |- _ ] =>
            destruct (fn_insts f) ! succ as [inst'|] eqn:Esucc;
              [ left; exists succ; apply succ_of with inst;
                [ auto
                | intros contra; rewrite Esucc in contra; inversion contra
                | constructor
                ]
              | right; intros contra; destruct contra as [next' Hnext];
                inversion Hnext; subst;
                rewrite Einst in HN; inversion HN; subst i;
                apply get_successors_correct in SUCC; simpl in SUCC;
                destruct SUCC; auto;
                subst next';
                rewrite Esucc in HM;
                contradiction
              ]
        | [ Esuccs: succs = [] |- _ ] =>
          right; intros contra; destruct contra as [next' Hnext];
          inversion Hnext; subst;
          rewrite Einst in HN; inversion HN; subst i;
          apply get_successors_correct in SUCC; simpl in SUCC;
          contradiction
        | [ Esuccs: succs = [?succ0; ?succ1]
          , Einst: (fn_insts f) ! n = Some ?inst
          |- _ ] =>
            destruct (fn_insts f) ! succ0 as [inst0|] eqn:Einst0;
              [ left; exists succ0; apply succ_of with inst;
                [ auto
                | intros contra; rewrite Einst0 in contra; inversion contra
                | constructor
                ]
              | destruct (fn_insts f) ! succ1 as [inst1|] eqn:Einst1;
                [ left; exists succ1; apply succ_of with inst;
                  [ auto
                  | intros contra; rewrite Einst1 in contra; inversion contra
                  | constructor
                  ]
                | right; intros contra; destruct contra as [next' Hnext];
                  inversion Hnext; subst;
                  rewrite Einst in HN; inversion HN; subst i;
                  apply get_successors_correct in SUCC; simpl in SUCC;
                  repeat destruct SUCC as [SUCC|SUCC]; subst;
                  try rewrite Einst0 in HM;
                  try rewrite Einst1 in HM;
                  contradiction
                ]
            ]
        end.
    }
    {
      right.
      intros contra; destruct contra as [m contra]; inversion contra.
      rewrite Einst in HN; inversion HN.
    }
  Qed.

  Definition get_predecessors (n: node) :=
    match f.(fn_insts) ! n with
    | None => []
    | Some _ =>
      PTrie.keys
        (PTrie.filter (fun k v =>
          let succs := get_successors v in
          List.existsb (fun succ => Pos.eqb succ n) succs
        ) f.(fn_insts))
    end.

  Lemma get_predecessors_correct:
    forall (n: node) (pred: node),
      In pred (get_predecessors n) <-> SuccOf pred n.
  Proof.
    intros n pred; split.
    {
      intros Hin.
      unfold get_predecessors in Hin.
      destruct ((fn_insts f) ! n) eqn:Einst.
      {
        apply PTrie.keys_inversion in Hin.
        destruct Hin as [k Hin].
        apply PTrie.map_opt_inversion in Hin.
        destruct Hin as [inst [Hinst Hpred]].
        apply succ_of with (i := inst); auto.
        { intros contra. rewrite Einst in contra. inversion contra. }
        {
          unfold get_successors in Hpred. unfold existsb in Hpred.
          destruct inst; simpl;
            repeat match goal with
            | [ H: context [ Pos.eqb ?v n ] |- _ ] =>
              destruct (Pos.eqb v n) eqn:E;
              simpl in H;
              [apply Pos.eqb_eq in E; subst; constructor|clear E]
            | [ H: Some ?v = None |- _ ] =>
              inversion H
            end.
        }
      }
      {
        inversion Hin.
      }
    }
    {
      intros Hsucc.
      inversion Hsucc.
      destruct ((fn_insts f) ! n) as [inst'|] eqn:En; try contradiction.
      unfold get_predecessors.
      rewrite En. subst. clear HM.
      apply PTrie.keys_correct with (v := i).
      apply PTrie.filter_correct; auto.
      apply List.existsb_exists. exists n.
      split; [|apply Pos.eqb_eq; reflexivity].
      destruct i; inversion SUCC; simpl; auto.
    }
  Qed.

  Lemma SuccOf_pred_dec:
    forall (m: node),
      {exists n, SuccOf n m} + {~exists n, SuccOf n m}.
  Proof.
    intros m.
    destruct ((fn_insts f) ! m) as [inst_m|] eqn:Einst_m.
    {
      remember (get_predecessors m) as preds eqn:Epreds.
      destruct preds.
      {
        right; intros contra; destruct contra as [n Hsucc].
        apply get_predecessors_correct in Hsucc.
        rewrite <- Epreds in Hsucc.
        inversion Hsucc.
      }
      {
        left; exists k.
        apply get_predecessors_correct.
        rewrite <- Epreds.
        left; auto.
      }
    }
    {
      right; intros contra; destruct contra as [n Hsucc]; inversion Hsucc;
      rewrite Einst_m in HM; contradiction.
    }
  Qed.

  Inductive InstDefinedAt: node -> reg -> Prop :=
    | inst_defined_at:
      forall (n: node) (r: reg) (i: inst)
        (INST: Some i = f.(fn_insts) ! n)
        (DEFS: InstDefs i r),
        InstDefinedAt n r
    .

  Inductive PhiDefinedAt: node -> reg -> Prop :=
    | phi_defined_at:
      forall (n: node) (r: reg) (phis: list phi)
        (PHIS: Some phis = f.(fn_phis) ! n)
        (DEFS: Exists (fun phi => PhiDefs phi r) phis),
        PhiDefinedAt n r
    .

  Inductive DefinedAt: node -> reg -> Prop :=
    | defined_at_inst:
      forall (n: node) (r: reg) (DEF: InstDefinedAt n r),
        DefinedAt n r
    | defined_at_phi:
      forall (n: node) (r: reg) (DEF: PhiDefinedAt n r),
        DefinedAt n r
    .

  Lemma inst_defined_at_dec:
    forall (n: node) (r: reg),
      {InstDefinedAt n r} + {~InstDefinedAt n r}.
  Proof.
    intros n r.
    destruct ((fn_insts f) ! n) as [inst|] eqn:Einst.
    {
      destruct (get_inst_def inst) as [dst|] eqn:Edst.
      {
        destruct (Pos.eq_dec dst r) as [Eq|Ne].
        {
          subst r. left. apply inst_defined_at with (i := inst); auto.
          apply get_inst_def_defs; auto.
        }
        {
          right; intros contra; inversion contra.
          rewrite Einst in INST; inversion INST; subst i.
          apply get_inst_def_defs in DEFS.
          rewrite Edst in DEFS; inversion DEFS.
          contradiction.
        }
      }
      {
        right; intros contra; inversion contra.
        apply get_inst_def_defs in DEFS.
        rewrite Einst in INST; inversion INST; subst i.
        rewrite Edst in DEFS; inversion DEFS.
      }
    }
    {
      right; intros contra; inversion contra.
      rewrite Einst in INST; inversion INST.
    }
  Qed.

  Lemma phi_defs_dec:
    forall (p: phi) (r: reg),
      {PhiDefs p r} + {~PhiDefs p r}.
  Proof.
    intros p r. destruct p; destruct dst.
    destruct (Pos.eq_dec p r); subst.
    - left; constructor.
    - right; intros contra; inversion contra; contradiction.
  Qed.

  Lemma phi_defined_at_dec:
    forall (n: node) (r: reg),
      {PhiDefinedAt n r} + {~PhiDefinedAt n r}.
  Proof.
    intros n r.
    destruct ((fn_phis f) ! n) as [phis|] eqn:Ephis.
    {
      destruct (Exists_dec (fun phi => PhiDefs phi r) phis).
      {
        intros phi.
        generalize (phi_defs_dec phi r); intros Hdec; destruct Hdec; auto.
      }
      {
        left. apply phi_defined_at with phis; auto.
      }
      {
        right; intros contra; inversion contra.
        rewrite Ephis in PHIS; inversion PHIS; subst.
        contradiction.
      }
    }
    {
      right; intros contra; inversion contra.
      rewrite Ephis in PHIS; inversion PHIS.
    }
  Qed.

  Lemma defined_at_dec:
    forall (n: node) (r: reg),
      {DefinedAt n r} + {~DefinedAt n r}.
  Proof.
    intros n r.
    destruct (inst_defined_at_dec n r).
    - left; apply defined_at_inst; auto.
    - destruct (phi_defined_at_dec n r).
      + left; apply defined_at_phi; auto.
      + right; intros contra; inversion contra; contradiction.
  Qed.

  Inductive InstUsedAt: node -> reg -> Prop :=
    | inst_used_at:
      forall (n: node) (r: reg) (i: inst)
        (INST: Some i = f.(fn_insts) ! n)
        (USES: InstUses i r),
        InstUsedAt n r.

  Inductive PhiUsedAt: node -> reg -> Prop :=
    | phi_used_at:
      forall (n: node) (r: reg) (block: node) (phis: list phi)
        (SUCC: SuccOf n block)
        (PHIS: Some phis = f.(fn_phis) ! block)
        (USES: PhiBlockUses phis n r),
        PhiUsedAt n r
    .

  Inductive UsedAt: node -> reg -> Prop :=
    | used_at_inst:
      forall (n: node) (r: reg) (USE: InstUsedAt n r),
        UsedAt n r
    | used_at_phi:
      forall (n: node) (r: reg) (USE: PhiUsedAt n r),
        UsedAt n r
    .

  Lemma inst_used_at_dec:
    forall (n: node) (r: reg),
      {InstUsedAt n r} + {~InstUsedAt n r}.
  Proof.
    intros n r.
    destruct ((fn_insts f) ! n) as [inst|] eqn:Einst.
    {
      destruct (in_dec Pos.eq_dec r (get_inst_uses inst)) as [In|NotIn].
      {
        left; apply inst_used_at with inst; auto.
        apply get_inst_uses_uses; auto.
      }
      {
        right; intros contra; inversion contra; subst.
        apply get_inst_uses_uses in USES.
        rewrite Einst in INST; inversion INST; subst.
        contradiction.
      }
    }
    {
      right; intros contra; inversion contra; subst;
      rewrite Einst in INST; inversion INST.
    }
  Qed.

  Lemma phi_in_dec:
    forall (a: (node * reg)) (b: (node * reg)),
      {a = b} + {a <> b}.
  Proof.
    destruct a as [an ar]; destruct b as [bn br].
    destruct (Pos.eq_dec an bn);
    destruct (Pos.eq_dec ar br);
    subst;
    try (left; reflexivity);
    right; intros contra; inversion contra; subst; contradiction.
  Qed.

  Lemma phi_uses_dec:
    forall (p: phi) (n: node) (r: reg),
      {PhiUses p n r} + {~PhiUses p n r}.
  Proof.
    destruct p; intros n r.
    destruct (in_dec phi_in_dec (n, r) ins) as [Ein|Enot_in].
    {
      left; constructor; auto.
    }
    {
      right; intros contra; inversion contra; subst; contradiction.
    }
  Qed.

  Lemma phi_block_uses_dec:
    forall (phis: list phi) (n: node) (r: reg),
      {PhiBlockUses phis n r} + {~PhiBlockUses phis n r}.
  Proof.
    induction phis; intros n r.
    { right; intros contra; inversion contra. }
    {
      destruct (IHphis n r) as [Ein|Enot_in].
      {
        left; apply Exists_exists.
        apply Exists_exists in Ein; inversion Ein; destruct H.
        exists x; split; auto; right; auto.
      }
      {
        destruct (phi_uses_dec a n r) as [Epin|Enot_pin].
        {
          left; apply Exists_exists; exists a; split; auto.
          left; reflexivity.
        }
        {
          right; intros contra.
          inversion contra; try contradiction.
        }
      }
    }
  Qed.

  Lemma phi_used_at_dec:
    forall (n: node) (r:reg),
      {PhiUsedAt n r} + {~PhiUsedAt n r}.
  Proof.
    intros n r.
    destruct ((fn_insts f) ! n) as [inst_n|] eqn:Esome_inst_n.
    {
      remember (get_successors inst_n) as succ_n eqn:Esucc_n.
      destruct inst_n eqn:Einst_n; simpl in Esucc_n;
        try match goal with
        | [ Esucc_n: succ_n = [?next] |- _ ] =>
          destruct ((fn_phis f) ! next) as [phis_next|] eqn:Ephis_next;
          [ destruct ((fn_insts f) ! next) as [inst_next|] eqn:Einst_next;
            [ destruct (phi_block_uses_dec phis_next n r) as [Euse|Eno_use];
              [ left; apply phi_used_at with next phis_next; auto;
                apply succ_of with inst_n; subst; auto; try constructor;
                intros contra; rewrite Einst_next in contra; inversion contra
              | right; intros contra; inversion contra;
                inversion SUCC; apply get_successors_correct in SUCC0;
                rewrite Esome_inst_n in HN; inversion HN; clear HN; subst;
                simpl in SUCC0;
                repeat destruct SUCC0 as [SUCC0|SUCC0]; subst; try contradiction;
                rewrite Ephis_next in PHIS; inversion PHIS; subst;
                contradiction
              ]
            | right; intros contra; inversion contra; inversion SUCC;
              rewrite Esome_inst_n in HN; inversion HN; clear HN; subst;
              apply get_successors_correct in SUCC0; simpl in SUCC0;
              repeat destruct SUCC0 as [SUCC0|SUCC0]; subst; try contradiction;
              rewrite Einst_next in HM; contradiction
            ]
          | right; intros contra; inversion contra; inversion SUCC; subst;
            rewrite Esome_inst_n in HN; inversion HN; subst;
            apply get_successors_correct in SUCC0; simpl in SUCC0;
            repeat destruct SUCC0 as [SUCC0|SUCC0]; subst; try contradiction;
            rewrite Ephis_next in PHIS; inversion PHIS
          ]
        | [ Esucc_n: succ_n = [] |- _ ] =>
          right; intros contra; inversion contra; inversion SUCC; subst;
          rewrite Esome_inst_n in HN; inversion HN; subst;
          apply get_successors_correct in SUCC0; subst; simpl in SUCC0;
          contradiction
        | [ Esucc_n: succ_n = [?s0; ?s1] |- _ ] =>
          destruct ((fn_phis f) ! s0) as [phis_s0|] eqn:Ephis_s0;
          destruct ((fn_phis f) ! s1) as [phis_s1|] eqn:Ephis_s1;
          destruct ((fn_insts f) ! s0) as [inst_s0|] eqn:Einst_s0;
          destruct ((fn_insts f) ! s1) as [inst_s1|] eqn:Einst_s1;
          try destruct (phi_block_uses_dec phis_s0 n r) as [Euse_s0|Eno_use_s0];
          try destruct (phi_block_uses_dec phis_s1 n r) as [Euse_s1|Eno_use_s1];
          try match goal with
          | [ Hphi: (fn_phis f) ! ?s0 = Some ?phis
            , Hinst: (fn_insts f) ! ?s0 = Some _
            , Hblock_use: PhiBlockUses ?phis n r
            |- _
            ] =>
            left;
            apply phi_used_at with s0 phis; auto;
            apply succ_of with inst_n;
              [ subst; auto
              | intros contra; rewrite Hinst in contra; inversion contra
              | subst inst_n; constructor
              ]
          end;
          right; intros contra; inversion contra; inversion SUCC;
          rewrite Esome_inst_n in HN; inversion HN; clear HN; subst;
          inversion SUCC0; subst;
          match goal with
          | [ Hinst: (fn_insts f) ! ?n = None, Hnone: None <> (fn_insts f) ! ?n |- _ ] =>
            rewrite Hinst in Hnone; contradiction
          | [ Hphi0: (fn_phis f) ! ?n = _, Hphi1: _ = (fn_phis f) ! ?n |- _ ] =>
            rewrite Hphi0 in Hphi1; inversion Hphi1; clear Hphi1; subst; contradiction
          end
        end.
    }
    {
      right; intros contra; inversion contra; inversion SUCC;
      rewrite Esome_inst_n in HN; inversion HN.
    }
  Qed.

  Inductive TermAt: node -> Prop :=
    | term_at:
      forall (i: inst) (n: node)
        (INST: Some i = f.(fn_insts) ! n)
        (TERM: Terminator i),
        TermAt n.

  Lemma non_terminal_unique_successor:
    forall (n: node) (s: node) (s': node),
      ~TermAt n ->
       SuccOf n s ->
       SuccOf n s' ->
       s = s'.
  Proof.
    intros n s s' Hterm Hsucc Hsucc'.
    destruct ((fn_insts f) ! n) as [i|] eqn:Einst.
    {
      destruct i eqn:Ei;
        try (
          assert (TermAt n);
          [apply term_at with i; subst; auto; constructor|];
          contradiction
        );
        inversion Hsucc; inversion Hsucc';
        rewrite Einst in HN; inversion HN; subst i0; clear HN; inversion SUCC;
        rewrite Einst in HN0; inversion HN0; subst i1; clear HN0; inversion SUCC0;
        subst; reflexivity.
    }
    {
      inversion Hsucc; rewrite Einst in HN; inversion HN.
    }
  Qed.

  Inductive ExitAt: node -> Prop :=
    | exit_at:
      forall (i: inst) (n: node)
        (INST: Some i = f.(fn_insts) ! n)
        (EXIT: Exit i),
        ExitAt n.

  Theorem exit_no_succ:
    forall (n: node),
      ExitAt n -> ~exists (m: node), SuccOf n m.
  Proof.
    intros n Hexit contra; destruct contra as [m Hsucc].
    inversion Hexit.
    inversion Hsucc.
    rewrite <- INST in HN; inversion HN; subst.
    inversion EXIT; subst; inversion SUCC; subst.
  Qed.
End FUNCTION.