Set Implicit Arguments.
Set Maximal Implicit Insertion.
Set Contextual Implicit.

From Coq Require Import
     List
     Psatz
     Relation_Definitions
     RelationClasses
.

Require Import GHC.Base.
Require Import Fix.
Require Import Tactics.Tactics.
Require Import ClassesOfFunctors.FunctorPlus.
Require Import ClassesOfFunctors.DictDerive.

Require Import Adverb.Composable.Adverb.
Require Import Adverb.Composable.Purely.
Require Import Adverb.Composable.Statically.
Require Import Adverb.Composable.Dynamically.

Definition var := nat.

Definition val := nat.

(** * Effect. *)

Variant DataEff (K : Set -> Set) : Set -> Set :=
| GetData : var -> DataEff K val.

Arguments GetData {_}.

Definition fmap1_DataEff {F G : Set -> Set} {A : Set}
           (f : forall X, F X -> G X)
           (a : DataEff F A) : DataEff G A :=
  match a with
  | GetData v => GetData v
  end.

#[global] Program Instance Functor1__DataEff : Functor1 DataEff :=
  {| fmap1 := @fmap1_DataEff |}.
Next Obligation.
  destruct x; reflexivity.
Qed.
Next Obligation.
  destruct x; reflexivity.
Qed.

Section SmartConstructor.

  Variable F : (Set -> Set) -> Set -> Set.
  Context `{Functor1 F}.
  Context `{DataEff -≪ F}.

  Definition getData (x : var) : Fix1 F val :=
    @inF1 _ _ _ (inj1 (GetData x)).

End SmartConstructor.

(** * Adverbs used. *)

Definition LanAdverbs := PurelyAdv ⊕ StaticallyAdv ⊕ DynamicallyAdv ⊕ DataEff.

Definition Lan := Fix1 LanAdverbs.

(** * The Update monad

    As shown in Fig. 14a. *)

Definition Update (A : Set) : Set := ((var -> val) -> A * nat).

Open Scope nat_scope.

Definition retUpdate {A : Set} (a : A) : Update A := fun map => (a, 0).

Definition bindUpdate {A B : Set}
           (m : Update A) (k : A -> Update B) : Update B :=
  fun map =>
    match m map with
    | (i, n) =>
      match (k i map) with
      | (r, n') => (r, n + n')
      end
    end.

Definition parUpdate {A B C : Set}
           (f : A -> B -> C) (a : Update A) (b : Update B) : Update C :=
  fun map =>
    match (a map, b map) with
    | ((a, n1), (b, n2)) => (f a b, Nat.max n1 n2)
    end.

(* [getUpdate] is [get] in Fig. 14a. *)
Definition getUpdate (v : var) : Update val :=
  fun map => (map v, 1).

Goal forall {A B C : Set} (f : A -> B -> C) a b,
    forall m, parUpdate f a b m = parUpdate (flip f) b a m.
Proof.
  intros. unfold parUpdate.
  remember (a m) as am. remember (b m) as bm.
  destruct am; destruct bm. unfold flip.
  f_equal. apply Nat.max_comm.
Qed.

Definition MonadDict__Update : Monad__Dict Update :=
  (* [bindUpdate] is [bind] in Fig. 14a. *)
  {| op_zgzg____ := fun _ _ m k => bindUpdate m (fun _ => k) ;
     op_zgzgze____ := fun _ _ => bindUpdate ;
  (* [retUpdate] is [ret] in Fig. 14a. *)
     return___ := fun _ => retUpdate
  |}.

Definition ApDict__Update : Applicative__Dict Update :=
  (* [parUpdate] is [liftA2] in Fig. 14a. *)
  {| liftA2__ := fun _ _ _ => parUpdate ;
     op_zlztzg____ := fun _ _ => parUpdate id ;
     op_ztzg____ := fun _ _ => parUpdate (fun _ => id) ;
     pure__ := fun _ => retUpdate
  |}.

(** Give a name to [AdverbAlg], a technical way to tell apart
    different adverb interpretations. *)

Definition costName : nat := 0.

(** * Interpreting Composed Adverbs

    Fig. 14b. We define the interpreter of our composed adverb [LanAdverbs] by
    defining an interpretation for each individual adverb and then compose their
    interpretation together (automatically composed via the [AdverbAlgSum]
    instance shown earlier). *)

#[global] Instance CostApp : AdverbAlg StaticallyAdv Update costName :=
  {| adverbAlg := fun _ c =>
                    match c with
                    | LiftA2 f a b =>
                      parUpdate f a b
                    end
  |}.

#[global] Instance CostMonad : AdverbAlg DynamicallyAdv Update costName :=
  {| adverbAlg := fun _ c =>
                    match c with
                    | Bind m k =>
                      bindUpdate m k
                    end
  |}.

#[global] Instance CostPure : AdverbAlg PurelyAdv Update costName :=
  {| adverbAlg := fun _ c =>
                    match c with
                    | Pure a => retUpdate a
                    end
  |}.

#[global] Instance CostData : AdverbAlg DataEff Update costName :=
  {| adverbAlg := fun _ c =>
                    match c in (DataEff _ N) return (Update N) with
                    | GetData v => getUpdate v
                    end
  |}.

(** The composed interpreter. *)

Definition costAlg : Alg1 LanAdverbs Update := adverbAlg (name := costName).

Definition cost {A : Set} : Lan A -> Update A := foldFix1 (@costAlg).

(** * Examples. *)

Definition test1 : Lan bool := liftA2 (fun _ _ => true)
                              (@getData _ _ _ 0)
                              (@getData _ _ _ 1).

Definition test2 : Lan val := (@getData _ _ _ 0) >> (@getData _ _ _ 1).

Definition test3 : Lan bool := liftA2 (fun _ _ => true)
                              (@test2)
                              ((@test1) >> (@test2)).

(** Uncomment the following to see results: *)

(*
Compute (cost (@test1)).

Compute (cost (@test2)).

Compute (cost (@test3)).
*)

(* cost (the second value in the product) of [test1] should be 1 *)
(* cost (the second value in the product) of [test2] should be 2 *)
(* cost (the second value in the product) of [test3] should be 3 *)


(* ** Imports and settings *)
From mathcomp Require Import all_ssreflect all_algebra.
Require Import oseq.
Require Export ZArith Setoid Morphisms.
From mathcomp Require Import word_ssrZ.
Require Export strings word utils type ident var global sem_type sopn syscall.
Require Import xseq.
Import Utf8 ZArith.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Unset Elimination Schemes.

(* ** Operators
 * -------------------------------------------------------------------- *)
(* *** Summary
   Operators represent several constructs in the Ocaml compiler:
   - const-op: compile-time expressions (constexpr in C++)
   - list-op: argument and result lists
   - arr-op: reading and writing arrays
   - cpu-op: CPU instructions such as addition with carry
*)

Variant cmp_kind :=
  | Cmp_int
  | Cmp_w of signedness & wsize.

Variant op_kind :=
  | Op_int
  | Op_w of wsize.

Variant sop1 :=
| Oword_of_int of wsize     (* int → word *)
| Oint_of_word of wsize     (* word → unsigned int *)
| Osignext of wsize & wsize (* Sign-extension: output-size, input-size *)
| Ozeroext of wsize & wsize (* Zero-extension: output-size, input-size *)
| Onot                      (* Boolean negation *)
| Olnot of wsize            (* Bitwize not: 1s’ complement *)
| Oneg  of op_kind          (* Arithmetic negation *)
.

