Generic functions for unboxed types

Author: Ekdohibs

backend/cmm_helpers.ml

@@ -61,7 +61,7 @@ val boxedintnat_header : nativeint
 
 (** Closure info for a closure of given arity and distance to environment *)
 val closure_info :
-  arity:Clambda.arity -> startenv:int -> is_last:bool -> nativeint
+  arity:Lambda.function_kind * int -> startenv:int -> is_last:bool -> nativeint
 
 (** Wrappers *)
 val alloc_infix_header : int -> Debuginfo.t -> expression
@@ -369,6 +369,8 @@ val call_cached_method :
   expression ->
   expression ->
   expression list ->
+  machtype list ->
+  machtype ->
   Clambda.apply_kind ->
   Debuginfo.t ->
   expression
@@ -408,11 +410,13 @@ val opaque : expression -> Debuginfo.t -> expression
 
 (** Get the symbol for the generic application with [n] arguments, and ensure
     its presence in the set of defined symbols *)
-val apply_function_sym : int -> Lambda.alloc_mode -> string
+val apply_function_sym :
+  machtype list -> machtype -> Lambda.alloc_mode -> string
 
 (** Get the symbol for the generic currying or tuplifying wrapper with [n]
     arguments, and ensure its presence in the set of defined symbols. *)
-val curry_function_sym : Clambda.arity -> string
+val curry_function_sym :
+  Lambda.function_kind -> machtype list -> machtype -> string
 
 (** Bigarrays *)
 
@@ -755,6 +759,8 @@ val generic_apply :
   Asttypes.mutable_flag ->
   expression ->
   expression list ->
+  machtype list ->
+  machtype ->
   Clambda.apply_kind ->
   Debuginfo.t ->
   expression
@@ -774,6 +780,8 @@ val send :
   expression ->
   expression ->
   expression list ->
+  machtype list ->
+  machtype ->
   Clambda.apply_kind ->
   Debuginfo.t ->
   expression
@@ -1107,6 +1115,7 @@ val indirect_call :
   Lambda.region_close ->
   Lambda.alloc_mode ->
   expression ->
+  machtype list ->
   expression list ->
   expression
 
@@ -1118,6 +1127,7 @@ val indirect_full_call :
   Lambda.region_close ->
   Lambda.alloc_mode ->
   expression ->
+  machtype list ->
   expression list ->
   expression
 
@@ -1197,3 +1207,5 @@ val transl_attrib : Lambda.check_attribute -> Cmm.codegen_option list
 val make_symbol : ?compilation_unit:Compilation_unit.t -> string -> string
 
 val kind_of_layout : Lambda.layout -> value_kind
+
+val machtype_of_layout : Lambda.layout -> machtype

backend/cmm_helpers.mli

@@ -459,14 +459,14 @@ let rec transl env e =
             let dbg = f.dbg in
             let without_header =
               match f.arity with
-              | Curried _, (1|0) as arity ->
+              | { function_kind = Curried _ ; params_layout = ([] | [_]) } as arity ->
                 Cconst_symbol (f.label, dbg) ::
-                alloc_closure_info ~arity
+                alloc_closure_info ~arity:(arity.function_kind, List.length arity.params_layout)
                                    ~startenv:(startenv - pos) ~is_last dbg ::
                 transl_fundecls (pos + 3) rem
               | arity ->
-                Cconst_symbol (curry_function_sym arity, dbg) ::
-                alloc_closure_info ~arity
+                Cconst_symbol (curry_function_sym arity.function_kind (List.map machtype_of_layout arity.params_layout) (machtype_of_layout arity.return_layout), dbg) ::
+                alloc_closure_info ~arity:(arity.function_kind, List.length arity.params_layout)
                                    ~startenv:(startenv - pos) ~is_last dbg ::
                 Cconst_symbol (f.label, dbg) ::
                 transl_fundecls (pos + 4) rem
@@ -496,12 +496,16 @@ let rec transl env e =
   | Ugeneric_apply(clos, args, kind, dbg) ->
       let clos = transl env clos in
       let args = List.map (transl env) args in
-      generic_apply (mut_from_env env clos) clos args kind dbg
+      let args_type = List.map (fun _ -> typ_val) args in
+      let return = typ_val in
+      generic_apply (mut_from_env env clos) clos args args_type return kind dbg
   | Usend(kind, met, obj, args, pos, dbg) ->
       let met = transl env met in
       let obj = transl env obj in
       let args = List.map (transl env) args in
