re-do the complicated change

Signed-off-by: Arseniy Alekseyev <[email protected]>

bin/build_cmd.ml

@@ -20,30 +20,35 @@ let run_build_system ~common ~(request : unit Action_builder.t) () =
 
 let run_build_command_poll ~(common : Common.t) ~config ~request ~setup =
   let open Fiber.O in
-  let every () =
-    Cached_digest.invalidate_cached_timestamps ();
-    let* setup = setup () in
-    let* request =
-      match
-        let open Option.O in
-        let* rpc = Common.rpc common in
-        Dune_rpc_impl.Server.pending_build_action rpc
-      with
-      | None -> Fiber.return (request setup)
-      | Some (Build (targets, ivar)) ->
-        let+ () = Fiber.Ivar.fill ivar Accepted in
-        Target.interpret_targets (Common.root common) config setup targets
-    in
-    let+ () = run_build_system ~common ~request () in
-    `Continue
+  let every =
+    Fiber.of_thunk (fun () ->
+        Cached_digest.invalidate_cached_timestamps ();
+        let* setup = setup () in
+        let* request =
+          match
+            let open Option.O in
+            let* rpc = Common.rpc common in
+            Dune_rpc_impl.Server.pending_build_action rpc
+          with
+          | None -> Fiber.return (request setup)
+          | Some (Build (targets, ivar)) ->
+            let+ () = Fiber.Ivar.fill ivar Accepted in
+            Target.interpret_targets (Common.root common) config setup targets
+        in
+        run_build_system ~common ~request ())
   in
   Scheduler.poll ~common ~config ~every ~finally:Hooks.End_of_build.run
 
 let run_build_command_once ~(common : Common.t) ~config ~request ~setup =
   let open Fiber.O in
   let once () =
     let* setup = setup () in
-    run_build_system ~common ~request:(request setup) ()
+    let+ res = run_build_system ~common ~request:(request setup) () in
+    match res with
+    | Error `Already_reported ->
+      (* to ensure non-zero exit code *)
+      raise Dune_util.Report_error.Already_reported
+    | Ok () -> ()
   in
   Scheduler.go ~common ~config once
 

bin/exec.ml

@@ -85,7 +85,7 @@ let term =
       in
       let* prog =
         let open Memo.Build.O in
