Start dependents once a module's interface is final

Why:
    A dependent only needs a module's .cmi to type check, but it waits
    until that module has also produced its lambda, JavaScript, .cmj and
    .cmt. On builds limited by a long dependency chain most job slots sit
    idle on the critical path: a 136 module library gets only 1.6x from 7
    domains.

When a slot would otherwise idle, a module can now start as soon as each
unfinished dependency's interface is final: an implementation without
.resi has computed the .cmi it is about to write (with no pending warning
as error), or an interface file has compiled. The early request reads
those .cmi files from memory and waits at a gate before writing any file
or returning its result. The scheduler adopts it at the point master would
have started it (dependencies complete, module still dirty), so its code
generation sees the dependencies' .cmj files, and artifacts, diagnostics
and compiler.log are unchanged. Otherwise it is abandoned without effects,
together with anything that started on top of it.

A redirected lookup matches directories by identity (device and inode,
or the Windows file id). A lookup that might be another spelling of a
published file, or a directory that can't be identified, waits for
adoption instead of reading the disk. Modules with js-post-build commands
or lowercase .cmi names don't release their dependents early, and with
one domain nothing changes.

Review: Can a dependent see an interface that differs from master's?
It reads the exact bytes the dependency then writes, and it is only
adopted after the dependency completed. If the dependency fails later,
for example in code generation, the dependent is abandoned before it
wrote or reported anything.

Author: JonoPrest

changes/pipeline-dependents-after-interface.polish.md

@@ -0,0 +1 @@
+- Build: start type checking a module as soon as the interfaces of its dependencies are final, instead of waiting for their JavaScript generation, which shortens builds limited by long dependency chains.

compiler/bsc/rescript_compiler_driver.ml

@@ -569,15 +569,15 @@ let start_request () =
   Predef.reset_for_request ();
   Env.reset_initial_for_request ()
 
-let with_fresh_request_states ~cwd action =
+let with_fresh_request_states ?hooks ~cwd action =
   Predef.with_fresh (fun () ->
       Env.with_fresh_initial (fun () ->
           Ident.with_fresh (fun () ->
               Request_local.with_fresh (fun () ->
-                  Compiler_request_state.with_fresh ~cwd action))))
+                  Compiler_request_state.with_fresh ~cwd ?hooks action))))
 
-let run_argv ?run_external ~capture ~cwd argv =
-  with_fresh_request_states ~cwd (fun () ->
+let run_argv ?run_external ?hooks ~capture ~cwd argv =
+  with_fresh_request_states ?hooks ~cwd (fun () ->
       start_request ();
       Cmt_format.set_args argv;
       let execute () =
@@ -635,8 +635,12 @@ let run_argv ?run_external ~capture ~cwd argv =
         in
         {exit_code; stdout = ""; stderr = ""})
 
-let run_request ~run_external ~cwd ~argv ~input =
+let run_request_with_hooks ~hooks ~run_external ~cwd ~argv ~input =
   let logical_argv = Array.of_list ("bsc" :: (argv @ [input])) in
-  run_argv ?run_external ~capture:true ~cwd logical_argv
+  run_argv ?run_external ~hooks ~capture:true ~cwd logical_argv
+
+let run_request ~run_external ~cwd ~argv ~input =
+  run_request_with_hooks ~hooks:Compiler_request_state.no_hooks ~run_external
+    ~cwd ~argv ~input
 
 let run argv = (run_argv ~capture:false ~cwd:(Sys.getcwd ()) argv).exit_code

compiler/bsc/rescript_compiler_driver.mli

@@ -24,6 +24,16 @@ val run_request :
     I/O against [cwd] without changing the process working directory. Request
     state is restored on success and failure. *)
 
+val run_request_with_hooks :
+  hooks:Compiler_request_state.hooks ->
+  run_external:(string -> int * string * string) option ->
+  cwd:string ->
+  argv:string list ->
+  input:string ->
+  result
+(** {!run_request} with build-system callbacks attached to the request; see
+    {!Compiler_request_state.hooks}. *)
+
 val run : string array -> int
 (** Command-line entry point of the standalone [bsc]. It writes to the process's
     stdout and stderr as it goes. *)

