From 31ba228811eb9564861751a41bfd81ed28e929d5 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sat, 18 Apr 2026 01:49:44 +0100 Subject: [PATCH] feature: bring back action runners Add an opt-in action runner for executing eligible build processes in a separate Dune worker process. - Add --action-runner and the internal action-runner worker command. - Add --sandbox-actions, which runs eligible actions through a bubblewrap-wrapped worker and protects the shared cache from worker writes. - Extend process execution with a path-based runner hook, runner-safe metadata, output/capture handling, and parent-owned trace events. - Add action eligibility plumbing (Allow_action_runner, can_run_in_action_runner, runs_process) for user actions, cram tests, pp/ppx, inline tests, and selected action extensions. - Add RPC protocol/server support for runner ready/exec/cancel requests, per-generation lifecycle tracking, disconnect handling, and build-cancellation propagation. - Add trace events and inherited trace-fd support for worker lifecycle and process events. - Account for sandbox-actions in rule digests only for actions that spawn processes. - Add black-box coverage for runner execution, failures, disconnects, cancellation, watch shutdown, tracing, and sandboxed actions. Signed-off-by: Rudi Grinberg refactor: pass run ids to action runner requests Signed-off-by: Rudi Grinberg refactor(action): store runner eligibility on Action.Full Signed-off-by: Rudi Grinberg fix(cache): avoid unnecessary rule digest churn Signed-off-by: Rudi Grinberg --- bin/build.ml | 15 +- bin/build.mli | 3 +- bin/common.ml | 75 +- bin/common.mli | 2 + bin/describe/aliases_targets.ml | 3 +- bin/describe/describe_pp.ml | 5 +- bin/exec.ml | 4 +- bin/fmt.ml | 2 +- bin/internal.ml | 1 + bin/internal_action_runner.ml | 41 + bin/internal_action_runner.mli | 3 + bin/scheduler_setup.ml | 132 +++- bin/tools/tools_common.ml | 2 +- boot/libs.ml | 45 +- flake.nix | 7 +- otherlibs/stdune/src/action_runner_name.ml | 32 + otherlibs/stdune/src/action_runner_name.mli | 6 + otherlibs/stdune/src/fd.ml | 11 +- otherlibs/stdune/src/fd.mli | 8 + otherlibs/stdune/src/permissions.ml | 9 + otherlibs/stdune/src/permissions.mli | 9 + otherlibs/stdune/src/stdune.ml | 1 + src/action_ext/action_ext.ml | 2 + src/action_ext/action_ext.mli | 1 + src/action_plugin/action_plugin.ml | 1 + src/dune_engine/action.ml | 46 +- src/dune_engine/action.mli | 7 + src/dune_engine/action_exec.ml | 20 +- src/dune_engine/action_exec.mli | 1 + src/dune_engine/action_intf.ml | 1 + src/dune_engine/action_runner.ml | 441 +++++++++++ src/dune_engine/action_runner.mli | 49 ++ src/dune_engine/build_loop.ml | 23 +- src/dune_engine/build_loop.mli | 4 +- src/dune_engine/build_system.ml | 38 +- src/dune_engine/build_system.mli | 4 +- src/dune_engine/dune | 4 +- src/dune_engine/dune_engine.ml | 1 + src/dune_engine/execution_parameters.ml | 16 +- src/dune_engine/execution_parameters.mli | 1 + src/dune_engine/process.ml | 713 ++++++++++++++---- src/dune_engine/process.mli | 82 +- src/dune_patch/dune_patch.ml | 1 + src/dune_rpc_impl/server.ml | 47 +- src/dune_rpc_impl/server.mli | 2 + src/dune_rules/action_unexpanded.ml | 8 +- src/dune_rules/cc_flags.ml | 1 + src/dune_rules/command.ml | 34 +- src/dune_rules/command.mli | 3 + src/dune_rules/copy_line_directive.ml | 1 + src/dune_rules/cram/cram_exec.ml | 6 +- src/dune_rules/dep_rules.ml | 1 + src/dune_rules/fetch_rules.ml | 2 + src/dune_rules/format_dune_file.ml | 2 + src/dune_rules/inline_tests.ml | 10 +- src/dune_rules/install_rules.ml | 1 + src/dune_rules/lock_rules.ml | 1 + src/dune_rules/main.ml | 9 +- src/dune_rules/main.mli | 6 +- src/dune_rules/module_compilation.ml | 8 +- src/dune_rules/ocamldep.ml | 43 +- src/dune_rules/pkg_build_progress.ml | 1 + src/dune_rules/pkg_rules.ml | 2 + src/dune_rules/pp_spec_rules.ml | 49 +- src/dune_rules/run_with_path.ml | 8 +- src/dune_rules/system.ml | 1 + src/dune_scheduler/scheduler.ml | 44 +- src/dune_scheduler/scheduler.mli | 15 +- src/dune_scheduler/types.ml | 1 - src/dune_trace/dune_trace.ml | 166 ++-- src/dune_trace/dune_trace.mli | 17 +- src/dune_trace/event.ml | 43 +- src/dune_trace/out.ml | 95 ++- src/dune_trace/out.mli | 14 +- test/blackbox-tests/dune.jq | 79 ++ test/blackbox-tests/setup-script.sh | 46 ++ .../test-cases/action-runner/basic.t | 138 ++++ .../action-runner/cancel-disconnect.t | 30 + .../test-cases/action-runner/disconnect.t | 39 + .../test-cases/action-runner/dune | 21 + .../test-cases/action-runner/failure.t | 43 ++ .../test-cases/action-runner/pool.t | 43 ++ .../test-cases/action-runner/runtest.t | 62 ++ .../action-runner/stop-on-first-error.t | 21 + .../test-cases/action-runner/trace.t | 45 ++ .../action-runner/watch-stop-on-first-error.t | 26 + .../test-cases/dune-cache/trim.t | 4 +- .../test-cases/sandbox-actions/basic.t | 39 + .../test-cases/sandbox-actions/dune | 10 + .../test-cases/sandbox-actions/shared-cache.t | 47 ++ .../watching/action-runner-shutdown.t | 15 + test/blackbox-tests/test-cases/watching/dune | 5 + test/expect-tests/build_loop_tests.ml | 11 +- .../rev_store_fetch_depth_test.ml | 8 +- 94 files changed, 2812 insertions(+), 433 deletions(-) create mode 100644 bin/internal_action_runner.ml create mode 100644 bin/internal_action_runner.mli create mode 100644 otherlibs/stdune/src/action_runner_name.ml create mode 100644 otherlibs/stdune/src/action_runner_name.mli create mode 100644 src/dune_engine/action_runner.ml create mode 100644 src/dune_engine/action_runner.mli create mode 100644 test/blackbox-tests/test-cases/action-runner/basic.t create mode 100644 test/blackbox-tests/test-cases/action-runner/cancel-disconnect.t create mode 100644 test/blackbox-tests/test-cases/action-runner/disconnect.t create mode 100644 test/blackbox-tests/test-cases/action-runner/dune create mode 100644 test/blackbox-tests/test-cases/action-runner/failure.t create mode 100644 test/blackbox-tests/test-cases/action-runner/pool.t create mode 100644 test/blackbox-tests/test-cases/action-runner/runtest.t create mode 100644 test/blackbox-tests/test-cases/action-runner/stop-on-first-error.t create mode 100644 test/blackbox-tests/test-cases/action-runner/trace.t create mode 100644 test/blackbox-tests/test-cases/action-runner/watch-stop-on-first-error.t create mode 100644 test/blackbox-tests/test-cases/sandbox-actions/basic.t create mode 100644 test/blackbox-tests/test-cases/sandbox-actions/dune create mode 100644 test/blackbox-tests/test-cases/sandbox-actions/shared-cache.t create mode 100644 test/blackbox-tests/test-cases/watching/action-runner-shutdown.t diff --git a/bin/build.ml b/bin/build.ml index bac72ae6533..22cc50f098a 100644 --- a/bin/build.ml +++ b/bin/build.ml @@ -1,14 +1,13 @@ open Import -let run_build_system_impl ?restart_started_at ~run_id ~request () = +let run_build_system_impl ?restart_started_at ~request () = Dune_engine.Build_system.run_action_builder ?restart_started_at - ~run_id (let open Action_builder.O in Action_builder.of_memo (Util.setup ()) >>= request) ;; -let run_build_system ~run_id ~request = run_build_system_impl ~run_id ~request () +let run_build_system ~request = run_build_system_impl ~request () let poll_handling_rpc_build_requests build_loop ~(common : Common.t) = let open Fiber.O in @@ -21,7 +20,7 @@ let poll_handling_rpc_build_requests build_loop ~(common : Common.t) = build_loop ~get_build_request: (let+ { kind; outcome } = Dune_rpc_impl.Server.pending_action rpc in - ( (fun ~run_id ~restart_started_at -> + ( (fun ~restart_started_at -> let request setup = let root = Common.root common in match kind with @@ -32,7 +31,7 @@ let poll_handling_rpc_build_requests build_loop ~(common : Common.t) = ~to_cwd:root.to_cwd ~test_paths in - run_build_system_impl ?restart_started_at ~run_id ~request ()) + run_build_system_impl ?restart_started_at ~request ()) , outcome )) ;; @@ -44,8 +43,8 @@ let run_build_command_poll_eager ~(common : Common.t) ~config ~request : unit = is responsible for building targets named in RPC build requests. *) Dune_engine.Build_loop.run (fun build_loop -> let+ () = - Dune_engine.Build_loop.poll build_loop (fun ~run_id ~restart_started_at -> - run_build_system_impl ?restart_started_at ~run_id ~request ()) + Dune_engine.Build_loop.poll build_loop (fun ~restart_started_at -> + run_build_system_impl ?restart_started_at ~request ()) and+ () = poll_handling_rpc_build_requests build_loop ~common in ())) ;; @@ -61,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 ~run_id:Dune_engine.Run_id.Batch ~request + run_build_system ~request >>| function | Error `Already_reported -> raise Dune_util.Report_error.Already_reported | Ok () -> () diff --git a/bin/build.mli b/bin/build.mli index aa8a621fb32..a01a5a71d16 100644 --- a/bin/build.mli +++ b/bin/build.mli @@ -1,8 +1,7 @@ open Import val run_build_system - : run_id:Dune_engine.Run_id.t - -> request:(Dune_rules.Main.build_system -> unit Action_builder.t) + : request:(Dune_rules.Main.build_system -> unit Action_builder.t) -> (unit, [ `Already_reported ]) result Fiber.t val build : unit Cmd.t diff --git a/bin/common.ml b/bin/common.ml index 8e03d5a0939..1385ed46828 100644 --- a/bin/common.ml +++ b/bin/common.ml @@ -60,6 +60,7 @@ end let default_build_dir = "_build" let trace_file_name = "trace.csexp" +let action_runner_name = Action_runner_name.of_string "action-runner" let find_default_trace_file () = let trace_file = Filename.concat default_build_dir trace_file_name in @@ -625,6 +626,8 @@ module Builder = struct ; allow_builds : bool ; default_root_is_cwd : bool ; target_exec : string option + ; action_runner : bool + ; sandbox_actions : bool } let set_no_build t no_build = { t with no_build } @@ -952,6 +955,25 @@ module Builder = struct & info [ "stop-on-first-error" ] ~doc:(Some "Stop the build as soon as an error is encountered.")) + and+ sandbox_actions = + Arg.( + value + & flag + & info + [ "sandbox-actions" ] + ~docs + ~doc: + (Some + "Run spawned build processes in an external dune action runner wrapped \ + with bubblewrap.")) + and+ action_runner = + Arg.( + value + & flag + & info + [ "action-runner" ] + ~docs + ~doc:(Some "Run spawned build processes in an external dune action runner.")) in { no_build ; debug_dep_path @@ -996,6 +1018,8 @@ module Builder = struct ; allow_builds = true ; default_root_is_cwd = false ; target_exec + ; action_runner + ; sandbox_actions } ;; @@ -1035,6 +1059,8 @@ module Builder = struct ; allow_builds ; default_root_is_cwd ; target_exec + ; action_runner + ; sandbox_actions } = No_build.equal t.no_build no_build @@ -1074,6 +1100,8 @@ module Builder = struct && Bool.equal t.allow_builds allow_builds && Bool.equal t.default_root_is_cwd default_root_is_cwd && Option.equal String.equal t.target_exec target_exec + && Bool.equal t.action_runner action_runner + && Bool.equal t.sandbox_actions sandbox_actions ;; end @@ -1082,6 +1110,7 @@ type t = ; root : Workspace_root.t ; rpc : [ `Allow of Dune_lang.Dep_conf.t Dune_rpc_impl.Server.t Lazy.t | `Forbid_builds ] + ; action_runner : Dune_engine.Action_runner.t option } let capture_outputs t = t.builder.capture_outputs @@ -1089,6 +1118,8 @@ let root t = t.root let watch t = t.builder.watch let x t = t.builder.workspace_config.x let file_watcher t = t.builder.file_watcher +let sandbox_actions t = t.builder.sandbox_actions +let action_runner t = t.action_runner let prefix_target t s = t.root.reach_from_root_prefix ^ s let rpc t = @@ -1176,7 +1207,7 @@ let build (root : Workspace_root.t) (builder : Builder.t) = Dune_rpc_impl.Server.create ~registry ~root:root.dir builder.watch)) else `Forbid_builds in - { builder; root; rpc } + { builder; root; rpc; action_runner = None } ;; let maybe_init_cache (cache_config : Dune_cache.Config.t) = @@ -1283,7 +1314,47 @@ let init_with_root ~(root : Workspace_root.t) (builder : Builder.t) = , Dyn.string (Path.to_string (Lazy.force Dune_cache.Layout.build_cache_dir)) ) ]; Dune_cache.Shared.config := maybe_init_cache cache_config; - Dune_rules.Main.init ~sandboxing_preference:config.sandboxing_preference (); + let action_runner = + match + c.builder.allow_builds, c.builder.action_runner || c.builder.sandbox_actions + with + | false, _ -> None + | true, false -> None + | true, true -> + let server = + match rpc c with + | `Allow server -> Dune_rpc_impl.Server.action_runner server + | `Forbid_builds -> + Code_error.raise "action runners require the dune RPC server" [] + in + Some (Dune_engine.Action_runner.create server ~name:action_runner_name) + in + let c = { c with action_runner } in + (match action_runner with + | None -> () + | Some runner -> + Dune_engine.Process.Runner.set (fun ~build request -> + let { Dune_engine.Process.Build.run_id; cancellation } = build in + let on_cancel () = Dune_engine.Action_runner.cancel_build runner ~run_id in + Some + (let open Fiber.O in + let* result, outcome = + Fiber.Cancel.with_handler + cancellation + (fun () -> + Fiber.collect_errors (fun () -> + Dune_engine.Action_runner.exec_process runner ~build request)) + ~on_cancel + in + match outcome, result with + | Cancelled (), _ -> + raise (Memo.Non_reproducible Dune_scheduler.Scheduler.Run.Build_cancelled) + | Not_cancelled, Ok result -> Fiber.return result + | Not_cancelled, Error exns -> Fiber.reraise_all exns))); + Dune_rules.Main.init + ~sandbox_actions:c.builder.sandbox_actions + ~sandboxing_preference:config.sandboxing_preference + (); Only_packages.Clflags.set c.builder.only_packages; Report_error.print_memo_stacks := c.builder.debug_dep_path; Dune_engine.Clflags.report_errors_config := c.builder.report_errors_config; diff --git a/bin/common.mli b/bin/common.mli index b0cbd5feb46..5f63bf3fd4d 100644 --- a/bin/common.mli +++ b/bin/common.mli @@ -18,6 +18,8 @@ val rpc val watch_exclusions : t -> string list val watch : t -> Dune_rpc_impl.Watch_mode_config.t val file_watcher : t -> Dune_scheduler.Scheduler.Run.file_watcher +val sandbox_actions : t -> bool +val action_runner : t -> Dune_engine.Action_runner.t option val prefix_target : t -> string -> string val find_default_trace_file : unit -> string diff --git a/bin/describe/aliases_targets.ml b/bin/describe/aliases_targets.ml index fdef37b729d..eafd9ecea73 100644 --- a/bin/describe/aliases_targets.ml +++ b/bin/describe/aliases_targets.ml @@ -106,8 +106,7 @@ 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 ~run_id:Dune_engine.Run_id.Batch ~request - >>| fun (_ : (unit, [ `Already_reported ]) result) -> () + Build.run_build_system ~request >>| fun (_ : (unit, [ `Already_reported ]) result) -> () ;; module Aliases_cmd = struct diff --git a/bin/describe/describe_pp.ml b/bin/describe/describe_pp.ml index 97821c8a53f..99ed38d2920 100644 --- a/bin/describe/describe_pp.ml +++ b/bin/describe/describe_pp.ml @@ -32,7 +32,7 @@ let execute_pp_action ~sctx file pp_file dump_file = let context = Dune_rules.Expander.context expander in let build_dir = Context_name.build_dir context in let* input = - let* action, _observing_facts = + let* (action, can_run_in_action_runner), _observing_facts = let* loc, action = let+ dialect, ml_kind = dialect_and_ml_kind file in match Dialect.print_ast dialect ml_kind with @@ -54,7 +54,7 @@ let execute_pp_action ~sctx file pp_file dump_file = ~deps:[] ~what:"describe pp" in - Action.with_outputs_to dump_file build.action + Action.with_outputs_to dump_file build.action, build.can_run_in_action_runner in Action_builder.evaluate_and_collect_facts build in @@ -74,6 +74,7 @@ let execute_pp_action ~sctx file pp_file dump_file = ; env ; rule_loc = Loc.none ; execution_parameters + ; can_run_in_action_runner ; action } in diff --git a/bin/exec.ml b/bin/exec.ml index 3a1149e76d2..c7ba0681508 100644 --- a/bin/exec.ml +++ b/bin/exec.ml @@ -304,10 +304,10 @@ let exec_building_directly ~common ~config ~context ~prog ~args ~no_rebuild = let on_exit = Console.printf "Program exited with code [%d]" in Dune_engine.Build_loop.run (fun build_loop -> Dune_engine.Build_loop.poll build_loop - @@ fun ~run_id ~restart_started_at -> + @@ fun ~restart_started_at -> let* () = Fiber.return () in Console.maybe_clear_screen ~details_hum:[]; - Dune_engine.Build_system.run ?restart_started_at ~run_id + Dune_engine.Build_system.run ?restart_started_at @@ step ~prog ~args ~common ~no_rebuild ~context ~on_exit) | No -> Scheduler_setup.go_with_rpc_server ~common ~config diff --git a/bin/fmt.ml b/bin/fmt.ml index c0df0b5bcbb..3d178465755 100644 --- a/bin/fmt.ml +++ b/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 ~run_id:Dune_engine.Run_id.Batch ~request + Build.run_build_system ~request >>| function | Ok () -> () | Error `Already_reported -> raise Dune_util.Report_error.Already_reported diff --git a/bin/internal.ml b/bin/internal.ml index 6986bc6aaba..91d39430f43 100644 --- a/bin/internal.ml +++ b/bin/internal.ml @@ -228,6 +228,7 @@ let group = (Cmd.info "internal") [ Internal_dump.command ; Internal_digest_db.command + ; Internal_action_runner.group ; latest_lang_version ; bootstrap_info ; Sexp_pp.command diff --git a/bin/internal_action_runner.ml b/bin/internal_action_runner.ml new file mode 100644 index 00000000000..091d20e1c63 --- /dev/null +++ b/bin/internal_action_runner.ml @@ -0,0 +1,41 @@ +open Import + +let start = + let+ builder = Common.Builder.term_no_trace_no_pkg + and+ name = + Arg.(required & pos 0 (some string) None (Arg.info [] ~docv:"NAME" ~doc:None)) + and+ generation = + Arg.(required & pos 1 (some int) None (Arg.info [] ~docv:"GENERATION" ~doc:None)) + and+ where = + Arg.(required & pos 2 (some string) None (Arg.info [] ~docv:"WHERE" ~doc:None)) + and+ trace_fd = + Arg.(value & opt (some string) None (Arg.info [ "trace-fd" ] ~docv:"FD" ~doc:None)) + in + let builder = Common.Builder.forbid_builds builder in + let common, config = Common.init builder in + let name = Action_runner_name.parse_string_exn (Loc.none, name) in + Option.iter trace_fd ~f:(fun fd -> + if Sys.win32 then Code_error.raise "trace fd handoff is not supported on Windows" []; + Dune_trace.set_global_inherited_fd + ~common_args:[ "action_runner", Sexp.Atom (Action_runner_name.to_string name) ] + (Fd.unsafe_of_int (Int.of_string_exn fd))); + let where = + match + Dune_rpc.Conv.of_sexp + Dune_rpc.Where.sexp + ~version:Dune_rpc.Version.latest + (Sexp.Atom where) + with + | Ok where -> where + | Error err -> + User_error.raise + [ Pp.textf "invalid action runner RPC address %S" where + ; Pp.text (Dyn.to_string (Dune_rpc.Conv.dyn_of_error err)) + ] + in + Scheduler_setup.go_without_rpc_server ~common ~config (fun () -> + Dune_engine.Action_runner.Worker.start ~name ~generation ~where) +;; + +let start = Cmd.v (Cmd.info "start") start +let group = Cmd.group (Cmd.info "action-runner") [ start ] diff --git a/bin/internal_action_runner.mli b/bin/internal_action_runner.mli new file mode 100644 index 00000000000..d4c5902fcd6 --- /dev/null +++ b/bin/internal_action_runner.mli @@ -0,0 +1,3 @@ +open Import + +val group : unit Cmd.t diff --git a/bin/scheduler_setup.ml b/bin/scheduler_setup.ml index cddc8f38784..1a3f94485bf 100644 --- a/bin/scheduler_setup.ml +++ b/bin/scheduler_setup.ml @@ -8,6 +8,131 @@ let rpc server = } ;; +let with_action_runner_worker ~(common : Common.t) f = + match Common.action_runner common with + | None -> f () + | Some action_runner -> + let open Fiber.O in + let server = + match Common.rpc common with + | `Allow server -> server + | `Forbid_builds -> Code_error.raise "action runners require the dune RPC server" [] + in + let find_in_path_exn prog = + match Bin.which ~path:(Env_path.path Env.initial) prog with + | Some path -> path + | None -> User_error.raise [ Pp.textf "unable to find %s in PATH" prog ] + in + let has_directory_component prog = + String.exists prog ~f:(function + | '/' | '\\' -> true + | _ -> false) + in + let dune_prog = + let prog = Sys.executable_name in + if Filename.is_relative prog && not (has_directory_component prog) + then find_in_path_exn prog + else Path.of_filename_relative_to_initial_cwd prog + in + let jobs = Int.to_string !Dune_rules.Clflags.concurrency in + let env = + Env.initial + |> Env.add ~var:"DUNE_JOBS" ~value:jobs + |> Env.add ~var:"DUNE_BUILD_DIR" ~value:(Path.Build.to_string Path.Build.root) + |> Env.to_unix + |> Spawn.Env.of_list + in + let where = Dune_rpc_impl.Server.listening_address server in + let monitor_pool = Fiber.Pool.create () in + let started_worker = ref (None : Pid.t option) in + let worker_command runner ~generation = + let worker_argv = + [ Path.to_string dune_prog + ; "internal" + ; "action-runner" + ; "start" + ; Action_runner_name.to_string (Dune_engine.Action_runner.name runner) + ; Int.to_string generation + ; Dune_rpc.Where.to_string where + ] + in + if Common.sandbox_actions common + then ( + let bwrap = + match Platform.OS.value with + | Linux -> find_in_path_exn "bwrap" + | _ -> + User_error.raise + [ Pp.text "--sandbox-actions is currently only supported on Linux" ] + in + let cwd = Path.to_absolute_filename Path.root in + let shared_cache_bindings = + let build_cache_dir = Lazy.force Dune_cache.Layout.build_cache_dir in + Path.mkdir_p build_cache_dir; + let build_cache_dir = Path.to_string build_cache_dir in + [ "--ro-bind"; build_cache_dir; build_cache_dir ] + in + ( Path.to_string bwrap + , [ Path.to_string bwrap; "--die-with-parent"; "--bind"; "/"; "/" ] + @ shared_cache_bindings + @ [ "--proc"; "/proc"; "--dev"; "/dev"; "--chdir"; cwd; "--" ] + @ worker_argv )) + else Path.to_string dune_prog, worker_argv + in + let close_trace_fd trace_fd = Option.iter trace_fd ~f:Fd.close in + let start_worker ~runner ~generation = + let* () = Root.Rpc.Global.ensure_ready () in + let prog, argv = worker_command runner ~generation in + let trace_fd = Dune_trace.duplicate_global_fd () in + let argv = + argv + @ + match trace_fd with + | None -> [] + | Some fd -> [ "--trace-fd"; Int.to_string (Fd.unsafe_to_int fd) ] + in + let pid = + match Spawn.spawn ~env ~prog ~argv ~setpgid:Spawn.Pgid.new_process_group () with + | pid -> + close_trace_fd trace_fd; + let pid = Pid.of_int pid in + Dune_trace.emit Action (fun () -> + Dune_trace.Event.Action.runner_spawn + ~name:(Dune_engine.Action_runner.name runner) + ~pid); + pid + | exception exn -> + close_trace_fd trace_fd; + raise exn + in + started_worker := Some pid; + Fiber.Pool.task monitor_pool ~f:(fun () -> + let* _status = Scheduler.wait_for_process pid ~is_process_group_leader:true in + let* () = Dune_engine.Action_runner.disconnect runner ~generation in + (match !started_worker with + | Some current_pid when Pid.equal current_pid pid -> started_worker := None + | None | Some _ -> ()); + Fiber.return ()) + in + let terminate_worker pid = + match Unix.kill (-Pid.to_int pid) Sys.sigterm with + | () -> Fiber.return () + | exception Unix.Unix_error (Unix.ESRCH, _, _) -> Fiber.return () + in + Dune_engine.Action_runner.set_start action_runner start_worker; + Fiber.fork_and_join_unit + (fun () -> Fiber.Pool.run monitor_pool) + (fun () -> + Fiber.finalize f ~finally:(fun () -> + let worker = !started_worker in + let* () = + match worker with + | None -> Fiber.return () + | Some pid -> terminate_worker pid + in + Fiber.Pool.close monitor_pool)) +;; + let no_build_no_rpc ~config:dune_config f = let config = Dune_config.for_scheduler dune_config ~print_ctrl_c_warning:true ~watch_exclusions:[] @@ -28,7 +153,10 @@ let go_without_rpc_server ~(common : Common.t) ~config:dune_config f = let go_with_rpc_server ~common ~config f = let f = match Common.rpc common with - | `Allow server -> fun () -> Root.Rpc.Global.with_background_rpc (rpc server) f + | `Allow server -> + fun () -> + Root.Rpc.Global.with_background_rpc (rpc server) (fun () -> + with_action_runner_worker ~common f) | `Forbid_builds -> f in go_without_rpc_server ~common ~config f @@ -52,7 +180,7 @@ let go_with_rpc_server_and_file_watcher ~(common : Common.t) ~config:dune_config Root.Rpc.Global.with_background_rpc server @@ fun () -> let* () = Root.Rpc.Global.ensure_ready () in - run () + with_action_runner_worker ~common run in Run.go config ~file_watcher run ;; diff --git a/bin/tools/tools_common.ml b/bin/tools/tools_common.ml index b07414710b9..1fe01c298c3 100644 --- a/bin/tools/tools_common.ml +++ b/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 ~run_id:Dune_engine.Run_id.Batch ~request:(fun _build_system -> + Build.run_build_system ~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. *) diff --git a/boot/libs.ml b/boot/libs.ml index 83b2272533e..713dfa64af8 100644 --- a/boot/libs.ml +++ b/boot/libs.ml @@ -226,11 +226,48 @@ let local_libraries = ; special_builtin_support = None ; root_module = None } + ; { path = "src/rpc" + ; main_module_name = Some "Rpc" + ; include_subdirs = No + ; special_builtin_support = None + ; root_module = None + } ; { path = "src/dune_engine" ; main_module_name = Some "Dune_engine" ; include_subdirs = No ; special_builtin_support = None - ; root_module = None + ; root_module = + Some + { name = "Root" + ; entries = + [ "Build_path_prefix_map" + ; "Csexp" + ; "Dune_action_plugin" + ; "Dune_action_trace" + ; "Dune_cache" + ; "Dune_digest" + ; "Dune_glob" + ; "Dune_rpc" + ; "Dune_scheduler" + ; "Dune_targets" + ; "Dune_trace" + ; "Dune_util" + ; "Dyn" + ; "Event" + ; "Fiber" + ; "Memo" + ; "Ordering" + ; "Pp" + ; "Predicate_lang" + ; "Rpc" + ; "Spawn" + ; "Stdune" + ; "Thread" + ; "Top_closure" + ; "Unix" + ; "UnixLabels" + ] + } } ; { path = "otherlibs/dune-private-libs/section" ; main_module_name = Some "Dune_section" @@ -298,12 +335,6 @@ let local_libraries = ; special_builtin_support = None ; root_module = None } - ; { path = "src/rpc" - ; main_module_name = Some "Rpc" - ; include_subdirs = No - ; special_builtin_support = None - ; root_module = None - } ; { path = "src/action_plugin" ; main_module_name = Some "Action_plugin" ; include_subdirs = No diff --git a/flake.nix b/flake.nix index 7a1c95a1090..67adcad51ae 100644 --- a/flake.nix +++ b/flake.nix @@ -318,12 +318,15 @@ ] ++ lib.optionals stdenv.isLinux [ strace ]; testNativeBuildInputs = - pkgs: with pkgs; [ + pkgs: + with pkgs; + [ nodejs-slim pkg-config opam ocamlformat - ]; + ] + ++ lib.optionals stdenv.isLinux [ bubblewrap ]; docInputs = with pkgs.python3.pkgs; [ sphinx-autobuild diff --git a/otherlibs/stdune/src/action_runner_name.ml b/otherlibs/stdune/src/action_runner_name.ml new file mode 100644 index 00000000000..addbfc90a21 --- /dev/null +++ b/otherlibs/stdune/src/action_runner_name.ml @@ -0,0 +1,32 @@ +type t = string + +let to_string t = t + +let of_string_opt s = + Option.some_if + ((not (String.is_empty s)) + && (not (String.equal s ".")) + && not (String.exists s ~f:(Char.equal '/'))) + s +;; + +let valid_description = + Pp.text + "Action runner names must be non-empty, may not contain '/', and may not be '.'." +;; + +let error_message s = Printf.sprintf "%S is an invalid action runner name." s + +let of_string s = + match of_string_opt s with + | Some s -> s + | None -> Code_error.raise "Invalid Action_runner_name.t" [ "s", Dyn.string s ] +;; + +let parse_string_exn (loc, s) = + match of_string_opt s with + | Some s -> s + | None -> User_error.raise ~loc [ Pp.text (error_message s); valid_description ] +;; + +let repr = Repr.view Repr.string ~to_:to_string diff --git a/otherlibs/stdune/src/action_runner_name.mli b/otherlibs/stdune/src/action_runner_name.mli new file mode 100644 index 00000000000..39c1b4c5d7e --- /dev/null +++ b/otherlibs/stdune/src/action_runner_name.mli @@ -0,0 +1,6 @@ +type t + +val of_string : string -> t +val parse_string_exn : Loc.t * string -> t +val to_string : t -> string +val repr : t Repr.t diff --git a/otherlibs/stdune/src/fd.ml b/otherlibs/stdune/src/fd.ml index 9053288f0f7..e0577d84a7e 100644 --- a/otherlibs/stdune/src/fd.ml +++ b/otherlibs/stdune/src/fd.ml @@ -3,13 +3,18 @@ type t = ; mutable closed : bool } -let unsafe_to_int (fd : Unix.file_descr) = (Obj.magic fd : int) +let unsafe_file_descr_to_int (fd : Unix.file_descr) = (Obj.magic fd : int) +let unsafe_file_descr_of_int (fd : int) : Unix.file_descr = Obj.magic fd +let unsafe_to_int t = unsafe_file_descr_to_int t.fd let equal_raw_fd = Poly.equal -let hash_raw_fd fd = Int.hash (unsafe_to_int fd) -let raw_fd_repr = Repr.view Repr.int ~to_:unsafe_to_int +let hash_raw_fd fd = Int.hash (unsafe_file_descr_to_int fd) +let raw_fd_repr = Repr.view Repr.int ~to_:unsafe_file_descr_to_int let unsafe_to_unix_file_descr t = t.fd let unsafe_of_unix_file_descr fd = { fd; closed = false } let is_closed t = t.closed +let unsafe_of_int fd = unsafe_of_unix_file_descr (unsafe_file_descr_of_int fd) +let set_close_on_exec t = Unix.set_close_on_exec t.fd +let clear_close_on_exec t = Unix.clear_close_on_exec t.fd let set_nonblock t = assert (not t.closed); diff --git a/otherlibs/stdune/src/fd.mli b/otherlibs/stdune/src/fd.mli index 4467f85802d..70d31084ec7 100644 --- a/otherlibs/stdune/src/fd.mli +++ b/otherlibs/stdune/src/fd.mli @@ -7,8 +7,16 @@ val to_dyn : t -> Dyn.t val close : t -> unit val is_closed : t -> bool val set_nonblock : t -> unit +val set_close_on_exec : t -> unit +val clear_close_on_exec : t -> unit (** Unsafe casts to bridge callers that still use [Unix.file_descr]. *) val unsafe_of_unix_file_descr : Unix.file_descr -> t val unsafe_to_unix_file_descr : t -> Unix.file_descr + +(** Unsafe casts to bridge file descriptors passed through command line + arguments. *) +val unsafe_of_int : int -> t + +val unsafe_to_int : t -> int diff --git a/otherlibs/stdune/src/permissions.ml b/otherlibs/stdune/src/permissions.ml index e3a7cd427c1..abd057530a1 100644 --- a/otherlibs/stdune/src/permissions.ml +++ b/otherlibs/stdune/src/permissions.ml @@ -9,3 +9,12 @@ let add t perm = perm lor t.current_user let test t perm = perm land t.current_user <> 0 let test_any t perm = perm land t.all_users <> 0 let remove t perm = perm land lnot t.all_users + +module Mode = struct + type permission = t + type nonrec t = int + + let of_int t = t + let to_int t = t + let default_file = of_int 0o666 +end diff --git a/otherlibs/stdune/src/permissions.mli b/otherlibs/stdune/src/permissions.mli index 43475ca6354..f38e3e532f0 100644 --- a/otherlibs/stdune/src/permissions.mli +++ b/otherlibs/stdune/src/permissions.mli @@ -17,3 +17,12 @@ val test_any : t -> int -> bool (** Remove permissions from a given mask for all users. *) val remove : t -> int -> int + +module Mode : sig + type permission = t + type t + + val of_int : int -> t + val to_int : t -> int + val default_file : t +end diff --git a/otherlibs/stdune/src/stdune.ml b/otherlibs/stdune/src/stdune.ml index 5986ce6364c..d962de87bf5 100644 --- a/otherlibs/stdune/src/stdune.ml +++ b/otherlibs/stdune/src/stdune.ml @@ -113,6 +113,7 @@ module Bit_set = Bit_set module Unix_error = Unix_error module File_kind = File_kind module Alias_name = Alias_name +module Action_runner_name = Action_runner_name module type Per_item = Per_item_intf.S module type Applicative = Applicative_intf.S diff --git a/src/action_ext/action_ext.ml b/src/action_ext/action_ext.ml index 4605d8f4d2e..d8f442a5a02 100644 --- a/src/action_ext/action_ext.ml +++ b/src/action_ext/action_ext.ml @@ -9,6 +9,7 @@ module Make (S : sig val name : string val version : int val is_useful_to : memoize:bool -> bool + val runs_process : bool val encode : ('p, 't) t -> ('p -> Sexp.t) -> ('t -> Sexp.t) -> Sexp.t val bimap : ('a, 'b) t -> ('a -> 'x) -> ('b -> 'y) -> ('x, 'y) t @@ -23,6 +24,7 @@ struct include S let is_dynamic = false + let runs_process = runs_process let encode t f g = let open Sexp in diff --git a/src/action_ext/action_ext.mli b/src/action_ext/action_ext.mli index 20a51af702e..2f6f8ae2ae2 100644 --- a/src/action_ext/action_ext.mli +++ b/src/action_ext/action_ext.mli @@ -7,6 +7,7 @@ module Make (S : sig val name : string val version : int val is_useful_to : memoize:bool -> bool + val runs_process : bool val encode : ('p, 't) t -> ('p -> Sexp.t) -> ('t -> Sexp.t) -> Sexp.t val bimap : ('a, 'b) t -> ('a -> 'x) -> ('b -> 'y) -> ('x, 'y) t diff --git a/src/action_plugin/action_plugin.ml b/src/action_plugin/action_plugin.ml index 4745337d22b..ef34cb383b0 100644 --- a/src/action_plugin/action_plugin.ml +++ b/src/action_plugin/action_plugin.ml @@ -122,6 +122,7 @@ module Spec = struct let version = 1 let is_useful_to ~memoize = memoize let is_dynamic = true + let runs_process = true let encode (prog, args) f _ : Sexp.t = let open Sexp in diff --git a/src/dune_engine/action.ml b/src/dune_engine/action.ml index a786a5bc466..9716650f42d 100644 --- a/src/dune_engine/action.ml +++ b/src/dune_engine/action.ml @@ -374,6 +374,27 @@ let rec is_dynamic = function | Extension (module A) -> A.Spec.is_dynamic ;; +let rec runs_process = function + | Chdir (_, t) + | Setenv (_, _, t) + | Redirect_out (_, _, _, t) + | Redirect_in (_, _, t) + | Ignore (_, t) + | With_accepted_exit_codes (_, t) -> runs_process t + | Progn l | Pipe (_, l) | Concurrent l -> List.exists l ~f:runs_process + | Run _ | Bash _ | Diff _ -> true + | Echo _ + | Cat _ + | Copy _ + | Symlink _ + | Hardlink _ + | Write_file _ + | Rename _ + | Remove_tree _ + | Mkdir _ -> false + | Extension (module A) -> A.Spec.runs_process +;; + let maybe_sandbox_path sandbox p = match Path.as_in_build_dir p with | None -> p @@ -441,6 +462,7 @@ module Full = struct ; env : Env.t ; locks : Path.t list ; can_go_in_shared_cache : bool + ; can_run_in_action_runner : bool ; sandbox : Sandbox_config.t ; corrections : Corrections.t option } @@ -450,6 +472,7 @@ module Full = struct ; env = Env.empty ; locks = [] ; can_go_in_shared_cache = true + ; can_run_in_action_runner = false ; sandbox = Sandbox_config.default ; corrections = None } @@ -467,11 +490,22 @@ module Full = struct [ "x", Corrections.to_dyn x; "y", Corrections.to_dyn y ] ;; - let combine { action; env; locks; can_go_in_shared_cache; sandbox; corrections } x = + let combine + { action + ; env + ; locks + ; can_go_in_shared_cache + ; can_run_in_action_runner + ; sandbox + ; corrections + } + x + = { action = combine action x.action ; env = Env.extend_env env x.env ; locks = locks @ x.locks ; can_go_in_shared_cache = can_go_in_shared_cache && x.can_go_in_shared_cache + ; can_run_in_action_runner = can_run_in_action_runner || x.can_run_in_action_runner ; sandbox = Sandbox_config.inter sandbox x.sandbox ; corrections = combine_corrections corrections x.corrections } @@ -485,11 +519,19 @@ module Full = struct ?(env = Env.empty) ?(locks = []) ?(can_go_in_shared_cache = !Clflags.can_go_in_shared_cache_default) + ?(can_run_in_action_runner = false) ?(sandbox = Sandbox_config.default) ?corrections action = - { action; env; locks; can_go_in_shared_cache; sandbox; corrections } + { action + ; env + ; locks + ; can_go_in_shared_cache + ; can_run_in_action_runner + ; sandbox + ; corrections + } ;; let map t ~f = { t with action = f t.action } diff --git a/src/dune_engine/action.mli b/src/dune_engine/action.mli index 1dec021e916..5820d489a2a 100644 --- a/src/dune_engine/action.mli +++ b/src/dune_engine/action.mli @@ -120,6 +120,9 @@ val empty : t (** Checks, if action contains a [Dynamic_run]. *) val is_dynamic : t -> bool +(** Checks if executing the action may spawn a process. *) +val runs_process : t -> bool + (** Re-root all the paths in the action to their sandbox version *) val sandbox : t -> Sandbox.t -> t @@ -149,6 +152,7 @@ module Full : sig ; env : Env.t ; locks : Path.t list ; can_go_in_shared_cache : bool + ; can_run_in_action_runner : bool ; sandbox : Sandbox_config.t ; corrections : Corrections.t option } @@ -158,6 +162,9 @@ module Full : sig -> ?locks:Path.t list (** default [[]] *) -> ?can_go_in_shared_cache:bool (** default [!Clflags.can_fo_in_shared_cache_default] *) + -> ?can_run_in_action_runner:bool + (** default [false]. Whether processes in this action may be delegated + to the action runner when one is active. *) -> ?sandbox:Sandbox_config.t (** default [Sandbox_config.default] *) -> ?corrections:Corrections.t (** default [Corrections.Ignore] *) -> action diff --git a/src/dune_engine/action_exec.ml b/src/dune_engine/action_exec.ml index 94547226ece..dfbce3817c6 100644 --- a/src/dune_engine/action_exec.ml +++ b/src/dune_engine/action_exec.ml @@ -310,7 +310,10 @@ and redirect t ~ectx ~eenv ?in_ ?out () = | None -> eenv.stdout_to, eenv.stderr_to, ignore | Some (outputs, fn, perm) -> let out = - Process.Io.file fn Process.Io.Out ~perm:(Action.File_perm.to_unix_perm perm) + Process.Io.file + fn + Process.Io.Out + ~perm:(Action.File_perm.to_unix_perm perm |> Permissions.Mode.of_int) in let stdout_to, stderr_to = match outputs with @@ -411,15 +414,26 @@ type input = ; env : Env.t ; rule_loc : Loc.t ; execution_parameters : Execution_parameters.t + ; can_run_in_action_runner : bool ; action : Action.t } let exec - { targets; root; context; env; rule_loc; execution_parameters; action = t } + { targets + ; root + ; context + ; env + ; rule_loc + ; execution_parameters + ; can_run_in_action_runner + ; action = t + } ~build_deps = let ectx = - let metadata = Process.create_metadata ~purpose:(Build_job targets) () in + let metadata = + Process.create_metadata ~purpose:(Build_job targets) ~can_run_in_action_runner () + in { targets; metadata; context; rule_loc; build_deps } and eenv = let env = diff --git a/src/dune_engine/action_exec.mli b/src/dune_engine/action_exec.mli index e84586919a3..823cf5efd55 100644 --- a/src/dune_engine/action_exec.mli +++ b/src/dune_engine/action_exec.mli @@ -35,6 +35,7 @@ type input = ; env : Env.t ; rule_loc : Loc.t ; execution_parameters : Execution_parameters.t + ; can_run_in_action_runner : bool ; action : Action.t } diff --git a/src/dune_engine/action_intf.ml b/src/dune_engine/action_intf.ml index 48bfb0ca789..ffb40de1a4d 100644 --- a/src/dune_engine/action_intf.ml +++ b/src/dune_engine/action_intf.ml @@ -121,6 +121,7 @@ module Ext = struct val version : int val is_useful_to : memoize:bool -> bool val is_dynamic : bool + val runs_process : bool val encode : ('p, 't) t -> ('p -> Sexp.t) -> ('t -> Sexp.t) -> Sexp.t val bimap : ('a, 'b) t -> ('a -> 'x) -> ('b -> 'y) -> ('x, 'y) t diff --git a/src/dune_engine/action_runner.ml b/src/dune_engine/action_runner.ml new file mode 100644 index 00000000000..b57e50827a0 --- /dev/null +++ b/src/dune_engine/action_runner.ml @@ -0,0 +1,441 @@ +open Import +open Fiber.O +module Client = Root.Rpc.Client +module Server = Root.Rpc.Server + +module Request = struct + module Exec = struct + type response = + | Completed of Process.Runner.response + | Cancelled + + type t = + { run_id : Run_id.t + ; process : Process.Runner.request + } + end + + module Ready = struct + type t = + { name : Action_runner_name.t + ; generation : int + } + end + + module Cancel_build = struct + type t = { run_id : Run_id.t } + end +end + +module Decl = struct + module Conv = Dune_rpc.Conv + module Decl = Dune_rpc.Decl + + let marshal () = + let to_ data = Marshal.from_string data in + let from value = Marshal.to_string value ~sharing:true in + Conv.iso Conv.string to_ from + ;; + + module Exec = struct + let decl = + let v1 = + Decl.Request.make_current_gen ~req:(marshal ()) ~resp:(marshal ()) ~version:1 + in + Decl.Request.make + ~method_:(Dune_rpc.Method.Name.of_string "action/exec") + ~generations:[ v1 ] + ;; + end + + module Ready = struct + let decl = + let v1 = + Decl.Request.make_current_gen ~req:(marshal ()) ~resp:Conv.unit ~version:1 + in + Decl.Request.make + ~method_:(Dune_rpc.Method.Name.of_string "action/ready") + ~generations:[ v1 ] + ;; + end + + module Cancel_build = struct + let decl = + let v1 = + Decl.Request.make_current_gen ~req:(marshal ()) ~resp:Conv.unit ~version:1 + in + Decl.Request.make + ~method_:(Dune_rpc.Method.Name.of_string "action/cancel-build") + ~generations:[ v1 ] + ;; + end + + let exec = Exec.decl + let ready = Ready.decl + let cancel_build = Cancel_build.decl +end + +type session = Session : _ Server.Session.t -> session + +type initialized = + { generation : int + ; session : session + } + +type starting = + { generation : int + ; ready : unit Fiber.Ivar.t + } + +type status = + | Not_started + | Starting of starting + | Initialized of initialized + | Closed + +module Request_id = Stdune.Id.Make () + +type t = + { name : Action_runner_name.t + ; mutable status : status + ; start_lock : Fiber.Mutex.t + ; mutable next_generation : int + ; mutable start : (runner:t -> generation:int -> unit Fiber.t) option + } + +let name t = t.name + +let disconnected t = + User_error.raise + [ Pp.textf "Action runner %S disconnected." (Action_runner_name.to_string t.name) ] +;; + +let disconnected_before_initialization t = + User_error.raise + [ Pp.textf + "Action runner %S failed to initialize." + (Action_runner_name.to_string t.name) + ; Pp.text "It exited before connecting back to Dune." + ] +;; + +let generation_matches generation current = + match generation with + | None -> true + | Some generation -> Int.equal generation current +;; + +let disconnect ?generation t = + let ready = + match t.status with + | Not_started | Closed -> None + | Starting { generation = current; ready } when generation_matches generation current + -> Some (Some ready) + | Initialized { generation = current; _ } when generation_matches generation current + -> Some None + | Starting _ | Initialized _ -> None + in + match ready with + | None -> Fiber.return () + | Some ready -> + t.status <- Closed; + Dune_trace.emit Action (fun () -> + Dune_trace.Event.Action.runner_disconnected ~name:t.name); + (match ready with + | None -> Fiber.return () + | Some ready -> Fiber.Ivar.fill ready ()) +;; + +let await_initialized t = + match t.status with + | Not_started | Closed -> disconnected t + | Initialized s -> Fiber.return s + | Starting { generation; ready } -> + let+ () = Fiber.Ivar.read ready in + (match t.status with + | Closed -> disconnected_before_initialization t + | Initialized ({ generation = current; _ } as s) when Int.equal generation current -> + s + | Not_started | Starting _ | Initialized _ -> + Code_error.raise + "action runner initialization finished without the expected session" + [ "name", Dyn.string (Action_runner_name.to_string t.name) + ; "generation", Dyn.int generation + ]) +;; + +let await_ready t = + let* _initialized = await_initialized t in + Fiber.return () +;; + +let set_start t start = + match t.start with + | None -> t.start <- Some start + | Some _ -> Code_error.raise "action runner start has already been set" [] +;; + +let ensure_started t = + Fiber.Mutex.with_lock t.start_lock ~f:(fun () -> + match t.status with + | Initialized _ | Starting _ -> await_ready t + | Not_started | Closed -> + let generation = t.next_generation in + t.next_generation <- generation + 1; + let ready = Fiber.Ivar.create () in + t.status <- Starting { generation; ready }; + let* result = + Fiber.collect_errors (fun () -> + match t.start with + | Some start -> start ~runner:t ~generation + | None -> Code_error.raise "action runner start has not been set" []) + in + (match result with + | Ok () -> await_ready t + | Error exns -> + let* () = disconnect t ~generation in + Fiber.reraise_all exns)) +;; + +let send_request ~request ~payload t = + let* { generation; session } = await_initialized t in + let (Session session) = session in + let id = + Dune_rpc.Id.make (Sexp.Atom (Int.to_string (Request_id.to_int (Request_id.gen ())))) + in + let* result = + Fiber.collect_errors (fun () -> + Server.Session.request session (Dune_rpc.Decl.Request.witness request) id payload) + in + let is_connection_dead { Exn_with_backtrace.exn; _ } = + match exn with + | Dune_rpc.Response.Error.E { kind = Connection_dead; _ } -> true + | _ -> false + in + match result with + | Ok response -> Fiber.return response + | Error exns when List.exists exns ~f:is_connection_dead -> + let* () = disconnect t ~generation in + disconnected t + | Error exns -> Fiber.reraise_all exns +;; + +let exec_process t ~(build : Process.Build.t) process = + let* () = ensure_started t in + Dune_trace.emit Action (fun () -> + Dune_trace.Event.Action.runner_request_sent ~name:t.name); + let payload = { Request.Exec.run_id = build.run_id; process } in + let+ (response : Request.Exec.response) = send_request ~request:Decl.exec ~payload t in + match response with + | Cancelled -> raise (Memo.Non_reproducible Scheduler.Run.Build_cancelled) + | Completed response -> + let trace_args = + ("action_runner", Sexp.Atom (Action_runner_name.to_string t.name)) + :: response.trace_args + in + { response with trace_args } +;; + +let cancel_build t ~run_id = + let payload = { Request.Cancel_build.run_id } in + Dune_trace.emit Action (fun () -> + Dune_trace.Event.Action.runner_cancel_request_sent ~name:t.name); + send_request ~request:Decl.cancel_build ~payload t +;; + +module Rpc_server = struct + type nonrec t = + { workers : (string, t) Table.t + ; pool : Fiber.Pool.t + } + + let create () = + { workers = Table.create (module String) 16; pool = Fiber.Pool.create () } + ;; + + let run t = Fiber.Pool.run t.pool + let stop t = Fiber.Pool.close t.pool + + let register t worker = + match Table.add t.workers (Action_runner_name.to_string worker.name) worker with + | Ok () -> () + | Error _ -> + User_error.raise + [ Pp.textf + "Cannot register %s as it already exists" + (Action_runner_name.to_string worker.name) + ] + ;; + + let invalid_request message = + let error = Dune_rpc.Response.Error.create ~kind:Invalid_request ~message () in + raise (Dune_rpc.Response.Error.E error) + ;; + + let implement_handler t (handler : _ Root.Rpc.Server.Handler.t) = + Server.Handler.declare_request handler Decl.exec; + Server.Handler.declare_request handler Decl.cancel_build; + Server.Handler.implement_request handler Decl.ready + @@ fun session ({ Request.Ready.name; generation } : Request.Ready.t) -> + match Table.find t.workers (Action_runner_name.to_string name) with + | None -> invalid_request "unexpected action runner" + | Some worker -> + (match worker.status with + | Not_started | Closed -> invalid_request "disconnected earlier" + | Initialized _ -> invalid_request "already signalled readiness to the server" + | Starting { generation = expected; ready } -> + if not (Int.equal generation expected) + then invalid_request "unexpected action runner generation"; + let initialized = { generation; session = Session session } in + worker.status <- Initialized initialized; + Dune_trace.emit Action (fun () -> + Dune_trace.Event.Action.runner_connected ~name:worker.name); + let* () = + Fiber.Pool.task t.pool ~f:(fun () -> + let* () = Server.Session.closed session in + disconnect worker ~generation) + in + Fiber.Ivar.fill ready ()) + ;; +end + +let create server ~name = + let t = + { name + ; status = Not_started + ; start_lock = Fiber.Mutex.create () + ; next_generation = 0 + ; start = None + } + in + Rpc_server.register server t; + t +;; + +module Worker = struct + type active_build = + { build : Process.Build.t + ; mutable count : int + ; drained : unit Fiber.Ivar.t + } + + type t = + { active_builds : (int, active_build) Table.t + ; mutable highest_cancelled_run_id : Run_id.t option + } + + let create () = + { active_builds = Table.create (module Int) 8; highest_cancelled_run_id = None } + ;; + + let run_id_compare a b = Int.compare (Run_id.to_int a) (Run_id.to_int b) + let run_id_leq a b = run_id_compare a b <> Gt + + let mark_cancelled t run_id = + match t.highest_cancelled_run_id with + | None -> t.highest_cancelled_run_id <- Some run_id + | Some highest when run_id_compare highest run_id = Lt -> + t.highest_cancelled_run_id <- Some run_id + | Some _ -> () + ;; + + let is_cancelled t run_id = + match t.highest_cancelled_run_id with + | None -> false + | Some highest -> run_id_leq run_id highest + ;; + + let start_build t run_id = + let key = Run_id.to_int run_id in + match Table.find t.active_builds key with + | Some active -> + active.count <- active.count + 1; + active.build + | None -> + let build = { Process.Build.run_id; cancellation = Fiber.Cancel.create () } in + let active = { build; count = 1; drained = Fiber.Ivar.create () } in + Table.set t.active_builds key active; + build + ;; + + let finish_build t run_id = + let key = Run_id.to_int run_id in + match Table.find t.active_builds key with + | None -> + Code_error.raise + "action runner finished a build that was not recorded as active" + [ "run_id", Dyn.int (Run_id.to_int run_id) ] + | Some active when active.count > 1 -> + active.count <- active.count - 1; + Fiber.return () + | Some active -> + Table.remove t.active_builds key; + Fiber.Ivar.fill active.drained () + ;; + + let exec_process t ~name ({ Request.Exec.run_id; process } : Request.Exec.t) = + if is_cancelled t run_id + then Fiber.return Request.Exec.Cancelled + else ( + let build = start_build t run_id in + Fiber.finalize + (fun () -> + Dune_trace.emit Action (fun () -> + Dune_trace.Event.Action.runner_exec_start ~name); + let+ response = Process.exec_locally ~build process in + Request.Exec.Completed response) + ~finally:(fun () -> finish_build t run_id)) + ;; + + let cancel_build t ~name ({ Request.Cancel_build.run_id } : Request.Cancel_build.t) = + Dune_trace.emit Action (fun () -> Dune_trace.Event.Action.runner_cancel_start ~name); + mark_cancelled t run_id; + let active_builds = + Table.values t.active_builds + |> List.filter ~f:(fun active -> run_id_leq active.build.run_id run_id) + in + Fiber.parallel_iter active_builds ~f:(fun active -> + let* () = Fiber.Cancel.fire active.build.cancellation in + Fiber.Ivar.read active.drained) + ;; + + let start ~name ~generation ~where = + let t = create () in + let name_string = Action_runner_name.to_string name in + Dune_trace.emit Action (fun () -> + Dune_trace.Event.Action.runner_connection_start ~name); + let* connection = Client.Connection.connect_exn where in + Dune_trace.emit Action (fun () -> + Dune_trace.Event.Action.runner_connection_established ~name); + let private_menu : Client.proc list = + [ Client.Request Decl.ready + ; Client.Handle_request (Decl.exec, exec_process t ~name) + ; Client.Handle_request (Decl.cancel_build, cancel_build t ~name) + ] + in + let id = Dune_rpc.Id.make (Sexp.Atom (sprintf "%s:%d" name_string generation)) in + let initialize = Dune_rpc.Initialize.Request.create ~id in + Client.client ~private_menu connection initialize ~f:(fun client -> + let* request = + Client.Versioned.prepare_request client (Dune_rpc.Decl.Request.witness Decl.ready) + in + match request with + | Error version_error -> + User_error.raise + [ Pp.textf + "Server does not agree on the menu. Are you running the same dune binary \ + for the worker?" + ; Pp.text (Dune_rpc.Version_error.message version_error) + ] + | Ok request -> + let payload = { Request.Ready.name; generation } in + let* response = Client.request client request payload in + (match response with + | Ok () -> Client.disconnected client + | Error error -> + User_error.raise + [ Pp.text "Failed to signal readiness to the server" + ; Pp.text (Dune_rpc.Response.Error.message error) + ])) + ;; +end diff --git a/src/dune_engine/action_runner.mli b/src/dune_engine/action_runner.mli new file mode 100644 index 00000000000..797c3a454aa --- /dev/null +++ b/src/dune_engine/action_runner.mli @@ -0,0 +1,49 @@ +open Import + +(** Action runners are instances capable of executing build processes outside + of the main dune process. *) + +type t + +module Rpc_server : sig + (** The server-side component responsible for orchestrating action runners. *) + type t + + val create : unit -> t + + (** [implement_handler t handler] wires the action runner requests into an + existing RPC handler. *) + val implement_handler : t -> 'a Root.Rpc.Server.Handler.t -> unit + + (** [run t] is to be run by the RPC server. *) + val run : t -> unit Fiber.t + + (** [stop t] is to be run by the RPC server. *) + val stop : t -> unit Fiber.t +end + +val create : Rpc_server.t -> name:Action_runner_name.t -> t +val name : t -> Action_runner_name.t +val set_start : t -> (runner:t -> generation:int -> unit Fiber.t) -> unit +val disconnect : ?generation:int -> t -> unit Fiber.t + +(** [exec_process t process] dispatches [process] to [t]. *) +val exec_process + : t + -> build:Process.Build.t + -> Process.Runner.request + -> Process.Runner.response Fiber.t + +(** [cancel_build] cancels the current run on [t] and only returns once that + run has drained. *) +val cancel_build : t -> run_id:Run_id.t -> unit Fiber.t + +module Worker : sig + (** [start ~name ~generation ~where] starts a runner named [name] connected to + the main dune RPC server listening at [where]. *) + val start + : name:Action_runner_name.t + -> generation:int + -> where:Dune_rpc.Where.t + -> unit Fiber.t +end diff --git a/src/dune_engine/build_loop.ml b/src/dune_engine/build_loop.ml index 4b2053e58a4..ae3737df576 100644 --- a/src/dune_engine/build_loop.ml +++ b/src/dune_engine/build_loop.ml @@ -3,9 +3,7 @@ open Fiber.O module Trigger = Fiber.Trigger type step = - run_id:Run_id.t - -> restart_started_at:Time.t option - -> (unit, [ `Already_reported ]) Result.t Fiber.t + restart_started_at:Time.t option -> (unit, [ `Already_reported ]) Result.t Fiber.t type status = | (* We are not doing a build. Just accumulating invalidations until the next @@ -79,12 +77,6 @@ let show_build_interrupted_status_line () = progress.number_of_rules_discovered)))) ;; -let current_run_id t = - match t.current_run_id with - | Some run_id -> run_id - | None -> Code_error.raise "expected current build run id" [] -;; - let request_restart t invalidation = let* () = Fiber.return () in if Memo.Invalidation.is_empty invalidation @@ -98,7 +90,10 @@ let request_restart t invalidation = build-start event. [build-restart] is emitted only when we cancel an active build below. *) Run_id.Watch !next_run_id - | Building | Restarting_build -> current_run_id t + | Building | Restarting_build -> + (match t.current_run_id with + | Some run_id -> run_id + | None -> Code_error.raise "expected current build run id" []) in if Option.is_none t.watch_restart_started_at then t.watch_restart_started_at <- Some now; @@ -110,7 +105,7 @@ let request_restart t invalidation = | Building -> show_build_interrupted_status_line (); t.status <- Restarting_build; - let+ () = Scheduler.cancel_current_build () in + let+ () = Process.Build.cancel_current () in Dune_trace.emit Build (fun () -> Dune_trace.Event.watch_build_restart ~run_id:(Run_id.to_int input_change_run_id) @@ -173,10 +168,8 @@ let run_current_build t ~run_id step = | Standing_by | Restarting_build -> ()); t.status <- Building; t.current_run_id <- Some run_id; - let+ outcome = - Scheduler.with_current_build_cancellation (Fiber.Cancel.create ()) (fun () -> - step ~run_id ~restart_started_at) - in + let build = { Process.Build.run_id; cancellation = Fiber.Cancel.create () } in + let+ outcome = Process.Build.with_ build (fun () -> step ~restart_started_at) in let next = match t.status with | Restarting_build -> `Restart diff --git a/src/dune_engine/build_loop.mli b/src/dune_engine/build_loop.mli index 07457bfe689..c629b9aa6b0 100644 --- a/src/dune_engine/build_loop.mli +++ b/src/dune_engine/build_loop.mli @@ -5,9 +5,7 @@ type t (** A build request run by the watch-mode build loop. *) type step = - run_id:Run_id.t - -> restart_started_at:Time.t option - -> (unit, [ `Already_reported ]) Result.t Fiber.t + restart_started_at:Time.t option -> (unit, [ `Already_reported ]) Result.t Fiber.t (** [run f] initializes watch-mode state and runs [f] with it. *) val run : (t -> 'a Fiber.t) -> 'a Fiber.t diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index 77582d80e40..ec00f44060e 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -226,12 +226,18 @@ module Internal = struct ; env ; locks ; can_go_in_shared_cache + ; can_run_in_action_runner = _ ; sandbox = _ (* already taken into account in [sandbox_mode] *) ; corrections } = action in + let execution_parameters = + if Action.runs_process action + then execution_parameters + else Execution_parameters.set_sandbox_actions false execution_parameters + in let digest = let d = Digest.Manual.create () in Digest.Manual.int d rule_digest_version; @@ -378,6 +384,7 @@ module Internal = struct ; env ; locks ; can_go_in_shared_cache = _ + ; can_run_in_action_runner ; sandbox = _ ; corrections } @@ -422,6 +429,7 @@ module Internal = struct ; targets = Some targets ; rule_loc = loc ; execution_parameters + ; can_run_in_action_runner ; action } in @@ -751,7 +759,14 @@ module Internal = struct ignore observing_facts; let digest = let { Rule.Anonymous_action.action = - { action; env; locks; can_go_in_shared_cache; sandbox; corrections } + { action + ; env + ; locks + ; can_go_in_shared_cache + ; can_run_in_action_runner = _ + ; sandbox + ; corrections + } ; loc = _ ; dir ; alias @@ -1081,7 +1096,7 @@ let report_early_exn exn = let+ () = State.add_errors errors and+ () = match !Clflags.stop_on_first_error with - | true -> Scheduler.cancel_current_build () + | true -> Process.Build.cancel_current () | false -> Fiber.return () in (match !Clflags.report_errors_config with @@ -1099,7 +1114,17 @@ let handle_final_exns exns = List.iter exns ~f:report ;; -let run ?restart_started_at ?(run_id = Run_id.Batch) f = +let run ?restart_started_at ?build f = + let build = + match build with + | Some build -> build + | None -> + (match Process.Build.get () with + | Some build -> build + | None -> + { Process.Build.run_id = Run_id.Batch; cancellation = Fiber.Cancel.create () }) + in + let { Process.Build.run_id; _ } = build in let finalize_diff_promotion () = protect ~f:Diff_promotion.finalize ~finally:Diff_promotion.clear_cache in @@ -1167,8 +1192,7 @@ let run ?restart_started_at ?(run_id = Run_id.Batch) f = |> Option.iter ~f:Dune_trace.always_emit; outcome in - Fiber.Mutex.with_lock State.build_mutex ~f:(fun () -> - Scheduler.with_current_build_cancellation (Fiber.Cancel.create ()) f) + Fiber.Mutex.with_lock State.build_mutex ~f:(fun () -> Process.Build.with_ build f) ;; let run_exn f = @@ -1179,8 +1203,8 @@ let run_exn f = | Error `Already_reported -> raise Dune_util.Report_error.Already_reported ;; -let run_action_builder ?restart_started_at ?run_id request = - run ?restart_started_at ?run_id (fun () -> +let run_action_builder ?restart_started_at ?build request = + run ?restart_started_at ?build (fun () -> let+ (), (_ : Dep.Fact.t Dep.Map.t) = Action_builder.evaluate_and_collect_facts request in diff --git a/src/dune_engine/build_system.mli b/src/dune_engine/build_system.mli index d8310734bd5..736160f1599 100644 --- a/src/dune_engine/build_system.mli +++ b/src/dune_engine/build_system.mli @@ -53,7 +53,7 @@ val dep_on_alias_definition : Rules.Dir_rules.Alias_spec.item -> unit Action_bui val run : ?restart_started_at:Time.t - -> ?run_id:Run_id.t + -> ?build:Process.Build.t -> (unit -> 'a Memo.t) -> ('a, [ `Already_reported ]) Result.t Fiber.t @@ -62,7 +62,7 @@ val run_exn : (unit -> 'a Memo.t) -> 'a Fiber.t val run_action_builder : ?restart_started_at:Time.t - -> ?run_id:Run_id.t + -> ?build:Process.Build.t -> unit Action_builder.t -> (unit, [ `Already_reported ]) result Fiber.t diff --git a/src/dune_engine/dune b/src/dune_engine/dune index 30c4979844b..f9028125dda 100644 --- a/src/dune_engine/dune +++ b/src/dune_engine/dune @@ -1,5 +1,6 @@ (library (name dune_engine) + (root_module root) (libraries unix csexp @@ -20,5 +21,6 @@ dune_rpc spawn dune_digest - dune_action_trace) + dune_action_trace + rpc) (synopsis "Internal Dune library, do not use!")) diff --git a/src/dune_engine/dune_engine.ml b/src/dune_engine/dune_engine.ml index bb1b7adc316..75263ace3cd 100644 --- a/src/dune_engine/dune_engine.ml +++ b/src/dune_engine/dune_engine.ml @@ -33,6 +33,7 @@ module Execution_parameters = Execution_parameters module Report_errors_config = Report_errors_config module Reflection = Reflection module No_io = No_io +module Action_runner = Action_runner module Action_exec = Action_exec module Running_jobs = Running_jobs module Rule_cache = Rule_cache diff --git a/src/dune_engine/execution_parameters.ml b/src/dune_engine/execution_parameters.ml index 14bf58ba2b7..3fa4ddc19f1 100644 --- a/src/dune_engine/execution_parameters.ml +++ b/src/dune_engine/execution_parameters.ml @@ -77,6 +77,7 @@ type t = ; workspace_root_to_build_path_prefix_map : Workspace_root_for_build_prefix_map.t ; action_project_root : Path.Source.t option ; should_remove_write_permissions_on_generated_files : bool + ; sandbox_actions : bool } let equal @@ -88,6 +89,7 @@ let equal ; workspace_root_to_build_path_prefix_map ; action_project_root ; should_remove_write_permissions_on_generated_files + ; sandbox_actions } t = @@ -103,6 +105,7 @@ let equal && Bool.equal should_remove_write_permissions_on_generated_files t.should_remove_write_permissions_on_generated_files + && Bool.equal sandbox_actions t.sandbox_actions ;; let hash @@ -114,6 +117,7 @@ let hash ; workspace_root_to_build_path_prefix_map ; action_project_root ; should_remove_write_permissions_on_generated_files + ; sandbox_actions } = Poly.hash @@ -124,7 +128,8 @@ let hash , expand_aliases_in_sandbox , workspace_root_to_build_path_prefix_map , action_project_root - , should_remove_write_permissions_on_generated_files ) + , should_remove_write_permissions_on_generated_files + , sandbox_actions ) ;; let bool_to_int b = if b then 1 else 0 @@ -138,6 +143,7 @@ let digest_fields ~workspace_root_to_build_path_prefix_map ~action_project_root ~should_remove_write_permissions_on_generated_files + ~sandbox_actions = let d = Digest.Manual.create () in let root = @@ -149,6 +155,7 @@ let digest_fields lor (bool_to_int expand_aliases_in_sandbox lsl 4) lor (bool_to_int (Option.is_some root) lsl 5) lor (bool_to_int should_remove_write_permissions_on_generated_files lsl 6) + lor (bool_to_int sandbox_actions lsl 7) in Digest.Manual.int d flags; Digest.Manual.int d action_stdout_limit; @@ -170,6 +177,7 @@ let make ~workspace_root_to_build_path_prefix_map ~action_project_root ~should_remove_write_permissions_on_generated_files + ~sandbox_actions = { action_stdout_on_success ; action_stderr_on_success @@ -179,6 +187,7 @@ let make ; workspace_root_to_build_path_prefix_map ; action_project_root ; should_remove_write_permissions_on_generated_files + ; sandbox_actions } ;; @@ -207,6 +216,7 @@ let repr = "should_remove_write_permissions_on_generated_files" Repr.bool ~get:(fun t -> t.should_remove_write_permissions_on_generated_files) + ; Repr.field "sandbox_actions" Repr.bool ~get:(fun t -> t.sandbox_actions) ] ;; @@ -219,6 +229,7 @@ let digest ; workspace_root_to_build_path_prefix_map ; action_project_root ; should_remove_write_permissions_on_generated_files + ; sandbox_actions } = digest_fields @@ -230,6 +241,7 @@ let digest ~workspace_root_to_build_path_prefix_map ~action_project_root ~should_remove_write_permissions_on_generated_files + ~sandbox_actions ;; let to_dyn = Repr.to_dyn repr @@ -245,6 +257,7 @@ let builtin_default = (Workspace_root_for_build_prefix_map.Set "/workspace_root") ~action_project_root:None ~should_remove_write_permissions_on_generated_files:true + ~sandbox_actions:false ;; let set_action_stdout_on_success x t = { t with action_stdout_on_success = x } @@ -258,6 +271,7 @@ let set_workspace_root_to_build_path_prefix_map x t = ;; let set_action_project_root x t = { t with action_project_root = x } +let set_sandbox_actions x t = { t with sandbox_actions = x } let set_should_remove_write_permissions_on_generated_files x t = { t with should_remove_write_permissions_on_generated_files = x } diff --git a/src/dune_engine/execution_parameters.mli b/src/dune_engine/execution_parameters.mli index d70fe2e4fd6..11ebb62005f 100644 --- a/src/dune_engine/execution_parameters.mli +++ b/src/dune_engine/execution_parameters.mli @@ -81,6 +81,7 @@ val set_workspace_root_to_build_path_prefix_map val set_action_project_root : Path.Source.t option -> t -> t val set_should_remove_write_permissions_on_generated_files : bool -> t -> t +val set_sandbox_actions : bool -> t -> t (** As configured by [init] *) val default : t Memo.t diff --git a/src/dune_engine/process.ml b/src/dune_engine/process.ml index e13f4ff4ef0..4165e23f541 100644 --- a/src/dune_engine/process.ml +++ b/src/dune_engine/process.ml @@ -78,7 +78,10 @@ module Io = struct | Out : output mode type kind = - | File of Path.t + | File of + { path : Path.t + ; perm : Permissions.Mode.t + } | Null (* This argument make no sense for inputs, but it seems annoying to change, especially as this code is meant to change again in #4435. *) @@ -161,8 +164,8 @@ module Io = struct { kind = Null; fd; channel; status = Keep_open } ;; - let file : type a. _ -> ?perm:int -> a mode -> a t = - fun fn ?(perm = 0o666) mode -> + let file : type a. _ -> ?perm:Permissions.Mode.t -> a mode -> a t = + fun fn ?(perm = Permissions.Mode.default_file) mode -> let fd = lazy (let flags = @@ -170,11 +173,14 @@ module Io = struct | Out -> [ Unix.O_WRONLY; O_CREAT; O_TRUNC ] | In -> [ O_RDONLY ] in - Unix.openfile (Path.to_string fn) (O_CLOEXEC :: O_SHARE_DELETE :: flags) perm + Unix.openfile + (Path.to_string fn) + (O_CLOEXEC :: O_SHARE_DELETE :: flags) + (Permissions.Mode.to_int perm) |> Fd.unsafe_of_unix_file_descr) in let channel = lazy (channel_of_descr (Lazy.force fd) mode) in - { kind = File fn; fd; channel; status = Close_after_exec } + { kind = File { path = fn; perm }; fd; channel; status = Close_after_exec } ;; let flush : type a. a t -> unit = @@ -230,6 +236,7 @@ type metadata = ; compound : User_message.Compound.t list ; name : string option ; categories : string list + ; can_run_in_action_runner : bool ; purpose : purpose ; has_embedded_location : bool ; promotion : User_message.Diff_annot.t option @@ -241,6 +248,7 @@ let default_metadata = ; purpose = Internal_job ; categories = [] ; name = None + ; can_run_in_action_runner = false ; has_embedded_location = false ; promotion = None } @@ -252,18 +260,111 @@ let create_metadata ?(has_embedded_location = false) ?name ?(categories = default_metadata.categories) + ?(can_run_in_action_runner = false) ?(purpose = Internal_job) ?promotion () = - { loc; compound; name; categories; purpose; has_embedded_location; promotion } + { loc + ; compound + ; name + ; categories + ; can_run_in_action_runner + ; purpose + ; has_embedded_location + ; promotion + } ;; +module Build = struct + type t = + { run_id : Run_id.t + ; cancellation : Fiber.Cancel.t + } + + let current : t option ref = ref None + let get () = !current + + let with_ t f = + let previous = !current in + current := Some t; + Fiber.finalize f ~finally:(fun () -> + current := previous; + Fiber.return ()) + ;; + + let cancel_current () = + match !current with + | None -> Fiber.return () + | Some { cancellation; _ } -> Fiber.Cancel.fire cancellation + ;; +end + +module Runner = struct + module Input = struct + type t = + | Null + | Terminal + | File of Path.t + end + + module Output = struct + type t = + | Null + | Terminal + | File of + { path : Path.t + ; perm : Permissions.Mode.t + } + end + + module Stderr = struct + type t = + | Same_as_stdout + | Output of Output.t + end + + type request = + { dir : Path.t option + ; env : Env.t + ; metadata : metadata + ; prog : Path.t + ; args : string list + ; stdin_from : Input.t + ; stdout_to : Output.t + ; stderr_to : Stderr.t + ; create_process_group : bool + ; timeout : Time.Span.t option + ; queued : Time.Span.t + } + + type response = + { started_at : Time.t + ; process_info : Proc.Process_info.t + ; termination_reason : Scheduler.termination_reason + ; times : Proc.Times.t + ; trace_args : (string * Sexp.t) list + } + + let impl : (build:Build.t -> request -> response Fiber.t option) option ref = ref None + + let set f = + if Option.is_some !impl then Code_error.raise "process runner has already been set" []; + impl := Some f + ;; + + let run ~build t = + match !impl with + | None -> None + | Some f -> f ~build t + ;; +end + let io_to_redirection_path (kind : Io.kind) = match kind with | Terminal _ -> None | Null -> Some (Path.to_string Dev_null.path) - | File fn -> Some (Path.to_string fn) + | File { path; _ } -> Some (Path.to_string path) | External -> None ;; @@ -282,7 +383,7 @@ let command_line_enclosers let suffix = match stdin_from.kind with | Null | Terminal _ | External -> suffix - | File fn -> suffix ^ " < " ^ quote fn + | File { path; _ } -> suffix ^ " < " ^ quote path in let suffix = match @@ -814,7 +915,15 @@ module Result = struct ;; end -let report_process_finished +let targets_of_metadata metadata = + match metadata.purpose with + | Internal_job -> None + | Build_job None -> None + | Build_job (Some { dirs; files; root }) -> Some { Dune_trace.Event.root; dirs; files } +;; + +let emit_process_finished + ?(extra_args = []) ~metadata ~dir ~prog @@ -826,20 +935,12 @@ let report_process_finished ~stderr (times : Proc.Times.t) = - let targets = - match metadata.purpose with - | Internal_job -> None - | Build_job None -> None - | Build_job (Some { dirs; files; root }) -> - Some { Dune_trace.Event.root; dirs; files } - in - let stdout = Result.Out.get stdout in - let stderr = Result.Out.get stderr in Dune_trace.emit Process (fun () -> Dune_trace.Event.process + ~extra_args ~name:metadata.name ~started_at - ~targets + ~targets:(targets_of_metadata metadata) ~categories:metadata.categories ~pid ~exit:exit_status @@ -851,28 +952,47 @@ let report_process_finished ~(times : Proc.Times.t)) ;; -let await ~timeout { response_file; pid; is_process_group_leader; _ } = - let+ process_info, termination_reason = - Scheduler.wait_for_build_process ?timeout pid ~is_process_group_leader - in - Option.iter response_file ~f:(fun path -> path |> Path.to_string |> Fpath.unlink_exn); - process_info, termination_reason -;; - -let spawn - ?dir - ?(env = Env.initial) - ~(stdout : _ Io.t) - ~(stderr : _ Io.t) - ~(stdin : _ Io.t) - ~queued - ~setpgid +let report_process_finished + ?(extra_args = []) + ~metadata + ~dir ~prog + ~pid ~args - ~metadata - ~timeout - () + ~started_at + ~exit_status + ~stdout + ~stderr + (times : Proc.Times.t) = + let stdout = Result.Out.get stdout in + let stderr = Result.Out.get stderr in + emit_process_finished + ~extra_args + ~metadata + ~dir + ~prog + ~pid + ~args + ~started_at + ~exit_status + ~stdout + ~stderr + times +;; + +type prepared_outputs = + { stdout_on_success : Action_output_on_success.t + ; stderr_on_success : Action_output_on_success.t + ; stdout_limit : Action_output_limit.t + ; stderr_limit : Action_output_limit.t + ; stdout_capture : Path.t option + ; stderr_capture : Path.t option + ; stdout : Io.output Io.t + ; stderr : Io.output Io.t + } + +let prepare_outputs ~(stdout : _ Io.t) ~(stderr : _ Io.t) = let stdout_on_success = Io.output_on_success stdout and stderr_on_success = Io.output_on_success stderr in let stdout_limit = Io.output_limit stdout @@ -898,11 +1018,6 @@ let spawn , Terminal { output_on_success = Print; _ } ) | ( Terminal { output_on_success = Swallow; _ } , Terminal { output_on_success = Swallow; _ } ) -> - (* We don't merge when both are [Must_be_empty]. If we did and an - action had unexpected output on both stdout and stderr the - error message would be "has unexpected output on stdout". With - the current code, it is "has unexpected output on stdout and - stderr", which is more precise. *) Io.flush stderr; None, stdout | _, Terminal _ -> @@ -913,6 +1028,51 @@ let spawn (stdout_capture, stdout), stderr | _ -> (None, stdout), (None, stderr) in + { stdout_on_success + ; stderr_on_success + ; stdout_limit + ; stderr_limit + ; stdout_capture + ; stderr_capture + ; stdout + ; stderr + } +;; + +let await ?cancellation ~timeout { response_file; pid; is_process_group_leader; _ } = + let+ process_info, termination_reason = + Scheduler.wait_for_build_process ?cancellation ?timeout pid ~is_process_group_leader + in + Option.iter response_file ~f:(fun path -> path |> Path.to_string |> Fpath.unlink_exn); + process_info, termination_reason +;; + +let spawn + ?dir + ?(env = Env.initial) + ?(emit_trace = true) + ~(prepared_outputs : prepared_outputs) + ~(stdin : _ Io.t) + ~queued + ~setpgid + ~prog + ~args + ~metadata + ~timeout + () + = + let { stdout_on_success + ; stderr_on_success + ; stdout_limit + ; stderr_limit + ; stdout_capture + ; stderr_capture + ; stdout + ; stderr + } + = + prepared_outputs + in let prog_str = Path.reach_for_running ?from:dir prog in (* Normalise to backslashes on Windows. Dune's path representation uses '/' across platforms for consistency, but some Windows programs (notably @@ -965,25 +1125,21 @@ let spawn | Some dir -> Path (Path.to_string dir)) |> Pid.of_int in - Dune_trace.emit Process (fun () -> - let targets = - match metadata.purpose with - | Internal_job -> None - | Build_job None -> None - | Build_job (Some { dirs; files; root }) -> - Some { Dune_trace.Event.root; dirs; files } - in - Dune_trace.Event.process_start - ~targets - ~pid - ~dir - ~prog:prog_str - ~args - ~timeout - ~name:metadata.name - ~categories:metadata.categories - ~started_at - ~queued); + if emit_trace + then + Dune_trace.emit Process (fun () -> + Dune_trace.Event.process_start + ~extra_args:[] + ~targets:(targets_of_metadata metadata) + ~pid + ~dir + ~prog:prog_str + ~args + ~timeout + ~name:metadata.name + ~categories:metadata.categories + ~started_at + ~queued); Io.release stdout; Io.release stderr; { started_at @@ -999,6 +1155,163 @@ let spawn } ;; +let runner_input_of_io (io : Io.input Io.t) = + match io.kind with + | Null -> Some Runner.Input.Null + | Terminal _ -> Some Runner.Input.Terminal + | File { path; _ } -> Some (Runner.Input.File path) + | External -> None +;; + +let runner_output_of_io (io : Io.output Io.t) = + match io.kind with + | Null -> Some Runner.Output.Null + | Terminal _ -> Some Runner.Output.Terminal + | File { path; perm } -> Some (Runner.Output.File { path; perm }) + | External -> None +;; + +let runner_request + ~dir + ~env + ~metadata + ~prog + ~args + ~(stdin_from : Io.input Io.t) + ~(stdout_to : Io.output Io.t) + ~(stderr_to : Io.output Io.t) + ~setpgid + ~timeout + ~queued + = + if not metadata.can_run_in_action_runner + then None + else ( + match + ( runner_input_of_io stdin_from + , runner_output_of_io stdout_to + , Stdlib.( == ) stdout_to stderr_to ) + with + | Some stdin_from, Some stdout_to, true -> + Some + { Runner.dir + ; env + ; metadata + ; prog + ; args + ; stdin_from + ; stdout_to + ; stderr_to = Runner.Stderr.Same_as_stdout + ; create_process_group = Option.is_some setpgid + ; timeout + ; queued + } + | Some stdin_from, Some stdout_to, false -> + (match runner_output_of_io stderr_to with + | None -> None + | Some stderr_to -> + Some + { Runner.dir + ; env + ; metadata + ; prog + ; args + ; stdin_from + ; stdout_to + ; stderr_to = Runner.Stderr.Output stderr_to + ; create_process_group = Option.is_some setpgid + ; timeout + ; queued + }) + | None, _, _ | _, None, _ -> None) +;; + +let exec_locally + ~build + ({ Runner.dir + ; env + ; metadata + ; prog + ; args + ; stdin_from + ; stdout_to + ; stderr_to + ; create_process_group + ; timeout + ; queued + } : + Runner.request) + = + let stdin = + match stdin_from with + | Null -> Io.null Io.In + | Terminal -> Io.stdin + | File path -> Io.file path Io.In + in + let stdout = + match stdout_to with + | Null -> Io.null Io.Out + | Terminal -> Io.stdout + | File { path; perm } -> Io.file path Io.Out ~perm + in + let stderr = + let stderr_to : Runner.Stderr.t = stderr_to in + let open Runner.Stderr in + match stderr_to with + | Same_as_stdout -> stdout + | Output (out : Runner.Output.t) -> + (match out with + | Null -> Io.null Io.Out + | Terminal -> Io.stderr + | File { path; perm } -> Io.file path Io.Out ~perm) + in + let prepared_outputs = + { stdout_on_success = Io.output_on_success stdout + ; stderr_on_success = Io.output_on_success stderr + ; stdout_limit = Io.output_limit stdout + ; stderr_limit = Io.output_limit stderr + ; stdout_capture = None + ; stderr_capture = None + ; stdout + ; stderr + } + in + Fiber.finalize + (fun () -> + let t = + spawn + ?dir + ~env + ~emit_trace:false + ~prepared_outputs + ~stdin + ~queued + ~setpgid: + (if create_process_group then Some Spawn.Pgid.new_process_group else None) + ~prog + ~args + ~metadata + ~timeout + () + in + let { Build.cancellation; _ } = build in + let+ process_info, termination_reason = await ~cancellation ~timeout t in + let times = + { Proc.Times.elapsed_time = Time.diff process_info.end_time t.started_at + ; resource_usage = process_info.resource_usage + } + in + { Runner.started_at = t.started_at + ; process_info + ; termination_reason + ; times + ; trace_args = [] + }) + ~finally:(fun () -> + Io.release stdin; + Fiber.return ()) +;; + let run_internal ?dir ~(display : Display.t) @@ -1008,12 +1321,21 @@ let run_internal ?env ?(metadata = default_metadata) ?(setpgid = Some Spawn.Pgid.new_process_group) + ?build fail_mode prog args = let start = Time.now () in - Scheduler.with_job_slot (fun () -> + let build = + match build with + | Some _ -> build + | None -> Build.get () + in + let cancellation = + Option.map build ~f:(fun { Build.cancellation; _ } -> cancellation) + in + Scheduler.with_job_slot ?cancellation (fun () -> let queued = Time.diff (Time.now ()) start in let dir = match dir with @@ -1043,96 +1365,184 @@ let run_internal | _ -> Pp.nop in let timeout = Failure_mode.timeout fail_mode in - let (t : t) = - spawn - ?dir - ?env - ~queued - ~stdout:stdout_to - ~stderr:stderr_to - ~stdin:stdin_from - ~setpgid - ~prog - ~args - ~metadata - ~timeout - () - in - let* () = - let description = - (* CR-soon amokhov: What happens with actions attached to aliases? Do they go into - [Build_job None] category? Can produce more informative description for them? *) - match metadata.purpose with - | Internal_job -> Pp.text "(internal)" - | Build_job None -> Pp.text "(no targets)" - | Build_job (Some target) -> - Targets.Validated.head target - |> Path.Build.to_string_maybe_quoted - |> Pp.verbatim + let prepared_outputs = prepare_outputs ~stdout:stdout_to ~stderr:stderr_to in + let env = Option.value env ~default:Env.initial in + let local () = + let t = + spawn + ?dir + ~env + ~prepared_outputs + ~stdin:stdin_from + ~queued + ~setpgid + ~prog + ~args + ~metadata + ~timeout + () + in + let* () = + let description = + match metadata.purpose with + | Internal_job -> Pp.text "(internal)" + | Build_job None -> Pp.text "(no targets)" + | Build_job (Some target) -> + Targets.Validated.head target + |> Path.Build.to_string_maybe_quoted + |> Pp.verbatim + in + Running_jobs.start id t.pid ~description ~started_at:t.started_at in - Running_jobs.start id t.pid ~description ~started_at:t.started_at + let* process_info, termination_reason = await ?cancellation ~timeout t in + let+ () = Running_jobs.stop id in + let times = + { Proc.Times.elapsed_time = Time.diff process_info.end_time t.started_at + ; resource_usage = process_info.resource_usage + } + in + t, process_info, termination_reason, times, None, [] in - let* process_info, termination_reason = await ~timeout t in - let+ () = Running_jobs.stop id in - let result = Result.make t process_info fail_mode in - let times = - { Proc.Times.elapsed_time = Time.diff process_info.end_time t.started_at - ; resource_usage = process_info.resource_usage - } + let* t, process_info, termination_reason, times, remote_started_at, trace_args = + match + runner_request + ~dir + ~env + ~metadata + ~prog + ~args + ~stdin_from + ~stdout_to:prepared_outputs.stdout + ~stderr_to:prepared_outputs.stderr + ~setpgid + ~timeout + ~queued + with + | Some request -> + (match Option.bind build ~f:(fun build -> Runner.run ~build request) with + | Some response -> + Io.release prepared_outputs.stdout; + Io.release prepared_outputs.stderr; + let+ { Runner.started_at; process_info; termination_reason; times; trace_args } + = + response + in + let dummy_process = + { started_at + ; pid = process_info.pid + ; is_process_group_leader = Option.is_some setpgid + ; response_file = None + ; stdout = prepared_outputs.stdout_capture + ; stderr = prepared_outputs.stderr_capture + ; stdout_on_success = prepared_outputs.stdout_on_success + ; stderr_on_success = prepared_outputs.stderr_on_success + ; stdout_limit = prepared_outputs.stdout_limit + ; stderr_limit = prepared_outputs.stderr_limit + } + in + ( dummy_process + , process_info + , termination_reason + , times + , Some started_at + , trace_args ) + | None -> local ()) + | None -> local () in - report_process_finished - ~metadata - ~dir - ~prog:prog_str - ~pid:t.pid - ~args - ~started_at:t.started_at - ~exit_status:result.exit_status - ~stdout:result.stdout - ~stderr:result.stderr - times; - match termination_reason with - | Cancel -> - (* if the cancellation token was fired, then we: - - 1) aren't interested in printing the output from the cancelled job - - 2) allowing callers to continue work with the already stale value - we're about to return. *) - Result.close result; - raise (Memo.Non_reproducible Scheduler.Run.Build_cancelled) - | Timeout -> `Timeout, times - | Normal -> - let output = Result.Out.get result.stdout ^ Result.Out.get result.stderr in - Log.command ~command_line ~output ~exit_status:process_info.status; - let res = - match display, result.exit_status, output with - | Quiet, Ok n, "" -> n (* Optimisation for the common case *) - | Verbose, _, _ -> - Handle_exit_status.verbose - result.exit_status - ~id - ~metadata - ~dir - ~command_line:fancy_command_line - ~output - | _ -> - Handle_exit_status.non_verbose - result.exit_status - ~prog:prog_str - ~dir - ~command_line - ~output - ~metadata - ~verbosity:display - ~has_unexpected_stdout:result.stdout.unexpected_output - ~has_unexpected_stderr:result.stderr.unexpected_output - in - Result.close result; - `Finished res, times) + let result = Result.make t process_info fail_mode in + (match remote_started_at with + | None -> + report_process_finished + ~metadata + ~dir + ~prog:prog_str + ~pid:t.pid + ~args + ~started_at:t.started_at + ~exit_status:result.exit_status + ~stdout:result.stdout + ~stderr:result.stderr + times + | Some started_at -> + Dune_trace.emit Process (fun () -> + Dune_trace.Event.process_start + ~extra_args:trace_args + ~targets:(targets_of_metadata metadata) + ~pid:process_info.pid + ~dir + ~prog:prog_str + ~args + ~timeout + ~name:metadata.name + ~categories:metadata.categories + ~started_at + ~queued); + report_process_finished + ~extra_args:trace_args + ~metadata + ~dir + ~prog:prog_str + ~pid:process_info.pid + ~args + ~started_at + ~exit_status:result.exit_status + ~stdout:result.stdout + ~stderr:result.stderr + times); + Fiber.return + (match termination_reason with + | Cancel -> + (* if the cancellation token was fired, then we: + + 1) aren't interested in printing the output from the cancelled job + + 2) allowing callers to continue work with the already stale value + we're about to return. *) + Result.close result; + raise (Memo.Non_reproducible Scheduler.Run.Build_cancelled) + | Timeout -> `Timeout, times + | Normal -> + let output = Result.Out.get result.stdout ^ Result.Out.get result.stderr in + Log.command ~command_line ~output ~exit_status:process_info.status; + let res = + match display, result.exit_status, output with + | Quiet, Ok n, "" -> n (* Optimisation for the common case *) + | Verbose, _, _ -> + Handle_exit_status.verbose + result.exit_status + ~id + ~metadata + ~dir + ~command_line:fancy_command_line + ~output + | _ -> + Handle_exit_status.non_verbose + result.exit_status + ~prog:prog_str + ~dir + ~command_line + ~output + ~metadata + ~verbosity:display + ~has_unexpected_stdout:result.stdout.unexpected_output + ~has_unexpected_stderr:result.stderr.unexpected_output + in + Result.close result; + `Finished res, times)) ;; -let run ?dir ~display ?stdout_to ?stderr_to ?stdin_from ?env ?metadata fail_mode prog args +let run + ?dir + ~display + ?stdout_to + ?stderr_to + ?stdin_from + ?env + ?metadata + ?build + fail_mode + prog + args = let+ run, _ = run_internal @@ -1143,6 +1553,7 @@ let run ?dir ~display ?stdout_to ?stderr_to ?stdin_from ?env ?metadata fail_mode ?stdin_from ?env ?metadata + ?build fail_mode prog args @@ -1158,6 +1569,7 @@ let run_with_times ?stdin_from ?env ?metadata + ?build fail_mode prog args @@ -1171,6 +1583,7 @@ let run_with_times ?stdin_from ?env ?metadata + ?build fail_mode prog args @@ -1185,6 +1598,7 @@ let run_capture_gen ?stdin_from ?env ?metadata + ?build fail_mode prog args @@ -1200,6 +1614,7 @@ let run_capture_gen ?stdin_from ?env ?metadata + ?build fail_mode prog args @@ -1221,6 +1636,7 @@ let run_capture_line ?stdin_from ?env ?metadata + ?build fail_mode prog args @@ -1232,6 +1648,7 @@ let run_capture_line ?stdin_from ?env ?metadata + ?build fail_mode prog args diff --git a/src/dune_engine/process.mli b/src/dune_engine/process.mli index 88b64645883..3f089cec29d 100644 --- a/src/dune_engine/process.mli +++ b/src/dune_engine/process.mli @@ -56,7 +56,7 @@ module Io : sig input from the file. The returned channel can only be used by a single call to {!run}. If you want to use it multiple times, you need to use [clone]. *) - val file : Path.t -> ?perm:int -> 'a mode -> 'a t + val file : Path.t -> ?perm:Permissions.Mode.t -> 'a mode -> 'a t (** Call this when you no longer need this redirection *) val release : 'a t -> unit @@ -78,6 +78,9 @@ type metadata = ; name : string option (** name when emitting stats. defaults to the basename of the executable *) ; categories : string list (** additional categories when emitting stats *) + ; can_run_in_action_runner : bool + (** Whether the process may be delegated to the action runner when one is + active. *) ; purpose : purpose ; has_embedded_location : bool ; promotion : User_message.Diff_annot.t option @@ -89,11 +92,82 @@ val create_metadata -> ?has_embedded_location:bool -> ?name:string -> ?categories:string list + -> ?can_run_in_action_runner:bool -> ?purpose:purpose -> ?promotion:User_message.Diff_annot.t -> unit -> metadata +module Build : sig + type t = + { run_id : Run_id.t + ; cancellation : Fiber.Cancel.t + } + + val get : unit -> t option + val with_ : t -> (unit -> 'a Fiber.t) -> 'a Fiber.t + val cancel_current : unit -> unit Fiber.t +end + +module Runner : sig + module Input : sig + type t = + | Null + | Terminal + | File of Path.t + end + + module Output : sig + type t = + | Null + | Terminal + | File of + { path : Path.t + ; perm : Permissions.Mode.t + } + end + + module Stderr : sig + type t = + | Same_as_stdout + | Output of Output.t + end + + (** The current runner contract is path-based: stdin/stdout/stderr file + redirections assume the runner executes in the same filesystem namespace + as the parent process. *) + type request = + { dir : Path.t option + ; env : Env.t + ; metadata : metadata + ; prog : Path.t + ; args : string list + ; stdin_from : Input.t + ; stdout_to : Output.t + ; stderr_to : Stderr.t + ; create_process_group : bool + ; timeout : Time.Span.t option + ; queued : Time.Span.t + } + + type response = + { started_at : Time.t + ; process_info : Proc.Process_info.t + ; termination_reason : Scheduler.termination_reason + ; times : Proc.Times.t + ; trace_args : (string * Sexp.t) list + (** Extra fields to append to the parent-owned process trace events. *) + } + + (** Install the process runner hook for this process. The installed runner is + expected to preserve the path-based redirection contract of [request]. *) + val set : (build:Build.t -> request -> response Fiber.t option) -> unit +end + +(** Execute a [Runner.request] locally without taking another scheduler job + slot. This is intended for the external worker implementation. *) +val exec_locally : build:Build.t -> Runner.request -> Runner.response Fiber.t + (** [run ?dir ?stdout_to prog args] spawns a sub-process and wait for its termination. [stdout_to] [stderr_to] are released *) val run @@ -104,6 +178,7 @@ val run -> ?stdin_from:Io.input Io.t -> ?env:Env.t -> ?metadata:metadata + -> ?build:Build.t -> (unit, 'a) Failure_mode.t -> Path.t -> string list @@ -117,6 +192,7 @@ val run_with_times -> ?stdin_from:Io.input Io.t -> ?env:Env.t -> ?metadata:metadata + -> ?build:Build.t -> (Proc.Times.t, 'a) Failure_mode.t -> Path.t -> string list @@ -130,6 +206,7 @@ val run_capture -> ?stdin_from:Io.input Io.t -> ?env:Env.t -> ?metadata:metadata + -> ?build:Build.t -> (string, 'a) Failure_mode.t -> Path.t -> string list @@ -142,6 +219,7 @@ val run_capture_line -> ?stdin_from:Io.input Io.t -> ?env:Env.t -> ?metadata:metadata + -> ?build:Build.t -> (string, 'a) Failure_mode.t -> Path.t -> string list @@ -154,6 +232,7 @@ val run_capture_lines -> ?stdin_from:Io.input Io.t -> ?env:Env.t -> ?metadata:metadata + -> ?build:Build.t -> (string list, 'a) Failure_mode.t -> Path.t -> string list @@ -166,6 +245,7 @@ val run_capture_zero_separated -> ?stdin_from:Io.input Io.t -> ?env:Env.t -> ?metadata:metadata + -> ?build:Build.t -> (string list, 'a) Failure_mode.t -> Path.t -> string list diff --git a/src/dune_patch/dune_patch.ml b/src/dune_patch/dune_patch.ml index 72739f7b143..01630978acc 100644 --- a/src/dune_patch/dune_patch.ml +++ b/src/dune_patch/dune_patch.ml @@ -182,6 +182,7 @@ module Action = Action_ext.Make (struct let name = "patch" let version = 3 + let runs_process = false let bimap patch f _ = f patch let is_useful_to ~memoize = memoize let encode patch input _ : Sexp.t = input patch diff --git a/src/dune_rpc_impl/server.ml b/src/dune_rpc_impl/server.ml index 0efabb530d9..20ac4325735 100644 --- a/src/dune_rpc_impl/server.ml +++ b/src/dune_rpc_impl/server.ml @@ -13,6 +13,7 @@ end include struct open Dune_engine module Diff_promotion = Diff_promotion + module Action_runner = Action_runner end include struct @@ -27,6 +28,7 @@ module Csexp_rpc = Rpc.Csexp_rpc module Run = struct type t = { handler : Rpc.Server.t + ; action_runner : Action_runner.Rpc_server.t ; pool : Fiber.Pool.t ; root : string ; where : Dune_rpc.Where.t @@ -157,11 +159,14 @@ let ready (t : _ t) = ;; let stop (t : _ t) = - Fiber.of_thunk (fun () -> - match Fiber.Ivar.peek t.server.config.startup_ivar with - | None -> Fiber.return () - | Some (Error _) -> Fiber.return () - | Some (Ok server) -> Csexp_rpc.Server.stop server) + Fiber.fork_and_join_unit + (fun () -> Action_runner.Rpc_server.stop t.server.config.action_runner) + (fun () -> + Fiber.of_thunk (fun () -> + match Fiber.Ivar.peek t.server.config.startup_ivar with + | None -> Fiber.return () + | Some (Error _) -> Fiber.return () + | Some (Ok server) -> Csexp_rpc.Server.stop server)) ;; let current_errors () = @@ -183,7 +188,7 @@ let enqueue_pending_action (t : _ t) kind = Fiber.Ivar.read outcome ;; -let handler (t : _ t Fdecl.t) : 'build_arg Handler.t = +let handler (t : _ t Fdecl.t) action_runner_server : 'build_arg Handler.t = let on_init session (_ : Initialize.Request.t) = let t = Fdecl.get t in let client = () in @@ -368,7 +373,7 @@ let handler (t : _ t Fdecl.t) : 'build_arg Handler.t = Session.Stage1.close entry.session)) in let shutdown () = - let* () = Csexp_rpc.Server.stop (Lazy.force t.server.config.server) in + let* () = stop t in Scheduler.shutdown (); Fiber.return () in @@ -433,6 +438,7 @@ let handler (t : _ t Fdecl.t) : 'build_arg Handler.t = let f _ () = Fiber.return Path.Build.(to_string root) in Handler.implement_request rpc Procedures.Public.build_dir f in + Action_runner.Rpc_server.implement_handler action_runner_server rpc; Dune_rules_rpc.register rpc; rpc ;; @@ -441,6 +447,9 @@ let create ~registry ~root watch_mode = let where = Where.default () in Global_lock.lock_exn (); let t = Fdecl.create Dyn.opaque in + let pending_jobs = Job_queue.create () in + let action_runner = Action_runner.Rpc_server.create () in + let pool = Fiber.Pool.create () in let config = let server = lazy @@ -462,9 +471,10 @@ let create ~registry ~root watch_mode = (Path.Build.to_string_maybe_quoted (Where.rpc_socket_file ())) ]) in - let handler = Rpc.Server.make (handler t) in + let handler = Rpc.Server.make (handler t action_runner) in { Run.handler - ; pool = Fiber.Pool.create () + ; action_runner + ; pool ; root ; where ; server @@ -474,22 +484,27 @@ let create ~registry ~root watch_mode = } in let server = { config; clients = Clients.empty } in - let res = { server; pending_jobs = Job_queue.create () } in + let res = { server; pending_jobs } in current := Some server; Fdecl.set t res; res ;; let run t = + let run () = + Fiber.fork_and_join_unit + (fun () -> Run.run t.server.config) + (fun () -> Action_runner.Rpc_server.run t.server.config.action_runner) + in match t.server.config.registry with - | `Skip -> Run.run t.server.config + | `Skip -> run () | `Add -> let section = Console.Status_line.add_section (Live (fun () -> pp_client_count t)) in - Fiber.finalize - (fun () -> Run.run t.server.config) - ~finally:(fun () -> - Console.Status_line.remove_section section; - Fiber.return ()) + Fiber.finalize run ~finally:(fun () -> + Console.Status_line.remove_section section; + Fiber.return ()) ;; let pending_action t = Job_queue.read t.pending_jobs +let listening_address t = t.server.config.where +let action_runner t = t.server.config.action_runner diff --git a/src/dune_rpc_impl/server.mli b/src/dune_rpc_impl/server.mli index 9c981f1f6c0..ed3dbfcbc20 100644 --- a/src/dune_rpc_impl/server.mli +++ b/src/dune_rpc_impl/server.mli @@ -33,3 +33,5 @@ val stop : _ t -> unit Fiber.t val ready : _ t -> unit Fiber.t val run : _ t -> unit Fiber.t +val listening_address : _ t -> Dune_rpc.Where.t +val action_runner : _ t -> Dune_engine.Action_runner.Rpc_server.t diff --git a/src/dune_rules/action_unexpanded.ml b/src/dune_rules/action_unexpanded.ml index 9803ce7671b..63222af607d 100644 --- a/src/dune_rules/action_unexpanded.ml +++ b/src/dune_rules/action_unexpanded.ml @@ -654,7 +654,8 @@ let expand_no_targets t sandbox ~loc ~chdir ~deps:deps_written_by_user ~expander and+ env and+ action in let action = Action.Chdir (Path.build chdir, action) in - Action.Full.make action ~sandbox |> Action.Full.add_env env + Action.Full.make action ~sandbox ~can_run_in_action_runner:true + |> Action.Full.add_env env ;; let expand @@ -714,7 +715,10 @@ let expand let+ sandbox and+ env and+ action in - Action.Full.make (Action.Chdir (Path.build chdir, action)) ~sandbox + Action.Full.make + (Action.Chdir (Path.build chdir, action)) + ~sandbox + ~can_run_in_action_runner:true |> Action.Full.add_env env in Action_builder.with_targets ~targets build diff --git a/src/dune_rules/cc_flags.ml b/src/dune_rules/cc_flags.ml index a50746064e7..65cd105417e 100644 --- a/src/dune_rules/cc_flags.ml +++ b/src/dune_rules/cc_flags.ml @@ -62,6 +62,7 @@ module Detect = struct let version = 1 let bimap t f _ = { t with c_compiler = f t.c_compiler } let is_useful_to ~memoize:_ = true + let runs_process = true let encode { c_compiler; ccomp_type } path _target = Sexp.List diff --git a/src/dune_rules/command.ml b/src/dune_rules/command.ml index 90b2fefbe48..6ef72f4a662 100644 --- a/src/dune_rules/command.ml +++ b/src/dune_rules/command.ml @@ -124,7 +124,15 @@ let dep_prog = function | Error _ -> Action_builder.return () ;; -let run_dyn_prog ~dir ?sandbox ?stdout_to ?env prog args = +let run_dyn_prog + ~dir + ?sandbox + ?stdout_to + ?env + ?(can_run_in_action_runner = false) + prog + args + = Action_builder.With_targets.add ~file_targets:(Option.to_list stdout_to) (let open Action_builder.With_targets.O in @@ -143,19 +151,25 @@ let run_dyn_prog ~dir ?sandbox ?stdout_to ?env prog args = | None -> Action_builder.return None) in let action = - let action = Action.Run (prog, args) in match stdout_to with - | None -> action - | Some path -> Action.with_stdout_to path action + | None -> Action.Run (prog, args) + | Some path -> Action.with_stdout_to path (Action.Run (prog, args)) in - Action.chdir dir action |> Action.Full.make ?sandbox ?env) + Action.chdir dir action |> Action.Full.make ?sandbox ?env ~can_run_in_action_runner) ;; -let run ~dir ?sandbox ?stdout_to ?env prog args = - run_dyn_prog ~dir ?sandbox ?stdout_to ?env (Action_builder.return prog) args +let run ~dir ?sandbox ?stdout_to ?env ?can_run_in_action_runner prog args = + run_dyn_prog + ~dir + ?sandbox + ?stdout_to + ?env + ?can_run_in_action_runner + (Action_builder.return prog) + args ;; -let run' ?sandbox ?env ~dir prog args = +let run' ?sandbox ?env ~dir ?(can_run_in_action_runner = false) prog args = let open Action_builder.O in let+ () = dep_prog prog and+ args = expand_list_no_targets ~dir args @@ -164,7 +178,9 @@ let run' ?sandbox ?env ~dir prog args = | Some env -> Action_builder.map env ~f:Option.some | None -> Action_builder.return None in - Action.Run (prog, args) |> Action.chdir dir |> Action.Full.make ?sandbox ?env + Action.Run (prog, args) + |> Action.chdir dir + |> Action.Full.make ?sandbox ?env ~can_run_in_action_runner ;; let quote_args = diff --git a/src/dune_rules/command.mli b/src/dune_rules/command.mli index dc45ce49d38..4145d44b9dc 100644 --- a/src/dune_rules/command.mli +++ b/src/dune_rules/command.mli @@ -77,6 +77,7 @@ val run_dyn_prog -> ?sandbox:Sandbox_config.t -> ?stdout_to:Path.Build.t -> ?env:Env.t Action_builder.t + -> ?can_run_in_action_runner:bool -> Action.Prog.t Action_builder.t -> Args.any Args.t list -> Action.Full.t Action_builder.With_targets.t @@ -86,6 +87,7 @@ val run -> ?sandbox:Sandbox_config.t -> ?stdout_to:Path.Build.t -> ?env:Env.t Action_builder.t + -> ?can_run_in_action_runner:bool -> Action.Prog.t -> Args.any Args.t list -> Action.Full.t Action_builder.With_targets.t @@ -95,6 +97,7 @@ val run' : ?sandbox:Sandbox_config.t -> ?env:Env.t Action_builder.t -> dir:Path.t + -> ?can_run_in_action_runner:bool -> Action.Prog.t -> Args.without_targets Args.t list -> Action.Full.t Action_builder.t diff --git a/src/dune_rules/copy_line_directive.ml b/src/dune_rules/copy_line_directive.ml index 0426dc85131..1015dd36f6a 100644 --- a/src/dune_rules/copy_line_directive.ml +++ b/src/dune_rules/copy_line_directive.ml @@ -71,6 +71,7 @@ module Spec = struct let name = "copy-line-directive" let version = 2 + let runs_process = false let bimap (src, dst, merlin) f g = f src, g dst, merlin let is_useful_to ~memoize = memoize diff --git a/src/dune_rules/cram/cram_exec.ml b/src/dune_rules/cram/cram_exec.ml index 717bad14c34..68ad9a92527 100644 --- a/src/dune_rules/cram/cram_exec.ml +++ b/src/dune_rules/cram/cram_exec.ml @@ -571,7 +571,7 @@ let run_cram_test |> Path.drop_build_context_exn |> Path.Source.to_string in - Process.create_metadata ~name ~categories:[ "cram" ] () + Process.create_metadata ~can_run_in_action_runner:true ~name ~categories:[ "cram" ] () in Process.run ~display:Quiet @@ -727,6 +727,7 @@ module Run = struct let name = "cram-run" let version = 6 + let runs_process = true let bimap ({ src = _; dir; script; output; timeout; setup_scripts; shell = _ } as t) @@ -794,6 +795,7 @@ module Make_script = struct let name = "cram-generate" let version = 2 + let runs_process = false let bimap t f g = { t with script = f t.script; target = g t.target } let is_useful_to ~memoize:_ = true @@ -840,6 +842,7 @@ module Diff = struct let name = "cram-generate" let version = 1 + let runs_process = false let bimap { script; out } f _ = { script = f script; out = f out } let is_useful_to ~memoize:_ = true let encode { script; out } path _ : Sexp.t = List [ path script; path out ] @@ -891,6 +894,7 @@ module Action = struct let name = "cram" let version = 2 + let runs_process = true let bimap path f _ = f path let is_useful_to ~memoize:_ = true let encode script path _ : Sexp.t = List [ path script ] diff --git a/src/dune_rules/dep_rules.ml b/src/dune_rules/dep_rules.ml index b9e70e4768d..e6297f736c0 100644 --- a/src/dune_rules/dep_rules.ml +++ b/src/dune_rules/dep_rules.ml @@ -11,6 +11,7 @@ module Merge_dep_output = struct let name = "merge_dep_output" let version = 3 + let runs_process = false let is_useful_to ~memoize:_ = true let bimap diff --git a/src/dune_rules/fetch_rules.ml b/src/dune_rules/fetch_rules.ml index 2c31de81418..a2219540d19 100644 --- a/src/dune_rules/fetch_rules.ml +++ b/src/dune_rules/fetch_rules.ml @@ -75,6 +75,7 @@ module Spec = struct let name = "source-fetch" let version = 2 + let runs_process = false let bimap t _ g = { t with target = g t.target } let is_useful_to ~memoize = memoize @@ -303,6 +304,7 @@ module Copy = struct let name = "copy-dir" let version = 2 + let runs_process = false let bimap t f g = { src_dir = f t.src_dir; dst_dir = g t.dst_dir } let is_useful_to ~memoize = memoize diff --git a/src/dune_rules/format_dune_file.ml b/src/dune_rules/format_dune_file.ml index 871cf8fd113..02a7a665b43 100644 --- a/src/dune_rules/format_dune_file.ml +++ b/src/dune_rules/format_dune_file.ml @@ -6,6 +6,7 @@ module To_file = struct let name = "format-dune-file" let version = 1 + let runs_process = false let bimap (ver, src, dst) f g = ver, f src, g dst let is_useful_to ~memoize = memoize @@ -32,6 +33,7 @@ module To_stdout = struct let name = "format-dune-file-stdout" let version = 1 + let runs_process = false let bimap (ver, src) f _ = ver, f src let is_useful_to ~memoize = memoize diff --git a/src/dune_rules/inline_tests.ml b/src/dune_rules/inline_tests.ml index 04847f01bb8..8c9af95b412 100644 --- a/src/dune_rules/inline_tests.ml +++ b/src/dune_rules/inline_tests.ml @@ -33,7 +33,7 @@ let action | Native | Best | Byte -> None | Jsoo _ -> Some Jsoo_rules.runner with - | None -> flags >>| Action.run (Ok exe) + | None -> flags >>| fun flags -> Action.run (Ok exe) flags | Some runner -> let* prog = Super_context.resolve_program @@ -393,7 +393,8 @@ include Sub_system.Register_end_point (struct let action = let+ action = test_action mode partitions_flags and+ env in - Action.Full.make ~sandbox action |> Action.Full.add_env env + Action.Full.make ~sandbox ~can_run_in_action_runner:true action + |> Action.Full.add_env env in let+ partitions = Super_context.execute_action_stdout sctx ~loc ~dir action @@ -462,7 +463,10 @@ include Sub_system.Register_end_point (struct |> Action.diff ~optional:true fn) |> Action.concurrent in - Action.Full.make ~sandbox (Action.progn [ run_tests; diffs ]) + Action.Full.make + ~sandbox + ~can_run_in_action_runner:true + (Action.progn [ run_tests; diffs ]) |> Action.Full.add_env env)) ;; diff --git a/src/dune_rules/install_rules.ml b/src/dune_rules/install_rules.ml index 2fb3a820dd4..226f5ed845d 100644 --- a/src/dune_rules/install_rules.ml +++ b/src/dune_rules/install_rules.ml @@ -1302,6 +1302,7 @@ struct let name = "gen-install-file" let version = 2 + let runs_process = false let bimap (entries, dst) _ g = entries, g dst let is_useful_to ~memoize = memoize let encode (_entries, dst) _path target : Sexp.t = List [ target dst ] diff --git a/src/dune_rules/lock_rules.ml b/src/dune_rules/lock_rules.ml index a9806ba68a0..a44f15001c3 100644 --- a/src/dune_rules/lock_rules.ml +++ b/src/dune_rules/lock_rules.ml @@ -37,6 +37,7 @@ module Spec = struct let name = "lock" let version = 1 + let runs_process = false let bimap t f g = { t with lock_dir = f t.lock_dir; target = g t.target } let is_useful_to ~memoize = memoize diff --git a/src/dune_rules/main.ml b/src/dune_rules/main.ml index 509ed785661..24340f6161c 100644 --- a/src/dune_rules/main.ml +++ b/src/dune_rules/main.ml @@ -25,7 +25,7 @@ let implicit_default_alias dir = Some (Action_builder.ignore (Alias_rec.dep_on_alias_rec default_alias dir))) ;; -let execution_parameters = +let execution_parameters ~sandbox_actions = let source_backed_dir path = match Dpath.Target_dir.of_target path with | Regular (With_context (context, source)) @@ -38,6 +38,9 @@ let execution_parameters = let f context path = let open Memo.O in let* ep = Execution_parameters.default in + let ep = + if sandbox_actions then Execution_parameters.set_sandbox_actions true ep else ep + in if Context_name.equal context Private_context.t.name || Context_name.equal context Fetch_rules.context.name @@ -67,7 +70,7 @@ let execution_parameters = fun context ~dir -> Memo.exec memo (context, dir) ;; -let init ~sandboxing_preference () : unit = +let init ~sandbox_actions ~sandboxing_preference () : unit = let promote_source ~chmod ~delete_dst_if_it_is_a_directory ~src ~dst = let open Fiber.O in let* ctx = Path.Build.parent_exn src |> Context.DB.by_dir |> Memo.run in @@ -96,7 +99,7 @@ let init ~sandboxing_preference () : unit = :: List.map contexts ~f:(fun ctx -> ctx, With_sources))) ~rule_generator:(module Gen_rules) ~implicit_default_alias - ~execution_parameters + ~execution_parameters:(execution_parameters ~sandbox_actions) ~source_tree:(module Source_tree) ;; diff --git a/src/dune_rules/main.mli b/src/dune_rules/main.mli index 5cb412aa10b..2efba9436e3 100644 --- a/src/dune_rules/main.mli +++ b/src/dune_rules/main.mli @@ -1,7 +1,11 @@ open Import (** Tie the knot between [Dune_engine] and [Dune_rules]. *) -val init : sandboxing_preference:Sandbox_mode.t list -> unit -> unit +val init + : sandbox_actions:bool + -> sandboxing_preference:Sandbox_mode.t list + -> unit + -> unit type build_system = { contexts : Context.t list diff --git a/src/dune_rules/module_compilation.ml b/src/dune_rules/module_compilation.ml index c8562dc294b..52bc5615098 100644 --- a/src/dune_rules/module_compilation.ml +++ b/src/dune_rules/module_compilation.ml @@ -354,10 +354,11 @@ let build_cm >>| List.concat_map ~f:(fun m -> [ "-parameter"; Module_name.to_string m ])) in let flags = Command.Args.dyn (Ocaml_flags.get (Compilation_context.flags cctx) mode) in - let pp_flags, sandbox = + let pp_flags, sandbox, can_run_in_action_runner = match Module.pp_flags m with - | None -> Command.Args.empty, sandbox - | Some (pp, sandbox') -> Command.Args.dyn pp, Sandbox_config.inter sandbox sandbox' + | None -> Command.Args.empty, sandbox, false + | Some (pp, sandbox') -> + Command.Args.dyn pp, Sandbox_config.inter sandbox sandbox', true in let output = match phase with @@ -402,6 +403,7 @@ let build_cm >>> Command.run ~dir:(Path.build (Context.build_dir ctx)) ~sandbox + ~can_run_in_action_runner compiler [ flags ; pp_flags diff --git a/src/dune_rules/ocamldep.ml b/src/dune_rules/ocamldep.ml index a4a1c52d1ca..cd6d4871dbf 100644 --- a/src/dune_rules/ocamldep.ml +++ b/src/dune_rules/ocamldep.ml @@ -46,26 +46,39 @@ let parse_deps_exn ~file lines = String.extract_blank_separated_words deps) ;; -let ocamldep_action ~sandbox ~sctx ~ml_kind unit = +let ocamldep_action ~sandbox ~sctx ~dir ~ml_kind unit = let context = Super_context.context sctx in - let flags, sandbox = - Module.pp_flags unit |> Option.value ~default:(Action_builder.return [], sandbox) + let flags, sandbox, can_run_in_action_runner = + match Module.pp_flags unit with + | None -> Action_builder.return [], sandbox, false + | Some (flags, sandbox) -> flags, sandbox, true in let open Action_builder.O in let* ocamldep = let+ ocaml = Action_builder.of_memo (Context.ocaml context) in ocaml.ocamldep in - let source = Option.value_exn (Module.source unit ~ml_kind) in - Command.run' - ~dir:(Path.build (Context.build_dir context)) - ~sandbox - ocamldep - [ A "-modules" - ; Command.Args.dyn flags - ; Command.Ml_kind.flag ml_kind - ; Dep (Module.File.path source) - ] + let+ action = + let source = Option.value_exn (Module.source unit ~ml_kind) in + let env = + (* CR-someday rgrinberg: consider getting rid of this *) + Action_builder.of_memo + (let open Memo.O in + Super_context.env_node sctx ~dir >>= Env_node.external_env) + in + Command.run' + ~dir:(Path.build (Context.build_dir context)) + ~sandbox + ~env + ~can_run_in_action_runner + ocamldep + [ A "-modules" + ; Command.Args.dyn flags + ; Command.Ml_kind.flag ml_kind + ; Dep (Module.File.path source) + ] + in + { Rule.Anonymous_action.action; loc = Loc.none; dir; alias = None } ;; (* Top-level cache per (source path, ml_kind). Without it, each caller's @@ -105,8 +118,8 @@ let read_immediate_deps_words = | None -> let dir = Obj_dir.dir obj_dir in let builder = - ocamldep_action ~sandbox ~sctx ~ml_kind unit - |> Super_context.execute_action_stdout sctx ~loc:Loc.none ~dir + ocamldep_action ~sandbox ~sctx ~dir ~ml_kind unit + |> Build_system.execute_action_stdout |> Memo.map ~f:(fun output -> Some (String.split_lines output |> parse_deps_exn ~file:source_path)) |> Action_builder.of_memo diff --git a/src/dune_rules/pkg_build_progress.ml b/src/dune_rules/pkg_build_progress.ml index e54d91d644e..3e95ee095a9 100644 --- a/src/dune_rules/pkg_build_progress.ml +++ b/src/dune_rules/pkg_build_progress.ml @@ -55,6 +55,7 @@ module Spec = struct let name = "progress-action" let version = 1 + let runs_process = false let is_useful_to ~memoize:_ = true let bimap t _f _g = t let encode t _ _ = Message.encode t diff --git a/src/dune_rules/pkg_rules.ml b/src/dune_rules/pkg_rules.ml index 2acb6025620..47254350048 100644 --- a/src/dune_rules/pkg_rules.ml +++ b/src/dune_rules/pkg_rules.ml @@ -663,6 +663,7 @@ module Substitute = struct let name = "substitute" let version = 4 + let runs_process = false let bimap t f g = { t with src = f t.src; dst = g t.dst } let is_useful_to ~memoize = memoize @@ -1718,6 +1719,7 @@ module Install_action = struct let name = "install-file-run" let version = 1 + let runs_process = false let bimap ({ install_file diff --git a/src/dune_rules/pp_spec_rules.ml b/src/dune_rules/pp_spec_rules.ml index 8baef6d55de..415eda2570b 100644 --- a/src/dune_rules/pp_spec_rules.ml +++ b/src/dune_rules/pp_spec_rules.ml @@ -211,6 +211,7 @@ let lint_module sctx ~sandbox ~dir ~expander ~lint ~lib_name ~scope = let dir = ctx |> Context.build_dir |> Path.build in Command.run' ~dir + ~can_run_in_action_runner:true (Ok (Path.build exe)) [ As args ; Command.Ml_kind.ppx_driver_flag ml_kind @@ -363,29 +364,31 @@ let pp_one_module (Action_builder.with_file_targets ~file_targets:[ dst ] (let open Action_builder.O in - let* exe, flags, args = driver_and_flags in - let dir = - Super_context.context sctx |> Context.build_dir |> Path.build - in - Command.run' - ~dir - ~sandbox - ~env - (Ok (Path.build exe)) - [ As args - ; A "-o" - ; Path (Path.build dst) - ; loc_filename_arg - ; Command.Ml_kind.ppx_driver_flag ml_kind - ; Dep (Path.build src) - ; Hidden_deps - (Module.source m ~ml_kind - |> Option.value_exn - |> Module.File.path - |> Dep.file - |> Dep.Set.singleton) - ; As flags - ]))))) + preprocessor_deps + >>> let* exe, flags, args = driver_and_flags in + let dir = + Super_context.context sctx |> Context.build_dir |> Path.build + in + Command.run' + ~dir + ~sandbox + ~env + ~can_run_in_action_runner:true + (Ok (Path.build exe)) + [ As args + ; A "-o" + ; Path (Path.build dst) + ; loc_filename_arg + ; Command.Ml_kind.ppx_driver_flag ml_kind + ; Dep (Path.build src) + ; Hidden_deps + (Module.source m ~ml_kind + |> Option.value_exn + |> Module.File.path + |> Dep.file + |> Dep.Set.singleton) + ; As flags + ]))))) ;; let make diff --git a/src/dune_rules/run_with_path.ml b/src/dune_rules/run_with_path.ml index 5c3ceb1210b..4372cd9cbf8 100644 --- a/src/dune_rules/run_with_path.ml +++ b/src/dune_rules/run_with_path.ml @@ -177,6 +177,7 @@ module Spec = struct let name = "run-with-path" let version = 2 + let runs_process = true let map_arg arg ~f = Array.Immutable.map arg ~f:(function @@ -227,7 +228,12 @@ module Spec = struct | Path p -> Path.to_absolute_filename p) |> String.concat ~sep:"") in - let metadata = Process.create_metadata ~purpose:ectx.metadata.purpose () in + let metadata = + Process.create_metadata + ~can_run_in_action_runner:ectx.metadata.can_run_in_action_runner + ~purpose:ectx.metadata.purpose + () + in let dune_folder = let bin_folder = Temp.create Dir ~prefix:"dune" ~suffix:"self-in-path" in let src = Path.of_string Sys.executable_name in diff --git a/src/dune_rules/system.ml b/src/dune_rules/system.ml index e88661d36ce..70fe6a9045b 100644 --- a/src/dune_rules/system.ml +++ b/src/dune_rules/system.ml @@ -6,6 +6,7 @@ module Spec = struct let name = "system" let version = 1 + let runs_process = true let bimap t _ _ = t let is_useful_to ~memoize = memoize let encode cmd _ _ : Sexp.t = Atom cmd diff --git a/src/dune_scheduler/scheduler.ml b/src/dune_scheduler/scheduler.ml index c66027cea6c..3aa350a15de 100644 --- a/src/dune_scheduler/scheduler.ml +++ b/src/dune_scheduler/scheduler.ml @@ -19,24 +19,11 @@ exception Build_cancelled let cancelled () = raise (Memo.Non_reproducible Build_cancelled) -let check_cancelled t = - match t.current_build_cancel with +let check_cancelled = function | Some cancel when Fiber.Cancel.fired cancel -> cancelled () | None | Some _ -> () ;; -let with_current_build_cancellation cancel f = - let* () = Fiber.return () in - let t = t () in - match t.current_build_cancel with - | Some _ -> f () - | None -> - t.current_build_cancel <- Some cancel; - Fiber.finalize f ~finally:(fun () -> - t.current_build_cancel <- None; - Fiber.return ()) -;; - let check_point = let* () = Fiber.return () in match t_opt () with @@ -52,11 +39,11 @@ let check_point = let () = Memo.check_point := check_point -let with_job_slot f = +let with_job_slot ?cancellation f = let* () = Fiber.return () in let t = t () in Fiber.Throttle.run t.job_throttle ~f:(fun () -> - check_cancelled t; + check_cancelled cancellation; f ()) ;; @@ -76,7 +63,7 @@ type termination_reason = (* We use this version privately in this module whenever we can pass the scheduler explicitly *) -let wait_for_build_process t ~is_process_group_leader pid = +let wait_for_build_process t ?cancellation ~is_process_group_leader pid = let sigkill_alarm = ref None in let wait () = let* r = wait_for_process t ~is_process_group_leader pid in @@ -89,7 +76,7 @@ let wait_for_build_process t ~is_process_group_leader pid = in r in - match t.current_build_cancel with + match cancellation with | None -> let+ res = wait () in res, Normal @@ -98,13 +85,15 @@ let wait_for_build_process t ~is_process_group_leader pid = Fiber.Cancel.with_handler cancel ~on_cancel:(fun () -> - if not Sys.win32 then Process_watcher.killall t.process_watcher Sys.sigterm; + if not Sys.win32 + then Process_watcher.kill_process_group pid Sys.sigterm ~is_process_group_leader; let sleep = Async_io.sleep t.async_io sigterm_grace_period in sigkill_alarm := Some sleep; Async_io.Task.await sleep >>| function | Error `Cancelled -> () - | Ok () -> Process_watcher.killall t.process_watcher Sys.sigkill + | Ok () -> + Process_watcher.kill_process_group pid Sys.sigkill ~is_process_group_leader | Error (`Exn _) -> assert false) wait in @@ -206,7 +195,6 @@ let prepare (config : Config.t) ~events ~file_watcher = ; thread_pool = lazy (Thread_pool.create ~min_workers:4 ~max_workers:50) ; signal_watcher ; async_io - ; current_build_cancel = None } in current := Some t; @@ -375,13 +363,6 @@ let shutdown () = Event.Queue.send_shutdown t.events Requested ;; -let cancel_current_build () = - let* () = Fiber.return () in - match (t ()).current_build_cancel with - | None -> Fiber.return () - | Some cancel -> Fiber.Cancel.fire cancel -;; - let wait_for_process_with_timeout t pid waiter ~timeout ~is_process_group_leader = Fiber.of_thunk (fun () -> let sleep = Async_io.sleep t.async_io timeout in @@ -408,16 +389,17 @@ let wait_for_process_with_timeout t pid waiter ~timeout ~is_process_group_leader | `Finished -> termination_reason )) ;; -let wait_for_build_process ?timeout ~is_process_group_leader pid = +let wait_for_build_process ?cancellation ?timeout ~is_process_group_leader pid = let* () = Fiber.return () in let t = t () in match timeout with - | None -> wait_for_build_process t ~is_process_group_leader pid + | None -> wait_for_build_process t ?cancellation ~is_process_group_leader pid | Some timeout -> wait_for_process_with_timeout t pid - wait_for_build_process + (fun t ~is_process_group_leader pid -> + wait_for_build_process t ?cancellation ~is_process_group_leader pid) ~timeout ~is_process_group_leader ;; diff --git a/src/dune_scheduler/scheduler.mli b/src/dune_scheduler/scheduler.mli index 66058958c8e..a5e5b069963 100644 --- a/src/dune_scheduler/scheduler.mli +++ b/src/dune_scheduler/scheduler.mli @@ -39,8 +39,9 @@ type t val t : unit -> t (** [with_job_slot f] waits for one job slot (as per [-j 'a Fiber.t) -> 'a Fiber.t + available and then calls [f]. If [cancellation] is fired before the job + starts, the job is cancelled. *) +val with_job_slot : ?cancellation:Fiber.Cancel.t -> (unit -> 'a Fiber.t) -> 'a Fiber.t (** Wait for the following process to terminate. If [is_process_group_leader] is true, kill the entire process group instead of just the process in case of @@ -57,7 +58,8 @@ type termination_reason = | Timeout val wait_for_build_process - : ?timeout:Time.Span.t + : ?cancellation:Fiber.Cancel.t + -> ?timeout:Time.Span.t -> is_process_group_leader:bool -> Pid.t -> (Proc.Process_info.t * termination_reason) Fiber.t @@ -88,16 +90,9 @@ val running_jobs_count : t -> int restart. *) val shutdown : unit -> unit -(** Cancel the current build. Superficially, this function is like [shutdown] - in that it stops the build early, but it is different because the [Run.go] - call is allowed to complete its fiber. In this respect, the behavior is - similar to what happens on file system events in polling mode. *) -val cancel_current_build : unit -> unit Fiber.t - (** [sleep duration] waits for [duration] to elapse. *) val sleep : Time.Span.t -> unit Fiber.t val spawn_thread : name:string -> (unit -> unit) -> Thread.t val flush_file_watcher : unit -> unit Fiber.t val file_watcher : unit -> File_watcher.t option -val with_current_build_cancellation : Fiber.Cancel.t -> (unit -> 'a Fiber.t) -> 'a Fiber.t diff --git a/src/dune_scheduler/types.ml b/src/dune_scheduler/types.ml index 3fb75bdabcb..0cc3e33d6fb 100644 --- a/src/dune_scheduler/types.ml +++ b/src/dune_scheduler/types.ml @@ -60,7 +60,6 @@ module Scheduler = struct ; thread_pool : Thread_pool.t Lazy.t ; signal_watcher : Thread.t ; async_io : Async_io.t - ; mutable current_build_cancel : Fiber.Cancel.t option } let current : t option ref = ref None diff --git a/src/dune_trace/dune_trace.ml b/src/dune_trace/dune_trace.ml index 2d3493f64cf..acfa62a546e 100644 --- a/src/dune_trace/dune_trace.ml +++ b/src/dune_trace/dune_trace.ml @@ -1,74 +1,84 @@ open Stdune module Category = Category module Event = Event +module Raw_out = Out module Out = struct - include Out + include Raw_out - let create path = + let enabled_categories () = let of_string_exn x = match Category.of_string x with | Some x -> x | None -> User_error.raise [ Pp.textf "unrecognized trace category %S" x ] in - let cats = - match Sys.getenv_opt "DUNE_TRACE" with - | None -> Category.default - | Some s -> - let tokens = - let dune_trace_re = Re.compile (Re.set ",+-") in - Re.split_full dune_trace_re s - |> List.map ~f:(function - | `Text s -> `Category (of_string_exn s) - | `Delim g -> - (match Re.Group.get g 0 with - | "," -> `Comma - | "+" -> `Add - | "-" -> `Remove - | _ -> assert false)) + match Sys.getenv_opt "DUNE_TRACE" with + | None -> Category.default + | Some s -> + let tokens = + let dune_trace_re = Re.compile (Re.set ",+-") in + Re.split_full dune_trace_re s + |> List.map ~f:(function + | `Text s -> `Category (of_string_exn s) + | `Delim g -> + (match Re.Group.get g 0 with + | "," -> `Comma + | "+" -> `Add + | "-" -> `Remove + | _ -> assert false)) + in + if + List.for_all tokens ~f:(function + | `Category _ | `Comma -> true + | _ -> false) + then + (* We can do better validation here *) + List.filter_map tokens ~f:(function + | `Category x -> Some x + | _ -> None) + else ( + let rec loop acc = function + | `Add :: `Category cat :: xs -> + let acc = cat :: acc in + loop acc xs + | `Remove :: `Category cat :: xs -> + let acc = List.filter acc ~f:(fun x -> x <> cat) in + loop acc xs + | [] -> acc + | _ :: _ -> + User_error.raise + [ Pp.text + "invalid DUNE_TRACE. Either specify categories by only ',' or a mix of \ + '+', and '-' " + ] in - if - List.for_all tokens ~f:(function - | `Category _ | `Comma -> true - | _ -> false) - then - (* We can do better validation here *) - List.filter_map tokens ~f:(function - | `Category x -> Some x - | _ -> None) - else ( - let rec loop acc = function - | `Add :: `Category cat :: xs -> - let acc = cat :: acc in - loop acc xs - | `Remove :: `Category cat :: xs -> - let acc = List.filter acc ~f:(fun x -> x <> cat) in - loop acc xs - | [] -> acc - | _ :: _ -> - User_error.raise - [ Pp.text - "invalid DUNE_TRACE. Either specify categories by only ',' or a mix \ - of '+', and '-' " - ] - in - loop Category.default tokens) - in - create cats path + loop Category.default tokens) ;; + + let create path = Raw_out.create (enabled_categories ()) path + let of_fd fd = Raw_out.of_fd (enabled_categories ()) fd end +type ownership = + | Owned + | Borrowed + +type global = + { out : Out.t + ; ownership : ownership + } + let global = ref None let reset_alloc_profile () = - Option.iter !global ~f:(fun (out : Out.t) -> Option.iter out.alloc ~f:Alloc.reset) + Option.iter !global ~f:(fun { out; _ } -> Option.iter (Out.alloc out) ~f:Alloc.reset) ;; let capture_alloc_profile kind = match match !global with | None -> None - | Some (global : Out.t) -> global.alloc + | Some { out; _ } -> Out.alloc out with | None -> None | Some alloc -> @@ -85,15 +95,22 @@ let at_exit = At_exit.at_exit Global_lock.at_exit (fun () -> match !global with | None -> () - | Some t -> + | Some { out; ownership = Borrowed } -> + let alloc_summary = capture_alloc_profile `Exit in + Option.iter (Out.alloc out) ~f:Alloc.stop; + Option.iter alloc_summary ~f:(Out.emit out); + Out.close out + | Some { out; ownership = Owned } -> let alloc_summary = capture_alloc_profile `Exit in - Option.iter t.alloc ~f:Alloc.stop; - Option.iter alloc_summary ~f:(Out.emit t); - Out.emit t (Event.exit ()); - Out.close t; - (match Env.(get initial Dune_action_trace.Private.trace_dir_env_var) with - | None -> () - | Some dir -> + Option.iter (Out.alloc out) ~f:Alloc.stop; + Option.iter alloc_summary ~f:(Out.emit out); + Out.emit out (Event.exit ()); + Out.close out; + (match + Env.(get initial Dune_action_trace.Private.trace_dir_env_var), Out.path out + with + | None, _ | _, None -> () + | Some dir, Some path -> let dir = Path.of_string dir in Path.mkdir_p dir; let dst = @@ -101,15 +118,39 @@ let at_exit = (Temp.temp_dir ~parent_dir:dir ~prefix:"dune" ~suffix:"trace") "trace.csexp" in - Io.copy_file ~src:t.path ~dst ())) + Io.copy_file ~src:path ~dst ())) ;; -let set_global t = +let set_global_impl ~ownership out = if Option.is_some !global then Code_error.raise "global stats have been set" []; - global := Some t + global := Some { out; ownership } ;; -let global () = !global +let set_global t = set_global_impl ~ownership:Owned t + +let set_global_inherited_fd ?(common_args = []) fd = + Fd.set_close_on_exec fd; + let out = Out.of_fd fd in + set_global_impl ~ownership:Borrowed out; + Event.Event.set_common_args common_args +;; + +let global () = Option.map !global ~f:(fun { out; _ } -> out) + +let duplicate_global_fd () = + if Sys.win32 + then None + else ( + match global () with + | None -> None + | Some out -> + let fd = + Unix.dup (Fd.unsafe_to_unix_file_descr (Out.fd out)) + |> Fd.unsafe_of_unix_file_descr + in + Fd.clear_close_on_exec fd; + Some fd) +;; let always_emit event = match global () with @@ -120,7 +161,7 @@ let always_emit event = let emit ?buffered cat f = match global () with | None -> () - | Some out -> if Category.Set.mem out.cats cat then Out.emit ?buffered out (f ()) + | Some out -> if Category.Set.mem (Out.cats out) cat then Out.emit ?buffered out (f ()) ;; let flush () = @@ -133,13 +174,14 @@ let emit_all ?buffered cat f = match global () with | None -> () | Some out -> - if Category.Set.mem out.cats cat then List.iter (f ()) ~f:(Out.emit ?buffered out) + if Category.Set.mem (Out.cats out) cat + then List.iter (f ()) ~f:(Out.emit ?buffered out) ;; let enabled cat = match global () with | None -> false - | Some s -> Category.Set.mem s.cats cat + | Some s -> Category.Set.mem (Out.cats s) cat ;; module Private = struct diff --git a/src/dune_trace/dune_trace.mli b/src/dune_trace/dune_trace.mli index 954bfb0d102..e5ab7e1310c 100644 --- a/src/dune_trace/dune_trace.mli +++ b/src/dune_trace/dune_trace.mli @@ -65,7 +65,8 @@ module Event : sig } val process_start - : pid:Pid.t + : extra_args:(string * Sexp.t) list + -> pid:Pid.t -> dir:Path.t option -> prog:string -> args:string list @@ -78,7 +79,8 @@ module Event : sig -> t val process - : name:string option + : extra_args:(string * Sexp.t) list + -> name:string option -> started_at:Time.t -> targets:targets option -> categories:string list @@ -213,6 +215,15 @@ module Event : sig module Action : sig val start : name:string -> start:Time.t -> t val finish : name:string -> start:Time.t -> t + val runner_spawn : name:Action_runner_name.t -> pid:Pid.t -> t + val runner_connection_start : name:Action_runner_name.t -> t + val runner_connection_established : name:Action_runner_name.t -> t + val runner_connected : name:Action_runner_name.t -> t + val runner_request_sent : name:Action_runner_name.t -> t + val runner_cancel_request_sent : name:Action_runner_name.t -> t + val runner_exec_start : name:Action_runner_name.t -> t + val runner_cancel_start : name:Action_runner_name.t -> t + val runner_disconnected : name:Action_runner_name.t -> t val write_file : start:Time.t -> finish:Time.t -> file:Path.t -> size:int -> t val trace : digest:string -> Csexp.t -> t end @@ -268,6 +279,8 @@ end val global : unit -> Out.t option val set_global : Out.t -> unit +val set_global_inherited_fd : ?common_args:(string * Sexp.t) list -> Fd.t -> unit +val duplicate_global_fd : unit -> Fd.t option val always_emit : Event.t -> unit val enabled : Category.t -> bool val emit : ?buffered:bool -> Category.t -> (unit -> Event.t) -> unit diff --git a/src/dune_trace/event.ml b/src/dune_trace/event.ml index e727c49c5a2..bf7105f5bc0 100644 --- a/src/dune_trace/event.ml +++ b/src/dune_trace/event.ml @@ -45,15 +45,18 @@ module Event = struct type args = (string * Arg.t) list type t = Sexp.t + let common_args = ref [] let base ~name cat : Sexp.t list = [ Atom (Category.to_string cat); Atom name ] + let record_args args = Arg.record (args @ !common_args) + let set_common_args args = common_args := args let complete ?(args = []) ~name ~start ~dur cat : t = List - (base ~name cat @ [ Sexp.List [ Arg.time start; Arg.span dur ] ] @ Arg.record args) + (base ~name cat @ [ Sexp.List [ Arg.time start; Arg.span dur ] ] @ record_args args) ;; let instant ?(args = []) ~name ts cat : t = - List (base ~name cat @ [ Arg.time ts ] @ Arg.record args) + List (base ~name cat @ [ Arg.time ts ] @ record_args args) ;; let async ?(args = []) id ~name ts stage cat : t = @@ -68,7 +71,7 @@ module Event = struct | `Start -> "start" | `Stop -> "stop") ) ] - @ Arg.record args) + @ record_args args) ;; end @@ -368,6 +371,7 @@ let make_exit exit = ;; let process_start + ~extra_args ~pid ~dir ~prog @@ -403,12 +407,13 @@ let process_start | Some timeout -> [ "timeout", Arg.span timeout ]) ] in - always @ extended + always @ extended @ extra_args in Event.instant ~args ~name:"start" started_at Process ;; let process + ~extra_args ~name ~started_at ~targets @@ -452,7 +457,7 @@ let process ] in let resource_usage = make_rusage_args resource_usage in - always @ extended @ resource_usage + always @ extended @ resource_usage @ extra_args in Event.complete ~args ~start:started_at ~dur:elapsed_time ~name:"finish" Process ;; @@ -780,6 +785,34 @@ module Action = struct Event.complete ~args:[ "name", Arg.string name ] ~name:"finish" ~start ~dur Action ;; + let runner_name_arg name = "name", Arg.string (Action_runner_name.to_string name) + + let runner_event ~name event_name extra_args = + let args = runner_name_arg name :: extra_args in + Event.instant ~args ~name:event_name (Time.now ()) Action + ;; + + let runner_spawn ~name ~pid = + runner_event ~name "runner-spawn" [ "pid", Arg.int (Pid.to_int pid) ] + ;; + + let runner_connection_start ~name = runner_event ~name "runner-connection-start" [] + + let runner_connection_established ~name = + runner_event ~name "runner-connection-established" [] + ;; + + let runner_connected ~name = runner_event ~name "runner-connected" [] + let runner_request_sent ~name = runner_event ~name "runner-request-sent" [] + + let runner_cancel_request_sent ~name = + runner_event ~name "runner-cancel-request-sent" [] + ;; + + let runner_exec_start ~name = runner_event ~name "runner-exec-start" [] + let runner_cancel_start ~name = runner_event ~name "runner-cancel-start" [] + let runner_disconnected ~name = runner_event ~name "runner-disconnected" [] + let write_file ~start ~finish ~file ~size = let dur = Time.diff finish start in let args = [ "file", Arg.path file; "size", Arg.int size ] in diff --git a/src/dune_trace/out.ml b/src/dune_trace/out.ml index 9b8bc2238e4..86cd7247d45 100644 --- a/src/dune_trace/out.ml +++ b/src/dune_trace/out.ml @@ -22,10 +22,17 @@ type t = ; buf : Buffer.t ; cats : Category.Set.t ; mutex : Mutex.t - ; path : Path.t - ; mutable alloc : Alloc.t option + ; path : Path.t option + ; alloc : Alloc.t option + ; terminate_process_on_error : bool + ; mutable failed : bool } +let fd t = t.fd +let cats t = t.cats +let path t = t.path +let alloc t = t.alloc + (* CR-someday rgrinberg: remove this once we drop support for < 5.2 *) external write_bigstring : Unix.file_descr @@ -35,7 +42,7 @@ external write_bigstring -> int = "dune_trace_write" -let flush = +let flush_unlocked = (* This loop will almost always result in a single write, but we make sure to write everything (albeit inefficiently) if the user is running out of disk space, is on NFS, or some exotic operation system that doesn't give us @@ -63,12 +70,35 @@ let flush = fun t -> loop t 0 (Buffer.pos t.buf) ;; -let close t = +let mark_failed t = Mutex.protect t.mutex (fun () -> - if not (Fd.is_closed t.fd) + if not t.failed then ( - flush t; - Fd.close t.fd)) + t.failed <- true; + Buffer.clear t.buf)) +;; + +let handle_emit_error t exn = + mark_failed t; + if t.terminate_process_on_error then Stdlib.exit 1 else raise exn +;; + +let close t = + match + Mutex.protect t.mutex (fun () -> + if not (Fd.is_closed t.fd) + then + if t.failed + then ( + match Fd.close t.fd with + | () -> () + | exception _ -> ()) + else ( + flush_unlocked t; + Fd.close t.fd)) + with + | () -> () + | exception exn -> handle_emit_error t exn ;; let create cats path = @@ -82,7 +112,29 @@ let create cats path = let cats = Category.Set.of_list cats in let buf = Buffer.create (1 lsl 16) in let alloc = if Category.Set.mem cats Alloc then Some (Alloc.start ()) else None in - { fd; cats; buf; mutex = Mutex.create (); path; alloc } + { fd + ; cats + ; buf + ; mutex = Mutex.create () + ; path = Some path + ; alloc + ; terminate_process_on_error = false + ; failed = false + } +;; + +let of_fd cats fd = + let cats = Category.Set.of_list cats in + let buf = Buffer.create (1 lsl 16) in + { fd + ; cats + ; buf + ; mutex = Mutex.create () + ; path = None + ; alloc = (if Category.Set.mem cats Alloc then Some (Alloc.start ()) else None) + ; terminate_process_on_error = true + ; failed = false + } ;; let to_buffer t sexp = @@ -109,14 +161,29 @@ let emit_buffered t event = ;; let emit ?(buffered = false) t event = - Mutex.protect t.mutex (fun () -> - if not (Fd.is_closed t.fd) - then ( - emit_buffered t event; - if not buffered then flush t)) + if not t.failed + then ( + match + Mutex.protect t.mutex (fun () -> + if (not t.failed) && not (Fd.is_closed t.fd) + then ( + emit_buffered t event; + if not buffered then flush_unlocked t)) + with + | () -> () + | exception exn -> handle_emit_error t exn) ;; -let flush t = Mutex.protect t.mutex (fun () -> if not (Fd.is_closed t.fd) then flush t) +let flush t = + if not t.failed + then ( + match + Mutex.protect t.mutex (fun () -> + if (not t.failed) && not (Fd.is_closed t.fd) then flush_unlocked t) + with + | () -> () + | exception exn -> handle_emit_error t exn) +;; let start t k : Event.Async.t option = match t with diff --git a/src/dune_trace/out.mli b/src/dune_trace/out.mli index 6e302ecd4d2..b5ebbfff293 100644 --- a/src/dune_trace/out.mli +++ b/src/dune_trace/out.mli @@ -1,17 +1,15 @@ open Stdune -type t = - { fd : Fd.t - ; buf : Buffer.t - ; cats : Category.Set.t - ; mutex : Mutex.t - ; path : Stdune.Path.t - ; mutable alloc : Alloc.t option - } +type t +val fd : t -> Fd.t +val cats : t -> Category.Set.t +val path : t -> Stdune.Path.t option +val alloc : t -> Alloc.t option val emit : ?buffered:bool -> t -> Event.t -> unit val flush : t -> unit val close : t -> unit val create : Category.t list -> Stdune.Path.t -> t +val of_fd : Category.t list -> Fd.t -> t val start : t option -> (unit -> Event.Async.data) -> Event.Async.t option val finish : t -> Event.Async.t option -> unit diff --git a/test/blackbox-tests/dune.jq b/test/blackbox-tests/dune.jq index dc6ed877c20..14137d5a14e 100644 --- a/test/blackbox-tests/dune.jq +++ b/test/blackbox-tests/dune.jq @@ -296,6 +296,85 @@ def normalizeBuildRestartEvents: | flush | .[]; +def runnerEventSummary: + [ .[] + | select(.cat == "action" and (.name | startswith("runner-"))) + ] as $events + | { + spawn: ([$events[] | select(.name == "runner-spawn")] | length), + connection_start: + ([$events[] | select(.name == "runner-connection-start")] | length), + connection_established: + ([$events[] | select(.name == "runner-connection-established")] | length), + connected: ([$events[] | select(.name == "runner-connected")] | length), + exec_start: ([$events[] | select(.name == "runner-exec-start")] | length), + cancel_request_sent: + ([$events[] | select(.name == "runner-cancel-request-sent")] | length), + cancel_start: ([$events[] | select(.name == "runner-cancel-start")] | length), + disconnected: ([$events[] | select(.name == "runner-disconnected")] | length), + request_sent: ([$events[] | select(.name == "runner-request-sent")] | length > 0), + names: ([$events[] | .args.name] | unique), + spawn_pid_types: ([$events[] | select(.name == "runner-spawn") | .args.pid | type] | unique) + }; + +def runnerRequestSummary: + runnerEventSummary | {request_sent, exec_start, names}; + +def runnerSpawnSummary: + runnerEventSummary | {spawn, names}; + +def runnerLifecycleSummary: + runnerEventSummary + | { spawn + , connection_start + , connection_established + , connected + , exec_start + , cancel_request_sent + , cancel_start + , disconnected + , names + , spawn_pid_types + }; + +def runnerEventCount($name): + [ .[] + | select(.cat == "action" and .name == $name) + ] | length; + +def actionRunnerTraceSummary($runner_name): + { runner_request_sent: runnerEventCount("runner-request-sent") + , worker_action_events: + ([ .[] + | select(.cat == "action" and .args.action_runner == $runner_name) + | .name + ] | sort) + , worker_process_events: + ([ .[] + | select( + .cat == "process" + and .args.action_runner == $runner_name + and (.name == "start" or .name == "finish")) + | .name + ] | sort) + , worker_names: + ([ .[] | select(.args.action_runner?) | .args.action_runner ] | unique) + }; + +def lastRunnerSpawnPid: + [ .[] + | select(.cat == "action" and .name == "runner-spawn") + | .args.pid + ] | last; + +def writeFileCountBySuffix($suffix): + [ .[] + | select( + .cat == "action" + and .name == "write-file" + and (.args.file | endswith($suffix))) + ] | length; + def cacheEvent($path): select(.cat == "cache") | .args | select(.path == $path); diff --git a/test/blackbox-tests/setup-script.sh b/test/blackbox-tests/setup-script.sh index c503bb35efd..7621781a42a 100644 --- a/test/blackbox-tests/setup-script.sh +++ b/test/blackbox-tests/setup-script.sh @@ -1346,6 +1346,52 @@ trace_rocq_flags () { dune trace cat | jq_dune -c 'rocqFlags' } +trace_jq() { + dune trace cat 2>/dev/null | jq -rs "$@" +} + +wait_for_trace_jq_true() { + filter=$1 + iterations=${2:-200} + while [ "$iterations" -gt 0 ] + do + if dune trace cat 2>/dev/null | jq -es "$filter" >/dev/null 2>&1 + then + return 0 + fi + iterations=$((iterations - 1)) + sleep 0.01 + done + return 124 +} + +wait_for_runner_event_count() { + event_name=$1 + count=$2 + wait_for_trace_jq_true \ + "include \"dune\"; runnerEventCount(\"$event_name\") >= $count" +} + +runner_spawn_pid() { + trace_jq 'include "dune"; lastRunnerSpawnPid // empty' +} + +wait_for_runner_spawn_pid() { + iterations=${1:-200} + while [ "$iterations" -gt 0 ] + do + pid=$(runner_spawn_pid) + if [ -n "$pid" ] && [ "$pid" != "null" ] + then + printf '%s\n' "$pid" + return 0 + fi + iterations=$((iterations - 1)) + sleep 0.01 + done + return 124 +} + wait_for_dune_exit_with_timeout () { exit_code=0 wait_for_pid_to_exit_with_timeout "$DUNE_PID" 200 || exit_code=$? diff --git a/test/blackbox-tests/test-cases/action-runner/basic.t b/test/blackbox-tests/test-cases/action-runner/basic.t new file mode 100644 index 00000000000..65807be1cd2 --- /dev/null +++ b/test/blackbox-tests/test-cases/action-runner/basic.t @@ -0,0 +1,138 @@ +`--action-runner` does not invalidate stale outputs when it is toggled. + + $ make_dune_project 3.23 + $ export TEST_DIR=$PWD + $ export DUNE_TRACE=action,process + $ echo one > input + $ cat > dune <<'EOF' + > (rule + > (target probe) + > (deps input) + > (action + > (bash + > "count=0; if [ -e \"$TEST_DIR/counter\" ]; then count=$(cat \"$TEST_DIR/counter\"); fi; count=$((count + 1)); echo $count > \"$TEST_DIR/counter\"; echo ran-$count > %{target}"))) + > EOF + + $ dune build probe + $ cat counter + 1 + + $ dune build --action-runner probe + $ cat counter + 1 + $ dune trace cat | jq -s 'include "dune"; runnerRequestSummary' + { + "request_sent": false, + "exec_start": 0, + "names": [] + } + + $ echo two > input + $ dune build --action-runner probe + $ cat counter + 2 + $ dune trace cat | jq -s 'include "dune"; runnerRequestSummary' + { + "request_sent": true, + "exec_start": 1, + "names": [ + "action-runner" + ] + } + + $ dune build probe + $ cat counter + 2 + $ dune trace cat | jq -s 'include "dune"; runnerRequestSummary' + { + "request_sent": false, + "exec_start": 0, + "names": [] + } + +The worker can also be started when dune itself was invoked via a relative path +that contains a directory component. + + $ ln -s "$(command -v dune)" ./dune.exe + $ echo three > input + $ ./dune.exe build --action-runner probe + $ cat counter + 3 + $ dune trace cat | jq -s 'include "dune"; runnerRequestSummary' + { + "request_sent": true, + "exec_start": 1, + "names": [ + "action-runner" + ] + } + +The worker uses the same build directory as the parent process. + + $ rm -rf _build _custom + $ cat > dune <<'EOF' + > (rule + > (target custom) + > (action + > (with-stdout-to %{target} + > (bash "printf custom")))) + > EOF + $ dune build --build-dir _custom --action-runner custom + $ cat _custom/default/custom + custom + $ test ! -e _build/default/custom + +Generated ocamldep processes only use the runner when they invoke a preprocessor. + + $ rm -rf _build _custom + $ rm -f counter dune dune.exe input plain.ml probe + $ cat > dune <<'EOF' + > (library + > (name plain) + > (modules plain plain_dep)) + > EOF + $ echo 'let x = 1' > plain_dep.ml + $ echo 'let _ = Plain_dep.x' > plain.ml + + $ dune build --action-runner plain.cma + $ dune trace cat | jq -s '[ .[] | select(.cat == "process" and .name == "start" and (.args.prog | contains("ocamldep")) and .args.action_runner?) ] | length' + 0 + $ dune trace cat | jq -s 'include "dune"; runnerRequestSummary | {request_sent}' + { + "request_sent": false + } + + $ rm -rf _build + $ rm -f plain.ml plain_dep.ml + $ cat > dune <<'EOF' + > (library + > (name ppx_noop) + > (modules ppx_noop) + > (kind ppx_rewriter) + > (ppx.driver (main Ppx_noop.main))) + > + > (library + > (name staged) + > (modules staged staged_dep) + > (preprocess (staged_pps ppx_noop))) + > EOF + $ cat > ppx_noop.ml <<'EOF' + > let main () = + > if Array.length Sys.argv >= 3 then ( + > let input_file = Sys.argv.(Array.length Sys.argv - 2) in + > let output_file = Sys.argv.(Array.length Sys.argv - 1) in + > let ic = open_in_bin input_file in + > let contents = really_input_string ic (in_channel_length ic) in + > close_in ic; + > let oc = open_out_bin output_file in + > output_string oc contents; + > close_out oc) + > else + > exit 2 + > EOF + $ echo 'let x = 1' > staged_dep.ml + $ echo 'let _ = Staged_dep.x' > staged.ml + + $ dune build --action-runner staged.cma + $ dune trace cat | jq -s '[ .[] | select(.cat == "process" and .name == "start" and (.args.prog | contains("ocamldep")) and ((.args.process_args | index("-pp")) or (.args.process_args | index("-ppx"))) and .args.action_runner == "action-runner") ] | length > 0' + true diff --git a/test/blackbox-tests/test-cases/action-runner/cancel-disconnect.t b/test/blackbox-tests/test-cases/action-runner/cancel-disconnect.t new file mode 100644 index 00000000000..37bf42bd050 --- /dev/null +++ b/test/blackbox-tests/test-cases/action-runner/cancel-disconnect.t @@ -0,0 +1,30 @@ +If the worker dies while the main process is sending `action/cancel-build`, the +build still fails promptly instead of waiting forever for that RPC response. + + $ command -v setsid >/dev/null + $ make_dune_project 3.23 + $ export TEST_DIR=$PWD + $ cat > dune <<'EOF' + > (rule + > (target slow) + > (action + > (bash "touch \"$TEST_DIR/slow-started\"; sleep 0.5; echo done > %{target}"))) + > + > (rule + > (target fail) + > (action + > (bash "touch \"$TEST_DIR/fail-started\"; WORKER_PID=$PPID setsid sh -c 'sleep 0.1; kill -9 \"$WORKER_PID\"' >/dev/null 2>&1 < /dev/null & echo failing-from-runner >&2; exit 1"))) + > EOF + +The failure triggers `--stop-on-first-error`, and the detached helper kills the +worker just after that. The main process still exits promptly. + + $ DUNE_JOBS=2 $timeout 2 dune build --action-runner --stop-on-first-error slow fail \ + > > /dev/null 2>&1 + [1] + + $ file_status slow-started + slow-started exists + + $ file_status fail-started + fail-started exists diff --git a/test/blackbox-tests/test-cases/action-runner/disconnect.t b/test/blackbox-tests/test-cases/action-runner/disconnect.t new file mode 100644 index 00000000000..9a274c092cb --- /dev/null +++ b/test/blackbox-tests/test-cases/action-runner/disconnect.t @@ -0,0 +1,39 @@ +A worker disconnect in the middle of an exec request should fail the build +promptly. + + $ make_dune_project 3.23 + $ export DUNE_TRACE=action + $ cat > dune <<'EOF' + > (rule + > (target break) + > (action (bash "sleep 30"))) + > EOF + +Start the build, wait until the worker has entered the exec handler, then kill +the worker from the test harness. + + $ DUNE_JOBS=1 $timeout 10 dune build --action-runner break > /dev/null 2>&1 & + $ BUILD_PID=$! + $ wait_for_runner_event_count runner-exec-start 1 + $ RUNNER_PID=$(wait_for_runner_spawn_pid) + $ kill -9 "$RUNNER_PID" + $ wait_for_runner_event_count runner-disconnected 1 + $ wait $BUILD_PID; [ "$?" = 1 ] + + $ dune trace cat | jq -s 'include "dune"; runnerLifecycleSummary' + { + "spawn": 1, + "connection_start": 1, + "connection_established": 1, + "connected": 1, + "exec_start": 1, + "cancel_request_sent": 0, + "cancel_start": 0, + "disconnected": 1, + "names": [ + "action-runner" + ], + "spawn_pid_types": [ + "number" + ] + } diff --git a/test/blackbox-tests/test-cases/action-runner/dune b/test/blackbox-tests/test-cases/action-runner/dune new file mode 100644 index 00000000000..6b9a06a2793 --- /dev/null +++ b/test/blackbox-tests/test-cases/action-runner/dune @@ -0,0 +1,21 @@ +(cram + (alias runtest-action-runner) + (applies_to + basic + cancel-disconnect + disconnect + failure + pool + runtest + trace + watch-stop-on-first-error)) + +(cram + (applies_to cancel-disconnect) + (deps %{bin:setsid}) + (enabled_if %{bin-available:setsid})) + +(cram + (enabled_if false) + (alias runtest-action-runner) + (applies_to stop-on-first-error)) diff --git a/test/blackbox-tests/test-cases/action-runner/failure.t b/test/blackbox-tests/test-cases/action-runner/failure.t new file mode 100644 index 00000000000..2e3e0d230e9 --- /dev/null +++ b/test/blackbox-tests/test-cases/action-runner/failure.t @@ -0,0 +1,43 @@ +Failures from action-runner actions are reported back to the main process. + + $ make_dune_project 3.23 + $ export DUNE_TRACE=action + $ cat > dune <<'EOF' + > (rule + > (target fail) + > (action + > (bash "echo stderr-from-runner >&2; exit 1"))) + > EOF + + $ dune build --action-runner fail 2>&1 \ + > | sed -E 's/characters [0-9]+-[0-9]+/characters /' + File "dune", lines 1-4, characters : + 1 | (rule + 2 | (target fail) + 3 | (action + 4 | (bash "echo stderr-from-runner >&2; exit 1"))) + stderr-from-runner + [1] + $ dune trace cat | jq -s 'include "dune"; runnerRequestSummary' + { + "request_sent": true, + "exec_start": 1, + "names": [ + "action-runner" + ] + } + +Stderr from successful actions remains separate from stdout. + + $ cat > dune <<'EOF' + > (rule + > (target noisy) + > (action + > (progn + > (bash "echo stderr-from-runner >&2") + > (write-file %{target} done)))) + > EOF + $ dune build --no-buffer --action-runner noisy >stdout 2>stderr + $ cat stdout + $ cat stderr + stderr-from-runner diff --git a/test/blackbox-tests/test-cases/action-runner/pool.t b/test/blackbox-tests/test-cases/action-runner/pool.t new file mode 100644 index 00000000000..9d261a18332 --- /dev/null +++ b/test/blackbox-tests/test-cases/action-runner/pool.t @@ -0,0 +1,43 @@ +A single action runner is started lazily and reused even when dune is running +multiple processes. + + $ make_dune_project 3.23 + $ export DUNE_TRACE=action + $ export TEST_DIR=$PWD + $ cat > dune <<'EOF' + > (rule + > (target single) + > (action (bash "echo single > %{target}"))) + > EOF + + $ DUNE_JOBS=2 dune build --action-runner single + $ dune trace cat | jq -s 'include "dune"; runnerSpawnSummary' + { + "spawn": 1, + "names": [ + "action-runner" + ] + } + + $ rm -f started-a started-b + $ cat > dune <<'EOF' + > (rule + > (target stamp) + > (action + > (progn + > (concurrent + > (bash "touch \"$TEST_DIR/started-a\"; while [ ! -f \"$TEST_DIR/started-b\" ]; do sleep 0.01; done") + > (bash "touch \"$TEST_DIR/started-b\"; while [ ! -f \"$TEST_DIR/started-a\" ]; do sleep 0.01; done")) + > (write-file %{target} done)))) + > EOF + + $ DUNE_JOBS=2 $timeout 5 dune build --action-runner stamp + $ cat _build/default/stamp + done + $ dune trace cat | jq -s 'include "dune"; runnerSpawnSummary' + { + "spawn": 1, + "names": [ + "action-runner" + ] + } diff --git a/test/blackbox-tests/test-cases/action-runner/runtest.t b/test/blackbox-tests/test-cases/action-runner/runtest.t new file mode 100644 index 00000000000..f2f7bca7c0c --- /dev/null +++ b/test/blackbox-tests/test-cases/action-runner/runtest.t @@ -0,0 +1,62 @@ +`dune runtest --action-runner` routes test actions through the worker too. + + $ make_dune_project 3.23 + $ export DUNE_TRACE=action + $ cat > dune <<'EOF' + > (rule + > (alias runtest) + > (action (bash "echo runtest-through-runner"))) + > EOF + + $ dune runtest --action-runner + runtest-through-runner + + $ dune trace cat | jq -s 'include "dune"; runnerEventSummary' + { + "spawn": 1, + "connection_start": 1, + "connection_established": 1, + "connected": 1, + "exec_start": 1, + "cancel_request_sent": 0, + "cancel_start": 0, + "disconnected": 1, + "request_sent": true, + "names": [ + "action-runner" + ], + "spawn_pid_types": [ + "number" + ] + } + +Cram test commands are user-controlled and should be routed through the runner. + + $ cat > dune <<'EOF' + > (cram) + > EOF + $ cat > sample.t <<'EOF' + > $ echo cram-through-runner + > cram-through-runner + > EOF + + $ dune runtest --action-runner + + $ dune trace cat | jq -s 'include "dune"; runnerEventSummary' + { + "spawn": 1, + "connection_start": 1, + "connection_established": 1, + "connected": 1, + "exec_start": 1, + "cancel_request_sent": 0, + "cancel_start": 0, + "disconnected": 1, + "request_sent": true, + "names": [ + "action-runner" + ], + "spawn_pid_types": [ + "number" + ] + } diff --git a/test/blackbox-tests/test-cases/action-runner/stop-on-first-error.t b/test/blackbox-tests/test-cases/action-runner/stop-on-first-error.t new file mode 100644 index 00000000000..fe71cbf7a28 --- /dev/null +++ b/test/blackbox-tests/test-cases/action-runner/stop-on-first-error.t @@ -0,0 +1,21 @@ +`--stop-on-first-error` is not yet stable for actions already running in the +worker. + + $ make_dune_project 3.23 + $ export TEST_DIR=$PWD + $ cat > dune <<'EOF' + > (rule + > (target slow) + > (action + > (bash "touch \"$TEST_DIR/slow-started\"; sleep 10; echo done > %{target}"))) + > + > (rule + > (target fail) + > (action + > (bash "while [ ! -f \"$TEST_DIR/slow-started\" ]; do sleep 0.1; done; touch \"$TEST_DIR/fail-started\"; echo failing-from-runner >&2; exit 1"))) + > EOF + $ DUNE_JOBS=2 $timeout 2 dune build --action-runner --stop-on-first-error \ + > slow fail > /dev/null 2>&1; code=$?; [ "$code" = 1 ] || [ "$code" = 124 ] + $ [ -e slow-started ] + $ [ -e fail-started ] + $ [ ! -e _build/default/slow ] diff --git a/test/blackbox-tests/test-cases/action-runner/trace.t b/test/blackbox-tests/test-cases/action-runner/trace.t new file mode 100644 index 00000000000..5de27d94fe0 --- /dev/null +++ b/test/blackbox-tests/test-cases/action-runner/trace.t @@ -0,0 +1,45 @@ +`--action-runner` only dispatches actions that run processes, and trace events +emitted inside the worker are stamped with the action runner name. + + $ make_dune_project 3.23 + $ export DUNE_TRACE=action,process + $ echo one > input + $ cat > dune <<'EOF' + > (rule + > (target pure) + > (deps input) + > (action (copy input %{target}))) + > + > (rule + > (target proc) + > (deps input) + > (action (bash "cat input > %{target}"))) + > EOF + + $ dune build pure proc + $ dune trace cat | jq -s 'include "dune"; actionRunnerTraceSummary("action-runner")' + { + "runner_request_sent": 0, + "worker_action_events": [], + "worker_process_events": [], + "worker_names": [] + } + + $ echo two > input + $ dune build --action-runner pure proc + $ dune trace cat | jq -s 'include "dune"; actionRunnerTraceSummary("action-runner")' + { + "runner_request_sent": 1, + "worker_action_events": [ + "runner-connection-established", + "runner-connection-start", + "runner-exec-start" + ], + "worker_process_events": [ + "finish", + "start" + ], + "worker_names": [ + "action-runner" + ] + } diff --git a/test/blackbox-tests/test-cases/action-runner/watch-stop-on-first-error.t b/test/blackbox-tests/test-cases/action-runner/watch-stop-on-first-error.t new file mode 100644 index 00000000000..9208686b14a --- /dev/null +++ b/test/blackbox-tests/test-cases/action-runner/watch-stop-on-first-error.t @@ -0,0 +1,26 @@ +After an action-runner stop-on-first-error cancellation in watch mode, the +reused action runner still recovers cleanly for the next build. + + $ setup_xdg_runtime_dir + $ make_dune_project 3.23 + $ export TEST_DIR=$PWD + $ cat > dune <<'EOF' + > (rule + > (target slow) + > (action + > (bash "touch \"$TEST_DIR/slow-started\"; sleep 10; echo done > %{target}"))) + > + > (rule + > (target fail) + > (action + > (bash "while [ ! -f \"$TEST_DIR/slow-started\" ]; do sleep 0.1; done; echo failing-from-runner >&2; exit 1"))) + > EOF + $ start_dune --action-runner --stop-on-first-error + $ build_quiet slow fail >/dev/null 2>&1; code=$?; [ "$code" = 124 ] + $ cat > dune <<'EOF' + > (rule + > (target ok) + > (action (bash "echo ok > %{target}"))) + > EOF + $ build_quiet ok >/dev/null 2>&1; code=$?; [ "$code" = 0 ] + $ stop_dune_quiet diff --git a/test/blackbox-tests/test-cases/dune-cache/trim.t b/test/blackbox-tests/test-cases/dune-cache/trim.t index 3e5046d27a7..0667a98d52a 100644 --- a/test/blackbox-tests/test-cases/dune-cache/trim.t +++ b/test/blackbox-tests/test-cases/dune-cache/trim.t @@ -77,8 +77,8 @@ entries uniformly. $ metadata_dir="$PWD/.xdg-cache/dune/db/meta/v5" $ (cd "$metadata_dir"; find . -mindepth 2 -maxdepth 2 -type f | sort) > metadata-paths $ cat metadata-paths | censor - ./0c/$DIGEST1 - ./3f/$DIGEST2 + ./53/$DIGEST1 + ./ea/$DIGEST2 $ while read path; do dune internal cache-metadata "$metadata_dir/$path"; done < metadata-paths \ > | jq_dune -S -s 'sortCacheMetadataByFirstPath' \ diff --git a/test/blackbox-tests/test-cases/sandbox-actions/basic.t b/test/blackbox-tests/test-cases/sandbox-actions/basic.t new file mode 100644 index 00000000000..7f6a7310e47 --- /dev/null +++ b/test/blackbox-tests/test-cases/sandbox-actions/basic.t @@ -0,0 +1,39 @@ +`--sandbox-actions` only invalidates stale outputs for actions that run +processes. + + $ make_dune_project 3.23 + $ export DUNE_TRACE=action + $ cat > dune <<'EOF' + > (rule + > (target pure) + > (action (write-file %{target} pure))) + > + > (rule + > (target probe) + > (action (bash "readlink /proc/self/ns/mnt > %{target}"))) + > EOF + $ readlink /proc/self/ns/mnt > host-ns + + $ dune build pure probe + $ dune trace cat | jq -s 'include "dune"; writeFileCountBySuffix("/pure")' + 1 + $ cmp -s host-ns _build/default/probe && echo same || echo different + same + $ cat _build/default/pure + pure + + $ dune build --sandbox-actions pure probe + $ dune trace cat | jq -s 'include "dune"; writeFileCountBySuffix("/pure")' + 0 + $ cmp -s host-ns _build/default/probe && echo same || echo different + different + $ cat _build/default/pure + pure + + $ dune build pure probe + $ dune trace cat | jq -s 'include "dune"; writeFileCountBySuffix("/pure")' + 0 + $ cmp -s host-ns _build/default/probe && echo same || echo different + same + $ cat _build/default/pure + pure diff --git a/test/blackbox-tests/test-cases/sandbox-actions/dune b/test/blackbox-tests/test-cases/sandbox-actions/dune new file mode 100644 index 00000000000..69d568865d2 --- /dev/null +++ b/test/blackbox-tests/test-cases/sandbox-actions/dune @@ -0,0 +1,10 @@ +(cram + (applies_to :whole_subtree) + (alias runtest-bwrap) + (runtest_alias + (<> %{env:CI=false} true)) + (deps %{bin:bwrap}) + (enabled_if + (and + (= %{system} linux) + %{bin-available:bwrap}))) diff --git a/test/blackbox-tests/test-cases/sandbox-actions/shared-cache.t b/test/blackbox-tests/test-cases/sandbox-actions/shared-cache.t new file mode 100644 index 00000000000..53393fed6b2 --- /dev/null +++ b/test/blackbox-tests/test-cases/sandbox-actions/shared-cache.t @@ -0,0 +1,47 @@ +`--sandbox-actions` prevents the worker from writing to the launching dune's +shared cache. + + $ make_dune_project 3.23 + $ export DUNE_CACHE_ROOT=$PWD/cache-root + $ echo "$DUNE_CACHE_ROOT" > cache-root-name + $ mkdir -p "$DUNE_CACHE_ROOT/db" + $ cat > dune <<'EOF' + > (rule + > (target result) + > (deps cache-root-name) + > (action + > (bash + > "if touch \"$DUNE_CACHE_ROOT/db/runner-marker\" 2>/dev/null; then echo wrote > %{target}; else echo blocked > %{target}; fi"))) + > EOF + +Normal actions can still write there. + + $ dune build result + $ cat _build/default/result + wrote + $ test -e "$DUNE_CACHE_ROOT/db/runner-marker" && echo present + present + +Sandboxed actions are blocked from writing there. + + $ rm -f "$DUNE_CACHE_ROOT/db/runner-marker" + $ dune build --sandbox-actions result + $ cat _build/default/result + blocked + $ test -e "$DUNE_CACHE_ROOT/db/runner-marker" && echo present || echo missing + missing + +If the shared cache path does not exist yet, dune creates it and still protects +it from the worker. + + $ export DUNE_CACHE_ROOT=$PWD/fresh-cache-root + $ echo "$DUNE_CACHE_ROOT" > cache-root-name + $ test -e "$DUNE_CACHE_ROOT/db" && echo present || echo missing + missing + $ dune build --sandbox-actions result + $ cat _build/default/result + blocked + $ test -d "$DUNE_CACHE_ROOT/db" && echo present || echo missing + present + $ test -e "$DUNE_CACHE_ROOT/db/runner-marker" && echo present || echo missing + missing diff --git a/test/blackbox-tests/test-cases/watching/action-runner-shutdown.t b/test/blackbox-tests/test-cases/watching/action-runner-shutdown.t new file mode 100644 index 00000000000..f673afc688f --- /dev/null +++ b/test/blackbox-tests/test-cases/watching/action-runner-shutdown.t @@ -0,0 +1,15 @@ +`dune shutdown` stops the action-runner loop in watch mode. + + $ setup_xdg_runtime_dir + $ export DUNE_TRACE=rpc + $ echo "(lang dune 3.23)" > dune-project + $ cat > dune < (rule + > (target x) + > (action (bash "echo ok > %{target}"))) + > EOF + $ start_dune --action-runner + $ build_quiet x + $ shutdown_dune_quiet >/dev/null 2>&1 + $ wait_for_dune_exit_with_timeout >/dev/null 2>&1 + $ [ "$?" = 0 ] diff --git a/test/blackbox-tests/test-cases/watching/dune b/test/blackbox-tests/test-cases/watching/dune index eaba64b99a2..5b678c849a8 100644 --- a/test/blackbox-tests/test-cases/watching/dune +++ b/test/blackbox-tests/test-cases/watching/dune @@ -44,6 +44,11 @@ source-backed-promotion) (setup_scripts promotion-helpers.sh)) +(cram + (applies_to action-runner-shutdown) + (enabled_if + (<> %{ocaml-config:system} win))) + ;; Disabled due to timeouts (cram diff --git a/test/expect-tests/build_loop_tests.ml b/test/expect-tests/build_loop_tests.ml index d0c4a358db3..f5e8b9638cf 100644 --- a/test/expect-tests/build_loop_tests.ml +++ b/test/expect-tests/build_loop_tests.ml @@ -28,11 +28,16 @@ let%expect_test "cancelling a build" = Build_loop.run (fun build_loop -> Fiber.fork_and_join_unit (fun () -> - Build_loop.poll build_loop (fun ~run_id:_ ~restart_started_at:_ -> + Build_loop.poll build_loop (fun ~restart_started_at:_ -> let* () = Fiber.Ivar.fill build_started () in let* () = Fiber.Ivar.read build_cancelled in + let cancellation = + Option.map (Process.Build.get ()) ~f:(fun { cancellation; _ } -> + cancellation) + in let* res = - Fiber.collect_errors (fun () -> Scheduler.with_job_slot Fiber.return) + Fiber.collect_errors (fun () -> + Scheduler.with_job_slot ?cancellation Fiber.return) in print_endline (match res with @@ -61,7 +66,7 @@ let%expect_test "cancelling a build: effect on other fibers" = Build_loop.run (fun build_loop -> Fiber.fork_and_join_unit (fun () -> - Build_loop.poll build_loop (fun ~run_id:_ ~restart_started_at:_ -> + Build_loop.poll build_loop (fun ~restart_started_at:_ -> let* () = Fiber.Ivar.fill build_started () in Fiber.never)) (fun () -> diff --git a/test/expect-tests/dune_pkg/rev_store_fetch_depth/rev_store_fetch_depth_test.ml b/test/expect-tests/dune_pkg/rev_store_fetch_depth/rev_store_fetch_depth_test.ml index 6d0ddc149d6..8ed66a28fdf 100644 --- a/test/expect-tests/dune_pkg/rev_store_fetch_depth/rev_store_fetch_depth_test.ml +++ b/test/expect-tests/dune_pkg/rev_store_fetch_depth/rev_store_fetch_depth_test.ml @@ -34,6 +34,11 @@ let%expect_test "second fetch uses refs for efficient negotiation (fix #13323)" (Dune_scheduler.Scheduler.Run.go { concurrency = 2; print_ctrl_c_warning = false; watch_exclusions = [] } @@ fun () -> + let build = + { Dune_engine.Process.Build.run_id = Dune_engine.Run_id.Batch + ; cancellation = Fiber.Cancel.create () + } + in let* rev_store = Rev_store.get in let git = git ~dir:repo_dir in (* Create a repository with initial commits *) @@ -93,6 +98,7 @@ let%expect_test "second fetch uses refs for efficient negotiation (fix #13323)" Dune_engine.Process.run ~dir:parent_dir ~display + ~build ~stdout_to:(make_stdout ()) ~stderr_to:(make_stderr ()) Dune_engine.Process.Failure_mode.( @@ -195,7 +201,7 @@ let%expect_test "second fetch uses refs for efficient negotiation (fix #13323)" |> List.length in Console.print [ Pp.textf "Negotiation 'have' lines sent: %d" have_count ]; - Dune_scheduler.Scheduler.cancel_current_build ())); + Fiber.Cancel.fire build.cancellation)); (* With refs created by previous fetches, git can tell the server what it already has, avoiding redundant downloads. The count does not include refs from the unrelated remote due to URL-based namespacing. *)