From 9a22da8417c0bdadc5ca830cf40070592eda1b14 Mon Sep 17 00:00:00 2001 From: Simon Spies Date: Wed, 30 Apr 2025 13:43:25 +0100 Subject: [PATCH 1/9] propagate uids from typed tree through lambda --- bytecomp/bytegen.ml | 10 +- chamelon/compat.jst.ml | 2 + lambda/lambda.ml | 130 +++++++------- lambda/lambda.mli | 33 +++- lambda/matching.ml | 161 +++++++++++------- lambda/printlambda.ml | 12 +- lambda/simplif.ml | 102 ++++++----- lambda/simplif.mli | 1 + lambda/tmc.ml | 65 ++++--- lambda/transl_array_comprehension.ml | 46 +++-- lambda/transl_comprehension_utils.ml | 18 +- lambda/transl_comprehension_utils.mli | 3 +- lambda/transl_list_comprehension.ml | 31 +++- lambda/translclass.ml | 161 +++++++++++------- lambda/translcore.ml | 103 +++++++---- lambda/translmod.ml | 121 +++++++++---- lambda/translobj.ml | 7 +- lambda/translprim.ml | 6 +- lambda/value_rec_compiler.ml | 64 +++---- lambda/value_rec_compiler.mli | 2 +- .../flambda2/from_lambda/lambda_to_flambda.ml | 64 ++++--- .../lambda_to_lambda_transforms.ml | 53 ++++-- .../lambda_to_lambda_transforms.mli | 1 + toplevel/native/opttoploop.ml | 2 +- typing/printtyped.ml | 3 +- typing/tast_iterator.ml | 2 +- typing/tast_mapper.ml | 16 +- typing/typecore.ml | 51 +++--- typing/typecore.mli | 4 +- typing/typedtree.ml | 5 + typing/typedtree.mli | 5 + 31 files changed, 838 insertions(+), 446 deletions(-) diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index fcd03657384..ee82ed4ff0f 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -875,8 +875,9 @@ and comp_expr stack_info env exp sz cont = Stack.push to_compile functions_to_compile; comp_args stack_info env (List.map (fun n -> Lvar n) fv) sz (Kclosure(lbl, List.length fv) :: cont) - | Llet(_, _k, id, arg, body) - | Lmutlet(_k, id, arg, body) -> + | Llet(_, _k, id, _duid, arg, body) + | Lmutlet(_k, id, _duid, arg, body) -> + (* We are intentionally dropping the [debug_uid] identifiers here. *) comp_expr stack_info env arg sz (Kpush :: comp_expr stack_info (add_var id (sz+1) env) body (sz+1) (add_pop 1 cont)) @@ -1158,7 +1159,7 @@ and comp_expr stack_info env exp sz cont = comp_args stack_info env args sz (comp_primitive stack_info p (sz + nargs - 1) args :: cont) | Lstaticcatch (body, (i, vars) , handler, _, _) -> - let vars = List.map fst vars in + let vars = List.map fst3 vars in let nvars = List.length vars in let branch1, cont1 = make_branch cont in let r = @@ -1202,7 +1203,8 @@ and comp_expr stack_info env exp sz cont = comp_expr stack_info env arg sz cont | _ -> comp_exit_args stack_info env args sz size cont end - | Ltrywith(body, id, handler, _kind) -> + | Ltrywith(body, id, _duid, handler, _kind) -> + (* We are intentionally dropping the [debug_uid] identifiers here. *) let (branch1, cont1) = make_branch cont in let lbl_handler = new_label() in let body_cont = diff --git a/chamelon/compat.jst.ml b/chamelon/compat.jst.ml index 8f370371fc5..c5e6a3112c0 100644 --- a/chamelon/compat.jst.ml +++ b/chamelon/compat.jst.ml @@ -146,6 +146,7 @@ let mkTexp_function ?(id = texp_function_defaults) | Some default -> Tparam_optional_default (pattern, default, id.param_sort)); fp_param = param; + fp_param_debug_uid = Lambda.debug_uid_none; fp_partial = partial; fp_sort = id.param_sort; fp_mode = id.param_mode; @@ -163,6 +164,7 @@ let mkTexp_function ?(id = texp_function_defaults) { fc_cases = cases; fc_param = param; + fc_param_debug_uid = Lambda.debug_uid_none; fc_partial = partial; fc_env = id.env; fc_ret_type = id.ret_type; diff --git a/lambda/lambda.ml b/lambda/lambda.ml index 8b94491fb67..9b3004d1b75 100644 --- a/lambda/lambda.ml +++ b/lambda/lambda.ml @@ -802,8 +802,12 @@ type parameter_attribute = { unbox_param: bool; } +type debug_uid = Shape.Uid.t +let debug_uid_none = Shape.Uid.internal_not_actually_unique + type lparam = { name : Ident.t; + debug_uid : debug_uid; layout : layout; attributes : parameter_attribute; mode : locality_mode @@ -819,8 +823,8 @@ type lambda = | Lconst of structured_constant | Lapply of lambda_apply | Lfunction of lfunction - | Llet of let_kind * layout * Ident.t * lambda * lambda - | Lmutlet of layout * Ident.t * lambda * lambda + | Llet of let_kind * layout * Ident.t * debug_uid * lambda * lambda + | Lmutlet of layout * Ident.t * debug_uid * lambda * lambda | Lletrec of rec_binding list * lambda | Lprim of primitive * lambda list * scoped_location | Lswitch of lambda * lambda_switch * scoped_location * layout @@ -828,9 +832,9 @@ type lambda = lambda * (string * lambda) list * lambda option * scoped_location * layout | Lstaticraise of static_label * lambda list | Lstaticcatch of - lambda * (static_label * (Ident.t * layout) list) * lambda + lambda * (static_label * (Ident.t * debug_uid * layout) list) * lambda * pop_region * layout - | Ltrywith of lambda * Ident.t * lambda * layout + | Ltrywith of lambda * Ident.t * debug_uid * lambda * layout | Lifthenelse of lambda * lambda * lambda * layout | Lsequence of lambda * lambda | Lwhile of lambda_while @@ -846,6 +850,7 @@ type lambda = and rec_binding = { id : Ident.t; + debug_uid : debug_uid; def : lfunction; } @@ -867,6 +872,7 @@ and lambda_while = and lambda_for = { for_id : Ident.t; + for_debug_uid : debug_uid; for_loc : scoped_location; for_from : lambda; for_to : lambda; @@ -1092,20 +1098,20 @@ let make_key e = Lapply {ap with ap_func = tr_rec env ap.ap_func; ap_args = tr_recs env ap.ap_args; ap_loc = Loc_unknown} - | Llet (Alias,_k,x,ex,e) -> (* Ignore aliases -> substitute *) + | Llet (Alias,_k,x,_x_duid,ex,e) -> (* Ignore aliases -> substitute *) let ex = tr_rec env ex in tr_rec (Ident.add x ex env) e - | Llet ((Strict | StrictOpt),_k,x,ex,Lvar v) when Ident.same v x -> + | Llet ((Strict | StrictOpt),_k,x,_x_duid,ex,Lvar v) when Ident.same v x -> tr_rec env ex - | Llet (str,k,x,ex,e) -> + | Llet (str,k,x,x_duid,ex,e) -> (* Because of side effects, keep other lets with normalized names *) let ex = tr_rec env ex in let y = make_key x in - Llet (str,k,y,ex,tr_rec (Ident.add x (Lvar y) env) e) - | Lmutlet (k,x,ex,e) -> + Llet (str,k,y,x_duid,ex,tr_rec (Ident.add x (Lvar y) env) e) + | Lmutlet (k,x,x_duid,ex,e) -> let ex = tr_rec env ex in let y = make_key x in - Lmutlet (k,y,ex,tr_rec (Ident.add x (Lmutvar y) env) e) + Lmutlet (k,y,x_duid,ex,tr_rec (Ident.add x (Lmutvar y) env) e) | Lprim (p,es,_) -> Lprim (p,tr_recs env es, Loc_unknown) | Lswitch (e,sw,loc,kind) -> @@ -1120,8 +1126,8 @@ let make_key e = Lstaticraise (i,tr_recs env es) | Lstaticcatch (e1,xs,e2, r, kind) -> Lstaticcatch (tr_rec env e1,xs,tr_rec env e2, r, kind) - | Ltrywith (e1,x,e2,kind) -> - Ltrywith (tr_rec env e1,x,tr_rec env e2,kind) + | Ltrywith (e1,x,x_duid,e2,kind) -> + Ltrywith (tr_rec env e1,x,x_duid,tr_rec env e2,kind) | Lifthenelse (cond,ifso,ifnot,kind) -> Lifthenelse (tr_rec env cond,tr_rec env ifso,tr_rec env ifnot,kind) | Lsequence (e1,e2) -> @@ -1163,7 +1169,8 @@ let name_lambda strict arg layout fn = Lvar id -> fn id | _ -> let id = Ident.create_local "let" in - Llet(strict, layout, id, arg, fn id) + let id_debug_uid = debug_uid_none in + Llet(strict, layout, id, id_debug_uid, arg, fn id) let name_lambda_list args fn = let rec name_list names = function @@ -1172,7 +1179,8 @@ let name_lambda_list args fn = name_list (arg :: names) rem | (arg, layout) :: rem -> let id = Ident.create_local "let" in - Llet(Strict, layout, id, arg, name_list (Lvar id :: names) rem) in + let id_debug_uid = debug_uid_none in + Llet(Strict, layout, id, id_debug_uid, arg, name_list (Lvar id :: names) rem) in name_list [] args @@ -1188,8 +1196,8 @@ let shallow_iter ~tail ~non_tail:f = function f fn; List.iter f args | Lfunction{body} -> f body - | Llet(_, _k, _id, arg, body) - | Lmutlet(_k, _id, arg, body) -> + | Llet(_, _k, _id, _duid, arg, body) + | Lmutlet(_k, _id, _duid, arg, body) -> f arg; tail body | Lletrec(decl, body) -> tail body; @@ -1213,7 +1221,7 @@ let shallow_iter ~tail ~non_tail:f = function List.iter f args | Lstaticcatch(e1, _, e2, _, _kind) -> tail e1; tail e2 - | Ltrywith(e1, _, e2,_) -> + | Ltrywith(e1, _, _, e2,_) -> f e1; tail e2 | Lifthenelse(e1, e2, e3,_) -> f e1; tail e2; tail e3 @@ -1248,8 +1256,8 @@ let rec free_variables = function | Lfunction{body; params} -> Ident.Set.diff (free_variables body) (Ident.Set.of_list (List.map (fun p -> p.name) params)) - | Llet(_, _k, id, arg, body) - | Lmutlet(_k, id, arg, body) -> + | Llet(_, _k, id, _duid, arg, body) + | Lmutlet(_k, id, _duid, arg, body) -> Ident.Set.union (free_variables arg) (Ident.Set.remove id (free_variables body)) @@ -1288,9 +1296,9 @@ let rec free_variables = function Ident.Set.union (Ident.Set.diff (free_variables handler) - (Ident.Set.of_list (List.map fst params))) + (Ident.Set.of_list (List.map fst3 params))) (free_variables body) - | Ltrywith(body, param, handler, _) -> + | Ltrywith(body, param, _duid, handler, _) -> Ident.Set.union (Ident.Set.remove param @@ -1340,15 +1348,15 @@ let staticfail = Lstaticraise (0,[]) let rec is_guarded = function | Lifthenelse(_cond, _body, Lstaticraise (0,[]),_) -> true - | Llet(_str, _k, _id, _lam, body) -> is_guarded body + | Llet(_str, _k, _id, _duid, _lam, body) -> is_guarded body | Levent(lam, _ev) -> is_guarded lam | _ -> false let rec patch_guarded patch = function | Lifthenelse (cond, body, Lstaticraise (0,[]), kind) -> Lifthenelse (cond, body, patch, kind) - | Llet(str, k, id, lam, body) -> - Llet (str, k, id, lam, patch_guarded patch body) + | Llet(str, k, id, duid, lam, body) -> + Llet (str, k, id, duid, lam, patch_guarded patch body) | Levent(lam, ev) -> Levent (patch_guarded patch lam, ev) | _ -> fatal_error "Lambda.patch_guarded" @@ -1445,26 +1453,29 @@ let build_substs update_env ?(freshen_bound_variables = false) s = [l] with all the bound variables of the input term in the current scope, mapped to either themselves or freshened versions of themselves when [freshen_bound_variables] is set. *) - let bind id l = + let bind id duid l = let id' = if not freshen_bound_variables then id else Ident.rename id in - id', Ident.Map.add id id' l + (* CR sspies: If [freshen_bound_variables] is set, this code duplicates + the debug uids. [freshen_bound_variables] is currently only set by + [duplicate] below, which is called from [tmc.ml]. *) + id', duid, Ident.Map.add id id' l in let bind_many ids l = - List.fold_right (fun (id, rhs) (ids', l) -> - let id', l = bind id l in - ((id', rhs) :: ids' , l) + List.fold_right (fun (id, duid, rhs) (ids', l) -> + let id', duid', l = bind id duid l in + ((id', duid', rhs) :: ids' , l) ) ids ([], l) in let bind_params params l = - List.fold_right (fun p (params', l) -> - let name', l = bind p.name l in - ({ p with name = name' } :: params' , l) + List.fold_right (fun (p: lparam) (params', l) -> + let name', duid', l = bind p.name p.debug_uid l in + ({ p with name = name'; debug_uid = duid' } :: params' , l) ) params ([], l) in let bind_rec ids l = - List.fold_right (fun rb (ids', l) -> - let id', l = bind rb.id l in - ({ rb with id = id' } :: ids' , l) + List.fold_right (fun (rb: rec_binding) (ids', l) -> + let id', duid', l = bind rb.id rb.debug_uid l in + ({ rb with id = id'; debug_uid = duid' } :: ids' , l) ) ids ([], l) in let rec subst s l lam = @@ -1492,12 +1503,12 @@ let build_substs update_env ?(freshen_bound_variables = false) s = ap_args = subst_list s l ap.ap_args} | Lfunction lf -> Lfunction (subst_lfun s l lf) - | Llet(str, k, id, arg, body) -> - let id, l' = bind id l in - Llet(str, k, id, subst s l arg, subst s l' body) - | Lmutlet(k, id, arg, body) -> - let id, l' = bind id l in - Lmutlet(k, id, subst s l arg, subst s l' body) + | Llet(str, k, id, duid, arg, body) -> + let id, duid, l' = bind id duid l in + Llet(str, k, id, duid, subst s l arg, subst s l' body) + | Lmutlet(k, id, duid, arg, body) -> + let id, duid, l' = bind id duid l in + Lmutlet(k, id, duid, subst s l arg, subst s l' body) | Lletrec(decl, body) -> let decl, l' = bind_rec decl l in Lletrec(List.map (subst_decl s l') decl, subst s l' body) @@ -1519,17 +1530,18 @@ let build_substs update_env ?(freshen_bound_variables = false) s = let params, l' = bind_many params l in Lstaticcatch(subst s l body, (id, params), subst s l' handler, r, kind) - | Ltrywith(body, exn, handler,kind) -> - let exn, l' = bind exn l in - Ltrywith(subst s l body, exn, subst s l' handler,kind) + | Ltrywith(body, exn, duid, handler,kind) -> + let exn, duid, l' = bind exn duid l in + Ltrywith(subst s l body, exn, duid, subst s l' handler,kind) | Lifthenelse(e1, e2, e3,kind) -> Lifthenelse(subst s l e1, subst s l e2, subst s l e3,kind) | Lsequence(e1, e2) -> Lsequence(subst s l e1, subst s l e2) | Lwhile lw -> Lwhile { wh_cond = subst s l lw.wh_cond; wh_body = subst s l lw.wh_body} | Lfor lf -> - let for_id, l' = bind lf.for_id l in + let for_id, for_duid, l' = bind lf.for_id lf.for_debug_uid l in Lfor {lf with for_id; + for_debug_uid = for_duid; for_from = subst s l lf.for_from; for_to = subst s l lf.for_to; for_body = subst s l' lf.for_body} @@ -1640,10 +1652,10 @@ let shallow_map ~tail ~non_tail:f = function } | Lfunction lfun -> Lfunction (map_lfunction f lfun) - | Llet (str, layout, v, e1, e2) -> - Llet (str, layout, v, f e1, tail e2) - | Lmutlet (layout, v, e1, e2) -> - Lmutlet (layout, v, f e1, tail e2) + | Llet (str, layout, v, v_duid, e1, e2) -> + Llet (str, layout, v, v_duid, f e1, tail e2) + | Lmutlet (layout, v, v_duid, e1, e2) -> + Lmutlet (layout, v, v_duid, f e1, tail e2) | Lletrec (idel, e2) -> Lletrec (List.map (fun rb -> @@ -1674,8 +1686,8 @@ let shallow_map ~tail ~non_tail:f = function Lstaticraise (i, List.map f args) | Lstaticcatch (body, id, handler, r, layout) -> Lstaticcatch (tail body, id, tail handler, r, layout) - | Ltrywith (e1, v, e2, layout) -> - Ltrywith (f e1, v, tail e2, layout) + | Ltrywith (e1, v, duid, e2, layout) -> + Ltrywith (f e1, v, duid, tail e2, layout) | Lifthenelse (e1, e2, e3, layout) -> Lifthenelse (f e1, tail e2, tail e3, layout) | Lsequence (e1, e2) -> @@ -1706,10 +1718,12 @@ let map f = (* To let-bind expressions to variables *) -let bind_with_layout str (var, layout) exp body = +let bind_with_layout str (var, duid, layout) exp body = match exp with Lvar var' when Ident.same var var' -> body - | _ -> Llet(str, layout, var, exp, body) + (* CR sspies: This implicitly assumes that they have the same debug uid, + which is probably correct.*) + | _ -> Llet(str, layout, var, duid, exp, body) let negate_integer_comparison = function | Ceq -> Cne @@ -2421,7 +2435,7 @@ let compute_expr_layout free_vars_kind lam = | Lfunction _ -> layout_function | Lapply { ap_result_layout; _ } -> ap_result_layout | Lsend (_, _, _, _, _, _, _, layout) -> layout - | Llet(_, kind, id, _, body) | Lmutlet(kind, id, _, body) -> + | Llet(_, kind, id, _duid, _, body) | Lmutlet(kind, id, _duid, _, body) -> compute_expr_layout (Ident.Map.add id kind kinds) body | Lletrec(defs, body) -> let kinds = @@ -2432,7 +2446,7 @@ let compute_expr_layout free_vars_kind lam = | Lprim(p, _, _) -> primitive_result_layout p | Lswitch(_, _, _, kind) | Lstringswitch(_, _, _, _, kind) - | Lstaticcatch(_, _, _, _, kind) | Ltrywith(_, _, _, kind) + | Lstaticcatch(_, _, _, _, kind) | Ltrywith(_, _, _, _, kind) | Lifthenelse(_, _, _, kind) | Lregion (_, kind) -> kind | Lstaticraise (_, _) -> @@ -2555,8 +2569,8 @@ let rec try_to_find_location lam = | Lsend (_, _, _, _, _, _, loc, _) | Levent (_, { lev_loc = loc; _ }) -> loc - | Llet (_, _, _, lam, _) - | Lmutlet (_, _, lam, _) + | Llet (_, _, _, _, lam, _) + | Lmutlet (_, _, _, lam, _) | Lifthenelse (lam, _, _, _) | Lstaticcatch (lam, _, _, _, _) | Lstaticraise (_, lam :: _) @@ -2566,7 +2580,7 @@ let rec try_to_find_location lam = | Lifused (_, lam) | Lregion (lam, _) | Lexclave lam - | Ltrywith (lam, _, _, _) -> + | Ltrywith (lam, _, _, _, _) -> try_to_find_location lam | Lvar _ | Lmutvar _ | Lconst _ | Lletrec _ | Lstaticraise (_, []) -> Debuginfo.Scoped_location.Loc_unknown diff --git a/lambda/lambda.mli b/lambda/lambda.mli index cdf74d87b86..cf6d28201a2 100644 --- a/lambda/lambda.mli +++ b/lambda/lambda.mli @@ -736,8 +736,27 @@ type parameter_attribute = { unbox_param: bool; } +type debug_uid = Shape.Uid.t +(** The [debug_uid] values track typed-tree level identifiers that are then + passed down to the lower level IRs and eventually emitted into dwarf output. + WARNING: Unlike the name sugggests, these identifiers are not always unique. + Instead, in many cases, we use [debug_uid_none] below, and multiple variables + at the level of Lambda or below can use the same [debug_uid]. *) +(* CR sspies: This comment is currently not accurate, since we do not yet + emit these ids into dwarf code. *) +(* CR sspies: The point of the name [debug_uid] is to preserve the connection + to the underlying [Shape.Uid.t]. It could lead to confusion around the fact + that these identifiers are not actually unique. *) + +val debug_uid_none : debug_uid +(** [debug_uid_none] should be used for those identifiers that are not + user visible (i.e., that are created internally in the compiler and do not + mean anything to users writing OCaml code). *) + + type lparam = { name : Ident.t; + debug_uid : debug_uid; layout : layout; attributes : parameter_attribute; mode : locality_mode @@ -755,8 +774,8 @@ type lambda = | Lconst of structured_constant | Lapply of lambda_apply | Lfunction of lfunction - | Llet of let_kind * layout * Ident.t * lambda * lambda - | Lmutlet of layout * Ident.t * lambda * lambda + | Llet of let_kind * layout * Ident.t * debug_uid * lambda * lambda + | Lmutlet of layout * Ident.t * debug_uid * lambda * lambda | Lletrec of rec_binding list * lambda | Lprim of primitive * lambda list * scoped_location | Lswitch of lambda * lambda_switch * scoped_location * layout @@ -778,9 +797,11 @@ type lambda = it means that we consider the top region at the point of the [Lstaticcatch] to not be considered open inside the handler. *) | Lstaticcatch of - lambda * (static_label * (Ident.t * layout) list) * lambda + lambda * (static_label * (Ident.t * debug_uid * layout) list) * lambda * pop_region * layout - | Ltrywith of lambda * Ident.t * lambda * layout + | Ltrywith of lambda * Ident.t * debug_uid * lambda * layout + (* CR sspies: What is the identifier in a [Ltrywith]. Should it get a debug + id? *) (* Lifthenelse (e, t, f, layout) evaluates t if e evaluates to 0, and evaluates f if e evaluates to any other value; layout must be the layout of [t] and [f] *) | Lifthenelse of lambda * lambda * lambda * layout @@ -799,6 +820,7 @@ type lambda = and rec_binding = { id : Ident.t; + debug_uid : debug_uid; def : lfunction; (* Generic recursive bindings have been removed from Lambda in 5.2. [Value_rec_compiler.compile_letrec] deals with transforming generic @@ -825,6 +847,7 @@ and lambda_while = and lambda_for = { for_id : Ident.t; + for_debug_uid : debug_uid; for_loc : scoped_location; for_from : lambda; for_to : lambda; @@ -1113,7 +1136,7 @@ val shallow_map : (** Rewrite each immediate sub-term with the function. *) val bind_with_layout: - let_kind -> (Ident.t * layout) -> lambda -> lambda -> lambda + let_kind -> (Ident.t * debug_uid * layout) -> lambda -> lambda -> lambda val negate_integer_comparison : integer_comparison -> integer_comparison val swap_integer_comparison : integer_comparison -> integer_comparison diff --git a/lambda/matching.ml b/lambda/matching.ml index 8ca101b7242..efdc33209db 100644 --- a/lambda/matching.ml +++ b/lambda/matching.ml @@ -181,9 +181,9 @@ let expand_record_unboxed_product_head h = { h with pat_desc = Record_unboxed_product (Array.to_list lbl_all) } | _ -> h -let bind_alias p id ~arg ~arg_sort ~action = +let bind_alias p id duid ~arg ~arg_sort ~action = let k = Typeopt.layout p.pat_env p.pat_loc arg_sort p.pat_type in - bind_with_layout Alias (id, k) arg action + bind_with_layout Alias (id, duid, k) arg action let head_loc ~scopes head = Scoped_location.of_location ~scopes head.pat_loc @@ -269,10 +269,10 @@ end = struct | `Any -> stop p `Any | `Var (id, s, uid, mode) -> continue p (`Alias (Patterns.omega, id, s, uid, mode, p.pat_type)) - | `Alias (p, id, _, _, _, _) -> + | `Alias (p, id, _, duid, _, _) -> aux ( (General.view p, patl), - bind_alias p id ~arg ~arg_sort ~action ) + bind_alias p id duid ~arg ~arg_sort ~action ) | `Record ([], _) as view -> stop p view | `Record (lbls, closed) -> let full_view = `Record (all_record_args lbls, closed) in @@ -309,7 +309,7 @@ module Simple : sig arg_sort:Jkind.Sort.Const.t -> Half_simple.pattern -> mk_action:(vars:Ident.t list -> lambda) -> - patbound_action_vars:Ident.t list -> + patbound_action_vars:(Ident.t * Lambda.debug_uid) list -> (pattern * lambda) list end = struct include Patterns.Simple @@ -403,7 +403,7 @@ end = struct let fresh_pat = alpha renaming_env { p with pat_desc = view } in let fresh_action = mk_action ~vars:(List.rev action_vars) in (fresh_pat, fresh_action) - | pat_id :: rem_vars -> + | (pat_id, pat_duid) :: rem_vars -> if not (List.mem pat_id aliases) then begin let fresh_id = Ident.rename pat_id in let action_vars = fresh_id :: action_vars in @@ -422,7 +422,7 @@ end = struct let pat, action = fresh_clause (Some id) action_vars renaming_env rem_vars in - pat, bind_alias pat id ~arg ~arg_sort ~action + pat, bind_alias pat id pat_duid ~arg ~arg_sort ~action end in fresh_clause None [] [] patbound_action_vars :: rem @@ -1022,7 +1022,7 @@ type 'row pattern_matching = { type handler = { provenance : matrix; exit : int; - vars : (Ident.t * Lambda.layout) list; + vars : (Ident.t * Lambda.debug_uid * Lambda.layout) list; pm : initial_clause pattern_matching } @@ -1158,7 +1158,7 @@ let make_catch kind d k = (* Introduce a catch, if worth it, delayed version *) let rec as_simple_exit = function | Lstaticraise (i, []) -> Some i - | Llet (Alias, _k, _, _, e) -> as_simple_exit e + | Llet (Alias, _k, _, _, _, e) -> as_simple_exit e | _ -> None let make_catch_delayed kind handler = @@ -1701,8 +1701,9 @@ and precompile_or ~arg ~arg_sort (cls : Simple.clause list) ors args def k = that are used in the orpm actions *) Typedtree.pat_bound_idents_full arg_sort orp |> List.filter (fun (id, _, _, _, _) -> Ident.Set.mem id pm_fv) - |> List.map (fun (id, _, ty, _, id_sort) -> - (id, Typeopt.layout orp.pat_env orp.pat_loc id_sort ty)) + |> List.map (fun (id, _, ty, uid, id_sort) -> + (* CR sspies: Can this uid be used for debugging? *) + (id, uid, Typeopt.layout orp.pat_env orp.pat_loc id_sort ty)) in let or_num = next_raise_count () in let new_patl = Patterns.omega_list patl in @@ -1712,7 +1713,8 @@ and precompile_or ~arg ~arg_sort (cls : Simple.clause list) ors args def k = let new_cases = Simple.explode_or_pat ~arg ~arg_sort p ~mk_action:mk_new_action - ~patbound_action_vars:(List.map fst patbound_action_vars) + ~patbound_action_vars: + (List.map (fun (id, duid, _) -> id, duid) patbound_action_vars) |> List.map (fun (p, act) -> ((p, new_patl), act)) in let handler = { provenance = [ [ orp ] ]; @@ -2115,8 +2117,10 @@ let lazy_forward_field = Lambda.Pfield (0, Pointer, Reads_vary) let inline_lazy_force_cond arg pos loc = let idarg = Ident.create_local "lzarg" in + let idarg_duid = Lambda.debug_uid_none in let varg = Lvar idarg in let tag = Ident.create_local "tag" in + let tag_duid = Lambda.debug_uid_none in let test_tag t = Lprim(Pintcomp Ceq, [Lvar tag; Lconst(Const_base(Const_int t))], loc) in @@ -2124,11 +2128,13 @@ let inline_lazy_force_cond arg pos loc = ( Strict, Lambda.layout_lazy, idarg, + idarg_duid, arg, Llet ( Alias, Lambda.layout_int, tag, + tag_duid, Lprim (Pccall prim_obj_tag, [ varg ], loc), Lifthenelse ( (* if (tag == Obj.forward_tag) then varg.(0) else ... *) @@ -2149,11 +2155,13 @@ let inline_lazy_force_cond arg pos loc = let inline_lazy_force_switch arg pos loc = let idarg = Ident.create_local "lzarg" in + let idarg_duid = Lambda.debug_uid_none in let varg = Lvar idarg in Llet ( Strict, Lambda.layout_lazy, idarg, + idarg_duid, arg, Lifthenelse ( Lprim (Pisint { variant_only = false }, [ varg ], loc), @@ -2515,7 +2523,8 @@ let bind_sw arg layout k = | Lvar _ -> k arg | _ -> let id = Ident.create_local "switch" in - Llet (Strict, layout, id, arg, k (Lvar id)) + let id_duid = Lambda.debug_uid_none in + Llet (Strict, layout, id, id_duid, arg, k (Lvar id)) (* Sequential equality tests *) @@ -2722,15 +2731,19 @@ module SArg = struct | _ -> Lprim (Poffsetint n, [ arg ], Loc_unknown) let bind arg body = - let newvar, newarg = + let newvar, newvar_duid, newarg = match arg with - | Lvar v -> (v, arg) + | Lvar v -> (v, Lambda.debug_uid_none, arg) + (* CR sspies: This seems like the kind of place where we could have + a debug uid. Is there a way to get it here? *) | _ -> let newvar = Ident.create_local "switcher" in - (newvar, Lvar newvar) + let newvar_duid = Lambda.debug_uid_none in + (newvar, newvar_duid, Lvar newvar) in (* [switch.ml] will only call bind with an integer argument *) - bind_with_layout Alias (newvar, Lambda.layout_int) arg (body newarg) + bind_with_layout Alias + (newvar, newvar_duid, Lambda.layout_int) arg (body newarg) let make_const i = Lconst (Const_base (Const_int i)) @@ -3263,6 +3276,7 @@ let combine_constructor value_kind loc arg pat_env pat_barrier cstr partial ctx | [] -> default | _ -> let tag = Ident.create_local "tag" in + let tag_duid = Lambda.debug_uid_none in let tests = List.fold_right (fun (path, act) rem -> @@ -3274,7 +3288,7 @@ let combine_constructor value_kind loc arg pat_env pat_barrier cstr partial ctx let ubr = Translmode.transl_unique_barrier pat_barrier in let sem = add_barrier_to_read ubr Reads_agree in let str = add_barrier_to_let_kind ubr Alias in - Llet (str, Lambda.layout_block, tag, + Llet (str, Lambda.layout_block, tag, tag_duid, Lprim (Pfield (0, Pointer, sem), [ arg ], loc), tests) in @@ -3406,12 +3420,14 @@ let call_switcher_variant_constant kind loc fail arg int_lambda_list = let call_switcher_variant_constr value_kind loc fail arg pat_barrier int_lambda_list = let v = Ident.create_local "variant" in + let v_duid = Lambda.debug_uid_none in let ubr = Translmode.transl_unique_barrier pat_barrier in let str = add_barrier_to_let_kind ubr Alias in Llet ( str, Lambda.layout_int, v, + v_duid, Lprim (nonconstant_variant_field ubr 0, [ arg ], loc), call_switcher value_kind loc fail (Lvar v) min_int max_int int_lambda_list ) @@ -3491,10 +3507,12 @@ let combine_array value_kind loc arg kind partial ctx def (len_lambda_list, tota let fail, local_jumps = mk_failaction_neg partial ctx def in let lambda1 = let newvar = Ident.create_local "len" in + let newvar_duid = Lambda.debug_uid_none in let switch = call_switcher value_kind loc fail (Lvar newvar) 0 max_int len_lambda_list in - bind_with_layout Alias (newvar, Lambda.layout_int) (Lprim (Parraylength kind, [ arg ], loc)) switch + bind_with_layout Alias (newvar, newvar_duid, Lambda.layout_int) + (Lprim (Parraylength kind, [ arg ], loc)) switch in (lambda1, Jumps.union local_jumps total1) @@ -3512,8 +3530,8 @@ let rec event_branch repr lam = lev_repr = repr; lev_env = ev.lev_env } ) - | Llet (str, k, id, lam, body), _ -> - Llet (str, k, id, lam, event_branch repr body) + | Llet (str, k, id, duid, lam, body), _ -> + Llet (str, k, id, duid, lam, event_branch repr body) | Lstaticraise _, _ -> lam | _, Some _ -> fatal_errorf "Matching.event_branch: %a" Printlambda.lambda lam @@ -3614,11 +3632,13 @@ let rec approx_present v = function | Lstaticraise (_, args) -> List.exists (fun lam -> approx_present v lam) args | Lprim (_, args, _) -> List.exists (fun lam -> approx_present v lam) args - | Llet (Alias, _k, _, l1, l2) -> approx_present v l1 || approx_present v l2 + | Llet (Alias, _k, _duid, _, l1, l2) -> + approx_present v l1 || approx_present v l2 | Lvar vv -> Ident.same v vv | _ -> true -let rec lower_bind v arg_layout arg lam = +(* CR sspies: I'm unsure about the [debug_uid] handling in this function. *) +let rec lower_bind v v_duid arg_layout arg lam = match lam with | Lifthenelse (cond, ifso, ifnot, kind) -> ( let pcond = approx_present v cond @@ -3627,33 +3647,35 @@ let rec lower_bind v arg_layout arg lam = match (pcond, pso, pnot) with | false, false, false -> lam | false, true, false -> - Lifthenelse (cond, lower_bind v arg_layout arg ifso, ifnot, kind) + Lifthenelse (cond, lower_bind v v_duid arg_layout arg ifso, ifnot, kind) | false, false, true -> - Lifthenelse (cond, ifso, lower_bind v arg_layout arg ifnot, kind) - | _, _, _ -> bind_with_layout Alias (v, arg_layout) arg lam + Lifthenelse (cond, ifso, lower_bind v v_duid arg_layout arg ifnot, kind) + | _, _, _ -> bind_with_layout Alias (v, v_duid, arg_layout) arg lam ) | Lswitch (ls, ({ sw_consts = [ (i, act) ]; sw_blocks = [] } as sw), loc, kind) when not (approx_present v ls) -> - Lswitch (ls, { sw with sw_consts = [ (i, lower_bind v arg_layout arg act) ] }, + Lswitch (ls, { sw with sw_consts = + [ (i, lower_bind v v_duid arg_layout arg act) ] }, loc, kind) | Lswitch (ls, ({ sw_consts = []; sw_blocks = [ (i, act) ] } as sw), loc, kind) when not (approx_present v ls) -> - Lswitch (ls, { sw with sw_blocks = [ (i, lower_bind v arg_layout arg act) ] }, + Lswitch (ls, { sw with sw_blocks = + [ (i, lower_bind v v_duid arg_layout arg act) ] }, loc, kind) - | Llet (Alias, k, vv, lv, l) -> + | Llet (Alias, k, vv, vv_duid, lv, l) -> if approx_present v lv then - bind_with_layout Alias (v, arg_layout) arg lam + bind_with_layout Alias (v, v_duid, arg_layout) arg lam else - Llet (Alias, k, vv, lv, lower_bind v arg_layout arg l) - | _ -> bind_with_layout Alias (v, arg_layout) arg lam + Llet (Alias, k, vv, vv_duid, lv, lower_bind v v_duid arg_layout arg l) + | _ -> bind_with_layout Alias (v, v_duid, arg_layout) arg lam -let bind_check str v arg_layout arg lam = +let bind_check str v v_duid arg_layout arg lam = match (str, arg) with - | _, Lvar _ -> bind_with_layout str (v, arg_layout) arg lam - | Alias, _ -> lower_bind v arg_layout arg lam - | _, _ -> bind_with_layout str (v, arg_layout) arg lam + | _, Lvar _ -> bind_with_layout str (v, v_duid, arg_layout) arg lam + | Alias, _ -> lower_bind v v_duid arg_layout arg lam + | _, _ -> bind_with_layout str (v, v_duid, arg_layout) arg lam let comp_exit ctx m = match Default_environment.pop m.default with @@ -3715,10 +3737,13 @@ let rec name_pattern default = function let arg_to_var arg cls = match arg with - | Lvar v -> (v, arg) + | Lvar v -> (v, Lambda.debug_uid_none, arg) + (* CR sspies: This seems like a place where we could be able to actually + get a debug uid. *) | _ -> let v = name_pattern "*match*" cls in - (v, Lvar v) + let v_duid = Lambda.debug_uid_none in + (v, v_duid, Lvar v) (* The main compilation function. @@ -3757,7 +3782,7 @@ and compile_match_nonempty ~scopes value_kind repr partial ctx match m with | { cases = []; args = [] } -> comp_exit ctx m | { args = (arg, str, arg_sort, layout) :: argl } -> - let v, newarg = arg_to_var arg m.cases in + let v, v_duid, newarg = arg_to_var arg m.cases in let args = (newarg, Alias, arg_sort, layout) :: argl in let cases = List.map (half_simplify_nonempty ~arg:newarg ~arg_sort) @@ -3767,7 +3792,8 @@ and compile_match_nonempty ~scopes value_kind repr partial ctx let first_match, rem = split_and_precompile_half_simplified ~arg:newarg ~arg_sort m in - combine_handlers ~scopes value_kind repr partial ctx (v, str, layout, arg) first_match rem + combine_handlers ~scopes value_kind repr partial ctx + (v, v_duid, str, layout, arg) first_match rem | _ -> assert false and compile_match_simplified ~scopes value_kind repr partial ctx @@ -3775,15 +3801,18 @@ and compile_match_simplified ~scopes value_kind repr partial ctx match m with | { cases = []; args = [] } -> comp_exit ctx m | { args = ((Lvar v as arg), str, sort, layout) :: argl } -> + let v_duid = Lambda.debug_uid_none in + (* CR sspies: Is this the expression in [match e with ...] or one of the cases? + Seems like the kind of place where we could potentially get a debug uid. *) let args = (arg, Alias, sort, layout) :: argl in let m = { m with args } in let first_match, rem = split_and_precompile_simplified m in - combine_handlers value_kind ~scopes repr partial ctx (v, str, layout, arg) - first_match rem + combine_handlers value_kind ~scopes repr partial ctx + (v, v_duid, str, layout, arg) first_match rem | _ -> assert false -and combine_handlers ~scopes value_kind repr partial ctx (v, str, arg_layout, arg) - first_match rem = +and combine_handlers ~scopes value_kind repr partial ctx + (v, v_duid, str, arg_layout, arg) first_match rem = let lam, total = comp_match_handlers value_kind (( if dbg then @@ -3794,7 +3823,7 @@ and combine_handlers ~scopes value_kind repr partial ctx (v, str, arg_layout, ar repr) partial ctx first_match rem in - (bind_check str v arg_layout arg lam, total) + (bind_check str v v_duid arg_layout arg lam, total) (* verbose version of do_compile_matching, for debug *) and do_compile_matching_pr ~scopes value_kind repr partial ctx x = @@ -4153,14 +4182,17 @@ let simple_for_let ~scopes ~arg_sort ~return_layout loc param pat body = *) let rec map_return f = function - | Llet (str, k, id, l1, l2) -> Llet (str, k, id, l1, map_return f l2) - | Lmutlet (k, id, l1, l2) -> Lmutlet (k, id, l1, map_return f l2) + | Llet (str, k, id, duid, l1, l2) -> + Llet (str, k, id, duid, l1, map_return f l2) + | Lmutlet (k, id, duid, l1, l2) -> + Lmutlet (k, id, duid, l1, map_return f l2) | Lletrec (l1, l2) -> Lletrec (l1, map_return f l2) | Lifthenelse (lcond, lthen, lelse, k) -> Lifthenelse (lcond, map_return f lthen, map_return f lelse, k) | Lsequence (l1, l2) -> Lsequence (l1, map_return f l2) | Levent (l, ev) -> Levent (map_return f l, ev) - | Ltrywith (l1, id, l2, k) -> Ltrywith (map_return f l1, id, map_return f l2, k) + | Ltrywith (l1, id, duid, l2, k) -> + Ltrywith (map_return f l1, id, duid, map_return f l2, k) | Lstaticcatch (l1, b, l2, r, k) -> Lstaticcatch (map_return f l1, b, map_return f l2, r, k) | Lswitch (s, sw, loc, k) -> @@ -4251,8 +4283,9 @@ let for_let ~scopes ~arg_sort ~return_layout loc param pat body = (* This eliminates a useless variable (and stack slot in bytecode) for "let _ = ...". See #6865. *) Lsequence (param, body) - | Tpat_var (id, _, _, _) - | Tpat_alias ({ pat_desc = Tpat_any }, id, _, _, _, _) -> + | Tpat_var (id, _, duid, _) + | Tpat_alias ({ pat_desc = Tpat_any }, id, _, duid, _, _) -> + (* CR sspies: Can these [Uid.t] values be used for debug information? *) (* Fast path, and keep track of simple bindings to unboxable numbers. Note: the (Tpat_alias (Tpat_any, id)) case needs to be @@ -4261,15 +4294,16 @@ let for_let ~scopes ~arg_sort ~return_layout loc param pat body = non-polymorphic Ppat_constraint case in type_pat_aux. *) let k = Typeopt.layout pat.pat_env pat.pat_loc arg_sort pat.pat_type in - Llet (Strict, k, id, param, body) + Llet (Strict, k, id, duid, param, body) | _ -> let opt = ref false in let nraise = next_raise_count () in let catch_ids = pat_bound_idents_full arg_sort pat in let ids_with_kinds = List.map - (fun (id, _, typ, _, sort) -> - (id, Typeopt.layout pat.pat_env pat.pat_loc sort typ)) + (fun (id, _, typ, uid, sort) -> + (* CR sspies: Can this uid be used for debug information? *) + (id, uid, Typeopt.layout pat.pat_env pat.pat_loc sort typ)) catch_ids in let ids = List.map (fun (id, _, _, _, _) -> id) catch_ids in @@ -4408,10 +4442,13 @@ let do_for_multiple_match ~scopes ~return_layout loc paraml mode pat_act_list pa let (idl_with_layouts, args) = List.map (function | Lvar id as lid, sort, layout -> - (id, layout), (lid, Alias, sort, layout) + (id, Lambda.debug_uid_none, layout), (lid, Alias, sort, layout) + (* CR sspies: This seems like a place where we should be able to actually + get a debug uid. The variable is used for a smart let binding below. *) | _, sort, layout -> let id = Ident.create_local "*match*" in - (id, layout), (Lvar id, Alias, sort, layout)) + let id_uid = Lambda.debug_uid_none in + (id, id_uid, layout), (Lvar id, Alias, sort, layout)) paraml |> List.split in @@ -4433,18 +4470,22 @@ let do_for_multiple_match ~scopes ~return_layout loc paraml mode pat_act_list pa let param_to_var (param, sort, layout) = match param with - | Lvar v -> (v, sort, layout, None) - | _ -> (Ident.create_local "*match*", sort, layout, Some param) + | Lvar v -> (v, Lambda.debug_uid_none, sort, layout, None) + (* CR sspies: Another one of these places that looks like + we could get a debug uid here. *) + | _ -> (Ident.create_local "*match*", + Lambda.debug_uid_none, sort, layout, Some param) -let bind_opt (v, _, layout, eo) k = +let bind_opt (v, v_duid, _, layout, eo) k = match eo with | None -> k - | Some e -> Lambda.bind_with_layout Strict (v, layout) e k + | Some e -> + Lambda.bind_with_layout Strict (v, v_duid, layout) e k let for_multiple_match ~scopes ~return_layout loc paraml mode pat_act_list partial = let v_paraml = List.map param_to_var paraml in let paraml = - List.map (fun (v, sort, layout, _) -> (Lvar v, sort, layout)) v_paraml + List.map (fun (v, _, sort, layout, _) -> (Lvar v, sort, layout)) v_paraml in List.fold_right bind_opt v_paraml (do_for_multiple_match ~scopes ~return_layout loc paraml mode pat_act_list diff --git a/lambda/printlambda.ml b/lambda/printlambda.ml index 1bb5f0366ab..ed92b85ed0f 100644 --- a/lambda/printlambda.ml +++ b/lambda/printlambda.ml @@ -1260,7 +1260,7 @@ let rec lam ppf = function lfunction ppf lfun | Llet _ | Lmutlet _ as expr -> let let_kind = begin function - | Llet(str,_,_,_,_) -> + | Llet(str,_,_,_,_,_) -> begin match str with Alias -> "a" | Strict -> "" | StrictOpt -> "o" end @@ -1269,8 +1269,8 @@ let rec lam ppf = function end in let rec letbody ~sp = function - | Llet(_, k, id, arg, body) - | Lmutlet(k, id, arg, body) as l -> + | Llet(_, k, id, _duid, arg, body) + | Lmutlet(k, id, _duid, arg, body) as l -> if sp then fprintf ppf "@ "; fprintf ppf "@[<2>%a =%s%a@ %a@]" Ident.print id (let_kind l) layout k lam arg; @@ -1283,7 +1283,7 @@ let rec lam ppf = function let bindings ppf id_arg_list = let spc = ref false in List.iter - (fun { id; def } -> + (fun { id; debug_uid=_; def } -> if !spc then fprintf ppf "@ " else spc := true; fprintf ppf "@[<2>%a@ %a@]" Ident.print id lfunction def) id_arg_list in @@ -1346,12 +1346,12 @@ let rec lam ppf = function lam lbody i (fun ppf vars -> List.iter - (fun (x, k) -> fprintf ppf " %a%a" Ident.print x layout k) + (fun (x, _duid, k) -> fprintf ppf " %a%a" Ident.print x layout k) vars ) vars excl lam lhandler - | Ltrywith(lbody, param, lhandler, _kind) -> + | Ltrywith(lbody, param, _duid, lhandler, _kind) -> fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" lam lbody Ident.print param lam lhandler | Lifthenelse(lcond, lif, lelse, _kind) -> diff --git a/lambda/simplif.ml b/lambda/simplif.ml index 0e71d83e1a7..6151a3e517a 100644 --- a/lambda/simplif.ml +++ b/lambda/simplif.ml @@ -40,10 +40,10 @@ let rec eliminate_ref id = function | Lfunction lfun as lam -> check_function_escape id lfun; lam - | Llet(str, kind, v, e1, e2) -> - Llet(str, kind, v, eliminate_ref id e1, eliminate_ref id e2) - | Lmutlet(kind, v, e1, e2) -> - Lmutlet(kind, v, eliminate_ref id e1, eliminate_ref id e2) + | Llet(str, kind, v, duid, e1, e2) -> + Llet(str, kind, v, duid, eliminate_ref id e1, eliminate_ref id e2) + | Lmutlet(kind, v, duid, e1, e2) -> + Lmutlet(kind, v, duid, eliminate_ref id e1, eliminate_ref id e2) | Lletrec(idel, e2) -> List.iter (fun rb -> check_function_escape id rb.def) idel; Lletrec(idel, eliminate_ref id e2) @@ -76,8 +76,8 @@ let rec eliminate_ref id = function Lstaticraise (i,List.map (eliminate_ref id) args) | Lstaticcatch(e1, i, e2, r, kind) -> Lstaticcatch(eliminate_ref id e1, i, eliminate_ref id e2, r, kind) - | Ltrywith(e1, v, e2, kind) -> - Ltrywith(eliminate_ref id e1, v, eliminate_ref id e2, kind) + | Ltrywith(e1, v, duid, e2, kind) -> + Ltrywith(eliminate_ref id e1, v, duid, eliminate_ref id e2, kind) | Lifthenelse(e1, e2, e3, kind) -> Lifthenelse(eliminate_ref id e1, eliminate_ref id e2, @@ -137,8 +137,8 @@ let simplify_exits lam = count ~try_depth ap.ap_func; List.iter (count ~try_depth) ap.ap_args | Lfunction {body} -> count ~try_depth body - | Llet(_, _kind, _v, l1, l2) - | Lmutlet(_kind, _v, l1, l2) -> + | Llet(_, _kind, _v, _duid, l1, l2) + | Lmutlet(_kind, _v, _duid, l1, l2) -> count ~try_depth l2; count ~try_depth l1 | Lletrec(bindings, body) -> List.iter (fun { def = { body } } -> count ~try_depth body) bindings; @@ -180,7 +180,7 @@ let simplify_exits lam = in count ~try_depth l2 end - | Ltrywith(l1, _v, l2, _kind) -> + | Ltrywith(l1, _v, _duid, l2, _kind) -> count ~try_depth:(try_depth+1) l1; count ~try_depth l2; | Lifthenelse(l1, l2, l3, _kind) -> @@ -246,10 +246,10 @@ let simplify_exits lam = ap_args = List.map (simplif ~layout:None ~try_depth) ap.ap_args} | Lfunction lfun -> Lfunction (map_lfunction (simplif ~layout:None ~try_depth) lfun) - | Llet(str, kind, v, l1, l2) -> - Llet(str, kind, v, simplif ~layout:None ~try_depth l1, simplif ~layout ~try_depth l2) - | Lmutlet(kind, v, l1, l2) -> - Lmutlet(kind, v, simplif ~layout:None ~try_depth l1, simplif ~layout ~try_depth l2) + | Llet(str, kind, v, duid, l1, l2) -> + Llet(str, kind, v, duid, simplif ~layout:None ~try_depth l1, simplif ~layout ~try_depth l2) + | Lmutlet(kind, v, duid, l1, l2) -> + Lmutlet(kind, v, duid, simplif ~layout:None ~try_depth l1, simplif ~layout ~try_depth l2) | Lletrec(bindings, body) -> let bindings = List.map (fun ({ def = {kind; params; return; body = l; attr; loc; @@ -308,10 +308,10 @@ let simplify_exits lam = let ls = List.map (simplif ~layout:None ~try_depth) ls in begin try let xs,handler = Hashtbl.find subst i in - let ys = List.map (fun (x, k) -> Ident.rename x, k) xs in + let ys = List.map (fun (x, duid, k) -> Ident.rename x, duid, k) xs in let env = List.fold_right2 - (fun (x, _) (y, _) env -> Ident.Map.add x y env) + (fun (x, _, _) (y, _, _) env -> Ident.Map.add x y env) xs ys Ident.Map.empty in (* The evaluation order for Lstaticraise arguments is currently @@ -321,7 +321,7 @@ let simplify_exits lam = so will be evaluated last). *) List.fold_left2 - (fun r (y, kind) l -> Llet (Strict, kind, y, l, r)) + (fun r (y, duid, kind) l -> Llet (Strict, kind, y, duid, l, r)) (Lambda.rename env handler) ys ls with | Not_found -> Lstaticraise (i,ls) @@ -353,9 +353,9 @@ let simplify_exits lam = simplif ~layout ~try_depth l2, r, result_layout kind) - | Ltrywith(l1, v, l2, kind) -> + | Ltrywith(l1, v, duid, l2, kind) -> let l1 = simplif ~layout ~try_depth:(try_depth + 1) l1 in - Ltrywith(l1, v, simplif ~layout ~try_depth l2, result_layout kind) + Ltrywith(l1, v, duid, simplif ~layout ~try_depth l2, result_layout kind) | Lifthenelse(l1, l2, l3, kind) -> Lifthenelse( simplif ~layout:None ~try_depth l1, @@ -400,7 +400,8 @@ let exact_application {kind; params; _} args = let beta_reduce params body args = List.fold_left2 - (fun l param arg -> Llet(Strict, param.layout, param.name, arg, l)) + (fun l (param: lparam) arg -> + Llet(Strict, param.layout, param.name, param.debug_uid, arg, l)) body params args (* Simplification of lets *) @@ -467,16 +468,16 @@ let simplify_lets lam = end | Lfunction fn -> count_lfunction fn - | Llet(_str, _k, v, Lvar w, l2) when optimize -> + | Llet(_str, _k, v, _duid, Lvar w, l2) when optimize -> (* v will be replaced by w in l2, so each occurrence of v in l2 increases w's refcount *) count (bind_var bv v) l2; use_var bv w (count_var v) - | Llet(str, _kind, v, l1, l2) -> + | Llet(str, _kind, v, _duid, l1, l2) -> count (bind_var bv v) l2; (* If v is unused, l1 will be removed, so don't count its variables *) if str = Strict || count_var v > 0 then count bv l1 - | Lmutlet(_kind, _v, l1, l2) -> + | Lmutlet(_kind, _v, _duid, l1, l2) -> count bv l1; count bv l2 | Lletrec(bindings, body) -> @@ -501,7 +502,7 @@ let simplify_lets lam = end | Lstaticraise (_i,ls) -> List.iter (count bv) ls | Lstaticcatch(l1, _, l2, Same_region, _) -> count bv l1; count bv l2 - | Ltrywith(l1, _v, l2, _kind) -> count bv l1; count bv l2 + | Ltrywith(l1, _v, _duid, l2, _kind) -> count bv l1; count bv l2 | Lifthenelse(l1, l2, l3, _kind) -> count bv l1; count bv l2; count bv l3 | Lsequence(l1, l2) -> count bv l1; count bv l2 | Lwhile {wh_cond; wh_body} -> @@ -555,16 +556,16 @@ let simplify_lets lam = (* This (small) optimisation is always legal, it may uncover some tail call later on. *) - let mklet str kind v e1 e2 = + let mklet str kind v duid e1 e2 = match e2 with | Lvar w when optimize && Ident.same v w -> e1 - | _ -> Llet (str, kind,v,e1,e2) + | _ -> Llet (str, kind,v,duid,e1,e2) in - let mkmutlet kind v e1 e2 = + let mkmutlet kind v duid e1 e2 = match e2 with | Lmutvar w when optimize && Ident.same v w -> e1 - | _ -> Lmutlet (kind,v,e1,e2) + | _ -> Lmutlet (kind,v,duid,e1,e2) in let rec simplif = function @@ -609,10 +610,10 @@ let simplify_lets lam = | kind, ret_mode, body -> lfunction ~kind ~params ~return:outer_return ~body ~attr:attr1 ~loc ~mode ~ret_mode end - | Llet(_str, _k, v, Lvar w, l2) when optimize -> + | Llet(_str, _k, v, _duid, Lvar w, l2) when optimize -> Hashtbl.add subst v (simplif (Lvar w)); simplif l2 - | Llet(Strict, kind, v, + | Llet(Strict, kind, v, duid, Lprim(Pmakeblock(0, Mutable, kind_ref, _mode) as prim, [linit], loc), lbody) when optimize -> @@ -626,23 +627,23 @@ let simplify_lets lam = | Some [field_kind] -> Pvalue field_kind | Some _ -> assert false in - mkmutlet kind v slinit (eliminate_ref v slbody) + mkmutlet kind v duid slinit (eliminate_ref v slbody) with Real_reference -> - mklet Strict kind v (Lprim(prim, [slinit], loc)) slbody + mklet Strict kind v duid (Lprim(prim, [slinit], loc)) slbody end - | Llet(Alias, kind, v, l1, l2) -> + | Llet(Alias, kind, v, duid, l1, l2) -> begin match count_var v with 0 -> simplif l2 | 1 when optimize -> Hashtbl.add subst v (simplif l1); simplif l2 - | _ -> Llet(Alias, kind, v, simplif l1, simplif l2) + | _ -> Llet(Alias, kind, v, duid, simplif l1, simplif l2) end - | Llet(StrictOpt, kind, v, l1, l2) -> + | Llet(StrictOpt, kind, v, duid, l1, l2) -> begin match count_var v with 0 -> simplif l2 - | _ -> mklet StrictOpt kind v (simplif l1) (simplif l2) + | _ -> mklet StrictOpt kind v duid (simplif l1) (simplif l2) end - | Llet(str, kind, v, l1, l2) -> mklet str kind v (simplif l1) (simplif l2) - | Lmutlet(kind, v, l1, l2) -> mkmutlet kind v (simplif l1) (simplif l2) + | Llet(str, kind, v, duid, l1, l2) -> mklet str kind v duid (simplif l1) (simplif l2) + | Lmutlet(kind, v, duid, l1, l2) -> mkmutlet kind v duid (simplif l1) (simplif l2) | Lletrec(bindings, body) -> let bindings = List.map (fun rb -> @@ -669,7 +670,7 @@ let simplify_lets lam = Lstaticraise (i, List.map simplif ls) | Lstaticcatch(l1, (i,args), l2, r, kind) -> Lstaticcatch (simplif l1, (i,args), simplif l2, r, kind) - | Ltrywith(l1, v, l2, kind) -> Ltrywith(simplif l1, v, simplif l2, kind) + | Ltrywith(l1, v, duid, l2, kind) -> Ltrywith(simplif l1, v, duid, simplif l2, kind) | Lifthenelse(l1, l2, l3, kind) -> Lifthenelse(simplif l1, simplif l2, simplif l3, kind) | Lsequence(Lifused(v, l1), l2) -> if count_var v > 0 @@ -721,8 +722,8 @@ let rec emit_tail_infos is_tail lambda = list_emit_tail_infos false ap.ap_args | Lfunction lfun -> emit_tail_infos_lfunction is_tail lfun - | Llet (_, _k, _, lam, body) - | Lmutlet (_k, _, lam, body) -> + | Llet (_, _k, _, _, lam, body) + | Lmutlet (_k, _, _, lam, body) -> emit_tail_infos false lam; emit_tail_infos is_tail body | Lletrec (bindings, body) -> @@ -755,7 +756,7 @@ let rec emit_tail_infos is_tail lambda = | Lstaticcatch (body, _, handler, _, _kind) -> emit_tail_infos is_tail body; emit_tail_infos is_tail handler - | Ltrywith (body, _, handler, _k) -> + | Ltrywith (body, _, _, handler, _k) -> emit_tail_infos false body; emit_tail_infos is_tail handler | Lifthenelse (cond, ifso, ifno, _k) -> @@ -803,7 +804,7 @@ and emit_tail_infos_lfunction _is_tail lfun = 'Some' constructor, only to deconstruct it immediately in the function's body. *) -let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body +let split_default_wrapper ~id:fun_id ~debug_uid:fun_duid ~kind ~params ~return ~body ~attr ~loc ~mode ~ret_mode = let rec aux map add_region = function (* When compiling [fun ?(x=expr) -> body], this is first translated @@ -821,7 +822,7 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body which is why we need a deep pattern matching on the expected result of the pattern-matching compiler for options. *) - | Llet(Strict, k, id, + | Llet(Strict, k, id, duid, (Lifthenelse(Lprim (Pisint _, [Lvar optparam], _), _, _, _) as def), rest) when String.starts_with (Ident.name optparam) ~prefix:"*opt*" && @@ -829,7 +830,7 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body && not (List.mem_assoc optparam map) -> let wrapper_body, inner = aux ((optparam, id) :: map) add_region rest in - Llet(Strict, k, id, def, wrapper_body), inner + Llet(Strict, k, id, duid, def, wrapper_body), inner | Lregion (rest, ret) -> let wrapper_body, inner = aux map true rest in if may_allocate_in_region wrapper_body then @@ -844,10 +845,14 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body List.iter (fun (id, _) -> if Ident.Set.mem id fv then raise Exit) map; let inner_id = Ident.create_local (Ident.name fun_id ^ "_inner") in + let inner_id_duid = Lambda.debug_uid_none in + (* CR sspies: This variable is not user visible, right? I think passing + on [fun_duid] would lead to a duplication of [debug_uid]. *) let map_param (p : Lambda.lparam) = try { name = List.assoc p.name map; + debug_uid = p.debug_uid; layout = Lambda.layout_optional_arg; attributes = Lambda.default_param_attribute; mode = p.mode @@ -887,6 +892,7 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body ~return ~body ~attr ~loc ~mode ~ret_mode in (wrapper_body, { id = inner_id; + debug_uid = inner_id_duid; def = inner_fun }) in try @@ -900,11 +906,13 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body let body, inner = aux [] false body in let attr = { default_stub_attribute with zero_alloc = attr.zero_alloc } in [{ id = fun_id; + debug_uid = fun_duid; def = lfunction' ~kind ~params ~return ~body ~attr ~loc ~mode ~ret_mode }; inner] with Exit -> [{ id = fun_id; + debug_uid = fun_duid; def = lfunction' ~kind ~params ~return ~body ~attr ~loc ~mode ~ret_mode }] @@ -969,7 +977,7 @@ let simplify_local_functions lam = | Some sco -> sco == scope in let rec tail = function - | Llet (_str, _kind, id, Lfunction lf, cont) when enabled lf.attr -> + | Llet (_str, _kind, id, _duid, Lfunction lf, cont) when enabled lf.attr -> let r = { func = lf; function_scope = !current_function_scope; @@ -1079,7 +1087,7 @@ let simplify_local_functions lam = let rec rewrite lam0 = let lam = match lam0 with - | Llet (_, _, id, _, cont) when Hashtbl.mem static_id id -> + | Llet (_, _, id, _duid, _, cont) when Hashtbl.mem static_id id -> rewrite cont | Lapply {ap_func = Lvar id; ap_args; _} when Hashtbl.mem static_id id -> let st = Hashtbl.find static_id id in @@ -1094,7 +1102,7 @@ let simplify_local_functions lam = in let new_params lf = List.map - (fun p -> (p.name, p.layout)) lf.params + (fun (p: lparam) -> (p.name, p.debug_uid, p.layout)) lf.params in List.fold_right (fun (st, lf, exclave) lam -> diff --git a/lambda/simplif.mli b/lambda/simplif.mli index 9e52c8f0ca4..fa81d340e76 100644 --- a/lambda/simplif.mli +++ b/lambda/simplif.mli @@ -31,6 +31,7 @@ val simplify_lambda: lambda -> lambda val split_default_wrapper : id:Ident.t + -> debug_uid: debug_uid -> kind:function_kind -> params:Lambda.lparam list -> return:Lambda.layout diff --git a/lambda/tmc.ml b/lambda/tmc.ml index 1fe9dfae161..13113279acf 100644 --- a/lambda/tmc.ml +++ b/lambda/tmc.ml @@ -63,8 +63,14 @@ let offset_code (Offset t) = t let add_dst_params ({var; offset} : Ident.t destination) params = { name = var ; layout = Lambda.layout_block ; + debug_uid= Lambda.debug_uid_none; + (* The destination parameters are generated internally as part of the TMC + optimization. As such, they are not user visible, and we do not associate + them with a [debug_uid]. *) + (* CR sspies: Is this comment correct? *) attributes = Lambda.default_param_attribute ; mode = alloc_heap } :: { name = offset ; layout = Lambda.layout_int ; + debug_uid= Lambda.debug_uid_none; attributes = Lambda.default_param_attribute ; mode = alloc_heap } :: params @@ -138,7 +144,9 @@ end = struct let placeholder_pos = List.length constr.before in let placeholder_pos_lam = Lconst (Const_base (Const_int placeholder_pos)) in let block_var = Ident.create_local "block" in - Llet (Strict, Lambda.layout_block, block_var, k_with_placeholder, + let block_var_duid = Lambda.debug_uid_none in + Llet (Strict, Lambda.layout_block, block_var, block_var_duid, + k_with_placeholder, body { var = block_var; offset = Offset placeholder_pos_lam ; @@ -162,14 +170,16 @@ end = struct else begin let v = Ident.create_local (Printf.sprintf "block%d_arg%d" block_id (arg_offset + i)) in - (Some (v, lam), Lvar v) + let v_duid = Lambda.debug_uid_none in + (Some (v, v_duid, lam), Lvar v) end) |> List.split in let body = k args in List.fold_right (fun binding body -> match binding with | None -> body - | Some (v, lam) -> Llet(Strict, Lambda.layout_tmc_field, v, lam, body) + | Some (v, v_duid, lam) -> + Llet(Strict, Lambda.layout_tmc_field, v, v_duid, lam, body) ) bindings body in fun ~block_id constr body -> bind_list ~block_id ~arg_offset:0 constr.before @@ fun vbefore -> @@ -557,8 +567,8 @@ and specialized = { } let llets lk vk bindings body = - List.fold_right (fun (var, def) body -> - Llet (lk, vk, var, def, body) + List.fold_right (fun (var, var_duid, def) body -> + Llet (lk, vk, var, var_duid, def, body) ) bindings body let find_candidate = function @@ -611,13 +621,13 @@ let rec choice ctx t = let l1 = traverse ctx l1 in let+ (l2, l3) = choice_pair ctx ~tail (l2, l3) in Lifthenelse (l1, l2, l3, kind) - | Lmutlet (vk, var, def, body) -> + | Lmutlet (vk, var, var_duid, def, body) -> (* mutable bindings are not TMC-specialized *) let def = traverse ctx def in let+ body = choice ctx ~tail body in - Lmutlet (vk, var, def, body) - | Llet (lk, vk, var, def, body) -> - let ctx, bindings = traverse_let ctx var def in + Lmutlet (vk, var, var_duid, def, body) + | Llet (lk, vk, var, var_duid, def, body) -> + let ctx, bindings = traverse_let ctx var var_duid def in let+ body = choice ctx ~tail body in llets lk vk bindings body | Lletrec (bindings, body) -> @@ -651,13 +661,13 @@ let rec choice ctx t = | Lstaticraise (id, ls) -> let ls = traverse_list ctx ls in Choice.lambda (Lstaticraise (id, ls)) - | Ltrywith (l1, id, l2, kind) -> + | Ltrywith (l1, id, id_duid, l2, kind) -> (* in [try l1 with id -> l2], the term [l1] is not in tail-call position (after it returns we need to remove the exception handler) *) let+ l1 = choice ctx ~tail:false l1 and+ l2 = choice ctx ~tail l2 in - Ltrywith (l1, id, l2, kind) + Ltrywith (l1, id, id_duid, l2, kind) | Lstaticcatch (l1, ids, l2, r, kind) -> (* In [static-catch l1 with ids -> l2], the term [l1] is in fact in tail-position *) @@ -994,8 +1004,8 @@ let rec choice ctx t = in choice ctx t and traverse ctx = function - | Llet (lk, vk, var, def, body) -> - let ctx, bindings = traverse_let ctx var def in + | Llet (lk, vk, var, var_duid, def, body) -> + let ctx, bindings = traverse_let ctx var var_duid def in let body = traverse ctx body in llets lk vk bindings body | Lletrec (bindings, body) -> @@ -1007,10 +1017,10 @@ and traverse ctx = function and traverse_lfunction ctx lfun = map_lfunction (traverse ctx) lfun -and traverse_let outer_ctx var def = +and traverse_let outer_ctx var var_duid def = let inner_ctx = declare_binding outer_ctx (var, def) in let bindings = - traverse_let_binding outer_ctx inner_ctx var def + traverse_let_binding outer_ctx inner_ctx var var_duid def in inner_ctx, bindings @@ -1025,22 +1035,22 @@ and traverse_letrec ctx bindings = in ctx, bindings -and traverse_let_binding outer_ctx inner_ctx var def = +and traverse_let_binding outer_ctx inner_ctx var var_duid def = match find_candidate def with - | None -> [ var, traverse outer_ctx def ] + | None -> [ var, var_duid, traverse outer_ctx def ] | Some lfun -> - let functions = make_dps_variant var inner_ctx outer_ctx lfun in - List.map (fun (var, lfun) -> var, Lfunction lfun) functions + let functions = make_dps_variant var var_duid inner_ctx outer_ctx lfun in + List.map (fun (var, var_duid, lfun) -> var, var_duid, Lfunction lfun) functions -and traverse_letrec_binding ctx { id; def } = +and traverse_letrec_binding ctx { id; debug_uid; def } = if def.attr.tmc_candidate then - let functions = make_dps_variant id ctx ctx def in - List.map (fun (id, def) -> { id; def }) functions + let functions = make_dps_variant id debug_uid ctx ctx def in + List.map (fun (id, id_duid, def) -> { id; debug_uid = id_duid; def }) functions else - [ { id; def = traverse_lfunction ctx def } ] + [ { id; debug_uid = debug_uid; def = traverse_lfunction ctx def } ] -and make_dps_variant var inner_ctx outer_ctx (lfun : lfunction) = +and make_dps_variant var var_duid inner_ctx outer_ctx (lfun : lfunction) = let special = Ident.Map.find var inner_ctx.specialized in let fun_choice = choice outer_ctx ~tail:true lfun.body in if fun_choice.Choice.tmc_calls = [] then @@ -1081,7 +1091,12 @@ and make_dps_variant var inner_ctx outer_ctx (lfun : lfunction) = ~ret_mode:lfun.ret_mode in let dps_var = special.dps_id in - [var, direct; dps_var, dps] + let dps_var_duid = Lambda.debug_uid_none in + (* The [dps_var] variable is generated internally in the TMC optimization. + Hence, we do not associate any [debug_uid] with it. *) + (* CR sspies: Is the comment above correct? *) + [var, var_duid, direct; + dps_var, dps_var_duid, dps] and traverse_list ctx terms = List.map (traverse ctx) terms diff --git a/lambda/transl_array_comprehension.ml b/lambda/transl_array_comprehension.ml index 924bd6a0f9f..bbd1e8faf2b 100644 --- a/lambda/transl_array_comprehension.ml +++ b/lambda/transl_array_comprehension.ml @@ -201,7 +201,11 @@ module Precompute_array_size : sig due to the overflow check; the optional argument [variable_name] customizes the string used to name these variables. *) val safe_product_pos : - ?variable_name:string -> loc:scoped_location -> lambda list -> lambda + ?variable_name:string -> + debug_uid:debug_uid -> + loc:scoped_location -> + lambda list -> + lambda end = struct (* Modeled after [Translcore.assert_failed] *) let raise_overflow_exn ~loc = @@ -234,7 +238,8 @@ end = struct let y = y.Let_binding.var in let open (val Lambda_utils.int_ops ~loc) in let product = - Let_binding.make (Immutable Alias) layout_int "product" (x * y) + Let_binding.make (Immutable Alias) layout_int "product" + Lambda.debug_uid_none (x * y) in (* [x * y] is safe, for strictly positive [x] and [y], iff you can undo the multiplication: [(x * y)/y = x]. We assume the inputs are values, so we @@ -259,10 +264,10 @@ end = struct (* The inputs are *not* required to be values, as we save them in variables. We could avoid making let-bindings for lambda-terms that are already variables, but we assume the optimizer can deal with that case nicely. *) - let safe_product_pos ?(variable_name = "x") ~loc factors = + let safe_product_pos ?(variable_name = "x") ~debug_uid ~loc factors = let factors = List.map - (Let_binding.make (Immutable Strict) layout_int variable_name) + (Let_binding.make (Immutable Strict) layout_int variable_name debug_uid) factors in Let_binding.let_all factors (safe_product_pos_vals ~loc factors) @@ -366,6 +371,7 @@ module Iterator_bindings = struct still might overflow *) let range_size = Let_binding.make (Immutable Alias) layout_int "range_size" + Lambda.debug_uid_none (high - low + l1) in Let_binding.let_one range_size @@ -386,7 +392,8 @@ module Iterator_bindings = struct a nonempty fixed-size array; check against [are_any_empty] first to address the case of fixedly-empty array. *) let total_size_nonempty ~loc iterators = - Precompute_array_size.safe_product_pos ~variable_name:"iterator_size" ~loc + Precompute_array_size.safe_product_pos ~variable_name:"iterator_size" + ~debug_uid:Lambda.debug_uid_none ~loc (List.map (size_nonempty ~loc) iterators) end end @@ -441,16 +448,18 @@ end let iterator ~transl_exp ~scopes ~loc : comprehension_iterator -> (lambda -> lambda) * Iterator_bindings.t = function - | Texp_comp_range { ident; pattern = _; start; stop; direction } -> - let bound name value = - Let_binding.make (Immutable Strict) layout_int name + | Texp_comp_range + { ident; ident_debug_uid; pattern = _; start; stop; direction } -> + let bound name debug_uid value = + Let_binding.make (Immutable Strict) layout_int name debug_uid (transl_exp ~scopes Jkind.Sort.Const.for_predef_value value) in - let start = bound "start" start in - let stop = bound "stop" stop in + let start = bound "start" Lambda.debug_uid_none start in + let stop = bound "stop" Lambda.debug_uid_none stop in let mk_iterator body = Lfor { for_id = ident; + for_debug_uid = ident_debug_uid; for_loc = loc; for_from = start.var; for_to = stop.var; @@ -462,6 +471,7 @@ let iterator ~transl_exp ~scopes ~loc : | Texp_comp_in { pattern; sequence = iter_arr_exp } -> let iter_arr = Let_binding.make (Immutable Strict) layout_any_value "iter_arr" + Lambda.debug_uid_none (transl_exp ~scopes Jkind.Sort.Const.for_predef_value iter_arr_exp) in let iter_arr_kind = @@ -478,15 +488,18 @@ let iterator ~transl_exp ~scopes ~loc : (* Extra let-binding if we're not in the fixed-size array case; the middle-end will simplify this for us *) Let_binding.make (Immutable Alias) layout_int "iter_len" + Lambda.debug_uid_none (Lprim (Parraylength iter_arr_kind, [iter_arr.var], loc)) in let iter_ix = Ident.create_local "iter_ix" in + let iter_ix_duid = Lambda.debug_uid_none in let mk_iterator body = let open (val Lambda_utils.int_ops ~loc) in (* for iter_ix = 0 to Array.length iter_arr - 1 ... *) (* CR layouts v4: will need updating when we allow non-values in arrays. *) Lfor { for_id = iter_ix; + for_debug_uid = iter_ix_duid; for_loc = loc; for_from = l0; for_to = iter_len.var - l1; @@ -627,6 +640,7 @@ let clauses ~transl_exp ~scopes ~loc = function in let array_size = Let_binding.make (Immutable Alias) layout_int "array_size" + Lambda.debug_uid_none (Iterator_bindings.Fixed_size_array.total_size_nonempty ~loc var_bindings) in @@ -636,7 +650,7 @@ let clauses ~transl_exp ~scopes ~loc = function } | clauses -> let array_size = - Let_binding.make Mutable layout_int "array_size" + Let_binding.make Mutable layout_int "array_size" Lambda.debug_uid_none (int Resizable_array.starting_size) in let make_comprehension = @@ -735,7 +749,8 @@ let initial_array ~loc ~array_kind ~array_size ~array_sizing = Misc.fatal_error "Transl_array_comprehension.initial_array: unboxed product array" in - Let_binding.make array_let_kind layout_any_value "array" array_value + Let_binding.make array_let_kind layout_any_value "array" Lambda.debug_uid_none + array_value (** Generate the code for the body of an array comprehension. This involves translating the body expression (a [Typedtree.expression], which is the @@ -805,7 +820,8 @@ let body ~loc ~array_kind ~array_size ~array_sizing ~array ~index ~body = | Pgenarray -> let is_first_iteration = index.var = l0 in let elt = - Let_binding.make (Immutable Strict) layout_any_value "elt" body + Let_binding.make (Immutable Strict) layout_any_value "elt" + Lambda.debug_uid_none body in let make_array = match array_sizing with @@ -856,7 +872,9 @@ let comprehension ~transl_exp ~scopes ~loc ~(array_kind : Lambda.array_kind) | Dynamic_size_info -> Dynamic_size in let array = initial_array ~loc ~array_kind ~array_size ~array_sizing in - let index = Let_binding.make Mutable layout_int "index" (int 0) in + let index = + Let_binding.make Mutable layout_int "index" Lambda.debug_uid_none (int 0) + in (* The core of the comprehension: the array, the index, and the iteration that fills everything in. The translation of the clauses will produce a check to see if we can avoid doing the hard work of growing the array, which is diff --git a/lambda/transl_comprehension_utils.ml b/lambda/transl_comprehension_utils.ml index b405b3ab70d..702efc9ff66 100644 --- a/lambda/transl_comprehension_utils.ml +++ b/lambda/transl_comprehension_utils.ml @@ -11,21 +11,29 @@ module Let_binding = struct { let_kind : Let_kind.t; layout : layout; id : Ident.t; + debug_uid : debug_uid; init : lambda; var : lambda } - let make (let_kind : Let_kind.t) layout name init = + (* CR sspies: The [debug_uid] is Lambda.debug_uid_none at all call sites. + It appears we only use this function for internal variables. (The + definition does not really currently suggest that.) As an alternative, + we could remove the debug_uid from the record [t] and always choose + [Lambda.debug_uid_none] in the [let_one] function. In that case, it might + be worth renaming the function to suggest that this is only used for + internal variables. *) + let make (let_kind : Let_kind.t) layout name debug_uid init = let id = Ident.create_local name in let var = match let_kind with Mutable -> Lmutvar id | Immutable _ -> Lvar id in - { let_kind; layout; id; init; var } + { let_kind; layout; id; debug_uid; init; var } - let let_one { let_kind; layout; id; init } body = + let let_one { let_kind; layout; id; debug_uid; init } body = match let_kind with - | Immutable let_kind -> Llet (let_kind, layout, id, init, body) - | Mutable -> Lmutlet (layout, id, init, body) + | Immutable let_kind -> Llet (let_kind, layout, id, debug_uid, init, body) + | Mutable -> Lmutlet (layout, id, debug_uid, init, body) let let_all = List.fold_right let_one end diff --git a/lambda/transl_comprehension_utils.mli b/lambda/transl_comprehension_utils.mli index 79ff0afab01..d5caeff3a65 100644 --- a/lambda/transl_comprehension_utils.mli +++ b/lambda/transl_comprehension_utils.mli @@ -28,13 +28,14 @@ module Let_binding : sig { let_kind : Let_kind.t; layout : layout; id : Ident.t; + debug_uid : debug_uid; init : lambda; (* initial value *) var : lambda (* occurrence of this variable *) } (** Create a fresh local identifier (with name as given by the string argument) to bind to an initial value given by the lambda argument. *) - val make : Let_kind.t -> layout -> string -> lambda -> t + val make : Let_kind.t -> layout -> string -> debug_uid -> lambda -> t (** Create a Lambda let-binding (with [Llet]) from a first-class let binding, providing the body. *) diff --git a/lambda/transl_list_comprehension.ml b/lambda/transl_list_comprehension.ml index b5989eb6092..7b2593f4898 100644 --- a/lambda/transl_list_comprehension.ml +++ b/lambda/transl_list_comprehension.ml @@ -149,6 +149,8 @@ type translated_iterator = (** The name given to the values we're iterating over; needs to be a fresh name for [for]-[in] iterators in case the user specifies a complex pattern. *) + element_debug_uid : Lambda.debug_uid; + (** The [debug_uid] of the element identifier. *) element_kind : layout; (** The [layout] of the values we're iterating over. *) add_bindings : lambda -> lambda @@ -164,34 +166,40 @@ type translated_iterator = containing the body of the iteration; that body function can't be filled in until the rest of the translations have been done. *) let iterator ~transl_exp ~scopes = function - | Texp_comp_range { ident; pattern = _; start; stop; direction } -> + | Texp_comp_range + { ident; ident_debug_uid; pattern = _; start; stop; direction } -> (* We have to let-bind [start] and [stop] so that they're evaluated in the correct (i.e., left-to-right) order *) - let transl_bound var bound = - Let_binding.make (Immutable Strict) layout_int var + let transl_bound var debug_uid bound = + Let_binding.make (Immutable Strict) layout_int var debug_uid (transl_exp ~scopes Jkind.Sort.Const.for_predef_value bound) in - let start = transl_bound "start" start in - let stop = transl_bound "stop" stop in + let start = transl_bound "start" Lambda.debug_uid_none start in + let stop = transl_bound "stop" Lambda.debug_uid_none stop in { builder = (match direction with | Upto -> rev_dlist_concat_iterate_up | Downto -> rev_dlist_concat_iterate_down); arg_lets = [start; stop]; element = ident; + element_debug_uid = ident_debug_uid; element_kind = layout_int; add_bindings = Fun.id } | Texp_comp_in { pattern; sequence } -> let iter_list = Let_binding.make (Immutable Strict) layout_any_value "iter_list" + Lambda.debug_uid_none (transl_exp ~scopes Jkind.Sort.Const.for_predef_value sequence) in - (* Create a fresh variable to use as the function argument *) + (* Create a fresh variable to use as the function argument. The debug uid is + [ident_debug_uid], because the variable is not visible to users. *) let element = Ident.create_local "element" in + let element_debug_uid = Lambda.debug_uid_none in { builder = rev_dlist_concat_map; arg_lets = [iter_list]; element; + element_debug_uid; element_kind = Typeopt.layout pattern.pat_env pattern.pat_loc Jkind.Sort.Const.for_list_element pattern.pat_type; @@ -226,10 +234,17 @@ let binding ~transl_exp ~scopes { comp_cb_iterator; comp_cb_attributes = _ } = let rec translate_bindings ~transl_exp ~scopes ~loc ~inner_body ~accumulator = function | cur_binding :: bindings -> - let { builder; arg_lets; element; element_kind; add_bindings } = + let { builder; + arg_lets; + element; + element_debug_uid; + element_kind; + add_bindings + } = binding ~transl_exp ~scopes cur_binding in let inner_acc = Ident.create_local "accumulator" in + let inner_acc_duid = Lambda.debug_uid_none in let body_arg_lets, body = translate_bindings ~transl_exp ~scopes ~loc ~inner_body ~accumulator:(Lvar inner_acc) bindings @@ -241,12 +256,14 @@ let rec translate_bindings ~transl_exp ~scopes ~loc ~inner_body ~accumulator = local, [nlocal] has to be equal to the number of parameters *) ~params: [ { name = element; + debug_uid = element_debug_uid; layout = element_kind; attributes = Lambda.default_param_attribute; (* CR ncourant: check *) mode = alloc_heap }; { name = inner_acc; + debug_uid = inner_acc_duid; layout = layout_any_value; attributes = Lambda.default_param_attribute; mode = alloc_local diff --git a/lambda/translclass.ml b/lambda/translclass.ml index b47993f0864..1098c407e68 100644 --- a/lambda/translclass.ml +++ b/lambda/translclass.ml @@ -67,8 +67,8 @@ let lapply ap = | _ -> Lapply ap -let lparam name layout : Lambda.lparam = - { name; layout; +let lparam name debug_uid layout : Lambda.lparam = + { name; debug_uid; layout; attributes = Lambda.default_param_attribute; mode = alloc_heap } let mkappl (func, args, layout) = @@ -114,7 +114,8 @@ let transl_val tbl create name = let transl_vals tbl create strict vals rem = List.fold_right (fun (name, id) rem -> - Llet(strict, layout_int, id, transl_val tbl create name, rem)) + Llet(strict, layout_int, id, Lambda.debug_uid_none, + transl_val tbl create name, rem)) vals rem let meths_super tbl meths inh_meths = @@ -130,11 +131,12 @@ let meths_super tbl meths inh_meths = let bind_super tbl (vals, meths) cl_init = transl_vals tbl false StrictOpt vals (List.fold_right (fun (_nm, id, def) rem -> - Llet(StrictOpt, layout_meth, id, def, rem)) + Llet(StrictOpt, layout_meth, id, Lambda.debug_uid_none, def, rem)) meths cl_init) let create_object cl obj init = let obj' = Ident.create_local "self" in + let obj'_duid = Lambda.debug_uid_none in let (inh_init, obj_init, has_init) = init obj' in if obj_init = lambda_unit then (inh_init, @@ -143,7 +145,7 @@ let create_object cl obj init = [obj; Lvar cl], layout_obj)) else begin (inh_init, - Llet(Strict, layout_obj, obj', + Llet(Strict, layout_obj, obj', obj'_duid, mkappl (oo_prim "create_object_opt", [obj; Lvar cl], layout_obj), Lsequence(obj_init, if not has_init then Lvar obj' else @@ -211,6 +213,7 @@ let rec build_object_init ~scopes cl_table obj params inh_init obj_init cl = (inh_init, let build params rem = let param = name_pattern "param" pat in + let param_duid = Lambda.debug_uid_none in let arg_sort = Jkind.Sort.Const.for_class_arg in let arg_layout = Typeopt.layout pat.pat_env pat.pat_loc arg_sort pat.pat_type @@ -222,7 +225,7 @@ let rec build_object_init ~scopes cl_table obj params inh_init obj_init cl = in Lambda.lfunction ~kind:(Curried {nlocal=0}) - ~params:(lparam param arg_layout::params) + ~params:(lparam param param_duid arg_layout::params) ~return:layout_obj ~attr:default_function_attribute ~loc:(of_location ~scopes pat.pat_loc) @@ -260,19 +263,27 @@ let rec build_object_init_0 ~scopes cl_table (vals@params) cl copy_env subst_env top ids | _ -> let self = Ident.create_local "self" in + let self_duid = Lambda.debug_uid_none in let env = Ident.create_local "env" in + let env_duid = Lambda.debug_uid_none in let obj = if ids = [] then lambda_unit else Lvar self in let envs = if top then None else Some env in let ((_,inh_init), obj_init) = build_object_init ~scopes cl_table obj params (envs,[]) copy_env cl in let obj_init = - if ids = [] then obj_init else lfunction layout_obj [lparam self layout_obj] obj_init in + if ids = [] + then obj_init + else lfunction layout_obj [lparam self self_duid layout_obj] obj_init + in (inh_init, lfunction (if ids = [] then layout_obj else layout_function) - [lparam env layout_block] (subst_env env inh_init obj_init)) + [lparam env env_duid layout_block] (subst_env env inh_init obj_init)) let bind_method tbl lab id cl_init = - Llet(Strict, layout_label, id, mkappl (oo_prim "get_method_label", + (* CR sspies: We could probably do a better job with uids here. Not sure it + is worth it, though. *) + Llet(Strict, layout_label, id, Lambda.debug_uid_none, + mkappl (oo_prim "get_method_label", [Lvar tbl; transl_label lab], layout_label), cl_init) @@ -282,17 +293,22 @@ let bind_methods tbl meths vals cl_init = if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else if len = 0 && nvals < 2 then transl_vals tbl true Strict vals cl_init else let ids = Ident.create_local "ids" in + let ids_duid = Lambda.debug_uid_none in let i = ref (len + nvals) in let getter, names = if nvals = 0 then "get_method_labels", [] else - "new_methods_variables", [transl_meth_list (List.map fst vals)] + "new_methods_variables", + [transl_meth_list (List.map fst vals)] in - Llet(Strict, layout_label_array, ids, + Llet(Strict, layout_label_array, ids, ids_duid, mkappl (oo_prim getter, - [Lvar tbl; transl_meth_list (List.map fst methl)] @ names, + [Lvar tbl; + transl_meth_list (List.map fst methl)] @ names, layout_label_array), List.fold_right - (fun (_lab,id) lam -> decr i; Llet(StrictOpt, layout_label, id, + (* CR sspies: Could we do a better job with debug uids here? *) + (fun (_lab, id) lam -> decr i; Llet(StrictOpt, layout_label, id, + Lambda.debug_uid_none, lfield ids !i, lam)) (methl @ vals) cl_init) @@ -331,7 +347,7 @@ let rec build_class_init ~scopes cla cstr super inh_init cl_init msubst top cl = begin match inh_init with | (_, path_lam, obj_init)::inh_init -> (inh_init, - Llet (Strict, layout_t, obj_init, + Llet (Strict, layout_t, obj_init, Lambda.debug_uid_none, mkappl(Lprim(class_field 1, [path_lam], Loc_unknown), (Lvar cla :: if top then [Lprim(class_field 3, [path_lam], Loc_unknown)] else []), layout_t), @@ -370,7 +386,8 @@ let rec build_class_init ~scopes cla cstr super inh_init cl_init msubst top cl = if !Clflags.native_code && List.length met_code = 1 then (* Force correct naming of method for profiles *) let met = Ident.create_local ("method_" ^ name.txt) in - [Llet(Strict, layout_meth, met, List.hd met_code, Lvar met)] + [Llet(Strict, layout_meth, met, Lambda.debug_uid_none, + List.hd met_code, Lvar met)] else met_code in (inh_init, cl_init, @@ -420,28 +437,30 @@ let rec build_class_init ~scopes cla cstr super inh_init cl_init msubst top cl = | Tcl_ident (path, _, _), (path', path_lam, obj_init)::inh_init -> assert (Path.same path path'); let inh = Ident.create_local "inh" + and inh_duid = Lambda.debug_uid_none and ofs = List.length vals + 1 and valids, methids = super in let cl_init = List.fold_left (fun init (nm, id, _) -> - Llet(StrictOpt, layout_meth, id, + Llet(StrictOpt, layout_meth, id, Lambda.debug_uid_none, lfield inh (index nm concr_meths + ofs), init)) cl_init methids in let cl_init = List.fold_left (fun init (nm, id) -> - Llet(StrictOpt, layout_meth, id, + Llet(StrictOpt, layout_meth, id, Lambda.debug_uid_none, lfield inh (index nm vals + 1), init)) cl_init valids in (inh_init, - Llet (Strict, layout_array Pgenarray, inh, + Llet (Strict, layout_array Pgenarray, inh, inh_duid, mkappl(oo_prim "inherits", narrow_args @ [path_lam; Lconst(const_int (if top then 1 else 0))], layout_array Pgenarray), - Llet(StrictOpt, layout_t, obj_init, lfield inh 0, cl_init))) + Llet(StrictOpt, layout_t, obj_init, Lambda.debug_uid_none, + lfield inh 0, cl_init))) | _ -> let core cl_init = build_class_init @@ -500,6 +519,7 @@ let rec transl_class_rebind ~scopes obj_init cl vf = transl_class_rebind ~scopes obj_init cl vf in let build params rem = let param = name_pattern "param" pat in + let param_duid = Lambda.debug_uid_none in let arg_sort = Jkind.Sort.Const.for_class_arg in let arg_layout = Typeopt.layout pat.pat_env pat.pat_loc arg_sort pat.pat_type @@ -511,7 +531,7 @@ let rec transl_class_rebind ~scopes obj_init cl vf = in Lambda.lfunction ~kind:(Curried {nlocal=0}) - ~params:(lparam param arg_layout :: params) + ~params:(lparam param param_duid arg_layout :: params) ~return:return_layout ~attr:default_function_attribute ~loc:(of_location ~scopes pat.pat_loc) @@ -549,11 +569,11 @@ let rec transl_class_rebind ~scopes obj_init cl vf = | Tcl_open (_, cl) -> transl_class_rebind ~scopes obj_init cl vf -let rec transl_class_rebind_0 ~scopes (self:Ident.t) obj_init cl vf = +let rec transl_class_rebind_0 ~scopes (self:Ident.t) self_debug_uid obj_init cl vf = match cl.cl_desc with Tcl_let (rec_flag, defs, _vals, cl) -> let path, path_lam, obj_init = - transl_class_rebind_0 ~scopes self obj_init cl vf + transl_class_rebind_0 ~scopes self self_debug_uid obj_init cl vf in (path, path_lam, Translcore.transl_let ~scopes ~return_layout:layout_obj rec_flag defs @@ -561,12 +581,14 @@ let rec transl_class_rebind_0 ~scopes (self:Ident.t) obj_init cl vf = | _ -> let path, path_lam, obj_init = transl_class_rebind ~scopes obj_init cl vf in - (path, path_lam, lfunction layout_obj [lparam self layout_obj] obj_init) + (path, path_lam, lfunction layout_obj [lparam self self_debug_uid layout_obj] obj_init) let transl_class_rebind ~scopes cl vf = try let obj_init = Ident.create_local "obj_init" - and self = Ident.create_local "self" in + and obj_init_duid = Lambda.debug_uid_none + and self = Ident.create_local "self" + and self_debug_uid = Lambda.debug_uid_none in let obj_init0 = lapply { ap_loc=Loc_unknown; @@ -582,25 +604,31 @@ let transl_class_rebind ~scopes cl vf = } in let _, path_lam, obj_init' = - transl_class_rebind_0 ~scopes self obj_init0 cl vf in - let id = (obj_init' = lfunction layout_obj [lparam self layout_obj] obj_init0) in + transl_class_rebind_0 ~scopes self self_debug_uid obj_init0 cl vf in + let id = (obj_init' = lfunction layout_obj [lparam self self_debug_uid layout_obj] obj_init0) in if id then path_lam else let cla = Ident.create_local "class" + and cla_duid = Lambda.debug_uid_none and new_init = Ident.create_local "new_init" + and new_init_duid = Lambda.debug_uid_none and env_init = Ident.create_local "env_init" + and env_init_duid = Lambda.debug_uid_none and table = Ident.create_local "table" - and envs = Ident.create_local "envs" in + and table_duid = Lambda.debug_uid_none + and envs = Ident.create_local "envs" + and envs_duid = Lambda.debug_uid_none in Llet( - Strict, layout_function, new_init, lfunction layout_function [lparam obj_init layout_function] obj_init', + Strict, layout_function, new_init, new_init_duid, lfunction layout_function + [lparam obj_init obj_init_duid layout_function] obj_init', Llet( - Alias, layout_block, cla, path_lam, + Alias, layout_block, cla, cla_duid, path_lam, Lprim(Pmakeblock(0, Immutable, None, alloc_heap), [mkappl(Lvar new_init, [lfield cla 0], layout_function); - lfunction layout_function [lparam table layout_table] - (Llet(Strict, layout_function, env_init, + lfunction layout_function [lparam table table_duid layout_table] + (Llet(Strict, layout_function, env_init, env_init_duid, mkappl(lfield cla 1, [Lvar table], layout_function), - lfunction layout_function [lparam envs layout_block] + lfunction layout_function [lparam envs envs_duid layout_block] (mkappl(Lvar new_init, [mkappl(Lvar env_init, [Lvar envs], layout_obj)], layout_function)))); lfield cla 2; @@ -633,7 +661,7 @@ let rec builtin_meths self env env2 body = | _ -> raise Not_found in match body with - | Llet(_str, _k, s', Lvar s, body) when List.mem s self -> + | Llet(_str, _k, s', _duid, Lvar s, body) when List.mem s self -> builtin_meths (s'::self) env env2 body | Lapply{ap_func = f; ap_args = [arg]} when const_path f -> let s, args = conv arg in ("app_"^s, f :: args) @@ -659,7 +687,7 @@ let rec builtin_meths self env env2 body = | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'], _) when Ident.same x x' && List.mem s self -> ("set_var", [Lvar n]) - | Llet(_str, _k, s', Lvar s, body) when List.mem s self -> + | Llet(_str, _k, s', _duid, Lvar s, body) when List.mem s self -> enter (s'::self) body | _ -> raise Not_found in enter self body @@ -738,14 +766,14 @@ let free_methods l = | Lsend _ -> () | Lfunction{params} -> List.iter (fun p -> fv := Ident.Set.remove p.name !fv) params - | Llet(_, _k, id, _arg, _body) - | Lmutlet(_k, id, _arg, _body) -> + | Llet(_, _k, id, _duid, _arg, _body) + | Lmutlet(_k, id, _duid, _arg, _body) -> fv := Ident.Set.remove id !fv | Lletrec(decl, _body) -> List.iter (fun { id } -> fv := Ident.Set.remove id !fv) decl | Lstaticcatch(_e1, (_,vars), _e2, _, _kind) -> - List.iter (fun (id, _) -> fv := Ident.Set.remove id !fv) vars - | Ltrywith(_e1, exn, _e2, _k) -> + List.iter (fun (id, _, _) -> fv := Ident.Set.remove id !fv) vars + | Ltrywith(_e1, exn, _duid, _e2, _k) -> fv := Ident.Set.remove exn !fv | Lfor {for_id} -> fv := Ident.Set.remove for_id !fv @@ -769,7 +797,8 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = let top = not req in let cl_env, llets = build_class_lets ~scopes cl in let new_ids = if top then [] else Env.diff top_env cl_env in - let env2 = Ident.create_local "env" in + let env2 = Ident.create_local "env" + and env2_duid = Lambda.debug_uid_none in let meth_ids = get_class_meths cl in let subst env lam i0 new_ids' = let fv = free_variables lam in @@ -799,6 +828,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = Lfunction {kind = Curried _ as kind; ret_mode; params = self :: args; return; body} -> let env = Ident.create_local "env" in + let env_duid = Lambda.debug_uid_none in let body' = if new_ids = [] then body else Lambda.subst no_env_update (subst env body 0 new_ids_meths) body in @@ -810,7 +840,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = with Not_found -> [lfunction ~kind ~ret_mode return (self :: args) (if not (Ident.Set.mem env (free_variables body')) then body' else - Llet(Alias, layout_block, env, + Llet(Alias, layout_block, env, env_duid, Lprim(Pfield_computed Reads_vary, [Lvar self.name; Lvar env2], Loc_unknown), @@ -819,7 +849,10 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = | _ -> assert false in let new_ids_init = ref [] in - let env1 = Ident.create_local "env" and env1' = Ident.create_local "env'" in + let env1 = Ident.create_local "env" + and env1_duid = Lambda.debug_uid_none + and env1' = Ident.create_local "env'" + and env1'_duid = Lambda.debug_uid_none in let copy_env self = if top then lambda_unit else Lifused(env2, Lprim(Psetfield_computed (Pointer, Assignment modify_heap), @@ -829,14 +862,16 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = if top then lam else (* must be called only once! *) let lam = Lambda.subst no_env_update (subst env1 lam 1 new_ids_init) lam in - Llet(Alias, layout_block, env1, (if l = [] then Lvar envs else lfield envs 0), - Llet(Alias, layout_block, env1', + Llet(Alias, layout_block, env1, env1_duid, + (if l = [] then Lvar envs else lfield envs 0), + Llet(Alias, layout_block, env1', env1'_duid, (if !new_ids_init = [] then Lvar env1 else lfield env1 0), lam)) in (* Now we start compiling the class *) let cla = Ident.create_local "class" in + let cla_duid = Lambda.debug_uid_none in let (inh_init, obj_init) = build_object_init_0 ~scopes cla [] cl copy_env subst_env top ids in let inh_init' = List.rev inh_init in @@ -845,9 +880,13 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = in assert (inh_init' = []); let table = Ident.create_local "table" + and table_duid = Lambda.debug_uid_none and class_init = Ident.create_local (Ident.name cl_id ^ "_init") + and class_init_duid = Lambda.debug_uid_none and env_init = Ident.create_local "env_init" - and obj_init = Ident.create_local "obj_init" in + and env_init_duid = Lambda.debug_uid_none + and obj_init = Ident.create_local "obj_init" + and obj_init_duid = Lambda.debug_uid_none in let pub_meths = List.sort (fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s')) @@ -860,11 +899,11 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = if name' <> name then raise(Error(cl.cl_loc, Tags(name, name')))) tags pub_meths; let ltable table lam = - Llet(Strict, layout_table, table, + Llet(Strict, layout_table, table, table_duid, mkappl (oo_prim "create_table", [transl_meth_list pub_meths], layout_table), lam) and ldirect obj_init = - Llet(Strict, layout_function, obj_init, cl_init, + Llet(Strict, layout_function, obj_init, obj_init_duid, cl_init, Lsequence(mkappl (oo_prim "init_class", [Lvar cla], layout_unit), mkappl (Lvar obj_init, [lambda_unit], layout_function))) in @@ -882,12 +921,12 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = ~return:layout_function ~mode:alloc_heap ~ret_mode:alloc_heap - ~params:[lparam cla layout_table] + ~params:[lparam cla cla_duid layout_table] ~body:cl_init, Dynamic (* Placeholder, real kind is computed in [lbody] below *)) in let lam, rkind = mk_lam_and_kind (free_variables cl_init) in - Llet(Strict, layout_function, class_init, cl_init, lam), rkind + Llet(Strict, layout_function, class_init, class_init_duid, cl_init, lam), rkind and lbody fv = if List.for_all (fun id -> not (Ident.Set.mem id fv)) ids then mkappl (oo_prim "make_class",[transl_meth_list pub_meths; @@ -896,7 +935,8 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = else ltable table ( Llet( - Strict, layout_function, env_init, mkappl (Lvar class_init, [Lvar table], layout_function), + Strict, layout_function, env_init, env_init_duid, + mkappl (Lvar class_init, [Lvar table], layout_function), Lsequence( mkappl (oo_prim "init_class", [Lvar table], layout_unit), Lprim(Pmakeblock(0, Immutable, None, alloc_heap), @@ -913,7 +953,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = ~return:layout_function ~mode:alloc_heap ~ret_mode:alloc_heap - ~params:[lparam cla layout_table] ~body:cl_init; + ~params:[lparam cla cla_duid layout_table] ~body:cl_init; lambda_unit; lenvs], Loc_unknown), Static @@ -924,7 +964,9 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = (* Now for the hard stuff: prepare for table caching *) let envs = Ident.create_local "envs" - and cached = Ident.create_local "cached" in + and envs_duid = Lambda.debug_uid_none + and cached = Ident.create_local "cached" + and cached_duid = Lambda.debug_uid_none in let lenvs = if !new_ids_meths = [] && !new_ids_init = [] && inh_init = [] then lambda_unit @@ -945,14 +987,14 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = (List.rev inh_init) in let make_envs (lam, rkind) = - Llet(StrictOpt, layout_block, envs, + Llet(StrictOpt, layout_block, envs, envs_duid, (if linh_envs = [] then lenv else Lprim(Pmakeblock(0, Immutable, None, alloc_heap), lenv :: linh_envs, Loc_unknown)), lam), rkind and def_ids cla lam = - Llet(StrictOpt, layout_int, env2, + Llet(StrictOpt, layout_int, env2, env2_duid, mkappl (oo_prim "new_variable", [Lvar cla; transl_label ""], layout_int), lam) in @@ -967,9 +1009,10 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = inh_paths in let lclass lam = - Llet(Strict, layout_function, class_init, + Llet(Strict, layout_function, class_init, class_init_duid, Lambda.lfunction - ~kind:(Curried {nlocal=0}) ~params:[lparam cla layout_table] + ~kind:(Curried {nlocal=0}) + ~params:[lparam cla cla_duid layout_table] ~return:layout_function ~attr:default_function_attribute ~loc:Loc_unknown @@ -982,7 +1025,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = in let ldirect () = ltable cla - (Llet(Strict, layout_function, env_init, def_ids cla cl_init, + (Llet(Strict, layout_function, env_init, env_init_duid, def_ids cla cl_init, Lsequence(mkappl (oo_prim "init_class", [Lvar cla], layout_unit), lset cached 0 (Lvar env_init)))) and lclass_virt () = @@ -994,7 +1037,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = ~mode:alloc_heap ~ret_mode:alloc_heap ~return:layout_function - ~params:[lparam cla layout_table] + ~params:[lparam cla cla_duid layout_table] ~body:(def_ids cla cl_init)) in let lupdate_cache = @@ -1015,9 +1058,9 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = let lam = Lsequence (lcheck_cache, lam) in let lam = if inh_keys = [] - then Llet(Alias, layout_tables, cached, Lvar tables, lam) + then Llet(Alias, layout_tables, cached, cached_duid, Lvar tables, lam) else - Llet(Strict, layout_tables, cached, + Llet(Strict, layout_tables, cached, cached_duid, mkappl (oo_prim "lookup_tables", [Lvar tables; Lprim(Pmakearray(Paddrarray, Immutable, alloc_heap), inh_keys, Loc_unknown)], layout_tables), diff --git a/lambda/translcore.ml b/lambda/translcore.ml index 00cdb6ffa4a..5151b666561 100644 --- a/lambda/translcore.ml +++ b/lambda/translcore.ml @@ -77,8 +77,8 @@ let transl_object = let probe_handlers = ref [] let clear_probe_handlers () = probe_handlers := [] let declare_probe_handlers lam = - List.fold_left (fun acc (funcid, func) -> - Llet(Strict, Lambda.layout_function, funcid, func, acc)) + List.fold_left (fun acc (funcid, func_duid, func) -> + Llet(Strict, Lambda.layout_function, funcid, func_duid, func, acc)) lam !probe_handlers @@ -475,9 +475,9 @@ and transl_exp0 ~in_new_scope ~scopes sort e = transl_match ~scopes ~arg_sort ~return_sort:sort e arg pat_expr_list partial | Texp_try(body, pat_expr_list) -> - let id = Typecore.name_cases "exn" pat_expr_list in + let id, id_duid = Typecore.name_cases "exn" pat_expr_list in let return_layout = layout_exp sort e in - Ltrywith(transl_exp ~scopes sort body, id, + Ltrywith(transl_exp ~scopes sort body, id, id_duid, Matching.for_trywith ~scopes ~return_layout e.exp_loc (Lvar id) (transl_cases_try ~scopes sort pat_expr_list), return_layout) @@ -884,12 +884,14 @@ and transl_exp0 ~in_new_scope ~scopes sort e = wh_body = event_before ~scopes wh_body (maybe_region_layout layout_unit body); } - | Texp_for {for_id; for_from; for_to; for_dir; for_body; for_body_sort} -> + | Texp_for {for_id; for_debug_uid; for_from; for_to; for_dir; for_body; + for_body_sort} -> let for_body_sort = Jkind.Sort.default_for_transl_and_get for_body_sort in sort_must_not_be_void for_body.exp_loc for_body.exp_type for_body_sort; let body = transl_exp ~scopes for_body_sort for_body in Lfor { for_id; + for_debug_uid; for_loc = of_location ~scopes e.exp_loc; for_from = transl_exp ~scopes Jkind.Sort.Const.for_predef_value for_from; for_to = transl_exp ~scopes Jkind.Sort.Const.for_predef_value for_to; @@ -957,7 +959,8 @@ and transl_exp0 ~in_new_scope ~scopes sort e = let loc = of_location ~scopes e.exp_loc in let self = transl_value_path loc e.exp_env path_self in let cpy = Ident.create_local "copy" in - Llet(Strict, Lambda.layout_object, cpy, + let cpy_duid = Lambda.debug_uid_none in + Llet(Strict, Lambda.layout_object, cpy, cpy_duid, Lapply{ ap_loc=Loc_unknown; ap_func=Translobj.oo_prim "copy"; @@ -985,13 +988,16 @@ and transl_exp0 ~in_new_scope ~scopes sort e = let mod_scopes = enter_module_definition ~scopes id in !transl_module ~scopes:mod_scopes Tcoerce_none None modl in - Llet(Strict, Lambda.layout_module, id, defining_expr, - transl_exp ~scopes sort body) + (* CR sspies: Consider adding a [debug_uid]. *) + Llet(Strict, Lambda.layout_module, id, Lambda.debug_uid_none, + defining_expr, transl_exp ~scopes sort body) | Texp_letmodule(_, _, Mp_absent, _, body) -> transl_exp ~scopes sort body | Texp_letexception(cd, body) -> Llet(Strict, Lambda.layout_block, - cd.ext_id, transl_extension_constructor ~scopes e.exp_env None cd, + (* CR sspies: Consider adding a [debug_uid]. *) + cd.ext_id, Lambda.debug_uid_none, + transl_extension_constructor ~scopes e.exp_env None cd, transl_exp ~scopes sort body) | Texp_pack modl -> !transl_module ~scopes Tcoerce_none None modl @@ -1041,6 +1047,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e = let scopes = enter_lazy ~scopes in let fn = lfunction ~kind:(Curried {nlocal=0}) ~params:[{ name = Ident.create_local "param"; + debug_uid = Lambda.debug_uid_none; layout = Lambda.layout_unit; attributes = Lambda.default_param_attribute; mode = alloc_heap}] @@ -1070,11 +1077,12 @@ and transl_exp0 ~in_new_scope ~scopes sort e = cl_env = e.exp_env; cl_attributes = []; } - | Texp_letop{let_; ands; param; param_sort; body; body_sort; partial} -> + | Texp_letop{let_; ands; param; param_debug_uid; param_sort; body; body_sort; + partial} -> let body_sort = Jkind.Sort.default_for_transl_and_get body_sort in event_after ~scopes e (transl_letop ~scopes e.exp_loc e.exp_env let_ ands - param param_sort body body_sort partial) + param param_debug_uid param_sort body body_sort partial) | Texp_unreachable -> raise (Error (e.exp_loc, Unreachable_reached)) | Texp_open (od, e) -> @@ -1087,19 +1095,21 @@ and transl_exp0 ~in_new_scope ~scopes sort e = | [] when pure = Alias -> transl_exp ~scopes sort e | _ -> let oid = Ident.create_local "open" in + let oid_duid = Lambda.debug_uid_none in let body, _ = (* CR layouts v5: Currently we only allow values at the top of a module. When that changes, some adjustments may be needed here. *) List.fold_left (fun (body, pos) id -> Llet(Alias, Lambda.layout_module_field, id, + Lambda.debug_uid_none, Lprim(mod_field pos, [Lvar oid], of_location ~scopes od.open_loc), body), pos + 1 ) (transl_exp ~scopes sort e, 0) (bound_value_identifiers od.open_bound_items) in - Llet(pure, Lambda.layout_module, oid, + Llet(pure, Lambda.layout_module, oid, oid_duid, !transl_module ~scopes Tcoerce_none None od.open_expr, body) end | Texp_probe {name; handler=exp; enabled_at_init} -> @@ -1157,6 +1167,8 @@ and transl_exp0 ~in_new_scope ~scopes sort e = ) arg_idents; let make_param name = { name; + debug_uid = Lambda.debug_uid_none; + (* For probes, we currently do not track [debug_uid] values. *) layout = layout_probe_arg; attributes = Lambda.default_param_attribute; mode = alloc_local } @@ -1186,6 +1198,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e = may_fuse_arity = false; } in let funcid = Ident.create_local ("probe_handler_" ^ name) in + let funcid_duid = Lambda.debug_uid_none in let return_layout = layout_unit (* Probe bodies have type unit. *) in let handler = let assume_zero_alloc = get_assume_zero_alloc ~scopes in @@ -1221,14 +1234,15 @@ and transl_exp0 ~in_new_scope ~scopes sort e = in begin match Config.flambda || Config.flambda2 with | true -> - Llet(Strict, Lambda.layout_function, funcid, handler, Lapply app) + Llet(Strict, Lambda.layout_function, funcid, funcid_duid, handler, + Lapply app) | false -> (* Needs to be lifted to top level manually here, because functions that contain other function declarations are not inlined by Closure. For example, adding a probe into the body of function foo will prevent foo from being inlined into another function. *) - probe_handlers := (funcid, handler)::!probe_handlers; + probe_handlers := (funcid, funcid_duid, handler)::!probe_handlers; Lapply app end end else begin @@ -1418,6 +1432,7 @@ and transl_apply ~scopes l in let id_arg = Ident.create_local "param" in + let id_arg_duid = Lambda.debug_uid_none in (* Process remaining arguments and build closure *) let body = let loc = map_scopes enter_partial_or_eta_wrapper loc in @@ -1439,6 +1454,7 @@ and transl_apply ~scopes let layout_arg = layout_of_sort (to_location loc) sort_arg in let params = [{ name = id_arg; + debug_uid = id_arg_duid; layout = layout_arg; attributes = Lambda.default_param_attribute; mode = arg_mode @@ -1450,7 +1466,10 @@ and transl_apply ~scopes (* Wrap "protected" definitions, starting from the left, so that evaluation is right-to-left. *) List.fold_right - (fun (id, layout, lam) body -> Llet(Strict, layout, id, lam, body)) + (fun (id, layout, lam) body -> + (* CR sspies: It appears all variables in [defs] are hidden from + the user. Is that correct? *) + Llet(Strict, layout, id, Lambda.debug_uid_none, lam, body)) !defs body | Arg (arg, _) :: l -> build_apply lam (arg :: args) loc pos ap_mode result_layout l @@ -1551,6 +1570,7 @@ and transl_tupled_function let tparams = List.map (fun kind -> { name = Ident.create_local "param"; + debug_uid = Lambda.debug_uid_none; layout = kind; attributes = Lambda.default_param_attribute; mode = alloc_heap @@ -1585,7 +1605,8 @@ and transl_curried_function ~scopes loc repr params body | Tfunction_body body -> None, event_before ~scopes body (transl_exp ~scopes return_sort body) | Tfunction_cases - { fc_cases; fc_partial; fc_param; fc_loc; fc_arg_sort; fc_arg_mode } + { fc_cases; fc_partial; fc_param; fc_param_debug_uid; + fc_loc; fc_arg_sort; fc_arg_mode } -> let fc_arg_sort = Jkind.Sort.default_for_transl_and_get fc_arg_sort in let arg_layout = @@ -1606,6 +1627,7 @@ and transl_curried_function ~scopes loc repr params body in let param = { name = fc_param; + debug_uid = fc_param_debug_uid; layout = arg_layout; attributes; mode = arg_mode; @@ -1621,7 +1643,8 @@ and transl_curried_function ~scopes loc repr params body let body, params = List.fold_right (fun fp (body, params) -> - let { fp_param; fp_kind; fp_mode; fp_sort; fp_partial; fp_loc } = fp in + let { fp_param; fp_param_debug_uid; fp_kind; fp_mode; fp_sort; + fp_partial; fp_loc } = fp in let arg_env, arg_type, attributes = match fp_kind with | Tparam_pat pat -> @@ -1634,6 +1657,7 @@ and transl_curried_function ~scopes loc repr params body let arg_mode = transl_alloc_mode_l fp_mode in let param = { name = fp_param; + debug_uid = fp_param_debug_uid; layout = arg_layout; attributes; mode = arg_mode; @@ -1863,12 +1887,13 @@ and transl_let ~scopes ~return_layout ?(add_regions=false) ?(in_structure=false) let idlist = List.map (fun {vb_pat=pat} -> match pat.pat_desc with - Tpat_var (id,_,_,_) -> id + Tpat_var (id,_,uid,_) -> id, uid + (* CR sspies: ^^^ seems like a reasonable uid for debugging *) | _ -> assert false) pat_expr_list in let transl_case {vb_expr=expr; vb_sort; vb_attributes; vb_rec_kind = rkind; - vb_loc; vb_pat} id = + vb_loc; vb_pat} (id, id_duid) = let vb_sort = Jkind.Sort.default_for_transl_and_get vb_sort in let def = transl_bound_exp ~scopes ~in_structure vb_pat vb_sort expr vb_loc vb_attributes @@ -1876,7 +1901,7 @@ and transl_let ~scopes ~return_layout ?(add_regions=false) ?(in_structure=false) let def = if add_regions then maybe_region_exp vb_sort expr def else def in - ( id, rkind, def ) in + ( id, id_duid, rkind, def ) in let lam_bds = List.map2 transl_case pat_expr_list idlist in fun body -> Value_rec_compiler.compile_letrec lam_bds body @@ -1900,6 +1925,7 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = (* Take a shallow copy of the init record, then mutate the fields of the copy *) let copy_id = Ident.create_local "newrecord" in + let copy_id_duid = Lambda.debug_uid_none in let update_field cont (lbl, definition) = (* CR layouts v5: allow more unboxed types here. *) check_record_field_sort lbl.lbl_loc lbl.lbl_sort; @@ -1958,7 +1984,7 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = Jkind.Sort.default_for_transl_and_get init_expr_sort in assert (is_heap_mode (Option.get mode)); (* Pduprecord must be Alloc_heap and not unboxed *) - Llet(Strict, Lambda.layout_block, copy_id, + Llet(Strict, Lambda.layout_block, copy_id, copy_id_duid, Lprim(Pduprecord (repres, size), [transl_exp ~scopes init_expr_sort init_expr], of_location ~scopes loc), @@ -1968,6 +1994,7 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = taken from init_expr if any *) (* CR layouts v5: allow non-value fields beyond just float# *) let init_id = Ident.create_local "init" in + let init_id_duid = Lambda.debug_uid_none in let lv = Array.mapi (fun i (lbl, definition) -> @@ -2133,7 +2160,7 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = let init_expr_sort = Jkind.Sort.default_for_transl_and_get init_expr_sort in - Llet(Strict, Lambda.layout_block, init_id, + Llet(Strict, Lambda.layout_block, init_id, init_id_duid, transl_exp ~scopes init_expr_sort init_expr, lam) end @@ -2141,6 +2168,7 @@ and transl_record_unboxed_product ~scopes loc env fields repres opt_init_expr = match repres with | Record_unboxed_product -> let init_id = Ident.create_local "init" in + let init_id_duid = Lambda.debug_uid_none in let shape = Array.map (fun (lbl, definition) -> @@ -2174,7 +2202,7 @@ and transl_record_unboxed_product ~scopes loc env fields repres opt_init_expr = in let layout = layout_exp init_expr_sort init_expr in let exp = transl_exp ~scopes init_expr_sort init_expr in - Llet(Strict, layout, init_id, exp, lam) + Llet(Strict, layout, init_id, init_id_duid, exp, lam) and transl_match ~scopes ~arg_sort ~return_sort e arg pat_expr_list partial = let return_layout = layout_exp return_sort e in @@ -2205,8 +2233,8 @@ and transl_match ~scopes ~arg_sort ~return_sort e arg pat_expr_list partial = let ids_full = Typedtree.pat_bound_idents_full arg_sort pv in let ids = List.map (fun (id, _, _, _, _) -> id) ids_full in let ids_kinds = - List.map (fun (id, {Location.loc; _}, ty, _, s) -> - id, Typeopt.layout pv.pat_env loc s ty) + List.map (fun (id, {Location.loc; _}, ty, duid, s) -> + id, duid, Typeopt.layout pv.pat_env loc s ty) ids_full in let vids = List.map Ident.rename ids in @@ -2246,10 +2274,10 @@ and transl_match ~scopes ~arg_sort ~return_sort e arg pat_expr_list partial = value actions run outside the try..with exception handler. *) let static_catch scrutinees val_ids handler = - let id = Typecore.name_pattern "exn" (List.map fst exn_cases) in + let id, id_duid = Typecore.name_pattern "exn" (List.map fst exn_cases) in let static_exception_id = next_raise_count () in Lstaticcatch - (Ltrywith (Lstaticraise (static_exception_id, scrutinees), id, + (Ltrywith (Lstaticraise (static_exception_id, scrutinees), id, id_duid, Matching.for_trywith ~scopes ~return_layout e.exp_loc (Lvar id) exn_cases, return_layout), @@ -2280,8 +2308,8 @@ and transl_match ~scopes ~arg_sort ~return_sort e arg pat_expr_list partial = List.map (fun (arg,s) -> let layout = layout_exp s arg in - let id = Typecore.name_pattern "val" [] in - (id, layout), (Lvar id, s, layout)) + let id, id_duid = Typecore.name_pattern "val" [] in + (id, id_duid, layout), (Lvar id, s, layout)) argl |> List.split in @@ -2295,9 +2323,11 @@ and transl_match ~scopes ~arg_sort ~return_sort e arg pat_expr_list partial = Matching.for_function ~scopes ~arg_sort ~arg_layout ~return_layout e.exp_loc None (transl_exp ~scopes arg_sort arg) val_cases partial | arg, _ :: _ -> - let val_id = Typecore.name_pattern "val" (List.map fst val_cases) in + let val_id, val_id_duid = Typecore.name_pattern "val" (List.map fst val_cases) in let arg_layout = layout_exp arg_sort arg in - static_catch [transl_exp ~scopes arg_sort arg] [val_id, arg_layout] + static_catch + [transl_exp ~scopes arg_sort arg] + [val_id, val_id_duid, arg_layout] (Matching.for_function ~scopes ~arg_sort ~arg_layout ~return_layout e.exp_loc None (Lvar val_id) val_cases partial) in @@ -2307,13 +2337,15 @@ and transl_match ~scopes ~arg_sort ~return_sort e arg pat_expr_list partial = handler, Same_region, return_layout) ) classic static_handlers -and transl_letop ~scopes loc env let_ ands param param_sort case case_sort +and transl_letop ~scopes loc env let_ ands param param_debug_uid param_sort case case_sort partial = let rec loop prev_layout prev_lam = function | [] -> prev_lam | and_ :: rest -> let left_id = Ident.create_local "left" in + let left_id_duid = Lambda.debug_uid_none in let right_id = Ident.create_local "right" in + let right_id_duid = Lambda.debug_uid_none in let op = transl_ident (of_location ~scopes and_.bop_op_name.loc) env and_.bop_op_type and_.bop_op_path and_.bop_op_val Id_value @@ -2331,7 +2363,7 @@ and transl_letop ~scopes loc env let_ ands param param_sort case case_sort and_.bop_op_type in let lam = - bind_with_layout Strict (right_id, right_layout) exp + bind_with_layout Strict (right_id, right_id_duid, right_layout) exp (Lapply{ ap_loc = of_location ~scopes and_.bop_loc; ap_func = op; @@ -2345,7 +2377,7 @@ and transl_letop ~scopes loc env let_ ands param param_sort case case_sort ap_probe=None; }) in - bind_with_layout Strict (left_id, prev_layout) prev_lam (loop result_layout lam rest) + bind_with_layout Strict (left_id, left_id_duid, prev_layout) prev_lam (loop result_layout lam rest) in let op = transl_ident (of_location ~scopes let_.bop_op_name.loc) env @@ -2372,7 +2404,8 @@ and transl_letop ~scopes loc env let_ ands param param_sort case case_sort ~return_sort:case_sort ~mode:alloc_heap ~return_mode loc repr [] (Tfunction_cases - { fc_cases = [case]; fc_param = param; fc_partial = partial; + { fc_cases = [case]; fc_param = param; + fc_param_debug_uid = param_debug_uid; fc_partial = partial; fc_loc = ghost_loc; fc_exp_extra = None; fc_attributes = []; fc_arg_mode = Mode.Alloc.disallow_right Mode.Alloc.legacy; fc_arg_sort = param_sort; fc_env = env; diff --git a/lambda/translmod.ml b/lambda/translmod.ml index a85fc4c83a4..3c181dc1a45 100644 --- a/lambda/translmod.ml +++ b/lambda/translmod.ml @@ -100,7 +100,8 @@ let transl_type_extension ~scopes env rootpath tyext body = transl_extension_constructor ~scopes env (field_path rootpath ext.ext_id) ext in - Llet(Strict, Lambda.layout_block, ext.ext_id, lam, body)) + (* CR sspies: Can we find a better [debug_uid] here? *) + Llet(Strict, Lambda.layout_block, ext.ext_id, Lambda.debug_uid_none, lam, body)) tyext.tyext_constructors body @@ -125,9 +126,10 @@ let rec apply_coercion loc strict restr arg = wrap_id_pos_list loc id_pos_list get_field lam) | Tcoerce_functor(cc_arg, cc_res) -> let param = Ident.create_local "funarg" in + let param_duid = Lambda.debug_uid_none in let carg = apply_coercion loc Alias cc_arg (Lvar param) in apply_coercion_result loc strict arg - [{name = param; layout = Lambda.layout_module; + [{name = param; debug_uid = param_duid; layout = Lambda.layout_module; attributes = Lambda.default_param_attribute; mode = alloc_heap}] [carg] cc_res | Tcoerce_primitive { pc_desc; pc_env; pc_type; pc_poly_mode; pc_poly_sort } -> @@ -147,9 +149,11 @@ and apply_coercion_result loc strict funct params args cc_res = match cc_res with | Tcoerce_functor(cc_arg, cc_res) -> let param = Ident.create_local "funarg" in + let param_duid = Lambda.debug_uid_none in let arg = apply_coercion loc Alias cc_arg (Lvar param) in apply_coercion_result loc strict funct ({ name = param; + debug_uid = param_duid; layout = Lambda.layout_module; attributes = Lambda.default_param_attribute; mode = alloc_heap } :: params) @@ -193,9 +197,11 @@ and wrap_id_pos_list loc id_pos_list get_field lam = List.fold_left (fun (lam, fv, s) (id',pos,c) -> if Ident.Set.mem id' fv then let id'' = Ident.create_local (Ident.name id') in + let id''_duid = Lambda.debug_uid_none in + (* CR sspies: What does this function do? It seems to duplicate code.*) let rhs = apply_coercion loc Alias c (get_field pos) in let fv_rhs = free_variables rhs in - (Llet(Alias, Lambda.layout_module_field, id'', rhs, lam), + (Llet(Alias, Lambda.layout_module_field, id'', id''_duid, rhs, lam), Ident.Set.union fv fv_rhs, Ident.Map.add id' id'' s) else (lam, fv, s)) @@ -423,6 +429,8 @@ let eval_rec_bindings bindings cont = bind_inits rem | (Id id, Some(loc, shape), _rhs) :: rem -> Llet(Strict, Lambda.layout_module, id, + Lambda.debug_uid_none, + (* CR sspies: Is there a sensible [debug_uid] here? *) Lapply{ ap_loc=Loc_unknown; ap_func=mod_prim "init_mod"; @@ -442,7 +450,9 @@ let eval_rec_bindings bindings cont = | (Ignore_loc loc, None, rhs) :: rem -> Lsequence(Lprim(Pignore, [rhs], loc), bind_strict rem) | (Id id, None, rhs) :: rem -> - Llet(Strict, Lambda.layout_module, id, rhs, bind_strict rem) + Llet(Strict, Lambda.layout_module, id, + Lambda.debug_uid_none, rhs, bind_strict rem) + (* CR sspies: Is there a sensible [debug_uid] here? *) | (_id, Some _, _rhs) :: rem -> bind_strict rem and patch_forwards = function @@ -493,7 +503,8 @@ let transl_class_bindings ~scopes cl_list = List.map (fun ({ci_id_class=id; ci_expr=cl; ci_virt=vf}, meths) -> let def, rkind = transl_class ~scopes ids id meths cl vf in - (id, rkind, def)) + (* CR sspies: Should class_infos have debug identifiers? *) + (id, Lambda.debug_uid_none, rkind, def)) cl_list) (* Compile one or more functors, merging curried functors to produce @@ -548,14 +559,21 @@ let rec compile_functor ~scopes mexp coercion root_path loc = let params, body = List.fold_left (fun (params, body) (param, loc, arg_coercion) -> let param' = Ident.rename param in + let param'_duid = Lambda.debug_uid_none in + (* CR sspies: Is there a sensible [debug_uid] here? *) let arg = apply_coercion loc Alias arg_coercion (Lvar param') in let params = { name = param'; + debug_uid = param'_duid; layout = Lambda.layout_module; attributes = Lambda.default_param_attribute; mode = alloc_heap } :: params in - let body = Llet (Alias, Lambda.layout_module, param, arg, body) in + let param_duid = Lambda.debug_uid_none in + (* CR sspies: Should param come with a [debug_uid]? *) + let body = Llet (Alias, Lambda.layout_module, param, param_duid, arg, + body) + in params, body) ([], transl_module ~scopes res_coercion body_path body) functor_params_rev @@ -722,11 +740,13 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function transl_type_extension ~scopes item.str_env rootpath tyext body, size | Tstr_exception ext -> let id = ext.tyexn_constructor.ext_id in + let id_duid = Lambda.debug_uid_none in + (* CR sspies: Can we find a better [debug_uid] here? *) let path = field_path rootpath id in let body, size = transl_structure ~scopes loc (id::fields) cc rootpath final_env rem in - Llet(Strict, Lambda.layout_block, id, + Llet(Strict, Lambda.layout_block, id, id_duid, transl_extension_constructor ~scopes item.str_env path @@ -757,7 +777,9 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function of_location ~scopes mb.mb_name.loc), body), size | Some id -> - Llet(pure_module mb.mb_expr, Lambda.layout_module, id, module_body, body), size + Llet(pure_module mb.mb_expr, Lambda.layout_module, id, + Lambda.debug_uid_none, module_body, body), size + (* CR sspies: Can we find a better [debug_uid] here? *) end | Tstr_module ({mb_presence=Mp_absent}) -> transl_structure ~scopes loc fields cc rootpath final_env rem @@ -791,6 +813,7 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function let ids = bound_value_identifiers incl.incl_type in let modl = incl.incl_mod in let mid = Ident.create_local "include" in + let mid_duid = Lambda.debug_uid_none in let rec rebind_idents pos newfields = function [] -> transl_structure ~scopes loc newfields cc rootpath final_env rem @@ -798,7 +821,9 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function let body, size = rebind_idents (pos + 1) (id :: newfields) ids in - Llet(Alias, Lambda.layout_module_field, id, + let id_duid = Lambda.debug_uid_none in + (* CR sspies: Can we find a better [debug_uid] here? *) + Llet(Alias, Lambda.layout_module_field, id, id_duid, Lprim(mod_field pos, [Lvar mid], of_location ~scopes incl.incl_loc), body), size @@ -816,7 +841,7 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function Strict, transl_include_functor ~generative:true modl ccs scopes loc in - Llet(let_kind, Lambda.layout_module, mid, modl, body), + Llet(let_kind, Lambda.layout_module, mid, mid_duid, modl, body), size | Tstr_open od -> @@ -831,6 +856,7 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function | _ -> let ids = bound_value_identifiers od.open_bound_items in let mid = Ident.create_local "open" in + let mid_duid = Lambda.debug_uid_none in let rec rebind_idents pos newfields = function [] -> transl_structure ~scopes loc newfields cc rootpath final_env rem @@ -838,13 +864,15 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function let body, size = rebind_idents (pos + 1) (id :: newfields) ids in - Llet(Alias, Lambda.layout_module_field, id, + let id_duid = Lambda.debug_uid_none in + (* CR sspies: Can we find a better [debug_uid] here? *) + Llet(Alias, Lambda.layout_module_field, id, id_duid, Lprim(mod_field pos, [Lvar mid], of_location ~scopes od.open_loc), body), size in let body, size = rebind_idents 0 fields ids in - Llet(pure, Lambda.layout_module, mid, + Llet(pure, Lambda.layout_module, mid, mid_duid, transl_module ~scopes Tcoerce_none None od.open_expr, body), size end @@ -920,7 +948,9 @@ let required_globals ~flambda body = let add_arg_block_to_module_block primary_block_lam size restr = let primary_block_id = Ident.create_local "*primary-block*" in + let primary_block_id_duid = Lambda.debug_uid_none in let arg_block_id = Ident.create_local "*arg-block*" in + let arg_block_id_duid = Lambda.debug_uid_none in let arg_block_lam = apply_coercion Loc_unknown Strict restr (Lvar primary_block_id) in @@ -928,8 +958,10 @@ let add_arg_block_to_module_block primary_block_lam size restr = let all_fields = List.init size get_field @ [Lvar arg_block_id] in let arg_block_field = size in let new_size = size + 1 in - Llet(Strict, layout_module, primary_block_id, primary_block_lam, - Llet(Strict, layout_module, arg_block_id, arg_block_lam, + Llet(Strict, layout_module, primary_block_id, + primary_block_id_duid, primary_block_lam, + Llet(Strict, layout_module, arg_block_id, + arg_block_id_duid, arg_block_lam, Lprim(Pmakeblock(0, Immutable, None, alloc_heap), all_fields, Loc_unknown))), @@ -941,6 +973,8 @@ let add_runtime_parameters lam params = List.map (fun name -> { name; + debug_uid = Lambda.debug_uid_none; + (* CR sspies: Can we find a better [debug_uid] here? *) layout = Pvalue Lambda.generic_value; attributes = Lambda.default_param_attribute; mode = Lambda.alloc_heap }) @@ -1256,6 +1290,8 @@ let transl_store_structure ~scopes glob map prims aliases str = (add_idents false ids subst) cont rem) | Tstr_exception ext -> let id = ext.tyexn_constructor.ext_id in + let id_duid = Lambda.debug_uid_none in + (* CR sspies: Can we find a better [debug_uid] here? *) let path = field_path rootpath id in let loc = of_location ~scopes ext.tyexn_constructor.ext_loc in let lam = @@ -1264,7 +1300,7 @@ let transl_store_structure ~scopes glob map prims aliases str = path ext.tyexn_constructor in - Lsequence(Llet(Strict, Lambda.layout_block, id, + Lsequence(Llet(Strict, Lambda.layout_block, id, id_duid, Lambda.subst no_env_update subst lam, store_ident loc id), transl_store ~scopes rootpath @@ -1284,6 +1320,8 @@ let transl_store_structure ~scopes glob map prims aliases str = ) | Tstr_module{mb_id=Some id;mb_loc=loc;mb_presence=Mp_present; mb_expr={mod_desc = Tmod_structure str}} -> + let id_duid = Lambda.debug_uid_none in + (* CR sspies: Can we find a better [debug_uid] here? *) let loc = of_location ~scopes loc in let lam = transl_store @@ -1294,7 +1332,7 @@ let transl_store_structure ~scopes glob map prims aliases str = (* Careful: see next case *) let subst = !transl_store_subst in Lsequence(lam, - Llet(Strict, Lambda.layout_module, id, + Llet(Strict, Lambda.layout_module, id, id_duid, Lambda.subst no_env_update subst (Lprim(Pmakeblock(0, Immutable, None, alloc_heap), List.map (fun id -> Lvar id) @@ -1312,6 +1350,8 @@ let transl_store_structure ~scopes glob map prims aliases str = } -> (* Format.printf "coerc id %s: %a@." (Ident.unique_name id) Includemod.print_coercion cc; *) + let id_duid = Lambda.debug_uid_none in + (* CR sspies: Can we find a better [debug_uid] here? *) let loc = of_location ~scopes loc in let lam = transl_store @@ -1323,7 +1363,7 @@ let transl_store_structure ~scopes glob map prims aliases str = let subst = !transl_store_subst in let field = field_of_str loc str in Lsequence(lam, - Llet(Strict, Lambda.layout_module, id, + Llet(Strict, Lambda.layout_module, id, id_duid, Lambda.subst no_env_update subst (Lprim(Pmakeblock(0, Immutable, None, alloc_heap), List.map field map, loc)), @@ -1334,6 +1374,8 @@ let transl_store_structure ~scopes glob map prims aliases str = | Tstr_module {mb_id=Some id; mb_presence=Mp_present; mb_expr=modl; mb_loc=loc; mb_attributes} -> + let id_duid = Lambda.debug_uid_none in + (* CR sspies: Can we find a better [debug_uid] here? *) let lam = Translattribute.add_inline_attribute (transl_module @@ -1347,7 +1389,8 @@ let transl_store_structure ~scopes glob map prims aliases str = the compilation unit (add_ident true returns subst unchanged). If not, we can use the value from the global (add_ident true adds id -> Pgetglobal... to subst). *) - Llet(Strict, Lambda.layout_module, id, Lambda.subst no_env_update subst lam, + Llet(Strict, Lambda.layout_module, id, id_duid, + Lambda.subst no_env_update subst lam, Lsequence(store_ident (of_location ~scopes loc) id, transl_store ~scopes rootpath (add_ident true id subst) @@ -1406,6 +1449,8 @@ let transl_store_structure ~scopes glob map prims aliases str = cont rem | id :: ids, arg :: args -> Llet(Alias, Lambda.layout_module_field, id, + Lambda.debug_uid_none, + (* CR sspies: Can we find a better [debug_uid] here? *) Lambda.subst no_env_update subst (field arg), Lsequence(store_ident (of_location ~scopes loc) id, loop ids args)) @@ -1426,12 +1471,16 @@ let transl_store_structure ~scopes glob map prims aliases str = let ids = bound_value_identifiers incl.incl_type in let modl = incl.incl_mod in let mid = Ident.create_local "include" in + let mid_duid = Lambda.debug_uid_none in let loc = of_location ~scopes incl.incl_loc in let rec store_idents pos = function | [] -> transl_store ~scopes rootpath (add_idents true ids subst) cont rem | id :: idl -> - Llet(Alias, Lambda.layout_module_field, id, Lprim(mod_field pos, [Lvar mid], + let id_duid = Lambda.debug_uid_none in + (* CR sspies: Can we find a better [debug_uid] here? *) + Llet(Alias, Lambda.layout_module_field, id, id_duid, + Lprim(mod_field pos, [Lvar mid], loc), Lsequence(store_ident loc id, store_idents (pos + 1) idl)) @@ -1444,7 +1493,7 @@ let transl_store_structure ~scopes glob map prims aliases str = | Tincl_gen_functor ccs -> transl_include_functor ~generative:true modl ccs scopes loc in - Llet(Strict, Lambda.layout_module, mid, + Llet(Strict, Lambda.layout_module, mid, mid_duid, Lambda.subst no_env_update subst modl, store_idents 0 ids) | Tstr_open od -> @@ -1461,7 +1510,10 @@ let transl_store_structure ~scopes glob map prims aliases str = | [] -> transl_store ~scopes rootpath (add_idents true ids0 subst) cont rem | id :: idl -> - Llet(Alias, Lambda.layout_module_field, id, Lvar ids.(pos), + let id_duid = Lambda.debug_uid_none in + (* CR sspies: Can we find a better [debug_uid] here? *) + Llet(Alias, Lambda.layout_module_field, id, id_duid, + Lvar ids.(pos), Lsequence(store_ident loc id, store_idents (pos + 1) idl)) in @@ -1479,19 +1531,22 @@ let transl_store_structure ~scopes glob map prims aliases str = | _ -> let ids = bound_value_identifiers od.open_bound_items in let mid = Ident.create_local "open" in + let mid_duid = Lambda.debug_uid_none in let loc = of_location ~scopes od.open_loc in let rec store_idents pos = function [] -> transl_store ~scopes rootpath (add_idents true ids subst) cont rem | id :: idl -> - Llet(Alias, Lambda.layout_module_field, id, + let id_duid = Lambda.debug_uid_none in + (* CR sspies: Can we find a better [debug_uid] here? *) + Llet(Alias, Lambda.layout_module_field, id, id_duid, Lprim(mod_field pos, [Lvar mid], loc), Lsequence(store_ident loc id, store_idents (pos + 1) idl)) in Llet( - pure, Lambda.layout_module, mid, + pure, Lambda.layout_module, mid, mid_duid, Lambda.subst no_env_update subst (transl_module ~scopes Tcoerce_none None od.open_expr), store_idents 0 ids) @@ -1606,6 +1661,7 @@ let store_arg_block_with_module_block module_name set_primary_fields restr size = let glob = Lprim(Pgetglobal module_name, [], Loc_unknown) in let primary_block_id = Ident.create_local "*primary-block*" in + let primary_block_id_duid = Lambda.debug_uid_none in let primary_block_lam = (* We could just access the global, but if [restr] is the trivial coercion, that would end up storing the global in itself as a circular reference, @@ -1617,6 +1673,7 @@ let store_arg_block_with_module_block Lprim(Pmakeblock(0, Immutable, None, alloc_heap), fields, Loc_unknown) in let arg_block_id = Ident.create_local "*arg-block*" in + let arg_block_duid = Lambda.debug_uid_none in let arg_block_lam = apply_coercion Loc_unknown Strict restr (Lvar primary_block_id) in @@ -1627,9 +1684,10 @@ let store_arg_block_with_module_block in let lam = Lsequence(set_primary_fields, - Llet(Strict, layout_module, primary_block_id, primary_block_lam, - Llet(Strict, layout_module, arg_block_id, arg_block_lam, - set_arg_block))) + Llet(Strict, layout_module, primary_block_id, + primary_block_id_duid, primary_block_lam, + Llet(Strict, layout_module, arg_block_id, arg_block_duid, + arg_block_lam, set_arg_block))) in new_size, lam, Some arg_field @@ -1769,6 +1827,8 @@ let toploop_setvalue_id id = toploop_setvalue id (Lvar id) let close_toplevel_term (lam, ()) = Ident.Set.fold (fun id l -> Llet(Strict, Lambda.layout_any_value, id, + Lambda.debug_uid_none, + (* CR sspies: Seems like this is an internal use. *) toploop_getvalue id, l)) (free_variables lam) lam @@ -1849,6 +1909,7 @@ let transl_toplevel_item ~scopes item = transl_include_functor ~generative:true modl ccs scopes loc in let mid = Ident.create_local "include" in + let mid_duid = Lambda.debug_uid_none in let rec set_idents pos = function [] -> lambda_unit @@ -1856,7 +1917,7 @@ let transl_toplevel_item ~scopes item = Lsequence(toploop_setvalue id (Lprim(mod_field pos, [Lvar mid], Loc_unknown)), set_idents (pos + 1) ids) in - Llet(Strict, Lambda.layout_module, mid, modl, set_idents 0 ids) + Llet(Strict, Lambda.layout_module, mid, mid_duid, modl, set_idents 0 ids) | Tstr_primitive descr -> record_primitive descr.val_val; lambda_unit @@ -1871,6 +1932,7 @@ let transl_toplevel_item ~scopes item = | _ -> let ids = bound_value_identifiers od.open_bound_items in let mid = Ident.create_local "open" in + let mid_duid = Lambda.debug_uid_none in let rec set_idents pos = function [] -> lambda_unit @@ -1879,7 +1941,7 @@ let transl_toplevel_item ~scopes item = (Lprim(mod_field pos, [Lvar mid], Loc_unknown)), set_idents (pos + 1) ids) in - Llet(pure, Lambda.layout_module, mid, + Llet(pure, Lambda.layout_module, mid, mid_duid, transl_module ~scopes Tcoerce_none None od.open_expr, set_idents 0 ids) end @@ -1968,8 +2030,9 @@ let transl_package_set_fields component_names target_name coercion = Loc_unknown) in let blk = Ident.create_local "block" in + let blk_duid = Lambda.debug_uid_none in (List.length pos_cc_list, - Llet (Strict, Lambda.layout_module, blk, + Llet (Strict, Lambda.layout_module, blk, blk_duid, apply_coercion Loc_unknown Strict coercion components, make_sequence (fun pos _id -> diff --git a/lambda/translobj.ml b/lambda/translobj.ml index 348730fe9f4..a5af0f3be00 100644 --- a/lambda/translobj.ml +++ b/lambda/translobj.ml @@ -99,7 +99,8 @@ let transl_label_init_general f = (* CR ncourant: this *should* not be too precise for the moment, but we should take care, or fix the underlying cause that led us to using [Popaque]. *) - Llet(Alias, layout, id, const, expr)) + (* CR sspies: Can we find a better [debug_uid] here? *) + Llet(Alias, layout, id, Lambda.debug_uid_none, const, expr)) consts expr in (*let expr = @@ -114,6 +115,7 @@ let transl_label_init_general f = let transl_label_init_flambda f = assert(Config.flambda || Config.flambda2); let method_cache_id = Ident.create_local "method_cache" in + let method_cache_duid = Lambda.debug_uid_none in method_cache := Lvar method_cache_id; (* Calling f (usually Translmod.transl_struct) requires the method_cache variable to be initialised to be able to generate @@ -123,6 +125,7 @@ let transl_label_init_flambda f = if !method_count = 0 then expr else Llet (Strict, Lambda.layout_array Pgenarray, method_cache_id, + method_cache_duid, Lprim (Pccall prim_makearray, [int !method_count; int 0], Loc_unknown), @@ -192,6 +195,8 @@ let oo_wrap_gen env req f x = Loc_unknown) in Llet(StrictOpt, Lambda.layout_class, id, + Lambda.debug_uid_none, + (* CR sspies: Can we find a better [debug_uid] here? *) Lprim (Popaque Lambda.layout_class, [cl], Loc_unknown), lambda)) lambda !classes diff --git a/lambda/translprim.ml b/lambda/translprim.ml index 158e2ac4a74..42e7e49b919 100644 --- a/lambda/translprim.ml +++ b/lambda/translprim.ml @@ -1664,13 +1664,14 @@ let lambda_of_prim prim_name prim loc args arg_exps = Lprim(Praise kind, [arg], loc) | Raise_with_backtrace, [exn; bt] -> let vexn = Ident.create_local "exn" in + let vexn_duid = Lambda.debug_uid_none in let raise_arg = match arg_exps with | None -> Lvar vexn | Some [exn_exp; _] -> event_after loc exn_exp (Lvar vexn) | Some _ -> assert false in - Llet(Strict, Lambda.layout_block, vexn, exn, + Llet(Strict, Lambda.layout_block, vexn, vexn_duid, exn, Lsequence(Lprim(Pccall caml_restore_raw_backtrace, [Lvar vexn; bt], loc), @@ -1810,6 +1811,9 @@ let transl_primitive loc p env ty ~poly_mode ~poly_sort path = let arg_mode = to_locality arg in let params, return = make_params ret_ty repr_args repr_res in { name = Ident.create_local "prim"; + debug_uid = Lambda.debug_uid_none; + (* The eta expansion is not actually visible at the source level, + so we do not generate a fresh [debug_uid] here. *) layout = arg_layout; attributes = Lambda.default_param_attribute; mode = arg_mode } diff --git a/lambda/value_rec_compiler.ml b/lambda/value_rec_compiler.ml index 24ebe75634e..d5459edf182 100644 --- a/lambda/value_rec_compiler.ml +++ b/lambda/value_rec_compiler.ml @@ -127,12 +127,12 @@ let compute_static_size lam = | Lconst _ -> Constant | Lapply _ -> dynamic_size lam | Lfunction lfun -> Function lfun - | Llet (_, _, id, def, body) -> + | Llet (_, _, id, _, def, body) -> let env = Ident.Map.add id (Lazy_backtrack.create { lambda = def; env }) env in compute_expression_size env body - | Lmutlet(_, _, _, body) -> + | Lmutlet(_, _, _, _, body) -> compute_expression_size env body | Lletrec (bindings, body) -> let env = @@ -159,7 +159,7 @@ let compute_static_size lam = compute_and_join_sizes_switch env [cases; fail_case] | Lstaticraise _ -> Unreachable | Lstaticcatch (body, _, handler, _, _) - | Ltrywith (body, _, handler, _) -> + | Ltrywith (body, _, _, handler, _) -> compute_and_join_sizes env [body; handler] | Lifthenelse (_cond, ifso, ifnot, _) -> compute_and_join_sizes env [ifso; ifnot] @@ -502,6 +502,8 @@ let lifted_block_read_sem : Lambda.field_read_semantics = Reads_agree let no_loc = Debuginfo.Scoped_location.Loc_unknown +(* CR sspies: The function [split_static_function] seems to replace a function, + so copying over debug_ids inside should be fine. *) let rec split_static_function lfun block_var local_idents lam : Lambda.lambda split_result = match lam with @@ -573,16 +575,16 @@ let rec split_static_function lfun block_var local_idents lam : no_loc) in Reachable (lifted, block) - | Llet (lkind, vkind, var, def, body) -> + | Llet (lkind, vkind, var, debug_uid, def, body) -> let+ body = split_static_function lfun block_var (Ident.Set.add var local_idents) body in - Llet (lkind, vkind, var, def, body) - | Lmutlet (vkind, var, def, body) -> + Llet (lkind, vkind, var, debug_uid, def, body) + | Lmutlet (vkind, var, debug_uid, def, body) -> let+ body = split_static_function lfun block_var (Ident.Set.add var local_idents) body in - Lmutlet (vkind, var, def, body) + Lmutlet (vkind, var, debug_uid, def, body) | Lletrec (bindings, body) -> let local_idents = List.fold_left (fun ids { id } -> Ident.Set.add id ids) @@ -637,7 +639,7 @@ let rec split_static_function lfun block_var local_idents lam : let body_res = split_static_function lfun block_var local_idents body in let handler_res = let local_idents = - List.fold_left (fun vars (var, _) -> Ident.Set.add var vars) + List.fold_left (fun vars (var, _, _) -> Ident.Set.add var vars) local_idents params in split_static_function lfun block_var local_idents handler @@ -653,7 +655,7 @@ let rec split_static_function lfun block_var local_idents lam : Printlambda.lfunction lfun Printlambda.lambda lam end - | Ltrywith (body, exn_var, handler, layout) -> + | Ltrywith (body, exn_var, debug_uid, handler, layout) -> let body_res = split_static_function lfun block_var local_idents body in let handler_res = split_static_function lfun block_var @@ -662,9 +664,9 @@ let rec split_static_function lfun block_var local_idents lam : begin match body_res, handler_res with | Unreachable, Unreachable -> Unreachable | Reachable (lfun, body), Unreachable -> - Reachable (lfun, Ltrywith (body, exn_var, handler, layout)) + Reachable (lfun, Ltrywith (body, exn_var, debug_uid, handler, layout)) | Unreachable, Reachable (lfun, handler) -> - Reachable (lfun, Ltrywith (body, exn_var, handler, layout)) + Reachable (lfun, Ltrywith (body, exn_var, debug_uid, handler, layout)) | Reachable _, Reachable _ -> Misc.fatal_errorf "letrec: multiple functions:@ lfun=%a@ lam=%a" Printlambda.lfunction lfun @@ -820,9 +822,9 @@ and rebuild_arms : *) type rec_bindings = - { static : (Ident.t * block_size * Lambda.lambda) list; - functions : (Ident.t * Lambda.lfunction) list; - dynamic : (Ident.t * Lambda.lambda) list; + { static : (Ident.t * Lambda.debug_uid * block_size * Lambda.lambda) list; + functions : (Ident.t * Lambda.debug_uid * Lambda.lfunction) list; + dynamic : (Ident.t * Lambda.debug_uid * Lambda.lambda) list; } let empty_bindings = @@ -851,21 +853,21 @@ let update_prim = let compile_letrec input_bindings body = if !Clflags.dump_letreclambda then ( Format.eprintf "Value_rec_compiler input bindings:\n"; - List.iter (fun (id, _, def) -> + List.iter (fun (id, _, _, def) -> Format.eprintf " %a = %a\n%!" Ident.print id Printlambda.lambda def) input_bindings; Format.eprintf "Value_rec_compiler body:@ %a\n%!" Printlambda.lambda body ); let subst_for_constants = - List.fold_left (fun subst (id, _, _) -> + List.fold_left (fun subst (id, _, _, _) -> Ident.Map.add id Lambda.dummy_constant subst) Ident.Map.empty input_bindings in let all_bindings_rev = - List.fold_left (fun rev_bindings (id, rkind, def) -> + List.fold_left (fun rev_bindings (id, duid, rkind, def) -> match (rkind : Value_rec_types.recursive_binding_kind) with | Dynamic -> - { rev_bindings with dynamic = (id, def) :: rev_bindings.dynamic } + { rev_bindings with dynamic = (id, duid, def) :: rev_bindings.dynamic } | Static -> let size = compute_static_size def in begin match size with @@ -877,15 +879,15 @@ let compile_letrec input_bindings body = let def = Lambda.subst (fun _ _ env -> env) subst_for_constants def in - { rev_bindings with dynamic = (id, def) :: rev_bindings.dynamic } + { rev_bindings with dynamic = (id, duid, def) :: rev_bindings.dynamic } | Block size -> { rev_bindings with - static = (id, size, def) :: rev_bindings.static } + static = (id, duid, size, def) :: rev_bindings.static } | Function lfun -> begin match def with | Lfunction lfun -> { rev_bindings with - functions = (id, lfun) :: rev_bindings.functions + functions = (id, duid, lfun) :: rev_bindings.functions } | _ -> let ctx_id = Ident.create_local "letrec_function_context" in @@ -897,10 +899,12 @@ let compile_letrec input_bindings body = "letrec: no function for binding:@ def=%a@ lfun=%a" Printlambda.lambda def Printlambda.lfunction lfun | Reachable ({ lfun; free_vars_block_size }, lam) -> - let functions = (id, lfun) :: rev_bindings.functions in + let functions = (id, duid, lfun) :: rev_bindings.functions in let static = - (ctx_id, Regular_block free_vars_block_size, lam) :: + (ctx_id, duid, Regular_block free_vars_block_size, lam) :: rev_bindings.static + (* CR sspies: We are explicitly duplicating a debug_id here. + Does that make sense? Seems to be the same source variable. *) in { rev_bindings with functions; static } end @@ -909,7 +913,7 @@ let compile_letrec input_bindings body = empty_bindings input_bindings in let body_with_patches = - List.fold_left (fun body (id, _size, lam) -> + List.fold_left (fun body (id, _, _size, lam) -> let update = Lprim (Pccall update_prim, [Lvar id; lam], no_loc) in @@ -921,19 +925,19 @@ let compile_letrec input_bindings body = | [] -> body_with_patches | bindings_rev -> let function_bindings = - List.rev_map (fun (id, lfun) -> - { id; def = lfun }) + List.rev_map (fun (id, debug_uid, lfun) -> + { id; debug_uid; def = lfun }) bindings_rev in Lletrec (function_bindings, body_with_patches) in let body_with_dynamic_values = - List.fold_left (fun body (id, lam) -> - Llet(Strict, Lambda.layout_letrec, id, lam, body)) + List.fold_left (fun body (id, duid, lam) -> + Llet(Strict, Lambda.layout_letrec, id, duid, lam, body)) body_with_functions all_bindings_rev.dynamic in let body_with_pre_allocations = - List.fold_left (fun body (id, size, _lam) -> + List.fold_left (fun body (id, duid, size, _lam) -> let alloc_prim, const_args = match size with | Regular_block size -> alloc_prim, [size] @@ -950,7 +954,7 @@ let compile_letrec input_bindings body = List.map (fun n -> Lconst (Lambda.const_int n)) const_args, no_loc) in - Llet(Strict, Lambda.layout_letrec, id, alloc, body)) + Llet(Strict, Lambda.layout_letrec, id, duid, alloc, body)) body_with_dynamic_values all_bindings_rev.static in body_with_pre_allocations diff --git a/lambda/value_rec_compiler.mli b/lambda/value_rec_compiler.mli index 6ddd0eef68f..2f7d214499e 100644 --- a/lambda/value_rec_compiler.mli +++ b/lambda/value_rec_compiler.mli @@ -36,6 +36,6 @@ *) val compile_letrec : - (Ident.t * Value_rec_types.recursive_binding_kind * Lambda.lambda) list -> + (Ident.t * Lambda.debug_uid * Value_rec_types.recursive_binding_kind * Lambda.lambda) list -> Lambda.lambda -> Lambda.lambda diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml index 5f058a77ebd..da6d7b9d498 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml @@ -497,7 +497,8 @@ 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 (value_kind, id, defining_expr, body) -> + | Lmutlet (value_kind, id, _duid, defining_expr, body) -> + (* CR sspies: dropping [debug_uid]; address in subsequent PR. *) (* 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 @@ -514,9 +515,12 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) CC.close_let acc ccenv [new_id, kind] User_visible (Simple (Var temp_id)) ~body) - | Llet ((Strict | Alias | StrictOpt), _, fun_id, Lfunction func, body) -> + | Llet ((Strict | Alias | StrictOpt), _, fun_id, duid, Lfunction func, body) + -> (* This case is here to get function names right. *) - let bindings = cps_function_bindings env [L.{ id = fun_id; def = func }] in + let bindings = + cps_function_bindings env [L.{ id = fun_id; debug_uid = duid; def = func }] + in let body acc ccenv = cps acc env ccenv body k k_exn in let let_expr = List.fold_left @@ -528,7 +532,9 @@ 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, Lconst const, body) -> + | Llet ((Strict | Alias | StrictOpt), layout, id, _duid, Lconst const, body) + -> + (* CR sspies: dropping [debug_uid]; address in subsequent PR. *) (* This case avoids extraneous continuations. *) let body acc ccenv = cps acc env ccenv body k k_exn in let kind = @@ -542,6 +548,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) ( ((Strict | Alias | StrictOpt) as let_kind), layout, id, + duid, Lprim (prim, args, loc), body ) -> ( let env, result = @@ -549,6 +556,7 @@ 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 @@ -598,13 +606,16 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) ~body) k_exn | Transformed lam -> - cps acc env ccenv (L.Llet (let_kind, layout, id, lam, body)) k k_exn) + cps acc env ccenv (L.Llet (let_kind, layout, id, duid, lam, body)) k k_exn + ) | Llet ( (Strict | Alias | StrictOpt), _, id, + _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) @@ -628,13 +639,17 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) [new_id, value_kind] User_visible (Simple new_value) ~body) k_exn - | Llet ((Strict | Alias | StrictOpt), _layout, id, defining_expr, Lvar id') + | 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. *) (* 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, defining_expr, body) -> + | Llet ((Strict | Alias | StrictOpt), layout, id, _duid, defining_expr, body) + -> + (* CR sspies: dropping [debug_uid]; address in subsequent PR. *) let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler:false ~params:[id, is_user_visible env id, layout] ~body:(fun acc env ccenv after_defining_expr -> @@ -685,6 +700,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) expression isn't a primitive. *) let name = Printlambda.name_of_primitive prim in let id = Ident.create_local name in + let id_duid = Lambda.debug_uid_none in let result_layout = L.primitive_result_layout prim in (match result_layout with | Pvalue _ | Punboxed_float _ | Punboxed_int _ | Punboxed_vector _ @@ -694,7 +710,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) Misc.fatal_errorf "Invalid result layout %a for primitive %a" Printlambda.layout result_layout Printlambda.primitive prim); cps acc env ccenv - (L.Llet (Strict, result_layout, id, lam, L.Lvar id)) + (L.Llet (Strict, result_layout, id, id_duid, lam, L.Lvar id)) k k_exn) | Lswitch (scrutinee, switch, loc, kind) -> maybe_insert_let_cont "switch_result" kind k acc env ccenv @@ -735,13 +751,17 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) else Nonrecursive in let handler_env, params = - let args_arity = Flambda_arity.from_lambda_list (List.map snd args) in + let args_arity = + Flambda_arity.from_lambda_list + (List.map (fun (_, _, layout) -> layout) args) + in let unarized_per_arg = Flambda_arity.unarize_per_parameter args_arity in let handler_env, args = List.fold_left_map - (fun handler_env ((arg, layout), kinds) -> + (fun handler_env ((arg, _duid, layout), kinds) -> + (* CR sspies: dropping [debug_uid]; address in subsequent PR. *) match kinds with | [] -> handler_env, [] | [kind] -> handler_env, [arg, kind] @@ -824,7 +844,8 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) k_exn) k_exn) k_exn - | Ltrywith (body, id, handler, kind) -> + | Ltrywith (body, id, _duid, handler, kind) -> + (* CR sspies: dropping [debug_uid]; address in subsequent PR. *) let dbg = Debuginfo.none (* CR mshinwell: fix [Lambda] *) in let body_result = Ident.create_local "body_result" in let region = Ident.create_local "try_region" in @@ -927,6 +948,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) cps acc env ccenv loop k k_exn | Lfor { for_id = ident; + for_debug_uid = duid; for_loc = loc; for_from = start; for_to = stop; @@ -934,8 +956,8 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) for_body = body } -> let env, loop = - Lambda_to_lambda_transforms.rec_catch_for_for_loop env loc ident start - stop dir body + Lambda_to_lambda_transforms.rec_catch_for_for_loop env loc ident duid + start stop dir body in cps acc env ccenv loop k k_exn | Lassign (being_assigned, new_value) -> @@ -1193,6 +1215,7 @@ and cps_function_bindings env (bindings : Lambda.rec_binding list) = List.map (fun L. { id = fun_id; + debug_uid = fun_duid; def = { kind; params; @@ -1206,11 +1229,13 @@ and cps_function_bindings env (bindings : Lambda.rec_binding list) = } } -> match - Simplif.split_default_wrapper ~id:fun_id ~kind ~params ~body:fbody - ~return ~attr ~loc ~ret_mode ~mode + Simplif.split_default_wrapper ~id:fun_id ~debug_uid:fun_duid ~kind + ~params ~body:fbody ~return ~attr ~loc ~ret_mode ~mode with - | [{ id; def = lfun }] -> [id, lfun] - | [{ id = id1; def = lfun1 }; { id = id2; def = lfun2 }] -> + (* 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] | [] | _ :: _ :: _ :: _ -> Misc.fatal_errorf @@ -1429,8 +1454,9 @@ 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; layout; mode; attributes } : L.lparam), kinds) : - Function_decl.param list -> + (fun ( ({ name; debug_uid = _; layout; mode; attributes } : L.lparam), + kinds ) : Function_decl.param list -> + (* CR sspies: dropping [debug_uid]; address in subsequent PR. *) match kinds with | [] -> [] | [kind] -> [{ name; kind; mode; attributes }] diff --git a/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.ml b/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.ml index 765f2fa4b57..b553d27bcf7 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.ml @@ -37,6 +37,7 @@ let rec_catch_for_while_loop env cond body = let cont = L.next_raise_count () in let env = Env.mark_as_recursive_static_catch env cont in let cond_result = Ident.create_local "while_cond_result" in + let cond_result_duid = Lambda.debug_uid_none in let lam : L.lambda = Lstaticcatch ( Lstaticraise (cont, []), @@ -45,6 +46,7 @@ let rec_catch_for_while_loop env cond body = ( Strict, L.layout_int, cond_result, + cond_result_duid, cond, Lifthenelse ( Lvar cond_result, @@ -56,12 +58,14 @@ let rec_catch_for_while_loop env cond body = in env, lam -let rec_catch_for_for_loop env loc ident start stop +let rec_catch_for_for_loop env loc ident duid start stop (dir : Asttypes.direction_flag) body = let cont = L.next_raise_count () in let env = Env.mark_as_recursive_static_catch env cont in let start_ident = Ident.create_local "for_start" in + let start_ident_duid = Lambda.debug_uid_none in let stop_ident = Ident.create_local "for_stop" in + let stop_ident_duid = Lambda.debug_uid_none in let first_test : L.lambda = match dir with | Upto -> Lprim (Pintcomp Cle, [L.Lvar start_ident; L.Lvar stop_ident], loc) @@ -85,17 +89,19 @@ let rec_catch_for_for_loop env loc ident start stop ( Strict, L.layout_int, start_ident, + start_ident_duid, start, Llet ( Strict, L.layout_int, stop_ident, + stop_ident_duid, stop, Lifthenelse ( first_test, Lstaticcatch ( Lstaticraise (cont, [L.Lvar start_ident]), - (cont, [ident, L.layout_int]), + (cont, [ident, duid, L.layout_int]), Lsequence ( body, Lifthenelse @@ -117,6 +123,7 @@ type initialize_array_element_width = let initialize_array0 env loc ~length array_set_kind width ~(init : L.lambda) creation_expr = let array = Ident.create_local "array" in + let array_duid = Lambda.debug_uid_none in (* If the element size is 32-bit, zero-initialize the last 64-bit word, to ensure reproducibility. *) (* CR mshinwell: why does e.g. caml_make_unboxed_int32_vect not do this? *) @@ -150,7 +157,8 @@ let initialize_array0 env loc ~length array_set_kind width ~(init : L.lambda) in let env, initialize = let index = Ident.create_local "index" in - rec_catch_for_for_loop env loc index + let index_duid = Lambda.debug_uid_none in + rec_catch_for_for_loop env loc index index_duid (Lconst (L.const_int 0)) (L.Lprim (Psubint, [length; Lconst (L.const_int 1)], loc)) Upto @@ -164,6 +172,7 @@ let initialize_array0 env loc ~length array_set_kind width ~(init : L.lambda) ( Strict, Pvalue { raw_kind = Pgenval; nullable = Non_nullable }, array, + array_duid, creation_expr, Lsequence (maybe_zero_init_last_field, Lsequence (initialize, Lvar array)) ) @@ -296,6 +305,7 @@ let makearray_dynamic_scannable_unboxed_product0 "Cannot compile Pmakearray_dynamic at unboxed product layouts without \ stack allocation enabled"; let args_array = Ident.create_local "args_array" in + let args_array_duid = Lambda.debug_uid_none in let array_layout = L.layout_array lambda_array_kind in let is_local = L.of_bool (match mode with Alloc_heap -> false | Alloc_local -> true) @@ -312,6 +322,7 @@ let makearray_dynamic_scannable_unboxed_product0 ( Strict, array_layout, args_array, + args_array_duid, Lprim ( Pmakearray (lambda_array_kind, Immutable, L.alloc_local), [init] (* will be unarized when this term is CPS converted *), @@ -482,10 +493,15 @@ let arrayblit_expanded env ~(src_mutability : L.mutable_flag) let id = Ident.create_local in let bind = L.bind_with_layout in let src = id "src" in + let src_duid = Lambda.debug_uid_none in let src_start_pos = id "src_start_pos" in + let src_start_pos_duid = Lambda.debug_uid_none in let dst = id "dst" in + let dst_duid = Lambda.debug_uid_none in let dst_start_pos = id "dst_start_pos" in + let dst_start_pos_duid = Lambda.debug_uid_none in let length = id "length" in + let length_duid = Lambda.debug_uid_none in (* CR mshinwell: support indexing by other types apart from [int] *) let src_end_pos_exclusive = L.Lprim (Paddint, [Lvar src_start_pos; Lvar length], loc) @@ -499,17 +515,20 @@ let arrayblit_expanded env ~(src_mutability : L.mutable_flag) let dst_start_pos_minus_src_start_pos_var = Ident.create_local "dst_start_pos_minus_src_start_pos" in + let dst_start_pos_minus_src_start_pos_var_duid = Lambda.debug_uid_none in let must_copy_backwards = L.Lprim (Pintcomp Cgt, [Lvar dst_start_pos; Lvar src_start_pos], loc) in let make_loop env (direction : Asttypes.direction_flag) = let src_index = Ident.create_local "index" in + let src_index_duid = Lambda.debug_uid_none in let start_pos, end_pos = match direction with | Upto -> L.Lvar src_start_pos, src_end_pos_inclusive | Downto -> src_end_pos_inclusive, L.Lvar src_start_pos in - rec_catch_for_for_loop env loc src_index start_pos end_pos direction + rec_catch_for_for_loop env loc src_index src_index_duid start_pos end_pos + direction (Lprim ( Parraysetu (dst_array_set_kind, Ptagged_int_index), [ Lvar dst; @@ -540,13 +559,19 @@ let arrayblit_expanded env ~(src_mutability : L.mutable_flag) in let expr = (* Preserve right-to-left evaluation order. *) - bind Strict (length, L.layout_int) length_expr - @@ bind Strict (dst_start_pos, L.layout_int) dst_start_pos_expr - @@ bind Strict (dst, L.layout_any_value) dst_expr - @@ bind Strict (src_start_pos, L.layout_int) src_start_pos_expr - @@ bind Strict (src, L.layout_any_value) src_expr + bind Strict (length, length_duid, L.layout_int) length_expr @@ bind Strict - (dst_start_pos_minus_src_start_pos_var, L.layout_int) + (dst_start_pos, dst_start_pos_duid, L.layout_int) + dst_start_pos_expr + @@ bind Strict (dst, dst_duid, L.layout_any_value) dst_expr + @@ bind Strict + (src_start_pos, src_start_pos_duid, L.layout_int) + src_start_pos_expr + @@ bind Strict (src, src_duid, L.layout_any_value) src_expr + @@ bind Strict + ( dst_start_pos_minus_src_start_pos_var, + dst_start_pos_minus_src_start_pos_var_duid, + L.layout_int ) dst_start_pos_minus_src_start_pos body in env, Transformed expr @@ -587,33 +612,41 @@ let transform_primitive0 env (prim : L.primitive) args loc = match prim, args with | Psequor, [arg1; arg2] -> let const_true = Ident.create_local "const_true" in + let const_true_duid = Lambda.debug_uid_none in let cond = Ident.create_local "cond_sequor" in + let cond_duid = Lambda.debug_uid_none in Transformed (L.Llet ( Strict, L.layout_int, const_true, + const_true_duid, Lconst (Const_base (Const_int 1)), L.Llet ( Strict, L.layout_int, cond, + cond_duid, arg1, switch_for_if_then_else ~cond:(L.Lvar cond) ~ifso:(L.Lvar const_true) ~ifnot:arg2 ~kind:L.layout_int ) )) | Psequand, [arg1; arg2] -> let const_false = Ident.create_local "const_false" in + let const_false_duid = Lambda.debug_uid_none in let cond = Ident.create_local "cond_sequand" in + let cond_duid = Lambda.debug_uid_none in Transformed (L.Llet ( Strict, L.layout_int, const_false, + const_false_duid, Lconst (Const_base (Const_int 0)), L.Llet ( Strict, L.layout_int, cond, + cond_duid, arg1, switch_for_if_then_else ~cond:(L.Lvar cond) ~ifso:arg2 ~ifnot:(L.Lvar const_false) ~kind:L.layout_int ) )) diff --git a/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.mli b/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.mli index 4ea169908bb..7d78001cbb0 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.mli +++ b/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.mli @@ -28,6 +28,7 @@ val rec_catch_for_for_loop : Lambda_to_flambda_env.t -> Lambda.scoped_location -> Ident.t -> + Lambda.debug_uid -> Lambda.lambda -> Lambda.lambda -> Asttypes.direction_flag -> diff --git a/toplevel/native/opttoploop.ml b/toplevel/native/opttoploop.ml index 0316c3b85e7..a5dcd6fb6b7 100644 --- a/toplevel/native/opttoploop.ml +++ b/toplevel/native/opttoploop.ml @@ -119,7 +119,7 @@ let close_phrase lam = [Lprim (Pgetglobal glb, [], Loc_unknown)], Loc_unknown) in - Llet(Strict, Lambda.layout_module_field, id, glob, l) + Llet(Strict, Lambda.layout_module_field, id, Lambda.debug_uid_none, glob, l) ) (free_variables lam) lam let toplevel_value id = diff --git a/typing/printtyped.ml b/typing/printtyped.ml index 0a540df111e..c341a75cf58 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -418,7 +418,8 @@ and function_body i ppf (body : function_body) = expression (i+1) ppf e | Tfunction_cases { fc_cases; fc_loc; fc_exp_extra; fc_attributes; fc_arg_mode; - fc_arg_sort; fc_param = _; fc_partial; fc_env = _; fc_ret_type = _ } + fc_arg_sort; fc_param = _; fc_param_debug_uid = _; + fc_partial; fc_env = _; fc_ret_type = _ } -> line i ppf "Tfunction_cases%a %a\n" fmt_partiality fc_partial diff --git a/typing/tast_iterator.ml b/typing/tast_iterator.ml index 1f183c0275b..4e166808872 100644 --- a/typing/tast_iterator.ml +++ b/typing/tast_iterator.ml @@ -313,7 +313,7 @@ let function_body sub body = | Tfunction_cases { fc_cases; fc_exp_extra; fc_loc; fc_attributes; fc_env; fc_arg_mode = _; fc_arg_sort = _; fc_ret_type = _; - fc_partial = _; fc_param = _; + fc_partial = _; fc_param = _; fc_param_debug_uid = _; } -> List.iter (sub.case sub) fc_cases; Option.iter (extra sub) fc_exp_extra; diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml index a6b9f01fa37..1d35203cdff 100644 --- a/typing/tast_mapper.ml +++ b/typing/tast_mapper.ml @@ -339,6 +339,7 @@ let pat let function_param sub { fp_kind; fp_param; + fp_param_debug_uid; fp_arg_label; fp_partial; fp_curry; @@ -365,6 +366,7 @@ let function_param sub in { fp_kind; fp_param; + fp_param_debug_uid; fp_arg_label; fp_partial; fp_curry; @@ -389,7 +391,8 @@ let function_body sub body = | Tfunction_body body -> Tfunction_body (sub.expr sub body) | Tfunction_cases - { fc_cases; fc_partial; fc_param; fc_loc; fc_exp_extra; fc_attributes; + { fc_cases; fc_partial; fc_param; fc_param_debug_uid; + fc_loc; fc_exp_extra; fc_attributes; fc_arg_mode; fc_arg_sort; fc_env; fc_ret_type; } -> let fc_loc = sub.location sub fc_loc in @@ -398,7 +401,8 @@ let function_body sub body = let fc_exp_extra = Option.map (extra sub) fc_exp_extra in let fc_env = sub.env sub fc_env in Tfunction_cases - { fc_cases; fc_partial; fc_param; fc_loc; fc_exp_extra; fc_attributes; + { fc_cases; fc_partial; fc_param; fc_param_debug_uid; + fc_loc; fc_exp_extra; fc_attributes; fc_arg_mode; fc_arg_sort; fc_env; fc_ret_type; } let expr sub x = @@ -421,10 +425,12 @@ let expr sub x = in let comp_cb_iterator = match comp_cb_iterator with | Texp_comp_range - { ident; pattern; start; stop; direction } + { ident; ident_debug_uid; pattern; start; stop; + direction } -> Texp_comp_range { ident + ; ident_debug_uid ; pattern (* Just mirroring [ident], ignored (see [Texp_for] *) @@ -602,11 +608,13 @@ let expr sub x = Texp_object (sub.class_structure sub cl, sl) | Texp_pack mexpr -> Texp_pack (sub.module_expr sub mexpr) - | Texp_letop {let_; ands; param; param_sort; body; body_sort; partial} -> + | Texp_letop {let_; ands; param; param_debug_uid; param_sort; + body; body_sort; partial} -> Texp_letop{ let_ = sub.binding_op sub let_; ands = List.map (sub.binding_op sub) ands; param; + param_debug_uid; param_sort; body = sub.case sub body; body_sort; diff --git a/typing/typecore.ml b/typing/typecore.ml index bd421c202bd..8b495ddbb42 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -4935,11 +4935,14 @@ let proper_exp_loc exp = (* To find reasonable names for let-bound and lambda-bound idents *) let rec name_pattern default = function - [] -> Ident.create_local default + [] -> Ident.create_local default, + Shape.Uid.internal_not_actually_unique + (* CR sspies: This code sits above Lambda, so we do not use + [Lambda.debug_uid_none] here. *) | p :: rem -> match p.pat_desc with - Tpat_var (id, _, _, _) -> id - | Tpat_alias(_, id, _, _, _, _) -> id + Tpat_var (id, _, uid, _) -> id, uid + | Tpat_alias(_, id, _, uid, _, _) -> id, uid | _ -> name_pattern default rem let name_cases default lst = @@ -6294,8 +6297,7 @@ and type_expect_ (mk_expected ~explanation:For_loop_stop_index Predef.type_int) in let env = Env.add_share_lock For_loop env in - (* When we'll want to add Uid to for loops, we can take it from here. *) - let (for_id, _for_uid), new_env = + let (for_id, for_uid), new_env = type_for_loop_index ~loc ~env ~param in let new_env = Env.add_region_lock new_env in @@ -6304,8 +6306,9 @@ and type_expect_ type_statement ~explanation:For_loop_body ~position new_env sbody in rue { - exp_desc = Texp_for {for_id; for_pat = param; for_from; for_to; - for_dir = dir; for_body; for_body_sort }; + exp_desc = Texp_for {for_id; for_debug_uid = for_uid; for_pat = param; + for_from; for_to; for_dir = dir; for_body; + for_body_sort }; exp_loc = loc; exp_extra = []; exp_type = instance Predef.type_unit; exp_attributes = sexp.pexp_attributes; @@ -6755,7 +6758,7 @@ and type_expect_ | [case] -> case | _ -> assert false in - let param = name_cases "param" cases in + let param, param_debug_uid = name_cases "param" cases in let let_ = { bop_op_name = slet.pbop_op; bop_op_path = op_path; @@ -6767,7 +6770,8 @@ and type_expect_ bop_loc = slet.pbop_loc; } in let desc = - Texp_letop{let_; ands; param; param_sort; body; body_sort; partial} + Texp_letop{let_; ands; param; param_debug_uid; param_sort; body; + body_sort; partial} in rue { exp_desc = desc; exp_loc = sexp.pexp_loc; @@ -7438,14 +7442,17 @@ and type_function else if is_position typed_arg_label && not_nolabel_function ty_ret then Location.prerr_warning pat.pat_loc Warnings.Unerasable_position_argument; - let fp_kind, fp_param = + let fp_kind, fp_param, fp_param_debug_uid = match default_arg with | None -> - let param = name_pattern "param" [ pat ] in - Tparam_pat pat, param + let param, param_uid = name_pattern "param" [ pat ] in + Tparam_pat pat, param, param_uid | Some (default_arg, arg_label, default_arg_sort) -> let param = Ident.create_local ("*opt*" ^ arg_label) in - Tparam_optional_default (pat, default_arg, default_arg_sort), param + let param_uid = Shape.Uid.internal_not_actually_unique in + Tparam_optional_default (pat, default_arg, default_arg_sort), + param, + param_uid in let param = { has_poly; @@ -7453,6 +7460,7 @@ and type_function { fp_kind; fp_arg_label = typed_arg_label; fp_param; + fp_param_debug_uid; fp_partial = partial; fp_newtypes = newtypes; fp_sort = arg_sort; @@ -8120,16 +8128,17 @@ and type_argument ?explanation ?recarg ~overwrite env (mode : expected_mode) sar let e = {texp with exp_type = ty_res; exp_desc = Texp_exclave e} in let cases = [ case eta_pat e ] in let cases_loc = { texp.exp_loc with loc_ghost = true } in - let param = name_cases "param" cases in + let param, param_uid = name_cases "param" cases in { texp with exp_type = ty_fun; exp_desc = Texp_function { params = []; body = Tfunction_cases { fc_cases = cases; fc_partial = Total; fc_param = param; - fc_env = env; fc_ret_type = ty_res; - fc_loc = cases_loc; fc_exp_extra = None; - fc_attributes = []; fc_arg_mode = Alloc.disallow_right marg; + fc_param_debug_uid = param_uid; fc_env = env; + fc_ret_type = ty_res; fc_loc = cases_loc; + fc_exp_extra = None; fc_attributes = []; + fc_arg_mode = Alloc.disallow_right marg; fc_arg_sort = arg_sort; }; ret_mode = Alloc.disallow_right mret; @@ -9062,11 +9071,12 @@ and type_function_cases_expect (Tarrow ((Nolabel, arg_mode, ret_mode), ty_arg, ty_ret, commu_ok))) in unify_exp_types loc env ty_fun (instance ty_expected); - let param = name_cases "param" cases in + let param , param_uid = name_cases "param" cases in let cases = { fc_cases = cases; fc_partial = partial; fc_param = param; + fc_param_debug_uid = param_uid; fc_loc = loc; fc_exp_extra = None; fc_env = env; @@ -9893,14 +9903,15 @@ and type_comprehension_iterator let stop = tbound ~explanation:Comprehension_for_stop stop in (* When we'll want to add Uid to comprehension bindings, we can take it from here. *) - let (ident, _uid) = + let (ident, uid) = type_comprehension_for_range_iterator_index tps ~loc ~env ~param:pattern in - Texp_comp_range { ident; pattern; start; stop; direction } + Texp_comp_range { ident; ident_debug_uid = uid; pattern; start; stop; + direction } | Pcomp_in seq -> let value_reason = match (comprehension_type : comprehension_type) with diff --git a/typing/typecore.mli b/typing/typecore.mli index 1a9fe0465f2..907ef03ad1a 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -168,8 +168,8 @@ val optimise_allocations: unit -> unit val has_poly_constraint : Parsetree.pattern -> bool -val name_pattern : string -> Typedtree.pattern list -> Ident.t -val name_cases : string -> Typedtree.value Typedtree.case list -> Ident.t +val name_pattern : string -> Typedtree.pattern list -> Ident.t * Uid.t +val name_cases : string -> Typedtree.value Typedtree.case list -> Ident.t * Uid.t (* Why are we calling [submode]? This tells us why. *) type submode_reason = diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 8617ae35545..d85b4a9c9ef 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -265,6 +265,7 @@ and expression_desc = } | Texp_for of { for_id : Ident.t; + for_debug_uid: Shape.Uid.t; for_pat : Parsetree.pattern; for_from : expression; for_to : expression; @@ -290,6 +291,7 @@ and expression_desc = let_ : binding_op; ands : binding_op list; param : Ident.t; + param_debug_uid : Shape.Uid.t; param_sort : Jkind.sort; body : value case; body_sort : Jkind.sort; @@ -333,6 +335,7 @@ and comprehension_clause_binding = and comprehension_iterator = | Texp_comp_range of { ident : Ident.t + ; ident_debug_uid : Shape.Uid.t ; pattern : Parsetree.pattern ; start : expression ; stop : expression @@ -356,6 +359,7 @@ and function_param = { fp_arg_label: arg_label; fp_param: Ident.t; + fp_param_debug_uid : Shape.Uid.t; fp_partial: partial; fp_kind: function_param_kind; fp_sort: Jkind.sort; @@ -382,6 +386,7 @@ and function_cases = fc_ret_type : Types.type_expr; fc_partial: partial; fc_param: Ident.t; + fc_param_debug_uid: Shape.Uid.t; fc_loc: Location.t; fc_exp_extra: exp_extra option; fc_attributes: attributes; diff --git a/typing/typedtree.mli b/typing/typedtree.mli index a876a249981..07691b755e2 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -469,6 +469,7 @@ and expression_desc = } | Texp_for of { for_id : Ident.t; + for_debug_uid: Shape.Uid.t; for_pat : Parsetree.pattern; for_from : expression; for_to : expression; @@ -494,6 +495,7 @@ and expression_desc = let_ : binding_op; ands : binding_op list; param : Ident.t; + param_debug_uid : Shape.Uid.t; param_sort : Jkind.sort; body : value case; body_sort : Jkind.sort; @@ -524,6 +526,7 @@ and function_param = (** [fp_param] is the identifier that is to be used to name the parameter of the function. *) + fp_param_debug_uid: Shape.Uid.t; fp_partial: partial; (** [fp_partial] = @@ -578,6 +581,7 @@ and function_cases = fc_ret_type : Types.type_expr; fc_partial: partial; fc_param: Ident.t; + fc_param_debug_uid : Shape.Uid.t; fc_loc: Location.t; fc_exp_extra: exp_extra option; fc_attributes: attributes; @@ -620,6 +624,7 @@ and comprehension_clause_binding = and comprehension_iterator = | Texp_comp_range of { ident : Ident.t + ; ident_debug_uid : Shape.Uid.t ; pattern : Parsetree.pattern (** Redundant with [ident] *) ; start : expression ; stop : expression From 353da39131ef1f591f78848c242a0e3d593f482f Mon Sep 17 00:00:00 2001 From: Simon Spies Date: Wed, 30 Apr 2025 15:24:15 +0100 Subject: [PATCH 2/9] 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 | 200 ++++++++++++------ .../from_lambda/lambda_to_flambda_env.ml | 22 +- .../from_lambda/lambda_to_flambda_env.mli | 14 +- .../lambda_to_flambda_primitives_helpers.ml | 24 ++- .../flambda2/identifiers/flambda_uid.ml | 62 ++++++ .../flambda2/identifiers/flambda_uid.mli | 28 +++ .../flambda2/parser/fexpr_to_flambda.ml | 21 +- .../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 | 3 +- .../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 | 40 +++- .../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 +- 49 files changed, 823 insertions(+), 277 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 31a548c0737..5967079aa32 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion.ml @@ -353,13 +353,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 @@ -383,7 +388,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) @@ -583,7 +590,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 = @@ -681,7 +689,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 = @@ -733,7 +744,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 @@ -745,7 +759,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 @@ -762,7 +779,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 = @@ -809,7 +828,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 @@ -850,7 +869,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 = @@ -867,7 +887,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 = @@ -1202,7 +1224,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 @@ -1235,7 +1257,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 *) @@ -1458,7 +1480,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 = @@ -1467,7 +1491,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; _ } -> @@ -1622,7 +1647,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 @@ -1661,7 +1689,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 @@ -1830,14 +1861,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, @@ -1883,7 +1920,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 = @@ -1898,7 +1938,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) @@ -1922,7 +1964,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 @@ -2001,7 +2045,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) @@ -2055,7 +2101,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))) @@ -2078,7 +2126,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 = @@ -2096,7 +2146,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: @@ -2373,7 +2425,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 @@ -2406,7 +2459,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 @@ -2416,7 +2472,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 @@ -2430,7 +2489,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 @@ -2848,7 +2909,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, @@ -2911,7 +2975,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 @@ -2974,6 +3040,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 @@ -3057,7 +3125,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 = @@ -3149,7 +3218,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 = @@ -3164,7 +3236,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) @@ -3172,7 +3246,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) @@ -3190,7 +3266,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 @@ -3201,14 +3278,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) @@ -3531,7 +3612,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 @@ -3552,7 +3637,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 c9346e37398..3a4d0bbe7af 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 @@ -744,6 +746,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 @@ -761,6 +764,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; @@ -782,9 +786,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 = @@ -805,6 +809,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 da6d7b9d498..c9a7699af5c 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,7 +470,7 @@ 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 -> (* CR mshinwell: note: mutable variables of non-singleton layouts are not @@ -488,7 +505,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 @@ -497,12 +516,11 @@ 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 (value_kind, id, _duid, defining_expr, body) -> - (* CR sspies: dropping [debug_uid]; address in subsequent PR. *) + | Lmutlet (value_kind, 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, value_kind] + ~params:[temp_id, duid, IR.Not_user_visible, value_kind] ~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 -> @@ -513,7 +531,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let env, new_id = Env.register_mutable_variable env id kind in let body acc ccenv = cps acc env ccenv body k k_exn in CC.close_let acc ccenv - [new_id, kind] + [new_id, Flambda_uid.uid duid, kind] User_visible (Simple (Var temp_id)) ~body) | Llet ((Strict | Alias | StrictOpt), _, fun_id, duid, Lfunction func, body) -> @@ -532,9 +550,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 = @@ -542,7 +558,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), @@ -577,6 +593,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 -> @@ -586,7 +603,13 @@ 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 = + List.mapi + (fun n (id, kind) -> + let duid = Flambda_uid.proj duid ~field:n in + id, duid, kind) + (Flambda_arity.fresh_idents_unarized ~id arity) + in let env = Env.register_unboxed_product_with_kinds env ~unboxed_product:id ~before_unarization:arity_component ~fields @@ -612,7 +635,7 @@ 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. *) @@ -629,29 +652,30 @@ 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 value_kind = snd (Env.get_mutable_variable_with_kind env being_assigned) in CC.close_let acc ccenv - [new_id, value_kind] + [new_id, Flambda_uid.internal_not_actually_unique, value_kind] User_visible (Simple new_value) ~body) k_exn | 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. *) (* 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) -> (* CR sspies: dropping [debug_uid]; address in subsequent PR. *) 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) @@ -760,11 +784,10 @@ 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 | [] -> handler_env, [] - | [kind] -> handler_env, [arg, kind] + | [kind] -> handler_env, [arg, Flambda_uid.uid duid, kind] | _ :: _ -> let fields = List.mapi @@ -774,7 +797,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 = @@ -788,7 +812,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 = @@ -869,12 +894,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 @@ -884,7 +914,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; @@ -894,7 +926,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; @@ -910,11 +944,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:[] @@ -977,7 +1021,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) Env.get_mutable_variable_with_kind env being_assigned in CC.close_let acc ccenv - [new_id, value_kind] + [new_id, Flambda_uid.internal_not_actually_unique, value_kind] User_visible (Simple new_value) ~body) k_exn | Levent (body, _event) -> cps acc env ccenv body k k_exn @@ -999,12 +1043,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 }) @@ -1023,7 +1071,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; @@ -1033,7 +1083,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; @@ -1046,9 +1098,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 @@ -1081,6 +1135,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 @@ -1088,6 +1143,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 @@ -1232,11 +1288,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 \ @@ -1249,7 +1304,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 @@ -1277,13 +1332,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 = @@ -1440,7 +1497,8 @@ and cps_function env ~fid ~(recursive : Recursive.t) ?precomputed_free_idents | Some (before_unarization, fields) -> ( 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 (List.map fst fields)) )) free_idents_of_body (new_env, Ident.Set.empty) in let exn_continuation : IR.exn_continuation = @@ -1454,21 +1512,23 @@ 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), + (fun ( ({ name; debug_uid = var_uid; layout; mode; attributes } : L.lparam), kinds ) : Function_decl.param list -> - (* CR sspies: dropping [debug_uid]; address in subsequent PR. *) 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 = @@ -1477,8 +1537,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 @@ -1501,11 +1561,11 @@ and cps_function env ~fid ~(recursive : Recursive.t) ?precomputed_free_idents 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 = @@ -1619,7 +1679,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 @@ -1651,7 +1713,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 c43cc71a3d0..6905db9448d 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_env.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_env.ml @@ -74,7 +74,8 @@ type t = (Ident.t * Flambda_kind.With_subkind.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; @@ -152,12 +153,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 @@ -210,6 +211,12 @@ let add_continuation t cont ~push_to_try_stack ~pop_region let extra_params = Ident.Map.data handler_env.current_values_of_mutables_in_scope in + let extra_params = + List.map + (fun (id, kind) -> + id, Flambda_uid.internal_not_actually_unique (* CR sspies: fix *), kind) + extra_params + in { body_env; handler_env; extra_params } let add_static_exn_continuation t static_exn ~pop_region cont = @@ -269,11 +276,16 @@ let extra_args_for_continuation_with_kinds t cont = match Ident.Map.find mut t.current_values_of_mutables_in_scope with | exception Not_found -> Misc.fatal_errorf "No current value for %a" Ident.print mut - | current_value, kind -> current_value, kind) + | current_value, kind -> + ( current_value, + Flambda_uid.internal_not_actually_unique (* CR sspies: fix *), + kind )) 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_kind 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 3d6ce56da30..46648ebaedd 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_env.mli +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_env.mli @@ -50,25 +50,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 : @@ -95,7 +97,9 @@ 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_kind : t -> Ident.t -> Ident.t * Flambda_kind.With_subkind.t 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 5612c904d74..43c8b4ccbfd 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 @@ -309,7 +309,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 @@ -319,7 +322,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 @@ -350,7 +354,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 @@ -389,7 +395,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)) @@ -411,7 +419,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..2c551b9618c --- /dev/null +++ b/middle_end/flambda2/identifiers/flambda_uid.ml @@ -0,0 +1,62 @@ +(**************************************************************************) +(* *) +(* 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) + +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..ca81b6a2238 --- /dev/null +++ b/middle_end/flambda2/identifiers/flambda_uid.mli @@ -0,0 +1,28 @@ +(**************************************************************************) +(* *) +(* 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 + +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 ef4b791bc9e..6b8662122b3 100644 --- a/middle_end/flambda2/parser/fexpr_to_flambda.ml +++ b/middle_end/flambda2/parser/fexpr_to_flambda.ml @@ -624,7 +624,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 @@ -651,7 +655,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 @@ -680,7 +687,10 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = (fun ({ param; kind } : Fexpr.kinded_parameter) (env, args) -> 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 env, param :: args) params (env, []) @@ -894,7 +904,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/simplify/apply_cont_rewrite.ml b/middle_end/flambda2/simplify/apply_cont_rewrite.ml index d9a64615796..a6c4daee778 100644 --- a/middle_end/flambda2/simplify/apply_cont_rewrite.ml +++ b/middle_end/flambda2/simplify/apply_cont_rewrite.ml @@ -176,7 +176,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 @@ -195,7 +196,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 bbcc5180cc9..457faa85a5c 100644 --- a/middle_end/flambda2/simplify/env/downwards_env.ml +++ b/middle_end/flambda2/simplify/env/downwards_env.ml @@ -143,7 +143,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 @@ -203,9 +204,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 @@ -312,7 +317,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) @@ -332,7 +338,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 = @@ -371,7 +380,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) @@ -389,7 +402,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 b3499849dde..bc5412bae6c 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 @@ -568,7 +570,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 @@ -764,12 +768,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 d8bad139fdb..a3f0028bc23 100644 --- a/middle_end/flambda2/simplify/flow/mutable_unboxing.ml +++ b/middle_end/flambda2/simplify/flow/mutable_unboxing.ml @@ -476,7 +476,9 @@ module Fold_prims = struct (fun i kind -> let name = Variable.unique_name block_needed 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 034f86d4160..5f85e18414c 100644 --- a/middle_end/flambda2/simplify/simplify_apply_cont_expr.ml +++ b/middle_end/flambda2/simplify/simplify_apply_cont_expr.ml @@ -43,7 +43,8 @@ let inline_linearly_used_continuation uacc ~create_apply_cont ~params:params' let bindings_outermost_first = ListLabels.map2 params args ~f:(fun param arg -> let let_bound = - Bound_var.create (BP.var param) Name_mode.normal + 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 diff --git a/middle_end/flambda2/simplify/simplify_apply_expr.ml b/middle_end/flambda2/simplify/simplify_apply_expr.ml index 02a405623ea..c2a8794a67e 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 @@ -476,7 +480,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 @@ -594,7 +599,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 @@ -703,7 +711,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 db750cda786..2050beea532 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)) @@ -242,7 +248,10 @@ let split_direct_over_application apply in let after_full_application = Continuation.create () in let after_full_application_handler = - 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 @@ -275,14 +284,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 9d1c6dbef6e..345e2c1718c 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 bdcfe027887..7b3c27f84cf 100644 --- a/middle_end/flambda2/simplify/simplify_let_cont_expr.ml +++ b/middle_end/flambda2/simplify/simplify_let_cont_expr.ml @@ -260,7 +260,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 @@ -502,7 +504,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 (Simple.var bound_to) in let handler, uacc = @@ -538,9 +543,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 7b0b12376a8..e7a1183718e 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 = @@ -189,7 +200,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 @@ -199,9 +211,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 @@ -375,7 +388,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 c862a8a65ac..9118ea41525 100644 --- a/middle_end/flambda2/simplify/simplify_switch_expr.ml +++ b/middle_end/flambda2/simplify/simplify_switch_expr.ml @@ -341,11 +341,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 = @@ -513,7 +520,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 @@ -638,7 +647,9 @@ let simplify_switch ~simplify_let ~simplify_function_body dacc switch 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 99a4257d065..22ce453d375 100644 --- a/middle_end/flambda2/simplify/simplify_unary_primitive.ml +++ b/middle_end/flambda2/simplify/simplify_unary_primitive.ml @@ -719,7 +719,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 } @@ -727,7 +729,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 6171a115467..649932b691d 100644 --- a/middle_end/flambda2/simplify/unboxing/build_unboxing_denv.ml +++ b/middle_end/flambda2/simplify/unboxing/build_unboxing_denv.ml @@ -26,7 +26,11 @@ 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 + (* CR tnowak: verify *) + let naked_name = + VB.create naked_var Flambda_uid.internal_not_actually_unique + Name_mode.normal + in let denv = DE.define_variable denv naked_name naked_kind in add_equation_on_var denv param_var shape @@ -37,7 +41,10 @@ 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 DE.define_variable denv v (K.Block_shape.element_kind shape index)) denv fields in @@ -60,7 +67,11 @@ 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 + (* CR tnowak: verify *) + let v = + VB.create var Flambda_uid.internal_not_actually_unique + Name_mode.normal + in DE.define_variable denv v (K.With_subkind.kind kind)) vars_within_closure denv in @@ -81,7 +92,11 @@ 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 + (* CR tnowak: verify *) + let tag_v = + VB.create tag.param Flambda_uid.internal_not_actually_unique + Name_mode.normal + in let denv = DE.define_variable denv tag_v K.naked_immediate in let denv = DE.map_typing_env denv ~f:(fun tenv -> @@ -97,7 +112,11 @@ 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 + (* CR tnowak: verify *) + let is_int_v = + VB.create is_int.param Flambda_uid.internal_not_actually_unique + Name_mode.normal + in let denv = DE.define_variable denv is_int_v K.naked_immediate in let denv = DE.map_typing_env denv ~f:(fun tenv -> @@ -119,7 +138,11 @@ 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 + (* CR tnowak: verify *) + let v = + VB.create ctor_epa.param Flambda_uid.internal_not_actually_unique + Name_mode.normal + in let denv = DE.define_variable denv v K.naked_immediate in let ty = T.alias_type_of K.naked_immediate (Simple.var ctor_epa.param) @@ -144,7 +167,10 @@ 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_variable denv v (K.Block_shape.element_kind shape index)) denv block_fields) fields_by_tag denv diff --git a/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml b/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml index a9f738bc6ea..bdeb41b2118 100644 --- a/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml +++ b/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml @@ -420,7 +420,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 @@ -431,7 +434,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 @@ -445,7 +451,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 @@ -460,6 +470,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 @@ -467,6 +478,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 @@ -474,6 +486,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 @@ -491,13 +504,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 d7d3b2e6f97..964119abe46 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 @@ -866,7 +867,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 e1f5ed41128..49da3d73e4c 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_expr.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_expr.ml @@ -616,12 +616,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) = @@ -662,7 +662,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 @@ -985,7 +984,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 @@ -1004,7 +1004,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 = @@ -1075,8 +1076,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 088483173ca..b74708e2981 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 @@ -445,6 +445,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]) @@ -468,7 +469,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]. *) @@ -476,7 +481,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 *) @@ -680,7 +689,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)) @@ -722,7 +730,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 @@ -735,7 +747,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 @@ -762,7 +774,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 e5895568d9b..5f72842a851 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_shared.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_shared.ml @@ -263,7 +263,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 92b5f880acf..f3494f4c885 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 c58f1cce301..1aef8a19165 100644 --- a/middle_end/flambda2/types/equal_types_for_debug.ml +++ b/middle_end/flambda2/types/equal_types_for_debug.ml @@ -462,7 +462,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 @@ -470,7 +473,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 1a772fbaa01..fe1b848447f 100644 --- a/middle_end/flambda2/types/meet_and_n_way_join.ml +++ b/middle_end/flambda2/types/meet_and_n_way_join.ml @@ -283,7 +283,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 @@ -1223,7 +1225,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 c1963bcbee10c21554ccb8df8147e87c0b3e6b64 Mon Sep 17 00:00:00 2001 From: Simon Spies Date: Wed, 30 Apr 2025 15:43:36 +0100 Subject: [PATCH 3/9] rename flambda_uid -> flambda_debug_uid --- middle_end/backend_var.ml | 2 +- middle_end/backend_var.mli | 2 +- .../bound_identifiers/bound_parameter.ml | 8 +- .../bound_identifiers/bound_parameter.mli | 5 +- .../bound_identifiers/bound_parameters.mli | 2 +- .../flambda2/bound_identifiers/bound_var.ml | 4 +- .../flambda2/bound_identifiers/bound_var.mli | 4 +- .../from_lambda/closure_conversion.ml | 83 ++++++++++--------- .../from_lambda/closure_conversion.mli | 8 +- .../from_lambda/closure_conversion_aux.ml | 7 +- .../from_lambda/closure_conversion_aux.mli | 8 +- .../flambda2/from_lambda/lambda_to_flambda.ml | 71 ++++++++-------- .../from_lambda/lambda_to_flambda_env.ml | 11 ++- .../from_lambda/lambda_to_flambda_env.mli | 11 +-- .../lambda_to_flambda_primitives_helpers.ml | 13 +-- .../{flambda_uid.ml => flambda_debug_uid.ml} | 0 ...{flambda_uid.mli => flambda_debug_uid.mli} | 0 .../flambda2/parser/fexpr_to_flambda.ml | 8 +- .../flambda2/simplify/apply_cont_rewrite.ml | 6 +- .../common_subexpression_elimination.ml | 2 +- .../flambda2/simplify/env/downwards_env.ml | 17 ++-- middle_end/flambda2/simplify/expr_builder.ml | 8 +- .../simplify/flow/mutable_unboxing.ml | 2 +- .../simplify/inlining/inlining_transforms.ml | 5 +- .../flambda2/simplify/lifted_cont_params.ml | 2 +- .../flambda2/simplify/simplify_apply_expr.ml | 9 +- .../flambda2/simplify/simplify_common.ml | 14 ++-- .../flambda2/simplify/simplify_extcall.ml | 3 +- .../simplify/simplify_let_cont_expr.ml | 5 +- .../simplify/simplify_set_of_closures.ml | 25 +++--- .../flambda2/simplify/simplify_switch_expr.ml | 13 +-- .../simplify/simplify_unary_primitive.ml | 4 +- .../simplify/unboxing/build_unboxing_denv.ml | 16 ++-- .../simplify/unboxing/unboxing_epa.ml | 21 +++-- .../simplify_shared/inlining_helpers.ml | 6 +- middle_end/flambda2/terms/flambda.ml | 2 +- middle_end/flambda2/tests/meet_test.ml | 24 +++--- middle_end/flambda2/to_cmm/to_cmm.ml | 6 +- middle_end/flambda2/to_cmm/to_cmm_env.mli | 6 +- .../flambda2/to_cmm/to_cmm_set_of_closures.ml | 10 ++- middle_end/flambda2/types/env/join_env.ml | 3 +- .../flambda2/types/equal_types_for_debug.ml | 6 +- middle_end/flambda2/types/join_levels_old.ml | 2 +- .../flambda2/types/meet_and_n_way_join.ml | 5 +- 44 files changed, 259 insertions(+), 210 deletions(-) rename middle_end/flambda2/identifiers/{flambda_uid.ml => flambda_debug_uid.ml} (100%) rename middle_end/flambda2/identifiers/{flambda_uid.mli => flambda_debug_uid.mli} (100%) diff --git a/middle_end/backend_var.ml b/middle_end/backend_var.ml index 89433026612..a23e92a3473 100644 --- a/middle_end/backend_var.ml +++ b/middle_end/backend_var.ml @@ -16,7 +16,7 @@ include Ident -module Uid = Flambda2_identifiers.Flambda_uid +module Uid = Flambda2_identifiers.Flambda_debug_uid type backend_var = t diff --git a/middle_end/backend_var.mli b/middle_end/backend_var.mli index 2288ab698bd..15f43a83f89 100644 --- a/middle_end/backend_var.mli +++ b/middle_end/backend_var.mli @@ -19,7 +19,7 @@ include module type of struct include Ident end -module Uid = Flambda2_identifiers.Flambda_uid +module Uid = Flambda2_identifiers.Flambda_debug_uid type backend_var = t diff --git a/middle_end/flambda2/bound_identifiers/bound_parameter.ml b/middle_end/flambda2/bound_identifiers/bound_parameter.ml index 66797aa6c98..0b49a7fce49 100644 --- a/middle_end/flambda2/bound_identifiers/bound_parameter.ml +++ b/middle_end/flambda2/bound_identifiers/bound_parameter.ml @@ -19,7 +19,7 @@ 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 +33,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 +41,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..8c860605738 100644 --- a/middle_end/flambda2/bound_identifiers/bound_parameter.mli +++ b/middle_end/flambda2/bound_identifiers/bound_parameter.mli @@ -20,13 +20,14 @@ module Uid = Shape.Uid 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..4d7fe84f53d 100644 --- a/middle_end/flambda2/bound_identifiers/bound_var.ml +++ b/middle_end/flambda2/bound_identifiers/bound_var.ml @@ -16,12 +16,12 @@ type t = { var : Variable.t; - uid : Flambda_uid.t; + 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 + Format.fprintf ppf "%a,uid=%a" Variable.print var Flambda_debug_uid.print uid let create var uid name_mode = (* Note that [name_mode] might be [In_types], e.g. when dealing with function diff --git a/middle_end/flambda2/bound_identifiers/bound_var.mli b/middle_end/flambda2/bound_identifiers/bound_var.mli index f6ed340ce99..f697f6d6d1a 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 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 5967079aa32..f06c6752c1e 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion.ml @@ -355,7 +355,7 @@ module Inlining = struct Let_with_acc.create acc (* CR tnowak: verify *) (Bound_pattern.singleton - (VB.create param Flambda_uid.internal_not_actually_unique + (VB.create param Flambda_debug_uid.internal_not_actually_unique Name_mode.normal)) (Named.create_simple arg) ~body) (acc, body) params args @@ -363,7 +363,7 @@ module Inlining = struct 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 + (VB.create my_depth Flambda_debug_uid.internal_not_actually_unique Name_mode.normal)) (Named.create_rec_info rec_info) ~body @@ -390,7 +390,7 @@ module Inlining = struct (Bound_pattern.singleton (VB.create (Variable.create "inlined_dbg") - Flambda_uid.internal_not_actually_unique Name_mode.normal)) + Flambda_debug_uid.internal_not_actually_unique Name_mode.normal)) (Named.create_prim (Nullary (Enter_inlined_apply { dbg = inlined_debuginfo })) Debuginfo.none) @@ -690,8 +690,8 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds | [arg] -> let result = Variable.create "reinterpreted" in let result' = - Bound_var.create result Flambda_uid.internal_not_actually_unique - Name_mode.normal + Bound_var.create result + Flambda_debug_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 @@ -745,8 +745,8 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds fun args acc -> let unboxed_arg = Variable.create "unboxed" in let unboxed_arg' = - VB.create unboxed_arg Flambda_uid.internal_not_actually_unique - Name_mode.normal + VB.create unboxed_arg + Flambda_debug_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 @@ -761,7 +761,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds (fun ret_value { kind; _ } -> BP.create ret_value (K.With_subkind.anything kind) - Flambda_uid.internal_not_actually_unique + Flambda_debug_uid.internal_not_actually_unique (* CR tnowak: verify *)) handler_params unarized_results |> Bound_parameters.create @@ -780,7 +780,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds let let_bound_vars' = List.map (fun let_bound_var -> - VB.create let_bound_var Flambda_uid.internal_not_actually_unique + VB.create let_bound_var Flambda_debug_uid.internal_not_actually_unique Name_mode.normal) let_bound_vars in @@ -888,7 +888,7 @@ let close_effect_primitive acc env ~dbg exn_continuation 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 *) ] + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) ] |> Bound_parameters.create in let close call_kind = @@ -1648,7 +1648,7 @@ let close_switch acc env ~condition_dbg scrutinee (sw : IR.switch) : let scrutinee = find_simple_from_id env scrutinee in let untagged_scrutinee = Variable.create "untagged" in let untagged_scrutinee' = - VB.create untagged_scrutinee Flambda_uid.internal_not_actually_unique + VB.create untagged_scrutinee Flambda_debug_uid.internal_not_actually_unique Name_mode.normal in let known_const_scrutinee = @@ -1690,7 +1690,7 @@ let close_switch acc env ~condition_dbg scrutinee (sw : IR.switch) : in let comparison_result = Variable.create "eq" in let comparison_result' = - VB.create comparison_result Flambda_uid.internal_not_actually_unique + VB.create comparison_result Flambda_debug_uid.internal_not_actually_unique Name_mode.normal in let acc, default_action = @@ -1863,7 +1863,7 @@ let compute_body_of_unboxed_function acc my_region my_closure (Bound_pattern.singleton (Bound_var.create (Bound_parameter.var param) - Flambda_uid.internal_not_actually_unique + Flambda_debug_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)) @@ -1873,7 +1873,7 @@ let compute_body_of_unboxed_function acc my_region my_closure ( List.map (fun (var, kind) -> Bound_parameter.create var kind - Flambda_uid.internal_not_actually_unique + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *)) vars_with_kinds @ main_code_params, @@ -1922,7 +1922,7 @@ let compute_body_of_unboxed_function acc my_region my_closure let handler_params = Bound_parameters.create [ Bound_parameter.create boxed_variable return - Flambda_uid.internal_not_actually_unique + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) ] in let handler acc = @@ -1939,7 +1939,7 @@ let compute_body_of_unboxed_function acc my_region my_closure ( Let_with_acc.create acc (Bound_pattern.singleton (Bound_var.create var - Flambda_uid.internal_not_actually_unique + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) Name_mode.normal)) (Named.create_prim (unboxing_primitive k boxed_variable i) @@ -1965,7 +1965,8 @@ let compute_body_of_unboxed_function acc my_region my_closure let acc, unboxed_body = Let_with_acc.create acc (Bound_pattern.singleton - (Bound_var.create my_closure Flambda_uid.internal_not_actually_unique + (Bound_var.create my_closure + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) Name_mode.normal)) (Named.create_prim (Flambda_primitive.Unary @@ -2046,7 +2047,7 @@ let make_unboxed_function_wrapper acc function_slot ~unarized_params:params (Let_expr.create (Bound_pattern.singleton (Bound_var.create var - Flambda_uid.internal_not_actually_unique + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) Name_mode.normal)) named ~body ~free_names_of_body:(Known free_names_of_body)), @@ -2102,7 +2103,7 @@ let make_unboxed_function_wrapper acc function_slot ~unarized_params:params (Let_expr.create (Bound_pattern.singleton (Bound_var.create main_closure - Flambda_uid.internal_not_actually_unique + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) Name_mode.normal)) projection ~body:(Expr.create_apply main_application) @@ -2127,7 +2128,7 @@ let make_unboxed_function_wrapper acc function_slot ~unarized_params:params (fun kind -> let var = Variable.create "unboxed_return" in Bound_parameter.create var kind - Flambda_uid.internal_not_actually_unique + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *)) (Flambda_arity.unarized_components result_arity_main_code)) in @@ -2147,7 +2148,7 @@ let make_unboxed_function_wrapper acc function_slot ~unarized_params:params (Let_expr.create (Bound_pattern.singleton (Bound_var.create boxed_return - Flambda_uid.internal_not_actually_unique + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) Name_mode.normal)) box_result_named ~body:(Expr.create_apply_cont return_apply_cont) @@ -2425,7 +2426,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 + BP.create var p.kind Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *)) unarized_params |> Bound_parameters.create @@ -2460,7 +2461,7 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot Project_function_slot { move_from = function_slot; move_to } in let var = - VB.create var Flambda_uid.internal_not_actually_unique + VB.create var Flambda_debug_uid.internal_not_actually_unique Name_mode.normal in let named = @@ -2473,7 +2474,7 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot Variable.Map.fold (fun var value_slot (acc, body) -> let var = - VB.create var Flambda_uid.internal_not_actually_unique + VB.create var Flambda_debug_uid.internal_not_actually_unique Name_mode.normal in let named = @@ -2490,8 +2491,8 @@ 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 + Flambda_debug_uid.internal_not_actually_unique Name_mode.normal) in Let_with_acc.create acc bound (Named.create_rec_info next_depth_expr) ~body in @@ -2912,7 +2913,7 @@ let close_let_rec acc env ~function_declarations (* CR tnowak: verify *) VB.create (fst (Env.find_var env ident)) - Flambda_uid.internal_not_actually_unique Name_mode.normal + Flambda_debug_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, @@ -2977,7 +2978,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.internal_not_actually_unique Name_mode.normal in Function_slot.Map.add function_slot fun_var fun_vars_map) generated_closures fun_vars_map @@ -3041,7 +3042,8 @@ let wrap_partial_application acc env apply_continuation (apply : IR.apply) (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 *); + Flambda_debug_uid.internal_not_actually_unique + (* CR tnowak: verify *); kind; attributes = Lambda.default_param_attribute; mode = Alloc_mode.For_types.to_lambda mode @@ -3126,7 +3128,8 @@ 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:Flambda_debug_uid.internal_not_actually_unique + ~function_slot ~kind: (Lambda.Curried { nlocal = @@ -3220,8 +3223,8 @@ let wrap_over_application acc env full_call (apply : IR.apply) ~remaining (fun i kind -> BP.create (Variable.create ("result" ^ string_of_int i)) - kind - Flambda_uid.internal_not_actually_unique (* CR tnowak: verify *)) + kind Flambda_debug_uid.internal_not_actually_unique + (* CR tnowak: verify *)) (Flambda_arity.unarized_components apply.return_arity) in let handler acc = @@ -3237,7 +3240,7 @@ let wrap_over_application acc env full_call (apply : IR.apply) ~remaining Let_with_acc.create acc (Bound_pattern.singleton (Bound_var.create (Variable.create "unit") - Flambda_uid.internal_not_actually_unique + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) Name_mode.normal)) (Named.create_prim (Unary (End_region { ghost = true }, Simple.var ghost_region)) @@ -3247,7 +3250,7 @@ let wrap_over_application acc env full_call (apply : IR.apply) ~remaining Let_with_acc.create acc (Bound_pattern.singleton (Bound_var.create (Variable.create "unit") - Flambda_uid.internal_not_actually_unique + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) Name_mode.normal)) (Named.create_prim (Unary (End_region { ghost = false }, Simple.var region)) @@ -3267,7 +3270,8 @@ let wrap_over_application acc env full_call (apply : IR.apply) ~remaining 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? *) ] + Flambda_debug_uid.internal_not_actually_unique + (* CR tnowak: maybe? *) ] |> Bound_parameters.create) ~handler:perform_over_application ~body ~is_exn_handler:false ~is_cold:false @@ -3279,7 +3283,7 @@ let wrap_over_application acc env full_call (apply : IR.apply) ~remaining Let_with_acc.create acc (Bound_pattern.singleton (Bound_var.create ghost_region - Flambda_uid.internal_not_actually_unique + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) Name_mode.normal)) (Named.create_prim (Variadic (Begin_region { ghost = true }, [])) @@ -3288,7 +3292,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 + (Bound_var.create region Flambda_debug_uid.internal_not_actually_unique Name_mode.normal)) (Named.create_prim (Variadic (Begin_region { ghost = false }, [])) @@ -3614,7 +3618,7 @@ let wrap_final_module_block acc env ~program ~prog_return_cont (fun (acc, body) (pos, var) -> (* CR tnowak: verify *) let var = - VB.create var Flambda_uid.internal_not_actually_unique + VB.create var Flambda_debug_uid.internal_not_actually_unique Name_mode.normal in let pat = Bound_pattern.singleton var in @@ -3638,7 +3642,8 @@ let wrap_final_module_block acc env ~program ~prog_return_cont 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? *) ] + Flambda_debug_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 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 3a4d0bbe7af..ef1ac19d815 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 = @@ -746,7 +747,7 @@ module Function_decls = struct module Function_decl = struct type param = { name : Ident.t; - var_uid : Flambda_uid.t; + var_uid : Flambda_debug_uid.t; kind : Flambda_kind.With_subkind.t; attributes : Lambda.parameter_attribute; mode : Lambda.locality_mode @@ -764,7 +765,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; diff --git a/middle_end/flambda2/from_lambda/closure_conversion_aux.mli b/middle_end/flambda2/from_lambda/closure_conversion_aux.mli index 40489c3e62f..1d7cc54c0fb 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion_aux.mli +++ b/middle_end/flambda2/from_lambda/closure_conversion_aux.mli @@ -25,7 +25,7 @@ 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 +146,7 @@ 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 +343,7 @@ module Function_decls : sig type param = { name : Ident.t; - var_uid : Flambda_uid.t; + var_uid : Flambda_debug_uid.t; kind : Flambda_kind.With_subkind.t; attributes : Lambda.parameter_attribute; mode : Lambda.locality_mode @@ -351,7 +351,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 -> diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml index c9a7699af5c..acd2575c425 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml @@ -137,14 +137,15 @@ 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.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_debug_uid.internal_not_actually_unique, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region @@ -204,7 +205,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.uid duid in let param = id, duid, visible, kind in handler_env, param :: params_rev | Unboxed_product _ -> @@ -216,7 +217,7 @@ 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.proj duid ~field:n in field, field_uid, kind) (Flambda_arity.unarize arity) in @@ -280,14 +281,15 @@ 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.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_debug_uid.internal_not_actually_unique + (* CR sspies: fix*), Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region @@ -373,7 +375,7 @@ 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.internal_not_actually_unique, IR.Not_user_visible, kind )) return_value_components return_kinds @@ -448,7 +450,7 @@ 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 duid = Flambda_debug_uid.internal_not_actually_unique in CC.close_let acc ccenv [id, duid, kind] Not_user_visible (IR.Simple simple) ~body:(body id) @@ -505,7 +507,8 @@ 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 ~fuid:Flambda_uid.internal_not_actually_unique + cps_function env ~fid:id + ~fuid:Flambda_debug_uid.internal_not_actually_unique ~recursive:(Non_recursive : Recursive.t) func in @@ -531,7 +534,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let env, new_id = Env.register_mutable_variable env id kind in let body acc ccenv = cps acc env ccenv body k k_exn in CC.close_let acc ccenv - [new_id, Flambda_uid.uid duid, kind] + [new_id, Flambda_debug_uid.uid duid, kind] User_visible (Simple (Var temp_id)) ~body) | Llet ((Strict | Alias | StrictOpt), _, fun_id, duid, Lfunction func, body) -> @@ -558,7 +561,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.uid duid, kind] (is_user_visible env id) (Simple (Const const)) ~body | Llet ( ((Strict | Alias | StrictOpt) as let_kind), @@ -593,7 +596,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) -> ( env, [ ( id, - Flambda_uid.uid duid, + Flambda_debug_uid.uid duid, Flambda_kind.With_subkind .from_lambda_values_and_unboxed_numbers_only layout ) ] ) | Punboxed_product layouts -> @@ -606,7 +609,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let fields = List.mapi (fun n (id, kind) -> - let duid = Flambda_uid.proj duid ~field:n in + let duid = Flambda_debug_uid.proj duid ~field:n in id, duid, kind) (Flambda_arity.fresh_idents_unarized ~id arity) in @@ -653,7 +656,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.uid duid, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (Simple (Const L.const_unit)) ~body in @@ -661,7 +664,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) snd (Env.get_mutable_variable_with_kind env being_assigned) in CC.close_let acc ccenv - [new_id, Flambda_uid.internal_not_actually_unique, value_kind] + [new_id, Flambda_debug_uid.internal_not_actually_unique, value_kind] User_visible (Simple new_value) ~body) k_exn | Llet @@ -787,7 +790,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) (fun handler_env ((arg, duid, layout), kinds) -> match kinds with | [] -> handler_env, [] - | [kind] -> handler_env, [arg, Flambda_uid.uid duid, kind] + | [kind] -> handler_env, [arg, Flambda_debug_uid.uid duid, kind] | _ :: _ -> let fields = List.mapi @@ -797,7 +800,7 @@ 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.proj duid ~field:n in ident, duid, kind) kinds in @@ -895,7 +898,7 @@ 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.internal_not_actually_unique, Flambda_kind.With_subkind.tagged_immediate ) ] (* CR sspies: can we do better? *) Not_user_visible @@ -903,7 +906,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.internal_not_actually_unique, (* CR sspies: can we do better? *) Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible @@ -915,7 +918,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let begin_try_region body = CC.close_let acc ccenv [ ( region, - Flambda_uid.internal_not_actually_unique, + Flambda_debug_uid.internal_not_actually_unique, Flambda_kind.With_subkind.region ) ] Not_user_visible (Begin_region @@ -927,7 +930,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_debug_uid.internal_not_actually_unique, Flambda_kind.With_subkind.region ) ] Not_user_visible (Begin_region @@ -1021,7 +1024,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) Env.get_mutable_variable_with_kind env being_assigned in CC.close_let acc ccenv - [new_id, Flambda_uid.internal_not_actually_unique, value_kind] + [new_id, Flambda_debug_uid.internal_not_actually_unique, value_kind] User_visible (Simple new_value) ~body) k_exn | Levent (body, _event) -> cps acc env ccenv body k k_exn @@ -1044,14 +1047,15 @@ 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.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_uid.internal_not_actually_unique (* CR sspies: fix *), + Flambda_debug_uid.internal_not_actually_unique + (* CR sspies: fix *), Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region @@ -1072,7 +1076,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let dbg = Debuginfo.none in CC.close_let acc ccenv [ ( region, - Flambda_uid.internal_not_actually_unique, + Flambda_debug_uid.internal_not_actually_unique, Flambda_kind.With_subkind.region ) ] Not_user_visible (Begin_region @@ -1084,7 +1088,8 @@ 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_debug_uid.internal_not_actually_unique + (* CR sspies: fix *), Flambda_kind.With_subkind.region ) ] Not_user_visible (Begin_region @@ -1135,7 +1140,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.internal_not_actually_unique, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region @@ -1143,7 +1148,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.internal_not_actually_unique, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region @@ -1333,7 +1338,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.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) @@ -1517,13 +1522,13 @@ and cps_function env ~fid ~fuid ~(recursive : Recursive.t) match kinds with | [] -> [] | [kind] -> - let var_uid = Flambda_uid.uid var_uid in + let var_uid = Flambda_debug_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 duid = Flambda_debug_uid.proj var_uid ~field:n in let ident = Ident.create_local (Printf.sprintf "%s_unboxed%d" (Ident.unique_name name) n) @@ -1680,7 +1685,7 @@ and cps_switch acc env ccenv (switch : L.lambda_switch) ~condition_dbg in CC.close_let acc ccenv [ ( scrutinee_tag, - Flambda_uid.internal_not_actually_unique, + Flambda_debug_uid.internal_not_actually_unique, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (Get_tag scrutinee) ~body in @@ -1714,7 +1719,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, + Flambda_debug_uid.internal_not_actually_unique, 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 6905db9448d..d266bffeb2c 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_env.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_env.ml @@ -75,7 +75,7 @@ type 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; @@ -158,7 +158,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 @@ -214,7 +215,9 @@ let add_continuation t cont ~push_to_try_stack ~pop_region let extra_params = List.map (fun (id, kind) -> - id, Flambda_uid.internal_not_actually_unique (* CR sspies: fix *), kind) + ( id, + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *), + kind )) extra_params in { body_env; handler_env; extra_params } @@ -278,7 +281,7 @@ let extra_args_for_continuation_with_kinds t cont = Misc.fatal_errorf "No current value for %a" Ident.print mut | current_value, kind -> ( current_value, - Flambda_uid.internal_not_actually_unique (* CR sspies: fix *), + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *), kind )) mutables 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 46648ebaedd..e75b1d861bc 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_env.mli +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_env.mli @@ -50,27 +50,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 : @@ -99,7 +100,7 @@ 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_kind : t -> Ident.t -> Ident.t * Flambda_kind.With_subkind.t 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 43c8b4ccbfd..66592cdcd20 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 @@ -310,8 +310,8 @@ let rec bind_recs acc exn_cont ~register_const0 (prim : expr_primitive) | 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 Flambda_uid.internal_not_actually_unique - Name_mode.normal + Bound_var.create cond_result + Flambda_debug_uid.internal_not_actually_unique Name_mode.normal in let ifso_cont = Continuation.create () in let ifnot_cont = Continuation.create () in @@ -323,7 +323,7 @@ let rec bind_recs acc exn_cont ~register_const0 (prim : expr_primitive) List.map2 (fun result_var result_kind -> Bound_parameter.create result_var result_kind - Flambda_uid.internal_not_actually_unique (* CR sspies: new *)) + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: new *)) result_vars result_kinds in let result_simples = List.map Simple.var result_vars in @@ -355,7 +355,8 @@ let rec bind_recs acc exn_cont ~register_const0 (prim : expr_primitive) let result_pats = List.map (fun result_var -> - Bound_var.create result_var Flambda_uid.internal_not_actually_unique + Bound_var.create result_var + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) Name_mode.normal) result_vars in @@ -396,7 +397,7 @@ let rec bind_recs acc exn_cont ~register_const0 (prim : expr_primitive) let named = must_be_singleton_named nameds in let pat = Bound_var.create (Variable.create "seq") - Flambda_uid.internal_not_actually_unique + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) Name_mode.normal |> Bound_pattern.singleton in @@ -422,7 +423,7 @@ and bind_rec_primitive acc exn_cont ~register_const0 (prim : simple_or_prim) let vars' = List.map (fun var -> - VB.create var Flambda_uid.internal_not_actually_unique + VB.create var Flambda_debug_uid.internal_not_actually_unique Name_mode.normal) vars in diff --git a/middle_end/flambda2/identifiers/flambda_uid.ml b/middle_end/flambda2/identifiers/flambda_debug_uid.ml similarity index 100% rename from middle_end/flambda2/identifiers/flambda_uid.ml rename to middle_end/flambda2/identifiers/flambda_debug_uid.ml diff --git a/middle_end/flambda2/identifiers/flambda_uid.mli b/middle_end/flambda2/identifiers/flambda_debug_uid.mli similarity index 100% rename from middle_end/flambda2/identifiers/flambda_uid.mli rename to middle_end/flambda2/identifiers/flambda_debug_uid.mli diff --git a/middle_end/flambda2/parser/fexpr_to_flambda.ml b/middle_end/flambda2/parser/fexpr_to_flambda.ml index 6b8662122b3..76d398832fc 100644 --- a/middle_end/flambda2/parser/fexpr_to_flambda.ml +++ b/middle_end/flambda2/parser/fexpr_to_flambda.ml @@ -626,7 +626,7 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = let var, env = fresh_var env var in (* CR tnowak: verify *) let var = - Bound_var.create var Flambda_uid.internal_not_actually_unique + Bound_var.create var Flambda_debug_uid.internal_not_actually_unique Name_mode.normal in var, env @@ -656,7 +656,7 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = let id, env = fresh_var env var in let body = expr env body in let var = - Bound_var.create id Flambda_uid.internal_not_actually_unique + Bound_var.create id Flambda_debug_uid.internal_not_actually_unique Name_mode.normal in let bound = Bound_pattern.singleton var in @@ -689,7 +689,7 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = let param = Bound_parameter.create var (value_kind_with_subkind_opt kind) - Flambda_uid.internal_not_actually_unique + Flambda_debug_uid.internal_not_actually_unique (* CR tnowak: verify *) in env, param :: args) @@ -906,7 +906,7 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = let param = Bound_parameter.create var (value_kind_with_subkind_opt kind) - Flambda_uid.internal_not_actually_unique + Flambda_debug_uid.internal_not_actually_unique (* CR tnowak: verify *) in param, env) diff --git a/middle_end/flambda2/simplify/apply_cont_rewrite.ml b/middle_end/flambda2/simplify/apply_cont_rewrite.ml index a6c4daee778..710cf79d6f3 100644 --- a/middle_end/flambda2/simplify/apply_cont_rewrite.ml +++ b/middle_end/flambda2/simplify/apply_cont_rewrite.ml @@ -176,7 +176,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 Flambda_uid.internal_not_actually_unique + ( Bound_var.create temp + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) Name_mode.normal, Code_size.prim prim, Flambda.Named.create_prim prim Debuginfo.none ) @@ -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 Flambda_uid.internal_not_actually_unique + ( Bound_var.create temp + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) Name_mode.normal, Code_size.prim prim, Flambda.Named.create_prim prim Debuginfo.none ) diff --git a/middle_end/flambda2/simplify/common_subexpression_elimination.ml b/middle_end/flambda2/simplify/common_subexpression_elimination.ml index 7d901c105fd..b7f0db7e1be 100644 --- a/middle_end/flambda2/simplify/common_subexpression_elimination.ml +++ b/middle_end/flambda2/simplify/common_subexpression_elimination.ml @@ -263,7 +263,7 @@ let join_one_cse_equation ~cse_at_each_use prim bound_to_map let extra_param = BP.create var (K.With_subkind.anything prim_result_kind) - Flambda_uid.internal_not_actually_unique (* CR tnowak: verify *) + Flambda_debug_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 457faa85a5c..5fc21fdb7fb 100644 --- a/middle_end/flambda2/simplify/env/downwards_env.ml +++ b/middle_end/flambda2/simplify/env/downwards_env.ml @@ -144,7 +144,8 @@ 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 *)) + Flambda_debug_uid.internal_not_actually_unique + (* CR sspies: fix *)) in variables_defined_in_current_continuation :: r in @@ -205,11 +206,11 @@ let create ~round ~(resolver : resolver) define_variable (define_variable t (Bound_var.create toplevel_my_region - Flambda_uid.internal_not_actually_unique + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) Name_mode.normal) K.region) (Bound_var.create toplevel_my_ghost_region - Flambda_uid.internal_not_actually_unique + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) Name_mode.normal) K.region @@ -317,7 +318,7 @@ 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 + (Bound_var.create var Flambda_debug_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) @@ -339,7 +340,7 @@ 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 + (Bound_var.create var Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) (Bound_name.name_mode name)) ty) ~symbol:(fun [@inline] sym -> add_symbol t sym ty) @@ -382,7 +383,8 @@ let define_parameters ~extra t ~params = (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 + Bound_var.create param_var + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) Name_mode.normal in define_variable0 ~extra t var (K.With_subkind.kind (BP.kind param))) @@ -404,7 +406,8 @@ let add_parameters ~extra ?(name_mode = Name_mode.normal) t params ~param_types (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 + Bound_var.create param_var + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) name_mode in add_variable0 ~extra t var param_type) diff --git a/middle_end/flambda2/simplify/expr_builder.ml b/middle_end/flambda2/simplify/expr_builder.ml index bc5412bae6c..a1aaf2a8e96 100644 --- a/middle_end/flambda2/simplify/expr_builder.ml +++ b/middle_end/flambda2/simplify/expr_builder.ml @@ -285,8 +285,8 @@ 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 + Flambda_debug_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 @@ -571,7 +571,7 @@ let create_let_symbols uacc lifted_constant ~body = let expr, uacc, _ = create_coerced_singleton_let uacc (* CR tnowak: verify *) - (VB.create var Flambda_uid.internal_not_actually_unique + (VB.create var Flambda_debug_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 @@ -770,7 +770,7 @@ let rewrite_fixed_arity_continuation0 uacc cont_or_apply_cont ~use_id arity : List.map (fun kind -> BP.create (Variable.create "param") kind - Flambda_uid.internal_not_actually_unique + Flambda_debug_uid.internal_not_actually_unique (* CR tnowak: verify *)) (Flambda_arity.unarized_components arity) in diff --git a/middle_end/flambda2/simplify/flow/mutable_unboxing.ml b/middle_end/flambda2/simplify/flow/mutable_unboxing.ml index a3f0028bc23..ae5b0550f16 100644 --- a/middle_end/flambda2/simplify/flow/mutable_unboxing.ml +++ b/middle_end/flambda2/simplify/flow/mutable_unboxing.ml @@ -477,7 +477,7 @@ module Fold_prims = struct let name = Variable.unique_name block_needed in let var = Variable.create (Printf.sprintf "%s_%i" name i) in Bound_parameter.create var kind - Flambda_uid.internal_not_actually_unique + Flambda_debug_uid.internal_not_actually_unique (* CR tnowak: verify *)) fields_kinds in diff --git a/middle_end/flambda2/simplify/inlining/inlining_transforms.ml b/middle_end/flambda2/simplify/inlining/inlining_transforms.ml index f572d53585d..510f644643b 100644 --- a/middle_end/flambda2/simplify/inlining/inlining_transforms.ml +++ b/middle_end/flambda2/simplify/inlining/inlining_transforms.ml @@ -46,7 +46,8 @@ 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? *) + Flambda_debug_uid.internal_not_actually_unique + (* CR tnowak: maybe here? *) in let bind_params ~params ~args ~body = if List.compare_lengths params args <> 0 @@ -67,7 +68,7 @@ let make_inlined_body ~callee ~called_code_id ~unroll_to ~params ~args let bind_depth ~my_depth ~rec_info ~body = let bound = Bound_pattern.singleton - (VB.create my_depth Flambda_uid.internal_not_actually_unique + (VB.create my_depth Flambda_debug_uid.internal_not_actually_unique Name_mode.normal) in Let.create bound diff --git a/middle_end/flambda2/simplify/lifted_cont_params.ml b/middle_end/flambda2/simplify/lifted_cont_params.ml index ab53b063bbd..107ef1c75df 100644 --- a/middle_end/flambda2/simplify/lifted_cont_params.ml +++ b/middle_end/flambda2/simplify/lifted_cont_params.ml @@ -39,7 +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 *) + Flambda_debug_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_expr.ml b/middle_end/flambda2/simplify/simplify_apply_expr.ml index c2a8794a67e..fc478f8b49e 100644 --- a/middle_end/flambda2/simplify/simplify_apply_expr.ml +++ b/middle_end/flambda2/simplify/simplify_apply_expr.ml @@ -165,7 +165,7 @@ let simplify_direct_tuple_application ~simplify_expr dacc apply List.fold_right (fun (v, defining_expr) body -> let var_bind = - Bound_var.create v Flambda_uid.internal_not_actually_unique + Bound_var.create v Flambda_debug_uid.internal_not_actually_unique Name_mode.normal in Let.create @@ -481,7 +481,8 @@ let simplify_direct_partial_application ~simplify_expr dacc apply (fun kind -> let param = Variable.create "param" in Bound_parameter.create param kind - Flambda_uid.internal_not_actually_unique (* CR sspies: fix *)) + Flambda_debug_uid.internal_not_actually_unique + (* CR sspies: fix *)) (Flambda_arity.unarize remaining_param_arity) |> Bound_parameters.create in @@ -600,7 +601,7 @@ 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 + VB.create var Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) Name_mode.normal in let prim = @@ -712,7 +713,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 + VB.create wrapper_var Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) Name_mode.normal in let bound_vars = [wrapper_var] in diff --git a/middle_end/flambda2/simplify/simplify_common.ml b/middle_end/flambda2/simplify/simplify_common.ml index 2050beea532..5b04fad41d0 100644 --- a/middle_end/flambda2/simplify/simplify_common.ml +++ b/middle_end/flambda2/simplify/simplify_common.ml @@ -187,8 +187,8 @@ let split_direct_over_application apply (fun i kind -> BP.create (Variable.create ("result" ^ string_of_int i)) - kind - Flambda_uid.internal_not_actually_unique (* CR tnowak: verify *)) + kind Flambda_debug_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 = @@ -209,7 +209,7 @@ let split_direct_over_application apply Let.create (Bound_pattern.singleton (Bound_var.create (Variable.create "unit") - Flambda_uid.internal_not_actually_unique Name_mode.normal)) + Flambda_debug_uid.internal_not_actually_unique Name_mode.normal)) (Named.create_prim (Unary (End_region { ghost = false }, Simple.var region)) (Apply.dbg apply)) @@ -217,7 +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 + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) Name_mode.normal)) (Named.create_prim (Unary (End_region { ghost = true }, Simple.var ghost_region)) @@ -250,7 +250,7 @@ let split_direct_over_application apply let after_full_application_handler = let func_param = BP.create func_var K.With_subkind.any_value - Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *) + Flambda_debug_uid.internal_not_actually_unique (* CR tnowak: maybe? *) in Continuation_handler.create (Bound_parameters.create [func_param]) @@ -285,7 +285,7 @@ let split_direct_over_application apply in Let.create (Bound_pattern.singleton - (Bound_var.create region Flambda_uid.internal_not_actually_unique + (Bound_var.create region Flambda_debug_uid.internal_not_actually_unique (* CR tnowak: verify *) Name_mode.normal)) (Named.create_prim (Variadic (Begin_region { ghost = false }, [])) @@ -294,7 +294,7 @@ let split_direct_over_application apply (Let.create (Bound_pattern.singleton (Bound_var.create ghost_region - Flambda_uid.internal_not_actually_unique + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) Name_mode.normal)) (Named.create_prim (Variadic (Begin_region { ghost = false }, [])) diff --git a/middle_end/flambda2/simplify/simplify_extcall.ml b/middle_end/flambda2/simplify/simplify_extcall.ml index 345e2c1718c..026f9e85e6a 100644 --- a/middle_end/flambda2/simplify/simplify_extcall.ml +++ b/middle_end/flambda2/simplify/simplify_extcall.ml @@ -45,7 +45,8 @@ let apply_cont cont v ~dbg = let let_prim ~dbg v prim (free_names, body) = let v' = - Bound_var.create v Flambda_uid.internal_not_actually_unique Name_mode.normal + Bound_var.create v Flambda_debug_uid.internal_not_actually_unique + Name_mode.normal in let bindable = Bound_pattern.singleton v' in let named = Named.create_prim prim dbg in diff --git a/middle_end/flambda2/simplify/simplify_let_cont_expr.ml b/middle_end/flambda2/simplify/simplify_let_cont_expr.ml index 7b3c27f84cf..7ff400c6068 100644 --- a/middle_end/flambda2/simplify/simplify_let_cont_expr.ml +++ b/middle_end/flambda2/simplify/simplify_let_cont_expr.ml @@ -262,7 +262,8 @@ let extra_params_for_continuation_param_aliases cont uacc rewrite_ids = EPA.add ~extra_param: (Bound_parameter.create var var_kind - Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *)) + Flambda_debug_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 @@ -506,7 +507,7 @@ let add_lets_around_handler cont at_unit_toplevel uacc handler = let bound_pattern = (* CR tnowak: verify *) Bound_pattern.singleton - (Bound_var.create var Flambda_uid.internal_not_actually_unique + (Bound_var.create var Flambda_debug_uid.internal_not_actually_unique Name_mode.normal) in let named = Named.create_simple (Simple.var bound_to) in diff --git a/middle_end/flambda2/simplify/simplify_set_of_closures.ml b/middle_end/flambda2/simplify/simplify_set_of_closures.ml index e7a1183718e..67e72e6cf69 100644 --- a/middle_end/flambda2/simplify/simplify_set_of_closures.ml +++ b/middle_end/flambda2/simplify/simplify_set_of_closures.ml @@ -46,8 +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 Flambda_uid.internal_not_actually_unique - NM.normal) + (Bound_var.create my_closure + Flambda_debug_uid.internal_not_actually_unique NM.normal) (T.unknown K.value) | Some function_slot -> ( match @@ -63,8 +63,8 @@ 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 + Flambda_debug_uid.internal_not_actually_unique NM.normal) (T.alias_type_of K.value (Simple.name name))) in let denv = @@ -72,8 +72,8 @@ let dacc_inside_function context ~outer_dacc ~params ~my_closure ~my_region | None -> denv | Some my_region -> let my_region = - Bound_var.create my_region Flambda_uid.internal_not_actually_unique - Name_mode.normal + Bound_var.create my_region + Flambda_debug_uid.internal_not_actually_unique Name_mode.normal in DE.add_variable denv my_region (T.unknown K.region) in @@ -83,13 +83,13 @@ let dacc_inside_function context ~outer_dacc ~params ~my_closure ~my_region | Some my_ghost_region -> let my_ghost_region = Bound_var.create my_ghost_region - Flambda_uid.internal_not_actually_unique Name_mode.normal + Flambda_debug_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 Flambda_uid.internal_not_actually_unique + Bound_var.create my_depth Flambda_debug_uid.internal_not_actually_unique Name_mode.normal in DE.add_variable denv my_depth (T.unknown K.rec_info) @@ -201,7 +201,8 @@ let simplify_function_body context ~outer_dacc function_slot_opt | None -> [] | Some region -> [ Bound_parameter.create region Flambda_kind.With_subkind.region - Flambda_uid.internal_not_actually_unique (* CR sspies: fix *) ] + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) + ] in region_param my_region @ region_param my_ghost_region in @@ -212,9 +213,9 @@ let simplify_function_body context ~outer_dacc function_slot_opt (Bound_parameters.create ([ Bound_parameter.create my_closure Flambda_kind.With_subkind.any_value - Flambda_uid.internal_not_actually_unique; + Flambda_debug_uid.internal_not_actually_unique; Bound_parameter.create my_depth Flambda_kind.With_subkind.rec_info - Flambda_uid.internal_not_actually_unique ] + Flambda_debug_uid.internal_not_actually_unique ] @ region_params)) ~loopify_state ~params with @@ -389,7 +390,7 @@ let simplify_function0 context ~outer_dacc function_slot_opt code_id code BP.create (Variable.create ("result" ^ string_of_int i)) kind_with_subkind - Flambda_uid.internal_not_actually_unique (* CR tnowak: verify *)) + Flambda_debug_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 9118ea41525..e9a02ba9c9a 100644 --- a/middle_end/flambda2/simplify/simplify_switch_expr.ml +++ b/middle_end/flambda2/simplify/simplify_switch_expr.ml @@ -343,15 +343,16 @@ let rebuild_switch_with_single_arg_to_same_destination uacc ~dacc_before_switch | Must_untag -> let bound = BPt.singleton - (BV.create final_arg_var Flambda_uid.internal_not_actually_unique - NM.normal) + (BV.create final_arg_var + Flambda_debug_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 Flambda_uid.internal_not_actually_unique NM.normal) + (BV.create arg_var Flambda_debug_uid.internal_not_actually_unique + NM.normal) in RE.create_let rebuilding bound load_from_block ~body ~free_names_of_body in @@ -520,8 +521,8 @@ 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 + Flambda_debug_uid.internal_not_actually_unique NM.normal |> Bound_pattern.singleton in let apply_cont = @@ -649,7 +650,7 @@ let simplify_switch ~simplify_let ~simplify_function_body dacc switch Let.create (Bound_pattern.singleton (Bound_var.create tagged_scrutinee - Flambda_uid.internal_not_actually_unique NM.normal)) + Flambda_debug_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 22ce453d375..21de76d0827 100644 --- a/middle_end/flambda2/simplify/simplify_unary_primitive.ml +++ b/middle_end/flambda2/simplify/simplify_unary_primitive.ml @@ -721,7 +721,7 @@ let simplify_obj_dup dbg dacc ~original_term ~arg ~arg_ty ~result_var = { Expr_builder.let_bound = Bound_pattern.singleton (Bound_var.create contents_var - Flambda_uid.internal_not_actually_unique NM.normal); + Flambda_debug_uid.internal_not_actually_unique NM.normal); simplified_defining_expr = Simplified_named.create contents_expr; original_defining_expr = None } @@ -730,7 +730,7 @@ let simplify_obj_dup dbg dacc ~original_term ~arg ~arg_ty ~result_var = let dacc = DA.add_variable dacc (Bound_var.create contents_var - Flambda_uid.internal_not_actually_unique NM.normal) + Flambda_debug_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 649932b691d..6d2881cd093 100644 --- a/middle_end/flambda2/simplify/unboxing/build_unboxing_denv.ml +++ b/middle_end/flambda2/simplify/unboxing/build_unboxing_denv.ml @@ -28,7 +28,7 @@ let add_equation_on_var denv var shape = let denv_of_number_decision naked_kind shape param_var naked_var denv : DE.t = (* CR tnowak: verify *) let naked_name = - VB.create naked_var Flambda_uid.internal_not_actually_unique + VB.create naked_var Flambda_debug_uid.internal_not_actually_unique Name_mode.normal in let denv = DE.define_variable denv naked_name naked_kind in @@ -42,7 +42,7 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = 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 + VB.create var Flambda_debug_uid.internal_not_actually_unique Name_mode.normal in DE.define_variable denv v (K.Block_shape.element_kind shape index)) @@ -69,7 +69,7 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = (fun _ ({ epa = { param = var; _ }; kind; _ } : U.field_decision) denv -> (* CR tnowak: verify *) let v = - VB.create var Flambda_uid.internal_not_actually_unique + VB.create var Flambda_debug_uid.internal_not_actually_unique Name_mode.normal in DE.define_variable denv v (K.With_subkind.kind kind)) @@ -94,7 +94,7 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = (* Adapt the denv for the tag *) (* CR tnowak: verify *) let tag_v = - VB.create tag.param Flambda_uid.internal_not_actually_unique + VB.create tag.param Flambda_debug_uid.internal_not_actually_unique Name_mode.normal in let denv = DE.define_variable denv tag_v K.naked_immediate in @@ -114,7 +114,7 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = | At_least_one { is_int; _ } -> (* CR tnowak: verify *) let is_int_v = - VB.create is_int.param Flambda_uid.internal_not_actually_unique + VB.create is_int.param Flambda_debug_uid.internal_not_actually_unique Name_mode.normal in let denv = DE.define_variable denv is_int_v K.naked_immediate in @@ -140,8 +140,8 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = | At_least_one { ctor = Unbox (Number (Naked_immediate, ctor_epa)); _ } -> (* CR tnowak: verify *) let v = - VB.create ctor_epa.param Flambda_uid.internal_not_actually_unique - Name_mode.normal + VB.create ctor_epa.param + Flambda_debug_uid.internal_not_actually_unique Name_mode.normal in let denv = DE.define_variable denv v K.naked_immediate in let ty = @@ -168,7 +168,7 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = 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 + VB.create var Flambda_debug_uid.internal_not_actually_unique Name_mode.normal in DE.define_variable denv v (K.Block_shape.element_kind shape index)) diff --git a/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml b/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml index bdeb41b2118..8fa52cb5b19 100644 --- a/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml +++ b/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml @@ -422,7 +422,8 @@ 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? *) + Flambda_debug_uid.internal_not_actually_unique + (* CR tnowak: maybe? *) in let extra_params_and_args = EPA.add extra_params_and_args ~invalids ~extra_param @@ -436,7 +437,8 @@ let add_extra_params_and_args extra_params_and_args ~invalids decision = extra_params_and_args -> let extra_param = BP.create epa.param kind - Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *) + Flambda_debug_uid.internal_not_actually_unique + (* CR tnowak: maybe? *) in let extra_params_and_args = EPA.add extra_params_and_args ~invalids ~extra_param @@ -453,7 +455,7 @@ let add_extra_params_and_args extra_params_and_args ~invalids decision = ({ epa; decision; kind } : U.field_decision) -> let extra_param = BP.create epa.param kind - Flambda_uid.internal_not_actually_unique + Flambda_debug_uid.internal_not_actually_unique (* CR tnowak: maybe? *) in let extra_params_and_args = @@ -470,7 +472,8 @@ 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? *) + Flambda_debug_uid.internal_not_actually_unique + (* CR tnowak: maybe? *) in EPA.add extra_params_and_args ~invalids ~extra_param ~extra_args:is_int.args @@ -478,7 +481,8 @@ 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? *) + Flambda_debug_uid.internal_not_actually_unique + (* CR tnowak: maybe? *) in let extra_params_and_args = EPA.add extra_params_and_args ~invalids ~extra_param @@ -486,7 +490,8 @@ 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? *) + Flambda_debug_uid.internal_not_actually_unique + (* CR tnowak: maybe? *) in EPA.add extra_params_and_args ~invalids ~extra_param ~extra_args:ctor.args @@ -506,7 +511,7 @@ let add_extra_params_and_args extra_params_and_args ~invalids decision = in let extra_param = BP.create tag.param K.With_subkind.naked_immediate - Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *) + Flambda_debug_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)) -> @@ -515,7 +520,7 @@ let add_extra_params_and_args extra_params_and_args ~invalids decision = in let extra_param = BP.create epa.param kind_with_subkind - Flambda_uid.internal_not_actually_unique (* CR tnowak: maybe? *) + Flambda_debug_uid.internal_not_actually_unique (* CR tnowak: maybe? *) in EPA.add extra_params_and_args ~invalids ~extra_param ~extra_args:epa.args in diff --git a/middle_end/flambda2/simplify_shared/inlining_helpers.ml b/middle_end/flambda2/simplify_shared/inlining_helpers.ml index ef31708d858..9670d15c9bc 100644 --- a/middle_end/flambda2/simplify_shared/inlining_helpers.ml +++ b/middle_end/flambda2/simplify_shared/inlining_helpers.ml @@ -92,7 +92,8 @@ let wrap_inlined_body_for_exn_extra_args acc ~extra_args ~apply_exn_continuation (fun k -> Bound_parameter.create (Variable.create "wrapper_return") - k Flambda_uid.internal_not_actually_unique (* CR tnowak: verify *)) + k Flambda_debug_uid.internal_not_actually_unique + (* CR tnowak: verify *)) (Flambda_arity.unarized_components result_arity) in let trap_action = @@ -110,7 +111,8 @@ let wrap_inlined_body_for_exn_extra_args acc ~extra_args ~apply_exn_continuation let param = Variable.create "exn" in let wrapper_handler_params = [ Bound_parameter.create param Flambda_kind.With_subkind.any_value - Flambda_uid.internal_not_actually_unique (* CR tnowak: verify *) ] + Flambda_debug_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 964119abe46..425c29cecee 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.internal_not_actually_unique 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 b74708e2981..75266185f16 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 @@ -445,7 +445,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? *) + Flambda_debug_uid.internal_not_actually_unique (* CR tnowak: maybe? *) in Bound_parameters.append params (Bound_parameters.create [my_closure_param]) @@ -472,7 +472,8 @@ let params_and_body0 env res code_id ~result_arity ~fun_dbg let env, region = Env.create_bound_parameter env ( my_region, - Flambda_uid.internal_not_actually_unique (* CR sspies: fix *) ) + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) + ) in env, Some region in @@ -484,7 +485,8 @@ let params_and_body0 env res code_id ~result_arity ~fun_dbg let env, region = Env.create_bound_parameter env ( my_ghost_region, - Flambda_uid.internal_not_actually_unique (* CR sspies: fix *) ) + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) + ) in env, Some region in @@ -733,7 +735,7 @@ let let_dynamic_set_of_closures0 env res ~body ~bound_vars set let soc_var = Bound_var.create (Variable.create "*set_of_closures*") - Flambda_uid.internal_not_actually_unique Name_mode.normal + Flambda_debug_uid.internal_not_actually_unique Name_mode.normal in let defining_expr = Env.simple csoc free_vars in let env, res = diff --git a/middle_end/flambda2/types/env/join_env.ml b/middle_end/flambda2/types/env/join_env.ml index f3494f4c885..9cef69e8f5d 100644 --- a/middle_end/flambda2/types/env/join_env.ml +++ b/middle_end/flambda2/types/env/join_env.ml @@ -1193,7 +1193,8 @@ 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 + (Bound_var.create var + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) Name_mode.in_types)) kind) extra_variables target_env diff --git a/middle_end/flambda2/types/equal_types_for_debug.ml b/middle_end/flambda2/types/equal_types_for_debug.ml index 1aef8a19165..c6216c92688 100644 --- a/middle_end/flambda2/types/equal_types_for_debug.ml +++ b/middle_end/flambda2/types/equal_types_for_debug.ml @@ -464,7 +464,8 @@ let names_with_non_equal_types_level_ignoring_name_mode ~meet_type env level1 TE.add_definition left_env (Bound_name.create_var (Bound_var.create var - Flambda_uid.internal_not_actually_unique (* CR sspies: fix *) + Flambda_debug_uid.internal_not_actually_unique + (* CR sspies: fix *) Name_mode.in_types)) kind) level1 env @@ -475,7 +476,8 @@ let names_with_non_equal_types_level_ignoring_name_mode ~meet_type env level1 TE.add_definition right_env (Bound_name.create_var (Bound_var.create var - Flambda_uid.internal_not_actually_unique (* CR sspies: fix *) + Flambda_debug_uid.internal_not_actually_unique + (* CR sspies: fix *) 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..7e571738ba7 100644 --- a/middle_end/flambda2/types/join_levels_old.ml +++ b/middle_end/flambda2/types/join_levels_old.ml @@ -47,7 +47,7 @@ let join_types ~env_at_fork envs_with_levels = TE.add_definition base_env (Bound_name.create_var (Bound_var.create var - Flambda_uid.internal_not_actually_unique + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) Name_mode.in_types)) kind) vars base_env) 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 fe1b848447f..a837230d611 100644 --- a/middle_end/flambda2/types/meet_and_n_way_join.ml +++ b/middle_end/flambda2/types/meet_and_n_way_join.ml @@ -284,7 +284,7 @@ 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 + (Bound_var.create var Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) Name_mode.in_types)) kind) level env @@ -1226,7 +1226,8 @@ 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 + (Bound_var.create var + Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) Name_mode.in_types)) kind) !extra_variables result_env From ce32e64c9d8286e749f63f4a309a1b83c7d66562 Mon Sep 17 00:00:00 2001 From: Simon Spies Date: Wed, 30 Apr 2025 15:46:39 +0100 Subject: [PATCH 4/9] rename debug uid constructors --- .../from_lambda/closure_conversion.ml | 104 ++++++------------ .../flambda2/from_lambda/lambda_to_flambda.ml | 86 ++++++++------- .../from_lambda/lambda_to_flambda_env.ml | 9 +- .../lambda_to_flambda_primitives_helpers.ml | 15 +-- .../flambda2/identifiers/flambda_debug_uid.ml | 10 +- .../identifiers/flambda_debug_uid.mli | 12 +- .../flambda2/parser/fexpr_to_flambda.ml | 12 +- .../flambda2/simplify/apply_cont_rewrite.ml | 6 +- .../common_subexpression_elimination.ml | 2 +- .../flambda2/simplify/env/downwards_env.ml | 19 ++-- middle_end/flambda2/simplify/expr_builder.ml | 9 +- .../simplify/flow/mutable_unboxing.ml | 3 +- .../simplify/inlining/inlining_transforms.ml | 5 +- .../flambda2/simplify/lifted_cont_params.ml | 2 +- .../flambda2/simplify/simplify_apply_expr.ml | 10 +- .../flambda2/simplify/simplify_common.ml | 15 ++- .../flambda2/simplify/simplify_extcall.ml | 5 +- .../simplify/simplify_let_cont_expr.ml | 6 +- .../simplify/simplify_set_of_closures.ml | 26 ++--- .../flambda2/simplify/simplify_switch_expr.ml | 13 +-- .../simplify/simplify_unary_primitive.ml | 6 +- .../simplify/unboxing/build_unboxing_denv.ml | 29 ++--- .../simplify/unboxing/unboxing_epa.ml | 19 ++-- .../simplify_shared/inlining_helpers.ml | 5 +- middle_end/flambda2/terms/flambda.ml | 2 +- middle_end/flambda2/tests/meet_test.ml | 42 ++----- middle_end/flambda2/to_cmm/to_cmm.ml | 6 +- .../flambda2/to_cmm/to_cmm_set_of_closures.ml | 12 +- middle_end/flambda2/types/env/join_env.ml | 3 +- .../flambda2/types/equal_types_for_debug.ml | 6 +- middle_end/flambda2/types/join_levels_old.ml | 3 +- .../flambda2/types/meet_and_n_way_join.ml | 5 +- 32 files changed, 189 insertions(+), 318 deletions(-) diff --git a/middle_end/flambda2/from_lambda/closure_conversion.ml b/middle_end/flambda2/from_lambda/closure_conversion.ml index f06c6752c1e..430efc6ba1d 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion.ml @@ -355,16 +355,14 @@ module Inlining = struct Let_with_acc.create acc (* CR tnowak: verify *) (Bound_pattern.singleton - (VB.create param Flambda_debug_uid.internal_not_actually_unique - Name_mode.normal)) + (VB.create param Flambda_debug_uid.none 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_debug_uid.internal_not_actually_unique - Name_mode.normal)) + (VB.create my_depth Flambda_debug_uid.none Name_mode.normal)) (Named.create_rec_info rec_info) ~body in @@ -390,7 +388,7 @@ module Inlining = struct (Bound_pattern.singleton (VB.create (Variable.create "inlined_dbg") - Flambda_debug_uid.internal_not_actually_unique Name_mode.normal)) + Flambda_debug_uid.none Name_mode.normal)) (Named.create_prim (Nullary (Enter_inlined_apply { dbg = inlined_debuginfo })) Debuginfo.none) @@ -690,8 +688,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds | [arg] -> let result = Variable.create "reinterpreted" in let result' = - Bound_var.create result - Flambda_debug_uid.internal_not_actually_unique Name_mode.normal + Bound_var.create result Flambda_debug_uid.none Name_mode.normal in let bindable = Bound_pattern.singleton result' in let prim = P.Unary (Reinterpret_64_bit_word op, arg) in @@ -745,8 +742,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds fun args acc -> let unboxed_arg = Variable.create "unboxed" in let unboxed_arg' = - VB.create unboxed_arg - Flambda_debug_uid.internal_not_actually_unique Name_mode.normal + VB.create unboxed_arg Flambda_debug_uid.none 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 @@ -761,7 +757,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds (fun ret_value { kind; _ } -> BP.create ret_value (K.With_subkind.anything kind) - Flambda_debug_uid.internal_not_actually_unique + Flambda_debug_uid.none (* CR tnowak: verify *)) handler_params unarized_results |> Bound_parameters.create @@ -780,8 +776,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds let let_bound_vars' = List.map (fun let_bound_var -> - VB.create let_bound_var Flambda_debug_uid.internal_not_actually_unique - Name_mode.normal) + VB.create let_bound_var Flambda_debug_uid.none Name_mode.normal) let_bound_vars in let handler_params = @@ -888,7 +883,7 @@ let close_effect_primitive acc env ~dbg exn_continuation let return_kind = Flambda_kind.With_subkind.any_value in let params = [ BP.create let_bound_var return_kind - Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) ] + Flambda_debug_uid.none (* CR sspies: fix *) ] |> Bound_parameters.create in let close call_kind = @@ -1648,8 +1643,7 @@ let close_switch acc env ~condition_dbg scrutinee (sw : IR.switch) : let scrutinee = find_simple_from_id env scrutinee in let untagged_scrutinee = Variable.create "untagged" in let untagged_scrutinee' = - VB.create untagged_scrutinee Flambda_debug_uid.internal_not_actually_unique - Name_mode.normal + VB.create untagged_scrutinee Flambda_debug_uid.none Name_mode.normal in let known_const_scrutinee = match find_value_approximation_through_symbol acc env scrutinee with @@ -1690,8 +1684,7 @@ let close_switch acc env ~condition_dbg scrutinee (sw : IR.switch) : in let comparison_result = Variable.create "eq" in let comparison_result' = - VB.create comparison_result Flambda_debug_uid.internal_not_actually_unique - Name_mode.normal + VB.create comparison_result Flambda_debug_uid.none Name_mode.normal in let acc, default_action = let acc, args = find_simples acc env default_args in @@ -1863,8 +1856,7 @@ let compute_body_of_unboxed_function acc my_region my_closure (Bound_pattern.singleton (Bound_var.create (Bound_parameter.var param) - Flambda_debug_uid.internal_not_actually_unique - (* CR sspies: fix *) Name_mode.normal)) + Flambda_debug_uid.none (* CR sspies: fix *) Name_mode.normal)) (Named.create_prim (boxing_primitive k alloc_mode (List.map fst vars_with_kinds)) Debuginfo.none) @@ -1872,8 +1864,7 @@ let compute_body_of_unboxed_function acc my_region my_closure in ( List.map (fun (var, kind) -> - Bound_parameter.create var kind - Flambda_debug_uid.internal_not_actually_unique + Bound_parameter.create var kind Flambda_debug_uid.none (* CR sspies: fix *)) vars_with_kinds @ main_code_params, @@ -1921,8 +1912,7 @@ 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_debug_uid.internal_not_actually_unique + [ Bound_parameter.create boxed_variable return Flambda_debug_uid.none (* CR sspies: fix *) ] in let handler acc = @@ -1938,8 +1928,7 @@ 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 - Flambda_debug_uid.internal_not_actually_unique + (Bound_var.create var Flambda_debug_uid.none (* CR sspies: fix *) Name_mode.normal)) (Named.create_prim (unboxing_primitive k boxed_variable i) @@ -1965,8 +1954,7 @@ let compute_body_of_unboxed_function acc my_region my_closure let acc, unboxed_body = Let_with_acc.create acc (Bound_pattern.singleton - (Bound_var.create my_closure - Flambda_debug_uid.internal_not_actually_unique + (Bound_var.create my_closure Flambda_debug_uid.none (* CR sspies: fix *) Name_mode.normal)) (Named.create_prim (Flambda_primitive.Unary @@ -2046,8 +2034,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_debug_uid.internal_not_actually_unique + (Bound_var.create var Flambda_debug_uid.none (* CR sspies: fix *) Name_mode.normal)) named ~body ~free_names_of_body:(Known free_names_of_body)), @@ -2102,8 +2089,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_debug_uid.internal_not_actually_unique + (Bound_var.create main_closure Flambda_debug_uid.none (* CR sspies: fix *) Name_mode.normal)) projection ~body:(Expr.create_apply main_application) @@ -2127,8 +2113,7 @@ 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_debug_uid.internal_not_actually_unique + Bound_parameter.create var kind Flambda_debug_uid.none (* CR sspies: fix *)) (Flambda_arity.unarized_components result_arity_main_code)) in @@ -2147,8 +2132,7 @@ 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_debug_uid.internal_not_actually_unique + (Bound_var.create boxed_return Flambda_debug_uid.none (* CR sspies: fix *) Name_mode.normal)) box_result_named ~body:(Expr.create_apply_cont return_apply_cont) @@ -2426,7 +2410,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_debug_uid.internal_not_actually_unique + BP.create var p.kind Flambda_debug_uid.none (* CR sspies: fix *)) unarized_params |> Bound_parameters.create @@ -2460,10 +2444,7 @@ 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_debug_uid.internal_not_actually_unique - Name_mode.normal - in + let var = VB.create var Flambda_debug_uid.none Name_mode.normal in let named = Named.create_prim (Unary (move, my_closure')) Debuginfo.none in @@ -2473,10 +2454,7 @@ 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_debug_uid.internal_not_actually_unique - Name_mode.normal - in + let var = VB.create var Flambda_debug_uid.none Name_mode.normal in let named = Named.create_prim (Unary @@ -2491,8 +2469,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_debug_uid.internal_not_actually_unique Name_mode.normal) + (Bound_var.create next_depth Flambda_debug_uid.none Name_mode.normal) in Let_with_acc.create acc bound (Named.create_rec_info next_depth_expr) ~body in @@ -2913,7 +2890,7 @@ let close_let_rec acc env ~function_declarations (* CR tnowak: verify *) VB.create (fst (Env.find_var env ident)) - Flambda_debug_uid.internal_not_actually_unique Name_mode.normal + Flambda_debug_uid.none Name_mode.normal in let function_slot = Function_decl.function_slot decl in ( Function_slot.Map.add function_slot fun_var fun_vars_map, @@ -2978,7 +2955,7 @@ let close_let_rec acc env ~function_declarations let fun_var = VB.create (Variable.create "generated") - Flambda_debug_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 @@ -3041,9 +3018,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_debug_uid.internal_not_actually_unique - (* CR tnowak: verify *); + var_uid = Flambda_debug_uid.none (* CR tnowak: verify *); kind; attributes = Lambda.default_param_attribute; mode = Alloc_mode.For_types.to_lambda mode @@ -3128,8 +3103,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_debug_uid.internal_not_actually_unique - ~function_slot + ~let_rec_uid:Flambda_debug_uid.none ~function_slot ~kind: (Lambda.Curried { nlocal = @@ -3223,7 +3197,7 @@ let wrap_over_application acc env full_call (apply : IR.apply) ~remaining (fun i kind -> BP.create (Variable.create ("result" ^ string_of_int i)) - kind Flambda_debug_uid.internal_not_actually_unique + kind Flambda_debug_uid.none (* CR tnowak: verify *)) (Flambda_arity.unarized_components apply.return_arity) in @@ -3239,8 +3213,7 @@ 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_debug_uid.internal_not_actually_unique + (Bound_var.create (Variable.create "unit") Flambda_debug_uid.none (* CR sspies: fix *) Name_mode.normal)) (Named.create_prim (Unary (End_region { ghost = true }, Simple.var ghost_region)) @@ -3249,8 +3222,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 (Variable.create "unit") - Flambda_debug_uid.internal_not_actually_unique + (Bound_var.create (Variable.create "unit") Flambda_debug_uid.none (* CR sspies: fix *) Name_mode.normal)) (Named.create_prim (Unary (End_region { ghost = false }, Simple.var region)) @@ -3270,7 +3242,7 @@ let wrap_over_application acc env full_call (apply : IR.apply) ~remaining Let_cont_with_acc.build_non_recursive acc wrapper_cont ~handler_params: ([ BP.create returned_func K.With_subkind.any_value - Flambda_debug_uid.internal_not_actually_unique + Flambda_debug_uid.none (* CR tnowak: maybe? *) ] |> Bound_parameters.create) ~handler:perform_over_application ~body ~is_exn_handler:false @@ -3282,8 +3254,7 @@ 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 - Flambda_debug_uid.internal_not_actually_unique + (Bound_var.create ghost_region Flambda_debug_uid.none (* CR sspies: fix *) Name_mode.normal)) (Named.create_prim (Variadic (Begin_region { ghost = true }, [])) @@ -3292,8 +3263,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_debug_uid.internal_not_actually_unique - Name_mode.normal)) + (Bound_var.create region Flambda_debug_uid.none Name_mode.normal)) (Named.create_prim (Variadic (Begin_region { ghost = false }, [])) apply_dbg) @@ -3617,10 +3587,7 @@ let wrap_final_module_block acc env ~program ~prog_return_cont List.fold_left (fun (acc, body) (pos, var) -> (* CR tnowak: verify *) - let var = - VB.create var Flambda_debug_uid.internal_not_actually_unique - Name_mode.normal - in + let var = VB.create var Flambda_debug_uid.none 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 @@ -3642,8 +3609,7 @@ let wrap_final_module_block acc env ~program ~prog_return_cont in let load_fields_handler_param = [ BP.create module_block_var K.With_subkind.any_value - Flambda_debug_uid.internal_not_actually_unique (* CR tnowak: maybe? *) - ] + Flambda_debug_uid.none (* 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/lambda_to_flambda.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml index acd2575c425..fd90a08fc67 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml @@ -137,15 +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_debug_uid.internal_not_actually_unique - (* CR sspies: fix *), + Flambda_debug_uid.none (* 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_debug_uid.internal_not_actually_unique, + Flambda_debug_uid.none, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region @@ -205,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_debug_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 _ -> @@ -217,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_debug_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 @@ -281,15 +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_debug_uid.internal_not_actually_unique (* CR sspies: fix *), + Flambda_debug_uid.none (* 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_debug_uid.internal_not_actually_unique - (* CR sspies: fix*), + Flambda_debug_uid.none (* CR sspies: fix*), Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region @@ -375,7 +375,7 @@ let wrap_return_continuation acc env ccenv (apply : IR.apply) = List.map2 (fun return_value_component kind -> ( return_value_component, - Flambda_debug_uid.internal_not_actually_unique, + Flambda_debug_uid.none, IR.Not_user_visible, kind )) return_value_components return_kinds @@ -450,7 +450,7 @@ 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_debug_uid.internal_not_actually_unique in + let duid = Flambda_debug_uid.none in CC.close_let acc ccenv [id, duid, kind] Not_user_visible (IR.Simple simple) ~body:(body id) @@ -507,8 +507,7 @@ 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 - ~fuid:Flambda_debug_uid.internal_not_actually_unique + cps_function env ~fid:id ~fuid:Flambda_debug_uid.none ~recursive:(Non_recursive : Recursive.t) func in @@ -534,7 +533,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let env, new_id = Env.register_mutable_variable env id kind in let body acc ccenv = cps acc env ccenv body k k_exn in CC.close_let acc ccenv - [new_id, Flambda_debug_uid.uid duid, kind] + [new_id, Flambda_debug_uid.of_lambda_debug_uid duid, kind] User_visible (Simple (Var temp_id)) ~body) | Llet ((Strict | Alias | StrictOpt), _, fun_id, duid, Lfunction func, body) -> @@ -561,7 +560,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) layout in CC.close_let acc ccenv - [id, Flambda_debug_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), @@ -596,7 +595,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) -> ( env, [ ( id, - Flambda_debug_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 -> @@ -609,7 +608,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let fields = List.mapi (fun n (id, kind) -> - let duid = Flambda_debug_uid.proj duid ~field:n in + let duid = + Flambda_debug_uid.of_lambda_debug_uid_proj duid ~field:n + in id, duid, kind) (Flambda_arity.fresh_idents_unarized ~id arity) in @@ -656,7 +657,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_debug_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 @@ -664,7 +665,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) snd (Env.get_mutable_variable_with_kind env being_assigned) in CC.close_let acc ccenv - [new_id, Flambda_debug_uid.internal_not_actually_unique, value_kind] + [new_id, Flambda_debug_uid.none, value_kind] User_visible (Simple new_value) ~body) k_exn | Llet @@ -790,7 +791,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) (fun handler_env ((arg, duid, layout), kinds) -> match kinds with | [] -> handler_env, [] - | [kind] -> handler_env, [arg, Flambda_debug_uid.uid duid, kind] + | [kind] -> + ( handler_env, + [arg, Flambda_debug_uid.of_lambda_debug_uid duid, kind] ) | _ :: _ -> let fields = List.mapi @@ -800,7 +803,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_debug_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 @@ -898,7 +904,7 @@ 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_debug_uid.internal_not_actually_unique, + Flambda_debug_uid.none, Flambda_kind.With_subkind.tagged_immediate ) ] (* CR sspies: can we do better? *) Not_user_visible @@ -906,7 +912,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_debug_uid.internal_not_actually_unique, + Flambda_debug_uid.none, (* CR sspies: can we do better? *) Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible @@ -917,9 +923,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_debug_uid.internal_not_actually_unique, - Flambda_kind.With_subkind.region ) ] + [region, Flambda_debug_uid.none, Flambda_kind.With_subkind.region] Not_user_visible (Begin_region { is_try_region = true; @@ -930,7 +934,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_debug_uid.internal_not_actually_unique, + Flambda_debug_uid.none, Flambda_kind.With_subkind.region ) ] Not_user_visible (Begin_region @@ -1024,7 +1028,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) Env.get_mutable_variable_with_kind env being_assigned in CC.close_let acc ccenv - [new_id, Flambda_debug_uid.internal_not_actually_unique, value_kind] + [new_id, Flambda_debug_uid.none, value_kind] User_visible (Simple new_value) ~body) k_exn | Levent (body, _event) -> cps acc env ccenv body k k_exn @@ -1047,15 +1051,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_debug_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_debug_uid.internal_not_actually_unique - (* CR sspies: fix *), + Flambda_debug_uid.none (* CR sspies: fix *), Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region @@ -1075,9 +1078,7 @@ 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_debug_uid.internal_not_actually_unique, - Flambda_kind.With_subkind.region ) ] + [region, Flambda_debug_uid.none, Flambda_kind.With_subkind.region] Not_user_visible (Begin_region { is_try_region = false; @@ -1088,8 +1089,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_debug_uid.internal_not_actually_unique - (* CR sspies: fix *), + Flambda_debug_uid.none (* CR sspies: fix *), Flambda_kind.With_subkind.region ) ] Not_user_visible (Begin_region @@ -1140,7 +1140,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_debug_uid.internal_not_actually_unique, + Flambda_debug_uid.none, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region @@ -1148,7 +1148,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_debug_uid.internal_not_actually_unique, + Flambda_debug_uid.none, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region @@ -1338,7 +1338,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_debug_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) @@ -1522,13 +1522,15 @@ and cps_function env ~fid ~fuid ~(recursive : Recursive.t) match kinds with | [] -> [] | [kind] -> - let var_uid = Flambda_debug_uid.uid var_uid in + let var_uid = Flambda_debug_uid.of_lambda_debug_uid var_uid in [{ name; var_uid; kind; mode; attributes }] | _ :: _ -> let fields = List.mapi (fun n kind -> - let duid = Flambda_debug_uid.proj var_uid ~field:n in + let duid = + Flambda_debug_uid.of_lambda_debug_uid_proj var_uid ~field:n + in let ident = Ident.create_local (Printf.sprintf "%s_unboxed%d" (Ident.unique_name name) n) @@ -1685,7 +1687,7 @@ and cps_switch acc env ccenv (switch : L.lambda_switch) ~condition_dbg in CC.close_let acc ccenv [ ( scrutinee_tag, - Flambda_debug_uid.internal_not_actually_unique, + Flambda_debug_uid.none, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (Get_tag scrutinee) ~body in @@ -1719,7 +1721,7 @@ and cps_switch acc env ccenv (switch : L.lambda_switch) ~condition_dbg in CC.close_let acc ccenv [ ( is_scrutinee_int, - Flambda_debug_uid.internal_not_actually_unique, + Flambda_debug_uid.none, 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 d266bffeb2c..1f44e1eb4cb 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_env.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_env.ml @@ -214,10 +214,7 @@ let add_continuation t cont ~push_to_try_stack ~pop_region in let extra_params = List.map - (fun (id, kind) -> - ( id, - Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *), - kind )) + (fun (id, kind) -> id, Flambda_debug_uid.none (* CR sspies: fix *), kind) extra_params in { body_env; handler_env; extra_params } @@ -280,9 +277,7 @@ let extra_args_for_continuation_with_kinds t cont = | exception Not_found -> Misc.fatal_errorf "No current value for %a" Ident.print mut | current_value, kind -> - ( current_value, - Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *), - kind )) + current_value, Flambda_debug_uid.none (* CR sspies: fix *), kind) mutables let extra_args_for_continuation t cont = 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 66592cdcd20..c8b16e16da5 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 @@ -310,8 +310,7 @@ let rec bind_recs acc exn_cont ~register_const0 (prim : expr_primitive) | 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 - Flambda_debug_uid.internal_not_actually_unique Name_mode.normal + Bound_var.create cond_result Flambda_debug_uid.none Name_mode.normal in let ifso_cont = Continuation.create () in let ifnot_cont = Continuation.create () in @@ -323,7 +322,7 @@ let rec bind_recs acc exn_cont ~register_const0 (prim : expr_primitive) List.map2 (fun result_var result_kind -> Bound_parameter.create result_var result_kind - Flambda_debug_uid.internal_not_actually_unique (* CR sspies: new *)) + Flambda_debug_uid.none (* CR sspies: new *)) result_vars result_kinds in let result_simples = List.map Simple.var result_vars in @@ -355,8 +354,7 @@ let rec bind_recs acc exn_cont ~register_const0 (prim : expr_primitive) let result_pats = List.map (fun result_var -> - Bound_var.create result_var - Flambda_debug_uid.internal_not_actually_unique + Bound_var.create result_var Flambda_debug_uid.none (* CR sspies: fix *) Name_mode.normal) result_vars in @@ -396,8 +394,7 @@ 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_debug_uid.internal_not_actually_unique + Bound_var.create (Variable.create "seq") Flambda_debug_uid.none (* CR sspies: fix *) Name_mode.normal |> Bound_pattern.singleton in @@ -422,9 +419,7 @@ and bind_rec_primitive acc exn_cont ~register_const0 (prim : simple_or_prim) let vars = List.map (fun _ -> Variable.create "prim") nameds in let vars' = List.map - (fun var -> - VB.create var Flambda_debug_uid.internal_not_actually_unique - Name_mode.normal) + (fun var -> VB.create var Flambda_debug_uid.none Name_mode.normal) vars in let acc, body = cont acc (List.map Simple.var vars) in diff --git a/middle_end/flambda2/identifiers/flambda_debug_uid.ml b/middle_end/flambda2/identifiers/flambda_debug_uid.ml index 2c551b9618c..6e9071357a2 100644 --- a/middle_end/flambda2/identifiers/flambda_debug_uid.ml +++ b/middle_end/flambda2/identifiers/flambda_debug_uid.ml @@ -15,14 +15,14 @@ module Uid = Shape.Uid 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) module T0 = struct type nonrec t = t diff --git a/middle_end/flambda2/identifiers/flambda_debug_uid.mli b/middle_end/flambda2/identifiers/flambda_debug_uid.mli index ca81b6a2238..2fc29275a59 100644 --- a/middle_end/flambda2/identifiers/flambda_debug_uid.mli +++ b/middle_end/flambda2/identifiers/flambda_debug_uid.mli @@ -12,17 +12,17 @@ (* *) (**************************************************************************) -(** 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 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 76d398832fc..a8d725b54cc 100644 --- a/middle_end/flambda2/parser/fexpr_to_flambda.ml +++ b/middle_end/flambda2/parser/fexpr_to_flambda.ml @@ -626,8 +626,7 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = let var, env = fresh_var env var in (* CR tnowak: verify *) let var = - Bound_var.create var Flambda_debug_uid.internal_not_actually_unique - Name_mode.normal + Bound_var.create var Flambda_debug_uid.none Name_mode.normal in var, env in @@ -655,10 +654,7 @@ 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 Flambda_debug_uid.internal_not_actually_unique - Name_mode.normal - in + let var = Bound_var.create id Flambda_debug_uid.none 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 @@ -689,7 +685,7 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = let param = Bound_parameter.create var (value_kind_with_subkind_opt kind) - Flambda_debug_uid.internal_not_actually_unique + Flambda_debug_uid.none (* CR tnowak: verify *) in env, param :: args) @@ -906,7 +902,7 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = let param = Bound_parameter.create var (value_kind_with_subkind_opt kind) - Flambda_debug_uid.internal_not_actually_unique + Flambda_debug_uid.none (* CR tnowak: verify *) in param, env) diff --git a/middle_end/flambda2/simplify/apply_cont_rewrite.ml b/middle_end/flambda2/simplify/apply_cont_rewrite.ml index 710cf79d6f3..6ae292231cc 100644 --- a/middle_end/flambda2/simplify/apply_cont_rewrite.ml +++ b/middle_end/flambda2/simplify/apply_cont_rewrite.ml @@ -176,8 +176,7 @@ 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 - Flambda_debug_uid.internal_not_actually_unique + ( Bound_var.create temp Flambda_debug_uid.none (* CR sspies: fix *) Name_mode.normal, Code_size.prim prim, Flambda.Named.create_prim prim Debuginfo.none ) @@ -197,8 +196,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_debug_uid.internal_not_actually_unique + ( Bound_var.create temp Flambda_debug_uid.none (* CR sspies: fix *) Name_mode.normal, Code_size.prim prim, Flambda.Named.create_prim prim Debuginfo.none ) diff --git a/middle_end/flambda2/simplify/common_subexpression_elimination.ml b/middle_end/flambda2/simplify/common_subexpression_elimination.ml index b7f0db7e1be..8bf8c6bff4f 100644 --- a/middle_end/flambda2/simplify/common_subexpression_elimination.ml +++ b/middle_end/flambda2/simplify/common_subexpression_elimination.ml @@ -263,7 +263,7 @@ let join_one_cse_equation ~cse_at_each_use prim bound_to_map let extra_param = BP.create var (K.With_subkind.anything prim_result_kind) - Flambda_debug_uid.internal_not_actually_unique (* CR tnowak: verify *) + Flambda_debug_uid.none (* 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 5fc21fdb7fb..6ed91e6d9f2 100644 --- a/middle_end/flambda2/simplify/env/downwards_env.ml +++ b/middle_end/flambda2/simplify/env/downwards_env.ml @@ -144,8 +144,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_debug_uid.internal_not_actually_unique - (* CR sspies: fix *)) + Flambda_debug_uid.none (* CR sspies: fix *)) in variables_defined_in_current_continuation :: r in @@ -205,12 +204,10 @@ let create ~round ~(resolver : resolver) in define_variable (define_variable t - (Bound_var.create toplevel_my_region - Flambda_debug_uid.internal_not_actually_unique + (Bound_var.create toplevel_my_region Flambda_debug_uid.none (* CR sspies: fix *) Name_mode.normal) K.region) - (Bound_var.create toplevel_my_ghost_region - Flambda_debug_uid.internal_not_actually_unique + (Bound_var.create toplevel_my_ghost_region Flambda_debug_uid.none (* CR sspies: fix *) Name_mode.normal) K.region @@ -318,7 +315,7 @@ 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_debug_uid.internal_not_actually_unique + (Bound_var.create var Flambda_debug_uid.none (* CR sspies: fix *) (Bound_name.name_mode name)) kind) ~symbol:(fun [@inline] sym -> (define_symbol [@inlined hint]) t sym kind) @@ -340,7 +337,7 @@ 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_debug_uid.internal_not_actually_unique + (Bound_var.create var Flambda_debug_uid.none (* CR sspies: fix *) (Bound_name.name_mode name)) ty) ~symbol:(fun [@inline] sym -> add_symbol t sym ty) @@ -383,8 +380,7 @@ let define_parameters ~extra t ~params = (fun t param -> let param_var, _param_uid = BP.var_and_uid param in let var = - Bound_var.create param_var - Flambda_debug_uid.internal_not_actually_unique + Bound_var.create param_var Flambda_debug_uid.none (* CR sspies: fix *) Name_mode.normal in define_variable0 ~extra t var (K.With_subkind.kind (BP.kind param))) @@ -406,8 +402,7 @@ let add_parameters ~extra ?(name_mode = Name_mode.normal) t params ~param_types (fun t param param_type -> let param_var, _param_uid = BP.var_and_uid param in let var = - Bound_var.create param_var - Flambda_debug_uid.internal_not_actually_unique + Bound_var.create param_var Flambda_debug_uid.none (* CR sspies: fix *) name_mode in add_variable0 ~extra t var param_type) diff --git a/middle_end/flambda2/simplify/expr_builder.ml b/middle_end/flambda2/simplify/expr_builder.ml index a1aaf2a8e96..80b01d0bc16 100644 --- a/middle_end/flambda2/simplify/expr_builder.ml +++ b/middle_end/flambda2/simplify/expr_builder.ml @@ -285,8 +285,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_debug_uid.internal_not_actually_unique name_mode) + (VB.create uncoerced_var Flambda_debug_uid.none name_mode) in create_let uacc bound defining_expr ~free_names_of_defining_expr ~body ~cost_metrics_of_defining_expr @@ -571,8 +570,7 @@ let create_let_symbols uacc lifted_constant ~body = let expr, uacc, _ = create_coerced_singleton_let uacc (* CR tnowak: verify *) - (VB.create var Flambda_debug_uid.internal_not_actually_unique - Name_mode.normal) + (VB.create var Flambda_debug_uid.none Name_mode.normal) defining_expr ~coercion_from_defining_expr_to_var ~free_names_of_defining_expr ~body:expr ~cost_metrics_of_defining_expr in @@ -769,8 +767,7 @@ 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_debug_uid.internal_not_actually_unique + BP.create (Variable.create "param") kind Flambda_debug_uid.none (* CR tnowak: verify *)) (Flambda_arity.unarized_components arity) in diff --git a/middle_end/flambda2/simplify/flow/mutable_unboxing.ml b/middle_end/flambda2/simplify/flow/mutable_unboxing.ml index ae5b0550f16..75ae77fbf27 100644 --- a/middle_end/flambda2/simplify/flow/mutable_unboxing.ml +++ b/middle_end/flambda2/simplify/flow/mutable_unboxing.ml @@ -476,8 +476,7 @@ module Fold_prims = struct (fun i kind -> let name = Variable.unique_name block_needed in let var = Variable.create (Printf.sprintf "%s_%i" name i) in - Bound_parameter.create var kind - Flambda_debug_uid.internal_not_actually_unique + Bound_parameter.create var kind Flambda_debug_uid.none (* CR tnowak: verify *)) fields_kinds in diff --git a/middle_end/flambda2/simplify/inlining/inlining_transforms.ml b/middle_end/flambda2/simplify/inlining/inlining_transforms.ml index 510f644643b..bc9746a171c 100644 --- a/middle_end/flambda2/simplify/inlining/inlining_transforms.ml +++ b/middle_end/flambda2/simplify/inlining/inlining_transforms.ml @@ -46,7 +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_debug_uid.internal_not_actually_unique + Flambda_debug_uid.none (* CR tnowak: maybe here? *) in let bind_params ~params ~args ~body = @@ -68,8 +68,7 @@ let make_inlined_body ~callee ~called_code_id ~unroll_to ~params ~args let bind_depth ~my_depth ~rec_info ~body = let bound = Bound_pattern.singleton - (VB.create my_depth Flambda_debug_uid.internal_not_actually_unique - Name_mode.normal) + (VB.create my_depth Flambda_debug_uid.none 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 107ef1c75df..a289ec40fde 100644 --- a/middle_end/flambda2/simplify/lifted_cont_params.ml +++ b/middle_end/flambda2/simplify/lifted_cont_params.ml @@ -39,7 +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_debug_uid.internal_not_actually_unique (* CR sspies: fix *) + Flambda_debug_uid.none (* 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_expr.ml b/middle_end/flambda2/simplify/simplify_apply_expr.ml index fc478f8b49e..8bdcb799530 100644 --- a/middle_end/flambda2/simplify/simplify_apply_expr.ml +++ b/middle_end/flambda2/simplify/simplify_apply_expr.ml @@ -165,8 +165,7 @@ let simplify_direct_tuple_application ~simplify_expr dacc apply List.fold_right (fun (v, defining_expr) body -> let var_bind = - Bound_var.create v Flambda_debug_uid.internal_not_actually_unique - Name_mode.normal + Bound_var.create v Flambda_debug_uid.none Name_mode.normal in Let.create (Bound_pattern.singleton var_bind) @@ -480,8 +479,7 @@ 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_debug_uid.internal_not_actually_unique + Bound_parameter.create param kind Flambda_debug_uid.none (* CR sspies: fix *)) (Flambda_arity.unarize remaining_param_arity) |> Bound_parameters.create @@ -601,7 +599,7 @@ 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_debug_uid.internal_not_actually_unique + VB.create var Flambda_debug_uid.none (* CR sspies: fix *) Name_mode.normal in let prim = @@ -713,7 +711,7 @@ let simplify_direct_partial_application ~simplify_expr dacc apply in let expr = let wrapper_var = - VB.create wrapper_var Flambda_debug_uid.internal_not_actually_unique + VB.create wrapper_var Flambda_debug_uid.none (* CR sspies: fix *) Name_mode.normal in let bound_vars = [wrapper_var] in diff --git a/middle_end/flambda2/simplify/simplify_common.ml b/middle_end/flambda2/simplify/simplify_common.ml index 5b04fad41d0..8cae70fb870 100644 --- a/middle_end/flambda2/simplify/simplify_common.ml +++ b/middle_end/flambda2/simplify/simplify_common.ml @@ -187,7 +187,7 @@ let split_direct_over_application apply (fun i kind -> BP.create (Variable.create ("result" ^ string_of_int i)) - kind Flambda_debug_uid.internal_not_actually_unique + kind Flambda_debug_uid.none (* CR tnowak: verify *)) (Flambda_arity.unarized_components (Apply.return_arity apply)) in @@ -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_debug_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,7 +217,7 @@ let split_direct_over_application apply (Let.create (Bound_pattern.singleton (Bound_var.create (Variable.create "unit") - Flambda_debug_uid.internal_not_actually_unique + Flambda_debug_uid.none (* CR sspies: fix *) Name_mode.normal)) (Named.create_prim (Unary (End_region { ghost = true }, Simple.var ghost_region)) @@ -250,7 +250,7 @@ let split_direct_over_application apply let after_full_application_handler = let func_param = BP.create func_var K.With_subkind.any_value - Flambda_debug_uid.internal_not_actually_unique (* CR tnowak: maybe? *) + Flambda_debug_uid.none (* CR tnowak: maybe? *) in Continuation_handler.create (Bound_parameters.create [func_param]) @@ -285,7 +285,7 @@ let split_direct_over_application apply in Let.create (Bound_pattern.singleton - (Bound_var.create region Flambda_debug_uid.internal_not_actually_unique + (Bound_var.create region Flambda_debug_uid.none (* CR tnowak: verify *) Name_mode.normal)) (Named.create_prim (Variadic (Begin_region { ghost = false }, [])) @@ -293,8 +293,7 @@ let split_direct_over_application apply ~body: (Let.create (Bound_pattern.singleton - (Bound_var.create ghost_region - Flambda_debug_uid.internal_not_actually_unique + (Bound_var.create ghost_region Flambda_debug_uid.none (* CR sspies: fix *) Name_mode.normal)) (Named.create_prim (Variadic (Begin_region { ghost = false }, [])) diff --git a/middle_end/flambda2/simplify/simplify_extcall.ml b/middle_end/flambda2/simplify/simplify_extcall.ml index 026f9e85e6a..dfff2df3e47 100644 --- a/middle_end/flambda2/simplify/simplify_extcall.ml +++ b/middle_end/flambda2/simplify/simplify_extcall.ml @@ -44,10 +44,7 @@ let apply_cont cont v ~dbg = free_names, expr let let_prim ~dbg v prim (free_names, body) = - let v' = - Bound_var.create v Flambda_debug_uid.internal_not_actually_unique - Name_mode.normal - in + let v' = Bound_var.create v Flambda_debug_uid.none 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 7ff400c6068..1bdc8089718 100644 --- a/middle_end/flambda2/simplify/simplify_let_cont_expr.ml +++ b/middle_end/flambda2/simplify/simplify_let_cont_expr.ml @@ -262,8 +262,7 @@ let extra_params_for_continuation_param_aliases cont uacc rewrite_ids = EPA.add ~extra_param: (Bound_parameter.create var var_kind - Flambda_debug_uid.internal_not_actually_unique - (* CR tnowak: maybe? *)) + Flambda_debug_uid.none (* CR tnowak: maybe? *)) ~extra_args epa ~invalids:Apply_cont_rewrite_id.Set.empty) required_extra_args.extra_args_for_aliases EPA.empty @@ -507,8 +506,7 @@ let add_lets_around_handler cont at_unit_toplevel uacc handler = let bound_pattern = (* CR tnowak: verify *) Bound_pattern.singleton - (Bound_var.create var Flambda_debug_uid.internal_not_actually_unique - Name_mode.normal) + (Bound_var.create var Flambda_debug_uid.none Name_mode.normal) in let named = Named.create_simple (Simple.var 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 67e72e6cf69..f16df32d0c0 100644 --- a/middle_end/flambda2/simplify/simplify_set_of_closures.ml +++ b/middle_end/flambda2/simplify/simplify_set_of_closures.ml @@ -46,8 +46,7 @@ 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 - Flambda_debug_uid.internal_not_actually_unique NM.normal) + (Bound_var.create my_closure Flambda_debug_uid.none NM.normal) (T.unknown K.value) | Some function_slot -> ( match @@ -63,8 +62,7 @@ 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_debug_uid.internal_not_actually_unique NM.normal) + (Bound_var.create my_closure Flambda_debug_uid.none NM.normal) (T.alias_type_of K.value (Simple.name name))) in let denv = @@ -72,8 +70,7 @@ let dacc_inside_function context ~outer_dacc ~params ~my_closure ~my_region | None -> denv | Some my_region -> let my_region = - Bound_var.create my_region - Flambda_debug_uid.internal_not_actually_unique Name_mode.normal + Bound_var.create my_region Flambda_debug_uid.none Name_mode.normal in DE.add_variable denv my_region (T.unknown K.region) in @@ -82,15 +79,13 @@ let dacc_inside_function context ~outer_dacc ~params ~my_closure ~my_region | None -> denv | Some my_ghost_region -> let my_ghost_region = - Bound_var.create my_ghost_region - Flambda_debug_uid.internal_not_actually_unique Name_mode.normal + Bound_var.create my_ghost_region Flambda_debug_uid.none 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 Flambda_debug_uid.internal_not_actually_unique - Name_mode.normal + Bound_var.create my_depth Flambda_debug_uid.none Name_mode.normal in DE.add_variable denv my_depth (T.unknown K.rec_info) in @@ -201,8 +196,7 @@ let simplify_function_body context ~outer_dacc function_slot_opt | None -> [] | Some region -> [ Bound_parameter.create region Flambda_kind.With_subkind.region - Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) - ] + Flambda_debug_uid.none (* CR sspies: fix *) ] in region_param my_region @ region_param my_ghost_region in @@ -212,10 +206,9 @@ 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_debug_uid.internal_not_actually_unique; + Flambda_kind.With_subkind.any_value Flambda_debug_uid.none; Bound_parameter.create my_depth Flambda_kind.With_subkind.rec_info - Flambda_debug_uid.internal_not_actually_unique ] + Flambda_debug_uid.none ] @ region_params)) ~loopify_state ~params with @@ -389,8 +382,7 @@ 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 - Flambda_debug_uid.internal_not_actually_unique (* CR tnowak: verify *)) + kind_with_subkind Flambda_debug_uid.none (* 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 e9a02ba9c9a..782087ddca1 100644 --- a/middle_end/flambda2/simplify/simplify_switch_expr.ml +++ b/middle_end/flambda2/simplify/simplify_switch_expr.ml @@ -343,16 +343,13 @@ let rebuild_switch_with_single_arg_to_same_destination uacc ~dacc_before_switch | Must_untag -> let bound = BPt.singleton - (BV.create final_arg_var - Flambda_debug_uid.internal_not_actually_unique NM.normal) + (BV.create final_arg_var Flambda_debug_uid.none 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_debug_uid.internal_not_actually_unique - NM.normal) + BPt.singleton (BV.create arg_var Flambda_debug_uid.none NM.normal) in RE.create_let rebuilding bound load_from_block ~body ~free_names_of_body in @@ -521,8 +518,7 @@ let rebuild_switch ~original ~arms ~condition_dbg ~scrutinee ~scrutinee_ty Debuginfo.none in let bound = - VB.create not_scrutinee - Flambda_debug_uid.internal_not_actually_unique NM.normal + VB.create not_scrutinee Flambda_debug_uid.none NM.normal |> Bound_pattern.singleton in let apply_cont = @@ -649,8 +645,7 @@ let simplify_switch ~simplify_let ~simplify_function_body dacc switch (* [body] won't be looked at (see below). *) Let.create (Bound_pattern.singleton - (Bound_var.create tagged_scrutinee - Flambda_debug_uid.internal_not_actually_unique NM.normal)) + (Bound_var.create tagged_scrutinee Flambda_debug_uid.none 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 21de76d0827..a57e74e42fa 100644 --- a/middle_end/flambda2/simplify/simplify_unary_primitive.ml +++ b/middle_end/flambda2/simplify/simplify_unary_primitive.ml @@ -720,8 +720,7 @@ let simplify_obj_dup dbg dacc ~original_term ~arg ~arg_ty ~result_var = let bind_contents = { Expr_builder.let_bound = Bound_pattern.singleton - (Bound_var.create contents_var - Flambda_debug_uid.internal_not_actually_unique NM.normal); + (Bound_var.create contents_var Flambda_debug_uid.none NM.normal); simplified_defining_expr = Simplified_named.create contents_expr; original_defining_expr = None } @@ -729,8 +728,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_debug_uid.internal_not_actually_unique NM.normal) + (Bound_var.create contents_var Flambda_debug_uid.none 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 6d2881cd093..250ef6693cf 100644 --- a/middle_end/flambda2/simplify/unboxing/build_unboxing_denv.ml +++ b/middle_end/flambda2/simplify/unboxing/build_unboxing_denv.ml @@ -28,8 +28,7 @@ let add_equation_on_var denv var shape = let denv_of_number_decision naked_kind shape param_var naked_var denv : DE.t = (* CR tnowak: verify *) let naked_name = - VB.create naked_var Flambda_debug_uid.internal_not_actually_unique - Name_mode.normal + VB.create naked_var Flambda_debug_uid.none Name_mode.normal in let denv = DE.define_variable denv naked_name naked_kind in add_equation_on_var denv param_var shape @@ -41,10 +40,7 @@ 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 Flambda_debug_uid.internal_not_actually_unique - Name_mode.normal - in + let v = VB.create var Flambda_debug_uid.none Name_mode.normal in DE.define_variable denv v (K.Block_shape.element_kind shape index)) denv fields in @@ -68,10 +64,7 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = Value_slot.Map.fold (fun _ ({ epa = { param = var; _ }; kind; _ } : U.field_decision) denv -> (* CR tnowak: verify *) - let v = - VB.create var Flambda_debug_uid.internal_not_actually_unique - Name_mode.normal - in + let v = VB.create var Flambda_debug_uid.none Name_mode.normal in DE.define_variable denv v (K.With_subkind.kind kind)) vars_within_closure denv in @@ -93,10 +86,7 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = | Unbox (Variant { tag; const_ctors; fields_by_tag }) -> (* Adapt the denv for the tag *) (* CR tnowak: verify *) - let tag_v = - VB.create tag.param Flambda_debug_uid.internal_not_actually_unique - Name_mode.normal - in + let tag_v = VB.create tag.param Flambda_debug_uid.none Name_mode.normal in let denv = DE.define_variable denv tag_v K.naked_immediate in let denv = DE.map_typing_env denv ~f:(fun tenv -> @@ -114,8 +104,7 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = | At_least_one { is_int; _ } -> (* CR tnowak: verify *) let is_int_v = - VB.create is_int.param Flambda_debug_uid.internal_not_actually_unique - Name_mode.normal + VB.create is_int.param Flambda_debug_uid.none Name_mode.normal in let denv = DE.define_variable denv is_int_v K.naked_immediate in let denv = @@ -140,8 +129,7 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = | At_least_one { ctor = Unbox (Number (Naked_immediate, ctor_epa)); _ } -> (* CR tnowak: verify *) let v = - VB.create ctor_epa.param - Flambda_debug_uid.internal_not_actually_unique Name_mode.normal + VB.create ctor_epa.param Flambda_debug_uid.none Name_mode.normal in let denv = DE.define_variable denv v K.naked_immediate in let ty = @@ -167,10 +155,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 Flambda_debug_uid.internal_not_actually_unique - Name_mode.normal - in + let v = VB.create var Flambda_debug_uid.none Name_mode.normal in DE.define_variable denv v (K.Block_shape.element_kind shape index)) denv block_fields) fields_by_tag denv diff --git a/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml b/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml index 8fa52cb5b19..d9be6364a13 100644 --- a/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml +++ b/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml @@ -421,8 +421,7 @@ 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 - Flambda_debug_uid.internal_not_actually_unique + BP.create epa.param kind Flambda_debug_uid.none (* CR tnowak: maybe? *) in let extra_params_and_args = @@ -436,8 +435,7 @@ let add_extra_params_and_args extra_params_and_args ~invalids decision = (fun _ ({ epa; decision; kind } : U.field_decision) extra_params_and_args -> let extra_param = - BP.create epa.param kind - Flambda_debug_uid.internal_not_actually_unique + BP.create epa.param kind Flambda_debug_uid.none (* CR tnowak: maybe? *) in let extra_params_and_args = @@ -454,8 +452,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_debug_uid.internal_not_actually_unique + BP.create epa.param kind Flambda_debug_uid.none (* CR tnowak: maybe? *) in let extra_params_and_args = @@ -472,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_debug_uid.internal_not_actually_unique + Flambda_debug_uid.none (* CR tnowak: maybe? *) in EPA.add extra_params_and_args ~invalids ~extra_param @@ -481,7 +478,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_debug_uid.internal_not_actually_unique + Flambda_debug_uid.none (* CR tnowak: maybe? *) in let extra_params_and_args = @@ -490,7 +487,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_debug_uid.internal_not_actually_unique + Flambda_debug_uid.none (* CR tnowak: maybe? *) in EPA.add extra_params_and_args ~invalids ~extra_param @@ -511,7 +508,7 @@ let add_extra_params_and_args extra_params_and_args ~invalids decision = in let extra_param = BP.create tag.param K.With_subkind.naked_immediate - Flambda_debug_uid.internal_not_actually_unique (* CR tnowak: maybe? *) + Flambda_debug_uid.none (* CR tnowak: maybe? *) in EPA.add extra_params_and_args ~invalids ~extra_param ~extra_args:tag.args | Unbox (Number (naked_number_kind, epa)) -> @@ -520,7 +517,7 @@ let add_extra_params_and_args extra_params_and_args ~invalids decision = in let extra_param = BP.create epa.param kind_with_subkind - Flambda_debug_uid.internal_not_actually_unique (* CR tnowak: maybe? *) + Flambda_debug_uid.none (* CR tnowak: maybe? *) in EPA.add extra_params_and_args ~invalids ~extra_param ~extra_args:epa.args in diff --git a/middle_end/flambda2/simplify_shared/inlining_helpers.ml b/middle_end/flambda2/simplify_shared/inlining_helpers.ml index 9670d15c9bc..e6eb0341960 100644 --- a/middle_end/flambda2/simplify_shared/inlining_helpers.ml +++ b/middle_end/flambda2/simplify_shared/inlining_helpers.ml @@ -92,7 +92,7 @@ let wrap_inlined_body_for_exn_extra_args acc ~extra_args ~apply_exn_continuation (fun k -> Bound_parameter.create (Variable.create "wrapper_return") - k Flambda_debug_uid.internal_not_actually_unique + k Flambda_debug_uid.none (* CR tnowak: verify *)) (Flambda_arity.unarized_components result_arity) in @@ -111,8 +111,7 @@ let wrap_inlined_body_for_exn_extra_args acc ~extra_args ~apply_exn_continuation let param = Variable.create "exn" in let wrapper_handler_params = [ Bound_parameter.create param Flambda_kind.With_subkind.any_value - Flambda_debug_uid.internal_not_actually_unique (* CR tnowak: verify *) - ] + Flambda_debug_uid.none (* 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 425c29cecee..0b5b9addf70 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_debug_uid.internal_not_actually_unique + Flambda_debug_uid.none in fprintf ppf "@[(%t@<1>\u{03bb}%t@[ let env, region = Env.create_bound_parameter env - ( my_region, - Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) - ) + (my_region, Flambda_debug_uid.none (* CR sspies: fix *)) in env, Some region in @@ -484,9 +482,7 @@ let params_and_body0 env res code_id ~result_arity ~fun_dbg | Some my_ghost_region -> let env, region = Env.create_bound_parameter env - ( my_ghost_region, - Flambda_debug_uid.internal_not_actually_unique (* CR sspies: fix *) - ) + (my_ghost_region, Flambda_debug_uid.none (* CR sspies: fix *)) in env, Some region in @@ -735,7 +731,7 @@ let let_dynamic_set_of_closures0 env res ~body ~bound_vars set let soc_var = Bound_var.create (Variable.create "*set_of_closures*") - Flambda_debug_uid.internal_not_actually_unique Name_mode.normal + Flambda_debug_uid.none Name_mode.normal in let defining_expr = Env.simple csoc free_vars in let env, res = diff --git a/middle_end/flambda2/types/env/join_env.ml b/middle_end/flambda2/types/env/join_env.ml index 9cef69e8f5d..306666b0d56 100644 --- a/middle_end/flambda2/types/env/join_env.ml +++ b/middle_end/flambda2/types/env/join_env.ml @@ -1193,8 +1193,7 @@ 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_debug_uid.internal_not_actually_unique + (Bound_var.create var Flambda_debug_uid.none (* CR sspies: fix *) Name_mode.in_types)) kind) extra_variables target_env diff --git a/middle_end/flambda2/types/equal_types_for_debug.ml b/middle_end/flambda2/types/equal_types_for_debug.ml index c6216c92688..ac6e1b8917c 100644 --- a/middle_end/flambda2/types/equal_types_for_debug.ml +++ b/middle_end/flambda2/types/equal_types_for_debug.ml @@ -463,8 +463,7 @@ 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_debug_uid.internal_not_actually_unique + (Bound_var.create var Flambda_debug_uid.none (* CR sspies: fix *) Name_mode.in_types)) kind) @@ -475,8 +474,7 @@ 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_debug_uid.internal_not_actually_unique + (Bound_var.create var Flambda_debug_uid.none (* CR sspies: fix *) Name_mode.in_types)) kind) diff --git a/middle_end/flambda2/types/join_levels_old.ml b/middle_end/flambda2/types/join_levels_old.ml index 7e571738ba7..74e89863f4f 100644 --- a/middle_end/flambda2/types/join_levels_old.ml +++ b/middle_end/flambda2/types/join_levels_old.ml @@ -46,8 +46,7 @@ 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_debug_uid.internal_not_actually_unique + (Bound_var.create var Flambda_debug_uid.none (* CR sspies: fix *) Name_mode.in_types)) kind) vars base_env) 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 a837230d611..b6cf297d6fd 100644 --- a/middle_end/flambda2/types/meet_and_n_way_join.ml +++ b/middle_end/flambda2/types/meet_and_n_way_join.ml @@ -284,7 +284,7 @@ let add_defined_vars env level = (fun var kind env -> TE.add_definition env (Bound_name.create_var - (Bound_var.create var Flambda_debug_uid.internal_not_actually_unique + (Bound_var.create var Flambda_debug_uid.none (* CR sspies: fix *) Name_mode.in_types)) kind) level env @@ -1226,8 +1226,7 @@ and meet_row_like : (fun var kind env -> TE.add_definition env (Bound_name.create_var - (Bound_var.create var - Flambda_debug_uid.internal_not_actually_unique + (Bound_var.create var Flambda_debug_uid.none (* CR sspies: fix *) Name_mode.in_types)) kind) !extra_variables result_env From a7df02673a8553acae8be70e224b8a231dcdd606 Mon Sep 17 00:00:00 2001 From: Simon Spies Date: Wed, 30 Apr 2025 15:52:09 +0100 Subject: [PATCH 5/9] cleanup backend_var and debug_uid --- middle_end/backend_var.ml | 14 ++++++-------- middle_end/backend_var.mli | 5 ++--- .../flambda2/identifiers/flambda_debug_uid.ml | 2 ++ middle_end/flambda2/to_cmm/to_cmm_env.ml | 12 +++++++----- 4 files changed, 17 insertions(+), 16 deletions(-) diff --git a/middle_end/backend_var.ml b/middle_end/backend_var.ml index a23e92a3473..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_debug_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 15f43a83f89..171bd378d15 100644 --- a/middle_end/backend_var.mli +++ b/middle_end/backend_var.mli @@ -19,7 +19,6 @@ include module type of struct include Ident end -module Uid = Flambda2_identifiers.Flambda_debug_uid type backend_var = t @@ -33,13 +32,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/identifiers/flambda_debug_uid.ml b/middle_end/flambda2/identifiers/flambda_debug_uid.ml index 6e9071357a2..9dd6d450f88 100644 --- a/middle_end/flambda2/identifiers/flambda_debug_uid.ml +++ b/middle_end/flambda2/identifiers/flambda_debug_uid.ml @@ -13,6 +13,8 @@ (**************************************************************************) 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 Lambda.debug_uid diff --git a/middle_end/flambda2/to_cmm/to_cmm_env.ml b/middle_end/flambda2/to_cmm/to_cmm_env.ml index e7e20f7c667..2edd39b49a9 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_env.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_env.ml @@ -293,7 +293,7 @@ let exported_offsets t = t.offsets (* Variables *) -let gen_variable ~uid v = +let gen_variable ~debug_uid v = let user_visible = Variable.user_visible v in let name = Variable.name v in let v = Backend_var.create_local name in @@ -307,7 +307,7 @@ let gen_variable ~uid v = be reworked soon *) Some (Backend_var.Provenance.create ~module_path:(Path.Pident v) - ~location:Debuginfo.none ~original_ident:v ~uid) + ~location:Debuginfo.none ~original_ident:v ~debug_uid) in Backend_var.With_provenance.create ?provenance v @@ -317,12 +317,12 @@ let add_bound_param env v v' = let vars = Variable.Map.add v (C.var v'', free_vars) env.vars in { env with vars } -let create_bound_parameter env (v, uid) = +let create_bound_parameter env (v, debug_uid) = if Variable.Map.mem v env.vars then Misc.fatal_errorf "Cannot rebind variable %a in To_cmm environment" Variable.print v; - let v' = gen_variable v ~uid in + let v' = gen_variable v ~debug_uid in let env = add_bound_param env v v' in env, v' @@ -425,7 +425,9 @@ let create_binding_aux (type a) effs (var : Bound_var.t) ~(inline : a inline) next_order := !next_order + incr; !next_order in - let cmm_var = gen_variable ~uid:(Bound_var.uid var) (Bound_var.var var) in + let cmm_var = + gen_variable ~debug_uid:(Bound_var.uid var) (Bound_var.var var) + in let binding = Binding { order; inline; effs; cmm_var; bound_expr } in binding From 3d8105983050476a663b54f617217f0aa73bb5da Mon Sep 17 00:00:00 2001 From: Simon Spies Date: Wed, 30 Apr 2025 15:54:30 +0100 Subject: [PATCH 6/9] more name cleanup --- .../bound_identifiers/bound_parameter.ml | 1 - .../bound_identifiers/bound_parameter.mli | 2 -- .../flambda2/bound_identifiers/bound_var.ml | 20 ++++++++++--------- .../flambda2/bound_identifiers/bound_var.mli | 2 +- middle_end/flambda2/to_cmm/to_cmm_env.ml | 2 +- 5 files changed, 13 insertions(+), 14 deletions(-) diff --git a/middle_end/flambda2/bound_identifiers/bound_parameter.ml b/middle_end/flambda2/bound_identifiers/bound_parameter.ml index 0b49a7fce49..a9a7fe11698 100644 --- a/middle_end/flambda2/bound_identifiers/bound_parameter.ml +++ b/middle_end/flambda2/bound_identifiers/bound_parameter.ml @@ -15,7 +15,6 @@ (**************************************************************************) module Simple = Int_ids.Simple -module Uid = Shape.Uid type t = { param : Variable.t; diff --git a/middle_end/flambda2/bound_identifiers/bound_parameter.mli b/middle_end/flambda2/bound_identifiers/bound_parameter.mli index 8c860605738..2abaf4ddc16 100644 --- a/middle_end/flambda2/bound_identifiers/bound_parameter.mli +++ b/middle_end/flambda2/bound_identifiers/bound_parameter.mli @@ -14,8 +14,6 @@ (* *) (**************************************************************************) -module Uid = Shape.Uid - (** A parameter (to a function, continuation, etc.) together with its kind. *) type t diff --git a/middle_end/flambda2/bound_identifiers/bound_var.ml b/middle_end/flambda2/bound_identifiers/bound_var.ml index 4d7fe84f53d..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_debug_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_debug_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 f697f6d6d1a..36920339fdf 100644 --- a/middle_end/flambda2/bound_identifiers/bound_var.mli +++ b/middle_end/flambda2/bound_identifiers/bound_var.mli @@ -23,7 +23,7 @@ val create : Variable.t -> Flambda_debug_uid.t -> Name_mode.t -> t val var : t -> Variable.t -val uid : t -> Flambda_debug_uid.t +val debug_uid : t -> Flambda_debug_uid.t val name_mode : t -> Name_mode.t diff --git a/middle_end/flambda2/to_cmm/to_cmm_env.ml b/middle_end/flambda2/to_cmm/to_cmm_env.ml index 2edd39b49a9..297800b6f4f 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_env.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_env.ml @@ -426,7 +426,7 @@ let create_binding_aux (type a) effs (var : Bound_var.t) ~(inline : a inline) !next_order in let cmm_var = - gen_variable ~debug_uid:(Bound_var.uid var) (Bound_var.var var) + gen_variable ~debug_uid:(Bound_var.debug_uid var) (Bound_var.var var) in let binding = Binding { order; inline; effs; cmm_var; bound_expr } in binding From 00bebd7d27111701dc9d9c4dcff5fd40cafe1e11 Mon Sep 17 00:00:00 2001 From: Simon Spies Date: Wed, 30 Apr 2025 17:47:37 +0100 Subject: [PATCH 7/9] inspect cases where we do not have debug uid's (Part 1) --- .../flambda2/parser/fexpr_to_flambda.ml | 38 ++++---- .../flambda2/simplify/apply_cont_rewrite.ml | 12 ++- .../common_subexpression_elimination.ml | 5 +- .../flambda2/simplify/env/downwards_env.ml | 35 ++++---- middle_end/flambda2/simplify/expr_builder.ml | 13 ++- .../simplify/flow/mutable_unboxing.ml | 7 +- .../simplify/inlining/inlining_transforms.ml | 11 ++- .../flambda2/simplify/lifted_cont_params.ml | 10 +-- .../flambda2/simplify/simplify_apply_expr.ml | 24 ++--- .../flambda2/simplify/simplify_common.ml | 22 +++-- .../flambda2/simplify/simplify_extcall.ml | 24 +++-- .../simplify/simplify_let_cont_expr.ml | 15 ++-- .../simplify/simplify_set_of_closures.ml | 37 ++++---- .../flambda2/simplify/simplify_switch_expr.ml | 21 ++--- .../simplify/simplify_unary_primitive.ml | 5 +- .../simplify/unboxing/build_unboxing_denv.ml | 90 ++++++++++++------- .../unboxing/optimistic_unboxing_decision.ml | 25 ++++-- .../simplify/unboxing/unboxing_epa.ml | 28 ++---- .../simplify/unboxing/unboxing_types.ml | 10 ++- .../simplify/unboxing/unboxing_types.mli | 6 +- .../simplify_shared/inlining_helpers.ml | 11 ++- middle_end/flambda2/to_cmm/to_cmm.ml | 11 ++- .../flambda2/to_cmm/to_cmm_set_of_closures.ml | 22 ++--- middle_end/flambda2/types/env/join_env.ml | 5 +- .../flambda2/types/equal_types_for_debug.ml | 8 +- middle_end/flambda2/types/join_levels_old.ml | 6 +- .../flambda2/types/meet_and_n_way_join.ml | 10 ++- 27 files changed, 303 insertions(+), 208 deletions(-) diff --git a/middle_end/flambda2/parser/fexpr_to_flambda.ml b/middle_end/flambda2/parser/fexpr_to_flambda.ml index a8d725b54cc..541c37db23f 100644 --- a/middle_end/flambda2/parser/fexpr_to_flambda.ml +++ b/middle_end/flambda2/parser/fexpr_to_flambda.ml @@ -130,7 +130,11 @@ 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 } + (* CR sspies: These variables are apparently user visible. Where do we get + [Lambda.debug_uid] values for them from? *) + ( v, + Flambda_debug_uid.none, + { 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 @@ -623,11 +627,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_debug_uid.none 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 @@ -652,9 +653,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_debug_uid.none 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 @@ -681,12 +682,11 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = let handler_env, params = 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_debug_uid.none - (* CR tnowak: verify *) + var_duid in env, param :: args) params (env, []) @@ -898,20 +898,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_debug_uid.none - (* 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/simplify/apply_cont_rewrite.ml b/middle_end/flambda2/simplify/apply_cont_rewrite.ml index 6ae292231cc..9ac06b80dcb 100644 --- a/middle_end/flambda2/simplify/apply_cont_rewrite.ml +++ b/middle_end/flambda2/simplify/apply_cont_rewrite.ml @@ -175,9 +175,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_debug_uid.none - (* 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 @@ -186,6 +188,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 -> @@ -196,8 +201,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_debug_uid.none - (* 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 8bf8c6bff4f..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_debug_uid.none (* 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 6ed91e6d9f2..f4db75188f1 100644 --- a/middle_end/flambda2/simplify/env/downwards_env.ml +++ b/middle_end/flambda2/simplify/env/downwards_env.ml @@ -144,7 +144,9 @@ 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_debug_uid.none (* CR sspies: fix *)) + Flambda_debug_uid.none + (* CR sspies: Unclear whether bound variables should have a + [Flambda_debug_uid.t]. For now, I just left it as [.none]. *)) in variables_defined_in_current_continuation :: r in @@ -202,13 +204,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_debug_uid.none - (* 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_debug_uid.none - (* 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 @@ -316,7 +319,9 @@ let define_name t name kind = ~var:(fun [@inline] var -> (define_variable [@inlined hint]) t (Bound_var.create var Flambda_debug_uid.none - (* CR sspies: fix *) (Bound_name.name_mode name)) + (* CR sspies: Unclear whether bound variables 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) @@ -338,7 +343,9 @@ let add_name t name ty = ~var:(fun [@inline] var -> add_variable t (Bound_var.create var Flambda_debug_uid.none - (* CR sspies: fix *) (Bound_name.name_mode name)) + (* CR sspies: Unclear whether bound variables 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) @@ -378,11 +385,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_debug_uid.none - (* 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) @@ -400,11 +404,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_debug_uid.none - (* 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 80b01d0bc16..858728259fb 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,7 +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_debug_uid.none 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 @@ -569,8 +572,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_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 @@ -767,8 +771,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_debug_uid.none - (* 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 75ae77fbf27..170386d252e 100644 --- a/middle_end/flambda2/simplify/flow/mutable_unboxing.ml +++ b/middle_end/flambda2/simplify/flow/mutable_unboxing.ml @@ -476,8 +476,11 @@ module Fold_prims = struct (fun i kind -> let name = Variable.unique_name block_needed in let var = Variable.create (Printf.sprintf "%s_%i" name i) in - Bound_parameter.create var kind Flambda_debug_uid.none - (* 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 bc9746a171c..bfcb9712f83 100644 --- a/middle_end/flambda2/simplify/inlining/inlining_transforms.ml +++ b/middle_end/flambda2/simplify/inlining/inlining_transforms.ml @@ -44,10 +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_debug_uid.none - (* CR tnowak: maybe here? *) + my_closure_duid in let bind_params ~params ~args ~body = if List.compare_lengths params args <> 0 @@ -66,9 +69,11 @@ 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 + (* CR sspies: [my_depth] sounds like something internally generated. *) let bound = Bound_pattern.singleton - (VB.create my_depth Flambda_debug_uid.none 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 a289ec40fde..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_debug_uid.none (* 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_expr.ml b/middle_end/flambda2/simplify/simplify_apply_expr.ml index 8bdcb799530..3ffd4872458 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,10 +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_debug_uid.none 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 @@ -425,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" @@ -479,8 +481,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_debug_uid.none - (* 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 @@ -600,7 +602,10 @@ let simplify_direct_partial_application ~simplify_expr dacc apply | In_closure { var; value_slot; value = _ } -> let arg = VB.create var Flambda_debug_uid.none - (* CR sspies: fix *) Name_mode.normal + (* 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 @@ -711,8 +716,7 @@ let simplify_direct_partial_application ~simplify_expr dacc apply in let expr = let wrapper_var = - VB.create wrapper_var Flambda_debug_uid.none - (* 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 8cae70fb870..ae4241334c9 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_debug_uid.none - (* 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 = @@ -217,8 +217,7 @@ let split_direct_over_application apply (Let.create (Bound_pattern.singleton (Bound_var.create (Variable.create "unit") - Flambda_debug_uid.none - (* 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)) @@ -249,8 +248,7 @@ let split_direct_over_application apply let after_full_application = Continuation.create () in let after_full_application_handler = let func_param = - BP.create func_var K.With_subkind.any_value - Flambda_debug_uid.none (* CR tnowak: maybe? *) + BP.create func_var K.With_subkind.any_value func_var_duid in Continuation_handler.create (Bound_parameters.create [func_param]) @@ -283,18 +281,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_debug_uid.none - (* 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_debug_uid.none - (* 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 dfff2df3e47..d099564963c 100644 --- a/middle_end/flambda2/simplify/simplify_extcall.ml +++ b/middle_end/flambda2/simplify/simplify_extcall.ml @@ -43,8 +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_debug_uid.none 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 @@ -58,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 1bdc8089718..0747d8cc6fb 100644 --- a/middle_end/flambda2/simplify/simplify_let_cont_expr.ml +++ b/middle_end/flambda2/simplify/simplify_let_cont_expr.ml @@ -256,13 +256,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_debug_uid.none (* 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 @@ -503,10 +505,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_debug_uid.none Name_mode.normal) + (Bound_var.create var var_duid Name_mode.normal) in let named = Named.create_simple (Simple.var 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 f16df32d0c0..a3037eec075 100644 --- a/middle_end/flambda2/simplify/simplify_set_of_closures.ml +++ b/middle_end/flambda2/simplify/simplify_set_of_closures.ml @@ -40,13 +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_debug_uid.none NM.normal) + (Bound_var.create my_closure my_closure_duid NM.normal) (T.unknown K.value) | Some function_slot -> ( match @@ -62,15 +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_debug_uid.none 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_debug_uid.none 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 @@ -78,15 +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_debug_uid.none 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_debug_uid.none 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 = @@ -190,25 +192,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_debug_uid.none (* 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_debug_uid.none; + Flambda_kind.With_subkind.any_value my_closure_duid; Bound_parameter.create my_depth Flambda_kind.With_subkind.rec_info - Flambda_debug_uid.none ] + my_depth_duid ] @ region_params)) ~loopify_state ~params with @@ -380,9 +387,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_debug_uid.none (* 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 782087ddca1..8213259b17c 100644 --- a/middle_end/flambda2/simplify/simplify_switch_expr.ml +++ b/middle_end/flambda2/simplify/simplify_switch_expr.ml @@ -316,13 +316,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 @@ -342,15 +344,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_debug_uid.none 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_debug_uid.none 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 = @@ -504,6 +503,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 @@ -518,7 +518,7 @@ let rebuild_switch ~original ~arms ~condition_dbg ~scrutinee ~scrutinee_ty Debuginfo.none in let bound = - VB.create not_scrutinee Flambda_debug_uid.none NM.normal + VB.create not_scrutinee not_scrutinee_duid NM.normal |> Bound_pattern.singleton in let apply_cont = @@ -636,6 +636,7 @@ let simplify_switch0 dacc switch ~down_to_up = let simplify_switch ~simplify_let ~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)) @@ -645,7 +646,7 @@ let simplify_switch ~simplify_let ~simplify_function_body dacc switch (* [body] won't be looked at (see below). *) Let.create (Bound_pattern.singleton - (Bound_var.create tagged_scrutinee Flambda_debug_uid.none 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 a57e74e42fa..580a3208c1e 100644 --- a/middle_end/flambda2/simplify/simplify_unary_primitive.ml +++ b/middle_end/flambda2/simplify/simplify_unary_primitive.ml @@ -714,13 +714,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_debug_uid.none NM.normal); + (Bound_var.create contents_var contents_var_duid NM.normal); simplified_defining_expr = Simplified_named.create contents_expr; original_defining_expr = None } @@ -728,7 +729,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_debug_uid.none 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 250ef6693cf..679db03c81e 100644 --- a/middle_end/flambda2/simplify/unboxing/build_unboxing_denv.ml +++ b/middle_end/flambda2/simplify/unboxing/build_unboxing_denv.ml @@ -25,11 +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 = - (* CR tnowak: verify *) - let naked_name = - VB.create naked_var Flambda_debug_uid.none 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_variable denv naked_name naked_kind in add_equation_on_var denv param_var shape @@ -39,8 +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_debug_uid.none 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_variable denv v (K.Block_shape.element_kind shape index)) denv fields in @@ -62,9 +62,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 -> - (* CR tnowak: verify *) - let v = VB.create var Flambda_debug_uid.none Name_mode.normal in + (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_variable denv v (K.With_subkind.kind kind)) vars_within_closure denv in @@ -85,8 +86,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 *) - (* CR tnowak: verify *) - let tag_v = VB.create tag.param Flambda_debug_uid.none Name_mode.normal in + let tag_v = VB.create tag.param tag.param_debug_uid Name_mode.normal in let denv = DE.define_variable denv tag_v K.naked_immediate in let denv = DE.map_typing_env denv ~f:(fun tenv -> @@ -102,9 +102,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; _ } -> - (* CR tnowak: verify *) let is_int_v = - VB.create is_int.param Flambda_debug_uid.none Name_mode.normal + VB.create is_int.param is_int.param_debug_uid Name_mode.normal in let denv = DE.define_variable denv is_int_v K.naked_immediate in let denv = @@ -127,9 +126,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)); _ } -> - (* CR tnowak: verify *) let v = - VB.create ctor_epa.param Flambda_debug_uid.none Name_mode.normal + VB.create ctor_epa.param ctor_epa.param_debug_uid Name_mode.normal in let denv = DE.define_variable denv v K.naked_immediate in let ty = @@ -154,8 +152,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_debug_uid.none 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_variable denv v (K.Block_shape.element_kind shape index)) denv block_fields) fields_by_tag denv @@ -184,39 +184,61 @@ 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 + denv_of_number_decision K.naked_vec128 shape param_var param_debug_uid + naked_vec128 denv diff --git a/middle_end/flambda2/simplify/unboxing/optimistic_unboxing_decision.ml b/middle_end/flambda2/simplify/unboxing/optimistic_unboxing_decision.ml index 4b7bc866909..ef451e448ae 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 @@ -97,7 +103,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 @@ -151,7 +160,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 @@ -161,7 +171,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 @@ -195,7 +206,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 d9be6364a13..46b72b7d14d 100644 --- a/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml +++ b/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml @@ -420,10 +420,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_debug_uid.none - (* 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 @@ -434,10 +431,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_debug_uid.none - (* 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 @@ -452,8 +446,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_debug_uid.none - (* 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 @@ -469,8 +462,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_debug_uid.none - (* CR tnowak: maybe? *) + is_int.param_debug_uid in EPA.add extra_params_and_args ~invalids ~extra_param ~extra_args:is_int.args @@ -478,8 +470,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_debug_uid.none - (* CR tnowak: maybe? *) + is_int.param_debug_uid in let extra_params_and_args = EPA.add extra_params_and_args ~invalids ~extra_param @@ -487,8 +478,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_debug_uid.none - (* CR tnowak: maybe? *) + ctor.param_debug_uid in EPA.add extra_params_and_args ~invalids ~extra_param ~extra_args:ctor.args @@ -507,8 +497,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_debug_uid.none (* 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)) -> @@ -516,8 +505,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_debug_uid.none (* 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 e6eb0341960..fc728dd03af 100644 --- a/middle_end/flambda2/simplify_shared/inlining_helpers.ml +++ b/middle_end/flambda2/simplify_shared/inlining_helpers.ml @@ -90,10 +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_debug_uid.none - (* 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 = @@ -109,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_debug_uid.none (* 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/to_cmm/to_cmm.ml b/middle_end/flambda2/to_cmm/to_cmm.ml index 766b8b31706..5a7430ac34d 100644 --- a/middle_end/flambda2/to_cmm/to_cmm.ml +++ b/middle_end/flambda2/to_cmm/to_cmm.ml @@ -75,14 +75,15 @@ let unit0 ~offsets ~all_code ~reachable_names flambda_unit = ~return_continuation_arity:[] ~trans_prim:To_cmm_primitive.trans_prim ~exn_continuation:(Flambda_unit.exn_continuation flambda_unit) in + let ret_var = Variable.create "*ret*" in + let ret_var_duid = Flambda_debug_uid.none in let _env, return_cont_params = (* The environment is dropped because the handler for the dummy continuation (which just returns unit) doesn't use any of the parameters. *) C.continuation_bound_parameters env (Bound_parameters.create - [ Bound_parameter.create (Variable.create "*ret*") - Flambda_kind.With_subkind.any_value Flambda_debug_uid.none - (* CR tnowak: verify *) ]) + [ Bound_parameter.create ret_var Flambda_kind.With_subkind.any_value + ret_var_duid ]) in let return_cont, env = Env.add_jump_cont env @@ -93,7 +94,9 @@ 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 tnowak: verify *) ) + Flambda_debug_uid.none + (* CR sspies: Do we have a better [Flambda_debug_uid.t] available + here? *) ) 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 250511ec29e..5305ae4616d 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 @@ -443,9 +443,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_debug_uid.none (* CR tnowak: maybe? *) + my_closure_duid in Bound_parameters.append params (Bound_parameters.create [my_closure_param]) @@ -469,9 +473,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_debug_uid.none (* CR sspies: fix *)) + Env.create_bound_parameter env (my_region, my_region_duid) in env, Some region in @@ -480,9 +484,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_debug_uid.none (* CR sspies: fix *)) + Env.create_bound_parameter env (my_ghost_region, my_ghost_region_duid) in env, Some region in @@ -728,11 +732,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_debug_uid.none 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 306666b0d56..017454fcc2d 100644 --- a/middle_end/flambda2/types/env/join_env.ml +++ b/middle_end/flambda2/types/env/join_env.ml @@ -1194,7 +1194,10 @@ let cut_and_n_way_join ~n_way_join_type ~meet_type ~cut_after target_env TE.add_definition target_env (Bound_name.create_var (Bound_var.create var Flambda_debug_uid.none - (* CR sspies: fix *) Name_mode.in_types)) + (* CR sspies: We can probably find a better + [Flambda_debug_uid.t] for these extra variables. However, + propagating it here seems non-trivial. *) + 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 ac6e1b8917c..ebe24f44539 100644 --- a/middle_end/flambda2/types/equal_types_for_debug.ml +++ b/middle_end/flambda2/types/equal_types_for_debug.ml @@ -464,7 +464,9 @@ let names_with_non_equal_types_level_ignoring_name_mode ~meet_type env level1 TE.add_definition left_env (Bound_name.create_var (Bound_var.create var Flambda_debug_uid.none - (* CR sspies: fix *) + (* CR sspies: We can probably find a better + [Flambda_debug_uid.t] for these variables. However, + propagating it here seems non-trivial. *) Name_mode.in_types)) kind) level1 env @@ -475,7 +477,9 @@ let names_with_non_equal_types_level_ignoring_name_mode ~meet_type env level1 TE.add_definition right_env (Bound_name.create_var (Bound_var.create var Flambda_debug_uid.none - (* CR sspies: fix *) + (* CR sspies: We can probably find a better + [Flambda_debug_uid.t] for these variables. However, + propagating it here seems non-trivial. *) 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 74e89863f4f..cd6eb9149ea 100644 --- a/middle_end/flambda2/types/join_levels_old.ml +++ b/middle_end/flambda2/types/join_levels_old.ml @@ -47,7 +47,11 @@ let join_types ~env_at_fork envs_with_levels = TE.add_definition base_env (Bound_name.create_var (Bound_var.create var Flambda_debug_uid.none - (* CR sspies: fix *) Name_mode.in_types)) + (* CR sspies: We can probably find a better + [Flambda_debug_uid.t] for these variables. + However, propagating it here seems + non-trivial. *) + 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 b6cf297d6fd..1be2fb4f37a 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,10 @@ let add_defined_vars env level = TE.add_definition env (Bound_name.create_var (Bound_var.create var Flambda_debug_uid.none - (* CR sspies: fix *) Name_mode.in_types)) + (* CR sspies: We can probably find a better [Flambda_debug_uid.t] + for these variables. However, propagating it here seems + non-trivial. *) + Name_mode.in_types)) kind) level env @@ -1227,7 +1230,10 @@ and meet_row_like : TE.add_definition env (Bound_name.create_var (Bound_var.create var Flambda_debug_uid.none - (* CR sspies: fix *) Name_mode.in_types)) + (* CR sspies: We can probably find a better + [Flambda_debug_uid.t] for these extra variables. However, + propagating it here seems non-trivial. *) + Name_mode.in_types)) kind) !extra_variables result_env in From 22e9adfc54273f2768c125d14c46173c630f07fc Mon Sep 17 00:00:00 2001 From: Simon Spies Date: Mon, 5 May 2025 11:27:40 +0100 Subject: [PATCH 8/9] inspect cases where we do not have debug uid's (Part 2) --- .../from_lambda/closure_conversion.ml | 218 ++++++++++-------- .../from_lambda/closure_conversion_aux.ml | 4 +- .../from_lambda/closure_conversion_aux.mli | 12 +- .../flambda2/from_lambda/lambda_to_flambda.ml | 85 ++++--- .../from_lambda/lambda_to_flambda_env.ml | 14 +- .../lambda_to_flambda_primitives_helpers.ml | 37 +-- .../flambda2/parser/fexpr_to_flambda.ml | 5 +- .../flambda2/simplify/env/downwards_env.ml | 8 +- .../simplify/inlining/inlining_transforms.ml | 1 - 9 files changed, 225 insertions(+), 159 deletions(-) diff --git a/middle_end/flambda2/from_lambda/closure_conversion.ml b/middle_end/flambda2/from_lambda/closure_conversion.ml index 430efc6ba1d..7158820bd2c 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion.ml @@ -343,6 +343,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 @@ -351,18 +353,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_debug_uid.none 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_debug_uid.none Name_mode.normal)) + (VB.create my_depth my_depth_duid Name_mode.normal)) (Named.create_rec_info rec_info) ~body in @@ -376,19 +377,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_debug_uid.none 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) @@ -451,7 +453,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 @@ -588,13 +590,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 @@ -646,7 +653,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 @@ -687,8 +694,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_debug_uid.none 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 @@ -741,8 +749,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_debug_uid.none 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 @@ -754,11 +763,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_debug_uid.none - (* 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 @@ -775,19 +781,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_debug_uid.none 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 @@ -864,26 +872,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, 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 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_debug_uid.none (* CR sspies: fix *) ] + [BP.create let_bound_var return_kind let_bound_var_duid] |> Bound_parameters.create in let close call_kind = @@ -904,7 +916,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 @@ -1642,8 +1654,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_debug_uid.none 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 @@ -1683,8 +1696,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_debug_uid.none 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 @@ -1760,20 +1774,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 = @@ -1826,6 +1848,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 @@ -1852,23 +1875,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_debug_uid.none (* 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_debug_uid.none - (* 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, @@ -1902,6 +1928,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 @@ -1912,24 +1939,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_debug_uid.none - (* 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_debug_uid.none - (* 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) @@ -1947,15 +1974,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_debug_uid.none - (* 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 @@ -1990,6 +2017,9 @@ 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 + (* CR sspies: Should we have a debug uid available here? How would it interact + with unboxed types? *) let return_continuation = Continuation.create () in let exn_continuation = Continuation.create () in let my_closure = Variable.create "my_closure" in @@ -2025,7 +2055,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) @@ -2034,8 +2064,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_debug_uid.none - (* 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) @@ -2046,8 +2075,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 = @@ -2089,8 +2120,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_debug_uid.none - (* 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))) @@ -2113,12 +2143,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_debug_uid.none - (* 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] @@ -2132,8 +2163,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_debug_uid.none - (* 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: @@ -2273,6 +2304,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 @@ -2410,8 +2442,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_debug_uid.none - (* CR sspies: fix *)) + BP.create var p.kind p.debug_uid) unarized_params |> Bound_parameters.create in @@ -2445,6 +2476,8 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot Project_function_slot { move_from = function_slot; move_to } 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 @@ -2455,6 +2488,8 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot Variable.Map.fold (fun var value_slot (acc, body) -> 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 @@ -2469,7 +2504,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_debug_uid.none 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 @@ -2886,11 +2921,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_debug_uid.none 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, @@ -2987,6 +3022,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 ()) @@ -3018,7 +3056,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_debug_uid.none (* CR tnowak: verify *); + debug_uid = Flambda_debug_uid.none; kind; attributes = Lambda.default_param_attribute; mode = Alloc_mode.For_types.to_lambda mode @@ -3103,7 +3141,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_debug_uid.none ~function_slot + ~let_rec_uid:wrapper_id_duid ~function_slot ~kind: (Lambda.Curried { nlocal = @@ -3133,6 +3171,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 = @@ -3195,10 +3234,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_debug_uid.none - (* 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 = @@ -3214,7 +3252,7 @@ let wrap_over_application acc env full_call (apply : IR.apply) ~remaining Let_with_acc.create acc (Bound_pattern.singleton (Bound_var.create (Variable.create "unit") Flambda_debug_uid.none - (* CR sspies: fix *) Name_mode.normal)) + Name_mode.normal)) (Named.create_prim (Unary (End_region { ghost = true }, Simple.var ghost_region)) apply_dbg) @@ -3223,7 +3261,7 @@ let wrap_over_application acc env full_call (apply : IR.apply) ~remaining Let_with_acc.create acc (Bound_pattern.singleton (Bound_var.create (Variable.create "unit") Flambda_debug_uid.none - (* CR sspies: fix *) Name_mode.normal)) + Name_mode.normal)) (Named.create_prim (Unary (End_region { ghost = false }, Simple.var region)) apply_dbg) @@ -3241,9 +3279,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_debug_uid.none - (* 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 @@ -3251,11 +3287,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_debug_uid.none - (* 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) @@ -3263,7 +3300,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_debug_uid.none Name_mode.normal)) + (Bound_var.create region region_duid Name_mode.normal)) (Named.create_prim (Variadic (Begin_region { ghost = false }, [])) apply_dbg) @@ -3528,6 +3565,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 = @@ -3544,13 +3582,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 @@ -3585,9 +3623,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_debug_uid.none 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 @@ -3608,8 +3645,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_debug_uid.none (* 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_aux.ml b/middle_end/flambda2/from_lambda/closure_conversion_aux.ml index ef1ac19d815..4ca5c953010 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion_aux.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion_aux.ml @@ -747,7 +747,7 @@ module Function_decls = struct module Function_decl = struct type param = { name : Ident.t; - var_uid : Flambda_debug_uid.t; + debug_uid : Flambda_debug_uid.t; kind : Flambda_kind.With_subkind.t; attributes : Lambda.parameter_attribute; mode : Lambda.locality_mode @@ -834,6 +834,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 1d7cc54c0fb..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_debug_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_debug_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_debug_uid.t; + debug_uid : Flambda_debug_uid.t; kind : Flambda_kind.With_subkind.t; attributes : Lambda.parameter_attribute; mode : Lambda.locality_mode @@ -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 fd90a08fc67..4817bc138f9 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml @@ -137,7 +137,7 @@ let compile_staticfail acc env ccenv ~(continuation : Continuation.t) ~args : fun acc ccenv -> CC.close_let acc ccenv [ ( Ident.create_local "unit", - Flambda_debug_uid.none (* 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 }) @@ -282,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_debug_uid.none (* 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_debug_uid.none (* CR sspies: fix*), + Flambda_debug_uid.none, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region @@ -376,6 +376,10 @@ let wrap_return_continuation acc env ccenv (apply : IR.apply) = (fun return_value_component kind -> ( return_value_component, 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 @@ -450,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_debug_uid.none 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) @@ -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_debug_uid.none + cps_function env ~fid:id ~fuid:id_duid ~recursive:(Non_recursive : Recursive.t) func in @@ -642,7 +650,6 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) 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) @@ -653,6 +660,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) (fun acc env ccenv new_value _arity -> let new_value = must_be_singleton_simple new_value in let env, new_id = Env.update_mutable_variable env being_assigned in + let new_id_duid = Flambda_debug_uid.none in + (* CR sspies: Or should this be [new_id_duid = + Flambda_debug_uid.of_lambda_debug_uid duid]? *) let body acc ccenv = let body acc ccenv = cps acc env ccenv body k k_exn in CC.close_let acc ccenv @@ -665,7 +675,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) snd (Env.get_mutable_variable_with_kind env being_assigned) in CC.close_let acc ccenv - [new_id, Flambda_debug_uid.none, value_kind] + [new_id, new_id_duid, value_kind] User_visible (Simple new_value) ~body) k_exn | Llet @@ -878,12 +888,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 @@ -913,7 +925,6 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) CC.close_let acc ccenv [ ( Ident.create_local "unit", Flambda_debug_uid.none, - (* CR sspies: can we do better? *) Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region @@ -923,7 +934,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_debug_uid.none, Flambda_kind.With_subkind.region] + [region, region_duid, Flambda_kind.With_subkind.region] Not_user_visible (Begin_region { is_try_region = true; @@ -933,9 +944,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_debug_uid.none, - 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 +960,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 -> @@ -1020,6 +1023,10 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) (fun acc env ccenv new_value _arity -> let new_value = must_be_singleton_simple new_value in let env, new_id = Env.update_mutable_variable env being_assigned in + let new_id_duid = Flambda_debug_uid.none in + (* CR sspies: Can we find a better [Flambda_debug_uid.t] here. (Is that + even necessary?) The environment unfortunately does not track debug + uids. *) let body acc ccenv = apply_cps_cont_simple k acc env ccenv [Const L.const_unit] (Singleton Flambda_kind.With_subkind.tagged_immediate) @@ -1028,7 +1035,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) Env.get_mutable_variable_with_kind env being_assigned in CC.close_let acc ccenv - [new_id, Flambda_debug_uid.none, value_kind] + [new_id, new_id_duid, value_kind] User_visible (Simple new_value) ~body) k_exn | Levent (body, _event) -> cps acc env ccenv body k k_exn @@ -1058,7 +1065,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_debug_uid.none (* CR sspies: fix *), + Flambda_debug_uid.none, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (End_region @@ -1071,14 +1078,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_debug_uid.none, Flambda_kind.With_subkind.region] + [region, region_duid, Flambda_kind.With_subkind.region] Not_user_visible (Begin_region { is_try_region = false; @@ -1088,9 +1097,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_debug_uid.none (* 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; @@ -1517,19 +1524,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 ) : Function_decl.param list -> + (fun (({ name; debug_uid; layout; mode; attributes } : L.lparam), kinds) : + Function_decl.param list -> match kinds with | [] -> [] | [kind] -> - let var_uid = Flambda_debug_uid.of_lambda_debug_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_debug_uid.of_lambda_debug_uid_proj var_uid ~field:n + Flambda_debug_uid.of_lambda_debug_uid_proj debug_uid ~field:n in let ident = Ident.create_local @@ -1544,8 +1551,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 @@ -1681,13 +1688,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_debug_uid.none, + scrutinee_tag_duid, Flambda_kind.With_subkind.tagged_immediate ) ] Not_user_visible (Get_tag scrutinee) ~body in @@ -1707,6 +1715,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 @@ -1721,7 +1730,7 @@ and cps_switch acc env ccenv (switch : L.lambda_switch) ~condition_dbg in CC.close_let acc ccenv [ ( is_scrutinee_int, - Flambda_debug_uid.none, + 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 1f44e1eb4cb..85ef24e4949 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_env.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_env.ml @@ -72,6 +72,9 @@ type t = { current_unit : Compilation_unit.t; current_values_of_mutables_in_scope : (Ident.t * Flambda_kind.With_subkind.t) Ident.Map.t; + (* CR sspies: Should this additinally track the debug uid of the variables? + There is currently a point belowm where we set the debug uids for the + variables in this map to [.none]. *) mutables_needed_by_continuations : Ident.Set.t Continuation.Map.t; unboxed_product_components_in_scope : ([`Complex] Flambda_arity.Component_for_creation.t @@ -214,7 +217,11 @@ let add_continuation t cont ~push_to_try_stack ~pop_region in let extra_params = List.map - (fun (id, kind) -> id, Flambda_debug_uid.none (* CR sspies: fix *), kind) + (fun (id, kind) -> + let id_duid = Flambda_debug_uid.none in + (* CR sspies: Do the original variables in + [current_values_of_mutables_in_scope] not have a debug uid? *) + id, id_duid, kind) extra_params in { body_env; handler_env; extra_params } @@ -277,7 +284,10 @@ let extra_args_for_continuation_with_kinds t cont = | exception Not_found -> Misc.fatal_errorf "No current value for %a" Ident.print mut | current_value, kind -> - current_value, Flambda_debug_uid.none (* CR sspies: fix *), kind) + let current_value_duid = Flambda_debug_uid.none in + (* CR sspies: Do these variables have any debug uids that we could use + here? Are they always not user visible variables? *) + current_value, current_value_duid, kind) mutables let extra_args_for_continuation t cont = 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 c8b16e16da5..a3b6c384592 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 @@ -309,23 +309,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_debug_uid.none 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_debug_uid.none (* 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 +351,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_debug_uid.none - (* 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 @@ -395,7 +398,7 @@ let rec bind_recs acc exn_cont ~register_const0 (prim : expr_primitive) let named = must_be_singleton_named nameds in let pat = Bound_var.create (Variable.create "seq") Flambda_debug_uid.none - (* CR sspies: fix *) Name_mode.normal + Name_mode.normal |> Bound_pattern.singleton in Let_with_acc.create acc pat named ~body)) @@ -416,13 +419,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_debug_uid.none 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/parser/fexpr_to_flambda.ml b/middle_end/flambda2/parser/fexpr_to_flambda.ml index 541c37db23f..09f7b883a50 100644 --- a/middle_end/flambda2/parser/fexpr_to_flambda.ml +++ b/middle_end/flambda2/parser/fexpr_to_flambda.ml @@ -130,11 +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 + 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, - Flambda_debug_uid.none, - { env with variables = VM.add name v env.variables } ) + 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 diff --git a/middle_end/flambda2/simplify/env/downwards_env.ml b/middle_end/flambda2/simplify/env/downwards_env.ml index f4db75188f1..29c3f488636 100644 --- a/middle_end/flambda2/simplify/env/downwards_env.ml +++ b/middle_end/flambda2/simplify/env/downwards_env.ml @@ -144,9 +144,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_debug_uid.none - (* CR sspies: Unclear whether bound variables should have a - [Flambda_debug_uid.t]. For now, I just left it as [.none]. *)) + (Bound_var.debug_uid var)) in variables_defined_in_current_continuation :: r in @@ -319,7 +317,7 @@ let define_name t name kind = ~var:(fun [@inline] var -> (define_variable [@inlined hint]) t (Bound_var.create var Flambda_debug_uid.none - (* CR sspies: Unclear whether bound variables should have a + (* 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) @@ -343,7 +341,7 @@ let add_name t name ty = ~var:(fun [@inline] var -> add_variable t (Bound_var.create var Flambda_debug_uid.none - (* CR sspies: Unclear whether bound variables should have a + (* 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) diff --git a/middle_end/flambda2/simplify/inlining/inlining_transforms.ml b/middle_end/flambda2/simplify/inlining/inlining_transforms.ml index bfcb9712f83..a9b160ed3f4 100644 --- a/middle_end/flambda2/simplify/inlining/inlining_transforms.ml +++ b/middle_end/flambda2/simplify/inlining/inlining_transforms.ml @@ -70,7 +70,6 @@ let make_inlined_body ~callee ~called_code_id ~unroll_to ~params ~args in let bind_depth ~my_depth ~rec_info ~body = let my_depth_duid = Flambda_debug_uid.none in - (* CR sspies: [my_depth] sounds like something internally generated. *) let bound = Bound_pattern.singleton (VB.create my_depth my_depth_duid Name_mode.normal) From 88bc6df77eaf37e5df5520fef7430889a5487378 Mon Sep 17 00:00:00 2001 From: Simon Spies Date: Mon, 5 May 2025 16:29:27 +0100 Subject: [PATCH 9/9] update comments for Name_mode.in_types --- middle_end/flambda2/types/env/join_env.ml | 6 +++--- middle_end/flambda2/types/equal_types_for_debug.ml | 12 ++++++------ middle_end/flambda2/types/join_levels_old.ml | 7 +++---- middle_end/flambda2/types/meet_and_n_way_join.ml | 12 ++++++------ 4 files changed, 18 insertions(+), 19 deletions(-) diff --git a/middle_end/flambda2/types/env/join_env.ml b/middle_end/flambda2/types/env/join_env.ml index 017454fcc2d..809b0b14930 100644 --- a/middle_end/flambda2/types/env/join_env.ml +++ b/middle_end/flambda2/types/env/join_env.ml @@ -1194,9 +1194,9 @@ let cut_and_n_way_join ~n_way_join_type ~meet_type ~cut_after target_env TE.add_definition target_env (Bound_name.create_var (Bound_var.create var Flambda_debug_uid.none - (* CR sspies: We can probably find a better - [Flambda_debug_uid.t] for these extra variables. However, - propagating it here seems non-trivial. *) + (* 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 diff --git a/middle_end/flambda2/types/equal_types_for_debug.ml b/middle_end/flambda2/types/equal_types_for_debug.ml index ebe24f44539..0b371072af0 100644 --- a/middle_end/flambda2/types/equal_types_for_debug.ml +++ b/middle_end/flambda2/types/equal_types_for_debug.ml @@ -464,9 +464,9 @@ let names_with_non_equal_types_level_ignoring_name_mode ~meet_type env level1 TE.add_definition left_env (Bound_name.create_var (Bound_var.create var Flambda_debug_uid.none - (* CR sspies: We can probably find a better - [Flambda_debug_uid.t] for these variables. However, - propagating it here seems non-trivial. *) + (* 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 @@ -477,9 +477,9 @@ let names_with_non_equal_types_level_ignoring_name_mode ~meet_type env level1 TE.add_definition right_env (Bound_name.create_var (Bound_var.create var Flambda_debug_uid.none - (* CR sspies: We can probably find a better - [Flambda_debug_uid.t] for these variables. However, - propagating it here seems non-trivial. *) + (* 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 cd6eb9149ea..e29b0d0f146 100644 --- a/middle_end/flambda2/types/join_levels_old.ml +++ b/middle_end/flambda2/types/join_levels_old.ml @@ -47,10 +47,9 @@ let join_types ~env_at_fork envs_with_levels = TE.add_definition base_env (Bound_name.create_var (Bound_var.create var Flambda_debug_uid.none - (* CR sspies: We can probably find a better - [Flambda_debug_uid.t] for these variables. - However, propagating it here seems - non-trivial. *) + (* 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) 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 1be2fb4f37a..39f745618ea 100644 --- a/middle_end/flambda2/types/meet_and_n_way_join.ml +++ b/middle_end/flambda2/types/meet_and_n_way_join.ml @@ -285,9 +285,9 @@ let add_defined_vars env level = TE.add_definition env (Bound_name.create_var (Bound_var.create var Flambda_debug_uid.none - (* CR sspies: We can probably find a better [Flambda_debug_uid.t] - for these variables. However, propagating it here seems - non-trivial. *) + (* 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 @@ -1230,9 +1230,9 @@ and meet_row_like : TE.add_definition env (Bound_name.create_var (Bound_var.create var Flambda_debug_uid.none - (* CR sspies: We can probably find a better - [Flambda_debug_uid.t] for these extra variables. However, - propagating it here seems non-trivial. *) + (* 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