compiler/core/bs_cmi_load.ml

@@ -29,15 +29,20 @@ let load_cmi ~unit_name : Env.Persistent_signature.t option =
   Misc.find_map_in_path_uncap (Config.get_load_path ()) (unit_name ^ ".cmi")
     (fun filename ->
       let path = Compiler_request_state.resolve_path filename in
-      match Unix.openfile path [Unix.O_RDONLY; Unix.O_CLOEXEC] 0 with
-      | descriptor ->
-        let channel = Unix.in_channel_of_descr descriptor in
-        let cmi =
-          Fun.protect
-            (fun () -> Cmi_format.read_cmi_channel filename channel)
-            ~finally:(fun () -> close_in_noerr channel)
-        in
+      match Compiler_request_state.redirect_cmi path with
+      | Some bytes ->
+        let cmi = Cmi_format.read_cmi_string filename bytes in
         Some Env.Persistent_signature.{filename; cmi}
-      | exception Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) -> None
-      | exception Unix.Unix_error (error, _, _) ->
-        raise (Sys_error (path ^ ": " ^ Unix.error_message error)))
+      | None -> (
+        match Unix.openfile path [Unix.O_RDONLY; Unix.O_CLOEXEC] 0 with
+        | descriptor ->
+          let channel = Unix.in_channel_of_descr descriptor in
+          let cmi =
+            Fun.protect
+              (fun () -> Cmi_format.read_cmi_channel filename channel)
+              ~finally:(fun () -> close_in_noerr channel)
+          in
+          Some Env.Persistent_signature.{filename; cmi}
+        | exception Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) -> None
+        | exception Unix.Unix_error (error, _, _) ->
+          raise (Sys_error (path ^ ": " ^ Unix.error_message error))))

compiler/ext/compiler_request_state.ml

