diff --git a/src/build.ml b/src/build.ml index 4902aba9..32e1f912 100644 --- a/src/build.ml +++ b/src/build.ml @@ -27,6 +27,7 @@ module Repr = struct | Split : ('a, 'b) t * ('c, 'd) t -> ('a * 'c, 'b * 'd) t | Fanout : ('a, 'b) t * ('a, 'c) t -> ('a, 'b * 'c) t | Paths : Pset.t -> ('a, 'a) t + | Paths_for_rule : Path.Set.t -> ('a, 'a) t | Paths_glob : glob_state ref -> ('a, Path.t list) t (* The reference gets decided in Build_interpret.deps *) | If_file_exists : Path.t * ('a, 'b) if_file_exists_state ref -> ('a, 'b) t @@ -135,6 +136,7 @@ let path_set ps = Paths ps let paths_glob ~loc ~dir re = Paths_glob (ref (G_unevaluated (loc, dir, re))) let vpath vp = Vpath vp let dyn_paths t = Dyn_paths t +let paths_for_rule ps = Paths_for_rule ps let catch t ~on_error = Catch (t, on_error) diff --git a/src/build.mli b/src/build.mli index 1dc7904e..d8c704d7 100644 --- a/src/build.mli +++ b/src/build.mli @@ -183,6 +183,7 @@ module Repr : sig | Split : ('a, 'b) t * ('c, 'd) t -> ('a * 'c, 'b * 'd) t | Fanout : ('a, 'b) t * ('a, 'c) t -> ('a, 'b * 'c) t | Paths : Path.Set.t -> ('a, 'a) t + | Paths_for_rule : Path.Set.t -> ('a, 'a) t | Paths_glob : glob_state ref -> ('a, Path.t list) t | If_file_exists : Path.t * ('a, 'b) if_file_exists_state ref -> ('a, 'b) t | Contents : Path.t -> ('a, string) t @@ -220,3 +221,6 @@ end val repr : ('a, 'b) t -> ('a, 'b) Repr.t val merge_lib_deps : lib_deps -> lib_deps -> lib_deps + +(**/**) +val paths_for_rule : Path.Set.t -> ('a, 'a) t diff --git a/src/build_interpret.ml b/src/build_interpret.ml index 37c55471..f559174d 100644 --- a/src/build_interpret.ml +++ b/src/build_interpret.ml @@ -63,6 +63,8 @@ let static_deps t ~all_targets ~file_tree = | Split (a, b) -> loop a (loop b acc) | Fanout (a, b) -> loop a (loop b acc) | Paths fns -> { acc with action_deps = Pset.union fns acc.action_deps } + | Paths_for_rule fns -> + { acc with rule_deps = Pset.union fns acc.rule_deps } | Paths_glob state -> begin match !state with | G_evaluated l -> @@ -129,6 +131,7 @@ let lib_deps = | Split (a, b) -> loop a (loop b acc) | Fanout (a, b) -> loop a (loop b acc) | Paths _ -> acc + | Paths_for_rule _ -> acc | Vpath _ -> acc | Paths_glob _ -> acc | Dyn_paths t -> loop t acc @@ -156,6 +159,7 @@ let targets = | Split (a, b) -> loop a (loop b acc) | Fanout (a, b) -> loop a (loop b acc) | Paths _ -> acc + | Paths_for_rule _ -> acc | Vpath _ -> acc | Paths_glob _ -> acc | Dyn_paths t -> loop t acc @@ -188,10 +192,11 @@ module Rule = struct ; locks : Path.t list ; loc : Loc.t option ; dir : Path.t + ; package : Package.Name.t option } let make ?(sandbox=false) ?(mode=Jbuild.Rule.Mode.Not_a_rule_stanza) - ~context ?(locks=[]) ?loc build = + ~context ?(locks=[]) ?loc ?package build = let targets = targets build in let dir = match targets with @@ -225,5 +230,6 @@ module Rule = struct ; locks ; loc ; dir + ; package } end diff --git a/src/build_interpret.mli b/src/build_interpret.mli index 5d2f08c7..01bf3687 100644 --- a/src/build_interpret.mli +++ b/src/build_interpret.mli @@ -20,6 +20,7 @@ module Rule : sig ; loc : Loc.t option ; (** Directory where all the targets are produced *) dir : Path.t + ; package : Package.Name.t option } val make @@ -28,6 +29,7 @@ module Rule : sig -> context:Context.t option -> ?locks:Path.t list -> ?loc:Loc.t + -> ?package:Package.Name.t -> (unit, Action.t) Build.t -> t end diff --git a/src/build_system.ml b/src/build_system.ml index ef4bec8a..99fbaad1 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -161,6 +161,7 @@ module Internal_rule = struct ; loc : Loc.t option ; dir : Path.t ; mutable exec : Exec_status.t + ; package : Package.Name.t option } let compare a b = Id.compare a.id b.id @@ -446,6 +447,7 @@ module Build_exec = struct let b = exec dyn_deps b x in (a, b) | Paths _ -> x + | Paths_for_rule _ -> x | Paths_glob state -> get_glob_result_exn state | Contents p -> Io.read_file (Path.to_string p) | Lines_of p -> Io.lines_of_file (Path.to_string p) @@ -650,6 +652,7 @@ let rec compile_rule t ?(copy_source=false) pre_rule = ; locks ; loc ; dir + ; package } = pre_rule in @@ -774,6 +777,7 @@ let rec compile_rule t ?(copy_source=false) pre_rule = ; mode ; loc ; dir + ; package } in create_file_specs t target_specs rule ~copy_source @@ -1328,7 +1332,8 @@ let build_rules_internal ?(recursive=false) t ~request = else begin rules_seen := Id_set.add !rules_seen ir.id; (match ir.exec with - | Running { rule_evaluation; _ } | Evaluating_rule { rule_evaluation; _ } -> + | Running { rule_evaluation; _ } + | Evaluating_rule { rule_evaluation; _ } -> Fiber.return rule_evaluation | Not_started { eval_rule; exec_rule } -> Fiber.fork (fun () -> @@ -1385,6 +1390,38 @@ let build_rules ?recursive t ~request = entry_point t ~f:(fun () -> build_rules_internal ?recursive t ~request) +let package_deps t files = + let rules_seen = ref Id_set.empty in + let packages = ref Package.Name.Set.empty in + let rec loop fn = + let dir = Path.parent fn in + if Path.is_in_build_dir dir then load_dir t ~dir; + match Hashtbl.find t.files fn with + | None -> () + | Some (File_spec.T { rule = ir; _ }) -> + if not (Id_set.mem !rules_seen ir.id) then begin + rules_seen := Id_set.add !rules_seen ir.id; + let _, dyn_deps = + match ir.exec with + | Running { rule_evaluation; _ } + | Evaluating_rule { rule_evaluation; _ } -> + Option.value_exn (Fiber.Future.peek rule_evaluation) + | Not_started _ -> assert false + in + match ir.package with + | None -> + Pset.iter (Pset.union ir.static_deps dyn_deps) ~f:loop + | Some p -> + packages := Package.Name.Set.add !packages p + end + in + let open Build.O in + Build.paths_for_rule files >>^ fun () -> + (* This is a bit ugly, we know that at this point of execution, all + the relevant ivars have been filled *) + Pset.iter files ~f:loop; + !packages + (* +-----------------------------------------------------------------+ | Adding rules to the system | +-----------------------------------------------------------------+ *) diff --git a/src/build_system.mli b/src/build_system.mli index 5dd60c2d..0a3aaea8 100644 --- a/src/build_system.mli +++ b/src/build_system.mli @@ -77,6 +77,14 @@ val on_load_dir : t -> dir:Path.t -> f:(unit -> unit) -> unit (** Stamp file that depends on all files of [dir] with extension [ext]. *) val stamp_file_for_files_of : t -> dir:Path.t -> ext:string -> Path.t +(** Scan the transitive dependencies of the following files and return + set of packages these files are part of. Do not scan packages + recursively. *) +val package_deps + : t + -> Path.Set.t + -> (unit, Package.Name.Set.t) Build.t + (** {2 Aliases} *) module Alias : sig diff --git a/src/fiber/fiber.ml b/src/fiber/fiber.ml index 3903acd0..10fd3252 100644 --- a/src/fiber/fiber.ml +++ b/src/fiber/fiber.ml @@ -386,12 +386,18 @@ module Ivar = struct | Full x -> k x | Empty q -> Queue.push { Handler. run = k; ctx } q + + let peek t = + match t.state with + | Full x -> Some x + | Empty _ -> None end module Future = struct type 'a t = 'a Ivar.t let wait = Ivar.read + let peek = Ivar.peek end let fork f ctx k = diff --git a/src/fiber/fiber.mli b/src/fiber/fiber.mli index 9bbf1b0d..d1c7851d 100644 --- a/src/fiber/fiber.mli +++ b/src/fiber/fiber.mli @@ -40,6 +40,9 @@ module Future : sig (** Wait for the given future to yield a value. *) val wait : 'a t -> 'a fiber + + (** Return [Some x] if [t] has already returned. *) + val peek : 'a t -> 'a option end with type 'a fiber := 'a t (** [fork f] creates a sub-fiber and return a [Future.t] to wait its result. *) @@ -226,6 +229,9 @@ module Ivar : sig (** Fill the ivar with the following value. This can only be called once for a given ivar. *) val fill : 'a t -> 'a -> unit fiber + + (** Return [Some x] is [fill t x] has been called previously. *) + val peek : 'a t -> 'a option end with type 'a fiber := 'a t module Mutex : sig diff --git a/src/install_rules.ml b/src/install_rules.ml index 6db17359..7c948d76 100644 --- a/src/install_rules.ml +++ b/src/install_rules.ml @@ -205,7 +205,7 @@ module Gen(P : Install_params) = struct let dst = Path.append install_dir (Install.Entry.relative_installed_path entry ~package) in - SC.add_rule sctx (Build.symlink ~src:entry.src ~dst); + SC.add_rule sctx (Build.symlink ~src:entry.src ~dst) ~package; Install.Entry.set_src entry dst) let promote_install_file = @@ -237,9 +237,24 @@ module Gen(P : Install_params) = struct (Utils.install_file ~package ~findlib_toolchain:ctx.findlib_toolchain) in let entries = local_install_rules entries ~package in - SC.add_alias_deps sctx + SC.add_alias_action sctx ~stamp:(List []) (Alias.package_install ~context:ctx ~pkg:package) - (List.map entries ~f:(fun (e : Install.Entry.t) -> e.src)); + (let files = + List.map entries ~f:(fun (e : Install.Entry.t) -> e.src) + |> Path.Set.of_list + in + Build.path_set files + >>> + Build_system.package_deps (SC.build_system sctx) files + >>> + Build.dyn_paths (Build.arr (fun packages -> + Package.Name.Set.remove packages package + |> Package.Name.Set.to_list + |> List.map ~f:(fun pkg -> + Build_system.Alias.package_install + ~context:(SC.context sctx) ~pkg + |> Build_system.Alias.stamp_file))) + >>^ fun _ -> Action.Progn []); SC.add_rule sctx ~mode:(if promote_install_file then Promote_but_delete_on_clean diff --git a/src/super_context.ml b/src/super_context.ml index b8733474..8eb6724b 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -41,6 +41,7 @@ let file_tree t = t.file_tree let stanzas_to_consider_for_install t = t.stanzas_to_consider_for_install let cxx_flags t = t.cxx_flags let build_dir t = t.context.build_dir +let build_system t = t.build_system let host t = Option.value t.host ~default:t @@ -218,10 +219,10 @@ let create let prefix_rules t prefix ~f = Build_system.prefix_rules t.build_system prefix ~f -let add_rule t ?sandbox ?mode ?locks ?loc build = +let add_rule t ?sandbox ?mode ?locks ?loc ?package build = let build = Build.O.(>>>) build t.chdir in Build_system.add_rule t.build_system - (Build_interpret.Rule.make ?sandbox ?mode ?locks ?loc + (Build_interpret.Rule.make ?sandbox ?mode ?locks ?loc ?package ~context:(Some t.context) build) let add_rule_get_targets t ?sandbox ?mode ?locks ?loc build = diff --git a/src/super_context.mli b/src/super_context.mli index 9921587c..ffd2900d 100644 --- a/src/super_context.mli +++ b/src/super_context.mli @@ -41,6 +41,7 @@ val stanzas_to_consider_for_install : t -> (Path.t * Scope.t * Stanza.t) list val cxx_flags : t -> string list val build_dir : t -> Path.t val host : t -> t +val build_system : t -> Build_system.t (** All public libraries of the workspace *) val public_libs : t -> Lib.DB.t @@ -79,6 +80,7 @@ val add_rule -> ?mode:Jbuild.Rule.Mode.t -> ?locks:Path.t list -> ?loc:Loc.t + -> ?package:Package.Name.t -> (unit, Action.t) Build.t -> unit val add_rule_get_targets