Organise and simplify translation of primitives

9 files changed, 849 insertions, 674 deletions

diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index 6e773d8e67..4b396af11f 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -27,13 +27,6 @@ type compile_time_constant =
   | Ostype_cygwin
   | Backend_type
 
-type loc_kind =
-  | Loc_FILE
-  | Loc_LINE
-  | Loc_MODULE
-  | Loc_LOC
-  | Loc_POS
-
 type immediate_or_pointer =
   | Immediate
   | Pointer
@@ -54,7 +47,6 @@ type primitive =
   | Pignore
   | Prevapply
   | Pdirapply
-  | Ploc of loc_kind
     (* Globals *)
   | Pgetglobal of Ident.t
   | Psetglobal of Ident.t
@@ -68,7 +60,6 @@ type primitive =
   | Psetfloatfield of int * initialization_or_assignment
   | Pduprecord of Types.record_representation * int
   (* Force lazy values *)
-  | Plazyforce
   (* External call *)
   | Pccall of Primitive.description
   (* Exceptions *)
@@ -775,31 +766,6 @@ let raise_kind = function
   | Raise_reraise -> "reraise"
   | Raise_notrace -> "raise_notrace"
 
-let lam_of_loc kind loc =
-  let loc_start = loc.Location.loc_start in
-  let (file, lnum, cnum) = Location.get_pos_info loc_start 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))
-
 let merge_inline_attributes attr1 attr2 =
   match attr1, attr2 with
   | Default_inline, _ -> Some attr2
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index a59d4412f8..e82aa3e752 100644
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -27,13 +27,6 @@ type compile_time_constant =
   | Ostype_cygwin
   | Backend_type
 
-type loc_kind =
-  | Loc_FILE
-  | Loc_LINE
-  | Loc_MODULE
-  | Loc_LOC
-  | Loc_POS
-
 type immediate_or_pointer =
   | Immediate
   | Pointer
@@ -59,7 +52,6 @@ type primitive =
   | Pignore
   | Prevapply
   | Pdirapply
-  | Ploc of loc_kind
     (* Globals *)
   | Pgetglobal of Ident.t
   | Psetglobal of Ident.t
@@ -72,8 +64,6 @@ type primitive =
   | Pfloatfield of int
   | Psetfloatfield of int * initialization_or_assignment
   | Pduprecord of Types.record_representation * int
-  (* Force lazy values *)
-  | Plazyforce
   (* External call *)
   | Pccall of Primitive.description
   (* Exceptions *)
@@ -375,7 +365,6 @@ val is_guarded: lambda -> bool
 val patch_guarded : lambda -> lambda -> lambda
 
 val raise_kind: raise_kind -> string
-val lam_of_loc : loc_kind -> Location.t -> lambda
 
 val merge_inline_attributes
    : inline_attribute
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index c85d3f0ce2..f128db5e24 100644
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -109,13 +109,6 @@ let record_rep ppf r =
   | Record_extension -> fprintf ppf "ext"
 ;;
 
-let string_of_loc_kind = function
-  | Loc_FILE -> "loc_FILE"
-  | Loc_LINE -> "loc_LINE"
-  | Loc_MODULE -> "loc_MODULE"
-  | Loc_POS -> "loc_POS"
-  | Loc_LOC -> "loc_LOC"
-
 let block_shape ppf shape = match shape with
   | None | Some [] -> ()
   | Some l when List.for_all ((=) Pgenval) l -> ()
@@ -155,7 +148,6 @@ let primitive ppf = function
   | Pignore -> fprintf ppf "ignore"
   | Prevapply -> fprintf ppf "revapply"
   | Pdirapply -> fprintf ppf "dirapply"
-  | Ploc kind -> fprintf ppf "%s" (string_of_loc_kind kind)
   | Pgetglobal id -> fprintf ppf "global %a" Ident.print id
   | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id
   | Pmakeblock(tag, Immutable, shape) ->
@@ -200,7 +192,6 @@ let primitive ppf = function
       in
       fprintf ppf "setfloatfield%s %i" init n
   | Pduprecord (rep, size) -> fprintf ppf "duprecord %a %i" record_rep rep size
-  | Plazyforce -> fprintf ppf "force"
   | Pccall p -> fprintf ppf "%s" p.prim_name
   | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k)
   | Psequand -> fprintf ppf "&&"
@@ -352,7 +343,6 @@ let name_of_primitive = function
   | Pignore -> "Pignore"
   | Prevapply -> "Prevapply"
   | Pdirapply -> "Pdirapply"
-  | Ploc _ -> "Ploc"
   | Pgetglobal _ -> "Pgetglobal"
   | Psetglobal _ -> "Psetglobal"
   | Pmakeblock _ -> "Pmakeblock"
@@ -363,7 +353,6 @@ let name_of_primitive = function
   | Pfloatfield _ -> "Pfloatfield"
   | Psetfloatfield _ -> "Psetfloatfield"
   | Pduprecord _ -> "Pduprecord"
-  | Plazyforce -> "Plazyforce"
   | Pccall _ -> "Pccall"
   | Praise _ -> "Praise"
   | Psequand -> "Psequand"
diff --git a/bytecomp/semantics_of_primitives.ml b/bytecomp/semantics_of_primitives.ml
index 22f37962f8..b6b09e1936 100644
--- a/bytecomp/semantics_of_primitives.ml
+++ b/bytecomp/semantics_of_primitives.ml
@@ -37,7 +37,6 @@ let for_primitive (prim : Lambda.primitive) =
                ( "caml_format_float" | "caml_format_int" | "caml_int32_format"
                | "caml_nativeint_format" | "caml_int64_format" ) } ->
       No_effects, No_coeffects
-  | Plazyforce
   | Pccall _ -> Arbitrary_effects, Has_coeffects
   | Praise _ -> Arbitrary_effects, No_coeffects
   | Pnot
@@ -150,9 +149,6 @@ let for_primitive (prim : Lambda.primitive) =
   | Pbbswap _ -> No_effects, No_coeffects
   | Pint_as_pointer -> No_effects, No_coeffects
   | Popaque -> Arbitrary_effects, Has_coeffects
