ocaml/asmcomp/cmmgen.ml

(***********************************************************************)
(*                                                                     *)
(*                           Objective Caml                            *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)

(* $Id$ *)

(* Translation from closed lambda to C-- *)

open Misc
open Arch
open Asttypes
open Primitive
open Types
open Lambda
open Clambda
open Cmm

(* Local binding of complex expressions *)

let bind name arg fn =
  match arg with
    Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _
  | Cconst_pointer _ | Cconst_natpointer _ -> fn arg
  | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id))

let bind_nonvar name arg fn =
  match arg with
    Cconst_int _ | Cconst_natint _ | Cconst_symbol _
  | Cconst_pointer _ | Cconst_natpointer _ -> fn arg
  | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id))

(* Block headers. Meaning of the tag field: see stdlib/obj.ml *)

let float_tag = Cconst_int Obj.double_tag
let floatarray_tag = Cconst_int Obj.double_array_tag

let block_header tag sz =
  Nativeint.add (Nativeint.shift_left (Nativeint.of_int sz) 10)
                (Nativeint.of_int tag)
let closure_header sz = block_header Obj.closure_tag sz
let infix_header ofs = block_header Obj.infix_tag ofs
let float_header = block_header Obj.double_tag (size_float / size_addr)
let floatarray_header len =
      block_header Obj.double_array_tag (len * size_float / size_addr)
let string_header len =
      block_header Obj.string_tag ((len + size_addr) / size_addr)
let boxedint_header = block_header Obj.custom_tag 2

let alloc_block_header tag sz = Cconst_natint(block_header tag sz)
let alloc_float_header = Cconst_natint(float_header)
let alloc_floatarray_header len = Cconst_natint(floatarray_header len)
let alloc_closure_header sz = Cconst_natint(closure_header sz)
let alloc_infix_header ofs = Cconst_natint(infix_header ofs)
let alloc_boxedint_header = Cconst_natint(boxedint_header)

(* Integers *)

let max_repr_int = max_int asr 1
let min_repr_int = min_int asr 1

let int_const n =
  if n <= max_repr_int && n >= min_repr_int
  then Cconst_int((n lsl 1) + 1)
  else Cconst_natint
          (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n)

let add_const c n =
  if n = 0 then c else Cop(Caddi, [c; Cconst_int n])

let incr_int = function
    Cconst_int n when n < max_int -> Cconst_int(n+1)
  | Cop(Caddi, [c; Cconst_int n]) when n < max_int -> add_const c (n + 1)
  | c -> add_const c 1

let decr_int = function
    Cconst_int n when n > min_int -> Cconst_int(n-1)
  | Cop(Caddi, [c; Cconst_int n]) when n > min_int -> add_const c (n - 1)
  | c -> add_const c (-1)

let add_int c1 c2 =
  match (c1, c2) with
    (Cop(Caddi, [c1; Cconst_int n1]),
     Cop(Caddi, [c2; Cconst_int n2])) when no_overflow_add n1 n2 ->
      add_const (Cop(Caddi, [c1; c2])) (n1 + n2)
  | (Cop(Caddi, [c1; Cconst_int n1]), c2) ->
      add_const (Cop(Caddi, [c1; c2])) n1
  | (c1, Cop(Caddi, [c2; Cconst_int n2])) ->
      add_const (Cop(Caddi, [c1; c2])) n2
  | (Cconst_int _, _) ->
      Cop(Caddi, [c2; c1])
  | (_, _) ->
      Cop(Caddi, [c1; c2])

let sub_int c1 c2 =
  match (c1, c2) with
    (Cop(Caddi, [c1; Cconst_int n1]),
     Cop(Caddi, [c2; Cconst_int n2])) when no_overflow_sub n1 n2 ->
      add_const (Cop(Csubi, [c1; c2])) (n1 - n2)
  | (Cop(Caddi, [c1; Cconst_int n1]), c2) ->
      add_const (Cop(Csubi, [c1; c2])) n1
  | (c1, Cop(Caddi, [c2; Cconst_int n2])) when n2 <> min_int ->
      add_const (Cop(Csubi, [c1; c2])) (-n2)
  | (c1, Cconst_int n) when n <> min_int ->
      add_const c1 (-n)
  | (c1, c2) ->
      Cop(Csubi, [c1; c2])

let mul_int c1 c2 =
  match (c1, c2) with
    (Cconst_int 0, _) -> c1
  | (Cconst_int 1, _) -> c2
  | (_, Cconst_int 0) -> c2
  | (_, Cconst_int 1) -> c1
  | (_, _) -> Cop(Cmuli, [c1; c2])

let tag_int = function
    Cconst_int n -> int_const n
  | c -> Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1])

let force_tag_int = function
    Cconst_int n -> int_const n
  | c -> Cop(Cor, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1])

let untag_int = function
    Cconst_int n -> Cconst_int(n asr 1)
  | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> c
  | Cop(Cor, [Cop(Casr, [c; Cconst_int n]); Cconst_int 1])
    when n > 0 && n < size_int * 8 ->
      Cop(Casr, [c; Cconst_int (n+1)])
  | Cop(Cor, [Cop(Clsr, [c; Cconst_int n]); Cconst_int 1])
    when n > 0 && n < size_int * 8 ->
      Cop(Clsr, [c; Cconst_int (n+1)])
  | Cop(Cor, [c; Cconst_int 1]) -> Cop(Casr, [c; Cconst_int 1])
  | c -> Cop(Casr, [c; Cconst_int 1])

let lsl_int c1 c2 =
  match (c1, c2) with
    (Cop(Clsl, [c; Cconst_int n1]), Cconst_int n2)
    when n1 > 0 && n2 > 0 && n1 + n2 < size_int * 8 ->
      Cop(Clsl, [c; Cconst_int (n1 + n2)])
  | (_, _) ->
      Cop(Clsl, [c1; c2])

let ignore_low_bit_int = function
    Cop(Caddi, [(Cop(Clsl, [_; Cconst_int 1]) as c); Cconst_int 1]) -> c
  | Cop(Cor, [c; Cconst_int 1]) -> c
  | c -> c

let is_nonzero_constant = function
    Cconst_int n -> n <> 0
  | Cconst_natint n -> n <> 0n
  | _ -> false

let safe_divmod op c1 c2 dbg =
  if !Clflags.fast || is_nonzero_constant c2 then
    Cop(op, [c1; c2])
  else
    bind "divisor" c2 (fun c2 ->
      Cifthenelse(c2,
                  Cop(op, [c1; c2]),
                  Cop(Craise dbg,
                      [Cconst_symbol "caml_bucket_Division_by_zero"])))

(* Bool *)

let test_bool = function
    Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> c
  | Cop(Clsl, [c; Cconst_int 1]) -> c
  | c -> Cop(Ccmpi Cne, [c; Cconst_int 1])

(* Float *)

let box_float c = Cop(Calloc, [alloc_float_header; c])

let unbox_float = function
    Cop(Calloc, [header; c]) -> c
  | c -> Cop(Cload Double_u, [c])

(* Complex *)

let box_complex c_re c_im =
  Cop(Calloc, [alloc_floatarray_header 2; c_re; c_im])

let complex_re c = Cop(Cload Double_u, [c])
let complex_im c = Cop(Cload Double_u,
                       [Cop(Cadda, [c; Cconst_int size_float])])

(* Unit *)

let return_unit c = Csequence(c, Cconst_pointer 1)

let rec remove_unit = function
    Cconst_pointer 1 -> Ctuple []
  | Csequence(c, Cconst_pointer 1) -> c
  | Csequence(c1, c2) ->
      Csequence(c1, remove_unit c2)
  | Cifthenelse(cond, ifso, ifnot) ->
      Cifthenelse(cond, remove_unit ifso, remove_unit ifnot)
  | Cswitch(sel, index, cases) ->
      Cswitch(sel, index, Array.map remove_unit cases)
  | Ccatch(io, ids, body, handler) ->
      Ccatch(io, ids, remove_unit body, remove_unit handler)
  | Ctrywith(body, exn, handler) ->
      Ctrywith(remove_unit body, exn, remove_unit handler)
  | Clet(id, c1, c2) ->
      Clet(id, c1, remove_unit c2)
  | Cop(Capply (mty, dbg), args) ->
      Cop(Capply (typ_void, dbg), args)
  | Cop(Cextcall(proc, mty, alloc, dbg), args) ->
      Cop(Cextcall(proc, typ_void, alloc, dbg), args)
  | Cexit (_,_) as c -> c
  | Ctuple [] as c -> c
  | c -> Csequence(c, Ctuple [])

(* Access to block fields *)

let field_address ptr n =
  if n = 0
  then ptr
  else Cop(Cadda, [ptr; Cconst_int(n * size_addr)])

let get_field ptr n =
  Cop(Cload Word, [field_address ptr n])

let set_field ptr n newval =
  Cop(Cstore Word, [field_address ptr n; newval])

let header ptr =
  Cop(Cload Word, [Cop(Cadda, [ptr; Cconst_int(-size_int)])])

let tag_offset =
  if big_endian then -1 else -size_int

let get_tag ptr =
  if Proc.word_addressed then           (* If byte loads are slow *)
    Cop(Cand, [header ptr; Cconst_int 255])
  else                                  (* If byte loads are efficient *)
    Cop(Cload Byte_unsigned,
        [Cop(Cadda, [ptr; Cconst_int(tag_offset)])])

let get_size ptr =
  Cop(Clsr, [header ptr; Cconst_int 10])

(* Array indexing *)

let log2_size_addr = Misc.log2 size_addr
let log2_size_float = Misc.log2 size_float

let wordsize_shift = 9
let numfloat_shift = 9 + log2_size_float - log2_size_addr

let is_addr_array_hdr hdr =
  Cop(Ccmpi Cne, [Cop(Cand, [hdr; Cconst_int 255]); floatarray_tag])

let is_addr_array_ptr ptr =
  Cop(Ccmpi Cne, [get_tag ptr; floatarray_tag])

let addr_array_length hdr = Cop(Clsr, [hdr; Cconst_int wordsize_shift])
let float_array_length hdr = Cop(Clsr, [hdr; Cconst_int numfloat_shift])

let lsl_const c n =
  Cop(Clsl, [c; Cconst_int n])

