From c83fabd09ae40d3da424809c674d9b112fd6a74b Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 9 Dec 2025 06:34:37 +0100 Subject: [PATCH 1/2] DCE: Make OptionalArgs tracking immutable (Optional Task) OptionalArgs.t is now fully immutable with no mutation of declarations. Key changes: - OptionalArgs.t: removed mutable fields - apply_call: pure function, returns new state - combine_pair: pure function, returns pair of new states - OptionalArgsState module in Common.ml for computed state map - compute_optional_args_state: returns immutable OptionalArgsState.t - DeadOptionalArgs.check: looks up state from map Architecture: - Declaration's optionalArgs = initial state (what args exist) - OptionalArgsState.t = computed state (after all calls/combines) - Solver uses OptionalArgsState.find_opt to get final state This completes the pure analysis pipeline - no mutation anywhere. --- analysis/reanalyze/DEADCODE_REFACTOR_PLAN.md | 35 +++++------ analysis/reanalyze/src/Common.ml | 61 ++++++++++++++------ analysis/reanalyze/src/CrossFileItems.ml | 56 +++++++++++++----- analysis/reanalyze/src/CrossFileItems.mli | 8 ++- analysis/reanalyze/src/DeadCommon.ml | 5 +- analysis/reanalyze/src/DeadOptionalArgs.ml | 15 +++-- analysis/reanalyze/src/Reanalyze.ml | 9 ++- 7 files changed, 124 insertions(+), 65 deletions(-) diff --git a/analysis/reanalyze/DEADCODE_REFACTOR_PLAN.md b/analysis/reanalyze/DEADCODE_REFACTOR_PLAN.md index 00e4a12897..b25b90855f 100644 --- a/analysis/reanalyze/DEADCODE_REFACTOR_PLAN.md +++ b/analysis/reanalyze/DEADCODE_REFACTOR_PLAN.md @@ -613,32 +613,23 @@ add `@dead` annotations. ## Optional Future Tasks -### Optional Task: Make OptionalArgs tracking immutable +### Optional Task: Make OptionalArgs tracking immutable ✅ -**Value**: Currently `CrossFileItems.process_optional_args` mutates `optionalArgs` inside declarations. -Making this immutable would complete the pure pipeline. +**Value**: `OptionalArgs.t` is now fully immutable. No mutation of declarations. -**Current state**: -- `OptionalArgs.t` inside `decl.declKind = Value {optionalArgs}` is mutable -- `OptionalArgs.call` and `OptionalArgs.combine` mutate the record -- This happens after merge but before solver +**Changes made**: +- [x] Made `OptionalArgs.t` immutable (no mutable fields) +- [x] Added pure functions: `apply_call`, `combine_pair` +- [x] Created `OptionalArgsState` module in `Common.ml` for state map +- [x] `compute_optional_args_state` returns immutable state map +- [x] `DeadOptionalArgs.check` looks up state from map -**Why it's acceptable now**: -- Mutation happens in a well-defined phase (after merge, before solver) -- Solver sees effectively immutable data -- Order independence is maintained (calls accumulate, order doesn't matter) +**Architecture**: +- Declaration's `optionalArgs` = initial state (what args exist) +- `OptionalArgsState.t` = computed state (after all calls/combines) +- Solver uses `OptionalArgsState.find_opt` to get final state -**Changes needed**: -- [ ] Make `OptionalArgs.t` an immutable data structure -- [ ] Collect call info during AST processing as `OptionalArgCalls.builder` -- [ ] Return calls from `process_cmt_file` in `file_data` -- [ ] Merge all calls after file processing -- [ ] Build final `OptionalArgs` state from merged calls (pure) -- [ ] Store immutable `OptionalArgs` in declarations - -**Estimated effort**: Medium-High (touches core data structures) - -**Priority**: Low (current design works, just not fully pure) +**Status**: Complete ✅ --- diff --git a/analysis/reanalyze/src/Common.ml b/analysis/reanalyze/src/Common.ml index f158ff9fd1..01c57cc31f 100644 --- a/analysis/reanalyze/src/Common.ml +++ b/analysis/reanalyze/src/Common.ml @@ -99,11 +99,11 @@ module Path = struct end module OptionalArgs = struct - type t = { - mutable count: int; - mutable unused: StringSet.t; - mutable alwaysUsed: StringSet.t; - } + type t = {count: int; unused: StringSet.t; alwaysUsed: StringSet.t} + (** Immutable record tracking optional argument usage. + - unused: args that have never been passed + - alwaysUsed: args that are always passed (when count > 0) + - count: number of calls observed *) let empty = {unused = StringSet.empty; alwaysUsed = StringSet.empty; count = 0} @@ -113,23 +113,27 @@ module OptionalArgs = struct let isEmpty x = StringSet.is_empty x.unused - let call ~argNames ~argNamesMaybe x = + (** Apply a call to the optional args state. Returns new state. *) + let apply_call ~argNames ~argNamesMaybe x = let nameSet = argNames |> StringSet.of_list in let nameSetMaybe = argNamesMaybe |> StringSet.of_list in let nameSetAlways = StringSet.diff nameSet nameSetMaybe in - if x.count = 0 then x.alwaysUsed <- nameSetAlways - else x.alwaysUsed <- StringSet.inter nameSetAlways x.alwaysUsed; - argNames - |> List.iter (fun name -> x.unused <- StringSet.remove name x.unused); - x.count <- x.count + 1 - - let combine x y = + let alwaysUsed = + if x.count = 0 then nameSetAlways + else StringSet.inter nameSetAlways x.alwaysUsed + in + let unused = + argNames + |> List.fold_left (fun acc name -> StringSet.remove name acc) x.unused + in + {count = x.count + 1; unused; alwaysUsed} + + (** Combine two optional args states (for function references). + Returns a pair of updated states with intersected unused/alwaysUsed. *) + let combine_pair x y = let unused = StringSet.inter x.unused y.unused in - x.unused <- unused; - y.unused <- unused; let alwaysUsed = StringSet.inter x.alwaysUsed y.alwaysUsed in - x.alwaysUsed <- alwaysUsed; - y.alwaysUsed <- alwaysUsed + ({x with unused; alwaysUsed}, {y with unused; alwaysUsed}) let iterUnused f x = StringSet.iter f x.unused let iterAlwaysUsed f x = StringSet.iter (fun s -> f s x.count) x.alwaysUsed @@ -140,6 +144,29 @@ module OptionalArgs = struct StringSet.fold (fun s acc -> f s x.count acc) x.alwaysUsed init end +(* Position-keyed hashtable - shared across modules *) +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) + +(** State map for computed OptionalArgs. + Maps declaration position to final state after all calls/combines. *) +module OptionalArgsState = struct + type t = OptionalArgs.t PosHash.t + + let create () : t = PosHash.create 256 + + let find_opt (state : t) pos = PosHash.find_opt state pos + + let set (state : t) pos value = PosHash.replace state pos value +end + module DeclKind = struct type t = | Exception diff --git a/analysis/reanalyze/src/CrossFileItems.ml b/analysis/reanalyze/src/CrossFileItems.ml index f886262fce..1ed6faf027 100644 --- a/analysis/reanalyze/src/CrossFileItems.ml +++ b/analysis/reanalyze/src/CrossFileItems.ml @@ -5,6 +5,17 @@ open Common +(* Position-keyed hashtable *) +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) + (** {2 Item types} *) type exception_ref = {exception_path: Path.t; loc_from: Location.t} @@ -70,24 +81,39 @@ let process_exception_refs (t : t) ~refs ~file_deps ~find_exception ~config = ~binding:Location.none ~addFileReference:true ~locFrom:loc_from ~locTo:loc_to) -let process_optional_args (t : t) ~decls = +(** Compute optional args state from calls and function references. + Returns a map from position to final OptionalArgs.t state. + Pure function - does not mutate declarations. *) +let compute_optional_args_state (t : t) ~decls : OptionalArgsState.t = + let state = OptionalArgsState.create () in + (* Initialize state from declarations *) + let get_state pos = + match OptionalArgsState.find_opt state pos with + | Some s -> s + | None -> ( + match Declarations.find_opt decls pos with + | Some {declKind = Value {optionalArgs}} -> optionalArgs + | _ -> OptionalArgs.empty) + in + let set_state pos s = OptionalArgsState.set state pos s in (* Process optional arg calls *) t.optional_arg_calls |> List.iter (fun {pos_to; arg_names; arg_names_maybe} -> - match Declarations.find_opt decls pos_to with - | Some {declKind = Value r} -> - r.optionalArgs - |> OptionalArgs.call ~argNames:arg_names - ~argNamesMaybe:arg_names_maybe - | _ -> ()); + let current = get_state pos_to in + let updated = + OptionalArgs.apply_call ~argNames:arg_names + ~argNamesMaybe:arg_names_maybe current + in + set_state pos_to updated); (* Process function references *) t.function_refs |> List.iter (fun {pos_from; pos_to} -> - match - ( Declarations.find_opt decls pos_from, - Declarations.find_opt decls pos_to ) - with - | Some {declKind = Value rFrom}, Some {declKind = Value rTo} - when not (OptionalArgs.isEmpty rTo.optionalArgs) -> - OptionalArgs.combine rFrom.optionalArgs rTo.optionalArgs - | _ -> ()) + let state_from = get_state pos_from in + let state_to = get_state pos_to in + if not (OptionalArgs.isEmpty state_to) then ( + let updated_from, updated_to = + OptionalArgs.combine_pair state_from state_to + in + set_state pos_from updated_from; + set_state pos_to updated_to)); + state diff --git a/analysis/reanalyze/src/CrossFileItems.mli b/analysis/reanalyze/src/CrossFileItems.mli index 1ae0456497..71d1dca6ce 100644 --- a/analysis/reanalyze/src/CrossFileItems.mli +++ b/analysis/reanalyze/src/CrossFileItems.mli @@ -49,5 +49,9 @@ val process_exception_refs : unit (** Process cross-file exception references. *) -val process_optional_args : t -> decls:Declarations.t -> unit -(** Process cross-file optional argument calls and function references. *) +(** {2 Optional Args State} *) + +val compute_optional_args_state : + t -> decls:Declarations.t -> Common.OptionalArgsState.t +(** Compute final optional args state from calls and function references. + Pure function - does not mutate declarations. *) diff --git a/analysis/reanalyze/src/DeadCommon.ml b/analysis/reanalyze/src/DeadCommon.ml index 3b0041cb34..8cbbf82e89 100644 --- a/analysis/reanalyze/src/DeadCommon.ml +++ b/analysis/reanalyze/src/DeadCommon.ml @@ -430,9 +430,10 @@ let rec resolveRecursiveRefs ~all_refs ~annotations ~config ~decls refsString level); isDead -let reportDead ~annotations ~config ~decls ~refs ~file_deps +let reportDead ~annotations ~config ~decls ~refs ~file_deps ~optional_args_state ~checkOptionalArg: (checkOptionalArgFn : + optional_args_state:OptionalArgsState.t -> annotations:FileAnnotations.t -> config:DceConfig.t -> decl -> @@ -444,7 +445,7 @@ let reportDead ~annotations ~config ~decls ~refs ~file_deps | false -> References.find_type_refs refs decl.pos in resolveRecursiveRefs ~all_refs:refs ~annotations ~config ~decls - ~checkOptionalArg:(checkOptionalArgFn ~annotations) + ~checkOptionalArg:(checkOptionalArgFn ~optional_args_state ~annotations) ~deadDeclarations ~issues ~level:0 ~orderedFiles ~refsBeingResolved:(ref PosSet.empty) ~refs:decl_refs decl |> ignore diff --git a/analysis/reanalyze/src/DeadOptionalArgs.ml b/analysis/reanalyze/src/DeadOptionalArgs.ml index 8d8585d5b3..48354f92b9 100644 --- a/analysis/reanalyze/src/DeadOptionalArgs.ml +++ b/analysis/reanalyze/src/DeadOptionalArgs.ml @@ -56,14 +56,21 @@ let addReferences ~config ~cross_file ~(locFrom : Location.t) (argNamesMaybe |> String.concat ", ") (posFrom |> posToString)) -(** Check for optional args issues. Returns issues instead of logging. *) -let check ~annotations ~config:_ decl : Common.issue list = +(** Check for optional args issues. Returns issues instead of logging. + Uses optional_args_state map for final computed state. *) +let check ~optional_args_state ~annotations ~config:_ decl : Common.issue list = match decl with | {declKind = Value {optionalArgs}} when active () && not (FileAnnotations.is_annotated_gentype_or_live annotations decl.pos) -> + (* Look up computed state from map, fall back to declaration's initial state *) + let state = + match OptionalArgsState.find_opt optional_args_state decl.pos with + | Some s -> s + | None -> optionalArgs + in let loc = decl |> declGetLoc in let unused_issues = OptionalArgs.foldUnused @@ -87,7 +94,7 @@ let check ~annotations ~config:_ decl : Common.issue list = } in issue :: acc) - optionalArgs [] + state [] in let redundant_issues = OptionalArgs.foldAlwaysUsed @@ -112,7 +119,7 @@ let check ~annotations ~config:_ decl : Common.issue list = } in issue :: acc) - optionalArgs [] + state [] in (* Reverse to maintain original order from iterUnused/iterAlwaysUsed *) List.rev unused_issues @ List.rev redundant_issues diff --git a/analysis/reanalyze/src/Reanalyze.ml b/analysis/reanalyze/src/Reanalyze.ml index 5099ab4541..7358a72c3f 100644 --- a/analysis/reanalyze/src/Reanalyze.ml +++ b/analysis/reanalyze/src/Reanalyze.ml @@ -147,15 +147,18 @@ let runAnalysis ~dce_config ~cmtRoot = CrossFileItems.process_exception_refs cross_file ~refs:refs_builder ~file_deps:file_deps_builder ~find_exception:DeadException.find_exception ~config:dce_config; - (* Process cross-file optional args - they read decls *) - CrossFileItems.process_optional_args cross_file ~decls; + (* Compute optional args state (pure - no mutation) *) + let optional_args_state = + CrossFileItems.compute_optional_args_state cross_file ~decls + in (* Now freeze refs and file_deps for solver *) let refs = References.freeze_builder refs_builder in let file_deps = FileDeps.freeze_builder file_deps_builder in (* Run the solver - returns immutable AnalysisResult.t *) let analysis_result = DeadCommon.reportDead ~annotations ~decls ~refs ~file_deps - ~config:dce_config ~checkOptionalArg:DeadOptionalArgs.check + ~optional_args_state ~config:dce_config + ~checkOptionalArg:DeadOptionalArgs.check in (* Report all issues *) AnalysisResult.get_issues analysis_result From e9d22747623ccd80b30f9d5204c0e9f915d0800b Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 9 Dec 2025 07:35:14 +0100 Subject: [PATCH 2/2] refactor(reanalyze): remove Common.ml kitchen sink module Extract focused modules from Common.ml: - Cli.ml: CLI option refs - Pos.ml: Position utilities - PosSet.ml, PosHash.ml: Position collections - StringSet.ml, FileSet.ml, FileHash.ml: String/file collections - DcePath.ml: Dead code path type (renamed from Path to avoid shadowing) - Decl.ml: Declaration types (Kind, t, posAdjustment) - Issue.ml: Issue types (severity, deadWarning, description, etc.) - LocSet.ml: Location set - OptionalArgs.ml, OptionalArgsState.ml: Optional args tracking This eliminates the Common.ml 'kitchen sink' that was causing: - Circular dependency issues - Poor code organization - Difficulty understanding module boundaries Each module now has a single responsibility. Signed-Off-By: Cristiano Calcagno --- analysis/reanalyze/src/AnalysisResult.ml | 14 +- analysis/reanalyze/src/AnalysisResult.mli | 14 +- analysis/reanalyze/src/Cli.ml | 20 ++ analysis/reanalyze/src/Common.ml | 248 ---------------- analysis/reanalyze/src/CrossFileItems.ml | 15 +- analysis/reanalyze/src/CrossFileItems.mli | 6 +- analysis/reanalyze/src/DceConfig.ml | 16 +- analysis/reanalyze/src/DcePath.ml | 48 +++ analysis/reanalyze/src/DeadCommon.ml | 314 +++++++------------- analysis/reanalyze/src/DeadException.ml | 3 +- analysis/reanalyze/src/DeadModules.ml | 7 +- analysis/reanalyze/src/DeadOptionalArgs.ml | 19 +- analysis/reanalyze/src/DeadType.ml | 21 +- analysis/reanalyze/src/DeadValue.ml | 11 +- analysis/reanalyze/src/Decl.ml | 81 +++++ analysis/reanalyze/src/Declarations.ml | 22 +- analysis/reanalyze/src/Declarations.mli | 12 +- analysis/reanalyze/src/Exception.ml | 42 ++- analysis/reanalyze/src/Exceptions.ml | 6 +- analysis/reanalyze/src/ExnLib.ml | 4 +- analysis/reanalyze/src/FileAnnotations.ml | 11 - analysis/reanalyze/src/FileDeps.ml | 2 - analysis/reanalyze/src/FileDeps.mli | 2 - analysis/reanalyze/src/FileHash.ml | 8 + analysis/reanalyze/src/FileSet.ml | 3 + analysis/reanalyze/src/FindSourceFile.ml | 4 +- analysis/reanalyze/src/Issue.ml | 45 +++ analysis/reanalyze/src/LocSet.ml | 5 + analysis/reanalyze/src/Log_.ml | 20 +- analysis/reanalyze/src/ModulePath.ml | 14 +- analysis/reanalyze/src/OptionalArgs.ml | 45 +++ analysis/reanalyze/src/OptionalArgsState.ml | 10 + analysis/reanalyze/src/Paths.ml | 3 +- analysis/reanalyze/src/Pos.ml | 9 + analysis/reanalyze/src/PosHash.ml | 12 + analysis/reanalyze/src/PosSet.ml | 8 + analysis/reanalyze/src/Reanalyze.ml | 18 +- analysis/reanalyze/src/References.ml | 18 -- analysis/reanalyze/src/References.mli | 4 - analysis/reanalyze/src/SideEffects.ml | 2 +- analysis/reanalyze/src/StringSet.ml | 3 + analysis/reanalyze/src/Suppress.ml | 2 +- 42 files changed, 527 insertions(+), 644 deletions(-) create mode 100644 analysis/reanalyze/src/Cli.ml delete mode 100644 analysis/reanalyze/src/Common.ml create mode 100644 analysis/reanalyze/src/DcePath.ml create mode 100644 analysis/reanalyze/src/Decl.ml create mode 100644 analysis/reanalyze/src/FileHash.ml create mode 100644 analysis/reanalyze/src/FileSet.ml create mode 100644 analysis/reanalyze/src/Issue.ml create mode 100644 analysis/reanalyze/src/LocSet.ml create mode 100644 analysis/reanalyze/src/OptionalArgs.ml create mode 100644 analysis/reanalyze/src/OptionalArgsState.ml create mode 100644 analysis/reanalyze/src/Pos.ml create mode 100644 analysis/reanalyze/src/PosHash.ml create mode 100644 analysis/reanalyze/src/PosSet.ml create mode 100644 analysis/reanalyze/src/StringSet.ml diff --git a/analysis/reanalyze/src/AnalysisResult.ml b/analysis/reanalyze/src/AnalysisResult.ml index c46df48f07..dd145b4c4b 100644 --- a/analysis/reanalyze/src/AnalysisResult.ml +++ b/analysis/reanalyze/src/AnalysisResult.ml @@ -3,9 +3,7 @@ The solver returns this instead of logging directly. All side effects (logging, JSON output) happen in the reporting phase. *) -open Common - -type t = {issues: issue list} +type t = {issues: Issue.t list} (** Immutable analysis result *) let empty = {issues = []} @@ -20,11 +18,11 @@ let get_issues result = result.issues |> List.rev let issue_count result = List.length result.issues (** Create a dead code issue *) -let make_dead_issue ~loc ~deadWarning ~path ~message = +let make_dead_issue ~loc ~deadWarning ~path ~message : Issue.t = { - name = + Issue.name = (match deadWarning with - | WarningDeadException -> "Warning Dead Exception" + | Issue.WarningDeadException -> "Warning Dead Exception" | WarningDeadType -> "Warning Dead Type" | WarningDeadValue -> "Warning Dead Value" | WarningDeadValueWithSideEffects -> @@ -36,9 +34,9 @@ let make_dead_issue ~loc ~deadWarning ~path ~message = } (** Create a dead module issue *) -let make_dead_module_issue ~loc ~moduleName = +let make_dead_module_issue ~loc ~moduleName : Issue.t = { - name = "Warning Dead Module"; + Issue.name = "Warning Dead Module"; severity = Warning; loc; description = diff --git a/analysis/reanalyze/src/AnalysisResult.mli b/analysis/reanalyze/src/AnalysisResult.mli index 15f85af628..beee4e4d4e 100644 --- a/analysis/reanalyze/src/AnalysisResult.mli +++ b/analysis/reanalyze/src/AnalysisResult.mli @@ -3,21 +3,19 @@ The solver returns this instead of logging directly. All side effects (logging, JSON output) happen in the reporting phase. *) -open Common - type t (** Immutable analysis result *) val empty : t (** Empty result with no issues *) -val add_issue : t -> issue -> t +val add_issue : t -> Issue.t -> t (** Add a single issue to the result *) -val add_issues : t -> issue list -> t +val add_issues : t -> Issue.t list -> t (** Add multiple issues to the result *) -val get_issues : t -> issue list +val get_issues : t -> Issue.t list (** Get all issues in order they were added *) val issue_count : t -> int @@ -27,11 +25,11 @@ val issue_count : t -> int val make_dead_issue : loc:Location.t -> - deadWarning:deadWarning -> + deadWarning:Issue.deadWarning -> path:string -> message:string -> - issue + Issue.t (** Create a dead code warning issue *) -val make_dead_module_issue : loc:Location.t -> moduleName:Name.t -> issue +val make_dead_module_issue : loc:Location.t -> moduleName:Name.t -> Issue.t (** Create a dead module warning issue *) diff --git a/analysis/reanalyze/src/Cli.ml b/analysis/reanalyze/src/Cli.ml new file mode 100644 index 0000000000..5cc8eddbc3 --- /dev/null +++ b/analysis/reanalyze/src/Cli.ml @@ -0,0 +1,20 @@ +(** Command-line interface options for reanalyze. + These refs are set by argument parsing in Reanalyze.ml *) + +let debug = ref false +let ci = ref false + +(** The command was a -cmt variant (e.g. -exception-cmt) *) +let cmtCommand = ref false + +let experimental = ref false +let json = ref false + +(* names to be considered live values *) +let liveNames = ref ([] : string list) + +(* paths of files where all values are considered live *) +let livePaths = ref ([] : string list) + +(* paths of files to exclude from analysis *) +let excludePaths = ref ([] : string list) diff --git a/analysis/reanalyze/src/Common.ml b/analysis/reanalyze/src/Common.ml deleted file mode 100644 index 01c57cc31f..0000000000 --- a/analysis/reanalyze/src/Common.ml +++ /dev/null @@ -1,248 +0,0 @@ -let runConfig = RunConfig.runConfig - -(* Location printer: `filename:line: ' *) -let posToString (pos : Lexing.position) = - let file = pos.Lexing.pos_fname in - let line = pos.Lexing.pos_lnum in - let col = pos.Lexing.pos_cnum - pos.Lexing.pos_bol in - (file |> Filename.basename) - ^ ":" ^ string_of_int line ^ ":" ^ string_of_int col - -module Cli = struct - let debug = ref false - let ci = ref false - - (** The command was a -cmt variant (e.g. -exception-cmt) *) - let cmtCommand = ref false - - let experimental = ref false - let json = ref false - - (* names to be considered live values *) - let liveNames = ref ([] : string list) - - (* paths of files where all values are considered live *) - - let livePaths = ref ([] : string list) - - (* paths of files to exclude from analysis *) - let excludePaths = ref ([] : string list) -end - -module StringSet = Set.Make (String) - -module LocSet = Set.Make (struct - include Location - - let compare = compare -end) - -module FileSet = Set.Make (String) - -module FileHash = struct - include Hashtbl.Make (struct - type t = string - - let hash (x : t) = Hashtbl.hash x - let equal (x : t) y = x = y - end) -end - -(* NOTE: FileReferences has been moved to FileDeps module *) - -module Path = struct - type t = Name.t list - - let toName (path : t) = - path |> List.rev_map Name.toString |> String.concat "." |> Name.create - - let toString path = path |> toName |> Name.toString - - let withoutHead path = - match - path |> List.rev_map (fun n -> n |> Name.toInterface |> Name.toString) - with - | _ :: tl -> tl |> String.concat "." - | [] -> "" - - let onOkPath ~whenContainsApply ~f path = - match path |> Path.flatten with - | `Ok (id, mods) -> f (Ident.name id :: mods |> String.concat ".") - | `Contains_apply -> whenContainsApply - - let fromPathT path = - match path |> Path.flatten with - | `Ok (id, mods) -> Ident.name id :: mods |> List.rev_map Name.create - | `Contains_apply -> [] - - let moduleToImplementation path = - match path |> List.rev with - | moduleName :: rest -> - (moduleName |> Name.toImplementation) :: rest |> List.rev - | [] -> path - - let moduleToInterface path = - match path |> List.rev with - | moduleName :: rest -> (moduleName |> Name.toInterface) :: rest |> List.rev - | [] -> path - - let toModuleName ~isType path = - match path with - | _ :: tl when not isType -> tl |> toName - | _ :: _ :: tl when isType -> tl |> toName - | _ -> "" |> Name.create - - let typeToInterface path = - match path with - | typeName :: rest -> (typeName |> Name.toInterface) :: rest - | [] -> path -end - -module OptionalArgs = struct - type t = {count: int; unused: StringSet.t; alwaysUsed: StringSet.t} - (** Immutable record tracking optional argument usage. - - unused: args that have never been passed - - alwaysUsed: args that are always passed (when count > 0) - - count: number of calls observed *) - - let empty = - {unused = StringSet.empty; alwaysUsed = StringSet.empty; count = 0} - - let fromList l = - {unused = StringSet.of_list l; alwaysUsed = StringSet.empty; count = 0} - - let isEmpty x = StringSet.is_empty x.unused - - (** Apply a call to the optional args state. Returns new state. *) - let apply_call ~argNames ~argNamesMaybe x = - let nameSet = argNames |> StringSet.of_list in - let nameSetMaybe = argNamesMaybe |> StringSet.of_list in - let nameSetAlways = StringSet.diff nameSet nameSetMaybe in - let alwaysUsed = - if x.count = 0 then nameSetAlways - else StringSet.inter nameSetAlways x.alwaysUsed - in - let unused = - argNames - |> List.fold_left (fun acc name -> StringSet.remove name acc) x.unused - in - {count = x.count + 1; unused; alwaysUsed} - - (** Combine two optional args states (for function references). - Returns a pair of updated states with intersected unused/alwaysUsed. *) - let combine_pair x y = - let unused = StringSet.inter x.unused y.unused in - let alwaysUsed = StringSet.inter x.alwaysUsed y.alwaysUsed in - ({x with unused; alwaysUsed}, {y with unused; alwaysUsed}) - - let iterUnused f x = StringSet.iter f x.unused - let iterAlwaysUsed f x = StringSet.iter (fun s -> f s x.count) x.alwaysUsed - - let foldUnused f x init = StringSet.fold f x.unused init - - let foldAlwaysUsed f x init = - StringSet.fold (fun s acc -> f s x.count acc) x.alwaysUsed init -end - -(* Position-keyed hashtable - shared across modules *) -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) - -(** State map for computed OptionalArgs. - Maps declaration position to final state after all calls/combines. *) -module OptionalArgsState = struct - type t = OptionalArgs.t PosHash.t - - let create () : t = PosHash.create 256 - - let find_opt (state : t) pos = PosHash.find_opt state pos - - let set (state : t) pos value = PosHash.replace state pos value -end - -module DeclKind = struct - type t = - | Exception - | RecordLabel - | VariantCase - | Value of { - isToplevel: bool; - mutable optionalArgs: OptionalArgs.t; - sideEffects: bool; - } - - let isType dk = - match dk with - | RecordLabel | VariantCase -> true - | Exception | Value _ -> false - - let toString dk = - match dk with - | Exception -> "Exception" - | RecordLabel -> "RecordLabel" - | VariantCase -> "VariantCase" - | Value _ -> "Value" -end - -type posAdjustment = FirstVariant | OtherVariant | Nothing - -type decl = { - declKind: DeclKind.t; - moduleLoc: Location.t; - posAdjustment: posAdjustment; - path: Path.t; - pos: Lexing.position; - posEnd: Lexing.position; - posStart: Lexing.position; - mutable resolvedDead: bool option; - mutable report: bool; -} - -module ExnSet = Set.Make (Exn) - -type missingThrowInfo = { - exnName: string; - exnTable: (Exn.t, LocSet.t) Hashtbl.t; - locFull: Location.t; - missingAnnotations: ExnSet.t; - throwSet: ExnSet.t; -} - -type severity = Warning | Error -type deadOptional = WarningUnusedArgument | WarningRedundantOptionalArgument - -type termination = - | ErrorHygiene - | ErrorNotImplemented - | ErrorTermination - | TerminationAnalysisInternal - -type deadWarning = - | WarningDeadException - | WarningDeadType - | WarningDeadValue - | WarningDeadValueWithSideEffects - | IncorrectDeadAnnotation - -type description = - | Circular of {message: string} - | ExceptionAnalysis of {message: string} - | ExceptionAnalysisMissing of missingThrowInfo - | DeadModule of {message: string} - | DeadOptional of {deadOptional: deadOptional; message: string} - | DeadWarning of {deadWarning: deadWarning; path: string; message: string} - | Termination of {termination: termination; message: string} - -type issue = { - name: string; - severity: severity; - loc: Location.t; - description: description; -} diff --git a/analysis/reanalyze/src/CrossFileItems.ml b/analysis/reanalyze/src/CrossFileItems.ml index 1ed6faf027..c7c5f5504a 100644 --- a/analysis/reanalyze/src/CrossFileItems.ml +++ b/analysis/reanalyze/src/CrossFileItems.ml @@ -3,22 +3,9 @@ These are references that span file boundaries and need to be resolved after all files are processed. *) -open Common - -(* Position-keyed hashtable *) -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) - (** {2 Item types} *) -type exception_ref = {exception_path: Path.t; loc_from: Location.t} +type exception_ref = {exception_path: DcePath.t; loc_from: Location.t} type optional_arg_call = { pos_to: Lexing.position; diff --git a/analysis/reanalyze/src/CrossFileItems.mli b/analysis/reanalyze/src/CrossFileItems.mli index 71d1dca6ce..34620b6917 100644 --- a/analysis/reanalyze/src/CrossFileItems.mli +++ b/analysis/reanalyze/src/CrossFileItems.mli @@ -18,7 +18,7 @@ type builder val create_builder : unit -> builder val add_exception_ref : - builder -> exception_path:Common.Path.t -> loc_from:Location.t -> unit + builder -> exception_path:DcePath.t -> loc_from:Location.t -> unit (** Add a cross-file exception reference (defined in another file). *) val add_optional_arg_call : @@ -44,7 +44,7 @@ val process_exception_refs : t -> refs:References.builder -> file_deps:FileDeps.builder -> - find_exception:(Common.Path.t -> Location.t option) -> + find_exception:(DcePath.t -> Location.t option) -> config:DceConfig.t -> unit (** Process cross-file exception references. *) @@ -52,6 +52,6 @@ val process_exception_refs : (** {2 Optional Args State} *) val compute_optional_args_state : - t -> decls:Declarations.t -> Common.OptionalArgsState.t + t -> decls:Declarations.t -> OptionalArgsState.t (** Compute final optional args state from calls and function references. Pure function - does not mutate declarations. *) diff --git a/analysis/reanalyze/src/DceConfig.ml b/analysis/reanalyze/src/DceConfig.ml index 1f4f9ebb32..ce7a074061 100644 --- a/analysis/reanalyze/src/DceConfig.ml +++ b/analysis/reanalyze/src/DceConfig.ml @@ -16,17 +16,17 @@ type t = {run: RunConfig.t; cli: cli_config} (** Capture the current DCE configuration from global state. - This reads from [RunConfig.runConfig] and [Common.Cli] refs + This reads from [RunConfig.runConfig] and [Cli] refs to produce a single immutable configuration value. *) let current () = let cli = { - debug = !Common.Cli.debug; - ci = !Common.Cli.ci; - json = !Common.Cli.json; - live_names = !Common.Cli.liveNames; - live_paths = !Common.Cli.livePaths; - exclude_paths = !Common.Cli.excludePaths; + debug = !Cli.debug; + ci = !Cli.ci; + json = !Cli.json; + live_names = !Cli.liveNames; + live_paths = !Cli.livePaths; + exclude_paths = !Cli.excludePaths; } in - {run = Common.runConfig; cli} + {run = RunConfig.runConfig; cli} diff --git a/analysis/reanalyze/src/DcePath.ml b/analysis/reanalyze/src/DcePath.ml new file mode 100644 index 0000000000..5d73e9ff04 --- /dev/null +++ b/analysis/reanalyze/src/DcePath.ml @@ -0,0 +1,48 @@ +(** Path representation for dead code analysis. + A path is a list of names, e.g. [MyModule; myFunction] *) + +type t = Name.t list + +let toName (path : t) = + path |> List.rev_map Name.toString |> String.concat "." |> Name.create + +let toString path = path |> toName |> Name.toString + +let withoutHead path = + match + path |> List.rev_map (fun n -> n |> Name.toInterface |> Name.toString) + with + | _ :: tl -> tl |> String.concat "." + | [] -> "" + +let onOkPath ~whenContainsApply ~f path = + match path |> Path.flatten with + | `Ok (id, mods) -> f (Ident.name id :: mods |> String.concat ".") + | `Contains_apply -> whenContainsApply + +let fromPathT path = + match path |> Path.flatten with + | `Ok (id, mods) -> Ident.name id :: mods |> List.rev_map Name.create + | `Contains_apply -> [] + +let moduleToImplementation path = + match path |> List.rev with + | moduleName :: rest -> + (moduleName |> Name.toImplementation) :: rest |> List.rev + | [] -> path + +let moduleToInterface path = + match path |> List.rev with + | moduleName :: rest -> (moduleName |> Name.toInterface) :: rest |> List.rev + | [] -> path + +let toModuleName ~isType path = + match path with + | _ :: tl when not isType -> tl |> toName + | _ :: _ :: tl when isType -> tl |> toName + | _ -> "" |> Name.create + +let typeToInterface path = + match path with + | typeName :: rest -> (typeName |> Name.toInterface) :: rest + | [] -> path diff --git a/analysis/reanalyze/src/DeadCommon.ml b/analysis/reanalyze/src/DeadCommon.ml index 8cbbf82e89..b74f5a062b 100644 --- a/analysis/reanalyze/src/DeadCommon.ml +++ b/analysis/reanalyze/src/DeadCommon.ml @@ -8,14 +8,6 @@ end (* Adapted from https://github.com/LexiFi/dead_code_analyzer *) -open Common - -module PosSet = Set.Make (struct - type t = Lexing.position - - let compare = compare -end) - module Config = struct (* Turn on type analysis *) let analyzeTypes = ref true @@ -37,25 +29,14 @@ let fileIsImplementationOf s1 s2 = let liveAnnotation = "live" -module PosHash = struct - include 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) +(* Helper functions for PosHash with PosSet values *) +let posHashFindSet h k = try PosHash.find h k with Not_found -> PosSet.empty - let equal (x : t) y = x = y - end) +let posHashAddSet h k v = + let set = posHashFindSet h k in + PosHash.replace h k (PosSet.add v set) - let findSet h k = try find h k with Not_found -> PosSet.empty - - let addSet h k v = - let set = findSet h k in - replace h k (PosSet.add v set) -end - -type decls = decl PosHash.t +type decls = Decl.t PosHash.t (** type alias for declaration hashtables *) (* NOTE: Global decls removed - now using Declarations.builder/t pattern *) @@ -78,7 +59,7 @@ end let declGetLoc decl = let loc_start = let offset = - match decl.posAdjustment with + match decl.Decl.posAdjustment with | FirstVariant | Nothing -> 0 | OtherVariant -> 2 in @@ -95,8 +76,8 @@ let addValueReference ~config ~refs ~file_deps ~(binding : Location.t) if not effectiveFrom.loc_ghost then ( if config.DceConfig.cli.debug then Log_.item "addValueReference %s --> %s@." - (effectiveFrom.loc_start |> posToString) - (locTo.loc_start |> posToString); + (effectiveFrom.loc_start |> Pos.toString) + (locTo.loc_start |> Pos.toString); References.add_value_ref refs ~posTo:locTo.loc_start ~posFrom:effectiveFrom.loc_start; if @@ -113,8 +94,8 @@ let iterFilesFromRootsToLeaves ~file_deps iterFun = FileDeps.iter_files_from_roots_to_leaves file_deps iterFun let addDeclaration_ ~config ~decls ~(file : FileContext.t) ?posEnd ?posStart - ~declKind ~path ~(loc : Location.t) ?(posAdjustment = Nothing) ~moduleLoc - (name : Name.t) = + ~declKind ~path ~(loc : Location.t) ?(posAdjustment = Decl.Nothing) + ~moduleLoc (name : Name.t) = let pos = loc.loc_start in let posStart = match posStart with @@ -134,11 +115,11 @@ let addDeclaration_ ~config ~decls ~(file : FileContext.t) ?posEnd ?posStart if (not loc.loc_ghost) && pos.pos_fname = file.source_path then ( if config.DceConfig.cli.debug then Log_.item "add%sDeclaration %s %s path:%s@." - (declKind |> DeclKind.toString) - (name |> Name.toString) (pos |> posToString) (path |> Path.toString); + (declKind |> Decl.Kind.toString) + (name |> Name.toString) (pos |> Pos.toString) (path |> DcePath.toString); let decl = { - declKind; + Decl.declKind; moduleLoc; posAdjustment; path = name :: path; @@ -160,218 +141,149 @@ let addValueDeclaration ~config ~decls ~file ?(isToplevel = true) ~loc ~moduleLoc ~path (** Create a dead code issue. Pure - no side effects. *) -let makeDeadIssue ~decl ~message deadWarning : Common.issue = +let makeDeadIssue ~decl ~message deadWarning : Issue.t = let loc = decl |> declGetLoc in AnalysisResult.make_dead_issue ~loc ~deadWarning - ~path:(Path.withoutHead decl.path) + ~path:(DcePath.withoutHead decl.path) ~message -module Decl = struct - let isValue decl = - match decl.declKind with - | Value _ (* | Exception *) -> true - | _ -> false - - let isToplevelValueWithSideEffects decl = - match decl.declKind with - | Value {isToplevel; sideEffects} -> isToplevel && sideEffects - | _ -> false - - let compareUsingDependencies ~orderedFiles - { - declKind = kind1; - path = _path1; - pos = - { - pos_fname = fname1; - pos_lnum = lnum1; - pos_bol = bol1; - pos_cnum = cnum1; - }; - } - { - declKind = kind2; - path = _path2; - pos = - { - pos_fname = fname2; - pos_lnum = lnum2; - pos_bol = bol2; - pos_cnum = cnum2; - }; - } = - let findPosition fn = Hashtbl.find orderedFiles fn [@@raises Not_found] in - (* From the root of the file dependency DAG to the leaves. - From the bottom of the file to the top. *) - let position1, position2 = - try (fname1 |> findPosition, fname2 |> findPosition) - with Not_found -> (0, 0) - in - compare - (position1, lnum2, bol2, cnum2, kind1) - (position2, lnum1, bol1, cnum1, kind2) - - let compareForReporting - { - declKind = kind1; - pos = - { - pos_fname = fname1; - pos_lnum = lnum1; - pos_bol = bol1; - pos_cnum = cnum1; - }; - } - { - declKind = kind2; - pos = - { - pos_fname = fname2; - pos_lnum = lnum2; - pos_bol = bol2; - pos_cnum = cnum2; - }; - } = - compare - (fname1, lnum1, bol1, cnum1, kind1) - (fname2, lnum2, bol2, cnum2, kind2) - - let isInsideReportedValue (ctx : ReportingContext.t) decl = - let max_end = ReportingContext.get_max_end ctx in - let fileHasChanged = max_end.pos_fname <> decl.pos.pos_fname in - let insideReportedValue = - decl |> isValue && (not fileHasChanged) - && max_end.pos_cnum > decl.pos.pos_cnum - in - if not insideReportedValue then - if decl |> isValue then - if fileHasChanged || decl.posEnd.pos_cnum > max_end.pos_cnum then - ReportingContext.set_max_end ctx decl.posEnd; - insideReportedValue +let isInsideReportedValue (ctx : ReportingContext.t) decl = + let max_end = ReportingContext.get_max_end ctx in + let fileHasChanged = max_end.pos_fname <> decl.Decl.pos.pos_fname in + let insideReportedValue = + decl |> Decl.isValue && (not fileHasChanged) + && max_end.pos_cnum > decl.pos.pos_cnum + in + if not insideReportedValue then + if decl |> Decl.isValue then + if fileHasChanged || decl.posEnd.pos_cnum > max_end.pos_cnum then + ReportingContext.set_max_end ctx decl.posEnd; + insideReportedValue - (** Report a dead declaration. Returns list of issues (dead module first, then dead value). +(** Report a dead declaration. Returns list of issues (dead module first, then dead value). Caller is responsible for logging. *) - let report ~config ~refs (ctx : ReportingContext.t) decl : Common.issue list = - let insideReportedValue = decl |> isInsideReportedValue ctx in - if not decl.report then [] - else - let deadWarning, message = - match decl.declKind with - | Exception -> - (WarningDeadException, "is never raised or passed as value") - | Value {sideEffects} -> ( - let noSideEffectsOrUnderscore = - (not sideEffects) - || - match decl.path with - | hd :: _ -> hd |> Name.startsWithUnderscore - | [] -> false - in - ( (match not noSideEffectsOrUnderscore with - | true -> WarningDeadValueWithSideEffects - | false -> WarningDeadValue), - match decl.path with - | name :: _ when name |> Name.isUnderscore -> - "has no side effects and can be removed" - | _ -> ( - "is never used" - ^ - match not noSideEffectsOrUnderscore with - | true -> " and could have side effects" - | false -> "") )) - | RecordLabel -> - (WarningDeadType, "is a record label never used to read a value") - | VariantCase -> - (WarningDeadType, "is a variant case which is never constructed") - in - let hasRefBelow () = - let decl_refs = References.find_value_refs refs decl.pos in - let refIsBelow (pos : Lexing.position) = - decl.pos.pos_fname <> pos.pos_fname - || decl.pos.pos_cnum < pos.pos_cnum - && - (* not a function defined inside a function, e.g. not a callback *) - decl.posEnd.pos_cnum < pos.pos_cnum +let reportDeclaration ~config ~refs (ctx : ReportingContext.t) decl : + Issue.t list = + let insideReportedValue = decl |> isInsideReportedValue ctx in + if not decl.report then [] + else + let deadWarning, message = + match decl.declKind with + | Exception -> + (Issue.WarningDeadException, "is never raised or passed as value") + | Value {sideEffects} -> ( + let noSideEffectsOrUnderscore = + (not sideEffects) + || + match decl.path with + | hd :: _ -> hd |> Name.startsWithUnderscore + | [] -> false in - decl_refs |> References.PosSet.exists refIsBelow + ( (match not noSideEffectsOrUnderscore with + | true -> WarningDeadValueWithSideEffects + | false -> WarningDeadValue), + match decl.path with + | name :: _ when name |> Name.isUnderscore -> + "has no side effects and can be removed" + | _ -> ( + "is never used" + ^ + match not noSideEffectsOrUnderscore with + | true -> " and could have side effects" + | false -> "") )) + | RecordLabel -> + (WarningDeadType, "is a record label never used to read a value") + | VariantCase -> + (WarningDeadType, "is a variant case which is never constructed") + in + let hasRefBelow () = + let decl_refs = References.find_value_refs refs decl.pos in + let refIsBelow (pos : Lexing.position) = + decl.pos.pos_fname <> pos.pos_fname + || decl.pos.pos_cnum < pos.pos_cnum + && + (* not a function defined inside a function, e.g. not a callback *) + decl.posEnd.pos_cnum < pos.pos_cnum in - let shouldEmitWarning = - (not insideReportedValue) - && (match decl.path with - | name :: _ when name |> Name.isUnderscore -> Config.reportUnderscore - | _ -> true) - && (config.DceConfig.run.transitive || not (hasRefBelow ())) + decl_refs |> PosSet.exists refIsBelow + in + let shouldEmitWarning = + (not insideReportedValue) + && (match decl.path with + | name :: _ when name |> Name.isUnderscore -> Config.reportUnderscore + | _ -> true) + && (config.DceConfig.run.transitive || not (hasRefBelow ())) + in + if shouldEmitWarning then + let dead_module_issue = + decl.path + |> DcePath.toModuleName ~isType:(decl.declKind |> Decl.Kind.isType) + |> DeadModules.checkModuleDead ~config ~fileName:decl.pos.pos_fname in - if shouldEmitWarning then - let dead_module_issue = - decl.path - |> Path.toModuleName ~isType:(decl.declKind |> DeclKind.isType) - |> DeadModules.checkModuleDead ~config ~fileName:decl.pos.pos_fname - in - let dead_value_issue = makeDeadIssue ~decl ~message deadWarning in - (* Return in order: dead module first (if any), then dead value *) - match dead_module_issue with - | Some mi -> [mi; dead_value_issue] - | None -> [dead_value_issue] - else [] -end + let dead_value_issue = makeDeadIssue ~decl ~message deadWarning in + (* Return in order: dead module first (if any), then dead value *) + match dead_module_issue with + | Some mi -> [mi; dead_value_issue] + | None -> [dead_value_issue] + else [] let declIsDead ~annotations ~refs decl = let liveRefs = refs - |> References.PosSet.filter (fun p -> + |> PosSet.filter (fun p -> not (FileAnnotations.is_annotated_dead annotations p)) in - liveRefs |> References.PosSet.cardinal = 0 - && not (FileAnnotations.is_annotated_gentype_or_live annotations decl.pos) + liveRefs |> PosSet.cardinal = 0 + && not + (FileAnnotations.is_annotated_gentype_or_live annotations decl.Decl.pos) let doReportDead ~annotations pos = not (FileAnnotations.is_annotated_gentype_or_dead annotations pos) let rec resolveRecursiveRefs ~all_refs ~annotations ~config ~decls ~checkOptionalArg: - (checkOptionalArgFn : config:DceConfig.t -> decl -> Common.issue list) + (checkOptionalArgFn : config:DceConfig.t -> Decl.t -> Issue.t list) ~deadDeclarations ~issues ~level ~orderedFiles ~refs ~refsBeingResolved decl : bool = - match decl.pos with + match decl.Decl.pos with | _ when decl.resolvedDead <> None -> if Config.recursiveDebug then Log_.item "recursiveDebug %s [%d] already resolved@." - (decl.path |> Path.toString) + (decl.path |> DcePath.toString) level; (* Use the already-resolved value, not source annotations *) Option.get decl.resolvedDead | _ when PosSet.mem decl.pos !refsBeingResolved -> if Config.recursiveDebug then Log_.item "recursiveDebug %s [%d] is being resolved: assume dead@." - (decl.path |> Path.toString) + (decl.path |> DcePath.toString) level; true | _ -> if Config.recursiveDebug then Log_.item "recursiveDebug resolving %s [%d]@." - (decl.path |> Path.toString) + (decl.path |> DcePath.toString) level; refsBeingResolved := PosSet.add decl.pos !refsBeingResolved; let allDepsResolved = ref true in let newRefs = refs - |> References.PosSet.filter (fun pos -> + |> PosSet.filter (fun pos -> if pos = decl.pos then ( if Config.recursiveDebug then Log_.item "recursiveDebug %s ignoring reference to self@." - (decl.path |> Path.toString); + (decl.path |> DcePath.toString); false) else match Declarations.find_opt decls pos with | None -> if Config.recursiveDebug then Log_.item "recursiveDebug can't find decl for %s@." - (pos |> posToString); + (pos |> Pos.toString); true | Some xDecl -> let xRefs = - match xDecl.declKind |> DeclKind.isType with + match xDecl.declKind |> Decl.Kind.isType with | true -> References.find_type_refs all_refs pos | false -> References.find_value_refs all_refs pos in @@ -392,7 +304,7 @@ let rec resolveRecursiveRefs ~all_refs ~annotations ~config ~decls if isDead then ( decl.path |> DeadModules.markDead ~config - ~isType:(decl.declKind |> DeclKind.isType) + ~isType:(decl.declKind |> Decl.Kind.isType) ~loc:decl.moduleLoc; if not (doReportDead ~annotations decl.pos) then decl.report <- false; deadDeclarations := decl :: !deadDeclarations) @@ -402,7 +314,7 @@ let rec resolveRecursiveRefs ~all_refs ~annotations ~config ~decls |> List.iter (fun issue -> issues := issue :: !issues); decl.path |> DeadModules.markLive ~config - ~isType:(decl.declKind |> DeclKind.isType) + ~isType:(decl.declKind |> Decl.Kind.isType) ~loc:decl.moduleLoc; if FileAnnotations.is_annotated_dead annotations decl.pos then ( (* Collect incorrect @dead annotation issue *) @@ -411,22 +323,22 @@ let rec resolveRecursiveRefs ~all_refs ~annotations ~config ~decls IncorrectDeadAnnotation in decl.path - |> Path.toModuleName ~isType:(decl.declKind |> DeclKind.isType) + |> DcePath.toModuleName ~isType:(decl.declKind |> Decl.Kind.isType) |> DeadModules.checkModuleDead ~config ~fileName:decl.pos.pos_fname |> Option.iter (fun mod_issue -> issues := mod_issue :: !issues); issues := issue :: !issues)); if config.DceConfig.cli.debug then let refsString = - newRefs |> References.PosSet.elements |> List.map posToString + newRefs |> PosSet.elements |> List.map Pos.toString |> String.concat ", " in Log_.item "%s %s %s: %d references (%s) [%d]@." (match isDead with | true -> "Dead" | false -> "Live") - (decl.declKind |> DeclKind.toString) - (decl.path |> Path.toString) - (newRefs |> References.PosSet.cardinal) + (decl.declKind |> Decl.Kind.toString) + (decl.path |> DcePath.toString) + (newRefs |> PosSet.cardinal) refsString level); isDead @@ -436,8 +348,8 @@ let reportDead ~annotations ~config ~decls ~refs ~file_deps ~optional_args_state optional_args_state:OptionalArgsState.t -> annotations:FileAnnotations.t -> config:DceConfig.t -> - decl -> - Common.issue list) : AnalysisResult.t = + Decl.t -> + Issue.t list) : AnalysisResult.t = let iterDeclInOrder ~deadDeclarations ~issues ~orderedFiles decl = let decl_refs = match decl |> Decl.isValue with @@ -490,7 +402,7 @@ let reportDead ~annotations ~config ~decls ~refs ~file_deps ~optional_args_state let dead_issues = sortedDeadDeclarations |> List.concat_map (fun decl -> - Decl.report ~config ~refs reporting_ctx decl) + reportDeclaration ~config ~refs reporting_ctx decl) in (* Combine all issues: inline issues first (they were logged during analysis), then dead declaration issues *) diff --git a/analysis/reanalyze/src/DeadException.ml b/analysis/reanalyze/src/DeadException.ml index c741e7172e..caaa108cb4 100644 --- a/analysis/reanalyze/src/DeadException.ml +++ b/analysis/reanalyze/src/DeadException.ml @@ -1,5 +1,4 @@ open DeadCommon -open Common let declarations = Hashtbl.create 1 @@ -18,7 +17,7 @@ let markAsUsed ~config ~refs ~file_deps ~cross_file ~(binding : Location.t) if locTo.loc_ghost then (* Probably defined in another file, delay processing and check at the end *) let exceptionPath = - path_ |> Path.fromPathT |> Path.moduleToImplementation + path_ |> DcePath.fromPathT |> DcePath.moduleToImplementation in CrossFileItems.add_exception_ref cross_file ~exception_path:exceptionPath ~loc_from:locFrom diff --git a/analysis/reanalyze/src/DeadModules.ml b/analysis/reanalyze/src/DeadModules.ml index 5635ea47ec..c8d512c371 100644 --- a/analysis/reanalyze/src/DeadModules.ml +++ b/analysis/reanalyze/src/DeadModules.ml @@ -6,22 +6,21 @@ let table = Hashtbl.create 1 let markDead ~config ~isType ~loc path = if active ~config then - let moduleName = path |> Common.Path.toModuleName ~isType in + let moduleName = path |> DcePath.toModuleName ~isType in match Hashtbl.find_opt table moduleName with | Some _ -> () | _ -> Hashtbl.replace table moduleName (false, loc) let markLive ~config ~isType ~(loc : Location.t) path = if active ~config then - let moduleName = path |> Common.Path.toModuleName ~isType in + let moduleName = path |> DcePath.toModuleName ~isType in match Hashtbl.find_opt table moduleName with | None -> Hashtbl.replace table moduleName (true, loc) | Some (false, loc) -> Hashtbl.replace table moduleName (true, loc) | Some (true, _) -> () (** Check if a module is dead and return issue if so. Pure - no logging. *) -let checkModuleDead ~config ~fileName:pos_fname moduleName : Common.issue option - = +let checkModuleDead ~config ~fileName:pos_fname moduleName : Issue.t option = if not (active ~config) then None else match Hashtbl.find_opt table moduleName with diff --git a/analysis/reanalyze/src/DeadOptionalArgs.ml b/analysis/reanalyze/src/DeadOptionalArgs.ml index 48354f92b9..d5842e5eaa 100644 --- a/analysis/reanalyze/src/DeadOptionalArgs.ml +++ b/analysis/reanalyze/src/DeadOptionalArgs.ml @@ -1,5 +1,4 @@ open DeadCommon -open Common let active () = true @@ -18,7 +17,7 @@ let addFunctionReference ~config ~decls ~cross_file ~(locFrom : Location.t) if shouldAdd then ( if config.DceConfig.cli.debug then Log_.item "OptionalArgs.addFunctionReference %s %s@." - (posFrom |> posToString) (posTo |> posToString); + (posFrom |> Pos.toString) (posTo |> Pos.toString); CrossFileItems.add_function_reference cross_file ~pos_from:posFrom ~pos_to:posTo) @@ -51,16 +50,16 @@ let addReferences ~config ~cross_file ~(locFrom : Location.t) Log_.item "DeadOptionalArgs.addReferences %s called with optional argNames:%s \ argNamesMaybe:%s %s@." - (path |> Path.fromPathT |> Path.toString) + (path |> DcePath.fromPathT |> DcePath.toString) (argNames |> String.concat ", ") (argNamesMaybe |> String.concat ", ") - (posFrom |> posToString)) + (posFrom |> Pos.toString)) (** Check for optional args issues. Returns issues instead of logging. Uses optional_args_state map for final computed state. *) -let check ~optional_args_state ~annotations ~config:_ decl : Common.issue list = +let check ~optional_args_state ~annotations ~config:_ decl : Issue.t list = match decl with - | {declKind = Value {optionalArgs}} + | {Decl.declKind = Value {optionalArgs}} when active () && not (FileAnnotations.is_annotated_gentype_or_live annotations decl.pos) @@ -75,7 +74,7 @@ let check ~optional_args_state ~annotations ~config:_ decl : Common.issue list = let unused_issues = OptionalArgs.foldUnused (fun s acc -> - let issue : Common.issue = + let issue : Issue.t = { name = "Warning Unused Argument"; severity = Warning; @@ -89,7 +88,7 @@ let check ~optional_args_state ~annotations ~config:_ decl : Common.issue list = "optional argument @{%s@} of function \ @{%s@} is never used" s - (decl.path |> Path.withoutHead); + (decl.path |> DcePath.withoutHead); }; } in @@ -99,7 +98,7 @@ let check ~optional_args_state ~annotations ~config:_ decl : Common.issue list = let redundant_issues = OptionalArgs.foldAlwaysUsed (fun s nCalls acc -> - let issue : Common.issue = + let issue : Issue.t = { name = "Warning Redundant Optional Argument"; severity = Warning; @@ -113,7 +112,7 @@ let check ~optional_args_state ~annotations ~config:_ decl : Common.issue list = "optional argument @{%s@} of function \ @{%s@} is always supplied (%d calls)" s - (decl.path |> Path.withoutHead) + (decl.path |> DcePath.withoutHead) nCalls; }; } diff --git a/analysis/reanalyze/src/DeadType.ml b/analysis/reanalyze/src/DeadType.ml index 41455cc570..402c4b0340 100644 --- a/analysis/reanalyze/src/DeadType.ml +++ b/analysis/reanalyze/src/DeadType.ml @@ -1,20 +1,19 @@ (* Adapted from https://github.com/LexiFi/dead_code_analyzer *) -open Common open DeadCommon module TypeLabels = struct (* map from type path (for record/variant label) to its location *) - let table = (Hashtbl.create 256 : (Path.t, Location.t) Hashtbl.t) + let table = (Hashtbl.create 256 : (DcePath.t, Location.t) Hashtbl.t) let add path loc = Hashtbl.replace table path loc let find path = Hashtbl.find_opt table path end let addTypeReference ~config ~refs ~posFrom ~posTo = if config.DceConfig.cli.debug then - Log_.item "addTypeReference %s --> %s@." (posFrom |> posToString) - (posTo |> posToString); + Log_.item "addTypeReference %s --> %s@." (posFrom |> Pos.toString) + (posTo |> Pos.toString); References.add_type_ref refs ~posTo ~posFrom module TypeDependencies = struct @@ -36,8 +35,8 @@ let extendTypeDependencies ~config (loc1 : Location.t) (loc2 : Location.t) = if loc1.loc_start <> loc2.loc_start then ( if config.DceConfig.cli.debug then Log_.item "extendTypeDependencies %s --> %s@." - (loc1.loc_start |> posToString) - (loc2.loc_start |> posToString); + (loc1.loc_start |> Pos.toString) + (loc2.loc_start |> Pos.toString); TypeDependencies.add loc1 loc2) (* Type dependencies between Foo.re and Foo.rei *) @@ -45,8 +44,8 @@ let addTypeDependenciesAcrossFiles ~config ~file ~pathToType ~loc ~typeLabelName = let isInterface = file.FileContext.is_interface in if not isInterface then ( - let path_1 = pathToType |> Path.moduleToInterface in - let path_2 = path_1 |> Path.typeToInterface in + let path_1 = pathToType |> DcePath.moduleToInterface in + let path_2 = path_1 |> DcePath.typeToInterface in let path1 = typeLabelName :: path_1 in let path2 = typeLabelName :: path_2 in match TypeLabels.find path1 with @@ -62,7 +61,7 @@ let addTypeDependenciesAcrossFiles ~config ~file ~pathToType ~loc ~typeLabelName if not Config.reportTypesDeadOnlyInInterface then extendTypeDependencies ~config loc1 loc) else - let path_1 = pathToType |> Path.moduleToImplementation in + let path_1 = pathToType |> DcePath.moduleToImplementation in let path1 = typeLabelName :: path_1 in match TypeLabels.find path1 with | None -> () @@ -88,7 +87,7 @@ let addDeclaration ~config ~decls ~file ~(typeId : Ident.t) (typeId |> Ident.name |> Name.create) :: (currentModulePath.path @ [FileContext.module_name_tagged file]) in - let processTypeLabel ?(posAdjustment = Nothing) typeLabelName ~declKind + let processTypeLabel ?(posAdjustment = Decl.Nothing) typeLabelName ~declKind ~(loc : Location.t) = addDeclaration_ ~config ~decls ~file ~declKind ~path:pathToType ~loc ~moduleLoc:currentModulePath.loc ~posAdjustment typeLabelName; @@ -124,7 +123,7 @@ let addDeclaration ~config ~decls ~file ~(typeId : Ident.t) Filename.check_suffix fname ".res" || Filename.check_suffix fname ".resi" in - if isRes then if i = 0 then FirstVariant else OtherVariant + if isRes then if i = 0 then Decl.FirstVariant else OtherVariant else Nothing in Ident.name cd_id |> Name.create diff --git a/analysis/reanalyze/src/DeadValue.ml b/analysis/reanalyze/src/DeadValue.ml index 5eea48c8fa..6197ce7417 100644 --- a/analysis/reanalyze/src/DeadValue.ml +++ b/analysis/reanalyze/src/DeadValue.ml @@ -28,7 +28,7 @@ let collectValueBinding ~config ~decls ~file ~(current_binding : Location.t) let name = Ident.name id |> Name.create ~isInterface:false in let optionalArgs = vb.vb_expr.exp_type |> DeadOptionalArgs.fromTypeExpr - |> Common.OptionalArgs.fromList + |> OptionalArgs.fromList in let exists = match Declarations.find_opt_builder decls loc_start with @@ -61,7 +61,7 @@ let collectValueBinding ~config ~decls ~file ~(current_binding : Location.t) let declKind = match decl.declKind with | Value vk -> - Common.DeclKind.Value + Decl.Kind.Value {vk with sideEffects = SideEffects.checkExpr vb.vb_expr} | dk -> dk in @@ -121,8 +121,8 @@ let rec collectExpr ~config ~refs ~file_deps ~cross_file which is called from its own location as many things are generated on the same location. *) if config.DceConfig.cli.debug then Log_.item "addDummyReference %s --> %s@." - (Location.none.loc_start |> Common.posToString) - (locTo.loc_start |> Common.posToString); + (Location.none.loc_start |> Pos.toString) + (locTo.loc_start |> Pos.toString); References.add_value_ref refs ~posTo:locTo.loc_start ~posFrom:Location.none.loc_start) else @@ -262,8 +262,7 @@ let rec processSignatureItem ~config ~decls ~file ~doTypes ~doValues ~moduleLoc in if (not isPrimitive) || !Config.analyzeExternals then let optionalArgs = - val_type |> DeadOptionalArgs.fromTypeExpr - |> Common.OptionalArgs.fromList + val_type |> DeadOptionalArgs.fromTypeExpr |> OptionalArgs.fromList in (* if Ident.name id = "someValue" then diff --git a/analysis/reanalyze/src/Decl.ml b/analysis/reanalyze/src/Decl.ml new file mode 100644 index 0000000000..0ce1d08af2 --- /dev/null +++ b/analysis/reanalyze/src/Decl.ml @@ -0,0 +1,81 @@ +(** Declaration types for dead code analysis. *) + +module Kind = struct + type t = + | Exception + | RecordLabel + | VariantCase + | Value of { + isToplevel: bool; + mutable optionalArgs: OptionalArgs.t; + sideEffects: bool; + } + + let isType dk = + match dk with + | RecordLabel | VariantCase -> true + | Exception | Value _ -> false + + let toString dk = + match dk with + | Exception -> "Exception" + | RecordLabel -> "RecordLabel" + | VariantCase -> "VariantCase" + | Value _ -> "Value" +end + +type posAdjustment = FirstVariant | OtherVariant | Nothing + +type t = { + declKind: Kind.t; + moduleLoc: Location.t; + posAdjustment: posAdjustment; + path: DcePath.t; + pos: Lexing.position; + posEnd: Lexing.position; + posStart: Lexing.position; + mutable resolvedDead: bool option; + mutable report: bool; +} + +let isValue decl = + match decl.declKind with + | Value _ (* | Exception *) -> true + | _ -> false + +let compareUsingDependencies ~orderedFiles + { + declKind = kind1; + path = _path1; + pos = + {pos_fname = fname1; pos_lnum = lnum1; pos_bol = bol1; pos_cnum = cnum1}; + } + { + declKind = kind2; + path = _path2; + pos = + {pos_fname = fname2; pos_lnum = lnum2; pos_bol = bol2; pos_cnum = cnum2}; + } = + let findPosition fn = Hashtbl.find orderedFiles fn [@@raises Not_found] in + (* From the root of the file dependency DAG to the leaves. + From the bottom of the file to the top. *) + let position1, position2 = + try (fname1 |> findPosition, fname2 |> findPosition) + with Not_found -> (0, 0) + in + compare + (position1, lnum2, bol2, cnum2, kind1) + (position2, lnum1, bol1, cnum1, kind2) + +let compareForReporting + { + declKind = kind1; + pos = + {pos_fname = fname1; pos_lnum = lnum1; pos_bol = bol1; pos_cnum = cnum1}; + } + { + declKind = kind2; + pos = + {pos_fname = fname2; pos_lnum = lnum2; pos_bol = bol2; pos_cnum = cnum2}; + } = + compare (fname1, lnum1, bol1, cnum1, kind1) (fname2, lnum2, bol2, cnum2, kind2) diff --git a/analysis/reanalyze/src/Declarations.ml b/analysis/reanalyze/src/Declarations.ml index d6e5311116..cf49afdd5a 100644 --- a/analysis/reanalyze/src/Declarations.ml +++ b/analysis/reanalyze/src/Declarations.ml @@ -4,33 +4,21 @@ - [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 +type t = Decl.t PosHash.t +type builder = Decl.t PosHash.t (* ===== Builder API ===== *) let create_builder () : builder = PosHash.create 256 -let add (builder : builder) (pos : Lexing.position) (decl : decl) = +let add (builder : builder) (pos : Lexing.position) (decl : Decl.t) = 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) = +let replace_builder (builder : builder) (pos : Lexing.position) (decl : Decl.t) + = PosHash.replace builder pos decl let merge_all (builders : builder list) : t = diff --git a/analysis/reanalyze/src/Declarations.mli b/analysis/reanalyze/src/Declarations.mli index d498e08462..31bbb7934a 100644 --- a/analysis/reanalyze/src/Declarations.mli +++ b/analysis/reanalyze/src/Declarations.mli @@ -18,15 +18,15 @@ type builder (** {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 add : builder -> Lexing.position -> Decl.t -> unit +val find_opt_builder : builder -> Lexing.position -> Decl.t option +val replace_builder : builder -> Lexing.position -> Decl.t -> 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 +val find_opt : t -> Lexing.position -> Decl.t option +val fold : (Lexing.position -> Decl.t -> 'a -> 'a) -> t -> 'a -> 'a +val iter : (Lexing.position -> Decl.t -> unit) -> t -> unit diff --git a/analysis/reanalyze/src/Exception.ml b/analysis/reanalyze/src/Exception.ml index b9822e383c..9cf5d4ff39 100644 --- a/analysis/reanalyze/src/Exception.ml +++ b/analysis/reanalyze/src/Exception.ml @@ -1,6 +1,4 @@ open DeadCommon -module LocSet = Common.LocSet -let posToString = Common.posToString module Values = struct let valueBindingsTable = @@ -10,10 +8,10 @@ module Values = struct let add ~name exceptions = let path = (name |> Name.create) :: (ModulePath.getCurrent ()).path in - Hashtbl.replace !currentFileTable (path |> Common.Path.toName) exceptions + Hashtbl.replace !currentFileTable (path |> DcePath.toName) exceptions - let getFromModule ~moduleName ~modulePath (path_ : Common.Path.t) = - let name = path_ @ modulePath |> Common.Path.toName in + let getFromModule ~moduleName ~modulePath (path_ : DcePath.t) = + let name = path_ @ modulePath |> DcePath.toName in match Hashtbl.find_opt valueBindingsTable (String.capitalize_ascii moduleName) with @@ -50,7 +48,7 @@ module Values = struct match (findExternal ~externalModuleName ~pathRev, pathRev) with | (Some _ as found), _ -> found | None, externalModuleName2 :: pathRev2 - when !Common.Cli.cmtCommand && pathRev2 <> [] -> + when !Cli.cmtCommand && pathRev2 <> [] -> (* Simplistic namespace resolution for dune namespace: skip the root of the path *) findExternal ~externalModuleName:externalModuleName2 ~pathRev:pathRev2 | None, _ -> None) @@ -65,7 +63,7 @@ end module Event = struct type kind = | Catches of t list (* with | E => ... *) - | Call of {callee: Common.Path.t; modulePath: Common.Path.t} (* foo() *) + | Call of {callee: DcePath.t; modulePath: DcePath.t} (* foo() *) | DoesNotThrow of t list (* DoesNotThrow(events) where events come from an expression *) | Throws (** throw E *) @@ -76,25 +74,25 @@ module Event = struct match event with | {kind = Call {callee; modulePath}; exceptions; loc} -> Format.fprintf ppf "%s Call(%s, modulePath:%s) %a@." - (loc.loc_start |> posToString) - (callee |> Common.Path.toString) - (modulePath |> Common.Path.toString) + (loc.loc_start |> Pos.toString) + (callee |> DcePath.toString) + (modulePath |> DcePath.toString) (Exceptions.pp ~exnTable:None) exceptions | {kind = DoesNotThrow nestedEvents; loc} -> Format.fprintf ppf "%s DoesNotThrow(%a)@." - (loc.loc_start |> posToString) + (loc.loc_start |> Pos.toString) (fun ppf () -> nestedEvents |> List.iter (fun e -> Format.fprintf ppf "%a " print e)) () | {kind = Throws; exceptions; loc} -> Format.fprintf ppf "%s throws %a@." - (loc.loc_start |> posToString) + (loc.loc_start |> Pos.toString) (Exceptions.pp ~exnTable:None) exceptions | {kind = Catches nestedEvents; exceptions; loc} -> Format.fprintf ppf "%s Catches exceptions:%a nestedEvents:%a@." - (loc.loc_start |> posToString) + (loc.loc_start |> Pos.toString) (Exceptions.pp ~exnTable:None) exceptions (fun ppf () -> @@ -140,11 +138,11 @@ module Event = struct (if Exceptions.isEmpty nestedExceptions (* catch-all *) then let name = match nestedEvents with - | {kind = Call {callee}} :: _ -> callee |> Common.Path.toName + | {kind = Call {callee}} :: _ -> callee |> DcePath.toName | _ -> "expression" |> Name.create in Log_.warning ~loc - (Common.ExceptionAnalysis + (Issue.ExceptionAnalysis { message = Format.asprintf @@ -193,13 +191,13 @@ module Checks = struct let redundantAnnotations = Exceptions.diff exceptions throwSet in (if not (Exceptions.isEmpty missingAnnotations) then let description = - Common.ExceptionAnalysisMissing + Issue.ExceptionAnalysisMissing {exnName; exnTable; throwSet; missingAnnotations; locFull} in Log_.warning ~loc description); if not (Exceptions.isEmpty redundantAnnotations) then Log_.warning ~loc - (Common.ExceptionAnalysis + (Issue.ExceptionAnalysis { message = (let throwsDescription ppf () = @@ -276,13 +274,11 @@ let traverseAst ~file () = if isDoesNoThrow then currentEvents := []; (match expr.exp_desc with | Texp_ident (callee_, _, _) -> - let callee = - callee_ |> Common.Path.fromPathT |> ModulePath.resolveAlias - in - let calleeName = callee |> Common.Path.toName in + let callee = callee_ |> DcePath.fromPathT |> ModulePath.resolveAlias in + let calleeName = callee |> DcePath.toName in if calleeName |> Name.toString |> isThrow then Log_.warning ~loc - (Common.ExceptionAnalysis + (Issue.ExceptionAnalysis { message = Format.asprintf @@ -421,7 +417,7 @@ let traverseAst ~file () = | Tstr_module {mb_id; mb_expr = {mod_desc = Tmod_ident (path_, _lid)}} -> ModulePath.addAlias ~name:(mb_id |> Ident.name |> Name.create) - ~path:(path_ |> Common.Path.fromPathT) + ~path:(path_ |> DcePath.fromPathT) | _ -> ()); result in diff --git a/analysis/reanalyze/src/Exceptions.ml b/analysis/reanalyze/src/Exceptions.ml index 06d4d5c187..91ae2000aa 100644 --- a/analysis/reanalyze/src/Exceptions.ml +++ b/analysis/reanalyze/src/Exceptions.ml @@ -1,4 +1,4 @@ -open Common +module ExnSet = Set.Make (Exn) type t = ExnSet.t @@ -22,11 +22,11 @@ let pp ~exnTable ppf exceptions = match Hashtbl.find_opt exnTable exn with | Some locSet -> let positions = - locSet |> Common.LocSet.elements + locSet |> LocSet.elements |> List.map (fun loc -> loc.Location.loc_start) in Format.fprintf ppf "%s@{%s@} (@{%s@})" separator name - (positions |> List.map posToString |> String.concat " ") + (positions |> List.map Pos.toString |> String.concat " ") | None -> Format.fprintf ppf "%s@{%s@}" separator name) | None -> Format.fprintf ppf "%s@{%s@}" separator name in diff --git a/analysis/reanalyze/src/ExnLib.ml b/analysis/reanalyze/src/ExnLib.ml index 3b9f2602ff..1104661b71 100644 --- a/analysis/reanalyze/src/ExnLib.ml +++ b/analysis/reanalyze/src/ExnLib.ml @@ -240,5 +240,5 @@ let raisesLibTable : (Name.t, Exceptions.t) Hashtbl.t = (e |> Exceptions.fromList))); table -let find (path : Common.Path.t) = - Hashtbl.find_opt raisesLibTable (path |> Common.Path.toName) +let find (path : DcePath.t) = + Hashtbl.find_opt raisesLibTable (path |> DcePath.toName) diff --git a/analysis/reanalyze/src/FileAnnotations.ml b/analysis/reanalyze/src/FileAnnotations.ml index 2c71f308e1..c8344a201f 100644 --- a/analysis/reanalyze/src/FileAnnotations.ml +++ b/analysis/reanalyze/src/FileAnnotations.ml @@ -4,17 +4,6 @@ - [builder] - mutable, for AST processing and merging - [t] - immutable, for solver (read-only access) *) -(* Position-keyed hashtable *) -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) - type annotated_as = GenType | Dead | Live (* Both types have the same representation, but different semantics *) diff --git a/analysis/reanalyze/src/FileDeps.ml b/analysis/reanalyze/src/FileDeps.ml index c80b44f284..ed34e7c4c6 100644 --- a/analysis/reanalyze/src/FileDeps.ml +++ b/analysis/reanalyze/src/FileDeps.ml @@ -2,8 +2,6 @@ Tracks which files reference which other files. *) -open Common - (* File-keyed hashtable *) module FileHash = Hashtbl.Make (struct type t = string diff --git a/analysis/reanalyze/src/FileDeps.mli b/analysis/reanalyze/src/FileDeps.mli index 2a0a4d2573..2975e5ceca 100644 --- a/analysis/reanalyze/src/FileDeps.mli +++ b/analysis/reanalyze/src/FileDeps.mli @@ -5,8 +5,6 @@ - [builder] - mutable, for AST processing - [t] - immutable, for analysis *) -open Common - (** {2 Types} *) type t diff --git a/analysis/reanalyze/src/FileHash.ml b/analysis/reanalyze/src/FileHash.ml new file mode 100644 index 0000000000..433c7ee8a0 --- /dev/null +++ b/analysis/reanalyze/src/FileHash.ml @@ -0,0 +1,8 @@ +(** File name hashtable. *) + +include Hashtbl.Make (struct + type t = string + + let hash (x : t) = Hashtbl.hash x + let equal (x : t) y = x = y +end) diff --git a/analysis/reanalyze/src/FileSet.ml b/analysis/reanalyze/src/FileSet.ml new file mode 100644 index 0000000000..8caf46fe2d --- /dev/null +++ b/analysis/reanalyze/src/FileSet.ml @@ -0,0 +1,3 @@ +(** File name set. *) + +include Set.Make (String) diff --git a/analysis/reanalyze/src/FindSourceFile.ml b/analysis/reanalyze/src/FindSourceFile.ml index 3c92f8120c..a61dfcdd07 100644 --- a/analysis/reanalyze/src/FindSourceFile.ml +++ b/analysis/reanalyze/src/FindSourceFile.ml @@ -17,11 +17,11 @@ let rec implementation items = let cmt cmt_annots = match cmt_annots with | Cmt_format.Interface signature -> - if !Common.Cli.debug && signature.sig_items = [] then + if !Cli.debug && signature.sig_items = [] then Log_.item "Interface %d@." (signature.sig_items |> List.length); interface signature.sig_items | Implementation structure -> - if !Common.Cli.debug && structure.str_items = [] then + if !Cli.debug && structure.str_items = [] then Log_.item "Implementation %d@." (structure.str_items |> List.length); implementation structure.str_items | _ -> None diff --git a/analysis/reanalyze/src/Issue.ml b/analysis/reanalyze/src/Issue.ml new file mode 100644 index 0000000000..ed9ab87b22 --- /dev/null +++ b/analysis/reanalyze/src/Issue.ml @@ -0,0 +1,45 @@ +(** Issue types for dead code analysis. + + These types represent the various issues that can be reported. *) + +module ExnSet = Set.Make (Exn) + +type missingThrowInfo = { + exnName: string; + exnTable: (Exn.t, LocSet.t) Hashtbl.t; + locFull: Location.t; + missingAnnotations: ExnSet.t; + throwSet: ExnSet.t; +} + +type severity = Warning | Error +type deadOptional = WarningUnusedArgument | WarningRedundantOptionalArgument + +type termination = + | ErrorHygiene + | ErrorNotImplemented + | ErrorTermination + | TerminationAnalysisInternal + +type deadWarning = + | WarningDeadException + | WarningDeadType + | WarningDeadValue + | WarningDeadValueWithSideEffects + | IncorrectDeadAnnotation + +type description = + | Circular of {message: string} + | ExceptionAnalysis of {message: string} + | ExceptionAnalysisMissing of missingThrowInfo + | DeadModule of {message: string} + | DeadOptional of {deadOptional: deadOptional; message: string} + | DeadWarning of {deadWarning: deadWarning; path: string; message: string} + | Termination of {termination: termination; message: string} + +type t = { + name: string; + severity: severity; + loc: Location.t; + description: description; +} diff --git a/analysis/reanalyze/src/LocSet.ml b/analysis/reanalyze/src/LocSet.ml new file mode 100644 index 0000000000..9823d6eb1d --- /dev/null +++ b/analysis/reanalyze/src/LocSet.ml @@ -0,0 +1,5 @@ +include Set.Make (struct + include Location + + let compare = compare +end) diff --git a/analysis/reanalyze/src/Log_.ml b/analysis/reanalyze/src/Log_.ml index b880b75e8f..a50a73cd68 100644 --- a/analysis/reanalyze/src/Log_.ml +++ b/analysis/reanalyze/src/Log_.ml @@ -1,5 +1,3 @@ -open Common - module Color = struct let color_enabled = lazy (Unix.isatty Unix.stdout) let forceColor = ref false @@ -97,7 +95,7 @@ let item x = Format.fprintf Format.std_formatter " "; Format.fprintf Format.std_formatter x -let missingRaiseInfoToText {missingAnnotations; locFull} = +let missingRaiseInfoToText {Issue.missingAnnotations; locFull} = let missingTxt = Format.asprintf "%a" (Exceptions.pp ~exnTable:None) missingAnnotations in @@ -107,14 +105,14 @@ let missingRaiseInfoToText {missingAnnotations; locFull} = ~text:(Format.asprintf "@throws(%s)\\n" missingTxt) else "" -let logAdditionalInfo ~(description : description) = +let logAdditionalInfo ~(description : Issue.description) = match description with | ExceptionAnalysisMissing missingRaiseInfo -> missingRaiseInfoToText missingRaiseInfo | _ -> "" -let missingThrowInfoToMessage {exnTable; exnName; missingAnnotations; throwSet} - = +let missingThrowInfoToMessage + {Issue.exnTable; exnName; missingAnnotations; throwSet} = let throwsTxt = Format.asprintf "%a" (Exceptions.pp ~exnTable:(Some exnTable)) throwSet in @@ -125,7 +123,7 @@ let missingThrowInfoToMessage {exnTable; exnName; missingAnnotations; throwSet} "@{%s@} might throw %s and is not annotated with @throws(%s)" exnName throwsTxt missingTxt -let descriptionToMessage (description : description) = +let descriptionToMessage (description : Issue.description) = match description with | Circular {message} -> message | DeadModule {message} -> message @@ -137,7 +135,7 @@ let descriptionToMessage (description : description) = missingThrowInfoToMessage missingRaiseInfo | Termination {message} -> message -let descriptionToName (description : description) = +let descriptionToName (description : Issue.description) = match description with | Circular _ -> Issues.warningDeadAnalysisCycle | DeadModule _ -> Issues.warningDeadModule @@ -162,7 +160,7 @@ let descriptionToName (description : description) = | Termination {termination = TerminationAnalysisInternal} -> Issues.terminationAnalysisInternal -let logIssue ~config ~(issue : issue) = +let logIssue ~config ~(issue : Issue.t) = let open Format in let loc = issue.loc in if config.DceConfig.cli.json then @@ -197,13 +195,13 @@ let logIssue ~config ~(issue : issue) = module Stats = struct let issues = ref [] - let addIssue (issue : issue) = issues := issue :: !issues + let addIssue (issue : Issue.t) = issues := issue :: !issues let clear () = issues := [] let getSortedIssues () = let counters2 = Hashtbl.create 1 in !issues - |> List.iter (fun (issue : issue) -> + |> List.iter (fun (issue : Issue.t) -> let counter = match Hashtbl.find_opt counters2 issue.name with | Some counter -> counter diff --git a/analysis/reanalyze/src/ModulePath.ml b/analysis/reanalyze/src/ModulePath.ml index 1955da1810..3d9e6b9aad 100644 --- a/analysis/reanalyze/src/ModulePath.ml +++ b/analysis/reanalyze/src/ModulePath.ml @@ -1,8 +1,7 @@ -open Common module NameMap = Map.Make (Name) (* Keep track of the module path while traversing with Tast_mapper *) -type t = {aliases: Path.t NameMap.t; loc: Location.t; path: Path.t} +type t = {aliases: DcePath.t NameMap.t; loc: Location.t; path: DcePath.t} let initial = ({aliases = NameMap.empty; loc = Location.none; path = []} : t) let current = (ref initial : t ref) @@ -15,19 +14,18 @@ let normalizePath ~aliases path = | None -> path | Some path1 -> let newPath = List.rev (path1 @ restRev) in - if !Common.Cli.debug then - Log_.item "Resolve Alias: %s to %s@." - (path |> Common.Path.toString) - (newPath |> Common.Path.toString); + if !Cli.debug then + Log_.item "Resolve Alias: %s to %s@." (path |> DcePath.toString) + (newPath |> DcePath.toString); newPath) | _ -> path let addAlias ~name ~path = let aliases = !current.aliases in let pathNormalized = path |> normalizePath ~aliases in - if !Common.Cli.debug then + if !Cli.debug then Log_.item "Module Alias: %s = %s@." (name |> Name.toString) - (Path.toString pathNormalized); + (DcePath.toString pathNormalized); current := {!current with aliases = NameMap.add name pathNormalized aliases} let resolveAlias path = path |> normalizePath ~aliases:!current.aliases diff --git a/analysis/reanalyze/src/OptionalArgs.ml b/analysis/reanalyze/src/OptionalArgs.ml new file mode 100644 index 0000000000..1010075979 --- /dev/null +++ b/analysis/reanalyze/src/OptionalArgs.ml @@ -0,0 +1,45 @@ +(** Immutable record tracking optional argument usage. + - unused: args that have never been passed + - alwaysUsed: args that are always passed (when count > 0) + - count: number of calls observed *) + +module StringSet = Set.Make (String) + +type t = {count: int; unused: StringSet.t; alwaysUsed: StringSet.t} + +let empty = {unused = StringSet.empty; alwaysUsed = StringSet.empty; count = 0} + +let fromList l = + {unused = StringSet.of_list l; alwaysUsed = StringSet.empty; count = 0} + +let isEmpty x = StringSet.is_empty x.unused + +(** Apply a call to the optional args state. Returns new state. *) +let apply_call ~argNames ~argNamesMaybe x = + let nameSet = argNames |> StringSet.of_list in + let nameSetMaybe = argNamesMaybe |> StringSet.of_list in + let nameSetAlways = StringSet.diff nameSet nameSetMaybe in + let alwaysUsed = + if x.count = 0 then nameSetAlways + else StringSet.inter nameSetAlways x.alwaysUsed + in + let unused = + argNames + |> List.fold_left (fun acc name -> StringSet.remove name acc) x.unused + in + {count = x.count + 1; unused; alwaysUsed} + +(** Combine two optional args states (for function references). + Returns a pair of updated states with intersected unused/alwaysUsed. *) +let combine_pair x y = + let unused = StringSet.inter x.unused y.unused in + let alwaysUsed = StringSet.inter x.alwaysUsed y.alwaysUsed in + ({x with unused; alwaysUsed}, {y with unused; alwaysUsed}) + +let iterUnused f x = StringSet.iter f x.unused +let iterAlwaysUsed f x = StringSet.iter (fun s -> f s x.count) x.alwaysUsed + +let foldUnused f x init = StringSet.fold f x.unused init + +let foldAlwaysUsed f x init = + StringSet.fold (fun s acc -> f s x.count acc) x.alwaysUsed init diff --git a/analysis/reanalyze/src/OptionalArgsState.ml b/analysis/reanalyze/src/OptionalArgsState.ml new file mode 100644 index 0000000000..66a0d0cee6 --- /dev/null +++ b/analysis/reanalyze/src/OptionalArgsState.ml @@ -0,0 +1,10 @@ +(** State map for computed OptionalArgs. + Maps declaration position to final state after all calls/combines. *) + +type t = OptionalArgs.t PosHash.t + +let create () : t = PosHash.create 256 + +let find_opt (state : t) pos = PosHash.find_opt state pos + +let set (state : t) pos value = PosHash.replace state pos value diff --git a/analysis/reanalyze/src/Paths.ml b/analysis/reanalyze/src/Paths.ml index a3471e31c4..70b399932a 100644 --- a/analysis/reanalyze/src/Paths.ml +++ b/analysis/reanalyze/src/Paths.ml @@ -1,4 +1,3 @@ -open Common module StringMap = Map_string let bsconfig = "bsconfig.json" @@ -25,6 +24,8 @@ let rec findProjectRoot ~dir = assert false) else findProjectRoot ~dir:parent +let runConfig = RunConfig.runConfig + let setReScriptProjectRoot = lazy (runConfig.projectRoot <- findProjectRoot ~dir:(Sys.getcwd ()); diff --git a/analysis/reanalyze/src/Pos.ml b/analysis/reanalyze/src/Pos.ml new file mode 100644 index 0000000000..07b053bb4c --- /dev/null +++ b/analysis/reanalyze/src/Pos.ml @@ -0,0 +1,9 @@ +(** Position utilities. *) + +(** Format a position as "filename:line:col" *) +let toString (pos : Lexing.position) = + let file = pos.Lexing.pos_fname in + let line = pos.Lexing.pos_lnum in + let col = pos.Lexing.pos_cnum - pos.Lexing.pos_bol in + (file |> Filename.basename) + ^ ":" ^ string_of_int line ^ ":" ^ string_of_int col diff --git a/analysis/reanalyze/src/PosHash.ml b/analysis/reanalyze/src/PosHash.ml new file mode 100644 index 0000000000..35e49a1422 --- /dev/null +++ b/analysis/reanalyze/src/PosHash.ml @@ -0,0 +1,12 @@ +(** Position-keyed hashtable. + Used throughout dead code analysis for mapping source positions to data. *) + +include 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) diff --git a/analysis/reanalyze/src/PosSet.ml b/analysis/reanalyze/src/PosSet.ml new file mode 100644 index 0000000000..28ef935428 --- /dev/null +++ b/analysis/reanalyze/src/PosSet.ml @@ -0,0 +1,8 @@ +(** Position set. + Used for tracking sets of source positions in dead code analysis. *) + +include Set.Make (struct + type t = Lexing.position + + let compare = compare +end) diff --git a/analysis/reanalyze/src/Reanalyze.ml b/analysis/reanalyze/src/Reanalyze.ml index 7358a72c3f..e10ac45a13 100644 --- a/analysis/reanalyze/src/Reanalyze.ml +++ b/analysis/reanalyze/src/Reanalyze.ml @@ -1,4 +1,4 @@ -open Common +let runConfig = RunConfig.runConfig (** Process a cmt file and return its file_data (if DCE enabled). Conceptually: map over files, then merge results. *) @@ -162,7 +162,7 @@ let runAnalysis ~dce_config ~cmtRoot = in (* Report all issues *) AnalysisResult.get_issues analysis_result - |> List.iter (fun (issue : Common.issue) -> + |> List.iter (fun (issue : Issue.t) -> Log_.warning ~loc:issue.loc issue.description)); if dce_config.DceConfig.run.exception_ then Exception.Checks.doChecks ~config:dce_config; @@ -171,12 +171,12 @@ let runAnalysis ~dce_config ~cmtRoot = let runAnalysisAndReport ~cmtRoot = Log_.Color.setup (); - if !Common.Cli.json then EmitJson.start (); + if !Cli.json then EmitJson.start (); let dce_config = DceConfig.current () in runAnalysis ~dce_config ~cmtRoot; Log_.Stats.report ~config:dce_config; Log_.Stats.clear (); - if !Common.Cli.json then EmitJson.finish () + if !Cli.json then EmitJson.finish () let cli () = let analysisKindSet = ref false in @@ -232,28 +232,28 @@ let cli () = String (fun s -> let paths = s |> String.split_on_char ',' in - Common.Cli.excludePaths := paths @ Common.Cli.excludePaths.contents), + Cli.excludePaths := paths @ Cli.excludePaths.contents), "comma-separated-path-prefixes Exclude from analysis files whose path \ has a prefix in the list" ); ( "-experimental", - Set Common.Cli.experimental, + Set Cli.experimental, "Turn on experimental analyses (this option is currently unused)" ); ( "-externals", Set DeadCommon.Config.analyzeExternals, "Report on externals in dead code analysis" ); - ("-json", Set Common.Cli.json, "Print reports in json format"); + ("-json", Set Cli.json, "Print reports in json format"); ( "-live-names", String (fun s -> let names = s |> String.split_on_char ',' in - Common.Cli.liveNames := names @ Common.Cli.liveNames.contents), + Cli.liveNames := names @ Cli.liveNames.contents), "comma-separated-names Consider all values with the given names as live" ); ( "-live-paths", String (fun s -> let paths = s |> String.split_on_char ',' in - Common.Cli.livePaths := paths @ Common.Cli.livePaths.contents), + Cli.livePaths := paths @ Cli.livePaths.contents), "comma-separated-path-prefixes Consider all values whose path has a \ prefix in the list as live" ); ( "-suppress", diff --git a/analysis/reanalyze/src/References.ml b/analysis/reanalyze/src/References.ml index 34f5017dea..632dbd7861 100644 --- a/analysis/reanalyze/src/References.ml +++ b/analysis/reanalyze/src/References.ml @@ -4,24 +4,6 @@ - [builder] - mutable, for AST processing - [t] - immutable, for solver (read-only access) *) -(* Position set - same definition as DeadCommon.PosSet *) -module PosSet = Set.Make (struct - type t = Lexing.position - - let compare = compare -end) - -(* Position-keyed hashtable *) -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) - (* Helper to add to a set in a hashtable *) let addSet h k v = let set = try PosHash.find h k with Not_found -> PosSet.empty in diff --git a/analysis/reanalyze/src/References.mli b/analysis/reanalyze/src/References.mli index 977588dec2..05228b7b8e 100644 --- a/analysis/reanalyze/src/References.mli +++ b/analysis/reanalyze/src/References.mli @@ -32,10 +32,6 @@ val merge_all : builder list -> t val freeze_builder : builder -> t (** Convert builder to immutable t. Builder should not be used after this. *) -(** {2 Types for refs} *) - -module PosSet : Set.S with type elt = Lexing.position - (** {2 Read-only API for t - for solver} *) val find_value_refs : t -> Lexing.position -> PosSet.t diff --git a/analysis/reanalyze/src/SideEffects.ml b/analysis/reanalyze/src/SideEffects.ml index 5aceaf124d..89d5756bf1 100644 --- a/analysis/reanalyze/src/SideEffects.ml +++ b/analysis/reanalyze/src/SideEffects.ml @@ -18,7 +18,7 @@ let whiteTableSideEffects = let pathIsWhitelistedForSideEffects path = path - |> Common.Path.onOkPath ~whenContainsApply:false ~f:(fun s -> + |> DcePath.onOkPath ~whenContainsApply:false ~f:(fun s -> Hashtbl.mem (Lazy.force whiteTableSideEffects) s) let rec exprNoSideEffects (expr : Typedtree.expression) = diff --git a/analysis/reanalyze/src/StringSet.ml b/analysis/reanalyze/src/StringSet.ml new file mode 100644 index 0000000000..cbd76247a9 --- /dev/null +++ b/analysis/reanalyze/src/StringSet.ml @@ -0,0 +1,3 @@ +(** String set. *) + +include Set.Make (String) diff --git a/analysis/reanalyze/src/Suppress.ml b/analysis/reanalyze/src/Suppress.ml index dc9c521a5d..0502ce9d3f 100644 --- a/analysis/reanalyze/src/Suppress.ml +++ b/analysis/reanalyze/src/Suppress.ml @@ -1,4 +1,4 @@ -open Common +let runConfig = RunConfig.runConfig let checkPrefix prefix_ = let prefix =