to_cmm: do not fail on recinfo continuation parameters

middle_end/flambda2/to_cmm/to_cmm.ml

@@ -78,7 +78,7 @@ let unit0 ~offsets ~all_code ~reachable_names flambda_unit =
   let _env, return_cont_params =
     (* The environment is dropped because the handler for the dummy continuation
        (which just returns unit) doesn't use any of the parameters. *)
-    C.bound_parameters env
+    C.continuation_bound_parameters env
       (Bound_parameters.create
          [ Bound_parameter.create (Variable.create "*ret*")
              Flambda_kind.With_subkind.any_value ])
@@ -113,7 +113,10 @@ let unit0 ~offsets ~all_code ~reachable_names flambda_unit =
   let body =
     let unit_value = C.targetint ~dbg Targetint_32_64.one in
     C.create_ccatch ~rec_flag:false ~body
-      ~handlers:[C.handler ~dbg return_cont return_cont_params unit_value false]
+      ~handlers:
+        [ C.handler ~dbg return_cont
+            (C.actual_params return_cont_params)
+            unit_value false ]
   in
   let body =
     if !Clflags.afl_instrument

middle_end/flambda2/to_cmm/to_cmm_env.ml

@@ -26,10 +26,14 @@ type expr_with_info =
     free_vars : free_vars
   }
 
+type 'a param_type =
+  | Param of 'a
+  | Skip_param
+
 type cont =
   | Jump of
       { cont : Lambda.static_label;
-        param_types : Cmm.machtype list
+        param_types : Cmm.machtype param_type list
       }
   | Inline of
       { handler_params : Bound_parameters.t;
@@ -167,6 +171,10 @@ type translation_result =
 
 (* Printing *)
 
+let print_param_type print_typ ppf = function
+  | Param typ -> print_typ ppf typ
+  | Skip_param -> Format.fprintf ppf "skip"
+
 let print_extra_info ppf = function
   | Untag e -> Format.fprintf ppf "Untag(%a)" Printcmm.expression e
 

middle_end/flambda2/to_cmm/to_cmm_env.mli

@@ -290,13 +290,19 @@ val extra_info : t -> Simple.t -> extra_info option
 
 (** {2 Continuation bindings} *)
 
+(** Param types: some parameters might be skipped: for instance parameters
+    of kind [Rec_info] are meant to be removed during to_cmm translation. *)
+type 'a param_type =
+  | Param of 'a
+  | Skip_param
+
 (** Translation information for continuations. A continuation may either be
     translated as a static jump to a Cmm continuation (represented as a Cmm
     label), or inlined at any unique use site. *)
 type cont = private
   | Jump of
       { cont : Lambda.static_label;
-        param_types : Cmm.machtype list
+        param_types : Cmm.machtype param_type list
       }
   | Inline of
       { handler_params : Bound_parameters.t;
@@ -310,7 +316,7 @@ type cont = private
 val add_jump_cont :
   t ->
   Continuation.t ->
-  param_types:Cmm.machtype list ->
+  param_types:Cmm.machtype param_type list ->
   Lambda.static_label * t
 
 (** Record that the given continuation should be inlined. *)
@@ -347,3 +353,7 @@ val get_continuation : t -> Continuation.t -> cont
     fatal error if given an unbound continuation, or a continuation that was
     registered (using [add_inline_cont]) to be inlined. *)
 val get_cmm_continuation : t -> Continuation.t -> Lambda.static_label
+
+(** print function *)
+val print_param_type :
+  (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a param_type -> unit

middle_end/flambda2/to_cmm/to_cmm_expr.ml

@@ -401,13 +401,15 @@ let translate_jump_to_continuation ~dbg_with_inlined:dbg env res apply types
         let cont = Env.get_cmm_continuation env exn_handler in
         [Cmm.Push cont]
     in
+    let args = C.actual_args args types in
     let args, free_vars, env, res, _ = C.simple_list ~dbg env res args in
     let wrap, _, res = Env.flush_delayed_lets ~mode:Branching_point env res in
     let cmm, free_vars = wrap (C.cexit cont args trap_actions) free_vars in
     cmm, free_vars, res
   else
     Misc.fatal_errorf "Types (%a) do not match arguments of@ %a"
-      (Format.pp_print_list ~pp_sep:Format.pp_print_space Printcmm.machtype)
+      (Format.pp_print_list ~pp_sep:Format.pp_print_space
+         (To_cmm_env.print_param_type Printcmm.machtype))
       types Apply_cont.print apply
 
 (* A call to the return continuation of the current block simply is the return
@@ -643,7 +645,8 @@ and let_cont_not_inlined env res k handler body =
           (C.remove_vars_with_machtype free_vars_of_handler vars)
       in
       ( C.create_ccatch ~rec_flag:false ~body
-          ~handlers:[C.handler ~dbg catch_id vars handler is_cold],
+          ~handlers:
+            [C.handler ~dbg catch_id (C.actual_params vars) handler is_cold],
         free_vars,
         res )
   in
@@ -733,15 +736,17 @@ and let_cont_rec env res invariant_params conts body =
         let continuation_arg_tys =
           Continuation_handler.pattern_match' handler
             ~f:(fun params ~num_normal_occurrences_of_params:_ ~handler:_ ->
-              List.map C.machtype_of_kinded_parameter
+              List.map C.param_machtype_of_kinded_parameter
                 (Bound_parameters.to_list
                    (Bound_parameters.append invariant_params params)))
         in
         snd (Env.add_jump_cont acc k ~param_types:continuation_arg_tys))
       conts_to_handlers env
   in
   (* Generate variables for the invariant params *)
-  let env, invariant_vars = C.bound_parameters env invariant_params in
+  let env, invariant_vars =
+    C.continuation_bound_parameters env invariant_params
+  in
   (* Translate each continuation handler *)
   let conts_to_handlers, res =
     Continuation.Map.fold
@@ -770,7 +775,8 @@ and let_cont_rec env res invariant_params conts body =
             (C.remove_vars_with_machtype free_vars_of_handler vars)
         in
         let id = Env.get_cmm_continuation env k in
-        C.handler ~dbg id vars handler false :: handlers, free_vars)
+        ( C.handler ~dbg id (C.actual_params vars) handler false :: handlers,
+          free_vars ))
       conts_to_handlers ([], free_vars_of_body)
   in
   let cmm = C.create_ccatch ~rec_flag:true ~body ~handlers in
