From bc2f41bd6a468442814a00186c127d0102d9b618 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 | 33 ++++++++------- compiler/ml/cmt_format.mli | 12 +++++- compiler/ml/cmt_format_common.ml | 44 +++++++++++++++++--- 4 files changed, 68 insertions(+), 28 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 425bdf83b27..d659e25eb6c 100644 --- a/analysis/reanalyze/src/dead_value.ml +++ b/analysis/reanalyze/src/dead_value.ml @@ -594,26 +594,27 @@ let traverse_structure ~config ~decls ~refs ~file_deps ~cross_file ~file (* Merge a location's references to another one's *) let process_value_dependency ~config ~refs ~file_deps ~cross_file - ( ({ - val_loc = - {loc_start = {pos_fname = fn_to} as pos_to; loc_ghost = ghost1} as - loc_to; - val_type = type_to; - } : - Types.value_description), - ({ - val_loc = - {loc_start = {pos_fname = fn_from} as pos_from; loc_ghost = ghost2} - as loc_from; - val_type = type_from; - } : - Types.value_description) ) = + ({ + value_loc = + {loc_start = {pos_fname = fn_to} as pos_to; loc_ghost = ghost1} as + loc_to; + spec_loc = + {loc_start = {pos_fname = fn_from} as pos_from; loc_ghost = ghost2} as + loc_from; + optional_args; + } : + Cmt_format.value_dependency) = if (not ghost1) && (not ghost2) && pos_to <> pos_from then ( let add_file_reference = file_is_implementation_of fn_to fn_from in add_value_reference ~config ~refs ~file_deps ~binding:Location.none ~add_file_reference ~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 ~file_deps ~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 fccae7f2225..62c106f8b75 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_comments: (string * Location.t) list; cmt_args: string array; cmt_sourcefile: string option; diff --git a/compiler/ml/cmt_format_common.ml b/compiler/ml/cmt_format_common.ml index c42455d58f0..f220361aa71 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_comments: (string * Location.t) list; cmt_args: string array; cmt_sourcefile: string option; @@ -145,7 +152,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 () = @@ -176,7 +182,35 @@ let 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 5a289d9e3766c801cb9bec9c499a2dd6afde9b48 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 .cmt fields that no tool reads Why: Eight cmt_infos fields came from OCaml and had no reader: the comments (always empty), the command line, source file, build directory, load path, initial environment, imports and the use_summaries flag. Dropping them and the OCAML_BINANNOT_WITHENV switch (which kept full environments in the typed tree) leaves the module name, the typed tree, the value dependencies, the source digest (rescript-tools migrate) and the deprecation uses. The runtime's .cmt and .cmti files get 3% smaller. 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/core/js_implementation.ml | 3 +- compiler/ext/compiler_request_state.ml | 2 - compiler/ext/compiler_request_state.mli | 1 - compiler/jsoo/jsoo_playground_main.ml | 12 +----- compiler/ml/cmt_format.ml | 7 +--- compiler/ml/cmt_format.mli | 20 ++-------- compiler/ml/cmt_format_common.ml | 38 ++++--------------- .../platform/native/cmt_format_persistence.ml | 14 +------ .../playground/cmt_format_persistence.ml | 4 +- compiler/ml/typemod.ml | 10 ++--- compiler/ml/typemod.mli | 3 +- .../ounit_compiler_request_tests.ml | 18 +++------ 13 files changed, 29 insertions(+), 104 deletions(-) diff --git a/compiler/bsc/rescript_compiler_driver.ml b/compiler/bsc/rescript_compiler_driver.ml index f0afa805571..128368a8fc3 100644 --- a/compiler/bsc/rescript_compiler_driver.ml +++ b/compiler/bsc/rescript_compiler_driver.ml @@ -595,7 +595,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/core/js_implementation.ml b/compiler/core/js_implementation.ml index df80ff56295..d092dcecb80 100644 --- a/compiler/core/js_implementation.ml +++ b/compiler/core/js_implementation.ml @@ -56,8 +56,7 @@ let after_parsing_sig ppf outputprefix ast = ignore (Env.save_signature ~deprecated sg modulename (outputprefix ^ ".cmi")); Typemod.save_signature modulename tsg outputprefix - (Location.get_input_name ()) - initial_env; + (Location.get_input_name ()); process_with_gentype (outputprefix ^ ".cmti")) let interface ~parser ppf ?outputprefix fname = 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 2531f825e63..006004f52d4 100644 --- a/compiler/jsoo/jsoo_playground_main.ml +++ b/compiler/jsoo/jsoo_playground_main.ml @@ -494,22 +494,14 @@ module Compile = struct List.iter Iter.iter_structure_item structure.str_items; Js.array (!acc |> Array.of_list) - let gentype_output ~module_system ~modulename ~sourcefile structure env = + let gentype_output ~module_system ~modulename ~sourcefile structure = let cmt_annots = Cmt_format.Implementation structure in let input_cmt = { Cmt_format.cmt_modname = modulename; cmt_annots; cmt_value_dependencies = []; - cmt_comments = []; - cmt_args = [||]; - cmt_sourcefile = Some sourcefile; - cmt_builddir = Sys.getcwd (); - cmt_loadpath = Config.get_load_path (); cmt_source_digest = None; - cmt_initial_env = env; - cmt_imports = []; - cmt_use_summaries = false; cmt_extra_info = {Cmt_utils.deprecated_used = []}; } in @@ -720,7 +712,7 @@ module Compile = struct inject @@ Js.string (gentype_output ~module_system ~modulename - ~sourcefile:filename structure env) ); + ~sourcefile:filename structure) ); |] else [||] in diff --git a/compiler/ml/cmt_format.ml b/compiler/ml/cmt_format.ml index b8218796f45..d86f88a8a03 100644 --- a/compiler/ml/cmt_format.ml +++ b/compiler/ml/cmt_format.ml @@ -1,8 +1,5 @@ include Cmt_format_common -let set_args = Cmt_format_persistence.set_args - -let save_cmt filename modname binary_annots sourcefile initial_env = - Cmt_format_persistence.save_cmt filename modname binary_annots sourcefile - initial_env; +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 62c106f8b75..843d711c5df 100644 --- a/compiler/ml/cmt_format.mli +++ b/compiler/ml/cmt_format.mli @@ -51,15 +51,9 @@ type cmt_infos = { cmt_modname: string; cmt_annots: binary_annots; cmt_value_dependencies: value_dependency list; - cmt_comments: (string * Location.t) list; - cmt_args: string array; - cmt_sourcefile: string option; - cmt_builddir: string; - cmt_loadpath: string list; cmt_source_digest: Digest.t option; - cmt_initial_env: Env.t; - cmt_imports: (string * Digest.t option) list; - cmt_use_summaries: bool; + (** 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; } @@ -67,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 @@ -82,11 +72,9 @@ val save_cmt : binary_annots -> string option -> (* source file *) - Env.t -> - (* initial env *) unit -(** [save_cmt filename modname binary_annots sourcefile initial_env] - writes a cmt(i) file. *) +(** [save_cmt filename modname binary_annots sourcefile] writes a cmt(i) + file. *) (* Miscellaneous functions *) diff --git a/compiler/ml/cmt_format_common.ml b/compiler/ml/cmt_format_common.ml index f220361aa71..9cbdef3912e 100644 --- a/compiler/ml/cmt_format_common.ml +++ b/compiler/ml/cmt_format_common.ml @@ -47,38 +47,16 @@ type cmt_infos = { cmt_modname: string; cmt_annots: binary_annots; cmt_value_dependencies: value_dependency list; - cmt_comments: (string * Location.t) list; - cmt_args: string array; - cmt_sourcefile: string option; - cmt_builddir: string; - cmt_loadpath: string list; cmt_source_digest: Digest.t option; - cmt_initial_env: Env.t; - cmt_imports: (string * Digest.t option) list; - cmt_use_summaries: bool; 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) @@ -92,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 9fac04c5842..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 @@ -25,27 +23,17 @@ let read_source_file path = (* Unlike OCaml, no copy of the .cmi is written in front of the cmt infos: tools read the .cmi itself. *) -let save_cmt filename modname binary_annots sourcefile initial_env = +let save_cmt filename modname binary_annots sourcefile = if !((Clflags.current ()).binary_annotations) then let cmt = { cmt_modname = modname; cmt_annots = clear_env binary_annots; cmt_value_dependencies = value_dependencies (); - cmt_comments = []; - cmt_args = (Compiler_request_state.current ()).cmt_args; - cmt_sourcefile = sourcefile; - cmt_builddir = Compiler_request_state.cwd (); - cmt_loadpath = Config.get_load_path (); cmt_source_digest = Misc.may_map (fun path -> Digest.string (read_source_file path)) sourcefile; - cmt_initial_env = - (if need_to_clear_env then keep_only_summary initial_env - else initial_env); - cmt_imports = List.sort compare (Env.imports ()); - cmt_use_summaries = need_to_clear_env; cmt_extra_info = {deprecated_used = deprecated_uses ()}; } in diff --git a/compiler/ml/platform/playground/cmt_format_persistence.ml b/compiler/ml/platform/playground/cmt_format_persistence.ml index a6981d8b1a4..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 _initial_env = () +let save_cmt _filename _modname _binary_annots _sourcefile = () diff --git a/compiler/ml/typemod.ml b/compiler/ml/typemod.ml index 072f91bfd82..68ea6842859 100644 --- a/compiler/ml/typemod.ml +++ b/compiler/ml/typemod.ml @@ -1801,7 +1801,7 @@ let type_implementation_more ?check_exists sourcefile outputprefix modulename so that value declarations which are not used internally but exported are not reported as being unused. *) Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename - (Cmt_format.Implementation str) (Some sourcefile) initial_env; + (Cmt_format.Implementation str) (Some sourcefile); (str, coercion, finalenv, dclsig) (* identifier is useless might read from serialized cmi files*)) else ( @@ -1823,18 +1823,18 @@ let type_implementation_more ?check_exists sourcefile outputprefix modulename (Env.save_signature ?check_exists ~deprecated simple_sg modulename (outputprefix ^ ".cmi")); Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename - (Cmt_format.Implementation str) (Some sourcefile) initial_env); + (Cmt_format.Implementation str) (Some sourcefile)); (str, coercion, finalenv, simple_sg)) with e -> Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename (Cmt_format.Partial_implementation (Array.of_list (Cmt_format.get_saved_types ()))) - (Some sourcefile) initial_env; + (Some sourcefile); raise e -let save_signature modname tsg outputprefix source_file initial_env = +let save_signature modname tsg outputprefix source_file = Cmt_format.save_cmt (outputprefix ^ ".cmti") modname - (Cmt_format.Interface tsg) (Some source_file) initial_env + (Cmt_format.Interface tsg) (Some source_file) (* "Packaging" of several compilation units into one unit having them as sub-modules. *) diff --git a/compiler/ml/typemod.mli b/compiler/ml/typemod.mli index 14026cd9510..dce19d6c619 100644 --- a/compiler/ml/typemod.mli +++ b/compiler/ml/typemod.mli @@ -42,8 +42,7 @@ val type_open_ : Longident.t Asttypes.loc -> Path.t * Env.t -val save_signature : - string -> Typedtree.signature -> string -> string -> Env.t -> unit +val save_signature : string -> Typedtree.signature -> string -> string -> unit type error = | Cannot_apply of module_type 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 14fa937d67440743e4e7070bf657c7365b5d2084 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 | 64 ++++----------------------- compiler/ml/env.mli | 22 ++------- 4 files changed, 17 insertions(+), 75 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..8ee4e98dd3e --- /dev/null +++ b/changes/smaller-cmt-files.internal.md @@ -0,0 +1 @@ +- Write a quarter less into `.cmt` files by dropping data no tool reads (full value descriptions in the value dependencies, OCaml-only fields, environment summaries). diff --git a/compiler/ml/cmt_format_common.ml b/compiler/ml/cmt_format_common.ml index 9cbdef3912e..4fd28aa8a73 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 f40ba2dc63d..06590447734 100644 --- a/compiler/ml/env.ml +++ b/compiler/ml/env.ml @@ -147,18 +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_constraints of summary * type_declaration Path_map.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 @@ -376,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; @@ -456,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; @@ -1089,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 @@ -1552,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 @@ -1599,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 = @@ -1608,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 @@ -1636,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 = @@ -1655,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. *) @@ -1690,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 @@ -1781,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 @@ -2003,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 0f3f1589232..a2ebfcaf66b 100644 --- a/compiler/ml/env.mli +++ b/compiler/ml/env.mli @@ -20,18 +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_constraints of summary * type_declaration Path_map.t - | Env_copy_types of summary * string list - type t val empty : t @@ -201,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