From cc2ee4ccfda05acc2c60c5b4c45c63e7f6e1cf2f Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Tue, 3 Nov 2026 08:47:09 +0000 Subject: [PATCH 1/4] Copy a dependency's signature only when it is read Why: Env keeps each loaded compilation unit's signature as a lazy copy of the .cmi signature with its binders renamed (Subst.signature). normalize_path forced that copy just to learn that a compilation unit is not a module alias, which it never is; normalize_path is reached for every value reference such as Belt.Array.map, for abstract dependency types in Ctype.try_expand_once, and from Includemod and Printtyp. These copies were about 4-6 % of a clean build's CPU time on real projects (ui: 0.62 s of 13.3 s with one domain). normalize_path now only looks the unit up (keeping the .cmi load, import and CRC checks) and reserves the stamps and type ids the copy would take, so every later identifier and type node gets the same stamp and id as before. The copy is made with exactly those stamps and ids when the signature is first read (find_module, scrape_alias, fold_modules, read_signature); on a 552-module app 2,921 copies are reserved and 10 are ever made. How many stamps and ids a copy takes is learnt from the first copy of the same .cmi contents, keyed by the CRC create_cmi wrote, and kept for the process. If a reserved copy ever takes a different number, it is thrown away and made again with fresh stamps and ids, so a wrong count can change ids but never makes two nodes share one. Review: Are the artifacts the same? Yes: stamps and type ids are the same by construction. JS, .cmi, .cmj, .ast and .cmt are byte-identical to master on the 5,398-artifact corpus (default and one domain), and a unit test checks that deferred copies of every runtime and Belt interface marshal to the same bytes as eager ones, with the same stamps and ids created around them. Review: Can the copy differ when it is made later? Only if the .cmi graph changed in between; the type checker only works on copies of it, and closed object types' shared mutability cells, the one part it can change, do not change what is copied. Signed-off-by: Jono Prest --- ...efer-dependency-signature-copy.internal.md | 1 + compiler/ext/ident.ml | 13 ++ compiler/ext/ident.mli | 8 + compiler/ml/env.ml | 152 ++++++++++++++++-- compiler/ml/env.mli | 6 + .../src/belt_deferred_signature_copy_test.mjs | 142 ++++++++++++++++ .../src/belt_deferred_signature_copy_test.res | 65 ++++++++ ...cy_functor_type_through_alias.res.expected | 13 ++ ...ency_type_through_alias_chain.res.expected | 11 ++ ...ependency_value_through_alias.res.expected | 11 ++ .../dependency_functor_type_through_alias.res | 9 ++ .../dependency_type_through_alias_chain.res | 4 + ...recated_dependency_value_through_alias.res | 4 + .../ounit_deferred_signature_tests.ml | 107 ++++++++++++ tests/ounit_tests/ounit_tests_main.ml | 1 + 15 files changed, 538 insertions(+), 9 deletions(-) create mode 100644 changes/defer-dependency-signature-copy.internal.md create mode 100644 tests/belt_tests/src/belt_deferred_signature_copy_test.mjs create mode 100644 tests/belt_tests/src/belt_deferred_signature_copy_test.res create mode 100644 tests/build_tests/super_errors/expected/dependency_functor_type_through_alias.res.expected create mode 100644 tests/build_tests/super_errors/expected/dependency_type_through_alias_chain.res.expected create mode 100644 tests/build_tests/super_errors/expected/deprecated_dependency_value_through_alias.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/dependency_functor_type_through_alias.res create mode 100644 tests/build_tests/super_errors/fixtures/dependency_type_through_alias_chain.res create mode 100644 tests/build_tests/super_errors/fixtures/deprecated_dependency_value_through_alias.res create mode 100644 tests/ounit_tests/ounit_deferred_signature_tests.ml diff --git a/changes/defer-dependency-signature-copy.internal.md b/changes/defer-dependency-signature-copy.internal.md new file mode 100644 index 00000000000..b411632f681 --- /dev/null +++ b/changes/defer-dependency-signature-copy.internal.md @@ -0,0 +1 @@ +- Speed up type checking by copying a dependency's interface only when it is read, not when the compiler only checks whether it is a module alias. diff --git a/compiler/ext/ident.ml b/compiler/ext/ident.ml index 9944627a533..89904517c76 100644 --- a/compiler/ext/ident.ml +++ b/compiler/ext/ident.ml @@ -82,6 +82,19 @@ let set_current_time t = let state = counter () in state.currentstamp <- max state.currentstamp t +let with_current_time t f = + let state = counter () in + let saved = state.currentstamp in + state.currentstamp <- t; + match f () with + | result -> + let final = state.currentstamp in + state.currentstamp <- saved; + (result, final) + | exception exn -> + state.currentstamp <- saved; + raise exn + let reinit () = let state = counter () in if state.reinit_level < 0 then state.reinit_level <- state.currentstamp diff --git a/compiler/ext/ident.mli b/compiler/ext/ident.mli index f374f7a232c..38c4a01ea25 100644 --- a/compiler/ext/ident.mli +++ b/compiler/ext/ident.mli @@ -50,6 +50,14 @@ val is_predef_exn : t -> bool val binding_time : t -> int val current_time : unit -> int val set_current_time : int -> unit + +val with_current_time : int -> (unit -> 'a) -> 'a * int + +(* [with_current_time t f] runs [f] with the stamp counter set to [t], so the + identifiers it creates get the stamps after [t], and returns [f]'s result + with the counter value it ended at. The counter is then put back to its + value before the call, also if [f] raises. Used to create identifiers whose + stamps were reserved earlier. *) val reinit : unit -> unit val capture_request_baseline : unit -> unit diff --git a/compiler/ml/env.ml b/compiler/ml/env.ml index 06590447734..1dc752e9ab2 100644 --- a/compiler/ml/env.ml +++ b/compiler/ml/env.ml @@ -541,9 +541,113 @@ let current_unit () = Domain.DLS.get current_unit_key (* Persistent structure descriptions *) +(* The signature of a persistent structure is a copy of the one in its .cmi + file whose bound identifiers are renamed ([Subst.signature Subst.identity]). + The copy is often only asked for to learn that a compilation unit is not a + module alias ([normalize_path]), so it is not made then: the stamps and type + ids it would have taken are reserved, so every later stamp and id is the + same as if it had been made, and the copy is made with exactly those stamps + and ids when the signature is first read. + + The number of stamps and ids a copy takes is learnt from the first copy of + the same .cmi contents (keyed by its CRC) and kept for the whole process. + It only depends on the signature graph, which the type checker does not + change before copying it: only copies of it are given to the rest of the + type checker. If a reserved copy ever takes a different number of stamps or + ids, it is thrown away and made again with fresh ones. *) + +type pers_sig_state = + | Sig_pending + | Sig_reserved of {stamp_base: int; type_base: int; stamps: int; types: int} + | Sig_copied of signature + +type pers_sig = { + pers_sig_raw: signature; + pers_sig_key: Digest.t option; + mutable pers_sig_state: pers_sig_state; +} + +let copy_counts : (Digest.t, int * int) Hashtbl.t = Hashtbl.create 64 +let copy_counts_lock = Mutex.create () + +let find_copy_counts key = + Mutex.protect copy_counts_lock (fun () -> Hashtbl.find_opt copy_counts key) + +let record_copy_counts key counts = + Mutex.protect copy_counts_lock (fun () -> + if Hashtbl.length copy_counts >= 65536 then Hashtbl.reset copy_counts; + Hashtbl.replace copy_counts key counts) + +let reserved_copies = Atomic.make 0 +let reserved_copy_fallbacks = Atomic.make 0 + +let pers_sig ?key raw = + {pers_sig_raw = raw; pers_sig_key = key; pers_sig_state = Sig_pending} + +let copy_pers_sig raw = Subst.signature Subst.identity raw + +let force_pers_sig ps = + match ps.pers_sig_state with + | Sig_copied sg -> sg + | Sig_pending -> + let state = Compiler_request_state.current () in + let stamp0 = Ident.current_time () and type0 = state.type_node_id in + let sg = copy_pers_sig ps.pers_sig_raw in + (match ps.pers_sig_key with + | Some key -> + record_copy_counts key + (Ident.current_time () - stamp0, state.type_node_id - type0) + | None -> ()); + ps.pers_sig_state <- Sig_copied sg; + sg + | Sig_reserved {stamp_base; type_base; stamps; types} -> + let state = Compiler_request_state.current () in + let saved_type_id = state.type_node_id in + state.type_node_id <- type_base; + let (sg, stamp_end), type_end = + match + Ident.with_current_time stamp_base (fun () -> + copy_pers_sig ps.pers_sig_raw) + with + | result -> + let type_end = state.type_node_id in + state.type_node_id <- saved_type_id; + (result, type_end) + | exception exn -> + state.type_node_id <- saved_type_id; + raise exn + in + let sg = + if stamp_end = stamp_base + stamps && type_end = type_base + types then sg + else ( + (* Some of the stamps or ids may also belong to later identifiers and + type nodes: copy again with fresh ones. *) + Atomic.incr reserved_copy_fallbacks; + copy_pers_sig ps.pers_sig_raw) + in + ps.pers_sig_state <- Sig_copied sg; + sg + +(* Take the stamps and type ids [force_pers_sig] would take now, without + copying yet. *) +let reserve_pers_sig ps = + match ps.pers_sig_state with + | Sig_copied _ | Sig_reserved _ -> () + | Sig_pending -> ( + match Option.bind ps.pers_sig_key find_copy_counts with + | None -> ignore (force_pers_sig ps) + | Some (stamps, types) -> + let state = Compiler_request_state.current () in + let stamp_base = Ident.current_time () in + let type_base = state.type_node_id in + Atomic.incr reserved_copies; + Ident.set_current_time (stamp_base + stamps); + state.type_node_id <- type_base + types; + ps.pers_sig_state <- Sig_reserved {stamp_base; type_base; stamps; types}) + type pers_struct = { ps_name: string; - ps_sig: signature Lazy.t; + ps_sig: pers_sig; ps_comps: module_components; ps_crcs: (string * Digest.t option) list; ps_filename: string; @@ -607,6 +711,13 @@ module Persistent_signature = struct | exception Not_found -> None) end +(* The CRC create_cmi wrote for the contents of the .cmi (its name and + signature). *) +let own_crc (cmi : Cmi_format.cmi_infos) = + match cmi.cmi_crcs with + | (name, Some crc) :: _ when name = cmi.cmi_name -> Some crc + | _ -> None + let acknowledge_pers_struct check modname {Persistent_signature.filename; cmi} = let name = cmi.cmi_name in let sign = cmi.cmi_sign in @@ -626,7 +737,7 @@ let acknowledge_pers_struct check modname {Persistent_signature.filename; cmi} = let ps = { ps_name = name; - ps_sig = lazy (Subst.signature Subst.identity sign); + ps_sig = pers_sig ?key:(own_crc cmi) sign; ps_comps = comps; ps_crcs = crcs; ps_filename = filename; @@ -822,7 +933,7 @@ let find_module ~alias path env = with Not_found -> if Ident.persistent id && not (Ident.name id = !(current_unit ())) then let ps = find_pers_struct (Ident.name id) in - md (Mty_signature (Lazy.force ps.ps_sig)) + md (Mty_signature (force_pers_sig ps.ps_sig)) else raise Not_found) | Pdot (p, s, _pos) -> ( match get_components (find_module_descr p env) with @@ -851,6 +962,26 @@ let find_module ~alias path env = mty)) | Structure_comps _ -> raise Not_found) +(* The path a module is an alias of, as [find_module ~alias:true] gives it. A + compilation unit is never an alias, so its signature is not copied. *) +let module_alias_target path env = + let alias_target = function + | {md_type = Mty_alias (_, path1)} -> Some path1 + | _ -> None + in + match path with + | Pident id -> ( + try + let data = Id_tbl.find_same id env.modules in + alias_target (Env_lazy.force subst_modtype_maker data) + with Not_found -> + if Ident.persistent id && not (Ident.name id = !(current_unit ())) then ( + let ps = find_pers_struct (Ident.name id) in + reserve_pers_sig ps.ps_sig; + None) + else raise Not_found) + | Pdot _ | Papply _ -> alias_target (find_module ~alias:true path env) + let rec normalize_path lax env path = let path = match path with @@ -860,9 +991,9 @@ let rec normalize_path lax env path = | _ -> path in try - match find_module ~alias:true path env with - | {md_type = Mty_alias (_, path1)} -> normalize_path lax env path1 - | _ -> path + match module_alias_target path env with + | Some path1 -> normalize_path lax env path1 + | None -> path with | Not_found when lax @@ -1791,9 +1922,12 @@ let open_signature ?(used_slot = ref false) ?(loc = Location.none) ovf root env (* Read a signature from a file *) +let deferred_signature_copy_stats () = + (Atomic.get reserved_copies, Atomic.get reserved_copy_fallbacks) + let read_signature modname filename = let ps = read_pers_struct modname filename in - Lazy.force ps.ps_sig + force_pers_sig ps.ps_sig (* Return the CRC of the interface of the given compilation unit *) @@ -1839,7 +1973,7 @@ let save_signature_with_imports ?check_exists ~deprecated sg modname filename let ps = { ps_name = modname; - ps_sig = lazy (Subst.signature Subst.identity sg); + ps_sig = pers_sig sg; ps_comps = comps; ps_crcs = (cmi.cmi_name, Some crc) :: imports; ps_filename = filename; @@ -1908,7 +2042,7 @@ let fold_modules f lid env acc = | Some ps -> f name (Pident (Ident.create_persistent name)) - (md (Mty_signature (Lazy.force ps.ps_sig))) + (md (Mty_signature (force_pers_sig ps.ps_sig))) acc) (persistent_structures ()) acc | Some l -> ( diff --git a/compiler/ml/env.mli b/compiler/ml/env.mli index a2ebfcaf66b..db441dc9a3f 100644 --- a/compiler/ml/env.mli +++ b/compiler/ml/env.mli @@ -166,6 +166,12 @@ val get_unit_name : unit -> string (* Read, save a signature to/from a file *) val read_signature : string -> string -> signature + +val deferred_signature_copy_stats : unit -> int * int +(* For tests: how many copies of compilation units' signatures were deferred, + and how many of those did not take the stamps and type ids reserved for + them and were made again with fresh ones (expected: none), in the process + so far. *) (* Arguments: module name, file name. Results: signature. *) val save_signature : diff --git a/tests/belt_tests/src/belt_deferred_signature_copy_test.mjs b/tests/belt_tests/src/belt_deferred_signature_copy_test.mjs new file mode 100644 index 00000000000..64658a08c64 --- /dev/null +++ b/tests/belt_tests/src/belt_deferred_signature_copy_test.mjs @@ -0,0 +1,142 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Mocha from "mocha"; +import * as Belt_Id from "@rescript/belt/src/Belt_Id.mjs"; +import * as Belt_Set from "@rescript/belt/src/Belt_Set.mjs"; +import * as Belt_List from "@rescript/belt/src/Belt_List.mjs"; +import * as Belt_Array from "@rescript/belt/src/Belt_Array.mjs"; +import * as Test_utils from "./test_utils.mjs"; +import * as Belt_Option from "@rescript/belt/src/Belt_Option.mjs"; +import * as Primitive_int from "@rescript/runtime/lib/es6/Primitive_int.mjs"; + +let C = { + D: undefined +}; + +let mapped = [ + 1, + 2, + 3 +].map(x => x + 1 | 0); + +let viaBelt = Belt_Array.map([ + 1, + 2 +], x => x * 10 | 0); + +let viaList = Belt_List.toArray(Belt_List.map({hd: 1, tl: {hd: 2, tl: /* [] */0}}, x => x - 1 | 0)); + +let cmp = Primitive_int.compare; + +let IntCmp = Belt_Id.MakeComparable({ + cmp: cmp +}); + +let set = Belt_Set.fromArray([ + 3, + 1, + 2 +], IntCmp); + +function orZero(x) { + return Belt_Option.getWithDefault(x, 0); +} + +let Extended = { + keepU: Belt_Option.keepU, + keep: Belt_Option.keep, + forEachU: Belt_Option.forEachU, + forEach: Belt_Option.forEach, + getExn: Belt_Option.getExn, + getOrThrow: Belt_Option.getOrThrow, + mapWithDefaultU: Belt_Option.mapWithDefaultU, + mapWithDefault: Belt_Option.mapWithDefault, + mapU: Belt_Option.mapU, + map: Belt_Option.map, + flatMapU: Belt_Option.flatMapU, + flatMap: Belt_Option.flatMap, + getWithDefault: Belt_Option.getWithDefault, + orElse: Belt_Option.orElse, + isSome: Belt_Option.isSome, + isNone: Belt_Option.isNone, + eqU: Belt_Option.eqU, + eq: Belt_Option.eq, + cmpU: Belt_Option.cmpU, + cmp: Belt_Option.cmp, + orZero: orZero +}; + +function size(t) { + if (typeof t !== "object") { + return 1; + } else { + return Belt_Array.reduce(t._0, 1, (acc, c) => acc + Tree.size(c) | 0); + } +} + +let Tree = { + size: size +}; + +Mocha.describe("Belt_deferred_signature_copy_test", () => { + Mocha.test("alias chains", () => { + Test_utils.eq("File \"belt_deferred_signature_copy_test.res\", line 53, characters 7-14", [ + 2, + 3, + 4 + ], mapped); + Test_utils.eq("File \"belt_deferred_signature_copy_test.res\", line 54, characters 7-14", [ + 10, + 20 + ], viaBelt); + Test_utils.eq("File \"belt_deferred_signature_copy_test.res\", line 55, characters 7-14", [ + 0, + 1 + ], viaList); + }); + Mocha.test("functors and module types of dependencies", () => { + Test_utils.eq("File \"belt_deferred_signature_copy_test.res\", line 58, characters 7-14", [ + 1, + 2, + 3 + ], Belt_Set.toArray(set)); + Test_utils.eq("File \"belt_deferred_signature_copy_test.res\", line 59, characters 7-14", 2, 2); + }); + Mocha.test("include and recursive modules", () => { + Test_utils.eq("File \"belt_deferred_signature_copy_test.res\", line 62, characters 7-14", 0, Belt_Option.getWithDefault(undefined, 0)); + Test_utils.eq("File \"belt_deferred_signature_copy_test.res\", line 63, characters 7-14", 3, Tree.size({ + TAG: "Node", + _0: [ + "Leaf", + "Leaf" + ] + })); + }); +}); + +let A; + +let B; + +let L; + +let MyArray = Belt_Array; + +let MyArray$make = Belt_Array.make; + +export { + A, + B, + C, + L, + mapped, + viaBelt, + viaList, + IntCmp, + set, + MyArray, + Extended, + Tree, + MyArray$make, +} +/* mapped Not a pure module */ diff --git a/tests/belt_tests/src/belt_deferred_signature_copy_test.res b/tests/belt_tests/src/belt_deferred_signature_copy_test.res new file mode 100644 index 00000000000..6f668b44099 --- /dev/null +++ b/tests/belt_tests/src/belt_deferred_signature_copy_test.res @@ -0,0 +1,65 @@ +// Uses of compilation units whose signatures the compiler only copies when +// they are read: module aliases and chains of them, values reached through an +// alias, functors and module types of dependencies, nested and recursive +// modules, and includes. + +module A = Stdlib.Array +module B = A + +module C = { + module D = B +} + +module L = Belt.List + +let mapped = C.D.map([1, 2, 3], x => x + 1) +let viaBelt = Belt.Array.map([1, 2], x => x * 10) +let viaList = L.toArray(L.map(list{1, 2}, x => x - 1)) + +module IntCmp = Belt.Id.MakeComparable({ + type t = int + let cmp = (a: int, b: int) => compare(a, b) +}) + +let set = Belt.Set.fromArray([3, 1, 2], ~id=module(IntCmp)) + +module type ArrayLike = module type of Belt.Array + +module MyArray: ArrayLike = Belt.Array + +module Extended = { + include Belt.Option + let orZero = x => getWithDefault(x, 0) +} + +module rec Tree: { + type t = Leaf | Node(Belt.Array.t) + let size: t => int +} = { + type t = Leaf | Node(Belt.Array.t) + + let size = t => + switch t { + | Leaf => 1 + | Node(children) => Belt.Array.reduce(children, 1, (acc, c) => acc + Tree.size(c)) + } +} + +open Mocha +open Test_utils + +describe(__MODULE__, () => { + test("alias chains", () => { + eq(__LOC__, [2, 3, 4], mapped) + eq(__LOC__, [10, 20], viaBelt) + eq(__LOC__, [0, 1], viaList) + }) + test("functors and module types of dependencies", () => { + eq(__LOC__, [1, 2, 3], Belt.Set.toArray(set)) + eq(__LOC__, 2, MyArray.length([1, 2])) + }) + test("include and recursive modules", () => { + eq(__LOC__, 0, Extended.orZero(None)) + eq(__LOC__, 3, Tree.size(Node([Leaf, Leaf]))) + }) +}) diff --git a/tests/build_tests/super_errors/expected/dependency_functor_type_through_alias.res.expected b/tests/build_tests/super_errors/expected/dependency_functor_type_through_alias.res.expected new file mode 100644 index 00000000000..5d692f64008 --- /dev/null +++ b/tests/build_tests/super_errors/expected/dependency_functor_type_through_alias.res.expected @@ -0,0 +1,13 @@ + + We've found a bug for you! + /.../fixtures/dependency_functor_type_through_alias.res:9:17-25 + + 7 │ + 8 │ let s = M.fromArray([1], ~id=module(IntCmp)) + 9 │ let n: string = M.size(s) + 10 │ + + This has type: int + But it's expected to have type: string + + You can convert int to string with Int.toString. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/dependency_type_through_alias_chain.res.expected b/tests/build_tests/super_errors/expected/dependency_type_through_alias_chain.res.expected new file mode 100644 index 00000000000..3b616dc6aad --- /dev/null +++ b/tests/build_tests/super_errors/expected/dependency_type_through_alias_chain.res.expected @@ -0,0 +1,11 @@ + + We've found a bug for you! + /.../fixtures/dependency_type_through_alias_chain.res:4:19-25 + + 2 │ module B = A + 3 │ + 4 │ let x: B.t = list{1} + 5 │ + + This has type: list<'a> + But it's expected to have type: B.t (defined as array) \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/deprecated_dependency_value_through_alias.res.expected b/tests/build_tests/super_errors/expected/deprecated_dependency_value_through_alias.res.expected new file mode 100644 index 00000000000..8e9d6f4ee46 --- /dev/null +++ b/tests/build_tests/super_errors/expected/deprecated_dependency_value_through_alias.res.expected @@ -0,0 +1,11 @@ + + Warning number 3 + /.../fixtures/deprecated_dependency_value_through_alias.res:4:12-18 + + 2 │ module P = O + 3 │ + 4 │ let kept = P.keepU(Some(1), x => x > 0) + 5 │ + + deprecated: P.keepU + Use `keep` instead \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/dependency_functor_type_through_alias.res b/tests/build_tests/super_errors/fixtures/dependency_functor_type_through_alias.res new file mode 100644 index 00000000000..75cb36569d9 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/dependency_functor_type_through_alias.res @@ -0,0 +1,9 @@ +module M = Belt.Set + +module IntCmp = Belt.Id.MakeComparable({ + type t = int + let cmp = (a: int, b: int) => compare(a, b) +}) + +let s = M.fromArray([1], ~id=module(IntCmp)) +let n: string = M.size(s) diff --git a/tests/build_tests/super_errors/fixtures/dependency_type_through_alias_chain.res b/tests/build_tests/super_errors/fixtures/dependency_type_through_alias_chain.res new file mode 100644 index 00000000000..33035beb1fb --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/dependency_type_through_alias_chain.res @@ -0,0 +1,4 @@ +module A = Belt.Array +module B = A + +let x: B.t = list{1} diff --git a/tests/build_tests/super_errors/fixtures/deprecated_dependency_value_through_alias.res b/tests/build_tests/super_errors/fixtures/deprecated_dependency_value_through_alias.res new file mode 100644 index 00000000000..9b167286f90 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/deprecated_dependency_value_through_alias.res @@ -0,0 +1,4 @@ +module O = Belt.Option +module P = O + +let kept = P.keepU(Some(1), x => x > 0) diff --git a/tests/ounit_tests/ounit_deferred_signature_tests.ml b/tests/ounit_tests/ounit_deferred_signature_tests.ml new file mode 100644 index 00000000000..d74201516a2 --- /dev/null +++ b/tests/ounit_tests/ounit_deferred_signature_tests.ml @@ -0,0 +1,107 @@ +(* The copy of a compilation unit's signature that [Env] makes when it is + first read is deferred when only [Env.normalize_path] asks for it: the + stamps and type ids it takes are reserved then and used when the copy is + made later. These tests check that a deferred copy, and everything created + between the reservation and the copy, gets exactly the stamps and type ids + it gets when the copy is made at once, for every interface of the runtime + and Belt (nested modules, functors, module types, aliases). *) + +open OUnit + +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) + +let interface_dirs () = + let runtime = Runtime_package.get_path () in + let belt = Filename.concat (Filename.dirname runtime) "belt" in + List.filter Sys.file_exists + [Filename.concat runtime "lib/ocaml"; Filename.concat belt "lib/ocaml"] + +let unit_names dirs = + List.concat_map + (fun dir -> + Sys.readdir dir |> Array.to_list + |> List.filter (fun file -> Filename.check_suffix file ".cmi") + |> List.map (fun file -> + (Cmi_format.read_cmi (Filename.concat dir file)).cmi_name)) + dirs + |> List.sort_uniq compare + +let unit_path name = Path.Pident (Ident.create_persistent name) + +let probe () = + (Ident.binding_time (Ident.create "probe"), (Btype.newgenvar ()).Types.id) + +(* Ask whether every unit is an alias, creating an identifier and a type node + after each question, then read every signature in reverse order. With + [~eager], each signature is read before the question, so its copy is made + then, as before the copies were deferred. The result is marshalled: equal + strings mean equal stamps, type ids and sharing. *) +let run ~eager dirs names = + Compiler_request_state.with_fresh (fun () -> + Request_local.with_fresh (fun () -> + Ident.with_fresh (fun () -> + Config.set_load_path dirs; + let env = Env.empty in + let asked = + List.map + (fun name -> + let path = unit_path name in + if eager then ignore (Env.find_module path env); + let normalized = Env.normalize_path None env path in + (normalized, probe ())) + names + in + let read = + List.rev_map + (fun name -> (Env.find_module (unit_path name) env).md_type) + names + in + Marshal.to_string (asked, read, probe ()) []))) + +let deferred_copy_tests _ = + let dirs = interface_dirs () in + let names = unit_names dirs in + assert_bool "runtime interfaces found" (List.length names > 50); + (* The eager run also records how many stamps and ids each copy takes. *) + let eager = run ~eager:true dirs names in + let reserved_before, fallbacks_before = + Env.deferred_signature_copy_stats () + in + let deferred = run ~eager:false dirs names in + let reserved_after, fallbacks_after = Env.deferred_signature_copy_stats () in + assert_equal ~printer:string_of_int ~msg:"every copy was deferred" + (List.length names) + (reserved_after - reserved_before); + assert_equal ~printer:string_of_int + ~msg:"every deferred copy took exactly its reserved stamps and 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) + +(* A copy that is never read still takes its stamps and ids. *) +let unread_copy_tests _ = + let dirs = interface_dirs () in + let names = ["Belt_Array"; "Stdlib_Array"; "Belt_Id"; "Stdlib"] in + let ask_only ~eager = + Compiler_request_state.with_fresh (fun () -> + Request_local.with_fresh (fun () -> + Ident.with_fresh (fun () -> + Config.set_load_path dirs; + List.map + (fun name -> + let path = unit_path name in + if eager then ignore (Env.find_module path Env.empty); + ignore (Env.normalize_path None Env.empty path); + probe ()) + names))) + in + let eager = ask_only ~eager:true in + assert_equal eager (ask_only ~eager:false) + +let suites = + __FILE__ + >::: [ + "deferred_copy_matches_eager_copy" >:: deferred_copy_tests; + "unread_copy_reserves_stamps_and_ids" >:: unread_copy_tests; + ] diff --git a/tests/ounit_tests/ounit_tests_main.ml b/tests/ounit_tests/ounit_tests_main.ml index d53bffff6cd..3348a045e8d 100644 --- a/tests/ounit_tests/ounit_tests_main.ml +++ b/tests/ounit_tests/ounit_tests_main.ml @@ -38,6 +38,7 @@ let suites = Ounit_compiler_request_tests.suites; Ounit_find_in_path_tests.suites; Ounit_build_file_store_tests.suites; + Ounit_deferred_signature_tests.suites; ] let _ = OUnit.run_test_tt_main suites From 04a12ede7b38685925638bfc731a249b913e2f91 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Tue, 3 Nov 2026 08:53:47 +0000 Subject: [PATCH 2/4] Read the signatures in reverse order in the deferred copy test List.rev_map applies its function from the head, so the test read the signatures in the order they were reserved; it now reads the last one first, so each copy is made with stamps and ids reserved before others. Signed-off-by: Jono Prest --- tests/ounit_tests/ounit_deferred_signature_tests.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/tests/ounit_tests/ounit_deferred_signature_tests.ml b/tests/ounit_tests/ounit_deferred_signature_tests.ml index d74201516a2..28e4bca422b 100644 --- a/tests/ounit_tests/ounit_deferred_signature_tests.ml +++ b/tests/ounit_tests/ounit_deferred_signature_tests.ml @@ -52,9 +52,11 @@ let run ~eager dirs names = names in let read = - List.rev_map + (* [List.map] applies its function from the head: read the + last unit's signature first. *) + List.map (fun name -> (Env.find_module (unit_path name) env).md_type) - names + (List.rev names) in Marshal.to_string (asked, read, probe ()) []))) From d1dd52389e5ea8ef4ef589f80f8b5d8d995b32b6 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Tue, 3 Nov 2026 09:02:20 +0000 Subject: [PATCH 3/4] Test the counter restore and the fallback of deferred signature copies The independent review found the env.mli comment for read_signature attached to the new stats function, and the comment and changelog overstating when copies are deferred: only after an earlier copy of the same interface in the process, never for the first one or a one-shot bsc. New unit tests check that Ident.with_current_time puts the counter back when its function raises, and that a deferred copy whose counts are wrong (a forged .cmi CRC) is made again with fresh stamps. Signed-off-by: Jono Prest --- ...efer-dependency-signature-copy.internal.md | 2 +- compiler/ml/env.ml | 17 +-- compiler/ml/env.mli | 2 +- .../ounit_deferred_signature_tests.ml | 100 ++++++++++++++++++ 4 files changed, 111 insertions(+), 10 deletions(-) diff --git a/changes/defer-dependency-signature-copy.internal.md b/changes/defer-dependency-signature-copy.internal.md index b411632f681..08c0e00262f 100644 --- a/changes/defer-dependency-signature-copy.internal.md +++ b/changes/defer-dependency-signature-copy.internal.md @@ -1 +1 @@ -- Speed up type checking by copying a dependency's interface only when it is read, not when the compiler only checks whether it is a module alias. +- Speed up type checking in builds: after the first copy of a dependency's interface, later requests only copy it when they read it, not when they only check whether it is a module alias. diff --git a/compiler/ml/env.ml b/compiler/ml/env.ml index 1dc752e9ab2..1b4be3cbc44 100644 --- a/compiler/ml/env.ml +++ b/compiler/ml/env.ml @@ -544,14 +544,15 @@ let current_unit () = Domain.DLS.get current_unit_key (* The signature of a persistent structure is a copy of the one in its .cmi file whose bound identifiers are renamed ([Subst.signature Subst.identity]). The copy is often only asked for to learn that a compilation unit is not a - module alias ([normalize_path]), so it is not made then: the stamps and type - ids it would have taken are reserved, so every later stamp and id is the - same as if it had been made, and the copy is made with exactly those stamps - and ids when the signature is first read. - - The number of stamps and ids a copy takes is learnt from the first copy of - the same .cmi contents (keyed by its CRC) and kept for the whole process. - It only depends on the signature graph, which the type checker does not + module alias ([normalize_path]). When this process has already copied the + same .cmi contents (same CRC), e.g. in an earlier request of the same + build, the copy is not made then: the stamps and type ids it would take are + reserved, so every later stamp and id is the same as if it had been made, + and the copy is made with exactly those stamps and ids when the signature + is first read. Otherwise (the first copy of an interface, or a one-shot + bsc) it is made at once, as before, and its counts are kept. + + The number of stamps and ids a copy takes only depends on the signature graph, which the type checker does not change before copying it: only copies of it are given to the rest of the type checker. If a reserved copy ever takes a different number of stamps or ids, it is thrown away and made again with fresh ones. *) diff --git a/compiler/ml/env.mli b/compiler/ml/env.mli index db441dc9a3f..895090bbad8 100644 --- a/compiler/ml/env.mli +++ b/compiler/ml/env.mli @@ -166,13 +166,13 @@ val get_unit_name : unit -> string (* Read, save a signature to/from a file *) val read_signature : string -> string -> signature +(* Arguments: module name, file name. Results: signature. *) val deferred_signature_copy_stats : unit -> int * int (* For tests: how many copies of compilation units' signatures were deferred, and how many of those did not take the stamps and type ids reserved for them and were made again with fresh ones (expected: none), in the process so far. *) -(* Arguments: module name, file name. Results: signature. *) val save_signature : ?check_exists:unit -> diff --git a/tests/ounit_tests/ounit_deferred_signature_tests.ml b/tests/ounit_tests/ounit_deferred_signature_tests.ml index 28e4bca422b..3acf0d3ff47 100644 --- a/tests/ounit_tests/ounit_deferred_signature_tests.ml +++ b/tests/ounit_tests/ounit_deferred_signature_tests.ml @@ -101,9 +101,109 @@ let unread_copy_tests _ = let eager = ask_only ~eager:true in assert_equal eager (ask_only ~eager:false) +(* [Ident.with_current_time] puts the counter back also when its function + raises. *) +let with_current_time_restores_on_exception _ = + Ident.with_fresh (fun () -> + let before = Ident.current_time () in + let inside = ref 0 in + (match + Ident.with_current_time (before + 100) (fun () -> + inside := Ident.binding_time (Ident.create "inside"); + failwith "raised inside") + with + | _ -> assert_failure "the function should have raised" + | exception Failure _ -> ()); + assert_equal ~printer:string_of_int (before + 101) !inside; + assert_equal ~printer:string_of_int ~msg:"counter restored after raise" + before (Ident.current_time ()); + let (), final = + Ident.with_current_time (before + 7) (fun () -> + ignore (Ident.create "a"); + ignore (Ident.create "b")) + in + assert_equal ~printer:string_of_int (before + 9) final; + assert_equal ~printer:string_of_int ~msg:"counter restored after return" + before (Ident.current_time ())) + +(* A compilation unit [Forged] whose .cmi claims the CRC of different contents: + the counts learnt from the first contents are wrong for the second, so its + deferred copy takes more stamps and ids than were reserved, and is made + again with fresh ones. *) +let value name = + Types.Sig_value + ( Ident.create name, + { + val_type = Predef.type_int (); + val_kind = Val_reg; + val_loc = Location.none; + val_attributes = []; + } ) + +let forged_crc = Digest.string "ounit_deferred_signature_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 () -> + Compiler_request_state.with_fresh (fun () -> + Request_local.with_fresh (fun () -> Ident.with_fresh action))) + +let count_mismatch_fallback_tests _ = + let path = unit_path "Forged" in + (* Learn the counts of a one-value signature. *) + with_forged_unit + [value "x"] + (fun () -> ignore (Env.find_module path Env.empty)); + let reserved_before, fallbacks_before = + Env.deferred_signature_copy_stats () + in + let stamps, probe_stamp = + with_forged_unit + [value "x"; value "y"] + (fun () -> + ignore (Env.normalize_path None Env.empty path); + let probe_stamp = Ident.binding_time (Ident.create "probe") in + match (Env.find_module path Env.empty).md_type with + | Mty_signature items -> + ( List.map + (function + | Types.Sig_value (id, _) -> Ident.binding_time id + | _ -> assert_failure "expected values") + items, + probe_stamp ) + | _ -> assert_failure "expected a signature") + in + let reserved_after, fallbacks_after = Env.deferred_signature_copy_stats () in + assert_equal ~printer:string_of_int ~msg:"the copy was deferred" + (reserved_before + 1) reserved_after; + assert_equal ~printer:string_of_int ~msg:"the copy fell back" + (fallbacks_before + 1) fallbacks_after; + assert_bool "the fallback copy has both values with fresh stamps" + (List.length stamps = 2 + && List.for_all (fun stamp -> stamp > probe_stamp) stamps) + let suites = __FILE__ >::: [ "deferred_copy_matches_eager_copy" >:: deferred_copy_tests; "unread_copy_reserves_stamps_and_ids" >:: unread_copy_tests; + "with_current_time_restores_on_exception" + >:: with_current_time_restores_on_exception; + "count_mismatch_falls_back_to_fresh_ids" + >:: count_mismatch_fallback_tests; ] From 6bfcbc9d94fa70922e25e5c6fa2cab0a7888b8dd Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Tue, 3 Nov 2026 09:23:19 +0000 Subject: [PATCH 4/4] Build on OCaml 5.0 and test unread copies with runtime interfaces Mutex.protect only exists from OCaml 5.1, so the count table locks with Mutex.lock and Fun.protect like Process_child.with_lock. The unread copy test asked for Belt modules, which the coverage job doesn't build; it now uses runtime interfaces only. Signed-off-by: Jono Prest --- changes/defer-dependency-signature-copy.internal.md | 1 - changes/defer-dependency-signature-copy.polish.md | 1 + compiler/ml/env.ml | 9 +++++++-- tests/ounit_tests/ounit_deferred_signature_tests.ml | 6 ++++-- 4 files changed, 12 insertions(+), 5 deletions(-) delete mode 100644 changes/defer-dependency-signature-copy.internal.md create mode 100644 changes/defer-dependency-signature-copy.polish.md diff --git a/changes/defer-dependency-signature-copy.internal.md b/changes/defer-dependency-signature-copy.internal.md deleted file mode 100644 index 08c0e00262f..00000000000 --- a/changes/defer-dependency-signature-copy.internal.md +++ /dev/null @@ -1 +0,0 @@ -- Speed up type checking in builds: after the first copy of a dependency's interface, later requests only copy it when they read it, not when they only check whether it is a module alias. diff --git a/changes/defer-dependency-signature-copy.polish.md b/changes/defer-dependency-signature-copy.polish.md new file mode 100644 index 00000000000..13e98128259 --- /dev/null +++ b/changes/defer-dependency-signature-copy.polish.md @@ -0,0 +1 @@ +- Build: copy a dependency's interface only when it is read, after the first copy of the same interface in a build, instead of every time a module checks whether the dependency is an alias. diff --git a/compiler/ml/env.ml b/compiler/ml/env.ml index 1b4be3cbc44..0b39f41d919 100644 --- a/compiler/ml/env.ml +++ b/compiler/ml/env.ml @@ -571,11 +571,16 @@ type pers_sig = { let copy_counts : (Digest.t, int * int) Hashtbl.t = Hashtbl.create 64 let copy_counts_lock = Mutex.create () +(* [Mutex.protect] needs OCaml 5.1. *) +let with_copy_counts_lock action = + Mutex.lock copy_counts_lock; + Fun.protect ~finally:(fun () -> Mutex.unlock copy_counts_lock) action + let find_copy_counts key = - Mutex.protect copy_counts_lock (fun () -> Hashtbl.find_opt copy_counts key) + with_copy_counts_lock (fun () -> Hashtbl.find_opt copy_counts key) let record_copy_counts key counts = - Mutex.protect copy_counts_lock (fun () -> + with_copy_counts_lock (fun () -> if Hashtbl.length copy_counts >= 65536 then Hashtbl.reset copy_counts; Hashtbl.replace copy_counts key counts) diff --git a/tests/ounit_tests/ounit_deferred_signature_tests.ml b/tests/ounit_tests/ounit_deferred_signature_tests.ml index 3acf0d3ff47..1033f565766 100644 --- a/tests/ounit_tests/ounit_deferred_signature_tests.ml +++ b/tests/ounit_tests/ounit_deferred_signature_tests.ml @@ -14,7 +14,9 @@ let interface_dirs () = let runtime = Runtime_package.get_path () in let belt = Filename.concat (Filename.dirname runtime) "belt" in List.filter Sys.file_exists - [Filename.concat runtime "lib/ocaml"; Filename.concat belt "lib/ocaml"] + [ + Filename.concat runtime "lib/rescript"; Filename.concat belt "lib/rescript"; + ] let unit_names dirs = List.concat_map @@ -84,7 +86,7 @@ let deferred_copy_tests _ = (* A copy that is never read still takes its stamps and ids. *) let unread_copy_tests _ = let dirs = interface_dirs () in - let names = ["Belt_Array"; "Stdlib_Array"; "Belt_Id"; "Stdlib"] in + let names = ["Stdlib_Array"; "Stdlib_List"; "Stdlib_Option"; "Stdlib"] in let ask_only ~eager = Compiler_request_state.with_fresh (fun () -> Request_local.with_fresh (fun () ->