Variant sop2 :=
| Obeq                        (* const : sbool -> sbool -> sbool *)
| Oand                        (* const : sbool -> sbool -> sbool *)
| Oor                         (* const : sbool -> sbool -> sbool *)

| Oadd  of op_kind
| Omul  of op_kind
| Osub  of op_kind
| Odiv  of cmp_kind
| Omod  of cmp_kind

| Oland of wsize
| Olor  of wsize
| Olxor of wsize
| Olsr  of wsize
| Olsl  of op_kind
| Oasr  of op_kind
| Oror  of wsize
| Orol  of wsize

| Oeq   of op_kind
| Oneq  of op_kind
| Olt   of cmp_kind
| Ole   of cmp_kind
| Ogt   of cmp_kind
| Oge   of cmp_kind

(* vector operation *)
| Ovadd of velem & wsize (* VPADD   *)
| Ovsub of velem & wsize (* VPSUB   *)
| Ovmul of velem & wsize (* VPMULLW *)
| Ovlsr of velem & wsize
| Ovlsl of velem & wsize
| Ovasr of velem & wsize
.

(* N-ary operators *)
Variant combine_flags :=
| CF_LT    of signedness   (* Alias : signed => L  ; unsigned => B   *)
| CF_LE    of signedness   (* Alias : signed => LE ; unsigned => BE  *)
| CF_EQ                    (* Alias : E                              *)
| CF_NEQ                   (* Alias : !E                             *)
| CF_GE    of signedness   (* Alias : signed => !L ; unsigned => !B  *)
| CF_GT    of signedness   (* Alias : signed => !LE; unsigned => !BE *)
.

Variant opN :=
| Opack of wsize & pelem (* Pack words of size pelem into one word of wsize *)
| Ocombine_flags of combine_flags
.

Scheme Equality for sop1.
(* Definition sop1_beq : sop1 -> sop1 -> bool *)

Lemma sop1_eq_axiom : Equality.axiom sop1_beq.
Proof.
  move=> x y;apply:(iffP idP).
  + by apply: internal_sop1_dec_bl.
  by apply: internal_sop1_dec_lb.
Qed.

Definition sop1_eqMixin     := Equality.Mixin sop1_eq_axiom.
Canonical  sop1_eqType      := Eval hnf in EqType sop1 sop1_eqMixin.

Scheme Equality for sop2.
(* Definition sop2_beq : sop2 -> sop2 -> bool *)

Lemma sop2_eq_axiom : Equality.axiom sop2_beq.
Proof.
  move=> x y;apply:(iffP idP).
  + by apply: internal_sop2_dec_bl.
  by apply: internal_sop2_dec_lb.
Qed.

Definition sop2_eqMixin     := Equality.Mixin sop2_eq_axiom.
Canonical  sop2_eqType      := Eval hnf in EqType sop2 sop2_eqMixin.

Scheme Equality for opN.

Lemma opN_eq_axiom : Equality.axiom opN_beq.
Proof.
  move=> x y;apply:(iffP idP).
  + by apply: internal_opN_dec_bl.
  by apply: internal_opN_dec_lb.
Qed.

Definition opN_eqMixin     := Equality.Mixin opN_eq_axiom.
Canonical  opN_eqType      := Eval hnf in EqType opN opN_eqMixin.

(* ----------------------------------------------------------------------------- *)

(* Type of unany operators: input, output *)
Definition type_of_op1 (o: sop1) : stype * stype :=
  match o with
  | Oword_of_int sz => (sint, sword sz)
  | Oint_of_word sz => (sword sz, sint)
  | Osignext szo szi
  | Ozeroext szo szi
    => (sword szi, sword szo)
  | Onot => (sbool, sbool)
  | Olnot sz
  | Oneg (Op_w sz)
    => let t := sword sz in (t, t)
  | Oneg Op_int => (sint, sint)
  end.

(* Type of binany operators: inputs, output *)
Definition type_of_op2 (o: sop2) : stype * stype * stype :=
  match o with
  | Obeq | Oand | Oor => (sbool, sbool, sbool)
  | Oadd Op_int
  | Omul Op_int
  | Osub Op_int
  | Odiv Cmp_int | Omod Cmp_int
  | Olsl Op_int | Oasr Op_int
    => (sint, sint, sint)
  | Oadd (Op_w s)
  | Omul (Op_w s)
  | Osub (Op_w s)
  | Odiv (Cmp_w _ s) | Omod (Cmp_w _ s)
  | Oland s | Olor s | Olxor s | Ovadd _ s | Ovsub _ s | Ovmul _ s
    => let t := sword s in (t, t, t)
  | Olsr s | Olsl (Op_w s) | Oasr (Op_w s) | Oror s | Orol s
  | Ovlsr _ s | Ovlsl _ s | Ovasr _ s
    => let t := sword s in (t, sword8, t)
  | Oeq Op_int | Oneq Op_int
  | Olt Cmp_int | Ole Cmp_int
  | Ogt Cmp_int | Oge Cmp_int
    => (sint, sint, sbool)
  | Oeq (Op_w s) | Oneq (Op_w s)
  | Olt (Cmp_w _ s) | Ole (Cmp_w _ s)
  | Ogt (Cmp_w _ s) | Oge (Cmp_w _ s)
    => let t := sword s in (t, t, sbool)
  end.

(* Type of n-ary operators: inputs, output *)

Definition tin_combine_flags := [:: sbool; sbool; sbool; sbool].

Definition type_of_opN (op: opN) : seq stype * stype :=
  match op with
  | Opack ws p =>
    let n := nat_of_wsize ws %/ nat_of_pelem p in
    (nseq n sint, sword ws)
  | Ocombine_flags c => (tin_combine_flags, sbool)
  end.

(* ** Expressions
 * -------------------------------------------------------------------- *)
(* Used only by the ocaml compiler *)
(** A “tag” is a non-empty type, extracted to plain OCaml [int] *)
Module Type TAG.
  Parameter t : Type.
  Parameter witness : t.
End TAG.

Module VarInfo : TAG.
  Definition t := positive.
  Definition witness : t := 1%positive.
End VarInfo.

Definition var_info := VarInfo.t.
Definition dummy_var_info : var_info := VarInfo.witness.

Record var_i := VarI {
  v_var :> var;
  v_info : var_info
}.

Notation vid ident :=
  {|
    v_var :=
      {|
        vtype := sword Uptr;
        vname := ident%string;
      |};
    v_info := dummy_var_info;
  |}.

Variant v_scope :=
  | Slocal
  | Sglob.

Scheme Equality for v_scope.

Lemma v_scope_eq_axiom : Equality.axiom v_scope_beq.
Proof.
  move=> x y;apply:(iffP idP).
  + by apply: internal_v_scope_dec_bl.
  by apply: internal_v_scope_dec_lb.
Qed.

Definition v_scope_eqMixin     := Equality.Mixin v_scope_eq_axiom.
Canonical  v_scope_eqType      := Eval hnf in EqType v_scope v_scope_eqMixin.

Record gvar := Gvar { gv : var_i; gs : v_scope }.

Definition mk_gvar x := {| gv := x; gs := Sglob  |}.
Definition mk_lvar x := {| gv := x; gs := Slocal |}.

Definition is_lvar (x:gvar) := x.(gs) == Slocal.
Definition is_glob (x:gvar) := x.(gs) == Sglob.

