From cd9cdacd7205742ff8a5e7e37d6aef1c24e00ace Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nathana=C3=ABlle=20Courant?= Date: Mon, 27 May 2024 16:57:25 +0200 Subject: [PATCH] to_cmm: do not fail on recinfo continuation parameters --- middle_end/flambda2/to_cmm/to_cmm.ml | 7 +++- middle_end/flambda2/to_cmm/to_cmm_env.ml | 10 ++++- middle_end/flambda2/to_cmm/to_cmm_env.mli | 14 ++++++- middle_end/flambda2/to_cmm/to_cmm_expr.ml | 34 ++++++++++----- .../flambda2/to_cmm/to_cmm_primitive.ml | 9 +--- .../flambda2/to_cmm/to_cmm_set_of_closures.ml | 2 +- middle_end/flambda2/to_cmm/to_cmm_shared.ml | 41 +++++++++++++++---- middle_end/flambda2/to_cmm/to_cmm_shared.mli | 19 ++++++++- 8 files changed, 103 insertions(+), 33 deletions(-) diff --git a/middle_end/flambda2/to_cmm/to_cmm.ml b/middle_end/flambda2/to_cmm/to_cmm.ml index 1da56e8e991..7c3647e11e6 100644 --- a/middle_end/flambda2/to_cmm/to_cmm.ml +++ b/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 diff --git a/middle_end/flambda2/to_cmm/to_cmm_env.ml b/middle_end/flambda2/to_cmm/to_cmm_env.ml index 74c3a7bc886..8a73bf6b17d 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_env.ml +++ b/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 diff --git a/middle_end/flambda2/to_cmm/to_cmm_env.mli b/middle_end/flambda2/to_cmm/to_cmm_env.mli index cc512450b46..be25759a506 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_env.mli +++ b/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 diff --git a/middle_end/flambda2/to_cmm/to_cmm_expr.ml b/middle_end/flambda2/to_cmm/to_cmm_expr.ml index de0141c4edf..e29c29b0587 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_expr.ml +++ b/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,7 +736,7 @@ 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 @@ -741,7 +744,9 @@ and let_cont_rec env res invariant_params conts body = 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 = diff --git a/middle_end/flambda2/to_cmm/to_cmm_primitive.ml b/middle_end/flambda2/to_cmm/to_cmm_primitive.ml index 94f0354a1cf..328e826a3b8 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_primitive.ml +++ b/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) -> diff --git a/middle_end/flambda2/to_cmm/to_cmm_set_of_closures.ml b/middle_end/flambda2/to_cmm/to_cmm_set_of_closures.ml index 3e8d7d226a2..c547d1da608 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_set_of_closures.ml +++ b/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 diff --git a/middle_end/flambda2/to_cmm/to_cmm_shared.ml b/middle_end/flambda2/to_cmm/to_cmm_shared.ml index 6eca29a4713..81f5dc6b4d4 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_shared.ml +++ b/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 = diff --git a/middle_end/flambda2/to_cmm/to_cmm_shared.mli b/middle_end/flambda2/to_cmm/to_cmm_shared.mli index 42a05ee1fdd..60997ddfe42 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_shared.mli +++ b/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