From b4583a1df7ab3d1b853b4f43f5c03e512c1a34f9 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 6 Nov 2026 21:06:41 +0000 Subject: [PATCH 1/3] Record value dependencies in .cmt files as two locations and a flag Why: Each value inclusion check stored both full value descriptions (type, attributes, doc comments) in the .cmt, a fifth of the stdlib's .cmt bytes. Reanalyze, the only reader, uses the two locations and whether both types take optional arguments; the compiler now records just that. Review: Does reanalyze still see the same optional-argument references? Yes: the flag is computed with the same check on the same two types, the deadcode snapshots are unchanged, and forcing the flag off adds three findings to them. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01Kbf3gLMbg8G3FeSq6sPLM2 Signed-off-by: Christoph Knittel --- analysis/reanalyze/src/dead_optional_args.ml | 7 +--- analysis/reanalyze/src/dead_value.ml | 25 +++++------ compiler/ml/cmt_format.mli | 12 +++++- compiler/ml/cmt_format_common.ml | 44 +++++++++++++++++--- 4 files changed, 64 insertions(+), 24 deletions(-) diff --git a/analysis/reanalyze/src/dead_optional_args.ml b/analysis/reanalyze/src/dead_optional_args.ml index 4866f750777..c3b84a28a4f 100644 --- a/analysis/reanalyze/src/dead_optional_args.ml +++ b/analysis/reanalyze/src/dead_optional_args.ml @@ -16,11 +16,8 @@ let rec has_optional_args (texpr : Types.type_expr) = | _ -> false let add_function_reference ~config ~cross_file ~(loc_from : Location.t) - ~(loc_to : Location.t) ~type_from ~type_to = - (* Keep this filter type-based rather than consulting the declaration table. - References can be collected before their target declaration is visited, - notably in [let rec ... and ...] groups. *) - if has_optional_args type_from && has_optional_args type_to then ( + ~(loc_to : Location.t) = + if active () then ( let pos_to = loc_to.loc_start in let pos_from = loc_from.loc_start in if config.Dce_config.cli.debug then diff --git a/analysis/reanalyze/src/dead_value.ml b/analysis/reanalyze/src/dead_value.ml index 0dd32051602..d44ceac6493 100644 --- a/analysis/reanalyze/src/dead_value.ml +++ b/analysis/reanalyze/src/dead_value.ml @@ -593,20 +593,21 @@ let traverse_structure ~config ~decls ~refs ~cross_file ~file ~do_types (* Merge a location's references to another one's *) let process_value_dependency ~config ~refs ~cross_file - ( ({ - val_loc = {loc_start = pos_to; loc_ghost = ghost1} as loc_to; - val_type = type_to; - } : - Types.value_description), - ({ - val_loc = {loc_start = pos_from; loc_ghost = ghost2} as loc_from; - val_type = type_from; - } : - Types.value_description) ) = + ({ + value_loc = {loc_start = pos_to; loc_ghost = ghost1} as loc_to; + spec_loc = {loc_start = pos_from; loc_ghost = ghost2} as loc_from; + optional_args; + } : + Cmt_format.value_dependency) = if (not ghost1) && (not ghost2) && pos_to <> pos_from then ( add_value_reference ~config ~refs ~binding:Location.none ~loc_from ~loc_to; - Dead_optional_args.add_function_reference ~config ~cross_file ~loc_from - ~loc_to ~type_from ~type_to) + (* The compiler decides this from the two types rather than reanalyze + consulting its declaration table: references can be collected before + their target declaration is visited, notably in [let rec ... and ...] + groups. *) + if optional_args then + Dead_optional_args.add_function_reference ~config ~cross_file ~loc_from + ~loc_to) let process_structure ~config ~decls ~refs ~cross_file ~file ~cmt_value_dependencies ~do_types ~do_externals diff --git a/compiler/ml/cmt_format.mli b/compiler/ml/cmt_format.mli index 8bdd9642c36..60163534a66 100644 --- a/compiler/ml/cmt_format.mli +++ b/compiler/ml/cmt_format.mli @@ -38,11 +38,19 @@ and binary_part = | Partial_signature_item of signature_item | Partial_module_type of module_type +type value_dependency = { + value_loc: Location.t; (** The value that was matched. *) + spec_loc: Location.t; (** The declaration it was matched against. *) + optional_args: bool; + (** Both types are functions with an optional parameter. *) +} +(** One value inclusion check (an implementation against its interface, or a + module against a module type), recorded for reanalyze. *) + type cmt_infos = { cmt_modname: string; cmt_annots: binary_annots; - cmt_value_dependencies: - (Types.value_description * Types.value_description) list; + cmt_value_dependencies: value_dependency list; cmt_args: string array; cmt_source_digest: Digest.t option; cmt_extra_info: Cmt_utils.cmt_extra_info; diff --git a/compiler/ml/cmt_format_common.ml b/compiler/ml/cmt_format_common.ml index fdb6140216e..dd00aba1f85 100644 --- a/compiler/ml/cmt_format_common.ml +++ b/compiler/ml/cmt_format_common.ml @@ -35,11 +35,18 @@ and binary_part = | Partial_signature_item of signature_item | Partial_module_type of module_type +(* What reanalyze needs from one value inclusion check. Keeping the two full + value descriptions instead made up a fifth of the stdlib's .cmt bytes. *) +type value_dependency = { + value_loc: Location.t; + spec_loc: Location.t; + optional_args: bool; +} + type cmt_infos = { cmt_modname: string; cmt_annots: binary_annots; - cmt_value_dependencies: - (Types.value_description * Types.value_description) list; + cmt_value_dependencies: value_dependency list; cmt_args: string array; cmt_source_digest: Digest.t option; cmt_extra_info: Cmt_utils.cmt_extra_info; @@ -138,7 +145,6 @@ let accumulators = {saved_types = []; value_deps = []; deprecated_used = []}) let current_accumulators () = Domain.DLS.get accumulators -let value_dependencies () = (current_accumulators ()).value_deps let deprecated_uses () = (current_accumulators ()).deprecated_used let clear () = @@ -170,7 +176,35 @@ let[@live] record_deprecated_used ?deprecated_context ?migration_template let _ = Cmt_utils.record_deprecated_used := record_deprecated_used -let record_value_dependency vd1 vd2 = - if vd1.Types.val_loc <> vd2.Types.val_loc then +(* Whether a type is a function with an optional parameter. *) +let rec takes_optional_args (t : Types.type_expr) = + match t.desc with + | Tarrow (params, _) -> + List.exists + (fun ({lbl} : Types.arg) -> + match lbl with + | Optional _ -> true + | Nolabel | Labelled _ -> false) + params + | Tlink t | Tsubst t -> takes_optional_args t + | _ -> false + +let record_value_dependency (vd1 : Types.value_description) + (vd2 : Types.value_description) = + if vd1.val_loc <> vd2.val_loc then let state = current_accumulators () in state.value_deps <- (vd1, vd2) :: state.value_deps + +(* The flag is decided when the .cmt is written, not when the dependency is + recorded: the inclusion check that follows the recording can still + instantiate weak type variables of the value. *) +let value_dependencies () = + List.map + (fun ((vd1 : Types.value_description), (vd2 : Types.value_description)) -> + { + value_loc = vd1.val_loc; + spec_loc = vd2.val_loc; + optional_args = + takes_optional_args vd1.val_type && takes_optional_args vd2.val_type; + }) + (current_accumulators ()).value_deps From b0465b49b1e65bcaec8418e1b1b87d40484917cc Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 6 Nov 2026 21:10:13 +0000 Subject: [PATCH 2/3] Stop writing the command line into .cmt files Why: #9173 removed most of the cmt_infos fields that came from OCaml and had no reader. Two leftovers remain: cmt_args, the command line that no tool reads, and the OCAML_BINANNOT_WITHENV switch, which kept full environments in the typed tree for OCaml's Envaux, which this compiler doesn't have. Both are removed, leaving the module name, the typed tree, the value dependencies, the source digest (rescript-tools migrate) and the deprecation uses. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01Kbf3gLMbg8G3FeSq6sPLM2 Signed-off-by: Christoph Knittel --- compiler/bsc/rescript_compiler_driver.ml | 1 - compiler/ext/compiler_request_state.ml | 2 -- compiler/ext/compiler_request_state.mli | 1 - compiler/jsoo/jsoo_playground_main.ml | 1 - compiler/ml/cmt_format.ml | 2 -- compiler/ml/cmt_format.mli | 7 ++--- compiler/ml/cmt_format_common.ml | 31 +++++-------------- .../platform/native/cmt_format_persistence.ml | 3 -- .../playground/cmt_format_persistence.ml | 2 -- .../ounit_compiler_request_tests.ml | 18 +++-------- 10 files changed, 14 insertions(+), 54 deletions(-) diff --git a/compiler/bsc/rescript_compiler_driver.ml b/compiler/bsc/rescript_compiler_driver.ml index 06f3461f884..9a5f16088a3 100644 --- a/compiler/bsc/rescript_compiler_driver.ml +++ b/compiler/bsc/rescript_compiler_driver.ml @@ -592,7 +592,6 @@ let with_fresh_request_states ~cwd action = let run_argv ?run_external ~capture ~cwd argv = with_fresh_request_states ~cwd (fun () -> start_request (); - Cmt_format.set_args argv; let execute () = try Bsc_args.parse_exn ~argv (command_line_flags ()) anonymous ~usage; diff --git a/compiler/ext/compiler_request_state.ml b/compiler/ext/compiler_request_state.ml index db71341576e..6ac9922b283 100644 --- a/compiler/ext/compiler_request_state.ml +++ b/compiler/ext/compiler_request_state.ml @@ -3,7 +3,6 @@ type t = { cwd: string; mutable input_name: string; mutable command_runner: string -> int; - mutable cmt_args: string array; mutable lambda_raise_count: int; mutable lambda_negative_raise_count: int; mutable builtin_ppx_local_module_counter: int; @@ -22,7 +21,6 @@ let create ~active cwd = cwd; input_name = "_none_"; command_runner = Sys.command; - cmt_args = Sys.argv; lambda_raise_count = 0; lambda_negative_raise_count = 0; builtin_ppx_local_module_counter = 0; diff --git a/compiler/ext/compiler_request_state.mli b/compiler/ext/compiler_request_state.mli index 71e3bed64fd..7bb74ef4b06 100644 --- a/compiler/ext/compiler_request_state.mli +++ b/compiler/ext/compiler_request_state.mli @@ -3,7 +3,6 @@ type t = { cwd: string; mutable input_name: string; mutable command_runner: string -> int; - mutable cmt_args: string array; mutable lambda_raise_count: int; mutable lambda_negative_raise_count: int; mutable builtin_ppx_local_module_counter: int; diff --git a/compiler/jsoo/jsoo_playground_main.ml b/compiler/jsoo/jsoo_playground_main.ml index dd8484a49b9..77aed6e3aa0 100644 --- a/compiler/jsoo/jsoo_playground_main.ml +++ b/compiler/jsoo/jsoo_playground_main.ml @@ -493,7 +493,6 @@ module Compile = struct Cmt_format.cmt_modname = modulename; cmt_annots; cmt_value_dependencies = []; - cmt_args = [||]; cmt_source_digest = None; cmt_extra_info = {Cmt_utils.deprecated_used = []}; } diff --git a/compiler/ml/cmt_format.ml b/compiler/ml/cmt_format.ml index cc2484a4531..d86f88a8a03 100644 --- a/compiler/ml/cmt_format.ml +++ b/compiler/ml/cmt_format.ml @@ -1,7 +1,5 @@ include Cmt_format_common -let set_args = Cmt_format_persistence.set_args - let save_cmt filename modname binary_annots sourcefile = Cmt_format_persistence.save_cmt filename modname binary_annots sourcefile; clear () diff --git a/compiler/ml/cmt_format.mli b/compiler/ml/cmt_format.mli index 60163534a66..843d711c5df 100644 --- a/compiler/ml/cmt_format.mli +++ b/compiler/ml/cmt_format.mli @@ -51,8 +51,9 @@ type cmt_infos = { cmt_modname: string; cmt_annots: binary_annots; cmt_value_dependencies: value_dependency list; - cmt_args: string array; cmt_source_digest: Digest.t option; + (** Digest of the source file, which [rescript-tools migrate] compares + to tell whether the .cmt is current. *) cmt_extra_info: Cmt_utils.cmt_extra_info; } @@ -60,10 +61,6 @@ type error = Not_a_typedtree of string exception Error of error -val set_args : string array -> unit -(** Set the logical compiler arguments recorded in subsequently written CMT - files. Long-lived compiler hosts set this at each request boundary. *) - val read_cmt : string -> cmt_infos val read_cmi : string -> Cmi_format.cmi_infos diff --git a/compiler/ml/cmt_format_common.ml b/compiler/ml/cmt_format_common.ml index dd00aba1f85..6a06b39d254 100644 --- a/compiler/ml/cmt_format_common.ml +++ b/compiler/ml/cmt_format_common.ml @@ -47,31 +47,16 @@ type cmt_infos = { cmt_modname: string; cmt_annots: binary_annots; cmt_value_dependencies: value_dependency list; - cmt_args: string array; cmt_source_digest: Digest.t option; cmt_extra_info: Cmt_utils.cmt_extra_info; } -(* Note that in Typerex, there is an awful hack to save a cmt file - together with the interface file that was generated by ocaml (this - is because the installed version of ocaml might differ from the one - integrated in Typerex). -*) - type error = Not_a_typedtree of string -let need_to_clear_env = - try - ignore (Sys.getenv "OCAML_BINANNOT_WITHENV"); - false - with Not_found -> true - -let keep_only_summary = Env.keep_only_summary - open Tast_mapper let cenv = - {Tast_mapper.default with env = (fun _sub env -> keep_only_summary env)} + {Tast_mapper.default with env = (fun _sub env -> Env.keep_only_summary env)} let clear_part = function | Partial_structure s -> Partial_structure (cenv.structure cenv s) @@ -85,14 +70,12 @@ let clear_part = function | Partial_module_type s -> Partial_module_type (cenv.module_type cenv s) let clear_env binary_annots = - if need_to_clear_env then - match binary_annots with - | Implementation s -> Implementation (cenv.structure cenv s) - | Interface s -> Interface (cenv.signature cenv s) - | Partial_implementation array -> - Partial_implementation (Array.map clear_part array) - | Partial_interface array -> Partial_interface (Array.map clear_part array) - else binary_annots + match binary_annots with + | Implementation s -> Implementation (cenv.structure cenv s) + | Interface s -> Interface (cenv.signature cenv s) + | Partial_implementation array -> + Partial_implementation (Array.map clear_part array) + | Partial_interface array -> Partial_interface (Array.map clear_part array) exception Error of error diff --git a/compiler/ml/platform/native/cmt_format_persistence.ml b/compiler/ml/platform/native/cmt_format_persistence.ml index 461230a1262..f911cf044e7 100644 --- a/compiler/ml/platform/native/cmt_format_persistence.ml +++ b/compiler/ml/platform/native/cmt_format_persistence.ml @@ -15,8 +15,6 @@ open Cmt_format_common -let set_args value = (Compiler_request_state.current ()).cmt_args <- value - let read_source_file path = let path = Compiler_request_state.resolve_path path in match Build_file_store.read path with @@ -32,7 +30,6 @@ let save_cmt filename modname binary_annots sourcefile = cmt_modname = modname; cmt_annots = clear_env binary_annots; cmt_value_dependencies = value_dependencies (); - cmt_args = (Compiler_request_state.current ()).cmt_args; cmt_source_digest = Misc.may_map (fun path -> Digest.string (read_source_file path)) diff --git a/compiler/ml/platform/playground/cmt_format_persistence.ml b/compiler/ml/platform/playground/cmt_format_persistence.ml index 48dccc6d623..713f8376e7b 100644 --- a/compiler/ml/platform/playground/cmt_format_persistence.ml +++ b/compiler/ml/platform/playground/cmt_format_persistence.ml @@ -1,3 +1 @@ -let set_args _value = () - let save_cmt _filename _modname _binary_annots _sourcefile = () diff --git a/tests/ounit_tests/ounit_compiler_request_tests.ml b/tests/ounit_tests/ounit_compiler_request_tests.ml index 24b121ef3c5..38278613ad0 100644 --- a/tests/ounit_tests/ounit_compiler_request_tests.ml +++ b/tests/ounit_tests/ounit_compiler_request_tests.ml @@ -813,26 +813,22 @@ let cmt_accumulator_isolation_tests _context = let left = Domain.spawn (fun () -> Cmt_format.clear (); - Cmt_format.set_args [|"bsc"; "First.res"|]; Cmt_format.add_saved_type saved_part; Atomic.set left_ready true; wait_for_atomic right_ready; - ( List.length (Cmt_format.get_saved_types ()), - (Compiler_request_state.current ()).cmt_args )) + List.length (Cmt_format.get_saved_types ())) in let right = Domain.spawn (fun () -> wait_for_atomic left_ready; Cmt_format.clear (); - Cmt_format.set_args [|"bsc"; "Second.res"|]; Cmt_format.add_saved_type saved_part; Cmt_format.add_saved_type saved_part; Atomic.set right_ready true; - ( List.length (Cmt_format.get_saved_types ()), - (Compiler_request_state.current ()).cmt_args )) + List.length (Cmt_format.get_saved_types ())) in - assert_equal (1, [|"bsc"; "First.res"|]) (Domain.join left); - assert_equal (2, [|"bsc"; "Second.res"|]) (Domain.join right) + assert_equal 1 (Domain.join left); + assert_equal 2 (Domain.join right) let package_output_isolation_tests _context = let left_ready = Atomic.make false in @@ -1304,17 +1300,13 @@ let state_boundary_tests _context = (contains_text after_source_flags.stderr "Warning number 39") "source-level compiler flags are reset between requests"; write root "Mapped.res" "let mapped = 1\n"; - let mapped_args, mapped = + let _, mapped = run root ~extra:["-bs-source-map"; "linked"] "Mapped.res" in expect_code 0 mapped; check (Sys.file_exists (Filename.concat root "Mapped.js.map")) "the requested source map is generated"; - let cmt = Cmt_format.read_cmt (Filename.concat root "Mapped.cmt") in - check - (Array.to_list cmt.cmt_args = ("bsc" :: mapped_args) @ ["Mapped.res"]) - "CMT metadata records the logical request argv"; write root "Plain.res" "let plain = 1\n"; let _, plain = run root From 37dc85ed3ddf1983dfc91fb6fb9153ce8135ed6d Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 6 Nov 2026 21:12:34 +0000 Subject: [PATCH 3/3] Remove environment summaries Why: Every environment extension also prepended a summary node (a log of the bindings and opens that built it), and .cmt files kept these logs in every environment of the typed tree. OCaml tools replay them with Envaux to rebuild an environment; this compiler has no Envaux and no tool reads them. The environments stored in .cmt files now keep only their GADT local constraints and flags, and the runtime's .cmt and .cmti files get 7% smaller. Review: Do reanalyze and gentype lose anything? No: they only look types and modules up in typed-tree environments, and the tables those lookups read were already empty in .cmt files. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01Kbf3gLMbg8G3FeSq6sPLM2 Signed-off-by: Christoph Knittel --- changes/smaller-cmt-files.internal.md | 1 + compiler/ml/cmt_format_common.ml | 5 ++- compiler/ml/env.ml | 63 ++++----------------------- compiler/ml/env.mli | 21 ++------- 4 files changed, 17 insertions(+), 73 deletions(-) create mode 100644 changes/smaller-cmt-files.internal.md diff --git a/changes/smaller-cmt-files.internal.md b/changes/smaller-cmt-files.internal.md new file mode 100644 index 00000000000..de1da7715f8 --- /dev/null +++ b/changes/smaller-cmt-files.internal.md @@ -0,0 +1 @@ +- Write smaller `.cmt` files by dropping data no tool reads: full value descriptions in the value dependencies, the command line and environment summaries. diff --git a/compiler/ml/cmt_format_common.ml b/compiler/ml/cmt_format_common.ml index 6a06b39d254..61023d0ed9d 100644 --- a/compiler/ml/cmt_format_common.ml +++ b/compiler/ml/cmt_format_common.ml @@ -56,7 +56,10 @@ type error = Not_a_typedtree of string open Tast_mapper let cenv = - {Tast_mapper.default with env = (fun _sub env -> Env.keep_only_summary env)} + { + Tast_mapper.default with + env = (fun _sub env -> Env.keep_only_local_constraints env); + } let clear_part = function | Partial_structure s -> Partial_structure (cenv.structure cenv s) diff --git a/compiler/ml/env.ml b/compiler/ml/env.ml index fee35abf0aa..06590447734 100644 --- a/compiler/ml/env.ml +++ b/compiler/ml/env.ml @@ -147,17 +147,6 @@ end module Path_map = Map.Make (Path) -type summary = - | Env_empty - | Env_value of summary * Ident.t * value_description - | Env_type of summary * Ident.t * type_declaration - | Env_extension of summary * Ident.t * extension_constructor - | Env_module of summary * Ident.t * module_declaration - | Env_modtype of summary * Ident.t * modtype_declaration - | Env_open of summary * Path.t - | Env_functor_arg of summary * Ident.t - | Env_copy_types of summary * string list - module Tycomp_tbl = struct (** This module is used to store components of types (i.e. labels and constructors). We keep a representation of each nested @@ -375,7 +364,6 @@ type t = { modtypes: modtype_declaration Id_tbl.t; components: module_components Id_tbl.t; functor_args: unit Ident.tbl; - summary: summary; local_constraints: type_declaration Path_map.t; gadt_instances: (int * Type_set.t ref) list; flags: int; @@ -455,7 +443,6 @@ let empty = modules = Id_tbl.empty; modtypes = Id_tbl.empty; components = Id_tbl.empty; - summary = Env_empty; local_constraints = Path_map.empty; gadt_instances = []; flags = 0; @@ -1088,7 +1075,7 @@ let copy_types l env = let values = List.fold_left (fun env s -> Id_tbl.update s f env) env.values l in - {env with values; summary = Env_copy_types (env.summary, l)} + {env with values} let mark_value_used env name vd = if not (is_implicit_coercion env) then @@ -1551,11 +1538,7 @@ and check_value_name name loc = and store_value ?check id decl env = check_value_name (Ident.name id) decl.val_loc; may (fun f -> check_usage decl.val_loc id f (value_declarations ())) check; - { - env with - values = Id_tbl.add id decl env.values; - summary = Env_value (env.summary, id, decl); - } + {env with values = Id_tbl.add id decl env.values} and store_type ~check id info env = let loc = info.type_loc in @@ -1598,7 +1581,6 @@ and store_type ~check id info env = (fun (id, descr) labels -> Tycomp_tbl.add id descr labels) labels env.labels; types = Id_tbl.add id (info, descrs) env.types; - summary = Env_type (env.summary, id, info); } and store_type_infos id info env = @@ -1607,11 +1589,7 @@ and store_type_infos id info env = manifest-ness of the type. Used in components_of_module to keep track of type abbreviations (e.g. type t = float) in the computation of label representations. *) - { - env with - types = Id_tbl.add id (info, ([], [])) env.types; - summary = Env_type (env.summary, id, info); - } + {env with types = Id_tbl.add id (info, ([], [])) env.types} and store_extension ~check id ext env = let loc = ext.ext_loc in @@ -1635,7 +1613,6 @@ and store_extension ~check id ext env = env with constrs = Tycomp_tbl.add id (Datarepr.extension_descr (Pident id) ext) env.constrs; - summary = Env_extension (env.summary, id, ext); } and store_module ~check id md env = @@ -1654,15 +1631,10 @@ and store_module ~check id md env = (components_of_module ~deprecated ~loc:md.md_loc env Subst.identity (Pident id) md.md_type) env.components; - summary = Env_module (env.summary, id, md); } and store_modtype id info env = - { - env with - modtypes = Id_tbl.add id info env.modtypes; - summary = Env_modtype (env.summary, id, info); - } + {env with modtypes = Id_tbl.add id info env.modtypes} (* Compute the components of a functor application in a path. *) @@ -1689,11 +1661,7 @@ let _ = (* Insertion of bindings by identifier *) let add_functor_arg id env = - { - env with - functor_args = Ident.add id () env.functor_args; - summary = Env_functor_arg (env.summary, id); - } + {env with functor_args = Ident.add id () env.functor_args} let add_value ?check id desc env = store_value ?check id desc env @@ -1780,17 +1748,7 @@ let add_components slot root env0 comps = let modules = add (fun x -> `Module x) comps.comp_modules env0.modules in - { - env0 with - summary = Env_open (env0.summary, root); - constrs; - labels; - values; - types; - modtypes; - components; - modules; - } + {env0 with constrs; labels; values; types; modtypes; components; modules} let open_signature slot root env0 = match get_components (find_module_descr root env0) with @@ -2002,16 +1960,11 @@ let last_env () = Domain.DLS.get last_env_key let last_reduced_env_key = Request_local.new_key (fun () -> ref empty) let last_reduced_env () = Domain.DLS.get last_reduced_env_key -let keep_only_summary env = +let keep_only_local_constraints env = if !(last_env ()) == env then !(last_reduced_env ()) else let new_env = - { - empty with - summary = env.summary; - local_constraints = env.local_constraints; - flags = env.flags; - } + {empty with local_constraints = env.local_constraints; flags = env.flags} in last_env () := env; last_reduced_env () := new_env; diff --git a/compiler/ml/env.mli b/compiler/ml/env.mli index a7b680ac539..a2ebfcaf66b 100644 --- a/compiler/ml/env.mli +++ b/compiler/ml/env.mli @@ -20,17 +20,6 @@ open Types module Path_map : Map.S with type key = Path.t and type 'a t = 'a Map.Make(Path).t -type summary = - | Env_empty - | Env_value of summary * Ident.t * value_description - | Env_type of summary * Ident.t * type_declaration - | Env_extension of summary * Ident.t * extension_constructor - | Env_module of summary * Ident.t * module_declaration - | Env_modtype of summary * Ident.t * modtype_declaration - | Env_open of summary * Path.t - | Env_functor_arg of summary * Ident.t - | Env_copy_types of summary * string list - type t val empty : t @@ -200,13 +189,11 @@ val imports : unit -> (string * Digest.t option) list val crc_units : unit -> Consistbl.t val add_import : string -> unit -(* Summaries -- compact representation of an environment, to be - exported in debugging information. *) - -(* Return an equivalent environment where all fields have been reset, - except the summary. *) +val keep_only_local_constraints : t -> t +(** The environment stored in .cmt files: empty except for its GADT local + constraints and flags. Tools only look things up in it, and the lookups + find nothing in an empty table. *) -val keep_only_summary : t -> t type error = | Illegal_renaming of string * string * string | Inconsistent_import of string * string * string