let array_indexing log2size ptr ofs =
  match ofs with
    Cconst_int n ->
      let i = n asr 1 in
      if i = 0 then ptr else Cop(Cadda, [ptr; Cconst_int(i lsl log2size)])
  | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) ->
      Cop(Cadda, [ptr; lsl_const c log2size])
  | Cop(Caddi, [c; Cconst_int n]) ->
      Cop(Cadda, [Cop(Cadda, [ptr; lsl_const c (log2size - 1)]);
                   Cconst_int((n-1) lsl (log2size - 1))])
  | _ ->
      Cop(Cadda, [Cop(Cadda, [ptr; lsl_const ofs (log2size - 1)]);
                   Cconst_int((-1) lsl (log2size - 1))])

let addr_array_ref arr ofs =
  Cop(Cload Word, [array_indexing log2_size_addr arr ofs])
let unboxed_float_array_ref arr ofs =
  Cop(Cload Double_u, [array_indexing log2_size_float arr ofs])
let float_array_ref arr ofs =
  box_float(unboxed_float_array_ref arr ofs)

let addr_array_set arr ofs newval =
  Cop(Cextcall("caml_modify", typ_void, false, Debuginfo.none),
      [array_indexing log2_size_addr arr ofs; newval])
let int_array_set arr ofs newval =
  Cop(Cstore Word, [array_indexing log2_size_addr arr ofs; newval])
let float_array_set arr ofs newval =
  Cop(Cstore Double_u, [array_indexing log2_size_float arr ofs; newval])

(* String length *)

let string_length exp =
  bind "str" exp (fun str ->
    let tmp_var = Ident.create "tmp" in
    Clet(tmp_var,
         Cop(Csubi,
             [Cop(Clsl,
                   [Cop(Clsr, [header str; Cconst_int 10]);
                     Cconst_int log2_size_addr]);
              Cconst_int 1]),
         Cop(Csubi,
             [Cvar tmp_var;
               Cop(Cload Byte_unsigned,
                     [Cop(Cadda, [str; Cvar tmp_var])])])))

(* Message sending *)

let lookup_tag obj tag =
  bind "tag" tag (fun tag ->
    Cop(Cextcall("caml_get_public_method", typ_addr, false, Debuginfo.none),
        [obj; tag]))

let lookup_label obj lab =
  bind "lab" lab (fun lab ->
    let table = Cop (Cload Word, [obj]) in
    addr_array_ref table lab)

let call_cached_method obj tag cache pos args dbg =
  let arity = List.length args in
  let cache = array_indexing log2_size_addr cache pos in
  Compilenv.need_send_fun arity;
  Cop(Capply (typ_addr, dbg),
      Cconst_symbol("caml_send" ^ string_of_int arity) ::
      obj :: tag :: cache :: args)

(* Allocation *)

let make_alloc_generic set_fn tag wordsize args =
  if wordsize <= Config.max_young_wosize then
    Cop(Calloc, Cconst_natint(block_header tag wordsize) :: args)
  else begin
    let id = Ident.create "alloc" in
    let rec fill_fields idx = function
      [] -> Cvar id
    | e1::el -> Csequence(set_fn (Cvar id) (Cconst_int idx) e1,
                          fill_fields (idx + 2) el) in
    Clet(id,
         Cop(Cextcall("caml_alloc", typ_addr, true, Debuginfo.none),
                 [Cconst_int wordsize; Cconst_int tag]),
         fill_fields 1 args)
  end

let make_alloc tag args =
  make_alloc_generic addr_array_set tag (List.length args) args
let make_float_alloc tag args =
  make_alloc_generic float_array_set tag
                     (List.length args * size_float / size_addr) args

(* To compile "let rec" over values *)

let fundecls_size fundecls =
  let sz = ref (-1) in
  List.iter
    (fun (label, arity, params, body) ->
      sz := !sz + 1 + (if arity = 1 then 2 else 3))
    fundecls;
  !sz

type rhs_kind =
  | RHS_block of int
  | RHS_nonrec
;;
let rec expr_size = function
  | Uclosure(fundecls, clos_vars) ->
      RHS_block (fundecls_size fundecls + List.length clos_vars)
  | Ulet(id, exp, body) ->
      expr_size body
  | Uletrec(bindings, body) ->
      expr_size body
  | Uprim(Pmakeblock(tag, mut), args, _) ->
      RHS_block (List.length args)
  | Uprim(Pmakearray(Paddrarray | Pintarray), args, _) ->
      RHS_block (List.length args)
  | Usequence(exp, exp') ->
      expr_size exp'
  | _ -> RHS_nonrec

(* Record application and currying functions *)

let apply_function n =
  Compilenv.need_apply_fun n; "caml_apply" ^ string_of_int n
let curry_function n =
  Compilenv.need_curry_fun n;
  if n >= 0
  then "caml_curry" ^ string_of_int n
  else "caml_tuplify" ^ string_of_int (-n)

(* Comparisons *)

let transl_comparison = function
    Lambda.Ceq -> Ceq
  | Lambda.Cneq -> Cne
  | Lambda.Cge -> Cge
  | Lambda.Cgt -> Cgt
  | Lambda.Cle -> Cle
  | Lambda.Clt -> Clt

(* Translate structured constants *)

let const_label = ref 0

let new_const_label () =
  incr const_label;
  !const_label

let new_const_symbol () =
  incr const_label;
  Compilenv.make_symbol (Some (string_of_int !const_label))

let structured_constants = ref ([] : (string * structured_constant) list)

let transl_constant = function
    Const_base(Const_int n) ->
      int_const n
  | Const_base(Const_char c) ->
      Cconst_int(((Char.code c) lsl 1) + 1)
  | Const_pointer n ->
      if n <= max_repr_int && n >= min_repr_int
      then Cconst_pointer((n lsl 1) + 1)
      else Cconst_natpointer
              (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n)
  | cst ->
      let lbl = new_const_symbol() in
      structured_constants := (lbl, cst) :: !structured_constants;
      Cconst_symbol lbl

(* Translate constant closures *)

let constant_closures =
  ref ([] : (string * (string * int * Ident.t list * ulambda) list) list)

(* Boxed integers *)

let box_int_constant bi n =
  match bi with
    Pnativeint -> Const_base(Const_nativeint n)
  | Pint32 -> Const_base(Const_int32 (Nativeint.to_int32 n))
  | Pint64 -> Const_base(Const_int64 (Int64.of_nativeint n))

let operations_boxed_int bi =
  match bi with
    Pnativeint -> "caml_nativeint_ops"
  | Pint32 -> "caml_int32_ops"
  | Pint64 -> "caml_int64_ops"

let box_int bi arg =
  match arg with
    Cconst_int n ->
      transl_constant (box_int_constant bi (Nativeint.of_int n))
  | Cconst_natint n ->
      transl_constant (box_int_constant bi n)
  | _ ->
      let arg' =
        if bi = Pint32 && size_int = 8 && big_endian
        then Cop(Clsl, [arg; Cconst_int 32])
        else arg in
      Cop(Calloc, [alloc_boxedint_header;
                   Cconst_symbol(operations_boxed_int bi);
                   arg'])

let unbox_int bi arg =
  match arg with
    Cop(Calloc, [hdr; ops; Cop(Clsl, [contents; Cconst_int 32])])
    when bi = Pint32 && size_int = 8 && big_endian ->
      (* Force sign-extension of low 32 bits *)
      Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32])
  | Cop(Calloc, [hdr; ops; contents])
    when bi = Pint32 && size_int = 8 && not big_endian ->
      (* Force sign-extension of low 32 bits *)
      Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32])
  | Cop(Calloc, [hdr; ops; contents]) ->
      contents
  | _ ->
      Cop(Cload(if bi = Pint32 then Thirtytwo_signed else Word),
          [Cop(Cadda, [arg; Cconst_int size_addr])])

let make_unsigned_int bi arg =
  if bi = Pint32 && size_int = 8
  then Cop(Cand, [arg; Cconst_natint 0xFFFFFFFFn])
  else arg

(* Big arrays *)

let bigarray_elt_size = function
    Pbigarray_unknown -> assert false
  | Pbigarray_float32 -> 4
  | Pbigarray_float64 -> 8
  | Pbigarray_sint8 -> 1
  | Pbigarray_uint8 -> 1
  | Pbigarray_sint16 -> 2
  | Pbigarray_uint16 -> 2
  | Pbigarray_int32 -> 4
  | Pbigarray_int64 -> 8
  | Pbigarray_caml_int -> size_int
  | Pbigarray_native_int -> size_int
  | Pbigarray_complex32 -> 8
  | Pbigarray_complex64 -> 16

let bigarray_indexing elt_kind layout b args dbg =
  let rec ba_indexing dim_ofs delta_ofs = function
    [] -> assert false
  | [arg] ->
      bind "idx" (untag_int arg)
        (fun idx ->
          Csequence(
            Cop(Ccheckbound dbg, [Cop(Cload Word,[field_address b dim_ofs]); idx]),
            idx))
  | arg1 :: argl ->
      let rem = ba_indexing (dim_ofs + delta_ofs) delta_ofs argl in
      bind "idx" (untag_int arg1)
        (fun idx ->
          bind "bound" (Cop(Cload Word, [field_address b dim_ofs]))
          (fun bound ->
            Csequence(Cop(Ccheckbound dbg, [bound; idx]),
                      add_int (mul_int rem bound) idx))) in
  let offset =
    match layout with
      Pbigarray_unknown_layout ->
        assert false
    | Pbigarray_c_layout ->
        ba_indexing (4 + List.length args) (-1) (List.rev args)
    | Pbigarray_fortran_layout ->
        ba_indexing 5 1 (List.map (fun idx -> sub_int idx (Cconst_int 2)) args)
  and elt_size =
    bigarray_elt_size elt_kind in
  let byte_offset =
    if elt_size = 1
    then offset
    else Cop(Clsl, [offset; Cconst_int(log2 elt_size)]) in
  Cop(Cadda, [Cop(Cload Word, [field_address b 1]); byte_offset])

let bigarray_word_kind = function
    Pbigarray_unknown -> assert false
  | Pbigarray_float32 -> Single
  | Pbigarray_float64 -> Double
  | Pbigarray_sint8 -> Byte_signed
  | Pbigarray_uint8 -> Byte_unsigned
  | Pbigarray_sint16 -> Sixteen_signed
  | Pbigarray_uint16 -> Sixteen_unsigned
  | Pbigarray_int32 -> Thirtytwo_signed
  | Pbigarray_int64 -> Word
  | Pbigarray_caml_int -> Word
  | Pbigarray_native_int -> Word
  | Pbigarray_complex32 -> Single
  | Pbigarray_complex64 -> Double

