Fix DCE false positives for functors constrained by a named module type

When a module or functor result is constrained to a module type defined
in another file (via .mli or inline), the typed tree's declaration
dependencies link each implementation value to the `val` item of that
module type, which lives in another compilation unit's cmt. The
extractor only loaded the local cmt and cmti, so those links were dropped
and every value in the functor body was reported dead.

- Index all cmt/cmti files by compilation unit up front and resolve
  foreign uids from them (OCaml 5.3+).
- Defer processing of value dependencies until all files are scanned.
  When the signature side is not a declaration (a `val` inside a named
  module type), forward the references made to it onto the
  implementation rather than treating it as an always-live reference,
  so unused items in the signature are still reported.

Author: JonoPrest

Changes.md

@@ -1,3 +1,7 @@
+# Unreleased
+
+- Fix false positives for values in functor bodies (and modules) constrained by a module type defined in another file, e.g. `module Make (K) : Gen.S with type key = K.t`. On OCaml 5.3+ declaration dependencies pointing at other compilation units are now resolved, and references to `val` items of a named module type are forwarded to the implementations satisfying it.
+
 # 2.26.0
 
 - Support OCaml 5.3, 5.4, and 5.5.

src/Compat.ml

@@ -303,26 +303,80 @@ let applyArgOfExpression e =
   Some e
 #endif
 
+(* Index of the .cmt/.cmti files under analysis, keyed by compilation unit
+   name. Populated before processing so declaration dependencies pointing at
+   other units (e.g. a functor result constrained by a module type defined in
+   another file) can be resolved regardless of processing order. *)
+let cmtFilesByUnit : (string, string list) Hashtbl.t = Hashtbl.create 256
+
+let unitNameOfCmtFile path =
+  path |> Filename.basename |> Filename.remove_extension
+  |> String.capitalize_ascii
+
+let registerCmtFile path =
+  let unit = unitNameOfCmtFile path in
+  let existing =
+    match Hashtbl.find_opt cmtFilesByUnit unit with
+    | Some paths -> paths
+    | None -> []
+  in
+  if not (List.mem path existing) then
+    Hashtbl.replace cmtFilesByUnit unit (path :: existing)
+
 let extractValueDependencies ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) =
 #if OCAML_VERSION >= (5, 3, 0)
   let module UidTbl = Shape.Uid.Tbl in
   let uid_to_decl = UidTbl.create 1024 in
   UidTbl.iter (UidTbl.replace uid_to_decl) cmt_infos.cmt_uid_to_decl;
+  let loadedFiles = Hashtbl.create 16 in
   let add_uid_to_decl_from_cmt path =
-    if Sys.file_exists path then
+    if (not (Hashtbl.mem loadedFiles path)) && Sys.file_exists path then (
+      Hashtbl.replace loadedFiles path ();
       try
         let cmt_infos = Cmt_format.read_cmt path in
-        UidTbl.iter (UidTbl.replace uid_to_decl) cmt_infos.cmt_uid_to_decl
-      with _ -> ()
+        UidTbl.iter
+          (fun uid decl ->
+            if not (UidTbl.mem uid_to_decl uid) then
+              UidTbl.replace uid_to_decl uid decl)
+          cmt_infos.cmt_uid_to_decl
+      with _ -> ())
   in
+  Hashtbl.replace loadedFiles cmtFilePath ();
   add_uid_to_decl_from_cmt
     ((cmtFilePath |> Filename.remove_extension) ^ ".cmti");
+  let loadedUnits = Hashtbl.create 16 in
+  let load_unit comp_unit =
+    if not (Hashtbl.mem loadedUnits comp_unit) then (
+      Hashtbl.replace loadedUnits comp_unit ();
+      let indexed =
+        match Hashtbl.find_opt cmtFilesByUnit comp_unit with
+        | Some paths -> paths
+        | None -> []
+      in
+      (* Fall back to sibling files, for callers that did not register. *)
+      let dir = Filename.dirname cmtFilePath in
+      let siblings =
+        [".cmt"; ".cmti"]
+        |> List.concat_map (fun ext ->
+               [
+                 Filename.concat dir (comp_unit ^ ext);
+                 Filename.concat dir (String.uncapitalize_ascii comp_unit ^ ext);
+               ])
+      in
+      List.iter add_uid_to_decl_from_cmt (indexed @ siblings))
+  in
   let loc_of_value_decl = function
     | Typedtree.Value {val_loc; _} -> Some val_loc
     | Typedtree.Value_binding {vb_pat = {pat_loc; _}; _} -> Some pat_loc
     | _ -> None
   in
   let loc_of_uid uid =
