Allow primitives to be poly-moded (#43)

Author: stedolan

asmcomp/cmm_helpers.ml

@@ -1373,7 +1373,7 @@ let default_prim name =
 
 
 let int64_native_prim name arity ~alloc =
-  let u64 = Primitive.Unboxed_integer Primitive.Pint64 in
+  let u64 = Primitive.(Prim_global, Unboxed_integer Pint64) in
   let rec make_args = function 0 -> [] | n -> u64 :: make_args (n - 1) in
   Primitive.make ~name ~native_name:(name ^ "_native")
     ~alloc

asmcomp/cmmgen.ml

@@ -781,19 +781,19 @@ and transl_ccall env prim args dbg =
         (List.map (fun _ -> XInt) args, List.map (transl env) args)
     | _, [] ->
         assert false
-    | native_repr :: native_repr_args, arg :: args ->
+    | (_, native_repr) :: native_repr_args, arg :: args ->
         let (ty1, arg') = transl_arg native_repr arg in
         let (tys, args') = transl_args native_repr_args args in
         (ty1 :: tys, arg' :: 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 dbg)
-    | Unboxed_integer Pint64 when size_int = 4 ->
+    | _, Same_as_ocaml_repr -> (typ_val, fun x -> x)
+    | _, Unboxed_float -> (typ_float, box_float dbg)
+    | _, Unboxed_integer Pint64 when size_int = 4 ->
         ([|Int; Int|], box_int dbg Pint64)
-    | Unboxed_integer bi -> (typ_int, box_int dbg bi)
-    | Untagged_int -> (typ_int, (fun i -> tag_int i dbg))
+    | _, Unboxed_integer bi -> (typ_int, box_int dbg bi)
+    | _, Untagged_int -> (typ_int, (fun i -> tag_int i dbg))
   in
   let typ_args, args = transl_args prim.prim_native_repr_args args in
   wrap_result

lambda/translcore.ml

@@ -165,7 +165,8 @@ let rec push_defaults loc bindings cases partial =
           Texp_match
             ({exp with exp_type = pat.pat_type; exp_env = env; exp_desc =
               Texp_ident
-                (Path.Pident param, mknoloc (Longident.Lident name), desc)},
+                (Path.Pident param, mknoloc (Longident.Lident name),
+                 desc, Id_value)},
              cases, partial) }
       in
       push_defaults loc bindings
@@ -231,13 +232,14 @@ let rec iter_exn_names f pat =
       iter_exn_names f p
   | _ -> ()
 
-let transl_ident loc env ty path desc =
-  match desc.val_kind with
-  | Val_prim p ->
-      Translprim.transl_primitive loc p env ty (Some path)
-  | Val_anc _ ->
+let transl_ident loc env ty path desc kind =
+  match desc.val_kind, kind with
+  | Val_prim p, Id_prim pmode ->
+      let poly_mode = transl_alloc_mode pmode in
+      Translprim.transl_primitive loc p env ty ~poly_mode (Some path)
+  | Val_anc _, Id_value ->
       raise(Error(to_location loc, Free_super_var))
-  | Val_reg | Val_self _ ->
+  | (Val_reg | Val_self _), Id_value ->
       transl_value_path loc env path
   |  _ -> fatal_error "Translcore.transl_exp: bad Texp_ident"
 
@@ -273,9 +275,9 @@ and transl_exp1 ~scopes ~in_new_scope e =
 
 and transl_exp0 ~in_new_scope ~scopes e =
   match e.exp_desc with
-  | Texp_ident(path, _, desc) ->
+  | Texp_ident(path, _, desc, kind) ->
       transl_ident (of_location ~scopes e.exp_loc)
-        e.exp_env e.exp_type path desc
+        e.exp_env e.exp_type path desc kind
   | Texp_constant cst ->
       Lconst(Const_base cst)
   | Texp_let(rec_flag, pat_expr_list, body) ->
@@ -288,7 +290,8 @@ and transl_exp0 ~in_new_scope ~scopes e =
         else enter_anonymous_function ~scopes
       in
       transl_function ~scopes e param cases partial
-  | Texp_apply({ exp_desc = Texp_ident(path, _, {val_kind = Val_prim p});
+  | Texp_apply({ exp_desc = Texp_ident(path, _, {val_kind = Val_prim p},
+                                       Id_prim pmode);
                 exp_type = prim_type } as funct, oargs)
     when List.length oargs >= p.prim_arity
     && List.for_all (fun (_, arg) -> not (is_omitted arg)) oargs ->
@@ -298,9 +301,10 @@ and transl_exp0 ~in_new_scope ~scopes e =
       in
       let args = transl_list ~scopes arg_exps in
       let prim_exp = if extra_args = [] then Some e else None in
+      let pmode = transl_alloc_mode pmode in
       let lam =
         Translprim.transl_primitive_application
-          (of_location ~scopes e.exp_loc) p e.exp_env prim_type path
+          (of_location ~scopes e.exp_loc) p e.exp_env prim_type pmode path
           prim_exp args arg_exps
       in
       if extra_args = [] then lam
@@ -1248,7 +1252,7 @@ and transl_letop ~scopes loc env let_ ands param case partial =
         let right_id = Ident.create_local "right" in
         let op =
           transl_ident (of_location ~scopes and_.bop_op_name.loc) env
-            and_.bop_op_type and_.bop_op_path and_.bop_op_val
+            and_.bop_op_type and_.bop_op_path and_.bop_op_val Id_value
         in
         let exp = transl_exp ~scopes and_.bop_exp in
         let lam =
@@ -1266,7 +1270,7 @@ and transl_letop ~scopes loc env let_ ands param case partial =
   in
   let op =
     transl_ident (of_location ~scopes let_.bop_op_name.loc) env
-      let_.bop_op_type let_.bop_op_path let_.bop_op_val
+      let_.bop_op_type let_.bop_op_path let_.bop_op_val Id_value
   in
   let exp = loop (transl_exp ~scopes let_.bop_exp) ands in
   let func =

lambda/translcore.mli

@@ -41,6 +41,8 @@ val transl_extension_constructor: scopes:scopes ->
 
 val transl_scoped_exp : scopes:scopes -> expression -> lambda
 
+val transl_alloc_mode : Types.alloc_mode -> Lambda.alloc_mode
+
 type error =
     Free_super_var
   | Unreachable_reached

lambda/translmod.ml

@@ -95,8 +95,9 @@ let rec apply_coercion loc strict restr arg =
       let param = Ident.create_local "funarg" in
       let carg = apply_coercion loc Alias cc_arg (Lvar param) in
       apply_coercion_result loc strict arg [param, Pgenval] [carg] cc_res
-  | Tcoerce_primitive { pc_loc = _; pc_desc; pc_env; pc_type; } ->
-      Translprim.transl_primitive loc pc_desc pc_env pc_type None
+  | Tcoerce_primitive { pc_loc = _; pc_desc; pc_env; pc_type; pc_poly_mode } ->
+      let poly_mode = Translcore.transl_alloc_mode pc_poly_mode in
+      Translprim.transl_primitive loc pc_desc pc_env pc_type ~poly_mode None
   | Tcoerce_alias (env, path, cc) ->
       let lam = transl_module_path loc env path in
       name_lambda strict arg
@@ -209,7 +210,10 @@ let compose_coercions c1 c2 =
 let primitive_declarations = ref ([] : Primitive.description list)
 let record_primitive = function
   | {val_kind=Val_prim p;val_loc} ->
-      Translprim.check_primitive_arity val_loc p;
+      let mode = match p.prim_native_repr_res with
+        | Prim_global, _ | Prim_poly, _ -> Alloc_heap
+        | Prim_local, _ -> Alloc_local in
+      Translprim.check_primitive_arity val_loc p mode;
       primitive_declarations := p :: !primitive_declarations
   | _ -> ()
 
@@ -569,7 +573,9 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function
                         Tcoerce_primitive p ->
                           Translprim.transl_primitive
                             (of_location ~scopes p.pc_loc)
-                            p.pc_desc p.pc_env p.pc_type None
+                            p.pc_desc p.pc_env p.pc_type
+                            ~poly_mode:(Translcore.transl_alloc_mode p.pc_poly_mode)
+                            None
                       | _ -> apply_coercion loc Strict cc (get_field pos))
                     pos_cc_list, loc)
             and id_pos_list =
@@ -979,8 +985,9 @@ let field_of_str loc str =
   let ids = Array.of_list (defined_idents str.str_items) in
   fun (pos, cc) ->
     match cc with
-    | Tcoerce_primitive { pc_loc = _; pc_desc; pc_env; pc_type; } ->
-        Translprim.transl_primitive loc pc_desc pc_env pc_type None
+    | Tcoerce_primitive { pc_loc = _; pc_desc; pc_env; pc_type; pc_poly_mode } ->
+        let poly_mode = Translcore.transl_alloc_mode pc_poly_mode in
+        Translprim.transl_primitive loc pc_desc pc_env pc_type ~poly_mode None
     | Tcoerce_alias (env, path, cc) ->
         let lam = transl_module_path loc env path in
         apply_coercion loc Alias cc lam
@@ -1300,10 +1307,11 @@ let transl_store_structure ~scopes glob map prims aliases str =
     List.fold_right (add_ident may_coerce) idlist subst
 
   and store_primitive (pos, prim) cont =
+    let poly_mode = Translcore.transl_alloc_mode prim.pc_poly_mode in
     Lsequence(Lprim(Psetfield(pos, Pointer, Root_initialization),
                     [Lprim(Pgetglobal glob, [], Loc_unknown);
                      Translprim.transl_primitive Loc_unknown
-                       prim.pc_desc prim.pc_env prim.pc_type None],
+                       prim.pc_desc prim.pc_env prim.pc_type ~poly_mode None],
                     Loc_unknown),
               cont)