From fc9f3357abd8106765d9217153b3925b2c0fbdf7 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Thu, 28 Jun 2018 17:55:52 +0100 Subject: [PATCH] Allow some part of a Build.t to be lazy This is useful for (alias_rec ...) since at definition site we recurse through all sub-directories. This is especially relevant now that we have the default alias which defaults to (alias_rec install). Signed-off-by: Jeremie Dimino --- src/build.ml | 3 ++ src/build.mli | 5 +++ src/build_interpret.ml | 46 ++++++++++++++++--------- src/build_system.ml | 77 ++++++++++++++++++++++++------------------ 4 files changed, 82 insertions(+), 49 deletions(-) diff --git a/src/build.ml b/src/build.ml index 94310da1..034bd03c 100644 --- a/src/build.ml +++ b/src/build.ml @@ -37,6 +37,7 @@ module Repr = struct | Fail : fail -> (_, _) t | Memo : 'a memo -> (unit, 'a) t | Catch : ('a, 'b) t * (exn -> 'b) -> ('a, 'b) t + | Lazy_no_targets : ('a, 'b) t Lazy.t -> ('a, 'b) t and 'a memo = { name : string @@ -132,6 +133,8 @@ let rec all = function >>> arr (fun (x, y) -> x :: y) +let lazy_no_targets t = Lazy_no_targets t + let path p = Paths (Path.Set.singleton p) let paths ps = Paths (Path.Set.of_list ps) let path_set ps = Paths ps diff --git a/src/build.mli b/src/build.mli index aed438c6..357592e2 100644 --- a/src/build.mli +++ b/src/build.mli @@ -34,6 +34,10 @@ val fanout4 : ('a, 'b) t -> ('a, 'c) t -> ('a, 'd) t -> ('a, 'e) t -> ('a, 'b * val all : ('a, 'b) t list -> ('a, 'b list) t +(** Optimization to avoiding eagerly computing a [Build.t] value, + assume it contains no targets. *) +val lazy_no_targets : ('a, 'b) t Lazy.t -> ('a, 'b) t + (* CR-someday diml: this API is not great, what about: {[ @@ -202,6 +206,7 @@ module Repr : sig | Fail : fail -> (_, _) t | Memo : 'a memo -> (unit, 'a) t | Catch : ('a, 'b) t * (exn -> 'b) -> ('a, 'b) t + | Lazy_no_targets : ('a, 'b) t Lazy.t -> ('a, 'b) t and 'a memo = { name : string diff --git a/src/build_interpret.ml b/src/build_interpret.ml index a4e7de9f..578d2dd8 100644 --- a/src/build_interpret.ml +++ b/src/build_interpret.ml @@ -49,17 +49,23 @@ let inspect_path file_tree path = else None +let no_targets_allowed () = + Exn.code_error "No targets allowed under a [Build.lazy_no_targets] \ + or [Build.if_file_exists]" [] +[@@inline never] + let static_deps t ~all_targets ~file_tree = - let rec loop : type a b. (a, b) t -> Static_deps.t -> Static_deps.t = fun t acc -> + let rec loop : type a b. (a, b) t -> Static_deps.t -> bool -> Static_deps.t + = fun t acc targets_allowed -> match t with | Arr _ -> acc - | Targets _ -> acc - | Store_vfile _ -> acc - | Compose (a, b) -> loop a (loop b acc) - | First t -> loop t acc - | Second t -> loop t acc - | Split (a, b) -> loop a (loop b acc) - | Fanout (a, b) -> loop a (loop b acc) + | Targets _ -> if not targets_allowed then no_targets_allowed (); acc + | Store_vfile _ -> if not targets_allowed then no_targets_allowed (); acc + | Compose (a, b) -> loop a (loop b acc targets_allowed) targets_allowed + | First t -> loop t acc targets_allowed + | Second t -> loop t acc targets_allowed + | Split (a, b) -> loop a (loop b acc targets_allowed) targets_allowed + | Fanout (a, b) -> loop a (loop b acc targets_allowed) targets_allowed | Paths fns -> { acc with action_deps = Path.Set.union fns acc.action_deps } | Paths_for_rule fns -> { acc with rule_deps = Path.Set.union fns acc.rule_deps } @@ -93,28 +99,34 @@ let static_deps t ~all_targets ~file_tree = end | If_file_exists (p, state) -> begin match !state with - | Decided (_, t) -> loop t acc + | Decided (_, t) -> loop t acc false | Undecided (then_, else_) -> let dir = Path.parent_exn p in let targets = all_targets ~dir in if Path.Set.mem targets p then begin state := Decided (true, then_); - loop then_ acc + loop then_ acc false end else begin state := Decided (false, else_); - loop else_ acc + loop else_ acc false end end - | Dyn_paths t -> loop t acc - | Vpath (Vspec.T (p, _)) -> { acc with rule_deps = Path.Set.add acc.rule_deps p } + | Dyn_paths t -> loop t acc targets_allowed + | Vpath (Vspec.T (p, _)) -> + { acc with rule_deps = Path.Set.add acc.rule_deps p } | Contents p -> { acc with rule_deps = Path.Set.add acc.rule_deps p } | Lines_of p -> { acc with rule_deps = Path.Set.add acc.rule_deps p } | Record_lib_deps _ -> acc | Fail _ -> acc - | Memo m -> loop m.t acc - | Catch (t, _) -> loop t acc + | Memo m -> loop m.t acc targets_allowed + | Catch (t, _) -> loop t acc targets_allowed + | Lazy_no_targets t -> loop (Lazy.force t) acc false in - loop (Build.repr t) { rule_deps = Path.Set.empty; action_deps = Path.Set.empty } + loop (Build.repr t) + { rule_deps = Path.Set.empty + ; action_deps = Path.Set.empty + } + true let lib_deps = let rec loop : type a b. (a, b) t -> Build.lib_deps -> Build.lib_deps @@ -141,6 +153,7 @@ let lib_deps = loop (get_if_file_exists_exn state) acc | Memo m -> loop m.t acc | Catch (t, _) -> loop t acc + | Lazy_no_targets t -> loop (Lazy.force t) acc in fun t -> loop (Build.repr t) String.Map.empty @@ -183,6 +196,7 @@ let targets = end | Memo m -> loop m.t acc | Catch (t, _) -> loop t acc + | Lazy_no_targets _ -> acc in fun t -> loop (Build.repr t) [] diff --git a/src/build_system.ml b/src/build_system.ml index 281b6a7e..ea71d66d 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -164,8 +164,7 @@ module Internal_rule = struct type t = { id : Id.t - ; rule_deps : Path.Set.t - ; static_deps : Path.Set.t + ; static_deps : Build_interpret.Static_deps.t Lazy.t ; targets : Path.Set.t ; context : Context.t option ; build : (unit, Action.t) Build.t @@ -178,6 +177,12 @@ module Internal_rule = struct let compare a b = Id.compare a.id b.id let loc ~file_tree ~dir t = rule_loc ~file_tree ~dir ~loc:t.loc + + let lib_deps t = + (* Forcing this lazy ensures that the various globs and + [if_file_exists] are resolved inside the [Build.t] value. *) + ignore (Lazy.force t.static_deps : Build_interpret.Static_deps.t); + Build_interpret.lib_deps t.build end module File_kind = struct @@ -277,15 +282,17 @@ module Alias0 = struct open Build.O let dep_rec_internal ~name ~dir ~ctx_dir = - File_tree.Dir.fold dir ~traverse_ignored_dirs:false ~init:(Build.return true) - ~f:(fun dir acc -> - let path = Path.append ctx_dir (File_tree.Dir.path dir) in - let fn = stamp_file (make ~dir:path name) in - acc - >>> - Build.if_file_exists fn - ~then_:(Build.path fn >>^ fun _ -> false) - ~else_:(Build.arr (fun x -> x))) + Build.lazy_no_targets (lazy ( + File_tree.Dir.fold dir ~traverse_ignored_dirs:false + ~init:(Build.return true) + ~f:(fun dir acc -> + let path = Path.append ctx_dir (File_tree.Dir.path dir) in + let fn = stamp_file (make ~dir:path name) in + acc + >>> + Build.if_file_exists fn + ~then_:(Build.path fn >>^ fun _ -> false) + ~else_:(Build.arr (fun x -> x))))) let dep_rec t ~loc ~file_tree = let ctx_dir, src_dir = @@ -300,8 +307,9 @@ module Alias0 = struct dep_rec_internal ~name:t.name ~dir ~ctx_dir >>^ fun is_empty -> if is_empty && not (is_standard t.name) then - Loc.fail loc "This alias is empty.\n\ - Alias %S is not defined in %s or any of its descendants." + Loc.fail loc + "This alias is empty.\n\ + Alias %S is not defined in %s or any of its descendants." t.name (Path.to_string_maybe_quoted src_dir) let dep_rec_multi_contexts ~dir:src_dir ~name ~file_tree ~contexts = @@ -518,6 +526,8 @@ module Build_exec = struct with exn -> on_error exn end + | Lazy_no_targets t -> + exec dyn_deps (Lazy.force t) x | Memo m -> match m.state with | Evaluated (x, deps) -> @@ -709,20 +719,19 @@ let rec compile_rule t ?(copy_source=false) pre_rule = pre_rule in let targets = Target.paths target_specs in - let { Build_interpret.Static_deps. - rule_deps - ; action_deps = static_deps - } = Build_interpret.static_deps build ~all_targets:(targets_of t) - ~file_tree:t.file_tree + let static_deps = + lazy (Build_interpret.static_deps build ~all_targets:(targets_of t) + ~file_tree:t.file_tree) in let eval_rule () = t.hook Rule_started; - wait_for_deps t rule_deps + wait_for_deps t (Lazy.force static_deps).rule_deps >>| fun () -> Build_exec.exec t build () in let exec_rule (rule_evaluation : Exec_status.rule_evaluation) = + let static_deps = (Lazy.force static_deps).action_deps in Fiber.fork_and_join_unit (fun () -> wait_for_deps t static_deps) @@ -826,7 +835,6 @@ let rec compile_rule t ?(copy_source=false) pre_rule = { Internal_rule. id = Internal_rule.Id.gen () ; static_deps - ; rule_deps ; targets ; build ; context @@ -921,17 +929,16 @@ and load_dir_step2_exn t ~dir ~collector ~lazy_generators = else match Path.extract_build_context_dir dir with | None -> aliases - | Some (_, src_dir) -> + | Some (ctx_dir, src_dir) -> match File_tree.find_dir t.file_tree src_dir with | None -> aliases - | Some _ -> + | Some dir -> String.Map.add aliases "default" { deps = Path.Set.empty ; dyn_deps = - Alias0.dep_rec (Alias0.install ~dir) ~loc:Loc.none - ~file_tree:t.file_tree - >>> - Build.return Path.Set.empty + (Alias0.dep_rec_internal ~name:"install" ~dir ~ctx_dir + >>^ fun (_ : bool) -> + Path.Set.empty) ; actions = [] } in @@ -1297,7 +1304,8 @@ let rules_for_targets t targets = Internal_rule.Id.Top_closure.top_closure (rules_for_files t targets) ~key:(fun (r : Internal_rule.t) -> r.id) ~deps:(fun (r : Internal_rule.t) -> - rules_for_files t (Path.Set.union r.static_deps r.rule_deps)) + let x = Lazy.force r.static_deps in + rules_for_files t (Path.Set.union x.action_deps x.rule_deps)) with | Ok l -> l | Error cycle -> @@ -1319,8 +1327,8 @@ let static_deps_of_request t request = let all_lib_deps t ~request = let targets = static_deps_of_request t request in List.fold_left (rules_for_targets t targets) ~init:Path.Map.empty - ~f:(fun acc (rule : Internal_rule.t) -> - let deps = Build_interpret.lib_deps rule.build in + ~f:(fun acc rule -> + let deps = Internal_rule.lib_deps rule in if String.Map.is_empty deps then acc else @@ -1334,8 +1342,8 @@ let all_lib_deps t ~request = let all_lib_deps_by_context t ~request = let targets = static_deps_of_request t request in let rules = rules_for_targets t targets in - List.fold_left rules ~init:[] ~f:(fun acc (rule : Internal_rule.t) -> - let deps = Build_interpret.lib_deps rule.build in + List.fold_left rules ~init:[] ~f:(fun acc rule -> + let deps = Internal_rule.lib_deps rule in if String.Map.is_empty deps then acc else @@ -1404,9 +1412,10 @@ let build_rules_internal ?(recursive=false) t ~request = Fiber.fork (fun () -> Fiber.Future.wait rule_evaluation >>| fun (action, dyn_deps) -> + let static_deps = (Lazy.force ir.static_deps).action_deps in { Rule. id = ir.id - ; deps = Path.Set.union ir.static_deps dyn_deps + ; deps = Path.Set.union static_deps dyn_deps ; targets = ir.targets ; context = ir.context ; action = action @@ -1483,7 +1492,9 @@ let package_deps t pkg files = Option.value_exn (Fiber.Future.peek rule_evaluation) | Not_started _ -> assert false in - Path.Set.fold (Path.Set.union ir.static_deps dyn_deps) ~init:acc ~f:loop + Path.Set.fold + (Path.Set.union (Lazy.force ir.static_deps).action_deps dyn_deps) + ~init:acc ~f:loop end in let open Build.O in