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

Author: jeremiedimino

.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

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,24 +1236,33 @@ 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 *)
   let join k1 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 *)

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
 

boot/ocamlc

@@ -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 =

boot/ocamldep

@@ -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 =

boot/ocamllex

@@ -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

bytecomp/lambda.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