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
|
| Fail : fail -> (_, _) t
|
||||||
| Memo : 'a memo -> (unit, 'a) t
|
| Memo : 'a memo -> (unit, 'a) t
|
||||||
| Catch : ('a, 'b) t * (exn -> 'b) -> ('a, 'b) t
|
| Catch : ('a, 'b) t * (exn -> 'b) -> ('a, 'b) t
|
||||||
|
| Lazy_no_targets : ('a, 'b) t Lazy.t -> ('a, 'b) t
|
||||||
|
|
||||||
and 'a memo =
|
and 'a memo =
|
||||||
{ name : string
|
{ name : string
|
||||||
|
@ -132,6 +133,8 @@ let rec all = function
|
||||||
>>>
|
>>>
|
||||||
arr (fun (x, y) -> x :: y)
|
arr (fun (x, y) -> x :: y)
|
||||||
|
|
||||||
|
let lazy_no_targets t = Lazy_no_targets t
|
||||||
|
|
||||||
let path p = Paths (Path.Set.singleton p)
|
let path p = Paths (Path.Set.singleton p)
|
||||||
let paths ps = Paths (Path.Set.of_list ps)
|
let paths ps = Paths (Path.Set.of_list ps)
|
||||||
let path_set ps = Paths 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
|
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:
|
(* CR-someday diml: this API is not great, what about:
|
||||||
|
|
||||||
{[
|
{[
|
||||||
|
@ -202,6 +206,7 @@ module Repr : sig
|
||||||
| Fail : fail -> (_, _) t
|
| Fail : fail -> (_, _) t
|
||||||
| Memo : 'a memo -> (unit, 'a) t
|
| Memo : 'a memo -> (unit, 'a) t
|
||||||
| Catch : ('a, 'b) t * (exn -> 'b) -> ('a, 'b) t
|
| Catch : ('a, 'b) t * (exn -> 'b) -> ('a, 'b) t
|
||||||
|
| Lazy_no_targets : ('a, 'b) t Lazy.t -> ('a, 'b) t
|
||||||
|
|
||||||
and 'a memo =
|
and 'a memo =
|
||||||
{ name : string
|
{ name : string
|
||||||
|
|
|
@ -49,17 +49,23 @@ let inspect_path file_tree path =
|
||||||
else
|
else
|
||||||
None
|
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 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
|
match t with
|
||||||
| Arr _ -> acc
|
| Arr _ -> acc
|
||||||
| Targets _ -> acc
|
| Targets _ -> if not targets_allowed then no_targets_allowed (); acc
|
||||||
| Store_vfile _ -> acc
|
| Store_vfile _ -> if not targets_allowed then no_targets_allowed (); acc
|
||||||
| Compose (a, b) -> loop a (loop b acc)
|
| Compose (a, b) -> loop a (loop b acc targets_allowed) targets_allowed
|
||||||
| First t -> loop t acc
|
| First t -> loop t acc targets_allowed
|
||||||
| Second t -> loop t acc
|
| Second t -> loop t acc targets_allowed
|
||||||
| Split (a, b) -> loop a (loop b acc)
|
| Split (a, b) -> loop a (loop b acc targets_allowed) targets_allowed
|
||||||
| Fanout (a, b) -> loop a (loop b acc)
|
| 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 fns -> { acc with action_deps = Path.Set.union fns acc.action_deps }
|
||||||
| Paths_for_rule fns ->
|
| Paths_for_rule fns ->
|
||||||
{ acc with rule_deps = Path.Set.union fns acc.rule_deps }
|
{ acc with rule_deps = Path.Set.union fns acc.rule_deps }
|
||||||
|
@ -93,28 +99,34 @@ let static_deps t ~all_targets ~file_tree =
|
||||||
end
|
end
|
||||||
| If_file_exists (p, state) -> begin
|
| If_file_exists (p, state) -> begin
|
||||||
match !state with
|
match !state with
|
||||||
| Decided (_, t) -> loop t acc
|
| Decided (_, t) -> loop t acc false
|
||||||
| Undecided (then_, else_) ->
|
| Undecided (then_, else_) ->
|
||||||
let dir = Path.parent_exn p in
|
let dir = Path.parent_exn p in
|
||||||
let targets = all_targets ~dir in
|
let targets = all_targets ~dir in
|
||||||
if Path.Set.mem targets p then begin
|
if Path.Set.mem targets p then begin
|
||||||
state := Decided (true, then_);
|
state := Decided (true, then_);
|
||||||
loop then_ acc
|
loop then_ acc false
|
||||||
end else begin
|
end else begin
|
||||||
state := Decided (false, else_);
|
state := Decided (false, else_);
|
||||||
loop else_ acc
|
loop else_ acc false
|
||||||
end
|
end
|
||||||
end
|
end
|
||||||
| Dyn_paths t -> loop t acc
|
| Dyn_paths t -> loop t acc targets_allowed
|
||||||
| Vpath (Vspec.T (p, _)) -> { acc with rule_deps = Path.Set.add acc.rule_deps p }
|
| 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 }
|
| 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 }
|
| Lines_of p -> { acc with rule_deps = Path.Set.add acc.rule_deps p }
|
||||||
| Record_lib_deps _ -> acc
|
| Record_lib_deps _ -> acc
|
||||||
| Fail _ -> acc
|
| Fail _ -> acc
|
||||||
| Memo m -> loop m.t acc
|
| Memo m -> loop m.t acc targets_allowed
|
||||||
| Catch (t, _) -> loop t acc
|
| Catch (t, _) -> loop t acc targets_allowed
|
||||||
|
| Lazy_no_targets t -> loop (Lazy.force t) acc false
|
||||||
in
|
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 lib_deps =
|
||||||
let rec loop : type a b. (a, b) t -> Build.lib_deps -> Build.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
|
loop (get_if_file_exists_exn state) acc
|
||||||
| Memo m -> loop m.t acc
|
| Memo m -> loop m.t acc
|
||||||
| Catch (t, _) -> loop t acc
|
| Catch (t, _) -> loop t acc
|
||||||
|
| Lazy_no_targets t -> loop (Lazy.force t) acc
|
||||||
in
|
in
|
||||||
fun t -> loop (Build.repr t) String.Map.empty
|
fun t -> loop (Build.repr t) String.Map.empty
|
||||||
|
|
||||||
|
@ -183,6 +196,7 @@ let targets =
|
||||||
end
|
end
|
||||||
| Memo m -> loop m.t acc
|
| Memo m -> loop m.t acc
|
||||||
| Catch (t, _) -> loop t acc
|
| Catch (t, _) -> loop t acc
|
||||||
|
| Lazy_no_targets _ -> acc
|
||||||
in
|
in
|
||||||
fun t -> loop (Build.repr t) []
|
fun t -> loop (Build.repr t) []
|
||||||
|
|
||||||
|
|
|
@ -164,8 +164,7 @@ module Internal_rule = struct
|
||||||
|
|
||||||
type t =
|
type t =
|
||||||
{ id : Id.t
|
{ id : Id.t
|
||||||
; rule_deps : Path.Set.t
|
; static_deps : Build_interpret.Static_deps.t Lazy.t
|
||||||
; static_deps : Path.Set.t
|
|
||||||
; targets : Path.Set.t
|
; targets : Path.Set.t
|
||||||
; context : Context.t option
|
; context : Context.t option
|
||||||
; build : (unit, Action.t) Build.t
|
; 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 compare a b = Id.compare a.id b.id
|
||||||
|
|
||||||
let loc ~file_tree ~dir t = rule_loc ~file_tree ~dir ~loc:t.loc
|
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
|
end
|
||||||
|
|
||||||
module File_kind = struct
|
module File_kind = struct
|
||||||
|
@ -277,15 +282,17 @@ module Alias0 = struct
|
||||||
open Build.O
|
open Build.O
|
||||||
|
|
||||||
let dep_rec_internal ~name ~dir ~ctx_dir =
|
let dep_rec_internal ~name ~dir ~ctx_dir =
|
||||||
File_tree.Dir.fold dir ~traverse_ignored_dirs:false ~init:(Build.return true)
|
Build.lazy_no_targets (lazy (
|
||||||
~f:(fun dir acc ->
|
File_tree.Dir.fold dir ~traverse_ignored_dirs:false
|
||||||
let path = Path.append ctx_dir (File_tree.Dir.path dir) in
|
~init:(Build.return true)
|
||||||
let fn = stamp_file (make ~dir:path name) in
|
~f:(fun dir acc ->
|
||||||
acc
|
let path = Path.append ctx_dir (File_tree.Dir.path dir) in
|
||||||
>>>
|
let fn = stamp_file (make ~dir:path name) in
|
||||||
Build.if_file_exists fn
|
acc
|
||||||
~then_:(Build.path fn >>^ fun _ -> false)
|
>>>
|
||||||
~else_:(Build.arr (fun x -> x)))
|
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 dep_rec t ~loc ~file_tree =
|
||||||
let ctx_dir, src_dir =
|
let ctx_dir, src_dir =
|
||||||
|
@ -300,8 +307,9 @@ module Alias0 = struct
|
||||||
dep_rec_internal ~name:t.name ~dir ~ctx_dir
|
dep_rec_internal ~name:t.name ~dir ~ctx_dir
|
||||||
>>^ fun is_empty ->
|
>>^ fun is_empty ->
|
||||||
if is_empty && not (is_standard t.name) then
|
if is_empty && not (is_standard t.name) then
|
||||||
Loc.fail loc "This alias is empty.\n\
|
Loc.fail loc
|
||||||
Alias %S is not defined in %s or any of its descendants."
|
"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)
|
t.name (Path.to_string_maybe_quoted src_dir)
|
||||||
|
|
||||||
let dep_rec_multi_contexts ~dir:src_dir ~name ~file_tree ~contexts =
|
let dep_rec_multi_contexts ~dir:src_dir ~name ~file_tree ~contexts =
|
||||||
|
@ -518,6 +526,8 @@ module Build_exec = struct
|
||||||
with exn ->
|
with exn ->
|
||||||
on_error exn
|
on_error exn
|
||||||
end
|
end
|
||||||
|
| Lazy_no_targets t ->
|
||||||
|
exec dyn_deps (Lazy.force t) x
|
||||||
| Memo m ->
|
| Memo m ->
|
||||||
match m.state with
|
match m.state with
|
||||||
| Evaluated (x, deps) ->
|
| Evaluated (x, deps) ->
|
||||||
|
@ -709,20 +719,19 @@ let rec compile_rule t ?(copy_source=false) pre_rule =
|
||||||
pre_rule
|
pre_rule
|
||||||
in
|
in
|
||||||
let targets = Target.paths target_specs in
|
let targets = Target.paths target_specs in
|
||||||
let { Build_interpret.Static_deps.
|
let static_deps =
|
||||||
rule_deps
|
lazy (Build_interpret.static_deps build ~all_targets:(targets_of t)
|
||||||
; action_deps = static_deps
|
~file_tree:t.file_tree)
|
||||||
} = Build_interpret.static_deps build ~all_targets:(targets_of t)
|
|
||||||
~file_tree:t.file_tree
|
|
||||||
in
|
in
|
||||||
|
|
||||||
let eval_rule () =
|
let eval_rule () =
|
||||||
t.hook Rule_started;
|
t.hook Rule_started;
|
||||||
wait_for_deps t rule_deps
|
wait_for_deps t (Lazy.force static_deps).rule_deps
|
||||||
>>| fun () ->
|
>>| fun () ->
|
||||||
Build_exec.exec t build ()
|
Build_exec.exec t build ()
|
||||||
in
|
in
|
||||||
let exec_rule (rule_evaluation : Exec_status.rule_evaluation) =
|
let exec_rule (rule_evaluation : Exec_status.rule_evaluation) =
|
||||||
|
let static_deps = (Lazy.force static_deps).action_deps in
|
||||||
Fiber.fork_and_join_unit
|
Fiber.fork_and_join_unit
|
||||||
(fun () ->
|
(fun () ->
|
||||||
wait_for_deps t static_deps)
|
wait_for_deps t static_deps)
|
||||||
|
@ -826,7 +835,6 @@ let rec compile_rule t ?(copy_source=false) pre_rule =
|
||||||
{ Internal_rule.
|
{ Internal_rule.
|
||||||
id = Internal_rule.Id.gen ()
|
id = Internal_rule.Id.gen ()
|
||||||
; static_deps
|
; static_deps
|
||||||
; rule_deps
|
|
||||||
; targets
|
; targets
|
||||||
; build
|
; build
|
||||||
; context
|
; context
|
||||||
|
@ -921,17 +929,16 @@ and load_dir_step2_exn t ~dir ~collector ~lazy_generators =
|
||||||
else
|
else
|
||||||
match Path.extract_build_context_dir dir with
|
match Path.extract_build_context_dir dir with
|
||||||
| None -> aliases
|
| None -> aliases
|
||||||
| Some (_, src_dir) ->
|
| Some (ctx_dir, src_dir) ->
|
||||||
match File_tree.find_dir t.file_tree src_dir with
|
match File_tree.find_dir t.file_tree src_dir with
|
||||||
| None -> aliases
|
| None -> aliases
|
||||||
| Some _ ->
|
| Some dir ->
|
||||||
String.Map.add aliases "default"
|
String.Map.add aliases "default"
|
||||||
{ deps = Path.Set.empty
|
{ deps = Path.Set.empty
|
||||||
; dyn_deps =
|
; dyn_deps =
|
||||||
Alias0.dep_rec (Alias0.install ~dir) ~loc:Loc.none
|
(Alias0.dep_rec_internal ~name:"install" ~dir ~ctx_dir
|
||||||
~file_tree:t.file_tree
|
>>^ fun (_ : bool) ->
|
||||||
>>>
|
Path.Set.empty)
|
||||||
Build.return Path.Set.empty
|
|
||||||
; actions = []
|
; actions = []
|
||||||
}
|
}
|
||||||
in
|
in
|
||||||
|
@ -1297,7 +1304,8 @@ let rules_for_targets t targets =
|
||||||
Internal_rule.Id.Top_closure.top_closure (rules_for_files t targets)
|
Internal_rule.Id.Top_closure.top_closure (rules_for_files t targets)
|
||||||
~key:(fun (r : Internal_rule.t) -> r.id)
|
~key:(fun (r : Internal_rule.t) -> r.id)
|
||||||
~deps:(fun (r : Internal_rule.t) ->
|
~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
|
with
|
||||||
| Ok l -> l
|
| Ok l -> l
|
||||||
| Error cycle ->
|
| Error cycle ->
|
||||||
|
@ -1319,8 +1327,8 @@ let static_deps_of_request t request =
|
||||||
let all_lib_deps t ~request =
|
let all_lib_deps t ~request =
|
||||||
let targets = static_deps_of_request t request in
|
let targets = static_deps_of_request t request in
|
||||||
List.fold_left (rules_for_targets t targets) ~init:Path.Map.empty
|
List.fold_left (rules_for_targets t targets) ~init:Path.Map.empty
|
||||||
~f:(fun acc (rule : Internal_rule.t) ->
|
~f:(fun acc rule ->
|
||||||
let deps = Build_interpret.lib_deps rule.build in
|
let deps = Internal_rule.lib_deps rule in
|
||||||
if String.Map.is_empty deps then
|
if String.Map.is_empty deps then
|
||||||
acc
|
acc
|
||||||
else
|
else
|
||||||
|
@ -1334,8 +1342,8 @@ let all_lib_deps t ~request =
|
||||||
let all_lib_deps_by_context t ~request =
|
let all_lib_deps_by_context t ~request =
|
||||||
let targets = static_deps_of_request t request in
|
let targets = static_deps_of_request t request in
|
||||||
let rules = rules_for_targets t targets in
|
let rules = rules_for_targets t targets in
|
||||||
List.fold_left rules ~init:[] ~f:(fun acc (rule : Internal_rule.t) ->
|
List.fold_left rules ~init:[] ~f:(fun acc rule ->
|
||||||
let deps = Build_interpret.lib_deps rule.build in
|
let deps = Internal_rule.lib_deps rule in
|
||||||
if String.Map.is_empty deps then
|
if String.Map.is_empty deps then
|
||||||
acc
|
acc
|
||||||
else
|
else
|
||||||
|
@ -1404,9 +1412,10 @@ let build_rules_internal ?(recursive=false) t ~request =
|
||||||
Fiber.fork (fun () ->
|
Fiber.fork (fun () ->
|
||||||
Fiber.Future.wait rule_evaluation
|
Fiber.Future.wait rule_evaluation
|
||||||
>>| fun (action, dyn_deps) ->
|
>>| fun (action, dyn_deps) ->
|
||||||
|
let static_deps = (Lazy.force ir.static_deps).action_deps in
|
||||||
{ Rule.
|
{ Rule.
|
||||||
id = ir.id
|
id = ir.id
|
||||||
; deps = Path.Set.union ir.static_deps dyn_deps
|
; deps = Path.Set.union static_deps dyn_deps
|
||||||
; targets = ir.targets
|
; targets = ir.targets
|
||||||
; context = ir.context
|
; context = ir.context
|
||||||
; action = action
|
; action = action
|
||||||
|
@ -1483,7 +1492,9 @@ let package_deps t pkg files =
|
||||||
Option.value_exn (Fiber.Future.peek rule_evaluation)
|
Option.value_exn (Fiber.Future.peek rule_evaluation)
|
||||||
| Not_started _ -> assert false
|
| Not_started _ -> assert false
|
||||||
in
|
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
|
end
|
||||||
in
|
in
|
||||||
let open Build.O in
|
let open Build.O in
|
||||||
|
|
Loading…
Reference in New Issue