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/examples/deadcode/src/FunctorSigGen.ml b/examples/deadcode/src/FunctorSigGen.ml new file mode 100644 index 00000000..bc18cfb7 --- /dev/null +++ b/examples/deadcode/src/FunctorSigGen.ml @@ -0,0 +1,14 @@ +(* 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 + + val with_opt : ?x:int -> unit -> 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..d23d7e75 --- /dev/null +++ b/examples/deadcode/src/FunctorSigMli.ml @@ -0,0 +1,12 @@ +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 + + let with_opt ?(x = 0) () = x +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..bb218f6e --- /dev/null +++ b/examples/deadcode/src/FunctorSigUse.ml @@ -0,0 +1,13 @@ +module H = FunctorSigMli.Make (struct + type t = int +end) + +module I = FunctorSigInline.Make (struct + type t = int +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/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..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 @@ -41,6 +45,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 +151,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 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/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 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 ce228dee..ef1d6538 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -303,35 +303,158 @@ 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 add_uid_to_decl_from_cmt path = + (* 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 - let cmt_infos = Cmt_format.read_cmt path in - UidTbl.iter (UidTbl.replace uid_to_decl) cmt_infos.cmt_uid_to_decl - with _ -> () + try Some (Cmt_format.read_cmt path) with _ -> None + else None + in + (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 + 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 + Hashtbl.replace loadedUnits comp_unit decls; + decls in - add_uid_to_decl_from_cmt - ((cmtFilePath |> Filename.remove_extension) ^ ".cmti"); 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 - | Some item_decl -> loc_of_value_decl item_decl - | None -> None + 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; _} -> + 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 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 62a7503d..332b74b8 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -509,14 +509,43 @@ 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. *) + DeadOptionalArgs.forwardDelayedItems ~posFrom ~posTo; + 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;