feat: finer dependency analysis between libraries (#4572)

src/dune_rules/compilation_context.ml

@@ -4,55 +4,32 @@ open Memo.O
 module Includes = struct
   type t = Command.Args.without_targets Command.Args.t Lib_mode.Cm_kind.Map.t
 
-  let make ~project ~opaque ~direct_requires ~hidden_requires lib_config
+  (* Library file dependencies (Hidden_deps) are added per-module in
+     module_compilation.ml rather than here.
+     TODO: some of the requires can be filtered out using [ocamldep] info.
+     See issue #4572. *)
+  let make ~project ~direct_requires ~hidden_requires lib_config
     : _ Lib_mode.Cm_kind.Map.t
     =
-    (* TODO: some of the requires can filtered out using [ocamldep] info *)
     let open Resolve.Memo.O in
     let iflags direct_libs hidden_libs mode =
       Lib_flags.L.include_flags ~project ~direct_libs ~hidden_libs mode lib_config
     in
-    let make_includes_args ~mode groups =
+    let make_includes_args ~mode =
       (let+ direct_libs = direct_requires
        and+ hidden_libs = hidden_requires in
-       Command.Args.S
-         [ iflags direct_libs hidden_libs mode
-         ; Hidden_deps (Lib_file_deps.deps (direct_libs @ hidden_libs) ~groups)
-         ])
+       iflags direct_libs hidden_libs mode)
       |> Resolve.Memo.args
       |> Command.Args.memo
     in
     { ocaml =
-        (let cmi_includes = make_includes_args ~mode:(Ocaml Byte) [ Ocaml Cmi ] in
+        (let cmi_includes = make_includes_args ~mode:(Ocaml Byte) in
          { cmi = cmi_includes
          ; cmo = cmi_includes
-         ; cmx =
-             (let+ direct_libs = direct_requires
-              and+ hidden_libs = hidden_requires in
-              Command.Args.S
-                [ iflags direct_libs hidden_libs (Ocaml Native)
-                ; Hidden_deps
-                    (let libs = direct_libs @ hidden_libs in
-                     if opaque
-                     then
-                       List.map libs ~f:(fun lib ->
-                         ( lib
-                         , if Lib.is_local lib
-                           then [ Lib_file_deps.Group.Ocaml Cmi ]
-                           else [ Ocaml Cmi; Ocaml Cmx ] ))
-                       |> Lib_file_deps.deps_with_exts
-                     else
-                       Lib_file_deps.deps
-                         libs
-                         ~groups:[ Lib_file_deps.Group.Ocaml Cmi; Ocaml Cmx ])
-                ])
-             |> Resolve.Memo.args
-             |> Command.Args.memo
+         ; cmx = make_includes_args ~mode:(Ocaml Native)
          })
     ; melange =
-        { cmi = make_includes_args ~mode:Melange [ Melange Cmi ]
-        ; cmj = make_includes_args ~mode:Melange [ Melange Cmi; Melange Cmj ]
-        }
+        { cmi = make_includes_args ~mode:Melange; cmj = make_includes_args ~mode:Melange }
     }
   ;;
 
@@ -91,6 +68,7 @@ type t =
   ; parameters : Module_name.t list Resolve.Memo.t
   ; instances : Parameterised_instances.t Resolve.Memo.t option
   ; includes : Includes.t
+  ; lib_index : Lib_file_deps.Lib_index.t Resolve.Memo.t
   ; preprocessing : Pp_spec.t
   ; opaque : bool
   ; js_of_ocaml : Js_of_ocaml.In_context.t option Js_of_ocaml.Mode.Pair.t
@@ -118,6 +96,7 @@ let requires_hidden t = t.requires_hidden
 let requires_link t = Memo.Lazy.force t.requires_link
 let parameters t = t.parameters
 let includes t = t.includes
+let lib_index t = t.lib_index
 let preprocessing t = t.preprocessing
 let opaque t = t.opaque
 let js_of_ocaml t = t.js_of_ocaml
@@ -240,8 +219,12 @@ let create
   ; requires_link
   ; implements
   ; parameters
-  ; includes =
-      Includes.make ~project ~opaque ~direct_requires ~hidden_requires ocaml.lib_config
+  ; includes = Includes.make ~project ~direct_requires ~hidden_requires ocaml.lib_config
+  ; lib_index =
+      (let open Resolve.Memo.O in
+       let* direct_libs = direct_requires
+       and* hidden_libs = hidden_requires in
+       Lib_file_deps.Lib_index.create super_context (direct_libs @ hidden_libs) ~for_)
   ; preprocessing
   ; opaque
   ; js_of_ocaml
@@ -333,7 +316,6 @@ let for_module_generated_at_link_time cctx ~requires ~module_ =
     let direct_requires = requires in
     Includes.make
       ~project:(Scope.project cctx.scope)
-      ~opaque
       ~direct_requires
       ~hidden_requires
       cctx.ocaml.lib_config

src/dune_rules/compilation_context.mli

@@ -62,6 +62,7 @@ val requires_hidden : t -> Lib.t list Resolve.Memo.t
 val requires_compile : t -> Lib.t list Resolve.Memo.t
 val parameters : t -> Module_name.t list Resolve.Memo.t
 val includes : t -> Command.Args.without_targets Command.Args.t Lib_mode.Cm_kind.Map.t
+val lib_index : t -> Lib_file_deps.Lib_index.t Resolve.Memo.t
 val preprocessing : t -> Pp_spec.t
 val opaque : t -> bool
 val js_of_ocaml : t -> Js_of_ocaml.In_context.t option Js_of_ocaml.Mode.Pair.t

src/dune_rules/dep_graph.ml

@@ -7,6 +7,7 @@ type t =
   }
 
 let make ~dir ~per_module = { dir; per_module }
+let dir t = t.dir
 
 let deps_of t (m : Module.t) =
   match Module_name.Unique.Map.find t.per_module (Module.obj_name m) with

src/dune_rules/dep_graph.mli

@@ -9,6 +9,7 @@ val make
   -> per_module:Module.t list Action_builder.t Module_name.Unique.Map.t
   -> t
 
+val dir : t -> Path.Build.t
 val deps_of : t -> Module.t -> Module.t list Action_builder.t
 val top_closed_implementations : t -> Module.t list -> Module.t list Action_builder.t
 

src/dune_rules/lib_file_deps.ml

@@ -48,9 +48,41 @@ let deps_of_lib (lib : Lib.t) ~groups =
   |> Dep.Set.of_list
 ;;
 
-let deps_with_exts = Dep.Set.union_map ~f:(fun (lib, groups) -> deps_of_lib lib ~groups)
+let deps_of_module (lib : Lib.t) (m : Module.t) ~cm_kinds =
+  let obj_dir = Lib.info lib |> Lib_info.obj_dir in
+  List.filter_map cm_kinds ~f:(fun kind ->
+    Obj_dir.Module.cm_public_file obj_dir m ~kind |> Option.map ~f:(fun p -> Dep.file p))
+  |> Dep.Set.of_list
+;;
+
 let deps libs ~groups = Dep.Set.union_map libs ~f:(deps_of_lib ~groups)
 
+let deps_of_entries ~opaque ~(cm_kind : Lib_mode.Cm_kind.t) entries =
+  let groups, cm_kinds =
+    match cm_kind with
+    | Ocaml Cmi | Ocaml Cmo -> [ Group.Ocaml Cmi ], [ Lib_mode.Cm_kind.Ocaml Cmi ]
+    | Melange Cmi -> [ Group.Melange Cmi ], [ Melange Cmi ]
+    | Melange Cmj -> [ Group.Melange Cmi; Melange Cmj ], [ Melange Cmi; Melange Cmj ]
+    | Ocaml Cmx -> [ Group.Ocaml Cmi; Ocaml Cmx ], [ Ocaml Cmi; Ocaml Cmx ]
+  in
+  List.map entries ~f:(fun ((lib : Lib.t), mod_opt) ->
+    let is_opaque_local =
+      match cm_kind with
+      | Ocaml Cmx -> opaque && Lib.is_local lib
+      | _ -> false
+    in
+    match mod_opt with
+    | Some m ->
+      let cm_kinds =
+        if is_opaque_local then [ Lib_mode.Cm_kind.Ocaml Cmi ] else cm_kinds
+      in
+      deps_of_module lib m ~cm_kinds
+    | None ->
+      let groups = if is_opaque_local then [ Group.Ocaml Cmi ] else groups in
+      deps_of_lib lib ~groups)
+  |> List.fold_left ~init:Dep.Set.empty ~f:Dep.Set.union
+;;
+
 type path_specification =
   | Allow_all
   | Disallow_external of Lib_name.t
@@ -82,3 +114,86 @@ let eval ~loc ~expander ~paths:path_spec (deps : Dep_conf.t list) =
        | Some _ -> raise_disallowed_external_path ~loc lib_name path));
   paths
 ;;
