Support [@unboxed] and [@untagged] attributes

Adding [@unboxed] (resp [@untagged]) on a primitive argument means
that the argument must passed unboxed (resp untagged) to the external
function. Adding [@unboxed] (resp [@untagged]) on the result means
that the external function returns its result unboxed (resp untagged).

The unboxing (resp untagging) method is derived from the type.

Currently unboxing is suported for: float, int32, int64 and nativeint.
Untagging is supported for int.

This patch also increases the cm{i,o,a,x,xa} magic numbers as the type
Primitive.description is changed.

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@16382 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

17 files changed, 324 insertions, 131 deletions

diff --git a/.depend b/.depend
index d08269930f..c67b2efc2e 100644
--- a/.depend
+++ b/.depend
@@ -125,7 +125,7 @@ typing/parmatch.cmi : typing/types.cmi typing/typedtree.cmi \
     typing/env.cmi parsing/asttypes.cmi
 typing/path.cmi : typing/ident.cmi
 typing/predef.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi
-typing/primitive.cmi :
+typing/primitive.cmi : parsing/parsetree.cmi parsing/location.cmi
 typing/printtyped.cmi : typing/typedtree.cmi
 typing/printtyp.cmi : typing/types.cmi typing/path.cmi \
     typing/outcometree.cmi parsing/longident.cmi typing/ident.cmi \
@@ -266,8 +266,10 @@ typing/predef.cmo : typing/types.cmi typing/path.cmi parsing/location.cmi \
     typing/ident.cmi typing/btype.cmi parsing/asttypes.cmi typing/predef.cmi
 typing/predef.cmx : typing/types.cmx typing/path.cmx parsing/location.cmx \
     typing/ident.cmx typing/btype.cmx parsing/asttypes.cmi typing/predef.cmi
-typing/primitive.cmo : utils/misc.cmi typing/primitive.cmi
-typing/primitive.cmx : utils/misc.cmx typing/primitive.cmi
+typing/primitive.cmo : parsing/parsetree.cmi utils/misc.cmi \
+    parsing/location.cmi typing/primitive.cmi
+typing/primitive.cmx : parsing/parsetree.cmi utils/misc.cmx \
+    parsing/location.cmx typing/primitive.cmi
 typing/printtyped.cmo : typing/typedtree.cmi parsing/printast.cmi \
     typing/path.cmi utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
     typing/ident.cmi parsing/asttypes.cmi typing/printtyped.cmi
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index 39c53042ea..1ec651efbb 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -1061,8 +1061,7 @@ let check_bound unsafe dbg a1 a2 k =
 (* Simplification of some primitives into C calls *)
 
 let default_prim name =
-  { prim_name = name; prim_arity = 0 (*ignored*);
-    prim_alloc = true; prim_native_name = ""; prim_native_float = false }
+  Primitive.simple ~name ~arity:0(*ignored*) ~alloc:true
 
 let simplif_primitive_32bits = function
     Pbintofint Pint64 -> Pccall (default_prim "caml_int64_of_int")
@@ -1237,6 +1236,12 @@ type unboxed_number_kind =
   | Boxed_integer of boxed_integer
   | No_result (* expression never returns a result *)
 
+let unboxed_number_kind_of_unbox = function
+  | Same_as_ocaml_repr -> No_unboxing
+  | Unboxed_float -> Boxed_float
+  | Unboxed_integer bi -> Boxed_integer bi
+  | Untagged_int -> No_unboxing
+
 let rec is_unboxed_number e =
   (* Given unboxed_number_kind from two branches of the code, returns the
      resulting unboxed_number_kind *)
@@ -1244,17 +1249,20 @@ let rec is_unboxed_number e =
     match k1, is_unboxed_number e with
     | Boxed_float, Boxed_float -> Boxed_float
     | Boxed_integer bi1, Boxed_integer bi2 when bi1 = bi2 -> k1
-    | No_result, k | k, No_result -> k (* if a branch never returns, it is safe to unbox it *)
+    | No_result, k | k, No_result ->
+        k (* if a branch never returns, it is safe to unbox it *)
     | _, _ -> No_unboxing
   in
   match e with
   | Uconst(Uconst_ref(_, Uconst_float _)) -> Boxed_float
   | Uconst(Uconst_ref(_, Uconst_int32 _)) -> Boxed_integer Pint32
