Require Import Coq.Bool.Bool.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.

Require Import Helix.FSigmaHCOL.FSigmaHCOL.
Require Import Helix.FSigmaHCOL.Int64asNT.
Require Import Helix.FSigmaHCOL.Float64asCT.
Require Import Helix.LLVMGen.Utils.
Require Import Helix.Util.Misc.
Require Import Helix.Tactics.HelixTactics.

Require Import Vellvm.Semantics.IntrinsicsDefinitions.
Require Import Vellvm.Utils.Util.
Require Import Vellvm.Numeric.Floats.
Require Import Vellvm.Semantics.TopLevel.
Require Import Vellvm.Syntax.LLVMAst.
Require Import Helix.Util.ErrorSetoid.

Require Import Flocq.IEEE754.Binary.
Require Import Flocq.IEEE754.Bits.

Require Import Coq.Numbers.BinNums. (* for Z scope *)
Require Import Coq.ZArith.BinInt.
From Coq Require Import ZArith.

Require Import ExtLib.Structures.Monads.
Require Import Helix.Util.ErrorWithState.
Require Import Helix.LLVMGen.Data.

Import ListNotations.
Import MonadNotation.
Open Scope monad_scope.

Set Implicit Arguments.
Set Strict Implicit.

Import FHCOL.

(* Both [String] and [List] define [(++)] notation. We use both.
   To avoid implicit scoping, we re-define one for String *)
Notation "x @@ y" := (String.append x y) (right associativity, at level 60) : string_scope.

Section withErrorStateMonad.

  Record IRState :=
    mkIRState
      {
        block_count: nat ;
        local_count: nat ;
        void_count : nat ;
        Γ: list (ident * typ)
      }.

  Definition newState: IRState :=
    {|
      block_count := 0 ;
      local_count := 0 ;
      void_count  := 0 ;
      Γ := []
    |}.

  Definition cerr := errS IRState.

  Definition setVars (s:IRState) (newvars:list (ident * typ)): IRState :=
    {|
      block_count := block_count s ;
      local_count := local_count s ;
      void_count  := void_count s ;
      Γ := newvars
    |}.

  (* Returns n-th varable from state or error if [n] index oob *)
  Definition getStateVar (msg:string) (n:nat): cerr (ident * typ) :=
    st <- get ;;
    option2errS msg (List.nth_error (Γ st) n).

  (* for debugging and error reporting *)
  Definition getVarsAsString : cerr string :=
    st <- get ;;
    ret (string_of_Γ (Γ st)).

  Definition nat_eq_or_cerr msg a b : cerr _ := err2errS (nat_eq_or_err msg a b).
  Definition Z_eq_or_cerr msg a b : cerr _ := err2errS (Z_eq_or_err msg a b).
  Definition Int64_eq_or_cerr msg a b : cerr _ := Z_eq_or_cerr msg
                                                               (Int64.intval a)
                                                               (Int64.intval b).

  Definition evalCErrS {St:Type} {A:Type} (c : errS St A) (initial : St) : cerr A :=
    match c initial with
    | inl msg => raise msg
    | inr (s,v) => ret v
    end.

End withErrorStateMonad.

(* 64-bit IEEE floats *)
Definition SizeofFloatT: nat := 8.

Definition getIRType (t: DSHType): typ :=
  match t with
  | DSHnat => IntType
  | DSHCType => TYPE_Double
  | DSHPtr n => TYPE_Array (Z.to_N (Int64.intval n)) TYPE_Double
  end.

Definition add_comments (b:block typ) (xs:list string): block typ :=
  {|
    blk_id    := blk_id b;
    blk_phis  := blk_phis b;
    blk_code  := blk_code b;
    blk_term  := blk_term b;
    blk_comments := match blk_comments b with
                    | None => Some xs
                    | Some ys => Some (ys++xs)
                    end
  |}.

Definition add_comment (bs:list (block typ)) (xs:list string): list (block typ) :=
  match bs with
  | nil => nil
  | b::bs => (add_comments b xs)::bs
  end.

Definition incBlockNamed (prefix:string): (cerr block_id) :=
  st <- get  ;;
  put
    {|
      block_count := S (block_count st);
      local_count := local_count st ;
      void_count := void_count st ;
      Γ := Γ st
    |} ;;
  ret (Name (prefix ++ string_of_nat (block_count st))).

Definition incBlock := incBlockNamed "b".

Definition incLocalNamed (prefix:string): (cerr raw_id) :=
  st <- get ;;
  put
    {|
      block_count := block_count st ;
      local_count := S (local_count st) ;
      void_count  := void_count st ;
      Γ := Γ st
    |} ;;
  ret (Name (prefix @@ string_of_nat (local_count st))).

Definition incLocal := incLocalNamed "l".

Definition incVoid: (cerr int) :=
  st <- get ;;
  put
    {|
      block_count := block_count st ;
      local_count := local_count st ;
      void_count  := S (void_count st) ;
      Γ := Γ st
    |} ;;
  ret (Z.of_nat (void_count st)).

Definition addVars (newvars: list (ident * typ)): cerr unit :=
  st <- get ;;
  put
    {|
      block_count := block_count st ;
      local_count := local_count st ;
      void_count  := void_count st ;
      Γ := newvars ++ Γ st
    |}.

Definition newLocalVar (t:typ) (prefix:string): (cerr raw_id) :=
  st <- get ;;
  let v := Name (prefix @@ string_of_nat (local_count st)) in
  put
    {|
      block_count := block_count st ;
      local_count := S (local_count st) ;
      void_count  := void_count st ;
      Γ := [(ID_Local v,t)] ++ (Γ st)
    |} ;;
  ret v.

Definition intrinsic_exp (d:declaration typ): exp typ :=
  EXP_Ident (ID_Global (dc_name d)).

(* TODO: move *)
Fixpoint drop_err {A:Type} (n:nat) (lst:list A) : err (list A)
  := match n, lst with
     | O, xs => ret xs
     | S n', (_::xs) => drop_err n' xs
     | _, _ => raise "drop on empty list"
     end.

Definition dropVars (n: nat): cerr unit :=
  st <- get ;;
  Γ' <- err2errS (drop_err n (Γ st)) ;;
  put {|
      block_count := block_count st ;
      local_count := local_count st ;
      void_count  := void_count st ;
      Γ := Γ'
    |}.

Definition swap_err {A:Type} (lst:list A) : err (list A)
  := match lst with
     | (x :: y :: xs) => ret (y :: x :: xs)
     | _ => raise "drop on empty list"
     end.

(* Swap top most elements on list. Used in IMapLoopBody *)
Definition swapVars : cerr unit :=
  st <- get ;;
  Γ' <- err2errS (swap_err (Γ st)) ;;
  put {|
      block_count := block_count st ;
      local_count := local_count st ;
      void_count  := void_count st ;
      Γ := Γ'
    |}.

Definition allocTempArrayCode (name: local_id) (size:Int64.int)
  :=
    [(IId name, INSTR_Alloca (getIRType (DSHPtr size)) None (Some PtrAlignment))].

Definition allocTempArrayBlock
           (name: local_id)
           (nextblock: block_id)
           (size: Int64.int): (cerr (local_id * (block typ)))
  :=
    bid <- incBlock ;;
    ret (bid,
         {|
           blk_id    := bid ;
           blk_phis  := [];
           blk_code  := allocTempArrayCode name size;
           blk_term  := TERM_Br_1 nextblock ;
           blk_comments := None
         |}).

Fixpoint genNExpr
         (nexp: NExpr) :
  cerr ((exp typ) * (code typ))
  :=
    let gen_binop a b iop :=
        '(aexp, acode) <- genNExpr a ;;
        '(bexp, bcode) <- genNExpr b ;;
        res <- incLocal ;;
        ret (EXP_Ident (ID_Local res),
             acode ++ bcode ++
                   [(IId res, INSTR_Op (OP_IBinop iop
                                                  IntType
                                                  aexp
                                                  bexp))
            ]) in
    match nexp with
    | NVar n => '(i,t) <- getStateVar "NVar out of range" n ;;
                match t, IntType with
                | TYPE_I z, TYPE_I zi =>
                  if BinNat.N.eq_dec z zi then
                    ret (EXP_Ident i, [])
                  else
                    (sΓ <- getVarsAsString ;;
                     raise ("NVar #" @@ string_of_nat n @@ " dimensions mismatch in " @@ sΓ))
                | TYPE_Pointer (TYPE_I z), TYPE_I zi =>
                  if BinNat.N.eq_dec z zi then
                    res <- incLocal ;;
                    ret (EXP_Ident (ID_Local res),
                         [(IId res, INSTR_Load false (IntType)
                                               (TYPE_Pointer (IntType),
                                                (EXP_Ident i))
                                               (ret 8%Z))])
                  else
                    (sΓ <- getVarsAsString ;;
                     raise ("NVar #" @@ string_of_nat n @@ " pointer type mismatch in " @@ sΓ))
                | _,_ =>
                  sΓ <- getVarsAsString ;;
                  raise ("NVar #" @@ string_of_nat n @@ " type mismatch in " @@ sΓ)
                end
    | NConst v => ret (EXP_Integer (Int64.intval v), [])
    | NDiv   a b => gen_binop a b (UDiv false)
    | NMod   a b => gen_binop a b URem
    | NPlus  a b => gen_binop a b (Add false false)
    | NMinus a b => gen_binop a b (Sub false false)
    | NMult  a b => gen_binop a b (Mul false false)
    | NMin   a b => raise "NMin not implemented" (* TODO *)
    | NMax   a b => raise "NMax not implemented" (* TODO *)
    end.

Definition genMExpr
           (mexp: MExpr)
  :
    cerr ((exp typ) * (code typ) * typ)
  := match mexp with
     | MPtrDeref (PVar x) => '(i,t) <- getStateVar "PVar un MPtrDeref out of range" x ;;
                             match t with
                             | TYPE_Pointer (TYPE_Array zi TYPE_Double) =>
                               ret (EXP_Ident i, [], (TYPE_Array zi TYPE_Double))
                             | _  =>
                               sΓ <- getVarsAsString ;;
                               raise ("MPtrDeref's PVar #" @@ string_of_nat x @@ " type mismatch in " @@ sΓ)
                             end
     | MConst _ _ => raise "MConst not implemented" (* TODO *)
     end.

