Move build run ids into dune_engine

bin/build.ml

@@ -1,7 +1,8 @@
 open Import
 
-let run_build_system ~request =
+let run_build_system ~run_id ~request =
   Dune_engine.Build_system.run_action_builder
+    ~run_id
     (let open Action_builder.O in
      Action_builder.of_memo (Util.setup ()) >>= request)
 ;;
@@ -16,17 +17,20 @@ let poll_handling_rpc_build_requests ~(common : Common.t) =
   Dune_engine.Build_loop.poll_passive
     ~get_build_request:
       (let+ { kind; outcome } = Dune_rpc_impl.Server.pending_action rpc in
-       let request setup =
-         let root = Common.root common in
-         match kind with
-         | Build targets -> Target.interpret_targets (Common.root common) setup targets
-         | Runtest test_paths ->
-           Runtest_common.make_request
-             ~scontexts:setup.scontexts
-             ~to_cwd:root.to_cwd
-             ~test_paths
-       in
-       run_build_system ~request, outcome)
+       ( (fun ~run_id ->
+           let request setup =
+             let root = Common.root common in
+             match kind with
+             | Build targets ->
+               Target.interpret_targets (Common.root common) setup targets
+             | Runtest test_paths ->
+               Runtest_common.make_request
+                 ~scontexts:setup.scontexts
+                 ~to_cwd:root.to_cwd
+                 ~test_paths
+           in
+           run_build_system ~run_id ~request)
+       , outcome ))
 ;;
 
 let run_build_command_poll_eager ~(common : Common.t) ~config ~request : unit =
@@ -36,9 +40,10 @@ let run_build_command_poll_eager ~(common : Common.t) ~config ~request : unit =
     (fun () ->
        let open Fiber.O in
        (* Run two fibers concurrently. One is responible for rebuilding targets
-       named on the command line in reaction to file system changes. The other
-       is responsible for building targets named in RPC build requests. *)
-       let+ () = Dune_engine.Build_loop.poll (run_build_system ~request)
+          named on the command line in reaction to file system changes. The other
+          is responsible for building targets named in RPC build requests. *)
+       let+ () =
+         Dune_engine.Build_loop.poll (fun ~run_id -> run_build_system ~run_id ~request)
        and+ () = poll_handling_rpc_build_requests ~common in
        ())
 ;;
@@ -55,7 +60,7 @@ let run_build_command_poll_passive ~common ~config ~request:_ : unit =
 let run_build_command_once ~(common : Common.t) ~config ~request =
   let open Fiber.O in
   let once () =
-    run_build_system ~request
+    run_build_system ~run_id:Dune_engine.Run_id.Batch ~request
     >>| function
     | Error `Already_reported -> raise Dune_util.Report_error.Already_reported
     | Ok () -> ()

bin/build.mli

@@ -1,7 +1,8 @@
 open Import
 
 val run_build_system
-  :  request:(Dune_rules.Main.build_system -> unit Action_builder.t)
+  :  run_id:Dune_engine.Run_id.t
+  -> request:(Dune_rules.Main.build_system -> unit Action_builder.t)
   -> (unit, [ `Already_reported ]) result Fiber.t
 
 val build : unit Cmd.t

bin/describe/aliases_targets.ml

@@ -88,7 +88,8 @@ let ls_term (fetch_results : Path.Build.t -> string list Action_builder.t) =
   Scheduler_setup.go_with_rpc_server ~common ~config
   @@ fun () ->
   let open Fiber.O in
-  Build.run_build_system ~request >>| fun (_ : (unit, [ `Already_reported ]) result) -> ()
+  Build.run_build_system ~run_id:Dune_engine.Run_id.Batch ~request
+  >>| fun (_ : (unit, [ `Already_reported ]) result) -> ()
 ;;
 
 module Aliases_cmd = struct

bin/exec.ml

@@ -287,10 +287,11 @@ let exec_building_directly ~common ~config ~context ~prog ~args ~no_rebuild =
     let open Fiber.O in
     let on_exit = Console.printf "Program exited with code [%d]" in
     Dune_engine.Build_loop.poll
-    @@
+    @@ fun ~run_id ->
     let* () = Fiber.return () in
     Console.maybe_clear_screen ~details_hum:[];
-    Build.build_memo @@ step ~prog ~args ~common ~no_rebuild ~context ~on_exit
+    Dune_engine.Build_system.run ~run_id
+    @@ step ~prog ~args ~common ~no_rebuild ~context ~on_exit
   | No ->
     Scheduler_setup.go_with_rpc_server ~common ~config
     @@ fun () ->

bin/fmt.ml

