From 9cc4b9de969c43ba57693f3e2288069f0e7bbd33 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 11:10:19 +0000 Subject: [PATCH 1/4] Add failing fixture for functors constrained by a named module type Values in a functor body whose result is constrained to a module type defined in another module (via .mli or inline) are reported dead even when instances are used from live code. --- examples/deadcode/src/FunctorSigGen.ml | 12 +++++++++++ examples/deadcode/src/FunctorSigInline.ml | 9 ++++++++ examples/deadcode/src/FunctorSigMli.ml | 10 +++++++++ examples/deadcode/src/FunctorSigMli.mli | 3 +++ examples/deadcode/src/FunctorSigUse.ml | 12 +++++++++++ examples/deadcode/src/Main.ml | 1 + examples/deadcode/src/deadcode.txt | 26 ++++++++++++++++++++++- examples/deadcode/src/dune | 4 ++++ 8 files changed, 76 insertions(+), 1 deletion(-) create mode 100644 examples/deadcode/src/FunctorSigGen.ml create mode 100644 examples/deadcode/src/FunctorSigInline.ml create mode 100644 examples/deadcode/src/FunctorSigMli.ml create mode 100644 examples/deadcode/src/FunctorSigMli.mli create mode 100644 examples/deadcode/src/FunctorSigUse.ml diff --git a/examples/deadcode/src/FunctorSigGen.ml b/examples/deadcode/src/FunctorSigGen.ml new file mode 100644 index 00000000..e1d68a97 --- /dev/null +++ b/examples/deadcode/src/FunctorSigGen.ml @@ -0,0 +1,12 @@ +(* Named module types used as functor result signatures from other files. *) +module type S = sig + val find_opt : int -> int option + + val unused_in_sig : int -> int +end + +module type T = sig + val lookup : int -> int option + + val unused_in_inline_sig : int -> int +end diff --git a/examples/deadcode/src/FunctorSigInline.ml b/examples/deadcode/src/FunctorSigInline.ml new file mode 100644 index 00000000..46ae480c --- /dev/null +++ b/examples/deadcode/src/FunctorSigInline.ml @@ -0,0 +1,9 @@ +module Make (K : sig + type t +end) : FunctorSigGen.T = struct + let lookup k = Some k + + let unused_in_inline_sig k = k + + let truly_dead_inline k = k +end diff --git a/examples/deadcode/src/FunctorSigMli.ml b/examples/deadcode/src/FunctorSigMli.ml new file mode 100644 index 00000000..dc07fe15 --- /dev/null +++ b/examples/deadcode/src/FunctorSigMli.ml @@ -0,0 +1,10 @@ +module Make (K : sig + type t +end) = +struct + let find_opt k = Some k + + let unused_in_sig k = k + + let truly_dead k = k +end diff --git a/examples/deadcode/src/FunctorSigMli.mli b/examples/deadcode/src/FunctorSigMli.mli new file mode 100644 index 00000000..79b75666 --- /dev/null +++ b/examples/deadcode/src/FunctorSigMli.mli @@ -0,0 +1,3 @@ +module Make (K : sig + type t +end) : FunctorSigGen.S diff --git a/examples/deadcode/src/FunctorSigUse.ml b/examples/deadcode/src/FunctorSigUse.ml new file mode 100644 index 00000000..9b9269f7 --- /dev/null +++ b/examples/deadcode/src/FunctorSigUse.ml @@ -0,0 +1,12 @@ +module H = FunctorSigMli.Make (struct + type t = int +end) + +module I = FunctorSigInline.Make (struct + type t = int +end) + +let run () = + match (H.find_opt 1, I.lookup 2) with + | Some _, Some _ -> print_endline "x" + | _ -> () diff --git a/examples/deadcode/src/Main.ml b/examples/deadcode/src/Main.ml index eae14ea1..266a19e7 100644 --- a/examples/deadcode/src/Main.ml +++ b/examples/deadcode/src/Main.ml @@ -7,6 +7,7 @@ let () = ignore (Types.make_live 1); ignore TransitiveTypes.live_value; FirstClassModules.run (); + FunctorSigUse.run (); OptionalArgs.live_optional ~used:1 (); ignore (Externals.live_external "abc"); Annotations.live_value (); diff --git a/examples/deadcode/src/deadcode.txt b/examples/deadcode/src/deadcode.txt index c3c5bffa..a9da5274 100644 --- a/examples/deadcode/src/deadcode.txt +++ b/examples/deadcode/src/deadcode.txt @@ -41,6 +41,30 @@ <-- line 10 let run () = () [@@dead "DeadRunner.+run"] + Warning Dead Value + File "FunctorSigInline.ml", line 6, characters 2-32 + Make.+unused_in_inline_sig is never used + <-- line 6 + let unused_in_inline_sig k = k [@@dead "Make.+unused_in_inline_sig"] + + Warning Dead Value + File "FunctorSigInline.ml", line 8, characters 2-29 + Make.+truly_dead_inline is never used + <-- line 8 + let truly_dead_inline k = k [@@dead "Make.+truly_dead_inline"] + + Warning Dead Value + File "FunctorSigMli.ml", line 7, characters 2-25 + Make.+unused_in_sig is never used + <-- line 7 + let unused_in_sig k = k [@@dead "Make.+unused_in_sig"] + + Warning Dead Value + File "FunctorSigMli.ml", line 9, characters 2-22 + Make.+truly_dead is never used + <-- line 9 + let truly_dead k = k [@@dead "Make.+truly_dead"] + Warning Dead Value File "Includes.ml", line 4, characters 2-29 +included_unused is never used @@ -123,4 +147,4 @@ <-- line 4 | LiveA [@dead "live_variant.LiveA"] - Analysis reported 22 issues (Warning Dead Module:2, Warning Dead Type:5, Warning Dead Value:13, Warning Redundant Optional Argument:1, Warning Unused Argument:1) + Analysis reported 26 issues (Warning Dead Module:2, Warning Dead Type:5, Warning Dead Value:17, Warning Redundant Optional Argument:1, Warning Unused Argument:1) diff --git a/examples/deadcode/src/dune b/examples/deadcode/src/dune index b6b568be..08859067 100644 --- a/examples/deadcode/src/dune +++ b/examples/deadcode/src/dune @@ -6,6 +6,10 @@ Exceptions Externals FirstClassModules + FunctorSigGen + FunctorSigInline + FunctorSigMli + FunctorSigUse Includes Main ModuleAliases From 1878fc1ca47f6935b494dcde0d776b9a833e2fbe Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 11:13:10 +0000 Subject: [PATCH 2/4] 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. --- Changes.md | 4 ++++ src/Compat.ml | 60 +++++++++++++++++++++++++++++++++++++++++++++--- src/DeadValue.ml | 38 ++++++++++++++++++++++++++---- src/Reanalyze.ml | 5 +++- 4 files changed, 98 insertions(+), 9 deletions(-) diff --git a/Changes.md b/Changes.md index 0bbd7869..050b6ad8 100644 --- a/Changes.md +++ b/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. diff --git a/src/Compat.ml b/src/Compat.ml index ce228dee..9610e577 100644 --- a/src/Compat.ml +++ b/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 diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 62a7503d..2732b6a8 100644 --- a/src/DeadValue.ml +++ b/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 diff --git a/src/Reanalyze.ml b/src/Reanalyze.ml index d15c3ff2..630d8386 100644 --- a/src/Reanalyze.ml +++ b/src/Reanalyze.ml @@ -57,7 +57,9 @@ let processCmtFiles ~root = else if isCmtFile absDir then [absDir] else [] in - walkSubDirs "" |> List.iter (loadCmtFile ~cmtRoot:(Some root)) + let cmtFilePaths = walkSubDirs "" in + cmtFilePaths |> List.iter Compat.registerCmtFile; + cmtFilePaths |> List.iter (loadCmtFile ~cmtRoot:(Some root)) let runAnalysis ~root ~ppf = Log_.Color.setup (); @@ -65,6 +67,7 @@ let runAnalysis ~root ~ppf = processCmtFiles ~root; if runConfig.dce then ( + DeadValue.forceDelayedItems (); DeadException.forceDelayedItems (); DeadOptionalArgs.forceDelayedItems (); DeadCommon.reportDead ~checkOptionalArg:DeadOptionalArgs.check ppf; From f81371e06d8ed106cfd86163926cd32225473217 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 11:38:28 +0000 Subject: [PATCH 3/4] Address review: register all cmts up front, forward optional-arg calls - In ReScript project mode, collect the cmt files of every source directory before processing any, so declaration dependencies across directories resolve. - When forwarding references from a module-type val item onto its implementation, also forward the recorded optional-argument calls. Otherwise a call like H.f ~x:1 () through a constrained functor result would report x as never used. Covered by with_opt in the fixture. --- examples/deadcode/src/FunctorSigGen.ml | 2 ++ examples/deadcode/src/FunctorSigMli.ml | 2 ++ examples/deadcode/src/FunctorSigUse.ml | 1 + examples/deadcode/src/deadcode.txt | 6 +++++- src/DeadOptionalArgs.ml | 12 ++++++++++++ src/DeadValue.ml | 1 + 6 files changed, 23 insertions(+), 1 deletion(-) diff --git a/examples/deadcode/src/FunctorSigGen.ml b/examples/deadcode/src/FunctorSigGen.ml index e1d68a97..bc18cfb7 100644 --- a/examples/deadcode/src/FunctorSigGen.ml +++ b/examples/deadcode/src/FunctorSigGen.ml @@ -3,6 +3,8 @@ module type S = sig val find_opt : int -> int option val unused_in_sig : int -> int + + val with_opt : ?x:int -> unit -> int end module type T = sig diff --git a/examples/deadcode/src/FunctorSigMli.ml b/examples/deadcode/src/FunctorSigMli.ml index dc07fe15..d23d7e75 100644 --- a/examples/deadcode/src/FunctorSigMli.ml +++ b/examples/deadcode/src/FunctorSigMli.ml @@ -7,4 +7,6 @@ struct let unused_in_sig k = k let truly_dead k = k + + let with_opt ?(x = 0) () = x end diff --git a/examples/deadcode/src/FunctorSigUse.ml b/examples/deadcode/src/FunctorSigUse.ml index 9b9269f7..bb218f6e 100644 --- a/examples/deadcode/src/FunctorSigUse.ml +++ b/examples/deadcode/src/FunctorSigUse.ml @@ -7,6 +7,7 @@ module I = FunctorSigInline.Make (struct end) let run () = + ignore (H.with_opt ~x:1 ()); match (H.find_opt 1, I.lookup 2) with | Some _, Some _ -> print_endline "x" | _ -> () diff --git a/examples/deadcode/src/deadcode.txt b/examples/deadcode/src/deadcode.txt index a9da5274..b5b0a777 100644 --- a/examples/deadcode/src/deadcode.txt +++ b/examples/deadcode/src/deadcode.txt @@ -7,6 +7,10 @@ File "OptionalArgs.ml", line 1, characters 0-86 optional argument used of function +live_optional is always supplied (1 calls) + Warning Redundant Optional Argument + File "FunctorSigMli.ml", line 11, characters 2-30 + optional argument x of function Make.+with_opt is always supplied (1 calls) + Warning Dead Value File "Annotations.ml", line 5, characters 0-33 +stale_dead_annotation is never used @@ -147,4 +151,4 @@ <-- line 4 | LiveA [@dead "live_variant.LiveA"] - Analysis reported 26 issues (Warning Dead Module:2, Warning Dead Type:5, Warning Dead Value:17, Warning Redundant Optional Argument:1, Warning Unused Argument:1) + Analysis reported 27 issues (Warning Dead Module:2, Warning Dead Type:5, Warning Dead Value:17, Warning Redundant Optional Argument:2, Warning Unused Argument:1) diff --git a/src/DeadOptionalArgs.ml b/src/DeadOptionalArgs.ml index a5993c47..03da9d6b 100644 --- a/src/DeadOptionalArgs.ml +++ b/src/DeadOptionalArgs.ml @@ -61,6 +61,18 @@ let addReferences ~(locFrom : Location.t) ~(locTo : Location.t) ~path (argNamesMaybe |> String.concat ", ") (posFrom |> posToString)) +(* Calls recorded against a signature item that is not a declaration (e.g. a + [val] inside a named module type) are re-attributed to the implementation. + Must run before [forceDelayedItems]. *) +let forwardDelayedItems ~(posFrom : Lexing.position) ~(posTo : Lexing.position) + = + let forwarded = + !delayedItems + |> List.filter_map (fun item -> + if item.posTo = posFrom then Some {item with posTo} else None) + in + delayedItems := forwarded @ !delayedItems + let forceDelayedItems () = let items = !delayedItems |> List.rev in delayedItems := []; diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 2732b6a8..332b74b8 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -516,6 +516,7 @@ let processValueDependency 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. *) + DeadOptionalArgs.forwardDelayedItems ~posFrom ~posTo; ValueReferences.find posFrom |> PosSet.iter (fun posRef -> if posRef <> posTo then From dc2d4de2bb1fd96e9765c6e362fdc9a4ce103709 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 17 Sep 2026 10:03:03 +0000 Subject: [PATCH 4/4] Resolve same-named compilation units by interface digest The analysis root can contain several units with the same name (e.g. unwrapped libraries in different directories). Their declarations share uids, so merging every candidate into one table first-one-wins could resolve a functor's module type constraint to the wrong unit and leave a used value reported dead. Cross-unit lookups now keep one declaration table per candidate file, narrow the candidates down using the interface digest the importer recorded in cmt_imports, and consult every remaining candidate when the digest cannot disambiguate. Adds a regression fixture with two unwrapped libraries defining Dup_sig. --- examples/regression/dup_a/Dup_a_impl.ml | 9 ++ examples/regression/dup_a/Dup_a_use.ml | 6 + examples/regression/dup_a/Dup_sig.ml | 8 ++ examples/regression/dup_a/dune | 6 + examples/regression/dup_b/Dup_b_impl.ml | 11 ++ examples/regression/dup_b/Dup_b_use.ml | 6 + examples/regression/dup_b/Dup_sig.ml | 10 ++ examples/regression/dup_b/dune | 6 + scripts/run_integration_tests.js | 22 ++++ src/Compat.ml | 163 +++++++++++++++++------- 10 files changed, 200 insertions(+), 47 deletions(-) create mode 100644 examples/regression/dup_a/Dup_a_impl.ml create mode 100644 examples/regression/dup_a/Dup_a_use.ml create mode 100644 examples/regression/dup_a/Dup_sig.ml create mode 100644 examples/regression/dup_a/dune create mode 100644 examples/regression/dup_b/Dup_b_impl.ml create mode 100644 examples/regression/dup_b/Dup_b_use.ml create mode 100644 examples/regression/dup_b/Dup_sig.ml create mode 100644 examples/regression/dup_b/dune diff --git a/examples/regression/dup_a/Dup_a_impl.ml b/examples/regression/dup_a/Dup_a_impl.ml new file mode 100644 index 00000000..17d5f454 --- /dev/null +++ b/examples/regression/dup_a/Dup_a_impl.ml @@ -0,0 +1,9 @@ +module Make (K : sig + type t +end) : Dup_sig.S with type t = K.t = struct + type t = K.t + + let f x = x + + let g x = x +end diff --git a/examples/regression/dup_a/Dup_a_use.ml b/examples/regression/dup_a/Dup_a_use.ml new file mode 100644 index 00000000..5950b259 --- /dev/null +++ b/examples/regression/dup_a/Dup_a_use.ml @@ -0,0 +1,6 @@ +module M = Dup_a_impl.Make (struct + type t = int +end) + +let run () = M.f 1 +let () = ignore (run ()) diff --git a/examples/regression/dup_a/Dup_sig.ml b/examples/regression/dup_a/Dup_sig.ml new file mode 100644 index 00000000..a2618aa4 --- /dev/null +++ b/examples/regression/dup_a/Dup_sig.ml @@ -0,0 +1,8 @@ +(* Same compilation unit name as dup_b/Dup_sig.ml, different content. *) +module type S = sig + type t + + val f : t -> t + + val g : t -> t +end diff --git a/examples/regression/dup_a/dune b/examples/regression/dup_a/dune new file mode 100644 index 00000000..5b28eb9d --- /dev/null +++ b/examples/regression/dup_a/dune @@ -0,0 +1,6 @@ +(library + (name dup_a) + (wrapped false) + (modes byte) + (modules Dup_sig Dup_a_impl Dup_a_use) + (flags :standard -w -27-32-34-37-39 -bin-annot)) diff --git a/examples/regression/dup_b/Dup_b_impl.ml b/examples/regression/dup_b/Dup_b_impl.ml new file mode 100644 index 00000000..493f2f61 --- /dev/null +++ b/examples/regression/dup_b/Dup_b_impl.ml @@ -0,0 +1,11 @@ +module Make (K : sig + type t +end) : Dup_sig.S with type t = K.t = struct + type t = K.t + + let f x = x + + let g x = x + + let h x = x +end diff --git a/examples/regression/dup_b/Dup_b_use.ml b/examples/regression/dup_b/Dup_b_use.ml new file mode 100644 index 00000000..0b610339 --- /dev/null +++ b/examples/regression/dup_b/Dup_b_use.ml @@ -0,0 +1,6 @@ +module M = Dup_b_impl.Make (struct + type t = int +end) + +let run () = M.g 1 +let () = ignore (run ()) diff --git a/examples/regression/dup_b/Dup_sig.ml b/examples/regression/dup_b/Dup_sig.ml new file mode 100644 index 00000000..585f18e6 --- /dev/null +++ b/examples/regression/dup_b/Dup_sig.ml @@ -0,0 +1,10 @@ +(* Same compilation unit name as dup_a/Dup_sig.ml, different content. *) +module type S = sig + type t + + val f : t -> t + + val g : t -> t + + val h : t -> t +end diff --git a/examples/regression/dup_b/dune b/examples/regression/dup_b/dune new file mode 100644 index 00000000..fe436bc6 --- /dev/null +++ b/examples/regression/dup_b/dune @@ -0,0 +1,6 @@ +(library + (name dup_b) + (wrapped false) + (modes byte) + (modules Dup_sig Dup_b_impl Dup_b_use) + (flags :standard -w -27-32-34-37-39 -bin-annot)) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index d615ba48..eba51cfe 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -112,6 +112,28 @@ function runRegressionTests() { assertNotIncludes(output, "Dead Value +Local_side_effects.+_info"); assertNotIncludes(output, "Dead Value +Local_side_effects.+process"); assertNotIncludes(output, "Dead Value +Local_side_effects.+register"); + + // Two unwrapped libraries each define a `Dup_sig` compilation unit. The + // functor result constraints in dup_a and dup_b must resolve to their own + // Dup_sig, not to whichever one happens to be indexed first. + console.log(`${cwd}: reanalyze duplicate compilation unit assertions`); + const dupOutput = child_process.execFileSync( + reanalyzeFile, + ["-ci", "-debug", "-native-build-target", ".", "-dce-cmt", "_build/default"], + { + cwd, + encoding: "utf8", + } + ); + + assertIncludes(dupOutput, "Live Value +Dup_a_impl.Make.+f"); + assertIncludes(dupOutput, "Dead Value +Dup_a_impl.Make.+g"); + assertIncludes(dupOutput, "Dead Value +Dup_b_impl.Make.+f"); + assertIncludes(dupOutput, "Live Value +Dup_b_impl.Make.+g"); + assertIncludes(dupOutput, "Dead Value +Dup_b_impl.Make.+h"); + + assertNotIncludes(dupOutput, "Dead Value +Dup_a_impl.Make.+f"); + assertNotIncludes(dupOutput, "Dead Value +Dup_b_impl.Make.+g"); } function checkSetup() { diff --git a/src/Compat.ml b/src/Compat.ml index 9610e577..ef1d6538 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -326,66 +326,135 @@ let registerCmtFile path = 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 (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 - (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 _ -> ()) + (* The declarations of the file being processed and of its own interface. *) + let own_uid_to_decl = UidTbl.create 1024 in + UidTbl.iter (UidTbl.replace own_uid_to_decl) cmt_infos.cmt_uid_to_decl; + let read_cmt path = + if Sys.file_exists path then + try Some (Cmt_format.read_cmt path) with _ -> None + else None 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 -> [] + (match read_cmt ((cmtFilePath |> Filename.remove_extension) ^ ".cmti") with + | Some cmti_infos -> + UidTbl.iter + (fun uid decl -> + if not (UidTbl.mem own_uid_to_decl uid) then + UidTbl.replace own_uid_to_decl uid decl) + cmti_infos.cmt_uid_to_decl + | None -> ()); + (* Declarations of other compilation units, one table per candidate file. + The analysis root can contain several units with the same name (e.g. + unwrapped libraries in different directories), whose declarations share + uids. Candidates are narrowed down using the interface digest recorded + in the importer; when that is not possible every candidate is consulted, + so a reference is never dropped because the wrong unit was picked. *) + let loadedFiles : (string, Typedtree.item_declaration UidTbl.t option) Hashtbl.t + = + Hashtbl.create 16 + in + let decls_of_file path = + match Hashtbl.find_opt loadedFiles path with + | Some decls -> decls + | None -> + let decls = + match read_cmt path with + | Some infos -> Some infos.cmt_uid_to_decl + | None -> 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); - ]) + Hashtbl.replace loadedFiles path decls; + decls + in + let interface_digest_of_file path = + match read_cmt path with + | Some infos -> infos.cmt_interface_digest + | None -> None + in + let loadedUnits : (string, Typedtree.item_declaration UidTbl.t list) Hashtbl.t + = + Hashtbl.create 16 + in + let candidate_files 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 + indexed @ siblings + |> List.filter (fun path -> path <> cmtFilePath && Sys.file_exists path) + |> List.sort_uniq compare + in + let select_by_digest comp_unit files = + let digest = + match List.assoc_opt comp_unit cmt_infos.cmt_imports with + | Some (Some digest) -> Some digest + | _ -> None + in + match digest with + | None -> files + | Some digest -> ( + (* A .cmt compiled against an .mli carries no interface digest: the + digest is in the .cmti next to it. Group by stem so the whole unit + is kept when either file matches. *) + let stem path = Filename.remove_extension path in + let stems = files |> List.map stem |> List.sort_uniq compare in + let matching_stems = + stems + |> List.filter (fun stem -> + [".cmt"; ".cmti"] + |> List.exists (fun ext -> + interface_digest_of_file (stem ^ ext) = Some digest)) + in + match matching_stems with + | [] -> files + | _ -> files |> List.filter (fun path -> List.mem (stem path) matching_stems) + ) + in + let decls_of_unit comp_unit = + match Hashtbl.find_opt loadedUnits comp_unit with + | Some decls -> decls + | None -> + let decls = + candidate_files comp_unit |> select_by_digest comp_unit + |> List.filter_map decls_of_file in - List.iter add_uid_to_decl_from_cmt (indexed @ siblings)) + Hashtbl.replace loadedUnits comp_unit decls; + decls 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 + let locs_of_uid uid = + match UidTbl.find_opt own_uid_to_decl uid with + | Some item_decl -> Option.to_list (loc_of_value_decl item_decl) | 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 + | Shape.Uid.Item {comp_unit; _} -> + decls_of_unit comp_unit + |> List.filter_map (fun decls -> + match UidTbl.find_opt decls uid with + | Some item_decl -> loc_of_value_decl item_decl + | None -> None) + |> List.sort_uniq compare + | _ -> []) in cmt_infos.cmt_declaration_dependencies - |> filter_map (fun (_, uid_def, uid_decl) -> - match (loc_of_uid uid_def, loc_of_uid uid_decl) with - | Some def_loc, Some decl_loc -> Some (def_loc, decl_loc) - | _ -> None) + |> List.concat_map (fun (_, uid_def, uid_decl) -> + let decl_locs = locs_of_uid uid_decl in + locs_of_uid uid_def + |> List.concat_map (fun def_loc -> + decl_locs |> List.map (fun decl_loc -> (def_loc, decl_loc)))) #else let _ = cmtFilePath in cmt_infos.cmt_value_dependencies