@@ -781,7 +787,7 @@ 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 env, vars = C.bound_parameters env params in
+      let env, vars = C.continuation_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)
 
@@ -918,10 +924,18 @@ and apply_cont env res apply_cont =
       then
         let env, res =
           List.fold_left2
-            (fun (env, res) param ->
-              bind_var_to_simple ~dbg_with_inlined env res
-                (Bound_parameter.var param)
-                ~num_normal_occurrences_of_bound_vars:handler_params_occurrences)
+            (fun (env, res) param arg ->
+              match[@ocaml.warning "-4"]
+                Flambda_kind.With_subkind.kind (Bound_parameter.kind param)
+              with
+              | Rec_info ->
+                (* Skip depth variables/parameters *)
+                env, res
+              | _ ->
+                bind_var_to_simple ~dbg_with_inlined env res
+                  (Bound_parameter.var param)
+                  ~num_normal_occurrences_of_bound_vars:
+                    handler_params_occurrences arg)
             (env, res) handler_params args
         in
         let env =

middle_end/flambda2/to_cmm/to_cmm_primitive.ml

@@ -698,14 +698,7 @@ let unary_primitive env res dbg f arg =
     let extra, expr = arithmetic_conversion dbg src dst arg in
     extra, res, expr
   | Boolean_not -> None, res, C.mk_not dbg arg
-  | Reinterpret_int64_as_float ->
-    (* Will be translated to MOVQ by backend/amd64/selection.ml. *)
-    ( None,
-      res,
-      C.extcall ~dbg ~alloc:false ~returns:true ~is_c_builtin:false
-        ~effects:Arbitrary_effects ~coeffects:Has_coeffects
-        ~ty_args:[C.exttype_of_kind K.naked_int64]
-        "caml_int64_float_of_bits_unboxed" Cmm.typ_float [arg] )
+  | Reinterpret_int64_as_float -> None, res, C.int64_as_float ~dbg arg
   | Unbox_number kind -> None, res, unbox_number ~dbg kind arg
   | Untag_immediate -> Some (Env.Untag arg), res, C.untag_int arg dbg
   | Box_number (kind, alloc_mode) ->

middle_end/flambda2/to_cmm/to_cmm_set_of_closures.ml

@@ -384,7 +384,7 @@ let params_and_body0 env res code_id ~fun_dbg ~zero_alloc_attribute
      and refuse to compile the code. *)
   let env, my_region_var = Env.create_bound_parameter env my_region in
   (* Translate the arg list and body *)
-  let env, fun_params = C.bound_parameters env params in
+  let env, fun_params = C.function_bound_parameters env params in
   let fun_body, fun_body_free_vars, res = translate_expr env res body in
   let fun_free_vars =
     C.remove_vars_with_machtype

middle_end/flambda2/to_cmm/to_cmm_shared.ml

@@ -16,6 +16,22 @@ open! Cmm_helpers
 open! Cmm_builtins
 module Ece = Effects_and_coeffects
 
+let actual_params params_with_types =
+  List.filter_map
+    (fun (v, param_type) ->
+      match (param_type : Cmm.machtype To_cmm_env.param_type) with
+      | Skip_param -> None
+      | Param machtype -> Some (v, machtype))
+    params_with_types
+
+let rec actual_args args param_types =
+  match args, (param_types : _ To_cmm_env.param_type list) with
+  | [], [] -> []
+  | _ :: r, Skip_param :: r' -> actual_args r r'
+  | arg :: r, Param _ :: r' -> arg :: actual_args r r'
+  | _ :: _, [] | [], _ :: _ ->
+    Misc.fatal_errorf "Mismatched list sizes in To_cmm_shared.actual_args"
+
 let remove_var_with_provenance free_vars var =
   let v = Backend_var.With_provenance.var var in
   Backend_var.Set.remove v free_vars