@@ -35,7 +35,7 @@ let run_fmt_command ~common ~config ~preview builder =
       Alias.in_dir ~name:Dune_rules.Alias.fmt ~recursive:true ~contexts:setup.contexts dir
       |> Alias.request
     in
-    Build.run_build_system ~request
+    Build.run_build_system ~run_id:Dune_engine.Run_id.Batch ~request
     >>| function
     | Ok () -> ()
     | Error `Already_reported -> raise Dune_util.Report_error.Already_reported

bin/tools/tools_common.ml

@@ -22,7 +22,7 @@ let dev_tool_build_target dev_tool =
 let build_dev_tool_directly dev_tool =
   let open Fiber.O in
   let+ result =
-    Build.run_build_system ~request:(fun _build_system ->
+    Build.run_build_system ~run_id:Dune_engine.Run_id.Batch ~request:(fun _build_system ->
       let open Action_builder.O in
       let* () = dev_tool |> Lock_dev_tool.lock_dev_tool |> Action_builder.of_memo in
       (* Make sure the tool's lockdir is generated before building the tool. *)

src/dune_engine/build_loop.ml

@@ -1,7 +1,9 @@
 open Import
 open Fiber.O
 
-type step = (unit, [ `Already_reported ]) Result.t Fiber.t
+type step = run_id:Run_id.t -> (unit, [ `Already_reported ]) Result.t Fiber.t
+
+let next_run_id = ref 1
 
 let build_finish (build_result : Build_outcome.t) =
   let message =
@@ -23,23 +25,34 @@ let build_finish (build_result : Build_outcome.t) =
 ;;
 
 let rec poll_iter t step =
+  let run_id =
+    let run_id = Run_id.Watch !next_run_id in
+    incr next_run_id;
+    run_id
+  in
   let invalidation = Scheduler.Build_loop.pending_invalidation t in
   if Memo.Invalidation.is_empty invalidation
   then Memo.Metrics.reset ()
   else (
+    Dune_trace.emit Build (fun () ->
+      let reasons = Memo.Invalidation.details_hum ~max_elements:max_int invalidation in
+      Dune_trace.Event.watch_build_restart
+        ~run_id:(Run_id.to_int run_id)
+        ~reasons
+        ~at:(Time.now ()));
     let details_hum = Memo.Invalidation.details_hum invalidation in
     Console.maybe_clear_screen ~details_hum;
     Memo.reset invalidation);
   Scheduler.Build_loop.start_iteration t;
-  let* res = step in
-  let res : Build_outcome.t =
-    match res with
-    | Error `Already_reported -> Failure
-    | Ok () -> Success
-  in
+  let* res = step ~run_id in
   match Scheduler.Build_loop.finish_iteration t with
   | `Restart -> poll_iter t step
   | `Done ->
+    let res : Build_outcome.t =
+      match res with
+      | Error `Already_reported -> Failure
+      | Ok () -> Success
+    in
     build_finish res;
     Fiber.return res
 ;;

src/dune_engine/build_loop.mli

@@ -1,7 +1,7 @@
 open Import
 
 (** A build request run by the watch-mode build loop. *)
-type step = (unit, [ `Already_reported ]) Result.t Fiber.t
+type step = run_id:Run_id.t -> (unit, [ `Already_reported ]) Result.t Fiber.t
 
 (** [poll step] runs [step] in a loop.
 

src/dune_engine/build_system.ml

@@ -1099,7 +1099,7 @@ let handle_final_exns exns =
     List.iter exns ~f:report
 ;;
 
-let run f =
+let run ?(run_id = Run_id.Batch) f =
   let f =
     (* CR-someday cmoseley: Can we avoid creating a new lazy memo node every
        time the build system is rerun? *)
@@ -1112,7 +1112,7 @@ let run f =
   in
   let open Fiber.O in
   let f () =
-    let run_id, `Restart restart = Scheduler.Build_loop.start_build () in
+    let (`Restart restart) = Scheduler.Build_loop.start_build () in
     let start = Time.now () in
     Dune_trace.emit ~buffered:false Build (fun () ->
       Dune_trace.Event.watch_build_start ~run_id:(Run_id.to_int run_id) ~restart ~start);
@@ -1188,8 +1188,8 @@ let run_exn f =
   | Error `Already_reported -> raise Dune_util.Report_error.Already_reported
 ;;
 
-let run_action_builder request =
-  run (fun () ->
+let run_action_builder ?run_id request =
+  run ?run_id (fun () ->
     let+ (), (_ : Dep.Fact.t Dep.Map.t) =
       Action_builder.evaluate_and_collect_facts request
     in

src/dune_engine/build_system.mli

@@ -51,13 +51,17 @@ val dep_on_alias_definition : Rules.Dir_rules.Alias_spec.item -> unit Action_bui
 
 (** {2 Running the build system} *)
 
-val run : (unit -> 'a Memo.t) -> ('a, [ `Already_reported ]) Result.t Fiber.t
+val run
+  :  ?run_id:Run_id.t
+  -> (unit -> 'a Memo.t)
+  -> ('a, [ `Already_reported ]) Result.t Fiber.t
 
 (** A variant of [run] that raises an [Already_reported] exception on error. *)
 val run_exn : (unit -> 'a Memo.t) -> 'a Fiber.t
 
 val run_action_builder
-  :  unit Action_builder.t
+  :  ?run_id:Run_id.t
+  -> unit Action_builder.t
   -> (unit, [ `Already_reported ]) result Fiber.t
 
 (** {2 Misc} *)

src/dune_engine/dune_engine.ml

@@ -20,6 +20,7 @@ module Build_context = Build_context
 module Build_config = Build_config
 module Build_loop = Build_loop
 module Build_system = Build_system
+module Run_id = Run_id
 module Build_system_error = Build_system_error
 module Load_rules = Load_rules
 module Clflags = Clflags

src/dune_engine/run_id.ml

@@ -0,0 +1,8 @@
+type t =
+  | Batch
+  | Watch of int
+
+let to_int = function
+  | Batch -> 0
+  | Watch n -> n
+;;

src/dune_engine/run_id.mli

@@ -0,0 +1,5 @@
+type t =
+  | Batch
+  | Watch of int
+
+val to_int : t -> int

src/dune_scheduler/dune_scheduler.ml

@@ -2,7 +2,6 @@ module Scheduler = Scheduler
 module Async_io = Async_io
 module File_watcher = File_watcher
 module Shutdown = Shutdown
-module Run_id = Run_id
 
 module For_tests = struct
   module Inotify = Inotify

src/dune_scheduler/scheduler.ml

@@ -24,7 +24,6 @@ end
 
 let spawn_thread ~name f = Thread0.spawn ~name f
 
-module Run_id = Run_id
 include Types.Scheduler
 
 let running_jobs_count (t : t) = Event.Queue.pending_jobs t.events
@@ -203,7 +202,6 @@ let prepare (config : Config.t) ~(handler : Handler.t) ~events ~file_watcher =
            mode, which is even weirder. *)
         Building cancel
     ; invalidation = Memo.Invalidation.empty
-    ; run_id_state = Run_id.State.create ~watch_mode:(Option.is_some file_watcher)
     ; watch_restart_started_at = None
     ; handler
     ; build_inputs_changed = Trigger.create ()
@@ -285,17 +283,8 @@ module Run_once = struct
     else (
       let now = Time.now () in
       let build_loop = t.build_loop in
-      if Run_id.State.is_watch build_loop.run_id_state
-      then (
-        let run_id = Run_id.State.next_to_start build_loop.run_id_state in
-        let reasons = Memo.Invalidation.details_hum ~max_elements:max_int invalidation in
-        if Option.is_none build_loop.watch_restart_started_at
-        then build_loop.watch_restart_started_at <- Some now;
-        Dune_trace.emit Build (fun () ->
-          Dune_trace.Event.watch_build_restart
-            ~run_id:(Run_id.to_int run_id)
-            ~reasons
-            ~at:now));
+      if Option.is_none build_loop.watch_restart_started_at
+      then build_loop.watch_restart_started_at <- Some now;
       build_loop.invalidation
       <- Memo.Invalidation.combine build_loop.invalidation invalidation;
       let fills =
@@ -400,10 +389,8 @@ module Build_loop = struct
 
   let start_build () =
     let build_loop = (t ()).build_loop in
-    let state, run_id = Run_id.State.start build_loop.run_id_state in
     let restart = Option.is_some build_loop.watch_restart_started_at in
-    build_loop.run_id_state <- state;
-    run_id, `Restart restart
+    `Restart restart
   ;;
 
   let finish_build ~stop =

src/dune_scheduler/scheduler.mli

@@ -112,7 +112,7 @@ module Build_loop : sig
     | Finished of { restart_duration : Time.Span.t option }
     | Restarting
 
-  val start_build : unit -> Run_id.t * [ `Restart of bool ]
+  val start_build : unit -> [ `Restart of bool ]
   val finish_build : stop:Time.t -> build_finish
   val init : unit -> t Fiber.t
   val pending_invalidation : t -> Memo.Invalidation.t

src/dune_scheduler/types.ml

@@ -74,7 +74,6 @@ module Scheduler = struct
     type t =
       { mutable status : status
       ; mutable invalidation : Memo.Invalidation.t
-      ; mutable run_id_state : Run_id.State.t
       ; mutable watch_restart_started_at : Time.t option
       ; handler : Handler.t
       ; mutable build_inputs_changed : Trigger.t