Reuse compiler signatures and runtime CMIs in OCaml rewatch

CHANGELOG.md

@@ -28,6 +28,8 @@
 
 #### :nail_care: Polish
 
+- Speed up OCaml rewatch builds that repeatedly open large signatures by reusing verified expanded signature graphs per compiler worker. https://github.com/rescript-lang/rescript/pull/8673
+- Reuse decoded standard-library interfaces and share prepared signature images across OCaml rewatch workers for faster clean builds. https://github.com/rescript-lang/rescript/pull/8673
 - Avoid running `rescript-schema-ppx` and `sury-ppx` on source files without an `@schema` annotation. https://github.com/rescript-lang/rescript/pull/8662
 
 #### :house: Internal

compiler/bsc/rescript_compiler_driver.ml

@@ -600,10 +600,15 @@ let with_fresh_request_states ~cwd action =
                                                       Compiler_request_state
                                                       .with_fresh ~cwd action)))))))))))))
 
+let with_fresh_request_states_and_snapshot ~cwd action =
+  Fun.protect
+    (fun () -> with_fresh_request_states ~cwd action)
+    ~finally:Env.finalize_expanded_snapshot_cache
+
 let run_argv ?run_external ~cwd argv =
   let input = argv.(Array.length argv - 1) in
   Compiler_phase_trace.request ~cwd ~input (fun () ->
-      with_fresh_request_states ~cwd (fun () ->
+      with_fresh_request_states_and_snapshot ~cwd (fun () ->
           Compiler_phase_trace.section "request.reset" (fun () ->
               reset_state ~new_request:true ());
           Cmt_format.set_args argv;

compiler/ext/compiler_phase_trace.ml

@@ -53,6 +53,11 @@ let dependency name action =
     action ()
   | _ -> section name action
 
+let dependency_lazy name action =
+  match Domain.DLS.get state_key with
+  | None -> action ()
+  | Some _ -> dependency (name ()) action
+
 let open_signature action =
   match Domain.DLS.get state_key with
   | Some {phase = "setup.initial_env"; _} -> section "setup.open" action

compiler/ext/ident.ml

@@ -15,18 +15,23 @@
 
 open Format
 
-type t = {stamp: int; name: string; mutable flags: int}
+type t = {mutable stamp: int; name: string; mutable flags: int}
 
 let[@inlnie] max (x : int) y = if x >= y then x else y
 let global_flag = 1
 let predef_exn_flag = 2
 
 (* A stamp of 0 denotes a persistent identifier *)
 
-type counter_state = {mutable currentstamp: int; mutable reinit_level: int}
+type counter_state = {
+  mutable currentstamp: int;
+  mutable reinit_level: int;
+  mutable allocation_capture: t list ref option;
+}
 
 let counter_key =
-  Domain.DLS.new_key (fun () -> {currentstamp = 0; reinit_level = -1})
+  Domain.DLS.new_key (fun () ->
+      {currentstamp = 0; reinit_level = -1; allocation_capture = None})
 
 let counter () = Domain.DLS.get counter_key
 
@@ -44,25 +49,41 @@ let with_fresh action =
     | Some baseline -> baseline
     | None -> previous.currentstamp
   in
-  Domain.DLS.set counter_key {currentstamp = baseline; reinit_level = baseline};
+  Domain.DLS.set counter_key
+    {
+      currentstamp = baseline;
+      reinit_level = baseline;
+      allocation_capture = None;
+    };
   Fun.protect action ~finally:(fun () -> Domain.DLS.set counter_key previous)
 
+let record_allocation state id =
+  match state.allocation_capture with
+  | Some captured -> captured := id :: !captured
+  | None -> ()
+
 let create s =
   let state = counter () in
   state.currentstamp <- state.currentstamp + 1;
-  {name = s; stamp = state.currentstamp; flags = 0}
+  let id = {name = s; stamp = state.currentstamp; flags = 0} in
+  record_allocation state id;
+  id
 
 let create_predef_exn s =
   let state = counter () in
   state.currentstamp <- state.currentstamp + 1;
-  {name = s; stamp = state.currentstamp; flags = predef_exn_flag}
+  let id = {name = s; stamp = state.currentstamp; flags = predef_exn_flag} in
+  record_allocation state id;
+  id
 
 let create_persistent s = {name = s; stamp = 0; flags = global_flag}
 
 let rename i =
   let state = counter () in
   state.currentstamp <- state.currentstamp + 1;
-  {i with stamp = state.currentstamp}
+  let id = {i with stamp = state.currentstamp} in
+  record_allocation state id;
+  id
 
 let name i = i.name
 
@@ -80,6 +101,20 @@ let same ({stamp; name} : t) i2 =
 let binding_time i = i.stamp
 
 let current_time () = (counter ()).currentstamp
+let with_allocation_capture action =
+  let state = counter () in
+  let previous = state.allocation_capture in
+  let captured = ref [] in
+  state.allocation_capture <- Some captured;
+  Fun.protect
+    (fun () ->
+      let result = action () in
+      (result, Array.of_list (List.rev !captured)))
+    ~finally:(fun () ->
+      state.allocation_capture <- previous;
+      match previous with
+      | Some outer -> outer := !captured @ !outer
+      | None -> ())
 let set_current_time t =
   let state = counter () in
   state.currentstamp <- max state.currentstamp t

compiler/ext/ident.mli

@@ -15,7 +15,9 @@
 
 (* Identifiers (unique names) *)
 
-type t = {stamp: int; name: string; mutable flags: int}
+type t = {mutable stamp: int; name: string; mutable flags: int}
+(** [stamp] may be relocated only on a private, freshly deserialized
+    dependency graph before the identifier becomes visible to typing. *)
 
 include Identifiable.S with type t := t
 (* Notes:
@@ -52,6 +54,10 @@ val is_predef_exn : t -> bool
 
 val binding_time : t -> int
 val current_time : unit -> int
+
+(* Record fresh identifiers made during [action]. Nested captures also
+   contribute to their outer capture. *)
+val with_allocation_capture : (unit -> 'a) -> 'a * t array
 val set_current_time : int -> unit
 val reinit : unit -> unit
 

compiler/ml/btype.ml

@@ -41,6 +41,22 @@ let pivot_level = (2 * lowest_level) - 1
 
 (**** Some type creators ****)
 
+let allocation_capture_key = Domain.DLS.new_key (fun () -> None)
+
+let with_allocation_capture action =
+  let previous = Domain.DLS.get allocation_capture_key in
+  let captured = ref [] in
+  Domain.DLS.set allocation_capture_key (Some captured);
+  Fun.protect
+    (fun () ->
+      let result = action () in
+      (result, Array.of_list (List.rev !captured)))
+    ~finally:(fun () ->
+      Domain.DLS.set allocation_capture_key previous;
+      match previous with
+      | Some outer -> outer := !captured @ !outer
+      | None -> ())
+
 let reinit () =
   let state = Compiler_request_state.current () in
   match state.type_node_reset_id with
@@ -50,7 +66,11 @@ let reinit () =
 let newty2 level desc =
   let state = Compiler_request_state.current () in
   state.type_node_id <- state.type_node_id + 1;
-  {desc; level; id = state.type_node_id}
+  let ty = {desc; level; id = state.type_node_id} in
+  (match Domain.DLS.get allocation_capture_key with
+  | Some captured -> captured := ty :: !captured
+  | None -> ());
+  ty
 let newgenty desc = newty2 generic_level desc
 let newgenvar ?name () = newgenty (Tvar name)
 (*

compiler/ml/btype.mli

@@ -31,6 +31,10 @@ val generic_level : int
 val newty2 : int -> type_desc -> type_expr
 (* Create a type *)
 
+val with_allocation_capture : (unit -> 'a) -> 'a * type_expr array
+(** Record fresh type nodes created by [newty2] during [action]. Nested
+    captures also contribute to their outer capture. *)
+
 val newgenty : type_desc -> type_expr
 (* Create a generic type *)