From 7667084ce91763072c99e83fa25c504cf354e142 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Tue, 3 Nov 2026 11:26:30 +0000 Subject: [PATCH 1/3] Copy a dependency's values when they are read Why: Forcing a dependency's components copied every value of its interface with the module path substitution, although a dependent reads only a few of them: on a 552-module app, about 5 % of the values of .cmi components are ever read. For the components of a .cmi signature as it was read, values are now table cells that make the copy on first read. Type ids are allocated in order and end up in .cmt files and in which nodes the backtracking trail logs, so the copies keep their ids: once the process has built the components of the same .cmi contents (same CRC) eagerly, it knows how many type ids each value takes, reserves them when the components are built and makes the copy with exactly those ids when the value is read. A copy that takes a different number is made again with fresh ids, like the deferred signature copies, and counted per domain for the tests. One-shot bsc and the first use of an interface in a build still build eagerly. Types, constructors, labels, extension constructors, module types, submodules and components of anything else (aliases, functor applications, local modules) are built as before. The tables of an open take the cells too: an open keeps a function giving the binding of each component, and the bindings Env.copy_types replaces through an open in a table checked before the components. Review: Can a deferred copy differ from the eager one apart from when it is made? The copied values are the unmarshalled .cmi signature, which the type checker never sees (it only gets copies), and the copy takes no stamps; the type ids are the eager ones, so every later stamp and id, and every operation on the copied nodes, is the same. The new unit tests compare marshalled results of eager and deferred components over every runtime interface, and whole requests (outputs, .cmt and error messages) using functors, aliases, include, module type of, recursive modules, shadowing and first-class modules, also on several domains at once. Review: Are the cells shared between requests or domains? No: components belong to the persistent structures of one request; only the count table is shared, behind a mutex, and its arrays are not changed once recorded. Signed-off-by: Jono Prest --- .../defer-dependency-value-copies.polish.md | 1 + compiler/ml/env.ml | 409 ++++++++--- compiler/ml/env.mli | 10 + .../ounit_deferred_components_tests.ml | 662 ++++++++++++++++++ tests/ounit_tests/ounit_tests_main.ml | 1 + 5 files changed, 991 insertions(+), 92 deletions(-) create mode 100644 changes/defer-dependency-value-copies.polish.md create mode 100644 tests/ounit_tests/ounit_deferred_components_tests.ml diff --git a/changes/defer-dependency-value-copies.polish.md b/changes/defer-dependency-value-copies.polish.md new file mode 100644 index 0000000000..411055da1a --- /dev/null +++ b/changes/defer-dependency-value-copies.polish.md @@ -0,0 +1 @@ +- Build: copy the values of a dependency's interface only when a module reads them, after the first use of the same interface in a build, instead of copying all of them when the module first uses the dependency. diff --git a/compiler/ml/env.ml b/compiler/ml/env.ml index 23c25c8173..52cd35102a 100644 --- a/compiler/ml/env.ml +++ b/compiler/ml/env.ml @@ -147,6 +147,31 @@ end module Path_map = Map.Make (Path) +(* A value of a module that is built when it is first read. See + [components_of_module_maker]. *) +module Comp_cell : sig + type 'a t + + val ready : 'a -> 'a t + val pending : (unit -> 'a) -> 'a t + val force : 'a t -> 'a +end = struct + type 'a t = {mutable state: 'a state} + and 'a state = Ready of 'a | Pending of (unit -> 'a) + + let ready x = {state = Ready x} + let pending f = {state = Pending f} + + (* If [f] raises, the cell stays pending and the exception is passed on. *) + let force c = + match c.state with + | Ready x -> x + | Pending f -> + let x = f () in + c.state <- Ready x; + x +end + module Tycomp_tbl = struct (** This module is used to store components of types (i.e. labels and constructors). We keep a representation of each nested @@ -236,37 +261,65 @@ module Id_tbl = struct (** Symbolic representation of the last (innermost) open, if any. *) } - and 'a opened = { - root: Path.t; - (** The path of the opened module, to be prefixed in front of - its local names to produce a valid path in the current - environment. *) - components: (string, 'a * int) Tbl.t; - (** Components from the opened module. *) - using: (string -> ('a * 'a) option -> unit) option; - (** A callback to be applied when a component is used from this - "open". This is used to detect unused "opens". The - arguments are used to detect shadowing. *) - next: 'a t; (** The table before opening the module. *) - } + and 'a opened = + | Opened : { + root: Path.t; + (** The path of the opened module, to be prefixed in front of + its local names to produce a valid path in the current + environment. *) + components: (string, 'b * int) Tbl.t; + (** Components from the opened module. *) + force: 'b -> 'a; (** Gives the binding a component stands for. *) + overrides: (string, 'a * int) Tbl.t; + (** Components replaced by [update], which take precedence over + [components]. *) + using: (string -> ('a * 'a) option -> unit) option; + (** A callback to be applied when a component is used from this + "open". This is used to detect unused "opens". The + arguments are used to detect shadowing. *) + next: 'a t; (** The table before opening the module. *) + } + -> 'a opened let empty = {current = Ident.empty; opened = None} let add id x tbl = {tbl with current = Ident.add id x tbl.current} - let add_open slot wrap root components next = + let add_open slot wrap root ~force components next = let using = match slot with | None -> None | Some f -> Some (fun s x -> f s (wrap x)) in - {current = Ident.empty; opened = Some {using; root; components; next}} + { + current = Ident.empty; + opened = + Some + (Opened {using; root; components; force; overrides = Tbl.empty; next}); + } + + (* The binding named [name] in an open, with its position. *) + let find_opened (type a) name (Opened o : a opened) : a * int = + match Tbl.find_str name o.overrides with + | found -> found + | exception Not_found -> + let desc, pos = Tbl.find_str name o.components in + (o.force desc, pos) + + (* Every binding of an open, as [find_opened] gives it. *) + let fold_opened (type a) f (Opened o : a opened) acc = + Tbl.fold + (fun name (desc, pos) acc -> + match Tbl.find_str name o.overrides with + | found -> f name found acc + | exception Not_found -> f name (o.force desc, pos) acc) + o.components acc let rec find_same id tbl = try Ident.find_same id tbl.current with Not_found as exn -> ( match tbl.opened with - | Some {next; _} -> find_same id next + | Some (Opened {next}) -> find_same id next | None -> raise exn) let rec find_name mark name tbl = @@ -275,9 +328,9 @@ module Id_tbl = struct (Pident id, desc) with Not_found as exn -> ( match tbl.opened with - | Some {using; root; next; components} -> ( + | Some (Opened {using; root; next} as opened) -> ( try - let descr, pos = Tbl.find_str name components in + let descr, pos = find_opened name opened in let res = (Pdot (root, name, pos), descr) in (if mark then match using with @@ -298,15 +351,14 @@ module Id_tbl = struct {tbl with current = Ident.add id new_desc tbl.current} with Not_found -> ( match tbl.opened with - | Some {root; using; next; components} -> ( - try - let desc, pos = Tbl.find_str name components in - let new_desc = f desc in - let components = Tbl.add name (new_desc, pos) components in - {tbl with opened = Some {root; using; next; components}} - with Not_found -> - let next = update name f next in - {tbl with opened = Some {root; using; next; components}}) + | Some (Opened o as opened) -> ( + match find_opened name opened with + | desc, pos -> + let overrides = Tbl.add name (f desc, pos) o.overrides in + {tbl with opened = Some (Opened {o with overrides})} + | exception Not_found -> + let next = update name f o.next in + {tbl with opened = Some (Opened {o with next})}) | None -> tbl) let rec find_all name tbl = @@ -316,11 +368,10 @@ module Id_tbl = struct @ match tbl.opened with | None -> [] - | Some {root; using = _; next; components} -> ( - try - let desc, pos = Tbl.find_str name components in - (Pdot (root, name, pos), desc) :: find_all name next - with Not_found -> find_all name next) + | Some (Opened {root; next} as opened) -> ( + match find_opened name opened with + | desc, pos -> (Pdot (root, name, pos), desc) :: find_all name next + | exception Not_found -> find_all name next) let rec fold_name f tbl acc = let acc = @@ -329,22 +380,23 @@ module Id_tbl = struct tbl.current acc in match tbl.opened with - | Some {root; using = _; next; components} -> + | Some (Opened {root; next} as opened) -> acc - |> Tbl.fold - (fun name (desc, pos) -> f name (Pdot (root, name, pos), desc)) - components + |> fold_opened + (fun name (desc, pos) acc -> + f name (Pdot (root, name, pos), desc) acc) + opened |> fold_name f next | None -> acc let rec iter f tbl = Ident.iter (fun id desc -> f id (Pident id, desc)) tbl.current; match tbl.opened with - | Some {root; using = _; next; components} -> - Tbl.iter - (fun s (x, pos) -> + | Some (Opened {root; next} as opened) -> + fold_opened + (fun s (x, pos) () -> f (Ident.hide (Ident.create s) (* ??? *)) (Pdot (root, s, pos), x)) - components; + opened (); iter f next | None -> () end @@ -372,10 +424,17 @@ type t = { and module_components = { deprecated: string option; loc: Location.t; - comps: - ( t * Subst.t * Path.t * Types.module_type, - module_components_repr option ) - Env_lazy.t; + comps: (components_maker_arg, module_components_repr option) Env_lazy.t; +} + +and components_maker_arg = { + maker_env: t; + maker_sub: Subst.t; + maker_path: Path.t; + maker_mty: Types.module_type; + maker_origin: Digest.t option; + (** The CRC of the .cmi whose signature [maker_mty] is part of, as read + from the file. [None] for any other module type. *) } and module_components_repr = @@ -385,7 +444,7 @@ and module_components_repr = and 'a comp_tbl = (string, 'a * int) Tbl.t and structure_components = { - mutable comp_values: value_description comp_tbl; + mutable comp_values: value_description Comp_cell.t comp_tbl; mutable comp_constrs: (string, constructor_description list) Tbl.t; mutable comp_labels: (string, label_description list) Tbl.t; mutable comp_types: (type_declaration * type_descriptions) comp_tbl; @@ -481,8 +540,9 @@ let without_cmis f x = let components_of_module' = ref - (fun ~deprecated:_ ~loc:_ _env _sub _path _mty -> assert false - : deprecated:string option -> + (fun ?origin:_ ~deprecated:_ ~loc:_ _env _sub _path _mty -> assert false + : ?origin:Digest.t -> + deprecated:string option -> loc:Location.t -> t -> Subst.t -> @@ -491,8 +551,8 @@ let components_of_module' = module_components) let components_of_module_maker' = ref - (fun (_env, _sub, _path, _mty) -> assert false - : t * Subst.t * Path.t * module_type -> module_components_repr option) + (fun _ -> assert false + : components_maker_arg -> module_components_repr option) let components_of_functor_appl' = ref (fun _f _env _p1 _p2 -> assert false @@ -736,7 +796,8 @@ let acknowledge_pers_struct check modname {Persistent_signature.filename; cmi} = None flags in let comps = - !components_of_module' ~deprecated ~loc:Location.none empty Subst.identity + !components_of_module' ?origin:(own_crc cmi) ~deprecated ~loc:Location.none + empty Subst.identity (Pident (Ident.create_persistent name)) (Mty_signature sign) in @@ -865,22 +926,25 @@ let rec find_module_descr path env = | Functor_comps f -> !components_of_functor_appl' f env p1 p2 | Structure_comps _ -> raise Not_found) -let find proj1 proj2 path env = +let find proj1 proj2 force path env = match path with | Pident id -> Id_tbl.find_same id (proj1 env) | Pdot (p, s, _pos) -> ( match get_components (find_module_descr p env) with | Structure_comps c -> let data, _pos = Tbl.find_str s (proj2 c) in - data + force data | Functor_comps _ -> raise Not_found) | Papply _ -> raise Not_found -let find_value = find (fun env -> env.values) (fun sc -> sc.comp_values) +let find_value = + find (fun env -> env.values) (fun sc -> sc.comp_values) Comp_cell.force -and find_type_full = find (fun env -> env.types) (fun sc -> sc.comp_types) +and find_type_full = + find (fun env -> env.types) (fun sc -> sc.comp_types) Fun.id -and find_modtype = find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) +and find_modtype = + find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) Fun.id let type_of_cstr path = function | {cstr_inlined = Some d; _} -> @@ -1151,7 +1215,7 @@ and lookup_module ~load ?loc lid env : Path.t = p | Functor_comps _ -> raise Not_found) -let lookup proj1 proj2 ?loc lid env = +let lookup proj1 proj2 force ?loc lid env = match lid with | Lident s -> Id_tbl.find_name s (proj1 env) | Ldot (l, s) -> ( @@ -1159,7 +1223,7 @@ let lookup proj1 proj2 ?loc lid env = match get_components desc with | Structure_comps c -> let data, pos = Tbl.find_str s (proj2 c) in - (Pdot (p, s, pos), data) + (Pdot (p, s, pos), force data) | Functor_comps _ -> raise Not_found) let lookup_all_simple proj1 proj2 shadow ?loc lid env = @@ -1190,7 +1254,8 @@ let cstr_shadow cstr1 cstr2 = let lbl_shadow _lbl1 _lbl2 = false -let lookup_value = lookup (fun env -> env.values) (fun sc -> sc.comp_values) +let lookup_value = + lookup (fun env -> env.values) (fun sc -> sc.comp_values) Comp_cell.force let lookup_all_constructors = lookup_all_simple (fun env -> env.constrs) @@ -1201,9 +1266,9 @@ let lookup_all_labels = (fun env -> env.labels) (fun sc -> sc.comp_labels) lbl_shadow -let lookup_type = lookup (fun env -> env.types) (fun sc -> sc.comp_types) +let lookup_type = lookup (fun env -> env.types) (fun sc -> sc.comp_types) Fun.id let lookup_modtype = - lookup (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) + lookup (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) Fun.id let copy_types l env = let f desc = @@ -1348,21 +1413,23 @@ let rec scrape_alias_for_visit env mty = with Not_found -> false) | _ -> true -let iter_env proj1 proj2 f env () = +let iter_env proj1 proj2 force f env () = Id_tbl.iter (fun id x -> f (Pident id) x) (proj1 env); let rec iter_components path path' mcomps = let cont () = let visit = match Env_lazy.get_arg mcomps.comps with | None -> true - | Some (env, _sub, _path, mty) -> scrape_alias_for_visit env mty + | Some {maker_env; maker_mty} -> + scrape_alias_for_visit maker_env maker_mty in if not visit then () else match get_components mcomps with | Structure_comps comps -> Tbl.iter - (fun s (d, n) -> f (Pdot (path, s, n)) (Pdot (path', s, n), d)) + (fun s (d, n) -> + f (Pdot (path, s, n)) (Pdot (path', s, n), force d)) (proj2 comps); Tbl.iter (fun s (c, n) -> @@ -1391,7 +1458,8 @@ let run_iter_cont l = iter_env_cont () := []; cont -let iter_types f = iter_env (fun env -> env.types) (fun sc -> sc.comp_types) f +let iter_types f = + iter_env (fun env -> env.types) (fun sc -> sc.comp_types) Fun.id f let same_types env1 env2 = env1.types == env2.types && env1.components == env2.components @@ -1403,14 +1471,13 @@ let used_persistent () = (persistent_structures ()); !r -let find_all_comps proj s (p, mcomps) = +let find_all_comps proj force s (p, mcomps) = match get_components mcomps with | Functor_comps _ -> [] | Structure_comps comps -> ( - try - let c, n = Tbl.find_str s (proj comps) in - [(Pdot (p, s, n), c)] - with Not_found -> []) + match Tbl.find_str s (proj comps) with + | c, n -> [(Pdot (p, s, n), force c)] + | exception Not_found -> []) let rec find_shadowed_comps path env = match path with @@ -1418,17 +1485,17 @@ let rec find_shadowed_comps path env = | Pdot (p, s, _) -> let l = find_shadowed_comps p env in let l' = - List.map (find_all_comps (fun comps -> comps.comp_components) s) l + List.map (find_all_comps (fun comps -> comps.comp_components) Fun.id s) l in List.flatten l' | Papply _ -> [] -let find_shadowed proj1 proj2 path env = +let find_shadowed proj1 proj2 force path env = match path with | Pident id -> Id_tbl.find_all (Ident.name id) (proj1 env) | Pdot (p, s, _) -> let l = find_shadowed_comps p env in - let l' = List.map (find_all_comps proj2 s) l in + let l' = List.map (find_all_comps proj2 force s) l in List.flatten l' | Papply _ -> [] @@ -1437,7 +1504,7 @@ let find_shadowed_types path env = (find_shadowed (fun env -> env.types) (fun comps -> comps.comp_types) - path env) + Fun.id path env) (* GADT instance tracking *) @@ -1634,10 +1701,102 @@ let add_to_tbl id decl tbl = let decls = try Tbl.find_str id tbl with Not_found -> [] in Tbl.add id (decl :: decls) tbl -let rec components_of_module ~deprecated ~loc env sub path mty = - {deprecated; loc; comps = Env_lazy.create (env, sub, path, mty)} +(* Deferred components of persistent structures. + + Building the components of a module copies every value of its signature + with the module's path substitution, although a dependent usually reads + only a few of them. In the signature of a .cmi file as it was read (whose + CRC is [maker_origin]), the values are therefore copied when they are first + read instead, once the process has built the same + components eagerly once and knows how many type ids each item takes (the + copies take no stamps). The type ids an item would have taken when the + components are built are reserved for it, so every later type id is the + same as if it had been copied at once, and the copy is made with exactly + those ids when it is read. If a deferred copy ever takes a different number + of ids, it is thrown away and made again with fresh ones. + + The items of a .cmi signature are not changed before they are copied: the + type checker only sees copies of them. The other items (types with their + constructors and labels, extension constructors, module types, submodules) + are still built at once. *) + +let component_counts : (Digest.t * string, int array) Hashtbl.t = + Hashtbl.create 64 +let component_counts_lock = Mutex.create () + +let with_component_counts_lock f = + Mutex.lock component_counts_lock; + Fun.protect ~finally:(fun () -> Mutex.unlock component_counts_lock) f + +let find_component_counts key = + with_component_counts_lock (fun () -> Hashtbl.find_opt component_counts key) + +let record_component_counts key counts = + with_component_counts_lock (fun () -> + if Hashtbl.length component_counts >= 65536 then + Hashtbl.reset component_counts; + Hashtbl.replace component_counts key counts) + +(* How many items were deferred, and how many deferred copies were made again + with fresh ids, on this domain. Domain-local so that the counts cost no + shared writes; only tests read them. *) +type deferred_component_stats = {mutable deferred: int; mutable fallbacks: int} + +let deferred_component_stats_key = + Domain.DLS.new_key (fun () -> {deferred = 0; fallbacks = 0}) + +let deferred_component_stats () = + let stats = Domain.DLS.get deferred_component_stats_key in + (stats.deferred, stats.fallbacks) + +let forget_component_counts () = + with_component_counts_lock (fun () -> Hashtbl.reset component_counts) + +(* Run [compute] with the [count] type ids from [base], which were reserved + for it. *) +let with_reserved_type_ids ~base ~count compute = + let state = Compiler_request_state.current () in + let saved = state.type_node_id in + let stamp0 = Ident.current_time () in + state.type_node_id <- base; + match compute () with + | result -> + let type_end = state.type_node_id in + state.type_node_id <- saved; + if type_end = base + count && Ident.current_time () = stamp0 then result + else + (* Some of the ids may also belong to later type nodes: copy again with + fresh ones. *) + let stats = Domain.DLS.get deferred_component_stats_key in + stats.fallbacks <- stats.fallbacks + 1; + compute () + | exception exn -> + state.type_node_id <- saved; + raise exn -and components_of_module_maker (env, sub, path, mty) = +let rec components_of_module ?origin ~deprecated ~loc env sub path mty = + { + deprecated; + loc; + comps = + Env_lazy.create + { + maker_env = env; + maker_sub = sub; + maker_path = path; + maker_mty = mty; + maker_origin = origin; + }; + } + +and components_of_module_maker + { + maker_env = env; + maker_sub = sub; + maker_path = path; + maker_mty = mty; + maker_origin; + } = match scrape_alias env mty with | Mty_signature (_ :: _ as sg) when is_alias_map sg -> Some (alias_map_components env sub path sg) @@ -1653,14 +1812,67 @@ and components_of_module_maker (env, sub, path, mty) = comp_components = Tbl.empty; } in + (* [origin] is set when [sg] is part of a .cmi signature as it was read. *) + let origin = + match mty with + | Mty_signature _ -> maker_origin + | Mty_ident _ | Mty_alias _ | Mty_functor _ -> None + in + let key = Option.map (fun crc -> (crc, Path.name path)) origin in + let state = Compiler_request_state.current () in + let item_count = List.length sg in + let counts = + match Option.bind key find_component_counts with + | Some counts + when Array.length counts = item_count + && List.for_all2 + (fun item count -> + match item with + | Sig_value _ -> count >= 0 + | Sig_type _ | Sig_typext _ | Sig_module _ | Sig_modtype _ + -> + true) + sg (Array.to_list counts) -> + (* The counts fit this signature: one for every value. *) + Some counts + | Some _ | None -> None + in + (* The type ids each value takes, when the counts of these + components are not known yet. *) + let recorded = + match (key, counts) with + | Some _, None -> Some (Array.make item_count (-1)) + | _ -> None + in + let stamps_taken = ref false in + let deferred = ref 0 in + let make_cell index compute = + match (counts, recorded) with + | Some counts, _ -> + let base = state.type_node_id and count = counts.(index) in + state.type_node_id <- base + count; + incr deferred; + Comp_cell.pending (fun () -> + with_reserved_type_ids ~base ~count compute) + | None, Some recorded -> + let type0 = state.type_node_id and stamp0 = Ident.current_time () in + let result = compute () in + recorded.(index) <- state.type_node_id - type0; + if Ident.current_time () <> stamp0 then stamps_taken := true; + Comp_cell.ready result + | None, None -> Comp_cell.ready (compute ()) + in let pl, sub = prefix_idents path sub sg in let env = ref env in let pos = ref 0 in + let index = ref 0 in List.iter2 (fun item path -> - match item with + (match item with | Sig_value (id, decl) -> ( - let decl' = Subst.value_description sub decl in + let decl' = + make_cell !index (fun () -> Subst.value_description sub decl) + in c.comp_values <- Tbl.add (Ident.name id) (decl', !pos) c.comp_values; match decl.val_kind with | Val_prim _ -> () @@ -1697,8 +1909,8 @@ and components_of_module_maker (env, sub, path, mty) = Builtin_attributes.deprecated_of_attrs md.md_attributes in let comps = - components_of_module ~deprecated ~loc:md.md_loc !env sub path - md.md_type + components_of_module ?origin ~deprecated ~loc:md.md_loc !env sub + path md.md_type in c.comp_components <- Tbl.add (Ident.name id) (comps, !pos) c.comp_components; @@ -1708,8 +1920,16 @@ and components_of_module_maker (env, sub, path, mty) = let decl' = Subst.modtype_declaration sub decl in c.comp_modtypes <- Tbl.add (Ident.name id) (decl', nopos) c.comp_modtypes; - env := store_modtype id decl !env) + env := store_modtype id decl !env); + incr index) sg pl; + (if !deferred > 0 then + let stats = Domain.DLS.get deferred_component_stats_key in + stats.deferred <- stats.deferred + !deferred); + (match (key, recorded) with + | Some key, Some recorded when not !stamps_taken -> + record_component_counts key recorded + | _ -> ()); Some (Structure_comps c) | Mty_functor (param, _ty_arg, ty_res) -> Some @@ -1988,23 +2208,27 @@ let rec add_signature sg env = let add_components slot root env0 comps = let add_l w comps env0 = Tycomp_tbl.add_open slot w comps env0 in - let add w comps env0 = Id_tbl.add_open slot w root comps env0 in + let add w force comps env0 = Id_tbl.add_open slot w root ~force comps env0 in let constrs = add_l (fun x -> `Constructor x) comps.comp_constrs env0.constrs in let labels = add_l (fun x -> `Label x) comps.comp_labels env0.labels in - let values = add (fun x -> `Value x) comps.comp_values env0.values in - let types = add (fun x -> `Type x) comps.comp_types env0.types in + let values = + add (fun x -> `Value x) Comp_cell.force comps.comp_values env0.values + in + let types = add (fun x -> `Type x) Fun.id comps.comp_types env0.types in let modtypes = - add (fun x -> `Module_type x) comps.comp_modtypes env0.modtypes + add (fun x -> `Module_type x) Fun.id comps.comp_modtypes env0.modtypes in let components = - add (fun x -> `Component x) comps.comp_components env0.components + add (fun x -> `Component x) Fun.id comps.comp_components env0.components in - let modules = add (fun x -> `Module x) comps.comp_modules env0.modules in + let modules = + add (fun x -> `Module x) Fun.id comps.comp_modules env0.modules + in {env0 with constrs; labels; values; types; modtypes; components; modules} @@ -2122,7 +2346,7 @@ let save_signature ?check_exists ~deprecated sg modname filename = (* Folding on environments *) -let find_all proj1 proj2 f lid env acc = +let find_all proj1 proj2 force f lid env acc = match lid with | None -> Id_tbl.fold_name @@ -2133,7 +2357,7 @@ let find_all proj1 proj2 f lid env acc = match get_components desc with | Structure_comps c -> Tbl.fold - (fun s (data, pos) acc -> f s (Pdot (p, s, pos)) data acc) + (fun s (data, pos) acc -> f s (Pdot (p, s, pos)) (force data) acc) (proj2 c) acc | Functor_comps _ -> acc) @@ -2183,7 +2407,7 @@ let fold_modules f lid env acc = | Functor_comps _ -> acc) let fold_values f = - find_all (fun env -> env.values) (fun sc -> sc.comp_values) f + find_all (fun env -> env.values) (fun sc -> sc.comp_values) Comp_cell.force f and fold_constructors f = find_all_simple_list (fun env -> env.constrs) (fun sc -> sc.comp_constrs) f @@ -2191,10 +2415,11 @@ and fold_constructors f = and fold_labels f = find_all_simple_list (fun env -> env.labels) (fun sc -> sc.comp_labels) f -and fold_types f = find_all (fun env -> env.types) (fun sc -> sc.comp_types) f +and fold_types f = + find_all (fun env -> env.types) (fun sc -> sc.comp_types) Fun.id f and fold_modtypes f = - find_all (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) f + find_all (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) Fun.id f (* Make the initial environment *) (* The initial environment contains mutable type graphs. Each compiler domain diff --git a/compiler/ml/env.mli b/compiler/ml/env.mli index 895090bbad..d206c95350 100644 --- a/compiler/ml/env.mli +++ b/compiler/ml/env.mli @@ -174,6 +174,16 @@ val deferred_signature_copy_stats : unit -> int * int them and were made again with fresh ones (expected: none), in the process so far. *) +val deferred_component_stats : unit -> int * int +(* For tests: how many values of compilation units' components were + left to be copied when first read, and how many of those copies did not take + the type ids reserved for them and were made again with fresh ones + (expected: none), on the calling domain so far. *) + +val forget_component_counts : unit -> unit +(* For tests: build the components of every compilation unit at once again + (and learn their counts), as when the process has not built them before. *) + val save_signature : ?check_exists:unit -> deprecated:string option -> diff --git a/tests/ounit_tests/ounit_deferred_components_tests.ml b/tests/ounit_tests/ounit_deferred_components_tests.ml new file mode 100644 index 0000000000..0014957c3f --- /dev/null +++ b/tests/ounit_tests/ounit_deferred_components_tests.ml @@ -0,0 +1,662 @@ +(* The values of a compilation unit's components are copied when + they are first read, once the process knows how many type ids each of them + takes; the ids are reserved when the components are built. These tests check + that reading them later, in another order or never, gives exactly the type + ids, stamps and graphs of components built at once, both directly through + [Env] on every runtime interface and through whole compiler requests that + use dependencies through functors, aliases, includes, module type of, + recursive modules, shadowing, first-class modules and error messages. *) + +open OUnit + +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) + +let runtime_dir () = + Filename.concat (Runtime_package.get_path ()) "lib/rescript" + +let probe () = + (Ident.binding_time (Ident.create "probe"), (Btype.newgenvar ()).Types.id) + +let in_fresh_request dirs action = + Compiler_request_state.with_fresh (fun () -> + Request_local.with_fresh (fun () -> + Ident.with_fresh (fun () -> + Config.set_load_path dirs; + action ()))) + +(* What reading one item of a signature gives. *) +type read = + | Value of Path.t * Types.value_description + | Type of + Path.t + * Types.type_declaration + * Env.type_descriptions + * Types.constructor_description list list + * Types.label_description list list + | Module of string * read list + | Missing of string + +(* Read the items of [sg], the signature of module [lid], from the last to + the first, and the submodules declared with a signature recursively. *) +let rec read_signature env lid sg = + List.fold_left + (fun acc item -> read_item env lid item :: acc) + [] (List.rev sg) + |> List.rev + +and read_item env lid item = + let field name = Longident.Ldot (lid, name) in + match item with + | Types.Sig_value (id, _) -> ( + match Env.lookup_value (field (Ident.name id)) env with + | path, decl -> Value (path, decl) + | exception Not_found -> Missing (Ident.name id)) + | Sig_type (id, decl, _) -> ( + match Env.lookup_type (field (Ident.name id)) env with + | path -> + let constructors = + match decl.type_kind with + | Type_variant (cds, _) -> + List.map + (fun (cd : Types.constructor_declaration) -> + List.map fst + (Env.lookup_all_constructors (field (Ident.name cd.cd_id)) env)) + cds + | Type_record _ | Type_abstract | Type_open -> [] + in + let labels = + match decl.type_kind with + | Type_record (lds, _) -> + List.map + (fun (ld : Types.label_declaration) -> + List.map fst + (Env.lookup_all_labels (field (Ident.name ld.ld_id)) env)) + lds + | Type_variant _ | Type_abstract | Type_open -> [] + in + Type + ( path, + Env.find_type path env, + Env.find_type_descrs path env, + constructors, + labels ) + | exception Not_found -> Missing (Ident.name id)) + | Sig_module (id, {md_type = Mty_signature sg}, _) -> + Module (Ident.name id, read_signature env (field (Ident.name id)) sg) + | Sig_module (id, _, _) | Sig_modtype (id, _) | Sig_typext (id, _, _) -> + Missing (Ident.name id) + +let runtime_units dir = + Sys.readdir dir |> Array.to_list + |> List.filter (fun file -> Filename.check_suffix file ".cmi") + |> List.map (fun file -> + let cmi = Cmi_format.read_cmi (Filename.concat dir file) in + (cmi.cmi_name, cmi.cmi_sign)) + |> List.sort (fun (a, _) (b, _) -> String.compare a b) + +(* Build the components of every unit, creating an identifier and a type node + after each, then read every item of every unit from the last unit to the + first. The result is marshalled: equal strings mean equal stamps, type ids + and sharing. *) +let read_all_units dir units = + in_fresh_request [dir] (fun () -> + let env = Env.empty in + let built = + List.map + (fun (name, _) -> + (match + Env.lookup_value + (Longident.Ldot (Lident name, "not a component")) + env + with + | _ -> assert_failure "no such value" + | exception Not_found -> ()); + probe ()) + units + in + let read = + List.fold_left + (fun acc (name, sg) -> + (name, read_signature env (Longident.Lident name) sg) :: acc) + [] (List.rev units) + in + Marshal.to_string (built, read, probe ()) []) + +let deferred_matches_eager_tests _ = + let dir = runtime_dir () in + let units = runtime_units dir in + assert_bool "runtime interfaces found" (List.length units > 50); + Env.forget_component_counts (); + let deferred_before, fallbacks_before = Env.deferred_component_stats () in + let eager = read_all_units dir units in + let deferred_eager, _ = Env.deferred_component_stats () in + assert_equal ~printer:string_of_int ~msg:"nothing deferred before the counts" + deferred_before deferred_eager; + let deferred = read_all_units dir units in + let deferred_after, fallbacks_after = Env.deferred_component_stats () in + assert_bool "values were deferred" (deferred_after > deferred_eager); + assert_equal ~printer:string_of_int + ~msg:"every deferred copy took exactly its reserved type ids" + fallbacks_before fallbacks_after; + assert_bool + "deferred copies give the same stamps, type ids and graphs as eager ones" + (String.equal eager deferred) + +(* Components whose values are never read still take their type ids. *) +let unread_components_tests _ = + let dir = runtime_dir () in + let names = ["Stdlib_Array"; "Stdlib_List"; "Stdlib_Option"; "Stdlib"] in + let build_only () = + in_fresh_request [dir] (fun () -> + List.map + (fun name -> + (match + Env.lookup_value + (Longident.Ldot (Lident name, "not a component")) + Env.empty + with + | _ -> assert_failure "no such value" + | exception Not_found -> ()); + probe ()) + names) + in + Env.forget_component_counts (); + let eager = build_only () in + assert_equal eager (build_only ()) + +(* A compilation unit [Forged] whose .cmi claims the CRC of different + contents. *) +let value name val_type = + Types.Sig_value + ( Ident.create name, + { + val_type; + val_kind = Val_reg; + val_loc = Location.none; + val_attributes = []; + } ) + +let forged_crc = Digest.string "ounit_deferred_components_tests forged crc" + +let with_forged_unit sign action = + let cmi = + { + Cmi_format.cmi_name = "Forged"; + cmi_sign = sign; + cmi_crcs = [("Forged", Some forged_crc)]; + cmi_flags = []; + } + in + let saved_load = !Env.Persistent_signature.load in + (Env.Persistent_signature.load := + fun ~unit_name -> + if unit_name = "Forged" then + Some {Env.Persistent_signature.filename = "Forged.cmi"; cmi} + else saved_load ~unit_name); + Fun.protect + ~finally:(fun () -> Env.Persistent_signature.load := saved_load) + (fun () -> in_fresh_request [] action) + +let forged = Longident.Lident "Forged" + +let build_forged () = + match + Env.lookup_value (Longident.Ldot (forged, "not a component")) Env.empty + with + | _ -> assert_failure "no such value" + | exception Not_found -> () + +let read_forged name = + snd (Env.lookup_value (Longident.Ldot (forged, name)) Env.empty) + +(* Learn that the value [x] of [Forged] takes one type id. *) +let learn_forged_counts () = + with_forged_unit + [value "x" (Predef.type_int ())] + (fun () -> ignore (read_forged "x")) + +(* The counts learnt from the first contents are wrong for the second: the + deferred copy takes more type ids than were reserved, and is made again with + fresh ones. *) +let count_mismatch_fallback_tests _ = + learn_forged_counts (); + let deferred_before, fallbacks_before = Env.deferred_component_stats () in + let probe_id, copy_id = + with_forged_unit + [ + value "x" + (Btype.newgenty (Ttuple [Predef.type_int (); Predef.type_int ()])); + ] + (fun () -> + build_forged (); + let _, probe_id = probe () in + (probe_id, (read_forged "x").val_type.id)) + in + let deferred_after, fallbacks_after = Env.deferred_component_stats () in + assert_equal ~printer:string_of_int ~msg:"the copy was deferred" + (deferred_before + 1) deferred_after; + assert_equal ~printer:string_of_int ~msg:"the copy fell back" + (fallbacks_before + 1) fallbacks_after; + assert_bool "the fallback copy has fresh type ids" (copy_id > probe_id) + +(* Counts learnt from contents with a module type where the second contents + have a value (same CRC, same number of items) do not fit them: the + components are built at once instead of reserving from a missing count, and + every value gets its own type ids. *) +let counts_without_value_slot_tests _ = + let module_type name = + Types.Sig_modtype + ( Ident.create name, + {mtd_type = None; mtd_attributes = []; mtd_loc = Location.none} ) + in + with_forged_unit + [value "x" (Predef.type_int ()); module_type "M"] + (fun () -> ignore (read_forged "x")); + let deferred_before, _ = Env.deferred_component_stats () in + let x_id, y_id, probe_id = + with_forged_unit + [value "x" (Predef.type_int ()); value "y" (Predef.type_int ())] + (fun () -> + build_forged (); + let _, probe_id = probe () in + ((read_forged "x").val_type.id, (read_forged "y").val_type.id, probe_id)) + in + let deferred_after, _ = Env.deferred_component_stats () in + assert_equal ~printer:string_of_int ~msg:"nothing was deferred" + deferred_before deferred_after; + assert_bool "every value has its own type ids, taken when built" + (x_id <> y_id && x_id < probe_id && y_id < probe_id) + +(* A deferred copy that raises puts the type id and stamp counters back and + stays to be made: reading it again raises again. *) +let raising_copy_tests _ = + learn_forged_counts (); + (* A variant type whose row ends in a tuple: copying it fails. *) + let broken = + Btype.newgenty + (Tvariant + { + row_fields = []; + row_more = Btype.newgenty (Ttuple []); + row_closed = true; + row_fixed = false; + row_name = None; + }) + in + with_forged_unit + [value "x" broken] + (fun () -> + build_forged (); + let stamp, id = probe () in + let read_raises () = + match read_forged "x" with + | _ -> assert_failure "the copy should have raised" + | exception Assert_failure _ -> () + in + read_raises (); + assert_equal ~msg:"counters put back after the failed copy" + (stamp + 1, id + 1) + (probe ()); + read_raises (); + assert_equal ~msg:"counters put back after the second failed copy" + (stamp + 2, id + 2) + (probe ())) + +(* [Env.copy_types] replaces values bound by an open: the replaced ones are + copies, the others stay as they were, and every way of reading the open + sees the replacements. *) +let copy_types_in_open_tests _ = + let dir = runtime_dir () in + in_fresh_request [dir] (fun () -> + let env = + match + Env.open_signature Asttypes.Fresh + (Path.Pident (Ident.create_persistent "Stdlib_Array")) + Env.empty + with + | Some env -> env + | None -> assert_failure "Stdlib_Array opens" + in + let value env name = snd (Env.lookup_value (Longident.Lident name) env) in + let names = ["length"; "map"; "reduce"] in + let before = List.map (value env) names in + let other_before = value env "concat" in + let copied = Env.copy_types names env in + let copied_twice = Env.copy_types ["map"] copied in + List.iter2 + (fun name (decl : Types.value_description) -> + let decl' = value copied name in + assert_bool (name ^ " is a copy") (decl'.val_type != decl.val_type); + assert_bool + (name ^ " is the same type") + (Ctype.equal Env.empty true [decl.val_type] [decl'.val_type])) + names before; + assert_bool "values not named are not copied" + (value copied "concat" == other_before); + assert_bool "the original environment is unchanged" + (value env "length" == List.hd before); + assert_bool "a second copy copies the first one" + ((value copied_twice "map").val_type != (value copied "map").val_type); + assert_bool "the second copy keeps the other copies" + (value copied_twice "length" == value copied "length"); + let folded = + Env.fold_values + (fun name _ decl acc -> if name = "length" then decl :: acc else acc) + None copied [] + in + assert_bool "folding sees the copy" + (List.exists (fun decl -> decl == value copied "length") folded); + assert_bool "folding does not see the original" + (not (List.exists (fun decl -> decl == List.hd before) folded))) + +(* Whole compiler requests *) + +let rec ensure_dir path = + if not (Sys.file_exists path) then ( + ensure_dir (Filename.dirname path); + try Unix.mkdir path 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ()) + +let write_file path contents = + ensure_dir (Filename.dirname path); + let channel = open_out_bin path in + Fun.protect + ~finally:(fun () -> close_out_noerr channel) + (fun () -> output_string channel contents) + +let read_file path = + let channel = open_in_bin path in + Fun.protect + ~finally:(fun () -> close_in_noerr channel) + (fun () -> really_input_string channel (in_channel_length channel)) + +let rec remove_tree path = + match (Unix.lstat path).st_kind with + | Unix.S_DIR -> + Array.iter + (fun name -> remove_tree (Filename.concat path name)) + (Sys.readdir path); + Unix.rmdir path + | _ -> Sys.remove path + | exception Unix.Unix_error (Unix.ENOENT, _, _) -> () + +let with_temp_dir action = + let path = Filename.temp_file "deferred-components-" "" in + Sys.remove path; + Unix.mkdir path 0o755; + let path = Unix.realpath path in + Fun.protect ~finally:(fun () -> remove_tree path) (fun () -> action path) + +let dep_source = + {|type color = Red | Green | Blue(int) +type point = {x: int, y: int, label?: string} +type rec tree = Leaf | Node(tree, int, tree) +type box<'a> = {items: array<'a>, count: int} +type poly = [#a | #b(int)] +type inline = Inline({name: string, age: int}) +exception Failed(string) +type ext = .. +type ext += Extended(int) +let origin = {x: 0, y: 0} +let make = items => {items, count: Array.length(items)} +let colorName = c => + switch c { + | Red => "red" + | Green => "green" + | Blue(n) => Int.toString(n) + } +module type Show = { + type t + let show: t => string +} +module IntShow: Show with type t = int = { + type t = int + let show = n => Int.toString(n) +} +module MakeShow = (S: Show) => { + let showAll = xs => Array.map(xs, S.show) +} +module Nested = { + type inner = {value: int} + let unused = 1 + module Deep = { + let deep = 42 + type d = D(inner) + } +} +module Alias = Nested +module rec Even: { + let even: int => bool +} = { + let even = n => n == 0 || Odd.odd(n - 1) +} +and Odd: { + let odd: int => bool +} = { + let odd = n => n != 0 && Even.even(n - 1) +} +let shadowed = 1 +let shadowed = "now a string" +module type OfNested = module type of Nested +let packed: module(Show with type t = int) = module(IntShow) +|} + +let main_source = + {|open Dep +let c = Blue(3) +let p = {x: 1, y: 2} +let q = {...origin, label: "q"} +let n = colorName(c) +let tr = Node(Leaf, 1, Leaf) +let w = make([1, 2]) +let v: poly = #b(1) +let i = Inline({name: "a", age: 1}) +let e = Extended(2) +module S = MakeShow(IntShow) +let shown = S.showAll([1, 2]) +module A = Dep.Alias +let deep = A.Deep.deep +let d = A.Deep.D({value: 3}) +include Dep.Nested.Deep +module M: OfNested = Dep.Nested +let even = Even.even(4) +let s: string = shadowed +module P = unpack(packed) +let shownP = P.show(3) +let first = (module(IntShow): module(Show with type t = int)) +let raised = try throw(Failed("x")) catch { + | Failed(s) => s + } +let arr = Array.map([1, 2], x => x + 1) +let opt = Option.map(Some(1), x => x) +let red = Dep.Red +|} + +(* Each of these fails with a message that prints types of dependencies. *) +let error_sources = + [ + ("ErrRecord.res", {|let p: Dep.point = {x: 1, y: "2"}|}); + ("ErrConstructor.res", {|let c: Dep.tree = Dep.Blue(1)|}); + ("ErrInline.res", {|let i = Dep.Inline({name: 1, age: 1})|}); + ("ErrLabel.res", {|let p: Dep.point = {x: 1, z: 2}|}); + ("ErrFunctor.res", {|module S = Dep.MakeShow(Dep.Nested)|}); + ("ErrAlias.res", {|let i: int = Dep.Alias.Deep.D({value: 1})|}); + ("ErrStdlib.res", {|let x: int = Array.map([1], x => x)|}); + ("ErrPacked.res", {|let x: string = Dep.packed|}); + ("ErrInclude.res", {|include Dep.Nested +let y: string = unused|}); + ] + +let request root input = + let argv = + [ + "-nostdlib"; + "-I"; + runtime_dir (); + "-I"; + root; + "-bs-project-root"; + root; + "-bs-package-name"; + "deferred-components-test"; + "-bs-package-output"; + "commonjs:.:.js"; + "-bs-no-version-header"; + ] + in + Rescript_compiler_driver.run_request ~run_external:None ~cwd:root ~argv ~input + +let outputs root base = + List.filter_map + (fun ext -> + let path = Filename.concat root (base ^ ext) in + if Sys.file_exists path then Some (ext, read_file path) else None) + [".js"; ".cmi"; ".cmj"; ".cmt"] + +(* What compiling [input] gives: exit code, diagnostics and every output. *) +let compile root input = + let base = Filename.remove_extension input in + List.iter + (fun (ext, _) -> Sys.remove (Filename.concat root (base ^ ext))) + (outputs root base); + let result = request root input in + (result.Rescript_compiler_driver.exit_code, result.stderr, outputs root base) + +let setup root = + write_file (Filename.concat root "Dep.res") dep_source; + write_file (Filename.concat root "Main.res") main_source; + List.iter + (fun (name, source) -> write_file (Filename.concat root name) source) + error_sources; + let code, stderr, _ = compile root "Dep.res" in + if code <> 0 then assert_failure ("Dep.res: " ^ stderr) + +let requests_tests _ = + with_temp_dir (fun root -> + setup root; + let inputs = "Main.res" :: List.map fst error_sources in + (* Each input is compiled once with no counts known (everything is + built at once), then again with the counts that request learnt. *) + let eager, deferred = + List.split + (List.map + (fun input -> + Env.forget_component_counts (); + let eager = compile root input in + let deferred_before, fallbacks_before = + Env.deferred_component_stats () + in + let deferred = compile root input in + let deferred_after, fallbacks_after = + Env.deferred_component_stats () + in + assert_bool + (input ^ ": values were deferred") + (deferred_after > deferred_before); + assert_equal ~printer:string_of_int + ~msg: + (input + ^ ": every deferred copy took exactly its reserved type ids") + fallbacks_before fallbacks_after; + (eager, deferred)) + inputs) + in + List.iter2 + (fun input ((code, stderr, files) as eager) -> + let main = input = "Main.res" in + assert_bool + (input ^ " exit code: " ^ stderr) + (if main then code = 0 else code <> 0); + if not main then + assert_bool + (input ^ " reports an error: " ^ stderr) + (String.length stderr > 0); + if main then + assert_equal ~printer:string_of_int ~msg:"Main outputs" 4 + (List.length files); + ignore eager) + inputs eager; + List.iter2 + (fun input (eager, deferred) -> + let code, stderr, files = deferred in + let eager_code, eager_stderr, eager_files = eager in + assert_equal ~printer:string_of_int ~msg:(input ^ " exit code") + eager_code code; + assert_equal ~printer:Fun.id ~msg:(input ^ " diagnostics") + eager_stderr stderr; + assert_equal + ~printer:(fun files -> + String.concat ", " + (List.map + (fun (ext, contents) -> + ext ^ " " ^ Digest.to_hex (Digest.string contents)) + files)) + ~msg:(input ^ " outputs") eager_files files) + inputs + (List.combine eager deferred)) + +(* Requests on several domains at once, each building and reading the + deferred components of its own environment, give the outputs of the + eager request. *) +let concurrent_requests_tests _ = + with_temp_dir (fun root -> + let dirs = + List.init 5 (fun index -> + let dir = Filename.concat root (string_of_int index) in + ensure_dir dir; + setup dir; + dir) + in + let portable (code, stderr, files) = + (* The .cmt files record their own directory. *) + (code, String.length stderr, List.remove_assoc ".cmt" files) + in + Env.forget_component_counts (); + let eager = portable (compile (List.hd dirs) "Main.res") in + let domains = + List.map + (fun dir -> + Domain.spawn (fun () -> + let results = + List.init 3 (fun _ -> portable (compile dir "Main.res")) + in + let deferred, fallbacks = Env.deferred_component_stats () in + assert_bool "the domain deferred values" (deferred > 0); + assert_equal ~printer:string_of_int + ~msg:"no deferred copy on the domain fell back" 0 fallbacks; + results)) + (List.tl dirs) + in + (* Join every domain before reporting a failure. *) + let results = + List.map + (fun domain -> + match Domain.join domain with + | results -> Ok results + | exception error -> Error error) + domains + in + List.iter + (function + | Ok results -> + List.iter + (fun result -> + assert_bool "a concurrent request gives the eager outputs" + (result = eager)) + results + | Error error -> raise error) + results) + +let suites = + __FILE__ + >::: [ + "deferred_components_match_eager_ones" >:: deferred_matches_eager_tests; + "unread_components_reserve_type_ids" >:: unread_components_tests; + "count_mismatch_falls_back_to_fresh_ids" + >:: count_mismatch_fallback_tests; + "counts_without_value_slot_build_at_once" + >:: counts_without_value_slot_tests; + "raising_copy_restores_counters" >:: raising_copy_tests; + "copy_types_in_open" >:: copy_types_in_open_tests; + "requests_match_eager_requests" >:: requests_tests; + "concurrent_requests_match_eager_request" >:: concurrent_requests_tests; + ] diff --git a/tests/ounit_tests/ounit_tests_main.ml b/tests/ounit_tests/ounit_tests_main.ml index 84184db90c..2617bdc5db 100644 --- a/tests/ounit_tests/ounit_tests_main.ml +++ b/tests/ounit_tests/ounit_tests_main.ml @@ -40,6 +40,7 @@ let suites = Ounit_find_in_path_tests.suites; Ounit_build_file_store_tests.suites; Ounit_deferred_signature_tests.suites; + Ounit_deferred_components_tests.suites; ] let _ = OUnit.run_test_tt_main suites From 76138a2808a1de9fd08a0b59083621b0bd6366d6 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Mon, 9 Nov 2026 14:34:44 +0000 Subject: [PATCH 2/3] Allocate a value's copy closure only when the copy is deferred Why: `components_of_module_maker` built a closure for the copy of every value it added, also when it then copied the value at once (the first time the process builds a .cmi's components, and for every module that is not part of a .cmi), and checked recorded counts against the signature by converting the count array to a list. `make_cell` now takes the substitution and the declaration and builds a closure only for a deferred copy, and the counts are checked by walking the signature with an index. Which values are deferred, the type ids they take and the components built are unchanged. Measured with scripts/compilerBenchmarks.js against the previous commit: allocated words -0.15% in total, -0.25% in the project builds (where components are built again in one process and their counts are known), -0.04% for the files compiled one by one. On a 552 module React app (clean build, one domain) the build allocates 0.2% fewer words. Signed-off-by: Jono Prest --- compiler/ml/env.ml | 41 ++++++++++++++++++++++------------------- 1 file changed, 22 insertions(+), 19 deletions(-) diff --git a/compiler/ml/env.ml b/compiler/ml/env.ml index 52cd35102a..042cf77af7 100644 --- a/compiler/ml/env.ml +++ b/compiler/ml/env.ml @@ -1821,20 +1821,23 @@ and components_of_module_maker let key = Option.map (fun crc -> (crc, Path.name path)) origin in let state = Compiler_request_state.current () in let item_count = List.length sg in + (* Whether [counts] fit this signature: one for every value. *) + let counts_fit counts = + Array.length counts = item_count + && + let rec fit index = function + | [] -> true + | Sig_value _ :: _ when counts.(index) < 0 -> false + | ( Sig_value _ | Sig_type _ | Sig_typext _ | Sig_module _ + | Sig_modtype _ ) + :: rest -> + fit (index + 1) rest + in + fit 0 sg + in let counts = match Option.bind key find_component_counts with - | Some counts - when Array.length counts = item_count - && List.for_all2 - (fun item count -> - match item with - | Sig_value _ -> count >= 0 - | Sig_type _ | Sig_typext _ | Sig_module _ | Sig_modtype _ - -> - true) - sg (Array.to_list counts) -> - (* The counts fit this signature: one for every value. *) - Some counts + | Some counts when counts_fit counts -> Some counts | Some _ | None -> None in (* The type ids each value takes, when the counts of these @@ -1846,21 +1849,23 @@ and components_of_module_maker in let stamps_taken = ref false in let deferred = ref 0 in - let make_cell index compute = + (* The copy is a closure only when it is deferred. *) + let make_cell index sub decl = match (counts, recorded) with | Some counts, _ -> let base = state.type_node_id and count = counts.(index) in state.type_node_id <- base + count; incr deferred; Comp_cell.pending (fun () -> - with_reserved_type_ids ~base ~count compute) + with_reserved_type_ids ~base ~count (fun () -> + Subst.value_description sub decl)) | None, Some recorded -> let type0 = state.type_node_id and stamp0 = Ident.current_time () in - let result = compute () in + let result = Subst.value_description sub decl in recorded.(index) <- state.type_node_id - type0; if Ident.current_time () <> stamp0 then stamps_taken := true; Comp_cell.ready result - | None, None -> Comp_cell.ready (compute ()) + | None, None -> Comp_cell.ready (Subst.value_description sub decl) in let pl, sub = prefix_idents path sub sg in let env = ref env in @@ -1870,9 +1875,7 @@ and components_of_module_maker (fun item path -> (match item with | Sig_value (id, decl) -> ( - let decl' = - make_cell !index (fun () -> Subst.value_description sub decl) - in + let decl' = make_cell !index sub decl in c.comp_values <- Tbl.add (Ident.name id) (decl', !pos) c.comp_values; match decl.val_kind with | Val_prim _ -> () From 768ed639cd8fd478ae68426f7957ffa4e2932ab7 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Tue, 10 Nov 2026 11:40:14 +0000 Subject: [PATCH 3/3] Build the path of a component found through an open with its binding Why: Id_tbl.find_opened returned the binding and its position as a new pair, which find_name and find_all took apart again to build the path, so every lookup of a name found in the components of an open allocated three words more than before the open tables took the cells. In stress/RefsInLoop that moved each statement's allocations from 46272 to 46368 bytes, a Fibonacci number: with the minor heap the benchmarks run with, the objects of the 300 statements in the .cmt then fall on the same slot of the marshaller's position table (Fibonacci hashing of addresses, linear probing), and marshalling the .cmt took about 40M more instructions (+23% under cachegrind), though the file is byte-identical. find_opened now gives the path and the binding, built from the pair stored in the table; update, which only Env.copy_types calls, looks the binding up as before. The bindings found, their order and the outputs are unchanged. Measured with scripts/compilerBenchmarks.js against the previous commit: allocated words -0.02% in total, stress/NestedClosures -0.13%, and stress/RefsInLoop -5.4K words; with perf stat (s=64M as the benchmarks run) RefsInLoop takes 456.5M instructions, against 515.0M before and 456.1M for #9192 head. Review: Does the instruction count of RefsInLoop now depend on luck? Yes, as before #9194: any change of 96 bytes per statement in this benchmark can land on a stride that hashes badly, without any work in the compiler. The fix removes the allocation that moved it there, which is worth having on its own. Signed-off-by: Jono Prest --- compiler/ml/env.ml | 30 ++++++++++++++++++------------ 1 file changed, 18 insertions(+), 12 deletions(-) diff --git a/compiler/ml/env.ml b/compiler/ml/env.ml index 042cf77af7..f8ce183bb3 100644 --- a/compiler/ml/env.ml +++ b/compiler/ml/env.ml @@ -298,15 +298,16 @@ module Id_tbl = struct (Opened {using; root; components; force; overrides = Tbl.empty; next}); } - (* The binding named [name] in an open, with its position. *) - let find_opened (type a) name (Opened o : a opened) : a * int = + (* The path and binding named [name] in an open. The result is built here, + so that a lookup allocates no other pair on the way. *) + let find_opened (type a) name (Opened o : a opened) : Path.t * a = match Tbl.find_str name o.overrides with - | found -> found + | desc, pos -> (Pdot (o.root, name, pos), desc) | exception Not_found -> let desc, pos = Tbl.find_str name o.components in - (o.force desc, pos) + (Pdot (o.root, name, pos), o.force desc) - (* Every binding of an open, as [find_opened] gives it. *) + (* Every binding of an open, as [find_opened] gives it, with its position. *) let fold_opened (type a) f (Opened o : a opened) acc = Tbl.fold (fun name (desc, pos) acc -> @@ -328,10 +329,9 @@ module Id_tbl = struct (Pident id, desc) with Not_found as exn -> ( match tbl.opened with - | Some (Opened {using; root; next} as opened) -> ( + | Some (Opened {using; next} as opened) -> ( try - let descr, pos = find_opened name opened in - let res = (Pdot (root, name, pos), descr) in + let res = find_opened name opened in (if mark then match using with | None -> () @@ -351,8 +351,14 @@ module Id_tbl = struct {tbl with current = Ident.add id new_desc tbl.current} with Not_found -> ( match tbl.opened with - | Some (Opened o as opened) -> ( - match find_opened name opened with + | Some (Opened o) -> ( + match + match Tbl.find_str name o.overrides with + | found -> found + | exception Not_found -> + let desc, pos = Tbl.find_str name o.components in + (o.force desc, pos) + with | desc, pos -> let overrides = Tbl.add name (f desc, pos) o.overrides in {tbl with opened = Some (Opened {o with overrides})} @@ -368,9 +374,9 @@ module Id_tbl = struct @ match tbl.opened with | None -> [] - | Some (Opened {root; next} as opened) -> ( + | Some (Opened {next} as opened) -> ( match find_opened name opened with - | desc, pos -> (Pdot (root, name, pos), desc) :: find_all name next + | found -> found :: find_all name next | exception Not_found -> find_all name next) let rec fold_name f tbl acc =