Merge pull request #1031 from rgrinberg/action-exec
Action exec & Promotion modules
This commit is contained in:
commit
6b29a24d89
|
@ -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 ();
|
||||
Promotion.promote_files_registered_in_last_run ();
|
||||
Utils.Cached_digest.dump ()
|
||||
in
|
||||
(term, Term.info "promote" ~doc ~man )
|
||||
|
|
372
src/action.ml
372
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)
|
||||
"(<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 =
|
||||
|
@ -1107,3 +754,22 @@ module Infer = struct
|
|||
let unexpanded_targets t =
|
||||
(Unexp.infer t).targets
|
||||
end
|
||||
|
||||
let sandbox t ~sandboxed ~deps ~targets : t =
|
||||
Progn
|
||||
[ Progn (List.filter_map deps ~f:(fun path ->
|
||||
if Path.is_managed path then
|
||||
Some (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 (Rename (sandboxed path, path))
|
||||
else
|
||||
None))
|
||||
]
|
||||
|
|
|
@ -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
|
||||
(** Return a sandboxed version of an action *)
|
||||
val sandbox
|
||||
: t
|
||||
-> sandboxed:(Path.t -> Path.t)
|
||||
-> deps:Path.t list
|
||||
-> targets:Path.t list
|
||||
-> t
|
||||
|
|
|
@ -0,0 +1,229 @@
|
|||
open Import
|
||||
open Fiber.O
|
||||
|
||||
type exec_context =
|
||||
{ context : Context.t option
|
||||
; purpose : Process.purpose
|
||||
}
|
||||
|
||||
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
|
|
@ -0,0 +1,7 @@
|
|||
open Stdune
|
||||
|
||||
val exec
|
||||
: targets:Path.Set.t
|
||||
-> context:Context.t option
|
||||
-> Action.t
|
||||
-> unit Fiber.t
|
|
@ -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 ();
|
||||
Promotion.finalize ();
|
||||
Promoted_to_delete.dump ();
|
||||
Utils.Cached_digest.dump ();
|
||||
Trace.dump t.trace
|
||||
|
|
|
@ -0,0 +1,104 @@
|
|||
open Stdune
|
||||
|
||||
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 []
|
|
@ -0,0 +1,17 @@
|
|||
open Stdune
|
||||
|
||||
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
|
Loading…
Reference in New Issue