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:
parent
3b9fb8df0a
commit
bf2d842075
|
@ -1402,7 +1402,7 @@ let promote =
|
||||||
(* We load and restore the digest cache as we need to clear the
|
(* We load and restore the digest cache as we need to clear the
|
||||||
cache for promoted files, due to issues on OSX. *)
|
cache for promoted files, due to issues on OSX. *)
|
||||||
Utils.Cached_digest.load ();
|
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 ()
|
Utils.Cached_digest.dump ()
|
||||||
in
|
in
|
||||||
(term, Term.info "promote" ~doc ~man )
|
(term, Term.info "promote" ~doc ~man )
|
||||||
|
|
353
src/action.ml
353
src/action.ml
|
@ -597,359 +597,6 @@ let chdirs =
|
||||||
fold_one_step t ~init:acc ~f:loop
|
fold_one_step t ~init:acc ~f:loop
|
||||||
in
|
in
|
||||||
fun t -> loop Path.Set.empty t
|
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 Infer = struct
|
||||||
module Outcome = struct
|
module Outcome = struct
|
||||||
type t =
|
type t =
|
||||||
|
|
|
@ -95,16 +95,6 @@ module Unexpanded : sig
|
||||||
-> Partial.t
|
-> Partial.t
|
||||||
end
|
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.
|
(** Infer dependencies and targets.
|
||||||
|
|
||||||
This currently doesn't support well (rename ...) and (remove-tree ...). However these
|
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
|
val unexpanded_targets : Unexpanded.t -> String_with_vars.t list
|
||||||
end
|
end
|
||||||
|
|
||||||
module Promotion : sig
|
val map
|
||||||
module File : sig
|
: t
|
||||||
type t =
|
-> dir:Path.t
|
||||||
{ src : Path.t
|
-> f_program:(dir:Path.t -> Prog.t -> Prog.t)
|
||||||
; dst : Path.t
|
-> f_string:(dir:Path.t -> string -> string)
|
||||||
}
|
-> f_path:(dir:Path.t -> Path.t -> Path.t)
|
||||||
|
-> 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
|
|
||||||
|
|
|
@ -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))
|
||||||
|
]
|
|
@ -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
|
|
@ -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
|
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 all_deps ~map_path:sandboxed;
|
||||||
make_local_parent_dirs t targets ~map_path:sandboxed;
|
make_local_parent_dirs t targets ~map_path:sandboxed;
|
||||||
Action.sandbox action
|
Action_exec.sandbox action
|
||||||
~sandboxed
|
~sandboxed
|
||||||
~deps:all_deps_as_list
|
~deps:all_deps_as_list
|
||||||
~targets:targets_as_list
|
~targets:targets_as_list
|
||||||
|
@ -805,7 +805,7 @@ let rec compile_rule t ?(copy_source=false) pre_rule =
|
||||||
in
|
in
|
||||||
make_local_dirs t (Action.chdirs action);
|
make_local_dirs t (Action.chdirs action);
|
||||||
with_locks locks ~f:(fun () ->
|
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;
|
Option.iter sandbox_dir ~f:Path.rm_rf;
|
||||||
(* All went well, these targets are no longer pending *)
|
(* All went well, these targets are no longer pending *)
|
||||||
pending_targets := Path.Set.diff !pending_targets targets;
|
pending_targets := Path.Set.diff !pending_targets targets;
|
||||||
|
@ -1214,7 +1214,7 @@ let all_targets t =
|
||||||
let finalize t =
|
let finalize t =
|
||||||
(* Promotion must be handled before dumping the digest cache, as it
|
(* Promotion must be handled before dumping the digest cache, as it
|
||||||
might delete some entries. *)
|
might delete some entries. *)
|
||||||
Action.Promotion.finalize ();
|
Action_exec.Promotion.finalize ();
|
||||||
Promoted_to_delete.dump ();
|
Promoted_to_delete.dump ();
|
||||||
Utils.Cached_digest.dump ();
|
Utils.Cached_digest.dump ();
|
||||||
Trace.dump t.trace
|
Trace.dump t.trace
|
||||||
|
|
Loading…
Reference in New Issue