-  | Uconst(Uconst_ref(_, Uconst_int64 _)) when size_int = 8 -> Boxed_integer Pint64
-  | Uconst(Uconst_ref(_, Uconst_nativeint _)) -> Boxed_integer Pnativeint
+  | Uconst(Uconst_ref(_, Uconst_int64 _)) when size_int = 8 ->
+      Boxed_integer Pint64
+  | Uconst(Uconst_ref(_, Uconst_nativeint _)) ->
+      Boxed_integer Pnativeint
   | Uprim(p, _, _) ->
       begin match simplif_primitive p with
-        | Pccall p -> if p.prim_native_float then Boxed_float else No_unboxing
+        | Pccall p -> unboxed_number_kind_of_unbox p.prim_native_repr_res
         | Pfloatfield _ -> Boxed_float
         | Pfloatofint -> Boxed_float
         | Pnegfloat -> Boxed_float
@@ -1434,14 +1442,7 @@ let rec transl = function
       | (Pmakeblock(tag, mut), args) ->
           make_alloc tag (List.map transl args)
       | (Pccall prim, args) ->
-          if prim.prim_native_float then
-            box_float
-              (Cop(Cextcall(prim.prim_native_name, typ_float, false, dbg),
-                   List.map transl_unbox_float args))
-          else
-            Cop(Cextcall(Primitive.native_name prim, typ_val, prim.prim_alloc,
-                         dbg),
-                List.map transl args)
+          transl_ccall prim args dbg
       | (Pmakearray kind, []) ->
           transl_structured_constant (Uconst_block(0, []))
       | (Pmakearray kind, args) ->
@@ -1596,6 +1597,37 @@ let rec transl = function
   | Uassign(id, exp) ->
       return_unit(Cassign(id, transl exp))
 
+and transl_ccall prim args dbg =
+  let transl_arg native_repr arg =
+    match native_repr with
+    | Same_as_ocaml_repr -> transl arg
+    | Unboxed_float -> transl_unbox_float arg
+    | Unboxed_integer bi -> transl_unbox_int bi arg
+    | Untagged_int -> untag_int (transl arg)
+  in
+  let rec transl_args native_repr_args args =
+    match native_repr_args, args with
+    | [], args ->
+        (* We don't require the two lists to be of the same length as
+           [default_prim] always sets the arity to [0]. *)
+        List.map transl args
+    | _, [] -> assert false
+    | native_repr :: native_repr_args, arg :: args ->
+        transl_arg native_repr arg :: transl_args native_repr_args args
+  in
+  let typ_res, wrap_result =
+    match prim.prim_native_repr_res with
+    | Same_as_ocaml_repr -> (typ_val, fun x -> x)
+    | Unboxed_float -> (typ_float, box_float)
+    | Unboxed_integer Pint64 when size_int = 4 -> ([|Int; Int|], box_int Pint64)
+    | Unboxed_integer bi -> (typ_int, box_int bi)
+    | Untagged_int -> (typ_int, tag_int)
+  in
+  let args = transl_args prim.prim_native_repr_args args in
+  wrap_result
+    (Cop(Cextcall(Primitive.native_name prim,
+                  typ_res, prim.prim_alloc, dbg), args))
+
 and transl_prim_1 p arg dbg =
   match p with
   (* Generic operations *)
diff --git a/asmcomp/i386/proc.ml b/asmcomp/i386/proc.ml
index 922c76941e..9f009c7878 100644
--- a/asmcomp/i386/proc.ml
+++ b/asmcomp/i386/proc.ml
@@ -150,7 +150,10 @@ let extcall_use_push = true
 let loc_external_arguments arg =
   fatal_error "Proc.loc_external_arguments"
 let loc_external_results res =
-  let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc
+  match res with
+  | [|{typ=Int};{typ=Int}|] -> [|eax; edx|]
+  | _ ->
+      let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc
 
 let loc_exn_bucket = eax
 
diff --git a/boot/ocamlc b/boot/ocamlc
index f56d5c8bf8..c3fc4e8b11 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamldep b/boot/ocamldep
index a69e2e49ec..50f50fd51c 100755
--- a/boot/ocamldep
+++ b/boot/ocamldep
diff --git a/boot/ocamllex b/boot/ocamllex
index ae152f7d30..5085380626 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index 7783368828..c080683eb8 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -132,7 +132,7 @@ and comparison =
 and array_kind =
     Pgenarray | Paddrarray | Pintarray | Pfloatarray
 