-  | Ploc _ ->
-      (* Removed by [Translcore]. *)
-      No_effects, No_coeffects
   | Prevapply
   | Pdirapply ->
       (* Removed by [Simplif], but there is no reason to prevent using
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index fa10feded5..4efb271b36 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -26,7 +26,6 @@ open Lambda
 
 type error =
     Free_super_var
-  | Unknown_builtin_primitive of string
   | Unreachable_reached
 
 exception Error of Location.t * error
@@ -67,473 +66,6 @@ let transl_extension_constructor env path ext =
   | Text_rebind(path, _lid) ->
       transl_extension_path ~loc env path
 
-(* Translation of primitives *)
-
-let comparisons_table = create_hashtable 11 [
-  "%equal",
-      (Pccall(Primitive.simple ~name:"caml_equal" ~arity:2 ~alloc:true),
-       Pintcomp Ceq,
-       Pfloatcomp CFeq,
-       Pccall(Primitive.simple ~name:"caml_string_equal" ~arity:2
-                ~alloc:false),
-       Pccall(Primitive.simple ~name:"caml_bytes_equal" ~arity:2
-                ~alloc:false),
-       Pbintcomp(Pnativeint, Ceq),
-       Pbintcomp(Pint32, Ceq),
-       Pbintcomp(Pint64, Ceq),
-       true);
-  "%notequal",
-      (Pccall(Primitive.simple ~name:"caml_notequal" ~arity:2 ~alloc:true),
-       Pintcomp Cne,
-       Pfloatcomp CFneq,
-       Pccall(Primitive.simple ~name:"caml_string_notequal" ~arity:2
-                ~alloc:false),
-       Pccall(Primitive.simple ~name:"caml_bytes_notequal" ~arity:2
-                ~alloc:false),
-       Pbintcomp(Pnativeint, Cne),
-       Pbintcomp(Pint32, Cne),
-       Pbintcomp(Pint64, Cne),
-       true);
-  "%lessthan",
-      (Pccall(Primitive.simple ~name:"caml_lessthan" ~arity:2 ~alloc:true),
-       Pintcomp Clt,
-       Pfloatcomp CFlt,
-       Pccall(Primitive.simple ~name:"caml_string_lessthan" ~arity:2
-                ~alloc:false),
-       Pccall(Primitive.simple ~name:"caml_bytes_lessthan" ~arity:2
-                ~alloc:false),
-       Pbintcomp(Pnativeint, Clt),
-       Pbintcomp(Pint32, Clt),
-       Pbintcomp(Pint64, Clt),
-       false);
-  "%greaterthan",
-      (Pccall(Primitive.simple ~name:"caml_greaterthan" ~arity:2 ~alloc:true),
-       Pintcomp Cgt,
-       Pfloatcomp CFgt,
-       Pccall(Primitive.simple ~name:"caml_string_greaterthan" ~arity:2
-                ~alloc: false),
-       Pccall(Primitive.simple ~name:"caml_bytes_greaterthan" ~arity:2
-                ~alloc: false),
-       Pbintcomp(Pnativeint, Cgt),
-       Pbintcomp(Pint32, Cgt),
-       Pbintcomp(Pint64, Cgt),
-       false);
-  "%lessequal",
-      (Pccall(Primitive.simple ~name:"caml_lessequal" ~arity:2 ~alloc:true),
-       Pintcomp Cle,
-       Pfloatcomp CFle,
-       Pccall(Primitive.simple ~name:"caml_string_lessequal" ~arity:2
-                ~alloc:false),
-       Pccall(Primitive.simple ~name:"caml_bytes_lessequal" ~arity:2
-                ~alloc:false),
-       Pbintcomp(Pnativeint, Cle),
-       Pbintcomp(Pint32, Cle),
-       Pbintcomp(Pint64, Cle),
-       false);
-  "%greaterequal",
-      (Pccall(Primitive.simple ~name:"caml_greaterequal" ~arity:2 ~alloc:true),
-       Pintcomp Cge,
-       Pfloatcomp CFge,
-       Pccall(Primitive.simple ~name:"caml_string_greaterequal" ~arity:2
-                ~alloc:false),
-       Pccall(Primitive.simple ~name:"caml_bytes_greaterequal" ~arity:2
-                ~alloc:false),
-       Pbintcomp(Pnativeint, Cge),
-       Pbintcomp(Pint32, Cge),
-       Pbintcomp(Pint64, Cge),
-       false);
-  "%compare",
-      let unboxed_compare name native_repr =
-        Pccall( Primitive.make ~name ~alloc:false
-                  ~native_name:(name^"_unboxed")
-                  ~native_repr_args:[native_repr;native_repr]
-                  ~native_repr_res:Untagged_int
-              ) in
-      (Pccall(Primitive.simple ~name:"caml_compare" ~arity:2 ~alloc:true),
-       (* Not unboxed since the comparison is done directly on tagged int *)
-       Pccall(Primitive.simple ~name:"caml_int_compare" ~arity:2 ~alloc:false),
-       unboxed_compare "caml_float_compare" Unboxed_float,
-       Pccall(Primitive.simple ~name:"caml_string_compare" ~arity:2
-                ~alloc:false),
-       Pccall(Primitive.simple ~name:"caml_bytes_compare" ~arity:2
-                ~alloc:false),
-       unboxed_compare "caml_nativeint_compare" (Unboxed_integer Pnativeint),
-       unboxed_compare "caml_int32_compare" (Unboxed_integer Pint32),
-       unboxed_compare "caml_int64_compare" (Unboxed_integer Pint64),
-       false)
-]
-
-let gen_array_kind =
-  if Config.flat_float_array then Pgenarray else Paddrarray
-
-let primitives_table = create_hashtable 57 [
-  "%identity", Pidentity;
-  "%bytes_to_string", Pbytes_to_string;
-  "%bytes_of_string", Pbytes_of_string;
-  "%ignore", Pignore;
-  "%revapply", Prevapply;
-  "%apply", Pdirapply;
-  "%loc_LOC", Ploc Loc_LOC;
-  "%loc_FILE", Ploc Loc_FILE;
-  "%loc_LINE", Ploc Loc_LINE;
-  "%loc_POS", Ploc Loc_POS;
-  "%loc_MODULE", Ploc Loc_MODULE;
-  "%field0", Pfield 0;
-  "%field1", Pfield 1;
-  "%setfield0", Psetfield(0, Pointer, Assignment);
-  "%makeblock", Pmakeblock(0, Immutable, None);
-  "%makemutable", Pmakeblock(0, Mutable, None);
-  "%raise", Praise Raise_regular;
-  "%reraise", Praise Raise_reraise;
-  "%raise_notrace", Praise Raise_notrace;
-  "%sequand", Psequand;
-  "%sequor", Psequor;
-  "%boolnot", Pnot;
-  "%big_endian", Pctconst Big_endian;
-  "%backend_type", Pctconst Backend_type;
-  "%word_size", Pctconst Word_size;
-  "%int_size", Pctconst Int_size;
-  "%max_wosize", Pctconst Max_wosize;
-  "%ostype_unix", Pctconst Ostype_unix;
-  "%ostype_win32", Pctconst Ostype_win32;
-  "%ostype_cygwin", Pctconst Ostype_cygwin;
-  "%negint", Pnegint;
-  "%succint", Poffsetint 1;
-  "%predint", Poffsetint(-1);
-  "%addint", Paddint;
-  "%subint", Psubint;
-  "%mulint", Pmulint;
-  "%divint", Pdivint Safe;
-  "%modint", Pmodint Safe;
-  "%andint", Pandint;
-  "%orint", Porint;
-  "%xorint", Pxorint;
-  "%lslint", Plslint;
-  "%lsrint", Plsrint;
-  "%asrint", Pasrint;
-  "%eq", Pintcomp Ceq;
-  "%noteq", Pintcomp Cne;
-  "%ltint", Pintcomp Clt;
-  "%leint", Pintcomp Cle;
-  "%gtint", Pintcomp Cgt;
-  "%geint", Pintcomp Cge;
-  "%incr", Poffsetref(1);
-  "%decr", Poffsetref(-1);
-  "%intoffloat", Pintoffloat;
-  "%floatofint", Pfloatofint;
-  "%negfloat", Pnegfloat;
-  "%absfloat", Pabsfloat;
-  "%addfloat", Paddfloat;
-  "%subfloat", Psubfloat;
-  "%mulfloat", Pmulfloat;
-  "%divfloat", Pdivfloat;
-  "%eqfloat", Pfloatcomp CFeq;
-  "%noteqfloat", Pfloatcomp CFneq;
-  "%ltfloat", Pfloatcomp CFlt;
-  "%lefloat", Pfloatcomp CFle;
-  "%gtfloat", Pfloatcomp CFgt;
-  "%gefloat", Pfloatcomp CFge;
-  "%string_length", Pstringlength;
-  "%string_safe_get", Pstringrefs;
-  "%string_safe_set", Pbytessets;
-  "%string_unsafe_get", Pstringrefu;
-  "%string_unsafe_set", Pbytessetu;
-  "%bytes_length", Pbyteslength;
-  "%bytes_safe_get", Pbytesrefs;
-  "%bytes_safe_set", Pbytessets;
-  "%bytes_unsafe_get", Pbytesrefu;
-  "%bytes_unsafe_set", Pbytessetu;
-  "%array_length", Parraylength gen_array_kind;
-  "%array_safe_get", Parrayrefs gen_array_kind;
-  "%array_safe_set", Parraysets gen_array_kind;
-  "%array_unsafe_get", Parrayrefu gen_array_kind;
-  "%array_unsafe_set", Parraysetu gen_array_kind;
-  "%obj_size", Parraylength gen_array_kind;
-  "%obj_field", Parrayrefu gen_array_kind;
-  "%obj_set_field", Parraysetu gen_array_kind;
-  "%floatarray_length", Parraylength Pfloatarray;
-  "%floatarray_safe_get", Parrayrefs Pfloatarray;
-  "%floatarray_safe_set", Parraysets Pfloatarray;
-  "%floatarray_unsafe_get", Parrayrefu Pfloatarray;
-  "%floatarray_unsafe_set", Parraysetu Pfloatarray;
-  "%obj_is_int", Pisint;
-  "%lazy_force", Plazyforce;
-  "%nativeint_of_int", Pbintofint Pnativeint;
-  "%nativeint_to_int", Pintofbint Pnativeint;
-  "%nativeint_neg", Pnegbint Pnativeint;
-  "%nativeint_add", Paddbint Pnativeint;
-  "%nativeint_sub", Psubbint Pnativeint;
-  "%nativeint_mul", Pmulbint Pnativeint;
-  "%nativeint_div", Pdivbint { size = Pnativeint; is_safe = Safe };
-  "%nativeint_mod", Pmodbint { size = Pnativeint; is_safe = Safe };
-  "%nativeint_and", Pandbint Pnativeint;
-  "%nativeint_or",  Porbint Pnativeint;
-  "%nativeint_xor", Pxorbint Pnativeint;
-  "%nativeint_lsl", Plslbint Pnativeint;
-  "%nativeint_lsr", Plsrbint Pnativeint;
-  "%nativeint_asr", Pasrbint Pnativeint;
-  "%int32_of_int", Pbintofint Pint32;
-  "%int32_to_int", Pintofbint Pint32;
-  "%int32_neg", Pnegbint Pint32;
-  "%int32_add", Paddbint Pint32;
-  "%int32_sub", Psubbint Pint32;
-  "%int32_mul", Pmulbint Pint32;
-  "%int32_div", Pdivbint { size = Pint32; is_safe = Safe };
-  "%int32_mod", Pmodbint { size = Pint32; is_safe = Safe };
-  "%int32_and", Pandbint Pint32;
-  "%int32_or",  Porbint Pint32;
-  "%int32_xor", Pxorbint Pint32;
-  "%int32_lsl", Plslbint Pint32;
-  "%int32_lsr", Plsrbint Pint32;
-  "%int32_asr", Pasrbint Pint32;
-  "%int64_of_int", Pbintofint Pint64;
-  "%int64_to_int", Pintofbint Pint64;
-  "%int64_neg", Pnegbint Pint64;
-  "%int64_add", Paddbint Pint64;
-  "%int64_sub", Psubbint Pint64;
-  "%int64_mul", Pmulbint Pint64;
-  "%int64_div", Pdivbint { size = Pint64; is_safe = Safe };
-  "%int64_mod", Pmodbint { size = Pint64; is_safe = Safe };
-  "%int64_and", Pandbint Pint64;
-  "%int64_or",  Porbint Pint64;
-  "%int64_xor", Pxorbint Pint64;
-  "%int64_lsl", Plslbint Pint64;
-  "%int64_lsr", Plsrbint Pint64;
-  "%int64_asr", Pasrbint Pint64;
-  "%nativeint_of_int32", Pcvtbint(Pint32, Pnativeint);
-  "%nativeint_to_int32", Pcvtbint(Pnativeint, Pint32);
-  "%int64_of_int32", Pcvtbint(Pint32, Pint64);
-  "%int64_to_int32", Pcvtbint(Pint64, Pint32);
-  "%int64_of_nativeint", Pcvtbint(Pnativeint, Pint64);
-  "%int64_to_nativeint", Pcvtbint(Pint64, Pnativeint);
-  "%caml_ba_ref_1",
-    Pbigarrayref(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout);
-  "%caml_ba_ref_2",
-    Pbigarrayref(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout);
-  "%caml_ba_ref_3",
-    Pbigarrayref(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout);
-  "%caml_ba_set_1",
-    Pbigarrayset(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout);
-  "%caml_ba_set_2",
-    Pbigarrayset(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout);
-  "%caml_ba_set_3",
-    Pbigarrayset(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout);
-  "%caml_ba_unsafe_ref_1",
-    Pbigarrayref(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout);
-  "%caml_ba_unsafe_ref_2",
-    Pbigarrayref(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout);
-  "%caml_ba_unsafe_ref_3",
-    Pbigarrayref(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout);
-  "%caml_ba_unsafe_set_1",
-    Pbigarrayset(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout);
-  "%caml_ba_unsafe_set_2",
-    Pbigarrayset(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout);
-  "%caml_ba_unsafe_set_3",
-    Pbigarrayset(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout);
-  "%caml_ba_dim_1", Pbigarraydim(1);
-  "%caml_ba_dim_2", Pbigarraydim(2);
-  "%caml_ba_dim_3", Pbigarraydim(3);
-  "%caml_string_get16", Pstring_load_16(false);
-  "%caml_string_get16u", Pstring_load_16(true);
-  "%caml_string_get32", Pstring_load_32(false);
-  "%caml_string_get32u", Pstring_load_32(true);
-  "%caml_string_get64", Pstring_load_64(false);
-  "%caml_string_get64u", Pstring_load_64(true);
-  "%caml_string_set16", Pbytes_set_16(false);
-  "%caml_string_set16u", Pbytes_set_16(true);
-  "%caml_string_set32", Pbytes_set_32(false);
-  "%caml_string_set32u", Pbytes_set_32(true);
-  "%caml_string_set64", Pbytes_set_64(false);
-  "%caml_string_set64u", Pbytes_set_64(true);
-  "%caml_bytes_get16", Pbytes_load_16(false);
-  "%caml_bytes_get16u", Pbytes_load_16(true);
-  "%caml_bytes_get32", Pbytes_load_32(false);
-  "%caml_bytes_get32u", Pbytes_load_32(true);
-  "%caml_bytes_get64", Pbytes_load_64(false);
-  "%caml_bytes_get64u", Pbytes_load_64(true);
-  "%caml_bytes_set16", Pbytes_set_16(false);
-  "%caml_bytes_set16u", Pbytes_set_16(true);
-  "%caml_bytes_set32", Pbytes_set_32(false);
-  "%caml_bytes_set32u", Pbytes_set_32(true);
-  "%caml_bytes_set64", Pbytes_set_64(false);
-  "%caml_bytes_set64u", Pbytes_set_64(true);
-  "%caml_bigstring_get16", Pbigstring_load_16(false);
-  "%caml_bigstring_get16u", Pbigstring_load_16(true);
-  "%caml_bigstring_get32", Pbigstring_load_32(false);
-  "%caml_bigstring_get32u", Pbigstring_load_32(true);
-  "%caml_bigstring_get64", Pbigstring_load_64(false);
-  "%caml_bigstring_get64u", Pbigstring_load_64(true);
-  "%caml_bigstring_set16", Pbigstring_set_16(false);
-  "%caml_bigstring_set16u", Pbigstring_set_16(true);
-  "%caml_bigstring_set32", Pbigstring_set_32(false);
-  "%caml_bigstring_set32u", Pbigstring_set_32(true);
-  "%caml_bigstring_set64", Pbigstring_set_64(false);
-  "%caml_bigstring_set64u", Pbigstring_set_64(true);
-  "%bswap16", Pbswap16;
-  "%bswap_int32", Pbbswap(Pint32);
-  "%bswap_int64", Pbbswap(Pint64);
-  "%bswap_native", Pbbswap(Pnativeint);
-  "%int_as_pointer", Pint_as_pointer;
-  "%opaque", Popaque;
-]
-
-let find_primitive prim_name =
-  Hashtbl.find primitives_table prim_name
-
-let prim_restore_raw_backtrace =
-  Primitive.simple ~name:"caml_restore_raw_backtrace" ~arity:2 ~alloc:false
-
-let specialize_comparison table env ty =
-  let (gencomp, intcomp, floatcomp, stringcomp, bytescomp,
-           nativeintcomp, int32comp, int64comp, _) = table in
-  match () with
-  | () when is_base_type env ty Predef.path_int
-         || is_base_type env ty Predef.path_char
-         || (maybe_pointer_type env ty = Immediate)   -> intcomp
-  | () when is_base_type env ty Predef.path_float     -> floatcomp
-  | () when is_base_type env ty Predef.path_string    -> stringcomp
-  | () when is_base_type env ty Predef.path_bytes     -> bytescomp
-  | () when is_base_type env ty Predef.path_nativeint -> nativeintcomp
-  | () when is_base_type env ty Predef.path_int32     -> int32comp
-  | () when is_base_type env ty Predef.path_int64     -> int64comp
-  | () -> gencomp
-
-(* 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,
-   raise Not_found if primitive is unknown  *)
-
-let specialize_primitive p env ty ~has_constant_constructor =
-  try
-    let table = Hashtbl.find comparisons_table p.prim_name in
-    let (gencomp, intcomp, _, _, _, _, _, _, simplify_constant_constructor) =
-      table in
-    if has_constant_constructor && simplify_constant_constructor then
-      intcomp
-    else
-      match is_function_type env ty with
-      | Some (lhs,_rhs) -> specialize_comparison table env lhs
-      | None -> gencomp
-  with Not_found ->
-    let p = find_primitive p.prim_name in
-    (* Try strength reduction based on the type of the argument *)
-    let params = 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 (p, params) with
-      (Psetfield(n, _, init), [_p1; p2]) ->
-        Psetfield(n, maybe_pointer_type env p2, init)
-    | (Parraylength t, [p])   ->
-        Parraylength(glb_array_type t (array_type_kind env p))
-    | (Parrayrefu t, p1 :: _) ->
-        Parrayrefu(glb_array_type t (array_type_kind env p1))
-    | (Parraysetu t, p1 :: _) ->
-        Parraysetu(glb_array_type t (array_type_kind env p1))
-    | (Parrayrefs t, p1 :: _) ->
-        Parrayrefs(glb_array_type t (array_type_kind env p1))
-    | (Parraysets t, p1 :: _) ->
-        Parraysets(glb_array_type t (array_type_kind env p1))
-    | (Pbigarrayref(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout),
-       p1 :: _) ->
-        let (k, l) = bigarray_type_kind_and_layout env p1 in
-        Pbigarrayref(unsafe, n, k, l)
-    | (Pbigarrayset(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout),
-       p1 :: _) ->
-        let (k, l) = bigarray_type_kind_and_layout env p1 in
-        Pbigarrayset(unsafe, n, k, l)
-    | (Pmakeblock(tag, mut, None), fields) ->
-        let shape = List.map (Typeopt.value_kind env) fields in
-        Pmakeblock(tag, mut, Some shape)
-    | _ -> p
-
-(* Eta-expand a primitive *)
-
-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 (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 transl_primitive loc p env ty path =
-  let prim =
-    try specialize_primitive p env ty ~has_constant_constructor:false
-    with Not_found ->
-      add_used_primitive loc env path;
-      Pccall p
-  in
-  match prim with
-  | Plazyforce ->
-      let parm = Ident.create "prim" in
-      Lfunction{kind = Curried; params = [parm];
-                body = Matching.inline_lazy_force (Lvar parm) Location.none;
-                loc = loc;
-                attr = default_stub_attribute }
-  | Ploc kind ->
-    let lam = lam_of_loc kind loc in
-    begin match p.prim_arity with
-      | 0 -> lam
-      | 1 -> (* TODO: we should issue a warning ? *)
-        let param = Ident.create "prim" in
-        Lfunction{kind = Curried; params = [param];
-                  attr = default_stub_attribute;
-                  loc = loc;
-                  body = Lprim(Pmakeblock(0, Immutable, None),
-                               [lam; Lvar param], loc)}
-      | _ -> assert false
-    end
-  | _ ->
-      let rec make_params n =
-        if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in
-      let params = make_params p.prim_arity in
-      Lfunction{ kind = Curried; params;
-                 attr = default_stub_attribute;
-                 loc = loc;
-                 body = Lprim(prim, List.map (fun id -> Lvar id) params, loc) }
-
-let transl_primitive_application loc prim env ty path args =
-  let prim_name = prim.prim_name in
-  try
-    let has_constant_constructor = match args 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
-    specialize_primitive prim env ty ~has_constant_constructor
-  with Not_found ->
-    if String.length prim_name > 0 && prim_name.[0] = '%' then
-      raise(Error(loc, Unknown_builtin_primitive prim_name));
-    add_used_primitive loc env path;
-    Pccall prim
-
 (* To propagate structured constants *)
 
 exception Not_constant
@@ -611,23 +143,9 @@ let rec push_defaults loc bindings cases partial =
 
 (* Insertion of debugging events *)
 
-let event_before exp lam = match lam with
-| Lstaticraise (_,_) -> lam
-| _ ->
-  if !Clflags.debug && not !Clflags.native_code
-  then Levent(lam, {lev_loc = exp.exp_loc;
-                    lev_kind = Lev_before;
-                    lev_repr = None;
-                    lev_env = Env.summary exp.exp_env})
-  else lam
+let event_before = Translprim.event_before
 
-let event_after exp lam =
-  if !Clflags.debug && not !Clflags.native_code
-  then Levent(lam, {lev_loc = exp.exp_loc;
-                    lev_kind = Lev_after exp.exp_type;
-                    lev_repr = None;
-                    lev_env = Env.summary exp.exp_env})
-  else lam
+let event_after = Translprim.event_after
 
 let event_function exp lam =
   if !Clflags.debug && not !Clflags.native_code then
@@ -641,14 +159,6 @@ let event_function exp lam =
   else
     lam None
 
-let primitive_is_ccall = function
-  (* Determine if a primitive is a Pccall or will be turned later into
-     a C function call that may raise an exception *)
-  | Pccall _ | Pstringrefs  | Pbytesrefs | Pbytessets | Parrayrefs _ |
-    Parraysets _ | Pbigarrayref _ | Pbigarrayset _ | Pduprecord _ | Pdirapply |
-    Prevapply -> true
-  | _ -> false
-
 (* Assertions *)
 
 let assert_failed exp =
@@ -670,8 +180,6 @@ let rec cut n l =
 
 (* Translation of expressions *)
 
-let try_ids = Hashtbl.create 8
-
 let rec transl_exp e =
   List.iter (Translattribute.check_attribute e) e.exp_attributes;
   let eval_once =
@@ -685,25 +193,8 @@ let rec transl_exp e =
 
 and transl_exp0 e =
   match e.exp_desc with
-    Texp_ident(path, _, {val_kind = Val_prim p}) ->
-      let public_send = p.prim_name = "%send" in
-      if public_send || p.prim_name = "%sendself" then
-        let kind = if public_send then Public else Self in
-        let obj = Ident.create "obj" and meth = Ident.create "meth" in
-        Lfunction{kind = Curried; params = [obj; meth];
-                  attr = default_stub_attribute;
-                  loc = e.exp_loc;
-                  body = Lsend(kind, Lvar meth, Lvar obj, [], e.exp_loc)}
-      else if p.prim_name = "%sendcache" then
-        let obj = Ident.create "obj" and meth = Ident.create "meth" in
-        let cache = Ident.create "cache" and pos = Ident.create "pos" in
-        Lfunction{kind = Curried; params = [obj; meth; cache; pos];
-                  attr = default_stub_attribute;
-                  loc = e.exp_loc;
-                  body = Lsend(Cached, Lvar meth, Lvar obj,
-                               [Lvar cache; Lvar pos], e.exp_loc)}
-      else
-        transl_primitive e.exp_loc p e.exp_env e.exp_type (Some path)
+  | Texp_ident(path, _, {val_kind = Val_prim p}) ->
+      Translprim.transl_primitive e.exp_loc p e.exp_env e.exp_type (Some path)
   | Texp_ident(_, _, {val_kind = Val_anc _}) ->
       raise(Error(e.exp_loc, Free_super_var))
   | Texp_ident(path, _, {val_kind = Val_reg | Val_self _}) ->
@@ -733,89 +224,32 @@ and transl_exp0 e =
                 exp_type = prim_type } as funct, oargs)
     when List.length oargs >= p.prim_arity
     && List.for_all (fun (_, arg) -> arg <> None) oargs ->