let bigarray_get elt_kind layout b args dbg =
  match elt_kind with
    Pbigarray_complex32 | Pbigarray_complex64 ->
      let kind = bigarray_word_kind elt_kind in
      let sz = bigarray_elt_size elt_kind / 2 in
      bind "addr" (bigarray_indexing elt_kind layout b args dbg) (fun addr ->
        box_complex
          (Cop(Cload kind, [addr]))
          (Cop(Cload kind, [Cop(Cadda, [addr; Cconst_int sz])])))
  | _ ->
      Cop(Cload (bigarray_word_kind elt_kind),
          [bigarray_indexing elt_kind layout b args dbg])

let bigarray_set elt_kind layout b args newval dbg =
  match elt_kind with
    Pbigarray_complex32 | Pbigarray_complex64 ->
      let kind = bigarray_word_kind elt_kind in
      let sz = bigarray_elt_size elt_kind / 2 in
      bind "newval" newval (fun newv ->
      bind "addr" (bigarray_indexing elt_kind layout b args dbg) (fun addr ->
        Csequence(
          Cop(Cstore kind, [addr; complex_re newv]),
          Cop(Cstore kind,
              [Cop(Cadda, [addr; Cconst_int sz]); complex_im newv]))))
  | _ ->
      Cop(Cstore (bigarray_word_kind elt_kind),
          [bigarray_indexing elt_kind layout b args dbg; newval])

(* Simplification of some primitives into C calls *)

let default_prim name =
  { prim_name = name; prim_arity = 0 (*ignored*);
    prim_alloc = true; prim_native_name = ""; prim_native_float = false }

let simplif_primitive_32bits = function
    Pbintofint Pint64 -> Pccall (default_prim "caml_int64_of_int")
  | Pintofbint Pint64 -> Pccall (default_prim "caml_int64_to_int")
  | Pcvtbint(Pint32, Pint64) -> Pccall (default_prim "caml_int64_of_int32")
  | Pcvtbint(Pint64, Pint32) -> Pccall (default_prim "caml_int64_to_int32")
  | Pcvtbint(Pnativeint, Pint64) ->
      Pccall (default_prim "caml_int64_of_nativeint")
  | Pcvtbint(Pint64, Pnativeint) ->
      Pccall (default_prim "caml_int64_to_nativeint")
  | Pnegbint Pint64 -> Pccall (default_prim "caml_int64_neg")
  | Paddbint Pint64 -> Pccall (default_prim "caml_int64_add")
  | Psubbint Pint64 -> Pccall (default_prim "caml_int64_sub")
  | Pmulbint Pint64 -> Pccall (default_prim "caml_int64_mul")
  | Pdivbint Pint64 -> Pccall (default_prim "caml_int64_div")
  | Pmodbint Pint64 -> Pccall (default_prim "caml_int64_mod")
  | Pandbint Pint64 -> Pccall (default_prim "caml_int64_and")
  | Porbint Pint64 ->  Pccall (default_prim "caml_int64_or")
  | Pxorbint Pint64 -> Pccall (default_prim "caml_int64_xor")
  | Plslbint Pint64 -> Pccall (default_prim "caml_int64_shift_left")
  | Plsrbint Pint64 -> Pccall (default_prim "caml_int64_shift_right_unsigned")
  | Pasrbint Pint64 -> Pccall (default_prim "caml_int64_shift_right")
  | Pbintcomp(Pint64, Lambda.Ceq) -> Pccall (default_prim "caml_equal")
  | Pbintcomp(Pint64, Lambda.Cneq) -> Pccall (default_prim "caml_notequal")
  | Pbintcomp(Pint64, Lambda.Clt) -> Pccall (default_prim "caml_lessthan")
  | Pbintcomp(Pint64, Lambda.Cgt) -> Pccall (default_prim "caml_greaterthan")
  | Pbintcomp(Pint64, Lambda.Cle) -> Pccall (default_prim "caml_lessequal")
  | Pbintcomp(Pint64, Lambda.Cge) -> Pccall (default_prim "caml_greaterequal")
  | Pbigarrayref(n, Pbigarray_int64, layout) ->
      Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
  | Pbigarrayset(n, Pbigarray_int64, layout) ->
      Pccall (default_prim ("caml_ba_set_" ^ string_of_int n))
  | p -> p

let simplif_primitive p =
  match p with
  | Pduprecord _ ->
      Pccall (default_prim "caml_obj_dup")
  | Pbigarrayref(n, Pbigarray_unknown, layout) ->
      Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
  | Pbigarrayset(n, Pbigarray_unknown, layout) ->
      Pccall (default_prim ("caml_ba_set_" ^ string_of_int n))
  | Pbigarrayref(n, kind, Pbigarray_unknown_layout) ->
      Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
  | Pbigarrayset(n, kind, Pbigarray_unknown_layout) ->
      Pccall (default_prim ("caml_ba_set_" ^ string_of_int n))
  | p ->
      if size_int = 8 then p else simplif_primitive_32bits p

(* Build switchers both for constants and blocks *)

(* constants first *)

let transl_isout h arg = tag_int (Cop(Ccmpa Clt, [h ; arg]))

exception Found of int

let make_switch_gen arg cases acts =
  let lcases = Array.length cases in
  let new_cases = Array.create lcases 0 in
  let store = Switch.mk_store (=) in

  for i = 0 to Array.length cases-1 do
    let act = cases.(i) in
    let new_act = store.Switch.act_store act in
    new_cases.(i) <- new_act
  done ;
  Cswitch
    (arg, new_cases,
     Array.map
       (fun n -> acts.(n))
       (store.Switch.act_get ()))


(* Then for blocks *)

module SArgBlocks =
struct
  type primitive = operation

  let eqint = Ccmpi Ceq
  let neint = Ccmpi Cne
  let leint = Ccmpi Cle
  let ltint = Ccmpi Clt
  let geint = Ccmpi Cge
  let gtint = Ccmpi Cgt

  type act = expression

  let default = Cexit (0,[])
  let make_prim p args = Cop (p,args)
  let make_offset arg n = add_const arg n
  let make_isout h arg =  Cop (Ccmpa Clt, [h ; arg])
  let make_isin h arg =  Cop (Ccmpa Cge, [h ; arg])
  let make_if cond ifso ifnot = Cifthenelse (cond, ifso, ifnot)
  let make_switch arg cases actions =
    make_switch_gen arg cases actions
  let bind arg body = bind "switcher" arg body

end

module SwitcherBlocks = Switch.Make(SArgBlocks)