+
+module Lib_index = struct
+  type entry = Lib.t * Module.t option
+
+  type t =
+    { by_module_name : entry list Module_name.Map.t
+    ; unresolved : Lib.t list
+    }
+
+  let module_names_of_lib _sctx (lib : Lib.t) ~for_
+    : (Module_name.t * Module.t option) list option Resolve.Memo.t
+    =
+    let open Resolve.Memo.O in
+    let* main_module = Lib.main_module_name lib in
+    match main_module with
+    | Some name -> Resolve.Memo.return (Some [ name, None ])
+    | None ->
+      let info = Lib.info lib in
+      (match Lib_info.entry_modules info ~for_ with
+       | Lib_info.Source.External (Ok names) ->
+         Resolve.Memo.return (Some (List.map names ~f:(fun n -> n, None)))
+       | Lib_info.Source.External (Error _) -> Resolve.Memo.return None
+       | Lib_info.Source.Local ->
+         Resolve.Memo.lift_memo
+           (let open Memo.O in
+            let+ modules_opt = Dir_contents.modules_of_lib _sctx lib ~for_ in
+            match modules_opt with
+            | None -> None
+            | Some modules_with_vlib ->
+              let modules = Modules.With_vlib.drop_vlib modules_with_vlib in
+              let entry_modules = Modules.entry_modules modules in
+              Some (List.map entry_modules ~f:(fun m -> Module.name m, Some m))))
+  ;;
+
+  let empty = { by_module_name = Module_name.Map.empty; unresolved = [] }
+
+  let create sctx (libs : Lib.t list) ~for_ : t Resolve.Memo.t =
+    let open Resolve.Memo.O in
+    let+ entries =
+      Resolve.Memo.List.map libs ~f:(fun lib ->
+        let+ names_opt = module_names_of_lib sctx lib ~for_ in
+        lib, names_opt)
+    in
+    let by_module_name, unresolved =
+      List.fold_left
+        entries
+        ~init:(Module_name.Map.empty, [])
+        ~f:(fun (by_name, unresolved) (lib, names_opt) ->
+          match names_opt with
+          | None -> by_name, lib :: unresolved
+          | Some named_modules ->
+            let by_name =
+              List.fold_left named_modules ~init:by_name ~f:(fun acc (name, mod_opt) ->
+                Module_name.Map.update acc name ~f:(function
+                  | None -> Some [ lib, mod_opt ]
+                  | Some entries -> Some ((lib, mod_opt) :: entries)))
+            in
+            by_name, unresolved)
+    in
+    { by_module_name; unresolved }
+  ;;
+
+  let filter_libs (index : t) ~(referenced_modules : Module_name.Set.t) : entry list =
+    let from_refs =
+      Module_name.Set.fold referenced_modules ~init:[] ~f:(fun name acc ->
+        match Module_name.Map.find index.by_module_name name with
+        | None -> acc
+        | Some entries -> List.rev_append entries acc)
+    in
+    let unresolved = List.map index.unresolved ~f:(fun lib -> lib, None) in
+    let compare (a_lib, a_mod) (b_lib, b_mod) =
+      match Lib.compare a_lib b_lib with
+      | (Lt | Gt) as c -> c
+      | Eq ->
+        (match a_mod, b_mod with
+         | None, None -> Eq
+         | None, Some _ -> Lt
+         | Some _, None -> Gt
+         | Some a, Some b -> Module_name.compare (Module.name a) (Module.name b))
+    in
+    List.rev_append unresolved from_refs |> List.sort_uniq ~compare
+  ;;
+end

src/dune_rules/lib_file_deps.mli

@@ -15,7 +15,13 @@ end
     with extension [files] of libraries [libs]. *)
 val deps : Lib.t list -> groups:Group.t list -> Dep.Set.t
 
-val deps_with_exts : (Lib.t * Group.t list) list -> Dep.Set.t
+(** Compute library file dependencies for all [libs] for the given [cm_kind].
+    When [opaque] is true, local libraries only depend on .cmi (not .cmx). *)
+val deps_of_entries
+  :  opaque:bool
+  -> cm_kind:Lib_mode.Cm_kind.t
+  -> (Lib.t * Module.t option) list
+  -> Dep.Set.t
 
 type path_specification =
   | Allow_all
@@ -29,3 +35,18 @@ val eval
   -> paths:path_specification
   -> Dep_conf.t list
   -> Path.Set.t Memo.t
+
+module Lib_index : sig
+  type entry = Lib.t * Module.t option
+  type t
+
+  val empty : t
+
+  val create
+    :  Super_context.t
+    -> Lib.t list
+    -> for_:Compilation_mode.t
+    -> t Resolve.Memo.t
+
+  val filter_libs : t -> referenced_modules:Module_name.Set.t -> entry list
+end