From 1b71d57bba457ef4d573223f56dedc3b8596279a Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Wed, 18 Jul 2018 11:20:48 +0200 Subject: [PATCH] Move promotion to own module It's not really related to actions Signed-off-by: Rudi Grinberg --- bin/main.ml | 2 +- src/action_exec.ml | 106 -------------------------------------------- src/action_exec.mli | 18 -------- src/build_system.ml | 2 +- src/promotion.ml | 104 +++++++++++++++++++++++++++++++++++++++++++ src/promotion.mli | 17 +++++++ 6 files changed, 123 insertions(+), 126 deletions(-) create mode 100644 src/promotion.ml create mode 100644 src/promotion.mli diff --git a/bin/main.ml b/bin/main.ml index f742e029..02d7d7c1 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_exec.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 ) diff --git a/src/action_exec.ml b/src/action_exec.ml index 6e173672..59c4b32a 100644 --- a/src/action_exec.ml +++ b/src/action_exec.ml @@ -6,112 +6,6 @@ type exec_context = ; 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) -> diff --git a/src/action_exec.mli b/src/action_exec.mli index bd869b85..c3b1d6cb 100644 --- a/src/action_exec.mli +++ b/src/action_exec.mli @@ -1,23 +1,5 @@ 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 diff --git a/src/build_system.ml b/src/build_system.ml index c9cd0f99..4c3a5278 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -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_exec.Promotion.finalize (); + Promotion.finalize (); Promoted_to_delete.dump (); Utils.Cached_digest.dump (); Trace.dump t.trace diff --git a/src/promotion.ml b/src/promotion.ml new file mode 100644 index 00000000..5873b2a2 --- /dev/null +++ b/src/promotion.ml @@ -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) + "( 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 [] diff --git a/src/promotion.mli b/src/promotion.mli new file mode 100644 index 00000000..56ce9ad7 --- /dev/null +++ b/src/promotion.mli @@ -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