(* Instruction selection and choice of evaluation order. *)

open Misc
open Cmm
open Mach

type expression =
    Sconst of Cmm.constant
  | Svar of Ident.t
  | Slet of Ident.t * expression * expression
  | Sassign of Ident.t * expression
  | Stuple of expression array * int list
  | Sop of operation * expression * Cmm.machtype
  | Sproj of expression * int * int
  | Ssequence of expression * expression
  | Sifthenelse of test * expression * expression * expression
  | Sswitch of expression * int array * expression array
  | Sloop of expression
  | Scatch of expression * expression
  | Sexit
  | Strywith of expression * Ident.t * expression
  | Sraise of expression

(* Infer the type of the result of an operation *)

let oper_result_type = function
    Capply ty -> ty
  | Cextcall(s, ty) -> ty
  | Cload ty -> ty
  | Cloadchunk c -> typ_int
  | Calloc -> typ_addr
  | Cstore -> typ_void
  | Cstorechunk c -> typ_void
  | Cmodify -> typ_void
  | Caddi | Csubi | Cmuli | Cdivi | Cmodi
  | Cand | Cor | Cxor | Clsl | Clsr | Casr
  | Ccmpi _ | Ccmpa _ | Ccmpf _ -> typ_int
  | Cadda | Csuba -> typ_addr
  | Caddf | Csubf | Cmulf | Cdivf -> typ_float
  | Cfloatofint -> typ_float
  | Cintoffloat -> typ_int
  | Craise -> typ_void
  | _ -> fatal_error "Selection.oper_result_type"

(* Estimate the intrinsic cost of an operation.
   The cost reflects both the number of registers destroyed by the operation
   and the time it will take to complete. Since subexpressions with higher
   cost are evaluated first, this increases slightly the probability that
   the result will be ready when needed. *)
   
let oper_cost = function
    Capply ty -> 32
  | Cextcall(s, ty) -> 16
  | Cload ty -> 2 * Array.length ty
  | Cloadchunk c -> 2
  | Cmuli -> 3
  | Cdivi | Cmodi -> 5
  | Caddf | Csubf | Cmulf | Cdivf -> 3
  | _ -> 1

(* Common instruction selection for operations *)

let rec sel_oper op args =
  match (op, args) with
    (Capply ty, Cconst(Const_symbol s) :: rem) -> (Icall_imm s, Ctuple rem)
  | (Capply ty, _) -> (Icall_ind, Ctuple args)
  | (Cextcall(s, ty), _) -> (Iextcall s, Ctuple args)
  | (Cload ty, [arg]) ->
      let (addr, eloc) = Proc.select_addressing arg in
      (Iload(Word, addr), eloc)
  | (Cloadchunk chunk, [arg]) ->
      let (addr, eloc) = Proc.select_addressing arg in
      (Iload(chunk, addr), eloc)
  | (Cstore, arg1 :: rem) ->
      let (addr, eloc) = Proc.select_addressing arg1 in
      (Istore(Word, addr), Ctuple(eloc :: rem))
  | (Cstorechunk chunk, arg1 :: rem) ->
      let (addr, eloc) = Proc.select_addressing arg1 in
      (Istore(chunk, addr), Ctuple(eloc :: rem))
  | (Calloc, _) -> (Ialloc 0, Ctuple args)
  | (Cmodify, [arg]) -> (Imodify, arg)
  | (Caddi, _) -> sel_arith_comm Iadd args
  | (Csubi, _) -> sel_arith Isub args
  | (Cmuli, _) -> sel_arith_comm Imul args
  | (Cdivi, _) -> sel_arith Idiv args
  | (Cmodi, _) -> sel_arith_comm Imod args
  | (Cand, _) -> sel_arith_comm Iand args
  | (Cor, _) -> sel_arith_comm Ior args
  | (Cxor, _) -> sel_arith_comm Ixor args
  | (Clsl, _) -> sel_arith Ilsl args
  | (Clsr, _) -> sel_arith Ilsr args
  | (Casr, _) -> sel_arith Iasr args
  | (Ccmpi comp, _) -> sel_arith_comp (Isigned comp) args
  | (Cadda, _) -> sel_arith_comm Iadd args
  | (Csuba, _) -> sel_arith Isub args
  | (Ccmpa comp, _) -> sel_arith_comp (Iunsigned comp) args
  | (Caddf, _) -> (Iaddf, Ctuple args)
  | (Csubf, _) -> (Isubf, Ctuple args)  
  | (Cmulf, _) -> (Imulf, Ctuple args)  
  | (Cdivf, _) -> (Idivf, Ctuple args)
  | (Cfloatofint, _) -> (Ifloatofint, Ctuple args)
  | (Cintoffloat, _) -> (Iintoffloat, Ctuple args)
  | _ -> fatal_error "Selection.sel_oper"