Inductive pexpr : Type :=
| Pconst :> Z -> pexpr
| Pbool  :> bool -> pexpr
| Parr_init : positive → pexpr
| Pvar   :> gvar -> pexpr
| Pget   : arr_access -> wsize -> gvar -> pexpr -> pexpr
| Psub   : arr_access -> wsize -> positive -> gvar -> pexpr -> pexpr
| Pload  : wsize -> var_i -> pexpr -> pexpr
| Papp1  : sop1 -> pexpr -> pexpr
| Papp2  : sop2 -> pexpr -> pexpr -> pexpr
| PappN of opN & seq pexpr
| Pif    : stype -> pexpr -> pexpr -> pexpr -> pexpr.

Notation pexprs := (seq pexpr).

Definition Plvar x := Pvar (mk_lvar x).

Definition enot e := Papp1 Onot e.
Definition eor e1 e2 := Papp2 Oor e1 e2.
Definition eand e1 e2 := Papp2 Oand e1 e2.
Definition eeq e1 e2 := Papp2 Obeq e1 e2.
Definition eneq e1 e2 := enot (eeq e1 e2).

(* ** Left values
 * -------------------------------------------------------------------- *)

Variant lval : Type :=
| Lnone `(var_info) `(stype)
| Lvar  `(var_i)
| Lmem  `(wsize) `(var_i) `(pexpr)
| Laset `(arr_access) `(wsize) `(var_i) `(pexpr)
| Lasub `(arr_access) `(wsize) `(positive) `(var_i) `(pexpr).

Coercion Lvar : var_i >-> lval.

Notation lvals := (seq lval).

Definition get_pvar (e: pexpr) : exec var :=
  if e is Pvar {| gv := x ; gs := Slocal |} then ok (v_var x) else type_error.

Definition get_lvar (x: lval) : exec var :=
  if x is Lvar x then ok (v_var x) else type_error.

(* ** Instructions
 * -------------------------------------------------------------------- *)

Variant dir := UpTo | DownTo.

Scheme Equality for dir.

Lemma dir_eq_axiom : Equality.axiom dir_beq.
Proof.
  move=> x y;apply:(iffP idP).
  + by apply: internal_dir_dec_bl.
  by apply: internal_dir_dec_lb.
Qed.

Definition dir_eqMixin     := Equality.Mixin dir_eq_axiom.
Canonical  dir_eqType      := Eval hnf in EqType dir dir_eqMixin.

Definition range := (dir * pexpr * pexpr)%type.

Definition wrange d (n1 n2 : Z) :=
  let n := Z.to_nat (n2 - n1) in
  match d with
  | UpTo   => [seq (Z.add n1 (Z.of_nat i)) | i <- iota 0 n]
  | DownTo => [seq (Z.sub n2 (Z.of_nat i)) | i <- iota 0 n]
  end.

Module InstrInfo : TAG.
  Definition t := positive.
  Definition witness : t := 1%positive.
End InstrInfo.

Definition instr_info := InstrInfo.t.
Definition dummy_instr_info : instr_info := InstrInfo.witness.

Variant assgn_tag :=
  | AT_none       (* assignment introduced by the developer that can be removed *)
  | AT_keep       (* assignment that should be kept by the compiler *)
  | AT_rename     (* equality constraint introduced by inline, used in reg-alloc
                     and compiled to no-op *)
  | AT_inline     (* assignment to be propagated and removed later : introduced
                     by unrolling, inlining or lowering *)
  | AT_phinode    (* renaming during SSA transformation *)
  .

Scheme Equality for assgn_tag.

Lemma assgn_tag_eq_axiom : Equality.axiom assgn_tag_beq.
Proof.
  move=> x y;apply:(iffP idP).
  + by apply: internal_assgn_tag_dec_bl.
  by apply: internal_assgn_tag_dec_lb.
Qed.

Definition assgn_tag_eqMixin     := Equality.Mixin assgn_tag_eq_axiom.
Canonical  assgn_tag_eqType      := Eval hnf in EqType assgn_tag assgn_tag_eqMixin.

(* -------------------------------------------------------------------- *)

Variant inline_info :=
  | InlineFun
  | DoNotInline.

Scheme Equality for inline_info.

Lemma inline_info_eq_axiom : Equality.axiom inline_info_beq.
Proof.
  move=> x y;apply:(iffP idP).
  + by apply: internal_inline_info_dec_bl.
  by apply: internal_inline_info_dec_lb.
Qed.

Definition inline_info_eqMixin     := Equality.Mixin inline_info_eq_axiom.
Canonical  inline_info_eqType      := Eval hnf in EqType inline_info inline_info_eqMixin.

(* -------------------------------------------------------------------- *)

Variant align :=
  | Align
  | NoAlign.

Scheme Equality for align.

Lemma align_eq_axiom : Equality.axiom align_beq.
Proof.
  move=> x y;apply:(iffP idP).
  + by apply: internal_align_dec_bl.
  by apply: internal_align_dec_lb.
Qed.

Definition align_eqMixin     := Equality.Mixin align_eq_axiom.
Canonical  align_eqType      := Eval hnf in EqType align align_eqMixin.

(* -------------------------------------------------------------------- *)

(* ----------------------------------------------------------------------------- *)

Section ASM_OP.

Context `{asmop:asmOp}.

Inductive instr_r :=
| Cassgn   : lval -> assgn_tag -> stype -> pexpr -> instr_r
| Copn     : lvals -> assgn_tag -> sopn -> pexprs -> instr_r
| Csyscall : lvals -> syscall_t -> pexprs -> instr_r
| Cif      : pexpr -> seq instr -> seq instr  -> instr_r
| Cfor     : var_i -> range -> seq instr -> instr_r
| Cwhile   : align -> seq instr -> pexpr -> seq instr -> instr_r
| Ccall    : inline_info -> lvals -> funname -> pexprs -> instr_r

with instr := MkI : instr_info -> instr_r ->  instr.

End ASM_OP.

Notation cmd := (seq instr).

Section CMD_RECT.

  Context `{asmop:asmOp}.

  Variables (Pr:instr_r -> Type) (Pi:instr -> Type) (Pc : cmd -> Type).
  Hypothesis Hmk  : forall i ii, Pr i -> Pi (MkI ii i).
  Hypothesis Hnil : Pc [::].
  Hypothesis Hcons: forall i c, Pi i -> Pc c -> Pc (i::c).
  Hypothesis Hasgn: forall x tg ty e, Pr (Cassgn x tg ty e).
  Hypothesis Hopn : forall xs t o es, Pr (Copn xs t o es).
  Hypothesis Hsyscall : forall xs o es, Pr (Csyscall xs o es).
  Hypothesis Hif  : forall e c1 c2, Pc c1 -> Pc c2 -> Pr (Cif e c1 c2).
  Hypothesis Hfor : forall v dir lo hi c, Pc c -> Pr (Cfor v (dir,lo,hi) c).
  Hypothesis Hwhile : forall a c e c', Pc c -> Pc c' -> Pr (Cwhile a c e c').
  Hypothesis Hcall: forall i xs f es, Pr (Ccall i xs f es).

  Section C.
  Variable instr_rect : forall i, Pi i.

  Fixpoint cmd_rect_aux (c:cmd) : Pc c :=
    match c return Pc c with
    | [::] => Hnil
    | i::c => @Hcons i c (instr_rect i) (cmd_rect_aux c)
    end.
  End C.

  Fixpoint instr_Rect (i:instr) : Pi i :=
    match i return Pi i with
    | MkI ii i => @Hmk i ii (instr_r_Rect i)
    end
  with instr_r_Rect (i:instr_r) : Pr i :=
    match i return Pr i with
    | Cassgn x tg ty e => Hasgn x tg ty e
    | Copn xs t o es => Hopn xs t o es
    | Csyscall xs o es => Hsyscall xs o es
    | Cif e c1 c2  => @Hif e c1 c2 (cmd_rect_aux instr_Rect c1) (cmd_rect_aux instr_Rect c2)
    | Cfor i (dir,lo,hi) c => @Hfor i dir lo hi c (cmd_rect_aux instr_Rect c)
    | Cwhile a c e c'   => @Hwhile a c e c' (cmd_rect_aux instr_Rect c) (cmd_rect_aux instr_Rect c')
    | Ccall ii xs f es => @Hcall ii xs f es
    end.

  Definition cmd_rect := cmd_rect_aux instr_Rect.

End CMD_RECT.

Module FunInfo : TAG.
  Definition t := positive.
  Definition witness : t := 1%positive.
End FunInfo.

Section ASM_OP.

Context `{asmop:asmOp}.