-      send kind met obj args pos dbg
+      let args_type = List.map (fun _ -> typ_val) args in
+      let return = typ_val in
+      send kind met obj args args_type return pos dbg
   | Ulet(str, kind, id, exp, body) ->
       transl_let env str kind id exp (fun env -> transl env body)
   | Uphantom_let (var, defining_expr, body) ->
@@ -1480,8 +1484,14 @@ let transl_function f =
     else
       [ Reduce_code_size ]
   in
+  let params_layout =
+    if List.length f.params = List.length f.arity.params_layout then
+      f.arity.params_layout
+    else
+      f.arity.params_layout @ [Lambda.layout_function]
+  in
   Cfunction {fun_name = f.label;
-             fun_args = List.map (fun (id, _) -> (id, typ_val)) f.params;
+             fun_args = List.map2 (fun id ty -> (id, machtype_of_layout ty)) f.params params_layout;
              fun_body = cmm_body;
              fun_codegen_options;
              fun_poll = f.poll;

backend/cmmgen.ml

@@ -41,11 +41,11 @@ type export_info_raw =
   | Flambda1_raw of Export_info.t
   | Flambda2_raw of Flambda2_cmx.Flambda_cmx_format.raw option
 
-type apply_fn := int * Lambda.alloc_mode
+type apply_fn := Cmm.machtype list * Cmm.machtype * Lambda.alloc_mode
 
 (* Curry/apply/send functions *)
 type generic_fns =
-  { curry_fun: Clambda.arity list;
+  { curry_fun: (Lambda.function_kind * Cmm.machtype list * Cmm.machtype) list;
     apply_fun: apply_fn list;
     send_fun: apply_fn list }
 

file_formats/cmx_format.mli

@@ -20,7 +20,11 @@ open Asttypes
 open Lambda
 
 type function_label = string
-type arity = Lambda.function_kind * int
+type arity = {
+  function_kind : Lambda.function_kind ;
+  params_layout : Lambda.layout list ;
+  return_layout : Lambda.layout ;
+}
 type apply_kind = Lambda.region_close * Lambda.alloc_mode
 
 type ustructured_constant =
@@ -98,8 +102,7 @@ and ulambda =
 and ufunction = {
   label  : function_label;
   arity  : arity;
-  params : (Backend_var.With_provenance.t * layout) list;
-  return : layout;
+  params : Backend_var.With_provenance.t list;
   body   : ulambda;
   dbg    : Debuginfo.t;
   env    : Backend_var.t option;

middle_end/clambda.ml

@@ -20,7 +20,11 @@ open Asttypes
 open Lambda
 
 type function_label = string
-type arity = Lambda.function_kind * int
+type arity = {
+  function_kind : Lambda.function_kind ;
+  params_layout : Lambda.layout list ;
+  return_layout : Lambda.layout ;
+}
 type apply_kind = Lambda.region_close * Lambda.alloc_mode
 
 type ustructured_constant =
@@ -109,8 +113,7 @@ and ulambda =
 and ufunction = {
   label  : function_label;
   arity  : arity;
-  params : (Backend_var.With_provenance.t * layout) list;
-  return : layout;
+  params : Backend_var.With_provenance.t list;
   body   : ulambda;
   dbg    : Debuginfo.t;
   env    : Backend_var.t option;

middle_end/clambda.mli

@@ -1029,28 +1029,29 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env)
           Location.print_loc (Debuginfo.Scoped_location.to_location loc);
       begin match (close env funct, close_list env args) with
         ((ufunct, Value_closure(_,
-                                ({fun_arity=(Tupled, nparams)} as fundesc),
+                                ({fun_arity={function_kind = Tupled ; params_layout = params_layout; _}} as fundesc),
                                 approx_res)),
          [Uprim(P.Pmakeblock _, uargs, _)])
-        when List.length uargs = nparams ->
+        when List.length uargs = List.length params_layout ->
           let app =
             direct_apply env ~loc ~attribute fundesc ufunct uargs
               pos mode ~probe in
           (app, strengthen_approx app approx_res)
       | ((ufunct, Value_closure(_,
-                                ({fun_arity=(Curried _, nparams)} as fundesc),
+                                ({fun_arity={function_kind = Curried _ ; params_layout ; _}} as fundesc),
                                 approx_res)), uargs)
-        when nargs = nparams ->
+        when nargs = List.length params_layout ->
           let app =
             direct_apply env ~loc ~attribute fundesc ufunct uargs
               pos mode ~probe in
           (app, strengthen_approx app approx_res)
 
       | ((ufunct, (Value_closure(
             clos_mode,
-            ({fun_arity=(Curried {nlocal}, nparams)} as fundesc),
+            ({fun_arity={ function_kind = Curried {nlocal} ; params_layout ; _ }} as fundesc),
             _) as fapprox)), uargs)
-          when nargs < nparams ->
+          when nargs < List.length params_layout ->
+        let nparams = List.length params_layout in
         let first_args = List.map (fun arg ->
           (V.create_local "arg", arg) ) uargs in
         (* CR mshinwell: Edit when Lapply has kinds *)
@@ -1119,9 +1120,10 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env)
         fail_if_probe ~probe "Partial application";
         (new_fun, approx)
 
-      | ((ufunct, Value_closure(_, ({fun_arity = (Curried _, nparams)} as fundesc),
+      | ((ufunct, Value_closure(_, ({fun_arity = { function_kind = Curried _; params_layout ; _}} as fundesc),
                                 _approx_res)), uargs)
-        when nargs > nparams ->
+        when nargs > List.length params_layout ->
+          let nparams = List.length params_layout in
           let args = List.map (fun arg -> V.create_local "arg", arg) uargs in
           (* CR mshinwell: Edit when Lapply has kinds *)
           let kinds =
@@ -1154,6 +1156,7 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env)
           in
           let result =
             List.fold_left (fun body (id, defining_expr) ->
+                (* CR ncourant: we need to know the layout of defining_expr here, this is hard *)
                 Ulet (Immutable, Lambda.layout_top, VP.create id, defining_expr, body))
               body
               args
@@ -1276,7 +1279,7 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env)
       in
       let arg, _approx = close env arg in
       let id = Ident.create_local "dummy" in
-      Ulet(Immutable, Lambda.layout_top, VP.create id, arg, cst), approx
+      Ulet(Immutable, Lambda.layout_unit, VP.create id, arg, cst), approx
   | Lprim(Pignore, [arg], _loc) ->
       let expr, approx = make_const_int 0 in
       Usequence(fst (close env arg), expr), approx
@@ -1483,10 +1486,9 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_
               |> Symbol.linkage_name
               |> Linkage_name.to_string
             in
-            let arity = List.length params in
             let fundesc =
               {fun_label = label;
-               fun_arity = (kind, arity);
+               fun_arity = { function_kind = kind ; params_layout = List.map snd params ; return_layout = return };
                fun_closed = initially_closed;
                fun_inline = None;
                fun_float_const_prop = !Clflags.float_const_prop;
@@ -1515,7 +1517,7 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_
       (fun (_id, _params, _return, _body, _mode, _attrib, fundesc, _dbg) ->
         let pos = !env_pos + 1 in
         env_pos := !env_pos + 1 +
-          (match fundesc.fun_arity with (Curried _, (0|1)) -> 2 | _ -> 3);
+          (match fundesc.fun_arity with { function_kind = Curried _; params_layout = ([] | [_]); _} -> 2 | _ -> 3);
         pos)
       uncurried_defs in
   let fv_pos = !env_pos in
@@ -1565,8 +1567,7 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_
       {
         label  = fundesc.fun_label;
         arity  = fundesc.fun_arity;
-        params = List.map (fun (var, kind) -> VP.create var, kind) fun_params;
-        return;
+        params = List.map (fun (var, _) -> VP.create var) fun_params;
         body   = ubody;
         dbg;
         env = Some env_param;

middle_end/closure/closure.ml

@@ -323,24 +323,24 @@ let approx_env () = !merged_environment
 
 (* Record that a currying function or application function is needed *)
 
-let need_curry_fun arity =
+let need_curry_fun kind arity result =
   let fns = current_unit.ui_generic_fns in
-  if not (List.mem arity fns.curry_fun) then
+  if not (List.mem (kind, arity, result) fns.curry_fun) then
     current_unit.ui_generic_fns <-
-      { fns with curry_fun = arity :: fns.curry_fun }
+      { fns with curry_fun = (kind, arity, result) :: fns.curry_fun }
 
-let need_apply_fun n mode =
-  assert(n > 0);
+let need_apply_fun arity result mode =
+  assert(List.compare_length_with arity 0 > 0);
   let fns = current_unit.ui_generic_fns in
-  if not (List.mem (n,mode) fns.apply_fun) then
+  if not (List.mem (arity, result, mode) fns.apply_fun) then
     current_unit.ui_generic_fns <-
-      { fns with apply_fun = (n,mode) :: fns.apply_fun }
+      { fns with apply_fun = (arity, result, mode) :: fns.apply_fun }
 
-let need_send_fun n mode =
+let need_send_fun arity result mode =
   let fns = current_unit.ui_generic_fns in
-  if not (List.mem (n,mode) fns.send_fun) then
+  if not (List.mem (arity, result, mode) fns.send_fun) then
     current_unit.ui_generic_fns <-
-      { fns with send_fun = (n,mode) :: fns.send_fun }
+      { fns with send_fun = (arity, result, mode) :: fns.send_fun }
 
 (* Write the description of the current unit *)
 

middle_end/compilenv.ml

@@ -1,3 +1,4 @@
+
 (**************************************************************************)
 (*                                                                        *)
 (*                                 OCaml                                  *)
@@ -68,9 +69,9 @@ val get_unit_export_info
 val flambda2_set_export_info : Flambda2_cmx.Flambda_cmx_format.t -> unit
         (* Set the export information for the current unit (Flambda 2 only). *)
 
-val need_curry_fun: Clambda.arity -> unit
-val need_apply_fun: int -> Lambda.alloc_mode -> unit
-val need_send_fun: int -> Lambda.alloc_mode -> unit
+val need_curry_fun: Lambda.function_kind -> Cmm.machtype list -> Cmm.machtype -> unit
+val need_apply_fun: Cmm.machtype list -> Cmm.machtype -> Lambda.alloc_mode -> unit
+val need_send_fun: Cmm.machtype list -> Cmm.machtype -> Lambda.alloc_mode -> unit
         (* Record the need of a currying (resp. application,
            message sending) function with the given arity *)
 

middle_end/compilenv.mli

@@ -99,7 +99,11 @@ let clambda_arity (func : Flambda.function_declaration) : Clambda.arity =
            Lambda.is_local_mode (Parameter.alloc_mode p))
     |> List.length
   in
-  Curried {nlocal}, Flambda_utils.function_arity func
+  {
+    function_kind = Curried {nlocal} ;
+    params_layout = List.map Parameter.kind func.params ;
+    return_layout = assert false ; (* Need func.return *)
+  }
 
 let check_field t ulam pos named_opt : Clambda.ulambda =
   if not !Clflags.clambda_checks then ulam
@@ -562,7 +566,7 @@ and to_clambda_set_of_closures t env
     let env_body, params =
       List.fold_right (fun var (env, params) ->
           let id, env = Env.add_fresh_ident env (Parameter.var var) in
-          env, (VP.create id, Parameter.kind var) :: params)
+          env, VP.create id :: params)
         function_decl.params (env, [])
     in
     let label =
@@ -572,8 +576,7 @@ and to_clambda_set_of_closures t env
     in
     { label;
       arity = clambda_arity function_decl;
-      params = params @ [VP.create env_var, Lambda.layout_function];
-      return = Lambda.layout_top;
+      params = params @ [VP.create env_var];
       body = to_clambda t env_body function_decl.body;
       dbg = function_decl.dbg;
       env = Some env_var;
@@ -623,7 +626,7 @@ and to_clambda_closed_set_of_closures t env symbol
     let env_body, params =
       List.fold_right (fun var (env, params) ->
           let id, env = Env.add_fresh_ident env (Parameter.var var) in
-          env, (VP.create id, Parameter.kind var) :: params)
+          env, VP.create id :: params)
         function_decl.params (env, [])
     in
     let body =
@@ -641,7 +644,6 @@ and to_clambda_closed_set_of_closures t env symbol
     { label;
       arity = clambda_arity function_decl;
       params;
-      return = Lambda.layout_top;
       body;
       dbg = function_decl.dbg;
       env = None;