Drop unread data from .cmt files

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

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

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).

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;

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 =

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;

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;

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

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 ()

compiler/ml/cmt_format.mli

@@ -38,31 +38,29 @@ 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_comments: (string * Location.t) list;
-  cmt_args: string array;
-  cmt_sourcefile: string option;
-  cmt_builddir: string;
-  cmt_loadpath: string list;
+  cmt_value_dependencies: value_dependency 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;
 }
 
 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
 
@@ -74,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 *)
 

compiler/ml/cmt_format_common.ml

@@ -35,43 +35,31 @@ 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_comments: (string * Location.t) list;
-  cmt_args: string array;
-  cmt_sourcefile: string option;
-  cmt_builddir: string;
-  cmt_loadpath: string list;
+  cmt_value_dependencies: value_dependency 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_local_constraints env);
+  }
 
 let clear_part = function
   | Partial_structure s -> Partial_structure (cenv.structure cenv s)
@@ -85,14 +73,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
 
@@ -145,7 +131,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 +161,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