Let a build system start a request before its dependencies publish

Why:
    A dependent only needs a module's .cmi to type check, but a build
    system that runs requests in process can only start it after that
    module has also produced its lambda, JavaScript, .cmj and .cmt.

A request now takes hooks from the build system. interface_computed
receives the contents of the .cmi an implementation is about to write,
once no warning reported as an error is pending; the contents are
computed once (Cmi_format.cmi_contents) and also written. redirect_cmi
hands Bs_cmi_load the contents of a .cmi that is not published yet,
which it reads instead of the build file store; the store never sees
them. before_effect is called before the
request writes a .cmi, .cmt, .cmti, binary AST or a PPX's input, runs
a command such as a PPX, or takes a command line action that writes a file (-e,
-format); a build system that started the request early waits there,
or raises to abandon it before any effect. Build_file_store.key is
exported so that a build system matches paths as the store does. bsc
attaches no hooks and behaves as before.

Review: Can a redirected interface reach a later request through the
store or the decoded interface cache? Only as the same bytes. The
dependency writes the very string it announced through the store, and
publishing copies it, so a domain's cache may reuse an interface it
decoded from the redirect for the published file. A request that is
abandoned or fails drops its domain's cache.

Signed-off-by: Jono Prest <jjprest@gmail.com>

Author: JonoPrest

compiler/bsc/rescript_compiler_driver.ml

@@ -167,7 +167,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
@@ -192,6 +195,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
@@ -584,16 +588,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 ();
       Cmt_format.set_args argv;
       let execute () =
@@ -651,8 +655,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

@@ -93,7 +93,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. So an entry changes
+   only when it is written through the store, and the store is emptied before
+   each build. *)
 
 type entry =
   | Contents of string

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 : string -> string option
 (** [read path] is the contents of [path], or [None] when it does not exist.
     Other failures raise [Sys_error]. *)

compiler/ext/compiler_request_state.ml

@@ -1,5 +1,19 @@
+type hooks = {
+  before_effect: unit -> unit;
+  interface_computed: string -> string -> unit;
+  redirect_cmi: string -> string option;
+}
+
+let no_hooks =
+  {
+    before_effect = 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_effect () = (current ()).hooks.before_effect ()
+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_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;
+      (** 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}. *)
+  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_effect : unit -> unit
+val interface_computed : string -> 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