Fixpoint genAExpr
         (fexp: AExpr) :
  cerr ((exp typ) * (code typ))
  :=
    let gen_binop a b fop :=
        '(aexp, acode) <- genAExpr a ;;
        '(bexp, bcode) <- genAExpr b ;;
        res <- incLocal ;;
        ret (EXP_Ident (ID_Local res),
             acode ++ bcode ++
                   [(IId res, INSTR_Op (OP_FBinop fop
                                                  [] (* TODO: list fast_math *)
                                                  TYPE_Double
                                                  aexp
                                                  bexp))
            ]) in
    let gen_call1 a f :=
        '(aexp, acode) <- genAExpr a ;;
        res <- incLocal ;;
        let ftyp := TYPE_Double in
        ret (EXP_Ident (ID_Local res),
             acode ++
                   [(IId res, INSTR_Call (ftyp,f) [(ftyp,aexp)])
            ]) in
    let gen_call2 a b f :=
        '(aexp, acode) <- genAExpr a ;;
        '(bexp, bcode) <- genAExpr b ;;
        res <- incLocal ;;
        let ftyp := TYPE_Double in
        ret (EXP_Ident (ID_Local res),
             acode ++ bcode ++
                   [(IId res, INSTR_Call (ftyp,f)
                                         [(ftyp,aexp); (ftyp,bexp)])
            ]) in
    match fexp with
    | AVar n => '(i,t) <- getStateVar "AVar out of range" n ;;
                match t with
                | TYPE_Double => ret (EXP_Ident i, [])
                | TYPE_Pointer TYPE_Double =>
                  res <- incLocal ;;
                  ret (EXP_Ident (ID_Local res),
                       [(IId res, INSTR_Load false TYPE_Double
                                             (TYPE_Pointer TYPE_Double,
                                              (EXP_Ident i))
                                             (ret 8%Z))])
                | _ =>
                  sΓ <- getVarsAsString ;;
                  raise ("AVar #" @@ string_of_nat n @@ " type mismatch in " @@ sΓ)
                end
    | AConst v => ret (EXP_Double v, [])
    | ANth vec i =>
      '(iexp, icode) <- genNExpr i ;;
      '(vexp, vcode, xtyp) <- genMExpr vec ;;
      px <- incLocal ;;
      let xptyp := TYPE_Pointer xtyp in
      res <- incLocal ;;
      ret (EXP_Ident (ID_Local res),
           icode ++ vcode ++
                 [
                   (IId px,  INSTR_Op (OP_GetElementPtr
                                         xtyp (xptyp, vexp)
                                         [(IntType, EXP_Integer 0%Z);
                                            (IntType, iexp)]

                   )) ;
                     (IId res, INSTR_Load false TYPE_Double
                                          (TYPE_Pointer TYPE_Double,
                                           (EXP_Ident (ID_Local px)))
                                          (ret 8%Z))
          ])
    | AAbs a => gen_call1 a (intrinsic_exp fabs_64_decl)
    | APlus a b => gen_binop a b FAdd
    | AMinus a b => gen_binop a b FSub
    | AMult a b => gen_binop a b FMul
    | AMin a b => gen_call2 a b (intrinsic_exp minimum_64_decl)
    | AMax a b => gen_call2 a b (intrinsic_exp maxnum_64_decl)
    | AZless a b =>
      (* this is special as requires bool -> double cast *)
      '(aexp, acode) <- genAExpr a ;;
      '(bexp, bcode) <- genAExpr b ;;
      ires <- incLocal ;;
      fres <- incLocal ;;
      void0 <- incVoid ;;
      ret (EXP_Ident (ID_Local fres),
           acode ++ bcode ++
                 [(IId ires, INSTR_Op (OP_FCmp FOlt
                                               TYPE_Double
                                               aexp
                                               bexp));
                    (IVoid void0, INSTR_Comment "Casting bool to float") ;
                    (IId fres, INSTR_Op (OP_Conversion
                                           Uitofp
                                           (TYPE_I 1%N)
                                           (EXP_Ident (ID_Local ires))
                                           TYPE_Double))
          ])
    end.

(* List of blocks with entry point *)
Definition segment:Type := block_id * list (block typ).

Definition genFSHAssign
           (i o: Int64.int)
           (x y: ident)
           (src dst: NExpr)
           (nextblock: block_id)
  : cerr segment
  :=
    entryblock <- incBlockNamed "Assign" ;;
    storeid <- incVoid ;;
    px <- incLocal ;;
    py <- incLocal ;;
    v <- incLocal ;;
    let xtyp := getIRType (DSHPtr i) in
    let xptyp := TYPE_Pointer xtyp in
    let ytyp := getIRType (DSHPtr o) in
    let yptyp := TYPE_Pointer ytyp in
    '(src_nexpr, src_nexpcode) <- genNExpr src  ;;
    '(dst_nexpr, dst_nexpcode) <- genNExpr dst  ;;
    ret (entryblock, [
           {|
             blk_id    := entryblock ;
             blk_phis  := [];
             blk_code  := src_nexpcode ++ dst_nexpcode ++ [
                                         (IId px,  INSTR_Op (OP_GetElementPtr
                                                               xtyp (xptyp, (EXP_Ident x))
                                                               [(IntType, EXP_Integer 0%Z);
                                                                  (IntType, src_nexpr)]

                                         )) ;
                                           (IId v, INSTR_Load false TYPE_Double
                                                              (TYPE_Pointer TYPE_Double,
                                                               (EXP_Ident (ID_Local px)))
                                                              (ret 8%Z));

                                           (IId py,  INSTR_Op (OP_GetElementPtr
                                                                 ytyp (yptyp, (EXP_Ident y))
                                                                 [(IntType, EXP_Integer 0%Z);
                                                                    (IntType, dst_nexpr)]

                                           ));

                                           (IVoid storeid, INSTR_Store false
                                                                       (TYPE_Double, (EXP_Ident (ID_Local v)))
                                                                       (TYPE_Pointer TYPE_Double,
                                                                        (EXP_Ident (ID_Local py)))
                                                                       (ret 8%Z))

                                       ];
             blk_term  := TERM_Br_1 nextblock;
             blk_comments := None
           |}
        ]).

(* Generates while loop `init_code(); i=from; while(i<to){ body(); i++;}`

    .entry:
      (init_code)
      %c0 = icmp ult i32 %start, %n
      br i1 %c0, label %.loop, label %.nextblock
    .loop:
      %i = phi i32 [ %next_i, .loopcontblock], [ %start, .entry ]
     (body)
    .loopcontblock:
      %next_i = add nsw i32 %i, 1
      %c = icmp ult i32 %next_i, %n
      br i1 %c, label %.loop, label nextblock
    nextblock:
 *)
Definition genWhileLoop
           (prefix: string)
           (from to: exp typ)
           (loopvar: raw_id)
           (loopcontblock: block_id)
           (body_entry: block_id)
           (body_blocks: list (block typ))
           (init_code: (code typ))
           (nextblock: block_id)
  : cerr segment
  :=
    entryblock <- incBlockNamed (prefix @@ "_entry") ;;
    loopblock <- incBlockNamed (prefix @@ "_loop") ;;
    loopcond <- incLocal ;;
    loopcond1 <- incLocal ;;
    nextvar <- incLocalNamed (prefix @@ "_next_i") ;;

    (* Not strictly necessary to split loop blocks, but for
        readability it is nice to have body in-place inside the
        loop *)
    let loop_pre := [
          {|
            blk_id    := entryblock ;
            blk_phis  := [];
            blk_code  :=
              init_code ++
                        [
                          (IId loopcond, INSTR_Op (OP_ICmp Ult
                                                           IntType
                                                           from
                                                           to))

                        ];
            blk_term  := TERM_Br (TYPE_I 1%N, EXP_Ident (ID_Local loopcond)) loopblock nextblock;
            blk_comments := None
          |} ;

            {|
              blk_id    := loopblock ;
              blk_phis  := [(loopvar, Phi IntType [(entryblock, from); (loopcontblock, EXP_Ident (ID_Local nextvar))])];
              blk_code  := [];
              blk_term  := TERM_Br_1 body_entry;
              blk_comments := None
            |}
        ] in
    let loop_post := [
          {|
            blk_id    := loopcontblock;
            blk_phis  := [];
            blk_code  := [
                          (IId nextvar, INSTR_Op (OP_IBinop (Add false false)
                                                            IntType
                                                            (EXP_Ident (ID_Local loopvar))
                                                            (EXP_Integer 1%Z))) ;
                            (IId loopcond1, INSTR_Op (OP_ICmp Ult
                                                              IntType
                                                              (EXP_Ident (ID_Local nextvar))
                                                              to))

                        ];
            blk_term  := TERM_Br (TYPE_I 1%N, EXP_Ident (ID_Local loopcond1)) loopblock nextblock;
            blk_comments := None
          |}
        ] in
    ret (entryblock, loop_pre ++ body_blocks ++ loop_post).

Definition genIMapBody
           (i o: Int64.int)
           (x y: ident)
           (f: AExpr)
           (loopvar: raw_id)
           (nextblock: block_id)
  : cerr segment
  :=
    pwblock <- incBlockNamed "IMapLoopBody" ;;
    storeid <- incVoid ;;
    px <- incLocal ;;
    py <- incLocal ;;
    v <- incLocal ;;
    let xtyp := getIRType (DSHPtr i) in
    let ytyp := getIRType (DSHPtr o) in
    let xptyp := TYPE_Pointer xtyp in
    let yptyp := TYPE_Pointer ytyp in
    let loopvarid := ID_Local loopvar in
    addVars [(ID_Local v, TYPE_Double)];;
    (* swapVars ;; *)
    '(fexpr, fexpcode) <- genAExpr f ;;
    dropVars 1 ;;
    ret (pwblock,
         [
           {|
             blk_id    := pwblock ;
             blk_phis  := [];
             blk_code  := [
                           (IId px,  INSTR_Op (OP_GetElementPtr
                                                 xtyp (xptyp, (EXP_Ident x))
                                                 [(IntType, EXP_Integer 0%Z);
                                                    (IntType,(EXP_Ident loopvarid))]

                           ));

                             (IId v, INSTR_Load false TYPE_Double
                                                (TYPE_Pointer TYPE_Double,
                                                 (EXP_Ident (ID_Local px)))
                                                (ret 8%Z))
                         ]

                            ++ fexpcode ++

                            [ (IId py,  INSTR_Op (OP_GetElementPtr
                                                    ytyp (yptyp, (EXP_Ident y))
                                                    [(IntType, EXP_Integer 0%Z);
                                                       (IntType,(EXP_Ident loopvarid))]

                              ));

                                (IVoid storeid, INSTR_Store false
                                                            (TYPE_Double, fexpr)
                                                            (TYPE_Pointer TYPE_Double,
                                                             (EXP_Ident (ID_Local py)))
                                                            (ret 8%Z))

                            ];
             blk_term  := TERM_Br_1 nextblock;
             blk_comments := None
           |}
        ]).

Definition genBinOpBody
           (i o: Int64.int)
           (n: nat)
           (x y: ident)
           (f: AExpr)
           (loopvar: raw_id)
           (nextblock: block_id)
  : cerr segment
  :=
    binopblock <- incBlockNamed "BinOpLoopBody" ;;
    storeid <- incVoid ;;
    loopvar2 <- incLocal ;;
    px0 <- incLocal ;;
    px1 <- incLocal ;;
    py <- incLocal ;;
    v0 <- incLocal ;;
    v1 <- incLocal ;;
    n' <- err2errS (MInt64asNT.from_nat n) ;;
    let xtyp := getIRType (DSHPtr i) in
    let xptyp := TYPE_Pointer xtyp in
    let ytyp := getIRType (DSHPtr o) in
    let yptyp := TYPE_Pointer ytyp in
    let loopvarid := ID_Local loopvar in
    addVars [(ID_Local v1, TYPE_Double); (ID_Local v0, TYPE_Double); (loopvarid, IntType)] ;;
    '(fexpr, fexpcode) <- genAExpr f ;;
    dropVars 3 ;;
    ret (binopblock,
         [
           {|
             blk_id    := binopblock ;
             blk_phis  := [];
             blk_code  := [
                           (IId px0,  INSTR_Op (OP_GetElementPtr
                                                  xtyp (xptyp, (EXP_Ident x))
                                                  [(IntType, EXP_Integer 0%Z);
                                                     (IntType,(EXP_Ident loopvarid))]

                           ));

                             (IId v0, INSTR_Load false TYPE_Double
                                                 (TYPE_Pointer TYPE_Double,
                                                  (EXP_Ident (ID_Local px0)))
                                                 (ret 8%Z));

                             (IId loopvar2, INSTR_Op (OP_IBinop (Add false false)
                                                                IntType
                                                                (EXP_Ident loopvarid)
                                                                (EXP_Integer (Z.of_nat n))));

                             (IId px1,  INSTR_Op (OP_GetElementPtr
                                                    xtyp (xptyp, (EXP_Ident x))
                                                    [(IntType, EXP_Integer 0%Z);
                                                       (IntType,(EXP_Ident (ID_Local loopvar2)))]

                             ));

                             (IId v1, INSTR_Load false TYPE_Double
                                                 (TYPE_Pointer TYPE_Double,
                                                  (EXP_Ident (ID_Local px1)))
                                                 (ret 8%Z))
                         ]

                            ++ fexpcode ++

                            [ (IId py,  INSTR_Op (OP_GetElementPtr
                                                    ytyp (yptyp, (EXP_Ident y))
                                                    [(IntType, EXP_Integer 0%Z);
                                                       (IntType, (EXP_Ident loopvarid))]

                              ));

                                (IVoid storeid, INSTR_Store false
                                                            (TYPE_Double, fexpr)
                                                            (TYPE_Pointer TYPE_Double,
                                                             (EXP_Ident (ID_Local py)))
                                                            (ret 8%Z))

                            ];
             blk_term  := TERM_Br_1 nextblock;
             blk_comments := None
           |}
        ]).