-      let args, args' = cut p.prim_arity oargs in
-      let wrap f =
-        if args' = []
-        then event_after e f
-        else
-          let should_be_tailcall, funct =
-            Translattribute.get_tailcall_attribute funct
-          in
-          let inlined, funct =
-            Translattribute.get_and_remove_inlined_attribute funct
-          in
-          let specialised, funct =
-            Translattribute.get_and_remove_specialised_attribute funct
-          in
-          let e = { e with exp_desc = Texp_apply(funct, oargs) } in
-          event_after e
-            (transl_apply ~should_be_tailcall ~inlined ~specialised
-               f args' e.exp_loc)
+      let argl, extra_args = cut p.prim_arity oargs in
+      let arg_exps =
+         List.map (function _, Some x -> x | _ -> assert false) argl
       in
-      let wrap0 f =
-        if args' = [] then f else wrap f in
-      let args =
-         List.map (function _, Some x -> x | _ -> assert false) args in
-      let argl = transl_list args in
-      let public_send = p.prim_name = "%send"
-        || not !Clflags.native_code && p.prim_name = "%sendcache"in
-      if public_send || p.prim_name = "%sendself" then
-        let kind = if public_send then Public else Self in
-        let obj = List.hd argl in
-        wrap (Lsend (kind, List.nth argl 1, obj, [], e.exp_loc))
-      else if p.prim_name = "%sendcache" then
-        match argl with [obj; meth; cache; pos] ->
-          wrap (Lsend(Cached, meth, obj, [cache; pos], e.exp_loc))
-        | _ -> assert false
-      else if p.prim_name = "%raise_with_backtrace" then begin
-        let texn1 = List.hd args (* Should not fail by typing *) in
-        let texn2,bt = match argl with
-          | [a;b] -> a,b
-          | _ -> assert false (* idem *)
-        in
-        let vexn = Ident.create "exn" in
-        Llet(Strict, Pgenval, vexn, texn2,
-             event_before e begin
-               Lsequence(
-                 wrap  (Lprim (Pccall prim_restore_raw_backtrace,
-                               [Lvar vexn;bt],
-                               e.exp_loc)),
-                 wrap0 (Lprim(Praise Raise_reraise,
-                              [event_after texn1 (Lvar vexn)],
-                              e.exp_loc))
-               )
-             end
-            )
-      end
+      let args = transl_list arg_exps in
+      let prim_exp = if extra_args = [] then Some e else None in
+      let lam =
+        Translprim.transl_primitive_application
+          e.exp_loc p e.exp_env prim_type path
+          prim_exp args arg_exps
+      in
+      if extra_args = [] then lam
       else begin
-        let prim = transl_primitive_application
-            e.exp_loc p e.exp_env prim_type (Some path) args in
-        match (prim, args) with
-          (Praise k, [arg1]) ->
-            let targ = List.hd argl in
-            let k =
-              match k, targ with
-              | Raise_regular, Lvar id
-                when Hashtbl.mem try_ids id ->
-                  Raise_reraise
-              | _ ->
-                  k
-            in
-            wrap0 (Lprim(Praise k, [event_after arg1 targ], e.exp_loc))
-        | (Ploc kind, []) ->
-          lam_of_loc kind e.exp_loc
-        | (Ploc kind, [arg1]) ->
-          let lam = lam_of_loc kind arg1.exp_loc in
-          Lprim(Pmakeblock(0, Immutable, None), lam :: argl, e.exp_loc)
-        | (Ploc _, _) -> assert false
-        | (_, _) ->
-            begin match (prim, argl) with
-            | (Plazyforce, [a]) ->
-                wrap (Matching.inline_lazy_force a e.exp_loc)
-            | (Plazyforce, _) -> assert false
-            |_ -> let p = Lprim(prim, argl, e.exp_loc) in
-               if primitive_is_ccall prim then wrap p else wrap0 p
-            end
+        let should_be_tailcall, funct =
+          Translattribute.get_tailcall_attribute funct
+        in
+        let inlined, funct =
+          Translattribute.get_and_remove_inlined_attribute funct
+        in
+        let specialised, funct =
+          Translattribute.get_and_remove_specialised_attribute funct
+        in
+        let e = { e with exp_desc = Texp_apply(funct, oargs) } in
+        event_after e
+          (transl_apply ~should_be_tailcall ~inlined ~specialised
+             lam extra_args e.exp_loc)
       end
   | Texp_apply(funct, oargs) ->
       let should_be_tailcall, funct =
@@ -1109,10 +543,11 @@ and transl_case_try {c_lhs; c_guard; c_rhs} =
         iter_exn_names f p
     | _ -> ()
   in
-  iter_exn_names (fun id -> Hashtbl.replace try_ids id ()) c_lhs;
+  iter_exn_names Translprim.add_exception_ident c_lhs;
   Misc.try_finally
     (fun () -> c_lhs, transl_guard c_guard c_rhs)
-    (fun () -> iter_exn_names (Hashtbl.remove try_ids) c_lhs)
+    (fun () ->
+       iter_exn_names Translprim.remove_exception_ident c_lhs)
 
 and transl_cases_try cases =
   let cases =
@@ -1417,8 +852,6 @@ let report_error ppf = function
   | Free_super_var ->
       fprintf ppf
         "Ancestor names can only be used to select inherited methods"
-  | Unknown_builtin_primitive prim_name ->
-      fprintf ppf "Unknown builtin primitive \"%s\"" prim_name
   | Unreachable_reached ->
       fprintf ppf "Unreachable expression was reached"
 
diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli
index 75c26f8d1e..e27eb20ac4 100644
--- a/bytecomp/translcore.mli
+++ b/bytecomp/translcore.mli
@@ -27,17 +27,12 @@ val transl_apply: ?should_be_tailcall:bool
                   -> lambda -> (arg_label * expression option) list
                   -> Location.t -> lambda
 val transl_let: rec_flag -> value_binding list -> lambda -> lambda
-val transl_primitive: Location.t -> Primitive.description -> Env.t
-                      -> Types.type_expr -> Path.t option -> lambda
 
 val transl_extension_constructor: Env.t -> Path.t option ->
   extension_constructor -> lambda
 
-val used_primitives: (Path.t, Location.t) Hashtbl.t
-
 type error =
     Free_super_var
-  | Unknown_builtin_primitive of string
   | Unreachable_reached
 
 exception Error of Location.t * error
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index b66550e4c3..4644feac7a 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -78,7 +78,7 @@ let rec apply_coercion loc strict restr arg =
       let carg = apply_coercion loc Alias cc_arg (Lvar param) in
       apply_coercion_result loc strict arg [param] [carg] cc_res
   | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } ->
