summaryrefslogtreecommitdiff
path: root/ocaml-binary-annot/asmcomp/cmmgen.ml
diff options
context:
space:
mode:
Diffstat (limited to 'ocaml-binary-annot/asmcomp/cmmgen.ml')
-rw-r--r--ocaml-binary-annot/asmcomp/cmmgen.ml2073
1 files changed, 2073 insertions, 0 deletions
diff --git a/ocaml-binary-annot/asmcomp/cmmgen.ml b/ocaml-binary-annot/asmcomp/cmmgen.ml
new file mode 100644
index 0000000000..bb96153fa4
--- /dev/null
+++ b/ocaml-binary-annot/asmcomp/cmmgen.ml
@@ -0,0 +1,2073 @@
+(***********************************************************************)
+(* *)
+(* 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
+open Cmx_format
+
+(* 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 boxedint32_header = block_header Obj.custom_tag 2
+let boxedint64_header = block_header Obj.custom_tag (1 + 8 / size_addr)
+let boxedintnat_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_boxedint32_header = Cconst_natint(boxedint32_header)
+let alloc_boxedint64_header = Cconst_natint(boxedint64_header)
+let alloc_boxedintnat_header = Cconst_natint(boxedintnat_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 rec unbox_float = function
+ Cop(Calloc, [header; c]) -> c
+ | Clet(id, exp, body) -> Clet(id, exp, unbox_float body)
+ | Cifthenelse(cond, e1, e2) ->
+ Cifthenelse(cond, unbox_float e1, unbox_float e2)
+ | Csequence(e1, e2) -> Csequence(e1, unbox_float e2)
+ | Cswitch(e, tbl, el) -> Cswitch(e, tbl, Array.map unbox_float el)
+ | Ccatch(n, ids, e1, e2) -> Ccatch(n, ids, unbox_float e1, unbox_float e2)
+ | Ctrywith(e1, id, e2) -> Ctrywith(unbox_float e1, id, unbox_float e2)
+ | 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 alloc_header_boxed_int bi =
+ match bi with
+ Pnativeint -> alloc_boxedintnat_header
+ | Pint32 -> alloc_boxedint32_header
+ | Pint64 -> alloc_boxedint64_header
+
+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_header_boxed_int bi;
+ Cconst_symbol(operations_boxed_int bi);
+ arg'])
+
+let rec 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
+ | Clet(id, exp, body) -> Clet(id, exp, unbox_int bi body)
+ | Cifthenelse(cond, e1, e2) ->
+ Cifthenelse(cond, unbox_int bi e1, unbox_int bi e2)
+ | Csequence(e1, e2) -> Csequence(e1, unbox_int bi e2)
+ | Cswitch(e, tbl, el) -> Cswitch(e, tbl, Array.map (unbox_int bi) el)
+ | Ccatch(n, ids, e1, e2) -> Ccatch(n, ids, unbox_int bi e1, unbox_int bi e2)
+ | Ctrywith(e1, id, e2) -> Ctrywith(unbox_int bi e1, id, unbox_int bi e2)
+ | _ ->
+ 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 unsafe elt_kind layout b args dbg =
+ let check_bound a1 a2 k =
+ if unsafe then k else Csequence(Cop(Ccheckbound dbg, [a1;a2]), k) in
+ let rec ba_indexing dim_ofs delta_ofs = function
+ [] -> assert false
+ | [arg] ->
+ bind "idx" (untag_int arg)
+ (fun idx ->
+ check_bound (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 ->
+ check_bound 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 unsafe 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 unsafe 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 unsafe elt_kind layout b args dbg])
+
+let bigarray_set unsafe 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 unsafe 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 unsafe 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(unsafe, n, Pbigarray_int64, layout) ->
+ Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
+ | Pbigarrayset(unsafe, 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(unsafe, n, Pbigarray_unknown, layout) ->
+ Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
+ | Pbigarrayset(unsafe, n, Pbigarray_unknown, layout) ->
+ Pccall (default_prim ("caml_ba_set_" ^ string_of_int n))
+ | Pbigarrayref(unsafe, n, kind, Pbigarray_unknown_layout) ->
+ Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
+ | Pbigarrayset(unsafe, 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
+ Cop(Cextcall(Primitive.native_name prim, typ_addr, prim.prim_alloc, dbg),
+ List.map transl args)
+ | (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(unsafe, num_dims, elt_kind, layout), arg1 :: argl) ->
+ let elt =
+ bigarray_get unsafe 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(unsafe, num_dims, elt_kind, layout), arg1 :: argl) ->
+ let (argidx, argnewval) = split_last argl in
+ return_unit(bigarray_set unsafe 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(boxedint32_header) :: Cdefine_symbol symb ::
+ emit_boxed_int32_constant n cont
+ | Const_base(Const_int64 n) ->
+ Cint(boxedint64_header) :: Cdefine_symbol symb ::
+ emit_boxed_int64_constant n cont
+ | Const_base(Const_nativeint n) ->
+ Cint(boxedintnat_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(boxedint32_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(boxedint64_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(boxedintnat_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 because
+ the run-time system needs them (cf. asmrun/<arch>.S) . *)
+
+let generic_functions shared units =
+ let (apply,send,curry) =
+ List.fold_left
+ (fun (apply,send,curry) ui ->
+ List.fold_right IntSet.add ui.ui_apply_fun apply,
+ List.fold_right IntSet.add ui.ui_send_fun send,
+ List.fold_right IntSet.add ui.ui_curry_fun curry)
+ (IntSet.empty,IntSet.empty,IntSet.empty)
+ units in
+ let apply = if shared then 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)
+
+let plugin_header units =
+ let mk (ui,crc) =
+ { dynu_name = ui.ui_name;
+ dynu_crc = crc;
+ dynu_imports_cmi = ui.ui_imports_cmi;
+ dynu_imports_cmx = ui.ui_imports_cmx;
+ dynu_defines = ui.ui_defines
+ } in
+ global_data "caml_plugin_header"
+ { dynu_magic = Config.cmxs_magic_number; dynu_units = List.map mk units }
View Lorry Controller Status