fix(melange): prefer melobjinfo for imported virtual-library dependencies

src/dune_rules/dep_rules.ml

@@ -199,6 +199,126 @@ let ooi_deps
     Action_builder.if_file_exists cmt ~then_:(read cmt) ~else_:(Action_builder.return [])
 ;;
 
+let make_melange_imported_vlib_deps
+      ~melobjinfo
+      ~sctx
+      ~dir
+      ~vlib_obj_dir
+      ~dune_version
+      ~vlib_obj_map
+  =
+  let modules =
+    Module_name.Unique.Map.values vlib_obj_map
+    |> List.map ~f:Modules.Sourced_module.to_module
+  in
+  let module_files kind =
+    List.filter_map modules ~f:(fun m ->
+      Obj_dir.Module.cm_file vlib_obj_dir m ~kind |> Option.map ~f:(fun path -> m, path))
+  in
+  let cmi_files = module_files (Melange Cmi) in
+  let cmj_files = module_files (Melange Cmj) in
+  let sandbox =
+    if dune_version >= (3, 3) then Some Sandbox_config.needs_sandboxing else None
+  in
+  let deps_map files results kind =
+    let expected = List.length files in
+    let actual = List.length results in
+    if expected <> actual
+    then
+      Code_error.raise
+        "unexpected number of object-info results"
+        [ "expected", Dyn.int expected; "actual", Dyn.int actual ];
+    List.combine files results
+    |> List.fold_left ~init:Module_name.Unique.Map.empty ~f:(fun deps ((m, _), ooi) ->
+      Module_name.Unique.Map.set deps (Module.obj_name m) (Ml_kind.Dict.get ooi kind))
+  in
+  let transitive_deps cmi_deps cmj_deps m =
+    let root = Module.obj_name m in
+    let rec visit seen_intf seen_impl deps = function
+      | [] -> deps
+      | (dep, ml_kind) :: rest ->
+        let seen =
+          match ml_kind with
+          | Ml_kind.Intf -> seen_intf
+          | Impl -> seen_impl
+        in
+        if Module_name.Unique.Set.mem seen dep
+        then visit seen_intf seen_impl deps rest
+        else (
+          let seen_intf, seen_impl =
+            match ml_kind with
+            | Ml_kind.Intf -> Module_name.Unique.Set.add seen_intf dep, seen_impl
+            | Impl -> seen_intf, Module_name.Unique.Set.add seen_impl dep
+          in
+          match Module_name.Unique.Map.find vlib_obj_map dep with
+          | None -> visit seen_intf seen_impl deps rest
+          | Some sourced_module ->
+            let module_ = Modules.Sourced_module.to_module sourced_module in
+            let deps =
+              if Module_name.Unique.equal dep root
+              then deps
+              else Module_name.Unique.Set.add deps dep
+            in
+            let rest =
+              match Module.kind module_ with
+              | Root | Alias _ -> rest
+              | _ ->
+                let intf_deps =
+                  Module_name.Unique.Map.find cmi_deps dep
+                  |> Option.value ~default:Module_name.Unique.Set.empty
+                  |> Module_name.Unique.Set.to_list
+                  |> List.map ~f:(fun dep -> dep, Ml_kind.Intf)
+                in
+                let impl_deps =
+                  match ml_kind with
+                  | Ml_kind.Intf -> []
+                  | Impl ->
+                    Module_name.Unique.Map.find cmj_deps dep
+                    |> Option.value ~default:Module_name.Unique.Set.empty
+                    |> Module_name.Unique.Set.to_list
+                    |> List.map ~f:(fun dep -> dep, Ml_kind.Impl)
+                in
+                impl_deps @ intf_deps @ rest
+            in
+            visit seen_intf seen_impl deps rest)
+    in
+    visit
+      Module_name.Unique.Set.empty
+      Module_name.Unique.Set.empty
+      Module_name.Unique.Set.empty
+      [ root, Ml_kind.Impl ]
+    |> Module_name.Unique.Set.to_list
+    |> List.filter_map ~f:(fun dep ->
+      Module_name.Unique.Map.find vlib_obj_map dep
+      |> Option.map ~f:Modules.Sourced_module.to_module)
+  in
+  let deps =
+    Memo.lazy_ ~name:"installed-melange-vlib-deps" (fun () ->
+      let* ocaml = Context.ocaml (Super_context.context sctx)
+      and* melobjinfo = melobjinfo in
+      let open Action_builder.O in
+      let deps =
+        let+ cmi_results =
+          Ocamlobjinfo.rules ocaml ~sandbox ~dir ~units:(List.map cmi_files ~f:snd)
+        and+ cmj_results =
+          match cmj_files with
+          | [] -> Action_builder.return []
+          | _ ->
+            Melobjinfo.rules melobjinfo ~sandbox ~dir ~units:(List.map cmj_files ~f:snd)
+        in
+        ( deps_map cmi_files cmi_results Ml_kind.Intf
+        , deps_map cmj_files cmj_results Ml_kind.Impl )
+      in
+      Memo.return (Action_builder.memoize "installed Melange vlib deps" deps))
+  in
+  fun sourced_module ->
+    let* deps = Memo.Lazy.force deps in
+    let m = Modules.Sourced_module.to_module sourced_module in
+    Action_builder.map deps ~f:(fun (cmi_deps, cmj_deps) ->
+      transitive_deps cmi_deps cmj_deps m)
+    |> Memo.return
+;;
+
 let wrapped_compat_deps modules m =
   let inner = Modules.compat_for_exn (Modules.With_vlib.drop_vlib modules) m in
   match Modules.With_vlib.lib_interface modules with
