Start dependents once a module's interface is final in OCaml rewatch

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

@@ -164,7 +164,10 @@ let anonymous ~(rev_args : string list) =
           process_file filename (ppf ()))
     else Bsc_args.bad_arg "can not handle multiple files"
 
+(* Immediate actions of the command line write files: a request started
+   early waits for the build system first. *)
 let format_file input =
+  Compiler_request_state.before_effect ();
   let ext =
     Ext_file_extensions.classify_input (Ext_filename.get_extension_maybe input)
   in
@@ -189,6 +192,7 @@ let set_color_option option =
    directory under the process's working directory, while a request resolves
    relative paths against its own. *)
 let eval (s : string) ~suffix =
+  Compiler_request_state.before_effect ();
   let tmpfile = Filename.temp_file "eval" suffix in
   let tmpfile =
     if Filename.is_relative tmpfile then Filename.concat (Sys.getcwd ()) tmpfile
@@ -581,16 +585,16 @@ let leave_cached_interfaces_clean action =
     Bs_cmi_load.discard_cached_cmis ();
     raise exn
 
-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 (fun () ->
+                  Compiler_request_state.with_fresh ~cwd ?hooks (fun () ->
                       leave_cached_interfaces_clean 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 ();
       let execute () =
         try
@@ -647,8 +651,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

@@ -99,7 +99,14 @@ 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 Build_file_store.read path with
+      (* A build system that starts a request before a dependency has
+         published its interface hands over that interface's contents. *)
+      let contents =
+        match Compiler_request_state.redirect_cmi path with
+        | Some _ as contents -> contents
+        | None -> Build_file_store.read path
+      in
+      match contents with
       | None -> None
       | Some contents ->
         let cmi =

compiler/core/cmd_ppx_apply.ml

@@ -78,6 +78,8 @@ let read_ast (type a) (kind : a Ml_binary.kind) fn : Ml_binary.ast0 =
     are stored as [-ppx3; -ppx2; -ppx1]
     [fold_right] happens to process the first one *)
 let rewrite kind ppxs ast =
+  (* A request started early waits before it writes the AST for the PPXs. *)
+  Compiler_request_state.before_effect ();
   (* Remove the temporary files also when a PPX fails or the build is
      interrupted, since the compiler can run inside a long-lived process. *)
   let temp_files = ref [] in

compiler/depends/binary_ast.ml

@@ -71,6 +71,7 @@ let read_ast_exn (type t) ~fname (_ : t kind) : t =
 *)
 let write_ast (type t) ~(sourcefile : string) ~output (kind : t kind) (pt : t) :
     unit =
+  Compiler_request_state.before_effect ();
   let output_set = Ast_extract.read_parse_and_extract kind pt in
   let buf = Ext_buffer.create 1000 in
   Ext_buffer.add_char buf magic_sep_char;

compiler/ext/build_file_store.ml

@@ -6,8 +6,11 @@
 
    Within a build, a file is read only after the request that writes it has
    finished, because the build system orders requests by their dependencies.
-   So an entry changes only when it is written through the store, and the
-   store is emptied before each build. *)
+   A request it starts before then gets the interfaces not yet written from
+   the build system instead (see [Compiler_request_state.redirect_cmi]): the
+   same strings that are then written through the store, held or not. So an
+   entry changes only when it is written through the store, and the store is
+   emptied before each build. *)
 
 (* What the disk holds for a path, as far as the build has read it. *)
 type on_disk = Read of string | Missing | Unknown

compiler/ext/build_file_store.mli

@@ -22,6 +22,10 @@ val generation : unit -> int
 (** Changes whenever the store is emptied, so caches derived from its contents
     know to start over. *)
 
