diff --git a/analysis/reanalyze/DEADCODE_REFACTOR_PLAN.md b/analysis/reanalyze/DEADCODE_REFACTOR_PLAN.md index e4c8b65b6a..d173b47041 100644 --- a/analysis/reanalyze/DEADCODE_REFACTOR_PLAN.md +++ b/analysis/reanalyze/DEADCODE_REFACTOR_PLAN.md @@ -325,12 +325,15 @@ val is_annotated_* : t -> ... -> bool **Pattern**: Same as Task 3 - `builder` (mutable) → `builder list` → `merge_all` → `t` (immutable) **Changes**: -- [ ] Create `Declarations` module with `builder` and `t` types -- [ ] `process_cmt_file` returns `Declarations.builder` (local mutable) -- [ ] `processCmtFiles` collects into `builder list` -- [ ] `Declarations.merge_all : builder list -> t` -- [ ] Solver uses immutable `Declarations.t` -- [ ] Delete global `DeadCommon.decls` +- [x] Create `Declarations` module with `builder` and `t` types +- [x] `process_cmt_file` returns `DceFileProcessing.file_data` containing both `annotations` and `decls` builders +- [x] `processCmtFiles` collects into `file_data list` +- [x] `Declarations.merge_all : builder list -> t` +- [x] Solver uses immutable `Declarations.t` +- [x] Delete global `DeadCommon.decls` +- [x] Update `DeadOptionalArgs.forceDelayedItems` to take `~decls:Declarations.t` + +**Status**: Complete ✅ **Test**: Process files in different orders - results should be identical. diff --git a/analysis/reanalyze/src/CollectAnnotations.ml b/analysis/reanalyze/src/CollectAnnotations.ml new file mode 100644 index 0000000000..91f97a8924 --- /dev/null +++ b/analysis/reanalyze/src/CollectAnnotations.ml @@ -0,0 +1,149 @@ +(** AST traversal to collect source annotations (@dead, @live, @genType). + + This module traverses the typed AST to find attribute annotations + and records them in a FileAnnotations.builder. *) + +open DeadCommon + +let processAttributes ~state ~config ~doGenType ~name ~pos attributes = + let getPayloadFun f = attributes |> Annotation.getAttributePayload f in + let getPayload (x : string) = + attributes |> Annotation.getAttributePayload (( = ) x) + in + if + doGenType + && getPayloadFun Annotation.tagIsOneOfTheGenTypeAnnotations <> None + then FileAnnotations.annotate_gentype state pos; + if getPayload WriteDeadAnnotations.deadAnnotation <> None then + FileAnnotations.annotate_dead state pos; + let nameIsInLiveNamesOrPaths () = + config.DceConfig.cli.live_names |> List.mem name + || + let fname = + match Filename.is_relative pos.pos_fname with + | true -> pos.pos_fname + | false -> Filename.concat (Sys.getcwd ()) pos.pos_fname + in + let fnameLen = String.length fname in + config.DceConfig.cli.live_paths + |> List.exists (fun prefix -> + String.length prefix <= fnameLen + && + try String.sub fname 0 (String.length prefix) = prefix + with Invalid_argument _ -> false) + in + if getPayload liveAnnotation <> None || nameIsInLiveNamesOrPaths () then + FileAnnotations.annotate_live state pos; + if attributes |> Annotation.isOcamlSuppressDeadWarning then + FileAnnotations.annotate_live state pos + +let collectExportLocations ~state ~config ~doGenType = + let super = Tast_mapper.default in + let currentlyDisableWarnings = ref false in + let value_binding self + ({vb_attributes; vb_pat} as value_binding : Typedtree.value_binding) = + (match vb_pat.pat_desc with + | Tpat_var (id, {loc = {loc_start = pos}}) + | Tpat_alias ({pat_desc = Tpat_any}, id, {loc = {loc_start = pos}}) -> + if !currentlyDisableWarnings then FileAnnotations.annotate_live state pos; + vb_attributes + |> processAttributes ~state ~config ~doGenType ~name:(id |> Ident.name) + ~pos + | _ -> ()); + super.value_binding self value_binding + in + let type_kind toplevelAttrs self (typeKind : Typedtree.type_kind) = + (match typeKind with + | Ttype_record labelDeclarations -> + labelDeclarations + |> List.iter + (fun ({ld_attributes; ld_loc} : Typedtree.label_declaration) -> + toplevelAttrs @ ld_attributes + |> processAttributes ~state ~config ~doGenType:false ~name:"" + ~pos:ld_loc.loc_start) + | Ttype_variant constructorDeclarations -> + constructorDeclarations + |> List.iter + (fun + ({cd_attributes; cd_loc; cd_args} : + Typedtree.constructor_declaration) + -> + let _process_inline_records = + match cd_args with + | Cstr_record flds -> + List.iter + (fun ({ld_attributes; ld_loc} : Typedtree.label_declaration) + -> + toplevelAttrs @ cd_attributes @ ld_attributes + |> processAttributes ~state ~config ~doGenType:false + ~name:"" ~pos:ld_loc.loc_start) + flds + | Cstr_tuple _ -> () + in + toplevelAttrs @ cd_attributes + |> processAttributes ~state ~config ~doGenType:false ~name:"" + ~pos:cd_loc.loc_start) + | _ -> ()); + super.type_kind self typeKind + in + let type_declaration self (typeDeclaration : Typedtree.type_declaration) = + let attributes = typeDeclaration.typ_attributes in + let _ = type_kind attributes self typeDeclaration.typ_kind in + typeDeclaration + in + let value_description self + ({val_attributes; val_id; val_val = {val_loc = {loc_start = pos}}} as + value_description : + Typedtree.value_description) = + if !currentlyDisableWarnings then FileAnnotations.annotate_live state pos; + val_attributes + |> processAttributes ~state ~config ~doGenType ~name:(val_id |> Ident.name) + ~pos; + super.value_description self value_description + in + let structure_item self (item : Typedtree.structure_item) = + (match item.str_desc with + | Tstr_attribute attribute + when [attribute] |> Annotation.isOcamlSuppressDeadWarning -> + currentlyDisableWarnings := true + | _ -> ()); + super.structure_item self item + in + let structure self (structure : Typedtree.structure) = + let oldDisableWarnings = !currentlyDisableWarnings in + super.structure self structure |> ignore; + currentlyDisableWarnings := oldDisableWarnings; + structure + in + let signature_item self (item : Typedtree.signature_item) = + (match item.sig_desc with + | Tsig_attribute attribute + when [attribute] |> Annotation.isOcamlSuppressDeadWarning -> + currentlyDisableWarnings := true + | _ -> ()); + super.signature_item self item + in + let signature self (signature : Typedtree.signature) = + let oldDisableWarnings = !currentlyDisableWarnings in + super.signature self signature |> ignore; + currentlyDisableWarnings := oldDisableWarnings; + signature + in + { + super with + signature; + signature_item; + structure; + structure_item; + type_declaration; + value_binding; + value_description; + } + +let structure ~state ~config ~doGenType structure = + let mapper = collectExportLocations ~state ~config ~doGenType in + structure |> mapper.structure mapper |> ignore + +let signature ~state ~config signature = + let mapper = collectExportLocations ~state ~config ~doGenType:true in + signature |> mapper.signature mapper |> ignore diff --git a/analysis/reanalyze/src/CollectAnnotations.mli b/analysis/reanalyze/src/CollectAnnotations.mli new file mode 100644 index 0000000000..c81279e396 --- /dev/null +++ b/analysis/reanalyze/src/CollectAnnotations.mli @@ -0,0 +1,18 @@ +(** AST traversal to collect source annotations (@dead, @live, @genType). + + Traverses the typed AST and records annotations in a FileAnnotations.builder. *) + +val structure : + state:FileAnnotations.builder -> + config:DceConfig.t -> + doGenType:bool -> + Typedtree.structure -> + unit +(** Traverse a structure and collect annotations. *) + +val signature : + state:FileAnnotations.builder -> + config:DceConfig.t -> + Typedtree.signature -> + unit +(** Traverse a signature and collect annotations. *) diff --git a/analysis/reanalyze/src/DceFileProcessing.ml b/analysis/reanalyze/src/DceFileProcessing.ml index 425f72aedb..3959508d6d 100644 --- a/analysis/reanalyze/src/DceFileProcessing.ml +++ b/analysis/reanalyze/src/DceFileProcessing.ml @@ -1,7 +1,7 @@ (** Per-file AST processing for dead code analysis. - This module uses FileAnnotations.builder during AST traversal - and returns it for merging. The caller freezes it before + This module coordinates per-file processing using local mutable builders + and returns them for merging. The caller freezes them before passing to the solver. *) open DeadCommon @@ -17,163 +17,9 @@ type file_context = { let module_name_tagged (file : file_context) = file.module_name |> Name.create ~isInterface:file.is_interface -(* ===== AST Processing (internal) ===== *) +(* ===== Signature processing ===== *) -module CollectAnnotations = struct - let processAttributes ~state ~config ~doGenType ~name ~pos attributes = - let getPayloadFun f = attributes |> Annotation.getAttributePayload f in - let getPayload (x : string) = - attributes |> Annotation.getAttributePayload (( = ) x) - in - if - doGenType - && getPayloadFun Annotation.tagIsOneOfTheGenTypeAnnotations <> None - then FileAnnotations.annotate_gentype state pos; - if getPayload WriteDeadAnnotations.deadAnnotation <> None then - FileAnnotations.annotate_dead state pos; - let nameIsInLiveNamesOrPaths () = - config.DceConfig.cli.live_names |> List.mem name - || - let fname = - match Filename.is_relative pos.pos_fname with - | true -> pos.pos_fname - | false -> Filename.concat (Sys.getcwd ()) pos.pos_fname - in - let fnameLen = String.length fname in - config.DceConfig.cli.live_paths - |> List.exists (fun prefix -> - String.length prefix <= fnameLen - && - try String.sub fname 0 (String.length prefix) = prefix - with Invalid_argument _ -> false) - in - if getPayload liveAnnotation <> None || nameIsInLiveNamesOrPaths () then - FileAnnotations.annotate_live state pos; - if attributes |> Annotation.isOcamlSuppressDeadWarning then - FileAnnotations.annotate_live state pos - - let collectExportLocations ~state ~config ~doGenType = - let super = Tast_mapper.default in - let currentlyDisableWarnings = ref false in - let value_binding self - ({vb_attributes; vb_pat} as value_binding : Typedtree.value_binding) = - (match vb_pat.pat_desc with - | Tpat_var (id, {loc = {loc_start = pos}}) - | Tpat_alias ({pat_desc = Tpat_any}, id, {loc = {loc_start = pos}}) -> - if !currentlyDisableWarnings then - FileAnnotations.annotate_live state pos; - vb_attributes - |> processAttributes ~state ~config ~doGenType ~name:(id |> Ident.name) - ~pos - | _ -> ()); - super.value_binding self value_binding - in - let type_kind toplevelAttrs self (typeKind : Typedtree.type_kind) = - (match typeKind with - | Ttype_record labelDeclarations -> - labelDeclarations - |> List.iter - (fun ({ld_attributes; ld_loc} : Typedtree.label_declaration) -> - toplevelAttrs @ ld_attributes - |> processAttributes ~state ~config ~doGenType:false ~name:"" - ~pos:ld_loc.loc_start) - | Ttype_variant constructorDeclarations -> - constructorDeclarations - |> List.iter - (fun - ({cd_attributes; cd_loc; cd_args} : - Typedtree.constructor_declaration) - -> - let _process_inline_records = - match cd_args with - | Cstr_record flds -> - List.iter - (fun ({ld_attributes; ld_loc} : - Typedtree.label_declaration) -> - toplevelAttrs @ cd_attributes @ ld_attributes - |> processAttributes ~state ~config ~doGenType:false - ~name:"" ~pos:ld_loc.loc_start) - flds - | Cstr_tuple _ -> () - in - toplevelAttrs @ cd_attributes - |> processAttributes ~state ~config ~doGenType:false ~name:"" - ~pos:cd_loc.loc_start) - | _ -> ()); - super.type_kind self typeKind - in - let type_declaration self (typeDeclaration : Typedtree.type_declaration) = - let attributes = typeDeclaration.typ_attributes in - let _ = type_kind attributes self typeDeclaration.typ_kind in - typeDeclaration - in - let value_description self - ({val_attributes; val_id; val_val = {val_loc = {loc_start = pos}}} as - value_description : - Typedtree.value_description) = - if !currentlyDisableWarnings then FileAnnotations.annotate_live state pos; - val_attributes - |> processAttributes ~state ~config ~doGenType - ~name:(val_id |> Ident.name) ~pos; - super.value_description self value_description - in - let structure_item self (item : Typedtree.structure_item) = - (match item.str_desc with - | Tstr_attribute attribute - when [attribute] |> Annotation.isOcamlSuppressDeadWarning -> - currentlyDisableWarnings := true - | _ -> ()); - super.structure_item self item - in - let structure self (structure : Typedtree.structure) = - let oldDisableWarnings = !currentlyDisableWarnings in - super.structure self structure |> ignore; - currentlyDisableWarnings := oldDisableWarnings; - structure - in - let signature_item self (item : Typedtree.signature_item) = - (match item.sig_desc with - | Tsig_attribute attribute - when [attribute] |> Annotation.isOcamlSuppressDeadWarning -> - currentlyDisableWarnings := true - | _ -> ()); - super.signature_item self item - in - let signature self (signature : Typedtree.signature) = - let oldDisableWarnings = !currentlyDisableWarnings in - super.signature self signature |> ignore; - currentlyDisableWarnings := oldDisableWarnings; - signature - in - { - super with - signature; - signature_item; - structure; - structure_item; - type_declaration; - value_binding; - value_description; - } - - let structure ~state ~config ~doGenType structure = - let collectExportLocations = - collectExportLocations ~state ~config ~doGenType - in - structure - |> collectExportLocations.structure collectExportLocations - |> ignore - - let signature ~state ~config signature = - let collectExportLocations = - collectExportLocations ~state ~config ~doGenType:true - in - signature - |> collectExportLocations.signature collectExportLocations - |> ignore -end - -let processSignature ~config ~(file : file_context) ~doValues ~doTypes +let processSignature ~config ~decls ~(file : file_context) ~doValues ~doTypes (signature : Types.signature) = let dead_common_file : FileContext.t = { @@ -184,15 +30,20 @@ let processSignature ~config ~(file : file_context) ~doValues ~doTypes in signature |> List.iter (fun sig_item -> - DeadValue.processSignatureItem ~config ~file:dead_common_file ~doValues - ~doTypes ~moduleLoc:Location.none + DeadValue.processSignatureItem ~config ~decls ~file:dead_common_file + ~doValues ~doTypes ~moduleLoc:Location.none ~path:[module_name_tagged file] sig_item) (* ===== Main entry point ===== *) +type file_data = { + annotations: FileAnnotations.builder; + decls: Declarations.builder; +} + let process_cmt_file ~config ~(file : file_context) ~cmtFilePath - (cmt_infos : Cmt_format.cmt_infos) : FileAnnotations.builder = + (cmt_infos : Cmt_format.cmt_infos) : file_data = (* Convert to DeadCommon.FileContext for functions that need it *) let dead_common_file : FileContext.t = { @@ -201,27 +52,28 @@ let process_cmt_file ~config ~(file : file_context) ~cmtFilePath is_interface = file.is_interface; } in - (* Mutable builder for AST processing *) - let builder = FileAnnotations.create_builder () in + (* Mutable builders for AST processing *) + let annotations = FileAnnotations.create_builder () in + let decls = Declarations.create_builder () in (match cmt_infos.cmt_annots with | Interface signature -> - CollectAnnotations.signature ~state:builder ~config signature; - processSignature ~config ~file ~doValues:true ~doTypes:true + CollectAnnotations.signature ~state:annotations ~config signature; + processSignature ~config ~decls ~file ~doValues:true ~doTypes:true signature.sig_type | Implementation structure -> let cmtiExists = Sys.file_exists ((cmtFilePath |> Filename.remove_extension) ^ ".cmti") in - CollectAnnotations.structure ~state:builder ~config + CollectAnnotations.structure ~state:annotations ~config ~doGenType:(not cmtiExists) structure; - processSignature ~config ~file ~doValues:true ~doTypes:false + processSignature ~config ~decls ~file ~doValues:true ~doTypes:false structure.str_type; let doExternals = false in - DeadValue.processStructure ~config ~file:dead_common_file ~doTypes:true - ~doExternals ~cmt_value_dependencies:cmt_infos.cmt_value_dependencies - structure + DeadValue.processStructure ~config ~decls ~file:dead_common_file + ~doTypes:true ~doExternals + ~cmt_value_dependencies:cmt_infos.cmt_value_dependencies structure | _ -> ()); DeadType.TypeDependencies.forceDelayedItems ~config; DeadType.TypeDependencies.clear (); - (* Return builder - caller will merge and freeze *) - builder + (* Return builders - caller will merge and freeze *) + {annotations; decls} diff --git a/analysis/reanalyze/src/DceFileProcessing.mli b/analysis/reanalyze/src/DceFileProcessing.mli index 2fc48ba3cf..d5f152c5cd 100644 --- a/analysis/reanalyze/src/DceFileProcessing.mli +++ b/analysis/reanalyze/src/DceFileProcessing.mli @@ -1,8 +1,8 @@ (** Per-file AST processing for dead code analysis. - This module uses [FileAnnotations.builder] during AST traversal - and returns it for merging. The caller freezes the accumulated - builder before passing to the solver. *) + This module uses mutable builders during AST traversal + and returns them for merging. The caller freezes the accumulated + builders before passing to the solver. *) type file_context = { source_path: string; @@ -11,11 +11,17 @@ type file_context = { } (** File context for processing *) +type file_data = { + annotations: FileAnnotations.builder; + decls: Declarations.builder; +} +(** Result of processing a cmt file - both annotations and declarations *) + val process_cmt_file : config:DceConfig.t -> file:file_context -> cmtFilePath:string -> Cmt_format.cmt_infos -> - FileAnnotations.builder -(** Process a cmt file and return mutable builder. + file_data +(** Process a cmt file and return mutable builders. Caller should merge builders and freeze before passing to solver. *) diff --git a/analysis/reanalyze/src/DeadCommon.ml b/analysis/reanalyze/src/DeadCommon.ml index 7ab6315c46..b212c55db7 100644 --- a/analysis/reanalyze/src/DeadCommon.ml +++ b/analysis/reanalyze/src/DeadCommon.ml @@ -56,9 +56,9 @@ module PosHash = struct end type decls = decl PosHash.t -(** all exported declarations *) +(** type alias for declaration hashtables *) -let decls = (PosHash.create 256 : decls) +(* NOTE: Global decls removed - now using Declarations.builder/t pattern *) module ValueReferences = struct (** all value references *) @@ -189,8 +189,8 @@ let iterFilesFromRootsToLeaves iterFun = }); iterFun fileName)) -let addDeclaration_ ~config ~(file : FileContext.t) ?posEnd ?posStart ~declKind - ~path ~(loc : Location.t) ?(posAdjustment = Nothing) ~moduleLoc +let addDeclaration_ ~config ~decls ~(file : FileContext.t) ?posEnd ?posStart + ~declKind ~path ~(loc : Location.t) ?(posAdjustment = Nothing) ~moduleLoc (name : Name.t) = let pos = loc.loc_start in let posStart = @@ -226,12 +226,13 @@ let addDeclaration_ ~config ~(file : FileContext.t) ?posEnd ?posStart ~declKind report = true; } in - PosHash.replace decls pos decl) + Declarations.add decls pos decl) -let addValueDeclaration ~config ~file ?(isToplevel = true) ~(loc : Location.t) - ~moduleLoc ?(optionalArgs = OptionalArgs.empty) ~path ~sideEffects name = +let addValueDeclaration ~config ~decls ~file ?(isToplevel = true) + ~(loc : Location.t) ~moduleLoc ?(optionalArgs = OptionalArgs.empty) ~path + ~sideEffects name = name - |> addDeclaration_ ~config ~file + |> addDeclaration_ ~config ~decls ~file ~declKind:(Value {isToplevel; optionalArgs; sideEffects}) ~loc ~moduleLoc ~path @@ -417,7 +418,7 @@ let declIsDead ~annotations ~refs decl = let doReportDead ~annotations pos = not (FileAnnotations.is_annotated_gentype_or_dead annotations pos) -let rec resolveRecursiveRefs ~annotations ~config +let rec resolveRecursiveRefs ~annotations ~config ~decls ~checkOptionalArg:(checkOptionalArgFn : config:DceConfig.t -> decl -> unit) ~deadDeclarations ~level ~orderedFiles ~refs ~refsBeingResolved decl : bool = @@ -451,7 +452,7 @@ let rec resolveRecursiveRefs ~annotations ~config (decl.path |> Path.toString); false) else - match PosHash.find_opt decls pos with + match Declarations.find_opt decls pos with | None -> if Config.recursiveDebug then Log_.item "recursiveDebug can't find decl for %s@." @@ -465,7 +466,7 @@ let rec resolveRecursiveRefs ~annotations ~config in let xDeclIsDead = xDecl - |> resolveRecursiveRefs ~annotations ~config + |> resolveRecursiveRefs ~annotations ~config ~decls ~checkOptionalArg:checkOptionalArgFn ~deadDeclarations ~level:(level + 1) ~orderedFiles ~refs:xRefs ~refsBeingResolved @@ -508,7 +509,7 @@ let rec resolveRecursiveRefs ~annotations ~config refsString level); isDead -let reportDead ~annotations ~config +let reportDead ~annotations ~config ~decls ~checkOptionalArg: (checkOptionalArgFn : annotations:FileAnnotations.t -> config:DceConfig.t -> decl -> unit) = @@ -518,7 +519,7 @@ let reportDead ~annotations ~config | true -> ValueReferences.find decl.pos | false -> TypeReferences.find decl.pos in - resolveRecursiveRefs ~annotations ~config + resolveRecursiveRefs ~annotations ~config ~decls ~checkOptionalArg:(checkOptionalArgFn ~annotations) ~deadDeclarations ~level:0 ~orderedFiles ~refsBeingResolved:(ref PosSet.empty) ~refs decl @@ -537,7 +538,9 @@ let reportDead ~annotations ~config (files |> FileSet.elements |> List.map Filename.basename |> String.concat ", "))); let declarations = - PosHash.fold (fun _pos decl declarations -> decl :: declarations) decls [] + Declarations.fold + (fun _pos decl declarations -> decl :: declarations) + decls [] in let orderedFiles = Hashtbl.create 256 in iterFilesFromRootsToLeaves diff --git a/analysis/reanalyze/src/DeadException.ml b/analysis/reanalyze/src/DeadException.ml index 01509c8fa2..6cf1673359 100644 --- a/analysis/reanalyze/src/DeadException.ml +++ b/analysis/reanalyze/src/DeadException.ml @@ -6,11 +6,11 @@ type item = {exceptionPath: Path.t; locFrom: Location.t} let delayedItems = ref [] let declarations = Hashtbl.create 1 -let add ~config ~file ~path ~loc ~(strLoc : Location.t) name = +let add ~config ~decls ~file ~path ~loc ~(strLoc : Location.t) name = let exceptionPath = name :: path in Hashtbl.add declarations exceptionPath loc; name - |> addDeclaration_ ~config ~file ~posEnd:strLoc.loc_end + |> addDeclaration_ ~config ~decls ~file ~posEnd:strLoc.loc_end ~posStart:strLoc.loc_start ~declKind:Exception ~moduleLoc:(ModulePath.getCurrent ()).loc ~path ~loc diff --git a/analysis/reanalyze/src/DeadOptionalArgs.ml b/analysis/reanalyze/src/DeadOptionalArgs.ml index 3eaf7b055e..9f5e4faf7c 100644 --- a/analysis/reanalyze/src/DeadOptionalArgs.ml +++ b/analysis/reanalyze/src/DeadOptionalArgs.ml @@ -12,12 +12,14 @@ type item = { let delayedItems = (ref [] : item list ref) let functionReferences = (ref [] : (Lexing.position * Lexing.position) list ref) -let addFunctionReference ~config ~(locFrom : Location.t) ~(locTo : Location.t) = +let addFunctionReference ~config ~decls ~(locFrom : Location.t) + ~(locTo : Location.t) = if active () then let posTo = locTo.loc_start in let posFrom = locFrom.loc_start in + (* Check if target has optional args - for filtering and debug logging *) let shouldAdd = - match PosHash.find_opt decls posTo with + match Declarations.find_opt_builder decls posTo with | Some {declKind = Value {optionalArgs}} -> not (OptionalArgs.isEmpty optionalArgs) | _ -> false @@ -61,12 +63,12 @@ let addReferences ~config ~(locFrom : Location.t) ~(locTo : Location.t) ~path (argNamesMaybe |> String.concat ", ") (posFrom |> posToString)) -let forceDelayedItems () = +let forceDelayedItems ~decls = let items = !delayedItems |> List.rev in delayedItems := []; items |> List.iter (fun {posTo; argNames; argNamesMaybe} -> - match PosHash.find_opt decls posTo with + match Declarations.find_opt decls posTo with | Some {declKind = Value r} -> r.optionalArgs |> OptionalArgs.call ~argNames ~argNamesMaybe | _ -> ()); @@ -75,9 +77,12 @@ let forceDelayedItems () = fRefs |> List.iter (fun (posFrom, posTo) -> match - (PosHash.find_opt decls posFrom, PosHash.find_opt decls posTo) + ( Declarations.find_opt decls posFrom, + Declarations.find_opt decls posTo ) with - | Some {declKind = Value rFrom}, Some {declKind = Value rTo} -> + | Some {declKind = Value rFrom}, Some {declKind = Value rTo} + when not (OptionalArgs.isEmpty rTo.optionalArgs) -> + (* Only process if target has optional args - matching original filtering *) OptionalArgs.combine rFrom.optionalArgs rTo.optionalArgs | _ -> ()) diff --git a/analysis/reanalyze/src/DeadType.ml b/analysis/reanalyze/src/DeadType.ml index 2144c30d7c..aa401cfb15 100644 --- a/analysis/reanalyze/src/DeadType.ml +++ b/analysis/reanalyze/src/DeadType.ml @@ -81,7 +81,7 @@ let addTypeDependenciesInnerModule ~config ~pathToType ~loc ~typeLabelName = extendTypeDependencies ~config loc2 loc | None -> TypeLabels.add path loc -let addDeclaration ~config ~file ~(typeId : Ident.t) +let addDeclaration ~config ~decls ~file ~(typeId : Ident.t) ~(typeKind : Types.type_kind) = let currentModulePath = ModulePath.getCurrent () in let pathToType = @@ -90,7 +90,7 @@ let addDeclaration ~config ~file ~(typeId : Ident.t) in let processTypeLabel ?(posAdjustment = Nothing) typeLabelName ~declKind ~(loc : Location.t) = - addDeclaration_ ~config ~file ~declKind ~path:pathToType ~loc + addDeclaration_ ~config ~decls ~file ~declKind ~path:pathToType ~loc ~moduleLoc:currentModulePath.loc ~posAdjustment typeLabelName; addTypeDependenciesAcrossFiles ~config ~file ~pathToType ~loc ~typeLabelName; addTypeDependenciesInnerModule ~config ~pathToType ~loc ~typeLabelName; diff --git a/analysis/reanalyze/src/DeadValue.ml b/analysis/reanalyze/src/DeadValue.ml index c73443cf7e..f7b0e2a9d6 100644 --- a/analysis/reanalyze/src/DeadValue.ml +++ b/analysis/reanalyze/src/DeadValue.ml @@ -2,7 +2,7 @@ open DeadCommon -let checkAnyValueBindingWithNoSideEffects ~config ~file +let checkAnyValueBindingWithNoSideEffects ~config ~decls ~file ({vb_pat = {pat_desc}; vb_expr = expr; vb_loc = loc} : Typedtree.value_binding) = match pat_desc with @@ -11,14 +11,14 @@ let checkAnyValueBindingWithNoSideEffects ~config ~file let currentModulePath = ModulePath.getCurrent () in let path = currentModulePath.path @ [FileContext.module_name_tagged file] in name - |> addValueDeclaration ~config ~file ~path ~loc + |> addValueDeclaration ~config ~decls ~file ~path ~loc ~moduleLoc:currentModulePath.loc ~sideEffects:false | _ -> () -let collectValueBinding ~config ~file ~(current_binding : Location.t) +let collectValueBinding ~config ~decls ~file ~(current_binding : Location.t) (vb : Typedtree.value_binding) = let oldLastBinding = current_binding in - checkAnyValueBindingWithNoSideEffects ~config ~file vb; + checkAnyValueBindingWithNoSideEffects ~config ~decls ~file vb; let loc = match vb.vb_pat.pat_desc with | Tpat_var (id, {loc = {loc_start; loc_ghost} as loc}) @@ -31,7 +31,7 @@ let collectValueBinding ~config ~file ~(current_binding : Location.t) |> Common.OptionalArgs.fromList in let exists = - match PosHash.find_opt decls loc_start with + match Declarations.find_opt_builder decls loc_start with | Some {declKind = Value r} -> r.optionalArgs <- optionalArgs; true @@ -51,9 +51,9 @@ let collectValueBinding ~config ~file ~(current_binding : Location.t) let isToplevel = oldLastBinding = Location.none in let sideEffects = SideEffects.checkExpr vb.vb_expr in name - |> addValueDeclaration ~config ~file ~isToplevel ~loc + |> addValueDeclaration ~config ~decls ~file ~isToplevel ~loc ~moduleLoc:currentModulePath.loc ~optionalArgs ~path ~sideEffects); - (match PosHash.find_opt decls loc_start with + (match Declarations.find_opt_builder decls loc_start with | None -> () | Some decl -> (* Value bindings contain the correct location for the entire declaration: update final position. @@ -65,7 +65,7 @@ let collectValueBinding ~config ~file ~(current_binding : Location.t) {vk with sideEffects = SideEffects.checkExpr vb.vb_expr} | dk -> dk in - PosHash.replace decls loc_start + Declarations.replace_builder decls loc_start { decl with declKind; @@ -237,13 +237,14 @@ let rec getSignature (moduleType : Types.module_type) = | Mty_functor (_, _mtParam, mt) -> getSignature mt | _ -> [] -let rec processSignatureItem ~config ~file ~doTypes ~doValues ~moduleLoc ~path - (si : Types.signature_item) = +let rec processSignatureItem ~config ~decls ~file ~doTypes ~doValues ~moduleLoc + ~path (si : Types.signature_item) = let oldModulePath = ModulePath.getCurrent () in (match si with | Sig_type (id, t, _) when doTypes -> if !Config.analyzeTypes then - DeadType.addDeclaration ~config ~file ~typeId:id ~typeKind:t.type_kind + DeadType.addDeclaration ~config ~decls ~file ~typeId:id + ~typeKind:t.type_kind | Sig_value (id, {Types.val_loc = loc; val_kind = kind; val_type}) when doValues -> if not loc.Location.loc_ghost then @@ -262,8 +263,8 @@ let rec processSignatureItem ~config ~file ~doTypes ~doValues ~moduleLoc ~path Printf.printf "XXX %s\n" (Ident.name id); *) Ident.name id |> Name.create ~isInterface:false - |> addValueDeclaration ~config ~file ~loc ~moduleLoc ~optionalArgs ~path - ~sideEffects:false + |> addValueDeclaration ~config ~decls ~file ~loc ~moduleLoc + ~optionalArgs ~path ~sideEffects:false | Sig_module (id, {Types.md_type = moduleType; md_loc = moduleLoc}, _) | Sig_modtype (id, {Types.mtd_type = Some moduleType; mtd_loc = moduleLoc}) -> ModulePath.setCurrent @@ -280,13 +281,14 @@ let rec processSignatureItem ~config ~file ~doTypes ~doValues ~moduleLoc ~path if collect then getSignature moduleType |> List.iter - (processSignatureItem ~config ~file ~doTypes ~doValues ~moduleLoc + (processSignatureItem ~config ~decls ~file ~doTypes ~doValues + ~moduleLoc ~path:((id |> Ident.name |> Name.create) :: path)) | _ -> ()); ModulePath.setCurrent oldModulePath (* Traverse the AST *) -let traverseStructure ~config ~file ~doTypes ~doExternals +let traverseStructure ~config ~decls ~file ~doTypes ~doExternals (structure : Typedtree.structure) : unit = let rec create_mapper (last_binding : Location.t) = let super = Tast_mapper.default in @@ -318,7 +320,7 @@ let traverseStructure ~config ~file ~doTypes ~doExternals | Mty_signature signature -> signature |> List.iter - (processSignatureItem ~config ~file ~doTypes + (processSignatureItem ~config ~decls ~file ~doTypes ~doValues:false ~moduleLoc:mb_expr.mod_loc ~path: ((ModulePath.getCurrent ()).path @@ -330,7 +332,9 @@ let traverseStructure ~config ~file ~doTypes ~doExternals currentModulePath.path @ [FileContext.module_name_tagged file] in let exists = - match PosHash.find_opt decls vd.val_loc.loc_start with + match + Declarations.find_opt_builder decls vd.val_loc.loc_start + with | Some {declKind = Value _} -> true | _ -> false in @@ -342,14 +346,15 @@ let traverseStructure ~config ~file ~doTypes ~doExternals then id |> Name.create ~isInterface:false - |> addValueDeclaration ~config ~file ~path ~loc:vd.val_loc - ~moduleLoc:currentModulePath.loc ~sideEffects:false + |> addValueDeclaration ~config ~decls ~file ~path + ~loc:vd.val_loc ~moduleLoc:currentModulePath.loc + ~sideEffects:false | Tstr_type (_recFlag, typeDeclarations) when doTypes -> if !Config.analyzeTypes then typeDeclarations |> List.iter (fun (typeDeclaration : Typedtree.type_declaration) -> - DeadType.addDeclaration ~config ~file + DeadType.addDeclaration ~config ~decls ~file ~typeId:typeDeclaration.typ_id ~typeKind:typeDeclaration.typ_type.type_kind) | Tstr_include {incl_mod; incl_type} -> ( @@ -361,7 +366,7 @@ let traverseStructure ~config ~file ~doTypes ~doExternals in incl_type |> List.iter - (processSignatureItem ~config ~file ~doTypes + (processSignatureItem ~config ~decls ~file ~doTypes ~doValues:false (* TODO: also values? *) ~moduleLoc:incl_mod.mod_loc ~path:currentPath) | _ -> ()) @@ -372,7 +377,7 @@ let traverseStructure ~config ~file ~doTypes ~doExternals in let name = id |> Ident.name |> Name.create in name - |> DeadException.add ~config ~file ~path ~loc + |> DeadException.add ~config ~decls ~file ~path ~loc ~strLoc:structureItem.str_loc | _ -> ()); let result = super.structure_item mapper structureItem in @@ -382,7 +387,8 @@ let traverseStructure ~config ~file ~doTypes ~doExternals (fun _self vb -> let loc = vb - |> collectValueBinding ~config ~file ~current_binding:last_binding + |> collectValueBinding ~config ~decls ~file + ~current_binding:last_binding in let nested_mapper = create_mapper loc in super.Tast_mapper.value_binding nested_mapper vb); @@ -394,7 +400,7 @@ let traverseStructure ~config ~file ~doTypes ~doExternals mapper.structure mapper structure |> ignore (* Merge a location's references to another one's *) -let processValueDependency ~config +let processValueDependency ~config ~decls ( ({ val_loc = {loc_start = {pos_fname = fnTo} as posTo; loc_ghost = ghost1} as @@ -411,10 +417,10 @@ let processValueDependency ~config let addFileReference = fileIsImplementationOf fnTo fnFrom in addValueReference ~config ~binding:Location.none ~addFileReference ~locFrom ~locTo; - DeadOptionalArgs.addFunctionReference ~config ~locFrom ~locTo) + DeadOptionalArgs.addFunctionReference ~config ~decls ~locFrom ~locTo) -let processStructure ~config ~file ~cmt_value_dependencies ~doTypes ~doExternals - (structure : Typedtree.structure) = - traverseStructure ~config ~file ~doTypes ~doExternals structure; +let processStructure ~config ~decls ~file ~cmt_value_dependencies ~doTypes + ~doExternals (structure : Typedtree.structure) = + traverseStructure ~config ~decls ~file ~doTypes ~doExternals structure; let valueDependencies = cmt_value_dependencies |> List.rev in - valueDependencies |> List.iter (processValueDependency ~config) + valueDependencies |> List.iter (processValueDependency ~config ~decls) diff --git a/analysis/reanalyze/src/Declarations.ml b/analysis/reanalyze/src/Declarations.ml new file mode 100644 index 0000000000..d6e5311116 --- /dev/null +++ b/analysis/reanalyze/src/Declarations.ml @@ -0,0 +1,49 @@ +(** Declarations collected during dead code analysis. + + Two types are provided: + - [builder] - mutable, for AST processing + - [t] - immutable, for solver (read-only access) *) + +open Common + +(* Position-keyed hashtable (same as DeadCommon.PosHash but no dependency) *) +module PosHash = Hashtbl.Make (struct + type t = Lexing.position + + let hash x = + let s = Filename.basename x.Lexing.pos_fname in + Hashtbl.hash (x.Lexing.pos_cnum, s) + + let equal (x : t) y = x = y +end) + +(* Both types have the same representation, but different semantics *) +type t = decl PosHash.t +type builder = decl PosHash.t + +(* ===== Builder API ===== *) + +let create_builder () : builder = PosHash.create 256 + +let add (builder : builder) (pos : Lexing.position) (decl : decl) = + PosHash.replace builder pos decl + +let find_opt_builder (builder : builder) pos = PosHash.find_opt builder pos + +let replace_builder (builder : builder) (pos : Lexing.position) (decl : decl) = + PosHash.replace builder pos decl + +let merge_all (builders : builder list) : t = + let result = PosHash.create 256 in + builders + |> List.iter (fun builder -> + PosHash.iter (fun pos decl -> PosHash.replace result pos decl) builder); + result + +(* ===== Read-only API ===== *) + +let find_opt (t : t) pos = PosHash.find_opt t pos + +let fold f (t : t) init = PosHash.fold f t init + +let iter f (t : t) = PosHash.iter f t diff --git a/analysis/reanalyze/src/Declarations.mli b/analysis/reanalyze/src/Declarations.mli new file mode 100644 index 0000000000..d498e08462 --- /dev/null +++ b/analysis/reanalyze/src/Declarations.mli @@ -0,0 +1,32 @@ +(** Declarations collected during dead code analysis. + + Two types are provided: + - [builder] - mutable, for AST processing + - [t] - immutable, for solver (read-only access) + + Only DceFileProcessing should use [builder]. + The solver uses [t] which is frozen/immutable. *) + +(** {2 Types} *) + +type t +(** Immutable declarations - for solver (read-only) *) + +type builder +(** Mutable builder - for AST processing *) + +(** {2 Builder API - for DceFileProcessing only} *) + +val create_builder : unit -> builder +val add : builder -> Lexing.position -> Common.decl -> unit +val find_opt_builder : builder -> Lexing.position -> Common.decl option +val replace_builder : builder -> Lexing.position -> Common.decl -> unit + +val merge_all : builder list -> t +(** Merge all builders into one immutable result. Order doesn't matter. *) + +(** {2 Read-only API for t - for solver} *) + +val find_opt : t -> Lexing.position -> Common.decl option +val fold : (Lexing.position -> Common.decl -> 'a -> 'a) -> t -> 'a -> 'a +val iter : (Lexing.position -> Common.decl -> unit) -> t -> unit diff --git a/analysis/reanalyze/src/Reanalyze.ml b/analysis/reanalyze/src/Reanalyze.ml index 96f0639592..23ec4301aa 100644 --- a/analysis/reanalyze/src/Reanalyze.ml +++ b/analysis/reanalyze/src/Reanalyze.ml @@ -1,8 +1,8 @@ open Common -(** Process a cmt file and return its annotations builder (if DCE enabled). +(** Process a cmt file and return its file_data (if DCE enabled). Conceptually: map over files, then merge results. *) -let loadCmtFile ~config cmtFilePath : FileAnnotations.builder option = +let loadCmtFile ~config cmtFilePath : DceFileProcessing.file_data option = let cmt_infos = Cmt_format.read_cmt cmtFilePath in let excludePath sourceFile = config.DceConfig.cli.exclude_paths @@ -43,8 +43,8 @@ let loadCmtFile ~config cmtFilePath : FileAnnotations.builder option = | true -> sourceFile |> Filename.basename | false -> sourceFile); FileReferences.addFile sourceFile; - (* Process file for DCE - return builder *) - let builder_opt = + (* Process file for DCE - return file_data *) + let file_data_opt = if config.DceConfig.run.dce then Some (cmt_infos @@ -56,18 +56,18 @@ let loadCmtFile ~config cmtFilePath : FileAnnotations.builder option = cmt_infos |> Exception.processCmt ~file:file_context; if config.DceConfig.run.termination then cmt_infos |> Arnold.processCmt ~config ~file:file_context; - builder_opt + file_data_opt | _ -> None -(** Process all cmt files and return list of annotation builders. +(** Process all cmt files and return list of file_data. Conceptually: map process_cmt_file over all files. *) -let processCmtFiles ~config ~cmtRoot : FileAnnotations.builder list = +let processCmtFiles ~config ~cmtRoot : DceFileProcessing.file_data list = let ( +++ ) = Filename.concat in (* Local mutable state for collecting results - does not escape this function *) - let builders = ref [] in + let file_data_list = ref [] in let processFile cmtFilePath = match loadCmtFile ~config cmtFilePath with - | Some builder -> builders := builder :: !builders + | Some file_data -> file_data_list := file_data :: !file_data_list | None -> () in (match cmtRoot with @@ -116,17 +116,25 @@ let processCmtFiles ~config ~cmtRoot : FileAnnotations.builder list = |> List.iter (fun cmtFile -> let cmtFilePath = Filename.concat libBsSourceDir cmtFile in processFile cmtFilePath))); - !builders + !file_data_list let runAnalysis ~dce_config ~cmtRoot = - (* Map: process each file -> list of builders *) - let builders = processCmtFiles ~config:dce_config ~cmtRoot in + (* Map: process each file -> list of file_data *) + let file_data_list = processCmtFiles ~config:dce_config ~cmtRoot in if dce_config.DceConfig.run.dce then ( DeadException.forceDelayedItems ~config:dce_config; - DeadOptionalArgs.forceDelayedItems (); - (* Merge: combine all builders -> immutable annotations *) - let annotations = FileAnnotations.merge_all builders in - DeadCommon.reportDead ~annotations ~config:dce_config + (* Merge: combine all builders -> immutable data *) + let annotations = + FileAnnotations.merge_all + (file_data_list |> List.map (fun fd -> fd.DceFileProcessing.annotations)) + in + let decls = + Declarations.merge_all + (file_data_list |> List.map (fun fd -> fd.DceFileProcessing.decls)) + in + (* Process delayed optional args with merged decls *) + DeadOptionalArgs.forceDelayedItems ~decls; + DeadCommon.reportDead ~annotations ~decls ~config:dce_config ~checkOptionalArg:DeadOptionalArgs.check; WriteDeadAnnotations.write ~config:dce_config); if dce_config.DceConfig.run.exception_ then