diff --git a/CHANGELOG.md b/CHANGELOG.md index 9fad2cec27..6d7dc9e407 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -36,6 +36,8 @@ #### :house: Internal +- Add an opt-in immutable representation of compiled interfaces for OCaml rewatch experiments (`REWATCH_FROZEN_VALUES=1`), allowing selective lookup without eagerly expanding imported signatures. https://github.com/rescript-lang/rescript/pull/8676 + # 13.0.0-alpha.6 #### :boom: Breaking Change diff --git a/compiler/ml/IMMUTABLE_INTERFACES.md b/compiler/ml/IMMUTABLE_INTERFACES.md new file mode 100644 index 0000000000..599cd39159 --- /dev/null +++ b/compiler/ml/IMMUTABLE_INTERFACES.md @@ -0,0 +1,283 @@ +# Immutable compiled interfaces: experiment + +## Current boundary + +`Env` borrows decoded CMI graphs from a project cache, one request at a time. +The cache verifies their mutable fields at request end and restores a saved +marshaled image after a change. This avoids most repeated decoding, but it +cannot share a graph with concurrent compiler domains. The large alias cache +similarly shares a marshaled prepared image and gives each domain its own +decoded graph. + +The exposed `Types.type_expr` graph is unsuitable for direct sharing. Its +`desc`, `level`, and `id` fields are mutable. `Ctype.instance` temporarily +installs `Tsubst` marks in source nodes; `Subst` does the same while copying +signatures and component declarations. Abbreviation memos, polymorphic +variant row references, object-field mutability classes, `Ident` stamps, and +record layout references are also mutable. A caller can receive declarations +or component descriptions that refer back into the imported graph. + +## First measurement + +A local synthetic project used a 26 KiB `Api.cmi` with 400 exported integer +values, a polymorphic identity function, and a parameterized record. Two +hundred implementation modules each import it. Four compiler domains built +201 modules. The probe used the retained project cache and the exclusive +`REWATCH_TYPECHECK_TRACE` phase timer. The numbers below are **summed worker +time**, not wall-time savings, from one traced clean build on 2026-09-25. + +| Implementation-request work | Cached | Cache disabled | +| --- | ---: | ---: | +| CMI read and decode | 3.7 ms, 1.0 MB, 11 calls | 175.0 ms, 46.3 MB, 603 calls | +| Imported `Subst.signature` copies | 18.5 ms, 39.6 MB, 201 calls | 16.2 ms, 39.6 MB, 201 calls | +| Component-item construction, including `Subst` copies | 65.9 ms, 111.3 MB, 602 calls | 82.8 ms, 111.3 MB, 602 calls | +| CMI cache validation, capture, and verification | 26.2 ms, 6.0 MB | absent | + +The two consumer phases still allocate about 151 MB across the cached build. +Their time varies between runs, but their allocation is stable. The current +cache eliminates most decoding and does **not** eliminate those copies. A +representation that merely freezes and then fully thaws every interface for +each request would give much of the decoding cost back. The first version +should preserve these phase labels and add materialized-node counts so the +comparison is direct. + +The `frozen_type_graph_probe` microprobe used the same `Api.cmi` for 200 +operations in one process. The arena had 403 type roots and 403 type nodes. +Freezing those roots took 12.8 ms and 18.7 MB; thawing all of them took 7.8 +ms and 11.7 MB. Materializing only the first root 200 times took 0.14 ms and +0.7 MB. Decoding a marshaled **whole CMI** 200 times took 20.2 ms and 28.6 +MB; `Subst.signature` took 11.6 ms and 39.3 MB. For `Stdlib.cmi` (30 roots, +73 nodes), 200 full thaws took 0.45 ms and 2.4 MB. These are diagnostic +single-run measurements, not equivalent operations: the arena probe omits +signature metadata and component tables. They show that selective +materialization can be cheap, while full materialization leaves substantial +consumer work. + +The same probe on the larger `JsxDOMStyle.cmi` (505 roots, 1,010 nodes) took +1.5 ms and 2.9 MB for 20 full thaws; `Subst.signature` took 1.8 ms and 5.5 +MB. Another run measured 2.0 versus 1.7 ms, respectively. Whole-graph thaw +is in the same time range as the existing signature copy before metadata and +component work. This favors direct frozen lookups and per-use instantiation +over whole-interface thawing. + +This fixture stresses repeated flat value exports. It says little about +functors, recursive modules, large variants, deeply nested signatures, or +watch invalidation. Its trace cannot be extrapolated to the testrepo or a +production project. The testrepo's installed PPX in this workspace is a +macOS binary, so the local testrepo build failed before compiler measurements. + +## Proposed representation + +A project owns an `interface_image` assembled once from each accepted CMI: + +```text +interface_image + file identity + content digest + immutable identifier table (name, original stamp, flags, binder token) + immutable path table (identifier and path indices) + immutable type arena (indexed graph, levels, descriptor payloads) + immutable signature and declaration tables (indices into the same arenas) + immutable name/component indexes (values, types, constructors, labels, + modules, module types) +``` + +The arena uses integer edges rather than `type_expr` pointers, so it can +represent sharing and cycles without linkable source nodes. Every reference +in the image must lead to another immutable value; in particular, a `ref`, +array, mutable identifier, or mutable layout cannot be reachable through a +public accessor. The image is published to the project's workers only after +validation and complete construction. Its cache key includes the resolved +path and CMI identity; a changed or newly shadowing CMI gets a new image. +Existing CMI file format and digest semantics stay unchanged. + +Each compile request owns a small view over an image. The view maps image +binder tokens to request-local `Ident.t`s and applies module and type path +substitutions without copying the image. Ordinary value lookup returns a +scheme handle. Instantiation walks that frozen scheme with a **request-local** +memo from arena index to fresh `type_expr`, preserving aliases within one use +while giving sibling uses independent inference variables. `Tpoly` bound +variables and row references need the same rule. Object-field mutability +classes become fresh cells per generalized instance, preserving class +sharing inside that instance; non-generalized occurrences instead share a +request-local cell. Abbreviation expansions and speculative trail state live +in the request view, keyed by arena index, and never write into the image. + +Type constructor identity must come from the image's binder token plus its +instantiation context, rather than from a copied node's physical address. +Functor application creates a fresh request-local context; aliases that point +to the same exported constructor retain one token. This must be verified with +module inclusion, GADTs, recursive types, and polymorphic variants. Imported +record labels and constructor descriptions can be indexed immutably, but +their current mutable `lbl_all` and layout behavior needs request-local +overlays or an explicit immutable replacement before direct publication. + +The checker should keep `Types.type_expr` for local inference and typed-tree +output while imported schemes use a separate immutable type. The boundary is +an API, not a convention to refrain from writing to an ordinary `type_expr`. +Any operation that genuinely needs a mutable imported graph can materialize +only the reached subgraph in the request view and count those nodes. That +fallback preserves behavior while revealing whether consumers force costly +copying. + +## Prototype and integrated experiments + +`Frozen_type_graph` is an initial arena for type expressions. It +snapshots identifier and path data, object-field mutability equivalence +classes, and polymorphic-variant row references; it rejects active `Tsubst` +and abbreviation memo state. A request-local view lazily materializes roots +while preserving cycles and sharing. Unit tests exercise polymorphic +instantiation, aliasing, class independence, cycles, concurrent views, and +rejection of transient state. + +`Frozen_values` adds immutable indexes for exported values, all completed type +kinds, record labels, variant and extension constructors, modules, and module +types in nested signatures. It snapshots runtime layouts and inline-record +metadata. A module typed by a locally declared module type gets a separate +path-substitution context over the same immutable type arena, so repeated +uses retain distinct abstract type identities. Module aliases can traverse +to the target image, including another compilation unit. When +`REWATCH_FROZEN_VALUES=1`, `Env` builds the image once for each accepted CMI +in a project dependency cache and shares it between domains. + +Each compile request gets its own view and materializes reached declarations +and type nodes. Opened imports use on-demand name sources in `Env` instead of +building every component. Module and module-type declarations are decoded and +substituted one at a time; functor applications use a request-owned component +for the reached functor. Full-signature consumers and legacy component +expansion decode private copies from immutable signature bytes. Mutable label +and constructor descriptions, runtime layout references, and attribute +payloads belong to the view. Imported member identifiers use a reserved +stamp range, so materialization does not renumber identifiers emitted by the +compiling module. A failed arena snapshot or a shape that needs contextual +substitution still uses request-owned fallback structures. The CMI format is +unchanged and the flag remains off by default. + +The flag takes precedence over `REWATCH_COMBINED_SIGNATURE_CACHE`, including +its `force` setting. A namespace-open regression test confirms that the older +mutable combined snapshot is skipped. Avoiding eager expansion can change an +internal identifier stamp in a consumer's CMI, and therefore its self CRC, +even when the exported value, type, dependency CRCs, and JavaScript agree. +This can cause downstream rebuilds when switching flag settings. + +A values-only variant of the same synthetic fixture used 200 consumers and +four compiler domains. Each consumer accessed two `Api` values. With the +retained CMI cache active in both configurations, one traced clean build on +2026-09-25 gave the following **summed worker time and allocation**: + +| Implementation-request work | Existing path | Frozen values | +| --- | ---: | ---: | +| Component construction | 64.4 ms, 111.3 MB, 602 calls | 25.0 ms, 40.8 MB, 402 calls | +| `Api` component expansion | 200 calls | 0 calls | +| `Api` signature copy | 0.1 ms, 0.2 MB, 1 call | 0.1 ms, 0.2 MB, 1 call | +| Frozen image preparation | absent | 0.1 ms, 0.4 MB, 1 call | +| Direct frozen value lookup | absent | 1.4 ms, 0.3 MB, 600 calls | + +The signature-copy count reflects a separate path-normalization improvement: +normalizing a persistent compilation-unit root now validates its CMI without +copying the whole signature. Before that change, both configurations copied +`Api`'s signature 201 times, allocating 39.6 MB. The remaining copy checks +the implementation against `Api.resi`. + +Across all 201 implementation requests, summed worker time fell from 208.6 +to 176.0 ms and allocation from 174.8 to 107.1 MB. All 1,610 selected CMI, +CMJ, JavaScript, and AST artifacts in the two builds were byte-identical. In +11 interleaved clean-build pairs, median wall time +was 165.38 ms with the existing path and 161.07 ms with frozen values; eight +pairs favored frozen values. This is a small directional result for a +synthetic, flat interface, not a general speed estimate. The large residual +component work comes from dependencies outside the direct `Api` lookup path. +This was the first flat-interface measurement, before the nested, extension, +and opened-name work below. + +The next fixture exported 200 abstract types and 200 manifest aliases, with +each consumer mentioning one of each. On one traced clean build, 200 `Api` +component expansions disappeared. Component construction fell from 172.1 to +40.8 MB; allocation across all implementation requests fell from 287.8 to +107.3 MB. Summed worker time fell from 280.7 to 165.1 ms. The direct type +lookup phase took 1.3 ms and 0.9 MB for 2,600 calls. All 805 selected +artifacts were byte-identical. + +A mixed fixture with exported values and a record type exercises record-label +lookup too. Direct record and label lookup removed its 200 `Api` expansions: +component construction fell from 111.3 to 40.8 MB, total implementation +allocation from 182.2 to 109.4 MB, and summed worker time from 220.2 to +197.5 ms. Its 805 selected artifacts were also byte-identical. These are +single traced runs, not stable wall-time estimates. + +A variant fixture exported 200 variant types and had consumers construct and +match their constructors. Direct constructor lookup removed its 200 `Api` +expansions: component construction fell from 194.3 to 40.8 MB, total +implementation allocation from 281.6 to 109.5 MB, and summed worker time +from 298.7 to 175.8 ms. Its 805 selected artifacts were byte-identical. + +Interleaved clean-build pairs, with tracing disabled and four compiler +domains, measured the complete Rewatch build process (11 pairs for the first +three fixtures, 17 for the last two): + +| Fixture | Existing median wall time | Frozen median wall time | Frozen faster | +| --- | ---: | ---: | ---: | +| Abstract types and aliases | 184.54 ms | 165.14 ms | 11/11 pairs | +| Values and record | 170.75 ms | 165.17 ms | 7/11 pairs | +| Variants and constructors | 192.54 ms | 162.64 ms | 11/11 pairs | +| Modules, aliases, and functor use | 169.22 ms | 144.67 ms | 17/17 pairs | +| Opened values and record | 174.07 ms | 151.84 ms | 17/17 pairs | + +These are short synthetic builds on one machine. The larger gains occur when +the fixture's main dependency has many declarations that the old path copied +for every consumer; the mixed fixture shows a smaller wall-time gain despite +removing the same expansion count. + +The last two fixtures exercise broader interface shapes. The module fixture +exports 400 values, a module type, two modules ascribed to that type, an +alias, and a functor. Every consumer reads the modules and alias and applies +the functor. The opened fixture exports 400 values, an identity function, and +a record type; every consumer uses `open Api`. In one traced clean build with +201 implementation requests and four compiler domains: + +| Fixture | Existing implementation allocation | Frozen allocation | Existing component construction | Frozen component construction | `Api` expansions | +| --- | ---: | ---: | ---: | ---: | ---: | +| Modules | 193.6 MB | 74.8 MB | 113.3 MB, 1,403 calls | 0.2 MB, 201 calls | 200 → 0 | +| Opened interface | 183.6 MB | 71.9 MB | 111.5 MB, 602 calls | 0, 0 calls | 200 → 0 | + +Summed implementation worker time in those traced builds was 204.1 → +167.6 ms for modules and 248.5 → 148.6 ms for opened imports. The 17 +interleaved wall-time pairs above had tracing disabled. All 1,608 selected +module-fixture artifacts and all 1,610 opened-fixture artifacts matched byte +for byte across flag settings. These synthetic builds provide directional +evidence, not a production-project speed estimate. + +An initial type-image view eagerly built a substitution map for all 400 +binders in every request. It added about 64 MB across the fixture and kept +the component expansions. Replacing that with immutable binder indexes and +lazy path substitution removed that view-construction cost. A separate path +normalization probe showed that asking whether `Api.opaque` is a module +forced the entire `Api` component table; the immutable top-level type-name +index now answers that check without expanding the module. These two failures +illustrate why selective materialization has to include consumers outside +ordinary type lookup. + +To repeat the type-only microprobe after building the compiler, run +`opam exec -- dune build rewatch-ocaml/bench/frozen_type_graph_probe.exe` +and then invoke that executable with a CMI path and iteration count. The +synthetic project can be recreated with +`python3 rewatch-ocaml/bench/make_immutable_interface_fixture.py OUTPUT_DIRECTORY`. +It has `Api.resi` with 400 integer values, `id: 'a => 'a`, and +`type box<'a> = {value: 'a}`. Its 200 consumers each access one value and +call `Api.id`; `--values-only` omits the record use, `--types-only` generates +the abstract-type and alias fixture, `--variants-only` generates the variant +fixture, `--modules-only` exercises module types, aliases, and a functor, and +`--open-only` exercises an opened interface. +Build it with the embedded OCaml +Rewatch executable, four domains, and `REWATCH_TYPECHECK_TRACE` set to an +absolute TSV path; compare clean builds with `REWATCH_FROZEN_VALUES` absent and +set to `1`. Analyze both files with +`rewatch-ocaml/bench/analyze_typecheck_trace.js`. + +Direct indexing still stops where the module shape depends on a functor +application or on a module-type identifier that cannot be resolved within the +same CMI. Those cases materialize request-owned declarations or components +from the image. Signature inclusion still requests a full copied signature. +The next validation should measure edit workloads, larger real projects, and +fallback frequency before enabling the flag by default. The goal remains to +remove repeated interface preparation without moving that cost into per-use +materialization. diff --git a/compiler/ml/README.md b/compiler/ml/README.md index 717e44fcd9..4b3c7febe1 100644 --- a/compiler/ml/README.md +++ b/compiler/ml/README.md @@ -59,6 +59,13 @@ For module inclusion and signature compatibility, start with : Substitution and copying across environments and persistence boundaries. `for_saving` has stronger independence requirements than an ordinary copy. +[`IMMUTABLE_INTERFACES.md`](IMMUTABLE_INTERFACES.md) +: Design and measurements for sharing compiled interfaces across compiler + domains. `Frozen_type_graph` is an experimental type arena; `Frozen_values` + indexes values, types, constructors, labels, modules, and module types in + nested signatures. `Env` uses its request-local views and lazy opened-name + tables when `REWATCH_FROZEN_VALUES=1`. + ## Polymorphic value positions A `Tpoly` node represents a type scheme, so the operation depends on whether diff --git a/compiler/ml/env.ml b/compiler/ml/env.ml index f118457678..209edec20a 100644 --- a/compiler/ml/env.ml +++ b/compiler/ml/env.ml @@ -169,8 +169,13 @@ module Tycomp_tbl = struct (** Symbolic representation of the last (innermost) open, if any. *) } + and 'a source = { + find: string -> 'a list option; + iter: (string -> 'a list -> unit) -> unit; + } + and 'a opened = { - components: (string, 'a list) Tbl.t; + components: 'a source; (** Components from the opened module. We keep a list of bindings for each name, as in comp_labels and comp_constrs. *) @@ -185,7 +190,15 @@ module Tycomp_tbl = struct let add id x tbl = {tbl with current = Ident.add id x tbl.current} - let add_open slot wrap components next = + let source_of_table table = + { + find = + (fun name -> + try Some (Tbl.find_str name table) with Not_found -> None); + iter = (fun callback -> Tbl.iter callback table); + } + + let add_open_source slot wrap components next = let using = match slot with | None -> None @@ -193,6 +206,9 @@ module Tycomp_tbl = struct in {current = Ident.empty; opened = Some {using; components; next}} + let add_open slot wrap components next = + add_open_source slot wrap (source_of_table components) next + let rec find_same id tbl = try Ident.find_same id tbl.current with Not_found as exn -> ( @@ -219,9 +235,9 @@ module Tycomp_tbl = struct | None -> [] | Some {using; next; components} -> ( let rest = find_all name next in - match Tbl.find_str name components with - | exception Not_found -> rest - | opened -> + match components.find name with + | None -> rest + | Some opened -> List.map (fun desc -> (desc, mk_callback rest name desc using)) opened @ rest) @@ -229,9 +245,10 @@ module Tycomp_tbl = struct let acc = Ident.fold_name (fun _id d -> f d) tbl.current acc in match tbl.opened with | Some {using = _; next; components} -> - acc - |> Tbl.fold (fun _name -> List.fold_right (fun desc -> f desc)) components - |> fold_name f next + let acc = ref acc in + components.iter (fun _name descriptions -> + acc := List.fold_right (fun desc -> f desc) descriptions !acc); + fold_name f next !acc | None -> acc let rec local_keys tbl acc = @@ -263,13 +280,17 @@ module Id_tbl = struct (** Symbolic representation of the last (innermost) open, if any. *) } + and 'a source = { + find: string -> ('a * int) option; + iter: (string -> 'a * int -> unit) -> unit; + } + 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. *) + components: 'a source; (** 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 @@ -281,7 +302,15 @@ module Id_tbl = struct let add id x tbl = {tbl with current = Ident.add id x tbl.current} - let add_open slot wrap root components next = + let source_of_table table = + { + find = + (fun name -> + try Some (Tbl.find_str name table) with Not_found -> None); + iter = (fun callback -> Tbl.iter callback table); + } + + let add_open_source slot wrap root components next = let using = match slot with | None -> None @@ -289,6 +318,9 @@ module Id_tbl = struct in {current = Ident.empty; opened = Some {using; root; components; next}} + let add_open slot wrap root components next = + add_open_source slot wrap root (source_of_table components) next + let rec find_same id tbl = try Ident.find_same id tbl.current with Not_found as exn -> ( @@ -303,8 +335,8 @@ module Id_tbl = struct with Not_found as exn -> ( match tbl.opened with | Some {using; root; next; components} -> ( - try - let descr, pos = Tbl.find_str name components in + match components.find name with + | Some (descr, pos) -> let res = (Pdot (root, name, pos), descr) in (if mark then match using with @@ -313,7 +345,7 @@ module Id_tbl = struct try f name (Some (snd (find_name false name next), snd res)) with Not_found -> f name None)); res - with Not_found -> find_name mark name next) + | None -> find_name mark name next) | None -> raise exn) let find_name name tbl = find_name true name tbl @@ -326,12 +358,25 @@ module Id_tbl = struct with Not_found -> ( match tbl.opened with | Some {root; using; next; components} -> ( - try - let desc, pos = Tbl.find_str name components in + match components.find name with + | Some (desc, pos) -> let new_desc = f desc in - let components = Tbl.add name (new_desc, pos) components in + let previous = components in + let components = + { + find = + (fun query -> + if query = name then Some (new_desc, pos) + else previous.find query); + iter = + (fun callback -> + previous.iter (fun query entry -> + callback query + (if query = name then (new_desc, pos) else entry))); + } + in {tbl with opened = Some {root; using; next; components}} - with Not_found -> + | None -> let next = update name f next in {tbl with opened = Some {root; using; next; components}}) | None -> tbl) @@ -344,10 +389,9 @@ 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) + match components.find name with + | Some (desc, pos) -> (Pdot (root, name, pos), desc) :: find_all name next + | None -> find_all name next) let rec fold_name f tbl acc = let acc = @@ -357,11 +401,10 @@ module Id_tbl = struct in match tbl.opened with | Some {root; using = _; next; components} -> - acc - |> Tbl.fold - (fun name (desc, pos) -> f name (Pdot (root, name, pos), desc)) - components - |> fold_name f next + let acc = ref acc in + components.iter (fun name (desc, pos) -> + acc := f name (Pdot (root, name, pos), desc) !acc); + fold_name f next !acc | None -> acc let rec local_keys tbl acc = @@ -374,10 +417,8 @@ module Id_tbl = struct 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) -> - f (Ident.hide (Ident.create s) (* ??? *)) (Pdot (root, s, pos), x)) - components; + components.iter (fun s (x, pos) -> + f (Ident.hide (Ident.create s) (* ??? *)) (Pdot (root, s, pos), x)); iter f next | None -> () @@ -414,6 +455,7 @@ type t = { and module_components = { deprecated: string option; loc: Location.t; + frozen_root: Frozen_values.view option; comps: ( t * Subst.t * Path.t * Types.module_type, module_components_repr option ) @@ -575,10 +617,17 @@ let strengthen = let md md_type = {md_type; md_attributes = []; md_loc = Location.none} let get_components_opt c = + let maker = + match c.frozen_root with + | None -> !components_of_module_maker' + | Some view -> + fun (env, sub, path, _) -> + let signature = Frozen_values.source_signature view in + !components_of_module_maker' (env, sub, path, Mty_signature signature) + in match !(can_load_cmis ()) with - | Can_load_cmis -> Env_lazy.force !components_of_module_maker' c.comps - | Cannot_load_cmis log -> - Env_lazy.force_logged log !components_of_module_maker' c.comps + | Can_load_cmis -> Env_lazy.force maker c.comps + | Cannot_load_cmis log -> Env_lazy.force_logged log maker c.comps let empty_structure = Structure_comps @@ -698,6 +747,8 @@ type pers_struct = { ps_filename: string; ps_flags: pers_flags list; ps_snapshot: request_snapshot option; + ps_frozen_values: Frozen_values.view option; + ps_frozen_components: (Path.t, module_components) Hashtbl.t; } [@@warning "-69"] @@ -706,6 +757,57 @@ let persistent_structures_key = (Hashtbl.create 17 : (string, pers_struct option) Hashtbl.t)) let persistent_structures () = Domain.DLS.get persistent_structures_key +let same_file_stats first second = + first.Unix.st_dev = second.Unix.st_dev + && first.Unix.st_ino = second.Unix.st_ino + && first.Unix.st_size = second.Unix.st_size + && first.Unix.st_mtime = second.Unix.st_mtime + && first.Unix.st_ctime = second.Unix.st_ctime + +type frozen_values_entry = { + resolved_filename: string; + stats: Unix.stats; + image: Frozen_values.t; +} + +type frozen_values_cache = { + lock: Mutex.t; + entries: (string, frozen_values_entry) Hashtbl.t; +} + +let frozen_values_cache_key = Domain.DLS.new_key (fun () -> None) + +let prepare_frozen_values ~name ~filename cmi = + if Sys.getenv_opt "REWATCH_FROZEN_VALUES" <> Some "1" then None + else + match Domain.DLS.get frozen_values_cache_key with + | None -> None + | Some cache -> ( + try + let resolved_filename = Compiler_request_state.resolve_path filename in + let stats = Unix.stat resolved_filename in + Mutex.lock cache.lock; + Fun.protect + (fun () -> + match Hashtbl.find_opt cache.entries name with + | Some entry + when entry.resolved_filename = resolved_filename + && same_file_stats entry.stats stats -> + Some entry.image + | _ -> + Compiler_phase_trace.dependency "dependency.frozen_values_prepare" + (fun () -> + match Frozen_values.freeze cmi with + | Error _ -> None + | Ok image -> + if same_file_stats (Unix.stat resolved_filename) stats then ( + Hashtbl.replace cache.entries name + {resolved_filename; stats; image}; + Some image) + else None)) + ~finally:(fun () -> Mutex.unlock cache.lock) + with Sys_error _ | Unix.Unix_error _ -> None) + (* Consistency between persistent structures *) let crc_units_key = Domain.DLS.new_key Consistbl.create @@ -774,6 +876,10 @@ let acknowledge_pers_struct check modname {Persistent_signature.filename; cmi} = let sign = cmi.cmi_sign in let crcs = cmi.cmi_crcs in let flags = cmi.cmi_flags in + let frozen_values = + prepare_frozen_values ~name ~filename cmi + |> Option.map Frozen_values.create_view + in let deprecated = List.fold_left (fun _ -> function @@ -784,17 +890,31 @@ let acknowledge_pers_struct check modname {Persistent_signature.filename; cmi} = !components_of_module' ~deprecated ~loc:Location.none empty Subst.identity (Pident (Ident.create_persistent name)) - (Mty_signature sign) + (Mty_signature (if Option.is_some frozen_values then [] else sign)) + in + let comps = + match frozen_values with + | Some view -> {comps with frozen_root = Some view} + | None -> comps in let ps = { ps_name = name; - ps_sig = lazy (Subst.signature Subst.identity sign); + ps_sig = + lazy + (Compiler_phase_trace.dependency_lazy + (fun () -> "dependency.signature_copy:" ^ name) + (fun () -> + match frozen_values with + | Some view -> Frozen_values.copy_signature view + | None -> Subst.signature Subst.identity sign)); ps_comps = comps; ps_crcs = crcs; ps_filename = filename; ps_flags = flags; ps_snapshot = None; + ps_frozen_values = frozen_values; + ps_frozen_components = Hashtbl.create 8; } in if ps.ps_name <> modname then @@ -905,6 +1025,34 @@ let get_unit_name () = !(current_unit ()) (* Lookup by identifier *) +let find_frozen_scope_path path = + if Sys.getenv_opt "REWATCH_FROZEN_VALUES" <> Some "1" then None + else + let rec find visited path = + if List.exists (Path.same path) visited then None + else + let visited = path :: visited in + match path with + | Pident id + when Ident.persistent id && Ident.name id <> !(current_unit ()) -> + let ps = find_pers_struct (Ident.name id) in + Option.map + (fun view -> (view, Frozen_values.root_scope view)) + ps.ps_frozen_values + | Pdot (parent, name, _) -> ( + match find visited parent with + | Some (view, scope) -> ( + match Frozen_values.find_module scope name with + | Some (nested, _, _, _) -> Some (view, nested) + | None -> ( + match Frozen_values.find_module_alias view scope name with + | Some target -> find visited target + | None -> None)) + | None -> None) + | Pident _ | Papply _ -> None + in + find [] path + let rec find_module_descr path env = match path with | Pident id -> ( @@ -914,11 +1062,34 @@ let rec find_module_descr path env = (find_pers_struct (Ident.name id)).ps_comps else raise Not_found) | Pdot (p, s, _pos) -> ( - match get_components (find_module_descr p env) with - | Structure_comps c -> - let descr, _pos = Tbl.find_str s c.comp_components in - descr - | Functor_comps _ -> raise Not_found) + let generic () = + match get_components (find_module_descr p env) with + | Structure_comps c -> + let descr, _pos = Tbl.find_str s c.comp_components in + descr + | Functor_comps _ -> raise Not_found + in + match find_frozen_scope_path p with + | Some (view, scope) -> ( + match Frozen_values.find_module_declaration view scope s with + | Some (declaration, position) -> ( + let path = Pdot (p, s, position) in + let ps = find_pers_struct (Ident.name (Path.head p)) in + match Hashtbl.find_opt ps.ps_frozen_components path with + | Some components -> components + | None -> + let components = + !components_of_module' + ~deprecated: + (Builtin_attributes.deprecated_of_attrs + declaration.md_attributes) + ~loc:declaration.md_loc empty Subst.identity path + declaration.md_type + in + Hashtbl.add ps.ps_frozen_components path components; + components) + | None -> generic ()) + | None -> generic ()) | Papply (p1, p2) -> ( match get_components (find_module_descr p1 env) with | Functor_comps f -> !components_of_functor_appl' f env p1 p2 @@ -935,22 +1106,76 @@ let find proj1 proj2 path env = | 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_generic = find (fun env -> env.values) (fun sc -> sc.comp_values) -and find_type_full = find (fun env -> env.types) (fun sc -> sc.comp_types) +let find_value path env = + if Sys.getenv_opt "REWATCH_FROZEN_VALUES" <> Some "1" then + find_value_generic path env + else + match path with + | Pdot (module_path, name, _) -> ( + match find_frozen_scope_path module_path with + | Some (view, scope) -> ( + match + Compiler_phase_trace.dependency "dependency.frozen_value_lookup" + (fun () -> Frozen_values.find_in_scope view scope name) + with + | Some (description, _) -> description + | None -> find_value_generic path env) + | None -> find_value_generic path env) + | _ -> find_value_generic path env -and find_modtype = find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) +and find_type_full_generic = + find (fun env -> env.types) (fun sc -> sc.comp_types) + +and find_modtype path env = + match path with + | Pdot (module_path, name, _) -> ( + match find_frozen_scope_path module_path with + | Some (view, scope) -> ( + match Frozen_values.find_modtype_declaration view scope name with + | Some declaration -> declaration + | None -> + find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) path env) + | None -> + find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) path env) + | Pident _ | Papply _ -> + find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) path env let type_of_cstr path = function | {cstr_inlined = Some d; _} -> (d, ([], List.map snd (Datarepr.labels_of_type path d))) | _ -> assert false -let find_type_full path env = +let find_frozen_type path = + if Sys.getenv_opt "REWATCH_FROZEN_VALUES" <> Some "1" then None + else + match path with + | Pdot (module_path, name, _) -> ( + match find_frozen_scope_path module_path with + | Some (view, scope) -> + Compiler_phase_trace.dependency "dependency.frozen_type_lookup" + (fun () -> Frozen_values.find_type_in_scope view scope name) + | None -> None) + | Pident _ | Papply _ -> None + +let find_frozen_extension mod_path name = + if Sys.getenv_opt "REWATCH_FROZEN_VALUES" <> Some "1" then None + else + match find_frozen_scope_path mod_path with + | Some (view, scope) -> + Compiler_phase_trace.dependency "dependency.frozen_extension_lookup" + (fun () -> Frozen_values.find_extension_in_scope view scope name) + | None -> None + +let rec 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 -> ( + match find_frozen_type p with + | Some declaration -> declaration + | None -> find_type_full_generic p env)) | Cstr (ty_path, s) -> let _, (cstrs, _) = try find_type_full ty_path env with Not_found -> assert false @@ -966,25 +1191,29 @@ let find_type_full path env = in type_of_cstr path cstr | Ext (mod_path, s) -> ( - let comps = - try find_module_descr mod_path env with Not_found -> assert false - in - let comps = - match get_components comps with - | Structure_comps c -> c - | Functor_comps _ -> assert false - in - let exts = - Ext_list.filter - (try Tbl.find_str s comps.comp_constrs with Not_found -> assert false) - (function - | {cstr_kind = Extension_constructor _} -> true - | _ -> false) - in + match find_frozen_extension mod_path s with + | Some constructor -> type_of_cstr path constructor + | None -> ( + let comps = + try find_module_descr mod_path env with Not_found -> assert false + in + let comps = + match get_components comps with + | Structure_comps c -> c + | Functor_comps _ -> assert false + in + let exts = + Ext_list.filter + (try Tbl.find_str s comps.comp_constrs + with Not_found -> assert false) + (function + | {cstr_kind = Extension_constructor _} -> true + | _ -> false) + in - match exts with - | [cstr] -> type_of_cstr path cstr - | _ -> assert false) + match exts with + | [cstr] -> type_of_cstr path cstr + | _ -> assert false)) let find_type p env = fst (find_type_full p env) let find_type_descrs p env = snd (find_type_full p env) @@ -1001,11 +1230,22 @@ let find_module ~alias path env = md (Mty_signature (Lazy.force ps.ps_sig)) else raise Not_found) | Pdot (p, s, _pos) -> ( - match get_components (find_module_descr p env) with - | Structure_comps c -> - let data, _pos = Tbl.find_str s c.comp_modules in - Env_lazy.force subst_modtype_maker data - | Functor_comps _ -> raise Not_found) + match find_frozen_scope_path p with + | Some (view, scope) -> ( + match Frozen_values.find_module_declaration view scope s with + | Some (declaration, _) -> declaration + | None -> ( + match get_components (find_module_descr p env) with + | Structure_comps c -> + let data, _pos = Tbl.find_str s c.comp_modules in + Env_lazy.force subst_modtype_maker data + | Functor_comps _ -> raise Not_found)) + | None -> ( + match get_components (find_module_descr p env) with + | Structure_comps c -> + let data, _pos = Tbl.find_str s c.comp_modules in + Env_lazy.force subst_modtype_maker data + | Functor_comps _ -> raise Not_found)) | Papply (p1, p2) -> ( let desc1 = find_module_descr p1 env in match get_components desc1 with @@ -1036,9 +1276,42 @@ 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 path with + | Pdot (parent, name, _) when lax -> ( + match find_frozen_scope_path parent with + | Some (view, scope) -> ( + match Frozen_values.find_module_alias view scope name with + | Some target -> normalize_path lax env target + | None -> ( + if + Option.is_some (Frozen_values.find_module scope name) + || Frozen_values.is_type_name_in_scope scope name + then path + else + match find_module ~alias:true path env with + | {md_type = Mty_alias (_, path1)} -> normalize_path lax env path1 + | _ -> path)) + | None -> ( + match find_module ~alias:true path env with + | {md_type = Mty_alias (_, path1)} -> normalize_path lax env path1 + | _ -> path)) + | Pident id when Ident.persistent id && Ident.name id <> !(current_unit ()) + -> ( + match Id_tbl.find_same id env.modules with + | _ -> ( + match find_module ~alias:true path env with + | {md_type = Mty_alias (_, path1)} -> normalize_path lax env path1 + | _ -> path) + | exception Not_found -> + (* A compiled unit's root is a signature, never a module alias. + Loading it validates the dependency without copying its entire + signature just to normalize a value access path. *) + ignore (find_pers_struct (Ident.name id)); + path) + | Pident _ | Pdot _ | Papply _ -> ( + match find_module ~alias:true path env with + | {md_type = Mty_alias (_, path1)} -> normalize_path lax env path1 + | _ -> path) with | Not_found when lax @@ -1141,6 +1414,44 @@ let rec lookup_module_descr_aux ?loc lid env = (Pdot (p, s, pos), descr) | Functor_comps _ -> raise Not_found) +and lookup_frozen_scope ?loc lid env = + if Sys.getenv_opt "REWATCH_FROZEN_VALUES" <> Some "1" then None + else + match lid with + | Lident name -> ( + let path, _ = lookup_module_descr ?loc lid env in + match path with + | Pident id when Ident.persistent id -> + let ps = find_pers_struct name in + Option.map + (fun view -> (path, view, Frozen_values.root_scope view)) + ps.ps_frozen_values + | Pident _ | Pdot _ | Papply _ -> None) + | Ldot (parent, name) -> ( + match lookup_frozen_scope ?loc parent env with + | Some (parent_path, view, scope) -> ( + match Frozen_values.find_module scope name with + | Some (nested, position, module_loc, deprecated) -> + let path = Pdot (parent_path, name, position) in + mark_module_used env name module_loc; + report_deprecated ?loc path deprecated; + Some (path, view, nested) + | None -> ( + match + ( Frozen_values.find_module_info scope name, + Frozen_values.find_module_alias view scope name ) + with + | Some (position, module_loc, deprecated), Some target -> ( + match find_frozen_scope_path target with + | Some (target_view, target_scope) -> + let path = Pdot (parent_path, name, position) in + mark_module_used env name module_loc; + report_deprecated ?loc path deprecated; + Some (path, target_view, target_scope) + | None -> None) + | _ -> None)) + | None -> None) + and lookup_module_descr ?loc lid env = let ((p, comps) as res) = lookup_module_descr_aux ?loc lid env in mark_module_used env (Path.last p) comps.loc; @@ -1179,16 +1490,36 @@ and lookup_module ~load ?loc lid env : Path.t = report_deprecated ?loc p ps.ps_comps.deprecated); p) | Ldot (l, s) -> ( - let p, descr = lookup_module_descr ?loc l env in - match get_components descr with - | Structure_comps c -> - let _data, pos = Tbl.find_str s c.comp_modules in - let comps, _ = Tbl.find_str s c.comp_components in - mark_module_used env s comps.loc; - let p = Pdot (p, s, pos) in - report_deprecated ?loc p comps.deprecated; - p - | Functor_comps _ -> raise Not_found) + match lookup_frozen_scope ?loc l env with + | Some (parent_path, _, scope) -> ( + match Frozen_values.find_module_info scope s with + | Some (position, module_loc, deprecated) -> + let path = Pdot (parent_path, s, position) in + mark_module_used env s module_loc; + report_deprecated ?loc path deprecated; + path + | None -> ( + let p, descr = lookup_module_descr ?loc l env in + match get_components descr with + | Structure_comps c -> + let _data, pos = Tbl.find_str s c.comp_modules in + let comps, _ = Tbl.find_str s c.comp_components in + mark_module_used env s comps.loc; + let p = Pdot (p, s, pos) in + report_deprecated ?loc p comps.deprecated; + p + | Functor_comps _ -> raise Not_found)) + | None -> ( + let p, descr = lookup_module_descr ?loc l env in + match get_components descr with + | Structure_comps c -> + let _data, pos = Tbl.find_str s c.comp_modules in + let comps, _ = Tbl.find_str s c.comp_components in + mark_module_used env s comps.loc; + let p = Pdot (p, s, pos) in + report_deprecated ?loc p comps.deprecated; + p + | Functor_comps _ -> raise Not_found)) let lookup proj1 proj2 ?loc lid env = match lid with @@ -1229,20 +1560,103 @@ 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_all_constructors = +let lookup_value_generic = + lookup (fun env -> env.values) (fun sc -> sc.comp_values) + +let lookup_value ?loc lid env = + if Sys.getenv_opt "REWATCH_FROZEN_VALUES" <> Some "1" then + lookup_value_generic ?loc lid env + else + match lid with + | Longident.Ldot (module_lid, name) -> ( + match lookup_frozen_scope ?loc module_lid env with + | Some (module_path, view, scope) -> ( + match + Compiler_phase_trace.dependency "dependency.frozen_value_lookup" + (fun () -> Frozen_values.find_in_scope view scope name) + with + | Some (description, position) -> + (Pdot (module_path, name, position), description) + | None -> lookup_value_generic ?loc lid env) + | None -> lookup_value_generic ?loc lid env) + | Longident.Lident _ -> lookup_value_generic ?loc lid env +let lookup_all_constructors_generic = lookup_all_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs) cstr_shadow -let lookup_all_labels = + +let lookup_all_constructors ?loc lid env = + if Sys.getenv_opt "REWATCH_FROZEN_VALUES" <> Some "1" then + lookup_all_constructors_generic ?loc lid env + else + match lid with + | Longident.Ldot (module_lid, name) -> ( + match lookup_frozen_scope ?loc module_lid env with + | Some (_, view, scope) -> ( + match + Compiler_phase_trace.dependency "dependency.frozen_constructor_lookup" + (fun () -> Frozen_values.find_constructors_in_scope view scope name) + with + | Some constructors -> + List.map (fun constructor -> (constructor, fun () -> ())) constructors + | None -> lookup_all_constructors_generic ?loc lid env) + | None -> lookup_all_constructors_generic ?loc lid env) + | Longident.Lident _ -> lookup_all_constructors_generic ?loc lid env +let lookup_all_labels_generic = lookup_all_simple (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_modtype = - lookup (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) + +let lookup_all_labels ?loc lid env = + if Sys.getenv_opt "REWATCH_FROZEN_VALUES" <> Some "1" then + lookup_all_labels_generic ?loc lid env + else + match lid with + | Longident.Ldot (module_lid, name) -> ( + match lookup_frozen_scope ?loc module_lid env with + | Some (_, view, scope) -> ( + match + Compiler_phase_trace.dependency "dependency.frozen_label_lookup" + (fun () -> Frozen_values.find_labels_in_scope view scope name) + with + | Some labels -> List.map (fun label -> (label, fun () -> ())) labels + | None -> lookup_all_labels_generic ?loc lid env) + | None -> lookup_all_labels_generic ?loc lid env) + | Longident.Lident _ -> lookup_all_labels_generic ?loc lid env +let lookup_type_generic = + lookup (fun env -> env.types) (fun sc -> sc.comp_types) + +let lookup_type ?loc lid env = + if Sys.getenv_opt "REWATCH_FROZEN_VALUES" <> Some "1" then + lookup_type_generic ?loc lid env + else + match lid with + | Longident.Ldot (module_lid, name) -> ( + match lookup_frozen_scope ?loc module_lid env with + | Some (module_path, view, scope) -> ( + match + Compiler_phase_trace.dependency "dependency.frozen_type_lookup" + (fun () -> Frozen_values.find_type_in_scope view scope name) + with + | Some declaration -> (Pdot (module_path, name, nopos), declaration) + | None -> lookup_type_generic ?loc lid env) + | None -> lookup_type_generic ?loc lid env) + | Longident.Lident _ -> lookup_type_generic ?loc lid env +let lookup_modtype ?loc lid env = + let generic () = + lookup (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) ?loc lid env + in + match lid with + | Lident _ -> generic () + | Ldot (module_lid, name) -> ( + match lookup_frozen_scope ?loc module_lid env with + | Some (module_path, view, scope) -> ( + match Frozen_values.find_modtype_declaration view scope name with + | Some declaration -> (Pdot (module_path, name, nopos), declaration) + | None -> generic ()) + | None -> generic ()) let copy_types l env = let f desc = @@ -1990,10 +2404,12 @@ let preparing_expanded_snapshot = Domain.DLS.new_key (fun () -> false) let prepare_expanded_snapshot : (alias_key -> unit) ref = ref (fun _ -> ()) let expanded_snapshot_enabled () = - match Sys.getenv_opt "REWATCH_COMBINED_SIGNATURE_CACHE" with - | Some "0" -> false - | Some ("force" | "force_typed" | "typed" | "audit") -> true - | _ -> Domain.DLS.get expanded_snapshot_enabled_key + if Sys.getenv_opt "REWATCH_FROZEN_VALUES" = Some "1" then false + else + match Sys.getenv_opt "REWATCH_COMBINED_SIGNATURE_CACHE" with + | Some "0" -> false + | Some ("force" | "force_typed" | "typed" | "audit") -> true + | _ -> Domain.DLS.get expanded_snapshot_enabled_key let typed_expanded_snapshot_reuse () = not (Sys.getenv_opt "REWATCH_COMBINED_SIGNATURE_CACHE" = Some "force") @@ -2004,13 +2420,6 @@ let audit_expanded_snapshot_reuse () = let force_fresh_expanded_snapshot () = Sys.getenv_opt "REWATCH_COMBINED_SIGNATURE_CACHE" = Some "force" -let same_file_stats first second = - first.Unix.st_dev = second.Unix.st_dev - && first.Unix.st_ino = second.Unix.st_ino - && first.Unix.st_size = second.Unix.st_size - && first.Unix.st_mtime = second.Unix.st_mtime - && first.Unix.st_ctime = second.Unix.st_ctime - type cmi_cache_entry = { resolved_filename: string; stats: Unix.stats; @@ -2023,6 +2432,7 @@ type cmi_cache_entry = { type dependency_cache = { mutex: Mutex.t; mutable available: dependency_cache_table list; + frozen_values: frozen_values_cache; } and dependency_cache_table = { @@ -2030,7 +2440,12 @@ and dependency_cache_table = { expanded_snapshot: expanded_snapshot_cache_entry option ref; } -let create_dependency_cache () = {mutex = Mutex.create (); available = []} +let create_dependency_cache () = + { + mutex = Mutex.create (); + available = []; + frozen_values = {lock = Mutex.create (); entries = Hashtbl.create 32}; + } let cmi_cache_key = Domain.DLS.new_key (fun () -> Hashtbl.create 2) let cmi_cache () = Domain.DLS.get cmi_cache_key @@ -2153,7 +2568,12 @@ let alias_key_of_module path mty = let is_alias_path key path mty = alias_key_of_module path mty = Some key let rec components_of_module ~deprecated ~loc env sub path mty = - {deprecated; loc; comps = Env_lazy.create (env, sub, path, mty)} + { + deprecated; + loc; + frozen_root = None; + comps = Env_lazy.create (env, sub, path, mty); + } and components_of_module_maker (env, sub, path, mty) = Compiler_phase_trace.dependency_lazy @@ -2229,66 +2649,70 @@ and components_of_module_maker_uncached (env, sub, path, mty) = let pos = ref 0 in let labels_by_name = Hashtbl.create 127 in let label_names_rev = ref [] in - List.iter2 - (fun item path -> - match item with - | Sig_value (id, decl) -> ( - let decl' = 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 _ -> () - | _ -> incr pos) - | Sig_type (id, decl, _) -> - let decl' = Subst.type_declaration sub decl in - Datarepr.set_row_name decl' (Subst.type_path sub (Path.Pident id)); - let constructors = - List.map snd (Datarepr.constructors_of_type path decl') - in - let labels = List.map snd (Datarepr.labels_of_type path decl') in - c.comp_types <- - Tbl.add (Ident.name id) - ((decl', (constructors, labels)), nopos) - c.comp_types; - List.iter - (fun descr -> - c.comp_constrs <- add_to_tbl descr.cstr_name descr c.comp_constrs) - constructors; - List.iter - (fun descr -> - let name = descr.lbl_name in - match Hashtbl.find labels_by_name name with - | _, previous -> - Hashtbl.replace labels_by_name name (name, descr :: previous) - | exception Not_found -> - Hashtbl.add labels_by_name name (name, [descr]); - label_names_rev := name :: !label_names_rev) - labels; - env := store_type_infos id decl !env - | Sig_typext (id, ext, _) -> - let ext' = Subst.extension_constructor sub ext in - let descr = Datarepr.extension_descr path ext' in - c.comp_constrs <- add_to_tbl (Ident.name id) descr c.comp_constrs; - incr pos - | Sig_module (id, md, _) -> - let md' = Env_lazy.create (sub, md) in - c.comp_modules <- Tbl.add (Ident.name id) (md', !pos) c.comp_modules; - let deprecated = - 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 - in - c.comp_components <- - Tbl.add (Ident.name id) (comps, !pos) c.comp_components; - env := store_module ~check:false id md !env; - incr pos - | Sig_modtype (id, decl) -> - 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) - sg pl; + Compiler_phase_trace.dependency "dependency.components_build" (fun () -> + List.iter2 + (fun item path -> + match item with + | Sig_value (id, decl) -> ( + let decl' = 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 _ -> () + | _ -> incr pos) + | Sig_type (id, decl, _) -> + let decl' = Subst.type_declaration sub decl in + Datarepr.set_row_name decl' (Subst.type_path sub (Path.Pident id)); + let constructors = + List.map snd (Datarepr.constructors_of_type path decl') + in + let labels = List.map snd (Datarepr.labels_of_type path decl') in + c.comp_types <- + Tbl.add (Ident.name id) + ((decl', (constructors, labels)), nopos) + c.comp_types; + List.iter + (fun descr -> + c.comp_constrs <- + add_to_tbl descr.cstr_name descr c.comp_constrs) + constructors; + List.iter + (fun descr -> + let name = descr.lbl_name in + match Hashtbl.find labels_by_name name with + | _, previous -> + Hashtbl.replace labels_by_name name (name, descr :: previous) + | exception Not_found -> + Hashtbl.add labels_by_name name (name, [descr]); + label_names_rev := name :: !label_names_rev) + labels; + env := store_type_infos id decl !env + | Sig_typext (id, ext, _) -> + let ext' = Subst.extension_constructor sub ext in + let descr = Datarepr.extension_descr path ext' in + c.comp_constrs <- add_to_tbl (Ident.name id) descr c.comp_constrs; + incr pos + | Sig_module (id, md, _) -> + let md' = Env_lazy.create (sub, md) in + c.comp_modules <- + Tbl.add (Ident.name id) (md', !pos) c.comp_modules; + let deprecated = + 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 + in + c.comp_components <- + Tbl.add (Ident.name id) (comps, !pos) c.comp_components; + env := store_module ~check:false id md !env; + incr pos + | Sig_modtype (id, decl) -> + 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) + sg pl); (* Large signatures often repeat label names. Keep first appearance order to preserve Tbl's shape and the latest key and declarations to preserve its contents. *) @@ -2581,10 +3005,127 @@ let add_components slot root env0 comps = modules; } +let add_frozen_components slot root env0 view scope = + let generic_components () = + Compiler_phase_trace.dependency "dependency.frozen_open_fallback" (fun () -> + match get_components (find_module_descr root env0) with + | Structure_comps components -> components + | Functor_comps _ -> raise Not_found) + in + let from_table table name = + try Some (Tbl.find_str name table) with Not_found -> None + in + let id_source names contains lookup : _ Id_tbl.source = + let find name = if contains name then lookup name else None in + { + find; + iter = + (fun callback -> + List.iter (fun name -> Option.iter (callback name) (find name)) names); + } + in + let ty_source names contains lookup : _ Tycomp_tbl.source = + let find name = if contains name then lookup name else None in + { + find; + iter = + (fun callback -> + List.iter (fun name -> Option.iter (callback name) (find name)) names); + } + in + let values = + id_source (Frozen_values.value_names scope) (Frozen_values.has_value scope) + (fun name -> + match Frozen_values.find_in_scope view scope name with + | Some value -> Some value + | None -> from_table (generic_components ()).comp_values name) + in + let types = + id_source (Frozen_values.type_names scope) (Frozen_values.has_type scope) + (fun name -> + match Frozen_values.find_type_in_scope view scope name with + | Some declaration -> Some (declaration, nopos) + | None -> from_table (generic_components ()).comp_types name) + in + let constrs = + ty_source (Frozen_values.constructor_names scope) + (Frozen_values.has_constructor scope) (fun name -> + match Frozen_values.find_constructors_in_scope view scope name with + | Some constructors -> Some constructors + | None -> from_table (generic_components ()).comp_constrs name) + in + let labels = + ty_source (Frozen_values.label_names scope) (Frozen_values.has_label scope) + (fun name -> + match Frozen_values.find_labels_in_scope view scope name with + | Some labels -> Some labels + | None -> from_table (generic_components ()).comp_labels name) + in + let module_cache = Hashtbl.create 8 in + let modules = + id_source (Frozen_values.module_names scope) + (Frozen_values.has_module scope) (fun name -> + match Hashtbl.find_opt module_cache name with + | Some module_entry -> Some module_entry + | None -> + let result = + match Frozen_values.find_module_declaration view scope name with + | Some (declaration, position) -> + Some (Env_lazy.create (Subst.identity, declaration), position) + | None -> from_table (generic_components ()).comp_modules name + in + Option.iter (Hashtbl.add module_cache name) result; + result) + in + let modtypes = + id_source (Frozen_values.modtype_names scope) + (Frozen_values.has_modtype scope) (fun name -> + match Frozen_values.find_modtype_declaration view scope name with + | Some declaration -> Some (declaration, nopos) + | None -> from_table (generic_components ()).comp_modtypes name) + in + let components = + id_source (Frozen_values.module_names scope) + (Frozen_values.has_module scope) (fun name -> + match Frozen_values.find_module_info scope name with + | Some (position, _, _) -> + Some (find_module_descr (Pdot (root, name, position)) env0, position) + | None -> from_table (generic_components ()).comp_components name) + in + { + env0 with + summary = Env_open (env0.summary, root); + values = + Id_tbl.add_open_source slot (fun x -> `Value x) root values env0.values; + types = Id_tbl.add_open_source slot (fun x -> `Type x) root types env0.types; + constrs = + Tycomp_tbl.add_open_source slot + (fun x -> `Constructor x) + constrs env0.constrs; + labels = + Tycomp_tbl.add_open_source slot (fun x -> `Label x) labels env0.labels; + modules = + Id_tbl.add_open_source slot (fun x -> `Module x) root modules env0.modules; + modtypes = + Id_tbl.add_open_source slot + (fun x -> `Module_type x) + root modtypes env0.modtypes; + components = + Id_tbl.add_open_source slot + (fun x -> `Component x) + root components env0.components; + } + let open_signature slot root env0 = - match get_components (find_module_descr root env0) with - | Functor_comps _ -> None - | Structure_comps comps -> Some (add_components slot root env0 comps) + match find_frozen_scope_path root with + | Some (view, scope) -> + Some + (Compiler_phase_trace.dependency "dependency.frozen_open" (fun () -> + add_frozen_components slot root env0 view scope)) + | None -> ( + match get_components (find_module_descr root env0) with + | Functor_comps _ -> None + | Structure_comps comps -> Some (add_components slot root env0 comps)) (* Open a signature from a file *) @@ -2684,6 +3225,8 @@ let save_signature_with_imports ?check_exists ~deprecated sg modname filename ps_filename = filename; ps_flags = cmi.cmi_flags; ps_snapshot = None; + ps_frozen_values = None; + ps_frozen_components = Hashtbl.create 0; } in save_pers_struct crc ps; @@ -3107,6 +3650,8 @@ let load_expanded_snapshot ~check:_ ~name = ps_filename = entry.target_filename; ps_flags = graph.flags; ps_snapshot = Some snapshot; + ps_frozen_values = None; + ps_frozen_components = Hashtbl.create 0; })) | _ -> None @@ -3158,15 +3703,18 @@ let with_dependency_cache cache action = in let previous_cmis = cmi_cache () in let previous_snapshot = expanded_snapshot_cache () in + let previous_frozen_values = Domain.DLS.get frozen_values_cache_key in Domain.DLS.set cmi_cache_key table.cmis; Domain.DLS.set expanded_snapshot_cache_key table.expanded_snapshot; + Domain.DLS.set frozen_values_cache_key (Some cache.frozen_values); Fun.protect action ~finally:(fun () -> (* Both graphs are exclusive to this request. Finalization restores allocation IDs and any mutated nodes before another domain leases the same table. A failed finalization discards the table. *) Fun.protect finalize_expanded_snapshot_cache ~finally:(fun () -> Domain.DLS.set cmi_cache_key previous_cmis; - Domain.DLS.set expanded_snapshot_cache_key previous_snapshot); + Domain.DLS.set expanded_snapshot_cache_key previous_snapshot; + Domain.DLS.set frozen_values_cache_key previous_frozen_values); Mutex.lock cache.mutex; Fun.protect (fun () -> cache.available <- table :: cache.available) diff --git a/compiler/ml/frozen_type_graph.ml b/compiler/ml/frozen_type_graph.ml new file mode 100644 index 0000000000..bec7943b31 --- /dev/null +++ b/compiler/ml/frozen_type_graph.ml @@ -0,0 +1,329 @@ +open Types + +type frozen_ident = {name: string; stamp: int; flags: int} + +type frozen_path = + | Fident of int + | Fdot of frozen_path * string * int + | Fapply of frozen_path * frozen_path + +type frozen_row_field = + | Fpresent of int option + | Feither of bool * int list * bool * int + | Fabsent + +type frozen_desc = + | Fvar of string option + | Farrow of (Asttypes.arg_label * int) list * int + | Ftuple of int list + | Fconstr of frozen_path * int list + | Fobject of int + | Ffield of string * int * int * int + | Fnil + | Fvariant of + (string * frozen_row_field) list + * int + * bool + * bool + * (frozen_path * int list) option + | Funivar of string option + | Fpoly of int * int list + | Fpackage of frozen_path * Longident.t list * int list + +type frozen_node = {level: int; desc: frozen_desc} + +type t = { + roots: int list; + requested_identifiers: int list; + nodes: frozen_node array; + identifiers: frozen_ident array; + mutabilities: Asttypes.mutable_flag array; + row_references: frozen_row_field option array; +} + +module Physical_type = Hashtbl.Make (struct + type t = type_expr + let equal a b = a == b + let hash ty = ty.id +end) + +module Physical_ident = Hashtbl.Make (struct + type t = Ident.t + let equal a b = a == b + let hash id = Hashtbl.hash (id.Ident.stamp, id.Ident.name) +end) + +module Physical_mutability = Hashtbl.Make (struct + type t = field_mutability ref + let equal a b = a == b + let hash = Hashtbl.hash +end) + +module Physical_row_reference = Hashtbl.Make (struct + type t = row_field option ref + let equal a b = a == b + let hash = Hashtbl.hash +end) + +exception Unsupported of string + +let freeze ?(identifiers = []) roots = + try + let requested = identifiers in + let seen_types = Physical_type.create 128 in + let seen_idents = Physical_ident.create 32 in + let seen_mutabilities = Physical_mutability.create 16 in + let seen_row_references = Physical_row_reference.create 16 in + let nodes = ref [] in + let identifiers = ref [] in + let mutabilities = ref [] in + let row_references = ref [] in + let type_count = ref 0 in + let ident_count = ref 0 in + let mutability_count = ref 0 in + let row_reference_count = ref 0 in + let index_ident id = + match Physical_ident.find_opt seen_idents id with + | Some index -> index + | None -> + let index = !ident_count in + incr ident_count; + Physical_ident.add seen_idents id index; + identifiers := + ( index, + { + name = id.Ident.name; + stamp = id.Ident.stamp; + flags = id.Ident.flags; + } ) + :: !identifiers; + index + in + let rec freeze_path = function + | Path.Pident id -> Fident (index_ident id) + | Path.Pdot (path, name, position) -> + Fdot (freeze_path path, name, position) + | Path.Papply (first, second) -> + Fapply (freeze_path first, freeze_path second) + in + let index_mutability cell = + let cell = Btype.mutability_ref_repr cell in + match Physical_mutability.find_opt seen_mutabilities cell with + | Some index -> index + | None -> + let index = !mutability_count in + incr mutability_count; + Physical_mutability.add seen_mutabilities cell index; + mutabilities := (index, Btype.mutability_repr cell) :: !mutabilities; + index + in + let rec freeze_type ty = + match Physical_type.find_opt seen_types ty with + | Some index -> index + | None -> + let index = !type_count in + incr type_count; + Physical_type.add seen_types ty index; + let desc = + match ty.desc with + | Tvar name -> Fvar name + | Tarrow (arguments, result) -> + Farrow + ( List.map + (fun argument -> (argument.lbl, freeze_type argument.typ)) + arguments, + freeze_type result ) + | Ttuple types -> Ftuple (List.map freeze_type types) + | Tconstr (path, parameters, memo) -> + (match !memo with + | Mnil -> () + | Mcons _ | Mlink _ -> + raise (Unsupported "an active abbreviation memo")); + Fconstr (freeze_path path, List.map freeze_type parameters) + | Tobject fields -> Fobject (freeze_type fields) + | Tfield {name; mutability; typ; rest} -> + Ffield + ( name, + index_mutability mutability, + freeze_type typ, + freeze_type rest ) + | Tnil -> Fnil + | Tvariant row -> + Fvariant + ( List.map + (fun (label, field) -> (label, freeze_row_field field)) + row.row_fields, + freeze_type row.row_more, + row.row_closed, + row.row_fixed, + Option.map + (fun (path, parameters) -> + (freeze_path path, List.map freeze_type parameters)) + row.row_name ) + | Tunivar name -> Funivar name + | Tpoly (body, variables) -> + Fpoly (freeze_type body, List.map freeze_type variables) + | Tpackage (path, names, types) -> + Fpackage (freeze_path path, names, List.map freeze_type types) + | Tlink _ -> raise (Unsupported "a linked type node") + | Tsubst _ -> raise (Unsupported "an active type copy mark") + in + nodes := (index, {level = ty.level; desc}) :: !nodes; + index + and freeze_row_field = function + | Rpresent ty -> Fpresent (Option.map freeze_type ty) + | Reither (constant, types, matched, reference) -> + Feither + ( constant, + List.map freeze_type types, + matched, + freeze_row_reference reference ) + | Rabsent -> Fabsent + and freeze_row_reference reference = + match Physical_row_reference.find_opt seen_row_references reference with + | Some index -> index + | None -> + let index = !row_reference_count in + incr row_reference_count; + Physical_row_reference.add seen_row_references reference index; + row_references := + (index, Option.map freeze_row_field !reference) :: !row_references; + index + in + let requested_identifiers = List.map index_ident requested in + let roots = List.map freeze_type roots in + let array count entries empty = + let result = Array.make count empty in + List.iter (fun (index, value) -> result.(index) <- value) entries; + result + in + Ok + { + roots; + requested_identifiers; + nodes = array !type_count !nodes {level = 0; desc = Fnil}; + identifiers = + array !ident_count !identifiers {name = ""; stamp = 0; flags = 0}; + mutabilities = array !mutability_count !mutabilities Asttypes.Immutable; + row_references = array !row_reference_count !row_references None; + } + with Unsupported reason -> Error reason + +type view = {type_at: int -> type_expr; identifier_at: int -> Ident.t} + +let create_view ?(map_type_path = Fun.id) ?(map_modtype_path = Fun.id) image = + let identifiers = Array.make (Array.length image.identifiers) None in + let mutabilities = Array.make (Array.length image.mutabilities) None in + let row_references = Array.make (Array.length image.row_references) None in + let nodes = Array.make (Array.length image.nodes) None in + let get_ident index = + match identifiers.(index) with + | Some id -> id + | None -> + let {name; stamp; flags} : frozen_ident = image.identifiers.(index) in + let id = {Ident.name; stamp; flags} in + identifiers.(index) <- Some id; + id + in + let rec thaw_path = function + | Fident index -> Path.Pident (get_ident index) + | Fdot (path, name, position) -> Path.Pdot (thaw_path path, name, position) + | Fapply (first, second) -> Path.Papply (thaw_path first, thaw_path second) + in + let get_mutability index = + match mutabilities.(index) with + | Some cell -> cell + | None -> + let cell = ref (Mutability_value image.mutabilities.(index)) in + mutabilities.(index) <- Some cell; + cell + in + let rec get index = + match nodes.(index) with + | Some ty -> ty + | None -> + let {level; desc} = image.nodes.(index) in + let ty = Btype.newty2 level (Tvar None) in + nodes.(index) <- Some ty; + ty.desc <- thaw_desc desc; + ty + and thaw_desc = function + | Fvar name -> Tvar name + | Farrow (arguments, result) -> + Tarrow + ( List.map (fun (lbl, typ) -> Types.{lbl; typ = get typ}) arguments, + get result ) + | Ftuple types -> Ttuple (List.map get types) + | Fconstr (path, parameters) -> + Tconstr (map_type_path (thaw_path path), List.map get parameters, ref Mnil) + | Fobject fields -> Tobject (get fields) + | Ffield (name, mutability, typ, rest) -> + Tfield + { + name; + mutability = get_mutability mutability; + typ = get typ; + rest = get rest; + } + | Fnil -> Tnil + | Fvariant (fields, more, closed, fixed, name) -> + Tvariant + { + row_fields = + List.map + (fun (label, field) -> (label, thaw_row_field field)) + fields; + row_more = get more; + row_closed = closed; + row_fixed = fixed; + row_name = + Option.map + (fun (path, parameters) -> + (map_type_path (thaw_path path), List.map get parameters)) + name; + } + | Funivar name -> Tunivar name + | Fpoly (body, variables) -> Tpoly (get body, List.map get variables) + | Fpackage (path, names, types) -> + Tpackage (map_modtype_path (thaw_path path), names, List.map get types) + and thaw_row_field = function + | Fpresent ty -> Rpresent (Option.map get ty) + | Feither (constant, types, matched, reference) -> + Reither + (constant, List.map get types, matched, get_row_reference reference) + | Fabsent -> Rabsent + and get_row_reference index = + match row_references.(index) with + | Some reference -> reference + | None -> + let reference = ref None in + row_references.(index) <- Some reference; + reference := Option.map thaw_row_field image.row_references.(index); + reference + in + { + type_at = + (fun root -> + match List.nth_opt image.roots root with + | Some index -> get index + | None -> invalid_arg "Frozen_type_graph.type_at"); + identifier_at = + (fun requested -> + match List.nth_opt image.requested_identifiers requested with + | Some index -> get_ident index + | None -> invalid_arg "Frozen_type_graph.identifier_at"); + } + +let type_at view root = view.type_at root + +let identifier_at view requested = view.identifier_at requested + +let thaw image = + let view = create_view image in + List.init (List.length image.roots) (type_at view) + +let thaw_root image root = type_at (create_view image) root + +let root_count image = List.length image.roots + +let node_count image = Array.length image.nodes diff --git a/compiler/ml/frozen_type_graph.mli b/compiler/ml/frozen_type_graph.mli new file mode 100644 index 0000000000..42ffe15992 --- /dev/null +++ b/compiler/ml/frozen_type_graph.mli @@ -0,0 +1,47 @@ +(** An immutable, indexed image of the type expressions in a compiled + interface. The image contains no mutable compiler nodes and can be shared + between domains. [thaw] creates request-local [Types.type_expr] nodes. + + This is the type-graph part of the immutable-interface experiment. A full + interface image must also encode declarations, identifiers, and paths so + that all roots use the same identity table. *) + +type t + +val freeze : + ?identifiers:Ident.t list -> Types.type_expr list -> (t, string) result +(** Capture roots and their reachable graph. Active copy marks and abbreviation + memo entries are rejected; saved interfaces must not contain either. + [identifiers] registers signature binders in the same identifier table as + paths inside the type graph. *) + +type view + +val create_view : + ?map_type_path:(Path.t -> Path.t) -> + ?map_modtype_path:(Path.t -> Path.t) -> + t -> + view +(** A request-local memo for lazy materialization. Do not share a view between + compiler requests. The callbacks apply the request's path substitution + while a type node is materialized. *) + +val type_at : view -> int -> Types.type_expr +(** Materialize a zero-based root, preserving sharing with any other roots + already materialized through this view. *) + +val identifier_at : view -> int -> Ident.t +(** Materialize a zero-based identifier passed to [freeze]. A matching path + inside a type root receives this exact identifier object. *) + +val thaw : t -> Types.type_expr list +(** Materialize an independent graph, preserving sharing among its roots. *) + +val thaw_root : t -> int -> Types.type_expr +(** Materialize only nodes reachable from one zero-based root. This is a + request-local fallback for consumers which cannot read the frozen graph + directly. *) + +val root_count : t -> int + +val node_count : t -> int diff --git a/compiler/ml/frozen_values.ml b/compiler/ml/frozen_values.ml new file mode 100644 index 0000000000..b574aab0b7 --- /dev/null +++ b/compiler/ml/frozen_values.ml @@ -0,0 +1,996 @@ +open Types + +module String_map = Map.Make (String) +module String_set = Set.Make (String) +module Stamp_map = Map.Make (Int) +module Int_map = Map.Make (Int) + +type binder_kind = Bound_type | Bound_module | Bound_modtype +type binder_path = (string * int) list + +type value = { + typ: int; + kind: string option; + loc: Location.t; + attributes: string option; + position: int; +} + +type frozen_label = { + name: string; + flags: int; + runtime_name: string option; + mutable_flag: Asttypes.mutable_flag; + optional: bool; + typ: int; + loc: Location.t; + attributes: string option; +} + +type frozen_constructor_arguments = + | Frozen_tuple of int list + | Frozen_record_arguments of frozen_label list + +type frozen_constructor = { + name: string; + flags: int; + runtime_tag: Variant_runtime.literal_tag option; + args: frozen_constructor_arguments; + result: int option; + loc: Location.t; + attributes: string option; +} + +type frozen_extension = { + name: string; + position: int; + type_path: string; + type_params: int list; + args: frozen_constructor_arguments; + ret_type: int option; + private_flag: Asttypes.private_flag; + loc: Location.t; + attributes: string option; + is_exception: bool; +} + +type constructor_source = + | Variant_source of string + | Extension_source of frozen_extension + +type frozen_kind = + | Frozen_abstract + | Frozen_record of frozen_label list * frozen_record_representation + | Frozen_variant of frozen_constructor list * int + | Frozen_open + +and frozen_record_representation = + | Static_record of record_representation + | Inlined_record of {name: string; layout: int; position: int} + +type frozen_layout = { + configuration: Variant_runtime.configuration; + cases: Variant_runtime.constructor_case list; +} + +type frozen_inlined_type = Frozen_inlined_record of string * frozen_label list + +type frozen_type = { + params: int list; + arity: int; + kind: frozen_kind; + private_flag: Asttypes.private_flag; + manifest: int option; + variance: Variance.t list; + loc: Location.t; + attributes: string option; + immediate: bool; + representation: type_representation; + inlined_types: frozen_inlined_type list; +} + +type scope = { + id: int; + path: binder_path; + context_id: int option; + values: value String_map.t; + type_names: String_set.t; + duplicate_type_names: String_set.t; + types: frozen_type String_map.t; + label_sources: string list String_map.t; + constructor_sources: constructor_source list String_map.t; + modules: module_entry String_map.t; + duplicate_module_names: String_set.t; + modtypes: string String_map.t; + duplicate_modtype_names: String_set.t; +} + +and module_entry = { + position: int; + loc: Location.t; + deprecated: string option; + nested: scope option; + alias_path: string option; + declaration: string; +} + +type t = { + name: string; + signature_bytes: string; + graph: Frozen_type_graph.t; + type_binders: binder_path Stamp_map.t; + module_binders: binder_path Stamp_map.t; + modtype_binders: binder_path Stamp_map.t; + contexts: binder_context Int_map.t; + layouts: frozen_layout array; + root: scope; +} + +and binder_context = { + parent: int option; + type_binders: binder_path Stamp_map.t; + module_binders: binder_path Stamp_map.t; + modtype_binders: binder_path Stamp_map.t; +} + +type building_context = { + id: int; + parent: int option; + types: binder_path Stamp_map.t ref; + modules: binder_path Stamp_map.t ref; + modtypes: binder_path Stamp_map.t ref; +} + +type view = { + image: t; + graph: Frozen_type_graph.view; + materialized_values: (int * string, value_description * int) Hashtbl.t; + materialized_types: + ( int * string, + type_declaration * (constructor_description list * label_description list) + ) + Hashtbl.t; + materialized_extensions: (int * int, constructor_description) Hashtbl.t; + materialized_modules: (int * string, module_declaration) Hashtbl.t; + materialized_modtypes: (int * string, modtype_declaration) Hashtbl.t; + substitutions: (int, Subst.t) Hashtbl.t; + context_graphs: (int, Frozen_type_graph.view * (Path.t -> Path.t)) Hashtbl.t; + materialized_layouts: + (int option * int, Variant_runtime.layout_ref) Hashtbl.t; + map_type_path: Path.t -> Path.t; +} + +(* Keep imported member IDs outside the positive request-local stamp range. + Lazy materialization must not renumber IDs saved by the compiling module. *) +let imported_member_stamp = Atomic.make (-1_000_000_000) + +let freeze (cmi : Cmi_format.cmi_infos) = + let roots = ref [] in + let type_binders = ref Stamp_map.empty in + let module_binders = ref Stamp_map.empty in + let modtype_binders = ref Stamp_map.empty in + let next_root = ref 0 in + let next_scope = ref 0 in + let next_context = ref 0 in + let contexts = ref Int_map.empty in + let modtype_definitions = Hashtbl.create 16 in + let layout_refs = ref [] in + let layouts = ref [] in + let freeze_layout layout_ref = + match + List.find_opt (fun (saved, _) -> saved == layout_ref) !layout_refs + with + | Some (_, id) -> Some id + | None -> ( + match + try Some (Variant_runtime.get_layout layout_ref) + with Failure _ -> None + with + | None -> None + | Some layout -> + let id = List.length !layouts in + let cases = + List.init + (Variant_runtime.length layout) + (Variant_runtime.constructor_at layout) + in + layout_refs := (layout_ref, id) :: !layout_refs; + layouts := + {configuration = Variant_runtime.configuration layout; cases} + :: !layouts; + Some id) + in + let create_context parent = + let id = !next_context in + incr next_context; + { + id; + parent = Option.map (fun context -> context.id) parent; + types = ref Stamp_map.empty; + modules = ref Stamp_map.empty; + modtypes = ref Stamp_map.empty; + } + in + let add_binder scope_path context kind id position = + let entry = scope_path @ [(Ident.name id, position)] in + let add table = table := Stamp_map.add id.Ident.stamp entry !table in + match (context, kind) with + | None, Bound_type -> add type_binders + | None, Bound_module -> add module_binders + | None, Bound_modtype -> add modtype_binders + | Some context, Bound_type -> add context.types + | Some context, Bound_module -> add context.modules + | Some context, Bound_modtype -> add context.modtypes + in + let rec signature_of_modtype visited = function + | Mty_signature signature -> Some signature + | Mty_ident (Path.Pident id) -> + let stamp = id.Ident.stamp in + if List.mem stamp visited then None + else + Option.bind + (Hashtbl.find_opt modtype_definitions stamp) + (signature_of_modtype (stamp :: visited)) + | Mty_ident (Path.Pdot _ | Path.Papply _) | Mty_functor _ | Mty_alias _ -> + None + in + let add_root ty = + let root = !next_root in + incr next_root; + roots := ty :: !roots; + root + in + let marshal_nonempty = function + | [] -> None + | items -> Some (Marshal.to_string items []) + in + let freeze_label (label : label_declaration) = + { + name = label.ld_id.Ident.name; + flags = label.ld_id.Ident.flags; + runtime_name = label.ld_runtime_name; + mutable_flag = label.ld_mutable; + optional = label.ld_optional; + typ = add_root label.ld_type; + loc = label.ld_loc; + attributes = marshal_nonempty label.ld_attributes; + } + in + let freeze_constructor (constructor : constructor_declaration) = + { + name = constructor.cd_id.Ident.name; + flags = constructor.cd_id.Ident.flags; + runtime_tag = constructor.cd_runtime_tag; + args = + (match constructor.cd_args with + | Cstr_tuple types -> Frozen_tuple (List.map add_root types) + | Cstr_record labels -> + Frozen_record_arguments (List.map freeze_label labels)); + result = Option.map add_root constructor.cd_res; + loc = constructor.cd_loc; + attributes = marshal_nonempty constructor.cd_attributes; + } + in + let freeze_args = function + | Cstr_tuple types -> Frozen_tuple (List.map add_root types) + | Cstr_record labels -> + Frozen_record_arguments (List.map freeze_label labels) + in + let index_source table name source = + let previous = + match String_map.find_opt name !table with + | Some sources -> sources + | None -> [] + in + table := String_map.add name (source :: previous) !table + in + let rec freeze_scope scope_path context signature = + let id = !next_scope in + incr next_scope; + let values = ref String_map.empty in + let type_names = ref String_set.empty in + let duplicate_type_names = ref String_set.empty in + let types = ref String_map.empty in + let label_sources = ref String_map.empty in + let constructor_sources = ref String_map.empty in + let modules = ref String_map.empty in + let duplicate_module_names = ref String_set.empty in + let modtypes = ref String_map.empty in + let duplicate_modtype_names = ref String_set.empty in + let position = ref 0 in + List.iter + (function + | Sig_value (id, declaration) -> ( + let typ = add_root declaration.val_type in + let kind = + match declaration.val_kind with + | Val_reg -> None + | Val_prim _ as kind -> Some (Marshal.to_string kind []) + in + let attributes = marshal_nonempty declaration.val_attributes in + values := + String_map.add (Ident.name id) + { + typ; + kind; + loc = declaration.val_loc; + attributes; + position = !position; + } + !values; + match declaration.val_kind with + | Val_reg -> incr position + | Val_prim _ -> ()) + | Sig_type (id, declaration, _) -> ( + let type_name = Ident.name id in + if String_set.mem type_name !type_names then + duplicate_type_names := + String_set.add type_name !duplicate_type_names; + type_names := String_set.add type_name !type_names; + add_binder scope_path context Bound_type id Path.nopos; + let kind = + match declaration.type_kind with + | Type_abstract -> Some Frozen_abstract + | Type_record (labels, representation) -> ( + List.iter + (fun label -> + index_source label_sources (Ident.name label.ld_id) type_name) + labels; + match representation with + | Record_inlined {name; representation = {variant; position}} -> + Option.map + (fun layout -> + Frozen_record + ( List.map freeze_label labels, + Inlined_record {name; layout; position} )) + (freeze_layout variant) + | Record_regular | Record_float_unused | Record_unboxed _ + | Record_extension -> + Some + (Frozen_record + (List.map freeze_label labels, Static_record representation)) + ) + | Type_variant (constructors, layout_ref) -> + List.iter + (fun constructor -> + index_source constructor_sources + (Ident.name constructor.cd_id) + (Variant_source type_name)) + constructors; + Option.map + (fun layout -> + Frozen_variant + (List.map freeze_constructor constructors, layout)) + (freeze_layout layout_ref) + | Type_open -> Some Frozen_open + in + match kind with + | Some kind -> + let inlined_types = + List.map + (function + | Record {type_name; labels} -> + Frozen_inlined_record + (type_name, List.map freeze_label labels)) + declaration.type_inlined_types + in + types := + String_map.add (Ident.name id) + { + params = List.map add_root declaration.type_params; + arity = declaration.type_arity; + kind; + private_flag = declaration.type_private; + manifest = Option.map add_root declaration.type_manifest; + variance = declaration.type_variance; + loc = declaration.type_loc; + attributes = marshal_nonempty declaration.type_attributes; + immediate = declaration.type_immediate; + representation = declaration.type_representation; + inlined_types; + } + !types + | None -> ()) + | Sig_typext (id, extension, _) -> + add_binder scope_path context Bound_type id !position; + let source = + Extension_source + { + name = Ident.name id; + position = !position; + type_path = Marshal.to_string extension.ext_type_path []; + type_params = List.map add_root extension.ext_type_params; + args = freeze_args extension.ext_args; + ret_type = Option.map add_root extension.ext_ret_type; + private_flag = extension.ext_private; + loc = extension.ext_loc; + attributes = marshal_nonempty extension.ext_attributes; + is_exception = extension.ext_is_exception; + } + in + index_source constructor_sources (Ident.name id) source; + incr position + | Sig_module (id, declaration, _) -> + let name = Ident.name id in + if String_map.mem name !modules then + duplicate_module_names := + String_set.add name !duplicate_module_names; + add_binder scope_path context Bound_module id !position; + let nested = + match declaration.md_type with + | Mty_signature signature -> + Some + (freeze_scope + (scope_path @ [(name, !position)]) + context signature) + | Mty_ident _ as module_type -> ( + match signature_of_modtype [] module_type with + | None -> None + | Some signature -> + let instantiation = create_context context in + let nested = + freeze_scope + (scope_path @ [(name, !position)]) + (Some instantiation) signature + in + contexts := + Int_map.add instantiation.id + { + parent = instantiation.parent; + type_binders = !(instantiation.types); + module_binders = !(instantiation.modules); + modtype_binders = !(instantiation.modtypes); + } + !contexts; + Some nested) + | Mty_functor _ | Mty_alias _ -> None + in + modules := + String_map.add name + { + position = !position; + loc = declaration.md_loc; + deprecated = + Builtin_attributes.deprecated_of_attrs + declaration.md_attributes; + nested; + alias_path = + (match declaration.md_type with + | Mty_alias (_, path) -> Some (Marshal.to_string path []) + | Mty_ident _ | Mty_signature _ | Mty_functor _ -> None); + declaration = Marshal.to_string declaration []; + } + !modules; + incr position + | Sig_modtype (id, declaration) -> + let name = Ident.name id in + if String_map.mem name !modtypes then + duplicate_modtype_names := + String_set.add name !duplicate_modtype_names; + add_binder scope_path context Bound_modtype id Path.nopos; + Option.iter + (fun module_type -> + Hashtbl.replace modtype_definitions id.Ident.stamp module_type) + declaration.mtd_type; + modtypes := + String_map.add name (Marshal.to_string declaration []) !modtypes) + signature; + { + id; + path = scope_path; + context_id = Option.map (fun context -> context.id) context; + values = !values; + type_names = !type_names; + duplicate_type_names = !duplicate_type_names; + types = !types; + label_sources = !label_sources; + constructor_sources = !constructor_sources; + modules = !modules; + duplicate_module_names = !duplicate_module_names; + modtypes = !modtypes; + duplicate_modtype_names = !duplicate_modtype_names; + } + in + let root = freeze_scope [] None cmi.cmi_sign in + match Frozen_type_graph.freeze (List.rev !roots) with + | Error reason -> Error reason + | Ok graph -> + Ok + { + name = cmi.cmi_name; + signature_bytes = Marshal.to_string cmi.cmi_sign []; + graph; + type_binders = !type_binders; + module_binders = !module_binders; + modtype_binders = !modtype_binders; + contexts = !contexts; + layouts = Array.of_list (List.rev !layouts); + root; + } + +let create_graph_view image context_id = + let root = Path.Pident (Ident.create_persistent image.name) in + let rec find_context_binder context_id select stamp = + match context_id with + | None -> None + | Some context_id -> ( + let context = Int_map.find context_id image.contexts in + match Stamp_map.find_opt stamp (select context) with + | Some _ as entry -> entry + | None -> find_context_binder context.parent select stamp) + in + let prefixed global select id = + let entry = + match find_context_binder context_id select id.Ident.stamp with + | Some _ as entry -> entry + | None -> Stamp_map.find_opt id.Ident.stamp global + in + match entry with + | Some segments -> + List.fold_left + (fun path (name, position) -> Path.Pdot (path, name, position)) + root segments + | None -> Path.Pident id + in + let rec map_module_path = function + | Path.Pident id -> + prefixed image.module_binders (fun context -> context.module_binders) id + | Path.Pdot (path, name, position) -> + Path.Pdot (map_module_path path, name, position) + | Path.Papply (first, second) -> + Path.Papply (map_module_path first, map_module_path second) + in + let map_type_path path = + match Path.constructor_typath path with + | Path.Regular (Path.Pident id) -> + prefixed image.type_binders (fun context -> context.type_binders) id + | Path.Regular (Path.Pdot (module_path, name, position)) -> + Path.Pdot (map_module_path module_path, name, position) + | Path.Regular (Path.Papply _) -> path + | Path.Cstr (type_path, constructor) -> + let type_path = + match type_path with + | Path.Pident id -> + prefixed image.type_binders (fun context -> context.type_binders) id + | Path.Pdot (module_path, name, position) -> + Path.Pdot (map_module_path module_path, name, position) + | Path.Papply _ -> type_path + in + Path.Pdot (type_path, constructor, Path.nopos) + | Path.LocalExt _ -> path + | Path.Ext (module_path, constructor) -> + Path.Pdot (map_module_path module_path, constructor, Path.nopos) + in + let map_modtype_path = function + | Path.Pident id -> + prefixed image.modtype_binders (fun context -> context.modtype_binders) id + | Path.Pdot (path, name, position) -> + Path.Pdot (map_module_path path, name, position) + | Path.Papply _ as path -> map_module_path path + in + let graph = + Frozen_type_graph.create_view ~map_type_path ~map_modtype_path image.graph + in + (graph, map_type_path) + +let create_view image = + let graph, map_type_path = create_graph_view image None in + { + image; + graph; + materialized_values = Hashtbl.create 16; + materialized_types = Hashtbl.create 16; + materialized_extensions = Hashtbl.create 8; + materialized_modules = Hashtbl.create 8; + materialized_modtypes = Hashtbl.create 8; + substitutions = Hashtbl.create 8; + context_graphs = Hashtbl.create 8; + materialized_layouts = Hashtbl.create 8; + map_type_path; + } + +let copy_signature view : signature = + let source = Marshal.from_string view.image.signature_bytes 0 in + Subst.signature Subst.identity source + +let source_signature view : signature = + Marshal.from_string view.image.signature_bytes 0 + +let scope_graph view (scope : scope) = + match scope.context_id with + | None -> (view.graph, view.map_type_path) + | Some context_id -> ( + match Hashtbl.find_opt view.context_graphs context_id with + | Some graph -> graph + | None -> + let graph = create_graph_view view.image (Some context_id) in + Hashtbl.add view.context_graphs context_id graph; + graph) + +let scope_layout view (scope : scope) id = + let key = (scope.context_id, id) in + match Hashtbl.find_opt view.materialized_layouts key with + | Some layout -> layout + | None -> + let {configuration; cases} = view.image.layouts.(id) in + let layout = Variant_runtime.pending_layout () in + Variant_runtime.complete_layout layout + (Variant_runtime.make_layout ~configuration (Array.of_list cases)); + Hashtbl.add view.materialized_layouts key layout; + layout + +let thaw_attributes = function + | None -> [] + | Some bytes -> Marshal.from_string bytes 0 + +let fresh_member_id name flags = + {Ident.name; stamp = Atomic.fetch_and_add imported_member_stamp (-1); flags} + +let thaw_label graph (label : frozen_label) = + { + ld_id = fresh_member_id label.name label.flags; + ld_runtime_name = label.runtime_name; + ld_mutable = label.mutable_flag; + ld_optional = label.optional; + ld_type = Frozen_type_graph.type_at graph label.typ; + ld_loc = label.loc; + ld_attributes = thaw_attributes label.attributes; + } + +let thaw_args graph = function + | Frozen_tuple types -> + Cstr_tuple (List.map (Frozen_type_graph.type_at graph) types) + | Frozen_record_arguments labels -> + Cstr_record (List.map (thaw_label graph) labels) + +let scope_path view (scope : scope) = + List.fold_left + (fun path (name, position) -> Path.Pdot (path, name, position)) + (Path.Pident (Ident.create_persistent view.image.name)) + scope.path + +let scope_substitution view (scope : scope) = + match Hashtbl.find_opt view.substitutions scope.id with + | Some substitution -> substitution + | None -> + let rec is_prefix prefix path = + match (prefix, path) with + | [], _ -> true + | first :: rest, next :: tail when first = next -> is_prefix rest tail + | _ -> false + in + let rec parent_segments = function + | [] | [_] -> [] + | first :: rest -> first :: parent_segments rest + in + let is_visible segments = is_prefix (parent_segments segments) scope.path in + let path segments = + List.fold_left + (fun path (name, position) -> Path.Pdot (path, name, position)) + (Path.Pident (Ident.create_persistent view.image.name)) + segments + in + let identifier stamp segments = + let name, _ = List.hd (List.rev segments) in + {Ident.name; stamp; flags = 0} + in + let add table add substitution = + Stamp_map.fold + (fun stamp segments substitution -> + if is_visible segments then + add (identifier stamp segments) (path segments) substitution + else substitution) + table substitution + in + let substitution = + Subst.identity + |> add view.image.type_binders Subst.add_type + |> add view.image.module_binders Subst.add_module + |> add view.image.modtype_binders (fun id path substitution -> + Subst.add_modtype id (Mty_ident path) substitution) + in + let rec context_chain = function + | None -> [] + | Some context_id -> + let context = Int_map.find context_id view.image.contexts in + context_chain context.parent @ [context] + in + let substitution = + List.fold_left + (fun substitution (context : binder_context) -> + substitution + |> add context.type_binders Subst.add_type + |> add context.module_binders Subst.add_module + |> add context.modtype_binders (fun id path substitution -> + Subst.add_modtype id (Mty_ident path) substitution)) + substitution + (context_chain scope.context_id) + in + Hashtbl.add view.substitutions scope.id substitution; + substitution + +let find_module_declaration view (scope : scope) name = + if String_set.mem name scope.duplicate_module_names then None + else + match String_map.find_opt name scope.modules with + | None -> None + | Some entry -> ( + let key = (scope.id, name) in + match Hashtbl.find_opt view.materialized_modules key with + | Some declaration -> Some (declaration, entry.position) + | None -> + let source = Marshal.from_string entry.declaration 0 in + let declaration = + Subst.module_declaration (scope_substitution view scope) source + in + Hashtbl.add view.materialized_modules key declaration; + Some (declaration, entry.position)) + +let find_modtype_declaration view (scope : scope) name = + if String_set.mem name scope.duplicate_modtype_names then None + else + match String_map.find_opt name scope.modtypes with + | None -> None + | Some bytes -> ( + let key = (scope.id, name) in + match Hashtbl.find_opt view.materialized_modtypes key with + | Some declaration -> Some declaration + | None -> + let source = Marshal.from_string bytes 0 in + let declaration = + Subst.modtype_declaration (scope_substitution view scope) source + in + Hashtbl.add view.materialized_modtypes key declaration; + Some declaration) + +let thaw_extension view (scope : scope) (extension : frozen_extension) = + let key = (scope.id, extension.position) in + match Hashtbl.find_opt view.materialized_extensions key with + | Some descr -> descr + | None -> + let graph, map_type_path = scope_graph view scope in + let path = + Path.Pdot (scope_path view scope, extension.name, extension.position) + in + let ext : extension_constructor = + { + ext_type_path = map_type_path (Marshal.from_string extension.type_path 0); + ext_type_params = + List.map (Frozen_type_graph.type_at graph) extension.type_params; + ext_args = thaw_args graph extension.args; + ext_ret_type = + Option.map (Frozen_type_graph.type_at graph) extension.ret_type; + ext_private = extension.private_flag; + ext_loc = extension.loc; + ext_attributes = thaw_attributes extension.attributes; + ext_is_exception = extension.is_exception; + } + in + let descr = Datarepr.extension_descr path ext in + Hashtbl.add view.materialized_extensions key descr; + descr + +let find_in_scope view (scope : scope) name = + let key = (scope.id, name) in + match Hashtbl.find_opt view.materialized_values key with + | Some value -> Some value + | None -> ( + match String_map.find_opt name scope.values with + | None -> None + | Some {typ; kind; loc; attributes; position} -> + let graph, _ = scope_graph view scope in + let val_type = Frozen_type_graph.type_at graph typ in + let val_kind = + match kind with + | None -> Val_reg + | Some bytes -> Marshal.from_string bytes 0 + in + let val_attributes = thaw_attributes attributes in + let value = + ({val_type; val_kind; val_loc = loc; val_attributes}, position) + in + Hashtbl.add view.materialized_values key value; + Some value) + +let find_type_in_scope view (scope : scope) name = + let key = (scope.id, name) in + match Hashtbl.find_opt view.materialized_types key with + | Some declaration -> Some declaration + | None -> ( + match String_map.find_opt name scope.types with + | None -> None + | Some + { + params; + arity; + kind; + private_flag; + manifest; + variance; + loc; + attributes; + immediate; + representation; + inlined_types; + } -> + let graph, _ = scope_graph view scope in + let thaw_constructor (constructor : frozen_constructor) = + { + cd_id = fresh_member_id constructor.name constructor.flags; + cd_runtime_tag = constructor.runtime_tag; + cd_args = thaw_args graph constructor.args; + cd_res = + Option.map (Frozen_type_graph.type_at graph) constructor.result; + cd_loc = constructor.loc; + cd_attributes = thaw_attributes constructor.attributes; + } + in + let declaration = + { + type_params = List.map (Frozen_type_graph.type_at graph) params; + type_arity = arity; + type_kind = + (match kind with + | Frozen_abstract -> Type_abstract + | Frozen_record (labels, representation) -> + let representation = + match representation with + | Static_record representation -> representation + | Inlined_record {name; layout; position} -> + Record_inlined + { + name; + representation = + {variant = scope_layout view scope layout; position}; + } + in + Type_record (List.map (thaw_label graph) labels, representation) + | Frozen_variant (constructors, layout) -> + Type_variant + ( List.map thaw_constructor constructors, + scope_layout view scope layout ) + | Frozen_open -> Type_open); + type_private = private_flag; + type_manifest = Option.map (Frozen_type_graph.type_at graph) manifest; + type_variance = variance; + type_newtype_level = None; + type_loc = loc; + type_attributes = thaw_attributes attributes; + type_immediate = immediate; + type_representation = representation; + type_inlined_types = + List.map + (function + | Frozen_inlined_record (type_name, labels) -> + Record + {type_name; labels = List.map (thaw_label graph) labels}) + inlined_types; + } + in + let path = Path.Pdot (scope_path view scope, name, Path.nopos) in + Datarepr.set_row_name declaration path; + let descriptions = + ( List.map snd (Datarepr.constructors_of_type path declaration), + List.map snd (Datarepr.labels_of_type path declaration) ) + in + let result = (declaration, descriptions) in + Hashtbl.add view.materialized_types key result; + Some result) + +let find_labels_in_scope view (scope : scope) name = + match String_map.find_opt name scope.label_sources with + | None -> Some [] + | Some sources + when List.exists + (fun source -> String_set.mem source scope.duplicate_type_names) + sources -> + None + | Some sources -> + let rec collect acc = function + | [] -> Some (List.rev acc) + | source :: rest -> ( + match find_type_in_scope view scope source with + | None -> None + | Some (_, (_, labels)) -> + let matching = + List.filter (fun label -> label.lbl_name = name) labels + in + collect (List.rev_append matching acc) rest) + in + collect [] sources + +let find_constructors_in_scope view (scope : scope) name = + match String_map.find_opt name scope.constructor_sources with + | None -> Some [] + | Some sources -> + let rec collect acc = function + | [] -> Some (List.rev acc) + | Extension_source extension :: rest -> + collect (thaw_extension view scope extension :: acc) rest + | Variant_source source :: rest -> ( + if String_set.mem source scope.duplicate_type_names then None + else + match find_type_in_scope view scope source with + | None -> None + | Some (_, (constructors, _)) -> + let matching = + List.filter + (fun constructor -> constructor.cstr_name = name) + constructors + in + collect (List.rev_append matching acc) rest) + in + collect [] sources + +let find_extension_in_scope view (scope : scope) name = + match String_map.find_opt name scope.constructor_sources with + | None -> None + | Some sources -> ( + let extensions = + List.filter_map + (function + | Extension_source extension -> Some extension + | Variant_source _ -> None) + sources + in + match extensions with + | [extension] -> Some (thaw_extension view scope extension) + | [] | _ :: _ :: _ -> None) + +let root_scope view = view.image.root + +let names table = List.map fst (String_map.bindings table) +let value_names (scope : scope) = names scope.values +let type_names (scope : scope) = String_set.elements scope.type_names +let label_names (scope : scope) = names scope.label_sources +let constructor_names (scope : scope) = names scope.constructor_sources +let module_names (scope : scope) = names scope.modules +let modtype_names (scope : scope) = names scope.modtypes +let has_value (scope : scope) name = String_map.mem name scope.values +let has_type (scope : scope) name = String_set.mem name scope.type_names +let has_label (scope : scope) name = String_map.mem name scope.label_sources + +let has_constructor (scope : scope) name = + String_map.mem name scope.constructor_sources + +let has_module (scope : scope) name = String_map.mem name scope.modules +let has_modtype (scope : scope) name = String_map.mem name scope.modtypes + +let find_module_info (scope : scope) name = + if String_set.mem name scope.duplicate_module_names then None + else + match String_map.find_opt name scope.modules with + | Some {position; loc; deprecated} -> Some (position, loc, deprecated) + | None -> None + +let find_module_alias view (scope : scope) name = + if String_set.mem name scope.duplicate_module_names then None + else + match String_map.find_opt name scope.modules with + | Some {alias_path = Some bytes} -> + let path = Marshal.from_string bytes 0 in + Some (Subst.module_path (scope_substitution view scope) path) + | Some {alias_path = None} | None -> None + +let find_module (scope : scope) name = + if String_set.mem name scope.duplicate_module_names then None + else + match String_map.find_opt name scope.modules with + | Some {nested = Some nested; position; loc; deprecated} -> + Some (nested, position, loc, deprecated) + | Some {nested = None} | None -> None + +let find view name = find_in_scope view view.image.root name +let find_type view name = find_type_in_scope view view.image.root name +let find_labels view name = find_labels_in_scope view view.image.root name + +let find_constructors view name = + find_constructors_in_scope view view.image.root name + +let find_extension view name = find_extension_in_scope view view.image.root name + +let value_count (image : t) = String_map.cardinal image.root.values +let is_type_name_in_scope scope name = String_set.mem name scope.type_names +let is_type_name view name = is_type_name_in_scope view.image.root name +let type_count (image : t) = String_map.cardinal image.root.types +let type_node_count (image : t) = Frozen_type_graph.node_count image.graph diff --git a/compiler/ml/frozen_values.mli b/compiler/ml/frozen_values.mli new file mode 100644 index 0000000000..f6fe3560e4 --- /dev/null +++ b/compiler/ml/frozen_values.mli @@ -0,0 +1,110 @@ +(** The directly indexed slice of an immutable compiled interface. The image + is safe to share between compiler domains; every [view] and materialized + declaration belongs to one compilation request. *) + +type t +type view +type scope + +val freeze : Cmi_format.cmi_infos -> (t, string) result +(** Snapshot an imported signature, its nested scopes, type graph, module + declarations, and name indexes into project-shareable data. *) + +val create_view : t -> view + +val copy_signature : view -> Types.signature +(** Materialize and prefix an entire request-owned signature when a caller + needs one. This is intentionally a full-copy compatibility path. *) + +val source_signature : view -> Types.signature +(** Decode a private source signature for legacy component expansion. *) + +val root_scope : view -> scope + +val value_names : scope -> string list +val type_names : scope -> string list +val label_names : scope -> string list +val constructor_names : scope -> string list +val module_names : scope -> string list +val modtype_names : scope -> string list +val has_value : scope -> string -> bool +val has_type : scope -> string -> bool +val has_label : scope -> string -> bool +val has_constructor : scope -> string -> bool +val has_module : scope -> string -> bool +val has_modtype : scope -> string -> bool + +val find_module : + scope -> string -> (scope * int * Location.t * string option) option +(** Return a nested signature and its path position, location, and deprecation + message. Literal signatures and instances of locally declared module + types are indexed. Aliases, functors, and shadowed module names return + [None] here and have separate declaration or alias accessors. *) + +val find_module_info : + scope -> string -> (int * Location.t * string option) option + +val find_module_alias : view -> scope -> string -> Path.t option +(** Return the target of a module alias after prefixing local binders. *) + +val find_module_declaration : + view -> scope -> string -> (Types.module_declaration * int) option +(** Decode and substitute one module declaration in the request view. *) + +val find_modtype_declaration : + view -> scope -> string -> Types.modtype_declaration option +(** Decode and substitute one module-type declaration in the request view. *) + +val find_in_scope : + view -> scope -> string -> (Types.value_description * int) option + +val find_type_in_scope : + view -> + scope -> + string -> + (Types.type_declaration + * (Types.constructor_description list * Types.label_description list)) + option + +val find_labels_in_scope : + view -> scope -> string -> Types.label_description list option + +val find_constructors_in_scope : + view -> scope -> string -> Types.constructor_description list option + +val find_extension_in_scope : + view -> scope -> string -> Types.constructor_description option + +val is_type_name_in_scope : scope -> string -> bool + +val find : view -> string -> (Types.value_description * int) option +(** Return a request-local description and its signature position. No type + graph or declaration record from the image escapes this operation. *) + +val find_type : + view -> + string -> + (Types.type_declaration + * (Types.constructor_description list * Types.label_description list)) + option +(** Materialize a root type and its descriptions in the request-local view. *) + +val find_labels : view -> string -> Types.label_description list option +(** Return request-local root record labels. [None] means a duplicate or + unsupported declaration needs the legacy component path. *) + +val find_constructors : + view -> string -> Types.constructor_description list option +(** Return request-local top-level variant and extension constructors. [None] + means an unsupported declaration needs the existing component path. *) + +val find_extension : view -> string -> Types.constructor_description option +(** Return a unique extension constructor for a constructor type path. *) + +val value_count : t -> int + +val is_type_name : view -> string -> bool +(** Test whether a top-level name denotes a type, without materializing it. *) + +val type_count : t -> int +val type_node_count : t -> int diff --git a/rewatch-ocaml/bench/dune b/rewatch-ocaml/bench/dune new file mode 100644 index 0000000000..b314dec24a --- /dev/null +++ b/rewatch-ocaml/bench/dune @@ -0,0 +1,3 @@ +(executable + (name frozen_type_graph_probe) + (libraries ml unix)) diff --git a/rewatch-ocaml/bench/frozen_type_graph_probe.ml b/rewatch-ocaml/bench/frozen_type_graph_probe.ml new file mode 100644 index 0000000000..a7b2d57b85 --- /dev/null +++ b/rewatch-ocaml/bench/frozen_type_graph_probe.ml @@ -0,0 +1,57 @@ +(* Diagnostic microprobe for the type-graph slice of an imported CMI. It does + not model signature records or Env component construction. *) + +let roots_of_signature signature = + let roots = ref [] in + let original = Btype.type_iterators in + let iterator = + {original with it_type_expr = (fun _ ty -> roots := ty :: !roots)} + in + iterator.it_signature iterator signature; + List.rev !roots + +let measure ~iterations name action = + Gc.full_major (); + let started = Unix.gettimeofday () in + let before = Gc.allocated_bytes () in + let consumed = ref 0 in + for _ = 1 to iterations do + consumed := !consumed + action () + done; + let seconds = Unix.gettimeofday () -. started in + let bytes = Gc.allocated_bytes () -. before in + Printf.printf "%s\t%d\t%.3f\t%.1f\t%d\n" name iterations (seconds *. 1000.) + (bytes /. 1e6) !consumed + +let () = + if Array.length Sys.argv <> 3 then ( + prerr_endline "Usage: frozen_type_graph_probe CMI ITERATIONS"; + exit 2); + let filename = Sys.argv.(1) in + let iterations = int_of_string Sys.argv.(2) in + if iterations <= 0 then invalid_arg "iterations must be positive"; + let cmi = Cmi_format.read_cmi filename in + let roots = roots_of_signature cmi.cmi_sign in + let image = + match Frozen_type_graph.freeze roots with + | Ok image -> image + | Error reason -> failwith reason + in + let bytes = Marshal.to_bytes cmi [] in + Printf.printf "cmi_bytes=%d type_roots=%d type_nodes=%d\n" + (Bytes.length bytes) (List.length roots) + (Frozen_type_graph.node_count image); + Printf.printf "operation\titerations\tworker_ms\tallocated_MB\tchecksum\n"; + measure ~iterations "freeze_type_graph" (fun () -> + match Frozen_type_graph.freeze roots with + | Ok image -> Frozen_type_graph.node_count image + | Error reason -> failwith reason); + measure ~iterations "thaw_type_graph" (fun () -> + List.length (Frozen_type_graph.thaw image)); + measure ~iterations "thaw_first_root" (fun () -> + (Frozen_type_graph.thaw_root image 0).Types.id); + measure ~iterations "marshal_cmi_decode" (fun () -> + let copy : Cmi_format.cmi_infos = Marshal.from_bytes bytes 0 in + List.length copy.cmi_sign); + measure ~iterations "subst_signature" (fun () -> + List.length (Subst.signature Subst.identity cmi.cmi_sign)) diff --git a/rewatch-ocaml/bench/make_immutable_interface_fixture.py b/rewatch-ocaml/bench/make_immutable_interface_fixture.py new file mode 100644 index 0000000000..3c6ba7720c --- /dev/null +++ b/rewatch-ocaml/bench/make_immutable_interface_fixture.py @@ -0,0 +1,114 @@ +#!/usr/bin/env python3 +"""Create the flat-CMI workload used by IMMUTABLE_INTERFACES.md.""" + +import json +import sys +from pathlib import Path + + +def main() -> None: + if len(sys.argv) not in (2, 3) or ( + len(sys.argv) == 3 + and sys.argv[2] + not in ( + "--values-only", + "--types-only", + "--variants-only", + "--modules-only", + "--open-only", + ) + ): + raise SystemExit( + f"Usage: {sys.argv[0]} OUTPUT_DIRECTORY " + "[--values-only|--types-only|--variants-only|--modules-only|--open-only]" + ) + mode = sys.argv[2] if len(sys.argv) == 3 else "default" + root = Path(sys.argv[1]).resolve() + if root.exists(): + raise SystemExit(f"Output directory already exists: {root}") + source = root / "src" + source.mkdir(parents=True) + (root / "rescript.json").write_text( + json.dumps( + { + "name": "immutable-interface-probe", + "sources": {"dir": "src", "subdirs": True}, + "package-specs": {"module": "esmodule", "in-source": True}, + "suffix": ".mjs", + }, + indent=2, + ) + + "\n" + ) + if mode == "--modules-only": + (source / "Api.res").write_text( + "".join(f"let value{i} = {i}\n" for i in range(400)) + + "module type S = {type t; let answer: int}\n" + + "module A: S = {type t = int; let answer = 1}\n" + + 'module B: S = {type t = string; let answer = 2}\n' + + "module Alias = A\n" + + "module F = (X: S) => {let same = X.answer}\n" + ) + elif mode == "--types-only": + (source / "Api.resi").write_text( + "".join(f"type opaque{i}\ntype alias{i} = opaque{i}\n" for i in range(200)) + ) + (source / "Api.res").write_text( + "".join( + f"type opaque{i} = int\ntype alias{i} = opaque{i}\n" + for i in range(200) + ) + ) + elif mode == "--variants-only": + variants = "".join( + f"type choice{i} = A{i} | B{i}(int)\n" for i in range(200) + ) + (source / "Api.resi").write_text(variants) + (source / "Api.res").write_text(variants) + else: + (source / "Api.resi").write_text( + "".join(f"let value{i}: int\n" for i in range(400)) + + "let id: 'a => 'a\n" + + "type box<'a> = {value: 'a}\n" + ) + (source / "Api.res").write_text( + "".join(f"let value{i} = {i}\n" for i in range(400)) + + "let id = x => x\n" + + "type box<'a> = {value: 'a}\n" + ) + for i in range(200): + if mode == "--modules-only": + text = ( + "module Applied = Api.F(Api.A)\n" + f"let result = Api.value{i} + Api.A.answer + Api.B.answer " + "+ Api.Alias.answer + Applied.same\n" + ) + elif mode == "--open-only": + text = ( + "open Api\n" + f"let result = value{i} + id({i})\n" + "let box: box = {value: result}\n" + ) + elif mode == "--types-only": + text = ( + f"let opaque = (x: Api.opaque{i}) => x\n" + f"let alias = (x: Api.alias{i}) => x\n" + ) + elif mode == "--variants-only": + text = ( + f"let selected = Api.B{i}({i})\n" + f"let result = switch selected {{\n" + f"| Api.A{i} => 0\n" + f"| Api.B{i}(value) => value\n" + f"}}\n" + ) + else: + text = f"let result = Api.value{i} + Api.id({i})\n" + ( + "" if mode == "--values-only" else "let box: Api.box = {value: result}\n" + ) + (source / f"Consumer{i}.res").write_text(text) + print(root) + + +if __name__ == "__main__": + main() diff --git a/tests/ounit_tests/ounit_frozen_type_graph_tests.ml b/tests/ounit_tests/ounit_frozen_type_graph_tests.ml new file mode 100644 index 0000000000..66e621a088 --- /dev/null +++ b/tests/ounit_tests/ounit_frozen_type_graph_tests.ml @@ -0,0 +1,234 @@ +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) +let assert_bool = OUnit.assert_bool + +let freeze roots = + match Frozen_type_graph.freeze roots with + | Ok image -> image + | Error reason -> OUnit.assert_failure reason + +let test_root_sharing_and_instantiation _ = + let variable = Btype.newgenty (Types.Tvar (Some "a")) in + let scheme = + Btype.newgenty + (Types.Tarrow ([Types.{lbl = Asttypes.Nolabel; typ = variable}], variable)) + in + let image = freeze [scheme; scheme] in + OUnit.assert_equal 2 (Frozen_type_graph.node_count image); + match Frozen_type_graph.thaw image with + | [first; second] -> ( + assert_bool "two roots keep the same scheme identity" (first == second); + let first_use = Ctype.instance Env.empty first in + let second_use = Ctype.instance Env.empty first in + assert_bool "each use has its own mutable inference graph" + (first_use != second_use); + match (first_use.desc, second_use.desc, first.desc) with + | ( Types.Tarrow ([{typ = first_arg}], first_result), + Types.Tarrow ([{typ = second_arg}], second_result), + Types.Tarrow ([{typ = scheme_arg}], scheme_result) ) -> + assert_bool "an instance preserves type-variable identity" + (first_arg == first_result && second_arg == second_result); + assert_bool "separate uses do not share inference variables" + (first_arg != second_arg); + assert_bool "instantiation did not change the thawed scheme" + (scheme_arg == scheme_result && scheme_arg != first_arg) + | _ -> OUnit.assert_failure "expected three function types") + | _ -> OUnit.assert_failure "expected two roots" + +let field_cell ty = + match ty.Types.desc with + | Types.Tfield {mutability; _} -> mutability + | _ -> OUnit.assert_failure "expected an object field" + +let test_mutability_classes_are_local _ = + let cell = ref (Types.Mutability_value Asttypes.Immutable) in + let rest = Btype.newgenty (Types.Tvar None) in + let field name = + Btype.newgenty + (Types.Tfield {name; mutability = cell; typ = Predef.type_int (); rest}) + in + let image = freeze [field "x"; field "y"] in + let first = Frozen_type_graph.thaw image in + let second = Frozen_type_graph.thaw image in + match (first, second) with + | [a; b], [c; d] -> + let a_cell = field_cell a in + assert_bool "a thaw preserves aliasing inside the image" + (a_cell == field_cell b); + assert_bool "separate thaws own separate mutability classes" + (a_cell != field_cell c && field_cell c == field_cell d); + a_cell := Types.Mutability_value Asttypes.Mutable; + assert_bool "a thaw cannot mutate the shared image or another thaw" + (Btype.mutability_repr (field_cell c) = Asttypes.Immutable + && Btype.mutability_repr cell = Asttypes.Immutable) + | _ -> OUnit.assert_failure "expected two fields per thaw" + +let test_poly_quantifiers_instantiate_independently _ = + let universal = Btype.newgenty (Types.Tunivar (Some "a")) in + let body = + Btype.newgenty + (Types.Tarrow + ([Types.{lbl = Asttypes.Nolabel; typ = universal}], universal)) + in + let image = freeze [Btype.newgenty (Types.Tpoly (body, [universal]))] in + let scheme = Frozen_type_graph.thaw_root image 0 in + match scheme.Types.desc with + | Types.Tpoly (body, [universal]) -> ( + let first_variables, first = + Ctype.instance_poly ~fixed:false [universal] body + in + let second_variables, second = + Ctype.instance_poly ~fixed:false [universal] body + in + let first_variable, second_variable = + match (first_variables, second_variables) with + | [first_variable], [second_variable] -> (first_variable, second_variable) + | _ -> OUnit.assert_failure "expected one instance variable per use" + in + assert_bool "quantified variables are fresh for each use" + (first_variable != second_variable); + match (first.desc, second.desc, body.desc) with + | ( Types.Tarrow ([{typ = first_arg}], first_result), + Types.Tarrow ([{typ = second_arg}], second_result), + Types.Tarrow ([{typ = original_arg}], original_result) ) -> + assert_bool "each body uses its own quantified variable" + (first_arg == first_result + && first_arg == first_variable + && second_arg == second_result + && second_arg == second_variable); + assert_bool "the frozen scheme's thaw stays quantified" + (original_arg == universal && original_result == universal) + | _ -> OUnit.assert_failure "expected two instantiated functions") + | _ -> OUnit.assert_failure "expected a quantified function" + +let test_cycles_and_identifier_sharing _ = + let recursive = Btype.newgenty (Types.Tvar None) in + recursive.desc <- Types.Ttuple [recursive]; + let ident = Ident.create "local" in + let first = + Btype.newgenty (Types.Tconstr (Path.Pident ident, [], ref Types.Mnil)) + in + let second = + Btype.newgenty (Types.Tconstr (Path.Pident ident, [], ref Types.Mnil)) + in + let image = freeze [recursive; first; second] in + let thaw () = Frozen_type_graph.thaw image in + let left = Domain.spawn thaw in + let right = Domain.spawn thaw in + match (Domain.join left, Domain.join right) with + | [cycle_a; a; b], [cycle_b; c; d] -> + (match (cycle_a.desc, cycle_b.desc) with + | Types.Ttuple [back_a], Types.Ttuple [back_b] -> + assert_bool "cycles preserve their own identity" + (back_a == cycle_a && back_b == cycle_b && cycle_a != cycle_b) + | _ -> OUnit.assert_failure "expected recursive tuples"); + let path_ident ty = + match ty.Types.desc with + | Types.Tconstr (Path.Pident id, _, _) -> id + | _ -> OUnit.assert_failure "expected a constructor path" + in + assert_bool "identifiers share within a thaw" + (path_ident a == path_ident b && path_ident c == path_ident d); + assert_bool "identifiers belong to one thaw" (path_ident a != path_ident c) + | _ -> OUnit.assert_failure "expected three roots per thaw" + +let test_variant_row_references_are_local _ = + let row_reference = ref None in + let field = Types.Reither (true, [], false, row_reference) in + let source = + Btype.newgenty + (Types.Tvariant + { + row_fields = [("A", field); ("B", field)]; + row_more = Btype.newgenty Types.Tnil; + row_closed = true; + row_fixed = false; + row_name = None; + }) + in + let image = freeze [source] in + let row_refs ty = + match ty.Types.desc with + | Types.Tvariant + { + row_fields = + [ + ("A", Types.Reither (_, _, _, a)); + ("B", Types.Reither (_, _, _, b)); + ]; + _; + } -> + (a, b) + | _ -> OUnit.assert_failure "expected two variant rows" + in + match (Frozen_type_graph.thaw image, Frozen_type_graph.thaw image) with + | [first], [second] -> + let a, b = row_refs first in + let c, d = row_refs second in + assert_bool "row references share within an image" (a == b && c == d); + assert_bool "row references are request-local" (a != c); + a := Some Types.Rabsent; + assert_bool "a row update does not change the image or another thaw" + (!c = None && !row_reference = None) + | _ -> OUnit.assert_failure "expected one variant per thaw" + +let test_rejects_transient_state _ = + let variable = Btype.newgenty (Types.Tvar None) in + let marked = Btype.newgenty (Types.Tsubst variable) in + let memo = ref (Types.Mlink (ref Types.Mnil)) in + let abbreviated = + Btype.newgenty + (Types.Tconstr (Path.Pident (Ident.create_persistent "Alias"), [], memo)) + in + assert_bool "copy marks cannot enter the immutable image" + (Result.is_error (Frozen_type_graph.freeze [marked])); + assert_bool "abbreviation memo state cannot enter the immutable image" + (Result.is_error (Frozen_type_graph.freeze [abbreviated])) + +let test_selective_thaw _ = + let unused = Btype.newgenty (Types.Ttuple [Predef.type_int ()]) in + let chosen = Btype.newgenty (Types.Tvar (Some "chosen")) in + let image = freeze [unused; chosen] in + OUnit.assert_equal 2 (Frozen_type_graph.root_count image); + let first = Frozen_type_graph.thaw_root image 1 in + let second = Frozen_type_graph.thaw_root image 1 in + assert_bool "one root can be materialized without sharing mutable nodes" + (first != second && first != chosen); + first.desc <- Types.Tvar (Some "changed"); + match (second.desc, chosen.desc) with + | Types.Tvar (Some "chosen"), Types.Tvar (Some "chosen") -> () + | _ -> OUnit.assert_failure "selective thaw changed another graph" + +let test_registered_identifier_matches_path _ = + let binder = Ident.create "t" in + let root = + Btype.newgenty (Types.Tconstr (Path.Pident binder, [], ref Types.Mnil)) + in + let image = Frozen_type_graph.freeze ~identifiers:[binder] [root] in + let image = + match image with + | Ok image -> image + | Error reason -> OUnit.assert_failure reason + in + let view = Frozen_type_graph.create_view image in + let materialized_binder = Frozen_type_graph.identifier_at view 0 in + match (Frozen_type_graph.type_at view 0).Types.desc with + | Types.Tconstr (Path.Pident path_ident, _, _) -> + assert_bool "signature binder and type path use the same local object" + (materialized_binder == path_ident && materialized_binder != binder) + | _ -> OUnit.assert_failure "expected a constructor path" + +let suites = + __FILE__ + >::: [ + "root_sharing_and_instantiation" >:: test_root_sharing_and_instantiation; + "mutability_classes_are_local" >:: test_mutability_classes_are_local; + "poly_quantifiers_instantiate_independently" + >:: test_poly_quantifiers_instantiate_independently; + "cycles_and_identifier_sharing" >:: test_cycles_and_identifier_sharing; + "variant_row_references_are_local" + >:: test_variant_row_references_are_local; + "rejects_transient_state" >:: test_rejects_transient_state; + "selective_thaw" >:: test_selective_thaw; + "registered_identifier_matches_path" + >:: test_registered_identifier_matches_path; + ] diff --git a/tests/ounit_tests/ounit_frozen_values_tests.ml b/tests/ounit_tests/ounit_frozen_values_tests.ml new file mode 100644 index 0000000000..6f9565f59a --- /dev/null +++ b/tests/ounit_tests/ounit_frozen_values_tests.ml @@ -0,0 +1,611 @@ +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) +let assert_bool = OUnit.assert_bool + +let abstract_type : Types.type_declaration = + { + type_params = []; + type_arity = 0; + type_kind = Type_abstract; + type_private = Public; + type_manifest = None; + type_variance = []; + type_newtype_level = None; + type_loc = Location.none; + type_attributes = []; + type_immediate = false; + type_representation = Boxed; + type_inlined_types = []; + } + +let value ?(attributes = []) ty : Types.value_description = + { + val_type = ty; + val_kind = Val_reg; + val_loc = Location.none; + val_attributes = attributes; + } + +let freeze signature = + let cmi : Cmi_format.cmi_infos = + {cmi_name = "Api"; cmi_sign = signature; cmi_crcs = []; cmi_flags = []} + in + match Frozen_values.freeze cmi with + | Ok image -> image + | Error reason -> OUnit.assert_failure reason + +let test_prefixed_type_identity_and_positions _ = + let type_id = Ident.create "t" in + let value_type = + Btype.newgenty (Types.Tconstr (Path.Pident type_id, [], ref Types.Mnil)) + in + let image = + freeze + [ + Types.Sig_type (type_id, abstract_type, Types.Trec_not); + Types.Sig_value (Ident.create "first", value value_type); + Types.Sig_module + ( Ident.create "Nested", + { + Types.md_type = Mty_signature []; + md_attributes = []; + md_loc = Location.none; + }, + Types.Trec_not ); + Types.Sig_value (Ident.create "second", value value_type); + ] + in + OUnit.assert_equal 2 (Frozen_values.value_count image); + let view = Frozen_values.create_view image in + match (Frozen_values.find view "first", Frozen_values.find view "second") with + | Some (first, first_pos), Some (second, second_pos) -> ( + OUnit.assert_equal 0 first_pos; + OUnit.assert_equal 2 second_pos; + assert_bool "one request view preserves value type sharing" + (first.val_type == second.val_type); + (match Frozen_values.find view "first" with + | Some (again, _) -> + assert_bool "one view reuses its materialized declaration" (again == first) + | None -> OUnit.assert_failure "expected first value again"); + match first.val_type.desc with + | Types.Tconstr (path, [], _) -> + let expected = + Path.Pdot (Path.Pident (Ident.create_persistent "Api"), "t", Path.nopos) + in + assert_bool "local type identity is prefixed by the importing module" + (Path.same path expected) + | _ -> OUnit.assert_failure "expected a named type") + | _ -> OUnit.assert_failure "expected two exported values" + +let test_views_are_independent _ = + let source = Btype.newgenty (Types.Tvar (Some "a")) in + let image = freeze [Types.Sig_value (Ident.create "value", value source)] in + let get () = + match Frozen_values.find (Frozen_values.create_view image) "value" with + | Some (description, _) -> description.val_type + | None -> OUnit.assert_failure "missing value" + in + let first = Domain.spawn get in + let second = Domain.spawn get in + let first = Domain.join first in + let second = Domain.join second in + assert_bool "domain views own their type nodes" (first != second); + first.desc <- Types.Tvar (Some "changed"); + match (second.desc, source.desc) with + | Types.Tvar (Some "a"), Types.Tvar (Some "a") -> () + | _ -> OUnit.assert_failure "a view changed another graph" + +let test_attributes_are_copied _ = + let attributes = [(Location.mknoloc "tag", Parsetree.PStr [])] in + let image = + freeze + [ + Types.Sig_value + ( Ident.create "value", + value ~attributes (Btype.newgenty (Types.Tvar None)) ); + ] + in + let get () = + match Frozen_values.find (Frozen_values.create_view image) "value" with + | Some (description, _) -> description.val_attributes + | None -> OUnit.assert_failure "missing value" + in + let first = get () in + let second = get () in + assert_bool "metadata does not expose the source or another view" + (first != attributes && first != second); + OUnit.assert_equal attributes first; + OUnit.assert_equal attributes second + +let test_abstract_type_manifest_is_local_and_prefixed _ = + let other_id = Ident.create "other" in + let type_id = Ident.create "t" in + let parameter = Btype.newgenty (Types.Tvar (Some "a")) in + let manifest = + Btype.newgenty + (Types.Tconstr (Path.Pident other_id, [parameter], ref Types.Mnil)) + in + let declaration = + { + abstract_type with + type_params = [parameter]; + type_arity = 1; + type_manifest = Some manifest; + } + in + let image = + freeze + [ + Types.Sig_type (other_id, abstract_type, Types.Trec_not); + Types.Sig_type (type_id, declaration, Types.Trec_not); + ] + in + OUnit.assert_equal 2 (Frozen_values.type_count image); + let first_view = Frozen_values.create_view image in + let second_view = Frozen_values.create_view image in + match + ( Frozen_values.find_type first_view "t", + Frozen_values.find_type second_view "t" ) + with + | Some (first, _), Some (second, _) -> ( + assert_bool "type declaration is cached within one view" + (match Frozen_values.find_type first_view "t" with + | Some (again, _) -> again == first + | None -> false); + assert_bool "type parameters are independent across views" + (List.hd first.type_params != List.hd second.type_params); + match first.type_manifest with + | Some {desc = Types.Tconstr (path, [argument], _)} -> + let expected = + Path.Pdot + (Path.Pident (Ident.create_persistent "Api"), "other", Path.nopos) + in + assert_bool "manifest path is prefixed" (Path.same path expected); + assert_bool "manifest shares its parameter within a view" + (argument == List.hd first.type_params) + | _ -> OUnit.assert_failure "expected a parameterized manifest") + | _ -> OUnit.assert_failure "expected abstract type declarations" + +let test_record_labels_are_local _ = + let field_type = Btype.newgenty (Types.Tvar None) in + let label : Types.label_declaration = + { + ld_id = Ident.create "value"; + ld_runtime_name = None; + ld_mutable = Immutable; + ld_optional = false; + ld_type = field_type; + ld_loc = Location.none; + ld_attributes = []; + } + in + let image = + freeze + [ + Types.Sig_type + ( Ident.create "box", + { + abstract_type with + type_kind = Type_record ([label], Record_regular); + }, + Types.Trec_not ); + ] + in + let first = Frozen_values.create_view image in + let second = Frozen_values.create_view image in + let identifier_time = Ident.current_time () in + match + ( Frozen_values.find_labels first "value", + Frozen_values.find_labels second "value" ) + with + | Some [first_label], Some [second_label] -> ( + OUnit.assert_equal identifier_time (Ident.current_time ()); + assert_bool "label descriptors are request-local" + (first_label != second_label + && first_label.lbl_arg != second_label.lbl_arg + && first_label.lbl_all != second_label.lbl_all); + (match + ( Frozen_values.find_type first "box", + Frozen_values.find_type second "box" ) + with + | ( Some ({type_kind = Types.Type_record ([left], _)}, _), + Some ({type_kind = Types.Type_record ([right], _)}, _) ) -> + assert_bool "label identifiers receive fresh stamps" + (not (Ident.same left.ld_id right.ld_id)) + | _ -> OUnit.assert_failure "expected two record declarations"); + assert_bool "one view reuses its label descriptor" + (match Frozen_values.find_labels first "value" with + | Some [again] -> again == first_label + | _ -> false); + match Frozen_values.find_type first "box" with + | Some (declaration, (_, [type_label])) -> ( + assert_bool "label lookup and type lookup share one description" + (first_label == type_label); + match declaration.type_kind with + | Types.Type_record ([materialized], Types.Record_regular) -> + assert_bool "label type belongs to the same view" + (materialized.ld_type == first_label.lbl_arg) + | _ -> OUnit.assert_failure "expected record type") + | _ -> OUnit.assert_failure "expected a record declaration") + | _ -> OUnit.assert_failure "expected record labels" + +let test_shadowed_record_labels_fall_back _ = + let field_type = Btype.newgenty (Types.Tvar None) in + let label : Types.label_declaration = + { + ld_id = Ident.create "value"; + ld_runtime_name = None; + ld_mutable = Immutable; + ld_optional = false; + ld_type = field_type; + ld_loc = Location.none; + ld_attributes = []; + } + in + let record = + {abstract_type with type_kind = Type_record ([label], Record_regular)} + in + let image = + freeze + [ + Types.Sig_type (Ident.create "box", record, Types.Trec_not); + Types.Sig_type (Ident.create "box", record, Types.Trec_not); + ] + in + match Frozen_values.find_labels (Frozen_values.create_view image) "value" with + | None -> () + | Some _ -> OUnit.assert_failure "shadowed records need component lookup" + +let test_variant_constructors_are_local _ = + let constructor name args : Types.constructor_declaration = + { + cd_id = Ident.create name; + cd_runtime_tag = None; + cd_args = Cstr_tuple args; + cd_res = None; + cd_loc = Location.none; + cd_attributes = []; + } + in + let argument = Btype.newgenty (Types.Tvar None) in + let layout = Variant_runtime.plain_layout [("A", false); ("B", true)] in + let variant = + { + abstract_type with + type_kind = + Type_variant ([constructor "A" []; constructor "B" [argument]], layout); + } + in + let image = + freeze [Types.Sig_type (Ident.create "choice", variant, Types.Trec_not)] + in + let first = Frozen_values.create_view image in + let second = Frozen_values.create_view image in + let identifier_time = Ident.current_time () in + match + ( Frozen_values.find_constructors first "B", + Frozen_values.find_constructors second "B" ) + with + | Some [left], Some [right] -> ( + OUnit.assert_equal identifier_time (Ident.current_time ()); + assert_bool "constructor descriptors and types are request-local" + (left != right && List.hd left.cstr_args != List.hd right.cstr_args); + (match (left.cstr_kind, right.cstr_kind) with + | Types.Ordinary_constructor left_ref, Types.Ordinary_constructor right_ref + -> + assert_bool "runtime layouts are request-local" + (left_ref.variant != right_ref.variant) + | _ -> OUnit.assert_failure "expected ordinary constructors"); + match Frozen_values.find_type first "choice" with + | Some (_, ([first_a; first_b], _)) -> + assert_bool "constructor lookup reuses the type description" + (first_b == left && first_a.cstr_name = "A") + | _ -> OUnit.assert_failure "expected two constructors") + | _ -> OUnit.assert_failure "expected constructor B" + +let test_extension_constructors_are_local _ = + let payload = Btype.newgenty (Types.Tvar None) in + let extension : Types.extension_constructor = + { + ext_type_path = Predef.path_exn; + ext_type_params = []; + ext_args = Cstr_tuple [payload]; + ext_ret_type = None; + ext_private = Public; + ext_loc = Location.none; + ext_attributes = []; + ext_is_exception = true; + } + in + let image = + freeze [Types.Sig_typext (Ident.create "Boom", extension, Text_exception)] + in + let first = Frozen_values.create_view image in + let second = Frozen_values.create_view image in + let identifier_time = Ident.current_time () in + match + ( Frozen_values.find_extension first "Boom", + Frozen_values.find_constructors first "Boom", + Frozen_values.find_extension second "Boom" ) + with + | Some left, Some [again], Some right -> ( + OUnit.assert_equal identifier_time (Ident.current_time ()); + assert_bool "extension lookup reuses the constructor" (left == again); + assert_bool "extension payloads belong to each request" + (List.hd left.cstr_args != List.hd right.cstr_args); + match left.cstr_kind with + | Types.Extension_constructor path -> + assert_bool "extension path includes its signature position" + (Path.same path + (Path.Pdot (Path.Pident (Ident.create_persistent "Api"), "Boom", 0))) + | _ -> OUnit.assert_failure "expected an extension constructor") + | _ -> OUnit.assert_failure "expected a frozen extension constructor" + +let test_nested_scope_paths_and_sharing _ = + let outer_id = Ident.create "outer" in + let inner_id = Ident.create "inner" in + let inner_type = + Btype.newgenty (Types.Tconstr (Path.Pident inner_id, [], ref Types.Mnil)) + in + let outer_type = + Btype.newgenty (Types.Tconstr (Path.Pident outer_id, [], ref Types.Mnil)) + in + let module_decl signature : Types.module_declaration = + { + md_type = Mty_signature signature; + md_attributes = []; + md_loc = Location.none; + } + in + let image = + freeze + [ + Types.Sig_type (outer_id, abstract_type, Trec_not); + Types.Sig_module + ( Ident.create "Nested", + module_decl + [ + Types.Sig_type + ( inner_id, + {abstract_type with type_manifest = Some outer_type}, + Trec_not ); + Types.Sig_value (Ident.create "value", value inner_type); + Types.Sig_module + ( Ident.create "Deep", + module_decl + [Types.Sig_value (Ident.create "value", value inner_type)], + Trec_not ); + ], + Trec_not ); + ] + in + let view = Frozen_values.create_view image in + match Frozen_values.find_module (Frozen_values.root_scope view) "Nested" with + | Some (nested, nested_pos, _, _) -> ( + OUnit.assert_equal 0 nested_pos; + match + ( Frozen_values.find_type_in_scope view nested "inner", + Frozen_values.find_in_scope view nested "value", + Frozen_values.find_module nested "Deep" ) + with + | Some (declaration, _), Some (value, value_pos), Some (deep, deep_pos, _, _) + -> ( + OUnit.assert_equal 0 value_pos; + OUnit.assert_equal 1 deep_pos; + (match declaration.type_manifest with + | Some {desc = Types.Tconstr (path, _, _)} -> + assert_bool "nested manifest resolves an outer binder" + (Path.same path + (Path.Pdot + ( Path.Pident (Ident.create_persistent "Api"), + "outer", + Path.nopos ))) + | _ -> OUnit.assert_failure "expected an outer type manifest"); + match + (value.val_type.desc, Frozen_values.find_in_scope view deep "value") + with + | Types.Tconstr (path, _, _), Some (deep_value, 0) -> + assert_bool "nested binder has a qualified path" + (Path.same path + (Path.Pdot + ( Path.Pdot + (Path.Pident (Ident.create_persistent "Api"), "Nested", 0), + "inner", + Path.nopos ))); + assert_bool "one arena shares types across scopes" + (value.val_type == deep_value.val_type) + | _ -> OUnit.assert_failure "expected a deep value") + | _ -> OUnit.assert_failure "expected nested declarations") + | None -> OUnit.assert_failure "expected a nested frozen signature" + +let test_reused_module_type_has_distinct_binders _ = + let signature_id = Ident.create "S" in + let type_id = Ident.create "t" in + let value_type = + Btype.newgenty (Types.Tconstr (Path.Pident type_id, [], ref Types.Mnil)) + in + let signature = + [ + Types.Sig_type (type_id, abstract_type, Trec_not); + Types.Sig_value (Ident.create "value", value value_type); + ] + in + let module_decl : Types.module_declaration = + { + md_type = Mty_ident (Path.Pident signature_id); + md_attributes = []; + md_loc = Location.none; + } + in + let image = + freeze + [ + Types.Sig_modtype + ( signature_id, + { + mtd_type = Some (Mty_signature signature); + mtd_attributes = []; + mtd_loc = Location.none; + } ); + Types.Sig_module (Ident.create "A", module_decl, Trec_not); + Types.Sig_module (Ident.create "B", module_decl, Trec_not); + ] + in + let view = Frozen_values.create_view image in + let root = Frozen_values.root_scope view in + match + (Frozen_values.find_module root "A", Frozen_values.find_module root "B") + with + | Some (a, 0, _, _), Some (b, 1, _, _) -> ( + match + ( Frozen_values.find_in_scope view a "value", + Frozen_values.find_in_scope view b "value", + Frozen_values.find_module_declaration view root "A", + Frozen_values.find_modtype_declaration view root "S" ) + with + | ( Some (a_value, 0), + Some (b_value, 0), + Some ({md_type = Types.Mty_ident module_type_path}, 0), + Some {mtd_type = Some (Types.Mty_signature _)} ) -> ( + assert_bool "reuse gets independent mutable type graphs" + (a_value.val_type != b_value.val_type); + assert_bool "module type path is prefixed" + (Path.same module_type_path + (Path.Pdot + (Path.Pident (Ident.create_persistent "Api"), "S", Path.nopos))); + match (a_value.val_type.desc, b_value.val_type.desc) with + | Types.Tconstr (a_path, _, _), Types.Tconstr (b_path, _, _) -> + assert_bool "A uses its own abstract type" + (Path.same a_path + (Path.Pdot + ( Path.Pdot (Path.Pident (Ident.create_persistent "Api"), "A", 0), + "t", + Path.nopos ))); + assert_bool "B uses its own abstract type" + (Path.same b_path + (Path.Pdot + ( Path.Pdot (Path.Pident (Ident.create_persistent "Api"), "B", 1), + "t", + Path.nopos ))) + | _ -> OUnit.assert_failure "expected two abstract type paths") + | _ -> OUnit.assert_failure "expected reusable module type entries") + | _ -> OUnit.assert_failure "expected two module type instantiations" + +let test_open_and_inline_record_types _ = + let label : Types.label_declaration = + { + ld_id = Ident.create "field"; + ld_runtime_name = None; + ld_mutable = Immutable; + ld_optional = false; + ld_type = Predef.type_int (); + ld_loc = Location.none; + ld_attributes = []; + } + in + let layout = Variant_runtime.plain_layout [("Case", true)] in + let constructor : Types.constructor_declaration = + { + cd_id = Ident.create "Case"; + cd_runtime_tag = None; + cd_args = Cstr_record [label]; + cd_res = None; + cd_loc = Location.none; + cd_attributes = []; + } + in + let inline_types = [Types.Record {type_name = "payload"; labels = [label]}] in + let image = + freeze + [ + Types.Sig_type + ( Ident.create "open_type", + {abstract_type with type_kind = Type_open}, + Trec_not ); + Types.Sig_type + ( Ident.create "choice", + { + abstract_type with + type_kind = Type_variant ([constructor], layout); + type_inlined_types = inline_types; + }, + Trec_not ); + Types.Sig_type + ( Ident.create "payload", + { + abstract_type with + type_kind = + Type_record + ( [label], + Record_inlined + { + name = "Case"; + representation = {variant = layout; position = 0}; + } ); + type_inlined_types = inline_types; + }, + Trec_not ); + ] + in + let view = Frozen_values.create_view image in + match + ( Frozen_values.find_type view "open_type", + Frozen_values.find_type view "choice", + Frozen_values.find_type view "payload" ) + with + | ( Some ({type_kind = Types.Type_open}, _), + Some ({type_kind = Types.Type_variant (_, variant_layout)}, _), + Some + ( { + type_kind = + Types.Type_record + (_, Types.Record_inlined {representation = inline_ref}); + type_inlined_types = [Types.Record {labels = [inline_label]}]; + }, + _ ) ) -> + assert_bool "inline record shares its variant layout" + (variant_layout == inline_ref.variant); + assert_bool "inline metadata is request-owned" + (inline_label.ld_id != label.ld_id) + | _ -> OUnit.assert_failure "expected open and inline-record types" + +let test_full_signature_copies_are_independent _ = + let source = Btype.newgenty (Types.Tvar (Some "a")) in + let image = freeze [Types.Sig_value (Ident.create "value", value source)] in + let copy () = + match Frozen_values.copy_signature (Frozen_values.create_view image) with + | [Types.Sig_value (_, description)] -> description.val_type + | _ -> OUnit.assert_failure "expected one copied value" + in + let first = copy () in + let second = copy () in + assert_bool "full signature copies have independent type graphs" + (first != second); + first.desc <- Types.Tvar (Some "changed"); + match (second.desc, source.desc) with + | Types.Tvar (Some "a"), Types.Tvar (Some "a") -> () + | _ -> OUnit.assert_failure "a full signature copy leaked into another" + +let suites = + __FILE__ + >::: [ + "prefixed_type_identity_and_positions" + >:: test_prefixed_type_identity_and_positions; + "views_are_independent" >:: test_views_are_independent; + "attributes_are_copied" >:: test_attributes_are_copied; + "abstract_type_manifest_is_local_and_prefixed" + >:: test_abstract_type_manifest_is_local_and_prefixed; + "record_labels_are_local" >:: test_record_labels_are_local; + "shadowed_record_labels_fall_back" + >:: test_shadowed_record_labels_fall_back; + "variant_constructors_are_local" + >:: test_variant_constructors_are_local; + "extension_constructors_are_local" + >:: test_extension_constructors_are_local; + "nested_scope_paths_and_sharing" + >:: test_nested_scope_paths_and_sharing; + "reused_module_type_has_distinct_binders" + >:: test_reused_module_type_has_distinct_binders; + "open_and_inline_record_types" >:: test_open_and_inline_record_types; + "full_signature_copies_are_independent" + >:: test_full_signature_copies_are_independent; + ] diff --git a/tests/ounit_tests/ounit_tests_main.ml b/tests/ounit_tests/ounit_tests_main.ml index 8dad3e6f03..79b59cea35 100644 --- a/tests/ounit_tests/ounit_tests_main.ml +++ b/tests/ounit_tests/ounit_tests_main.ml @@ -27,6 +27,8 @@ let suites = Ounit_ast_mapper0_tests.suites; Ounit_constructor_arguments_tests.suites; Ounit_object_mutability_tests.suites; + Ounit_frozen_type_graph_tests.suites; + Ounit_frozen_values_tests.suites; Ounit_pattern_printer_tests.suites; Ounit_js_analyzer_tests.suites; Ounit_flow_parser_tests.suites; diff --git a/tests/rewatch_ounit_tests/compiler_driver_tests.ml b/tests/rewatch_ounit_tests/compiler_driver_tests.ml index 96baca07f4..db5dd0270e 100644 --- a/tests/rewatch_ounit_tests/compiler_driver_tests.ml +++ b/tests/rewatch_ounit_tests/compiler_driver_tests.ml @@ -1019,8 +1019,10 @@ let combined_dependency_cache_tests _context = Test_support.with_temp_dir "rewatch-combined-dependency-" (fun root -> let previous_cache = Sys.getenv_opt "REWATCH_COMBINED_SIGNATURE_CACHE" in let previous_trace = Sys.getenv_opt "REWATCH_TYPECHECK_TRACE" in + let previous_frozen = Sys.getenv_opt "REWATCH_FROZEN_VALUES" in Fun.protect (fun () -> + Unix.putenv "REWATCH_FROZEN_VALUES" "0"; Unix.putenv "REWATCH_COMBINED_SIGNATURE_CACHE" "force"; let trace = Filename.concat root "dependency-trace.tsv" in Unix.putenv "REWATCH_TYPECHECK_TRACE" trace; @@ -1183,10 +1185,90 @@ let combined_dependency_cache_tests _context = (match previous_trace with | Some value -> Unix.putenv "REWATCH_TYPECHECK_TRACE" value | None -> Unix.unsetenv "REWATCH_TYPECHECK_TRACE"); + (match previous_frozen with + | Some value -> Unix.putenv "REWATCH_FROZEN_VALUES" value + | None -> Unix.unsetenv "REWATCH_FROZEN_VALUES"); match previous_cache with | Some value -> Unix.putenv "REWATCH_COMBINED_SIGNATURE_CACHE" value | None -> Unix.unsetenv "REWATCH_COMBINED_SIGNATURE_CACHE")) +let frozen_overrides_combined_snapshot_tests _context = + Test_support.with_temp_dir "rewatch-frozen-namespace-" (fun root -> + let previous_cache = Sys.getenv_opt "REWATCH_COMBINED_SIGNATURE_CACHE" in + let previous_trace = Sys.getenv_opt "REWATCH_TYPECHECK_TRACE" in + let previous_frozen = Sys.getenv_opt "REWATCH_FROZEN_VALUES" in + Fun.protect + ~finally:(fun () -> + (match previous_cache with + | Some value -> Unix.putenv "REWATCH_COMBINED_SIGNATURE_CACHE" value + | None -> Unix.unsetenv "REWATCH_COMBINED_SIGNATURE_CACHE"); + (match previous_trace with + | Some value -> Unix.putenv "REWATCH_TYPECHECK_TRACE" value + | None -> Unix.unsetenv "REWATCH_TYPECHECK_TRACE"); + match previous_frozen with + | Some value -> Unix.putenv "REWATCH_FROZEN_VALUES" value + | None -> Unix.unsetenv "REWATCH_FROZEN_VALUES") + (fun () -> + Unix.putenv "REWATCH_FROZEN_VALUES" "0"; + Unix.putenv "REWATCH_COMBINED_SIGNATURE_CACHE" "0"; + write root "Shapes.mlmap" "randjbuildsystem\nCircle\n"; + write root "Circle.resi" "let value: int\n"; + write root "Circle.res" "let value = 1\n"; + let compile ?(extra = []) input = + let result = snd (run root ~extra:(["-I"; root] @ extra) input) in + assert_equal ~msg:result.stderr 0 result.exit_code + in + compile ~extra:["-no-alias-deps"] "Shapes.mlmap"; + compile ~extra:["-bs-ns"; "Shapes"] "Circle.resi"; + compile ~extra:["-bs-ns"; "Shapes"; "-bs-read-cmi"] "Circle.res"; + compile ~extra:["-no-alias-deps"] "Shapes.mlmap"; + write root "Consumer.res" + "open Shapes.Circle\nlet result: int = value\n"; + compile "Consumer.res"; + let output = Filename.concat root "Consumer.js" in + let cmi = Filename.concat root "Consumer.cmi" in + let baseline_js = File_util.read_file output in + let baseline_cmi_info = Cmi_format.read_cmi cmi in + Unix.putenv "REWATCH_FROZEN_VALUES" "1"; + Unix.putenv "REWATCH_COMBINED_SIGNATURE_CACHE" "force"; + let trace = Filename.concat root "frozen-trace.tsv" in + Unix.putenv "REWATCH_TYPECHECK_TRACE" trace; + let session = Rescript_compiler_driver.create_session () in + for _ = 1 to 2 do + let result = + snd (run ~session root ~extra:["-I"; root] "Consumer.res") + in + assert_equal ~msg:result.stderr 0 result.exit_code + done; + assert_equal baseline_js (File_util.read_file output); + let frozen_cmi_info = Cmi_format.read_cmi cmi in + let exported_value cmi = + match cmi.Cmi_format.cmi_sign with + | [Types.Sig_value (id, value)] -> + ( Ident.name id, + Stdlib.Format.asprintf "%a" Printtyp.type_expr value.val_type ) + | _ -> assert_failure "Consumer exports one value" + in + assert_equal + (exported_value baseline_cmi_info) + (exported_value frozen_cmi_info); + assert_equal baseline_cmi_info.cmi_flags frozen_cmi_info.cmi_flags; + let external_crcs cmi = + match cmi.Cmi_format.cmi_crcs with + | _self :: dependencies -> dependencies + | [] -> assert_failure "Consumer CMI contains its own CRC" + in + assert_equal + (external_crcs baseline_cmi_info) + (external_crcs frozen_cmi_info); + let trace = File_util.read_file trace in + check + (Test_support.contains_text trace "dependency.frozen_open") + "the forced legacy cache still takes the frozen open path"; + check + (not (Test_support.contains_text trace "dependency.snapshot_reuse")) + "the frozen flag skips the mutable combined snapshot")) + let runtime_cmi_cache_tests _context = Test_support.with_temp_dir "rewatch-runtime-cmi-cache-" (fun root -> let first = Filename.concat root "first" in @@ -1324,6 +1406,295 @@ let project_cmi_cache_tests _context = (before_update + 1) !loads | _ -> assert_failure "expected the updated interface type")) +let frozen_values_tests _context = + Test_support.with_temp_dir "rewatch-frozen-values-" (fun root -> + let previous = Sys.getenv_opt "REWATCH_FROZEN_VALUES" in + Fun.protect + ~finally:(fun () -> + match previous with + | Some value -> Unix.putenv "REWATCH_FROZEN_VALUES" value + | None -> Unix.unsetenv "REWATCH_FROZEN_VALUES") + (fun () -> + write root "Api.resi" + "type t\n\ + type u = t\n\ + type box = {value: int}\n\ + type choice = A | B(int)\n\ + exception Boom(int)\n\ + module Nested: {\n\ + type item = {value: int}\n\ + let answer: int\n\ + module Deep: {let answer: int}\n\ + exception Oops(int)\n\ + }\n\ + let value: int\n\ + let make: unit => t\n\ + let use: t => int\n"; + expect_code 0 (snd (run root "Api.resi")); + write root "Api.res" + "type t = int\n\ + type u = t\n\ + type box = {value: int}\n\ + type choice = A | B(int)\n\ + exception Boom(int)\n\ + module Nested = {\n\ + type item = {value: int}\n\ + let answer = 2\n\ + module Deep = {let answer = 3}\n\ + exception Oops(int)\n\ + }\n\ + let value = 1\n\ + let make = () => 2\n\ + let use = x => x\n"; + expect_code 0 (snd (run root "Api.res")); + write root "Consumer.res" + "let typed: Api.u = Api.make()\n\ + let result = Api.use(typed)\n\ + let box: Api.box = {value: Api.value}\n\ + let selected = Api.B(2)\n\ + let selectedValue = switch selected {\n\ + | Api.A => 0\n\ + | Api.B(value) => value\n\ + }\n\ + let raised = Api.Boom(3)\n\ + let nested = Api.Nested.answer\n\ + let deep = Api.Nested.Deep.answer\n\ + let boxed: Api.Nested.item = {value: deep}\n\ + let nestedError = Api.Nested.Oops(nested)\n\ + let other = Api.value\n"; + let baseline = snd (run root ~extra:["-I"; root] "Consumer.res") in + assert_equal ~msg:baseline.stderr 0 baseline.exit_code; + let output = Filename.concat root "Consumer.js" in + let baseline_js = File_util.read_file output in + write root "Shadow.res" + "module Api = {let value = 9}\nlet result = Api.value\n"; + let shadow_baseline = + snd (run root ~extra:["-I"; root] "Shadow.res") + in + assert_equal ~msg:shadow_baseline.stderr 0 shadow_baseline.exit_code; + let shadow_output = Filename.concat root "Shadow.js" in + let shadow_baseline_js = File_util.read_file shadow_output in + Unix.putenv "REWATCH_FROZEN_VALUES" "1"; + let session = Rescript_compiler_driver.create_session () in + let frozen = + snd (run ~session root ~extra:["-I"; root] "Consumer.res") + in + expect_code 0 frozen; + assert_equal baseline_js (File_util.read_file output); + expect_code 0 + (snd (run ~session root ~extra:["-I"; root] "Shadow.res")); + assert_equal shadow_baseline_js (File_util.read_file shadow_output); + let cache = Env.create_dependency_cache () in + let load ?(mutate = false) () = + Env.with_dependency_cache cache (fun () -> + Compiler_request_state.with_fresh ~cwd:root (fun () -> + Env.with_fresh (fun () -> + (Compiler_request_state.current ()).load_path <- [root]; + let _, description = + Env.lookup_value + (Longident.Ldot (Longident.Lident "Api", "value")) + Env.empty + in + let typ = description.Types.val_type in + let name = + match typ.desc with + | Types.Tconstr (path, _, _) -> Path.name path + | _ -> assert_failure "expected a named type" + in + if mutate then typ.desc <- Types.Tvar None; + (name, typ)))) + in + let constructors name = + Env.with_dependency_cache cache (fun () -> + Compiler_request_state.with_fresh ~cwd:root (fun () -> + Env.with_fresh (fun () -> + (Compiler_request_state.current ()).load_path <- [root]; + Env.lookup_all_constructors + (Longident.Ldot (Longident.Lident "Api", name)) + Env.empty + |> List.map (fun (description, _) -> + description.Types.cstr_name)))) + in + assert_equal "int" (fst (load ~mutate:true ())); + assert_equal "int" (fst (load ())); + assert_equal ["B"] (constructors "B"); + assert_equal ["Boom"] (constructors "Boom"); + let first = Domain.spawn load in + let second = Domain.spawn load in + let first_name, first_type = Domain.join first in + let second_name, second_type = Domain.join second in + assert_equal "int" first_name; + assert_equal "int" second_name; + check + (first_type != second_type) + "workers materialize independent value types"; + write root "Api.resi" + "type t\n\ + type u = t\n\ + type box = {value: int}\n\ + type choice = A | C(int)\n\ + exception Bang(int)\n\ + module Nested: {\n\ + type item = {value: int}\n\ + let answer: int\n\ + module Deep: {let answer: int}\n\ + exception Oops(int)\n\ + }\n\ + let value: string\n\ + let make: unit => t\n\ + let use: t => int\n"; + expect_code 0 (snd (run root "Api.resi")); + write root "Api.res" + "type t = string\n\ + type u = t\n\ + type box = {value: int}\n\ + type choice = A | C(int)\n\ + exception Bang(int)\n\ + module Nested = {\n\ + type item = {value: int}\n\ + let answer = 2\n\ + module Deep = {let answer = 3}\n\ + exception Oops(int)\n\ + }\n\ + let value = \"updated\"\n\ + let make = () => \"updated\"\n\ + let use = x => 1\n"; + expect_code 0 (snd (run root "Api.res")); + assert_equal "string" (fst (load ())); + assert_equal [] (constructors "B"); + assert_equal ["C"] (constructors "C"); + assert_equal [] (constructors "Boom"); + assert_equal ["Bang"] (constructors "Bang"))) + +let frozen_module_forms_tests _context = + Test_support.with_temp_dir "rewatch-frozen-modules-" (fun root -> + let previous = Sys.getenv_opt "REWATCH_FROZEN_VALUES" in + Fun.protect + ~finally:(fun () -> + match previous with + | Some value -> Unix.putenv "REWATCH_FROZEN_VALUES" value + | None -> Unix.unsetenv "REWATCH_FROZEN_VALUES") + (fun () -> + write root "Other.res" "let value = 7\n"; + expect_code 0 (snd (run root "Other.res")); + write root "Api.res" + "module type S = {type t; let value: t}\n\ + module A: S = {type t = int; let value = 1}\n\ + module B: S = {type t = string; let value = \"b\"}\n\ + module Alias = A\n\ + module External = Other\n\ + module F = (X: S) => {let same: X.t = X.value}\n"; + expect_code 0 (snd (run root ~extra:["-I"; root] "Api.res")); + write root "Consumer.res" + "let a: Api.A.t = Api.A.value\n\ + let b: Api.B.t = Api.B.value\n\ + let aliased: Api.A.t = Api.Alias.value\n\ + let externalValue = Api.External.value\n\ + module Applied = Api.F(Api.A)\n\ + let c = Applied.same\n"; + let baseline = snd (run root ~extra:["-I"; root] "Consumer.res") in + assert_equal ~msg:baseline.stderr 0 baseline.exit_code; + let output = Filename.concat root "Consumer.js" in + let baseline_js = File_util.read_file output in + write root "Bad.res" "let wrong: Api.A.t = Api.B.value\n"; + let baseline_error = snd (run root ~extra:["-I"; root] "Bad.res") in + expect_code 2 baseline_error; + write root "Include.res" + "include Api\nlet fromInclude = External.value\n"; + let included_baseline = + snd (run root ~extra:["-I"; root] "Include.res") + in + assert_equal ~msg:included_baseline.stderr 0 + included_baseline.exit_code; + let include_output = Filename.concat root "Include.js" in + let include_cmi = Filename.concat root "Include.cmi" in + let baseline_include_js = File_util.read_file include_output in + let baseline_include_cmi = File_util.read_file include_cmi in + Unix.putenv "REWATCH_FROZEN_VALUES" "1"; + let session = Rescript_compiler_driver.create_session () in + let frozen = + snd (run ~session root ~extra:["-I"; root] "Consumer.res") + in + assert_equal ~msg:frozen.stderr 0 frozen.exit_code; + assert_equal baseline_js (File_util.read_file output); + let frozen_error = + snd (run ~session root ~extra:["-I"; root] "Bad.res") + in + expect_code 2 frozen_error; + assert_equal baseline_error.stderr frozen_error.stderr; + let included_frozen = + snd (run ~session root ~extra:["-I"; root] "Include.res") + in + assert_equal ~msg:included_frozen.stderr 0 included_frozen.exit_code; + assert_equal baseline_include_js (File_util.read_file include_output); + assert_equal baseline_include_cmi (File_util.read_file include_cmi))) + +let frozen_inline_records_tests _context = + Test_support.with_temp_dir "rewatch-frozen-inline-records-" (fun root -> + let previous = Sys.getenv_opt "REWATCH_FROZEN_VALUES" in + Fun.protect + ~finally:(fun () -> + match previous with + | Some value -> Unix.putenv "REWATCH_FROZEN_VALUES" value + | None -> Unix.unsetenv "REWATCH_FROZEN_VALUES") + (fun () -> + write root "Api.res" + "type choice = Case({field: int})\n\ + type extensible = ..\n\ + type extensible += More({value: int})\n"; + expect_code 0 (snd (run root "Api.res")); + write root "Consumer.res" + "let selected = Api.Case({field: 3})\n\ + let field = switch selected {\n\ + | Api.Case({field}) => field\n\ + }\n\ + let extended = Api.More({value: field})\n"; + let baseline = snd (run root ~extra:["-I"; root] "Consumer.res") in + assert_equal ~msg:baseline.stderr 0 baseline.exit_code; + let output = Filename.concat root "Consumer.js" in + let baseline_js = File_util.read_file output in + Unix.putenv "REWATCH_FROZEN_VALUES" "1"; + let session = Rescript_compiler_driver.create_session () in + let frozen = + snd (run ~session root ~extra:["-I"; root] "Consumer.res") + in + assert_equal ~msg:frozen.stderr 0 frozen.exit_code; + assert_equal baseline_js (File_util.read_file output))) + +let frozen_open_tests _context = + Test_support.with_temp_dir "rewatch-frozen-open-" (fun root -> + let previous = Sys.getenv_opt "REWATCH_FROZEN_VALUES" in + Fun.protect + ~finally:(fun () -> + match previous with + | Some value -> Unix.putenv "REWATCH_FROZEN_VALUES" value + | None -> Unix.unsetenv "REWATCH_FROZEN_VALUES") + (fun () -> + write root "Api.res" + "type choice = A | B(int)\n\ + type box = {value: int}\n\ + exception Boom(int)\n\ + module Nested = {let answer = 2}\n\ + let value = 1\n"; + expect_code 0 (snd (run root "Api.res")); + write root "Consumer.res" + "open Api\n\ + let selected = B(value)\n\ + let boxed: box = {value: value}\n\ + let raised = Boom(value)\n\ + let nested = Nested.answer\n"; + let baseline = snd (run root ~extra:["-I"; root] "Consumer.res") in + assert_equal ~msg:baseline.stderr 0 baseline.exit_code; + let output = Filename.concat root "Consumer.js" in + let baseline_js = File_util.read_file output in + Unix.putenv "REWATCH_FROZEN_VALUES" "1"; + let session = Rescript_compiler_driver.create_session () in + let frozen = + snd (run ~session root ~extra:["-I"; root] "Consumer.res") + in + assert_equal ~msg:frozen.stderr 0 frozen.exit_code; + assert_equal baseline_js (File_util.read_file output))) + let concurrent_diagnostic_recovery_tests _context = Test_support.with_temp_dir "rewatch-driver-errors-" (fun root -> let first = Filename.concat root "first" in @@ -1602,8 +1973,14 @@ let tests = "interfaces_namespaces_load_paths" >:: interface_namespace_and_load_path_tests; "combined_dependency_cache" >:: combined_dependency_cache_tests; + "frozen_overrides_combined_snapshot" + >:: frozen_overrides_combined_snapshot_tests; "runtime_cmi_cache" >:: runtime_cmi_cache_tests; "project_cmi_cache" >:: project_cmi_cache_tests; + "frozen_values" >:: frozen_values_tests; + "frozen_module_forms" >:: frozen_module_forms_tests; + "frozen_inline_records" >:: frozen_inline_records_tests; + "frozen_open" >:: frozen_open_tests; "concurrent_diagnostic_recovery" >:: concurrent_diagnostic_recovery_tests; "concurrent_jsx_diagnostic" >:: concurrent_jsx_diagnostic_tests; diff --git a/tests/rewatch_ounit_tests/compiler_process_tests.ml b/tests/rewatch_ounit_tests/compiler_process_tests.ml index b986fbe377..779070a2aa 100644 --- a/tests/rewatch_ounit_tests/compiler_process_tests.ml +++ b/tests/rewatch_ounit_tests/compiler_process_tests.ml @@ -180,6 +180,7 @@ let domain_execution_test _context = in let ppx_result = Compiler_process.run + ~session:(Rescript_compiler_driver.create_session ()) Process. { program = "";