-      transl_primitive pc_loc pc_desc pc_env pc_type None
+      Translprim.transl_primitive pc_loc pc_desc pc_env pc_type None
   | Tcoerce_alias (path, cc) ->
       name_lambda strict arg
         (fun _ -> apply_coercion loc Alias cc (transl_normal_path path))
@@ -498,7 +498,7 @@ and transl_structure loc fields cc rootpath final_env = function
                     (fun (pos, cc) ->
                       match cc with
                         Tcoerce_primitive p ->
-                          transl_primitive p.pc_loc
+                          Translprim.transl_primitive p.pc_loc
                             p.pc_desc p.pc_env p.pc_type None
                       | _ -> apply_coercion loc Strict cc (get_field pos))
                     pos_cc_list, loc)
@@ -673,15 +673,16 @@ let required_globals ~flambda body =
       Ident.Set.add id req
   in
   let required =
-    Hashtbl.fold
-      (fun path _ -> add_global (Path.head path)) used_primitives
+    List.fold_left
+      (fun acc path -> add_global (Path.head path) acc)
       (if flambda then globals else Ident.Set.empty)
+      (Translprim.get_used_primitives ())
   in
   let required =
     List.fold_right add_global (Env.get_required_globals ()) required
   in
   Env.reset_required_globals ();