Definition genMemMap2Body
           (i0 i1 o: Int64.int)
           (x0 x1 y: ident)
           (f: AExpr)
           (loopvar: raw_id)
           (nextblock: block_id)
  : cerr segment
  :=
    binopblock <- incBlockNamed "MemMapTwoLoopBody" ;;
    storeid <- incVoid ;;
    px0 <- incLocal ;;
    px1 <- incLocal ;;
    py <- incLocal ;;
    v0 <- incLocal ;;
    v1 <- incLocal ;;
    let x0typ := getIRType (DSHPtr i0) in
    let x1typ := getIRType (DSHPtr i1) in
    let ytyp := getIRType (DSHPtr o) in
    let x0ptyp := TYPE_Pointer x0typ in
    let x1ptyp := TYPE_Pointer x1typ in
    let yptyp := TYPE_Pointer ytyp in
    let loopvarid := ID_Local loopvar in
    addVars [(ID_Local v1, TYPE_Double); (ID_Local v0, TYPE_Double)] ;;
    '(fexpr, fexpcode) <- genAExpr f ;;
    dropVars 2 ;;
    ret (binopblock,
         [
           {|
             blk_id    := binopblock ;
             blk_phis  := [];
             blk_code  := [
                           (IId px0,  INSTR_Op (OP_GetElementPtr
                                                  x0typ (x0ptyp, (EXP_Ident x0))
                                                  [(IntType, EXP_Integer 0%Z);
                                                     (IntType,(EXP_Ident loopvarid))]

                           ));

                             (IId v0, INSTR_Load false TYPE_Double
                                                 (TYPE_Pointer TYPE_Double,
                                                  (EXP_Ident (ID_Local px0)))
                                                 (ret 8%Z));

                             (IId px1,  INSTR_Op (OP_GetElementPtr
                                                    x1typ (x1ptyp, (EXP_Ident x1))
                                                    [(IntType, EXP_Integer 0%Z);
                                                       (IntType,(EXP_Ident (ID_Local loopvar)))]

                             ));

                             (IId v1, INSTR_Load false TYPE_Double
                                                 (TYPE_Pointer TYPE_Double,
                                                  (EXP_Ident (ID_Local px1)))
                                                 (ret 8%Z))
                         ]

                            ++ fexpcode ++

                            [ (IId py,  INSTR_Op (OP_GetElementPtr
                                                    ytyp (yptyp, (EXP_Ident y))
                                                    [(IntType, EXP_Integer 0%Z);
                                                       (IntType, (EXP_Ident loopvarid))]

                              ));

                                (IVoid storeid, INSTR_Store false
                                                            (TYPE_Double, fexpr)
                                                            (TYPE_Pointer TYPE_Double,
                                                             (EXP_Ident (ID_Local py)))
                                                            (ret 8%Z))

                            ];
             blk_term  := TERM_Br_1 nextblock;
             blk_comments := None
           |}
        ]).

Definition genMemInit
           (size: Int64.int)
           (y: ident)
           (initial: binary64)
           (nextblock: block_id):
  cerr segment
  :=
    let ini := genFloatV initial in
    let ttyp := getIRType (DSHPtr size) in
    let tptyp := TYPE_Pointer ttyp in
    pt <- incLocal ;;
    init_block_id <- incBlockNamed "MemInit_init" ;;
    loopcontblock <- incBlockNamed "MemInit_init_lcont" ;;
    loopvar <- incLocalNamed "MemInit_init_i" ;;
    storeid <- incVoid ;;
    let init_block :=
        {|
          blk_id    := init_block_id ;
          blk_phis  := [];
          blk_code  := [
                        (IId pt,  INSTR_Op (OP_GetElementPtr
                                              ttyp (tptyp, (EXP_Ident y))
                                              [(IntType, EXP_Integer 0%Z);
                                                 (IntType,(EXP_Ident (ID_Local loopvar)))]

                        ));

                          (IVoid storeid, INSTR_Store false
                                                      (TYPE_Double, ini)
                                                      (TYPE_Pointer TYPE_Double,
                                                       (EXP_Ident (ID_Local pt)))
                                                      (ret 8%Z))

                      ];
          blk_term  := TERM_Br_1 loopcontblock;
          blk_comments := None
        |} in
    genWhileLoop "MemInit_loop" (EXP_Integer 0%Z) (EXP_Integer (Int64.intval size)) loopvar loopcontblock init_block_id [init_block] [] nextblock.

Definition genPower
           (i o: Int64.int)
           (x y: ident)
           (src dst: NExpr)
           (n: NExpr)
           (f: AExpr)
           (initial: binary64)
           (nextblock: block_id): cerr segment
  :=
    loopcontblock <- incBlockNamed "Power_lcont" ;;
    let xtyp := getIRType (DSHPtr i) in
    let xptyp := TYPE_Pointer xtyp in
    let ytyp := getIRType (DSHPtr o) in
    let yptyp := TYPE_Pointer ytyp in
    '(nexp, ncode) <- genNExpr n ;;
    '(src_nexpr, src_nexpcode) <- genNExpr src  ;;
    '(dst_nexpr, dst_nexpcode) <- genNExpr dst  ;;
    py <- incLocal ;;
    storeid0 <- incVoid ;;
    px <- incLocal ;;
    let ini := genFloatV initial in
    let init_code := ncode ++ src_nexpcode ++ dst_nexpcode ++ [
                                    (IId px,  INSTR_Op (OP_GetElementPtr
                                                          xtyp (xptyp, (EXP_Ident x))
                                                          [(IntType, EXP_Integer 0%Z);
                                                          (IntType, src_nexpr)]

                                    ));

                                  (IId py,  INSTR_Op (OP_GetElementPtr
                                                        ytyp (yptyp, (EXP_Ident y))
                                                        [(IntType, EXP_Integer 0%Z);
                                                        (IntType,dst_nexpr)]

                                  ));

                                  (IVoid storeid0, INSTR_Store false
                                                               (TYPE_Double, ini)
                                                               (TYPE_Pointer TYPE_Double,
                                                                (EXP_Ident (ID_Local py)))
                                                               (ret 8%Z))
                           ] in

    body_block_id <- incBlockNamed "PowerLoopBody" ;;
    storeid1 <- incVoid ;;
    void2 <- incVoid ;;
    xv <- incLocal ;;
    yv <- incLocal ;;
    addVars [(ID_Local xv, TYPE_Double); (ID_Local yv, TYPE_Double)] ;;
    '(fexpr, fexpcode) <- genAExpr f ;;
    dropVars 2 ;;
    let body_block := {|
          blk_id    := body_block_id ;
          blk_phis  := [];
          blk_code  := [ (IId xv, INSTR_Load false TYPE_Double
                                              (TYPE_Pointer TYPE_Double,
                                               (EXP_Ident (ID_Local px)))
                                              (ret 8%Z));

                          (IId yv, INSTR_Load false TYPE_Double
                                              (TYPE_Pointer TYPE_Double,
                                               (EXP_Ident (ID_Local py)))
                                              (ret 8%Z))
                      ]
                         ++ fexpcode ++
                         [
                           (IVoid storeid1, INSTR_Store false
                                                        (TYPE_Double, fexpr)
                                                        (TYPE_Pointer TYPE_Double,
                                                         (EXP_Ident (ID_Local py)))
                                                        (ret 8%Z))
                         ];
          blk_term  := TERM_Br_1 loopcontblock;
          blk_comments := None
        |} in
    loopvar <- incLocalNamed "Power_i" ;;
    genWhileLoop "Power" (EXP_Integer 0%Z) nexp loopvar loopcontblock body_block_id [body_block] init_code nextblock.

Definition resolve_PVar (p:PExpr): cerr (ident*Int64.int)
  :=
    sΓ <- getVarsAsString ;;
    match p with
    | PVar n =>
      let ns := string_of_nat n in
      '(l,t) <- getStateVar ("NVar#" @@ ns @@ " out of range in " @@ sΓ) n ;;
      match t with
      | TYPE_Pointer (TYPE_Array sz TYPE_Double) =>
        sz' <- err2errS (MInt64asNT.from_N sz) ;;
        ret (l, sz')
      | _ => raise ("Invalid type of PVar#" @@ ns @@ " in " @@ sΓ)
      end
    end.

Definition genNop (nextblock: block_id) : cerr segment
  :=
    nopblock <- incBlockNamed "Nop" ;;
    ret (nopblock,
         [
           {|
             blk_id    := nopblock ;
             blk_phis  := [];
             blk_code  := [];
             blk_term  := TERM_Br_1 nextblock;
             blk_comments := None
           |}
        ]).

Fixpoint genIR
         (fshcol: DSHOperator)
         (nextblock: block_id):
  cerr segment
  :=
    let fshcol_s := string_of_DSHOperator fshcol in
    let op_s := ("--- Operator: " @@ fshcol_s @@ "---") in
    let add_comment r : cerr (segment) := '((e, b)) <- r ;; ret (e,add_comment b [op_s]) in
    catch (
        match fshcol with
        | DSHNop =>
          '(body_entry, body_blocks) <- genNop nextblock ;;
          add_comment
            (ret (body_entry, body_blocks))
        | DSHAssign (src_p,src_n) (dst_p,dst_n) =>
          '(x,i) <- resolve_PVar src_p ;;
          '(y,o) <- resolve_PVar dst_p ;;
          add_comment
            (genFSHAssign i o x y src_n dst_n nextblock)
        | DSHIMap n x_p y_p f =>
          (* the following check ensures loop bound fits integer. *)
          _ <- err2errS (MInt64asNT.from_nat n) ;;
          '(x,i) <- resolve_PVar x_p ;;
          '(y,o) <- resolve_PVar y_p ;;
          loopcontblock <- incBlockNamed "IMap_lcont" ;;
          loopvar <- newLocalVar IntType "IMap_i" ;;
          '(body_entry, body_blocks) <- genIMapBody i o x y f loopvar loopcontblock ;;
          dropVars 1 ;;
          add_comment
            (genWhileLoop "IMap" (EXP_Integer 0%Z) (EXP_Integer (Z.of_nat n)) loopvar loopcontblock body_entry body_blocks [] nextblock)
        | DSHBinOp n x_p y_p f =>
          loopcontblock <- incBlockNamed "BinOp_lcont" ;;
          '(x,i) <- resolve_PVar x_p ;;
          '(y,o) <- resolve_PVar y_p ;;
          loopvar <- incLocalNamed "BinOp_i" ;;
          '(body_entry, body_blocks) <- genBinOpBody i o n x y f loopvar loopcontblock ;;
          add_comment
            (genWhileLoop "BinOp" (EXP_Integer 0%Z) (EXP_Integer (Z.of_nat n)) loopvar loopcontblock body_entry body_blocks [] nextblock)
        | DSHMemMap2 n x0_p x1_p y_p f =>
          loopcontblock <- incBlockNamed "MemMapTwo_lcont" ;;
          '(x0,i0) <- resolve_PVar x0_p ;;
          '(x1,i1) <- resolve_PVar x1_p ;;
          '(y,o) <- resolve_PVar y_p ;;
          n' <- err2errS (MInt64asNT.from_nat n) ;;
          loopvar <- incLocalNamed "MemMapTwo_i" ;;
          '(body_entry, body_blocks) <- genMemMap2Body i0 i1 o x0 x1 y f loopvar loopcontblock ;;
          add_comment
            (genWhileLoop "MemMapTwo" (EXP_Integer 0%Z) (EXP_Integer (Z.of_nat n)) loopvar loopcontblock body_entry body_blocks [] nextblock)
        | DSHPower n (src_p,src_n) (dst_p,dst_n) f initial =>
          '(x,i) <- resolve_PVar src_p ;;
          '(y,o) <- resolve_PVar dst_p ;;
          add_comment
            (genPower i o x y src_n dst_n n f initial nextblock)
        | DSHLoop n body =>
          (* the following check ensures loop bound fits integer. *)
          _ <- err2errS (MInt64asNT.from_nat n) ;;
          loopcontblock <- incBlockNamed "Loop_lcont" ;;

          loopvar <- newLocalVar IntType "Loop_i" ;;
          '(child_block_id, child_blocks) <- genIR body loopcontblock ;;
          dropVars 1 ;;
          add_comment
            (genWhileLoop "Loop_loop" (EXP_Integer 0%Z) (EXP_Integer (Z.of_nat n))
                          loopvar loopcontblock child_block_id child_blocks[] nextblock)
        | DSHAlloc size body =>
          aname <- newLocalVar (TYPE_Pointer (getIRType (DSHPtr size))) "a" ;;
          '(bblock, bcode) <- genIR body nextblock ;;
          '(ablock,acode) <- allocTempArrayBlock aname bblock size ;;
          dropVars 1 ;;
          add_comment (ret (ablock, [acode]++bcode))
        | DSHMemInit y_p value =>
          '(y,size) <- resolve_PVar y_p ;; (* ignore actual block size *)
          '(ablock,acode) <- genMemInit size y value nextblock ;;
          add_comment (ret (ablock, acode))
        | DSHSeq f g =>
          '(gb, g') <- genIR g nextblock ;;
          '(fb, f') <- genIR f gb ;;
          add_comment (ret (fb, f'++g'))
        end)
          (fun m => raise (m @@ " in " @@ fshcol_s)).

