From 30964652fcb19453b379adae27fbcb159ef49511 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Tue, 3 Nov 2026 07:59:14 +0000 Subject: [PATCH] Remember type path lookups within a compilation Why: Typechecking a 552 module React app calls Env.find_type_full 1.76M times, and normalize_path 666k times from expand_abbrev. Most calls look up the same few paths against the same environment: `option` alone is 528k of them, followed by `string`, `array`, `Jsx.element`. Each lookup walks the open layers of env.types, and expanding a type that isn't an abbreviation also normalizes its path, which raises and catches Not_found to return the path unchanged. A direct-mapped table now remembers successful lookups and unchanged normalizations. An entry is only reused while the environment tables the lookup read are physically the same (env.types for a Pident, env.components for a Pdot, env.modules and env.components for a normalization), and only within the request that stored it. Changed normalizations are computed again, so paths in types are allocated as before. Paths with a functor application aren't cached, the memo is skipped while loading .cmi files is disabled, and it is emptied when a request ends and when a loaded module is replaced. The two tables start empty and grow from 64 to 4096 slots as entries are stored, and a replaced entry is updated in place, so a small compilation allocates little for them: fixed 4096 slot tables made each runtime file allocate about 3% more words than master. Now the file that grows most, Dom.res, allocates 0.24% more, and the runtime and Belt in total 0.06% less. On the corpus 94% of lookups and 96% of normalizations hit, and the output is byte identical to master. Review: Can an entry be stale? The tables an entry depends on are immutable, so the same physical table gives the same answer. New unit tests bind the same path differently in two environments within one request (recursive type placeholders, recursive module approximations, an alias) and fail if any of these checks is removed. Review: Can growing or reusing an entry return a wrong result? Growth moves each entry to the slot of its path in the larger table, and a lookup still checks the path, the epoch and the tables of each entry it finds. An entry is only referenced from its slot, so updating it in place changes no result a caller holds. A unit test looks up 3000 types across the growth and fails if a replaced entry keeps its old result. Signed-off-by: Jono Prest --- changes/type-path-memo.polish.md | 1 + compiler/ml/ctype.ml | 8 +- compiler/ml/env.ml | 239 ++++++++++++++- compiler/ml/env.mli | 11 + compiler/ml/typecore.ml | 7 +- ...rning_34_unused_type_shadowed.res.expected | 47 +++ .../warning_34_unused_type_shadowed.res | 17 ++ .../ounit_compiler_request_tests.ml | 69 +++++ tests/ounit_tests/ounit_tests_main.ml | 1 + .../ounit_tests/ounit_type_path_memo_tests.ml | 124 ++++++++ tests/tests/src/type_path_lookup_test.mjs | 274 ++++++++++++++++++ tests/tests/src/type_path_lookup_test.res | 186 ++++++++++++ 12 files changed, 971 insertions(+), 13 deletions(-) create mode 100644 changes/type-path-memo.polish.md create mode 100644 tests/build_tests/super_errors/expected/warning_34_unused_type_shadowed.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/warning_34_unused_type_shadowed.res create mode 100644 tests/ounit_tests/ounit_type_path_memo_tests.ml create mode 100644 tests/tests/src/type_path_lookup_test.mjs create mode 100644 tests/tests/src/type_path_lookup_test.res diff --git a/changes/type-path-memo.polish.md b/changes/type-path-memo.polish.md new file mode 100644 index 0000000000..570205b4ec --- /dev/null +++ b/changes/type-path-memo.polish.md @@ -0,0 +1 @@ +- Build: remember type path lookups within a compilation, which avoids looking up the same types such as `option` and `string` hundreds of thousands of times per build. diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index 7b86f96de7..1816866950 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -1206,11 +1206,11 @@ let expand_abbrev_gen kind find_type_expansion env ty = ty' | None -> ( match find_type_expansion path env with - | exception Not_found -> + | exception Not_found -> ( (* another way to expand is to normalize the path itself *) - let path' = Env.normalize_path None env path in - if Path.same path path' then raise Cannot_expand - else newty2 level (Tconstr (path', args, abbrev)) + match Env.normalize_type_path env path with + | None -> raise Cannot_expand + | Some path' -> newty2 level (Tconstr (path', args, abbrev))) | params, body, lv -> (* prerr_endline ("add a "^string_of_kind kind^" expansion for "^Path.name path);*) diff --git a/compiler/ml/env.ml b/compiler/ml/env.ml index 0659044773..9f9040f9f7 100644 --- a/compiler/ml/env.ml +++ b/compiler/ml/env.ml @@ -549,11 +549,156 @@ type pers_struct = { ps_filename: string; } +(* Request-local memo of type path lookups ([find_type_full] on regular + paths) and of [normalize_path] calls that leave a type path unchanged. + + The typechecker resolves the same type paths over and over (expanding + [option], [Js.Null.t], ... in [expand_head], [update_level], [occur_univar], + ...), each time walking the [open] layers of [env.types] or the components + of a persistent module. Both lookups only read immutable environment tables + ([env.types] for [Pident] type paths, [env.components] for [Pdot] ones, + [env.modules] and [env.components] for normalization) plus request-wide + state that only grows: persistent structures (replacing one starts a new + memo epoch, see [add_persistent_structure]) and module components, which + are forced at most once. An entry is therefore + reused only when the tables it read are physically the same, and only + successful results are stored. A repeated call has no side effect the memo + would skip: the first, uncached call already loaded the [.cmi]s and forced + the lazy components it needed. Paths that contain a functor application are + never cached ([find_module_descr] applies the functor against [env]), and + the memo is bypassed while [.cmi] loading is disabled ([without_cmis] may + backtrack components). *) +module Type_path_memo = struct + (* Powers of two. A table starts empty, and only allocates its first array + when it stores an entry, so that a process that doesn't typecheck (such as + a parse with -bs-ast) allocates none. It grows when it has stored as many + entries as it has slots since it last grew, which keeps a small + compilation from allocating the full size. *) + let initial_size = 64 + let max_size = 4096 + + let string_hash s = + let n = String.length s in + if n = 0 then 0 + else + (n * 31) + + (Char.code (String.unsafe_get s 0) * 7) + + Char.code (String.unsafe_get s (n - 1)) + + exception Not_cacheable + + (* Consistent with [equal]: it ignores [pos] and ident flags, which no lookup + reads. *) + let rec hash (path : Path.t) = + match path with + | Pident id -> (id.Ident.stamp * 65599) + string_hash id.name + | Pdot (p, s, _pos) -> (hash p * 31) + string_hash s + | Papply _ -> raise_notrace Not_cacheable + + (* Paths that every lookup in this file resolves identically: identifiers are + looked up by name and stamp, and components by name. *) + let rec equal (p1 : Path.t) (p2 : Path.t) = + p1 == p2 + || + match (p1, p2) with + | Pident id1, Pident id2 -> + id1.Ident.stamp = id2.Ident.stamp && String.equal id1.name id2.name + | Pdot (p1, s1, _), Pdot (p2, s2, _) -> String.equal s1 s2 && equal p1 p2 + | _ -> false + + type ('types, 'modules, 'components, 'result) entry = { + mutable epoch: unit ref; + mutable path: Path.t; + mutable types: 'types; + mutable modules: 'modules; + mutable components: 'components; + mutable result: 'result; + } + + type ('types, 'modules, 'components, 'result) t = { + mutable entries: + ('types, 'modules, 'components, 'result) entry option array; + mutable stores: int; (** Since [entries] was allocated. *) + } + + let create () = {entries = [||]; stores = 0} + + let clear t = Array.fill t.entries 0 (Array.length t.entries) None + + (* The entry in the slot of a path whose [hash] is [h]. *) + let find t h = + let entries = t.entries in + let n = Array.length entries in + if n = 0 then None else Array.unsafe_get entries (h land (n - 1)) + + (* Stores an entry in the slot of a path whose [hash] is [h]. An entry is + only referenced from its slot, so the one it replaces is updated in place + instead of allocating another: a file that declares many types changes + [env.types] often, and stores the paths it looks up again each time. *) + let store t h ~epoch ~path ~types ~modules ~components ~result = + let n = Array.length t.entries in + if n = 0 then t.entries <- Array.make initial_size None + else if t.stores >= n && n < max_size then ( + let old = t.entries in + let entries = Array.make (n * 2) None in + Array.iter + (function + | None -> () + | Some e as slot -> + Array.unsafe_set entries (hash e.path land ((n * 2) - 1)) slot) + old; + t.entries <- entries; + t.stores <- 0); + t.stores <- t.stores + 1; + let entries = t.entries in + let i = h land (Array.length entries - 1) in + match Array.unsafe_get entries i with + | Some e -> + e.epoch <- epoch; + e.path <- path; + e.types <- types; + e.modules <- modules; + e.components <- components; + e.result <- result + | None -> + Array.unsafe_set entries i + (Some {epoch; path; types; modules; components; result}) +end + +(* The tables are allocated once per domain rather than per request: they can + grow large, and requests are small. An entry is valid only in the epoch that + stored it. Each request starts a fresh epoch (and a nested request restores + the outer one when it returns), so entries never cross requests; clearing + starts a new epoch too. *) +let type_path_memo_key = + Domain.DLS.new_key (fun () -> + (Type_path_memo.create (), Type_path_memo.create ())) + +let type_path_memo_epoch_key = Request_local.new_key (fun () -> ref (ref ())) +let type_path_memo_epoch () = !(Domain.DLS.get type_path_memo_epoch_key) + +let clear_type_path_memo_tables () = + let found, unchanged = Domain.DLS.get type_path_memo_key in + Type_path_memo.clear found; + Type_path_memo.clear unchanged + +let clear_type_path_memo () = + Domain.DLS.get type_path_memo_epoch_key := ref (); + clear_type_path_memo_tables () + let persistent_structures_key = Request_local.new_key (fun () -> (Hashtbl.create 17 : (string, pers_struct option) Hashtbl.t)) let persistent_structures () = Domain.DLS.get persistent_structures_key +(* [Hashtbl.add] shadows an earlier binding for [name], which the type path + memo may have read (directly, or as a missing module), so replacing one + starts a new memo epoch. *) +let add_persistent_structure name ps = + let tbl = persistent_structures () in + if Hashtbl.mem tbl name then clear_type_path_memo (); + Hashtbl.add tbl name ps + (* Consistency between persistent structures *) let crc_units_key = Request_local.new_key Consistbl.create @@ -590,7 +735,7 @@ let check_consistency ps = let save_pers_struct crc ps = let modname = ps.ps_name in - Hashtbl.add (persistent_structures ()) modname (Some ps); + add_persistent_structure modname (Some ps); Consistbl.set (crc_units ()) modname crc ps.ps_filename; add_import modname @@ -635,7 +780,7 @@ let acknowledge_pers_struct check modname {Persistent_signature.filename; cmi} = if ps.ps_name <> modname then error (Illegal_renaming (modname, ps.ps_name, filename)); if check then check_consistency ps; - Hashtbl.add (persistent_structures ()) modname (Some ps); + add_persistent_structure modname (Some ps); ps let read_pers_struct check modname filename = @@ -656,7 +801,7 @@ let find_pers_struct check name = match !Persistent_signature.load ~unit_name:name with | Some ps -> ps | None -> - Hashtbl.add (persistent_structures ()) name None; + add_persistent_structure name None; raise Not_found in add_import name; @@ -701,6 +846,7 @@ let check_pers_struct name = let reset_cache () = current_unit () := ""; + clear_type_path_memo (); Hashtbl.clear (persistent_structures ()); clear_imports (); Hashtbl.clear (value_declarations ()); @@ -717,13 +863,16 @@ let reset_cache_toplevel () = (persistent_structures ()) [] in List.iter (Hashtbl.remove (persistent_structures ())) l; + clear_type_path_memo (); Hashtbl.clear (value_declarations ()); Hashtbl.clear (type_declarations ()); Hashtbl.clear (module_declarations ()); Hashtbl.clear (used_constructors ()); Hashtbl.clear (prefixed_sg ()) -let set_unit_name name = current_unit () := name +let set_unit_name name = + clear_type_path_memo (); + current_unit () := name let get_unit_name () = !(current_unit ()) @@ -770,11 +919,36 @@ let type_of_cstr path = function (d, ([], List.map snd (Datarepr.labels_of_type path d))) | _ -> assert false +(* [find_type_full p env] for a regular type path, memoized as described at + [Type_path_memo]. *) +let find_regular_type_full p env = + match !(can_load_cmis ()) with + | Cannot_load_cmis _ -> find_type_full p env + | Can_load_cmis -> ( + match Type_path_memo.hash p with + | exception Type_path_memo.Not_cacheable -> find_type_full p env + | h -> ( + let memo, _ = Domain.DLS.get type_path_memo_key in + let epoch = type_path_memo_epoch () in + match Type_path_memo.find memo h with + | Some e + when e.epoch == epoch + && (match p with + | Pident _ -> e.types == env.types + | Pdot _ | Papply _ -> e.components == env.components) + && Type_path_memo.equal e.path p -> + e.result + | _ -> + let result = find_type_full p env in + Type_path_memo.store memo h ~epoch ~path:p ~types:env.types ~modules:() + ~components:env.components ~result; + result)) + let find_type_full path env = match Path.constructor_typath path with | Regular p -> ( try (Path_map.find p env.local_constraints, ([], [])) - with Not_found -> find_type_full p env) + with Not_found -> find_regular_type_full p env) | Cstr (ty_path, s) -> let _, (cstrs, _) = try find_type_full ty_path env with Not_found -> assert false @@ -881,6 +1055,41 @@ let normalize_path oloc env path = | Some loc -> raise (Error (Missing_module (loc, path, normalize_path true env path)))) +(* [Some (normalize_path None env path)] when normalization changes [path] + ([Path.same] is false), [None] when it leaves it unchanged. The unchanged + outcome is memoized as described at [Type_path_memo]; a changed path is + always computed afresh, so callers get a new path value as before. *) +(* Not a closure in [normalize_type_path], which would be allocated on every + call, hits included. *) +let normalize_type_path_uncached env path = + let path' = normalize_path None env path in + if Path.same path path' then None else Some path' + +let normalize_type_path env path = + match !(can_load_cmis ()) with + | Cannot_load_cmis _ -> normalize_type_path_uncached env path + | Can_load_cmis -> ( + match Type_path_memo.hash path with + | exception Type_path_memo.Not_cacheable -> + normalize_type_path_uncached env path + | h -> ( + let _, memo = Domain.DLS.get type_path_memo_key in + let epoch = type_path_memo_epoch () in + match Type_path_memo.find memo h with + | Some e + when e.epoch == epoch && e.modules == env.modules + && e.components == env.components + && Type_path_memo.equal e.path path -> + None + | _ -> + let result = normalize_type_path_uncached env path in + (match result with + | None -> + Type_path_memo.store memo h ~epoch ~path ~types:() + ~modules:env.modules ~components:env.components ~result:() + | Some _ -> ()); + result)) + let normalize_path_prefix oloc env path = match path with | Pdot (p, s, pos) -> Pdot (normalize_path oloc env p, s, pos) @@ -1953,7 +2162,25 @@ let reset_initial_for_request () = let with_fresh_initial action = let previous = initial_safe_string () in Fun.protect action ~finally:(fun () -> - Domain.DLS.set initial_safe_string_key previous) + Domain.DLS.set initial_safe_string_key previous; + (* The per-domain memo tables would otherwise keep the finished + request's environments alive until their slots are overwritten. Their + entries are already invalid outside the request's epoch. *) + clear_type_path_memo_tables ()) + +module For_test = struct + let type_path_memo_entries () = + let found, unchanged = Domain.DLS.get type_path_memo_key in + let count (t : _ Type_path_memo.t) = + Array.fold_left + (fun n e -> + match e with + | None -> n + | Some _ -> n + 1) + 0 t.entries + in + count found + count unchanged +end let last_env_key = Request_local.new_key (fun () -> ref empty) let last_env () = Domain.DLS.get last_env_key diff --git a/compiler/ml/env.mli b/compiler/ml/env.mli index a2ebfcaf66..8831acc840 100644 --- a/compiler/ml/env.mli +++ b/compiler/ml/env.mli @@ -26,6 +26,8 @@ val empty : t val initial_safe_string : unit -> t val reset_initial_for_request : unit -> unit val with_fresh_initial : (unit -> 'a) -> 'a +(* Runs a request with its own initial environment; on return, also empties + this domain's type path memo. *) type type_descriptions = constructor_description list * label_description list @@ -65,6 +67,10 @@ val normalize_path : Location.t option -> t -> Path.t -> Path.t If the option is None, allow returning dangling paths. Otherwise raise a Missing_module error, and may add forgotten head as required global. *) +val normalize_type_path : t -> Path.t -> Path.t option +(* [normalize_type_path env path] is [Some (normalize_path None env path)] when + that differs from [path] according to [Path.same], and [None] otherwise. *) + val normalize_path_prefix : Location.t option -> t -> Path.t -> Path.t (* Only normalize the prefix part of the path *) @@ -285,3 +291,8 @@ module Persistent_signature : sig the .cmi file in the load path. This function can be overridden to load it from memory, for instance to build a self-contained toplevel. *) end + +module For_test : sig + val type_path_memo_entries : unit -> int + (** The type path memo entries held on this domain. *) +end diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 59ce0e57b7..bcb116cb8d 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -814,9 +814,10 @@ let rec expand_path env p = match repr ty with | {desc = Tconstr (p, _, _)} -> expand_path env p | _ -> p (* PR#6394: recursive module may introduce incoherent manifest *)) - | _ -> - let p' = Env.normalize_path None env p in - if Path.same p p' then p else expand_path env p' + | _ -> ( + match Env.normalize_type_path env p with + | None -> p + | Some p' -> expand_path env p') let compare_type_path env tpath1 tpath2 = Path.same (expand_path env tpath1) (expand_path env tpath2) diff --git a/tests/build_tests/super_errors/expected/warning_34_unused_type_shadowed.res.expected b/tests/build_tests/super_errors/expected/warning_34_unused_type_shadowed.res.expected new file mode 100644 index 0000000000..d49d1178e3 --- /dev/null +++ b/tests/build_tests/super_errors/expected/warning_34_unused_type_shadowed.res.expected @@ -0,0 +1,47 @@ + + Warning number 44 + /.../fixtures/warning_34_unused_type_shadowed.res:14:3-12 + + 12 ┆ } + 13 ┆ + 14 ┆ open Inner + 15 ┆ let w: t = w + 16 ┆ let v = (Some(String.length(w)): option) + + this open statement shadows the type identifier t (which is later used) + + + Warning number 34 + /.../fixtures/warning_34_unused_type_shadowed.res:5:3-22 + + 3 │ let w: string + 4 │ } = { + 5 │ type t = option + 6 │ type unusedAlias = option + 7 │ + + unused type t. + + + Warning number 34 + /.../fixtures/warning_34_unused_type_shadowed.res:6:3-32 + + 4 │ } = { + 5 │ type t = option + 6 │ type unusedAlias = option + 7 │ + 8 │ module Inner = { + + unused type unusedAlias. + + + Warning number 34 + /.../fixtures/warning_34_unused_type_shadowed.res:10:5-24 + + 8 ┆ module Inner = { + 9 ┆ type t = string + 10 ┆ type unusedInner = t + 11 ┆ let w: t = "w" + 12 ┆ } + + unused type unusedInner. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/warning_34_unused_type_shadowed.res b/tests/build_tests/super_errors/fixtures/warning_34_unused_type_shadowed.res new file mode 100644 index 0000000000..20632507c9 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/warning_34_unused_type_shadowed.res @@ -0,0 +1,17 @@ +module M: { + let v: option + let w: string +} = { + type t = option + type unusedAlias = option + + module Inner = { + type t = string + type unusedInner = t + let w: t = "w" + } + + open Inner + let w: t = w + let v = (Some(String.length(w)): option) +} diff --git a/tests/ounit_tests/ounit_compiler_request_tests.ml b/tests/ounit_tests/ounit_compiler_request_tests.ml index 38278613ad..2465f3f4b9 100644 --- a/tests/ounit_tests/ounit_compiler_request_tests.ml +++ b/tests/ounit_tests/ounit_compiler_request_tests.ml @@ -1353,6 +1353,74 @@ let ctype_memo_reset_tests _context = (Ctype.For_test.previous_env_is_empty ()) "the expansion environment does not outlive its request") +(* Consecutive requests reuse identifier stamps, so the same path text with + the same stamps names different declarations in each request. Requests that + compile such units one after another give the output of cold compiles, and + a finished request leaves no type path memo entry behind to keep its + environments alive. The memo is also cleared when a request starts + ([Env.reset_cache], [Env.set_unit_name]), so this does not exercise the + memo's per-environment guards; Ounit_type_path_memo_tests does. *) +let type_path_memo_isolation_tests _context = + with_temp_dir "rewatch-driver-type-path-memo-" (fun root -> + let js name = read_file (Filename.concat root (name ^ ".js")) in + let compile name = + let _, result = run root ~extra:["-I"; root] (name ^ ".res") in + assert_equal ~printer:string_of_int 0 result.exit_code + ~msg:(name ^ ": " ^ result.stderr) + in + let unit_source t literal = + String.concat "\n" + [ + "type t = " ^ t; + "type box = {value: t, next: option}"; + "let make = (v: t) => {value: v, next: Some(v)}"; + "let literal: t = " ^ literal; + "let boxed = make(literal)"; + "let value = (b: box): option => b.next"; + ""; + ] + in + write root "IntBox.res" (unit_source "int" "1"); + write root "StringBox.res" (unit_source "string" "\"one\""); + compile "StringBox"; + let cold_string = js "StringBox" in + compile "IntBox"; + let cold_int = js "IntBox" in + assert_equal ~printer:string_of_int 0 + (Env.For_test.type_path_memo_entries ()) + ~msg:"the type path memo is empty after a request"; + compile "StringBox"; + assert_equal ~printer:Fun.id cold_string (js "StringBox") + ~msg:"a request after a same-shaped unit compiles as a cold one"; + compile "IntBox"; + assert_equal ~printer:Fun.id cold_int (js "IntBox"); + (* A unit's types change between requests that look them up. *) + write root "Lib.res" "type t = int\nlet zero: t = 0\n"; + compile "Lib"; + write root "Use.res" "let one: Lib.t = 1\nlet zero: Lib.t = Lib.zero\n"; + compile "Use"; + write root "Lib.res" "type t = string\nlet zero: t = \"\"\n"; + compile "Lib"; + let _, stale = run root ~extra:["-I"; root] "Use.res" in + assert_equal ~printer:string_of_int 2 stale.exit_code ~msg:"Use"; + check + (contains_text stale.stderr "string") + "a later request sees the recompiled unit's type"; + (* A unit with an interface reads its own .cmi, then records the saved + signature for the same name, inside one request. *) + write root "Sealed.resi" "type t\nlet make: int => t\nlet get: t => int\n"; + write root "Sealed.res" + "type t = int\nlet make = (n: int): t => n\nlet get = (x: t) => x\n"; + expect_code 0 (snd (run root ~extra:["-I"; root] "Sealed.resi")); + expect_code 0 + (snd (run root ~extra:["-I"; root; "-bs-read-cmi"] "Sealed.res")); + write root "UseSealed.res" + "let v = Sealed.get(Sealed.make(2))\nlet w: Sealed.t = Sealed.make(v)\n"; + compile "UseSealed"; + write root "Leak.res" "let bad: Sealed.t = 1\n"; + let _, leaked = run root ~extra:["-I"; root] "Leak.res" in + assert_equal ~printer:string_of_int 2 leaked.exit_code ~msg:"Leak") + let package_and_load_path_isolation_tests _context = with_temp_dir "rewatch-driver-load-roots-" (fun root -> let first = Filename.concat root "first" in @@ -1717,6 +1785,7 @@ let suites = "ctype_level_isolation" >:: ctype_level_isolation_tests; "free_variable_isolation" >:: free_variable_isolation_tests; "ctype_memo_reset" >:: ctype_memo_reset_tests; + "type_path_memo_isolation" >:: type_path_memo_isolation_tests; "shared_type_graph_isolation" >:: shared_type_graph_isolation_tests; "dependency_extraction_isolation" >:: dependency_extraction_isolation_tests; diff --git a/tests/ounit_tests/ounit_tests_main.ml b/tests/ounit_tests/ounit_tests_main.ml index d53bffff6c..a4995fdad9 100644 --- a/tests/ounit_tests/ounit_tests_main.ml +++ b/tests/ounit_tests/ounit_tests_main.ml @@ -36,6 +36,7 @@ let suites = Ounit_typeopt_tests.suites; Ounit_gentype_tests.suites; Ounit_compiler_request_tests.suites; + Ounit_type_path_memo_tests.suites; Ounit_find_in_path_tests.suites; Ounit_build_file_store_tests.suites; ] diff --git a/tests/ounit_tests/ounit_type_path_memo_tests.ml b/tests/ounit_tests/ounit_type_path_memo_tests.ml new file mode 100644 index 0000000000..c57aaf37ad --- /dev/null +++ b/tests/ounit_tests/ounit_type_path_memo_tests.ml @@ -0,0 +1,124 @@ +open Types + +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) + +(* Env memoizes type path lookups. The same path, with the same identifier + stamps, can name different declarations in different environments of one + request: typedecl first enters abstract placeholders for a recursive group + and then the real declarations under the same identifiers, and recursive + modules are typed against an approximation first. Each lookup must answer + for the environment it is given, whatever an earlier lookup of the same + path cached. *) + +let declaration manifest = + { + type_params = []; + type_arity = 0; + type_kind = Type_abstract; + type_private = Asttypes.Public; + type_manifest = manifest; + type_variance = []; + type_newtype_level = None; + type_loc = Location.none; + type_attributes = []; + type_immediate = false; + type_representation = Boxed; + type_shape = Unstated; + type_inlined_types = []; + } + +let abstract () = declaration None +let int_alias () = declaration (Some (Predef.type_int ())) + +let has_manifest decl = decl.type_manifest <> None + +let check message condition = OUnit.assert_bool message condition + +let suites = + __FILE__ + >::: [ + ( "an identifier bound to different declarations" >:: fun _ -> + let id = Ident.create "t" in + let placeholder = abstract () and real = int_alias () in + let first = Env.add_type ~check:false id placeholder Env.empty in + let second = Env.add_type ~check:false id real Env.empty in + let path = Path.Pident id in + check "the first environment's declaration" + (Env.find_type path first == placeholder); + check "the second environment's declaration" + (Env.find_type path second == real); + check "the first environment's declaration again" + (Env.find_type path first == placeholder) ); + ( "a module bound to different signatures" >:: fun _ -> + let module_id = Ident.create "M" and type_id = Ident.create "t" in + let signature decl = + Mty_signature [Sig_type (type_id, decl, Trec_not)] + in + let approximated = + Env.add_module module_id (signature (abstract ())) Env.empty + in + let real = + Env.add_module module_id (signature (int_alias ())) Env.empty + in + let path = Path.Pdot (Path.Pident module_id, "t", 0) in + check "the approximation is abstract" + (not (has_manifest (Env.find_type path approximated))); + check "the real module has the manifest" + (has_manifest (Env.find_type path real)); + check "the approximation is still abstract" + (not (has_manifest (Env.find_type path approximated))) ); + ( "a module that is an alias in only one environment" >:: fun _ -> + let target = Ident.create "Target" + and module_id = Ident.create "A" in + let type_id = Ident.create "t" in + let signature = + Mty_signature [Sig_type (type_id, int_alias (), Trec_not)] + in + let base = Env.add_module target signature Env.empty in + let plain = Env.add_module module_id signature base in + let alias = + Env.add_module module_id + (Mty_alias (Mta_present, Path.Pident target)) + base + in + let path = Path.Pdot (Path.Pident module_id, "t", 0) in + check "a plain module leaves the path unchanged" + (Env.normalize_type_path plain path = None); + (match Env.normalize_type_path alias path with + | Some normalized -> + check "an alias normalizes to its target" + (Path.same normalized (Path.Pdot (Path.Pident target, "t", 0))) + | None -> OUnit.assert_failure "an alias normalizes the path"); + check "the plain module still leaves the path unchanged" + (Env.normalize_type_path plain path = None) ); + ( "lookups while the memo grows" >:: fun _ -> + (* The memo's tables start small and grow, moving their entries, as + lookups store more; a replaced entry is updated in place. The + test runs in a fresh domain, whose tables start empty. *) + Domain.join @@ Domain.spawn + @@ fun () -> + let bindings = + List.init 3000 (fun i -> + (Ident.create (Printf.sprintf "t%d" i), abstract ())) + in + let env = + List.fold_left + (fun env (id, decl) -> Env.add_type ~check:false id decl env) + Env.empty bindings + in + let first_id, first_decl = List.hd bindings in + let other = Env.add_type ~check:false first_id (int_alias ()) env in + let first = Env.find_type (Path.Pident first_id) env in + for _ = 1 to 2 do + List.iter + (fun (id, decl) -> + check "each identifier's declaration" + (Env.find_type (Path.Pident id) env == decl)) + bindings; + check "the other environment's declaration" + (has_manifest (Env.find_type (Path.Pident first_id) other)) + done; + check "an earlier result is unchanged" (first == first_decl); + check "the memo grew past its first table" + (Env.For_test.type_path_memo_entries () > 64) ); + ] diff --git a/tests/tests/src/type_path_lookup_test.mjs b/tests/tests/src/type_path_lookup_test.mjs new file mode 100644 index 0000000000..b83a9c8498 --- /dev/null +++ b/tests/tests/src/type_path_lookup_test.mjs @@ -0,0 +1,274 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Mocha from "mocha"; +import * as Test_utils from "./test_utils.mjs"; +import * as Stdlib_List from "@rescript/runtime/lib/es6/Stdlib_List.mjs"; + +let after = "two"; + +let Inner = { + before: 1, + after: after +}; + +let Rec = {}; + +function fromOpen() { + return 3; +} + +function afterOpen() { + return "after"; +} + +let Shadow = { + v: 10 +}; + +function shadowed() { + return "shadowed!"; +} + +let unshadowed = 11; + +let Color = {}; + +function colourName(c) { + if (c === "Red") { + return "red"; + } else { + return "green"; + } +} + +function colorAsColour(c) { + return c; +} + +function make(n) { + return (n << 1); +} + +function get(n) { + return n; +} + +let Counter = { + make: make, + get: get +}; + +function Wrap(V) { + let wrapped = V.value; + let describe = () => "<" + V.show(wrapped) + ">"; + return { + wrapped: wrapped, + describe: describe + }; +} + +function describe() { + return "<" + (4).toString() + ">"; +} + +let IntWrap = { + wrapped: 4, + describe: describe +}; + +let value = "s"; + +function describe$1() { + return ""; +} + +let StringWrap = { + wrapped: value, + describe: describe$1 +}; + +let wrappedSum = 5; + +let wrappedString = "s!"; + +function showPacked(m) { + return m.show(m.value); +} + +let packedInt = (7).toString(); + +function pair(x) { + return [ + x, + x + ]; +} + +let tree = { + TAG: "Branch", + _0: {hd: { + TAG: "Leaf", + _0: 1 + }, tl: {hd: { + TAG: "Branch", + _0: /* [] */0 + }, tl: /* [] */0}} +}; + +function branchCount(n) { + if (n.TAG === "Leaf") { + return 0; + } else { + return Stdlib_List.length(n._0); + } +} + +function width(t) { + if (typeof t !== "object") { + return 0; + } else { + return Stdlib_List.length(t._0); + } +} + +function size(t) { + if (typeof t !== "object") { + return 1; + } else { + return 1 + Forest.size(t._0) | 0; + } +} + +let Tree = { + size: size, + width: width +}; + +function size$1(f) { + return Stdlib_List.reduce(f, 0, (acc, t) => acc + size(t) | 0); +} + +let Forest = { + size: size$1 +}; + +Mocha.describe("Type_path_lookup_test", () => { + Mocha.test("shadowed and opened types", () => { + Test_utils.eq("File \"type_path_lookup_test.res\", line 171, characters 7-14", [ + 1, + "two" + ], [ + 1, + after + ]); + Test_utils.eq("File \"type_path_lookup_test.res\", line 172, characters 7-14", [ + 3, + "after" + ], [ + 3, + "after" + ]); + Test_utils.eq("File \"type_path_lookup_test.res\", line 173, characters 7-14", [ + "shadowed!", + 11 + ], [ + "shadowed!", + unshadowed + ]); + }); + Mocha.test("aliases and constraints", () => { + Test_utils.eq("File \"type_path_lookup_test.res\", line 176, characters 7-14", [ + "red", + "green" + ], [ + "red", + "green" + ]); + Test_utils.eq("File \"type_path_lookup_test.res\", line 177, characters 7-14", 6, 6); + }); + Mocha.test("functors, first-class and recursive modules", () => { + Test_utils.eq("File \"type_path_lookup_test.res\", line 180, characters 7-14", [ + 5, + "s!" + ], [ + wrappedSum, + wrappedString + ]); + Test_utils.eq("File \"type_path_lookup_test.res\", line 181, characters 7-14", [ + "<4>", + "" + ], [ + describe(), + describe$1() + ]); + Test_utils.eq("File \"type_path_lookup_test.res\", line 182, characters 7-14", [ + "7", + [ + 1, + 1 + ] + ], [ + packedInt, + [ + 1, + 1 + ] + ]); + Test_utils.eq("File \"type_path_lookup_test.res\", line 183, characters 7-14", 3, size({ + TAG: "Node", + _0: {hd: "Leaf", tl: {hd: { + TAG: "Node", + _0: /* [] */0 + }, tl: /* [] */0}} + })); + Test_utils.eq("File \"type_path_lookup_test.res\", line 184, characters 7-14", [ + 2, + 2 + ], [ + branchCount(tree), + width({ + TAG: "Node", + _0: {hd: "Leaf", tl: {hd: "Leaf", tl: /* [] */0}} + }) + ]); + }); +}); + +let first = 1; + +let second = after; + +let Colour; + +let Counter$make = make; + +export { + Inner, + first, + second, + Rec, + fromOpen, + afterOpen, + Shadow, + shadowed, + unshadowed, + Color, + Colour, + colourName, + colorAsColour, + Counter, + Wrap, + IntWrap, + StringWrap, + wrappedSum, + wrappedString, + showPacked, + packedInt, + pair, + tree, + branchCount, + Tree, + Forest, + Counter$make, +} +/* packedInt Not a pure module */ diff --git a/tests/tests/src/type_path_lookup_test.res b/tests/tests/src/type_path_lookup_test.res new file mode 100644 index 0000000000..687c2eb06e --- /dev/null +++ b/tests/tests/src/type_path_lookup_test.res @@ -0,0 +1,186 @@ +open Mocha +open Test_utils + +// The type checker memoizes type path lookups per request. Each section +// resolves the same type path text against environments that bind it +// differently, so a stale lookup would make it fail to type check or change +// the generated code. + +// A type shadowed in a nested module, then used again outside it. +type t = int + +module Inner = { + let before: t = 1 + type t = string + let after: t = "two" +} + +let first: t = Inner.before +let second = Inner.after + +// A local open shadows a type, and the outer type is used again afterwards. +module Rec = { + type t = {a: int} +} + +type r = {b: string} + +let fromOpen = () => { + open Rec + let v: t = {a: 3} + v.a +} + +let afterOpen = () => { + let v: r = {b: "after"} + v.b +} + +// A local module shadows a top-level module of the same name. +module Shadow = { + type t = int + let v: t = 10 +} + +let shadowed = () => { + module Shadow = { + type t = string + let v: t = "shadowed" + } + Shadow.v ++ "!" +} + +let unshadowed = Shadow.v + 1 + +// Module aliases: the alias path normalizes to the aliased module's type. +module Color = { + type t = Red | Green +} + +module Colour = Color + +let colourName = (c: Colour.t) => + switch c { + | Red => "red" + | Green => "green" + } + +let colorAsColour = (c: Color.t): Colour.t => c + +// A module type constraint makes a type abstract outside the module. +module Counter: { + type t + let make: int => t + let get: t => int +} = { + type t = int + let make = n => n * 2 + let get = n => n +} + +// Functor applications give the same type path different meanings. +module type Value = { + type t + let value: t + let show: t => string +} + +module Wrap = (V: Value) => { + type t = V.t + let wrapped: t = V.value + let describe = () => "<" ++ V.show(wrapped) ++ ">" +} + +module IntWrap = Wrap({ + type t = int + let value = 4 + let show = n => Int.toString(n) +}) + +module StringWrap = Wrap({ + type t = string + let value = "s" + let show = s => s +}) + +let wrappedSum = IntWrap.wrapped + 1 +let wrappedString = StringWrap.wrapped ++ "!" + +// First-class modules and locally abstract types. +let showPacked = (type a, m: module(Value with type t = a)) => { + module M = unpack(m) + M.show(M.value) +} + +let packedInt = showPacked( + module( + { + type t = int + let value = 7 + let show = n => Int.toString(n) + } + ), +) + +let pair = (type a, x: a): array => [x, x] + +// A recursive type group is checked with placeholder declarations first, +// then with the real ones under the same identifiers. +type rec node<'a> = Leaf('a) | Branch(branches<'a>) +and branches<'a> = list> + +let tree = Branch(list{Leaf(1), Branch(list{})}) + +let branchCount = (n: node) => + switch n { + | Leaf(_) => 0 + | Branch(b) => List.length(b) + } + +// Recursive modules refer to each other's types, and are typed against an +// approximation of their signatures first. +module rec Tree: { + type t = Leaf | Node(Forest.t) + let size: t => int + let width: t => int +} = { + type t = Leaf | Node(Forest.t) + + let width = t => + switch t { + | Leaf => 0 + | Node(f) => List.length(f) + } + + let size = t => + switch t { + | Leaf => 1 + | Node(f) => 1 + Forest.size(f) + } +} +and Forest: { + type t = list + let size: t => int +} = { + type t = list + let size = f => List.reduce(f, 0, (acc, t) => acc + Tree.size(t)) +} + +describe(__MODULE__, () => { + test("shadowed and opened types", () => { + eq(__LOC__, (1, "two"), (first, second)) + eq(__LOC__, (3, "after"), (fromOpen(), afterOpen())) + eq(__LOC__, ("shadowed!", 11), (shadowed(), unshadowed)) + }) + test("aliases and constraints", () => { + eq(__LOC__, ("red", "green"), (colourName(Red), colourName(colorAsColour(Green)))) + eq(__LOC__, 6, Counter.get(Counter.make(3))) + }) + test("functors, first-class and recursive modules", () => { + eq(__LOC__, (5, "s!"), (wrappedSum, wrappedString)) + eq(__LOC__, ("<4>", ""), (IntWrap.describe(), StringWrap.describe())) + eq(__LOC__, ("7", [1, 1]), (packedInt, pair(1))) + eq(__LOC__, 3, Tree.size(Node(list{Leaf, Node(list{})}))) + eq(__LOC__, (2, 2), (branchCount(tree), Tree.width(Node(list{Leaf, Leaf})))) + }) +})