@@ -1,5 +1,19 @@
+type hooks = {
+  before_artifact_write: unit -> unit;
+  interface_computed: string -> (unit -> string) -> unit;
+  redirect_cmi: string -> string option;
+}
+
+let no_hooks =
+  {
+    before_artifact_write = ignore;
+    interface_computed = (fun _ _ -> ());
+    redirect_cmi = (fun _ -> None);
+  }
+
 type t = {
   active: bool;
+  hooks: hooks;
   cwd: string;
   mutable input_name: string;
   mutable command_runner: string -> int;
@@ -16,9 +30,10 @@ type t = {
   mutable load_path: string list;
 }
 
-let create ~active cwd =
+let create ?(hooks = no_hooks) ~active cwd =
   {
     active;
+    hooks;
     cwd;
     input_name = "_none_";
     command_runner = Sys.command;
@@ -47,13 +62,18 @@ let resolve_path path =
     Filename.concat state.cwd path
   else path
 
-let with_fresh ?cwd:requested_cwd action =
+let before_artifact_write () = (current ()).hooks.before_artifact_write ()
+let interface_computed path bytes =
+  (current ()).hooks.interface_computed path bytes
+let redirect_cmi path = (current ()).hooks.redirect_cmi path
+
+let with_fresh ?cwd:requested_cwd ?hooks action =
   let previous = current () in
   let cwd =
     match requested_cwd with
     | None -> cwd ()
     | Some path when Filename.is_relative path -> Filename.concat (cwd ()) path
     | Some path -> path
   in
-  Domain.DLS.set key (create ~active:true cwd);
+  Domain.DLS.set key (create ?hooks ~active:true cwd);
   Fun.protect action ~finally:(fun () -> Domain.DLS.set key previous)

compiler/ext/compiler_request_state.mli

@@ -1,5 +1,24 @@
+type hooks = {
+  before_artifact_write: unit -> unit;
+      (** Called before the request writes its first compiled artifact (.cmi,
+          .cmt, .cmti). A build system that starts a request before its
+          dependencies have finished uses it to wait for them; it may raise to
+          abandon the request before anything is written. *)
+  interface_computed: string -> (unit -> string) -> unit;
+      (** Called with the path of a .cmi the request is about to write, and a
+          function giving the file's bytes, when no error is pending. Called
+          before {!before_artifact_write}. *)
+  redirect_cmi: string -> string option;
+      (** The bytes to read instead of the .cmi file at a resolved candidate
+          path. The name the compiler records stays the candidate's. *)
+}
+(** Callbacks a build system attaches to one in-process request. *)
+
+val no_hooks : hooks
+
 type t = {
   active: bool;
+  hooks: hooks;
   cwd: string;
   mutable input_name: string;
   mutable command_runner: string -> int;
@@ -27,5 +46,9 @@ val resolve_path : string -> string
 (** Resolve a relative file path against the active request root. Outside a
     request, preserve the path so ordinary process-relative I/O is unchanged. *)
 
-val with_fresh : ?cwd:string -> (unit -> 'a) -> 'a
+val before_artifact_write : unit -> unit
+val interface_computed : string -> (unit -> string) -> unit
+val redirect_cmi : string -> string option
+
+val with_fresh : ?cwd:string -> ?hooks:hooks -> (unit -> 'a) -> 'a
 (** Run with new request state and restore the prior state on success or failure. *)

compiler/ext/warnings.mli

@@ -88,6 +88,9 @@ exception Errors
 
 val check_fatal : unit -> unit
 
+val nerrors : unit -> int
+(** Warnings reported as errors since the last {!check_fatal}. *)
+
 val reset_fatal : unit -> unit
 
 val help_warnings : unit -> unit

compiler/ml/cmi_format.ml

@@ -38,24 +38,47 @@ let input_cmi ic =
 (* Earlier compilers wrote OCaml-style magic numbers *)
 let legacy_magic_prefix = "Caml1999I"
 
+let check_magic filename buffer =
+  if buffer <> Config.cmi_magic_number then
+    let pre_len = String.length Config.cmi_magic_number - 3 in
+    if
+      String.sub buffer 0 pre_len = String.sub Config.cmi_magic_number 0 pre_len
+    then
+      let msg =
+        if buffer < Config.cmi_magic_number then "an older" else "a newer"
+      in
+      raise (Error (Wrong_version_interface (filename, msg)))
+    else if String.starts_with ~prefix:legacy_magic_prefix buffer then
+      raise (Error (Wrong_version_interface (filename, "an older")))
+    else raise (Error (Not_an_interface filename))
+
+(* The same decoding as [read_cmi_channel], from the bytes of a .cmi file. *)
+let read_cmi_string filename bytes =
+  let magic_length = String.length Config.cmi_magic_number in
+  if String.length bytes < magic_length then
+    raise (Error (Corrupted_interface filename));
+  check_magic filename (String.sub bytes 0 magic_length);
+  let value offset =
+    if offset + Marshal.header_size > String.length bytes then
+      raise (Error (Corrupted_interface filename));
+    let size = Marshal.total_size (Bytes.unsafe_of_string bytes) offset in
+    if offset + size > String.length bytes then
+      raise (Error (Corrupted_interface filename));
+    (Marshal.from_string bytes offset, offset + size)
+  in
+  try
+    let (name, sign), offset = value magic_length in
+    let crcs, offset = value offset in
+    let flags, _ = value offset in
+    {cmi_name = name; cmi_sign = sign; cmi_crcs = crcs; cmi_flags = flags}
+  with Failure _ -> raise (Error (Corrupted_interface filename))
+
 let read_cmi_channel filename ic =
   try
     let buffer =
       really_input_string ic (String.length Config.cmi_magic_number)
     in
-    (if buffer <> Config.cmi_magic_number then
-       let pre_len = String.length Config.cmi_magic_number - 3 in
-       if
-         String.sub buffer 0 pre_len
-         = String.sub Config.cmi_magic_number 0 pre_len
-       then
-         let msg =
-           if buffer < Config.cmi_magic_number then "an older" else "a newer"
-         in
-         raise (Error (Wrong_version_interface (filename, msg)))
-       else if String.starts_with ~prefix:legacy_magic_prefix buffer then
-         raise (Error (Wrong_version_interface (filename, "an older")))
-       else raise (Error (Not_an_interface filename)));
+    check_magic filename buffer;
     let cmi = input_cmi ic in
     cmi
   with End_of_file | Failure _ -> raise (Error (Corrupted_interface filename))
@@ -66,15 +89,31 @@ let read_cmi filename =
     (fun () -> read_cmi_channel filename ic)
     ~finally:(fun () -> close_in_noerr ic)
 
-(* Writes the .cmi file, keeping an existing one with the same contents
-   when [check_exists] is given *)
-let create_cmi ?check_exists filename (cmi : cmi_infos) =
+type prepared = {content: string; crc: Digest.t}
+
+let prepare_cmi (cmi : cmi_infos) =
   (* beware: the provided signature must have been substituted for saving *)
   let content =
     Config.cmi_magic_number ^ Marshal.to_string (cmi.cmi_name, cmi.cmi_sign) []
     (* checkout [output_value] in {!Pervasives} module *)
   in
-  let crc = Digest.string content in
+  {content; crc = Digest.string content}
+
+(* The bytes [create_cmi] leaves in the file. An existing file it keeps has
+   the same bytes: the same content, imports and flags. *)
+let prepared_bytes {content; crc} (cmi : cmi_infos) =
+  content
+  ^ Marshal.to_string ((cmi.cmi_name, Some crc) :: cmi.cmi_crcs) []
+  ^ Marshal.to_string cmi.cmi_flags []
+
+(* Writes the .cmi file, keeping an existing one with the same contents
+   when [check_exists] is given *)
+let create_cmi ?check_exists ?prepared filename (cmi : cmi_infos) =
+  let {content; crc} =
+    match prepared with
+    | Some prepared -> prepared
+    | None -> prepare_cmi cmi
+  in
   let cmi_infos =
     if
       check_exists <> None

compiler/ml/cmi_format.mli

@@ -22,14 +22,27 @@ type cmi_infos = {
   cmi_flags: pers_flags list;
 }
 
-val create_cmi : ?check_exists:unit -> string -> cmi_infos -> Digest.t
+type prepared
+(** A signature marshalled for saving, and its CRC. *)
+
+val prepare_cmi : cmi_infos -> prepared
+
+val prepared_bytes : prepared -> cmi_infos -> string
+(** The bytes of the .cmi file {!create_cmi} leaves for [cmi]. *)
+
+val create_cmi :
+  ?check_exists:unit -> ?prepared:prepared -> string -> cmi_infos -> Digest.t
 
 (* read the cmi information (the magic is supposed to have already been read) *)
 val input_cmi : in_channel -> cmi_infos
 
 (* read a cmi from a filename, checking the magic *)
 val read_cmi : string -> cmi_infos
 val read_cmi_channel : string -> in_channel -> cmi_infos
+
+val read_cmi_string : string -> string -> cmi_infos
+(** [read_cmi_string filename bytes] decodes the bytes of a .cmi file like
+    {!read_cmi_channel}; [filename] names it in errors. *)
 (* Parse an already opened CMI. The caller retains ownership of the channel. *)
 
 (* Error report *)

compiler/ml/cmt_format.ml

@@ -3,6 +3,7 @@ include Cmt_format_common
 let set_args = Cmt_format_persistence.set_args
 
 let save_cmt filename modname binary_annots sourcefile initial_env =
+  Compiler_request_state.before_artifact_write ();
   Cmt_format_persistence.save_cmt filename modname binary_annots sourcefile
     initial_env;
   clear ()