Definition body_non_empty_cast (body : list (block typ)) : cerr (block typ * list (block typ)) :=
  match body with
  | [] => raise "Attempting to generate a function containing no block"
  | b::body => ret (b,body)
  end.

Definition LLVMGen
           (i o: Int64.int)
           (fshcol: DSHOperator)
           (funname: string)
  : cerr (toplevel_entities typ (block typ * list (block typ)))
  :=
    rid <- incBlock ;;
    let retblock :=
        {|
          blk_id    := rid ;
          blk_phis  := [];
          blk_code  := [];
          blk_term  := TERM_Ret_void;
          blk_comments := None
        |} in

    '(_,body) <- genIR fshcol rid ;;

    bodyt <- body_non_empty_cast (body ++ [retblock]) ;;
    let all_intrinsics:toplevel_entities typ (block typ * list (block typ))
        := [TLE_Comment "Prototypes for intrinsics we use"]
             ++ (List.map (TLE_Declaration) defined_intrinsics_decls)
    in

    let x := Name "X" in
    let xtyp := TYPE_Pointer (getIRType (DSHPtr i)) in
    let y := Name "Y" in
    let ytyp := TYPE_Pointer (getIRType (DSHPtr o)) in

    ret
      (all_intrinsics ++
                      [
                        TLE_Comment "Top-level operator definition" ;
                      TLE_Definition
                        {|
                          df_prototype   :=
                            {|
                              dc_name        := Name funname;
                              dc_type        := TYPE_Function TYPE_Void [xtyp; ytyp] ;
                              dc_param_attrs := ([],
                                                 [[PARAMATTR_Readonly] ++ ArrayPtrParamAttrs;
                                                 ArrayPtrParamAttrs]);
                              dc_linkage     := None ;
                              dc_visibility  := None ;
                              dc_dll_storage := None ;
                              dc_cconv       := None ;
                              dc_attrs       := []   ;
                              dc_section     := None ;
                              dc_align       := None ;
                              dc_gc          := None
                            |} ;
                          df_args        := [x; y];
                          df_instrs      := bodyt
                        |}
      ]).

(* Creates 64 bit integer from floating pointer data list by interpreting
   first 64 floating point values as bit values. *)
Definition int64FromData (data:list binary64) : (Int64.int*(list binary64)) :=
  let fix int64FromData (n: nat) (data:list binary64) (i: Int64.int) {struct n}: (Int64.int*(list binary64)) :=
      match n with
      | O => (Int64.zero, data)
      | S m =>
        let '(f,data) := rotate Float64Zero data in
        let si := Int64.add i Int64.one in
        match f with
        | B754_zero _ => int64FromData m data si
        | _ =>
          let '(x,data) := int64FromData m data si in
          (Int64.add (Int64.repr (two_power_nat m)) x, data)
        end
      end
  in int64FromData 64 data Int64.zero.

Definition initOneIRGlobal
           (data: list binary64)
           (nmt:string * DSHType)
  : cerr (list binary64 * (toplevel_entity typ (block typ * list (block typ))))
  :=
    let (nm,t) := nmt in
    match t with
    | DSHnat =>
      let '(xi, data) := int64FromData data in
      let xu := Integers.Int64.unsigned xi in
      let v_id := Name nm in
      let v_typ := getIRType t in
      let g := TLE_Global {|
                   g_ident        := v_id;
                   g_typ          := v_typ ;
                   g_constant     := true ;
                   g_exp          := Some (EXP_Integer xu);
                   g_linkage      := Some LINKAGE_Internal ;
                   g_visibility   := None ;
                   g_dll_storage  := None ;
                   g_thread_local := None ;
                   g_unnamed_addr := true ;
                   g_addrspace    := None ;
                   g_externally_initialized := false ;
                   g_section      := None ;
                   g_align        := None ; (* TODO: maybe need to alight to 64-bit boundary? *)
                 |} in
      addVars [(ID_Global v_id, TYPE_Pointer v_typ)] ;;
      ret (data, g)

    | DSHCType =>
      let '(x, data) := rotate Float64Zero data in
      let v_id := Name nm in
      let v_typ := getIRType t in
      let g := TLE_Global {|
                   g_ident        := v_id;
                   g_typ          := v_typ ;
                   g_constant     := true ;
                   g_exp          := Some (EXP_Double x);
                   g_linkage      := Some LINKAGE_Internal ;
                   g_visibility   := None ;
                   g_dll_storage  := None ;
                   g_thread_local := None ;
                   g_unnamed_addr := true ;
                   g_addrspace    := None ;
                   g_externally_initialized := false ;
                   g_section      := None ;
                   g_align        := None ; (* TODO: maybe need to alight to 64-bit boundary? *)
                 |} in
      addVars [(ID_Global v_id, TYPE_Pointer v_typ)] ;;
      ret (data, g)
    | DSHPtr n =>
      let (data, arr) := constArray (MInt64asNT.to_nat n) data in
      let v_id := Name nm in
      let v_typ := getIRType t in
      let g := TLE_Global {|
                   g_ident        := v_id;
                   g_typ          := v_typ;
                   g_constant     := true ;
                   g_exp          := Some (EXP_Array arr);
                   g_linkage      := Some LINKAGE_Internal ;
                   g_visibility   := None ;
                   g_dll_storage  := None ;
                   g_thread_local := None ;
                   g_unnamed_addr := true ;
                   g_addrspace    := None ;
                   g_externally_initialized := false ;
                   g_section      := None ;
                   g_align        := Some Utils.PtrAlignment ;
                 |} in
      addVars [(ID_Global v_id, TYPE_Pointer v_typ)] ;;
      ret (data, g)
    end.

Definition globals_name_present
           (name:string)
           (l:list (string * DSHType)) : bool
  :=
    List.fold_right (fun v f => orb f (string_beq (fst v) name)) false l.

Fact nth_to_globals_name_present (globals:list (string * DSHType)) nm :
  (exists res j, (nth_error globals j = Some res /\ fst res = nm))
  ->
  globals_name_present nm globals = true.
Proof.
  revert nm.
  unfold globals_name_present.
  induction globals.
  -
    cbn.
    intros.
    exfalso.
    destruct H as [res [j [H0 H1]]].
    rewrite Util.nth_error_nil in H0.
    inv H0.
  -
    intros.
    destruct H as [res [j H]].
    specialize (IHglobals nm).
    cbn.
    apply orb_true_iff.
    destruct j.
    +
      right.
      cbn in H.
      destruct H.
      inv H.
      unfold Misc.string_beq.
      break_if; auto.
    +
      left.
      apply IHglobals.
      eauto.
Qed.

Definition global_uniq_chk: string * DSHType -> list (string * DSHType) -> cerr unit
  := fun x xs =>
       let nm := (fst x) in
       err2errS (assert_false_to_err
         ("duplicate global name: " @@ nm)
         (globals_name_present nm xs)
         tt).

