From 306d389b488a296b6eac0e25a89b0aef673f8508 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Wed, 7 Oct 2026 16:03:29 +0000 Subject: [PATCH] Store an application's location directly in Lambda.lambda_apply Removing the @inlined attribute left ap_info as a record with a single field, ap_loc. Store the location in lambda_apply instead, and pass it to Lambda.apply as a plain Location.t, like prim takes its location. Signed-off-by: Christoph Knittel Co-Authored-By: Claude Opus 5.5 --- compiler/core/lam_beta_reduce_util.ml | 4 +-- compiler/core/lam_bounded_vars.ml | 4 +-- compiler/core/lam_compile.ml | 6 ++--- compiler/core/lam_pass_remove_alias.ml | 8 +++--- compiler/core/lam_util.ml | 4 +-- compiler/ml/lambda.ml | 26 ++++++++----------- compiler/ml/lambda.mli | 6 ++--- compiler/ml/lambda_traverse.ml | 4 +-- compiler/ml/translcore.ml | 8 +++--- compiler/ml/translmod.ml | 5 ++-- .../ounit_lambda_traverse_tests.ml | 2 +- 11 files changed, 34 insertions(+), 43 deletions(-) diff --git a/compiler/core/lam_beta_reduce_util.ml b/compiler/core/lam_beta_reduce_util.ml index 00b70ce726c..f771a3d95f6 100644 --- a/compiler/core/lam_beta_reduce_util.ml +++ b/compiler/core/lam_beta_reduce_util.ml @@ -94,7 +94,7 @@ let simple_beta_reduce params body args = (Lvar _ | Lprim {primitive = Pfield _; args = [Lglobal_module _]}) as f; ap_args; - ap_info; + ap_loc; } -> ( let () = List.iter2 @@ -114,7 +114,7 @@ let simple_beta_reduce params body args = | _ -> f in let result = - Hash_ident.fold param_hash (Lambda.apply f new_args ap_info) + Hash_ident.fold param_hash (Lambda.apply f new_args ap_loc) (fun _param stat acc -> let {lambda; used} = stat in if not used then Lambda.seq lambda acc else acc) diff --git a/compiler/core/lam_bounded_vars.ml b/compiler/core/lam_bounded_vars.ml index 4737086a083..a96ab691450 100644 --- a/compiler/core/lam_bounded_vars.ml +++ b/compiler/core/lam_bounded_vars.ml @@ -118,10 +118,10 @@ let rewrite (map : _ Hash_ident.t) (lam : Lambda.t) : Lambda.t = (* here it makes sure that global vars are not rebound *) Lambda.prim ~primitive ~args:(Ext_list.map args aux) loc | Lglobal_module _ -> lam - | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> + | Lapply {ap_func; ap_args; ap_loc; ap_transformed_jsx} -> let fn = aux ap_func in let args = Ext_list.map ap_args aux in - Lambda.apply ~ap_transformed_jsx fn args ap_info + Lambda.apply ~ap_transformed_jsx fn args ap_loc | Lswitch ( l, { diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 3e1912b2b7c..147eee82d79 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -34,7 +34,7 @@ let with_source_loc loc (exp : J.expression) = let rec source_loc_of_lam (lam : Lambda.t) = match lam with - | Lapply {ap_info = {ap_loc}} -> Some ap_loc + | Lapply {ap_loc} -> Some ap_loc | Lprim {loc} | Lfunction {loc} -> Some loc | Llet (_, _, arg, body) -> ( match source_loc_of_lam arg with @@ -356,7 +356,7 @@ let compile output_prefix = appinfo) fn args in - let expression = with_source_loc appinfo.ap_info.ap_loc expression in + let expression = with_source_loc appinfo.ap_loc expression in Js_output.output_of_block_and_expression lambda_cxt.continuation args_code expression (* @@ -1606,7 +1606,7 @@ let compile output_prefix = | _ -> Js_output.output_of_block_and_expression lambda_cxt.continuation args_code - (with_source_loc appinfo.ap_info.ap_loc + (with_source_loc appinfo.ap_loc (E.call ~info: (call_info_of_apply lambda_cxt.meta appinfo.ap_transformed_jsx diff --git a/compiler/core/lam_pass_remove_alias.ml b/compiler/core/lam_pass_remove_alias.ml index edad8785760..f0b33d5cf17 100644 --- a/compiler/core/lam_pass_remove_alias.ml +++ b/compiler/core/lam_pass_remove_alias.ml @@ -130,7 +130,7 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lambda.t) : Lambda.t = _; } as l1; ap_args = args; - ap_info; + ap_loc; } -> ( match Lam_compile_env.query_external_id_info ident fld_name with | { @@ -151,7 +151,7 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lambda.t) : Lambda.t = let fn = simpl l1 in let args' = Ext_list.map_sharing args simpl in if fn == l1 && args' == args then lam - else Lambda.apply fn args' ap_info ?ap_transformed_jsx:None) + else Lambda.apply fn args' ap_loc ?ap_transformed_jsx:None) (* Function inlining interact with other optimizations... - parameter attributes @@ -159,14 +159,14 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lambda.t) : Lambda.t = - code bloat *) | Lapply - {ap_func = Lvar v as fn; ap_args = args; ap_info; ap_transformed_jsx} + {ap_func = Lvar v as fn; ap_args = args; ap_loc; ap_transformed_jsx} -> ( (* Check info for always inlining *) let ap_args = Ext_list.map_sharing args simpl in let[@local] normal () = let fn' = simpl fn in if fn' == fn && ap_args == args then lam - else Lambda.apply fn' ap_args ap_info ~ap_transformed_jsx + else Lambda.apply fn' ap_args ap_loc ~ap_transformed_jsx in match Hash_ident.find_opt meta.ident_tbl v with | Some diff --git a/compiler/core/lam_util.ml b/compiler/core/lam_util.ml index 04ad4d468df..fb5a2411ec8 100644 --- a/compiler/core/lam_util.ml +++ b/compiler/core/lam_util.ml @@ -105,12 +105,12 @@ let refine_let ?original ~kind param (arg : Lambda.t) (l : Lambda.t) : Lambda.t with `value`. This only happens for primitives that are pure and do not allocate new blocks, so evaluation order and side effects stay the same. *) Lambda.prim ~primitive ~args:[arg] loc - | _, _, Lapply {ap_func = fn; ap_args = [Lvar w]; ap_info; ap_transformed_jsx} + | _, _, Lapply {ap_func = fn; ap_args = [Lvar w]; ap_loc; ap_transformed_jsx} when Ident.same w param && not (Lam_hit.hit_variable param fn) -> (* For a function call such as `{ let x = value; someFn(x) }`, we can rewrite to `someFn(value)` as long as the callee does not capture `x`. This removes the temporary binding while preserving the call semantics. *) - Lambda.apply fn [arg] ap_info ~ap_transformed_jsx + Lambda.apply fn [arg] ap_loc ~ap_transformed_jsx | (Strict | StrictOpt), arg, _ when is_safe_to_alias arg -> (* `Strict` and `StrictOpt` bindings both evaluate the RHS immediately (with `StrictOpt` allowing later elimination if unused). When that RHS diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 24ec6eb7846..e19a0670c2b 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -362,12 +362,10 @@ and lfunction = { and prim_info = {primitive: primitive; args: t list; loc: Location.t} -and ap_info = {ap_loc: Location.t} - and lambda_apply = { ap_func: t; ap_args: t list; - ap_info: ap_info; + ap_loc: Location.t; ap_transformed_jsx: bool; } @@ -1074,7 +1072,7 @@ let prim ~primitive:(prim : primitive) ~args loc : t = *) | _ -> default ()) -let rec apply ?(ap_transformed_jsx = false) fn args (ap_info : ap_info) : t = +let rec apply ?(ap_transformed_jsx = false) fn args (ap_loc : Location.t) : t = match fn with | Lfunction { @@ -1091,21 +1089,20 @@ let rec apply ?(ap_transformed_jsx = false) fn args (ap_info : ap_info) : t = } -> ( match is_eta_conversion_exn params inner_args args with | args -> - let loc = ap_info.ap_loc in prim ~primitive:wrap - ~args:[prim ~primitive:primitive_call.primitive ~args loc] - loc + ~args:[prim ~primitive:primitive_call.primitive ~args ap_loc] + ap_loc | exception Not_simple_form -> - Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx}) + Lapply {ap_func = fn; ap_args = args; ap_loc; ap_transformed_jsx}) | Lfunction { params; body = Lprim ({primitive = _; args = inner_args} as primitive_call); } -> ( match is_eta_conversion_exn params inner_args args with - | args -> prim ~primitive:primitive_call.primitive ~args ap_info.ap_loc + | args -> prim ~primitive:primitive_call.primitive ~args ap_loc | exception _ -> - Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx}) + Lapply {ap_func = fn; ap_args = args; ap_loc; ap_transformed_jsx}) | Lfunction { params; @@ -1115,20 +1112,19 @@ let rec apply ?(ap_transformed_jsx = false) fn args (ap_info : ap_info) : t = (Lconst _ as const) ); } -> ( match is_eta_conversion_exn params inner_args args with - | args -> - seq (prim ~primitive:primitive_call.primitive ~args ap_info.ap_loc) const + | args -> seq (prim ~primitive:primitive_call.primitive ~args ap_loc) const | exception _ -> - Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx} + Lapply {ap_func = fn; ap_args = args; ap_loc; ap_transformed_jsx} (* | Lfunction {params;body} when Ext_list.same_length params args -> Ext_list.fold_right2 (fun p arg acc -> Llet(Strict,p,arg,acc) ) params args body *) (* TODO: more rigirous analysis on [let_kind] *)) | Llet (kind, id, e, (Lfunction _ as fn)) -> - let_ kind id e (apply fn args ap_info ~ap_transformed_jsx) + let_ kind id e (apply fn args ap_loc ~ap_transformed_jsx) (* | Llet (kind0, id0, e0, Llet (kind,id, e, (Lfunction _ as fn))) -> Llet(kind0,id0,e0,Llet (kind, id, e, apply fn args loc status)) *) - | _ -> Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx} + | _ -> Lapply {ap_func = fn; ap_args = args; ap_loc; ap_transformed_jsx} let not_ loc x : t = match x with diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 49a26d5e636..30741c141ba 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -375,12 +375,10 @@ and lfunction = { and prim_info = private {primitive: primitive; args: t list; loc: Location.t} -and ap_info = {ap_loc: Location.t} - and lambda_apply = private { ap_func: t; ap_args: t list; - ap_info: ap_info; + ap_loc: Location.t; ap_transformed_jsx: bool; } @@ -456,7 +454,7 @@ val global_module : Ident.t -> t val const : structured_constant -> t -val apply : ?ap_transformed_jsx:bool -> t -> t list -> ap_info -> t +val apply : ?ap_transformed_jsx:bool -> t -> t list -> Location.t -> t val function_ : loc:Location.t -> diff --git a/compiler/ml/lambda_traverse.ml b/compiler/ml/lambda_traverse.ml index f0cfeb222fa..4dbae1e53f5 100644 --- a/compiler/ml/lambda_traverse.ml +++ b/compiler/ml/lambda_traverse.ml @@ -40,7 +40,7 @@ let shallow_map_sharing (f : t -> t) (lam : t) : t = let fn = f ap.ap_func in let args = Ext_list.map_sharing ap.ap_args f in if fn == ap.ap_func && args == ap.ap_args then lam - else apply fn args ap.ap_info ~ap_transformed_jsx:ap.ap_transformed_jsx + else apply fn args ap.ap_loc ~ap_transformed_jsx:ap.ap_transformed_jsx | Lfunction {params; body; attr; loc} -> let body' = f body in if body' == body then lam else function_ ~loc ~attr ~params ~body:body' @@ -124,7 +124,7 @@ let make_key e = | Lglobal_module _ | Lconst _ -> e | Lapply ap -> apply ~ap_transformed_jsx:ap.ap_transformed_jsx (tr_rec env ap.ap_func) - (tr_recs env ap.ap_args) {ap_loc = Location.none} + (tr_recs env ap.ap_args) Location.none | Llet (Alias, x, ex, e) -> (* Ignore aliases -> substitute *) let ex = tr_rec env ex in diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 2953971a889..17670ed5ab1 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -909,7 +909,7 @@ let wrap_exn loc arg = ~args: [global_module (Ident.create_persistent Primitive_modules.exceptions)] loc) - [arg] {ap_loc = loc} + [arg] loc let exception_id_destructed (l : Lambda.t) (fv : Ident.t) : bool = let rec hit_opt = function | None -> false @@ -1314,7 +1314,7 @@ and transl_cases cases = List.map transl_case cases and transl_apply ?(uncurried_partial_application = None) ?(transformed_jsx = false) lam sargs loc = let lapply ap_func ap_args = - apply ~ap_transformed_jsx:transformed_jsx ap_func ap_args {ap_loc = loc} + apply ~ap_transformed_jsx:transformed_jsx ap_func ap_args loc in let rec build_apply lam args = function | (None, optional) :: l -> @@ -1364,9 +1364,7 @@ and transl_apply ?(uncurried_partial_application = None) in let extra_args = Ext_list.map extra_ids (fun id -> var id) in let ap_args = args @ extra_args in - let l0 = - apply ~ap_transformed_jsx:transformed_jsx lam ap_args {ap_loc = loc} - in + let l0 = apply ~ap_transformed_jsx:transformed_jsx lam ap_args loc in function_ ~loc ~attr:default_function_attribute ~params:(List.rev_append !none_ids extra_ids) ~body:l0 diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index 1badca9a9c1..bfa648769e3 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -125,8 +125,7 @@ and apply_coercion_result loc strict funct param arg cc_res = ~params:[param] ~body: (apply_coercion loc Strict cc_res - (Lambda.apply ~ap_transformed_jsx:false (Lambda.var id) [arg] - {ap_loc = loc}))) + (Lambda.apply ~ap_transformed_jsx:false (Lambda.var id) [arg] loc))) and wrap_id_pos_list loc id_pos_list get_field lam = let fv = Lambda_traverse.free_variables lam in @@ -289,7 +288,7 @@ and transl_module0 cc rootpath mexp = (Lambda.apply ~ap_transformed_jsx:false (transl_module Tcoerce_none None funct) [transl_module ccarg None arg] - {ap_loc = loc}) + loc) | Tmod_constraint (arg, _, _, ccarg) -> transl_module (compose_coercions cc ccarg) rootpath arg | Tmod_unpack (arg, _) -> diff --git a/tests/ounit_tests/ounit_lambda_traverse_tests.ml b/tests/ounit_tests/ounit_lambda_traverse_tests.ml index 4b11e4d213d..67d3f39a185 100644 --- a/tests/ounit_tests/ounit_lambda_traverse_tests.ml +++ b/tests/ounit_tests/ounit_lambda_traverse_tests.ml @@ -10,7 +10,7 @@ let var = Lambda.var x would pass either check below without exercising anything. *) let nodes : (string * Lambda.t) list = [ - ("apply", Lambda.apply var [var] {ap_loc = loc}); + ("apply", Lambda.apply var [var] loc); ( "function", Lambda.function_ ~loc ~attr:Lambda.default_function_attribute ~params:[x] ~body:debugger );