-  Hashtbl.clear used_primitives;
+  Translprim.clear_used_primitives ();
   required
 
 (* Compile an implementation *)
@@ -689,7 +690,7 @@ let required_globals ~flambda body =
 let transl_implementation_flambda module_name (str, cc) =
   reset_labels ();
   primitive_declarations := [];
-  Hashtbl.clear used_primitives;
+  Translprim.clear_used_primitives ();
   let module_id = Ident.create_persistent module_name in
   let body, size =
     Translobj.transl_label_init
@@ -832,7 +833,7 @@ let field_of_str loc str =
   fun (pos, cc) ->
     match cc with
     | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } ->
-        transl_primitive pc_loc pc_desc pc_env pc_type None
+        Translprim.transl_primitive pc_loc pc_desc pc_env pc_type None
     | _ -> apply_coercion loc Strict cc (Lvar ids.(pos))
 
 
@@ -1046,7 +1047,7 @@ let transl_store_structure glob map prims str =
   and store_primitive (pos, prim) cont =
     Lsequence(Lprim(Psetfield(pos, Pointer, Root_initialization),
                     [Lprim(Pgetglobal glob, [], Location.none);
-                     transl_primitive Location.none
+                     Translprim.transl_primitive Location.none
                        prim.pc_desc prim.pc_env prim.pc_type None],
                     Location.none),
               cont)
