matthieu
/
dune
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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:
Jeremie Dimino 2018-06-28 17:55:52 +01:00 committed by Jérémie Dimino
parent 81bcd0f3e1
commit fc9f3357ab
4 changed files with 82 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/build.ml
View File

@ -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

5
src/build.mli
View File

@ -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

46
src/build_interpret.ml
View File

@ -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) []

77
src/build_system.ml
View File

@ -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