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 <jeremie@dimino.org>
This commit is contained in:
parent
81bcd0f3e1
commit
fc9f3357ab
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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) []
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue