l4/pkg/ocaml/contrib/asmcomp/cmmgen.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the Q Public License version 1.0.               *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id: cmmgen.ml 9167 2009-01-26 17:06:10Z xleroy $ *)
  14
  15 (* Translation from closed lambda to C-- *)
  16
  17 open Misc
  18 open Arch
  19 open Asttypes
  20 open Primitive
  21 open Types
  22 open Lambda
  23 open Clambda
  24 open Cmm
  25
  26 (* Local binding of complex expressions *)
  27
  28 let bind name arg fn =
  29   match arg with
  30     Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _
  31   | Cconst_pointer _ | Cconst_natpointer _ -> fn arg
  32   | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id))
  33
  34 let bind_nonvar name arg fn =
  35   match arg with
  36     Cconst_int _ | Cconst_natint _ | Cconst_symbol _
  37   | Cconst_pointer _ | Cconst_natpointer _ -> fn arg
  38   | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id))
  39
  40 (* Block headers. Meaning of the tag field: see stdlib/obj.ml *)
  41
  42 let float_tag = Cconst_int Obj.double_tag
  43 let floatarray_tag = Cconst_int Obj.double_array_tag
  44
  45 let block_header tag sz =
  46   Nativeint.add (Nativeint.shift_left (Nativeint.of_int sz) 10)
  47                 (Nativeint.of_int tag)
  48 let closure_header sz = block_header Obj.closure_tag sz
  49 let infix_header ofs = block_header Obj.infix_tag ofs
  50 let float_header = block_header Obj.double_tag (size_float / size_addr)
  51 let floatarray_header len =
  52       block_header Obj.double_array_tag (len * size_float / size_addr)
  53 let string_header len =
  54       block_header Obj.string_tag ((len + size_addr) / size_addr)
  55 let boxedint_header = block_header Obj.custom_tag 2
  56
  57 let alloc_block_header tag sz = Cconst_natint(block_header tag sz)
  58 let alloc_float_header = Cconst_natint(float_header)
  59 let alloc_floatarray_header len = Cconst_natint(floatarray_header len)
  60 let alloc_closure_header sz = Cconst_natint(closure_header sz)
  61 let alloc_infix_header ofs = Cconst_natint(infix_header ofs)
  62 let alloc_boxedint_header = Cconst_natint(boxedint_header)
  63
  64 (* Integers *)
  65
  66 let max_repr_int = max_int asr 1
  67 let min_repr_int = min_int asr 1
  68
  69 let int_const n =
  70   if n <= max_repr_int && n >= min_repr_int
  71   then Cconst_int((n lsl 1) + 1)
  72   else Cconst_natint
  73           (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n)
  74
  75 let add_const c n =
  76   if n = 0 then c else Cop(Caddi, [c; Cconst_int n])
  77
  78 let incr_int = function
  79     Cconst_int n when n < max_int -> Cconst_int(n+1)
  80   | Cop(Caddi, [c; Cconst_int n]) when n < max_int -> add_const c (n + 1)
  81   | c -> add_const c 1
  82
  83 let decr_int = function
  84     Cconst_int n when n > min_int -> Cconst_int(n-1)
  85   | Cop(Caddi, [c; Cconst_int n]) when n > min_int -> add_const c (n - 1)
  86   | c -> add_const c (-1)
  87
  88 let add_int c1 c2 =
  89   match (c1, c2) with
  90     (Cop(Caddi, [c1; Cconst_int n1]),
  91      Cop(Caddi, [c2; Cconst_int n2])) when no_overflow_add n1 n2 ->
  92       add_const (Cop(Caddi, [c1; c2])) (n1 + n2)
  93   | (Cop(Caddi, [c1; Cconst_int n1]), c2) ->
  94       add_const (Cop(Caddi, [c1; c2])) n1
  95   | (c1, Cop(Caddi, [c2; Cconst_int n2])) ->
  96       add_const (Cop(Caddi, [c1; c2])) n2
  97   | (Cconst_int _, _) ->
  98       Cop(Caddi, [c2; c1])
  99   | (_, _) ->
 100       Cop(Caddi, [c1; c2])
 101
 102 let sub_int c1 c2 =
 103   match (c1, c2) with
 104     (Cop(Caddi, [c1; Cconst_int n1]),
 105      Cop(Caddi, [c2; Cconst_int n2])) when no_overflow_sub n1 n2 ->
 106       add_const (Cop(Csubi, [c1; c2])) (n1 - n2)
 107   | (Cop(Caddi, [c1; Cconst_int n1]), c2) ->
 108       add_const (Cop(Csubi, [c1; c2])) n1
 109   | (c1, Cop(Caddi, [c2; Cconst_int n2])) when n2 <> min_int ->
 110       add_const (Cop(Csubi, [c1; c2])) (-n2)
 111   | (c1, Cconst_int n) when n <> min_int ->
 112       add_const c1 (-n)
 113   | (c1, c2) ->
 114       Cop(Csubi, [c1; c2])
 115
 116 let mul_int c1 c2 =
 117   match (c1, c2) with
 118     (Cconst_int 0, _) -> c1
 119   | (Cconst_int 1, _) -> c2
 120   | (_, Cconst_int 0) -> c2
 121   | (_, Cconst_int 1) -> c1
 122   | (_, _) -> Cop(Cmuli, [c1; c2])
 123
 124 let tag_int = function
 125     Cconst_int n -> int_const n
 126   | c -> Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1])
 127
 128 let force_tag_int = function
 129     Cconst_int n -> int_const n
 130   | c -> Cop(Cor, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1])
 131
 132 let untag_int = function
 133     Cconst_int n -> Cconst_int(n asr 1)
 134   | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> c
 135   | Cop(Cor, [Cop(Casr, [c; Cconst_int n]); Cconst_int 1])
 136     when n > 0 && n < size_int * 8 ->
 137       Cop(Casr, [c; Cconst_int (n+1)])
 138   | Cop(Cor, [Cop(Clsr, [c; Cconst_int n]); Cconst_int 1])
 139     when n > 0 && n < size_int * 8 ->
 140       Cop(Clsr, [c; Cconst_int (n+1)])
 141   | Cop(Cor, [c; Cconst_int 1]) -> Cop(Casr, [c; Cconst_int 1])
 142   | c -> Cop(Casr, [c; Cconst_int 1])
 143
 144 let lsl_int c1 c2 =
 145   match (c1, c2) with
 146     (Cop(Clsl, [c; Cconst_int n1]), Cconst_int n2)
 147     when n1 > 0 && n2 > 0 && n1 + n2 < size_int * 8 ->
 148       Cop(Clsl, [c; Cconst_int (n1 + n2)])
 149   | (_, _) ->
 150       Cop(Clsl, [c1; c2])
 151
 152 let ignore_low_bit_int = function
 153     Cop(Caddi, [(Cop(Clsl, [_; Cconst_int 1]) as c); Cconst_int 1]) -> c
 154   | Cop(Cor, [c; Cconst_int 1]) -> c
 155   | c -> c
 156
 157 let is_nonzero_constant = function
 158     Cconst_int n -> n <> 0
 159   | Cconst_natint n -> n <> 0n
 160   | _ -> false
 161
 162 let safe_divmod op c1 c2 dbg =
 163   if !Clflags.fast || is_nonzero_constant c2 then
 164     Cop(op, [c1; c2])
 165   else
 166     bind "divisor" c2 (fun c2 ->
 167       Cifthenelse(c2,
 168                   Cop(op, [c1; c2]),
 169                   Cop(Craise dbg,
 170                       [Cconst_symbol "caml_bucket_Division_by_zero"])))
 171
 172 (* Bool *)
 173
 174 let test_bool = function
 175     Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> c
 176   | Cop(Clsl, [c; Cconst_int 1]) -> c
 177   | c -> Cop(Ccmpi Cne, [c; Cconst_int 1])
 178
 179 (* Float *)
 180
 181 let box_float c = Cop(Calloc, [alloc_float_header; c])
 182
 183 let rec unbox_float = function
 184     Cop(Calloc, [header; c]) -> c
 185   | Clet(id, exp, body) -> Clet(id, exp, unbox_float body)
 186   | Cifthenelse(cond, e1, e2) ->
 187       Cifthenelse(cond, unbox_float e1, unbox_float e2)
 188   | Csequence(e1, e2) -> Csequence(e1, unbox_float e2)
 189   | Cswitch(e, tbl, el) -> Cswitch(e, tbl, Array.map unbox_float el)
 190   | Ccatch(n, ids, e1, e2) -> Ccatch(n, ids, unbox_float e1, unbox_float e2)
 191   | Ctrywith(e1, id, e2) -> Ctrywith(unbox_float e1, id, unbox_float e2)
 192   | c -> Cop(Cload Double_u, [c])
 193
 194 (* Complex *)
 195
 196 let box_complex c_re c_im =
 197   Cop(Calloc, [alloc_floatarray_header 2; c_re; c_im])
 198
 199 let complex_re c = Cop(Cload Double_u, [c])
 200 let complex_im c = Cop(Cload Double_u,
 201                        [Cop(Cadda, [c; Cconst_int size_float])])
 202
 203 (* Unit *)
 204
 205 let return_unit c = Csequence(c, Cconst_pointer 1)
 206
 207 let rec remove_unit = function
 208     Cconst_pointer 1 -> Ctuple []
 209   | Csequence(c, Cconst_pointer 1) -> c
 210   | Csequence(c1, c2) ->
 211       Csequence(c1, remove_unit c2)
 212   | Cifthenelse(cond, ifso, ifnot) ->
 213       Cifthenelse(cond, remove_unit ifso, remove_unit ifnot)
 214   | Cswitch(sel, index, cases) ->
 215       Cswitch(sel, index, Array.map remove_unit cases)
 216   | Ccatch(io, ids, body, handler) ->
 217       Ccatch(io, ids, remove_unit body, remove_unit handler)
 218   | Ctrywith(body, exn, handler) ->
 219       Ctrywith(remove_unit body, exn, remove_unit handler)
 220   | Clet(id, c1, c2) ->
 221       Clet(id, c1, remove_unit c2)
 222   | Cop(Capply (mty, dbg), args) ->
 223       Cop(Capply (typ_void, dbg), args)
 224   | Cop(Cextcall(proc, mty, alloc, dbg), args) ->
 225       Cop(Cextcall(proc, typ_void, alloc, dbg), args)
 226   | Cexit (_,_) as c -> c
 227   | Ctuple [] as c -> c
 228   | c -> Csequence(c, Ctuple [])
 229
 230 (* Access to block fields *)
 231
 232 let field_address ptr n =
 233   if n = 0
 234   then ptr
 235   else Cop(Cadda, [ptr; Cconst_int(n * size_addr)])
 236
 237 let get_field ptr n =
 238   Cop(Cload Word, [field_address ptr n])
 239
 240 let set_field ptr n newval =
 241   Cop(Cstore Word, [field_address ptr n; newval])
 242
 243 let header ptr =
 244   Cop(Cload Word, [Cop(Cadda, [ptr; Cconst_int(-size_int)])])
 245
 246 let tag_offset =
 247   if big_endian then -1 else -size_int
 248
 249 let get_tag ptr =
 250   if Proc.word_addressed then           (* If byte loads are slow *)
 251     Cop(Cand, [header ptr; Cconst_int 255])
 252   else                                  (* If byte loads are efficient *)
 253     Cop(Cload Byte_unsigned,
 254         [Cop(Cadda, [ptr; Cconst_int(tag_offset)])])
 255
 256 let get_size ptr =
 257   Cop(Clsr, [header ptr; Cconst_int 10])
 258
 259 (* Array indexing *)
 260
 261 let log2_size_addr = Misc.log2 size_addr
 262 let log2_size_float = Misc.log2 size_float
 263
 264 let wordsize_shift = 9
 265 let numfloat_shift = 9 + log2_size_float - log2_size_addr
 266
 267 let is_addr_array_hdr hdr =
 268   Cop(Ccmpi Cne, [Cop(Cand, [hdr; Cconst_int 255]); floatarray_tag])
 269
 270 let is_addr_array_ptr ptr =
 271   Cop(Ccmpi Cne, [get_tag ptr; floatarray_tag])
 272
 273 let addr_array_length hdr = Cop(Clsr, [hdr; Cconst_int wordsize_shift])
 274 let float_array_length hdr = Cop(Clsr, [hdr; Cconst_int numfloat_shift])
 275
 276 let lsl_const c n =
 277   Cop(Clsl, [c; Cconst_int n])
 278
 279 let array_indexing log2size ptr ofs =
 280   match ofs with
 281     Cconst_int n ->
 282       let i = n asr 1 in
 283       if i = 0 then ptr else Cop(Cadda, [ptr; Cconst_int(i lsl log2size)])
 284   | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) ->
 285       Cop(Cadda, [ptr; lsl_const c log2size])
 286   | Cop(Caddi, [c; Cconst_int n]) ->
 287       Cop(Cadda, [Cop(Cadda, [ptr; lsl_const c (log2size - 1)]);
 288                    Cconst_int((n-1) lsl (log2size - 1))])
 289   | _ ->
 290       Cop(Cadda, [Cop(Cadda, [ptr; lsl_const ofs (log2size - 1)]);
 291                    Cconst_int((-1) lsl (log2size - 1))])
 292
 293 let addr_array_ref arr ofs =
 294   Cop(Cload Word, [array_indexing log2_size_addr arr ofs])
 295 let unboxed_float_array_ref arr ofs =
 296   Cop(Cload Double_u, [array_indexing log2_size_float arr ofs])
 297 let float_array_ref arr ofs =
 298   box_float(unboxed_float_array_ref arr ofs)
 299
 300 let addr_array_set arr ofs newval =
 301   Cop(Cextcall("caml_modify", typ_void, false, Debuginfo.none),
 302       [array_indexing log2_size_addr arr ofs; newval])
 303 let int_array_set arr ofs newval =
 304   Cop(Cstore Word, [array_indexing log2_size_addr arr ofs; newval])
 305 let float_array_set arr ofs newval =
 306   Cop(Cstore Double_u, [array_indexing log2_size_float arr ofs; newval])
 307
 308 (* String length *)
 309
 310 let string_length exp =
 311   bind "str" exp (fun str ->
 312     let tmp_var = Ident.create "tmp" in
 313     Clet(tmp_var,
 314          Cop(Csubi,
 315              [Cop(Clsl,
 316                    [Cop(Clsr, [header str; Cconst_int 10]);
 317                      Cconst_int log2_size_addr]);
 318               Cconst_int 1]),
 319          Cop(Csubi,
 320              [Cvar tmp_var;
 321                Cop(Cload Byte_unsigned,
 322                      [Cop(Cadda, [str; Cvar tmp_var])])])))
 323
 324 (* Message sending *)
 325
 326 let lookup_tag obj tag =
 327   bind "tag" tag (fun tag ->
 328     Cop(Cextcall("caml_get_public_method", typ_addr, false, Debuginfo.none),
 329         [obj; tag]))
 330
 331 let lookup_label obj lab =
 332   bind "lab" lab (fun lab ->
 333     let table = Cop (Cload Word, [obj]) in
 334     addr_array_ref table lab)
 335
 336 let call_cached_method obj tag cache pos args dbg =
 337   let arity = List.length args in
 338   let cache = array_indexing log2_size_addr cache pos in
 339   Compilenv.need_send_fun arity;
 340   Cop(Capply (typ_addr, dbg),
 341       Cconst_symbol("caml_send" ^ string_of_int arity) ::
 342       obj :: tag :: cache :: args)
 343
 344 (* Allocation *)
 345
 346 let make_alloc_generic set_fn tag wordsize args =
 347   if wordsize <= Config.max_young_wosize then
 348     Cop(Calloc, Cconst_natint(block_header tag wordsize) :: args)
 349   else begin
 350     let id = Ident.create "alloc" in
 351     let rec fill_fields idx = function
 352       [] -> Cvar id
 353     | e1::el -> Csequence(set_fn (Cvar id) (Cconst_int idx) e1,
 354                           fill_fields (idx + 2) el) in
 355     Clet(id,
 356          Cop(Cextcall("caml_alloc", typ_addr, true, Debuginfo.none),
 357                  [Cconst_int wordsize; Cconst_int tag]),
 358          fill_fields 1 args)
 359   end
 360
 361 let make_alloc tag args =
 362   make_alloc_generic addr_array_set tag (List.length args) args
 363 let make_float_alloc tag args =
 364   make_alloc_generic float_array_set tag
 365                      (List.length args * size_float / size_addr) args
 366
 367 (* To compile "let rec" over values *)
 368
 369 let fundecls_size fundecls =
 370   let sz = ref (-1) in
 371   List.iter
 372     (fun (label, arity, params, body) ->
 373       sz := !sz + 1 + (if arity = 1 then 2 else 3))
 374     fundecls;
 375   !sz
 376
 377 type rhs_kind =
 378   | RHS_block of int
 379   | RHS_nonrec
 380 ;;
 381 let rec expr_size = function
 382   | Uclosure(fundecls, clos_vars) ->
 383       RHS_block (fundecls_size fundecls + List.length clos_vars)
 384   | Ulet(id, exp, body) ->
 385       expr_size body
 386   | Uletrec(bindings, body) ->
 387       expr_size body
 388   | Uprim(Pmakeblock(tag, mut), args, _) ->
 389       RHS_block (List.length args)
 390   | Uprim(Pmakearray(Paddrarray | Pintarray), args, _) ->
 391       RHS_block (List.length args)
 392   | Usequence(exp, exp') ->
 393       expr_size exp'
 394   | _ -> RHS_nonrec
 395
 396 (* Record application and currying functions *)
 397
 398 let apply_function n =
 399   Compilenv.need_apply_fun n; "caml_apply" ^ string_of_int n
 400 let curry_function n =
 401   Compilenv.need_curry_fun n;
 402   if n >= 0
 403   then "caml_curry" ^ string_of_int n
 404   else "caml_tuplify" ^ string_of_int (-n)
 405
 406 (* Comparisons *)
 407
 408 let transl_comparison = function
 409     Lambda.Ceq -> Ceq
 410   | Lambda.Cneq -> Cne
 411   | Lambda.Cge -> Cge
 412   | Lambda.Cgt -> Cgt
 413   | Lambda.Cle -> Cle
 414   | Lambda.Clt -> Clt
 415
 416 (* Translate structured constants *)
 417
 418 let const_label = ref 0
 419
 420 let new_const_label () =
 421   incr const_label;
 422   !const_label
 423
 424 let new_const_symbol () =
 425   incr const_label;
 426   Compilenv.make_symbol (Some (string_of_int !const_label))
 427
 428 let structured_constants = ref ([] : (string * structured_constant) list)
 429
 430 let transl_constant = function
 431     Const_base(Const_int n) ->
 432       int_const n
 433   | Const_base(Const_char c) ->
 434       Cconst_int(((Char.code c) lsl 1) + 1)
 435   | Const_pointer n ->
 436       if n <= max_repr_int && n >= min_repr_int
 437       then Cconst_pointer((n lsl 1) + 1)
 438       else Cconst_natpointer
 439               (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n)
 440   | cst ->
 441       let lbl = new_const_symbol() in
 442       structured_constants := (lbl, cst) :: !structured_constants;
 443       Cconst_symbol lbl
 444
 445 (* Translate constant closures *)
 446
 447 let constant_closures =
 448   ref ([] : (string * (string * int * Ident.t list * ulambda) list) list)
 449
 450 (* Boxed integers *)
 451
 452 let box_int_constant bi n =
 453   match bi with
 454     Pnativeint -> Const_base(Const_nativeint n)
 455   | Pint32 -> Const_base(Const_int32 (Nativeint.to_int32 n))
 456   | Pint64 -> Const_base(Const_int64 (Int64.of_nativeint n))
 457
 458 let operations_boxed_int bi =
 459   match bi with
 460     Pnativeint -> "caml_nativeint_ops"
 461   | Pint32 -> "caml_int32_ops"
 462   | Pint64 -> "caml_int64_ops"
 463
 464 let box_int bi arg =
 465   match arg with
 466     Cconst_int n ->
 467       transl_constant (box_int_constant bi (Nativeint.of_int n))
 468   | Cconst_natint n ->
 469       transl_constant (box_int_constant bi n)
 470   | _ ->
 471       let arg' =
 472         if bi = Pint32 && size_int = 8 && big_endian
 473         then Cop(Clsl, [arg; Cconst_int 32])
 474         else arg in
 475       Cop(Calloc, [alloc_boxedint_header;
 476                    Cconst_symbol(operations_boxed_int bi);
 477                    arg'])
 478
 479 let rec unbox_int bi arg =
 480   match arg with
 481     Cop(Calloc, [hdr; ops; Cop(Clsl, [contents; Cconst_int 32])])
 482     when bi = Pint32 && size_int = 8 && big_endian ->
 483       (* Force sign-extension of low 32 bits *)
 484       Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32])
 485   | Cop(Calloc, [hdr; ops; contents])
 486     when bi = Pint32 && size_int = 8 && not big_endian ->
 487       (* Force sign-extension of low 32 bits *)
 488       Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32])
 489   | Cop(Calloc, [hdr; ops; contents]) ->
 490       contents
 491   | Clet(id, exp, body) -> Clet(id, exp, unbox_int bi body)
 492   | Cifthenelse(cond, e1, e2) ->
 493       Cifthenelse(cond, unbox_int bi e1, unbox_int bi e2)
 494   | Csequence(e1, e2) -> Csequence(e1, unbox_int bi e2)
 495   | Cswitch(e, tbl, el) -> Cswitch(e, tbl, Array.map (unbox_int bi) el)
 496   | Ccatch(n, ids, e1, e2) -> Ccatch(n, ids, unbox_int bi e1, unbox_int bi e2)
 497   | Ctrywith(e1, id, e2) -> Ctrywith(unbox_int bi e1, id, unbox_int bi e2)
 498   | _ ->
 499       Cop(Cload(if bi = Pint32 then Thirtytwo_signed else Word),
 500           [Cop(Cadda, [arg; Cconst_int size_addr])])
 501
 502 let make_unsigned_int bi arg =
 503   if bi = Pint32 && size_int = 8
 504   then Cop(Cand, [arg; Cconst_natint 0xFFFFFFFFn])
 505   else arg
 506
 507 (* Big arrays *)
 508
 509 let bigarray_elt_size = function
 510     Pbigarray_unknown -> assert false
 511   | Pbigarray_float32 -> 4
 512   | Pbigarray_float64 -> 8
 513   | Pbigarray_sint8 -> 1
 514   | Pbigarray_uint8 -> 1
 515   | Pbigarray_sint16 -> 2
 516   | Pbigarray_uint16 -> 2
 517   | Pbigarray_int32 -> 4
 518   | Pbigarray_int64 -> 8
 519   | Pbigarray_caml_int -> size_int
 520   | Pbigarray_native_int -> size_int
 521   | Pbigarray_complex32 -> 8
 522   | Pbigarray_complex64 -> 16
 523
 524 let bigarray_indexing unsafe elt_kind layout b args dbg =
 525   let check_bound a1 a2 k =
 526     if unsafe then k else Csequence(Cop(Ccheckbound dbg, [a1;a2]), k) in
 527   let rec ba_indexing dim_ofs delta_ofs = function
 528     [] -> assert false
 529   | [arg] ->
 530       bind "idx" (untag_int arg)
 531         (fun idx ->
 532            check_bound (Cop(Cload Word,[field_address b dim_ofs])) idx idx)
 533   | arg1 :: argl ->
 534       let rem = ba_indexing (dim_ofs + delta_ofs) delta_ofs argl in
 535       bind "idx" (untag_int arg1)
 536         (fun idx ->
 537           bind "bound" (Cop(Cload Word, [field_address b dim_ofs]))
 538           (fun bound ->
 539             check_bound bound idx (add_int (mul_int rem bound) idx))) in
 540   let offset =
 541     match layout with
 542       Pbigarray_unknown_layout ->
 543         assert false
 544     | Pbigarray_c_layout ->
 545         ba_indexing (4 + List.length args) (-1) (List.rev args)
 546     | Pbigarray_fortran_layout ->
 547         ba_indexing 5 1 (List.map (fun idx -> sub_int idx (Cconst_int 2)) args)
 548   and elt_size =
 549     bigarray_elt_size elt_kind in
 550   let byte_offset =
 551     if elt_size = 1
 552     then offset
 553     else Cop(Clsl, [offset; Cconst_int(log2 elt_size)]) in
 554   Cop(Cadda, [Cop(Cload Word, [field_address b 1]); byte_offset])
 555
 556 let bigarray_word_kind = function
 557     Pbigarray_unknown -> assert false
 558   | Pbigarray_float32 -> Single
 559   | Pbigarray_float64 -> Double
 560   | Pbigarray_sint8 -> Byte_signed
 561   | Pbigarray_uint8 -> Byte_unsigned
 562   | Pbigarray_sint16 -> Sixteen_signed
 563   | Pbigarray_uint16 -> Sixteen_unsigned
 564   | Pbigarray_int32 -> Thirtytwo_signed
 565   | Pbigarray_int64 -> Word
 566   | Pbigarray_caml_int -> Word
 567   | Pbigarray_native_int -> Word
 568   | Pbigarray_complex32 -> Single
 569   | Pbigarray_complex64 -> Double
 570
 571 let bigarray_get unsafe elt_kind layout b args dbg =
 572   match elt_kind with
 573     Pbigarray_complex32 | Pbigarray_complex64 ->
 574       let kind = bigarray_word_kind elt_kind in
 575       let sz = bigarray_elt_size elt_kind / 2 in
 576       bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr ->
 577         box_complex
 578           (Cop(Cload kind, [addr]))
 579           (Cop(Cload kind, [Cop(Cadda, [addr; Cconst_int sz])])))
 580   | _ ->
 581       Cop(Cload (bigarray_word_kind elt_kind),
 582           [bigarray_indexing unsafe elt_kind layout b args dbg])
 583
 584 let bigarray_set unsafe elt_kind layout b args newval dbg =
 585   match elt_kind with
 586     Pbigarray_complex32 | Pbigarray_complex64 ->
 587       let kind = bigarray_word_kind elt_kind in
 588       let sz = bigarray_elt_size elt_kind / 2 in
 589       bind "newval" newval (fun newv ->
 590       bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr ->
 591         Csequence(
 592           Cop(Cstore kind, [addr; complex_re newv]),
 593           Cop(Cstore kind,
 594               [Cop(Cadda, [addr; Cconst_int sz]); complex_im newv]))))
 595   | _ ->
 596       Cop(Cstore (bigarray_word_kind elt_kind),
 597           [bigarray_indexing unsafe elt_kind layout b args dbg; newval])
 598
 599 (* Simplification of some primitives into C calls *)
 600
 601 let default_prim name =
 602   { prim_name = name; prim_arity = 0 (*ignored*);
 603     prim_alloc = true; prim_native_name = ""; prim_native_float = false }
 604
 605 let simplif_primitive_32bits = function
 606     Pbintofint Pint64 -> Pccall (default_prim "caml_int64_of_int")
 607   | Pintofbint Pint64 -> Pccall (default_prim "caml_int64_to_int")
 608   | Pcvtbint(Pint32, Pint64) -> Pccall (default_prim "caml_int64_of_int32")
 609   | Pcvtbint(Pint64, Pint32) -> Pccall (default_prim "caml_int64_to_int32")
 610   | Pcvtbint(Pnativeint, Pint64) ->
 611       Pccall (default_prim "caml_int64_of_nativeint")
 612   | Pcvtbint(Pint64, Pnativeint) ->
 613       Pccall (default_prim "caml_int64_to_nativeint")
 614   | Pnegbint Pint64 -> Pccall (default_prim "caml_int64_neg")
 615   | Paddbint Pint64 -> Pccall (default_prim "caml_int64_add")
 616   | Psubbint Pint64 -> Pccall (default_prim "caml_int64_sub")
 617   | Pmulbint Pint64 -> Pccall (default_prim "caml_int64_mul")
 618   | Pdivbint Pint64 -> Pccall (default_prim "caml_int64_div")
 619   | Pmodbint Pint64 -> Pccall (default_prim "caml_int64_mod")
 620   | Pandbint Pint64 -> Pccall (default_prim "caml_int64_and")
 621   | Porbint Pint64 ->  Pccall (default_prim "caml_int64_or")
 622   | Pxorbint Pint64 -> Pccall (default_prim "caml_int64_xor")
 623   | Plslbint Pint64 -> Pccall (default_prim "caml_int64_shift_left")
 624   | Plsrbint Pint64 -> Pccall (default_prim "caml_int64_shift_right_unsigned")
 625   | Pasrbint Pint64 -> Pccall (default_prim "caml_int64_shift_right")
 626   | Pbintcomp(Pint64, Lambda.Ceq) -> Pccall (default_prim "caml_equal")
 627   | Pbintcomp(Pint64, Lambda.Cneq) -> Pccall (default_prim "caml_notequal")
 628   | Pbintcomp(Pint64, Lambda.Clt) -> Pccall (default_prim "caml_lessthan")
 629   | Pbintcomp(Pint64, Lambda.Cgt) -> Pccall (default_prim "caml_greaterthan")
 630   | Pbintcomp(Pint64, Lambda.Cle) -> Pccall (default_prim "caml_lessequal")
 631   | Pbintcomp(Pint64, Lambda.Cge) -> Pccall (default_prim "caml_greaterequal")
 632   | Pbigarrayref(unsafe, n, Pbigarray_int64, layout) ->
 633       Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
 634   | Pbigarrayset(unsafe, n, Pbigarray_int64, layout) ->
 635       Pccall (default_prim ("caml_ba_set_" ^ string_of_int n))
 636   | p -> p
 637
 638 let simplif_primitive p =
 639   match p with
 640   | Pduprecord _ ->
 641       Pccall (default_prim "caml_obj_dup")
 642   | Pbigarrayref(unsafe, n, Pbigarray_unknown, layout) ->
 643       Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
 644   | Pbigarrayset(unsafe, n, Pbigarray_unknown, layout) ->
 645       Pccall (default_prim ("caml_ba_set_" ^ string_of_int n))
 646   | Pbigarrayref(unsafe, n, kind, Pbigarray_unknown_layout) ->
 647       Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
 648   | Pbigarrayset(unsafe, n, kind, Pbigarray_unknown_layout) ->
 649       Pccall (default_prim ("caml_ba_set_" ^ string_of_int n))
 650   | p ->
 651       if size_int = 8 then p else simplif_primitive_32bits p
 652
 653 (* Build switchers both for constants and blocks *)
 654
 655 (* constants first *)
 656
 657 let transl_isout h arg = tag_int (Cop(Ccmpa Clt, [h ; arg]))
 658
 659 exception Found of int
 660
 661 let make_switch_gen arg cases acts =
 662   let lcases = Array.length cases in
 663   let new_cases = Array.create lcases 0 in
 664   let store = Switch.mk_store (=) in
 665
 666   for i = 0 to Array.length cases-1 do
 667     let act = cases.(i) in
 668     let new_act = store.Switch.act_store act in
 669     new_cases.(i) <- new_act
 670   done ;
 671   Cswitch
 672     (arg, new_cases,
 673      Array.map
 674        (fun n -> acts.(n))
 675        (store.Switch.act_get ()))
 676
 677
 678 (* Then for blocks *)
 679
 680 module SArgBlocks =
 681 struct
 682   type primitive = operation
 683
 684   let eqint = Ccmpi Ceq
 685   let neint = Ccmpi Cne
 686   let leint = Ccmpi Cle
 687   let ltint = Ccmpi Clt
 688   let geint = Ccmpi Cge
 689   let gtint = Ccmpi Cgt
 690
 691   type act = expression
 692
 693   let default = Cexit (0,[])
 694   let make_prim p args = Cop (p,args)
 695   let make_offset arg n = add_const arg n
 696   let make_isout h arg =  Cop (Ccmpa Clt, [h ; arg])
 697   let make_isin h arg =  Cop (Ccmpa Cge, [h ; arg])
 698   let make_if cond ifso ifnot = Cifthenelse (cond, ifso, ifnot)
 699   let make_switch arg cases actions =
 700     make_switch_gen arg cases actions
 701   let bind arg body = bind "switcher" arg body
 702
 703 end
 704
 705 module SwitcherBlocks = Switch.Make(SArgBlocks)
 706
 707 (* Auxiliary functions for optimizing "let" of boxed numbers (floats and
 708    boxed integers *)
 709
 710 type unboxed_number_kind =
 711     No_unboxing
 712   | Boxed_float
 713   | Boxed_integer of boxed_integer
 714
 715 let is_unboxed_number = function
 716     Uconst(Const_base(Const_float f)) ->
 717       Boxed_float
 718   | Uprim(p, _, _) ->
 719       begin match simplif_primitive p with
 720           Pccall p -> if p.prim_native_float then Boxed_float else No_unboxing
 721         | Pfloatfield _ -> Boxed_float
 722         | Pfloatofint -> Boxed_float
 723         | Pnegfloat -> Boxed_float
 724         | Pabsfloat -> Boxed_float
 725         | Paddfloat -> Boxed_float
 726         | Psubfloat -> Boxed_float
 727         | Pmulfloat -> Boxed_float
 728         | Pdivfloat -> Boxed_float
 729         | Parrayrefu Pfloatarray -> Boxed_float
 730         | Parrayrefs Pfloatarray -> Boxed_float
 731         | Pbintofint bi -> Boxed_integer bi
 732         | Pcvtbint(src, dst) -> Boxed_integer dst
 733         | Pnegbint bi -> Boxed_integer bi
 734         | Paddbint bi -> Boxed_integer bi
 735         | Psubbint bi -> Boxed_integer bi
 736         | Pmulbint bi -> Boxed_integer bi
 737         | Pdivbint bi -> Boxed_integer bi
 738         | Pmodbint bi -> Boxed_integer bi
 739         | Pandbint bi -> Boxed_integer bi
 740         | Porbint bi -> Boxed_integer bi
 741         | Pxorbint bi -> Boxed_integer bi
 742         | Plslbint bi -> Boxed_integer bi
 743         | Plsrbint bi -> Boxed_integer bi
 744         | Pasrbint bi -> Boxed_integer bi
 745         | Pbigarrayref(_, _, (Pbigarray_float32 | Pbigarray_float64), _) ->
 746             Boxed_float
 747         | Pbigarrayref(_, _, Pbigarray_int32, _) -> Boxed_integer Pint32
 748         | Pbigarrayref(_, _, Pbigarray_int64, _) -> Boxed_integer Pint64
 749         | Pbigarrayref(_, _, Pbigarray_native_int, _) -> Boxed_integer Pnativeint
 750         | _ -> No_unboxing
 751       end
 752   | _ -> No_unboxing
 753
 754 let subst_boxed_number unbox_fn boxed_id unboxed_id exp =
 755   let need_boxed = ref false in
 756   let assigned = ref false in
 757   let rec subst = function
 758       Cvar id as e ->
 759         if Ident.same id boxed_id then need_boxed := true; e
 760     | Clet(id, arg, body) -> Clet(id, subst arg, subst body)
 761     | Cassign(id, arg) ->
 762         if Ident.same id boxed_id then begin
 763           assigned := true;
 764           Cassign(unboxed_id, subst(unbox_fn arg))
 765         end else
 766           Cassign(id, subst arg)
 767     | Ctuple argv -> Ctuple(List.map subst argv)
 768     | Cop(Cload _, [Cvar id]) as e ->
 769         if Ident.same id boxed_id then Cvar unboxed_id else e
 770     | Cop(Cload _, [Cop(Cadda, [Cvar id; _])]) as e ->
 771         if Ident.same id boxed_id then Cvar unboxed_id else e
 772     | Cop(op, argv) -> Cop(op, List.map subst argv)
 773     | Csequence(e1, e2) -> Csequence(subst e1, subst e2)
 774     | Cifthenelse(e1, e2, e3) -> Cifthenelse(subst e1, subst e2, subst e3)
 775     | Cswitch(arg, index, cases) ->
 776         Cswitch(subst arg, index, Array.map subst cases)
 777     | Cloop e -> Cloop(subst e)
 778     | Ccatch(nfail, ids, e1, e2) -> Ccatch(nfail, ids, subst e1, subst e2)
 779     | Cexit (nfail, el) -> Cexit (nfail, List.map subst el)
 780     | Ctrywith(e1, id, e2) -> Ctrywith(subst e1, id, subst e2)
 781     | e -> e in
 782   let res = subst exp in
 783   (res, !need_boxed, !assigned)
 784
 785 (* Translate an expression *)
 786
 787 let functions = (Queue.create() : (string * Ident.t list * ulambda) Queue.t)
 788
 789 let rec transl = function
 790     Uvar id ->
 791       Cvar id
 792   | Uconst sc ->
 793       transl_constant sc
 794   | Uclosure(fundecls, []) ->
 795       let lbl = new_const_symbol() in
 796       constant_closures := (lbl, fundecls) :: !constant_closures;
 797       List.iter
 798         (fun (label, arity, params, body) ->
 799           Queue.add (label, params, body) functions)
 800         fundecls;
 801       Cconst_symbol lbl
 802   | Uclosure(fundecls, clos_vars) ->
 803       let block_size =
 804         fundecls_size fundecls + List.length clos_vars in
 805       let rec transl_fundecls pos = function
 806           [] ->
 807             List.map transl clos_vars
 808         | (label, arity, params, body) :: rem ->
 809             Queue.add (label, params, body) functions;
 810             let header =
 811               if pos = 0
 812               then alloc_closure_header block_size
 813               else alloc_infix_header pos in
 814             if arity = 1 then
 815               header ::
 816               Cconst_symbol label ::
 817               int_const 1 ::
 818               transl_fundecls (pos + 3) rem
 819             else
 820               header ::
 821               Cconst_symbol(curry_function arity) ::
 822               int_const arity ::
 823               Cconst_symbol label ::
 824               transl_fundecls (pos + 4) rem in
 825       Cop(Calloc, transl_fundecls 0 fundecls)
 826   | Uoffset(arg, offset) ->
 827       field_address (transl arg) offset
 828   | Udirect_apply(lbl, args, dbg) ->
 829       Cop(Capply(typ_addr, dbg), Cconst_symbol lbl :: List.map transl args)
 830   | Ugeneric_apply(clos, [arg], dbg) ->
 831       bind "fun" (transl clos) (fun clos ->
 832         Cop(Capply(typ_addr, dbg), [get_field clos 0; transl arg; clos]))
 833   | Ugeneric_apply(clos, args, dbg) ->
 834       let arity = List.length args in
 835       let cargs = Cconst_symbol(apply_function arity) ::
 836         List.map transl (args @ [clos]) in
 837       Cop(Capply(typ_addr, dbg), cargs)
 838   | Usend(kind, met, obj, args, dbg) ->
 839       let call_met obj args clos =
 840         if args = [] then
 841           Cop(Capply(typ_addr, dbg), [get_field clos 0;obj;clos])
 842         else
 843           let arity = List.length args + 1 in
 844           let cargs = Cconst_symbol(apply_function arity) :: obj ::
 845             (List.map transl args) @ [clos] in
 846           Cop(Capply(typ_addr, dbg), cargs)
 847       in
 848       bind "obj" (transl obj) (fun obj ->
 849         match kind, args with
 850           Self, _ ->
 851             bind "met" (lookup_label obj (transl met)) (call_met obj args)
 852         | Cached, cache :: pos :: args ->
 853             call_cached_method obj (transl met) (transl cache) (transl pos)
 854               (List.map transl args) dbg
 855         | _ ->
 856             bind "met" (lookup_tag obj (transl met)) (call_met obj args))
 857   | Ulet(id, exp, body) ->
 858       begin match is_unboxed_number exp with
 859         No_unboxing ->
 860           Clet(id, transl exp, transl body)
 861       | Boxed_float ->
 862           transl_unbox_let box_float unbox_float transl_unbox_float
 863                            id exp body
 864       | Boxed_integer bi ->
 865           transl_unbox_let (box_int bi) (unbox_int bi) (transl_unbox_int bi)
 866                            id exp body
 867       end
 868   | Uletrec(bindings, body) ->
 869       transl_letrec bindings (transl body)
 870
 871   (* Primitives *)
 872   | Uprim(prim, args, dbg) ->
 873       begin match (simplif_primitive prim, args) with
 874         (Pgetglobal id, []) ->
 875           Cconst_symbol (Ident.name id)
 876       | (Pmakeblock(tag, mut), []) ->
 877           transl_constant(Const_block(tag, []))
 878       | (Pmakeblock(tag, mut), args) ->
 879           make_alloc tag (List.map transl args)
 880       | (Pccall prim, args) ->
 881           if prim.prim_native_float then
 882             box_float
 883               (Cop(Cextcall(prim.prim_native_name, typ_float, false, dbg),
 884                    List.map transl_unbox_float args))
 885           else
 886             Cop(Cextcall(Primitive.native_name prim, typ_addr, prim.prim_alloc, dbg),
 887                 List.map transl args)
 888       | (Pmakearray kind, []) ->
 889           transl_constant(Const_block(0, []))
 890       | (Pmakearray kind, args) ->
 891           begin match kind with
 892             Pgenarray ->
 893               Cop(Cextcall("caml_make_array", typ_addr, true, Debuginfo.none),
 894                   [make_alloc 0 (List.map transl args)])
 895           | Paddrarray | Pintarray ->
 896               make_alloc 0 (List.map transl args)
 897           | Pfloatarray ->
 898               make_float_alloc Obj.double_array_tag
 899                               (List.map transl_unbox_float args)
 900           end
 901       | (Pbigarrayref(unsafe, num_dims, elt_kind, layout), arg1 :: argl) ->
 902           let elt =
 903             bigarray_get unsafe elt_kind layout
 904               (transl arg1) (List.map transl argl) dbg in
 905           begin match elt_kind with
 906             Pbigarray_float32 | Pbigarray_float64 -> box_float elt
 907           | Pbigarray_complex32 | Pbigarray_complex64 -> elt
 908           | Pbigarray_int32 -> box_int Pint32 elt
 909           | Pbigarray_int64 -> box_int Pint64 elt
 910           | Pbigarray_native_int -> box_int Pnativeint elt
 911           | Pbigarray_caml_int -> force_tag_int elt
 912           | _ -> tag_int elt
 913           end
 914       | (Pbigarrayset(unsafe, num_dims, elt_kind, layout), arg1 :: argl) ->
 915           let (argidx, argnewval) = split_last argl in
 916           return_unit(bigarray_set unsafe elt_kind layout
 917             (transl arg1)
 918             (List.map transl argidx)
 919             (match elt_kind with
 920               Pbigarray_float32 | Pbigarray_float64 ->
 921                 transl_unbox_float argnewval
 922             | Pbigarray_complex32 | Pbigarray_complex64 -> transl argnewval
 923             | Pbigarray_int32 -> transl_unbox_int Pint32 argnewval
 924             | Pbigarray_int64 -> transl_unbox_int Pint64 argnewval
 925             | Pbigarray_native_int -> transl_unbox_int Pnativeint argnewval
 926             | _ -> untag_int (transl argnewval))
 927             dbg)
 928       | (p, [arg]) ->
 929           transl_prim_1 p arg dbg
 930       | (p, [arg1; arg2]) ->
 931           transl_prim_2 p arg1 arg2 dbg
 932       | (p, [arg1; arg2; arg3]) ->
 933           transl_prim_3 p arg1 arg2 arg3 dbg
 934       | (_, _) ->
 935           fatal_error "Cmmgen.transl:prim"
 936       end
 937
 938   (* Control structures *)
 939   | Uswitch(arg, s) ->
 940       (* As in the bytecode interpreter, only matching against constants
 941          can be checked *)
 942       if Array.length s.us_index_blocks = 0 then
 943         Cswitch
 944           (untag_int (transl arg),
 945            s.us_index_consts,
 946            Array.map transl s.us_actions_consts)
 947       else if Array.length s.us_index_consts = 0 then
 948         transl_switch (get_tag (transl arg))
 949           s.us_index_blocks s.us_actions_blocks
 950       else
 951         bind "switch" (transl arg) (fun arg ->
 952           Cifthenelse(
 953           Cop(Cand, [arg; Cconst_int 1]),
 954           transl_switch
 955             (untag_int arg) s.us_index_consts s.us_actions_consts,
 956           transl_switch
 957             (get_tag arg) s.us_index_blocks s.us_actions_blocks))
 958   | Ustaticfail (nfail, args) ->
 959       Cexit (nfail, List.map transl args)
 960   | Ucatch(nfail, [], body, handler) ->
 961       make_catch nfail (transl body) (transl handler)
 962   | Ucatch(nfail, ids, body, handler) ->
 963       Ccatch(nfail, ids, transl body, transl handler)
 964   | Utrywith(body, exn, handler) ->
 965       Ctrywith(transl body, exn, transl handler)
 966   | Uifthenelse(Uprim(Pnot, [arg], _), ifso, ifnot) ->
 967       transl (Uifthenelse(arg, ifnot, ifso))
 968   | Uifthenelse(cond, ifso, Ustaticfail (nfail, [])) ->
 969       exit_if_false cond (transl ifso) nfail
 970   | Uifthenelse(cond, Ustaticfail (nfail, []), ifnot) ->
 971       exit_if_true cond nfail (transl ifnot)
 972   | Uifthenelse(Uprim(Psequand, _, _) as cond, ifso, ifnot) ->
 973       let raise_num = next_raise_count () in
 974       make_catch
 975         raise_num
 976         (exit_if_false cond (transl ifso) raise_num)
 977         (transl ifnot)
 978   | Uifthenelse(Uprim(Psequor, _, _) as cond, ifso, ifnot) ->
 979       let raise_num = next_raise_count () in
 980       make_catch
 981         raise_num
 982         (exit_if_true cond raise_num (transl ifnot))
 983         (transl ifso)
 984   | Uifthenelse (Uifthenelse (cond, condso, condnot), ifso, ifnot) ->
 985       let num_true = next_raise_count () in
 986       make_catch
 987         num_true
 988         (make_catch2
 989            (fun shared_false ->
 990              Cifthenelse
 991                (test_bool (transl cond),
 992                 exit_if_true condso num_true shared_false,
 993                 exit_if_true condnot num_true shared_false))
 994            (transl ifnot))
 995         (transl ifso)
 996   | Uifthenelse(cond, ifso, ifnot) ->
 997       Cifthenelse(test_bool(transl cond), transl ifso, transl ifnot)
 998   | Usequence(exp1, exp2) ->
 999       Csequence(remove_unit(transl exp1), transl exp2)
1000   | Uwhile(cond, body) ->
1001       let raise_num = next_raise_count () in
1002       return_unit
1003         (Ccatch
1004            (raise_num, [],
1005             Cloop(exit_if_false cond (remove_unit(transl body)) raise_num),
1006             Ctuple []))
1007   | Ufor(id, low, high, dir, body) ->
1008       let tst = match dir with Upto -> Cgt   | Downto -> Clt in
1009       let inc = match dir with Upto -> Caddi | Downto -> Csubi in
1010       let raise_num = next_raise_count () in
1011       let id_prev = Ident.rename id in
1012       return_unit
1013         (Clet
1014            (id, transl low,
1015             bind_nonvar "bound" (transl high) (fun high ->
1016               Ccatch
1017                 (raise_num, [],
1018                  Cifthenelse
1019                    (Cop(Ccmpi tst, [Cvar id; high]), Cexit (raise_num, []),
1020                     Cloop
1021                       (Csequence
1022                          (remove_unit(transl body),
1023                          Clet(id_prev, Cvar id,
1024                           Csequence
1025                             (Cassign(id,
1026                                Cop(inc, [Cvar id; Cconst_int 2])),
1027                              Cifthenelse
1028                                (Cop(Ccmpi Ceq, [Cvar id_prev; high]),
1029                                 Cexit (raise_num,[]), Ctuple [])))))),
1030                  Ctuple []))))
1031   | Uassign(id, exp) ->
1032       return_unit(Cassign(id, transl exp))
1033
1034 and transl_prim_1 p arg dbg =
1035   match p with
1036   (* Generic operations *)
1037     Pidentity ->
1038       transl arg
1039   | Pignore ->
1040       return_unit(remove_unit (transl arg))
1041   (* Heap operations *)
1042   | Pfield n ->
1043       get_field (transl arg) n
1044   | Pfloatfield n ->
1045       let ptr = transl arg in
1046       box_float(
1047         Cop(Cload Double_u,
1048             [if n = 0 then ptr
1049                        else Cop(Cadda, [ptr; Cconst_int(n * size_float)])]))
1050   (* Exceptions *)
1051   | Praise ->
1052       Cop(Craise dbg, [transl arg])
1053   (* Integer operations *)
1054   | Pnegint ->
1055       Cop(Csubi, [Cconst_int 2; transl arg])
1056   | Poffsetint n ->
1057       if no_overflow_lsl n then
1058         add_const (transl arg) (n lsl 1)
1059       else
1060         transl_prim_2 Paddint arg (Uconst (Const_base(Const_int n))) Debuginfo.none
1061   | Poffsetref n ->
1062       return_unit
1063         (bind "ref" (transl arg) (fun arg ->
1064           Cop(Cstore Word,
1065               [arg; add_const (Cop(Cload Word, [arg])) (n lsl 1)])))
1066   (* Floating-point operations *)
1067   | Pfloatofint ->
1068       box_float(Cop(Cfloatofint, [untag_int(transl arg)]))
1069   | Pintoffloat ->
1070      tag_int(Cop(Cintoffloat, [transl_unbox_float arg]))
1071   | Pnegfloat ->
1072       box_float(Cop(Cnegf, [transl_unbox_float arg]))
1073   | Pabsfloat ->
1074       box_float(Cop(Cabsf, [transl_unbox_float arg]))
1075   (* String operations *)
1076   | Pstringlength ->
1077       tag_int(string_length (transl arg))
1078   (* Array operations *)
1079   | Parraylength kind ->
1080       begin match kind with
1081         Pgenarray ->
1082           let len =
1083             if wordsize_shift = numfloat_shift then
1084               Cop(Clsr, [header(transl arg); Cconst_int wordsize_shift])
1085             else
1086               bind "header" (header(transl arg)) (fun hdr ->
1087                 Cifthenelse(is_addr_array_hdr hdr,
1088                             Cop(Clsr, [hdr; Cconst_int wordsize_shift]),
1089                             Cop(Clsr, [hdr; Cconst_int numfloat_shift]))) in
1090           Cop(Cor, [len; Cconst_int 1])
1091       | Paddrarray | Pintarray ->
1092           Cop(Cor, [addr_array_length(header(transl arg)); Cconst_int 1])
1093       | Pfloatarray ->
1094           Cop(Cor, [float_array_length(header(transl arg)); Cconst_int 1])
1095       end
1096   (* Boolean operations *)
1097   | Pnot ->
1098       Cop(Csubi, [Cconst_int 4; transl arg]) (* 1 -> 3, 3 -> 1 *)
1099   (* Test integer/block *)
1100   | Pisint ->
1101       tag_int(Cop(Cand, [transl arg; Cconst_int 1]))
1102   (* Boxed integers *)
1103   | Pbintofint bi ->
1104       box_int bi (untag_int (transl arg))
1105   | Pintofbint bi ->
1106       force_tag_int (transl_unbox_int bi arg)
1107   | Pcvtbint(bi1, bi2) ->
1108       box_int bi2 (transl_unbox_int bi1 arg)
1109   | Pnegbint bi ->
1110       box_int bi (Cop(Csubi, [Cconst_int 0; transl_unbox_int bi arg]))
1111   | _ ->
1112       fatal_error "Cmmgen.transl_prim_1"
1113
1114 and transl_prim_2 p arg1 arg2 dbg =
1115   match p with
1116   (* Heap operations *)
1117     Psetfield(n, ptr) ->
1118       if ptr then
1119         return_unit(Cop(Cextcall("caml_modify", typ_void, false, Debuginfo.none),
1120                         [field_address (transl arg1) n; transl arg2]))
1121       else
1122         return_unit(set_field (transl arg1) n (transl arg2))
1123   | Psetfloatfield n ->
1124       let ptr = transl arg1 in
1125       return_unit(
1126         Cop(Cstore Double_u,
1127             [if n = 0 then ptr
1128                        else Cop(Cadda, [ptr; Cconst_int(n * size_float)]);
1129                    transl_unbox_float arg2]))
1130
1131   (* Boolean operations *)
1132   | Psequand ->
1133       Cifthenelse(test_bool(transl arg1), transl arg2, Cconst_int 1)
1134       (* let id = Ident.create "res1" in
1135       Clet(id, transl arg1,
1136            Cifthenelse(test_bool(Cvar id), transl arg2, Cvar id)) *)
1137   | Psequor ->
1138       Cifthenelse(test_bool(transl arg1), Cconst_int 3, transl arg2)
1139
1140   (* Integer operations *)
1141   | Paddint ->
1142       decr_int(add_int (transl arg1) (transl arg2))
1143   | Psubint ->
1144       incr_int(sub_int (transl arg1) (transl arg2))
1145   | Pmulint ->
1146       incr_int(Cop(Cmuli, [decr_int(transl arg1); untag_int(transl arg2)]))
1147   | Pdivint ->
1148       tag_int(safe_divmod Cdivi (untag_int(transl arg1)) (untag_int(transl arg2)) dbg)
1149   | Pmodint ->
1150       tag_int(safe_divmod Cmodi (untag_int(transl arg1)) (untag_int(transl arg2)) dbg)
1151   | Pandint ->
1152       Cop(Cand, [transl arg1; transl arg2])
1153   | Porint ->
1154       Cop(Cor, [transl arg1; transl arg2])
1155   | Pxorint ->
1156       Cop(Cor, [Cop(Cxor, [ignore_low_bit_int(transl arg1);
1157                            ignore_low_bit_int(transl arg2)]);
1158                 Cconst_int 1])
1159   | Plslint ->
1160       incr_int(lsl_int (decr_int(transl arg1)) (untag_int(transl arg2)))
1161   | Plsrint ->
1162       Cop(Cor, [Cop(Clsr, [transl arg1; untag_int(transl arg2)]);
1163                 Cconst_int 1])
1164   | Pasrint ->
1165       Cop(Cor, [Cop(Casr, [transl arg1; untag_int(transl arg2)]);
1166                 Cconst_int 1])
1167   | Pintcomp cmp ->
1168       tag_int(Cop(Ccmpi(transl_comparison cmp), [transl arg1; transl arg2]))
1169   | Pisout ->
1170       transl_isout (transl arg1) (transl arg2)
1171   (* Float operations *)
1172   | Paddfloat ->
1173       box_float(Cop(Caddf,
1174                     [transl_unbox_float arg1; transl_unbox_float arg2]))
1175   | Psubfloat ->
1176       box_float(Cop(Csubf,
1177                     [transl_unbox_float arg1; transl_unbox_float arg2]))
1178   | Pmulfloat ->
1179       box_float(Cop(Cmulf,
1180                     [transl_unbox_float arg1; transl_unbox_float arg2]))
1181   | Pdivfloat ->
1182       box_float(Cop(Cdivf,
1183                     [transl_unbox_float arg1; transl_unbox_float arg2]))
1184   | Pfloatcomp cmp ->
1185       tag_int(Cop(Ccmpf(transl_comparison cmp),
1186                   [transl_unbox_float arg1; transl_unbox_float arg2]))
1187
1188   (* String operations *)
1189   | Pstringrefu ->
1190       tag_int(Cop(Cload Byte_unsigned,
1191                   [add_int (transl arg1) (untag_int(transl arg2))]))
1192   | Pstringrefs ->
1193       tag_int
1194         (bind "str" (transl arg1) (fun str ->
1195           bind "index" (untag_int (transl arg2)) (fun idx ->
1196             Csequence(
1197               Cop(Ccheckbound dbg, [string_length str; idx]),
1198               Cop(Cload Byte_unsigned, [add_int str idx])))))
1199
1200   (* Array operations *)
1201   | Parrayrefu kind ->
1202       begin match kind with
1203         Pgenarray ->
1204           bind "arr" (transl arg1) (fun arr ->
1205             bind "index" (transl arg2) (fun idx ->
1206               Cifthenelse(is_addr_array_ptr arr,
1207                           addr_array_ref arr idx,
1208                           float_array_ref arr idx)))
1209       | Paddrarray | Pintarray ->
1210           addr_array_ref (transl arg1) (transl arg2)
1211       | Pfloatarray ->
1212           float_array_ref (transl arg1) (transl arg2)
1213       end
1214   | Parrayrefs kind ->
1215       begin match kind with
1216         Pgenarray ->
1217           bind "index" (transl arg2) (fun idx ->
1218             bind "arr" (transl arg1) (fun arr ->
1219               bind "header" (header arr) (fun hdr ->
1220                 Cifthenelse(is_addr_array_hdr hdr,
1221                   Csequence(Cop(Ccheckbound dbg, [addr_array_length hdr; idx]),
1222                             addr_array_ref arr idx),
1223                   Csequence(Cop(Ccheckbound dbg, [float_array_length hdr; idx]),
1224                             float_array_ref arr idx)))))
1225       | Paddrarray | Pintarray ->
1226           bind "index" (transl arg2) (fun idx ->
1227             bind "arr" (transl arg1) (fun arr ->
1228               Csequence(Cop(Ccheckbound dbg, [addr_array_length(header arr); idx]),
1229                         addr_array_ref arr idx)))
1230       | Pfloatarray ->
1231           box_float(
1232             bind "index" (transl arg2) (fun idx ->
1233               bind "arr" (transl arg1) (fun arr ->
1234                 Csequence(Cop(Ccheckbound dbg,
1235                               [float_array_length(header arr); idx]),
1236                           unboxed_float_array_ref arr idx))))
1237       end
1238
1239   (* Operations on bitvects *)
1240   | Pbittest ->
1241       bind "index" (untag_int(transl arg2)) (fun idx ->
1242         tag_int(
1243           Cop(Cand, [Cop(Clsr, [Cop(Cload Byte_unsigned,
1244                                     [add_int (transl arg1)
1245                                       (Cop(Clsr, [idx; Cconst_int 3]))]);
1246                                 Cop(Cand, [idx; Cconst_int 7])]);
1247                      Cconst_int 1])))
1248
1249   (* Boxed integers *)
1250   | Paddbint bi ->
1251       box_int bi (Cop(Caddi,
1252                       [transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
1253   | Psubbint bi ->
1254       box_int bi (Cop(Csubi,
1255                       [transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
1256   | Pmulbint bi ->
1257       box_int bi (Cop(Cmuli,
1258                       [transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
1259   | Pdivbint bi ->
1260       box_int bi (safe_divmod Cdivi
1261                       (transl_unbox_int bi arg1) (transl_unbox_int bi arg2)
1262                       dbg)
1263   | Pmodbint bi ->
1264       box_int bi (safe_divmod Cmodi
1265                       (transl_unbox_int bi arg1) (transl_unbox_int bi arg2)
1266                       dbg)
1267   | Pandbint bi ->
1268       box_int bi (Cop(Cand,
1269                      [transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
1270   | Porbint bi ->
1271       box_int bi (Cop(Cor,
1272                      [transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
1273   | Pxorbint bi ->
1274       box_int bi (Cop(Cxor,
1275                      [transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
1276   | Plslbint bi ->
1277       box_int bi (Cop(Clsl,
1278                      [transl_unbox_int bi arg1; untag_int(transl arg2)]))
1279   | Plsrbint bi ->
1280       box_int bi (Cop(Clsr,
1281                      [make_unsigned_int bi (transl_unbox_int bi arg1);
1282                       untag_int(transl arg2)]))
1283   | Pasrbint bi ->
1284       box_int bi (Cop(Casr,
1285                      [transl_unbox_int bi arg1; untag_int(transl arg2)]))
1286   | Pbintcomp(bi, cmp) ->
1287       tag_int (Cop(Ccmpi(transl_comparison cmp),
1288                      [transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
1289   | _ ->
1290       fatal_error "Cmmgen.transl_prim_2"
1291
1292 and transl_prim_3 p arg1 arg2 arg3 dbg =
1293   match p with
1294   (* String operations *)
1295     Pstringsetu ->
1296       return_unit(Cop(Cstore Byte_unsigned,
1297                       [add_int (transl arg1) (untag_int(transl arg2));
1298                         untag_int(transl arg3)]))
1299   | Pstringsets ->
1300       return_unit
1301         (bind "str" (transl arg1) (fun str ->
1302           bind "index" (untag_int (transl arg2)) (fun idx ->
1303             Csequence(
1304               Cop(Ccheckbound dbg, [string_length str; idx]),
1305               Cop(Cstore Byte_unsigned,
1306                   [add_int str idx; untag_int(transl arg3)])))))
1307
1308   (* Array operations *)
1309   | Parraysetu kind ->
1310       return_unit(begin match kind with
1311         Pgenarray ->
1312           bind "newval" (transl arg3) (fun newval ->
1313             bind "index" (transl arg2) (fun index ->
1314               bind "arr" (transl arg1) (fun arr ->
1315                 Cifthenelse(is_addr_array_ptr arr,
1316                             addr_array_set arr index newval,
1317                             float_array_set arr index (unbox_float newval)))))
1318       | Paddrarray ->
1319           addr_array_set (transl arg1) (transl arg2) (transl arg3)
1320       | Pintarray ->
1321           int_array_set (transl arg1) (transl arg2) (transl arg3)
1322       | Pfloatarray ->
1323           float_array_set (transl arg1) (transl arg2) (transl_unbox_float arg3)
1324       end)
1325   | Parraysets kind ->
1326       return_unit(begin match kind with
1327         Pgenarray ->
1328           bind "newval" (transl arg3) (fun newval ->
1329             bind "index" (transl arg2) (fun idx ->
1330               bind "arr" (transl arg1) (fun arr ->
1331                 bind "header" (header arr) (fun hdr ->
1332                   Cifthenelse(is_addr_array_hdr hdr,
1333                     Csequence(Cop(Ccheckbound dbg, [addr_array_length hdr; idx]),
1334                               addr_array_set arr idx newval),
1335                     Csequence(Cop(Ccheckbound dbg, [float_array_length hdr; idx]),
1336                               float_array_set arr idx
1337                                               (unbox_float newval)))))))
1338       | Paddrarray ->
1339           bind "index" (transl arg2) (fun idx ->
1340             bind "arr" (transl arg1) (fun arr ->
1341               Csequence(Cop(Ccheckbound dbg, [addr_array_length(header arr); idx]),
1342                         addr_array_set arr idx (transl arg3))))
1343       | Pintarray ->
1344           bind "index" (transl arg2) (fun idx ->
1345             bind "arr" (transl arg1) (fun arr ->
1346               Csequence(Cop(Ccheckbound dbg, [addr_array_length(header arr); idx]),
1347                         int_array_set arr idx (transl arg3))))
1348       | Pfloatarray ->
1349           bind "index" (transl arg2) (fun idx ->
1350             bind "arr" (transl arg1) (fun arr ->
1351               Csequence(Cop(Ccheckbound dbg, [float_array_length(header arr);idx]),
1352                         float_array_set arr idx (transl_unbox_float arg3))))
1353       end)
1354   | _ ->
1355     fatal_error "Cmmgen.transl_prim_3"
1356
1357 and transl_unbox_float = function
1358     Uconst(Const_base(Const_float f)) -> Cconst_float f
1359   | exp -> unbox_float(transl exp)
1360
1361 and transl_unbox_int bi = function
1362     Uconst(Const_base(Const_int32 n)) ->
1363       Cconst_natint (Nativeint.of_int32 n)
1364   | Uconst(Const_base(Const_nativeint n)) ->
1365       Cconst_natint n
1366   | Uconst(Const_base(Const_int64 n)) ->
1367       assert (size_int = 8); Cconst_natint (Int64.to_nativeint n)
1368   | Uprim(Pbintofint bi', [Uconst(Const_base(Const_int i))], _) when bi = bi' ->
1369       Cconst_int i
1370   | exp -> unbox_int bi (transl exp)
1371
1372 and transl_unbox_let box_fn unbox_fn transl_unbox_fn id exp body =
1373   let unboxed_id = Ident.create (Ident.name id) in
1374   let trbody1 = transl body in
1375   let (trbody2, need_boxed, is_assigned) =
1376     subst_boxed_number unbox_fn id unboxed_id trbody1 in
1377   if need_boxed && is_assigned then
1378     Clet(id, transl exp, trbody1)
1379   else
1380     Clet(unboxed_id, transl_unbox_fn exp,
1381          if need_boxed
1382          then Clet(id, box_fn(Cvar unboxed_id), trbody2)
1383          else trbody2)
1384
1385 and make_catch ncatch body handler = match body with
1386 | Cexit (nexit,[]) when nexit=ncatch -> handler
1387 | _ ->  Ccatch (ncatch, [], body, handler)
1388
1389 and make_catch2 mk_body handler = match handler with
1390 | Cexit (_,[])|Ctuple []|Cconst_int _|Cconst_pointer _ ->
1391     mk_body handler
1392 | _ ->
1393     let nfail = next_raise_count () in
1394     make_catch
1395       nfail
1396       (mk_body (Cexit (nfail,[])))
1397       handler
1398
1399 and exit_if_true cond nfail otherwise =
1400   match cond with
1401   | Uconst (Const_pointer 0) -> otherwise
1402   | Uconst (Const_pointer 1) -> Cexit (nfail,[])
1403   | Uprim(Psequor, [arg1; arg2], _) ->
1404       exit_if_true arg1 nfail (exit_if_true arg2 nfail otherwise)
1405   | Uprim(Psequand, _, _) ->
1406       begin match otherwise with
1407       | Cexit (raise_num,[]) ->
1408           exit_if_false cond (Cexit (nfail,[])) raise_num
1409       | _ ->
1410           let raise_num = next_raise_count () in
1411           make_catch
1412             raise_num
1413             (exit_if_false cond (Cexit (nfail,[])) raise_num)
1414             otherwise
1415       end
1416   | Uprim(Pnot, [arg], _) ->
1417       exit_if_false arg otherwise nfail
1418   | Uifthenelse (cond, ifso, ifnot) ->
1419       make_catch2
1420         (fun shared ->
1421           Cifthenelse
1422             (test_bool (transl cond),
1423              exit_if_true ifso nfail shared,
1424              exit_if_true ifnot nfail shared))
1425         otherwise
1426   | _ ->
1427       Cifthenelse(test_bool(transl cond), Cexit (nfail, []), otherwise)
1428
1429 and exit_if_false cond otherwise nfail =
1430   match cond with
1431   | Uconst (Const_pointer 0) -> Cexit (nfail,[])
1432   | Uconst (Const_pointer 1) -> otherwise
1433   | Uprim(Psequand, [arg1; arg2], _) ->
1434       exit_if_false arg1 (exit_if_false arg2 otherwise nfail) nfail
1435   | Uprim(Psequor, _, _) ->
1436       begin match otherwise with
1437       | Cexit (raise_num,[]) ->
1438           exit_if_true cond raise_num (Cexit (nfail,[]))
1439       | _ ->
1440           let raise_num = next_raise_count () in
1441           make_catch
1442             raise_num
1443             (exit_if_true cond raise_num (Cexit (nfail,[])))
1444             otherwise
1445       end
1446   | Uprim(Pnot, [arg], _) ->
1447       exit_if_true arg nfail otherwise
1448   | Uifthenelse (cond, ifso, ifnot) ->
1449       make_catch2
1450         (fun shared ->
1451           Cifthenelse
1452             (test_bool (transl cond),
1453              exit_if_false ifso shared nfail,
1454              exit_if_false ifnot shared nfail))
1455         otherwise
1456   | _ ->
1457       Cifthenelse(test_bool(transl cond), otherwise, Cexit (nfail, []))
1458
1459 and transl_switch arg index cases = match Array.length cases with
1460 | 0 -> fatal_error "Cmmgen.transl_switch"
1461 | 1 -> transl cases.(0)
1462 | _ ->
1463     let n_index = Array.length index in
1464     let actions = Array.map transl cases in
1465
1466     let inters = ref []
1467     and this_high = ref (n_index-1)
1468     and this_low = ref (n_index-1)
1469     and this_act = ref index.(n_index-1) in
1470     for i = n_index-2 downto 0 do
1471       let act = index.(i) in
1472       if act = !this_act then
1473         decr this_low
1474       else begin
1475         inters := (!this_low, !this_high, !this_act) :: !inters ;
1476         this_high := i ;
1477         this_low := i ;
1478         this_act := act
1479       end
1480     done ;
1481     inters := (0, !this_high, !this_act) :: !inters ;
1482     bind "switcher" arg
1483       (fun a ->
1484         SwitcherBlocks.zyva
1485           (0,n_index-1)
1486           (fun i -> Cconst_int i)
1487           a
1488           (Array.of_list !inters) actions)
1489
1490 and transl_letrec bindings cont =
1491   let bsz = List.map (fun (id, exp) -> (id, exp, expr_size exp)) bindings in
1492   let rec init_blocks = function
1493     | [] -> fill_nonrec bsz
1494     | (id, exp, RHS_block sz) :: rem ->
1495         Clet(id, Cop(Cextcall("caml_alloc_dummy", typ_addr, true, Debuginfo.none),
1496                      [int_const sz]),
1497              init_blocks rem)
1498     | (id, exp, RHS_nonrec) :: rem ->
1499         Clet (id, Cconst_int 0, init_blocks rem)
1500   and fill_nonrec = function
1501     | [] -> fill_blocks bsz
1502     | (id, exp, RHS_block sz) :: rem -> fill_nonrec rem
1503     | (id, exp, RHS_nonrec) :: rem ->
1504         Clet (id, transl exp, fill_nonrec rem)
1505   and fill_blocks = function
1506     | [] -> cont
1507     | (id, exp, RHS_block _) :: rem ->
1508         Csequence(Cop(Cextcall("caml_update_dummy", typ_void, false, Debuginfo.none),
1509                       [Cvar id; transl exp]),
1510                   fill_blocks rem)
1511     | (id, exp, RHS_nonrec) :: rem ->
1512         fill_blocks rem
1513   in init_blocks bsz
1514
1515 (* Translate a function definition *)
1516
1517 let transl_function lbl params body =
1518   Cfunction {fun_name = lbl;
1519              fun_args = List.map (fun id -> (id, typ_addr)) params;
1520              fun_body = transl body;
1521              fun_fast = !Clflags.optimize_for_speed}
1522
1523 (* Translate all function definitions *)
1524
1525 module StringSet =
1526   Set.Make(struct
1527     type t = string
1528     let compare = compare
1529   end)
1530
1531 let rec transl_all_functions already_translated cont =
1532   try
1533     let (lbl, params, body) = Queue.take functions in
1534     if StringSet.mem lbl already_translated then
1535       transl_all_functions already_translated cont
1536     else begin
1537       transl_all_functions (StringSet.add lbl already_translated)
1538                            (transl_function lbl params body :: cont)
1539     end
1540   with Queue.Empty ->
1541     cont
1542
1543 (* Emit structured constants *)
1544
1545 let immstrings = Hashtbl.create 17
1546
1547 let rec emit_constant symb cst cont =
1548   match cst with
1549     Const_base(Const_float s) ->
1550       Cint(float_header) :: Cdefine_symbol symb :: Cdouble s :: cont
1551   | Const_base(Const_string s) | Const_immstring s ->
1552       Cint(string_header (String.length s)) ::
1553       Cdefine_symbol symb ::
1554       emit_string_constant s cont
1555   | Const_base(Const_int32 n) ->
1556       Cint(boxedint_header) :: Cdefine_symbol symb ::
1557       emit_boxed_int32_constant n cont
1558   | Const_base(Const_int64 n) ->
1559       Cint(boxedint_header) :: Cdefine_symbol symb ::
1560       emit_boxed_int64_constant n cont
1561   | Const_base(Const_nativeint n) ->
1562       Cint(boxedint_header) :: Cdefine_symbol symb ::
1563       emit_boxed_nativeint_constant n cont
1564   | Const_block(tag, fields) ->
1565       let (emit_fields, cont1) = emit_constant_fields fields cont in
1566       Cint(block_header tag (List.length fields)) ::
1567       Cdefine_symbol symb ::
1568       emit_fields @ cont1
1569   | Const_float_array(fields) ->
1570       Cint(floatarray_header (List.length fields)) ::
1571       Cdefine_symbol symb ::
1572       Misc.map_end (fun f -> Cdouble f) fields cont
1573   | _ -> fatal_error "gencmm.emit_constant"
1574
1575 and emit_constant_fields fields cont =
1576   match fields with
1577     [] -> ([], cont)
1578   | f1 :: fl ->
1579       let (data1, cont1) = emit_constant_field f1 cont in
1580       let (datal, contl) = emit_constant_fields fl cont1 in
1581       (data1 :: datal, contl)
1582
1583 and emit_constant_field field cont =
1584   match field with
1585     Const_base(Const_int n) ->
1586       (Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n),
1587        cont)
1588   | Const_base(Const_char c) ->
1589       (Cint(Nativeint.of_int(((Char.code c) lsl 1) + 1)), cont)
1590   | Const_base(Const_float s) ->
1591       let lbl = new_const_label() in
1592       (Clabel_address lbl,
1593        Cint(float_header) :: Cdefine_label lbl :: Cdouble s :: cont)
1594   | Const_base(Const_string s) ->
1595       let lbl = new_const_label() in
1596       (Clabel_address lbl,
1597        Cint(string_header (String.length s)) :: Cdefine_label lbl ::
1598        emit_string_constant s cont)
1599   | Const_immstring s ->
1600       begin try
1601         (Clabel_address (Hashtbl.find immstrings s), cont)
1602       with Not_found ->
1603         let lbl = new_const_label() in
1604         Hashtbl.add immstrings s lbl;
1605         (Clabel_address lbl,
1606          Cint(string_header (String.length s)) :: Cdefine_label lbl ::
1607          emit_string_constant s cont)
1608       end
1609   | Const_base(Const_int32 n) ->
1610       let lbl = new_const_label() in
1611       (Clabel_address lbl,
1612        Cint(boxedint_header) :: Cdefine_label lbl ::
1613        emit_boxed_int32_constant n cont)
1614   | Const_base(Const_int64 n) ->
1615       let lbl = new_const_label() in
1616       (Clabel_address lbl,
1617        Cint(boxedint_header) :: Cdefine_label lbl ::
1618        emit_boxed_int64_constant n cont)
1619   | Const_base(Const_nativeint n) ->
1620       let lbl = new_const_label() in
1621       (Clabel_address lbl,
1622        Cint(boxedint_header) :: Cdefine_label lbl ::
1623        emit_boxed_nativeint_constant n cont)
1624   | Const_pointer n ->
1625       (Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n),
1626        cont)
1627   | Const_block(tag, fields) ->
1628       let lbl = new_const_label() in
1629       let (emit_fields, cont1) = emit_constant_fields fields cont in
1630       (Clabel_address lbl,
1631        Cint(block_header tag (List.length fields)) :: Cdefine_label lbl ::
1632        emit_fields @ cont1)
1633   | Const_float_array(fields) ->
1634       let lbl = new_const_label() in
1635       (Clabel_address lbl,
1636        Cint(floatarray_header (List.length fields)) :: Cdefine_label lbl ::
1637        Misc.map_end (fun f -> Cdouble f) fields cont)
1638
1639 and emit_string_constant s cont =
1640   let n = size_int - 1 - (String.length s) mod size_int in
1641   Cstring s :: Cskip n :: Cint8 n :: cont
1642
1643 and emit_boxed_int32_constant n cont =
1644   let n = Nativeint.of_int32 n in
1645   if size_int = 8 then
1646     Csymbol_address("caml_int32_ops") :: Cint32 n :: Cint32 0n :: cont
1647   else
1648     Csymbol_address("caml_int32_ops") :: Cint n :: cont
1649
1650 and emit_boxed_nativeint_constant n cont =
1651   Csymbol_address("caml_nativeint_ops") :: Cint n :: cont
1652
1653 and emit_boxed_int64_constant n cont =
1654   let lo = Int64.to_nativeint n in
1655   if size_int = 8 then
1656     Csymbol_address("caml_int64_ops") :: Cint lo :: cont
1657   else begin
1658     let hi = Int64.to_nativeint (Int64.shift_right n 32) in
1659     if big_endian then
1660       Csymbol_address("caml_int64_ops") :: Cint hi :: Cint lo :: cont
1661     else
1662       Csymbol_address("caml_int64_ops") :: Cint lo :: Cint hi :: cont
1663   end
1664
1665 (* Emit constant closures *)
1666
1667 let emit_constant_closure symb fundecls cont =
1668   match fundecls with
1669     [] -> assert false
1670   | (label, arity, params, body) :: remainder ->
1671       let rec emit_others pos = function
1672         [] -> cont
1673       | (label, arity, params, body) :: rem ->
1674           if arity = 1 then
1675             Cint(infix_header pos) ::
1676             Csymbol_address label ::
1677             Cint 3n ::
1678             emit_others (pos + 3) rem
1679           else
1680             Cint(infix_header pos) ::
1681             Csymbol_address(curry_function arity) ::
1682             Cint(Nativeint.of_int (arity lsl 1 + 1)) ::
1683             Csymbol_address label ::
1684             emit_others (pos + 4) rem in
1685       Cint(closure_header (fundecls_size fundecls)) ::
1686       Cdefine_symbol symb ::
1687       if arity = 1 then
1688         Csymbol_address label ::
1689         Cint 3n ::
1690         emit_others 3 remainder
1691       else
1692         Csymbol_address(curry_function arity) ::
1693         Cint(Nativeint.of_int (arity lsl 1 + 1)) ::
1694         Csymbol_address label ::
1695         emit_others 4 remainder
1696
1697 (* Emit all structured constants *)
1698
1699 let emit_all_constants cont =
1700   let c = ref cont in
1701   List.iter
1702     (fun (lbl, cst) -> c := Cdata(emit_constant lbl cst []) :: !c)
1703     !structured_constants;
1704   structured_constants := [];
1705   Hashtbl.clear immstrings;   (* PR#3979 *)
1706   List.iter
1707     (fun (symb, fundecls) ->
1708         c := Cdata(emit_constant_closure symb fundecls []) :: !c)
1709     !constant_closures;
1710   constant_closures := [];
1711   !c
1712
1713 (* Translate a compilation unit *)
1714
1715 let compunit size ulam =
1716   let glob = Compilenv.make_symbol None in
1717   let init_code = transl ulam in
1718   let c1 = [Cfunction {fun_name = Compilenv.make_symbol (Some "entry");
1719                        fun_args = [];
1720                        fun_body = init_code; fun_fast = false}] in
1721   let c2 = transl_all_functions StringSet.empty c1 in
1722   let c3 = emit_all_constants c2 in
1723   Cdata [Cint(block_header 0 size);
1724          Cglobal_symbol glob;
1725          Cdefine_symbol glob;
1726          Cskip(size * size_addr)] :: c3
1727
1728 (*
1729 CAMLprim value caml_cache_public_method (value meths, value tag, value *cache)
1730 {
1731   int li = 3, hi = Field(meths,0), mi;
1732   while (li < hi) { // no need to check the 1st time
1733     mi = ((li+hi) >> 1) | 1;
1734     if (tag < Field(meths,mi)) hi = mi-2;
1735     else li = mi;
1736   }
1737   *cache = (li-3)*sizeof(value)+1;
1738   return Field (meths, li-1);
1739 }
1740 *)
1741
1742 let cache_public_method meths tag cache =
1743   let raise_num = next_raise_count () in
1744   let li = Ident.create "li" and hi = Ident.create "hi"
1745   and mi = Ident.create "mi" and tagged = Ident.create "tagged" in
1746   Clet (
1747   li, Cconst_int 3,
1748   Clet (
1749   hi, Cop(Cload Word, [meths]),
1750   Csequence(
1751   Ccatch
1752     (raise_num, [],
1753      Cloop
1754        (Clet(
1755         mi,
1756         Cop(Cor,
1757             [Cop(Clsr, [Cop(Caddi, [Cvar li; Cvar hi]); Cconst_int 1]);
1758              Cconst_int 1]),
1759         Csequence(
1760         Cifthenelse
1761           (Cop (Ccmpi Clt,
1762                 [tag;
1763                  Cop(Cload Word,
1764                      [Cop(Cadda,
1765                           [meths; lsl_const (Cvar mi) log2_size_addr])])]),
1766            Cassign(hi, Cop(Csubi, [Cvar mi; Cconst_int 2])),
1767            Cassign(li, Cvar mi)),
1768         Cifthenelse
1769           (Cop(Ccmpi Cge, [Cvar li; Cvar hi]), Cexit (raise_num, []),
1770            Ctuple [])))),
1771      Ctuple []),
1772   Clet (
1773   tagged, Cop(Cadda, [lsl_const (Cvar li) log2_size_addr;
1774                       Cconst_int(1 - 3 * size_addr)]),
1775   Csequence(Cop (Cstore Word, [cache; Cvar tagged]),
1776             Cvar tagged)))))
1777
1778 (* Generate an application function:
1779      (defun caml_applyN (a1 ... aN clos)
1780        (if (= clos.arity N)
1781          (app clos.direct a1 ... aN clos)
1782          (let (clos1 (app clos.code a1 clos)
1783                clos2 (app clos1.code a2 clos)
1784                ...
1785                closN-1 (app closN-2.code aN-1 closN-2))
1786            (app closN-1.code aN closN-1))))
1787 *)
1788
1789 let apply_function_body arity =
1790   let arg = Array.create arity (Ident.create "arg") in
1791   for i = 1 to arity - 1 do arg.(i) <- Ident.create "arg" done;
1792   let clos = Ident.create "clos" in
1793   let rec app_fun clos n =
1794     if n = arity-1 then
1795       Cop(Capply(typ_addr, Debuginfo.none),
1796           [get_field (Cvar clos) 0; Cvar arg.(n); Cvar clos])
1797     else begin
1798       let newclos = Ident.create "clos" in
1799       Clet(newclos,
1800            Cop(Capply(typ_addr, Debuginfo.none),
1801                [get_field (Cvar clos) 0; Cvar arg.(n); Cvar clos]),
1802            app_fun newclos (n+1))
1803     end in
1804   let args = Array.to_list arg in
1805   let all_args = args @ [clos] in
1806   (args, clos,
1807    if arity = 1 then app_fun clos 0 else
1808    Cifthenelse(
1809    Cop(Ccmpi Ceq, [get_field (Cvar clos) 1; int_const arity]),
1810    Cop(Capply(typ_addr, Debuginfo.none),
1811        get_field (Cvar clos) 2 :: List.map (fun s -> Cvar s) all_args),
1812    app_fun clos 0))
1813
1814 let send_function arity =
1815   let (args, clos', body) = apply_function_body (1+arity) in
1816   let cache = Ident.create "cache"
1817   and obj = List.hd args
1818   and tag = Ident.create "tag" in
1819   let clos =
1820     let cache = Cvar cache and obj = Cvar obj and tag = Cvar tag in
1821     let meths = Ident.create "meths" and cached = Ident.create "cached" in
1822     let real = Ident.create "real" in
1823     let mask = get_field (Cvar meths) 1 in
1824     let cached_pos = Cvar cached in
1825     let tag_pos = Cop(Cadda, [Cop (Cadda, [cached_pos; Cvar meths]);
1826                               Cconst_int(3*size_addr-1)]) in
1827     let tag' = Cop(Cload Word, [tag_pos]) in
1828     Clet (
1829     meths, Cop(Cload Word, [obj]),
1830     Clet (
1831     cached, Cop(Cand, [Cop(Cload Word, [cache]); mask]),
1832     Clet (
1833     real,
1834     Cifthenelse(Cop(Ccmpa Cne, [tag'; tag]),
1835                 cache_public_method (Cvar meths) tag cache,
1836                 cached_pos),
1837     Cop(Cload Word, [Cop(Cadda, [Cop (Cadda, [Cvar real; Cvar meths]);
1838                                  Cconst_int(2*size_addr-1)])]))))
1839
1840   in
1841   let body = Clet(clos', clos, body) in
1842   let fun_args =
1843     [obj, typ_addr; tag, typ_int; cache, typ_addr]
1844     @ List.map (fun id -> (id, typ_addr)) (List.tl args) in
1845   Cfunction
1846    {fun_name = "caml_send" ^ string_of_int arity;
1847     fun_args = fun_args;
1848     fun_body = body;
1849     fun_fast = true}
1850
1851 let apply_function arity =
1852   let (args, clos, body) = apply_function_body arity in
1853   let all_args = args @ [clos] in
1854   Cfunction
1855    {fun_name = "caml_apply" ^ string_of_int arity;
1856     fun_args = List.map (fun id -> (id, typ_addr)) all_args;
1857     fun_body = body;
1858     fun_fast = true}
1859
1860 (* Generate tuplifying functions:
1861       (defun caml_tuplifyN (arg clos)
1862         (app clos.direct #0(arg) ... #N-1(arg) clos)) *)
1863
1864 let tuplify_function arity =
1865   let arg = Ident.create "arg" in
1866   let clos = Ident.create "clos" in
1867   let rec access_components i =
1868     if i >= arity
1869     then []
1870     else get_field (Cvar arg) i :: access_components(i+1) in
1871   Cfunction
1872    {fun_name = "caml_tuplify" ^ string_of_int arity;
1873     fun_args = [arg, typ_addr; clos, typ_addr];
1874     fun_body =
1875       Cop(Capply(typ_addr, Debuginfo.none),
1876           get_field (Cvar clos) 2 :: access_components 0 @ [Cvar clos]);
1877     fun_fast = true}
1878
1879 (* Generate currying functions:
1880       (defun caml_curryN (arg clos)
1881          (alloc HDR caml_curryN_1 arg clos))
1882       (defun caml_curryN_1 (arg clos)
1883          (alloc HDR caml_curryN_2 arg clos))
1884       ...
1885       (defun caml_curryN_N-1 (arg clos)
1886          (let (closN-2 clos.cdr
1887                closN-3 closN-2.cdr
1888                ...
1889                clos1 clos2.cdr
1890                clos clos1.cdr)
1891            (app clos.direct
1892                 clos1.car clos2.car ... closN-2.car clos.car arg clos))) *)
1893
1894 let final_curry_function arity =
1895   let last_arg = Ident.create "arg" in
1896   let last_clos = Ident.create "clos" in
1897   let rec curry_fun args clos n =
1898     if n = 0 then
1899       Cop(Capply(typ_addr, Debuginfo.none),
1900           get_field (Cvar clos) 2 ::
1901           args @ [Cvar last_arg; Cvar clos])
1902     else begin
1903       let newclos = Ident.create "clos" in
1904       Clet(newclos,
1905            get_field (Cvar clos) 3,
1906            curry_fun (get_field (Cvar clos) 2 :: args) newclos (n-1))
1907     end in
1908   Cfunction
1909    {fun_name = "caml_curry" ^ string_of_int arity ^
1910                "_" ^ string_of_int (arity-1);
1911     fun_args = [last_arg, typ_addr; last_clos, typ_addr];
1912     fun_body = curry_fun [] last_clos (arity-1);
1913     fun_fast = true}
1914
1915 let rec intermediate_curry_functions arity num =
1916   if num = arity - 1 then
1917     [final_curry_function arity]
1918   else begin
1919     let name1 = "caml_curry" ^ string_of_int arity in
1920     let name2 = if num = 0 then name1 else name1 ^ "_" ^ string_of_int num in
1921     let arg = Ident.create "arg" and clos = Ident.create "clos" in
1922     Cfunction
1923      {fun_name = name2;
1924       fun_args = [arg, typ_addr; clos, typ_addr];
1925       fun_body = Cop(Calloc,
1926                      [alloc_closure_header 4;
1927                       Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1));
1928                       int_const 1; Cvar arg; Cvar clos]);
1929       fun_fast = true}
1930     :: intermediate_curry_functions arity (num+1)
1931   end
1932
1933 let curry_function arity =
1934   if arity >= 0
1935   then intermediate_curry_functions arity 0
1936   else [tuplify_function (-arity)]
1937
1938
1939 module IntSet = Set.Make(
1940   struct
1941     type t = int
1942     let compare = compare
1943   end)
1944
1945 let default_apply = IntSet.add 2 (IntSet.add 3 IntSet.empty)
1946   (* These apply funs are always present in the main program because
1947      the run-time system needs them (cf. asmrun/<arch>.S) . *)
1948
1949 let generic_functions shared units =
1950   let (apply,send,curry) =
1951     List.fold_left
1952       (fun (apply,send,curry) ui ->
1953          List.fold_right IntSet.add ui.Compilenv.ui_apply_fun apply,
1954          List.fold_right IntSet.add ui.Compilenv.ui_send_fun send,
1955          List.fold_right IntSet.add ui.Compilenv.ui_curry_fun curry)
1956       (IntSet.empty,IntSet.empty,IntSet.empty)
1957       units in
1958   let apply = if shared then apply else IntSet.union apply default_apply in
1959   let accu = IntSet.fold (fun n accu -> apply_function n :: accu) apply [] in
1960   let accu = IntSet.fold (fun n accu -> send_function n :: accu) send accu in
1961   IntSet.fold (fun n accu -> curry_function n @ accu) curry accu
1962
1963 (* Generate the entry point *)
1964
1965 let entry_point namelist =
1966   let incr_global_inited =
1967     Cop(Cstore Word,
1968         [Cconst_symbol "caml_globals_inited";
1969          Cop(Caddi, [Cop(Cload Word, [Cconst_symbol "caml_globals_inited"]);
1970                      Cconst_int 1])]) in
1971   let body =
1972     List.fold_right
1973       (fun name next ->
1974         let entry_sym = Compilenv.make_symbol ~unitname:name (Some "entry") in
1975         Csequence(Cop(Capply(typ_void, Debuginfo.none),
1976                          [Cconst_symbol entry_sym]),
1977                   Csequence(incr_global_inited, next)))
1978       namelist (Cconst_int 1) in
1979   Cfunction {fun_name = "caml_program";
1980              fun_args = [];
1981              fun_body = body;
1982              fun_fast = false}
1983
1984 (* Generate the table of globals *)
1985
1986 let cint_zero = Cint 0n
1987
1988 let global_table namelist =
1989   let mksym name =
1990     Csymbol_address (Compilenv.make_symbol ~unitname:name None)
1991   in
1992   Cdata(Cglobal_symbol "caml_globals" ::
1993         Cdefine_symbol "caml_globals" ::
1994         List.map mksym namelist @
1995         [cint_zero])
1996
1997 let reference_symbols namelist =
1998   let mksym name = Csymbol_address name in
1999   Cdata(List.map mksym namelist)
2000
2001 let global_data name v =
2002   Cdata(Cglobal_symbol name ::
2003           emit_constant name
2004           (Const_base (Const_string (Marshal.to_string v []))) [])
2005
2006 let globals_map v = global_data "caml_globals_map" v
2007
2008 (* Generate the master table of frame descriptors *)
2009
2010 let frame_table namelist =
2011   let mksym name =
2012     Csymbol_address (Compilenv.make_symbol ~unitname:name (Some "frametable"))
2013   in
2014   Cdata(Cglobal_symbol "caml_frametable" ::
2015         Cdefine_symbol "caml_frametable" ::
2016         List.map mksym namelist
2017         @ [cint_zero])
2018
2019 (* Generate the table of module data and code segments *)
2020
2021 let segment_table namelist symbol begname endname =
2022   let addsyms name lst =
2023     Csymbol_address (Compilenv.make_symbol ~unitname:name (Some begname)) ::
2024     Csymbol_address (Compilenv.make_symbol ~unitname:name (Some endname)) ::
2025     lst
2026   in
2027   Cdata(Cglobal_symbol symbol ::
2028         Cdefine_symbol symbol ::
2029         List.fold_right addsyms namelist [cint_zero])
2030
2031 let data_segment_table namelist =
2032   segment_table namelist "caml_data_segments" "data_begin" "data_end"
2033
2034 let code_segment_table namelist =
2035   segment_table namelist "caml_code_segments" "code_begin" "code_end"
2036
2037 (* Initialize a predefined exception *)
2038
2039 let predef_exception name =
2040   let bucketname = "caml_bucket_" ^ name in
2041   let symname = "caml_exn_" ^ name in
2042   Cdata(Cglobal_symbol symname ::
2043         emit_constant symname (Const_block(0,[Const_base(Const_string name)]))
2044         [ Cglobal_symbol bucketname;
2045           Cint(block_header 0 1);
2046           Cdefine_symbol bucketname;
2047           Csymbol_address symname ])
2048
2049 (* Header for a plugin *)
2050
2051 let mapflat f l = List.flatten (List.map f l)
2052
2053 type dynunit = {
2054   name: string;
2055   crc: Digest.t;
2056   imports_cmi: (string * Digest.t) list;
2057   imports_cmx: (string * Digest.t) list;
2058   defines: string list;
2059 }
2060
2061 type dynheader = {
2062   magic: string;
2063   units: dynunit list;
2064 }
2065
2066 let dyn_magic_number = "Caml2007D001"
2067
2068 let plugin_header units =
2069   let mk (ui,crc) =
2070     { name = ui.Compilenv.ui_name;
2071       crc = crc;
2072       imports_cmi = ui.Compilenv.ui_imports_cmi;
2073       imports_cmx = ui.Compilenv.ui_imports_cmx;
2074       defines = ui.Compilenv.ui_defines
2075     } in
2076   global_data "caml_plugin_header"
2077     { magic = dyn_magic_number; units = List.map mk units }