(* ** Functions
 * -------------------------------------------------------------------- *)

Definition fun_info := FunInfo.t.

Class progT (eft:eqType) := {
  extra_prog_t : Type;
  extra_val_t  : Type;
}.

Definition extra_fun_t {eft} {pT: progT eft} := eft.

Record _fundef (extra_fun_t: Type) := MkFun {
  f_info   : fun_info;
  f_tyin   : seq stype;
  f_params : seq var_i;
  f_body   : cmd;
  f_tyout  : seq stype;
  f_res    : seq var_i;
  f_extra  : extra_fun_t;
}.

Definition _fun_decl (extra_fun_t: Type) := (funname * _fundef extra_fun_t)%type.

Record _prog (extra_fun_t: Type) (extra_prog_t: Type):= {
  p_funcs : seq (_fun_decl extra_fun_t);
  p_globs : glob_decls;
  p_extra : extra_prog_t;
}.

Section PROG.

Context {eft} {pT:progT eft}.

Definition fundef := _fundef extra_fun_t.

Definition function_signature : Type :=
  (seq stype * seq stype).

Definition signature_of_fundef (fd: fundef) : function_signature :=
  (f_tyin fd, f_tyout fd).

Definition fun_decl := (funname * fundef)%type.

Definition prog := _prog extra_fun_t extra_prog_t.

Definition Build_prog p_funcs p_globs p_extra : prog := Build__prog p_funcs p_globs p_extra.

End PROG.

End ASM_OP.

Notation fun_decls  := (seq fun_decl).

Section ASM_OP.

Context {pd: PointerData}.
Context `{asmop:asmOp}.

(* ** Programs before stack/memory allocation
 * -------------------------------------------------------------------- *)

Definition progUnit : progT [eqType of unit] :=
  {| extra_val_t := unit;
     extra_prog_t := unit;
  |}.

Definition ufundef     := @fundef _ _ _ progUnit.
Definition ufun_decl   := @fun_decl _ _ _ progUnit.
Definition ufun_decls  := seq (@fun_decl _ _ _ progUnit).
Definition uprog       := @prog _ _ _ progUnit.

(* For extraction *)
Definition _ufundef    := _fundef unit.
Definition _ufun_decl  := _fun_decl unit.
Definition _ufun_decls :=  seq (_fun_decl unit).
Definition _uprog      := _prog unit unit.
Definition to_uprog (p:_uprog) : uprog := p.

(* ** Programs after stack/memory allocation
 * -------------------------------------------------------------------- *)

Variant saved_stack :=
| SavedStackNone
| SavedStackReg of var
| SavedStackStk of Z.

Definition saved_stack_beq (x y : saved_stack) :=
  match x, y with
  | SavedStackNone, SavedStackNone => true
  | SavedStackReg v1, SavedStackReg v2 => v1 == v2
  | SavedStackStk z1, SavedStackStk z2 => z1 == z2
  | _, _ => false
  end.

Lemma saved_stack_eq_axiom : Equality.axiom saved_stack_beq.
Proof.
  move=> [ | v1 | z1] [ | v2 | z2] /=; try by constructor.
  + by apply (iffP eqP); congruence.
  by apply (iffP eqP); congruence.
Qed.

Definition saved_stack_eqMixin   := Equality.Mixin saved_stack_eq_axiom.
Canonical  saved_stack_eqType    := Eval hnf in EqType saved_stack saved_stack_eqMixin.

Variant return_address_location :=
| RAnone
| RAreg of var               (* The return address is pass by a register and
                                keeped in this register during function call *)
| RAstack of option var & Z. (* None means that the call instruction directly store ra on the stack
                                Some r means that the call instruction directly store ra on r and
                                the function should store r on the stack *)

Definition return_address_location_beq (r1 r2: return_address_location) : bool :=
  match r1 with
  | RAnone => if r2 is RAnone then true else false
  | RAreg x1 => if r2 is RAreg x2 then x1 == x2 else false
  | RAstack lr1 z1 => if r2 is RAstack lr2 z2 then (lr1 == lr2) && (z1 == z2) else false
  end.

Lemma return_address_location_eq_axiom : Equality.axiom return_address_location_beq.
Proof.
  case => [ | x1 | lr1 z1 ] [ | x2 | lr2 z2 ] /=; try by constructor.
  + by apply (iffP eqP); congruence.
  by apply (iffP andP) => [ []/eqP-> /eqP-> | []-> ->].
Qed.

Definition return_address_location_eqMixin := Equality.Mixin return_address_location_eq_axiom.
Canonical  return_address_location_eqType  := Eval hnf in EqType return_address_location return_address_location_eqMixin.

Record stk_fun_extra := MkSFun {
  sf_align          : wsize;
  sf_stk_sz         : Z;
  sf_stk_ioff       : Z;
  sf_stk_extra_sz   : Z;
  sf_stk_max        : Z;
  sf_max_call_depth : Z;
  sf_to_save        : seq (var * Z);
  sf_save_stack     : saved_stack;
  sf_return_address : return_address_location;
}.

Definition sfe_beq (e1 e2: stk_fun_extra) : bool :=
  (e1.(sf_align) == e2.(sf_align)) &&
  (e1.(sf_stk_sz) == e2.(sf_stk_sz)) &&
  (e1.(sf_stk_ioff) == e2.(sf_stk_ioff)) &&
  (e1.(sf_stk_max) == e2.(sf_stk_max)) &&
  (e1.(sf_max_call_depth) == e2.(sf_max_call_depth)) &&
  (e1.(sf_stk_extra_sz) == e2.(sf_stk_extra_sz)) &&
  (e1.(sf_to_save) == e2.(sf_to_save)) &&
  (e1.(sf_save_stack) == e2.(sf_save_stack)) &&
  (e1.(sf_return_address) == e2.(sf_return_address)).

Lemma sfe_eq_axiom : Equality.axiom sfe_beq.
Proof.
  case => a b c d e f g h i [] a' b' c' d' e' f' g' h' i'; apply: (equivP andP) => /=; split.
  + by case => /andP[] /andP[] /andP[] /andP[] /andP[] /andP[] /andP[] /eqP <- /eqP <- /eqP <- /eqP <- /eqP <- /eqP <- /eqP <- /eqP <- /eqP <-.
  by case => <- <- <- <- <- <- <- <- <-; rewrite !eqxx.
Qed.

Definition sfe_eqMixin   := Equality.Mixin sfe_eq_axiom.
Canonical  sfe_eqType    := Eval hnf in EqType stk_fun_extra sfe_eqMixin.

Record sprog_extra := {
  sp_rsp   : Ident.ident;
  sp_rip   : Ident.ident;
  sp_globs : seq u8;
}.

Definition progStack : progT [eqType of stk_fun_extra] :=
  {| extra_val_t := pointer;
     extra_prog_t := sprog_extra  |}.

Definition sfundef     := @fundef _ _ _ progStack.
Definition sfun_decl   := @fun_decl _ _ _ progStack.
Definition sfun_decls  := seq (@fun_decl _ _ _ progStack).
Definition sprog       := @prog _ _ _ progStack.

(* For extraction *)

Definition _sfundef    := _fundef stk_fun_extra.
Definition _sfun_decl  := _fun_decl stk_fun_extra.
Definition _sfun_decls := seq (_fun_decl stk_fun_extra).
Definition _sprog      := _prog stk_fun_extra sprog_extra.
Definition to_sprog (p:_sprog) : sprog := p.

(* Update functions *)
Definition with_body eft (fd:_fundef eft) body := {|
  f_info   := fd.(f_info);
  f_tyin   := fd.(f_tyin);
  f_params := fd.(f_params);
  f_body   := body;
  f_tyout  := fd.(f_tyout);
  f_res    := fd.(f_res);
  f_extra  := fd.(f_extra);
|}.

Definition swith_extra {_: PointerData} (fd:ufundef) f_extra : sfundef := {|
  f_info   := fd.(f_info);
  f_tyin   := fd.(f_tyin);
  f_params := fd.(f_params);
  f_body   := fd.(f_body);
  f_tyout  := fd.(f_tyout);
  f_res    := fd.(f_res);
  f_extra  := f_extra;
|}.

End ASM_OP.

Section ASM_OP.

Context `{asmop:asmOp}.
Context {eft} {pT : progT eft}.

