Reuse read interfaces across compiler requests in OCaml rewatch

changes/ocaml-rewatch-cmi-read-cache.polish.md

@@ -0,0 +1 @@
+- OCaml rewatch: reuse the interfaces a worker has read for later modules while their files are unchanged, which makes builds of projects using the standard library faster. https://github.com/rescript-lang/rescript/pull/8874

compiler/core/bs_cmi_load.ml

@@ -22,6 +22,59 @@
  * along with this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
+(* A host that compiles many modules in one process, such as rewatch, would
+   otherwise read the same interfaces again for every module, and reading the
+   large Stdlib ones is a sizable part of compiling a small module. With the
+   cache enabled, each domain keeps the interfaces it reads. Domains can't share
+   them: copying a signature (Subst) marks its types in place until the copy is
+   done.
+
+   An entry is used only while the file's identity, size and modification time
+   are unchanged. Like Git with racily clean files, a file modified in the last
+   two seconds is always read again: a rewrite of the same size within one tick
+   of a coarse file system clock leaves all of these unchanged. *)
+let cache_enabled = Atomic.make false
+let enable_cache () = Atomic.set cache_enabled true
+
+let recently_modified_seconds = 2.
+
+(* Bytes of interface files a domain keeps at most: the runtime's are about
+   1.5 MB. Past the limit, the domain starts over. *)
+let max_cached_bytes = 16 * 1024 * 1024
+
+type cache = {
+  entries: (string, (int * int * int * float) * Cmi_format.cmi_infos) Hashtbl.t;
+  mutable cached_bytes: int;
+}
+
+let cache =
+  Domain.DLS.new_key (fun () -> {entries = Hashtbl.create 64; cached_bytes = 0})
+
+let read_cmi_channel filename path descriptor channel =
+  if not (Atomic.get cache_enabled) then
+    Cmi_format.read_cmi_channel filename channel
+  else
+    let {Unix.st_dev; st_ino; st_size; st_mtime} = Unix.fstat descriptor in
+    if Unix.gettimeofday () -. st_mtime < recently_modified_seconds then
+      Cmi_format.read_cmi_channel filename channel
+    else
+      let file_id = (st_dev, st_ino, st_size, st_mtime) in
+      let cache = Domain.DLS.get cache in
+      match Hashtbl.find_opt cache.entries path with
+      | Some (cached_id, cmi) when cached_id = file_id -> cmi
+      | previous ->
+        let cmi = Cmi_format.read_cmi_channel filename channel in
+        (match previous with
+        | Some ((_, _, size, _), _) ->
+          cache.cached_bytes <- cache.cached_bytes - size
+        | None -> ());
+        if cache.cached_bytes + st_size > max_cached_bytes then (
+          Hashtbl.reset cache.entries;
+          cache.cached_bytes <- 0);
+        Hashtbl.replace cache.entries path (file_id, cmi);
+        cache.cached_bytes <- cache.cached_bytes + st_size;
+        cmi
+
 let load_cmi ~unit_name : Env.Persistent_signature.t option =
   (* On case-insensitive filesystems a lowercase alias can remain visible to
      [Sys.file_exists] briefly after its CMI is removed. Open each candidate
@@ -41,7 +94,7 @@ let load_cmi ~unit_name : Env.Persistent_signature.t option =
             let channel = Unix.in_channel_of_descr descriptor in
             let cmi =
               Fun.protect
-                (fun () -> Cmi_format.read_cmi_channel filename channel)
+                (fun () -> read_cmi_channel filename path descriptor channel)
                 ~finally:(fun () -> close_in_noerr channel)
             in
             Some Env.Persistent_signature.{filename; cmi}
@@ -53,3 +106,7 @@ let load_cmi ~unit_name : Env.Persistent_signature.t option =
       try_names (if lower_name = name then [name] else [lower_name; name])
   in
   find (Config.get_load_path ())
+
+module For_test = struct
+  let cached_interfaces () = Hashtbl.length (Domain.DLS.get cache).entries
+end

rewatch-ocaml/compiler_process.ml

@@ -10,6 +10,9 @@ let retain_critical_external_warnings stderr =
 
 let build_identity = Rescript_compiler_driver.build_identity
 
+(* Later modules compiled on a domain reuse the interfaces earlier ones read. *)
+let () = Bs_cmi_load.enable_cache ()
+
 type request = {args: string list; cwd: string}
 
 let compiler_phase args =

tests/ounit_tests/ounit_compiler_request_tests.ml

@@ -1200,6 +1200,34 @@ let ctype_memo_reset_tests _context =
         (Ctype.For_test.previous_env_is_empty ())
         "the expansion environment does not outlive its request")
 
+(* Requests reuse interfaces read by earlier ones while their files are
+   unchanged. *)
+let cmi_read_cache_tests _context =
+  Bs_cmi_load.enable_cache ();
+  with_temp_dir "rewatch-driver-cmi-cache-" (fun root ->
+      let compile input = snd (run root ~extra:["-I"; root] input) in
+      let lib_cmi = Filename.concat root "Lib.cmi" in
+      let age seconds =
+        let time = Unix.gettimeofday () -. seconds in
+        Unix.utimes lib_cmi time time
+      in
+      let cached = Bs_cmi_load.For_test.cached_interfaces in
+      write root "Lib.res" "type t = int\n";
+      expect_code 0 (compile "Lib.res");
+      write root "Use.res" "let value: Lib.t = 1\n";
+      let before = cached () in
+      expect_code 0 (compile "Use.res");
+      check (cached () = before) "a just-written interface is not kept";
+      age 60.;
+      expect_code 0 (compile "Use.res");
+      check (cached () = before + 1) "an older interface is kept";
+      expect_code 0 (compile "Use.res");
+      (* The same size, so only the file's time tells it changed. *)
+      write root "Lib.res" "type u = int\n";
+      expect_code 0 (compile "Lib.res");
+      age 30.;
+      expect_code 2 (compile "Use.res"))
+
 let package_and_load_path_isolation_tests _context =
   with_temp_dir "rewatch-driver-load-roots-" (fun root ->
       let first = Filename.concat root "first" in
@@ -1560,6 +1588,7 @@ let suites =
          "ctype_level_isolation" >:: ctype_level_isolation_tests;
          "free_variable_isolation" >:: free_variable_isolation_tests;
          "ctype_memo_reset" >:: ctype_memo_reset_tests;
+         "cmi_read_cache" >:: cmi_read_cache_tests;
          "shared_type_graph_isolation" >:: shared_type_graph_isolation_tests;
          "dependency_extraction_isolation"
          >:: dependency_extraction_isolation_tests;