From 3c50e90bf7618e9a30de46d10523ca6791b72d5d Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 22 Aug 2026 14:43:33 +0200 Subject: [PATCH 01/12] Add `@res.hoistedFunction` support for flat JS export Signed-off-by: Christoph Knittel --- CHANGELOG.md | 1 + compiler/core/js_cmj_format.ml | 20 ++- compiler/core/js_cmj_format.mli | 9 + compiler/core/lam_compile.ml | 102 ++++++++--- compiler/core/lam_compile_env.ml | 26 +-- compiler/core/lam_compile_env.mli | 3 + compiler/core/lam_compile_main.ml | 143 ++++++++++++++- compiler/core/lam_stats_export.ml | 6 +- compiler/core/lam_stats_export.mli | 1 + compiler/ext/ident.ml | 5 + compiler/ext/ident.mli | 2 + compiler/ml/translattribute.ml | 15 ++ compiler/ml/translattribute.mli | 2 + compiler/ml/translcore.ml | 32 +++- compiler/ml/translcore.mli | 1 + compiler/ml/translmod.ml | 27 ++- ...ted_function_export_collision.res.expected | 11 ++ ...sted_function_invalid_payload.res.expected | 11 ++ ...isted_function_not_exportable.res.expected | 34 ++++ ...isted_function_path_collision.res.expected | 11 ++ .../hoisted_function_export_collision.res | 5 + .../hoisted_function_invalid_payload.res | 4 + .../hoisted_function_not_exportable.res | 17 ++ .../hoisted_function_path_collision.res | 9 + tests/tests/src/hoisted_function_attr.mjs | 165 ++++++++++++++++++ tests/tests/src/hoisted_function_attr.res | 69 ++++++++ .../tests/src/hoisted_function_attr_test.mjs | 26 +++ .../tests/src/hoisted_function_attr_test.res | 29 +++ tests/tests/src/hoisted_function_attr_use.mjs | 46 +++++ tests/tests/src/hoisted_function_attr_use.res | 17 ++ 30 files changed, 800 insertions(+), 49 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/hoisted_function_export_collision.res.expected create mode 100644 tests/build_tests/super_errors/expected/hoisted_function_invalid_payload.res.expected create mode 100644 tests/build_tests/super_errors/expected/hoisted_function_not_exportable.res.expected create mode 100644 tests/build_tests/super_errors/expected/hoisted_function_path_collision.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/hoisted_function_export_collision.res create mode 100644 tests/build_tests/super_errors/fixtures/hoisted_function_invalid_payload.res create mode 100644 tests/build_tests/super_errors/fixtures/hoisted_function_not_exportable.res create mode 100644 tests/build_tests/super_errors/fixtures/hoisted_function_path_collision.res create mode 100644 tests/tests/src/hoisted_function_attr.mjs create mode 100644 tests/tests/src/hoisted_function_attr.res create mode 100644 tests/tests/src/hoisted_function_attr_test.mjs create mode 100644 tests/tests/src/hoisted_function_attr_test.res create mode 100644 tests/tests/src/hoisted_function_attr_use.mjs create mode 100644 tests/tests/src/hoisted_function_attr_use.res diff --git a/CHANGELOG.md b/CHANGELOG.md index ff63df08f19..9a4d0eea4a8 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -23,6 +23,7 @@ #### :rocket: New Feature +- Add `@res.hoistedFunction` for emitting nested module functions as flat JavaScript exports. https://github.com/rescript-lang/rescript/pull/8402 - Add source map support with linked, inline, and hidden modes. https://github.com/rescript-lang/rescript/pull/8393 - Add `List.includes`, deprecate `List.has` in favor of `List.some`, and clarify the equality semantics of `List.includes` and `Array.includes`. https://github.com/rescript-lang/rescript/pull/8530 diff --git a/compiler/core/js_cmj_format.ml b/compiler/core/js_cmj_format.ml index 0956812bb0d..9df5ffdac89 100644 --- a/compiler/core/js_cmj_format.ml +++ b/compiler/core/js_cmj_format.ml @@ -45,14 +45,21 @@ type keyed_cmj_value = { type keyed_cmj_values = keyed_cmj_value array +type hoisted_export = { + path: string list; (** Exact source-level module path segments. *) + name: string; (** Flat compiler identifier used for the public JS export. *) +} + type t = { values: keyed_cmj_values; + hoisted_exports: hoisted_export array; pure: bool; package_spec: Js_packages_info.t; case: Ext_js_file_kind.case; } -let make ~(values : cmj_value Map_string.t) ~effect_ ~package_spec ~case : t = +let make ~(values : cmj_value Map_string.t) ~hoisted_exports ~effect_ + ~package_spec ~case : t = { values = Map_string.to_sorted_array_with_f values (fun k v -> @@ -61,6 +68,7 @@ let make ~(values : cmj_value Map_string.t) ~effect_ ~package_spec ~case : t = arity = v.arity; persistent_closed_lambda = v.persistent_closed_lambda; }); + hoisted_exports = Array.of_list hoisted_exports; pure = effect_ = None; package_spec; case; @@ -97,7 +105,8 @@ let to_file name ~check_exists (v : t) = output_string oc s; close_out oc) -let key_comp (a : string) b = Map_string.compare_key a b.name +let key_comp (a : string) (b : keyed_cmj_value) = + Map_string.compare_key a b.name let not_found key = {name = key; arity = single_na; persistent_closed_lambda = None} @@ -151,6 +160,13 @@ let query_by_name (cmj_table : t) name : keyed_cmj_value = let values = cmj_table.values in binary_search values name +let find_hoisted_export (cmj_table : t) path = + Array.find_map + (fun value -> + if List.equal Ext_string.equal value.path path then Some value.name + else None) + cmj_table.hoisted_exports + type path = string type cmj_load_info = { diff --git a/compiler/core/js_cmj_format.mli b/compiler/core/js_cmj_format.mli index 32c8c423e87..5cfd0a703d7 100644 --- a/compiler/core/js_cmj_format.mli +++ b/compiler/core/js_cmj_format.mli @@ -60,8 +60,14 @@ type keyed_cmj_value = { persistent_closed_lambda: Lam.t option; } +type hoisted_export = { + path: string list; (** Exact source-level module path segments. *) + name: string; (** Flat compiler identifier used for the public JS export. *) +} + type t = { values: keyed_cmj_value array; + hoisted_exports: hoisted_export array; pure: bool; package_spec: Js_packages_info.t; case: Ext_js_file_kind.case; @@ -69,6 +75,7 @@ type t = { val make : values:cmj_value Map_string.t -> + hoisted_exports:hoisted_export list -> effect_:effect_ -> package_spec:Js_packages_info.t -> case:Ext_js_file_kind.case -> @@ -76,6 +83,8 @@ val make : val query_by_name : t -> string -> keyed_cmj_value +val find_hoisted_export : t -> string list -> string option + val single_na : arity val from_file : string -> t diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index dfb703f37d5..05c78d08d20 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -290,6 +290,39 @@ type initialization = J.block *) let compile output_prefix = + (* When compiling a read from another module, a nested source path like + Other.A.B.make reaches this point as nested module-field reads: + + Pfield "make" (Pfield "B" (Pfield "A" (Lglobal_module Other))) + + Normal compilation does not look up the full path. It only queries the + first field, "A", and then emits the remaining fields as JS property + access: Other.A.B.make. The "A" lookup may include Submodule arity data, + but it does not say whether A.B.make has a separate root-level export. + + Hoisted functions need that extra question. For them, query the separate + hoisted-values table with an unambiguous key for source path A.B.make. If + present, the table returns the root-level JS export name, for example + A$B$make. Normal export metadata still lives in the regular .cmj values + table. *) + let rec extract_field_path segments primitive args = + match (primitive, args) with + | ( Lam_primitive.Pfield (_, Fld_module {name}), + [Lam.Lprim {primitive; args; _}] ) -> + extract_field_path (name :: segments) primitive args + | ( Lam_primitive.Pfield (_, Fld_module {name}), + [Lam.Lglobal_module (id, dynamic_import)] ) -> + Some (id, dynamic_import, name :: segments) + | _ -> None + in + let hoisted_external_field_name primitive args = + match extract_field_path [] primitive args with + | Some (id, dynamic_import, (_ :: _ :: _ as segments)) -> + Ext_option.map + (Lam_compile_env.find_hoisted_external_export ~dynamic_import id + segments) (fun name -> (id, dynamic_import, name)) + | Some (_, _, ([] | [_])) | None -> None + in let rec compile_external_field (* Like [List.empty]*) ?(dynamic_import = false) (lamba_cxt : Lam_compile_context.t) (id : Ident.t) name : Js_output.t = @@ -1718,17 +1751,47 @@ let compile output_prefix = fn_code args))) and compile_prim (prim_info : Lam.prim_info) (lambda_cxt : Lam_compile_context.t) = + let compile_primitive_default primitive args loc = + let args_block, args_expr = + if args = [] then ([], []) + else + let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in + Ext_list.split_map args (fun x -> + match compile_lambda new_cxt x with + | {block; value = Some b} -> (block, b) + | {value = None} -> assert false) + in + let args_code : J.block = List.concat args_block in + let exp = + (* TODO: all can be done in [compile_primitive] *) + Lam_compile_primitive.translate output_prefix loc lambda_cxt primitive + args_expr + in + Js_output.output_of_block_and_expression lambda_cxt.continuation args_code + (with_source_loc loc exp) + in match prim_info with - | { - primitive = Pfield (_, fld_info); - args = [Lglobal_module (id, dynamic_import)]; - _; - } -> ( - (* should be before Lglobal_global *) - match fld_info with - | Fld_module {name = field} -> - compile_external_field ~dynamic_import lambda_cxt id field - | _ -> assert false) + | {primitive = Pfield (_, Fld_module _); _} -> ( + match hoisted_external_field_name prim_info.primitive prim_info.args with + | Some (id, dynamic_import, hoisted_name) -> + Js_output.output_of_expression lambda_cxt.continuation + ~no_effects:no_effects_const + (E.ml_var_dot ~dynamic_import id hoisted_name) + | None -> ( + match prim_info with + | { + primitive = Pfield (_, fld_info); + args = [Lglobal_module (id, dynamic_import)]; + _; + } -> ( + (* should be before Lglobal_global *) + match fld_info with + | Fld_module {name = field} -> + compile_external_field ~dynamic_import lambda_cxt id field + | _ -> assert false) + | _ -> + compile_primitive_default prim_info.primitive prim_info.args + prim_info.loc)) | {primitive = Praise; args = [e]; loc} -> ( match compile_lambda {lambda_cxt with continuation = NeedValue Not_tail} e @@ -1898,24 +1961,7 @@ let compile output_prefix = Location.raise_errorf ~loc "Invalid argument: unsupported argument to dynamic import. If you \ believe this should be supported, please open an issue.") - | {primitive; args; loc} -> - let args_block, args_expr = - if args = [] then ([], []) - else - let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in - Ext_list.split_map args (fun x -> - match compile_lambda new_cxt x with - | {block; value = Some b} -> (block, b) - | {value = None} -> assert false) - in - let args_code : J.block = List.concat args_block in - let exp = - (* TODO: all can be done in [compile_primitive] *) - Lam_compile_primitive.translate output_prefix loc lambda_cxt primitive - args_expr - in - Js_output.output_of_block_and_expression lambda_cxt.continuation args_code - (with_source_loc loc exp) + | {primitive; args; loc} -> compile_primitive_default primitive args loc and collect_dup_overrides (copy_id : Ident.t) (lam : Lam.t) (acc : (Lam_compat.set_field_dbg_info * Lam.t) list) : (Lam_compat.set_field_dbg_info * Lam.t) list option = diff --git a/compiler/core/lam_compile_env.ml b/compiler/core/lam_compile_env.ml index a23b6116809..98cc70ddc32 100644 --- a/compiler/core/lam_compile_env.ml +++ b/compiler/core/lam_compile_env.ml @@ -84,20 +84,26 @@ let add_js_module ?import_attributes id | Some old_key -> old_key.id +let cmj_table_of_module_id ~dynamic_import (module_id : Ident.t) = + let oid = Lam_module_ident.of_ml ~dynamic_import module_id in + match Lam_module_ident.Hash.find_opt cached_tbl oid with + | None -> + let cmj_load_info = !Js_cmj_load.load_unit module_id.name in + oid +> Ml cmj_load_info; + cmj_load_info.cmj_table + | Some (Ml {cmj_table}) -> cmj_table + | Some External -> assert false + let query_external_id_info ?(dynamic_import = false) (module_id : Ident.t) (name : string) : ident_info = - let oid = Lam_module_ident.of_ml ~dynamic_import module_id in - let cmj_table = - match Lam_module_ident.Hash.find_opt cached_tbl oid with - | None -> - let cmj_load_info = !Js_cmj_load.load_unit module_id.name in - oid +> Ml cmj_load_info; - cmj_load_info.cmj_table - | Some (Ml {cmj_table}) -> cmj_table - | Some External -> assert false - in + let cmj_table = cmj_table_of_module_id ~dynamic_import module_id in Js_cmj_format.query_by_name cmj_table name +let find_hoisted_external_export ?(dynamic_import = false) (module_id : Ident.t) + (path : string list) : string option = + let cmj_table = cmj_table_of_module_id ~dynamic_import module_id in + Js_cmj_format.find_hoisted_export cmj_table path + let get_package_path_from_cmj (id : Lam_module_ident.t) : string * Js_packages_info.t * Ext_js_file_kind.case = let cmj_load_info = diff --git a/compiler/core/lam_compile_env.mli b/compiler/core/lam_compile_env.mli index 75527d0eee3..3472b82d883 100644 --- a/compiler/core/lam_compile_env.mli +++ b/compiler/core/lam_compile_env.mli @@ -71,6 +71,9 @@ val query_external_id_info : will raise if not found *) +val find_hoisted_external_export : + ?dynamic_import:bool -> Ident.t -> string list -> string option + val is_pure_module : Lam_module_ident.t -> bool val get_package_path_from_cmj : diff --git a/compiler/core/lam_compile_main.ml b/compiler/core/lam_compile_main.ml index 4db6c659179..3f4b1ec7b96 100644 --- a/compiler/core/lam_compile_main.ml +++ b/compiler/core/lam_compile_main.ml @@ -107,6 +107,119 @@ let no_side_effects (rest : Lam_group.t list) : string option = Some "" else None (* TODO :*)) +(* Materialize JS-hoisted values as root-level aliases and exports. The source + value still lives at its normal module path, but downstream tools can import + the flat name directly when the .cmj metadata marks it as hoisted. *) +let js_hoisted_aliases (export_idents : Set_ident.t) (groups : Lam_group.t list) + = + let has_hoisted_binding = + List.exists + (function + | Lam_group.Single (_, id, _) -> Ident.js_hoisted id + | Lam_group.Recursive bindings -> + List.exists (fun (id, _) -> Ident.js_hoisted id) bindings + | Lam_group.Nop _ -> false) + groups + in + if not has_hoisted_binding then [] + else + let group_map = + Ext_list.fold_left groups Map_ident.empty (fun group_map group -> + match group with + | Single (_, id, lam) -> Map_ident.add group_map id lam + | Recursive bindings -> + Ext_list.fold_left bindings group_map (fun group_map (id, lam) -> + Map_ident.add group_map id lam) + | Nop _ -> group_map) + in + let rec access loc base fields = + match fields with + | [] -> base + | (pos, name) :: fields -> + access loc + (Lam.prim + ~primitive: + (Lam_primitive.Pfield (pos, Lam_compat.Fld_module {name})) + ~args:[base] loc) + fields + in + let resolve = function + | Lam.Lvar id as lam -> ( + match Map_ident.find_opt group_map id with + | Some resolved -> resolved + | None -> lam) + | lam -> lam + in + let rec fold_module_fields fields args index acc f = + match (fields, args) with + | [], [] -> acc + | field :: fields, arg :: args -> + fold_module_fields fields args (index + 1) (f index field arg acc) f + | _, _ -> invalid_arg "fold_module_fields" + in + let occupied_names = + Ext_list.fold_left groups Set_string.empty (fun occupied group -> + match group with + | Single (_, id, _) -> + Set_string.add occupied (Ext_ident.convert id.Ident.name) + | Recursive bindings -> + Ext_list.fold_left bindings occupied (fun occupied (id, _) -> + Set_string.add occupied (Ext_ident.convert id.Ident.name)) + | Nop _ -> occupied) + in + let rec scan top_id path ((aliases, occupied_names) as state) lam = + match resolve lam with + | Lam.Lprim + { + primitive = Lam_primitive.Pmakeblock (_, Blk_module fields, _); + args; + loc; + } -> + fold_module_fields fields args 0 state (fun pos field arg state -> + let path = path @ [(pos, field)] in + let aliases, occupied_names = scan top_id path state arg in + match arg with + | Lam.Lvar id when Ident.js_hoisted id -> + let segments = + top_id.Ident.name + :: Ext_list.map path (fun (_pos, name) -> name) + in + let name = + segments + |> List.map Ext_ident.unwrap_uppercase_exotic + |> String.concat "$" + in + let js_name = Ext_ident.convert name in + if Set_string.mem occupied_names js_name then + let loc = + match resolve arg with + | Lam.Lfunction {loc} -> loc + | _ -> loc + in + Location.raise_errorf ~loc + "Cannot hoist this function as `%s` because that name is \ + already used by a top-level binding." + name + else + let alias_id = Ident.create name in + let alias = access loc (Lam.var top_id) path in + ( ( Lam_group.Single (Alias, alias_id, alias), + alias_id, + alias, + segments, + name ) + :: aliases, + Set_string.add occupied_names js_name ) + | _ -> (aliases, occupied_names)) + | _ -> state + in + fst + (Ext_list.fold_left groups ([], occupied_names) (fun state group -> + match group with + | Single (_, id, lam) when Set_ident.mem export_idents id -> + scan id [] state lam + | Single _ | Recursive _ | Nop _ -> state)) + (** Actually simplify_lets is kind of global optimization since it requires you to know whether it's used or not *) @@ -203,6 +316,34 @@ let compile (output_prefix : string) export_idents (lam : Lambda.lambda) = Ir_diagnostics.dump_groups diagnostics coerced_input.groups)) in let maybe_pure = no_side_effects groups in + (* Add the generated alias groups before JS lowering so regular export + printing, tree shaking, and .cmj metadata all see the flat runtime value. *) + let hoisted_aliases = js_hoisted_aliases meta.export_idents groups in + let hoisted_groups, hoisted_exports, hoisted_export_map, hoisted_metadata = + Ext_list.fold_left hoisted_aliases ([], [], Map_ident.empty, []) + (fun + (groups, exports, export_map, hoisted_metadata) + (group, id, lam, path, name) + -> + ( group :: groups, + id :: exports, + Map_ident.add export_map id lam, + {Js_cmj_format.path; name} :: hoisted_metadata )) + in + let groups = groups @ List.rev hoisted_groups in + let meta = + { + meta with + exports = meta.exports @ List.rev hoisted_exports; + export_idents = + Ext_list.fold_left hoisted_exports meta.export_idents (fun acc id -> + Set_ident.add acc id); + } + in + let export_map = + Map_ident.fold hoisted_export_map coerced_input.export_map + (fun id lam acc -> Map_ident.add acc id lam) + in let () = if debug_ir then Ext_log.dwarn ~__POS__ "\n@[[TIME:]Pre-compile: %f@]@." @@ -250,7 +391,7 @@ let compile (output_prefix : string) export_idents (lam : Lambda.lambda) = Lam_stats_export.get_dependent_module_effect maybe_pure external_module_ids in let v : Js_cmj_format.t = - Lam_stats_export.export_to_cmj meta effect_ coerced_input.export_map + Lam_stats_export.export_to_cmj meta effect_ export_map hoisted_metadata (if Ext_char.is_lower_case (Filename.basename output_prefix).[0] then Little else Upper) diff --git a/compiler/core/lam_stats_export.ml b/compiler/core/lam_stats_export.ml index 711ab5be42f..c84f3874e31 100644 --- a/compiler/core/lam_stats_export.ml +++ b/compiler/core/lam_stats_export.ml @@ -128,11 +128,11 @@ let get_dependent_module_effect (maybe_pure : string option) ]} TODO: check that we don't do this in browser environment *) -let export_to_cmj (meta : Lam_stats.t) effect_ export_map case : Js_cmj_format.t - = +let export_to_cmj (meta : Lam_stats.t) effect_ export_map hoisted_exports case : + Js_cmj_format.t = let values = values_of_export meta export_map in - Js_cmj_format.make ~values ~effect_ + Js_cmj_format.make ~values ~hoisted_exports ~effect_ ~package_spec:(Js_packages_state.get_packages_info ()) ~case (* FIXME: make sure [-o] would not change its case diff --git a/compiler/core/lam_stats_export.mli b/compiler/core/lam_stats_export.mli index 593ff0a1b98..9d8e814581f 100644 --- a/compiler/core/lam_stats_export.mli +++ b/compiler/core/lam_stats_export.mli @@ -29,5 +29,6 @@ val export_to_cmj : Lam_stats.t -> Js_cmj_format.effect_ -> Lam.t Map_ident.t -> + Js_cmj_format.hoisted_export list -> Ext_js_file_kind.case -> Js_cmj_format.t diff --git a/compiler/ext/ident.ml b/compiler/ext/ident.ml index a5ca80e840f..0a53e314d31 100644 --- a/compiler/ext/ident.ml +++ b/compiler/ext/ident.ml @@ -20,6 +20,7 @@ type t = {stamp: int; name: string; mutable flags: int} let[@inlnie] max (x : int) y = if x >= y then x else y let global_flag = 1 let predef_exn_flag = 2 +let js_hoisted_flag = 4 (* A stamp of 0 denotes a persistent identifier *) @@ -71,6 +72,10 @@ let global i = i.flags land global_flag <> 0 let is_predef_exn i = i.flags land predef_exn_flag <> 0 +let make_js_hoisted i = i.flags <- i.flags lor js_hoisted_flag + +let js_hoisted i = i.flags land js_hoisted_flag <> 0 + let print ppf i = match i.stamp with | 0 -> fprintf ppf "%s!" i.name diff --git a/compiler/ext/ident.mli b/compiler/ext/ident.mli index d73cff6f6eb..6771e538a10 100644 --- a/compiler/ext/ident.mli +++ b/compiler/ext/ident.mli @@ -49,6 +49,8 @@ val hide : t -> t val make_global : t -> unit val global : t -> bool val is_predef_exn : t -> bool +val make_js_hoisted : t -> unit +val js_hoisted : t -> bool val binding_time : t -> int val current_time : unit -> int diff --git a/compiler/ml/translattribute.ml b/compiler/ml/translattribute.ml index 7c9c9a7a0a0..91314cfdcf3 100644 --- a/compiler/ml/translattribute.ml +++ b/compiler/ml/translattribute.ml @@ -37,6 +37,21 @@ let find_attribute p (attributes : t list) = in (attr, other_attributes) +let get_empty_attribute name attributes = + let attr, _ = + find_attribute + (fun (({txt}, _) : Parsetree.attribute) -> txt = name) + attributes + in + match attr with + | None -> None + | Some ({loc}, Parsetree.PStr []) -> Some loc + | Some ({loc}, _) -> + Location.prerr_warning loc + (Warnings.Attribute_payload + (name, "This attribute does not accept a payload")); + None + let parse_inline_attribute (attr : t option) : Lambda.inline_attribute = match attr with | None -> Default_inline diff --git a/compiler/ml/translattribute.mli b/compiler/ml/translattribute.mli index 03115eb0eee..bac456ba8d8 100644 --- a/compiler/ml/translattribute.mli +++ b/compiler/ml/translattribute.mli @@ -23,6 +23,8 @@ val add_inline_attribute : val get_inline_attribute : Parsetree.attributes -> Lambda.inline_attribute +val get_empty_attribute : string -> Parsetree.attributes -> Location.t option + val get_and_remove_inlined_attribute : Typedtree.expression -> Lambda.inline_attribute * Typedtree.expression diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 6a55f5d0264..9c148ea388a 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -598,6 +598,32 @@ let extract_directive_for_fn exp = if txt = "directive" then Ast_payload.is_single_string payload else None) +let hoisted_function_attr_name = "res.hoistedFunction" + +let find_js_hoisted_attr attrs = + Translattribute.get_empty_attribute hoisted_function_attr_name attrs + +(* A value binding's source attributes are not carried all the way to JS + emission. When a function has @res.hoistedFunction, mark the bound variable + itself so later compiler stages can add the flat JS export and write the + matching .cmj metadata. *) +let mark_js_hoisted_pattern ~allow_js_hoist attrs pat lam = + match find_js_hoisted_attr attrs with + | None -> () + | Some loc -> ( + match lam with + | Lfunction _ -> ( + match pat.pat_desc with + | Tpat_var (id, _) | Tpat_alias ({pat_desc = Tpat_any}, id, _) -> + if allow_js_hoist then Ident.make_js_hoisted id + else + Location.prerr_warning loc + (Warnings.Misplaced_attribute hoisted_function_attr_name) + | _ -> ()) + | _ -> + Location.prerr_warning loc + (Warnings.Misplaced_attribute hoisted_function_attr_name)) + let rec transl_exp e = Builtin_attributes.warning_scope ~ppwarning:false e.exp_attributes (fun () -> List.iter (Translattribute.check_attribute e) e.exp_attributes; @@ -611,7 +637,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = transl_value_path ~loc:e.exp_loc e.exp_env path | Texp_constant cst -> Lconst (Const_base cst) | Texp_let (rec_flag, pat_expr_list, body) -> - transl_let rec_flag pat_expr_list (transl_exp body) + transl_let ~allow_js_hoist:false rec_flag pat_expr_list (transl_exp body) | Texp_function {params = fparams; body; async} -> let directive = match extract_directive_for_fn e with @@ -1019,7 +1045,7 @@ and transl_function loc (params : function_param list) body = fp_partial, return_unit ) -and transl_let rec_flag pat_expr_list body = +and transl_let ~allow_js_hoist rec_flag pat_expr_list body = match rec_flag with | Nonrecursive -> let rec transl = function @@ -1030,6 +1056,7 @@ and transl_let rec_flag pat_expr_list body = transl_exp expr) in let lam = Translattribute.add_inline_attribute lam vb_loc attr in + mark_js_hoisted_pattern ~allow_js_hoist attr pat lam; Matching.for_let pat.pat_loc lam pat (transl rem) in transl pat_expr_list @@ -1049,6 +1076,7 @@ and transl_let rec_flag pat_expr_list body = (fun () -> transl_exp expr) in let lam = Translattribute.add_inline_attribute lam vb_loc vb_attributes in + mark_js_hoisted_pattern ~allow_js_hoist vb_attributes pat lam; (id, lam) in Lletrec (Ext_list.map pat_expr_list transl_case, body) diff --git a/compiler/ml/translcore.mli b/compiler/ml/translcore.mli index 1847a4883c4..ef2a8e3e9ef 100644 --- a/compiler/ml/translcore.mli +++ b/compiler/ml/translcore.mli @@ -19,6 +19,7 @@ val transl_exp : Typedtree.expression -> Lambda.lambda val transl_let : + allow_js_hoist:bool -> Asttypes.rec_flag -> Typedtree.value_binding list -> Lambda.lambda -> diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index aaf83129678..5a1bf91305e 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -32,6 +32,13 @@ let is_top (rootpath : Path.t option) = | Some (Pident _) -> true | _ -> false +let has_exportable_module_path = function + | Some path -> ( + match Path.flatten path with + | `Ok (_, _ :: _) -> true + | `Ok (_, []) | `Contains_apply -> false) + | None -> false + let functor_path path param : Path.t option = match path with | None -> None @@ -367,7 +374,10 @@ and transl_structure loc fields cc rootpath final_env = function | _ -> if not (Parmatch.irrefutable vb_pat) then raise (Error (vb_pat.pat_loc, Fragile_pattern_in_toplevel))); - (Translcore.transl_let rec_flag pat_expr_list body, size) + ( Translcore.transl_let + ~allow_js_hoist:(has_exportable_module_path rootpath) + rec_flag pat_expr_list body, + size ) | Tstr_typext tyext -> let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in let body, size = @@ -445,8 +455,19 @@ and transl_structure loc fields cc rootpath final_env = function transl_module Tcoerce_none None modl, body ), size ) - | Tstr_primitive _ | Tstr_type _ | Tstr_modtype _ | Tstr_open _ - | Tstr_attribute _ -> + | Tstr_primitive {val_attributes} -> + (* Externals do not introduce a Lambda function binding that can be + hoisted, so surface the attribute as misplaced here. *) + (match + Translattribute.get_empty_attribute "res.hoistedFunction" + val_attributes + with + | Some loc -> + Location.prerr_warning loc + (Warnings.Misplaced_attribute "res.hoistedFunction") + | None -> ()); + transl_structure loc fields cc rootpath final_env rem + | Tstr_type _ | Tstr_modtype _ | Tstr_open _ | Tstr_attribute _ -> transl_structure loc fields cc rootpath final_env rem) (* Update forward declaration in Translcore *) diff --git a/tests/build_tests/super_errors/expected/hoisted_function_export_collision.res.expected b/tests/build_tests/super_errors/expected/hoisted_function_export_collision.res.expected new file mode 100644 index 00000000000..a8c130e227f --- /dev/null +++ b/tests/build_tests/super_errors/expected/hoisted_function_export_collision.res.expected @@ -0,0 +1,11 @@ + + We've found a bug for you! + /.../fixtures/hoisted_function_export_collision.res:3:14-21 + + 1 │ module One = { + 2 │ @res.hoistedFunction + 3 │ let make = () => () + 4 │ } + 5 │ let \"One$make" = () => () + + Cannot hoist this function as `One$make` because that name is already used by a top-level binding. diff --git a/tests/build_tests/super_errors/expected/hoisted_function_invalid_payload.res.expected b/tests/build_tests/super_errors/expected/hoisted_function_invalid_payload.res.expected new file mode 100644 index 00000000000..ae6bd4b594a --- /dev/null +++ b/tests/build_tests/super_errors/expected/hoisted_function_invalid_payload.res.expected @@ -0,0 +1,11 @@ + + Warning number 47 + /.../fixtures/hoisted_function_invalid_payload.res:2:3-22 + + 1 │ module Nested = { + 2 │ @res.hoistedFunction("name") + 3 │ let make = () => () + 4 │ } + + illegal payload for attribute @res.hoistedFunction. +This attribute does not accept a payload \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/hoisted_function_not_exportable.res.expected b/tests/build_tests/super_errors/expected/hoisted_function_not_exportable.res.expected new file mode 100644 index 00000000000..b2ec9cea4cd --- /dev/null +++ b/tests/build_tests/super_errors/expected/hoisted_function_not_exportable.res.expected @@ -0,0 +1,34 @@ + + Warning number 53 + /.../fixtures/hoisted_function_not_exportable.res:15:3-22 + + 13 │ } + 14 │ module Make = () => { + 15 │ @res.hoistedFunction + 16 │ let make = () => () + 17 │ } + + the @res.hoistedFunction attribute cannot appear in this context + + + Warning number 53 + /.../fixtures/hoisted_function_not_exportable.res:9:5-24 + + 7 │ let localModule = () => { + 8 │ module Local = { + 9 │ @res.hoistedFunction + 10 │ let make = () => () + 11 │ } + + the @res.hoistedFunction attribute cannot appear in this context + + + Warning number 53 + /.../fixtures/hoisted_function_not_exportable.res:2:3-22 + + 1 │ let run = () => { + 2 │ @res.hoistedFunction + 3 │ let local = () => () + 4 │ local() + + the @res.hoistedFunction attribute cannot appear in this context \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/hoisted_function_path_collision.res.expected b/tests/build_tests/super_errors/expected/hoisted_function_path_collision.res.expected new file mode 100644 index 00000000000..3f049f96977 --- /dev/null +++ b/tests/build_tests/super_errors/expected/hoisted_function_path_collision.res.expected @@ -0,0 +1,11 @@ + + We've found a bug for you! + /.../fixtures/hoisted_function_path_collision.res:7:19-26 + + 5 │ } + 6 │ @res.hoistedFunction + 7 │ let \"B$make" = () => () + 8 │ } + 9 │ let after = () + + Cannot hoist this function as `A$B$make` because that name is already used by a top-level binding. diff --git a/tests/build_tests/super_errors/fixtures/hoisted_function_export_collision.res b/tests/build_tests/super_errors/fixtures/hoisted_function_export_collision.res new file mode 100644 index 00000000000..ac642bfe4e5 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/hoisted_function_export_collision.res @@ -0,0 +1,5 @@ +module One = { + @res.hoistedFunction + let make = () => () +} +let \"One$make" = () => () diff --git a/tests/build_tests/super_errors/fixtures/hoisted_function_invalid_payload.res b/tests/build_tests/super_errors/fixtures/hoisted_function_invalid_payload.res new file mode 100644 index 00000000000..3f4a9a6b25e --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/hoisted_function_invalid_payload.res @@ -0,0 +1,4 @@ +module Nested = { + @res.hoistedFunction("name") + let make = () => () +} diff --git a/tests/build_tests/super_errors/fixtures/hoisted_function_not_exportable.res b/tests/build_tests/super_errors/fixtures/hoisted_function_not_exportable.res new file mode 100644 index 00000000000..39c0609f6d9 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/hoisted_function_not_exportable.res @@ -0,0 +1,17 @@ +let run = () => { + @res.hoistedFunction + let local = () => () + local() +} + +let localModule = () => { + module Local = { + @res.hoistedFunction + let make = () => () + } + Local.make() +} +module Make = () => { + @res.hoistedFunction + let make = () => () +} diff --git a/tests/build_tests/super_errors/fixtures/hoisted_function_path_collision.res b/tests/build_tests/super_errors/fixtures/hoisted_function_path_collision.res new file mode 100644 index 00000000000..c74d5feb43f --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/hoisted_function_path_collision.res @@ -0,0 +1,9 @@ +module A = { + module B = { + @res.hoistedFunction + let make = () => () + } + @res.hoistedFunction + let \"B$make" = () => () +} +let after = () diff --git a/tests/tests/src/hoisted_function_attr.mjs b/tests/tests/src/hoisted_function_attr.mjs new file mode 100644 index 00000000000..8428fe698f2 --- /dev/null +++ b/tests/tests/src/hoisted_function_attr.mjs @@ -0,0 +1,165 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + + +function make() { + return "one"; +} + +function keep() { + return "one-keep"; +} + +let One = { + make: make, + keep: keep +}; + +function keep$1() { + return "two-keep"; +} + +function make$1() { + return "two"; +} + +function keep$2() { + return "two-inner-keep"; +} + +let Inner = { + make: make$1, + keep: keep$2 +}; + +let Two = { + keep: keep$1, + Inner: Inner +}; + +function keep$3() { + return "three-inner-keep"; +} + +function make$2() { + return "three"; +} + +function keep$4() { + return "three-deep-keep"; +} + +let Deep = { + make: make$2, + keep: keep$4 +}; + +let Inner$1 = { + keep: keep$3, + Deep: Deep +}; + +let Three = { + Inner: Inner$1 +}; + +function $$switch() { + return "keyword"; +} + +function $plus() { + return "dollar"; +} + +let Escaped = { + $$switch: $$switch, + $plus: $plus +}; + +function $plus$1() { + return "operator"; +} + +let Operator = { + $plus: $plus$1 +}; + +function make$3() { + return "nested"; +} + +let B = { + make: make$3 +}; + +function B$make() { + return "exotic"; +} + +let Ambiguous = { + B: B, + B$make: B$make +}; + +function value() { + return "recursive"; +} + +let RecursiveB = { + value: value +}; + +function make$4() { + return RecursiveB.value(); +} + +let RecursiveA = { + make: make$4 +}; + +function make$5() { + return "typed"; +} + +let Typed = { + make: make$5 +}; + +let Typed$make = Typed.make; + +let RecursiveA$make = RecursiveA.make; + +let Ambiguous$B$make = B.make; + +let Operator$$plus = Operator.$plus; + +let Escaped$$plus = $plus; + +let Escaped$switch = $$switch; + +let Three$Inner$Deep$make = Three.Inner.Deep.make; + +let Two$Inner$make = Inner.make; + +let One$make = make; + +export { + One, + Two, + Three, + Escaped, + Operator, + Ambiguous, + RecursiveA, + RecursiveB, + Typed, + Typed$make, + RecursiveA$make, + Ambiguous$B$make, + Operator$$plus, + Escaped$$plus, + Escaped$switch, + Three$Inner$Deep$make, + Two$Inner$make, + One$make, +} +/* No side effect */ diff --git a/tests/tests/src/hoisted_function_attr.res b/tests/tests/src/hoisted_function_attr.res new file mode 100644 index 00000000000..912a9609e97 --- /dev/null +++ b/tests/tests/src/hoisted_function_attr.res @@ -0,0 +1,69 @@ +module One = { + @res.hoistedFunction + let make = () => "one" + + let keep = () => "one-keep" +} + +module Two = { + let keep = () => "two-keep" + + module Inner = { + @res.hoistedFunction + let make = () => "two" + + let keep = () => "two-inner-keep" + } +} + +module Three = { + module Inner = { + let keep = () => "three-inner-keep" + + module Deep = { + @res.hoistedFunction + let make = () => "three" + + let keep = () => "three-deep-keep" + } + } +} + +module Escaped = { + @res.hoistedFunction + let \"switch" = () => "keyword" + + @res.hoistedFunction + let \"$plus" = () => "dollar" +} + +module Operator = { + @res.hoistedFunction + let \"+" = () => "operator" +} + +module Ambiguous = { + module B = { + @res.hoistedFunction + let make = () => "nested" + } + + let \"B$make" = () => "exotic" +} + +module rec RecursiveA: { + let make: unit => string +} = { + @res.hoistedFunction + let make = () => RecursiveB.value() +} +and RecursiveB: { + let value: unit => string +} = { + let value = () => "recursive" +} + +module Typed = { + @res.hoistedFunction + let make: unit => string = () => "typed" +} diff --git a/tests/tests/src/hoisted_function_attr_test.mjs b/tests/tests/src/hoisted_function_attr_test.mjs new file mode 100644 index 00000000000..c3621d2fd0e --- /dev/null +++ b/tests/tests/src/hoisted_function_attr_test.mjs @@ -0,0 +1,26 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Mocha from "mocha"; +import * as Test_utils from "./test_utils.mjs"; +import * as Hoisted_function_attr_use from "./hoisted_function_attr_use.mjs"; + +Mocha.describe("Hoisted_function_attr_test", () => { + Mocha.test("flat cross-module exports", () => { + Test_utils.eq("File \"hoisted_function_attr_test.res\", line 6, characters 7-14", Hoisted_function_attr_use.one, "one"); + Test_utils.eq("File \"hoisted_function_attr_test.res\", line 7, characters 7-14", Hoisted_function_attr_use.two, "two"); + Test_utils.eq("File \"hoisted_function_attr_test.res\", line 8, characters 7-14", Hoisted_function_attr_use.three, "three"); + }); + Mocha.test("exotic identifiers", () => { + Test_utils.eq("File \"hoisted_function_attr_test.res\", line 12, characters 7-14", Hoisted_function_attr_use.keyword, "keyword"); + Test_utils.eq("File \"hoisted_function_attr_test.res\", line 13, characters 7-14", Hoisted_function_attr_use.dollar, "dollar"); + Test_utils.eq("File \"hoisted_function_attr_test.res\", line 14, characters 7-14", Hoisted_function_attr_use.operator, "operator"); + }); + Mocha.test("structurally distinct paths", () => { + Test_utils.eq("File \"hoisted_function_attr_test.res\", line 18, characters 7-14", Hoisted_function_attr_use.nested, "nested"); + Test_utils.eq("File \"hoisted_function_attr_test.res\", line 19, characters 7-14", Hoisted_function_attr_use.exoticPath, "exotic"); + }); + Mocha.test("recursive modules", () => Test_utils.eq("File \"hoisted_function_attr_test.res\", line 23, characters 7-14", Hoisted_function_attr_use.recursive, "recursive")); + Mocha.test("explicit function type annotations", () => Test_utils.eq("File \"hoisted_function_attr_test.res\", line 27, characters 7-14", Hoisted_function_attr_use.typed, "typed")); +}); + +/* Not a pure module */ diff --git a/tests/tests/src/hoisted_function_attr_test.res b/tests/tests/src/hoisted_function_attr_test.res new file mode 100644 index 00000000000..314046330e1 --- /dev/null +++ b/tests/tests/src/hoisted_function_attr_test.res @@ -0,0 +1,29 @@ +open Mocha +open Test_utils + +describe(__MODULE__, () => { + test("flat cross-module exports", () => { + eq(__LOC__, Hoisted_function_attr_use.one, "one") + eq(__LOC__, Hoisted_function_attr_use.two, "two") + eq(__LOC__, Hoisted_function_attr_use.three, "three") + }) + + test("exotic identifiers", () => { + eq(__LOC__, Hoisted_function_attr_use.keyword, "keyword") + eq(__LOC__, Hoisted_function_attr_use.dollar, "dollar") + eq(__LOC__, Hoisted_function_attr_use.operator, "operator") + }) + + test("structurally distinct paths", () => { + eq(__LOC__, Hoisted_function_attr_use.nested, "nested") + eq(__LOC__, Hoisted_function_attr_use.exoticPath, "exotic") + }) + + test("recursive modules", () => { + eq(__LOC__, Hoisted_function_attr_use.recursive, "recursive") + }) + + test("explicit function type annotations", () => { + eq(__LOC__, Hoisted_function_attr_use.typed, "typed") + }) +}) diff --git a/tests/tests/src/hoisted_function_attr_use.mjs b/tests/tests/src/hoisted_function_attr_use.mjs new file mode 100644 index 00000000000..6cb0a0b5fe1 --- /dev/null +++ b/tests/tests/src/hoisted_function_attr_use.mjs @@ -0,0 +1,46 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Hoisted_function_attr from "./hoisted_function_attr.mjs"; + +let one = Hoisted_function_attr.One$make(); + +let oneKeep = Hoisted_function_attr.One.keep(); + +let two = Hoisted_function_attr.Two$Inner$make(); + +let twoKeep = Hoisted_function_attr.Two.Inner.keep(); + +let three = Hoisted_function_attr.Three$Inner$Deep$make(); + +let threeKeep = Hoisted_function_attr.Three.Inner.Deep.keep(); + +let keyword = Hoisted_function_attr.Escaped$switch(); + +let dollar = Hoisted_function_attr.Escaped$$plus(); + +let operator = Hoisted_function_attr.Operator$$plus(); + +let nested = Hoisted_function_attr.Ambiguous$B$make(); + +let exoticPath = Hoisted_function_attr.Ambiguous.B$make(); + +let recursive = Hoisted_function_attr.RecursiveA$make(); + +let typed = Hoisted_function_attr.Typed$make(); + +export { + one, + oneKeep, + two, + twoKeep, + three, + threeKeep, + keyword, + dollar, + operator, + nested, + exoticPath, + recursive, + typed, +} +/* one Not a pure module */ diff --git a/tests/tests/src/hoisted_function_attr_use.res b/tests/tests/src/hoisted_function_attr_use.res new file mode 100644 index 00000000000..6529d0160cf --- /dev/null +++ b/tests/tests/src/hoisted_function_attr_use.res @@ -0,0 +1,17 @@ +let one = Hoisted_function_attr.One.make() +let oneKeep = Hoisted_function_attr.One.keep() + +let two = Hoisted_function_attr.Two.Inner.make() +let twoKeep = Hoisted_function_attr.Two.Inner.keep() + +let three = Hoisted_function_attr.Three.Inner.Deep.make() +let threeKeep = Hoisted_function_attr.Three.Inner.Deep.keep() + +let keyword = Hoisted_function_attr.Escaped.\"switch"() +let dollar = Hoisted_function_attr.Escaped.\"$plus"() +let operator = Hoisted_function_attr.Operator.\"+"() + +let nested = Hoisted_function_attr.Ambiguous.B.make() +let exoticPath = Hoisted_function_attr.Ambiguous.\"B$make"() +let recursive = Hoisted_function_attr.RecursiveA.make() +let typed = Hoisted_function_attr.Typed.make() From a433fe210c0cd68646214f1592b1bec72b525e29 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 22 Aug 2026 17:14:28 +0200 Subject: [PATCH 02/12] Diagnose unsupported hoisted function patterns Signed-off-by: Christoph Knittel --- compiler/ml/translcore.ml | 4 +++- .../hoisted_function_unsupported_pattern.res.expected | 10 ++++++++++ .../fixtures/hoisted_function_unsupported_pattern.res | 4 ++++ 3 files changed, 17 insertions(+), 1 deletion(-) create mode 100644 tests/build_tests/super_errors/expected/hoisted_function_unsupported_pattern.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/hoisted_function_unsupported_pattern.res diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 9c148ea388a..426403da5fc 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -619,7 +619,9 @@ let mark_js_hoisted_pattern ~allow_js_hoist attrs pat lam = else Location.prerr_warning loc (Warnings.Misplaced_attribute hoisted_function_attr_name) - | _ -> ()) + | _ -> + Location.prerr_warning loc + (Warnings.Misplaced_attribute hoisted_function_attr_name)) | _ -> Location.prerr_warning loc (Warnings.Misplaced_attribute hoisted_function_attr_name)) diff --git a/tests/build_tests/super_errors/expected/hoisted_function_unsupported_pattern.res.expected b/tests/build_tests/super_errors/expected/hoisted_function_unsupported_pattern.res.expected new file mode 100644 index 00000000000..a2e9b9970ea --- /dev/null +++ b/tests/build_tests/super_errors/expected/hoisted_function_unsupported_pattern.res.expected @@ -0,0 +1,10 @@ + + Warning number 53 + /.../fixtures/hoisted_function_unsupported_pattern.res:2:3-22 + + 1 │ module Nested = { + 2 │ @res.hoistedFunction + 3 │ let f as g = () => "ok" + 4 │ } + + the @res.hoistedFunction attribute cannot appear in this context \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/hoisted_function_unsupported_pattern.res b/tests/build_tests/super_errors/fixtures/hoisted_function_unsupported_pattern.res new file mode 100644 index 00000000000..258b059e263 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/hoisted_function_unsupported_pattern.res @@ -0,0 +1,4 @@ +module Nested = { + @res.hoistedFunction + let f as g = () => "ok" +} From ea708706b99d4bbe2a743649ff438005ebb26692 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 22 Aug 2026 20:37:12 +0200 Subject: [PATCH 03/12] Diagnose hoists hidden by signatures Signed-off-by: Christoph Knittel --- compiler/ext/ident.ml | 2 + compiler/ext/ident.mli | 1 + compiler/ml/translcore.ml | 21 +++--- compiler/ml/translcore.mli | 2 +- compiler/ml/translmod.ml | 72 +++++++++++++++++-- ..._function_hidden_by_signature.res.expected | 11 +++ .../hoisted_function_hidden_by_signature.res | 7 ++ 7 files changed, 100 insertions(+), 16 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/hoisted_function_hidden_by_signature.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/hoisted_function_hidden_by_signature.res diff --git a/compiler/ext/ident.ml b/compiler/ext/ident.ml index 0a53e314d31..3f31f010c5e 100644 --- a/compiler/ext/ident.ml +++ b/compiler/ext/ident.ml @@ -74,6 +74,8 @@ let is_predef_exn i = i.flags land predef_exn_flag <> 0 let make_js_hoisted i = i.flags <- i.flags lor js_hoisted_flag +let clear_js_hoisted i = i.flags <- i.flags land lnot js_hoisted_flag + let js_hoisted i = i.flags land js_hoisted_flag <> 0 let print ppf i = diff --git a/compiler/ext/ident.mli b/compiler/ext/ident.mli index 6771e538a10..e29622f8789 100644 --- a/compiler/ext/ident.mli +++ b/compiler/ext/ident.mli @@ -50,6 +50,7 @@ val make_global : t -> unit val global : t -> bool val is_predef_exn : t -> bool val make_js_hoisted : t -> unit +val clear_js_hoisted : t -> unit val js_hoisted : t -> bool val binding_time : t -> int diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 426403da5fc..86a94649e40 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -607,18 +607,21 @@ let find_js_hoisted_attr attrs = emission. When a function has @res.hoistedFunction, mark the bound variable itself so later compiler stages can add the flat JS export and write the matching .cmj metadata. *) -let mark_js_hoisted_pattern ~allow_js_hoist attrs pat lam = +let mark_js_hoisted_pattern ~js_hoist attrs pat lam = match find_js_hoisted_attr attrs with | None -> () | Some loc -> ( match lam with | Lfunction _ -> ( match pat.pat_desc with - | Tpat_var (id, _) | Tpat_alias ({pat_desc = Tpat_any}, id, _) -> - if allow_js_hoist then Ident.make_js_hoisted id - else + | Tpat_var (id, _) | Tpat_alias ({pat_desc = Tpat_any}, id, _) -> ( + match js_hoist with + | Some register -> + Ident.make_js_hoisted id; + register id loc + | None -> Location.prerr_warning loc - (Warnings.Misplaced_attribute hoisted_function_attr_name) + (Warnings.Misplaced_attribute hoisted_function_attr_name)) | _ -> Location.prerr_warning loc (Warnings.Misplaced_attribute hoisted_function_attr_name)) @@ -639,7 +642,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = transl_value_path ~loc:e.exp_loc e.exp_env path | Texp_constant cst -> Lconst (Const_base cst) | Texp_let (rec_flag, pat_expr_list, body) -> - transl_let ~allow_js_hoist:false rec_flag pat_expr_list (transl_exp body) + transl_let ~js_hoist:None rec_flag pat_expr_list (transl_exp body) | Texp_function {params = fparams; body; async} -> let directive = match extract_directive_for_fn e with @@ -1047,7 +1050,7 @@ and transl_function loc (params : function_param list) body = fp_partial, return_unit ) -and transl_let ~allow_js_hoist rec_flag pat_expr_list body = +and transl_let ~js_hoist rec_flag pat_expr_list body = match rec_flag with | Nonrecursive -> let rec transl = function @@ -1058,7 +1061,7 @@ and transl_let ~allow_js_hoist rec_flag pat_expr_list body = transl_exp expr) in let lam = Translattribute.add_inline_attribute lam vb_loc attr in - mark_js_hoisted_pattern ~allow_js_hoist attr pat lam; + mark_js_hoisted_pattern ~js_hoist attr pat lam; Matching.for_let pat.pat_loc lam pat (transl rem) in transl pat_expr_list @@ -1078,7 +1081,7 @@ and transl_let ~allow_js_hoist rec_flag pat_expr_list body = (fun () -> transl_exp expr) in let lam = Translattribute.add_inline_attribute lam vb_loc vb_attributes in - mark_js_hoisted_pattern ~allow_js_hoist vb_attributes pat lam; + mark_js_hoisted_pattern ~js_hoist vb_attributes pat lam; (id, lam) in Lletrec (Ext_list.map pat_expr_list transl_case, body) diff --git a/compiler/ml/translcore.mli b/compiler/ml/translcore.mli index ef2a8e3e9ef..f3d90ee02a4 100644 --- a/compiler/ml/translcore.mli +++ b/compiler/ml/translcore.mli @@ -19,7 +19,7 @@ val transl_exp : Typedtree.expression -> Lambda.lambda val transl_let : - allow_js_hoist:bool -> + js_hoist:(Ident.t -> Location.t -> unit) option -> Asttypes.rec_flag -> Typedtree.value_binding list -> Lambda.lambda -> diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index 5a1bf91305e..b8a4701d085 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -32,12 +32,17 @@ let is_top (rootpath : Path.t option) = | Some (Pident _) -> true | _ -> false -let has_exportable_module_path = function +let module_path = function | Some path -> ( match Path.flatten path with - | `Ok (_, _ :: _) -> true - | `Ok (_, []) | `Contains_apply -> false) - | None -> false + | `Ok (_, segments) -> Some segments + | `Contains_apply -> None) + | None -> None + +let exportable_module_path rootpath = + match module_path rootpath with + | Some (_ :: _ as path) -> Some path + | _ -> None let functor_path path param : Path.t option = match path with @@ -229,6 +234,55 @@ let get_functor_params mexp coercion root_path = | _ -> assert false let export_identifiers : Ident.t list ref = ref [] +let js_hoisted : (Ident.t * string list * Location.t) list ref = ref [] + +let js_hoist_handler rootpath = + match exportable_module_path rootpath with + | None -> None + | Some path -> + Some + (fun id loc -> + js_hoisted := (id, path @ [id.Ident.name], loc) :: !js_hoisted) + +let rec remove_prefix prefix path = + match (prefix, path) with + | [], path -> Some path + | prefix :: prefixes, segment :: segments when prefix = segment -> + remove_prefix prefixes segments + | _ -> None + +let rec exported_by_coercion path coercion = + match path with + | [] -> true + | segment :: rest -> ( + match coercion with + | Tcoerce_none -> true + | Tcoerce_structure (fields, _, names) -> + let rec find fields names = + match (fields, names) with + | (_, coercion) :: fields, name :: names -> + if name = segment then exported_by_coercion rest coercion + else find fields names + | [], [] -> false + | _ -> assert false + in + find fields names + | Tcoerce_functor _ | Tcoerce_primitive _ | Tcoerce_alias _ -> false) + +let validate_js_hoisted prefix coercion = + match coercion with + | Tcoerce_none -> () + | _ -> + List.iter + (fun (id, path, loc) -> + if Ident.js_hoisted id then + match remove_prefix prefix path with + | Some path when not (exported_by_coercion path coercion) -> + Ident.clear_js_hoisted id; + Location.prerr_warning loc + (Warnings.Misplaced_attribute "res.hoistedFunction") + | Some _ | None -> ()) + !js_hoisted let rec compile_functor mexp coercion root_path loc = let functor_param, body, body_path, res_coercion, inline_attribute = @@ -270,7 +324,11 @@ and transl_module cc rootpath mexp = | Tmod_ident (path, _) -> apply_coercion loc Strict cc (Lambda.transl_module_path ~loc mexp.mod_env path) - | Tmod_structure str -> fst (transl_struct loc [] cc rootpath str) + | Tmod_structure str -> + let lam = fst (transl_struct loc [] cc rootpath str) in + Ext_option.iter (module_path rootpath) (fun path -> + validate_js_hoisted path cc); + lam | Tmod_functor _ -> compile_functor mexp cc rootpath loc | Tmod_apply (funct, arg, ccarg) -> let inlined_attribute, funct = @@ -375,7 +433,7 @@ and transl_structure loc fields cc rootpath final_env = function if not (Parmatch.irrefutable vb_pat) then raise (Error (vb_pat.pat_loc, Fragile_pattern_in_toplevel))); ( Translcore.transl_let - ~allow_js_hoist:(has_exportable_module_path rootpath) + ~js_hoist:(js_hoist_handler rootpath) rec_flag pat_expr_list body, size ) | Tstr_typext tyext -> @@ -479,8 +537,10 @@ let _ = Translcore.transl_module := transl_module let transl_implementation module_name (str, cc) = export_identifiers := []; + js_hoisted := []; let module_id = Ident.create_persistent module_name in let body, _ = transl_struct Location.none [] cc (global_path module_id) str in + validate_js_hoisted [] cc; (body, !export_identifiers) (* Build the list of value identifiers defined by a toplevel structure diff --git a/tests/build_tests/super_errors/expected/hoisted_function_hidden_by_signature.res.expected b/tests/build_tests/super_errors/expected/hoisted_function_hidden_by_signature.res.expected new file mode 100644 index 00000000000..bbba188005a --- /dev/null +++ b/tests/build_tests/super_errors/expected/hoisted_function_hidden_by_signature.res.expected @@ -0,0 +1,11 @@ + + Warning number 53 + /.../fixtures/hoisted_function_hidden_by_signature.res:4:3-22 + + 2 │ let visible: unit => string + 3 │ } = { + 4 │ @res.hoistedFunction + 5 │ let hidden = () => "hidden" + 6 │ let visible = hidden + + the @res.hoistedFunction attribute cannot appear in this context \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/hoisted_function_hidden_by_signature.res b/tests/build_tests/super_errors/fixtures/hoisted_function_hidden_by_signature.res new file mode 100644 index 00000000000..7b50cba0d12 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/hoisted_function_hidden_by_signature.res @@ -0,0 +1,7 @@ +module A: { + let visible: unit => string +} = { + @res.hoistedFunction + let hidden = () => "hidden" + let visible = hidden +} From cb7e60c88ecafb17f917c82e5b1f340d9eed3768 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 22 Aug 2026 21:03:59 +0200 Subject: [PATCH 04/12] Reject hoists inside private modules Signed-off-by: Christoph Knittel --- compiler/ml/translmod.ml | 22 +++++++++++++++---- ...isted_function_not_exportable.res.expected | 12 ++++++++++ .../hoisted_function_not_exportable.res | 6 +++++ 3 files changed, 36 insertions(+), 4 deletions(-) diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index b8a4701d085..351d63227f7 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -284,6 +284,18 @@ let validate_js_hoisted prefix coercion = | Some _ | None -> ()) !js_hoisted +let reject_js_hoisted prefix = + List.iter + (fun (id, path, loc) -> + if Ident.js_hoisted id then + match remove_prefix prefix path with + | Some _ -> + Ident.clear_js_hoisted id; + Location.prerr_warning loc + (Warnings.Misplaced_attribute "res.hoistedFunction") + | None -> ()) + !js_hoisted + let rec compile_functor mexp coercion root_path loc = let functor_param, body, body_path, res_coercion, inline_attribute = get_functor_params mexp coercion root_path @@ -459,14 +471,16 @@ and transl_structure loc fields cc rootpath final_env = function size ) | Tstr_module mb as s -> let id = mb.mb_id in + let hidden = Typemod.rescript_hide s in let body, size = transl_structure loc - (if Typemod.rescript_hide s then fields else id :: fields) + (if hidden then fields else id :: fields) cc rootpath final_env rem in - let module_body = - transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr - in + let module_rootpath = field_path rootpath id in + let module_body = transl_module Tcoerce_none module_rootpath mb.mb_expr in + if hidden then + Ext_option.iter (module_path module_rootpath) reject_js_hoisted; let module_body = Translattribute.add_inline_attribute module_body mb.mb_loc mb.mb_attributes diff --git a/tests/build_tests/super_errors/expected/hoisted_function_not_exportable.res.expected b/tests/build_tests/super_errors/expected/hoisted_function_not_exportable.res.expected index b2ec9cea4cd..a53c96a6218 100644 --- a/tests/build_tests/super_errors/expected/hoisted_function_not_exportable.res.expected +++ b/tests/build_tests/super_errors/expected/hoisted_function_not_exportable.res.expected @@ -1,4 +1,16 @@ + Warning number 53 + /.../fixtures/hoisted_function_not_exportable.res:19:3-22 + + 17 │ } + 18 │ %%private( + 19 │ @res.hoistedFunction + 20 │ let privateMake = () => () + 21 │ ) + + the @res.hoistedFunction attribute cannot appear in this context + + Warning number 53 /.../fixtures/hoisted_function_not_exportable.res:15:3-22 diff --git a/tests/build_tests/super_errors/fixtures/hoisted_function_not_exportable.res b/tests/build_tests/super_errors/fixtures/hoisted_function_not_exportable.res index 39c0609f6d9..cb1b64c48c9 100644 --- a/tests/build_tests/super_errors/fixtures/hoisted_function_not_exportable.res +++ b/tests/build_tests/super_errors/fixtures/hoisted_function_not_exportable.res @@ -15,3 +15,9 @@ module Make = () => { @res.hoistedFunction let make = () => () } +%%private( + @res.hoistedFunction + let privateMake = () => () +) + +let usePrivate = privateMake() From 24763f159ebe2388c0196861eb8940acb3f47be3 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 22 Aug 2026 22:07:16 +0200 Subject: [PATCH 05/12] Track hoisted functions by source path Signed-off-by: Christoph Knittel --- compiler/core/js_implementation.ml | 4 +- compiler/core/lam_compile_main.ml | 165 ++++++++++-------- compiler/core/lam_compile_main.mli | 7 +- compiler/ext/ident.ml | 7 - compiler/ext/ident.mli | 3 - compiler/jsoo/jsoo_playground_main.ml | 4 +- compiler/ml/translcore.ml | 4 +- compiler/ml/translmod.ml | 42 ++--- compiler/ml/translmod.mli | 2 +- tests/tests/src/hoisted_function_attr.mjs | 21 +++ tests/tests/src/hoisted_function_attr.res | 15 ++ .../tests/src/hoisted_function_attr_test.mjs | 5 + .../tests/src/hoisted_function_attr_test.res | 9 + tests/tests/src/hoisted_function_attr_use.mjs | 9 + tests/tests/src/hoisted_function_attr_use.res | 3 + 15 files changed, 183 insertions(+), 117 deletions(-) diff --git a/compiler/core/js_implementation.ml b/compiler/core/js_implementation.ml index df6ab959d12..e4c2cba0985 100644 --- a/compiler/core/js_implementation.ml +++ b/compiler/core/js_implementation.ml @@ -143,12 +143,12 @@ let after_parsing_impl ppf outputprefix (ast : Parsetree.structure) = Printtyped.implementation_with_coercion typedtree_coercion; (if !Js_config.cmi_only then Warnings.check_fatal () else - let lambda, exports = + let lambda, exports, hoisted = Translmod.transl_implementation modulename typedtree_coercion in let js_program = print_if_pipe ppf Clflags.dump_rawlambda Printlambda.lambda lambda - |> Lam_compile_main.compile outputprefix exports + |> Lam_compile_main.compile outputprefix exports hoisted in if not !Js_config.cmj_only then Lam_compile_main.lambda_as_module js_program outputprefix); diff --git a/compiler/core/lam_compile_main.ml b/compiler/core/lam_compile_main.ml index 3f4b1ec7b96..867b9ef39b7 100644 --- a/compiler/core/lam_compile_main.ml +++ b/compiler/core/lam_compile_main.ml @@ -110,18 +110,9 @@ let no_side_effects (rest : Lam_group.t list) : string option = (* Materialize JS-hoisted values as root-level aliases and exports. The source value still lives at its normal module path, but downstream tools can import the flat name directly when the .cmj metadata marks it as hoisted. *) -let js_hoisted_aliases (export_idents : Set_ident.t) (groups : Lam_group.t list) - = - let has_hoisted_binding = - List.exists - (function - | Lam_group.Single (_, id, _) -> Ident.js_hoisted id - | Lam_group.Recursive bindings -> - List.exists (fun (id, _) -> Ident.js_hoisted id) bindings - | Lam_group.Nop _ -> false) - groups - in - if not has_hoisted_binding then [] +let js_hoisted_aliases (export_ids : Ident.t list) + (hoisted : (string list * Location.t) list) (groups : Lam_group.t list) = + if hoisted = [] then [] else let group_map = Ext_list.fold_left groups Map_ident.empty (fun group_map group -> @@ -143,19 +134,50 @@ let js_hoisted_aliases (export_idents : Set_ident.t) (groups : Lam_group.t list) ~args:[base] loc) fields in - let resolve = function + let rec resolve seen = function | Lam.Lvar id as lam -> ( - match Map_ident.find_opt group_map id with - | Some resolved -> resolved - | None -> lam) + if Set_ident.mem seen id then lam + else + match Map_ident.find_opt group_map id with + | Some resolved -> resolve (Set_ident.add seen id) resolved + | None -> lam) + | Lam.Lprim {primitive = Lam_primitive.Pfield (pos, _); args = [base]} as + lam -> ( + match resolve seen base with + | Lam.Lprim + {primitive = Lam_primitive.Pmakeblock (_, Blk_module _, _); args} + -> ( + match List.nth_opt args pos with + | Some field -> resolve seen field + | None -> lam) + | _ -> lam) | lam -> lam in - let rec fold_module_fields fields args index acc f = + let rec find_field name pos fields args = match (fields, args) with - | [], [] -> acc - | field :: fields, arg :: args -> - fold_module_fields fields args (index + 1) (f index field arg acc) f - | _, _ -> invalid_arg "fold_module_fields" + | field :: _, arg :: _ when field = name -> Some (pos, arg) + | _ :: fields, _ :: args -> find_field name (pos + 1) fields args + | [], [] -> None + | _ -> invalid_arg "find_field" + in + let rec find_path lam fields positions = + match fields with + | [] -> Some (List.rev positions, resolve Set_ident.empty lam) + | field :: fields -> ( + match resolve Set_ident.empty lam with + | Lam.Lprim + { + primitive = Lam_primitive.Pmakeblock (_, Blk_module names, _); + args; + } -> ( + match find_field field 0 names args with + | Some (pos, arg) -> find_path arg fields ((pos, field) :: positions) + | None -> None) + | _ -> None) + in + let exported_modules = + Ext_list.fold_left export_ids Map_string.empty (fun modules id -> + Map_string.add modules id.Ident.name id) in let occupied_names = Ext_list.fold_left groups Set_string.empty (fun occupied group -> @@ -167,63 +189,58 @@ let js_hoisted_aliases (export_idents : Set_ident.t) (groups : Lam_group.t list) Set_string.add occupied (Ext_ident.convert id.Ident.name)) | Nop _ -> occupied) in - let rec scan top_id path ((aliases, occupied_names) as state) lam = - match resolve lam with - | Lam.Lprim - { - primitive = Lam_primitive.Pmakeblock (_, Blk_module fields, _); - args; - loc; - } -> - fold_module_fields fields args 0 state (fun pos field arg state -> - let path = path @ [(pos, field)] in - let aliases, occupied_names = scan top_id path state arg in - match arg with - | Lam.Lvar id when Ident.js_hoisted id -> - let segments = - top_id.Ident.name - :: Ext_list.map path (fun (_pos, name) -> name) - in - let name = - segments - |> List.map Ext_ident.unwrap_uppercase_exotic - |> String.concat "$" - in - let js_name = Ext_ident.convert name in - if Set_string.mem occupied_names js_name then - let loc = - match resolve arg with - | Lam.Lfunction {loc} -> loc - | _ -> loc - in - Location.raise_errorf ~loc - "Cannot hoist this function as `%s` because that name is \ - already used by a top-level binding." - name - else - let alias_id = Ident.create name in - let alias = access loc (Lam.var top_id) path in - ( ( Lam_group.Single (Alias, alias_id, alias), - alias_id, - alias, - segments, - name ) - :: aliases, - Set_string.add occupied_names js_name ) - | _ -> (aliases, occupied_names)) - | _ -> state - in fst - (Ext_list.fold_left groups ([], occupied_names) (fun state group -> - match group with - | Single (_, id, lam) when Set_ident.mem export_idents id -> - scan id [] state lam - | Single _ | Recursive _ | Nop _ -> state)) + (Ext_list.fold_left hoisted ([], occupied_names) + (fun ((aliases, occupied_names) as state) (segments, loc) -> + let missing_path () = + Location.prerr_warning loc + (Warnings.Misplaced_attribute "res.hoistedFunction"); + state + in + match segments with + | top :: fields -> ( + match Map_string.find_opt exported_modules top with + | Some top_id -> ( + match Map_ident.find_opt group_map top_id with + | Some lam -> ( + match find_path lam fields [] with + | Some (path, target) -> + let name = + segments + |> List.map Ext_ident.unwrap_uppercase_exotic + |> String.concat "$" + in + let js_name = Ext_ident.convert name in + if Set_string.mem occupied_names js_name then + let error_loc = + match target with + | Lam.Lfunction {loc} -> loc + | _ -> loc + in + Location.raise_errorf ~loc:error_loc + "Cannot hoist this function as `%s` because that name \ + is already used by a top-level binding." + name + else + let alias_id = Ident.create name in + let alias = access loc (Lam.var top_id) path in + ( ( Lam_group.Single (Alias, alias_id, alias), + alias_id, + alias, + segments, + name ) + :: aliases, + Set_string.add occupied_names js_name ) + | None -> missing_path ()) + | None -> missing_path ()) + | None -> missing_path ()) + | [] -> missing_path ())) (** Actually simplify_lets is kind of global optimization since it requires you to know whether it's used or not *) -let compile (output_prefix : string) export_idents (lam : Lambda.lambda) = +let compile (output_prefix : string) export_idents hoisted (lam : Lambda.lambda) + = let debug_ir = !Js_config.debug_ir in let diagnostics = if debug_ir then Some (Ir_diagnostics.create ~output_prefix) else None @@ -318,7 +335,7 @@ let compile (output_prefix : string) export_idents (lam : Lambda.lambda) = let maybe_pure = no_side_effects groups in (* Add the generated alias groups before JS lowering so regular export printing, tree shaking, and .cmj metadata all see the flat runtime value. *) - let hoisted_aliases = js_hoisted_aliases meta.export_idents groups in + let hoisted_aliases = js_hoisted_aliases meta.exports hoisted groups in let hoisted_groups, hoisted_exports, hoisted_export_map, hoisted_metadata = Ext_list.fold_left hoisted_aliases ([], [], Map_ident.empty, []) (fun diff --git a/compiler/core/lam_compile_main.mli b/compiler/core/lam_compile_main.mli index fcd298ce3aa..64a8dad24a6 100644 --- a/compiler/core/lam_compile_main.mli +++ b/compiler/core/lam_compile_main.mli @@ -27,7 +27,12 @@ (** Compile and register the hook of function to compile a lambda to JS IR *) -val compile : string -> Ident.t list -> Lambda.lambda -> J.deps_program +val compile : + string -> + Ident.t list -> + (string list * Location.t) list -> + Lambda.lambda -> + J.deps_program (** For toplevel, [filename] is [""] which is the same as {!Env.get_unit_name ()} *) diff --git a/compiler/ext/ident.ml b/compiler/ext/ident.ml index 3f31f010c5e..a5ca80e840f 100644 --- a/compiler/ext/ident.ml +++ b/compiler/ext/ident.ml @@ -20,7 +20,6 @@ type t = {stamp: int; name: string; mutable flags: int} let[@inlnie] max (x : int) y = if x >= y then x else y let global_flag = 1 let predef_exn_flag = 2 -let js_hoisted_flag = 4 (* A stamp of 0 denotes a persistent identifier *) @@ -72,12 +71,6 @@ let global i = i.flags land global_flag <> 0 let is_predef_exn i = i.flags land predef_exn_flag <> 0 -let make_js_hoisted i = i.flags <- i.flags lor js_hoisted_flag - -let clear_js_hoisted i = i.flags <- i.flags land lnot js_hoisted_flag - -let js_hoisted i = i.flags land js_hoisted_flag <> 0 - let print ppf i = match i.stamp with | 0 -> fprintf ppf "%s!" i.name diff --git a/compiler/ext/ident.mli b/compiler/ext/ident.mli index e29622f8789..d73cff6f6eb 100644 --- a/compiler/ext/ident.mli +++ b/compiler/ext/ident.mli @@ -49,9 +49,6 @@ val hide : t -> t val make_global : t -> unit val global : t -> bool val is_predef_exn : t -> bool -val make_js_hoisted : t -> unit -val clear_js_hoisted : t -> unit -val js_hoisted : t -> bool val binding_time : t -> int val current_time : unit -> int diff --git a/compiler/jsoo/jsoo_playground_main.ml b/compiler/jsoo/jsoo_playground_main.ml index a78cf8c3eb3..abf7ebb504f 100644 --- a/compiler/jsoo/jsoo_playground_main.ml +++ b/compiler/jsoo/jsoo_playground_main.ml @@ -519,12 +519,12 @@ module Compile = struct (a, b) in typed_tree |> Translmod.transl_implementation modulename - |> (* Printlambda.lambda ppf *) fun (lam, exports) -> + |> (* Printlambda.lambda ppf *) fun (lam, exports, hoisted) -> let buffer = Buffer.create 1000 in let () = Js_dump_program.pp_deps_program ~output_prefix:"" (* does not matter here *) module_system - (Lam_compile_main.compile "" exports lam) + (Lam_compile_main.compile "" exports hoisted lam) (Ext_pp.from_buffer buffer) in let v = Buffer.contents buffer in diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 86a94649e40..667f2d55a3c 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -616,9 +616,7 @@ let mark_js_hoisted_pattern ~js_hoist attrs pat lam = match pat.pat_desc with | Tpat_var (id, _) | Tpat_alias ({pat_desc = Tpat_any}, id, _) -> ( match js_hoist with - | Some register -> - Ident.make_js_hoisted id; - register id loc + | Some register -> register id loc | None -> Location.prerr_warning loc (Warnings.Misplaced_attribute hoisted_function_attr_name)) diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index 351d63227f7..16b0eb71e6a 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -234,15 +234,14 @@ let get_functor_params mexp coercion root_path = | _ -> assert false let export_identifiers : Ident.t list ref = ref [] -let js_hoisted : (Ident.t * string list * Location.t) list ref = ref [] +let js_hoisted : (string list * Location.t) list ref = ref [] let js_hoist_handler rootpath = match exportable_module_path rootpath with | None -> None | Some path -> Some - (fun id loc -> - js_hoisted := (id, path @ [id.Ident.name], loc) :: !js_hoisted) + (fun id loc -> js_hoisted := (path @ [id.Ident.name], loc) :: !js_hoisted) let rec remove_prefix prefix path = match (prefix, path) with @@ -269,32 +268,27 @@ let rec exported_by_coercion path coercion = find fields names | Tcoerce_functor _ | Tcoerce_primitive _ | Tcoerce_alias _ -> false) +let validate_js_hoisted_path prefix exported = + js_hoisted := + List.filter + (fun (path, loc) -> + match remove_prefix prefix path with + | Some path when not (exported path) -> + Location.prerr_warning loc + (Warnings.Misplaced_attribute "res.hoistedFunction"); + false + | Some _ | None -> true) + !js_hoisted + let validate_js_hoisted prefix coercion = match coercion with | Tcoerce_none -> () | _ -> - List.iter - (fun (id, path, loc) -> - if Ident.js_hoisted id then - match remove_prefix prefix path with - | Some path when not (exported_by_coercion path coercion) -> - Ident.clear_js_hoisted id; - Location.prerr_warning loc - (Warnings.Misplaced_attribute "res.hoistedFunction") - | Some _ | None -> ()) - !js_hoisted + validate_js_hoisted_path prefix (fun path -> + exported_by_coercion path coercion) let reject_js_hoisted prefix = - List.iter - (fun (id, path, loc) -> - if Ident.js_hoisted id then - match remove_prefix prefix path with - | Some _ -> - Ident.clear_js_hoisted id; - Location.prerr_warning loc - (Warnings.Misplaced_attribute "res.hoistedFunction") - | None -> ()) - !js_hoisted + validate_js_hoisted_path prefix (fun _path -> false) let rec compile_functor mexp coercion root_path loc = let functor_param, body, body_path, res_coercion, inline_attribute = @@ -555,7 +549,7 @@ let transl_implementation module_name (str, cc) = let module_id = Ident.create_persistent module_name in let body, _ = transl_struct Location.none [] cc (global_path module_id) str in validate_js_hoisted [] cc; - (body, !export_identifiers) + (body, !export_identifiers, !js_hoisted) (* Build the list of value identifiers defined by a toplevel structure (excluding primitive declarations). *) diff --git a/compiler/ml/translmod.mli b/compiler/ml/translmod.mli index 74ef747e105..f54b916fcf4 100644 --- a/compiler/ml/translmod.mli +++ b/compiler/ml/translmod.mli @@ -19,7 +19,7 @@ val transl_implementation : string -> Typedtree.structure * Typedtree.module_coercion -> - Lambda.lambda * Ident.t list + Lambda.lambda * Ident.t list * (string list * Location.t) list type error (* exception Error of Location.t * error *) diff --git a/tests/tests/src/hoisted_function_attr.mjs b/tests/tests/src/hoisted_function_attr.mjs index 8428fe698f2..3d466232380 100644 --- a/tests/tests/src/hoisted_function_attr.mjs +++ b/tests/tests/src/hoisted_function_attr.mjs @@ -124,6 +124,23 @@ let Typed = { make: make$5 }; +function make$6() { + return "coerced"; +} + +let Coerced = { + make: make$6 +}; + +let Included = { + make: make, + keep: keep +}; + +let Aliased; + +let Coerced$make = Coerced.make; + let Typed$make = Typed.make; let RecursiveA$make = RecursiveA.make; @@ -152,6 +169,10 @@ export { RecursiveA, RecursiveB, Typed, + Coerced, + Included, + Aliased, + Coerced$make, Typed$make, RecursiveA$make, Ambiguous$B$make, diff --git a/tests/tests/src/hoisted_function_attr.res b/tests/tests/src/hoisted_function_attr.res index 912a9609e97..149eabd5605 100644 --- a/tests/tests/src/hoisted_function_attr.res +++ b/tests/tests/src/hoisted_function_attr.res @@ -67,3 +67,18 @@ module Typed = { @res.hoistedFunction let make: unit => string = () => "typed" } + +module Coerced: { + let make: unit => string +} = { + let hidden = () => "coerced" + + @res.hoistedFunction + let make = () => hidden() +} + +module Included = { + include One +} + +module Aliased = One diff --git a/tests/tests/src/hoisted_function_attr_test.mjs b/tests/tests/src/hoisted_function_attr_test.mjs index c3621d2fd0e..94f44dc7bef 100644 --- a/tests/tests/src/hoisted_function_attr_test.mjs +++ b/tests/tests/src/hoisted_function_attr_test.mjs @@ -21,6 +21,11 @@ Mocha.describe("Hoisted_function_attr_test", () => { }); Mocha.test("recursive modules", () => Test_utils.eq("File \"hoisted_function_attr_test.res\", line 23, characters 7-14", Hoisted_function_attr_use.recursive, "recursive")); Mocha.test("explicit function type annotations", () => Test_utils.eq("File \"hoisted_function_attr_test.res\", line 27, characters 7-14", Hoisted_function_attr_use.typed, "typed")); + Mocha.test("signature coercion preserves hoists", () => Test_utils.eq("File \"hoisted_function_attr_test.res\", line 31, characters 7-14", Hoisted_function_attr_use.coerced, "coerced")); + Mocha.test("includes and aliases do not create additional hoists", () => { + Test_utils.eq("File \"hoisted_function_attr_test.res\", line 35, characters 7-14", Hoisted_function_attr_use.included, "one"); + Test_utils.eq("File \"hoisted_function_attr_test.res\", line 36, characters 7-14", Hoisted_function_attr_use.aliased, "one"); + }); }); /* Not a pure module */ diff --git a/tests/tests/src/hoisted_function_attr_test.res b/tests/tests/src/hoisted_function_attr_test.res index 314046330e1..e5e3212bfdb 100644 --- a/tests/tests/src/hoisted_function_attr_test.res +++ b/tests/tests/src/hoisted_function_attr_test.res @@ -26,4 +26,13 @@ describe(__MODULE__, () => { test("explicit function type annotations", () => { eq(__LOC__, Hoisted_function_attr_use.typed, "typed") }) + + test("signature coercion preserves hoists", () => { + eq(__LOC__, Hoisted_function_attr_use.coerced, "coerced") + }) + + test("includes and aliases do not create additional hoists", () => { + eq(__LOC__, Hoisted_function_attr_use.included, "one") + eq(__LOC__, Hoisted_function_attr_use.aliased, "one") + }) }) diff --git a/tests/tests/src/hoisted_function_attr_use.mjs b/tests/tests/src/hoisted_function_attr_use.mjs index 6cb0a0b5fe1..979b2062421 100644 --- a/tests/tests/src/hoisted_function_attr_use.mjs +++ b/tests/tests/src/hoisted_function_attr_use.mjs @@ -28,6 +28,12 @@ let recursive = Hoisted_function_attr.RecursiveA$make(); let typed = Hoisted_function_attr.Typed$make(); +let coerced = Hoisted_function_attr.Coerced$make(); + +let included = Hoisted_function_attr.Included.make(); + +let aliased = Hoisted_function_attr.One$make(); + export { one, oneKeep, @@ -42,5 +48,8 @@ export { exoticPath, recursive, typed, + coerced, + included, + aliased, } /* one Not a pure module */ diff --git a/tests/tests/src/hoisted_function_attr_use.res b/tests/tests/src/hoisted_function_attr_use.res index 6529d0160cf..28470c4c060 100644 --- a/tests/tests/src/hoisted_function_attr_use.res +++ b/tests/tests/src/hoisted_function_attr_use.res @@ -15,3 +15,6 @@ let nested = Hoisted_function_attr.Ambiguous.B.make() let exoticPath = Hoisted_function_attr.Ambiguous.\"B$make"() let recursive = Hoisted_function_attr.RecursiveA.make() let typed = Hoisted_function_attr.Typed.make() +let coerced = Hoisted_function_attr.Coerced.make() +let included = Hoisted_function_attr.Included.make() +let aliased = Hoisted_function_attr.Aliased.make() From 8e5d81c6bba37db9dc436195c881e3ef83e5f8f7 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sun, 23 Aug 2026 07:48:25 +0200 Subject: [PATCH 06/12] Preserve hoisted binding identity Signed-off-by: Christoph Knittel --- compiler/core/lam_compile_main.ml | 38 +++++++++------ compiler/core/lam_compile_main.mli | 2 +- compiler/ml/translcore.ml | 5 +- compiler/ml/translmod.ml | 33 ++++++++----- compiler/ml/translmod.mli | 2 +- ...isted_function_not_exportable.res.expected | 48 +++++++++++++++++++ .../hoisted_function_not_exportable.res | 10 ++++ 7 files changed, 107 insertions(+), 31 deletions(-) diff --git a/compiler/core/lam_compile_main.ml b/compiler/core/lam_compile_main.ml index 867b9ef39b7..ef403a0dccd 100644 --- a/compiler/core/lam_compile_main.ml +++ b/compiler/core/lam_compile_main.ml @@ -111,7 +111,8 @@ let no_side_effects (rest : Lam_group.t list) : string option = value still lives at its normal module path, but downstream tools can import the flat name directly when the .cmj metadata marks it as hoisted. *) let js_hoisted_aliases (export_ids : Ident.t list) - (hoisted : (string list * Location.t) list) (groups : Lam_group.t list) = + (hoisted : (Ident.t * string list * Location.t) list) + (groups : Lam_group.t list) = if hoisted = [] then [] else let group_map = @@ -134,25 +135,30 @@ let js_hoisted_aliases (export_ids : Ident.t list) ~args:[base] loc) fields in - let rec resolve seen = function + let rec resolve_binding seen = function | Lam.Lvar id as lam -> ( - if Set_ident.mem seen id then lam + if Set_ident.mem seen id then (lam, Some id) else match Map_ident.find_opt group_map id with - | Some resolved -> resolve (Set_ident.add seen id) resolved - | None -> lam) + | Some + ((Lam.Lvar _ | Lam.Lprim {primitive = Lam_primitive.Pfield _; _}) + as alias) -> + resolve_binding (Set_ident.add seen id) alias + | Some resolved -> (resolved, Some id) + | None -> (lam, Some id)) | Lam.Lprim {primitive = Lam_primitive.Pfield (pos, _); args = [base]} as lam -> ( - match resolve seen base with + match fst (resolve_binding seen base) with | Lam.Lprim {primitive = Lam_primitive.Pmakeblock (_, Blk_module _, _); args} -> ( match List.nth_opt args pos with - | Some field -> resolve seen field - | None -> lam) - | _ -> lam) - | lam -> lam + | Some field -> resolve_binding seen field + | None -> (lam, None)) + | _ -> (lam, None)) + | lam -> (lam, None) in + let resolve seen lam = fst (resolve_binding seen lam) in let rec find_field name pos fields args = match (fields, args) with | field :: _, arg :: _ when field = name -> Some (pos, arg) @@ -162,7 +168,9 @@ let js_hoisted_aliases (export_ids : Ident.t list) in let rec find_path lam fields positions = match fields with - | [] -> Some (List.rev positions, resolve Set_ident.empty lam) + | [] -> + let target, binding_id = resolve_binding Set_ident.empty lam in + Some (List.rev positions, binding_id, target) | field :: fields -> ( match resolve Set_ident.empty lam with | Lam.Lprim @@ -191,7 +199,8 @@ let js_hoisted_aliases (export_ids : Ident.t list) in fst (Ext_list.fold_left hoisted ([], occupied_names) - (fun ((aliases, occupied_names) as state) (segments, loc) -> + (fun + ((aliases, occupied_names) as state) (binding_id, segments, loc) -> let missing_path () = Location.prerr_warning loc (Warnings.Misplaced_attribute "res.hoistedFunction"); @@ -204,7 +213,8 @@ let js_hoisted_aliases (export_ids : Ident.t list) match Map_ident.find_opt group_map top_id with | Some lam -> ( match find_path lam fields [] with - | Some (path, target) -> + | Some (path, Some target_id, target) + when Ident.same binding_id target_id -> let name = segments |> List.map Ext_ident.unwrap_uppercase_exotic @@ -231,7 +241,7 @@ let js_hoisted_aliases (export_ids : Ident.t list) name ) :: aliases, Set_string.add occupied_names js_name ) - | None -> missing_path ()) + | Some _ | None -> missing_path ()) | None -> missing_path ()) | None -> missing_path ()) | [] -> missing_path ())) diff --git a/compiler/core/lam_compile_main.mli b/compiler/core/lam_compile_main.mli index 64a8dad24a6..016f1f90525 100644 --- a/compiler/core/lam_compile_main.mli +++ b/compiler/core/lam_compile_main.mli @@ -30,7 +30,7 @@ val compile : string -> Ident.t list -> - (string list * Location.t) list -> + (Ident.t * string list * Location.t) list -> Lambda.lambda -> J.deps_program (** For toplevel, [filename] is [""] which is the same as diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 667f2d55a3c..d9fa1954650 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -604,9 +604,8 @@ let find_js_hoisted_attr attrs = Translattribute.get_empty_attribute hoisted_function_attr_name attrs (* A value binding's source attributes are not carried all the way to JS - emission. When a function has @res.hoistedFunction, mark the bound variable - itself so later compiler stages can add the flat JS export and write the - matching .cmj metadata. *) + emission. Record the binding and its source path here so later compiler + stages can add the flat JS export and matching .cmj metadata. *) let mark_js_hoisted_pattern ~js_hoist attrs pat lam = match find_js_hoisted_attr attrs with | None -> () diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index 16b0eb71e6a..cd54072d41d 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -234,14 +234,22 @@ let get_functor_params mexp coercion root_path = | _ -> assert false let export_identifiers : Ident.t list ref = ref [] -let js_hoisted : (string list * Location.t) list ref = ref [] +let js_hoisted : (Ident.t * string list * Location.t) list ref = ref [] let js_hoist_handler rootpath = match exportable_module_path rootpath with | None -> None | Some path -> Some - (fun id loc -> js_hoisted := (path @ [id.Ident.name], loc) :: !js_hoisted) + (fun id loc -> + js_hoisted := (id, path @ [id.Ident.name], loc) :: !js_hoisted) + +let reject_js_hoisted_attribute attrs = + match Translattribute.get_empty_attribute "res.hoistedFunction" attrs with + | Some loc -> + Location.prerr_warning loc + (Warnings.Misplaced_attribute "res.hoistedFunction") + | None -> () let rec remove_prefix prefix path = match (prefix, path) with @@ -271,7 +279,7 @@ let rec exported_by_coercion path coercion = let validate_js_hoisted_path prefix exported = js_hoisted := List.filter - (fun (path, loc) -> + (fun (_, path, loc) -> match remove_prefix prefix path with | Some path when not (exported path) -> Location.prerr_warning loc @@ -524,16 +532,17 @@ and transl_structure loc fields cc rootpath final_env = function | Tstr_primitive {val_attributes} -> (* Externals do not introduce a Lambda function binding that can be hoisted, so surface the attribute as misplaced here. *) - (match - Translattribute.get_empty_attribute "res.hoistedFunction" - val_attributes - with - | Some loc -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute "res.hoistedFunction") - | None -> ()); + reject_js_hoisted_attribute val_attributes; + transl_structure loc fields cc rootpath final_env rem + | Tstr_type (_, declarations) -> + List.iter + (fun {typ_attributes} -> reject_js_hoisted_attribute typ_attributes) + declarations; + transl_structure loc fields cc rootpath final_env rem + | Tstr_modtype {mtd_attributes} -> + reject_js_hoisted_attribute mtd_attributes; transl_structure loc fields cc rootpath final_env rem - | Tstr_type _ | Tstr_modtype _ | Tstr_open _ | Tstr_attribute _ -> + | Tstr_open _ | Tstr_attribute _ -> transl_structure loc fields cc rootpath final_env rem) (* Update forward declaration in Translcore *) diff --git a/compiler/ml/translmod.mli b/compiler/ml/translmod.mli index f54b916fcf4..4f9249ee7c7 100644 --- a/compiler/ml/translmod.mli +++ b/compiler/ml/translmod.mli @@ -19,7 +19,7 @@ val transl_implementation : string -> Typedtree.structure * Typedtree.module_coercion -> - Lambda.lambda * Ident.t list * (string list * Location.t) list + Lambda.lambda * Ident.t list * (Ident.t * string list * Location.t) list type error (* exception Error of Location.t * error *) diff --git a/tests/build_tests/super_errors/expected/hoisted_function_not_exportable.res.expected b/tests/build_tests/super_errors/expected/hoisted_function_not_exportable.res.expected index a53c96a6218..91b97180691 100644 --- a/tests/build_tests/super_errors/expected/hoisted_function_not_exportable.res.expected +++ b/tests/build_tests/super_errors/expected/hoisted_function_not_exportable.res.expected @@ -1,4 +1,40 @@ + Warning number 32 + /.../fixtures/hoisted_function_not_exportable.res:26:7-10 + + 24 │ module Shadowed = { + 25 │ @res.hoistedFunction + 26 │ let make = () => "first" + 27 │ let make = () => "second" + 28 │ } + + unused value make. + + + Warning number 53 + /.../fixtures/hoisted_function_not_exportable.res:29:1-20 + + 27 │ let make = () => "second" + 28 │ } + 29 │ @res.hoistedFunction + 30 │ type markedType = int + 31 │ @res.hoistedFunction + + the @res.hoistedFunction attribute cannot appear in this context + + + Warning number 53 + /.../fixtures/hoisted_function_not_exportable.res:31:1-20 + + 29 │ @res.hoistedFunction + 30 │ type markedType = int + 31 │ @res.hoistedFunction + 32 │ module type MarkedModule = {} + 33 │ let after = () + + the @res.hoistedFunction attribute cannot appear in this context + + Warning number 53 /.../fixtures/hoisted_function_not_exportable.res:19:3-22 @@ -43,4 +79,16 @@ 3 │ let local = () => () 4 │ local() + the @res.hoistedFunction attribute cannot appear in this context + + + Warning number 53 + /.../fixtures/hoisted_function_not_exportable.res:25:3-22 + + 23 │ let usePrivate = privateMake() + 24 │ module Shadowed = { + 25 │ @res.hoistedFunction + 26 │ let make = () => "first" + 27 │ let make = () => "second" + the @res.hoistedFunction attribute cannot appear in this context \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/hoisted_function_not_exportable.res b/tests/build_tests/super_errors/fixtures/hoisted_function_not_exportable.res index cb1b64c48c9..aa7671ab368 100644 --- a/tests/build_tests/super_errors/fixtures/hoisted_function_not_exportable.res +++ b/tests/build_tests/super_errors/fixtures/hoisted_function_not_exportable.res @@ -21,3 +21,13 @@ module Make = () => { ) let usePrivate = privateMake() +module Shadowed = { + @res.hoistedFunction + let make = () => "first" + let make = () => "second" +} +@res.hoistedFunction +type markedType = int +@res.hoistedFunction +module type MarkedModule = {} +let after = () From f52fd1a63ebc70cb18a0e794a9bcd133d077f234 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sun, 23 Aug 2026 07:56:53 +0200 Subject: [PATCH 07/12] Name hoisted function metadata fields Signed-off-by: Christoph Knittel --- compiler/core/lam_compile_main.ml | 19 +++++++++---------- compiler/core/lam_compile_main.mli | 2 +- compiler/ml/lambda.ml | 2 ++ compiler/ml/lambda.mli | 2 ++ compiler/ml/translmod.ml | 8 +++++--- compiler/ml/translmod.mli | 2 +- 6 files changed, 20 insertions(+), 15 deletions(-) diff --git a/compiler/core/lam_compile_main.ml b/compiler/core/lam_compile_main.ml index ef403a0dccd..3caa040b4d6 100644 --- a/compiler/core/lam_compile_main.ml +++ b/compiler/core/lam_compile_main.ml @@ -111,8 +111,7 @@ let no_side_effects (rest : Lam_group.t list) : string option = value still lives at its normal module path, but downstream tools can import the flat name directly when the .cmj metadata marks it as hoisted. *) let js_hoisted_aliases (export_ids : Ident.t list) - (hoisted : (Ident.t * string list * Location.t) list) - (groups : Lam_group.t list) = + (hoisted : Lambda.hoisted_function list) (groups : Lam_group.t list) = if hoisted = [] then [] else let group_map = @@ -199,24 +198,24 @@ let js_hoisted_aliases (export_ids : Ident.t list) in fst (Ext_list.fold_left hoisted ([], occupied_names) - (fun - ((aliases, occupied_names) as state) (binding_id, segments, loc) -> + (fun ((aliases, occupied_names) as state) hoisted -> + let {Lambda.binding; path; loc} = hoisted in let missing_path () = Location.prerr_warning loc (Warnings.Misplaced_attribute "res.hoistedFunction"); state in - match segments with + match path with | top :: fields -> ( match Map_string.find_opt exported_modules top with | Some top_id -> ( match Map_ident.find_opt group_map top_id with | Some lam -> ( match find_path lam fields [] with - | Some (path, Some target_id, target) - when Ident.same binding_id target_id -> + | Some (access_path, Some target_id, target) + when Ident.same binding target_id -> let name = - segments + path |> List.map Ext_ident.unwrap_uppercase_exotic |> String.concat "$" in @@ -233,11 +232,11 @@ let js_hoisted_aliases (export_ids : Ident.t list) name else let alias_id = Ident.create name in - let alias = access loc (Lam.var top_id) path in + let alias = access loc (Lam.var top_id) access_path in ( ( Lam_group.Single (Alias, alias_id, alias), alias_id, alias, - segments, + path, name ) :: aliases, Set_string.add occupied_names js_name ) diff --git a/compiler/core/lam_compile_main.mli b/compiler/core/lam_compile_main.mli index 016f1f90525..2cfeef80019 100644 --- a/compiler/core/lam_compile_main.mli +++ b/compiler/core/lam_compile_main.mli @@ -30,7 +30,7 @@ val compile : string -> Ident.t list -> - (Ident.t * string list * Location.t) list -> + Lambda.hoisted_function list -> Lambda.lambda -> J.deps_program (** For toplevel, [filename] is [""] which is the same as diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 987d844ddd6..e649a0876e9 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -15,6 +15,8 @@ type loc_kind = Loc_FILE | Loc_LINE | Loc_MODULE | Loc_LOC | Loc_POS +type hoisted_function = {binding: Ident.t; path: string list; loc: Location.t} + type tag_info = | Blk_constructor of { name: string; diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index efe4d9802b5..d781c525dc1 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -19,6 +19,8 @@ open Asttypes type loc_kind = Loc_FILE | Loc_LINE | Loc_MODULE | Loc_LOC | Loc_POS +type hoisted_function = {binding: Ident.t; path: string list; loc: Location.t} + type tag_info = | Blk_constructor of { name: string; diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index cd54072d41d..281f81278fd 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -234,7 +234,7 @@ let get_functor_params mexp coercion root_path = | _ -> assert false let export_identifiers : Ident.t list ref = ref [] -let js_hoisted : (Ident.t * string list * Location.t) list ref = ref [] +let js_hoisted : Lambda.hoisted_function list ref = ref [] let js_hoist_handler rootpath = match exportable_module_path rootpath with @@ -242,7 +242,9 @@ let js_hoist_handler rootpath = | Some path -> Some (fun id loc -> - js_hoisted := (id, path @ [id.Ident.name], loc) :: !js_hoisted) + js_hoisted := + {Lambda.binding = id; path = path @ [id.Ident.name]; loc} + :: !js_hoisted) let reject_js_hoisted_attribute attrs = match Translattribute.get_empty_attribute "res.hoistedFunction" attrs with @@ -279,7 +281,7 @@ let rec exported_by_coercion path coercion = let validate_js_hoisted_path prefix exported = js_hoisted := List.filter - (fun (_, path, loc) -> + (fun {Lambda.path; loc} -> match remove_prefix prefix path with | Some path when not (exported path) -> Location.prerr_warning loc diff --git a/compiler/ml/translmod.mli b/compiler/ml/translmod.mli index 4f9249ee7c7..7d891d8c4e6 100644 --- a/compiler/ml/translmod.mli +++ b/compiler/ml/translmod.mli @@ -19,7 +19,7 @@ val transl_implementation : string -> Typedtree.structure * Typedtree.module_coercion -> - Lambda.lambda * Ident.t list * (Ident.t * string list * Location.t) list + Lambda.lambda * Ident.t list * Lambda.hoisted_function list type error (* exception Error of Location.t * error *) From 15f9480b150ec67af1f56983120a1b3f0d1b0256 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sun, 23 Aug 2026 08:08:20 +0200 Subject: [PATCH 08/12] Tidy hoisted function metadata handling Signed-off-by: Christoph Knittel --- compiler/core/js_cmj_format.ml | 8 +-- compiler/core/js_cmj_format.mli | 3 +- compiler/core/js_implementation.ml | 4 +- compiler/core/lam_compile_main.ml | 2 +- compiler/jsoo/jsoo_playground_main.ml | 7 ++- compiler/ml/translattribute.ml | 5 ++ compiler/ml/translattribute.mli | 2 + compiler/ml/translmod.ml | 59 ++++++++++++------- compiler/ml/translmod.mli | 10 +++- compiler/ml/typemod.ml | 27 +++++++++ ...isted_function_not_exportable.res.expected | 26 +++++++- .../hoisted_function_not_exportable.res | 6 ++ 12 files changed, 124 insertions(+), 35 deletions(-) diff --git a/compiler/core/js_cmj_format.ml b/compiler/core/js_cmj_format.ml index 9df5ffdac89..005b34d0de6 100644 --- a/compiler/core/js_cmj_format.ml +++ b/compiler/core/js_cmj_format.ml @@ -47,7 +47,8 @@ type keyed_cmj_values = keyed_cmj_value array type hoisted_export = { path: string list; (** Exact source-level module path segments. *) - name: string; (** Flat compiler identifier used for the public JS export. *) + export_name: string; + (** Flat compiler identifier used for the public JS export. *) } type t = { @@ -105,8 +106,7 @@ let to_file name ~check_exists (v : t) = output_string oc s; close_out oc) -let key_comp (a : string) (b : keyed_cmj_value) = - Map_string.compare_key a b.name +let key_comp a b = Map_string.compare_key a b.name let not_found key = {name = key; arity = single_na; persistent_closed_lambda = None} @@ -163,7 +163,7 @@ let query_by_name (cmj_table : t) name : keyed_cmj_value = let find_hoisted_export (cmj_table : t) path = Array.find_map (fun value -> - if List.equal Ext_string.equal value.path path then Some value.name + if List.equal Ext_string.equal value.path path then Some value.export_name else None) cmj_table.hoisted_exports diff --git a/compiler/core/js_cmj_format.mli b/compiler/core/js_cmj_format.mli index 5cfd0a703d7..913ac3a889c 100644 --- a/compiler/core/js_cmj_format.mli +++ b/compiler/core/js_cmj_format.mli @@ -62,7 +62,8 @@ type keyed_cmj_value = { type hoisted_export = { path: string list; (** Exact source-level module path segments. *) - name: string; (** Flat compiler identifier used for the public JS export. *) + export_name: string; + (** Flat compiler identifier used for the public JS export. *) } type t = { diff --git a/compiler/core/js_implementation.ml b/compiler/core/js_implementation.ml index e4c2cba0985..49fcdc3c534 100644 --- a/compiler/core/js_implementation.ml +++ b/compiler/core/js_implementation.ml @@ -143,12 +143,12 @@ let after_parsing_impl ppf outputprefix (ast : Parsetree.structure) = Printtyped.implementation_with_coercion typedtree_coercion; (if !Js_config.cmi_only then Warnings.check_fatal () else - let lambda, exports, hoisted = + let {Translmod.lambda; exports; hoisted_functions} = Translmod.transl_implementation modulename typedtree_coercion in let js_program = print_if_pipe ppf Clflags.dump_rawlambda Printlambda.lambda lambda - |> Lam_compile_main.compile outputprefix exports hoisted + |> Lam_compile_main.compile outputprefix exports hoisted_functions in if not !Js_config.cmj_only then Lam_compile_main.lambda_as_module js_program outputprefix); diff --git a/compiler/core/lam_compile_main.ml b/compiler/core/lam_compile_main.ml index 3caa040b4d6..07f53dbc348 100644 --- a/compiler/core/lam_compile_main.ml +++ b/compiler/core/lam_compile_main.ml @@ -354,7 +354,7 @@ let compile (output_prefix : string) export_idents hoisted (lam : Lambda.lambda) ( group :: groups, id :: exports, Map_ident.add export_map id lam, - {Js_cmj_format.path; name} :: hoisted_metadata )) + {Js_cmj_format.path; export_name = name} :: hoisted_metadata )) in let groups = groups @ List.rev hoisted_groups in let meta = diff --git a/compiler/jsoo/jsoo_playground_main.ml b/compiler/jsoo/jsoo_playground_main.ml index abf7ebb504f..2fffbd4b15f 100644 --- a/compiler/jsoo/jsoo_playground_main.ml +++ b/compiler/jsoo/jsoo_playground_main.ml @@ -518,13 +518,14 @@ module Compile = struct types_signature := signature; (a, b) in - typed_tree |> Translmod.transl_implementation modulename - |> (* Printlambda.lambda ppf *) fun (lam, exports, hoisted) -> + let {Translmod.lambda; exports; hoisted_functions} = + Translmod.transl_implementation modulename typed_tree + in let buffer = Buffer.create 1000 in let () = Js_dump_program.pp_deps_program ~output_prefix:"" (* does not matter here *) module_system - (Lam_compile_main.compile "" exports hoisted lam) + (Lam_compile_main.compile "" exports hoisted_functions lambda) (Ext_pp.from_buffer buffer) in let v = Buffer.contents buffer in diff --git a/compiler/ml/translattribute.ml b/compiler/ml/translattribute.ml index 91314cfdcf3..a5dbd2d9747 100644 --- a/compiler/ml/translattribute.ml +++ b/compiler/ml/translattribute.ml @@ -52,6 +52,11 @@ let get_empty_attribute name attributes = (name, "This attribute does not accept a payload")); None +let reject_attribute name attributes = + match get_empty_attribute name attributes with + | Some loc -> Location.prerr_warning loc (Warnings.Misplaced_attribute name) + | None -> () + let parse_inline_attribute (attr : t option) : Lambda.inline_attribute = match attr with | None -> Default_inline diff --git a/compiler/ml/translattribute.mli b/compiler/ml/translattribute.mli index bac456ba8d8..992b323241b 100644 --- a/compiler/ml/translattribute.mli +++ b/compiler/ml/translattribute.mli @@ -25,6 +25,8 @@ val get_inline_attribute : Parsetree.attributes -> Lambda.inline_attribute val get_empty_attribute : string -> Parsetree.attributes -> Location.t option +val reject_attribute : string -> Parsetree.attributes -> unit + val get_and_remove_inlined_attribute : Typedtree.expression -> Lambda.inline_attribute * Typedtree.expression diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index 281f81278fd..cec4f9435e3 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -247,11 +247,31 @@ let js_hoist_handler rootpath = :: !js_hoisted) let reject_js_hoisted_attribute attrs = - match Translattribute.get_empty_attribute "res.hoistedFunction" attrs with - | Some loc -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute "res.hoistedFunction") - | None -> () + Translattribute.reject_attribute "res.hoistedFunction" attrs + +let reject_js_hoisted_structure_item = function + | Tstr_value _ -> () + | Tstr_eval (_, attrs) -> reject_js_hoisted_attribute attrs + | Tstr_primitive {val_attributes} -> + reject_js_hoisted_attribute val_attributes + | Tstr_type (_, declarations) -> + List.iter + (fun {typ_attributes} -> reject_js_hoisted_attribute typ_attributes) + declarations + | Tstr_typext {tyext_attributes} -> + reject_js_hoisted_attribute tyext_attributes + | Tstr_exception {ext_attributes} -> + reject_js_hoisted_attribute ext_attributes + | Tstr_module {mb_attributes} -> reject_js_hoisted_attribute mb_attributes + | Tstr_recmodule bindings -> + List.iter + (fun {mb_attributes} -> reject_js_hoisted_attribute mb_attributes) + bindings + | Tstr_modtype {mtd_attributes} -> reject_js_hoisted_attribute mtd_attributes + | Tstr_open {open_attributes} -> reject_js_hoisted_attribute open_attributes + | Tstr_include {incl_attributes} -> + reject_js_hoisted_attribute incl_attributes + | Tstr_attribute attr -> reject_js_hoisted_attribute [attr] let rec remove_prefix prefix path = match (prefix, path) with @@ -431,6 +451,7 @@ and transl_structure loc fields cc rootpath final_env = function List.length pos_cc_list ) | _ -> Misc.fatal_error "Translmod.transl_structure") | item :: rem -> ( + reject_js_hoisted_structure_item item.str_desc; match item.str_desc with | Tstr_eval (expr, _) -> let body, size = transl_structure loc fields cc rootpath final_env rem in @@ -531,20 +552,8 @@ and transl_structure loc fields cc rootpath final_env = function transl_module Tcoerce_none None modl, body ), size ) - | Tstr_primitive {val_attributes} -> - (* Externals do not introduce a Lambda function binding that can be - hoisted, so surface the attribute as misplaced here. *) - reject_js_hoisted_attribute val_attributes; - transl_structure loc fields cc rootpath final_env rem - | Tstr_type (_, declarations) -> - List.iter - (fun {typ_attributes} -> reject_js_hoisted_attribute typ_attributes) - declarations; - transl_structure loc fields cc rootpath final_env rem - | Tstr_modtype {mtd_attributes} -> - reject_js_hoisted_attribute mtd_attributes; - transl_structure loc fields cc rootpath final_env rem - | Tstr_open _ | Tstr_attribute _ -> + | Tstr_primitive _ | Tstr_type _ | Tstr_modtype _ | Tstr_open _ + | Tstr_attribute _ -> transl_structure loc fields cc rootpath final_env rem) (* Update forward declaration in Translcore *) @@ -554,13 +563,23 @@ let _ = Translcore.transl_module := transl_module (* Compile an implementation *) +type implementation = { + lambda: Lambda.lambda; + exports: Ident.t list; + hoisted_functions: Lambda.hoisted_function list; +} + let transl_implementation module_name (str, cc) = export_identifiers := []; js_hoisted := []; let module_id = Ident.create_persistent module_name in let body, _ = transl_struct Location.none [] cc (global_path module_id) str in validate_js_hoisted [] cc; - (body, !export_identifiers, !js_hoisted) + { + lambda = body; + exports = !export_identifiers; + hoisted_functions = !js_hoisted; + } (* Build the list of value identifiers defined by a toplevel structure (excluding primitive declarations). *) diff --git a/compiler/ml/translmod.mli b/compiler/ml/translmod.mli index 7d891d8c4e6..5da4808c1fa 100644 --- a/compiler/ml/translmod.mli +++ b/compiler/ml/translmod.mli @@ -16,10 +16,14 @@ (* Translation from typed abstract syntax to lambda terms, for the module language *) +type implementation = { + lambda: Lambda.lambda; + exports: Ident.t list; + hoisted_functions: Lambda.hoisted_function list; +} + val transl_implementation : - string -> - Typedtree.structure * Typedtree.module_coercion -> - Lambda.lambda * Ident.t list * Lambda.hoisted_function list + string -> Typedtree.structure * Typedtree.module_coercion -> implementation type error (* exception Error of Location.t * error *) diff --git a/compiler/ml/typemod.ml b/compiler/ml/typemod.ml index b35814fe62c..0c204af7841 100644 --- a/compiler/ml/typemod.ml +++ b/compiler/ml/typemod.ml @@ -600,6 +600,32 @@ let check_recmod_typedecls env sdecls decls = (Mtype.type_paths env (Pident id) mty)) sdecls decls +let reject_js_hoisted_attribute attrs = + Translattribute.reject_attribute "res.hoistedFunction" attrs + +let reject_js_hoisted_signature_item = function + | Psig_value {pval_attributes} -> reject_js_hoisted_attribute pval_attributes + | Psig_type (_, declarations) -> + List.iter + (fun {ptype_attributes} -> reject_js_hoisted_attribute ptype_attributes) + declarations + | Psig_typext {ptyext_attributes} -> + reject_js_hoisted_attribute ptyext_attributes + | Psig_exception {pext_attributes} -> + reject_js_hoisted_attribute pext_attributes + | Psig_module {pmd_attributes} -> reject_js_hoisted_attribute pmd_attributes + | Psig_recmodule declarations -> + List.iter + (fun {pmd_attributes} -> reject_js_hoisted_attribute pmd_attributes) + declarations + | Psig_modtype {pmtd_attributes} -> + reject_js_hoisted_attribute pmtd_attributes + | Psig_open {popen_attributes} -> reject_js_hoisted_attribute popen_attributes + | Psig_include {pincl_attributes} -> + reject_js_hoisted_attribute pincl_attributes + | Psig_attribute attr -> reject_js_hoisted_attribute [attr] + | Psig_extension (_, attrs) -> reject_js_hoisted_attribute attrs + (* Auxiliaries for checking uniqueness of names in signatures and structures *) module String_set = Set.Make (struct @@ -751,6 +777,7 @@ and transl_signature env sg = | [] -> ([], [], env) | item :: srem -> ( let loc = item.psig_loc in + reject_js_hoisted_signature_item item.psig_desc; match item.psig_desc with | Psig_value sdesc -> let tdesc, newenv = diff --git a/tests/build_tests/super_errors/expected/hoisted_function_not_exportable.res.expected b/tests/build_tests/super_errors/expected/hoisted_function_not_exportable.res.expected index 91b97180691..e073e15bf11 100644 --- a/tests/build_tests/super_errors/expected/hoisted_function_not_exportable.res.expected +++ b/tests/build_tests/super_errors/expected/hoisted_function_not_exportable.res.expected @@ -1,4 +1,16 @@ + Warning number 53 + /.../fixtures/hoisted_function_not_exportable.res:36:3-22 + + 34 │ module MarkedModule = {} + 35 │ module type MarkedSignature = { + 36 │ @res.hoistedFunction + 37 │ let make: unit => unit + 38 │ } + + the @res.hoistedFunction attribute cannot appear in this context + + Warning number 32 /.../fixtures/hoisted_function_not_exportable.res:26:7-10 @@ -30,7 +42,19 @@ 30 │ type markedType = int 31 │ @res.hoistedFunction 32 │ module type MarkedModule = {} - 33 │ let after = () + 33 │ @res.hoistedFunction + + the @res.hoistedFunction attribute cannot appear in this context + + + Warning number 53 + /.../fixtures/hoisted_function_not_exportable.res:33:1-20 + + 31 │ @res.hoistedFunction + 32 │ module type MarkedModule = {} + 33 │ @res.hoistedFunction + 34 │ module MarkedModule = {} + 35 │ module type MarkedSignature = { the @res.hoistedFunction attribute cannot appear in this context diff --git a/tests/build_tests/super_errors/fixtures/hoisted_function_not_exportable.res b/tests/build_tests/super_errors/fixtures/hoisted_function_not_exportable.res index aa7671ab368..6c0e34854be 100644 --- a/tests/build_tests/super_errors/fixtures/hoisted_function_not_exportable.res +++ b/tests/build_tests/super_errors/fixtures/hoisted_function_not_exportable.res @@ -30,4 +30,10 @@ module Shadowed = { type markedType = int @res.hoistedFunction module type MarkedModule = {} +@res.hoistedFunction +module MarkedModule = {} +module type MarkedSignature = { + @res.hoistedFunction + let make: unit => unit +} let after = () From b8b8c209d74b3b93c7c3f0fbbe4b5f92846c44d6 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sun, 23 Aug 2026 08:09:48 +0200 Subject: [PATCH 09/12] Bump compatibility marker for CMJ schema Signed-off-by: Christoph Knittel --- compiler/ext/config.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/ext/config.ml b/compiler/ext/config.ml index c44aa8392d3..e848a4ccbc3 100644 --- a/compiler/ext/config.ml +++ b/compiler/ext/config.ml @@ -1,4 +1,4 @@ -let cmi_magic_number = "Caml1999I023" +let cmi_magic_number = "Caml1999I024" (* Magic numbers for marshaled values of the *current* parsetree, whose layout changes across compiler versions. *) From 3f6fae317d8bbc381c35ad69725eb7fed5d320e8 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sun, 23 Aug 2026 10:59:18 +0200 Subject: [PATCH 10/12] Reuse unused attribute handling for hoisted functions Signed-off-by: Christoph Knittel --- compiler/frontend/bs_ast_invariant.ml | 9 ++-- compiler/frontend/bs_builtin_ppx.ml | 22 ++++++++- compiler/ml/translattribute.ml | 5 -- compiler/ml/translattribute.mli | 2 - compiler/ml/translmod.ml | 28 ----------- compiler/ml/typemod.ml | 27 ----------- ...isted_function_not_exportable.res.expected | 48 ------------------- ...rning_101_bs_unused_attribute.res.expected | 30 ++++++++++++ .../hoisted_function_not_exportable.res | 10 ---- .../warning_101_bs_unused_attribute.res | 7 +++ 10 files changed, 63 insertions(+), 125 deletions(-) diff --git a/compiler/frontend/bs_ast_invariant.ml b/compiler/frontend/bs_ast_invariant.ml index 023043f9f44..a5b38f9669a 100644 --- a/compiler/frontend/bs_ast_invariant.ml +++ b/compiler/frontend/bs_ast_invariant.ml @@ -22,19 +22,20 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(** Warning unused bs attributes +(** Warn about unused compiler attributes. Note if we warn `deriving` too, it may fail third party ppxes *) -let is_bs_attribute txt = +let is_checked_attribute txt = match txt with - | "as" | "config" | "ignore" | "int" | "optional" | "string" | "unwrap" -> + | "as" | "config" | "ignore" | "int" | "optional" | "res.hoistedFunction" + | "string" | "unwrap" -> true | _ -> false let warn_unused_attribute ((({txt; loc} as sloc), _) : Parsetree.attribute) = if - is_bs_attribute txt && (not loc.loc_ghost) + is_checked_attribute txt && (not loc.loc_ghost) && not (Used_attributes.is_used_attribute sloc) then (* diff --git a/compiler/frontend/bs_builtin_ppx.ml b/compiler/frontend/bs_builtin_ppx.ml index b71c3d2524c..3a24dde987b 100644 --- a/compiler/frontend/bs_builtin_ppx.ml +++ b/compiler/frontend/bs_builtin_ppx.ml @@ -406,6 +406,22 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) let typ_mapper (self : mapper) (typ : Parsetree.core_type) = Ast_core_type_class_type.typ_mapper self typ +let mark_hoisted_function_attributes (bindings : Parsetree.value_binding list) = + Ext_list.iter bindings (fun {pvb_attributes} -> + Ext_list.iter pvb_attributes (fun (({txt}, _) as attr) -> + if txt = "res.hoistedFunction" then + Used_attributes.mark_used_attribute attr)) + +let value_bindings_mapper (self : mapper) + (bindings : Parsetree.value_binding list) = + mark_hoisted_function_attributes bindings; + Ast_tuple_pattern_flatten.value_bindings_mapper self bindings + +let value_bindings_rec_mapper (self : mapper) + (bindings : Parsetree.value_binding list) = + mark_hoisted_function_attributes bindings; + default_mapper.value_bindings_rec self bindings + let signature_item_mapper (self : mapper) (sigi : Parsetree.signature_item) : Parsetree.signature_item = match sigi.psig_desc with @@ -486,6 +502,9 @@ let signature_item_mapper (self : mapper) (sigi : Parsetree.signature_item) : let structure_item_mapper (self : mapper) (str : Parsetree.structure_item) : Parsetree.structure_item = + (match str.pstr_desc with + | Pstr_value (_, bindings) -> mark_hoisted_function_attributes bindings + | _ -> ()); match str.pstr_desc with | Pstr_value (_, vbs) when List.exists @@ -784,7 +803,8 @@ let mapper : mapper = pat = pat_mapper; typ = typ_mapper; signature_item = signature_item_mapper; - value_bindings = Ast_tuple_pattern_flatten.value_bindings_mapper; + value_bindings = value_bindings_mapper; + value_bindings_rec = value_bindings_rec_mapper; structure_item = structure_item_mapper; structure = structure_mapper ~await_context:(ref (Hashtbl.create 10)); (* Ad-hoc way to internalize stuff *) diff --git a/compiler/ml/translattribute.ml b/compiler/ml/translattribute.ml index a5dbd2d9747..91314cfdcf3 100644 --- a/compiler/ml/translattribute.ml +++ b/compiler/ml/translattribute.ml @@ -52,11 +52,6 @@ let get_empty_attribute name attributes = (name, "This attribute does not accept a payload")); None -let reject_attribute name attributes = - match get_empty_attribute name attributes with - | Some loc -> Location.prerr_warning loc (Warnings.Misplaced_attribute name) - | None -> () - let parse_inline_attribute (attr : t option) : Lambda.inline_attribute = match attr with | None -> Default_inline diff --git a/compiler/ml/translattribute.mli b/compiler/ml/translattribute.mli index 992b323241b..bac456ba8d8 100644 --- a/compiler/ml/translattribute.mli +++ b/compiler/ml/translattribute.mli @@ -25,8 +25,6 @@ val get_inline_attribute : Parsetree.attributes -> Lambda.inline_attribute val get_empty_attribute : string -> Parsetree.attributes -> Location.t option -val reject_attribute : string -> Parsetree.attributes -> unit - val get_and_remove_inlined_attribute : Typedtree.expression -> Lambda.inline_attribute * Typedtree.expression diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index cec4f9435e3..0f038d70b42 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -246,33 +246,6 @@ let js_hoist_handler rootpath = {Lambda.binding = id; path = path @ [id.Ident.name]; loc} :: !js_hoisted) -let reject_js_hoisted_attribute attrs = - Translattribute.reject_attribute "res.hoistedFunction" attrs - -let reject_js_hoisted_structure_item = function - | Tstr_value _ -> () - | Tstr_eval (_, attrs) -> reject_js_hoisted_attribute attrs - | Tstr_primitive {val_attributes} -> - reject_js_hoisted_attribute val_attributes - | Tstr_type (_, declarations) -> - List.iter - (fun {typ_attributes} -> reject_js_hoisted_attribute typ_attributes) - declarations - | Tstr_typext {tyext_attributes} -> - reject_js_hoisted_attribute tyext_attributes - | Tstr_exception {ext_attributes} -> - reject_js_hoisted_attribute ext_attributes - | Tstr_module {mb_attributes} -> reject_js_hoisted_attribute mb_attributes - | Tstr_recmodule bindings -> - List.iter - (fun {mb_attributes} -> reject_js_hoisted_attribute mb_attributes) - bindings - | Tstr_modtype {mtd_attributes} -> reject_js_hoisted_attribute mtd_attributes - | Tstr_open {open_attributes} -> reject_js_hoisted_attribute open_attributes - | Tstr_include {incl_attributes} -> - reject_js_hoisted_attribute incl_attributes - | Tstr_attribute attr -> reject_js_hoisted_attribute [attr] - let rec remove_prefix prefix path = match (prefix, path) with | [], path -> Some path @@ -451,7 +424,6 @@ and transl_structure loc fields cc rootpath final_env = function List.length pos_cc_list ) | _ -> Misc.fatal_error "Translmod.transl_structure") | item :: rem -> ( - reject_js_hoisted_structure_item item.str_desc; match item.str_desc with | Tstr_eval (expr, _) -> let body, size = transl_structure loc fields cc rootpath final_env rem in diff --git a/compiler/ml/typemod.ml b/compiler/ml/typemod.ml index 0c204af7841..b35814fe62c 100644 --- a/compiler/ml/typemod.ml +++ b/compiler/ml/typemod.ml @@ -600,32 +600,6 @@ let check_recmod_typedecls env sdecls decls = (Mtype.type_paths env (Pident id) mty)) sdecls decls -let reject_js_hoisted_attribute attrs = - Translattribute.reject_attribute "res.hoistedFunction" attrs - -let reject_js_hoisted_signature_item = function - | Psig_value {pval_attributes} -> reject_js_hoisted_attribute pval_attributes - | Psig_type (_, declarations) -> - List.iter - (fun {ptype_attributes} -> reject_js_hoisted_attribute ptype_attributes) - declarations - | Psig_typext {ptyext_attributes} -> - reject_js_hoisted_attribute ptyext_attributes - | Psig_exception {pext_attributes} -> - reject_js_hoisted_attribute pext_attributes - | Psig_module {pmd_attributes} -> reject_js_hoisted_attribute pmd_attributes - | Psig_recmodule declarations -> - List.iter - (fun {pmd_attributes} -> reject_js_hoisted_attribute pmd_attributes) - declarations - | Psig_modtype {pmtd_attributes} -> - reject_js_hoisted_attribute pmtd_attributes - | Psig_open {popen_attributes} -> reject_js_hoisted_attribute popen_attributes - | Psig_include {pincl_attributes} -> - reject_js_hoisted_attribute pincl_attributes - | Psig_attribute attr -> reject_js_hoisted_attribute [attr] - | Psig_extension (_, attrs) -> reject_js_hoisted_attribute attrs - (* Auxiliaries for checking uniqueness of names in signatures and structures *) module String_set = Set.Make (struct @@ -777,7 +751,6 @@ and transl_signature env sg = | [] -> ([], [], env) | item :: srem -> ( let loc = item.psig_loc in - reject_js_hoisted_signature_item item.psig_desc; match item.psig_desc with | Psig_value sdesc -> let tdesc, newenv = diff --git a/tests/build_tests/super_errors/expected/hoisted_function_not_exportable.res.expected b/tests/build_tests/super_errors/expected/hoisted_function_not_exportable.res.expected index e073e15bf11..4cdd788a86c 100644 --- a/tests/build_tests/super_errors/expected/hoisted_function_not_exportable.res.expected +++ b/tests/build_tests/super_errors/expected/hoisted_function_not_exportable.res.expected @@ -1,16 +1,4 @@ - Warning number 53 - /.../fixtures/hoisted_function_not_exportable.res:36:3-22 - - 34 │ module MarkedModule = {} - 35 │ module type MarkedSignature = { - 36 │ @res.hoistedFunction - 37 │ let make: unit => unit - 38 │ } - - the @res.hoistedFunction attribute cannot appear in this context - - Warning number 32 /.../fixtures/hoisted_function_not_exportable.res:26:7-10 @@ -23,42 +11,6 @@ unused value make. - Warning number 53 - /.../fixtures/hoisted_function_not_exportable.res:29:1-20 - - 27 │ let make = () => "second" - 28 │ } - 29 │ @res.hoistedFunction - 30 │ type markedType = int - 31 │ @res.hoistedFunction - - the @res.hoistedFunction attribute cannot appear in this context - - - Warning number 53 - /.../fixtures/hoisted_function_not_exportable.res:31:1-20 - - 29 │ @res.hoistedFunction - 30 │ type markedType = int - 31 │ @res.hoistedFunction - 32 │ module type MarkedModule = {} - 33 │ @res.hoistedFunction - - the @res.hoistedFunction attribute cannot appear in this context - - - Warning number 53 - /.../fixtures/hoisted_function_not_exportable.res:33:1-20 - - 31 │ @res.hoistedFunction - 32 │ module type MarkedModule = {} - 33 │ @res.hoistedFunction - 34 │ module MarkedModule = {} - 35 │ module type MarkedSignature = { - - the @res.hoistedFunction attribute cannot appear in this context - - Warning number 53 /.../fixtures/hoisted_function_not_exportable.res:19:3-22 diff --git a/tests/build_tests/super_errors/expected/warning_101_bs_unused_attribute.res.expected b/tests/build_tests/super_errors/expected/warning_101_bs_unused_attribute.res.expected index 395cc146bc9..7fcb36fc443 100644 --- a/tests/build_tests/super_errors/expected/warning_101_bs_unused_attribute.res.expected +++ b/tests/build_tests/super_errors/expected/warning_101_bs_unused_attribute.res.expected @@ -8,4 +8,34 @@ Unused attribute: @as This attribute has no effect here. +For example, some attributes are only meaningful in externals. + + + + Warning number 101 (configured as error) + /.../fixtures/warning_101_bs_unused_attribute.res:4:1-20 + + 2 │ let x = 1 + 3 │ + 4 │ @res.hoistedFunction + 5 │ type t = int + 6 │ + + Unused attribute: @res.hoistedFunction +This attribute has no effect here. +For example, some attributes are only meaningful in externals. + + + + Warning number 101 (configured as error) + /.../fixtures/warning_101_bs_unused_attribute.res:8:14-33 + + 6 │ + 7 │ module ExpressionAttribute = { + 8 │ let make = @res.hoistedFunction () => () + 9 │ } + 10 │ + + Unused attribute: @res.hoistedFunction +This attribute has no effect here. For example, some attributes are only meaningful in externals. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/hoisted_function_not_exportable.res b/tests/build_tests/super_errors/fixtures/hoisted_function_not_exportable.res index 6c0e34854be..a4e0037fd3b 100644 --- a/tests/build_tests/super_errors/fixtures/hoisted_function_not_exportable.res +++ b/tests/build_tests/super_errors/fixtures/hoisted_function_not_exportable.res @@ -26,14 +26,4 @@ module Shadowed = { let make = () => "first" let make = () => "second" } -@res.hoistedFunction -type markedType = int -@res.hoistedFunction -module type MarkedModule = {} -@res.hoistedFunction -module MarkedModule = {} -module type MarkedSignature = { - @res.hoistedFunction - let make: unit => unit -} let after = () diff --git a/tests/build_tests/super_errors/fixtures/warning_101_bs_unused_attribute.res b/tests/build_tests/super_errors/fixtures/warning_101_bs_unused_attribute.res index 73dc385515a..2206888afd4 100644 --- a/tests/build_tests/super_errors/fixtures/warning_101_bs_unused_attribute.res +++ b/tests/build_tests/super_errors/fixtures/warning_101_bs_unused_attribute.res @@ -1,2 +1,9 @@ @as("foo") let x = 1 + +@res.hoistedFunction +type t = int + +module ExpressionAttribute = { + let make = @res.hoistedFunction () => () +} From d1900ac709ac71bf79820ef7ec2e48555506f482 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sun, 23 Aug 2026 11:26:55 +0200 Subject: [PATCH 11/12] Rely on final hoisted binding validation Signed-off-by: Christoph Knittel --- compiler/ml/translmod.ml | 61 ++----------------- ...isted_function_not_exportable.res.expected | 24 ++++---- 2 files changed, 16 insertions(+), 69 deletions(-) diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index 0f038d70b42..45e6a705a58 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -246,53 +246,6 @@ let js_hoist_handler rootpath = {Lambda.binding = id; path = path @ [id.Ident.name]; loc} :: !js_hoisted) -let rec remove_prefix prefix path = - match (prefix, path) with - | [], path -> Some path - | prefix :: prefixes, segment :: segments when prefix = segment -> - remove_prefix prefixes segments - | _ -> None - -let rec exported_by_coercion path coercion = - match path with - | [] -> true - | segment :: rest -> ( - match coercion with - | Tcoerce_none -> true - | Tcoerce_structure (fields, _, names) -> - let rec find fields names = - match (fields, names) with - | (_, coercion) :: fields, name :: names -> - if name = segment then exported_by_coercion rest coercion - else find fields names - | [], [] -> false - | _ -> assert false - in - find fields names - | Tcoerce_functor _ | Tcoerce_primitive _ | Tcoerce_alias _ -> false) - -let validate_js_hoisted_path prefix exported = - js_hoisted := - List.filter - (fun {Lambda.path; loc} -> - match remove_prefix prefix path with - | Some path when not (exported path) -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute "res.hoistedFunction"); - false - | Some _ | None -> true) - !js_hoisted - -let validate_js_hoisted prefix coercion = - match coercion with - | Tcoerce_none -> () - | _ -> - validate_js_hoisted_path prefix (fun path -> - exported_by_coercion path coercion) - -let reject_js_hoisted prefix = - validate_js_hoisted_path prefix (fun _path -> false) - let rec compile_functor mexp coercion root_path loc = let functor_param, body, body_path, res_coercion, inline_attribute = get_functor_params mexp coercion root_path @@ -333,11 +286,7 @@ and transl_module cc rootpath mexp = | Tmod_ident (path, _) -> apply_coercion loc Strict cc (Lambda.transl_module_path ~loc mexp.mod_env path) - | Tmod_structure str -> - let lam = fst (transl_struct loc [] cc rootpath str) in - Ext_option.iter (module_path rootpath) (fun path -> - validate_js_hoisted path cc); - lam + | Tmod_structure str -> fst (transl_struct loc [] cc rootpath str) | Tmod_functor _ -> compile_functor mexp cc rootpath loc | Tmod_apply (funct, arg, ccarg) -> let inlined_attribute, funct = @@ -474,10 +423,9 @@ and transl_structure loc fields cc rootpath final_env = function (if hidden then fields else id :: fields) cc rootpath final_env rem in - let module_rootpath = field_path rootpath id in - let module_body = transl_module Tcoerce_none module_rootpath mb.mb_expr in - if hidden then - Ext_option.iter (module_path module_rootpath) reject_js_hoisted; + let module_body = + transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr + in let module_body = Translattribute.add_inline_attribute module_body mb.mb_loc mb.mb_attributes @@ -546,7 +494,6 @@ let transl_implementation module_name (str, cc) = js_hoisted := []; let module_id = Ident.create_persistent module_name in let body, _ = transl_struct Location.none [] cc (global_path module_id) str in - validate_js_hoisted [] cc; { lambda = body; exports = !export_identifiers; diff --git a/tests/build_tests/super_errors/expected/hoisted_function_not_exportable.res.expected b/tests/build_tests/super_errors/expected/hoisted_function_not_exportable.res.expected index 4cdd788a86c..9d299b480aa 100644 --- a/tests/build_tests/super_errors/expected/hoisted_function_not_exportable.res.expected +++ b/tests/build_tests/super_errors/expected/hoisted_function_not_exportable.res.expected @@ -11,18 +11,6 @@ unused value make. - Warning number 53 - /.../fixtures/hoisted_function_not_exportable.res:19:3-22 - - 17 │ } - 18 │ %%private( - 19 │ @res.hoistedFunction - 20 │ let privateMake = () => () - 21 │ ) - - the @res.hoistedFunction attribute cannot appear in this context - - Warning number 53 /.../fixtures/hoisted_function_not_exportable.res:15:3-22 @@ -58,6 +46,18 @@ the @res.hoistedFunction attribute cannot appear in this context + Warning number 53 + /.../fixtures/hoisted_function_not_exportable.res:19:3-22 + + 17 │ } + 18 │ %%private( + 19 │ @res.hoistedFunction + 20 │ let privateMake = () => () + 21 │ ) + + the @res.hoistedFunction attribute cannot appear in this context + + Warning number 53 /.../fixtures/hoisted_function_not_exportable.res:25:3-22 From 4cc7110ae466b2142ec9d1f6bd561d5113902a0b Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sun, 23 Aug 2026 11:46:18 +0200 Subject: [PATCH 12/12] Fix playground Lambda debug output Signed-off-by: Christoph Knittel --- compiler/jsoo/jsoo_playground_main.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/compiler/jsoo/jsoo_playground_main.ml b/compiler/jsoo/jsoo_playground_main.ml index 2fffbd4b15f..2ca3db57251 100644 --- a/compiler/jsoo/jsoo_playground_main.ml +++ b/compiler/jsoo/jsoo_playground_main.ml @@ -549,15 +549,15 @@ module Compile = struct let typedtree = Printer.to_string Printtyped.implementation_with_coercion typed_tree in - let lambda = Printer.to_string Printlambda.lambda lam in - let lam, _ = Lam_convert.convert export_ident_sets lam in + let lambda_output = Printer.to_string Printlambda.lambda lambda in + let lam, _ = Lam_convert.convert export_ident_sets lambda in let lam = Lam_print.lambda_to_string lam in let debug_attrs = Js.Unsafe. [| ("parsetree", inject @@ Js.string parsetree); ("typedtree", inject @@ Js.string typedtree); - ("lambda", inject @@ Js.string lambda); + ("lambda", inject @@ Js.string lambda_output); ("lam", inject @@ Js.string lam); |] in