@@ -377,6 +497,24 @@ let make_imported_vlib_deps
   | None ->
     let vlib_obj_map = Vimpl.vlib_obj_map vimpl in
     let vlib_obj_dir = Lib.info vlib |> Lib_info.obj_dir in
+    let dune_version =
+      let impl = Vimpl.impl vimpl in
+      Dune_project.dune_version impl.project
+    in
+    let melobjinfo =
+      Memo.lazy_ ~name:"melobjinfo" (fun () ->
+        Melange_binary.melobjinfo sctx ~loc:None ~dir)
+      |> Memo.Lazy.force
+    in
+    let melange_impl_deps =
+      make_melange_imported_vlib_deps
+        ~melobjinfo
+        ~sctx
+        ~dir
+        ~vlib_obj_dir
+        ~dune_version
+        ~vlib_obj_map
+    in
     let impl_deps_if_cmt_missing =
       (match for_ with
        | Ocaml -> Action_builder.return ()
@@ -397,30 +535,39 @@ let make_imported_vlib_deps
            @ Obj_dir.Module.L.cm_files obj_dir vlib_modules ~kind:(Melange Cmj)
          in
          let open Action_builder.O in
-         let* cmts_exist =
-           List.map cmts ~f:Action_builder.file_exists |> Action_builder.all
-         in
-         if List.for_all cmts_exist ~f:Fun.id
-         then Action_builder.return ()
-         else Action_builder.paths files)
+         let* melobjinfo = Action_builder.of_memo melobjinfo in
+         (match melobjinfo with
+          | Ok _ -> Action_builder.return ()
+          | Error _ ->
+            let* cmts_exist =
+              List.map cmts ~f:Action_builder.file_exists |> Action_builder.all
+            in
+            if List.for_all cmts_exist ~f:Fun.id
+            then Action_builder.return ()
+            else Action_builder.paths files))
       |> Action_builder.memoize "imported vlib object deps if CMT missing"
     in