@@ -1100,7 +1101,7 @@ let build_ident_map restr idlist more_ids =
 let transl_store_gen module_name ({ str_items = str }, restr) topl =
   reset_labels ();
   primitive_declarations := [];
-  Hashtbl.clear used_primitives;
+  Translprim.clear_used_primitives ();
   let module_id = Ident.create_persistent module_name in
   let (map, prims, size) =
     build_ident_map restr (defined_idents str) (more_idents str) in
@@ -1243,7 +1244,7 @@ let transl_toplevel_item_and_close itm =
 
 let transl_toplevel_definition str =
   reset_labels ();
-  Hashtbl.clear used_primitives;
+  Translprim.clear_used_primitives ();
   make_sequence transl_toplevel_item_and_close str.str_items
 
 (* Compile the initialization code for a packed library *)
@@ -1369,4 +1370,4 @@ let reset () =
   transl_store_subst := Ident.Map.empty;
   aliased_idents := Ident.empty;
   Env.reset_required_globals ();
-  Hashtbl.clear used_primitives
+  Translprim.clear_used_primitives ()
diff --git a/bytecomp/translprim.ml b/bytecomp/translprim.ml
new file mode 100644
index 0000000000..e5f02db398
--- /dev/null
+++ b/bytecomp/translprim.ml
@@ -0,0 +1,757 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 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
+
+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 exp lam = match lam with
+| Lstaticraise (_,_) -> lam
+| _ ->
+  if !Clflags.debug && not !Clflags.native_code
+  then Levent(lam, {lev_loc = exp.exp_loc;
+                    lev_kind = Lev_before;
+                    lev_repr = None;
+                    lev_env = Env.summary exp.exp_env})
+  else lam
+
+let event_after exp lam =
+  if !Clflags.debug && not !Clflags.native_code
+  then Levent(lam, {lev_loc = exp.exp_loc;
+                    lev_kind = Lev_after exp.exp_type;
+                    lev_repr = None;
+                    lev_env = Env.summary 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
+
+type prim =
+  | Primitive of Lambda.primitive
+  | 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 (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 primitives_table = create_hashtable 57 [
+  "%identity", Primitive Pidentity;
+  "%bytes_to_string", Primitive Pbytes_to_string;
+  "%bytes_of_string", Primitive Pbytes_of_string;
+  "%ignore", Primitive Pignore;
+  "%revapply", Primitive Prevapply;
+  "%apply", Primitive Pdirapply;
+  "%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;
+  "%field0", Primitive (Pfield 0);
+  "%field1", Primitive (Pfield 1);
+  "%setfield0", Primitive (Psetfield(0, Pointer, Assignment));
+  "%makeblock", Primitive (Pmakeblock(0, Immutable, None));
+  "%makemutable", Primitive (Pmakeblock(0, Mutable, None));
+  "%raise", Raise Raise_regular;
+  "%reraise", Raise Raise_reraise;
+  "%raise_notrace", Raise Raise_notrace;
+  "%raise_with_backtrace", Raise_with_backtrace;
+  "%sequand", Primitive Psequand;
+  "%sequor", Primitive Psequor;
+  "%boolnot", Primitive Pnot;
+  "%big_endian", Primitive (Pctconst Big_endian);
+  "%backend_type", Primitive (Pctconst Backend_type);
+  "%word_size", Primitive (Pctconst Word_size);
+  "%int_size", Primitive (Pctconst Int_size);
+  "%max_wosize", Primitive (Pctconst Max_wosize);
+  "%ostype_unix", Primitive (Pctconst Ostype_unix);
+  "%ostype_win32", Primitive (Pctconst Ostype_win32);
+  "%ostype_cygwin", Primitive (Pctconst Ostype_cygwin);
+  "%negint", Primitive Pnegint;
+  "%succint", Primitive (Poffsetint 1);
+  "%predint", Primitive (Poffsetint(-1));
+  "%addint", Primitive Paddint;
+  "%subint", Primitive Psubint;
+  "%mulint", Primitive Pmulint;
+  "%divint", Primitive (Pdivint Safe);
+  "%modint", Primitive (Pmodint Safe);
+  "%andint", Primitive Pandint;
+  "%orint", Primitive Porint;
+  "%xorint", Primitive Pxorint;
+  "%lslint", Primitive Plslint;
+  "%lsrint", Primitive Plsrint;
+  "%asrint", Primitive Pasrint;
+  "%eq", Primitive (Pintcomp Ceq);
+  "%noteq", Primitive (Pintcomp Cne);
+  "%ltint", Primitive (Pintcomp Clt);
+  "%leint", Primitive (Pintcomp Cle);
+  "%gtint", Primitive (Pintcomp Cgt);
+  "%geint", Primitive (Pintcomp Cge);
+  "%incr", Primitive (Poffsetref(1));
+  "%decr", Primitive (Poffsetref(-1));
+  "%intoffloat", Primitive Pintoffloat;
+  "%floatofint", Primitive Pfloatofint;
+  "%negfloat", Primitive Pnegfloat;
+  "%absfloat", Primitive Pabsfloat;
+  "%addfloat", Primitive Paddfloat;
+  "%subfloat", Primitive Psubfloat;
+  "%mulfloat", Primitive Pmulfloat;
+  "%divfloat", Primitive Pdivfloat;
+  "%eqfloat", Primitive (Pfloatcomp CFeq);
+  "%noteqfloat", Primitive (Pfloatcomp CFneq);
+  "%ltfloat", Primitive (Pfloatcomp CFlt);
+  "%lefloat", Primitive (Pfloatcomp CFle);
+  "%gtfloat", Primitive (Pfloatcomp CFgt);
+  "%gefloat", Primitive (Pfloatcomp CFge);
+  "%string_length", Primitive Pstringlength;
+  "%string_safe_get", Primitive Pstringrefs;
+  "%string_safe_set", Primitive Pbytessets;
+  "%string_unsafe_get", Primitive Pstringrefu;
+  "%string_unsafe_set", Primitive Pbytessetu;
+  "%bytes_length", Primitive Pbyteslength;
+  "%bytes_safe_get", Primitive Pbytesrefs;
+  "%bytes_safe_set", Primitive Pbytessets;
+  "%bytes_unsafe_get", Primitive Pbytesrefu;
+  "%bytes_unsafe_set", Primitive Pbytessetu;
+  "%array_length", Primitive (Parraylength gen_array_kind);
+  "%array_safe_get", Primitive (Parrayrefs gen_array_kind);
+  "%array_safe_set", Primitive (Parraysets gen_array_kind);
+  "%array_unsafe_get", Primitive (Parrayrefu gen_array_kind);
+  "%array_unsafe_set", Primitive (Parraysetu gen_array_kind);
+  "%obj_size", Primitive (Parraylength gen_array_kind);
+  "%obj_field", Primitive (Parrayrefu gen_array_kind);
+  "%obj_set_field", Primitive (Parraysetu gen_array_kind);
+  "%floatarray_length", Primitive (Parraylength Pfloatarray);
+  "%floatarray_safe_get", Primitive (Parrayrefs Pfloatarray);
+  "%floatarray_safe_set", Primitive (Parraysets Pfloatarray);
+  "%floatarray_unsafe_get", Primitive (Parrayrefu Pfloatarray);
+  "%floatarray_unsafe_set", Primitive (Parraysetu Pfloatarray);
+  "%obj_is_int", Primitive Pisint;
+  "%lazy_force", Lazy_force;
+  "%nativeint_of_int", Primitive (Pbintofint Pnativeint);
+  "%nativeint_to_int", Primitive (Pintofbint Pnativeint);
+  "%nativeint_neg", Primitive (Pnegbint Pnativeint);
+  "%nativeint_add", Primitive (Paddbint Pnativeint);
+  "%nativeint_sub", Primitive (Psubbint Pnativeint);
+  "%nativeint_mul", Primitive (Pmulbint Pnativeint);
+  "%nativeint_div", Primitive (Pdivbint { size = Pnativeint; is_safe = Safe });
+  "%nativeint_mod", Primitive (Pmodbint { size = Pnativeint; is_safe = Safe });
+  "%nativeint_and", Primitive (Pandbint Pnativeint);
+  "%nativeint_or", Primitive  (Porbint Pnativeint);
+  "%nativeint_xor", Primitive (Pxorbint Pnativeint);
+  "%nativeint_lsl", Primitive (Plslbint Pnativeint);
+  "%nativeint_lsr", Primitive (Plsrbint Pnativeint);
+  "%nativeint_asr", Primitive (Pasrbint Pnativeint);
+  "%int32_of_int", Primitive (Pbintofint Pint32);
+  "%int32_to_int", Primitive (Pintofbint Pint32);
+  "%int32_neg", Primitive (Pnegbint Pint32);
+  "%int32_add", Primitive (Paddbint Pint32);
+  "%int32_sub", Primitive (Psubbint Pint32);
+  "%int32_mul", Primitive (Pmulbint Pint32);
+  "%int32_div", Primitive (Pdivbint { size = Pint32; is_safe = Safe });
+  "%int32_mod", Primitive (Pmodbint { size = Pint32; is_safe = Safe });
+  "%int32_and", Primitive (Pandbint Pint32);
+  "%int32_or", Primitive  (Porbint Pint32);
+  "%int32_xor", Primitive (Pxorbint Pint32);
+  "%int32_lsl", Primitive (Plslbint Pint32);
+  "%int32_lsr", Primitive (Plsrbint Pint32);
+  "%int32_asr", Primitive (Pasrbint Pint32);
+  "%int64_of_int", Primitive (Pbintofint Pint64);
+  "%int64_to_int", Primitive (Pintofbint Pint64);
+  "%int64_neg", Primitive (Pnegbint Pint64);
+  "%int64_add", Primitive (Paddbint Pint64);
+  "%int64_sub", Primitive (Psubbint Pint64);
+  "%int64_mul", Primitive (Pmulbint Pint64);
+  "%int64_div", Primitive (Pdivbint { size = Pint64; is_safe = Safe });
+  "%int64_mod", Primitive (Pmodbint { size = Pint64; is_safe = Safe });
+  "%int64_and", Primitive (Pandbint Pint64);
+  "%int64_or", Primitive  (Porbint Pint64);
+  "%int64_xor", Primitive (Pxorbint Pint64);
+  "%int64_lsl", Primitive (Plslbint Pint64);
+  "%int64_lsr", Primitive (Plsrbint Pint64);
+  "%int64_asr", Primitive (Pasrbint Pint64);
+  "%nativeint_of_int32", Primitive (Pcvtbint(Pint32, Pnativeint));
+  "%nativeint_to_int32", Primitive (Pcvtbint(Pnativeint, Pint32));
+  "%int64_of_int32", Primitive (Pcvtbint(Pint32, Pint64));
+  "%int64_to_int32", Primitive (Pcvtbint(Pint64, Pint32));
+  "%int64_of_nativeint", Primitive (Pcvtbint(Pnativeint, Pint64));
+  "%int64_to_nativeint", Primitive (Pcvtbint(Pint64, Pnativeint));
+  "%caml_ba_ref_1",
+    Primitive
+      (Pbigarrayref(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout));
+  "%caml_ba_ref_2",
+    Primitive
+      (Pbigarrayref(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout));
+  "%caml_ba_ref_3",
+    Primitive
+      (Pbigarrayref(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout));
+  "%caml_ba_set_1",
+    Primitive
+      (Pbigarrayset(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout));
+  "%caml_ba_set_2",
+    Primitive
+      (Pbigarrayset(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout));
+  "%caml_ba_set_3",
+    Primitive
+      (Pbigarrayset(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout));
+  "%caml_ba_unsafe_ref_1",
+    Primitive
+      (Pbigarrayref(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout));
+  "%caml_ba_unsafe_ref_2",
+    Primitive
+      (Pbigarrayref(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout));
+  "%caml_ba_unsafe_ref_3",
+    Primitive
+      (Pbigarrayref(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout));
+  "%caml_ba_unsafe_set_1",
+    Primitive
+      (Pbigarrayset(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout));
+  "%caml_ba_unsafe_set_2",
+    Primitive
+      (Pbigarrayset(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout));
+  "%caml_ba_unsafe_set_3",
+    Primitive
+      (Pbigarrayset(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout));
+  "%caml_ba_dim_1", Primitive (Pbigarraydim(1));
+  "%caml_ba_dim_2", Primitive (Pbigarraydim(2));
+  "%caml_ba_dim_3", Primitive (Pbigarraydim(3));
+  "%caml_string_get16", Primitive (Pstring_load_16(false));
+  "%caml_string_get16u", Primitive (Pstring_load_16(true));
+  "%caml_string_get32", Primitive (Pstring_load_32(false));
+  "%caml_string_get32u", Primitive (Pstring_load_32(true));
+  "%caml_string_get64", Primitive (Pstring_load_64(false));
+  "%caml_string_get64u", Primitive (Pstring_load_64(true));
+  "%caml_string_set16", Primitive (Pbytes_set_16(false));
+  "%caml_string_set16u", Primitive (Pbytes_set_16(true));
+  "%caml_string_set32", Primitive (Pbytes_set_32(false));
+  "%caml_string_set32u", Primitive (Pbytes_set_32(true));
+  "%caml_string_set64", Primitive (Pbytes_set_64(false));
+  "%caml_string_set64u", Primitive (Pbytes_set_64(true));
+  "%caml_bytes_get16", Primitive (Pbytes_load_16(false));
+  "%caml_bytes_get16u", Primitive (Pbytes_load_16(true));
+  "%caml_bytes_get32", Primitive (Pbytes_load_32(false));
+  "%caml_bytes_get32u", Primitive (Pbytes_load_32(true));
+  "%caml_bytes_get64", Primitive (Pbytes_load_64(false));
+  "%caml_bytes_get64u", Primitive (Pbytes_load_64(true));
+  "%caml_bytes_set16", Primitive (Pbytes_set_16(false));
+  "%caml_bytes_set16u", Primitive (Pbytes_set_16(true));
+  "%caml_bytes_set32", Primitive (Pbytes_set_32(false));
+  "%caml_bytes_set32u", Primitive (Pbytes_set_32(true));
+  "%caml_bytes_set64", Primitive (Pbytes_set_64(false));
+  "%caml_bytes_set64u", Primitive (Pbytes_set_64(true));
+  "%caml_bigstring_get16", Primitive (Pbigstring_load_16(false));
+  "%caml_bigstring_get16u", Primitive (Pbigstring_load_16(true));
+  "%caml_bigstring_get32", Primitive (Pbigstring_load_32(false));
+  "%caml_bigstring_get32u", Primitive (Pbigstring_load_32(true));
+  "%caml_bigstring_get64", Primitive (Pbigstring_load_64(false));
+  "%caml_bigstring_get64u", Primitive (Pbigstring_load_64(true));
+  "%caml_bigstring_set16", Primitive (Pbigstring_set_16(false));
+  "%caml_bigstring_set16u", Primitive (Pbigstring_set_16(true));
+  "%caml_bigstring_set32", Primitive (Pbigstring_set_32(false));
+  "%caml_bigstring_set32u", Primitive (Pbigstring_set_32(true));
+  "%caml_bigstring_set64", Primitive (Pbigstring_set_64(false));
+  "%caml_bigstring_set64u", Primitive (Pbigstring_set_64(true));
+  "%bswap16", Primitive Pbswap16;
+  "%bswap_int32", Primitive (Pbbswap(Pint32));
+  "%bswap_int64", Primitive (Pbbswap(Pint64));
+  "%bswap_native", Primitive (Pbbswap(Pnativeint));
+  "%int_as_pointer", Primitive Pint_as_pointer;
+  "%opaque", Primitive Popaque;
+  "%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 env path =
+  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));
+      add_used_primitive loc env path;
+      Primitive (Pccall p)
+
+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)), [_; p2] -> begin
+      match maybe_pointer_type env p2 with
+      | Pointer -> None
+      | Immediate -> Some (Primitive (Psetfield(n, Immediate, init)))
+    end
+  | Primitive (Parraylength t), [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))
+    end
+  | Primitive (Parrayrefu t), 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))
+    end
+  | Primitive (Parraysetu t), 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))
+    end
+  | Primitive (Parrayrefs t), 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))
+    end
+  | Primitive (Parraysets t), 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))
+    end
+  | Primitive (Pbigarrayref(unsafe, n, Pbigarray_unknown,
+                            Pbigarray_unknown_layout)), 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)))
+    end
+  | Primitive (Pbigarrayset(unsafe, n, Pbigarray_unknown,
+                            Pbigarray_unknown_layout)), 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)))
+    end
+  | Primitive (Pmakeblock(tag, mut, None)), 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)))
+      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 unboxed_compare name native_repr =
+  Primitive.make ~name ~alloc:false ~native_name:(name^"_unboxed")
+    ~native_repr_args:[native_repr;native_repr] ~native_repr_res:Untagged_int
+
+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_int_compare =
+  (* Not unboxed since the comparison is done directly on tagged int *)
+  Primitive.simple ~name:"caml_int_compare" ~arity:2 ~alloc:false
+let caml_float_compare =
+  unboxed_compare "caml_float_compare" Unboxed_float
+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 caml_nativeint_compare =
+  unboxed_compare "caml_nativeint_compare" (Unboxed_integer Pnativeint)
+let caml_int32_compare =
+  unboxed_compare "caml_int32_compare" (Unboxed_integer Pint32)
+let caml_int64_compare =
+  unboxed_compare "caml_int64_compare" (Unboxed_integer Pint64)
+
+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 -> Pccall caml_int_compare
+  | Compare, Compare_floats -> Pccall caml_float_compare
+  | Compare, Compare_strings -> Pccall caml_string_compare
+  | Compare, Compare_bytes -> Pccall caml_bytes_compare
+  | Compare, Compare_nativeints -> Pccall caml_nativeint_compare
+  | Compare, Compare_int32s -> Pccall caml_int32_compare
+  | Compare, Compare_int64s -> Pccall caml_int64_compare
+
+let lambda_of_loc kind loc =
+  let loc_start = loc.Location.loc_start in
+  let (file, lnum, cnum) = Location.get_pos_info loc_start 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))
+
+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, args ->
+      Lprim(prim, args, loc)
+  | Comparison(comp, knd), 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 arg_exp arg
+        | Some _ -> assert false
+      in
+      Lprim(Praise kind, [arg], loc)
+  | Raise_with_backtrace, [exn; bt] ->
+      let vexn = Ident.create "exn" in
+      let raise_arg =
+        match arg_exps with
+        | None -> Lvar vexn
+        | Some [exn_exp; _] -> event_after 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 Location.none
+  | 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 _
+    | Send | Send_self | Send_cache), _ ->
+      raise(Error(loc, Wrong_arity_builtin_primitive prim_name))
+
+(* Eta-expand a primitive *)
+
+let transl_primitive loc p env ty path =
+  let prim = lookup_primitive 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 "prim" :: 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
+  let lam =
+    Lfunction{ kind = Curried; params;
+               attr = default_stub_attribute;
+               loc = loc;
+               body = body; }
+  in
+  lam
+
+(* Determine if a primitive is a Pccall or will be turned later into
+   a C function call that may raise an exception *)
+let primitive_is_ccall = function
+  | Pccall _ | Pstringrefs  | Pbytesrefs | Pbytessets | Parrayrefs _ |
+    Parraysets _ | Pbigarrayref _ | Pbigarrayset _ | Pduprecord _ | Pdirapply |
+    Prevapply -> true
+  | _ -> false
+
+(* Determine if a primitive should be surrounded by an "after" debug event *)
+let primitive_needs_event_after = function
+  | Primitive prim -> primitive_is_ccall prim
+  | Comparison(comp, knd) ->
+      primitive_is_ccall (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 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 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
+    )
diff --git a/bytecomp/translprim.mli b/bytecomp/translprim.mli
new file mode 100644
index 0000000000..d894165640
--- /dev/null
+++ b/bytecomp/translprim.mli
@@ -0,0 +1,49 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 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.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Insertion of debugging events *)
+
+val event_before : Typedtree.expression -> Lambda.lambda -> Lambda.lambda
+
+val event_after : Typedtree.expression -> Lambda.lambda -> Lambda.lambda
+
+(* Translation of primitives *)
+
+val add_exception_ident : Ident.t -> unit
+val remove_exception_ident : Ident.t -> unit
+
+val clear_used_primitives : unit -> unit
+val get_used_primitives: unit -> Path.t list
+
+val transl_primitive :
+  Location.t -> Primitive.description -> Env.t ->
+  Types.type_expr -> Path.t option -> Lambda.lambda
+
+val transl_primitive_application :
+  Location.t -> Primitive.description -> Env.t ->
+  Types.type_expr -> Path.t -> Typedtree.expression option ->
+  Lambda.lambda list -> Typedtree.expression list -> Lambda.lambda
+
+(* Errors *)
+
+type error =
+  | Unknown_builtin_primitive of string
+  | Wrong_arity_builtin_primitive of string
+
+exception Error of Location.t * error
+
+open Format
+
+val report_error : formatter -> error -> unit