-and boxed_integer =
+and boxed_integer = Primitive.boxed_integer =
     Pnativeint | Pint32 | Pint64
 
 and bigarray_kind =
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index eba9593d7f..5acf2e502f 100644
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -132,7 +132,7 @@ and comparison =
 and array_kind =
     Pgenarray | Paddrarray | Pintarray | Pfloatarray
 
-and boxed_integer =
+and boxed_integer = Primitive.boxed_integer =
     Pnativeint | Pint32 | Pint64
 
 and bigarray_kind =
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index 1bdeef8ea7..ff3863d3bf 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -14,7 +14,6 @@
 
 open Misc
 open Asttypes
-open Primitive
 open Types
 open Typedtree
 open Lambda
@@ -1475,10 +1474,7 @@ let matcher_lazy p rem = match p.pat_desc with
 *)
 
 let prim_obj_tag =
-  {prim_name = "caml_obj_tag";
-   prim_arity = 1; prim_alloc = false;
-   prim_native_name = "";
-   prim_native_float = false}
+  Primitive.simple ~name:"caml_obj_tag" ~arity:1 ~alloc:false
 
 let get_mod_field modname field =
   lazy (
@@ -1707,14 +1703,16 @@ let divide_array kind ctx pm =
 let strings_test_threshold = 8
 
 let prim_string_notequal =
-  Pccall{prim_name = "caml_string_notequal";
-         prim_arity = 2; prim_alloc = false;
-         prim_native_name = ""; prim_native_float = false}
+  Pccall(Primitive.simple
+           ~name:"caml_string_notequal"
+           ~arity:2
+           ~alloc:false)
 
 let prim_string_compare =
-  Pccall{prim_name = "caml_string_compare";
-         prim_arity = 2; prim_alloc = false;
-         prim_native_name = ""; prim_native_float = false}
+  Pccall(Primitive.simple
+           ~name:"caml_string_compare"
+           ~arity:2
+           ~alloc:false)
 
 let bind_sw arg k = match arg with
 | Lvar _ -> k arg
@@ -2287,7 +2285,7 @@ let mk_failaction_pos partial seen ctx defs  =
       | _  -> scan_def ((List.map fst now,idef)::env) later rem in
 
   let fail_pats = complete_pats_constrs seen in
-  if List.length fail_pats < 32 then begin 
+  if List.length fail_pats < 32 then begin
     let fail,jmps =
       scan_def
         []
@@ -2305,7 +2303,7 @@ let mk_failaction_pos partial seen ctx defs  =
     let fail,jumps =  mk_failaction_neg partial ctx defs in
     if dbg then
       eprintf "FAIL: %s\n"
-        (match fail with 
+        (match fail with
         | None -> "<none>"
         | Some lam -> string_of_lam lam) ;
     fail,[],jumps
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index e7f5a3ae0a..8d308f6469 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -42,99 +42,78 @@ let transl_object =
 
 let comparisons_table = create_hashtable 11 [
   "%equal",
-      (Pccall{prim_name = "caml_equal"; prim_arity = 2; prim_alloc = true;
-              prim_native_name = ""; prim_native_float = false},
+      (Pccall(Primitive.simple ~name:"caml_equal" ~arity:2 ~alloc:true),
        Pintcomp Ceq,
        Pfloatcomp Ceq,
-       Pccall{prim_name = "caml_string_equal"; prim_arity = 2;
-              prim_alloc = false;
-              prim_native_name = ""; prim_native_float = false},
+       Pccall(Primitive.simple ~name:"caml_string_equal" ~arity:2
+                ~alloc:false),
        Pbintcomp(Pnativeint, Ceq),
        Pbintcomp(Pint32, Ceq),
        Pbintcomp(Pint64, Ceq),
        true);
   "%notequal",
-      (Pccall{prim_name = "caml_notequal"; prim_arity = 2; prim_alloc = true;
-              prim_native_name = ""; prim_native_float = false},
+      (Pccall(Primitive.simple ~name:"caml_notequal" ~arity:2 ~alloc:true),
        Pintcomp Cneq,
        Pfloatcomp Cneq,
-       Pccall{prim_name = "caml_string_notequal"; prim_arity = 2;
-              prim_alloc = false; prim_native_name = "";
-              prim_native_float = false},
+       Pccall(Primitive.simple ~name:"caml_string_notequal" ~arity:2
+                ~alloc:false),
        Pbintcomp(Pnativeint, Cneq),
        Pbintcomp(Pint32, Cneq),
        Pbintcomp(Pint64, Cneq),
        true);
   "%lessthan",
-      (Pccall{prim_name = "caml_lessthan"; prim_arity = 2; prim_alloc = true;
-              prim_native_name = ""; prim_native_float = false},
+      (Pccall(Primitive.simple ~name:"caml_lessthan" ~arity:2 ~alloc:true),
        Pintcomp Clt,
        Pfloatcomp Clt,
-       Pccall{prim_name = "caml_string_lessthan"; prim_arity = 2;
-              prim_alloc = false; prim_native_name = "";
-              prim_native_float = false},
+       Pccall(Primitive.simple ~name:"caml_string_lessthan" ~arity:2
+                ~alloc:false),
        Pbintcomp(Pnativeint, Clt),
        Pbintcomp(Pint32, Clt),
        Pbintcomp(Pint64, Clt),
        false);
   "%greaterthan",
-      (Pccall{prim_name = "caml_greaterthan"; prim_arity = 2; prim_alloc = true;
-              prim_native_name = ""; prim_native_float = false},
+      (Pccall(Primitive.simple ~name:"caml_greaterthan" ~arity:2 ~alloc:true),
        Pintcomp Cgt,
        Pfloatcomp Cgt,
-       Pccall{prim_name = "caml_string_greaterthan"; prim_arity = 2;
-              prim_alloc = false; prim_native_name = "";
-              prim_native_float = false},
+       Pccall(Primitive.simple ~name:"caml_string_greaterthan" ~arity:2
+                ~alloc: false),
        Pbintcomp(Pnativeint, Cgt),
        Pbintcomp(Pint32, Cgt),
        Pbintcomp(Pint64, Cgt),
        false);
   "%lessequal",
-      (Pccall{prim_name = "caml_lessequal"; prim_arity = 2; prim_alloc = true;
-              prim_native_name = ""; prim_native_float = false},
+      (Pccall(Primitive.simple ~name:"caml_lessequal" ~arity:2 ~alloc:true),
        Pintcomp Cle,
        Pfloatcomp Cle,
-       Pccall{prim_name = "caml_string_lessequal"; prim_arity = 2;
-              prim_alloc = false; prim_native_name = "";
-              prim_native_float = false},
+       Pccall(Primitive.simple ~name:"caml_string_lessequal" ~arity:2
+                ~alloc:false),
        Pbintcomp(Pnativeint, Cle),
        Pbintcomp(Pint32, Cle),
        Pbintcomp(Pint64, Cle),
        false);
   "%greaterequal",
-      (Pccall{prim_name = "caml_greaterequal"; prim_arity = 2;
-              prim_alloc = true;
-              prim_native_name = ""; prim_native_float = false},
+      (Pccall(Primitive.simple ~name:"caml_greaterequal" ~arity:2 ~alloc:true),
        Pintcomp Cge,
        Pfloatcomp Cge,
-       Pccall{prim_name = "caml_string_greaterequal"; prim_arity = 2;
-              prim_alloc = false; prim_native_name = "";
-              prim_native_float = false},
+       Pccall(Primitive.simple ~name:"caml_string_greaterequal" ~arity:2
+                ~alloc:false),
        Pbintcomp(Pnativeint, Cge),
        Pbintcomp(Pint32, Cge),
        Pbintcomp(Pint64, Cge),
        false);
   "%compare",
-      (Pccall{prim_name = "caml_compare"; prim_arity = 2; prim_alloc = true;
-              prim_native_name = ""; prim_native_float = false},
-       Pccall{prim_name = "caml_int_compare"; prim_arity = 2;
-              prim_alloc = false; prim_native_name = "";
-              prim_native_float = false},
-       Pccall{prim_name = "caml_float_compare"; prim_arity = 2;
-              prim_alloc = false; prim_native_name = "";
-              prim_native_float = false},
-       Pccall{prim_name = "caml_string_compare"; prim_arity = 2;
-              prim_alloc = false; prim_native_name = "";
-              prim_native_float = false},
-       Pccall{prim_name = "caml_nativeint_compare"; prim_arity = 2;
-              prim_alloc = false; prim_native_name = "";
-              prim_native_float = false},
-       Pccall{prim_name = "caml_int32_compare"; prim_arity = 2;
-              prim_alloc = false; prim_native_name = "";
-              prim_native_float = false},
-       Pccall{prim_name = "caml_int64_compare"; prim_arity = 2;
-              prim_alloc = false; prim_native_name = "";
-              prim_native_float = false},
+      (Pccall(Primitive.simple ~name:"caml_compare" ~arity:2 ~alloc:true),
+       Pccall(Primitive.simple ~name:"caml_int_compare" ~arity:2 ~alloc:false),
+       Pccall(Primitive.simple ~name:"caml_float_compare" ~arity:2
+                ~alloc:false),
+       Pccall(Primitive.simple ~name:"caml_string_compare" ~arity:2
+                ~alloc:false),
+       Pccall(Primitive.simple ~name:"caml_nativeint_compare" ~arity:2
+                ~alloc:false),
+       Pccall(Primitive.simple ~name:"caml_int32_compare" ~arity:2
+                ~alloc:false),
+       Pccall(Primitive.simple ~name:"caml_int64_compare" ~arity:2
+                ~alloc:false),
        false)
 ]
 
@@ -332,12 +311,10 @@ let index_primitives_table =
 ]
 
 let prim_makearray =
-  { prim_name = "caml_make_vect"; prim_arity = 2; prim_alloc = true;
-    prim_native_name = ""; prim_native_float = false }
+  Primitive.simple ~name:"caml_make_vect" ~arity:2 ~alloc:true
 
 let prim_obj_dup =
-  { prim_name = "caml_obj_dup"; prim_arity = 1; prim_alloc = true;
-    prim_native_name = ""; prim_native_float = false }
+  Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true
 
 let find_primitive loc prim_name =
   match prim_name with
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index 4ff70b7be4..86da2dfafa 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -46,9 +46,7 @@ let field_path path field =
 (* Compile type extensions *)
 
 let prim_set_oo_id =
-  Pccall {Primitive.prim_name = "caml_set_oo_id"; prim_arity = 1;
-          prim_alloc = false; prim_native_name = "";
-          prim_native_float = false}
+  Pccall (Primitive.simple ~name:"caml_set_oo_id" ~arity:1 ~alloc:false)
 
 let transl_extension_constructor env path ext =
   let name =
diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml
index 02731ec684..a87a39e68b 100644
--- a/bytecomp/translobj.ml
+++ b/bytecomp/translobj.ml
@@ -11,7 +11,6 @@
 (***********************************************************************)
 
 open Misc
-open Primitive
 open Asttypes
 open Longident
 open Lambda
@@ -90,8 +89,7 @@ let string s = Lconst (Const_base (Const_string (s, None)))
 let int n = Lconst (Const_base (Const_int n))
 
 let prim_makearray =
-  { prim_name = "caml_make_vect"; prim_arity = 2; prim_alloc = true;
-    prim_native_name = ""; prim_native_float = false }
+  Primitive.simple ~name:"caml_make_vect" ~arity:2 ~alloc:true
 
 (* Also use it for required globals *)
 let transl_label_init expr =
diff --git a/typing/primitive.ml b/typing/primitive.ml
index 17abeb34f1..3b55b2ac52 100644
--- a/typing/primitive.ml
+++ b/typing/primitive.ml
@@ -13,36 +13,81 @@
 (* Description of primitive functions *)
 
 open Misc
+open Parsetree
+
+type boxed_integer = Pnativeint | Pint32 | Pint64
+
+type native_repr =
+  | Same_as_ocaml_repr
+  | Unboxed_float
+  | Unboxed_integer of boxed_integer
+  | Untagged_int
 
 type description =
   { prim_name: string;         (* Name of primitive  or C function *)
     prim_arity: int;           (* Number of arguments *)
     prim_alloc: bool;          (* Does it allocates or raise? *)
     prim_native_name: string;  (* Name of C function for the nat. code gen. *)
-    prim_native_float: bool }  (* Does the above operate on unboxed floats? *)
-
-let parse_declaration arity decl =
-  match decl with
-  | name :: "noalloc" :: name2 :: "float" :: _ ->
-      {prim_name = name; prim_arity = arity; prim_alloc = false;
-       prim_native_name = name2; prim_native_float = true}
-  | name :: "noalloc" :: name2 :: _ ->
-      {prim_name = name; prim_arity = arity; prim_alloc = false;
-       prim_native_name = name2; prim_native_float = false}
-  | name :: name2 :: "float" :: _ ->
-      {prim_name = name; prim_arity = arity; prim_alloc = true;
-       prim_native_name = name2; prim_native_float = true}
-  | name :: "noalloc" :: _ ->
-      {prim_name = name; prim_arity = arity; prim_alloc = false;
-       prim_native_name = ""; prim_native_float = false}
-  | name :: name2 :: _ ->
-      {prim_name = name; prim_arity = arity; prim_alloc = true;
-       prim_native_name = name2; prim_native_float = false}
-  | name :: _ ->
-      {prim_name = name; prim_arity = arity; prim_alloc = true;
-       prim_native_name = ""; prim_native_float = false}
-  | [] ->
-      fatal_error "Primitive.parse_declaration"
+    prim_native_repr_args: native_repr list;
+    prim_native_repr_res: native_repr }
+
+type error =
+  | Float_with_native_repr_attribute
+
+exception Error of Location.t * error
+
+let is_ocaml_repor = function
+  | Same_as_ocaml_repr -> true
+  | Unboxed_float
+  | Unboxed_integer _
+  | Untagged_int -> false
+
+let rec make_native_repr_args arity x =
+  if arity = 0 then
+    []
+  else
+    x :: make_native_repr_args (arity - 1) x
+
+let simple ~name ~arity ~alloc =
+  {prim_name = name;
+   prim_arity = arity;
+   prim_alloc = alloc;
+   prim_native_name = "";
+   prim_native_repr_args = make_native_repr_args arity Same_as_ocaml_repr;
+   prim_native_repr_res = Same_as_ocaml_repr}
+
+let parse_declaration valdecl ~native_repr_args ~native_repr_res =
+  let arity = List.length native_repr_args in
+  let name, native_name, noalloc, float =
+    match valdecl.pval_prim with
+    | name :: "noalloc" :: name2 :: "float" :: _ -> (name, name2, true, true)
+    | name :: "noalloc" :: name2 :: _ -> (name, name2, true, false)
+    | name :: name2 :: "float" :: _ -> (name, name2, false, true)
+    | name :: "noalloc" :: _ -> (name, "", true, false)
+    | name :: name2 :: _ -> (name, name2, false, false)
+    | name :: _ -> (name, "", false, false)
+    | [] ->
+        fatal_error "Primitive.parse_declaration"
+  in
+  (* The compiler used to assume "noalloc" with "float", we just make this
+     explicit now (GPR#167): *)
+  let noalloc = noalloc || float in
+  if float &&
+     not (List.for_all is_ocaml_repor native_repr_args &&
+          is_ocaml_repor native_repr_res) then
+    raise (Error (valdecl.pval_loc, Float_with_native_repr_attribute));
+  let native_repr_args, native_repr_res =
+    if float then
+      (make_native_repr_args arity Unboxed_float, Unboxed_float)
+    else
+      (native_repr_args, native_repr_res)
+  in
+  {prim_name = name;
+   prim_arity = arity;
+   prim_alloc = not noalloc;
+   prim_native_name = native_name;
+   prim_native_repr_args = native_repr_args;
+   prim_native_repr_res = native_repr_res}
 
 let description_list p =
   let list = [p.prim_name] in
@@ -50,7 +95,14 @@ let description_list p =
   let list =
     if p.prim_native_name <> "" then p.prim_native_name :: list else list
   in
-  let list = if p.prim_native_float then "float" :: list else list in
+  let list =
+    let is_unboxed_float x = x = Unboxed_float in
+    if List.for_all is_unboxed_float p.prim_native_repr_args &&
+       is_unboxed_float p.prim_native_repr_res then
+      "float" :: list
+    else
+      list
+  in
   List.rev list
 
 let native_name p =
@@ -60,3 +112,18 @@ let native_name p =
 
 let byte_name p =
   p.prim_name
+
+let report_error ppf err =
+  let open Format in
+  match err with
+  | Float_with_native_repr_attribute ->
+      fprintf ppf "Cannot use \"float\" in conjunction with [@unboxed ]/[@untagged ]"
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (loc, err) ->
+        Some (Location.error_of_printer loc report_error err)
+      | _ ->
+        None
+    )
diff --git a/typing/primitive.mli b/typing/primitive.mli
index 585dba0d13..d2a2032572 100644
--- a/typing/primitive.mli
+++ b/typing/primitive.mli
@@ -12,16 +12,42 @@
 
 (* Description of primitive functions *)
 
-type description =
+type boxed_integer = Pnativeint | Pint32 | Pint64
+
+(* Representation of arguments/result for the native code version
+   of a primitive *)
+type native_repr =
+  | Same_as_ocaml_repr
+  | Unboxed_float
+  | Unboxed_integer of boxed_integer
+  | Untagged_int
+
+type description = private
   { prim_name: string;         (* Name of primitive  or C function *)
     prim_arity: int;           (* Number of arguments *)
     prim_alloc: bool;          (* Does it allocates or raise? *)
     prim_native_name: string;  (* Name of C function for the nat. code gen. *)
-    prim_native_float: bool }  (* Does the above operate on unboxed floats? *)
+    prim_native_repr_args: native_repr list;
+    prim_native_repr_res: native_repr }
+
+val simple
+  :  name:string
+  -> arity:int
+  -> alloc:bool
+  -> description
 
-val parse_declaration: int -> string list -> description
+val parse_declaration
+  :  Parsetree.value_description
+  -> native_repr_args:native_repr list
+  -> native_repr_res:native_repr
+  -> description
 
 val description_list: description -> string list
 
 val native_name: description -> string
 val byte_name: description -> string
+
+type error =
+  | Float_with_native_repr_attribute
+
+exception Error of Location.t * error
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index ccca63a614..7d4482f07a 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -19,6 +19,12 @@ open Primitive
 open Types
 open Typetexp
 
+type native_repr_kind = Unboxed | Untagged
+
+let string_of_native_repr_kind = function
+  | Unboxed -> "unboxed"
+  | Untagged -> "untagged"
+
 type error =
     Repeated_parameter
   | Duplicate_constructor of string
@@ -46,6 +52,9 @@ type error =
   | Unbound_type_var_ext of type_expr * extension_constructor
   | Varying_anonymous
   | Val_in_structure
+  | Invalid_native_repr_attribute_payload of native_repr_kind
+  | Multiple_native_repr_attributes
+  | Cannot_unbox_or_untag_type of native_repr_kind
 
 open Typedtree
 
@@ -1351,6 +1360,66 @@ let transl_exception env sext =
   let newenv = Env.add_extension ~check:true ext.ext_id ext.ext_type env in
     ext, newenv
 
+type native_repr_attribute =
+  | Native_repr_attr_absent
+  | Native_repr_attr_present of native_repr_kind
+
+let get_native_repr_attribute core_type =
+  match
+    List.filter
+      (fun (n, _) ->
+         match n.Location.txt with
+         | "unboxed" | "untagged" -> true
+         | _ -> false)
+      core_type.ptyp_attributes
+  with
+  | [] ->
+    Native_repr_attr_absent
+  | _ :: (n, _) :: _ ->
+    raise (Error (n.Location.loc, Multiple_native_repr_attributes))
+  | [(n, payload)] ->
+    let kind = if n.txt = "unboxed" then Unboxed else Untagged in
+    match payload with
+    | PStr [] ->
+      Native_repr_attr_present kind
+    | _ ->
+      raise (Error (n.Location.loc,
+                    Invalid_native_repr_attribute_payload kind))
+
+let native_repr_of_type env kind ty =
+  match kind, (Ctype.expand_head_opt env ty).desc with
+  | Untagged, Tconstr (path, _, _) when Path.same path Predef.path_int ->
+    Some Untagged_int
+  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_float ->
+    Some Unboxed_float
+  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int32 ->
+    Some (Unboxed_integer Pint32)
+  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int64 ->
+    Some (Unboxed_integer Pint64)
+  | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_nativeint ->
+    Some (Unboxed_integer Pnativeint)
+  | _ ->
+    None
+
+let make_native_repr env core_type ty =
+  match get_native_repr_attribute core_type with
+  | Native_repr_attr_absent -> Same_as_ocaml_repr
+  | Native_repr_attr_present kind ->
+    begin match native_repr_of_type env kind ty with
+    | None ->
+      raise (Error (core_type.ptyp_loc, Cannot_unbox_or_untag_type kind))
+    | Some repr -> repr
+    end
+
+let rec parse_native_repr_attributes env core_type ty =
+  match core_type.ptyp_desc, (Ctype.repr ty).desc with
+  | Ptyp_arrow (_, ct1, ct2), Tarrow (_, t1, t2, _) ->
+    let repr_arg = make_native_repr env ct1 t1 in
+    let repr_args, repr_res = parse_native_repr_attributes env ct2 t2 in
+    (repr_arg :: repr_args, repr_res)
+  | Ptyp_arrow _, _ | _, Tarrow _ -> assert false
+  | _ -> ([], make_native_repr env core_type ty)
+
 (* Translate a value declaration *)
 let transl_value_decl env loc valdecl =
   let cty = Typetexp.transl_type_scheme env valdecl.pval_type in
@@ -1362,10 +1431,17 @@ let transl_value_decl env loc valdecl =
         val_attributes = valdecl.pval_attributes }
   | [] ->
       raise (Error(valdecl.pval_loc, Val_in_structure))
-  | decl ->
-      let arity = Ctype.arity ty in
-      let prim = Primitive.parse_declaration arity decl in
-      if arity = 0 && (prim.prim_name = "" || prim.prim_name.[0] <> '%') then
+  | _ ->
+      let native_repr_args, native_repr_res =
+        parse_native_repr_attributes env valdecl.pval_type ty
+      in
+      let prim =
+        Primitive.parse_declaration valdecl
+          ~native_repr_args
+          ~native_repr_res
+      in
+      if prim.prim_arity = 0 &&
+         (prim.prim_name = "" || prim.prim_name.[0] <> '%') then
         raise(Error(valdecl.pval_type.ptyp_loc, Null_arity_external));
       if !Clflags.native_code
       && prim.prim_arity > 5
@@ -1714,6 +1790,17 @@ let report_error ppf = function
         "cannot be checked"
   | Val_in_structure ->
       fprintf ppf "Value declarations are only allowed in signatures"
+  | Invalid_native_repr_attribute_payload kind ->
+      fprintf ppf "[@%s] attribute does not accept a payload"
+        (string_of_native_repr_kind kind)
+  | Multiple_native_repr_attributes ->
+      fprintf ppf "Too many [@unboxed]/[@untagged] attributes"
+  | Cannot_unbox_or_untag_type Unboxed ->
+      fprintf ppf "Don't know how to unbox this type. Only float, int32, \
+                   int64 and nativeint can be unboxed"
+  | Cannot_unbox_or_untag_type Untagged ->
+      fprintf ppf "Don't know how to untag this type. Only int \
+                   can be untagged"
 
 let () =
   Location.register_error_of_exn
diff --git a/typing/typedecl.mli b/typing/typedecl.mli
index 34cb00be7a..7f3b96c204 100644
--- a/typing/typedecl.mli
+++ b/typing/typedecl.mli
@@ -56,6 +56,8 @@ val compute_variance_decls:
     (Types.type_declaration * Types.type_declaration *
      Types.class_declaration * Types.class_type_declaration) list
 
+type native_repr_kind = Unboxed | Untagged
+
 type error =
     Repeated_parameter
   | Duplicate_constructor of string
@@ -83,6 +85,9 @@ type error =
   | Unbound_type_var_ext of type_expr * extension_constructor
   | Varying_anonymous
   | Val_in_structure
+  | Invalid_native_repr_attribute_payload of native_repr_kind
+  | Multiple_native_repr_attributes
+  | Cannot_unbox_or_untag_type of native_repr_kind
 
 exception Error of Location.t * error
 
diff --git a/utils/config.mlp b/utils/config.mlp
index f89f618eaf..c668d13214 100644
--- a/utils/config.mlp
+++ b/utils/config.mlp
@@ -49,11 +49,11 @@ let mkexe = "%%MKEXE%%"
 let mkmaindll = "%%MKMAINDLL%%"
 
 let exec_magic_number = "Caml1999X011"
-and cmi_magic_number = "Caml1999I019"
-and cmo_magic_number = "Caml1999O010"
-and cma_magic_number = "Caml1999A011"
-and cmx_magic_number = "Caml1999Y014"
-and cmxa_magic_number = "Caml1999Z013"
+and cmi_magic_number = "Caml1999I020"
+and cmo_magic_number = "Caml1999O011"
+and cma_magic_number = "Caml1999A012"
+and cmx_magic_number = "Caml1999Y015"
+and cmxa_magic_number = "Caml1999Z014"
 and ast_impl_magic_number = "Caml1999M019"
 and ast_intf_magic_number = "Caml1999N018"
 and cmxs_magic_number = "Caml2007D002"