-    let dune_version =
-      let impl = Vimpl.impl vimpl in
-      Dune_project.dune_version impl.project
-    in
-    let deps_of sourced_module ~ml_kind =
-      ooi_deps
-        ~vimpl
-        ~sctx
-        ~dir
-        ~obj_dir
-        ~vlib_obj_dir
-        ~dune_version
-        ~vlib_obj_map
-        ~for_
-        ~ml_kind
-        sourced_module
+    let deps_of sourced_module ~(ml_kind : Ml_kind.t) =
+      let fallback_deps =
+        ooi_deps
+          ~vimpl
+          ~sctx
+          ~dir
+          ~obj_dir
+          ~vlib_obj_dir
+          ~dune_version
+          ~vlib_obj_map
+          ~for_
+          ~ml_kind
+          sourced_module
+      in
+      match for_, ml_kind with
+      | Melange, Impl ->
+        let* melobjinfo = melobjinfo in
+        (match melobjinfo with
+         | Ok _ -> melange_impl_deps sourced_module
+         | Error _ -> fallback_deps)
+      | Ocaml, _ | Melange, Intf -> fallback_deps
     in
     { deps_of; impl_deps_if_cmt_missing }
   | Some lib ->

src/dune_rules/melange/melange_binary.ml

@@ -11,6 +11,16 @@ let melc sctx ~loc ~dir =
     "melc"
 ;;
 
+let melobjinfo sctx ~loc ~dir =
+  Super_context.resolve_program_memo
+    sctx
+    ~loc
+    ~dir
+    ~where:Original_path
+    ~hint:"opam install melange"
+    "melobjinfo"
+;;
+
 let available sctx ~dir =
   let+ melc = melc sctx ~loc:None ~dir in
   Result.is_ok melc

src/dune_rules/melange/melange_binary.mli

@@ -1,5 +1,12 @@
 open Import
 
 val melc : Super_context.t -> loc:Loc.t option -> dir:Path.Build.t -> Action.Prog.t Memo.t
+
+val melobjinfo
+  :  Super_context.t
+  -> loc:Loc.t option
+  -> dir:Path.Build.t
+  -> Action.Prog.t Memo.t
+
 val available : Super_context.t -> dir:Path.Build.t -> bool Memo.t
 val where : Super_context.t -> loc:Loc.t option -> dir:Path.Build.t -> Path.t list Memo.t

src/dune_rules/melange/melobjinfo.ml

@@ -0,0 +1,12 @@
+open Import
+
+let rules program ~dir ~sandbox ~units =
+  let open Action_builder.O in
+  let action =
+    let+ action = Command.run' ?sandbox ~dir:(Path.build dir) program [ Deps units ] in
+    { Rule.Anonymous_action.action; loc = Loc.none; dir }
+  in
+  Build_system.execute_action_stdout action
+  |> Memo.map ~f:Ocamlobjinfo.parse
+  |> Action_builder.of_memo
+;;

src/dune_rules/melange/melobjinfo.mli

@@ -0,0 +1,8 @@
+open Import
+
+val rules
+  :  Action.Prog.t
+  -> dir:Path.Build.t
+  -> sandbox:Sandbox_config.t option
+  -> units:Path.t list
+  -> Ocamlobjinfo.t list Action_builder.t

src/dune_rules/ocamlobjinfo.mli

@@ -21,7 +21,8 @@ val archive_rules
   -> archive:Path.t
   -> Module_name.Unique.Set.t Action_builder.t
 
-(** For testing only *)
+(** Parse the output of an object-info tool that follows the [ocamlobjinfo]
+    format. *)
 val parse : string -> t list
 
 (** Parse archive output to extract module names defined in the archive *)

test/blackbox-tests/test-cases/melange/installed-virtual-lib-deps-melobjinfo-no-cmt.t