+    (match UidTbl.find_opt uid_to_decl uid with
+    | None -> (
+      match uid with
+      | Shape.Uid.Item {comp_unit; _} -> load_unit comp_unit
+      | _ -> ())
+    | Some _ -> ());
     match UidTbl.find_opt uid_to_decl uid with
     | Some item_decl -> loc_of_value_decl item_decl
     | None -> None

src/DeadValue.ml

@@ -509,14 +509,42 @@ let processValueDependency
     ({loc_start = {pos_fname = fnFrom} as posFrom; loc_ghost = ghost2} as
           locFrom :
       Location.t) ) =
-  if (not ghost1) && (not ghost2) && posTo <> posFrom then (
-    let addFileReference = fileIsImplementationOf fnTo fnFrom in
-    addValueReference ~addFileReference ~locFrom ~locTo;
-    DeadOptionalArgs.addFunctionReference ~locFrom ~locTo)
+  if (not ghost1) && (not ghost2) && posTo <> posFrom then
+    match PosHash.find_opt decls posFrom with
+    | None ->
+      (* The signature item is not a declaration (e.g. a [val] inside a named
+         module type used to constrain a module or functor result), so it can
+         never be resolved as dead. Forward the references made to the
+         signature item onto the implementation instead. *)
+      ValueReferences.find posFrom
+      |> PosSet.iter (fun posRef ->
+             if posRef <> posTo then
+               let locRef =
+                 {
+                   Location.loc_start = posRef;
+                   loc_end = posRef;
+                   loc_ghost = false;
+                 }
+               in
+               addValueReference ~addFileReference:true ~locFrom:locRef ~locTo)
+    | Some _ ->
+      let addFileReference = fileIsImplementationOf fnTo fnFrom in
+      addValueReference ~addFileReference ~locFrom ~locTo;
+      DeadOptionalArgs.addFunctionReference ~locFrom ~locTo
+
+(* Value dependencies are processed once all files have been scanned, so that
+   declarations and references from every file are known. *)
+let delayedValueDependencies = ref []
+
+let forceDelayedItems () =
+  let dependencies = List.rev !delayedValueDependencies in
+  delayedValueDependencies := [];
+  dependencies |> List.iter processValueDependency
 
 let processStructure ~cmt_value_dependencies ~doTypes ~doExternals
     (structure : Typedtree.structure) =
   let traverseStructure = traverseStructure ~doTypes ~doExternals in
   structure |> traverseStructure.structure traverseStructure |> ignore;
   let valueDependencies = cmt_value_dependencies |> List.rev in
-  valueDependencies |> List.iter processValueDependency
+  delayedValueDependencies :=
+    List.rev_append valueDependencies !delayedValueDependencies

src/Reanalyze.ml

@@ -43,6 +43,7 @@ let processCmtFiles ~cmtRoot =
     Filename.check_suffix path ".cmt" || Filename.check_suffix path ".cmti"
   in
   let processCmtFilePaths cmtFilePaths =
+    cmtFilePaths |> List.iter Compat.registerCmtFile;
     cmtFilePaths |> List.iter (loadCmtFile ~cmtRoot)
   in
   match cmtRoot with
@@ -88,6 +89,7 @@ let runAnalysis ~cmtRoot ~ppf =
 
   processCmtFiles ~cmtRoot;
   if runConfig.dce then (
+    DeadValue.forceDelayedItems ();
     DeadException.forceDelayedItems ();
     DeadOptionalArgs.forceDelayedItems ();
     DeadCommon.reportDead ~checkOptionalArg:DeadOptionalArgs.check ppf;