+val key : string -> string
+(** [key path] names the entry of [path]: [path] with [.] and [..] segments
+    removed lexically, so that two spellings of one build file share it. *)
+
 val read : ?keep:bool -> string -> string option
 (** [read path] is the contents of [path], or [None] when it does not exist.
     Other failures raise [Sys_error]. Contents read from disk are kept for

compiler/ext/compiler_request_state.ml

@@ -1,5 +1,19 @@
+type hooks = {
+  before_effect: unit -> unit;
+  interface_computed: (string -> string -> unit) option;
+  redirect_cmi: string -> string option;
+}
+
+let no_hooks =
+  {
+    before_effect = ignore;
+    interface_computed = None;
+    redirect_cmi = (fun _ -> None);
+  }
+
 type t = {
   active: bool;
+  hooks: hooks;
   cwd: string;
   mutable input_name: string;
   mutable command_runner: string -> int;
@@ -15,9 +29,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;
@@ -45,13 +60,17 @@ let resolve_path path =
     Filename.concat state.cwd path
   else path
 
-let with_fresh ?cwd:requested_cwd action =
+let before_effect () = (current ()).hooks.before_effect ()
+let interface_computed () = (current ()).hooks.interface_computed
+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,25 @@
+type hooks = {
+  before_effect: unit -> unit;
+      (** Called before the request writes a file (such as an .ast, .cmi,
+          .cmt or .cmti) or runs a command. 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 any effect. *)
+  interface_computed: (string -> string -> unit) option;
+      (** Called with the path of a .cmi the request is about to write, and
+          the file's contents, when no error is pending. Called before
+          {!before_effect}. [None] when nothing reads the contents, so that
+          the request only builds them to write the file. *)
+  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;
@@ -26,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_effect : unit -> unit
+val interface_computed : unit -> (string -> string -> unit) option
+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/ccomp.ml

@@ -5,6 +5,7 @@ let with_command_runner runner action =
   Fun.protect action ~finally:(fun () -> state.command_runner <- previous)
 
 let command cmdline =
+  Compiler_request_state.before_effect ();
   if !((Clflags.current ()).verbose) then (
     Compiler_request_output.write_stderr "+ ";
     Compiler_request_output.print_stderr cmdline);

compiler/ml/cmi_format.ml

@@ -75,15 +75,35 @@ let read_cmi filename =
          (Compiler_request_state.resolve_path filename
          ^ ": No such file or directory"))
 
+(* The signature part of the .cmi file for [cmi], whose digest is its CRC. *)
+let signature_contents (cmi : cmi_infos) =
+  (* beware: the provided signature must have been substituted for saving;
+     checkout [output_value] in {!Pervasives} module *)
+  Config.cmi_magic_number ^ Marshal.to_string (cmi.cmi_name, cmi.cmi_sign) []
+
+let file_contents (cmi : cmi_infos) signature crc =
+  let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in
+  String.concat ""
+    [signature; Marshal.to_string crcs []; Marshal.to_string cmi.cmi_flags []]
+
+(* The contents of the .cmi file for [cmi], and its CRC. *)
+let cmi_contents (cmi : cmi_infos) =
+  let signature = signature_contents cmi in
+  let crc = Digest.string signature in
+  (file_contents cmi signature crc, crc)
+
 (* 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) =
-  (* 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 *)
+let create_cmi ?check_exists ?contents filename (cmi : cmi_infos) =
+  (* Without [contents], the whole file is only built when it is written. *)
+  let contents, crc =
+    match contents with
+    | Some (contents, crc) -> (lazy contents, crc)
+    | None ->
+      let signature = signature_contents cmi in
+      let crc = Digest.string signature in
+      (lazy (file_contents cmi signature crc), crc)
   in
-  let crc = Digest.string content in
   let cmi_infos =
     if check_exists = None then None
     else
@@ -109,13 +129,9 @@ let create_cmi ?check_exists filename (cmi : cmi_infos) =
          && cmi_flags = cmi.cmi_flags ->
     crc
   | _ ->
-    let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in
     Build_file_store.write
       (Compiler_request_state.resolve_path filename)
-      (String.concat ""
-         [
-           content; Marshal.to_string crcs []; Marshal.to_string cmi.cmi_flags [];
-         ]);
+      (Lazy.force contents);
     crc
 
 (* Error report *)

compiler/ml/cmi_format.mli

@@ -22,7 +22,17 @@ type cmi_infos = {
   cmi_flags: pers_flags list;
 }
 
-val create_cmi : ?check_exists:unit -> string -> cmi_infos -> Digest.t
+val cmi_contents : cmi_infos -> string * Digest.t
+(** The contents of the .cmi file for an interface, and its CRC. *)
+
+val create_cmi :
+  ?check_exists:unit ->
+  ?contents:string * Digest.t ->
+  string ->
+  cmi_infos ->
+  Digest.t
+(** [create_cmi filename cmi] writes [cmi] to [filename] and returns its CRC.
+    [contents] is [cmi_contents cmi], when the caller computed it. *)
 
 (* read the cmi information (the magic is supposed to have already been read) *)
 

compiler/ml/cmt_format.ml

@@ -1,5 +1,6 @@
 include Cmt_format_common
 
 let save_cmt filename modname binary_annots sourcefile =
+  Compiler_request_state.before_effect ();
   Cmt_format_persistence.save_cmt filename modname binary_annots sourcefile;
   clear ()

compiler/ml/env.ml

@@ -1824,11 +1824,25 @@ let save_signature_with_imports ?check_exists ~deprecated sg modname filename
     | Some s -> [Deprecated s]
     | None -> []
   in
+  let cmi =
+    {cmi_name = modname; cmi_sign = sg; cmi_crcs = imports; cmi_flags = flags}
+  in
+  (* The interface is final here. A build system may let dependents type
+     check against it while this request waits to write it. A warning already
+     reported as an error fails the request, so it keeps the interface back.
+     Without a listener the contents are only built to write the file, which
+     an unchanged interface with [check_exists] skips. *)
+  let contents =
+    match Compiler_request_state.interface_computed () with
+    | Some computed when Warnings.nerrors () = 0 ->
+      let ((bytes, _) as contents) = Cmi_format.cmi_contents cmi in
+      computed filename bytes;
+      Some contents
+    | Some _ | None -> None
+  in
+  Compiler_request_state.before_effect ();
   try
-    let cmi =
-      {cmi_name = modname; cmi_sign = sg; cmi_crcs = imports; cmi_flags = flags}
-    in
-    let crc = create_cmi ?check_exists filename cmi in
+    let crc = create_cmi ?check_exists ?contents filename cmi in
     (* Enter signature in persistent table so that imports ()
        will also return its crc *)
     let comps =

rewatch-ocaml/README.md

@@ -110,6 +110,24 @@ going to the process's stdout and stderr. The compiler build identity is
 derived from the compiler sources, so compiler changes clean the build while
 rewatch-only changes don't.
 
+When no ready module can take a free job slot, a module can start before its
+dependencies have finished: as soon as each unfinished dependency's interface
+is final. That is when the implementation of a module without an interface
+file has computed the `.cmi` it is about to write, or when an interface file
+has compiled. The early request reads those not yet published `.cmi` files
+from memory. It keeps its job slot while it waits, before it writes any file,
+held or not, runs any command or reports any result, until the scheduler
+would have started it anyway: its dependencies have completed and it still needs
+compiling. Otherwise it is abandoned without effects, as are early requests
+that depend on it. Code generation therefore always sees the `.cmj` of
+completed dependencies, and artifacts, diagnostics and `compiler.log` are
+those of a build without pipelining. A module with `js-post-build` commands
+does not release its dependents early. Held writes alone would not keep an
+early request without effects: the build file store is shared by the
+build's requests, and an abandoned request may still run beside the request
+that replaces it. `REWATCH_SPECULATION_LOG` names a file to which tests append
+each early start, adoption and abandonment.
+
 External PPXs, `js-post-build` hooks, and `--after-build` remain subprocesses
 under the process owners described below.
 

rewatch-ocaml/compile_assets.ml

@@ -130,6 +130,11 @@ let create directories =
         state_entries);
   state
 
+let directories state =
+  Hashtbl.fold
+    (fun directory _ directories -> directory :: directories)
+    state.files_by_directory []
+
 let files state directory =
   Hashtbl.find_opt state.files_by_directory directory
   |> Option.value ~default:[]

rewatch-ocaml/compile_assets.mli

@@ -11,6 +11,10 @@ val is_managed_basename : string -> bool
     which cleanup removes when no current module expects them. *)
 
 val create : string list -> t
+
+val directories : t -> string list
+(** The directories indexed, in which the build publishes interfaces. *)
+
 val files : t -> string -> string list
 val ast_sources : t -> string -> ast_source list
 val ast_dependencies : t -> string -> string list