(* ** Some smart constructors
 * -------------------------------------------------------------------------- *)

Definition is_const (e:pexpr) :=
  match e with
  | Pconst n => Some n
  | _        => None
  end.

Definition is_bool (e:pexpr) :=
  match e with
  | Pbool b => Some b
  | _ => None
  end.

Fixpoint cast_w ws (e: pexpr) : pexpr :=
  match e with
  | Papp2 (Oadd Op_int) e1 e2 =>
      let: e1 := cast_w ws e1 in
      let: e2 := cast_w ws e2 in
      Papp2 (Oadd (Op_w ws)) e1 e2
  | Papp2 (Osub Op_int) e1 e2 =>
      let: e1 := cast_w ws e1 in
      let: e2 := cast_w ws e2 in
      Papp2 (Osub (Op_w ws)) e1 e2
  | Papp2 (Omul Op_int) e1 e2 =>
      let: e1 := cast_w ws e1 in
      let: e2 := cast_w ws e2 in
      Papp2 (Omul (Op_w ws)) e1 e2
  | Papp1 (Oneg Op_int) e' =>
      let: e' := cast_w ws e' in
      Papp1 (Oneg (Op_w ws)) e'
  | Papp1 (Oint_of_word ws') e' =>
      if (ws ≤ ws')%CMP then e'
      else Papp1 (Oword_of_int ws) e
  | _ => Papp1 (Oword_of_int ws) e
  end.

Section WITH_POINTER_DATA.
Context {pd: PointerData}.

Definition cast_ptr := cast_w Uptr.

Definition cast_const z := cast_ptr (Pconst z).

End WITH_POINTER_DATA.

Definition eword_of_int (ws : wsize) (x : Z) : pexpr :=
  Papp1 (Oword_of_int ws) (Pconst x).

Definition wconst (sz: wsize) (n: word sz) : pexpr :=
  Papp1 (Oword_of_int sz) (Pconst (wunsigned n)).

Definition is_wconst (sz: wsize) (e: pexpr) : option (word sz) :=
  match e with
  | Papp1 (Oword_of_int sz') e =>
    if (sz <= sz')%CMP then
      is_const e >>= λ n, Some (zero_extend sz (wrepr sz' n))
    else None
  | _       => None
  end%O.

Definition is_wconst_of_size sz (e: pexpr) : option Z :=
  match e with
  | Papp1 (Oword_of_int sz') (Pconst z) =>
    if sz' == sz then Some z else None
  | _ => None end.

(* ** Compute written variables
 * -------------------------------------------------------------------- *)

Definition vrv_rec (s:Sv.t) (rv:lval) :=
  match rv with
  | Lnone _ _  => s
  | Lvar  x    => Sv.add x s
  | Lmem _ _ _  => s
  | Laset _ _ x _  => Sv.add x s
  | Lasub _ _ _ x _ => Sv.add x s
  end.

Definition vrvs_rec s (rv:lvals) := foldl vrv_rec s rv.

Definition vrv := (vrv_rec Sv.empty).
Definition vrvs := (vrvs_rec Sv.empty).

Definition lv_write_mem (r:lval) : bool :=
  if r is Lmem _ _ _ then true else false.

Fixpoint write_i_rec s (i:instr_r) :=
  match i with
  | Cassgn x _ _ _  => vrv_rec s x
  | Copn xs _ _ _   => vrvs_rec s xs
  | Csyscall xs _ _ => vrvs_rec s xs
  | Cif   _ c1 c2   => foldl write_I_rec (foldl write_I_rec s c2) c1
  | Cfor  x _ c     => foldl write_I_rec (Sv.add x s) c
  | Cwhile _ c _ c' => foldl write_I_rec (foldl write_I_rec s c') c
  | Ccall _ x _ _   => vrvs_rec s x
  end
with write_I_rec s i :=
  match i with
  | MkI _ i => write_i_rec s i
  end.

Definition write_i i := write_i_rec Sv.empty i.

Definition write_I i := write_I_rec Sv.empty i.

Definition write_c_rec s c := foldl write_I_rec s c.

Definition write_c c := write_c_rec Sv.empty c.

(* ** Compute read variables
 * -------------------------------------------------------------------- *)

Definition read_gvar (x:gvar) :=
  if is_lvar x then Sv.singleton x.(gv)
  else Sv.empty.

Fixpoint read_e_rec (s:Sv.t) (e:pexpr) : Sv.t :=
  match e with
  | Pconst _
  | Pbool  _
  | Parr_init _    => s
  | Pvar   x       => Sv.union (read_gvar x) s
  | Pget _ _ x e   => read_e_rec (Sv.union (read_gvar x) s) e
  | Psub _ _ _ x e => read_e_rec (Sv.union (read_gvar x) s) e
  | Pload _ x e    => read_e_rec (Sv.add x s) e
  | Papp1  _ e     => read_e_rec s e
  | Papp2  _ e1 e2 => read_e_rec (read_e_rec s e2) e1
  | PappN _ es     => foldl read_e_rec s es
  | Pif  _ t e1 e2 => read_e_rec (read_e_rec (read_e_rec s e2) e1) t
  end.

Definition read_e := read_e_rec Sv.empty.
Definition read_es_rec := foldl read_e_rec.
Definition read_es := read_es_rec Sv.empty.

Definition read_rv_rec  (s:Sv.t) (r:lval) :=
  match r with
  | Lnone _ _     => s
  | Lvar  _       => s
  | Lmem _ x e    => read_e_rec (Sv.add x s) e
  | Laset _ _ x e => read_e_rec (Sv.add x s) e
  | Lasub _ _ _ x e => read_e_rec (Sv.add x s) e
  end.

Definition read_rv := read_rv_rec Sv.empty.
Definition read_rvs_rec := foldl read_rv_rec.
Definition read_rvs := read_rvs_rec Sv.empty.

Fixpoint read_i_rec (s:Sv.t) (i:instr_r) : Sv.t :=
  match i with
  | Cassgn x _ _ e => read_rv_rec (read_e_rec s e) x
  | Copn xs _ _ es => read_es_rec (read_rvs_rec s xs) es
  | Csyscall xs _ es => read_es_rec (read_rvs_rec s xs) es
  | Cif b c1 c2 =>
    let s := foldl read_I_rec s c1 in
    let s := foldl read_I_rec s c2 in
    read_e_rec s b
  | Cfor x (dir, e1, e2) c =>
    let s := foldl read_I_rec s c in
    read_e_rec (read_e_rec s e2) e1
  | Cwhile a c e c' =>
    let s := foldl read_I_rec s c in
    let s := foldl read_I_rec s c' in
    read_e_rec s e
  | Ccall _ xs _ es => read_es_rec (read_rvs_rec s xs) es
  end
with read_I_rec (s:Sv.t) (i:instr) : Sv.t :=
  match i with
  | MkI _ i => read_i_rec s i
  end.

Definition read_c_rec := foldl read_I_rec.

Definition read_i := read_i_rec Sv.empty.

Definition read_I := read_I_rec Sv.empty.

Definition read_c := read_c_rec Sv.empty.

(* ** Compute occurring variables (= read + write)
 * -------------------------------------------------------------------------- *)

Definition vars_I (i: instr) := Sv.union (read_I i) (write_I i).

Definition vars_c c := Sv.union (read_c c) (write_c c).

Definition vars_lval l := Sv.union (read_rv l) (vrv l).

Definition vars_lvals ls := Sv.union (read_rvs ls) (vrvs ls).

Fixpoint vars_l (l: seq var_i) :=
  match l with
  | [::] => Sv.empty
  | h :: q => Sv.add h (vars_l q)
  end.

Definition vars_fd (fd:fundef) :=
  Sv.union (vars_l fd.(f_params)) (Sv.union (vars_l fd.(f_res)) (vars_c fd.(f_body))).

Definition vars_p (p: fun_decls) :=
  foldr (fun f x => let '(fn, fd) := f in Sv.union x (vars_fd fd)) Sv.empty p.

End ASM_OP.

(* --------------------------------------------------------------------- *)
(* Test the equality of two expressions modulo variable info             *)

Definition eq_gvar x x' :=
  (x.(gs) == x'.(gs)) && (v_var x.(gv) == v_var x'.(gv)).

Fixpoint eq_expr e e' :=
  match e, e' with
  | Pconst z      , Pconst z'         => z == z'
  | Pbool  b      , Pbool  b'         => b == b'
  | Parr_init n   , Parr_init n'      => n == n'
  | Pvar   x      , Pvar   x'         => eq_gvar x x'
  | Pget aa w x e , Pget aa' w' x' e' => (aa==aa') && (w == w') && (eq_gvar x x') && eq_expr e e'
  | Psub aa w len x e , Psub aa' w' len' x' e' => (aa==aa') && (w == w') && (len == len') && (eq_gvar x x') && eq_expr e e'
  | Pload w x e, Pload w' x' e' => (w == w') && (v_var x == v_var x') && eq_expr e e'
  | Papp1  o e    , Papp1  o' e'      => (o == o') && eq_expr e e'
  | Papp2  o e1 e2, Papp2  o' e1' e2' => (o == o') && eq_expr e1 e1' && eq_expr e2 e2'
  | PappN o es, PappN o' es' => (o == o') && (all2 eq_expr es es')
  | Pif t e e1 e2, Pif t' e' e1' e2' =>
    (t == t') && eq_expr e e' && eq_expr e1 e1' && eq_expr e2 e2'
  | _             , _                 => false
  end.

(* ------------------------------------------------------------------- *)
Definition to_lvals (l:seq var) : seq lval :=
  map (fun x => Lvar {|v_var := x; v_info := dummy_var_info |}) l.

(* ------------------------------------------------------------------- *)
Definition is_false (e: pexpr) : bool :=
  if e is Pbool false then true else false.

Definition is_zero sz (e: pexpr) : bool :=
  if e is Papp1 (Oword_of_int sz') (Pconst Z0) then sz' == sz else false.

Notation copn_args := (seq lval * sopn * seq pexpr)%type (only parsing).


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Compile-time evaluation of initializers for global C variables. *)

Require Import Coqlib Maps Errors.
Require Import Integers Floats Values AST Memory Globalenvs.
Require Import Ctypes Cop Csyntax.

Open Scope error_monad_scope.

(** * Evaluation of compile-time constant expressions *)

(** To evaluate constant expressions at compile-time, we use the same [value]
  type and the same [sem_*] functions that are used in CompCert C's semantics
  (module [Csem]).  However, we interpret pointer values symbolically:
  [Vptr id ofs] represents the address of global variable [id]
  plus byte offset [ofs]. *)

(** [constval a] evaluates the constant expression [a].

If [a] is a r-value, the returned value denotes:
- [Vint n], [Vlong n], [Vfloat f], [Vsingle f]: the corresponding number
- [Vptr id ofs]: address of global variable [id] plus byte offset [ofs]
- [Vundef]: erroneous expression

If [a] is a l-value, the returned value denotes:
- [Vptr id ofs]: global variable [id] plus byte offset [ofs]
*)

Definition do_cast (v: val) (t1 t2: type) : res val :=
  match sem_cast v t1 t2 Mem.empty with
  | Some v' => OK v'
  | None => Error(msg "undefined cast")
  end.

Definition lookup_composite (ce: composite_env) (id: ident) : res composite :=
  match ce!id with
  | Some co => OK co
  | None => Error (MSG "Undefined struct or union " :: CTX id :: nil)
  end.

Fixpoint constval (ce: composite_env) (a: expr) : res val :=
  match a with
  | Eval v ty =>
      match v with
      | Vint _ | Vfloat _ | Vsingle _ | Vlong _ => OK v
      | Vptr _ _ | Vundef => Error(msg "illegal constant")
      end
  | Evalof l ty =>
      match access_mode ty with
      | By_reference | By_copy => constval ce l
      | _ => Error(msg "dereferencing of an l-value")
      end
  | Eaddrof l ty =>
      constval ce l
  | Eunop op r1 ty =>
      do v1 <- constval ce r1;
      match sem_unary_operation op v1 (typeof r1) Mem.empty with
      | Some v => OK v
      | None => Error(msg "undefined unary operation")
      end
  | Ebinop op r1 r2 ty =>
      do v1 <- constval ce r1;
      do v2 <- constval ce r2;
      match sem_binary_operation ce op v1 (typeof r1) v2 (typeof r2) Mem.empty with
      | Some v => OK v
      | None => Error(msg "undefined binary operation")
      end
  | Ecast r ty =>
      do v1 <- constval ce r; do_cast v1 (typeof r) ty
  | Esizeof ty1 ty =>
      OK (Vptrofs (Ptrofs.repr (sizeof ce ty1)))
  | Ealignof ty1 ty =>
      OK (Vptrofs (Ptrofs.repr (alignof ce ty1)))
  | Eseqand r1 r2 ty =>
      do v1 <- constval ce r1;
      do v2 <- constval ce r2;
      match bool_val v1 (typeof r1) Mem.empty with
      | Some true => do_cast v2 (typeof r2) type_bool
      | Some false => OK (Vint Int.zero)
      | None => Error(msg "undefined && operation")
      end
  | Eseqor r1 r2 ty =>
      do v1 <- constval ce r1;
      do v2 <- constval ce r2;
      match bool_val v1 (typeof r1) Mem.empty with
      | Some false => do_cast v2 (typeof r2) type_bool
      | Some true => OK (Vint Int.one)
      | None => Error(msg "undefined || operation")
      end
  | Econdition r1 r2 r3 ty =>
      do v1 <- constval ce r1;
      do v2 <- constval ce r2;
      do v3 <- constval ce r3;
      match bool_val v1 (typeof r1) Mem.empty with
      | Some true => do_cast v2 (typeof r2) ty
      | Some false => do_cast v3 (typeof r3) ty
      | None => Error(msg "condition is undefined")
      end
  | Ecomma r1 r2 ty =>
      do v1 <- constval ce r1; constval ce r2
  | Evar x ty =>
      OK(Vptr x Ptrofs.zero)
  | Ederef r ty =>
      constval ce r
  | Efield l f ty =>
      do (delta, bf) <-
        match typeof l with
        | Tstruct id _ =>
            do co <- lookup_composite ce id; field_offset ce f (co_members co)
        | Tunion id _ =>
            do co <- lookup_composite ce id; union_field_offset ce f (co_members co)
        | _ =>
            Error (msg "ill-typed field access")
        end;
      do v <- constval ce l;
      match bf with
      | Full =>
          OK (if Archi.ptr64
              then Val.addl v (Vlong (Int64.repr delta))
              else Val.add v (Vint (Int.repr delta)))
      | Bits _ _ _ _ =>
          Error(msg "taking the address of a bitfield")
      end
  | Eparen r tycast ty =>
      do v <- constval ce r; do_cast v (typeof r) tycast
  | _ =>
    Error(msg "not a compile-time constant")
  end.

(** [constval_cast ce a ty] evaluates [a] then converts its value to type [ty]. *)

Definition constval_cast (ce: composite_env) (a: expr) (ty: type): res val :=
  do v <- constval ce a; do_cast v (typeof a) ty.

(** * Building and recording initialization data *)

(** The following [state] type is the output of the translation of
    initializers.  It contains the list of initialization data
    generated so far, the corresponding position in bytes, and the
    total size expected for the final initialization data, in bytes. *)

Record state : Type := {
  init: list init_data;      (**r reversed *)
  curr: Z;                   (**r current position for head of [init] *)
  total_size: Z              (**r total expected size *)
}.

(** A state [s] can also be viewed as a memory block.  The size of
    the block is [s.(total_size)], it is initialized with zero bytes,
    then filled with the initialization data [rev s.(init)] like
    [Genv.store_init_data_list] does. *)

Definition initial_state (sz: Z) : state :=
  {| init := nil; curr := 0; total_size := sz |}.

(** We now define abstract "store" operations that operate
    directly on the state, but whose behavior mimic those of
    storing in the corresponding memory block.  To initialize
    bitfields, we also need an abstract "load" operation.
    The operations are optimized for stores that occur at increasing
    positions, like those that take place during initialization. *)

(** Initialization from bytes *)

Definition int_of_byte (b: byte) := Int.repr (Byte.unsigned b).

Definition Init_byte (b: byte) := Init_int8 (int_of_byte b).

(** Add a list of bytes to a reversed initialization data list. *)

Fixpoint add_rev_bytes (l: list byte) (il: list init_data) :=
  match l with
  | nil => il
  | b :: l => add_rev_bytes l (Init_byte b :: il)
  end.

(** Add [n] zero bytes to an initialization data list. *)

Definition add_zeros (n: Z) (il: list init_data) :=
  Z.iter n (fun l => Init_int8 Int.zero :: l) il.

(** Make sure the [depth] positions at the top of [il] are bytes,
    that is, [Init_int8] items.  Other numerical items are split
    into bytes.  [Init_addrof] items cannot be split and result in
    an error. *)

Fixpoint normalize (il: list init_data) (depth: Z) : res (list init_data) :=
  if zle depth 0 then OK il else
    match il with
    | nil =>
        Error (msg "normalize: empty list")
    | Init_int8 n :: il =>
        do il' <- normalize il (depth - 1);
        OK (Init_int8 n :: il')
    | Init_int16 n :: il =>
        do il' <- normalize il (depth - 2);
        OK (add_rev_bytes (encode_int 2%nat (Int.unsigned n)) il')
    | Init_int32 n :: il =>
        do il' <- normalize il (depth - 4);
        OK (add_rev_bytes (encode_int 4%nat (Int.unsigned n)) il')
    | Init_int64 n :: il =>
        do il' <- normalize il (depth - 8);
        OK (add_rev_bytes (encode_int 8%nat (Int64.unsigned n)) il')
    | Init_float32 f :: il =>
        do il' <- normalize il (depth - 4);
        OK (add_rev_bytes (encode_int 4%nat (Int.unsigned (Float32.to_bits f))) il')
    | Init_float64 f :: il =>
        do il' <- normalize il (depth - 8);
        OK (add_rev_bytes (encode_int 8%nat (Int64.unsigned (Float.to_bits f))) il')
    | Init_addrof _ _ :: il =>
        Error (msg "normalize: Init_addrof")
    | Init_space n :: il =>
        let n := Z.max 0 n in
        if zle n depth then
          do il' <- normalize il (depth - n);
          OK (add_zeros n il')
        else
          OK (add_zeros depth (Init_space (n - depth) :: il))
    end.

(** Split [il] into [depth] bytes and the initialization list that follows.
    The bytes are returned reversed. *)

Fixpoint decompose_rec (accu: list byte) (il: list init_data) (depth: Z) : res (list byte * list init_data) :=
  if zle depth 0 then OK (accu, il) else
    match il with
    | Init_int8 n :: il => decompose_rec (Byte.repr (Int.unsigned n) :: accu) il (depth - 1)
    | _ => Error (msg "decompose: wrong shape")
    end.

Definition decompose (il: list init_data) (depth: Z) : res (list byte * list init_data) :=
  decompose_rec nil il depth.

(** Decompose an initialization list in three parts:
    [depth] bytes (reversed), [sz] bytes (reversed),
    and the remainder of the initialization list. *)

Definition trisection (il: list init_data) (depth sz: Z) : res (list byte * list byte * list init_data) :=
  do il0 <- normalize il (depth + sz);
  do (bytes1, il1) <- decompose il0 depth;
  do (bytes2, il2) <- decompose il1 sz;
  OK (bytes1, bytes2, il2).

(** Graphically: [rev il] is equal to
<<
                 <---sz---><--depth-->
+----------------+---------+---------+
|                |         |         |
+----------------+---------+---------+
    rev il2         bytes2    bytes1
>>
*)

(** Add padding if necessary so that position [pos] is within the state. *)

Definition pad_to (s: state) (pos: Z) : state :=
  if zle pos s.(curr)
  then s
  else {| init := Init_space (pos - s.(curr)) :: s.(init);
          curr := pos;
          total_size := s.(total_size) |}.

(** Store the initialization data [i] at position [pos] in state [s]. *)

Definition store_data (s: state) (pos: Z) (i: init_data) : res state :=
  let sz := init_data_size i in
  assertion (zle 0 pos && zle (pos + sz) s.(total_size));
  if zle s.(curr) pos then
    OK {| init := i :: (if zlt s.(curr) pos
                        then Init_space (pos - s.(curr)) :: s.(init)
                        else s.(init));
          curr := pos + sz;
          total_size := s.(total_size) |}
  else
    let s' := pad_to s (pos + sz) in
    do x3 <- trisection s'.(init) (s'.(curr) - (pos + sz)) sz;
    let '(bytes1, _, il2) := x3 in
    OK {| init := add_rev_bytes bytes1 (i :: il2);
          curr := s'.(curr);
          total_size := s'.(total_size) |}.

(** Store the integer [n] of size [isz] at position [pos] in state [s]. *)

Definition init_data_for_carrier (isz: intsize) (n: int) :=
  match isz with
  | I8 | IBool => Init_int8 n
  | I16 => Init_int16 n
  | I32 => Init_int32 n
  end.

Definition store_int (s: state) (pos: Z) (isz: intsize) (n: int) : res state :=
  store_data s pos (init_data_for_carrier isz n).

(** Load the integer of size [isz] at position [pos] in state [s]. *)

Definition load_int (s: state) (pos: Z) (isz: intsize) : res int :=
  let chunk := chunk_for_carrier isz in
  let sz := size_chunk chunk in
  assertion (zle 0 pos && zle (pos + sz) s.(total_size));
  let s' := pad_to s (pos + sz) in
  do x3 <- trisection s'.(init) (s'.(curr) - (pos + sz)) sz;
  let '(_, bytes2, _) := x3 in
  OK (Int.repr (decode_int bytes2)).

(** Extract the final initialization data from a state. *)

Definition init_data_list_of_state (s: state) : res (list init_data) :=
  assertion (zle s.(curr) s.(total_size));
  let s' := pad_to s s.(total_size) in
  OK (List.rev' s'.(init)).

(** * Translation of initializers *)

Inductive initializer :=
  | Init_single (a: expr)
  | Init_array (il: initializer_list)
  | Init_struct (il: initializer_list)
  | Init_union (f: ident) (i: initializer)
with initializer_list :=
  | Init_nil
  | Init_cons (i: initializer) (il: initializer_list).

Definition length_initializer_list (il: initializer_list) :=
  let fix length (accu: Z) (il: initializer_list) : Z :=
    match il with Init_nil => accu | Init_cons _ il => length (Z.succ accu) il end
  in length 0 il.

(** Translate an initializing expression [a] for a scalar variable
  of type [ty].  Return the corresponding initialization datum. *)

Definition transl_init_single (ce: composite_env) (ty: type) (a: expr) : res init_data :=
  do v <- constval_cast ce a ty;
  match v, ty with
  | Vint n, Tint (I8|IBool) sg _ => OK(Init_int8 n)
  | Vint n, Tint I16 sg _ => OK(Init_int16 n)
  | Vint n, Tint I32 sg _ => OK(Init_int32 n)
  | Vint n, Tpointer _ _ => assertion (negb Archi.ptr64); OK(Init_int32 n)
  | Vlong n, Tlong _ _ => OK(Init_int64 n)
  | Vlong n, Tpointer _ _ => assertion (Archi.ptr64); OK(Init_int64 n)
  | Vsingle f, Tfloat F32 _ => OK(Init_float32 f)
  | Vfloat f, Tfloat F64 _ => OK(Init_float64 f)
  | Vptr id ofs, Tint I32 sg _ => assertion (negb Archi.ptr64); OK(Init_addrof id ofs)
  | Vptr id ofs, Tlong _ _ => assertion (Archi.ptr64); OK(Init_addrof id ofs)
  | Vptr id ofs, Tpointer _ _ => OK(Init_addrof id ofs)
  | Vundef, _ => Error(msg "undefined operation in initializer")
  | _, _ => Error (msg "type mismatch in initializer")
  end.

(** Initialize a bitfield [Bits sz sg p w] with expression [a]. *)

Definition transl_init_bitfield (ce: composite_env) (s: state)
                                (ty: type) (sz: intsize) (p w: Z)
                                (i: initializer) (pos: Z) : res state :=
  match i with
  | Init_single a =>
      do v <- constval_cast ce a ty;
      match v with
      | Vint n =>
          do c <- load_int s pos sz;
          let c' := Int.bitfield_insert (first_bit sz p w) w c n in
          store_int s pos sz c'
      | Vundef =>
          Error (msg "undefined operation in bitfield initializer")
      | _ =>
          Error (msg "type mismatch in bitfield initializer")
      end
  | _ =>
      Error (msg "bitfield initialized by composite initializer")
  end.

(** Padding bitfields and bitfields with zero width are not initialized. *)

Definition member_not_initialized (m: member) : bool :=
  match m with
  | Member_plain _ _ => false
  | Member_bitfield _ _ _ _ w p => p || zle w 0
  end.

(** Translate an initializer [i] for a variable of type [ty]
    and store the corresponding list of initialization data in state [s]
    at position [pos].  Return the updated state. *)

Fixpoint transl_init_rec (ce: composite_env) (s: state)
                         (ty: type) (i: initializer) (pos: Z)
                         {struct i} : res state :=
  match i, ty with
  | Init_single a, _ =>
      do d <- transl_init_single ce ty a; store_data s pos d
  | Init_array il, Tarray tyelt nelt _ =>
      assertion (zle (length_initializer_list il) (Z.max 0 nelt));
      transl_init_array ce s tyelt il pos
  | Init_struct il, Tstruct id _ =>
      do co <- lookup_composite ce id;
      match co_su co with
      | Struct => transl_init_struct ce s (co_members co) il pos 0
      | Union  => Error (MSG "struct/union mismatch on " :: CTX id :: nil)
      end
  | Init_union f i1, Tunion id _ =>
      do co <- lookup_composite ce id;
      match co_su co with
      | Struct => Error (MSG "union/struct mismatch on " :: CTX id :: nil)
      | Union =>  do ty1 <- field_type f (co_members co);
                  do (delta, layout) <- union_field_offset ce f (co_members co);
                  match layout with
                  | Full =>
                      transl_init_rec ce s ty1 i1 (pos + delta)
                  | Bits sz sg p w =>
                      transl_init_bitfield ce s ty1 sz p w i1 (pos + delta)
                  end
      end
  | _, _ =>
      Error (msg "wrong type for compound initializer")
  end

with transl_init_array (ce: composite_env) (s: state)
                       (tyelt: type) (il: initializer_list) (pos: Z)
                       {struct il} : res state :=
  match il with
  | Init_nil =>
      OK s
  | Init_cons i1 il' =>
      do s1 <- transl_init_rec ce s tyelt i1 pos;
      transl_init_array ce s1 tyelt il' (pos + sizeof ce tyelt)
  end

with transl_init_struct (ce: composite_env) (s: state)
                        (ms: members) (il: initializer_list)
                        (base: Z) (pos: Z)
                        {struct il} : res state :=
  match il with
  | Init_nil =>
      OK s
  | Init_cons i1 il' =>
      let fix init (ms: members) (pos: Z) {struct ms} : res state :=
        match ms with
        | nil =>
            Error (msg "too many elements in struct initializer")
        | m :: ms' =>
            if member_not_initialized m then
              init ms' (next_field ce pos m)
            else
              do (delta, layout) <- layout_field ce pos m;
              do s1 <-
                match layout with
                | Full =>
                    transl_init_rec ce s (type_member m) i1 (base + delta)
                | Bits sz sg p w =>
                    transl_init_bitfield ce s (type_member m) sz p w i1 (base + delta)
                end;
                transl_init_struct ce s1 ms' il' base (next_field ce pos m)
         end in
      init ms pos
  end.

(** The entry point. *)

Definition transl_init (ce: composite_env) (ty: type) (i: initializer)
                       : res (list init_data) :=
  let s0 := initial_state (sizeof ce ty) in
  do s1 <- transl_init_rec ce s0 ty i 0;
  init_data_list_of_state s1.