@@ -58,7 +74,8 @@ let machtype_of_kind (kind : Flambda_kind.With_subkind.t) =
   | Naked_number (Naked_immediate | Naked_int32 | Naked_int64 | Naked_nativeint)
     ->
     Cmm.typ_int
-  | Region | Rec_info -> assert false
+  | Region -> Cmm.typ_int
+  | Rec_info -> Misc.fatal_error "[Rec_info] kind not expected here"
 
 let extended_machtype_of_kind (kind : Flambda_kind.With_subkind.t) =
   match Flambda_kind.With_subkind.kind kind with
@@ -77,7 +94,8 @@ let extended_machtype_of_kind (kind : Flambda_kind.With_subkind.t) =
   | Naked_number (Naked_immediate | Naked_int32 | Naked_int64 | Naked_nativeint)
     ->
     Extended_machtype.typ_any_int
-  | Region | Rec_info -> assert false
+  | Region -> Misc.fatal_error "[Region] kind not expected here"
+  | Rec_info -> Misc.fatal_error "[Rec_info] kind not expected here"
 
 let memory_chunk_of_kind (kind : Flambda_kind.With_subkind.t) : Cmm.memory_chunk
     =
@@ -107,6 +125,12 @@ let memory_chunk_of_kind (kind : Flambda_kind.With_subkind.t) : Cmm.memory_chunk
 
 let machtype_of_kinded_parameter p = Bound_parameter.kind p |> machtype_of_kind
 
+let param_machtype_of_kinded_parameter bp : _ To_cmm_env.param_type =
+  let k = Bound_parameter.kind bp in
+  match[@ocaml.warning "-4"] Flambda_kind.With_subkind.kind k with
+  | Rec_info -> Skip_param
+  | _ -> Param (machtype_of_kind k)
+
 let targetint ~dbg t =
   match Targetint_32_64.repr t with
   | Int32 i -> int32 ~dbg i
@@ -225,17 +249,20 @@ let simple_list ?consider_inlining_effectful_expressions ~dbg env res l =
   in
   List.rev args, free_vars, env, res, effs
 
-let bound_parameters env l =
+let bound_parameters_aux ~f env l =
   let flambda_vars = Bound_parameters.vars l in
   let env, cmm_vars = To_cmm_env.create_bound_parameters env flambda_vars in
   let vars =
-    List.map2
-      (fun v v' -> v, machtype_of_kinded_parameter v')
-      cmm_vars
-      (Bound_parameters.to_list l)
+    List.map2 (fun v v' -> v, f v') cmm_vars (Bound_parameters.to_list l)
   in
   env, vars
 
+let continuation_bound_parameters env l =
+  bound_parameters_aux ~f:param_machtype_of_kinded_parameter env l
+
+let function_bound_parameters env l =
+  bound_parameters_aux ~f:machtype_of_kinded_parameter env l
+
 let invalid res ~message =
   let dbg = Debuginfo.none in
   let message_sym, res =

middle_end/flambda2/to_cmm/to_cmm_shared.mli

@@ -16,12 +16,18 @@
     this module, unlike the ones in [Cmm_helpers], depend on Flambda 2 data
     types. *)
 
+val actual_params :
+  (Backend_var.With_provenance.t * Cmm.machtype To_cmm_env.param_type) list ->
+  (Backend_var.With_provenance.t * Cmm.machtype) list
+
+val actual_args : 'a list -> _ To_cmm_env.param_type list -> 'a list
+
 val remove_var_with_provenance :
   To_cmm_env.free_vars -> Backend_var.With_provenance.t -> To_cmm_env.free_vars
 
 val remove_vars_with_machtype :
   To_cmm_env.free_vars ->
-  (Backend_var.With_provenance.t * Cmm.machtype) list ->
+  (Backend_var.With_provenance.t * _) list ->
   To_cmm_env.free_vars
 
 val exttype_of_kind : Flambda_kind.t -> Cmm.exttype
@@ -33,6 +39,9 @@ val extended_machtype_of_kind :
 
 val machtype_of_kinded_parameter : Bound_parameter.t -> Cmm.machtype
 
+val param_machtype_of_kinded_parameter :
+  Bound_parameter.t -> Cmm.machtype To_cmm_env.param_type
+
 val memory_chunk_of_kind : Flambda_kind.With_subkind.t -> Cmm.memory_chunk
 
 (** Create a constant int expression from a targetint. *)
@@ -78,7 +87,13 @@ val simple_list :
   * To_cmm_result.t
   * Effects_and_coeffects.t
 
-val bound_parameters :
+val continuation_bound_parameters :
+  To_cmm_env.t ->
+  Bound_parameters.t ->
+  To_cmm_env.t
+  * (Backend_var.With_provenance.t * Cmm.machtype To_cmm_env.param_type) list
+
+val function_bound_parameters :
   To_cmm_env.t ->
   Bound_parameters.t ->
   To_cmm_env.t * (Backend_var.With_provenance.t * Cmm.machtype) list