Recursive package deps

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)
 

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

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

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

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                                      |
    +-----------------------------------------------------------------+ *)

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

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 =

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

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

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 =

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