and sel_arith_comm op = function
    [arg; Cconst(Const_int n)] when Proc.is_immediate n ->
      (Iintop_imm(op, n), arg)
  | [arg; Cconst(Const_pointer n)] when Proc.is_immediate n ->
      (Iintop_imm(op, n), arg)
  | [Cconst(Const_int n); arg] when Proc.is_immediate n ->
      (Iintop_imm(op, n), arg)
  | [Cconst(Const_pointer n); arg] when Proc.is_immediate n ->
      (Iintop_imm(op, n), arg)
  | args ->
      (Iintop op, Ctuple args)

and sel_arith op = function
    [arg; Cconst(Const_int n)] when Proc.is_immediate n ->
      (Iintop_imm(op, n), arg)
  | [arg; Cconst(Const_pointer n)] when Proc.is_immediate n ->
      (Iintop_imm(op, n), arg)
  | args ->
      (Iintop op, Ctuple args)

and sel_arith_comp cmp = function
    [arg; Cconst(Const_int n)] when Proc.is_immediate n ->
      (Iintop_imm(Icomp cmp, n), arg)
  | [arg; Cconst(Const_pointer n)] when Proc.is_immediate n ->
      (Iintop_imm(Icomp cmp, n), arg)
  | [Cconst(Const_int n); arg] when Proc.is_immediate n ->
      (Iintop_imm(Icomp(swap_intcomp cmp), n), arg)
  | [Cconst(Const_pointer n); arg] when Proc.is_immediate n ->
      (Iintop_imm(Icomp(swap_intcomp cmp), n), arg)
  | args ->
      (Iintop(Icomp cmp), Ctuple args)

and swap_intcomp = function
    Isigned cmp -> Isigned(swap_comparison cmp)
  | Iunsigned cmp -> Iunsigned(swap_comparison cmp)

(* Instruction selection for conditionals *)

let sel_condition = function
    Cop(Ccmpi cmp, [arg1; Cconst(Const_int n)]) ->
      (Iinttest_imm(Isigned cmp, n), arg1)
  | Cop(Ccmpi cmp, [Cconst(Const_int n); arg2]) ->
      (Iinttest_imm(Isigned(swap_comparison cmp), n), arg2)
  | Cop(Ccmpi cmp, args) ->
      (Iinttest(Isigned cmp), Ctuple args)
  | Cop(Ccmpa cmp, [arg1; Cconst(Const_pointer n)]) ->
      (Iinttest_imm(Iunsigned cmp, n), arg1)
  | Cop(Ccmpa cmp, [Cconst(Const_pointer n); arg2]) ->
      (Iinttest_imm(Iunsigned(swap_comparison cmp), n), arg2)
  | Cop(Ccmpa cmp, args) ->
      (Iinttest(Iunsigned cmp), Ctuple args)
  | Cop(Ccmpf cmp, args) ->
      (Ifloattest cmp, Ctuple args)
  | arg ->
      (Itruetest, arg)

(* Flattening of tuples *)

let rec flatten_tuples = function
    [] -> []
  | Ctuple el :: rem -> flatten_tuples el @ flatten_tuples rem
  | exp :: rem -> exp :: flatten_tuples rem

(* Enumerate integers *)

let rec interval lo hi =
  if lo > hi then [] else lo :: interval (lo+1) hi

(* Instruction selection and annotation for an expression *)

