From 373f8dccb0b634cd33ba87aa847d6c386f540c67 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nathana=C3=ABlle=20Courant?= Date: Fri, 4 Apr 2025 10:49:21 +0200 Subject: [PATCH 1/5] remove subkind from value slot --- .../from_lambda/closure_conversion.ml | 12 ++++++++---- .../flambda2/from_lambda/lambda_to_flambda.ml | 4 ++-- middle_end/flambda2/identifiers/slot.ml | 10 ++++------ middle_end/flambda2/identifiers/slot.mli | 5 ++--- .../flambda2/parser/fexpr_to_flambda.ml | 7 +++---- .../flambda2/parser/flambda_to_fexpr.ml | 5 +---- .../flambda2/simplify/simplify_apply_expr.ml | 10 ++++------ .../simplify/simplify_set_of_closures.ml | 2 +- .../simplify/simplify_unary_primitive.ml | 8 ++++---- .../simplify/unboxing/build_unboxing_denv.ml | 2 +- .../flambda2/simplify/unboxing/unboxers.ml | 5 +---- .../flambda2/simplify_shared/slot_offsets.ml | 9 ++------- .../flambda2/terms/flambda_primitive.ml | 2 +- .../flambda2/to_cmm/to_cmm_primitive.ml | 4 +++- .../flambda2/to_cmm/to_cmm_set_of_closures.ml | 19 +++++-------------- middle_end/flambda2/types/flambda2_types.mli | 4 ++-- .../types/grammar/more_type_creators.ml | 4 +--- .../types/grammar/more_type_creators.mli | 4 ++-- middle_end/flambda2/types/provers.ml | 4 +--- 19 files changed, 48 insertions(+), 72 deletions(-) diff --git a/middle_end/flambda2/from_lambda/closure_conversion.ml b/middle_end/flambda2/from_lambda/closure_conversion.ml index 31a548c0737..a810e8ddd95 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion.ml @@ -2627,7 +2627,10 @@ let close_functions acc external_env ~current_region function_declarations = | None -> Ident.name id | Some var -> Variable.name var in - Ident.Map.add id (Value_slot.create compilation_unit ~name kind) map) + Ident.Map.add id + (Value_slot.create compilation_unit ~name + (Flambda_kind.With_subkind.kind kind)) + map) (Function_decls.all_free_idents function_declarations) Ident.Map.empty in @@ -2774,10 +2777,11 @@ let close_functions acc external_env ~current_region function_declarations = let external_simple, kind' = find_simple_from_id_with_kind external_env id in - if not (K.With_subkind.equal kind kind') + if not (K.equal kind (K.With_subkind.kind kind')) then Misc.fatal_errorf "Value slot kinds %a and %a don't match for slot %a" - K.With_subkind.print kind K.With_subkind.print kind' + K.print kind K.print + (K.With_subkind.kind kind') Value_slot.print value_slot; (* We're sure [external_simple] is a variable since [value_slot_from_idents] has already filtered constants and symbols @@ -2946,7 +2950,7 @@ let wrap_partial_application acc env apply_continuation (apply : IR.apply) let function_slot = Function_slot.create (Compilation_unit.get_current_exn ()) - ~name:(Ident.name wrapper_id) K.With_subkind.any_value + ~name:(Ident.name wrapper_id) K.value in let num_provided = Flambda_arity.num_params provided_arity in let missing_arity_and_param_modes = diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml index 5f058a77ebd..72c92107528 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml @@ -1353,7 +1353,7 @@ and cps_function env ~fid ~(recursive : Recursive.t) ?precomputed_free_idents Function_slot.create (Compilation_unit.get_current_exn ()) ~name:(Ident.name fid ^ "_unboxed") - Flambda_kind.With_subkind.any_value + Flambda_kind.value in let unboxed_return = if attr.unbox_return then unboxing_kind return else None @@ -1424,7 +1424,7 @@ and cps_function env ~fid ~(recursive : Recursive.t) ?precomputed_free_idents let function_slot = Function_slot.create (Compilation_unit.get_current_exn ()) - ~name:(Ident.name fid) Flambda_kind.With_subkind.any_value + ~name:(Ident.name fid) Flambda_kind.value in let unboxed_products = ref Ident.Map.empty in let params = diff --git a/middle_end/flambda2/identifiers/slot.ml b/middle_end/flambda2/identifiers/slot.ml index 7e44997a516..65ea27e4780 100644 --- a/middle_end/flambda2/identifiers/slot.ml +++ b/middle_end/flambda2/identifiers/slot.ml @@ -19,8 +19,7 @@ module type S = sig module Lmap : Lmap.S with type key = t - val create : - Compilation_unit.t -> name:string -> Flambda_kind.With_subkind.t -> t + val create : Compilation_unit.t -> name:string -> Flambda_kind.t -> t val get_compilation_unit : t -> Compilation_unit.t @@ -32,7 +31,7 @@ module type S = sig val name : t -> string - val kind : t -> Flambda_kind.With_subkind.t + val kind : t -> Flambda_kind.t val rename : t -> t end @@ -45,7 +44,7 @@ end) : S = struct name : string; name_stamp : int; (** [name_stamp]s are unique within any given compilation unit. *) - kind : Flambda_kind.With_subkind.t + kind : Flambda_kind.t } module Self = Container_types.Make (struct @@ -83,8 +82,7 @@ end) : S = struct else Format.fprintf ppf "%a.%s/%d" Compilation_unit.print t.compilation_unit t.name t.name_stamp; - Format.fprintf ppf " @<1>\u{2237} %a" Flambda_kind.With_subkind.print - t.kind; + Format.fprintf ppf " @<1>\u{2237} %a" Flambda_kind.print t.kind; Format.fprintf ppf ")%t@]" Flambda_colours.pop end) diff --git a/middle_end/flambda2/identifiers/slot.mli b/middle_end/flambda2/identifiers/slot.mli index ce978414260..5846777f8b7 100644 --- a/middle_end/flambda2/identifiers/slot.mli +++ b/middle_end/flambda2/identifiers/slot.mli @@ -19,8 +19,7 @@ module type S = sig module Lmap : Lmap.S with type key = t - val create : - Compilation_unit.t -> name:string -> Flambda_kind.With_subkind.t -> t + val create : Compilation_unit.t -> name:string -> Flambda_kind.t -> t val get_compilation_unit : t -> Compilation_unit.t @@ -32,7 +31,7 @@ module type S = sig val name : t -> string - val kind : t -> Flambda_kind.With_subkind.t + val kind : t -> Flambda_kind.t val rename : t -> t end diff --git a/middle_end/flambda2/parser/fexpr_to_flambda.ml b/middle_end/flambda2/parser/fexpr_to_flambda.ml index ef4b791bc9e..9bbeef93b95 100644 --- a/middle_end/flambda2/parser/fexpr_to_flambda.ml +++ b/middle_end/flambda2/parser/fexpr_to_flambda.ml @@ -144,7 +144,7 @@ let fresh_function_slot env { Fexpr.txt = name; loc = _ } = let c = Function_slot.create (Compilation_unit.get_current_exn ()) - ~name Flambda_kind.With_subkind.any_value + ~name Flambda_kind.value in UT.add env.function_slots name c; c @@ -436,7 +436,7 @@ let unop env (unop : Fexpr.unop) : Flambda_primitive.unary_primitive = Opaque_identity { middle_end_only = false; kind = Flambda_kind.value } | Project_value_slot { project_from; value_slot } -> (* CR mshinwell: support non-value kinds *) - let kind = Flambda_kind.With_subkind.any_value in + let kind = Flambda_kind.value in let value_slot = fresh_or_existing_value_slot env value_slot kind in let project_from = fresh_or_existing_function_slot env project_from in Project_value_slot { project_from; value_slot } @@ -562,8 +562,7 @@ let set_of_closures env fun_decls value_slots alloc = let value_slots : Simple.t Value_slot.Map.t = let convert ({ var; value } : Fexpr.one_value_slot) = (* CR mshinwell: support non-value kinds *) - ( fresh_or_existing_value_slot env var Flambda_kind.With_subkind.any_value, - simple env value ) + fresh_or_existing_value_slot env var Flambda_kind.value, simple env value in List.map convert value_slots |> Value_slot.Map.of_list in diff --git a/middle_end/flambda2/parser/flambda_to_fexpr.ml b/middle_end/flambda2/parser/flambda_to_fexpr.ml index 688aaec94e7..75836ad1d50 100644 --- a/middle_end/flambda2/parser/flambda_to_fexpr.ml +++ b/middle_end/flambda2/parser/flambda_to_fexpr.ml @@ -676,10 +676,7 @@ let value_slots env map = List.map (fun (var, value) -> let kind = Value_slot.kind var in - if not - (Flambda_kind.equal - (Flambda_kind.With_subkind.kind kind) - Flambda_kind.value) + if not (Flambda_kind.equal kind Flambda_kind.value) then Misc.fatal_errorf "Value slot %a not of kind Value" Simple.print value; let var = Env.translate_value_slot env var in diff --git a/middle_end/flambda2/simplify/simplify_apply_expr.ml b/middle_end/flambda2/simplify/simplify_apply_expr.ml index 02a405623ea..f362d56e787 100644 --- a/middle_end/flambda2/simplify/simplify_apply_expr.ml +++ b/middle_end/flambda2/simplify/simplify_apply_expr.ml @@ -417,15 +417,14 @@ let simplify_direct_partial_application ~simplify_expr dacc apply in let applied_unarized_args, _ = Misc.Stdlib.List.map2_prefix - (fun arg kind -> arg, kind) + (fun arg kind -> arg, K.With_subkind.kind kind) args (Flambda_arity.unarize param_arity) in let wrapper_var = Variable.create "partial_app" in let compilation_unit = Compilation_unit.get_current_exn () in let wrapper_function_slot = - Function_slot.create compilation_unit ~name:"partial_app_closure" - K.With_subkind.any_value + Function_slot.create compilation_unit ~name:"partial_app_closure" K.value in (* The allocation mode of the closure is directly determined by the alloc_mode of the application. We check here that it is consistent with @@ -517,7 +516,7 @@ let simplify_direct_partial_application ~simplify_expr dacc apply then Symbol symbol else let var = Variable.create "symbol" in - if not (K.equal (K.With_subkind.kind kind) K.value) + if not (K.equal kind K.value) then Misc.fatal_errorf "Simple %a which is a symbol should be of kind Value" @@ -529,8 +528,7 @@ let simplify_direct_partial_application ~simplify_expr dacc apply let applied_callee = match Apply.callee apply with | None -> None - | Some callee -> - Some (applied_value (callee, K.With_subkind.any_value)) + | Some callee -> Some (applied_value (callee, K.value)) in let applied_unarized_args = List.map applied_value applied_unarized_args diff --git a/middle_end/flambda2/simplify/simplify_set_of_closures.ml b/middle_end/flambda2/simplify/simplify_set_of_closures.ml index 7b0b12376a8..08ea8166b5c 100644 --- a/middle_end/flambda2/simplify/simplify_set_of_closures.ml +++ b/middle_end/flambda2/simplify/simplify_set_of_closures.ml @@ -682,7 +682,7 @@ let simplify_and_lift_set_of_closures dacc ~closure_bound_vars_inverse let value_slot_types = Value_slot.Map.mapi (fun value_slot in_slot -> - let kind = K.With_subkind.kind (Value_slot.kind value_slot) in + let kind = Value_slot.kind value_slot in Simple.pattern_match in_slot ~const:(fun _ -> T.alias_type_of kind in_slot) ~name:(fun name ~coercion -> diff --git a/middle_end/flambda2/simplify/simplify_unary_primitive.ml b/middle_end/flambda2/simplify/simplify_unary_primitive.ml index 99a4257d065..e600f17e98b 100644 --- a/middle_end/flambda2/simplify/simplify_unary_primitive.ml +++ b/middle_end/flambda2/simplify/simplify_unary_primitive.ml @@ -69,8 +69,7 @@ let simplify_project_value_slot function_slot value_slot ~min_name_mode dacc simple in let dacc = - DA.add_variable dacc result_var - (T.alias_type_of (K.With_subkind.kind kind) simple) + DA.add_variable dacc result_var (T.alias_type_of kind simple) in SPR.create (Named.create_simple simple) ~try_reify:true dacc | Need_meet -> @@ -81,7 +80,7 @@ let simplify_project_value_slot function_slot value_slot ~min_name_mode dacc (T.closure_with_at_least_this_value_slot ~this_function_slot:function_slot value_slot ~value_slot_var:(Bound_var.var result_var) ~value_slot_kind:kind) - ~result_var ~result_kind:(K.With_subkind.kind kind) + ~result_var ~result_kind:kind in let dacc = DA.add_use_of_value_slot result.dacc value_slot in SPR.with_dacc result dacc @@ -89,7 +88,8 @@ let simplify_project_value_slot function_slot value_slot ~min_name_mode dacc let dacc = Simplify_common.add_symbol_projection result.dacc ~projected_from:closure (Symbol_projection.Projection.project_value_slot function_slot value_slot) - ~projection_bound_to:result_var ~kind + ~projection_bound_to:result_var + ~kind:(Flambda_kind.With_subkind.anything kind) in SPR.with_dacc result dacc diff --git a/middle_end/flambda2/simplify/unboxing/build_unboxing_denv.ml b/middle_end/flambda2/simplify/unboxing/build_unboxing_denv.ml index 6171a115467..425d86b3157 100644 --- a/middle_end/flambda2/simplify/unboxing/build_unboxing_denv.ml +++ b/middle_end/flambda2/simplify/unboxing/build_unboxing_denv.ml @@ -67,7 +67,7 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = let map = Value_slot.Map.map (fun ({ epa = { param = var; _ }; kind; _ } : U.field_decision) -> - var, kind) + var, K.With_subkind.kind kind) vars_within_closure in let shape = diff --git a/middle_end/flambda2/simplify/unboxing/unboxers.ml b/middle_end/flambda2/simplify/unboxing/unboxers.ml index 9c4a84aa0e1..26318feb343 100644 --- a/middle_end/flambda2/simplify/unboxing/unboxers.ml +++ b/middle_end/flambda2/simplify/unboxing/unboxers.ml @@ -181,10 +181,7 @@ module Closure_field = struct let unboxer function_slot value_slot = { var_name = "closure_field_at_use"; - poison_const = - Const.of_int_of_kind - (Flambda_kind.With_subkind.kind (Value_slot.kind value_slot)) - 0; + poison_const = Const.of_int_of_kind (Value_slot.kind value_slot) 0; unboxing_prim = (fun closure -> unboxing_prim function_slot ~closure value_slot); prove_simple = diff --git a/middle_end/flambda2/simplify_shared/slot_offsets.ml b/middle_end/flambda2/simplify_shared/slot_offsets.ml index fdfe8109c9b..f34e21104fd 100644 --- a/middle_end/flambda2/simplify_shared/slot_offsets.ml +++ b/middle_end/flambda2/simplify_shared/slot_offsets.ml @@ -880,7 +880,7 @@ end = struct (fun value_slot _ -> let kind = Value_slot.kind value_slot in let size, is_unboxed = - match Flambda_kind.With_subkind.kind kind with + match kind with | Region | Rec_info -> Misc.fatal_errorf "Value slot %a has Region or Rec_info kind" Value_slot.print value_slot @@ -891,12 +891,7 @@ end = struct (* flambda2 only supports 64-bit targets for now, so naked numbers can only be of size 1 *) | Naked_number Naked_vec128 -> 2, true - | Value -> ( - match[@ocaml.warning "-4"] - Flambda_kind.With_subkind.non_null_value_subkind kind - with - | Tagged_immediate -> 1, true - | _ -> 1, false) + | Value -> 1, false in if is_unboxed then diff --git a/middle_end/flambda2/terms/flambda_primitive.ml b/middle_end/flambda2/terms/flambda_primitive.ml index c6a542d58cf..5c4482f8e6b 100644 --- a/middle_end/flambda2/terms/flambda_primitive.ml +++ b/middle_end/flambda2/terms/flambda_primitive.ml @@ -1379,7 +1379,7 @@ let result_kind_of_unary_primitive p : result_kind = | Untag_immediate -> Singleton K.naked_immediate | Box_number _ | Tag_immediate | Project_function_slot _ -> Singleton K.value | Project_value_slot { value_slot; _ } -> - Singleton (K.With_subkind.kind (Value_slot.kind value_slot)) + Singleton (Value_slot.kind value_slot) | Is_boxed_float | Is_flat_float_array -> Singleton K.naked_immediate | End_region _ -> Singleton K.value | End_try_region _ -> Singleton K.value diff --git a/middle_end/flambda2/to_cmm/to_cmm_primitive.ml b/middle_end/flambda2/to_cmm/to_cmm_primitive.ml index 0f1970fc547..ac9fb993076 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_primitive.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_primitive.ml @@ -933,7 +933,9 @@ let unary_primitive env res dbg f arg = value_slot_offset env value_slot, function_slot_offset env project_from with | Live_value_slot { offset; _ }, Live_function_slot { offset = base; _ } -> - let memory_chunk = To_cmm_shared.memory_chunk_of_kind kind in + let memory_chunk = + To_cmm_shared.memory_chunk_of_kind (KS.anything kind) + in let expr = C.get_field_gen_given_memory_chunk memory_chunk Asttypes.Immutable arg (offset - base) dbg 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 088483173ca..1b93009ddc6 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 @@ -149,11 +149,7 @@ end = struct | Value_slot { value_slot; is_scanned; size } -> let simple = Value_slot.Map.find value_slot value_slots in let kind = Value_slot.kind value_slot in - if (not - (Flambda_kind.equal - (Flambda_kind.With_subkind.kind kind) - Flambda_kind.value)) - && is_scanned + if (not (Flambda_kind.equal kind Flambda_kind.value)) && is_scanned then Misc.fatal_errorf "Value slot %a not of kind Value (%a) but is visible by GC" @@ -162,7 +158,7 @@ end = struct let env, res, fields, chunk_acc, updates = match contents with | `Expr field -> - let chunk = C.memory_chunk_of_kind kind in + let chunk = C.memory_chunk_of_kind (KS.anything kind) in let chunk_acc = rev_append_chunks ~for_static_sets [chunk] chunk_acc in @@ -179,13 +175,8 @@ end = struct } -> let update_kind = let module UK = C.Update_kind in - match KS.kind kind with - | Value -> - if KS.Non_null_value_subkind.equal - (KS.non_null_value_subkind kind) - Tagged_immediate - then UK.tagged_immediates - else UK.pointers + match kind with + | Value -> UK.pointers | Naked_number Naked_immediate | Naked_number Naked_int64 | Naked_number Naked_nativeint -> @@ -198,7 +189,7 @@ end = struct | Naked_number Naked_float32 -> UK.naked_float32_fields | Region | Rec_info -> Misc.fatal_errorf "Unexpected value slot kind for %a: %a" - Value_slot.print value_slot KS.print kind + Value_slot.print value_slot Flambda_kind.print kind in let env, res, updates = C.make_update env res dbg update_kind diff --git a/middle_end/flambda2/types/flambda2_types.mli b/middle_end/flambda2/types/flambda2_types.mli index dae61eb1685..da8c47402df 100644 --- a/middle_end/flambda2/types/flambda2_types.mli +++ b/middle_end/flambda2/types/flambda2_types.mli @@ -505,12 +505,12 @@ val closure_with_at_least_this_value_slot : this_function_slot:Function_slot.t -> Value_slot.t -> value_slot_var:Variable.t -> - value_slot_kind:Flambda_kind.With_subkind.t -> + value_slot_kind:Flambda_kind.t -> flambda_type val closure_with_at_least_these_value_slots : this_function_slot:Function_slot.t -> - (Variable.t * Flambda_kind.With_subkind.t) Value_slot.Map.t -> + (Variable.t * Flambda_kind.t) Value_slot.Map.t -> flambda_type val array_of_length : diff --git a/middle_end/flambda2/types/grammar/more_type_creators.ml b/middle_end/flambda2/types/grammar/more_type_creators.ml index d08dd72bed9..0f37c1d9617 100644 --- a/middle_end/flambda2/types/grammar/more_type_creators.ml +++ b/middle_end/flambda2/types/grammar/more_type_creators.ml @@ -339,9 +339,7 @@ let closure_with_at_least_these_function_slots ~this_function_slot let closure_with_at_least_these_value_slots ~this_function_slot value_slots = let value_slot_types = - let type_of_var (v, kind) = - TG.alias_type_of (K.With_subkind.kind kind) (Simple.var v) - in + let type_of_var (v, kind) = TG.alias_type_of kind (Simple.var v) in let value_slot_components_by_index = Value_slot.Map.map type_of_var value_slots in diff --git a/middle_end/flambda2/types/grammar/more_type_creators.mli b/middle_end/flambda2/types/grammar/more_type_creators.mli index 24ff390bb2f..758cf30727e 100644 --- a/middle_end/flambda2/types/grammar/more_type_creators.mli +++ b/middle_end/flambda2/types/grammar/more_type_creators.mli @@ -150,14 +150,14 @@ val static_closure_with_this_code : val closure_with_at_least_these_value_slots : this_function_slot:Function_slot.t -> - (Variable.t * Flambda_kind.With_subkind.t) Value_slot.Map.t -> + (Variable.t * Flambda_kind.t) Value_slot.Map.t -> Type_grammar.t val closure_with_at_least_this_value_slot : this_function_slot:Function_slot.t -> Value_slot.t -> value_slot_var:Variable.t -> - value_slot_kind:Flambda_kind.With_subkind.t -> + value_slot_kind:Flambda_kind.t -> Type_grammar.t val type_for_const : Reg_width_const.t -> Type_grammar.t diff --git a/middle_end/flambda2/types/provers.ml b/middle_end/flambda2/types/provers.ml index 3546f7d456a..c51792abc96 100644 --- a/middle_end/flambda2/types/provers.ml +++ b/middle_end/flambda2/types/provers.ml @@ -935,9 +935,7 @@ let meet_project_value_slot_simple_value ~min_name_mode value_slot env | Known ty -> ( if (* It's more straightforward to check the kind of [ty] instead of examining the row-like structure directly. *) - not - (Flambda_kind.equal (TG.kind ty) - (Value_slot.kind value_slot |> Flambda_kind.With_subkind.kind)) + not (Flambda_kind.equal (TG.kind ty) (Value_slot.kind value_slot)) then Invalid else match TG.get_alias_exn ty with From b089269c8d160369bb04009a044ac898e62ef98d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nathana=C3=ABlle=20Courant?= Date: Tue, 6 May 2025 13:30:36 +0200 Subject: [PATCH 2/5] fix compare --- middle_end/flambda2/compare/compare.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/middle_end/flambda2/compare/compare.ml b/middle_end/flambda2/compare/compare.ml index 4e45cb12ca8..de932e18722 100644 --- a/middle_end/flambda2/compare/compare.ml +++ b/middle_end/flambda2/compare/compare.ml @@ -775,7 +775,7 @@ let sets_of_closures env set1 set2 : Set_of_closures.t Comparison.t = let ok = ref true in let () = let compare (kind1, value1, _var1) (kind2, value2, _var2) = - let c = Flambda_kind.With_subkind.compare kind1 kind2 in + let c = Flambda_kind.compare kind1 kind2 in if c = 0 then Simple.compare value1 value2 else c in iter2_merged (value_slots_by_value set1) (value_slots_by_value set2) From 8ad0902d29c24f64a6f1221efdb60c0a88fea17c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nathana=C3=ABlle=20Courant?= Date: Fri, 9 May 2025 15:42:46 +0200 Subject: [PATCH 3/5] try to fix CI --- testsuite/tests/tool-ocamlobjinfo/question.reference | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/testsuite/tests/tool-ocamlobjinfo/question.reference b/testsuite/tests/tool-ocamlobjinfo/question.reference index 75a9244fe5c..a2158c8e103 100644 --- a/testsuite/tests/tool-ocamlobjinfo/question.reference +++ b/testsuite/tests/tool-ocamlobjinfo/question.reference @@ -51,16 +51,15 @@ Typing env: (Question.camlQuestion__answer_1 (Val ( (((alloc_mode Heap) (known - {((answer/0 ∷ 𝕍*|Null) - => (Known ((closures { (answer/0 ∷ 𝕍*|Null) }) (value_slots { }))), + {((answer/0 ∷ 𝕍) + => (Known ((closures { (answer/0 ∷ 𝕍) }) (value_slots { }))), ((function_types - {((answer/0 ∷ 𝕍*|Null) + {((answer/0 ∷ 𝕍) ((function_type (code_id camlQuestion__answer_0_1_code) (rec_info (Rec_info (0))))))}) (closure_types ((function_slot_components_by_index - {((answer/0 ∷ 𝕍*|Null) - (Val ((= Question.camlQuestion__answer_1))))}))) + {((answer/0 ∷ 𝕍) (Val ((= Question.camlQuestion__answer_1))))}))) (value_slot_types ((value_slot_components_by_index {})))))}) (other Bottom)))!)))}) (aliases From 4e606f1e86f4e518975790c05f5357945f558a75 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nathana=C3=ABlle=20Courant?= Date: Tue, 13 May 2025 16:12:08 +0200 Subject: [PATCH 4/5] add Slot.is_always_immediate --- .../from_lambda/closure_conversion.ml | 11 +++++-- .../flambda2/from_lambda/lambda_to_flambda.ml | 4 +-- middle_end/flambda2/identifiers/slot.ml | 32 +++++++++++++++---- middle_end/flambda2/identifiers/slot.mli | 9 +++++- .../flambda2/parser/fexpr_to_flambda.ml | 8 +++-- .../flambda2/simplify/simplify_apply_expr.ml | 6 ++-- .../flambda2/simplify_shared/slot_offsets.ml | 2 +- .../flambda2/to_cmm/to_cmm_set_of_closures.ml | 11 +++++-- 8 files changed, 64 insertions(+), 19 deletions(-) diff --git a/middle_end/flambda2/from_lambda/closure_conversion.ml b/middle_end/flambda2/from_lambda/closure_conversion.ml index a810e8ddd95..74cce009b8e 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion.ml @@ -2627,8 +2627,15 @@ let close_functions acc external_env ~current_region function_declarations = | None -> Ident.name id | Some var -> Variable.name var in + let is_always_immediate = + match[@ocaml.warning "-4"] + Flambda_kind.With_subkind.non_null_value_subkind kind + with + | Tagged_immediate -> true + | _ -> false + in Ident.Map.add id - (Value_slot.create compilation_unit ~name + (Value_slot.create compilation_unit ~name ~is_always_immediate (Flambda_kind.With_subkind.kind kind)) map) (Function_decls.all_free_idents function_declarations) @@ -2950,7 +2957,7 @@ let wrap_partial_application acc env apply_continuation (apply : IR.apply) let function_slot = Function_slot.create (Compilation_unit.get_current_exn ()) - ~name:(Ident.name wrapper_id) K.value + ~name:(Ident.name wrapper_id) ~is_always_immediate:false K.value in let num_provided = Flambda_arity.num_params provided_arity in let missing_arity_and_param_modes = diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml index 72c92107528..84405993f86 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml @@ -1353,7 +1353,7 @@ and cps_function env ~fid ~(recursive : Recursive.t) ?precomputed_free_idents Function_slot.create (Compilation_unit.get_current_exn ()) ~name:(Ident.name fid ^ "_unboxed") - Flambda_kind.value + ~is_always_immediate:false Flambda_kind.value in let unboxed_return = if attr.unbox_return then unboxing_kind return else None @@ -1424,7 +1424,7 @@ and cps_function env ~fid ~(recursive : Recursive.t) ?precomputed_free_idents let function_slot = Function_slot.create (Compilation_unit.get_current_exn ()) - ~name:(Ident.name fid) Flambda_kind.value + ~name:(Ident.name fid) ~is_always_immediate:false Flambda_kind.value in let unboxed_products = ref Ident.Map.empty in let params = diff --git a/middle_end/flambda2/identifiers/slot.ml b/middle_end/flambda2/identifiers/slot.ml index 65ea27e4780..49474b3b2a5 100644 --- a/middle_end/flambda2/identifiers/slot.ml +++ b/middle_end/flambda2/identifiers/slot.ml @@ -19,7 +19,12 @@ module type S = sig module Lmap : Lmap.S with type key = t - val create : Compilation_unit.t -> name:string -> Flambda_kind.t -> t + val create : + Compilation_unit.t -> + name:string -> + is_always_immediate:bool -> + Flambda_kind.t -> + t val get_compilation_unit : t -> Compilation_unit.t @@ -33,6 +38,8 @@ module type S = sig val kind : t -> Flambda_kind.t + val is_always_immediate : t -> bool + val rename : t -> t end @@ -44,7 +51,8 @@ end) : S = struct name : string; name_stamp : int; (** [name_stamp]s are unique within any given compilation unit. *) - kind : Flambda_kind.t + kind : Flambda_kind.t; + is_always_immediate : bool } module Self = Container_types.Make (struct @@ -54,12 +62,14 @@ end) : S = struct ({ compilation_unit = compilation_unit1; name = _; name_stamp = name_stamp1; - kind = _ + kind = _; + is_always_immediate = _ } as t1) ({ compilation_unit = compilation_unit2; name = _; name_stamp = name_stamp2; - kind = _ + kind = _; + is_always_immediate = _ } as t2) = if t1 == t2 then 0 @@ -82,7 +92,8 @@ end) : S = struct else Format.fprintf ppf "%a.%s/%d" Compilation_unit.print t.compilation_unit t.name t.name_stamp; - Format.fprintf ppf " @<1>\u{2237} %a" Flambda_kind.print t.kind; + Format.fprintf ppf " @<1>\u{2237} %a%s" Flambda_kind.print t.kind + (if t.is_always_immediate then "(immediate)" else ""); Format.fprintf ppf ")%t@]" Flambda_colours.pop end) @@ -101,8 +112,13 @@ end) : S = struct incr next_stamp; stamp - let create compilation_unit ~name kind = - { compilation_unit; name; name_stamp = get_next_stamp (); kind } + let create compilation_unit ~name ~is_always_immediate kind = + { compilation_unit; + name; + name_stamp = get_next_stamp (); + kind; + is_always_immediate + } let get_compilation_unit t = t.compilation_unit @@ -117,5 +133,7 @@ end) : S = struct let kind t = t.kind + let is_always_immediate t = t.is_always_immediate + let rename t = { t with name_stamp = get_next_stamp () } end diff --git a/middle_end/flambda2/identifiers/slot.mli b/middle_end/flambda2/identifiers/slot.mli index 5846777f8b7..714b8de8481 100644 --- a/middle_end/flambda2/identifiers/slot.mli +++ b/middle_end/flambda2/identifiers/slot.mli @@ -19,7 +19,12 @@ module type S = sig module Lmap : Lmap.S with type key = t - val create : Compilation_unit.t -> name:string -> Flambda_kind.t -> t + val create : + Compilation_unit.t -> + name:string -> + is_always_immediate:bool -> + Flambda_kind.t -> + t val get_compilation_unit : t -> Compilation_unit.t @@ -33,6 +38,8 @@ module type S = sig val kind : t -> Flambda_kind.t + val is_always_immediate : t -> bool + val rename : t -> t end diff --git a/middle_end/flambda2/parser/fexpr_to_flambda.ml b/middle_end/flambda2/parser/fexpr_to_flambda.ml index 9bbeef93b95..dd43c560c3d 100644 --- a/middle_end/flambda2/parser/fexpr_to_flambda.ml +++ b/middle_end/flambda2/parser/fexpr_to_flambda.ml @@ -144,7 +144,7 @@ let fresh_function_slot env { Fexpr.txt = name; loc = _ } = let c = Function_slot.create (Compilation_unit.get_current_exn ()) - ~name Flambda_kind.value + ~name ~is_always_immediate:false Flambda_kind.value in UT.add env.function_slots name c; c @@ -155,7 +155,11 @@ let fresh_or_existing_function_slot env ({ Fexpr.txt = name; loc = _ } as id) = | Some function_slot -> function_slot let fresh_value_slot env { Fexpr.txt = name; loc = _ } kind = - let c = Value_slot.create (Compilation_unit.get_current_exn ()) ~name kind in + let c = + Value_slot.create + (Compilation_unit.get_current_exn ()) + ~name ~is_always_immediate:false kind + in WT.add env.vars_within_closures name c; c diff --git a/middle_end/flambda2/simplify/simplify_apply_expr.ml b/middle_end/flambda2/simplify/simplify_apply_expr.ml index f362d56e787..c1a9930cafc 100644 --- a/middle_end/flambda2/simplify/simplify_apply_expr.ml +++ b/middle_end/flambda2/simplify/simplify_apply_expr.ml @@ -424,7 +424,8 @@ let simplify_direct_partial_application ~simplify_expr dacc apply let wrapper_var = Variable.create "partial_app" in let compilation_unit = Compilation_unit.get_current_exn () in let wrapper_function_slot = - Function_slot.create compilation_unit ~name:"partial_app_closure" K.value + Function_slot.create compilation_unit ~name:"partial_app_closure" + ~is_always_immediate:false K.value in (* The allocation mode of the closure is directly determined by the alloc_mode of the application. We check here that it is consistent with @@ -506,7 +507,8 @@ let simplify_direct_partial_application ~simplify_expr dacc apply } end in let mk_value_slot kind = - Value_slot.create compilation_unit ~name:"arg" kind + Value_slot.create compilation_unit ~name:"arg" + ~is_always_immediate:false kind in let applied_value (value, kind) = Simple.pattern_match' value diff --git a/middle_end/flambda2/simplify_shared/slot_offsets.ml b/middle_end/flambda2/simplify_shared/slot_offsets.ml index f34e21104fd..f0513e20700 100644 --- a/middle_end/flambda2/simplify_shared/slot_offsets.ml +++ b/middle_end/flambda2/simplify_shared/slot_offsets.ml @@ -891,7 +891,7 @@ end = struct (* flambda2 only supports 64-bit targets for now, so naked numbers can only be of size 1 *) | Naked_number Naked_vec128 -> 2, true - | Value -> 1, false + | Value -> 1, Value_slot.is_always_immediate value_slot in if is_unboxed then 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 1b93009ddc6..dc4ce99bce5 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 @@ -158,7 +158,11 @@ end = struct let env, res, fields, chunk_acc, updates = match contents with | `Expr field -> - let chunk = C.memory_chunk_of_kind (KS.anything kind) in + let chunk = + if Value_slot.is_always_immediate value_slot + then (Word_int : Cmm.memory_chunk) + else C.memory_chunk_of_kind (KS.anything kind) + in let chunk_acc = rev_append_chunks ~for_static_sets [chunk] chunk_acc in @@ -176,7 +180,10 @@ end = struct let update_kind = let module UK = C.Update_kind in match kind with - | Value -> UK.pointers + | Value -> + if Value_slot.is_always_immediate value_slot + then UK.tagged_immediates + else UK.pointers | Naked_number Naked_immediate | Naked_number Naked_int64 | Naked_number Naked_nativeint -> From fca2103a74a7435fd0f40e125e77e5fd508a94e1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nathana=C3=ABlle=20Courant?= Date: Tue, 13 May 2025 16:25:14 +0200 Subject: [PATCH 5/5] clean --- middle_end/flambda2/to_cmm/to_cmm_set_of_closures.ml | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) 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 dc4ce99bce5..5229ef5f6ac 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 @@ -149,6 +149,11 @@ end = struct | Value_slot { value_slot; is_scanned; size } -> let simple = Value_slot.Map.find value_slot value_slots in let kind = Value_slot.kind value_slot in + let kind_with_subkind = + if Value_slot.is_always_immediate value_slot + then KS.tagged_immediate + else KS.anything kind + in if (not (Flambda_kind.equal kind Flambda_kind.value)) && is_scanned then Misc.fatal_errorf @@ -158,11 +163,7 @@ end = struct let env, res, fields, chunk_acc, updates = match contents with | `Expr field -> - let chunk = - if Value_slot.is_always_immediate value_slot - then (Word_int : Cmm.memory_chunk) - else C.memory_chunk_of_kind (KS.anything kind) - in + let chunk = C.memory_chunk_of_kind kind_with_subkind in let chunk_acc = rev_append_chunks ~for_static_sets [chunk] chunk_acc in