From 8a91d960a0b9ab5c6e4f0da2f47e79daea9f5a3c Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 11:54:43 +0000 Subject: [PATCH 01/53] Resolve identifier occurrences through shapes for precise attribution Forwarding references from a module type's val item to its implementations keeps every implementation of a shared signature live when only one is used. Instead, reduce each cross-unit identifier occurrence via Shape_reduce with a loader over the indexed cmt files, and reference the resolved implementation directly. The decision is deferred until all declarations are known so that references to .mli declarations are kept as before. The forwarding remains as a conservative fallback for occurrences the reducer cannot resolve. Adds FunctorSigOther: a second functor over the same module type that is never instantiated and must be reported dead. --- examples/deadcode/src/FunctorSigOther.ml | 11 + examples/deadcode/src/deadcode.txt | 24 +- examples/deadcode/src/dune | 1 + src/Compat.ml | 269 ++++++++++++----------- src/DeadCode.ml | 5 +- src/DeadOptionalArgs.ml | 20 +- src/DeadValue.ml | 67 +++++- 7 files changed, 254 insertions(+), 143 deletions(-) create mode 100644 examples/deadcode/src/FunctorSigOther.ml diff --git a/examples/deadcode/src/FunctorSigOther.ml b/examples/deadcode/src/FunctorSigOther.ml new file mode 100644 index 00000000..81ad4532 --- /dev/null +++ b/examples/deadcode/src/FunctorSigOther.ml @@ -0,0 +1,11 @@ +(* Constrained by the same module type as FunctorSigMli.Make, but never + instantiated: calls through FunctorSigMli instances must not keep it live. *) +module Make (K : sig + type t +end) : FunctorSigGen.S = struct + let find_opt k = Some k + + let unused_in_sig k = k + + let with_opt ?(x = 0) () = x +end diff --git a/examples/deadcode/src/deadcode.txt b/examples/deadcode/src/deadcode.txt index b5b0a777..d42cb3af 100644 --- a/examples/deadcode/src/deadcode.txt +++ b/examples/deadcode/src/deadcode.txt @@ -69,6 +69,28 @@ <-- line 9 let truly_dead k = k [@@dead "Make.+truly_dead"] + Warning Dead Module + File "FunctorSigOther.ml", line 3, characters 0-150 + +FunctorSigOther.Make is a dead module as all its items are dead. + + Warning Dead Value + File "FunctorSigOther.ml", line 6, characters 2-25 + Make.+find_opt is never used + <-- line 6 + let find_opt k = Some k [@@dead "Make.+find_opt"] + + Warning Dead Value + File "FunctorSigOther.ml", line 8, characters 2-25 + Make.+unused_in_sig is never used + <-- line 8 + let unused_in_sig k = k [@@dead "Make.+unused_in_sig"] + + Warning Dead Value + File "FunctorSigOther.ml", line 10, characters 2-30 + Make.+with_opt is never used + <-- line 10 + let with_opt ?(x = 0) () = x [@@dead "Make.+with_opt"] + Warning Dead Value File "Includes.ml", line 4, characters 2-29 +included_unused is never used @@ -151,4 +173,4 @@ <-- line 4 | LiveA [@dead "live_variant.LiveA"] - 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) + Analysis reported 31 issues (Warning Dead Module:3, Warning Dead Type:5, Warning Dead Value:20, Warning Redundant Optional Argument:2, Warning Unused Argument:1) diff --git a/examples/deadcode/src/dune b/examples/deadcode/src/dune index 08859067..45ed8206 100644 --- a/examples/deadcode/src/dune +++ b/examples/deadcode/src/dune @@ -9,6 +9,7 @@ FunctorSigGen FunctorSigInline FunctorSigMli + FunctorSigOther FunctorSigUse Includes Main diff --git a/src/Compat.ml b/src/Compat.ml index ef1d6538..2388a82e 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -304,9 +304,10 @@ let applyArgOfExpression 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. *) + name. Populated before processing so declaration dependencies and identifier + occurrences 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 = @@ -323,141 +324,147 @@ let registerCmtFile path = 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 - (* 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 - (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 - let loc_of_value_decl = function - | Typedtree.Value {val_loc; _} -> Some val_loc - | Typedtree.Value_binding {vb_pat = {pat_loc; _}; _} -> Some pat_loc - | _ -> None +(* Per compilation unit: the implementation shape (from the .cmt) and the + uid -> declaration table (merged from .cmt and .cmti). Loaded on demand. *) +type unitInfo = { + shape : Shape.t option; + uidToDecl : Typedtree.item_declaration Shape.Uid.Tbl.t; +} + +let unitInfoCache : (string, unitInfo) Hashtbl.t = Hashtbl.create 64 + +let candidateFilesForUnit ~currentCmtFile comp_unit = + let indexed = + match Hashtbl.find_opt cmtFilesByUnit comp_unit with + | Some paths -> paths + | None -> [] in - 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 - | _ -> []) + (* Fall back to sibling files, for callers that did not register. *) + let dir = Filename.dirname currentCmtFile 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 Sys.file_exists |> List.sort_uniq compare + +let loadUnitInfo ~currentCmtFile comp_unit = + match Hashtbl.find_opt unitInfoCache comp_unit with + | Some info -> Some info + | None -> ( + let files = candidateFilesForUnit ~currentCmtFile comp_unit in + match files with + | [] -> None + | _ -> + let uidToDecl = Shape.Uid.Tbl.create 64 in + let shape = ref None in + files + |> List.iter (fun path -> + try + let cmt_infos = Cmt_format.read_cmt path in + Shape.Uid.Tbl.iter + (fun uid decl -> + if not (Shape.Uid.Tbl.mem uidToDecl uid) then + Shape.Uid.Tbl.replace uidToDecl uid decl) + cmt_infos.cmt_uid_to_decl; + match (!shape, cmt_infos.cmt_impl_shape) with + | None, Some _ -> shape := cmt_infos.cmt_impl_shape + | _ -> () + with _ -> ()); + let info = {shape = !shape; uidToDecl} in + Hashtbl.replace unitInfoCache comp_unit info; + Some info) + +let locOfItemDeclaration = function + | Typedtree.Value {val_loc; _} -> Some val_loc + | Typedtree.Value_binding {vb_pat = {pat_loc; _}; _} -> Some pat_loc + | _ -> None + +let locOfUid ~currentCmtFile ~(local : Typedtree.item_declaration Shape.Uid.Tbl.t) + uid = + match Shape.Uid.Tbl.find_opt local uid with + | Some decl -> locOfItemDeclaration decl + | None -> ( + match uid with + | Shape.Uid.Item {comp_unit; _} -> ( + match loadUnitInfo ~currentCmtFile comp_unit with + | Some {uidToDecl} -> ( + match Shape.Uid.Tbl.find_opt uidToDecl uid with + | Some decl -> locOfItemDeclaration decl + | None -> None) + | None -> None) + | _ -> None) +#endif + +let extractValueDependencies ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) = +#if OCAML_VERSION >= (5, 3, 0) + let local = Shape.Uid.Tbl.create 1024 in + Shape.Uid.Tbl.iter (Shape.Uid.Tbl.replace local) cmt_infos.cmt_uid_to_decl; + (let cmti = (cmtFilePath |> Filename.remove_extension) ^ ".cmti" in + if Sys.file_exists cmti then + try + let cmti_infos = Cmt_format.read_cmt cmti in + Shape.Uid.Tbl.iter + (fun uid decl -> + if not (Shape.Uid.Tbl.mem local uid) then + Shape.Uid.Tbl.replace local uid decl) + cmti_infos.cmt_uid_to_decl + with _ -> ()); + let loc_of_uid = locOfUid ~currentCmtFile:cmtFilePath ~local in cmt_infos.cmt_declaration_dependencies - |> 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)))) + |> 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) #else let _ = cmtFilePath in cmt_infos.cmt_value_dependencies |> List.map (fun (valueTo, valueFrom) -> (valueTo.Types.val_loc, valueFrom.Types.val_loc)) #endif + +(* Identifier occurrences whose definition lives in another compilation unit + (e.g. [Inst.H.find_opt] where [H] is an instance of a functor constrained by + a named module type) are reduced through the shapes of the other units, so + references land on the implementation rather than on the module type item. + Returns a table from the occurrence's start position to the implementation + location. *) +let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : + (Lexing.position, Location.t) Hashtbl.t = + let table = Hashtbl.create 64 in +#if OCAML_VERSION >= (5, 3, 0) + let module Reduce = Shape_reduce.Make (struct + let fuel = 10 + + let read_unit_shape ~unit_name = + match loadUnitInfo ~currentCmtFile:cmtFilePath unit_name with + | Some {shape} -> shape + | None -> None + end) in + let local = cmt_infos.cmt_uid_to_decl in + let rec uidOfResult (result : Shape_reduce.result) = + match result with + | Resolved uid -> Some uid + | Resolved_alias (_, result) -> uidOfResult result + | _ -> None + in + cmt_infos.cmt_ident_occurrences + |> List.iter (fun ((lid : Longident.t Location.loc), result) -> + match result with + | Shape_reduce.Unresolved shape when not lid.loc.loc_ghost -> ( + match Reduce.reduce_for_uid Env.empty shape |> uidOfResult with + | Some uid -> ( + match locOfUid ~currentCmtFile:cmtFilePath ~local uid with + | Some loc when not loc.loc_ghost -> + Hashtbl.replace table lid.loc.loc_start loc + | _ -> ()) + | None -> ()) + | _ -> ()); +#else + let _ = (cmtFilePath, cmt_infos) in +#endif + table diff --git a/src/DeadCode.ml b/src/DeadCode.ml index ee77c7dc..ca9b5913 100644 --- a/src/DeadCode.ml +++ b/src/DeadCode.ml @@ -28,8 +28,11 @@ let processCmt ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) = let cmt_value_dependencies = Compat.extractValueDependencies ~cmtFilePath cmt_infos in + let cmt_ident_resolutions = + Compat.resolveIdentOccurrences ~cmtFilePath cmt_infos + in DeadValue.processStructure ~doTypes:true ~doExternals - ~cmt_value_dependencies structure + ~cmt_value_dependencies ~cmt_ident_resolutions structure | _ -> ()); DeadType.TypeDependencies.forceDelayedItems (); DeadType.TypeDependencies.clear () diff --git a/src/DeadOptionalArgs.ml b/src/DeadOptionalArgs.ml index 03da9d6b..02a69b81 100644 --- a/src/DeadOptionalArgs.ml +++ b/src/DeadOptionalArgs.ml @@ -5,6 +5,8 @@ let active () = true type item = { posTo : Lexing.position; + posToImpl : Lexing.position option; + (** Shape-resolved implementation, used when [posTo] is not a declaration. *) argNames : string list; argNamesMaybe : string list; } @@ -46,12 +48,13 @@ let rec fromTypeExpr (texpr : Types.type_expr) = | Tsubst _ -> fromTypeExpr (Compat.getTSubst (Compat.get_desc texpr)) | _ -> [] -let addReferences ~(locFrom : Location.t) ~(locTo : Location.t) ~path - (argNames, argNamesMaybe) = +let addReferences ~(locFrom : Location.t) ~(locTo : Location.t) + ?(locToImpl : Location.t option) ~path (argNames, argNamesMaybe) = if active () then ( let posTo = locTo.loc_start in + let posToImpl = Option.map (fun (l : Location.t) -> l.loc_start) locToImpl in let posFrom = locFrom.loc_start in - delayedItems := {posTo; argNames; argNamesMaybe} :: !delayedItems; + delayedItems := {posTo; posToImpl; argNames; argNamesMaybe} :: !delayedItems; if !Common.Cli.debug then Log_.item "DeadOptionalArgs.addReferences %s called with optional argNames:%s \ @@ -61,6 +64,17 @@ let addReferences ~(locFrom : Location.t) ~(locTo : Location.t) ~path (argNamesMaybe |> String.concat ", ") (posFrom |> posToString)) +(* Once all declarations are known, calls whose target is not a declaration + but have a shape-resolved implementation are attributed to it. Must run + before [forwardDelayedItems] and [forceDelayedItems]. *) +let settleDelayedItems () = + delayedItems := + !delayedItems + |> List.map (fun item -> + match (item.posToImpl, PosHash.find_opt decls item.posTo) with + | Some posToImpl, None -> {item with posTo = posToImpl; posToImpl = None} + | _ -> item) + (* 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]. *) diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 332b74b8..4e51dd1d 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -95,7 +95,8 @@ let collectValueBinding super self (vb : Typedtree.value_binding) = Current.lastBinding := oldLastBinding; r -let processOptionalArgs ~expType ~(locFrom : Location.t) ~locTo ~path args = +let processOptionalArgs ~expType ~(locFrom : Location.t) ~locTo ?locToImpl + ~path args = let args = List.map (fun (lbl, arg) -> (lbl, Compat.applyArgToOption arg)) args in @@ -127,7 +128,41 @@ let processOptionalArgs ~expType ~(locFrom : Location.t) ~locTo ~path args = if argIsSupplied = None then suppliedMaybe := s :: !suppliedMaybe | _ -> ()); (!supplied, !suppliedMaybe) - |> DeadOptionalArgs.addReferences ~locFrom ~locTo ~path) + |> DeadOptionalArgs.addReferences ~locFrom ~locTo ?locToImpl ~path) + +(* Occurrence start position -> implementation location, for identifiers + resolved through other compilation units' shapes. See + [Compat.resolveIdentOccurrences]. *) +let identResolutions : (Lexing.position, Location.t) Hashtbl.t ref = + ref (Hashtbl.create 1) + +(* References whose target may be redirected to a shape-resolved + implementation. Decided in [forceDelayedItems], once every declaration is + known: if the original target is a declaration (e.g. a [val] in an .mli), it + is kept, otherwise the implementation is referenced. *) +type redirectedReference = { + locFrom : Location.t; + locTo : Location.t; + locToImpl : Location.t; +} + +let delayedRedirects : redirectedReference list ref = ref [] + +let findResolution ~(identLoc : Location.t) = + Hashtbl.find_opt !identResolutions identLoc.loc_start + +let addValueReferenceOrRedirect ~(locFrom : Location.t) ~(locTo : Location.t) = + match findResolution ~identLoc:locFrom with + | Some locToImpl when locToImpl.loc_start <> locTo.loc_start -> + let lastBinding = !Current.lastBinding in + let locFrom = + match lastBinding = Location.none with + | true -> locFrom + | false -> lastBinding + in + if not locFrom.loc_ghost then + delayedRedirects := {locFrom; locTo; locToImpl} :: !delayedRedirects + | _ -> addValueReference ~addFileReference:true ~locFrom ~locTo let rec collectExpr super self (e : Typedtree.expression) = let locFrom = e.exp_loc in @@ -143,19 +178,21 @@ let rec collectExpr super self (e : Typedtree.expression) = (Location.none.loc_start |> posToString) (locTo.loc_start |> posToString); ValueReferences.add locTo.loc_start Location.none.loc_start) - else addValueReference ~addFileReference:true ~locFrom ~locTo + else addValueReferenceOrRedirect ~locFrom ~locTo | Texp_apply ( { exp_desc = Texp_ident (path, _, {Types.val_loc = {loc_ghost = false; _} as locTo}); exp_type; + exp_loc = identLoc; }, args ) -> + let locToImpl = findResolution ~identLoc in args |> processOptionalArgs ~expType:exp_type ~locFrom:(locFrom : Location.t) - ~locTo ~path + ~locTo ?locToImpl ~path | Texp_let ( (* generated for functions with optional args *) Nonrecursive, @@ -515,7 +552,10 @@ let processValueDependency (* 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. *) + signature item onto the implementation instead. Occurrences resolved + through shapes already point at the implementation and are not in + this set; this is the conservative fallback for the rest, and keeps + every implementation of the item live. *) DeadOptionalArgs.forwardDelayedItems ~posFrom ~posTo; ValueReferences.find posFrom |> PosSet.iter (fun posRef -> @@ -538,14 +578,27 @@ let processValueDependency let delayedValueDependencies = ref [] let forceDelayedItems () = + let redirects = List.rev !delayedRedirects in + delayedRedirects := []; + redirects + |> List.iter (fun {locFrom; locTo; locToImpl} -> + let locTo = + match PosHash.find_opt decls locTo.loc_start with + | Some _ -> locTo + | None -> locToImpl + in + addValueReference ~addFileReference:true ~locFrom ~locTo); + DeadOptionalArgs.settleDelayedItems (); let dependencies = List.rev !delayedValueDependencies in delayedValueDependencies := []; dependencies |> List.iter processValueDependency -let processStructure ~cmt_value_dependencies ~doTypes ~doExternals - (structure : Typedtree.structure) = +let processStructure ~cmt_value_dependencies ~cmt_ident_resolutions ~doTypes + ~doExternals (structure : Typedtree.structure) = let traverseStructure = traverseStructure ~doTypes ~doExternals in + identResolutions := cmt_ident_resolutions; structure |> traverseStructure.structure traverseStructure |> ignore; + identResolutions := Hashtbl.create 1; let valueDependencies = cmt_value_dependencies |> List.rev in delayedValueDependencies := List.rev_append valueDependencies !delayedValueDependencies From 2bfc7c6dfe116e2bac735c2fc7a15b8b35acc1de Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 12:03:40 +0000 Subject: [PATCH 02/53] Move shared-signature case to version-gated regression test Precise attribution through a shared named module type relies on shape reduction of cmt_ident_occurrences, available from OCaml 5.3. On earlier versions the conservative forwarding applies, as it did before this change, so the deadcode fixture (whose expected output is shared across all supported versions) cannot contain the case. Assert it in the regression suite only on OCaml >= 5.3. --- examples/deadcode/src/FunctorSigOther.ml | 11 --------- examples/deadcode/src/deadcode.txt | 24 +------------------ examples/deadcode/src/dune | 1 - examples/regression/src/Main.ml | 3 ++- examples/regression/src/Shared_signature.ml | 6 +++++ .../regression/src/Shared_signature_unused.ml | 5 ++++ .../regression/src/Shared_signature_use.ml | 5 ++++ .../regression/src/Shared_signature_used.ml | 5 ++++ examples/regression/src/dune | 6 ++++- scripts/run_integration_tests.js | 22 +++++++++++++++++ 10 files changed, 51 insertions(+), 37 deletions(-) delete mode 100644 examples/deadcode/src/FunctorSigOther.ml create mode 100644 examples/regression/src/Shared_signature.ml create mode 100644 examples/regression/src/Shared_signature_unused.ml create mode 100644 examples/regression/src/Shared_signature_use.ml create mode 100644 examples/regression/src/Shared_signature_used.ml diff --git a/examples/deadcode/src/FunctorSigOther.ml b/examples/deadcode/src/FunctorSigOther.ml deleted file mode 100644 index 81ad4532..00000000 --- a/examples/deadcode/src/FunctorSigOther.ml +++ /dev/null @@ -1,11 +0,0 @@ -(* Constrained by the same module type as FunctorSigMli.Make, but never - instantiated: calls through FunctorSigMli instances must not keep it live. *) -module Make (K : sig - type t -end) : FunctorSigGen.S = struct - let find_opt k = Some k - - let unused_in_sig k = k - - let with_opt ?(x = 0) () = x -end diff --git a/examples/deadcode/src/deadcode.txt b/examples/deadcode/src/deadcode.txt index d42cb3af..b5b0a777 100644 --- a/examples/deadcode/src/deadcode.txt +++ b/examples/deadcode/src/deadcode.txt @@ -69,28 +69,6 @@ <-- line 9 let truly_dead k = k [@@dead "Make.+truly_dead"] - Warning Dead Module - File "FunctorSigOther.ml", line 3, characters 0-150 - +FunctorSigOther.Make is a dead module as all its items are dead. - - Warning Dead Value - File "FunctorSigOther.ml", line 6, characters 2-25 - Make.+find_opt is never used - <-- line 6 - let find_opt k = Some k [@@dead "Make.+find_opt"] - - Warning Dead Value - File "FunctorSigOther.ml", line 8, characters 2-25 - Make.+unused_in_sig is never used - <-- line 8 - let unused_in_sig k = k [@@dead "Make.+unused_in_sig"] - - Warning Dead Value - File "FunctorSigOther.ml", line 10, characters 2-30 - Make.+with_opt is never used - <-- line 10 - let with_opt ?(x = 0) () = x [@@dead "Make.+with_opt"] - Warning Dead Value File "Includes.ml", line 4, characters 2-29 +included_unused is never used @@ -173,4 +151,4 @@ <-- line 4 | LiveA [@dead "live_variant.LiveA"] - Analysis reported 31 issues (Warning Dead Module:3, Warning Dead Type:5, Warning Dead Value:20, Warning Redundant Optional Argument:2, 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 45ed8206..08859067 100644 --- a/examples/deadcode/src/dune +++ b/examples/deadcode/src/dune @@ -9,7 +9,6 @@ FunctorSigGen FunctorSigInline FunctorSigMli - FunctorSigOther FunctorSigUse Includes Main diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 41f2ad56..44d188e7 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -5,4 +5,5 @@ let () = Functor_argument.use_set (); Functor_argument.use_anonymous_set (); Local_side_effects.start (); - Ocaml_compiler_compat.run () + Ocaml_compiler_compat.run (); + Shared_signature_use.run () diff --git a/examples/regression/src/Shared_signature.ml b/examples/regression/src/Shared_signature.ml new file mode 100644 index 00000000..ab70c670 --- /dev/null +++ b/examples/regression/src/Shared_signature.ml @@ -0,0 +1,6 @@ +(* A named module type shared by two functors. Only [Used] is instantiated, so + [Unused.Make.f] must be reported dead: a call through [Used]'s instance must + not keep [Unused]'s implementation alive. *) +module type S = sig + val f : unit -> int +end diff --git a/examples/regression/src/Shared_signature_unused.ml b/examples/regression/src/Shared_signature_unused.ml new file mode 100644 index 00000000..27c4788d --- /dev/null +++ b/examples/regression/src/Shared_signature_unused.ml @@ -0,0 +1,5 @@ +module Make (K : sig + type t +end) : Shared_signature.S = struct + let f () = 2 +end diff --git a/examples/regression/src/Shared_signature_use.ml b/examples/regression/src/Shared_signature_use.ml new file mode 100644 index 00000000..94ce2551 --- /dev/null +++ b/examples/regression/src/Shared_signature_use.ml @@ -0,0 +1,5 @@ +module H = Shared_signature_used.Make (struct + type t = int +end) + +let run () = ignore (H.f ()) diff --git a/examples/regression/src/Shared_signature_used.ml b/examples/regression/src/Shared_signature_used.ml new file mode 100644 index 00000000..e538392e --- /dev/null +++ b/examples/regression/src/Shared_signature_used.ml @@ -0,0 +1,5 @@ +module Make (K : sig + type t +end) : Shared_signature.S = struct + let f () = 1 +end diff --git a/examples/regression/src/dune b/examples/regression/src/dune index 097f5580..53e38b73 100644 --- a/examples/regression/src/dune +++ b/examples/regression/src/dune @@ -6,5 +6,9 @@ Live_ancestors Local_side_effects Main - Ocaml_compiler_compat) + Ocaml_compiler_compat + Shared_signature + Shared_signature_unused + Shared_signature_use + Shared_signature_used) (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 eba51cfe..68cc5178 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -70,6 +70,16 @@ function assertNotIncludes(output, unexpected) { } } +function ocamlVersionAtLeast(major, minor) { + const version = child_process + .execFileSync("ocamlc", ["-version"], { encoding: "utf8" }) + .trim(); + const [actualMajor, actualMinor] = version.split(".").map(Number); + return ( + actualMajor > major || (actualMajor === major && actualMinor >= minor) + ); +} + function runRegressionTests() { const cwd = path.join(__dirname, "..", "examples", "regression"); const cmtDir = "_build/default/src/.regression_fixture.objs/byte"; @@ -104,6 +114,18 @@ function runRegressionTests() { assertIncludes(output, "Live Value +Local_side_effects.+process"); assertIncludes(output, "Live Value +Local_side_effects.+register"); + // A call through one functor instance must never mark the used + // implementation dead. + assertIncludes(output, "Live Value +Shared_signature_used.Make.+f"); + assertNotIncludes(output, "Dead Value +Shared_signature_used.Make.+f"); + // Precise attribution through a shared named module type relies on shape + // reduction of identifier occurrences, available from OCaml 5.3. Earlier + // versions conservatively keep every implementation of the item live. + if (ocamlVersionAtLeast(5, 3)) { + assertIncludes(output, "Dead Value +Shared_signature_unused.Make.+f"); + assertNotIncludes(output, "Live Value +Shared_signature_unused.Make.+f"); + } + assertNotIncludes(output, "Parent is a dead module"); assertNotIncludes(output, "Dead Value +Functor_argument.Ordered.+compare"); assertNotIncludes(output, "Live Value +Functor_argument.Ordered.+unused"); From fead8d2559805d99aa7c6b3146094198bfc40db9 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 12:17:15 +0000 Subject: [PATCH 03/53] Address review: shape-resolve functor arguments, key occurrences precisely - Key identifier resolutions by full location and last name component, so distinct identifiers a ppx emits at the same position do not collide. - Also use occurrences the compiler resolved locally, so modules defined in the same file as their use are attributed precisely. - Route functor argument coercions (Tmod_apply) through the argument module's shape, so passing one of several modules implementing a shared named signature only credits that module. - Never forward references made through a functor parameter to the implementations of the module type item: the application sites credit the actual arguments. First-class module uses still fall back to forwarding. Regression cases: Shared_signature_arg covers the functor argument and same-file module cases. --- examples/regression/src/Main.ml | 3 +- .../regression/src/Shared_signature_arg.ml | 26 +++ examples/regression/src/dune | 1 + scripts/run_integration_tests.js | 8 + src/Compat.ml | 125 ++++++++++++--- src/DeadValue.ml | 149 +++++++++++++----- 6 files changed, 253 insertions(+), 59 deletions(-) create mode 100644 examples/regression/src/Shared_signature_arg.ml diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 44d188e7..3c4cf3cf 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -6,4 +6,5 @@ let () = Functor_argument.use_anonymous_set (); Local_side_effects.start (); Ocaml_compiler_compat.run (); - Shared_signature_use.run () + Shared_signature_use.run (); + Shared_signature_arg.run () diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml new file mode 100644 index 00000000..b4fc0f47 --- /dev/null +++ b/examples/regression/src/Shared_signature_arg.ml @@ -0,0 +1,26 @@ +(* Two modules implement the shared named signature; only [Chosen] is passed + to a functor. [Ignored.f] must be reported dead. *) +module Chosen : Shared_signature.S = struct + let f () = 3 +end + +module Ignored : Shared_signature.S = struct + let f () = 4 +end + +module Apply (M : Shared_signature.S) = struct + let run () = M.f () +end + +module Applied = Apply (Chosen) + +(* Same, but the module is used directly from the same file. *) +module Local_used : Shared_signature.S = struct + let f () = 5 +end + +module Local_unused : Shared_signature.S = struct + let f () = 6 +end + +let run () = ignore (Applied.run () + Local_used.f ()) diff --git a/examples/regression/src/dune b/examples/regression/src/dune index 53e38b73..7cb6ca6f 100644 --- a/examples/regression/src/dune +++ b/examples/regression/src/dune @@ -8,6 +8,7 @@ Main Ocaml_compiler_compat Shared_signature + Shared_signature_arg Shared_signature_unused Shared_signature_use Shared_signature_used) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index 68cc5178..a42eda66 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -118,12 +118,20 @@ function runRegressionTests() { // implementation dead. assertIncludes(output, "Live Value +Shared_signature_used.Make.+f"); assertNotIncludes(output, "Dead Value +Shared_signature_used.Make.+f"); + assertIncludes(output, "Live Value +Shared_signature_arg.Chosen.+f"); + assertNotIncludes(output, "Dead Value +Shared_signature_arg.Chosen.+f"); + assertIncludes(output, "Live Value +Shared_signature_arg.Local_used.+f"); + assertNotIncludes(output, "Dead Value +Shared_signature_arg.Local_used.+f"); // Precise attribution through a shared named module type relies on shape // reduction of identifier occurrences, available from OCaml 5.3. Earlier // versions conservatively keep every implementation of the item live. if (ocamlVersionAtLeast(5, 3)) { assertIncludes(output, "Dead Value +Shared_signature_unused.Make.+f"); assertNotIncludes(output, "Live Value +Shared_signature_unused.Make.+f"); + assertIncludes(output, "Dead Value +Shared_signature_arg.Ignored.+f"); + assertNotIncludes(output, "Live Value +Shared_signature_arg.Ignored.+f"); + assertIncludes(output, "Dead Value +Shared_signature_arg.Local_unused.+f"); + assertNotIncludes(output, "Live Value +Shared_signature_arg.Local_unused.+f"); } assertNotIncludes(output, "Parent is a dead module"); diff --git a/src/Compat.ml b/src/Compat.ml index 2388a82e..e75381d3 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -427,15 +427,63 @@ let extractValueDependencies ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) = (valueTo.Types.val_loc, valueFrom.Types.val_loc)) #endif -(* Identifier occurrences whose definition lives in another compilation unit - (e.g. [Inst.H.find_opt] where [H] is an instance of a functor constrained by - a named module type) are reduced through the shapes of the other units, so - references land on the implementation rather than on the module type item. - Returns a table from the occurrence's start position to the implementation - location. *) +(* Resolution of identifier occurrences to the implementation they denote. + + An occurrence such as [Inst.H.find_opt], where [H] is an instance of a + functor constrained by a named module type, has a [val_loc] pointing at the + module type item. Reducing the occurrence's shape (through the shapes of the + other compilation units) yields the implementation instead, so references + land on the right definition rather than on the shared module type item. + + Occurrences are keyed by their location and last name component, so that + distinct identifiers a ppx may emit at the same position do not collide. *) +type moduleShape = +#if OCAML_VERSION >= (5, 3, 0) + Shape.t +#else + unit +#endif + +type identResolutions = { + valueImpl : Location.t -> string -> Location.t option; + (** occurrence location, last name -> implementation location *) + moduleShape : Location.t -> string -> moduleShape option; + (** occurrence location, last name -> shape of the module *) + projValue : moduleShape -> string -> Location.t option; + (** implementation of a value item of a module shape *) + projModule : moduleShape -> string -> moduleShape option; + (** shape of a module item of a module shape *) +} + +let emptyIdentResolutions = + { + valueImpl = (fun _ _ -> None); + moduleShape = (fun _ _ -> None); + projValue = (fun _ _ -> None); + projModule = (fun _ _ -> None); + } + +#if OCAML_VERSION >= (5, 3, 0) +(* Find, inside the implementation shape of the current unit, the shape of the + item defined with [uid]. Used for modules defined locally, whose occurrences + the compiler resolves to a uid rather than leaving a shape. *) +let rec findShapeByUid (shape : Shape.t) uid : Shape.t option = + if shape.uid = Some uid then Some shape + else + match shape.desc with + | Struct items -> + Shape.Item.Map.fold + (fun _item itemShape acc -> + match acc with + | Some _ -> acc + | None -> findShapeByUid itemShape uid) + items None + | Alias s -> findShapeByUid s uid + | _ -> None +#endif + let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : - (Lexing.position, Location.t) Hashtbl.t = - let table = Hashtbl.create 64 in + identResolutions = #if OCAML_VERSION >= (5, 3, 0) let module Reduce = Shape_reduce.Make (struct let fuel = 10 @@ -446,25 +494,64 @@ let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : | None -> None end) in let local = cmt_infos.cmt_uid_to_decl in + let locOfUid = locOfUid ~currentCmtFile:cmtFilePath ~local in let rec uidOfResult (result : Shape_reduce.result) = match result with | Resolved uid -> Some uid | Resolved_alias (_, result) -> uidOfResult result | _ -> None in + let key (loc : Location.t) name = (loc.loc_start, loc.loc_end, name) in + let values = Hashtbl.create 64 in + let modules = Hashtbl.create 16 in cmt_infos.cmt_ident_occurrences |> List.iter (fun ((lid : Longident.t Location.loc), result) -> - match result with - | Shape_reduce.Unresolved shape when not lid.loc.loc_ghost -> ( - match Reduce.reduce_for_uid Env.empty shape |> uidOfResult with - | Some uid -> ( - match locOfUid ~currentCmtFile:cmtFilePath ~local uid with - | Some loc when not loc.loc_ghost -> - Hashtbl.replace table lid.loc.loc_start loc - | _ -> ()) - | None -> ()) - | _ -> ()); + if not lid.loc.loc_ghost then + let name = Longident.last lid.txt in + let k = key lid.loc name in + match result with + | Shape_reduce.Unresolved shape -> + (* Definition in another unit: reduce lazily, as a value and as a + module, depending on how the occurrence is used. *) + Hashtbl.replace values k (lazy ( + match Reduce.reduce_for_uid Env.empty shape |> uidOfResult with + | Some uid -> locOfUid uid + | None -> None)); + Hashtbl.replace modules k (Some shape) + | _ -> ( + match uidOfResult result with + | Some uid -> + Hashtbl.replace values k (lazy (locOfUid uid)); + Hashtbl.replace modules k + (match cmt_infos.cmt_impl_shape with + | Some impl -> findShapeByUid impl uid + | None -> None) + | None -> ())); + let nonGhost (loc : Location.t option) = + match loc with Some l when not l.loc_ghost -> loc | _ -> None + in + { + valueImpl = + (fun loc name -> + match Hashtbl.find_opt values (key loc name) with + | Some l -> Lazy.force l |> nonGhost + | None -> None); + moduleShape = + (fun loc name -> + match Hashtbl.find_opt modules (key loc name) with + | Some s -> s + | None -> None); + projValue = + (fun shape name -> + let item = Shape.proj shape (Shape.Item.make name Value) in + match Reduce.reduce_for_uid Env.empty item |> uidOfResult with + | Some uid -> locOfUid uid |> nonGhost + | None -> None); + projModule = + (fun shape name -> + Some (Shape.proj shape (Shape.Item.make name Module))); + } #else let _ = (cmtFilePath, cmt_infos) in + emptyIdentResolutions #endif - table diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 4e51dd1d..0a04a36a 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -130,11 +130,9 @@ let processOptionalArgs ~expType ~(locFrom : Location.t) ~locTo ?locToImpl (!supplied, !suppliedMaybe) |> DeadOptionalArgs.addReferences ~locFrom ~locTo ?locToImpl ~path) -(* Occurrence start position -> implementation location, for identifiers - resolved through other compilation units' shapes. See - [Compat.resolveIdentOccurrences]. *) -let identResolutions : (Lexing.position, Location.t) Hashtbl.t ref = - ref (Hashtbl.create 1) +(* Implementation locations of identifier occurrences resolved through + shapes. See [Compat.resolveIdentOccurrences]. *) +let identResolutions = ref Compat.emptyIdentResolutions (* References whose target may be redirected to a shape-resolved implementation. Decided in [forceDelayedItems], once every declaration is @@ -148,22 +146,55 @@ type redirectedReference = { let delayedRedirects : redirectedReference list ref = ref [] -let findResolution ~(identLoc : Location.t) = - Hashtbl.find_opt !identResolutions identLoc.loc_start - -let addValueReferenceOrRedirect ~(locFrom : Location.t) ~(locTo : Location.t) = - match findResolution ~identLoc:locFrom with - | Some locToImpl when locToImpl.loc_start <> locTo.loc_start -> - let lastBinding = !Current.lastBinding in - let locFrom = - match lastBinding = Location.none with - | true -> locFrom - | false -> lastBinding - in +let findResolution ~(identLoc : Location.t) ~(path : Path.t) = + !identResolutions.valueImpl identLoc (Path.last path) + +(* Functor parameters in scope during traversal. A reference through a + parameter (e.g. [M.f] in [functor (M : S) -> ...]) is credited to the actual + arguments at application sites, via the coercion in [Tmod_apply]; it must + not be forwarded to every implementation of the module type item. *) +let functorParameters : Ident.t list ref = ref [] + +let isFunctorParameterPath (path : Path.t) = + match Path.head path with + | head -> List.exists (Ident.same head) !functorParameters + | exception _ -> false + +(* (module type item position, referencing position) pairs that must not be + forwarded to implementations. *) +module PosPairSet = Set.Make (struct + type t = Lexing.position * Lexing.position + + let compare = compare +end) + +let nonForwardableReferences = ref PosPairSet.empty + +let effectiveLocFrom (locFrom : Location.t) = + let lastBinding = !Current.lastBinding in + match lastBinding = Location.none with + | true -> locFrom + | false -> lastBinding + +let addRedirect ~(locFrom : Location.t) ~(locTo : Location.t) ~locToImpl = + match locToImpl with + | Some (locToImpl : Location.t) when locToImpl.loc_start <> locTo.loc_start -> + let locFrom = effectiveLocFrom locFrom in if not locFrom.loc_ghost then delayedRedirects := {locFrom; locTo; locToImpl} :: !delayedRedirects | _ -> addValueReference ~addFileReference:true ~locFrom ~locTo +let addValueReferenceOrRedirect ~(locFrom : Location.t) ~(locTo : Location.t) + ~path = + let pair = (locTo.loc_start, (effectiveLocFrom locFrom).loc_start) in + (if isFunctorParameterPath path then + nonForwardableReferences := PosPairSet.add pair !nonForwardableReferences + else if PosPairSet.mem pair !nonForwardableReferences then + (* A non-parameter reference from the same position keeps it + forwardable. *) + nonForwardableReferences := PosPairSet.remove pair !nonForwardableReferences); + addRedirect ~locFrom ~locTo ~locToImpl:(findResolution ~identLoc:locFrom ~path) + let rec collectExpr super self (e : Typedtree.expression) = let locFrom = e.exp_loc in (match e.exp_desc with @@ -178,7 +209,7 @@ let rec collectExpr super self (e : Typedtree.expression) = (Location.none.loc_start |> posToString) (locTo.loc_start |> posToString); ValueReferences.add locTo.loc_start Location.none.loc_start) - else addValueReferenceOrRedirect ~locFrom ~locTo + else addValueReferenceOrRedirect ~locFrom ~locTo ~path:_path | Texp_apply ( { exp_desc = @@ -188,7 +219,7 @@ let rec collectExpr super self (e : Typedtree.expression) = exp_loc = identLoc; }, args ) -> - let locToImpl = findResolution ~identLoc in + let locToImpl = findResolution ~identLoc ~path in args |> processOptionalArgs ~expType:exp_type ~locFrom:(locFrom : Location.t) @@ -347,28 +378,46 @@ let findSignatureItem name signature = | Some itemName -> itemName = name | None -> false) -let addValueReferenceFromSignatureItem ~locFrom signatureItem = - let _id, locTo, _kind, _valType = signatureItem |> Compat.getSigValue in +(* [shape], when known, is the shape of the module the signature items belong + to; it is used to reference the implementation of an item rather than a + shared module type item. See [Compat.resolveIdentOccurrences]. *) +let addValueReferenceFromSignatureItem ~locFrom ?shape signatureItem = + let id, locTo, _kind, _valType = signatureItem |> Compat.getSigValue in if not locTo.loc_ghost then - addValueReference ~addFileReference:true ~locFrom ~locTo + let locToImpl = + match shape with + | Some shape -> !identResolutions.projValue shape (Ident.name id) + | None -> None + in + addRedirect ~locFrom ~locTo ~locToImpl + +let projModuleShape ?shape id = + match shape with + | Some shape -> !identResolutions.projModule shape (Ident.name id) + | None -> None -let rec addAllModuleValueReferences ~locFrom (moduleType : Types.module_type) = +let rec addAllModuleValueReferences ~locFrom ?shape + (moduleType : Types.module_type) = moduleType |> getSignature |> List.iter (fun (signatureItem : Types.signature_item) -> match signatureItem with | Types.Sig_value _ -> - addValueReferenceFromSignatureItem ~locFrom signatureItem + addValueReferenceFromSignatureItem ~locFrom ?shape signatureItem | Types.Sig_module _ | Types.Sig_modtype _ -> ( match signatureItem |> Compat.getSigModuleModtype with - | Some (_id, moduleType, _moduleLoc) -> - addAllModuleValueReferences ~locFrom moduleType + | Some (id, moduleType, _moduleLoc) -> + addAllModuleValueReferences ~locFrom + ?shape:(projModuleShape ?shape id) + moduleType | None -> ()) | _ -> ()) -let rec addCoercedModuleValueReferences ~locFrom ~coercion ~actualType = +let rec addCoercedModuleValueReferences ~locFrom ~coercion ?shape ~actualType + () = let actualSignature = actualType |> getSignature in match coercion with - | Typedtree.Tcoerce_none -> addAllModuleValueReferences ~locFrom actualType + | Typedtree.Tcoerce_none -> + addAllModuleValueReferences ~locFrom ?shape actualType | Typedtree.Tcoerce_structure (values, modules) -> let actualFields = actualSignature @@ -381,7 +430,7 @@ let rec addCoercedModuleValueReferences ~locFrom ~coercion ~actualType = |> List.iter (fun (index, _coercion) -> match nth_opt actualFields index with | Some (Types.Sig_value _ as actualItem) -> - addValueReferenceFromSignatureItem ~locFrom actualItem + addValueReferenceFromSignatureItem ~locFrom ?shape actualItem | Some _ -> () | None -> ()); let actualModules = @@ -400,15 +449,17 @@ let rec addCoercedModuleValueReferences ~locFrom ~coercion ~actualType = match actualItem with | Some actualItem -> ( match actualItem |> Compat.getSigModuleModtype with - | Some (_actualId, actualType, _moduleLoc) -> - addCoercedModuleValueReferences ~locFrom ~coercion ~actualType + | Some (actualId, actualType, _moduleLoc) -> + addCoercedModuleValueReferences ~locFrom ~coercion + ?shape:(projModuleShape ?shape actualId) + ~actualType () | None -> ()) | None -> ()) | Typedtree.Tcoerce_alias (_env, _path, coercion) -> - addCoercedModuleValueReferences ~locFrom ~coercion ~actualType + addCoercedModuleValueReferences ~locFrom ~coercion ?shape ~actualType () | Typedtree.Tcoerce_functor (_argCoercion, resultCoercion) -> - addCoercedModuleValueReferences ~locFrom ~coercion:resultCoercion - ~actualType + addCoercedModuleValueReferences ~locFrom ~coercion:resultCoercion ?shape + ~actualType () | Typedtree.Tcoerce_primitive _ -> () let rec processSignatureItem ~doTypes ~doValues ~moduleLoc ~path @@ -451,14 +502,29 @@ let traverseStructure ~doTypes ~doExternals = let expr self e = e |> collectExpr super self in let pat self p = p |> collectPattern super self in let module_expr self (moduleExpr : Typedtree.module_expr) = + let oldFunctorParameters = !functorParameters in + (match moduleExpr.mod_desc with + | Tmod_functor (Named (Some id, _, _), _) -> + functorParameters := id :: !functorParameters + | _ -> ()); (match moduleExpr.mod_desc with | Tmod_apply (_functorExpr, argumentExpr, coercion) -> (* Functor arguments are used through the parameter coercion, not every - value exposed by the actual argument module. *) + value exposed by the actual argument module. When the argument is a + module path, its shape lets the references target that module's + implementation rather than a shared module type item. *) + let shape = + match argumentExpr.mod_desc with + | Tmod_ident (path, lid) -> + !identResolutions.moduleShape lid.loc (Path.last path) + | _ -> None + in addCoercedModuleValueReferences ~locFrom:argumentExpr.mod_loc ~coercion - ~actualType:argumentExpr.mod_type + ?shape ~actualType:argumentExpr.mod_type () | _ -> ()); - super.Tast_mapper.module_expr self moduleExpr + let r = super.Tast_mapper.module_expr self moduleExpr in + functorParameters := oldFunctorParameters; + r in let value_binding self vb = vb |> collectValueBinding super self in let structure_item self (structureItem : Typedtree.structure_item) = @@ -559,7 +625,12 @@ let processValueDependency DeadOptionalArgs.forwardDelayedItems ~posFrom ~posTo; ValueReferences.find posFrom |> PosSet.iter (fun posRef -> - if posRef <> posTo then + if + posRef <> posTo + && not + (PosPairSet.mem (posFrom, posRef) + !nonForwardableReferences) + then let locRef = { Location.loc_start = posRef; @@ -598,7 +669,7 @@ let processStructure ~cmt_value_dependencies ~cmt_ident_resolutions ~doTypes let traverseStructure = traverseStructure ~doTypes ~doExternals in identResolutions := cmt_ident_resolutions; structure |> traverseStructure.structure traverseStructure |> ignore; - identResolutions := Hashtbl.create 1; + identResolutions := Compat.emptyIdentResolutions; let valueDependencies = cmt_value_dependencies |> List.rev in delayedValueDependencies := List.rev_append valueDependencies !delayedValueDependencies From a23dd851b3f72ac7646c878b7d6c61b6e865cebb Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 13:29:43 +0000 Subject: [PATCH 04/53] Address review: scope unit cache, fix mixed-reference suppression, credit parameter calls - Key the per-unit cache by the files the unit is loaded from and prefer the unit built alongside the current file, so same-named units in different build directories (notably each executable's Dune__exe alias module) are not confused. - Only a non-parameter reference that stays targeted at the module type item re-enables forwarding for a binding; a shape-redirected one does not, since it never lands on the item. - Optional-argument calls made through a functor parameter are no longer forwarded to every implementation. Instead they are credited to the actual argument at each functor application, resolved through the argument's shape (or its signature as a fallback), once all files are scanned. Regression cases: a binding mixing a parameter call with a resolved call, and an optional argument supplied only through a functor parameter. --- examples/regression/src/Main.ml | 3 +- examples/regression/src/Shared_signature.ml | 4 + .../regression/src/Shared_signature_arg.ml | 27 +++ scripts/run_integration_tests.js | 11 + src/Compat.ml | 69 +++++-- src/DeadOptionalArgs.ml | 23 ++- src/DeadValue.ml | 192 ++++++++++++++++-- 7 files changed, 293 insertions(+), 36 deletions(-) diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 3c4cf3cf..49b0d1a6 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -7,4 +7,5 @@ let () = Local_side_effects.start (); Ocaml_compiler_compat.run (); Shared_signature_use.run (); - Shared_signature_arg.run () + Shared_signature_arg.run (); + Shared_signature_arg.run_more () diff --git a/examples/regression/src/Shared_signature.ml b/examples/regression/src/Shared_signature.ml index ab70c670..2afce9cd 100644 --- a/examples/regression/src/Shared_signature.ml +++ b/examples/regression/src/Shared_signature.ml @@ -4,3 +4,7 @@ module type S = sig val f : unit -> int end + +module type O = sig + val g : ?x:int -> unit -> int +end diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml index b4fc0f47..0c696175 100644 --- a/examples/regression/src/Shared_signature_arg.ml +++ b/examples/regression/src/Shared_signature_arg.ml @@ -24,3 +24,30 @@ module Local_unused : Shared_signature.S = struct end let run () = ignore (Applied.run () + Local_used.f ()) + +(* A binding calling both through the parameter and a resolved module: the + parameter call must still not be forwarded to [Ignored]. *) +module Apply_mixed (M : Shared_signature.S) = struct + let run () = M.f () + Chosen.f () +end + +module Applied_mixed = Apply_mixed (Chosen) + +(* Optional argument supplied only through a functor parameter call: must be + credited to [Opt_chosen] only, so [Opt_direct]'s [x] stays never used. *) +module Opt_chosen : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_direct : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Apply_opt (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Applied_opt = Apply_opt (Opt_chosen) + +let run_more () = + ignore (Applied_mixed.run () + Applied_opt.run () + Opt_direct.g ()) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index a42eda66..875e2fb9 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -122,6 +122,12 @@ function runRegressionTests() { assertNotIncludes(output, "Dead Value +Shared_signature_arg.Chosen.+f"); assertIncludes(output, "Live Value +Shared_signature_arg.Local_used.+f"); assertNotIncludes(output, "Dead Value +Shared_signature_arg.Local_used.+f"); + // A call through a functor parameter supplying ?x must not be attributed to + // other implementations of the module type item. + assertIncludes( + output, + "optional argument x of function Opt_direct.+g is never used" + ); // Precise attribution through a shared named module type relies on shape // reduction of identifier occurrences, available from OCaml 5.3. Earlier // versions conservatively keep every implementation of the item live. @@ -132,6 +138,11 @@ function runRegressionTests() { assertNotIncludes(output, "Live Value +Shared_signature_arg.Ignored.+f"); assertIncludes(output, "Dead Value +Shared_signature_arg.Local_unused.+f"); assertNotIncludes(output, "Live Value +Shared_signature_arg.Local_unused.+f"); + // A call through a functor parameter is credited to the actual argument. + assertIncludes( + output, + "optional argument x of function Opt_chosen.+g is always supplied" + ); } assertNotIncludes(output, "Parent is a dead module"); diff --git a/src/Compat.ml b/src/Compat.ml index e75381d3..48f364aa 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -332,16 +332,19 @@ type unitInfo = { uidToDecl : Typedtree.item_declaration Shape.Uid.Tbl.t; } -let unitInfoCache : (string, unitInfo) Hashtbl.t = Hashtbl.create 64 +(* Keyed by the list of files a unit is loaded from, so that same-named units + in different build targets (e.g. two unwrapped libraries each defining + [Config]) do not share an entry. *) +let unitInfoCache : (string list, unitInfo) Hashtbl.t = Hashtbl.create 64 let candidateFilesForUnit ~currentCmtFile comp_unit = + let dir = Filename.dirname currentCmtFile in 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 currentCmtFile in let siblings = [".cmt"; ".cmti"] |> List.concat_map (fun ext -> @@ -350,13 +353,20 @@ let candidateFilesForUnit ~currentCmtFile comp_unit = Filename.concat dir (String.uncapitalize_ascii comp_unit ^ ext); ]) in - (indexed @ siblings) |> List.filter Sys.file_exists |> List.sort_uniq compare + let candidates = + (indexed @ siblings) |> List.filter Sys.file_exists |> List.sort_uniq compare + in + (* Prefer the unit built alongside the current file when the same unit name + exists in several build targets. *) + match candidates |> List.filter (fun p -> Filename.dirname p = dir) with + | [] -> candidates + | sameDir -> sameDir let loadUnitInfo ~currentCmtFile comp_unit = - match Hashtbl.find_opt unitInfoCache comp_unit with + let files = candidateFilesForUnit ~currentCmtFile comp_unit in + match Hashtbl.find_opt unitInfoCache files with | Some info -> Some info | None -> ( - let files = candidateFilesForUnit ~currentCmtFile comp_unit in match files with | [] -> None | _ -> @@ -376,7 +386,7 @@ let loadUnitInfo ~currentCmtFile comp_unit = | _ -> () with _ -> ()); let info = {shape = !shape; uidToDecl} in - Hashtbl.replace unitInfoCache comp_unit info; + Hashtbl.replace unitInfoCache files info; Some info) let locOfItemDeclaration = function @@ -384,20 +394,27 @@ let locOfItemDeclaration = function | Typedtree.Value_binding {vb_pat = {pat_loc; _}; _} -> Some pat_loc | _ -> None -let locOfUid ~currentCmtFile ~(local : Typedtree.item_declaration Shape.Uid.Tbl.t) - uid = +let declOfUid ~currentCmtFile + ~(local : Typedtree.item_declaration Shape.Uid.Tbl.t) uid = match Shape.Uid.Tbl.find_opt local uid with - | Some decl -> locOfItemDeclaration decl + | Some decl -> Some decl | None -> ( match uid with | Shape.Uid.Item {comp_unit; _} -> ( match loadUnitInfo ~currentCmtFile comp_unit with - | Some {uidToDecl} -> ( - match Shape.Uid.Tbl.find_opt uidToDecl uid with - | Some decl -> locOfItemDeclaration decl - | None -> None) + | Some {uidToDecl} -> Shape.Uid.Tbl.find_opt uidToDecl uid | None -> None) | _ -> None) + +let locOfUid ~currentCmtFile ~local uid = + match declOfUid ~currentCmtFile ~local uid with + | Some decl -> locOfItemDeclaration decl + | None -> None + +let moduleBindingLocOfUid ~currentCmtFile ~local uid = + match declOfUid ~currentCmtFile ~local uid with + | Some (Typedtree.Module_binding {mb_name = {loc}}) -> Some loc + | _ -> None #endif let extractValueDependencies ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) = @@ -453,6 +470,9 @@ type identResolutions = { (** implementation of a value item of a module shape *) projModule : moduleShape -> string -> moduleShape option; (** shape of a module item of a module shape *) + moduleDefLoc : Location.t -> string -> Location.t option; + (** occurrence location, last name -> location of the module binding's + name, for a module (e.g. a functor) defined with [module X = ...] *) } let emptyIdentResolutions = @@ -461,6 +481,7 @@ let emptyIdentResolutions = moduleShape = (fun _ _ -> None); projValue = (fun _ _ -> None); projModule = (fun _ _ -> None); + moduleDefLoc = (fun _ _ -> None); } #if OCAML_VERSION >= (5, 3, 0) @@ -504,6 +525,7 @@ let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : let key (loc : Location.t) name = (loc.loc_start, loc.loc_end, name) in let values = Hashtbl.create 64 in let modules = Hashtbl.create 16 in + let moduleUids = Hashtbl.create 16 in cmt_infos.cmt_ident_occurrences |> List.iter (fun ((lid : Longident.t Location.loc), result) -> if not lid.loc.loc_ghost then @@ -513,11 +535,15 @@ let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : | Shape_reduce.Unresolved shape -> (* Definition in another unit: reduce lazily, as a value and as a module, depending on how the occurrence is used. *) + let uid = + lazy (Reduce.reduce_for_uid Env.empty shape |> uidOfResult) + in Hashtbl.replace values k (lazy ( - match Reduce.reduce_for_uid Env.empty shape |> uidOfResult with + match Lazy.force uid with | Some uid -> locOfUid uid | None -> None)); - Hashtbl.replace modules k (Some shape) + Hashtbl.replace modules k (Some shape); + Hashtbl.replace moduleUids k uid | _ -> ( match uidOfResult result with | Some uid -> @@ -525,7 +551,8 @@ let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : Hashtbl.replace modules k (match cmt_infos.cmt_impl_shape with | Some impl -> findShapeByUid impl uid - | None -> None) + | None -> None); + Hashtbl.replace moduleUids k (lazy (Some uid)) | None -> ())); let nonGhost (loc : Location.t option) = match loc with Some l when not l.loc_ghost -> loc | _ -> None @@ -550,6 +577,16 @@ let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : projModule = (fun shape name -> Some (Shape.proj shape (Shape.Item.make name Module))); + moduleDefLoc = + (fun loc name -> + match Hashtbl.find_opt moduleUids (key loc name) with + | Some uid -> ( + match Lazy.force uid with + | Some uid -> + moduleBindingLocOfUid ~currentCmtFile:cmtFilePath ~local uid + |> nonGhost + | None -> None) + | None -> None); } #else let _ = (cmtFilePath, cmt_infos) in diff --git a/src/DeadOptionalArgs.ml b/src/DeadOptionalArgs.ml index 02a69b81..136c74e1 100644 --- a/src/DeadOptionalArgs.ml +++ b/src/DeadOptionalArgs.ml @@ -7,6 +7,10 @@ type item = { posTo : Lexing.position; posToImpl : Lexing.position option; (** Shape-resolved implementation, used when [posTo] is not a declaration. *) + forwardable : bool; + (** Whether the call may be attributed to the implementations of a module + type item. False for calls through a functor parameter, which are + credited at application sites. *) argNames : string list; argNamesMaybe : string list; } @@ -49,12 +53,14 @@ let rec fromTypeExpr (texpr : Types.type_expr) = | _ -> [] let addReferences ~(locFrom : Location.t) ~(locTo : Location.t) - ?(locToImpl : Location.t option) ~path (argNames, argNamesMaybe) = + ?(locToImpl : Location.t option) ?(forwardable = true) ~path + (argNames, argNamesMaybe) = if active () then ( let posTo = locTo.loc_start in let posToImpl = Option.map (fun (l : Location.t) -> l.loc_start) locToImpl in let posFrom = locFrom.loc_start in - delayedItems := {posTo; posToImpl; argNames; argNamesMaybe} :: !delayedItems; + delayedItems := + {posTo; posToImpl; forwardable; argNames; argNamesMaybe} :: !delayedItems; if !Common.Cli.debug then Log_.item "DeadOptionalArgs.addReferences %s called with optional argNames:%s \ @@ -64,6 +70,15 @@ let addReferences ~(locFrom : Location.t) ~(locTo : Location.t) (argNamesMaybe |> String.concat ", ") (posFrom |> posToString)) +(* A call through a functor parameter, credited to the implementation the + functor was applied to. *) +let addCallToImplementation ~(posTo : Lexing.position) (argNames, argNamesMaybe) + = + if active () then + delayedItems := + {posTo; posToImpl = None; forwardable = false; argNames; argNamesMaybe} + :: !delayedItems + (* Once all declarations are known, calls whose target is not a declaration but have a shape-resolved implementation are attributed to it. Must run before [forwardDelayedItems] and [forceDelayedItems]. *) @@ -83,7 +98,9 @@ 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) + if item.forwardable && item.posTo = posFrom then + Some {item with posTo} + else None) in delayedItems := forwarded @ !delayedItems diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 0a04a36a..61e958eb 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -95,6 +95,53 @@ let collectValueBinding super self (vb : Typedtree.value_binding) = Current.lastBinding := oldLastBinding; r +type functorParameter = { + paramId : Ident.t; + functorDef : Lexing.position; + (** position of the name of the module binding defining the functor *) + paramIndex : int; (** position of the parameter, for curried functors *) +} + +let functorParameters : functorParameter list ref = ref [] + +(* Name position of the module binding being traversed, see [Tstr_module]. *) +let currentModuleBindingPos = ref Lexing.dummy_pos + +let findFunctorParameter (path : Path.t) = + match Path.head path with + | head -> List.find_opt (fun p -> Ident.same p.paramId head) !functorParameters + | exception _ -> None + +let isFunctorParameterPath path = findFunctorParameter path <> None + +(* Calls with optional arguments made through a functor parameter, keyed by + the functor definition, parameter index, and path of the value within the + parameter (e.g. ["g"] for [M.g], ["Sub"; "g"] for [M.Sub.g]). They are + credited to the actual arguments at application sites, once all files are + scanned. *) +let parameterCalls : + (Lexing.position * int * string list, (string list * string list) list) + Hashtbl.t = + Hashtbl.create 16 + +type delayedApplication = { + appliedFunctor : Lexing.position; + argIndex : int; + resolveItem : string list -> Location.t option; + (** implementation of a value of the actual argument, by path *) +} + +let delayedApplications : delayedApplication list ref = ref [] + +let rec pathComponents (path : Path.t) = + match path with + | Pident _ -> Some [] + | Pdot (p, name) -> ( + match pathComponents p with + | Some comps -> Some (comps @ [name]) + | None -> None) + | _ -> None + let processOptionalArgs ~expType ~(locFrom : Location.t) ~locTo ?locToImpl ~path args = let args = @@ -127,8 +174,21 @@ let processOptionalArgs ~expType ~(locFrom : Location.t) ~locTo ?locToImpl if argIsSupplied <> Some false then supplied := s :: !supplied; if argIsSupplied = None then suppliedMaybe := s :: !suppliedMaybe | _ -> ()); - (!supplied, !suppliedMaybe) - |> DeadOptionalArgs.addReferences ~locFrom ~locTo ?locToImpl ~path) + let call = (!supplied, !suppliedMaybe) in + let parameter = findFunctorParameter path in + (match (parameter, pathComponents path) with + | Some {functorDef; paramIndex}, Some components -> + let key = (functorDef, paramIndex, components) in + let calls = + match Hashtbl.find_opt parameterCalls key with + | Some calls -> calls + | None -> [] + in + Hashtbl.replace parameterCalls key (call :: calls) + | _ -> ()); + call + |> DeadOptionalArgs.addReferences ~locFrom ~locTo ?locToImpl + ~forwardable:(parameter = None) ~path) (* Implementation locations of identifier occurrences resolved through shapes. See [Compat.resolveIdentOccurrences]. *) @@ -153,13 +213,6 @@ let findResolution ~(identLoc : Location.t) ~(path : Path.t) = parameter (e.g. [M.f] in [functor (M : S) -> ...]) is credited to the actual arguments at application sites, via the coercion in [Tmod_apply]; it must not be forwarded to every implementation of the module type item. *) -let functorParameters : Ident.t list ref = ref [] - -let isFunctorParameterPath (path : Path.t) = - match Path.head path with - | head -> List.exists (Ident.same head) !functorParameters - | exception _ -> false - (* (module type item position, referencing position) pairs that must not be forwarded to implementations. *) module PosPairSet = Set.Make (struct @@ -187,13 +240,16 @@ let addRedirect ~(locFrom : Location.t) ~(locTo : Location.t) ~locToImpl = let addValueReferenceOrRedirect ~(locFrom : Location.t) ~(locTo : Location.t) ~path = let pair = (locTo.loc_start, (effectiveLocFrom locFrom).loc_start) in + let locToImpl = findResolution ~identLoc:locFrom ~path in (if isFunctorParameterPath path then nonForwardableReferences := PosPairSet.add pair !nonForwardableReferences - else if PosPairSet.mem pair !nonForwardableReferences then - (* A non-parameter reference from the same position keeps it - forwardable. *) + else if locToImpl = None && PosPairSet.mem pair !nonForwardableReferences + then + (* A non-parameter reference from the same position that stays targeted + at the module type item keeps the pair forwardable. A redirected one + does not: it never lands on the item. *) nonForwardableReferences := PosPairSet.remove pair !nonForwardableReferences); - addRedirect ~locFrom ~locTo ~locToImpl:(findResolution ~identLoc:locFrom ~path) + addRedirect ~locFrom ~locTo ~locToImpl let rec collectExpr super self (e : Typedtree.expression) = let locFrom = e.exp_loc in @@ -496,6 +552,83 @@ let rec processSignatureItem ~doTypes ~doValues ~moduleLoc ~path | None -> ()) | _ -> () +(* Implementation of a value of an actual functor argument, by path. *) +let argumentItemResolver (argumentExpr : Typedtree.module_expr) = + let shape = + match argumentExpr.mod_desc with + | Tmod_ident (path, lid) -> + !identResolutions.moduleShape lid.loc (Path.last path) + | _ -> None + in + let resolutions = !identResolutions in + let rec viaShape shape components = + match components with + | [] -> None + | [name] -> resolutions.projValue shape name + | m :: rest -> ( + match resolutions.projModule shape m with + | Some shape -> viaShape shape rest + | None -> None) + in + let rec viaSignature (moduleType : Types.module_type) components = + let signature = moduleType |> getSignature in + match components with + | [] -> None + | [name] -> ( + match signature |> findSignatureItem name with + | Some (Types.Sig_value _ as item) -> + let _id, loc, _kind, _valType = item |> Compat.getSigValue in + if loc.loc_ghost then None else Some loc + | _ -> None) + | m :: rest -> ( + match signature |> findSignatureItem m with + | Some item -> ( + match item |> Compat.getSigModuleModtype with + | Some (_id, moduleType, _loc) -> viaSignature moduleType rest + | None -> None) + | None -> None) + in + fun components -> + match shape with + | Some shape -> ( + match viaShape shape components with + | Some loc -> Some loc + | None -> viaSignature argumentExpr.mod_type components) + | None -> viaSignature argumentExpr.mod_type components + +(* Applications already recorded as part of an outer curried application. *) +let recordedApplications = ref PosSet.empty + +(* [F (A) (B)] is [Tmod_apply (Tmod_apply (F, A), B)]: collect the functor and + the arguments in order, and defer crediting the calls made through each + parameter to the corresponding argument. *) +let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = + if not (PosSet.mem moduleExpr.mod_loc.loc_start !recordedApplications) then + let rec flatten (e : Typedtree.module_expr) args = + match e.mod_desc with + | Tmod_apply (functorExpr, argumentExpr, _) -> + recordedApplications := + PosSet.add e.mod_loc.loc_start !recordedApplications; + flatten functorExpr (argumentExpr :: args) + | Tmod_ident (path, lid) -> Some (path, lid, args) + | _ -> None + in + match flatten moduleExpr [] with + | Some (path, lid, args) -> ( + match !identResolutions.moduleDefLoc lid.loc (Path.last path) with + | Some defLoc -> + args + |> List.iteri (fun argIndex argumentExpr -> + delayedApplications := + { + appliedFunctor = defLoc.loc_start; + argIndex; + resolveItem = argumentItemResolver argumentExpr; + } + :: !delayedApplications) + | None -> ()) + | None -> () + (* Traverse the AST *) let traverseStructure ~doTypes ~doExternals = let super = Tast_mapper.default in @@ -505,7 +638,14 @@ let traverseStructure ~doTypes ~doExternals = let oldFunctorParameters = !functorParameters in (match moduleExpr.mod_desc with | Tmod_functor (Named (Some id, _, _), _) -> - functorParameters := id :: !functorParameters + let functorDef = !currentModuleBindingPos in + let paramIndex = + !functorParameters + |> List.filter (fun p -> p.functorDef = functorDef) + |> List.length + in + functorParameters := + {paramId = id; functorDef; paramIndex} :: !functorParameters | _ -> ()); (match moduleExpr.mod_desc with | Tmod_apply (_functorExpr, argumentExpr, coercion) -> @@ -520,7 +660,8 @@ let traverseStructure ~doTypes ~doExternals = | _ -> None in addCoercedModuleValueReferences ~locFrom:argumentExpr.mod_loc ~coercion - ?shape ~actualType:argumentExpr.mod_type () + ?shape ~actualType:argumentExpr.mod_type (); + recordFunctorApplication moduleExpr | _ -> ()); let r = super.Tast_mapper.module_expr self moduleExpr in functorParameters := oldFunctorParameters; @@ -529,8 +670,10 @@ let traverseStructure ~doTypes ~doExternals = let value_binding self vb = vb |> collectValueBinding super self in let structure_item self (structureItem : Typedtree.structure_item) = let oldModulePath = ModulePath.getCurrent () in + let oldModuleBindingPos = !currentModuleBindingPos in (match structureItem.str_desc with - | Tstr_module {mb_expr; mb_id; mb_loc} -> ( + | Tstr_module {mb_expr; mb_id; mb_loc; mb_name} -> ( + currentModuleBindingPos := mb_name.loc.loc_start; let hasInterface = match mb_expr.mod_desc with Tmod_constraint _ -> true | _ -> false in @@ -600,6 +743,7 @@ let traverseStructure ~doTypes ~doExternals = | _ -> ()); let result = super.structure_item self structureItem in ModulePath.setCurrent oldModulePath; + currentModuleBindingPos := oldModuleBindingPos; result in {super with expr; module_expr; pat; structure_item; value_binding} @@ -659,6 +803,22 @@ let forceDelayedItems () = | None -> locToImpl in addValueReference ~addFileReference:true ~locFrom ~locTo); + (* Credit calls made through functor parameters to the actual arguments. *) + let applications = List.rev !delayedApplications in + delayedApplications := []; + applications + |> List.iter (fun {appliedFunctor; argIndex; resolveItem} -> + Hashtbl.iter + (fun (def, index, components) calls -> + if def = appliedFunctor && index = argIndex then + match resolveItem components with + | Some (locTo : Location.t) -> + calls + |> List.iter + (DeadOptionalArgs.addCallToImplementation + ~posTo:locTo.loc_start) + | None -> ()) + parameterCalls); DeadOptionalArgs.settleDelayedItems (); let dependencies = List.rev !delayedValueDependencies in delayedValueDependencies := []; From 088c695223c66ab11b93ef9ffcd2ce3458c703ff Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 13:56:39 +0000 Subject: [PATCH 05/53] Address review: constrained arguments, inline functors, unit selection by digest - Unwrap (M : S) constraints around functor arguments before resolving the argument's shape, and expand an explicit constraint by a named module type to that module type's signature: the typed tree leaves it as Mty_ident, which exposed no items and silently dropped every reference to the argument (a pre-existing gap that the previous inert signature reference happened to mask). - Key inline functors ((functor (M : S) -> ...) (A)) by their own position so calls through their parameters are credited at the application. - When the same unit name exists in several build directories and none is next to the consumer, select the candidate whose interface digest matches the consumer's recorded import. Regression cases: constrained argument (value and optional argument), inline functor. --- examples/regression/src/Main.ml | 3 +- .../regression/src/Shared_signature_arg.ml | 34 ++++++ scripts/run_integration_tests.js | 16 ++- src/Compat.ml | 94 +++++++++++---- src/DeadValue.ml | 113 +++++++++++++----- 5 files changed, 204 insertions(+), 56 deletions(-) diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 49b0d1a6..a588a86d 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -8,4 +8,5 @@ let () = Ocaml_compiler_compat.run (); Shared_signature_use.run (); Shared_signature_arg.run (); - Shared_signature_arg.run_more () + Shared_signature_arg.run_more (); + Shared_signature_arg.run_even_more () diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml index 0c696175..4919806e 100644 --- a/examples/regression/src/Shared_signature_arg.ml +++ b/examples/regression/src/Shared_signature_arg.ml @@ -51,3 +51,37 @@ module Applied_opt = Apply_opt (Opt_chosen) let run_more () = ignore (Applied_mixed.run () + Applied_opt.run () + Opt_direct.g ()) + +(* Argument wrapped in a constraint: [(Opt_constrained : O)]. *) +module Opt_constrained : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Applied_constrained = Apply_opt ((Opt_constrained : Shared_signature.O)) + +(* Inline functor applied directly. *) +module Opt_inline : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Applied_inline = + (functor (M : Shared_signature.O) -> struct + let run () = M.g ~x:1 () + end) + (Opt_inline) + +(* Constrained argument for liveness: [Ignored2] must stay dead. *) +module Chosen2 : Shared_signature.S = struct + let f () = 7 +end + +module Ignored2 : Shared_signature.S = struct + let f () = 8 +end + +module Applied_constrained_value = Apply ((Chosen2 : Shared_signature.S)) + +let run_even_more () = + ignore + (Applied_constrained.run () + Applied_inline.run () + + Applied_constrained_value.run ()) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index 875e2fb9..527906b3 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -128,6 +128,10 @@ function runRegressionTests() { output, "optional argument x of function Opt_direct.+g is never used" ); + // Arguments wrapped in a constraint by a named module type are still used. + assertIncludes(output, "Live Value +Shared_signature_arg.Chosen2.+f"); + assertNotIncludes(output, "Dead Value +Shared_signature_arg.Chosen2.+f"); + assertNotIncludes(output, "Dead Value +Shared_signature_arg.Opt_constrained.+g"); // Precise attribution through a shared named module type relies on shape // reduction of identifier occurrences, available from OCaml 5.3. Earlier // versions conservatively keep every implementation of the item live. @@ -138,11 +142,21 @@ function runRegressionTests() { assertNotIncludes(output, "Live Value +Shared_signature_arg.Ignored.+f"); assertIncludes(output, "Dead Value +Shared_signature_arg.Local_unused.+f"); assertNotIncludes(output, "Live Value +Shared_signature_arg.Local_unused.+f"); - // A call through a functor parameter is credited to the actual argument. + // A call through a functor parameter is credited to the actual argument, + // including through a constraint and for an inline functor. assertIncludes( output, "optional argument x of function Opt_chosen.+g is always supplied" ); + assertIncludes( + output, + "optional argument x of function Opt_constrained.+g is always supplied" + ); + assertIncludes( + output, + "optional argument x of function Opt_inline.+g is always supplied" + ); + assertIncludes(output, "Dead Value +Shared_signature_arg.Ignored2.+f"); } assertNotIncludes(output, "Parent is a dead module"); diff --git a/src/Compat.ml b/src/Compat.ml index 48f364aa..f9e672d4 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -362,7 +362,11 @@ let candidateFilesForUnit ~currentCmtFile comp_unit = | [] -> candidates | sameDir -> sameDir -let loadUnitInfo ~currentCmtFile comp_unit = +(* [imports] are the consumer's recorded imports: when the same unit name + exists in several build directories, the candidate whose interface digest + matches the one the consumer was compiled against is the actual + dependency. *) +let loadUnitInfo ~currentCmtFile ~(imports : Misc.crcs) comp_unit = let files = candidateFilesForUnit ~currentCmtFile comp_unit in match Hashtbl.find_opt unitInfoCache files with | Some info -> Some info @@ -370,21 +374,38 @@ let loadUnitInfo ~currentCmtFile comp_unit = match files with | [] -> None | _ -> + let read path = + try Some (path, Cmt_format.read_cmt path) with _ -> None + in + let loaded = files |> List.filter_map read in + let dirs = + loaded |> List.map (fun (p, _) -> Filename.dirname p) + |> List.sort_uniq compare + in + let loaded = + match (dirs, List.assoc_opt comp_unit imports) with + | _ :: _ :: _, Some (Some digest) -> ( + match + loaded + |> List.filter (fun (_, (cmt_infos : Cmt_format.cmt_infos)) -> + cmt_infos.cmt_interface_digest = Some digest) + with + | [] -> loaded + | matching -> matching) + | _ -> loaded + in let uidToDecl = Shape.Uid.Tbl.create 64 in let shape = ref None in - files - |> List.iter (fun path -> - try - let cmt_infos = Cmt_format.read_cmt path in - Shape.Uid.Tbl.iter - (fun uid decl -> - if not (Shape.Uid.Tbl.mem uidToDecl uid) then - Shape.Uid.Tbl.replace uidToDecl uid decl) - cmt_infos.cmt_uid_to_decl; - match (!shape, cmt_infos.cmt_impl_shape) with - | None, Some _ -> shape := cmt_infos.cmt_impl_shape - | _ -> () - with _ -> ()); + loaded + |> List.iter (fun (_, (cmt_infos : Cmt_format.cmt_infos)) -> + Shape.Uid.Tbl.iter + (fun uid decl -> + if not (Shape.Uid.Tbl.mem uidToDecl uid) then + Shape.Uid.Tbl.replace uidToDecl uid decl) + cmt_infos.cmt_uid_to_decl; + match (!shape, cmt_infos.cmt_impl_shape) with + | None, Some _ -> shape := cmt_infos.cmt_impl_shape + | _ -> ()); let info = {shape = !shape; uidToDecl} in Hashtbl.replace unitInfoCache files info; Some info) @@ -394,27 +415,32 @@ let locOfItemDeclaration = function | Typedtree.Value_binding {vb_pat = {pat_loc; _}; _} -> Some pat_loc | _ -> None -let declOfUid ~currentCmtFile +let declOfUid ~currentCmtFile ~imports ~(local : Typedtree.item_declaration Shape.Uid.Tbl.t) uid = match Shape.Uid.Tbl.find_opt local uid with | Some decl -> Some decl | None -> ( match uid with | Shape.Uid.Item {comp_unit; _} -> ( - match loadUnitInfo ~currentCmtFile comp_unit with + match loadUnitInfo ~currentCmtFile ~imports comp_unit with | Some {uidToDecl} -> Shape.Uid.Tbl.find_opt uidToDecl uid | None -> None) | _ -> None) -let locOfUid ~currentCmtFile ~local uid = - match declOfUid ~currentCmtFile ~local uid with +let locOfUid ~currentCmtFile ~imports ~local uid = + match declOfUid ~currentCmtFile ~imports ~local uid with | Some decl -> locOfItemDeclaration decl | None -> None -let moduleBindingLocOfUid ~currentCmtFile ~local uid = - match declOfUid ~currentCmtFile ~local uid with +let moduleBindingLocOfUid ~currentCmtFile ~imports ~local uid = + match declOfUid ~currentCmtFile ~imports ~local uid with | Some (Typedtree.Module_binding {mb_name = {loc}}) -> Some loc | _ -> None + +let moduleTypeOfUid ~currentCmtFile ~imports ~local uid = + match declOfUid ~currentCmtFile ~imports ~local uid with + | Some (Typedtree.Module_type {mtd_type = Some {mty_type}}) -> Some mty_type + | _ -> None #endif let extractValueDependencies ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) = @@ -431,7 +457,9 @@ let extractValueDependencies ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) = Shape.Uid.Tbl.replace local uid decl) cmti_infos.cmt_uid_to_decl with _ -> ()); - let loc_of_uid = locOfUid ~currentCmtFile:cmtFilePath ~local in + let loc_of_uid = + locOfUid ~currentCmtFile:cmtFilePath ~imports:cmt_infos.cmt_imports ~local + 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 @@ -473,6 +501,9 @@ type identResolutions = { moduleDefLoc : Location.t -> string -> Location.t option; (** occurrence location, last name -> location of the module binding's name, for a module (e.g. a functor) defined with [module X = ...] *) + moduleTypeOf : Location.t -> string -> Types.module_type option; + (** occurrence location, last name -> the module type a + [module type X = ...] declaration denotes *) } let emptyIdentResolutions = @@ -482,6 +513,7 @@ let emptyIdentResolutions = projValue = (fun _ _ -> None); projModule = (fun _ _ -> None); moduleDefLoc = (fun _ _ -> None); + moduleTypeOf = (fun _ _ -> None); } #if OCAML_VERSION >= (5, 3, 0) @@ -510,12 +542,16 @@ let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : let fuel = 10 let read_unit_shape ~unit_name = - match loadUnitInfo ~currentCmtFile:cmtFilePath unit_name with + match + loadUnitInfo ~currentCmtFile:cmtFilePath ~imports:cmt_infos.cmt_imports + unit_name + with | Some {shape} -> shape | None -> None end) in let local = cmt_infos.cmt_uid_to_decl in - let locOfUid = locOfUid ~currentCmtFile:cmtFilePath ~local in + let imports = cmt_infos.cmt_imports in + let locOfUid = locOfUid ~currentCmtFile:cmtFilePath ~imports ~local in let rec uidOfResult (result : Shape_reduce.result) = match result with | Resolved uid -> Some uid @@ -583,10 +619,20 @@ let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : | Some uid -> ( match Lazy.force uid with | Some uid -> - moduleBindingLocOfUid ~currentCmtFile:cmtFilePath ~local uid + moduleBindingLocOfUid ~currentCmtFile:cmtFilePath ~imports ~local + uid |> nonGhost | None -> None) | None -> None); + moduleTypeOf = + (fun loc name -> + match Hashtbl.find_opt moduleUids (key loc name) with + | Some uid -> ( + match Lazy.force uid with + | Some uid -> + moduleTypeOfUid ~currentCmtFile:cmtFilePath ~imports ~local uid + | None -> None) + | None -> None); } #else let _ = (cmtFilePath, cmt_infos) in diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 61e958eb..6b67b92d 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -133,6 +133,21 @@ type delayedApplication = { let delayedApplications : delayedApplication list ref = ref [] +(* The module path an argument or functor expression denotes, through any + [( M : S )] constraints. *) +let rec moduleIdent (moduleExpr : Typedtree.module_expr) = + match moduleExpr.mod_desc with + | Tmod_ident (path, lid) -> Some (path, lid) + | Tmod_constraint (inner, _, _, _) -> moduleIdent inner + | _ -> None + +(* The next functor expression physically equal to the first component gets + the second as its key: the module binding's name for named functors, and + the enclosing functor's key for curried parameters. Other functors (inline + applications) are keyed by their own position. *) +let functorChainNext : (Typedtree.module_expr * Lexing.position) option ref = + ref None + let rec pathComponents (path : Path.t) = match path with | Pident _ -> Some [] @@ -552,13 +567,26 @@ let rec processSignatureItem ~doTypes ~doValues ~moduleLoc ~path | None -> ()) | _ -> () +(* The type of a functor argument, with an explicit constraint by a named + module type [(M : Other.S)] expanded to that module type's signature: the + typed tree leaves it as [Mty_ident], which exposes no items. *) +let rec argumentModuleType (argumentExpr : Typedtree.module_expr) = + match (argumentExpr.mod_desc, argumentExpr.mod_type) with + | ( Tmod_constraint + (_, _, Tmodtype_explicit {mty_desc = Tmty_ident (path, lid)}, _), + Mty_ident _ ) -> ( + match !identResolutions.moduleTypeOf lid.loc (Path.last path) with + | Some moduleType -> moduleType + | None -> argumentExpr.mod_type) + | Tmod_constraint (inner, _, _, _), Mty_ident _ -> argumentModuleType inner + | _ -> argumentExpr.mod_type + (* Implementation of a value of an actual functor argument, by path. *) let argumentItemResolver (argumentExpr : Typedtree.module_expr) = let shape = - match argumentExpr.mod_desc with - | Tmod_ident (path, lid) -> - !identResolutions.moduleShape lid.loc (Path.last path) - | _ -> None + match moduleIdent argumentExpr with + | Some (path, lid) -> !identResolutions.moduleShape lid.loc (Path.last path) + | None -> None in let resolutions = !identResolutions in let rec viaShape shape components = @@ -588,13 +616,14 @@ let argumentItemResolver (argumentExpr : Typedtree.module_expr) = | None -> None) | None -> None) in + let moduleType = argumentModuleType argumentExpr in fun components -> match shape with | Some shape -> ( match viaShape shape components with | Some loc -> Some loc - | None -> viaSignature argumentExpr.mod_type components) - | None -> viaSignature argumentExpr.mod_type components + | None -> viaSignature moduleType components) + | None -> viaSignature moduleType components (* Applications already recorded as part of an outer curried application. *) let recordedApplications = ref PosSet.empty @@ -610,24 +639,26 @@ let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = recordedApplications := PosSet.add e.mod_loc.loc_start !recordedApplications; flatten functorExpr (argumentExpr :: args) - | Tmod_ident (path, lid) -> Some (path, lid, args) + | Tmod_constraint (inner, _, _, _) -> flatten inner args + | Tmod_ident (path, lid) -> + Some (!identResolutions.moduleDefLoc lid.loc (Path.last path), args) + | Tmod_functor _ -> + (* Inline functor: keyed by its own position, see [functorChainNext]. *) + Some (Some e.mod_loc, args) | _ -> None in match flatten moduleExpr [] with - | Some (path, lid, args) -> ( - match !identResolutions.moduleDefLoc lid.loc (Path.last path) with - | Some defLoc -> - args - |> List.iteri (fun argIndex argumentExpr -> - delayedApplications := - { - appliedFunctor = defLoc.loc_start; - argIndex; - resolveItem = argumentItemResolver argumentExpr; - } - :: !delayedApplications) - | None -> ()) - | None -> () + | Some (Some defLoc, args) -> + args + |> List.iteri (fun argIndex argumentExpr -> + delayedApplications := + { + appliedFunctor = defLoc.loc_start; + argIndex; + resolveItem = argumentItemResolver argumentExpr; + } + :: !delayedApplications) + | _ -> () (* Traverse the AST *) let traverseStructure ~doTypes ~doExternals = @@ -637,15 +668,27 @@ let traverseStructure ~doTypes ~doExternals = let module_expr self (moduleExpr : Typedtree.module_expr) = let oldFunctorParameters = !functorParameters in (match moduleExpr.mod_desc with - | Tmod_functor (Named (Some id, _, _), _) -> - let functorDef = !currentModuleBindingPos in + | Tmod_functor (param, body) -> + let functorDef = + match !functorChainNext with + | Some (next, pos) when next == moduleExpr -> pos + | _ -> moduleExpr.mod_loc.loc_start + in + functorChainNext := Some (body, functorDef); let paramIndex = !functorParameters |> List.filter (fun p -> p.functorDef = functorDef) |> List.length in - functorParameters := - {paramId = id; functorDef; paramIndex} :: !functorParameters + (match param with + | Named (Some id, _, _) -> + functorParameters := + {paramId = id; functorDef; paramIndex} :: !functorParameters + | _ -> + (* Unnamed or unit parameter: still occupies an index. *) + functorParameters := + {paramId = Ident.create_local "_"; functorDef; paramIndex} + :: !functorParameters) | _ -> ()); (match moduleExpr.mod_desc with | Tmod_apply (_functorExpr, argumentExpr, coercion) -> @@ -653,14 +696,23 @@ let traverseStructure ~doTypes ~doExternals = value exposed by the actual argument module. When the argument is a module path, its shape lets the references target that module's implementation rather than a shared module type item. *) + let ident = moduleIdent argumentExpr in let shape = - match argumentExpr.mod_desc with - | Tmod_ident (path, lid) -> + match ident with + | Some (path, lid) -> !identResolutions.moduleShape lid.loc (Path.last path) - | _ -> None + | None -> None + in + (* A constraint node [(M : S)] can carry a ghost location, which would + drop the references: use the module path's own location then. *) + let locFrom = + match ident with + | Some (_, lid) when not lid.loc.loc_ghost -> lid.loc + | _ when not argumentExpr.mod_loc.loc_ghost -> argumentExpr.mod_loc + | _ -> moduleExpr.mod_loc in - addCoercedModuleValueReferences ~locFrom:argumentExpr.mod_loc ~coercion - ?shape ~actualType:argumentExpr.mod_type (); + addCoercedModuleValueReferences ~locFrom ~coercion ?shape + ~actualType:(argumentModuleType argumentExpr) (); recordFunctorApplication moduleExpr | _ -> ()); let r = super.Tast_mapper.module_expr self moduleExpr in @@ -674,6 +726,7 @@ let traverseStructure ~doTypes ~doExternals = (match structureItem.str_desc with | Tstr_module {mb_expr; mb_id; mb_loc; mb_name} -> ( currentModuleBindingPos := mb_name.loc.loc_start; + functorChainNext := Some (mb_expr, mb_name.loc.loc_start); let hasInterface = match mb_expr.mod_desc with Tmod_constraint _ -> true | _ -> false in From 79af1458b5debcb7cca3fea93fe8b06aaed2c600 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 14:08:17 +0000 Subject: [PATCH 06/53] Address review: cache key digest, conservative crediting, constrained functors, app identity - Include the consumer's import digest in the unit-info cache key. - A parameter call credited at an application whose argument resolves only to a module type item (no shape) is forwarded to that item's implementations rather than discarded. Without shape resolution at all (before OCaml 5.3) parameter references stay forwardable, as the functor cannot be identified. - Carry the module binding's key through a Tmod_constraint wrapper, so functors with a whole-functor signature credit their parameter calls. - Deduplicate curried applications by node identity, not position. Regression case: Apply_sig, a functor with an explicit functor signature. --- examples/regression/src/Main.ml | 3 +- .../regression/src/Shared_signature_arg.ml | 20 +++++++++++++ scripts/run_integration_tests.js | 23 +++++++++++---- src/Compat.ml | 29 +++++++++++++++---- src/DeadOptionalArgs.ml | 7 +++-- src/DeadValue.ml | 23 ++++++++++----- 6 files changed, 84 insertions(+), 21 deletions(-) diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index a588a86d..547f29ba 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -9,4 +9,5 @@ let () = Shared_signature_use.run (); Shared_signature_arg.run (); Shared_signature_arg.run_more (); - Shared_signature_arg.run_even_more () + Shared_signature_arg.run_even_more (); + Shared_signature_arg.run_sig () diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml index 4919806e..ea0063e3 100644 --- a/examples/regression/src/Shared_signature_arg.ml +++ b/examples/regression/src/Shared_signature_arg.ml @@ -85,3 +85,23 @@ let run_even_more () = ignore (Applied_constrained.run () + Applied_inline.run () + Applied_constrained_value.run ()) + +(* Named functor with a whole-functor signature: the binding expression is a + constraint around the functor. *) +module Opt_sigfun : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Apply_sig : functor (M : Shared_signature.O) -> sig + val run : unit -> int +end = +functor + (M : Shared_signature.O) + -> + struct + let run () = M.g ~x:1 () + end + +module Applied_sig = Apply_sig (Opt_sigfun) + +let run_sig () = ignore (Applied_sig.run ()) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index 527906b3..6a456876 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -122,11 +122,12 @@ function runRegressionTests() { assertNotIncludes(output, "Dead Value +Shared_signature_arg.Chosen.+f"); assertIncludes(output, "Live Value +Shared_signature_arg.Local_used.+f"); assertNotIncludes(output, "Dead Value +Shared_signature_arg.Local_used.+f"); - // A call through a functor parameter supplying ?x must not be attributed to - // other implementations of the module type item. - assertIncludes( + // A call through a functor parameter is credited to the actual argument + // (conservatively, to every implementation of the item, before OCaml 5.3): + // x must never be reported unused. + assertNotIncludes( output, - "optional argument x of function Opt_direct.+g is never used" + "optional argument x of function Opt_chosen.+g is never used" ); // Arguments wrapped in a constraint by a named module type are still used. assertIncludes(output, "Live Value +Shared_signature_arg.Chosen2.+f"); @@ -142,12 +143,22 @@ function runRegressionTests() { assertNotIncludes(output, "Live Value +Shared_signature_arg.Ignored.+f"); assertIncludes(output, "Dead Value +Shared_signature_arg.Local_unused.+f"); assertNotIncludes(output, "Live Value +Shared_signature_arg.Local_unused.+f"); - // A call through a functor parameter is credited to the actual argument, - // including through a constraint and for an inline functor. + // A call through a functor parameter supplying ?x must not be attributed + // to other implementations of the module type item. + assertIncludes( + output, + "optional argument x of function Opt_direct.+g is never used" + ); + // ... and is credited precisely, including through a constraint, for an + // inline functor, and for a functor with a whole-functor signature. assertIncludes( output, "optional argument x of function Opt_chosen.+g is always supplied" ); + assertIncludes( + output, + "optional argument x of function Opt_sigfun.+g is always supplied" + ); assertIncludes( output, "optional argument x of function Opt_constrained.+g is always supplied" diff --git a/src/Compat.ml b/src/Compat.ml index f9e672d4..3b9ff765 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -335,7 +335,8 @@ type unitInfo = { (* Keyed by the list of files a unit is loaded from, so that same-named units in different build targets (e.g. two unwrapped libraries each defining [Config]) do not share an entry. *) -let unitInfoCache : (string list, unitInfo) Hashtbl.t = Hashtbl.create 64 +let unitInfoCache : (string list * string option, unitInfo) Hashtbl.t = + Hashtbl.create 64 let candidateFilesForUnit ~currentCmtFile comp_unit = let dir = Filename.dirname currentCmtFile in @@ -368,7 +369,15 @@ let candidateFilesForUnit ~currentCmtFile comp_unit = dependency. *) let loadUnitInfo ~currentCmtFile ~(imports : Misc.crcs) comp_unit = let files = candidateFilesForUnit ~currentCmtFile comp_unit in - match Hashtbl.find_opt unitInfoCache files with + let digest = + match List.assoc_opt comp_unit imports with + | Some (Some digest) -> Some digest + | _ -> None + in + (* The digest takes part in the key: two consumers compiled against + different same-named units must not share an entry. *) + let cacheKey = (files, Option.map Digest.to_hex digest) in + match Hashtbl.find_opt unitInfoCache cacheKey with | Some info -> Some info | None -> ( match files with @@ -383,8 +392,8 @@ let loadUnitInfo ~currentCmtFile ~(imports : Misc.crcs) comp_unit = |> List.sort_uniq compare in let loaded = - match (dirs, List.assoc_opt comp_unit imports) with - | _ :: _ :: _, Some (Some digest) -> ( + match (dirs, digest) with + | _ :: _ :: _, Some digest -> ( match loaded |> List.filter (fun (_, (cmt_infos : Cmt_format.cmt_infos)) -> @@ -407,7 +416,7 @@ let loadUnitInfo ~currentCmtFile ~(imports : Misc.crcs) comp_unit = | None, Some _ -> shape := cmt_infos.cmt_impl_shape | _ -> ()); let info = {shape = !shape; uidToDecl} in - Hashtbl.replace unitInfoCache files info; + Hashtbl.replace unitInfoCache cacheKey info; Some info) let locOfItemDeclaration = function @@ -535,6 +544,16 @@ let rec findShapeByUid (shape : Shape.t) uid : Shape.t option = | _ -> None #endif +(* Whether occurrences can be resolved through shapes at all. Without it, + references through a functor parameter can only be credited conservatively, + to every implementation of the module type item. *) +let shapeResolutionAvailable = +#if OCAML_VERSION >= (5, 3, 0) + true +#else + false +#endif + let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : identResolutions = #if OCAML_VERSION >= (5, 3, 0) diff --git a/src/DeadOptionalArgs.ml b/src/DeadOptionalArgs.ml index 136c74e1..5250c422 100644 --- a/src/DeadOptionalArgs.ml +++ b/src/DeadOptionalArgs.ml @@ -71,12 +71,15 @@ let addReferences ~(locFrom : Location.t) ~(locTo : Location.t) (posFrom |> posToString)) (* A call through a functor parameter, credited to the implementation the - functor was applied to. *) + functor was applied to. When [posTo] could only be resolved to a module + type item rather than a declaration (no shapes, e.g. before OCaml 5.3, or + an argument without a resolvable shape), the call is forwarded to the + implementations of that item, conservatively. *) let addCallToImplementation ~(posTo : Lexing.position) (argNames, argNamesMaybe) = if active () then delayedItems := - {posTo; posToImpl = None; forwardable = false; argNames; argNamesMaybe} + {posTo; posToImpl = None; forwardable = true; argNames; argNamesMaybe} :: !delayedItems (* Once all declarations are known, calls whose target is not a declaration diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 6b67b92d..7d425d2a 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -203,7 +203,8 @@ let processOptionalArgs ~expType ~(locFrom : Location.t) ~locTo ?locToImpl | _ -> ()); call |> DeadOptionalArgs.addReferences ~locFrom ~locTo ?locToImpl - ~forwardable:(parameter = None) ~path) + ~forwardable:(parameter = None || not Compat.shapeResolutionAvailable) + ~path) (* Implementation locations of identifier occurrences resolved through shapes. See [Compat.resolveIdentOccurrences]. *) @@ -256,7 +257,7 @@ let addValueReferenceOrRedirect ~(locFrom : Location.t) ~(locTo : Location.t) ~path = let pair = (locTo.loc_start, (effectiveLocFrom locFrom).loc_start) in let locToImpl = findResolution ~identLoc:locFrom ~path in - (if isFunctorParameterPath path then + (if isFunctorParameterPath path && Compat.shapeResolutionAvailable then nonForwardableReferences := PosPairSet.add pair !nonForwardableReferences else if locToImpl = None && PosPairSet.mem pair !nonForwardableReferences then @@ -625,19 +626,19 @@ let argumentItemResolver (argumentExpr : Typedtree.module_expr) = | None -> viaSignature moduleType components) | None -> viaSignature moduleType components -(* Applications already recorded as part of an outer curried application. *) -let recordedApplications = ref PosSet.empty +(* Applications already recorded as part of an outer curried application, + by node identity (a ppx may emit distinct applications at one position). *) +let recordedApplications : Typedtree.module_expr list ref = ref [] (* [F (A) (B)] is [Tmod_apply (Tmod_apply (F, A), B)]: collect the functor and the arguments in order, and defer crediting the calls made through each parameter to the corresponding argument. *) let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = - if not (PosSet.mem moduleExpr.mod_loc.loc_start !recordedApplications) then + if not (List.memq moduleExpr !recordedApplications) then let rec flatten (e : Typedtree.module_expr) args = match e.mod_desc with | Tmod_apply (functorExpr, argumentExpr, _) -> - recordedApplications := - PosSet.add e.mod_loc.loc_start !recordedApplications; + recordedApplications := e :: !recordedApplications; flatten functorExpr (argumentExpr :: args) | Tmod_constraint (inner, _, _, _) -> flatten inner args | Tmod_ident (path, lid) -> @@ -668,6 +669,12 @@ let traverseStructure ~doTypes ~doExternals = let module_expr self (moduleExpr : Typedtree.module_expr) = let oldFunctorParameters = !functorParameters in (match moduleExpr.mod_desc with + | Tmod_constraint (inner, _, _, _) -> ( + (* [module F : FT = functor ...]: carry the binding's key through. *) + match !functorChainNext with + | Some (next, pos) when next == moduleExpr -> + functorChainNext := Some (inner, pos) + | _ -> ()) | Tmod_functor (param, body) -> let functorDef = match !functorChainNext with @@ -881,7 +888,9 @@ let processStructure ~cmt_value_dependencies ~cmt_ident_resolutions ~doTypes ~doExternals (structure : Typedtree.structure) = let traverseStructure = traverseStructure ~doTypes ~doExternals in identResolutions := cmt_ident_resolutions; + recordedApplications := []; structure |> traverseStructure.structure traverseStructure |> ignore; + recordedApplications := []; identResolutions := Compat.emptyIdentResolutions; let valueDependencies = cmt_value_dependencies |> List.rev in delayedValueDependencies := From fad9d64491cf07e02efc294057eac5769bdbb0f9 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 14:18:15 +0000 Subject: [PATCH 07/53] Address review: partial applications and let-module functors - When the head of an application is a module bound to a partial application (module G = F (A); G (B)), follow the binding to the head functor and offset the argument index by the arguments already consumed, so calls through F's later parameters are credited to B. - Key functors bound with let module by their binding (Texp_letmodule before OCaml 5.5; Texp_struct_item goes through the Tstr_module hook from 5.5 on). Regression cases: Apply2 partially applied, Apply_local via let module. --- examples/regression/src/Main.ml | 3 +- .../regression/src/Shared_signature_arg.ml | 26 +++++++++++ scripts/run_integration_tests.js | 9 ++++ src/Compat.ml | 28 ++++++++++- src/DeadValue.ml | 46 +++++++++++++++---- 5 files changed, 100 insertions(+), 12 deletions(-) diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 547f29ba..0d1fc529 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -10,4 +10,5 @@ let () = Shared_signature_arg.run (); Shared_signature_arg.run_more (); Shared_signature_arg.run_even_more (); - Shared_signature_arg.run_sig () + Shared_signature_arg.run_sig (); + Shared_signature_arg.run_partial () diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml index ea0063e3..f3a3278b 100644 --- a/examples/regression/src/Shared_signature_arg.ml +++ b/examples/regression/src/Shared_signature_arg.ml @@ -105,3 +105,29 @@ functor module Applied_sig = Apply_sig (Opt_sigfun) let run_sig () = ignore (Applied_sig.run ()) + +(* Curried functor, partially applied and named before the second argument. *) +module Opt_partial : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Apply2 (A : Shared_signature.S) (B : Shared_signature.O) = struct + let run () = A.f () + B.g ~x:1 () +end + +module Apply2_partial = Apply2 (Chosen) +module Applied_partial = Apply2_partial (Opt_partial) + +(* Functor bound with [let module]. *) +module Opt_letmodule : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +let run_local () = + let module Apply_local (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () + end in + let module Applied_local = Apply_local (Opt_letmodule) in + Applied_local.run () + +let run_partial () = ignore (Applied_partial.run () + run_local ()) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index 6a456876..371b1ef7 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -159,6 +159,15 @@ function runRegressionTests() { output, "optional argument x of function Opt_sigfun.+g is always supplied" ); + // ... through a named partial application, and for a let-module functor. + assertIncludes( + output, + "optional argument x of function Opt_partial.+g is always supplied" + ); + assertIncludes( + output, + "optional argument x of function Opt_letmodule.+g is always supplied" + ); assertIncludes( output, "optional argument x of function Opt_constrained.+g is always supplied" diff --git a/src/Compat.ml b/src/Compat.ml index 3b9ff765..51195b77 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -441,11 +441,17 @@ let locOfUid ~currentCmtFile ~imports ~local uid = | Some decl -> locOfItemDeclaration decl | None -> None -let moduleBindingLocOfUid ~currentCmtFile ~imports ~local uid = +let moduleBindingOfUid ~currentCmtFile ~imports ~local uid = match declOfUid ~currentCmtFile ~imports ~local uid with - | Some (Typedtree.Module_binding {mb_name = {loc}}) -> Some loc + | Some (Typedtree.Module_binding {mb_name = {loc}; mb_expr}) -> + Some (loc, mb_expr) | _ -> None +let moduleBindingLocOfUid ~currentCmtFile ~imports ~local uid = + match moduleBindingOfUid ~currentCmtFile ~imports ~local uid with + | Some (loc, _) -> Some loc + | None -> None + let moduleTypeOfUid ~currentCmtFile ~imports ~local uid = match declOfUid ~currentCmtFile ~imports ~local uid with | Some (Typedtree.Module_type {mtd_type = Some {mty_type}}) -> Some mty_type @@ -513,6 +519,10 @@ type identResolutions = { moduleTypeOf : Location.t -> string -> Types.module_type option; (** occurrence location, last name -> the module type a [module type X = ...] declaration denotes *) + moduleDefinition : + Location.t -> string -> (Location.t * Typedtree.module_expr) option; + (** occurrence location, last name -> the module binding's name location + and expression *) } let emptyIdentResolutions = @@ -523,6 +533,7 @@ let emptyIdentResolutions = projModule = (fun _ _ -> None); moduleDefLoc = (fun _ _ -> None); moduleTypeOf = (fun _ _ -> None); + moduleDefinition = (fun _ _ -> None); } #if OCAML_VERSION >= (5, 3, 0) @@ -652,6 +663,19 @@ let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : moduleTypeOfUid ~currentCmtFile:cmtFilePath ~imports ~local uid | None -> None) | None -> None); + moduleDefinition = + (fun loc name -> + match Hashtbl.find_opt moduleUids (key loc name) with + | Some uid -> ( + match Lazy.force uid with + | Some uid -> ( + match + moduleBindingOfUid ~currentCmtFile:cmtFilePath ~imports ~local uid + with + | Some (loc, _) when loc.loc_ghost -> None + | def -> def) + | None -> None) + | None -> None); } #else let _ = (cmtFilePath, cmt_infos) in diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 7d425d2a..c535b6d5 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -269,6 +269,15 @@ let addValueReferenceOrRedirect ~(locFrom : Location.t) ~(locTo : Location.t) let rec collectExpr super self (e : Typedtree.expression) = let locFrom = e.exp_loc in + (* [let module F (M : S) = ... in]: key the functor by its binding. On + OCaml >= 5.5 this is a [Texp_struct_item] holding a [Tstr_module], which + the structure item handler covers. *) + #if OCAML_VERSION < (5, 5, 0) + (match e.exp_desc with + | Texp_letmodule (_, name, _, moduleExpr, _) -> + functorChainNext := Some (moduleExpr, name.loc.loc_start) + | _ -> ()); + #endif (match e.exp_desc with | Texp_ident (_path, _, {Types.val_loc = {loc_ghost = false; _} as locTo}) -> @@ -635,31 +644,50 @@ let recordedApplications : Typedtree.module_expr list ref = ref [] parameter to the corresponding argument. *) let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = if not (List.memq moduleExpr !recordedApplications) then + (* The arguments of this application chain, and its head. *) let rec flatten (e : Typedtree.module_expr) args = match e.mod_desc with | Tmod_apply (functorExpr, argumentExpr, _) -> recordedApplications := e :: !recordedApplications; flatten functorExpr (argumentExpr :: args) | Tmod_constraint (inner, _, _, _) -> flatten inner args - | Tmod_ident (path, lid) -> - Some (!identResolutions.moduleDefLoc lid.loc (Path.last path), args) + | _ -> (e, args) + in + (* The key of the functor a head denotes, and the number of arguments + already consumed by partial applications it stands for, as in + [module G = F (A)] followed by [G (B)]. *) + let rec headKey (e : Typedtree.module_expr) = + match e.mod_desc with + | Tmod_apply (functorExpr, _, _) -> ( + match headKey functorExpr with + | Some (key, consumed) -> Some (key, consumed + 1) + | None -> None) + | Tmod_constraint (inner, _, _, _) -> headKey inner | Tmod_functor _ -> (* Inline functor: keyed by its own position, see [functorChainNext]. *) - Some (Some e.mod_loc, args) + Some (e.mod_loc.loc_start, 0) + | Tmod_ident (path, lid) -> ( + match !identResolutions.moduleDefinition lid.loc (Path.last path) with + | Some (nameLoc, definition) -> ( + match (moduleIdent definition, definition.mod_desc) with + | None, Tmod_apply _ -> headKey definition + | _ -> Some (nameLoc.loc_start, 0)) + | None -> None) | _ -> None in - match flatten moduleExpr [] with - | Some (Some defLoc, args) -> + let head, args = flatten moduleExpr [] in + match headKey head with + | Some (key, consumed) -> args - |> List.iteri (fun argIndex argumentExpr -> + |> List.iteri (fun i argumentExpr -> delayedApplications := { - appliedFunctor = defLoc.loc_start; - argIndex; + appliedFunctor = key; + argIndex = consumed + i; resolveItem = argumentItemResolver argumentExpr; } :: !delayedApplications) - | _ -> () + | None -> () (* Traverse the AST *) let traverseStructure ~doTypes ~doExternals = From 516e81f3b8388a2a1cd9357b4f18f7bef6942da5 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 14:25:57 +0000 Subject: [PATCH 08/53] Fix let-module functor keys on OCaml 5.3 and 5.4 Two problems specific to versions where let module is Texp_letmodule: - The mapper visits a binding's body before its module expression, so a nested let module overwrote the single pending-key slot. Functor keys are now a list keyed by node identity. - Such bindings are not registered as module binding declarations, so applications could not find them by uid. They are also keyed by their identifier. Also adds debug logging of functor applications and parameter calls. --- src/DeadValue.ml | 80 ++++++++++++++++++++++++++++++++++++------------ 1 file changed, 60 insertions(+), 20 deletions(-) diff --git a/src/DeadValue.ml b/src/DeadValue.ml index c535b6d5..f31f5954 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -141,12 +141,25 @@ let rec moduleIdent (moduleExpr : Typedtree.module_expr) = | Tmod_constraint (inner, _, _, _) -> moduleIdent inner | _ -> None -(* The next functor expression physically equal to the first component gets - the second as its key: the module binding's name for named functors, and - the enclosing functor's key for curried parameters. Other functors (inline - applications) are keyed by their own position. *) -let functorChainNext : (Typedtree.module_expr * Lexing.position) option ref = - ref None +(* Keys of functor expressions, by node identity: the module binding's name + for named functors, and the enclosing functor's key for curried parameters. + Functors not listed (inline applications) are keyed by their own position. + A list rather than a single slot, as the mapper may visit a binding's body + (and the bindings nested in it) before its module expression. *) +let functorKeys : (Typedtree.module_expr * Lexing.position) list ref = ref [] + +let setFunctorKey (moduleExpr : Typedtree.module_expr) pos = + functorKeys := (moduleExpr, pos) :: !functorKeys + +let findFunctorKey (moduleExpr : Typedtree.module_expr) = + match List.find_opt (fun (e, _) -> e == moduleExpr) !functorKeys with + | Some (_, pos) -> Some pos + | None -> None + +(* Functors bound with [let module], by identifier: such bindings are not + registered as declarations before OCaml 5.5, so applications cannot find + them by uid. *) +let letModuleFunctors : (Ident.t * Lexing.position) list ref = ref [] let rec pathComponents (path : Path.t) = match path with @@ -194,6 +207,11 @@ let processOptionalArgs ~expType ~(locFrom : Location.t) ~locTo ?locToImpl (match (parameter, pathComponents path) with | Some {functorDef; paramIndex}, Some components -> let key = (functorDef, paramIndex, components) in + if !Common.Cli.debug then + Log_.item "parameterCall %s functor:%s index:%d@." + (String.concat "." components) + (functorDef |> posToString) + paramIndex; let calls = match Hashtbl.find_opt parameterCalls key with | Some calls -> calls @@ -274,8 +292,11 @@ let rec collectExpr super self (e : Typedtree.expression) = the structure item handler covers. *) #if OCAML_VERSION < (5, 5, 0) (match e.exp_desc with - | Texp_letmodule (_, name, _, moduleExpr, _) -> - functorChainNext := Some (moduleExpr, name.loc.loc_start) + | Texp_letmodule (id, name, _, moduleExpr, _) -> + setFunctorKey moduleExpr name.loc.loc_start; + (match id with + | Some id -> letModuleFunctors := (id, name.loc.loc_start) :: !letModuleFunctors + | None -> ()) | _ -> ()); #endif (match e.exp_desc with @@ -664,7 +685,7 @@ let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = | None -> None) | Tmod_constraint (inner, _, _, _) -> headKey inner | Tmod_functor _ -> - (* Inline functor: keyed by its own position, see [functorChainNext]. *) + (* Inline functor: keyed by its own position, see [functorKeys]. *) Some (e.mod_loc.loc_start, 0) | Tmod_ident (path, lid) -> ( match !identResolutions.moduleDefinition lid.loc (Path.last path) with @@ -672,11 +693,28 @@ let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = match (moduleIdent definition, definition.mod_desc) with | None, Tmod_apply _ -> headKey definition | _ -> Some (nameLoc.loc_start, 0)) - | None -> None) + | None -> ( + match + List.find_opt + (fun (id, _) -> Ident.same id (Path.head path)) + !letModuleFunctors + with + | Some (_, pos) -> Some (pos, 0) + | None -> None + | exception _ -> None)) | _ -> None in let head, args = flatten moduleExpr [] in - match headKey head with + let key = headKey head in + if !Common.Cli.debug then + Log_.item "functorApplication %s key:%s args:%d@." + (moduleExpr.mod_loc.loc_start |> posToString) + (match key with + | Some (pos, consumed) -> + Printf.sprintf "%s+%d" (pos |> posToString) consumed + | None -> "none") + (List.length args); + match key with | Some (key, consumed) -> args |> List.iteri (fun i argumentExpr -> @@ -699,17 +737,16 @@ let traverseStructure ~doTypes ~doExternals = (match moduleExpr.mod_desc with | Tmod_constraint (inner, _, _, _) -> ( (* [module F : FT = functor ...]: carry the binding's key through. *) - match !functorChainNext with - | Some (next, pos) when next == moduleExpr -> - functorChainNext := Some (inner, pos) - | _ -> ()) + match findFunctorKey moduleExpr with + | Some pos -> setFunctorKey inner pos + | None -> ()) | Tmod_functor (param, body) -> let functorDef = - match !functorChainNext with - | Some (next, pos) when next == moduleExpr -> pos - | _ -> moduleExpr.mod_loc.loc_start + match findFunctorKey moduleExpr with + | Some pos -> pos + | None -> moduleExpr.mod_loc.loc_start in - functorChainNext := Some (body, functorDef); + setFunctorKey body functorDef; let paramIndex = !functorParameters |> List.filter (fun p -> p.functorDef = functorDef) @@ -761,7 +798,7 @@ let traverseStructure ~doTypes ~doExternals = (match structureItem.str_desc with | Tstr_module {mb_expr; mb_id; mb_loc; mb_name} -> ( currentModuleBindingPos := mb_name.loc.loc_start; - functorChainNext := Some (mb_expr, mb_name.loc.loc_start); + setFunctorKey mb_expr mb_name.loc.loc_start; let hasInterface = match mb_expr.mod_desc with Tmod_constraint _ -> true | _ -> false in @@ -917,8 +954,11 @@ let processStructure ~cmt_value_dependencies ~cmt_ident_resolutions ~doTypes let traverseStructure = traverseStructure ~doTypes ~doExternals in identResolutions := cmt_ident_resolutions; recordedApplications := []; + letModuleFunctors := []; + functorKeys := []; structure |> traverseStructure.structure traverseStructure |> ignore; recordedApplications := []; + functorKeys := []; identResolutions := Compat.emptyIdentResolutions; let valueDependencies = cmt_value_dependencies |> List.rev in delayedValueDependencies := From 130f9713ed93013e92f344c32c30b18ce8be5f48 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 14:29:26 +0000 Subject: [PATCH 09/53] Address review: parameter aliases and recursive functors - module N = M (or M.Sub) inside a functor body, where M is a parameter, makes N stand for the parameter: calls through N are parameter calls, with the alias path prefixed. - Recursive module functors get their binding key, and are also keyed by identifier since their occurrences carry no uid. Regression cases: Apply_alias, Apply_rec. --- examples/regression/src/Main.ml | 3 +- .../regression/src/Shared_signature_arg.ml | 37 ++++++++++++ scripts/run_integration_tests.js | 14 +++++ src/DeadValue.ml | 56 +++++++++++++++---- 4 files changed, 99 insertions(+), 11 deletions(-) diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 0d1fc529..7d4b606b 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -11,4 +11,5 @@ let () = Shared_signature_arg.run_more (); Shared_signature_arg.run_even_more (); Shared_signature_arg.run_sig (); - Shared_signature_arg.run_partial () + Shared_signature_arg.run_partial (); + Shared_signature_arg.run_alias () diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml index f3a3278b..65d96e21 100644 --- a/examples/regression/src/Shared_signature_arg.ml +++ b/examples/regression/src/Shared_signature_arg.ml @@ -131,3 +131,40 @@ let run_local () = Applied_local.run () let run_partial () = ignore (Applied_partial.run () + run_local ()) + +(* Alias of the parameter inside the body: [N.g] is a parameter call. *) +module Opt_alias : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_alias_other : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Apply_alias (M : Shared_signature.O) = struct + module N = M + + let run () = N.g ~x:1 () +end + +module Applied_alias = Apply_alias (Opt_alias) + +(* Recursive functor. *) +module Opt_rec : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module rec Apply_rec : functor (M : Shared_signature.O) -> sig + val run : unit -> int +end = +functor + (M : Shared_signature.O) + -> + struct + let run () = M.g ~x:1 () + end + +module Applied_rec = Apply_rec (Opt_rec) + +let run_alias () = + ignore (Applied_alias.run () + Applied_rec.run () + Opt_alias_other.g ()) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index 371b1ef7..90d9b6f7 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -168,6 +168,20 @@ function runRegressionTests() { output, "optional argument x of function Opt_letmodule.+g is always supplied" ); + // ... through an alias of the parameter, and for a recursive functor. The + // aliased call must not leak to another implementation. + assertIncludes( + output, + "optional argument x of function Opt_alias.+g is always supplied" + ); + assertIncludes( + output, + "optional argument x of function Opt_alias_other.+g is never used" + ); + assertIncludes( + output, + "optional argument x of function Opt_rec.+g is always supplied" + ); assertIncludes( output, "optional argument x of function Opt_constrained.+g is always supplied" diff --git a/src/DeadValue.ml b/src/DeadValue.ml index f31f5954..5dbeb189 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -100,6 +100,9 @@ type functorParameter = { functorDef : Lexing.position; (** position of the name of the module binding defining the functor *) paramIndex : int; (** position of the parameter, for curried functors *) + prefix : string list; + (** for an alias of (a submodule of) a parameter, [module N = M.Sub], + the path from the parameter: ["Sub"] *) } let functorParameters : functorParameter list ref = ref [] @@ -156,10 +159,10 @@ let findFunctorKey (moduleExpr : Typedtree.module_expr) = | Some (_, pos) -> Some pos | None -> None -(* Functors bound with [let module], by identifier: such bindings are not - registered as declarations before OCaml 5.5, so applications cannot find - them by uid. *) -let letModuleFunctors : (Ident.t * Lexing.position) list ref = ref [] +(* Functors that applications in the same file cannot find by uid, keyed by + identifier: [let module] bindings (not registered as declarations before + OCaml 5.5) and recursive modules (whose occurrences have no uid). *) +let functorsByIdent : (Ident.t * Lexing.position) list ref = ref [] let rec pathComponents (path : Path.t) = match path with @@ -170,6 +173,26 @@ let rec pathComponents (path : Path.t) = | None -> None) | _ -> None +(* [module N = M] or [module N = M.Sub] inside a functor body, where [M] is a + parameter: [N] then stands for the parameter too. *) +let registerParameterAlias (id : Ident.t option) + (moduleExpr : Typedtree.module_expr) = + let rec ident (e : Typedtree.module_expr) = + match e.mod_desc with + | Tmod_ident (path, _) -> Some path + | Tmod_constraint (inner, _, _, _) -> ident inner + | _ -> None + in + match (id, ident moduleExpr) with + | Some id, Some path -> ( + match (findFunctorParameter path, pathComponents path) with + | Some p, Some components -> + functorParameters := + {p with paramId = id; prefix = p.prefix @ components} + :: !functorParameters + | _ -> ()) + | _ -> () + let processOptionalArgs ~expType ~(locFrom : Location.t) ~locTo ?locToImpl ~path args = let args = @@ -205,7 +228,8 @@ let processOptionalArgs ~expType ~(locFrom : Location.t) ~locTo ?locToImpl let call = (!supplied, !suppliedMaybe) in let parameter = findFunctorParameter path in (match (parameter, pathComponents path) with - | Some {functorDef; paramIndex}, Some components -> + | Some {functorDef; paramIndex; prefix}, Some components -> + let components = prefix @ components in let key = (functorDef, paramIndex, components) in if !Common.Cli.debug then Log_.item "parameterCall %s functor:%s index:%d@." @@ -294,8 +318,9 @@ let rec collectExpr super self (e : Typedtree.expression) = (match e.exp_desc with | Texp_letmodule (id, name, _, moduleExpr, _) -> setFunctorKey moduleExpr name.loc.loc_start; + registerParameterAlias id moduleExpr; (match id with - | Some id -> letModuleFunctors := (id, name.loc.loc_start) :: !letModuleFunctors + | Some id -> functorsByIdent := (id, name.loc.loc_start) :: !functorsByIdent | None -> ()) | _ -> ()); #endif @@ -697,7 +722,7 @@ let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = match List.find_opt (fun (id, _) -> Ident.same id (Path.head path)) - !letModuleFunctors + !functorsByIdent with | Some (_, pos) -> Some (pos, 0) | None -> None @@ -755,11 +780,12 @@ let traverseStructure ~doTypes ~doExternals = (match param with | Named (Some id, _, _) -> functorParameters := - {paramId = id; functorDef; paramIndex} :: !functorParameters + {paramId = id; functorDef; paramIndex; prefix = []} + :: !functorParameters | _ -> (* Unnamed or unit parameter: still occupies an index. *) functorParameters := - {paramId = Ident.create_local "_"; functorDef; paramIndex} + {paramId = Ident.create_local "_"; functorDef; paramIndex; prefix = []} :: !functorParameters) | _ -> ()); (match moduleExpr.mod_desc with @@ -799,6 +825,7 @@ let traverseStructure ~doTypes ~doExternals = | Tstr_module {mb_expr; mb_id; mb_loc; mb_name} -> ( currentModuleBindingPos := mb_name.loc.loc_start; setFunctorKey mb_expr mb_name.loc.loc_start; + registerParameterAlias mb_id mb_expr; let hasInterface = match mb_expr.mod_desc with Tmod_constraint _ -> true | _ -> false in @@ -820,6 +847,15 @@ let traverseStructure ~doTypes ~doExternals = ((ModulePath.getCurrent ()).path @ [!Common.currentModuleName])) | _ -> ()) + | Tstr_recmodule moduleBindings -> + moduleBindings + |> List.iter (fun (mb : Typedtree.module_binding) -> + setFunctorKey mb.mb_expr mb.mb_name.loc.loc_start; + match mb.mb_id with + | Some id -> + functorsByIdent := + (id, mb.mb_name.loc.loc_start) :: !functorsByIdent + | None -> ()) | Tstr_primitive vd when doExternals && !Config.analyzeExternals -> let currentModulePath = ModulePath.getCurrent () in let path = currentModulePath.path @ [!Common.currentModuleName] in @@ -954,7 +990,7 @@ let processStructure ~cmt_value_dependencies ~cmt_ident_resolutions ~doTypes let traverseStructure = traverseStructure ~doTypes ~doExternals in identResolutions := cmt_ident_resolutions; recordedApplications := []; - letModuleFunctors := []; + functorsByIdent := []; functorKeys := []; structure |> traverseStructure.structure traverseStructure |> ignore; recordedApplications := []; From ed26678346429d3310bf932629be09e57c8a7668 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 14:42:56 +0000 Subject: [PATCH 10/53] Address review: fall back conservatively on ppx key collisions - Occurrences sharing a location key but spelled differently (distinct identifiers a ppx emitted at one position) are left unresolved rather than one winning: the written identifier cannot be matched against the typed path under open and aliases. - Functor keys are positions, since applications learn a definition only through its declaration's location. Two distinct definitions at one position make the key ambiguous, and it is not credited. - Skip identifiers through functor applications (F(X).t), on which Longident.flatten is fatal. Fixture now contains one. --- .../regression/src/Shared_signature_arg.ml | 6 +++++ src/Compat.ml | 27 ++++++++++++++++++- src/DeadValue.ml | 26 +++++++++++++++++- 3 files changed, 57 insertions(+), 2 deletions(-) diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml index 65d96e21..011a9d93 100644 --- a/examples/regression/src/Shared_signature_arg.ml +++ b/examples/regression/src/Shared_signature_arg.ml @@ -168,3 +168,9 @@ module Applied_rec = Apply_rec (Opt_rec) let run_alias () = ignore (Applied_alias.run () + Applied_rec.run () + Opt_alias_other.g ()) + +(* An identifier through a functor application, [F(X).t]: must not crash the + occurrence resolver. *) +module Set_of_ints = Set.Make (Int) + +let _apply_ident : Set.Make(Int).t = Set_of_ints.empty diff --git a/src/Compat.ml b/src/Compat.ml index 51195b77..7b88494a 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -592,11 +592,36 @@ let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : let values = Hashtbl.create 64 in let modules = Hashtbl.create 16 in let moduleUids = Hashtbl.create 16 in + (* Occurrences sharing a key but spelled differently (distinct identifiers + a ppx emitted at one position, e.g. [A.f] and [B.f]) cannot be told apart + from the typed tree, whose paths differ from the written identifiers under + [open] and aliases: such keys are left unresolved, conservatively. *) + (* [Longident.last] and [flatten] are fatal on [Lapply] ([F(X).t]): such + occurrences are not values or modules of interest here. *) + let lidText (lid : Longident.t) = + match Longident.flatten lid with + | components -> Some (String.concat "." components) + | exception Misc.Fatal_error -> None + in + let spelled = Hashtbl.create 64 in + let ambiguous = Hashtbl.create 4 in cmt_infos.cmt_ident_occurrences - |> List.iter (fun ((lid : Longident.t Location.loc), result) -> + |> List.iter (fun ((lid : Longident.t Location.loc), _) -> if not lid.loc.loc_ghost then + match lidText lid.txt with + | None -> () + | Some text -> ( + let k = key lid.loc (Longident.last lid.txt) in + match Hashtbl.find_opt spelled k with + | Some other when other <> text -> Hashtbl.replace ambiguous k () + | _ -> Hashtbl.replace spelled k text)); + cmt_infos.cmt_ident_occurrences + |> List.iter (fun ((lid : Longident.t Location.loc), result) -> + if (not lid.loc.loc_ghost) && lidText lid.txt <> None then let name = Longident.last lid.txt in let k = key lid.loc name in + if Hashtbl.mem ambiguous k then () + else match result with | Shape_reduce.Unresolved shape -> (* Definition in another unit: reduce lazily, as a value and as a diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 5dbeb189..a24e31c5 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -154,6 +154,22 @@ let functorKeys : (Typedtree.module_expr * Lexing.position) list ref = ref [] let setFunctorKey (moduleExpr : Typedtree.module_expr) pos = functorKeys := (moduleExpr, pos) :: !functorKeys +(* Keys must identify one functor definition. Applications only learn a + position (through the binding's declaration, possibly in another file), so + two distinct definitions a ppx emitted at one position cannot be told + apart: such keys are not credited at all, conservatively. *) +let functorKeyOwners : (Lexing.position, Typedtree.module_expr) Hashtbl.t = + Hashtbl.create 16 + +let ambiguousFunctorKeys = ref PosSet.empty + +let claimFunctorKey (moduleExpr : Typedtree.module_expr) pos = + match Hashtbl.find_opt functorKeyOwners pos with + | Some owner when owner != moduleExpr -> + ambiguousFunctorKeys := PosSet.add pos !ambiguousFunctorKeys + | Some _ -> () + | None -> Hashtbl.replace functorKeyOwners pos moduleExpr + let findFunctorKey (moduleExpr : Typedtree.module_expr) = match List.find_opt (fun (e, _) -> e == moduleExpr) !functorKeys with | Some (_, pos) -> Some pos @@ -318,6 +334,7 @@ let rec collectExpr super self (e : Typedtree.expression) = (match e.exp_desc with | Texp_letmodule (id, name, _, moduleExpr, _) -> setFunctorKey moduleExpr name.loc.loc_start; + claimFunctorKey moduleExpr name.loc.loc_start; registerParameterAlias id moduleExpr; (match id with | Some id -> functorsByIdent := (id, name.loc.loc_start) :: !functorsByIdent @@ -769,7 +786,9 @@ let traverseStructure ~doTypes ~doExternals = let functorDef = match findFunctorKey moduleExpr with | Some pos -> pos - | None -> moduleExpr.mod_loc.loc_start + | None -> + claimFunctorKey moduleExpr moduleExpr.mod_loc.loc_start; + moduleExpr.mod_loc.loc_start in setFunctorKey body functorDef; let paramIndex = @@ -825,6 +844,7 @@ let traverseStructure ~doTypes ~doExternals = | Tstr_module {mb_expr; mb_id; mb_loc; mb_name} -> ( currentModuleBindingPos := mb_name.loc.loc_start; setFunctorKey mb_expr mb_name.loc.loc_start; + claimFunctorKey mb_expr mb_name.loc.loc_start; registerParameterAlias mb_id mb_expr; let hasInterface = match mb_expr.mod_desc with Tmod_constraint _ -> true | _ -> false @@ -851,6 +871,7 @@ let traverseStructure ~doTypes ~doExternals = moduleBindings |> List.iter (fun (mb : Typedtree.module_binding) -> setFunctorKey mb.mb_expr mb.mb_name.loc.loc_start; + claimFunctorKey mb.mb_expr mb.mb_name.loc.loc_start; match mb.mb_id with | Some id -> functorsByIdent := @@ -969,6 +990,7 @@ let forceDelayedItems () = delayedApplications := []; applications |> List.iter (fun {appliedFunctor; argIndex; resolveItem} -> + if not (PosSet.mem appliedFunctor !ambiguousFunctorKeys) then Hashtbl.iter (fun (def, index, components) calls -> if def = appliedFunctor && index = argIndex then @@ -992,9 +1014,11 @@ let processStructure ~cmt_value_dependencies ~cmt_ident_resolutions ~doTypes recordedApplications := []; functorsByIdent := []; functorKeys := []; + Hashtbl.reset functorKeyOwners; structure |> traverseStructure.structure traverseStructure |> ignore; recordedApplications := []; functorKeys := []; + Hashtbl.reset functorKeyOwners; identResolutions := Compat.emptyIdentResolutions; let valueDependencies = cmt_value_dependencies |> List.rev in delayedValueDependencies := From 5a5e87277468257c932c8c46603fd1d838839236 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 15:37:35 +0000 Subject: [PATCH 11/53] Address review: indistinguishable units and occurrences resolve nothing - Same-named units across build directories with identical interfaces cannot be told apart by digest: load none rather than pick one. - Occurrences sharing a key count as one identifier only if spelled the same and resolved the same way by the compiler; otherwise the key is ambiguous and left unresolved. --- src/Compat.ml | 35 ++++++++++++++++++++++++++++++----- 1 file changed, 30 insertions(+), 5 deletions(-) diff --git a/src/Compat.ml b/src/Compat.ml index 7b88494a..e8dfc486 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -403,6 +403,17 @@ let loadUnitInfo ~currentCmtFile ~(imports : Misc.crcs) comp_unit = | matching -> matching) | _ -> loaded in + (* Candidates still spanning several build directories (same name and + same interface) cannot be told apart: resolve nothing rather than + redirect into the wrong target. *) + let loaded = + match + loaded |> List.map (fun (p, _) -> Filename.dirname p) + |> List.sort_uniq compare + with + | _ :: _ :: _ -> [] + | _ -> loaded + in let uidToDecl = Shape.Uid.Tbl.create 64 in let shape = ref None in loaded @@ -603,18 +614,32 @@ let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : | components -> Some (String.concat "." components) | exception Misc.Fatal_error -> None in + (* Two occurrences with one key are the same identifier only if they are + spelled the same and the compiler resolved them the same way (the same + spelling can resolve differently under distinct local opens). *) + let identity (lid : Longident.t) (result : Shape_reduce.result) = + match lidText lid with + | None -> None + | Some text -> + let resolution = + match result with + | Unresolved shape -> Format.asprintf "%a" Shape.print shape + | result -> Format.asprintf "%a" Shape_reduce.print_result result + in + Some (text ^ " " ^ resolution) + in let spelled = Hashtbl.create 64 in let ambiguous = Hashtbl.create 4 in cmt_infos.cmt_ident_occurrences - |> List.iter (fun ((lid : Longident.t Location.loc), _) -> + |> List.iter (fun ((lid : Longident.t Location.loc), result) -> if not lid.loc.loc_ghost then - match lidText lid.txt with + match identity lid.txt result with | None -> () - | Some text -> ( + | Some id -> ( let k = key lid.loc (Longident.last lid.txt) in match Hashtbl.find_opt spelled k with - | Some other when other <> text -> Hashtbl.replace ambiguous k () - | _ -> Hashtbl.replace spelled k text)); + | Some other when other <> id -> Hashtbl.replace ambiguous k () + | _ -> Hashtbl.replace spelled k id)); cmt_infos.cmt_ident_occurrences |> List.iter (fun ((lid : Longident.t Location.loc), result) -> if (not lid.loc.loc_ghost) && lidText lid.txt <> None then From b20f8f624d7b311bc998ea623bb5afd083a6b4f3 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 16:00:19 +0000 Subject: [PATCH 12/53] Address review: module type aliases, forwarded parameters, include of parameters - Expand module type aliases (module type S = Base) through shapes before reading a constrained argument's signature. - module Outer (M : S) = Inner (M): the coercion references and the parameter calls of the inner application are credited to the outer applications' arguments rather than broadcast to every implementation of S. Arguments that are parameters resolve through the enclosing functor's applications, transitively. - include M with M a parameter: the included identifiers stand for the parameter's items. - Declarations taken from a file's signature are restricted to the file's own definitions: items in another file or inside a module type come from includes (e.g. include T of a parameter re-exporting the module type's vals) and were only kept live by the internal coercions now credited precisely. Regression cases: Applied_alias_mt, Outer, Outer_opt, Apply_incl. --- examples/regression/src/Main.ml | 3 +- .../regression/src/Shared_signature_arg.ml | 56 ++++ scripts/run_integration_tests.js | 18 ++ src/Compat.ml | 51 +++ src/DeadCode.ml | 21 ++ src/DeadValue.ml | 292 ++++++++++++++---- 6 files changed, 373 insertions(+), 68 deletions(-) diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 7d4b606b..e014ac04 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -12,4 +12,5 @@ let () = Shared_signature_arg.run_even_more (); Shared_signature_arg.run_sig (); Shared_signature_arg.run_partial (); - Shared_signature_arg.run_alias () + Shared_signature_arg.run_alias (); + Shared_signature_arg.run_forwarded () diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml index 011a9d93..45b3526a 100644 --- a/examples/regression/src/Shared_signature_arg.ml +++ b/examples/regression/src/Shared_signature_arg.ml @@ -174,3 +174,59 @@ let run_alias () = module Set_of_ints = Set.Make (Int) let _apply_ident : Set.Make(Int).t = Set_of_ints.empty + +(* Argument constrained by an alias of the named module type. *) +module type S_alias = Shared_signature.S + +module Chosen3 : Shared_signature.S = struct + let f () = 9 +end + +module Ignored3 : Shared_signature.S = struct + let f () = 10 +end + +module Applied_alias_mt = Apply ((Chosen3 : S_alias)) + +(* A functor forwarding its parameter to another functor. *) +module Outer (M : Shared_signature.S) = Apply (M) + +module Chosen4 : Shared_signature.S = struct + let f () = 11 +end + +module Ignored4 : Shared_signature.S = struct + let f () = 12 +end + +module Applied_outer = Outer (Chosen4) + +module Outer_opt (M : Shared_signature.O) = Apply_opt (M) + +module Opt_outer : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Applied_outer_opt = Outer_opt (Opt_outer) + +(* [include M] then an unqualified call to an included member. *) +module Apply_incl (M : Shared_signature.O) = struct + include M + + let run () = g ~x:1 () +end + +module Opt_incl : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_incl_other : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Applied_incl = Apply_incl (Opt_incl) + +let run_forwarded () = + ignore + (Applied_alias_mt.run () + Applied_outer.run () + Applied_outer_opt.run () + + Applied_incl.run () + Opt_incl_other.g ()) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index 90d9b6f7..eab4d471 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -182,6 +182,24 @@ function runRegressionTests() { output, "optional argument x of function Opt_rec.+g is always supplied" ); + // Argument constrained by an alias of the module type; a functor + // forwarding its parameter to another functor; include of the parameter. + assertIncludes(output, "Live Value +Shared_signature_arg.Chosen3.+f"); + assertIncludes(output, "Dead Value +Shared_signature_arg.Ignored3.+f"); + assertIncludes(output, "Live Value +Shared_signature_arg.Chosen4.+f"); + assertIncludes(output, "Dead Value +Shared_signature_arg.Ignored4.+f"); + assertIncludes( + output, + "optional argument x of function Opt_outer.+g is always supplied" + ); + assertIncludes( + output, + "optional argument x of function Opt_incl.+g is always supplied" + ); + assertIncludes( + output, + "optional argument x of function Opt_incl_other.+g is never used" + ); assertIncludes( output, "optional argument x of function Opt_constrained.+g is always supplied" diff --git a/src/Compat.ml b/src/Compat.ml index e8dfc486..bafea82f 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -534,6 +534,9 @@ type identResolutions = { Location.t -> string -> (Location.t * Typedtree.module_expr) option; (** occurrence location, last name -> the module binding's name location and expression *) + expandModuleType : Types.module_type -> Types.module_type; + (** follow module type aliases ([module type S = Base]) until a signature + or an unresolvable name is reached *) } let emptyIdentResolutions = @@ -545,6 +548,7 @@ let emptyIdentResolutions = moduleDefLoc = (fun _ _ -> None); moduleTypeOf = (fun _ _ -> None); moduleDefinition = (fun _ _ -> None); + expandModuleType = (fun mt -> mt); } #if OCAML_VERSION >= (5, 3, 0) @@ -726,6 +730,53 @@ let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : | def -> def) | None -> None) | None -> None); + expandModuleType = + (let compUnitShape name = + {Shape.uid = None; desc = Comp_unit name; approximated = false} + in + (* Shape of a module path rooted at a compilation unit. *) + let rec moduleShapeOfPath (path : Path.t) = + match path with + | Pident id when Ident.global id -> Some (compUnitShape (Ident.name id)) + | Pdot (p, name) -> ( + match moduleShapeOfPath p with + | Some shape -> Some (Shape.proj shape (Shape.Item.make name Module)) + | None -> None) + | _ -> None + in + let moduleTypeOfUid = moduleTypeOfUid ~currentCmtFile:cmtFilePath ~imports ~local in + let moduleTypeOfPath (path : Path.t) = + match path with + | Pdot (p, name) -> ( + match moduleShapeOfPath p with + | Some shape -> ( + let item = Shape.proj shape (Shape.Item.make name Module_type) in + match Reduce.reduce_for_uid Env.empty item |> uidOfResult with + | Some uid -> moduleTypeOfUid uid + | None -> None) + | None -> None) + | Pident id -> + (* A module type of the current unit: by name among its + declarations. *) + Shape.Uid.Tbl.fold + (fun _uid decl acc -> + match (acc, decl) with + | None, Typedtree.Module_type {mtd_name; mtd_type = Some {mty_type}} + when mtd_name.txt = Ident.name id -> + Some mty_type + | _ -> acc) + local None + | _ -> None + in + let rec expand fuel (moduleType : Types.module_type) = + match moduleType with + | Mty_ident path when fuel > 0 -> ( + match moduleTypeOfPath path with + | Some expanded -> expand (fuel - 1) expanded + | None -> moduleType) + | _ -> moduleType + in + expand 8); } #else let _ = (cmtFilePath, cmt_infos) in diff --git a/src/DeadCode.ml b/src/DeadCode.ml index ca9b5913..3937c01f 100644 --- a/src/DeadCode.ml +++ b/src/DeadCode.ml @@ -8,16 +8,37 @@ let processSignature ~doValues ~doTypes (signature : Types.signature) = ~path:[!Common.currentModuleName] sig_item) +(* Restrict the declarations taken from a file's signature to definitions of + the file itself, see [DeadValue.setSignatureValueFilter]. *) +let setSignatureValueFilter ~(fileName : string option) ~moduleTypeRanges = + match fileName with + | Some fileName -> DeadValue.setSignatureValueFilter ~fileName ~moduleTypeRanges + | None -> DeadValue.isSignatureValueDeclaration := fun _ -> true + let processCmt ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) = (match cmt_infos.cmt_annots with | Interface signature -> ProcessDeadAnnotations.signature signature; + setSignatureValueFilter ~fileName:cmt_infos.cmt_sourcefile + ~moduleTypeRanges: + (signature.sig_items + |> List.filter_map (fun (item : Typedtree.signature_item) -> + match item.sig_desc with + | Tsig_modtype _ -> Some item.sig_loc + | _ -> None)); processSignature ~doValues:true ~doTypes:true signature.sig_type | Implementation structure -> let cmtiExists = Sys.file_exists ((cmtFilePath |> Filename.remove_extension) ^ ".cmti") in ProcessDeadAnnotations.structure ~doGenType:(not cmtiExists) structure; + setSignatureValueFilter ~fileName:cmt_infos.cmt_sourcefile + ~moduleTypeRanges: + (structure.str_items + |> List.filter_map (fun (item : Typedtree.structure_item) -> + match item.str_desc with + | Tstr_modtype _ -> Some item.str_loc + | _ -> None)); processSignature ~doValues:true ~doTypes:false structure.str_type; let doExternals = (* This is already handled at the interface level, avoid issues in inconsistent locations diff --git a/src/DeadValue.ml b/src/DeadValue.ml index a24e31c5..9b776d46 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -127,15 +127,50 @@ let parameterCalls : Hashtbl.t = Hashtbl.create 16 +type argumentResolver = + | Direct of (string list -> Location.t option) + (** implementation of a value of the actual argument, by path *) + | ViaParameter of Lexing.position * int * string list + (** the argument is (a submodule of) a parameter of the enclosing + functor: resolved through that functor's own applications *) + type delayedApplication = { appliedFunctor : Lexing.position; argIndex : int; - resolveItem : string list -> Location.t option; - (** implementation of a value of the actual argument, by path *) + resolver : argumentResolver; } let delayedApplications : delayedApplication list ref = ref [] +(* Implementations of a value of the argument at [argIndex] of every + application of the functor keyed [functorDef]. *) +let rec resolveArgumentItems ~depth functorDef argIndex components = + if depth > 8 then [] + else + !delayedApplications + |> List.concat_map (fun {appliedFunctor; argIndex = index; resolver} -> + if appliedFunctor <> functorDef || index <> argIndex then [] + else + match resolver with + | Direct resolve -> ( + match resolve components with Some loc -> [loc] | None -> []) + | ViaParameter (outerDef, outerIndex, prefix) -> + resolveArgumentItems ~depth:(depth + 1) outerDef outerIndex + (prefix @ components)) + +(* Coercion references made through a functor parameter, as in + [module Outer (M : S) = Inner (M)]: credited to the arguments of the + enclosing functor's applications, once all files are scanned. *) +type parameterCoercion = { + outerFunctor : Lexing.position; + outerIndex : int; + itemPath : string list; + coercionFrom : Location.t; + coercionTo : Location.t; (** the module type item, as fallback *) +} + +let parameterCoercions : parameterCoercion list ref = ref [] + (* The module path an argument or functor expression denotes, through any [( M : S )] constraints. *) let rec moduleIdent (moduleExpr : Typedtree.module_expr) = @@ -522,46 +557,24 @@ let findSignatureItem name signature = | Some itemName -> itemName = name | None -> false) -(* [shape], when known, is the shape of the module the signature items belong - to; it is used to reference the implementation of an item rather than a - shared module type item. See [Compat.resolveIdentOccurrences]. *) -let addValueReferenceFromSignatureItem ~locFrom ?shape signatureItem = - let id, locTo, _kind, _valType = signatureItem |> Compat.getSigValue in - if not locTo.loc_ghost then - let locToImpl = - match shape with - | Some shape -> !identResolutions.projValue shape (Ident.name id) - | None -> None - in - addRedirect ~locFrom ~locTo ~locToImpl - -let projModuleShape ?shape id = - match shape with - | Some shape -> !identResolutions.projModule shape (Ident.name id) - | None -> None - -let rec addAllModuleValueReferences ~locFrom ?shape - (moduleType : Types.module_type) = +(* The value items a module coercion uses, with the path of submodules + leading to each. *) +let rec iterAllModuleValues ~path (moduleType : Types.module_type) f = moduleType |> getSignature |> List.iter (fun (signatureItem : Types.signature_item) -> match signatureItem with - | Types.Sig_value _ -> - addValueReferenceFromSignatureItem ~locFrom ?shape signatureItem + | Types.Sig_value _ -> f ~path signatureItem | Types.Sig_module _ | Types.Sig_modtype _ -> ( match signatureItem |> Compat.getSigModuleModtype with | Some (id, moduleType, _moduleLoc) -> - addAllModuleValueReferences ~locFrom - ?shape:(projModuleShape ?shape id) - moduleType + iterAllModuleValues ~path:(path @ [Ident.name id]) moduleType f | None -> ()) | _ -> ()) -let rec addCoercedModuleValueReferences ~locFrom ~coercion ?shape ~actualType - () = +let rec iterCoercedValues ~path ~coercion ~actualType f = let actualSignature = actualType |> getSignature in match coercion with - | Typedtree.Tcoerce_none -> - addAllModuleValueReferences ~locFrom ?shape actualType + | Typedtree.Tcoerce_none -> iterAllModuleValues ~path actualType f | Typedtree.Tcoerce_structure (values, modules) -> let actualFields = actualSignature @@ -573,8 +586,7 @@ let rec addCoercedModuleValueReferences ~locFrom ~coercion ?shape ~actualType values |> List.iter (fun (index, _coercion) -> match nth_opt actualFields index with - | Some (Types.Sig_value _ as actualItem) -> - addValueReferenceFromSignatureItem ~locFrom ?shape actualItem + | Some (Types.Sig_value _ as actualItem) -> f ~path actualItem | Some _ -> () | None -> ()); let actualModules = @@ -594,18 +606,88 @@ let rec addCoercedModuleValueReferences ~locFrom ~coercion ?shape ~actualType | Some actualItem -> ( match actualItem |> Compat.getSigModuleModtype with | Some (actualId, actualType, _moduleLoc) -> - addCoercedModuleValueReferences ~locFrom ~coercion - ?shape:(projModuleShape ?shape actualId) - ~actualType () + iterCoercedValues + ~path:(path @ [Ident.name actualId]) + ~coercion ~actualType f | None -> ()) | None -> ()) | Typedtree.Tcoerce_alias (_env, _path, coercion) -> - addCoercedModuleValueReferences ~locFrom ~coercion ?shape ~actualType () + iterCoercedValues ~path ~coercion ~actualType f | Typedtree.Tcoerce_functor (_argCoercion, resultCoercion) -> - addCoercedModuleValueReferences ~locFrom ~coercion:resultCoercion ?shape - ~actualType () + iterCoercedValues ~path ~coercion:resultCoercion ~actualType f | Typedtree.Tcoerce_primitive _ -> () +(* Reference the values a functor argument's coercion uses. [shape], when + known, is the argument module's shape: items are then redirected to their + implementation rather than to a shared module type item. *) +let addCoercedModuleValueReferences ~locFrom ~coercion ?shape ~actualType () = + iterCoercedValues ~path:[] ~coercion ~actualType (fun ~path signatureItem -> + let id, locTo, _kind, _valType = signatureItem |> Compat.getSigValue in + if not locTo.loc_ghost then + let resolutions = !identResolutions in + let itemShape = + path + |> List.fold_left + (fun shape name -> + match shape with + | Some shape -> resolutions.projModule shape name + | None -> None) + shape + in + let locToImpl = + match itemShape with + | Some shape -> resolutions.projValue shape (Ident.name id) + | None -> None + in + addRedirect ~locFrom ~locTo ~locToImpl) + +(* Same, when the argument is a functor parameter: deferred to the arguments + of the enclosing functor's applications. *) +let recordParameterCoercion ~locFrom ~coercion ~actualType + (parameter : functorParameter) components = + iterCoercedValues ~path:[] ~coercion ~actualType (fun ~path signatureItem -> + let id, locTo, _kind, _valType = signatureItem |> Compat.getSigValue in + if not locTo.loc_ghost then + parameterCoercions := + { + outerFunctor = parameter.functorDef; + outerIndex = parameter.paramIndex; + itemPath = parameter.prefix @ components @ path @ [Ident.name id]; + coercionFrom = locFrom; + coercionTo = locTo; + } + :: !parameterCoercions) + +(* Whether a value item of a file's signature is a definition of that file. + Items whose location lies in another file, or inside a [module type] of the + file, come from [include]s (e.g. [include T] of a functor parameter, whose + items point at the module type's [val]s): they are not declarations. *) +let isSignatureValueDeclaration = ref (fun (_ : Location.t) -> true) + +let setSignatureValueFilter ~(fileName : string) + ~(moduleTypeRanges : Location.t list) = + (* By module name: a preprocessed source is recorded as [foo.pp.ml] while + its positions say [foo.ml]. *) + let moduleName path = + match String.index_opt (Filename.basename path) '.' with + | Some i -> String.sub (Filename.basename path) 0 i + | None -> Filename.basename path + in + let name = moduleName fileName in + isSignatureValueDeclaration := + fun (loc : Location.t) -> + let sameFile = moduleName loc.loc_start.pos_fname = name in + if (not sameFile) && !Common.Cli.debug then + Log_.item "signatureValueSkipped %s (file %s)@." + (loc.loc_start |> posToString) + fileName; + sameFile + && not + (moduleTypeRanges + |> List.exists (fun (range : Location.t) -> + range.loc_start.pos_cnum <= loc.loc_start.pos_cnum + && loc.loc_start.pos_cnum < range.loc_end.pos_cnum)) + let rec processSignatureItem ~doTypes ~doValues ~moduleLoc ~path (si : Types.signature_item) = match si with @@ -615,7 +697,7 @@ let rec processSignatureItem ~doTypes ~doValues ~moduleLoc ~path DeadType.addDeclaration ~typeId:id ~typeKind:t.type_kind | Sig_value _ when doValues -> let id, loc, kind, valType = si |> Compat.getSigValue in - if not loc.Location.loc_ghost then + if (not loc.Location.loc_ghost) && !isSignatureValueDeclaration loc then let isPrimitive = match kind with Val_prim _ -> true | _ -> false in if (not isPrimitive) || !Config.analyzeExternals then let optionalArgs = @@ -644,18 +726,27 @@ let rec processSignatureItem ~doTypes ~doValues ~moduleLoc ~path module type [(M : Other.S)] expanded to that module type's signature: the typed tree leaves it as [Mty_ident], which exposes no items. *) let rec argumentModuleType (argumentExpr : Typedtree.module_expr) = + let expand = !identResolutions.expandModuleType in match (argumentExpr.mod_desc, argumentExpr.mod_type) with | ( Tmod_constraint (_, _, Tmodtype_explicit {mty_desc = Tmty_ident (path, lid)}, _), Mty_ident _ ) -> ( match !identResolutions.moduleTypeOf lid.loc (Path.last path) with - | Some moduleType -> moduleType - | None -> argumentExpr.mod_type) + | Some moduleType -> expand moduleType + | None -> expand argumentExpr.mod_type) | Tmod_constraint (inner, _, _, _), Mty_ident _ -> argumentModuleType inner - | _ -> argumentExpr.mod_type + | _ -> expand argumentExpr.mod_type (* Implementation of a value of an actual functor argument, by path. *) let argumentItemResolver (argumentExpr : Typedtree.module_expr) = + match moduleIdent argumentExpr with + | Some (path, _) + when Compat.shapeResolutionAvailable && isFunctorParameterPath path -> ( + match (findFunctorParameter path, pathComponents path) with + | Some p, Some components -> + ViaParameter (p.functorDef, p.paramIndex, p.prefix @ components) + | _ -> Direct (fun _ -> None)) + | _ -> let shape = match moduleIdent argumentExpr with | Some (path, lid) -> !identResolutions.moduleShape lid.loc (Path.last path) @@ -690,13 +781,14 @@ let argumentItemResolver (argumentExpr : Typedtree.module_expr) = | None -> None) in let moduleType = argumentModuleType argumentExpr in - fun components -> - match shape with - | Some shape -> ( - match viaShape shape components with - | Some loc -> Some loc + Direct + (fun components -> + match shape with + | Some shape -> ( + match viaShape shape components with + | Some loc -> Some loc + | None -> viaSignature moduleType components) | None -> viaSignature moduleType components) - | None -> viaSignature moduleType components (* Applications already recorded as part of an outer curried application, by node identity (a ppx may emit distinct applications at one position). *) @@ -764,7 +856,7 @@ let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = { appliedFunctor = key; argIndex = consumed + i; - resolveItem = argumentItemResolver argumentExpr; + resolver = argumentItemResolver argumentExpr; } :: !delayedApplications) | None -> () @@ -828,8 +920,21 @@ let traverseStructure ~doTypes ~doExternals = | _ when not argumentExpr.mod_loc.loc_ghost -> argumentExpr.mod_loc | _ -> moduleExpr.mod_loc in - addCoercedModuleValueReferences ~locFrom ~coercion ?shape - ~actualType:(argumentModuleType argumentExpr) (); + let actualType = argumentModuleType argumentExpr in + let parameter = + match ident with + | Some (path, _) when Compat.shapeResolutionAvailable -> ( + match (findFunctorParameter path, pathComponents path) with + | Some p, Some components -> Some (p, components) + | _ -> None) + | _ -> None + in + (match parameter with + | Some (p, components) -> + recordParameterCoercion ~locFrom ~coercion ~actualType p components + | None -> + addCoercedModuleValueReferences ~locFrom ~coercion ?shape ~actualType + ()); recordFunctorApplication moduleExpr | _ -> ()); let r = super.Tast_mapper.module_expr self moduleExpr in @@ -902,6 +1007,38 @@ let traverseStructure ~doTypes ~doExternals = DeadType.addDeclaration ~typeId:typeDeclaration.typ_id ~typeKind:typeDeclaration.typ_type.type_kind) | Tstr_include {incl_mod; incl_type} -> ( + (* [include M] with [M] a functor parameter: the included identifiers + stand for the parameter's items. *) + (match moduleIdent incl_mod with + | Some (path, _) -> ( + match (findFunctorParameter path, pathComponents path) with + | Some p, Some components -> + incl_type + |> List.iter (fun (item : Types.signature_item) -> + match item with + | Sig_value _ -> + let id, _, _, _ = item |> Compat.getSigValue in + functorParameters := + { + p with + paramId = id; + prefix = p.prefix @ components @ [Ident.name id]; + } + :: !functorParameters + | Sig_module _ -> ( + match item |> Compat.getSigModuleModtype with + | Some (id, _, _) -> + functorParameters := + { + p with + paramId = id; + prefix = p.prefix @ components @ [Ident.name id]; + } + :: !functorParameters + | None -> ()) + | _ -> ()) + | _ -> ()) + | None -> ()); match incl_mod.mod_desc with | Tmod_ident (_path, _lid) -> let currentPath = @@ -986,22 +1123,43 @@ let forceDelayedItems () = in addValueReference ~addFileReference:true ~locFrom ~locTo); (* Credit calls made through functor parameters to the actual arguments. *) - let applications = List.rev !delayedApplications in + delayedApplications := List.rev !delayedApplications; + Hashtbl.iter + (fun (def, index, components) calls -> + if not (PosSet.mem def !ambiguousFunctorKeys) then + resolveArgumentItems ~depth:0 def index components + |> List.iter (fun (locTo : Location.t) -> + calls + |> List.iter + (DeadOptionalArgs.addCallToImplementation + ~posTo:locTo.loc_start))) + parameterCalls; + (* Reference the items a parameter's coercion uses, in the arguments of the + enclosing functor's applications; the module type item is the fallback + when an argument cannot be resolved. *) + List.rev !parameterCoercions + |> List.iter + (fun {outerFunctor; outerIndex; itemPath; coercionFrom; coercionTo} -> + if not (PosSet.mem outerFunctor !ambiguousFunctorKeys) then + let resolved = + resolveArgumentItems ~depth:0 outerFunctor outerIndex itemPath + in + let applied = + !delayedApplications + |> List.exists (fun {appliedFunctor; argIndex} -> + appliedFunctor = outerFunctor && argIndex = outerIndex) + in + match resolved with + | [] when applied -> + addValueReference ~addFileReference:true ~locFrom:coercionFrom + ~locTo:coercionTo + | _ -> + resolved + |> List.iter (fun locTo -> + addValueReference ~addFileReference:true + ~locFrom:coercionFrom ~locTo)); + parameterCoercions := []; delayedApplications := []; - applications - |> List.iter (fun {appliedFunctor; argIndex; resolveItem} -> - if not (PosSet.mem appliedFunctor !ambiguousFunctorKeys) then - Hashtbl.iter - (fun (def, index, components) calls -> - if def = appliedFunctor && index = argIndex then - match resolveItem components with - | Some (locTo : Location.t) -> - calls - |> List.iter - (DeadOptionalArgs.addCallToImplementation - ~posTo:locTo.loc_start) - | None -> ()) - parameterCalls); DeadOptionalArgs.settleDelayedItems (); let dependencies = List.rev !delayedValueDependencies in delayedValueDependencies := []; From dea753807866fb6aa1acfa048afbd89d391bcbac Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 16:09:46 +0000 Subject: [PATCH 13/53] Address review: collect nested module type ranges Module types declared inside modules, functors, includes, and their interface counterparts are now part of the ranges excluded from signature declarations. Regression case: Nested_module_type. --- examples/regression/src/Main.ml | 3 +- examples/regression/src/Nested_module_type.ml | 17 ++++++ examples/regression/src/dune | 1 + scripts/run_integration_tests.js | 3 ++ src/DeadCode.ml | 53 ++++++++++++++----- 5 files changed, 64 insertions(+), 13 deletions(-) create mode 100644 examples/regression/src/Nested_module_type.ml diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index e014ac04..3a7a75d8 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -13,4 +13,5 @@ let () = Shared_signature_arg.run_sig (); Shared_signature_arg.run_partial (); Shared_signature_arg.run_alias (); - Shared_signature_arg.run_forwarded () + Shared_signature_arg.run_forwarded (); + Nested_module_type.run () diff --git a/examples/regression/src/Nested_module_type.ml b/examples/regression/src/Nested_module_type.ml new file mode 100644 index 00000000..49b51d0f --- /dev/null +++ b/examples/regression/src/Nested_module_type.ml @@ -0,0 +1,17 @@ +(* A named module type declared inside a module: its items must not count as + declarations, so [Unused.f] is reported dead and [Used.f] live. *) +module Outer = struct + module type S = sig + val f : unit -> int + end + + module Used : S = struct + let f () = 1 + end + + module Unused : S = struct + let f () = 2 + end +end + +let run () = ignore (Outer.Used.f ()) diff --git a/examples/regression/src/dune b/examples/regression/src/dune index 7cb6ca6f..a523a862 100644 --- a/examples/regression/src/dune +++ b/examples/regression/src/dune @@ -6,6 +6,7 @@ Live_ancestors Local_side_effects Main + Nested_module_type Ocaml_compiler_compat Shared_signature Shared_signature_arg diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index eab4d471..8e29450c 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -200,6 +200,9 @@ function runRegressionTests() { output, "optional argument x of function Opt_incl_other.+g is never used" ); + // A module type declared inside a module. + assertIncludes(output, "Live Value +Nested_module_type.Outer.Used.+f"); + assertIncludes(output, "Dead Value +Nested_module_type.Outer.Unused.+f"); assertIncludes( output, "optional argument x of function Opt_constrained.+g is always supplied" diff --git a/src/DeadCode.ml b/src/DeadCode.ml index 3937c01f..7831c311 100644 --- a/src/DeadCode.ml +++ b/src/DeadCode.ml @@ -15,17 +15,51 @@ let setSignatureValueFilter ~(fileName : string option) ~moduleTypeRanges = | Some fileName -> DeadValue.setSignatureValueFilter ~fileName ~moduleTypeRanges | None -> DeadValue.isSignatureValueDeclaration := fun _ -> true +(* Locations of every [module type] declaration of a file, at any depth. *) +let rec moduleTypeRangesOfStructure (structure : Typedtree.structure) = + structure.str_items + |> List.concat_map (fun (item : Typedtree.structure_item) -> + match item.str_desc with + | Tstr_modtype _ -> [item.str_loc] + | Tstr_module mb -> moduleTypeRangesOfModuleExpr mb.mb_expr + | Tstr_recmodule mbs -> + mbs + |> List.concat_map (fun (mb : Typedtree.module_binding) -> + moduleTypeRangesOfModuleExpr mb.mb_expr) + | Tstr_include {incl_mod} -> moduleTypeRangesOfModuleExpr incl_mod + | _ -> []) + +and moduleTypeRangesOfModuleExpr (moduleExpr : Typedtree.module_expr) = + match moduleExpr.mod_desc with + | Tmod_structure structure -> moduleTypeRangesOfStructure structure + | Tmod_constraint (inner, _, _, _) -> moduleTypeRangesOfModuleExpr inner + | Tmod_functor (_, body) -> moduleTypeRangesOfModuleExpr body + | _ -> [] + +let rec moduleTypeRangesOfSignature (signature : Typedtree.signature) = + signature.sig_items + |> List.concat_map (fun (item : Typedtree.signature_item) -> + match item.sig_desc with + | Tsig_modtype _ -> [item.sig_loc] + | Tsig_module md -> moduleTypeRangesOfModuleType md.md_type + | Tsig_recmodule mds -> + mds + |> List.concat_map (fun (md : Typedtree.module_declaration) -> + moduleTypeRangesOfModuleType md.md_type) + | _ -> []) + +and moduleTypeRangesOfModuleType (moduleType : Typedtree.module_type) = + match moduleType.mty_desc with + | Tmty_signature signature -> moduleTypeRangesOfSignature signature + | Tmty_functor (_, body) -> moduleTypeRangesOfModuleType body + | _ -> [] + let processCmt ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) = (match cmt_infos.cmt_annots with | Interface signature -> ProcessDeadAnnotations.signature signature; setSignatureValueFilter ~fileName:cmt_infos.cmt_sourcefile - ~moduleTypeRanges: - (signature.sig_items - |> List.filter_map (fun (item : Typedtree.signature_item) -> - match item.sig_desc with - | Tsig_modtype _ -> Some item.sig_loc - | _ -> None)); + ~moduleTypeRanges:(moduleTypeRangesOfSignature signature); processSignature ~doValues:true ~doTypes:true signature.sig_type | Implementation structure -> let cmtiExists = @@ -33,12 +67,7 @@ let processCmt ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) = in ProcessDeadAnnotations.structure ~doGenType:(not cmtiExists) structure; setSignatureValueFilter ~fileName:cmt_infos.cmt_sourcefile - ~moduleTypeRanges: - (structure.str_items - |> List.filter_map (fun (item : Typedtree.structure_item) -> - match item.str_desc with - | Tstr_modtype _ -> Some item.str_loc - | _ -> None)); + ~moduleTypeRanges:(moduleTypeRangesOfStructure structure); processSignature ~doValues:true ~doTypes:false structure.str_type; let doExternals = (* This is already handled at the interface level, avoid issues in inconsistent locations From c934d7b4e7f4cc294f82f728fafe32af6375b50c Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 16:18:57 +0000 Subject: [PATCH 14/53] Address review: functor aliases, local module type roots, identity matching - let module G = F in G (A), and module G = F: the alias is chased to the functor's key within the current file. - Module type paths rooted at a module of the current unit resolve through the implementation shape, by module binding identity. - Module types of the current unit are matched by identifier identity rather than name, so a shadowed same-named module type is not confused. Regression cases: run_letalias, T_alias rooted at Inner, Shadow.T. --- examples/regression/src/Main.ml | 3 +- .../regression/src/Shared_signature_arg.ml | 55 ++++++++++++ scripts/run_integration_tests.js | 8 ++ src/Compat.ml | 30 +++++-- src/DeadValue.ml | 84 ++++++++++++------- 5 files changed, 142 insertions(+), 38 deletions(-) diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 3a7a75d8..631abfe3 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -14,4 +14,5 @@ let () = Shared_signature_arg.run_partial (); Shared_signature_arg.run_alias (); Shared_signature_arg.run_forwarded (); - Nested_module_type.run () + Nested_module_type.run (); + Shared_signature_arg.run_shadow () diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml index 45b3526a..8717b6ee 100644 --- a/examples/regression/src/Shared_signature_arg.ml +++ b/examples/regression/src/Shared_signature_arg.ml @@ -230,3 +230,58 @@ let run_forwarded () = ignore (Applied_alias_mt.run () + Applied_outer.run () + Applied_outer_opt.run () + Applied_incl.run () + Opt_incl_other.g ()) + +(* [let module G = F in G (A)]: the alias stands for the functor. *) +module Opt_letalias : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +let run_letalias () = + let module G = Apply_opt in + let module Applied = G (Opt_letalias) in + Applied.run () + +(* Module type alias rooted at a module of this file, and a module type + shadowing a same-named one: resolution must follow identity, not names. *) +module type T = sig + val f : unit -> int +end + +module Inner = struct + module type T = sig + val h : unit -> int + end +end + +module type T_alias = Inner.T + +module Use_t : Inner.T = struct + let h () = 3 +end + +module Apply_h (M : Inner.T) = struct + let run () = M.h () +end + +module Applied_h = Apply_h ((Use_t : T_alias)) + +module Shadow = struct + module type T = sig + val k : unit -> int + end + + module type T_alias3 = T + + module Use3 : T = struct + let k () = 4 + end + + module Apply_k (M : T) = struct + let run () = M.k () + end + + module Applied3 = Apply_k ((Use3 : T_alias3)) +end + +let run_shadow () = + ignore (run_letalias () + Applied_h.run () + Shadow.Applied3.run ()) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index 8e29450c..c539824a 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -203,6 +203,14 @@ function runRegressionTests() { // A module type declared inside a module. assertIncludes(output, "Live Value +Nested_module_type.Outer.Used.+f"); assertIncludes(output, "Dead Value +Nested_module_type.Outer.Unused.+f"); + // let-module alias of a functor; module type aliases rooted at a local + // module and shadowing a same-named module type. + assertIncludes( + output, + "optional argument x of function Opt_letalias.+g is always supplied" + ); + assertIncludes(output, "Live Value +Shared_signature_arg.Use_t.+h"); + assertIncludes(output, "Live Value +Shared_signature_arg.Shadow.Use3.+k"); assertIncludes( output, "optional argument x of function Opt_constrained.+g is always supplied" diff --git a/src/Compat.ml b/src/Compat.ml index bafea82f..48192b5e 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -734,10 +734,30 @@ let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : (let compUnitShape name = {Shape.uid = None; desc = Comp_unit name; approximated = false} in - (* Shape of a module path rooted at a compilation unit. *) + (* The uid of a declaration of the current unit, by identifier. *) + let localUid (matches : Typedtree.item_declaration -> bool) = + Shape.Uid.Tbl.fold + (fun uid decl acc -> + match acc with + | Some _ -> acc + | None -> if matches decl then Some uid else None) + local None + in + (* Shape of a module path rooted at a compilation unit or at a module + of the current unit. *) let rec moduleShapeOfPath (path : Path.t) = match path with | Pident id when Ident.global id -> Some (compUnitShape (Ident.name id)) + | Pident id -> ( + let uid = + localUid (function + | Typedtree.Module_binding {mb_id = Some mbId} -> + Ident.same mbId id + | _ -> false) + in + match (uid, cmt_infos.cmt_impl_shape) with + | Some uid, Some impl -> findShapeByUid impl uid + | _ -> None) | Pdot (p, name) -> ( match moduleShapeOfPath p with | Some shape -> Some (Shape.proj shape (Shape.Item.make name Module)) @@ -756,13 +776,13 @@ let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : | None -> None) | None -> None) | Pident id -> - (* A module type of the current unit: by name among its - declarations. *) + (* A module type of the current unit, by identifier identity (the + same name may be declared in several scopes). *) Shape.Uid.Tbl.fold (fun _uid decl acc -> match (acc, decl) with - | None, Typedtree.Module_type {mtd_name; mtd_type = Some {mty_type}} - when mtd_name.txt = Ident.name id -> + | None, Typedtree.Module_type {mtd_id; mtd_type = Some {mty_type}} + when Ident.same mtd_id id -> Some mty_type | _ -> acc) local None diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 9b776d46..ac34585c 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -360,6 +360,46 @@ let addValueReferenceOrRedirect ~(locFrom : Location.t) ~(locTo : Location.t) nonForwardableReferences := PosPairSet.remove pair !nonForwardableReferences); addRedirect ~locFrom ~locTo ~locToImpl +(* The key of the functor a module expression denotes, and the number of + arguments already consumed by partial applications it stands for, as in + [module G = F (A)] followed by [G (B)]. Aliases ([module G = F]) are + chased within the current file. *) +let rec functorKeyOfHead ~fuel (e : Typedtree.module_expr) = + if fuel = 0 then None + else + match e.mod_desc with + | Tmod_apply (functorExpr, _, _) -> ( + match functorKeyOfHead ~fuel functorExpr with + | Some (key, consumed) -> Some (key, consumed + 1) + | None -> None) + | Tmod_constraint (inner, _, _, _) -> functorKeyOfHead ~fuel inner + | Tmod_functor _ -> + (* Inline functor: keyed by its own position, see [functorKeys]. *) + Some (e.mod_loc.loc_start, 0) + | Tmod_ident (path, lid) -> ( + let byIdent () = + match + List.find_opt + (fun (id, _) -> Ident.same id (Path.head path)) + !functorsByIdent + with + | Some (_, pos) -> Some (pos, 0) + | None -> None + | exception _ -> None + in + match !identResolutions.moduleDefinition lid.loc (Path.last path) with + | Some (nameLoc, definition) -> ( + match (moduleIdent definition, definition.mod_desc) with + | None, Tmod_apply _ -> functorKeyOfHead ~fuel:(fuel - 1) definition + | Some _, _ -> ( + (* An alias: chase it, falling back to the alias's own binding. *) + match functorKeyOfHead ~fuel:(fuel - 1) definition with + | Some key -> Some key + | None -> Some (nameLoc.loc_start, 0)) + | _ -> Some (nameLoc.loc_start, 0)) + | None -> byIdent ()) + | _ -> None + let rec collectExpr super self (e : Typedtree.expression) = let locFrom = e.exp_loc in (* [let module F (M : S) = ... in]: key the functor by its binding. On @@ -372,7 +412,17 @@ let rec collectExpr super self (e : Typedtree.expression) = claimFunctorKey moduleExpr name.loc.loc_start; registerParameterAlias id moduleExpr; (match id with - | Some id -> functorsByIdent := (id, name.loc.loc_start) :: !functorsByIdent + | Some id -> + (* [let module G = F in]: G stands for F's key. *) + let key = + match moduleIdent moduleExpr with + | Some _ -> ( + match functorKeyOfHead ~fuel:8 moduleExpr with + | Some (key, 0) -> key + | _ -> name.loc.loc_start) + | None -> name.loc.loc_start + in + functorsByIdent := (id, key) :: !functorsByIdent | None -> ()) | _ -> ()); #endif @@ -808,38 +858,8 @@ let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = | Tmod_constraint (inner, _, _, _) -> flatten inner args | _ -> (e, args) in - (* The key of the functor a head denotes, and the number of arguments - already consumed by partial applications it stands for, as in - [module G = F (A)] followed by [G (B)]. *) - let rec headKey (e : Typedtree.module_expr) = - match e.mod_desc with - | Tmod_apply (functorExpr, _, _) -> ( - match headKey functorExpr with - | Some (key, consumed) -> Some (key, consumed + 1) - | None -> None) - | Tmod_constraint (inner, _, _, _) -> headKey inner - | Tmod_functor _ -> - (* Inline functor: keyed by its own position, see [functorKeys]. *) - Some (e.mod_loc.loc_start, 0) - | Tmod_ident (path, lid) -> ( - match !identResolutions.moduleDefinition lid.loc (Path.last path) with - | Some (nameLoc, definition) -> ( - match (moduleIdent definition, definition.mod_desc) with - | None, Tmod_apply _ -> headKey definition - | _ -> Some (nameLoc.loc_start, 0)) - | None -> ( - match - List.find_opt - (fun (id, _) -> Ident.same id (Path.head path)) - !functorsByIdent - with - | Some (_, pos) -> Some (pos, 0) - | None -> None - | exception _ -> None)) - | _ -> None - in let head, args = flatten moduleExpr [] in - let key = headKey head in + let key = functorKeyOfHead ~fuel:8 head in if !Common.Cli.debug then Log_.item "functorApplication %s key:%s args:%d@." (moduleExpr.mod_loc.loc_start |> posToString) From bc4c375d5bacaae46ab4dae19cfd77fe9262a47a Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 16:33:20 +0000 Subject: [PATCH 15/53] Address review: nested module types, Sig_modtype, alias cycles; fix coercion walk - Module types of nested modules in a signature are expanded before their values are walked, and module aliases (which a strengthened signature produces for submodules) resolve to the aliased module's declared type. - Sig_modtype items are not walked: a module type declaration has no runtime fields. - Alias expansion tracks visited paths instead of a fixed depth. - Structure coercions are walked by runtime field position, as the compiler lays them out: values, extension constructors, present modules and classes, with submodules recursing with their own coercion. The second list of a Tcoerce_structure maps source module identifiers to positions and is not a list of target submodules; walking it referenced every submodule of an argument (e.g. all of Ident.Set/Map/Tbl for Map.Make (Ident)), which alias expansion had just made visible. Regression case: Apply_nested with a nested constrained module. --- examples/regression/src/Main.ml | 3 +- .../regression/src/Shared_signature_arg.ml | 26 +++++++ scripts/run_integration_tests.js | 10 +++ src/Compat.ml | 42 +++++++++- src/DeadValue.ml | 76 ++++++++++--------- 5 files changed, 117 insertions(+), 40 deletions(-) diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 631abfe3..e907caab 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -15,4 +15,5 @@ let () = Shared_signature_arg.run_alias (); Shared_signature_arg.run_forwarded (); Nested_module_type.run (); - Shared_signature_arg.run_shadow () + Shared_signature_arg.run_shadow (); + Shared_signature_arg.run_nested () diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml index 8717b6ee..71ab2454 100644 --- a/examples/regression/src/Shared_signature_arg.ml +++ b/examples/regression/src/Shared_signature_arg.ml @@ -285,3 +285,29 @@ end let run_shadow () = ignore (run_letalias () + Applied_h.run () + Shadow.Applied3.run ()) + +(* A nested module in the parameter's signature, constrained by a named + module type: [M.N.g] must be credited to the argument's [N.g]. *) +module type With_nested = sig + module N : Shared_signature.O +end + +module Nested_arg : With_nested = struct + module N = struct + let g ?(x = 0) () = x + end +end + +module Nested_other : With_nested = struct + module N = struct + let g ?(x = 0) () = x + end +end + +module Apply_nested (M : With_nested) = struct + let run () = M.N.g ~x:1 () +end + +module Applied_nested = Apply_nested (Nested_arg) + +let run_nested () = ignore (Applied_nested.run () + Nested_other.N.g ()) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index c539824a..424d042b 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -211,6 +211,16 @@ function runRegressionTests() { ); assertIncludes(output, "Live Value +Shared_signature_arg.Use_t.+h"); assertIncludes(output, "Live Value +Shared_signature_arg.Shadow.Use3.+k"); + // A nested module of the parameter constrained by a named module type. + assertIncludes(output, "Live Value +Shared_signature_arg.Nested_arg.N.+g"); + assertIncludes( + output, + "optional argument x of function Nested_arg.N.+g is always supplied" + ); + assertIncludes( + output, + "optional argument x of function Nested_other.N.+g is never used" + ); assertIncludes( output, "optional argument x of function Opt_constrained.+g is always supplied" diff --git a/src/Compat.ml b/src/Compat.ml index 48192b5e..c13fe155 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -149,6 +149,19 @@ let getTypeVariant (tk: ('a, 'b) type_kind) = match tk with #endif | _ -> assert false +(* Whether a signature item occupies a runtime slot, as the positions of a + [Tcoerce_structure] count them: values (not primitives), extension + constructors, present modules and classes. *) +let isRuntimeField (si : Types.signature_item) = + match si with + | Types.Sig_value (_, {val_kind = Val_prim _}, _) -> false + | Types.Sig_value _ -> true + | Types.Sig_typext _ -> true + | Types.Sig_module (_, Mp_present, _, _, _) -> true + | Types.Sig_module (_, Mp_absent, _, _, _) -> false + | Types.Sig_class _ -> true + | _ -> false + let getSigModuleModtype si = match si with #if OCAML_VERSION >= (4, 08, 0) | Types.Sig_module(id, _, {Types.md_type=moduleType; md_loc=loc}, _, _) @@ -788,15 +801,36 @@ let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : local None | _ -> None in - let rec expand fuel (moduleType : Types.module_type) = + (* The declared type of the module a path denotes: a strengthened + signature turns submodules into aliases ([module N = Arg.N]), + which expose no items. *) + let moduleTypeOfModulePath (path : Path.t) = + match moduleShapeOfPath path with + | Some shape -> ( + match Reduce.reduce_for_uid Env.empty shape |> uidOfResult with + | Some uid -> ( + match declOfUid ~currentCmtFile:cmtFilePath ~imports ~local uid with + | Some (Typedtree.Module_binding {mb_expr}) -> Some mb_expr.mod_type + | Some (Typedtree.Module {md_type}) -> Some md_type.mty_type + | _ -> None) + | None -> None) + | None -> None + in + (* Aliases are followed until a signature is reached; the visited + paths break cycles. *) + let rec expand visited (moduleType : Types.module_type) = match moduleType with - | Mty_ident path when fuel > 0 -> ( + | Mty_ident path when not (List.exists (Path.same path) visited) -> ( match moduleTypeOfPath path with - | Some expanded -> expand (fuel - 1) expanded + | Some expanded -> expand (path :: visited) expanded + | None -> moduleType) + | Mty_alias path when not (List.exists (Path.same path) visited) -> ( + match moduleTypeOfModulePath path with + | Some expanded -> expand (path :: visited) expanded | None -> moduleType) | _ -> moduleType in - expand 8); + expand []); } #else let _ = (cmtFilePath, cmt_infos) in diff --git a/src/DeadValue.ml b/src/DeadValue.ml index ac34585c..c0d6094b 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -609,12 +609,19 @@ let findSignatureItem name signature = (* The value items a module coercion uses, with the path of submodules leading to each. *) +(* Signature of a module type, with aliases of named module types expanded + ([module N : Other.O] inside a signature is [Mty_ident] in the typed tree, + which exposes no items). Only runtime modules ([Sig_module]) are walked: + a [Sig_modtype] declaration has no fields. *) +let expandedSignature (moduleType : Types.module_type) = + moduleType |> !identResolutions.expandModuleType |> getSignature + let rec iterAllModuleValues ~path (moduleType : Types.module_type) f = - moduleType |> getSignature + moduleType |> expandedSignature |> List.iter (fun (signatureItem : Types.signature_item) -> match signatureItem with | Types.Sig_value _ -> f ~path signatureItem - | Types.Sig_module _ | Types.Sig_modtype _ -> ( + | Types.Sig_module _ -> ( match signatureItem |> Compat.getSigModuleModtype with | Some (id, moduleType, _moduleLoc) -> iterAllModuleValues ~path:(path @ [Ident.name id]) moduleType f @@ -622,45 +629,27 @@ let rec iterAllModuleValues ~path (moduleType : Types.module_type) f = | _ -> ()) let rec iterCoercedValues ~path ~coercion ~actualType f = - let actualSignature = actualType |> getSignature in + let actualSignature = actualType |> expandedSignature in match coercion with | Typedtree.Tcoerce_none -> iterAllModuleValues ~path actualType f - | Typedtree.Tcoerce_structure (values, modules) -> - let actualFields = - actualSignature - |> List.filter (function - | Types.Sig_type _ | Types.Sig_module _ | Types.Sig_modtype _ -> - false - | _ -> true) - in - values - |> List.iter (fun (index, _coercion) -> - match nth_opt actualFields index with + | Typedtree.Tcoerce_structure (fields, _idPositions) -> + (* [fields] has one entry per runtime component of the target, giving + the position in the source's runtime fields and the coercion of that + component; submodules recurse with theirs. The second list only maps + source module identifiers to positions, for aliases. *) + let runtimeFields = actualSignature |> List.filter Compat.isRuntimeField in + fields + |> List.iter (fun (index, coercion) -> + match nth_opt runtimeFields index with | Some (Types.Sig_value _ as actualItem) -> f ~path actualItem - | Some _ -> () - | None -> ()); - let actualModules = - actualSignature - |> List.filter (function - | Types.Sig_module _ | Types.Sig_modtype _ -> true - | _ -> false) - in - modules - |> List.iter (fun (id, index, coercion) -> - let actualItem = - match actualSignature |> findSignatureItem (Ident.name id) with - | Some item -> Some item - | None -> nth_opt actualModules index - in - match actualItem with - | Some actualItem -> ( + | Some (Types.Sig_module _ as actualItem) -> ( match actualItem |> Compat.getSigModuleModtype with | Some (actualId, actualType, _moduleLoc) -> iterCoercedValues ~path:(path @ [Ident.name actualId]) ~coercion ~actualType f | None -> ()) - | None -> ()) + | _ -> ()) | Typedtree.Tcoerce_alias (_env, _path, coercion) -> iterCoercedValues ~path ~coercion ~actualType f | Typedtree.Tcoerce_functor (_argCoercion, resultCoercion) -> @@ -813,7 +802,7 @@ let argumentItemResolver (argumentExpr : Typedtree.module_expr) = | None -> None) in let rec viaSignature (moduleType : Types.module_type) components = - let signature = moduleType |> getSignature in + let signature = moduleType |> expandedSignature in match components with | [] -> None | [name] -> ( @@ -824,11 +813,11 @@ let argumentItemResolver (argumentExpr : Typedtree.module_expr) = | _ -> None) | m :: rest -> ( match signature |> findSignatureItem m with - | Some item -> ( + | Some (Types.Sig_module _ as item) -> ( match item |> Compat.getSigModuleModtype with | Some (_id, moduleType, _loc) -> viaSignature moduleType rest | None -> None) - | None -> None) + | _ -> None) in let moduleType = argumentModuleType argumentExpr in Direct @@ -941,6 +930,23 @@ let traverseStructure ~doTypes ~doExternals = | _ -> moduleExpr.mod_loc in let actualType = argumentModuleType argumentExpr in + if !Common.Cli.debug then + Log_.item "functorArgument %s coercion:%s type:%s items:%d@." + (argumentExpr.mod_loc.loc_start |> posToString) + (match coercion with + | Tcoerce_none -> "none" + | Tcoerce_structure (vs, ms) -> + Printf.sprintf "structure(%d values, %d modules)" (List.length vs) + (List.length ms) + | Tcoerce_alias _ -> "alias" + | Tcoerce_functor _ -> "functor" + | Tcoerce_primitive _ -> "primitive") + (match actualType with + | Mty_ident p -> "ident " ^ Path.name p + | Mty_signature _ -> "signature" + | Mty_functor _ -> "functor" + | Mty_alias p -> "alias " ^ Path.name p) + (List.length (expandedSignature actualType)); let parameter = match ident with | Some (path, _) when Compat.shapeResolutionAvailable -> ( From cab3cc0fef64cdafa66ec44f1c173939bc743f1f Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 16:42:07 +0000 Subject: [PATCH 16/53] Address review: forwarding cycles, cross-file aliases, functor-body shapes, included signatures - Forwarding through parameters tracks visited (functor, index) pairs instead of a depth cap. - A functor alias (module G = A.F), possibly in another unit, is chased through its shape, which needs no occurrence data of that unit. - Shapes of modules defined inside a functor body are found through the abstraction node. - Module type ranges are collected inside included signatures. Regression cases: Chain0..Chain10, Apply_in_body, Cross_alias, Included_sig. --- examples/regression/src/Cross_alias.ml | 2 + examples/regression/src/Cross_alias_use.ml | 7 +++ examples/regression/src/Included_sig.ml | 7 +++ examples/regression/src/Included_sig.mli | 7 +++ examples/regression/src/Main.ml | 5 +- .../regression/src/Shared_signature_arg.ml | 42 +++++++++++++ examples/regression/src/dune | 3 + scripts/run_integration_tests.js | 19 ++++++ src/Compat.ml | 63 +++++++++++++++---- src/DeadCode.ml | 1 + src/DeadValue.ml | 11 ++-- 11 files changed, 149 insertions(+), 18 deletions(-) create mode 100644 examples/regression/src/Cross_alias.ml create mode 100644 examples/regression/src/Cross_alias_use.ml create mode 100644 examples/regression/src/Included_sig.ml create mode 100644 examples/regression/src/Included_sig.mli diff --git a/examples/regression/src/Cross_alias.ml b/examples/regression/src/Cross_alias.ml new file mode 100644 index 00000000..a631f899 --- /dev/null +++ b/examples/regression/src/Cross_alias.ml @@ -0,0 +1,2 @@ +(* An alias of a functor defined in another file, applied from a third. *) +module G = Shared_signature_arg.Apply_opt diff --git a/examples/regression/src/Cross_alias_use.ml b/examples/regression/src/Cross_alias_use.ml new file mode 100644 index 00000000..800d348d --- /dev/null +++ b/examples/regression/src/Cross_alias_use.ml @@ -0,0 +1,7 @@ +module Opt_cross : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Applied_cross = Cross_alias.G (Opt_cross) + +let run () = ignore (Applied_cross.run ()) diff --git a/examples/regression/src/Included_sig.ml b/examples/regression/src/Included_sig.ml new file mode 100644 index 00000000..ea25e758 --- /dev/null +++ b/examples/regression/src/Included_sig.ml @@ -0,0 +1,7 @@ +module type S = sig + val f : unit -> int +end + +module M : S = struct + let f () = 5 +end diff --git a/examples/regression/src/Included_sig.mli b/examples/regression/src/Included_sig.mli new file mode 100644 index 00000000..24f3bd5b --- /dev/null +++ b/examples/regression/src/Included_sig.mli @@ -0,0 +1,7 @@ +include sig + module type S = sig + val f : unit -> int + end + + module M : S +end diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index e907caab..21ed1672 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -16,4 +16,7 @@ let () = Shared_signature_arg.run_forwarded (); Nested_module_type.run (); Shared_signature_arg.run_shadow (); - Shared_signature_arg.run_nested () + Shared_signature_arg.run_nested (); + Shared_signature_arg.run_chain (); + Cross_alias_use.run (); + ignore (Included_sig.M.f ()) diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml index 71ab2454..bf6ac66b 100644 --- a/examples/regression/src/Shared_signature_arg.ml +++ b/examples/regression/src/Shared_signature_arg.ml @@ -311,3 +311,45 @@ end module Applied_nested = Apply_nested (Nested_arg) let run_nested () = ignore (Applied_nested.run () + Nested_other.N.g ()) + + +(* A parameter forwarded through ten functors. *) +module Opt_chain : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Chain0 (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Chain1 (M : Shared_signature.O) = Chain0 (M) +module Chain2 (M : Shared_signature.O) = Chain1 (M) +module Chain3 (M : Shared_signature.O) = Chain2 (M) +module Chain4 (M : Shared_signature.O) = Chain3 (M) +module Chain5 (M : Shared_signature.O) = Chain4 (M) +module Chain6 (M : Shared_signature.O) = Chain5 (M) +module Chain7 (M : Shared_signature.O) = Chain6 (M) +module Chain8 (M : Shared_signature.O) = Chain7 (M) +module Chain9 (M : Shared_signature.O) = Chain8 (M) +module Chain10 (M : Shared_signature.O) = Chain9 (M) + +module Applied_chain = Chain10 (Opt_chain) + +(* Modules defined inside a functor body, one applied, one not. *) +module Apply_in_body (X : sig end) = struct + module Chosen_in : Shared_signature.S = struct + let f () = 20 + end + + module Ignored_in : Shared_signature.S = struct + let f () = 21 + end + + module Applied_in = Apply (Chosen_in) + + let run () = Applied_in.run () +end + +module Applied_body = Apply_in_body (struct end) + +let run_chain () = ignore (Applied_chain.run () + Applied_body.run ()) diff --git a/examples/regression/src/dune b/examples/regression/src/dune index a523a862..5e49766f 100644 --- a/examples/regression/src/dune +++ b/examples/regression/src/dune @@ -1,8 +1,11 @@ (library (name regression_fixture) (modules + Cross_alias + Cross_alias_use Functor_argument Generated_source + Included_sig Live_ancestors Local_side_effects Main diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index 424d042b..14517591 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -221,6 +221,25 @@ function runRegressionTests() { output, "optional argument x of function Nested_other.N.+g is never used" ); + // Ten forwarding functors; modules inside a functor body; an alias of a + // functor defined in another file; a module type in an included signature. + assertIncludes( + output, + "optional argument x of function Opt_chain.+g is always supplied" + ); + assertIncludes( + output, + "Dead Value +Shared_signature_arg.Apply_in_body.Ignored_in.+f" + ); + assertIncludes( + output, + "Live Value +Shared_signature_arg.Apply_in_body.Chosen_in.+f" + ); + assertIncludes( + output, + "optional argument x of function Opt_cross.+g is always supplied" + ); + assertIncludes(output, "Live Value +Included_sig.M.+f"); assertIncludes( output, "optional argument x of function Opt_constrained.+g is always supplied" diff --git a/src/Compat.ml b/src/Compat.ml index c13fe155..76625ee3 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -580,6 +580,7 @@ let rec findShapeByUid (shape : Shape.t) uid : Shape.t option = | None -> findShapeByUid itemShape uid) items None | Alias s -> findShapeByUid s uid + | Abs (_, body) -> findShapeByUid body uid | _ -> None #endif @@ -731,18 +732,56 @@ let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : | None -> None) | None -> None); moduleDefinition = - (fun loc name -> - match Hashtbl.find_opt moduleUids (key loc name) with - | Some uid -> ( - match Lazy.force uid with - | Some uid -> ( - match - moduleBindingOfUid ~currentCmtFile:cmtFilePath ~imports ~local uid - with - | Some (loc, _) when loc.loc_ghost -> None - | def -> def) - | None -> None) - | None -> None); + (let bindingOfUid = + moduleBindingOfUid ~currentCmtFile:cmtFilePath ~imports ~local + in + (* The shape of the module defined with [uid], in its own unit. *) + let shapeOfDefinition (uid : Shape.Uid.t) = + let impl = + match uid with + | Shape.Uid.Item {comp_unit; _} -> ( + match + loadUnitInfo ~currentCmtFile:cmtFilePath ~imports comp_unit + with + | Some {shape} -> shape + | None -> None) + | _ -> None + in + match impl with + | Some impl -> findShapeByUid impl uid + | None -> None + in + let isAlias (definition : Typedtree.module_expr) = + let rec go (e : Typedtree.module_expr) = + match e.mod_desc with + | Tmod_ident _ -> true + | Tmod_constraint (inner, _, _, _) -> go inner + | _ -> false + in + go definition + in + (* [module G = A.F], possibly in another unit: chase the alias through + its shape, which needs no occurrence data of that unit. *) + let rec chase visited uid = + match bindingOfUid uid with + | Some (loc, _) when loc.loc_ghost -> None + | Some (_, definition) as def when isAlias definition -> ( + match shapeOfDefinition uid with + | Some shape when not (List.mem uid visited) -> ( + match Reduce.reduce_for_uid Env.empty shape |> uidOfResult with + | Some target when target <> uid -> ( + match chase (uid :: visited) target with + | Some def -> Some def + | None -> def) + | _ -> def) + | _ -> def) + | def -> def + in + fun loc name -> + match Hashtbl.find_opt moduleUids (key loc name) with + | Some uid -> ( + match Lazy.force uid with Some uid -> chase [] uid | None -> None) + | None -> None); expandModuleType = (let compUnitShape name = {Shape.uid = None; desc = Comp_unit name; approximated = false} diff --git a/src/DeadCode.ml b/src/DeadCode.ml index 7831c311..e407e892 100644 --- a/src/DeadCode.ml +++ b/src/DeadCode.ml @@ -46,6 +46,7 @@ let rec moduleTypeRangesOfSignature (signature : Typedtree.signature) = mds |> List.concat_map (fun (md : Typedtree.module_declaration) -> moduleTypeRangesOfModuleType md.md_type) + | Tsig_include {incl_mod} -> moduleTypeRangesOfModuleType incl_mod | _ -> []) and moduleTypeRangesOfModuleType (moduleType : Typedtree.module_type) = diff --git a/src/DeadValue.ml b/src/DeadValue.ml index c0d6094b..ec8a5b94 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -144,9 +144,10 @@ let delayedApplications : delayedApplication list ref = ref [] (* Implementations of a value of the argument at [argIndex] of every application of the functor keyed [functorDef]. *) -let rec resolveArgumentItems ~depth functorDef argIndex components = - if depth > 8 then [] +let rec resolveArgumentItems ~visited functorDef argIndex components = + if List.mem (functorDef, argIndex) visited then [] else + let visited = (functorDef, argIndex) :: visited in !delayedApplications |> List.concat_map (fun {appliedFunctor; argIndex = index; resolver} -> if appliedFunctor <> functorDef || index <> argIndex then [] @@ -155,7 +156,7 @@ let rec resolveArgumentItems ~depth functorDef argIndex components = | Direct resolve -> ( match resolve components with Some loc -> [loc] | None -> []) | ViaParameter (outerDef, outerIndex, prefix) -> - resolveArgumentItems ~depth:(depth + 1) outerDef outerIndex + resolveArgumentItems ~visited outerDef outerIndex (prefix @ components)) (* Coercion references made through a functor parameter, as in @@ -1153,7 +1154,7 @@ let forceDelayedItems () = Hashtbl.iter (fun (def, index, components) calls -> if not (PosSet.mem def !ambiguousFunctorKeys) then - resolveArgumentItems ~depth:0 def index components + resolveArgumentItems ~visited:[] def index components |> List.iter (fun (locTo : Location.t) -> calls |> List.iter @@ -1168,7 +1169,7 @@ let forceDelayedItems () = (fun {outerFunctor; outerIndex; itemPath; coercionFrom; coercionTo} -> if not (PosSet.mem outerFunctor !ambiguousFunctorKeys) then let resolved = - resolveArgumentItems ~depth:0 outerFunctor outerIndex itemPath + resolveArgumentItems ~visited:[] outerFunctor outerIndex itemPath in let applied = !delayedApplications From 3042528c607e9eed3b548ad7398fbf8f99f9bb98 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 16:55:30 +0000 Subject: [PATCH 17/53] Address review: partial applications held locally or bound in other units A module binding's shape is stored already reduced, so an application's structure cannot be read off it. Instead, each unit gets a resolver built from its own occurrence data (cached), and the head of a functor expression is chased with the resolver of the unit binding it: aliases and partial applications bound in other units resolve to the originating functor with the consumed argument count. let-module bindings keep the consumed count in the identifier fallback used before OCaml 5.5. Regression cases: run_letpartial, Cross_alias.GP. --- examples/regression/src/Cross_alias.ml | 3 + examples/regression/src/Cross_alias_use.ml | 8 + examples/regression/src/Main.ml | 2 + .../regression/src/Shared_signature_arg.ml | 12 ++ scripts/run_integration_tests.js | 9 + src/Compat.ml | 177 +++++++++++------- src/DeadValue.ml | 33 ++-- 7 files changed, 157 insertions(+), 87 deletions(-) diff --git a/examples/regression/src/Cross_alias.ml b/examples/regression/src/Cross_alias.ml index a631f899..56d0910b 100644 --- a/examples/regression/src/Cross_alias.ml +++ b/examples/regression/src/Cross_alias.ml @@ -1,2 +1,5 @@ (* An alias of a functor defined in another file, applied from a third. *) module G = Shared_signature_arg.Apply_opt + +(* A partial application bound in this file, completed from another. *) +module GP = Shared_signature_arg.Apply2 (Shared_signature_arg.Chosen) diff --git a/examples/regression/src/Cross_alias_use.ml b/examples/regression/src/Cross_alias_use.ml index 800d348d..34f02900 100644 --- a/examples/regression/src/Cross_alias_use.ml +++ b/examples/regression/src/Cross_alias_use.ml @@ -5,3 +5,11 @@ end module Applied_cross = Cross_alias.G (Opt_cross) let run () = ignore (Applied_cross.run ()) + +module Opt_cross_partial : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Applied_cross_partial = Cross_alias.GP (Opt_cross_partial) + +let run_partial () = ignore (Applied_cross_partial.run ()) diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 21ed1672..04c7cfd1 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -19,4 +19,6 @@ let () = Shared_signature_arg.run_nested (); Shared_signature_arg.run_chain (); Cross_alias_use.run (); + Cross_alias_use.run_partial (); + Shared_signature_arg.run_local_partial (); ignore (Included_sig.M.f ()) diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml index bf6ac66b..02bda913 100644 --- a/examples/regression/src/Shared_signature_arg.ml +++ b/examples/regression/src/Shared_signature_arg.ml @@ -353,3 +353,15 @@ end module Applied_body = Apply_in_body (struct end) let run_chain () = ignore (Applied_chain.run () + Applied_body.run ()) + +(* [let module G = F (A) in G (B)]: a local partial application. *) +module Opt_letpartial : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +let run_letpartial () = + let module G = Apply2 (Chosen) in + let module Applied = G (Opt_letpartial) in + Applied.run () + +let run_local_partial () = ignore (run_letpartial ()) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index 14517591..94b56222 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -240,6 +240,15 @@ function runRegressionTests() { "optional argument x of function Opt_cross.+g is always supplied" ); assertIncludes(output, "Live Value +Included_sig.M.+f"); + // Partial applications: held by a let module, and bound in another file. + assertIncludes( + output, + "optional argument x of function Opt_letpartial.+g is always supplied" + ); + assertIncludes( + output, + "optional argument x of function Opt_cross_partial.+g is always supplied" + ); assertIncludes( output, "optional argument x of function Opt_constrained.+g is always supplied" diff --git a/src/Compat.ml b/src/Compat.ml index 76625ee3..ca3d4c20 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -343,6 +343,9 @@ let registerCmtFile path = type unitInfo = { shape : Shape.t option; uidToDecl : Typedtree.item_declaration Shape.Uid.Tbl.t; + cmtPath : string; (** the .cmt (or, failing that, the first file) loaded *) + unitImports : Misc.crcs; + occurrences : (Longident.t Location.loc * Shape_reduce.result) list; } (* Keyed by the list of files a unit is loaded from, so that same-named units @@ -429,17 +432,26 @@ let loadUnitInfo ~currentCmtFile ~(imports : Misc.crcs) comp_unit = in let uidToDecl = Shape.Uid.Tbl.create 64 in let shape = ref None in + let implementation = ref None in loaded - |> List.iter (fun (_, (cmt_infos : Cmt_format.cmt_infos)) -> + |> List.iter (fun (path, (cmt_infos : Cmt_format.cmt_infos)) -> Shape.Uid.Tbl.iter (fun uid decl -> if not (Shape.Uid.Tbl.mem uidToDecl uid) then Shape.Uid.Tbl.replace uidToDecl uid decl) cmt_infos.cmt_uid_to_decl; match (!shape, cmt_infos.cmt_impl_shape) with - | None, Some _ -> shape := cmt_infos.cmt_impl_shape + | None, Some _ -> + shape := cmt_infos.cmt_impl_shape; + implementation := Some (path, cmt_infos) | _ -> ()); - let info = {shape = !shape; uidToDecl} in + let cmtPath, unitImports, occurrences = + match (!implementation, loaded) with + | Some (path, cmt_infos), _ | None, (path, cmt_infos) :: _ -> + (path, cmt_infos.cmt_imports, cmt_infos.cmt_ident_occurrences) + | None, [] -> ("", [], []) + in + let info = {shape = !shape; uidToDecl; cmtPath; unitImports; occurrences} in Hashtbl.replace unitInfoCache cacheKey info; Some info) @@ -543,10 +555,12 @@ type identResolutions = { moduleTypeOf : Location.t -> string -> Types.module_type option; (** occurrence location, last name -> the module type a [module type X = ...] declaration denotes *) - moduleDefinition : - Location.t -> string -> (Location.t * Typedtree.module_expr) option; - (** occurrence location, last name -> the module binding's name location - and expression *) + headKey : int -> Typedtree.module_expr -> (Location.t * int) option; + (** fuel, module expression -> the binding name location of the functor + it stands for, through aliases and partial applications (possibly + bound in other units, resolved with those units' own occurrence + data), and the number of arguments those partial applications + consumed; inline functors are keyed by their own location *) expandModuleType : Types.module_type -> Types.module_type; (** follow module type aliases ([module type S = Base]) until a signature or an unresolvable name is reached *) @@ -560,7 +574,7 @@ let emptyIdentResolutions = projModule = (fun _ _ -> None); moduleDefLoc = (fun _ _ -> None); moduleTypeOf = (fun _ _ -> None); - moduleDefinition = (fun _ _ -> None); + headKey = (fun _ _ -> None); expandModuleType = (fun mt -> mt); } @@ -594,22 +608,25 @@ let shapeResolutionAvailable = false #endif -let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : - identResolutions = #if OCAML_VERSION >= (5, 3, 0) +(* Resolvers of other units, by .cmt path, for chasing definitions bound + there (aliases and partial applications of functors). *) +let resolverCache : (string, identResolutions) Hashtbl.t = Hashtbl.create 16 + +let rec makeResolver ~cmtFilePath + ~(local : Typedtree.item_declaration Shape.Uid.Tbl.t) + ~(imports : Misc.crcs) ~(implShape : Shape.t option) + ~(occurrences : (Longident.t Location.loc * Shape_reduce.result) list) : + identResolutions = let module Reduce = Shape_reduce.Make (struct let fuel = 10 let read_unit_shape ~unit_name = - match - loadUnitInfo ~currentCmtFile:cmtFilePath ~imports:cmt_infos.cmt_imports - unit_name - with + match loadUnitInfo ~currentCmtFile:cmtFilePath ~imports unit_name with | Some {shape} -> shape | None -> None end) in - let local = cmt_infos.cmt_uid_to_decl in - let imports = cmt_infos.cmt_imports in + let thisUnit = unitNameOfCmtFile cmtFilePath in let locOfUid = locOfUid ~currentCmtFile:cmtFilePath ~imports ~local in let rec uidOfResult (result : Shape_reduce.result) = match result with @@ -648,7 +665,7 @@ let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : in let spelled = Hashtbl.create 64 in let ambiguous = Hashtbl.create 4 in - cmt_infos.cmt_ident_occurrences + occurrences |> List.iter (fun ((lid : Longident.t Location.loc), result) -> if not lid.loc.loc_ghost then match identity lid.txt result with @@ -658,7 +675,7 @@ let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : match Hashtbl.find_opt spelled k with | Some other when other <> id -> Hashtbl.replace ambiguous k () | _ -> Hashtbl.replace spelled k id)); - cmt_infos.cmt_ident_occurrences + occurrences |> List.iter (fun ((lid : Longident.t Location.loc), result) -> if (not lid.loc.loc_ghost) && lidText lid.txt <> None then let name = Longident.last lid.txt in @@ -683,7 +700,7 @@ let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : | Some uid -> Hashtbl.replace values k (lazy (locOfUid uid)); Hashtbl.replace modules k - (match cmt_infos.cmt_impl_shape with + (match implShape with | Some impl -> findShapeByUid impl uid | None -> None); Hashtbl.replace moduleUids k (lazy (Some uid)) @@ -691,7 +708,7 @@ let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : let nonGhost (loc : Location.t option) = match loc with Some l when not l.loc_ghost -> loc | _ -> None in - { + let rec self : identResolutions = { valueImpl = (fun loc name -> match Hashtbl.find_opt values (key loc name) with @@ -731,57 +748,59 @@ let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : moduleTypeOfUid ~currentCmtFile:cmtFilePath ~imports ~local uid | None -> None) | None -> None); - moduleDefinition = + headKey = (let bindingOfUid = moduleBindingOfUid ~currentCmtFile:cmtFilePath ~imports ~local in - (* The shape of the module defined with [uid], in its own unit. *) - let shapeOfDefinition (uid : Shape.Uid.t) = - let impl = - match uid with - | Shape.Uid.Item {comp_unit; _} -> ( - match - loadUnitInfo ~currentCmtFile:cmtFilePath ~imports comp_unit - with - | Some {shape} -> shape - | None -> None) - | _ -> None - in - match impl with - | Some impl -> findShapeByUid impl uid - | None -> None + let rec unwrap (e : Typedtree.module_expr) = + match e.mod_desc with + | Tmod_constraint (inner, _, _, _) -> unwrap inner + | _ -> e in - let isAlias (definition : Typedtree.module_expr) = - let rec go (e : Typedtree.module_expr) = - match e.mod_desc with - | Tmod_ident _ -> true - | Tmod_constraint (inner, _, _, _) -> go inner - | _ -> false - in - go definition + (* The resolver of the unit defining [uid]: this one, or that unit's + own, built from its occurrence data. *) + let resolverOfUid (uid : Shape.Uid.t) = + match uid with + | Shape.Uid.Item {comp_unit; _} when comp_unit = thisUnit -> Some self + | Shape.Uid.Item {comp_unit; _} -> + resolverForUnit ~currentCmtFile:cmtFilePath ~imports comp_unit + | _ -> None in - (* [module G = A.F], possibly in another unit: chase the alias through - its shape, which needs no occurrence data of that unit. *) - let rec chase visited uid = - match bindingOfUid uid with - | Some (loc, _) when loc.loc_ghost -> None - | Some (_, definition) as def when isAlias definition -> ( - match shapeOfDefinition uid with - | Some shape when not (List.mem uid visited) -> ( - match Reduce.reduce_for_uid Env.empty shape |> uidOfResult with - | Some target when target <> uid -> ( - match chase (uid :: visited) target with - | Some def -> Some def - | None -> def) - | _ -> def) - | _ -> def) - | def -> def + let rec headKey fuel (e : Typedtree.module_expr) = + if fuel = 0 then None + else + match e.mod_desc with + | Tmod_apply (functorExpr, _, _) -> ( + match headKey fuel functorExpr with + | Some (loc, consumed) -> Some (loc, consumed + 1) + | None -> None) + | Tmod_constraint (inner, _, _, _) -> headKey fuel inner + | Tmod_functor _ -> Some (e.mod_loc, 0) + | Tmod_ident (path, lid) -> ( + match Hashtbl.find_opt moduleUids (key lid.loc (Path.last path)) with + | Some uid -> ( + match Lazy.force uid with + | Some uid -> ( + match bindingOfUid uid with + | Some (loc, _) when loc.loc_ghost -> None + | Some (loc, definition) -> ( + match (unwrap definition).mod_desc with + | Tmod_apply _ | Tmod_ident _ -> ( + (* Bound to a partial application or an alias: chase + it with the resolver of the unit binding it. *) + match resolverOfUid uid with + | Some resolver -> ( + match resolver.headKey (fuel - 1) definition with + | Some head -> Some head + | None -> Some (loc, 0)) + | None -> Some (loc, 0)) + | _ -> Some (loc, 0)) + | None -> None) + | None -> None) + | None -> None) + | _ -> None in - fun loc name -> - match Hashtbl.find_opt moduleUids (key loc name) with - | Some uid -> ( - match Lazy.force uid with Some uid -> chase [] uid | None -> None) - | None -> None); + headKey); expandModuleType = (let compUnitShape name = {Shape.uid = None; desc = Comp_unit name; approximated = false} @@ -807,7 +826,7 @@ let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : Ident.same mbId id | _ -> false) in - match (uid, cmt_infos.cmt_impl_shape) with + match (uid, implShape) with | Some uid, Some impl -> findShapeByUid impl uid | _ -> None) | Pdot (p, name) -> ( @@ -870,7 +889,31 @@ let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : | _ -> moduleType in expand []); - } + } in + self + +and resolverForUnit ~currentCmtFile ~imports comp_unit = + match loadUnitInfo ~currentCmtFile ~imports comp_unit with + | Some info when info.cmtPath <> "" -> ( + match Hashtbl.find_opt resolverCache info.cmtPath with + | Some resolver -> Some resolver + | None -> + let resolver = + makeResolver ~cmtFilePath:info.cmtPath ~local:info.uidToDecl + ~imports:info.unitImports ~implShape:info.shape + ~occurrences:info.occurrences + in + Hashtbl.replace resolverCache info.cmtPath resolver; + Some resolver) + | _ -> None +#endif + +let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : + identResolutions = +#if OCAML_VERSION >= (5, 3, 0) + makeResolver ~cmtFilePath ~local:cmt_infos.cmt_uid_to_decl + ~imports:cmt_infos.cmt_imports ~implShape:cmt_infos.cmt_impl_shape + ~occurrences:cmt_infos.cmt_ident_occurrences #else let _ = (cmtFilePath, cmt_infos) in emptyIdentResolutions diff --git a/src/DeadValue.ml b/src/DeadValue.ml index ec8a5b94..ed2dec82 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -214,7 +214,7 @@ let findFunctorKey (moduleExpr : Typedtree.module_expr) = (* Functors that applications in the same file cannot find by uid, keyed by identifier: [let module] bindings (not registered as declarations before OCaml 5.5) and recursive modules (whose occurrences have no uid). *) -let functorsByIdent : (Ident.t * Lexing.position) list ref = ref [] +let functorsByIdent : (Ident.t * (Lexing.position * int)) list ref = ref [] let rec pathComponents (path : Path.t) = match path with @@ -377,27 +377,19 @@ let rec functorKeyOfHead ~fuel (e : Typedtree.module_expr) = | Tmod_functor _ -> (* Inline functor: keyed by its own position, see [functorKeys]. *) Some (e.mod_loc.loc_start, 0) - | Tmod_ident (path, lid) -> ( + | Tmod_ident (path, _lid) -> ( let byIdent () = match List.find_opt (fun (id, _) -> Ident.same id (Path.head path)) !functorsByIdent with - | Some (_, pos) -> Some (pos, 0) + | Some (_, key) -> Some key | None -> None | exception _ -> None in - match !identResolutions.moduleDefinition lid.loc (Path.last path) with - | Some (nameLoc, definition) -> ( - match (moduleIdent definition, definition.mod_desc) with - | None, Tmod_apply _ -> functorKeyOfHead ~fuel:(fuel - 1) definition - | Some _, _ -> ( - (* An alias: chase it, falling back to the alias's own binding. *) - match functorKeyOfHead ~fuel:(fuel - 1) definition with - | Some key -> Some key - | None -> Some (nameLoc.loc_start, 0)) - | _ -> Some (nameLoc.loc_start, 0)) + match !identResolutions.headKey fuel e with + | Some (nameLoc, consumed) -> Some (nameLoc.loc_start, consumed) | None -> byIdent ()) | _ -> None @@ -414,14 +406,15 @@ let rec collectExpr super self (e : Typedtree.expression) = registerParameterAlias id moduleExpr; (match id with | Some id -> - (* [let module G = F in]: G stands for F's key. *) + (* [let module G = F in] or [let module G = F (A) in]: G stands for + F's key, with the arguments already consumed. *) let key = - match moduleIdent moduleExpr with - | Some _ -> ( + match moduleExpr.mod_desc with + | Tmod_functor _ -> (name.loc.loc_start, 0) + | _ -> ( match functorKeyOfHead ~fuel:8 moduleExpr with - | Some (key, 0) -> key - | _ -> name.loc.loc_start) - | None -> name.loc.loc_start + | Some key -> key + | None -> (name.loc.loc_start, 0)) in functorsByIdent := (id, key) :: !functorsByIdent | None -> ()) @@ -1007,7 +1000,7 @@ let traverseStructure ~doTypes ~doExternals = match mb.mb_id with | Some id -> functorsByIdent := - (id, mb.mb_name.loc.loc_start) :: !functorsByIdent + (id, (mb.mb_name.loc.loc_start, 0)) :: !functorsByIdent | None -> ()) | Tstr_primitive vd when doExternals && !Config.analyzeExternals -> let currentModulePath = ModulePath.getCurrent () in From dae35e23fad20c411e3907152ad6a3d340593512 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 17:03:05 +0000 Subject: [PATCH 18/53] Address review: with-constrained module types, alias cycle detection - Module type ranges are collected through Tmty_with. - The functor head chase tracks visited bindings instead of a fuel counter, so long alias chains resolve and cycles still terminate. Regression cases: Included_sig.W (with constraint), Alias1..Alias9. --- examples/regression/src/Included_sig.ml | 12 +++ examples/regression/src/Included_sig.mli | 11 +++ examples/regression/src/Main.ml | 4 +- .../regression/src/Shared_signature_arg.ml | 20 +++++ scripts/run_integration_tests.js | 6 ++ src/Compat.ml | 89 +++++++++++-------- src/DeadCode.ml | 1 + src/DeadValue.ml | 14 ++- 8 files changed, 111 insertions(+), 46 deletions(-) diff --git a/examples/regression/src/Included_sig.ml b/examples/regression/src/Included_sig.ml index ea25e758..a3327a25 100644 --- a/examples/regression/src/Included_sig.ml +++ b/examples/regression/src/Included_sig.ml @@ -5,3 +5,15 @@ end module M : S = struct let f () = 5 end + +module W = struct + type t = int + + module type S2 = sig + val f : unit -> int + end + + module X = struct + let f () = 7 + end +end diff --git a/examples/regression/src/Included_sig.mli b/examples/regression/src/Included_sig.mli index 24f3bd5b..34911749 100644 --- a/examples/regression/src/Included_sig.mli +++ b/examples/regression/src/Included_sig.mli @@ -5,3 +5,14 @@ include sig module M : S end + +module W : sig + type t + + module type S2 = sig + val f : unit -> int + end + + module X : S2 +end +with type t = int diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 04c7cfd1..3ca8f5b7 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -21,4 +21,6 @@ let () = Cross_alias_use.run (); Cross_alias_use.run_partial (); Shared_signature_arg.run_local_partial (); - ignore (Included_sig.M.f ()) + ignore (Included_sig.M.f ()); + ignore (Included_sig.W.X.f ()); + Shared_signature_arg.run_alias9 () diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml index 02bda913..4ea1a85d 100644 --- a/examples/regression/src/Shared_signature_arg.ml +++ b/examples/regression/src/Shared_signature_arg.ml @@ -365,3 +365,23 @@ let run_letpartial () = Applied.run () let run_local_partial () = ignore (run_letpartial ()) + + +(* A functor reached through nine aliases. *) +module Opt_alias9 : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Alias1 = Apply_opt +module Alias2 = Alias1 +module Alias3 = Alias2 +module Alias4 = Alias3 +module Alias5 = Alias4 +module Alias6 = Alias5 +module Alias7 = Alias6 +module Alias8 = Alias7 +module Alias9 = Alias8 + +module Applied_alias9 = Alias9 (Opt_alias9) + +let run_alias9 () = ignore (Applied_alias9.run ()) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index 94b56222..f1e1c629 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -240,6 +240,12 @@ function runRegressionTests() { "optional argument x of function Opt_cross.+g is always supplied" ); assertIncludes(output, "Live Value +Included_sig.M.+f"); + // A module type nested in a with-constrained signature; nine aliases. + assertIncludes(output, "Live Value +Included_sig.W.X.+f"); + assertIncludes( + output, + "optional argument x of function Opt_alias9.+g is always supplied" + ); // Partial applications: held by a let module, and bound in another file. assertIncludes( output, diff --git a/src/Compat.ml b/src/Compat.ml index ca3d4c20..41b68d5f 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -540,6 +540,21 @@ type moduleShape = unit #endif +(* Bindings already chased when resolving a functor head, to break cycles. *) +type headVisited = +#if OCAML_VERSION >= (5, 3, 0) + Shape.Uid.t list +#else + unit +#endif + +let noHeadVisited : headVisited = +#if OCAML_VERSION >= (5, 3, 0) + [] +#else + () +#endif + type identResolutions = { valueImpl : Location.t -> string -> Location.t option; (** occurrence location, last name -> implementation location *) @@ -555,12 +570,14 @@ type identResolutions = { moduleTypeOf : Location.t -> string -> Types.module_type option; (** occurrence location, last name -> the module type a [module type X = ...] declaration denotes *) - headKey : int -> Typedtree.module_expr -> (Location.t * int) option; - (** fuel, module expression -> the binding name location of the functor - it stands for, through aliases and partial applications (possibly - bound in other units, resolved with those units' own occurrence - data), and the number of arguments those partial applications - consumed; inline functors are keyed by their own location *) + headKey : + headVisited -> Typedtree.module_expr -> (Location.t * int) option; + (** visited bindings (start with [noHeadVisited]), module expression -> + the binding name location of the functor it stands for, through + aliases and partial applications (possibly bound in other units, + resolved with those units' own occurrence data), and the number of + arguments those partial applications consumed; inline functors are + keyed by their own location *) expandModuleType : Types.module_type -> Types.module_type; (** follow module type aliases ([module type S = Base]) until a signature or an unresolvable name is reached *) @@ -766,39 +783,37 @@ let rec makeResolver ~cmtFilePath resolverForUnit ~currentCmtFile:cmtFilePath ~imports comp_unit | _ -> None in - let rec headKey fuel (e : Typedtree.module_expr) = - if fuel = 0 then None - else - match e.mod_desc with - | Tmod_apply (functorExpr, _, _) -> ( - match headKey fuel functorExpr with - | Some (loc, consumed) -> Some (loc, consumed + 1) - | None -> None) - | Tmod_constraint (inner, _, _, _) -> headKey fuel inner - | Tmod_functor _ -> Some (e.mod_loc, 0) - | Tmod_ident (path, lid) -> ( - match Hashtbl.find_opt moduleUids (key lid.loc (Path.last path)) with - | Some uid -> ( - match Lazy.force uid with - | Some uid -> ( - match bindingOfUid uid with - | Some (loc, _) when loc.loc_ghost -> None - | Some (loc, definition) -> ( - match (unwrap definition).mod_desc with - | Tmod_apply _ | Tmod_ident _ -> ( - (* Bound to a partial application or an alias: chase - it with the resolver of the unit binding it. *) - match resolverOfUid uid with - | Some resolver -> ( - match resolver.headKey (fuel - 1) definition with - | Some head -> Some head - | None -> Some (loc, 0)) + let rec headKey (visited : headVisited) (e : Typedtree.module_expr) = + match e.mod_desc with + | Tmod_apply (functorExpr, _, _) -> ( + match headKey visited functorExpr with + | Some (loc, consumed) -> Some (loc, consumed + 1) + | None -> None) + | Tmod_constraint (inner, _, _, _) -> headKey visited inner + | Tmod_functor _ -> Some (e.mod_loc, 0) + | Tmod_ident (path, lid) -> ( + match Hashtbl.find_opt moduleUids (key lid.loc (Path.last path)) with + | Some uid -> ( + match Lazy.force uid with + | Some uid when not (List.mem uid visited) -> ( + match bindingOfUid uid with + | Some (loc, _) when loc.loc_ghost -> None + | Some (loc, definition) -> ( + match (unwrap definition).mod_desc with + | Tmod_apply _ | Tmod_ident _ -> ( + (* Bound to a partial application or an alias: chase it + with the resolver of the unit binding it. *) + match resolverOfUid uid with + | Some resolver -> ( + match resolver.headKey (uid :: visited) definition with + | Some head -> Some head | None -> Some (loc, 0)) - | _ -> Some (loc, 0)) - | None -> None) + | None -> Some (loc, 0)) + | _ -> Some (loc, 0)) | None -> None) - | None -> None) - | _ -> None + | _ -> None) + | None -> None) + | _ -> None in headKey); expandModuleType = diff --git a/src/DeadCode.ml b/src/DeadCode.ml index e407e892..ce64b007 100644 --- a/src/DeadCode.ml +++ b/src/DeadCode.ml @@ -53,6 +53,7 @@ and moduleTypeRangesOfModuleType (moduleType : Typedtree.module_type) = match moduleType.mty_desc with | Tmty_signature signature -> moduleTypeRangesOfSignature signature | Tmty_functor (_, body) -> moduleTypeRangesOfModuleType body + | Tmty_with (base, _) -> moduleTypeRangesOfModuleType base | _ -> [] let processCmt ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) = diff --git a/src/DeadValue.ml b/src/DeadValue.ml index ed2dec82..9ca38c48 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -365,15 +365,13 @@ let addValueReferenceOrRedirect ~(locFrom : Location.t) ~(locTo : Location.t) arguments already consumed by partial applications it stands for, as in [module G = F (A)] followed by [G (B)]. Aliases ([module G = F]) are chased within the current file. *) -let rec functorKeyOfHead ~fuel (e : Typedtree.module_expr) = - if fuel = 0 then None - else +let rec functorKeyOfHead (e : Typedtree.module_expr) = match e.mod_desc with | Tmod_apply (functorExpr, _, _) -> ( - match functorKeyOfHead ~fuel functorExpr with + match functorKeyOfHead functorExpr with | Some (key, consumed) -> Some (key, consumed + 1) | None -> None) - | Tmod_constraint (inner, _, _, _) -> functorKeyOfHead ~fuel inner + | Tmod_constraint (inner, _, _, _) -> functorKeyOfHead inner | Tmod_functor _ -> (* Inline functor: keyed by its own position, see [functorKeys]. *) Some (e.mod_loc.loc_start, 0) @@ -388,7 +386,7 @@ let rec functorKeyOfHead ~fuel (e : Typedtree.module_expr) = | None -> None | exception _ -> None in - match !identResolutions.headKey fuel e with + match !identResolutions.headKey Compat.noHeadVisited e with | Some (nameLoc, consumed) -> Some (nameLoc.loc_start, consumed) | None -> byIdent ()) | _ -> None @@ -412,7 +410,7 @@ let rec collectExpr super self (e : Typedtree.expression) = match moduleExpr.mod_desc with | Tmod_functor _ -> (name.loc.loc_start, 0) | _ -> ( - match functorKeyOfHead ~fuel:8 moduleExpr with + match functorKeyOfHead moduleExpr with | Some key -> key | None -> (name.loc.loc_start, 0)) in @@ -842,7 +840,7 @@ let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = | _ -> (e, args) in let head, args = flatten moduleExpr [] in - let key = functorKeyOfHead ~fuel:8 head in + let key = functorKeyOfHead head in if !Common.Cli.debug then Log_.item "functorApplication %s key:%s args:%d@." (moduleExpr.mod_loc.loc_start |> posToString) From 17f2704646348f383c4eb8550b92f9e740e93c45 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 17:11:40 +0000 Subject: [PATCH 19/53] Address review: structural path resolution, recursive aliases - When a module path has no usable occurrence, its binding is found structurally: through units, local bindings, and the bodies of applied functors (Outer (A).Inner), so the functor key can still be derived. - Recursive module bindings aliasing or partially applying a functor take that functor's key. Regression cases: Applied_outer_f.Inner, Rec_alias. --- examples/regression/src/Main.ml | 3 +- .../regression/src/Shared_signature_arg.ml | 28 +++ scripts/run_integration_tests.js | 9 + src/Compat.ml | 160 ++++++++++++++---- src/DeadValue.ml | 13 +- 5 files changed, 177 insertions(+), 36 deletions(-) diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 3ca8f5b7..942bfe64 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -23,4 +23,5 @@ let () = Shared_signature_arg.run_local_partial (); ignore (Included_sig.M.f ()); ignore (Included_sig.W.X.f ()); - Shared_signature_arg.run_alias9 () + Shared_signature_arg.run_alias9 (); + Shared_signature_arg.run_ext () diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml index 4ea1a85d..d9a24ee9 100644 --- a/examples/regression/src/Shared_signature_arg.ml +++ b/examples/regression/src/Shared_signature_arg.ml @@ -385,3 +385,31 @@ module Alias9 = Alias8 module Applied_alias9 = Alias9 (Opt_alias9) let run_alias9 () = ignore (Applied_alias9.run ()) + +(* A nested functor applied through an extended path: [Outer_f (A).Inner (B)]. *) +module Opt_ext : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Outer_f (A : Shared_signature.S) = struct + module Inner (B : Shared_signature.O) = struct + let run () = A.f () + B.g ~x:1 () + end +end + +module Applied_outer_f = Outer_f (Chosen) +module Applied_ext = Applied_outer_f.Inner (Opt_ext) + +(* A recursive module binding aliasing a functor. *) +module Opt_rec_alias : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module rec Rec_alias : functor (M : Shared_signature.O) -> sig + val run : unit -> int +end = + Apply_opt + +module Applied_rec_alias = Rec_alias (Opt_rec_alias) + +let run_ext () = ignore (Applied_ext.run () + Applied_rec_alias.run ()) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index f1e1c629..17c35f22 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -246,6 +246,15 @@ function runRegressionTests() { output, "optional argument x of function Opt_alias9.+g is always supplied" ); + // A nested functor applied through Outer (A).Inner; a recursive alias. + assertIncludes( + output, + "optional argument x of function Opt_ext.+g is always supplied" + ); + assertIncludes( + output, + "optional argument x of function Opt_rec_alias.+g is always supplied" + ); // Partial applications: held by a let module, and bound in another file. assertIncludes( output, diff --git a/src/Compat.ml b/src/Compat.ml index 41b68d5f..80947260 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -644,6 +644,18 @@ let rec makeResolver ~cmtFilePath | None -> None end) in let thisUnit = unitNameOfCmtFile cmtFilePath in + let compUnitShape name = + {Shape.uid = None; desc = Comp_unit name; approximated = false} + in + (* The uid of a declaration of this unit, by identifier. *) + let localUid (matches : Typedtree.item_declaration -> bool) = + Shape.Uid.Tbl.fold + (fun uid decl acc -> + match acc with + | Some _ -> acc + | None -> if matches decl then Some uid else None) + local None + in let locOfUid = locOfUid ~currentCmtFile:cmtFilePath ~imports ~local in let rec uidOfResult (result : Shape_reduce.result) = match result with @@ -783,6 +795,97 @@ let rec makeResolver ~cmtFilePath resolverForUnit ~currentCmtFile:cmtFilePath ~imports comp_unit | _ -> None in + (* The key of a binding found for a module expression: a functor is + keyed by the binding; an alias or a partial application is chased + with the resolver of the unit binding it. *) + let keyOfBinding visited (loc : Location.t) + (definition : Typedtree.module_expr) resolver = + if loc.loc_ghost then None + else + match (unwrap definition).mod_desc with + | Tmod_apply _ | Tmod_ident _ -> ( + match resolver with + | Some (resolver : identResolutions) -> ( + match resolver.headKey visited definition with + | Some head -> Some head + | None -> Some (loc, 0)) + | None -> Some (loc, 0)) + | _ -> Some (loc, 0) + in + (* The binding a module path denotes, structurally: through units, + local bindings, and the bodies of applied functors, as in + [Outer (A).Inner]. Returns the binding, the resolver of its unit, + and the number of functor layers the path applied. *) + let rec bindingOfPath (path : Path.t) : + (Location.t * Typedtree.module_expr * identResolutions option * int) + option = + match path with + | Pident id when Ident.global id -> None + | Pident id -> ( + let uid = + localUid (function + | Typedtree.Module_binding {mb_id = Some mbId} -> + Ident.same mbId id + | _ -> false) + in + match uid with + | Some uid -> ( + match bindingOfUid uid with + | Some (loc, definition) -> Some (loc, definition, Some self, 0) + | None -> None) + | None -> None) + | Pdot (Pident unit, name) when Ident.global unit -> ( + let shape = + Shape.proj (compUnitShape (Ident.name unit)) + (Shape.Item.make name Module) + in + match Reduce.reduce_for_uid Env.empty shape |> uidOfResult with + | Some uid -> ( + match bindingOfUid uid with + | Some (loc, definition) -> + Some (loc, definition, resolverOfUid uid, 0) + | None -> None) + | None -> None) + | Pdot (parent, name) -> ( + match bindingOfPath parent with + | Some (_, definition, resolver, applied) -> ( + (* Peel the applied functor layers, then find the member. *) + let rec body (e : Typedtree.module_expr) applied = + match e.mod_desc with + | Tmod_constraint (inner, _, _, _) -> body inner applied + | Tmod_functor (_, inner) when applied > 0 -> + body inner (applied - 1) + | Tmod_structure structure when applied = 0 -> Some structure + | _ -> None + in + match body definition applied with + | Some structure -> ( + let member = + structure.str_items + |> List.find_map (fun (item : Typedtree.structure_item) -> + match item.str_desc with + | Tstr_module ({mb_name = {txt = Some n}} as mb) + when n = name -> + Some mb + | Tstr_recmodule mbs -> + mbs + |> List.find_opt + (fun (mb : Typedtree.module_binding) -> + mb.mb_name.txt = Some name) + | _ -> None) + in + match member with + | Some mb -> Some (mb.mb_name.loc, mb.mb_expr, resolver, 0) + | None -> None) + | None -> None) + | None -> None) + | Papply (functorPath, _) -> ( + match bindingOfPath functorPath with + | Some (loc, definition, resolver, applied) -> + Some (loc, definition, resolver, applied + 1) + | None -> None) + | _ -> None + in let rec headKey (visited : headVisited) (e : Typedtree.module_expr) = match e.mod_desc with | Tmod_apply (functorExpr, _, _) -> ( @@ -792,44 +895,35 @@ let rec makeResolver ~cmtFilePath | Tmod_constraint (inner, _, _, _) -> headKey visited inner | Tmod_functor _ -> Some (e.mod_loc, 0) | Tmod_ident (path, lid) -> ( - match Hashtbl.find_opt moduleUids (key lid.loc (Path.last path)) with - | Some uid -> ( - match Lazy.force uid with - | Some uid when not (List.mem uid visited) -> ( - match bindingOfUid uid with - | Some (loc, _) when loc.loc_ghost -> None - | Some (loc, definition) -> ( - match (unwrap definition).mod_desc with - | Tmod_apply _ | Tmod_ident _ -> ( - (* Bound to a partial application or an alias: chase it - with the resolver of the unit binding it. *) - match resolverOfUid uid with - | Some resolver -> ( - match resolver.headKey (uid :: visited) definition with - | Some head -> Some head - | None -> Some (loc, 0)) - | None -> Some (loc, 0)) - | _ -> Some (loc, 0)) + let byOccurrence = + match Longident.last lid.txt with + | exception Misc.Fatal_error -> None + | name -> ( + match Hashtbl.find_opt moduleUids (key lid.loc name) with + | Some uid -> ( + match Lazy.force uid with + | Some uid when not (List.mem uid visited) -> ( + match bindingOfUid uid with + | Some (loc, definition) -> + keyOfBinding (uid :: visited) loc definition + (resolverOfUid uid) + | None -> None) + | _ -> None) | None -> None) - | _ -> None) - | None -> None) + in + match byOccurrence with + | Some head -> Some head + | None -> ( + (* No usable occurrence (e.g. [Outer (A).Inner]): structurally. *) + match bindingOfPath path with + | Some (loc, definition, resolver, 0) -> + keyOfBinding visited loc definition resolver + | _ -> None)) | _ -> None in headKey); expandModuleType = - (let compUnitShape name = - {Shape.uid = None; desc = Comp_unit name; approximated = false} - in - (* The uid of a declaration of the current unit, by identifier. *) - let localUid (matches : Typedtree.item_declaration -> bool) = - Shape.Uid.Tbl.fold - (fun uid decl acc -> - match acc with - | Some _ -> acc - | None -> if matches decl then Some uid else None) - local None - in - (* Shape of a module path rooted at a compilation unit or at a module + ( (* Shape of a module path rooted at a compilation unit or at a module of the current unit. *) let rec moduleShapeOfPath (path : Path.t) = match path with diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 9ca38c48..97954205 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -997,8 +997,17 @@ let traverseStructure ~doTypes ~doExternals = claimFunctorKey mb.mb_expr mb.mb_name.loc.loc_start; match mb.mb_id with | Some id -> - functorsByIdent := - (id, (mb.mb_name.loc.loc_start, 0)) :: !functorsByIdent + (* [module rec G : T = F], or a partial application: G stands + for F's key. *) + let key = + match (moduleIdent mb.mb_expr, mb.mb_expr.mod_desc) with + | None, Tmod_functor _ -> (mb.mb_name.loc.loc_start, 0) + | _ -> ( + match functorKeyOfHead mb.mb_expr with + | Some key -> key + | None -> (mb.mb_name.loc.loc_start, 0)) + in + functorsByIdent := (id, key) :: !functorsByIdent | None -> ()) | Tstr_primitive vd when doExternals && !Config.analyzeExternals -> let currentModulePath = ModulePath.getCurrent () in From 53687b3b4d2ed9d163d96dc65e9098a0d83510d1 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 17:20:16 +0000 Subject: [PATCH 20/53] Address review: with module type constraints, recursive parameter aliases, reducer fuel - Module types carried by with module type constraints are part of the excluded ranges. - The structural path fallback picks the last binding of a name. - Recursive module bindings aliasing a functor parameter register as parameter aliases. - The shape reducer's fuel, which bounds recursive shapes, is raised so long alias and projection chains are not cut short. Regression cases: Included_sig.W2, Apply_recalias. --- examples/regression/src/Included_sig.ml | 10 ++++++++ examples/regression/src/Included_sig.mli | 9 +++++++ examples/regression/src/Main.ml | 4 ++- .../regression/src/Shared_signature_arg.ml | 20 +++++++++++++++ scripts/run_integration_tests.js | 11 ++++++++ src/Compat.ml | 25 +++++++++++++------ src/DeadCode.ml | 11 +++++++- src/DeadValue.ml | 1 + 8 files changed, 81 insertions(+), 10 deletions(-) diff --git a/examples/regression/src/Included_sig.ml b/examples/regression/src/Included_sig.ml index a3327a25..229cbde5 100644 --- a/examples/regression/src/Included_sig.ml +++ b/examples/regression/src/Included_sig.ml @@ -17,3 +17,13 @@ module W = struct let f () = 7 end end + +module W2 = struct + module type S = sig + val f : unit -> int + end + + module X = struct + let f () = 8 + end +end diff --git a/examples/regression/src/Included_sig.mli b/examples/regression/src/Included_sig.mli index 34911749..fab23d71 100644 --- a/examples/regression/src/Included_sig.mli +++ b/examples/regression/src/Included_sig.mli @@ -16,3 +16,12 @@ module W : sig module X : S2 end with type t = int + +module W2 : sig + module type S + + module X : S +end +with module type S = sig + val f : unit -> int +end diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 942bfe64..a10f0762 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -24,4 +24,6 @@ let () = ignore (Included_sig.M.f ()); ignore (Included_sig.W.X.f ()); Shared_signature_arg.run_alias9 (); - Shared_signature_arg.run_ext () + Shared_signature_arg.run_ext (); + Shared_signature_arg.run_shadow_rec (); + ignore (Included_sig.W2.X.f ()) diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml index d9a24ee9..aebfdb46 100644 --- a/examples/regression/src/Shared_signature_arg.ml +++ b/examples/regression/src/Shared_signature_arg.ml @@ -413,3 +413,23 @@ end = module Applied_rec_alias = Rec_alias (Opt_rec_alias) let run_ext () = ignore (Applied_ext.run () + Applied_rec_alias.run ()) + +(* A recursive alias of the parameter inside the body. *) +module Opt_recalias : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_recalias_other : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Apply_recalias (M : Shared_signature.O) = struct + module rec N : Shared_signature.O = M + + let run () = N.g ~x:1 () +end + +module Applied_recalias = Apply_recalias (Opt_recalias) + +let run_shadow_rec () = + ignore (Applied_recalias.run () + Opt_recalias_other.g ()) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index 17c35f22..39a6890f 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -255,6 +255,17 @@ function runRegressionTests() { output, "optional argument x of function Opt_rec_alias.+g is always supplied" ); + // A recursive alias of the parameter; a module type introduced by a + // with-constraint. + assertIncludes( + output, + "optional argument x of function Opt_recalias.+g is always supplied" + ); + assertIncludes( + output, + "optional argument x of function Opt_recalias_other.+g is never used" + ); + assertIncludes(output, "Live Value +Included_sig.W2.X.+f"); // Partial applications: held by a let module, and bound in another file. assertIncludes( output, diff --git a/src/Compat.ml b/src/Compat.ml index 80947260..a18cec7d 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -636,7 +636,9 @@ let rec makeResolver ~cmtFilePath ~(occurrences : (Longident.t Location.loc * Shape_reduce.result) list) : identResolutions = let module Reduce = Shape_reduce.Make (struct - let fuel = 10 + (* Bounds the reduction of recursive shapes; long alias and projection + chains must not be cut short by it. *) + let fuel = 100 let read_unit_shape ~unit_name = match loadUnitInfo ~currentCmtFile:cmtFilePath ~imports unit_name with @@ -860,19 +862,26 @@ let rec makeResolver ~cmtFilePath in match body definition applied with | Some structure -> ( + (* The last binding of that name is the visible one. *) let member = structure.str_items - |> List.find_map (fun (item : Typedtree.structure_item) -> + |> List.fold_left + (fun acc (item : Typedtree.structure_item) -> match item.str_desc with | Tstr_module ({mb_name = {txt = Some n}} as mb) when n = name -> Some mb - | Tstr_recmodule mbs -> - mbs - |> List.find_opt - (fun (mb : Typedtree.module_binding) -> - mb.mb_name.txt = Some name) - | _ -> None) + | Tstr_recmodule mbs -> ( + match + mbs + |> List.find_opt + (fun (mb : Typedtree.module_binding) -> + mb.mb_name.txt = Some name) + with + | Some mb -> Some mb + | None -> acc) + | _ -> acc) + None in match member with | Some mb -> Some (mb.mb_name.loc, mb.mb_expr, resolver, 0) diff --git a/src/DeadCode.ml b/src/DeadCode.ml index ce64b007..318ebc1b 100644 --- a/src/DeadCode.ml +++ b/src/DeadCode.ml @@ -53,7 +53,16 @@ and moduleTypeRangesOfModuleType (moduleType : Typedtree.module_type) = match moduleType.mty_desc with | Tmty_signature signature -> moduleTypeRangesOfSignature signature | Tmty_functor (_, body) -> moduleTypeRangesOfModuleType body - | Tmty_with (base, _) -> moduleTypeRangesOfModuleType base + | Tmty_with (base, constraints) -> + (* A [with module type S = sig ... end] constraint carries a module type + whose items must not count as declarations either. *) + moduleTypeRangesOfModuleType base + @ (constraints + |> List.concat_map (fun (_, _, (constraint_ : Typedtree.with_constraint)) -> + match constraint_ with + | Twith_modtype mty | Twith_modtypesubst mty -> + mty.mty_loc :: moduleTypeRangesOfModuleType mty + | _ -> [])) | _ -> [] let processCmt ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) = diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 97954205..609c82f9 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -995,6 +995,7 @@ let traverseStructure ~doTypes ~doExternals = |> List.iter (fun (mb : Typedtree.module_binding) -> setFunctorKey mb.mb_expr mb.mb_name.loc.loc_start; claimFunctorKey mb.mb_expr mb.mb_name.loc.loc_start; + registerParameterAlias mb.mb_id mb.mb_expr; match mb.mb_id with | Some id -> (* [module rec G : T = F], or a partial application: G stands From a8b4936c1e17a33f7dc95607470701915c59b5d9 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 18:27:42 +0000 Subject: [PATCH 21/53] Address review: module type of, included members in structural lookup - Module type ranges are collected through module type of and through explicit constraints on module expressions. - The structural member lookup for applied-functor paths sees through includes and aliases in the body. Regression cases: Included_sig.W3, Outer_i. --- examples/regression/src/Included_sig.ml | 10 +++++ examples/regression/src/Included_sig.mli | 10 +++++ examples/regression/src/Main.ml | 4 +- .../regression/src/Shared_signature_arg.ml | 18 +++++++++ scripts/run_integration_tests.js | 6 +++ src/Compat.ml | 39 +++++++++++-------- src/DeadCode.ml | 5 ++- 7 files changed, 73 insertions(+), 19 deletions(-) diff --git a/examples/regression/src/Included_sig.ml b/examples/regression/src/Included_sig.ml index 229cbde5..0f47ae35 100644 --- a/examples/regression/src/Included_sig.ml +++ b/examples/regression/src/Included_sig.ml @@ -27,3 +27,13 @@ module W2 = struct let f () = 8 end end + +module W3 = struct + module type S3 = sig + val f : unit -> int + end + + module X : S3 = struct + let f () = 9 + end +end diff --git a/examples/regression/src/Included_sig.mli b/examples/regression/src/Included_sig.mli index fab23d71..e1dd2e19 100644 --- a/examples/regression/src/Included_sig.mli +++ b/examples/regression/src/Included_sig.mli @@ -25,3 +25,13 @@ end with module type S = sig val f : unit -> int end + +module W3 : module type of struct + module type S3 = sig + val f : unit -> int + end + + module X : S3 = struct + let f () = 9 + end +end diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index a10f0762..81904162 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -26,4 +26,6 @@ let () = Shared_signature_arg.run_alias9 (); Shared_signature_arg.run_ext (); Shared_signature_arg.run_shadow_rec (); - ignore (Included_sig.W2.X.f ()) + ignore (Included_sig.W2.X.f ()); + ignore (Included_sig.W3.X.f ()); + Shared_signature_arg.run_incl_f () diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml index aebfdb46..220259df 100644 --- a/examples/regression/src/Shared_signature_arg.ml +++ b/examples/regression/src/Shared_signature_arg.ml @@ -433,3 +433,21 @@ module Applied_recalias = Apply_recalias (Opt_recalias) let run_shadow_rec () = ignore (Applied_recalias.run () + Opt_recalias_other.g ()) + +(* A nested functor obtained through [include] in the functor's body. *) +module Opt_incl_f : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Outer_i (A : Shared_signature.S) = struct + include (struct + module Inner (B : Shared_signature.O) = struct + let run () = A.f () + B.g ~x:1 () + end + end) +end + +module Applied_outer_i = Outer_i (Chosen) +module Applied_incl_f = Applied_outer_i.Inner (Opt_incl_f) + +let run_incl_f () = ignore (Applied_incl_f.run ()) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index 39a6890f..1c7254b7 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -266,6 +266,12 @@ function runRegressionTests() { "optional argument x of function Opt_recalias_other.+g is never used" ); assertIncludes(output, "Live Value +Included_sig.W2.X.+f"); + // module type of; a nested functor obtained through include. + assertIncludes(output, "Live Value +Included_sig.W3.X.+f"); + assertIncludes( + output, + "optional argument x of function Opt_incl_f.+g is always supplied" + ); // Partial applications: held by a let module, and bound in another file. assertIncludes( output, diff --git a/src/Compat.ml b/src/Compat.ml index a18cec7d..2c84f66f 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -851,26 +851,27 @@ let rec makeResolver ~cmtFilePath | Pdot (parent, name) -> ( match bindingOfPath parent with | Some (_, definition, resolver, applied) -> ( - (* Peel the applied functor layers, then find the member. *) - let rec body (e : Typedtree.module_expr) applied = + (* Peel the applied functor layers, then find the member, the + last binding of that name (also through [include]s). *) + let rec memberIn (e : Typedtree.module_expr) applied = match e.mod_desc with - | Tmod_constraint (inner, _, _, _) -> body inner applied + | Tmod_constraint (inner, _, _, _) -> memberIn inner applied | Tmod_functor (_, inner) when applied > 0 -> - body inner (applied - 1) - | Tmod_structure structure when applied = 0 -> Some structure - | _ -> None - in - match body definition applied with - | Some structure -> ( - (* The last binding of that name is the visible one. *) - let member = + memberIn inner (applied - 1) + | Tmod_apply (functorExpr, _, _) -> + memberIn functorExpr (applied + 1) + | Tmod_ident (p, _) when applied = 0 -> ( + match bindingOfPath (Pdot (p, name)) with + | Some (loc, expr, _, 0) -> Some (loc, expr) + | _ -> None) + | Tmod_structure structure when applied = 0 -> structure.str_items |> List.fold_left (fun acc (item : Typedtree.structure_item) -> match item.str_desc with | Tstr_module ({mb_name = {txt = Some n}} as mb) when n = name -> - Some mb + Some (mb.mb_name.loc, mb.mb_expr) | Tstr_recmodule mbs -> ( match mbs @@ -878,14 +879,18 @@ let rec makeResolver ~cmtFilePath (fun (mb : Typedtree.module_binding) -> mb.mb_name.txt = Some name) with - | Some mb -> Some mb + | Some mb -> Some (mb.mb_name.loc, mb.mb_expr) + | None -> acc) + | Tstr_include {incl_mod} -> ( + match memberIn incl_mod 0 with + | Some member -> Some member | None -> acc) | _ -> acc) None - in - match member with - | Some mb -> Some (mb.mb_name.loc, mb.mb_expr, resolver, 0) - | None -> None) + | _ -> None + in + match memberIn definition applied with + | Some (loc, expr) -> Some (loc, expr, resolver, 0) | None -> None) | None -> None) | Papply (functorPath, _) -> ( diff --git a/src/DeadCode.ml b/src/DeadCode.ml index 318ebc1b..395dcd36 100644 --- a/src/DeadCode.ml +++ b/src/DeadCode.ml @@ -32,11 +32,13 @@ let rec moduleTypeRangesOfStructure (structure : Typedtree.structure) = and moduleTypeRangesOfModuleExpr (moduleExpr : Typedtree.module_expr) = match moduleExpr.mod_desc with | Tmod_structure structure -> moduleTypeRangesOfStructure structure + | Tmod_constraint (inner, _, Tmodtype_explicit mty, _) -> + moduleTypeRangesOfModuleExpr inner @ moduleTypeRangesOfModuleType mty | Tmod_constraint (inner, _, _, _) -> moduleTypeRangesOfModuleExpr inner | Tmod_functor (_, body) -> moduleTypeRangesOfModuleExpr body | _ -> [] -let rec moduleTypeRangesOfSignature (signature : Typedtree.signature) = +and moduleTypeRangesOfSignature (signature : Typedtree.signature) = signature.sig_items |> List.concat_map (fun (item : Typedtree.signature_item) -> match item.sig_desc with @@ -63,6 +65,7 @@ and moduleTypeRangesOfModuleType (moduleType : Typedtree.module_type) = | Twith_modtype mty | Twith_modtypesubst mty -> mty.mty_loc :: moduleTypeRangesOfModuleType mty | _ -> [])) + | Tmty_typeof moduleExpr -> moduleTypeRangesOfModuleExpr moduleExpr | _ -> [] let processCmt ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) = From b960ab283ecc171550e3cc281719249189a43cbb Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 18:36:34 +0000 Subject: [PATCH 22/53] Address review: resolve included members with the defining unit's resolver The structural member lookup is exposed on the resolver record, and the lookup of a module included into a foreign functor body uses the resolver of the unit defining that body, whose local bindings the consumer cannot see. Regression case: Cross_include.Outer_x applied from Cross_alias_use. --- examples/regression/src/Cross_alias_use.ml | 9 + examples/regression/src/Cross_include.ml | 12 ++ examples/regression/src/Main.ml | 1 + examples/regression/src/dune | 1 + scripts/run_integration_tests.js | 4 + src/Compat.ml | 216 +++++++++++---------- 6 files changed, 143 insertions(+), 100 deletions(-) create mode 100644 examples/regression/src/Cross_include.ml diff --git a/examples/regression/src/Cross_alias_use.ml b/examples/regression/src/Cross_alias_use.ml index 34f02900..e694b708 100644 --- a/examples/regression/src/Cross_alias_use.ml +++ b/examples/regression/src/Cross_alias_use.ml @@ -13,3 +13,12 @@ end module Applied_cross_partial = Cross_alias.GP (Opt_cross_partial) let run_partial () = ignore (Applied_cross_partial.run ()) + +module Opt_cross_incl : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Applied_outer_x = Cross_include.Outer_x (Shared_signature_arg.Chosen) +module Applied_cross_incl = Applied_outer_x.Inner (Opt_cross_incl) + +let run_incl () = ignore (Applied_cross_incl.run ()) diff --git a/examples/regression/src/Cross_include.ml b/examples/regression/src/Cross_include.ml new file mode 100644 index 00000000..5955e8d4 --- /dev/null +++ b/examples/regression/src/Cross_include.ml @@ -0,0 +1,12 @@ +(* A functor whose result obtains a nested functor through an include of a + module local to this file; applied from another file. *) +module Helpers = struct + module Inner (B : Shared_signature.O) = struct + let run () = B.g ~x:1 () + end +end + +module Outer_x (A : Shared_signature.S) = struct + let _ = A.f + include Helpers +end diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 81904162..00e4e825 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -20,6 +20,7 @@ let () = Shared_signature_arg.run_chain (); Cross_alias_use.run (); Cross_alias_use.run_partial (); + Cross_alias_use.run_incl (); Shared_signature_arg.run_local_partial (); ignore (Included_sig.M.f ()); ignore (Included_sig.W.X.f ()); diff --git a/examples/regression/src/dune b/examples/regression/src/dune index 5e49766f..26963597 100644 --- a/examples/regression/src/dune +++ b/examples/regression/src/dune @@ -3,6 +3,7 @@ (modules Cross_alias Cross_alias_use + Cross_include Functor_argument Generated_source Included_sig diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index 1c7254b7..4f3a10fd 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -272,6 +272,10 @@ function runRegressionTests() { output, "optional argument x of function Opt_incl_f.+g is always supplied" ); + assertIncludes( + output, + "optional argument x of function Opt_cross_incl.+g is always supplied" + ); // Partial applications: held by a let module, and bound in another file. assertIncludes( output, diff --git a/src/Compat.ml b/src/Compat.ml index 2c84f66f..2c203fa1 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -570,6 +570,11 @@ type identResolutions = { moduleTypeOf : Location.t -> string -> Types.module_type option; (** occurrence location, last name -> the module type a [module type X = ...] declaration denotes *) + bindingOfPath : + Path.t -> + (Location.t * Typedtree.module_expr * identResolutions option * int) option; + (** the binding a module path denotes, structurally, with the resolver + of its unit and the number of functor layers the path applied *) headKey : headVisited -> Typedtree.module_expr -> (Location.t * int) option; (** visited bindings (start with [noHeadVisited]), module expression -> @@ -591,6 +596,7 @@ let emptyIdentResolutions = projModule = (fun _ _ -> None); moduleDefLoc = (fun _ _ -> None); moduleTypeOf = (fun _ _ -> None); + bindingOfPath = (fun _ -> None); headKey = (fun _ _ -> None); expandModuleType = (fun mt -> mt); } @@ -739,7 +745,113 @@ let rec makeResolver ~cmtFilePath let nonGhost (loc : Location.t option) = match loc with Some l when not l.loc_ghost -> loc | _ -> None in - let rec self : identResolutions = { + let selfRef = ref emptyIdentResolutions in + let bindingOfUid = + moduleBindingOfUid ~currentCmtFile:cmtFilePath ~imports ~local + in + (* The resolver of the unit defining [uid]: this one, or that unit's own, + built from its occurrence data. *) + let resolverOfUid (uid : Shape.Uid.t) = + match uid with + | Shape.Uid.Item {comp_unit; _} when comp_unit = thisUnit -> Some !selfRef + | Shape.Uid.Item {comp_unit; _} -> + resolverForUnit ~currentCmtFile:cmtFilePath ~imports comp_unit + | _ -> None + in + (* The binding a module path denotes, structurally: through units, + local bindings, and the bodies of applied functors, as in + [Outer (A).Inner]. Returns the binding, the resolver of its unit, + and the number of functor layers the path applied. *) + let rec bindingOfPath (path : Path.t) : + (Location.t * Typedtree.module_expr * identResolutions option * int) + option = + match path with + | Pident id when Ident.global id -> None + | Pident id -> ( + let uid = + localUid (function + | Typedtree.Module_binding {mb_id = Some mbId} -> + Ident.same mbId id + | _ -> false) + in + match uid with + | Some uid -> ( + match bindingOfUid uid with + | Some (loc, definition) -> Some (loc, definition, Some !selfRef, 0) + | None -> None) + | None -> None) + | Pdot (Pident unit, name) when Ident.global unit -> ( + let shape = + Shape.proj (compUnitShape (Ident.name unit)) + (Shape.Item.make name Module) + in + match Reduce.reduce_for_uid Env.empty shape |> uidOfResult with + | Some uid -> ( + match bindingOfUid uid with + | Some (loc, definition) -> + Some (loc, definition, resolverOfUid uid, 0) + | None -> None) + | None -> None) + | Pdot (parent, name) -> ( + match bindingOfPath parent with + | Some (_, definition, resolver, applied) -> ( + (* Peel the applied functor layers, then find the member, the + last binding of that name (also through [include]s). *) + let rec memberIn (e : Typedtree.module_expr) applied = + match e.mod_desc with + | Tmod_constraint (inner, _, _, _) -> memberIn inner applied + | Tmod_functor (_, inner) when applied > 0 -> + memberIn inner (applied - 1) + | Tmod_apply (functorExpr, _, _) -> + memberIn functorExpr (applied + 1) + | Tmod_ident (p, _) when applied = 0 -> ( + (* [include Helpers] in a body: [Helpers] is local to the + unit defining the body, so its resolver must look it up. *) + let lookup = + match resolver with + | Some (r : identResolutions) -> r.bindingOfPath + | None -> bindingOfPath + in + match lookup (Pdot (p, name)) with + | Some (loc, expr, _, 0) -> Some (loc, expr) + | _ -> None) + | Tmod_structure structure when applied = 0 -> + structure.str_items + |> List.fold_left + (fun acc (item : Typedtree.structure_item) -> + match item.str_desc with + | Tstr_module ({mb_name = {txt = Some n}} as mb) + when n = name -> + Some (mb.mb_name.loc, mb.mb_expr) + | Tstr_recmodule mbs -> ( + match + mbs + |> List.find_opt + (fun (mb : Typedtree.module_binding) -> + mb.mb_name.txt = Some name) + with + | Some mb -> Some (mb.mb_name.loc, mb.mb_expr) + | None -> acc) + | Tstr_include {incl_mod} -> ( + match memberIn incl_mod 0 with + | Some member -> Some member + | None -> acc) + | _ -> acc) + None + | _ -> None + in + match memberIn definition applied with + | Some (loc, expr) -> Some (loc, expr, resolver, 0) + | None -> None) + | None -> None) + | Papply (functorPath, _) -> ( + match bindingOfPath functorPath with + | Some (loc, definition, resolver, applied) -> + Some (loc, definition, resolver, applied + 1) + | None -> None) + | _ -> None + in + let self : identResolutions = { valueImpl = (fun loc name -> match Hashtbl.find_opt values (key loc name) with @@ -779,24 +891,13 @@ let rec makeResolver ~cmtFilePath moduleTypeOfUid ~currentCmtFile:cmtFilePath ~imports ~local uid | None -> None) | None -> None); + bindingOfPath = (fun path -> bindingOfPath path); headKey = - (let bindingOfUid = - moduleBindingOfUid ~currentCmtFile:cmtFilePath ~imports ~local - in - let rec unwrap (e : Typedtree.module_expr) = + (let rec unwrap (e : Typedtree.module_expr) = match e.mod_desc with | Tmod_constraint (inner, _, _, _) -> unwrap inner | _ -> e in - (* The resolver of the unit defining [uid]: this one, or that unit's - own, built from its occurrence data. *) - let resolverOfUid (uid : Shape.Uid.t) = - match uid with - | Shape.Uid.Item {comp_unit; _} when comp_unit = thisUnit -> Some self - | Shape.Uid.Item {comp_unit; _} -> - resolverForUnit ~currentCmtFile:cmtFilePath ~imports comp_unit - | _ -> None - in (* The key of a binding found for a module expression: a functor is keyed by the binding; an alias or a partial application is chased with the resolver of the unit binding it. *) @@ -814,92 +915,6 @@ let rec makeResolver ~cmtFilePath | None -> Some (loc, 0)) | _ -> Some (loc, 0) in - (* The binding a module path denotes, structurally: through units, - local bindings, and the bodies of applied functors, as in - [Outer (A).Inner]. Returns the binding, the resolver of its unit, - and the number of functor layers the path applied. *) - let rec bindingOfPath (path : Path.t) : - (Location.t * Typedtree.module_expr * identResolutions option * int) - option = - match path with - | Pident id when Ident.global id -> None - | Pident id -> ( - let uid = - localUid (function - | Typedtree.Module_binding {mb_id = Some mbId} -> - Ident.same mbId id - | _ -> false) - in - match uid with - | Some uid -> ( - match bindingOfUid uid with - | Some (loc, definition) -> Some (loc, definition, Some self, 0) - | None -> None) - | None -> None) - | Pdot (Pident unit, name) when Ident.global unit -> ( - let shape = - Shape.proj (compUnitShape (Ident.name unit)) - (Shape.Item.make name Module) - in - match Reduce.reduce_for_uid Env.empty shape |> uidOfResult with - | Some uid -> ( - match bindingOfUid uid with - | Some (loc, definition) -> - Some (loc, definition, resolverOfUid uid, 0) - | None -> None) - | None -> None) - | Pdot (parent, name) -> ( - match bindingOfPath parent with - | Some (_, definition, resolver, applied) -> ( - (* Peel the applied functor layers, then find the member, the - last binding of that name (also through [include]s). *) - let rec memberIn (e : Typedtree.module_expr) applied = - match e.mod_desc with - | Tmod_constraint (inner, _, _, _) -> memberIn inner applied - | Tmod_functor (_, inner) when applied > 0 -> - memberIn inner (applied - 1) - | Tmod_apply (functorExpr, _, _) -> - memberIn functorExpr (applied + 1) - | Tmod_ident (p, _) when applied = 0 -> ( - match bindingOfPath (Pdot (p, name)) with - | Some (loc, expr, _, 0) -> Some (loc, expr) - | _ -> None) - | Tmod_structure structure when applied = 0 -> - structure.str_items - |> List.fold_left - (fun acc (item : Typedtree.structure_item) -> - match item.str_desc with - | Tstr_module ({mb_name = {txt = Some n}} as mb) - when n = name -> - Some (mb.mb_name.loc, mb.mb_expr) - | Tstr_recmodule mbs -> ( - match - mbs - |> List.find_opt - (fun (mb : Typedtree.module_binding) -> - mb.mb_name.txt = Some name) - with - | Some mb -> Some (mb.mb_name.loc, mb.mb_expr) - | None -> acc) - | Tstr_include {incl_mod} -> ( - match memberIn incl_mod 0 with - | Some member -> Some member - | None -> acc) - | _ -> acc) - None - | _ -> None - in - match memberIn definition applied with - | Some (loc, expr) -> Some (loc, expr, resolver, 0) - | None -> None) - | None -> None) - | Papply (functorPath, _) -> ( - match bindingOfPath functorPath with - | Some (loc, definition, resolver, applied) -> - Some (loc, definition, resolver, applied + 1) - | None -> None) - | _ -> None - in let rec headKey (visited : headVisited) (e : Typedtree.module_expr) = match e.mod_desc with | Tmod_apply (functorExpr, _, _) -> ( @@ -1013,6 +1028,7 @@ let rec makeResolver ~cmtFilePath in expand []); } in + selfRef := self; self and resolverForUnit ~currentCmtFile ~imports comp_unit = From c90ede4ade909dc1b14db8e3d85e523a13045478 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 18:44:33 +0000 Subject: [PATCH 23/53] Address review: forward aliases in recursive groups Recursive module bindings are all indexed first, then their keys are resolved to a fixed point, so an alias of a later binding in the group takes that binding's functor key. Regression case: Rec_g = Rec_h = Apply_opt. --- examples/regression/src/Main.ml | 3 +- .../regression/src/Shared_signature_arg.ml | 16 ++++++++ scripts/run_integration_tests.js | 4 ++ src/DeadValue.ml | 38 +++++++++++++------ 4 files changed, 48 insertions(+), 13 deletions(-) diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 00e4e825..d759e3c1 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -29,4 +29,5 @@ let () = Shared_signature_arg.run_shadow_rec (); ignore (Included_sig.W2.X.f ()); ignore (Included_sig.W3.X.f ()); - Shared_signature_arg.run_incl_f () + Shared_signature_arg.run_incl_f (); + Shared_signature_arg.run_rec_chain () diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml index 220259df..100e9e27 100644 --- a/examples/regression/src/Shared_signature_arg.ml +++ b/examples/regression/src/Shared_signature_arg.ml @@ -451,3 +451,19 @@ module Applied_outer_i = Outer_i (Chosen) module Applied_incl_f = Applied_outer_i.Inner (Opt_incl_f) let run_incl_f () = ignore (Applied_incl_f.run ()) + +(* A forward alias inside a recursive group. *) +module Opt_rec_chain : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module type Opt_functor = functor (M : Shared_signature.O) -> sig + val run : unit -> int +end + +module rec Rec_g : Opt_functor = Rec_h +and Rec_h : Opt_functor = Apply_opt + +module Applied_rec_chain = Rec_g (Opt_rec_chain) + +let run_rec_chain () = ignore (Applied_rec_chain.run ()) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index 4f3a10fd..3890f67f 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -276,6 +276,10 @@ function runRegressionTests() { output, "optional argument x of function Opt_cross_incl.+g is always supplied" ); + assertIncludes( + output, + "optional argument x of function Opt_rec_chain.+g is always supplied" + ); // Partial applications: held by a let module, and bound in another file. assertIncludes( output, diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 609c82f9..6599ab5c 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -998,18 +998,32 @@ let traverseStructure ~doTypes ~doExternals = registerParameterAlias mb.mb_id mb.mb_expr; match mb.mb_id with | Some id -> - (* [module rec G : T = F], or a partial application: G stands - for F's key. *) - let key = - match (moduleIdent mb.mb_expr, mb.mb_expr.mod_desc) with - | None, Tmod_functor _ -> (mb.mb_name.loc.loc_start, 0) - | _ -> ( - match functorKeyOfHead mb.mb_expr with - | Some key -> key - | None -> (mb.mb_name.loc.loc_start, 0)) - in - functorsByIdent := (id, key) :: !functorsByIdent - | None -> ()) + functorsByIdent := + (id, (mb.mb_name.loc.loc_start, 0)) :: !functorsByIdent + | None -> ()); + (* [module rec G : T = H and H : T = F]: an alias or partial + application stands for the functor's key; a forward alias resolves + once the later binding has, so iterate to a fixed point. *) + let resolveKeys () = + moduleBindings + |> List.fold_left + (fun changed (mb : Typedtree.module_binding) -> + match (mb.mb_id, moduleIdent mb.mb_expr, mb.mb_expr.mod_desc) with + | Some id, _, Tmod_apply _ | Some id, Some _, _ -> ( + match functorKeyOfHead mb.mb_expr with + | Some key when List.assq_opt id !functorsByIdent <> Some key -> + functorsByIdent := + (id, key) + :: List.filter + (fun (id', _) -> not (Ident.same id id')) + !functorsByIdent; + true + | _ -> changed) + | _ -> changed) + false + in + let rec fixpoint n = if n > 0 && resolveKeys () then fixpoint (n - 1) in + fixpoint (List.length moduleBindings) | Tstr_primitive vd when doExternals && !Config.analyzeExternals -> let currentModulePath = ModulePath.getCurrent () in let path = currentModulePath.path @ [!Common.currentModuleName] in From 53aa9675f4cd506dbe3a4a9bbe1f6d126714f82c Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 18:53:12 +0000 Subject: [PATCH 24/53] Address review: keep the resolver of an included member A member found through an included module keeps the resolver returned for it, so an alias or partial application local to that module's unit is chased there rather than in the enclosing unit. Regression case: Cross_alias.Outer_y including Cross_include.Helpers2, whose Inner2 aliases a local binding of Cross_c.F. --- examples/regression/src/Cross_alias.ml | 5 +++++ examples/regression/src/Cross_alias_use.ml | 9 +++++++++ examples/regression/src/Cross_c.ml | 5 +++++ examples/regression/src/Cross_include.ml | 6 ++++++ examples/regression/src/Main.ml | 1 + examples/regression/src/dune | 1 + scripts/run_integration_tests.js | 4 ++++ src/Compat.ml | 11 +++++++---- 8 files changed, 38 insertions(+), 4 deletions(-) create mode 100644 examples/regression/src/Cross_c.ml diff --git a/examples/regression/src/Cross_alias.ml b/examples/regression/src/Cross_alias.ml index 56d0910b..3787be38 100644 --- a/examples/regression/src/Cross_alias.ml +++ b/examples/regression/src/Cross_alias.ml @@ -3,3 +3,8 @@ module G = Shared_signature_arg.Apply_opt (* A partial application bound in this file, completed from another. *) module GP = Shared_signature_arg.Apply2 (Shared_signature_arg.Chosen) + +module Outer_y (X : Shared_signature.S) = struct + let _ = X.f + include Cross_include.Helpers2 +end diff --git a/examples/regression/src/Cross_alias_use.ml b/examples/regression/src/Cross_alias_use.ml index e694b708..de2eba01 100644 --- a/examples/regression/src/Cross_alias_use.ml +++ b/examples/regression/src/Cross_alias_use.ml @@ -22,3 +22,12 @@ module Applied_outer_x = Cross_include.Outer_x (Shared_signature_arg.Chosen) module Applied_cross_incl = Applied_outer_x.Inner (Opt_cross_incl) let run_incl () = ignore (Applied_cross_incl.run ()) + +module Opt_y : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Applied_outer_y = Cross_alias.Outer_y (Shared_signature_arg.Chosen) +module Applied_y = Applied_outer_y.Inner2 (Opt_y) + +let run_y () = ignore (Applied_y.run ()) diff --git a/examples/regression/src/Cross_c.ml b/examples/regression/src/Cross_c.ml new file mode 100644 index 00000000..3ac16bc1 --- /dev/null +++ b/examples/regression/src/Cross_c.ml @@ -0,0 +1,5 @@ +(* A functor defined in a third unit, reached through an alias in a second + unit's included module, from a first unit's functor result. *) +module F (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end diff --git a/examples/regression/src/Cross_include.ml b/examples/regression/src/Cross_include.ml index 5955e8d4..08386c9b 100644 --- a/examples/regression/src/Cross_include.ml +++ b/examples/regression/src/Cross_include.ml @@ -10,3 +10,9 @@ module Outer_x (A : Shared_signature.S) = struct let _ = A.f include Helpers end + +module Local_f = Cross_c.F + +module Helpers2 = struct + module Inner2 = Local_f +end diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index d759e3c1..08559bd4 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -21,6 +21,7 @@ let () = Cross_alias_use.run (); Cross_alias_use.run_partial (); Cross_alias_use.run_incl (); + Cross_alias_use.run_y (); Shared_signature_arg.run_local_partial (); ignore (Included_sig.M.f ()); ignore (Included_sig.W.X.f ()); diff --git a/examples/regression/src/dune b/examples/regression/src/dune index 26963597..ad0ff049 100644 --- a/examples/regression/src/dune +++ b/examples/regression/src/dune @@ -3,6 +3,7 @@ (modules Cross_alias Cross_alias_use + Cross_c Cross_include Functor_argument Generated_source diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index 3890f67f..e30a33b9 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -280,6 +280,10 @@ function runRegressionTests() { output, "optional argument x of function Opt_rec_chain.+g is always supplied" ); + assertIncludes( + output, + "optional argument x of function Opt_y.+g is always supplied" + ); // Partial applications: held by a let module, and bound in another file. assertIncludes( output, diff --git a/src/Compat.ml b/src/Compat.ml index 2c203fa1..be32f486 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -813,7 +813,8 @@ let rec makeResolver ~cmtFilePath | None -> bindingOfPath in match lookup (Pdot (p, name)) with - | Some (loc, expr, _, 0) -> Some (loc, expr) + | Some (loc, expr, memberResolver, 0) -> + Some (loc, expr, memberResolver) | _ -> None) | Tmod_structure structure when applied = 0 -> structure.str_items @@ -822,7 +823,7 @@ let rec makeResolver ~cmtFilePath match item.str_desc with | Tstr_module ({mb_name = {txt = Some n}} as mb) when n = name -> - Some (mb.mb_name.loc, mb.mb_expr) + Some (mb.mb_name.loc, mb.mb_expr, resolver) | Tstr_recmodule mbs -> ( match mbs @@ -830,7 +831,8 @@ let rec makeResolver ~cmtFilePath (fun (mb : Typedtree.module_binding) -> mb.mb_name.txt = Some name) with - | Some mb -> Some (mb.mb_name.loc, mb.mb_expr) + | Some mb -> + Some (mb.mb_name.loc, mb.mb_expr, resolver) | None -> acc) | Tstr_include {incl_mod} -> ( match memberIn incl_mod 0 with @@ -841,7 +843,8 @@ let rec makeResolver ~cmtFilePath | _ -> None in match memberIn definition applied with - | Some (loc, expr) -> Some (loc, expr, resolver, 0) + | Some (loc, expr, memberResolver) -> + Some (loc, expr, memberResolver, 0) | None -> None) | None -> None) | Papply (functorPath, _) -> ( From 2a3e486b4afa7390d54bb1be708f58d8ad23a7d9 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 19:00:10 +0000 Subject: [PATCH 25/53] Address review: module types rooted at functor applications The shape of a path Outer (A) is the application of the two shapes, so a module type Outer (A).S is now expanded like any other. Regression case: S_app = Outer_mt (Chosen).SM. --- examples/regression/src/Main.ml | 3 ++- .../regression/src/Shared_signature_arg.ml | 27 +++++++++++++++++++ scripts/run_integration_tests.js | 3 +++ src/Compat.ml | 8 ++++++ 4 files changed, 40 insertions(+), 1 deletion(-) diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 08559bd4..cc4ac660 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -31,4 +31,5 @@ let () = ignore (Included_sig.W2.X.f ()); ignore (Included_sig.W3.X.f ()); Shared_signature_arg.run_incl_f (); - Shared_signature_arg.run_rec_chain () + Shared_signature_arg.run_rec_chain (); + Shared_signature_arg.run_mt () diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml index 100e9e27..5940205e 100644 --- a/examples/regression/src/Shared_signature_arg.ml +++ b/examples/regression/src/Shared_signature_arg.ml @@ -467,3 +467,30 @@ and Rec_h : Opt_functor = Apply_opt module Applied_rec_chain = Rec_g (Opt_rec_chain) let run_rec_chain () = ignore (Applied_rec_chain.run ()) + +(* A module type rooted at a functor application: [Outer_mt (Chosen).SM]. *) +module Outer_mt (A : Shared_signature.S) = struct + let _ = A.f + + module type SM = sig + val f : unit -> int + end +end + +module type S_app = Outer_mt(Chosen).SM + +module Apply_mt (M : S_app) = struct + let run () = M.f () +end + +module Used_mt : S_app = struct + let f () = 30 +end + +module Unused_mt : S_app = struct + let f () = 31 +end + +module Applied_mt = Apply_mt ((Used_mt : S_app)) + +let run_mt () = ignore (Applied_mt.run ()) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index e30a33b9..10da4c1c 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -284,6 +284,9 @@ function runRegressionTests() { output, "optional argument x of function Opt_y.+g is always supplied" ); + // A module type rooted at a functor application. + assertIncludes(output, "Live Value +Shared_signature_arg.Used_mt.+f"); + assertIncludes(output, "Dead Value +Shared_signature_arg.Unused_mt.+f"); // Partial applications: held by a let module, and bound in another file. assertIncludes( output, diff --git a/src/Compat.ml b/src/Compat.ml index be32f486..924d2cec 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -974,6 +974,14 @@ let rec makeResolver ~cmtFilePath match moduleShapeOfPath p with | Some shape -> Some (Shape.proj shape (Shape.Item.make name Module)) | None -> None) + | Papply (functorPath, argumentPath) -> ( + (* [Outer (A).S]: the application's shape, reduced on projection. *) + match + (moduleShapeOfPath functorPath, moduleShapeOfPath argumentPath) + with + | Some functorShape, Some argumentShape -> + Some (Shape.app functorShape ~arg:argumentShape) + | _ -> None) | _ -> None in let moduleTypeOfUid = moduleTypeOfUid ~currentCmtFile:cmtFilePath ~imports ~local in From 120f50f0e03dfed0653b4b5972c2b02f5f1f7e99 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 19:10:24 +0000 Subject: [PATCH 26/53] Address review: module types rooted at functor parameters and applications The whole family of module type paths inside functor bodies: - Outer (M).S, whatever the argument: the module type is found in Outer's body structurally. - M.T and M.Sub.T2 with M a parameter: found in the parameter's declared module type, which the functor declaration carries. - Through a parameter alias (module N = M; N.T) and through include of the parameter (include M; T). - When an argument's signature cannot be expanded at all, the values its shape exports are referenced, precise to that argument, rather than nothing. Regression cases: Apply_pt, Apply_app, Apply_pt2. --- examples/regression/src/Main.ml | 4 +- .../regression/src/Shared_signature_arg.ml | 125 ++++++++++++++++++ scripts/run_integration_tests.js | 15 +++ src/Compat.ml | 67 +++++++++- src/DeadValue.ml | 75 ++++++++++- 5 files changed, 273 insertions(+), 13 deletions(-) diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index cc4ac660..1e14c191 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -32,4 +32,6 @@ let () = ignore (Included_sig.W3.X.f ()); Shared_signature_arg.run_incl_f (); Shared_signature_arg.run_rec_chain (); - Shared_signature_arg.run_mt () + Shared_signature_arg.run_mt (); + Shared_signature_arg.run_param_mt (); + Shared_signature_arg.run_param_mt2 () diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml index 5940205e..f3f590fc 100644 --- a/examples/regression/src/Shared_signature_arg.ml +++ b/examples/regression/src/Shared_signature_arg.ml @@ -494,3 +494,128 @@ end module Applied_mt = Apply_mt ((Used_mt : S_app)) let run_mt () = ignore (Applied_mt.run ()) + +(* Module types rooted at a functor parameter: [M.T], [M.Sub.T], and + [Outer_mt (M).SM] with [M] the parameter. *) +module type Has_t = sig + module type T = sig + val f : unit -> int + end + + module Sub : sig + module type T2 = sig + val h : unit -> int + end + end +end + +module Apply_pt (M : Has_t) = struct + module type T_alias = M.T + module type T2_alias = M.Sub.T2 + + module Use_p : T_alias = struct + let f () = 40 + end + + module Unused_p : T_alias = struct + let f () = 41 + end + + module Use_p2 : T2_alias = struct + let h () = 42 + end + + module Apply_t (X : T_alias) = struct + let run () = X.f () + end + + module Apply_t2 (X : T2_alias) = struct + let run () = X.h () + end + + module Applied_t = Apply_t ((Use_p : T_alias)) + module Applied_t2 = Apply_t2 ((Use_p2 : T2_alias)) + + let run () = Applied_t.run () + Applied_t2.run () +end + +module Applied_pt = Apply_pt (struct + module type T = sig + val f : unit -> int + end + + module Sub = struct + module type T2 = sig + val h : unit -> int + end + end +end) + +module Apply_app (M : Shared_signature.S) = struct + module type T_app = Outer_mt(M).SM + + module Use_a : T_app = struct + let f () = 43 + end + + module Unused_a : T_app = struct + let f () = 44 + end + + module Apply_a (X : T_app) = struct + let run () = X.f () + end + + module Applied_a = Apply_a ((Use_a : T_app)) + + let run () = Applied_a.run () +end + +module Applied_app = Apply_app (Chosen) + +let run_param_mt () = ignore (Applied_pt.run () + Applied_app.run ()) + +(* Module types through a parameter alias and through [include] of the + parameter. *) +module Apply_pt2 (M : Has_t) = struct + module N = M + module type T_via_alias = N.T + + include M + module type T_via_include = T + + module Use_alias_mt : T_via_alias = struct + let f () = 45 + end + + module Use_include_mt : T_via_include = struct + let f () = 46 + end + + module Apply_ta (X : T_via_alias) = struct + let run () = X.f () + end + + module Apply_ti (X : T_via_include) = struct + let run () = X.f () + end + + module Applied_ta = Apply_ta ((Use_alias_mt : T_via_alias)) + module Applied_ti = Apply_ti ((Use_include_mt : T_via_include)) + + let run () = Applied_ta.run () + Applied_ti.run () +end + +module Applied_pt2 = Apply_pt2 (struct + module type T = sig + val f : unit -> int + end + + module Sub = struct + module type T2 = sig + val h : unit -> int + end + end +end) + +let run_param_mt2 () = ignore (Applied_pt2.run ()) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index 10da4c1c..bc43828e 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -287,6 +287,21 @@ function runRegressionTests() { // A module type rooted at a functor application. assertIncludes(output, "Live Value +Shared_signature_arg.Used_mt.+f"); assertIncludes(output, "Dead Value +Shared_signature_arg.Unused_mt.+f"); + // Module types rooted at a functor parameter: M.T, M.Sub.T2, + // Outer (M).SM, through a parameter alias, and through include. + assertIncludes(output, "Live Value +Shared_signature_arg.Apply_pt.Use_p.+f"); + assertIncludes(output, "Dead Value +Shared_signature_arg.Apply_pt.Unused_p.+f"); + assertIncludes(output, "Live Value +Shared_signature_arg.Apply_pt.Use_p2.+h"); + assertIncludes(output, "Live Value +Shared_signature_arg.Apply_app.Use_a.+f"); + assertIncludes(output, "Dead Value +Shared_signature_arg.Apply_app.Unused_a.+f"); + assertIncludes( + output, + "Live Value +Shared_signature_arg.Apply_pt2.Use_alias_mt.+f" + ); + assertIncludes( + output, + "Live Value +Shared_signature_arg.Apply_pt2.Use_include_mt.+f" + ); // Partial applications: held by a let module, and bound in another file. assertIncludes( output, diff --git a/src/Compat.ml b/src/Compat.ml index 924d2cec..c559154e 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -570,6 +570,9 @@ type identResolutions = { moduleTypeOf : Location.t -> string -> Types.module_type option; (** occurrence location, last name -> the module type a [module type X = ...] declaration denotes *) + shapeValueItems : moduleShape -> (string * Location.t) list; + (** the values a module shape exports, with their implementations; a + fallback when the module's signature cannot be expanded *) bindingOfPath : Path.t -> (Location.t * Typedtree.module_expr * identResolutions option * int) option; @@ -596,6 +599,7 @@ let emptyIdentResolutions = projModule = (fun _ _ -> None); moduleDefLoc = (fun _ _ -> None); moduleTypeOf = (fun _ _ -> None); + shapeValueItems = (fun _ -> []); bindingOfPath = (fun _ -> None); headKey = (fun _ _ -> None); expandModuleType = (fun mt -> mt); @@ -745,6 +749,12 @@ let rec makeResolver ~cmtFilePath let nonGhost (loc : Location.t option) = match loc with Some l when not l.loc_ghost -> loc | _ -> None in + let projValueLoc shape name = + let item = Shape.proj shape (Shape.Item.make name Value) in + match Reduce.reduce_for_uid Env.empty item |> uidOfResult with + | Some uid -> locOfUid uid |> nonGhost + | None -> None + in let selfRef = ref emptyIdentResolutions in let bindingOfUid = moduleBindingOfUid ~currentCmtFile:cmtFilePath ~imports ~local @@ -865,12 +875,7 @@ let rec makeResolver ~cmtFilePath match Hashtbl.find_opt modules (key loc name) with | Some s -> s | None -> None); - projValue = - (fun shape name -> - let item = Shape.proj shape (Shape.Item.make name Value) in - match Reduce.reduce_for_uid Env.empty item |> uidOfResult with - | Some uid -> locOfUid uid |> nonGhost - | None -> None); + projValue = projValueLoc; projModule = (fun shape name -> Some (Shape.proj shape (Shape.Item.make name Module))); @@ -894,6 +899,20 @@ let rec makeResolver ~cmtFilePath moduleTypeOfUid ~currentCmtFile:cmtFilePath ~imports ~local uid | None -> None) | None -> None); + shapeValueItems = + (fun shape -> + match (Reduce.reduce Env.empty shape).desc with + | Struct items -> + Shape.Item.Map.fold + (fun (name, kind) _ acc -> + match kind with + | Shape.Sig_component_kind.Value -> ( + match projValueLoc shape name with + | Some loc -> (name, loc) :: acc + | None -> acc) + | _ -> acc) + items [] + | _ -> []); bindingOfPath = (fun path -> bindingOfPath path); headKey = (let rec unwrap (e : Typedtree.module_expr) = @@ -985,8 +1004,44 @@ let rec makeResolver ~cmtFilePath | _ -> None in let moduleTypeOfUid = moduleTypeOfUid ~currentCmtFile:cmtFilePath ~imports ~local in + let rec hasApply (path : Path.t) = + match path with + | Papply _ -> true + | Pdot (p, _) -> hasApply p + | _ -> false + in + (* [module type S] in the body of a functor the path applies, as in + [Outer (A).S]: found structurally, whatever the argument. *) + let rec moduleTypeInBody (e : Typedtree.module_expr) applied name = + match e.mod_desc with + | Tmod_constraint (inner, _, _, _) -> moduleTypeInBody inner applied name + | Tmod_functor (_, inner) when applied > 0 -> + moduleTypeInBody inner (applied - 1) name + | Tmod_apply (functorExpr, _, _) -> + moduleTypeInBody functorExpr (applied + 1) name + | Tmod_structure structure when applied = 0 -> + structure.str_items + |> List.fold_left + (fun acc (item : Typedtree.structure_item) -> + match item.str_desc with + | Tstr_modtype {mtd_name; mtd_type = Some {mty_type}} + when mtd_name.txt = name -> + Some mty_type + | Tstr_include {incl_mod} -> ( + match moduleTypeInBody incl_mod 0 name with + | Some mt -> Some mt + | None -> acc) + | _ -> acc) + None + | _ -> None + in let moduleTypeOfPath (path : Path.t) = match path with + | Pdot (p, name) when hasApply p -> ( + match bindingOfPath p with + | Some (_, definition, _, applied) -> + moduleTypeInBody definition applied name + | None -> None) | Pdot (p, name) -> ( match moduleShapeOfPath p with | Some shape -> ( diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 6599ab5c..19835249 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -103,6 +103,9 @@ type functorParameter = { prefix : string list; (** for an alias of (a submodule of) a parameter, [module N = M.Sub], the path from the parameter: ["Sub"] *) + paramType : Types.module_type option; + (** the parameter's declared module type, for module types rooted at + the parameter ([module type T = M.T]) *) } let functorParameters : functorParameter list ref = ref [] @@ -601,12 +604,49 @@ let findSignatureItem name signature = (* The value items a module coercion uses, with the path of submodules leading to each. *) +(* Module type expansion, also for module types rooted at a functor + parameter in scope ([module type T = M.T], [M.Sub.T2]): those are found in + the parameter's declared module type. *) +let rec expandModuleType ?(fuel = 16) (moduleType : Types.module_type) = + let expanded = !identResolutions.expandModuleType moduleType in + match expanded with + | Mty_ident path when fuel > 0 -> ( + match moduleTypeViaParameter ~fuel path with + | Some moduleType -> expandModuleType ~fuel:(fuel - 1) moduleType + | None -> expanded) + | _ -> expanded + +and moduleTypeViaParameter ~fuel (path : Path.t) = + match (findFunctorParameter path, pathComponents path) with + | Some {paramType = Some paramType; prefix}, Some components -> ( + let rec walk (moduleType : Types.module_type) components = + let signature = moduleType |> expandModuleType ~fuel:(fuel - 1) |> getSignature in + match components with + | [] -> None + | [name] -> ( + match signature |> findSignatureItem name with + | Some (Types.Sig_modtype _ as item) -> ( + match item |> Compat.getSigModuleModtype with + | Some (_, moduleType, _) -> Some moduleType + | None -> None) + | _ -> None) + | m :: rest -> ( + match signature |> findSignatureItem m with + | Some (Types.Sig_module _ as item) -> ( + match item |> Compat.getSigModuleModtype with + | Some (_, moduleType, _) -> walk moduleType rest + | None -> None) + | _ -> None) + in + walk paramType (prefix @ components)) + | _ -> None + (* Signature of a module type, with aliases of named module types expanded ([module N : Other.O] inside a signature is [Mty_ident] in the typed tree, which exposes no items). Only runtime modules ([Sig_module]) are walked: a [Sig_modtype] declaration has no fields. *) let expandedSignature (moduleType : Types.module_type) = - moduleType |> !identResolutions.expandModuleType |> getSignature + moduleType |> expandModuleType |> getSignature let rec iterAllModuleValues ~path (moduleType : Types.module_type) f = moduleType |> expandedSignature @@ -652,6 +692,15 @@ let rec iterCoercedValues ~path ~coercion ~actualType f = known, is the argument module's shape: items are then redirected to their implementation rather than to a shared module type item. *) let addCoercedModuleValueReferences ~locFrom ~coercion ?shape ~actualType () = + (match (expandedSignature actualType, shape) with + | [], Some shape -> + (* The argument's signature could not be expanded (a module type this + analysis cannot resolve): reference the values its shape exports + instead, which is precise to this argument. *) + !identResolutions.shapeValueItems shape + |> List.iter (fun (_, locTo) -> + addValueReference ~addFileReference:true ~locFrom ~locTo) + | _ -> ()); iterCoercedValues ~path:[] ~coercion ~actualType (fun ~path signatureItem -> let id, locTo, _kind, _valType = signatureItem |> Compat.getSigValue in if not locTo.loc_ghost then @@ -757,7 +806,7 @@ let rec processSignatureItem ~doTypes ~doValues ~moduleLoc ~path module type [(M : Other.S)] expanded to that module type's signature: the typed tree leaves it as [Mty_ident], which exposes no items. *) let rec argumentModuleType (argumentExpr : Typedtree.module_expr) = - let expand = !identResolutions.expandModuleType in + let expand moduleType = expandModuleType moduleType in match (argumentExpr.mod_desc, argumentExpr.mod_type) with | ( Tmod_constraint (_, _, Tmodtype_explicit {mty_desc = Tmty_ident (path, lid)}, _), @@ -890,14 +939,26 @@ let traverseStructure ~doTypes ~doExternals = |> List.length in (match param with - | Named (Some id, _, _) -> + | Named (Some id, _, mty) -> functorParameters := - {paramId = id; functorDef; paramIndex; prefix = []} + { + paramId = id; + functorDef; + paramIndex; + prefix = []; + paramType = Some mty.mty_type; + } :: !functorParameters | _ -> (* Unnamed or unit parameter: still occupies an index. *) functorParameters := - {paramId = Ident.create_local "_"; functorDef; paramIndex; prefix = []} + { + paramId = Ident.create_local "_"; + functorDef; + paramIndex; + prefix = []; + paramType = None; + } :: !functorParameters) | _ -> ()); (match moduleExpr.mod_desc with @@ -1067,7 +1128,9 @@ let traverseStructure ~doTypes ~doExternals = prefix = p.prefix @ components @ [Ident.name id]; } :: !functorParameters - | Sig_module _ -> ( + | Sig_module _ | Sig_modtype _ -> ( + (* Included modules, and module types ([module type T = + T] after [include M]), stand for the parameter's. *) match item |> Compat.getSigModuleModtype with | Some (id, _, _) -> functorParameters := From fcec04e60b71fc484f4999b17c67b07fec183871 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 19:19:39 +0000 Subject: [PATCH 27/53] Address review: aliased result members, parameter alias cycles, full source paths - A module type through an aliased or applied member of an applied functor's result (Outer (A).Alias.T, Outer (A).Applied.T) is followed in the unit defining the body. - Parameter-rooted module type expansion tracks visited paths instead of a fuel counter. - The signature declaration filter compares normalized full source paths (extensions and .pp dropped, path suffixes tolerated) rather than basenames, so same-named sources of different build targets are not confused. Regression cases: U_alias, U_applied. --- examples/regression/src/Main.ml | 3 +- .../regression/src/Shared_signature_arg.ml | 46 +++++++++++++++++++ scripts/run_integration_tests.js | 4 ++ src/Compat.ml | 37 +++++++++++---- src/DeadValue.ml | 44 ++++++++++++------ 5 files changed, 110 insertions(+), 24 deletions(-) diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 1e14c191..36e9ad83 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -34,4 +34,5 @@ let () = Shared_signature_arg.run_rec_chain (); Shared_signature_arg.run_mt (); Shared_signature_arg.run_param_mt (); - Shared_signature_arg.run_param_mt2 () + Shared_signature_arg.run_param_mt2 (); + Shared_signature_arg.run_u () diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml index f3f590fc..f36aebd9 100644 --- a/examples/regression/src/Shared_signature_arg.ml +++ b/examples/regression/src/Shared_signature_arg.ml @@ -619,3 +619,49 @@ module Applied_pt2 = Apply_pt2 (struct end) let run_param_mt2 () = ignore (Applied_pt2.run ()) + +(* Module types through an aliased or applied member of an applied functor's + result: [Outer_h (Chosen).Alias.T] and [Outer_h (Chosen).Applied_inner.T]. *) +module Outer_h (A : Shared_signature.S) = struct + let _ = A.f + + module Holder = struct + module type T = sig + val f : unit -> int + end + end + + module Alias = Holder + + module Inner_f (X : Shared_signature.S) = struct + module type T = sig + val k : unit -> int + end + end + + module Applied_inner = Inner_f (A) +end + +module type U_alias = Outer_h(Chosen).Alias.T +module type U_applied = Outer_h(Chosen).Applied_inner.T + +module Use_u : U_alias = struct + let f () = 47 +end + +module Use_u2 : U_applied = struct + let k () = 48 +end + +module Apply_u (X : U_alias) = struct + let run () = X.f () +end + +module Apply_u2 (X : U_applied) = struct + let run () = X.k () +end + +module Applied_u = Apply_u ((Use_u : U_alias)) +module Applied_u2 = Apply_u2 ((Use_u2 : U_applied)) + +let run_u () = ignore (Applied_u.run () + Applied_u2.run ()) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index bc43828e..e183a4ff 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -302,6 +302,10 @@ function runRegressionTests() { output, "Live Value +Shared_signature_arg.Apply_pt2.Use_include_mt.+f" ); + // Module types through an aliased or applied member of an applied + // functor's result. + assertIncludes(output, "Live Value +Shared_signature_arg.Use_u.+f"); + assertIncludes(output, "Live Value +Shared_signature_arg.Use_u2.+k"); // Partial applications: held by a let module, and bound in another file. assertIncludes( output, diff --git a/src/Compat.ml b/src/Compat.ml index c559154e..be4644fc 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -570,6 +570,8 @@ type identResolutions = { moduleTypeOf : Location.t -> string -> Types.module_type option; (** occurrence location, last name -> the module type a [module type X = ...] declaration denotes *) + moduleTypeOfPath : Path.t -> Types.module_type option; + (** the module type a path denotes, in this unit's scope *) shapeValueItems : moduleShape -> (string * Location.t) list; (** the values a module shape exports, with their implementations; a fallback when the module's signature cannot be expanded *) @@ -599,6 +601,7 @@ let emptyIdentResolutions = projModule = (fun _ _ -> None); moduleDefLoc = (fun _ _ -> None); moduleTypeOf = (fun _ _ -> None); + moduleTypeOfPath = (fun _ -> None); shapeValueItems = (fun _ -> []); bindingOfPath = (fun _ -> None); headKey = (fun _ _ -> None); @@ -756,6 +759,7 @@ let rec makeResolver ~cmtFilePath | None -> None in let selfRef = ref emptyIdentResolutions in + let moduleTypeOfPathRef = ref (fun (_ : Path.t) -> (None : Types.module_type option)) in let bindingOfUid = moduleBindingOfUid ~currentCmtFile:cmtFilePath ~imports ~local in @@ -899,6 +903,7 @@ let rec makeResolver ~cmtFilePath moduleTypeOfUid ~currentCmtFile:cmtFilePath ~imports ~local uid | None -> None) | None -> None); + moduleTypeOfPath = (fun path -> !moduleTypeOfPathRef path); shapeValueItems = (fun shape -> match (Reduce.reduce Env.empty shape).desc with @@ -1012,13 +1017,27 @@ let rec makeResolver ~cmtFilePath in (* [module type S] in the body of a functor the path applies, as in [Outer (A).S]: found structurally, whatever the argument. *) - let rec moduleTypeInBody (e : Typedtree.module_expr) applied name = + let rec moduleTypeInBody ~resolver (e : Typedtree.module_expr) applied + name = match e.mod_desc with - | Tmod_constraint (inner, _, _, _) -> moduleTypeInBody inner applied name + | Tmod_constraint (inner, _, _, _) -> + moduleTypeInBody ~resolver inner applied name | Tmod_functor (_, inner) when applied > 0 -> - moduleTypeInBody inner (applied - 1) name + moduleTypeInBody ~resolver inner (applied - 1) name | Tmod_apply (functorExpr, _, _) -> - moduleTypeInBody functorExpr (applied + 1) name + moduleTypeInBody ~resolver functorExpr (applied + 1) name + | Tmod_ident (p, _) -> ( + (* An aliased member ([module Alias = Holder]) or an applied one: + follow it in the unit defining the body. *) + let r : identResolutions = + match resolver with Some r -> r | None -> !selfRef + in + if applied = 0 then r.moduleTypeOfPath (Pdot (p, name)) + else + match r.bindingOfPath p with + | Some (_, definition, resolver, applied') -> + moduleTypeInBody ~resolver definition (applied + applied') name + | None -> None) | Tmod_structure structure when applied = 0 -> structure.str_items |> List.fold_left @@ -1028,19 +1047,18 @@ let rec makeResolver ~cmtFilePath when mtd_name.txt = name -> Some mty_type | Tstr_include {incl_mod} -> ( - match moduleTypeInBody incl_mod 0 name with + match moduleTypeInBody ~resolver incl_mod 0 name with | Some mt -> Some mt | None -> acc) | _ -> acc) None | _ -> None - in - let moduleTypeOfPath (path : Path.t) = + and moduleTypeOfPath (path : Path.t) = match path with | Pdot (p, name) when hasApply p -> ( match bindingOfPath p with - | Some (_, definition, _, applied) -> - moduleTypeInBody definition applied name + | Some (_, definition, resolver, applied) -> + moduleTypeInBody ~resolver definition applied name | None -> None) | Pdot (p, name) -> ( match moduleShapeOfPath p with @@ -1080,6 +1098,7 @@ let rec makeResolver ~cmtFilePath in (* Aliases are followed until a signature is reached; the visited paths break cycles. *) + moduleTypeOfPathRef := moduleTypeOfPath; let rec expand visited (moduleType : Types.module_type) = match moduleType with | Mty_ident path when not (List.exists (Path.same path) visited) -> ( diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 19835249..dd7ecc00 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -607,20 +607,21 @@ let findSignatureItem name signature = (* Module type expansion, also for module types rooted at a functor parameter in scope ([module type T = M.T], [M.Sub.T2]): those are found in the parameter's declared module type. *) -let rec expandModuleType ?(fuel = 16) (moduleType : Types.module_type) = +let rec expandModuleType ?(visited = []) (moduleType : Types.module_type) = let expanded = !identResolutions.expandModuleType moduleType in match expanded with - | Mty_ident path when fuel > 0 -> ( - match moduleTypeViaParameter ~fuel path with - | Some moduleType -> expandModuleType ~fuel:(fuel - 1) moduleType + | Mty_ident path when not (List.exists (Path.same path) visited) -> ( + let visited = path :: visited in + match moduleTypeViaParameter ~visited path with + | Some moduleType -> expandModuleType ~visited moduleType | None -> expanded) | _ -> expanded -and moduleTypeViaParameter ~fuel (path : Path.t) = +and moduleTypeViaParameter ~visited (path : Path.t) = match (findFunctorParameter path, pathComponents path) with | Some {paramType = Some paramType; prefix}, Some components -> ( let rec walk (moduleType : Types.module_type) components = - let signature = moduleType |> expandModuleType ~fuel:(fuel - 1) |> getSignature in + let signature = moduleType |> expandModuleType ~visited |> getSignature in match components with | [] -> None | [name] -> ( @@ -746,17 +747,32 @@ let isSignatureValueDeclaration = ref (fun (_ : Location.t) -> true) let setSignatureValueFilter ~(fileName : string) ~(moduleTypeRanges : Location.t list) = - (* By module name: a preprocessed source is recorded as [foo.pp.ml] while - its positions say [foo.ml]. *) - let moduleName path = - match String.index_opt (Filename.basename path) '.' with - | Some i -> String.sub (Filename.basename path) 0 i - | None -> Filename.basename path + (* Full paths, without extensions (a preprocessed source is recorded as + [foo.pp.ml] while its positions say [foo.ml]); one may be relative to + the other's root, so a path suffix also matches. Basenames alone would + confuse same-named sources of different build targets. *) + let normalize path = + let dir = Filename.dirname path in + let base = + match String.index_opt (Filename.basename path) '.' with + | Some i -> String.sub (Filename.basename path) 0 i + | None -> Filename.basename path + in + if dir = "." then base else dir ^ "/" ^ base + in + let endsWith ~suffix s = + let ls = String.length s and lsuf = String.length suffix in + ls >= lsuf && String.sub s (ls - lsuf) lsuf = suffix in - let name = moduleName fileName in + let self = normalize fileName in isSignatureValueDeclaration := fun (loc : Location.t) -> - let sameFile = moduleName loc.loc_start.pos_fname = name in + let other = normalize loc.loc_start.pos_fname in + let sameFile = + other = self + || endsWith ~suffix:("/" ^ other) self + || endsWith ~suffix:("/" ^ self) other + in if (not sameFile) && !Common.Cli.debug then Log_.item "signatureValueSkipped %s (file %s)@." (loc.loc_start |> posToString) From 89275b02ec97e3f03ca68cf64bff0580b3efb1e6 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 19:27:09 +0000 Subject: [PATCH 28/53] Address review: recurse through submodules in the shape fallback When an argument's signature cannot be expanded, the values referenced from its shape now include those of nested modules at any depth, with aliases followed and recursive shapes guarded. --- src/Compat.ml | 40 +++++++++++++++++++++++++++------------- 1 file changed, 27 insertions(+), 13 deletions(-) diff --git a/src/Compat.ml b/src/Compat.ml index be4644fc..160d2a2a 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -905,19 +905,33 @@ let rec makeResolver ~cmtFilePath | None -> None); moduleTypeOfPath = (fun path -> !moduleTypeOfPathRef path); shapeValueItems = - (fun shape -> - match (Reduce.reduce Env.empty shape).desc with - | Struct items -> - Shape.Item.Map.fold - (fun (name, kind) _ acc -> - match kind with - | Shape.Sig_component_kind.Value -> ( - match projValueLoc shape name with - | Some loc -> (name, loc) :: acc - | None -> acc) - | _ -> acc) - items [] - | _ -> []); + (* Values at any depth of submodules; [visited] guards recursive + shapes. Functor members have no values to reference. *) + (let rec items visited (shape : Shape.t) path = + let reduced = Reduce.reduce Env.empty shape in + if List.memq reduced visited then [] + else + let visited = reduced :: visited in + match reduced.desc with + | Struct fields -> + Shape.Item.Map.fold + (fun (name, kind) _ acc -> + match kind with + | Shape.Sig_component_kind.Value -> ( + match projValueLoc shape name with + | Some loc -> (String.concat "." (path @ [name]), loc) :: acc + | None -> acc) + | Shape.Sig_component_kind.Module -> + items visited + (Shape.proj shape (Shape.Item.make name Module)) + (path @ [name]) + @ acc + | _ -> acc) + fields [] + | Alias aliased -> items visited aliased path + | _ -> [] + in + fun shape -> items [] shape []); bindingOfPath = (fun path -> bindingOfPath path); headKey = (let rec unwrap (e : Typedtree.module_expr) = From 62f4eadf872f23a9d36f6455e3f9cee4e26aa34b Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 19:33:46 +0000 Subject: [PATCH 29/53] Address review: forward parameter aliases in recursive groups Parameter aliases in a recursive module group are registered to a fixed point, so module rec G = H and H = M inside a functor makes G stand for the parameter M too. Regression case: Apply_recfwd. --- examples/regression/src/Main.ml | 3 ++- .../regression/src/Shared_signature_arg.ml | 20 +++++++++++++++++++ scripts/run_integration_tests.js | 9 +++++++++ src/DeadValue.ml | 19 +++++++++++++++++- 4 files changed, 49 insertions(+), 2 deletions(-) diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 36e9ad83..bceb7c34 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -35,4 +35,5 @@ let () = Shared_signature_arg.run_mt (); Shared_signature_arg.run_param_mt (); Shared_signature_arg.run_param_mt2 (); - Shared_signature_arg.run_u () + Shared_signature_arg.run_u (); + Shared_signature_arg.run_recfwd () diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml index f36aebd9..3b6146da 100644 --- a/examples/regression/src/Shared_signature_arg.ml +++ b/examples/regression/src/Shared_signature_arg.ml @@ -665,3 +665,23 @@ module Applied_u = Apply_u ((Use_u : U_alias)) module Applied_u2 = Apply_u2 ((Use_u2 : U_applied)) let run_u () = ignore (Applied_u.run () + Applied_u2.run ()) + +(* A forward alias of the parameter inside a recursive group. *) +module Opt_recfwd : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_recfwd_other : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Apply_recfwd (M : Shared_signature.O) = struct + module rec G : Shared_signature.O = H + and H : Shared_signature.O = M + + let run () = G.g ~x:1 () +end + +module Applied_recfwd = Apply_recfwd (Opt_recfwd) + +let run_recfwd () = ignore (Applied_recfwd.run () + Opt_recfwd_other.g ()) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index e183a4ff..cfa8bcf7 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -306,6 +306,15 @@ function runRegressionTests() { // functor's result. assertIncludes(output, "Live Value +Shared_signature_arg.Use_u.+f"); assertIncludes(output, "Live Value +Shared_signature_arg.Use_u2.+k"); + // A forward alias of the parameter in a recursive group. + assertIncludes( + output, + "optional argument x of function Opt_recfwd.+g is always supplied" + ); + assertIncludes( + output, + "optional argument x of function Opt_recfwd_other.+g is never used" + ); // Partial applications: held by a let module, and bound in another file. assertIncludes( output, diff --git a/src/DeadValue.ml b/src/DeadValue.ml index dd7ecc00..4bc158ef 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -1100,7 +1100,24 @@ let traverseStructure ~doTypes ~doExternals = false in let rec fixpoint n = if n > 0 && resolveKeys () then fixpoint (n - 1) in - fixpoint (List.length moduleBindings) + fixpoint (List.length moduleBindings); + (* Likewise for aliases of a functor parameter: [module rec G : S = H + and H : S = M] registers H first, then G through H. *) + let registerAliases () = + moduleBindings + |> List.fold_left + (fun changed (mb : Typedtree.module_binding) -> + match mb.mb_id with + | Some id when findFunctorParameter (Pident id) = None -> + registerParameterAlias mb.mb_id mb.mb_expr; + findFunctorParameter (Pident id) <> None || changed + | _ -> changed) + false + in + let rec aliasFixpoint n = + if n > 0 && registerAliases () then aliasFixpoint (n - 1) + in + aliasFixpoint (List.length moduleBindings) | Tstr_primitive vd when doExternals && !Config.analyzeExternals -> let currentModulePath = ModulePath.getCurrent () in let path = currentModulePath.path @ [!Common.currentModuleName] in From 4b5d3cbca50ca826991ea7e8dd2bf4f519c32c74 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 19:38:23 +0000 Subject: [PATCH 30/53] Register let-module parameter aliases before their body is visited (OCaml 5.5) Found by sweeping parameter-alias forms: on 5.5 a let module is a Texp_struct_item whose body the mapper visits before the item, so an alias chain (let module G = M in let module H = G in H.g ~x:1 ()) left H unregistered and its call forwardable to every implementation of the module type item. The alias is now registered in the expression hook before the body. Regression cases: Apply_sw1..Apply_sw4 (recursive alias of a parameter submodule, let-module alias chain, recursive alias of an outer alias, alias passed as a functor argument), each credited exactly once, with Opt_sw_other keeping its never-used warning. --- examples/regression/src/Main.ml | 3 +- .../regression/src/Shared_signature_arg.ml | 65 +++++++++++++++++++ scripts/run_integration_tests.js | 14 ++++ src/DeadValue.ml | 14 +++- 4 files changed, 94 insertions(+), 2 deletions(-) diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index bceb7c34..d7d1a36d 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -36,4 +36,5 @@ let () = Shared_signature_arg.run_param_mt (); Shared_signature_arg.run_param_mt2 (); Shared_signature_arg.run_u (); - Shared_signature_arg.run_recfwd () + Shared_signature_arg.run_recfwd (); + Shared_signature_arg.run_sweep () diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml index 3b6146da..8519ba52 100644 --- a/examples/regression/src/Shared_signature_arg.ml +++ b/examples/regression/src/Shared_signature_arg.ml @@ -685,3 +685,68 @@ end module Applied_recfwd = Apply_recfwd (Opt_recfwd) let run_recfwd () = ignore (Applied_recfwd.run () + Opt_recfwd_other.g ()) + +(* Sweep of parameter-alias forms: a recursive alias of a parameter's + submodule, a let-module alias chain, a recursive alias of an outer alias, + and an alias passed as a functor argument. *) +module Opt_sw1 : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_sw2 : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_sw3 : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_sw4 : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_sw_other : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Nested_sw1 : With_nested = struct + module N = Opt_sw1 +end + +module Apply_sw1 (M : With_nested) = struct + module rec G : Shared_signature.O = H + and H : Shared_signature.O = M.N + + let run () = G.g ~x:1 () +end + +module Apply_sw2 (M : Shared_signature.O) = struct + let run () = + let module G = M in + let module H = G in + H.g ~x:1 () +end + +module Apply_sw3 (M : Shared_signature.O) = struct + module N = M + module rec G : Shared_signature.O = N + + let run () = G.g ~x:1 () +end + +module Apply_sw4 (M : Shared_signature.O) = struct + module N = M + module App = Apply_opt (N) + + let run () = App.run () +end + +module Applied_sw1 = Apply_sw1 (Nested_sw1) +module Applied_sw2 = Apply_sw2 (Opt_sw2) +module Applied_sw3 = Apply_sw3 (Opt_sw3) +module Applied_sw4 = Apply_sw4 (Opt_sw4) + +let run_sweep () = + ignore + (Applied_sw1.run () + Applied_sw2.run () + Applied_sw3.run () + + Applied_sw4.run () + Opt_sw_other.g ()) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index cfa8bcf7..fdcdafa5 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -315,6 +315,20 @@ function runRegressionTests() { output, "optional argument x of function Opt_recfwd_other.+g is never used" ); + // Sweep of parameter-alias forms: recursive alias of a parameter's + // submodule, let-module alias chain, recursive alias of an outer alias, + // alias passed as a functor argument. Each credited exactly once and + // never leaked to an unrelated implementation. + for (const m of ["Opt_sw1", "Opt_sw2", "Opt_sw3", "Opt_sw4"]) { + assertIncludes( + output, + `optional argument x of function ${m}.+g is always supplied (1 calls)` + ); + } + assertIncludes( + output, + "optional argument x of function Opt_sw_other.+g is never used" + ); // Partial applications: held by a let module, and bound in another file. assertIncludes( output, diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 4bc158ef..3db6ffa9 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -242,6 +242,10 @@ let registerParameterAlias (id : Ident.t option) | Some id, Some path -> ( match (findFunctorParameter path, pathComponents path) with | Some p, Some components -> + if !Common.Cli.debug then + Log_.item "parameterAlias %s = %s (prefix %s)@." (Ident.unique_name id) + (Path.name path) + (String.concat "." (p.prefix @ components)); functorParameters := {p with paramId = id; prefix = p.prefix @ components} :: !functorParameters @@ -399,7 +403,15 @@ let rec collectExpr super self (e : Typedtree.expression) = (* [let module F (M : S) = ... in]: key the functor by its binding. On OCaml >= 5.5 this is a [Texp_struct_item] holding a [Tstr_module], which the structure item handler covers. *) - #if OCAML_VERSION < (5, 5, 0) + #if OCAML_VERSION >= (5, 5, 0) + (* The mapper visits the body of a [let module] before the binding, so an + alias of a parameter must be registered here for uses in the body. The + structure item handler registers it again, harmlessly. *) + (match e.exp_desc with + | Texp_struct_item ({str_desc = Tstr_module {mb_id; mb_expr}}, _) -> + registerParameterAlias mb_id mb_expr + | _ -> ()); + #else (match e.exp_desc with | Texp_letmodule (id, name, _, moduleExpr, _) -> setFunctorKey moduleExpr name.loc.loc_start; From 722a9619542acecab2c4cf7f5280833e9d3d81b8 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 19:45:32 +0000 Subject: [PATCH 31/53] Address review: colliding functor keys credit all applications; exact source paths - Two functor definitions a ppx emitted at one position share a key. Rather than dropping the calls through their parameters (which could report a supplied argument as unused), they are credited to the arguments of every application of that key, which is tighter than forwarding to every implementation. - The signature declaration filter resolves the recorded source file and positions against the cmt's build directory and compares exactly; no suffix matching. --- src/DeadCode.ml | 8 ++++-- src/DeadValue.ml | 71 ++++++++++++++++-------------------------------- 2 files changed, 30 insertions(+), 49 deletions(-) diff --git a/src/DeadCode.ml b/src/DeadCode.ml index 395dcd36..96817913 100644 --- a/src/DeadCode.ml +++ b/src/DeadCode.ml @@ -10,9 +10,11 @@ let processSignature ~doValues ~doTypes (signature : Types.signature) = (* Restrict the declarations taken from a file's signature to definitions of the file itself, see [DeadValue.setSignatureValueFilter]. *) -let setSignatureValueFilter ~(fileName : string option) ~moduleTypeRanges = +let setSignatureValueFilter ~(fileName : string option) ~buildDir + ~moduleTypeRanges = match fileName with - | Some fileName -> DeadValue.setSignatureValueFilter ~fileName ~moduleTypeRanges + | Some fileName -> + DeadValue.setSignatureValueFilter ~fileName ~buildDir ~moduleTypeRanges | None -> DeadValue.isSignatureValueDeclaration := fun _ -> true (* Locations of every [module type] declaration of a file, at any depth. *) @@ -73,6 +75,7 @@ let processCmt ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) = | Interface signature -> ProcessDeadAnnotations.signature signature; setSignatureValueFilter ~fileName:cmt_infos.cmt_sourcefile + ~buildDir:cmt_infos.cmt_builddir ~moduleTypeRanges:(moduleTypeRangesOfSignature signature); processSignature ~doValues:true ~doTypes:true signature.sig_type | Implementation structure -> @@ -81,6 +84,7 @@ let processCmt ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) = in ProcessDeadAnnotations.structure ~doGenType:(not cmtiExists) structure; setSignatureValueFilter ~fileName:cmt_infos.cmt_sourcefile + ~buildDir:cmt_infos.cmt_builddir ~moduleTypeRanges:(moduleTypeRangesOfStructure structure); processSignature ~doValues:true ~doTypes:false structure.str_type; let doExternals = diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 3db6ffa9..cbb6aa5f 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -193,21 +193,12 @@ let functorKeys : (Typedtree.module_expr * Lexing.position) list ref = ref [] let setFunctorKey (moduleExpr : Typedtree.module_expr) pos = functorKeys := (moduleExpr, pos) :: !functorKeys -(* Keys must identify one functor definition. Applications only learn a - position (through the binding's declaration, possibly in another file), so - two distinct definitions a ppx emitted at one position cannot be told - apart: such keys are not credited at all, conservatively. *) -let functorKeyOwners : (Lexing.position, Typedtree.module_expr) Hashtbl.t = - Hashtbl.create 16 - -let ambiguousFunctorKeys = ref PosSet.empty - -let claimFunctorKey (moduleExpr : Typedtree.module_expr) pos = - match Hashtbl.find_opt functorKeyOwners pos with - | Some owner when owner != moduleExpr -> - ambiguousFunctorKeys := PosSet.add pos !ambiguousFunctorKeys - | Some _ -> () - | None -> Hashtbl.replace functorKeyOwners pos moduleExpr +(* Keys are positions, since applications only learn a definition through + its declaration's location (possibly in another file). Two distinct + definitions a ppx emitted at one position therefore share a key: the + calls through either's parameters are credited to the arguments of every + application of that key, which is tighter than forwarding to every + implementation and never hides a supplied argument. *) let findFunctorKey (moduleExpr : Typedtree.module_expr) = match List.find_opt (fun (e, _) -> e == moduleExpr) !functorKeys with @@ -415,7 +406,6 @@ let rec collectExpr super self (e : Typedtree.expression) = (match e.exp_desc with | Texp_letmodule (id, name, _, moduleExpr, _) -> setFunctorKey moduleExpr name.loc.loc_start; - claimFunctorKey moduleExpr name.loc.loc_start; registerParameterAlias id moduleExpr; (match id with | Some id -> @@ -757,34 +747,29 @@ let recordParameterCoercion ~locFrom ~coercion ~actualType items point at the module type's [val]s): they are not declarations. *) let isSignatureValueDeclaration = ref (fun (_ : Location.t) -> true) -let setSignatureValueFilter ~(fileName : string) +let setSignatureValueFilter ~(fileName : string) ~(buildDir : string) ~(moduleTypeRanges : Location.t list) = - (* Full paths, without extensions (a preprocessed source is recorded as - [foo.pp.ml] while its positions say [foo.ml]); one may be relative to - the other's root, so a path suffix also matches. Basenames alone would - confuse same-named sources of different build targets. *) + (* Full paths resolved against the build directory the compiler ran in + (both the recorded source file and positions are relative to it), and + compared exactly, without extensions (a preprocessed source is recorded + as [foo.pp.ml] while its positions say [foo.ml]). Basenames or suffixes + alone would confuse same-named sources in different directories. *) let normalize path = + let path = + if Filename.is_relative path then Filename.concat buildDir path else path + in let dir = Filename.dirname path in let base = match String.index_opt (Filename.basename path) '.' with | Some i -> String.sub (Filename.basename path) 0 i | None -> Filename.basename path in - if dir = "." then base else dir ^ "/" ^ base - in - let endsWith ~suffix s = - let ls = String.length s and lsuf = String.length suffix in - ls >= lsuf && String.sub s (ls - lsuf) lsuf = suffix + Filename.concat dir base in let self = normalize fileName in isSignatureValueDeclaration := fun (loc : Location.t) -> - let other = normalize loc.loc_start.pos_fname in - let sameFile = - other = self - || endsWith ~suffix:("/" ^ other) self - || endsWith ~suffix:("/" ^ self) other - in + let sameFile = normalize loc.loc_start.pos_fname = self in if (not sameFile) && !Common.Cli.debug then Log_.item "signatureValueSkipped %s (file %s)@." (loc.loc_start |> posToString) @@ -956,9 +941,7 @@ let traverseStructure ~doTypes ~doExternals = let functorDef = match findFunctorKey moduleExpr with | Some pos -> pos - | None -> - claimFunctorKey moduleExpr moduleExpr.mod_loc.loc_start; - moduleExpr.mod_loc.loc_start + | None -> moduleExpr.mod_loc.loc_start in setFunctorKey body functorDef; let paramIndex = @@ -1056,7 +1039,6 @@ let traverseStructure ~doTypes ~doExternals = | Tstr_module {mb_expr; mb_id; mb_loc; mb_name} -> ( currentModuleBindingPos := mb_name.loc.loc_start; setFunctorKey mb_expr mb_name.loc.loc_start; - claimFunctorKey mb_expr mb_name.loc.loc_start; registerParameterAlias mb_id mb_expr; let hasInterface = match mb_expr.mod_desc with Tmod_constraint _ -> true | _ -> false @@ -1083,7 +1065,6 @@ let traverseStructure ~doTypes ~doExternals = moduleBindings |> List.iter (fun (mb : Typedtree.module_binding) -> setFunctorKey mb.mb_expr mb.mb_name.loc.loc_start; - claimFunctorKey mb.mb_expr mb.mb_name.loc.loc_start; registerParameterAlias mb.mb_id mb.mb_expr; match mb.mb_id with | Some id -> @@ -1276,13 +1257,12 @@ let forceDelayedItems () = delayedApplications := List.rev !delayedApplications; Hashtbl.iter (fun (def, index, components) calls -> - if not (PosSet.mem def !ambiguousFunctorKeys) then - resolveArgumentItems ~visited:[] def index components - |> List.iter (fun (locTo : Location.t) -> - calls - |> List.iter - (DeadOptionalArgs.addCallToImplementation - ~posTo:locTo.loc_start))) + resolveArgumentItems ~visited:[] def index components + |> List.iter (fun (locTo : Location.t) -> + calls + |> List.iter + (DeadOptionalArgs.addCallToImplementation + ~posTo:locTo.loc_start))) parameterCalls; (* Reference the items a parameter's coercion uses, in the arguments of the enclosing functor's applications; the module type item is the fallback @@ -1290,7 +1270,6 @@ let forceDelayedItems () = List.rev !parameterCoercions |> List.iter (fun {outerFunctor; outerIndex; itemPath; coercionFrom; coercionTo} -> - if not (PosSet.mem outerFunctor !ambiguousFunctorKeys) then let resolved = resolveArgumentItems ~visited:[] outerFunctor outerIndex itemPath in @@ -1322,11 +1301,9 @@ let processStructure ~cmt_value_dependencies ~cmt_ident_resolutions ~doTypes recordedApplications := []; functorsByIdent := []; functorKeys := []; - Hashtbl.reset functorKeyOwners; structure |> traverseStructure.structure traverseStructure |> ignore; recordedApplications := []; functorKeys := []; - Hashtbl.reset functorKeyOwners; identResolutions := Compat.emptyIdentResolutions; let valueDependencies = cmt_value_dependencies |> List.rev in delayedValueDependencies := From 43683e8390fbcce27702766d42f01ba9c482c4d4 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 19:47:37 +0000 Subject: [PATCH 32/53] Normalize path segments in the source-file comparison Found by sweeping the exact-path filter: a position path may carry ./ or ../ segments the recorded source file does not, which Filename.concat keeps. Segments are now normalized before comparing. --- src/DeadValue.ml | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/src/DeadValue.ml b/src/DeadValue.ml index cbb6aa5f..52b4f314 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -758,13 +758,24 @@ let setSignatureValueFilter ~(fileName : string) ~(buildDir : string) let path = if Filename.is_relative path then Filename.concat buildDir path else path in - let dir = Filename.dirname path in let base = match String.index_opt (Filename.basename path) '.' with | Some i -> String.sub (Filename.basename path) 0 i | None -> Filename.basename path in - Filename.concat dir base + (* Drop [.] segments and resolve [..], which one side may carry. *) + let segments = + String.split_on_char '/' (Filename.dirname path) + |> List.fold_left + (fun acc segment -> + match (segment, acc) with + | ".", _ -> acc + | "..", _ :: rest -> rest + | _ -> segment :: acc) + [] + |> List.rev + in + String.concat "/" (segments @ [base]) in let self = normalize fileName in isSignatureValueDeclaration := From 5c7069e2b870c1f6b9cb28277cf8f18b717f8be9 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 19:56:57 +0000 Subject: [PATCH 33/53] Address review: copies of a compiled unit are one unit; both path separators A broad root such as _build holds copies of the same artifact: a library's objects and its _build/install copy, byte and native objects. - Scanning: a unit (by source file, build directory, interface digest) is scanned once; scanning copies recorded every application twice, multiplying optional-argument call counts (4096 through the ten-functor chain). - Loading: copies of one source are one candidate, so they no longer count as ambiguous directories and lose cross-unit resolution. - The source-file comparison normalizes both separators. The regression runner now scans a layout with dependencies duplicated in two directories and consumers in a third, and requires the same result as the single directory. --- scripts/run_integration_tests.js | 46 ++++++++++++++++++++++++++++++++ src/Compat.ml | 23 +++++++++++++--- src/DeadValue.ml | 8 ++++-- src/Reanalyze.ml | 14 ++++++++++ 4 files changed, 86 insertions(+), 5 deletions(-) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index fdcdafa5..335100ed 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -381,6 +381,51 @@ function runRegressionTests() { assertNotIncludes(dupOutput, "Dead Value +Dup_b_impl.Make.+g"); } +// A broad root may hold copies of the same compiled unit (a library's +// objects and its _build/install copy, byte and native objects). Scanning +// such a root must give exactly the single-directory result: copies are +// neither scanned twice nor mistaken for distinct units. +function runDuplicateLayoutTest() { + const fs = require("fs"); + const os = require("os"); + const cwd = path.join(__dirname, "..", "examples", "regression"); + const cmtDir = path.join( + cwd, + "_build/default/src/.regression_fixture.objs/byte" + ); + const root = fs.mkdtempSync(path.join(os.tmpdir(), "reanalyze-dup-")); + for (const dir of ["a", "b", "c"]) fs.mkdirSync(path.join(root, dir)); + for (const file of fs.readdirSync(cmtDir)) { + if (!/\.cmti?$/.test(file)) continue; + // Dependencies duplicated in a and b, consumers in c. + const dirs = /Shared_signature|Cross_/.test(file) ? ["a", "b"] : ["c"]; + for (const dir of dirs) + fs.copyFileSync(path.join(cmtDir, file), path.join(root, dir, file)); + } + const filter = (output) => + output + .split("\n") + .filter((line) => /never used|always supplied|dead module/.test(line)) + .sort() + .join("\n"); + const run = (dir) => + child_process.execFileSync( + reanalyzeFile, + ["-ci", "-native-build-target", ".", "-dce-cmt", dir], + { cwd, encoding: "utf8" } + ); + console.log(`${cwd}: reanalyze duplicate-layout comparison`); + const single = filter(run(cmtDir)); + const duplicated = filter(run(root)); + fs.rmSync(root, { recursive: true, force: true }); + if (single !== duplicated) { + throw new Error( + "Scanning a root with duplicated compiled units changed the result:\n" + + duplicated + ); + } +} + function checkSetup() { console.log("Checking if --version outputs the right version"); let output; @@ -413,6 +458,7 @@ function main() { checkSetup(); cleanBuildExamples(); runRegressionTests(); + runDuplicateLayoutTest(); checkDiff(); console.log("Test successful!"); diff --git a/src/Compat.ml b/src/Compat.ml index 160d2a2a..fda96121 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -419,9 +419,26 @@ let loadUnitInfo ~currentCmtFile ~(imports : Misc.crcs) comp_unit = | matching -> matching) | _ -> loaded in - (* Candidates still spanning several build directories (same name and - same interface) cannot be told apart: resolve nothing rather than - redirect into the wrong target. *) + (* Copies of one compiled source (e.g. a library's objects and its + _build/install copy, or byte and native objects) are one unit: keep + the first of each. Candidates that are still distinct sources in + several build directories (same name and same interface) cannot be + told apart: resolve nothing rather than redirect into the wrong + target. *) + let loaded = + let seen = Hashtbl.create 4 in + loaded + |> List.filter (fun (_, (cmt_infos : Cmt_format.cmt_infos)) -> + let key = + ( cmt_infos.cmt_sourcefile, + cmt_infos.cmt_builddir, + cmt_infos.cmt_impl_shape <> None ) + in + if Hashtbl.mem seen key then false + else ( + Hashtbl.replace seen key (); + true)) + in let loaded = match loaded |> List.map (fun (p, _) -> Filename.dirname p) diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 52b4f314..168f845a 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -763,9 +763,13 @@ let setSignatureValueFilter ~(fileName : string) ~(buildDir : string) | Some i -> String.sub (Filename.basename path) 0 i | None -> Filename.basename path in - (* Drop [.] segments and resolve [..], which one side may carry. *) + (* Drop [.] segments and resolve [..], which one side may carry; both + separators, as Windows paths may carry either. *) let segments = - String.split_on_char '/' (Filename.dirname path) + String.split_on_char '/' + (String.map + (fun c -> if c = '\\' then '/' else c) + (Filename.dirname path)) |> List.fold_left (fun acc segment -> match (segment, acc) with diff --git a/src/Reanalyze.ml b/src/Reanalyze.ml index 630d8386..7b5f6821 100644 --- a/src/Reanalyze.ml +++ b/src/Reanalyze.ml @@ -1,7 +1,21 @@ open Common +(* Compiled units already scanned, by source: a broad root may hold copies + of the same artifact (a library's objects and its _build/install copy, + byte and native objects), which must not be scanned twice. *) +let scannedUnits = Hashtbl.create 256 + let loadCmtFile ~cmtRoot cmtFilePath = let cmt_infos = Cmt_format.read_cmt cmtFilePath in + let unitKey = + ( cmt_infos.cmt_sourcefile, + cmt_infos.cmt_builddir, + cmt_infos.cmt_interface_digest, + Filename.check_suffix cmtFilePath ".cmti" ) + in + if Hashtbl.mem scannedUnits unitKey then () + else + let () = Hashtbl.replace scannedUnits unitKey () in let excludePath sourceFile = !Cli.excludePaths |> List.exists (fun prefix_ -> From 08c98e61a0c6d4f0314adbe91eee87713de7ce25 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 20:04:10 +0000 Subject: [PATCH 34/53] Address review: fall back to a constrained argument's concrete type When an argument's constraint names a module type whose unit is outside the analysis root, the type of the module under the constraints is used instead, with all of its values referenced since the coercion computed against the constraint does not apply to it. Regression cases: Apply_ord applied to an inline and to a named module constrained by Set.OrderedType. --- examples/regression/src/Main.ml | 4 ++- .../regression/src/Shared_signature_arg.ml | 28 ++++++++++++++++ scripts/run_integration_tests.js | 4 +++ src/DeadValue.ml | 32 +++++++++++++++++-- 4 files changed, 65 insertions(+), 3 deletions(-) diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index d7d1a36d..729229a5 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -37,4 +37,6 @@ let () = Shared_signature_arg.run_param_mt2 (); Shared_signature_arg.run_u (); Shared_signature_arg.run_recfwd (); - Shared_signature_arg.run_sweep () + Shared_signature_arg.run_sweep (); + Shared_signature_arg.run_ord (); + Shared_signature_arg.run_ord2 () diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml index 8519ba52..958f33cc 100644 --- a/examples/regression/src/Shared_signature_arg.ml +++ b/examples/regression/src/Shared_signature_arg.ml @@ -750,3 +750,31 @@ let run_sweep () = ignore (Applied_sw1.run () + Applied_sw2.run () + Applied_sw3.run () + Applied_sw4.run () + Opt_sw_other.g ()) + +(* An inline argument constrained by a module type whose unit is outside + the analysis root (Set.OrderedType lives in the stdlib): the concrete + structure's type is the fallback. *) +module Apply_ord (M : Set.OrderedType) = struct + let run () = + ignore M.compare; + 0 +end + +module Applied_ord = + Apply_ord ((struct + type t = int + + let compare (a : int) b = Stdlib.compare a b + end : Set.OrderedType)) + +let run_ord () = ignore (Applied_ord.run ()) + +module Ord_named = struct + type t = int + + let compare (a : int) b = Stdlib.compare a b +end + +module Applied_ord2 = Apply_ord ((Ord_named : Set.OrderedType)) + +let run_ord2 () = ignore (Applied_ord2.run ()) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index 335100ed..2841174f 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -329,6 +329,10 @@ function runRegressionTests() { output, "optional argument x of function Opt_sw_other.+g is never used" ); + // Arguments constrained by a module type from outside the analysis root + // (Set.OrderedType): inline and named. + assertIncludes(output, "Live Value +Shared_signature_arg.Applied_ord.+compare"); + assertIncludes(output, "Live Value +Shared_signature_arg.Ord_named.+compare"); // Partial applications: held by a let module, and bound in another file. assertIncludes( output, diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 168f845a..f5608bf2 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -845,6 +845,23 @@ let rec argumentModuleType (argumentExpr : Typedtree.module_expr) = | Tmod_constraint (inner, _, _, _), Mty_ident _ -> argumentModuleType inner | _ -> expand argumentExpr.mod_type +(* When a constrained argument's module type cannot be expanded (its unit is + outside the analysis root), the type of the module under the constraints + is the fallback: it is concrete, so it exposes items. The coercion + computed against the constraint does not apply to it, so callers + reference all of its values. *) +let concreteArgumentType (argumentExpr : Typedtree.module_expr) = + let rec innermost (e : Typedtree.module_expr) = + match e.mod_desc with + | Tmod_constraint (inner, _, _, _) -> innermost inner + | _ -> e + in + let inner = innermost argumentExpr in + if inner == argumentExpr then None + else + let moduleType = expandModuleType inner.mod_type in + match getSignature moduleType with [] -> None | _ -> Some moduleType + (* Implementation of a value of an actual functor argument, by path. *) let argumentItemResolver (argumentExpr : Typedtree.module_expr) = match moduleIdent argumentExpr with @@ -888,7 +905,12 @@ let argumentItemResolver (argumentExpr : Typedtree.module_expr) = | None -> None) | _ -> None) in - let moduleType = argumentModuleType argumentExpr in + let moduleType = + let declared = argumentModuleType argumentExpr in + match (expandedSignature declared, concreteArgumentType argumentExpr) with + | [], Some concrete -> concrete + | _ -> declared + in Direct (fun components -> match shape with @@ -1008,7 +1030,13 @@ let traverseStructure ~doTypes ~doExternals = | _ when not argumentExpr.mod_loc.loc_ghost -> argumentExpr.mod_loc | _ -> moduleExpr.mod_loc in - let actualType = argumentModuleType argumentExpr in + let actualType, coercion = + let declared = argumentModuleType argumentExpr in + match (expandedSignature declared, concreteArgumentType argumentExpr) with + | [], Some concrete -> (concrete, Typedtree.Tcoerce_none) + | _ -> (declared, coercion) + in + let actualType = actualType in if !Common.Cli.debug then Log_.item "functorArgument %s coercion:%s type:%s items:%d@." (argumentExpr.mod_loc.loc_start |> posToString) From 027aa9e29c661f429bc348f71afb018b5935b4d6 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 20:13:56 +0000 Subject: [PATCH 35/53] Address review: module type ranges in applications and parameter types Module types declared in an inline applied functor's body, in an argument that flows into the result, and in a functor parameter's type (both Tmod_functor and Tmty_functor) are now excluded from signature declarations; the val items of a parameter's module type were registered as implementations of every application. Regression cases: M_app, F_param applied to Arg_p and, unused, to Arg_p2, whose application must produce no report. --- examples/regression/src/Main.ml | 3 +- .../regression/src/Shared_signature_arg.ml | 55 +++++++++++++++++++ scripts/run_integration_tests.js | 7 +++ src/DeadCode.ml | 21 ++++++- 4 files changed, 83 insertions(+), 3 deletions(-) diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 729229a5..53204d7a 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -39,4 +39,5 @@ let () = Shared_signature_arg.run_recfwd (); Shared_signature_arg.run_sweep (); Shared_signature_arg.run_ord (); - Shared_signature_arg.run_ord2 () + Shared_signature_arg.run_ord2 (); + Shared_signature_arg.run_ranges () diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml index 958f33cc..327e7a74 100644 --- a/examples/regression/src/Shared_signature_arg.ml +++ b/examples/regression/src/Shared_signature_arg.ml @@ -778,3 +778,58 @@ end module Applied_ord2 = Apply_ord ((Ord_named : Set.OrderedType)) let run_ord2 () = ignore (Applied_ord2.run ()) + +(* Module types declared inside an inline applied functor's body, and inside + a functor parameter's module type whose result exposes the parameter. *) +module M_app = + (functor (A : Shared_signature.S) -> struct + let _ = A.f + + module type T = sig + val f : unit -> int + end + + module X : T = struct + let f () = 50 + end + end) + (Chosen) + +module F_param (M : sig + module type T = sig + val f : unit -> int + end + + module X : T +end) = +struct + include M +end + +module Arg_p = struct + module type T = sig + val f : unit -> int + end + + module X : T = struct + let f () = 51 + end +end + +module Applied_fp = F_param (Arg_p) + +let run_ranges () = ignore (M_app.X.f () + Applied_fp.X.f ()) + +(* An unused application of F_param: nothing may be reported at the + parameter's module type items. *) +module Arg_p2 = struct + module type T = sig + val f : unit -> int + end + + module X : T = struct + let f () = 52 + end +end + +module Applied_fp2 = F_param (Arg_p2) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index 2841174f..65fa8cf6 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -333,6 +333,13 @@ function runRegressionTests() { // (Set.OrderedType): inline and named. assertIncludes(output, "Live Value +Shared_signature_arg.Applied_ord.+compare"); assertIncludes(output, "Live Value +Shared_signature_arg.Ord_named.+compare"); + // Module types inside an applied inline functor and inside a functor + // parameter's type: their items are never declarations. + assertIncludes(output, "Live Value +Shared_signature_arg.M_app.X.+f"); + assertIncludes(output, "Live Value +Shared_signature_arg.Arg_p.X.+f"); + // (Arg_p2.X.f is live: an argument's coerced items count as used.) + assertNotIncludes(output, "Value +Shared_signature_arg.Applied_fp2.X.+f"); + assertNotIncludes(output, "Value +Shared_signature_arg.F_param.X.+f"); // Partial applications: held by a let module, and bound in another file. assertIncludes( output, diff --git a/src/DeadCode.ml b/src/DeadCode.ml index 96817913..4c6e8c7a 100644 --- a/src/DeadCode.ml +++ b/src/DeadCode.ml @@ -37,9 +37,25 @@ and moduleTypeRangesOfModuleExpr (moduleExpr : Typedtree.module_expr) = | Tmod_constraint (inner, _, Tmodtype_explicit mty, _) -> moduleTypeRangesOfModuleExpr inner @ moduleTypeRangesOfModuleType mty | Tmod_constraint (inner, _, _, _) -> moduleTypeRangesOfModuleExpr inner - | Tmod_functor (_, body) -> moduleTypeRangesOfModuleExpr body + | Tmod_functor (param, body) -> + (* A parameter's module type, whose items the result may expose. *) + moduleTypeRangesOfFunctorParameter param + @ moduleTypeRangesOfModuleExpr body + | Tmod_apply (functorExpr, argumentExpr, _) -> + (* An inline functor's body, and an argument's members that flow into + the result. *) + moduleTypeRangesOfModuleExpr functorExpr + @ moduleTypeRangesOfModuleExpr argumentExpr +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit functorExpr -> moduleTypeRangesOfModuleExpr functorExpr +#endif | _ -> [] +and moduleTypeRangesOfFunctorParameter (param : Typedtree.functor_parameter) = + match param with + | Named (_, _, mty) -> moduleTypeRangesOfModuleType mty + | Unit -> [] + and moduleTypeRangesOfSignature (signature : Typedtree.signature) = signature.sig_items |> List.concat_map (fun (item : Typedtree.signature_item) -> @@ -56,7 +72,8 @@ and moduleTypeRangesOfSignature (signature : Typedtree.signature) = and moduleTypeRangesOfModuleType (moduleType : Typedtree.module_type) = match moduleType.mty_desc with | Tmty_signature signature -> moduleTypeRangesOfSignature signature - | Tmty_functor (_, body) -> moduleTypeRangesOfModuleType body + | Tmty_functor (param, body) -> + moduleTypeRangesOfFunctorParameter param @ moduleTypeRangesOfModuleType body | Tmty_with (base, constraints) -> (* A [with module type S = sig ... end] constraint carries a module type whose items must not count as declarations either. *) From 68ae253620e55852da3812c2390c40d517c89181 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 3 Sep 2026 20:24:36 +0000 Subject: [PATCH 36/53] Address review: constraint-wrapped right-hand sides when deriving functor keys Constraints are unwrapped wherever a functor key is derived from a binding's right-hand side: recursive bindings of a constrained partial application or alias (module rec G : FT = (F (A) : FT)), and, before OCaml 5.5, let-module bindings of a constrained functor, whose key was the inline position while its parameter calls were keyed by the binding. Regression cases: G_c, run_letc. --- examples/regression/src/Main.ml | 3 ++- .../regression/src/Shared_signature_arg.ml | 26 +++++++++++++++++++ scripts/run_integration_tests.js | 10 +++++++ src/DeadValue.ml | 12 ++++++--- 4 files changed, 47 insertions(+), 4 deletions(-) diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 53204d7a..5777d3fd 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -40,4 +40,5 @@ let () = Shared_signature_arg.run_sweep (); Shared_signature_arg.run_ord (); Shared_signature_arg.run_ord2 (); - Shared_signature_arg.run_ranges () + Shared_signature_arg.run_ranges (); + Shared_signature_arg.run_constrained () diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml index 327e7a74..32f77d70 100644 --- a/examples/regression/src/Shared_signature_arg.ml +++ b/examples/regression/src/Shared_signature_arg.ml @@ -833,3 +833,29 @@ module Arg_p2 = struct end module Applied_fp2 = F_param (Arg_p2) + +(* Constraint-wrapped right-hand sides where a functor key is derived: a + recursive binding of a constrained partial application, and a let-module + binding of a constrained functor. *) +module Opt_recc : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_letc : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module rec G_c : Opt_functor = (Apply2 (Chosen) : Opt_functor) + +module Applied_recc = G_c (Opt_recc) + +let run_letc () = + let module F : Opt_functor = + (functor (M : Shared_signature.O) -> struct + let run () = M.g ~x:1 () + end : Opt_functor) + in + let module A = F (Opt_letc) in + A.run () + +let run_constrained () = ignore (Applied_recc.run () + run_letc ()) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index 65fa8cf6..ecbc1545 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -340,6 +340,16 @@ function runRegressionTests() { // (Arg_p2.X.f is live: an argument's coerced items count as used.) assertNotIncludes(output, "Value +Shared_signature_arg.Applied_fp2.X.+f"); assertNotIncludes(output, "Value +Shared_signature_arg.F_param.X.+f"); + // Constraint-wrapped right-hand sides: a recursive constrained partial + // application, and a let-module constrained functor. + assertIncludes( + output, + "optional argument x of function Opt_recc.+g is always supplied (1 calls)" + ); + assertIncludes( + output, + "optional argument x of function Opt_letc.+g is always supplied (1 calls)" + ); // Partial applications: held by a let module, and bound in another file. assertIncludes( output, diff --git a/src/DeadValue.ml b/src/DeadValue.ml index f5608bf2..dc3a5ec2 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -175,6 +175,12 @@ type parameterCoercion = { let parameterCoercions : parameterCoercion list ref = ref [] +(* A module expression under any [( M : S )] constraints. *) +let rec unwrapConstraints (moduleExpr : Typedtree.module_expr) = + match moduleExpr.mod_desc with + | Tmod_constraint (inner, _, _, _) -> unwrapConstraints inner + | _ -> moduleExpr + (* The module path an argument or functor expression denotes, through any [( M : S )] constraints. *) let rec moduleIdent (moduleExpr : Typedtree.module_expr) = @@ -412,7 +418,7 @@ let rec collectExpr super self (e : Typedtree.expression) = (* [let module G = F in] or [let module G = F (A) in]: G stands for F's key, with the arguments already consumed. *) let key = - match moduleExpr.mod_desc with + match (unwrapConstraints moduleExpr).mod_desc with | Tmod_functor _ -> (name.loc.loc_start, 0) | _ -> ( match functorKeyOfHead moduleExpr with @@ -1121,8 +1127,8 @@ let traverseStructure ~doTypes ~doExternals = moduleBindings |> List.fold_left (fun changed (mb : Typedtree.module_binding) -> - match (mb.mb_id, moduleIdent mb.mb_expr, mb.mb_expr.mod_desc) with - | Some id, _, Tmod_apply _ | Some id, Some _, _ -> ( + match (mb.mb_id, (unwrapConstraints mb.mb_expr).mod_desc) with + | Some id, (Tmod_apply _ | Tmod_ident _) -> ( match functorKeyOfHead mb.mb_expr with | Some key when List.assq_opt id !functorsByIdent <> Some key -> functorsByIdent := From 9cc6c3fa1db65463dce54093a619ccbbed35bfcd Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Fri, 4 Sep 2026 07:37:16 +0000 Subject: [PATCH 37/53] Address review: unit applications in chains, shapes of applied arguments Generative applications ([F () (Arg)], [Tmod_apply_unit] on OCaml 5.1+) now consume a parameter index in application chains: in functor keys, recorded applications, recursive bindings, and in the resolver's head, member and module type walkers. An argument that is itself an application ([Use (Make (A))]) gets the shape of the application, built from the functor's and the argument's, so calls and coercion references land in the applied functor's body rather than on every implementation of its result signature. Covered: direct, constrained, curried, nested, generative, through an alias of the functor, bound in another file, with a functor parameter as the inner argument, and an applied functor re-exporting its argument. When no shape is available (an inline functor, a constrained inline structure), values are found by name in the concrete type of the module. --- examples/regression/src/Cross_alias.ml | 10 + examples/regression/src/Cross_alias_use.ml | 26 +++ examples/regression/src/Main.ml | 7 +- .../regression/src/Shared_signature_arg.ml | 175 ++++++++++++++ scripts/run_integration_tests.js | 62 +++++ src/Compat.ml | 95 ++++++-- src/DeadValue.ml | 220 ++++++++++++------ 7 files changed, 502 insertions(+), 93 deletions(-) diff --git a/examples/regression/src/Cross_alias.ml b/examples/regression/src/Cross_alias.ml index 3787be38..47ce8017 100644 --- a/examples/regression/src/Cross_alias.ml +++ b/examples/regression/src/Cross_alias.ml @@ -8,3 +8,13 @@ module Outer_y (X : Shared_signature.S) = struct let _ = X.f include Cross_include.Helpers2 end + +(* A unit application bound in this file, completed from another. *) +module GU = Shared_signature_arg.F_unit () + +(* A functor applied in another file, as an argument of a further functor. *) +module Mk_cross (A : Shared_signature.S) : Shared_signature.O = struct + let g ?(x = 0) () = x + A.f () +end + +module Mk_cross_alias = Mk_cross diff --git a/examples/regression/src/Cross_alias_use.ml b/examples/regression/src/Cross_alias_use.ml index de2eba01..8e612e14 100644 --- a/examples/regression/src/Cross_alias_use.ml +++ b/examples/regression/src/Cross_alias_use.ml @@ -31,3 +31,29 @@ module Applied_outer_y = Cross_alias.Outer_y (Shared_signature_arg.Chosen) module Applied_y = Applied_outer_y.Inner2 (Opt_y) let run_y () = ignore (Applied_y.run ()) + +module Opt_cross_unit : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_cross_unit2 : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Applied_cross_unit = Cross_alias.GU (Opt_cross_unit) +module Applied_cross_unit2 = Shared_signature_arg.F_unit () (Opt_cross_unit2) + +module Applied_app_cross = + Shared_signature_arg.Use_o (Cross_alias.Mk_cross (Shared_signature_arg.Chosen)) + +let run_unit () = + ignore + (Applied_cross_unit.run () + Applied_cross_unit2.run () + + Applied_app_cross.run ()) + +(* An applied functor aliased in another file. *) +module Applied_app_cross_alias = + Shared_signature_arg.Use_o + (Cross_alias.Mk_cross_alias (Shared_signature_arg.Chosen)) + +let run_alias_app () = ignore (Applied_app_cross_alias.run ()) diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 5777d3fd..6eff4b52 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -41,4 +41,9 @@ let () = Shared_signature_arg.run_ord (); Shared_signature_arg.run_ord2 (); Shared_signature_arg.run_ranges (); - Shared_signature_arg.run_constrained () + Shared_signature_arg.run_constrained (); + Shared_signature_arg.run_unit (); + Shared_signature_arg.run_app (); + Cross_alias_use.run_unit (); + Shared_signature_arg.run_app2 (); + Cross_alias_use.run_alias_app () diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml index 32f77d70..ea7947ac 100644 --- a/examples/regression/src/Shared_signature_arg.ml +++ b/examples/regression/src/Shared_signature_arg.ml @@ -859,3 +859,178 @@ let run_letc () = A.run () let run_constrained () = ignore (Applied_recc.run () + run_letc ()) + +(* Generative functors: a unit application in an application chain, first, + in the middle, last, partially applied, in a recursive binding and in a + let-module. [Opt_unit_none] is never applied and keeps its never-used + argument. *) +module Opt_unit_first : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_unit_mid : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_unit_last : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_unit_partial : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_unit_end : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_unit_rec : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_unit_let : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_unit_none : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module F_unit () (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Applied_unit = F_unit () (Opt_unit_first) + +module F_unit_mid (M : Shared_signature.O) () (N : Shared_signature.O) = struct + let run () = M.g ~x:1 () + N.g ~x:1 () +end + +module Applied_unit_mid = F_unit_mid (Opt_unit_mid) () (Opt_unit_last) +module F_unit_partial = F_unit () +module Applied_unit_partial = F_unit_partial (Opt_unit_partial) + +module F_unit_end (M : Shared_signature.O) () = struct + let run () = M.g ~x:1 () +end + +module Applied_unit_end = F_unit_end (Opt_unit_end) () +module rec G_u : Opt_functor = F_unit () +module Applied_unit_rec = G_u (Opt_unit_rec) + +let run_unit_let () = + let module A = F_unit () (Opt_unit_let) in + A.run () + +let run_unit () = + ignore + (Applied_unit.run () + Applied_unit_mid.run () + + Applied_unit_partial.run () + Applied_unit_end.run () + + Applied_unit_rec.run () + run_unit_let () + Opt_unit_none.g ()) + +(* Arguments that are themselves applications: the result shape of the inner + application locates the values in the applied functor's body. Directly, + under a constraint, curried, nested, generative, through an alias of the + functor, and with a parameter as the inner argument. [Mk_o_none] is + applied but its result is never passed on. *) +module Mk_s (A : Shared_signature.S) : Shared_signature.S = struct + let f () = A.f () + 1 +end + +module Mk_o (A : Shared_signature.S) : Shared_signature.O = struct + let g ?(x = 0) () = x + A.f () +end + +module Mk_o_c (A : Shared_signature.S) : Shared_signature.O = struct + let g ?(x = 0) () = x + A.f () +end + +module Mk_o2 (A : Shared_signature.S) (B : Shared_signature.S) : + Shared_signature.O = struct + let g ?(x = 0) () = x + A.f () + B.f () +end + +module Mk_o_n (A : Shared_signature.S) : Shared_signature.O = struct + let g ?(x = 0) () = x + A.f () +end + +module Mk_o_unit () : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Mk_o_a (A : Shared_signature.S) : Shared_signature.O = struct + let g ?(x = 0) () = x + A.f () +end + +module Mk_o_p (A : Shared_signature.S) : Shared_signature.O = struct + let g ?(x = 0) () = x + A.f () +end + +module Mk_o_none (A : Shared_signature.S) : Shared_signature.O = struct + let g ?(x = 0) () = x + A.f () +end + +module Mk_alias = Mk_o_a + +module Use_o (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Applied_appl = Use_o (Mk_o (Chosen)) +module Applied_app_c = Use_o ((Mk_o_c (Chosen) : Shared_signature.O)) +module Applied_app2 = Use_o (Mk_o2 (Chosen) (Chosen)) +module Applied_app_n = Use_o (Mk_o_n (Mk_s (Chosen))) +module Applied_app_unit = Use_o (Mk_o_unit ()) +module Applied_app_alias = Use_o (Mk_alias (Chosen)) + +module Via_param (P : Shared_signature.S) = struct + module A = Use_o (Mk_o_p (P)) + + let run () = A.run () +end + +module Applied_via_param = Via_param (Chosen) +module Applied_none = Mk_o_none (Chosen) + +module Applied_app_inline = + Use_o + ((functor (A : Shared_signature.S) -> + (struct + let g ?(x = 0) () = x + A.f () + end : Shared_signature.O)) + (Chosen)) + +let run_app () = + ignore + (Applied_appl.run () + Applied_app_c.run () + Applied_app2.run () + + Applied_app_n.run () + Applied_app_unit.run () + + Applied_app_alias.run () + Applied_via_param.run () + + Applied_none.g () + Applied_app_inline.run ()) + +(* A constrained inline structure as argument, and an applied functor that + re-exports its argument. [Fwd_unused] is never passed and stays dead. *) +module Fwd_used : Shared_signature.S = struct + let f () = 60 +end + +module Fwd_unused : Shared_signature.S = struct + let f () = 61 +end + +module Mk_fwd (A : Shared_signature.S) : Shared_signature.S = struct + include A +end + +module Use_s (M : Shared_signature.S) = struct + let run () = M.f () +end + +module Applied_fwd = Use_s (Mk_fwd (Fwd_used)) + +module Applied_struct = + Use_o + ((struct + let g ?(x = 0) () = x + end : Shared_signature.O)) + +let run_app2 () = ignore (Applied_fwd.run () + Applied_struct.run ()) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index ecbc1545..0d4d5f2f 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -131,6 +131,12 @@ function runRegressionTests() { ); // Arguments wrapped in a constraint by a named module type are still used. assertIncludes(output, "Live Value +Shared_signature_arg.Chosen2.+f"); + // Arguments of generative functors and applied arguments are used. + assertIncludes(output, "Live Value +Shared_signature_arg.Opt_unit_first.+g"); + assertIncludes(output, "Live Value +Shared_signature_arg.Opt_unit_last.+g"); + assertIncludes(output, "Live Value +Shared_signature_arg.Mk_o.+g"); + assertIncludes(output, "Live Value +Shared_signature_arg.Fwd_used.+f"); + assertIncludes(output, "Live Value +Shared_signature_arg.Applied_struct.+g"); assertNotIncludes(output, "Dead Value +Shared_signature_arg.Chosen2.+f"); assertNotIncludes(output, "Dead Value +Shared_signature_arg.Opt_constrained.+g"); // Precise attribution through a shared named module type relies on shape @@ -368,6 +374,62 @@ function runRegressionTests() { "optional argument x of function Opt_inline.+g is always supplied" ); assertIncludes(output, "Dead Value +Shared_signature_arg.Ignored2.+f"); + // Generative functors: a unit application first, in the middle, last, in + // a partial application, a recursive binding, a let module, and bound in + // another file. An implementation never applied keeps its unused argument. + for (const name of [ + "Opt_unit_first", + "Opt_unit_mid", + "Opt_unit_last", + "Opt_unit_partial", + "Opt_unit_end", + "Opt_unit_rec", + "Opt_unit_let", + "Opt_cross_unit", + "Opt_cross_unit2", + ]) { + assertIncludes( + output, + `optional argument x of function ${name}.+g is always supplied (1 calls)` + ); + } + assertIncludes( + output, + "optional argument x of function Opt_unit_none.+g is never used" + ); + // Arguments that are themselves applications: directly, constrained, + // curried, nested, generative, through an alias of the functor, with a + // parameter as the inner argument, of an inline functor, bound in another + // file, and a constrained inline structure. The calls are credited to the + // applied functor's body only. + for (const name of [ + "Mk_o", + "Mk_o_c", + "Mk_o2", + "Mk_o_n", + "Mk_o_unit", + "Mk_o_a", + "Mk_o_p", + "Applied_app_inline", + "Applied_struct", + ]) { + assertIncludes( + output, + `optional argument x of function ${name}.+g is always supplied (1 calls)` + ); + } + assertIncludes( + output, + "optional argument x of function Mk_cross.+g is always supplied (2 calls)" + ); + assertIncludes( + output, + "optional argument x of function Mk_o_none.+g is never used" + ); + // An applied functor re-exporting its argument: the argument's value is + // used, another implementation of the module type stays dead. + assertIncludes(output, "Live Value +Shared_signature_arg.Fwd_used.+f"); + assertIncludes(output, "Dead Value +Shared_signature_arg.Fwd_unused.+f"); } assertNotIncludes(output, "Parent is a dead module"); diff --git a/src/Compat.ml b/src/Compat.ml index fda96121..ebc9772c 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -655,6 +655,37 @@ let shapeResolutionAvailable = false #endif +(* The shape of a functor application, as the compiler computes it for + [Tmod_apply]: reducing a projection of it lands in the functor's body, or + in the argument for items the body re-exports. *) +let applyShape (functorShape : moduleShape) (argumentShape : moduleShape) : + moduleShape = +#if OCAML_VERSION >= (5, 3, 0) + Shape.app functorShape ~arg:argumentShape +#else + ignore functorShape; + argumentShape +#endif + +(* The shape standing for a functor parameter inside an application + ([Use (Make (P))] in the body of [functor (P : S) -> ...]): an empty + structure, so that a projection lands in [Make]'s body for the items it + defines and stays unresolved for those it takes from [P]. *) +let parameterShape : moduleShape = +#if OCAML_VERSION >= (5, 3, 0) + Shape.dummy_mod +#else + () +#endif + +(* The shape of a generative application [F ()] ([Tmod_apply_unit]). *) +let applyUnitShape (functorShape : moduleShape) : moduleShape = +#if OCAML_VERSION >= (5, 3, 0) + Shape.app functorShape ~arg:Shape.dummy_mod +#else + functorShape +#endif + #if OCAML_VERSION >= (5, 3, 0) (* Resolvers of other units, by .cmt path, for chasing definitions bound there (aliases and partial applications of functors). *) @@ -828,25 +859,39 @@ let rec makeResolver ~cmtFilePath | Some (_, definition, resolver, applied) -> ( (* Peel the applied functor layers, then find the member, the last binding of that name (also through [include]s). *) - let rec memberIn (e : Typedtree.module_expr) applied = + let rec memberIn ~visited ~resolver (e : Typedtree.module_expr) + applied = + if List.memq e visited then None + else + let visited = e :: visited in + let lookup = + match resolver with + | Some (r : identResolutions) -> r.bindingOfPath + | None -> bindingOfPath + in match e.mod_desc with - | Tmod_constraint (inner, _, _, _) -> memberIn inner applied + | Tmod_constraint (inner, _, _, _) -> + memberIn ~visited ~resolver inner applied | Tmod_functor (_, inner) when applied > 0 -> - memberIn inner (applied - 1) + memberIn ~visited ~resolver inner (applied - 1) | Tmod_apply (functorExpr, _, _) -> - memberIn functorExpr (applied + 1) + memberIn ~visited ~resolver functorExpr (applied + 1) + | Tmod_apply_unit functorExpr -> + memberIn ~visited ~resolver functorExpr (applied + 1) | Tmod_ident (p, _) when applied = 0 -> ( (* [include Helpers] in a body: [Helpers] is local to the unit defining the body, so its resolver must look it up. *) - let lookup = - match resolver with - | Some (r : identResolutions) -> r.bindingOfPath - | None -> bindingOfPath - in match lookup (Pdot (p, name)) with | Some (loc, expr, memberResolver, 0) -> Some (loc, expr, memberResolver) | _ -> None) + | Tmod_ident (p, _) -> ( + (* An applied functor named by a path ([include Mid (A)] in a + body): its own definition, with the layers it consumed. *) + match lookup p with + | Some (_, definition, resolver, applied') -> + memberIn ~visited ~resolver definition (applied + applied') + | None -> None) | Tmod_structure structure when applied = 0 -> structure.str_items |> List.fold_left @@ -866,14 +911,14 @@ let rec makeResolver ~cmtFilePath Some (mb.mb_name.loc, mb.mb_expr, resolver) | None -> acc) | Tstr_include {incl_mod} -> ( - match memberIn incl_mod 0 with + match memberIn ~visited ~resolver incl_mod 0 with | Some member -> Some member | None -> acc) | _ -> acc) None | _ -> None in - match memberIn definition applied with + match memberIn ~visited:[] ~resolver definition applied with | Some (loc, expr, memberResolver) -> Some (loc, expr, memberResolver, 0) | None -> None) @@ -964,7 +1009,7 @@ let rec makeResolver ~cmtFilePath if loc.loc_ghost then None else match (unwrap definition).mod_desc with - | Tmod_apply _ | Tmod_ident _ -> ( + | Tmod_apply _ | Tmod_apply_unit _ | Tmod_ident _ -> ( match resolver with | Some (resolver : identResolutions) -> ( match resolver.headKey visited definition with @@ -975,7 +1020,7 @@ let rec makeResolver ~cmtFilePath in let rec headKey (visited : headVisited) (e : Typedtree.module_expr) = match e.mod_desc with - | Tmod_apply (functorExpr, _, _) -> ( + | Tmod_apply (functorExpr, _, _) | Tmod_apply_unit functorExpr -> ( match headKey visited functorExpr with | Some (loc, consumed) -> Some (loc, consumed + 1) | None -> None) @@ -1048,15 +1093,18 @@ let rec makeResolver ~cmtFilePath in (* [module type S] in the body of a functor the path applies, as in [Outer (A).S]: found structurally, whatever the argument. *) - let rec moduleTypeInBody ~resolver (e : Typedtree.module_expr) applied - name = + let rec moduleTypeInBody ~visited ~resolver + (e : Typedtree.module_expr) applied name = + if List.memq e visited then None + else + let visited = e :: visited in match e.mod_desc with | Tmod_constraint (inner, _, _, _) -> - moduleTypeInBody ~resolver inner applied name + moduleTypeInBody ~visited ~resolver inner applied name | Tmod_functor (_, inner) when applied > 0 -> - moduleTypeInBody ~resolver inner (applied - 1) name - | Tmod_apply (functorExpr, _, _) -> - moduleTypeInBody ~resolver functorExpr (applied + 1) name + moduleTypeInBody ~visited ~resolver inner (applied - 1) name + | Tmod_apply (functorExpr, _, _) | Tmod_apply_unit functorExpr -> + moduleTypeInBody ~visited ~resolver functorExpr (applied + 1) name | Tmod_ident (p, _) -> ( (* An aliased member ([module Alias = Holder]) or an applied one: follow it in the unit defining the body. *) @@ -1067,7 +1115,8 @@ let rec makeResolver ~cmtFilePath else match r.bindingOfPath p with | Some (_, definition, resolver, applied') -> - moduleTypeInBody ~resolver definition (applied + applied') name + moduleTypeInBody ~visited ~resolver definition + (applied + applied') name | None -> None) | Tmod_structure structure when applied = 0 -> structure.str_items @@ -1078,7 +1127,9 @@ let rec makeResolver ~cmtFilePath when mtd_name.txt = name -> Some mty_type | Tstr_include {incl_mod} -> ( - match moduleTypeInBody ~resolver incl_mod 0 name with + match + moduleTypeInBody ~visited ~resolver incl_mod 0 name + with | Some mt -> Some mt | None -> acc) | _ -> acc) @@ -1089,7 +1140,7 @@ let rec makeResolver ~cmtFilePath | Pdot (p, name) when hasApply p -> ( match bindingOfPath p with | Some (_, definition, resolver, applied) -> - moduleTypeInBody ~resolver definition applied name + moduleTypeInBody ~visited:[] ~resolver definition applied name | None -> None) | Pdot (p, name) -> ( match moduleShapeOfPath p with diff --git a/src/DeadValue.ml b/src/DeadValue.ml index dc3a5ec2..76235536 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -365,6 +365,30 @@ let addValueReferenceOrRedirect ~(locFrom : Location.t) ~(locTo : Location.t) nonForwardableReferences := PosPairSet.remove pair !nonForwardableReferences); addRedirect ~locFrom ~locTo ~locToImpl +(* The shape of a module expression used as a functor argument: a module + path's, or that of an application ([Use (Make (A))]), built from the + functor's and the argument's as the compiler does. *) +let rec moduleShapeOfExpr (moduleExpr : Typedtree.module_expr) = + match moduleExpr.mod_desc with + | Tmod_ident (path, _) + when Compat.shapeResolutionAvailable && isFunctorParameterPath path -> + Some Compat.parameterShape + | Tmod_ident (path, lid) -> + !identResolutions.moduleShape lid.loc (Path.last path) + | Tmod_constraint (inner, _, _, _) -> moduleShapeOfExpr inner + | Tmod_apply (functorExpr, argumentExpr, _) -> ( + match (moduleShapeOfExpr functorExpr, moduleShapeOfExpr argumentExpr) with + | Some functorShape, Some argumentShape -> + Some (Compat.applyShape functorShape argumentShape) + | _ -> None) +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit functorExpr -> ( + match moduleShapeOfExpr functorExpr with + | Some functorShape -> Some (Compat.applyUnitShape functorShape) + | None -> None) +#endif + | _ -> None + (* The key of the functor a module expression denotes, and the number of arguments already consumed by partial applications it stands for, as in [module G = F (A)] followed by [G (B)]. Aliases ([module G = F]) are @@ -375,6 +399,13 @@ let rec functorKeyOfHead (e : Typedtree.module_expr) = match functorKeyOfHead functorExpr with | Some (key, consumed) -> Some (key, consumed + 1) | None -> None) +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit functorExpr -> ( + (* [F ()]: the unit parameter occupies an index. *) + match functorKeyOfHead functorExpr with + | Some (key, consumed) -> Some (key, consumed + 1) + | None -> None) +#endif | Tmod_constraint (inner, _, _, _) -> functorKeyOfHead inner | Tmod_functor _ -> (* Inline functor: keyed by its own position, see [functorKeys]. *) @@ -657,6 +688,25 @@ and moduleTypeViaParameter ~visited (path : Path.t) = let expandedSignature (moduleType : Types.module_type) = moduleType |> expandModuleType |> getSignature +(* The location of a value in a module type, by path of names. *) +let rec findValueInModuleType (moduleType : Types.module_type) components = + let signature = moduleType |> expandedSignature in + match components with + | [] -> None + | [name] -> ( + match signature |> findSignatureItem name with + | Some (Types.Sig_value _ as item) -> + let _id, loc, _kind, _valType = item |> Compat.getSigValue in + if loc.loc_ghost then None else Some loc + | _ -> None) + | m :: rest -> ( + match signature |> findSignatureItem m with + | Some (Types.Sig_module _ as item) -> ( + match item |> Compat.getSigModuleModtype with + | Some (_id, moduleType, _loc) -> findValueInModuleType moduleType rest + | None -> None) + | _ -> None) + let rec iterAllModuleValues ~path (moduleType : Types.module_type) f = moduleType |> expandedSignature |> List.iter (fun (signatureItem : Types.signature_item) -> @@ -700,7 +750,8 @@ let rec iterCoercedValues ~path ~coercion ~actualType f = (* Reference the values a functor argument's coercion uses. [shape], when known, is the argument module's shape: items are then redirected to their implementation rather than to a shared module type item. *) -let addCoercedModuleValueReferences ~locFrom ~coercion ?shape ~actualType () = +let addCoercedModuleValueReferences ~locFrom ~coercion ?shape ?concrete + ~actualType () = (match (expandedSignature actualType, shape) with | [], Some shape -> (* The argument's signature could not be expanded (a module type this @@ -728,6 +779,12 @@ let addCoercedModuleValueReferences ~locFrom ~coercion ?shape ~actualType () = | Some shape -> resolutions.projValue shape (Ident.name id) | None -> None in + let locToImpl = + match (locToImpl, concrete) with + | None, Some concrete -> + findValueInModuleType concrete (path @ [Ident.name id]) + | _ -> locToImpl + in addRedirect ~locFrom ~locTo ~locToImpl) (* Same, when the argument is a functor parameter: deferred to the arguments @@ -851,22 +908,45 @@ let rec argumentModuleType (argumentExpr : Typedtree.module_expr) = | Tmod_constraint (inner, _, _, _), Mty_ident _ -> argumentModuleType inner | _ -> expand argumentExpr.mod_type -(* When a constrained argument's module type cannot be expanded (its unit is - outside the analysis root), the type of the module under the constraints - is the fallback: it is concrete, so it exposes items. The coercion - computed against the constraint does not apply to it, so callers - reference all of its values. *) -let concreteArgumentType (argumentExpr : Typedtree.module_expr) = - let rec innermost (e : Typedtree.module_expr) = +(* A more concrete type of an argument than its own, when the expression + shows one: the type of the module under [( _ : S )] constraints, and for an + application of an inline functor, the type of the functor's body. Its + items are the same runtime fields as the argument's, so a value the + argument's signature only names (a shared module type item) is found there + by name; when the argument's own type cannot be expanded at all (a module + type outside the analysis root), callers reference all of its values. *) +let rec concreteArgumentType (argumentExpr : Typedtree.module_expr) = + (* The body of an inline functor at the head of an application chain. *) + let rec appliedBody (e : Typedtree.module_expr) applied = match e.mod_desc with - | Tmod_constraint (inner, _, _, _) -> innermost inner - | _ -> e + | Tmod_constraint (inner, _, _, _) -> appliedBody inner applied + | Tmod_apply (functorExpr, _, _) -> appliedBody functorExpr (applied + 1) +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit functorExpr -> appliedBody functorExpr (applied + 1) +#endif + | Tmod_functor (_, body) when applied > 0 -> appliedBody body (applied - 1) + | Tmod_functor _ | Tmod_ident _ -> None + | _ when applied = 0 -> Some e + | _ -> None in - let inner = innermost argumentExpr in - if inner == argumentExpr then None - else - let moduleType = expandModuleType inner.mod_type in - match getSignature moduleType with [] -> None | _ -> Some moduleType + let concrete (inner : Typedtree.module_expr) = + match concreteArgumentType inner with + | Some moduleType -> Some moduleType + | None -> ( + let moduleType = expandModuleType inner.mod_type in + match getSignature moduleType with [] -> None | _ -> Some moduleType) + in + match argumentExpr.mod_desc with + | Tmod_constraint (inner, _, _, _) -> concrete inner + | Tmod_apply _ +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit _ +#endif + -> ( + match appliedBody argumentExpr 0 with + | Some body -> concrete body + | None -> None) + | _ -> None (* Implementation of a value of an actual functor argument, by path. *) let argumentItemResolver (argumentExpr : Typedtree.module_expr) = @@ -878,11 +958,7 @@ let argumentItemResolver (argumentExpr : Typedtree.module_expr) = ViaParameter (p.functorDef, p.paramIndex, p.prefix @ components) | _ -> Direct (fun _ -> None)) | _ -> - let shape = - match moduleIdent argumentExpr with - | Some (path, lid) -> !identResolutions.moduleShape lid.loc (Path.last path) - | None -> None - in + let shape = moduleShapeOfExpr argumentExpr in let resolutions = !identResolutions in let rec viaShape shape components = match components with @@ -893,38 +969,30 @@ let argumentItemResolver (argumentExpr : Typedtree.module_expr) = | Some shape -> viaShape shape rest | None -> None) in - let rec viaSignature (moduleType : Types.module_type) components = - let signature = moduleType |> expandedSignature in - match components with - | [] -> None - | [name] -> ( - match signature |> findSignatureItem name with - | Some (Types.Sig_value _ as item) -> - let _id, loc, _kind, _valType = item |> Compat.getSigValue in - if loc.loc_ghost then None else Some loc - | _ -> None) - | m :: rest -> ( - match signature |> findSignatureItem m with - | Some (Types.Sig_module _ as item) -> ( - match item |> Compat.getSigModuleModtype with - | Some (_id, moduleType, _loc) -> viaSignature moduleType rest - | None -> None) - | _ -> None) - in - let moduleType = - let declared = argumentModuleType argumentExpr in - match (expandedSignature declared, concreteArgumentType argumentExpr) with - | [], Some concrete -> concrete - | _ -> declared + let declared = argumentModuleType argumentExpr in + let concrete = concreteArgumentType argumentExpr in + (* By shape, then by name in the concrete type, then in the declared + one (a shared module type item, forwarded to its implementations). *) + let firstSome resolvers components = + resolvers + |> List.fold_left + (fun acc resolve -> + match acc with Some _ -> acc | None -> resolve components) + None in Direct - (fun components -> - match shape with - | Some shape -> ( - match viaShape shape components with - | Some loc -> Some loc - | None -> viaSignature moduleType components) - | None -> viaSignature moduleType components) + (firstSome + [ + (fun components -> + match shape with + | Some shape -> viaShape shape components + | None -> None); + (fun components -> + match concrete with + | Some concrete -> findValueInModuleType concrete components + | None -> None); + findValueInModuleType declared; + ]) (* Applications already recorded as part of an outer curried application, by node identity (a ppx may emit distinct applications at one position). *) @@ -935,12 +1003,18 @@ let recordedApplications : Typedtree.module_expr list ref = ref [] parameter to the corresponding argument. *) let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = if not (List.memq moduleExpr !recordedApplications) then - (* The arguments of this application chain, and its head. *) + (* The arguments of this application chain, in order, and its head. A + unit application ([F ()]) consumes an index without an argument. *) let rec flatten (e : Typedtree.module_expr) args = match e.mod_desc with | Tmod_apply (functorExpr, argumentExpr, _) -> recordedApplications := e :: !recordedApplications; - flatten functorExpr (argumentExpr :: args) + flatten functorExpr (Some argumentExpr :: args) +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit functorExpr -> + recordedApplications := e :: !recordedApplications; + flatten functorExpr (None :: args) +#endif | Tmod_constraint (inner, _, _, _) -> flatten inner args | _ -> (e, args) in @@ -958,13 +1032,16 @@ let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = | Some (key, consumed) -> args |> List.iteri (fun i argumentExpr -> - delayedApplications := - { - appliedFunctor = key; - argIndex = consumed + i; - resolver = argumentItemResolver argumentExpr; - } - :: !delayedApplications) + match argumentExpr with + | Some argumentExpr -> + delayedApplications := + { + appliedFunctor = key; + argIndex = consumed + i; + resolver = argumentItemResolver argumentExpr; + } + :: !delayedApplications + | None -> ()) | None -> () (* Traverse the AST *) @@ -1022,12 +1099,7 @@ let traverseStructure ~doTypes ~doExternals = module path, its shape lets the references target that module's implementation rather than a shared module type item. *) let ident = moduleIdent argumentExpr in - let shape = - match ident with - | Some (path, lid) -> - !identResolutions.moduleShape lid.loc (Path.last path) - | None -> None - in + let shape = moduleShapeOfExpr argumentExpr in (* A constraint node [(M : S)] can carry a ghost location, which would drop the references: use the module path's own location then. *) let locFrom = @@ -1036,13 +1108,13 @@ let traverseStructure ~doTypes ~doExternals = | _ when not argumentExpr.mod_loc.loc_ghost -> argumentExpr.mod_loc | _ -> moduleExpr.mod_loc in + let concrete = concreteArgumentType argumentExpr in let actualType, coercion = let declared = argumentModuleType argumentExpr in - match (expandedSignature declared, concreteArgumentType argumentExpr) with + match (expandedSignature declared, concrete) with | [], Some concrete -> (concrete, Typedtree.Tcoerce_none) | _ -> (declared, coercion) in - let actualType = actualType in if !Common.Cli.debug then Log_.item "functorArgument %s coercion:%s type:%s items:%d@." (argumentExpr.mod_loc.loc_start |> posToString) @@ -1072,9 +1144,12 @@ let traverseStructure ~doTypes ~doExternals = | Some (p, components) -> recordParameterCoercion ~locFrom ~coercion ~actualType p components | None -> - addCoercedModuleValueReferences ~locFrom ~coercion ?shape ~actualType - ()); + addCoercedModuleValueReferences ~locFrom ~coercion ?shape ?concrete + ~actualType ()); recordFunctorApplication moduleExpr +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit _ -> recordFunctorApplication moduleExpr +#endif | _ -> ()); let r = super.Tast_mapper.module_expr self moduleExpr in functorParameters := oldFunctorParameters; @@ -1128,7 +1203,12 @@ let traverseStructure ~doTypes ~doExternals = |> List.fold_left (fun changed (mb : Typedtree.module_binding) -> match (mb.mb_id, (unwrapConstraints mb.mb_expr).mod_desc) with - | Some id, (Tmod_apply _ | Tmod_ident _) -> ( + | ( Some id, + ( Tmod_apply _ | Tmod_ident _ +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit _ +#endif + ) ) -> ( match functorKeyOfHead mb.mb_expr with | Some key when List.assq_opt id !functorsByIdent <> Some key -> functorsByIdent := From cce0e6078a508e0af0c984c2a33b58d82d6ef2d8 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Fri, 4 Sep 2026 08:07:17 +0000 Subject: [PATCH 38/53] Address review: higher-order functors, first-class modules, unmatched keys A functor parameter applied in the body ([F (M)] in [Outer (F) (M)]) now records an application headed by the parameter, resolved once all files are scanned to the functors passed for it, through as many levels as needed, and paired with the arguments of the same enclosing application. Covered: the parameter applied to a parameter, a fixed module, a submodule of a parameter, through an alias, in an include, a partially applied functor argument, two levels, and the same functor applied twice. First-class modules bound with [let packed = (module M : S)] are resolved through a table filled where they are bound, as functors ([(val packed) (Arg)]) and as arguments, from any file. Other ways of obtaining one, and functors passed to applications whose head cannot be chased, mark the functor as escaping: its parameter calls are then forwarded to every implementation of the item rather than dropped. A functor never applied and not escaping credits nothing. An application of an inline functor whose body returns (a submodule of) a parameter, or applies a functor to it, resolves to the actual argument. The regression debug output now exceeds node's default buffer on older compilers; the runner raises it. --- examples/regression/src/Cross_alias.ml | 8 + examples/regression/src/Cross_alias_use.ml | 9 + examples/regression/src/Higher_order.ml | 258 +++++++ examples/regression/src/Main.ml | 6 +- examples/regression/src/dune | 1 + scripts/run_integration_tests.js | 54 ++ src/Compat.ml | 18 + src/DeadValue.ml | 798 +++++++++++++++++---- 8 files changed, 1024 insertions(+), 128 deletions(-) create mode 100644 examples/regression/src/Higher_order.ml diff --git a/examples/regression/src/Cross_alias.ml b/examples/regression/src/Cross_alias.ml index 47ce8017..ec43eade 100644 --- a/examples/regression/src/Cross_alias.ml +++ b/examples/regression/src/Cross_alias.ml @@ -18,3 +18,11 @@ module Mk_cross (A : Shared_signature.S) : Shared_signature.O = struct end module Mk_cross_alias = Mk_cross + +(* A functor packed as a first-class module, unpacked and applied from + another file. *) +module Impl_cross_fc (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +let packed_cross = (module Impl_cross_fc : Higher_order.Opt_functor) diff --git a/examples/regression/src/Cross_alias_use.ml b/examples/regression/src/Cross_alias_use.ml index 8e612e14..c7fb046b 100644 --- a/examples/regression/src/Cross_alias_use.ml +++ b/examples/regression/src/Cross_alias_use.ml @@ -57,3 +57,12 @@ module Applied_app_cross_alias = (Cross_alias.Mk_cross_alias (Shared_signature_arg.Chosen)) let run_alias_app () = ignore (Applied_app_cross_alias.run ()) + +module Opt_cross_fc : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Applied_cross_fc = + (val Cross_alias.packed_cross : Higher_order.Opt_functor) (Opt_cross_fc) + +let run_fc () = ignore (Applied_cross_fc.run ()) diff --git a/examples/regression/src/Higher_order.ml b/examples/regression/src/Higher_order.ml new file mode 100644 index 00000000..30c4f6c3 --- /dev/null +++ b/examples/regression/src/Higher_order.ml @@ -0,0 +1,258 @@ +(* Higher-order functors: a functor passed as an argument and applied inside + the body, to a parameter, to a fixed module, to a submodule of a + parameter, through an alias of the functor parameter, in an [include], + partially applied beforehand, through two levels, and first-class modules + as head and as argument. [Opt_none_ho] is called directly only and keeps + its never-used argument. *) +module type Opt_functor = functor (M : Shared_signature.O) -> sig + val run : unit -> int +end + +module Impl (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Impl_fixed (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Impl_sub (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Impl_alias (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Impl_incl (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Impl_partial (A : Shared_signature.S) (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () + A.f () +end + +module Impl_2 (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Impl_fc (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Impl_fca (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Impl_twice_a (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Impl_twice_b (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Opt_ho : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_fixed : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_sub_holder = struct + module Sub : Shared_signature.O = struct + let g ?(x = 0) () = x + end +end + +module Opt_alias_ho : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_incl_ho : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_partial_ho : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_2 : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_fc : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_fca : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_twice : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_none_ho : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Outer (F : Opt_functor) (M : Shared_signature.O) = struct + module A = F (M) + + let run () = A.run () +end + +module Applied_ho = Outer (Impl) (Opt_ho) + +module Outer_fixed (F : Opt_functor) = struct + module A = F (Opt_fixed) + + let run () = A.run () +end + +module Applied_fixed = Outer_fixed (Impl_fixed) + +module Outer_sub (F : Opt_functor) (H : sig + module Sub : Shared_signature.O +end) = +struct + module A = F (H.Sub) + + let run () = A.run () +end + +module Applied_sub = Outer_sub (Impl_sub) (Opt_sub_holder) + +module Outer_alias (F : Opt_functor) (M : Shared_signature.O) = struct + module G = F + module A = G (M) + + let run () = A.run () +end + +module Applied_alias = Outer_alias (Impl_alias) (Opt_alias_ho) + +module Outer_incl (F : Opt_functor) (M : Shared_signature.O) = struct + include F (M) +end + +module Applied_incl = Outer_incl (Impl_incl) (Opt_incl_ho) +module Applied_partial = Outer (Impl_partial (Shared_signature_arg.Chosen)) (Opt_partial_ho) + +module Outer2 (F : Opt_functor) (M : Shared_signature.O) = struct + module A = Outer (F) (M) + + let run () = A.run () +end + +module Applied_2 = Outer2 (Impl_2) (Opt_2) + +let impl_fc = (module Impl_fc : Opt_functor) + +module Applied_fc = (val impl_fc : Opt_functor) (Opt_fc) + +let opt_fca = (module Opt_fca : Shared_signature.O) + +module Applied_fca = Impl_fca ((val opt_fca : Shared_signature.O)) +module Applied_twice_a = Outer (Impl_twice_a) (Opt_twice) +module Applied_twice_b = Outer (Impl_twice_b) (Opt_twice) + +let run () = + ignore + (Applied_ho.run () + Applied_fixed.run () + Applied_sub.run () + + Applied_alias.run () + Applied_incl.run () + Applied_partial.run () + + Applied_2.run () + Applied_fc.run () + Applied_fca.run () + + Applied_twice_a.run () + Applied_twice_b.run () + Opt_none_ho.g ()) + +(* Inline functors returning their parameter, a submodule of it, or a + functor applied to it: the actual argument is what flows on. [Id_unused] + is never passed and stays dead; [Opt_id]'s call is credited to it only. *) +module Id_used : Shared_signature.S = struct + let f () = 70 +end + +module Id_sub_holder = struct + module Sub : Shared_signature.S = struct + let f () = 71 + end +end + +module Id_app : Shared_signature.S = struct + let f () = 72 +end + +module Id_curried : Shared_signature.S = struct + let f () = 73 +end + +module Id_unused : Shared_signature.S = struct + let f () = 74 +end + +module Opt_id : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Use_s (M : Shared_signature.S) = struct + let run () = M.f () +end + +module Applied_id = Use_s ((functor (A : Shared_signature.S) -> A) (Id_used)) + +module Applied_id_sub = + Use_s + ((functor (H : sig + module Sub : Shared_signature.S + end) -> H.Sub) + (Id_sub_holder)) + +module Applied_id_app = + Use_s + ((functor (A : Shared_signature.S) -> Shared_signature_arg.Mk_s (A)) + (Id_app)) + +module Applied_id_curried = + Use_s + ((functor (A : Shared_signature.S) (B : Shared_signature.S) -> B) + (Id_used) + (Id_curried)) + +module Applied_opt_id = + Shared_signature_arg.Use_o ((functor (A : Shared_signature.O) -> A) (Opt_id)) + +let run_id () = + ignore + (Applied_id.run () + Applied_id_sub.run () + Applied_id_app.run () + + Applied_id_curried.run () + Applied_opt_id.run ()) + +(* A functor escaping as a first-class module passed to a function: its + applications cannot be seen, so its calls are forwarded to every + implementation of the item, conservatively. [P_esc] must not be reported + as never supplying [y]. *) +module type P = sig + val h : ?y:int -> unit -> int +end + +module type P_functor = functor (M : P) -> sig + val run : unit -> int +end + +module Impl_esc (M : P) = struct + let run () = M.h ~y:1 () +end + +module P_esc : P = struct + let h ?(y = 0) () = y +end + +module P_other : P = struct + let h ?(y = 0) () = y +end + +let apply_packed (module F : P_functor) = + let module A = F (P_esc) in + A.run () + +let run_esc () = ignore (apply_packed (module Impl_esc) + P_other.h ()) diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 6eff4b52..b16b569d 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -46,4 +46,8 @@ let () = Shared_signature_arg.run_app (); Cross_alias_use.run_unit (); Shared_signature_arg.run_app2 (); - Cross_alias_use.run_alias_app () + Cross_alias_use.run_alias_app (); + Higher_order.run (); + Higher_order.run_id (); + Higher_order.run_esc (); + Cross_alias_use.run_fc () diff --git a/examples/regression/src/dune b/examples/regression/src/dune index ad0ff049..9593dfd3 100644 --- a/examples/regression/src/dune +++ b/examples/regression/src/dune @@ -7,6 +7,7 @@ Cross_include Functor_argument Generated_source + Higher_order Included_sig Live_ancestors Local_side_effects diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index 0d4d5f2f..f84eb0be 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -101,6 +101,9 @@ function runRegressionTests() { { cwd, encoding: "utf8", + // The debug output lists every reference; before OCaml 5.3 references + // through module type items fan out to every implementation. + maxBuffer: 256 * 1024 * 1024, } ); @@ -137,6 +140,10 @@ function runRegressionTests() { assertIncludes(output, "Live Value +Shared_signature_arg.Mk_o.+g"); assertIncludes(output, "Live Value +Shared_signature_arg.Fwd_used.+f"); assertIncludes(output, "Live Value +Shared_signature_arg.Applied_struct.+g"); + assertIncludes(output, "Live Value +Higher_order.Opt_ho.+g"); + assertIncludes(output, "Live Value +Higher_order.Opt_fc.+g"); + assertIncludes(output, "Live Value +Higher_order.P_esc.+h"); + assertIncludes(output, "Live Value +Higher_order.Id_used.+f"); assertNotIncludes(output, "Dead Value +Shared_signature_arg.Chosen2.+f"); assertNotIncludes(output, "Dead Value +Shared_signature_arg.Opt_constrained.+g"); // Precise attribution through a shared named module type relies on shape @@ -430,6 +437,53 @@ function runRegressionTests() { // used, another implementation of the module type stays dead. assertIncludes(output, "Live Value +Shared_signature_arg.Fwd_used.+f"); assertIncludes(output, "Dead Value +Shared_signature_arg.Fwd_unused.+f"); + // Higher-order functors: a functor passed as an argument and applied in + // the body, to a parameter, a fixed module, a submodule of a parameter, + // through an alias of the functor parameter, in an include, partially + // applied beforehand, through two levels; and first-class modules as + // head and as argument, in the same file and from another file. Each + // call is credited to the argument of the same application only. + for (const name of [ + "Opt_ho", + "Opt_fixed", + "Opt_sub_holder.Sub", + "Opt_alias_ho", + "Opt_incl_ho", + "Opt_partial_ho", + "Opt_2", + "Opt_fc", + "Opt_fca", + "Opt_cross_fc", + "Opt_id", + ]) { + assertIncludes( + output, + `optional argument x of function ${name}.+g is always supplied (1 calls)` + ); + } + assertIncludes( + output, + "optional argument x of function Opt_twice.+g is always supplied (2 calls)" + ); + assertIncludes( + output, + "optional argument x of function Opt_none_ho.+g is never used" + ); + // Inline functors returning (a submodule of) their parameter, or a + // functor applied to it: the argument flows on; an unrelated + // implementation stays dead. + assertIncludes(output, "Live Value +Higher_order.Id_used.+f"); + assertIncludes(output, "Live Value +Higher_order.Id_sub_holder.Sub.+f"); + assertIncludes(output, "Live Value +Higher_order.Id_app.+f"); + assertIncludes(output, "Live Value +Higher_order.Id_curried.+f"); + assertIncludes(output, "Dead Value +Higher_order.Id_unused.+f"); + // A functor escaping as a first-class module passed to a function: its + // calls are forwarded conservatively, never dropped. + assertIncludes( + output, + "optional argument y of function P_esc.+h is always supplied" + ); + assertNotIncludes(output, "P_esc.+h is never used"); } assertNotIncludes(output, "Parent is a dead module"); diff --git a/src/Compat.ml b/src/Compat.ml index ebc9772c..fc71822d 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -597,6 +597,9 @@ type identResolutions = { (Location.t * Typedtree.module_expr * identResolutions option * int) option; (** the binding a module path denotes, structurally, with the resolver of its unit and the number of functor layers the path applied *) + headKeyOfPath : Path.t -> (Location.t * int) option; + (** the binding name location of the functor a module path denotes, + found structurally, and the arguments consumed *) headKey : headVisited -> Typedtree.module_expr -> (Location.t * int) option; (** visited bindings (start with [noHeadVisited]), module expression -> @@ -621,6 +624,7 @@ let emptyIdentResolutions = moduleTypeOfPath = (fun _ -> None); shapeValueItems = (fun _ -> []); bindingOfPath = (fun _ -> None); + headKeyOfPath = (fun _ -> None); headKey = (fun _ _ -> None); expandModuleType = (fun mt -> mt); } @@ -807,6 +811,7 @@ let rec makeResolver ~cmtFilePath | None -> None in let selfRef = ref emptyIdentResolutions in + let headKeyOfPathRef = ref (fun (_ : Path.t) -> (None : (Location.t * int) option)) in let moduleTypeOfPathRef = ref (fun (_ : Path.t) -> (None : Types.module_type option)) in let bindingOfUid = moduleBindingOfUid ~currentCmtFile:cmtFilePath ~imports ~local @@ -995,6 +1000,7 @@ let rec makeResolver ~cmtFilePath in fun shape -> items [] shape []); bindingOfPath = (fun path -> bindingOfPath path); + headKeyOfPath = (fun path -> !headKeyOfPathRef path); headKey = (let rec unwrap (e : Typedtree.module_expr) = match e.mod_desc with @@ -1016,8 +1022,20 @@ let rec makeResolver ~cmtFilePath | Some head -> Some head | None -> Some (loc, 0)) | None -> Some (loc, 0)) + | Tmod_unpack _ -> + (* A first-class module: the functor it holds is not known + here. *) + None | _ -> Some (loc, 0) in + headKeyOfPathRef := + (fun path -> + match bindingOfPath path with + | Some (loc, definition, resolver, applied) -> ( + match keyOfBinding [] loc definition resolver with + | Some (loc, consumed) -> Some (loc, consumed + applied) + | None -> None) + | None -> None); let rec headKey (visited : headVisited) (e : Typedtree.module_expr) = match e.mod_desc with | Tmod_apply (functorExpr, _, _) | Tmod_apply_unit functorExpr -> ( diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 76235536..fcb90ce3 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -15,10 +15,14 @@ let checkAnyValueBindingWithNoSideEffects ~sideEffects:false | _ -> () +(* See [registerPackedModule], defined once its helpers are. *) +let registerPackedModuleRef = ref (fun (_ : Typedtree.value_binding) -> ()) + let collectValueBinding super self (vb : Typedtree.value_binding) = let oldCurrentBindings = !Current.bindings in let oldLastBinding = !Current.lastBinding in checkAnyValueBindingWithNoSideEffects vb; + !registerPackedModuleRef vb; let loc = match vb.vb_pat.pat_desc with #if OCAML_VERSION < (5, 2, 0) @@ -125,9 +129,16 @@ let isFunctorParameterPath path = findFunctorParameter path <> None parameter (e.g. ["g"] for [M.g], ["Sub"; "g"] for [M.Sub.g]). They are credited to the actual arguments at application sites, once all files are scanned. *) +type parameterCall = { + call : string list * string list; (** supplied, maybe supplied *) + callFrom : Location.t; + callTo : Location.t; (** the module type item *) + callToImpl : Location.t option; + callPath : Path.t; +} + let parameterCalls : - (Lexing.position * int * string list, (string list * string list) list) - Hashtbl.t = + (Lexing.position * int * string list, parameterCall list) Hashtbl.t = Hashtbl.create 16 type argumentResolver = @@ -137,30 +148,223 @@ type argumentResolver = (** the argument is (a submodule of) a parameter of the enclosing functor: resolved through that functor's own applications *) +(* The functor an application chain applies. *) +type functorHead = + | Key of Lexing.position * int + (** a functor's key, and the arguments partial applications already + consumed, as in [module G = F (A)] followed by [G (B)] *) + | ParamHead of Lexing.position * int * string list * int + (** (a submodule of) a parameter of the enclosing functor, applied in + its body: the functor's key, the parameter's index, the path within + the parameter, and the arguments already consumed. Which functors it + stands for is known once all applications are recorded. *) + | Packed of Lexing.position * int + (** a first-class module unpacked from a value, [(val packed : FT)]: + the position of the value's binding, and the arguments consumed. + Resolved once all files are scanned, through [packedModules]. *) + type delayedApplication = { - appliedFunctor : Lexing.position; + applicationId : int; + (** the application chain ([F (A) (B)]) the argument belongs to *) + appliedFunctor : functorHead; argIndex : int; + (** index of the parameter the argument is for; relative to the + functor a [ParamHead] resolves to *) resolver : argumentResolver; + argHead : string list -> functorHead option; + (** the functor (a submodule of) the argument denotes, when the + argument is passed on to a higher-order functor parameter *) + bindings : (Lexing.position * int) list; + (** for an application derived from a parameter-headed one ([F (M)] in + the body of [Outer (F) (M)]): the application of each enclosing + functor the head came through, by the functor's key. A parameter + of such a functor then resolves through that application only, + so that [M] pairs with the [F] of the same application. *) } let delayedApplications : delayedApplication list ref = ref [] +let nextApplicationId = ref 0 + +(* The applications of the functor keyed [functorDef] supplying its parameter + [argIndex], under [bindings]. *) +let applicationsOf ~bindings functorDef argIndex = + !delayedApplications + |> List.filter (fun {applicationId; appliedFunctor; argIndex = index} -> + appliedFunctor = Key (functorDef, 0) + && index = argIndex + && + match List.assoc_opt functorDef bindings with + | Some id -> id = applicationId + | None -> true) + +(* Functors whose applications cannot all be seen: packed as first-class + modules, or passed to an application whose head cannot be chased. Calls + through their parameters are forwarded to every implementation when no + application is known; a functor never applied nor escaping credits + nothing, as its calls never run. *) +let escapedHeads : functorHead list ref = ref [] + +let functorHeadToString head = + match head with + | Key (pos, consumed) -> Printf.sprintf "%s+%d" (pos |> posToString) consumed + | ParamHead (def, index, components, consumed) -> + Printf.sprintf "param(%s,%d,%s)+%d" (def |> posToString) index + (String.concat "." components) + consumed + | Packed (pos, consumed) -> + Printf.sprintf "packed(%s)+%d" (pos |> posToString) consumed + +(* [let packed = (module M : S)]: what the first-class value holds, by the + position of its binding, for [(val packed : S)] used as a functor or as an + argument, in any file. Computed where the value is bound, with that file's + resolver. Other ways to obtain a first-class module (function results, + patterns) are not chased: they stay conservative. *) +type packedModule = { + packedHead : functorHead option; + packedShape : Compat.moduleShape option; + packedConcrete : Types.module_type option; +} + +let packedModules : (Lexing.position, packedModule) Hashtbl.t = + Hashtbl.create 4 + +(* The binding a [(val e : S)] unpacks, when [e] names a value. *) +let unpackedBinding (e : Typedtree.expression) = + match e.exp_desc with + | Texp_ident (_, _, {val_loc}) -> Some val_loc.loc_start + | _ -> None (* Implementations of a value of the argument at [argIndex] of every - application of the functor keyed [functorDef]. *) -let rec resolveArgumentItems ~visited functorDef argIndex components = + application of the functor keyed [functorDef] (under [bindings]). *) +let rec resolveArgumentItems ~visited ~bindings functorDef argIndex components + = if List.mem (functorDef, argIndex) visited then [] else let visited = (functorDef, argIndex) :: visited in + applicationsOf ~bindings functorDef argIndex + |> List.concat_map (fun {resolver; bindings = own} -> + match resolver with + | Direct resolve -> ( + match resolve components with Some loc -> [loc] | None -> []) + | ViaParameter (outerDef, outerIndex, prefix) -> + resolveArgumentItems ~visited ~bindings:(own @ bindings) outerDef + outerIndex (prefix @ components)) + +(* Whether the functor keyed [functorDef] has an application supplying its + parameter [argIndex]. *) +let hasApplication functorDef argIndex = + applicationsOf ~bindings:[] functorDef argIndex <> [] + +(* The functors (a submodule of) the argument at [argIndex] of the + applications of [functorDef] denotes: their keys, the arguments they + consumed, and the applications they came through. *) +let rec resolveHeads ~visited ~bindings functorDef argIndex components = + if List.mem (functorDef, argIndex, components) visited then [] + else + let visited = (functorDef, argIndex, components) :: visited in + applicationsOf ~bindings functorDef argIndex + |> List.concat_map (fun {applicationId; argHead; bindings = own} -> + let here = ((functorDef, applicationId) :: own) @ bindings in + match argHead components with + | Some (Key (pos, consumed)) -> [(pos, consumed, here)] + | Some (ParamHead (def, index, prefix, consumed)) -> + resolveHeads ~visited ~bindings:here def index (prefix @ components) + |> List.map (fun (pos, consumed', bindings) -> + (pos, consumed + consumed', bindings)) + | Some (Packed (pos, consumed)) -> ( + match (Hashtbl.find_opt packedModules pos, components) with + | Some {packedHead = Some (Key (key, consumed'))}, [] -> + [(key, consumed + consumed', here)] + | ( Some {packedHead = Some (ParamHead (def, index, prefix, consumed'))}, + [] ) -> + resolveHeads ~visited ~bindings:here def index prefix + |> List.map (fun (pos, consumed'', bindings) -> + (pos, consumed + consumed' + consumed'', bindings)) + | _ -> []) + | None -> []) + +(* Applications headed by a functor parameter stand for the applications of + the functors passed for it. Resolved to a fixed point, as an argument may + itself come through a parameter; the ones left unresolved (the enclosing + functor is never applied, or applied to something not resolvable) are + dropped, and the calls they would credit fall back to forwarding. *) +let resolveParameterHeadedApplications () = + (* First-class modules, from the values they were packed into. *) + delayedApplications := !delayedApplications - |> List.concat_map (fun {appliedFunctor; argIndex = index; resolver} -> - if appliedFunctor <> functorDef || index <> argIndex then [] - else - match resolver with - | Direct resolve -> ( - match resolve components with Some loc -> [loc] | None -> []) - | ViaParameter (outerDef, outerIndex, prefix) -> - resolveArgumentItems ~visited outerDef outerIndex - (prefix @ components)) + |> List.map (fun application -> + match application.appliedFunctor with + | Packed (pos, consumed) -> ( + match Hashtbl.find_opt packedModules pos with + | Some {packedHead = Some (Key (key, consumed'))} -> + { + application with + appliedFunctor = Key (key, 0); + argIndex = application.argIndex + consumed + consumed'; + } + | Some {packedHead = Some (ParamHead (def, index, components, consumed'))} -> + { + application with + appliedFunctor = + ParamHead (def, index, components, consumed + consumed'); + } + | _ -> application) + | _ -> application); + let rec loop () = + let progress = ref false in + delayedApplications := + !delayedApplications + |> List.concat_map (fun application -> + match application.appliedFunctor with + | Key _ | Packed _ -> [application] + | ParamHead (def, index, components, consumed) -> ( + match + resolveHeads ~visited:[] ~bindings:application.bindings def + index components + with + | [] -> [application] + | heads -> + progress := true; + heads + |> List.map (fun (pos, consumed', bindings) -> + { + application with + appliedFunctor = Key (pos, 0); + argIndex = application.argIndex + consumed + consumed'; + bindings = bindings @ application.bindings; + }))); + if !progress then loop () + in + loop (); + !delayedApplications + |> List.iter (fun {appliedFunctor; argIndex; argHead} -> + match appliedFunctor with + | ParamHead _ | Packed _ -> ( + if !Common.Cli.debug then + Log_.item "unresolvedApplication %s index:%d@." + (functorHeadToString appliedFunctor) + argIndex; + match argHead [] with + | Some head -> escapedHeads := head :: !escapedHeads + | None -> ()) + | Key _ -> ()) + +(* The keys of the functors that escaped, see [escapedHeads]. *) +let escapedKeys () = + !escapedHeads + |> List.concat_map (fun head -> + match head with + | Key (pos, _) -> [pos] + | ParamHead (def, index, components, _) -> + resolveHeads ~visited:[] ~bindings:[] def index components + |> List.map (fun (pos, _, _) -> pos) + | Packed (pos, _) -> ( + match Hashtbl.find_opt packedModules pos with + | Some {packedHead = Some (Key (key, _))} -> [key] + | Some {packedHead = Some (ParamHead (def, index, components, _))} -> + resolveHeads ~visited:[] ~bindings:[] def index components + |> List.map (fun (pos, _, _) -> pos) + | _ -> [])) (* Coercion references made through a functor parameter, as in [module Outer (M : S) = Inner (M)]: credited to the arguments of the @@ -214,7 +418,15 @@ let findFunctorKey (moduleExpr : Typedtree.module_expr) = (* Functors that applications in the same file cannot find by uid, keyed by identifier: [let module] bindings (not registered as declarations before OCaml 5.5) and recursive modules (whose occurrences have no uid). *) -let functorsByIdent : (Ident.t * (Lexing.position * int)) list ref = ref [] +let functorsByIdent : (Ident.t * functorHead) list ref = ref [] + +(* Heads of module bindings of this file whose right-hand side applies or + aliases a functor parameter or a first-class module ([module G = F (A)] + in the body of [functor (F : FT) -> ...], [module G = (val packed)]), + by the position of the binding's name: the resolver of occurrences cannot + see through those. *) +let headsByBinding : (Lexing.position, functorHead) Hashtbl.t = + Hashtbl.create 4 let rec pathComponents (path : Path.t) = match path with @@ -297,12 +509,18 @@ let processOptionalArgs ~expType ~(locFrom : Location.t) ~locTo ?locToImpl | Some calls -> calls | None -> [] in - Hashtbl.replace parameterCalls key (call :: calls) + Hashtbl.replace parameterCalls key + ({call; callFrom = locFrom; callTo = locTo; callToImpl = locToImpl; + callPath = path} + :: calls) | _ -> ()); - call - |> DeadOptionalArgs.addReferences ~locFrom ~locTo ?locToImpl - ~forwardable:(parameter = None || not Compat.shapeResolutionAvailable) - ~path) + (* A call through a parameter is credited to the actual arguments once + all applications are known (see [forceDelayedItems]); without shape + resolution it can only be forwarded to every implementation. *) + if parameter = None || not Compat.shapeResolutionAvailable then + call + |> DeadOptionalArgs.addReferences ~locFrom ~locTo ?locToImpl + ~forwardable:true ~path) (* Implementation locations of identifier occurrences resolved through shapes. See [Compat.resolveIdentOccurrences]. *) @@ -365,66 +583,213 @@ let addValueReferenceOrRedirect ~(locFrom : Location.t) ~(locTo : Location.t) nonForwardableReferences := PosPairSet.remove pair !nonForwardableReferences); addRedirect ~locFrom ~locTo ~locToImpl +(* An application of an inline functor, [(functor (A : S) -> body) (X)]: + the body, with the parameters bound to the actual arguments ([None] for a + unit argument). Curried applications bind every layer. *) +let appliedInlineFunctor (moduleExpr : Typedtree.module_expr) = + let rec apply (e : Typedtree.module_expr) (args : Typedtree.module_expr option list) = + match e.mod_desc with + | Tmod_constraint (inner, _, _, _) -> apply inner args + | Tmod_apply (functorExpr, argumentExpr, _) -> + apply functorExpr (Some argumentExpr :: args) +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit functorExpr -> apply functorExpr (None :: args) +#endif + | Tmod_functor (param, body) -> ( + match args with + | [] -> None + | arg :: rest -> ( + let bound = + match (param, arg) with + | Named (Some id, _, _), Some argumentExpr -> [(id, argumentExpr)] + | _ -> [] + in + match rest with + | [] -> Some (body, bound) + | _ -> ( + match apply body rest with + | Some (innerBody, innerBound) -> Some (innerBody, bound @ innerBound) + | None -> None))) + | _ -> None + in + match moduleExpr.mod_desc with + | Tmod_apply _ -> apply moduleExpr [] +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit _ -> apply moduleExpr [] +#endif + | _ -> None + +(* The names after the head of a path, [["Sub"; "X"]] for [A.Sub.X]. *) +let rec pathTail (path : Path.t) = + match path with + | Pident _ -> Some [] + | Pdot (p, name) -> ( + match pathTail p with Some tail -> Some (tail @ [name]) | None -> None) + | _ -> None + (* The shape of a module expression used as a functor argument: a module - path's, or that of an application ([Use (Make (A))]), built from the - functor's and the argument's as the compiler does. *) -let rec moduleShapeOfExpr (moduleExpr : Typedtree.module_expr) = + path's, that of an application ([Use (Make (A))]) built from the functor's + and the argument's as the compiler does, or of a first-class module + unpacked from a value bound to a packed module (in a file scanned earlier; + the argument resolver looks it up again once every file is scanned). [env] + binds the parameters of inline functors being applied to their + arguments. *) +let rec moduleShapeOfExpr ?(env = []) (moduleExpr : Typedtree.module_expr) = match moduleExpr.mod_desc with - | Tmod_ident (path, _) - when Compat.shapeResolutionAvailable && isFunctorParameterPath path -> - Some Compat.parameterShape - | Tmod_ident (path, lid) -> - !identResolutions.moduleShape lid.loc (Path.last path) - | Tmod_constraint (inner, _, _, _) -> moduleShapeOfExpr inner + | Tmod_ident (path, lid) -> ( + let bound = + match Path.head path with + | head -> List.find_opt (fun (id, _) -> Ident.same id head) env + | exception _ -> None + in + match bound with + | Some (_, argumentExpr) -> ( + match (moduleShapeOfExpr ~env argumentExpr, pathTail path) with + | Some shape, Some tail -> + tail + |> List.fold_left + (fun shape name -> + match shape with + | Some shape -> !identResolutions.projModule shape name + | None -> None) + (Some shape) + | _ -> None) + | None -> + if Compat.shapeResolutionAvailable && isFunctorParameterPath path then + Some Compat.parameterShape + else !identResolutions.moduleShape lid.loc (Path.last path)) + | Tmod_constraint (inner, _, _, _) -> moduleShapeOfExpr ~env inner + | Tmod_unpack (packed, _) -> ( + match unpackedBinding packed with + | Some pos -> ( + match Hashtbl.find_opt packedModules pos with + | Some {packedShape} -> packedShape + | None -> None) + | None -> None) | Tmod_apply (functorExpr, argumentExpr, _) -> ( - match (moduleShapeOfExpr functorExpr, moduleShapeOfExpr argumentExpr) with - | Some functorShape, Some argumentShape -> - Some (Compat.applyShape functorShape argumentShape) - | _ -> None) + match appliedInlineFunctor moduleExpr with + | Some (body, bound) -> moduleShapeOfExpr ~env:(bound @ env) body + | None -> ( + match + (moduleShapeOfExpr ~env functorExpr, moduleShapeOfExpr ~env argumentExpr) + with + | Some functorShape, Some argumentShape -> + Some (Compat.applyShape functorShape argumentShape) + | _ -> None)) #if OCAML_VERSION >= (5, 1, 0) | Tmod_apply_unit functorExpr -> ( - match moduleShapeOfExpr functorExpr with - | Some functorShape -> Some (Compat.applyUnitShape functorShape) - | None -> None) + match appliedInlineFunctor moduleExpr with + | Some (body, bound) -> moduleShapeOfExpr ~env:(bound @ env) body + | None -> ( + match moduleShapeOfExpr ~env functorExpr with + | Some functorShape -> Some (Compat.applyUnitShape functorShape) + | None -> None)) #endif | _ -> None -(* The key of the functor a module expression denotes, and the number of - arguments already consumed by partial applications it stands for, as in +(* The functor a module expression applies, and the number of arguments + already consumed by partial applications it stands for, as in [module G = F (A)] followed by [G (B)]. Aliases ([module G = F]) are - chased within the current file. *) -let rec functorKeyOfHead (e : Typedtree.module_expr) = - match e.mod_desc with - | Tmod_apply (functorExpr, _, _) -> ( - match functorKeyOfHead functorExpr with - | Some (key, consumed) -> Some (key, consumed + 1) - | None -> None) + chased within the current file, and bindings in other files through the + resolver. A functor parameter ([F (M)] in [functor (F : FT) -> ...]) is + resolved once all applications are known. *) +let rec functorHeadOf (e : Typedtree.module_expr) : functorHead option = + let consume head = + match head with + | Some (Key (pos, consumed)) -> Some (Key (pos, consumed + 1)) + | Some (ParamHead (def, index, components, consumed)) -> + Some (ParamHead (def, index, components, consumed + 1)) + | Some (Packed (pos, consumed)) -> Some (Packed (pos, consumed + 1)) + | None -> None + in + match e.mod_desc with + | Tmod_apply (functorExpr, _, _) -> consume (functorHeadOf functorExpr) #if OCAML_VERSION >= (5, 1, 0) - | Tmod_apply_unit functorExpr -> ( - (* [F ()]: the unit parameter occupies an index. *) - match functorKeyOfHead functorExpr with - | Some (key, consumed) -> Some (key, consumed + 1) - | None -> None) + | Tmod_apply_unit functorExpr -> + (* [F ()]: the unit parameter occupies an index. *) + consume (functorHeadOf functorExpr) #endif - | Tmod_constraint (inner, _, _, _) -> functorKeyOfHead inner - | Tmod_functor _ -> - (* Inline functor: keyed by its own position, see [functorKeys]. *) - Some (e.mod_loc.loc_start, 0) - | Tmod_ident (path, _lid) -> ( - let byIdent () = - match - List.find_opt - (fun (id, _) -> Ident.same id (Path.head path)) - !functorsByIdent - with - | Some (_, key) -> Some key - | None -> None - | exception _ -> None - in - match !identResolutions.headKey Compat.noHeadVisited e with - | Some (nameLoc, consumed) -> Some (nameLoc.loc_start, consumed) - | None -> byIdent ()) + | Tmod_constraint (inner, _, _, _) -> functorHeadOf inner + | Tmod_functor _ -> + (* Inline functor: keyed by its own position, see [functorKeys]. *) + Some (Key (e.mod_loc.loc_start, 0)) + | Tmod_unpack (packed, _) -> ( + match unpackedBinding packed with + | Some pos -> Some (Packed (pos, 0)) + | None -> None) + | Tmod_ident (path, lid) -> headOfPath ~lid path [] + | _ -> None + +(* The head a module path denotes, extended by [components] ([Holder.F] for + the functor [F] of the argument [Holder]). *) +and headOfPath ?lid (path : Path.t) components : functorHead option = + let extended = + components |> List.fold_left (fun p name -> Path.Pdot (p, name)) path + in + let byParameter () = + match (findFunctorParameter path, pathComponents path) with + | Some p, Some pathComponents -> + Some + (ParamHead + (p.functorDef, p.paramIndex, p.prefix @ pathComponents @ components, 0)) + | _ -> None + in + let byBinding () = + match (lid, components) with + | Some (lid : Longident.t Location.loc), [] -> ( + match !identResolutions.moduleDefLoc lid.loc (Path.last path) with + | Some (loc : Location.t) -> Hashtbl.find_opt headsByBinding loc.loc_start + | None -> None) | _ -> None + in + let byIdent () = + match (path, components) with + | Pident id, [] -> ( + match List.find_opt (fun (id', _) -> Ident.same id' id) !functorsByIdent with + | Some (_, head) -> Some head + | None -> None) + | _ -> None + in + let byResolver () = + let key = + match (lid, components) with + | Some lid, [] -> + !identResolutions.headKey Compat.noHeadVisited + { + Typedtree.mod_desc = Tmod_ident (path, lid); + mod_loc = lid.loc; + mod_type = Types.Mty_signature []; + mod_env = Env.empty; + mod_attributes = []; + } + | _ -> !identResolutions.headKeyOfPath extended + in + match key with + | Some ((nameLoc : Location.t), consumed) -> + Some (Key (nameLoc.loc_start, consumed)) + | None -> None + in + let rec first = function + | [] -> None + | f :: rest -> ( + match f () with Some head -> Some head | None -> first rest) + in + first [byParameter; byBinding; byIdent; byResolver] + +(* Register the head a module binding stands for, when its right-hand side + is an alias, an application or an unpacking (see [headsByBinding]). *) +let registerBindingHead ~(namePos : Lexing.position) (id : Ident.t option) + (moduleExpr : Typedtree.module_expr) = + match (unwrapConstraints moduleExpr).mod_desc with + | Tmod_functor _ | Tmod_structure _ -> () + | _ -> ( + match functorHeadOf moduleExpr with + | Some head -> + Hashtbl.replace headsByBinding namePos head; + (match id with + | Some id -> functorsByIdent := (id, head) :: !functorsByIdent + | None -> ()) + | None -> ()) let rec collectExpr super self (e : Typedtree.expression) = let locFrom = e.exp_loc in @@ -436,8 +801,9 @@ let rec collectExpr super self (e : Typedtree.expression) = alias of a parameter must be registered here for uses in the body. The structure item handler registers it again, harmlessly. *) (match e.exp_desc with - | Texp_struct_item ({str_desc = Tstr_module {mb_id; mb_expr}}, _) -> - registerParameterAlias mb_id mb_expr + | Texp_struct_item ({str_desc = Tstr_module {mb_id; mb_expr; mb_name}}, _) -> + registerParameterAlias mb_id mb_expr; + registerBindingHead ~namePos:mb_name.loc.loc_start mb_id mb_expr | _ -> ()); #else (match e.exp_desc with @@ -450,17 +816,24 @@ let rec collectExpr super self (e : Typedtree.expression) = F's key, with the arguments already consumed. *) let key = match (unwrapConstraints moduleExpr).mod_desc with - | Tmod_functor _ -> (name.loc.loc_start, 0) + | Tmod_functor _ -> Key (name.loc.loc_start, 0) | _ -> ( - match functorKeyOfHead moduleExpr with + match functorHeadOf moduleExpr with | Some key -> key - | None -> (name.loc.loc_start, 0)) + | None -> Key (name.loc.loc_start, 0)) in functorsByIdent := (id, key) :: !functorsByIdent | None -> ()) | _ -> ()); #endif (match e.exp_desc with + | Texp_pack moduleExpr -> ( + (* A functor packed as a first-class module escapes, see [escapedHeads]. *) + match functorHeadOf moduleExpr with + | Some head -> escapedHeads := head :: !escapedHeads + | None -> ()) + | _ -> ()); + (match e.exp_desc with | Texp_ident (_path, _, {Types.val_loc = {loc_ghost = false; _} as locTo}) -> (* if Path.name _path = "rc" then assert false; *) @@ -908,46 +1281,104 @@ let rec argumentModuleType (argumentExpr : Typedtree.module_expr) = | Tmod_constraint (inner, _, _, _), Mty_ident _ -> argumentModuleType inner | _ -> expand argumentExpr.mod_type +(* The module type of a submodule of a module type, by path of names. *) +let rec findModuleInModuleType (moduleType : Types.module_type) components = + match components with + | [] -> Some moduleType + | m :: rest -> ( + match moduleType |> expandedSignature |> findSignatureItem m with + | Some (Types.Sig_module _ as item) -> ( + match item |> Compat.getSigModuleModtype with + | Some (_id, moduleType, _loc) -> findModuleInModuleType moduleType rest + | None -> None) + | _ -> None) + (* A more concrete type of an argument than its own, when the expression - shows one: the type of the module under [( _ : S )] constraints, and for an - application of an inline functor, the type of the functor's body. Its - items are the same runtime fields as the argument's, so a value the - argument's signature only names (a shared module type item) is found there - by name; when the argument's own type cannot be expanded at all (a module - type outside the analysis root), callers reference all of its values. *) -let rec concreteArgumentType (argumentExpr : Typedtree.module_expr) = - (* The body of an inline functor at the head of an application chain. *) - let rec appliedBody (e : Typedtree.module_expr) applied = - match e.mod_desc with - | Tmod_constraint (inner, _, _, _) -> appliedBody inner applied - | Tmod_apply (functorExpr, _, _) -> appliedBody functorExpr (applied + 1) -#if OCAML_VERSION >= (5, 1, 0) - | Tmod_apply_unit functorExpr -> appliedBody functorExpr (applied + 1) -#endif - | Tmod_functor (_, body) when applied > 0 -> appliedBody body (applied - 1) - | Tmod_functor _ | Tmod_ident _ -> None - | _ when applied = 0 -> Some e - | _ -> None + shows one: the type of the module under [( _ : S )] constraints, for an + application of an inline functor the type of the functor's body (with the + parameters standing for the actual arguments, as in + [(functor (A : S) -> A) (M)]), and for a first-class module the type of + the packed module. Its items are the same runtime fields as the + argument's, so a value the argument's signature only names (a shared module + type item) is found there by name; when the argument's own type cannot be + expanded at all (a module type outside the analysis root), callers + reference all of its values. *) +let rec concreteArgumentType ?(env = []) (argumentExpr : Typedtree.module_expr) + = + let ownType (e : Typedtree.module_expr) = + let moduleType = expandModuleType e.mod_type in + match getSignature moduleType with [] -> None | _ -> Some moduleType in - let concrete (inner : Typedtree.module_expr) = - match concreteArgumentType inner with + (* The concrete type of an expression, or its own when it exposes items. *) + let concrete (e : Typedtree.module_expr) = + match concreteArgumentType ~env e with | Some moduleType -> Some moduleType - | None -> ( - let moduleType = expandModuleType inner.mod_type in - match getSignature moduleType with [] -> None | _ -> Some moduleType) + | None -> ownType e in match argumentExpr.mod_desc with | Tmod_constraint (inner, _, _, _) -> concrete inner + | Tmod_ident (path, _) -> ( + let bound = + match Path.head path with + | head -> List.find_opt (fun (id, _) -> Ident.same id head) env + | exception _ -> None + in + match (bound, pathTail path) with + | Some (_, boundExpr), Some tail -> ( + match concrete boundExpr with + | Some moduleType -> findModuleInModuleType moduleType tail + | None -> None) + | _ -> None) + | Tmod_unpack (packed, _) -> ( + match unpackedBinding packed with + | Some pos -> ( + match Hashtbl.find_opt packedModules pos with + | Some {packedConcrete} -> packedConcrete + | None -> None) + | None -> None) | Tmod_apply _ #if OCAML_VERSION >= (5, 1, 0) | Tmod_apply_unit _ #endif -> ( - match appliedBody argumentExpr 0 with - | Some body -> concrete body + match appliedInlineFunctor argumentExpr with + | Some (body, bound) -> ( + let env = bound @ env in + match concreteArgumentType ~env body with + | Some moduleType -> Some moduleType + | None -> ownType body) | None -> None) | _ -> None +let registerPackedModule (vb : Typedtree.value_binding) = + let packed = + match vb.vb_expr.exp_desc with + | Texp_pack moduleExpr -> Some moduleExpr + | _ -> None + in + match (vb.vb_pat.pat_desc, packed) with +#if OCAML_VERSION < (5, 2, 0) + | Tpat_var (_, {loc}), Some moduleExpr -> +#else + | Tpat_var (_, {loc}, _), Some moduleExpr -> +#endif + let concrete = + match concreteArgumentType moduleExpr with + | Some moduleType -> Some moduleType + | None -> ( + let moduleType = expandModuleType moduleExpr.mod_type in + match getSignature moduleType with [] -> None | _ -> Some moduleType) + in + Hashtbl.replace packedModules loc.loc_start + { + packedHead = functorHeadOf moduleExpr; + packedShape = moduleShapeOfExpr moduleExpr; + packedConcrete = concrete; + } + | _ -> () + +let () = registerPackedModuleRef := registerPackedModule + (* Implementation of a value of an actual functor argument, by path. *) let argumentItemResolver (argumentExpr : Typedtree.module_expr) = match moduleIdent argumentExpr with @@ -958,7 +1389,16 @@ let argumentItemResolver (argumentExpr : Typedtree.module_expr) = ViaParameter (p.functorDef, p.paramIndex, p.prefix @ components) | _ -> Direct (fun _ -> None)) | _ -> - let shape = moduleShapeOfExpr argumentExpr in + (* A first-class module from a value: looked up when resolving, once every + file has registered its packed modules. *) + let packedPos = + match (unwrapConstraints argumentExpr).mod_desc with + | Tmod_unpack (packed, _) -> unpackedBinding packed + | _ -> None + in + let shape = + match packedPos with None -> moduleShapeOfExpr argumentExpr | Some _ -> None + in let resolutions = !identResolutions in let rec viaShape shape components = match components with @@ -970,7 +1410,24 @@ let argumentItemResolver (argumentExpr : Typedtree.module_expr) = | None -> None) in let declared = argumentModuleType argumentExpr in - let concrete = concreteArgumentType argumentExpr in + let concrete = + match packedPos with + | None -> concreteArgumentType argumentExpr + | Some _ -> None + in + let packed () = + match packedPos with + | Some pos -> Hashtbl.find_opt packedModules pos + | None -> None + in + let shape () = + match packed () with Some {packedShape} -> packedShape | None -> shape + in + let concrete () = + match packed () with + | Some {packedConcrete} -> packedConcrete + | None -> concrete + in (* By shape, then by name in the concrete type, then in the declared one (a shared module type item, forwarded to its implementations). *) let firstSome resolvers components = @@ -984,11 +1441,11 @@ let argumentItemResolver (argumentExpr : Typedtree.module_expr) = (firstSome [ (fun components -> - match shape with + match shape () with | Some shape -> viaShape shape components | None -> None); (fun components -> - match concrete with + match concrete () with | Some concrete -> findValueInModuleType concrete components | None -> None); findValueInModuleType declared; @@ -1019,30 +1476,86 @@ let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = | _ -> (e, args) in let head, args = flatten moduleExpr [] in - let key = functorKeyOfHead head in + let head = functorHeadOf head in if !Common.Cli.debug then Log_.item "functorApplication %s key:%s args:%d@." (moduleExpr.mod_loc.loc_start |> posToString) - (match key with - | Some (pos, consumed) -> - Printf.sprintf "%s+%d" (pos |> posToString) consumed + (match head with + | Some head -> functorHeadToString head | None -> "none") (List.length args); - match key with - | Some (key, consumed) -> + (* The functor (a submodule of) an argument denotes, for higher-order + parameters. Computed now: the resolver and the parameters in scope + are those of this file and this point of the traversal. *) + let argHead (argumentExpr : Typedtree.module_expr) = + let direct = functorHeadOf argumentExpr in + let resolutions = !identResolutions in + let ident = moduleIdent argumentExpr in + let parameter = + match ident with + | Some (path, _) -> ( + match (findFunctorParameter path, pathComponents path) with + | Some p, Some pathComponents -> Some (p, pathComponents) + | _ -> None) + | None -> None + in + fun components -> + match (components, parameter, ident) with + | [], _, _ -> direct + | _, Some (p, pathComponents), _ -> + Some + (ParamHead + ( p.functorDef, + p.paramIndex, + p.prefix @ pathComponents @ components, + 0 )) + | _, None, Some (path, _) -> ( + let extended = + components + |> List.fold_left (fun p name -> Path.Pdot (p, name)) path + in + match resolutions.headKeyOfPath extended with + | Some ((loc : Location.t), consumed) -> + Some (Key (loc.loc_start, consumed)) + | None -> None) + | _, None, None -> None + in + match head with + | None -> + (* The functors passed to an application whose head cannot be chased + (a first-class module from elsewhere) escape: their calls can only + be forwarded. *) + args + |> List.iter (fun argumentExpr -> + match argumentExpr with + | Some argumentExpr -> ( + match functorHeadOf argumentExpr with + | Some head -> escapedHeads := head :: !escapedHeads + | None -> ()) + | None -> ()) + | Some head -> + let appliedFunctor, firstIndex = + match head with + | Key (pos, consumed) -> (Key (pos, 0), consumed) + | ParamHead _ | Packed _ -> (head, 0) + in + incr nextApplicationId; + let applicationId = !nextApplicationId in args |> List.iteri (fun i argumentExpr -> match argumentExpr with | Some argumentExpr -> delayedApplications := { - appliedFunctor = key; - argIndex = consumed + i; + applicationId; + bindings = []; + appliedFunctor; + argIndex = firstIndex + i; resolver = argumentItemResolver argumentExpr; + argHead = argHead argumentExpr; } :: !delayedApplications | None -> ()) - | None -> () (* Traverse the AST *) let traverseStructure ~doTypes ~doExternals = @@ -1164,6 +1677,7 @@ let traverseStructure ~doTypes ~doExternals = currentModuleBindingPos := mb_name.loc.loc_start; setFunctorKey mb_expr mb_name.loc.loc_start; registerParameterAlias mb_id mb_expr; + registerBindingHead ~namePos:mb_name.loc.loc_start mb_id mb_expr; let hasInterface = match mb_expr.mod_desc with Tmod_constraint _ -> true | _ -> false in @@ -1193,7 +1707,7 @@ let traverseStructure ~doTypes ~doExternals = match mb.mb_id with | Some id -> functorsByIdent := - (id, (mb.mb_name.loc.loc_start, 0)) :: !functorsByIdent + (id, Key (mb.mb_name.loc.loc_start, 0)) :: !functorsByIdent | None -> ()); (* [module rec G : T = H and H : T = F]: an alias or partial application stands for the functor's key; a forward alias resolves @@ -1209,7 +1723,7 @@ let traverseStructure ~doTypes ~doExternals = | Tmod_apply_unit _ #endif ) ) -> ( - match functorKeyOfHead mb.mb_expr with + match functorHeadOf mb.mb_expr with | Some key when List.assq_opt id !functorsByIdent <> Some key -> functorsByIdent := (id, key) @@ -1382,17 +1896,50 @@ let forceDelayedItems () = | None -> locToImpl in addValueReference ~addFileReference:true ~locFrom ~locTo); - (* Credit calls made through functor parameters to the actual arguments. *) + (* Credit calls made through functor parameters to the actual arguments. + A functor without any application supplying the parameter (never + applied, or applied through something this analysis cannot chase, such + as a first-class module from another file) keeps the conservative + behaviour: the calls are forwarded to every implementation of the item. + An argument whose item cannot be resolved falls back to the item too. *) delayedApplications := List.rev !delayedApplications; + resolveParameterHeadedApplications (); + let escaped = escapedKeys () in Hashtbl.iter (fun (def, index, components) calls -> - resolveArgumentItems ~visited:[] def index components - |> List.iter (fun (locTo : Location.t) -> - calls - |> List.iter - (DeadOptionalArgs.addCallToImplementation - ~posTo:locTo.loc_start))) + let calls = List.rev calls in + if !Common.Cli.debug then + Log_.item "parameterCalls %s index:%d %s: %s@." (def |> posToString) + index + (String.concat "." components) + (if hasApplication def index then "applied" + else if List.mem def escaped then "escaped" + else "never applied"); + if hasApplication def index then + match + resolveArgumentItems ~visited:[] ~bindings:[] def index components + with + | [] -> + calls + |> List.iter (fun {call; callTo} -> + DeadOptionalArgs.addCallToImplementation + ~posTo:callTo.loc_start call) + | locs -> + locs + |> List.iter (fun (locTo : Location.t) -> + calls + |> List.iter (fun {call} -> + DeadOptionalArgs.addCallToImplementation + ~posTo:locTo.loc_start call)) + else if List.mem def escaped then + calls + |> List.iter (fun {call; callFrom; callTo; callToImpl; callPath} -> + call + |> DeadOptionalArgs.addReferences ~locFrom:callFrom ~locTo:callTo + ?locToImpl:callToImpl ~forwardable:true ~path:callPath)) parameterCalls; + Hashtbl.reset parameterCalls; + escapedHeads := []; (* Reference the items a parameter's coercion uses, in the arguments of the enclosing functor's applications; the module type item is the fallback when an argument cannot be resolved. *) @@ -1400,13 +1947,10 @@ let forceDelayedItems () = |> List.iter (fun {outerFunctor; outerIndex; itemPath; coercionFrom; coercionTo} -> let resolved = - resolveArgumentItems ~visited:[] outerFunctor outerIndex itemPath - in - let applied = - !delayedApplications - |> List.exists (fun {appliedFunctor; argIndex} -> - appliedFunctor = outerFunctor && argIndex = outerIndex) + resolveArgumentItems ~visited:[] ~bindings:[] outerFunctor + outerIndex itemPath in + let applied = hasApplication outerFunctor outerIndex in match resolved with | [] when applied -> addValueReference ~addFileReference:true ~locFrom:coercionFrom From 657bdf118b229d8a807867ac787b077876cf703f Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 17 Sep 2026 10:01:14 +0000 Subject: [PATCH 39/53] Track escaping nested functors and avoid duplicate optional calls --- examples/regression/src/Cross_alias.ml | 7 + examples/regression/src/Higher_order_more.ml | 144 +++++++++++ examples/regression/src/Main.ml | 6 +- .../regression/src/Shared_signature_arg.ml | 5 + examples/regression/src/dune | 1 + scripts/run_integration_tests.js | 38 +++ src/DeadValue.ml | 244 +++++++++++++++--- 7 files changed, 402 insertions(+), 43 deletions(-) create mode 100644 examples/regression/src/Higher_order_more.ml diff --git a/examples/regression/src/Cross_alias.ml b/examples/regression/src/Cross_alias.ml index ec43eade..4255ef55 100644 --- a/examples/regression/src/Cross_alias.ml +++ b/examples/regression/src/Cross_alias.ml @@ -26,3 +26,10 @@ module Impl_cross_fc (M : Shared_signature.O) = struct end let packed_cross = (module Impl_cross_fc : Higher_order.Opt_functor) + +module Outer_cross_ho (F : Higher_order.Opt_functor) (M : Shared_signature.O) = +struct + module A = F (M) + + let run () = A.run () +end diff --git a/examples/regression/src/Higher_order_more.ml b/examples/regression/src/Higher_order_more.ml new file mode 100644 index 00000000..5c3e660a --- /dev/null +++ b/examples/regression/src/Higher_order_more.ml @@ -0,0 +1,144 @@ +(* A functor whose body is directly the application of its functor + parameter, and a higher-order functor from another file applied here to a + functor from a third file. *) +module Opt_direct_body : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Opt_cross_ho : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Impl_direct_body (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end + +module Outer_direct (F : Higher_order.Opt_functor) (M : Shared_signature.O) = + F (M) + +module Applied_direct_body = Outer_direct (Impl_direct_body) (Opt_direct_body) + +module Applied_cross_ho = + Cross_alias.Outer_cross_ho (Shared_signature_arg.Impl_third) (Opt_cross_ho) + +let run () = ignore (Applied_direct_body.run () + Applied_cross_ho.run ()) + +(* The functor parameter's type written inline rather than named: the + passed functor's values, used through the parameter, stay live. *) +module Opt_anon : Shared_signature.O = struct + let g ?(x = 0) () = x +end + +module Impl_anon (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () + let helper () = 1 +end + +module Outer_anon + (F : functor (M : Shared_signature.O) -> sig + val run : unit -> int + end) + (M : Shared_signature.O) = +struct + module A = F (M) + + let run () = A.run () +end + +module Applied_anon = Outer_anon (Impl_anon) (Opt_anon) + +let run_anon () = ignore (Applied_anon.run ()) + +(* Functors reached through something whose applications cannot be seen: + nested in a module packed as a first-class value, and nested in the + result of a functor parameter applied in the body. Their calls are + forwarded conservatively: the arguments must not be reported as never + supplying the argument. *) +module type P2 = sig + val k : ?z:int -> unit -> int +end + +module type Holder_t = sig + module Inner : functor (M : P2) -> sig + val run : unit -> int + end +end + +module Holder = struct + module Inner (M : P2) = struct + let run () = M.k ~z:1 () + end +end + +module P2_esc : P2 = struct + let k ?(z = 0) () = z +end + +let packed_holder = (module Holder : Holder_t) + +let apply_holder (module H : Holder_t) = + let module A = H.Inner (P2_esc) in + A.run () + +module type P3 = sig + val q : ?w:int -> unit -> int +end + +module type Gi_t = functor (A : Shared_signature.S) -> sig + module Inner : functor (M : P3) -> sig + val run : unit -> int + end +end + +module Impl_gi (A : Shared_signature.S) = struct + module Inner (M : P3) = struct + let run () = M.q ~w:1 () + A.f () + end +end + +module P3_esc : P3 = struct + let q ?(w = 0) () = w +end + +module Outer_gi (F : Gi_t) (M : P3) = struct + module G = F (Shared_signature_arg.Chosen) + module A = G.Inner (M) + + let run () = A.run () +end + +module Applied_gi = Outer_gi (Impl_gi) (P3_esc) + +let run_nested () = ignore (apply_holder packed_holder + Applied_gi.run ()) + +(* A functor applied directly and also packed into a value that flows + through a function: the unseen application means its calls are forwarded, + so the second argument is not reported as never supplying [v]. *) +module type P4 = sig + val u : ?v:int -> unit -> int +end + +module type P4_functor = functor (M : P4) -> sig + val run : unit -> int +end + +module Impl_both (M : P4) = struct + let run () = M.u ~v:1 () +end + +module P4_a : P4 = struct + let u ?(v = 0) () = v +end + +module P4_b : P4 = struct + let u ?(v = 0) () = v +end + +module Applied_both_a = Impl_both (P4_a) + +let packed_both = (module Impl_both : P4_functor) +let through f = f + +module Applied_both_b = (val through packed_both : P4_functor) (P4_b) + +let run_both () = ignore (Applied_both_a.run () + Applied_both_b.run ()) diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index b16b569d..672364c8 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -50,4 +50,8 @@ let () = Higher_order.run (); Higher_order.run_id (); Higher_order.run_esc (); - Cross_alias_use.run_fc () + Cross_alias_use.run_fc (); + Higher_order_more.run (); + Higher_order_more.run_anon (); + Higher_order_more.run_nested (); + Higher_order_more.run_both () diff --git a/examples/regression/src/Shared_signature_arg.ml b/examples/regression/src/Shared_signature_arg.ml index ea7947ac..64a160cc 100644 --- a/examples/regression/src/Shared_signature_arg.ml +++ b/examples/regression/src/Shared_signature_arg.ml @@ -1034,3 +1034,8 @@ module Applied_struct = end : Shared_signature.O)) let run_app2 () = ignore (Applied_fwd.run () + Applied_struct.run ()) + +(* Passed to a higher-order functor of another file, from a third. *) +module Impl_third (M : Shared_signature.O) = struct + let run () = M.g ~x:1 () +end diff --git a/examples/regression/src/dune b/examples/regression/src/dune index 9593dfd3..341bd8bf 100644 --- a/examples/regression/src/dune +++ b/examples/regression/src/dune @@ -8,6 +8,7 @@ Functor_argument Generated_source Higher_order + Higher_order_more Included_sig Live_ancestors Local_side_effects diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index f84eb0be..1257a266 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -465,6 +465,25 @@ function runRegressionTests() { output, "optional argument x of function Opt_twice.+g is always supplied (2 calls)" ); + // ... a functor whose body is directly the parameter's application, and a + // higher-order functor from another file applied to a functor from a + // third file. + assertIncludes( + output, + "optional argument x of function Opt_direct_body.+g is always supplied (1 calls)" + ); + assertIncludes( + output, + "optional argument x of function Opt_cross_ho.+g is always supplied (1 calls)" + ); + // ... and with the functor parameter's type written inline: the passed + // functor's values used through it stay live, its unused helper dead. + assertIncludes( + output, + "optional argument x of function Opt_anon.+g is always supplied (1 calls)" + ); + assertIncludes(output, "Live Value +Higher_order_more.Impl_anon.+run"); + assertIncludes(output, "Dead Value +Higher_order_more.Impl_anon.+helper"); assertIncludes( output, "optional argument x of function Opt_none_ho.+g is never used" @@ -484,6 +503,25 @@ function runRegressionTests() { "optional argument y of function P_esc.+h is always supplied" ); assertNotIncludes(output, "P_esc.+h is never used"); + // ... including functors nested in a module that escapes, nested in + // the result of an applied functor parameter, and a functor applied + // directly whose packed value also flows through a function. + assertIncludes( + output, + "optional argument z of function P2_esc.+k is always supplied" + ); + assertNotIncludes(output, "P2_esc.+k is never used"); + assertIncludes( + output, + "optional argument w of function P3_esc.+q is always supplied" + ); + assertNotIncludes(output, "P3_esc.+q is never used"); + assertIncludes( + output, + "optional argument v of function P4_b.+u is always supplied" + ); + assertNotIncludes(output, "P4_b.+u is never used"); + assertNotIncludes(output, "P4_a.+u is never used"); } assertNotIncludes(output, "Parent is a dead module"); diff --git a/src/DeadValue.ml b/src/DeadValue.ml index fcb90ce3..1a37743f 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -180,6 +180,8 @@ type delayedApplication = { functor the head came through, by the functor's key. A parameter of such a functor then resolves through that application only, so that [M] pairs with the [F] of the same application. *) + argRange : (Lexing.position * Lexing.position) list; + (** source ranges of the argument's definition, see [escapedRanges] *) } let delayedApplications : delayedApplication list ref = ref [] @@ -198,12 +200,30 @@ let applicationsOf ~bindings functorDef argIndex = | None -> true) (* Functors whose applications cannot all be seen: packed as first-class - modules, or passed to an application whose head cannot be chased. Calls - through their parameters are forwarded to every implementation when no - application is known; a functor never applied nor escaping credits - nothing, as its calls never run. *) + modules that flow somewhere other than a direct [(val p)], or passed to + an application whose head cannot be chased. Calls through their parameters + are forwarded to every implementation of the item; a functor never applied + nor escaping credits nothing, as its calls never run. A module that + escapes takes the functors nested in its definition with it: those are + covered by source ranges rather than keys. *) let escapedHeads : functorHead list ref = ref [] +let escapedRanges : (Lexing.position * Lexing.position) list ref = ref [] + +(* Positions of the value expressions that are the operand of a + [(val e : S)], and the values (by binding position) used anywhere else: + a packed module used only through direct unpacks is followed precisely, + any other use makes it escape. *) +let unpackOperands = ref PosSet.empty +let usedOutsideUnpack = ref PosSet.empty + +let inRanges (pos : Lexing.position) ranges = + ranges + |> List.exists (fun ((start : Lexing.position), (stop : Lexing.position)) -> + start.pos_fname = pos.pos_fname + && start.pos_cnum <= pos.pos_cnum + && pos.pos_cnum <= stop.pos_cnum) + let functorHeadToString head = match head with | Key (pos, consumed) -> Printf.sprintf "%s+%d" (pos |> posToString) consumed @@ -223,11 +243,20 @@ type packedModule = { packedHead : functorHead option; packedShape : Compat.moduleShape option; packedConcrete : Types.module_type option; + packedRange : (Lexing.position * Lexing.position) list; + packedExpr : Typedtree.module_expr; } let packedModules : (Lexing.position, packedModule) Hashtbl.t = Hashtbl.create 4 +(* Whether a packed module expression is the right-hand side of a value + binding registered in [packedModules]; other packs escape at once. *) +let isRegisteredPack (moduleExpr : Typedtree.module_expr) = + Hashtbl.fold + (fun _ {packedExpr} acc -> acc || packedExpr == moduleExpr) + packedModules false + (* The binding a [(val e : S)] unpacks, when [e] names a value. *) let unpackedBinding (e : Typedtree.expression) = match e.exp_desc with @@ -288,14 +317,24 @@ let rec resolveHeads ~visited ~bindings functorDef argIndex components = itself come through a parameter; the ones left unresolved (the enclosing functor is never applied, or applied to something not resolvable) are dropped, and the calls they would credit fall back to forwarding. *) -let resolveParameterHeadedApplications () = +(* The packed module a value position denotes: bound there, or declared + there in an interface and bound at the implementation position. *) +let findPackedModule ~sigToImpl pos = + match Hashtbl.find_opt packedModules pos with + | Some packed -> Some packed + | None -> ( + match Hashtbl.find_opt sigToImpl pos with + | Some implPos -> Hashtbl.find_opt packedModules implPos + | None -> None) + +let resolveParameterHeadedApplications ~sigToImpl = (* First-class modules, from the values they were packed into. *) delayedApplications := !delayedApplications |> List.map (fun application -> match application.appliedFunctor with | Packed (pos, consumed) -> ( - match Hashtbl.find_opt packedModules pos with + match findPackedModule ~sigToImpl pos with | Some {packedHead = Some (Key (key, consumed'))} -> { application with @@ -337,34 +376,78 @@ let resolveParameterHeadedApplications () = in loop (); !delayedApplications - |> List.iter (fun {appliedFunctor; argIndex; argHead} -> + |> List.iter (fun {appliedFunctor; argIndex; argHead; argRange} -> match appliedFunctor with | ParamHead _ | Packed _ -> ( if !Common.Cli.debug then Log_.item "unresolvedApplication %s index:%d@." (functorHeadToString appliedFunctor) argIndex; + escapedRanges := argRange @ !escapedRanges; match argHead [] with | Some head -> escapedHeads := head :: !escapedHeads | None -> ()) | Key _ -> ()) -(* The keys of the functors that escaped, see [escapedHeads]. *) -let escapedKeys () = - !escapedHeads - |> List.concat_map (fun head -> - match head with - | Key (pos, _) -> [pos] - | ParamHead (def, index, components, _) -> - resolveHeads ~visited:[] ~bindings:[] def index components - |> List.map (fun (pos, _, _) -> pos) - | Packed (pos, _) -> ( - match Hashtbl.find_opt packedModules pos with - | Some {packedHead = Some (Key (key, _))} -> [key] - | Some {packedHead = Some (ParamHead (def, index, components, _))} -> - resolveHeads ~visited:[] ~bindings:[] def index components - |> List.map (fun (pos, _, _) -> pos) - | _ -> [])) +(* The definition ranges of the arguments at [argIndex] of the applications + of [functorDef], through parameters of enclosing functors. *) +let rec resolveRanges ~visited functorDef argIndex = + if List.mem (functorDef, argIndex) visited then [] + else + let visited = (functorDef, argIndex) :: visited in + applicationsOf ~bindings:[] functorDef argIndex + |> List.concat_map (fun {argRange; resolver} -> + argRange + @ + match resolver with + | ViaParameter (def, index, _) -> resolveRanges ~visited def index + | Direct _ -> []) + +(* The keys and definition ranges of what escaped, see [escapedHeads]. *) +let escapedKeysAndRanges ~sigToImpl = + let ofHead head = + match head with + | Key (pos, _) -> ([pos], []) + | ParamHead (def, index, components, _) -> + ( resolveHeads ~visited:[] ~bindings:[] def index components + |> List.map (fun (pos, _, _) -> pos), + resolveRanges ~visited:[] def index ) + | Packed (pos, _) -> ( + match findPackedModule ~sigToImpl pos with + | Some {packedHead = Some (Key (key, _)); packedRange} -> + ([key], packedRange) + | Some + {packedHead = Some (ParamHead (def, index, components, _)); packedRange} + -> + ( resolveHeads ~visited:[] ~bindings:[] def index components + |> List.map (fun (pos, _, _) -> pos), + packedRange @ resolveRanges ~visited:[] def index ) + | Some {packedRange} -> ([], packedRange) + | None -> ([], [])) + in + let keys, ranges = !escapedHeads |> List.map ofHead |> List.split in + (List.concat keys, List.concat ranges @ !escapedRanges) + +(* Packed modules that flowed somewhere other than a direct unpack escape, + decided once every use is known; an interface item stands for its + implementation. *) +let escapePackedModulesUsedElsewhere ~sigToImpl = + let usedElsewhere = ref !usedOutsideUnpack in + Hashtbl.iter + (fun sigPos implPos -> + if PosSet.mem sigPos !usedOutsideUnpack then + usedElsewhere := PosSet.add implPos !usedElsewhere) + sigToImpl; + Hashtbl.iter + (fun pos {packedHead; packedRange} -> + if PosSet.mem pos !usedElsewhere then ( + if !Common.Cli.debug then + Log_.item "packedEscapes %s@." (pos |> posToString); + escapedRanges := packedRange @ !escapedRanges; + match packedHead with + | Some head -> escapedHeads := head :: !escapedHeads + | None -> ())) + packedModules (* Coercion references made through a functor parameter, as in [module Outer (M : S) = Inner (M)]: credited to the arguments of the @@ -495,8 +578,11 @@ let processOptionalArgs ~expType ~(locFrom : Location.t) ~locTo ?locToImpl | _ -> ()); let call = (!supplied, !suppliedMaybe) in let parameter = findFunctorParameter path in + (* Without shape resolution the call is only forwarded (below); recording + it here too would credit it twice. *) (match (parameter, pathComponents path) with - | Some {functorDef; paramIndex; prefix}, Some components -> + | Some {functorDef; paramIndex; prefix}, Some components + when Compat.shapeResolutionAvailable -> let components = prefix @ components in let key = (functorDef, paramIndex, components) in if !Common.Cli.debug then @@ -687,6 +773,41 @@ let rec moduleShapeOfExpr ?(env = []) (moduleExpr : Typedtree.module_expr) = #endif | _ -> None +(* The source ranges of the definition a module expression denotes, for + the functors nested in it (see [escapedRanges]): its own for a structure + or functor, its binding's through paths and aliases (in any unit), and + those of the functor and the arguments for an application (the result + may re-export either). *) +let rec definitionRange ?(depth = 0) (e : Typedtree.module_expr) = + let own = + if e.mod_loc.loc_ghost then [] + else [(e.mod_loc.loc_start, e.mod_loc.loc_end)] + in + if depth > 8 then [] + else + match e.mod_desc with + | Tmod_structure _ | Tmod_functor _ -> own + | Tmod_constraint (inner, _, _, _) -> definitionRange ~depth inner + | Tmod_ident (path, _) -> definitionRangeOfPath ~depth path + | Tmod_apply (functorExpr, argumentExpr, _) -> + definitionRange ~depth:(depth + 1) functorExpr + @ definitionRange ~depth:(depth + 1) argumentExpr +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit functorExpr -> definitionRange ~depth:(depth + 1) functorExpr +#endif + | Tmod_unpack (packed, _) -> ( + match unpackedBinding packed with + | Some pos -> ( + match Hashtbl.find_opt packedModules pos with + | Some {packedRange} -> packedRange + | None -> []) + | None -> []) + +and definitionRangeOfPath ?(depth = 0) (path : Path.t) = + match !identResolutions.bindingOfPath path with + | Some (_, definition, _, _) -> definitionRange ~depth:(depth + 1) definition + | None -> [] + (* The functor a module expression applies, and the number of arguments already consumed by partial applications it stands for, as in [module G = F (A)] followed by [G (B)]. Aliases ([module G = F]) are @@ -827,11 +948,16 @@ let rec collectExpr super self (e : Typedtree.expression) = | _ -> ()); #endif (match e.exp_desc with - | Texp_pack moduleExpr -> ( - (* A functor packed as a first-class module escapes, see [escapedHeads]. *) + | Texp_pack moduleExpr when not (isRegisteredPack moduleExpr) -> ( + (* A module packed as a first-class value anywhere but in a value + binding escapes at once, with the functors nested in it. *) + escapedRanges := definitionRange moduleExpr @ !escapedRanges; match functorHeadOf moduleExpr with | Some head -> escapedHeads := head :: !escapedHeads | None -> ()) + | Texp_ident (_, _, {val_loc}) + when not (PosSet.mem e.exp_loc.loc_start !unpackOperands) -> + usedOutsideUnpack := PosSet.add val_loc.loc_start !usedOutsideUnpack | _ -> ()); (match e.exp_desc with | Texp_ident (_path, _, {Types.val_loc = {loc_ghost = false; _} as locTo}) @@ -1374,9 +1500,12 @@ let registerPackedModule (vb : Typedtree.value_binding) = packedHead = functorHeadOf moduleExpr; packedShape = moduleShapeOfExpr moduleExpr; packedConcrete = concrete; + packedRange = definitionRange moduleExpr; + packedExpr = moduleExpr; } | _ -> () + let () = registerPackedModuleRef := registerPackedModule (* Implementation of a value of an actual functor argument, by path. *) @@ -1475,8 +1604,8 @@ let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = | Tmod_constraint (inner, _, _, _) -> flatten inner args | _ -> (e, args) in - let head, args = flatten moduleExpr [] in - let head = functorHeadOf head in + let headExpr, args = flatten moduleExpr [] in + let head = functorHeadOf headExpr in if !Common.Cli.debug then Log_.item "functorApplication %s key:%s args:%d@." (moduleExpr.mod_loc.loc_start |> posToString) @@ -1523,16 +1652,30 @@ let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = match head with | None -> (* The functors passed to an application whose head cannot be chased - (a first-class module from elsewhere) escape: their calls can only - be forwarded. *) + (a first-class module from elsewhere, a member of the result of an + applied functor parameter) escape: their calls can only be + forwarded. So does what the head's root stands for, when it is a + parameter: [G.Inner (X)] with [module G = F (A)] applies a functor + nested in the argument passed for [F]. *) args |> List.iter (fun argumentExpr -> match argumentExpr with | Some argumentExpr -> ( + escapedRanges := definitionRange argumentExpr @ !escapedRanges; match functorHeadOf argumentExpr with | Some head -> escapedHeads := head :: !escapedHeads | None -> ()) - | None -> ()) + | None -> ()); + (match headExpr.mod_desc with + | Tmod_ident ((Pdot _ as path), _) -> ( + match headOfPath (Pident (Path.head path)) [] with + | Some root -> + escapedHeads := root :: !escapedHeads; + escapedRanges := + definitionRangeOfPath (Pident (Path.head path)) @ !escapedRanges + | None -> () + | exception _ -> ()) + | _ -> ()) | Some head -> let appliedFunctor, firstIndex = match head with @@ -1553,6 +1696,7 @@ let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = argIndex = firstIndex + i; resolver = argumentItemResolver argumentExpr; argHead = argHead argumentExpr; + argRange = definitionRange argumentExpr; } :: !delayedApplications | None -> ()) @@ -1663,6 +1807,8 @@ let traverseStructure ~doTypes ~doExternals = #if OCAML_VERSION >= (5, 1, 0) | Tmod_apply_unit _ -> recordFunctorApplication moduleExpr #endif + | Tmod_unpack (packed, _) -> + unpackOperands := PosSet.add packed.exp_loc.loc_start !unpackOperands | _ -> ()); let r = super.Tast_mapper.module_expr self moduleExpr in functorParameters := oldFunctorParameters; @@ -1903,8 +2049,17 @@ let forceDelayedItems () = behaviour: the calls are forwarded to every implementation of the item. An argument whose item cannot be resolved falls back to the item too. *) delayedApplications := List.rev !delayedApplications; - resolveParameterHeadedApplications (); - let escaped = escapedKeys () in + (* Interface items stand for their implementations (value dependencies + pair an implementation with the item it satisfies). *) + let sigToImpl = Hashtbl.create 16 in + !delayedValueDependencies + |> List.iter (fun ((locTo : Location.t), (locFrom : Location.t)) -> + if not (locTo.loc_ghost || locFrom.loc_ghost) then + Hashtbl.replace sigToImpl locFrom.loc_start locTo.loc_start); + resolveParameterHeadedApplications ~sigToImpl; + escapePackedModulesUsedElsewhere ~sigToImpl; + let keys, ranges = escapedKeysAndRanges ~sigToImpl in + let isEscaped def = List.mem def keys || inRanges def ranges in Hashtbl.iter (fun (def, index, components) calls -> let calls = List.rev calls in @@ -1912,10 +2067,19 @@ let forceDelayedItems () = Log_.item "parameterCalls %s index:%d %s: %s@." (def |> posToString) index (String.concat "." components) - (if hasApplication def index then "applied" - else if List.mem def escaped then "escaped" + (if isEscaped def then "escaped" + else if hasApplication def index then "applied" else "never applied"); - if hasApplication def index then + (* An escaping functor may have applications this analysis cannot + see: its calls are forwarded, even when some applications are + known (crediting those precisely as well would count them twice). *) + if isEscaped def then + calls + |> List.iter (fun {call; callFrom; callTo; callToImpl; callPath} -> + call + |> DeadOptionalArgs.addReferences ~locFrom:callFrom ~locTo:callTo + ?locToImpl:callToImpl ~forwardable:true ~path:callPath) + else if hasApplication def index then match resolveArgumentItems ~visited:[] ~bindings:[] def index components with @@ -1931,15 +2095,11 @@ let forceDelayedItems () = |> List.iter (fun {call} -> DeadOptionalArgs.addCallToImplementation ~posTo:locTo.loc_start call)) - else if List.mem def escaped then - calls - |> List.iter (fun {call; callFrom; callTo; callToImpl; callPath} -> - call - |> DeadOptionalArgs.addReferences ~locFrom:callFrom ~locTo:callTo - ?locToImpl:callToImpl ~forwardable:true ~path:callPath)) + else ()) parameterCalls; Hashtbl.reset parameterCalls; escapedHeads := []; + escapedRanges := []; (* Reference the items a parameter's coercion uses, in the arguments of the enclosing functor's applications; the module type item is the fallback when an argument cannot be resolved. *) From 9213d8d08fafddea6809fc3a3ee3580c1d6cd1c6 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 17 Sep 2026 10:02:57 +0000 Subject: [PATCH 40/53] Skip applied long identifiers without emitting fatal diagnostics --- src/Compat.ml | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/src/Compat.ml b/src/Compat.ml index fc71822d..c2cee516 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -741,9 +741,17 @@ let rec makeResolver ~cmtFilePath (* [Longident.last] and [flatten] are fatal on [Lapply] ([F(X).t]): such occurrences are not values or modules of interest here. *) let lidText (lid : Longident.t) = - match Longident.flatten lid with - | components -> Some (String.concat "." components) - | exception Misc.Fatal_error -> None + let rec components suffix = function + | Longident.Lident name -> Some (name :: suffix) +#if OCAML_VERSION >= (5, 4, 0) + | Longident.Ldot ({txt = parent}, {txt = name}) -> + components (name :: suffix) parent +#else + | Longident.Ldot (parent, name) -> components (name :: suffix) parent +#endif + | Longident.Lapply _ -> None + in + components [] lid |> Option.map (String.concat ".") in (* Two occurrences with one key are the same identifier only if they are spelled the same and the compiler resolved them the same way (the same From 043ea7b5f35ed1dff4a01b0614355b8226ae0497 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 17 Sep 2026 10:07:18 +0000 Subject: [PATCH 41/53] Merge updated functor-fix base and preserve duplicate-unit regressions --- scripts/run_integration_tests.js | 1 + src/Compat.ml | 146 +++++++++++++++++++++++++++---- 2 files changed, 129 insertions(+), 18 deletions(-) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index 1257a266..d6dee8c2 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -543,6 +543,7 @@ function runRegressionTests() { { cwd, encoding: "utf8", + maxBuffer: 256 * 1024 * 1024, } ); diff --git a/src/Compat.ml b/src/Compat.ml index c2cee516..6a89c1b4 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -513,26 +513,136 @@ let moduleTypeOfUid ~currentCmtFile ~imports ~local uid = let extractValueDependencies ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) = #if OCAML_VERSION >= (5, 3, 0) - let local = Shape.Uid.Tbl.create 1024 in - Shape.Uid.Tbl.iter (Shape.Uid.Tbl.replace local) cmt_infos.cmt_uid_to_decl; - (let cmti = (cmtFilePath |> Filename.remove_extension) ^ ".cmti" in - if Sys.file_exists cmti then - try - let cmti_infos = Cmt_format.read_cmt cmti in - Shape.Uid.Tbl.iter - (fun uid decl -> - if not (Shape.Uid.Tbl.mem local uid) then - Shape.Uid.Tbl.replace local uid decl) - cmti_infos.cmt_uid_to_decl - with _ -> ()); - let loc_of_uid = - locOfUid ~currentCmtFile:cmtFilePath ~imports:cmt_infos.cmt_imports ~local + let module UidTbl = Shape.Uid.Tbl in + (* 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 + (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 + 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 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 From 1ec950607ef55bb610d8339c6c4a91444595c66a Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 17 Sep 2026 10:11:58 +0000 Subject: [PATCH 42/53] Follow escaped module aliases across arbitrary chains and compilation units --- examples/regression/src/Cross_alias.ml | 20 +++++++++++ examples/regression/src/Higher_order_more.ml | 31 ++++++++++++++-- scripts/run_integration_tests.js | 5 +++ src/Compat.ml | 38 +++++++++++++------- src/DeadValue.ml | 27 ++++++++------ 5 files changed, 97 insertions(+), 24 deletions(-) diff --git a/examples/regression/src/Cross_alias.ml b/examples/regression/src/Cross_alias.ml index 4255ef55..36c40212 100644 --- a/examples/regression/src/Cross_alias.ml +++ b/examples/regression/src/Cross_alias.ml @@ -33,3 +33,23 @@ struct let run () = A.run () end + +(* Packed by a consumer in another compilation unit: chasing the alias's + local path requires this unit's resolver. *) +module type Escaped_arg = sig + val k : ?cross:int -> unit -> int +end + +module type Escaped_holder_type = sig + module Inner : functor (M : Escaped_arg) -> sig + val run : unit -> int + end +end + +module Escaped_holder = struct + module Inner (M : Escaped_arg) = struct + let run () = M.k ~cross:1 () + end +end + +module Escaped_alias = Escaped_holder diff --git a/examples/regression/src/Higher_order_more.ml b/examples/regression/src/Higher_order_more.ml index 5c3e660a..c11b8554 100644 --- a/examples/regression/src/Higher_order_more.ml +++ b/examples/regression/src/Higher_order_more.ml @@ -74,12 +74,36 @@ module P2_esc : P2 = struct let k ?(z = 0) () = z end -let packed_holder = (module Holder : Holder_t) +(* Escaping through a long, acyclic alias chain must still retain Inner's + calls. This exceeds the former fixed definition-lookup depth limit. *) +module Holder1 = Holder +module Holder2 = Holder1 +module Holder3 = Holder2 +module Holder4 = Holder3 +module Holder5 = Holder4 +module Holder6 = Holder5 +module Holder7 = Holder6 +module Holder8 = Holder7 +module Holder9 = Holder8 +module Holder10 = Holder9 + +let packed_holder = (module Holder10 : Holder_t) let apply_holder (module H : Holder_t) = let module A = H.Inner (P2_esc) in A.run () +module Cross_esc : Cross_alias.Escaped_arg = struct + let k ?(cross = 0) () = cross +end + +let packed_cross_holder = + (module Cross_alias.Escaped_alias : Cross_alias.Escaped_holder_type) + +let apply_cross_holder (module H : Cross_alias.Escaped_holder_type) = + let module A = H.Inner (Cross_esc) in + A.run () + module type P3 = sig val q : ?w:int -> unit -> int end @@ -109,7 +133,10 @@ end module Applied_gi = Outer_gi (Impl_gi) (P3_esc) -let run_nested () = ignore (apply_holder packed_holder + Applied_gi.run ()) +let run_nested () = + ignore + (apply_holder packed_holder + apply_cross_holder packed_cross_holder + + Applied_gi.run ()) (* A functor applied directly and also packed into a value that flows through a function: the unseen application means its calls are forwarded, diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index d6dee8c2..9d809bd7 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -511,6 +511,11 @@ function runRegressionTests() { "optional argument z of function P2_esc.+k is always supplied" ); assertNotIncludes(output, "P2_esc.+k is never used"); + assertIncludes( + output, + "optional argument cross of function Cross_esc.+k is always supplied" + ); + assertNotIncludes(output, "Cross_esc.+k is never used"); assertIncludes( output, "optional argument w of function P3_esc.+q is always supplied" diff --git a/src/Compat.ml b/src/Compat.ml index 6a89c1b4..079a5f54 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -943,6 +943,17 @@ let rec makeResolver ~cmtFilePath resolverForUnit ~currentCmtFile:cmtFilePath ~imports comp_unit | _ -> None in + (* Wrapped libraries introduce aliases to compilation units, such as + [Library.Unit.Member]. There is no module binding for the intermediate + compilation unit; reduce the complete path before structural lookup. *) + let rec globalPathShape (path : Path.t) = + match path with + | Pident id when Ident.global id -> Some (compUnitShape (Ident.name id)) + | Pdot (parent, name) -> + globalPathShape parent + |> Option.map (fun shape -> Shape.proj shape (Shape.Item.make name Module)) + | _ -> None + in (* The binding a module path denotes, structurally: through units, local bindings, and the bodies of applied functors, as in [Outer (A).Inner]. Returns the binding, the resolver of its unit, @@ -950,6 +961,21 @@ let rec makeResolver ~cmtFilePath let rec bindingOfPath (path : Path.t) : (Location.t * Typedtree.module_expr * identResolutions option * int) option = + let byShape = + match globalPathShape path with + | Some shape -> ( + match Reduce.reduce_for_uid Env.empty shape |> uidOfResult with + | Some uid -> ( + match bindingOfUid uid with + | Some (loc, definition) -> + Some (loc, definition, resolverOfUid uid, 0) + | None -> None) + | None -> None) + | None -> None + in + match byShape with + | Some binding -> Some binding + | None -> match path with | Pident id when Ident.global id -> None | Pident id -> ( @@ -965,18 +991,6 @@ let rec makeResolver ~cmtFilePath | Some (loc, definition) -> Some (loc, definition, Some !selfRef, 0) | None -> None) | None -> None) - | Pdot (Pident unit, name) when Ident.global unit -> ( - let shape = - Shape.proj (compUnitShape (Ident.name unit)) - (Shape.Item.make name Module) - in - match Reduce.reduce_for_uid Env.empty shape |> uidOfResult with - | Some uid -> ( - match bindingOfUid uid with - | Some (loc, definition) -> - Some (loc, definition, resolverOfUid uid, 0) - | None -> None) - | None -> None) | Pdot (parent, name) -> ( match bindingOfPath parent with | Some (_, definition, resolver, applied) -> ( diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 1a37743f..54d1b555 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -778,22 +778,26 @@ let rec moduleShapeOfExpr ?(env = []) (moduleExpr : Typedtree.module_expr) = or functor, its binding's through paths and aliases (in any unit), and those of the functor and the arguments for an application (the result may re-export either). *) -let rec definitionRange ?(depth = 0) (e : Typedtree.module_expr) = +let rec definitionRange ?(visited = []) ?(resolutions = !identResolutions) + (e : Typedtree.module_expr) = let own = if e.mod_loc.loc_ghost then [] else [(e.mod_loc.loc_start, e.mod_loc.loc_end)] in - if depth > 8 then [] + if List.memq e visited then [] else + let visited = e :: visited in match e.mod_desc with | Tmod_structure _ | Tmod_functor _ -> own - | Tmod_constraint (inner, _, _, _) -> definitionRange ~depth inner - | Tmod_ident (path, _) -> definitionRangeOfPath ~depth path + | Tmod_constraint (inner, _, _, _) -> + definitionRange ~visited ~resolutions inner + | Tmod_ident (path, _) -> definitionRangeOfPath ~visited ~resolutions path | Tmod_apply (functorExpr, argumentExpr, _) -> - definitionRange ~depth:(depth + 1) functorExpr - @ definitionRange ~depth:(depth + 1) argumentExpr + definitionRange ~visited ~resolutions functorExpr + @ definitionRange ~visited ~resolutions argumentExpr #if OCAML_VERSION >= (5, 1, 0) - | Tmod_apply_unit functorExpr -> definitionRange ~depth:(depth + 1) functorExpr + | Tmod_apply_unit functorExpr -> + definitionRange ~visited ~resolutions functorExpr #endif | Tmod_unpack (packed, _) -> ( match unpackedBinding packed with @@ -803,9 +807,12 @@ let rec definitionRange ?(depth = 0) (e : Typedtree.module_expr) = | None -> []) | None -> []) -and definitionRangeOfPath ?(depth = 0) (path : Path.t) = - match !identResolutions.bindingOfPath path with - | Some (_, definition, _, _) -> definitionRange ~depth:(depth + 1) definition +and definitionRangeOfPath ?(visited = []) ?(resolutions = !identResolutions) + (path : Path.t) = + match resolutions.bindingOfPath path with + | Some (_, definition, definingResolver, _) -> + let resolutions = Option.value definingResolver ~default:resolutions in + definitionRange ~visited ~resolutions definition | None -> [] (* The functor a module expression applies, and the number of arguments From d3ceacc49a9f4d825f54edc7c44a85efdcc10132 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 17 Sep 2026 10:14:20 +0000 Subject: [PATCH 43/53] Retain implementation shapes when matching interface digests --- examples/regression/dup_a/Dup_shape.ml | 11 ++++ examples/regression/dup_a/Dup_shape.mli | 2 + examples/regression/dup_a/dune | 2 +- examples/regression/dup_b/Dup_shape.ml | 6 ++ examples/regression/dup_b/Dup_shape.mli | 1 + examples/regression/dup_b/dune | 2 +- .../regression/dup_shape_use/Dup_shape_use.ml | 3 + examples/regression/dup_shape_use/dune | 7 +++ scripts/run_integration_tests.js | 8 +++ src/Compat.ml | 60 +++++++++---------- 10 files changed, 68 insertions(+), 34 deletions(-) create mode 100644 examples/regression/dup_a/Dup_shape.ml create mode 100644 examples/regression/dup_a/Dup_shape.mli create mode 100644 examples/regression/dup_b/Dup_shape.ml create mode 100644 examples/regression/dup_b/Dup_shape.mli create mode 100644 examples/regression/dup_shape_use/Dup_shape_use.ml create mode 100644 examples/regression/dup_shape_use/dune diff --git a/examples/regression/dup_a/Dup_shape.ml b/examples/regression/dup_a/Dup_shape.ml new file mode 100644 index 00000000..4086961b --- /dev/null +++ b/examples/regression/dup_a/Dup_shape.ml @@ -0,0 +1,11 @@ +module A_chosen : Dup_sig.S with type t = int = struct + type t = int + let f x = x + let g x = x +end + +module A_unused : Dup_sig.S with type t = int = struct + type t = int + let f x = x + let g x = x +end diff --git a/examples/regression/dup_a/Dup_shape.mli b/examples/regression/dup_a/Dup_shape.mli new file mode 100644 index 00000000..ceb2c381 --- /dev/null +++ b/examples/regression/dup_a/Dup_shape.mli @@ -0,0 +1,2 @@ +module A_chosen : Dup_sig.S with type t = int +module A_unused : Dup_sig.S with type t = int diff --git a/examples/regression/dup_a/dune b/examples/regression/dup_a/dune index 5b28eb9d..0ec61fd5 100644 --- a/examples/regression/dup_a/dune +++ b/examples/regression/dup_a/dune @@ -2,5 +2,5 @@ (name dup_a) (wrapped false) (modes byte) - (modules Dup_sig Dup_a_impl Dup_a_use) + (modules Dup_sig Dup_shape Dup_a_impl Dup_a_use) (flags :standard -w -27-32-34-37-39 -bin-annot)) diff --git a/examples/regression/dup_b/Dup_shape.ml b/examples/regression/dup_b/Dup_shape.ml new file mode 100644 index 00000000..44a67a91 --- /dev/null +++ b/examples/regression/dup_b/Dup_shape.ml @@ -0,0 +1,6 @@ +module B_unused : Dup_sig.S with type t = int = struct + type t = int + let f x = x + let g x = x + let h x = x +end diff --git a/examples/regression/dup_b/Dup_shape.mli b/examples/regression/dup_b/Dup_shape.mli new file mode 100644 index 00000000..419bfecd --- /dev/null +++ b/examples/regression/dup_b/Dup_shape.mli @@ -0,0 +1 @@ +module B_unused : Dup_sig.S with type t = int diff --git a/examples/regression/dup_b/dune b/examples/regression/dup_b/dune index fe436bc6..6a3869a9 100644 --- a/examples/regression/dup_b/dune +++ b/examples/regression/dup_b/dune @@ -2,5 +2,5 @@ (name dup_b) (wrapped false) (modes byte) - (modules Dup_sig Dup_b_impl Dup_b_use) + (modules Dup_sig Dup_shape Dup_b_impl Dup_b_use) (flags :standard -w -27-32-34-37-39 -bin-annot)) diff --git a/examples/regression/dup_shape_use/Dup_shape_use.ml b/examples/regression/dup_shape_use/Dup_shape_use.ml new file mode 100644 index 00000000..75f9fa60 --- /dev/null +++ b/examples/regression/dup_shape_use/Dup_shape_use.ml @@ -0,0 +1,3 @@ +(* The consumer has no sibling Dup_shape: the importer digest must choose + dup_a and retain its implementation shape as well as its interface. *) +let () = ignore (Dup_shape.A_chosen.f 1) diff --git a/examples/regression/dup_shape_use/dune b/examples/regression/dup_shape_use/dune new file mode 100644 index 00000000..b0b4557b --- /dev/null +++ b/examples/regression/dup_shape_use/dune @@ -0,0 +1,7 @@ +(library + (name dup_shape_use) + (wrapped false) + (modes byte) + (libraries dup_a) + (modules Dup_shape_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 9d809bd7..5d597cbf 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -560,6 +560,14 @@ function runRegressionTests() { assertNotIncludes(dupOutput, "Dead Value +Dup_a_impl.Make.+f"); assertNotIncludes(dupOutput, "Dead Value +Dup_b_impl.Make.+g"); + if (ocamlVersionAtLeast(5, 3)) { + // The matching .cmti supplies the digest, while the sibling .cmt + // supplies the shape needed to distinguish implementations of Dup_sig.S. + assertIncludes(dupOutput, "Live Value +Dup_shape.A_chosen.+f"); + assertNotIncludes(dupOutput, "Live Value +Dup_shape.A_unused.+f"); + assertIncludes(dupOutput, "Dead Value +Dup_shape.A_unused.+f"); + assertIncludes(dupOutput, "Dead Value +Dup_shape.B_unused.+f"); + } } // A broad root may hold copies of the same compiled unit (a library's diff --git a/src/Compat.ml b/src/Compat.ml index 079a5f54..f3d90f78 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -354,6 +354,24 @@ type unitInfo = { let unitInfoCache : (string list * string option, unitInfo) Hashtbl.t = Hashtbl.create 64 +(* An implementation compiled against an interface gets its digest from + the sibling .cmti. Retain both files of every matching unit, for shapes + as well as declaration dependencies; without a match stay conservative. *) +let selectUnitFilesByDigest ~interfaceDigest digest files = + match digest with + | None -> files + | Some digest -> + let stem = Filename.remove_extension in + let matchingStems = + files |> List.map stem |> List.sort_uniq compare + |> List.filter (fun base -> + [".cmt"; ".cmti"] + |> List.exists (fun ext -> interfaceDigest (base ^ ext) = Some digest)) + in + match matchingStems with + | [] -> files + | _ -> List.filter (fun path -> List.mem (stem path) matchingStems) files + let candidateFilesForUnit ~currentCmtFile comp_unit = let dir = Filename.dirname currentCmtFile in let indexed = @@ -403,21 +421,17 @@ let loadUnitInfo ~currentCmtFile ~(imports : Misc.crcs) comp_unit = try Some (path, Cmt_format.read_cmt path) with _ -> None in let loaded = files |> List.filter_map read in - let dirs = - loaded |> List.map (fun (p, _) -> Filename.dirname p) - |> List.sort_uniq compare + let interfaceDigest path = + match List.assoc_opt path loaded with + | Some infos -> infos.Cmt_format.cmt_interface_digest + | None -> ( + match read path with + | Some (_, infos) -> infos.Cmt_format.cmt_interface_digest + | None -> None) in + let selected = selectUnitFilesByDigest ~interfaceDigest digest files in let loaded = - match (dirs, digest) with - | _ :: _ :: _, Some digest -> ( - match - loaded - |> List.filter (fun (_, (cmt_infos : Cmt_format.cmt_infos)) -> - cmt_infos.cmt_interface_digest = Some digest) - with - | [] -> loaded - | matching -> matching) - | _ -> loaded + loaded |> List.filter (fun (path, _) -> List.mem path selected) in (* Copies of one compiled source (e.g. a library's objects and its _build/install copy, or byte and native objects) are one unit: keep @@ -587,25 +601,7 @@ let extractValueDependencies ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) = | 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) - ) + selectUnitFilesByDigest ~interfaceDigest:interface_digest_of_file digest files in let decls_of_unit comp_unit = match Hashtbl.find_opt loadedUnits comp_unit with From 06b6082c0375529158abf1453ee99f82ad26a34b Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 17 Sep 2026 10:46:13 +0000 Subject: [PATCH 44/53] Preserve references through late and escaping functor applications --- examples/regression/src/Cross_alias.ml | 8 +- examples/regression/src/Escape_exports.ml | 61 +++++++ .../regression/src/Higher_order_fixpoint.ml | 36 ++++ examples/regression/src/Main.ml | 6 +- examples/regression/src/Packed_interface.ml | 5 + examples/regression/src/Packed_interface.mli | 1 + .../regression/src/Packed_interface_use.ml | 8 + examples/regression/src/Packed_types.ml | 7 + examples/regression/src/Reference_order.ml | 55 ++++++ examples/regression/src/dune | 6 + scripts/run_integration_tests.js | 32 ++++ src/DeadValue.ml | 164 ++++++++++++------ 12 files changed, 335 insertions(+), 54 deletions(-) create mode 100644 examples/regression/src/Escape_exports.ml create mode 100644 examples/regression/src/Higher_order_fixpoint.ml create mode 100644 examples/regression/src/Packed_interface.ml create mode 100644 examples/regression/src/Packed_interface.mli create mode 100644 examples/regression/src/Packed_interface_use.ml create mode 100644 examples/regression/src/Packed_types.ml create mode 100644 examples/regression/src/Reference_order.ml diff --git a/examples/regression/src/Cross_alias.ml b/examples/regression/src/Cross_alias.ml index 36c40212..b570aaf8 100644 --- a/examples/regression/src/Cross_alias.ml +++ b/examples/regression/src/Cross_alias.ml @@ -46,10 +46,12 @@ module type Escaped_holder_type = sig end end +module Escaped_inner (M : Escaped_arg) = struct + let run () = M.k ~cross:1 () +end + module Escaped_holder = struct - module Inner (M : Escaped_arg) = struct - let run () = M.k ~cross:1 () - end + module Inner = Escaped_inner end module Escaped_alias = Escaped_holder diff --git a/examples/regression/src/Escape_exports.ml b/examples/regression/src/Escape_exports.ml new file mode 100644 index 00000000..617a1c84 --- /dev/null +++ b/examples/regression/src/Escape_exports.ml @@ -0,0 +1,61 @@ +(* The escaping holder's lexical range does not contain the functor it + exports. Both aliases and includes must carry that definition with it. *) +module type Alias_arg = sig + val g : ?alias:int -> unit -> int +end + +module type Alias_holder = sig + module Inner : functor (M : Alias_arg) -> sig + val run : unit -> int + end +end + +module Alias_inner (M : Alias_arg) = struct + let run () = M.g ~alias:1 () +end + +module Holder_alias = struct + module Inner = Alias_inner +end + +module Escaped_alias_arg : Alias_arg = struct + let g ?(alias = 0) () = alias +end + +let packed_alias = (module Holder_alias : Alias_holder) + +let apply_alias (module H : Alias_holder) = + let module A = H.Inner (Escaped_alias_arg) in + A.run () + +module type Include_arg = sig + val g : ?included:int -> unit -> int +end + +module type Include_holder = sig + module Inner : functor (M : Include_arg) -> sig + val run : unit -> int + end +end + +module Included = struct + module Inner (M : Include_arg) = struct + let run () = M.g ~included:1 () + end +end + +module Holder_include = struct + include Included +end + +module Escaped_include_arg : Include_arg = struct + let g ?(included = 0) () = included +end + +let packed_include = (module Holder_include : Include_holder) + +let apply_include (module H : Include_holder) = + let module A = H.Inner (Escaped_include_arg) in + A.run () + +let run () = ignore (apply_alias packed_alias + apply_include packed_include) diff --git a/examples/regression/src/Higher_order_fixpoint.ml b/examples/regression/src/Higher_order_fixpoint.ml new file mode 100644 index 00000000..1fd85404 --- /dev/null +++ b/examples/regression/src/Higher_order_fixpoint.ml @@ -0,0 +1,36 @@ +(* The indirect application of Outer becomes known after its body has + already been instantiated for the direct application. *) +module type Arg = sig + val g : ?y:int -> unit -> int +end + +module type FT = functor (M : Arg) -> sig + val run : unit -> int +end + +module type Higher = functor (F : FT) (M : Arg) -> sig + val run : unit -> int +end + +module Impl_a (M : Arg) = struct + let run () = M.g ~y:1 () +end + +module Impl_b (M : Arg) = struct + let run () = M.g ~y:2 () +end + +module Fixpoint_a : Arg = struct + let g ?(y = 0) () = y +end + +module Fixpoint_b : Arg = struct + let g ?(y = 0) () = y +end + +module Outer (F : FT) (M : Arg) = F (M) +module Top (H : Higher) (F : FT) (M : Arg) = H (F) (M) +module Direct = Outer (Impl_a) (Fixpoint_a) +module Indirect = Top (Outer) (Impl_b) (Fixpoint_b) + +let run () = ignore (Direct.run () + Indirect.run ()) diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 672364c8..08ef31be 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -54,4 +54,8 @@ let () = Higher_order_more.run (); Higher_order_more.run_anon (); Higher_order_more.run_nested (); - Higher_order_more.run_both () + Higher_order_more.run_both (); + Reference_order.run (); + Higher_order_fixpoint.run (); + Packed_interface_use.run (); + Escape_exports.run () diff --git a/examples/regression/src/Packed_interface.ml b/examples/regression/src/Packed_interface.ml new file mode 100644 index 00000000..6e759179 --- /dev/null +++ b/examples/regression/src/Packed_interface.ml @@ -0,0 +1,5 @@ +module Impl (M : Packed_types.Arg) = struct + let run () = M.g ~x:1 () +end + +let packed = (module Impl : Packed_types.FT) diff --git a/examples/regression/src/Packed_interface.mli b/examples/regression/src/Packed_interface.mli new file mode 100644 index 00000000..0bbc79e9 --- /dev/null +++ b/examples/regression/src/Packed_interface.mli @@ -0,0 +1 @@ +val packed : (module Packed_types.FT) diff --git a/examples/regression/src/Packed_interface_use.ml b/examples/regression/src/Packed_interface_use.ml new file mode 100644 index 00000000..fd0a21f6 --- /dev/null +++ b/examples/regression/src/Packed_interface_use.ml @@ -0,0 +1,8 @@ +module Packed_arg : Packed_types.Arg = struct + let g ?(x = 0) () = x +end + +module Outer (F : Packed_types.FT) (M : Packed_types.Arg) = F (M) +module A = Outer ((val Packed_interface.packed : Packed_types.FT)) (Packed_arg) + +let run () = ignore (A.run ()) diff --git a/examples/regression/src/Packed_types.ml b/examples/regression/src/Packed_types.ml new file mode 100644 index 00000000..bb958165 --- /dev/null +++ b/examples/regression/src/Packed_types.ml @@ -0,0 +1,7 @@ +module type Arg = sig + val g : ?x:int -> unit -> int +end + +module type FT = functor (M : Arg) -> sig + val run : unit -> int +end diff --git a/examples/regression/src/Reference_order.ml b/examples/regression/src/Reference_order.ml new file mode 100644 index 00000000..d068a8ae --- /dev/null +++ b/examples/regression/src/Reference_order.ml @@ -0,0 +1,55 @@ +(* An ordinary unresolved reference must remain forwardable even when a + parameter reference to the same item is visited later in the binding. *) +module Parameter_first = struct + module type S = sig + val f : unit -> int + end + + module Used : S = struct + let f () = 11 + end + + module Param : S = struct + let f () = 12 + end + + let packed = (module Used : S) + let through x = x + + module F (M : S) = struct + let run () = + let module N = (val through packed : S) in + ignore (M.f ()); + N.f () + end + + module A = F (Param) +end + +module Ordinary_first = struct + module type S = sig + val f : unit -> int + end + + module Used : S = struct + let f () = 21 + end + + module Param : S = struct + let f () = 22 + end + + let packed = (module Used : S) + let through x = x + + module F (M : S) = struct + let run () = + let module N = (val through packed : S) in + ignore (N.f ()); + M.f () + end + + module A = F (Param) +end + +let run () = ignore (Parameter_first.A.run () + Ordinary_first.A.run ()) diff --git a/examples/regression/src/dune b/examples/regression/src/dune index 341bd8bf..b388e19c 100644 --- a/examples/regression/src/dune +++ b/examples/regression/src/dune @@ -5,9 +5,11 @@ Cross_alias_use Cross_c Cross_include + Escape_exports Functor_argument Generated_source Higher_order + Higher_order_fixpoint Higher_order_more Included_sig Live_ancestors @@ -15,6 +17,10 @@ Main Nested_module_type Ocaml_compiler_compat + Packed_interface + Packed_interface_use + Packed_types + Reference_order Shared_signature Shared_signature_arg Shared_signature_unused diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index 5d597cbf..07d3d809 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -125,6 +125,12 @@ function runRegressionTests() { assertNotIncludes(output, "Dead Value +Shared_signature_arg.Chosen.+f"); assertIncludes(output, "Live Value +Shared_signature_arg.Local_used.+f"); assertNotIncludes(output, "Dead Value +Shared_signature_arg.Local_used.+f"); + // A parameter access must not suppress an ordinary access from the same + // binding, regardless of which occurrence the mapper visits first. + for (const order of ["Parameter_first", "Ordinary_first"]) { + assertIncludes(output, `Live Value +Reference_order.${order}.Used.+f`); + assertNotIncludes(output, `Dead Value +Reference_order.${order}.Used.+f`); + } // A call through a functor parameter is credited to the actual argument // (conservatively, to every implementation of the item, before OCaml 5.3): // x must never be reported unused. @@ -527,6 +533,32 @@ function runRegressionTests() { ); assertNotIncludes(output, "P4_b.+u is never used"); assertNotIncludes(output, "P4_a.+u is never used"); + // New enclosing applications discovered on later fixed-point rounds + // still instantiate the original parameter-headed application. + for (const name of ["Fixpoint_a", "Fixpoint_b"]) { + assertIncludes( + output, + `optional argument y of function ${name}.+g is always supplied (1 calls)` + ); + } + // A packed higher-order argument exported through an .mli resolves to + // the implementation binding where its functor was registered. + assertIncludes( + output, + "optional argument x of function Packed_arg.+g is always supplied (1 calls)" + ); + // Escaping holders also expose functors defined outside their lexical + // range through module aliases and includes. + for (const [name, argument] of [ + ["Escaped_alias_arg", "alias"], + ["Escaped_include_arg", "included"], + ]) { + assertIncludes( + output, + `optional argument ${argument} of function ${name}.+g is always supplied` + ); + assertNotIncludes(output, `${name}.+g is never used`); + } } assertNotIncludes(output, "Parent is a dead module"); diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 54d1b555..54a9a427 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -284,10 +284,21 @@ let rec resolveArgumentItems ~visited ~bindings functorDef argIndex components let hasApplication functorDef argIndex = applicationsOf ~bindings:[] functorDef argIndex <> [] +(* The packed module a value position denotes: bound there, or declared + there in an interface and bound at the implementation position. *) +let findPackedModule ~sigToImpl pos = + match Hashtbl.find_opt packedModules pos with + | Some packed -> Some packed + | None -> ( + match Hashtbl.find_opt sigToImpl pos with + | Some implPos -> Hashtbl.find_opt packedModules implPos + | None -> None) + (* The functors (a submodule of) the argument at [argIndex] of the applications of [functorDef] denotes: their keys, the arguments they consumed, and the applications they came through. *) -let rec resolveHeads ~visited ~bindings functorDef argIndex components = +let rec resolveHeads ~sigToImpl ~visited ~bindings functorDef argIndex + components = if List.mem (functorDef, argIndex, components) visited then [] else let visited = (functorDef, argIndex, components) :: visited in @@ -297,16 +308,17 @@ let rec resolveHeads ~visited ~bindings functorDef argIndex components = match argHead components with | Some (Key (pos, consumed)) -> [(pos, consumed, here)] | Some (ParamHead (def, index, prefix, consumed)) -> - resolveHeads ~visited ~bindings:here def index (prefix @ components) + resolveHeads ~sigToImpl ~visited ~bindings:here def index + (prefix @ components) |> List.map (fun (pos, consumed', bindings) -> (pos, consumed + consumed', bindings)) | Some (Packed (pos, consumed)) -> ( - match (Hashtbl.find_opt packedModules pos, components) with + match (findPackedModule ~sigToImpl pos, components) with | Some {packedHead = Some (Key (key, consumed'))}, [] -> [(key, consumed + consumed', here)] | ( Some {packedHead = Some (ParamHead (def, index, prefix, consumed'))}, [] ) -> - resolveHeads ~visited ~bindings:here def index prefix + resolveHeads ~sigToImpl ~visited ~bindings:here def index prefix |> List.map (fun (pos, consumed'', bindings) -> (pos, consumed + consumed' + consumed'', bindings)) | _ -> []) @@ -317,16 +329,6 @@ let rec resolveHeads ~visited ~bindings functorDef argIndex components = itself come through a parameter; the ones left unresolved (the enclosing functor is never applied, or applied to something not resolvable) are dropped, and the calls they would credit fall back to forwarding. *) -(* The packed module a value position denotes: bound there, or declared - there in an interface and bound at the implementation position. *) -let findPackedModule ~sigToImpl pos = - match Hashtbl.find_opt packedModules pos with - | Some packed -> Some packed - | None -> ( - match Hashtbl.find_opt sigToImpl pos with - | Some implPos -> Hashtbl.find_opt packedModules implPos - | None -> None) - let resolveParameterHeadedApplications ~sigToImpl = (* First-class modules, from the values they were packed into. *) delayedApplications := @@ -349,32 +351,70 @@ let resolveParameterHeadedApplications ~sigToImpl = } | _ -> application) | _ -> application); + (* Keep the templates until the whole fixed point is complete: resolving + one head does not mean all enclosing applications are known yet. *) + let templates = + !delayedApplications + |> List.filter (fun {appliedFunctor} -> + match appliedFunctor with ParamHead _ -> true | _ -> false) + in + let normalizeBindings bindings = + bindings + |> List.fold_left + (fun acc ((def, _) as binding) -> + if List.mem_assoc def acc then acc else binding :: acc) + [] + |> List.sort compare + in + (* Function-valued resolvers cannot be compared. The original application + identity, target argument, and effective enclosing bindings identify a + derived application without comparing those closures. *) + let key {applicationId; appliedFunctor; argIndex; bindings} = + (applicationId, appliedFunctor, argIndex, normalizeBindings bindings) + in + let known = Hashtbl.create 16 in + List.iter (fun application -> Hashtbl.replace known (key application) ()) + !delayedApplications; + let heads application def index components = + resolveHeads ~sigToImpl ~visited:[] ~bindings:application.bindings def + index components + in let rec loop () = - let progress = ref false in - delayedApplications := - !delayedApplications - |> List.concat_map (fun application -> - match application.appliedFunctor with - | Key _ | Packed _ -> [application] - | ParamHead (def, index, components, consumed) -> ( - match - resolveHeads ~visited:[] ~bindings:application.bindings def - index components - with - | [] -> [application] - | heads -> - progress := true; - heads - |> List.map (fun (pos, consumed', bindings) -> - { - application with - appliedFunctor = Key (pos, 0); - argIndex = application.argIndex + consumed + consumed'; - bindings = bindings @ application.bindings; - }))); - if !progress then loop () + let additions = ref [] in + templates + |> List.iter (fun application -> + match application.appliedFunctor with + | ParamHead (def, index, components, consumed) -> + heads application def index components + |> List.iter (fun (pos, consumed', bindings) -> + let derived = + { + application with + appliedFunctor = Key (pos, 0); + argIndex = application.argIndex + consumed + consumed'; + bindings = + normalizeBindings (bindings @ application.bindings); + } + in + let key = key derived in + if not (Hashtbl.mem known key) then ( + Hashtbl.add known key (); + additions := derived :: !additions)) + | Key _ | Packed _ -> ()); + if !additions <> [] then ( + delayedApplications := !delayedApplications @ List.rev !additions; + loop ()) in loop (); + (* Only genuinely unresolved templates escape; retaining resolved ones + here would unnecessarily forward precisely attributed calls. *) + delayedApplications := + !delayedApplications + |> List.filter (fun application -> + match application.appliedFunctor with + | ParamHead (def, index, components, _) -> + heads application def index components = [] + | Key _ | Packed _ -> true); !delayedApplications |> List.iter (fun {appliedFunctor; argIndex; argHead; argRange} -> match appliedFunctor with @@ -409,7 +449,7 @@ let escapedKeysAndRanges ~sigToImpl = match head with | Key (pos, _) -> ([pos], []) | ParamHead (def, index, components, _) -> - ( resolveHeads ~visited:[] ~bindings:[] def index components + ( resolveHeads ~sigToImpl ~visited:[] ~bindings:[] def index components |> List.map (fun (pos, _, _) -> pos), resolveRanges ~visited:[] def index ) | Packed (pos, _) -> ( @@ -419,7 +459,7 @@ let escapedKeysAndRanges ~sigToImpl = | Some {packedHead = Some (ParamHead (def, index, components, _)); packedRange} -> - ( resolveHeads ~visited:[] ~bindings:[] def index components + ( resolveHeads ~sigToImpl ~visited:[] ~bindings:[] def index components |> List.map (fun (pos, _, _) -> pos), packedRange @ resolveRanges ~visited:[] def index ) | Some {packedRange} -> ([], packedRange) @@ -640,6 +680,7 @@ module PosPairSet = Set.Make (struct end) let nonForwardableReferences = ref PosPairSet.empty +let ordinaryReferences = ref PosPairSet.empty let effectiveLocFrom (locFrom : Location.t) = let lastBinding = !Current.lastBinding in @@ -659,14 +700,18 @@ let addValueReferenceOrRedirect ~(locFrom : Location.t) ~(locTo : Location.t) ~path = let pair = (locTo.loc_start, (effectiveLocFrom locFrom).loc_start) in let locToImpl = findResolution ~identLoc:locFrom ~path in - (if isFunctorParameterPath path && Compat.shapeResolutionAvailable then - nonForwardableReferences := PosPairSet.add pair !nonForwardableReferences - else if locToImpl = None && PosPairSet.mem pair !nonForwardableReferences - then - (* A non-parameter reference from the same position that stays targeted - at the module type item keeps the pair forwardable. A redirected one - does not: it never lands on the item. *) - nonForwardableReferences := PosPairSet.remove pair !nonForwardableReferences); + (if isFunctorParameterPath path && Compat.shapeResolutionAvailable then ( + if not (PosPairSet.mem pair !ordinaryReferences) then + nonForwardableReferences := PosPairSet.add pair !nonForwardableReferences) + else + match locToImpl with + | Some (impl : Location.t) when impl.loc_start <> locTo.loc_start -> () + | _ -> + (* Once an ordinary occurrence lands on this item, the pair remains + forwardable regardless of later parameter occurrences from the + same enclosing binding. Redirected occurrences do not land here. *) + ordinaryReferences := PosPairSet.add pair !ordinaryReferences; + nonForwardableReferences := PosPairSet.remove pair !nonForwardableReferences); addRedirect ~locFrom ~locTo ~locToImpl (* An application of an inline functor, [(functor (A : S) -> body) (X)]: @@ -788,7 +833,21 @@ let rec definitionRange ?(visited = []) ?(resolutions = !identResolutions) else let visited = e :: visited in match e.mod_desc with - | Tmod_structure _ | Tmod_functor _ -> own + | Tmod_structure {str_items} -> + own + @ (str_items + |> List.concat_map (fun (item : Typedtree.structure_item) -> + match item.str_desc with + | Tstr_module {mb_expr} -> + definitionRange ~visited ~resolutions mb_expr + | Tstr_recmodule bindings -> + bindings + |> List.concat_map (fun (binding : Typedtree.module_binding) -> + definitionRange ~visited ~resolutions binding.mb_expr) + | Tstr_include {incl_mod} -> + definitionRange ~visited ~resolutions incl_mod + | _ -> [])) + | Tmod_functor (_, body) -> own @ definitionRange ~visited ~resolutions body | Tmod_constraint (inner, _, _, _) -> definitionRange ~visited ~resolutions inner | Tmod_ident (path, _) -> definitionRangeOfPath ~visited ~resolutions path @@ -810,9 +869,14 @@ let rec definitionRange ?(visited = []) ?(resolutions = !identResolutions) and definitionRangeOfPath ?(visited = []) ?(resolutions = !identResolutions) (path : Path.t) = match resolutions.bindingOfPath path with - | Some (_, definition, definingResolver, _) -> + | Some (loc, definition, definingResolver, _) -> let resolutions = Option.value definingResolver ~default:resolutions in - definitionRange ~visited ~resolutions definition + (* A named functor is keyed at its binding name, which precedes the + module expression's range. Aliases must retain that key as well. *) + let bindingRange = + if loc.loc_ghost then [] else [(loc.loc_start, loc.loc_end)] + in + bindingRange @ definitionRange ~visited ~resolutions definition | None -> [] (* The functor a module expression applies, and the number of arguments From e77c9f30096ff06472a5be7e018fd3670f639414 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 17 Sep 2026 10:51:05 +0000 Subject: [PATCH 45/53] Keep derived functor applications in their enclosing contexts --- .../regression/src/Higher_order_fixpoint.ml | 11 ++++++++++- scripts/run_integration_tests.js | 6 ++++++ src/DeadValue.ml | 19 ++++++++++++++----- 3 files changed, 30 insertions(+), 6 deletions(-) diff --git a/examples/regression/src/Higher_order_fixpoint.ml b/examples/regression/src/Higher_order_fixpoint.ml index 1fd85404..6873163e 100644 --- a/examples/regression/src/Higher_order_fixpoint.ml +++ b/examples/regression/src/Higher_order_fixpoint.ml @@ -20,6 +20,10 @@ module Impl_b (M : Arg) = struct let run () = M.g ~y:2 () end +module Impl_c (M : Arg) = struct + let run () = M.g () +end + module Fixpoint_a : Arg = struct let g ?(y = 0) () = y end @@ -28,9 +32,14 @@ module Fixpoint_b : Arg = struct let g ?(y = 0) () = y end +module Fixpoint_c : Arg = struct + let g ?(y = 0) () = y +end + module Outer (F : FT) (M : Arg) = F (M) module Top (H : Higher) (F : FT) (M : Arg) = H (F) (M) module Direct = Outer (Impl_a) (Fixpoint_a) module Indirect = Top (Outer) (Impl_b) (Fixpoint_b) +module Indirect_c = Top (Outer) (Impl_c) (Fixpoint_c) -let run () = ignore (Direct.run () + Indirect.run ()) +let run () = ignore (Direct.run () + Indirect.run () + Indirect_c.run ()) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index 07d3d809..9946d577 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -541,6 +541,12 @@ function runRegressionTests() { `optional argument y of function ${name}.+g is always supplied (1 calls)` ); } + // The two indirect applications share a source application ID but not + // an enclosing context: C's omitted argument must not mix with B's call. + assertIncludes( + output, + "optional argument y of function Fixpoint_c.+g is never used" + ); // A packed higher-order argument exported through an .mli resolves to // the implementation binding where its functor was registered. assertIncludes( diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 54a9a427..ad53413c 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -191,13 +191,22 @@ let nextApplicationId = ref 0 [argIndex], under [bindings]. *) let applicationsOf ~bindings functorDef argIndex = !delayedApplications - |> List.filter (fun {applicationId; appliedFunctor; argIndex = index} -> + |> List.filter (fun {applicationId; appliedFunctor; argIndex = index; + bindings = own} -> appliedFunctor = Key (functorDef, 0) && index = argIndex - && - match List.assoc_opt functorDef bindings with - | Some id -> id = applicationId - | None -> true) + && (match List.assoc_opt functorDef bindings with + | Some id -> id = applicationId + | None -> true) + (* A template instantiated through different enclosing applications + retains its source ID. Its inherited context must agree too, + before the caller prepends [own] to the requested bindings. *) + && List.for_all + (fun (def, id) -> + match List.assoc_opt def bindings with + | Some requested -> id = requested + | None -> true) + own) (* Functors whose applications cannot all be seen: packed as first-class modules that flow somewhere other than a direct [(val p)], or passed to From 96d32135e65af28a24bb7a60a902d794d68f05f0 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 17 Sep 2026 12:46:20 +0000 Subject: [PATCH 46/53] Preserve unpacked functor calls and deduplicate native scans --- .../duplicate_native/Duplicate_native.ml | 2 + examples/regression/src/Main.ml | 4 +- examples/regression/src/Unpacked_functor.ml | 17 +++ .../regression/src/Unpacked_functor_use.ml | 11 ++ examples/regression/src/Unpacked_include.ml | 12 ++ examples/regression/src/dune | 5 +- scripts/run_integration_tests.js | 127 ++++++++++++++++++ src/Compat.ml | 43 +++++- src/DeadOptionalArgs.ml | 12 +- src/DeadValue.ml | 96 +++++++++---- src/Reanalyze.ml | 2 +- 11 files changed, 288 insertions(+), 43 deletions(-) create mode 100644 examples/regression/duplicate_native/Duplicate_native.ml create mode 100644 examples/regression/src/Unpacked_functor.ml create mode 100644 examples/regression/src/Unpacked_functor_use.ml create mode 100644 examples/regression/src/Unpacked_include.ml diff --git a/examples/regression/duplicate_native/Duplicate_native.ml b/examples/regression/duplicate_native/Duplicate_native.ml new file mode 100644 index 00000000..210e3077 --- /dev/null +++ b/examples/regression/duplicate_native/Duplicate_native.ml @@ -0,0 +1,2 @@ +let g ?(x = 0) () = x +let () = ignore (g ~x:1 ()) diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 08ef31be..26278769 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -58,4 +58,6 @@ let () = Reference_order.run (); Higher_order_fixpoint.run (); Packed_interface_use.run (); - Escape_exports.run () + Escape_exports.run (); + Unpacked_functor_use.run (); + Unpacked_include.run () diff --git a/examples/regression/src/Unpacked_functor.ml b/examples/regression/src/Unpacked_functor.ml new file mode 100644 index 00000000..8f3e88f5 --- /dev/null +++ b/examples/regression/src/Unpacked_functor.ml @@ -0,0 +1,17 @@ +module type Arg = sig val g : ?x:int -> unit -> int end +module type FT = functor (M : Arg) -> sig val run : unit -> int end + +module Impl (M : Arg) = struct let run () = M.g ~x:1 () end +let packed = (module Impl : FT) +module G = (val packed : FT) +module Alias = G + +module type Nested_arg = sig val g : ?nested:int -> unit -> int end +module type Holder_t = sig + module Inner (M : Nested_arg) : sig val run : unit -> int end +end +module Holder_impl = struct + module Inner (M : Nested_arg) = struct let run () = M.g ~nested:1 () end +end +let holder = (module Holder_impl : Holder_t) +module Holder = (val holder : Holder_t) diff --git a/examples/regression/src/Unpacked_functor_use.ml b/examples/regression/src/Unpacked_functor_use.ml new file mode 100644 index 00000000..153c21aa --- /dev/null +++ b/examples/regression/src/Unpacked_functor_use.ml @@ -0,0 +1,11 @@ +module Unpacked_arg : Unpacked_functor.Arg = struct let g ?(x = 0) () = x end +module Unpacked_unused : Unpacked_functor.Arg = struct let g ?(x = 0) () = x end +module Applied = Unpacked_functor.Alias (Unpacked_arg) +module Unpacked_nested_arg : Unpacked_functor.Nested_arg = struct + let g ?(nested = 0) () = nested +end +module Applied_nested = Unpacked_functor.Holder.Inner (Unpacked_nested_arg) +let run () = + ignore (Applied.run ()); + ignore (Applied_nested.run ()); + ignore (Unpacked_unused.g ()) diff --git a/examples/regression/src/Unpacked_include.ml b/examples/regression/src/Unpacked_include.ml new file mode 100644 index 00000000..261062ec --- /dev/null +++ b/examples/regression/src/Unpacked_include.ml @@ -0,0 +1,12 @@ +module type Arg = sig val g : ?included:int -> unit -> int end +module type Holder_t = sig + module Inner (M : Arg) : sig val run : unit -> int end +end +module Holder = struct + module Inner (M : Arg) = struct let run () = M.g ~included:1 () end +end +let packed = (module Holder : Holder_t) +include (val packed : Holder_t) +module Unpacked_include_arg : Arg = struct let g ?(included = 0) () = included end +module Applied = Inner (Unpacked_include_arg) +let run () = ignore (Applied.run ()) diff --git a/examples/regression/src/dune b/examples/regression/src/dune index b388e19c..4f5be13f 100644 --- a/examples/regression/src/dune +++ b/examples/regression/src/dune @@ -25,5 +25,8 @@ Shared_signature_arg Shared_signature_unused Shared_signature_use - Shared_signature_used) + Shared_signature_used + Unpacked_functor + Unpacked_functor_use + Unpacked_include) (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 9946d577..5282e93b 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -553,6 +553,24 @@ function runRegressionTests() { output, "optional argument x of function Packed_arg.+g is always supplied (1 calls)" ); + // A foreign unpacked functor (and its alias) has no shape uid. Resolve + // its packed binding precisely; an unpacked include escapes instead. + assertIncludes( + output, + "optional argument x of function Unpacked_arg.+g is always supplied (1 calls)" + ); + assertIncludes( + output, + "optional argument x of function Unpacked_unused.+g is never used" + ); + assertIncludes( + output, + "optional argument included of function Unpacked_include_arg.+g is always supplied (1 calls)" + ); + assertIncludes( + output, + "optional argument nested of function Unpacked_nested_arg.+g is always supplied (1 calls)" + ); // Escaping holders also expose functors defined outside their lexical // range through module aliases and includes. for (const [name, argument] of [ @@ -653,6 +671,113 @@ function runDuplicateLayoutTest() { } } +// Compile the same source as bytecode and native code, as Dune does: the +// native compilation reuses the bytecode .cmi and records no interface digest. +function runByteNativeDuplicateTest() { + const fs = require("fs"); + const os = require("os"); + const cwd = fs.mkdtempSync(path.join(os.tmpdir(), "reanalyze-native-")); + const source = path.join( + __dirname, + "..", + "examples", + "regression", + "duplicate_native", + "Duplicate_native.ml" + ); + try { + for (const dir of ["byte", "native"]) fs.mkdirSync(path.join(cwd, dir)); + child_process.execFileSync( + "ocamlc", + ["-bin-annot", "-c", "-o", "byte/Duplicate_native.cmo", source], + { cwd } + ); + child_process.execFileSync( + "ocamlopt", + [ + "-bin-annot", "-intf-suffix", ".ml", "-I", "byte", "-c", + "-o", "native/Duplicate_native.cmx", source, + ], + { cwd } + ); + const run = (root) => + child_process.execFileSync( + reanalyzeFile, + ["-ci", "-dce-cmt", root], + { cwd, encoding: "utf8" } + ); + console.log(`${cwd}: reanalyze byte/native duplicate comparison`); + const single = run("byte"); + assertIncludes( + single, + "optional argument x of function +g is always supplied (1 calls)" + ); + if (single !== run(".")) { + throw new Error( + "Scanning byte and native artifacts changed optional-call counts" + ); + } + } finally { + fs.rmSync(cwd, { recursive: true, force: true }); + } +} + +function runUnpackedScanOrderTest() { + if (!ocamlVersionAtLeast(5, 3)) return; + const fs = require("fs"); + const os = require("os"); + const cwd = path.join(__dirname, "..", "examples", "regression"); + const cmtDir = path.join(cwd, "_build/default/src/.regression_fixture.objs/byte"); + const root = fs.mkdtempSync(path.join(os.tmpdir(), "reanalyze-unpack-order-")); + try { + for (const dir of ["first", "second"]) fs.mkdirSync(path.join(root, dir)); + const files = fs.readdirSync(cmtDir).filter((file) => /\.cmti?$/.test(file)); + const provider = "regression_fixture__Unpacked_functor.cmt"; + const consumer = "regression_fixture__Unpacked_functor_use.cmt"; + const orders = []; + console.log(`${cwd}: reanalyze unpacked functors in both scan orders`); + for (const providerDir of ["first", "second"]) { + const otherDir = providerDir === "first" ? "second" : "first"; + for (const file of files) { + const dir = file === provider ? providerDir : otherDir; + fs.copyFileSync(path.join(cmtDir, file), path.join(root, dir, file)); + } + const output = child_process.execFileSync( + reanalyzeFile, + ["-ci", "-debug", "-native-build-target", ".", "-dce-cmt", root], + { cwd, encoding: "utf8", maxBuffer: 256 * 1024 * 1024 } + ); + assertIncludes(output, `Scanning ${provider} `); + assertIncludes(output, `Scanning ${consumer} `); + orders.push( + output.indexOf(`Scanning ${provider} `) < + output.indexOf(`Scanning ${consumer} `) + ); + assertIncludes( + output, + "optional argument x of function Unpacked_arg.+g is always supplied (1 calls)" + ); + assertIncludes( + output, + "optional argument x of function Unpacked_unused.+g is never used" + ); + assertIncludes( + output, + "optional argument nested of function Unpacked_nested_arg.+g is always supplied (1 calls)" + ); + for (const file of files) { + const dir = file === provider ? providerDir : otherDir; + fs.unlinkSync(path.join(root, dir, file)); + } + } + if (orders[0] === orders[1]) { + throw new Error("Scan-order test did not reverse the unit order"); + } + } finally { + fs.rmSync(root, { recursive: true, force: true }); + } +} + function checkSetup() { console.log("Checking if --version outputs the right version"); let output; @@ -686,6 +811,8 @@ function main() { cleanBuildExamples(); runRegressionTests(); runDuplicateLayoutTest(); + runByteNativeDuplicateTest(); + runUnpackedScanOrderTest(); checkDiff(); console.log("Test successful!"); diff --git a/src/Compat.ml b/src/Compat.ml index f3d90f78..946a838e 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -338,10 +338,12 @@ let registerCmtFile path = Hashtbl.replace cmtFilesByUnit unit (path :: existing) #if OCAML_VERSION >= (5, 3, 0) -(* Per compilation unit: the implementation shape (from the .cmt) and the - uid -> declaration table (merged from .cmt and .cmti). Loaded on demand. *) +(* Per compilation unit: the implementation shape and structure (from the + .cmt), and the uid -> declaration table (merged from .cmt and .cmti). + Loaded on demand. *) type unitInfo = { shape : Shape.t option; + structure : Typedtree.structure option; uidToDecl : Typedtree.item_declaration Shape.Uid.Tbl.t; cmtPath : string; (** the .cmt (or, failing that, the first file) loaded *) unitImports : Misc.crcs; @@ -476,13 +478,20 @@ let loadUnitInfo ~currentCmtFile ~(imports : Misc.crcs) comp_unit = shape := cmt_infos.cmt_impl_shape; implementation := Some (path, cmt_infos) | _ -> ()); - let cmtPath, unitImports, occurrences = + let cmtPath, unitImports, occurrences, structure = match (!implementation, loaded) with | Some (path, cmt_infos), _ | None, (path, cmt_infos) :: _ -> - (path, cmt_infos.cmt_imports, cmt_infos.cmt_ident_occurrences) - | None, [] -> ("", [], []) + let structure = + match cmt_infos.cmt_annots with + | Implementation structure -> Some structure + | _ -> None + in + (path, cmt_infos.cmt_imports, cmt_infos.cmt_ident_occurrences, structure) + | None, [] -> ("", [], [], None) + in + let info = + {shape = !shape; structure; uidToDecl; cmtPath; unitImports; occurrences} in - let info = {shape = !shape; uidToDecl; cmtPath; unitImports; occurrences} in Hashtbl.replace unitInfoCache cacheKey info; Some info) @@ -973,7 +982,27 @@ let rec makeResolver ~cmtFilePath | Some binding -> Some binding | None -> match path with - | Pident id when Ident.global id -> None + | Pident id when Ident.global id -> ( + (* Unpacked modules have uid-less shapes. Keep the unit's structure + available so a projection can still find their actual binding. *) + let unitName = Ident.name id in + match loadUnitInfo ~currentCmtFile:cmtFilePath ~imports unitName with + | Some {structure = Some structure} -> + let definition : Typedtree.module_expr = + { + mod_desc = Tmod_structure structure; + mod_loc = Location.none; + mod_type = Types.Mty_signature structure.str_type; + mod_env = structure.str_final_env; + mod_attributes = []; + } + in + Some + ( Location.none, + definition, + resolverForUnit ~currentCmtFile:cmtFilePath ~imports unitName, + 0 ) + | _ -> None) | Pident id -> ( let uid = localUid (function diff --git a/src/DeadOptionalArgs.ml b/src/DeadOptionalArgs.ml index 5250c422..61deef4c 100644 --- a/src/DeadOptionalArgs.ml +++ b/src/DeadOptionalArgs.ml @@ -7,10 +7,6 @@ type item = { posTo : Lexing.position; posToImpl : Lexing.position option; (** Shape-resolved implementation, used when [posTo] is not a declaration. *) - forwardable : bool; - (** Whether the call may be attributed to the implementations of a module - type item. False for calls through a functor parameter, which are - credited at application sites. *) argNames : string list; argNamesMaybe : string list; } @@ -53,14 +49,14 @@ let rec fromTypeExpr (texpr : Types.type_expr) = | _ -> [] let addReferences ~(locFrom : Location.t) ~(locTo : Location.t) - ?(locToImpl : Location.t option) ?(forwardable = true) ~path + ?(locToImpl : Location.t option) ~path (argNames, argNamesMaybe) = if active () then ( let posTo = locTo.loc_start in let posToImpl = Option.map (fun (l : Location.t) -> l.loc_start) locToImpl in let posFrom = locFrom.loc_start in delayedItems := - {posTo; posToImpl; forwardable; argNames; argNamesMaybe} :: !delayedItems; + {posTo; posToImpl; argNames; argNamesMaybe} :: !delayedItems; if !Common.Cli.debug then Log_.item "DeadOptionalArgs.addReferences %s called with optional argNames:%s \ @@ -79,7 +75,7 @@ let addCallToImplementation ~(posTo : Lexing.position) (argNames, argNamesMaybe) = if active () then delayedItems := - {posTo; posToImpl = None; forwardable = true; argNames; argNamesMaybe} + {posTo; posToImpl = None; argNames; argNamesMaybe} :: !delayedItems (* Once all declarations are known, calls whose target is not a declaration @@ -101,7 +97,7 @@ let forwardDelayedItems ~(posFrom : Lexing.position) ~(posTo : Lexing.position) let forwarded = !delayedItems |> List.filter_map (fun item -> - if item.forwardable && item.posTo = posFrom then + if item.posTo = posFrom then Some {item with posTo} else None) in diff --git a/src/DeadValue.ml b/src/DeadValue.ml index ad53413c..c904277b 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -114,9 +114,6 @@ type functorParameter = { let functorParameters : functorParameter list ref = ref [] -(* Name position of the module binding being traversed, see [Tstr_module]. *) -let currentModuleBindingPos = ref Lexing.dummy_pos - let findFunctorParameter (path : Path.t) = match Path.head path with | head -> List.find_opt (fun p -> Ident.same p.paramId head) !functorParameters @@ -654,8 +651,7 @@ let processOptionalArgs ~expType ~(locFrom : Location.t) ~locTo ?locToImpl resolution it can only be forwarded to every implementation. *) if parameter = None || not Compat.shapeResolutionAvailable then call - |> DeadOptionalArgs.addReferences ~locFrom ~locTo ?locToImpl - ~forwardable:true ~path) + |> DeadOptionalArgs.addReferences ~locFrom ~locTo ?locToImpl ~path) (* Implementation locations of identifier occurrences resolved through shapes. See [Compat.resolveIdentOccurrences]. *) @@ -888,6 +884,37 @@ and definitionRangeOfPath ?(visited = []) ?(resolutions = !identResolutions) bindingRange @ definitionRange ~visited ~resolutions definition | None -> [] +(* Unlike ordinary functor keys, an unpacked head refers to a value binding + whose pack may be registered later, in another unit or behind an .mli. + Chase aliases using each definition's own resolver, without depending on + traversal order or on the unpack's (possibly uid-less) shape. *) +let packedHeadOfPath resolutions path = + let rec ofPath visited (resolutions : Compat.identResolutions) path consumed = + match resolutions.bindingOfPath path with + | Some (_, definition, resolver, applied) -> + let resolutions = Option.value resolver ~default:resolutions in + ofExpr visited resolutions definition (consumed + applied) + | None -> None + and ofExpr visited resolutions (e : Typedtree.module_expr) consumed = + if List.memq e visited then None + else + let visited = e :: visited in + match e.mod_desc with + | Tmod_constraint (inner, _, _, _) -> + ofExpr visited resolutions inner consumed + | Tmod_apply (inner, _, _) -> + ofExpr visited resolutions inner (consumed + 1) +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit inner -> + ofExpr visited resolutions inner (consumed + 1) +#endif + | Tmod_ident (path, _) -> ofPath visited resolutions path consumed + | Tmod_unpack (packed, _) -> + unpackedBinding packed |> Option.map (fun pos -> Packed (pos, consumed)) + | _ -> None + in + ofPath [] resolutions path 0 + (* The functor a module expression applies, and the number of arguments already consumed by partial applications it stands for, as in [module G = F (A)] followed by [G (B)]. Aliases ([module G = F]) are @@ -975,7 +1002,14 @@ and headOfPath ?lid (path : Path.t) components : functorHead option = | f :: rest -> ( match f () with Some head -> Some head | None -> first rest) in - first [byParameter; byBinding; byIdent; byResolver] + first + [ + byParameter; + byBinding; + byIdent; + (fun () -> packedHeadOfPath !identResolutions extended); + byResolver; + ] (* Register the head a module binding stands for, when its right-hand side is an alias, an application or an unpacking (see [headsByBinding]). *) @@ -1723,10 +1757,13 @@ let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = components |> List.fold_left (fun p name -> Path.Pdot (p, name)) path in - match resolutions.headKeyOfPath extended with - | Some ((loc : Location.t), consumed) -> - Some (Key (loc.loc_start, consumed)) - | None -> None) + match packedHeadOfPath resolutions extended with + | Some head -> Some head + | None -> ( + match resolutions.headKeyOfPath extended with + | Some ((loc : Location.t), consumed) -> + Some (Key (loc.loc_start, consumed)) + | None -> None)) | _, None, None -> None in match head with @@ -1734,9 +1771,10 @@ let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = (* The functors passed to an application whose head cannot be chased (a first-class module from elsewhere, a member of the result of an applied functor parameter) escape: their calls can only be - forwarded. So does what the head's root stands for, when it is a - parameter: [G.Inner (X)] with [module G = F (A)] applies a functor - nested in the argument passed for [F]. *) + forwarded. So does the nearest resolvable parent of the head: + [G.Inner (X)] with [module G = F (A)] applies a functor nested in + the argument passed for [F], while [Other.G.Inner (X)] may apply + one nested in a foreign unpacked module. *) args |> List.iter (fun argumentExpr -> match argumentExpr with @@ -1746,15 +1784,17 @@ let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = | Some head -> escapedHeads := head :: !escapedHeads | None -> ()) | None -> ()); + let rec escapeParent = function + | Path.Pdot (parent, _) -> ( + match headOfPath parent [] with + | Some head -> + escapedHeads := head :: !escapedHeads; + escapedRanges := definitionRangeOfPath parent @ !escapedRanges + | None -> escapeParent parent) + | _ -> () + in (match headExpr.mod_desc with - | Tmod_ident ((Pdot _ as path), _) -> ( - match headOfPath (Pident (Path.head path)) [] with - | Some root -> - escapedHeads := root :: !escapedHeads; - escapedRanges := - definitionRangeOfPath (Pident (Path.head path)) @ !escapedRanges - | None -> () - | exception _ -> ()) + | Tmod_ident (path, _) -> escapeParent path | _ -> ()) | Some head -> let appliedFunctor, firstIndex = @@ -1897,10 +1937,8 @@ let traverseStructure ~doTypes ~doExternals = let value_binding self vb = vb |> collectValueBinding super self in let structure_item self (structureItem : Typedtree.structure_item) = let oldModulePath = ModulePath.getCurrent () in - let oldModuleBindingPos = !currentModuleBindingPos in (match structureItem.str_desc with | Tstr_module {mb_expr; mb_id; mb_loc; mb_name} -> ( - currentModuleBindingPos := mb_name.loc.loc_start; setFunctorKey mb_expr mb_name.loc.loc_start; registerParameterAlias mb_id mb_expr; registerBindingHead ~namePos:mb_name.loc.loc_start mb_id mb_expr; @@ -2005,6 +2043,15 @@ let traverseStructure ~doTypes ~doExternals = DeadType.addDeclaration ~typeId:typeDeclaration.typ_id ~typeKind:typeDeclaration.typ_type.type_kind) | Tstr_include {incl_mod; incl_type} -> ( + (* An unpacked include introduces bare identifiers, with no module + root left to chase at their applications. Its packed functors must + therefore retain the conservative escape fallback. *) + (match (unwrapConstraints incl_mod).mod_desc with + | Tmod_unpack _ -> ( + match functorHeadOf incl_mod with + | Some head -> escapedHeads := head :: !escapedHeads + | None -> ()) + | _ -> ()); (* [include M] with [M] a functor parameter: the included identifiers stand for the parameter's items. *) (match moduleIdent incl_mod with @@ -2062,7 +2109,6 @@ let traverseStructure ~doTypes ~doExternals = | _ -> ()); let result = super.structure_item self structureItem in ModulePath.setCurrent oldModulePath; - currentModuleBindingPos := oldModuleBindingPos; result in {super with expr; module_expr; pat; structure_item; value_binding} @@ -2158,7 +2204,7 @@ let forceDelayedItems () = |> List.iter (fun {call; callFrom; callTo; callToImpl; callPath} -> call |> DeadOptionalArgs.addReferences ~locFrom:callFrom ~locTo:callTo - ?locToImpl:callToImpl ~forwardable:true ~path:callPath) + ?locToImpl:callToImpl ~path:callPath) else if hasApplication def index then match resolveArgumentItems ~visited:[] ~bindings:[] def index components diff --git a/src/Reanalyze.ml b/src/Reanalyze.ml index 7b5f6821..0803baa6 100644 --- a/src/Reanalyze.ml +++ b/src/Reanalyze.ml @@ -10,7 +10,7 @@ let loadCmtFile ~cmtRoot cmtFilePath = let unitKey = ( cmt_infos.cmt_sourcefile, cmt_infos.cmt_builddir, - cmt_infos.cmt_interface_digest, + cmt_infos.cmt_source_digest, Filename.check_suffix cmtFilePath ".cmti" ) in if Hashtbl.mem scannedUnits unitKey then () From 28cbf6ef9c12b07e5dfd415b3c2fb4de2a2f392b Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 17 Sep 2026 13:05:12 +0000 Subject: [PATCH 47/53] Match imported unit digests before choosing sibling artifacts --- examples/regression/digest_a/Collision.ml | 4 ++ examples/regression/digest_a/dune | 6 +++ examples/regression/digest_b/Collision.ml | 4 ++ examples/regression/digest_b/dune | 6 +++ .../regression/digest_use/Use_collision.ml | 1 + examples/regression/digest_use/dune | 7 +++ scripts/run_integration_tests.js | 52 +++++++++++++++++++ src/Compat.ml | 39 ++++++++------ 8 files changed, 102 insertions(+), 17 deletions(-) create mode 100644 examples/regression/digest_a/Collision.ml create mode 100644 examples/regression/digest_a/dune create mode 100644 examples/regression/digest_b/Collision.ml create mode 100644 examples/regression/digest_b/dune create mode 100644 examples/regression/digest_use/Use_collision.ml create mode 100644 examples/regression/digest_use/dune diff --git a/examples/regression/digest_a/Collision.ml b/examples/regression/digest_a/Collision.ml new file mode 100644 index 00000000..aa152b90 --- /dev/null +++ b/examples/regression/digest_a/Collision.ml @@ -0,0 +1,4 @@ +module type S = sig val g : ?x:int -> unit -> int end +module Chosen_impl = struct let g ?(x = 0) () = x end +module Target : S = Chosen_impl +let marker_a = () diff --git a/examples/regression/digest_a/dune b/examples/regression/digest_a/dune new file mode 100644 index 00000000..75b2e2dc --- /dev/null +++ b/examples/regression/digest_a/dune @@ -0,0 +1,6 @@ +(library + (name digest_a) + (wrapped false) + (modes byte) + (modules Collision) + (flags :standard -w -27-32-34-37-39 -bin-annot)) diff --git a/examples/regression/digest_b/Collision.ml b/examples/regression/digest_b/Collision.ml new file mode 100644 index 00000000..a4833ff0 --- /dev/null +++ b/examples/regression/digest_b/Collision.ml @@ -0,0 +1,4 @@ +module type S = sig val g : ?x:int -> unit -> int end +module Unrelated_impl = struct let g ?(x = 0) () = x end +module Target : S = Unrelated_impl +let marker_b = () diff --git a/examples/regression/digest_b/dune b/examples/regression/digest_b/dune new file mode 100644 index 00000000..d668f8a9 --- /dev/null +++ b/examples/regression/digest_b/dune @@ -0,0 +1,6 @@ +(library + (name digest_b) + (wrapped false) + (modes byte) + (modules Collision) + (flags :standard -w -27-32-34-37-39 -bin-annot)) diff --git a/examples/regression/digest_use/Use_collision.ml b/examples/regression/digest_use/Use_collision.ml new file mode 100644 index 00000000..e756773e --- /dev/null +++ b/examples/regression/digest_use/Use_collision.ml @@ -0,0 +1 @@ +let () = ignore (Collision.Target.g ~x:1 ()) diff --git a/examples/regression/digest_use/dune b/examples/regression/digest_use/dune new file mode 100644 index 00000000..e8b4f7ee --- /dev/null +++ b/examples/regression/digest_use/dune @@ -0,0 +1,7 @@ +(library + (name digest_use) + (wrapped false) + (modes byte) + (libraries digest_a) + (modules Use_collision) + (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 5282e93b..babf79d7 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -778,6 +778,57 @@ function runUnpackedScanOrderTest() { } } +// The importer was compiled against digest_a. A mismatching Collision unit +// beside it must not hide that dependency or replace it when it is absent. +function runImportDigestSelectionTest() { + if (!ocamlVersionAtLeast(5, 3)) return; + const fs = require("fs"); + const os = require("os"); + const cwd = path.join(__dirname, "..", "examples", "regression"); + const temp = fs.mkdtempSync(path.join(os.tmpdir(), "reanalyze-digest-")); + const root = path.join(temp, "layout"); + try { + for (const dir of ["provider", "consumer"]) { + fs.mkdirSync(path.join(root, dir), { recursive: true }); + } + const copy = (library, unit, dir) => + fs.copyFileSync( + path.join(cwd, "_build/default", library, `.${library}.objs/byte`, unit), + path.join(root, dir, unit) + ); + copy("digest_a", "collision.cmt", "provider"); + copy("digest_b", "collision.cmt", "consumer"); + copy("digest_use", "use_collision.cmt", "consumer"); + const run = () => + child_process.execFileSync( + reanalyzeFile, + ["-ci", "-debug", "-native-build-target", ".", "-dce-cmt", root], + { cwd, encoding: "utf8", maxBuffer: 256 * 1024 * 1024 } + ); + console.log(`${cwd}: reanalyze import digest before sibling preference`); + const present = run(); + assertIncludes(present, "Live Value +Collision.Chosen_impl.+g"); + assertIncludes(present, "Dead Value +Collision.Unrelated_impl.+g"); + assertIncludes( + present, + "optional argument x of function Chosen_impl.+g is always supplied (1 calls)" + ); + assertNotIncludes(present, "Live Value +Collision.Unrelated_impl.+g"); + + fs.renameSync( + path.join(root, "provider/collision.cmt"), + path.join(temp, "collision.cmt") + ); + console.log(`${cwd}: reanalyze missing imported digest stays unresolved`); + const absent = run(); + assertIncludes(absent, "Dead Value +Collision.Unrelated_impl.+g"); + assertNotIncludes(absent, "Live Value +Collision.Unrelated_impl.+g"); + assertNotIncludes(absent, "function Unrelated_impl.+g is always supplied"); + } finally { + fs.rmSync(temp, { recursive: true, force: true }); + } +} + function checkSetup() { console.log("Checking if --version outputs the right version"); let output; @@ -813,6 +864,7 @@ function main() { runDuplicateLayoutTest(); runByteNativeDuplicateTest(); runUnpackedScanOrderTest(); + runImportDigestSelectionTest(); checkDiff(); console.log("Test successful!"); diff --git a/src/Compat.ml b/src/Compat.ml index 946a838e..c0ae9183 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -353,13 +353,14 @@ type unitInfo = { (* Keyed by the list of files a unit is loaded from, so that same-named units in different build targets (e.g. two unwrapped libraries each defining [Config]) do not share an entry. *) -let unitInfoCache : (string list * string option, unitInfo) Hashtbl.t = +let unitInfoCache : (string list * string option * string, unitInfo) Hashtbl.t = Hashtbl.create 64 (* An implementation compiled against an interface gets its digest from the sibling .cmti. Retain both files of every matching unit, for shapes - as well as declaration dependencies; without a match stay conservative. *) -let selectUnitFilesByDigest ~interfaceDigest digest files = + as well as declaration dependencies. Only dependency extraction may fan + out to unmatched candidates; shape resolution must not choose one. *) +let selectUnitFilesByDigest ~interfaceDigest ~allowUnmatched digest files = match digest with | None -> files | Some digest -> @@ -371,7 +372,7 @@ let selectUnitFilesByDigest ~interfaceDigest digest files = |> List.exists (fun ext -> interfaceDigest (base ^ ext) = Some digest)) in match matchingStems with - | [] -> files + | [] when allowUnmatched -> files | _ -> List.filter (fun path -> List.mem (stem path) matchingStems) files let candidateFilesForUnit ~currentCmtFile comp_unit = @@ -390,14 +391,7 @@ let candidateFilesForUnit ~currentCmtFile comp_unit = Filename.concat dir (String.uncapitalize_ascii comp_unit ^ ext); ]) in - let candidates = - (indexed @ siblings) |> List.filter Sys.file_exists |> List.sort_uniq compare - in - (* Prefer the unit built alongside the current file when the same unit name - exists in several build targets. *) - match candidates |> List.filter (fun p -> Filename.dirname p = dir) with - | [] -> candidates - | sameDir -> sameDir + (indexed @ siblings) |> List.filter Sys.file_exists |> List.sort_uniq compare (* [imports] are the consumer's recorded imports: when the same unit name exists in several build directories, the candidate whose interface digest @@ -410,9 +404,10 @@ let loadUnitInfo ~currentCmtFile ~(imports : Misc.crcs) comp_unit = | Some (Some digest) -> Some digest | _ -> None in - (* The digest takes part in the key: two consumers compiled against - different same-named units must not share an entry. *) - let cacheKey = (files, Option.map Digest.to_hex digest) in + (* Both the import digest and the later sibling preference affect which + same-named unit a consumer can resolve. *) + let dir = Filename.dirname currentCmtFile in + let cacheKey = (files, Option.map Digest.to_hex digest, dir) in match Hashtbl.find_opt unitInfoCache cacheKey with | Some info -> Some info | None -> ( @@ -431,7 +426,16 @@ let loadUnitInfo ~currentCmtFile ~(imports : Misc.crcs) comp_unit = | Some (_, infos) -> infos.Cmt_format.cmt_interface_digest | None -> None) in - let selected = selectUnitFilesByDigest ~interfaceDigest digest files in + let selected = + selectUnitFilesByDigest ~interfaceDigest ~allowUnmatched:false digest files + in + (* Prefer siblings only after selecting the recorded import digest: + a same-named sibling must not hide the actual dependency elsewhere. *) + let selected = + match selected |> List.filter (fun p -> Filename.dirname p = dir) with + | [] -> selected + | sameDir -> sameDir + in let loaded = loaded |> List.filter (fun (path, _) -> List.mem path selected) in @@ -610,7 +614,8 @@ let extractValueDependencies ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) = | Some (Some digest) -> Some digest | _ -> None in - selectUnitFilesByDigest ~interfaceDigest:interface_digest_of_file digest files + selectUnitFilesByDigest ~interfaceDigest:interface_digest_of_file + ~allowUnmatched:true digest files in let decls_of_unit comp_unit = match Hashtbl.find_opt loadedUnits comp_unit with From 281442e52678bb4dfbd7cadac5728e21fbca94dc Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 17 Sep 2026 14:00:09 +0000 Subject: [PATCH 48/53] Preserve unpacked exports and partial functor contexts --- examples/regression/src/Attribution_sweep.ml | 106 ++++++ examples/regression/src/Main.ml | 5 +- .../regression/src/Partial_context_use.ml | 6 + examples/regression/src/Unpacked_open.ml | 54 +++ .../regression/src/Unpacked_open_provider.ml | 6 + .../regression/src/Unpacked_open_provider.mli | 4 + .../regression/src/Unpacked_open_types.ml | 2 + examples/regression/src/dune | 7 +- scripts/run_integration_tests.js | 91 ++++- src/DeadValue.ml | 321 +++++++++++++----- 10 files changed, 504 insertions(+), 98 deletions(-) create mode 100644 examples/regression/src/Attribution_sweep.ml create mode 100644 examples/regression/src/Partial_context_use.ml create mode 100644 examples/regression/src/Unpacked_open.ml create mode 100644 examples/regression/src/Unpacked_open_provider.ml create mode 100644 examples/regression/src/Unpacked_open_provider.mli create mode 100644 examples/regression/src/Unpacked_open_types.ml diff --git a/examples/regression/src/Attribution_sweep.ml b/examples/regression/src/Attribution_sweep.ml new file mode 100644 index 00000000..fc4d9950 --- /dev/null +++ b/examples/regression/src/Attribution_sweep.ml @@ -0,0 +1,106 @@ +module Repacked = struct + module type S = sig val g : ?repacked:int -> unit -> int end + module type FT = functor (M : S) -> sig val run : unit -> int end + module Make (M : S) = struct let run () = M.g ~repacked:1 () end + let first = (module Make : FT) + module First = (val first : FT) + let second = (module First : FT) + module Second = (val second : FT) + let third = (module Second : FT) + module Third = (val third : FT) + module Repacked_arg : S = struct let g ?(repacked = 0) () = repacked end + module Repacked_unused : S = struct let g ?(repacked = 0) () = repacked end + module Applied = Third (Repacked_arg) + let run () = ignore (Applied.run ()); ignore (Repacked_unused.g ()) +end + +module Projected = struct + module type S = sig val g : ?projected:int -> unit -> int end + module type FT = functor (M : S) -> sig val run : unit -> int end + module type Holder_t = sig module Inner : FT end + module Use (H : Holder_t) (M : S) = struct + module Applied = H.Inner (M) + let run = Applied.run + end + module Forward (H : Holder_t) (M : S) = Use (H) (M) + module Holder = struct + module Inner (M : S) = struct let run () = M.g ~projected:1 () end + end + module Projected_arg : S = struct let g ?(projected = 0) () = projected end + module Projected_unused : S = struct let g ?(projected = 0) () = projected end + module Applied = Forward (Holder) (Projected_arg) + let run () = ignore (Applied.run ()); ignore (Projected_unused.g ()) +end + +module Opaque_holder = struct + module type S = sig val g : ?opaque:int -> unit -> int end + module type FT = functor (M : S) -> sig val run : unit -> int end + module type Holder_t = sig module Inner : FT end + module Use (H : Holder_t) (M : S) = struct + module Applied = H.Inner (M) + let run = Applied.run + end + module Holder = struct + module Inner (M : S) = struct let run () = M.g ~opaque:1 () end + end + let packed = (module Holder : Holder_t) + module Opaque_arg : S = struct let g ?(opaque = 0) () = opaque end + module Applied = Use ((val packed : Holder_t)) (Opaque_arg) + module type Other = sig val h : ?untouched:int -> unit -> int end + module Never_applied (M : Other) = struct let run () = M.h ~untouched:1 () end + module Opaque_unrelated : Other = struct let h ?(untouched = 0) () = untouched end + let run () = ignore (Applied.run ()); ignore (Opaque_unrelated.h ()) +end + +module Partial_context = struct + module type S = sig val g : ?partial:int -> unit -> int end + module type FT = functor (M : S) -> sig val run : unit -> int end + module Supplied (M : S) = struct let run () = M.g ~partial:1 () end + module Omitted (M : S) = struct let run () = M.g () end + module Outer (F : FT) (M : S) = F (M) + module Partial_supplied_arg : S = struct let g ?(partial = 0) () = partial end + module Partial_omitted_arg : S = struct let g ?(partial = 0) () = partial end + module Supply = Outer (Supplied) + module Omit = Outer (Omitted) + module Applied_supply = Supply (Partial_supplied_arg) + module Applied_omit = Omit (Partial_omitted_arg) + module Invoke (F : FT) (M : S) = F (M) + module Passed_supplied_arg : S = struct let g ?(partial = 0) () = partial end + module Passed_omitted_arg : S = struct let g ?(partial = 0) () = partial end + module Passed_supply = Invoke (Supply) (Passed_supplied_arg) + module Passed_omit = Invoke (Omit) (Passed_omitted_arg) + let packed = (module Supply : FT) + module Repacked = (val packed : FT) + module Packed_partial_arg : S = struct let g ?(partial = 0) () = partial end + module Packed_supply = Repacked (Packed_partial_arg) + module With_unit (F : FT) () (M : S) = F (M) + module Unit_prefix = With_unit (Supplied) + module Unit_middle = Unit_prefix () + module Unit_partial_arg : S = struct let g ?(partial = 0) () = partial end + module Unit_supply = Unit_middle (Unit_partial_arg) + module type Higher = functor (F : FT) -> FT + module Forward_partial (F : Higher) (G : FT) (M : S) = struct + module Half = F (G) + module Applied = Invoke (Half) (M) + let run = Applied.run + end + module Forwarded_supplied_arg : S = struct let g ?(partial = 0) () = partial end + module Forwarded_omitted_arg : S = struct let g ?(partial = 0) () = partial end + module Forwarded_supply = Forward_partial (Outer) (Supplied) (Forwarded_supplied_arg) + module Forwarded_omit = Forward_partial (Outer) (Omitted) (Forwarded_omitted_arg) + let run () = + ignore (Applied_supply.run ()); + ignore (Applied_omit.run ()); + ignore (Passed_supply.run ()); + ignore (Passed_omit.run ()); + ignore (Packed_supply.run ()); + ignore (Unit_supply.run ()); + ignore (Forwarded_supply.run ()); + ignore (Forwarded_omit.run ()) +end + +let run () = + Repacked.run (); + Projected.run (); + Opaque_holder.run (); + Partial_context.run () diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 26278769..113e7cf1 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -1,6 +1,8 @@ let definitely_dead () = () let () = + Attribution_sweep.run (); + Partial_context_use.run (); Live_ancestors.use_child (); Functor_argument.use_set (); Functor_argument.use_anonymous_set (); @@ -60,4 +62,5 @@ let () = Packed_interface_use.run (); Escape_exports.run (); Unpacked_functor_use.run (); - Unpacked_include.run () + Unpacked_include.run (); + Unpacked_open.run () diff --git a/examples/regression/src/Partial_context_use.ml b/examples/regression/src/Partial_context_use.ml new file mode 100644 index 00000000..dd79b114 --- /dev/null +++ b/examples/regression/src/Partial_context_use.ml @@ -0,0 +1,6 @@ +module P = Attribution_sweep.Partial_context +module Foreign_supplied_arg : P.S = struct let g ?(partial = 0) () = partial end +module Foreign_omitted_arg : P.S = struct let g ?(partial = 0) () = partial end +module Supplied = P.Supply (Foreign_supplied_arg) +module Omitted = P.Omit (Foreign_omitted_arg) +let run () = ignore (Supplied.run ()); ignore (Omitted.run ()) diff --git a/examples/regression/src/Unpacked_open.ml b/examples/regression/src/Unpacked_open.ml new file mode 100644 index 00000000..96283142 --- /dev/null +++ b/examples/regression/src/Unpacked_open.ml @@ -0,0 +1,54 @@ +module type Arg = Unpacked_open_provider.Arg +module type Holder_t = Unpacked_open_provider.Holder_t +let packed = (module Unpacked_open_provider.Holder : Holder_t) + +module Direct = struct + open (val packed : Holder_t) + module Open_arg : Arg = struct let g ?(opened = 0) () = opened end + module Applied = Inner (Open_arg) + let run () = ignore (Applied.run ()) +end + +module Local = struct + module Local_open_arg : Arg = struct let g ?(opened = 0) () = opened end + let run () = + let open (val packed : Holder_t) in + let module Applied = Inner (Local_open_arg) in + ignore (Applied.run ()) +end + +module Open_struct = struct + open struct module H = (val packed : Holder_t) end + module Open_struct_arg : Arg = struct let g ?(opened = 0) () = opened end + module Applied = H.Inner (Open_struct_arg) + let run () = ignore (Applied.run ()) +end + +module Include_struct = struct + include struct module H = (val packed : Holder_t) end + module Include_struct_arg : Arg = struct let g ?(opened = 0) () = opened end + module Applied = H.Inner (Include_struct_arg) + let run () = ignore (Applied.run ()) +end + +module Cross_unit = struct + open (val Unpacked_open_provider.packed : Holder_t) + module Cross_open_arg : Arg = struct let g ?(opened = 0) () = opened end + module Applied = Inner (Cross_open_arg) + let run () = ignore (Applied.run ()) +end + +module Unrelated = struct + module type Arg = sig val g : ?unrelated:int -> unit -> int end + module Never_applied (M : Arg) = struct let run () = M.g ~unrelated:1 () end + module Unrelated_arg : Arg = struct let g ?(unrelated = 0) () = unrelated end + let run () = ignore (Unrelated_arg.g ()) +end + +let run () = + Direct.run (); + Local.run (); + Open_struct.run (); + Include_struct.run (); + Cross_unit.run (); + Unrelated.run () diff --git a/examples/regression/src/Unpacked_open_provider.ml b/examples/regression/src/Unpacked_open_provider.ml new file mode 100644 index 00000000..21008e26 --- /dev/null +++ b/examples/regression/src/Unpacked_open_provider.ml @@ -0,0 +1,6 @@ +module type Arg = Unpacked_open_types.Arg +module type Holder_t = Unpacked_open_types.Holder_t +module Holder = struct + module Inner (M : Arg) = struct let run () = M.g ~opened:1 () end +end +let packed = (module Holder : Holder_t) diff --git a/examples/regression/src/Unpacked_open_provider.mli b/examples/regression/src/Unpacked_open_provider.mli new file mode 100644 index 00000000..595e753c --- /dev/null +++ b/examples/regression/src/Unpacked_open_provider.mli @@ -0,0 +1,4 @@ +module type Arg = Unpacked_open_types.Arg +module type Holder_t = Unpacked_open_types.Holder_t +module Holder : Holder_t +val packed : (module Holder_t) diff --git a/examples/regression/src/Unpacked_open_types.ml b/examples/regression/src/Unpacked_open_types.ml new file mode 100644 index 00000000..3979f2d2 --- /dev/null +++ b/examples/regression/src/Unpacked_open_types.ml @@ -0,0 +1,2 @@ +module type Arg = sig val g : ?opened:int -> unit -> int end +module type Holder_t = sig module Inner (M : Arg) : sig val run : unit -> int end end diff --git a/examples/regression/src/dune b/examples/regression/src/dune index 4f5be13f..91c30135 100644 --- a/examples/regression/src/dune +++ b/examples/regression/src/dune @@ -1,6 +1,7 @@ (library (name regression_fixture) (modules + Attribution_sweep Cross_alias Cross_alias_use Cross_c @@ -20,6 +21,7 @@ Packed_interface Packed_interface_use Packed_types + Partial_context_use Reference_order Shared_signature Shared_signature_arg @@ -28,5 +30,8 @@ Shared_signature_used Unpacked_functor Unpacked_functor_use - Unpacked_include) + Unpacked_include + Unpacked_open + Unpacked_open_provider + Unpacked_open_types) (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 babf79d7..1476df9f 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -571,6 +571,66 @@ function runRegressionTests() { output, "optional argument nested of function Unpacked_nested_arg.+g is always supplied (1 calls)" ); + for (const name of [ + "Direct.Open_arg", "Local.Local_open_arg", "Open_struct.Open_struct_arg", + "Include_struct.Include_struct_arg", "Cross_unit.Cross_open_arg", + ]) { + assertIncludes( + output, + `optional argument opened of function ${name}.+g is always supplied (1 calls)` + ); + } + assertIncludes( + output, + "optional argument unrelated of function Unrelated.Unrelated_arg.+g is never used" + ); + for (const [name, argument] of [ + ["Repacked.Repacked_arg", "repacked"], + ["Projected.Projected_arg", "projected"], + ["Opaque_holder.Opaque_arg", "opaque"], + ]) { + assertIncludes( + output, + `optional argument ${argument} of function ${name}.+g is always supplied (1 calls)` + ); + } + for (const [name, argument] of [ + ["Repacked.Repacked_unused", "repacked"], + ["Projected.Projected_unused", "projected"], + ]) { + assertIncludes( + output, + `optional argument ${argument} of function ${name}.+g is never used` + ); + } + assertIncludes( + output, + "optional argument untouched of function Opaque_holder.Opaque_unrelated.+h is never used" + ); + for (const name of [ + "Partial_context.Partial_supplied_arg", + "Partial_context.Passed_supplied_arg", + "Partial_context.Packed_partial_arg", + "Partial_context.Unit_partial_arg", + "Partial_context.Forwarded_supplied_arg", + "Foreign_supplied_arg", + ]) { + assertIncludes( + output, + `optional argument partial of function ${name}.+g is always supplied (1 calls)` + ); + } + for (const name of [ + "Partial_context.Partial_omitted_arg", + "Partial_context.Passed_omitted_arg", + "Partial_context.Forwarded_omitted_arg", + "Foreign_omitted_arg", + ]) { + assertIncludes( + output, + `optional argument partial of function ${name}.+g is never used` + ); + } // Escaping holders also expose functors defined outside their lexical // range through module aliases and includes. for (const [name, argument] of [ @@ -722,7 +782,7 @@ function runByteNativeDuplicateTest() { } } -function runUnpackedScanOrderTest() { +function runFunctorScanOrderTest(providerName, consumerName, assertions) { if (!ocamlVersionAtLeast(5, 3)) return; const fs = require("fs"); const os = require("os"); @@ -732,10 +792,10 @@ function runUnpackedScanOrderTest() { try { for (const dir of ["first", "second"]) fs.mkdirSync(path.join(root, dir)); const files = fs.readdirSync(cmtDir).filter((file) => /\.cmti?$/.test(file)); - const provider = "regression_fixture__Unpacked_functor.cmt"; - const consumer = "regression_fixture__Unpacked_functor_use.cmt"; + const provider = `regression_fixture__${providerName}.cmt`; + const consumer = `regression_fixture__${consumerName}.cmt`; const orders = []; - console.log(`${cwd}: reanalyze unpacked functors in both scan orders`); + console.log(`${cwd}: reanalyze ${providerName} in both scan orders`); for (const providerDir of ["first", "second"]) { const otherDir = providerDir === "first" ? "second" : "first"; for (const file of files) { @@ -753,18 +813,7 @@ function runUnpackedScanOrderTest() { output.indexOf(`Scanning ${provider} `) < output.indexOf(`Scanning ${consumer} `) ); - assertIncludes( - output, - "optional argument x of function Unpacked_arg.+g is always supplied (1 calls)" - ); - assertIncludes( - output, - "optional argument x of function Unpacked_unused.+g is never used" - ); - assertIncludes( - output, - "optional argument nested of function Unpacked_nested_arg.+g is always supplied (1 calls)" - ); + for (const assertion of assertions) assertIncludes(output, assertion); for (const file of files) { const dir = file === provider ? providerDir : otherDir; fs.unlinkSync(path.join(root, dir, file)); @@ -863,7 +912,15 @@ function main() { runRegressionTests(); runDuplicateLayoutTest(); runByteNativeDuplicateTest(); - runUnpackedScanOrderTest(); + runFunctorScanOrderTest("Unpacked_functor", "Unpacked_functor_use", [ + "optional argument x of function Unpacked_arg.+g is always supplied (1 calls)", + "optional argument x of function Unpacked_unused.+g is never used", + "optional argument nested of function Unpacked_nested_arg.+g is always supplied (1 calls)", + ]); + runFunctorScanOrderTest("Attribution_sweep", "Partial_context_use", [ + "optional argument partial of function Foreign_supplied_arg.+g is always supplied (1 calls)", + "optional argument partial of function Foreign_omitted_arg.+g is never used", + ]); runImportDigestSelectionTest(); checkDiff(); diff --git a/src/DeadValue.ml b/src/DeadValue.ml index c904277b..8bd2b35c 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -150,6 +150,9 @@ type functorHead = | Key of Lexing.position * int (** a functor's key, and the arguments partial applications already consumed, as in [module G = F (A)] followed by [G (B)] *) + | Partial of Lexing.position * functorHead + (** application expression supplying the already consumed arguments; + retained so separate partial bindings keep their own context *) | ParamHead of Lexing.position * int * string list * int (** (a submodule of) a parameter of the enclosing functor, applied in its body: the functor's key, the parameter's index, the path within @@ -184,6 +187,53 @@ type delayedApplication = { let delayedApplications : delayedApplication list ref = ref [] let nextApplicationId = ref 0 +let applicationIdsByPosition : (Lexing.position, int list) Hashtbl.t = + Hashtbl.create 16 + +let applicationPrefixes : (int, Lexing.position list) Hashtbl.t = + Hashtbl.create 16 + +(* Unit-only applications have no argument record but can still extend a + partial context that a later application must inherit. *) +let applicationHeads : (int, functorHead) Hashtbl.t = Hashtbl.create 16 + +let prefixApplicationIds sources = + let rec first = function + | [] -> [] + | pos :: rest -> ( + match Hashtbl.find_opt applicationIdsByPosition pos with + | Some ids -> ids + | None -> first rest) + in + first sources + +let rec extendsApplication ?(visited = []) applicationId prefixId = + applicationId = prefixId + || ((not (List.mem applicationId visited)) + && match Hashtbl.find_opt applicationPrefixes applicationId with + | None -> false + | Some sources -> + prefixApplicationIds sources + |> List.exists + (fun parent -> + extendsApplication ~visited:(applicationId :: visited) + parent prefixId)) + +let compatibleApplications left right = + extendsApplication left right || extendsApplication right left + +(* A completed application is a more specific context than its prefix. + Do not replace it with the prefix when inheriting another binding set. *) +let mergeBindings bindings = + bindings + |> List.fold_left + (fun acc ((def, id) as binding) -> + match List.assoc_opt def acc with + | Some prior when extendsApplication prior id -> acc + | _ -> binding :: List.remove_assoc def acc) + [] + |> List.sort compare + (* The applications of the functor keyed [functorDef] supplying its parameter [argIndex], under [bindings]. *) let applicationsOf ~bindings functorDef argIndex = @@ -193,7 +243,11 @@ let applicationsOf ~bindings functorDef argIndex = appliedFunctor = Key (functorDef, 0) && index = argIndex && (match List.assoc_opt functorDef bindings with - | Some id -> id = applicationId + | Some id -> + extendsApplication applicationId id + || (match List.assoc_opt functorDef own with + | Some ownId -> compatibleApplications ownId id + | None -> false) | None -> true) (* A template instantiated through different enclosing applications retains its source ID. Its inherited context must agree too, @@ -201,7 +255,7 @@ let applicationsOf ~bindings functorDef argIndex = && List.for_all (fun (def, id) -> match List.assoc_opt def bindings with - | Some requested -> id = requested + | Some requested -> compatibleApplications id requested | None -> true) own) @@ -230,9 +284,12 @@ let inRanges (pos : Lexing.position) ranges = && start.pos_cnum <= pos.pos_cnum && pos.pos_cnum <= stop.pos_cnum) -let functorHeadToString head = +let rec functorHeadToString head = match head with | Key (pos, consumed) -> Printf.sprintf "%s+%d" (pos |> posToString) consumed + | Partial (pos, head) -> + Printf.sprintf "partial(%s,%s)" (pos |> posToString) + (functorHeadToString head) | ParamHead (def, index, components, consumed) -> Printf.sprintf "param(%s,%d,%s)+%d" (def |> posToString) index (String.concat "." components) @@ -282,8 +339,9 @@ let rec resolveArgumentItems ~visited ~bindings functorDef argIndex components | Direct resolve -> ( match resolve components with Some loc -> [loc] | None -> []) | ViaParameter (outerDef, outerIndex, prefix) -> - resolveArgumentItems ~visited ~bindings:(own @ bindings) outerDef - outerIndex (prefix @ components)) + resolveArgumentItems ~visited + ~bindings:(mergeBindings (own @ bindings)) outerDef outerIndex + (prefix @ components)) (* Whether the functor keyed [functorDef] has an application supplying its parameter [argIndex]. *) @@ -300,6 +358,32 @@ let findPackedModule ~sigToImpl pos = | Some implPos -> Hashtbl.find_opt packedModules implPos | None -> None) +(* Repacking an unpacked functor adds another value-binding indirection. + Chase the whole chain after every unit is registered, preserving partial + applications and guarding cycles. *) +let rec resolvePackedHead ~sigToImpl ?(visited = []) head = + match head with + | Packed (pos, consumed) when not (List.mem pos visited) -> ( + match findPackedModule ~sigToImpl pos with + | Some {packedHead = Some head} -> ( + match resolvePackedHead ~sigToImpl ~visited:(pos :: visited) head with + | Some (head, sources) -> + let head = + match head with + | Key (key, consumed') -> Key (key, consumed + consumed') + | ParamHead (def, index, components, consumed') -> + ParamHead (def, index, components, consumed + consumed') + | _ -> head + in + Some (head, sources) + | _ -> None) + | _ -> None) + | Packed _ -> None + | Partial (pos, head) -> + resolvePackedHead ~sigToImpl ~visited head + |> Option.map (fun (head, sources) -> (head, pos :: sources)) + | head -> Some (head, []) + (* The functors (a submodule of) the argument at [argIndex] of the applications of [functorDef] denotes: their keys, the arguments they consumed, and the applications they came through. *) @@ -310,25 +394,28 @@ let rec resolveHeads ~sigToImpl ~visited ~bindings functorDef argIndex let visited = (functorDef, argIndex, components) :: visited in applicationsOf ~bindings functorDef argIndex |> List.concat_map (fun {applicationId; argHead; bindings = own} -> - let here = ((functorDef, applicationId) :: own) @ bindings in - match argHead components with - | Some (Key (pos, consumed)) -> [(pos, consumed, here)] - | Some (ParamHead (def, index, prefix, consumed)) -> + let here = + mergeBindings (((functorDef, applicationId) :: own) @ bindings) + in + let withPrefixes sources (pos, consumed, bindings) = + match prefixApplicationIds sources with + | [] -> [(pos, consumed, bindings)] + | ids -> + List.map + (fun id -> + (pos, consumed, mergeBindings ((pos, id) :: bindings))) + ids + in + match Option.bind (argHead components) (resolvePackedHead ~sigToImpl) with + | Some (Key (pos, consumed), sources) -> + withPrefixes sources (pos, consumed, here) + | Some (ParamHead (def, index, prefix, consumed), sources) -> resolveHeads ~sigToImpl ~visited ~bindings:here def index - (prefix @ components) + prefix |> List.map (fun (pos, consumed', bindings) -> (pos, consumed + consumed', bindings)) - | Some (Packed (pos, consumed)) -> ( - match (findPackedModule ~sigToImpl pos, components) with - | Some {packedHead = Some (Key (key, consumed'))}, [] -> - [(key, consumed + consumed', here)] - | ( Some {packedHead = Some (ParamHead (def, index, prefix, consumed'))}, - [] ) -> - resolveHeads ~sigToImpl ~visited ~bindings:here def index prefix - |> List.map (fun (pos, consumed'', bindings) -> - (pos, consumed + consumed' + consumed'', bindings)) - | _ -> []) - | None -> []) + |> List.concat_map (withPrefixes sources) + | Some ((Packed _ | Partial _), _) | None -> []) (* Applications headed by a functor parameter stand for the applications of the functors passed for it. Resolved to a fixed point, as an argument may @@ -337,26 +424,27 @@ let rec resolveHeads ~sigToImpl ~visited ~bindings functorDef argIndex dropped, and the calls they would credit fall back to forwarding. *) let resolveParameterHeadedApplications ~sigToImpl = (* First-class modules, from the values they were packed into. *) + Hashtbl.iter + (fun id head -> + match resolvePackedHead ~sigToImpl head with + | Some (_, sources) -> Hashtbl.replace applicationPrefixes id sources + | None -> ()) + applicationHeads; delayedApplications := !delayedApplications |> List.map (fun application -> - match application.appliedFunctor with - | Packed (pos, consumed) -> ( - match findPackedModule ~sigToImpl pos with - | Some {packedHead = Some (Key (key, consumed'))} -> + match resolvePackedHead ~sigToImpl application.appliedFunctor with + | Some (head, sources) -> + Hashtbl.replace applicationPrefixes application.applicationId sources; + (match head with + | Key (key, consumed) -> { application with appliedFunctor = Key (key, 0); - argIndex = application.argIndex + consumed + consumed'; + argIndex = application.argIndex + consumed; } - | Some {packedHead = Some (ParamHead (def, index, components, consumed'))} -> - { - application with - appliedFunctor = - ParamHead (def, index, components, consumed + consumed'); - } - | _ -> application) - | _ -> application); + | appliedFunctor -> {application with appliedFunctor}) + | None -> application); (* Keep the templates until the whole fixed point is complete: resolving one head does not mean all enclosing applications are known yet. *) let templates = @@ -364,19 +452,11 @@ let resolveParameterHeadedApplications ~sigToImpl = |> List.filter (fun {appliedFunctor} -> match appliedFunctor with ParamHead _ -> true | _ -> false) in - let normalizeBindings bindings = - bindings - |> List.fold_left - (fun acc ((def, _) as binding) -> - if List.mem_assoc def acc then acc else binding :: acc) - [] - |> List.sort compare - in (* Function-valued resolvers cannot be compared. The original application identity, target argument, and effective enclosing bindings identify a derived application without comparing those closures. *) let key {applicationId; appliedFunctor; argIndex; bindings} = - (applicationId, appliedFunctor, argIndex, normalizeBindings bindings) + (applicationId, appliedFunctor, argIndex, mergeBindings bindings) in let known = Hashtbl.create 16 in List.iter (fun application -> Hashtbl.replace known (key application) ()) @@ -399,14 +479,14 @@ let resolveParameterHeadedApplications ~sigToImpl = appliedFunctor = Key (pos, 0); argIndex = application.argIndex + consumed + consumed'; bindings = - normalizeBindings (bindings @ application.bindings); + mergeBindings (bindings @ application.bindings); } in let key = key derived in if not (Hashtbl.mem known key) then ( Hashtbl.add known key (); additions := derived :: !additions)) - | Key _ | Packed _ -> ()); + | Key _ | Packed _ | Partial _ -> ()); if !additions <> [] then ( delayedApplications := !delayedApplications @ List.rev !additions; loop ()) @@ -420,15 +500,18 @@ let resolveParameterHeadedApplications ~sigToImpl = match application.appliedFunctor with | ParamHead (def, index, components, _) -> heads application def index components = [] - | Key _ | Packed _ -> true); + | Key _ | Packed _ | Partial _ -> true); !delayedApplications |> List.iter (fun {appliedFunctor; argIndex; argHead; argRange} -> match appliedFunctor with - | ParamHead _ | Packed _ -> ( + | ParamHead _ | Packed _ | Partial _ -> ( if !Common.Cli.debug then Log_.item "unresolvedApplication %s index:%d@." (functorHeadToString appliedFunctor) argIndex; + (* The unresolved head may itself hide a nested functor in an + argument holder. Escape its known definition ranges too. *) + escapedHeads := appliedFunctor :: !escapedHeads; escapedRanges := argRange @ !escapedRanges; match argHead [] with | Some head -> escapedHeads := head :: !escapedHeads @@ -451,27 +534,24 @@ let rec resolveRanges ~visited functorDef argIndex = (* The keys and definition ranges of what escaped, see [escapedHeads]. *) let escapedKeysAndRanges ~sigToImpl = - let ofHead head = + let rec ofHead visited head = match head with | Key (pos, _) -> ([pos], []) + | Partial (_, head) -> ofHead visited head | ParamHead (def, index, components, _) -> ( resolveHeads ~sigToImpl ~visited:[] ~bindings:[] def index components |> List.map (fun (pos, _, _) -> pos), resolveRanges ~visited:[] def index ) - | Packed (pos, _) -> ( + | Packed (pos, _) when not (List.mem pos visited) -> ( match findPackedModule ~sigToImpl pos with - | Some {packedHead = Some (Key (key, _)); packedRange} -> - ([key], packedRange) - | Some - {packedHead = Some (ParamHead (def, index, components, _)); packedRange} - -> - ( resolveHeads ~sigToImpl ~visited:[] ~bindings:[] def index components - |> List.map (fun (pos, _, _) -> pos), - packedRange @ resolveRanges ~visited:[] def index ) + | Some {packedHead = Some head; packedRange} -> + let keys, ranges = ofHead (pos :: visited) head in + (keys, packedRange @ ranges) | Some {packedRange} -> ([], packedRange) | None -> ([], [])) + | Packed _ -> ([], []) in - let keys, ranges = !escapedHeads |> List.map ofHead |> List.split in + let keys, ranges = !escapedHeads |> List.map (ofHead []) |> List.split in (List.concat keys, List.concat ranges @ !escapedRanges) (* Packed modules that flowed somewhere other than a direct unpack escape, @@ -904,9 +984,11 @@ let packedHeadOfPath resolutions path = ofExpr visited resolutions inner consumed | Tmod_apply (inner, _, _) -> ofExpr visited resolutions inner (consumed + 1) + |> Option.map (fun head -> Partial (e.mod_loc.loc_start, head)) #if OCAML_VERSION >= (5, 1, 0) | Tmod_apply_unit inner -> ofExpr visited resolutions inner (consumed + 1) + |> Option.map (fun head -> Partial (e.mod_loc.loc_start, head)) #endif | Tmod_ident (path, _) -> ofPath visited resolutions path consumed | Tmod_unpack (packed, _) -> @@ -915,6 +997,35 @@ let packedHeadOfPath resolutions path = in ofPath [] resolutions path 0 +(* A foreign alias of a partial application may be read before its unit is + traversed. Its application position still identifies the argument group + once that unit has been scanned. *) +let partialHeadOfPath resolutions path head = + let rec ofPath visited (resolutions : Compat.identResolutions) path = + match resolutions.bindingOfPath path with + | Some (_, definition, resolver, _) -> + ofExpr visited (Option.value resolver ~default:resolutions) definition + | None -> None + and ofExpr visited resolutions (e : Typedtree.module_expr) = + if List.memq e visited then None + else + let visited = e :: visited in + match e.mod_desc with + | Tmod_apply _ -> Some e.mod_loc.loc_start +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit _ -> Some e.mod_loc.loc_start +#endif + | Tmod_constraint (inner, _, _, _) -> ofExpr visited resolutions inner + | Tmod_ident (path, _) -> ofPath visited resolutions path + | _ -> None + in + match head with + | Key (_, consumed) when consumed > 0 -> ( + match ofPath [] resolutions path with + | Some pos -> Partial (pos, head) + | None -> head) + | _ -> head + (* The functor a module expression applies, and the number of arguments already consumed by partial applications it stands for, as in [module G = F (A)] followed by [G (B)]. Aliases ([module G = F]) are @@ -922,20 +1033,26 @@ let packedHeadOfPath resolutions path = resolver. A functor parameter ([F (M)] in [functor (F : FT) -> ...]) is resolved once all applications are known. *) let rec functorHeadOf (e : Typedtree.module_expr) : functorHead option = - let consume head = + let rec consume head = match head with | Some (Key (pos, consumed)) -> Some (Key (pos, consumed + 1)) | Some (ParamHead (def, index, components, consumed)) -> Some (ParamHead (def, index, components, consumed + 1)) | Some (Packed (pos, consumed)) -> Some (Packed (pos, consumed + 1)) + | Some (Partial (pos, head)) -> + consume (Some head) |> Option.map (fun head -> Partial (pos, head)) | None -> None in + let applied inner = + consume (functorHeadOf inner) + |> Option.map (fun head -> Partial (e.mod_loc.loc_start, head)) + in match e.mod_desc with - | Tmod_apply (functorExpr, _, _) -> consume (functorHeadOf functorExpr) + | Tmod_apply (functorExpr, _, _) -> applied functorExpr #if OCAML_VERSION >= (5, 1, 0) | Tmod_apply_unit functorExpr -> (* [F ()]: the unit parameter occupies an index. *) - consume (functorHeadOf functorExpr) + applied functorExpr #endif | Tmod_constraint (inner, _, _, _) -> functorHeadOf inner | Tmod_functor _ -> @@ -994,7 +1111,9 @@ and headOfPath ?lid (path : Path.t) components : functorHead option = in match key with | Some ((nameLoc : Location.t), consumed) -> - Some (Key (nameLoc.loc_start, consumed)) + Some + (partialHeadOfPath !identResolutions extended + (Key (nameLoc.loc_start, consumed))) | None -> None in let rec first = function @@ -1026,6 +1145,43 @@ let registerBindingHead ~(namePos : Lexing.position) (id : Ident.t option) | None -> ()) | None -> ()) +(* Opens and includes can introduce fresh identifiers whose unpacked origin + cannot be recovered at an application. Preserve the escape fallback for + unpacked exports, including bindings nested inside a structure wrapper. *) +let rec escapeUnpackedExports ?(visited = []) + ?(resolutions = !identResolutions) (e : Typedtree.module_expr) = + if not (List.memq e visited) then + let visited = e :: visited in + let walk = escapeUnpackedExports ~visited ~resolutions in + match e.mod_desc with + | Tmod_unpack (packed, _) -> ( + match unpackedBinding packed with + | Some pos -> escapedHeads := Packed (pos, 0) :: !escapedHeads + | None -> ()) + | Tmod_constraint (inner, _, _, _) | Tmod_functor (_, inner) -> walk inner + | Tmod_apply (functorExpr, argumentExpr, _) -> + walk functorExpr; + walk argumentExpr +#if OCAML_VERSION >= (5, 1, 0) + | Tmod_apply_unit inner -> walk inner +#endif + | Tmod_ident (path, _) -> ( + match resolutions.bindingOfPath path with + | Some (_, definition, resolver, _) -> + escapeUnpackedExports ~visited + ~resolutions:(Option.value resolver ~default:resolutions) definition + | None -> ()) + | Tmod_structure {str_items} -> + str_items + |> List.iter (fun (item : Typedtree.structure_item) -> + match item.str_desc with + | Tstr_module {mb_expr} -> walk mb_expr + | Tstr_recmodule bindings -> + List.iter (fun (mb : Typedtree.module_binding) -> walk mb.mb_expr) + bindings + | Tstr_include {incl_mod} -> walk incl_mod + | _ -> ()) + let rec collectExpr super self (e : Typedtree.expression) = let locFrom = e.exp_loc in (* [let module F (M : S) = ... in]: key the functor by its binding. On @@ -1042,6 +1198,7 @@ let rec collectExpr super self (e : Typedtree.expression) = | _ -> ()); #else (match e.exp_desc with + | Texp_open ({open_expr}, _) -> escapeUnpackedExports open_expr | Texp_letmodule (id, name, _, moduleExpr, _) -> setFunctorKey moduleExpr name.loc.loc_start; registerParameterAlias id moduleExpr; @@ -1703,16 +1860,19 @@ let recordedApplications : Typedtree.module_expr list ref = ref [] parameter to the corresponding argument. *) let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = if not (List.memq moduleExpr !recordedApplications) then + let chain = ref [] in (* The arguments of this application chain, in order, and its head. A unit application ([F ()]) consumes an index without an argument. *) let rec flatten (e : Typedtree.module_expr) args = match e.mod_desc with | Tmod_apply (functorExpr, argumentExpr, _) -> recordedApplications := e :: !recordedApplications; + chain := e :: !chain; flatten functorExpr (Some argumentExpr :: args) #if OCAML_VERSION >= (5, 1, 0) | Tmod_apply_unit functorExpr -> recordedApplications := e :: !recordedApplications; + chain := e :: !chain; flatten functorExpr (None :: args) #endif | Tmod_constraint (inner, _, _, _) -> flatten inner args @@ -1762,7 +1922,9 @@ let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = | None -> ( match resolutions.headKeyOfPath extended with | Some ((loc : Location.t), consumed) -> - Some (Key (loc.loc_start, consumed)) + Some + (partialHeadOfPath resolutions extended + (Key (loc.loc_start, consumed))) | None -> None)) | _, None, None -> None in @@ -1797,13 +1959,18 @@ let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = | Tmod_ident (path, _) -> escapeParent path | _ -> ()) | Some head -> - let appliedFunctor, firstIndex = - match head with - | Key (pos, consumed) -> (Key (pos, 0), consumed) - | ParamHead _ | Packed _ -> (head, 0) - in incr nextApplicationId; let applicationId = !nextApplicationId in + Hashtbl.replace applicationHeads applicationId head; + !chain + |> List.iter (fun (e : Typedtree.module_expr) -> + let pos = e.mod_loc.loc_start in + let ids = + Option.value (Hashtbl.find_opt applicationIdsByPosition pos) + ~default:[] + in + Hashtbl.replace applicationIdsByPosition pos + (List.sort_uniq compare (applicationId :: ids))); args |> List.iteri (fun i argumentExpr -> match argumentExpr with @@ -1812,8 +1979,8 @@ let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = { applicationId; bindings = []; - appliedFunctor; - argIndex = firstIndex + i; + appliedFunctor = head; + argIndex = i; resolver = argumentItemResolver argumentExpr; argHead = argHead argumentExpr; argRange = definitionRange argumentExpr; @@ -2043,15 +2210,7 @@ let traverseStructure ~doTypes ~doExternals = DeadType.addDeclaration ~typeId:typeDeclaration.typ_id ~typeKind:typeDeclaration.typ_type.type_kind) | Tstr_include {incl_mod; incl_type} -> ( - (* An unpacked include introduces bare identifiers, with no module - root left to chase at their applications. Its packed functors must - therefore retain the conservative escape fallback. *) - (match (unwrapConstraints incl_mod).mod_desc with - | Tmod_unpack _ -> ( - match functorHeadOf incl_mod with - | Some head -> escapedHeads := head :: !escapedHeads - | None -> ()) - | _ -> ()); + escapeUnpackedExports incl_mod; (* [include M] with [M] a functor parameter: the included identifiers stand for the parameter's items. *) (match moduleIdent incl_mod with @@ -2097,6 +2256,7 @@ let traverseStructure ~doTypes ~doExternals = ~doValues:false (* TODO: also values? *) ~moduleLoc:incl_mod.mod_loc ~path:currentPath) | _ -> ()) + | Tstr_open {open_expr} -> escapeUnpackedExports open_expr | Tstr_exception _ -> ( match structureItem.str_desc |> Compat.tstrExceptionGet with | Some (id, loc) -> @@ -2248,6 +2408,9 @@ let forceDelayedItems () = ~locFrom:coercionFrom ~locTo)); parameterCoercions := []; delayedApplications := []; + Hashtbl.reset applicationIdsByPosition; + Hashtbl.reset applicationPrefixes; + Hashtbl.reset applicationHeads; DeadOptionalArgs.settleDelayedItems (); let dependencies = List.rev !delayedValueDependencies in delayedValueDependencies := []; From 423fadfb5e84e9d61c782f7de738b7b7d93d3bcf Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 17 Sep 2026 14:17:38 +0000 Subject: [PATCH 49/53] Escape unpacked exports only when their applications need fallback --- examples/regression/src/Unpacked_open.ml | 79 +++++++++- examples/regression/src/Unpacked_unused.ml | 29 ++++ examples/regression/src/dune | 3 +- scripts/run_integration_tests.js | 26 ++++ src/Compat.ml | 10 +- src/DeadValue.ml | 165 ++++++++++++++++++--- 6 files changed, 281 insertions(+), 31 deletions(-) create mode 100644 examples/regression/src/Unpacked_unused.ml diff --git a/examples/regression/src/Unpacked_open.ml b/examples/regression/src/Unpacked_open.ml index 96283142..04d96337 100644 --- a/examples/regression/src/Unpacked_open.ml +++ b/examples/regression/src/Unpacked_open.ml @@ -1,8 +1,15 @@ module type Arg = Unpacked_open_provider.Arg module type Holder_t = Unpacked_open_provider.Holder_t -let packed = (module Unpacked_open_provider.Holder : Holder_t) +(* Separate signatures and holders keep one case's escape from satisfying + another case's assertions. *) module Direct = struct + module type Arg = sig val g : ?opened:int -> unit -> int end + module type Holder_t = sig module Inner (M : Arg) : sig val run : unit -> int end end + module Holder = struct + module Inner (M : Arg) = struct let run () = M.g ~opened:1 () end + end + let packed = (module Holder : Holder_t) open (val packed : Holder_t) module Open_arg : Arg = struct let g ?(opened = 0) () = opened end module Applied = Inner (Open_arg) @@ -10,6 +17,12 @@ module Direct = struct end module Local = struct + module type Arg = sig val g : ?opened:int -> unit -> int end + module type Holder_t = sig module Inner (M : Arg) : sig val run : unit -> int end end + module Holder = struct + module Inner (M : Arg) = struct let run () = M.g ~opened:1 () end + end + let packed = (module Holder : Holder_t) module Local_open_arg : Arg = struct let g ?(opened = 0) () = opened end let run () = let open (val packed : Holder_t) in @@ -18,6 +31,12 @@ module Local = struct end module Open_struct = struct + module type Arg = sig val g : ?opened:int -> unit -> int end + module type Holder_t = sig module Inner (M : Arg) : sig val run : unit -> int end end + module Holder = struct + module Inner (M : Arg) = struct let run () = M.g ~opened:1 () end + end + let packed = (module Holder : Holder_t) open struct module H = (val packed : Holder_t) end module Open_struct_arg : Arg = struct let g ?(opened = 0) () = opened end module Applied = H.Inner (Open_struct_arg) @@ -25,6 +44,12 @@ module Open_struct = struct end module Include_struct = struct + module type Arg = sig val g : ?opened:int -> unit -> int end + module type Holder_t = sig module Inner (M : Arg) : sig val run : unit -> int end end + module Holder = struct + module Inner (M : Arg) = struct let run () = M.g ~opened:1 () end + end + let packed = (module Holder : Holder_t) include struct module H = (val packed : Holder_t) end module Include_struct_arg : Arg = struct let g ?(opened = 0) () = opened end module Applied = H.Inner (Include_struct_arg) @@ -45,10 +70,60 @@ module Unrelated = struct let run () = ignore (Unrelated_arg.g ()) end +module Unused_import = struct + open Unpacked_unused + module Victim : Arg = struct let g ?(unused_open = 0) () = unused_open end + module Called_victim : Arg = struct let g ?(unused_open = 0) () = unused_open end + let fns = [Victim.g] + let run () = ignore (List.length fns); ignore (Called_victim.g ()); ignore (helper ()) +end + +module Mixed_open = struct + module type Arg = sig val g : ?opened:int -> unit -> int end + module type Holder_t = sig module Inner (M : Arg) : sig val run : unit -> int end end + module Holder = struct + module Inner (M : Arg) = struct let run () = M.g ~opened:1 () end + end + let packed = (module Holder : Holder_t) + open struct + module Used = (val packed : Holder_t) + module Ignored = (val Unpacked_unused.packed : Unpacked_unused.Holder_t) + end + module Used_arg : Arg = struct let g ?(opened = 0) () = opened end + module Victim : Unpacked_unused.Arg = struct let g ?(unused_open = 0) () = unused_open end + module Applied = Used.Inner (Used_arg) + let run () = ignore (Applied.run ()); ignore (Victim.g ()) +end + +module Aliases = struct + module type Arg = sig val g : ?aliased:int -> unit -> int end + module type Holder_t = sig module Inner (M : Arg) : sig val run : unit -> int end end + module Holder = struct + module Inner (M : Arg) = struct let run () = M.g ~aliased:1 () end + end + let packed = (module Holder : Holder_t) + open (val packed : Holder_t) + module Alias = Inner + module Local_alias_arg : Arg = struct let g ?(aliased = 0) () = aliased end + module Foreign_alias_arg : Unpacked_unused.Exported_alias.Arg = struct + let g ?(foreign_alias = 0) () = foreign_alias + end + module Foreign_include_arg : Unpacked_unused.Exported_include.Arg = struct + let g ?(foreign_include = 0) () = foreign_include + end + module Local = Alias (Local_alias_arg) + module Foreign = Unpacked_unused.Exported_alias.Alias (Foreign_alias_arg) + module Included = Unpacked_unused.Exported_include.Inner (Foreign_include_arg) + let run () = ignore (Local.run ()); ignore (Foreign.run ()); ignore (Included.run ()) +end + let run () = Direct.run (); Local.run (); Open_struct.run (); Include_struct.run (); Cross_unit.run (); - Unrelated.run () + Unrelated.run (); + Unused_import.run (); + Mixed_open.run (); + Aliases.run () diff --git a/examples/regression/src/Unpacked_unused.ml b/examples/regression/src/Unpacked_unused.ml new file mode 100644 index 00000000..d40cc6c6 --- /dev/null +++ b/examples/regression/src/Unpacked_unused.ml @@ -0,0 +1,29 @@ +module type Arg = sig val g : ?unused_open:int -> unit -> int end +module type Holder_t = sig module Inner (M : Arg) : sig val run : unit -> int end end +module Holder = struct + module Inner (M : Arg) = struct let run () = M.g ~unused_open:1 () end +end +let packed = (module Holder : Holder_t) +module Unused_holder = (val packed : Holder_t) +let helper () = 42 + +module Exported_include = struct + module type Arg = sig val g : ?foreign_include:int -> unit -> int end + module type Holder_t = sig module Inner (M : Arg) : sig val run : unit -> int end end + module Holder = struct + module Inner (M : Arg) = struct let run () = M.g ~foreign_include:1 () end + end + let packed = (module Holder : Holder_t) + include (val packed : Holder_t) +end + +module Exported_alias = struct + module type Arg = sig val g : ?foreign_alias:int -> unit -> int end + module type Holder_t = sig module Inner (M : Arg) : sig val run : unit -> int end end + module Holder = struct + module Inner (M : Arg) = struct let run () = M.g ~foreign_alias:1 () end + end + let packed = (module Holder : Holder_t) + include (val packed : Holder_t) + module Alias = Inner +end diff --git a/examples/regression/src/dune b/examples/regression/src/dune index 91c30135..5897274c 100644 --- a/examples/regression/src/dune +++ b/examples/regression/src/dune @@ -33,5 +33,6 @@ Unpacked_include Unpacked_open Unpacked_open_provider - Unpacked_open_types) + Unpacked_open_types + Unpacked_unused) (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 1476df9f..65013c9f 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -574,6 +574,7 @@ function runRegressionTests() { for (const name of [ "Direct.Open_arg", "Local.Local_open_arg", "Open_struct.Open_struct_arg", "Include_struct.Include_struct_arg", "Cross_unit.Cross_open_arg", + "Mixed_open.Used_arg", ]) { assertIncludes( output, @@ -584,6 +585,24 @@ function runRegressionTests() { output, "optional argument unrelated of function Unrelated.Unrelated_arg.+g is never used" ); + for (const name of [ + "Unused_import.Victim", "Unused_import.Called_victim", "Mixed_open.Victim", + ]) { + assertIncludes( + output, + `optional argument unused_open of function ${name}.+g is never used` + ); + } + for (const [name, argument] of [ + ["Local_alias_arg", "aliased"], + ["Foreign_alias_arg", "foreign_alias"], + ["Foreign_include_arg", "foreign_include"], + ]) { + assertIncludes( + output, + `optional argument ${argument} of function Aliases.${name}.+g is always supplied (1 calls)` + ); + } for (const [name, argument] of [ ["Repacked.Repacked_arg", "repacked"], ["Projected.Projected_arg", "projected"], @@ -921,6 +940,13 @@ function main() { "optional argument partial of function Foreign_supplied_arg.+g is always supplied (1 calls)", "optional argument partial of function Foreign_omitted_arg.+g is never used", ]); + runFunctorScanOrderTest("Unpacked_unused", "Unpacked_open", [ + "optional argument unused_open of function Unused_import.Victim.+g is never used", + "optional argument unused_open of function Unused_import.Called_victim.+g is never used", + "optional argument unused_open of function Mixed_open.Victim.+g is never used", + "optional argument foreign_alias of function Aliases.Foreign_alias_arg.+g is always supplied (1 calls)", + "optional argument foreign_include of function Aliases.Foreign_include_arg.+g is always supplied (1 calls)", + ]); runImportDigestSelectionTest(); checkDiff(); diff --git a/src/Compat.ml b/src/Compat.ml index c0ae9183..b42fdaed 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -1178,12 +1178,12 @@ let rec makeResolver ~cmtFilePath else match (unwrap definition).mod_desc with | Tmod_apply _ | Tmod_apply_unit _ | Tmod_ident _ -> ( + (* An unresolved alias is not a new functor definition. Giving + it its own key would bypass the unknown-head escape. *) match resolver with - | Some (resolver : identResolutions) -> ( - match resolver.headKey visited definition with - | Some head -> Some head - | None -> Some (loc, 0)) - | None -> Some (loc, 0)) + | Some (resolver : identResolutions) -> + resolver.headKey visited definition + | None -> None) | Tmod_unpack _ -> (* A first-class module: the functor it holds is not known here. *) diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 8bd2b35c..801f869d 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -1145,14 +1145,54 @@ let registerBindingHead ~(namePos : Lexing.position) (id : Ident.t option) | None -> ()) | None -> ()) +type unpackedExportCandidate = { + exportId : Ident.t; + exportOrigin : Typedtree.module_expr; + exportResolutions : Compat.identResolutions; + exportScope : unpackedExportCandidate list; +} + +let unpackedExportCandidates : unpackedExportCandidate list ref = ref [] + +let addUnpackedExports resolutions scope signature moduleExpr = + signature + |> List.fold_left + (fun acc item -> + match item with + | Types.Sig_module _ -> ( + match Compat.getSigModuleModtype item with + | Some (id, _, _) -> + { + exportId = id; + exportOrigin = moduleExpr; + exportResolutions = resolutions; + exportScope = scope; + } :: acc + | None -> acc) + | _ -> acc) + scope + +let rec unpackedCandidate candidates path components = + match path with + | Path.Pident id -> + List.find_opt (fun candidate -> Ident.same id candidate.exportId) candidates + |> Option.map (fun candidate -> (candidate, Ident.name id :: components)) + | Path.Pdot (parent, name) -> + unpackedCandidate candidates parent (name :: components) + | _ -> None + (* Opens and includes can introduce fresh identifiers whose unpacked origin - cannot be recovered at an application. Preserve the escape fallback for - unpacked exports, including bindings nested inside a structure wrapper. *) + cannot be recovered at an application. Follow only the demanded export: + an unused unpacked sibling must not make its parameter calls escape. *) let rec escapeUnpackedExports ?(visited = []) - ?(resolutions = !identResolutions) (e : Typedtree.module_expr) = + ?(resolutions = !identResolutions) ?(components = []) + ?(candidates = !unpackedExportCandidates) + (e : Typedtree.module_expr) = if not (List.memq e visited) then let visited = e :: visited in - let walk = escapeUnpackedExports ~visited ~resolutions in + let walk = + escapeUnpackedExports ~visited ~resolutions ~components ~candidates + in match e.mod_desc with | Tmod_unpack (packed, _) -> ( match unpackedBinding packed with @@ -1166,21 +1206,90 @@ let rec escapeUnpackedExports ?(visited = []) | Tmod_apply_unit inner -> walk inner #endif | Tmod_ident (path, _) -> ( - match resolutions.bindingOfPath path with - | Some (_, definition, resolver, _) -> - escapeUnpackedExports ~visited - ~resolutions:(Option.value resolver ~default:resolutions) definition - | None -> ()) - | Tmod_structure {str_items} -> - str_items - |> List.iter (fun (item : Typedtree.structure_item) -> - match item.str_desc with - | Tstr_module {mb_expr} -> walk mb_expr - | Tstr_recmodule bindings -> - List.iter (fun (mb : Typedtree.module_binding) -> walk mb.mb_expr) - bindings - | Tstr_include {incl_mod} -> walk incl_mod - | _ -> ()) + match unpackedCandidate candidates path components with + | Some (candidate, components) -> + escapeUnpackedExports ~visited ~components + ~resolutions:candidate.exportResolutions ~candidates:candidate.exportScope + candidate.exportOrigin + | None -> + let rec root path components = + match path with + | Path.Pdot (parent, name) -> root parent (name :: components) + | _ -> (path, components) + in + let path, components = root path components in + (match resolutions.bindingOfPath path with + | Some (_, definition, resolver, _) -> + let next = Option.value resolver ~default:resolutions in + escapeUnpackedExports ~visited ~resolutions:next ~components + ~candidates:(if next == resolutions then candidates else []) definition + | None -> ())) + | Tmod_structure {str_items} -> ( + (* A foreign structure can itself alias an identifier introduced by an + include/open. Reconstruct that lexical scope using its own AST and + resolver, without mixing identifier stamps from different units. *) + let candidates = + str_items + |> List.fold_left + (fun scope (item : Typedtree.structure_item) -> + match item.str_desc with + | Tstr_include {incl_mod; incl_type} -> + addUnpackedExports resolutions scope incl_type incl_mod + | Tstr_open {open_expr; open_bound_items} -> + addUnpackedExports resolutions scope open_bound_items open_expr + | _ -> scope) + candidates + in + let walk = + escapeUnpackedExports ~visited ~resolutions ~components ~candidates + in + match components with + | [] -> + str_items + |> List.iter (fun (item : Typedtree.structure_item) -> + match item.str_desc with + | Tstr_module {mb_expr} -> walk mb_expr + | Tstr_recmodule bindings -> + List.iter (fun (mb : Typedtree.module_binding) -> walk mb.mb_expr) + bindings + | Tstr_include {incl_mod} -> walk incl_mod + | _ -> ()) + | name :: rest -> + let matching (mb : Typedtree.module_binding) = mb.mb_name.txt = Some name in + let rec find = function + | [] -> () + | (item : Typedtree.structure_item) :: items -> ( + let binding = + match item.str_desc with + | Tstr_module mb when matching mb -> Some mb.mb_expr + | Tstr_recmodule bindings -> + List.find_opt matching bindings + |> Option.map (fun (mb : Typedtree.module_binding) -> mb.mb_expr) + | _ -> None + in + match binding with + | Some expr -> + escapeUnpackedExports ~visited ~resolutions ~components:rest + ~candidates expr + | None -> ( + match item.str_desc with + | Tstr_include {incl_mod; incl_type} + when List.exists + (fun item -> + match Compat.getSigModuleModtype item with + | Some (id, _, _) -> Ident.name id = name + | None -> false) + incl_type -> walk incl_mod + | _ -> find items)) + in + find (List.rev str_items)) + +(* Candidates are keyed by the actual identifiers introduced into scope, + not just their names. Registering an open alone does not escape anything. *) +let registerUnpackedExports signature moduleExpr = + unpackedExportCandidates := + addUnpackedExports !identResolutions !unpackedExportCandidates signature + moduleExpr let rec collectExpr super self (e : Typedtree.expression) = let locFrom = e.exp_loc in @@ -1195,10 +1304,15 @@ let rec collectExpr super self (e : Typedtree.expression) = | Texp_struct_item ({str_desc = Tstr_module {mb_id; mb_expr; mb_name}}, _) -> registerParameterAlias mb_id mb_expr; registerBindingHead ~namePos:mb_name.loc.loc_start mb_id mb_expr + | Texp_struct_item ({str_desc = Tstr_open {open_expr; open_bound_items}}, _) -> + registerUnpackedExports open_bound_items open_expr + | Texp_struct_item ({str_desc = Tstr_include {incl_mod; incl_type}}, _) -> + registerUnpackedExports incl_type incl_mod | _ -> ()); #else (match e.exp_desc with - | Texp_open ({open_expr}, _) -> escapeUnpackedExports open_expr + | Texp_open ({open_expr; open_bound_items}, _) -> + registerUnpackedExports open_bound_items open_expr | Texp_letmodule (id, name, _, moduleExpr, _) -> setFunctorKey moduleExpr name.loc.loc_start; registerParameterAlias id moduleExpr; @@ -1956,7 +2070,9 @@ let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = | _ -> () in (match headExpr.mod_desc with - | Tmod_ident (path, _) -> escapeParent path + | Tmod_ident (path, _) -> + escapeUnpackedExports headExpr; + escapeParent path | _ -> ()) | Some head -> incr nextApplicationId; @@ -2210,7 +2326,7 @@ let traverseStructure ~doTypes ~doExternals = DeadType.addDeclaration ~typeId:typeDeclaration.typ_id ~typeKind:typeDeclaration.typ_type.type_kind) | Tstr_include {incl_mod; incl_type} -> ( - escapeUnpackedExports incl_mod; + registerUnpackedExports incl_type incl_mod; (* [include M] with [M] a functor parameter: the included identifiers stand for the parameter's items. *) (match moduleIdent incl_mod with @@ -2256,7 +2372,8 @@ let traverseStructure ~doTypes ~doExternals = ~doValues:false (* TODO: also values? *) ~moduleLoc:incl_mod.mod_loc ~path:currentPath) | _ -> ()) - | Tstr_open {open_expr} -> escapeUnpackedExports open_expr + | Tstr_open {open_expr; open_bound_items} -> + registerUnpackedExports open_bound_items open_expr | Tstr_exception _ -> ( match structureItem.str_desc |> Compat.tstrExceptionGet with | Some (id, loc) -> @@ -2420,10 +2537,12 @@ let processStructure ~cmt_value_dependencies ~cmt_ident_resolutions ~doTypes ~doExternals (structure : Typedtree.structure) = let traverseStructure = traverseStructure ~doTypes ~doExternals in identResolutions := cmt_ident_resolutions; + unpackedExportCandidates := []; recordedApplications := []; functorsByIdent := []; functorKeys := []; structure |> traverseStructure.structure traverseStructure |> ignore; + unpackedExportCandidates := []; recordedApplications := []; functorKeys := []; identResolutions := Compat.emptyIdentResolutions; From 6e6feafd763c86c3b2750e7d588b91c5f405b46a Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 17 Sep 2026 14:41:59 +0000 Subject: [PATCH 50/53] Preserve escaped coercions and distinct compilation contexts --- .../regression/duplicate_context/Shared.ml | 4 + .../duplicate_context/a/Provider.ml | 1 + .../duplicate_context/b/Provider.ml | 1 + examples/regression/src/Escaped_coercion.ml | 79 +++++++++++++++++++ examples/regression/src/Main.ml | 1 + examples/regression/src/dune | 1 + scripts/run_integration_tests.js | 63 +++++++++++++++ src/DeadValue.ml | 12 ++- src/Reanalyze.ml | 16 +++- 9 files changed, 171 insertions(+), 7 deletions(-) create mode 100644 examples/regression/duplicate_context/Shared.ml create mode 100644 examples/regression/duplicate_context/a/Provider.ml create mode 100644 examples/regression/duplicate_context/b/Provider.ml create mode 100644 examples/regression/src/Escaped_coercion.ml diff --git a/examples/regression/duplicate_context/Shared.ml b/examples/regression/duplicate_context/Shared.ml new file mode 100644 index 00000000..7ad40d1e --- /dev/null +++ b/examples/regression/duplicate_context/Shared.ml @@ -0,0 +1,4 @@ +(* Both builds have the same source and inferred interface, but resolve + Provider.g against different imported interfaces. *) +let run () = ignore (Provider.g ~x:1 ()) +let () = run () diff --git a/examples/regression/duplicate_context/a/Provider.ml b/examples/regression/duplicate_context/a/Provider.ml new file mode 100644 index 00000000..8ce17cfd --- /dev/null +++ b/examples/regression/duplicate_context/a/Provider.ml @@ -0,0 +1 @@ +let g ?(x = 0) () = x diff --git a/examples/regression/duplicate_context/b/Provider.ml b/examples/regression/duplicate_context/b/Provider.ml new file mode 100644 index 00000000..d3f72e42 --- /dev/null +++ b/examples/regression/duplicate_context/b/Provider.ml @@ -0,0 +1 @@ +let g ?(x = 0) () = string_of_int x diff --git a/examples/regression/src/Escaped_coercion.ml b/examples/regression/src/Escaped_coercion.ml new file mode 100644 index 00000000..64c08acf --- /dev/null +++ b/examples/regression/src/Escaped_coercion.ml @@ -0,0 +1,79 @@ +module Escaped_only = struct + module type Arg = sig + val needed : unit -> int + val unused : unit -> int + end + module Inner (M : sig val needed : unit -> int end) = struct + let run () = M.needed () + end + module Outer (M : Arg) = Inner (M) + module type FT = functor (M : Arg) -> sig val run : unit -> int end + module Possible_arg : Arg = struct + let needed () = 1 + let unused () = 2 + end + let registry = [(module Outer : FT)] + let run () = ignore (List.length registry) +end + +module Known_and_escaped = struct + module type Arg = sig + val needed : unit -> int + val unused : unit -> int + end + module Inner (M : sig val needed : unit -> int end) = struct + let run () = M.needed () + end + module Outer (M : Arg) = Inner (M) + module type FT = functor (M : Arg) -> sig val run : unit -> int end + module Known_arg : Arg = struct + let needed () = 1 + let unused () = 2 + end + module Possible_arg : Arg = struct + let needed () = 3 + let unused () = 4 + end + module Applied = Outer (Known_arg) + let registry = [(module Outer : FT)] + let run () = ignore (Applied.run ()); ignore (List.length registry) +end + +module Never_applied = struct + module type Arg = sig val needed : unit -> int end + module Inner (M : Arg) = struct let run () = M.needed () end + module Outer (M : Arg) = Inner (M) + module Unrelated_arg : Arg = struct let needed () = 1 end +end + +module Known_only = struct + module type Arg = sig val needed : unit -> int end + module Inner (M : Arg) = struct let run () = M.needed () end + module Outer (M : Arg) = Inner (M) + module Known_arg : Arg = struct let needed () = 1 end + module Unrelated_arg : Arg = struct let needed () = 2 end + module Applied = Outer (Known_arg) + let run () = ignore (Applied.run ()) +end + +module Nested_stored = struct + module type Item = sig val needed : unit -> int val unused : unit -> int end + module type Arg = sig module N : Item end + module Inner (M : sig val needed : unit -> int end) = struct + let run () = M.needed () + end + module Outer (M : Arg) = Inner (M.N) + module type FT = functor (M : Arg) -> sig val run : unit -> int end + module Possible_arg : Arg = struct + module N = struct let needed () = 1 let unused () = 2 end + end + let packed = (module Outer : FT) + let registry = [packed] + let run () = ignore (List.length registry) +end + +let run () = + Escaped_only.run (); + Known_and_escaped.run (); + Known_only.run (); + Nested_stored.run () diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 113e7cf1..d7759fa3 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -2,6 +2,7 @@ let definitely_dead () = () let () = Attribution_sweep.run (); + Escaped_coercion.run (); Partial_context_use.run (); Live_ancestors.use_child (); Functor_argument.use_set (); diff --git a/examples/regression/src/dune b/examples/regression/src/dune index 5897274c..42337290 100644 --- a/examples/regression/src/dune +++ b/examples/regression/src/dune @@ -7,6 +7,7 @@ Cross_c Cross_include Escape_exports + Escaped_coercion Functor_argument Generated_source Higher_order diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index 65013c9f..ac434561 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -662,6 +662,19 @@ function runRegressionTests() { ); assertNotIncludes(output, `${name}.+g is never used`); } + for (const name of ["Escaped_only", "Known_and_escaped"]) { + assertIncludes(output, `Live Value +Escaped_coercion.${name}.Possible_arg.+needed`); + assertNotIncludes(output, `Dead Value +Escaped_coercion.${name}.Possible_arg.+needed`); + assertIncludes(output, `Dead Value +Escaped_coercion.${name}.Possible_arg.+unused`); + } + assertIncludes( + output, + "Dead Value +Escaped_coercion.Never_applied.Unrelated_arg.+needed" + ); + assertIncludes(output, "Live Value +Escaped_coercion.Known_only.Known_arg.+needed"); + assertIncludes(output, "Dead Value +Escaped_coercion.Known_only.Unrelated_arg.+needed"); + assertIncludes(output, "Live Value +Escaped_coercion.Nested_stored.Possible_arg.N.+needed"); + assertIncludes(output, "Dead Value +Escaped_coercion.Nested_stored.Possible_arg.N.+unused"); } assertNotIncludes(output, "Parent is a dead module"); @@ -801,6 +814,55 @@ function runByteNativeDuplicateTest() { } } +function runDuplicateContextTest() { + if (!ocamlVersionAtLeast(5, 3)) return; + const fs = require("fs"); + const os = require("os"); + const cwd = fs.mkdtempSync(path.join(os.tmpdir(), "reanalyze-context-")); + const fixture = path.join(__dirname, "..", "examples", "regression", "duplicate_context"); + try { + fs.copyFileSync(path.join(fixture, "Shared.ml"), path.join(cwd, "Shared.ml")); + for (const dir of ["a", "b"]) { + fs.mkdirSync(path.join(cwd, dir)); + fs.copyFileSync(path.join(fixture, dir, "Provider.ml"), path.join(cwd, dir, "Provider.ml")); + child_process.execFileSync("ocamlc", [ + "-bin-annot", "-bin-annot-occurrences", "-c", `${dir}/Provider.ml`, + ], { cwd }); + child_process.execFileSync("ocamlc", [ + "-bin-annot", "-bin-annot-occurrences", "-I", dir, "-c", + "-o", `${dir}/Shared.cmo`, "Shared.ml", + ], { cwd }); + } + const run = () => child_process.execFileSync( + reanalyzeFile, ["-ci", "-debug", "-dce-cmt", "."], + { cwd, encoding: "utf8" } + ); + const assertContexts = (output) => { + if ((output.match(/Scanning .*Shared\.cmt /g) || []).length !== 2) { + throw new Error("Both dependency contexts must be scanned exactly once"); + } + if ((output.match(/Live Value \+Provider\.\+g:/g) || []).length !== 2) { + throw new Error("Both dependency implementations must remain live"); + } + if ((output.match(/optional argument x of function \+g is always supplied \(1 calls\)/g) || []).length !== 2) { + throw new Error("Each dependency context must receive exactly one call"); + } + assertNotIncludes(output, "Dead Value +Provider.+g"); + }; + console.log(`${cwd}: reanalyze identical source with distinct dependency contexts`); + assertContexts(run()); + for (const dir of ["a", "b"]) { + fs.mkdirSync(path.join(cwd, dir, "install")); + for (const file of ["Provider.cmt", "Shared.cmt"]) { + fs.copyFileSync(path.join(cwd, dir, file), path.join(cwd, dir, "install", file)); + } + } + assertContexts(run()); + } finally { + fs.rmSync(cwd, { recursive: true, force: true }); + } +} + function runFunctorScanOrderTest(providerName, consumerName, assertions) { if (!ocamlVersionAtLeast(5, 3)) return; const fs = require("fs"); @@ -931,6 +993,7 @@ function main() { runRegressionTests(); runDuplicateLayoutTest(); runByteNativeDuplicateTest(); + runDuplicateContextTest(); runFunctorScanOrderTest("Unpacked_functor", "Unpacked_functor_use", [ "optional argument x of function Unpacked_arg.+g is always supplied (1 calls)", "optional argument x of function Unpacked_unused.+g is never used", diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 801f869d..2460dc42 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -2501,14 +2501,18 @@ let forceDelayedItems () = else ()) parameterCalls; Hashtbl.reset parameterCalls; - escapedHeads := []; - escapedRanges := []; (* Reference the items a parameter's coercion uses, in the arguments of the enclosing functor's applications; the module type item is the fallback - when an argument cannot be resolved. *) + when an argument cannot be resolved. An escaped functor also needs that + fallback even when some known applications resolve precisely: its + unseen applications can supply other implementations of the item. *) List.rev !parameterCoercions |> List.iter (fun {outerFunctor; outerIndex; itemPath; coercionFrom; coercionTo} -> + if isEscaped outerFunctor then + addValueReference ~addFileReference:true ~locFrom:coercionFrom + ~locTo:coercionTo + else let resolved = resolveArgumentItems ~visited:[] ~bindings:[] outerFunctor outerIndex itemPath @@ -2524,6 +2528,8 @@ let forceDelayedItems () = addValueReference ~addFileReference:true ~locFrom:coercionFrom ~locTo)); parameterCoercions := []; + escapedHeads := []; + escapedRanges := []; delayedApplications := []; Hashtbl.reset applicationIdsByPosition; Hashtbl.reset applicationPrefixes; diff --git a/src/Reanalyze.ml b/src/Reanalyze.ml index 0803baa6..07e47025 100644 --- a/src/Reanalyze.ml +++ b/src/Reanalyze.ml @@ -1,16 +1,24 @@ open Common -(* Compiled units already scanned, by source: a broad root may hold copies - of the same artifact (a library's objects and its _build/install copy, - byte and native objects), which must not be scanned twice. *) +(* Compiled units already scanned, by source and dependency context: a broad + root may hold copies of the same artifact (a library's objects and its + _build/install copy, byte and native objects), which must not be scanned + twice. *) let scannedUnits = Hashtbl.create 256 let loadCmtFile ~cmtRoot cmtFilePath = let cmt_infos = Cmt_format.read_cmt cmtFilePath in + (* Identical source can be compiled against different interfaces. Preserve + those contexts, but not the byte/native distinction: [cmt_imports] + records the reused self-interface in both artifacts, whereas + [cmt_interface_digest] can be absent from the native artifact. *) + let imports = List.sort_uniq compare cmt_infos.cmt_imports in let unitKey = - ( cmt_infos.cmt_sourcefile, + ( cmt_infos.cmt_modname, + cmt_infos.cmt_sourcefile, cmt_infos.cmt_builddir, cmt_infos.cmt_source_digest, + imports, Filename.check_suffix cmtFilePath ".cmti" ) in if Hashtbl.mem scannedUnits unitKey then () From 6d9b9541700fd363d69fd7712fd264c223558b56 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 17 Sep 2026 15:21:25 +0000 Subject: [PATCH 51/53] Fix compilation identity and chained functor attribution --- .../regression/compilation_context/First.ml | 1 + .../compilation_context/Native_provider.ml | 11 + .../compilation_context/Native_use.ml | 3 + .../regression/compilation_context/Opened.ml | 2 + .../regression/compilation_context/Second.ml | 1 + .../regression/compilation_context/Shared.ml | 19 + .../compilation_context/a/Provider.ml | 7 + .../regression/compilation_context/a/Use_a.ml | 24 ++ .../compilation_context/b/Provider.ml | 7 + .../regression/compilation_context/b/Use_b.ml | 24 ++ examples/regression/src/Main.ml | 1 + examples/regression/src/Review_round.ml | 189 +++++++++ examples/regression/src/dune | 1 + scripts/run_integration_tests.js | 101 +++++ src/Compat.ml | 112 +++-- src/DeadOptionalArgs.ml | 30 +- src/DeadValue.ml | 394 ++++++++++++------ src/Reanalyze.ml | 8 +- 18 files changed, 767 insertions(+), 168 deletions(-) create mode 100644 examples/regression/compilation_context/First.ml create mode 100644 examples/regression/compilation_context/Native_provider.ml create mode 100644 examples/regression/compilation_context/Native_use.ml create mode 100644 examples/regression/compilation_context/Opened.ml create mode 100644 examples/regression/compilation_context/Second.ml create mode 100644 examples/regression/compilation_context/Shared.ml create mode 100644 examples/regression/compilation_context/a/Provider.ml create mode 100644 examples/regression/compilation_context/a/Use_a.ml create mode 100644 examples/regression/compilation_context/b/Provider.ml create mode 100644 examples/regression/compilation_context/b/Use_b.ml create mode 100644 examples/regression/src/Review_round.ml diff --git a/examples/regression/compilation_context/First.ml b/examples/regression/compilation_context/First.ml new file mode 100644 index 00000000..4264a20c --- /dev/null +++ b/examples/regression/compilation_context/First.ml @@ -0,0 +1 @@ +let g ?(opened = 0) () = opened diff --git a/examples/regression/compilation_context/Native_provider.ml b/examples/regression/compilation_context/Native_provider.ml new file mode 100644 index 00000000..2b5f8461 --- /dev/null +++ b/examples/regression/compilation_context/Native_provider.ml @@ -0,0 +1,11 @@ +module type S = sig + val g : ?native:int -> unit -> int +end + +module Arg : S = struct + let g ?(native = 0) () = native +end + +module Make (M : S) = struct + let run () = M.g ~native:1 () +end diff --git a/examples/regression/compilation_context/Native_use.ml b/examples/regression/compilation_context/Native_use.ml new file mode 100644 index 00000000..f9893c06 --- /dev/null +++ b/examples/regression/compilation_context/Native_use.ml @@ -0,0 +1,3 @@ +module A = Native_provider.Make (Native_provider.Arg) + +let () = ignore (A.run ()) diff --git a/examples/regression/compilation_context/Opened.ml b/examples/regression/compilation_context/Opened.ml new file mode 100644 index 00000000..bfb3b594 --- /dev/null +++ b/examples/regression/compilation_context/Opened.ml @@ -0,0 +1,2 @@ +let run () = ignore (g ~opened:1 ()) +let () = run () diff --git a/examples/regression/compilation_context/Second.ml b/examples/regression/compilation_context/Second.ml new file mode 100644 index 00000000..a6ca4cd2 --- /dev/null +++ b/examples/regression/compilation_context/Second.ml @@ -0,0 +1 @@ +let g ?(opened = 0) () = opened + 1 diff --git a/examples/regression/compilation_context/Shared.ml b/examples/regression/compilation_context/Shared.ml new file mode 100644 index 00000000..5a6d0a80 --- /dev/null +++ b/examples/regression/compilation_context/Shared.ml @@ -0,0 +1,19 @@ +module type S = sig + val g : ?context:int -> unit -> int +end + +module Apply (M : S) = Provider.Op (M) +module Curried (Ignored : S) (M : S) = Provider.Op (M) + +module Seed = struct + let g ?(context = 0) () = context +end + +module Half = Curried (Seed) +module Alias = Half + +module type FT = functor (M : S) -> sig + val run : unit -> int +end + +let packed = (module Alias : FT) diff --git a/examples/regression/compilation_context/a/Provider.ml b/examples/regression/compilation_context/a/Provider.ml new file mode 100644 index 00000000..2027b359 --- /dev/null +++ b/examples/regression/compilation_context/a/Provider.ml @@ -0,0 +1,7 @@ +module type S = sig + val g : ?context:int -> unit -> int +end + +module Op (M : S) = struct + let run () = M.g ~context:1 () +end diff --git a/examples/regression/compilation_context/a/Use_a.ml b/examples/regression/compilation_context/a/Use_a.ml new file mode 100644 index 00000000..4c631f27 --- /dev/null +++ b/examples/regression/compilation_context/a/Use_a.ml @@ -0,0 +1,24 @@ +module Arg : Shared.S = struct + let g ?(context = 0) () = context +end + +module Applied = Shared.Apply (Arg) + +let () = ignore (Applied.run ()) + +module Partial_arg : Shared.S = struct + let g ?(context = 0) () = context +end + +module Partial = Shared.Alias (Partial_arg) + +module Packed_arg : Shared.S = struct + let g ?(context = 0) () = context +end + +module Unpacked = (val Shared.packed : Shared.FT) +module Packed = Unpacked (Packed_arg) + +let () = + ignore (Partial.run ()); + ignore (Packed.run ()) diff --git a/examples/regression/compilation_context/b/Provider.ml b/examples/regression/compilation_context/b/Provider.ml new file mode 100644 index 00000000..3e1fc2a4 --- /dev/null +++ b/examples/regression/compilation_context/b/Provider.ml @@ -0,0 +1,7 @@ +module type S = sig + val g : ?context:int -> unit -> int +end + +module Op (M : S) = struct + let run () = M.g () +end diff --git a/examples/regression/compilation_context/b/Use_b.ml b/examples/regression/compilation_context/b/Use_b.ml new file mode 100644 index 00000000..4c631f27 --- /dev/null +++ b/examples/regression/compilation_context/b/Use_b.ml @@ -0,0 +1,24 @@ +module Arg : Shared.S = struct + let g ?(context = 0) () = context +end + +module Applied = Shared.Apply (Arg) + +let () = ignore (Applied.run ()) + +module Partial_arg : Shared.S = struct + let g ?(context = 0) () = context +end + +module Partial = Shared.Alias (Partial_arg) + +module Packed_arg : Shared.S = struct + let g ?(context = 0) () = context +end + +module Unpacked = (val Shared.packed : Shared.FT) +module Packed = Unpacked (Packed_arg) + +let () = + ignore (Partial.run ()); + ignore (Packed.run ()) diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index d7759fa3..5064ef53 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -1,6 +1,7 @@ let definitely_dead () = () let () = + Review_round.run (); Attribution_sweep.run (); Escaped_coercion.run (); Partial_context_use.run (); diff --git a/examples/regression/src/Review_round.ml b/examples/regression/src/Review_round.ml new file mode 100644 index 00000000..d91f6318 --- /dev/null +++ b/examples/regression/src/Review_round.ml @@ -0,0 +1,189 @@ +module Mixed_holders = struct + module type S = sig + val g : ?mixed:int -> unit -> int + end + + module type Holder = sig + module Inner (M : S) : sig + val run : unit -> int + end + end + + module Apply (H : Holder) (M : S) = struct + module A = H.Inner (M) + + let run = A.run + end + + module Known = struct + module Inner (M : S) = struct + let run () = M.g ~mixed:1 () + end + end + + module Known_arg : S = struct + let g ?(mixed = 0) () = mixed + end + + module Anonymous_arg : S = struct + let g ?(mixed = 0) () = mixed + end + + module Included_arg : S = struct + let g ?(mixed = 0) () = mixed + end + + module Omitted_arg : S = struct + let g ?(mixed = 0) () = mixed + end + + module Unrelated_arg : S = struct + let g ?(mixed = 0) () = mixed + end + + module A = Apply (Known) (Known_arg) + + module B = + Apply + (struct + module Inner (M : S) = struct + let run () = M.g ~mixed:1 () + end + end) + (Anonymous_arg) + + module C = + Apply + (struct + module Nested = struct + module F (M : S) = struct + let run () = M.g ~mixed:1 () + end + end + + include struct + module Inner = Nested.F + end + end) + (Included_arg) + + module D = + Apply + (struct + module Inner (M : S) = struct + let run () = M.g () + end + end) + (Omitted_arg) + + let run () = + ignore (A.run ()); + ignore (B.run ()); + ignore (C.run ()); + ignore (D.run ()); + ignore (Unrelated_arg.g ()) +end + +module Partial_result = struct + module type S = sig end + + module type FT = functor (M : S) (N : S) -> sig + val run : ?result:int -> unit -> int + val unused : unit -> int + end + + module type Half = functor (N : S) -> sig + val run : ?result:int -> unit -> int + val unused : unit -> int + end + + module F (M : S) (N : S) = struct + let run ?(result = 0) () = result + let unused () = 0 + end + + let packed = (module F : FT) + + module G = (val packed : FT) + module H = G (struct end) + + let repacked = (module H : Half) + + module I = (val repacked : Half) + module J = I (struct end) + module K = H (struct end) + + (* Two paths reach the same implementation; neither may duplicate calls. *) + let run () = + ignore (J.run ~result:1 ()); + ignore (K.run ~result:2 ()) +end + +module Local_alias = struct + module type S = sig + val g : ?local_alias:int -> unit -> int + end + + module type Holder_t = sig + module Inner (M : S) : sig + val run : unit -> int + end + end + + module Holder = struct + module Inner (M : S) = struct + let run () = M.g ~local_alias:1 () + end + end + + let packed = (module Holder : Holder_t) + + module Arg : S = struct + let g ?(local_alias = 0) () = local_alias + end + + let run () = + let open (val packed : Holder_t) in + let module Alias = Inner in + let module A = Alias (Arg) in + ignore (A.run ()) +end + +module Recursive_alias = struct + module type S = sig + val g : ?recursive_alias:int -> unit -> int + end + + module type FT = functor (M : S) -> sig + val run : unit -> int + end + + module type Holder_t = sig + module Inner : FT + end + + module Holder = struct + module Inner (M : S) = struct + let run () = M.g ~recursive_alias:1 () + end + end + + let packed = (module Holder : Holder_t) + + open (val packed : Holder_t) + module rec Alias : FT = Inner + + module Arg : S = struct + let g ?(recursive_alias = 0) () = recursive_alias + end + + module Applied = Alias (Arg) + + let run () = ignore (Applied.run ()) +end + +let run () = + Mixed_holders.run (); + Partial_result.run (); + Local_alias.run (); + Recursive_alias.run () diff --git a/examples/regression/src/dune b/examples/regression/src/dune index 42337290..b1ee6da1 100644 --- a/examples/regression/src/dune +++ b/examples/regression/src/dune @@ -24,6 +24,7 @@ Packed_types Partial_context_use Reference_order + Review_round Shared_signature Shared_signature_arg Shared_signature_unused diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index ac434561..7178885b 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -675,6 +675,18 @@ function runRegressionTests() { assertIncludes(output, "Dead Value +Escaped_coercion.Known_only.Unrelated_arg.+needed"); assertIncludes(output, "Live Value +Escaped_coercion.Nested_stored.Possible_arg.N.+needed"); assertIncludes(output, "Dead Value +Escaped_coercion.Nested_stored.Possible_arg.N.+unused"); + for (const name of ["Known_arg", "Anonymous_arg", "Included_arg"]) { + assertIncludes(output, `optional argument mixed of function Mixed_holders.${name}.+g is always supplied (1 calls)`); + } + for (const name of ["Omitted_arg", "Unrelated_arg"]) { + assertIncludes(output, `optional argument mixed of function Mixed_holders.${name}.+g is never used`); + } + assertIncludes(output, "Live Value +Review_round.Partial_result.F.+run"); + assertNotIncludes(output, "Dead Value +Review_round.Partial_result.F.+run"); + assertIncludes(output, "Dead Value +Review_round.Partial_result.F.+unused"); + assertIncludes(output, "optional argument result of function Partial_result.F.+run is always supplied (2 calls)"); + assertIncludes(output, "optional argument local_alias of function Local_alias.Arg.+g is always supplied (1 calls)"); + assertIncludes(output, "optional argument recursive_alias of function Recursive_alias.Arg.+g is always supplied (1 calls)"); } assertNotIncludes(output, "Parent is a dead module"); @@ -863,6 +875,94 @@ function runDuplicateContextTest() { } } +function runCompilationContextTests() { + if (!ocamlVersionAtLeast(5, 3)) return; + const fs = require("fs"); + const cwd = fs.mkdtempSync(path.join(require("os").tmpdir(), "reanalyze-typing-context-")); + const fixture = path.join(__dirname, "..", "examples", "regression", "compilation_context"); + const copy = (name) => fs.copyFileSync(path.join(fixture, name), path.join(cwd, name)); + const compile = (args, compiler = "ocamlc") => child_process.execFileSync( + compiler, ["-bin-annot", "-bin-annot-occurrences", ...args], { cwd } + ); + const run = (root, debug = false) => child_process.execFileSync( + reanalyzeFile, ["-ci", ...(debug ? ["-debug"] : []), "-dce-cmt", root], + { cwd, encoding: "utf8" } + ); + try { + for (const dir of ["a", "b", "native_layout/byte", "native_layout/native"]) { + fs.mkdirSync(path.join(cwd, dir), { recursive: true }); + } + copy("Shared.ml"); + for (const dir of ["a", "b"]) { + for (const file of ["Provider.ml", `Use_${dir}.ml`]) copy(`${dir}/${file}`); + compile(["-c", `${dir}/Provider.ml`]); + compile(["-I", dir, "-c", "-o", `${dir}/Shared.cmo`, "Shared.ml"]); + compile(["-I", dir, "-c", `${dir}/Use_${dir}.ml`]); + } + console.log(`${cwd}: reanalyze functor identity in separate compilation contexts`); + const supplied = "optional argument context of function Arg.+g is always supplied (1 calls)"; + const omitted = "optional argument context of function Arg.+g is never used"; + assertIncludes(run("a"), supplied); + assertIncludes(run("b"), omitted); + const assertContexts = (output) => { + assertIncludes(output, supplied); + assertIncludes(output, omitted); + for (const name of ["Partial_arg", "Packed_arg"]) { + assertIncludes(output, `optional argument context of function ${name}.+g is always supplied (1 calls)`); + assertIncludes(output, `optional argument context of function ${name}.+g is never used`); + } + if ((output.match(/Scanning .*Shared\.cmt /g) || []).length !== 2) { + throw new Error("Both Shared functor contexts must be scanned exactly once"); + } + }; + assertContexts(run(".", true)); + + for (const name of ["First", "Second", "Opened"]) copy(`${name}.ml`); + compile(["-c", "First.ml"]); + compile(["-c", "Second.ml"]); + compile(["-open", "First", "-open", "Second", "-c", "-o", "a/Opened.cmo", "Opened.ml"]); + compile(["-open", "Second", "-open", "First", "-c", "-o", "b/Opened.cmo", "Opened.ml"]); + const assertOpens = (output) => { + for (const name of ["First", "Second"]) { + assertIncludes(output, `Live Value +${name}.+g`); + assertNotIncludes(output, `Dead Value +${name}.+g`); + } + if ((output.match(/Scanning .*Opened\.cmt /g) || []).length !== 2 || + (output.match(/optional argument opened of function \+g is always supplied \(1 calls\)/g) || []).length !== 2) { + throw new Error("Ordered -open contexts must each contribute one call"); + } + }; + console.log(`${cwd}: reanalyze ordered implicit opens`); + assertOpens(run(".", true)); + for (const dir of ["a", "b"]) { + fs.mkdirSync(path.join(cwd, dir, "install")); + for (const file of fs.readdirSync(path.join(cwd, dir)).filter((f) => f.endsWith(".cmt"))) { + fs.copyFileSync(path.join(cwd, dir, file), path.join(cwd, dir, "install", file)); + } + } + const copies = run(".", true); + assertContexts(copies); + assertOpens(copies); + + for (const name of ["Native_provider", "Native_use"]) { + copy(`${name}.ml`); + compile(["-I", "native_layout/byte", "-c", "-o", `native_layout/byte/${name}.cmo`, `${name}.ml`]); + } + for (const name of ["Native_provider", "Native_use"]) { + compile(["-intf-suffix", ".ml", "-I", "native_layout/byte", "-I", "native_layout/native", + "-c", "-o", `native_layout/native/${name}.cmx`, `${name}.ml`], "ocamlopt"); + } + console.log(`${cwd}: reanalyze native-only cross-unit functor imports`); + const byte = run("native_layout/byte"); + assertIncludes(byte, "optional argument native of function Arg.+g is always supplied (1 calls)"); + for (const root of ["native_layout/native", "native_layout"]) { + if (run(root) !== byte) throw new Error(`Cross-unit attribution changed for ${root}`); + } + } finally { + fs.rmSync(cwd, { recursive: true, force: true }); + } +} + function runFunctorScanOrderTest(providerName, consumerName, assertions) { if (!ocamlVersionAtLeast(5, 3)) return; const fs = require("fs"); @@ -994,6 +1094,7 @@ function main() { runDuplicateLayoutTest(); runByteNativeDuplicateTest(); runDuplicateContextTest(); + runCompilationContextTests(); runFunctorScanOrderTest("Unpacked_functor", "Unpacked_functor_use", [ "optional argument x of function Unpacked_arg.+g is always supplied (1 calls)", "optional argument x of function Unpacked_unused.+g is never used", diff --git a/src/Compat.ml b/src/Compat.ml index b42fdaed..b0396399 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -22,6 +22,43 @@ let filter_map f = aux [] #endif +(* The interface reused by a native compilation can be recorded only as a + self-import: its .cmt has no direct interface digest or sibling .cmti. *) +let interfaceDigest (infos : Cmt_format.cmt_infos) = + match infos.cmt_interface_digest with + | Some _ as digest -> digest + | None -> Option.join (List.assoc_opt infos.cmt_modname infos.cmt_imports) + +(* Output paths, backend options, and -I directories do not identify a typed + compilation: byte/native and install copies must share it. Imports identify + the resolved interfaces, but not ordered implicit opens or preprocessing. + Retain those source/typing options in command-line order. *) +let compilationContext (infos : Cmt_format.cmt_infos) = + let rec typingArgs = function + | (("-open" | "-pp" | "-ppx" | "-for-pack" | "-keywords") as flag) + :: value :: rest -> + flag :: value :: typingArgs rest + | (( "-principal" | "-no-principal" | "-rectypes" | "-no-rectypes" + | "-labels" | "-nolabels" | "-modern" | "-app-funct" | "-no-app-funct" + | "-alias-deps" | "-no-alias-deps" | "-opaque" | "-noassert" | "-unsafe" + | "-nopervasives" | "-safe-string" | "-unsafe-string" + | "-strict-sequence" | "-no-strict-sequence" | "-strict-formats" + | "-no-strict-formats" | "-unboxed-types" | "-no-unboxed-types" + | "-keep-docs" | "-no-keep-docs" | "-keep-locs" | "-no-keep-locs" ) as + flag) + :: rest -> + flag :: typingArgs rest + | _ :: rest -> typingArgs rest + | [] -> [] + in + ( infos.cmt_modname, + infos.cmt_sourcefile, + infos.cmt_builddir, + infos.cmt_source_digest, + List.sort_uniq compare infos.cmt_imports, + typingArgs (Array.to_list infos.cmt_args) ) + |> fun key -> Digest.to_hex (Digest.string (Marshal.to_string key [])) + let getStringValue const = match const with #if OCAML_VERSION >= (4, 11, 0) | Parsetree.Pconst_string(s, _, _) -> s @@ -342,6 +379,7 @@ let registerCmtFile path = .cmt), and the uid -> declaration table (merged from .cmt and .cmti). Loaded on demand. *) type unitInfo = { + context : string; shape : Shape.t option; structure : Typedtree.structure option; uidToDecl : Typedtree.item_declaration Shape.Uid.Tbl.t; @@ -420,10 +458,10 @@ let loadUnitInfo ~currentCmtFile ~(imports : Misc.crcs) comp_unit = let loaded = files |> List.filter_map read in let interfaceDigest path = match List.assoc_opt path loaded with - | Some infos -> infos.Cmt_format.cmt_interface_digest + | Some infos -> interfaceDigest infos | None -> ( match read path with - | Some (_, infos) -> infos.Cmt_format.cmt_interface_digest + | Some (_, infos) -> interfaceDigest infos | None -> None) in let selected = @@ -450,9 +488,7 @@ let loadUnitInfo ~currentCmtFile ~(imports : Misc.crcs) comp_unit = loaded |> List.filter (fun (_, (cmt_infos : Cmt_format.cmt_infos)) -> let key = - ( cmt_infos.cmt_sourcefile, - cmt_infos.cmt_builddir, - cmt_infos.cmt_impl_shape <> None ) + (compilationContext cmt_infos, cmt_infos.cmt_impl_shape <> None) in if Hashtbl.mem seen key then false else ( @@ -482,7 +518,7 @@ let loadUnitInfo ~currentCmtFile ~(imports : Misc.crcs) comp_unit = shape := cmt_infos.cmt_impl_shape; implementation := Some (path, cmt_infos) | _ -> ()); - let cmtPath, unitImports, occurrences, structure = + let cmtPath, unitImports, occurrences, structure, context = match (!implementation, loaded) with | Some (path, cmt_infos), _ | None, (path, cmt_infos) :: _ -> let structure = @@ -490,11 +526,12 @@ let loadUnitInfo ~currentCmtFile ~(imports : Misc.crcs) comp_unit = | Implementation structure -> Some structure | _ -> None in - (path, cmt_infos.cmt_imports, cmt_infos.cmt_ident_occurrences, structure) - | None, [] -> ("", [], [], None) + (path, cmt_infos.cmt_imports, cmt_infos.cmt_ident_occurrences, structure, + compilationContext cmt_infos) + | None, [] -> ("", [], [], None, "") in let info = - {shape = !shape; structure; uidToDecl; cmtPath; unitImports; occurrences} + {shape = !shape; structure; uidToDecl; cmtPath; unitImports; occurrences; context} in Hashtbl.replace unitInfoCache cacheKey info; Some info) @@ -581,7 +618,7 @@ let extractValueDependencies ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) = in let interface_digest_of_file path = match read_cmt path with - | Some infos -> infos.cmt_interface_digest + | Some infos -> interfaceDigest infos | None -> None in let loadedUnits : (string, Typedtree.item_declaration UidTbl.t list) Hashtbl.t @@ -692,7 +729,13 @@ let noHeadVisited : headVisited = () #endif +(* Source positions remain diagnostic locations, but are not identities when + the same source is compiled in different dependency/typing contexts. *) +type definitionKey = Lexing.position * string + type identResolutions = { + context : string; + valueKey : Types.value_description -> definitionKey; valueImpl : Location.t -> string -> Location.t option; (** occurrence location, last name -> implementation location *) moduleShape : Location.t -> string -> moduleShape option; @@ -701,8 +744,8 @@ type identResolutions = { (** implementation of a value item of a module shape *) projModule : moduleShape -> string -> moduleShape option; (** shape of a module item of a module shape *) - moduleDefLoc : Location.t -> string -> Location.t option; - (** occurrence location, last name -> location of the module binding's + moduleDefKey : Location.t -> string -> definitionKey option; + (** occurrence location, last name -> key of the module binding's name, for a module (e.g. a functor) defined with [module X = ...] *) moduleTypeOf : Location.t -> string -> Types.module_type option; (** occurrence location, last name -> the module type a @@ -717,13 +760,13 @@ type identResolutions = { (Location.t * Typedtree.module_expr * identResolutions option * int) option; (** the binding a module path denotes, structurally, with the resolver of its unit and the number of functor layers the path applied *) - headKeyOfPath : Path.t -> (Location.t * int) option; - (** the binding name location of the functor a module path denotes, + headKeyOfPath : Path.t -> (definitionKey * int) option; + (** the binding key of the functor a module path denotes, found structurally, and the arguments consumed *) headKey : - headVisited -> Typedtree.module_expr -> (Location.t * int) option; + headVisited -> Typedtree.module_expr -> (definitionKey * int) option; (** visited bindings (start with [noHeadVisited]), module expression -> - the binding name location of the functor it stands for, through + the binding key of the functor it stands for, through aliases and partial applications (possibly bound in other units, resolved with those units' own occurrence data), and the number of arguments those partial applications consumed; inline functors are @@ -735,11 +778,13 @@ type identResolutions = { let emptyIdentResolutions = { + context = ""; + valueKey = (fun vd -> (vd.Types.val_loc.loc_start, "")); valueImpl = (fun _ _ -> None); moduleShape = (fun _ _ -> None); projValue = (fun _ _ -> None); projModule = (fun _ _ -> None); - moduleDefLoc = (fun _ _ -> None); + moduleDefKey = (fun _ _ -> None); moduleTypeOf = (fun _ _ -> None); moduleTypeOfPath = (fun _ -> None); shapeValueItems = (fun _ -> []); @@ -815,7 +860,7 @@ let applyUnitShape (functorShape : moduleShape) : moduleShape = there (aliases and partial applications of functors). *) let resolverCache : (string, identResolutions) Hashtbl.t = Hashtbl.create 16 -let rec makeResolver ~cmtFilePath +let rec makeResolver ~cmtFilePath ~context ~(local : Typedtree.item_declaration Shape.Uid.Tbl.t) ~(imports : Misc.crcs) ~(implShape : Shape.t option) ~(occurrences : (Longident.t Location.loc * Shape_reduce.result) list) : @@ -939,7 +984,7 @@ let rec makeResolver ~cmtFilePath | None -> None in let selfRef = ref emptyIdentResolutions in - let headKeyOfPathRef = ref (fun (_ : Path.t) -> (None : (Location.t * int) option)) in + let headKeyOfPathRef = ref (fun (_ : Path.t) -> (None : (definitionKey * int) option)) in let moduleTypeOfPathRef = ref (fun (_ : Path.t) -> (None : Types.module_type option)) in let bindingOfUid = moduleBindingOfUid ~currentCmtFile:cmtFilePath ~imports ~local @@ -1098,6 +1143,13 @@ let rec makeResolver ~cmtFilePath | _ -> None in let self : identResolutions = { + context; + valueKey = (fun vd -> + let context = match resolverOfUid vd.Types.val_uid with + | Some resolver -> resolver.context + | None -> context + in + (vd.val_loc.loc_start, context)); valueImpl = (fun loc name -> match Hashtbl.find_opt values (key loc name) with @@ -1112,7 +1164,7 @@ let rec makeResolver ~cmtFilePath projModule = (fun shape name -> Some (Shape.proj shape (Shape.Item.make name Module))); - moduleDefLoc = + moduleDefKey = (fun loc name -> match Hashtbl.find_opt moduleUids (key loc name) with | Some uid -> ( @@ -1121,6 +1173,12 @@ let rec makeResolver ~cmtFilePath moduleBindingLocOfUid ~currentCmtFile:cmtFilePath ~imports ~local uid |> nonGhost + |> Option.map (fun loc -> + let context = match resolverOfUid uid with + | Some resolver -> resolver.context + | None -> context + in + (loc.Location.loc_start, context)) | None -> None) | None -> None); moduleTypeOf = @@ -1188,7 +1246,12 @@ let rec makeResolver ~cmtFilePath (* A first-class module: the functor it holds is not known here. *) None - | _ -> Some (loc, 0) + | _ -> + let context = match resolver with + | Some resolver -> resolver.context + | None -> context + in + Some ((loc.loc_start, context), 0) in headKeyOfPathRef := (fun path -> @@ -1205,7 +1268,7 @@ let rec makeResolver ~cmtFilePath | Some (loc, consumed) -> Some (loc, consumed + 1) | None -> None) | Tmod_constraint (inner, _, _, _) -> headKey visited inner - | Tmod_functor _ -> Some (e.mod_loc, 0) + | Tmod_functor _ -> Some ((e.mod_loc.loc_start, context), 0) | Tmod_ident (path, lid) -> ( let byOccurrence = match Longident.last lid.txt with @@ -1385,7 +1448,7 @@ and resolverForUnit ~currentCmtFile ~imports comp_unit = | Some resolver -> Some resolver | None -> let resolver = - makeResolver ~cmtFilePath:info.cmtPath ~local:info.uidToDecl + makeResolver ~cmtFilePath:info.cmtPath ~context:info.context ~local:info.uidToDecl ~imports:info.unitImports ~implShape:info.shape ~occurrences:info.occurrences in @@ -1397,7 +1460,8 @@ and resolverForUnit ~currentCmtFile ~imports comp_unit = let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : identResolutions = #if OCAML_VERSION >= (5, 3, 0) - makeResolver ~cmtFilePath ~local:cmt_infos.cmt_uid_to_decl + makeResolver ~cmtFilePath ~context:(compilationContext cmt_infos) + ~local:cmt_infos.cmt_uid_to_decl ~imports:cmt_infos.cmt_imports ~implShape:cmt_infos.cmt_impl_shape ~occurrences:cmt_infos.cmt_ident_occurrences #else diff --git a/src/DeadOptionalArgs.ml b/src/DeadOptionalArgs.ml index 61deef4c..13bcf6e8 100644 --- a/src/DeadOptionalArgs.ml +++ b/src/DeadOptionalArgs.ml @@ -92,16 +92,28 @@ let settleDelayedItems () = (* 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 = +let forwardDelayedItems dependencies = + (* Traverse each original call independently. A diamond or cycle in the + signature graph must not multiply a call, while distinct calls with the + same argument labels must remain distinct. Declarations are endpoints: + ordinary function references handle their optional-argument state. *) + delayedItems := !delayedItems - |> List.filter_map (fun item -> - if item.posTo = posFrom then - Some {item with posTo} - else None) - in - delayedItems := forwarded @ !delayedItems + |> List.concat_map (fun item -> + let rec visit seen pos = + if PosSet.mem pos seen then seen + else + let seen = PosSet.add pos seen in + if PosHash.mem decls pos then seen + else + PosSet.fold + (fun target seen -> visit seen target) + (PosHash.findSet dependencies pos) + seen + in + visit PosSet.empty item.posTo + |> PosSet.elements + |> List.map (fun posTo -> {item with posTo})) let forceDelayedItems () = let items = !delayedItems |> List.rev in diff --git a/src/DeadValue.ml b/src/DeadValue.ml index 2460dc42..f61cd116 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -99,9 +99,27 @@ let collectValueBinding super self (vb : Typedtree.value_binding) = Current.lastBinding := oldLastBinding; r +(* Implementation locations and compilation identities resolved through + shapes. See [Compat.resolveIdentOccurrences]. *) +let identResolutions = ref Compat.emptyIdentResolutions + +type definitionKey = Compat.definitionKey + +let definitionKey ?(resolutions = !identResolutions) pos = + (pos, resolutions.Compat.context) + +let keyToString (pos, _) = posToString pos + +module DefinitionSet = Set.Make (struct + type t = definitionKey + let compare = compare +end) + +type definitionRange = definitionKey * Lexing.position + type functorParameter = { paramId : Ident.t; - functorDef : Lexing.position; + functorDef : definitionKey; (** position of the name of the module binding defining the functor *) paramIndex : int; (** position of the parameter, for curried functors *) prefix : string list; @@ -135,30 +153,30 @@ type parameterCall = { } let parameterCalls : - (Lexing.position * int * string list, parameterCall list) Hashtbl.t = + (definitionKey * int * string list, parameterCall list) Hashtbl.t = Hashtbl.create 16 type argumentResolver = | Direct of (string list -> Location.t option) (** implementation of a value of the actual argument, by path *) - | ViaParameter of Lexing.position * int * string list + | ViaParameter of definitionKey * int * string list (** the argument is (a submodule of) a parameter of the enclosing functor: resolved through that functor's own applications *) (* The functor an application chain applies. *) type functorHead = - | Key of Lexing.position * int + | Key of definitionKey * int (** a functor's key, and the arguments partial applications already consumed, as in [module G = F (A)] followed by [G (B)] *) - | Partial of Lexing.position * functorHead + | Partial of definitionKey * functorHead (** application expression supplying the already consumed arguments; retained so separate partial bindings keep their own context *) - | ParamHead of Lexing.position * int * string list * int + | ParamHead of definitionKey * int * string list * int (** (a submodule of) a parameter of the enclosing functor, applied in its body: the functor's key, the parameter's index, the path within the parameter, and the arguments already consumed. Which functors it stands for is known once all applications are recorded. *) - | Packed of Lexing.position * int + | Packed of definitionKey * int (** a first-class module unpacked from a value, [(val packed : FT)]: the position of the value's binding, and the arguments consumed. Resolved once all files are scanned, through [packedModules]. *) @@ -174,23 +192,23 @@ type delayedApplication = { argHead : string list -> functorHead option; (** the functor (a submodule of) the argument denotes, when the argument is passed on to a higher-order functor parameter *) - bindings : (Lexing.position * int) list; + bindings : (definitionKey * int) list; (** for an application derived from a parameter-headed one ([F (M)] in the body of [Outer (F) (M)]): the application of each enclosing functor the head came through, by the functor's key. A parameter of such a functor then resolves through that application only, so that [M] pairs with the [F] of the same application. *) - argRange : (Lexing.position * Lexing.position) list; + argRange : definitionRange list; (** source ranges of the argument's definition, see [escapedRanges] *) } let delayedApplications : delayedApplication list ref = ref [] let nextApplicationId = ref 0 -let applicationIdsByPosition : (Lexing.position, int list) Hashtbl.t = +let applicationIdsByPosition : (definitionKey, int list) Hashtbl.t = Hashtbl.create 16 -let applicationPrefixes : (int, Lexing.position list) Hashtbl.t = +let applicationPrefixes : (int, definitionKey list) Hashtbl.t = Hashtbl.create 16 (* Unit-only applications have no argument record but can still extend a @@ -268,34 +286,34 @@ let applicationsOf ~bindings functorDef argIndex = covered by source ranges rather than keys. *) let escapedHeads : functorHead list ref = ref [] -let escapedRanges : (Lexing.position * Lexing.position) list ref = ref [] +let escapedRanges : definitionRange list ref = ref [] (* Positions of the value expressions that are the operand of a [(val e : S)], and the values (by binding position) used anywhere else: a packed module used only through direct unpacks is followed precisely, any other use makes it escape. *) let unpackOperands = ref PosSet.empty -let usedOutsideUnpack = ref PosSet.empty +let usedOutsideUnpack = ref DefinitionSet.empty -let inRanges (pos : Lexing.position) ranges = +let inRanges ((pos : Lexing.position), context) ranges = ranges - |> List.exists (fun ((start : Lexing.position), (stop : Lexing.position)) -> - start.pos_fname = pos.pos_fname + |> List.exists (fun (((start : Lexing.position), rangeContext), (stop : Lexing.position)) -> + context = rangeContext && start.pos_fname = pos.pos_fname && start.pos_cnum <= pos.pos_cnum && pos.pos_cnum <= stop.pos_cnum) let rec functorHeadToString head = match head with - | Key (pos, consumed) -> Printf.sprintf "%s+%d" (pos |> posToString) consumed + | Key (pos, consumed) -> Printf.sprintf "%s+%d" (pos |> keyToString) consumed | Partial (pos, head) -> - Printf.sprintf "partial(%s,%s)" (pos |> posToString) + Printf.sprintf "partial(%s,%s)" (pos |> keyToString) (functorHeadToString head) | ParamHead (def, index, components, consumed) -> - Printf.sprintf "param(%s,%d,%s)+%d" (def |> posToString) index + Printf.sprintf "param(%s,%d,%s)+%d" (def |> keyToString) index (String.concat "." components) consumed | Packed (pos, consumed) -> - Printf.sprintf "packed(%s)+%d" (pos |> posToString) consumed + Printf.sprintf "packed(%s)+%d" (pos |> keyToString) consumed (* [let packed = (module M : S)]: what the first-class value holds, by the position of its binding, for [(val packed : S)] used as a functor or as an @@ -306,11 +324,11 @@ type packedModule = { packedHead : functorHead option; packedShape : Compat.moduleShape option; packedConcrete : Types.module_type option; - packedRange : (Lexing.position * Lexing.position) list; + packedRange : definitionRange list; packedExpr : Typedtree.module_expr; } -let packedModules : (Lexing.position, packedModule) Hashtbl.t = +let packedModules : (definitionKey, packedModule) Hashtbl.t = Hashtbl.create 4 (* Whether a packed module expression is the right-hand side of a value @@ -321,9 +339,9 @@ let isRegisteredPack (moduleExpr : Typedtree.module_expr) = packedModules false (* The binding a [(val e : S)] unpacks, when [e] names a value. *) -let unpackedBinding (e : Typedtree.expression) = +let unpackedBinding ?(resolutions = !identResolutions) (e : Typedtree.expression) = match e.exp_desc with - | Texp_ident (_, _, {val_loc}) -> Some val_loc.loc_start + | Texp_ident (_, _, vd) -> Some (resolutions.Compat.valueKey vd) | _ -> None (* Implementations of a value of the argument at [argIndex] of every @@ -387,13 +405,13 @@ let rec resolvePackedHead ~sigToImpl ?(visited = []) head = (* The functors (a submodule of) the argument at [argIndex] of the applications of [functorDef] denotes: their keys, the arguments they consumed, and the applications they came through. *) -let rec resolveHeads ~sigToImpl ~visited ~bindings functorDef argIndex +let rec resolveHeads ?(onUnresolved = fun _ -> ()) ~sigToImpl ~visited ~bindings functorDef argIndex components = if List.mem (functorDef, argIndex, components) visited then [] else let visited = (functorDef, argIndex, components) :: visited in applicationsOf ~bindings functorDef argIndex - |> List.concat_map (fun {applicationId; argHead; bindings = own} -> + |> List.concat_map (fun ({applicationId; argHead; bindings = own} as application) -> let here = mergeBindings (((functorDef, applicationId) :: own) @ bindings) in @@ -410,12 +428,14 @@ let rec resolveHeads ~sigToImpl ~visited ~bindings functorDef argIndex | Some (Key (pos, consumed), sources) -> withPrefixes sources (pos, consumed, here) | Some (ParamHead (def, index, prefix, consumed), sources) -> - resolveHeads ~sigToImpl ~visited ~bindings:here def index + resolveHeads ~onUnresolved ~sigToImpl ~visited ~bindings:here def index prefix |> List.map (fun (pos, consumed', bindings) -> (pos, consumed + consumed', bindings)) |> List.concat_map (withPrefixes sources) - | Some ((Packed _ | Partial _), _) | None -> []) + | Some ((Packed _ | Partial _), _) | None -> + onUnresolved application; + []) (* Applications headed by a functor parameter stand for the applications of the functors passed for it. Resolved to a fixed point, as an argument may @@ -492,14 +512,25 @@ let resolveParameterHeadedApplications ~sigToImpl = loop ()) in loop (); - (* Only genuinely unresolved templates escape; retaining resolved ones - here would unnecessarily forward precisely attributed calls. *) + (* One resolved branch does not prove that all applications resolved. + Escape the unknown arguments, not their precisely resolved siblings. *) + let escapeArgument {argRange; argHead} = + escapedRanges := argRange @ !escapedRanges; + match argHead [] with + | Some head -> escapedHeads := head :: !escapedHeads + | None -> () + in delayedApplications := !delayedApplications |> List.filter (fun application -> match application.appliedFunctor with | ParamHead (def, index, components, _) -> - heads application def index components = [] + let onUnresolved argument = + escapeArgument argument; + escapeArgument application + in + resolveHeads ~onUnresolved ~sigToImpl ~visited:[] + ~bindings:application.bindings def index components = [] | Key _ | Packed _ | Partial _ -> true); !delayedApplications |> List.iter (fun {appliedFunctor; argIndex; argHead; argRange} -> @@ -561,14 +592,14 @@ let escapePackedModulesUsedElsewhere ~sigToImpl = let usedElsewhere = ref !usedOutsideUnpack in Hashtbl.iter (fun sigPos implPos -> - if PosSet.mem sigPos !usedOutsideUnpack then - usedElsewhere := PosSet.add implPos !usedElsewhere) + if DefinitionSet.mem sigPos !usedOutsideUnpack then + usedElsewhere := DefinitionSet.add implPos !usedElsewhere) sigToImpl; Hashtbl.iter (fun pos {packedHead; packedRange} -> - if PosSet.mem pos !usedElsewhere then ( + if DefinitionSet.mem pos !usedElsewhere then ( if !Common.Cli.debug then - Log_.item "packedEscapes %s@." (pos |> posToString); + Log_.item "packedEscapes %s@." (pos |> keyToString); escapedRanges := packedRange @ !escapedRanges; match packedHead with | Some head -> escapedHeads := head :: !escapedHeads @@ -579,7 +610,7 @@ let escapePackedModulesUsedElsewhere ~sigToImpl = [module Outer (M : S) = Inner (M)]: credited to the arguments of the enclosing functor's applications, once all files are scanned. *) type parameterCoercion = { - outerFunctor : Lexing.position; + outerFunctor : definitionKey; outerIndex : int; itemPath : string list; coercionFrom : Location.t; @@ -607,13 +638,13 @@ let rec moduleIdent (moduleExpr : Typedtree.module_expr) = Functors not listed (inline applications) are keyed by their own position. A list rather than a single slot, as the mapper may visit a binding's body (and the bindings nested in it) before its module expression. *) -let functorKeys : (Typedtree.module_expr * Lexing.position) list ref = ref [] +let functorKeys : (Typedtree.module_expr * definitionKey) list ref = ref [] let setFunctorKey (moduleExpr : Typedtree.module_expr) pos = functorKeys := (moduleExpr, pos) :: !functorKeys -(* Keys are positions, since applications only learn a definition through - its declaration's location (possibly in another file). Two distinct +(* Keys pair positions with compilation contexts, since applications learn a + definition through its declaration in the defining unit. Two distinct definitions a ppx emitted at one position therefore share a key: the calls through either's parameters are credited to the arguments of every application of that key, which is tighter than forwarding to every @@ -634,7 +665,7 @@ let functorsByIdent : (Ident.t * functorHead) list ref = ref [] in the body of [functor (F : FT) -> ...], [module G = (val packed)]), by the position of the binding's name: the resolver of occurrences cannot see through those. *) -let headsByBinding : (Lexing.position, functorHead) Hashtbl.t = +let headsByBinding : (definitionKey, functorHead) Hashtbl.t = Hashtbl.create 4 let rec pathComponents (path : Path.t) = @@ -714,7 +745,7 @@ let processOptionalArgs ~expType ~(locFrom : Location.t) ~locTo ?locToImpl if !Common.Cli.debug then Log_.item "parameterCall %s functor:%s index:%d@." (String.concat "." components) - (functorDef |> posToString) + (functorDef |> keyToString) paramIndex; let calls = match Hashtbl.find_opt parameterCalls key with @@ -733,10 +764,6 @@ let processOptionalArgs ~expType ~(locFrom : Location.t) ~locTo ?locToImpl call |> DeadOptionalArgs.addReferences ~locFrom ~locTo ?locToImpl ~path) -(* Implementation locations of identifier occurrences resolved through - shapes. See [Compat.resolveIdentOccurrences]. *) -let identResolutions = ref Compat.emptyIdentResolutions - (* References whose target may be redirected to a shape-resolved implementation. Decided in [forceDelayedItems], once every declaration is known: if the original target is a declaration (e.g. a [val] in an .mli), it @@ -912,7 +939,7 @@ let rec definitionRange ?(visited = []) ?(resolutions = !identResolutions) (e : Typedtree.module_expr) = let own = if e.mod_loc.loc_ghost then [] - else [(e.mod_loc.loc_start, e.mod_loc.loc_end)] + else [(definitionKey ~resolutions e.mod_loc.loc_start, e.mod_loc.loc_end)] in if List.memq e visited then [] else @@ -944,7 +971,7 @@ let rec definitionRange ?(visited = []) ?(resolutions = !identResolutions) definitionRange ~visited ~resolutions functorExpr #endif | Tmod_unpack (packed, _) -> ( - match unpackedBinding packed with + match unpackedBinding ~resolutions packed with | Some pos -> ( match Hashtbl.find_opt packedModules pos with | Some {packedRange} -> packedRange @@ -959,7 +986,7 @@ and definitionRangeOfPath ?(visited = []) ?(resolutions = !identResolutions) (* A named functor is keyed at its binding name, which precedes the module expression's range. Aliases must retain that key as well. *) let bindingRange = - if loc.loc_ghost then [] else [(loc.loc_start, loc.loc_end)] + if loc.loc_ghost then [] else [(definitionKey ~resolutions loc.loc_start, loc.loc_end)] in bindingRange @ definitionRange ~visited ~resolutions definition | None -> [] @@ -984,15 +1011,15 @@ let packedHeadOfPath resolutions path = ofExpr visited resolutions inner consumed | Tmod_apply (inner, _, _) -> ofExpr visited resolutions inner (consumed + 1) - |> Option.map (fun head -> Partial (e.mod_loc.loc_start, head)) + |> Option.map (fun head -> Partial (definitionKey ~resolutions e.mod_loc.loc_start, head)) #if OCAML_VERSION >= (5, 1, 0) | Tmod_apply_unit inner -> ofExpr visited resolutions inner (consumed + 1) - |> Option.map (fun head -> Partial (e.mod_loc.loc_start, head)) + |> Option.map (fun head -> Partial (definitionKey ~resolutions e.mod_loc.loc_start, head)) #endif | Tmod_ident (path, _) -> ofPath visited resolutions path consumed | Tmod_unpack (packed, _) -> - unpackedBinding packed |> Option.map (fun pos -> Packed (pos, consumed)) + unpackedBinding ~resolutions packed |> Option.map (fun pos -> Packed (pos, consumed)) | _ -> None in ofPath [] resolutions path 0 @@ -1011,9 +1038,9 @@ let partialHeadOfPath resolutions path head = else let visited = e :: visited in match e.mod_desc with - | Tmod_apply _ -> Some e.mod_loc.loc_start + | Tmod_apply _ -> Some (definitionKey ~resolutions e.mod_loc.loc_start) #if OCAML_VERSION >= (5, 1, 0) - | Tmod_apply_unit _ -> Some e.mod_loc.loc_start + | Tmod_apply_unit _ -> Some (definitionKey ~resolutions e.mod_loc.loc_start) #endif | Tmod_constraint (inner, _, _, _) -> ofExpr visited resolutions inner | Tmod_ident (path, _) -> ofPath visited resolutions path @@ -1045,7 +1072,7 @@ let rec functorHeadOf (e : Typedtree.module_expr) : functorHead option = in let applied inner = consume (functorHeadOf inner) - |> Option.map (fun head -> Partial (e.mod_loc.loc_start, head)) + |> Option.map (fun head -> Partial (definitionKey e.mod_loc.loc_start, head)) in match e.mod_desc with | Tmod_apply (functorExpr, _, _) -> applied functorExpr @@ -1057,7 +1084,7 @@ let rec functorHeadOf (e : Typedtree.module_expr) : functorHead option = | Tmod_constraint (inner, _, _, _) -> functorHeadOf inner | Tmod_functor _ -> (* Inline functor: keyed by its own position, see [functorKeys]. *) - Some (Key (e.mod_loc.loc_start, 0)) + Some (Key (definitionKey e.mod_loc.loc_start, 0)) | Tmod_unpack (packed, _) -> ( match unpackedBinding packed with | Some pos -> Some (Packed (pos, 0)) @@ -1082,8 +1109,8 @@ and headOfPath ?lid (path : Path.t) components : functorHead option = let byBinding () = match (lid, components) with | Some (lid : Longident.t Location.loc), [] -> ( - match !identResolutions.moduleDefLoc lid.loc (Path.last path) with - | Some (loc : Location.t) -> Hashtbl.find_opt headsByBinding loc.loc_start + match !identResolutions.moduleDefKey lid.loc (Path.last path) with + | Some key -> Hashtbl.find_opt headsByBinding key | None -> None) | _ -> None in @@ -1110,10 +1137,10 @@ and headOfPath ?lid (path : Path.t) components : functorHead option = | _ -> !identResolutions.headKeyOfPath extended in match key with - | Some ((nameLoc : Location.t), consumed) -> + | Some (key, consumed) -> Some (partialHeadOfPath !identResolutions extended - (Key (nameLoc.loc_start, consumed))) + (Key (key, consumed))) | None -> None in let rec first = function @@ -1139,7 +1166,7 @@ let registerBindingHead ~(namePos : Lexing.position) (id : Ident.t option) | _ -> ( match functorHeadOf moduleExpr with | Some head -> - Hashtbl.replace headsByBinding namePos head; + Hashtbl.replace headsByBinding (definitionKey namePos) head; (match id with | Some id -> functorsByIdent := (id, head) :: !functorsByIdent | None -> ()) @@ -1195,7 +1222,7 @@ let rec escapeUnpackedExports ?(visited = []) in match e.mod_desc with | Tmod_unpack (packed, _) -> ( - match unpackedBinding packed with + match unpackedBinding ~resolutions packed with | Some pos -> escapedHeads := Packed (pos, 0) :: !escapedHeads | None -> ()) | Tmod_constraint (inner, _, _, _) | Tmod_functor (_, inner) -> walk inner @@ -1314,21 +1341,27 @@ let rec collectExpr super self (e : Typedtree.expression) = | Texp_open ({open_expr; open_bound_items}, _) -> registerUnpackedExports open_bound_items open_expr | Texp_letmodule (id, name, _, moduleExpr, _) -> - setFunctorKey moduleExpr name.loc.loc_start; + setFunctorKey moduleExpr (definitionKey name.loc.loc_start); registerParameterAlias id moduleExpr; (match id with + | Some exportId -> + unpackedExportCandidates := + {exportId; exportOrigin = moduleExpr; + exportResolutions = !identResolutions; + exportScope = !unpackedExportCandidates} :: !unpackedExportCandidates + | None -> ()); + (match id with | Some id -> (* [let module G = F in] or [let module G = F (A) in]: G stands for F's key, with the arguments already consumed. *) let key = match (unwrapConstraints moduleExpr).mod_desc with - | Tmod_functor _ -> Key (name.loc.loc_start, 0) - | _ -> ( - match functorHeadOf moduleExpr with - | Some key -> key - | None -> Key (name.loc.loc_start, 0)) + | Tmod_functor _ -> Some (Key (definitionKey name.loc.loc_start, 0)) + | _ -> functorHeadOf moduleExpr in - functorsByIdent := (id, key) :: !functorsByIdent + (match key with + | Some key -> functorsByIdent := (id, key) :: !functorsByIdent + | None -> ()) | None -> ()) | _ -> ()); #endif @@ -1340,9 +1373,10 @@ let rec collectExpr super self (e : Typedtree.expression) = match functorHeadOf moduleExpr with | Some head -> escapedHeads := head :: !escapedHeads | None -> ()) - | Texp_ident (_, _, {val_loc}) + | Texp_ident (_, _, vd) when not (PosSet.mem e.exp_loc.loc_start !unpackOperands) -> - usedOutsideUnpack := PosSet.add val_loc.loc_start !usedOutsideUnpack + usedOutsideUnpack := + DefinitionSet.add (!identResolutions.valueKey vd) !usedOutsideUnpack | _ -> ()); (match e.exp_desc with | Texp_ident (_path, _, {Types.val_loc = {loc_ghost = false; _} as locTo}) @@ -1880,7 +1914,7 @@ let registerPackedModule (vb : Typedtree.value_binding) = let moduleType = expandModuleType moduleExpr.mod_type in match getSignature moduleType with [] -> None | _ -> Some moduleType) in - Hashtbl.replace packedModules loc.loc_start + Hashtbl.replace packedModules (definitionKey loc.loc_start) { packedHead = functorHeadOf moduleExpr; packedShape = moduleShapeOfExpr moduleExpr; @@ -1969,6 +2003,98 @@ let argumentItemResolver (argumentExpr : Typedtree.module_expr) = by node identity (a ppx may emit distinct applications at one position). *) let recordedApplications : Typedtree.module_expr list ref = ref [] +(* A holder argument need not have a path: [Apply (struct module F ... end)]. + Capture its lexical member resolvers now, before the traversal leaves the + enclosing parameter scope. Includes and aliases retain that same scope. *) +let argumentHeadResolver argumentExpr = + let resolutions = !identResolutions in + let rec ofExpr env ?namePos (e : Typedtree.module_expr) = + match e.mod_desc with + | Tmod_constraint (inner, _, _, _) -> ofExpr env ?namePos inner + | Tmod_structure {str_items} -> ( + let _, members = + List.fold_left + (fun (env, members) (item : Typedtree.structure_item) -> + let bind (env, members) (mb : Typedtree.module_binding) = + let resolve = + ofExpr env ~namePos:mb.mb_name.loc.loc_start mb.mb_expr + in + let env = + match mb.mb_id with + | Some id -> (id, resolve) :: env + | None -> env + in + let members = + match mb.mb_name.txt with + | Some name -> (name, resolve) :: members + | None -> members + in + (env, members) + in + match item.str_desc with + | Tstr_module mb -> bind (env, members) mb + | Tstr_recmodule mbs -> List.fold_left bind (env, members) mbs + | Tstr_include {incl_mod; incl_type} -> + let resolve = ofExpr env incl_mod in + List.fold_left + (fun (env, members) item -> + match Compat.getSigModuleModtype item with + | Some (id, _, _) -> + let name = Ident.name id in + let member rest = resolve (name :: rest) in + ((id, member) :: env, (name, member) :: members) + | None -> (env, members)) + (env, members) incl_type + | _ -> (env, members)) + (env, []) str_items + in + function + | name :: rest -> + Option.bind (List.assoc_opt name members) (fun f -> f rest) + | [] -> None) + | Tmod_ident (path, _) -> ( + let direct = functorHeadOf e in + let parameter = findFunctorParameter path in + let rec local path components = + match path with + | Path.Pident id -> + List.find_opt (fun (other, _) -> Ident.same id other) env + |> Option.map (fun (_, resolve) -> (resolve, components)) + | Path.Pdot (parent, name) -> local parent (name :: components) + | _ -> None + in + let local = local path [] in + fun components -> + match (local, parameter, pathComponents path) with + | Some (resolve, prefix), _, _ -> resolve (prefix @ components) + | _, Some p, Some prefix -> + Some + (ParamHead + (p.functorDef, p.paramIndex, p.prefix @ prefix @ components, 0)) + | _ -> ( + let extended = + List.fold_left (fun p name -> Path.Pdot (p, name)) path components + in + if components = [] && direct <> None then direct + else + match packedHeadOfPath resolutions extended with + | Some head -> Some head + | None -> + resolutions.headKeyOfPath extended + |> Option.map (fun (key, consumed) -> + partialHeadOfPath resolutions extended (Key (key, consumed)))) + ) + | Tmod_functor _ -> ( + let pos = Option.value namePos ~default:e.mod_loc.loc_start in + function + | [] -> Some (Key (definitionKey ~resolutions pos, 0)) + | _ -> None) + | _ -> ( + let direct = functorHeadOf e in + function [] -> direct | _ -> None) + in + ofExpr [] argumentExpr + (* [F (A) (B)] is [Tmod_apply (Tmod_apply (F, A), B)]: collect the functor and the arguments in order, and defer crediting the calls made through each parameter to the corresponding argument. *) @@ -2001,47 +2127,6 @@ let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = | Some head -> functorHeadToString head | None -> "none") (List.length args); - (* The functor (a submodule of) an argument denotes, for higher-order - parameters. Computed now: the resolver and the parameters in scope - are those of this file and this point of the traversal. *) - let argHead (argumentExpr : Typedtree.module_expr) = - let direct = functorHeadOf argumentExpr in - let resolutions = !identResolutions in - let ident = moduleIdent argumentExpr in - let parameter = - match ident with - | Some (path, _) -> ( - match (findFunctorParameter path, pathComponents path) with - | Some p, Some pathComponents -> Some (p, pathComponents) - | _ -> None) - | None -> None - in - fun components -> - match (components, parameter, ident) with - | [], _, _ -> direct - | _, Some (p, pathComponents), _ -> - Some - (ParamHead - ( p.functorDef, - p.paramIndex, - p.prefix @ pathComponents @ components, - 0 )) - | _, None, Some (path, _) -> ( - let extended = - components - |> List.fold_left (fun p name -> Path.Pdot (p, name)) path - in - match packedHeadOfPath resolutions extended with - | Some head -> Some head - | None -> ( - match resolutions.headKeyOfPath extended with - | Some ((loc : Location.t), consumed) -> - Some - (partialHeadOfPath resolutions extended - (Key (loc.loc_start, consumed))) - | None -> None)) - | _, None, None -> None - in match head with | None -> (* The functors passed to an application whose head cannot be chased @@ -2080,7 +2165,7 @@ let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = Hashtbl.replace applicationHeads applicationId head; !chain |> List.iter (fun (e : Typedtree.module_expr) -> - let pos = e.mod_loc.loc_start in + let pos = definitionKey e.mod_loc.loc_start in let ids = Option.value (Hashtbl.find_opt applicationIdsByPosition pos) ~default:[] @@ -2098,7 +2183,7 @@ let recordFunctorApplication (moduleExpr : Typedtree.module_expr) = appliedFunctor = head; argIndex = i; resolver = argumentItemResolver argumentExpr; - argHead = argHead argumentExpr; + argHead = argumentHeadResolver argumentExpr; argRange = definitionRange argumentExpr; } :: !delayedApplications @@ -2121,7 +2206,7 @@ let traverseStructure ~doTypes ~doExternals = let functorDef = match findFunctorKey moduleExpr with | Some pos -> pos - | None -> moduleExpr.mod_loc.loc_start + | None -> definitionKey moduleExpr.mod_loc.loc_start in setFunctorKey body functorDef; let paramIndex = @@ -2222,7 +2307,7 @@ let traverseStructure ~doTypes ~doExternals = let oldModulePath = ModulePath.getCurrent () in (match structureItem.str_desc with | Tstr_module {mb_expr; mb_id; mb_loc; mb_name} -> ( - setFunctorKey mb_expr mb_name.loc.loc_start; + setFunctorKey mb_expr (definitionKey mb_name.loc.loc_start); registerParameterAlias mb_id mb_expr; registerBindingHead ~namePos:mb_name.loc.loc_start mb_id mb_expr; let hasInterface = @@ -2249,13 +2334,13 @@ let traverseStructure ~doTypes ~doExternals = | Tstr_recmodule moduleBindings -> moduleBindings |> List.iter (fun (mb : Typedtree.module_binding) -> - setFunctorKey mb.mb_expr mb.mb_name.loc.loc_start; + setFunctorKey mb.mb_expr (definitionKey mb.mb_name.loc.loc_start); registerParameterAlias mb.mb_id mb.mb_expr; - match mb.mb_id with - | Some id -> + match (mb.mb_id, (unwrapConstraints mb.mb_expr).mod_desc) with + | Some id, Tmod_functor _ -> functorsByIdent := - (id, Key (mb.mb_name.loc.loc_start, 0)) :: !functorsByIdent - | None -> ()); + (id, Key (definitionKey mb.mb_name.loc.loc_start, 0)) :: !functorsByIdent + | _ -> ()); (* [module rec G : T = H and H : T = F]: an alias or partial application stands for the functor's key; a forward alias resolves once the later binding has, so iterate to a fixed point. *) @@ -2265,7 +2350,7 @@ let traverseStructure ~doTypes ~doExternals = (fun changed (mb : Typedtree.module_binding) -> match (mb.mb_id, (unwrapConstraints mb.mb_expr).mod_desc) with | ( Some id, - ( Tmod_apply _ | Tmod_ident _ + ( Tmod_apply _ | Tmod_ident _ | Tmod_unpack _ #if OCAML_VERSION >= (5, 1, 0) | Tmod_apply_unit _ #endif @@ -2408,7 +2493,6 @@ let processValueDependency through shapes already point at the implementation and are not in this set; this is the conservative fallback for the rest, and keeps every implementation of the item live. *) - DeadOptionalArgs.forwardDelayedItems ~posFrom ~posTo; ValueReferences.find posFrom |> PosSet.iter (fun posRef -> if @@ -2433,6 +2517,55 @@ let processValueDependency (* Value dependencies are processed once all files have been scanned, so that declarations and references from every file are known. *) let delayedValueDependencies = ref [] +let packedValueDependencies = ref [] + +let processValueDependencies dependencies = + let targets = PosHash.create 64 in + let locations = PosHash.create 64 in + let declarationEdges = ref [] in + dependencies + |> List.iter (fun ((locTo : Location.t), (locFrom : Location.t)) -> + if + (not (locTo.loc_ghost || locFrom.loc_ghost)) + && locTo.loc_start <> locFrom.loc_start + then ( + if + PosHash.mem decls locFrom.loc_start + && not + (PosSet.mem locTo.loc_start + (PosHash.findSet targets locFrom.loc_start)) + then declarationEdges := (locTo, locFrom) :: !declarationEdges; + PosHash.addSet targets locFrom.loc_start locTo.loc_start; + PosHash.replace locations locFrom.loc_start locFrom; + PosHash.replace locations locTo.loc_start locTo)); + let pending = Queue.create () in + let queued = ref PosSet.empty in + let enqueue pos = + if not (PosHash.mem decls pos || PosSet.mem pos !queued) then ( + queued := PosSet.add pos !queued; + Queue.add pos pending) + in + let forward posFrom posTo = + processValueDependency + (PosHash.find locations posTo, PosHash.find locations posFrom) + in + (* Declaration edges add real references exactly once. Signature-only + nodes then forward to a fixed point, regardless of dependency order. *) + (* Preserve the compiler's declaration-edge order for ordinary function + references; only signature forwarding needs the work queue. *) + List.rev !declarationEdges |> List.iter processValueDependency; + PosHash.iter (fun posFrom _ -> enqueue posFrom) targets; + while not (Queue.is_empty pending) do + let posFrom = Queue.take pending in + queued := PosSet.remove posFrom !queued; + PosHash.findSet targets posFrom + |> PosSet.iter (fun posTo -> + let before = ValueReferences.find posTo in + forward posFrom posTo; + if not (PosSet.equal before (ValueReferences.find posTo)) then + enqueue posTo) + done; + DeadOptionalArgs.forwardDelayedItems targets let forceDelayedItems () = let redirects = List.rev !delayedRedirects in @@ -2455,10 +2588,11 @@ let forceDelayedItems () = (* Interface items stand for their implementations (value dependencies pair an implementation with the item it satisfies). *) let sigToImpl = Hashtbl.create 16 in - !delayedValueDependencies - |> List.iter (fun ((locTo : Location.t), (locFrom : Location.t)) -> + !packedValueDependencies + |> List.iter (fun (context, ((locTo : Location.t), (locFrom : Location.t))) -> if not (locTo.loc_ghost || locFrom.loc_ghost) then - Hashtbl.replace sigToImpl locFrom.loc_start locTo.loc_start); + Hashtbl.replace sigToImpl (locFrom.loc_start, context) (locTo.loc_start, context)); + packedValueDependencies := []; resolveParameterHeadedApplications ~sigToImpl; escapePackedModulesUsedElsewhere ~sigToImpl; let keys, ranges = escapedKeysAndRanges ~sigToImpl in @@ -2467,7 +2601,7 @@ let forceDelayedItems () = (fun (def, index, components) calls -> let calls = List.rev calls in if !Common.Cli.debug then - Log_.item "parameterCalls %s index:%d %s: %s@." (def |> posToString) + Log_.item "parameterCalls %s index:%d %s: %s@." (def |> keyToString) index (String.concat "." components) (if isEscaped def then "escaped" @@ -2537,7 +2671,7 @@ let forceDelayedItems () = DeadOptionalArgs.settleDelayedItems (); let dependencies = List.rev !delayedValueDependencies in delayedValueDependencies := []; - dependencies |> List.iter processValueDependency + processValueDependencies dependencies let processStructure ~cmt_value_dependencies ~cmt_ident_resolutions ~doTypes ~doExternals (structure : Typedtree.structure) = @@ -2553,5 +2687,9 @@ let processStructure ~cmt_value_dependencies ~cmt_ident_resolutions ~doTypes functorKeys := []; identResolutions := Compat.emptyIdentResolutions; let valueDependencies = cmt_value_dependencies |> List.rev in + packedValueDependencies := + List.rev_append + (List.map (fun dep -> (cmt_ident_resolutions.Compat.context, dep)) valueDependencies) + !packedValueDependencies; delayedValueDependencies := List.rev_append valueDependencies !delayedValueDependencies diff --git a/src/Reanalyze.ml b/src/Reanalyze.ml index 07e47025..0a7d5daa 100644 --- a/src/Reanalyze.ml +++ b/src/Reanalyze.ml @@ -12,14 +12,8 @@ let loadCmtFile ~cmtRoot cmtFilePath = those contexts, but not the byte/native distinction: [cmt_imports] records the reused self-interface in both artifacts, whereas [cmt_interface_digest] can be absent from the native artifact. *) - let imports = List.sort_uniq compare cmt_infos.cmt_imports in let unitKey = - ( cmt_infos.cmt_modname, - cmt_infos.cmt_sourcefile, - cmt_infos.cmt_builddir, - cmt_infos.cmt_source_digest, - imports, - Filename.check_suffix cmtFilePath ".cmti" ) + (Compat.compilationContext cmt_infos, Filename.check_suffix cmtFilePath ".cmti") in if Hashtbl.mem scannedUnits unitKey then () else From 856bdabf6dd91449c1a3616be89af60217c60625 Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 17 Sep 2026 17:26:20 +0000 Subject: [PATCH 52/53] Preserve scoped argument lookups and dependency implementation identity --- .../compilation_context/Nested_alias.ml | 10 + .../compilation_context/Provider.mli | 7 + .../regression/compilation_context/Relay.ml | 1 + .../compilation_context/Safe_alias.ml | 6 + .../regression/compilation_context/a/Use_a.ml | 7 + .../regression/compilation_context/b/Use_b.ml | 7 + examples/regression/src/Main.ml | 1 + examples/regression/src/Nested_arguments.ml | 74 +++++++ .../regression/src/Nested_arguments_packed.ml | 23 ++ examples/regression/src/dune | 2 + scripts/run_integration_tests.js | 41 +++- src/Compat.ml | 202 +++++++++++++++--- src/DeadValue.ml | 186 ++++++++++++---- src/Reanalyze.ml | 9 +- 14 files changed, 497 insertions(+), 79 deletions(-) create mode 100644 examples/regression/compilation_context/Nested_alias.ml create mode 100644 examples/regression/compilation_context/Provider.mli create mode 100644 examples/regression/compilation_context/Relay.ml create mode 100644 examples/regression/compilation_context/Safe_alias.ml create mode 100644 examples/regression/src/Nested_arguments.ml create mode 100644 examples/regression/src/Nested_arguments_packed.ml diff --git a/examples/regression/compilation_context/Nested_alias.ml b/examples/regression/compilation_context/Nested_alias.ml new file mode 100644 index 00000000..56aa7dd9 --- /dev/null +++ b/examples/regression/compilation_context/Nested_alias.ml @@ -0,0 +1,10 @@ +module type S = sig + module N : sig + val f : unit -> int + end +end + +module rec A : S = B +and B : S = A + +module C = A.N diff --git a/examples/regression/compilation_context/Provider.mli b/examples/regression/compilation_context/Provider.mli new file mode 100644 index 00000000..18b630c4 --- /dev/null +++ b/examples/regression/compilation_context/Provider.mli @@ -0,0 +1,7 @@ +module type S = sig + val g : ?context:int -> unit -> int +end + +module Op (M : S) : sig + val run : unit -> int +end diff --git a/examples/regression/compilation_context/Relay.ml b/examples/regression/compilation_context/Relay.ml new file mode 100644 index 00000000..2b8221b3 --- /dev/null +++ b/examples/regression/compilation_context/Relay.ml @@ -0,0 +1 @@ +module Apply (M : Shared.S) = Shared.Apply (M) diff --git a/examples/regression/compilation_context/Safe_alias.ml b/examples/regression/compilation_context/Safe_alias.ml new file mode 100644 index 00000000..6fd99ab3 --- /dev/null +++ b/examples/regression/compilation_context/Safe_alias.ml @@ -0,0 +1,6 @@ +module type S = sig + val f : unit -> int +end + +module rec A : S = B +and B : S = A diff --git a/examples/regression/compilation_context/a/Use_a.ml b/examples/regression/compilation_context/a/Use_a.ml index 4c631f27..09d04906 100644 --- a/examples/regression/compilation_context/a/Use_a.ml +++ b/examples/regression/compilation_context/a/Use_a.ml @@ -4,6 +4,13 @@ end module Applied = Shared.Apply (Arg) +module Relayed_arg : Shared.S = struct + let g ?(context = 0) () = context +end + +module Relayed = Relay.Apply (Relayed_arg) + +let () = ignore (Relayed.run ()) let () = ignore (Applied.run ()) module Partial_arg : Shared.S = struct diff --git a/examples/regression/compilation_context/b/Use_b.ml b/examples/regression/compilation_context/b/Use_b.ml index 4c631f27..09d04906 100644 --- a/examples/regression/compilation_context/b/Use_b.ml +++ b/examples/regression/compilation_context/b/Use_b.ml @@ -4,6 +4,13 @@ end module Applied = Shared.Apply (Arg) +module Relayed_arg : Shared.S = struct + let g ?(context = 0) () = context +end + +module Relayed = Relay.Apply (Relayed_arg) + +let () = ignore (Relayed.run ()) let () = ignore (Applied.run ()) module Partial_arg : Shared.S = struct diff --git a/examples/regression/src/Main.ml b/examples/regression/src/Main.ml index 5064ef53..475f3ab9 100644 --- a/examples/regression/src/Main.ml +++ b/examples/regression/src/Main.ml @@ -2,6 +2,7 @@ let definitely_dead () = () let () = Review_round.run (); + Nested_arguments.run (); Attribution_sweep.run (); Escaped_coercion.run (); Partial_context_use.run (); diff --git a/examples/regression/src/Nested_arguments.ml b/examples/regression/src/Nested_arguments.ml new file mode 100644 index 00000000..247787de --- /dev/null +++ b/examples/regression/src/Nested_arguments.ml @@ -0,0 +1,74 @@ +module type N = sig + val g : ?nested_arg:int -> unit -> int +end + +module type S = sig + module N : N +end + +module F (M : S) = struct + let run () = M.N.g ~nested_arg:1 () +end + +module Known : S = struct + module N = struct + let g ?(nested_arg = 0) () = nested_arg + end +end + +module A = F (Known) + +module B = F (struct + module N : N = struct + let g ?(nested_arg = 0) () = nested_arg + end +end) + +module C = F (struct + module Actual : N = struct + let g ?(nested_arg = 0) () = nested_arg + end + + module N = Actual +end) + +module D = F (struct + include struct + module N : N = struct + let g ?(nested_arg = 0) () = nested_arg + end + end +end) + +module Packed_arg = struct + module N : N = struct + let g ?(nested_arg = 0) () = nested_arg + end +end + +let packed = (module Packed_arg : S) + +module E = F ((val packed : S)) + +module Unrelated : S = struct + module N = struct + let g ?(nested_arg = 0) () = nested_arg + end +end + +module Foreign (M : Nested_arguments_packed.S) = struct + let run () = M.N.g ~foreign_nested:1 () +end + +module Imported = + Foreign ((val Nested_arguments_packed.packed : Nested_arguments_packed.S)) + +let run () = + ignore (Imported.run ()); + Nested_arguments_packed.run (); + ignore (A.run ()); + ignore (B.run ()); + ignore (C.run ()); + ignore (D.run ()); + ignore (E.run ()); + ignore (Unrelated.N.g ()) diff --git a/examples/regression/src/Nested_arguments_packed.ml b/examples/regression/src/Nested_arguments_packed.ml new file mode 100644 index 00000000..6c9ac58f --- /dev/null +++ b/examples/regression/src/Nested_arguments_packed.ml @@ -0,0 +1,23 @@ +module type N = sig + val g : ?foreign_nested:int -> unit -> int +end + +module type S = sig + module N : N +end + +module Actual : S = struct + module N : N = struct + let g ?(foreign_nested = 0) () = foreign_nested + end +end + +let packed = (module Actual : S) + +module Unrelated : S = struct + module N = struct + let g ?(foreign_nested = 0) () = foreign_nested + end +end + +let run () = ignore (Unrelated.N.g ()) diff --git a/examples/regression/src/dune b/examples/regression/src/dune index b1ee6da1..84b0488d 100644 --- a/examples/regression/src/dune +++ b/examples/regression/src/dune @@ -18,6 +18,8 @@ Local_side_effects Main Nested_module_type + Nested_arguments + Nested_arguments_packed Ocaml_compiler_compat Packed_interface Packed_interface_use diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index 7178885b..8c9dd32d 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -687,6 +687,12 @@ function runRegressionTests() { assertIncludes(output, "optional argument result of function Partial_result.F.+run is always supplied (2 calls)"); assertIncludes(output, "optional argument local_alias of function Local_alias.Arg.+g is always supplied (1 calls)"); assertIncludes(output, "optional argument recursive_alias of function Recursive_alias.Arg.+g is always supplied (1 calls)"); + for (const name of ["Known.N", "B.N", "C.Actual", "D.N", "Packed_arg.N"]) { + assertIncludes(output, `optional argument nested_arg of function ${name}.+g is always supplied (1 calls)`); + } + assertIncludes(output, "optional argument nested_arg of function Unrelated.N.+g is never used"); + assertIncludes(output, "optional argument foreign_nested of function Actual.N.+g is always supplied (1 calls)"); + assertIncludes(output, "optional argument foreign_nested of function Unrelated.N.+g is never used"); } assertNotIncludes(output, "Parent is a dead module"); @@ -875,7 +881,7 @@ function runDuplicateContextTest() { } } -function runCompilationContextTests() { +function runCompilationContextTests(sharedInterface = false) { if (!ocamlVersionAtLeast(5, 3)) return; const fs = require("fs"); const cwd = fs.mkdtempSync(path.join(require("os").tmpdir(), "reanalyze-typing-context-")); @@ -886,20 +892,29 @@ function runCompilationContextTests() { ); const run = (root, debug = false) => child_process.execFileSync( reanalyzeFile, ["-ci", ...(debug ? ["-debug"] : []), "-dce-cmt", root], - { cwd, encoding: "utf8" } + { cwd, encoding: "utf8", timeout: 10000 } ); try { for (const dir of ["a", "b", "native_layout/byte", "native_layout/native"]) { fs.mkdirSync(path.join(cwd, dir), { recursive: true }); } copy("Shared.ml"); + copy("Relay.ml"); + const apiArgs = sharedInterface ? ["-I", "api"] : []; + if (sharedInterface) { + fs.mkdirSync(path.join(cwd, "api")); + copy("Provider.mli"); + compile(["-c", "-o", "api/Provider.cmi", "Provider.mli"]); + } for (const dir of ["a", "b"]) { for (const file of ["Provider.ml", `Use_${dir}.ml`]) copy(`${dir}/${file}`); - compile(["-c", `${dir}/Provider.ml`]); - compile(["-I", dir, "-c", "-o", `${dir}/Shared.cmo`, "Shared.ml"]); - compile(["-I", dir, "-c", `${dir}/Use_${dir}.ml`]); + compile([...(sharedInterface ? ["-intf-suffix", ".ml", ...apiArgs] : []), "-c", `${dir}/Provider.ml`]); + for (const name of ["Shared", "Relay"]) { + compile(["-I", dir, ...apiArgs, "-c", "-o", `${dir}/${name}.cmo`, `${name}.ml`]); + } + compile(["-I", dir, ...apiArgs, "-c", `${dir}/Use_${dir}.ml`]); } - console.log(`${cwd}: reanalyze functor identity in separate compilation contexts`); + console.log(`${cwd}: reanalyze functor identity with ${sharedInterface ? "shared" : "distinct"} dependency interfaces`); const supplied = "optional argument context of function Arg.+g is always supplied (1 calls)"; const omitted = "optional argument context of function Arg.+g is never used"; assertIncludes(run("a"), supplied); @@ -907,7 +922,7 @@ function runCompilationContextTests() { const assertContexts = (output) => { assertIncludes(output, supplied); assertIncludes(output, omitted); - for (const name of ["Partial_arg", "Packed_arg"]) { + for (const name of ["Partial_arg", "Packed_arg", "Relayed_arg"]) { assertIncludes(output, `optional argument context of function ${name}.+g is always supplied (1 calls)`); assertIncludes(output, `optional argument context of function ${name}.+g is never used`); } @@ -958,6 +973,13 @@ function runCompilationContextTests() { for (const root of ["native_layout/native", "native_layout"]) { if (run(root) !== byte) throw new Error(`Cross-unit attribution changed for ${root}`); } + for (const name of ["Safe_alias", "Nested_alias"]) { + copy(`${name}.ml`); + compile(["-o", `${name}.exe`, `${name}.ml`]); + child_process.execFileSync(path.join(cwd, `${name}.exe`), [], { cwd, timeout: 10000 }); + console.log(`${cwd}: bounded analysis of ${name}`); + assertIncludes(run(`${name}.cmt`), "Analysis reported 0 issues"); + } } finally { fs.rmSync(cwd, { recursive: true, force: true }); } @@ -1095,6 +1117,11 @@ function main() { runByteNativeDuplicateTest(); runDuplicateContextTest(); runCompilationContextTests(); + runCompilationContextTests(true); + runFunctorScanOrderTest("Nested_arguments_packed", "Nested_arguments", [ + "optional argument foreign_nested of function Actual.N.+g is always supplied (1 calls)", + "optional argument foreign_nested of function Unrelated.N.+g is never used", + ]); runFunctorScanOrderTest("Unpacked_functor", "Unpacked_functor_use", [ "optional argument x of function Unpacked_arg.+g is always supplied (1 calls)", "optional argument x of function Unpacked_unused.+g is never used", diff --git a/src/Compat.ml b/src/Compat.ml index b0396399..654b0d05 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -33,7 +33,7 @@ let interfaceDigest (infos : Cmt_format.cmt_infos) = compilation: byte/native and install copies must share it. Imports identify the resolved interfaces, but not ordered implicit opens or preprocessing. Retain those source/typing options in command-line order. *) -let compilationContext (infos : Cmt_format.cmt_infos) = +let sourceContext (infos : Cmt_format.cmt_infos) = let rec typingArgs = function | (("-open" | "-pp" | "-ppx" | "-for-pack" | "-keywords") as flag) :: value :: rest -> @@ -359,6 +359,8 @@ let applyArgOfExpression e = module type defined in another file) can be resolved regardless of processing order. *) let cmtFilesByUnit : (string, string list) Hashtbl.t = Hashtbl.create 256 +let compilationContexts : (string, string) Hashtbl.t = Hashtbl.create 256 +let compilationContextsReady = ref false let unitNameOfCmtFile path = path |> Filename.basename |> Filename.remove_extension @@ -371,8 +373,10 @@ let registerCmtFile path = | Some paths -> paths | None -> [] in - if not (List.mem path existing) then - Hashtbl.replace cmtFilesByUnit unit (path :: existing) + if not (List.mem path existing) then ( + Hashtbl.replace cmtFilesByUnit unit (path :: existing); + Hashtbl.reset compilationContexts; + compilationContextsReady := false) #if OCAML_VERSION >= (5, 3, 0) (* Per compilation unit: the implementation shape and structure (from the @@ -431,6 +435,137 @@ let candidateFilesForUnit ~currentCmtFile comp_unit = in (indexed @ siblings) |> List.filter Sys.file_exists |> List.sort_uniq compare +(* Source/typing identity is only the initial partition. Identical clients + may link different implementations of the same interface. Refine that + partition by their resolved dependency contexts, transitively. This also + handles dependency cycles without recursive fingerprints or directory IDs: + actual byte/native/install copies keep the same class. *) +let compilationContext ~cmtFilePath infos = + if not !compilationContextsReady then ( + let metadata = Hashtbl.create 256 in + let read path = + match Hashtbl.find_opt metadata path with + | Some entry -> entry + | None -> + let entry = + try + let info = Cmt_format.read_cmt path in + Some + ( sourceContext info, + info.cmt_modname, + info.cmt_imports, + interfaceDigest info ) + with _ -> None + in + Hashtbl.add metadata path entry; + entry + in + let graph = Hashtbl.create 256 in + let rec collect path = + if not (Hashtbl.mem graph path) then + match read path with + | None -> () + | Some (source, unitName, imports, _) -> + Hashtbl.add graph path (source, []); + let dependencies = + imports + |> List.filter_map (fun (name, digest) -> + if name = unitName then None + else + let candidates = + candidateFilesForUnit ~currentCmtFile:path name + in + let interfaceDigest path = + match read path with + | Some (_, _, _, digest) -> digest + | None -> None + in + let candidates = + selectUnitFilesByDigest ~interfaceDigest + ~allowUnmatched:false digest candidates + in + let candidates = + match + List.filter + (fun candidate -> + Filename.dirname candidate = Filename.dirname path) + candidates + with + | [] -> candidates + | siblings -> siblings + in + (* An implementation supplies shapes; a sibling interface + does not create a second implementation context. *) + let candidates = + match + List.filter + (fun p -> Filename.check_suffix p ".cmt") + candidates + with + | [] -> candidates + | implementations -> implementations + in + let candidates = + List.filter (fun p -> read p <> None) candidates + in + List.iter collect candidates; + Some (name, candidates)) + in + Hashtbl.replace graph path (source, dependencies) + in + Hashtbl.iter (fun _ files -> List.iter collect files) cmtFilesByUnit; + collect cmtFilePath; + let nodes = + Hashtbl.fold (fun path node acc -> (path, node) :: acc) graph [] + in + let partition signatures = + let classes = Hashtbl.create 256 in + signatures |> List.map snd |> List.sort_uniq compare + |> List.iteri (fun index signature -> Hashtbl.add classes signature index); + let colors = Hashtbl.create 256 in + List.iter + (fun (path, signature) -> + Hashtbl.add colors path (Hashtbl.find classes signature)) + signatures; + (colors, Hashtbl.length classes) + in + let initial, count = + partition (List.map (fun (path, (source, _)) -> (path, source)) nodes) + in + let rec refine colors count = + let next, nextCount = + partition + (List.map + (fun (path, (_, dependencies)) -> + let dependencies = + List.map + (fun (name, paths) -> + ( name, + List.map (Hashtbl.find colors) paths + |> List.sort_uniq compare )) + dependencies + |> List.sort_uniq compare + in + (path, (Hashtbl.find colors path, dependencies))) + nodes) + in + (* Refinement cannot merge classes, so an unchanged count is stable. *) + if nextCount = count then next else refine next nextCount + in + let colors = refine initial count in + Hashtbl.iter + (fun path color -> + Hashtbl.replace compilationContexts path + ("context:" ^ string_of_int color)) + colors; + compilationContextsReady := true); + match Hashtbl.find_opt compilationContexts cmtFilePath with + | Some context -> context + | None -> + (* A resolver reached an unindexed artifact outside the import graph. + Its equivalence is unproved: keep it separate rather than merging. *) + sourceContext infos ^ ":unindexed:" ^ cmtFilePath + (* [imports] are the consumer's recorded imports: when the same unit name exists in several build directories, the candidate whose interface digest matches the one the consumer was compiled against is the actual @@ -486,9 +621,9 @@ let loadUnitInfo ~currentCmtFile ~(imports : Misc.crcs) comp_unit = let loaded = let seen = Hashtbl.create 4 in loaded - |> List.filter (fun (_, (cmt_infos : Cmt_format.cmt_infos)) -> + |> List.filter (fun (path, (cmt_infos : Cmt_format.cmt_infos)) -> let key = - (compilationContext cmt_infos, cmt_infos.cmt_impl_shape <> None) + (compilationContext ~cmtFilePath:path cmt_infos, cmt_infos.cmt_impl_shape <> None) in if Hashtbl.mem seen key then false else ( @@ -527,7 +662,7 @@ let loadUnitInfo ~currentCmtFile ~(imports : Misc.crcs) comp_unit = | _ -> None in (path, cmt_infos.cmt_imports, cmt_infos.cmt_ident_occurrences, structure, - compilationContext cmt_infos) + compilationContext ~cmtFilePath:path cmt_infos) | None, [] -> ("", [], [], None, "") in let info = @@ -714,25 +849,25 @@ type moduleShape = unit #endif -(* Bindings already chased when resolving a functor head, to break cycles. *) +type definitionKey = Lexing.position * string + +(* Both occurrence and structural lookup must remember visited bindings. *) type headVisited = #if OCAML_VERSION >= (5, 3, 0) - Shape.Uid.t list + Shape.Uid.t list * definitionKey list #else unit #endif let noHeadVisited : headVisited = #if OCAML_VERSION >= (5, 3, 0) - [] + ([], []) #else () #endif (* Source positions remain diagnostic locations, but are not identities when the same source is compiled in different dependency/typing contexts. *) -type definitionKey = Lexing.position * string - type identResolutions = { context : string; valueKey : Types.value_description -> definitionKey; @@ -1013,7 +1148,16 @@ let rec makeResolver ~cmtFilePath ~context local bindings, and the bodies of applied functors, as in [Outer (A).Inner]. Returns the binding, the resolver of its unit, and the number of functor layers the path applied. *) - let rec bindingOfPath (path : Path.t) : + let activeBindingPaths = ref [] in + let rec bindingOfPath path = + if List.exists (Path.same path) !activeBindingPaths then None + else + let previous = !activeBindingPaths in + activeBindingPaths := path :: previous; + Fun.protect + ~finally:(fun () -> activeBindingPaths := previous) + (fun () -> bindingOfPathUnchecked path) + and bindingOfPathUnchecked (path : Path.t) : (Location.t * Typedtree.module_expr * identResolutions option * int) option = let byShape = @@ -1230,10 +1374,16 @@ let rec makeResolver ~cmtFilePath ~context (* The key of a binding found for a module expression: a functor is keyed by the binding; an alias or a partial application is chased with the resolver of the unit binding it. *) - let keyOfBinding visited (loc : Location.t) + let keyOfBinding (uids, bindings) (loc : Location.t) (definition : Typedtree.module_expr) resolver = - if loc.loc_ghost then None + let context = match resolver with + | Some (resolver : identResolutions) -> resolver.context + | None -> context + in + let key = (loc.loc_start, context) in + if loc.loc_ghost || List.mem key bindings then None else + let visited = (uids, key :: bindings) in match (unwrap definition).mod_desc with | Tmod_apply _ | Tmod_apply_unit _ | Tmod_ident _ -> ( (* An unresolved alias is not a new functor definition. Giving @@ -1246,18 +1396,13 @@ let rec makeResolver ~cmtFilePath ~context (* A first-class module: the functor it holds is not known here. *) None - | _ -> - let context = match resolver with - | Some resolver -> resolver.context - | None -> context - in - Some ((loc.loc_start, context), 0) + | _ -> Some (key, 0) in headKeyOfPathRef := (fun path -> match bindingOfPath path with | Some (loc, definition, resolver, applied) -> ( - match keyOfBinding [] loc definition resolver with + match keyOfBinding noHeadVisited loc definition resolver with | Some (loc, consumed) -> Some (loc, consumed + applied) | None -> None) | None -> None); @@ -1277,17 +1422,18 @@ let rec makeResolver ~cmtFilePath ~context match Hashtbl.find_opt moduleUids (key lid.loc name) with | Some uid -> ( match Lazy.force uid with - | Some uid when not (List.mem uid visited) -> ( + | Some uid when List.mem uid (fst visited) -> Some None + | Some uid -> ( match bindingOfUid uid with | Some (loc, definition) -> - keyOfBinding (uid :: visited) loc definition - (resolverOfUid uid) + Some (keyOfBinding (uid :: fst visited, snd visited) loc definition + (resolverOfUid uid)) | None -> None) | _ -> None) | None -> None) in match byOccurrence with - | Some head -> Some head + | Some head -> head | None -> ( (* No usable occurrence (e.g. [Outer (A).Inner]): structurally. *) match bindingOfPath path with @@ -1460,7 +1606,7 @@ and resolverForUnit ~currentCmtFile ~imports comp_unit = let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : identResolutions = #if OCAML_VERSION >= (5, 3, 0) - makeResolver ~cmtFilePath ~context:(compilationContext cmt_infos) + makeResolver ~cmtFilePath ~context:(compilationContext ~cmtFilePath cmt_infos) ~local:cmt_infos.cmt_uid_to_decl ~imports:cmt_infos.cmt_imports ~implShape:cmt_infos.cmt_impl_shape ~occurrences:cmt_infos.cmt_ident_occurrences @@ -1468,3 +1614,7 @@ let resolveIdentOccurrences ~cmtFilePath (cmt_infos : Cmt_format.cmt_infos) : let _ = (cmtFilePath, cmt_infos) in emptyIdentResolutions #endif + +#if OCAML_VERSION < (5, 3, 0) +let compilationContext ~cmtFilePath:_ infos = sourceContext infos +#endif diff --git a/src/DeadValue.ml b/src/DeadValue.ml index f61cd116..5bba9083 100644 --- a/src/DeadValue.ml +++ b/src/DeadValue.ml @@ -132,9 +132,9 @@ type functorParameter = { let functorParameters : functorParameter list ref = ref [] -let findFunctorParameter (path : Path.t) = +let findFunctorParameter ?(parameters = !functorParameters) (path : Path.t) = match Path.head path with - | head -> List.find_opt (fun p -> Ident.same p.paramId head) !functorParameters + | head -> List.find_opt (fun p -> Ident.same p.paramId head) parameters | exception _ -> None let isFunctorParameterPath path = findFunctorParameter path <> None @@ -324,6 +324,7 @@ type packedModule = { packedHead : functorHead option; packedShape : Compat.moduleShape option; packedConcrete : Types.module_type option; + packedResolveValue : string list -> Location.t option; packedRange : definitionRange list; packedExpr : Typedtree.module_expr; } @@ -345,21 +346,29 @@ let unpackedBinding ?(resolutions = !identResolutions) (e : Typedtree.expression | _ -> None (* Implementations of a value of the argument at [argIndex] of every - application of the functor keyed [functorDef] (under [bindings]). *) + application of the functor keyed [functorDef] (under [bindings]). Retain + [None] for each unresolved branch: a resolved sibling cannot erase it. *) let rec resolveArgumentItems ~visited ~bindings functorDef argIndex components = - if List.mem (functorDef, argIndex) visited then [] + if List.mem (functorDef, argIndex) visited then [None] else let visited = (functorDef, argIndex) :: visited in applicationsOf ~bindings functorDef argIndex |> List.concat_map (fun {resolver; bindings = own} -> match resolver with - | Direct resolve -> ( - match resolve components with Some loc -> [loc] | None -> []) + | Direct resolve -> + let resolved = resolve components in + if resolved = None && !Common.Cli.debug then + Log_.item "unresolvedArgument %s index:%d %s@." + (keyToString functorDef) argIndex (String.concat "." components); + [resolved] | ViaParameter (outerDef, outerIndex, prefix) -> - resolveArgumentItems ~visited - ~bindings:(mergeBindings (own @ bindings)) outerDef outerIndex - (prefix @ components)) + let resolved = + resolveArgumentItems ~visited + ~bindings:(mergeBindings (own @ bindings)) outerDef outerIndex + (prefix @ components) + in + if resolved = [] then [None] else resolved) (* Whether the functor keyed [functorDef] has an application supplying its parameter [argIndex]. *) @@ -1564,21 +1573,27 @@ let findSignatureItem name signature = (* Module type expansion, also for module types rooted at a functor parameter in scope ([module type T = M.T], [M.Sub.T2]): those are found in the parameter's declared module type. *) -let rec expandModuleType ?(visited = []) (moduleType : Types.module_type) = - let expanded = !identResolutions.expandModuleType moduleType in +let rec expandModuleType ?(visited = []) ?(resolutions = !identResolutions) + ?(parameters = !functorParameters) (moduleType : Types.module_type) = + let expanded = resolutions.Compat.expandModuleType moduleType in match expanded with | Mty_ident path when not (List.exists (Path.same path) visited) -> ( let visited = path :: visited in - match moduleTypeViaParameter ~visited path with - | Some moduleType -> expandModuleType ~visited moduleType + match moduleTypeViaParameter ~visited ~resolutions ~parameters path with + | Some moduleType -> + expandModuleType ~visited ~resolutions ~parameters moduleType | None -> expanded) | _ -> expanded -and moduleTypeViaParameter ~visited (path : Path.t) = - match (findFunctorParameter path, pathComponents path) with - | Some {paramType = Some paramType; prefix}, Some components -> ( +and moduleTypeViaParameter ~visited ~resolutions ~parameters (path : Path.t) = + match (findFunctorParameter ~parameters path, pathComponents path) with + | Some {paramType = Some paramType; prefix}, Some components -> let rec walk (moduleType : Types.module_type) components = - let signature = moduleType |> expandModuleType ~visited |> getSignature in + let signature = + moduleType + |> expandModuleType ~visited ~resolutions ~parameters + |> getSignature + in match components with | [] -> None | [name] -> ( @@ -1596,7 +1611,7 @@ and moduleTypeViaParameter ~visited (path : Path.t) = | None -> None) | _ -> None) in - walk paramType (prefix @ components)) + walk paramType (prefix @ components) | _ -> None (* Signature of a module type, with aliases of named module types expanded @@ -1607,8 +1622,9 @@ let expandedSignature (moduleType : Types.module_type) = moduleType |> expandModuleType |> getSignature (* The location of a value in a module type, by path of names. *) -let rec findValueInModuleType (moduleType : Types.module_type) components = - let signature = moduleType |> expandedSignature in +let rec findValueInModuleType ?(expand = fun mt -> expandModuleType mt) + (moduleType : Types.module_type) components = + let signature = moduleType |> expand |> getSignature in match components with | [] -> None | [name] -> ( @@ -1621,7 +1637,8 @@ let rec findValueInModuleType (moduleType : Types.module_type) components = match signature |> findSignatureItem m with | Some (Types.Sig_module _ as item) -> ( match item |> Compat.getSigModuleModtype with - | Some (_id, moduleType, _loc) -> findValueInModuleType moduleType rest + | Some (_id, moduleType, _loc) -> + findValueInModuleType ~expand moduleType rest | None -> None) | _ -> None) @@ -1895,6 +1912,68 @@ let rec concreteArgumentType ?(env = []) (argumentExpr : Typedtree.module_expr) | None -> None) | _ -> None +let rec valueInShape ~resolutions shape components = + match components with + | [] -> None + | [name] -> resolutions.Compat.projValue shape name + | name :: rest -> + Option.bind (resolutions.projModule shape name) (fun shape -> + valueInShape ~resolutions shape rest) + +(* Resolve anonymous members underneath their constraints, retaining the + defining scope for any named types reached after traversal has finished. *) +let rec argumentValue ~resolutions ~parameters ?(visited = []) + (e : Typedtree.module_expr) components = + if List.memq e visited then None + else + let visited = e :: visited in + let resolve = argumentValue ~resolutions ~parameters ~visited in + let fromType () = + findValueInModuleType + ~expand:(fun mt -> expandModuleType ~resolutions ~parameters mt) + e.mod_type components + in + match e.mod_desc with + | Tmod_constraint (inner, _, _, _) -> resolve inner components + | Tmod_structure {str_items} -> ( + match components with + | name :: (_ :: _ as rest) -> + let rec member = function + | [] -> None + | (item : Typedtree.structure_item) :: items -> ( + let matching (mb : Typedtree.module_binding) = + mb.mb_name.txt = Some name + in + let binding = + match item.str_desc with + | Tstr_module mb when matching mb -> Some mb + | Tstr_recmodule mbs -> List.find_opt matching mbs + | _ -> None + in + match binding with + | Some mb -> resolve mb.mb_expr rest + | None -> ( + match item.str_desc with + | Tstr_include {incl_mod; incl_type} + when List.exists + (fun item -> signatureItemName item = Some name) + incl_type -> + resolve incl_mod components + | _ -> member items)) + in + member (List.rev str_items) + | _ -> fromType ()) + | Tmod_ident (path, _) -> ( + match resolutions.Compat.bindingOfPath path with + | Some (_, definition, resolver, 0) -> + let next = Option.value resolver ~default:resolutions in + argumentValue ~resolutions:next + ~parameters: + (if next.context = resolutions.context then parameters else []) + ~visited definition components + | _ -> None) + | _ -> None + let registerPackedModule (vb : Typedtree.value_binding) = let packed = match vb.vb_expr.exp_desc with @@ -1914,17 +1993,35 @@ let registerPackedModule (vb : Typedtree.value_binding) = let moduleType = expandModuleType moduleExpr.mod_type in match getSignature moduleType with [] -> None | _ -> Some moduleType) in + let resolutions = !identResolutions in + let parameters = !functorParameters in + let shape = moduleShapeOfExpr moduleExpr in + let resolveValue components = + match + Option.bind shape (fun shape -> + valueInShape ~resolutions shape components) + with + | Some _ as loc -> loc + | None -> ( + match argumentValue ~resolutions ~parameters moduleExpr components with + | Some _ as loc -> loc + | None -> + Option.bind concrete (fun mt -> + findValueInModuleType + ~expand:(fun mt -> expandModuleType ~resolutions ~parameters mt) + mt components)) + in Hashtbl.replace packedModules (definitionKey loc.loc_start) { packedHead = functorHeadOf moduleExpr; - packedShape = moduleShapeOfExpr moduleExpr; + packedShape = shape; packedConcrete = concrete; + packedResolveValue = resolveValue; packedRange = definitionRange moduleExpr; packedExpr = moduleExpr; } | _ -> () - let () = registerPackedModuleRef := registerPackedModule (* Implementation of a value of an actual functor argument, by path. *) @@ -1948,15 +2045,8 @@ let argumentItemResolver (argumentExpr : Typedtree.module_expr) = match packedPos with None -> moduleShapeOfExpr argumentExpr | Some _ -> None in let resolutions = !identResolutions in - let rec viaShape shape components = - match components with - | [] -> None - | [name] -> resolutions.projValue shape name - | m :: rest -> ( - match resolutions.projModule shape m with - | Some shape -> viaShape shape rest - | None -> None) - in + let parameters = !functorParameters in + let expand mt = expandModuleType ~resolutions ~parameters mt in let declared = argumentModuleType argumentExpr in let concrete = match packedPos with @@ -1969,12 +2059,12 @@ let argumentItemResolver (argumentExpr : Typedtree.module_expr) = | None -> None in let shape () = - match packed () with Some {packedShape} -> packedShape | None -> shape + (* A pack's shape and named types belong to its defining resolver, not + the unit unpacking it. Its stored closure handles both together. *) + match packed () with Some _ -> None | None -> shape in let concrete () = - match packed () with - | Some {packedConcrete} -> packedConcrete - | None -> concrete + match packed () with Some _ -> None | None -> concrete in (* By shape, then by name in the concrete type, then in the declared one (a shared module type item, forwarded to its implementations). *) @@ -1990,13 +2080,17 @@ let argumentItemResolver (argumentExpr : Typedtree.module_expr) = [ (fun components -> match shape () with - | Some shape -> viaShape shape components + | Some shape -> valueInShape ~resolutions shape components | None -> None); + (fun components -> + match packed () with + | Some {packedResolveValue} -> packedResolveValue components + | None -> argumentValue ~resolutions ~parameters argumentExpr components); (fun components -> match concrete () with - | Some concrete -> findValueInModuleType concrete components + | Some concrete -> findValueInModuleType ~expand concrete components | None -> None); - findValueInModuleType declared; + findValueInModuleType ~expand declared; ]) (* Applications already recorded as part of an outer curried application, @@ -2627,9 +2721,18 @@ let forceDelayedItems () = ~posTo:callTo.loc_start call) | locs -> locs - |> List.iter (fun (locTo : Location.t) -> + |> List.iter (fun locTo -> calls - |> List.iter (fun {call} -> + |> List.iter (fun {call; callTo; callFrom} -> + (* Resolution can become possible only after the + argument's pack was scanned. The actual call is + a use even when its coercion could not resolve it. *) + Option.iter + (fun locTo -> + addValueReference ~addFileReference:true + ~locFrom:callFrom ~locTo) + locTo; + let locTo = Option.value locTo ~default:callTo in DeadOptionalArgs.addCallToImplementation ~posTo:locTo.loc_start call)) else ()) @@ -2659,6 +2762,7 @@ let forceDelayedItems () = | _ -> resolved |> List.iter (fun locTo -> + let locTo = Option.value locTo ~default:coercionTo in addValueReference ~addFileReference:true ~locFrom:coercionFrom ~locTo)); parameterCoercions := []; diff --git a/src/Reanalyze.ml b/src/Reanalyze.ml index 0a7d5daa..df106235 100644 --- a/src/Reanalyze.ml +++ b/src/Reanalyze.ml @@ -8,12 +8,11 @@ let scannedUnits = Hashtbl.create 256 let loadCmtFile ~cmtRoot cmtFilePath = let cmt_infos = Cmt_format.read_cmt cmtFilePath in - (* Identical source can be compiled against different interfaces. Preserve - those contexts, but not the byte/native distinction: [cmt_imports] - records the reused self-interface in both artifacts, whereas - [cmt_interface_digest] can be absent from the native artifact. *) + (* Identical source can use different dependency implementations, even + through the same interface. Preserve the full resolved context without + distinguishing actual byte/native/install copies. *) let unitKey = - (Compat.compilationContext cmt_infos, Filename.check_suffix cmtFilePath ".cmti") + (Compat.compilationContext ~cmtFilePath cmt_infos, Filename.check_suffix cmtFilePath ".cmti") in if Hashtbl.mem scannedUnits unitKey then () else From 7276e0765e5afade4e1911547faa611baae1843b Mon Sep 17 00:00:00 2001 From: Jono Prest Date: Thu, 17 Sep 2026 17:57:03 +0000 Subject: [PATCH 53/53] Preserve split interface and implementation artifact pairs --- .../regression/compilation_context/Split.ml | 11 +++ .../regression/compilation_context/Split.mli | 6 ++ .../compilation_context/Split_use.ml | 4 ++ scripts/run_integration_tests.js | 67 +++++++++++++++++++ src/Compat.ml | 50 ++++++++------ 5 files changed, 118 insertions(+), 20 deletions(-) create mode 100644 examples/regression/compilation_context/Split.ml create mode 100644 examples/regression/compilation_context/Split.mli create mode 100644 examples/regression/compilation_context/Split_use.ml diff --git a/examples/regression/compilation_context/Split.ml b/examples/regression/compilation_context/Split.ml new file mode 100644 index 00000000..077b5bbe --- /dev/null +++ b/examples/regression/compilation_context/Split.ml @@ -0,0 +1,11 @@ +module type S = sig + val g : ?split:int -> unit -> int +end + +module Used (_ : sig end) : S = struct + let g ?(split = 0) () = split +end + +module Unused (_ : sig end) : S = struct + let g ?(split = 0) () = split + 1 +end diff --git a/examples/regression/compilation_context/Split.mli b/examples/regression/compilation_context/Split.mli new file mode 100644 index 00000000..2403b472 --- /dev/null +++ b/examples/regression/compilation_context/Split.mli @@ -0,0 +1,6 @@ +module type S = sig + val g : ?split:int -> unit -> int +end + +module Used (_ : sig end) : S +module Unused (_ : sig end) : S diff --git a/examples/regression/compilation_context/Split_use.ml b/examples/regression/compilation_context/Split_use.ml new file mode 100644 index 00000000..1cce0b75 --- /dev/null +++ b/examples/regression/compilation_context/Split_use.ml @@ -0,0 +1,4 @@ +module Chosen = Split.Used (struct end) +module Unchosen = Split.Unused (struct end) + +let () = ignore (Chosen.g ~split:1 ()) diff --git a/scripts/run_integration_tests.js b/scripts/run_integration_tests.js index 8c9dd32d..844efa48 100644 --- a/scripts/run_integration_tests.js +++ b/scripts/run_integration_tests.js @@ -985,6 +985,72 @@ function runCompilationContextTests(sharedInterface = false) { } } +function runSplitInterfaceTests() { + if (!ocamlVersionAtLeast(5, 3)) return; + const fs = require("fs"); + const cwd = fs.mkdtempSync(path.join(require("os").tmpdir(), "reanalyze-split-interface-")); + const fixture = path.join(__dirname, "..", "examples", "regression", "compilation_context"); + const compile = (args) => child_process.execFileSync( + "ocamlc", ["-bin-annot", "-bin-annot-occurrences", ...args], { cwd } + ); + try { + for (const dir of ["src", "api", "objects", "consumer"]) { + fs.mkdirSync(path.join(cwd, dir)); + } + for (const name of ["Split.mli", "Split.ml", "Split_use.ml"]) { + fs.copyFileSync(path.join(fixture, name), path.join(cwd, "src", name)); + } + compile(["-c", "-o", "api/Split.cmi", "src/Split.mli"]); + compile(["-intf-suffix", ".ml", "-I", "api", "-c", "-o", "objects/Split.cmo", "src/Split.ml"]); + compile(["-I", "api", "-I", "objects", "-c", "-o", "consumer/Split_use.cmo", "src/Split_use.ml"]); + const artifacts = ["api/Split.cmti", "objects/Split.cmt", "consumer/Split_use.cmt"]; + const run = (root) => child_process.execFileSync( + reanalyzeFile, ["-ci", "-debug", "-dce-cmt", root], + { cwd, encoding: "utf8", timeout: 10000 } + ); + const copyArtifacts = (root, dirs) => { + for (let i = 0; i < artifacts.length; i++) { + const dir = path.join(root, dirs[i]); + fs.mkdirSync(dir, { recursive: true }); + fs.copyFileSync(path.join(cwd, artifacts[i]), path.join(dir, path.basename(artifacts[i]))); + } + }; + for (const [name, dirs, copies] of [ + ["colocated", ["all", "all", "all"]], + ["separate", ["api", "objects", "consumer"]], + ["consumer-with-api", ["api", "objects", "api"]], + ["consumer-with-implementation", ["api", "objects", "objects"]], + ["separate-copies", ["api", "objects", "consumer"], true], + ]) { + const root = path.join(cwd, "layouts", name); + copyArtifacts(root, dirs); + if (copies) copyArtifacts(root, dirs.map((dir) => path.join("install", dir))); + console.log(`${cwd}: reanalyze split interface layout ${name}`); + const output = run(root); + assertIncludes(output, "Live Value +Split.Used.+g"); + assertIncludes(output, "Dead Value +Split.Unused.+g"); + assertIncludes(output, "optional argument split of function Used.+g is always supplied (1 calls)"); + assertNotIncludes(output, "Dead Value +Split.Used.+g"); + } + // A second distinct implementation of the same API is still ambiguous: + // do not arbitrarily pick one just because a split pair is now allowed. + fs.copyFileSync(path.join(fixture, "Split.ml"), path.join(cwd, "src", "Split_other.ml")); + const ambiguous = path.join(cwd, "layouts", "ambiguous"); + copyArtifacts(ambiguous, ["api", "objects", "consumer"]); + fs.mkdirSync(path.join(ambiguous, "other")); + compile(["-intf-suffix", ".ml", "-I", "api", "-c", "-o", + path.join(ambiguous, "other", "Split.cmo"), "src/Split_other.ml"]); + console.log(`${cwd}: reanalyze ambiguous split implementations`); + const conservative = run(ambiguous); + for (const unit of ["Split", "Split_other"]) { + assertIncludes(conservative, `Live Value +${unit}.Used.+g`); + assertIncludes(conservative, `Live Value +${unit}.Unused.+g`); + } + } finally { + fs.rmSync(cwd, { recursive: true, force: true }); + } +} + function runFunctorScanOrderTest(providerName, consumerName, assertions) { if (!ocamlVersionAtLeast(5, 3)) return; const fs = require("fs"); @@ -1118,6 +1184,7 @@ function main() { runDuplicateContextTest(); runCompilationContextTests(); runCompilationContextTests(true); + runSplitInterfaceTests(); runFunctorScanOrderTest("Nested_arguments_packed", "Nested_arguments", [ "optional argument foreign_nested of function Actual.N.+g is always supplied (1 calls)", "optional argument foreign_nested of function Unrelated.N.+g is never used", diff --git a/src/Compat.ml b/src/Compat.ml index 654b0d05..9a5b5ee0 100644 --- a/src/Compat.ml +++ b/src/Compat.ml @@ -435,6 +435,24 @@ let candidateFilesForUnit ~currentCmtFile comp_unit = in (indexed @ siblings) |> List.filter Sys.file_exists |> List.sort_uniq compare +(* Prefer local candidates within each artifact kind. An interface beside + the consumer must not hide its implementation in another directory, or + vice versa. Call only after selecting the recorded interface digest. *) +let preferSiblingUnitFiles ~currentCmtFile files = + let implementations, interfaces = + List.partition (fun path -> Filename.check_suffix path ".cmt") files + in + let prefer files = + match + List.filter + (fun path -> Filename.dirname path = Filename.dirname currentCmtFile) + files + with + | [] -> files + | siblings -> siblings + in + prefer implementations @ prefer interfaces + (* Source/typing identity is only the initial partition. Identical clients may link different implementations of the same interface. Refine that partition by their resolved dependency contexts, transitively. This also @@ -485,14 +503,7 @@ let compilationContext ~cmtFilePath infos = ~allowUnmatched:false digest candidates in let candidates = - match - List.filter - (fun candidate -> - Filename.dirname candidate = Filename.dirname path) - candidates - with - | [] -> candidates - | siblings -> siblings + preferSiblingUnitFiles ~currentCmtFile:path candidates in (* An implementation supplies shapes; a sibling interface does not create a second implementation context. *) @@ -605,19 +616,16 @@ let loadUnitInfo ~currentCmtFile ~(imports : Misc.crcs) comp_unit = (* Prefer siblings only after selecting the recorded import digest: a same-named sibling must not hide the actual dependency elsewhere. *) let selected = - match selected |> List.filter (fun p -> Filename.dirname p = dir) with - | [] -> selected - | sameDir -> sameDir + preferSiblingUnitFiles ~currentCmtFile selected in let loaded = loaded |> List.filter (fun (path, _) -> List.mem path selected) in (* Copies of one compiled source (e.g. a library's objects and its _build/install copy, or byte and native objects) are one unit: keep - the first of each. Candidates that are still distinct sources in - several build directories (same name and same interface) cannot be - told apart: resolve nothing rather than redirect into the wrong - target. *) + the first of each. Distinct candidates of the same artifact kind + remain ambiguous, but a matching interface/implementation pair may + legitimately be stored in two different directories. *) let loaded = let seen = Hashtbl.create 4 in loaded @@ -631,11 +639,13 @@ let loadUnitInfo ~currentCmtFile ~(imports : Misc.crcs) comp_unit = true)) in let loaded = - match - loaded |> List.map (fun (p, _) -> Filename.dirname p) - |> List.sort_uniq compare - with - | _ :: _ :: _ -> [] + let implementations, interfaces = + List.partition + (fun (path, _) -> Filename.check_suffix path ".cmt") + loaded + in + match (implementations, interfaces) with + | _ :: _ :: _, _ | _, _ :: _ :: _ -> [] | _ -> loaded in let uidToDecl = Shape.Uid.Tbl.create 64 in