From 21a3dca870d3114a0ed2334782aeea4d5d5cd55d Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Wed, 17 Apr 2019 14:33:04 +0100 Subject: [PATCH] Refactor Build's related stuff Move all operations on Build.Repr.t directly into Build and stop exposing the internal representation. Signed-off-by: Jeremie Dimino --- src/build.ml | 299 ++++++++++++++++++++++++++++++++-------- src/build.mli | 66 +++------ src/build_interpret.ml | 176 ----------------------- src/build_interpret.mli | 42 ------ src/build_system.ml | 101 ++------------ src/build_system.mli | 2 +- src/rule.ml | 54 ++++++++ src/rule.mli | 27 ++++ src/super_context.ml | 19 ++- 9 files changed, 362 insertions(+), 424 deletions(-) delete mode 100644 src/build_interpret.ml delete mode 100644 src/build_interpret.mli create mode 100644 src/rule.ml create mode 100644 src/rule.mli diff --git a/src/build.ml b/src/build.ml index ccf533d13b4..464693b7012 100644 --- a/src/build.ml +++ b/src/build.ml @@ -1,65 +1,49 @@ open! Stdune open Import -module Repr = struct - type ('a, 'b) t = - | Arr : ('a -> 'b) -> ('a, 'b) t - | Targets : Path.Set.t -> ('a, 'a) t - | Compose : ('a, 'b) t * ('b, 'c) t -> ('a, 'c) t - | First : ('a, 'b) t -> ('a * 'c, 'b * 'c) t - | Second : ('a, 'b) t -> ('c * 'a, 'c * 'b) t - | Split : ('a, 'b) t * ('c, 'd) t -> ('a * 'c, 'b * 'd) t - | Fanout : ('a, 'b) t * ('a, 'c) t -> ('a, 'b * 'c) t - | Paths_for_rule : Path.Set.t -> ('a, 'a) t - | Paths_glob : File_selector.t -> ('a, Path.Set.t) t - (* The reference gets decided in Build_interpret.deps *) - | If_file_exists : Path.t * ('a, 'b) if_file_exists_state ref -> ('a, 'b) t - | Contents : Path.t -> ('a, string) t - | Lines_of : Path.t -> ('a, string list) t - | Dyn_paths : ('a, Path.Set.t) t -> ('a, 'a) t - | Dyn_deps : ('a, Dep.Set.t) t -> ('a, 'a) t - | Record_lib_deps : Lib_deps_info.t -> ('a, 'a) t - | 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 - | Deps : Dep.Set.t -> ('a, 'a) t - - and 'a memo = - { name : string - ; t : (unit, 'a) t - ; mutable state : 'a memo_state - } - - and 'a memo_state = - | Unevaluated - | Evaluating - | Evaluated of 'a * Dep.Set.t - - and ('a, 'b) if_file_exists_state = - | Undecided of ('a, 'b) t * ('a, 'b) t - | Decided of bool * ('a, 'b) t - - and glob_state = - | G_unevaluated of Loc.t * Path.t * Path.t Predicate.t - | G_evaluated of Path.Set.t - - let get_if_file_exists_exn state = - match !state with - | Decided (_, t) -> t - | Undecided _ -> - Exn.code_error "Build.get_if_file_exists_exn: got undecided" [] - - let get_glob_result_exn state = - match !state with - | G_evaluated l -> l - | G_unevaluated (loc, path, _) -> - Exn.code_error "Build.get_glob_result_exn: got unevaluated" - [ "loc", Loc.to_sexp loc - ; "path", Path.to_sexp path ] -end -include Repr -let repr t = t +type ('a, 'b) t = + | Arr : ('a -> 'b) -> ('a, 'b) t + | Targets : Path.Set.t -> ('a, 'a) t + | Compose : ('a, 'b) t * ('b, 'c) t -> ('a, 'c) t + | First : ('a, 'b) t -> ('a * 'c, 'b * 'c) t + | Second : ('a, 'b) t -> ('c * 'a, 'c * 'b) t + | Split : ('a, 'b) t * ('c, 'd) t -> ('a * 'c, 'b * 'd) t + | Fanout : ('a, 'b) t * ('a, 'c) t -> ('a, 'b * 'c) t + | Paths_for_rule : Path.Set.t -> ('a, 'a) t + | Paths_glob : File_selector.t -> ('a, Path.Set.t) t + (* The reference gets decided in Build_interpret.deps *) + | If_file_exists : Path.t * ('a, 'b) if_file_exists_state ref -> ('a, 'b) t + | Contents : Path.t -> ('a, string) t + | Lines_of : Path.t -> ('a, string list) t + | Dyn_paths : ('a, Path.Set.t) t -> ('a, 'a) t + | Dyn_deps : ('a, Dep.Set.t) t -> ('a, 'a) t + | Record_lib_deps : Lib_deps_info.t -> ('a, 'a) t + | 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 + | Deps : Dep.Set.t -> ('a, 'a) t + +and 'a memo = + { name : string + ; t : (unit, 'a) t + ; mutable state : 'a memo_state + } + +and 'a memo_state = + | Unevaluated + | Evaluating + | Evaluated of 'a * Dep.Set.t + +and ('a, 'b) if_file_exists_state = + | Undecided of ('a, 'b) t * ('a, 'b) t + | Decided of bool * ('a, 'b) t + +let get_if_file_exists_exn state = + match !state with + | Decided (_, t) -> t + | Undecided _ -> + Exn.code_error "Build.get_if_file_exists_exn: got undecided" [] let arr f = Arr f let return x = Arr (fun _ -> x) @@ -268,3 +252,200 @@ let merge_files_dyn ~target = >>^ (fun (sources, extras) -> Action.Merge_files_into (sources, extras, target)) >>> action_dyn ~targets:[target] () + +(* Analysis *) + +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 = + 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 _ -> 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 + | Deps deps -> + Static_deps.add_action_deps acc deps + | Paths_for_rule fns -> + Static_deps.add_rule_paths acc fns + | Paths_glob g -> + Static_deps.add_action_dep acc (Dep.glob g) + | If_file_exists (p, state) -> begin + match !state with + | 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 false + end else begin + state := Decided (false, else_); + loop else_ acc false + end + end + | Dyn_paths t -> loop t acc targets_allowed + | Dyn_deps t -> loop t acc targets_allowed + | Contents p -> Static_deps.add_rule_path acc p + | Lines_of p -> Static_deps.add_rule_path acc p + | Record_lib_deps _ -> acc + | Fail _ -> 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 t Static_deps.empty true + +let lib_deps = + let rec loop : type a b. (a, b) t -> Lib_deps_info.t -> Lib_deps_info.t + = fun t acc -> + match t with + | Arr _ -> acc + | Targets _ -> 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) + | Paths_for_rule _ -> acc + | Paths_glob _ -> acc + | Deps _ -> acc + | Dyn_paths t -> loop t acc + | Dyn_deps t -> loop t acc + | Contents _ -> acc + | Lines_of _ -> acc + | Record_lib_deps deps -> Lib_deps_info.merge deps acc + | Fail _ -> acc + | If_file_exists (_, state) -> + 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 t Lib_name.Map.empty + +let targets = + let rec loop : type a b. (a, b) t -> Path.Set.t -> Path.Set.t = fun t acc -> + match t with + | Arr _ -> acc + | Targets targets -> Path.Set.union targets 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) + | Paths_for_rule _ -> acc + | Paths_glob _ -> acc + | Deps _ -> acc + | Dyn_paths t -> loop t acc + | Dyn_deps t -> loop t acc + | Contents _ -> acc + | Lines_of _ -> acc + | Record_lib_deps _ -> acc + | Fail _ -> acc + | If_file_exists (_, state) -> begin + match !state with + | Decided (v, _) -> + Exn.code_error "Build_interpret.targets got decided if_file_exists" + ["exists", Sexp.Encoder.bool v] + | Undecided (a, b) -> + let a = loop a Path.Set.empty in + let b = loop b Path.Set.empty in + if Path.Set.is_empty a && Path.Set.is_empty b then + acc + else begin + Exn.code_error "Build_interpret.targets: cannot have targets \ + under a [if_file_exists]" + [ "targets-a", Path.Set.to_sexp a + ; "targets-b", Path.Set.to_sexp b + ] + end + end + | Memo m -> loop m.t acc + | Catch (t, _) -> loop t acc + | Lazy_no_targets _ -> acc + in + fun t -> loop t Path.Set.empty + +(* Execution *) + +let exec ~(eval_pred : Dep.eval_pred) (t : ('a, 'b) t) (x : 'a) + : 'b * Dep.Set.t = + let rec exec + : type a b. Dep.Set.t ref -> (a, b) t -> a -> b = fun dyn_deps t x -> + match t with + | Arr f -> f x + | Targets _ -> x + | Compose (a, b) -> + exec dyn_deps a x |> exec dyn_deps b + | First t -> + let x, y = x in + (exec dyn_deps t x, y) + | Second t -> + let x, y = x in + (x, exec dyn_deps t y) + | Split (a, b) -> + let x, y = x in + let x = exec dyn_deps a x in + let y = exec dyn_deps b y in + (x, y) + | Fanout (a, b) -> + let a = exec dyn_deps a x in + let b = exec dyn_deps b x in + (a, b) + | Deps _ -> x + | Paths_for_rule _ -> x + | Paths_glob g -> eval_pred g + | Contents p -> Io.read_file p + | Lines_of p -> Io.lines_of_file p + | Dyn_paths t -> + let fns = exec dyn_deps t x in + dyn_deps := Dep.Set.add_paths !dyn_deps fns; + x + | Dyn_deps t -> + let fns = exec dyn_deps t x in + dyn_deps := Dep.Set.union !dyn_deps fns; + x + | Record_lib_deps _ -> x + | Fail { fail } -> fail () + | If_file_exists (_, state) -> + exec dyn_deps (get_if_file_exists_exn state) x + | Catch (t, on_error) -> begin + try + exec dyn_deps t x + with exn -> + on_error exn + end + | Lazy_no_targets t -> + exec dyn_deps (Lazy.force t) x + | Memo m -> + begin match m.state with + | Evaluated (x, deps) -> + dyn_deps := Dep.Set.union !dyn_deps deps; + x + | Evaluating -> + die "Dependency cycle evaluating memoized build arrow %s" m.name + | Unevaluated -> + m.state <- Evaluating; + let dyn_deps' = ref Dep.Set.empty in + match exec dyn_deps' m.t x with + | x -> + m.state <- Evaluated (x, !dyn_deps'); + dyn_deps := Dep.Set.union !dyn_deps !dyn_deps'; + x + | exception exn -> + m.state <- Unevaluated; + reraise exn + end + in + let dyn_deps = ref Dep.Set.empty in + let result = exec dyn_deps t x in + (result, !dyn_deps) + diff --git a/src/build.mli b/src/build.mli index 29f746780cb..9427ed0da3c 100644 --- a/src/build.mli +++ b/src/build.mli @@ -175,56 +175,28 @@ val progn : ('a, Action.t) t list -> ('a, Action.t) t val record_lib_deps : Lib_deps_info.t -> ('a, 'a) t -(**/**) +(** {1 Analysis} *) +(** Must be called first before [lib_deps] and [targets] as it updates + some of the internal references in the build arrow. *) +val static_deps + : (_, _) t + -> all_targets:(dir:Path.t -> Path.Set.t) + -> Static_deps.t -module Repr : sig - type ('a, 'b) t = - | Arr : ('a -> 'b) -> ('a, 'b) t - | Targets : Path.Set.t -> ('a, 'a) t - | Compose : ('a, 'b) t * ('b, 'c) t -> ('a, 'c) t - | First : ('a, 'b) t -> ('a * 'c, 'b * 'c) t - | Second : ('a, 'b) t -> ('c * 'a, 'c * 'b) t - | Split : ('a, 'b) t * ('c, 'd) t -> ('a * 'c, 'b * 'd) t - | Fanout : ('a, 'b) t * ('a, 'c) t -> ('a, 'b * 'c) t - | Paths_for_rule : Path.Set.t -> ('a, 'a) t - | Paths_glob : File_selector.t -> ('a, Path.Set.t) t - | If_file_exists : Path.t * ('a, 'b) if_file_exists_state ref -> ('a, 'b) t - | Contents : Path.t -> ('a, string) t - | Lines_of : Path.t -> ('a, string list) t - | Dyn_paths : ('a, Path.Set.t) t -> ('a, 'a) t - | Dyn_deps : ('a, Dep.Set.t) t -> ('a, 'a) t - | Record_lib_deps : Lib_deps_info.t -> ('a, 'a) t - | 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 - | Deps : Dep.Set.t -> ('a, 'a) t - - and 'a memo = - { name : string - ; t : (unit, 'a) t - ; mutable state : 'a memo_state - } - - and 'a memo_state = - | Unevaluated - | Evaluating - | Evaluated of 'a * Dep.Set.t (* dynamic dependencies *) - - and ('a, 'b) if_file_exists_state = - | Undecided of ('a, 'b) t * ('a, 'b) t - | Decided of bool * ('a, 'b) t - - and glob_state = - | G_unevaluated of Loc.t * Path.t * Path.t Predicate.t - | G_evaluated of Path.Set.t - - val get_if_file_exists_exn : ('a, 'b) if_file_exists_state ref -> ('a, 'b) t - val get_glob_result_exn : glob_state ref -> Path.Set.t -end +val lib_deps + : (_, _) t + -> Lib_deps_info.t + +val targets + : (_, _) t + -> Path.Set.t + +(** {1 Execution} *) -val repr : ('a, 'b) t -> ('a, 'b) Repr.t +(** Executes a build arrow. Returns the result and the set of dynamic + dependencies discovered during execution. *) +val exec : eval_pred:Dep.eval_pred -> ('a, 'b) t -> 'a -> 'b * Dep.Set.t (**/**) val paths_for_rule : Path.Set.t -> ('a, 'a) t diff --git a/src/build_interpret.ml b/src/build_interpret.ml deleted file mode 100644 index d3a41cd6bcc..00000000000 --- a/src/build_interpret.ml +++ /dev/null @@ -1,176 +0,0 @@ -open! Stdune -open Import -open Build.Repr - -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 = - 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 _ -> 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 - | Deps deps -> - Static_deps.add_action_deps acc deps - | Paths_for_rule fns -> - Static_deps.add_rule_paths acc fns - | Paths_glob g -> - Static_deps.add_action_dep acc (Dep.glob g) - | If_file_exists (p, state) -> begin - match !state with - | 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 false - end else begin - state := Decided (false, else_); - loop else_ acc false - end - end - | Dyn_paths t -> loop t acc targets_allowed - | Dyn_deps t -> loop t acc targets_allowed - | Contents p -> Static_deps.add_rule_path acc p - | Lines_of p -> Static_deps.add_rule_path acc p - | Record_lib_deps _ -> acc - | Fail _ -> 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) Static_deps.empty true - -let lib_deps = - let rec loop : type a b. (a, b) t -> Lib_deps_info.t -> Lib_deps_info.t - = fun t acc -> - match t with - | Arr _ -> acc - | Targets _ -> 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) - | Paths_for_rule _ -> acc - | Paths_glob _ -> acc - | Deps _ -> acc - | Dyn_paths t -> loop t acc - | Dyn_deps t -> loop t acc - | Contents _ -> acc - | Lines_of _ -> acc - | Record_lib_deps deps -> Lib_deps_info.merge deps acc - | Fail _ -> acc - | If_file_exists (_, state) -> - 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) Lib_name.Map.empty - -let targets = - let rec loop : type a b. (a, b) t -> Path.Set.t -> Path.Set.t = fun t acc -> - match t with - | Arr _ -> acc - | Targets targets -> Path.Set.union targets 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) - | Paths_for_rule _ -> acc - | Paths_glob _ -> acc - | Deps _ -> acc - | Dyn_paths t -> loop t acc - | Dyn_deps t -> loop t acc - | Contents _ -> acc - | Lines_of _ -> acc - | Record_lib_deps _ -> acc - | Fail _ -> acc - | If_file_exists (_, state) -> begin - match !state with - | Decided (v, _) -> - Exn.code_error "Build_interpret.targets got decided if_file_exists" - ["exists", Sexp.Encoder.bool v] - | Undecided (a, b) -> - let a = loop a Path.Set.empty in - let b = loop b Path.Set.empty in - if Path.Set.is_empty a && Path.Set.is_empty b then - acc - else begin - Exn.code_error "Build_interpret.targets: cannot have targets \ - under a [if_file_exists]" - [ "targets-a", Path.Set.to_sexp a - ; "targets-b", Path.Set.to_sexp b - ] - end - end - | Memo m -> loop m.t acc - | Catch (t, _) -> loop t acc - | Lazy_no_targets _ -> acc - in - fun t -> loop (Build.repr t) Path.Set.empty - -module Rule = struct - type t = - { context : Context.t option - ; env : Env.t option - ; build : (unit, Action.t) Build.t - ; targets : Path.Set.t - ; sandbox : bool - ; mode : Dune_file.Rule.Mode.t - ; locks : Path.t list - ; loc : Loc.t option - ; dir : Path.t - } - - let make ?(sandbox=false) ?(mode=Dune_file.Rule.Mode.Not_a_rule_stanza) - ~context ~env ?(locks=[]) ?loc build = - let targets = targets build in - let dir = - match Path.Set.choose targets with - | None -> begin - match loc with - | Some loc -> Errors.fail loc "Rule has no targets specified" - | None -> Exn.code_error "Build_interpret.Rule.make: no targets" [] - end - | Some x -> - let dir = Path.parent_exn x in - if Path.Set.exists targets ~f:(fun path -> Path.parent_exn path <> dir) - then begin - match loc with - | None -> - Exn.code_error "rule has targets in different directories" - [ "targets", Path.Set.to_sexp targets - ] - | Some loc -> - Errors.fail loc - "Rule has targets in different directories.\nTargets:\n%s" - (String.concat ~sep:"\n" - (Path.Set.to_list targets |> List.map ~f:(fun p -> - sprintf "- %s" - (Path.to_string_maybe_quoted p)))) - end; - dir - in - { context - ; env - ; build - ; targets - ; sandbox - ; mode - ; locks - ; loc - ; dir - } -end diff --git a/src/build_interpret.mli b/src/build_interpret.mli deleted file mode 100644 index 677b6f7e0f6..00000000000 --- a/src/build_interpret.mli +++ /dev/null @@ -1,42 +0,0 @@ -open! Stdune -open! Import - -module Rule : sig - type t = - { context : Context.t option - ; env : Env.t option - ; build : (unit, Action.t) Build.t - ; targets : Path.Set.t - ; sandbox : bool - ; mode : Dune_file.Rule.Mode.t - ; locks : Path.t list - ; loc : Loc.t option - ; (** Directory where all the targets are produced *) - dir : Path.t - } - - val make - : ?sandbox:bool - -> ?mode:Dune_file.Rule.Mode.t - -> context:Context.t option - -> env:Env.t option - -> ?locks:Path.t list - -> ?loc:Loc.t - -> (unit, Action.t) Build.t - -> t -end - -(** Must be called first before [lib_deps] and [targets] as it updates - some of the internal references in the build arrow. *) -val static_deps - : (_, _) Build.t - -> all_targets:(dir:Path.t -> Path.Set.t) - -> Static_deps.t - -val lib_deps - : (_, _) Build.t - -> Lib_deps_info.t - -val targets - : (_, _) Build.t - -> Path.Set.t diff --git a/src/build_system.ml b/src/build_system.ml index 2d8f8637d86..10f26ad1ef8 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -2,6 +2,8 @@ open! Stdune open Import open Fiber.O +module Pre_rule = Rule + (* Where we store stamp files for aliases *) let alias_dir = Path.(relative build_dir) ".aliases" @@ -141,7 +143,7 @@ module Internal_rule = struct (* Forcing this lazy ensures that the various globs and [if_file_exists] are resolved inside the [Build.t] value. *) let+ _ = Fiber.Once.get t.static_deps in - Build_interpret.lib_deps t.build + Build.lib_deps t.build (* Represent the build goal given by the user. This rule is never actually executed and is only used starting point of all @@ -363,18 +365,18 @@ module Dir_status = struct (unit, [`Already_loading]) Result.t val freeze : t -> frozen - val rules : frozen -> Build_interpret.Rule.t list + val rules : frozen -> Pre_rule.t list val aliases : frozen -> Alias.immutable String.Map.t val forbid_freeze_until_thunk_is_forced : t -> Thunk_with_backtrace.t -> unit - val add_rule : t -> Build_interpret.Rule.t -> unit + val add_rule : t -> Pre_rule.t -> unit val modify_alias : t -> string -> f:(Alias.t -> unit) -> unit end = struct type t = - { mutable rules : Build_interpret.Rule.t list + { mutable rules : Pre_rule.t list ; mutable aliases : Alias.t String.Map.t ; mutable stage : collection_stage ; mutable thunks : Thunk_with_backtrace.t list @@ -614,85 +616,6 @@ let get_dir_status t ~dir = (Dir_status.Rules_collector.create_pending ~info:(Path.to_sexp dir) ()) end) -module Pre_rule = Build_interpret.Rule - -module Build_exec = struct - open Build.Repr - - let exec ~(eval_pred : Dep.eval_pred) (t : ('a, 'b) Build.t) (x : 'a) - : 'b * Dep.Set.t = - let rec exec - : type a b. Dep.Set.t ref -> (a, b) t -> a -> b = fun dyn_deps t x -> - match t with - | Arr f -> f x - | Targets _ -> x - | Compose (a, b) -> - exec dyn_deps a x |> exec dyn_deps b - | First t -> - let x, y = x in - (exec dyn_deps t x, y) - | Second t -> - let x, y = x in - (x, exec dyn_deps t y) - | Split (a, b) -> - let x, y = x in - let x = exec dyn_deps a x in - let y = exec dyn_deps b y in - (x, y) - | Fanout (a, b) -> - let a = exec dyn_deps a x in - let b = exec dyn_deps b x in - (a, b) - | Deps _ -> x - | Paths_for_rule _ -> x - | Paths_glob g -> eval_pred g - | Contents p -> Io.read_file p - | Lines_of p -> Io.lines_of_file p - | Dyn_paths t -> - let fns = exec dyn_deps t x in - dyn_deps := Dep.Set.add_paths !dyn_deps fns; - x - | Dyn_deps t -> - let fns = exec dyn_deps t x in - dyn_deps := Dep.Set.union !dyn_deps fns; - x - | Record_lib_deps _ -> x - | Fail { fail } -> fail () - | If_file_exists (_, state) -> - exec dyn_deps (get_if_file_exists_exn state) x - | Catch (t, on_error) -> begin - try - exec dyn_deps t x - with exn -> - on_error exn - end - | Lazy_no_targets t -> - exec dyn_deps (Lazy.force t) x - | Memo m -> - begin match m.state with - | Evaluated (x, deps) -> - dyn_deps := Dep.Set.union !dyn_deps deps; - x - | Evaluating -> - die "Dependency cycle evaluating memoized build arrow %s" m.name - | Unevaluated -> - m.state <- Evaluating; - let dyn_deps' = ref Dep.Set.empty in - match exec dyn_deps' m.t x with - | x -> - m.state <- Evaluated (x, !dyn_deps'); - dyn_deps := Dep.Set.union !dyn_deps !dyn_deps'; - x - | exception exn -> - m.state <- Unevaluated; - reraise exn - end - in - let dyn_deps = ref Dep.Set.empty in - let result = exec dyn_deps (Build.repr t) x in - (result, !dyn_deps) -end - (* [copy_source] is [true] for rules copying files from the source directory *) let add_spec t fn rule ~copy_source = match Path.Table.find t.files fn with @@ -878,7 +801,7 @@ let rec compile_rule t ?(copy_source=false) pre_rule = and static_deps t build = Fiber.Once.create (fun () -> Fiber.return - (Build_interpret.static_deps build + (Build.static_deps build ~all_targets:(targets_of t))) and start_rule t _rule = @@ -1076,7 +999,7 @@ and load_dir_step2_exn t ~dir ~collector = automatically kept *) rules | Some (_, to_copy) -> - List.filter rules ~f:(fun (rule : Build_interpret.Rule.t) -> + List.filter rules ~f:(fun (rule : Pre_rule.t) -> match rule.mode with | Standard | Promote _ | Not_a_rule_stanza | Ignore_source_files -> true @@ -1238,7 +1161,7 @@ let evaluate_action_and_dynamic_deps_def = let* static_deps = Fiber.Once.get rule.static_deps in let rule_deps = Static_deps.rule_deps static_deps in let+ () = build_deps rule_deps in - Build_exec.exec ~eval_pred rule.build () + Build.exec ~eval_pred rule.build () in Memo.create "evaluate-action-and-dynamic-deps" @@ -1630,7 +1553,7 @@ let produce_rule_collection collector f = Memo.Implicit_output.produce rule_collection_implicit_output ( Appendable_list.singleton thunk) -let add_rule (rule : Build_interpret.Rule.t) = +let add_rule (rule : Pre_rule.t) = let t = t () in let rule = match t.prefix with @@ -1646,7 +1569,7 @@ let prefix_rules' t prefix ~f = let prefix_rules prefix ~f = let t = t () in - let targets = Build_interpret.targets prefix in + let targets = Build.targets prefix in if not (Path.Set.is_empty targets) then Exn.code_error "Build_system.prefix_rules' prefix contains targets" ["targets", Path.Set.to_sexp targets]; @@ -1786,7 +1709,7 @@ module All_lib_deps : sig end = struct let static_deps_of_request request = Static_deps.paths @@ - Build_interpret.static_deps request ~all_targets:targets_of + Build.static_deps request ~all_targets:targets_of let rules_for_files t paths = Path.Set.fold paths ~init:[] ~f:(fun path acc -> diff --git a/src/build_system.mli b/src/build_system.mli index e6691e204de..5ff7e64e0b3 100644 --- a/src/build_system.mli +++ b/src/build_system.mli @@ -58,7 +58,7 @@ val set_rule_generators The call to [load_dir ~dir:a] from [gen_rules ~dir:b] declares a directory dependency from [b] to [a]. There must be no cyclic directory dependencies. *) -val add_rule : Build_interpret.Rule.t -> unit +val add_rule : Rule.t -> unit (** [prefix_rules t prefix ~f] Runs [f] and adds [prefix] as a dependency to all the rules generated by [f] *) diff --git a/src/rule.ml b/src/rule.ml new file mode 100644 index 00000000000..e9907ce1413 --- /dev/null +++ b/src/rule.ml @@ -0,0 +1,54 @@ +open! Stdune +open Import + +type t = + { context : Context.t option + ; env : Env.t option + ; build : (unit, Action.t) Build.t + ; targets : Path.Set.t + ; sandbox : bool + ; mode : Dune_file.Rule.Mode.t + ; locks : Path.t list + ; loc : Loc.t option + ; dir : Path.t + } + +let make ?(sandbox=false) ?(mode=Dune_file.Rule.Mode.Not_a_rule_stanza) + ~context ~env ?(locks=[]) ?loc build = + let targets = Build.targets build in + let dir = + match Path.Set.choose targets with + | None -> begin + match loc with + | Some loc -> Errors.fail loc "Rule has no targets specified" + | None -> Exn.code_error "Build_interpret.Rule.make: no targets" [] + end + | Some x -> + let dir = Path.parent_exn x in + if Path.Set.exists targets ~f:(fun path -> Path.parent_exn path <> dir) + then begin + match loc with + | None -> + Exn.code_error "rule has targets in different directories" + [ "targets", Path.Set.to_sexp targets + ] + | Some loc -> + Errors.fail loc + "Rule has targets in different directories.\nTargets:\n%s" + (String.concat ~sep:"\n" + (Path.Set.to_list targets |> List.map ~f:(fun p -> + sprintf "- %s" + (Path.to_string_maybe_quoted p)))) + end; + dir + in + { context + ; env + ; build + ; targets + ; sandbox + ; mode + ; locks + ; loc + ; dir + } diff --git a/src/rule.mli b/src/rule.mli new file mode 100644 index 00000000000..817d5589c5b --- /dev/null +++ b/src/rule.mli @@ -0,0 +1,27 @@ +(** Representation of rules *) + +open! Stdune +open! Import + +type t = + { context : Context.t option + ; env : Env.t option + ; build : (unit, Action.t) Build.t + ; targets : Path.Set.t + ; sandbox : bool + ; mode : Dune_file.Rule.Mode.t + ; locks : Path.t list + ; loc : Loc.t option + ; (** Directory where all the targets are produced *) + dir : Path.t + } + +val make + : ?sandbox:bool + -> ?mode:Dune_file.Rule.Mode.t + -> context:Context.t option + -> env:Env.t option + -> ?locks:Path.t list + -> ?loc:Loc.t + -> (unit, Action.t) Build.t + -> t diff --git a/src/super_context.ml b/src/super_context.ml index 528e5afc4d9..aaa188a6805 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -1,14 +1,13 @@ open! Stdune open Import -open Dune_file type t = { context : Context.t ; scopes : Scope.DB.t ; public_libs : Lib.DB.t ; installed_libs : Lib.DB.t - ; stanzas : Stanzas.t Dir_with_dune.t list - ; stanzas_per_dir : Stanzas.t Dir_with_dune.t Path.Map.t + ; stanzas : Dune_file.Stanzas.t Dir_with_dune.t list + ; stanzas_per_dir : Dune_file.Stanzas.t Dir_with_dune.t Path.Map.t ; packages : Package.t Package.Name.Map.t ; file_tree : File_tree.t ; artifacts : Artifacts.t @@ -47,7 +46,7 @@ let internal_lib_names t = List.fold_left t.stanzas ~init:Lib_name.Set.empty ~f:(fun acc { Dir_with_dune. data = stanzas; _ } -> List.fold_left stanzas ~init:acc ~f:(fun acc -> function - | Library lib -> + | Dune_file.Library lib -> Lib_name.Set.add (match lib.public with | None -> acc @@ -168,14 +167,14 @@ let add_rule t ?sandbox ?mode ?locks ?loc ~dir build = let build = Build.O.(>>>) build t.chdir in let env = Env.external_ t ~dir in Build_system.add_rule - (Build_interpret.Rule.make ?sandbox ?mode ?locks ?loc + (Rule.make ?sandbox ?mode ?locks ?loc ~context:(Some t.context) ~env:(Some env) build) let add_rule_get_targets t ?sandbox ?mode ?locks ?loc ~dir build = let build = Build.O.(>>>) build t.chdir in let env = Env.external_ t ~dir in let rule = - Build_interpret.Rule.make ?sandbox ?mode ?locks ?loc + Rule.make ?sandbox ?mode ?locks ?loc ~context:(Some t.context) ~env:(Some env) build in Build_system.add_rule rule; @@ -231,14 +230,14 @@ let partial_expand sctx ~dep_kind ~targets_written_by_user ~map_exe let partial = Action_unexpanded.partial_expand t ~expander ~map_exe in (partial, acc) -let ocaml_flags t ~dir (x : Buildable.t) = +let ocaml_flags t ~dir (x : Dune_file.Buildable.t) = let expander = Env.expander t ~dir in Ocaml_flags.make ~spec:x.flags ~default:(Env.ocaml_flags t ~dir) ~eval:(Expander.expand_and_eval_set expander) -let c_flags t ~dir ~expander ~(lib : Library.t) = +let c_flags t ~dir ~expander ~(lib : Dune_file.Library.t) = let ccg = Context.cc_g t.context in let flags = lib.c_flags in let default = Env.c_flags t ~dir in @@ -291,7 +290,7 @@ let create let ctx_dir = Path.append context.build_dir dir in List.filter_map stanzas ~f:(fun stanza -> match (stanza : Stanza.t) with - | Library lib -> Some (ctx_dir, lib) + | Dune_file.Library lib -> Some (ctx_dir, lib) | _ -> None)) in let scopes, public_libs = @@ -423,7 +422,7 @@ end module Deps = struct open Build.O - open Dep_conf + open Dune_file.Dep_conf let make_alias expander s = let loc = String_with_vars.loc s in