-        Build_system.run (fun () ->
+        Build_system.run_exn (fun () ->
             match Filename.analyze_program_name prog with
             | In_path -> (
               Super_context.resolve_program sctx ~dir ~loc:None prog

bin/import.ml

@@ -99,8 +99,10 @@ module Scheduler = struct
     let file_watcher = Common.file_watcher common in
     let run =
       let run () =
-        Scheduler.Run.poll (fun () ->
-            Fiber.finalize every ~finally:(fun () -> Fiber.return (finally ())))
+        Scheduler.Run.poll
+          (Fiber.finalize
+             (fun () -> every)
+             ~finally:(fun () -> Fiber.return (finally ())))
       in
       match Common.rpc common with
       | None -> run

bin/print_rules.ml

@@ -266,7 +266,7 @@ let term =
   Scheduler.go ~common ~config (fun () ->
       let open Fiber.O in
       let* setup = Import.Main.setup () in
-      Build_system.run (fun () ->
+      Build_system.run_exn (fun () ->
           let open Memo.Build.O in
           let* request =
             match targets with

bin/printenv.ml

@@ -75,7 +75,7 @@ let term =
             User_error.raise
               [ Pp.text "Environment is not defined in install dirs" ])
       in
-      Build_system.run (fun () -> Build_system.build request) >>| function
+      Build_system.run_exn (fun () -> Build_system.build request) >>| function
       | [ (_, env) ] -> Format.printf "%a" (pp ~fields) env
       | l ->
         List.iter l ~f:(fun (name, env) ->

bin/top.ml

@@ -33,7 +33,7 @@ let term =
   Scheduler.go ~common ~config (fun () ->
       let open Fiber.O in
       let* setup = Import.Main.setup () in
-      Build_system.run (fun () ->
+      Build_system.run_exn (fun () ->
           let open Memo.Build.O in
           let sctx =
             Dune_engine.Context_name.Map.find setup.scontexts ctx_name

bin/utop.ml

@@ -29,7 +29,7 @@ let term =
     Scheduler.go ~common ~config (fun () ->
         let open Fiber.O in
         let* setup = Import.Main.setup () in
-        Build_system.run (fun () ->
+        Build_system.run_exn (fun () ->
             let open Memo.Build.O in
             let context = Import.Main.find_context_exn setup ~name:ctx_name in
             let sctx = Import.Main.find_scontext_exn setup ~name:ctx_name in

src/dune_engine/build_system.ml

@@ -2264,21 +2264,27 @@ let caused_by_cancellation (exn : Exn_with_backtrace.t) =
 
 let report_early_exn exn =
   let t = t () in
-  let error = { Error.exn; id = Error.Id.gen () } in
-  t.errors <- error :: t.errors;
-  (match !Clflags.report_errors_config with
-  | Early
-  | Twice ->
-    if not (caused_by_cancellation exn) then Dune_util.Report_error.report exn
-  | Deterministic -> ());
-  t.handler.error [ Add error ]
-
-let reraise_exn exn =
+  match caused_by_cancellation exn with
+  | true -> Fiber.return ()
+  | false ->
+    let error = { Error.exn; id = Error.Id.gen () } in
+    t.errors <- error :: t.errors;
+    (match !Clflags.report_errors_config with
+    | Early
+    | Twice ->
+      Dune_util.Report_error.report exn
+    | Deterministic -> ());
+    t.handler.error [ Add error ]
+
+let handle_final_exns exns =
   match !Clflags.report_errors_config with
-  | Early -> raise Dune_util.Report_error.Already_reported
+  | Early -> ()
   | Twice
   | Deterministic ->
-    Exn_with_backtrace.reraise exn
+    let report exn =
+      if not (caused_by_cancellation exn) then Dune_util.Report_error.report exn
+    in
+    List.iter exns ~f:report
 
 let run f =
   let open Fiber.O in
@@ -2297,15 +2303,27 @@ let run f =
   let f () =
     let* () = t.handler.build_event Start in
     let* res =
-      Fiber.with_error_handler ~on_error:reraise_exn (fun () ->
+      Fiber.collect_errors (fun () ->
           Memo.Build.run_with_error_handler (f ())
             ~handle_error_no_raise:report_early_exn)
     in
-    let+ () = t.handler.build_event Finish in
-    res
+    match res with
+    | Ok res ->
+      let+ () = t.handler.build_event Finish in
+      Ok res
+    | Error exns ->
+      handle_final_exns exns;
+      Fiber.return (Error `Already_reported)
   in
   Fiber.Mutex.with_lock t.build_mutex f
 
+let run_exn f =
+  let open Fiber.O in
+  let+ res = run f in
+  match res with
+  | Ok res -> res
+  | Error `Already_reported -> raise Dune_util.Report_error.Already_reported
+
 let build_file = build_file
 
 let build_deps = build_deps

src/dune_engine/build_system.mli

@@ -182,7 +182,11 @@ val files_in_source_tree_to_delete : unit -> Path.Set.t
 
 (** {2 Running a build} *)
 
-val run : (unit -> 'a Memo.Build.t) -> 'a Fiber.t
+val run :
+  (unit -> 'a Memo.Build.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.Build.t) -> 'a Fiber.t
 
 (** {2 Misc} *)
 

src/dune_engine/scheduler.ml

@@ -827,6 +827,8 @@ module Worker = struct
 end
 
 module Run = struct
+  exception Build_cancelled = Build_cancelled
+
   type file_watcher =
     | Detect_external
     | No_watcher
@@ -838,18 +840,7 @@ module Run = struct
     let* t = t () in
     let rec loop () : unit Fiber.t =
       t.status <- Building;
-      let* res =
-        let report_error (exn : Exn_with_backtrace.t) =
-          match exn.exn with
-          | Build_cancelled -> ()
-          | _ -> Dune_util.Report_error.report exn
-        in
-        let on_error exn =
-          report_error exn;
-          Fiber.return ()
-        in
-        Fiber.map_reduce_errors (module Monoid.Unit) ~on_error step
-      in
+      let* res = step in
       match t.status with
       | Waiting_for_file_changes _ ->
         (* We just finished a build, so there's no way this was set *)
@@ -874,17 +865,14 @@ module Run = struct
           Memo.reset invalidations;
           t.handler t.config Source_files_changed;
           match res with
-          | Error _
-          | Ok `Continue ->
-            loop ()
-          | Ok `Stop -> Fiber.return ()))
+          | Error `Already_reported
+          | Ok () ->
+            loop ()))
     in
     loop ()
 
   exception Shutdown_requested
 
-  exception Build_cancelled
-
   let go config ?(file_watcher = No_watcher)
       ~(on_event : Config.t -> Handler.Event.t -> unit) run =
     let t = prepare config ~handler:on_event in

src/dune_engine/scheduler.mli

@@ -66,7 +66,7 @@ module Run : sig
 
       If [shutdown] is called, the current build will be canceled and new builds
       will not start. *)
-  val poll : (unit -> [ `Continue | `Stop ] Fiber.t) -> unit Fiber.t
+  val poll : (unit, [ `Already_reported ]) Result.t Fiber.t -> unit Fiber.t
 
   val go :
        Config.t