(**************************************************************************) (* *) (* OCaml *) (* *) (* 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 GNU Lesser General Public License version 2.1, with the *) (* special exception on linking described in the file LICENSE. *) (* *) (**************************************************************************) (* Translation of primitives *) open Misc open Asttypes open Primitive open Types open Typedtree open Typeopt open Lambda open Debuginfo.Scoped_location type error = | Unknown_builtin_primitive of string | Wrong_arity_builtin_primitive of string exception Error of Location.t * error (* Insertion of debugging events *) let event_before loc exp lam = match lam with | Lstaticraise (_,_) -> lam | _ -> if !Clflags.debug && not !Clflags.native_code then Levent(lam, {lev_loc = loc; lev_kind = Lev_before; lev_repr = None; lev_env = exp.exp_env}) else lam let event_after loc exp lam = if !Clflags.debug && not !Clflags.native_code then Levent(lam, {lev_loc = loc; lev_kind = Lev_after exp.exp_type; lev_repr = None; lev_env = exp.exp_env}) else lam type comparison = | Equal | Not_equal | Less_equal | Less_than | Greater_equal | Greater_than | Compare type comparison_kind = | Compare_generic | Compare_ints | Compare_floats | Compare_strings | Compare_bytes | Compare_nativeints | Compare_int32s | Compare_int64s type loc_kind = | Loc_FILE | Loc_LINE | Loc_MODULE | Loc_LOC | Loc_POS | Loc_FUNCTION type prim = | Primitive of Lambda.primitive * int | External of Primitive.description | Comparison of comparison * comparison_kind | Raise of Lambda.raise_kind | Raise_with_backtrace | Lazy_force | Loc of loc_kind | Send | Send_self | Send_cache let used_primitives = Hashtbl.create 7 let add_used_primitive loc env path = match path with Some (Path.Pdot _ as path) -> let path = Env.normalize_path_prefix (Some loc) env path in let unit = Path.head path in if Ident.global unit && not (Hashtbl.mem used_primitives path) then Hashtbl.add used_primitives path loc | _ -> () let clear_used_primitives () = Hashtbl.clear used_primitives let get_used_primitives () = Hashtbl.fold (fun path _ acc -> path :: acc) used_primitives [] let gen_array_kind = if Config.flat_float_array then Pgenarray else Paddrarray let prim_sys_argv = Primitive.simple ~name:"caml_sys_argv" ~arity:1 ~alloc:true let primitives_table = create_hashtable 57 [ "%identity", Primitive (Pidentity, 1); "%bytes_to_string", Primitive (Pbytes_to_string, 1); "%bytes_of_string", Primitive (Pbytes_of_string, 1); "%ignore", Primitive (Pignore, 1); "%revapply", Primitive (Prevapply, 2); "%apply", Primitive (Pdirapply, 2); "%loc_LOC", Loc Loc_LOC; "%loc_FILE", Loc Loc_FILE; "%loc_LINE", Loc Loc_LINE; "%loc_POS", Loc Loc_POS; "%loc_MODULE", Loc Loc_MODULE; "%loc_FUNCTION", Loc Loc_FUNCTION; "%field0", Primitive ((Pfield 0), 1); "%field1", Primitive ((Pfield 1), 1); "%setfield0", Primitive ((Psetfield(0, Pointer, Assignment)), 2); "%makeblock", Primitive ((Pmakeblock(0, Immutable, None)), 1); "%makemutable", Primitive ((Pmakeblock(0, Mutable, None)), 1); "%raise", Raise Raise_regular; "%reraise", Raise Raise_reraise; "%raise_notrace", Raise Raise_notrace; "%raise_with_backtrace", Raise_with_backtrace; "%sequand", Primitive (Psequand, 2); "%sequor", Primitive (Psequor, 2); "%boolnot", Primitive (Pnot, 1); "%big_endian", Primitive ((Pctconst Big_endian), 1); "%backend_type", Primitive ((Pctconst Backend_type), 1); "%word_size", Primitive ((Pctconst Word_size), 1); "%int_size", Primitive ((Pctconst Int_size), 1); "%max_wosize", Primitive ((Pctconst Max_wosize), 1); "%ostype_unix", Primitive ((Pctconst Ostype_unix), 1); "%ostype_win32", Primitive ((Pctconst Ostype_win32), 1); "%ostype_cygwin", Primitive ((Pctconst Ostype_cygwin), 1); "%negint", Primitive (Pnegint, 1); "%succint", Primitive ((Poffsetint 1), 1); "%predint", Primitive ((Poffsetint(-1)), 1); "%addint", Primitive (Paddint, 2); "%subint", Primitive (Psubint, 2); "%mulint", Primitive (Pmulint, 2); "%divint", Primitive ((Pdivint Safe), 2); "%modint", Primitive ((Pmodint Safe), 2); "%andint", Primitive (Pandint, 2); "%orint", Primitive (Porint, 2); "%xorint", Primitive (Pxorint, 2); "%lslint", Primitive (Plslint, 2); "%lsrint", Primitive (Plsrint, 2); "%asrint", Primitive (Pasrint, 2); "%eq", Primitive ((Pintcomp Ceq), 2); "%noteq", Primitive ((Pintcomp Cne), 2); "%ltint", Primitive ((Pintcomp Clt), 2); "%leint", Primitive ((Pintcomp Cle), 2); "%gtint", Primitive ((Pintcomp Cgt), 2); "%geint", Primitive ((Pintcomp Cge), 2); "%incr", Primitive ((Poffsetref(1)), 1); "%decr", Primitive ((Poffsetref(-1)), 1); "%intoffloat", Primitive (Pintoffloat, 1); "%floatofint", Primitive (Pfloatofint, 1); "%negfloat", Primitive (Pnegfloat, 1); "%absfloat", Primitive (Pabsfloat, 1); "%addfloat", Primitive (Paddfloat, 2); "%subfloat", Primitive (Psubfloat, 2); "%mulfloat", Primitive (Pmulfloat, 2); "%divfloat", Primitive (Pdivfloat, 2); "%eqfloat", Primitive ((Pfloatcomp CFeq), 2); "%noteqfloat", Primitive ((Pfloatcomp CFneq), 2); "%ltfloat", Primitive ((Pfloatcomp CFlt), 2); "%lefloat", Primitive ((Pfloatcomp CFle), 2); "%gtfloat", Primitive ((Pfloatcomp CFgt), 2); "%gefloat", Primitive ((Pfloatcomp CFge), 2); "%string_length", Primitive (Pstringlength, 1); "%string_safe_get", Primitive (Pstringrefs, 2); "%string_safe_set", Primitive (Pbytessets, 3); "%string_unsafe_get", Primitive (Pstringrefu, 2); "%string_unsafe_set", Primitive (Pbytessetu, 3); "%bytes_length", Primitive (Pbyteslength, 1); "%bytes_safe_get", Primitive (Pbytesrefs, 2); "%bytes_safe_set", Primitive (Pbytessets, 3); "%bytes_unsafe_get", Primitive (Pbytesrefu, 2); "%bytes_unsafe_set", Primitive (Pbytessetu, 3); "%array_length", Primitive ((Parraylength gen_array_kind), 1); "%array_safe_get", Primitive ((Parrayrefs gen_array_kind), 2); "%array_safe_set", Primitive ((Parraysets gen_array_kind), 3); "%array_unsafe_get", Primitive ((Parrayrefu gen_array_kind), 2); "%array_unsafe_set", Primitive ((Parraysetu gen_array_kind), 3); "%obj_size", Primitive ((Parraylength gen_array_kind), 1); "%obj_field", Primitive ((Parrayrefu gen_array_kind), 2); "%obj_set_field", Primitive ((Parraysetu gen_array_kind), 3); "%floatarray_length", Primitive ((Parraylength Pfloatarray), 1); "%floatarray_safe_get", Primitive ((Parrayrefs Pfloatarray), 2); "%floatarray_safe_set", Primitive ((Parraysets Pfloatarray), 3); "%floatarray_unsafe_get", Primitive ((Parrayrefu Pfloatarray), 2); "%floatarray_unsafe_set", Primitive ((Parraysetu Pfloatarray), 3); "%obj_is_int", Primitive (Pisint, 1); "%lazy_force", Lazy_force; "%nativeint_of_int", Primitive ((Pbintofint Pnativeint), 1); "%nativeint_to_int", Primitive ((Pintofbint Pnativeint), 1); "%nativeint_neg", Primitive ((Pnegbint Pnativeint), 1); "%nativeint_add", Primitive ((Paddbint Pnativeint), 2); "%nativeint_sub", Primitive ((Psubbint Pnativeint), 2); "%nativeint_mul", Primitive ((Pmulbint Pnativeint), 2); "%nativeint_div", Primitive ((Pdivbint { size = Pnativeint; is_safe = Safe }), 2); "%nativeint_mod", Primitive ((Pmodbint { size = Pnativeint; is_safe = Safe }), 2); "%nativeint_and", Primitive ((Pandbint Pnativeint), 2); "%nativeint_or", Primitive ( (Porbint Pnativeint), 2); "%nativeint_xor", Primitive ((Pxorbint Pnativeint), 2); "%nativeint_lsl", Primitive ((Plslbint Pnativeint), 2); "%nativeint_lsr", Primitive ((Plsrbint Pnativeint), 2); "%nativeint_asr", Primitive ((Pasrbint Pnativeint), 2); "%int32_of_int", Primitive ((Pbintofint Pint32), 1); "%int32_to_int", Primitive ((Pintofbint Pint32), 1); "%int32_neg", Primitive ((Pnegbint Pint32), 1); "%int32_add", Primitive ((Paddbint Pint32), 2); "%int32_sub", Primitive ((Psubbint Pint32), 2); "%int32_mul", Primitive ((Pmulbint Pint32), 2); "%int32_div", Primitive ((Pdivbint { size = Pint32; is_safe = Safe }), 2); "%int32_mod", Primitive ((Pmodbint { size = Pint32; is_safe = Safe }), 2); "%int32_and", Primitive ((Pandbint Pint32), 2); "%int32_or", Primitive ( (Porbint Pint32), 2); "%int32_xor", Primitive ((Pxorbint Pint32), 2); "%int32_lsl", Primitive ((Plslbint Pint32), 2); "%int32_lsr", Primitive ((Plsrbint Pint32), 2); "%int32_asr", Primitive ((Pasrbint Pint32), 2); "%int64_of_int", Primitive ((Pbintofint Pint64), 1); "%int64_to_int", Primitive ((Pintofbint Pint64), 1); "%int64_neg", Primitive ((Pnegbint Pint64), 1); "%int64_add", Primitive ((Paddbint Pint64), 2); "%int64_sub", Primitive ((Psubbint Pint64), 2); "%int64_mul", Primitive ((Pmulbint Pint64), 2); "%int64_div", Primitive ((Pdivbint { size = Pint64; is_safe = Safe }), 2); "%int64_mod", Primitive ((Pmodbint { size = Pint64; is_safe = Safe }), 2); "%int64_and", Primitive ((Pandbint Pint64), 2); "%int64_or", Primitive ( (Porbint Pint64), 2); "%int64_xor", Primitive ((Pxorbint Pint64), 2); "%int64_lsl", Primitive ((Plslbint Pint64), 2); "%int64_lsr", Primitive ((Plsrbint Pint64), 2); "%int64_asr", Primitive ((Pasrbint Pint64), 2); "%nativeint_of_int32", Primitive ((Pcvtbint(Pint32, Pnativeint)), 1); "%nativeint_to_int32", Primitive ((Pcvtbint(Pnativeint, Pint32)), 1); "%int64_of_int32", Primitive ((Pcvtbint(Pint32, Pint64)), 1); "%int64_to_int32", Primitive ((Pcvtbint(Pint64, Pint32)), 1); "%int64_of_nativeint", Primitive ((Pcvtbint(Pnativeint, Pint64)), 1); "%int64_to_nativeint", Primitive ((Pcvtbint(Pint64, Pnativeint)), 1); "%caml_ba_ref_1", Primitive ((Pbigarrayref(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), 2); "%caml_ba_ref_2", Primitive ((Pbigarrayref(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), 3); "%caml_ba_ref_3", Primitive ((Pbigarrayref(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), 4); "%caml_ba_set_1", Primitive ((Pbigarrayset(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), 3); "%caml_ba_set_2", Primitive ((Pbigarrayset(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), 4); "%caml_ba_set_3", Primitive ((Pbigarrayset(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), 5); "%caml_ba_unsafe_ref_1", Primitive ((Pbigarrayref(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), 2); "%caml_ba_unsafe_ref_2", Primitive ((Pbigarrayref(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), 3); "%caml_ba_unsafe_ref_3", Primitive ((Pbigarrayref(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), 4); "%caml_ba_unsafe_set_1", Primitive ((Pbigarrayset(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), 3); "%caml_ba_unsafe_set_2", Primitive ((Pbigarrayset(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), 4); "%caml_ba_unsafe_set_3", Primitive ((Pbigarrayset(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), 5); "%caml_ba_dim_1", Primitive ((Pbigarraydim(1)), 1); "%caml_ba_dim_2", Primitive ((Pbigarraydim(2)), 1); "%caml_ba_dim_3", Primitive ((Pbigarraydim(3)), 1); "%caml_string_get16", Primitive ((Pstring_load_16(false)), 2); "%caml_string_get16u", Primitive ((Pstring_load_16(true)), 2); "%caml_string_get32", Primitive ((Pstring_load_32(false)), 2); "%caml_string_get32u", Primitive ((Pstring_load_32(true)), 2); "%caml_string_get64", Primitive ((Pstring_load_64(false)), 2); "%caml_string_get64u", Primitive ((Pstring_load_64(true)), 2); "%caml_string_set16", Primitive ((Pbytes_set_16(false)), 3); "%caml_string_set16u", Primitive ((Pbytes_set_16(true)), 3); "%caml_string_set32", Primitive ((Pbytes_set_32(false)), 3); "%caml_string_set32u", Primitive ((Pbytes_set_32(true)), 3); "%caml_string_set64", Primitive ((Pbytes_set_64(false)), 3); "%caml_string_set64u", Primitive ((Pbytes_set_64(true)), 3); "%caml_bytes_get16", Primitive ((Pbytes_load_16(false)), 2); "%caml_bytes_get16u", Primitive ((Pbytes_load_16(true)), 2); "%caml_bytes_get32", Primitive ((Pbytes_load_32(false)), 2); "%caml_bytes_get32u", Primitive ((Pbytes_load_32(true)), 2); "%caml_bytes_get64", Primitive ((Pbytes_load_64(false)), 2); "%caml_bytes_get64u", Primitive ((Pbytes_load_64(true)), 2); "%caml_bytes_set16", Primitive ((Pbytes_set_16(false)), 3); "%caml_bytes_set16u", Primitive ((Pbytes_set_16(true)), 3); "%caml_bytes_set32", Primitive ((Pbytes_set_32(false)), 3); "%caml_bytes_set32u", Primitive ((Pbytes_set_32(true)), 3); "%caml_bytes_set64", Primitive ((Pbytes_set_64(false)), 3); "%caml_bytes_set64u", Primitive ((Pbytes_set_64(true)), 3); "%caml_bigstring_get16", Primitive ((Pbigstring_load_16(false)), 2); "%caml_bigstring_get16u", Primitive ((Pbigstring_load_16(true)), 2); "%caml_bigstring_get32", Primitive ((Pbigstring_load_32(false)), 2); "%caml_bigstring_get32u", Primitive ((Pbigstring_load_32(true)), 2); "%caml_bigstring_get64", Primitive ((Pbigstring_load_64(false)), 2); "%caml_bigstring_get64u", Primitive ((Pbigstring_load_64(true)), 2); "%caml_bigstring_set16", Primitive ((Pbigstring_set_16(false)), 3); "%caml_bigstring_set16u", Primitive ((Pbigstring_set_16(true)), 3); "%caml_bigstring_set32", Primitive ((Pbigstring_set_32(false)), 3); "%caml_bigstring_set32u", Primitive ((Pbigstring_set_32(true)), 3); "%caml_bigstring_set64", Primitive ((Pbigstring_set_64(false)), 3); "%caml_bigstring_set64u", Primitive ((Pbigstring_set_64(true)), 3); "%bswap16", Primitive (Pbswap16, 1); "%bswap_int32", Primitive ((Pbbswap(Pint32)), 1); "%bswap_int64", Primitive ((Pbbswap(Pint64)), 1); "%bswap_native", Primitive ((Pbbswap(Pnativeint)), 1); "%int_as_pointer", Primitive (Pint_as_pointer, 1); "%opaque", Primitive (Popaque, 1); "%sys_argv", External prim_sys_argv; "%send", Send; "%sendself", Send_self; "%sendcache", Send_cache; "%equal", Comparison(Equal, Compare_generic); "%notequal", Comparison(Not_equal, Compare_generic); "%lessequal", Comparison(Less_equal, Compare_generic); "%lessthan", Comparison(Less_than, Compare_generic); "%greaterequal", Comparison(Greater_equal, Compare_generic); "%greaterthan", Comparison(Greater_than, Compare_generic); "%compare", Comparison(Compare, Compare_generic); ] let lookup_primitive loc p = match Hashtbl.find primitives_table p.prim_name with | prim -> prim | exception Not_found -> if String.length p.prim_name > 0 && p.prim_name.[0] = '%' then raise(Error(loc, Unknown_builtin_primitive p.prim_name)); External p let lookup_primitive_and_mark_used loc p env path = match lookup_primitive loc p with | External _ as e -> add_used_primitive loc env path; e | x -> x let simplify_constant_constructor = function | Equal -> true | Not_equal -> true | Less_equal -> false | Less_than -> false | Greater_equal -> false | Greater_than -> false | Compare -> false (* The following function computes the greatest lower bound in the semilattice of array kinds: gen / \ addr float | int Note that the GLB is not guaranteed to exist, in which case we return our first argument instead of raising a fatal error because, although it cannot happen in a well-typed program, (ab)use of Obj.magic can probably trigger it. *) let glb_array_type t1 t2 = match t1, t2 with | Pfloatarray, (Paddrarray | Pintarray) | (Paddrarray | Pintarray), Pfloatarray -> t1 | Pgenarray, x | x, Pgenarray -> x | Paddrarray, x | x, Paddrarray -> x | Pintarray, Pintarray -> Pintarray | Pfloatarray, Pfloatarray -> Pfloatarray (* Specialize a primitive from available type information. *) let specialize_primitive env ty ~has_constant_constructor prim = let param_tys = match is_function_type env ty with | None -> [] | Some (p1, rhs) -> match is_function_type env rhs with | None -> [p1] | Some (p2, _) -> [p1;p2] in match prim, param_tys with | Primitive (Psetfield(n, Pointer, init), arity), [_; p2] -> begin match maybe_pointer_type env p2 with | Pointer -> None | Immediate -> Some (Primitive (Psetfield(n, Immediate, init), arity)) end | Primitive (Parraylength t, arity), [p] -> begin let array_type = glb_array_type t (array_type_kind env p) in if t = array_type then None else Some (Primitive (Parraylength array_type, arity)) end | Primitive (Parrayrefu t, arity), p1 :: _ -> begin let array_type = glb_array_type t (array_type_kind env p1) in if t = array_type then None else Some (Primitive (Parrayrefu array_type, arity)) end | Primitive (Parraysetu t, arity), p1 :: _ -> begin let array_type = glb_array_type t (array_type_kind env p1) in if t = array_type then None else Some (Primitive (Parraysetu array_type, arity)) end | Primitive (Parrayrefs t, arity), p1 :: _ -> begin let array_type = glb_array_type t (array_type_kind env p1) in if t = array_type then None else Some (Primitive (Parrayrefs array_type, arity)) end | Primitive (Parraysets t, arity), p1 :: _ -> begin let array_type = glb_array_type t (array_type_kind env p1) in if t = array_type then None else Some (Primitive (Parraysets array_type, arity)) end | Primitive (Pbigarrayref(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout), arity), p1 :: _ -> begin let (k, l) = bigarray_type_kind_and_layout env p1 in match k, l with | Pbigarray_unknown, Pbigarray_unknown_layout -> None | _, _ -> Some (Primitive (Pbigarrayref(unsafe, n, k, l), arity)) end | Primitive (Pbigarrayset(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout), arity), p1 :: _ -> begin let (k, l) = bigarray_type_kind_and_layout env p1 in match k, l with | Pbigarray_unknown, Pbigarray_unknown_layout -> None | _, _ -> Some (Primitive (Pbigarrayset(unsafe, n, k, l), arity)) end | Primitive (Pmakeblock(tag, mut, None), arity), fields -> begin let shape = List.map (Typeopt.value_kind env) fields in let useful = List.exists (fun knd -> knd <> Pgenval) shape in if useful then Some (Primitive (Pmakeblock(tag, mut, Some shape), arity)) else None end | Comparison(comp, Compare_generic), p1 :: _ -> if (has_constant_constructor && simplify_constant_constructor comp) then begin Some (Comparison(comp, Compare_ints)) end else if (is_base_type env p1 Predef.path_int || is_base_type env p1 Predef.path_char || (maybe_pointer_type env p1 = Immediate)) then begin Some (Comparison(comp, Compare_ints)) end else if is_base_type env p1 Predef.path_float then begin Some (Comparison(comp, Compare_floats)) end else if is_base_type env p1 Predef.path_string then begin Some (Comparison(comp, Compare_strings)) end else if is_base_type env p1 Predef.path_bytes then begin Some (Comparison(comp, Compare_bytes)) end else if is_base_type env p1 Predef.path_nativeint then begin Some (Comparison(comp, Compare_nativeints)) end else if is_base_type env p1 Predef.path_int32 then begin Some (Comparison(comp, Compare_int32s)) end else if is_base_type env p1 Predef.path_int64 then begin Some (Comparison(comp, Compare_int64s)) end else begin None end | _ -> None let caml_equal = Primitive.simple ~name:"caml_equal" ~arity:2 ~alloc:true let caml_string_equal = Primitive.simple ~name:"caml_string_equal" ~arity:2 ~alloc:false let caml_bytes_equal = Primitive.simple ~name:"caml_bytes_equal" ~arity:2 ~alloc:false let caml_notequal = Primitive.simple ~name:"caml_notequal" ~arity:2 ~alloc:true let caml_string_notequal = Primitive.simple ~name:"caml_string_notequal" ~arity:2 ~alloc:false let caml_bytes_notequal = Primitive.simple ~name:"caml_bytes_notequal" ~arity:2 ~alloc:false let caml_lessequal = Primitive.simple ~name:"caml_lessequal" ~arity:2 ~alloc:true let caml_string_lessequal = Primitive.simple ~name:"caml_string_lessequal" ~arity:2 ~alloc:false let caml_bytes_lessequal = Primitive.simple ~name:"caml_bytes_lessequal" ~arity:2 ~alloc:false let caml_lessthan = Primitive.simple ~name:"caml_lessthan" ~arity:2 ~alloc:true let caml_string_lessthan = Primitive.simple ~name:"caml_string_lessthan" ~arity:2 ~alloc:false let caml_bytes_lessthan = Primitive.simple ~name:"caml_bytes_lessthan" ~arity:2 ~alloc:false let caml_greaterequal = Primitive.simple ~name:"caml_greaterequal" ~arity:2 ~alloc:true let caml_string_greaterequal = Primitive.simple ~name:"caml_string_greaterequal" ~arity:2 ~alloc:false let caml_bytes_greaterequal = Primitive.simple ~name:"caml_bytes_greaterequal" ~arity:2 ~alloc:false let caml_greaterthan = Primitive.simple ~name:"caml_greaterthan" ~arity:2 ~alloc:true let caml_string_greaterthan = Primitive.simple ~name:"caml_string_greaterthan" ~arity:2 ~alloc: false let caml_bytes_greaterthan = Primitive.simple ~name:"caml_bytes_greaterthan" ~arity:2 ~alloc: false let caml_compare = Primitive.simple ~name:"caml_compare" ~arity:2 ~alloc:true let caml_string_compare = Primitive.simple ~name:"caml_string_compare" ~arity:2 ~alloc:false let caml_bytes_compare = Primitive.simple ~name:"caml_bytes_compare" ~arity:2 ~alloc:false let comparison_primitive comparison comparison_kind = match comparison, comparison_kind with | Equal, Compare_generic -> Pccall caml_equal | Equal, Compare_ints -> Pintcomp Ceq | Equal, Compare_floats -> Pfloatcomp CFeq | Equal, Compare_strings -> Pccall caml_string_equal | Equal, Compare_bytes -> Pccall caml_bytes_equal | Equal, Compare_nativeints -> Pbintcomp(Pnativeint, Ceq) | Equal, Compare_int32s -> Pbintcomp(Pint32, Ceq) | Equal, Compare_int64s -> Pbintcomp(Pint64, Ceq) | Not_equal, Compare_generic -> Pccall caml_notequal | Not_equal, Compare_ints -> Pintcomp Cne | Not_equal, Compare_floats -> Pfloatcomp CFneq | Not_equal, Compare_strings -> Pccall caml_string_notequal | Not_equal, Compare_bytes -> Pccall caml_bytes_notequal | Not_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cne) | Not_equal, Compare_int32s -> Pbintcomp(Pint32, Cne) | Not_equal, Compare_int64s -> Pbintcomp(Pint64, Cne) | Less_equal, Compare_generic -> Pccall caml_lessequal | Less_equal, Compare_ints -> Pintcomp Cle | Less_equal, Compare_floats -> Pfloatcomp CFle | Less_equal, Compare_strings -> Pccall caml_string_lessequal | Less_equal, Compare_bytes -> Pccall caml_bytes_lessequal | Less_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cle) | Less_equal, Compare_int32s -> Pbintcomp(Pint32, Cle) | Less_equal, Compare_int64s -> Pbintcomp(Pint64, Cle) | Less_than, Compare_generic -> Pccall caml_lessthan | Less_than, Compare_ints -> Pintcomp Clt | Less_than, Compare_floats -> Pfloatcomp CFlt | Less_than, Compare_strings -> Pccall caml_string_lessthan | Less_than, Compare_bytes -> Pccall caml_bytes_lessthan | Less_than, Compare_nativeints -> Pbintcomp(Pnativeint, Clt) | Less_than, Compare_int32s -> Pbintcomp(Pint32, Clt) | Less_than, Compare_int64s -> Pbintcomp(Pint64, Clt) | Greater_equal, Compare_generic -> Pccall caml_greaterequal | Greater_equal, Compare_ints -> Pintcomp Cge | Greater_equal, Compare_floats -> Pfloatcomp CFge | Greater_equal, Compare_strings -> Pccall caml_string_greaterequal | Greater_equal, Compare_bytes -> Pccall caml_bytes_greaterequal | Greater_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cge) | Greater_equal, Compare_int32s -> Pbintcomp(Pint32, Cge) | Greater_equal, Compare_int64s -> Pbintcomp(Pint64, Cge) | Greater_than, Compare_generic -> Pccall caml_greaterthan | Greater_than, Compare_ints -> Pintcomp Cgt | Greater_than, Compare_floats -> Pfloatcomp CFgt | Greater_than, Compare_strings -> Pccall caml_string_greaterthan | Greater_than, Compare_bytes -> Pccall caml_bytes_greaterthan | Greater_than, Compare_nativeints -> Pbintcomp(Pnativeint, Cgt) | Greater_than, Compare_int32s -> Pbintcomp(Pint32, Cgt) | Greater_than, Compare_int64s -> Pbintcomp(Pint64, Cgt) | Compare, Compare_generic -> Pccall caml_compare | Compare, Compare_ints -> Pcompare_ints | Compare, Compare_floats -> Pcompare_floats | Compare, Compare_strings -> Pccall caml_string_compare | Compare, Compare_bytes -> Pccall caml_bytes_compare | Compare, Compare_nativeints -> Pcompare_bints Pnativeint | Compare, Compare_int32s -> Pcompare_bints Pint32 | Compare, Compare_int64s -> Pcompare_bints Pint64 let lambda_of_loc kind sloc = let loc = to_location sloc in let loc_start = loc.Location.loc_start in let (file, lnum, cnum) = Location.get_pos_info loc_start in let file = if Filename.is_relative file then file else Location.rewrite_absolute_path file in let enum = loc.Location.loc_end.Lexing.pos_cnum - loc_start.Lexing.pos_cnum + cnum in match kind with | Loc_POS -> Lconst (Const_block (0, [ Const_immstring file; Const_base (Const_int lnum); Const_base (Const_int cnum); Const_base (Const_int enum); ])) | Loc_FILE -> Lconst (Const_immstring file) | Loc_MODULE -> let filename = Filename.basename file in let name = Env.get_unit_name () in let module_name = if name = "" then "//"^filename^"//" else name in Lconst (Const_immstring module_name) | Loc_LOC -> let loc = Printf.sprintf "File %S, line %d, characters %d-%d" file lnum cnum enum in Lconst (Const_immstring loc) | Loc_LINE -> Lconst (Const_base (Const_int lnum)) | Loc_FUNCTION -> let scope_name = Debuginfo.Scoped_location.string_of_scoped_location sloc in Lconst (Const_immstring scope_name) let caml_restore_raw_backtrace = Primitive.simple ~name:"caml_restore_raw_backtrace" ~arity:2 ~alloc:false let try_ids = Hashtbl.create 8 let add_exception_ident id = Hashtbl.replace try_ids id () let remove_exception_ident id = Hashtbl.remove try_ids id let lambda_of_prim prim_name prim loc args arg_exps = match prim, args with | Primitive (prim, arity), args when arity = List.length args -> Lprim(prim, args, loc) | External prim, args when prim = prim_sys_argv -> Lprim(Pccall prim, Lconst (const_int 0) :: args, loc) | External prim, args -> Lprim(Pccall prim, args, loc) | Comparison(comp, knd), ([_;_] as args) -> let prim = comparison_primitive comp knd in Lprim(prim, args, loc) | Raise kind, [arg] -> let kind = match kind, arg with | Raise_regular, Lvar argv when Hashtbl.mem try_ids argv -> Raise_reraise | _, _ -> kind in let arg = match arg_exps with | None -> arg | Some [arg_exp] -> event_after loc arg_exp arg | Some _ -> assert false in Lprim(Praise kind, [arg], loc) | Raise_with_backtrace, [exn; bt] -> let vexn = Ident.create_local "exn" in let raise_arg = match arg_exps with | None -> Lvar vexn | Some [exn_exp; _] -> event_after loc exn_exp (Lvar vexn) | Some _ -> assert false in Llet(Strict, Pgenval, vexn, exn, Lsequence(Lprim(Pccall caml_restore_raw_backtrace, [Lvar vexn; bt], loc), Lprim(Praise Raise_reraise, [raise_arg], loc))) | Lazy_force, [arg] -> Matching.inline_lazy_force arg loc | Loc kind, [] -> lambda_of_loc kind loc | Loc kind, [arg] -> let lam = lambda_of_loc kind loc in Lprim(Pmakeblock(0, Immutable, None), [lam; arg], loc) | Send, [obj; meth] -> Lsend(Public, meth, obj, [], loc) | Send_self, [obj; meth] -> Lsend(Self, meth, obj, [], loc) | Send_cache, [obj; meth; cache; pos] -> Lsend(Cached, meth, obj, [cache; pos], loc) | (Raise _ | Raise_with_backtrace | Lazy_force | Loc _ | Primitive _ | Comparison _ | Send | Send_self | Send_cache), _ -> raise(Error(to_location loc, Wrong_arity_builtin_primitive prim_name)) let check_primitive_arity loc p = let prim = lookup_primitive loc p in let ok = match prim with | Primitive (_,arity) -> arity = p.prim_arity | External _ -> true | Comparison _ -> p.prim_arity = 2 | Raise _ -> p.prim_arity = 1 | Raise_with_backtrace -> p.prim_arity = 2 | Lazy_force -> p.prim_arity = 1 | Loc _ -> p.prim_arity = 1 || p.prim_arity = 0 | Send | Send_self -> p.prim_arity = 2 | Send_cache -> p.prim_arity = 4 in if not ok then raise(Error(loc, Wrong_arity_builtin_primitive p.prim_name)) (* Eta-expand a primitive *) let transl_primitive loc p env ty path = let prim = lookup_primitive_and_mark_used (to_location loc) p env path in let has_constant_constructor = false in let prim = match specialize_primitive env ty ~has_constant_constructor prim with | None -> prim | Some prim -> prim in let rec make_params n = if n <= 0 then [] else (Ident.create_local "prim", Pgenval) :: make_params (n-1) in let params = make_params p.prim_arity in let args = List.map (fun (id, _) -> Lvar id) params in let body = lambda_of_prim p.prim_name prim loc args None in match params with | [] -> body | _ -> Lfunction{ kind = Curried; params; return = Pgenval; attr = default_stub_attribute; loc; body; } let lambda_primitive_needs_event_after = function | Prevapply | Pdirapply (* PR#6920 *) (* We add an event after any primitive resulting in a C call that may raise an exception or allocate. These are places where we may collect the call stack. *) | Pduprecord _ | Pccall _ | Pfloatofint | Pnegfloat | Pabsfloat | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat | Pstringrefs | Pbytesrefs | Pbytessets | Pmakearray (Pgenarray, _) | Pduparray _ | Parrayrefu (Pgenarray | Pfloatarray) | Parraysetu (Pgenarray | Pfloatarray) | Parrayrefs _ | Parraysets _ | Pbintofint _ | Pcvtbint _ | Pnegbint _ | Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _ | Pbintcomp _ | Pcompare_bints _ | Pbigarrayref _ | Pbigarrayset _ | Pbigarraydim _ | Pstring_load_16 _ | Pstring_load_32 _ | Pstring_load_64 _ | Pbytes_load_16 _ | Pbytes_load_32 _ | Pbytes_load_64 _ | Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_64 _ | Pbigstring_load_16 _ | Pbigstring_load_32 _ | Pbigstring_load_64 _ | Pbigstring_set_16 _ | Pbigstring_set_32 _ | Pbigstring_set_64 _ | Pbbswap _ -> true | Pidentity | Pbytes_to_string | Pbytes_of_string | Pignore | Psetglobal _ | Pgetglobal _ | Pmakeblock _ | Pfield _ | Pfield_computed | Psetfield _ | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Praise _ | Psequor | Psequand | Pnot | Pnegint | Paddint | Psubint | Pmulint | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint | Pintcomp _ | Poffsetint _ | Poffsetref _ | Pintoffloat | Pcompare_ints | Pcompare_floats | Pfloatcomp _ | Pstringlength | Pstringrefu | Pbyteslength | Pbytesrefu | Pbytessetu | Pmakearray ((Pintarray | Paddrarray | Pfloatarray), _) | Parraylength _ | Parrayrefu _ | Parraysetu _ | Pisint | Pisout | Pintofbint _ | Pctconst _ | Pbswap16 | Pint_as_pointer | Popaque -> false (* Determine if a primitive should be surrounded by an "after" debug event *) let primitive_needs_event_after = function | Primitive (prim,_) -> lambda_primitive_needs_event_after prim | External _ -> true | Comparison(comp, knd) -> lambda_primitive_needs_event_after (comparison_primitive comp knd) | Lazy_force | Send | Send_self | Send_cache -> true | Raise _ | Raise_with_backtrace | Loc _ -> false let transl_primitive_application loc p env ty path exp args arg_exps = let prim = lookup_primitive_and_mark_used (to_location loc) p env (Some path) in let has_constant_constructor = match arg_exps with | [_; {exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}] | [{exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}; _] | [_; {exp_desc = Texp_variant(_, None)}] | [{exp_desc = Texp_variant(_, None)}; _] -> true | _ -> false in let prim = match specialize_primitive env ty ~has_constant_constructor prim with | None -> prim | Some prim -> prim in let lam = lambda_of_prim p.prim_name prim loc args (Some arg_exps) in let lam = if primitive_needs_event_after prim then begin match exp with | None -> lam | Some exp -> event_after loc exp lam end else begin lam end in lam (* Error report *) open Format let report_error ppf = function | Unknown_builtin_primitive prim_name -> fprintf ppf "Unknown builtin primitive \"%s\"" prim_name | Wrong_arity_builtin_primitive prim_name -> fprintf ppf "Wrong arity for builtin primitive \"%s\"" prim_name let () = Location.register_error_of_exn (function | Error (loc, err) -> Some (Location.error_of_printer ~loc report_error err) | _ -> None )