auditor

commit f2600a3da8ea853940d3c6ea3a0a93de29022dde
parent 584dc047e8fdfb53d28b2190d5d2f755f1967b57
Author: Jared Tobin <jared@jtobin.io>
Date:   Wed, 11 Feb 2026 20:49:12 +0400

perf: use strict counters in check pass and avoid Map conversion (IMPL15)

Replace per-line AuditResult accumulation with strict counters and
cons-accumulation. Use IntMap lookups directly in inter-procedural
checks instead of converting to Map.

Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>

Diffstat:
M
lib/Audit/AArch64/Check.hs
 | 
45
+++++++++++++++++++++++++++------------------

1 file changed, 27 insertions(+), 18 deletions(-)
diff --git a/lib/Audit/AArch64/Check.hs b/lib/Audit/AArch64/Check.hs
@@ -1,4 +1,5 @@
 {-# OPTIONS_HADDOCK prune #-}
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -68,14 +69,24 @@ checkLine sym st l = case lineInstr l of
       in  AuditResult violations 1 1
 
 -- | Check a basic block, threading taint state.
+-- Uses strict counters and cons-accumulation for violations.
 checkBlock :: Text -> TaintState -> [Line] -> (AuditResult, TaintState)
-checkBlock sym st0 lns = go mempty st0 lns
+checkBlock sym st0 lns = go [] 0 0 st0 lns
   where
-    go acc st [] = (acc, st)
-    go acc st (l:ls) =
-      let result = checkLine sym st l
+    go !vs !lc !ma st [] =
+      (AuditResult (reverse vs) lc ma, st)
+    go !vs !lc !ma st (l:ls) =
+      let (vs', ma') = checkLineStrict sym st l
           st' = analyzeLine l st
-      in  go (acc <> result) st' ls
+      in  go (vs' ++ vs) (lc + 1) (ma + ma') st' ls
+
+-- | Check a single line, returning violations and memory access count.
+checkLineStrict :: Text -> TaintState -> Line -> ([Violation], Int)
+checkLineStrict sym st l = case lineInstr l of
+  Nothing -> ([], 0)
+  Just instr -> case getMemoryAccess instr of
+    Nothing -> ([], 0)
+    Just addr -> (checkAddrMode sym (lineNum l) instr addr st, 1)
 
 -- | Check entire CFG with inter-block dataflow.
 -- Runs fixpoint dataflow to propagate taint across blocks.
@@ -181,24 +192,24 @@ checkCFGInterProc sym cfg =
   where
     checkFunction c s func summs =
       let blockIdxs = functionBlocks c func
-          inStatesIM = runFunctionBlocks c blockIdxs summs
-          inStatesMap = IM.foldlWithKey' toMap Map.empty inStatesIM
+          inStates = runFunctionBlocks c blockIdxs summs
       in  mconcat
             [ fst (checkBlockWithSummary s summs inState (bbLines bb))
             | idx <- blockIdxs
             , let bb = indexBlock c idx
-                  inState = Map.findWithDefault initTaintState idx inStatesMap
+                  inState = IM.findWithDefault initTaintState idx inStates
             ]
-    toMap m k v = Map.insert k v m
 
 -- | Check a block using summaries for calls.
+-- Uses strict counters and cons-accumulation for violations.
 checkBlockWithSummary :: Text -> Map.Map Text FuncSummary -> TaintState
                       -> [Line] -> (AuditResult, TaintState)
-checkBlockWithSummary sym summaries st0 lns = go mempty st0 lns
+checkBlockWithSummary sym summaries st0 lns = go [] 0 0 st0 lns
   where
-    go acc st [] = (acc, st)
-    go acc st (l:ls) =
-      let result = checkLine sym st l
+    go !vs !lc !ma st [] =
+      (AuditResult (reverse vs) lc ma, st)
+    go !vs !lc !ma st (l:ls) =
+      let (vs', ma') = checkLineStrict sym st l
           st' = case lineInstr l of
             Nothing -> st
             Just instr -> case instr of
@@ -206,7 +217,7 @@ checkBlockWithSummary sym summaries st0 lns = go mempty st0 lns
                 Just summ -> applySummary summ st
                 Nothing   -> analyzeLine l st
               _ -> analyzeLine l st
-      in  go (acc <> result) st' ls
+      in  go (vs' ++ vs) (lc + 1) (ma + ma') st' ls
 
 -- | Check entire CFG with taint config.
 checkCFGWithConfig :: TaintConfig -> Text -> CFG -> AuditResult
@@ -238,12 +249,10 @@ checkCFGInterProcWithConfig tcfg sym cfg =
           entryState = case Map.lookup func (tcPolicies tc) of
             Nothing -> baseEntry
             Just policy -> seedArgs policy baseEntry
-          inStatesIM = runFunctionBlocksWithEntry c blockIdxs summs entryState
-          inStatesMap = IM.foldlWithKey' toMap Map.empty inStatesIM
+          inStates = runFunctionBlocksWithEntry c blockIdxs summs entryState
       in  mconcat
             [ fst (checkBlockWithSummary s summs inState (bbLines bb))
             | idx <- blockIdxs
             , let bb = indexBlock c idx
-                  inState = Map.findWithDefault entryState idx inStatesMap
+                  inState = IM.findWithDefault entryState idx inStates
             ]
-    toMap m k v = Map.insert k v m