@@ -0,0 +1,115 @@
+When melobjinfo is available, Dune should prefer precise CMJ dependencies even
+when an installed Melange virtual library has no binary annotations.
+
+  $ mkdir -p producer/vlib consumer/impl fake-bin
+
+  $ cat > producer/dune-project <<'EOF'
+  > (lang dune 3.24)
+  > (using melange 1.0)
+  > (package (name repro))
+  > EOF
+  $ cat > producer/vlib/dune <<'EOF'
+  > (library
+  >  (name vlib)
+  >  (public_name repro.vlib)
+  >  (modes melange)
+  >  (private_modules helper unused)
+  >  (virtual_modules virt reverse))
+  > (env
+  >  (_
+  >   (bin_annot false)))
+  > EOF
+  $ cat > producer/vlib/virt.mli <<'EOF'
+  > val run : unit -> unit
+  > EOF
+  $ cat > producer/vlib/reverse.mli <<'EOF'
+  > val answer : int
+  > EOF
+  $ cat > producer/vlib/shared.ml <<'EOF'
+  > let answer = Helper.answer
+  > EOF
+  $ cat > producer/vlib/helper.ml <<'EOF'
+  > let answer = 42
+  > EOF
+  $ cat > producer/vlib/helper.mli <<'EOF'
+  > val answer : int
+  > EOF
+  $ cat > producer/vlib/unused.ml <<'EOF'
+  > let ignored = 0
+  > EOF
+
+  $ dune build --root producer @install
+  $ dune install --root producer --prefix "$PWD/prefix"
+  $ test ! -e "$PWD/prefix/lib/repro/vlib/melange/vlib__Shared.cmt"
+
+  $ cat > fake-bin/melobjinfo <<'EOF'
+  > #!/bin/sh
+  > for unit do
+  >   printf 'File %s\n' "$unit"
+  >   printf 'Implementations imported:\n'
+  >   case "$unit" in
+  >     *vlib__Shared.cmj)
+  >       printf '  --------------------------------  Vlib__Helper\n'
+  >       ;;
+  >   esac
+  > done
+  > EOF
+  $ chmod +x fake-bin/melobjinfo
+
+  $ cat > consumer/dune-project <<'EOF'
+  > (lang dune 3.24)
+  > (using melange 1.0)
+  > (package (name consumer))
+  > EOF
+  $ cat > consumer/impl/dune <<'EOF'
+  > (library
+  >  (name impl)
+  >  (public_name consumer.impl)
+  >  (modes melange)
+  >  (implements repro.vlib))
+  > EOF
+  $ cat > consumer/impl/virt.ml <<'EOF'
+  > let run () = ignore Shared.answer
+  > EOF
+  $ cat > consumer/impl/reverse.ml <<'EOF'
+  > let answer = Virt.run (); 0
+  > EOF
+  $ cat > consumer/dune <<'EOF'
+  > (melange.emit
+  >  (target output)
+  >  (emit_stdlib false)
+  >  (compile_flags :standard --mel-cross-module-opt)
+  >  (libraries impl))
+  > EOF
+
+melobjinfo is preferred over conservative staging, so unrelated Reverse and
+Unused objects are excluded even though CMTs are unavailable.
+
+  $ PATH="$PWD/fake-bin:$PATH" \
+  > OCAMLPATH="$PWD/prefix/lib:$OCAMLPATH" \
+  > dune build --root consumer --sandbox=symlink --trace-file "$PWD/trace" @melange
+  $ dune trace cat --trace-file "$PWD/trace" \
+  > | jq_dune -s \
+  >   '[.[] | processesBrief | select(.prog == "melobjinfo")] | length'
+  1
+
+  $ PATH="$PWD/fake-bin:$PATH" \
+  > OCAMLPATH="$PWD/prefix/lib:$OCAMLPATH" \
+  > dune rules --root consumer --recursive --format=json --deps --display=quiet \
+  > impl/.impl.objs/melange/vlib__Virt.cmj > deps.json
+  $ jq_dune -r '
+  >   [.[] | depsFilePaths
+  >    | select(endswith("vlib__Helper.cmi")
+  >             or endswith("vlib__Helper.cmj")
+  >             or endswith("vlib__Reverse.cmi")
+  >             or endswith("vlib__Reverse.cmj")
+  >             or endswith("vlib__Unused.cmi")
+  >             or endswith("vlib__Unused.cmj")
+  >             or endswith("vlib__Virt.cmi")
+  >             or endswith("vlib__Virt.cmj"))
+  >    | select(startswith("_build/default/impl/.impl.objs/melange/"))]
+  >   | unique[]
+  > ' deps.json
+  _build/default/impl/.impl.objs/melange/vlib__Helper.cmi
+  _build/default/impl/.impl.objs/melange/vlib__Helper.cmj
+  _build/default/impl/.impl.objs/melange/vlib__Virt.cmi