(*
  Generate IR external definitoins for all globals.
  They are externally linked and not initialized here.
  (c.f [initIRglobals]

  TODO: this is ugly. 2 maps should be replaced with single monadic fold.
 *)
Definition genIRGlobals
           {FnBody: Set}
           (x: list (string*DSHType))
  : cerr (list (toplevel_entity _ FnBody))
  := let l := List.map
                (fun g:(string * DSHType) =>
                   let (n,t) := g in
                   TLE_Global {|
                       g_ident        := Name n;
                       g_typ          := getIRType t ; (* globals are always pointers *)
                       g_constant     := true ;
                       g_exp          := None ;
                       g_linkage      := Some LINKAGE_External ;
                       g_visibility   := None ;
                       g_dll_storage  := None ;
                       g_thread_local := None ;
                       g_unnamed_addr := true ; (* TODO: unsure about this *)
                       g_addrspace    := None ;
                       g_externally_initialized:= true ;
                       g_section      := None ;
                       g_align        := Some PtrAlignment ;
                     |}
                ) x in
     match l with
     | nil => ret []
     | _::_ =>
       (* Add globals *)
       addVars
         (List.map
            (fun g:(string* DSHType) =>
               let (n,t) := g in (ID_Global (Name n), TYPE_Pointer (getIRType t)))
            x) ;;
       ret ([TLE_Comment "Global variables"] ++ l)
     end.

Definition rev_firstn {A : Type} (n : nat) (l : list A) : list A :=
  rev (firstn n l) ++ skipn n l.

Definition rev_firstn_Γ (n : nat) (st : IRState) : IRState :=
  {| block_count := block_count st;
     local_count := local_count st;
     void_count := void_count st;
     Γ := rev_firstn n (Γ st) |}.

(* [initIRGlobals], except globals are appended to the start of [Γ] in reverse *)
Definition initIRGlobals_rev
         (data: list binary64)
         (x: list (string * DSHType))
  : cerr (list binary64 * list (toplevel_entity typ (block typ * list (block typ))))
  := init_with_data initOneIRGlobal global_uniq_chk data x.

(*
  Generate delclarations for all globals. They are all internally linked
  and initialized in-place.

  (c.f. genIRglobals)

  NOTE: Could not use [monadic_fold_left] here because of error check.
*)
Definition initIRGlobals
         (data: list binary64)
         (x: list (string * DSHType))
  : cerr (list binary64 * list (toplevel_entity typ (block typ * list (block typ))))
  := fun st =>
       match initIRGlobals_rev data x st with
       | inr (st, r) => inr (rev_firstn_Γ (length x) st, r)
       | l => l
       end.

(*
   When code genration generates [main], the input
   will be stored in pre-initialized [X] global placeholder variable.
 *)
Definition initXYplaceholders (i o:Int64.int) (data:list binary64) x xtyp y ytyp:
  cerr (list binary64 * (LLVMAst.toplevel_entities _ (LLVMAst.block typ * list (LLVMAst.block typ))))
  :=
    let '(data,ydata) := constArray (MInt64asNT.to_nat o) data in
    let '(data,xdata) := constArray (MInt64asNT.to_nat i) data in
    addVars [(ID_Global y, ytyp); (ID_Global x, xtyp)] ;;
    ret (data,[ TLE_Global
        {|
          g_ident        := y;
          g_typ          := ytyp;
          g_constant     := true;
          g_exp          := Some (EXP_Array ydata);
          g_linkage      := None;
          g_visibility   := None;
          g_dll_storage  := None;
          g_thread_local := None;
          g_unnamed_addr := false;
          g_addrspace    := None;
          g_externally_initialized := false;
          g_section      := None;
          g_align        := None;
        |}
      ; TLE_Global
          {|
            g_ident        := x;
            g_typ          := xtyp;
            g_constant     := true;
            g_exp          := Some (EXP_Array xdata);
            g_linkage      := None;
            g_visibility   := None;
            g_dll_storage  := None;
            g_thread_local := None;
            g_unnamed_addr := false;
            g_addrspace    := None;
            g_externally_initialized := false;
            g_section      := None;
            g_align        := None;
          |}
    ]).

(* Generates "main" function which will call "op_name", passing
   global "x" and "y" as arguments. Returns "y". Pseudo-code:

   global float[i] x;
   global float[y] y;

   float[o] main() {
        tmp = op_name(x,y);
        return y;
   }
*)
Definition genMain
           (op_name: string)
           (* Global X placeholder: *)
           (x:raw_id) (xptyp:typ)
           (* Global Y placeholder: *)
           (y:raw_id) (ytyp:typ)
           (yptyp:typ)
  : LLVMAst.toplevel_entities _ (LLVMAst.block typ * list (LLVMAst.block typ))
  :=
    let z := Name "z" in
    [
      TLE_Comment " Main function"
      ; TLE_Definition
          {|
            df_prototype   :=
              {|
                dc_name        := Name ("main") ;
                dc_type        := TYPE_Function ytyp [] ;
                dc_param_attrs := ([],
                                   []);
                dc_linkage     := None ;
                dc_visibility  := None ;
                dc_dll_storage := None ;
                dc_cconv       := None ;
                dc_attrs       := []   ;
                dc_section     := None ;
                dc_align       := None ;
                dc_gc          := None
              |} ;
            df_args        := [];
            df_instrs      := (
                               {|
                                 blk_id    := Name "main_block" ;
                                 blk_phis  := [];
                                 blk_code  :=
                                   [
                                     (IVoid 0%Z, INSTR_Call (TYPE_Void, EXP_Ident (ID_Global (Name op_name))) [(xptyp, EXP_Ident (ID_Global x)); (yptyp, EXP_Ident (ID_Global y))]) ;
                                   (IId z, INSTR_Load false ytyp (yptyp, EXP_Ident (ID_Global y)) None )
                                   ]
                                 ;

                                 blk_term  := TERM_Ret (ytyp, EXP_Ident (ID_Local z)) ;
                                 blk_comments := None
                               |}, [])
          |}].

(* Drop 2 vars before the last 2 in Γ *)
Definition dropFakeVars: cerr unit :=
  st <- get ;;
  let l := List.length (Γ st) in
  if Nat.ltb l 4 then raise "Γ too short"
  else
    '(globals, Γ') <- option2errS "Γ too short"
                                 (ListUtil.split (Γ st) (l-4)) ;;
    '(_, Γ'') <- option2errS "Γ too short"
                            (ListUtil.split Γ' 2) ;;
    put {|
        block_count := block_count st ;
        local_count := local_count st ;
        void_count  := void_count st ;
        Γ := (globals ++ Γ'')
      |}.

Definition not_in_globals (g: list (string * DSHType)) (n:string) : bool
  := is_None_bool (List.find (fun x => eqb n (fst x)) g).

(* Return list of names of declrations. E.g. defined_intrinsics_decls *)
Fixpoint declaration_names (decls: list (declaration typ)) : list string :=
  match decls with
  | [] => []
  | (d::ds) => match dc_name d with
             | Name s => s::declaration_names ds
             | _ => declaration_names ds
             end
  end.

Definition valid_program (p: FSHCOLProgram) : bool :=
  (negb (eqb (name p) "main")) &&
  not_in_globals (globals p) "main" &&
  not_in_globals (globals p) (name p) &&
  (let dnames := declaration_names defined_intrinsics_decls in
   (forallb (fun x => not_in_globals (globals p) x) (declaration_names defined_intrinsics_decls)) &&
   (is_None_bool (List.find (fun x => eqb (name p) x) dnames))).

Definition compile (p: FSHCOLProgram) (just_compile:bool) (data:list binary64): cerr (toplevel_entities typ (block typ * list (block typ))) :=
  match p with
  | mkFSHCOLProgram i o name globals op =>
    if valid_program p then
      if just_compile then
        (* While generate operator's function body, add parameters as
         locals X=PVar 1, Y=PVar 0.

        We want them to be in `Γ` before globals *)
        let x := Name "X" in
        let xtyp := TYPE_Pointer (getIRType (DSHPtr i)) in
        let y := Name "Y" in
        let ytyp := TYPE_Pointer (getIRType (DSHPtr o)) in

        addVars [(ID_Local y, ytyp);(ID_Local x, xtyp)] ;;
        ginit <- genIRGlobals (FnBody:= block typ * list (block typ)) globals ;;

        (* Γ := [y; x; fake_y; fake_x] *)
        prog <- LLVMGen i o op name ;;
        ret (ginit ++ prog)
      else
        (* Global placeholders for X,Y *)
        let gx := Anon 0%Z in
        let gxtyp := getIRType (DSHPtr i) in
        let gxptyp := TYPE_Pointer gxtyp in

        let gy := Anon 1%Z in
        let gytyp := getIRType (DSHPtr o) in
        let gyptyp := TYPE_Pointer gytyp in

        '(data,yxinit) <- initXYplaceholders i o data gx gxtyp gy gytyp ;;
        (* Γ := [fake_y; fake_x] *)

        (* While generate operator's function body, add parameters as
         locals X=PVar 1, Y=PVar 0.

        We want them to be in `Γ` before globals *)
        let x := Name "X" in
        let xtyp := TYPE_Pointer (getIRType (DSHPtr i)) in
        let y := Name "Y" in
        let ytyp := TYPE_Pointer (getIRType (DSHPtr o)) in

        addVars [(ID_Local y, ytyp);(ID_Local x, xtyp)] ;;
        (* Γ := [y; x; fake_y; fake_x] *)

        (* Global variables *)
        '(data,ginit) <- initIRGlobals data globals ;;
        (* Γ := [globals; y; x; fake_y; fake_x] *)

        (* operator function *)
        prog <- LLVMGen i o op name ;;

        (* After generation of operator function, we no longer need
         [x] and [y] in [Γ]. *)

        dropFakeVars ;;

        (* Main function *)
        let main := genMain name gx gxptyp gy gytyp gyptyp in
        ret (ginit ++ yxinit ++ prog ++ main)
    else
      raise "invalid program name"
  end.

Definition compile_w_main (p: FSHCOLProgram): list binary64 -> cerr (toplevel_entities typ (block typ * list (block typ))) :=
  compile p false.


From Usuba Require Import usuba_AST usuba_sem equiv_rel collect collectProof clean.
From Coq Require Import MSets MSets.MSetToFiniteSet MSets.MSetFacts.

From mathcomp Require Import all_ssreflect.
Require Import Coq.Sets.Ensembles.

Lemma clean_in_deqs_freevars:
    forall eqns vars x,
        iset.mem x (fst (clean_in_deqs vars (list_deq_of_deqL eqns))) = true <->
            iset.mem x vars = true \/
            In ident (deqs_vars (snd (clean_in_deqs vars (list_deq_of_deqL eqns)))) x.
Proof.
    move=> eqns; induction eqns as [|v e l tl HRec | i ae1 ae2 dL' HRec1 opt tl HRec2]; simpl.
    {
        split; auto.
        move => [|[]]; trivial.
    }
    {
        move=> vars x; specialize HRec with vars x.
        destruct (clean_in_deqs vars (list_deq_of_deqL tl)); simpl in *.
        case (iset.exists_ (iset.mem^~ t) (collect_varl v)); simpl; trivial.
        do 2 rewrite iset.mem_spec; do 2 rewrite iset.mem_spec in HRec.
        do 2 rewrite iset.union_spec; rewrite collect_expr_soundness.
        rewrite collect_varl_soundness.
        rewrite HRec; clear HRec; split.
        + move=> [[]|[]]; auto; move=> H; right.
            + constructor; assumption.
            + do 2 constructor; assumption.
            + do 2 constructor; assumption.
        + move=> [HIn|[elt' [elt HIn|elt HIn]|HIn]]; auto.
    }
    {
        move=> vars x; specialize HRec2 with vars x.
        destruct (clean_in_deqs vars (list_deq_of_deqL tl)) as [vars' tl']; simpl in *.
        case (iset.exists_ (iset.mem^~ vars') (collect_bounddeqs (list_deq_of_deqL dL')) || iset.mem i vars'); simpl; auto.
        rewrite iset.mem_spec; rewrite iset.add_spec; do 3 rewrite iset.union_spec; do 2 rewrite collect_aexpr_soundness.
        rewrite collect_deqs_soundness.
        rewrite iset.mem_spec in HRec2; rewrite HRec2; split.
        - move=> [|[[]|[[]|]]]; auto.
            * move=> ->; by do 3 constructor.
            * intros; right; constructor; assumption.
            * intros; right; do 3 constructor; assumption.
            * intros; right; do 4 constructor; assumption.
            * intros; right; do 4 constructor; assumption.
        - move=> [|[elt' [elt []|elt [|elt'2 []]]|]]; auto.
    }
Qed.

Lemma loop_rec_change_ctxt arch prog:
    forall e s body i ens ctxt1 ctxt2 type_ctxt,
        context_srel (Union ident (fun elt => iset.In elt (collect_deqs (list_deq_of_deqL body))) ens) ctxt1 ctxt2 ->
        opt_rel (context_srel (Union ident (fun elt => iset.In elt (collect_deqs (list_deq_of_deqL body))) ens))
            (loop_rec ctxt1 ((eval_deq_list arch prog type_ctxt)^~ (list_deq_of_deqL body)) i s e)
            (loop_rec ctxt2 ((eval_deq_list arch prog type_ctxt)^~ (list_deq_of_deqL body)) i s e).
Proof.
    move=> e; induction e as [|e HRec]; simpl; auto.
    move=> s body i ens ctxt1 ctxt2 type_ctxt HRel.
    case (match s with 0 => false | m'.+1 => PeanoNat.Nat.leb e m' end); simpl; auto.
    pose (p := HRec s body i ens ctxt1 ctxt2 type_ctxt HRel); move:p.
    destruct (loop_rec ctxt1 ((eval_deq_list arch prog type_ctxt)^~ (list_deq_of_deqL body)) i s e).
    all: destruct (loop_rec ctxt2 ((eval_deq_list arch prog type_ctxt)^~ (list_deq_of_deqL body)) i s e); simpl; auto.
    2: move=> [].
    2: discriminate.
    move=> HRel2.
    apply eval_deqL_change_ctxt.
    {
        reflexivity.
    }
    {
        move=> elt HIn.
        constructor 1.
        unfold In.
        rewrite collect_deqs_soundness.
        assumption.
    }
    {
        move=> elt HIn; simpl.
        case (String.eqb elt i); trivial.
        apply HRel2; assumption.
    }
Qed.

Lemma clean_in_deqs_soundness arch prog:
    forall eqns vars ctxt1 ctxt2 type_ctxt,
        eval_deq_list arch prog type_ctxt ctxt1 (list_deq_of_deqL eqns) <> None ->
        context_srel (deqs_vars (snd (clean_in_deqs vars (list_deq_of_deqL eqns)))) ctxt1 ctxt2 ->
        context_srel (fun i => iset.mem i vars = true) ctxt1 ctxt2 ->
        opt_rel (context_srel (fun i => iset.mem i vars = true))
            (eval_deq_list arch prog type_ctxt ctxt1 (list_deq_of_deqL eqns))
            (eval_deq_list arch prog type_ctxt ctxt2 (snd (clean_in_deqs vars (list_deq_of_deqL eqns)))).
Proof.
    move=> eqns; induction eqns as [|v expr b tl HRec'|i aei1 aei2 body HRecBody opt tl HRecTL]; simpl.
    { auto. }
    {
        move=> vars ctxt1 ctxt2 type_ctxt.
        pose (p := clean_in_deqs_freevars tl vars); move:p.
        pose (HRec := HRec' vars); move: HRec.
        destruct (clean_in_deqs vars (list_deq_of_deqL tl)) as [vars' tl']; simpl in *.
        clear HRec'.
        case_eq (iset.exists_ (iset.mem^~ vars') (collect_varl v)); simpl.
        {
            move=> _ HRec _ HnoErr HRel1 HRel2.
            rewrite <- (eval_expr_change_ctxt _ _ ctxt1 ctxt2 prog prog).
            + destruct (eval_expr arch prog ctxt1 expr) as [val|]; simpl; trivial.
                assert (context_srel (Union ident (varl_freevars v)
                    (Union ident (deqs_vars tl') (fun i : ident => iset.mem i vars = true))) ctxt1 ctxt2) as HRel3.
                {
                    move=> x HIn; destruct HIn as [|x []].
                    - apply HRel1; do 2 constructor; assumption.
                    - apply HRel1; constructor; assumption.
                    - apply HRel2; assumption.
                }
                pose (H := context_srel_bind v type_ctxt _ _ val _ HRel3); move: H.
                destruct (bind ctxt1 type_ctxt v val) as [ctxt1'|]; simpl.
                2: by move=> ->; simpl; reflexivity.
                destruct (bind ctxt2 type_ctxt v val) as [ctxt2'|]; simpl.
                2: by move=> [].
                move=> HRel4; apply HRec; trivial.
                - move=> x HIn; apply HRel4; do 2 constructor; assumption.
                - move=> x HIn; apply HRel4; do 2 constructor; assumption.
            + reflexivity.
            + move=> x HIn; apply HRel1; do 2 constructor; assumption.
        }
        {
            rewrite <- not_true_iff_false.
            rewrite iset.exists_spec.
            move=> NegExists HRec Hfreevars HnoErr HRel1 HRel2.
            case (eval_expr arch prog ctxt1 expr) as [x|].
            2: exfalso; apply HnoErr; reflexivity.
            pose (p := context_srel_bind_compl v x ctxt1 type_ctxt); move:p.
            case (bind ctxt1 type_ctxt v x) as [ctxt'|].
            2: exfalso; apply HnoErr; reflexivity.
            move=> HRel3; apply HRec; trivial.
            all: transitivity ctxt1; trivial.
            all: symmetry; move=> elt HIn; apply HRel3.
            all: assert (iset.mem elt vars' = true) as Hfreevars' by (rewrite Hfreevars; auto).
            all: clear Hfreevars; unfold Complement; unfold In; move=> HIn'.
            all: apply NegExists; unfold iset.Exists; exists elt; split; trivial.
            all: rewrite collect_varl_soundness; unfold In; assumption.
        }
    }
    {
        move=> vars ctxt1 ctxt2 type_ctxt HnoErr HRel1 HRel2.
        pose (p := clean_in_deqs_freevars tl vars); move:p.
        pose (p := HRecTL vars); move: p; clear HRecTL.
        destruct (clean_in_deqs vars (list_deq_of_deqL tl)) as [vars' tl']; simpl.
        move=> HRecTL.
        case_eq (iset.exists_ (iset.mem^~ vars') (collect_bounddeqs (list_deq_of_deqL body))
            || iset.mem i vars').
        all: move=> HEq; rewrite HEq in HRel1; simpl.
        {
            move=> _; clear HEq; move: HnoErr.
            rewrite (eval_aexpr_change_ctxt _ ctxt1 ctxt2).
            2: apply context_srel_imp_context_csrel; move=> x HIn; apply HRel1; simpl; do 3 constructor; assumption.
            rewrite (eval_aexpr_change_ctxt _ ctxt1 ctxt2).
            2: apply context_srel_imp_context_csrel; move=> x HIn; apply HRel1; simpl; do 4 constructor; assumption.
            destruct (eval_arith_expr ctxt2 aei1) as [s|]; simpl; trivial.
            destruct (eval_arith_expr ctxt2 aei2) as [e|]; simpl; trivial.
            assert (context_srel (Union ident (iset.In^~ (collect_deqs (list_deq_of_deqL body)))
               (Union ident (fun i : ident => iset.mem i vars = true) (deqs_vars tl'))) ctxt1 ctxt2) as HRel3.
            {
                move=> x' [x HIn|x'' [x HIn|x HIn]].
                + apply HRel1; simpl; unfold In in HIn; rewrite collect_deqs_soundness in HIn.
                    do 4 constructor; assumption.
                + apply HRel2; assumption.
                + apply HRel1; simpl; constructor; assumption.
            }
            pose (p := loop_rec_change_ctxt arch prog e s body i _ ctxt1 ctxt2 type_ctxt HRel3); move: p; clear HRel3.
            destruct (loop_rec ctxt1 ((eval_deq_list arch prog type_ctxt)^~ (list_deq_of_deqL body)) i s e) as [ctxt1'|].
            2: move=> _ HnoErr; exfalso; apply HnoErr; reflexivity.
            destruct (loop_rec ctxt2 ((eval_deq_list arch prog type_ctxt)^~ (list_deq_of_deqL body)) i s e) as [ctxt2'|]; simpl.
            2: move=> [].
            assert (match find_val ctxt1 i with Some v => Some ((i, v) :: ctxt1') | None => Some ctxt1' end
                = Some match find_val ctxt1 i with Some v => (i, v)::ctxt1' | None => ctxt1' end) as HEq
                by (case (find_val ctxt1 i); simpl; auto).
            rewrite HEq; clear HEq.
            assert (match find_val ctxt2 i with Some v => Some ((i, v) :: ctxt2') | None => Some ctxt2' end
                = Some match find_val ctxt2 i with Some v => (i, v)::ctxt2' | None => ctxt2' end) as HEq
                by (case (find_val ctxt2 i); simpl; auto).
            rewrite HEq; clear HEq.
            move=> HRel3 HnoErr.
            apply HRecTL; auto; move=> x HIn; case_eq (String.eqb x i).
            1,3: rewrite String.eqb_eq; move=> HEq; destruct HEq.
            {
                assert (find_val ctxt1 x = find_val ctxt2 x) as HEq
                    by (apply HRel1; simpl; constructor; assumption); destruct HEq.
                case (find_val ctxt1 x); simpl.
                + rewrite String.eqb_refl; reflexivity.
                + apply HRel3; do 2 constructor; assumption.
            }
            {
                assert (find_val ctxt1 x = find_val ctxt2 x) as HEq
                    by (apply HRel2; simpl; assumption); destruct HEq.
                case (find_val ctxt1 x); simpl.
                + rewrite String.eqb_refl; reflexivity.
                + apply HRel3; do 2 constructor; assumption.
            }
            all: case (find_val ctxt1 i); case (find_val ctxt2 i); simpl.
            1,5: move=> v v' ->.
            3,4,6,7: move=> v ->.
            7,8: move=> _.
            all: apply HRel3; do 2 constructor; assumption.
        }
        {
            rewrite orb_false_iff in HEq; destruct HEq as [Hexists HnegMem].
            destruct (eval_arith_expr ctxt1 aei1) as [i1|].
            2: exfalso; apply HnoErr; reflexivity.
            destruct (eval_arith_expr ctxt1 aei2) as [i2|].
            2: exfalso; apply HnoErr; reflexivity.
            pose (p := loop_rec_unchanged_ctxt arch prog i i1 i2 body ctxt1 type_ctxt); move:p.
            destruct (loop_rec ctxt1 ((eval_deq_list arch prog type_ctxt)^~ (list_deq_of_deqL body)) i i1 i2) as [ctxt'|].
            2: exfalso; apply HnoErr; reflexivity.
            clear HRecBody.
            move=> HRel Hvars'.
            case_eq (find_val ctxt1 i).
            1: move=> v Hfind_val; rewrite Hfind_val in HnoErr.
            2: move=> Hfind_val; rewrite Hfind_val in HnoErr.
            all: apply HRecTL; trivial; transitivity ctxt1; trivial; symmetry.
            all: move=> elt HIn; simpl.
            {
                case_eq (String.eqb elt i).
                + rewrite String.eqb_eq; move=> HEq2; destruct HEq2; assumption.
                + move=> HnotEq; apply HRel; unfold Complement, In; move=> HIn'.
                    rewrite <- not_true_iff_false in Hexists; apply Hexists.
                    rewrite iset.exists_spec; unfold iset.Exists.
                    exists elt.
                    destruct HIn' as [elt' []|].
                    by rewrite String.eqb_refl in HnotEq.
                    rewrite collect_bounddeqs_soundness_lemma; split; trivial.
                    rewrite Hvars'; auto.
            }
            {
                case_eq (String.eqb elt i).
                + rewrite String.eqb_eq; move=> HEq2; destruct HEq2; assumption.
                + move=> HnotEq; apply HRel; unfold Complement, In; move=> HIn'.
                    rewrite <- not_true_iff_false in Hexists; apply Hexists.
                    rewrite iset.exists_spec; unfold iset.Exists.
                    exists elt.
                    destruct HIn' as [elt' []|].
                    by rewrite String.eqb_refl in HnotEq.
                    rewrite collect_bounddeqs_soundness_lemma; split; trivial.
                    rewrite Hvars'; auto.
            }
            all: rewrite <- not_true_iff_false in HnegMem; rewrite Hvars' in HnegMem.
            all: apply HRel; unfold Complement, In; move=> HIn'; destruct HIn' as [elt' []|elt' HIn'].
            1,3: apply HnegMem; auto.
            all: rewrite <- not_true_iff_false in Hexists; apply Hexists.
            all: rewrite iset.exists_spec; unfold iset.Exists.
            all: exists elt'.
            all: rewrite Hvars'; split; auto.
            all: rewrite collect_bounddeqs_soundness_lemma; trivial.
        }
    }
Qed.

Theorem clean_node_soudness arch prog:
    forall node param input,
        eval_node node arch prog param input <> None ->
        eval_node node arch prog param input =
        eval_node (clean_node node) arch prog param input.
Proof.
    unfold clean_node.
    move=> [id p_in p_out node_opt [temp_vars eqns| | |]]; simpl; trivial.
    unfold eval_node; simpl.
    move=> [] input; trivial.
    case (build_ctxt p_in input); trivial.
    move=> ctxt HnoErr.
    assert (eval_deq_list arch prog (build_type_ctxt (temp_vars ++ p_in ++ p_out)) ctxt eqns <> None) as HnoErr1.
    {
        move=> HEq; rewrite HEq in HnoErr; apply HnoErr; trivial.
    }
    pose (p := clean_in_deqs_soundness arch prog (deqL_of_list_deq eqns) (collect_vdecl p_out) ctxt ctxt); move: p.
    rewrite deqL_is_list_deq; move=> p.
    pose (p' := p (build_type_ctxt (_ ++ _ ++ _)%list) HnoErr1 (context_srel_refl _ _) (context_srel_refl _ _)); move: p'; clear p.
    destruct (eval_deq_list arch prog _ ctxt eqns); simpl.
    2: by move=> ->; trivial.
    destruct (eval_deq_list arch prog _ ctxt (snd (clean_in_deqs (collect_vdecl p_out) eqns))); simpl.
    {
        induction p_out as [|a tl HRec]; simpl; trivial.
        move=> HRel; rewrite HRec.
        + rewrite HRel; trivial.
            unfold Ensembles.In; rewrite iset.mem_spec; rewrite iset.add_spec; auto.
        + simpl in HnoErr; move=> HEq; rewrite HEq in HnoErr; apply HnoErr; case (find_val c (VD_ID a)); trivial.
        + move=> x HIn; apply HRel; unfold Ensembles.In in *.
            rewrite iset.mem_spec; rewrite iset.mem_spec in HIn; rewrite iset.add_spec; auto.
    }
    {
        move=> [].
    }
Qed.


Require Export MicroBFTprops2.

Section MicroBFTprim.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { dtc                 : DTimeContext          }.
  Context { microbft_context    : MicroBFT_context      }.
  Context { m_initial_keys      : MicroBFT_initial_keys }.
  Context { u_initial_keys      : USIG_initial_keys     }.
  Context { usig_hash           : USIG_hash             }.
  Context { microbft_auth       : MicroBFT_auth         }.

  Lemma not_primary_false_implies :
    forall n,
      not_primary n = false
      -> n = MicroBFT_primary.
  Proof.
    introv h.
    apply negb_false_iff in h.
    unfold is_primary in *; smash_microbft2.
  Qed.
  Hint Resolve not_primary_false_implies : microbft.

  Lemma uis_from_primary :
    forall {eo : EventOrdering} (e : Event) ui,
      knows_after e (microbft_data_ui ui)
      -> ui2rep ui = MicroBFT_primary.
  Proof.
    introv kn.
    unfold knows_after, state_after in kn; exrepnd; simpl in *.
    unfold MicroBFT_data_knows in *; simpl in *.
    rewrite M_state_sys_on_event_unfold in kn2; apply map_option_Some in kn2; exrepnd; rev_Some.
    unfold MicroBFTheader.node2name in *; simpl in *.
    rewrite kn1 in *; simpl in *.
    unfold MicroBFTsys in *; simpl in *.
    applydup M_run_ls_on_event_ls_is_microbft in kn2; exrepnd; subst; simpl in *.

    apply option_map_Some in kn3; exrepnd; subst; simpl in *; microbft_simp.

    remember (loc e) as n; symmetry in Heqn.
    revert dependent s2.
    revert dependent s1.
    revert dependent s.
    induction e as [e ind] using predHappenedBeforeInd;[]; introv run i.

    rewrite M_run_ls_on_event_unroll2 in run.
    apply map_option_Some in run; exrepnd; rev_Some.
    apply map_option_Some in run0; exrepnd; rev_Some.
    simpl in *.
    applydup M_run_ls_before_event_ls_is_microbft in run1; exrepnd; subst; simpl in *.

    unfold M_run_ls_on_input_ls, M_run_ls_on_input in *.
    autorewrite with microbft in *.

    rewrite M_run_ls_before_event_unroll_on in run1.

    Time microbft_dest_msg Case;
      try (destruct (dec_isFirst e));
      repeat(simpl in *; autorewrite with microbft in *; smash_microbft2);
      try (complete (apply ind in run1; autorewrite with eo; eauto 3 with eo));
      try (dup run1 as w; eapply preserves_usig_id2 in w);
      autorewrite with microbft eo in *; eauto;
        repndors; ginv;
          try (complete (apply ind in run1; autorewrite with eo; eauto 3 with eo));
          try (complete (unfold ui_in_log_entry in *;
                           simpl in *; smash_microbft2;
                             allrw; eauto 3 with microbft));
          try (complete (unfold ui_in_log_entry in *; simpl in *; smash_microbft2;
                           apply invalid_request_false_implies_ui2rep_eq in Heqx; auto)).
  Qed.

End MicroBFTprim.

Hint Resolve not_primary_false_implies : microbft.


Set Implicit Arguments.

(* there is a name conflict on tactic 'unfolder' between GeneralTactics and MakeADT *)
Require Import Bedrock.Platform.Cito.GeneralTactics.

Require Import Bedrock.Platform.Facade.examples.FiatADTs.
Import Adt.
Require Import Bedrock.Platform.Cito.WordMap.
Require Import Bedrock.Platform.Cito.RepInv Bedrock.Platform.Cito.MakeADT.

Require Import Bedrock.Platform.AutoSep.

Require Import Bedrock.Platform.Facade.examples.ListSetF Bedrock.Platform.Facade.examples.ListSeqF Bedrock.Platform.Facade.examples.FiatRepInv.

Module Import Made := MakeADT.Make(FiatADTs.Adt)(Ri).

Import Semantics.

Import LinkMake.StubsMake.StubMake.CompileFuncSpecMake.InvMake.SemanticsMake.
Import LinkMake.StubsMake.StubMake.CompileFuncSpecMake.InvMake2.
Import LinkMake.StubsMake.StubMake.CompileFuncSpecMake.InvMake.

Lemma is_heap_eat : forall w v,
  is_heap heap_empty
  ===> is_heap (WordMap.remove w (heap_upd heap_empty w v)).
  intros; apply is_heap_Equal.
  apply Properties.F.Equal_mapsto_iff; intuition.
  apply Properties.F.empty_mapsto_iff in H; tauto.
  apply Properties.F.remove_mapsto_iff in H; intuition.
  apply Properties.F.add_mapsto_iff in H1; intuition.
Qed.
Require Import Bedrock.Platform.Cito.SemanticsFacts5.
Require Import Bedrock.Platform.Cito.LayoutHintsUtil.

Lemma readd_FEnsemble : forall c rv rv',
  lset rv' c * is_heap heap_empty
  ===> is_heap (WordMap.add c (FEnsemble rv') (heap_upd heap_empty c (FEnsemble rv))).
  intros.
  unfold is_heap at 2.
  assert (List.In (c, FEnsemble rv') (heap_elements (WordMap.add c (FEnsemble rv') (heap_upd heap_empty c (FEnsemble rv))))).
  apply InA_In.
  apply WordMap.elements_1.
  apply WordMap.add_1.
  auto.
  eapply starL_in in H; try (apply NoDupA_NoDup; apply WordMap.elements_3w).
  destruct H; intuition idtac.
  eapply Himp_trans; [ | apply H0 ].
  simpl.
  apply Himp_star_frame; try apply Himp_refl.
  apply starL_permute; auto.
  apply NoDupA_NoDup; apply WordMap.elements_3w.
  intuition.
  apply H2 in H1; intuition.
  apply In_InA' in H4.
  apply WordMap.elements_2 in H4.
  apply Properties.F.add_mapsto_iff in H4; intuition.
  apply Properties.F.add_mapsto_iff in H5; intuition.
  apply Properties.F.empty_mapsto_iff in H6; tauto.
Qed.
Import LayoutHintsUtil.

Lemma readd_List : forall c rv rv',
  lseq rv' c * is_heap heap_empty
  ===> is_heap (WordMap.add c (List rv') (heap_upd heap_empty c (List rv))).
  intros.
  unfold is_heap at 2.
  assert (List.In (c, List rv') (heap_elements (WordMap.add c (List rv') (heap_upd heap_empty c (List rv))))).
  apply InA_In.
  apply WordMap.elements_1.
  apply WordMap.add_1.
  auto.
  eapply starL_in in H; try (apply NoDupA_NoDup; apply WordMap.elements_3w).
  destruct H; intuition idtac.
  eapply Himp_trans; [ | apply H0 ].
  simpl.
  apply Himp_star_frame; try apply Himp_refl.
  apply starL_permute; auto.
  apply NoDupA_NoDup; apply WordMap.elements_3w.
  intuition.
  apply H2 in H1; intuition.
  apply In_InA' in H4.
  apply WordMap.elements_2 in H4.
  apply Properties.F.add_mapsto_iff in H4; intuition.
  apply Properties.F.add_mapsto_iff in H5; intuition.
  apply Properties.F.empty_mapsto_iff in H6; tauto.
Qed.

Lemma get_rval : forall specs st P (Q : Prop) R S T Z,
  (Q -> interp specs (![P * R * S * T] st ---> Z)%PropX)
  -> interp specs (![P * (([|Q|] * R) * S) * T] st ---> Z)%PropX.
  intros.
  apply Imply_trans with (![[|Q|] * (P * R * S * T)]st)%PropX.
  assert (P * ([|Q|] * R * S) * T ===> [|Q|] * (P * R * S * T)).
  sepLemma.
  rewrite sepFormula_eq.
  apply H0.
  apply Imply_trans with ([|Q|] /\ ![P * R * S * T]st)%PropX.
  rewrite sepFormula_eq.
  do 2 (apply existsL; intro).
  apply andL; apply injL; intro.
  apply andL.
  apply andL.
  apply injL; intro.
  apply injL; intro.
  apply split_semp in H0; auto; subst.
  apply andR.
  apply injR; auto.
  apply Imply_refl.
  apply andL.
  apply injL; auto.
Qed.

Lemma get_rval' : forall specs st P (Q : Prop) R S T Z,
  (Q -> interp specs (![P * R * S * T] st ---> Z)%PropX)
  -> interp specs (![P * ((R * [|Q|]) * S) * T] st ---> Z)%PropX.
  intros.
  apply Imply_trans with (![[|Q|] * (P * R * S * T)]st)%PropX.
  assert (P * (R * [|Q|] * S) * T ===> [|Q|] * (P * R * S * T)).
  sepLemma.
  rewrite sepFormula_eq.
  apply H0.
  apply Imply_trans with ([|Q|] /\ ![P * R * S * T]st)%PropX.
  rewrite sepFormula_eq.
  do 2 (apply existsL; intro).
  apply andL; apply injL; intro.
  apply andL.
  apply andL.
  apply injL; intro.
  apply injL; intro.
  apply split_semp in H0; auto; subst.
  apply andR.
  apply injR; auto.
  apply Imply_refl.
  apply andL.
  apply injL; auto.
Qed.

Lemma get_rval'' : forall specs st P (Q : Prop) R S Z,
  (Q -> interp specs (![P * R * S] st ---> Z)%PropX)
  -> interp specs (![P * ([|Q|] * R) * S] st ---> Z)%PropX.
  intros.
  apply Imply_trans with (![[|Q|] * (P * R * S)]st)%PropX.
  assert (P * ([|Q|] * R) * S ===> [|Q|] * (P * R * S)).
  sepLemma.
  rewrite sepFormula_eq.
  apply H0.
  apply Imply_trans with ([|Q|] /\ ![P * R * S]st)%PropX.
  rewrite sepFormula_eq.
  do 2 (apply existsL; intro).
  apply andL; apply injL; intro.
  apply andL.
  apply andL.
  apply injL; intro.
  apply injL; intro.
  apply split_semp in H0; auto; subst.
  apply andR.
  apply injR; auto.
  apply Imply_refl.
  apply andL.
  apply injL; auto.
Qed.

Definition hints : TacPackage.
  prepare (store_pair_inl_fwd, store_pair_inr_fwd)
  (store_pair_inl_bwd, store_pair_inr_bwd).
Defined.

Arguments SCA {ADTValue} _.
Arguments ADT {ADTValue} _.

Require Bedrock.Platform.Cito.AxSpec.
Import AxSpec.ConformTactic.

Definition m0 := bimport [[ "sys"!"abort" @ [abortS],

                            "ListSet"!"new" @ [ListSetF.newS],
                            "ListSet"!"delete" @ [ListSetF.deleteS],
                            "ListSet"!"mem" @ [ListSetF.memS],
                            "ListSet"!"add" @ [ListSetF.addS],
                            "ListSet"!"remove" @ [ListSetF.removeS],
                            "ListSet"!"size" @ [ListSetF.sizeS],

                            "ListSeq"!"new" @ [ListSeqF.newS],
                            "ListSeq"!"delete" @ [ListSeqF.deleteS],
                            "ListSeq"!"pop" @ [ListSeqF.popS],
                            "ListSeq"!"empty" @ [ListSeqF.emptyS],
                            "ListSeq"!"push" @ [ListSeqF.pushS],
                            "ListSeq"!"copy" @ [ListSeqF.copyS],
                            "ListSeq"!"rev" @ [ListSeqF.revS],
                            "ListSeq"!"length" @ [ListSeqF.lengthS] ]]
  fmodule "ADT" {{
    ffunction "sEmpty" reserving 8 [FEnsemble_sEmpty] := "ListSet"!"new"
    with ffunction "sDelete" reserving 7 [FEnsemble_sDelete] := "ListSet"!"delete"
    with ffunction "sAdd" reserving 9 [FEnsemble_sAdd] := "ListSet"!"add"
    with ffunction "sRemove" reserving 7 [FEnsemble_sRemove] := "ListSet"!"remove"
    with ffunction "sIn" reserving 1 [FEnsemble_sIn] := "ListSet"!"mem"
    with ffunction "sSize" reserving 1 [FEnsemble_sSize] := "ListSet"!"size"
    with ffunction "new" reserving 8 [List_new] := "ListSeq"!"new"
    with ffunction "delete" reserving 7 [List_delete] := "ListSeq"!"delete"
    with ffunction "pop" reserving 8 [List_pop] := "ListSeq"!"pop"
    with ffunction "empty" reserving 0 [List_empty] := "ListSeq"!"empty"
    with ffunction "push" reserving 8 [List_push] := "ListSeq"!"push"
    with ffunction "copy" reserving 10 [List_copy] := "ListSeq"!"copy"
    with ffunction "rev" reserving 2 [List_rev] := "ListSeq"!"rev"
    with ffunction "length" reserving 1 [List_length] := "ListSeq"!"length"
  }}.

Theorem ok0 : moduleOk m0.
  vcgen.

  (* ListSet *)

  (* sEmpty *)

  do_abort (@nil string).
  do_abort (@nil string).
  do_abort (@nil string).

  do_delegate1 (@nil string) hints.
  do 2 (descend; step auto_ext).
  2: returnAdt.
  simpl.
  make_toArray (@nil string).
  step auto_ext.
  etransitivity; [ | apply himp_star_frame; [ apply (@is_state_in x4) | reflexivity ] ].
  unfolder.
  do_delegate2 (@nil string).

  (* sDelete *)

  do_abort ("self" :: nil).
  do_abort ("self" :: nil).
  do_abort ("self" :: nil).

  do_delegate1 ("self" :: nil) hints.
  descend; step auto_ext.
  repeat (apply andL || (apply injL; intro) || (apply existsL; intro)); reduce.
  apply get_rval''; intro.
  descend; step auto_ext.
  2: returnScalar.
  simpl.
  make_toArray ("self" :: nil).
  step auto_ext.
  etransitivity; [ | apply (@is_state_in x2) ].
  unfolder.
  etransitivity; [ | apply himp_star_frame; [ reflexivity | apply is_heap_eat ] ].
  do_delegate2 ("self" :: nil).

  (* sAdd *)

  do_abort ("self" :: "n" :: nil).
  do_abort ("self" :: "n" :: nil).
  do_abort ("self" :: "n" :: nil).

  do_delegate1 ("self" :: "n" :: nil) hints.
  add_side_conditions.
  descend; step hints.
  simpl.
  descend; step auto_ext.
  descend; step auto_ext.
  simpl.
  repeat (apply andL || (apply injL; intro) || (apply existsL; intro)); reduce.
  apply get_rval; intro.
  descend; step auto_ext.
  2: returnScalar.
  simpl.
  make_toArray ("self" :: "n" :: nil).
  step auto_ext.
  etransitivity; [ | apply (@is_state_in x2) ].
  unfolder.
  etransitivity; [ | apply himp_star_frame; [ reflexivity | apply readd_FEnsemble ] ].
  do_delegate2 ("self" :: "n" :: nil).

  (* sRemove *)

  do_abort ("self" :: "n" :: nil).
  do_abort ("self" :: "n" :: nil).
  do_abort ("self" :: "n" :: nil).

  do_delegate1 ("self" :: "n" :: nil) hints.
  add_side_conditions.
  descend; step hints.
  simpl.
  descend; step auto_ext.
  descend; step auto_ext.
  simpl.
  repeat (apply andL || (apply injL; intro) || (apply existsL; intro)); reduce.
  apply get_rval; intro.
  descend; step auto_ext.
  2: returnScalar.
  simpl.
  make_toArray ("self" :: "n" :: nil).
  step auto_ext.
  etransitivity; [ | apply (@is_state_in x2) ].
  unfolder.
  etransitivity; [ | apply himp_star_frame; [ reflexivity | apply readd_FEnsemble ] ].
  do_delegate2 ("self" :: "n" :: nil).

  (* sIn *)

  do_abort ("self" :: "n" :: nil).
  do_abort ("self" :: "n" :: nil).
  do_abort ("self" :: "n" :: nil).

  do_delegate1 ("self" :: "n" :: nil) hints.
  add_side_conditions.
  descend; step hints.
  simpl.
  descend; step auto_ext.
  repeat (apply andL || (apply injL; intro) || (apply existsL; intro)); reduce.
  apply get_rval; intro.
  step auto_ext.
  descend; step auto_ext.
  2: rewrite FiniteSetF.Has.has_eq in *; returnSomething; eauto 6.
  simpl.
  make_toArray ("self" :: "n" :: nil).
  step auto_ext.
  etransitivity; [ | apply (@is_state_in x2) ].
  unfolder.
  etransitivity; [ | apply himp_star_frame; [ reflexivity | apply readd_FEnsemble ] ].
  do_delegate2 ("self" :: "n" :: nil).

  (* sSize *)

  do_abort ("self" :: nil).
  do_abort ("self" :: nil).
  do_abort ("self" :: nil).

  do_delegate1 ("self" :: nil) hints.
  descend; step hints.
  repeat (apply andL || (apply injL; intro) || (apply existsL; intro)); reduce.
  apply get_rval; intro.
  destruct H0 as [ ? [ ] ].
  step auto_ext.
  2: returnScalar.
  simpl.
  make_toArray ("self" :: nil).
  step auto_ext.
  etransitivity; [ | apply (@is_state_in x2) ].
  unfolder.
  etransitivity; [ | apply himp_star_frame; [ reflexivity | apply readd_FEnsemble ] ].
  do_delegate2 ("self" :: nil).

  (* ListSeq *)

  (* new *)

  do_abort (@nil string).
  do_abort (@nil string).
  do_abort (@nil string).

  do_delegate1 (@nil string) hints.
  do 2 (descend; step auto_ext).
  2: returnAdt.
  simpl.
  make_toArray (@nil string).
  step auto_ext.
  etransitivity; [ | apply himp_star_frame; [ apply (@is_state_in x4) | reflexivity ] ].
  unfolder.
  do_delegate2 (@nil string).

  (* delete *)

  do_abort ("self" :: nil).
  do_abort ("self" :: nil).
  do_abort ("self" :: nil).

  do_delegate1 ("self" :: nil) hints.
  descend; step auto_ext.
  repeat (apply andL || (apply injL; intro) || (apply existsL; intro)); reduce.
  apply get_rval''; intro.
  descend; step auto_ext.
  2: returnScalar.
  simpl.
  make_toArray ("self" :: nil).
  step auto_ext.
  etransitivity; [ | apply (@is_state_in x2) ].
  unfolder.
  etransitivity; [ | apply himp_star_frame; [ reflexivity | apply is_heap_eat ] ].
  do_delegate2 ("self" :: nil).

  (* pop *)

  do_abort ("self" :: nil).
  do_abort ("self" :: nil).
  do_abort ("self" :: nil).

  do_delegate1 ("self" :: nil) hints.
  repeat (apply andL || (apply injL; intro) || (apply existsL; intro)); reduce.
  apply get_rval; intro.
  descend; step auto_ext.
  descend; step auto_ext.
  2: returnScalar.
  simpl.
  make_toArray ("self" :: nil).
  step auto_ext.
  etransitivity; [ | apply (@is_state_in x2) ].
  unfolder.
  etransitivity; [ | apply himp_star_frame; [ reflexivity | apply readd_List ] ].
  do_delegate2 ("self" :: nil).

  (* empty *)

  do_abort ("self" :: nil).
  do_abort ("self" :: nil).
  do_abort ("self" :: nil).

  do_delegate1 ("self" :: nil) hints.
  repeat (apply andL || (apply injL; intro) || (apply existsL; intro)); reduce.
  apply get_rval; intro.
  step auto_ext.
  descend; step auto_ext.
  2: returnScalar.
  simpl.
  make_toArray ("self" :: nil).
  step auto_ext.
  etransitivity; [ | apply (@is_state_in x2) ].
  unfolder.
  etransitivity; [ | apply himp_star_frame; [ reflexivity | apply readd_List ] ].
  do_delegate2 ("self" :: nil).

  (* push *)

  do_abort ("self" :: "n" :: nil).
  do_abort ("self" :: "n" :: nil).
  do_abort ("self" :: "n" :: nil).

  do_delegate1 ("self" :: "n" :: nil) hints.
  add_side_conditions.
  descend; step hints.
  simpl.
  descend; step auto_ext.
  descend; step auto_ext.
  simpl.
  repeat (apply andL || (apply injL; intro) || (apply existsL; intro)); reduce.
  apply get_rval; intro.
  descend; step auto_ext.
  2: returnScalar.
  simpl.
  make_toArray ("self" :: "n" :: nil).
  step auto_ext.
  etransitivity; [ | apply (@is_state_in x2) ].
  unfolder.
  etransitivity; [ | apply himp_star_frame; [ reflexivity | apply readd_List ] ].
  do_delegate2 ("self" :: "n" :: nil).

  (* copy *)

  do_abort ("self" :: nil).
  do_abort ("self" :: nil).
  do_abort ("self" :: nil).

  do_delegate1 ("self" :: nil) hints.
  descend; step hints.
  simpl.
  descend; step auto_ext.
  2: returnAdt.
  simpl.
  make_toArray ("self" :: nil).
  step auto_ext.
  etransitivity; [ | apply (@is_state_in x2) ].
  unfolder.
  etransitivity; [ | apply himp_star_frame; [ reflexivity | apply readd_List ] ].
  do_delegate2 ("self" :: nil).

  (* rev *)

  do_abort ("self" :: nil).
  do_abort ("self" :: nil).
  do_abort ("self" :: nil).

  do_delegate1 ("self" :: nil) hints.
  descend; step hints.
  simpl.
  repeat (apply andL || (apply injL; intro) || (apply existsL; intro)); reduce.
  apply get_rval; intro.
  descend; step auto_ext.
  2: returnScalar.
  simpl.
  make_toArray ("self" :: nil).
  step auto_ext.
  etransitivity; [ | apply (@is_state_in x2) ].
  unfolder.
  etransitivity; [ | apply himp_star_frame; [ reflexivity | apply readd_List ] ].
  do_delegate2 ("self" :: nil).

  (* length *)

  do_abort ("self" :: nil).
  do_abort ("self" :: nil).
  do_abort ("self" :: nil).

  do_delegate1 ("self" :: nil) hints.
  descend; step hints.
  repeat (apply andL || (apply injL; intro) || (apply existsL; intro)); reduce.
  apply get_rval; intro.
  step auto_ext.
  2: returnScalar.
  simpl.
  make_toArray ("self" :: nil).
  step auto_ext.
  etransitivity; [ | apply (@is_state_in x2) ].
  unfolder.
  etransitivity; [ | apply himp_star_frame; [ reflexivity | apply readd_List ] ].
  do_delegate2 ("self" :: nil).

  Grab Existential Variables.
  exact 0.
  exact 0.
  exact 0.
  exact 0.
  exact 0.
  exact 0.
  exact 0.
  exact 0.
  exact 0.
  exact 0.
Qed.

Definition m1 := link ListSetF.m m0.
Definition m2 := link ListSeqF.m m1.
Definition m := link Malloc.m m2.

Theorem ok1 : moduleOk m1.
  link ListSetF.ok ok0.
Qed.

Theorem ok2 : moduleOk m2.
  link ListSeqF.ok ok1.
Qed.

Theorem ok : moduleOk m.
  link Malloc.ok ok2.
Qed.