From bf2d84207540589438ffffd2f5afe26e39833c63 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Wed, 18 Jul 2018 11:18:25 +0200 Subject: [PATCH] Split executable parts of Action into Action_exec This is required for breaking the dep cycle between the context and the Action module Signed-off-by: Rudi Grinberg --- bin/main.ml | 2 +- src/action.ml | 353 ------------------------------------------- src/action.mli | 34 +---- src/action_exec.ml | 354 ++++++++++++++++++++++++++++++++++++++++++++ src/action_exec.mli | 33 +++++ src/build_system.ml | 6 +- 6 files changed, 398 insertions(+), 384 deletions(-) create mode 100644 src/action_exec.ml create mode 100644 src/action_exec.mli diff --git a/bin/main.ml b/bin/main.ml index 276aa627..f742e029 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -1402,7 +1402,7 @@ let promote = (* We load and restore the digest cache as we need to clear the cache for promoted files, due to issues on OSX. *) Utils.Cached_digest.load (); - Action.Promotion.promote_files_registered_in_last_run (); + Action_exec.Promotion.promote_files_registered_in_last_run (); Utils.Cached_digest.dump () in (term, Term.info "promote" ~doc ~man ) diff --git a/src/action.ml b/src/action.ml index 58802cac..ddf439a3 100644 --- a/src/action.ml +++ b/src/action.ml @@ -597,359 +597,6 @@ let chdirs = fold_one_step t ~init:acc ~f:loop in fun t -> loop Path.Set.empty t - -open Fiber.O - -let get_std_output : _ -> Process.std_output_to = function - | None -> Terminal - | Some (fn, oc) -> - Opened_file { filename = fn - ; tail = false - ; desc = Channel oc } - -module Promotion = struct - module File = struct - type t = - { src : Path.t - ; dst : Path.t - } - - (* XXX these sexp converters will be useful for the dump command *) - let _t = - let open Sexp.Of_sexp in - peek_exn >>= function - | List (_, [_; Atom (_, A "as"); _]) -> - enter - (Path.t >>= fun src -> - junk >>= fun () -> - Path.t >>= fun dst -> - return { src; dst }) - | sexp -> - Sexp.Of_sexp.of_sexp_errorf (Sexp.Ast.loc sexp) - "( as ) expected" - - let _sexp_of_t { src; dst } = - Sexp.List [Path.sexp_of_t src; Sexp.unsafe_atom_of_string "as"; - Path.sexp_of_t dst] - - let db : t list ref = ref [] - - let register t = db := t :: !db - - let promote { src; dst } = - Format.eprintf "Promoting %s to %s.@." - (Path.to_string_maybe_quoted src) - (Path.to_string_maybe_quoted dst); - Io.copy_file ~src ~dst () - end - - module P = Utils.Persistent(struct - type t = File.t list - let name = "TO-PROMOTE" - let version = 1 - end) - - let db_file = Path.relative Path.build_dir ".to-promote" - - let dump_db db = - if Path.build_dir_exists () then begin - match db with - | [] -> if Path.exists db_file then Path.unlink_no_err db_file - | l -> P.dump db_file l - end - - let load_db () = Option.value ~default:[] (P.load db_file) - - let group_by_targets db = - List.map db ~f:(fun { File. src; dst } -> - (dst, src)) - |> Path.Map.of_list_multi - (* Sort the list of possible sources for deterministic behavior *) - |> Path.Map.map ~f:(List.sort ~compare:Path.compare) - - let do_promote db = - let by_targets = group_by_targets db in - let potential_build_contexts = - match Path.readdir_unsorted Path.build_dir with - | exception _ -> [] - | files -> - List.filter_map files ~f:(fun fn -> - if fn = "" || fn.[0] = '.' || fn = "install" then - None - else - let path = Path.(relative build_dir) fn in - Option.some_if (Path.is_directory path) path) - in - let dirs_to_clear_from_cache = Path.root :: potential_build_contexts in - Path.Map.iteri by_targets ~f:(fun dst srcs -> - match srcs with - | [] -> assert false - | src :: others -> - (* We remove the files from the digest cache to force a rehash - on the next run. We do this because on OSX [mtime] is not - precise enough and if a file is modified and promoted - quickly, it will look like it hasn't changed even though it - might have. *) - List.iter dirs_to_clear_from_cache ~f:(fun dir -> - Utils.Cached_digest.remove (Path.append dir dst)); - File.promote { src; dst }; - List.iter others ~f:(fun path -> - Format.eprintf " -> ignored %s.@." - (Path.to_string_maybe_quoted path))) - - let finalize () = - let db = - if !Clflags.auto_promote then - (do_promote !File.db; []) - else - !File.db - in - dump_db db - - let promote_files_registered_in_last_run () = - let db = load_db () in - do_promote db; - dump_db [] -end - -type exec_context = - { context : Context.t option - ; purpose : Process.purpose - } - -let exec_run_direct ~ectx ~dir ~env ~stdout_to ~stderr_to prog args = - begin match ectx.context with - | None - | Some { Context.for_host = None; _ } -> () - | Some ({ Context.for_host = Some host; _ } as target) -> - let invalid_prefix prefix = - match Path.descendant prog ~of_:prefix with - | None -> () - | Some _ -> - die "Context %s has a host %s.@.It's not possible to execute binary %a \ - in it.@.@.This is a bug and should be reported upstream." - target.name host.name Path.pp prog in - invalid_prefix (Path.relative Path.build_dir target.name); - invalid_prefix (Path.relative Path.build_dir ("install/" ^ target.name)); - end; - Process.run Strict ~dir ~env - ~stdout_to ~stderr_to - ~purpose:ectx.purpose - prog args - -let exec_run ~stdout_to ~stderr_to = - let stdout_to = get_std_output stdout_to in - let stderr_to = get_std_output stderr_to in - exec_run_direct ~stdout_to ~stderr_to - -let exec_echo stdout_to str = - Fiber.return - (match stdout_to with - | None -> print_string str; flush stdout - | Some (_, oc) -> output_string oc str) - -let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to = - match t with - | Run (Error e, _) -> - Prog.Not_found.raise e - | Run (Ok prog, args) -> - exec_run ~ectx ~dir ~env ~stdout_to ~stderr_to prog args - | Chdir (dir, t) -> - exec t ~ectx ~dir ~env ~stdout_to ~stderr_to - | Setenv (var, value, t) -> - exec t ~ectx ~dir ~stdout_to ~stderr_to - ~env:(Env.add env ~var ~value) - | Redirect (Stdout, fn, Echo s) -> - Io.write_file fn (String.concat s ~sep:" "); - Fiber.return () - | Redirect (outputs, fn, Run (Ok prog, args)) -> - let out = Process.File fn in - let stdout_to, stderr_to = - match outputs with - | Stdout -> (out, get_std_output stderr_to) - | Stderr -> (get_std_output stdout_to, out) - | Outputs -> (out, out) - in - exec_run_direct ~ectx ~dir ~env ~stdout_to ~stderr_to prog args - | Redirect (outputs, fn, t) -> - redirect ~ectx ~dir outputs fn t ~env ~stdout_to ~stderr_to - | Ignore (outputs, t) -> - redirect ~ectx ~dir outputs Config.dev_null t ~env ~stdout_to ~stderr_to - | Progn l -> - exec_list l ~ectx ~dir ~env ~stdout_to ~stderr_to - | Echo strs -> exec_echo stdout_to (String.concat strs ~sep:" ") - | Cat fn -> - Io.with_file_in fn ~f:(fun ic -> - let oc = - match stdout_to with - | None -> stdout - | Some (_, oc) -> oc - in - Io.copy_channels ic oc); - Fiber.return () - | Copy (src, dst) -> - Io.copy_file ~src ~dst (); - Fiber.return () - | Symlink (src, dst) -> - if Sys.win32 then - Io.copy_file ~src ~dst () - else begin - let src = - match Path.parent dst with - | None -> Path.to_string src - | Some from -> Path.reach ~from src - in - let dst = Path.to_string dst in - match Unix.readlink dst with - | target -> - if target <> src then begin - (* @@DRA Win32 remove read-only attribute needed when symlinking enabled *) - Unix.unlink dst; - Unix.symlink src dst - end - | exception _ -> - Unix.symlink src dst - end; - Fiber.return () - | Copy_and_add_line_directive (src, dst) -> - Io.with_file_in src ~f:(fun ic -> - Io.with_file_out dst ~f:(fun oc -> - let fn = Path.drop_optional_build_context src in - let directive = - if List.mem (Path.extension fn) ~set:[".c"; ".cpp"; ".h"] then - "line" - else - "" - in - Printf.fprintf oc "#%s 1 %S\n" directive (Path.to_string fn); - Io.copy_channels ic oc)); - Fiber.return () - | System cmd -> - let path, arg = - Utils.system_shell_exn ~needed_to:"interpret (system ...) actions" - in - exec_run ~ectx ~dir ~env ~stdout_to ~stderr_to path [arg; cmd] - | Bash cmd -> - exec_run ~ectx ~dir ~env ~stdout_to ~stderr_to - (Utils.bash_exn ~needed_to:"interpret (bash ...) actions") - ["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd] - | Write_file (fn, s) -> - Io.write_file fn s; - Fiber.return () - | Rename (src, dst) -> - Unix.rename (Path.to_string src) (Path.to_string dst); - Fiber.return () - | Remove_tree path -> - Path.rm_rf path; - Fiber.return () - | Mkdir path -> - Path.mkdir_p path; - Fiber.return () - | Digest_files paths -> - let s = - let data = - List.map paths ~f:(fun fn -> - (Path.to_string fn, Utils.Cached_digest.file fn)) - in - Digest.string - (Marshal.to_string data []) - in - exec_echo stdout_to s - | Diff { optional; file1; file2; mode } -> - let compare_files = - match mode with - | Text_jbuild | Binary -> Io.compare_files - | Text -> Io.compare_text_files - in - if (optional && not (Path.exists file1 && Path.exists file2)) || - compare_files file1 file2 = Eq then - Fiber.return () - else begin - let is_copied_from_source_tree file = - match Path.drop_build_context file with - | None -> false - | Some file -> Path.exists file - in - if is_copied_from_source_tree file1 && - not (is_copied_from_source_tree file2) then begin - Promotion.File.register - { src = file2 - ; dst = Option.value_exn (Path.drop_build_context file1) - } - end; - if mode = Binary then - die "@{Error@}: Files %s and %s differ." - (Path.to_string_maybe_quoted file1) - (Path.to_string_maybe_quoted file2) - else - Print_diff.print file1 file2 - ~skip_trailing_cr:(mode = Text && Sys.win32) - end - | Merge_files_into (sources, extras, target) -> - let lines = - List.fold_left - ~init:(String.Set.of_list extras) - ~f:(fun set source_path -> - Io.lines_of_file source_path - |> String.Set.of_list - |> String.Set.union set - ) - sources - in - Io.write_lines target (String.Set.to_list lines); - Fiber.return () - -and redirect outputs fn t ~ectx ~dir ~env ~stdout_to ~stderr_to = - let oc = Io.open_out fn in - let out = Some (fn, oc) in - let stdout_to, stderr_to = - match outputs with - | Stdout -> (out, stderr_to) - | Stderr -> (stdout_to, out) - | Outputs -> (out, out) - in - exec t ~ectx ~dir ~env ~stdout_to ~stderr_to >>| fun () -> - close_out oc - -and exec_list l ~ectx ~dir ~env ~stdout_to ~stderr_to = - match l with - | [] -> - Fiber.return () - | [t] -> - exec t ~ectx ~dir ~env ~stdout_to ~stderr_to - | t :: rest -> - exec t ~ectx ~dir ~env ~stdout_to ~stderr_to >>= fun () -> - exec_list rest ~ectx ~dir ~env ~stdout_to ~stderr_to - -let exec ~targets ~context t = - let env = - match (context : Context.t option) with - | None -> Env.initial - | Some c -> c.env - in - let purpose = Process.Build_job targets in - let ectx = { purpose; context } in - exec t ~ectx ~dir:Path.root ~env ~stdout_to:None ~stderr_to:None - -let sandbox t ~sandboxed ~deps ~targets = - Progn - [ Progn (List.filter_map deps ~f:(fun path -> - if Path.is_managed path then - Some (Ast.Symlink (path, sandboxed path)) - else - None)) - ; map t - ~dir:Path.root - ~f_string:(fun ~dir:_ x -> x) - ~f_path:(fun ~dir:_ p -> sandboxed p) - ~f_program:(fun ~dir:_ x -> Result.map x ~f:sandboxed) - ; Progn (List.filter_map targets ~f:(fun path -> - if Path.is_managed path then - Some (Ast.Rename (sandboxed path, path)) - else - None)) - ] - module Infer = struct module Outcome = struct type t = diff --git a/src/action.mli b/src/action.mli index 4a7d32ad..ea79a690 100644 --- a/src/action.mli +++ b/src/action.mli @@ -95,16 +95,6 @@ module Unexpanded : sig -> Partial.t end -val exec : targets:Path.Set.t -> context:Context.t option -> t -> unit Fiber.t - -(* Return a sandboxed version of an action *) -val sandbox - : t - -> sandboxed:(Path.t -> Path.t) - -> deps:Path.t list - -> targets:Path.t list - -> t - (** Infer dependencies and targets. This currently doesn't support well (rename ...) and (remove-tree ...). However these @@ -127,20 +117,10 @@ module Infer : sig val unexpanded_targets : Unexpanded.t -> String_with_vars.t list end -module Promotion : sig - module File : sig - type t = - { src : Path.t - ; dst : Path.t - } - - (** Register a file to promote *) - val register : t -> unit - end - - (** Promote all registered files if [!Clflags.auto_promote]. Otherwise dump the list of - registered files to [_build/.to-promote]. *) - val finalize : unit -> unit - - val promote_files_registered_in_last_run : unit -> unit -end +val map + : t + -> dir:Path.t + -> f_program:(dir:Path.t -> Prog.t -> Prog.t) + -> f_string:(dir:Path.t -> string -> string) + -> f_path:(dir:Path.t -> Path.t -> Path.t) + -> t diff --git a/src/action_exec.ml b/src/action_exec.ml new file mode 100644 index 00000000..6e173672 --- /dev/null +++ b/src/action_exec.ml @@ -0,0 +1,354 @@ +open Import +open Fiber.O + +type exec_context = + { context : Context.t option + ; purpose : Process.purpose + } + +module Promotion = struct + module File = struct + type t = + { src : Path.t + ; dst : Path.t + } + + (* XXX these sexp converters will be useful for the dump command *) + let _t = + let open Sexp.Of_sexp in + peek_exn >>= function + | List (_, [_; Atom (_, A "as"); _]) -> + enter + (Path.t >>= fun src -> + junk >>= fun () -> + Path.t >>= fun dst -> + return { src; dst }) + | sexp -> + Sexp.Of_sexp.of_sexp_errorf (Sexp.Ast.loc sexp) + "( as ) expected" + + let _sexp_of_t { src; dst } = + Sexp.List [Path.sexp_of_t src; Sexp.unsafe_atom_of_string "as"; + Path.sexp_of_t dst] + + let db : t list ref = ref [] + + let register t = db := t :: !db + + let promote { src; dst } = + Format.eprintf "Promoting %s to %s.@." + (Path.to_string_maybe_quoted src) + (Path.to_string_maybe_quoted dst); + Io.copy_file ~src ~dst () + end + + module P = Utils.Persistent(struct + type t = File.t list + let name = "TO-PROMOTE" + let version = 1 + end) + + let db_file = Path.relative Path.build_dir ".to-promote" + + let dump_db db = + if Path.build_dir_exists () then begin + match db with + | [] -> if Path.exists db_file then Path.unlink_no_err db_file + | l -> P.dump db_file l + end + + let load_db () = Option.value ~default:[] (P.load db_file) + + let group_by_targets db = + List.map db ~f:(fun { File. src; dst } -> + (dst, src)) + |> Path.Map.of_list_multi + (* Sort the list of possible sources for deterministic behavior *) + |> Path.Map.map ~f:(List.sort ~compare:Path.compare) + + let do_promote db = + let by_targets = group_by_targets db in + let potential_build_contexts = + match Path.readdir_unsorted Path.build_dir with + | exception _ -> [] + | files -> + List.filter_map files ~f:(fun fn -> + if fn = "" || fn.[0] = '.' || fn = "install" then + None + else + let path = Path.(relative build_dir) fn in + Option.some_if (Path.is_directory path) path) + in + let dirs_to_clear_from_cache = Path.root :: potential_build_contexts in + Path.Map.iteri by_targets ~f:(fun dst srcs -> + match srcs with + | [] -> assert false + | src :: others -> + (* We remove the files from the digest cache to force a rehash + on the next run. We do this because on OSX [mtime] is not + precise enough and if a file is modified and promoted + quickly, it will look like it hasn't changed even though it + might have. *) + List.iter dirs_to_clear_from_cache ~f:(fun dir -> + Utils.Cached_digest.remove (Path.append dir dst)); + File.promote { src; dst }; + List.iter others ~f:(fun path -> + Format.eprintf " -> ignored %s.@." + (Path.to_string_maybe_quoted path))) + + let finalize () = + let db = + if !Clflags.auto_promote then + (do_promote !File.db; []) + else + !File.db + in + dump_db db + + let promote_files_registered_in_last_run () = + let db = load_db () in + do_promote db; + dump_db [] +end + + +let get_std_output : _ -> Process.std_output_to = function + | None -> Terminal + | Some (fn, oc) -> + Opened_file { filename = fn + ; tail = false + ; desc = Channel oc } + + +let exec_run_direct ~ectx ~dir ~env ~stdout_to ~stderr_to prog args = + begin match ectx.context with + | None + | Some { Context.for_host = None; _ } -> () + | Some ({ Context.for_host = Some host; _ } as target) -> + let invalid_prefix prefix = + match Path.descendant prog ~of_:prefix with + | None -> () + | Some _ -> + die "Context %s has a host %s.@.It's not possible to execute binary %a \ + in it.@.@.This is a bug and should be reported upstream." + target.name host.name Path.pp prog in + invalid_prefix (Path.relative Path.build_dir target.name); + invalid_prefix (Path.relative Path.build_dir ("install/" ^ target.name)); + end; + Process.run Strict ~dir ~env + ~stdout_to ~stderr_to + ~purpose:ectx.purpose + prog args + +let exec_run ~stdout_to ~stderr_to = + let stdout_to = get_std_output stdout_to in + let stderr_to = get_std_output stderr_to in + exec_run_direct ~stdout_to ~stderr_to + +let exec_echo stdout_to str = + Fiber.return + (match stdout_to with + | None -> print_string str; flush stdout + | Some (_, oc) -> output_string oc str) + +let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to = + match (t : Action.t) with + | Run (Error e, _) -> + Action.Prog.Not_found.raise e + | Run (Ok prog, args) -> + exec_run ~ectx ~dir ~env ~stdout_to ~stderr_to prog args + | Chdir (dir, t) -> + exec t ~ectx ~dir ~env ~stdout_to ~stderr_to + | Setenv (var, value, t) -> + exec t ~ectx ~dir ~stdout_to ~stderr_to + ~env:(Env.add env ~var ~value) + | Redirect (Stdout, fn, Echo s) -> + Io.write_file fn (String.concat s ~sep:" "); + Fiber.return () + | Redirect (outputs, fn, Run (Ok prog, args)) -> + let out = Process.File fn in + let stdout_to, stderr_to = + match outputs with + | Stdout -> (out, get_std_output stderr_to) + | Stderr -> (get_std_output stdout_to, out) + | Outputs -> (out, out) + in + exec_run_direct ~ectx ~dir ~env ~stdout_to ~stderr_to prog args + | Redirect (outputs, fn, t) -> + redirect ~ectx ~dir outputs fn t ~env ~stdout_to ~stderr_to + | Ignore (outputs, t) -> + redirect ~ectx ~dir outputs Config.dev_null t ~env ~stdout_to ~stderr_to + | Progn l -> + exec_list l ~ectx ~dir ~env ~stdout_to ~stderr_to + | Echo strs -> exec_echo stdout_to (String.concat strs ~sep:" ") + | Cat fn -> + Io.with_file_in fn ~f:(fun ic -> + let oc = + match stdout_to with + | None -> stdout + | Some (_, oc) -> oc + in + Io.copy_channels ic oc); + Fiber.return () + | Copy (src, dst) -> + Io.copy_file ~src ~dst (); + Fiber.return () + | Symlink (src, dst) -> + if Sys.win32 then + Io.copy_file ~src ~dst () + else begin + let src = + match Path.parent dst with + | None -> Path.to_string src + | Some from -> Path.reach ~from src + in + let dst = Path.to_string dst in + match Unix.readlink dst with + | target -> + if target <> src then begin + (* @@DRA Win32 remove read-only attribute needed when symlinking enabled *) + Unix.unlink dst; + Unix.symlink src dst + end + | exception _ -> + Unix.symlink src dst + end; + Fiber.return () + | Copy_and_add_line_directive (src, dst) -> + Io.with_file_in src ~f:(fun ic -> + Io.with_file_out dst ~f:(fun oc -> + let fn = Path.drop_optional_build_context src in + let directive = + if List.mem (Path.extension fn) ~set:[".c"; ".cpp"; ".h"] then + "line" + else + "" + in + Printf.fprintf oc "#%s 1 %S\n" directive (Path.to_string fn); + Io.copy_channels ic oc)); + Fiber.return () + | System cmd -> + let path, arg = + Utils.system_shell_exn ~needed_to:"interpret (system ...) actions" + in + exec_run ~ectx ~dir ~env ~stdout_to ~stderr_to path [arg; cmd] + | Bash cmd -> + exec_run ~ectx ~dir ~env ~stdout_to ~stderr_to + (Utils.bash_exn ~needed_to:"interpret (bash ...) actions") + ["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd] + | Write_file (fn, s) -> + Io.write_file fn s; + Fiber.return () + | Rename (src, dst) -> + Unix.rename (Path.to_string src) (Path.to_string dst); + Fiber.return () + | Remove_tree path -> + Path.rm_rf path; + Fiber.return () + | Mkdir path -> + Path.mkdir_p path; + Fiber.return () + | Digest_files paths -> + let s = + let data = + List.map paths ~f:(fun fn -> + (Path.to_string fn, Utils.Cached_digest.file fn)) + in + Digest.string + (Marshal.to_string data []) + in + exec_echo stdout_to s + | Diff { optional; file1; file2; mode } -> + let compare_files = + match mode with + | Text_jbuild | Binary -> Io.compare_files + | Text -> Io.compare_text_files + in + if (optional && not (Path.exists file1 && Path.exists file2)) || + compare_files file1 file2 = Eq then + Fiber.return () + else begin + let is_copied_from_source_tree file = + match Path.drop_build_context file with + | None -> false + | Some file -> Path.exists file + in + if is_copied_from_source_tree file1 && + not (is_copied_from_source_tree file2) then begin + Promotion.File.register + { src = file2 + ; dst = Option.value_exn (Path.drop_build_context file1) + } + end; + if mode = Binary then + die "@{Error@}: Files %s and %s differ." + (Path.to_string_maybe_quoted file1) + (Path.to_string_maybe_quoted file2) + else + Print_diff.print file1 file2 + ~skip_trailing_cr:(mode = Text && Sys.win32) + end + | Merge_files_into (sources, extras, target) -> + let lines = + List.fold_left + ~init:(String.Set.of_list extras) + ~f:(fun set source_path -> + Io.lines_of_file source_path + |> String.Set.of_list + |> String.Set.union set + ) + sources + in + Io.write_lines target (String.Set.to_list lines); + Fiber.return () + +and redirect outputs fn t ~ectx ~dir ~env ~stdout_to ~stderr_to = + let oc = Io.open_out fn in + let out = Some (fn, oc) in + let stdout_to, stderr_to = + match outputs with + | Stdout -> (out, stderr_to) + | Stderr -> (stdout_to, out) + | Outputs -> (out, out) + in + exec t ~ectx ~dir ~env ~stdout_to ~stderr_to >>| fun () -> + close_out oc + +and exec_list l ~ectx ~dir ~env ~stdout_to ~stderr_to = + match l with + | [] -> + Fiber.return () + | [t] -> + exec t ~ectx ~dir ~env ~stdout_to ~stderr_to + | t :: rest -> + exec t ~ectx ~dir ~env ~stdout_to ~stderr_to >>= fun () -> + exec_list rest ~ectx ~dir ~env ~stdout_to ~stderr_to + +let exec ~targets ~context t = + let env = + match (context : Context.t option) with + | None -> Env.initial + | Some c -> c.env + in + let purpose = Process.Build_job targets in + let ectx = { purpose; context } in + exec t ~ectx ~dir:Path.root ~env ~stdout_to:None ~stderr_to:None + +let sandbox t ~sandboxed ~deps ~targets : Action.t = + Progn + [ Progn (List.filter_map deps ~f:(fun path -> + if Path.is_managed path then + Some (Action.Symlink (path, sandboxed path)) + else + None)) + ; Action.map t + ~dir:Path.root + ~f_string:(fun ~dir:_ x -> x) + ~f_path:(fun ~dir:_ p -> sandboxed p) + ~f_program:(fun ~dir:_ x -> Result.map x ~f:sandboxed) + ; Progn (List.filter_map targets ~f:(fun path -> + if Path.is_managed path then + Some (Action.Rename (sandboxed path, path)) + else + None)) + ] diff --git a/src/action_exec.mli b/src/action_exec.mli new file mode 100644 index 00000000..bd869b85 --- /dev/null +++ b/src/action_exec.mli @@ -0,0 +1,33 @@ +open Stdune + +module Promotion : sig + module File : sig + type t = + { src : Path.t + ; dst : Path.t + } + + (** Register a file to promote *) + val register : t -> unit + end + + (** Promote all registered files if [!Clflags.auto_promote]. Otherwise dump the list of + registered files to [_build/.to-promote]. *) + val finalize : unit -> unit + + val promote_files_registered_in_last_run : unit -> unit +end + +val exec + : targets:Path.Set.t + -> context:Context.t option + -> Action.t + -> unit Fiber.t + +(* Return a sandboxed version of an action *) +val sandbox + : Action.t + -> sandboxed:(Path.t -> Path.t) + -> deps:Path.t list + -> targets:Path.t list + -> Action.t diff --git a/src/build_system.ml b/src/build_system.ml index 7cfded1f..c9cd0f99 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -796,7 +796,7 @@ let rec compile_rule t ?(copy_source=false) pre_rule = let sandboxed path = Path.sandbox_managed_paths ~sandbox_dir path in make_local_parent_dirs t all_deps ~map_path:sandboxed; make_local_parent_dirs t targets ~map_path:sandboxed; - Action.sandbox action + Action_exec.sandbox action ~sandboxed ~deps:all_deps_as_list ~targets:targets_as_list @@ -805,7 +805,7 @@ let rec compile_rule t ?(copy_source=false) pre_rule = in make_local_dirs t (Action.chdirs action); with_locks locks ~f:(fun () -> - Action.exec ~context ~targets action) >>| fun () -> + Action_exec.exec ~context ~targets action) >>| fun () -> Option.iter sandbox_dir ~f:Path.rm_rf; (* All went well, these targets are no longer pending *) pending_targets := Path.Set.diff !pending_targets targets; @@ -1214,7 +1214,7 @@ let all_targets t = let finalize t = (* Promotion must be handled before dumping the digest cache, as it might delete some entries. *) - Action.Promotion.finalize (); + Action_exec.Promotion.finalize (); Promoted_to_delete.dump (); Utils.Cached_digest.dump (); Trace.dump t.trace