From 5010c886350215461bec80fe979073fdbe084483 Mon Sep 17 00:00:00 2001 From: Simon Spies Date: Wed, 21 May 2025 16:23:57 +0100 Subject: [PATCH 1/4] uids middle end --- middle_end/backend_var.ml | 14 +- middle_end/backend_var.mli | 4 + .../bound_identifiers/bound_parameter.ml | 38 ++-- .../bound_identifiers/bound_parameter.mli | 7 +- .../bound_identifiers/bound_parameters.ml | 2 + .../bound_identifiers/bound_parameters.mli | 2 + .../flambda2/bound_identifiers/bound_var.ml | 17 +- .../flambda2/bound_identifiers/bound_var.mli | 4 +- .../from_lambda/closure_conversion.ml | 168 +++++++++++---- .../from_lambda/closure_conversion.mli | 5 +- .../from_lambda/closure_conversion_aux.ml | 17 +- .../from_lambda/closure_conversion_aux.mli | 9 +- .../flambda2/from_lambda/lambda_to_flambda.ml | 201 ++++++++++++------ .../from_lambda/lambda_to_flambda_env.ml | 24 ++- .../from_lambda/lambda_to_flambda_env.mli | 18 +- .../lambda_to_flambda_primitives_helpers.ml | 24 ++- .../flambda2/identifiers/flambda_uid.ml | 65 ++++++ .../flambda2/identifiers/flambda_uid.mli | 35 +++ .../flambda2/parser/fexpr_to_flambda.ml | 18 +- middle_end/flambda2/reaper/rebuild.ml | 31 ++- .../flambda2/simplify/apply_cont_rewrite.ml | 6 +- .../common_subexpression_elimination.ml | 4 +- .../flambda2/simplify/env/downwards_env.ml | 31 ++- middle_end/flambda2/simplify/expr_builder.ml | 16 +- .../simplify/flow/mutable_unboxing.ml | 4 +- .../simplify/inlining/inlining_transforms.ml | 10 +- .../flambda2/simplify/lifted_cont_params.ml | 1 + .../simplify/simplify_apply_cont_expr.ml | 5 +- .../flambda2/simplify/simplify_apply_expr.ml | 21 +- .../flambda2/simplify/simplify_common.ml | 25 ++- .../flambda2/simplify/simplify_extcall.ml | 4 +- .../simplify/simplify_let_cont_expr.ml | 13 +- .../simplify/simplify_set_of_closures.ml | 32 ++- .../flambda2/simplify/simplify_switch_expr.ml | 19 +- .../simplify/simplify_unary_primitive.ml | 7 +- .../simplify/unboxing/build_unboxing_denv.ml | 19 +- .../simplify/unboxing/unboxing_epa.ml | 29 ++- .../simplify_shared/inlining_helpers.ml | 8 +- middle_end/flambda2/terms/flambda.ml | 1 + middle_end/flambda2/tests/meet_test.ml | 64 ++++-- middle_end/flambda2/to_cmm/to_cmm.ml | 6 +- middle_end/flambda2/to_cmm/to_cmm_env.ml | 19 +- middle_end/flambda2/to_cmm/to_cmm_env.mli | 10 +- middle_end/flambda2/to_cmm/to_cmm_expr.ml | 18 +- .../flambda2/to_cmm/to_cmm_set_of_closures.ml | 23 +- middle_end/flambda2/to_cmm/to_cmm_shared.ml | 2 +- middle_end/flambda2/types/env/join_env.ml | 4 +- .../flambda2/types/equal_types_for_debug.ml | 10 +- middle_end/flambda2/types/join_levels_old.ml | 4 +- .../flambda2/types/meet_and_n_way_join.ml | 8 +- 50 files changed, 833 insertions(+), 293 deletions(-) create mode 100644 middle_end/flambda2/identifiers/flambda_uid.ml create mode 100644 middle_end/flambda2/identifiers/flambda_uid.mli diff --git a/middle_end/backend_var.ml b/middle_end/backend_var.ml index 1e5c7d579c8..89433026612 100644 --- a/middle_end/backend_var.ml +++ b/middle_end/backend_var.ml @@ -16,6 +16,8 @@ include Ident +module Uid = Flambda2_identifiers.Flambda_uid + type backend_var = t let name_for_debugger t = @@ -35,9 +37,10 @@ module Provenance = struct module_path : Path.t; location : Debuginfo.t; original_ident : Ident.t; + uid : Uid.t } - let print ppf { module_path; location; original_ident; } = + let print ppf { module_path; location; original_ident; uid } = let printf fmt = Format.fprintf ppf fmt in printf "@[("; printf "@[(module_path@ %a)@]@ " @@ -45,19 +48,22 @@ module Provenance = struct if !Clflags.locations then printf "@[(location@ %a)@]@ " Debuginfo.print_compact location; - printf "@[(original_ident@ %a)@]" - Ident.print original_ident; + printf "@[(original_ident@ %a,uid=%a)@]" + Ident.print original_ident + Uid.print uid; printf ")@]" - let create ~module_path ~location ~original_ident = + let create ~module_path ~location ~original_ident ~uid = { module_path; location; original_ident; + uid } let module_path t = t.module_path let location t = t.location let original_ident t = t.original_ident + let uid t = t.uid let equal t1 t2 = Stdlib.compare t1 t2 = 0 end diff --git a/middle_end/backend_var.mli b/middle_end/backend_var.mli index 2b5ede6888c..2288ab698bd 100644 --- a/middle_end/backend_var.mli +++ b/middle_end/backend_var.mli @@ -19,6 +19,8 @@ include module type of struct include Ident end +module Uid = Flambda2_identifiers.Flambda_uid + type backend_var = t val name_for_debugger : t -> string @@ -31,11 +33,13 @@ module Provenance : sig : module_path:Path.t -> location:Debuginfo.t -> original_ident:Ident.t + -> uid:Uid.t -> t val module_path : t -> Path.t val location : t -> Debuginfo.t val original_ident : t -> Ident.t + val uid : t -> Uid.t val print : Format.formatter -> t -> unit diff --git a/middle_end/flambda2/bound_identifiers/bound_parameter.ml b/middle_end/flambda2/bound_identifiers/bound_parameter.ml index 3baff7a86dd..66797aa6c98 100644 --- a/middle_end/flambda2/bound_identifiers/bound_parameter.ml +++ b/middle_end/flambda2/bound_identifiers/bound_parameter.ml @@ -15,37 +15,49 @@ (**************************************************************************) module Simple = Int_ids.Simple +module Uid = Shape.Uid type t = { param : Variable.t; + uid : Flambda_uid.t; kind : Flambda_kind.With_subkind.t } include Container_types.Make (struct type nonrec t = t - let compare { param = param1; kind = kind1 } { param = param2; kind = kind2 } - = + let compare { param = param1; kind = kind1; uid = uid1 } + { param = param2; kind = kind2; uid = uid2 } = let c = Variable.compare param1 param2 in - if c <> 0 then c else Flambda_kind.With_subkind.compare kind1 kind2 + if c <> 0 + then c + else + let c = Flambda_kind.With_subkind.compare kind1 kind2 in + if c <> 0 then c else Flambda_uid.compare uid1 uid2 let equal t1 t2 = compare t1 t2 = 0 - let hash { param; kind } = - Hashtbl.hash (Variable.hash param, Flambda_kind.With_subkind.hash kind) + let hash { param; kind; uid } = + Hashtbl.hash + ( Variable.hash param, + Flambda_kind.With_subkind.hash kind, + Flambda_uid.hash uid ) - let [@ocamlformat "disable"] print ppf { param; kind; } = - Format.fprintf ppf "@[(%t%a%t @<1>\u{2237} %a)@]" + let [@ocamlformat "disable"] print ppf { param; kind; uid } = + Format.fprintf ppf "@[(%t%a,uid=%a%t @<1>\u{2237} %a)@]" Flambda_colours.parameter Variable.print param + Flambda_uid.print uid Flambda_colours.pop Flambda_kind.With_subkind.print kind end) -let create param kind = { param; kind } +let create param kind uid = { param; kind; uid } let var t = t.param +let var_and_uid t = t.param, t.uid + let name t = Name.var (var t) let simple t = Simple.var (var t) @@ -60,12 +72,12 @@ let is_renamed_version_of t t' = Flambda_kind.With_subkind.equal t.kind t'.kind && Variable.is_renamed_version_of t.param t'.param -let free_names ({ param = _; kind = _ } as t) = - Name_occurrences.singleton_variable (var t) Name_mode.normal +let free_names { param; kind = _; uid = _ } = + Name_occurrences.singleton_variable param Name_mode.normal -let apply_renaming { param; kind } renaming = +let apply_renaming { param; kind; uid } renaming = let param = Renaming.apply_variable renaming param in - create param kind + create param kind uid -let ids_for_export { param; kind = _ } = +let ids_for_export { param; kind = _; uid = _ } = Ids_for_export.add_variable Ids_for_export.empty param diff --git a/middle_end/flambda2/bound_identifiers/bound_parameter.mli b/middle_end/flambda2/bound_identifiers/bound_parameter.mli index 1f47aed5574..7795c80a084 100644 --- a/middle_end/flambda2/bound_identifiers/bound_parameter.mli +++ b/middle_end/flambda2/bound_identifiers/bound_parameter.mli @@ -14,15 +14,20 @@ (* *) (**************************************************************************) +module Uid = Shape.Uid + (** A parameter (to a function, continuation, etc.) together with its kind. *) type t (** Create a kinded parameter. *) -val create : Variable.t -> Flambda_kind.With_subkind.t -> t +val create : Variable.t -> Flambda_kind.With_subkind.t -> Flambda_uid.t -> t (** The underlying variable. *) + val var : t -> Variable.t +val var_and_uid : t -> Variable.t * Flambda_uid.t + val name : t -> Name.t (** As for [var], but returns a [Simple.t] describing the variable. *) diff --git a/middle_end/flambda2/bound_identifiers/bound_parameters.ml b/middle_end/flambda2/bound_identifiers/bound_parameters.ml index 301c53ea5b0..f6104d8248a 100644 --- a/middle_end/flambda2/bound_identifiers/bound_parameters.ml +++ b/middle_end/flambda2/bound_identifiers/bound_parameters.ml @@ -52,6 +52,8 @@ let cardinal t = List.length t let vars t = List.map BP.var t +let vars_and_uids t = List.map BP.var_and_uid t + let simples t = List.map BP.simple t let to_set t = Bound_parameter.Set.of_list t diff --git a/middle_end/flambda2/bound_identifiers/bound_parameters.mli b/middle_end/flambda2/bound_identifiers/bound_parameters.mli index 97ae800326b..d368a2e8c7e 100644 --- a/middle_end/flambda2/bound_identifiers/bound_parameters.mli +++ b/middle_end/flambda2/bound_identifiers/bound_parameters.mli @@ -44,6 +44,8 @@ val to_set : t -> Bound_parameter.Set.t val vars : t -> Variable.t list +val vars_and_uids : t -> (Variable.t * Flambda_uid.t) list + val var_set : t -> Variable.Set.t val iter : (Bound_parameter.t -> unit) -> t -> unit diff --git a/middle_end/flambda2/bound_identifiers/bound_var.ml b/middle_end/flambda2/bound_identifiers/bound_var.ml index 03091a9586d..97da91d57b7 100644 --- a/middle_end/flambda2/bound_identifiers/bound_var.ml +++ b/middle_end/flambda2/bound_identifiers/bound_var.ml @@ -16,19 +16,22 @@ type t = { var : Variable.t; + uid : Flambda_uid.t; name_mode : Name_mode.t } -let [@ocamlformat "disable"] print ppf { var; name_mode = _; } = - Variable.print ppf var +let [@ocamlformat "disable"] print ppf { var; uid; name_mode = _; } = + Format.fprintf ppf "%a,uid=%a" Variable.print var Flambda_uid.print uid -let create var name_mode = +let create var uid name_mode = (* Note that [name_mode] might be [In_types], e.g. when dealing with function return types and also using [Typing_env.add_definition]. *) - { var; name_mode } + { var; uid; name_mode } let var t = t.var +let uid t = t.uid + let name_mode t = t.name_mode let with_var t var = { t with var } @@ -46,9 +49,9 @@ let apply_renaming t renaming = let free_names t = Name_occurrences.singleton_variable t.var t.name_mode -let ids_for_export { var; name_mode = _ } = +let ids_for_export { var; uid = _; name_mode = _ } = Ids_for_export.add_variable Ids_for_export.empty var -let renaming { var; name_mode = _ } ~guaranteed_fresh = - let { var = guaranteed_fresh; name_mode = _ } = guaranteed_fresh in +let renaming { var; uid = _; name_mode = _ } ~guaranteed_fresh = + let { var = guaranteed_fresh; uid = _; name_mode = _ } = guaranteed_fresh in Renaming.add_fresh_variable Renaming.empty var ~guaranteed_fresh diff --git a/middle_end/flambda2/bound_identifiers/bound_var.mli b/middle_end/flambda2/bound_identifiers/bound_var.mli index 91d132d6239..f6ed340ce99 100644 --- a/middle_end/flambda2/bound_identifiers/bound_var.mli +++ b/middle_end/flambda2/bound_identifiers/bound_var.mli @@ -19,10 +19,12 @@ type t -val create : Variable.t -> Name_mode.t -> t +val create : Variable.t -> Flambda_uid.t -> Name_mode.t -> t val var : t -> Variable.t +val uid : t -> Flambda_uid.t + val name_mode : t -> Name_mode.t val with_name_mode : t -> Name_mode.t -> t diff --git a/middle_end/flambda2/from_lambda/closure_conversion.ml b/middle_end/flambda2/from_lambda/closure_conversion.ml index b6174f51b03..21cef3d5563 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion.ml @@ -370,13 +370,18 @@ module Inlining = struct List.fold_left2 (fun (acc, body) param arg -> Let_with_acc.create acc - (Bound_pattern.singleton (VB.create param Name_mode.normal)) + (* CR tnowak: verify *) + (Bound_pattern.singleton + (VB.create param Flambda_uid.internal_not_actually_unique + Name_mode.normal)) (Named.create_simple arg) ~body) (acc, body) params args in let bind_depth ~my_depth ~rec_info ~body:(acc, body) = Let_with_acc.create acc - (Bound_pattern.singleton (VB.create my_depth Name_mode.normal)) + (Bound_pattern.singleton + (VB.create my_depth Flambda_uid.internal_not_actually_unique + Name_mode.normal)) (Named.create_rec_info rec_info) ~body in @@ -400,7 +405,9 @@ module Inlining = struct in Let_with_acc.create acc (Bound_pattern.singleton - (VB.create (Variable.create "inlined_dbg") Name_mode.normal)) + (VB.create + (Variable.create "inlined_dbg") + Flambda_uid.internal_not_actually_unique Name_mode.normal)) (Named.create_prim (Nullary (Enter_inlined_apply { dbg = inlined_debuginfo })) Debuginfo.none) @@ -620,7 +627,8 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds "close_c_call: C call primitive %s can't be layout polymorphic." prim_name; let env, let_bound_vars = List.fold_left_map - (fun env (id, kind) -> Env.add_var_like env id Not_user_visible kind) + (fun env (id, _uid, kind) -> + Env.add_var_like env id Not_user_visible kind) env let_bound_ids_with_kinds in let cost_metrics_of_body, free_names_of_body, acc, body = @@ -718,7 +726,10 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds match args with | [arg] -> let result = Variable.create "reinterpreted" in - let result' = Bound_var.create result Name_mode.normal in + let result' = + Bound_var.create result Flambda_uid.internal_not_actually_unique + Name_mode.normal + in let bindable = Bound_pattern.singleton result' in let prim = P.Unary (Reinterpret_64_bit_word op, arg) in let acc, return_result = @@ -770,7 +781,10 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds | Some named -> fun args acc -> let unboxed_arg = Variable.create "unboxed" in - let unboxed_arg' = VB.create unboxed_arg Name_mode.normal in + let unboxed_arg' = + VB.create unboxed_arg Flambda_uid.internal_not_actually_unique + Name_mode.normal + in let acc, body = call (Simple.var unboxed_arg :: args) acc in let named = Named.create_prim (Unary (named, arg)) dbg in Let_with_acc.create acc @@ -782,7 +796,10 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds let params = List.map2 (fun ret_value { kind; _ } -> - BP.create ret_value (K.With_subkind.anything kind)) + BP.create ret_value + (K.With_subkind.anything kind) + Flambda_uid.internal_not_actually_unique + (* CR tnowak: verify *)) handler_params unarized_results |> Bound_parameters.create in @@ -799,7 +816,9 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds let box_unboxed_returns () = let let_bound_vars' = List.map - (fun let_bound_var -> VB.create let_bound_var Name_mode.normal) + (fun let_bound_var -> + VB.create let_bound_var Flambda_uid.internal_not_actually_unique + Name_mode.normal) let_bound_vars in let handler_params = @@ -846,7 +865,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds let close_exn_continuation acc env (exn_continuation : IR.exn_continuation) = let acc, extra_args = List.fold_left_map - (fun acc (simple, kind) -> + (fun acc (simple, _uid, kind) -> let acc, simple = find_simple acc env simple in acc, (simple, kind)) acc exn_continuation.extra_args @@ -887,7 +906,8 @@ let close_effect_primitive acc env ~dbg exn_continuation (* CR mshinwell: share with close_c_call, above *) let _env, let_bound_vars = List.fold_left_map - (fun env (id, kind) -> Env.add_var_like env id Not_user_visible kind) + (* CR sspies: Do we really want to drop the [debug_uid] here? *) + (fun env (id, _, kind) -> Env.add_var_like env id Not_user_visible kind) env let_bound_ids_with_kinds in let let_bound_var = @@ -904,7 +924,9 @@ let close_effect_primitive acc env ~dbg exn_continuation let continuation = Continuation.create () in let return_kind = Flambda_kind.With_subkind.any_value in let params = - [BP.create let_bound_var return_kind] |> Bound_parameters.create + [ BP.create let_bound_var return_kind + Flambda_uid.internal_not_actually_unique (* CR sspies: fix *) ] + |> Bound_parameters.create in let close call_kind = let apply acc = @@ -1239,7 +1261,7 @@ let close_let acc env let_bound_ids_with_kinds user_visible defining_expr let rec cont ids_with_kinds env acc (defining_exprs : Named.t list) = match ids_with_kinds, defining_exprs with | [], [] -> body acc env - | (id, kind) :: ids_with_kinds, defining_expr :: defining_exprs -> ( + | (id, uid, kind) :: ids_with_kinds, defining_expr :: defining_exprs -> ( let body_env, var = Env.add_var_like env id user_visible kind in let body acc env = cont ids_with_kinds env acc defining_exprs in match defining_expr with @@ -1272,7 +1294,7 @@ let close_let acc env let_bound_ids_with_kinds user_visible defining_expr prim Flambda_kind.print result_kind | Simple _ | Static_consts _ | Set_of_closures _ | Rec_info _ -> ()); let bound_pattern = - Bound_pattern.singleton (VB.create var Name_mode.normal) + Bound_pattern.singleton (VB.create var uid Name_mode.normal) in let bind acc env = (* CR pchambart: Not tail ! The body function is the recursion *) @@ -1496,7 +1518,9 @@ let close_let_cont acc env ~name ~is_exn_handler ~params Continuation.print name); let handler_env, env_params = Env.add_vars_like env params in let handler_params = - List.map2 (fun param (_, _, kind) -> BP.create param kind) env_params params + List.map2 + (fun param (_, uid, _, kind) -> BP.create param kind uid) + env_params params |> Bound_parameters.create in let handler acc = @@ -1505,7 +1529,8 @@ let close_let_cont acc env ~name ~is_exn_handler ~params | None -> handler_env | Some args -> List.fold_left2 - (fun env arg_approx (param, (param_id, _, kind)) -> + (fun env arg_approx (param, (param_id, _param_uid, _, kind)) -> + (* CR tnowak: not sure, should we ignore the param_uid here? *) let env = Env.add_var_approximation env param arg_approx in match (arg_approx : Env.value_approximation) with | Value_symbol s | Closure_approximation { symbol = Some s; _ } -> @@ -1661,7 +1686,10 @@ let close_switch acc env ~condition_dbg scrutinee (sw : IR.switch) : Expr_with_acc.t = let scrutinee = find_simple_from_id env scrutinee in let untagged_scrutinee = Variable.create "untagged" in - let untagged_scrutinee' = VB.create untagged_scrutinee Name_mode.normal in + let untagged_scrutinee' = + VB.create untagged_scrutinee Flambda_uid.internal_not_actually_unique + Name_mode.normal + in let known_const_scrutinee = match find_value_approximation_through_symbol acc env scrutinee with | Value_approximation.Value_const c -> Reg_width_const.is_tagged_immediate c @@ -1700,7 +1728,10 @@ let close_switch acc env ~condition_dbg scrutinee (sw : IR.switch) : condition_dbg in let comparison_result = Variable.create "eq" in - let comparison_result' = VB.create comparison_result Name_mode.normal in + let comparison_result' = + VB.create comparison_result Flambda_uid.internal_not_actually_unique + Name_mode.normal + in let acc, default_action = let acc, args = find_simples acc env default_args in let trap_action = close_trap_action_opt default_trap_action in @@ -1869,14 +1900,20 @@ let compute_body_of_unboxed_function acc my_region my_closure in Let_with_acc.create acc (Bound_pattern.singleton - (Bound_var.create (Bound_parameter.var param) Name_mode.normal)) + (Bound_var.create + (Bound_parameter.var param) + Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) Name_mode.normal)) (Named.create_prim (boxing_primitive k alloc_mode (List.map fst vars_with_kinds)) Debuginfo.none) ~body in ( List.map - (fun (var, kind) -> Bound_parameter.create var kind) + (fun (var, kind) -> + Bound_parameter.create var kind + Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *)) vars_with_kinds @ main_code_params, List.map snd vars_with_kinds @ main_code_params_arity, @@ -1922,7 +1959,10 @@ let compute_body_of_unboxed_function acc my_region my_closure unboxed return@." in let handler_params = - Bound_parameters.create [Bound_parameter.create boxed_variable return] + Bound_parameters.create + [ Bound_parameter.create boxed_variable return + Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) ] in let handler acc = let acc, apply_cont = @@ -1937,7 +1977,9 @@ let compute_body_of_unboxed_function acc my_region my_closure (fun ((acc, expr), i) (var, _kind) -> ( Let_with_acc.create acc (Bound_pattern.singleton - (Bound_var.create var Name_mode.normal)) + (Bound_var.create var + Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) Name_mode.normal)) (Named.create_prim (unboxing_primitive k boxed_variable i) Debuginfo.none) @@ -1961,7 +2003,9 @@ let compute_body_of_unboxed_function acc my_region my_closure let my_unboxed_closure = Variable.create "my_unboxed_closure" in let acc, unboxed_body = Let_with_acc.create acc - (Bound_pattern.singleton (Bound_var.create my_closure Name_mode.normal)) + (Bound_pattern.singleton + (Bound_var.create my_closure Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) Name_mode.normal)) (Named.create_prim (Flambda_primitive.Unary ( Project_function_slot @@ -2040,7 +2084,9 @@ let make_unboxed_function_wrapper acc function_slot ~unarized_params:params ( Expr.create_let (Let_expr.create (Bound_pattern.singleton - (Bound_var.create var Name_mode.normal)) + (Bound_var.create var + Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) Name_mode.normal)) named ~body ~free_names_of_body:(Known free_names_of_body)), Name_occurrences.union (Named.free_names named) @@ -2094,7 +2140,9 @@ let make_unboxed_function_wrapper acc function_slot ~unarized_params:params Expr.create_let (Let_expr.create (Bound_pattern.singleton - (Bound_var.create main_closure Name_mode.normal)) + (Bound_var.create main_closure + Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) Name_mode.normal)) projection ~body:(Expr.create_apply main_application) ~free_names_of_body:(Known (Apply_expr.free_names main_application))) @@ -2117,7 +2165,9 @@ let make_unboxed_function_wrapper acc function_slot ~unarized_params:params (List.map (fun kind -> let var = Variable.create "unboxed_return" in - Bound_parameter.create var kind) + Bound_parameter.create var kind + Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *)) (Flambda_arity.unarized_components result_arity_main_code)) in let handler, free_names_of_handler = @@ -2135,7 +2185,9 @@ let make_unboxed_function_wrapper acc function_slot ~unarized_params:params ( Expr.create_let (Let_expr.create (Bound_pattern.singleton - (Bound_var.create boxed_return Name_mode.normal)) + (Bound_var.create boxed_return + Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) Name_mode.normal)) box_result_named ~body:(Expr.create_apply_cont return_apply_cont) ~free_names_of_body: @@ -2412,7 +2464,8 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot List.map (fun (p : Function_decl.param) -> let var = fst (Env.find_var closure_env p.name) in - BP.create var p.kind) + BP.create var p.kind Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *)) unarized_params |> Bound_parameters.create in @@ -2445,7 +2498,10 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot let move : Flambda_primitive.unary_primitive = Project_function_slot { move_from = function_slot; move_to } in - let var = VB.create var Name_mode.normal in + let var = + VB.create var Flambda_uid.internal_not_actually_unique + Name_mode.normal + in let named = Named.create_prim (Unary (move, my_closure')) Debuginfo.none in @@ -2455,7 +2511,10 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot let acc, body = Variable.Map.fold (fun var value_slot (acc, body) -> - let var = VB.create var Name_mode.normal in + let var = + VB.create var Flambda_uid.internal_not_actually_unique + Name_mode.normal + in let named = Named.create_prim (Unary @@ -2469,7 +2528,9 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot in let next_depth_expr = Rec_info_expr.succ (Rec_info_expr.var my_depth) in let bound = - Bound_pattern.singleton (Bound_var.create next_depth Name_mode.normal) + Bound_pattern.singleton + (Bound_var.create next_depth Flambda_uid.internal_not_actually_unique + Name_mode.normal) in Let_with_acc.create acc bound (Named.create_rec_info next_depth_expr) ~body in @@ -2898,7 +2959,10 @@ let close_let_rec acc env ~function_declarations (fun (fun_vars_map, ident_map) decl -> let ident = Function_decl.let_rec_ident decl in let fun_var = - VB.create (fst (Env.find_var env ident)) Name_mode.normal + (* CR tnowak: verify *) + VB.create + (fst (Env.find_var env ident)) + Flambda_uid.internal_not_actually_unique Name_mode.normal in let function_slot = Function_decl.function_slot decl in ( Function_slot.Map.add function_slot fun_var fun_vars_map, @@ -2961,7 +3025,9 @@ let close_let_rec acc env ~function_declarations Function_slot.Set.fold (fun function_slot fun_vars_map -> let fun_var = - VB.create (Variable.create "generated") Name_mode.normal + VB.create + (Variable.create "generated") + Flambda_uid.internal_not_actually_unique Name_mode.normal in Function_slot.Map.add function_slot fun_var fun_vars_map) generated_closures fun_vars_map @@ -3024,6 +3090,8 @@ let wrap_partial_application acc env apply_continuation (apply : IR.apply) List.mapi (fun n (kind, mode) : Function_decl.param -> { name = Ident.create_local ("param" ^ string_of_int (num_provided + n)); + var_uid = + Flambda_uid.internal_not_actually_unique (* CR tnowak: verify *); kind; attributes = Lambda.default_param_attribute; mode = Alloc_mode.For_types.to_lambda mode @@ -3107,7 +3175,8 @@ let wrap_partial_application acc env apply_continuation (apply : IR.apply) (Debuginfo.from_location apply.loc)) ) else let function_declarations = - [ Function_decl.create ~let_rec_ident:(Some wrapper_id) ~function_slot + [ Function_decl.create ~let_rec_ident:(Some wrapper_id) + ~let_rec_uid:Flambda_uid.internal_not_actually_unique ~function_slot ~kind: (Lambda.Curried { nlocal = @@ -3199,7 +3268,10 @@ let wrap_over_application acc env full_call (apply : IR.apply) ~remaining let over_application_results = List.mapi (fun i kind -> - BP.create (Variable.create ("result" ^ string_of_int i)) kind) + BP.create + (Variable.create ("result" ^ string_of_int i)) + kind + Flambda_uid.internal_not_actually_unique (* CR tnowak: verify *)) (Flambda_arity.unarized_components apply.return_arity) in let handler acc = @@ -3214,7 +3286,9 @@ let wrap_over_application acc env full_call (apply : IR.apply) ~remaining let acc, body = Let_with_acc.create acc (Bound_pattern.singleton - (Bound_var.create (Variable.create "unit") Name_mode.normal)) + (Bound_var.create (Variable.create "unit") + Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) Name_mode.normal)) (Named.create_prim (Unary (End_region { ghost = true }, Simple.var ghost_region)) apply_dbg) @@ -3222,7 +3296,9 @@ let wrap_over_application acc env full_call (apply : IR.apply) ~remaining in Let_with_acc.create acc (Bound_pattern.singleton - (Bound_var.create (Variable.create "unit") Name_mode.normal)) + (Bound_var.create (Variable.create "unit") + Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) Name_mode.normal)) (Named.create_prim (Unary (End_region { ghost = false }, Simple.var region)) apply_dbg) @@ -3240,7 +3316,8 @@ let wrap_over_application acc env full_call (apply : IR.apply) ~remaining let acc, both_applications = Let_cont_with_acc.build_non_recursive acc wrapper_cont ~handler_params: - ([BP.create returned_func K.With_subkind.any_value] + ([ BP.create returned_func K.With_subkind.any_value + Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *) ] |> Bound_parameters.create) ~handler:perform_over_application ~body ~is_exn_handler:false ~is_cold:false @@ -3251,14 +3328,18 @@ let wrap_over_application acc env full_call (apply : IR.apply) ~remaining let acc, body = Let_with_acc.create acc (Bound_pattern.singleton - (Bound_var.create ghost_region Name_mode.normal)) + (Bound_var.create ghost_region + Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) Name_mode.normal)) (Named.create_prim (Variadic (Begin_region { ghost = true }, [])) apply_dbg) ~body:both_applications in Let_with_acc.create acc - (Bound_pattern.singleton (Bound_var.create region Name_mode.normal)) + (Bound_pattern.singleton + (Bound_var.create region Flambda_uid.internal_not_actually_unique + Name_mode.normal)) (Named.create_prim (Variadic (Begin_region { ghost = false }, [])) apply_dbg) @@ -3581,7 +3662,11 @@ let wrap_final_module_block acc env ~program ~prog_return_cont in List.fold_left (fun (acc, body) (pos, var) -> - let var = VB.create var Name_mode.normal in + (* CR tnowak: verify *) + let var = + VB.create var Flambda_uid.internal_not_actually_unique + Name_mode.normal + in let pat = Bound_pattern.singleton var in let pos = Targetint_31_63.of_int pos in let block = module_block_simple in @@ -3602,7 +3687,8 @@ let wrap_final_module_block acc env ~program ~prog_return_cont (acc, body) (List.rev field_vars) in let load_fields_handler_param = - [BP.create module_block_var K.With_subkind.any_value] + [ BP.create module_block_var K.With_subkind.any_value + Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *) ] |> Bound_parameters.create in (* This binds the return continuation that is free (or, at least, not bound) diff --git a/middle_end/flambda2/from_lambda/closure_conversion.mli b/middle_end/flambda2/from_lambda/closure_conversion.mli index 26eada90a02..b2cd1961c1d 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.mli +++ b/middle_end/flambda2/from_lambda/closure_conversion.mli @@ -25,7 +25,7 @@ module Expr_with_acc = Closure_conversion_aux.Expr_with_acc val close_let : Acc.t -> Env.t -> - (Ident.t * Flambda_kind.With_subkind.t) list -> + (Ident.t * Flambda_uid.t * Flambda_kind.With_subkind.t) list -> IR.user_visible -> IR.named -> body:(Acc.t -> Env.t -> Expr_with_acc.t) -> @@ -44,7 +44,8 @@ val close_let_cont : Env.t -> name:Continuation.t -> is_exn_handler:bool -> - params:(Ident.t * IR.user_visible * Flambda_kind.With_subkind.t) list -> + params: + (Ident.t * Flambda_uid.t * IR.user_visible * Flambda_kind.With_subkind.t) list -> recursive:Asttypes.rec_flag -> handler:(Acc.t -> Env.t -> Expr_with_acc.t) -> body:(Acc.t -> Env.t -> Expr_with_acc.t) -> diff --git a/middle_end/flambda2/from_lambda/closure_conversion_aux.ml b/middle_end/flambda2/from_lambda/closure_conversion_aux.ml index eacd7a9a418..4b66f646334 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion_aux.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion_aux.ml @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +module Uid = Shape.Uid + module IR = struct type simple = | Var of Ident.t @@ -21,7 +23,7 @@ module IR = struct type exn_continuation = { exn_handler : Continuation.t; - extra_args : (simple * Flambda_kind.With_subkind.t) list + extra_args : (simple * Flambda_uid.t * Flambda_kind.With_subkind.t) list } type trap_action = @@ -243,7 +245,7 @@ module Env = struct let add_vars_like t ids = let vars = List.map - (fun (id, (user_visible : IR.user_visible), kind) -> + (fun (id, _uid, (user_visible : IR.user_visible), kind) -> let user_visible = match user_visible with | Not_user_visible -> None @@ -252,7 +254,7 @@ module Env = struct Variable.create_with_same_name_as_ident ?user_visible id, kind) ids in - add_vars t (List.map (fun (id, _, _) -> id) ids) vars, List.map fst vars + add_vars t (List.map (fun (id, _, _, _) -> id) ids) vars, List.map fst vars let find_var t id = try Ident.Map.find id t.variables @@ -745,6 +747,7 @@ module Function_decls = struct module Function_decl = struct type param = { name : Ident.t; + var_uid : Flambda_uid.t; kind : Flambda_kind.With_subkind.t; attributes : Lambda.parameter_attribute; mode : Lambda.locality_mode @@ -762,6 +765,7 @@ module Function_decls = struct type t = { let_rec_ident : Ident.t; + let_rec_uid : Flambda_uid.t; function_slot : Function_slot.t; kind : Lambda.function_kind; params : param list; @@ -783,9 +787,9 @@ module Function_decls = struct result_mode : Lambda.locality_mode } - let create ~let_rec_ident ~function_slot ~kind ~params ~params_arity - ~removed_params ~return ~calling_convention ~return_continuation - ~exn_continuation ~my_region ~my_ghost_region ~body + let create ~let_rec_ident ~let_rec_uid ~function_slot ~kind ~params + ~params_arity ~removed_params ~return ~calling_convention + ~return_continuation ~exn_continuation ~my_region ~my_ghost_region ~body ~(attr : Lambda.function_attribute) ~loc ~free_idents_of_body recursive ~closure_alloc_mode ~first_complex_local_param ~result_mode = let let_rec_ident = @@ -806,6 +810,7 @@ module Function_decls = struct (Format.pp_print_option Ident.print) my_ghost_region); { let_rec_ident; + let_rec_uid; function_slot; kind; params; diff --git a/middle_end/flambda2/from_lambda/closure_conversion_aux.mli b/middle_end/flambda2/from_lambda/closure_conversion_aux.mli index bc1a04c3bbb..40489c3e62f 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion_aux.mli +++ b/middle_end/flambda2/from_lambda/closure_conversion_aux.mli @@ -14,6 +14,8 @@ (* *) (**************************************************************************) +module Uid = Shape.Uid + (** Environments and auxiliary structures used during closure conversion. *) module IR : sig @@ -23,7 +25,7 @@ module IR : sig type exn_continuation = { exn_handler : Continuation.t; - extra_args : (simple * Flambda_kind.With_subkind.t) list + extra_args : (simple * Flambda_uid.t * Flambda_kind.With_subkind.t) list } type trap_action = @@ -144,7 +146,8 @@ module Env : sig val add_vars_like : t -> - (Ident.t * IR.user_visible * Flambda_kind.With_subkind.t) list -> + (Ident.t * Flambda_uid.t * IR.user_visible * Flambda_kind.With_subkind.t) + list -> t * Variable.t list val find_name : t -> Ident.t -> Name.t @@ -340,6 +343,7 @@ module Function_decls : sig type param = { name : Ident.t; + var_uid : Flambda_uid.t; kind : Flambda_kind.With_subkind.t; attributes : Lambda.parameter_attribute; mode : Lambda.locality_mode @@ -347,6 +351,7 @@ module Function_decls : sig val create : let_rec_ident:Ident.t option -> + let_rec_uid:Flambda_uid.t -> function_slot:Function_slot.t -> kind:Lambda.function_kind -> params:param list -> diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml index de9e1f4c2f0..aceab5a2711 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml @@ -56,7 +56,7 @@ let name_for_function (func : Lambda.lfunction) = let extra_args_for_exn_continuation env exn_handler = List.map - (fun (ident, kind) -> IR.Var ident, kind) + (fun (ident, duid, kind) -> IR.Var ident, duid, kind) (Env.extra_args_for_continuation_with_kinds env exn_handler) let _print_stack ppf stack = @@ -136,12 +136,15 @@ let compile_staticfail acc env ccenv ~(continuation : Continuation.t) ~args : in fun acc ccenv -> CC.close_let acc ccenv - [Ident.create_local "unit", Flambda_kind.With_subkind.tagged_immediate] + [ ( Ident.create_local "unit", + Flambda_uid.internal_not_actually_unique (* CR sspies: fix *), + Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region { is_try_region = false; region; ghost = false }) ~body:(fun acc ccenv -> CC.close_let acc ccenv [ ( Ident.create_local "unit", + Flambda_uid.internal_not_actually_unique, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region @@ -195,13 +198,14 @@ let let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler in let handler_env, params_rev = List.fold_left - (fun (handler_env, params_rev) (id, visible, layout) -> + (fun (handler_env, params_rev) (id, duid, visible, layout) -> let arity_component = Flambda_arity.Component_for_creation.from_lambda layout in match arity_component with | Singleton kind -> - let param = id, visible, kind in + let duid = Flambda_uid.uid duid in + let param = id, duid, visible, kind in handler_env, param :: params_rev | Unboxed_product _ -> let arity = Flambda_arity.create [arity_component] in @@ -212,7 +216,8 @@ let let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler Ident.create_local (Printf.sprintf "%s_unboxed%d" (Ident.unique_name id) n) in - field, kind) + let field_uid = Flambda_uid.proj duid ~field:n in + field, field_uid, kind) (Flambda_arity.unarize arity) in let handler_env = @@ -220,7 +225,9 @@ let let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler ~unboxed_product:id ~before_unarization:arity_component ~fields in let new_params_rev = - List.map (fun (id, kind) -> id, IR.Not_user_visible, kind) fields + List.map + (fun (id, duid, kind) -> id, duid, IR.Not_user_visible, kind) + fields |> List.rev in handler_env, new_params_rev @ params_rev) @@ -228,7 +235,9 @@ let let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler in let params = List.rev params_rev in let extra_params = - List.map (fun (id, kind) -> id, is_user_visible env id, kind) extra_params + List.map + (fun (id, duid, kind) -> id, duid, is_user_visible env id, kind) + extra_params in let handler acc ccenv = handler acc handler_env ccenv in let body acc ccenv = body acc body_env ccenv cont in @@ -270,12 +279,15 @@ let restore_continuation_context acc env ccenv cont ~close_current_region_early Env.Region_stack_element.ghost_region region_stack_elt in CC.close_let acc ccenv - [Ident.create_local "unit", Flambda_kind.With_subkind.tagged_immediate] + [ ( Ident.create_local "unit", + Flambda_uid.internal_not_actually_unique (* CR sspies: fix *), + Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region { is_try_region = false; region; ghost = false }) ~body:(fun acc ccenv -> CC.close_let acc ccenv [ ( Ident.create_local "unit", + Flambda_uid.internal_not_actually_unique (* CR sspies: fix*), Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region @@ -360,7 +372,10 @@ let wrap_return_continuation acc env ccenv (apply : IR.apply) = let params = List.map2 (fun return_value_component kind -> - return_value_component, IR.Not_user_visible, kind) + ( return_value_component, + Flambda_uid.internal_not_actually_unique, + IR.Not_user_visible, + kind )) return_value_components return_kinds in CC.close_let_cont acc ccenv ~name:wrapper_cont ~is_exn_handler:false @@ -402,7 +417,7 @@ let apply_cps_cont k ?dbg acc env ccenv id let get_unarized_vars id env = match Env.get_unboxed_product_fields env id with | None -> [IR.Var id] - | Some (_, fields) -> List.map (fun id -> IR.Var id) fields + | Some (_, fields) -> List.map (fun (id, _) -> IR.Var id) fields let maybe_insert_let_cont result_var_name layout k acc env ccenv body = match k with @@ -420,9 +435,10 @@ let maybe_insert_let_cont result_var_name layout k acc env ccenv body = ~body else let result_var = Ident.create_local result_var_name in + let duid = Shape.Uid.internal_not_actually_unique in let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler:false - ~params:[result_var, IR.Not_user_visible, layout] + ~params:[result_var, duid, IR.Not_user_visible, layout] ~handler:(fun acc env ccenv -> k acc env ccenv (get_unarized_vars result_var env) arity_component) ~body @@ -432,8 +448,9 @@ let name_if_not_var acc ccenv name simple kind body = | IR.Var id -> body id acc ccenv | IR.Const _ -> let id = Ident.create_local name in + let duid = Flambda_uid.internal_not_actually_unique in CC.close_let acc ccenv - [id, kind] + [id, duid, kind] Not_user_visible (IR.Simple simple) ~body:(body id) let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) @@ -453,14 +470,14 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) in apply_cps_cont k acc env ccenv id arity_component | Some (before_unarization, fields) -> - let fields = List.map (fun id -> IR.Var id) fields in + let fields = List.map (fun (id, _) -> IR.Var id) fields in apply_cps_cont_simple k acc env ccenv fields before_unarization) | Lmutvar id -> let new_ids_with_kinds, before_unarization = Env.get_mutable_variable_with_kinds env id in let fields = - List.map (fun id -> IR.Var id) (List.map fst new_ids_with_kinds) + List.map (fun (id, _, _) -> IR.Var id) new_ids_with_kinds in apply_cps_cont_simple k acc env ccenv fields before_unarization | Lconst const -> @@ -490,7 +507,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let id = Ident.create_local (name_for_function func) in let dbg = Debuginfo.from_location func.loc in let func = - cps_function env ~fid:id ~recursive:(Non_recursive : Recursive.t) func + cps_function env ~fid:id ~fuid:Flambda_uid.internal_not_actually_unique + ~recursive:(Non_recursive : Recursive.t) + func in let body acc ccenv = apply_cps_cont k ~dbg acc env ccenv id @@ -499,12 +518,12 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) CC.close_let_rec acc ccenv ~function_declarations:[func] ~body ~current_region: (Env.current_region env |> Option.map Env.Region_stack_element.region) - | Lmutlet (layout, id, _duid, defining_expr, body) -> - (* CR sspies: dropping [debug_uid]; address in subsequent PR. *) + | Lmutlet (layout, id, duid, defining_expr, body) -> (* CR mshinwell: user-visibleness needs thinking about here *) let temp_id = Ident.create_local "let_mutable" in let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler:false - ~params:[temp_id, IR.Not_user_visible, layout] + ~params:[temp_id, duid, IR.Not_user_visible, layout] + (* CR sspies: Probably not where we want the duid to end up. *) ~body:(fun acc env ccenv after_defining_expr -> cps_tail acc env ccenv defining_expr after_defining_expr k_exn) ~handler:(fun acc env ccenv -> @@ -518,7 +537,8 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let temp_id_unarized : Ident.t list = match Env.get_unboxed_product_fields env temp_id with | None -> [temp_id] - | Some (_, temp_id_unarized) -> temp_id_unarized + | Some (_, temp_id_unarized) -> List.map fst temp_id_unarized + (* CR sspies: Probably not what we want to do here. *) in List.fold_left2 (fun body new_id_with_kind temp_id acc ccenv -> @@ -542,9 +562,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) body bindings in let_expr acc ccenv - | Llet ((Strict | Alias | StrictOpt), layout, id, _duid, Lconst const, body) - -> - (* CR sspies: dropping [debug_uid]; address in subsequent PR. *) + | Llet ((Strict | Alias | StrictOpt), layout, id, duid, Lconst const, body) -> (* This case avoids extraneous continuations. *) let body acc ccenv = cps acc env ccenv body k k_exn in let kind = @@ -552,7 +570,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) layout in CC.close_let acc ccenv - [id, kind] + [id, Flambda_uid.uid duid, kind] (is_user_visible env id) (Simple (Const const)) ~body | Llet ( ((Strict | Alias | StrictOpt) as let_kind), @@ -587,6 +605,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) -> ( env, [ ( id, + Flambda_uid.uid duid, Flambda_kind.With_subkind .from_lambda_values_and_unboxed_numbers_only layout ) ] ) | Punboxed_product layouts -> @@ -596,7 +615,10 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) layouts) in let arity = Flambda_arity.create [arity_component] in - let fields = Flambda_arity.fresh_idents_unarized ~id arity in + let fields = + Flambda_arity.fresh_idents_unarized ~id arity + |> Flambda_uid.add_proj_debugging_uids_to_fields ~duid + in let env = Env.register_unboxed_product_with_kinds env ~unboxed_product:id ~before_unarization:arity_component ~fields @@ -622,10 +644,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) ( (Strict | Alias | StrictOpt), _, id, - _duid, + duid, Lassign (being_assigned, new_value), body ) -> - (* CR sspies: dropping [debug_uid]; address in subsequent PR. *) (* This case is also to avoid extraneous continuations in code that relies on the ref-conversion optimisation. *) if not (Env.is_mutable env being_assigned) @@ -638,7 +659,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let body acc ccenv = let body acc ccenv = cps acc env ccenv body k k_exn in CC.close_let acc ccenv - [id, Flambda_kind.With_subkind.tagged_immediate] + [ ( id, + Flambda_uid.uid duid, + Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (Simple (Const L.const_unit)) ~body in let new_ids_with_kinds, _before_unarization = @@ -658,11 +681,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) when translating primitives (see the Lprim case below). *) (* This case must not be moved above the case for let-bound primitives. *) cps acc env ccenv defining_expr k k_exn - | Llet ((Strict | Alias | StrictOpt), layout, id, _duid, defining_expr, body) - -> - (* CR sspies: dropping [debug_uid]; address in subsequent PR. *) + | Llet ((Strict | Alias | StrictOpt), layout, id, duid, defining_expr, body) -> let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler:false - ~params:[id, is_user_visible env id, layout] + ~params:[id, duid, is_user_visible env id, layout] ~body:(fun acc env ccenv after_defining_expr -> cps_tail acc env ccenv defining_expr after_defining_expr k_exn) ~handler:(fun acc env ccenv -> cps acc env ccenv body k k_exn) @@ -771,10 +792,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) in let handler_env, args = List.fold_left_map - (fun handler_env ((arg, _duid, layout), kinds) -> - (* CR sspies: dropping [debug_uid]; address in subsequent PR. *) + (fun handler_env ((arg, duid, layout), kinds) -> match kinds with - | [kind] -> handler_env, [arg, kind] + | [kind] -> handler_env, [arg, Flambda_uid.uid duid, kind] | [] | _ :: _ -> let fields = List.mapi @@ -784,7 +804,8 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) (Printf.sprintf "%s_unboxed%d" (Ident.unique_name arg) n) in - ident, kind) + let duid = Flambda_uid.proj duid ~field:n in + ident, duid, kind) kinds in let before_unarization = @@ -798,7 +819,8 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) in ( handler_env, List.map - (fun (arg, kind) -> arg, is_user_visible env arg, kind) + (fun (arg, duid, kind) -> + arg, duid, is_user_visible env arg, kind) (List.flatten args @ extra_params) ) in let handler acc ccenv = @@ -879,12 +901,17 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let ccenv = CCenv.set_not_at_toplevel ccenv in let handler k acc env ccenv = CC.close_let acc ccenv - [Ident.create_local "unit", Flambda_kind.With_subkind.tagged_immediate] + [ ( Ident.create_local "unit", + Flambda_uid.internal_not_actually_unique, + Flambda_kind.With_subkind.tagged_immediate ) ] + (* CR sspies: can we do better? *) Not_user_visible (End_region { is_try_region = true; region; ghost = false }) ~body:(fun acc ccenv -> CC.close_let acc ccenv [ ( Ident.create_local "unit", + Flambda_uid.internal_not_actually_unique, + (* CR sspies: can we do better? *) Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region @@ -894,7 +921,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let region_stack_elt = Env.current_region env in let begin_try_region body = CC.close_let acc ccenv - [region, Flambda_kind.With_subkind.region] + [ ( region, + Flambda_uid.internal_not_actually_unique, + Flambda_kind.With_subkind.region ) ] Not_user_visible (Begin_region { is_try_region = true; @@ -904,7 +933,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) }) ~body:(fun acc ccenv -> CC.close_let acc ccenv - [ghost_region, Flambda_kind.With_subkind.region] + [ ( ghost_region, + Flambda_uid.internal_not_actually_unique, + Flambda_kind.With_subkind.region ) ] Not_user_visible (Begin_region { is_try_region = true; @@ -920,11 +951,21 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) (fun acc env ccenv k -> let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler:true - ~params:[id, is_user_visible env id, Lambda.layout_block] + ~params: + [ ( id, + (* CR mshinwell: there should be a Uid here, needs adding to + Ltrywith *) + Shape.Uid.internal_not_actually_unique, + is_user_visible env id, + Lambda.layout_block ) ] ~body:(fun acc env ccenv handler_continuation -> let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler:false - ~params:[body_result, Not_user_visible, kind] + ~params: + [ ( body_result, + Shape.Uid.internal_not_actually_unique, + Not_user_visible, + kind ) ] ~body:(fun acc env ccenv poptrap_continuation -> let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler:false ~params:[] @@ -1011,12 +1052,16 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let region = Env.Region_stack_element.region current_region in let ghost_region = Env.Region_stack_element.ghost_region current_region in CC.close_let acc ccenv - [Ident.create_local "unit", Flambda_kind.With_subkind.tagged_immediate] + [ ( Ident.create_local "unit", + Flambda_uid.internal_not_actually_unique, + Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region { is_try_region = false; region; ghost = false }) ~body:(fun acc ccenv -> CC.close_let acc ccenv - [Ident.create_local "unit", Flambda_kind.With_subkind.tagged_immediate] + [ ( Ident.create_local "unit", + Flambda_uid.internal_not_actually_unique (* CR sspies: fix *), + Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region { is_try_region = false; region = ghost_region; ghost = true }) @@ -1035,7 +1080,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) in let dbg = Debuginfo.none in CC.close_let acc ccenv - [region, Flambda_kind.With_subkind.region] + [ ( region, + Flambda_uid.internal_not_actually_unique, + Flambda_kind.With_subkind.region ) ] Not_user_visible (Begin_region { is_try_region = false; @@ -1045,7 +1092,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) }) ~body:(fun acc ccenv -> CC.close_let acc ccenv - [ghost_region, Flambda_kind.With_subkind.region] + [ ( ghost_region, + Flambda_uid.internal_not_actually_unique (* CR sspies: fix *), + Flambda_kind.With_subkind.region ) ] Not_user_visible (Begin_region { is_try_region = false; @@ -1058,9 +1107,11 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) maybe_insert_let_cont "body_return" layout k acc env ccenv (fun acc env ccenv k -> let wrap_return = Ident.create_local "region_return" in + let wrap_return_duid = Lambda.debug_uid_none in let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler:false - ~params:[wrap_return, Not_user_visible, layout] + ~params: + [wrap_return, wrap_return_duid, Not_user_visible, layout] ~body:(fun acc env ccenv continuation_closing_region -> (* We register this region to be closed by the newly-created region closure continuation. When we reach a point in @@ -1093,6 +1144,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) ~handler:(fun acc env ccenv -> CC.close_let acc ccenv [ ( Ident.create_local "unit", + Flambda_uid.internal_not_actually_unique, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region @@ -1100,6 +1152,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) ~body:(fun acc ccenv -> CC.close_let acc ccenv [ ( Ident.create_local "unit", + Flambda_uid.internal_not_actually_unique, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region @@ -1244,11 +1297,10 @@ and cps_function_bindings env (bindings : Lambda.rec_binding list) = Simplif.split_default_wrapper ~id:fun_id ~debug_uid:fun_duid ~kind ~params ~body:fbody ~return ~attr ~loc ~ret_mode ~mode with - (* CR sspies: dropping [debug_uid]; address in subsequent PR. *) - | [{ id; debug_uid = _duid; def = lfun }] -> [id, lfun] - | [ { id = id1; debug_uid = _duid1; def = lfun1 }; - { id = id2; debug_uid = _duid2; def = lfun2 } ] -> - [id1, lfun1; id2, lfun2] + | [{ id; debug_uid = duid; def = lfun }] -> [id, duid, lfun] + | [{ id = id1; debug_uid = duid1; def = lfun1 }; + { id = id2; debug_uid = duid2; def = lfun2 }] -> + [id1, duid1, lfun1; id2, duid2, lfun2] | [] | _ :: _ :: _ :: _ -> Misc.fatal_errorf "Unexpected return value from [split_default_wrapper] when \ @@ -1261,7 +1313,7 @@ and cps_function_bindings env (bindings : Lambda.rec_binding list) = Ident.Set.of_list (List.map (fun { L.id; _ } -> id) bindings) in List.fold_left - (fun (free_ids, graph) (fun_id, ({ body; _ } : L.lfunction)) -> + (fun (free_ids, graph) (fun_id, _fun_uid, ({ body; _ } : L.lfunction)) -> let free_ids_of_body = Lambda.free_variables body in let free_ids = Ident.Map.add fun_id free_ids_of_body free_ids in let free_fun_ids = Ident.Set.inter fun_ids free_ids_of_body in @@ -1289,13 +1341,15 @@ and cps_function_bindings env (bindings : Lambda.rec_binding list) = in let bindings_with_wrappers = List.flatten bindings_with_wrappers in List.map - (fun (fun_id, def) -> - cps_function env ~fid:fun_id ~recursive:(recursive fun_id) + (fun (fun_id, fun_uid, def) -> + let fuid = Flambda_uid.uid fun_uid in + cps_function env ~fid:fun_id ~fuid ~recursive:(recursive fun_id) ~precomputed_free_idents:(Ident.Map.find fun_id free_idents) def) bindings_with_wrappers -and cps_function env ~fid ~(recursive : Recursive.t) ?precomputed_free_idents +and cps_function env ~fid ~fuid ~(recursive : Recursive.t) + ?precomputed_free_idents ({ kind; params; return; body; attr; loc; mode; ret_mode } : L.lfunction) : Function_decl.t = let contains_no_escaping_local_allocs = @@ -1458,20 +1512,22 @@ and cps_function env ~fid ~(recursive : Recursive.t) ?precomputed_free_idents let unboxed_products = ref Ident.Map.empty in let params = List.concat_map - (fun ( ({ name; debug_uid = _; layout; mode; attributes } : L.lparam), - kinds ) : Function_decl.param list -> - (* CR sspies: dropping [debug_uid]; address in subsequent PR. *) + (fun (({ name; debug_uid = var_uid; layout; mode; attributes } : L.lparam), kinds) : + Function_decl.param list -> match kinds with - | [kind] -> [{ name; kind; mode; attributes }] + | [kind] -> + let var_uid = Flambda_uid.uid var_uid in + [{ name; var_uid; kind; mode; attributes }] | [] | _ :: _ -> let fields = List.mapi (fun n kind -> + let duid = Flambda_uid.proj var_uid ~field:n in let ident = Ident.create_local (Printf.sprintf "%s_unboxed%d" (Ident.unique_name name) n) in - ident, kind) + ident, duid, kind) kinds in let before_unarization = @@ -1480,8 +1536,8 @@ and cps_function env ~fid ~(recursive : Recursive.t) ?precomputed_free_idents unboxed_products := Ident.Map.add name (before_unarization, fields) !unboxed_products; List.map - (fun (name, kind) : Function_decl.param -> - { name; kind; mode; attributes }) + (fun (name, var_uid, kind) : Function_decl.param -> + { name; var_uid; kind; mode; attributes }) fields) (List.combine params unarized_per_param) in @@ -1507,9 +1563,10 @@ and cps_function env ~fid ~(recursive : Recursive.t) ?precomputed_free_idents match Env.get_unboxed_product_fields env id with | None -> new_env, Ident.Set.add id free_idents_of_body | Some (before_unarization, fields) -> + let field_ids = List.map fst fields in ( Env.register_unboxed_product new_env ~unboxed_product:id ~before_unarization ~fields, - Ident.Set.union free_idents_of_body (Ident.Set.of_list fields) )) + Ident.Set.union free_idents_of_body (Ident.Set.of_list field_ids) )) free_idents_of_body (new_env, Ident.Set.empty) in let body acc ccenv = @@ -1517,11 +1574,11 @@ and cps_function env ~fid ~(recursive : Recursive.t) ?precomputed_free_idents let ccenv = CCenv.set_not_at_toplevel ccenv in cps_tail acc new_env ccenv body body_cont body_exn_cont in - Function_decl.create ~let_rec_ident:(Some fid) ~function_slot ~kind ~params - ~params_arity ~removed_params ~return ~calling_convention - ~return_continuation:body_cont ~exn_continuation ~my_region ~my_ghost_region - ~body ~attr ~loc ~free_idents_of_body recursive ~closure_alloc_mode:mode - ~first_complex_local_param ~result_mode:ret_mode + Function_decl.create ~let_rec_ident:(Some fid) ~let_rec_uid:fuid + ~function_slot ~kind ~params ~params_arity ~removed_params ~return + ~calling_convention ~return_continuation:body_cont ~exn_continuation + ~my_region ~my_ghost_region ~body ~attr ~loc ~free_idents_of_body recursive + ~closure_alloc_mode:mode ~first_complex_local_param ~result_mode:ret_mode and cps_switch acc env ccenv (switch : L.lambda_switch) ~condition_dbg ~scrutinee (k : Continuation.t) (k_exn : Continuation.t) : Expr_with_acc.t = @@ -1635,7 +1692,9 @@ and cps_switch acc env ccenv (switch : L.lambda_switch) ~condition_dbg CC.close_switch acc ccenv ~condition_dbg scrutinee_tag block_switch in CC.close_let acc ccenv - [scrutinee_tag, Flambda_kind.With_subkind.tagged_immediate] + [ ( scrutinee_tag, + Flambda_uid.internal_not_actually_unique, + Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (Get_tag scrutinee) ~body in if switch.sw_numblocks = 0 @@ -1667,7 +1726,9 @@ and cps_switch acc env ccenv (switch : L.lambda_switch) ~condition_dbg Option.map Env.Region_stack_element.ghost_region current_region in CC.close_let acc ccenv - [is_scrutinee_int, Flambda_kind.With_subkind.tagged_immediate] + [ ( is_scrutinee_int, + Flambda_uid.internal_not_actually_unique, + Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (Prim { prim = Pisint { variant_only = true }; diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda_env.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda_env.ml index 5e64c4c7ddc..156325e6f63 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_env.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_env.ml @@ -71,12 +71,13 @@ end type t = { current_unit : Compilation_unit.t; current_values_of_mutables_in_scope : - ((Ident.t * Flambda_kind.With_subkind.full_kind) list + ((Ident.t * Flambda_uid.t * Flambda_kind.With_subkind.full_kind) list * [`Complex] Flambda_arity.Component_for_creation.t) Ident.Map.t; mutables_needed_by_continuations : Ident.Set.t Continuation.Map.t; unboxed_product_components_in_scope : - ([`Complex] Flambda_arity.Component_for_creation.t * Ident.t list) + ([`Complex] Flambda_arity.Component_for_creation.t + * (Ident.t * Flambda_uid.t) list) Ident.Map.t; try_stack : Continuation.t list; try_stack_at_handler : Continuation.t list Continuation.Map.t; @@ -125,6 +126,9 @@ let register_mutable_variable t id ~before_unarization = let fields = Flambda_arity.fresh_idents_unarized ~id (Flambda_arity.create [before_unarization]) + |> Flambda_uid.add_proj_debugging_uids_to_fields ~duid:Lambda.debug_uid_none + (* CR sspies: We should propagate the debugging uid here for mutable + variables. *) in let current_values_of_mutables_in_scope = Ident.Map.add id @@ -142,6 +146,10 @@ let update_mutable_variable t id = let fields = Flambda_arity.fresh_idents_unarized ~id (Flambda_arity.create [before_unarization]) + |> Flambda_uid.add_proj_debugging_uids_to_fields + ~duid:Lambda.debug_uid_none + (* CR sspies: We should derive/copy the debugging uids here from + before_unarization/old_ids_and_kinds. *) in let current_values_of_mutables_in_scope = Ident.Map.add id @@ -163,12 +171,12 @@ let register_unboxed_product t ~unboxed_product ~before_unarization ~fields = let register_unboxed_product_with_kinds t ~unboxed_product ~before_unarization ~fields = register_unboxed_product t ~unboxed_product ~before_unarization - ~fields:(List.map fst fields) + ~fields:(List.map (fun (id, duid, _) -> id, duid) fields) type add_continuation_result = { body_env : t; handler_env : t; - extra_params : (Ident.t * Flambda_kind.With_subkind.t) list + extra_params : (Ident.t * Flambda_uid.t * Flambda_kind.With_subkind.t) list } let add_continuation t cont ~push_to_try_stack ~pop_region @@ -204,6 +212,10 @@ let add_continuation t cont ~push_to_try_stack ~pop_region let fields = Flambda_arity.fresh_idents_unarized ~id:mut_var (Flambda_arity.create [before_unarization]) + |> Flambda_uid.add_proj_debugging_uids_to_fields + ~duid:Lambda.debug_uid_none + (* CR sspies: We should derive/copy the debugging uids here from + before_unarization/old_ids_and_kinds. *) in fields, before_unarization) t.current_values_of_mutables_in_scope @@ -291,7 +303,9 @@ let extra_args_for_continuation_with_kinds t cont = mutables let extra_args_for_continuation t cont = - List.map fst (extra_args_for_continuation_with_kinds t cont) + List.map + (fun (arg, _, _) -> arg) + (extra_args_for_continuation_with_kinds t cont) let get_mutable_variable_with_kinds t id = match Ident.Map.find id t.current_values_of_mutables_in_scope with diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda_env.mli b/middle_end/flambda2/from_lambda/lambda_to_flambda_env.mli index 751b3a7fe6f..c922ca10229 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_env.mli +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_env.mli @@ -45,7 +45,7 @@ val register_mutable_variable : t -> Ident.t -> before_unarization:[`Complex] Flambda_arity.Component_for_creation.t -> - t * (Ident.t * Flambda_kind.With_subkind.full_kind) list + t * (Ident.t * Flambda_uid.t * Flambda_kind.With_subkind.full_kind) list val update_mutable_variable : t -> Ident.t -> t @@ -53,25 +53,27 @@ val register_unboxed_product : t -> unboxed_product:Ident.t -> before_unarization:[`Complex] Flambda_arity.Component_for_creation.t -> - fields:Ident.t list -> + fields:(Ident.t * Flambda_uid.t) list -> t val register_unboxed_product_with_kinds : t -> unboxed_product:Ident.t -> before_unarization:[`Complex] Flambda_arity.Component_for_creation.t -> - fields:(Ident.t * Flambda_kind.With_subkind.t) list -> + fields:(Ident.t * Flambda_uid.t * Flambda_kind.With_subkind.t) list -> t val get_unboxed_product_fields : t -> Ident.t -> - ([`Complex] Flambda_arity.Component_for_creation.t * Ident.t list) option + ([`Complex] Flambda_arity.Component_for_creation.t + * (Ident.t * Flambda_uid.t) list) + option type add_continuation_result = private { body_env : t; handler_env : t; - extra_params : (Ident.t * Flambda_kind.With_subkind.t) list + extra_params : (Ident.t * Flambda_uid.t * Flambda_kind.With_subkind.t) list } val add_continuation : @@ -98,12 +100,14 @@ val get_try_stack_at_handler : t -> Continuation.t -> Continuation.t list val extra_args_for_continuation : t -> Continuation.t -> Ident.t list val extra_args_for_continuation_with_kinds : - t -> Continuation.t -> (Ident.t * Flambda_kind.With_subkind.t) list + t -> + Continuation.t -> + (Ident.t * Flambda_uid.t * Flambda_kind.With_subkind.t) list val get_mutable_variable_with_kinds : t -> Ident.t -> - (Ident.t * Flambda_kind.With_subkind.t) list + (Ident.t * Flambda_uid.t * Flambda_kind.With_subkind.t) list * [`Complex] Flambda_arity.Component_for_creation.t (** About local allocation regions: diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives_helpers.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives_helpers.ml index 420b92ef45c..96b180f6f7b 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives_helpers.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives_helpers.ml @@ -308,7 +308,10 @@ let rec bind_recs acc exn_cont ~register_const0 (prim : expr_primitive) ~body ~is_exn_handler:false ~is_cold:false | If_then_else (cond, ifso, ifnot, result_kinds) -> let cond_result = Variable.create "cond_result" in - let cond_result_pat = Bound_var.create cond_result Name_mode.normal in + let cond_result_pat = + Bound_var.create cond_result Flambda_uid.internal_not_actually_unique + Name_mode.normal + in let ifso_cont = Continuation.create () in let ifnot_cont = Continuation.create () in let join_point_cont = Continuation.create () in @@ -318,7 +321,8 @@ let rec bind_recs acc exn_cont ~register_const0 (prim : expr_primitive) let result_params = List.map2 (fun result_var result_kind -> - Bound_parameter.create result_var result_kind) + Bound_parameter.create result_var result_kind + Flambda_uid.internal_not_actually_unique (* CR sspies: new *)) result_vars result_kinds in let result_simples = List.map Simple.var result_vars in @@ -349,7 +353,9 @@ let rec bind_recs acc exn_cont ~register_const0 (prim : expr_primitive) in let result_pats = List.map - (fun result_var -> Bound_var.create result_var Name_mode.normal) + (fun result_var -> + Bound_var.create result_var Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) Name_mode.normal) result_vars in let result_simples = List.map Simple.var result_vars in @@ -388,7 +394,9 @@ let rec bind_recs acc exn_cont ~register_const0 (prim : expr_primitive) (fun acc nameds -> let named = must_be_singleton_named nameds in let pat = - Bound_var.create (Variable.create "seq") Name_mode.normal + Bound_var.create (Variable.create "seq") + Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) Name_mode.normal |> Bound_pattern.singleton in Let_with_acc.create acc pat named ~body)) @@ -410,7 +418,13 @@ and bind_rec_primitive acc exn_cont ~register_const0 (prim : simple_or_prim) | Prim p -> let cont acc (nameds : Named.t list) = let vars = List.map (fun _ -> Variable.create "prim") nameds in - let vars' = List.map (fun var -> VB.create var Name_mode.normal) vars in + let vars' = + List.map + (fun var -> + VB.create var Flambda_uid.internal_not_actually_unique + Name_mode.normal) + vars + in let acc, body = cont acc (List.map Simple.var vars) in List.fold_left2 (fun (acc, body) pat prim -> diff --git a/middle_end/flambda2/identifiers/flambda_uid.ml b/middle_end/flambda2/identifiers/flambda_uid.ml new file mode 100644 index 00000000000..d3b39db6090 --- /dev/null +++ b/middle_end/flambda2/identifiers/flambda_uid.ml @@ -0,0 +1,65 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 2023 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module Uid = Shape.Uid + +type t = + | Uid of Uid.t + | Proj of Uid.t * int + +let internal_not_actually_unique = Uid Uid.internal_not_actually_unique + +let uid u = Uid u + +let proj u ~field = Proj (u, field) + +let add_proj_debugging_uids_to_fields ~duid fields = + List.mapi (fun i (id, kind) -> id, proj duid ~field:i, kind) fields + +module T0 = struct + type nonrec t = t + + let print ppf t = + match t with + | Uid uid -> Format.fprintf ppf "@[(uid@ %a)@]" Uid.print uid + | Proj (uid, field) -> + Format.fprintf ppf + "@[(@[(uid@ %a)@]@ @[(field@ %d)@])@]" Uid.print + uid field + + let compare t1 t2 = + match t1, t2 with + | Uid uid1, Uid uid2 -> Uid.compare uid1 uid2 + | Proj (uid1, field1), Proj (uid2, field2) -> + let c = Uid.compare uid1 uid2 in + if c <> 0 then c else Int.compare field1 field2 + | Uid _, Proj _ -> -1 + | Proj _, Uid _ -> 1 + + let equal t1 t2 = + match t1, t2 with + | Uid uid1, Uid uid2 -> Uid.equal uid1 uid2 + | Proj (uid1, field1), Proj (uid2, field2) -> + Uid.equal uid1 uid2 && Int.equal field1 field2 + | Uid _, Proj _ | Proj _, Uid _ -> false + + let hash t = + match t with + | Uid uid -> Hashtbl.hash (0, Uid.hash uid) + | Proj (uid, field) -> Hashtbl.hash (1, (Uid.hash uid, field)) + + let output _ _ = Misc.fatal_error "Not implemented" +end + +include Identifiable.Make (T0) diff --git a/middle_end/flambda2/identifiers/flambda_uid.mli b/middle_end/flambda2/identifiers/flambda_uid.mli new file mode 100644 index 00000000000..c1df376a7a3 --- /dev/null +++ b/middle_end/flambda2/identifiers/flambda_uid.mli @@ -0,0 +1,35 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 2023 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Augmented version of [Shape.Uid.t] that can track variables forming parts + of unboxed products. *) + +type t = private + | Uid of Shape.Uid.t + | Proj of Shape.Uid.t * int + +val internal_not_actually_unique : t + +val uid : Shape.Uid.t -> t + +val proj : Shape.Uid.t -> field:int -> t + +val add_proj_debugging_uids_to_fields : + duid:Lambda.debug_uid -> + (Ident.t * Flambda_kind.With_subkind.t) list -> + (Ident.t * t * Flambda_kind.With_subkind.t) list + + + +include Identifiable.S with type t := t diff --git a/middle_end/flambda2/parser/fexpr_to_flambda.ml b/middle_end/flambda2/parser/fexpr_to_flambda.ml index 3e197b18e82..8121ff7c21b 100644 --- a/middle_end/flambda2/parser/fexpr_to_flambda.ml +++ b/middle_end/flambda2/parser/fexpr_to_flambda.ml @@ -635,7 +635,11 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = let bound_vars, env = let convert_binding env (var, _) : Bound_var.t * env = let var, env = fresh_var env var in - let var = Bound_var.create var Name_mode.normal in + (* CR tnowak: verify *) + let var = + Bound_var.create var Flambda_uid.internal_not_actually_unique + Name_mode.normal + in var, env in map_accum_left convert_binding env vars_and_closure_bindings @@ -662,7 +666,10 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = let named = defining_expr env d in let id, env = fresh_var env var in let body = expr env body in - let var = Bound_var.create id Name_mode.normal in + let var = + Bound_var.create id Flambda_uid.internal_not_actually_unique + Name_mode.normal + in let bound = Bound_pattern.singleton var in Flambda.Let.create bound named ~body ~free_names_of_body:Unknown |> Flambda.Expr.create_let @@ -696,6 +703,8 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = let var, env = fresh_var env param in let param = Bound_parameter.create var (value_kind_with_subkind_opt kind) + Flambda_uid.internal_not_actually_unique + (* CR tnowak: verify *) in env, param :: args) params (env, []) @@ -919,7 +928,10 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = (fun env ({ param; kind } : Fexpr.kinded_parameter) -> let var, env = fresh_var env param in let param = - Bound_parameter.create var (value_kind_with_subkind_opt kind) + Bound_parameter.create var + (value_kind_with_subkind_opt kind) + Flambda_uid.internal_not_actually_unique + (* CR tnowak: verify *) in param, env) env params diff --git a/middle_end/flambda2/reaper/rebuild.ml b/middle_end/flambda2/reaper/rebuild.ml index dbc366cc33b..b143a6d1765 100644 --- a/middle_end/flambda2/reaper/rebuild.ml +++ b/middle_end/flambda2/reaper/rebuild.ml @@ -185,11 +185,12 @@ let get_parameters params_decisions = (fun acc param_decision -> match param_decision with | Delete -> acc - | Keep (var, kind) -> Bound_parameter.create var kind :: acc + | Keep (var, kind) -> Bound_parameter.create var kind Flambda_uid.internal_not_actually_unique :: acc | Unbox fields -> fold_unboxed_with_kind - (fun kind v acc -> Bound_parameter.create v (KS.anything kind) :: acc) + (fun kind v acc -> Bound_parameter.create v (KS.anything kind) Flambda_uid.internal_not_actually_unique :: acc) fields acc) + (* CR sspies: Fix these. Propagate debugging uids here. *) [] params_decisions |> List.rev @@ -198,12 +199,13 @@ let get_parameters_and_modes params_decisions modes = (fun acc (param_decision, mode) -> match param_decision with | Delete -> acc - | Keep (var, kind) -> (Bound_parameter.create var kind, mode) :: acc + | Keep (var, kind) -> (Bound_parameter.create var kind Flambda_uid.internal_not_actually_unique, mode) :: acc | Unbox fields -> fold_unboxed_with_kind (fun kind v acc -> - (Bound_parameter.create v (KS.anything kind), mode) :: acc) + (Bound_parameter.create v (KS.anything kind) Flambda_uid.internal_not_actually_unique, mode) :: acc) fields acc) + (* CR sspies: Fix these. Propagate debugging uids here. *) [] (List.combine params_decisions modes) |> List.rev |> List.split @@ -242,7 +244,8 @@ let bind_fields fields arg_fields hole = fold2_unboxed_subset (fun var arg hole -> let bp = - Bound_pattern.singleton (Bound_var.create var Name_mode.normal) + Bound_pattern.singleton (Bound_var.create var Flambda_uid.internal_not_actually_unique Name_mode.normal) + (* CR sspies: Fix these. Propagate debugging uids here. *) in RE.create_let bp (Named.create_simple (Simple.var arg)) ~body:hole) fields arg_fields hole @@ -1005,7 +1008,8 @@ let load_field_from_value_which_is_being_unboxed env ~to_bind field arg dbg fold2_unboxed_subset (fun var (field, kind) hole -> let bp = - Bound_pattern.singleton (Bound_var.create var Name_mode.normal) + Bound_pattern.singleton (Bound_var.create var Flambda_uid.internal_not_actually_unique Name_mode.normal) + (* CR sspies: Fix these. *) in let named = Named.create_prim @@ -1026,7 +1030,8 @@ let load_field_from_value_which_is_being_unboxed env ~to_bind field arg dbg fold2_unboxed_subset (fun var value_slot hole -> let bp = - Bound_pattern.singleton (Bound_var.create var Name_mode.normal) + Bound_pattern.singleton (Bound_var.create var Flambda_uid.internal_not_actually_unique Name_mode.normal) + (* CR sspies: Fix these. *) in let named = Named.create_prim @@ -1086,7 +1091,8 @@ let rebuild_singleton_binding_which_is_being_unboxed env bv | Unboxed _ -> Misc.fatal_errorf "Trying to unbox non-unboxable" in let bp = - Bound_pattern.singleton (Bound_var.create var Name_mode.normal) + Bound_pattern.singleton (Bound_var.create var Flambda_uid.internal_not_actually_unique Name_mode.normal) + (* CR sspies: Fix these. *) in RE.create_let bp (Named.create_simple simple) ~body:hole | Right arg_fields -> bind_fields var (Unboxed arg_fields) hole) @@ -1162,7 +1168,8 @@ let rebuild_set_of_closures_binding_which_is_being_unboxed env bvs in let bp = Bound_pattern.singleton - (Bound_var.create var Name_mode.normal) + (Bound_var.create var Flambda_uid.internal_not_actually_unique Name_mode.normal) + (* CR sspies: Fix these. *) in RE.create_let bp (Named.create_simple arg) ~body:hole | Block _ | Is_int | Get_tag | Function_slot _ | Code_of_closure @@ -1538,7 +1545,8 @@ and rebuild_holed (env : env) res (rev_expr : Rev_expr.rev_expr_holed) | Some fields -> fold_unboxed_with_kind (fun kind v acc -> - Bound_parameter.create v (KS.anything kind) :: acc) + Bound_parameter.create v (KS.anything kind) Flambda_uid.internal_not_actually_unique :: acc) + (* CR sspies: Fix these. *) fields []) l in @@ -1747,7 +1755,8 @@ and rebuild_function_params_and_body (env : env) res code_metadata | Some fields -> ( fold_unboxed_with_kind (fun kind v acc -> - Bound_parameter.create v (KS.anything kind) :: acc) + Bound_parameter.create v (KS.anything kind) Flambda_uid.internal_not_actually_unique :: acc) + (* CR sspies: Fix these. *) fields [], Code_metadata.with_is_my_closure_used false code_metadata ) in diff --git a/middle_end/flambda2/simplify/apply_cont_rewrite.ml b/middle_end/flambda2/simplify/apply_cont_rewrite.ml index 0904ea0eab9..1f154a5d745 100644 --- a/middle_end/flambda2/simplify/apply_cont_rewrite.ml +++ b/middle_end/flambda2/simplify/apply_cont_rewrite.ml @@ -177,7 +177,8 @@ let make_rewrite rewrite ~ctx id args : _ Or_invalid.t = simple, [], Simple.free_names simple, Name_occurrences.empty | New_let_binding (temp, prim) -> let extra_let = - ( Bound_var.create temp Name_mode.normal, + ( Bound_var.create temp Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) Name_mode.normal, Code_size.prim prim, Flambda.Named.create_prim prim Debuginfo.none ) in @@ -196,7 +197,8 @@ let make_rewrite rewrite ~ctx id args : _ Or_invalid.t = since they are already named." in let extra_let = - ( Bound_var.create temp Name_mode.normal, + ( Bound_var.create temp Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) Name_mode.normal, Code_size.prim prim, Flambda.Named.create_prim prim Debuginfo.none ) in diff --git a/middle_end/flambda2/simplify/common_subexpression_elimination.ml b/middle_end/flambda2/simplify/common_subexpression_elimination.ml index 87f480fb45f..7d901c105fd 100644 --- a/middle_end/flambda2/simplify/common_subexpression_elimination.ml +++ b/middle_end/flambda2/simplify/common_subexpression_elimination.ml @@ -261,7 +261,9 @@ let join_one_cse_equation ~cse_at_each_use prim bound_to_map let prim_result_kind = P.result_kind' (EP.to_primitive prim) in let var = Variable.create "cse_param" in let extra_param = - BP.create var (K.With_subkind.anything prim_result_kind) + BP.create var + (K.With_subkind.anything prim_result_kind) + Flambda_uid.internal_not_actually_unique (* CR tnowak: verify *) in let bound_to = RI.Map.map Rhs_kind.bound_to bound_to_map in let cse = EP.Map.add prim (Simple.var var) cse in diff --git a/middle_end/flambda2/simplify/env/downwards_env.ml b/middle_end/flambda2/simplify/env/downwards_env.ml index 3ac70c615f5..04ef067735f 100644 --- a/middle_end/flambda2/simplify/env/downwards_env.ml +++ b/middle_end/flambda2/simplify/env/downwards_env.ml @@ -171,7 +171,8 @@ let define_variable0 ~extra t var kind = let variables_defined_in_current_continuation = Lifted_cont_params.new_param ~replay_history variables_defined_in_current_continuation - (Bound_parameter.create (Bound_var.var var) kind) + (Bound_parameter.create (Bound_var.var var) kind + Flambda_uid.internal_not_actually_unique (* CR sspies: fix *)) in variables_defined_in_current_continuation :: r in @@ -232,9 +233,13 @@ let create ~round ~(resolver : resolver) in define_variable (define_variable t - (Bound_var.create toplevel_my_region Name_mode.normal) + (Bound_var.create toplevel_my_region + Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) Name_mode.normal) K.region) - (Bound_var.create toplevel_my_ghost_region Name_mode.normal) + (Bound_var.create toplevel_my_ghost_region + Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) Name_mode.normal) K.region let all_code t = t.all_code @@ -343,7 +348,8 @@ let define_name t name kind = Name.pattern_match (Bound_name.name name) ~var:(fun [@inline] var -> (define_variable [@inlined hint]) t - (Bound_var.create var (Bound_name.name_mode name)) + (Bound_var.create var Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) (Bound_name.name_mode name)) kind) ~symbol:(fun [@inline] sym -> (define_symbol [@inlined hint]) t sym kind) @@ -363,7 +369,10 @@ let add_symbol t sym ty = let add_name t name ty = Name.pattern_match (Bound_name.name name) ~var:(fun [@inline] var -> - add_variable t (Bound_var.create var (Bound_name.name_mode name)) ty) + add_variable t + (Bound_var.create var Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) (Bound_name.name_mode name)) + ty) ~symbol:(fun [@inline] sym -> add_symbol t sym ty) let add_equation_on_variable t var ty = @@ -402,7 +411,11 @@ let add_equation_on_name t name ty = let define_parameters ~extra t ~params = List.fold_left (fun t param -> - let var = Bound_var.create (BP.var param) Name_mode.normal in + let param_var, _param_uid = BP.var_and_uid param in + let var = + Bound_var.create param_var Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) Name_mode.normal + in define_variable0 ~extra t var (K.With_subkind.kind (BP.kind param))) t (Bound_parameters.to_list params) @@ -420,7 +433,11 @@ let add_parameters ~extra ?(name_mode = Name_mode.normal) t params ~param_types param_types; List.fold_left2 (fun t param param_type -> - let var = Bound_var.create (BP.var param) name_mode in + let param_var, _param_uid = BP.var_and_uid param in + let var = + Bound_var.create param_var Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) name_mode + in add_variable0 ~extra t var param_type) t params param_types diff --git a/middle_end/flambda2/simplify/expr_builder.ml b/middle_end/flambda2/simplify/expr_builder.ml index d93b9361ccc..5d5ac75a5e5 100644 --- a/middle_end/flambda2/simplify/expr_builder.ml +++ b/middle_end/flambda2/simplify/expr_builder.ml @@ -284,7 +284,9 @@ let create_coerced_singleton_let uacc var defining_expr (* Generate [let uncoerced_var = ] *) let ((_body, _uacc, outer_result) as outer) = let bound = - Bound_pattern.singleton (VB.create uncoerced_var name_mode) + Bound_pattern.singleton + (VB.create uncoerced_var Flambda_uid.internal_not_actually_unique + name_mode) in create_let uacc bound defining_expr ~free_names_of_defining_expr ~body ~cost_metrics_of_defining_expr @@ -569,7 +571,9 @@ let create_let_symbols uacc lifted_constant ~body = let free_names_of_defining_expr = Named.free_names defining_expr in let expr, uacc, _ = create_coerced_singleton_let uacc - (VB.create var Name_mode.normal) + (* CR tnowak: verify *) + (VB.create var Flambda_uid.internal_not_actually_unique + Name_mode.normal) defining_expr ~coercion_from_defining_expr_to_var ~free_names_of_defining_expr ~body:expr ~cost_metrics_of_defining_expr in @@ -817,12 +821,12 @@ let rewrite_fixed_arity_continuation0 uacc cont_or_apply_cont ~use_id arity : binds [kinded_params]. *) let params = List.map - (fun _kind -> Variable.create "param") + (fun kind -> + BP.create (Variable.create "param") kind + Flambda_uid.internal_not_actually_unique + (* CR tnowak: verify *)) (Flambda_arity.unarized_components arity) in - let params = - List.map2 BP.create params (Flambda_arity.unarized_components arity) - in let args = List.map BP.simple params in let params = Bound_parameters.create params in let apply_cont = Apply_cont.create cont ~args ~dbg:Debuginfo.none in diff --git a/middle_end/flambda2/simplify/flow/mutable_unboxing.ml b/middle_end/flambda2/simplify/flow/mutable_unboxing.ml index 8d2bd10573a..adfb854f7d1 100644 --- a/middle_end/flambda2/simplify/flow/mutable_unboxing.ml +++ b/middle_end/flambda2/simplify/flow/mutable_unboxing.ml @@ -484,7 +484,9 @@ module Fold_prims = struct "[Mutable Unboxing] Cannot unbox constants") in let var = Variable.create (Printf.sprintf "%s_%i" name i) in - Bound_parameter.create var kind) + Bound_parameter.create var kind + Flambda_uid.internal_not_actually_unique + (* CR tnowak: verify *)) fields_kinds in let env = diff --git a/middle_end/flambda2/simplify/inlining/inlining_transforms.ml b/middle_end/flambda2/simplify/inlining/inlining_transforms.ml index 8b562de9bf6..f572d53585d 100644 --- a/middle_end/flambda2/simplify/inlining/inlining_transforms.ml +++ b/middle_end/flambda2/simplify/inlining/inlining_transforms.ml @@ -46,6 +46,7 @@ let make_inlined_body ~callee ~called_code_id ~unroll_to ~params ~args in let my_closure = Bound_parameter.create my_closure Flambda_kind.With_subkind.any_value + Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe here? *) in let bind_params ~params ~args ~body = if List.compare_lengths params args <> 0 @@ -56,14 +57,19 @@ let make_inlined_body ~callee ~called_code_id ~unroll_to ~params ~args Simple.List.print args; ListLabels.fold_left2 (List.rev params) (List.rev args) ~init:body ~f:(fun expr param arg -> - let var = Bound_var.create (BP.var param) Name_mode.normal in + let param_var, param_uid = BP.var_and_uid param in + let var = Bound_var.create param_var param_uid Name_mode.normal in Let.create (Bound_pattern.singleton var) (Named.create_simple arg) ~body:expr ~free_names_of_body:Unknown |> Expr.create_let) in let bind_depth ~my_depth ~rec_info ~body = - let bound = Bound_pattern.singleton (VB.create my_depth Name_mode.normal) in + let bound = + Bound_pattern.singleton + (VB.create my_depth Flambda_uid.internal_not_actually_unique + Name_mode.normal) + in Let.create bound (Named.create_rec_info rec_info) ~body ~free_names_of_body:Unknown diff --git a/middle_end/flambda2/simplify/lifted_cont_params.ml b/middle_end/flambda2/simplify/lifted_cont_params.ml index 24dc2292825..ab53b063bbd 100644 --- a/middle_end/flambda2/simplify/lifted_cont_params.ml +++ b/middle_end/flambda2/simplify/lifted_cont_params.ml @@ -39,6 +39,7 @@ let new_param t ~replay_history bound_param = Variable.Map.find (BP.var bound_param) variable_mapping in BP.create original_var (BP.kind bound_param) + Flambda_uid.internal_not_actually_unique (* CR sspies: fix *) in let new_params_indexed = BP.Map.add key bound_param t.new_params_indexed in { len = t.len + 1; new_params_indexed } diff --git a/middle_end/flambda2/simplify/simplify_apply_cont_expr.ml b/middle_end/flambda2/simplify/simplify_apply_cont_expr.ml index b2f0a4080b9..06e750bdce2 100644 --- a/middle_end/flambda2/simplify/simplify_apply_cont_expr.ml +++ b/middle_end/flambda2/simplify/simplify_apply_cont_expr.ml @@ -42,8 +42,9 @@ let inline_linearly_used_continuation uacc ~params:params' ~handler let bindings_outermost_first = ListLabels.map2 params args ~f:(fun param arg -> let let_bound = - Bound_var.create (BP.var param) Name_mode.normal - |> Bound_pattern.singleton + let param_var, param_uid = BP.var_and_uid param in + Bound_var.create param_var param_uid Name_mode.normal + |> Bound_pattern.singleton in let named = Named.create_simple arg in { Expr_builder.let_bound; diff --git a/middle_end/flambda2/simplify/simplify_apply_expr.ml b/middle_end/flambda2/simplify/simplify_apply_expr.ml index 6d3a4f77659..ebe61a65c4f 100644 --- a/middle_end/flambda2/simplify/simplify_apply_expr.ml +++ b/middle_end/flambda2/simplify/simplify_apply_expr.ml @@ -164,7 +164,10 @@ let simplify_direct_tuple_application ~simplify_expr dacc apply let expr = List.fold_right (fun (v, defining_expr) body -> - let var_bind = Bound_var.create v Name_mode.normal in + let var_bind = + Bound_var.create v Flambda_uid.internal_not_actually_unique + Name_mode.normal + in Let.create (Bound_pattern.singleton var_bind) defining_expr ~body ~free_names_of_body:Unknown @@ -318,8 +321,9 @@ let simplify_direct_full_application ~simplify_expr dacc apply function_type let denv = List.fold_left2 (fun denv kind result -> + let result_var, result_uid = BP.var_and_uid result in DE.add_variable denv - (VB.create (BP.var result) NM.in_types) + (VB.create result_var result_uid NM.in_types) (T.unknown_with_subkind kind)) denv result_arity results in @@ -478,7 +482,8 @@ let simplify_direct_partial_application ~simplify_expr dacc apply List.map (fun kind -> let param = Variable.create "param" in - Bound_parameter.create param kind) + Bound_parameter.create param kind + Flambda_uid.internal_not_actually_unique (* CR sspies: fix *)) (Flambda_arity.unarize remaining_param_arity) |> Bound_parameters.create in @@ -604,7 +609,10 @@ let simplify_direct_partial_application ~simplify_expr dacc apply match applied_value with | Const _ | Symbol _ -> expr, cost_metrics, free_names | In_closure { var; value_slot; value = _ } -> - let arg = VB.create var Name_mode.normal in + let arg = + VB.create var Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) Name_mode.normal + in let prim = P.Unary ( Project_value_slot @@ -713,7 +721,10 @@ let simplify_direct_partial_application ~simplify_expr dacc apply Apply_cont.create apply_continuation ~args:[Simple.var wrapper_var] ~dbg in let expr = - let wrapper_var = VB.create wrapper_var Name_mode.normal in + let wrapper_var = + VB.create wrapper_var Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) Name_mode.normal + in let bound_vars = [wrapper_var] in let bound = Bound_pattern.set_of_closures bound_vars in let body = diff --git a/middle_end/flambda2/simplify/simplify_common.ml b/middle_end/flambda2/simplify/simplify_common.ml index 682f0c6fcb2..b8eaa333839 100644 --- a/middle_end/flambda2/simplify/simplify_common.ml +++ b/middle_end/flambda2/simplify/simplify_common.ml @@ -185,7 +185,10 @@ let split_direct_over_application apply let over_application_results = List.mapi (fun i kind -> - BP.create (Variable.create ("result" ^ string_of_int i)) kind) + BP.create + (Variable.create ("result" ^ string_of_int i)) + kind + Flambda_uid.internal_not_actually_unique (* CR tnowak: verify *)) (Flambda_arity.unarized_components (Apply.return_arity apply)) in let call_return_continuation, call_return_continuation_free_names = @@ -205,14 +208,17 @@ let split_direct_over_application apply let handler_expr = Let.create (Bound_pattern.singleton - (Bound_var.create (Variable.create "unit") Name_mode.normal)) + (Bound_var.create (Variable.create "unit") + Flambda_uid.internal_not_actually_unique Name_mode.normal)) (Named.create_prim (Unary (End_region { ghost = false }, Simple.var region)) (Apply.dbg apply)) ~body: (Let.create (Bound_pattern.singleton - (Bound_var.create (Variable.create "unit") Name_mode.normal)) + (Bound_var.create (Variable.create "unit") + Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) Name_mode.normal)) (Named.create_prim (Unary (End_region { ghost = true }, Simple.var ghost_region)) (Apply.dbg apply)) @@ -251,7 +257,8 @@ let split_direct_over_application apply Bound_parameters.create (List.map (fun kind -> - Bound_parameter.create (Variable.create "over_app_result") kind) + Bound_parameter.create (Variable.create "over_app_result") kind + Flambda_uid.internal_not_actually_unique) (Flambda_arity.unarized_components full_apply_result_arity)) in Continuation_handler.create params @@ -259,7 +266,7 @@ let split_direct_over_application apply ~free_names_of_handler:(Known Name_occurrences.empty) ~is_exn_handler:false ~is_cold:true else - let func_param = BP.create func_var K.With_subkind.any_value in + let func_param = BP.create func_var K.With_subkind.any_value Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *) in Continuation_handler.create (Bound_parameters.create [func_param]) ~handler:perform_over_application @@ -292,14 +299,18 @@ let split_direct_over_application apply NO.union (Apply.free_names full_apply) perform_over_application_free_names in Let.create - (Bound_pattern.singleton (Bound_var.create region Name_mode.normal)) + (Bound_pattern.singleton + (Bound_var.create region Flambda_uid.internal_not_actually_unique + (* CR tnowak: verify *) Name_mode.normal)) (Named.create_prim (Variadic (Begin_region { ghost = false }, [])) (Apply.dbg apply)) ~body: (Let.create (Bound_pattern.singleton - (Bound_var.create ghost_region Name_mode.normal)) + (Bound_var.create ghost_region + Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) Name_mode.normal)) (Named.create_prim (Variadic (Begin_region { ghost = false }, [])) (Apply.dbg apply)) diff --git a/middle_end/flambda2/simplify/simplify_extcall.ml b/middle_end/flambda2/simplify/simplify_extcall.ml index c3d3a5e304b..5b9bbac4b0d 100644 --- a/middle_end/flambda2/simplify/simplify_extcall.ml +++ b/middle_end/flambda2/simplify/simplify_extcall.ml @@ -44,7 +44,9 @@ let apply_cont cont v ~dbg = free_names, expr let let_prim ~dbg v prim (free_names, body) = - let v' = Bound_var.create v Name_mode.normal in + let v' = + Bound_var.create v Flambda_uid.internal_not_actually_unique Name_mode.normal + in let bindable = Bound_pattern.singleton v' in let named = Named.create_prim prim dbg in let free_names_of_body = Or_unknown.Known free_names in diff --git a/middle_end/flambda2/simplify/simplify_let_cont_expr.ml b/middle_end/flambda2/simplify/simplify_let_cont_expr.ml index b837d16d012..306a6a110f5 100644 --- a/middle_end/flambda2/simplify/simplify_let_cont_expr.ml +++ b/middle_end/flambda2/simplify/simplify_let_cont_expr.ml @@ -309,7 +309,9 @@ let extra_params_for_continuation_param_aliases cont uacc rewrite_ids = Flambda_kind.With_subkind.anything (Variable.Map.find var aliases_kind) in EPA.add - ~extra_param:(Bound_parameter.create var var_kind) + ~extra_param: + (Bound_parameter.create var var_kind + Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *)) ~extra_args epa ~invalids:Apply_cont_rewrite_id.Set.empty) required_extra_args.extra_args_for_aliases EPA.empty @@ -556,7 +558,10 @@ let add_lets_around_handler cont at_unit_toplevel uacc handler = Variable.Map.fold (fun var bound_to (handler, uacc) -> let bound_pattern = - Bound_pattern.singleton (Bound_var.create var Name_mode.normal) + (* CR tnowak: verify *) + Bound_pattern.singleton + (Bound_var.create var Flambda_uid.internal_not_actually_unique + Name_mode.normal) in let named = Named.create_simple bound_to in let handler, uacc = @@ -591,9 +596,9 @@ let add_phantom_params_bindings uacc handler new_phantom_params = let new_phantom_param_bindings_outermost_first = List.map (fun param -> - let var = BP.var param in + let param_var, param_uid = BP.var_and_uid param in let kind = K.With_subkind.kind (BP.kind param) in - let var = Bound_var.create var Name_mode.phantom in + let var = Bound_var.create param_var param_uid Name_mode.phantom in let let_bound = Bound_pattern.singleton var in let prim = Flambda_primitive.(Nullary (Optimised_out kind)) in let named = Named.create_prim prim Debuginfo.none in diff --git a/middle_end/flambda2/simplify/simplify_set_of_closures.ml b/middle_end/flambda2/simplify/simplify_set_of_closures.ml index f57fa7548fc..33351b5d8ef 100644 --- a/middle_end/flambda2/simplify/simplify_set_of_closures.ml +++ b/middle_end/flambda2/simplify/simplify_set_of_closures.ml @@ -46,7 +46,8 @@ let dacc_inside_function context ~outer_dacc ~params ~my_closure ~my_region (* This happens in the stub case, where we are only simplifying code, not a set of closures. *) DE.add_variable denv - (Bound_var.create my_closure NM.normal) + (Bound_var.create my_closure Flambda_uid.internal_not_actually_unique + NM.normal) (T.unknown K.value) | Some function_slot -> ( match @@ -62,25 +63,35 @@ let dacc_inside_function context ~outer_dacc ~params ~my_closure ~my_region | name -> let name = Bound_name.name name in DE.add_variable denv - (Bound_var.create my_closure NM.normal) + (Bound_var.create my_closure Flambda_uid.internal_not_actually_unique + NM.normal) (T.alias_type_of K.value (Simple.name name))) in let denv = match my_region with | None -> denv | Some my_region -> - let my_region = Bound_var.create my_region Name_mode.normal in + let my_region = + Bound_var.create my_region Flambda_uid.internal_not_actually_unique + Name_mode.normal + in DE.add_variable denv my_region (T.unknown K.region) in let denv = match my_ghost_region with | None -> denv | Some my_ghost_region -> - let my_ghost_region = Bound_var.create my_ghost_region Name_mode.normal in + let my_ghost_region = + Bound_var.create my_ghost_region + Flambda_uid.internal_not_actually_unique Name_mode.normal + in DE.add_variable denv my_ghost_region (T.unknown K.region) in let denv = - let my_depth = Bound_var.create my_depth Name_mode.normal in + let my_depth = + Bound_var.create my_depth Flambda_uid.internal_not_actually_unique + Name_mode.normal + in DE.add_variable denv my_depth (T.unknown K.rec_info) in let denv = @@ -190,7 +201,8 @@ let simplify_function_body context ~outer_dacc function_slot_opt match region with | None -> [] | Some region -> - [Bound_parameter.create region Flambda_kind.With_subkind.region] + [ Bound_parameter.create region Flambda_kind.With_subkind.region + Flambda_uid.internal_not_actually_unique (* CR sspies: fix *) ] in region_param my_region @ region_param my_ghost_region in @@ -200,9 +212,10 @@ let simplify_function_body context ~outer_dacc function_slot_opt ~implicit_params: (Bound_parameters.create ([ Bound_parameter.create my_closure - Flambda_kind.With_subkind.any_value; + Flambda_kind.With_subkind.any_value + Flambda_uid.internal_not_actually_unique; Bound_parameter.create my_depth Flambda_kind.With_subkind.rec_info - ] + Flambda_uid.internal_not_actually_unique ] @ region_params)) ~loopify_state ~params with @@ -376,7 +389,8 @@ let simplify_function0 context ~outer_dacc function_slot_opt code_id code (fun i kind_with_subkind -> BP.create (Variable.create ("result" ^ string_of_int i)) - kind_with_subkind) + kind_with_subkind + Flambda_uid.internal_not_actually_unique (* CR tnowak: verify *)) (Flambda_arity.unarized_components result_arity) |> Bound_parameters.create in diff --git a/middle_end/flambda2/simplify/simplify_switch_expr.ml b/middle_end/flambda2/simplify/simplify_switch_expr.ml index 8450efdaad9..cfba5336945 100644 --- a/middle_end/flambda2/simplify/simplify_switch_expr.ml +++ b/middle_end/flambda2/simplify/simplify_switch_expr.ml @@ -353,11 +353,18 @@ let rebuild_switch_with_single_arg_to_same_destination uacc ~dacc_before_switch match must_untag_lookup_table_result with | Leave_as_tagged_immediate -> body | Must_untag -> - let bound = BPt.singleton (BV.create final_arg_var NM.normal) in + let bound = + BPt.singleton + (BV.create final_arg_var Flambda_uid.internal_not_actually_unique + NM.normal) + in let untag_arg = Named.create_prim untag_arg_prim dbg in RE.create_let rebuilding bound untag_arg ~body ~free_names_of_body in - let bound = BPt.singleton (BV.create arg_var NM.normal) in + let bound = + BPt.singleton + (BV.create arg_var Flambda_uid.internal_not_actually_unique NM.normal) + in RE.create_let rebuilding bound load_from_block ~body ~free_names_of_body in let extra_free_names = @@ -526,7 +533,9 @@ let rebuild_switch ~original ~arms ~condition_dbg ~scrutinee ~scrutinee_ty Debuginfo.none in let bound = - VB.create not_scrutinee NM.normal |> Bound_pattern.singleton + VB.create not_scrutinee Flambda_uid.internal_not_actually_unique + NM.normal + |> Bound_pattern.singleton in let apply_cont = Apply_cont.create dest ~args:[not_scrutinee'] ~dbg @@ -706,7 +715,9 @@ let simplify_switch ~simplify_let_with_bound_pattern ~simplify_function_body let let_expr = (* [body] won't be looked at (see below). *) Let.create - (Bound_pattern.singleton (Bound_var.create tagged_scrutinee NM.normal)) + (Bound_pattern.singleton + (Bound_var.create tagged_scrutinee + Flambda_uid.internal_not_actually_unique NM.normal)) tagging_prim ~body:(Expr.create_switch switch) ~free_names_of_body:Unknown diff --git a/middle_end/flambda2/simplify/simplify_unary_primitive.ml b/middle_end/flambda2/simplify/simplify_unary_primitive.ml index 9dddb3a1158..dd6755ae25c 100644 --- a/middle_end/flambda2/simplify/simplify_unary_primitive.ml +++ b/middle_end/flambda2/simplify/simplify_unary_primitive.ml @@ -729,7 +729,9 @@ let simplify_obj_dup dbg dacc ~original_term ~arg ~arg_ty ~result_var = in let bind_contents = { Expr_builder.let_bound = - Bound_pattern.singleton (Bound_var.create contents_var NM.normal); + Bound_pattern.singleton + (Bound_var.create contents_var + Flambda_uid.internal_not_actually_unique NM.normal); simplified_defining_expr = Simplified_named.create contents_expr; original_defining_expr = None } @@ -737,7 +739,8 @@ let simplify_obj_dup dbg dacc ~original_term ~arg ~arg_ty ~result_var = let contents_simple = Simple.var contents_var in let dacc = DA.add_variable dacc - (Bound_var.create contents_var NM.normal) + (Bound_var.create contents_var + Flambda_uid.internal_not_actually_unique NM.normal) contents_ty in ( [bind_contents], diff --git a/middle_end/flambda2/simplify/unboxing/build_unboxing_denv.ml b/middle_end/flambda2/simplify/unboxing/build_unboxing_denv.ml index 3c6794b2b2d..e88f0d7f729 100644 --- a/middle_end/flambda2/simplify/unboxing/build_unboxing_denv.ml +++ b/middle_end/flambda2/simplify/unboxing/build_unboxing_denv.ml @@ -26,7 +26,7 @@ let add_equation_on_var denv var shape = Misc.fatal_errorf "Meet failed whereas prove and meet previously succeeded" let denv_of_number_decision naked_kind shape param_var naked_var denv : DE.t = - let naked_name = VB.create naked_var Name_mode.normal in + let naked_name = VB.create naked_var Flambda_uid.internal_not_actually_unique Name_mode.normal in let denv = DE.define_extra_variable denv naked_name naked_kind in add_equation_on_var denv param_var shape @@ -37,7 +37,8 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = let denv = Misc.Stdlib.List.fold_lefti (fun index denv ({ epa = { param = var; _ }; _ } : U.field_decision) -> - let v = VB.create var Name_mode.normal in + let v = VB.create var Flambda_uid.internal_not_actually_unique Name_mode.normal in + (* CR tnowak: verify *) DE.define_extra_variable denv v (K.Block_shape.element_kind shape index)) denv fields @@ -61,7 +62,8 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = let denv = Value_slot.Map.fold (fun _ ({ epa = { param = var; _ }; kind; _ } : U.field_decision) denv -> - let v = VB.create var Name_mode.normal in + let v = VB.create var Flambda_uid.internal_not_actually_unique Name_mode.normal in + (* CR tnowak: verify *) DE.define_extra_variable denv v (K.With_subkind.kind kind)) vars_within_closure denv in @@ -82,7 +84,8 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = vars_within_closure denv | Unbox (Variant { tag; const_ctors; fields_by_tag }) -> (* Adapt the denv for the tag *) - let tag_v = VB.create tag.param Name_mode.normal in + let tag_v = VB.create tag.param Flambda_uid.internal_not_actually_unique Name_mode.normal in + (* CR tnowak: verify *) let denv = DE.define_extra_variable denv tag_v K.naked_immediate in let denv = DE.map_typing_env denv ~f:(fun tenv -> @@ -98,7 +101,8 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = match const_ctors with | Zero -> denv | At_least_one { is_int; _ } -> - let is_int_v = VB.create is_int.param Name_mode.normal in + let is_int_v = VB.create is_int.param Flambda_uid.internal_not_actually_unique Name_mode.normal in + (* CR tnowak: verify *) let denv = DE.define_extra_variable denv is_int_v K.naked_immediate in let denv = DE.map_typing_env denv ~f:(fun tenv -> @@ -120,7 +124,8 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = | At_least_one { ctor = Do_not_unbox _; _ } -> denv, T.unknown K.naked_immediate | At_least_one { ctor = Unbox (Number (Naked_immediate, ctor_epa)); _ } -> - let v = VB.create ctor_epa.param Name_mode.normal in + let v = VB.create ctor_epa.param Flambda_uid.internal_not_actually_unique Name_mode.normal in + (* CR tnowak: verify *) let denv = DE.define_extra_variable denv v K.naked_immediate in let ty = T.alias_type_of K.naked_immediate (Simple.var ctor_epa.param) @@ -146,7 +151,7 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = (fun _ (shape, block_fields) denv -> Misc.Stdlib.List.fold_lefti (fun index denv ({ epa = { param = var; _ }; _ } : U.field_decision) -> - let v = VB.create var Name_mode.normal in + let v = VB.create var Flambda_uid.internal_not_actually_unique Name_mode.normal in DE.define_extra_variable denv v (K.Block_shape.element_kind shape index)) denv block_fields) diff --git a/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml b/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml index 7a35cdc7d22..0010d772898 100644 --- a/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml +++ b/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml @@ -427,7 +427,10 @@ let add_extra_params_and_args extra_params_and_args ~invalids decision = | Unbox (Unique_tag_and_size { tag = _; shape = _; fields }) -> List.fold_left (fun extra_params_and_args ({ epa; decision; kind } : U.field_decision) -> - let extra_param = BP.create epa.param kind in + let extra_param = + BP.create epa.param kind + Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *) + in let extra_params_and_args = EPA.add extra_params_and_args ~invalids ~extra_param ~extra_args:epa.args @@ -438,7 +441,10 @@ let add_extra_params_and_args extra_params_and_args ~invalids decision = Value_slot.Map.fold (fun _ ({ epa; decision; kind } : U.field_decision) extra_params_and_args -> - let extra_param = BP.create epa.param kind in + let extra_param = + BP.create epa.param kind + Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *) + in let extra_params_and_args = EPA.add extra_params_and_args ~invalids ~extra_param ~extra_args:epa.args @@ -452,7 +458,11 @@ let add_extra_params_and_args extra_params_and_args ~invalids decision = List.fold_left (fun extra_params_and_args ({ epa; decision; kind } : U.field_decision) -> - let extra_param = BP.create epa.param kind in + let extra_param = + BP.create epa.param kind + Flambda_uid.internal_not_actually_unique + (* CR tnowak: maybe? *) + in let extra_params_and_args = EPA.add extra_params_and_args ~invalids ~extra_param ~extra_args:epa.args @@ -467,6 +477,7 @@ let add_extra_params_and_args extra_params_and_args ~invalids decision = | At_least_one { is_int; ctor = Do_not_unbox _; _ } -> let extra_param = BP.create is_int.param K.With_subkind.naked_immediate + Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *) in EPA.add extra_params_and_args ~invalids ~extra_param ~extra_args:is_int.args @@ -474,6 +485,7 @@ let add_extra_params_and_args extra_params_and_args ~invalids decision = -> let extra_param = BP.create is_int.param K.With_subkind.naked_immediate + Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *) in let extra_params_and_args = EPA.add extra_params_and_args ~invalids ~extra_param @@ -481,6 +493,7 @@ let add_extra_params_and_args extra_params_and_args ~invalids decision = in let extra_param = BP.create ctor.param K.With_subkind.naked_immediate + Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *) in EPA.add extra_params_and_args ~invalids ~extra_param ~extra_args:ctor.args @@ -499,13 +512,19 @@ let add_extra_params_and_args extra_params_and_args ~invalids decision = "Trying to unbox the constant constructor of a variant with a kind \ other than Naked_immediate." in - let extra_param = BP.create tag.param K.With_subkind.naked_immediate in + let extra_param = + BP.create tag.param K.With_subkind.naked_immediate + Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *) + in EPA.add extra_params_and_args ~invalids ~extra_param ~extra_args:tag.args | Unbox (Number (naked_number_kind, epa)) -> let kind_with_subkind = K.With_subkind.of_naked_number_kind naked_number_kind in - let extra_param = BP.create epa.param kind_with_subkind in + let extra_param = + BP.create epa.param kind_with_subkind + Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *) + in EPA.add extra_params_and_args ~invalids ~extra_param ~extra_args:epa.args in aux extra_params_and_args decision diff --git a/middle_end/flambda2/simplify_shared/inlining_helpers.ml b/middle_end/flambda2/simplify_shared/inlining_helpers.ml index c3d5ad7f7e1..ef31708d858 100644 --- a/middle_end/flambda2/simplify_shared/inlining_helpers.ml +++ b/middle_end/flambda2/simplify_shared/inlining_helpers.ml @@ -89,7 +89,10 @@ let wrap_inlined_body_for_exn_extra_args acc ~extra_args ~apply_exn_continuation in let kinded_params = List.map - (fun k -> Bound_parameter.create (Variable.create "wrapper_return") k) + (fun k -> + Bound_parameter.create + (Variable.create "wrapper_return") + k Flambda_uid.internal_not_actually_unique (* CR tnowak: verify *)) (Flambda_arity.unarized_components result_arity) in let trap_action = @@ -106,7 +109,8 @@ let wrap_inlined_body_for_exn_extra_args acc ~extra_args ~apply_exn_continuation in let param = Variable.create "exn" in let wrapper_handler_params = - [Bound_parameter.create param Flambda_kind.With_subkind.any_value] + [ Bound_parameter.create param Flambda_kind.With_subkind.any_value + Flambda_uid.internal_not_actually_unique (* CR tnowak: verify *) ] |> Bound_parameters.create in let exn_handler = Exn_continuation.exn_handler apply_exn_continuation in diff --git a/middle_end/flambda2/terms/flambda.ml b/middle_end/flambda2/terms/flambda.ml index 1440d3f9b19..257a52ef2b9 100644 --- a/middle_end/flambda2/terms/flambda.ml +++ b/middle_end/flambda2/terms/flambda.ml @@ -585,6 +585,7 @@ and print_function_params_and_body ppf t = let my_closure = Bound_parameter.create my_closure (K.With_subkind.create K.value Anything Non_nullable) + Flambda_uid.internal_not_actually_unique in fprintf ppf "@[(%t@<1>\u{03bb}%t@[ Misc.fatal_errorf @@ -867,7 +868,7 @@ let add_alias env res ~var ~alias_of ~num_normal_occurrences_of_bound_vars = | Zero -> let env = remove_binding env alias_of in env, res - | One -> make_alias env res var alias_of + | One -> make_alias env res (Bound_var.var var) alias_of | More_than_one -> let env = remove_binding env alias_of in split_binding_and_rebind ~num_occurrences_of_var env res ~var ~alias_of b) diff --git a/middle_end/flambda2/to_cmm/to_cmm_env.mli b/middle_end/flambda2/to_cmm/to_cmm_env.mli index a1ef6af2968..b77014fd496 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_env.mli +++ b/middle_end/flambda2/to_cmm/to_cmm_env.mli @@ -133,11 +133,11 @@ val exported_offsets : t -> Exported_offsets.t the new environment and the created variable. Will produce a fatal error if the given variable is already bound. *) val create_bound_parameter : - t -> Variable.t -> t * Backend_var.With_provenance.t + t -> Variable.t * Flambda_uid.t -> t * Backend_var.With_provenance.t (** Same as {!create_variable} but for a list of variables. *) val create_bound_parameters : - t -> Variable.t list -> t * Backend_var.With_provenance.t list + t -> (Variable.t * Flambda_uid.t) list -> t * Backend_var.With_provenance.t list (** {2 Delayed let-bindings} @@ -233,7 +233,7 @@ val bind_variable_to_primitive : ?extra:extra_info -> t -> To_cmm_result.t -> - Variable.t -> + Bound_var.t -> inline:'a inline -> defining_expr:'a bound_expr -> effects_and_coeffects_of_defining_expr:Effects_and_coeffects.t -> @@ -245,7 +245,7 @@ val bind_variable : ?extra:extra_info -> t -> To_cmm_result.t -> - Variable.t -> + Bound_var.t -> defining_expr:Cmm.expression -> free_vars_of_defining_expr:free_vars -> num_normal_occurrences_of_bound_vars:Num_occurrences.t Variable.Map.t -> @@ -255,7 +255,7 @@ val bind_variable : val add_alias : t -> To_cmm_result.t -> - var:Variable.t -> + var:Bound_var.t -> alias_of:Variable.t -> num_normal_occurrences_of_bound_vars:Num_occurrences.t Variable.Map.t -> t * To_cmm_result.t diff --git a/middle_end/flambda2/to_cmm/to_cmm_expr.ml b/middle_end/flambda2/to_cmm/to_cmm_expr.ml index 13635e21b25..3d7d6e68974 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_expr.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_expr.ml @@ -618,12 +618,12 @@ let rec expr env res e : Cmm.expression * Backend_var.Set.t * To_cmm_result.t = and let_prim env res ~num_normal_occurrences_of_bound_vars v p dbg body = let dbg = Env.add_inlined_debuginfo env dbg in - let v = Bound_var.var v in let effects_and_coeffects_of_prim = Flambda_primitive.effects_and_coeffects p in let inline = - To_cmm_effects.classify_let_binding v ~num_normal_occurrences_of_bound_vars + To_cmm_effects.classify_let_binding (Bound_var.var v) + ~num_normal_occurrences_of_bound_vars ~effects_and_coeffects_of_defining_expr:effects_and_coeffects_of_prim in let simple_case (inline : Env.simple Env.inline) = @@ -664,7 +664,6 @@ and let_expr0 env res let_expr (bound_pattern : Bound_pattern.t) ~num_normal_occurrences_of_bound_vars ~body = match[@warning "-4"] bound_pattern, Let.defining_expr let_expr with | Singleton v, Simple s -> - let v = Bound_var.var v in (* CR mshinwell: Try to get a proper [dbg] here (although the majority of these bindings should have been substituted out). *) (* CR gbury: once we get proper debuginfo here, remember to apply @@ -987,7 +986,8 @@ and apply_expr env res apply = let handler_params = Bound_parameters.to_list handler_params in match handler_params with | [param] -> - let var = Bound_parameter.var param in + let param_var, param_uid = Bound_parameter.var_and_uid param in + let var = Bound_var.create param_var param_uid Name_mode.normal in let env, res = Env.bind_variable env res var ~effects_and_coeffects_of_defining_expr:effs ~defining_expr:call @@ -1006,7 +1006,8 @@ and apply_expr env res apply = Env.flush_delayed_lets ~mode:Branching_point env res in let env, cmm_params = - Env.create_bound_parameters env (List.map Bound_parameter.var params) + Env.create_bound_parameters env + (List.map Bound_parameter.var_and_uid params) in let label = Lambda.next_raise_count () in let params_with_machtype = @@ -1077,8 +1078,11 @@ and apply_cont env res apply_cont = (* Skip depth variables/parameters *) env, res | _ -> - bind_var_to_simple ~dbg_with_inlined env res - (Bound_parameter.var param) + let param_var, param_uid = Bound_parameter.var_and_uid param in + let var = + Bound_var.create param_var param_uid Name_mode.normal + in + bind_var_to_simple ~dbg_with_inlined env res var ~num_normal_occurrences_of_bound_vars: handler_params_occurrences arg) (env, res) handler_params args 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 1b11c572627..7c2a9de677c 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 @@ -450,6 +450,7 @@ let params_and_body0 env res code_id ~result_arity ~fun_dbg else let my_closure_param = Bound_parameter.create my_closure Flambda_kind.With_subkind.any_value + Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *) in Bound_parameters.append params (Bound_parameters.create [my_closure_param]) @@ -473,7 +474,11 @@ let params_and_body0 env res code_id ~result_arity ~fun_dbg match my_region with | None -> env, None | Some my_region -> - let env, region = Env.create_bound_parameter env my_region in + let env, region = + Env.create_bound_parameter env + ( my_region, + Flambda_uid.internal_not_actually_unique (* CR sspies: fix *) ) + in env, Some region in (* Similarly for [my_ghost_region]. *) @@ -481,7 +486,11 @@ let params_and_body0 env res code_id ~result_arity ~fun_dbg match my_ghost_region with | None -> env, None | Some my_ghost_region -> - let env, region = Env.create_bound_parameter env my_ghost_region in + let env, region = + Env.create_bound_parameter env + ( my_ghost_region, + Flambda_uid.internal_not_actually_unique (* CR sspies: fix *) ) + in env, Some region in (* Translate the arg list and body *) @@ -685,7 +694,6 @@ let lift_set_of_closures env res ~body ~bound_vars layout set ~translate_expr let env, res = List.fold_left2 (fun (env, res) cid v -> - let v = Bound_var.var v in let sym = C.symbol ~dbg (R.symbol res (Function_slot.Map.find cid closure_symbols)) @@ -727,7 +735,11 @@ let let_dynamic_set_of_closures0 env res ~body ~bound_vars set ~mode:(C.alloc_mode_for_allocations_to_cmm closure_alloc_mode) dbg ~tag l memory_chunks in - let soc_var = Variable.create "*set_of_closures*" in + let soc_var = + Bound_var.create + (Variable.create "*set_of_closures*") + Flambda_uid.internal_not_actually_unique Name_mode.normal + in let defining_expr = Env.simple csoc free_vars in let env, res = Env.bind_variable_to_primitive env res soc_var ~inline:Env.Do_not_inline @@ -740,7 +752,7 @@ let let_dynamic_set_of_closures0 env res ~body ~bound_vars set res; expr = { cmm = soc_cmm_var; free_vars = s_free_vars; effs = peff } } = - Env.inline_variable env res soc_var + Env.inline_variable env res (Bound_var.var soc_var) in assert ( match To_cmm_effects.classify_by_effects_and_coeffects peff with @@ -767,7 +779,6 @@ let let_dynamic_set_of_closures0 env res ~body ~bound_vars set match get_closure_by_offset env cid with | None -> env, res | Some (defining_expr, effects_and_coeffects_of_defining_expr) -> - let v = Bound_var.var v in Env.bind_variable env res v ~defining_expr ~free_vars_of_defining_expr:s_free_vars ~num_normal_occurrences_of_bound_vars diff --git a/middle_end/flambda2/to_cmm/to_cmm_shared.ml b/middle_end/flambda2/to_cmm/to_cmm_shared.ml index 9bf85222942..583030dda55 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_shared.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_shared.ml @@ -309,7 +309,7 @@ let simple_list ?consider_inlining_effectful_expressions ~dbg env res l = List.rev args, free_vars, env, res, effs let bound_parameters_aux ~f env l = - let flambda_vars = Bound_parameters.vars l in + let flambda_vars = Bound_parameters.vars_and_uids l in let env, cmm_vars = To_cmm_env.create_bound_parameters env flambda_vars in let vars = List.map2 (fun v v' -> v, f v') cmm_vars (Bound_parameters.to_list l) diff --git a/middle_end/flambda2/types/env/join_env.ml b/middle_end/flambda2/types/env/join_env.ml index bad991a1ac2..a8e8ed0a997 100644 --- a/middle_end/flambda2/types/env/join_env.ml +++ b/middle_end/flambda2/types/env/join_env.ml @@ -1192,7 +1192,9 @@ let cut_and_n_way_join ~n_way_join_type ~meet_type ~cut_after target_env Variable.Map.fold (fun var kind target_env -> TE.add_definition target_env - (Bound_name.create_var (Bound_var.create var Name_mode.in_types)) + (Bound_name.create_var + (Bound_var.create var Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) Name_mode.in_types)) kind) extra_variables target_env in diff --git a/middle_end/flambda2/types/equal_types_for_debug.ml b/middle_end/flambda2/types/equal_types_for_debug.ml index e2a4d5029ee..93537bca1b4 100644 --- a/middle_end/flambda2/types/equal_types_for_debug.ml +++ b/middle_end/flambda2/types/equal_types_for_debug.ml @@ -480,7 +480,10 @@ let names_with_non_equal_types_level_ignoring_name_mode ~meet_type env level1 Typing_env_level.fold_on_defined_vars (fun var kind left_env -> TE.add_definition left_env - (Bound_name.create_var (Bound_var.create var Name_mode.in_types)) + (Bound_name.create_var + (Bound_var.create var + Flambda_uid.internal_not_actually_unique (* CR sspies: fix *) + Name_mode.in_types)) kind) level1 env in @@ -488,7 +491,10 @@ let names_with_non_equal_types_level_ignoring_name_mode ~meet_type env level1 Typing_env_level.fold_on_defined_vars (fun var kind right_env -> TE.add_definition right_env - (Bound_name.create_var (Bound_var.create var Name_mode.in_types)) + (Bound_name.create_var + (Bound_var.create var + Flambda_uid.internal_not_actually_unique (* CR sspies: fix *) + Name_mode.in_types)) kind) level2 env in diff --git a/middle_end/flambda2/types/join_levels_old.ml b/middle_end/flambda2/types/join_levels_old.ml index f7d98596d30..7ef72821801 100644 --- a/middle_end/flambda2/types/join_levels_old.ml +++ b/middle_end/flambda2/types/join_levels_old.ml @@ -46,7 +46,9 @@ let join_types ~env_at_fork envs_with_levels = let kind = TEL.find_kind level var in TE.add_definition base_env (Bound_name.create_var - (Bound_var.create var Name_mode.in_types)) + (Bound_var.create var + Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) Name_mode.in_types)) kind) vars base_env) (TEL.variables_by_binding_time level) diff --git a/middle_end/flambda2/types/meet_and_n_way_join.ml b/middle_end/flambda2/types/meet_and_n_way_join.ml index 0b99752e11b..391f9923ab5 100644 --- a/middle_end/flambda2/types/meet_and_n_way_join.ml +++ b/middle_end/flambda2/types/meet_and_n_way_join.ml @@ -285,7 +285,9 @@ let add_defined_vars env level = TEL.fold_on_defined_vars (fun var kind env -> TE.add_definition env - (Bound_name.create_var (Bound_var.create var Name_mode.in_types)) + (Bound_name.create_var + (Bound_var.create var Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) Name_mode.in_types)) kind) level env @@ -1257,7 +1259,9 @@ and meet_row_like : Variable.Map.fold (fun var kind env -> TE.add_definition env - (Bound_name.create_var (Bound_var.create var Name_mode.in_types)) + (Bound_name.create_var + (Bound_var.create var Flambda_uid.internal_not_actually_unique + (* CR sspies: fix *) Name_mode.in_types)) kind) !extra_variables result_env in From 54b550488a3ce221ac9a6597be9d9563ddf80468 Mon Sep 17 00:00:00 2001 From: Simon Spies Date: Mon, 30 Jun 2025 15:08:11 +0100 Subject: [PATCH 2/4] improve debug uid propagation --- middle_end/backend_var.ml | 14 +- middle_end/backend_var.mli | 6 +- .../bound_identifiers/bound_parameter.ml | 9 +- .../bound_identifiers/bound_parameter.mli | 8 +- .../bound_identifiers/bound_parameters.mli | 2 +- .../flambda2/bound_identifiers/bound_var.ml | 20 +- .../flambda2/bound_identifiers/bound_var.mli | 4 +- .../from_lambda/closure_conversion.ml | 256 +++++++++--------- .../from_lambda/closure_conversion.mli | 8 +- .../from_lambda/closure_conversion_aux.ml | 9 +- .../from_lambda/closure_conversion_aux.mli | 14 +- .../flambda2/from_lambda/lambda_to_flambda.ml | 146 +++++----- .../from_lambda/lambda_to_flambda_env.ml | 21 +- .../from_lambda/lambda_to_flambda_env.mli | 15 +- .../lambda_to_flambda_primitives_helpers.ml | 43 +-- .../{flambda_uid.ml => flambda_debug_uid.ml} | 16 +- ...{flambda_uid.mli => flambda_debug_uid.mli} | 14 +- .../flambda2/parser/fexpr_to_flambda.ml | 44 ++- middle_end/flambda2/reaper/rebuild.ml | 59 ++-- .../flambda2/simplify/apply_cont_rewrite.ml | 12 +- .../common_subexpression_elimination.ml | 5 +- .../flambda2/simplify/env/downwards_env.ml | 39 ++- middle_end/flambda2/simplify/expr_builder.ml | 18 +- .../simplify/flow/mutable_unboxing.ml | 8 +- .../simplify/inlining/inlining_transforms.ml | 10 +- .../flambda2/simplify/lifted_cont_params.ml | 10 +- .../simplify/simplify_apply_cont_expr.ml | 4 +- .../flambda2/simplify/simplify_apply_expr.ml | 27 +- .../flambda2/simplify/simplify_common.ml | 33 +-- .../flambda2/simplify/simplify_extcall.ml | 26 +- .../simplify/simplify_let_cont_expr.ml | 16 +- .../simplify/simplify_set_of_closures.ml | 44 +-- .../flambda2/simplify/simplify_switch_expr.ml | 25 +- .../simplify/simplify_unary_primitive.ml | 7 +- .../simplify/unboxing/build_unboxing_denv.ml | 106 +++++--- .../unboxing/optimistic_unboxing_decision.ml | 25 +- .../simplify/unboxing/unboxing_epa.ml | 26 +- .../simplify/unboxing/unboxing_types.ml | 10 +- .../simplify/unboxing/unboxing_types.mli | 6 +- .../simplify_shared/inlining_helpers.ml | 10 +- middle_end/flambda2/terms/flambda.ml | 2 +- middle_end/flambda2/tests/meet_test.ml | 62 +---- middle_end/flambda2/to_cmm/to_cmm.ml | 11 +- middle_end/flambda2/to_cmm/to_cmm_env.ml | 12 +- middle_end/flambda2/to_cmm/to_cmm_env.mli | 6 +- .../flambda2/to_cmm/to_cmm_set_of_closures.ml | 24 +- middle_end/flambda2/types/env/join_env.ml | 7 +- .../flambda2/types/equal_types_for_debug.ml | 12 +- middle_end/flambda2/types/join_levels_old.ml | 8 +- .../flambda2/types/meet_and_n_way_join.ml | 14 +- 50 files changed, 711 insertions(+), 622 deletions(-) rename middle_end/flambda2/identifiers/{flambda_uid.ml => flambda_debug_uid.ml} (83%) rename middle_end/flambda2/identifiers/{flambda_uid.mli => flambda_debug_uid.mli} (82%) diff --git a/middle_end/backend_var.ml b/middle_end/backend_var.ml index 89433026612..9a2ab9744a6 100644 --- a/middle_end/backend_var.ml +++ b/middle_end/backend_var.ml @@ -16,8 +16,6 @@ include Ident -module Uid = Flambda2_identifiers.Flambda_uid - type backend_var = t let name_for_debugger t = @@ -37,10 +35,10 @@ module Provenance = struct module_path : Path.t; location : Debuginfo.t; original_ident : Ident.t; - uid : Uid.t + debug_uid : Flambda2_identifiers.Flambda_debug_uid.t } - let print ppf { module_path; location; original_ident; uid } = + let print ppf { module_path; location; original_ident; debug_uid } = let printf fmt = Format.fprintf ppf fmt in printf "@[("; printf "@[(module_path@ %a)@]@ " @@ -50,20 +48,20 @@ module Provenance = struct Debuginfo.print_compact location; printf "@[(original_ident@ %a,uid=%a)@]" Ident.print original_ident - Uid.print uid; + Flambda2_identifiers.Flambda_debug_uid.print debug_uid; printf ")@]" - let create ~module_path ~location ~original_ident ~uid = + let create ~module_path ~location ~original_ident ~debug_uid = { module_path; location; original_ident; - uid + debug_uid } let module_path t = t.module_path let location t = t.location let original_ident t = t.original_ident - let uid t = t.uid + let debug_uid t = t.debug_uid let equal t1 t2 = Stdlib.compare t1 t2 = 0 end diff --git a/middle_end/backend_var.mli b/middle_end/backend_var.mli index 2288ab698bd..d1ae02c8cb3 100644 --- a/middle_end/backend_var.mli +++ b/middle_end/backend_var.mli @@ -19,8 +19,6 @@ include module type of struct include Ident end -module Uid = Flambda2_identifiers.Flambda_uid - type backend_var = t val name_for_debugger : t -> string @@ -33,13 +31,13 @@ module Provenance : sig : module_path:Path.t -> location:Debuginfo.t -> original_ident:Ident.t - -> uid:Uid.t + -> debug_uid:Flambda2_identifiers.Flambda_debug_uid.t -> t val module_path : t -> Path.t val location : t -> Debuginfo.t val original_ident : t -> Ident.t - val uid : t -> Uid.t + val debug_uid : t -> Flambda2_identifiers.Flambda_debug_uid.t val print : Format.formatter -> t -> unit diff --git a/middle_end/flambda2/bound_identifiers/bound_parameter.ml b/middle_end/flambda2/bound_identifiers/bound_parameter.ml index 66797aa6c98..a9a7fe11698 100644 --- a/middle_end/flambda2/bound_identifiers/bound_parameter.ml +++ b/middle_end/flambda2/bound_identifiers/bound_parameter.ml @@ -15,11 +15,10 @@ (**************************************************************************) module Simple = Int_ids.Simple -module Uid = Shape.Uid type t = { param : Variable.t; - uid : Flambda_uid.t; + uid : Flambda_debug_uid.t; kind : Flambda_kind.With_subkind.t } @@ -33,7 +32,7 @@ include Container_types.Make (struct then c else let c = Flambda_kind.With_subkind.compare kind1 kind2 in - if c <> 0 then c else Flambda_uid.compare uid1 uid2 + if c <> 0 then c else Flambda_debug_uid.compare uid1 uid2 let equal t1 t2 = compare t1 t2 = 0 @@ -41,13 +40,13 @@ include Container_types.Make (struct Hashtbl.hash ( Variable.hash param, Flambda_kind.With_subkind.hash kind, - Flambda_uid.hash uid ) + Flambda_debug_uid.hash uid ) let [@ocamlformat "disable"] print ppf { param; kind; uid } = Format.fprintf ppf "@[(%t%a,uid=%a%t @<1>\u{2237} %a)@]" Flambda_colours.parameter Variable.print param - Flambda_uid.print uid + Flambda_debug_uid.print uid Flambda_colours.pop Flambda_kind.With_subkind.print kind end) diff --git a/middle_end/flambda2/bound_identifiers/bound_parameter.mli b/middle_end/flambda2/bound_identifiers/bound_parameter.mli index 7795c80a084..e725aea4430 100644 --- a/middle_end/flambda2/bound_identifiers/bound_parameter.mli +++ b/middle_end/flambda2/bound_identifiers/bound_parameter.mli @@ -14,19 +14,17 @@ (* *) (**************************************************************************) -module Uid = Shape.Uid - (** A parameter (to a function, continuation, etc.) together with its kind. *) type t (** Create a kinded parameter. *) -val create : Variable.t -> Flambda_kind.With_subkind.t -> Flambda_uid.t -> t +val create : + Variable.t -> Flambda_kind.With_subkind.t -> Flambda_debug_uid.t -> t (** The underlying variable. *) - val var : t -> Variable.t -val var_and_uid : t -> Variable.t * Flambda_uid.t +val var_and_uid : t -> Variable.t * Flambda_debug_uid.t val name : t -> Name.t diff --git a/middle_end/flambda2/bound_identifiers/bound_parameters.mli b/middle_end/flambda2/bound_identifiers/bound_parameters.mli index d368a2e8c7e..8a1178e6a19 100644 --- a/middle_end/flambda2/bound_identifiers/bound_parameters.mli +++ b/middle_end/flambda2/bound_identifiers/bound_parameters.mli @@ -44,7 +44,7 @@ val to_set : t -> Bound_parameter.Set.t val vars : t -> Variable.t list -val vars_and_uids : t -> (Variable.t * Flambda_uid.t) list +val vars_and_uids : t -> (Variable.t * Flambda_debug_uid.t) list val var_set : t -> Variable.Set.t diff --git a/middle_end/flambda2/bound_identifiers/bound_var.ml b/middle_end/flambda2/bound_identifiers/bound_var.ml index 97da91d57b7..b954e424a59 100644 --- a/middle_end/flambda2/bound_identifiers/bound_var.ml +++ b/middle_end/flambda2/bound_identifiers/bound_var.ml @@ -16,21 +16,21 @@ type t = { var : Variable.t; - uid : Flambda_uid.t; + debug_uid : Flambda_debug_uid.t; name_mode : Name_mode.t } -let [@ocamlformat "disable"] print ppf { var; uid; name_mode = _; } = - Format.fprintf ppf "%a,uid=%a" Variable.print var Flambda_uid.print uid +let [@ocamlformat "disable"] print ppf { var; debug_uid; name_mode = _; } = + Format.fprintf ppf "%a,uid=%a" Variable.print var Flambda_debug_uid.print debug_uid -let create var uid name_mode = +let create var debug_uid name_mode = (* Note that [name_mode] might be [In_types], e.g. when dealing with function return types and also using [Typing_env.add_definition]. *) - { var; uid; name_mode } + { var; debug_uid; name_mode } let var t = t.var -let uid t = t.uid +let debug_uid t = t.debug_uid let name_mode t = t.name_mode @@ -49,9 +49,11 @@ let apply_renaming t renaming = let free_names t = Name_occurrences.singleton_variable t.var t.name_mode -let ids_for_export { var; uid = _; name_mode = _ } = +let ids_for_export { var; debug_uid = _; name_mode = _ } = Ids_for_export.add_variable Ids_for_export.empty var -let renaming { var; uid = _; name_mode = _ } ~guaranteed_fresh = - let { var = guaranteed_fresh; uid = _; name_mode = _ } = guaranteed_fresh in +let renaming { var; debug_uid = _; name_mode = _ } ~guaranteed_fresh = + let { var = guaranteed_fresh; debug_uid = _; name_mode = _ } = + guaranteed_fresh + in Renaming.add_fresh_variable Renaming.empty var ~guaranteed_fresh diff --git a/middle_end/flambda2/bound_identifiers/bound_var.mli b/middle_end/flambda2/bound_identifiers/bound_var.mli index f6ed340ce99..36920339fdf 100644 --- a/middle_end/flambda2/bound_identifiers/bound_var.mli +++ b/middle_end/flambda2/bound_identifiers/bound_var.mli @@ -19,11 +19,11 @@ type t -val create : Variable.t -> Flambda_uid.t -> Name_mode.t -> t +val create : Variable.t -> Flambda_debug_uid.t -> Name_mode.t -> t val var : t -> Variable.t -val uid : t -> Flambda_uid.t +val debug_uid : t -> Flambda_debug_uid.t val name_mode : t -> Name_mode.t diff --git a/middle_end/flambda2/from_lambda/closure_conversion.ml b/middle_end/flambda2/from_lambda/closure_conversion.ml index 21cef3d5563..c9164e9d2a0 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion.ml @@ -360,6 +360,8 @@ module Inlining = struct ~free_names_of_body ~exn_continuation ~return_continuation ~apply_exn_continuation ~apply_return_continuation ~apply_depth ~apply_dbg = + let my_depth_duid = Flambda_debug_uid.none in + let my_closure_duid = Flambda_debug_uid.none in let rec_info = match apply_depth with | None -> Rec_info_expr.initial @@ -368,20 +370,17 @@ module Inlining = struct let bind_params ~params ~args ~body:(acc, body) = let acc = Acc.with_free_names free_names_of_body acc in List.fold_left2 - (fun (acc, body) param arg -> + (fun (acc, body) (param, param_duid) arg -> Let_with_acc.create acc - (* CR tnowak: verify *) (Bound_pattern.singleton - (VB.create param Flambda_uid.internal_not_actually_unique - Name_mode.normal)) + (VB.create param param_duid Name_mode.normal)) (Named.create_simple arg) ~body) (acc, body) params args in let bind_depth ~my_depth ~rec_info ~body:(acc, body) = Let_with_acc.create acc (Bound_pattern.singleton - (VB.create my_depth Flambda_uid.internal_not_actually_unique - Name_mode.normal)) + (VB.create my_depth my_depth_duid Name_mode.normal)) (Named.create_rec_info rec_info) ~body in @@ -395,19 +394,20 @@ module Inlining = struct in let acc, body = Inlining_helpers.make_inlined_body ~callee ~called_code_id - ~region_inlined_into ~params ~args ~my_closure ~my_region - ~my_ghost_region ~my_depth ~rec_info ~body:(acc, body) ~exn_continuation - ~return_continuation ~apply_exn_continuation ~apply_return_continuation - ~bind_params ~bind_depth ~apply_renaming + ~region_inlined_into ~params ~args + ~my_closure:(my_closure, my_closure_duid) + ~my_region ~my_ghost_region ~my_depth ~rec_info ~body:(acc, body) + ~exn_continuation ~return_continuation ~apply_exn_continuation + ~apply_return_continuation ~bind_params ~bind_depth ~apply_renaming in let inlined_debuginfo = Inlined_debuginfo.create ~called_code_id ~apply_dbg in + let inlined_dbg_var = Variable.create "inlined_dbg" in + let inlined_dbg_var_duid = Flambda_debug_uid.none in Let_with_acc.create acc (Bound_pattern.singleton - (VB.create - (Variable.create "inlined_dbg") - Flambda_uid.internal_not_actually_unique Name_mode.normal)) + (VB.create inlined_dbg_var inlined_dbg_var_duid Name_mode.normal)) (Named.create_prim (Nullary (Enter_inlined_apply { dbg = inlined_debuginfo })) Debuginfo.none) @@ -470,7 +470,7 @@ module Inlining = struct let make_inlined_body = make_inlined_body ~callee ~called_code_id:(Code.code_id code) ~region_inlined_into - ~params:(Bound_parameters.vars params) + ~params:(Bound_parameters.vars_and_uids params) ~args ~my_closure ~my_region ~my_ghost_region ~my_depth ~body ~free_names_of_body ~exn_continuation ~return_continuation ~apply_depth ~apply_dbg @@ -627,13 +627,18 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds "close_c_call: C call primitive %s can't be layout polymorphic." prim_name; let env, let_bound_vars = List.fold_left_map - (fun env (id, _uid, kind) -> - Env.add_var_like env id Not_user_visible kind) + (fun env (id, id_duid, kind) -> + let env, let_bound_var = + Env.add_var_like env id Not_user_visible kind + in + env, (let_bound_var, id_duid)) + (* CR sspies: Alternatively, we could drop the debugging uid here, + because these variables are not user visible. *) env let_bound_ids_with_kinds in let cost_metrics_of_body, free_names_of_body, acc, body = Acc.measure_cost_metrics acc ~f:(fun acc -> - k acc (List.map Named.create_var let_bound_vars)) + k acc (List.map (fun (v, _) -> Named.create_var v) let_bound_vars)) in let alloc_mode_app = match Lambda.locality_mode_of_primitive_description prim_desc with @@ -685,7 +690,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds | Apply_cont apply_cont when Simple.List.equal (Apply_cont_expr.args apply_cont) - (Simple.vars let_bound_vars) + (Simple.vars (List.map fst let_bound_vars)) && Option.is_none (Apply_cont_expr.trap_action apply_cont) && not need_return_transformer -> Apply_cont_expr.continuation apply_cont, false @@ -726,9 +731,9 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds match args with | [arg] -> let result = Variable.create "reinterpreted" in + let result_duid = Flambda_debug_uid.none in let result' = - Bound_var.create result Flambda_uid.internal_not_actually_unique - Name_mode.normal + Bound_var.create result result_duid Name_mode.normal in let bindable = Bound_pattern.singleton result' in let prim = P.Unary (Reinterpret_64_bit_word op, arg) in @@ -781,9 +786,9 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds | Some named -> fun args acc -> let unboxed_arg = Variable.create "unboxed" in + let unboxed_arg_duid = Flambda_debug_uid.none in let unboxed_arg' = - VB.create unboxed_arg Flambda_uid.internal_not_actually_unique - Name_mode.normal + VB.create unboxed_arg unboxed_arg_duid Name_mode.normal in let acc, body = call (Simple.var unboxed_arg :: args) acc in let named = Named.create_prim (Unary (named, arg)) dbg in @@ -795,11 +800,8 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds let wrap_c_call acc ~handler_params ~code_after_call c_call = let params = List.map2 - (fun ret_value { kind; _ } -> - BP.create ret_value - (K.With_subkind.anything kind) - Flambda_uid.internal_not_actually_unique - (* CR tnowak: verify *)) + (fun (ret_value, ret_value_duid) { kind; _ } -> + BP.create ret_value (K.With_subkind.anything kind) ret_value_duid) handler_params unarized_results |> Bound_parameters.create in @@ -816,20 +818,21 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds let box_unboxed_returns () = let let_bound_vars' = List.map - (fun let_bound_var -> - VB.create let_bound_var Flambda_uid.internal_not_actually_unique - Name_mode.normal) + (fun (let_bound_var, let_bound_var_duid) -> + VB.create let_bound_var let_bound_var_duid Name_mode.normal) let_bound_vars in let handler_params = List.map - (fun let_bound_var -> Variable.rename let_bound_var) + (fun (let_bound_var, let_bound_var_duid) -> + Variable.rename let_bound_var, let_bound_var_duid) let_bound_vars in let body acc = let acc, body = keep_body acc in List.fold_left2 - (fun (acc, body) unarized_param (handler_param, let_bound_var') -> + (fun (acc, body) unarized_param + ((handler_param, _handler_param_duid), let_bound_var') -> let named = let handler_param = Simple.var handler_param in match unarized_param.return_transformer with @@ -906,26 +909,30 @@ let close_effect_primitive acc env ~dbg exn_continuation (* CR mshinwell: share with close_c_call, above *) let _env, let_bound_vars = List.fold_left_map - (* CR sspies: Do we really want to drop the [debug_uid] here? *) - (fun env (id, _, kind) -> Env.add_var_like env id Not_user_visible kind) + (fun env (id, _id_duid, kind) -> + let env, let_bound_var = + Env.add_var_like env id Not_user_visible kind + in + env, (let_bound_var, Flambda_debug_uid.none)) + (* We are dropping the debug uid here, because the variable is not user + visible. *) env let_bound_ids_with_kinds in - let let_bound_var = + let let_bound_var, let_bound_var_duid = match let_bound_vars with - | [let_bound_var] -> let_bound_var + | [(let_bound_var, let_bound_var_duid)] -> let_bound_var, let_bound_var_duid | [] | _ :: _ :: _ -> Misc.fatal_errorf "close_effect_primitive: expected singleton return for primitive %a, \ but got: [%a]" Printlambda.primitive prim (Format.pp_print_list ~pp_sep:Format.pp_print_space Variable.print) - let_bound_vars + (List.map fst let_bound_vars) in let continuation = Continuation.create () in let return_kind = Flambda_kind.With_subkind.any_value in let params = - [ BP.create let_bound_var return_kind - Flambda_uid.internal_not_actually_unique (* CR sspies: fix *) ] + [BP.create let_bound_var return_kind let_bound_var_duid] |> Bound_parameters.create in let close call_kind = @@ -946,7 +953,7 @@ let close_effect_primitive acc env ~dbg exn_continuation ~handler:(fun acc -> let cost_metrics_of_body, free_names_of_body, acc, code_after_call = Acc.measure_cost_metrics acc ~f:(fun acc -> - k acc (List.map Named.create_var let_bound_vars)) + k acc (List.map (fun (v, _) -> Named.create_var v) let_bound_vars)) in let acc = Acc.with_cost_metrics @@ -1530,7 +1537,6 @@ let close_let_cont acc env ~name ~is_exn_handler ~params | Some args -> List.fold_left2 (fun env arg_approx (param, (param_id, _param_uid, _, kind)) -> - (* CR tnowak: not sure, should we ignore the param_uid here? *) let env = Env.add_var_approximation env param arg_approx in match (arg_approx : Env.value_approximation) with | Value_symbol s | Closure_approximation { symbol = Some s; _ } -> @@ -1686,9 +1692,9 @@ let close_switch acc env ~condition_dbg scrutinee (sw : IR.switch) : Expr_with_acc.t = let scrutinee = find_simple_from_id env scrutinee in let untagged_scrutinee = Variable.create "untagged" in + let untagged_scrutinee_duid = Flambda_debug_uid.none in let untagged_scrutinee' = - VB.create untagged_scrutinee Flambda_uid.internal_not_actually_unique - Name_mode.normal + VB.create untagged_scrutinee untagged_scrutinee_duid Name_mode.normal in let known_const_scrutinee = match find_value_approximation_through_symbol acc env scrutinee with @@ -1728,9 +1734,9 @@ let close_switch acc env ~condition_dbg scrutinee (sw : IR.switch) : condition_dbg in let comparison_result = Variable.create "eq" in + let comparison_result_duid = Flambda_debug_uid.none in let comparison_result' = - VB.create comparison_result Flambda_uid.internal_not_actually_unique - Name_mode.normal + VB.create comparison_result comparison_result_duid Name_mode.normal in let acc, default_action = let acc, args = find_simples acc env default_args in @@ -1806,20 +1812,28 @@ let close_switch acc env ~condition_dbg scrutinee (sw : IR.switch) : let variables_for_unboxing boxed_variable_name (k : Function_decl.unboxing_kind) = + (* CR sspies: This function currently picks [.none] for all the debugging uids + of the unboxed variables. Should we put in more effort to propagate the + correct debugging uids here? How would the type change from boxed to + unboxed affect this function? That is, do all these variables even have the + same debugging uids as their original counter parts? *) match k with | Fields_of_block_with_tag_zero kinds -> List.mapi (fun i kind -> ( Variable.create (boxed_variable_name ^ "_field_" ^ Int.to_string i), + Flambda_debug_uid.none, kind )) kinds | Unboxed_number bn -> [ ( Variable.create (boxed_variable_name ^ "_unboxed"), + Flambda_debug_uid.none, Flambda_kind.With_subkind.naked_of_boxable_number bn ) ] | Unboxed_float_record num_fields -> List.init num_fields (fun i -> ( Variable.create (boxed_variable_name ^ "_floatfield_" ^ Int.to_string i), + Flambda_debug_uid.none, Flambda_kind.With_subkind.naked_float )) let unboxing_primitive (k : Function_decl.unboxing_kind) boxed_variable i = @@ -1872,6 +1886,7 @@ let compute_body_of_unboxed_function acc my_region my_closure ~unarized_params:params params_arity ~unarized_param_modes:param_modes function_slot compute_body return return_continuation unboxed_params unboxed_return unboxed_function_slot = + let my_closure_duid = Flambda_debug_uid.none in let rec box_params params params_arity param_modes params_unboxing body = match params, params_arity, param_modes, params_unboxing with | [], [], [], [] -> [], [], [], body @@ -1898,25 +1913,26 @@ let compute_body_of_unboxed_function acc my_region my_closure Alloc_mode.For_allocations.from_lambda ~current_region:my_region (Alloc_mode.For_types.to_lambda param_mode) in + let _, param_duid = BP.var_and_uid param in Let_with_acc.create acc (Bound_pattern.singleton (Bound_var.create (Bound_parameter.var param) - Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) Name_mode.normal)) + param_duid Name_mode.normal)) + (* CR sspies: Is this debugging uid correct? *) (Named.create_prim - (boxing_primitive k alloc_mode (List.map fst vars_with_kinds)) + (boxing_primitive k alloc_mode + (List.map (fun (var, _, _) -> var) vars_with_kinds)) Debuginfo.none) ~body in ( List.map - (fun (var, kind) -> - Bound_parameter.create var kind - Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *)) + (fun (var, var_duid, kind) -> + Bound_parameter.create var kind var_duid) vars_with_kinds @ main_code_params, - List.map snd vars_with_kinds @ main_code_params_arity, + List.map (fun (_, _, kind) -> kind) vars_with_kinds + @ main_code_params_arity, (* CR ncourant: is this correct in the presence of records with global fields? *) List.map (fun _ -> param_mode) vars_with_kinds @ main_code_param_modes, @@ -1950,6 +1966,7 @@ let compute_body_of_unboxed_function acc my_region my_closure Continuation.create ~sort:Return ~name:"unboxed_return" () in let boxed_variable = Variable.create "boxed_result" in + let boxed_variable_duid = Flambda_debug_uid.none in let return = match Flambda_arity.unarized_components return with | [return] -> return @@ -1960,26 +1977,24 @@ let compute_body_of_unboxed_function acc my_region my_closure in let handler_params = Bound_parameters.create - [ Bound_parameter.create boxed_variable return - Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) ] + [Bound_parameter.create boxed_variable return boxed_variable_duid] in let handler acc = let acc, apply_cont = Apply_cont_with_acc.create acc unboxed_return_continuation ~args: - (List.map (fun (var, _kind) -> Simple.var var) vars_with_kinds) + (List.map + (fun (var, _duid, _kind) -> Simple.var var) + vars_with_kinds) ~dbg:Debuginfo.none in let acc, apply_cont = Expr_with_acc.create_apply_cont acc apply_cont in let (acc, expr), _ = List.fold_left - (fun ((acc, expr), i) (var, _kind) -> + (fun ((acc, expr), i) (var, var_duid, _kind) -> ( Let_with_acc.create acc (Bound_pattern.singleton - (Bound_var.create var - Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) Name_mode.normal)) + (Bound_var.create var var_duid Name_mode.normal)) (Named.create_prim (unboxing_primitive k boxed_variable i) Debuginfo.none) @@ -1997,15 +2012,15 @@ let compute_body_of_unboxed_function acc my_region my_closure ( acc, unboxed_body, Flambda_arity.create_singletons - (List.map (fun (_, kind) -> kind) vars_with_kinds), + (List.map (fun (_, _, kind) -> kind) vars_with_kinds), unboxed_return_continuation ) in let my_unboxed_closure = Variable.create "my_unboxed_closure" in let acc, unboxed_body = Let_with_acc.create acc (Bound_pattern.singleton - (Bound_var.create my_closure Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) Name_mode.normal)) + (Bound_var.create my_closure my_closure_duid Name_mode.normal)) + (* CR sspies: Should this be [my_unboxed_closure]? *) (Named.create_prim (Flambda_primitive.Unary ( Project_function_slot @@ -2040,6 +2055,7 @@ let make_unboxed_function_wrapper acc function_slot ~unarized_params:params let main_function_slot = unboxed_function_slot in let main_name = Function_slot.name unboxed_function_slot in let main_closure = Variable.create main_name in + let main_closure_duid = Flambda_debug_uid.none in let return_continuation = Continuation.create () in let exn_continuation = Continuation.create () in let my_closure = Variable.create "my_closure" in @@ -2075,7 +2091,7 @@ let make_unboxed_function_wrapper acc function_slot ~unarized_params:params let body, free_names_of_body = body_wrapper body free_names_of_body in let body, free_names_of_body, _ = List.fold_left - (fun (body, free_names_of_body, i) (var, _kind) -> + (fun (body, free_names_of_body, i) (var, var_duid, _kind) -> let named = Named.create_prim (unboxing_primitive k (Bound_parameter.var param) i) @@ -2084,9 +2100,7 @@ let make_unboxed_function_wrapper acc function_slot ~unarized_params:params ( Expr.create_let (Let_expr.create (Bound_pattern.singleton - (Bound_var.create var - Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) Name_mode.normal)) + (Bound_var.create var var_duid Name_mode.normal)) named ~body ~free_names_of_body:(Known free_names_of_body)), Name_occurrences.union (Named.free_names named) @@ -2097,8 +2111,10 @@ let make_unboxed_function_wrapper acc function_slot ~unarized_params:params in body, free_names_of_body in - ( List.map (fun (var, _kind) -> Simple.var var) vars_with_kinds @ args, - List.map (fun (_var, kind) -> kind) vars_with_kinds @ args_arity, + ( List.map (fun (var, _duid, _kind) -> Simple.var var) vars_with_kinds + @ args, + List.map (fun (_var, _duid, kind) -> kind) vars_with_kinds + @ args_arity, new_wrapper )) in let args, args_arity, body_wrapper = @@ -2140,9 +2156,7 @@ let make_unboxed_function_wrapper acc function_slot ~unarized_params:params Expr.create_let (Let_expr.create (Bound_pattern.singleton - (Bound_var.create main_closure - Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) Name_mode.normal)) + (Bound_var.create main_closure main_closure_duid Name_mode.normal)) projection ~body:(Expr.create_apply main_application) ~free_names_of_body:(Known (Apply_expr.free_names main_application))) @@ -2165,13 +2179,13 @@ let make_unboxed_function_wrapper acc function_slot ~unarized_params:params (List.map (fun kind -> let var = Variable.create "unboxed_return" in - Bound_parameter.create var kind - Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *)) + let var_duid = Flambda_debug_uid.none in + Bound_parameter.create var kind var_duid) (Flambda_arity.unarized_components result_arity_main_code)) in let handler, free_names_of_handler = let boxed_return = Variable.create "boxed_return" in + let boxed_return_duid = Flambda_debug_uid.none in let return_apply_cont = Apply_cont.create return_continuation ~args:[Simple.var boxed_return] @@ -2185,9 +2199,8 @@ let make_unboxed_function_wrapper acc function_slot ~unarized_params:params ( Expr.create_let (Let_expr.create (Bound_pattern.singleton - (Bound_var.create boxed_return - Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) Name_mode.normal)) + (Bound_var.create boxed_return boxed_return_duid + Name_mode.normal)) box_result_named ~body:(Expr.create_apply_cont return_apply_cont) ~free_names_of_body: @@ -2327,6 +2340,7 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot let function_slot = Function_decl.function_slot decl in let my_depth = Variable.create "my_depth" in let next_depth = Variable.create "next_depth" in + let next_depth_duid = Flambda_debug_uid.none in let our_let_rec_ident = Function_decl.let_rec_ident decl in let is_curried = match Function_decl.kind decl with Curried _ -> true | Tupled -> false @@ -2464,8 +2478,7 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot List.map (fun (p : Function_decl.param) -> let var = fst (Env.find_var closure_env p.name) in - BP.create var p.kind Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *)) + BP.create var p.kind p.debug_uid) unarized_params |> Bound_parameters.create in @@ -2498,10 +2511,9 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot let move : Flambda_primitive.unary_primitive = Project_function_slot { move_from = function_slot; move_to } in - let var = - VB.create var Flambda_uid.internal_not_actually_unique - Name_mode.normal - in + let var = VB.create var Flambda_debug_uid.none Name_mode.normal in + (* CR sspies: Should we put in more effort to propagate a debugging + uid to here? *) let named = Named.create_prim (Unary (move, my_closure')) Debuginfo.none in @@ -2511,10 +2523,9 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot let acc, body = Variable.Map.fold (fun var value_slot (acc, body) -> - let var = - VB.create var Flambda_uid.internal_not_actually_unique - Name_mode.normal - in + let var = VB.create var Flambda_debug_uid.none Name_mode.normal in + (* CR sspies: Should we put in more effort to propagate a debugging + uid to here? *) let named = Named.create_prim (Unary @@ -2529,8 +2540,7 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot let next_depth_expr = Rec_info_expr.succ (Rec_info_expr.var my_depth) in let bound = Bound_pattern.singleton - (Bound_var.create next_depth Flambda_uid.internal_not_actually_unique - Name_mode.normal) + (Bound_var.create next_depth next_depth_duid Name_mode.normal) in Let_with_acc.create acc bound (Named.create_rec_info next_depth_expr) ~body in @@ -2958,11 +2968,11 @@ let close_let_rec acc env ~function_declarations List.fold_left (fun (fun_vars_map, ident_map) decl -> let ident = Function_decl.let_rec_ident decl in + let ident_duid = Function_decl.let_rec_debug_uid decl in let fun_var = - (* CR tnowak: verify *) - VB.create - (fst (Env.find_var env ident)) - Flambda_uid.internal_not_actually_unique Name_mode.normal + VB.create (fst (Env.find_var env ident)) ident_duid Name_mode.normal + (* CR sspies: Does it make sense here to take the debugging uid of the + function? *) in let function_slot = Function_decl.function_slot decl in ( Function_slot.Map.add function_slot fun_var fun_vars_map, @@ -3027,7 +3037,7 @@ let close_let_rec acc env ~function_declarations let fun_var = VB.create (Variable.create "generated") - Flambda_uid.internal_not_actually_unique Name_mode.normal + Flambda_debug_uid.none Name_mode.normal in Function_slot.Map.add function_slot fun_var fun_vars_map) generated_closures fun_vars_map @@ -3059,6 +3069,9 @@ let wrap_partial_application acc env apply_continuation (apply : IR.apply) (* In case of partial application, creates a wrapping function from scratch to allow inlining and lifting *) let wrapper_id = Ident.create_local ("partial_" ^ Ident.name apply.func) in + let wrapper_id_duid = Flambda_debug_uid.none in + (* CR sspies: Should we try harder to get a debug uid here? Seems this + variable is not user visible. *) let function_slot = Function_slot.create (Compilation_unit.get_current_exn ()) @@ -3090,8 +3103,7 @@ let wrap_partial_application acc env apply_continuation (apply : IR.apply) List.mapi (fun n (kind, mode) : Function_decl.param -> { name = Ident.create_local ("param" ^ string_of_int (num_provided + n)); - var_uid = - Flambda_uid.internal_not_actually_unique (* CR tnowak: verify *); + debug_uid = Flambda_debug_uid.none; kind; attributes = Lambda.default_param_attribute; mode = Alloc_mode.For_types.to_lambda mode @@ -3176,7 +3188,7 @@ let wrap_partial_application acc env apply_continuation (apply : IR.apply) else let function_declarations = [ Function_decl.create ~let_rec_ident:(Some wrapper_id) - ~let_rec_uid:Flambda_uid.internal_not_actually_unique ~function_slot + ~let_rec_uid:wrapper_id_duid ~function_slot ~kind: (Lambda.Curried { nlocal = @@ -3206,6 +3218,7 @@ let wrap_over_application acc env full_call (apply : IR.apply) ~remaining ~remaining_arity ~result_mode = let wrapper_cont = Continuation.create () in let returned_func = Variable.create "func" in + let returned_func_duid = Flambda_debug_uid.none in (* See comments in [Simplify_common.split_direct_over_application] about this code for handling local allocations. *) let apply_return_continuation = @@ -3268,10 +3281,9 @@ let wrap_over_application acc env full_call (apply : IR.apply) ~remaining let over_application_results = List.mapi (fun i kind -> - BP.create - (Variable.create ("result" ^ string_of_int i)) - kind - Flambda_uid.internal_not_actually_unique (* CR tnowak: verify *)) + let result_var = Variable.create ("result" ^ string_of_int i) in + let result_var_duid = Flambda_debug_uid.none in + BP.create result_var kind result_var_duid) (Flambda_arity.unarized_components apply.return_arity) in let handler acc = @@ -3286,9 +3298,8 @@ let wrap_over_application acc env full_call (apply : IR.apply) ~remaining let acc, body = Let_with_acc.create acc (Bound_pattern.singleton - (Bound_var.create (Variable.create "unit") - Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) Name_mode.normal)) + (Bound_var.create (Variable.create "unit") Flambda_debug_uid.none + Name_mode.normal)) (Named.create_prim (Unary (End_region { ghost = true }, Simple.var ghost_region)) apply_dbg) @@ -3296,9 +3307,8 @@ let wrap_over_application acc env full_call (apply : IR.apply) ~remaining in Let_with_acc.create acc (Bound_pattern.singleton - (Bound_var.create (Variable.create "unit") - Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) Name_mode.normal)) + (Bound_var.create (Variable.create "unit") Flambda_debug_uid.none + Name_mode.normal)) (Named.create_prim (Unary (End_region { ghost = false }, Simple.var region)) apply_dbg) @@ -3316,8 +3326,7 @@ let wrap_over_application acc env full_call (apply : IR.apply) ~remaining let acc, both_applications = Let_cont_with_acc.build_non_recursive acc wrapper_cont ~handler_params: - ([ BP.create returned_func K.With_subkind.any_value - Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *) ] + ([BP.create returned_func K.With_subkind.any_value returned_func_duid] |> Bound_parameters.create) ~handler:perform_over_application ~body ~is_exn_handler:false ~is_cold:false @@ -3325,12 +3334,12 @@ let wrap_over_application acc env full_call (apply : IR.apply) ~remaining match needs_region with | None -> acc, both_applications | Some (region, ghost_region, _) -> + let region_duid = Flambda_debug_uid.none in + let ghost_region_duid = Flambda_debug_uid.none in let acc, body = Let_with_acc.create acc (Bound_pattern.singleton - (Bound_var.create ghost_region - Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) Name_mode.normal)) + (Bound_var.create ghost_region ghost_region_duid Name_mode.normal)) (Named.create_prim (Variadic (Begin_region { ghost = true }, [])) apply_dbg) @@ -3338,8 +3347,7 @@ let wrap_over_application acc env full_call (apply : IR.apply) ~remaining in Let_with_acc.create acc (Bound_pattern.singleton - (Bound_var.create region Flambda_uid.internal_not_actually_unique - Name_mode.normal)) + (Bound_var.create region region_duid Name_mode.normal)) (Named.create_prim (Variadic (Begin_region { ghost = false }, [])) apply_dbg) @@ -3604,6 +3612,7 @@ let bind_code_and_sets_of_closures all_code sets_of_closures acc body = let wrap_final_module_block acc env ~program ~prog_return_cont ~module_block_size_in_words ~return_cont ~module_symbol = let module_block_var = Variable.create "module_block" in + let module_block_var_duid = Flambda_debug_uid.none in let module_block_tag = Tag.Scannable.zero in let load_fields_body acc = let env = @@ -3620,13 +3629,13 @@ let wrap_final_module_block acc env ~program ~prog_return_cont let field_vars = List.init module_block_size_in_words (fun pos -> let pos_str = string_of_int pos in - pos, Variable.create ("field_" ^ pos_str)) + pos, Variable.create ("field_" ^ pos_str), Flambda_debug_uid.none) in let acc, body = let static_const : Static_const.t = let field_vars = List.map - (fun (_, var) -> + (fun (_, var, _) -> Simple.With_debuginfo.create (Simple.var var) Debuginfo.none) field_vars in @@ -3661,12 +3670,8 @@ let wrap_final_module_block acc env ~program ~prog_return_cont } in List.fold_left - (fun (acc, body) (pos, var) -> - (* CR tnowak: verify *) - let var = - VB.create var Flambda_uid.internal_not_actually_unique - Name_mode.normal - in + (fun (acc, body) (pos, var, var_duid) -> + let var = VB.create var var_duid Name_mode.normal in let pat = Bound_pattern.singleton var in let pos = Targetint_31_63.of_int pos in let block = module_block_simple in @@ -3687,8 +3692,7 @@ let wrap_final_module_block acc env ~program ~prog_return_cont (acc, body) (List.rev field_vars) in let load_fields_handler_param = - [ BP.create module_block_var K.With_subkind.any_value - Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *) ] + [BP.create module_block_var K.With_subkind.any_value module_block_var_duid] |> Bound_parameters.create in (* This binds the return continuation that is free (or, at least, not bound) diff --git a/middle_end/flambda2/from_lambda/closure_conversion.mli b/middle_end/flambda2/from_lambda/closure_conversion.mli index b2cd1961c1d..cef45e75983 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.mli +++ b/middle_end/flambda2/from_lambda/closure_conversion.mli @@ -25,7 +25,7 @@ module Expr_with_acc = Closure_conversion_aux.Expr_with_acc val close_let : Acc.t -> Env.t -> - (Ident.t * Flambda_uid.t * Flambda_kind.With_subkind.t) list -> + (Ident.t * Flambda_debug_uid.t * Flambda_kind.With_subkind.t) list -> IR.user_visible -> IR.named -> body:(Acc.t -> Env.t -> Expr_with_acc.t) -> @@ -45,7 +45,11 @@ val close_let_cont : name:Continuation.t -> is_exn_handler:bool -> params: - (Ident.t * Flambda_uid.t * IR.user_visible * Flambda_kind.With_subkind.t) list -> + (Ident.t + * Flambda_debug_uid.t + * IR.user_visible + * Flambda_kind.With_subkind.t) + list -> recursive:Asttypes.rec_flag -> handler:(Acc.t -> Env.t -> Expr_with_acc.t) -> body:(Acc.t -> Env.t -> Expr_with_acc.t) -> diff --git a/middle_end/flambda2/from_lambda/closure_conversion_aux.ml b/middle_end/flambda2/from_lambda/closure_conversion_aux.ml index 4b66f646334..9d2db8a9ec2 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion_aux.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion_aux.ml @@ -23,7 +23,8 @@ module IR = struct type exn_continuation = { exn_handler : Continuation.t; - extra_args : (simple * Flambda_uid.t * Flambda_kind.With_subkind.t) list + extra_args : + (simple * Flambda_debug_uid.t * Flambda_kind.With_subkind.t) list } type trap_action = @@ -747,7 +748,7 @@ module Function_decls = struct module Function_decl = struct type param = { name : Ident.t; - var_uid : Flambda_uid.t; + debug_uid : Flambda_debug_uid.t; kind : Flambda_kind.With_subkind.t; attributes : Lambda.parameter_attribute; mode : Lambda.locality_mode @@ -765,7 +766,7 @@ module Function_decls = struct type t = { let_rec_ident : Ident.t; - let_rec_uid : Flambda_uid.t; + let_rec_uid : Flambda_debug_uid.t; function_slot : Function_slot.t; kind : Lambda.function_kind; params : param list; @@ -834,6 +835,8 @@ module Function_decls = struct let let_rec_ident t = t.let_rec_ident + let let_rec_debug_uid t = t.let_rec_uid + let function_slot t = t.function_slot let kind t = t.kind diff --git a/middle_end/flambda2/from_lambda/closure_conversion_aux.mli b/middle_end/flambda2/from_lambda/closure_conversion_aux.mli index 40489c3e62f..6bc198b6890 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion_aux.mli +++ b/middle_end/flambda2/from_lambda/closure_conversion_aux.mli @@ -25,7 +25,8 @@ module IR : sig type exn_continuation = { exn_handler : Continuation.t; - extra_args : (simple * Flambda_uid.t * Flambda_kind.With_subkind.t) list + extra_args : + (simple * Flambda_debug_uid.t * Flambda_kind.With_subkind.t) list } type trap_action = @@ -146,7 +147,10 @@ module Env : sig val add_vars_like : t -> - (Ident.t * Flambda_uid.t * IR.user_visible * Flambda_kind.With_subkind.t) + (Ident.t + * Flambda_debug_uid.t + * IR.user_visible + * Flambda_kind.With_subkind.t) list -> t * Variable.t list @@ -343,7 +347,7 @@ module Function_decls : sig type param = { name : Ident.t; - var_uid : Flambda_uid.t; + debug_uid : Flambda_debug_uid.t; kind : Flambda_kind.With_subkind.t; attributes : Lambda.parameter_attribute; mode : Lambda.locality_mode @@ -351,7 +355,7 @@ module Function_decls : sig val create : let_rec_ident:Ident.t option -> - let_rec_uid:Flambda_uid.t -> + let_rec_uid:Flambda_debug_uid.t -> function_slot:Function_slot.t -> kind:Lambda.function_kind -> params:param list -> @@ -375,6 +379,8 @@ module Function_decls : sig val let_rec_ident : t -> Ident.t + val let_rec_debug_uid : t -> Flambda_debug_uid.t + val function_slot : t -> Function_slot.t val kind : t -> Lambda.function_kind diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml index aceab5a2711..bac0c675ce7 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml @@ -137,14 +137,14 @@ let compile_staticfail acc env ccenv ~(continuation : Continuation.t) ~args : fun acc ccenv -> CC.close_let acc ccenv [ ( Ident.create_local "unit", - Flambda_uid.internal_not_actually_unique (* CR sspies: fix *), + Flambda_debug_uid.none, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region { is_try_region = false; region; ghost = false }) ~body:(fun acc ccenv -> CC.close_let acc ccenv [ ( Ident.create_local "unit", - Flambda_uid.internal_not_actually_unique, + Flambda_debug_uid.none, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region @@ -204,7 +204,7 @@ let let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler in match arity_component with | Singleton kind -> - let duid = Flambda_uid.uid duid in + let duid = Flambda_debug_uid.of_lambda_debug_uid duid in let param = id, duid, visible, kind in handler_env, param :: params_rev | Unboxed_product _ -> @@ -216,7 +216,9 @@ let let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler Ident.create_local (Printf.sprintf "%s_unboxed%d" (Ident.unique_name id) n) in - let field_uid = Flambda_uid.proj duid ~field:n in + let field_uid = + Flambda_debug_uid.of_lambda_debug_uid_proj duid ~field:n + in field, field_uid, kind) (Flambda_arity.unarize arity) in @@ -280,14 +282,14 @@ let restore_continuation_context acc env ccenv cont ~close_current_region_early in CC.close_let acc ccenv [ ( Ident.create_local "unit", - Flambda_uid.internal_not_actually_unique (* CR sspies: fix *), + Flambda_debug_uid.none, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region { is_try_region = false; region; ghost = false }) ~body:(fun acc ccenv -> CC.close_let acc ccenv [ ( Ident.create_local "unit", - Flambda_uid.internal_not_actually_unique (* CR sspies: fix*), + Flambda_debug_uid.none, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region @@ -373,7 +375,11 @@ let wrap_return_continuation acc env ccenv (apply : IR.apply) = List.map2 (fun return_value_component kind -> ( return_value_component, - Flambda_uid.internal_not_actually_unique, + Flambda_debug_uid.none, + (* CR sspies: There are some debug uids for the extra arguments + that we could propagate here. But it seems these are never user + visible, so there is currently no point in propagate the debug + uids. (They are probably [.none] anyways, I guess.) *) IR.Not_user_visible, kind )) return_value_components return_kinds @@ -435,10 +441,10 @@ let maybe_insert_let_cont result_var_name layout k acc env ccenv body = ~body else let result_var = Ident.create_local result_var_name in - let duid = Shape.Uid.internal_not_actually_unique in + let result_var_duid = Lambda.debug_uid_none in let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler:false - ~params:[result_var, duid, IR.Not_user_visible, layout] + ~params:[result_var, result_var_duid, IR.Not_user_visible, layout] ~handler:(fun acc env ccenv -> k acc env ccenv (get_unarized_vars result_var env) arity_component) ~body @@ -448,9 +454,11 @@ let name_if_not_var acc ccenv name simple kind body = | IR.Var id -> body id acc ccenv | IR.Const _ -> let id = Ident.create_local name in - let duid = Flambda_uid.internal_not_actually_unique in + let id_duid = Flambda_debug_uid.none in + (* CR sspies: I think the [name] is always a constant string (so these are + not user visible variables). As such, using [.none] should be fine. *) CC.close_let acc ccenv - [id, duid, kind] + [id, id_duid, kind] Not_user_visible (IR.Simple simple) ~body:(body id) let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) @@ -476,9 +484,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let new_ids_with_kinds, before_unarization = Env.get_mutable_variable_with_kinds env id in - let fields = - List.map (fun (id, _, _) -> IR.Var id) new_ids_with_kinds - in + let fields = List.map (fun (id, _, _) -> IR.Var id) new_ids_with_kinds in apply_cps_cont_simple k acc env ccenv fields before_unarization | Lconst const -> apply_cps_cont_simple k acc env ccenv [IR.Const const] @@ -505,9 +511,11 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) ap_loc ap_inlined ap_probe ap_result_layout k k_exn) | Lfunction func -> let id = Ident.create_local (name_for_function func) in + let id_duid = Flambda_debug_uid.none in + (* CR sspies: Is there a better [Flambda_debug_uid.t] available here? *) let dbg = Debuginfo.from_location func.loc in let func = - cps_function env ~fid:id ~fuid:Flambda_uid.internal_not_actually_unique + cps_function env ~fid:id ~fuid:id_duid ~recursive:(Non_recursive : Recursive.t) func in @@ -518,12 +526,14 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) CC.close_let_rec acc ccenv ~function_declarations:[func] ~body ~current_region: (Env.current_region env |> Option.map Env.Region_stack_element.region) - | Lmutlet (layout, id, duid, defining_expr, body) -> + | Lmutlet (layout, id, _duid, defining_expr, body) -> + (* CR sspies: Mutable lets currently do not propagate debugging uids + correctly. *) (* CR mshinwell: user-visibleness needs thinking about here *) let temp_id = Ident.create_local "let_mutable" in + let temp_id_duid = Lambda.debug_uid_none in let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler:false - ~params:[temp_id, duid, IR.Not_user_visible, layout] - (* CR sspies: Probably not where we want the duid to end up. *) + ~params:[temp_id, temp_id_duid, IR.Not_user_visible, layout] ~body:(fun acc env ccenv after_defining_expr -> cps_tail acc env ccenv defining_expr after_defining_expr k_exn) ~handler:(fun acc env ccenv -> @@ -538,7 +548,8 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) match Env.get_unboxed_product_fields env temp_id with | None -> [temp_id] | Some (_, temp_id_unarized) -> List.map fst temp_id_unarized - (* CR sspies: Probably not what we want to do here. *) + (* CR sspies: Probably we do not want to discard the debugging uid + here. *) in List.fold_left2 (fun body new_id_with_kind temp_id acc ccenv -> @@ -570,7 +581,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) layout in CC.close_let acc ccenv - [id, Flambda_uid.uid duid, kind] + [id, Flambda_debug_uid.of_lambda_debug_uid duid, kind] (is_user_visible env id) (Simple (Const const)) ~body | Llet ( ((Strict | Alias | StrictOpt) as let_kind), @@ -584,7 +595,6 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) in match result with | Primitive (prim, args, loc) -> - (* CR sspies: dropping [debug_uid]; address in subsequent PR. *) (* This case avoids extraneous continuations. *) let exn_continuation : IR.exn_continuation option = if L.primitive_can_raise prim @@ -605,7 +615,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) -> ( env, [ ( id, - Flambda_uid.uid duid, + Flambda_debug_uid.of_lambda_debug_uid duid, Flambda_kind.With_subkind .from_lambda_values_and_unboxed_numbers_only layout ) ] ) | Punboxed_product layouts -> @@ -617,7 +627,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let arity = Flambda_arity.create [arity_component] in let fields = Flambda_arity.fresh_idents_unarized ~id arity - |> Flambda_uid.add_proj_debugging_uids_to_fields ~duid + |> Flambda_debug_uid.add_proj_debugging_uids_to_fields ~duid in let env = Env.register_unboxed_product_with_kinds env ~unboxed_product:id @@ -660,7 +670,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let body acc ccenv = cps acc env ccenv body k k_exn in CC.close_let acc ccenv [ ( id, - Flambda_uid.uid duid, + Flambda_debug_uid.of_lambda_debug_uid duid, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (Simple (Const L.const_unit)) ~body in @@ -676,12 +686,13 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) | Llet ((Strict | Alias | StrictOpt), _layout, id, _duid, defining_expr, Lvar id') when Ident.same id id' -> - (* CR sspies: dropping [debug_uid]; address in subsequent PR. *) + (* CR sspies: Is there any use for the debugging uid in this case? *) (* Simplif already simplifies such bindings, but we can generate new ones when translating primitives (see the Lprim case below). *) (* This case must not be moved above the case for let-bound primitives. *) cps acc env ccenv defining_expr k k_exn - | Llet ((Strict | Alias | StrictOpt), layout, id, duid, defining_expr, body) -> + | Llet ((Strict | Alias | StrictOpt), layout, id, duid, defining_expr, body) + -> let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler:false ~params:[id, duid, is_user_visible env id, layout] ~body:(fun acc env ccenv after_defining_expr -> @@ -794,7 +805,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) List.fold_left_map (fun handler_env ((arg, duid, layout), kinds) -> match kinds with - | [kind] -> handler_env, [arg, Flambda_uid.uid duid, kind] + | [kind] -> + ( handler_env, + [arg, Flambda_debug_uid.of_lambda_debug_uid duid, kind] ) | [] | _ :: _ -> let fields = List.mapi @@ -804,7 +817,10 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) (Printf.sprintf "%s_unboxed%d" (Ident.unique_name arg) n) in - let duid = Flambda_uid.proj duid ~field:n in + let duid = + Flambda_debug_uid.of_lambda_debug_uid_proj duid + ~field:n + in ident, duid, kind) kinds in @@ -876,12 +892,14 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) k_exn) k_exn) k_exn - | Ltrywith (body, id, _duid, handler, kind) -> - (* CR sspies: dropping [debug_uid]; address in subsequent PR. *) + | Ltrywith (body, id, duid, handler, kind) -> let dbg = Debuginfo.none (* CR mshinwell: fix [Lambda] *) in let body_result = Ident.create_local "body_result" in + let body_result_lambda_duid = L.debug_uid_none in let region = Ident.create_local "try_region" in + let region_duid = Flambda_debug_uid.none in let ghost_region = Ident.create_local "try_ghost_region" in + let ghost_region_duid = Flambda_debug_uid.none in (* As for all other constructs, the OCaml type checker and the Lambda generation pass ensures that there will be an enclosing region around the whole [Ltrywith] (possibly not immediately enclosing, but maybe further @@ -902,16 +920,14 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let handler k acc env ccenv = CC.close_let acc ccenv [ ( Ident.create_local "unit", - Flambda_uid.internal_not_actually_unique, + Flambda_debug_uid.none, Flambda_kind.With_subkind.tagged_immediate ) ] - (* CR sspies: can we do better? *) Not_user_visible (End_region { is_try_region = true; region; ghost = false }) ~body:(fun acc ccenv -> CC.close_let acc ccenv [ ( Ident.create_local "unit", - Flambda_uid.internal_not_actually_unique, - (* CR sspies: can we do better? *) + Flambda_debug_uid.none, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region @@ -921,9 +937,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let region_stack_elt = Env.current_region env in let begin_try_region body = CC.close_let acc ccenv - [ ( region, - Flambda_uid.internal_not_actually_unique, - Flambda_kind.With_subkind.region ) ] + [region, region_duid, Flambda_kind.With_subkind.region] Not_user_visible (Begin_region { is_try_region = true; @@ -933,9 +947,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) }) ~body:(fun acc ccenv -> CC.close_let acc ccenv - [ ( ghost_region, - Flambda_uid.internal_not_actually_unique, - Flambda_kind.With_subkind.region ) ] + [ghost_region, ghost_region_duid, Flambda_kind.With_subkind.region] Not_user_visible (Begin_region { is_try_region = true; @@ -951,19 +963,13 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) (fun acc env ccenv k -> let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler:true - ~params: - [ ( id, - (* CR mshinwell: there should be a Uid here, needs adding to - Ltrywith *) - Shape.Uid.internal_not_actually_unique, - is_user_visible env id, - Lambda.layout_block ) ] + ~params:[id, duid, is_user_visible env id, Lambda.layout_block] ~body:(fun acc env ccenv handler_continuation -> let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler:false ~params: [ ( body_result, - Shape.Uid.internal_not_actually_unique, + body_result_lambda_duid, Not_user_visible, kind ) ] ~body:(fun acc env ccenv poptrap_continuation -> @@ -1053,14 +1059,14 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let ghost_region = Env.Region_stack_element.ghost_region current_region in CC.close_let acc ccenv [ ( Ident.create_local "unit", - Flambda_uid.internal_not_actually_unique, + Flambda_debug_uid.none, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region { is_try_region = false; region; ghost = false }) ~body:(fun acc ccenv -> CC.close_let acc ccenv [ ( Ident.create_local "unit", - Flambda_uid.internal_not_actually_unique (* CR sspies: fix *), + Flambda_debug_uid.none, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region @@ -1073,16 +1079,16 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) above). Since we're not in tail position, we also need to have a new continuation for the code after the body. *) let region = Ident.create_local "region" in + let region_duid = Flambda_debug_uid.none in let ghost_region = Ident.create_local "ghost_region" in + let ghost_region_duid = Flambda_debug_uid.none in let parent_stack_elt = Env.current_region env in let region_stack_elt = Env.Region_stack_element.create ~region ~ghost_region in let dbg = Debuginfo.none in CC.close_let acc ccenv - [ ( region, - Flambda_uid.internal_not_actually_unique, - Flambda_kind.With_subkind.region ) ] + [region, region_duid, Flambda_kind.With_subkind.region] Not_user_visible (Begin_region { is_try_region = false; @@ -1092,9 +1098,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) }) ~body:(fun acc ccenv -> CC.close_let acc ccenv - [ ( ghost_region, - Flambda_uid.internal_not_actually_unique (* CR sspies: fix *), - Flambda_kind.With_subkind.region ) ] + [ghost_region, ghost_region_duid, Flambda_kind.With_subkind.region] Not_user_visible (Begin_region { is_try_region = false; @@ -1144,7 +1148,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) ~handler:(fun acc env ccenv -> CC.close_let acc ccenv [ ( Ident.create_local "unit", - Flambda_uid.internal_not_actually_unique, + Flambda_debug_uid.none, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region @@ -1152,7 +1156,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) ~body:(fun acc ccenv -> CC.close_let acc ccenv [ ( Ident.create_local "unit", - Flambda_uid.internal_not_actually_unique, + Flambda_debug_uid.none, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region @@ -1298,8 +1302,8 @@ and cps_function_bindings env (bindings : Lambda.rec_binding list) = ~params ~body:fbody ~return ~attr ~loc ~ret_mode ~mode with | [{ id; debug_uid = duid; def = lfun }] -> [id, duid, lfun] - | [{ id = id1; debug_uid = duid1; def = lfun1 }; - { id = id2; debug_uid = duid2; def = lfun2 }] -> + | [ { id = id1; debug_uid = duid1; def = lfun1 }; + { id = id2; debug_uid = duid2; def = lfun2 } ] -> [id1, duid1, lfun1; id2, duid2, lfun2] | [] | _ :: _ :: _ :: _ -> Misc.fatal_errorf @@ -1342,7 +1346,7 @@ and cps_function_bindings env (bindings : Lambda.rec_binding list) = let bindings_with_wrappers = List.flatten bindings_with_wrappers in List.map (fun (fun_id, fun_uid, def) -> - let fuid = Flambda_uid.uid fun_uid in + let fuid = Flambda_debug_uid.of_lambda_debug_uid fun_uid in cps_function env ~fid:fun_id ~fuid ~recursive:(recursive fun_id) ~precomputed_free_idents:(Ident.Map.find fun_id free_idents) def) @@ -1512,17 +1516,19 @@ and cps_function env ~fid ~fuid ~(recursive : Recursive.t) let unboxed_products = ref Ident.Map.empty in let params = List.concat_map - (fun (({ name; debug_uid = var_uid; layout; mode; attributes } : L.lparam), kinds) : + (fun (({ name; debug_uid; layout; mode; attributes } : L.lparam), kinds) : Function_decl.param list -> match kinds with | [kind] -> - let var_uid = Flambda_uid.uid var_uid in - [{ name; var_uid; kind; mode; attributes }] + let debug_uid = Flambda_debug_uid.of_lambda_debug_uid debug_uid in + [{ name; debug_uid; kind; mode; attributes }] | [] | _ :: _ -> let fields = List.mapi (fun n kind -> - let duid = Flambda_uid.proj var_uid ~field:n in + let duid = + Flambda_debug_uid.of_lambda_debug_uid_proj debug_uid ~field:n + in let ident = Ident.create_local (Printf.sprintf "%s_unboxed%d" (Ident.unique_name name) n) @@ -1536,8 +1542,8 @@ and cps_function env ~fid ~fuid ~(recursive : Recursive.t) unboxed_products := Ident.Map.add name (before_unarization, fields) !unboxed_products; List.map - (fun (name, var_uid, kind) : Function_decl.param -> - { name; var_uid; kind; mode; attributes }) + (fun (name, debug_uid, kind) : Function_decl.param -> + { name; debug_uid; kind; mode; attributes }) fields) (List.combine params unarized_per_param) in @@ -1687,13 +1693,14 @@ and cps_switch acc env ccenv (switch : L.lambda_switch) ~condition_dbg CC.close_switch acc ccenv ~condition_dbg scrutinee const_switch in let scrutinee_tag = Ident.create_local "scrutinee_tag" in + let scrutinee_tag_duid = Flambda_debug_uid.none in let block_switch acc ccenv = let body acc ccenv = CC.close_switch acc ccenv ~condition_dbg scrutinee_tag block_switch in CC.close_let acc ccenv [ ( scrutinee_tag, - Flambda_uid.internal_not_actually_unique, + scrutinee_tag_duid, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (Get_tag scrutinee) ~body in @@ -1713,6 +1720,7 @@ and cps_switch acc env ccenv (switch : L.lambda_switch) ~condition_dbg } in let is_scrutinee_int = Ident.create_local "is_scrutinee_int" in + let is_scrutinee_int_duid = Flambda_debug_uid.none in let isint_switch acc ccenv = let body acc ccenv = CC.close_switch acc ccenv ~condition_dbg is_scrutinee_int @@ -1727,7 +1735,7 @@ and cps_switch acc env ccenv (switch : L.lambda_switch) ~condition_dbg in CC.close_let acc ccenv [ ( is_scrutinee_int, - Flambda_uid.internal_not_actually_unique, + is_scrutinee_int_duid, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (Prim diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda_env.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda_env.ml index 156325e6f63..809ee063fce 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_env.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_env.ml @@ -71,13 +71,14 @@ end type t = { current_unit : Compilation_unit.t; current_values_of_mutables_in_scope : - ((Ident.t * Flambda_uid.t * Flambda_kind.With_subkind.full_kind) list + ((Ident.t * Flambda_debug_uid.t * Flambda_kind.With_subkind.full_kind) + list * [`Complex] Flambda_arity.Component_for_creation.t) Ident.Map.t; mutables_needed_by_continuations : Ident.Set.t Continuation.Map.t; unboxed_product_components_in_scope : ([`Complex] Flambda_arity.Component_for_creation.t - * (Ident.t * Flambda_uid.t) list) + * (Ident.t * Flambda_debug_uid.t) list) Ident.Map.t; try_stack : Continuation.t list; try_stack_at_handler : Continuation.t list Continuation.Map.t; @@ -126,7 +127,8 @@ let register_mutable_variable t id ~before_unarization = let fields = Flambda_arity.fresh_idents_unarized ~id (Flambda_arity.create [before_unarization]) - |> Flambda_uid.add_proj_debugging_uids_to_fields ~duid:Lambda.debug_uid_none + |> Flambda_debug_uid.add_proj_debugging_uids_to_fields + ~duid:Lambda.debug_uid_none (* CR sspies: We should propagate the debugging uid here for mutable variables. *) in @@ -146,8 +148,8 @@ let update_mutable_variable t id = let fields = Flambda_arity.fresh_idents_unarized ~id (Flambda_arity.create [before_unarization]) - |> Flambda_uid.add_proj_debugging_uids_to_fields - ~duid:Lambda.debug_uid_none + |> Flambda_debug_uid.add_proj_debugging_uids_to_fields + ~duid:Lambda.debug_uid_none (* CR sspies: We should derive/copy the debugging uids here from before_unarization/old_ids_and_kinds. *) in @@ -176,7 +178,8 @@ let register_unboxed_product_with_kinds t ~unboxed_product ~before_unarization type add_continuation_result = { body_env : t; handler_env : t; - extra_params : (Ident.t * Flambda_uid.t * Flambda_kind.With_subkind.t) list + extra_params : + (Ident.t * Flambda_debug_uid.t * Flambda_kind.With_subkind.t) list } let add_continuation t cont ~push_to_try_stack ~pop_region @@ -212,10 +215,10 @@ let add_continuation t cont ~push_to_try_stack ~pop_region let fields = Flambda_arity.fresh_idents_unarized ~id:mut_var (Flambda_arity.create [before_unarization]) - |> Flambda_uid.add_proj_debugging_uids_to_fields - ~duid:Lambda.debug_uid_none + |> Flambda_debug_uid.add_proj_debugging_uids_to_fields + ~duid:Lambda.debug_uid_none (* CR sspies: We should derive/copy the debugging uids here from - before_unarization/old_ids_and_kinds. *) + before_unarization/old_ids_and_kinds. *) in fields, before_unarization) t.current_values_of_mutables_in_scope diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda_env.mli b/middle_end/flambda2/from_lambda/lambda_to_flambda_env.mli index c922ca10229..1179edc26c0 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_env.mli +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_env.mli @@ -45,7 +45,7 @@ val register_mutable_variable : t -> Ident.t -> before_unarization:[`Complex] Flambda_arity.Component_for_creation.t -> - t * (Ident.t * Flambda_uid.t * Flambda_kind.With_subkind.full_kind) list + t * (Ident.t * Flambda_debug_uid.t * Flambda_kind.With_subkind.full_kind) list val update_mutable_variable : t -> Ident.t -> t @@ -53,27 +53,28 @@ val register_unboxed_product : t -> unboxed_product:Ident.t -> before_unarization:[`Complex] Flambda_arity.Component_for_creation.t -> - fields:(Ident.t * Flambda_uid.t) list -> + fields:(Ident.t * Flambda_debug_uid.t) list -> t val register_unboxed_product_with_kinds : t -> unboxed_product:Ident.t -> before_unarization:[`Complex] Flambda_arity.Component_for_creation.t -> - fields:(Ident.t * Flambda_uid.t * Flambda_kind.With_subkind.t) list -> + fields:(Ident.t * Flambda_debug_uid.t * Flambda_kind.With_subkind.t) list -> t val get_unboxed_product_fields : t -> Ident.t -> ([`Complex] Flambda_arity.Component_for_creation.t - * (Ident.t * Flambda_uid.t) list) + * (Ident.t * Flambda_debug_uid.t) list) option type add_continuation_result = private { body_env : t; handler_env : t; - extra_params : (Ident.t * Flambda_uid.t * Flambda_kind.With_subkind.t) list + extra_params : + (Ident.t * Flambda_debug_uid.t * Flambda_kind.With_subkind.t) list } val add_continuation : @@ -102,12 +103,12 @@ val extra_args_for_continuation : t -> Continuation.t -> Ident.t list val extra_args_for_continuation_with_kinds : t -> Continuation.t -> - (Ident.t * Flambda_uid.t * Flambda_kind.With_subkind.t) list + (Ident.t * Flambda_debug_uid.t * Flambda_kind.With_subkind.t) list val get_mutable_variable_with_kinds : t -> Ident.t -> - (Ident.t * Flambda_uid.t * Flambda_kind.With_subkind.t) list + (Ident.t * Flambda_debug_uid.t * Flambda_kind.With_subkind.t) list * [`Complex] Flambda_arity.Component_for_creation.t (** About local allocation regions: diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives_helpers.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives_helpers.ml index 96b180f6f7b..be715a984ac 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives_helpers.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives_helpers.ml @@ -308,24 +308,25 @@ let rec bind_recs acc exn_cont ~register_const0 (prim : expr_primitive) ~body ~is_exn_handler:false ~is_cold:false | If_then_else (cond, ifso, ifnot, result_kinds) -> let cond_result = Variable.create "cond_result" in + let cond_result_duid = Flambda_debug_uid.none in let cond_result_pat = - Bound_var.create cond_result Flambda_uid.internal_not_actually_unique - Name_mode.normal + Bound_var.create cond_result cond_result_duid Name_mode.normal in let ifso_cont = Continuation.create () in let ifnot_cont = Continuation.create () in let join_point_cont = Continuation.create () in let result_vars = - List.map (fun _ -> Variable.create "if_then_else_result") result_kinds + List.map + (fun _ -> Variable.create "if_then_else_result", Flambda_debug_uid.none) + result_kinds in let result_params = List.map2 - (fun result_var result_kind -> - Bound_parameter.create result_var result_kind - Flambda_uid.internal_not_actually_unique (* CR sspies: new *)) + (fun (result_var, result_var_duid) result_kind -> + Bound_parameter.create result_var result_kind result_var_duid) result_vars result_kinds in - let result_simples = List.map Simple.var result_vars in + let result_simples = List.map (fun (v, _) -> Simple.var v) result_vars in let result_nameds = List.map Named.create_simple result_simples in bind_recs acc exn_cont ~register_const0 cond dbg @@ fun acc cond -> let cond = must_be_singleton_named cond in @@ -349,16 +350,17 @@ let rec bind_recs acc exn_cont ~register_const0 (prim : expr_primitive) bind_recs acc exn_cont ~register_const0 ifso_or_ifnot dbg @@ fun acc ifso_or_ifnot -> let result_vars = - List.map (fun _ -> Variable.create (name ^ "_result")) ifso_or_ifnot + List.map + (fun _ -> Variable.create (name ^ "_result"), Flambda_debug_uid.none) + ifso_or_ifnot in let result_pats = List.map - (fun result_var -> - Bound_var.create result_var Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) Name_mode.normal) + (fun (result_var, result_var_duid) -> + Bound_var.create result_var result_var_duid Name_mode.normal) result_vars in - let result_simples = List.map Simple.var result_vars in + let result_simples = List.map (fun (v, _) -> Simple.var v) result_vars in let acc, apply_cont = Apply_cont_with_acc.create acc join_point_cont ~args:result_simples ~dbg in @@ -394,9 +396,8 @@ let rec bind_recs acc exn_cont ~register_const0 (prim : expr_primitive) (fun acc nameds -> let named = must_be_singleton_named nameds in let pat = - Bound_var.create (Variable.create "seq") - Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) Name_mode.normal + Bound_var.create (Variable.create "seq") Flambda_debug_uid.none + Name_mode.normal |> Bound_pattern.singleton in Let_with_acc.create acc pat named ~body)) @@ -417,15 +418,17 @@ and bind_rec_primitive acc exn_cont ~register_const0 (prim : simple_or_prim) | Simple s -> cont acc [s] | Prim p -> let cont acc (nameds : Named.t list) = - let vars = List.map (fun _ -> Variable.create "prim") nameds in + let vars = + List.map + (fun _ -> Variable.create "prim", Flambda_debug_uid.none) + nameds + in let vars' = List.map - (fun var -> - VB.create var Flambda_uid.internal_not_actually_unique - Name_mode.normal) + (fun (var, var_duid) -> VB.create var var_duid Name_mode.normal) vars in - let acc, body = cont acc (List.map Simple.var vars) in + let acc, body = cont acc (List.map (fun (v, _) -> Simple.var v) vars) in List.fold_left2 (fun (acc, body) pat prim -> Let_with_acc.create acc (Bound_pattern.singleton pat) prim ~body) diff --git a/middle_end/flambda2/identifiers/flambda_uid.ml b/middle_end/flambda2/identifiers/flambda_debug_uid.ml similarity index 83% rename from middle_end/flambda2/identifiers/flambda_uid.ml rename to middle_end/flambda2/identifiers/flambda_debug_uid.ml index d3b39db6090..bcb664d4f2b 100644 --- a/middle_end/flambda2/identifiers/flambda_uid.ml +++ b/middle_end/flambda2/identifiers/flambda_debug_uid.ml @@ -13,19 +13,23 @@ (**************************************************************************) module Uid = Shape.Uid +(* Lambda debugging uids of type [Lambda.debug_uid] are actually values of type + Shape.Uid.t, so we use the functions from [Shape.Uid] below. *) type t = - | Uid of Uid.t - | Proj of Uid.t * int + | Uid of Lambda.debug_uid + | Proj of Lambda.debug_uid * int -let internal_not_actually_unique = Uid Uid.internal_not_actually_unique +let none = Uid Lambda.debug_uid_none -let uid u = Uid u +let of_lambda_debug_uid u = Uid u -let proj u ~field = Proj (u, field) +let of_lambda_debug_uid_proj u ~field = Proj (u, field) let add_proj_debugging_uids_to_fields ~duid fields = - List.mapi (fun i (id, kind) -> id, proj duid ~field:i, kind) fields + List.mapi + (fun i (id, kind) -> id, of_lambda_debug_uid_proj duid ~field:i, kind) + fields module T0 = struct type nonrec t = t diff --git a/middle_end/flambda2/identifiers/flambda_uid.mli b/middle_end/flambda2/identifiers/flambda_debug_uid.mli similarity index 82% rename from middle_end/flambda2/identifiers/flambda_uid.mli rename to middle_end/flambda2/identifiers/flambda_debug_uid.mli index c1df376a7a3..8ac916d46a3 100644 --- a/middle_end/flambda2/identifiers/flambda_uid.mli +++ b/middle_end/flambda2/identifiers/flambda_debug_uid.mli @@ -12,24 +12,22 @@ (* *) (**************************************************************************) -(** Augmented version of [Shape.Uid.t] that can track variables forming parts +(** Augmented version of [Lambda.debug_uid] that can track variables forming parts of unboxed products. *) type t = private - | Uid of Shape.Uid.t - | Proj of Shape.Uid.t * int + | Uid of Lambda.debug_uid + | Proj of Lambda.debug_uid * int -val internal_not_actually_unique : t +val none : t -val uid : Shape.Uid.t -> t +val of_lambda_debug_uid : Lambda.debug_uid -> t -val proj : Shape.Uid.t -> field:int -> t +val of_lambda_debug_uid_proj : Lambda.debug_uid -> field:int -> t val add_proj_debugging_uids_to_fields : duid:Lambda.debug_uid -> (Ident.t * Flambda_kind.With_subkind.t) list -> (Ident.t * t * Flambda_kind.With_subkind.t) list - - include Identifiable.S with type t := t diff --git a/middle_end/flambda2/parser/fexpr_to_flambda.ml b/middle_end/flambda2/parser/fexpr_to_flambda.ml index 8121ff7c21b..013c2736a1e 100644 --- a/middle_end/flambda2/parser/fexpr_to_flambda.ml +++ b/middle_end/flambda2/parser/fexpr_to_flambda.ml @@ -130,7 +130,10 @@ let fresh_exn_cont env { Fexpr.txt = name; loc = _ } = let fresh_var env { Fexpr.txt = name; loc = _ } = let v = Variable.create name ~user_visible:() in - v, { env with variables = VM.add name v env.variables } + let v_duid = Flambda_debug_uid.none in + (* CR sspies: These variables are apparently user visible. Where do we get + [Lambda.debug_uid] values for them from? *) + v, v_duid, { env with variables = VM.add name v env.variables } let fresh_or_existing_code_id env { Fexpr.txt = name; loc = _ } = match DM.find_opt env.code_ids name with @@ -634,12 +637,8 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = in let bound_vars, env = let convert_binding env (var, _) : Bound_var.t * env = - let var, env = fresh_var env var in - (* CR tnowak: verify *) - let var = - Bound_var.create var Flambda_uid.internal_not_actually_unique - Name_mode.normal - in + let var, var_duid, env = fresh_var env var in + let var = Bound_var.create var var_duid Name_mode.normal in var, env in map_accum_left convert_binding env vars_and_closure_bindings @@ -664,12 +663,9 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = Misc.fatal_errorf "'with' clause only allowed when defining closures" | Let { bindings = [{ var; defining_expr = d }]; body; value_slots = None } -> let named = defining_expr env d in - let id, env = fresh_var env var in + let id, id_duid, env = fresh_var env var in let body = expr env body in - let var = - Bound_var.create id Flambda_uid.internal_not_actually_unique - Name_mode.normal - in + let var = Bound_var.create id id_duid Name_mode.normal in let bound = Bound_pattern.singleton var in Flambda.Let.create bound named ~body ~free_names_of_body:Unknown |> Flambda.Expr.create_let @@ -700,11 +696,11 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = let env, parameters = List.fold_right (fun ({ param; kind } : Fexpr.kinded_parameter) (env, args) -> - let var, env = fresh_var env param in + let var, var_duid, env = fresh_var env param in let param = - Bound_parameter.create var (value_kind_with_subkind_opt kind) - Flambda_uid.internal_not_actually_unique - (* CR tnowak: verify *) + Bound_parameter.create var + (value_kind_with_subkind_opt kind) + var_duid in env, param :: args) params (env, []) @@ -926,20 +922,22 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = let params, env = map_accum_left (fun env ({ param; kind } : Fexpr.kinded_parameter) -> - let var, env = fresh_var env param in + let var, var_duid, env = fresh_var env param in let param = Bound_parameter.create var (value_kind_with_subkind_opt kind) - Flambda_uid.internal_not_actually_unique - (* CR tnowak: verify *) + var_duid in param, env) env params in - let my_closure, env = fresh_var env closure_var in - let my_region, env = fresh_var env region_var in - let my_ghost_region, env = fresh_var env ghost_region_var in - let my_depth, env = fresh_var env depth_var in + let my_closure, _my_closure_duid, env = fresh_var env closure_var in + let my_region, _my_region_duid, env = fresh_var env region_var in + let my_ghost_region, _my_ghost_region, env = + fresh_var env ghost_region_var + in + let my_depth, _my_depth, env = fresh_var env depth_var in + (* CR sspies: Should we propagate these debug identifiers? *) let return_continuation, env = fresh_cont env ret_cont ~sort:Return ~arity:(Flambda_arity.cardinal_unarized result_arity) diff --git a/middle_end/flambda2/reaper/rebuild.ml b/middle_end/flambda2/reaper/rebuild.ml index b143a6d1765..f90e42d2496 100644 --- a/middle_end/flambda2/reaper/rebuild.ml +++ b/middle_end/flambda2/reaper/rebuild.ml @@ -47,6 +47,10 @@ type param_decision = | Delete | Unbox of Variable.t DS.unboxed_fields Field.Map.t +(* CR sspies: Throughout this file, we create bound paramters and variables + without corresponding debugging uids. Does it make sense to properly + propagate debugging uids there? If so, where should they come from? *) + let print_param_decision ppf param_decision = match param_decision with | Keep (v, kind) -> @@ -185,12 +189,14 @@ let get_parameters params_decisions = (fun acc param_decision -> match param_decision with | Delete -> acc - | Keep (var, kind) -> Bound_parameter.create var kind Flambda_uid.internal_not_actually_unique :: acc + | Keep (var, kind) -> + Bound_parameter.create var kind Flambda_debug_uid.none :: acc | Unbox fields -> fold_unboxed_with_kind - (fun kind v acc -> Bound_parameter.create v (KS.anything kind) Flambda_uid.internal_not_actually_unique :: acc) - fields acc) - (* CR sspies: Fix these. Propagate debugging uids here. *) + (fun kind v acc -> + Bound_parameter.create v (KS.anything kind) Flambda_debug_uid.none + :: acc) + fields acc) (* CR sspies: Missing debug uid. *) [] params_decisions |> List.rev @@ -199,13 +205,15 @@ let get_parameters_and_modes params_decisions modes = (fun acc (param_decision, mode) -> match param_decision with | Delete -> acc - | Keep (var, kind) -> (Bound_parameter.create var kind Flambda_uid.internal_not_actually_unique, mode) :: acc + | Keep (var, kind) -> + (Bound_parameter.create var kind Flambda_debug_uid.none, mode) :: acc | Unbox fields -> fold_unboxed_with_kind (fun kind v acc -> - (Bound_parameter.create v (KS.anything kind) Flambda_uid.internal_not_actually_unique, mode) :: acc) - fields acc) - (* CR sspies: Fix these. Propagate debugging uids here. *) + ( Bound_parameter.create v (KS.anything kind) Flambda_debug_uid.none, + mode ) + :: acc) + fields acc) (* CR sspies: Missing debug uid. *) [] (List.combine params_decisions modes) |> List.rev |> List.split @@ -244,8 +252,9 @@ let bind_fields fields arg_fields hole = fold2_unboxed_subset (fun var arg hole -> let bp = - Bound_pattern.singleton (Bound_var.create var Flambda_uid.internal_not_actually_unique Name_mode.normal) - (* CR sspies: Fix these. Propagate debugging uids here. *) + Bound_pattern.singleton + (Bound_var.create var Flambda_debug_uid.none Name_mode.normal) + (* CR sspies: Missing debug uid. *) in RE.create_let bp (Named.create_simple (Simple.var arg)) ~body:hole) fields arg_fields hole @@ -1008,8 +1017,9 @@ let load_field_from_value_which_is_being_unboxed env ~to_bind field arg dbg fold2_unboxed_subset (fun var (field, kind) hole -> let bp = - Bound_pattern.singleton (Bound_var.create var Flambda_uid.internal_not_actually_unique Name_mode.normal) - (* CR sspies: Fix these. *) + Bound_pattern.singleton + (Bound_var.create var Flambda_debug_uid.none Name_mode.normal) + (* CR sspies: Missing debug uid. *) in let named = Named.create_prim @@ -1030,8 +1040,9 @@ let load_field_from_value_which_is_being_unboxed env ~to_bind field arg dbg fold2_unboxed_subset (fun var value_slot hole -> let bp = - Bound_pattern.singleton (Bound_var.create var Flambda_uid.internal_not_actually_unique Name_mode.normal) - (* CR sspies: Fix these. *) + Bound_pattern.singleton + (Bound_var.create var Flambda_debug_uid.none Name_mode.normal) + (* CR sspies: Missing debug uid. *) in let named = Named.create_prim @@ -1091,8 +1102,9 @@ let rebuild_singleton_binding_which_is_being_unboxed env bv | Unboxed _ -> Misc.fatal_errorf "Trying to unbox non-unboxable" in let bp = - Bound_pattern.singleton (Bound_var.create var Flambda_uid.internal_not_actually_unique Name_mode.normal) - (* CR sspies: Fix these. *) + Bound_pattern.singleton + (Bound_var.create var Flambda_debug_uid.none Name_mode.normal) + (* CR sspies: Missing debug uid. *) in RE.create_let bp (Named.create_simple simple) ~body:hole | Right arg_fields -> bind_fields var (Unboxed arg_fields) hole) @@ -1168,8 +1180,9 @@ let rebuild_set_of_closures_binding_which_is_being_unboxed env bvs in let bp = Bound_pattern.singleton - (Bound_var.create var Flambda_uid.internal_not_actually_unique Name_mode.normal) - (* CR sspies: Fix these. *) + (Bound_var.create var Flambda_debug_uid.none + Name_mode.normal) + (* CR sspies: Missing debug uid. *) in RE.create_let bp (Named.create_simple arg) ~body:hole | Block _ | Is_int | Get_tag | Function_slot _ | Code_of_closure @@ -1545,8 +1558,9 @@ and rebuild_holed (env : env) res (rev_expr : Rev_expr.rev_expr_holed) | Some fields -> fold_unboxed_with_kind (fun kind v acc -> - Bound_parameter.create v (KS.anything kind) Flambda_uid.internal_not_actually_unique :: acc) - (* CR sspies: Fix these. *) + Bound_parameter.create v (KS.anything kind) + Flambda_debug_uid.none + :: acc) (* CR sspies: Missing debug uid. *) fields []) l in @@ -1755,8 +1769,9 @@ and rebuild_function_params_and_body (env : env) res code_metadata | Some fields -> ( fold_unboxed_with_kind (fun kind v acc -> - Bound_parameter.create v (KS.anything kind) Flambda_uid.internal_not_actually_unique :: acc) - (* CR sspies: Fix these. *) + Bound_parameter.create v (KS.anything kind) Flambda_debug_uid.none + :: acc) + (* CR sspies: Missing debug uid. *) fields [], Code_metadata.with_is_my_closure_used false code_metadata ) in diff --git a/middle_end/flambda2/simplify/apply_cont_rewrite.ml b/middle_end/flambda2/simplify/apply_cont_rewrite.ml index 1f154a5d745..a078c67b817 100644 --- a/middle_end/flambda2/simplify/apply_cont_rewrite.ml +++ b/middle_end/flambda2/simplify/apply_cont_rewrite.ml @@ -176,9 +176,11 @@ let make_rewrite rewrite ~ctx id args : _ Or_invalid.t = | Already_in_scope simple -> simple, [], Simple.free_names simple, Name_occurrences.empty | New_let_binding (temp, prim) -> + let temp_duid = Flambda_debug_uid.none in + (* CR sspies: The name [temp] suggests that this is not + user-visible. *) let extra_let = - ( Bound_var.create temp Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) Name_mode.normal, + ( Bound_var.create temp temp_duid Name_mode.normal, Code_size.prim prim, Flambda.Named.create_prim prim Debuginfo.none ) in @@ -187,6 +189,9 @@ let make_rewrite rewrite ~ctx id args : _ Or_invalid.t = Flambda_primitive.free_names prim, Name_occurrences.singleton_variable temp Name_mode.normal ) | New_let_binding_with_named_args (temp, gen_prim) -> + let temp_duid = Flambda_debug_uid.none in + (* CR sspies: The name [temp] suggests that this is not + user-visible. *) let prim = match (ctx : rewrite_apply_cont_ctx) with | Apply_expr function_return_values -> @@ -197,8 +202,7 @@ let make_rewrite rewrite ~ctx id args : _ Or_invalid.t = since they are already named." in let extra_let = - ( Bound_var.create temp Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) Name_mode.normal, + ( Bound_var.create temp temp_duid Name_mode.normal, Code_size.prim prim, Flambda.Named.create_prim prim Debuginfo.none ) in diff --git a/middle_end/flambda2/simplify/common_subexpression_elimination.ml b/middle_end/flambda2/simplify/common_subexpression_elimination.ml index 7d901c105fd..b557cfca7ce 100644 --- a/middle_end/flambda2/simplify/common_subexpression_elimination.ml +++ b/middle_end/flambda2/simplify/common_subexpression_elimination.ml @@ -260,10 +260,9 @@ let join_one_cse_equation ~cse_at_each_use prim bound_to_map | None | Some (Rhs_kind.Needs_extra_binding { bound_to = _ }) -> let prim_result_kind = P.result_kind' (EP.to_primitive prim) in let var = Variable.create "cse_param" in + let var_duid = Flambda_debug_uid.none in let extra_param = - BP.create var - (K.With_subkind.anything prim_result_kind) - Flambda_uid.internal_not_actually_unique (* CR tnowak: verify *) + BP.create var (K.With_subkind.anything prim_result_kind) var_duid in let bound_to = RI.Map.map Rhs_kind.bound_to bound_to_map in let cse = EP.Map.add prim (Simple.var var) cse in diff --git a/middle_end/flambda2/simplify/env/downwards_env.ml b/middle_end/flambda2/simplify/env/downwards_env.ml index 04ef067735f..dd1c4792d55 100644 --- a/middle_end/flambda2/simplify/env/downwards_env.ml +++ b/middle_end/flambda2/simplify/env/downwards_env.ml @@ -172,7 +172,7 @@ let define_variable0 ~extra t var kind = Lifted_cont_params.new_param ~replay_history variables_defined_in_current_continuation (Bound_parameter.create (Bound_var.var var) kind - Flambda_uid.internal_not_actually_unique (* CR sspies: fix *)) + (Bound_var.debug_uid var)) in variables_defined_in_current_continuation :: r in @@ -231,15 +231,14 @@ let create ~round ~(resolver : resolver) cost_of_lifting_continuations_out_of_current_one = 0 } in + let my_region_duid = Flambda_debug_uid.none in + let my_ghost_region_duid = Flambda_debug_uid.none in define_variable (define_variable t - (Bound_var.create toplevel_my_region - Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) Name_mode.normal) + (Bound_var.create toplevel_my_region my_region_duid Name_mode.normal) K.region) - (Bound_var.create toplevel_my_ghost_region - Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) Name_mode.normal) + (Bound_var.create toplevel_my_ghost_region my_ghost_region_duid + Name_mode.normal) K.region let all_code t = t.all_code @@ -348,8 +347,10 @@ let define_name t name kind = Name.pattern_match (Bound_name.name name) ~var:(fun [@inline] var -> (define_variable [@inlined hint]) t - (Bound_var.create var Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) (Bound_name.name_mode name)) + (Bound_var.create var Flambda_debug_uid.none + (* CR sspies: Unclear whether bound names should have a + [Flambda_debug_uid.t]. For now, I just left it as [.none]. *) + (Bound_name.name_mode name)) kind) ~symbol:(fun [@inline] sym -> (define_symbol [@inlined hint]) t sym kind) @@ -370,8 +371,10 @@ let add_name t name ty = Name.pattern_match (Bound_name.name name) ~var:(fun [@inline] var -> add_variable t - (Bound_var.create var Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) (Bound_name.name_mode name)) + (Bound_var.create var Flambda_debug_uid.none + (* CR sspies: Unclear whether bound names should have a + [Flambda_debug_uid.t]. For now, I just left it as [.none]. *) + (Bound_name.name_mode name)) ty) ~symbol:(fun [@inline] sym -> add_symbol t sym ty) @@ -411,11 +414,8 @@ let add_equation_on_name t name ty = let define_parameters ~extra t ~params = List.fold_left (fun t param -> - let param_var, _param_uid = BP.var_and_uid param in - let var = - Bound_var.create param_var Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) Name_mode.normal - in + let param_var, param_duid = BP.var_and_uid param in + let var = Bound_var.create param_var param_duid Name_mode.normal in define_variable0 ~extra t var (K.With_subkind.kind (BP.kind param))) t (Bound_parameters.to_list params) @@ -433,11 +433,8 @@ let add_parameters ~extra ?(name_mode = Name_mode.normal) t params ~param_types param_types; List.fold_left2 (fun t param param_type -> - let param_var, _param_uid = BP.var_and_uid param in - let var = - Bound_var.create param_var Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) name_mode - in + let param_var, param_duid = BP.var_and_uid param in + let var = Bound_var.create param_var param_duid name_mode in add_variable0 ~extra t var param_type) t params param_types diff --git a/middle_end/flambda2/simplify/expr_builder.ml b/middle_end/flambda2/simplify/expr_builder.ml index 5d5ac75a5e5..4f8f47e4acf 100644 --- a/middle_end/flambda2/simplify/expr_builder.ml +++ b/middle_end/flambda2/simplify/expr_builder.ml @@ -264,6 +264,9 @@ let create_coerced_singleton_let uacc var defining_expr let name = "uncoerced_" ^ Variable.unique_name (VB.var var) in Variable.create name in + let uncoerced_var_duid = Flambda_debug_uid.none in + (* CR sspies: Would it make sense here to propagate the + [Flambda_debug_uid.t] of the variable [var]? *) (* Generate [let var = uncoerced_var @ ] *) let ((body, uacc, inner_result) as inner) = let defining_simple = @@ -285,8 +288,7 @@ let create_coerced_singleton_let uacc var defining_expr let ((_body, _uacc, outer_result) as outer) = let bound = Bound_pattern.singleton - (VB.create uncoerced_var Flambda_uid.internal_not_actually_unique - name_mode) + (VB.create uncoerced_var uncoerced_var_duid name_mode) in create_let uacc bound defining_expr ~free_names_of_defining_expr ~body ~cost_metrics_of_defining_expr @@ -571,9 +573,9 @@ let create_let_symbols uacc lifted_constant ~body = let free_names_of_defining_expr = Named.free_names defining_expr in let expr, uacc, _ = create_coerced_singleton_let uacc - (* CR tnowak: verify *) - (VB.create var Flambda_uid.internal_not_actually_unique - Name_mode.normal) + (VB.create var Flambda_debug_uid.none Name_mode.normal) + (* CR sspies: I have no idea whether this could ever be a user visible + variable. *) defining_expr ~coercion_from_defining_expr_to_var ~free_names_of_defining_expr ~body:expr ~cost_metrics_of_defining_expr in @@ -822,9 +824,9 @@ let rewrite_fixed_arity_continuation0 uacc cont_or_apply_cont ~use_id arity : let params = List.map (fun kind -> - BP.create (Variable.create "param") kind - Flambda_uid.internal_not_actually_unique - (* CR tnowak: verify *)) + let param_var = Variable.create "param" in + let param_var_duid = Flambda_debug_uid.none in + BP.create param_var kind param_var_duid) (Flambda_arity.unarized_components arity) in let args = List.map BP.simple params in diff --git a/middle_end/flambda2/simplify/flow/mutable_unboxing.ml b/middle_end/flambda2/simplify/flow/mutable_unboxing.ml index adfb854f7d1..f460c41db83 100644 --- a/middle_end/flambda2/simplify/flow/mutable_unboxing.ml +++ b/middle_end/flambda2/simplify/flow/mutable_unboxing.ml @@ -484,9 +484,11 @@ module Fold_prims = struct "[Mutable Unboxing] Cannot unbox constants") in let var = Variable.create (Printf.sprintf "%s_%i" name i) in - Bound_parameter.create var kind - Flambda_uid.internal_not_actually_unique - (* CR tnowak: verify *)) + let var_duid = Flambda_debug_uid.none in + (* CR sspies: While this is an internally generated variable, + would it make sense to try to propagate a + [Flambda_debug_uid.t] here? *) + Bound_parameter.create var kind var_duid) fields_kinds in let env = diff --git a/middle_end/flambda2/simplify/inlining/inlining_transforms.ml b/middle_end/flambda2/simplify/inlining/inlining_transforms.ml index f572d53585d..a9b160ed3f4 100644 --- a/middle_end/flambda2/simplify/inlining/inlining_transforms.ml +++ b/middle_end/flambda2/simplify/inlining/inlining_transforms.ml @@ -44,9 +44,13 @@ let make_inlined_body ~callee ~called_code_id ~unroll_to ~params ~args in Some callee, unrolled_rec_info) in + let my_closure_duid = Flambda_debug_uid.none in + (* CR sspies: Not sure whethere these closures can ever be user visible. + Popagating a [Lambda_debug_uid.t] here is nontrivial, so I picked + [Flambda_debug_uid.none] for now. *) let my_closure = Bound_parameter.create my_closure Flambda_kind.With_subkind.any_value - Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe here? *) + my_closure_duid in let bind_params ~params ~args ~body = if List.compare_lengths params args <> 0 @@ -65,10 +69,10 @@ let make_inlined_body ~callee ~called_code_id ~unroll_to ~params ~args |> Expr.create_let) in let bind_depth ~my_depth ~rec_info ~body = + let my_depth_duid = Flambda_debug_uid.none in let bound = Bound_pattern.singleton - (VB.create my_depth Flambda_uid.internal_not_actually_unique - Name_mode.normal) + (VB.create my_depth my_depth_duid Name_mode.normal) in Let.create bound (Named.create_rec_info rec_info) diff --git a/middle_end/flambda2/simplify/lifted_cont_params.ml b/middle_end/flambda2/simplify/lifted_cont_params.ml index ab53b063bbd..6ce7b052eff 100644 --- a/middle_end/flambda2/simplify/lifted_cont_params.ml +++ b/middle_end/flambda2/simplify/lifted_cont_params.ml @@ -35,11 +35,11 @@ let new_param t ~replay_history bound_param = match Replay_history.replay_variable_mapping replay_history with | Still_recording -> bound_param | Replayed variable_mapping -> - let original_var = - Variable.Map.find (BP.var bound_param) variable_mapping - in - BP.create original_var (BP.kind bound_param) - Flambda_uid.internal_not_actually_unique (* CR sspies: fix *) + let param_var, param_duid = BP.var_and_uid bound_param in + let original_var = Variable.Map.find param_var variable_mapping in + BP.create original_var (BP.kind bound_param) param_duid + (* CR sspies: Is it correct that we copy the [Flambda_debug_uid.t] here? + This requires a closer look. *) in let new_params_indexed = BP.Map.add key bound_param t.new_params_indexed in { len = t.len + 1; new_params_indexed } diff --git a/middle_end/flambda2/simplify/simplify_apply_cont_expr.ml b/middle_end/flambda2/simplify/simplify_apply_cont_expr.ml index 06e750bdce2..10bfbd820b7 100644 --- a/middle_end/flambda2/simplify/simplify_apply_cont_expr.ml +++ b/middle_end/flambda2/simplify/simplify_apply_cont_expr.ml @@ -43,8 +43,8 @@ let inline_linearly_used_continuation uacc ~params:params' ~handler ListLabels.map2 params args ~f:(fun param arg -> let let_bound = let param_var, param_uid = BP.var_and_uid param in - Bound_var.create param_var param_uid Name_mode.normal - |> Bound_pattern.singleton + Bound_var.create param_var param_uid Name_mode.normal + |> Bound_pattern.singleton in let named = Named.create_simple arg in { Expr_builder.let_bound; diff --git a/middle_end/flambda2/simplify/simplify_apply_expr.ml b/middle_end/flambda2/simplify/simplify_apply_expr.ml index ebe61a65c4f..61e8167ff98 100644 --- a/middle_end/flambda2/simplify/simplify_apply_expr.ml +++ b/middle_end/flambda2/simplify/simplify_apply_expr.ml @@ -124,6 +124,9 @@ let simplify_direct_tuple_application ~simplify_expr dacc apply let vars_and_fields = List.init tuple_size (fun field -> ( Variable.create "tuple_field", + Flambda_debug_uid.none, + (* This internally created varibale does not get a + [Flambda_debug_uid.t]. *) Simplify_common.project_tuple ~dbg ~size:tuple_size ~field tuple_arg )) in (* Construct the arities for the tuple and any over application arguments *) @@ -142,7 +145,7 @@ let simplify_direct_tuple_application ~simplify_expr dacc apply (* Change the application to operate on the fields of the tuple *) let apply = Apply.with_args apply - (List.map (fun (v, _) -> Simple.var v) vars_and_fields + (List.map (fun (v, _, _) -> Simple.var v) vars_and_fields @ over_application_args) ~args_arity in @@ -163,11 +166,8 @@ let simplify_direct_tuple_application ~simplify_expr dacc apply optimizations *) let expr = List.fold_right - (fun (v, defining_expr) body -> - let var_bind = - Bound_var.create v Flambda_uid.internal_not_actually_unique - Name_mode.normal - in + (fun (v, v_duid, defining_expr) body -> + let var_bind = Bound_var.create v v_duid Name_mode.normal in Let.create (Bound_pattern.singleton var_bind) defining_expr ~body ~free_names_of_body:Unknown @@ -426,6 +426,7 @@ let simplify_direct_partial_application ~simplify_expr dacc apply (Flambda_arity.unarize param_arity) in let wrapper_var = Variable.create "partial_app" in + let wrapper_var_duid = Flambda_debug_uid.none in let compilation_unit = Compilation_unit.get_current_exn () in let wrapper_function_slot = Function_slot.create compilation_unit ~name:"partial_app_closure" @@ -482,8 +483,8 @@ let simplify_direct_partial_application ~simplify_expr dacc apply List.map (fun kind -> let param = Variable.create "param" in - Bound_parameter.create param kind - Flambda_uid.internal_not_actually_unique (* CR sspies: fix *)) + let param_duid = Flambda_debug_uid.none in + Bound_parameter.create param kind param_duid) (Flambda_arity.unarize remaining_param_arity) |> Bound_parameters.create in @@ -610,8 +611,11 @@ let simplify_direct_partial_application ~simplify_expr dacc apply | Const _ | Symbol _ -> expr, cost_metrics, free_names | In_closure { var; value_slot; value = _ } -> let arg = - VB.create var Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) Name_mode.normal + VB.create var Flambda_debug_uid.none + (* CR sspies: I'm unsure whether these are user visible + variables. At least at one call site, this is an + internally defined variable. *) + Name_mode.normal in let prim = P.Unary @@ -722,8 +726,7 @@ let simplify_direct_partial_application ~simplify_expr dacc apply in let expr = let wrapper_var = - VB.create wrapper_var Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) Name_mode.normal + VB.create wrapper_var wrapper_var_duid Name_mode.normal in let bound_vars = [wrapper_var] in let bound = Bound_pattern.set_of_closures bound_vars in diff --git a/middle_end/flambda2/simplify/simplify_common.ml b/middle_end/flambda2/simplify/simplify_common.ml index b8eaa333839..7228bdff16c 100644 --- a/middle_end/flambda2/simplify/simplify_common.ml +++ b/middle_end/flambda2/simplify/simplify_common.ml @@ -122,6 +122,7 @@ let split_direct_over_application apply (Flambda_arity.cardinal_unarized remaining_arity) = 0); let func_var = Variable.create "full_apply" in + let func_var_duid = Flambda_debug_uid.none in let result_mode = Code_metadata.result_mode callee's_code_metadata in let outer_apply_alloc_mode = apply_alloc_mode in let needs_region, inner_apply_alloc_mode = @@ -185,10 +186,9 @@ let split_direct_over_application apply let over_application_results = List.mapi (fun i kind -> - BP.create - (Variable.create ("result" ^ string_of_int i)) - kind - Flambda_uid.internal_not_actually_unique (* CR tnowak: verify *)) + let result_var = Variable.create ("result" ^ string_of_int i) in + let result_var_duid = Flambda_debug_uid.none in + BP.create result_var kind result_var_duid) (Flambda_arity.unarized_components (Apply.return_arity apply)) in let call_return_continuation, call_return_continuation_free_names = @@ -208,8 +208,8 @@ let split_direct_over_application apply let handler_expr = Let.create (Bound_pattern.singleton - (Bound_var.create (Variable.create "unit") - Flambda_uid.internal_not_actually_unique Name_mode.normal)) + (Bound_var.create (Variable.create "unit") Flambda_debug_uid.none + Name_mode.normal)) (Named.create_prim (Unary (End_region { ghost = false }, Simple.var region)) (Apply.dbg apply)) @@ -217,8 +217,7 @@ let split_direct_over_application apply (Let.create (Bound_pattern.singleton (Bound_var.create (Variable.create "unit") - Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) Name_mode.normal)) + Flambda_debug_uid.none Name_mode.normal)) (Named.create_prim (Unary (End_region { ghost = true }, Simple.var ghost_region)) (Apply.dbg apply)) @@ -257,8 +256,9 @@ let split_direct_over_application apply Bound_parameters.create (List.map (fun kind -> - Bound_parameter.create (Variable.create "over_app_result") kind - Flambda_uid.internal_not_actually_unique) + Bound_parameter.create + (Variable.create "over_app_result") + kind Flambda_debug_uid.none) (Flambda_arity.unarized_components full_apply_result_arity)) in Continuation_handler.create params @@ -266,7 +266,9 @@ let split_direct_over_application apply ~free_names_of_handler:(Known Name_occurrences.empty) ~is_exn_handler:false ~is_cold:true else - let func_param = BP.create func_var K.With_subkind.any_value Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *) in + let func_param = + BP.create func_var K.With_subkind.any_value func_var_duid + in Continuation_handler.create (Bound_parameters.create [func_param]) ~handler:perform_over_application @@ -298,19 +300,18 @@ let split_direct_over_application apply let free_names_of_body = NO.union (Apply.free_names full_apply) perform_over_application_free_names in + let region_duid = Flambda_debug_uid.none in + let ghost_region_duid = Flambda_debug_uid.none in Let.create (Bound_pattern.singleton - (Bound_var.create region Flambda_uid.internal_not_actually_unique - (* CR tnowak: verify *) Name_mode.normal)) + (Bound_var.create region region_duid Name_mode.normal)) (Named.create_prim (Variadic (Begin_region { ghost = false }, [])) (Apply.dbg apply)) ~body: (Let.create (Bound_pattern.singleton - (Bound_var.create ghost_region - Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) Name_mode.normal)) + (Bound_var.create ghost_region ghost_region_duid Name_mode.normal)) (Named.create_prim (Variadic (Begin_region { ghost = false }, [])) (Apply.dbg apply)) diff --git a/middle_end/flambda2/simplify/simplify_extcall.ml b/middle_end/flambda2/simplify/simplify_extcall.ml index 5b9bbac4b0d..a65f65d2b4f 100644 --- a/middle_end/flambda2/simplify/simplify_extcall.ml +++ b/middle_end/flambda2/simplify/simplify_extcall.ml @@ -43,10 +43,8 @@ let apply_cont cont v ~dbg = let expr = Expr.create_apply_cont apply_cont in free_names, expr -let let_prim ~dbg v prim (free_names, body) = - let v' = - Bound_var.create v Flambda_uid.internal_not_actually_unique Name_mode.normal - in +let let_prim ~dbg v v_duid prim (free_names, body) = + let v' = Bound_var.create v v_duid Name_mode.normal in let bindable = Bound_pattern.singleton v' in let named = Named.create_prim prim dbg in let free_names_of_body = Or_unknown.Known free_names in @@ -60,26 +58,34 @@ let let_prim ~dbg v prim (free_names, body) = let simplify_comparison_of_tagged_immediates ~dbg dacc ~cmp_prim cont a b = let v_comp = Variable.create "comp" in + let v_comp_duid = Flambda_debug_uid.none in let tagged = Variable.create "tagged" in + let tagged_duid = Flambda_debug_uid.none in let _free_names, res = - let_prim ~dbg v_comp (P.Binary (cmp_prim, a, b)) - @@ let_prim ~dbg tagged (P.Unary (Tag_immediate, Simple.var v_comp)) + let_prim ~dbg v_comp v_comp_duid (P.Binary (cmp_prim, a, b)) + @@ let_prim ~dbg tagged tagged_duid + (P.Unary (Tag_immediate, Simple.var v_comp)) @@ apply_cont ~dbg cont tagged in Specialised (dacc, res, RO.specialized_poly_compare) let simplify_comparison_of_boxed_numbers ~dbg dacc ~kind ~cmp_prim cont a b = let a_naked = Variable.create "unboxed" in + let a_naked_duid = Flambda_debug_uid.none in let b_naked = Variable.create "unboxed" in + let b_naked_duid = Flambda_debug_uid.none in let v_comp = Variable.create "comp" in + let v_comp_duid = Flambda_debug_uid.none in let tagged = Variable.create "tagged" in + let tagged_duid = Flambda_debug_uid.none in let _free_names, res = (* XXX try to remove @@ *) - let_prim ~dbg a_naked (P.Unary (Unbox_number kind, a)) - @@ let_prim ~dbg b_naked (P.Unary (Unbox_number kind, b)) - @@ let_prim ~dbg v_comp + let_prim ~dbg a_naked a_naked_duid (P.Unary (Unbox_number kind, a)) + @@ let_prim ~dbg b_naked b_naked_duid (P.Unary (Unbox_number kind, b)) + @@ let_prim ~dbg v_comp v_comp_duid (P.Binary (cmp_prim, Simple.var a_naked, Simple.var b_naked)) - @@ let_prim ~dbg tagged (P.Unary (Tag_immediate, Simple.var v_comp)) + @@ let_prim ~dbg tagged tagged_duid + (P.Unary (Tag_immediate, Simple.var v_comp)) @@ apply_cont ~dbg cont tagged in Specialised (dacc, res, RO.specialized_poly_compare) diff --git a/middle_end/flambda2/simplify/simplify_let_cont_expr.ml b/middle_end/flambda2/simplify/simplify_let_cont_expr.ml index 306a6a110f5..63f022c6599 100644 --- a/middle_end/flambda2/simplify/simplify_let_cont_expr.ml +++ b/middle_end/flambda2/simplify/simplify_let_cont_expr.ml @@ -305,13 +305,15 @@ let extra_params_for_continuation_param_aliases cont uacc rewrite_ids = (fun _id -> EPA.Extra_arg.Already_in_scope (Simple.var var)) rewrite_ids in + let var_duid = Flambda_debug_uid.none in + (* CR sspies: [extra_params] sounds generated and not user visible. If + this is wrong, we should bother to propagate the right + [Flambda_debug_uid.t] values here. *) let var_kind = Flambda_kind.With_subkind.anything (Variable.Map.find var aliases_kind) in EPA.add - ~extra_param: - (Bound_parameter.create var var_kind - Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *)) + ~extra_param:(Bound_parameter.create var var_kind var_duid) ~extra_args epa ~invalids:Apply_cont_rewrite_id.Set.empty) required_extra_args.extra_args_for_aliases EPA.empty @@ -557,11 +559,13 @@ let add_lets_around_handler cont at_unit_toplevel uacc handler = let handler, uacc = Variable.Map.fold (fun var bound_to (handler, uacc) -> + let var_duid = Flambda_debug_uid.none in + (* CR sspies: This seems very generic. Are these ever user visible? If + so, we should propagate their [Flambda_debug_uid.t] values to this + point. *) let bound_pattern = - (* CR tnowak: verify *) Bound_pattern.singleton - (Bound_var.create var Flambda_uid.internal_not_actually_unique - Name_mode.normal) + (Bound_var.create var var_duid Name_mode.normal) in let named = Named.create_simple bound_to in let handler, uacc = diff --git a/middle_end/flambda2/simplify/simplify_set_of_closures.ml b/middle_end/flambda2/simplify/simplify_set_of_closures.ml index 33351b5d8ef..d145106c190 100644 --- a/middle_end/flambda2/simplify/simplify_set_of_closures.ml +++ b/middle_end/flambda2/simplify/simplify_set_of_closures.ml @@ -40,14 +40,14 @@ let dacc_inside_function context ~outer_dacc ~params ~my_closure ~my_region |> DE.set_inlining_history_tracker (Inlining_history.Tracker.inside_function absolute_history) in + let my_closure_duid = Flambda_debug_uid.none in let denv = match function_slot_opt with | None -> (* This happens in the stub case, where we are only simplifying code, not a set of closures. *) DE.add_variable denv - (Bound_var.create my_closure Flambda_uid.internal_not_actually_unique - NM.normal) + (Bound_var.create my_closure my_closure_duid NM.normal) (T.unknown K.value) | Some function_slot -> ( match @@ -63,17 +63,16 @@ let dacc_inside_function context ~outer_dacc ~params ~my_closure ~my_region | name -> let name = Bound_name.name name in DE.add_variable denv - (Bound_var.create my_closure Flambda_uid.internal_not_actually_unique - NM.normal) + (Bound_var.create my_closure my_closure_duid NM.normal) (T.alias_type_of K.value (Simple.name name))) in let denv = match my_region with | None -> denv | Some my_region -> + let my_region_duid = Flambda_debug_uid.none in let my_region = - Bound_var.create my_region Flambda_uid.internal_not_actually_unique - Name_mode.normal + Bound_var.create my_region my_region_duid Name_mode.normal in DE.add_variable denv my_region (T.unknown K.region) in @@ -81,17 +80,15 @@ let dacc_inside_function context ~outer_dacc ~params ~my_closure ~my_region match my_ghost_region with | None -> denv | Some my_ghost_region -> + let my_ghost_region_duid = Flambda_debug_uid.none in let my_ghost_region = - Bound_var.create my_ghost_region - Flambda_uid.internal_not_actually_unique Name_mode.normal + Bound_var.create my_ghost_region my_ghost_region_duid Name_mode.normal in DE.add_variable denv my_ghost_region (T.unknown K.region) in + let my_depth_duid = Flambda_debug_uid.none in let denv = - let my_depth = - Bound_var.create my_depth Flambda_uid.internal_not_actually_unique - Name_mode.normal - in + let my_depth = Bound_var.create my_depth my_depth_duid Name_mode.normal in DE.add_variable denv my_depth (T.unknown K.rec_info) in let denv = @@ -196,26 +193,30 @@ let simplify_function_body context ~outer_dacc function_slot_opt Misc.fatal_errorf "Did not expect lifted constants in [dacc]:@ %a" DA.print dacc; assert (not (DE.at_unit_toplevel (DA.denv dacc))); + let my_region_duid = Flambda_debug_uid.none in + let my_ghost_region_duid = Flambda_debug_uid.none in let region_params = - let region_param region = + let region_param region region_debug_duid = match region with | None -> [] | Some region -> [ Bound_parameter.create region Flambda_kind.With_subkind.region - Flambda_uid.internal_not_actually_unique (* CR sspies: fix *) ] + region_debug_duid ] in - region_param my_region @ region_param my_ghost_region + region_param my_region my_region_duid + @ region_param my_ghost_region my_ghost_region_duid in + let my_closure_duid = Flambda_debug_uid.none in + let my_depth_duid = Flambda_debug_uid.none in match C.simplify_function_body context dacc body ~return_continuation ~exn_continuation ~return_arity:(Code.result_arity code) ~implicit_params: (Bound_parameters.create ([ Bound_parameter.create my_closure - Flambda_kind.With_subkind.any_value - Flambda_uid.internal_not_actually_unique; + Flambda_kind.With_subkind.any_value my_closure_duid; Bound_parameter.create my_depth Flambda_kind.With_subkind.rec_info - Flambda_uid.internal_not_actually_unique ] + my_depth_duid ] @ region_params)) ~loopify_state ~params with @@ -387,10 +388,9 @@ let simplify_function0 context ~outer_dacc function_slot_opt code_id code let return_cont_params = List.mapi (fun i kind_with_subkind -> - BP.create - (Variable.create ("result" ^ string_of_int i)) - kind_with_subkind - Flambda_uid.internal_not_actually_unique (* CR tnowak: verify *)) + let result_var = Variable.create ("result" ^ string_of_int i) in + let result_var_duid = Flambda_debug_uid.none in + BP.create result_var kind_with_subkind result_var_duid) (Flambda_arity.unarized_components result_arity) |> Bound_parameters.create in diff --git a/middle_end/flambda2/simplify/simplify_switch_expr.ml b/middle_end/flambda2/simplify/simplify_switch_expr.ml index cfba5336945..370433f87f4 100644 --- a/middle_end/flambda2/simplify/simplify_switch_expr.ml +++ b/middle_end/flambda2/simplify/simplify_switch_expr.ml @@ -328,13 +328,15 @@ let rebuild_switch_with_single_arg_to_same_destination uacc ~dacc_before_switch in let load_from_block = Named.create_prim load_from_block_prim dbg in let arg_var = Variable.create "arg" in + let arg_var_duid = Flambda_debug_uid.none in let arg = Simple.var arg_var in - let final_arg_var, final_arg = + let final_arg_var, final_arg_var_duid, final_arg = match must_untag_lookup_table_result with | Must_untag -> let final_arg_var = Variable.create "final_arg" in - final_arg_var, Simple.var final_arg_var - | Leave_as_tagged_immediate -> arg_var, arg + let final_arg_var_duid = Flambda_debug_uid.none in + final_arg_var, final_arg_var_duid, Simple.var final_arg_var + | Leave_as_tagged_immediate -> arg_var, arg_var_duid, arg in (* Note that, unlike for the untagging of normal Switch scrutinees, there's no problem with CSE and Data_flow here. The reason is that in this case the @@ -354,17 +356,12 @@ let rebuild_switch_with_single_arg_to_same_destination uacc ~dacc_before_switch | Leave_as_tagged_immediate -> body | Must_untag -> let bound = - BPt.singleton - (BV.create final_arg_var Flambda_uid.internal_not_actually_unique - NM.normal) + BPt.singleton (BV.create final_arg_var final_arg_var_duid NM.normal) in let untag_arg = Named.create_prim untag_arg_prim dbg in RE.create_let rebuilding bound untag_arg ~body ~free_names_of_body in - let bound = - BPt.singleton - (BV.create arg_var Flambda_uid.internal_not_actually_unique NM.normal) - in + let bound = BPt.singleton (BV.create arg_var arg_var_duid NM.normal) in RE.create_let rebuilding bound load_from_block ~body ~free_names_of_body in let extra_free_names = @@ -518,6 +515,7 @@ let rebuild_switch ~original ~arms ~condition_dbg ~scrutinee ~scrutinee_ty UA.notify_removed ~operation:Removed_operations.branch uacc in let not_scrutinee = Variable.create "not_scrutinee" in + let not_scrutinee_duid = Flambda_debug_uid.none in let not_scrutinee' = Simple.var not_scrutinee in let tagging_prim : P.t = Unary (Tag_immediate, scrutinee) in match @@ -533,8 +531,7 @@ let rebuild_switch ~original ~arms ~condition_dbg ~scrutinee ~scrutinee_ty Debuginfo.none in let bound = - VB.create not_scrutinee Flambda_uid.internal_not_actually_unique - NM.normal + VB.create not_scrutinee not_scrutinee_duid NM.normal |> Bound_pattern.singleton in let apply_cont = @@ -707,6 +704,7 @@ let simplify_switch0 dacc switch ~down_to_up = let simplify_switch ~simplify_let_with_bound_pattern ~simplify_function_body dacc switch ~down_to_up = let tagged_scrutinee = Variable.create "tagged_scrutinee" in + let tagged_scrutinee_duid = Flambda_debug_uid.none in let tagging_prim = Named.create_prim (Unary (Tag_immediate, Switch.scrutinee switch)) @@ -716,8 +714,7 @@ let simplify_switch ~simplify_let_with_bound_pattern ~simplify_function_body (* [body] won't be looked at (see below). *) Let.create (Bound_pattern.singleton - (Bound_var.create tagged_scrutinee - Flambda_uid.internal_not_actually_unique NM.normal)) + (Bound_var.create tagged_scrutinee tagged_scrutinee_duid NM.normal)) tagging_prim ~body:(Expr.create_switch switch) ~free_names_of_body:Unknown diff --git a/middle_end/flambda2/simplify/simplify_unary_primitive.ml b/middle_end/flambda2/simplify/simplify_unary_primitive.ml index dd6755ae25c..98cf103cf43 100644 --- a/middle_end/flambda2/simplify/simplify_unary_primitive.ml +++ b/middle_end/flambda2/simplify/simplify_unary_primitive.ml @@ -724,14 +724,14 @@ let simplify_obj_dup dbg dacc ~original_term ~arg ~arg_ty ~result_var = earlier in the event that it already exists later, but this is probably fine: this operation isn't that common. *) let contents_var = Variable.create "obj_dup_contents" in + let contents_var_duid = Flambda_debug_uid.none in let contents_expr = Named.create_prim (Unary (Unbox_number boxable_number, arg)) dbg in let bind_contents = { Expr_builder.let_bound = Bound_pattern.singleton - (Bound_var.create contents_var - Flambda_uid.internal_not_actually_unique NM.normal); + (Bound_var.create contents_var contents_var_duid NM.normal); simplified_defining_expr = Simplified_named.create contents_expr; original_defining_expr = None } @@ -739,8 +739,7 @@ let simplify_obj_dup dbg dacc ~original_term ~arg ~arg_ty ~result_var = let contents_simple = Simple.var contents_var in let dacc = DA.add_variable dacc - (Bound_var.create contents_var - Flambda_uid.internal_not_actually_unique NM.normal) + (Bound_var.create contents_var contents_var_duid NM.normal) contents_ty in ( [bind_contents], diff --git a/middle_end/flambda2/simplify/unboxing/build_unboxing_denv.ml b/middle_end/flambda2/simplify/unboxing/build_unboxing_denv.ml index e88f0d7f729..f9f61cc6cc3 100644 --- a/middle_end/flambda2/simplify/unboxing/build_unboxing_denv.ml +++ b/middle_end/flambda2/simplify/unboxing/build_unboxing_denv.ml @@ -25,8 +25,9 @@ let add_equation_on_var denv var shape = | Bottom -> Misc.fatal_errorf "Meet failed whereas prove and meet previously succeeded" -let denv_of_number_decision naked_kind shape param_var naked_var denv : DE.t = - let naked_name = VB.create naked_var Flambda_uid.internal_not_actually_unique Name_mode.normal in +let denv_of_number_decision naked_kind shape param_var param_var_debug_uid + naked_var denv : DE.t = + let naked_name = VB.create naked_var param_var_debug_uid Name_mode.normal in let denv = DE.define_extra_variable denv naked_name naked_kind in add_equation_on_var denv param_var shape @@ -36,9 +37,10 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = | Unbox (Unique_tag_and_size { tag; shape; fields }) -> let denv = Misc.Stdlib.List.fold_lefti - (fun index denv ({ epa = { param = var; _ }; _ } : U.field_decision) -> - let v = VB.create var Flambda_uid.internal_not_actually_unique Name_mode.normal in - (* CR tnowak: verify *) + (fun index denv + ({ epa = { param = var; param_debug_uid; _ }; _ } : + U.field_decision) -> + let v = VB.create var param_debug_uid Name_mode.normal in DE.define_extra_variable denv v (K.Block_shape.element_kind shape index)) denv fields @@ -61,9 +63,10 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = | Unbox (Closure_single_entry { function_slot; vars_within_closure }) -> let denv = Value_slot.Map.fold - (fun _ ({ epa = { param = var; _ }; kind; _ } : U.field_decision) denv -> - let v = VB.create var Flambda_uid.internal_not_actually_unique Name_mode.normal in - (* CR tnowak: verify *) + (fun _ + ({ epa = { param = var; param_debug_uid; _ }; kind; _ } : + U.field_decision) denv -> + let v = VB.create var param_debug_uid Name_mode.normal in DE.define_extra_variable denv v (K.With_subkind.kind kind)) vars_within_closure denv in @@ -84,8 +87,7 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = vars_within_closure denv | Unbox (Variant { tag; const_ctors; fields_by_tag }) -> (* Adapt the denv for the tag *) - let tag_v = VB.create tag.param Flambda_uid.internal_not_actually_unique Name_mode.normal in - (* CR tnowak: verify *) + let tag_v = VB.create tag.param tag.param_debug_uid Name_mode.normal in let denv = DE.define_extra_variable denv tag_v K.naked_immediate in let denv = DE.map_typing_env denv ~f:(fun tenv -> @@ -101,8 +103,9 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = match const_ctors with | Zero -> denv | At_least_one { is_int; _ } -> - let is_int_v = VB.create is_int.param Flambda_uid.internal_not_actually_unique Name_mode.normal in - (* CR tnowak: verify *) + let is_int_v = + VB.create is_int.param is_int.param_debug_uid Name_mode.normal + in let denv = DE.define_extra_variable denv is_int_v K.naked_immediate in let denv = DE.map_typing_env denv ~f:(fun tenv -> @@ -124,8 +127,9 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = | At_least_one { ctor = Do_not_unbox _; _ } -> denv, T.unknown K.naked_immediate | At_least_one { ctor = Unbox (Number (Naked_immediate, ctor_epa)); _ } -> - let v = VB.create ctor_epa.param Flambda_uid.internal_not_actually_unique Name_mode.normal in - (* CR tnowak: verify *) + let v = + VB.create ctor_epa.param ctor_epa.param_debug_uid Name_mode.normal + in let denv = DE.define_extra_variable denv v K.naked_immediate in let ty = T.alias_type_of K.naked_immediate (Simple.var ctor_epa.param) @@ -150,8 +154,10 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = Tag.Scannable.Map.fold (fun _ (shape, block_fields) denv -> Misc.Stdlib.List.fold_lefti - (fun index denv ({ epa = { param = var; _ }; _ } : U.field_decision) -> - let v = VB.create var Flambda_uid.internal_not_actually_unique Name_mode.normal in + (fun index denv + ({ epa = { param = var; param_debug_uid; _ }; _ } : + U.field_decision) -> + let v = VB.create var param_debug_uid Name_mode.normal in DE.define_extra_variable denv v (K.Block_shape.element_kind shape index)) denv block_fields) @@ -181,49 +187,77 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = denv_of_decision denv ~param_var:field.epa.param field.decision) denv block_fields) fields_by_tag denv - | Unbox (Number (Naked_immediate, { param = naked_immediate; args = _ })) -> + | Unbox + (Number + (Naked_immediate, { param = naked_immediate; param_debug_uid; args = _ })) + -> let shape = T.tagged_immediate_alias_to ~naked_immediate in - denv_of_number_decision K.naked_immediate shape param_var naked_immediate - denv - | Unbox (Number (Naked_float32, { param = naked_float32; args = _ })) -> + denv_of_number_decision K.naked_immediate shape param_var param_debug_uid + naked_immediate denv + | Unbox + (Number + (Naked_float32, { param = naked_float32; param_debug_uid; args = _ })) + -> let shape = T.boxed_float32_alias_to ~naked_float32 (Alloc_mode.For_types.unknown ()) in - denv_of_number_decision K.naked_float32 shape param_var naked_float32 denv - | Unbox (Number (Naked_float, { param = naked_float; args = _ })) -> + denv_of_number_decision K.naked_float32 shape param_var param_debug_uid + naked_float32 denv + | Unbox + (Number (Naked_float, { param = naked_float; param_debug_uid; args = _ })) + -> let shape = T.boxed_float_alias_to ~naked_float (Alloc_mode.For_types.unknown ()) in - denv_of_number_decision K.naked_float shape param_var naked_float denv - | Unbox (Number (Naked_int32, { param = naked_int32; args = _ })) -> + denv_of_number_decision K.naked_float shape param_var param_debug_uid + naked_float denv + | Unbox + (Number (Naked_int32, { param = naked_int32; param_debug_uid; args = _ })) + -> let shape = T.boxed_int32_alias_to ~naked_int32 (Alloc_mode.For_types.unknown ()) in - denv_of_number_decision K.naked_int32 shape param_var naked_int32 denv - | Unbox (Number (Naked_int64, { param = naked_int64; args = _ })) -> + denv_of_number_decision K.naked_int32 shape param_var param_debug_uid + naked_int32 denv + | Unbox + (Number (Naked_int64, { param = naked_int64; param_debug_uid; args = _ })) + -> let shape = T.boxed_int64_alias_to ~naked_int64 (Alloc_mode.For_types.unknown ()) in - denv_of_number_decision K.naked_int64 shape param_var naked_int64 denv - | Unbox (Number (Naked_nativeint, { param = naked_nativeint; args = _ })) -> + denv_of_number_decision K.naked_int64 shape param_var param_debug_uid + naked_int64 denv + | Unbox + (Number + (Naked_nativeint, { param = naked_nativeint; param_debug_uid; args = _ })) + -> let shape = T.boxed_nativeint_alias_to ~naked_nativeint (Alloc_mode.For_types.unknown ()) in - denv_of_number_decision K.naked_nativeint shape param_var naked_nativeint - denv - | Unbox (Number (Naked_vec128, { param = naked_vec128; args = _ })) -> + denv_of_number_decision K.naked_nativeint shape param_var param_debug_uid + naked_nativeint denv + | Unbox + (Number + (Naked_vec128, { param = naked_vec128; param_debug_uid; args = _ })) -> let shape = T.boxed_vec128_alias_to ~naked_vec128 (Alloc_mode.For_types.unknown ()) in - denv_of_number_decision K.naked_vec128 shape param_var naked_vec128 denv - | Unbox (Number (Naked_vec256, { param = naked_vec256; args = _ })) -> + denv_of_number_decision K.naked_vec128 shape param_var param_debug_uid + naked_vec128 denv + | Unbox + (Number + (Naked_vec256, { param = naked_vec256; param_debug_uid; args = _ })) -> let shape = T.boxed_vec256_alias_to ~naked_vec256 (Alloc_mode.For_types.unknown ()) in - denv_of_number_decision K.naked_vec256 shape param_var naked_vec256 denv - | Unbox (Number (Naked_vec512, { param = naked_vec512; args = _ })) -> + denv_of_number_decision K.naked_vec256 shape param_var param_debug_uid + naked_vec256 denv + | Unbox + (Number + (Naked_vec512, { param = naked_vec512; param_debug_uid; args = _ })) -> let shape = T.boxed_vec512_alias_to ~naked_vec512 (Alloc_mode.For_types.unknown ()) in - denv_of_number_decision K.naked_vec512 shape param_var naked_vec512 denv + denv_of_number_decision K.naked_vec512 shape param_var param_debug_uid + naked_vec512 denv diff --git a/middle_end/flambda2/simplify/unboxing/optimistic_unboxing_decision.ml b/middle_end/flambda2/simplify/unboxing/optimistic_unboxing_decision.ml index 2e596ef76fa..a9b31371064 100644 --- a/middle_end/flambda2/simplify/unboxing/optimistic_unboxing_decision.ml +++ b/middle_end/flambda2/simplify/unboxing/optimistic_unboxing_decision.ml @@ -31,9 +31,12 @@ let unbox_variants = true let unbox_closures = true let make_optimistic_const_ctor () : U.const_ctors_decision = - let is_int = Extra_param_and_args.create ~name:"is_int" in + let is_int = + Extra_param_and_args.create ~name:"is_int" ~debug_uid:Flambda_debug_uid.none + in let unboxed_const_ctor = Extra_param_and_args.create ~name:"unboxed_const_ctor" + ~debug_uid:Flambda_debug_uid.none in let ctor = U.Unbox (Number (Naked_immediate, unboxed_const_ctor)) in At_least_one { is_int; ctor } @@ -42,7 +45,10 @@ let make_optimistic_number_decision tenv param_type (decider : Unboxers.number_decider) : U.decision option = match decider.prove_is_a_boxed_number tenv param_type with | Proved () -> - let naked_number = Extra_param_and_args.create ~name:decider.param_name in + let naked_number = + Extra_param_and_args.create ~name:decider.param_name + ~debug_uid:Flambda_debug_uid.none + in Some (Unbox (Number (decider.kind, naked_number))) | Unknown -> None @@ -99,7 +105,10 @@ let rec make_optimistic_decision ~depth ~recursive tenv ~param_type : U.decision match T.prove_variant_like tenv param_type with | Proved { const_ctors; non_const_ctors_with_sizes } when unbox_variants && not recursive -> ( - let tag = Extra_param_and_args.create ~name:"tag" in + let tag = + Extra_param_and_args.create ~name:"tag" + ~debug_uid:Flambda_debug_uid.none + in let const_ctors : U.const_ctors_decision = match const_ctors with | Known set when Targetint_31_63.Set.is_empty set -> Zero @@ -153,7 +162,8 @@ and make_optimistic_fields ~add_tag_to_name ~depth ~recursive tenv param_type in let field_vars = List.init (Targetint_31_63.to_int size) (fun i -> - Extra_param_and_args.create ~name:(field_name i)) + Extra_param_and_args.create ~name:(field_name i) + ~debug_uid:Flambda_debug_uid.none) in let type_of_var index (epa : Extra_param_and_args.t) = T.alias_type_of @@ -163,7 +173,8 @@ and make_optimistic_fields ~add_tag_to_name ~depth ~recursive tenv param_type let field_types = List.mapi type_of_var field_vars in let tenv = Misc.Stdlib.List.fold_lefti - (fun index acc { Extra_param_and_args.param = var; args = _ } -> + (fun index acc + { Extra_param_and_args.param = var; param_debug_uid = _; args = _ } -> let name = Bound_name.create (Name.var var) Name_mode.normal in TE.add_definition acc name (K.Block_shape.element_kind shape index)) tenv field_vars @@ -197,7 +208,9 @@ and make_optimistic_vars_within_closure ~depth ~recursive tenv closures_entry = Value_slot.Map.mapi (fun value_slot var_type : U.field_decision -> let epa = - Extra_param_and_args.create ~name:(Value_slot.to_string value_slot) + Extra_param_and_args.create + ~name:(Value_slot.to_string value_slot) + ~debug_uid:Flambda_debug_uid.none in let decision = make_optimistic_decision ~depth:(depth + 1) ~recursive tenv diff --git a/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml b/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml index 0010d772898..a38ac2e87f5 100644 --- a/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml +++ b/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml @@ -427,10 +427,7 @@ let add_extra_params_and_args extra_params_and_args ~invalids decision = | Unbox (Unique_tag_and_size { tag = _; shape = _; fields }) -> List.fold_left (fun extra_params_and_args ({ epa; decision; kind } : U.field_decision) -> - let extra_param = - BP.create epa.param kind - Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *) - in + let extra_param = BP.create epa.param kind epa.param_debug_uid in let extra_params_and_args = EPA.add extra_params_and_args ~invalids ~extra_param ~extra_args:epa.args @@ -441,10 +438,7 @@ let add_extra_params_and_args extra_params_and_args ~invalids decision = Value_slot.Map.fold (fun _ ({ epa; decision; kind } : U.field_decision) extra_params_and_args -> - let extra_param = - BP.create epa.param kind - Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *) - in + let extra_param = BP.create epa.param kind epa.param_debug_uid in let extra_params_and_args = EPA.add extra_params_and_args ~invalids ~extra_param ~extra_args:epa.args @@ -459,9 +453,7 @@ let add_extra_params_and_args extra_params_and_args ~invalids decision = (fun extra_params_and_args ({ epa; decision; kind } : U.field_decision) -> let extra_param = - BP.create epa.param kind - Flambda_uid.internal_not_actually_unique - (* CR tnowak: maybe? *) + BP.create epa.param kind epa.param_debug_uid in let extra_params_and_args = EPA.add extra_params_and_args ~invalids ~extra_param @@ -477,7 +469,7 @@ let add_extra_params_and_args extra_params_and_args ~invalids decision = | At_least_one { is_int; ctor = Do_not_unbox _; _ } -> let extra_param = BP.create is_int.param K.With_subkind.naked_immediate - Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *) + is_int.param_debug_uid in EPA.add extra_params_and_args ~invalids ~extra_param ~extra_args:is_int.args @@ -485,7 +477,7 @@ let add_extra_params_and_args extra_params_and_args ~invalids decision = -> let extra_param = BP.create is_int.param K.With_subkind.naked_immediate - Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *) + is_int.param_debug_uid in let extra_params_and_args = EPA.add extra_params_and_args ~invalids ~extra_param @@ -493,7 +485,7 @@ let add_extra_params_and_args extra_params_and_args ~invalids decision = in let extra_param = BP.create ctor.param K.With_subkind.naked_immediate - Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *) + ctor.param_debug_uid in EPA.add extra_params_and_args ~invalids ~extra_param ~extra_args:ctor.args @@ -513,8 +505,7 @@ let add_extra_params_and_args extra_params_and_args ~invalids decision = other than Naked_immediate." in let extra_param = - BP.create tag.param K.With_subkind.naked_immediate - Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *) + BP.create tag.param K.With_subkind.naked_immediate tag.param_debug_uid in EPA.add extra_params_and_args ~invalids ~extra_param ~extra_args:tag.args | Unbox (Number (naked_number_kind, epa)) -> @@ -522,8 +513,7 @@ let add_extra_params_and_args extra_params_and_args ~invalids decision = K.With_subkind.of_naked_number_kind naked_number_kind in let extra_param = - BP.create epa.param kind_with_subkind - Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *) + BP.create epa.param kind_with_subkind epa.param_debug_uid in EPA.add extra_params_and_args ~invalids ~extra_param ~extra_args:epa.args in diff --git a/middle_end/flambda2/simplify/unboxing/unboxing_types.ml b/middle_end/flambda2/simplify/unboxing/unboxing_types.ml index e46bb120592..0e65d4864fc 100644 --- a/middle_end/flambda2/simplify/unboxing/unboxing_types.ml +++ b/middle_end/flambda2/simplify/unboxing/unboxing_types.ml @@ -31,18 +31,22 @@ type do_not_unbox_reason = module Extra_param_and_args = struct type t = { param : Variable.t; + param_debug_uid : Flambda_debug_uid.t; args : EPA.Extra_arg.t Apply_cont_rewrite_id.Map.t } - let create ~name = - { param = Variable.create name; args = Apply_cont_rewrite_id.Map.empty } + let create ~name ~debug_uid = + { param = Variable.create name; + param_debug_uid = debug_uid; + args = Apply_cont_rewrite_id.Map.empty + } let update_param_args t rewrite_id extra_arg = assert (not (Apply_cont_rewrite_id.Map.mem rewrite_id t.args)); let args = Apply_cont_rewrite_id.Map.add rewrite_id extra_arg t.args in { t with args } - let [@ocamlformat "disable"] print fmt { param; args = _; } = + let [@ocamlformat "disable"] print fmt { param; param_debug_uid = _; args = _; } = Format.fprintf fmt "@[(\ @[(param %a)@]@ \ @[(args@ <...>)@]\ diff --git a/middle_end/flambda2/simplify/unboxing/unboxing_types.mli b/middle_end/flambda2/simplify/unboxing/unboxing_types.mli index 23d1678dcbd..f1d25e8fd76 100644 --- a/middle_end/flambda2/simplify/unboxing/unboxing_types.mli +++ b/middle_end/flambda2/simplify/unboxing/unboxing_types.mli @@ -31,10 +31,14 @@ type do_not_unbox_reason = module Extra_param_and_args : sig type t = private { param : Variable.t; + param_debug_uid : Flambda_debug_uid.t; + (* CR sspies: This is [Flambda_debug_uid.none] at all the creation points + that I found. I still added the field, because that is non-obvious at + the usage points of the these extra params. *) args : EPA.Extra_arg.t Apply_cont_rewrite_id.Map.t } - val create : name:string -> t + val create : name:string -> debug_uid:Flambda_debug_uid.t -> t val update_param_args : t -> Apply_cont_rewrite_id.t -> EPA.Extra_arg.t -> t end diff --git a/middle_end/flambda2/simplify_shared/inlining_helpers.ml b/middle_end/flambda2/simplify_shared/inlining_helpers.ml index ef31708d858..fc728dd03af 100644 --- a/middle_end/flambda2/simplify_shared/inlining_helpers.ml +++ b/middle_end/flambda2/simplify_shared/inlining_helpers.ml @@ -90,9 +90,9 @@ let wrap_inlined_body_for_exn_extra_args acc ~extra_args ~apply_exn_continuation let kinded_params = List.map (fun k -> - Bound_parameter.create - (Variable.create "wrapper_return") - k Flambda_uid.internal_not_actually_unique (* CR tnowak: verify *)) + let wrapper_return = Variable.create "wrapper_return" in + let wrapper_return_duid = Flambda_debug_uid.none in + Bound_parameter.create wrapper_return k wrapper_return_duid) (Flambda_arity.unarized_components result_arity) in let trap_action = @@ -108,9 +108,9 @@ let wrap_inlined_body_for_exn_extra_args acc ~extra_args ~apply_exn_continuation ~handler ~body ~is_exn_handler:false ~is_cold:false in let param = Variable.create "exn" in + let param_duid = Flambda_debug_uid.none in let wrapper_handler_params = - [ Bound_parameter.create param Flambda_kind.With_subkind.any_value - Flambda_uid.internal_not_actually_unique (* CR tnowak: verify *) ] + [Bound_parameter.create param Flambda_kind.With_subkind.any_value param_duid] |> Bound_parameters.create in let exn_handler = Exn_continuation.exn_handler apply_exn_continuation in diff --git a/middle_end/flambda2/terms/flambda.ml b/middle_end/flambda2/terms/flambda.ml index 257a52ef2b9..7f89b7ec2f8 100644 --- a/middle_end/flambda2/terms/flambda.ml +++ b/middle_end/flambda2/terms/flambda.ml @@ -585,7 +585,7 @@ and print_function_params_and_body ppf t = let my_closure = Bound_parameter.create my_closure (K.With_subkind.create K.value Anything Non_nullable) - Flambda_uid.internal_not_actually_unique + Flambda_debug_uid.none in fprintf ppf "@[(%t@<1>\u{03bb}%t@[ Exported_offsets.t the new environment and the created variable. Will produce a fatal error if the given variable is already bound. *) val create_bound_parameter : - t -> Variable.t * Flambda_uid.t -> t * Backend_var.With_provenance.t + t -> Variable.t * Flambda_debug_uid.t -> t * Backend_var.With_provenance.t (** Same as {!create_variable} but for a list of variables. *) val create_bound_parameters : - t -> (Variable.t * Flambda_uid.t) list -> t * Backend_var.With_provenance.t list + t -> + (Variable.t * Flambda_debug_uid.t) list -> + t * Backend_var.With_provenance.t list (** {2 Delayed let-bindings} 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 7c2a9de677c..08d1b6f80f9 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 @@ -448,9 +448,13 @@ let params_and_body0 env res code_id ~result_arity ~fun_dbg if not is_my_closure_used then params else + let my_closure_duid = Flambda_debug_uid.none in + (* CR sspies: Not sure whethere these closures can ever be user visible. + Popagating a [Lambda_debug_uid.t] here is nontrivial, so I picked + [Flambda_debug_uid.none] for now. *) let my_closure_param = Bound_parameter.create my_closure Flambda_kind.With_subkind.any_value - Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *) + my_closure_duid in Bound_parameters.append params (Bound_parameters.create [my_closure_param]) @@ -474,10 +478,9 @@ let params_and_body0 env res code_id ~result_arity ~fun_dbg match my_region with | None -> env, None | Some my_region -> + let my_region_duid = Flambda_debug_uid.none in let env, region = - Env.create_bound_parameter env - ( my_region, - Flambda_uid.internal_not_actually_unique (* CR sspies: fix *) ) + Env.create_bound_parameter env (my_region, my_region_duid) in env, Some region in @@ -486,10 +489,9 @@ let params_and_body0 env res code_id ~result_arity ~fun_dbg match my_ghost_region with | None -> env, None | Some my_ghost_region -> + let my_ghost_region_duid = Flambda_debug_uid.none in let env, region = - Env.create_bound_parameter env - ( my_ghost_region, - Flambda_uid.internal_not_actually_unique (* CR sspies: fix *) ) + Env.create_bound_parameter env (my_ghost_region, my_ghost_region_duid) in env, Some region in @@ -735,11 +737,9 @@ let let_dynamic_set_of_closures0 env res ~body ~bound_vars set ~mode:(C.alloc_mode_for_allocations_to_cmm closure_alloc_mode) dbg ~tag l memory_chunks in - let soc_var = - Bound_var.create - (Variable.create "*set_of_closures*") - Flambda_uid.internal_not_actually_unique Name_mode.normal - in + let soc_var = Variable.create "*set_of_closures*" in + let soc_var_duid = Flambda_debug_uid.none in + let soc_var = Bound_var.create soc_var soc_var_duid Name_mode.normal in let defining_expr = Env.simple csoc free_vars in let env, res = Env.bind_variable_to_primitive env res soc_var ~inline:Env.Do_not_inline diff --git a/middle_end/flambda2/types/env/join_env.ml b/middle_end/flambda2/types/env/join_env.ml index a8e8ed0a997..0ad5ffb4a08 100644 --- a/middle_end/flambda2/types/env/join_env.ml +++ b/middle_end/flambda2/types/env/join_env.ml @@ -1193,8 +1193,11 @@ let cut_and_n_way_join ~n_way_join_type ~meet_type ~cut_after target_env (fun var kind target_env -> TE.add_definition target_env (Bound_name.create_var - (Bound_var.create var Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) Name_mode.in_types)) + (Bound_var.create var Flambda_debug_uid.none + (* Variables with [Name_mode.in_types] do not exist at + runtime, so we do not equip them with a + [Flambda_debug_uid.t]. See #3967. *) + Name_mode.in_types)) kind) extra_variables target_env in diff --git a/middle_end/flambda2/types/equal_types_for_debug.ml b/middle_end/flambda2/types/equal_types_for_debug.ml index 93537bca1b4..6d9b36cfb1f 100644 --- a/middle_end/flambda2/types/equal_types_for_debug.ml +++ b/middle_end/flambda2/types/equal_types_for_debug.ml @@ -481,8 +481,10 @@ let names_with_non_equal_types_level_ignoring_name_mode ~meet_type env level1 (fun var kind left_env -> TE.add_definition left_env (Bound_name.create_var - (Bound_var.create var - Flambda_uid.internal_not_actually_unique (* CR sspies: fix *) + (Bound_var.create var Flambda_debug_uid.none + (* Variables with [Name_mode.in_types] do not exist at runtime, + so we do not equip them with a [Flambda_debug_uid.t]. See + #3967. *) Name_mode.in_types)) kind) level1 env @@ -492,8 +494,10 @@ let names_with_non_equal_types_level_ignoring_name_mode ~meet_type env level1 (fun var kind right_env -> TE.add_definition right_env (Bound_name.create_var - (Bound_var.create var - Flambda_uid.internal_not_actually_unique (* CR sspies: fix *) + (Bound_var.create var Flambda_debug_uid.none + (* Variables with [Name_mode.in_types] do not exist at runtime, + so we do not equip them with a [Flambda_debug_uid.t]. See + #3967. *) Name_mode.in_types)) kind) level2 env diff --git a/middle_end/flambda2/types/join_levels_old.ml b/middle_end/flambda2/types/join_levels_old.ml index 7ef72821801..e29b0d0f146 100644 --- a/middle_end/flambda2/types/join_levels_old.ml +++ b/middle_end/flambda2/types/join_levels_old.ml @@ -46,9 +46,11 @@ let join_types ~env_at_fork envs_with_levels = let kind = TEL.find_kind level var in TE.add_definition base_env (Bound_name.create_var - (Bound_var.create var - Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) Name_mode.in_types)) + (Bound_var.create var Flambda_debug_uid.none + (* Variables with [Name_mode.in_types] do not exist + at runtime, so we do not equip them with a + [Flambda_debug_uid.t]. See #3967. *) + Name_mode.in_types)) kind) vars base_env) (TEL.variables_by_binding_time level) diff --git a/middle_end/flambda2/types/meet_and_n_way_join.ml b/middle_end/flambda2/types/meet_and_n_way_join.ml index 391f9923ab5..ef5b6d76f5b 100644 --- a/middle_end/flambda2/types/meet_and_n_way_join.ml +++ b/middle_end/flambda2/types/meet_and_n_way_join.ml @@ -286,8 +286,11 @@ let add_defined_vars env level = (fun var kind env -> TE.add_definition env (Bound_name.create_var - (Bound_var.create var Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) Name_mode.in_types)) + (Bound_var.create var Flambda_debug_uid.none + (* Variables with [Name_mode.in_types] do not exist at runtime, so + we do not equip them with a [Flambda_debug_uid.t]. See + #3967. *) + Name_mode.in_types)) kind) level env @@ -1260,8 +1263,11 @@ and meet_row_like : (fun var kind env -> TE.add_definition env (Bound_name.create_var - (Bound_var.create var Flambda_uid.internal_not_actually_unique - (* CR sspies: fix *) Name_mode.in_types)) + (Bound_var.create var Flambda_debug_uid.none + (* Variables with [Name_mode.in_types] do not exist at runtime, + so we do not equip them with a [Flambda_debug_uid.t]. See + #3967. *) + Name_mode.in_types)) kind) !extra_variables result_env in From 70792c928ce364a7a336bbd7509a4027e8aba91c Mon Sep 17 00:00:00 2001 From: Simon Spies Date: Tue, 1 Jul 2025 18:10:13 +0100 Subject: [PATCH 3/4] cleanup comments --- middle_end/flambda2/simplify/flow/mutable_unboxing.ml | 3 --- middle_end/flambda2/simplify/unboxing/unboxing_types.mli | 4 ++-- middle_end/flambda2/to_cmm/to_cmm.ml | 4 +--- middle_end/flambda2/to_cmm/to_cmm_set_of_closures.ml | 3 --- 4 files changed, 3 insertions(+), 11 deletions(-) diff --git a/middle_end/flambda2/simplify/flow/mutable_unboxing.ml b/middle_end/flambda2/simplify/flow/mutable_unboxing.ml index f460c41db83..2eb8b03a811 100644 --- a/middle_end/flambda2/simplify/flow/mutable_unboxing.ml +++ b/middle_end/flambda2/simplify/flow/mutable_unboxing.ml @@ -485,9 +485,6 @@ module Fold_prims = struct in let var = Variable.create (Printf.sprintf "%s_%i" name i) in let var_duid = Flambda_debug_uid.none in - (* CR sspies: While this is an internally generated variable, - would it make sense to try to propagate a - [Flambda_debug_uid.t] here? *) Bound_parameter.create var kind var_duid) fields_kinds in diff --git a/middle_end/flambda2/simplify/unboxing/unboxing_types.mli b/middle_end/flambda2/simplify/unboxing/unboxing_types.mli index f1d25e8fd76..7fe2fbbcc6c 100644 --- a/middle_end/flambda2/simplify/unboxing/unboxing_types.mli +++ b/middle_end/flambda2/simplify/unboxing/unboxing_types.mli @@ -33,8 +33,8 @@ module Extra_param_and_args : sig { param : Variable.t; param_debug_uid : Flambda_debug_uid.t; (* CR sspies: This is [Flambda_debug_uid.none] at all the creation points - that I found. I still added the field, because that is non-obvious at - the usage points of the these extra params. *) + that I found. I still added the field, because it is non-obvious that + it is always [Flambda_debug_uid.none] at the usage points. *) args : EPA.Extra_arg.t Apply_cont_rewrite_id.Map.t } diff --git a/middle_end/flambda2/to_cmm/to_cmm.ml b/middle_end/flambda2/to_cmm/to_cmm.ml index d15eadbc93a..d6c176659fa 100644 --- a/middle_end/flambda2/to_cmm/to_cmm.ml +++ b/middle_end/flambda2/to_cmm/to_cmm.ml @@ -94,9 +94,7 @@ let unit0 ~offsets ~all_code ~reachable_names flambda_unit = let env, toplevel_region_var = Env.create_bound_parameter env ( Flambda_unit.toplevel_my_region flambda_unit, - Flambda_debug_uid.none - (* CR sspies: Do we have a better [Flambda_debug_uid.t] available - here? *) ) + Flambda_debug_uid.none ) in let r = R.create ~reachable_names 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 08d1b6f80f9..ad325605cac 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 @@ -449,9 +449,6 @@ let params_and_body0 env res code_id ~result_arity ~fun_dbg then params else let my_closure_duid = Flambda_debug_uid.none in - (* CR sspies: Not sure whethere these closures can ever be user visible. - Popagating a [Lambda_debug_uid.t] here is nontrivial, so I picked - [Flambda_debug_uid.none] for now. *) let my_closure_param = Bound_parameter.create my_closure Flambda_kind.With_subkind.any_value my_closure_duid From a6246d9afa14c9941837aa95c4876fe1bfe6ae5c Mon Sep 17 00:00:00 2001 From: Simon Spies Date: Tue, 1 Jul 2025 18:14:15 +0100 Subject: [PATCH 4/4] ocamlformat --- middle_end/flambda2/to_cmm/to_cmm.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/middle_end/flambda2/to_cmm/to_cmm.ml b/middle_end/flambda2/to_cmm/to_cmm.ml index d6c176659fa..b9d86390f63 100644 --- a/middle_end/flambda2/to_cmm/to_cmm.ml +++ b/middle_end/flambda2/to_cmm/to_cmm.ml @@ -93,8 +93,7 @@ let unit0 ~offsets ~all_code ~reachable_names flambda_unit = (* See comment in [To_cmm_set_of_closures] about binding [my_region] *) let env, toplevel_region_var = Env.create_bound_parameter env - ( Flambda_unit.toplevel_my_region flambda_unit, - Flambda_debug_uid.none ) + (Flambda_unit.toplevel_my_region flambda_unit, Flambda_debug_uid.none) in let r = R.create ~reachable_names