Use kinds-with-subkinds more in To_cmm_shared interface (ocaml-flambd…

…a#1208)

backend/cmm_helpers.ml

@@ -1106,20 +1106,25 @@ let apply_function_sym arity result mode =
   apply_function_name arity result mode
 
 let curry_function_sym function_kind arity result =
-  Compilenv.need_curry_fun function_kind arity result;
   match function_kind with
   | Lambda.Curried { nlocal } ->
+    Compilenv.need_curry_fun function_kind arity result;
     "caml_curry"
     ^ unique_arity_identifier arity
     ^ (match result with
       | [| Val |] -> ""
       | _ -> "_R" ^ machtype_identifier result)
     ^ if nlocal > 0 then "L" ^ Int.to_string nlocal else ""
   | Lambda.Tupled -> (
-    if List.exists (function [| Val |] -> false | _ -> true) arity
+    if List.exists (function [| Val |] | [| Int |] -> false | _ -> true) arity
     then
       Misc.fatal_error
         "tuplify_function is currently unsupported if arity contains non-values";
+    (* Always use [Val] to ensure we don't generate duplicate tuplify functions
+       when [Int] machtypes are involved. *)
+    Compilenv.need_curry_fun function_kind
+      (List.map (fun _ -> [| Val |]) arity)
+      result;
     "caml_tuplify"
     ^ Int.to_string (List.length arity)
     ^
@@ -2523,7 +2528,7 @@ let apply_function (arity, result, mode) =
  *)
 
 let tuplify_function arity return =
-  if List.exists (function [| Val |] -> false | _ -> true) arity
+  if List.exists (function [| Val |] | [| Int |] -> false | _ -> true) arity
   then
     Misc.fatal_error
       "tuplify_function is currently unsupported if arity contains non-values";
@@ -2538,7 +2543,11 @@ let tuplify_function arity return =
       get_field_gen Asttypes.Mutable (Cvar arg) i (dbg ())
       :: access_components (i + 1)
   in
-  let fun_name = "caml_tuplify" ^ Int.to_string arity in
+  let fun_name =
+    "caml_tuplify" ^ Int.to_string arity
+    ^
+    match return with [| Val |] -> "" | _ -> "_R" ^ machtype_identifier return
+  in
   let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in
   Cfunction
     { fun_name;

middle_end/flambda2/to_cmm/to_cmm_env.ml

@@ -360,7 +360,7 @@ let add_exn_handler env k arity =
   let env =
     { env with exn_handlers = Continuation.Set.add k env.exn_handlers }
   in
-  match Flambda_arity.to_list arity with
+  match Flambda_arity.With_subkinds.to_list arity with
   | [] -> Misc.fatal_error "Exception handlers must have at least one parameter"
   | [_] -> env, []
   | _ :: extra_args ->

middle_end/flambda2/to_cmm/to_cmm_env.mli

@@ -325,8 +325,8 @@ val add_inline_cont :
 val add_exn_handler :
   t ->
   Continuation.t ->
-  Flambda_arity.t ->
-  t * (Backend_var.t * Flambda_kind.t) list
+  Flambda_arity.With_subkinds.t ->
+  t * (Backend_var.t * Flambda_kind.With_subkind.t) list
 
 (** Return whether the given continuation has been registered as an exception
     handler. *)

middle_end/flambda2/to_cmm/to_cmm_expr.ml

@@ -94,12 +94,9 @@ let translate_apply0 ~dbg_with_inlined:dbg env res apply =
     | Nontail -> Lambda.Rc_nontail
   in
   let args_arity =
-    Apply.args_arity apply |> Flambda_arity.With_subkinds.to_arity
-    |> Flambda_arity.to_list
-  in
-  let return_arity =
-    Apply.return_arity apply |> Flambda_arity.With_subkinds.to_arity
+    Apply.args_arity apply |> Flambda_arity.With_subkinds.to_list
   in
+  let return_arity = Apply.return_arity apply in
   let args_ty = List.map C.machtype_of_kind args_arity in
   let return_ty = C.machtype_of_return_arity return_arity in
   match Apply.call_kind apply with
@@ -167,14 +164,14 @@ let translate_apply0 ~dbg_with_inlined:dbg env res apply =
     in
     let returns = Apply.returns apply in
     let wrap =
-      match Flambda_arity.to_list return_arity with
+      match Flambda_arity.With_subkinds.to_list return_arity with
       (* Returned int32 values need to be sign_extended because it's not clear
          whether C code that returns an int32 returns one that is sign extended
          or not. There is no need to wrap other return arities. Note that
          extcalls of arity 0 are allowed (these never return). *)
       | [] -> fun _dbg cmm -> cmm
       | [kind] -> (
-        match kind with
+        match Flambda_kind.With_subkind.kind kind with
         | Naked_number Naked_int32 -> C.sign_extend_32
         | Naked_number
             (Naked_float | Naked_immediate | Naked_int64 | Naked_nativeint)
@@ -614,21 +611,21 @@ and let_cont_exn_handler env res k body vars handler free_vars_of_handler
   (* Define and initialize the mutable Cmm variables for extra args *)
   let cmm =
     List.fold_left
-      (fun cmm (mut_var, (kind : K.t)) ->
+      (fun cmm (mut_var, kind) ->
         (* CR mshinwell: Fix [provenance] *)
         let mut_var =
           Backend_var.With_provenance.create ?provenance:None mut_var
         in
         let dummy_value =
-          match kind with
+          match K.With_subkind.kind kind with
           | Value -> C.int ~dbg 1
           | Naked_number Naked_float -> C.float ~dbg 0.
           | Naked_number
               (Naked_immediate | Naked_int32 | Naked_int64 | Naked_nativeint) ->
             C.int ~dbg 0
           | Region | Rec_info ->
-            Misc.fatal_errorf "No dummy value available for kind %a" K.print
-              kind
+            Misc.fatal_errorf "No dummy value available for kind %a"
+              K.With_subkind.print kind
         in
         C.letin_mut mut_var (C.machtype_of_kind kind) dummy_value cmm)
       trywith mut_vars
@@ -698,7 +695,7 @@ and let_cont_rec env res invariant_params conts body =
 and continuation_handler env res handler =
   Continuation_handler.pattern_match' handler
     ~f:(fun params ~num_normal_occurrences_of_params:_ ~handler ->
-      let arity = Bound_parameters.arity params in
+      let arity = Bound_parameters.arity_with_subkinds params in
       let env, vars = C.bound_parameters env params in
       let expr, free_vars_of_handler, res = expr env res handler in
       vars, arity, expr, free_vars_of_handler, res)

middle_end/flambda2/to_cmm/to_cmm_set_of_closures.ml

@@ -39,12 +39,11 @@ let get_func_decl_params_arity t code_id =
   let info = Env.get_code_metadata t code_id in
   let params_ty =
     List.map
-      (fun k -> C.machtype_of_kind (Flambda_kind.With_subkind.kind k))
+      (fun k -> C.machtype_of_kind k)
       (Flambda_arity.With_subkinds.to_list (Code_metadata.params_arity info))
   in
   let result_ty =
-    C.machtype_of_return_arity
-      (Flambda_arity.With_subkinds.to_arity (Code_metadata.result_arity info))
+    C.machtype_of_return_arity (Code_metadata.result_arity info)
   in
   let kind : Lambda.function_kind =
     if Code_metadata.is_tupled info

middle_end/flambda2/to_cmm/to_cmm_shared.ml

@@ -39,9 +39,15 @@ let exttype_of_kind (k : Flambda_kind.t) : Cmm.exttype =
   | Region -> Misc.fatal_error "[Region] kind not expected here"
   | Rec_info -> Misc.fatal_error "[Rec_info] kind not expected here"
 
-let machtype_of_kind (k : Flambda_kind.t) =
-  match k with
-  | Value -> Cmm.typ_val
+let machtype_of_kind (kind : Flambda_kind.With_subkind.t) =
+  match Flambda_kind.With_subkind.kind kind with
+  | Value -> (
+    match Flambda_kind.With_subkind.subkind kind with
+    | Tagged_immediate -> Cmm.typ_int
+    | Anything | Boxed_float | Boxed_int32 | Boxed_int64 | Boxed_nativeint
+    | Variant _ | Float_block _ | Float_array | Immediate_array | Value_array
+    | Generic_array ->
+      Cmm.typ_val)
   | Naked_number Naked_float -> Cmm.typ_float
   | Naked_number Naked_int64 -> typ_int64
   | Naked_number (Naked_immediate | Naked_int32 | Naked_nativeint) ->
@@ -66,8 +72,7 @@ let memory_chunk_of_kind (kind : Flambda_kind.With_subkind.t) : Cmm.memory_chunk
     Misc.fatal_errorf "Bad kind %a for [memory_chunk_of_kind]"
       Flambda_kind.With_subkind.print kind
 
-let machtype_of_kinded_parameter p =
-  Bound_parameter.kind p |> Flambda_kind.With_subkind.kind |> machtype_of_kind
+let machtype_of_kinded_parameter p = Bound_parameter.kind p |> machtype_of_kind
 
 let targetint ~dbg t =
   match Targetint_32_64.repr t with
@@ -237,7 +242,7 @@ let machtype_of_return_arity arity =
   (* Functions that never return have arity 0. In that case, we use the most
      restrictive machtype to ensure that the return value of the function is not
      used. *)
-  match Flambda_arity.to_list arity with
+  match Flambda_arity.With_subkinds.to_list arity with
   | [] -> Cmm.typ_void
   (* Regular functions with a single return value *)
   | [k] -> machtype_of_kind k

middle_end/flambda2/to_cmm/to_cmm_shared.mli

@@ -26,7 +26,8 @@ val remove_vars_with_machtype :
 
 val exttype_of_kind : Flambda_kind.t -> Cmm.exttype
 
-val machtype_of_kind : Flambda_kind.t -> Cmm.machtype_component array
+val machtype_of_kind :
+  Flambda_kind.With_subkind.t -> Cmm.machtype_component array
 
 val machtype_of_kinded_parameter :
   Bound_parameter.t -> Cmm.machtype_component array
@@ -101,4 +102,4 @@ val make_update :
 
 val check_arity : Flambda_arity.With_subkinds.t -> _ list -> bool
 
-val machtype_of_return_arity : Flambda_arity.t -> Cmm.machtype
+val machtype_of_return_arity : Flambda_arity.With_subkinds.t -> Cmm.machtype