From ee6f1379ae41cdfe4a5c28e7da0765065585c0ee Mon Sep 17 00:00:00 2001 From: Joe Hendrix Date: Wed, 12 Jun 2019 15:26:19 -0700 Subject: [PATCH 1/4] Additional cleanup to function args; bump versions. This also provides some exports needed by Reopt. --- base/macaw-base.cabal | 2 +- base/src/Data/Macaw/Analysis/FunctionArgs.hs | 184 +++++++++++-------- base/src/Data/Macaw/Discovery/State.hs | 2 +- x86/macaw-x86.cabal | 2 +- x86/src/Data/Macaw/X86/X86Reg.hs | 8 +- 5 files changed, 121 insertions(+), 77 deletions(-) diff --git a/base/macaw-base.cabal b/base/macaw-base.cabal index 7cd87f65..ec5b1e85 100644 --- a/base/macaw-base.cabal +++ b/base/macaw-base.cabal @@ -1,5 +1,5 @@ name: macaw-base -version: 0.3.7 +version: 0.3.8 author: Galois, Inc. maintainer: jhendrix@galois.com build-type: Simple diff --git a/base/src/Data/Macaw/Analysis/FunctionArgs.hs b/base/src/Data/Macaw/Analysis/FunctionArgs.hs index 6c403817..7f5e3b9e 100644 --- a/base/src/Data/Macaw/Analysis/FunctionArgs.hs +++ b/base/src/Data/Macaw/Analysis/FunctionArgs.hs @@ -52,6 +52,18 @@ import Data.Macaw.CFG.DemandSet import Data.Macaw.Discovery.State import Data.Macaw.Types +-- | Map from blocks to their predcessors within a function. +type PredBlockMap arch = Map (ArchSegmentOff arch) [ArchSegmentOff arch] + +-- | Generate map from block within a function to their predecessors +predBlockMap :: DiscoveryFunInfo arch ids -> PredBlockMap arch +predBlockMap finfo = + Map.fromListWith (++) + [ (dest, [pblockAddr b]) + | b <- Map.elems (finfo^.parsedBlocks) + , dest <- parsedTermSucc (pblockTermStmt b) + ] + ------------------------------------------------------------------------------- -- The algorithm computes the set of direct deps (i.e., from writes) @@ -93,6 +105,11 @@ data DemandSet (r :: Type -> Kind.Type) = , functionResultDemands :: !(Map (MemSegmentOff (RegAddrWidth r)) (RegisterSet r)) } +-- | Return True if the demand set indicates no registers are needed. +isEmptyDemandSet :: DemandSet r -> Bool +isEmptyDemandSet ds = + Set.null (registerDemands ds) && Map.null (functionResultDemands ds) + -- | Create a demand set for specific registers. registerDemandSet :: RegisterSet r -> DemandSet r registerDemandSet s = DemandSet { registerDemands = s @@ -145,7 +162,8 @@ data DemandType r -- | This denotes a value needed if the function at the given -- address needs the specific register as an argument. | forall tp. DemandFunctionArg (RegSegmentOff r) (r tp) - -- | This denotes demands if we need the return value of this + -- | This key is used to denote the demands associating with + -- needing to compute the the return value of the -- function stored in the given register. | forall tp. DemandFunctionResult (r tp) @@ -211,12 +229,26 @@ instance OrdF r => Semigroup (BlockDemands r) where instance OrdF r => Monoid (BlockDemands r) where mempty = BD Map.empty +-- | A cache from assignment identifiers to registers. type AssignmentCache r ids = Map (Some (AssignId ids)) (RegisterSet r) -- | Maps each register to the what information is needed to compute -- the value stored in that register. newtype FinalRegisterDemands r = FRD (Map (Some r) (DemandSet r)) +-- | Add demands for a register to collection. +insertRegDemand :: OrdF r + => r tp + -> DemandSet r + -> FinalRegisterDemands r + -> FinalRegisterDemands r +insertRegDemand r s (FRD m) + | isEmptyDemandSet s = FRD m + | otherwise = FRD (Map.insertWith mappend (Some r) s m) + +postRegisterDemands :: OrdF r => FinalRegisterDemands r -> r tp -> DemandSet r +postRegisterDemands (FRD m) r = m^.ix (Some r) + instance OrdF r => Semigroup (FinalRegisterDemands r) where FRD x <> FRD y = FRD (Map.unionWith mappend x y) @@ -289,16 +321,11 @@ data FunArgContext arch = FAC data FunctionArgsState arch ids = FAS { -- | Map from block address to the result demands map for the block. _blockTransfer :: !(Map (ArchSegmentOff arch) (FinalRegisterDemands (ArchReg arch))) - - -- | If a demand d is demanded of block address then the block demands S, s.t. - -- `blockDemandMap ^. at addr ^. at d = Just S1 + -- | If a demand d is demanded of block address then the block + -- demands S, s.t. `blockDemandMap ^. at addr ^. at d = Just S1 , _blockDemandMap :: !(Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))) - - -- | Maps each global block label to the set of blocks that have intra-procedural - -- jumps to that block. Since the function does not change, we omit the global label - , _blockPreds :: !(Map (ArchSegmentOff arch) [ArchSegmentOff arch]) - -- | A cache of the assignments and their deps. The key is not included - -- in the set of deps (but probably should be). + -- | A cache of the assignments and their deps. The key is not + -- included in the set of deps (but probably should be). , _assignmentCache :: !(AssignmentCache (ArchReg arch) ids) -- | Warnings from summarization in reverse order. , reversedWarnings :: [String] @@ -312,9 +339,6 @@ blockDemandMap :: Simple Lens (FunctionArgsState arch ids) (Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))) blockDemandMap = lens _blockDemandMap (\s v -> s { _blockDemandMap = v }) -blockPreds :: Simple Lens (FunctionArgsState arch ids) (Map (ArchSegmentOff arch) [ArchSegmentOff arch]) -blockPreds = lens _blockPreds (\s v -> s { _blockPreds = v }) - assignmentCache :: Simple Lens (FunctionArgsState arch ids) (AssignmentCache (ArchReg arch) ids) assignmentCache = lens _assignmentCache (\s v -> s { _assignmentCache = v }) @@ -322,7 +346,6 @@ initFunctionArgsState :: [String] -> FunctionArgsState arch ids initFunctionArgsState prevWarn = FAS { _blockTransfer = Map.empty , _blockDemandMap = Map.empty - , _blockPreds = Map.empty , _assignmentCache = Map.empty , reversedWarnings = prevWarn } @@ -344,14 +367,6 @@ addWarning msg = -- ---------------------------------------------------------------------------------------- -- Phase one functions --- | This registers a block in the first phase (block discovery). -addIntraproceduralJumpTarget :: {-ArchConstraints arch - => -} ArchSegmentOff arch - -> ArchSegmentOff arch - -> FunctionArgsM arch ids () -addIntraproceduralJumpTarget src dest = -- record the edge - blockPreds %= Map.insertWith (++) dest [src] - withAssignmentCache :: State (AssignmentCache (ArchReg arch) ids) a -> FunctionArgsM arch ids a withAssignmentCache m = do c <- use assignmentCache @@ -393,6 +408,32 @@ addBlockDemands :: OrdF (ArchReg arch) addBlockDemands a m = blockDemandMap %= Map.insertWith unionBlockDemands a m +-- | Given a block and a maping from register to value after the block +-- has executed, this traverses the registers that will be available +-- in future blocks, and records a mapping from those registers to +-- their input dependencies. +recordAllBlockTransfer :: forall arch ids t + . ( OrdF (ArchReg arch) + , FoldableFC (ArchFn arch) + ) + => ArchSegmentOff arch + -- ^ Address of current block. + -> RegState (ArchReg arch) (Value arch ids) + -- ^ Map from registers to values. + -> FunctionArgsM arch ids () +recordAllBlockTransfer addr regs = do + curDemands <- use $ blockTransfer . ix addr + let doReg :: FinalRegisterDemands (ArchReg arch) + -> ArchReg arch tp + -> Value arch ids tp + -> State (AssignmentCache (ArchReg arch) ids) + (FinalRegisterDemands (ArchReg arch)) + doReg m r v = do + rs' <- valueUses v + pure $! insertRegDemand r (registerDemandSet rs') m + vs <- withAssignmentCache $ MapF.foldlMWithKey doReg curDemands (regStateMap regs) + blockTransfer %= Map.insert addr vs + -- | Given a block and a maping from register to value after the block -- has executed, this traverses the registers that will be available -- in future blocks, and records a mapping from those registers to @@ -410,14 +451,14 @@ recordBlockTransfer :: forall arch ids t -- ^ List of registers that subsequent blocks may depend on. -> FunctionArgsM arch ids () recordBlockTransfer addr regs regSet = do - curDemands <- fromMaybe (FRD Map.empty) . Map.lookup addr <$> use blockTransfer + curDemands <- use $ blockTransfer . ix addr let doReg :: FinalRegisterDemands (ArchReg arch) -> Some (ArchReg arch) -> State (AssignmentCache (ArchReg arch) ids) (FinalRegisterDemands (ArchReg arch)) - doReg (FRD m) (Some r) = do - rs' <- valueUses (regs ^. boundValue r) - return $! FRD (Map.insertWith mappend (Some r) (registerDemandSet rs') m) + doReg m (Some r) = do + rs' <- valueUses (regs^.boundValue r) + pure $! insertRegDemand r (registerDemandSet rs') m vs <- withAssignmentCache $ foldlM doReg curDemands regSet blockTransfer %= Map.insert addr vs @@ -517,7 +558,7 @@ linkKnownCallReturnValues addr faddr regs mReturnAddr = do -- Update blockTransfer to indicate that for all potential -- return registers that demanding the register - let linkRetReg (FRD m) sr = FRD (Map.insertWith mappend sr (demandFunctionReturn faddr sr) m) + let linkRetReg m (Some r) = insertRegDemand r (demandFunctionReturn faddr (Some r)) m let srDemandSet :: FinalRegisterDemands (ArchReg arch) srDemandSet = foldl linkRetReg mempty retRegs @@ -628,13 +669,6 @@ summarizeBlock b = do -- Add values demanded by terminal statements case pblockTermStmt b of ParsedCall finalRegs mRetAddr -> do - -- Record the intraprocural jump target for the return address. - case mRetAddr of - Nothing -> do - pure () - Just retAddr -> do - addIntraproceduralJumpTarget addr retAddr - -- Record the demands based on the call, and add edges between -- this note and next nodes. summarizeCall addr finalRegs mRetAddr @@ -663,21 +697,17 @@ summarizeBlock b = do ParsedJump procState tgtAddr -> do -- record all propagations recordBlockTransfer addr procState archRegs - addIntraproceduralJumpTarget addr tgtAddr ParsedBranch nextRegs cond trueAddr falseAddr -> do demandValue addr cond -- record all propagations let notIP (Some r) = isNothing (testEquality r ip_reg) recordBlockTransfer addr nextRegs (filter notIP archRegs) - addIntraproceduralJumpTarget addr trueAddr - addIntraproceduralJumpTarget addr falseAddr ParsedLookupTable finalRegs lookup_idx vec -> do demandValue addr lookup_idx -- record all propagations recordBlockTransfer addr finalRegs archRegs - traverse_ (addIntraproceduralJumpTarget addr) vec ParsedReturn finalRegs -> do let retRegs = functionRetRegs ainfo @@ -698,7 +728,6 @@ summarizeBlock b = do addBlockDemands addr $ demandAlways (registerDemandSet demands) recordBlockTransfer addr finalRegs (termRegTransfers e) - traverse_ (addIntraproceduralJumpTarget addr) next_addr ParsedTranslateError _ -> do -- We ignore demands for translate errors. @@ -747,64 +776,77 @@ transferDemands :: ( MemWidth (ArchAddrWidth arch) transferDemands prev next xfer (DemandSet regs funs) = do foldlM (transferRegDemand prev next xfer) (DemandSet Set.empty funs) regs +-- | Data structure generated when computing the demands of blocks +-- within a function. +data BlockFixpointState arch = + BFS { bfsPending :: !(Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))) + -- ^ Maps each block to the demands that have not yet been backpropagated + -- to predecessors. + , bfsCurrent :: !(Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))) + } + -- | Given new demands on a register, this back propagates the demands -- to the predecessor blocks. calculateOnePred :: ( MemWidth (ArchAddrWidth arch) , OrdF (ArchReg arch) , ShowF (ArchReg arch) ) - => ArchSegmentOff arch + => Map (ArchSegmentOff arch) (FinalRegisterDemands (ArchReg arch)) + -- ^ Maps the entry point of each block in the function to the + -- register demands map for that block. + -> ArchSegmentOff arch -- ^ Address of the current block -> BlockDemands (ArchReg arch) + -- ^ New demands for this block. -> Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch)) - -- ^ Current demand map for function - -- - -- Maps block addresses to their demand map. + -- ^ Maps each block to the demands that have not yet + -- been backpropagated to predecessors. -> ArchSegmentOff arch -- ^ Address of the previous block. -> FunctionArgsM arch ids (Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))) -calculateOnePred addr (BD newDemands) pendingMap predAddr = do - xfer <- use (blockTransfer . ix predAddr) +calculateOnePred xferMap addr (BD newDemands) pendingMap predAddr = do + let xfer = xferMap^.ix predAddr -- update uses, returning value before this iteration BD seenDemands <- use (blockDemandMap . ix predAddr) demands' <- traverse (transferDemands predAddr addr xfer) newDemands - blockDemandMap %= Map.insert predAddr (unionBlockDemands (BD seenDemands) (BD demands')) - - let diff :: OrdF r => DemandSet r -> DemandSet r -> Maybe (DemandSet r) diff ds1 ds2 | ds' == mempty = Nothing | otherwise = Just ds' where ds' = ds1 `demandSetDifference` ds2 let d = Map.differenceWith diff demands' seenDemands + -- If no new entries are seen, then just return pendingMap if Map.null d then pure $! pendingMap - else + else do + blockDemandMap %= Map.insert predAddr (unionBlockDemands (BD seenDemands) (BD demands')) pure $! Map.insertWith unionBlockDemands predAddr (BD d) pendingMap --- | This updates the block map +-- | This back-propagates demands sets from blocks to their +-- predecessors until we each a fixpoint. calculateLocalFixpoint :: forall arch ids . ( MemWidth (ArchAddrWidth arch) , OrdF (ArchReg arch) , ShowF (ArchReg arch) ) - => Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch)) - -- ^ Maps block addresses to new entries in demand map - -- - -- The function + => PredBlockMap arch + -- ^ Predecessor block map for function. + -> Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch)) + -- ^ Maps each block starting address to demands that + -- have not yet been back propagated. -> FunctionArgsM arch ids () -calculateLocalFixpoint new = +calculateLocalFixpoint predMap new = case Map.maxViewWithKey new of Nothing -> pure () Just ((currAddr, newDemands), rest) -> do -- propagate new demands bacl to predecessors of this block. - preds <- use $ blockPreds . ix currAddr - next <- foldlM (calculateOnePred currAddr newDemands) rest preds - calculateLocalFixpoint next + xferMap <- use blockTransfer + next <- foldlM (calculateOnePred xferMap currAddr newDemands) rest (predMap^.ix currAddr) + calculateLocalFixpoint predMap next -- | Intermediate information used to infer global demands. data FunctionSummaries r = FunctionSummaries { @@ -844,10 +886,9 @@ decomposeMap _ addr acc (DemandFunctionArg f r) v = decomposeMap _ addr acc (DemandFunctionResult r) v = acc & funResMap %~ Map.insertWith mappend addr (FRD (Map.singleton (Some r) v)) -- Strip out callee saved registers as well. -decomposeMap ds addr acc DemandAlways v = do - +decomposeMap ds addr acc DemandAlways v = let v' = v { registerDemands = registerDemands v `Set.difference` ds } - acc & alwaysDemandMap %~ Map.insertWith mappend addr v' + in acc & alwaysDemandMap %~ Map.insertWith mappend addr v' -- | This records the registers a function demands in the global state after -- being inferred from definition. @@ -889,7 +930,7 @@ doOneFunction ctx acc (Some finfo) = do -- Propagate block demands until we are done. new <- use blockDemandMap - calculateLocalFixpoint new + calculateLocalFixpoint (predBlockMap finfo) new -- Get registers demanded by initial block map. entryDemands <- use $ blockDemandMap . ix addr @@ -917,7 +958,7 @@ calculateGlobalFixpoint s = (go (s^.alwaysDemandMap) (s^.alwaysDemandMap), rever go acc new | Just ((fun, newDemands), rest) <- Map.maxViewWithKey new = let (nexts, acc') = backPropagate acc fun newDemands - in go acc' (Map.unionWith mappend rest nexts) + in go acc' (Map.unionWith mappend rest nexts) | otherwise = acc backPropagate :: AddrDemandMap r @@ -929,11 +970,7 @@ calculateGlobalFixpoint s = (go (s^.alwaysDemandMap) (s^.alwaysDemandMap), rever -- notify all functions which call fun regs. let goRet :: RegSegmentOff r -> Set (Some r) -> DemandSet r goRet addr retRegs = - foldl (\prev r -> - let FRD m = resultDemandsMap^.ix addr - in mappend prev (m^.ix r)) - mempty - retRegs + foldMap (\(Some r) -> postRegisterDemands (resultDemandsMap^.ix addr) r) retRegs retDemands :: AddrDemandMap r retDemands = Map.mapWithKey goRet rets @@ -963,13 +1000,14 @@ functionDemands :: forall arch -- registers. -> Map BS.ByteString (ComputedRegs (ArchReg arch)) -- ^ Known symbol registers. - -> DiscoveryState arch + -> Memory (ArchAddrWidth arch) + -- ^ State of memory for resolving segment offsets. + -> [Some (DiscoveryFunInfo arch)] + -- ^ List of function to compute demands for. -> (AddrDemandMap (ArchReg arch), [String]) -functionDemands archFns addrMap symMap ds = +functionDemands archFns addrMap symMap mem entries = calculateGlobalFixpoint (foldl' (doOneFunction ctx) m0 entries) where - notKnown (Some f) = not (Map.member (discoveredFunAddr f) addrMap) - entries = filter notKnown $ exploredFunctions ds m0 :: FunctionSummaries (ArchReg arch) m0 = FunctionSummaries @@ -980,7 +1018,7 @@ functionDemands archFns addrMap symMap ds = } ctx = FAC { archDemandInfo = archFns - , ctxMemory = memory ds + , ctxMemory = mem , computedAddrSet = Set.fromList $ viewSome discoveredFunAddr <$> entries , resolvedAddrs = addrMap , knownSymbolDecls = symMap diff --git a/base/src/Data/Macaw/Discovery/State.hs b/base/src/Data/Macaw/Discovery/State.hs index 39be414d..11b23eec 100644 --- a/base/src/Data/Macaw/Discovery/State.hs +++ b/base/src/Data/Macaw/Discovery/State.hs @@ -248,8 +248,8 @@ parsedTermSucc ts = do ParsedBranch _ _ t f -> [t,f] ParsedLookupTable _ _ v -> V.toList v ParsedReturn{} -> [] - ParsedTranslateError{} -> [] ParsedArchTermStmt _ _ ret -> maybeToList ret + ParsedTranslateError{} -> [] ClassifyFailure{} -> [] ------------------------------------------------------------------------ diff --git a/x86/macaw-x86.cabal b/x86/macaw-x86.cabal index 4eeb2d7a..4b63d842 100644 --- a/x86/macaw-x86.cabal +++ b/x86/macaw-x86.cabal @@ -1,5 +1,5 @@ name: macaw-x86 -version: 0.0.1 +version: 0.3.0 author: Galois, Inc. maintainer: jhendrix@galois.com build-type: Simple diff --git a/x86/src/Data/Macaw/X86/X86Reg.hs b/x86/src/Data/Macaw/X86/X86Reg.hs index 1a509c95..c2d78f31 100644 --- a/x86/src/Data/Macaw/X86/X86Reg.hs +++ b/x86/src/Data/Macaw/X86/X86Reg.hs @@ -90,6 +90,7 @@ module Data.Macaw.X86.X86Reg , x87FPURegList , x86StateRegs , x86CalleeSavedRegs + , x86GPPArgumentRegs , x86ArgumentRegs , x86FloatArgumentRegs , x86ResultRegs @@ -446,8 +447,13 @@ x86CalleeSavedRegs = Set.fromList $ , Some X87_TopReg ] +-- | General purpose registers that may be needed for arguments according +-- to X86_64 ABI. +x86GPPArgumentRegs :: [F.Reg64] +x86GPPArgumentRegs = [F.RDI, F.RSI, F.RDX, F.RCX, F.R8, F.R9 ] + x86ArgumentRegs :: [X86Reg (BVType 64)] -x86ArgumentRegs = X86_GP <$> [ F.RDI, F.RSI, F.RDX, F.RCX, F.R8, F.R9 ] +x86ArgumentRegs = X86_GP <$> x86GPPArgumentRegs x86FloatArgumentRegs :: [X86Reg (BVType 512)] x86FloatArgumentRegs = X86_ZMMReg <$> [0..7] From dba7a2e88df24517f11d0e286e90663c2c50e6b9 Mon Sep 17 00:00:00 2001 From: Joe Hendrix Date: Wed, 12 Jun 2019 15:49:05 -0700 Subject: [PATCH 2/4] Bump submodules; version dependencies --- base/macaw-base.cabal | 2 +- deps/crucible | 2 +- deps/flexdis86 | 2 +- deps/parameterized-utils | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/base/macaw-base.cabal b/base/macaw-base.cabal index ec5b1e85..099d3bd9 100644 --- a/base/macaw-base.cabal +++ b/base/macaw-base.cabal @@ -39,7 +39,7 @@ library IntervalMap >= 0.5, lens >= 4.7, mtl, - parameterized-utils >= 2.0.0.0.100, + parameterized-utils >= 2.0.0.0.101, template-haskell, text, vector, diff --git a/deps/crucible b/deps/crucible index 51c03f50..2ca1b72e 160000 --- a/deps/crucible +++ b/deps/crucible @@ -1 +1 @@ -Subproject commit 51c03f500e514c5c9dbc7346672b07d35cc19542 +Subproject commit 2ca1b72e64816736f0f4561a82920456f40df2d8 diff --git a/deps/flexdis86 b/deps/flexdis86 index a6786e26..751ca702 160000 --- a/deps/flexdis86 +++ b/deps/flexdis86 @@ -1 +1 @@ -Subproject commit a6786e261dddf2ff3d206c7f8f76c17e50928e96 +Subproject commit 751ca702a28b7c365cefcc46c281a02c3160db49 diff --git a/deps/parameterized-utils b/deps/parameterized-utils index 1562a042..ed267619 160000 --- a/deps/parameterized-utils +++ b/deps/parameterized-utils @@ -1 +1 @@ -Subproject commit 1562a0425a0634897c0698aa0f4c4f4c56519e1c +Subproject commit ed267619990cda910e4b89a777f277805d2476c0 From e9b937923481bd77c6a90ac023e007e164802c8f Mon Sep 17 00:00:00 2001 From: Joe Hendrix Date: Wed, 12 Jun 2019 15:53:38 -0700 Subject: [PATCH 3/4] Add haddock to .travis so we catch errors in documentation strings. --- .travis.yml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.travis.yml b/.travis.yml index bd72603c..9416ba85 100644 --- a/.travis.yml +++ b/.travis.yml @@ -32,3 +32,5 @@ install: - stack build --ghc-options="-Wall -Werror" # Run tests - stack test macaw-x86 macaw-x86-symbolic --ghc-options="-Wall -Werror" + # Build documentation + - stack haddock \ No newline at end of file From cbb381401728b91a97ed5ad56f1880bdcef79b46 Mon Sep 17 00:00:00 2001 From: Joe Hendrix Date: Thu, 13 Jun 2019 09:33:58 -0700 Subject: [PATCH 4/4] Fix warnings. --- base/src/Data/Macaw/Analysis/FunctionArgs.hs | 65 +++++--------------- 1 file changed, 15 insertions(+), 50 deletions(-) diff --git a/base/src/Data/Macaw/Analysis/FunctionArgs.hs b/base/src/Data/Macaw/Analysis/FunctionArgs.hs index 7f5e3b9e..4c66d444 100644 --- a/base/src/Data/Macaw/Analysis/FunctionArgs.hs +++ b/base/src/Data/Macaw/Analysis/FunctionArgs.hs @@ -408,32 +408,6 @@ addBlockDemands :: OrdF (ArchReg arch) addBlockDemands a m = blockDemandMap %= Map.insertWith unionBlockDemands a m --- | Given a block and a maping from register to value after the block --- has executed, this traverses the registers that will be available --- in future blocks, and records a mapping from those registers to --- their input dependencies. -recordAllBlockTransfer :: forall arch ids t - . ( OrdF (ArchReg arch) - , FoldableFC (ArchFn arch) - ) - => ArchSegmentOff arch - -- ^ Address of current block. - -> RegState (ArchReg arch) (Value arch ids) - -- ^ Map from registers to values. - -> FunctionArgsM arch ids () -recordAllBlockTransfer addr regs = do - curDemands <- use $ blockTransfer . ix addr - let doReg :: FinalRegisterDemands (ArchReg arch) - -> ArchReg arch tp - -> Value arch ids tp - -> State (AssignmentCache (ArchReg arch) ids) - (FinalRegisterDemands (ArchReg arch)) - doReg m r v = do - rs' <- valueUses v - pure $! insertRegDemand r (registerDemandSet rs') m - vs <- withAssignmentCache $ MapF.foldlMWithKey doReg curDemands (regStateMap regs) - blockTransfer %= Map.insert addr vs - -- | Given a block and a maping from register to value after the block -- has executed, this traverses the registers that will be available -- in future blocks, and records a mapping from those registers to @@ -668,10 +642,10 @@ summarizeBlock b = do (pblockStmts b) -- Add values demanded by terminal statements case pblockTermStmt b of - ParsedCall finalRegs mRetAddr -> do + ParsedCall regs mRetAddr -> do -- Record the demands based on the call, and add edges between -- this note and next nodes. - summarizeCall addr finalRegs mRetAddr + summarizeCall addr regs mRetAddr PLTStub regs _ sym -> do -- Get argument registers if known for symbol. @@ -694,40 +668,40 @@ summarizeBlock b = do addBlockDemands addr $ demandAlways $ registerDemandSet $ demands - ParsedJump procState tgtAddr -> do + ParsedJump regs _tgtAddr -> do -- record all propagations - recordBlockTransfer addr procState archRegs + recordBlockTransfer addr regs archRegs - ParsedBranch nextRegs cond trueAddr falseAddr -> do + ParsedBranch regs cond _trueAddr _falseAddr -> do demandValue addr cond -- record all propagations let notIP (Some r) = isNothing (testEquality r ip_reg) - recordBlockTransfer addr nextRegs (filter notIP archRegs) + recordBlockTransfer addr regs (filter notIP archRegs) - ParsedLookupTable finalRegs lookup_idx vec -> do + ParsedLookupTable regs lookup_idx _vec -> do demandValue addr lookup_idx -- record all propagations - recordBlockTransfer addr finalRegs archRegs + recordBlockTransfer addr regs archRegs - ParsedReturn finalRegs -> do + ParsedReturn regs -> do let retRegs = functionRetRegs ainfo let regDemandSet m (Some r) = do - regs <- valueUses (finalRegs^.boundValue r) - pure $! addDemandFunctionResult r (registerDemandSet regs) m + rUses <- valueUses (regs^.boundValue r) + pure $! addDemandFunctionResult r (registerDemandSet rUses) m demands <- withAssignmentCache $ foldlM regDemandSet mempty retRegs addBlockDemands addr demands - ParsedArchTermStmt tstmt finalRegs next_addr -> do + ParsedArchTermStmt tstmt regs _nextAddr -> do -- Compute effects of terminal statement. - let e = computeArchTermStmtEffects ainfo tstmt finalRegs + let e = computeArchTermStmtEffects ainfo tstmt regs -- Demand all registers the terminal statement demands. - do let regUses s (Some r) = addValueUses s (finalRegs^.boundValue r) + do let regUses s (Some r) = addValueUses s (regs^.boundValue r) demands <- withAssignmentCache $ foldlM regUses Set.empty (termRegDemands e) addBlockDemands addr $ demandAlways (registerDemandSet demands) - recordBlockTransfer addr finalRegs (termRegTransfers e) + recordBlockTransfer addr regs (termRegTransfers e) ParsedTranslateError _ -> do -- We ignore demands for translate errors. @@ -776,15 +750,6 @@ transferDemands :: ( MemWidth (ArchAddrWidth arch) transferDemands prev next xfer (DemandSet regs funs) = do foldlM (transferRegDemand prev next xfer) (DemandSet Set.empty funs) regs --- | Data structure generated when computing the demands of blocks --- within a function. -data BlockFixpointState arch = - BFS { bfsPending :: !(Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))) - -- ^ Maps each block to the demands that have not yet been backpropagated - -- to predecessors. - , bfsCurrent :: !(Map (ArchSegmentOff arch) (BlockDemands (ArchReg arch))) - } - -- | Given new demands on a register, this back propagates the demands -- to the predecessor blocks. calculateOnePred :: ( MemWidth (ArchAddrWidth arch)