let rec sel_expr = function
    Cconst c ->
      (Sconst c, 0)
  | Cvar v ->
      (Svar v, 0)
  | Clet(v, e1, e2) ->
      let (s1, n1) = sel_expr e1 in
      let (s2, n2) = sel_expr e2 in
      (Slet(v, s1, s2), max n1 (n2 + 1))
  | Cassign(v, e1) ->
      let (s1, n1) = sel_expr e1 in
      (Sassign(v, s1), n1)
  | Ctuple(el) ->
      begin match flatten_tuples el with
        [] ->
          (Stuple([||], []), 0)
      | [e1] ->
          sel_expr e1
      | [e1; e2] ->
          let (s1, n1) = sel_expr e1 in
          let (s2, n2) = sel_expr e2 in
          if n1 >= n2 then
            (Stuple([|s1;s2|], [0;1]), max n1 (n2 + 1))
          else
            (Stuple([|s1;s2|], [1;0]), max n2 (n1 + 1))
      | el ->
          let sv = Array.of_list(List.map sel_expr el) in
          let perm =
            Sort.list
              (fun i j ->
                let (_, ni) = sv.(i) and (_, nj) = sv.(j) in i >= j)
              (interval 0 (Array.length sv - 1)) in
          let need = ref 0 and accu = ref 0 in
          List.iter
            (fun i ->
              let (_, ni) = sv.(i) in
              need := max !need (ni + !accu);
              incr accu)
            perm;
          let cases = Array.map (fun (s, n) -> s) sv in
          (Stuple(cases, perm), !need)
      end
  | Csequence(e1, e2) ->
      let (s1, n1) = sel_expr e1 in
      let (s2, n2) = sel_expr e2 in
      (Ssequence(s1, s2), max n1 n2)
  | Cifthenelse(econd, eif, eelse) ->
      let (cond, earg) = sel_condition econd in
      let (sarg, narg) = sel_expr earg in
      let (sif, nif) = sel_expr eif in
      let (selse, nelse) = sel_expr eelse in
      (Sifthenelse(cond, sarg, sif, selse), max narg (max nif nelse))
  | Cswitch(esel, index, ecases) ->
      let (ssel, nsel) = sel_expr esel in
      let scases = Array.map sel_expr ecases in
      let need = ref nsel in
      for i = 0 to Array.length scases - 1 do
        let (_, n) = scases.(i) in need := max !need n
      done;
      (Sswitch(ssel, index, Array.map (fun (s, n) -> s) scases), !need)
  | Cwhile(Cconst(Const_int 1), ebody) ->
      let (sbody, nbody) = sel_expr ebody in
      (Sloop sbody, nbody)
  | Cwhile(econd, ebody) ->
      let (cond, earg) = sel_condition econd in
      let (sarg, narg) = sel_expr earg in
      let (sbody, nbody) = sel_expr ebody in
      (Scatch(Sloop(Sifthenelse(cond, sarg, sbody, Sexit)), Stuple([||], [])),
       max narg nbody)
  | Ccatch(e1, e2) ->
      let (s1, n1) = sel_expr e1 in
      let (s2, n2) = sel_expr e2 in
      (Scatch(s1, s2), max n1 n2)
  | Cexit ->
      (Sexit, 0)
  | Ctrywith(e1, v, e2) ->
      let (s1, n1) = sel_expr e1 in
      let (s2, n2) = sel_expr e2 in
      (Strywith(s1, v, s2), max n1 (n2 + 1))
  | Cop(Cproj(ofs, len), [Cop(Cload ty, [arg])]) ->
      sel_expr
        (Cop(Cload (Array.sub ty ofs len),
             [Cop(Cadda,
                [arg; Cconst(Const_int(size_machtype(Array.sub ty 0 ofs)))])]))
  | Cop(Cproj(ofs, len), [arg]) ->
      let (s, n) = sel_expr arg in (Sproj(s, ofs, len), n)
  | Cop(Craise, [arg]) ->
      let (s, n) = sel_expr arg in (Sraise s, n)
  | Cop(op, args) ->
      let ty = oper_result_type op in
      let cost = oper_cost op in
      (* Offer the processor description a chance to do its own selection,
         e.g. to recognize processor-specific instructions *)
      try
        let (newop, newarg) = Proc.select_oper op args in
        let (sarg, narg) = sel_expr newarg in
        (Sop(newop, sarg, ty), narg + cost)
      with Proc.Use_default ->
      (* Do our own selection *)
        match op with
          Ccmpf comp ->
            let (sarg, narg) = sel_expr (Ctuple args) in
            (Sifthenelse(Ifloattest comp, sarg,
                         Sconst(Const_int 1), Sconst(Const_int 0)), narg)
        | _ ->
            let (newop, newarg) = sel_oper op args in
            let (sarg, narg) = sel_expr newarg in
            (Sop(newop, sarg, ty), narg + cost)

let expression e =
  let (s, n) = sel_expr e in s