(* Auxiliary functions for optimizing "let" of boxed numbers (floats and
   boxed integers *)

type unboxed_number_kind =
    No_unboxing
  | Boxed_float
  | Boxed_integer of boxed_integer

let is_unboxed_number = function
    Uconst(Const_base(Const_float f)) ->
      Boxed_float
  | Uprim(p, _, _) ->
      begin match simplif_primitive p with
          Pccall p -> if p.prim_native_float then Boxed_float else No_unboxing
        | Pfloatfield _ -> Boxed_float
        | Pfloatofint -> Boxed_float
        | Pnegfloat -> Boxed_float
        | Pabsfloat -> Boxed_float
        | Paddfloat -> Boxed_float
        | Psubfloat -> Boxed_float
        | Pmulfloat -> Boxed_float
        | Pdivfloat -> Boxed_float
        | Parrayrefu Pfloatarray -> Boxed_float
        | Parrayrefs Pfloatarray -> Boxed_float
        | Pbintofint bi -> Boxed_integer bi
        | Pcvtbint(src, dst) -> Boxed_integer dst
        | Pnegbint bi -> Boxed_integer bi
        | Paddbint bi -> Boxed_integer bi
        | Psubbint bi -> Boxed_integer bi
        | Pmulbint bi -> Boxed_integer bi
        | Pdivbint bi -> Boxed_integer bi
        | Pmodbint bi -> Boxed_integer bi
        | Pandbint bi -> Boxed_integer bi
        | Porbint bi -> Boxed_integer bi
        | Pxorbint bi -> Boxed_integer bi
        | Plslbint bi -> Boxed_integer bi
        | Plsrbint bi -> Boxed_integer bi
        | Pasrbint bi -> Boxed_integer bi
        | Pbigarrayref(_, (Pbigarray_float32 | Pbigarray_float64), _) ->
            Boxed_float
        | Pbigarrayref(_, Pbigarray_int32, _) -> Boxed_integer Pint32
        | Pbigarrayref(_, Pbigarray_int64, _) -> Boxed_integer Pint64
        | Pbigarrayref(_, Pbigarray_native_int, _) -> Boxed_integer Pnativeint
        | _ -> No_unboxing
      end
  | _ -> No_unboxing

let subst_boxed_number unbox_fn boxed_id unboxed_id exp =
  let need_boxed = ref false in
  let assigned = ref false in
  let rec subst = function
      Cvar id as e ->
        if Ident.same id boxed_id then need_boxed := true; e
    | Clet(id, arg, body) -> Clet(id, subst arg, subst body)
    | Cassign(id, arg) ->
        if Ident.same id boxed_id then begin
          assigned := true;
          Cassign(unboxed_id, subst(unbox_fn arg))
        end else
          Cassign(id, subst arg)
    | Ctuple argv -> Ctuple(List.map subst argv)
    | Cop(Cload _, [Cvar id]) as e ->
        if Ident.same id boxed_id then Cvar unboxed_id else e
    | Cop(Cload _, [Cop(Cadda, [Cvar id; _])]) as e ->
        if Ident.same id boxed_id then Cvar unboxed_id else e
    | Cop(op, argv) -> Cop(op, List.map subst argv)
    | Csequence(e1, e2) -> Csequence(subst e1, subst e2)
    | Cifthenelse(e1, e2, e3) -> Cifthenelse(subst e1, subst e2, subst e3)
    | Cswitch(arg, index, cases) ->
        Cswitch(subst arg, index, Array.map subst cases)
    | Cloop e -> Cloop(subst e)
    | Ccatch(nfail, ids, e1, e2) -> Ccatch(nfail, ids, subst e1, subst e2)
    | Cexit (nfail, el) -> Cexit (nfail, List.map subst el)
    | Ctrywith(e1, id, e2) -> Ctrywith(subst e1, id, subst e2)
    | e -> e in
  let res = subst exp in
  (res, !need_boxed, !assigned)

(* Translate an expression *)

let functions = (Queue.create() : (string * Ident.t list * ulambda) Queue.t)

let rec transl = function
    Uvar id ->
      Cvar id
  | Uconst sc ->
      transl_constant sc
  | Uclosure(fundecls, []) ->
      let lbl = new_const_symbol() in
      constant_closures := (lbl, fundecls) :: !constant_closures;
      List.iter
        (fun (label, arity, params, body) ->
          Queue.add (label, params, body) functions)
        fundecls;
      Cconst_symbol lbl
  | Uclosure(fundecls, clos_vars) ->
      let block_size =
        fundecls_size fundecls + List.length clos_vars in
      let rec transl_fundecls pos = function
          [] ->
            List.map transl clos_vars
        | (label, arity, params, body) :: rem ->
            Queue.add (label, params, body) functions;
            let header =
              if pos = 0
              then alloc_closure_header block_size
              else alloc_infix_header pos in
            if arity = 1 then
              header ::
              Cconst_symbol label ::
              int_const 1 ::
              transl_fundecls (pos + 3) rem
            else
              header ::
              Cconst_symbol(curry_function arity) ::
              int_const arity ::
              Cconst_symbol label ::
              transl_fundecls (pos + 4) rem in
      Cop(Calloc, transl_fundecls 0 fundecls)
  | Uoffset(arg, offset) ->
      field_address (transl arg) offset
  | Udirect_apply(lbl, args, dbg) ->
      Cop(Capply(typ_addr, dbg), Cconst_symbol lbl :: List.map transl args)
  | Ugeneric_apply(clos, [arg], dbg) ->
      bind "fun" (transl clos) (fun clos ->
        Cop(Capply(typ_addr, dbg), [get_field clos 0; transl arg; clos]))
  | Ugeneric_apply(clos, args, dbg) ->
      let arity = List.length args in
      let cargs = Cconst_symbol(apply_function arity) ::
        List.map transl (args @ [clos]) in
      Cop(Capply(typ_addr, dbg), cargs)
  | Usend(kind, met, obj, args, dbg) ->
      let call_met obj args clos =
        if args = [] then
          Cop(Capply(typ_addr, dbg), [get_field clos 0;obj;clos])
        else
          let arity = List.length args + 1 in
          let cargs = Cconst_symbol(apply_function arity) :: obj ::
            (List.map transl args) @ [clos] in
          Cop(Capply(typ_addr, dbg), cargs)
      in
      bind "obj" (transl obj) (fun obj ->
        match kind, args with
          Self, _ ->
            bind "met" (lookup_label obj (transl met)) (call_met obj args)
        | Cached, cache :: pos :: args ->
            call_cached_method obj (transl met) (transl cache) (transl pos)
              (List.map transl args) dbg
        | _ ->
            bind "met" (lookup_tag obj (transl met)) (call_met obj args))
  | Ulet(id, exp, body) ->
      begin match is_unboxed_number exp with
        No_unboxing ->
          Clet(id, transl exp, transl body)
      | Boxed_float ->
          transl_unbox_let box_float unbox_float transl_unbox_float
                           id exp body
      | Boxed_integer bi ->
          transl_unbox_let (box_int bi) (unbox_int bi) (transl_unbox_int bi)
                           id exp body
      end
  | Uletrec(bindings, body) ->
      transl_letrec bindings (transl body)

  (* Primitives *)
  | Uprim(prim, args, dbg) ->
      begin match (simplif_primitive prim, args) with
        (Pgetglobal id, []) ->
          Cconst_symbol (Ident.name id)
      | (Pmakeblock(tag, mut), []) ->
          transl_constant(Const_block(tag, []))
      | (Pmakeblock(tag, mut), args) ->
          make_alloc tag (List.map transl args)
      | (Pccall prim, args) ->
          if prim.prim_native_float then
            box_float
              (Cop(Cextcall(prim.prim_native_name, typ_float, false, dbg),
                   List.map transl_unbox_float args))
          else begin
            let name =
              if prim.prim_native_name <> ""
              then prim.prim_native_name
              else prim.prim_name in
            Cop(Cextcall(name, typ_addr, prim.prim_alloc, dbg),
                List.map transl args)
          end
      | (Pmakearray kind, []) ->
          transl_constant(Const_block(0, []))
      | (Pmakearray kind, args) ->
          begin match kind with
            Pgenarray ->
              Cop(Cextcall("caml_make_array", typ_addr, true, Debuginfo.none),
                  [make_alloc 0 (List.map transl args)])
          | Paddrarray | Pintarray ->
              make_alloc 0 (List.map transl args)
          | Pfloatarray ->
              make_float_alloc Obj.double_array_tag
                              (List.map transl_unbox_float args)
          end
      | (Pbigarrayref(num_dims, elt_kind, layout), arg1 :: argl) ->
          let elt =
            bigarray_get elt_kind layout
              (transl arg1) (List.map transl argl) dbg in
          begin match elt_kind with
            Pbigarray_float32 | Pbigarray_float64 -> box_float elt
          | Pbigarray_complex32 | Pbigarray_complex64 -> elt
          | Pbigarray_int32 -> box_int Pint32 elt
          | Pbigarray_int64 -> box_int Pint64 elt
          | Pbigarray_native_int -> box_int Pnativeint elt
          | Pbigarray_caml_int -> force_tag_int elt
          | _ -> tag_int elt
          end
      | (Pbigarrayset(num_dims, elt_kind, layout), arg1 :: argl) ->
          let (argidx, argnewval) = split_last argl in
          return_unit(bigarray_set elt_kind layout
            (transl arg1)
            (List.map transl argidx)
            (match elt_kind with
              Pbigarray_float32 | Pbigarray_float64 ->
                transl_unbox_float argnewval
            | Pbigarray_complex32 | Pbigarray_complex64 -> transl argnewval
            | Pbigarray_int32 -> transl_unbox_int Pint32 argnewval
            | Pbigarray_int64 -> transl_unbox_int Pint64 argnewval
            | Pbigarray_native_int -> transl_unbox_int Pnativeint argnewval
            | _ -> untag_int (transl argnewval))
            dbg)
      | (p, [arg]) ->
          transl_prim_1 p arg dbg
      | (p, [arg1; arg2]) ->
          transl_prim_2 p arg1 arg2 dbg
      | (p, [arg1; arg2; arg3]) ->
          transl_prim_3 p arg1 arg2 arg3 dbg
      | (_, _) ->
          fatal_error "Cmmgen.transl:prim"
      end

  (* Control structures *)
  | Uswitch(arg, s) ->
      (* As in the bytecode interpreter, only matching against constants
         can be checked *)
      if Array.length s.us_index_blocks = 0 then
        Cswitch
          (untag_int (transl arg),
           s.us_index_consts,
           Array.map transl s.us_actions_consts)
      else if Array.length s.us_index_consts = 0 then
        transl_switch (get_tag (transl arg))
          s.us_index_blocks s.us_actions_blocks
      else
        bind "switch" (transl arg) (fun arg ->
          Cifthenelse(
          Cop(Cand, [arg; Cconst_int 1]),
          transl_switch
            (untag_int arg) s.us_index_consts s.us_actions_consts,
          transl_switch
            (get_tag arg) s.us_index_blocks s.us_actions_blocks))
  | Ustaticfail (nfail, args) ->
      Cexit (nfail, List.map transl args)
  | Ucatch(nfail, [], body, handler) ->
      make_catch nfail (transl body) (transl handler)
  | Ucatch(nfail, ids, body, handler) ->
      Ccatch(nfail, ids, transl body, transl handler)
  | Utrywith(body, exn, handler) ->
      Ctrywith(transl body, exn, transl handler)
  | Uifthenelse(Uprim(Pnot, [arg], _), ifso, ifnot) ->
      transl (Uifthenelse(arg, ifnot, ifso))
  | Uifthenelse(cond, ifso, Ustaticfail (nfail, [])) ->
      exit_if_false cond (transl ifso) nfail
  | Uifthenelse(cond, Ustaticfail (nfail, []), ifnot) ->
      exit_if_true cond nfail (transl ifnot)
  | Uifthenelse(Uprim(Psequand, _, _) as cond, ifso, ifnot) ->
      let raise_num = next_raise_count () in
      make_catch
        raise_num
        (exit_if_false cond (transl ifso) raise_num)
        (transl ifnot)
  | Uifthenelse(Uprim(Psequor, _, _) as cond, ifso, ifnot) ->
      let raise_num = next_raise_count () in
      make_catch
        raise_num
        (exit_if_true cond raise_num (transl ifnot))
        (transl ifso)
  | Uifthenelse (Uifthenelse (cond, condso, condnot), ifso, ifnot) ->
      let num_true = next_raise_count () in
      make_catch
        num_true
        (make_catch2
           (fun shared_false ->
             Cifthenelse
               (test_bool (transl cond),
                exit_if_true condso num_true shared_false,
                exit_if_true condnot num_true shared_false))
           (transl ifnot))
        (transl ifso)
  | Uifthenelse(cond, ifso, ifnot) ->
      Cifthenelse(test_bool(transl cond), transl ifso, transl ifnot)
  | Usequence(exp1, exp2) ->
      Csequence(remove_unit(transl exp1), transl exp2)
  | Uwhile(cond, body) ->
      let raise_num = next_raise_count () in
      return_unit
        (Ccatch
           (raise_num, [],
            Cloop(exit_if_false cond (remove_unit(transl body)) raise_num),
            Ctuple []))
  | Ufor(id, low, high, dir, body) ->
      let tst = match dir with Upto -> Cgt   | Downto -> Clt in
      let inc = match dir with Upto -> Caddi | Downto -> Csubi in
      let raise_num = next_raise_count () in
      let id_prev = Ident.rename id in
      return_unit
        (Clet
           (id, transl low,
            bind_nonvar "bound" (transl high) (fun high ->
              Ccatch
                (raise_num, [],
                 Cifthenelse
                   (Cop(Ccmpi tst, [Cvar id; high]), Cexit (raise_num, []),
                    Cloop
                      (Csequence
                         (remove_unit(transl body),
                         Clet(id_prev, Cvar id,
                          Csequence
                            (Cassign(id,
                               Cop(inc, [Cvar id; Cconst_int 2])),
                             Cifthenelse
                               (Cop(Ccmpi Ceq, [Cvar id_prev; high]),
                                Cexit (raise_num,[]), Ctuple [])))))),
                 Ctuple []))))
  | Uassign(id, exp) ->
      return_unit(Cassign(id, transl exp))

and transl_prim_1 p arg dbg =
  match p with
  (* Generic operations *)
    Pidentity ->
      transl arg
  | Pignore ->
      return_unit(remove_unit (transl arg))
  (* Heap operations *)
  | Pfield n ->
      get_field (transl arg) n
  | Pfloatfield n ->
      let ptr = transl arg in
      box_float(
        Cop(Cload Double_u,
            [if n = 0 then ptr
                       else Cop(Cadda, [ptr; Cconst_int(n * size_float)])]))
  (* Exceptions *)
  | Praise ->
      Cop(Craise dbg, [transl arg])
  (* Integer operations *)
  | Pnegint ->
      Cop(Csubi, [Cconst_int 2; transl arg])
  | Poffsetint n ->
      if no_overflow_lsl n then
        add_const (transl arg) (n lsl 1)
      else
        transl_prim_2 Paddint arg (Uconst (Const_base(Const_int n))) Debuginfo.none
  | Poffsetref n ->
      return_unit
        (bind "ref" (transl arg) (fun arg ->
          Cop(Cstore Word,
              [arg; add_const (Cop(Cload Word, [arg])) (n lsl 1)])))
  (* Floating-point operations *)
  | Pfloatofint ->
      box_float(Cop(Cfloatofint, [untag_int(transl arg)]))
  | Pintoffloat ->
     tag_int(Cop(Cintoffloat, [transl_unbox_float arg]))
  | Pnegfloat ->
      box_float(Cop(Cnegf, [transl_unbox_float arg]))
  | Pabsfloat ->
      box_float(Cop(Cabsf, [transl_unbox_float arg]))
  (* String operations *)
  | Pstringlength ->
      tag_int(string_length (transl arg))
  (* Array operations *)
  | Parraylength kind ->
      begin match kind with
        Pgenarray ->
          let len =
            if wordsize_shift = numfloat_shift then
              Cop(Clsr, [header(transl arg); Cconst_int wordsize_shift])
            else
              bind "header" (header(transl arg)) (fun hdr ->
                Cifthenelse(is_addr_array_hdr hdr,
                            Cop(Clsr, [hdr; Cconst_int wordsize_shift]),
                            Cop(Clsr, [hdr; Cconst_int numfloat_shift]))) in
          Cop(Cor, [len; Cconst_int 1])
      | Paddrarray | Pintarray ->
          Cop(Cor, [addr_array_length(header(transl arg)); Cconst_int 1])
      | Pfloatarray ->
          Cop(Cor, [float_array_length(header(transl arg)); Cconst_int 1])
      end
  (* Boolean operations *)
  | Pnot ->
      Cop(Csubi, [Cconst_int 4; transl arg]) (* 1 -> 3, 3 -> 1 *)
  (* Test integer/block *)
  | Pisint ->
      tag_int(Cop(Cand, [transl arg; Cconst_int 1]))
  (* Boxed integers *)
  | Pbintofint bi ->
      box_int bi (untag_int (transl arg))
  | Pintofbint bi ->
      force_tag_int (transl_unbox_int bi arg)
  | Pcvtbint(bi1, bi2) ->
      box_int bi2 (transl_unbox_int bi1 arg)
  | Pnegbint bi ->
      box_int bi (Cop(Csubi, [Cconst_int 0; transl_unbox_int bi arg]))
  | _ ->
      fatal_error "Cmmgen.transl_prim_1"

and transl_prim_2 p arg1 arg2 dbg =
  match p with
  (* Heap operations *)
    Psetfield(n, ptr) ->
      if ptr then
        return_unit(Cop(Cextcall("caml_modify", typ_void, false, Debuginfo.none),
                        [field_address (transl arg1) n; transl arg2]))
      else
        return_unit(set_field (transl arg1) n (transl arg2))
  | Psetfloatfield n ->
      let ptr = transl arg1 in
      return_unit(
        Cop(Cstore Double_u,
            [if n = 0 then ptr
                       else Cop(Cadda, [ptr; Cconst_int(n * size_float)]);
                   transl_unbox_float arg2]))

  (* Boolean operations *)
  | Psequand ->
      Cifthenelse(test_bool(transl arg1), transl arg2, Cconst_int 1)
      (* let id = Ident.create "res1" in
      Clet(id, transl arg1,
           Cifthenelse(test_bool(Cvar id), transl arg2, Cvar id)) *)
  | Psequor ->
      Cifthenelse(test_bool(transl arg1), Cconst_int 3, transl arg2)

  (* Integer operations *)
  | Paddint ->
      decr_int(add_int (transl arg1) (transl arg2))
  | Psubint ->
      incr_int(sub_int (transl arg1) (transl arg2))
  | Pmulint ->
      incr_int(Cop(Cmuli, [decr_int(transl arg1); untag_int(transl arg2)]))
  | Pdivint ->
      tag_int(safe_divmod Cdivi (untag_int(transl arg1)) (untag_int(transl arg2)) dbg)
  | Pmodint ->
      tag_int(safe_divmod Cmodi (untag_int(transl arg1)) (untag_int(transl arg2)) dbg)
  | Pandint ->
      Cop(Cand, [transl arg1; transl arg2])
  | Porint ->
      Cop(Cor, [transl arg1; transl arg2])
  | Pxorint ->
      Cop(Cor, [Cop(Cxor, [ignore_low_bit_int(transl arg1);
                           ignore_low_bit_int(transl arg2)]);
                Cconst_int 1])
  | Plslint ->
      incr_int(lsl_int (decr_int(transl arg1)) (untag_int(transl arg2)))
  | Plsrint ->
      Cop(Cor, [Cop(Clsr, [transl arg1; untag_int(transl arg2)]);
                Cconst_int 1])
  | Pasrint ->
      Cop(Cor, [Cop(Casr, [transl arg1; untag_int(transl arg2)]);
                Cconst_int 1])
  | Pintcomp cmp ->
      tag_int(Cop(Ccmpi(transl_comparison cmp), [transl arg1; transl arg2]))
  | Pisout ->
      transl_isout (transl arg1) (transl arg2)
  (* Float operations *)
  | Paddfloat ->
      box_float(Cop(Caddf,
                    [transl_unbox_float arg1; transl_unbox_float arg2]))
  | Psubfloat ->
      box_float(Cop(Csubf,
                    [transl_unbox_float arg1; transl_unbox_float arg2]))
  | Pmulfloat ->
      box_float(Cop(Cmulf,
                    [transl_unbox_float arg1; transl_unbox_float arg2]))
  | Pdivfloat ->
      box_float(Cop(Cdivf,
                    [transl_unbox_float arg1; transl_unbox_float arg2]))
  | Pfloatcomp cmp ->
      tag_int(Cop(Ccmpf(transl_comparison cmp),
                  [transl_unbox_float arg1; transl_unbox_float arg2]))

  (* String operations *)
  | Pstringrefu ->
      tag_int(Cop(Cload Byte_unsigned,
                  [add_int (transl arg1) (untag_int(transl arg2))]))
  | Pstringrefs ->
      tag_int
        (bind "str" (transl arg1) (fun str ->
          bind "index" (untag_int (transl arg2)) (fun idx ->
            Csequence(
              Cop(Ccheckbound dbg, [string_length str; idx]),
              Cop(Cload Byte_unsigned, [add_int str idx])))))

  (* Array operations *)
  | Parrayrefu kind ->
      begin match kind with
        Pgenarray ->
          bind "arr" (transl arg1) (fun arr ->
            bind "index" (transl arg2) (fun idx ->
              Cifthenelse(is_addr_array_ptr arr,
                          addr_array_ref arr idx,
                          float_array_ref arr idx)))
      | Paddrarray | Pintarray ->
          addr_array_ref (transl arg1) (transl arg2)
      | Pfloatarray ->
          float_array_ref (transl arg1) (transl arg2)
      end
  | Parrayrefs kind ->
      begin match kind with
        Pgenarray ->
          bind "index" (transl arg2) (fun idx ->
            bind "arr" (transl arg1) (fun arr ->
              bind "header" (header arr) (fun hdr ->
                Cifthenelse(is_addr_array_hdr hdr,
                  Csequence(Cop(Ccheckbound dbg, [addr_array_length hdr; idx]),
                            addr_array_ref arr idx),
                  Csequence(Cop(Ccheckbound dbg, [float_array_length hdr; idx]),
                            float_array_ref arr idx)))))
      | Paddrarray | Pintarray ->
          bind "index" (transl arg2) (fun idx ->
            bind "arr" (transl arg1) (fun arr ->
              Csequence(Cop(Ccheckbound dbg, [addr_array_length(header arr); idx]),
                        addr_array_ref arr idx)))
      | Pfloatarray ->
          box_float(
            bind "index" (transl arg2) (fun idx ->
              bind "arr" (transl arg1) (fun arr ->
                Csequence(Cop(Ccheckbound dbg,
                              [float_array_length(header arr); idx]),
                          unboxed_float_array_ref arr idx))))
      end

  (* Operations on bitvects *)
  | Pbittest ->
      bind "index" (untag_int(transl arg2)) (fun idx ->
        tag_int(
          Cop(Cand, [Cop(Clsr, [Cop(Cload Byte_unsigned,
                                    [add_int (transl arg1)
                                      (Cop(Clsr, [idx; Cconst_int 3]))]);
                                Cop(Cand, [idx; Cconst_int 7])]);
                     Cconst_int 1])))

  (* Boxed integers *)
  | Paddbint bi ->
      box_int bi (Cop(Caddi,
                      [transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
  | Psubbint bi ->
      box_int bi (Cop(Csubi,
                      [transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
  | Pmulbint bi ->
      box_int bi (Cop(Cmuli,
                      [transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
  | Pdivbint bi ->
      box_int bi (safe_divmod Cdivi
                      (transl_unbox_int bi arg1) (transl_unbox_int bi arg2)
                      dbg)
  | Pmodbint bi ->
      box_int bi (safe_divmod Cmodi
                      (transl_unbox_int bi arg1) (transl_unbox_int bi arg2)
                      dbg)
  | Pandbint bi ->
      box_int bi (Cop(Cand,
                     [transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
  | Porbint bi ->
      box_int bi (Cop(Cor,
                     [transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
  | Pxorbint bi ->
      box_int bi (Cop(Cxor,
                     [transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
  | Plslbint bi ->
      box_int bi (Cop(Clsl,
                     [transl_unbox_int bi arg1; untag_int(transl arg2)]))
  | Plsrbint bi ->
      box_int bi (Cop(Clsr,
                     [make_unsigned_int bi (transl_unbox_int bi arg1);
                      untag_int(transl arg2)]))
  | Pasrbint bi ->
      box_int bi (Cop(Casr,
                     [transl_unbox_int bi arg1; untag_int(transl arg2)]))
  | Pbintcomp(bi, cmp) ->
      tag_int (Cop(Ccmpi(transl_comparison cmp),
                     [transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
  | _ ->
      fatal_error "Cmmgen.transl_prim_2"

and transl_prim_3 p arg1 arg2 arg3 dbg =
  match p with
  (* String operations *)
    Pstringsetu ->
      return_unit(Cop(Cstore Byte_unsigned,
                      [add_int (transl arg1) (untag_int(transl arg2));
                        untag_int(transl arg3)]))
  | Pstringsets ->
      return_unit
        (bind "str" (transl arg1) (fun str ->
          bind "index" (untag_int (transl arg2)) (fun idx ->
            Csequence(
              Cop(Ccheckbound dbg, [string_length str; idx]),
              Cop(Cstore Byte_unsigned,
                  [add_int str idx; untag_int(transl arg3)])))))

  (* Array operations *)
  | Parraysetu kind ->
      return_unit(begin match kind with
        Pgenarray ->
          bind "newval" (transl arg3) (fun newval ->
            bind "index" (transl arg2) (fun index ->
              bind "arr" (transl arg1) (fun arr ->
                Cifthenelse(is_addr_array_ptr arr,
                            addr_array_set arr index newval,
                            float_array_set arr index (unbox_float newval)))))
      | Paddrarray ->
          addr_array_set (transl arg1) (transl arg2) (transl arg3)
      | Pintarray ->
          int_array_set (transl arg1) (transl arg2) (transl arg3)
      | Pfloatarray ->
          float_array_set (transl arg1) (transl arg2) (transl_unbox_float arg3)
      end)
  | Parraysets kind ->
      return_unit(begin match kind with
        Pgenarray ->
          bind "newval" (transl arg3) (fun newval ->
            bind "index" (transl arg2) (fun idx ->
              bind "arr" (transl arg1) (fun arr ->
                bind "header" (header arr) (fun hdr ->
                  Cifthenelse(is_addr_array_hdr hdr,
                    Csequence(Cop(Ccheckbound dbg, [addr_array_length hdr; idx]),
                              addr_array_set arr idx newval),
                    Csequence(Cop(Ccheckbound dbg, [float_array_length hdr; idx]),
                              float_array_set arr idx
                                              (unbox_float newval)))))))
      | Paddrarray ->
          bind "index" (transl arg2) (fun idx ->
            bind "arr" (transl arg1) (fun arr ->
              Csequence(Cop(Ccheckbound dbg, [addr_array_length(header arr); idx]),
                        addr_array_set arr idx (transl arg3))))
      | Pintarray ->
          bind "index" (transl arg2) (fun idx ->
            bind "arr" (transl arg1) (fun arr ->
              Csequence(Cop(Ccheckbound dbg, [addr_array_length(header arr); idx]),
                        int_array_set arr idx (transl arg3))))
      | Pfloatarray ->
          bind "index" (transl arg2) (fun idx ->
            bind "arr" (transl arg1) (fun arr ->
              Csequence(Cop(Ccheckbound dbg, [float_array_length(header arr);idx]),
                        float_array_set arr idx (transl_unbox_float arg3))))
      end)
  | _ ->
    fatal_error "Cmmgen.transl_prim_3"

and transl_unbox_float = function
    Uconst(Const_base(Const_float f)) -> Cconst_float f
  | exp -> unbox_float(transl exp)

and transl_unbox_int bi = function
    Uconst(Const_base(Const_int32 n)) ->
      Cconst_natint (Nativeint.of_int32 n)
  | Uconst(Const_base(Const_nativeint n)) ->
      Cconst_natint n
  | Uconst(Const_base(Const_int64 n)) ->
      assert (size_int = 8); Cconst_natint (Int64.to_nativeint n)
  | Uprim(Pbintofint bi', [Uconst(Const_base(Const_int i))], _) when bi = bi' ->
      Cconst_int i
  | exp -> unbox_int bi (transl exp)

and transl_unbox_let box_fn unbox_fn transl_unbox_fn id exp body =
  let unboxed_id = Ident.create (Ident.name id) in
  let trbody1 = transl body in
  let (trbody2, need_boxed, is_assigned) =
    subst_boxed_number unbox_fn id unboxed_id trbody1 in
  if need_boxed && is_assigned then
    Clet(id, transl exp, trbody1)
  else
    Clet(unboxed_id, transl_unbox_fn exp,
         if need_boxed
         then Clet(id, box_fn(Cvar unboxed_id), trbody2)
         else trbody2)

and make_catch ncatch body handler = match body with
| Cexit (nexit,[]) when nexit=ncatch -> handler
| _ ->  Ccatch (ncatch, [], body, handler)

and make_catch2 mk_body handler = match handler with
| Cexit (_,[])|Ctuple []|Cconst_int _|Cconst_pointer _ ->
    mk_body handler
| _ ->
    let nfail = next_raise_count () in
    make_catch
      nfail
      (mk_body (Cexit (nfail,[])))
      handler

and exit_if_true cond nfail otherwise =
  match cond with
  | Uconst (Const_pointer 0) -> otherwise
  | Uconst (Const_pointer 1) -> Cexit (nfail,[])
  | Uprim(Psequor, [arg1; arg2], _) ->
      exit_if_true arg1 nfail (exit_if_true arg2 nfail otherwise)
  | Uprim(Psequand, _, _) ->
      begin match otherwise with
      | Cexit (raise_num,[]) ->
          exit_if_false cond (Cexit (nfail,[])) raise_num
      | _ ->
          let raise_num = next_raise_count () in
          make_catch
            raise_num
            (exit_if_false cond (Cexit (nfail,[])) raise_num)
            otherwise
      end
  | Uprim(Pnot, [arg], _) ->
      exit_if_false arg otherwise nfail
  | Uifthenelse (cond, ifso, ifnot) ->
      make_catch2
        (fun shared ->
          Cifthenelse
            (test_bool (transl cond),
             exit_if_true ifso nfail shared,
             exit_if_true ifnot nfail shared))
        otherwise
  | _ ->
      Cifthenelse(test_bool(transl cond), Cexit (nfail, []), otherwise)

and exit_if_false cond otherwise nfail =
  match cond with
  | Uconst (Const_pointer 0) -> Cexit (nfail,[])
  | Uconst (Const_pointer 1) -> otherwise
  | Uprim(Psequand, [arg1; arg2], _) ->
      exit_if_false arg1 (exit_if_false arg2 otherwise nfail) nfail
  | Uprim(Psequor, _, _) ->
      begin match otherwise with
      | Cexit (raise_num,[]) ->
          exit_if_true cond raise_num (Cexit (nfail,[]))
      | _ ->
          let raise_num = next_raise_count () in
          make_catch
            raise_num
            (exit_if_true cond raise_num (Cexit (nfail,[])))
            otherwise
      end
  | Uprim(Pnot, [arg], _) ->
      exit_if_true arg nfail otherwise
  | Uifthenelse (cond, ifso, ifnot) ->
      make_catch2
        (fun shared ->
          Cifthenelse
            (test_bool (transl cond),
             exit_if_false ifso shared nfail,
             exit_if_false ifnot shared nfail))
        otherwise
  | _ ->
      Cifthenelse(test_bool(transl cond), otherwise, Cexit (nfail, []))

and transl_switch arg index cases = match Array.length cases with
| 0 -> fatal_error "Cmmgen.transl_switch"
| 1 -> transl cases.(0)
| _ ->
    let n_index = Array.length index in
    let actions = Array.map transl cases in

    let inters = ref []
    and this_high = ref (n_index-1)
    and this_low = ref (n_index-1)
    and this_act = ref index.(n_index-1) in
    for i = n_index-2 downto 0 do
      let act = index.(i) in
      if act = !this_act then
        decr this_low
      else begin
        inters := (!this_low, !this_high, !this_act) :: !inters ;
        this_high := i ;
        this_low := i ;
        this_act := act
      end
    done ;
    inters := (0, !this_high, !this_act) :: !inters ;
    bind "switcher" arg
      (fun a ->
        SwitcherBlocks.zyva
          (0,n_index-1)
          (fun i -> Cconst_int i)
          a
          (Array.of_list !inters) actions)

and transl_letrec bindings cont =
  let bsz = List.map (fun (id, exp) -> (id, exp, expr_size exp)) bindings in
  let rec init_blocks = function
    | [] -> fill_nonrec bsz
    | (id, exp, RHS_block sz) :: rem ->
        Clet(id, Cop(Cextcall("caml_alloc_dummy", typ_addr, true, Debuginfo.none),
                     [int_const sz]),
             init_blocks rem)
    | (id, exp, RHS_nonrec) :: rem ->
        Clet (id, Cconst_int 0, init_blocks rem)
  and fill_nonrec = function
    | [] -> fill_blocks bsz
    | (id, exp, RHS_block sz) :: rem -> fill_nonrec rem
    | (id, exp, RHS_nonrec) :: rem ->
        Clet (id, transl exp, fill_nonrec rem)
  and fill_blocks = function
    | [] -> cont
    | (id, exp, RHS_block _) :: rem ->
        Csequence(Cop(Cextcall("caml_update_dummy", typ_void, false, Debuginfo.none),
                      [Cvar id; transl exp]),
                  fill_blocks rem)
    | (id, exp, RHS_nonrec) :: rem ->
        fill_blocks rem
  in init_blocks bsz

(* Translate a function definition *)

let transl_function lbl params body =
  Cfunction {fun_name = lbl;
             fun_args = List.map (fun id -> (id, typ_addr)) params;
             fun_body = transl body;
             fun_fast = !Clflags.optimize_for_speed}

(* Translate all function definitions *)

module StringSet =
  Set.Make(struct
    type t = string
    let compare = compare
  end)

let rec transl_all_functions already_translated cont =
  try
    let (lbl, params, body) = Queue.take functions in
    if StringSet.mem lbl already_translated then
      transl_all_functions already_translated cont
    else begin
      transl_all_functions (StringSet.add lbl already_translated)
                           (transl_function lbl params body :: cont)
    end
  with Queue.Empty ->
    cont

(* Emit structured constants *)

let immstrings = Hashtbl.create 17

let rec emit_constant symb cst cont =
  match cst with
    Const_base(Const_float s) ->
      Cint(float_header) :: Cdefine_symbol symb :: Cdouble s :: cont
  | Const_base(Const_string s) | Const_immstring s ->
      Cint(string_header (String.length s)) ::
      Cdefine_symbol symb ::
      emit_string_constant s cont
  | Const_base(Const_int32 n) ->
      Cint(boxedint_header) :: Cdefine_symbol symb ::
      emit_boxed_int32_constant n cont
  | Const_base(Const_int64 n) ->
      Cint(boxedint_header) :: Cdefine_symbol symb ::
      emit_boxed_int64_constant n cont
  | Const_base(Const_nativeint n) ->
      Cint(boxedint_header) :: Cdefine_symbol symb ::
      emit_boxed_nativeint_constant n cont
  | Const_block(tag, fields) ->
      let (emit_fields, cont1) = emit_constant_fields fields cont in
      Cint(block_header tag (List.length fields)) ::
      Cdefine_symbol symb ::
      emit_fields @ cont1
  | Const_float_array(fields) ->
      Cint(floatarray_header (List.length fields)) ::
      Cdefine_symbol symb ::
      Misc.map_end (fun f -> Cdouble f) fields cont
  | _ -> fatal_error "gencmm.emit_constant"

and emit_constant_fields fields cont =
  match fields with
    [] -> ([], cont)
  | f1 :: fl ->
      let (data1, cont1) = emit_constant_field f1 cont in
      let (datal, contl) = emit_constant_fields fl cont1 in
      (data1 :: datal, contl)

and emit_constant_field field cont =
  match field with
    Const_base(Const_int n) ->
      (Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n),
       cont)
  | Const_base(Const_char c) ->
      (Cint(Nativeint.of_int(((Char.code c) lsl 1) + 1)), cont)
  | Const_base(Const_float s) ->
      let lbl = new_const_label() in
      (Clabel_address lbl,
       Cint(float_header) :: Cdefine_label lbl :: Cdouble s :: cont)
  | Const_base(Const_string s) ->
      let lbl = new_const_label() in
      (Clabel_address lbl,
       Cint(string_header (String.length s)) :: Cdefine_label lbl ::
       emit_string_constant s cont)
  | Const_immstring s ->
      begin try
        (Clabel_address (Hashtbl.find immstrings s), cont)
      with Not_found ->
        let lbl = new_const_label() in
        Hashtbl.add immstrings s lbl;
        (Clabel_address lbl,
         Cint(string_header (String.length s)) :: Cdefine_label lbl ::
         emit_string_constant s cont)
      end
  | Const_base(Const_int32 n) ->
      let lbl = new_const_label() in
      (Clabel_address lbl,
       Cint(boxedint_header) :: Cdefine_label lbl ::
       emit_boxed_int32_constant n cont)
  | Const_base(Const_int64 n) ->
      let lbl = new_const_label() in
      (Clabel_address lbl,
       Cint(boxedint_header) :: Cdefine_label lbl ::
       emit_boxed_int64_constant n cont)
  | Const_base(Const_nativeint n) ->
      let lbl = new_const_label() in
      (Clabel_address lbl,
       Cint(boxedint_header) :: Cdefine_label lbl ::
       emit_boxed_nativeint_constant n cont)
  | Const_pointer n ->
      (Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n),
       cont)
  | Const_block(tag, fields) ->
      let lbl = new_const_label() in
      let (emit_fields, cont1) = emit_constant_fields fields cont in
      (Clabel_address lbl,
       Cint(block_header tag (List.length fields)) :: Cdefine_label lbl ::
       emit_fields @ cont1)
  | Const_float_array(fields) ->
      let lbl = new_const_label() in
      (Clabel_address lbl,
       Cint(floatarray_header (List.length fields)) :: Cdefine_label lbl ::
       Misc.map_end (fun f -> Cdouble f) fields cont)

and emit_string_constant s cont =
  let n = size_int - 1 - (String.length s) mod size_int in
  Cstring s :: Cskip n :: Cint8 n :: cont

and emit_boxed_int32_constant n cont =
  let n = Nativeint.of_int32 n in
  if size_int = 8 then
    Csymbol_address("caml_int32_ops") :: Cint32 n :: Cint32 0n :: cont
  else
    Csymbol_address("caml_int32_ops") :: Cint n :: cont

and emit_boxed_nativeint_constant n cont =
  Csymbol_address("caml_nativeint_ops") :: Cint n :: cont

and emit_boxed_int64_constant n cont =
  let lo = Int64.to_nativeint n in
  if size_int = 8 then
    Csymbol_address("caml_int64_ops") :: Cint lo :: cont
  else begin
    let hi = Int64.to_nativeint (Int64.shift_right n 32) in
    if big_endian then
      Csymbol_address("caml_int64_ops") :: Cint hi :: Cint lo :: cont
    else
      Csymbol_address("caml_int64_ops") :: Cint lo :: Cint hi :: cont
  end

(* Emit constant closures *)

let emit_constant_closure symb fundecls cont =
  match fundecls with
    [] -> assert false
  | (label, arity, params, body) :: remainder ->
      let rec emit_others pos = function
        [] -> cont
      | (label, arity, params, body) :: rem ->
          if arity = 1 then
            Cint(infix_header pos) ::
            Csymbol_address label ::
            Cint 3n ::
            emit_others (pos + 3) rem
          else
            Cint(infix_header pos) ::
            Csymbol_address(curry_function arity) ::
            Cint(Nativeint.of_int (arity lsl 1 + 1)) ::
            Csymbol_address label ::
            emit_others (pos + 4) rem in
      Cint(closure_header (fundecls_size fundecls)) ::
      Cdefine_symbol symb ::
      if arity = 1 then
        Csymbol_address label ::
        Cint 3n ::
        emit_others 3 remainder
      else
        Csymbol_address(curry_function arity) ::
        Cint(Nativeint.of_int (arity lsl 1 + 1)) ::
        Csymbol_address label ::
        emit_others 4 remainder

(* Emit all structured constants *)

let emit_all_constants cont =
  let c = ref cont in
  List.iter
    (fun (lbl, cst) -> c := Cdata(emit_constant lbl cst []) :: !c)
    !structured_constants;
  structured_constants := [];
  Hashtbl.clear immstrings;   (* PR#3979 *)
  List.iter
    (fun (symb, fundecls) ->
        c := Cdata(emit_constant_closure symb fundecls []) :: !c)
    !constant_closures;
  constant_closures := [];
  !c

(* Translate a compilation unit *)

let compunit size ulam =
  let glob = Compilenv.make_symbol None in
  let init_code = transl ulam in
  let c1 = [Cfunction {fun_name = Compilenv.make_symbol (Some "entry");
                       fun_args = [];
                       fun_body = init_code; fun_fast = false}] in
  let c2 = transl_all_functions StringSet.empty c1 in
  let c3 = emit_all_constants c2 in
  Cdata [Cint(block_header 0 size);
         Cglobal_symbol glob;
         Cdefine_symbol glob;
         Cskip(size * size_addr)] :: c3

(*
CAMLprim value caml_cache_public_method (value meths, value tag, value *cache)
{
  int li = 3, hi = Field(meths,0), mi;
  while (li < hi) { // no need to check the 1st time
    mi = ((li+hi) >> 1) | 1;
    if (tag < Field(meths,mi)) hi = mi-2;
    else li = mi;
  }
  *cache = (li-3)*sizeof(value)+1;
  return Field (meths, li-1);
}
*)

let cache_public_method meths tag cache =
  let raise_num = next_raise_count () in
  let li = Ident.create "li" and hi = Ident.create "hi"
  and mi = Ident.create "mi" and tagged = Ident.create "tagged" in
  Clet (
  li, Cconst_int 3,
  Clet (
  hi, Cop(Cload Word, [meths]),
  Csequence(
  Ccatch
    (raise_num, [],
     Cloop
       (Clet(
        mi,
        Cop(Cor,
            [Cop(Clsr, [Cop(Caddi, [Cvar li; Cvar hi]); Cconst_int 1]);
             Cconst_int 1]),
        Csequence(
        Cifthenelse
          (Cop (Ccmpi Clt,
                [tag;
                 Cop(Cload Word,
                     [Cop(Cadda,
                          [meths; lsl_const (Cvar mi) log2_size_addr])])]),
           Cassign(hi, Cop(Csubi, [Cvar mi; Cconst_int 2])),
           Cassign(li, Cvar mi)),
        Cifthenelse
          (Cop(Ccmpi Cge, [Cvar li; Cvar hi]), Cexit (raise_num, []),
           Ctuple [])))),
     Ctuple []),
  Clet (
  tagged, Cop(Cadda, [lsl_const (Cvar li) log2_size_addr;
                      Cconst_int(1 - 3 * size_addr)]),
  Csequence(Cop (Cstore Word, [cache; Cvar tagged]),
            Cvar tagged)))))

(* Generate an application function:
     (defun caml_applyN (a1 ... aN clos)
       (if (= clos.arity N)
         (app clos.direct a1 ... aN clos)
         (let (clos1 (app clos.code a1 clos)
               clos2 (app clos1.code a2 clos)
               ...
               closN-1 (app closN-2.code aN-1 closN-2))
           (app closN-1.code aN closN-1))))
*)

let apply_function_body arity =
  let arg = Array.create arity (Ident.create "arg") in
  for i = 1 to arity - 1 do arg.(i) <- Ident.create "arg" done;
  let clos = Ident.create "clos" in
  let rec app_fun clos n =
    if n = arity-1 then
      Cop(Capply(typ_addr, Debuginfo.none),
          [get_field (Cvar clos) 0; Cvar arg.(n); Cvar clos])
    else begin
      let newclos = Ident.create "clos" in
      Clet(newclos,
           Cop(Capply(typ_addr, Debuginfo.none),
               [get_field (Cvar clos) 0; Cvar arg.(n); Cvar clos]),
           app_fun newclos (n+1))
    end in
  let args = Array.to_list arg in
  let all_args = args @ [clos] in
  (args, clos,
   if arity = 1 then app_fun clos 0 else
   Cifthenelse(
   Cop(Ccmpi Ceq, [get_field (Cvar clos) 1; int_const arity]),
   Cop(Capply(typ_addr, Debuginfo.none),
       get_field (Cvar clos) 2 :: List.map (fun s -> Cvar s) all_args),
   app_fun clos 0))

let send_function arity =
  let (args, clos', body) = apply_function_body (1+arity) in
  let cache = Ident.create "cache"
  and obj = List.hd args
  and tag = Ident.create "tag" in
  let clos =
    let cache = Cvar cache and obj = Cvar obj and tag = Cvar tag in
    let meths = Ident.create "meths" and cached = Ident.create "cached" in
    let real = Ident.create "real" in
    let mask = get_field (Cvar meths) 1 in
    let cached_pos = Cvar cached in
    let tag_pos = Cop(Cadda, [Cop (Cadda, [cached_pos; Cvar meths]);
                              Cconst_int(3*size_addr-1)]) in
    let tag' = Cop(Cload Word, [tag_pos]) in
    Clet (
    meths, Cop(Cload Word, [obj]),
    Clet (
    cached, Cop(Cand, [Cop(Cload Word, [cache]); mask]),
    Clet (
    real,
    Cifthenelse(Cop(Ccmpa Cne, [tag'; tag]),
                cache_public_method (Cvar meths) tag cache,
                cached_pos),
    Cop(Cload Word, [Cop(Cadda, [Cop (Cadda, [Cvar real; Cvar meths]);
                                 Cconst_int(2*size_addr-1)])]))))

  in
  let body = Clet(clos', clos, body) in
  let fun_args =
    [obj, typ_addr; tag, typ_int; cache, typ_addr]
    @ List.map (fun id -> (id, typ_addr)) (List.tl args) in
  Cfunction
   {fun_name = "caml_send" ^ string_of_int arity;
    fun_args = fun_args;
    fun_body = body;
    fun_fast = true}

let apply_function arity =
  let (args, clos, body) = apply_function_body arity in
  let all_args = args @ [clos] in
  Cfunction
   {fun_name = "caml_apply" ^ string_of_int arity;
    fun_args = List.map (fun id -> (id, typ_addr)) all_args;
    fun_body = body;
    fun_fast = true}

(* Generate tuplifying functions:
      (defun caml_tuplifyN (arg clos)
        (app clos.direct #0(arg) ... #N-1(arg) clos)) *)

let tuplify_function arity =
  let arg = Ident.create "arg" in
  let clos = Ident.create "clos" in
  let rec access_components i =
    if i >= arity
    then []
    else get_field (Cvar arg) i :: access_components(i+1) in
  Cfunction
   {fun_name = "caml_tuplify" ^ string_of_int arity;
    fun_args = [arg, typ_addr; clos, typ_addr];
    fun_body =
      Cop(Capply(typ_addr, Debuginfo.none),
          get_field (Cvar clos) 2 :: access_components 0 @ [Cvar clos]);
    fun_fast = true}

(* Generate currying functions:
      (defun caml_curryN (arg clos)
         (alloc HDR caml_curryN_1 arg clos))
      (defun caml_curryN_1 (arg clos)
         (alloc HDR caml_curryN_2 arg clos))
      ...
      (defun caml_curryN_N-1 (arg clos)
         (let (closN-2 clos.cdr
               closN-3 closN-2.cdr
               ...
               clos1 clos2.cdr
               clos clos1.cdr)
           (app clos.direct
                clos1.car clos2.car ... closN-2.car clos.car arg clos))) *)

let final_curry_function arity =
  let last_arg = Ident.create "arg" in
  let last_clos = Ident.create "clos" in
  let rec curry_fun args clos n =
    if n = 0 then
      Cop(Capply(typ_addr, Debuginfo.none),
          get_field (Cvar clos) 2 ::
          args @ [Cvar last_arg; Cvar clos])
    else begin
      let newclos = Ident.create "clos" in
      Clet(newclos,
           get_field (Cvar clos) 3,
           curry_fun (get_field (Cvar clos) 2 :: args) newclos (n-1))
    end in
  Cfunction
   {fun_name = "caml_curry" ^ string_of_int arity ^
               "_" ^ string_of_int (arity-1);
    fun_args = [last_arg, typ_addr; last_clos, typ_addr];
    fun_body = curry_fun [] last_clos (arity-1);
    fun_fast = true}

let rec intermediate_curry_functions arity num =
  if num = arity - 1 then
    [final_curry_function arity]
  else begin
    let name1 = "caml_curry" ^ string_of_int arity in
    let name2 = if num = 0 then name1 else name1 ^ "_" ^ string_of_int num in
    let arg = Ident.create "arg" and clos = Ident.create "clos" in
    Cfunction
     {fun_name = name2;
      fun_args = [arg, typ_addr; clos, typ_addr];
      fun_body = Cop(Calloc,
                     [alloc_closure_header 4;
                      Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1));
                      int_const 1; Cvar arg; Cvar clos]);
      fun_fast = true}
    :: intermediate_curry_functions arity (num+1)
  end

let curry_function arity =
  if arity >= 0
  then intermediate_curry_functions arity 0
  else [tuplify_function (-arity)]


module IntSet = Set.Make(
  struct
    type t = int
    let compare = compare
  end)

let default_apply = IntSet.add 2 (IntSet.add 3 IntSet.empty)
  (* These apply funs are always present in the main program.
     TODO: add more, and do the same for send and curry funs
     (maybe up to 10-15?). *)

let generic_functions shared units =
  let (apply,send,curry) =
    List.fold_left
      (fun (apply,send,curry) ui ->
	 List.fold_right IntSet.add ui.Compilenv.ui_apply_fun apply,
	 List.fold_right IntSet.add ui.Compilenv.ui_send_fun send,
	 List.fold_right IntSet.add ui.Compilenv.ui_curry_fun curry)
      (IntSet.empty,IntSet.empty,IntSet.empty)
      units
  in
  let apply =
    if shared then IntSet.diff apply default_apply
    else IntSet.union apply default_apply
  in
  let accu = IntSet.fold (fun n accu -> apply_function n :: accu) apply [] in
  let accu = IntSet.fold (fun n accu -> send_function n :: accu) send accu in
  IntSet.fold (fun n accu -> curry_function n @ accu) curry accu

(* Generate the entry point *)

let entry_point namelist =
  let incr_global_inited =
    Cop(Cstore Word,
        [Cconst_symbol "caml_globals_inited";
         Cop(Caddi, [Cop(Cload Word, [Cconst_symbol "caml_globals_inited"]);
                     Cconst_int 1])]) in
  let body =
    List.fold_right
      (fun name next ->
        let entry_sym = Compilenv.make_symbol ~unitname:name (Some "entry") in
        Csequence(Cop(Capply(typ_void, Debuginfo.none),
                         [Cconst_symbol entry_sym]),
                  Csequence(incr_global_inited, next)))
      namelist (Cconst_int 1) in
  Cfunction {fun_name = "caml_program";
             fun_args = [];
             fun_body = body;
             fun_fast = false}

(* Generate the table of globals *)

let cint_zero = Cint 0n

let global_table namelist =
  let mksym name =
    Csymbol_address (Compilenv.make_symbol ~unitname:name None)
  in
  Cdata(Cglobal_symbol "caml_globals" ::
        Cdefine_symbol "caml_globals" ::
        List.map mksym namelist @
        [cint_zero])

let reference_symbols namelist =
  let mksym name = Csymbol_address name in
  Cdata(List.map mksym namelist)

let global_data name v =
  Cdata(Cglobal_symbol name ::
          emit_constant name
          (Const_base (Const_string (Marshal.to_string v []))) [])

let globals_map v = global_data "caml_globals_map" v

(* Generate the master table of frame descriptors *)

let frame_table namelist =
  let mksym name =
    Csymbol_address (Compilenv.make_symbol ~unitname:name (Some "frametable"))
  in
  Cdata(Cglobal_symbol "caml_frametable" ::
        Cdefine_symbol "caml_frametable" ::
        List.map mksym namelist
        @ [cint_zero])

(* Generate the table of module data and code segments *)

let segment_table namelist symbol begname endname =
  let addsyms name lst =
    Csymbol_address (Compilenv.make_symbol ~unitname:name (Some begname)) ::
    Csymbol_address (Compilenv.make_symbol ~unitname:name (Some endname)) ::
    lst
  in
  Cdata(Cglobal_symbol symbol ::
        Cdefine_symbol symbol ::
        List.fold_right addsyms namelist [cint_zero])

let data_segment_table namelist =
  segment_table namelist "caml_data_segments" "data_begin" "data_end"

let code_segment_table namelist =
  segment_table namelist "caml_code_segments" "code_begin" "code_end"

(* Initialize a predefined exception *)

let predef_exception name =
  let bucketname = "caml_bucket_" ^ name in
  let symname = "caml_exn_" ^ name in
  Cdata(Cglobal_symbol symname ::
        emit_constant symname (Const_block(0,[Const_base(Const_string name)]))
        [ Cglobal_symbol bucketname;
          Cint(block_header 0 1);
          Cdefine_symbol bucketname;
          Csymbol_address symname ])

(* Header for a plugin *)

let mapflat f l = List.flatten (List.map f l)

type dynunit = {
  name: string;
  crc: Digest.t;
  imports_cmi: (string * Digest.t) list;
  imports_cmx: (string * Digest.t) list;
  defines: string list;
}

type dynheader = {
  magic: string;
  units: dynunit list;
}

let dyn_magic_number = "Caml2007D001"

let plugin_header units =
  let mk (ui,crc) =
    { name = ui.Compilenv.ui_name;
      crc = crc;
      imports_cmi = ui.Compilenv.ui_imports_cmi;
      imports_cmx = ui.Compilenv.ui_imports_cmx;
      defines = ui.Compilenv.ui_defines 
    } in
  global_data "caml_plugin_header"
    { magic = dyn_magic_number; units = List.map mk units }