matthieu
/
dune
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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 <rudi.grinberg@gmail.com>
This commit is contained in:
Rudi Grinberg 2018-07-18 11:18:25 +02:00
parent 3b9fb8df0a
commit bf2d842075
6 changed files with 398 additions and 384 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
bin/main.ml
View File

@ -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 )

353
src/action.ml
View File

@ -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)
"(<file> as <file>) 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>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 =

34
src/action.mli
View File

@ -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

354
src/action_exec.ml Normal file
View File

@ -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)
"(<file> as <file>) 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>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))
]

33
src/action_exec.mli Normal file
View File

@ -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

6
src/build_system.ml
View File

@ -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