{-|
This module discovers the Functions and their internal Block CFG in
target binaries.
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Macaw.Discovery
       ( -- * DiscoveryInfo
         State.DiscoveryState(..)
       , State.emptyDiscoveryState
       , State.trustedFunctionEntryPoints
       , State.exploreFnPred
       , State.AddrSymMap
       , State.funInfo
       , State.exploredFunctions
       , State.ppDiscoveryStateBlocks
       , State.unexploredFunctions
       , Data.Macaw.Discovery.cfgFromAddrs
       , Data.Macaw.Discovery.cfgFromAddrsAndState
       , Data.Macaw.Discovery.markAddrAsFunction
       , Data.Macaw.Discovery.markAddrsAsFunction
       , State.FunctionExploreReason(..)
       , State.ppFunReason
       , State.BlockExploreReason(..)
       , Data.Macaw.Discovery.analyzeFunction
       , Data.Macaw.Discovery.analyzeDiscoveredFunctions
       , Data.Macaw.Discovery.addDiscoveredFunctionBlockTargets
       , Data.Macaw.Discovery.discoverFunction
         -- * Top level utilities
       , Data.Macaw.Discovery.completeDiscoveryState
       , Data.Macaw.Discovery.incCompleteDiscovery
       , DiscoveryOptions(..)
       , defaultDiscoveryOptions
       , DiscoveryEvent(..)
       , logDiscoveryEvent
         -- * DiscoveryFunInfo
       , State.DiscoveryFunInfo
       , State.discoveredFunAddr
       , State.discoveredFunName
       , State.discoveredFunSymbol
       , State.discoveredClassifyFailureResolutions
       , State.parsedBlocks
       , State.NoReturnFunStatus(..)
         -- * Parsed block
       , State.ParsedBlock
       , State.pblockAddr
       , State.blockSize
       , State.blockReason
       , State.blockAbstractState
       , State.pblockStmts
       , State.pblockTermStmt
       , State.ParsedTermStmt(..)
       , State.JumpTableLayout
       , State.jtlBackingAddr
       , State.jtlBackingSize
       -- * Block classifiers
       , BlockClassifier
       , defaultClassifier
       , branchClassifier
       , callClassifier
       , returnClassifier
       , directJumpClassifier
       , noreturnCallClassifier
       , tailCallClassifier
       , pltStubClassifier
       , jumpTableClassifier
         -- * Simplification
       , eliminateDeadStmts
         -- * Re-exports
       , ArchAddrWidth
       ) where

import           Control.Applicative ( Alternative((<|>)) )
import           Control.Lens ( Lens', (&), (^.), (^?), (%~), (.~), (%=), use, lens, _Just, at )
import           Control.Monad ( unless, when )
import qualified Control.Monad.ST.Lazy as STL
import qualified Control.Monad.ST.Strict as STS
import qualified Control.Monad.State.Strict as CMS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.Foldable as F
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe ( fromMaybe, maybeToList )
import qualified Data.Parameterized.Classes as PC
import qualified Data.Parameterized.Nonce as PN
import           Data.Parameterized.Some ( Some(..) )
import qualified Data.Parameterized.TraversableF as TF
import qualified Data.Sequence as Seq
import           Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified System.IO as IO

#define USE_REWRITER

import           Data.Macaw.AbsDomain.AbsState
import qualified Data.Macaw.AbsDomain.JumpBounds as Jmp
import           Data.Macaw.Architecture.Info
import           Data.Macaw.CFG
import           Data.Macaw.CFG.DemandSet
#ifdef USE_REWRITER
import           Data.Macaw.CFG.Rewriter
#endif
import           Data.Macaw.DebugLogging
import           Data.Macaw.Discovery.AbsEval
import           Data.Macaw.Discovery.Classifier
import           Data.Macaw.Discovery.Classifier.JumpTable ( jumpTableClassifier )
import           Data.Macaw.Discovery.Classifier.PLT ( pltStubClassifier )
import           Data.Macaw.Discovery.ParsedContents
import           Data.Macaw.Discovery.State as State
import qualified Data.Macaw.Memory.Permissions as Perm
import           Data.Macaw.Types
import           Data.Macaw.Utils.IncComp


{-
-- | Return true if this address was added because of the contents of a global address
-- in memory initially.
--
-- This heuristic is not very accurate, so we avoid printing errors when it leads to
-- issues.
cameFromUnsoundReason :: Map (ArchMemAddr arch) (FoundAddr arch)
                      -> CodeAddrReason (ArchAddrWidth arch)
                      -> Bool
cameFromUnsoundReason found_map rsn = do
  let prev addr =
        case Map.lookup addr found_map of
          Just info -> cameFromUnsoundReason found_map (foundReason info)
          Nothing -> error $ "Unknown reason for address " ++ show addr
  case rsn of
    InWrite{} -> True
    NextIP src  -> prev src
    CallTarget src -> prev src
    SplitAt src -> prev src
    InitAddr -> False
    CodePointerInMem{} -> True
-}

------------------------------------------------------------------------
-- Eliminate dead code in blocks

-- | Add any values needed to compute term statement to demand set.
addTermDemands :: TermStmt arch ids -> DemandComp arch ids ()
addTermDemands :: forall arch ids. TermStmt arch ids -> DemandComp arch ids ()
addTermDemands TermStmt arch ids
t =
  case TermStmt arch ids
t of
    FetchAndExecute RegState (ArchReg arch) (Value arch ids)
regs -> do
      (forall (s :: Type). Value arch ids s -> DemandComp arch ids ())
-> RegState (ArchReg arch) (Value arch ids)
-> DemandComp arch ids ()
forall {k} (t :: (k -> Type) -> Type) (f :: Type -> Type)
       (e :: k -> Type) a.
(FoldableF t, Applicative f) =>
(forall (s :: k). e s -> f a) -> t e -> f ()
TF.traverseF_ Value arch ids s -> DemandComp arch ids ()
forall arch ids (tp :: Type).
Value arch ids tp -> DemandComp arch ids ()
forall (s :: Type). Value arch ids s -> DemandComp arch ids ()
addValueDemands RegState (ArchReg arch) (Value arch ids)
regs
    TranslateError RegState (ArchReg arch) (Value arch ids)
regs Text
_ -> do
      (forall (s :: Type). Value arch ids s -> DemandComp arch ids ())
-> RegState (ArchReg arch) (Value arch ids)
-> DemandComp arch ids ()
forall {k} (t :: (k -> Type) -> Type) (f :: Type -> Type)
       (e :: k -> Type) a.
(FoldableF t, Applicative f) =>
(forall (s :: k). e s -> f a) -> t e -> f ()
TF.traverseF_ Value arch ids s -> DemandComp arch ids ()
forall arch ids (tp :: Type).
Value arch ids tp -> DemandComp arch ids ()
forall (s :: Type). Value arch ids s -> DemandComp arch ids ()
addValueDemands RegState (ArchReg arch) (Value arch ids)
regs
    ArchTermStmt ArchTermStmt arch (Value arch ids)
_ RegState (ArchReg arch) (Value arch ids)
regs -> do
      (forall (s :: Type). Value arch ids s -> DemandComp arch ids ())
-> RegState (ArchReg arch) (Value arch ids)
-> DemandComp arch ids ()
forall {k} (t :: (k -> Type) -> Type) (f :: Type -> Type)
       (e :: k -> Type) a.
(FoldableF t, Applicative f) =>
(forall (s :: k). e s -> f a) -> t e -> f ()
TF.traverseF_ Value arch ids s -> DemandComp arch ids ()
forall arch ids (tp :: Type).
Value arch ids tp -> DemandComp arch ids ()
forall (s :: Type). Value arch ids s -> DemandComp arch ids ()
addValueDemands RegState (ArchReg arch) (Value arch ids)
regs

-- | Add any assignments needed to evaluate statements with side
-- effects and terminal statement to demand set.
addBlockDemands :: Block arch ids -> DemandComp arch ids ()
addBlockDemands :: forall arch ids. Block arch ids -> DemandComp arch ids ()
addBlockDemands Block arch ids
b = do
  (Stmt arch ids -> DemandComp arch ids ())
-> [Stmt arch ids] -> DemandComp arch ids ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Stmt arch ids -> DemandComp arch ids ()
forall arch ids. Stmt arch ids -> DemandComp arch ids ()
addStmtDemands (Block arch ids -> [Stmt arch ids]
forall arch ids. Block arch ids -> [Stmt arch ids]
blockStmts Block arch ids
b)
  TermStmt arch ids -> DemandComp arch ids ()
forall arch ids. TermStmt arch ids -> DemandComp arch ids ()
addTermDemands (Block arch ids -> TermStmt arch ids
forall arch ids. Block arch ids -> TermStmt arch ids
blockTerm Block arch ids
b)

-- | Return a block after filtering out statements not needed to compute it.
elimDeadStmtsInBlock :: AssignIdSet ids -> Block arch ids -> Block arch ids
elimDeadStmtsInBlock :: forall ids arch.
AssignIdSet ids -> Block arch ids -> Block arch ids
elimDeadStmtsInBlock AssignIdSet ids
demandSet Block arch ids
b =
  Block arch ids
b { blockStmts = filter (stmtNeeded demandSet) (blockStmts b)
    }

-- | Eliminate all dead statements in blocks
eliminateDeadStmts :: ArchitectureInfo arch -> Block arch ids -> Block arch ids
eliminateDeadStmts :: forall arch ids.
ArchitectureInfo arch -> Block arch ids -> Block arch ids
eliminateDeadStmts ArchitectureInfo arch
ainfo Block arch ids
b = AssignIdSet ids -> Block arch ids -> Block arch ids
forall ids arch.
AssignIdSet ids -> Block arch ids -> Block arch ids
elimDeadStmtsInBlock AssignIdSet ids
demandSet Block arch ids
b
  where demandSet :: AssignIdSet ids
demandSet =
          DemandContext arch -> DemandComp arch ids () -> AssignIdSet ids
forall arch ids.
DemandContext arch -> DemandComp arch ids () -> AssignIdSet ids
runDemandComp (ArchitectureInfo arch -> DemandContext arch
forall arch. ArchitectureInfo arch -> DemandContext arch
archDemandContext ArchitectureInfo arch
ainfo) (DemandComp arch ids () -> AssignIdSet ids)
-> DemandComp arch ids () -> AssignIdSet ids
forall a b. (a -> b) -> a -> b
$ do
            Block arch ids -> DemandComp arch ids ()
forall arch ids. Block arch ids -> DemandComp arch ids ()
addBlockDemands Block arch ids
b

------------------------------------------------------------------------
-- Eliminate dead code in blocks

-- | Add any assignments needed to evaluate statements with side
-- effects and terminal statement to demand set.
addParsedBlockDemands :: ParsedBlock arch ids -> DemandComp arch ids ()
addParsedBlockDemands :: forall arch ids. ParsedBlock arch ids -> DemandComp arch ids ()
addParsedBlockDemands ParsedBlock arch ids
b = do
  (Stmt arch ids -> DemandComp arch ids ())
-> [Stmt arch ids] -> DemandComp arch ids ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Stmt arch ids -> DemandComp arch ids ()
forall arch ids. Stmt arch ids -> DemandComp arch ids ()
addStmtDemands (ParsedBlock arch ids -> [Stmt arch ids]
forall arch ids. ParsedBlock arch ids -> [Stmt arch ids]
pblockStmts ParsedBlock arch ids
b)
  case ParsedBlock arch ids -> ParsedTermStmt arch ids
forall arch ids. ParsedBlock arch ids -> ParsedTermStmt arch ids
pblockTermStmt ParsedBlock arch ids
b of
    ParsedCall RegState (ArchReg arch) (Value arch ids)
regs Maybe (ArchSegmentOff arch)
_ -> do
      (forall (s :: Type). Value arch ids s -> DemandComp arch ids ())
-> RegState (ArchReg arch) (Value arch ids)
-> DemandComp arch ids ()
forall {k} (t :: (k -> Type) -> Type) (f :: Type -> Type)
       (e :: k -> Type) a.
(FoldableF t, Applicative f) =>
(forall (s :: k). e s -> f a) -> t e -> f ()
TF.traverseF_ Value arch ids s -> DemandComp arch ids ()
forall arch ids (tp :: Type).
Value arch ids tp -> DemandComp arch ids ()
forall (s :: Type). Value arch ids s -> DemandComp arch ids ()
addValueDemands RegState (ArchReg arch) (Value arch ids)
regs
    PLTStub MapF (ArchReg arch) (Value arch ids)
regs ArchSegmentOff arch
_ VersionedSymbol
_ ->
      (forall (s :: Type). Value arch ids s -> DemandComp arch ids ())
-> MapF (ArchReg arch) (Value arch ids) -> DemandComp arch ids ()
forall {k} (t :: (k -> Type) -> Type) (f :: Type -> Type)
       (e :: k -> Type) a.
(FoldableF t, Applicative f) =>
(forall (s :: k). e s -> f a) -> t e -> f ()
TF.traverseF_ Value arch ids s -> DemandComp arch ids ()
forall arch ids (tp :: Type).
Value arch ids tp -> DemandComp arch ids ()
forall (s :: Type). Value arch ids s -> DemandComp arch ids ()
addValueDemands MapF (ArchReg arch) (Value arch ids)
regs
    ParsedJump RegState (ArchReg arch) (Value arch ids)
regs ArchSegmentOff arch
_ -> do
      (forall (s :: Type). Value arch ids s -> DemandComp arch ids ())
-> RegState (ArchReg arch) (Value arch ids)
-> DemandComp arch ids ()
forall {k} (t :: (k -> Type) -> Type) (f :: Type -> Type)
       (e :: k -> Type) a.
(FoldableF t, Applicative f) =>
(forall (s :: k). e s -> f a) -> t e -> f ()
TF.traverseF_ Value arch ids s -> DemandComp arch ids ()
forall arch ids (tp :: Type).
Value arch ids tp -> DemandComp arch ids ()
forall (s :: Type). Value arch ids s -> DemandComp arch ids ()
addValueDemands RegState (ArchReg arch) (Value arch ids)
regs
    ParsedBranch RegState (ArchReg arch) (Value arch ids)
regs Value arch ids BoolType
_ ArchSegmentOff arch
_ ArchSegmentOff arch
_ -> do
      (forall (s :: Type). Value arch ids s -> DemandComp arch ids ())
-> RegState (ArchReg arch) (Value arch ids)
-> DemandComp arch ids ()
forall {k} (t :: (k -> Type) -> Type) (f :: Type -> Type)
       (e :: k -> Type) a.
(FoldableF t, Applicative f) =>
(forall (s :: k). e s -> f a) -> t e -> f ()
TF.traverseF_ Value arch ids s -> DemandComp arch ids ()
forall arch ids (tp :: Type).
Value arch ids tp -> DemandComp arch ids ()
forall (s :: Type). Value arch ids s -> DemandComp arch ids ()
addValueDemands RegState (ArchReg arch) (Value arch ids)
regs
    ParsedLookupTable JumpTableLayout arch
_layout RegState (ArchReg arch) (Value arch ids)
regs ArchAddrValue arch ids
_idx Vector (ArchSegmentOff arch)
_tbl  -> do
      (forall (s :: Type). Value arch ids s -> DemandComp arch ids ())
-> RegState (ArchReg arch) (Value arch ids)
-> DemandComp arch ids ()
forall {k} (t :: (k -> Type) -> Type) (f :: Type -> Type)
       (e :: k -> Type) a.
(FoldableF t, Applicative f) =>
(forall (s :: k). e s -> f a) -> t e -> f ()
TF.traverseF_ Value arch ids s -> DemandComp arch ids ()
forall arch ids (tp :: Type).
Value arch ids tp -> DemandComp arch ids ()
forall (s :: Type). Value arch ids s -> DemandComp arch ids ()
addValueDemands RegState (ArchReg arch) (Value arch ids)
regs
    ParsedReturn RegState (ArchReg arch) (Value arch ids)
regs -> do
      (forall (s :: Type). Value arch ids s -> DemandComp arch ids ())
-> RegState (ArchReg arch) (Value arch ids)
-> DemandComp arch ids ()
forall {k} (t :: (k -> Type) -> Type) (f :: Type -> Type)
       (e :: k -> Type) a.
(FoldableF t, Applicative f) =>
(forall (s :: k). e s -> f a) -> t e -> f ()
TF.traverseF_ Value arch ids s -> DemandComp arch ids ()
forall arch ids (tp :: Type).
Value arch ids tp -> DemandComp arch ids ()
forall (s :: Type). Value arch ids s -> DemandComp arch ids ()
addValueDemands RegState (ArchReg arch) (Value arch ids)
regs
    ParsedArchTermStmt ArchTermStmt arch (Value arch ids)
_ RegState (ArchReg arch) (Value arch ids)
regs Maybe (ArchSegmentOff arch)
_ -> do
      (forall (s :: Type). Value arch ids s -> DemandComp arch ids ())
-> RegState (ArchReg arch) (Value arch ids)
-> DemandComp arch ids ()
forall {k} (t :: (k -> Type) -> Type) (f :: Type -> Type)
       (e :: k -> Type) a.
(FoldableF t, Applicative f) =>
(forall (s :: k). e s -> f a) -> t e -> f ()
TF.traverseF_ Value arch ids s -> DemandComp arch ids ()
forall arch ids (tp :: Type).
Value arch ids tp -> DemandComp arch ids ()
forall (s :: Type). Value arch ids s -> DemandComp arch ids ()
addValueDemands RegState (ArchReg arch) (Value arch ids)
regs
    ParsedTranslateError Text
_ -> do
      () -> DemandComp arch ids ()
forall a. a -> DemandComp arch ids a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
    ClassifyFailure RegState (ArchReg arch) (Value arch ids)
regs [String]
_ -> do
      (forall (s :: Type). Value arch ids s -> DemandComp arch ids ())
-> RegState (ArchReg arch) (Value arch ids)
-> DemandComp arch ids ()
forall {k} (t :: (k -> Type) -> Type) (f :: Type -> Type)
       (e :: k -> Type) a.
(FoldableF t, Applicative f) =>
(forall (s :: k). e s -> f a) -> t e -> f ()
TF.traverseF_ Value arch ids s -> DemandComp arch ids ()
forall arch ids (tp :: Type).
Value arch ids tp -> DemandComp arch ids ()
forall (s :: Type). Value arch ids s -> DemandComp arch ids ()
addValueDemands RegState (ArchReg arch) (Value arch ids)
regs

-- | Eliminate all dead statements in blocks
dropUnusedCodeInParsedBlock :: ArchitectureInfo arch
                            -> ParsedBlock arch ids
                            -> ParsedBlock arch ids
dropUnusedCodeInParsedBlock :: forall arch ids.
ArchitectureInfo arch
-> ParsedBlock arch ids -> ParsedBlock arch ids
dropUnusedCodeInParsedBlock ArchitectureInfo arch
ainfo ParsedBlock arch ids
b =
    -- Important to force the result list here, since otherwise we
    -- hold onto the entire input list
    (Stmt arch ids -> () -> ()) -> () -> [Stmt arch ids] -> ()
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Stmt arch ids -> () -> ()
forall a b. a -> b -> b
seq () [Stmt arch ids]
stmts' () -> ParsedBlock arch ids -> ParsedBlock arch ids
forall a b. a -> b -> b
`seq` ParsedBlock arch ids
b { pblockStmts = stmts' }
  where stmts' :: [Stmt arch ids]
stmts' = (Stmt arch ids -> Bool) -> [Stmt arch ids] -> [Stmt arch ids]
forall a. (a -> Bool) -> [a] -> [a]
filter Stmt arch ids -> Bool
stmtPred (ParsedBlock arch ids -> [Stmt arch ids]
forall arch ids. ParsedBlock arch ids -> [Stmt arch ids]
pblockStmts ParsedBlock arch ids
b)
        demandSet :: AssignIdSet ids
demandSet =
          DemandContext arch -> DemandComp arch ids () -> AssignIdSet ids
forall arch ids.
DemandContext arch -> DemandComp arch ids () -> AssignIdSet ids
runDemandComp (ArchitectureInfo arch -> DemandContext arch
forall arch. ArchitectureInfo arch -> DemandContext arch
archDemandContext ArchitectureInfo arch
ainfo) (DemandComp arch ids () -> AssignIdSet ids)
-> DemandComp arch ids () -> AssignIdSet ids
forall a b. (a -> b) -> a -> b
$ do
            ParsedBlock arch ids -> DemandComp arch ids ()
forall arch ids. ParsedBlock arch ids -> DemandComp arch ids ()
addParsedBlockDemands ParsedBlock arch ids
b
        stmtPred :: Stmt arch ids -> Bool
stmtPred = AssignIdSet ids -> Stmt arch ids -> Bool
forall ids arch. AssignIdSet ids -> Stmt arch ids -> Bool
stmtNeeded AssignIdSet ids
demandSet

------------------------------------------------------------------------
-- DiscoveryState utilities


-- | Return true if we should explore this function.
explorableFunction :: Memory w
                   -> (MemSegmentOff w -> Bool)
                   -> MemSegmentOff w
                   -> Bool
explorableFunction :: forall (w :: Natural).
Memory w -> (MemSegmentOff w -> Bool) -> MemSegmentOff w -> Bool
explorableFunction Memory w
mem MemSegmentOff w -> Bool
p MemSegmentOff w
addr
  | MemSegmentOff w -> Bool
forall (w :: Natural). MemSegmentOff w -> Bool
isExecutableSegOff MemSegmentOff w
addr
  , MemSegmentOff w -> Bool
p MemSegmentOff w
addr =
    AddrWidthRepr w -> (MemWidth w => Bool) -> Bool
forall (w :: Natural) a. AddrWidthRepr w -> (MemWidth w => a) -> a
addrWidthClass (Memory w -> AddrWidthRepr w
forall (w :: Natural). Memory w -> AddrWidthRepr w
memAddrWidth Memory w
mem) ((MemWidth w => Bool) -> Bool) -> (MemWidth w => Bool) -> Bool
forall a b. (a -> b) -> a -> b
$
      -- We check that the function address ignores bytes so that we do
      -- not start disassembling at a relocation or BSS region.
      case MemSegmentOff w -> Either (MemoryError w) [MemChunk w]
forall (w :: Natural).
MemWidth w =>
MemSegmentOff w -> Either (MemoryError w) [MemChunk w]
segoffContentsAfter MemSegmentOff w
addr of
        Right (ByteRegion ByteString
_:[MemChunk w]
_) -> Bool
True
        Either (MemoryError w) [MemChunk w]
_ -> Bool
False
  | Bool
otherwise = Bool
False

-- | Return true if we should explore this function.
shouldExploreFunction :: ArchSegmentOff arch
                      -> DiscoveryState arch
                      -> Bool
shouldExploreFunction :: forall arch. ArchSegmentOff arch -> DiscoveryState arch -> Bool
shouldExploreFunction MemSegmentOff (RegAddrWidth (ArchReg arch))
addr DiscoveryState arch
s
  =  Bool -> Bool
not (MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (Some (DiscoveryFunInfo arch))
-> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member MemSegmentOff (RegAddrWidth (ArchReg arch))
addr (DiscoveryState arch
sDiscoveryState arch
-> Getting
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (Some (DiscoveryFunInfo arch)))
     (DiscoveryState arch)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (Some (DiscoveryFunInfo arch)))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (Some (DiscoveryFunInfo arch))
forall s a. s -> Getting a s a -> a
^.Getting
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (Some (DiscoveryFunInfo arch)))
  (DiscoveryState arch)
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (Some (DiscoveryFunInfo arch)))
forall arch (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (Some (DiscoveryFunInfo arch))
 -> f (Map (ArchSegmentOff arch) (Some (DiscoveryFunInfo arch))))
-> DiscoveryState arch -> f (DiscoveryState arch)
funInfo))
  Bool -> Bool -> Bool
&& Bool -> Bool
not (MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (FunctionExploreReason (RegAddrWidth (ArchReg arch)))
-> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member MemSegmentOff (RegAddrWidth (ArchReg arch))
addr (DiscoveryState arch
sDiscoveryState arch
-> Getting
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (FunctionExploreReason (RegAddrWidth (ArchReg arch))))
     (DiscoveryState arch)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (FunctionExploreReason (RegAddrWidth (ArchReg arch))))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (FunctionExploreReason (RegAddrWidth (ArchReg arch)))
forall s a. s -> Getting a s a -> a
^.Getting
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (FunctionExploreReason (RegAddrWidth (ArchReg arch))))
  (DiscoveryState arch)
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (FunctionExploreReason (RegAddrWidth (ArchReg arch))))
forall arch (f :: Type -> Type).
Functor f =>
(UnexploredFunctionMap arch -> f (UnexploredFunctionMap arch))
-> DiscoveryState arch -> f (DiscoveryState arch)
unexploredFunctions))
  Bool -> Bool -> Bool
&& Memory (RegAddrWidth (ArchReg arch))
-> (MemSegmentOff (RegAddrWidth (ArchReg arch)) -> Bool)
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Bool
forall (w :: Natural).
Memory w -> (MemSegmentOff w -> Bool) -> MemSegmentOff w -> Bool
explorableFunction (DiscoveryState arch -> Memory (RegAddrWidth (ArchReg arch))
forall arch. DiscoveryState arch -> Memory (ArchAddrWidth arch)
memory DiscoveryState arch
s) (DiscoveryState arch
sDiscoveryState arch
-> Getting
     (MemSegmentOff (RegAddrWidth (ArchReg arch)) -> Bool)
     (DiscoveryState arch)
     (MemSegmentOff (RegAddrWidth (ArchReg arch)) -> Bool)
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Bool
forall s a. s -> Getting a s a -> a
^.Getting
  (MemSegmentOff (RegAddrWidth (ArchReg arch)) -> Bool)
  (DiscoveryState arch)
  (MemSegmentOff (RegAddrWidth (ArchReg arch)) -> Bool)
forall arch (f :: Type -> Type).
Functor f =>
((ArchSegmentOff arch -> Bool) -> f (ArchSegmentOff arch -> Bool))
-> DiscoveryState arch -> f (DiscoveryState arch)
exploreFnPred) MemSegmentOff (RegAddrWidth (ArchReg arch))
addr

-- | Mark a escaped code pointer as a function entry.
markAddrAsFunction :: FunctionExploreReason (ArchAddrWidth arch)
                      -- ^ Information about why the code address was discovered
                      --
                      -- Used for debugging
                   -> ArchSegmentOff arch
                   -> DiscoveryState arch
                   -> DiscoveryState arch
markAddrAsFunction :: forall arch.
FunctionExploreReason (ArchAddrWidth arch)
-> ArchSegmentOff arch
-> DiscoveryState arch
-> DiscoveryState arch
markAddrAsFunction FunctionExploreReason (RegAddrWidth (ArchReg arch))
rsn MemSegmentOff (RegAddrWidth (ArchReg arch))
addr DiscoveryState arch
s
  | MemSegmentOff (RegAddrWidth (ArchReg arch))
-> DiscoveryState arch -> Bool
forall arch. ArchSegmentOff arch -> DiscoveryState arch -> Bool
shouldExploreFunction MemSegmentOff (RegAddrWidth (ArchReg arch))
addr DiscoveryState arch
s =
    DiscoveryState arch
s DiscoveryState arch
-> (DiscoveryState arch -> DiscoveryState arch)
-> DiscoveryState arch
forall a b. a -> (a -> b) -> b
& (UnexploredFunctionMap arch
 -> Identity (UnexploredFunctionMap arch))
-> DiscoveryState arch -> Identity (DiscoveryState arch)
forall arch (f :: Type -> Type).
Functor f =>
(UnexploredFunctionMap arch -> f (UnexploredFunctionMap arch))
-> DiscoveryState arch -> f (DiscoveryState arch)
unexploredFunctions ((UnexploredFunctionMap arch
  -> Identity (UnexploredFunctionMap arch))
 -> DiscoveryState arch -> Identity (DiscoveryState arch))
-> (UnexploredFunctionMap arch -> UnexploredFunctionMap arch)
-> DiscoveryState arch
-> DiscoveryState arch
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ MemSegmentOff (RegAddrWidth (ArchReg arch))
-> FunctionExploreReason (RegAddrWidth (ArchReg arch))
-> UnexploredFunctionMap arch
-> UnexploredFunctionMap arch
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert MemSegmentOff (RegAddrWidth (ArchReg arch))
addr FunctionExploreReason (RegAddrWidth (ArchReg arch))
rsn
  | Bool
otherwise =
    DiscoveryState arch
s

-- | Mark a list of addresses as function entries with the same reason.
markAddrsAsFunction :: Foldable t
                    => FunctionExploreReason (ArchAddrWidth arch)
                    -> t (ArchSegmentOff arch)
                    -> DiscoveryState arch
                    -> DiscoveryState arch
markAddrsAsFunction :: forall (t :: Type -> Type) arch.
Foldable t =>
FunctionExploreReason (ArchAddrWidth arch)
-> t (ArchSegmentOff arch)
-> DiscoveryState arch
-> DiscoveryState arch
markAddrsAsFunction FunctionExploreReason (RegAddrWidth (ArchReg arch))
rsn t (MemSegmentOff (RegAddrWidth (ArchReg arch)))
addrs DiscoveryState arch
s0 =
  let ins :: DiscoveryState arch
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> DiscoveryState arch
ins DiscoveryState arch
s MemSegmentOff (RegAddrWidth (ArchReg arch))
a | MemSegmentOff (RegAddrWidth (ArchReg arch))
-> DiscoveryState arch -> Bool
forall arch. ArchSegmentOff arch -> DiscoveryState arch -> Bool
shouldExploreFunction MemSegmentOff (RegAddrWidth (ArchReg arch))
a DiscoveryState arch
s = DiscoveryState arch
s DiscoveryState arch
-> (DiscoveryState arch -> DiscoveryState arch)
-> DiscoveryState arch
forall a b. a -> (a -> b) -> b
& (UnexploredFunctionMap arch
 -> Identity (UnexploredFunctionMap arch))
-> DiscoveryState arch -> Identity (DiscoveryState arch)
forall arch (f :: Type -> Type).
Functor f =>
(UnexploredFunctionMap arch -> f (UnexploredFunctionMap arch))
-> DiscoveryState arch -> f (DiscoveryState arch)
unexploredFunctions ((UnexploredFunctionMap arch
  -> Identity (UnexploredFunctionMap arch))
 -> DiscoveryState arch -> Identity (DiscoveryState arch))
-> (UnexploredFunctionMap arch -> UnexploredFunctionMap arch)
-> DiscoveryState arch
-> DiscoveryState arch
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ MemSegmentOff (RegAddrWidth (ArchReg arch))
-> FunctionExploreReason (RegAddrWidth (ArchReg arch))
-> UnexploredFunctionMap arch
-> UnexploredFunctionMap arch
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert MemSegmentOff (RegAddrWidth (ArchReg arch))
a FunctionExploreReason (RegAddrWidth (ArchReg arch))
rsn
              | Bool
otherwise = DiscoveryState arch
s
   in (DiscoveryState arch
 -> MemSegmentOff (RegAddrWidth (ArchReg arch))
 -> DiscoveryState arch)
-> DiscoveryState arch
-> t (MemSegmentOff (RegAddrWidth (ArchReg arch)))
-> DiscoveryState arch
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' DiscoveryState arch
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> DiscoveryState arch
ins DiscoveryState arch
s0 t (MemSegmentOff (RegAddrWidth (ArchReg arch)))
addrs


------------------------------------------------------------------------
-- FoundAddr

-- | An address that has been found to be reachable.
data FoundAddr arch
   = FoundAddr { forall arch.
FoundAddr arch -> BlockExploreReason (ArchAddrWidth arch)
foundReason :: !(BlockExploreReason (ArchAddrWidth arch))
                 -- ^ The reason the address was found to be containing code.
               , forall arch. FoundAddr arch -> AbsBlockState (ArchReg arch)
foundAbstractState :: !(AbsBlockState (ArchReg arch))
                 -- ^ The abstract state formed from post-states that reach this address.
               , forall arch. FoundAddr arch -> InitJumpBounds arch
foundJumpBounds :: !(Jmp.InitJumpBounds arch)
                 -- ^ The abstract state formed from post-states that reach this address
                 --
                 -- This is used for jump bounds.
               }

foundReasonL :: Lens' (FoundAddr arch) (BlockExploreReason (ArchAddrWidth arch))
foundReasonL :: forall arch (f :: Type -> Type).
Functor f =>
(BlockExploreReason (ArchAddrWidth arch)
 -> f (BlockExploreReason (ArchAddrWidth arch)))
-> FoundAddr arch -> f (FoundAddr arch)
foundReasonL = (FoundAddr arch
 -> BlockExploreReason (RegAddrWidth (ArchReg arch)))
-> (FoundAddr arch
    -> BlockExploreReason (RegAddrWidth (ArchReg arch))
    -> FoundAddr arch)
-> Lens
     (FoundAddr arch)
     (FoundAddr arch)
     (BlockExploreReason (RegAddrWidth (ArchReg arch)))
     (BlockExploreReason (RegAddrWidth (ArchReg arch)))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens FoundAddr arch -> BlockExploreReason (RegAddrWidth (ArchReg arch))
forall arch.
FoundAddr arch -> BlockExploreReason (ArchAddrWidth arch)
foundReason (\FoundAddr arch
old BlockExploreReason (RegAddrWidth (ArchReg arch))
new -> FoundAddr arch
old { foundReason = new })

------------------------------------------------------------------------
-- FunState

-- | The state for the function exploration monad (funM)
data FunState arch s ids
   = FunState { forall arch s ids.
FunState arch s ids -> FunctionExploreReason (ArchAddrWidth arch)
funReason :: !(FunctionExploreReason (ArchAddrWidth arch))
              , forall arch s ids. FunState arch s ids -> NonceGenerator (ST s) ids
funNonceGen  :: !(PN.NonceGenerator (STS.ST s) ids)
              , forall arch s ids. FunState arch s ids -> ArchSegmentOff arch
curFunAddr   :: !(ArchSegmentOff arch)
                -- ^ Address of the function
              , forall arch s ids. FunState arch s ids -> DiscoveryState arch
_curFunCtx   :: !(DiscoveryState arch)
                -- ^ Discovery state without this function
              , forall arch s ids.
FunState arch s ids
-> Map (ArchSegmentOff arch) (ParsedBlock arch ids)
_curFunBlocks :: !(Map (ArchSegmentOff arch) (ParsedBlock arch ids))
                -- ^ Maps an address to the blocks associated with that address.
              , forall arch s ids.
FunState arch s ids -> Map (ArchSegmentOff arch) (FoundAddr arch)
_foundAddrs :: !(Map (ArchSegmentOff arch) (FoundAddr arch))
                -- ^ Maps found address to the pre-state for that block.
              , forall arch s ids. FunState arch s ids -> ReverseEdgeMap arch
_reverseEdges :: !(ReverseEdgeMap arch)
                -- ^ Maps each code address to the list of predecessors that
                -- affected its abstract state.
              , forall arch s ids. FunState arch s ids -> Set (ArchSegmentOff arch)
_frontier    :: !(Set (ArchSegmentOff arch))
                -- ^ Addresses to explore next.
              , forall arch s ids. FunState arch s ids -> CandidateFunctionMap arch
_newEntries :: !(CandidateFunctionMap arch)
              , forall arch s ids.
FunState arch s ids
-> [(ArchSegmentOff arch, [ArchSegmentOff arch])]
classifyFailureResolutions :: [(ArchSegmentOff arch, [ArchSegmentOff arch])]
                -- ^ The first element of each pair is the block (ending in a
                -- 'ClassifyFailure') for which the second element provides a
                -- list of known jump targets. These inform the initial
                -- frontier, but also need to be preserved as a side mapping
                -- when we construct the 'DiscoveryFunInfo'.
                --
                -- These resolutions are provided by external data (e.g.,
                -- another code discovery engine or SMT) and help resolve
                -- control flow that macaw cannot understand.
              }

-- | Discovery info
curFunCtx :: Lens' (FunState arch s ids)  (DiscoveryState arch)
curFunCtx :: forall arch s ids (f :: Type -> Type).
Functor f =>
(DiscoveryState arch -> f (DiscoveryState arch))
-> FunState arch s ids -> f (FunState arch s ids)
curFunCtx = (FunState arch s ids -> DiscoveryState arch)
-> (FunState arch s ids
    -> DiscoveryState arch -> FunState arch s ids)
-> Lens
     (FunState arch s ids)
     (FunState arch s ids)
     (DiscoveryState arch)
     (DiscoveryState arch)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens FunState arch s ids -> DiscoveryState arch
forall arch s ids. FunState arch s ids -> DiscoveryState arch
_curFunCtx (\FunState arch s ids
s DiscoveryState arch
v -> FunState arch s ids
s { _curFunCtx = v })

-- | Information about current function we are working on
curFunBlocks :: Lens' (FunState arch s ids) (Map (ArchSegmentOff arch) (ParsedBlock arch ids))
curFunBlocks :: forall arch s ids (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (ParsedBlock arch ids)
 -> f (Map (ArchSegmentOff arch) (ParsedBlock arch ids)))
-> FunState arch s ids -> f (FunState arch s ids)
curFunBlocks = (FunState arch s ids
 -> Map
      (MemSegmentOff (RegAddrWidth (ArchReg arch)))
      (ParsedBlock arch ids))
-> (FunState arch s ids
    -> Map
         (MemSegmentOff (RegAddrWidth (ArchReg arch)))
         (ParsedBlock arch ids)
    -> FunState arch s ids)
-> Lens
     (FunState arch s ids)
     (FunState arch s ids)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (ParsedBlock arch ids))
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (ParsedBlock arch ids))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens FunState arch s ids
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (ParsedBlock arch ids)
forall arch s ids.
FunState arch s ids
-> Map (ArchSegmentOff arch) (ParsedBlock arch ids)
_curFunBlocks (\FunState arch s ids
s Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (ParsedBlock arch ids)
v -> FunState arch s ids
s { _curFunBlocks = v })

foundAddrs :: Lens' (FunState arch s ids) (Map (ArchSegmentOff arch) (FoundAddr arch))
foundAddrs :: forall arch s ids (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (FoundAddr arch)
 -> f (Map (ArchSegmentOff arch) (FoundAddr arch)))
-> FunState arch s ids -> f (FunState arch s ids)
foundAddrs = (FunState arch s ids
 -> Map
      (MemSegmentOff (RegAddrWidth (ArchReg arch))) (FoundAddr arch))
-> (FunState arch s ids
    -> Map
         (MemSegmentOff (RegAddrWidth (ArchReg arch))) (FoundAddr arch)
    -> FunState arch s ids)
-> Lens
     (FunState arch s ids)
     (FunState arch s ids)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch))) (FoundAddr arch))
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch))) (FoundAddr arch))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens FunState arch s ids
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch))) (FoundAddr arch)
forall arch s ids.
FunState arch s ids -> Map (ArchSegmentOff arch) (FoundAddr arch)
_foundAddrs (\FunState arch s ids
s Map (MemSegmentOff (RegAddrWidth (ArchReg arch))) (FoundAddr arch)
v -> FunState arch s ids
s { _foundAddrs = v })

newEntries :: Lens' (FunState arch s ids) (CandidateFunctionMap arch)
newEntries :: forall arch s ids (f :: Type -> Type).
Functor f =>
(CandidateFunctionMap arch -> f (CandidateFunctionMap arch))
-> FunState arch s ids -> f (FunState arch s ids)
newEntries = (FunState arch s ids
 -> Map
      (MemSegmentOff (RegAddrWidth (ArchReg arch)))
      (FunctionExploreReason (RegAddrWidth (ArchReg arch))))
-> (FunState arch s ids
    -> Map
         (MemSegmentOff (RegAddrWidth (ArchReg arch)))
         (FunctionExploreReason (RegAddrWidth (ArchReg arch)))
    -> FunState arch s ids)
-> Lens
     (FunState arch s ids)
     (FunState arch s ids)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (FunctionExploreReason (RegAddrWidth (ArchReg arch))))
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (FunctionExploreReason (RegAddrWidth (ArchReg arch))))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens FunState arch s ids
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (FunctionExploreReason (RegAddrWidth (ArchReg arch)))
forall arch s ids. FunState arch s ids -> CandidateFunctionMap arch
_newEntries (\FunState arch s ids
s Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (FunctionExploreReason (RegAddrWidth (ArchReg arch)))
v -> FunState arch s ids
s { _newEntries = v })

-- | Add a block to the current function blocks. If this overlaps with an
-- existing block, split them so that there's no overlap.
addFunBlock
  :: MemWidth (ArchAddrWidth arch)
  => ArchSegmentOff arch
  -> ParsedBlock arch ids
  -> FunState arch s ids
  -> FunState arch s ids
addFunBlock :: forall arch ids s.
MemWidth (ArchAddrWidth arch) =>
ArchSegmentOff arch
-> ParsedBlock arch ids
-> FunState arch s ids
-> FunState arch s ids
addFunBlock MemSegmentOff (ArchAddrWidth arch)
segment ParsedBlock arch ids
block FunState arch s ids
s =
  case MemSegmentOff (ArchAddrWidth arch)
-> Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids)
-> Maybe (MemSegmentOff (ArchAddrWidth arch), ParsedBlock arch ids)
forall k v. Ord k => k -> Map k v -> Maybe (k, v)
Map.lookupLT MemSegmentOff (ArchAddrWidth arch)
segment (FunState arch s ids
s FunState arch s ids
-> Getting
     (Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids))
     (FunState arch s ids)
     (Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids))
-> Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids))
  (FunState arch s ids)
  (Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids))
forall arch s ids (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (ParsedBlock arch ids)
 -> f (Map (ArchSegmentOff arch) (ParsedBlock arch ids)))
-> FunState arch s ids -> f (FunState arch s ids)
curFunBlocks) of
    Just (MemSegmentOff (ArchAddrWidth arch)
bSegment, ParsedBlock arch ids
bBlock)
        -- very sneaky way to check that they are in the same segment (a
        -- Nothing result from diffSegmentOff will never be greater than a
        -- Just) and that they are overlapping (the block size is bigger than
        -- you'd expect given the address difference)
        | MemSegmentOff (ArchAddrWidth arch)
-> MemSegmentOff (ArchAddrWidth arch) -> Maybe Integer
forall (w :: Natural).
MemWidth w =>
MemSegmentOff w -> MemSegmentOff w -> Maybe Integer
diffSegmentOff MemSegmentOff (ArchAddrWidth arch)
bSegment MemSegmentOff (ArchAddrWidth arch)
segment Maybe Integer -> Maybe Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer -> Maybe Integer
forall a. a -> Maybe a
Just (-Int -> Integer
forall a. Integral a => a -> Integer
toInteger (ParsedBlock arch ids -> Int
forall arch ids. ParsedBlock arch ids -> Int
blockSize ParsedBlock arch ids
bBlock))
        -- put the overlapped segment back in the frontier
        -> FunState arch s ids
s FunState arch s ids
-> (FunState arch s ids -> FunState arch s ids)
-> FunState arch s ids
forall a b. a -> (a -> b) -> b
& (Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids)
 -> Identity
      (Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids)))
-> FunState arch s ids -> Identity (FunState arch s ids)
forall arch s ids (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (ParsedBlock arch ids)
 -> f (Map (ArchSegmentOff arch) (ParsedBlock arch ids)))
-> FunState arch s ids -> f (FunState arch s ids)
curFunBlocks ((Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids)
  -> Identity
       (Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids)))
 -> FunState arch s ids -> Identity (FunState arch s ids))
-> (Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids)
    -> Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids))
-> FunState arch s ids
-> FunState arch s ids
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (MemSegmentOff (ArchAddrWidth arch)
-> ParsedBlock arch ids
-> Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids)
-> Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert MemSegmentOff (ArchAddrWidth arch)
segment ParsedBlock arch ids
block (Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids)
 -> Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids))
-> (Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids)
    -> Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids))
-> Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids)
-> Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemSegmentOff (ArchAddrWidth arch)
-> Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids)
-> Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete MemSegmentOff (ArchAddrWidth arch)
bSegment)
             FunState arch s ids
-> (FunState arch s ids -> FunState arch s ids)
-> FunState arch s ids
forall a b. a -> (a -> b) -> b
& (Map (MemSegmentOff (ArchAddrWidth arch)) (FoundAddr arch)
 -> Identity
      (Map (MemSegmentOff (ArchAddrWidth arch)) (FoundAddr arch)))
-> FunState arch s ids -> Identity (FunState arch s ids)
forall arch s ids (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (FoundAddr arch)
 -> f (Map (ArchSegmentOff arch) (FoundAddr arch)))
-> FunState arch s ids -> f (FunState arch s ids)
foundAddrs((Map (MemSegmentOff (ArchAddrWidth arch)) (FoundAddr arch)
  -> Identity
       (Map (MemSegmentOff (ArchAddrWidth arch)) (FoundAddr arch)))
 -> FunState arch s ids -> Identity (FunState arch s ids))
-> ((BlockExploreReason (ArchAddrWidth arch)
     -> Identity (BlockExploreReason (ArchAddrWidth arch)))
    -> Map (MemSegmentOff (ArchAddrWidth arch)) (FoundAddr arch)
    -> Identity
         (Map (MemSegmentOff (ArchAddrWidth arch)) (FoundAddr arch)))
-> (BlockExploreReason (ArchAddrWidth arch)
    -> Identity (BlockExploreReason (ArchAddrWidth arch)))
-> FunState arch s ids
-> Identity (FunState arch s ids)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Index (Map (MemSegmentOff (ArchAddrWidth arch)) (FoundAddr arch))
-> Lens'
     (Map (MemSegmentOff (ArchAddrWidth arch)) (FoundAddr arch))
     (Maybe
        (IxValue
           (Map (MemSegmentOff (ArchAddrWidth arch)) (FoundAddr arch))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map (MemSegmentOff (ArchAddrWidth arch)) (FoundAddr arch))
MemSegmentOff (ArchAddrWidth arch)
bSegment((Maybe (FoundAddr arch) -> Identity (Maybe (FoundAddr arch)))
 -> Map (MemSegmentOff (ArchAddrWidth arch)) (FoundAddr arch)
 -> Identity
      (Map (MemSegmentOff (ArchAddrWidth arch)) (FoundAddr arch)))
-> ((BlockExploreReason (ArchAddrWidth arch)
     -> Identity (BlockExploreReason (ArchAddrWidth arch)))
    -> Maybe (FoundAddr arch) -> Identity (Maybe (FoundAddr arch)))
-> (BlockExploreReason (ArchAddrWidth arch)
    -> Identity (BlockExploreReason (ArchAddrWidth arch)))
-> Map (MemSegmentOff (ArchAddrWidth arch)) (FoundAddr arch)
-> Identity
     (Map (MemSegmentOff (ArchAddrWidth arch)) (FoundAddr arch))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(FoundAddr arch -> Identity (FoundAddr arch))
-> Maybe (FoundAddr arch) -> Identity (Maybe (FoundAddr arch))
forall a b (p :: Type -> Type -> Type) (f :: Type -> Type).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just((FoundAddr arch -> Identity (FoundAddr arch))
 -> Maybe (FoundAddr arch) -> Identity (Maybe (FoundAddr arch)))
-> ((BlockExploreReason (ArchAddrWidth arch)
     -> Identity (BlockExploreReason (ArchAddrWidth arch)))
    -> FoundAddr arch -> Identity (FoundAddr arch))
-> (BlockExploreReason (ArchAddrWidth arch)
    -> Identity (BlockExploreReason (ArchAddrWidth arch)))
-> Maybe (FoundAddr arch)
-> Identity (Maybe (FoundAddr arch))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(BlockExploreReason (ArchAddrWidth arch)
 -> Identity (BlockExploreReason (ArchAddrWidth arch)))
-> FoundAddr arch -> Identity (FoundAddr arch)
forall arch (f :: Type -> Type).
Functor f =>
(BlockExploreReason (ArchAddrWidth arch)
 -> f (BlockExploreReason (ArchAddrWidth arch)))
-> FoundAddr arch -> f (FoundAddr arch)
foundReasonL ((BlockExploreReason (ArchAddrWidth arch)
  -> Identity (BlockExploreReason (ArchAddrWidth arch)))
 -> FunState arch s ids -> Identity (FunState arch s ids))
-> (BlockExploreReason (ArchAddrWidth arch)
    -> BlockExploreReason (ArchAddrWidth arch))
-> FunState arch s ids
-> FunState arch s ids
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ MemSegmentOff (ArchAddrWidth arch)
-> BlockExploreReason (ArchAddrWidth arch)
-> BlockExploreReason (ArchAddrWidth arch)
forall (w :: Natural).
MemSegmentOff w -> BlockExploreReason w -> BlockExploreReason w
SplitAt MemSegmentOff (ArchAddrWidth arch)
segment
             FunState arch s ids
-> (FunState arch s ids -> FunState arch s ids)
-> FunState arch s ids
forall a b. a -> (a -> b) -> b
& (Set (MemSegmentOff (ArchAddrWidth arch))
 -> Identity (Set (MemSegmentOff (ArchAddrWidth arch))))
-> FunState arch s ids -> Identity (FunState arch s ids)
forall arch s ids (f :: Type -> Type).
Functor f =>
(Set (ArchSegmentOff arch) -> f (Set (ArchSegmentOff arch)))
-> FunState arch s ids -> f (FunState arch s ids)
frontier ((Set (MemSegmentOff (ArchAddrWidth arch))
  -> Identity (Set (MemSegmentOff (ArchAddrWidth arch))))
 -> FunState arch s ids -> Identity (FunState arch s ids))
-> (Set (MemSegmentOff (ArchAddrWidth arch))
    -> Set (MemSegmentOff (ArchAddrWidth arch)))
-> FunState arch s ids
-> FunState arch s ids
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ MemSegmentOff (ArchAddrWidth arch)
-> Set (MemSegmentOff (ArchAddrWidth arch))
-> Set (MemSegmentOff (ArchAddrWidth arch))
forall a. Ord a => a -> Set a -> Set a
Set.insert MemSegmentOff (ArchAddrWidth arch)
bSegment
    Maybe (MemSegmentOff (ArchAddrWidth arch), ParsedBlock arch ids)
_ -> FunState arch s ids
s FunState arch s ids
-> (FunState arch s ids -> FunState arch s ids)
-> FunState arch s ids
forall a b. a -> (a -> b) -> b
& (Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids)
 -> Identity
      (Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids)))
-> FunState arch s ids -> Identity (FunState arch s ids)
forall arch s ids (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (ParsedBlock arch ids)
 -> f (Map (ArchSegmentOff arch) (ParsedBlock arch ids)))
-> FunState arch s ids -> f (FunState arch s ids)
curFunBlocks ((Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids)
  -> Identity
       (Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids)))
 -> FunState arch s ids -> Identity (FunState arch s ids))
-> (Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids)
    -> Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids))
-> FunState arch s ids
-> FunState arch s ids
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ MemSegmentOff (ArchAddrWidth arch)
-> ParsedBlock arch ids
-> Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids)
-> Map (MemSegmentOff (ArchAddrWidth arch)) (ParsedBlock arch ids)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert MemSegmentOff (ArchAddrWidth arch)
segment ParsedBlock arch ids
block

type ReverseEdgeMap arch = Map (ArchSegmentOff arch) (Set (ArchSegmentOff arch))

-- | Maps each code address to the list of predecessors that
-- affected its abstract state.
reverseEdges :: Lens' (FunState arch s ids) (ReverseEdgeMap arch)
reverseEdges :: forall arch s ids (f :: Type -> Type).
Functor f =>
(ReverseEdgeMap arch -> f (ReverseEdgeMap arch))
-> FunState arch s ids -> f (FunState arch s ids)
reverseEdges = (FunState arch s ids
 -> Map
      (MemSegmentOff (RegAddrWidth (ArchReg arch)))
      (Set (MemSegmentOff (RegAddrWidth (ArchReg arch)))))
-> (FunState arch s ids
    -> Map
         (MemSegmentOff (RegAddrWidth (ArchReg arch)))
         (Set (MemSegmentOff (RegAddrWidth (ArchReg arch))))
    -> FunState arch s ids)
-> Lens
     (FunState arch s ids)
     (FunState arch s ids)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (Set (MemSegmentOff (RegAddrWidth (ArchReg arch)))))
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (Set (MemSegmentOff (RegAddrWidth (ArchReg arch)))))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens FunState arch s ids
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (Set (MemSegmentOff (RegAddrWidth (ArchReg arch))))
forall arch s ids. FunState arch s ids -> ReverseEdgeMap arch
_reverseEdges (\FunState arch s ids
s Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (Set (MemSegmentOff (RegAddrWidth (ArchReg arch))))
v -> FunState arch s ids
s { _reverseEdges = v })

-- | Set of addresses to explore next.
--
-- This is a map so that we can associate a reason why a code address
-- was added to the frontier.
frontier :: Lens' (FunState arch s ids) (Set (ArchSegmentOff arch))
frontier :: forall arch s ids (f :: Type -> Type).
Functor f =>
(Set (ArchSegmentOff arch) -> f (Set (ArchSegmentOff arch)))
-> FunState arch s ids -> f (FunState arch s ids)
frontier = (FunState arch s ids
 -> Set (MemSegmentOff (RegAddrWidth (ArchReg arch))))
-> (FunState arch s ids
    -> Set (MemSegmentOff (RegAddrWidth (ArchReg arch)))
    -> FunState arch s ids)
-> Lens
     (FunState arch s ids)
     (FunState arch s ids)
     (Set (MemSegmentOff (RegAddrWidth (ArchReg arch))))
     (Set (MemSegmentOff (RegAddrWidth (ArchReg arch))))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens FunState arch s ids
-> Set (MemSegmentOff (RegAddrWidth (ArchReg arch)))
forall arch s ids. FunState arch s ids -> Set (ArchSegmentOff arch)
_frontier (\FunState arch s ids
s Set (MemSegmentOff (RegAddrWidth (ArchReg arch)))
v -> FunState arch s ids
s { _frontier = v })

------------------------------------------------------------------------
-- FunM

-- | A newtype around a function
newtype FunM arch s ids a = FunM { forall arch s ids a.
FunM arch s ids a -> StateT (FunState arch s ids) (ST s) a
unFunM :: CMS.StateT (FunState arch s ids) (STL.ST s) a }
  deriving ((forall a b. (a -> b) -> FunM arch s ids a -> FunM arch s ids b)
-> (forall a b. a -> FunM arch s ids b -> FunM arch s ids a)
-> Functor (FunM arch s ids)
forall a b. a -> FunM arch s ids b -> FunM arch s ids a
forall a b. (a -> b) -> FunM arch s ids a -> FunM arch s ids b
forall arch s ids a b. a -> FunM arch s ids b -> FunM arch s ids a
forall arch s ids a b.
(a -> b) -> FunM arch s ids a -> FunM arch s ids b
forall (f :: Type -> Type).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall arch s ids a b.
(a -> b) -> FunM arch s ids a -> FunM arch s ids b
fmap :: forall a b. (a -> b) -> FunM arch s ids a -> FunM arch s ids b
$c<$ :: forall arch s ids a b. a -> FunM arch s ids b -> FunM arch s ids a
<$ :: forall a b. a -> FunM arch s ids b -> FunM arch s ids a
Functor, Functor (FunM arch s ids)
Functor (FunM arch s ids) =>
(forall a. a -> FunM arch s ids a)
-> (forall a b.
    FunM arch s ids (a -> b) -> FunM arch s ids a -> FunM arch s ids b)
-> (forall a b c.
    (a -> b -> c)
    -> FunM arch s ids a -> FunM arch s ids b -> FunM arch s ids c)
-> (forall a b.
    FunM arch s ids a -> FunM arch s ids b -> FunM arch s ids b)
-> (forall a b.
    FunM arch s ids a -> FunM arch s ids b -> FunM arch s ids a)
-> Applicative (FunM arch s ids)
forall a. a -> FunM arch s ids a
forall a b.
FunM arch s ids a -> FunM arch s ids b -> FunM arch s ids a
forall a b.
FunM arch s ids a -> FunM arch s ids b -> FunM arch s ids b
forall a b.
FunM arch s ids (a -> b) -> FunM arch s ids a -> FunM arch s ids b
forall arch s ids. Functor (FunM arch s ids)
forall a b c.
(a -> b -> c)
-> FunM arch s ids a -> FunM arch s ids b -> FunM arch s ids c
forall arch s ids a. a -> FunM arch s ids a
forall arch s ids a b.
FunM arch s ids a -> FunM arch s ids b -> FunM arch s ids a
forall arch s ids a b.
FunM arch s ids a -> FunM arch s ids b -> FunM arch s ids b
forall arch s ids a b.
FunM arch s ids (a -> b) -> FunM arch s ids a -> FunM arch s ids b
forall arch s ids a b c.
(a -> b -> c)
-> FunM arch s ids a -> FunM arch s ids b -> FunM arch s ids c
forall (f :: Type -> Type).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall arch s ids a. a -> FunM arch s ids a
pure :: forall a. a -> FunM arch s ids a
$c<*> :: forall arch s ids a b.
FunM arch s ids (a -> b) -> FunM arch s ids a -> FunM arch s ids b
<*> :: forall a b.
FunM arch s ids (a -> b) -> FunM arch s ids a -> FunM arch s ids b
$cliftA2 :: forall arch s ids a b c.
(a -> b -> c)
-> FunM arch s ids a -> FunM arch s ids b -> FunM arch s ids c
liftA2 :: forall a b c.
(a -> b -> c)
-> FunM arch s ids a -> FunM arch s ids b -> FunM arch s ids c
$c*> :: forall arch s ids a b.
FunM arch s ids a -> FunM arch s ids b -> FunM arch s ids b
*> :: forall a b.
FunM arch s ids a -> FunM arch s ids b -> FunM arch s ids b
$c<* :: forall arch s ids a b.
FunM arch s ids a -> FunM arch s ids b -> FunM arch s ids a
<* :: forall a b.
FunM arch s ids a -> FunM arch s ids b -> FunM arch s ids a
Applicative, Applicative (FunM arch s ids)
Applicative (FunM arch s ids) =>
(forall a b.
 FunM arch s ids a -> (a -> FunM arch s ids b) -> FunM arch s ids b)
-> (forall a b.
    FunM arch s ids a -> FunM arch s ids b -> FunM arch s ids b)
-> (forall a. a -> FunM arch s ids a)
-> Monad (FunM arch s ids)
forall a. a -> FunM arch s ids a
forall a b.
FunM arch s ids a -> FunM arch s ids b -> FunM arch s ids b
forall a b.
FunM arch s ids a -> (a -> FunM arch s ids b) -> FunM arch s ids b
forall arch s ids. Applicative (FunM arch s ids)
forall arch s ids a. a -> FunM arch s ids a
forall arch s ids a b.
FunM arch s ids a -> FunM arch s ids b -> FunM arch s ids b
forall arch s ids a b.
FunM arch s ids a -> (a -> FunM arch s ids b) -> FunM arch s ids b
forall (m :: Type -> Type).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall arch s ids a b.
FunM arch s ids a -> (a -> FunM arch s ids b) -> FunM arch s ids b
>>= :: forall a b.
FunM arch s ids a -> (a -> FunM arch s ids b) -> FunM arch s ids b
$c>> :: forall arch s ids a b.
FunM arch s ids a -> FunM arch s ids b -> FunM arch s ids b
>> :: forall a b.
FunM arch s ids a -> FunM arch s ids b -> FunM arch s ids b
$creturn :: forall arch s ids a. a -> FunM arch s ids a
return :: forall a. a -> FunM arch s ids a
Monad)

instance CMS.MonadState (FunState arch s ids) (FunM arch s ids) where
  get :: FunM arch s ids (FunState arch s ids)
get = StateT (FunState arch s ids) (ST s) (FunState arch s ids)
-> FunM arch s ids (FunState arch s ids)
forall arch s ids a.
StateT (FunState arch s ids) (ST s) a -> FunM arch s ids a
FunM StateT (FunState arch s ids) (ST s) (FunState arch s ids)
forall s (m :: Type -> Type). MonadState s m => m s
CMS.get
  put :: FunState arch s ids -> FunM arch s ids ()
put FunState arch s ids
s = StateT (FunState arch s ids) (ST s) () -> FunM arch s ids ()
forall arch s ids a.
StateT (FunState arch s ids) (ST s) a -> FunM arch s ids a
FunM (StateT (FunState arch s ids) (ST s) () -> FunM arch s ids ())
-> StateT (FunState arch s ids) (ST s) () -> FunM arch s ids ()
forall a b. (a -> b) -> a -> b
$ FunState arch s ids -> StateT (FunState arch s ids) (ST s) ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
CMS.put FunState arch s ids
s

------------------------------------------------------------------------
-- Transfer functions

-- | Joins in the new abstract state and returns the locations for
-- which the new state is changed.
mergeIntraJump  :: ArchitectureInfo arch
                -> ArchSegmentOff arch
                  -- ^ Source label that we are jumping from.
                -> Jmp.IntraJumpTarget arch
                   -- ^ Target we are jumping to.
                -> FunM arch s ids ()
mergeIntraJump :: forall arch s ids.
ArchitectureInfo arch
-> ArchSegmentOff arch
-> IntraJumpTarget arch
-> FunM arch s ids ()
mergeIntraJump ArchitectureInfo arch
info ArchSegmentOff arch
src (ArchSegmentOff arch
tgt, AbsBlockState (ArchReg arch)
ab, InitJumpBounds arch
bnds) = do
  ArchitectureInfo arch -> forall a. (ArchConstraints arch => a) -> a
forall arch.
ArchitectureInfo arch -> forall a. (ArchConstraints arch => a) -> a
withArchConstraints ArchitectureInfo arch
info ((ArchConstraints arch => FunM arch s ids ())
 -> FunM arch s ids ())
-> (ArchConstraints arch => FunM arch s ids ())
-> FunM arch s ids ()
forall a b. (a -> b) -> a -> b
$ do
   Bool -> FunM arch s ids () -> FunM arch s ids ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (AbsBlockState (ArchReg arch) -> Bool
forall (r :: Type -> Type). AbsBlockState r -> Bool
absStackHasReturnAddr AbsBlockState (ArchReg arch)
ab) (FunM arch s ids () -> FunM arch s ids ())
-> FunM arch s ids () -> FunM arch s ids ()
forall a b. (a -> b) -> a -> b
$ do
    DebugClass -> String -> FunM arch s ids () -> FunM arch s ids ()
forall a. (?loc::CallStack) => DebugClass -> String -> a -> a
debug DebugClass
DCFG (String
"WARNING: Missing return value in jump from " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ArchSegmentOff arch -> String
forall a. Show a => a -> String
show ArchSegmentOff arch
src String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ AbsBlockState (ArchReg arch) -> String
forall a. Show a => a -> String
show AbsBlockState (ArchReg arch)
ab) (FunM arch s ids () -> FunM arch s ids ())
-> FunM arch s ids () -> FunM arch s ids ()
forall a b. (a -> b) -> a -> b
$
      () -> FunM arch s ids ()
forall a. a -> FunM arch s ids a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
   -- Associate a new abstract state with the code region.
   Map (ArchSegmentOff arch) (FoundAddr arch)
foundMap <- Getting
  (Map (ArchSegmentOff arch) (FoundAddr arch))
  (FunState arch s ids)
  (Map (ArchSegmentOff arch) (FoundAddr arch))
-> FunM arch s ids (Map (ArchSegmentOff arch) (FoundAddr arch))
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use Getting
  (Map (ArchSegmentOff arch) (FoundAddr arch))
  (FunState arch s ids)
  (Map (ArchSegmentOff arch) (FoundAddr arch))
forall arch s ids (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (FoundAddr arch)
 -> f (Map (ArchSegmentOff arch) (FoundAddr arch)))
-> FunState arch s ids -> f (FunState arch s ids)
foundAddrs
   case ArchSegmentOff arch
-> Map (ArchSegmentOff arch) (FoundAddr arch)
-> Maybe (FoundAddr arch)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ArchSegmentOff arch
tgt Map (ArchSegmentOff arch) (FoundAddr arch)
foundMap of
    -- We have seen this block before, so need to join and see if
    -- the results is changed.
    Just FoundAddr arch
old_info -> do
      case AbsBlockState (ArchReg arch)
-> AbsBlockState (ArchReg arch)
-> Maybe (AbsBlockState (ArchReg arch))
forall (r :: Type -> Type).
RegisterInfo r =>
AbsBlockState r -> AbsBlockState r -> Maybe (AbsBlockState r)
joinAbsBlockState (FoundAddr arch -> AbsBlockState (ArchReg arch)
forall arch. FoundAddr arch -> AbsBlockState (ArchReg arch)
foundAbstractState FoundAddr arch
old_info) AbsBlockState (ArchReg arch)
ab of
        Maybe (AbsBlockState (ArchReg arch))
Nothing  -> () -> FunM arch s ids ()
forall a. a -> FunM arch s ids a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
        Just AbsBlockState (ArchReg arch)
new -> do
          let new_info :: FoundAddr arch
new_info = FoundAddr arch
old_info { foundAbstractState = new }
          (Map (ArchSegmentOff arch) (FoundAddr arch)
 -> Identity (Map (ArchSegmentOff arch) (FoundAddr arch)))
-> FunState arch s ids -> Identity (FunState arch s ids)
forall arch s ids (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (FoundAddr arch)
 -> f (Map (ArchSegmentOff arch) (FoundAddr arch)))
-> FunState arch s ids -> f (FunState arch s ids)
foundAddrs   ((Map (ArchSegmentOff arch) (FoundAddr arch)
  -> Identity (Map (ArchSegmentOff arch) (FoundAddr arch)))
 -> FunState arch s ids -> Identity (FunState arch s ids))
-> (Map (ArchSegmentOff arch) (FoundAddr arch)
    -> Map (ArchSegmentOff arch) (FoundAddr arch))
-> FunM arch s ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ArchSegmentOff arch
-> FoundAddr arch
-> Map (ArchSegmentOff arch) (FoundAddr arch)
-> Map (ArchSegmentOff arch) (FoundAddr arch)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ArchSegmentOff arch
tgt FoundAddr arch
new_info
          (ReverseEdgeMap arch -> Identity (ReverseEdgeMap arch))
-> FunState arch s ids -> Identity (FunState arch s ids)
forall arch s ids (f :: Type -> Type).
Functor f =>
(ReverseEdgeMap arch -> f (ReverseEdgeMap arch))
-> FunState arch s ids -> f (FunState arch s ids)
reverseEdges ((ReverseEdgeMap arch -> Identity (ReverseEdgeMap arch))
 -> FunState arch s ids -> Identity (FunState arch s ids))
-> (ReverseEdgeMap arch -> ReverseEdgeMap arch)
-> FunM arch s ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Set (ArchSegmentOff arch)
 -> Set (ArchSegmentOff arch) -> Set (ArchSegmentOff arch))
-> ArchSegmentOff arch
-> Set (ArchSegmentOff arch)
-> ReverseEdgeMap arch
-> ReverseEdgeMap arch
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Set (ArchSegmentOff arch)
-> Set (ArchSegmentOff arch) -> Set (ArchSegmentOff arch)
forall a. Ord a => Set a -> Set a -> Set a
Set.union ArchSegmentOff arch
tgt (ArchSegmentOff arch -> Set (ArchSegmentOff arch)
forall a. a -> Set a
Set.singleton ArchSegmentOff arch
src)
          (Set (ArchSegmentOff arch) -> Identity (Set (ArchSegmentOff arch)))
-> FunState arch s ids -> Identity (FunState arch s ids)
forall arch s ids (f :: Type -> Type).
Functor f =>
(Set (ArchSegmentOff arch) -> f (Set (ArchSegmentOff arch)))
-> FunState arch s ids -> f (FunState arch s ids)
frontier ((Set (ArchSegmentOff arch)
  -> Identity (Set (ArchSegmentOff arch)))
 -> FunState arch s ids -> Identity (FunState arch s ids))
-> (Set (ArchSegmentOff arch) -> Set (ArchSegmentOff arch))
-> FunM arch s ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ArchSegmentOff arch
-> Set (ArchSegmentOff arch) -> Set (ArchSegmentOff arch)
forall a. Ord a => a -> Set a -> Set a
Set.insert ArchSegmentOff arch
tgt
    -- We haven't seen this block before
    Maybe (FoundAddr arch)
Nothing -> do
      (ReverseEdgeMap arch -> Identity (ReverseEdgeMap arch))
-> FunState arch s ids -> Identity (FunState arch s ids)
forall arch s ids (f :: Type -> Type).
Functor f =>
(ReverseEdgeMap arch -> f (ReverseEdgeMap arch))
-> FunState arch s ids -> f (FunState arch s ids)
reverseEdges ((ReverseEdgeMap arch -> Identity (ReverseEdgeMap arch))
 -> FunState arch s ids -> Identity (FunState arch s ids))
-> (ReverseEdgeMap arch -> ReverseEdgeMap arch)
-> FunM arch s ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Set (ArchSegmentOff arch)
 -> Set (ArchSegmentOff arch) -> Set (ArchSegmentOff arch))
-> ArchSegmentOff arch
-> Set (ArchSegmentOff arch)
-> ReverseEdgeMap arch
-> ReverseEdgeMap arch
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Set (ArchSegmentOff arch)
-> Set (ArchSegmentOff arch) -> Set (ArchSegmentOff arch)
forall a. Ord a => Set a -> Set a -> Set a
Set.union ArchSegmentOff arch
tgt (ArchSegmentOff arch -> Set (ArchSegmentOff arch)
forall a. a -> Set a
Set.singleton ArchSegmentOff arch
src)
      (Set (ArchSegmentOff arch) -> Identity (Set (ArchSegmentOff arch)))
-> FunState arch s ids -> Identity (FunState arch s ids)
forall arch s ids (f :: Type -> Type).
Functor f =>
(Set (ArchSegmentOff arch) -> f (Set (ArchSegmentOff arch)))
-> FunState arch s ids -> f (FunState arch s ids)
frontier     ((Set (ArchSegmentOff arch)
  -> Identity (Set (ArchSegmentOff arch)))
 -> FunState arch s ids -> Identity (FunState arch s ids))
-> (Set (ArchSegmentOff arch) -> Set (ArchSegmentOff arch))
-> FunM arch s ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ArchSegmentOff arch
-> Set (ArchSegmentOff arch) -> Set (ArchSegmentOff arch)
forall a. Ord a => a -> Set a -> Set a
Set.insert ArchSegmentOff arch
tgt
      let foundInfo :: FoundAddr arch
foundInfo = FoundAddr { foundReason :: BlockExploreReason (RegAddrWidth (ArchReg arch))
foundReason = ArchSegmentOff arch
-> BlockExploreReason (RegAddrWidth (ArchReg arch))
forall (w :: Natural). MemSegmentOff w -> BlockExploreReason w
NextIP ArchSegmentOff arch
src
                                , foundAbstractState :: AbsBlockState (ArchReg arch)
foundAbstractState = AbsBlockState (ArchReg arch)
ab
                                , foundJumpBounds :: InitJumpBounds arch
foundJumpBounds = InitJumpBounds arch
bnds
                                }
      (Map (ArchSegmentOff arch) (FoundAddr arch)
 -> Identity (Map (ArchSegmentOff arch) (FoundAddr arch)))
-> FunState arch s ids -> Identity (FunState arch s ids)
forall arch s ids (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (FoundAddr arch)
 -> f (Map (ArchSegmentOff arch) (FoundAddr arch)))
-> FunState arch s ids -> f (FunState arch s ids)
foundAddrs ((Map (ArchSegmentOff arch) (FoundAddr arch)
  -> Identity (Map (ArchSegmentOff arch) (FoundAddr arch)))
 -> FunState arch s ids -> Identity (FunState arch s ids))
-> (Map (ArchSegmentOff arch) (FoundAddr arch)
    -> Map (ArchSegmentOff arch) (FoundAddr arch))
-> FunM arch s ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ArchSegmentOff arch
-> FoundAddr arch
-> Map (ArchSegmentOff arch) (FoundAddr arch)
-> Map (ArchSegmentOff arch) (FoundAddr arch)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ArchSegmentOff arch
tgt FoundAddr arch
foundInfo


------------------------------------------------------------------------
-- recordWriteStmts

-- | Mark addresses written to memory that point to code as function
-- entry points.
recordWriteStmts :: ArchitectureInfo arch
                 -> Memory (ArchAddrWidth arch)
                 -> AbsProcessorState (ArchReg arch) ids
                 -> [ArchSegmentOff arch]
                 -> [Stmt arch ids]
                 -> ( AbsProcessorState (ArchReg arch) ids
                    , [ArchSegmentOff arch]
                    )
recordWriteStmts :: forall arch ids.
ArchitectureInfo arch
-> Memory (ArchAddrWidth arch)
-> AbsProcessorState (ArchReg arch) ids
-> [ArchSegmentOff arch]
-> [Stmt arch ids]
-> (AbsProcessorState (ArchReg arch) ids, [ArchSegmentOff arch])
recordWriteStmts ArchitectureInfo arch
_archInfo Memory (ArchAddrWidth arch)
_mem AbsProcessorState (ArchReg arch) ids
absState [ArchSegmentOff arch]
writtenAddrs [] =
  AbsProcessorState (ArchReg arch) ids
-> (AbsProcessorState (ArchReg arch) ids, [ArchSegmentOff arch])
-> (AbsProcessorState (ArchReg arch) ids, [ArchSegmentOff arch])
forall a b. a -> b -> b
seq AbsProcessorState (ArchReg arch) ids
absState (AbsProcessorState (ArchReg arch) ids
absState, [ArchSegmentOff arch]
writtenAddrs)
recordWriteStmts ArchitectureInfo arch
ainfo Memory (ArchAddrWidth arch)
mem AbsProcessorState (ArchReg arch) ids
absState [ArchSegmentOff arch]
writtenAddrs (Stmt arch ids
stmt:[Stmt arch ids]
stmts) =
  AbsProcessorState (ArchReg arch) ids
-> (AbsProcessorState (ArchReg arch) ids, [ArchSegmentOff arch])
-> (AbsProcessorState (ArchReg arch) ids, [ArchSegmentOff arch])
forall a b. a -> b -> b
seq AbsProcessorState (ArchReg arch) ids
absState ((AbsProcessorState (ArchReg arch) ids, [ArchSegmentOff arch])
 -> (AbsProcessorState (ArchReg arch) ids, [ArchSegmentOff arch]))
-> (AbsProcessorState (ArchReg arch) ids, [ArchSegmentOff arch])
-> (AbsProcessorState (ArchReg arch) ids, [ArchSegmentOff arch])
forall a b. (a -> b) -> a -> b
$ do
    let absState' :: AbsProcessorState (ArchReg arch) ids
absState' = ArchitectureInfo arch
-> AbsProcessorState (ArchReg arch) ids
-> Stmt arch ids
-> AbsProcessorState (ArchReg arch) ids
forall arch ids.
ArchitectureInfo arch
-> AbsProcessorState (ArchReg arch) ids
-> Stmt arch ids
-> AbsProcessorState (ArchReg arch) ids
absEvalStmt ArchitectureInfo arch
ainfo AbsProcessorState (ArchReg arch) ids
absState Stmt arch ids
stmt
    let writtenAddrs' :: [ArchSegmentOff arch]
writtenAddrs' =
          case Stmt arch ids
stmt of
            WriteMem ArchAddrValue arch ids
_addr MemRepr tp
repr Value arch ids tp
v
              | Just tp :~: BVType (ArchAddrWidth arch)
PC.Refl <- MemRepr tp
-> MemRepr (BVType (ArchAddrWidth arch))
-> Maybe (tp :~: BVType (ArchAddrWidth arch))
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Type) (b :: Type).
MemRepr a -> MemRepr b -> Maybe (a :~: b)
PC.testEquality MemRepr tp
repr (ArchitectureInfo arch -> MemRepr (BVType (ArchAddrWidth arch))
forall arch.
ArchitectureInfo arch -> MemRepr (BVType (ArchAddrWidth arch))
addrMemRepr ArchitectureInfo arch
ainfo) ->
                ArchitectureInfo arch -> forall a. (ArchConstraints arch => a) -> a
forall arch.
ArchitectureInfo arch -> forall a. (ArchConstraints arch => a) -> a
withArchConstraints ArchitectureInfo arch
ainfo ((ArchConstraints arch => [ArchSegmentOff arch])
 -> [ArchSegmentOff arch])
-> (ArchConstraints arch => [ArchSegmentOff arch])
-> [ArchSegmentOff arch]
forall a b. (a -> b) -> a -> b
$
                  let addrs :: [ArchSegmentOff arch]
addrs = Memory (ArchAddrWidth arch)
-> AbsValue (ArchAddrWidth arch) (BVType (ArchAddrWidth arch))
-> [ArchSegmentOff arch]
forall (w :: Natural).
MemWidth w =>
Memory w -> AbsValue w (BVType w) -> [MemSegmentOff w]
identifyConcreteAddresses Memory (ArchAddrWidth arch)
mem (AbsProcessorState (ArchReg arch) ids
-> ArchAddrValue arch ids
-> AbsValue (ArchAddrWidth arch) (BVType (ArchAddrWidth arch))
forall a ids (tp :: Type).
(RegisterInfo (ArchReg a), HasCallStack) =>
AbsProcessorState (ArchReg a) ids
-> Value a ids tp -> ArchAbsValue a tp
transferValue AbsProcessorState (ArchReg arch) ids
absState Value arch ids tp
ArchAddrValue arch ids
v)
                   in [ArchSegmentOff arch]
addrs [ArchSegmentOff arch]
-> [ArchSegmentOff arch] -> [ArchSegmentOff arch]
forall a. [a] -> [a] -> [a]
++ [ArchSegmentOff arch]
writtenAddrs
            Stmt arch ids
_ ->
              [ArchSegmentOff arch]
writtenAddrs
    ArchitectureInfo arch
-> Memory (ArchAddrWidth arch)
-> AbsProcessorState (ArchReg arch) ids
-> [ArchSegmentOff arch]
-> [Stmt arch ids]
-> (AbsProcessorState (ArchReg arch) ids, [ArchSegmentOff arch])
forall arch ids.
ArchitectureInfo arch
-> Memory (ArchAddrWidth arch)
-> AbsProcessorState (ArchReg arch) ids
-> [ArchSegmentOff arch]
-> [Stmt arch ids]
-> (AbsProcessorState (ArchReg arch) ids, [ArchSegmentOff arch])
recordWriteStmts ArchitectureInfo arch
ainfo Memory (ArchAddrWidth arch)
mem AbsProcessorState (ArchReg arch) ids
absState' [ArchSegmentOff arch]
writtenAddrs' [Stmt arch ids]
stmts


-- | Get the memory representation associated with pointers in the
-- given architecture.
addrMemRepr :: ArchitectureInfo arch -> MemRepr (BVType (ArchAddrWidth arch))
addrMemRepr :: forall arch.
ArchitectureInfo arch -> MemRepr (BVType (ArchAddrWidth arch))
addrMemRepr ArchitectureInfo arch
arch_info =
  case ArchitectureInfo arch -> AddrWidthRepr (ArchAddrWidth arch)
forall arch.
ArchitectureInfo arch -> AddrWidthRepr (ArchAddrWidth arch)
archAddrWidth ArchitectureInfo arch
arch_info of
    AddrWidthRepr (ArchAddrWidth arch)
Addr32 -> NatRepr 4 -> Endianness -> MemRepr ('BVType (8 * 4))
forall (w :: Natural).
(1 <= w) =>
NatRepr w -> Endianness -> MemRepr ('BVType (8 * w))
BVMemRepr NatRepr 4
n4 (ArchitectureInfo arch -> Endianness
forall arch. ArchitectureInfo arch -> Endianness
archEndianness ArchitectureInfo arch
arch_info)
    AddrWidthRepr (ArchAddrWidth arch)
Addr64 -> NatRepr 8 -> Endianness -> MemRepr ('BVType (8 * 8))
forall (w :: Natural).
(1 <= w) =>
NatRepr w -> Endianness -> MemRepr ('BVType (8 * w))
BVMemRepr NatRepr 8
n8 (ArchitectureInfo arch -> Endianness
forall arch. ArchitectureInfo arch -> Endianness
archEndianness ArchitectureInfo arch
arch_info)

useExternalTargets :: ( PC.OrdF (ArchReg arch)
                      , RegisterInfo (ArchReg arch)
                      )
                   => BlockClassifierContext arch ids
                   -> Maybe [Jmp.IntraJumpTarget arch]
useExternalTargets :: forall arch ids.
(OrdF (ArchReg arch), RegisterInfo (ArchReg arch)) =>
BlockClassifierContext arch ids -> Maybe [IntraJumpTarget arch]
useExternalTargets BlockClassifierContext arch ids
bcc = do
  let ctx :: ParseContext arch ids
ctx = BlockClassifierContext arch ids -> ParseContext arch ids
forall arch ids.
BlockClassifierContext arch ids -> ParseContext arch ids
classifierParseContext BlockClassifierContext arch ids
bcc
  let finalRegs :: RegState (ArchReg arch) (Value arch ids)
finalRegs = BlockClassifierContext arch ids
-> RegState (ArchReg arch) (Value arch ids)
forall arch ids.
BlockClassifierContext arch ids
-> RegState (ArchReg arch) (Value arch ids)
classifierFinalRegState BlockClassifierContext arch ids
bcc
  let jmpBounds :: IntraJumpBounds arch ids
jmpBounds = BlockClassifierContext arch ids -> IntraJumpBounds arch ids
forall arch ids.
BlockClassifierContext arch ids -> IntraJumpBounds arch ids
classifierJumpBounds BlockClassifierContext arch ids
bcc
  let absState :: AbsProcessorState (ArchReg arch) ids
absState = BlockClassifierContext arch ids
-> AbsProcessorState (ArchReg arch) ids
forall arch ids.
BlockClassifierContext arch ids
-> AbsProcessorState (ArchReg arch) ids
classifierAbsState BlockClassifierContext arch ids
bcc
  let initRegs :: RegState (ArchReg arch) (Value arch ids)
initRegs = BlockClassifierContext arch ids
-> RegState (ArchReg arch) (Value arch ids)
forall arch ids.
BlockClassifierContext arch ids
-> RegState (ArchReg arch) (Value arch ids)
classifierInitRegState BlockClassifierContext arch ids
bcc
  let ipVal :: Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
ipVal = RegState (ArchReg arch) (Value arch ids)
initRegs RegState (ArchReg arch) (Value arch ids)
-> Getting
     (Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
     (RegState (ArchReg arch) (Value arch ids))
     (Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
-> Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
forall s a. s -> Getting a s a -> a
^. ArchReg arch (BVType (RegAddrWidth (ArchReg arch)))
-> Lens'
     (RegState (ArchReg arch) (Value arch ids))
     (Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
forall {k} (r :: k -> Type) (f :: k -> Type) (tp :: k).
OrdF r =>
r tp -> Lens' (RegState r f) (f tp)
boundValue ArchReg arch (BVType (RegAddrWidth (ArchReg arch)))
forall (r :: Type -> Type).
RegisterInfo r =>
r (BVType (RegAddrWidth r))
ip_reg
  MemSegmentOff (RegAddrWidth (ArchReg arch))
ipAddr <- Memory (RegAddrWidth (ArchReg arch))
-> Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
-> Maybe (MemSegmentOff (RegAddrWidth (ArchReg arch)))
forall arch ids.
Memory (ArchAddrWidth arch)
-> BVValue arch ids (ArchAddrWidth arch)
-> Maybe (ArchSegmentOff arch)
valueAsSegmentOff (ParseContext arch ids -> Memory (RegAddrWidth (ArchReg arch))
forall arch ids.
ParseContext arch ids -> Memory (ArchAddrWidth arch)
pctxMemory ParseContext arch ids
ctx) Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
ipVal
  [MemSegmentOff (RegAddrWidth (ArchReg arch))]
targets <- MemSegmentOff (RegAddrWidth (ArchReg arch))
-> [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
     [MemSegmentOff (RegAddrWidth (ArchReg arch))])]
-> Maybe [MemSegmentOff (RegAddrWidth (ArchReg arch))]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup MemSegmentOff (RegAddrWidth (ArchReg arch))
ipAddr (ParseContext arch ids
-> [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
     [MemSegmentOff (RegAddrWidth (ArchReg arch))])]
forall arch ids.
ParseContext arch ids
-> [(ArchSegmentOff arch, [ArchSegmentOff arch])]
pctxExtResolution ParseContext arch ids
ctx)
  let blockState :: AbsBlockState (ArchReg arch)
blockState = AbsProcessorState (ArchReg arch) ids
-> RegState (ArchReg arch) (Value arch ids)
-> AbsBlockState (ArchReg arch)
forall a ids.
RegisterInfo (ArchReg a) =>
AbsProcessorState (ArchReg a) ids
-> RegState (ArchReg a) (Value a ids) -> AbsBlockState (ArchReg a)
finalAbsBlockState AbsProcessorState (ArchReg arch) ids
absState RegState (ArchReg arch) (Value arch ids)
finalRegs
  let nextInitJmpBounds :: InitJumpBounds arch
nextInitJmpBounds = IntraJumpBounds arch ids
-> RegState (ArchReg arch) (Value arch ids) -> InitJumpBounds arch
forall arch ids.
RegisterInfo (ArchReg arch) =>
IntraJumpBounds arch ids
-> RegState (ArchReg arch) (Value arch ids) -> InitJumpBounds arch
Jmp.postJumpBounds IntraJumpBounds arch ids
jmpBounds RegState (ArchReg arch) (Value arch ids)
finalRegs
  [IntraJumpTarget arch] -> Maybe [IntraJumpTarget arch]
forall a. a -> Maybe a
forall (m :: Type -> Type) a. Monad m => a -> m a
return [ (MemSegmentOff (RegAddrWidth (ArchReg arch))
tgt, AbsBlockState (ArchReg arch)
blockState, InitJumpBounds arch
nextInitJmpBounds) | MemSegmentOff (RegAddrWidth (ArchReg arch))
tgt <- [MemSegmentOff (RegAddrWidth (ArchReg arch))]
targets ]

-- | This is a good default set of block classifiers
--
-- Block classifiers determine how the code discovery engine interprets the
-- final instruction in each block. The individual classifiers are also exported
-- so that architecture backends (or even end users) can provide their own
-- classifiers.
--
-- See 'Data.Macaw.Discovery.Classifier' for the primitives necessary to define
-- new classifiers (e.g., classifiers that can produce architecture-specific
-- terminators).
--
-- Note that classifiers are an instance of 'Control.Monad.Alternative', so the
-- order they are applied in matters.  While several are non-overlapping, at
-- least the order that the direct jump and tail call classifiers are applied in
-- matters, as they look substantially the same to the analysis. Being too eager
-- to flag jumps as tail calls classifies the jump targets as known function
-- entry points, which can interfere with other classifiers later in the
-- function.
defaultClassifier :: BlockClassifier arch ids
defaultClassifier :: forall arch ids. BlockClassifier arch ids
defaultClassifier = BlockClassifier arch ids
forall arch ids. BlockClassifier arch ids
branchClassifier
                BlockClassifier arch ids
-> BlockClassifier arch ids -> BlockClassifier arch ids
forall a.
BlockClassifierM arch ids a
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> BlockClassifier arch ids
forall arch ids. BlockClassifier arch ids
noreturnCallClassifier
                BlockClassifier arch ids
-> BlockClassifier arch ids -> BlockClassifier arch ids
forall a.
BlockClassifierM arch ids a
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> BlockClassifier arch ids
forall arch ids. BlockClassifier arch ids
callClassifier
                BlockClassifier arch ids
-> BlockClassifier arch ids -> BlockClassifier arch ids
forall a.
BlockClassifierM arch ids a
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> BlockClassifier arch ids
forall arch ids. BlockClassifier arch ids
returnClassifier
                BlockClassifier arch ids
-> BlockClassifier arch ids -> BlockClassifier arch ids
forall a.
BlockClassifierM arch ids a
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> BlockClassifier arch ids
forall arch ids. BlockClassifier arch ids
jumpTableClassifier
                BlockClassifier arch ids
-> BlockClassifier arch ids -> BlockClassifier arch ids
forall a.
BlockClassifierM arch ids a
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> BlockClassifier arch ids
forall arch ids. BlockClassifier arch ids
pltStubClassifier
                BlockClassifier arch ids
-> BlockClassifier arch ids -> BlockClassifier arch ids
forall a.
BlockClassifierM arch ids a
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> BlockClassifier arch ids
forall arch ids. BlockClassifier arch ids
directJumpClassifier
                BlockClassifier arch ids
-> BlockClassifier arch ids -> BlockClassifier arch ids
forall a.
BlockClassifierM arch ids a
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> BlockClassifier arch ids
forall arch ids. BlockClassifier arch ids
tailCallClassifier

-- | This parses a block that ended with a fetch and execute instruction.
parseFetchAndExecute :: forall arch ids
                     .  (RegisterInfo (ArchReg arch))
                     => ArchitectureInfo arch
                     -> BlockClassifierContext arch ids
                     -> [Stmt arch ids]
                     -> ParsedContents arch ids
parseFetchAndExecute :: forall arch ids.
RegisterInfo (ArchReg arch) =>
ArchitectureInfo arch
-> BlockClassifierContext arch ids
-> [Stmt arch ids]
-> ParsedContents arch ids
parseFetchAndExecute ArchitectureInfo arch
ainfo BlockClassifierContext arch ids
classCtx [Stmt arch ids]
stmts = do
  case BlockClassifier arch ids
-> BlockClassifierContext arch ids
-> Classifier (ParsedContents arch ids)
forall arch ids.
BlockClassifier arch ids
-> BlockClassifierContext arch ids
-> Classifier (ParsedContents arch ids)
runBlockClassifier (ArchitectureInfo arch -> forall ids. BlockClassifier arch ids
forall arch.
ArchitectureInfo arch -> forall ids. BlockClassifier arch ids
archClassifier ArchitectureInfo arch
ainfo) BlockClassifierContext arch ids
classCtx of
    ClassifySucceeded [String]
_ ParsedContents arch ids
m -> ParsedContents arch ids
m
    ClassifyFailed [String]
rsns ->
      ParsedContents { parsedNonterm :: [Stmt arch ids]
parsedNonterm = [Stmt arch ids]
stmts
                     , parsedTerm :: ParsedTermStmt arch ids
parsedTerm  = RegState (ArchReg arch) (Value arch ids)
-> [String] -> ParsedTermStmt arch ids
forall arch ids.
RegState (ArchReg arch) (Value arch ids)
-> [String] -> ParsedTermStmt arch ids
ClassifyFailure (BlockClassifierContext arch ids
-> RegState (ArchReg arch) (Value arch ids)
forall arch ids.
BlockClassifierContext arch ids
-> RegState (ArchReg arch) (Value arch ids)
classifierFinalRegState BlockClassifierContext arch ids
classCtx) [String]
rsns
                     , writtenCodeAddrs :: [ArchSegmentOff arch]
writtenCodeAddrs = BlockClassifierContext arch ids -> [ArchSegmentOff arch]
forall arch ids.
BlockClassifierContext arch ids -> [ArchSegmentOff arch]
classifierWrittenAddrs BlockClassifierContext arch ids
classCtx
                     , intraJumpTargets :: [IntraJumpTarget arch]
intraJumpTargets = [IntraJumpTarget arch]
-> Maybe [IntraJumpTarget arch] -> [IntraJumpTarget arch]
forall a. a -> Maybe a -> a
fromMaybe [] (BlockClassifierContext arch ids -> Maybe [IntraJumpTarget arch]
forall arch ids.
(OrdF (ArchReg arch), RegisterInfo (ArchReg arch)) =>
BlockClassifierContext arch ids -> Maybe [IntraJumpTarget arch]
useExternalTargets BlockClassifierContext arch ids
classCtx)
                     , newFunctionAddrs :: [ArchSegmentOff arch]
newFunctionAddrs = []
                     }

-- | this evalutes the statements in a block to expand the information known
-- about control flow targets of this block.
parseBlock :: ParseContext arch ids
              -- ^ Context for parsing blocks.
           -> RegState (ArchReg arch) (Value arch ids)
           -- ^ Initial register values
           -> Block arch ids
              -- ^ Block to parse
           -> Int
              -- ^ Size of block
           -> AbsBlockState (ArchReg arch)
              -- ^ Abstract state at start of block
           -> Jmp.InitJumpBounds arch
           -> ParsedContents arch ids
parseBlock :: forall arch ids.
ParseContext arch ids
-> RegState (ArchReg arch) (Value arch ids)
-> Block arch ids
-> Int
-> AbsBlockState (ArchReg arch)
-> InitJumpBounds arch
-> ParsedContents arch ids
parseBlock ParseContext arch ids
ctx RegState (ArchReg arch) (Value arch ids)
initRegs Block arch ids
b Int
sz AbsBlockState (ArchReg arch)
absBlockState InitJumpBounds arch
blockBnds = do
  let ainfo :: ArchitectureInfo arch
ainfo = ParseContext arch ids -> ArchitectureInfo arch
forall arch ids. ParseContext arch ids -> ArchitectureInfo arch
pctxArchInfo ParseContext arch ids
ctx
  let mem :: Memory (ArchAddrWidth arch)
mem   = ParseContext arch ids -> Memory (ArchAddrWidth arch)
forall arch ids.
ParseContext arch ids -> Memory (ArchAddrWidth arch)
pctxMemory ParseContext arch ids
ctx
  ArchitectureInfo arch -> forall a. (ArchConstraints arch => a) -> a
forall arch.
ArchitectureInfo arch -> forall a. (ArchConstraints arch => a) -> a
withArchConstraints (ParseContext arch ids -> ArchitectureInfo arch
forall arch ids. ParseContext arch ids -> ArchitectureInfo arch
pctxArchInfo ParseContext arch ids
ctx) ((ArchConstraints arch => ParsedContents arch ids)
 -> ParsedContents arch ids)
-> (ArchConstraints arch => ParsedContents arch ids)
-> ParsedContents arch ids
forall a b. (a -> b) -> a -> b
$ do
   let (AbsProcessorState (ArchReg arch) ids
absState, [ArchSegmentOff arch]
writtenAddrs) =
         let initAbsState :: AbsProcessorState (ArchReg arch) ids
initAbsState = Memory (ArchAddrWidth arch)
-> AbsBlockState (ArchReg arch)
-> AbsProcessorState (ArchReg arch) ids
forall (r :: Type -> Type) ids.
Memory (RegAddrWidth r)
-> AbsBlockState r -> AbsProcessorState r ids
initAbsProcessorState Memory (ArchAddrWidth arch)
mem AbsBlockState (ArchReg arch)
absBlockState
          in ArchitectureInfo arch
-> Memory (ArchAddrWidth arch)
-> AbsProcessorState (ArchReg arch) ids
-> [ArchSegmentOff arch]
-> [Stmt arch ids]
-> (AbsProcessorState (ArchReg arch) ids, [ArchSegmentOff arch])
forall arch ids.
ArchitectureInfo arch
-> Memory (ArchAddrWidth arch)
-> AbsProcessorState (ArchReg arch) ids
-> [ArchSegmentOff arch]
-> [Stmt arch ids]
-> (AbsProcessorState (ArchReg arch) ids, [ArchSegmentOff arch])
recordWriteStmts ArchitectureInfo arch
ainfo Memory (ArchAddrWidth arch)
mem AbsProcessorState (ArchReg arch) ids
initAbsState [] (Block arch ids -> [Stmt arch ids]
forall arch ids. Block arch ids -> [Stmt arch ids]
blockStmts Block arch ids
b)
   let jmpBounds :: IntraJumpBounds arch ids
jmpBounds = InitJumpBounds arch -> [Stmt arch ids] -> IntraJumpBounds arch ids
forall arch ids.
(MemWidth (ArchAddrWidth arch), OrdF (ArchReg arch),
 ShowF (ArchReg arch), FoldableFC (ArchFn arch)) =>
InitJumpBounds arch -> [Stmt arch ids] -> IntraJumpBounds arch ids
Jmp.blockEndBounds InitJumpBounds arch
blockBnds (Block arch ids -> [Stmt arch ids]
forall arch ids. Block arch ids -> [Stmt arch ids]
blockStmts Block arch ids
b)
   case Block arch ids -> TermStmt arch ids
forall arch ids. Block arch ids -> TermStmt arch ids
blockTerm Block arch ids
b of
    FetchAndExecute RegState (ArchReg arch) (Value arch ids)
finalRegs -> do
      -- Try to figure out what control flow statement we have.
      let classCtx :: BlockClassifierContext arch ids
classCtx = BlockClassifierContext
            { classifierParseContext :: ParseContext arch ids
classifierParseContext = ParseContext arch ids
ctx
            , classifierInitRegState :: RegState (ArchReg arch) (Value arch ids)
classifierInitRegState = RegState (ArchReg arch) (Value arch ids)
initRegs
            , classifierStmts :: Seq (Stmt arch ids)
classifierStmts = [Stmt arch ids] -> Seq (Stmt arch ids)
forall a. [a] -> Seq a
Seq.fromList (Block arch ids -> [Stmt arch ids]
forall arch ids. Block arch ids -> [Stmt arch ids]
blockStmts Block arch ids
b)
            , classifierBlockSize :: Int
classifierBlockSize = Int
sz
            , classifierAbsState :: AbsProcessorState (ArchReg arch) ids
classifierAbsState = AbsProcessorState (ArchReg arch) ids
absState
            , classifierJumpBounds :: IntraJumpBounds arch ids
classifierJumpBounds = IntraJumpBounds arch ids
jmpBounds
            , classifierWrittenAddrs :: [ArchSegmentOff arch]
classifierWrittenAddrs = [ArchSegmentOff arch]
writtenAddrs
            , classifierFinalRegState :: RegState (ArchReg arch) (Value arch ids)
classifierFinalRegState = RegState (ArchReg arch) (Value arch ids)
finalRegs
            }
      ArchitectureInfo arch
-> BlockClassifierContext arch ids
-> [Stmt arch ids]
-> ParsedContents arch ids
forall arch ids.
RegisterInfo (ArchReg arch) =>
ArchitectureInfo arch
-> BlockClassifierContext arch ids
-> [Stmt arch ids]
-> ParsedContents arch ids
parseFetchAndExecute ArchitectureInfo arch
ainfo BlockClassifierContext arch ids
classCtx (Block arch ids -> [Stmt arch ids]
forall arch ids. Block arch ids -> [Stmt arch ids]
blockStmts Block arch ids
b)

    -- Do nothing when this block ends in a translation error.
    TranslateError RegState (ArchReg arch) (Value arch ids)
_ Text
msg ->
      ParsedContents { parsedNonterm :: [Stmt arch ids]
parsedNonterm = Block arch ids -> [Stmt arch ids]
forall arch ids. Block arch ids -> [Stmt arch ids]
blockStmts Block arch ids
b
                     , parsedTerm :: ParsedTermStmt arch ids
parsedTerm = Text -> ParsedTermStmt arch ids
forall arch ids. Text -> ParsedTermStmt arch ids
ParsedTranslateError Text
msg
                     , writtenCodeAddrs :: [ArchSegmentOff arch]
writtenCodeAddrs = [ArchSegmentOff arch]
writtenAddrs
                     , intraJumpTargets :: [IntraJumpTarget arch]
intraJumpTargets = []
                     , newFunctionAddrs :: [ArchSegmentOff arch]
newFunctionAddrs = []
                     }
    ArchTermStmt ArchTermStmt arch (Value arch ids)
tstmt RegState (ArchReg arch) (Value arch ids)
regs ->
      let r :: Maybe (IntraJumpTarget arch)
r = ArchitectureInfo arch
-> forall ids.
   Memory (ArchAddrWidth arch)
   -> AbsProcessorState (ArchReg arch) ids
   -> IntraJumpBounds arch ids
   -> RegState (ArchReg arch) (Value arch ids)
   -> ArchTermStmt arch (Value arch ids)
   -> Maybe (IntraJumpTarget arch)
forall arch.
ArchitectureInfo arch
-> forall ids.
   Memory (ArchAddrWidth arch)
   -> AbsProcessorState (ArchReg arch) ids
   -> IntraJumpBounds arch ids
   -> RegState (ArchReg arch) (Value arch ids)
   -> ArchTermStmt arch (Value arch ids)
   -> Maybe (IntraJumpTarget arch)
postArchTermStmtAbsState ArchitectureInfo arch
ainfo Memory (ArchAddrWidth arch)
mem AbsProcessorState (ArchReg arch) ids
absState IntraJumpBounds arch ids
jmpBounds RegState (ArchReg arch) (Value arch ids)
regs ArchTermStmt arch (Value arch ids)
tstmt
       in ParsedContents { parsedNonterm :: [Stmt arch ids]
parsedNonterm = Block arch ids -> [Stmt arch ids]
forall arch ids. Block arch ids -> [Stmt arch ids]
blockStmts Block arch ids
b
                         , parsedTerm :: ParsedTermStmt arch ids
parsedTerm  = ArchTermStmt arch (Value arch ids)
-> RegState (ArchReg arch) (Value arch ids)
-> Maybe (ArchSegmentOff arch)
-> ParsedTermStmt arch ids
forall arch ids.
ArchTermStmt arch (Value arch ids)
-> RegState (ArchReg arch) (Value arch ids)
-> Maybe (ArchSegmentOff arch)
-> ParsedTermStmt arch ids
ParsedArchTermStmt ArchTermStmt arch (Value arch ids)
tstmt RegState (ArchReg arch) (Value arch ids)
regs ((\(ArchSegmentOff arch
a,AbsBlockState (ArchReg arch)
_,InitJumpBounds arch
_) -> ArchSegmentOff arch
a) (IntraJumpTarget arch -> ArchSegmentOff arch)
-> Maybe (IntraJumpTarget arch) -> Maybe (ArchSegmentOff arch)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (IntraJumpTarget arch)
r)
                         , writtenCodeAddrs :: [ArchSegmentOff arch]
writtenCodeAddrs = [ArchSegmentOff arch]
writtenAddrs
                         , intraJumpTargets :: [IntraJumpTarget arch]
intraJumpTargets = Maybe (IntraJumpTarget arch) -> [IntraJumpTarget arch]
forall a. Maybe a -> [a]
maybeToList Maybe (IntraJumpTarget arch)
r
                         , newFunctionAddrs :: [ArchSegmentOff arch]
newFunctionAddrs = []
                         }

type CandidateFunctionMap arch
   = Map (ArchSegmentOff arch) (FunctionExploreReason (ArchAddrWidth arch))

-- | This evaluates the statements in a block to expand the
-- information known about control flow targets of this block.
addBlock :: forall s arch ids
         .  ArchConstraints arch
         => DiscoveryState arch
         -> ArchSegmentOff arch
            -- ^ Address of the block to add.
         -> FoundAddr arch
            -- ^ State leading to explore block
         -> ArchBlockPrecond arch
            -- ^ State information needed to disassemble block at this address.
         -> FunState arch s ids
         -> STL.ST s (FunState arch s ids)
addBlock :: forall s arch ids.
ArchConstraints arch =>
DiscoveryState arch
-> ArchSegmentOff arch
-> FoundAddr arch
-> ArchBlockPrecond arch
-> FunState arch s ids
-> ST s (FunState arch s ids)
addBlock DiscoveryState arch
ctx MemSegmentOff (RegAddrWidth (ArchReg arch))
src FoundAddr arch
finfo ArchBlockPrecond arch
pr FunState arch s ids
s0 = do
  let ainfo :: ArchitectureInfo arch
ainfo = DiscoveryState arch -> ArchitectureInfo arch
forall arch. DiscoveryState arch -> ArchitectureInfo arch
archInfo DiscoveryState arch
ctx
  let mem :: Memory (RegAddrWidth (ArchReg arch))
mem = DiscoveryState arch -> Memory (RegAddrWidth (ArchReg arch))
forall arch. DiscoveryState arch -> Memory (ArchAddrWidth arch)
memory DiscoveryState arch
ctx
  let fnPred :: MemSegmentOff (RegAddrWidth (ArchReg arch)) -> Bool
fnPred = DiscoveryState arch
ctxDiscoveryState arch
-> Getting
     (MemSegmentOff (RegAddrWidth (ArchReg arch)) -> Bool)
     (DiscoveryState arch)
     (MemSegmentOff (RegAddrWidth (ArchReg arch)) -> Bool)
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Bool
forall s a. s -> Getting a s a -> a
^.Getting
  (MemSegmentOff (RegAddrWidth (ArchReg arch)) -> Bool)
  (DiscoveryState arch)
  (MemSegmentOff (RegAddrWidth (ArchReg arch)) -> Bool)
forall arch (f :: Type -> Type).
Functor f =>
((ArchSegmentOff arch -> Bool) -> f (ArchSegmentOff arch -> Bool))
-> DiscoveryState arch -> f (DiscoveryState arch)
exploreFnPred
  let knownFnEntries :: Map (MemSegmentOff (RegAddrWidth (ArchReg arch))) NoReturnFunStatus
knownFnEntries = DiscoveryState arch
ctxDiscoveryState arch
-> Getting
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch))) NoReturnFunStatus)
     (DiscoveryState arch)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch))) NoReturnFunStatus)
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch))) NoReturnFunStatus
forall s a. s -> Getting a s a -> a
^.Getting
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch))) NoReturnFunStatus)
  (DiscoveryState arch)
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch))) NoReturnFunStatus)
forall arch (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) NoReturnFunStatus
 -> f (Map (ArchSegmentOff arch) NoReturnFunStatus))
-> DiscoveryState arch -> f (DiscoveryState arch)
trustedFunctionEntryPoints

  let initRegs :: RegState (ArchReg arch) (Value arch ids)
initRegs = ArchitectureInfo arch
-> forall ids.
   MemSegmentOff (RegAddrWidth (ArchReg arch))
   -> ArchBlockPrecond arch
   -> RegState (ArchReg arch) (Value arch ids)
forall arch.
ArchitectureInfo arch
-> forall ids.
   ArchSegmentOff arch
   -> ArchBlockPrecond arch
   -> RegState (ArchReg arch) (Value arch ids)
initialBlockRegs ArchitectureInfo arch
ainfo MemSegmentOff (RegAddrWidth (ArchReg arch))
src ArchBlockPrecond arch
pr
  let nonceGen :: NonceGenerator (ST s) ids
nonceGen = FunState arch s ids -> NonceGenerator (ST s) ids
forall arch s ids. FunState arch s ids -> NonceGenerator (ST s) ids
funNonceGen FunState arch s ids
s0
  let prevBlockMap :: Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (ParsedBlock arch ids)
prevBlockMap = FunState arch s ids
s0FunState arch s ids
-> Getting
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (ParsedBlock arch ids))
     (FunState arch s ids)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (ParsedBlock arch ids))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (ParsedBlock arch ids)
forall s a. s -> Getting a s a -> a
^.Getting
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (ParsedBlock arch ids))
  (FunState arch s ids)
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (ParsedBlock arch ids))
forall arch s ids (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (ParsedBlock arch ids)
 -> f (Map (ArchSegmentOff arch) (ParsedBlock arch ids)))
-> FunState arch s ids -> f (FunState arch s ids)
curFunBlocks
  let maxSize :: Int
      maxSize :: Int
maxSize =
        case MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (ParsedBlock arch ids)
-> Maybe
     (MemSegmentOff (RegAddrWidth (ArchReg arch)), ParsedBlock arch ids)
forall k v. Ord k => k -> Map k v -> Maybe (k, v)
Map.lookupGT MemSegmentOff (RegAddrWidth (ArchReg arch))
src Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (ParsedBlock arch ids)
prevBlockMap of
          Just (MemSegmentOff (RegAddrWidth (ArchReg arch))
next,ParsedBlock arch ids
_) | Just Integer
o <- MemSegmentOff (RegAddrWidth (ArchReg arch))
-> MemSegmentOff (RegAddrWidth (ArchReg arch)) -> Maybe Integer
forall (w :: Natural).
MemWidth w =>
MemSegmentOff w -> MemSegmentOff w -> Maybe Integer
diffSegmentOff MemSegmentOff (RegAddrWidth (ArchReg arch))
next MemSegmentOff (RegAddrWidth (ArchReg arch))
src -> Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
o
          Maybe
  (MemSegmentOff (RegAddrWidth (ArchReg arch)), ParsedBlock arch ids)
_ -> Integer -> Int
forall a. Num a => Integer -> a
fromInteger (MemSegmentOff (RegAddrWidth (ArchReg arch)) -> Integer
forall (w :: Natural). MemWidth w => MemSegmentOff w -> Integer
segoffBytesLeft MemSegmentOff (RegAddrWidth (ArchReg arch))
src)
  (Block arch ids
b0, Int
sz) <- ST s (Block arch ids, Int) -> ST s (Block arch ids, Int)
forall s a. ST s a -> ST s a
STL.strictToLazyST (ST s (Block arch ids, Int) -> ST s (Block arch ids, Int))
-> ST s (Block arch ids, Int) -> ST s (Block arch ids, Int)
forall a b. (a -> b) -> a -> b
$ ArchitectureInfo arch -> DisassembleFn arch
forall arch. ArchitectureInfo arch -> DisassembleFn arch
disassembleFn ArchitectureInfo arch
ainfo NonceGenerator (ST s) ids
nonceGen MemSegmentOff (RegAddrWidth (ArchReg arch))
src RegState (ArchReg arch) (Value arch ids)
initRegs Int
maxSize
  -- Rewrite returned blocks to simplify expressions
#ifdef USE_REWRITER
  (RewriteContext arch s ids ids
_,Block arch ids
b) <- do
    let archStmt :: ArchStmt arch (Value arch ids) -> Rewriter arch s ids ids ()
archStmt = ArchitectureInfo arch
-> forall s src tgt.
   ArchStmt arch (Value arch src) -> Rewriter arch s src tgt ()
forall arch.
ArchitectureInfo arch
-> forall s src tgt.
   ArchStmt arch (Value arch src) -> Rewriter arch s src tgt ()
rewriteArchStmt ArchitectureInfo arch
ainfo
    let secAddrMap :: Map SectionIndex (MemSegmentOff (RegAddrWidth (ArchReg arch)))
secAddrMap = Memory (RegAddrWidth (ArchReg arch))
-> Map SectionIndex (MemSegmentOff (RegAddrWidth (ArchReg arch)))
forall (w :: Natural).
Memory w -> Map SectionIndex (MemSegmentOff w)
memSectionIndexMap Memory (RegAddrWidth (ArchReg arch))
mem
    ST s (RewriteContext arch s ids ids, Block arch ids)
-> ST s (RewriteContext arch s ids ids, Block arch ids)
forall s a. ST s a -> ST s a
STL.strictToLazyST (ST s (RewriteContext arch s ids ids, Block arch ids)
 -> ST s (RewriteContext arch s ids ids, Block arch ids))
-> ST s (RewriteContext arch s ids ids, Block arch ids)
-> ST s (RewriteContext arch s ids ids, Block arch ids)
forall a b. (a -> b) -> a -> b
$ do
      RewriteContext arch s ids ids
rctx <- NonceGenerator (ST s) ids
-> (forall (tp :: Type).
    ArchFn arch (Value arch ids) tp
    -> Rewriter arch s ids ids (Value arch ids tp))
-> (ArchStmt arch (Value arch ids) -> Rewriter arch s ids ids ())
-> (TermStmt arch ids
    -> Rewriter arch s ids ids (TermStmt arch ids))
-> Map SectionIndex (MemSegmentOff (RegAddrWidth (ArchReg arch)))
-> ST s (RewriteContext arch s ids ids)
forall arch s tgt src.
RegisterInfo (ArchReg arch) =>
NonceGenerator (ST s) tgt
-> (forall (tp :: Type).
    ArchFn arch (Value arch src) tp
    -> Rewriter arch s src tgt (Value arch tgt tp))
-> (ArchStmt arch (Value arch src) -> Rewriter arch s src tgt ())
-> (TermStmt arch tgt
    -> Rewriter arch s src tgt (TermStmt arch tgt))
-> Map SectionIndex (ArchSegmentOff arch)
-> ST s (RewriteContext arch s src tgt)
mkRewriteContext NonceGenerator (ST s) ids
nonceGen (ArchitectureInfo arch
-> forall s src tgt (tp :: Type).
   ArchFn arch (Value arch src) tp
   -> Rewriter arch s src tgt (Value arch tgt tp)
forall arch.
ArchitectureInfo arch
-> forall s src tgt (tp :: Type).
   ArchFn arch (Value arch src) tp
   -> Rewriter arch s src tgt (Value arch tgt tp)
rewriteArchFn ArchitectureInfo arch
ainfo) ArchStmt arch (Value arch ids) -> Rewriter arch s ids ids ()
archStmt TermStmt arch ids -> Rewriter arch s ids ids (TermStmt arch ids)
forall a. a -> Rewriter arch s ids ids a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Map SectionIndex (MemSegmentOff (RegAddrWidth (ArchReg arch)))
secAddrMap
      ArchitectureInfo arch
-> RewriteContext arch s ids ids
-> Block arch ids
-> ST s (RewriteContext arch s ids ids, Block arch ids)
forall arch s src tgt.
ArchitectureInfo arch
-> RewriteContext arch s src tgt
-> Block arch src
-> ST s (RewriteContext arch s src tgt, Block arch tgt)
rewriteBlock ArchitectureInfo arch
ainfo RewriteContext arch s ids ids
rctx Block arch ids
b0
#else
  b <- pure b0
#endif
  let extRes :: [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
  [MemSegmentOff (RegAddrWidth (ArchReg arch))])]
extRes = FunState arch s ids
-> [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
     [MemSegmentOff (RegAddrWidth (ArchReg arch))])]
forall arch s ids.
FunState arch s ids
-> [(ArchSegmentOff arch, [ArchSegmentOff arch])]
classifyFailureResolutions FunState arch s ids
s0
  let funAddr :: MemSegmentOff (RegAddrWidth (ArchReg arch))
funAddr = FunState arch s ids -> MemSegmentOff (RegAddrWidth (ArchReg arch))
forall arch s ids. FunState arch s ids -> ArchSegmentOff arch
curFunAddr FunState arch s ids
s0
  let pctx :: ParseContext arch ids
pctx = ParseContext { pctxMemory :: Memory (RegAddrWidth (ArchReg arch))
pctxMemory         =  Memory (RegAddrWidth (ArchReg arch))
mem
                          , pctxArchInfo :: ArchitectureInfo arch
pctxArchInfo       = ArchitectureInfo arch
ainfo
                          , pctxKnownFnEntries :: Map (MemSegmentOff (RegAddrWidth (ArchReg arch))) NoReturnFunStatus
pctxKnownFnEntries = Map (MemSegmentOff (RegAddrWidth (ArchReg arch))) NoReturnFunStatus
knownFnEntries
                          , pctxFunAddr :: MemSegmentOff (RegAddrWidth (ArchReg arch))
pctxFunAddr        = MemSegmentOff (RegAddrWidth (ArchReg arch))
funAddr
                          , pctxAddr :: MemSegmentOff (RegAddrWidth (ArchReg arch))
pctxAddr           = MemSegmentOff (RegAddrWidth (ArchReg arch))
src
                          , pctxExtResolution :: [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
  [MemSegmentOff (RegAddrWidth (ArchReg arch))])]
pctxExtResolution  = [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
  [MemSegmentOff (RegAddrWidth (ArchReg arch))])]
extRes
                          }
  let pc :: ParsedContents arch ids
pc = ParseContext arch ids
-> RegState (ArchReg arch) (Value arch ids)
-> Block arch ids
-> Int
-> AbsBlockState (ArchReg arch)
-> InitJumpBounds arch
-> ParsedContents arch ids
forall arch ids.
ParseContext arch ids
-> RegState (ArchReg arch) (Value arch ids)
-> Block arch ids
-> Int
-> AbsBlockState (ArchReg arch)
-> InitJumpBounds arch
-> ParsedContents arch ids
parseBlock ParseContext arch ids
pctx RegState (ArchReg arch) (Value arch ids)
initRegs Block arch ids
b Int
sz (FoundAddr arch -> AbsBlockState (ArchReg arch)
forall arch. FoundAddr arch -> AbsBlockState (ArchReg arch)
foundAbstractState FoundAddr arch
finfo) (FoundAddr arch -> InitJumpBounds arch
forall arch. FoundAddr arch -> InitJumpBounds arch
foundJumpBounds FoundAddr arch
finfo)
  let pb :: ParsedBlock arch ids
pb = ParsedBlock { pblockAddr :: MemSegmentOff (RegAddrWidth (ArchReg arch))
pblockAddr    = MemSegmentOff (RegAddrWidth (ArchReg arch))
src
                       , pblockPrecond :: Either String (ArchBlockPrecond arch)
pblockPrecond = ArchBlockPrecond arch -> Either String (ArchBlockPrecond arch)
forall a b. b -> Either a b
Right ArchBlockPrecond arch
pr
                       , blockSize :: Int
blockSize     = Int
sz
                       , blockReason :: BlockExploreReason (RegAddrWidth (ArchReg arch))
blockReason   = FoundAddr arch -> BlockExploreReason (RegAddrWidth (ArchReg arch))
forall arch.
FoundAddr arch -> BlockExploreReason (ArchAddrWidth arch)
foundReason FoundAddr arch
finfo
                       , blockAbstractState :: AbsBlockState (ArchReg arch)
blockAbstractState = FoundAddr arch -> AbsBlockState (ArchReg arch)
forall arch. FoundAddr arch -> AbsBlockState (ArchReg arch)
foundAbstractState FoundAddr arch
finfo
                       , blockJumpBounds :: InitJumpBounds arch
blockJumpBounds = FoundAddr arch -> InitJumpBounds arch
forall arch. FoundAddr arch -> InitJumpBounds arch
foundJumpBounds FoundAddr arch
finfo
                       , pblockStmts :: [Stmt arch ids]
pblockStmts     = ParsedContents arch ids -> [Stmt arch ids]
forall arch ids. ParsedContents arch ids -> [Stmt arch ids]
parsedNonterm ParsedContents arch ids
pc
                       , pblockTermStmt :: ParsedTermStmt arch ids
pblockTermStmt  = ParsedContents arch ids -> ParsedTermStmt arch ids
forall arch ids. ParsedContents arch ids -> ParsedTermStmt arch ids
parsedTerm ParsedContents arch ids
pc
                       }
  let pb' :: ParsedBlock arch ids
pb' = ArchitectureInfo arch
-> ParsedBlock arch ids -> ParsedBlock arch ids
forall arch ids.
ArchitectureInfo arch
-> ParsedBlock arch ids -> ParsedBlock arch ids
dropUnusedCodeInParsedBlock ArchitectureInfo arch
ainfo ParsedBlock arch ids
pb
  (StateT (FunState arch s ids) (ST s) ()
 -> FunState arch s ids -> ST s (FunState arch s ids))
-> FunState arch s ids
-> StateT (FunState arch s ids) (ST s) ()
-> ST s (FunState arch s ids)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (FunState arch s ids) (ST s) ()
-> FunState arch s ids -> ST s (FunState arch s ids)
forall (m :: Type -> Type) s a. Monad m => StateT s m a -> s -> m s
CMS.execStateT FunState arch s ids
s0 (StateT (FunState arch s ids) (ST s) ()
 -> ST s (FunState arch s ids))
-> StateT (FunState arch s ids) (ST s) ()
-> ST s (FunState arch s ids)
forall a b. (a -> b) -> a -> b
$ FunM arch s ids () -> StateT (FunState arch s ids) (ST s) ()
forall arch s ids a.
FunM arch s ids a -> StateT (FunState arch s ids) (ST s) a
unFunM (FunM arch s ids () -> StateT (FunState arch s ids) (ST s) ())
-> FunM arch s ids () -> StateT (FunState arch s ids) (ST s) ()
forall a b. (a -> b) -> a -> b
$ do
    (FunState arch s ids -> Identity (FunState arch s ids))
-> FunState arch s ids -> Identity (FunState arch s ids)
forall a. a -> a
id ((FunState arch s ids -> Identity (FunState arch s ids))
 -> FunState arch s ids -> Identity (FunState arch s ids))
-> (FunState arch s ids -> FunState arch s ids)
-> FunM arch s ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= MemSegmentOff (RegAddrWidth (ArchReg arch))
-> ParsedBlock arch ids
-> FunState arch s ids
-> FunState arch s ids
forall arch ids s.
MemWidth (ArchAddrWidth arch) =>
ArchSegmentOff arch
-> ParsedBlock arch ids
-> FunState arch s ids
-> FunState arch s ids
addFunBlock MemSegmentOff (RegAddrWidth (ArchReg arch))
src ParsedBlock arch ids
pb'
    let insAddr :: FunctionExploreReason (ArchAddrWidth arch) -> ArchSegmentOff arch -> FunM arch s ids ()
        insAddr :: FunctionExploreReason (RegAddrWidth (ArchReg arch))
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> FunM arch s ids ()
insAddr FunctionExploreReason (RegAddrWidth (ArchReg arch))
rsn MemSegmentOff (RegAddrWidth (ArchReg arch))
a
          | Memory (RegAddrWidth (ArchReg arch))
-> (MemSegmentOff (RegAddrWidth (ArchReg arch)) -> Bool)
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Bool
forall (w :: Natural).
Memory w -> (MemSegmentOff w -> Bool) -> MemSegmentOff w -> Bool
explorableFunction Memory (RegAddrWidth (ArchReg arch))
mem MemSegmentOff (RegAddrWidth (ArchReg arch)) -> Bool
fnPred MemSegmentOff (RegAddrWidth (ArchReg arch))
a =
              (CandidateFunctionMap arch -> Identity (CandidateFunctionMap arch))
-> FunState arch s ids -> Identity (FunState arch s ids)
forall arch s ids (f :: Type -> Type).
Functor f =>
(CandidateFunctionMap arch -> f (CandidateFunctionMap arch))
-> FunState arch s ids -> f (FunState arch s ids)
newEntries ((CandidateFunctionMap arch
  -> Identity (CandidateFunctionMap arch))
 -> FunState arch s ids -> Identity (FunState arch s ids))
-> (CandidateFunctionMap arch -> CandidateFunctionMap arch)
-> FunM arch s ids ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (FunctionExploreReason (RegAddrWidth (ArchReg arch))
 -> FunctionExploreReason (RegAddrWidth (ArchReg arch))
 -> FunctionExploreReason (RegAddrWidth (ArchReg arch)))
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> FunctionExploreReason (RegAddrWidth (ArchReg arch))
-> CandidateFunctionMap arch
-> CandidateFunctionMap arch
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (\FunctionExploreReason (RegAddrWidth (ArchReg arch))
_ FunctionExploreReason (RegAddrWidth (ArchReg arch))
o -> FunctionExploreReason (RegAddrWidth (ArchReg arch))
o) MemSegmentOff (RegAddrWidth (ArchReg arch))
a FunctionExploreReason (RegAddrWidth (ArchReg arch))
rsn
          | Bool
otherwise =
              () -> FunM arch s ids ()
forall a. a -> FunM arch s ids a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
    (MemSegmentOff (RegAddrWidth (ArchReg arch)) -> FunM arch s ids ())
-> [MemSegmentOff (RegAddrWidth (ArchReg arch))]
-> FunM arch s ids ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FunctionExploreReason (RegAddrWidth (ArchReg arch))
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> FunM arch s ids ()
insAddr (MemSegmentOff (RegAddrWidth (ArchReg arch))
-> FunctionExploreReason (RegAddrWidth (ArchReg arch))
forall (w :: Natural). MemSegmentOff w -> FunctionExploreReason w
CallTarget MemSegmentOff (RegAddrWidth (ArchReg arch))
src)) (ParsedContents arch ids
-> [MemSegmentOff (RegAddrWidth (ArchReg arch))]
forall arch ids. ParsedContents arch ids -> [ArchSegmentOff arch]
newFunctionAddrs ParsedContents arch ids
pc)
    (MemSegmentOff (RegAddrWidth (ArchReg arch)) -> FunM arch s ids ())
-> [MemSegmentOff (RegAddrWidth (ArchReg arch))]
-> FunM arch s ids ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FunctionExploreReason (RegAddrWidth (ArchReg arch))
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> FunM arch s ids ()
insAddr (MemSegmentOff (RegAddrWidth (ArchReg arch))
-> FunctionExploreReason (RegAddrWidth (ArchReg arch))
forall (w :: Natural). MemSegmentOff w -> FunctionExploreReason w
PossibleWriteEntry MemSegmentOff (RegAddrWidth (ArchReg arch))
src)) (ParsedContents arch ids
-> [MemSegmentOff (RegAddrWidth (ArchReg arch))]
forall arch ids. ParsedContents arch ids -> [ArchSegmentOff arch]
writtenCodeAddrs ParsedContents arch ids
pc)
    ((MemSegmentOff (RegAddrWidth (ArchReg arch)),
  AbsBlockState (ArchReg arch), InitJumpBounds arch)
 -> FunM arch s ids ())
-> [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
     AbsBlockState (ArchReg arch), InitJumpBounds arch)]
-> FunM arch s ids ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ArchitectureInfo arch
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> (MemSegmentOff (RegAddrWidth (ArchReg arch)),
    AbsBlockState (ArchReg arch), InitJumpBounds arch)
-> FunM arch s ids ()
forall arch s ids.
ArchitectureInfo arch
-> ArchSegmentOff arch
-> IntraJumpTarget arch
-> FunM arch s ids ()
mergeIntraJump ArchitectureInfo arch
ainfo MemSegmentOff (RegAddrWidth (ArchReg arch))
src) (ParsedContents arch ids
-> [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
     AbsBlockState (ArchReg arch), InitJumpBounds arch)]
forall arch ids. ParsedContents arch ids -> [IntraJumpTarget arch]
intraJumpTargets ParsedContents arch ids
pc)

-- | Make an error block with no statements for the given address.
mkErrorBlock :: ArchSegmentOff arch -> FoundAddr arch -> String -> ParsedBlock arch ids
mkErrorBlock :: forall arch ids.
ArchSegmentOff arch
-> FoundAddr arch -> String -> ParsedBlock arch ids
mkErrorBlock ArchSegmentOff arch
addr FoundAddr arch
finfo String
err =
  ParsedBlock { pblockAddr :: ArchSegmentOff arch
pblockAddr = ArchSegmentOff arch
addr
              , pblockPrecond :: Either String (ArchBlockPrecond arch)
pblockPrecond = String -> Either String (ArchBlockPrecond arch)
forall a b. a -> Either a b
Left String
err
              , blockSize :: Int
blockSize = Int
0
              , blockReason :: BlockExploreReason (ArchAddrWidth arch)
blockReason = FoundAddr arch -> BlockExploreReason (ArchAddrWidth arch)
forall arch.
FoundAddr arch -> BlockExploreReason (ArchAddrWidth arch)
foundReason FoundAddr arch
finfo
              , blockAbstractState :: AbsBlockState (ArchReg arch)
blockAbstractState = FoundAddr arch -> AbsBlockState (ArchReg arch)
forall arch. FoundAddr arch -> AbsBlockState (ArchReg arch)
foundAbstractState FoundAddr arch
finfo
              , blockJumpBounds :: InitJumpBounds arch
blockJumpBounds    = FoundAddr arch -> InitJumpBounds arch
forall arch. FoundAddr arch -> InitJumpBounds arch
foundJumpBounds FoundAddr arch
finfo
              , pblockStmts :: [Stmt arch ids]
pblockStmts = []
              , pblockTermStmt :: ParsedTermStmt arch ids
pblockTermStmt = Text -> ParsedTermStmt arch ids
forall arch ids. Text -> ParsedTermStmt arch ids
ParsedTranslateError (String -> Text
Text.pack String
err)
              }

transfer :: ArchSegmentOff arch
         -> FunState arch s ids
         -> STL.ST s (FunState arch s ids)
transfer :: forall arch s ids.
ArchSegmentOff arch
-> FunState arch s ids -> ST s (FunState arch s ids)
transfer ArchSegmentOff arch
addr FunState arch s ids
s0 = do
  let ctx :: DiscoveryState arch
ctx = FunState arch s ids
s0FunState arch s ids
-> Getting
     (DiscoveryState arch) (FunState arch s ids) (DiscoveryState arch)
-> DiscoveryState arch
forall s a. s -> Getting a s a -> a
^.Getting
  (DiscoveryState arch) (FunState arch s ids) (DiscoveryState arch)
forall arch s ids (f :: Type -> Type).
Functor f =>
(DiscoveryState arch -> f (DiscoveryState arch))
-> FunState arch s ids -> f (FunState arch s ids)
curFunCtx
  let ainfo :: ArchitectureInfo arch
ainfo = DiscoveryState arch -> ArchitectureInfo arch
forall arch. DiscoveryState arch -> ArchitectureInfo arch
archInfo DiscoveryState arch
ctx
  ArchitectureInfo arch -> forall a. (ArchConstraints arch => a) -> a
forall arch.
ArchitectureInfo arch -> forall a. (ArchConstraints arch => a) -> a
withArchConstraints ArchitectureInfo arch
ainfo ((ArchConstraints arch => ST s (FunState arch s ids))
 -> ST s (FunState arch s ids))
-> (ArchConstraints arch => ST s (FunState arch s ids))
-> ST s (FunState arch s ids)
forall a b. (a -> b) -> a -> b
$ do
    let emsg :: FoundAddr arch
emsg = String -> FoundAddr arch
forall a. HasCallStack => String -> a
error (String -> FoundAddr arch) -> String -> FoundAddr arch
forall a b. (a -> b) -> a -> b
$ String
"transfer called on unfound address " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ArchSegmentOff arch -> String
forall a. Show a => a -> String
show ArchSegmentOff arch
addr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
    let finfo :: FoundAddr arch
finfo = FoundAddr arch
-> ArchSegmentOff arch
-> Map (ArchSegmentOff arch) (FoundAddr arch)
-> FoundAddr arch
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault FoundAddr arch
emsg ArchSegmentOff arch
addr (FunState arch s ids
s0FunState arch s ids
-> Getting
     (Map (ArchSegmentOff arch) (FoundAddr arch))
     (FunState arch s ids)
     (Map (ArchSegmentOff arch) (FoundAddr arch))
-> Map (ArchSegmentOff arch) (FoundAddr arch)
forall s a. s -> Getting a s a -> a
^.Getting
  (Map (ArchSegmentOff arch) (FoundAddr arch))
  (FunState arch s ids)
  (Map (ArchSegmentOff arch) (FoundAddr arch))
forall arch s ids (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (FoundAddr arch)
 -> f (Map (ArchSegmentOff arch) (FoundAddr arch)))
-> FunState arch s ids -> f (FunState arch s ids)
foundAddrs)
    -- Get maximum number of bytes to disassemble
    case ArchitectureInfo arch
-> ArchSegmentOff arch
-> AbsBlockState (ArchReg arch)
-> Either String (ArchBlockPrecond arch)
forall arch.
ArchitectureInfo arch
-> ArchSegmentOff arch
-> AbsBlockState (ArchReg arch)
-> Either String (ArchBlockPrecond arch)
extractBlockPrecond ArchitectureInfo arch
ainfo ArchSegmentOff arch
addr (FoundAddr arch -> AbsBlockState (ArchReg arch)
forall arch. FoundAddr arch -> AbsBlockState (ArchReg arch)
foundAbstractState FoundAddr arch
finfo) of
      Left String
msg -> FunState arch s ids -> ST s (FunState arch s ids)
forall a. a -> ST s a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ArchSegmentOff arch
-> ParsedBlock arch ids
-> FunState arch s ids
-> FunState arch s ids
forall arch ids s.
MemWidth (ArchAddrWidth arch) =>
ArchSegmentOff arch
-> ParsedBlock arch ids
-> FunState arch s ids
-> FunState arch s ids
addFunBlock ArchSegmentOff arch
addr (ArchSegmentOff arch
-> FoundAddr arch -> String -> ParsedBlock arch ids
forall arch ids.
ArchSegmentOff arch
-> FoundAddr arch -> String -> ParsedBlock arch ids
mkErrorBlock ArchSegmentOff arch
addr FoundAddr arch
finfo String
msg) FunState arch s ids
s0)
      Right ArchBlockPrecond arch
pr -> DiscoveryState arch
-> ArchSegmentOff arch
-> FoundAddr arch
-> ArchBlockPrecond arch
-> FunState arch s ids
-> ST s (FunState arch s ids)
forall s arch ids.
ArchConstraints arch =>
DiscoveryState arch
-> ArchSegmentOff arch
-> FoundAddr arch
-> ArchBlockPrecond arch
-> FunState arch s ids
-> ST s (FunState arch s ids)
addBlock DiscoveryState arch
ctx ArchSegmentOff arch
addr FoundAddr arch
finfo ArchBlockPrecond arch
pr FunState arch s ids
s0

------------------------------------------------------------------------
-- Main loop

mkFunState :: PN.NonceGenerator (STS.ST s) ids
           -> DiscoveryState arch
           -> FunctionExploreReason (ArchAddrWidth arch)
              -- ^ Reason to provide for why we are analyzing this function
              --
              -- This can be used to figure out why we decided a
              -- given address identified a code location.
           -> ArchSegmentOff arch
           -> [(ArchSegmentOff arch, [ArchSegmentOff arch])]
           -> FunState arch s ids
mkFunState :: forall s ids arch.
NonceGenerator (ST s) ids
-> DiscoveryState arch
-> FunctionExploreReason (ArchAddrWidth arch)
-> ArchSegmentOff arch
-> [(ArchSegmentOff arch, [ArchSegmentOff arch])]
-> FunState arch s ids
mkFunState NonceGenerator (ST s) ids
gen DiscoveryState arch
s FunctionExploreReason (RegAddrWidth (ArchReg arch))
rsn MemSegmentOff (RegAddrWidth (ArchReg arch))
addr [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
  [MemSegmentOff (RegAddrWidth (ArchReg arch))])]
extraIntraTargets = do
  let faddr :: FoundAddr arch
faddr = FoundAddr { foundReason :: BlockExploreReason (RegAddrWidth (ArchReg arch))
foundReason = BlockExploreReason (RegAddrWidth (ArchReg arch))
forall (w :: Natural). BlockExploreReason w
FunctionEntryPoint
                        , foundAbstractState :: AbsBlockState (ArchReg arch)
foundAbstractState = ArchitectureInfo arch
-> Memory (RegAddrWidth (ArchReg arch))
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> AbsBlockState (ArchReg arch)
forall arch.
ArchitectureInfo arch
-> Memory (ArchAddrWidth arch)
-> ArchSegmentOff arch
-> AbsBlockState (ArchReg arch)
mkInitialAbsState (DiscoveryState arch -> ArchitectureInfo arch
forall arch. DiscoveryState arch -> ArchitectureInfo arch
archInfo DiscoveryState arch
s) (DiscoveryState arch -> Memory (RegAddrWidth (ArchReg arch))
forall arch. DiscoveryState arch -> Memory (ArchAddrWidth arch)
memory DiscoveryState arch
s) MemSegmentOff (RegAddrWidth (ArchReg arch))
addr
                        , foundJumpBounds :: InitJumpBounds arch
foundJumpBounds    = ArchitectureInfo arch -> forall a. (ArchConstraints arch => a) -> a
forall arch.
ArchitectureInfo arch -> forall a. (ArchConstraints arch => a) -> a
withArchConstraints (DiscoveryState arch -> ArchitectureInfo arch
forall arch. DiscoveryState arch -> ArchitectureInfo arch
archInfo DiscoveryState arch
s) InitJumpBounds arch
ArchConstraints arch => InitJumpBounds arch
forall arch. RegisterInfo (ArchReg arch) => InitJumpBounds arch
Jmp.functionStartBounds
                        }
   in FunState { funReason :: FunctionExploreReason (RegAddrWidth (ArchReg arch))
funReason = FunctionExploreReason (RegAddrWidth (ArchReg arch))
rsn
               , funNonceGen :: NonceGenerator (ST s) ids
funNonceGen = NonceGenerator (ST s) ids
gen
               , curFunAddr :: MemSegmentOff (RegAddrWidth (ArchReg arch))
curFunAddr  = MemSegmentOff (RegAddrWidth (ArchReg arch))
addr
               , _curFunCtx :: DiscoveryState arch
_curFunCtx  = DiscoveryState arch
s
               , _curFunBlocks :: Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (ParsedBlock arch ids)
_curFunBlocks = Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (ParsedBlock arch ids)
forall k a. Map k a
Map.empty
               , _foundAddrs :: Map (MemSegmentOff (RegAddrWidth (ArchReg arch))) (FoundAddr arch)
_foundAddrs = MemSegmentOff (RegAddrWidth (ArchReg arch))
-> FoundAddr arch
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch))) (FoundAddr arch)
forall k a. k -> a -> Map k a
Map.singleton MemSegmentOff (RegAddrWidth (ArchReg arch))
addr FoundAddr arch
faddr
               , _reverseEdges :: ReverseEdgeMap arch
_reverseEdges = ReverseEdgeMap arch
forall k a. Map k a
Map.empty
               , _frontier :: Set (MemSegmentOff (RegAddrWidth (ArchReg arch)))
_frontier   = [MemSegmentOff (RegAddrWidth (ArchReg arch))]
-> Set (MemSegmentOff (RegAddrWidth (ArchReg arch)))
forall a. Ord a => [a] -> Set a
Set.fromList [ MemSegmentOff (RegAddrWidth (ArchReg arch))
addr ]
               , _newEntries :: CandidateFunctionMap arch
_newEntries = CandidateFunctionMap arch
forall k a. Map k a
Map.empty
               , classifyFailureResolutions :: [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
  [MemSegmentOff (RegAddrWidth (ArchReg arch))])]
classifyFailureResolutions = [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
  [MemSegmentOff (RegAddrWidth (ArchReg arch))])]
extraIntraTargets
               }

mkFunInfo :: DiscoveryState arch -> FunState arch s ids -> DiscoveryFunInfo arch ids
mkFunInfo :: forall arch s ids.
DiscoveryState arch
-> FunState arch s ids -> DiscoveryFunInfo arch ids
mkFunInfo DiscoveryState arch
s FunState arch s ids
fs =
  let addr :: MemSegmentOff (RegAddrWidth (ArchReg arch))
addr = FunState arch s ids -> MemSegmentOff (RegAddrWidth (ArchReg arch))
forall arch s ids. FunState arch s ids -> ArchSegmentOff arch
curFunAddr FunState arch s ids
fs
   in DiscoveryFunInfo { discoveredFunReason :: FunctionExploreReason (RegAddrWidth (ArchReg arch))
discoveredFunReason = FunState arch s ids
-> FunctionExploreReason (RegAddrWidth (ArchReg arch))
forall arch s ids.
FunState arch s ids -> FunctionExploreReason (ArchAddrWidth arch)
funReason FunState arch s ids
fs
                       , discoveredFunAddr :: MemSegmentOff (RegAddrWidth (ArchReg arch))
discoveredFunAddr = MemSegmentOff (RegAddrWidth (ArchReg arch))
addr
                       , discoveredFunSymbol :: Maybe ByteString
discoveredFunSymbol = MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Map (MemSegmentOff (RegAddrWidth (ArchReg arch))) ByteString
-> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup MemSegmentOff (RegAddrWidth (ArchReg arch))
addr (DiscoveryState arch
-> Map (MemSegmentOff (RegAddrWidth (ArchReg arch))) ByteString
forall arch. DiscoveryState arch -> AddrSymMap (ArchAddrWidth arch)
symbolNames DiscoveryState arch
s)
                       , _parsedBlocks :: Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (ParsedBlock arch ids)
_parsedBlocks = FunState arch s ids
fsFunState arch s ids
-> Getting
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (ParsedBlock arch ids))
     (FunState arch s ids)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (ParsedBlock arch ids))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (ParsedBlock arch ids)
forall s a. s -> Getting a s a -> a
^.Getting
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (ParsedBlock arch ids))
  (FunState arch s ids)
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (ParsedBlock arch ids))
forall arch s ids (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (ParsedBlock arch ids)
 -> f (Map (ArchSegmentOff arch) (ParsedBlock arch ids)))
-> FunState arch s ids -> f (FunState arch s ids)
curFunBlocks
                       , discoveredClassifyFailureResolutions :: [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
  [MemSegmentOff (RegAddrWidth (ArchReg arch))])]
discoveredClassifyFailureResolutions = FunState arch s ids
-> [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
     [MemSegmentOff (RegAddrWidth (ArchReg arch))])]
forall arch s ids.
FunState arch s ids
-> [(ArchSegmentOff arch, [ArchSegmentOff arch])]
classifyFailureResolutions FunState arch s ids
fs
                       }

-- | Loop that repeatedly explore blocks until we have explored blocks
-- on the frontier.

reportAnalyzeBlock :: DiscoveryOptions
                      -- ^ Options controlling discovery
                   -> ArchSegmentOff arch -- ^ Function address
                   -> ArchSegmentOff arch -- ^ Block address
                   -> Maybe (BlockExploreReason (ArchAddrWidth arch))
                   -> IncComp (DiscoveryEvent arch) a
                   -> IncComp (DiscoveryEvent arch) a
reportAnalyzeBlock :: forall arch a.
DiscoveryOptions
-> ArchSegmentOff arch
-> ArchSegmentOff arch
-> Maybe (BlockExploreReason (ArchAddrWidth arch))
-> IncComp (DiscoveryEvent arch) a
-> IncComp (DiscoveryEvent arch) a
reportAnalyzeBlock DiscoveryOptions
disOpts ArchSegmentOff arch
faddr ArchSegmentOff arch
baddr Maybe (BlockExploreReason (ArchAddrWidth arch))
mReason
  | DiscoveryOptions -> Bool
logAtAnalyzeBlock DiscoveryOptions
disOpts = DiscoveryEvent arch
-> IncComp (DiscoveryEvent arch) a
-> IncComp (DiscoveryEvent arch) a
forall l r. l -> IncComp l r -> IncComp l r
IncCompLog (ArchSegmentOff arch
-> ArchSegmentOff arch
-> Maybe (BlockExploreReason (ArchAddrWidth arch))
-> DiscoveryEvent arch
forall arch.
ArchSegmentOff arch
-> ArchSegmentOff arch
-> Maybe (BlockExploreReason (ArchAddrWidth arch))
-> DiscoveryEvent arch
ReportAnalyzeBlock ArchSegmentOff arch
faddr ArchSegmentOff arch
baddr Maybe (BlockExploreReason (ArchAddrWidth arch))
mReason)
  | Bool
otherwise = IncComp (DiscoveryEvent arch) a -> IncComp (DiscoveryEvent arch) a
forall a. a -> a
id

analyzeBlocks :: DiscoveryOptions
                -- ^ Options controlling discovery
              -> DiscoveryState arch
              -> ArchSegmentOff arch
                    -- ^ The address to explore
              -> FunState arch s ids
              -> STL.ST s (IncComp (DiscoveryEvent arch)
                                   (DiscoveryState arch, Some (DiscoveryFunInfo arch)))
analyzeBlocks :: forall arch s ids.
DiscoveryOptions
-> DiscoveryState arch
-> ArchSegmentOff arch
-> FunState arch s ids
-> ST
     s
     (IncComp
        (DiscoveryEvent arch)
        (DiscoveryState arch, Some (DiscoveryFunInfo arch)))
analyzeBlocks DiscoveryOptions
disOpts DiscoveryState arch
ds0 MemSegmentOff (RegAddrWidth (ArchReg arch))
faddr FunState arch s ids
fs =
  case Set (MemSegmentOff (RegAddrWidth (ArchReg arch)))
-> Maybe
     (MemSegmentOff (RegAddrWidth (ArchReg arch)),
      Set (MemSegmentOff (RegAddrWidth (ArchReg arch))))
forall a. Set a -> Maybe (a, Set a)
Set.minView (FunState arch s ids
fsFunState arch s ids
-> Getting
     (Set (MemSegmentOff (RegAddrWidth (ArchReg arch))))
     (FunState arch s ids)
     (Set (MemSegmentOff (RegAddrWidth (ArchReg arch))))
-> Set (MemSegmentOff (RegAddrWidth (ArchReg arch)))
forall s a. s -> Getting a s a -> a
^.Getting
  (Set (MemSegmentOff (RegAddrWidth (ArchReg arch))))
  (FunState arch s ids)
  (Set (MemSegmentOff (RegAddrWidth (ArchReg arch))))
forall arch s ids (f :: Type -> Type).
Functor f =>
(Set (ArchSegmentOff arch) -> f (Set (ArchSegmentOff arch)))
-> FunState arch s ids -> f (FunState arch s ids)
frontier) of
    Maybe
  (MemSegmentOff (RegAddrWidth (ArchReg arch)),
   Set (MemSegmentOff (RegAddrWidth (ArchReg arch))))
Nothing -> do
      let finfo :: DiscoveryFunInfo arch ids
finfo = DiscoveryState arch
-> FunState arch s ids -> DiscoveryFunInfo arch ids
forall arch s ids.
DiscoveryState arch
-> FunState arch s ids -> DiscoveryFunInfo arch ids
mkFunInfo DiscoveryState arch
ds0 FunState arch s ids
fs
      let ds1 :: DiscoveryState arch
ds1 = DiscoveryState arch
ds0
              DiscoveryState arch
-> (DiscoveryState arch -> DiscoveryState arch)
-> DiscoveryState arch
forall a b. a -> (a -> b) -> b
& (Map
   (MemSegmentOff (RegAddrWidth (ArchReg arch)))
   (Some (DiscoveryFunInfo arch))
 -> Identity
      (Map
         (MemSegmentOff (RegAddrWidth (ArchReg arch)))
         (Some (DiscoveryFunInfo arch))))
-> DiscoveryState arch -> Identity (DiscoveryState arch)
forall arch (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (Some (DiscoveryFunInfo arch))
 -> f (Map (ArchSegmentOff arch) (Some (DiscoveryFunInfo arch))))
-> DiscoveryState arch -> f (DiscoveryState arch)
funInfo             ((Map
    (MemSegmentOff (RegAddrWidth (ArchReg arch)))
    (Some (DiscoveryFunInfo arch))
  -> Identity
       (Map
          (MemSegmentOff (RegAddrWidth (ArchReg arch)))
          (Some (DiscoveryFunInfo arch))))
 -> DiscoveryState arch -> Identity (DiscoveryState arch))
-> (Map
      (MemSegmentOff (RegAddrWidth (ArchReg arch)))
      (Some (DiscoveryFunInfo arch))
    -> Map
         (MemSegmentOff (RegAddrWidth (ArchReg arch)))
         (Some (DiscoveryFunInfo arch)))
-> DiscoveryState arch
-> DiscoveryState arch
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Some (DiscoveryFunInfo arch)
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (Some (DiscoveryFunInfo arch))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (Some (DiscoveryFunInfo arch))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert MemSegmentOff (RegAddrWidth (ArchReg arch))
faddr (DiscoveryFunInfo arch ids -> Some (DiscoveryFunInfo arch)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some DiscoveryFunInfo arch ids
finfo)
              DiscoveryState arch
-> (DiscoveryState arch -> DiscoveryState arch)
-> DiscoveryState arch
forall a b. a -> (a -> b) -> b
& (Map
   (MemSegmentOff (RegAddrWidth (ArchReg arch)))
   (FunctionExploreReason (RegAddrWidth (ArchReg arch)))
 -> Identity
      (Map
         (MemSegmentOff (RegAddrWidth (ArchReg arch)))
         (FunctionExploreReason (RegAddrWidth (ArchReg arch)))))
-> DiscoveryState arch -> Identity (DiscoveryState arch)
forall arch (f :: Type -> Type).
Functor f =>
(UnexploredFunctionMap arch -> f (UnexploredFunctionMap arch))
-> DiscoveryState arch -> f (DiscoveryState arch)
unexploredFunctions ((Map
    (MemSegmentOff (RegAddrWidth (ArchReg arch)))
    (FunctionExploreReason (RegAddrWidth (ArchReg arch)))
  -> Identity
       (Map
          (MemSegmentOff (RegAddrWidth (ArchReg arch)))
          (FunctionExploreReason (RegAddrWidth (ArchReg arch)))))
 -> DiscoveryState arch -> Identity (DiscoveryState arch))
-> (Map
      (MemSegmentOff (RegAddrWidth (ArchReg arch)))
      (FunctionExploreReason (RegAddrWidth (ArchReg arch)))
    -> Map
         (MemSegmentOff (RegAddrWidth (ArchReg arch)))
         (FunctionExploreReason (RegAddrWidth (ArchReg arch))))
-> DiscoveryState arch
-> DiscoveryState arch
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (FunctionExploreReason (RegAddrWidth (ArchReg arch)))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (FunctionExploreReason (RegAddrWidth (ArchReg arch)))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete MemSegmentOff (RegAddrWidth (ArchReg arch))
faddr
          go :: DiscoveryState arch
-> [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
     FunctionExploreReason (RegAddrWidth (ArchReg arch)))]
-> IncComp
     (DiscoveryEvent arch)
     (DiscoveryState arch, Some (DiscoveryFunInfo arch))
go DiscoveryState arch
ds [] = (DiscoveryState arch, Some (DiscoveryFunInfo arch))
-> IncComp
     (DiscoveryEvent arch)
     (DiscoveryState arch, Some (DiscoveryFunInfo arch))
forall l r. r -> IncComp l r
IncCompDone (DiscoveryState arch
ds, DiscoveryFunInfo arch ids -> Some (DiscoveryFunInfo arch)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some DiscoveryFunInfo arch ids
finfo)
          go DiscoveryState arch
ds ((MemSegmentOff (RegAddrWidth (ArchReg arch))
tgt,FunctionExploreReason (RegAddrWidth (ArchReg arch))
rsn):[(MemSegmentOff (RegAddrWidth (ArchReg arch)),
  FunctionExploreReason (RegAddrWidth (ArchReg arch)))]
r)
            | MemSegmentOff (RegAddrWidth (ArchReg arch))
-> DiscoveryState arch -> Bool
forall arch. ArchSegmentOff arch -> DiscoveryState arch -> Bool
shouldExploreFunction MemSegmentOff (RegAddrWidth (ArchReg arch))
tgt DiscoveryState arch
ds =
              DiscoveryEvent arch
-> IncComp
     (DiscoveryEvent arch)
     (DiscoveryState arch, Some (DiscoveryFunInfo arch))
-> IncComp
     (DiscoveryEvent arch)
     (DiscoveryState arch, Some (DiscoveryFunInfo arch))
forall l r. l -> IncComp l r -> IncComp l r
IncCompLog
                (MemSegmentOff (RegAddrWidth (ArchReg arch))
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> FunctionExploreReason (RegAddrWidth (ArchReg arch))
-> DiscoveryEvent arch
forall arch.
ArchSegmentOff arch
-> ArchSegmentOff arch
-> FunctionExploreReason (ArchAddrWidth arch)
-> DiscoveryEvent arch
ReportIdentifyFunction MemSegmentOff (RegAddrWidth (ArchReg arch))
faddr MemSegmentOff (RegAddrWidth (ArchReg arch))
tgt FunctionExploreReason (RegAddrWidth (ArchReg arch))
rsn)
                (DiscoveryState arch
-> [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
     FunctionExploreReason (RegAddrWidth (ArchReg arch)))]
-> IncComp
     (DiscoveryEvent arch)
     (DiscoveryState arch, Some (DiscoveryFunInfo arch))
go (DiscoveryState arch
ds DiscoveryState arch
-> (DiscoveryState arch -> DiscoveryState arch)
-> DiscoveryState arch
forall a b. a -> (a -> b) -> b
& (Map
   (MemSegmentOff (RegAddrWidth (ArchReg arch)))
   (FunctionExploreReason (RegAddrWidth (ArchReg arch)))
 -> Identity
      (Map
         (MemSegmentOff (RegAddrWidth (ArchReg arch)))
         (FunctionExploreReason (RegAddrWidth (ArchReg arch)))))
-> DiscoveryState arch -> Identity (DiscoveryState arch)
forall arch (f :: Type -> Type).
Functor f =>
(UnexploredFunctionMap arch -> f (UnexploredFunctionMap arch))
-> DiscoveryState arch -> f (DiscoveryState arch)
unexploredFunctions ((Map
    (MemSegmentOff (RegAddrWidth (ArchReg arch)))
    (FunctionExploreReason (RegAddrWidth (ArchReg arch)))
  -> Identity
       (Map
          (MemSegmentOff (RegAddrWidth (ArchReg arch)))
          (FunctionExploreReason (RegAddrWidth (ArchReg arch)))))
 -> DiscoveryState arch -> Identity (DiscoveryState arch))
-> (Map
      (MemSegmentOff (RegAddrWidth (ArchReg arch)))
      (FunctionExploreReason (RegAddrWidth (ArchReg arch)))
    -> Map
         (MemSegmentOff (RegAddrWidth (ArchReg arch)))
         (FunctionExploreReason (RegAddrWidth (ArchReg arch))))
-> DiscoveryState arch
-> DiscoveryState arch
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ MemSegmentOff (RegAddrWidth (ArchReg arch))
-> FunctionExploreReason (RegAddrWidth (ArchReg arch))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (FunctionExploreReason (RegAddrWidth (ArchReg arch)))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (FunctionExploreReason (RegAddrWidth (ArchReg arch)))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert MemSegmentOff (RegAddrWidth (ArchReg arch))
tgt FunctionExploreReason (RegAddrWidth (ArchReg arch))
rsn) [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
  FunctionExploreReason (RegAddrWidth (ArchReg arch)))]
r)
            | Bool
otherwise = DiscoveryState arch
-> [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
     FunctionExploreReason (RegAddrWidth (ArchReg arch)))]
-> IncComp
     (DiscoveryEvent arch)
     (DiscoveryState arch, Some (DiscoveryFunInfo arch))
go DiscoveryState arch
ds [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
  FunctionExploreReason (RegAddrWidth (ArchReg arch)))]
r
      IncComp
  (DiscoveryEvent arch)
  (DiscoveryState arch, Some (DiscoveryFunInfo arch))
-> ST
     s
     (IncComp
        (DiscoveryEvent arch)
        (DiscoveryState arch, Some (DiscoveryFunInfo arch)))
forall a. a -> ST s a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (IncComp
   (DiscoveryEvent arch)
   (DiscoveryState arch, Some (DiscoveryFunInfo arch))
 -> ST
      s
      (IncComp
         (DiscoveryEvent arch)
         (DiscoveryState arch, Some (DiscoveryFunInfo arch))))
-> IncComp
     (DiscoveryEvent arch)
     (DiscoveryState arch, Some (DiscoveryFunInfo arch))
-> ST
     s
     (IncComp
        (DiscoveryEvent arch)
        (DiscoveryState arch, Some (DiscoveryFunInfo arch)))
forall a b. (a -> b) -> a -> b
$ DiscoveryState arch
-> [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
     FunctionExploreReason (RegAddrWidth (ArchReg arch)))]
-> IncComp
     (DiscoveryEvent arch)
     (DiscoveryState arch, Some (DiscoveryFunInfo arch))
go DiscoveryState arch
ds1 (Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (FunctionExploreReason (RegAddrWidth (ArchReg arch)))
-> [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
     FunctionExploreReason (RegAddrWidth (ArchReg arch)))]
forall k a. Map k a -> [(k, a)]
Map.toList (FunState arch s ids
fsFunState arch s ids
-> Getting
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (FunctionExploreReason (RegAddrWidth (ArchReg arch))))
     (FunState arch s ids)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (FunctionExploreReason (RegAddrWidth (ArchReg arch))))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (FunctionExploreReason (RegAddrWidth (ArchReg arch)))
forall s a. s -> Getting a s a -> a
^.Getting
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (FunctionExploreReason (RegAddrWidth (ArchReg arch))))
  (FunState arch s ids)
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (FunctionExploreReason (RegAddrWidth (ArchReg arch))))
forall arch s ids (f :: Type -> Type).
Functor f =>
(CandidateFunctionMap arch -> f (CandidateFunctionMap arch))
-> FunState arch s ids -> f (FunState arch s ids)
newEntries))
    Just (MemSegmentOff (RegAddrWidth (ArchReg arch))
baddr, Set (MemSegmentOff (RegAddrWidth (ArchReg arch)))
next_roots) ->
      let mReason :: Maybe (BlockExploreReason (RegAddrWidth (ArchReg arch)))
mReason = FunState arch s ids
fsFunState arch s ids
-> Getting
     (Maybe (FoundAddr arch))
     (FunState arch s ids)
     (Maybe (FoundAddr arch))
-> Maybe (FoundAddr arch)
forall s a. s -> Getting a s a -> a
^.(Map (MemSegmentOff (RegAddrWidth (ArchReg arch))) (FoundAddr arch)
 -> Const
      (Maybe (FoundAddr arch))
      (Map
         (MemSegmentOff (RegAddrWidth (ArchReg arch))) (FoundAddr arch)))
-> FunState arch s ids
-> Const (Maybe (FoundAddr arch)) (FunState arch s ids)
forall arch s ids (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (FoundAddr arch)
 -> f (Map (ArchSegmentOff arch) (FoundAddr arch)))
-> FunState arch s ids -> f (FunState arch s ids)
foundAddrs((Map
    (MemSegmentOff (RegAddrWidth (ArchReg arch))) (FoundAddr arch)
  -> Const
       (Maybe (FoundAddr arch))
       (Map
          (MemSegmentOff (RegAddrWidth (ArchReg arch))) (FoundAddr arch)))
 -> FunState arch s ids
 -> Const (Maybe (FoundAddr arch)) (FunState arch s ids))
-> ((Maybe (FoundAddr arch)
     -> Const (Maybe (FoundAddr arch)) (Maybe (FoundAddr arch)))
    -> Map
         (MemSegmentOff (RegAddrWidth (ArchReg arch))) (FoundAddr arch)
    -> Const
         (Maybe (FoundAddr arch))
         (Map
            (MemSegmentOff (RegAddrWidth (ArchReg arch))) (FoundAddr arch)))
-> Getting
     (Maybe (FoundAddr arch))
     (FunState arch s ids)
     (Maybe (FoundAddr arch))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Index
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch))) (FoundAddr arch))
-> Lens'
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch))) (FoundAddr arch))
     (Maybe
        (IxValue
           (Map
              (MemSegmentOff (RegAddrWidth (ArchReg arch))) (FoundAddr arch))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch))) (FoundAddr arch))
MemSegmentOff (RegAddrWidth (ArchReg arch))
baddrMaybe (FoundAddr arch)
-> Getting
     (First (BlockExploreReason (RegAddrWidth (ArchReg arch))))
     (Maybe (FoundAddr arch))
     (BlockExploreReason (RegAddrWidth (ArchReg arch)))
-> Maybe (BlockExploreReason (RegAddrWidth (ArchReg arch)))
forall s a. s -> Getting (First a) s a -> Maybe a
^?(FoundAddr arch
 -> Const
      (First (BlockExploreReason (RegAddrWidth (ArchReg arch))))
      (FoundAddr arch))
-> Maybe (FoundAddr arch)
-> Const
     (First (BlockExploreReason (RegAddrWidth (ArchReg arch))))
     (Maybe (FoundAddr arch))
forall a b (p :: Type -> Type -> Type) (f :: Type -> Type).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just((FoundAddr arch
  -> Const
       (First (BlockExploreReason (RegAddrWidth (ArchReg arch))))
       (FoundAddr arch))
 -> Maybe (FoundAddr arch)
 -> Const
      (First (BlockExploreReason (RegAddrWidth (ArchReg arch))))
      (Maybe (FoundAddr arch)))
-> ((BlockExploreReason (RegAddrWidth (ArchReg arch))
     -> Const
          (First (BlockExploreReason (RegAddrWidth (ArchReg arch))))
          (BlockExploreReason (RegAddrWidth (ArchReg arch))))
    -> FoundAddr arch
    -> Const
         (First (BlockExploreReason (RegAddrWidth (ArchReg arch))))
         (FoundAddr arch))
-> Getting
     (First (BlockExploreReason (RegAddrWidth (ArchReg arch))))
     (Maybe (FoundAddr arch))
     (BlockExploreReason (RegAddrWidth (ArchReg arch)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(BlockExploreReason (RegAddrWidth (ArchReg arch))
 -> Const
      (First (BlockExploreReason (RegAddrWidth (ArchReg arch))))
      (BlockExploreReason (RegAddrWidth (ArchReg arch))))
-> FoundAddr arch
-> Const
     (First (BlockExploreReason (RegAddrWidth (ArchReg arch))))
     (FoundAddr arch)
forall arch (f :: Type -> Type).
Functor f =>
(BlockExploreReason (ArchAddrWidth arch)
 -> f (BlockExploreReason (ArchAddrWidth arch)))
-> FoundAddr arch -> f (FoundAddr arch)
foundReasonL in
      (IncComp
   (DiscoveryEvent arch)
   (DiscoveryState arch, Some (DiscoveryFunInfo arch))
 -> IncComp
      (DiscoveryEvent arch)
      (DiscoveryState arch, Some (DiscoveryFunInfo arch)))
-> ST
     s
     (IncComp
        (DiscoveryEvent arch)
        (DiscoveryState arch, Some (DiscoveryFunInfo arch)))
-> ST
     s
     (IncComp
        (DiscoveryEvent arch)
        (DiscoveryState arch, Some (DiscoveryFunInfo arch)))
forall a b. (a -> b) -> ST s a -> ST s b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (DiscoveryOptions
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Maybe (BlockExploreReason (RegAddrWidth (ArchReg arch)))
-> IncComp
     (DiscoveryEvent arch)
     (DiscoveryState arch, Some (DiscoveryFunInfo arch))
-> IncComp
     (DiscoveryEvent arch)
     (DiscoveryState arch, Some (DiscoveryFunInfo arch))
forall arch a.
DiscoveryOptions
-> ArchSegmentOff arch
-> ArchSegmentOff arch
-> Maybe (BlockExploreReason (ArchAddrWidth arch))
-> IncComp (DiscoveryEvent arch) a
-> IncComp (DiscoveryEvent arch) a
reportAnalyzeBlock DiscoveryOptions
disOpts MemSegmentOff (RegAddrWidth (ArchReg arch))
faddr MemSegmentOff (RegAddrWidth (ArchReg arch))
baddr Maybe (BlockExploreReason (RegAddrWidth (ArchReg arch)))
mReason) (ST
   s
   (IncComp
      (DiscoveryEvent arch)
      (DiscoveryState arch, Some (DiscoveryFunInfo arch)))
 -> ST
      s
      (IncComp
         (DiscoveryEvent arch)
         (DiscoveryState arch, Some (DiscoveryFunInfo arch))))
-> ST
     s
     (IncComp
        (DiscoveryEvent arch)
        (DiscoveryState arch, Some (DiscoveryFunInfo arch)))
-> ST
     s
     (IncComp
        (DiscoveryEvent arch)
        (DiscoveryState arch, Some (DiscoveryFunInfo arch)))
forall a b. (a -> b) -> a -> b
$ do
        FunState arch s ids
fs' <- MemSegmentOff (RegAddrWidth (ArchReg arch))
-> FunState arch s ids -> ST s (FunState arch s ids)
forall arch s ids.
ArchSegmentOff arch
-> FunState arch s ids -> ST s (FunState arch s ids)
transfer MemSegmentOff (RegAddrWidth (ArchReg arch))
baddr (FunState arch s ids
fs FunState arch s ids
-> (FunState arch s ids -> FunState arch s ids)
-> FunState arch s ids
forall a b. a -> (a -> b) -> b
& (Set (MemSegmentOff (RegAddrWidth (ArchReg arch)))
 -> Identity (Set (MemSegmentOff (RegAddrWidth (ArchReg arch)))))
-> FunState arch s ids -> Identity (FunState arch s ids)
forall arch s ids (f :: Type -> Type).
Functor f =>
(Set (ArchSegmentOff arch) -> f (Set (ArchSegmentOff arch)))
-> FunState arch s ids -> f (FunState arch s ids)
frontier ((Set (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  -> Identity (Set (MemSegmentOff (RegAddrWidth (ArchReg arch)))))
 -> FunState arch s ids -> Identity (FunState arch s ids))
-> Set (MemSegmentOff (RegAddrWidth (ArchReg arch)))
-> FunState arch s ids
-> FunState arch s ids
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set (MemSegmentOff (RegAddrWidth (ArchReg arch)))
next_roots)
        DiscoveryOptions
-> DiscoveryState arch
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> FunState arch s ids
-> ST
     s
     (IncComp
        (DiscoveryEvent arch)
        (DiscoveryState arch, Some (DiscoveryFunInfo arch)))
forall arch s ids.
DiscoveryOptions
-> DiscoveryState arch
-> ArchSegmentOff arch
-> FunState arch s ids
-> ST
     s
     (IncComp
        (DiscoveryEvent arch)
        (DiscoveryState arch, Some (DiscoveryFunInfo arch)))
analyzeBlocks DiscoveryOptions
disOpts DiscoveryState arch
ds0 MemSegmentOff (RegAddrWidth (ArchReg arch))
faddr FunState arch s ids
fs'

-- | Run tfunction discovery to explore blocks.
discoverFunction :: DiscoveryOptions
                -- ^ Options controlling discovery
                -> ArchSegmentOff arch
                   -- ^ The address to explore
                -> FunctionExploreReason (ArchAddrWidth arch)
                    -- ^ Reason to provide for why we are analyzing this function
                    --
                    -- This can be used to figure out why we decided a
                    -- given address identified a code location.
                -> DiscoveryState arch
                   -- ^ The current binary information.
                -> [(ArchSegmentOff arch, [ArchSegmentOff arch])]
                   -- ^ Additional identified intraprocedural jump targets
                   --
                   -- The pairs are: (address of the block jumped from, jump targets)
                -> IncComp (DiscoveryEvent arch)
                           (DiscoveryState arch, Some (DiscoveryFunInfo arch))
discoverFunction :: forall arch.
DiscoveryOptions
-> ArchSegmentOff arch
-> FunctionExploreReason (ArchAddrWidth arch)
-> DiscoveryState arch
-> [(ArchSegmentOff arch, [ArchSegmentOff arch])]
-> IncComp
     (DiscoveryEvent arch)
     (DiscoveryState arch, Some (DiscoveryFunInfo arch))
discoverFunction DiscoveryOptions
disOpts ArchSegmentOff arch
addr FunctionExploreReason (ArchAddrWidth arch)
rsn DiscoveryState arch
s [(ArchSegmentOff arch, [ArchSegmentOff arch])]
extraIntraTargets = (forall s.
 ST
   s
   (IncComp
      (DiscoveryEvent arch)
      (DiscoveryState arch, Some (DiscoveryFunInfo arch))))
-> IncComp
     (DiscoveryEvent arch)
     (DiscoveryState arch, Some (DiscoveryFunInfo arch))
forall a. (forall s. ST s a) -> a
STL.runST ((forall s.
  ST
    s
    (IncComp
       (DiscoveryEvent arch)
       (DiscoveryState arch, Some (DiscoveryFunInfo arch))))
 -> IncComp
      (DiscoveryEvent arch)
      (DiscoveryState arch, Some (DiscoveryFunInfo arch)))
-> (forall s.
    ST
      s
      (IncComp
         (DiscoveryEvent arch)
         (DiscoveryState arch, Some (DiscoveryFunInfo arch))))
-> IncComp
     (DiscoveryEvent arch)
     (DiscoveryState arch, Some (DiscoveryFunInfo arch))
forall a b. (a -> b) -> a -> b
$ do
  Some NonceGenerator (ST s) x
gen <- ST s (Some (NonceGenerator (ST s)))
-> ST s (Some (NonceGenerator (ST s)))
forall s a. ST s a -> ST s a
STL.strictToLazyST ST s (Some (NonceGenerator (ST s)))
forall t. ST t (Some (NonceGenerator (ST t)))
PN.newSTNonceGenerator
  let fs0 :: FunState arch s x
fs0 = NonceGenerator (ST s) x
-> DiscoveryState arch
-> FunctionExploreReason (ArchAddrWidth arch)
-> ArchSegmentOff arch
-> [(ArchSegmentOff arch, [ArchSegmentOff arch])]
-> FunState arch s x
forall s ids arch.
NonceGenerator (ST s) ids
-> DiscoveryState arch
-> FunctionExploreReason (ArchAddrWidth arch)
-> ArchSegmentOff arch
-> [(ArchSegmentOff arch, [ArchSegmentOff arch])]
-> FunState arch s ids
mkFunState NonceGenerator (ST s) x
gen DiscoveryState arch
s FunctionExploreReason (ArchAddrWidth arch)
rsn ArchSegmentOff arch
addr [(ArchSegmentOff arch, [ArchSegmentOff arch])]
extraIntraTargets
  DiscoveryOptions
-> DiscoveryState arch
-> ArchSegmentOff arch
-> FunState arch s x
-> ST
     s
     (IncComp
        (DiscoveryEvent arch)
        (DiscoveryState arch, Some (DiscoveryFunInfo arch)))
forall arch s ids.
DiscoveryOptions
-> DiscoveryState arch
-> ArchSegmentOff arch
-> FunState arch s ids
-> ST
     s
     (IncComp
        (DiscoveryEvent arch)
        (DiscoveryState arch, Some (DiscoveryFunInfo arch)))
analyzeBlocks DiscoveryOptions
disOpts DiscoveryState arch
s ArchSegmentOff arch
addr FunState arch s x
fs0

-- | This analyzes the function at a given address, possibly
-- discovering new candidates.
--
-- This returns the updated state and the discovered control flow
-- graph for this function.
analyzeFunction :: ArchSegmentOff arch
                   -- ^ The address to explore
                -> FunctionExploreReason (ArchAddrWidth arch)
                -- ^ Reason to provide for why we are analyzing this function
                --
                -- This can be used to figure out why we decided a
                -- given address identified a code location.
                -> DiscoveryState arch
                -- ^ The current binary information.
                -> (DiscoveryState arch, Some (DiscoveryFunInfo arch))
analyzeFunction :: forall arch.
ArchSegmentOff arch
-> FunctionExploreReason (ArchAddrWidth arch)
-> DiscoveryState arch
-> (DiscoveryState arch, Some (DiscoveryFunInfo arch))
analyzeFunction MemSegmentOff (RegAddrWidth (ArchReg arch))
addr FunctionExploreReason (RegAddrWidth (ArchReg arch))
rsn DiscoveryState arch
s =
  case MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (Some (DiscoveryFunInfo arch))
-> Maybe (Some (DiscoveryFunInfo arch))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup MemSegmentOff (RegAddrWidth (ArchReg arch))
addr (DiscoveryState arch
sDiscoveryState arch
-> Getting
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (Some (DiscoveryFunInfo arch)))
     (DiscoveryState arch)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (Some (DiscoveryFunInfo arch)))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (Some (DiscoveryFunInfo arch))
forall s a. s -> Getting a s a -> a
^.Getting
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (Some (DiscoveryFunInfo arch)))
  (DiscoveryState arch)
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (Some (DiscoveryFunInfo arch)))
forall arch (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (Some (DiscoveryFunInfo arch))
 -> f (Map (ArchSegmentOff arch) (Some (DiscoveryFunInfo arch))))
-> DiscoveryState arch -> f (DiscoveryState arch)
funInfo) of
    Just Some (DiscoveryFunInfo arch)
finfo -> (DiscoveryState arch
s, Some (DiscoveryFunInfo arch)
finfo)
    Maybe (Some (DiscoveryFunInfo arch))
Nothing -> IncComp
  (DiscoveryEvent arch)
  (DiscoveryState arch, Some (DiscoveryFunInfo arch))
-> (DiscoveryState arch, Some (DiscoveryFunInfo arch))
forall l r. IncComp l r -> r
incCompResult (DiscoveryOptions
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> FunctionExploreReason (RegAddrWidth (ArchReg arch))
-> DiscoveryState arch
-> [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
     [MemSegmentOff (RegAddrWidth (ArchReg arch))])]
-> IncComp
     (DiscoveryEvent arch)
     (DiscoveryState arch, Some (DiscoveryFunInfo arch))
forall arch.
DiscoveryOptions
-> ArchSegmentOff arch
-> FunctionExploreReason (ArchAddrWidth arch)
-> DiscoveryState arch
-> [(ArchSegmentOff arch, [ArchSegmentOff arch])]
-> IncComp
     (DiscoveryEvent arch)
     (DiscoveryState arch, Some (DiscoveryFunInfo arch))
discoverFunction DiscoveryOptions
defaultDiscoveryOptions MemSegmentOff (RegAddrWidth (ArchReg arch))
addr FunctionExploreReason (RegAddrWidth (ArchReg arch))
rsn DiscoveryState arch
s [])

-- | Analyze addresses that we have marked as functions, but not yet analyzed to
-- identify basic blocks, and discover new function candidates until we have
-- analyzed all function entry points.
--
-- If an exploreFnPred function exists in the DiscoveryState, then do not
-- analyze unexploredFunctions at addresses that do not satisfy this predicate.
analyzeDiscoveredFunctions :: DiscoveryState arch -> DiscoveryState arch
analyzeDiscoveredFunctions :: forall arch. DiscoveryState arch -> DiscoveryState arch
analyzeDiscoveredFunctions DiscoveryState arch
info =
  case Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (FunctionExploreReason (RegAddrWidth (ArchReg arch)))
-> Maybe
     (MemSegmentOff (RegAddrWidth (ArchReg arch)),
      FunctionExploreReason (RegAddrWidth (ArchReg arch)))
forall k a. Map k a -> Maybe (k, a)
Map.lookupMin (DiscoveryState arch
infoDiscoveryState arch
-> Getting
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (FunctionExploreReason (RegAddrWidth (ArchReg arch))))
     (DiscoveryState arch)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (FunctionExploreReason (RegAddrWidth (ArchReg arch))))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (FunctionExploreReason (RegAddrWidth (ArchReg arch)))
forall s a. s -> Getting a s a -> a
^.Getting
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (FunctionExploreReason (RegAddrWidth (ArchReg arch))))
  (DiscoveryState arch)
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (FunctionExploreReason (RegAddrWidth (ArchReg arch))))
forall arch (f :: Type -> Type).
Functor f =>
(UnexploredFunctionMap arch -> f (UnexploredFunctionMap arch))
-> DiscoveryState arch -> f (DiscoveryState arch)
unexploredFunctions) of
    Maybe
  (MemSegmentOff (RegAddrWidth (ArchReg arch)),
   FunctionExploreReason (RegAddrWidth (ArchReg arch)))
Nothing -> DiscoveryState arch
info
    Just (MemSegmentOff (RegAddrWidth (ArchReg arch))
addr, FunctionExploreReason (RegAddrWidth (ArchReg arch))
rsn) ->
      DiscoveryState arch -> DiscoveryState arch
forall arch. DiscoveryState arch -> DiscoveryState arch
analyzeDiscoveredFunctions (DiscoveryState arch -> DiscoveryState arch)
-> DiscoveryState arch -> DiscoveryState arch
forall a b. (a -> b) -> a -> b
$! (DiscoveryState arch, Some (DiscoveryFunInfo arch))
-> DiscoveryState arch
forall a b. (a, b) -> a
fst (MemSegmentOff (RegAddrWidth (ArchReg arch))
-> FunctionExploreReason (RegAddrWidth (ArchReg arch))
-> DiscoveryState arch
-> (DiscoveryState arch, Some (DiscoveryFunInfo arch))
forall arch.
ArchSegmentOff arch
-> FunctionExploreReason (ArchAddrWidth arch)
-> DiscoveryState arch
-> (DiscoveryState arch, Some (DiscoveryFunInfo arch))
analyzeFunction MemSegmentOff (RegAddrWidth (ArchReg arch))
addr FunctionExploreReason (RegAddrWidth (ArchReg arch))
rsn DiscoveryState arch
info)

-- | Extend the analysis of a previously analyzed function with new
-- information about the transfers for a block in that function.  The
-- assumption is that the block in question previously had an unknown
-- transfer state condition, and that the new transfer addresses were
-- discovered by other means (e.g. SMT analysis).  The block in
-- question's terminal statement will be replaced by an ITE (from IP
-- -> new addresses) and the new addresses will be added to the
-- frontier for additional discovery.
addDiscoveredFunctionBlockTargets :: DiscoveryState arch
                                  -> DiscoveryFunInfo arch ids
                                  -- ^ The function for which we have learned additional information
                                  -> [(ArchSegmentOff arch, [ArchSegmentOff arch])]
                                  -> DiscoveryState arch
addDiscoveredFunctionBlockTargets :: forall arch ids.
DiscoveryState arch
-> DiscoveryFunInfo arch ids
-> [(ArchSegmentOff arch, [ArchSegmentOff arch])]
-> DiscoveryState arch
addDiscoveredFunctionBlockTargets DiscoveryState arch
initState DiscoveryFunInfo arch ids
origFunInfo [(ArchSegmentOff arch, [ArchSegmentOff arch])]
resolvedTargets =
  let rsn :: FunctionExploreReason (ArchAddrWidth arch)
rsn = DiscoveryFunInfo arch ids
-> FunctionExploreReason (ArchAddrWidth arch)
forall arch ids.
DiscoveryFunInfo arch ids
-> FunctionExploreReason (ArchAddrWidth arch)
discoveredFunReason DiscoveryFunInfo arch ids
origFunInfo
      funAddr :: ArchSegmentOff arch
funAddr = DiscoveryFunInfo arch ids -> ArchSegmentOff arch
forall arch ids. DiscoveryFunInfo arch ids -> ArchSegmentOff arch
discoveredFunAddr DiscoveryFunInfo arch ids
origFunInfo
  in (DiscoveryState arch, Some (DiscoveryFunInfo arch))
-> DiscoveryState arch
forall a b. (a, b) -> a
fst ((DiscoveryState arch, Some (DiscoveryFunInfo arch))
 -> DiscoveryState arch)
-> (DiscoveryState arch, Some (DiscoveryFunInfo arch))
-> DiscoveryState arch
forall a b. (a -> b) -> a -> b
$ IncComp
  (DiscoveryEvent arch)
  (DiscoveryState arch, Some (DiscoveryFunInfo arch))
-> (DiscoveryState arch, Some (DiscoveryFunInfo arch))
forall l r. IncComp l r -> r
incCompResult (IncComp
   (DiscoveryEvent arch)
   (DiscoveryState arch, Some (DiscoveryFunInfo arch))
 -> (DiscoveryState arch, Some (DiscoveryFunInfo arch)))
-> IncComp
     (DiscoveryEvent arch)
     (DiscoveryState arch, Some (DiscoveryFunInfo arch))
-> (DiscoveryState arch, Some (DiscoveryFunInfo arch))
forall a b. (a -> b) -> a -> b
$ DiscoveryOptions
-> ArchSegmentOff arch
-> FunctionExploreReason (ArchAddrWidth arch)
-> DiscoveryState arch
-> [(ArchSegmentOff arch, [ArchSegmentOff arch])]
-> IncComp
     (DiscoveryEvent arch)
     (DiscoveryState arch, Some (DiscoveryFunInfo arch))
forall arch.
DiscoveryOptions
-> ArchSegmentOff arch
-> FunctionExploreReason (ArchAddrWidth arch)
-> DiscoveryState arch
-> [(ArchSegmentOff arch, [ArchSegmentOff arch])]
-> IncComp
     (DiscoveryEvent arch)
     (DiscoveryState arch, Some (DiscoveryFunInfo arch))
discoverFunction DiscoveryOptions
defaultDiscoveryOptions ArchSegmentOff arch
funAddr FunctionExploreReason (ArchAddrWidth arch)
rsn DiscoveryState arch
initState [(ArchSegmentOff arch, [ArchSegmentOff arch])]
resolvedTargets

exploreMemPointers :: [(ArchSegmentOff arch, ArchSegmentOff arch)]
                   -- ^ List of addresses and value pairs to use for
                   -- considering possible addresses.
                   -> DiscoveryState arch
                   -> DiscoveryState arch
exploreMemPointers :: forall arch.
[(ArchSegmentOff arch, ArchSegmentOff arch)]
-> DiscoveryState arch -> DiscoveryState arch
exploreMemPointers [(ArchSegmentOff arch, ArchSegmentOff arch)]
memWords DiscoveryState arch
info =
  (State (DiscoveryState arch) ()
 -> DiscoveryState arch -> DiscoveryState arch)
-> DiscoveryState arch
-> State (DiscoveryState arch) ()
-> DiscoveryState arch
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (DiscoveryState arch) ()
-> DiscoveryState arch -> DiscoveryState arch
forall s a. State s a -> s -> s
CMS.execState DiscoveryState arch
info (State (DiscoveryState arch) () -> DiscoveryState arch)
-> State (DiscoveryState arch) () -> DiscoveryState arch
forall a b. (a -> b) -> a -> b
$ do
    [(ArchSegmentOff arch, ArchSegmentOff arch)]
-> ((ArchSegmentOff arch, ArchSegmentOff arch)
    -> State (DiscoveryState arch) ())
-> State (DiscoveryState arch) ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ [(ArchSegmentOff arch, ArchSegmentOff arch)]
memWords (((ArchSegmentOff arch, ArchSegmentOff arch)
  -> State (DiscoveryState arch) ())
 -> State (DiscoveryState arch) ())
-> ((ArchSegmentOff arch, ArchSegmentOff arch)
    -> State (DiscoveryState arch) ())
-> State (DiscoveryState arch) ()
forall a b. (a -> b) -> a -> b
$ \(ArchSegmentOff arch
src, ArchSegmentOff arch
val) -> do
      DiscoveryState arch
s <- StateT (DiscoveryState arch) Identity (DiscoveryState arch)
forall s (m :: Type -> Type). MonadState s m => m s
CMS.get
      let addFun :: Bool
addFun = MemSegment (RegAddrWidth (ArchReg arch)) -> Flags
forall (w :: Natural). MemSegment w -> Flags
segmentFlags (ArchSegmentOff arch -> MemSegment (RegAddrWidth (ArchReg arch))
forall (w :: Natural). MemSegmentOff w -> MemSegment w
segoffSegment ArchSegmentOff arch
src) Flags -> Flags -> Bool
`Perm.hasPerm` Flags
Perm.write
                Bool -> Bool -> Bool
&& ArchSegmentOff arch -> DiscoveryState arch -> Bool
forall arch. ArchSegmentOff arch -> DiscoveryState arch -> Bool
shouldExploreFunction ArchSegmentOff arch
val DiscoveryState arch
s
      Bool
-> State (DiscoveryState arch) () -> State (DiscoveryState arch) ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when Bool
addFun (State (DiscoveryState arch) () -> State (DiscoveryState arch) ())
-> State (DiscoveryState arch) () -> State (DiscoveryState arch) ()
forall a b. (a -> b) -> a -> b
$ do
        DiscoveryState arch -> State (DiscoveryState arch) ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
CMS.put (DiscoveryState arch -> State (DiscoveryState arch) ())
-> DiscoveryState arch -> State (DiscoveryState arch) ()
forall a b. (a -> b) -> a -> b
$ FunctionExploreReason (RegAddrWidth (ArchReg arch))
-> ArchSegmentOff arch
-> DiscoveryState arch
-> DiscoveryState arch
forall arch.
FunctionExploreReason (ArchAddrWidth arch)
-> ArchSegmentOff arch
-> DiscoveryState arch
-> DiscoveryState arch
markAddrAsFunction (ArchSegmentOff arch
-> FunctionExploreReason (RegAddrWidth (ArchReg arch))
forall (w :: Natural). MemSegmentOff w -> FunctionExploreReason w
CodePointerInMem ArchSegmentOff arch
src) ArchSegmentOff arch
val DiscoveryState arch
s

-- | Expand an initial discovery state by exploring from a given set of function
-- entry points.
cfgFromAddrsAndState :: forall arch
                     .  DiscoveryState arch
                     -> [ArchSegmentOff arch]
                     -- ^ Initial function entry points.
                     -> [(ArchSegmentOff arch, ArchSegmentOff arch)]
                     -- ^ Function entry points in memory to be explored
                     -- after exploring function entry points.
                     --
                     -- Each entry contains an address and the value stored in it.
                     -> DiscoveryState arch
cfgFromAddrsAndState :: forall arch.
DiscoveryState arch
-> [ArchSegmentOff arch]
-> [(ArchSegmentOff arch, ArchSegmentOff arch)]
-> DiscoveryState arch
cfgFromAddrsAndState DiscoveryState arch
initial_state [ArchSegmentOff arch]
init_addrs [(ArchSegmentOff arch, ArchSegmentOff arch)]
mem_words =
  DiscoveryState arch
initial_state
    DiscoveryState arch
-> (DiscoveryState arch -> DiscoveryState arch)
-> DiscoveryState arch
forall a b. a -> (a -> b) -> b
& FunctionExploreReason (ArchAddrWidth arch)
-> [ArchSegmentOff arch]
-> DiscoveryState arch
-> DiscoveryState arch
forall (t :: Type -> Type) arch.
Foldable t =>
FunctionExploreReason (ArchAddrWidth arch)
-> t (ArchSegmentOff arch)
-> DiscoveryState arch
-> DiscoveryState arch
markAddrsAsFunction FunctionExploreReason (ArchAddrWidth arch)
forall (w :: Natural). FunctionExploreReason w
InitAddr [ArchSegmentOff arch]
init_addrs
    DiscoveryState arch
-> (DiscoveryState arch -> DiscoveryState arch)
-> DiscoveryState arch
forall a b. a -> (a -> b) -> b
& DiscoveryState arch -> DiscoveryState arch
forall arch. DiscoveryState arch -> DiscoveryState arch
analyzeDiscoveredFunctions
    DiscoveryState arch
-> (DiscoveryState arch -> DiscoveryState arch)
-> DiscoveryState arch
forall a b. a -> (a -> b) -> b
& [(ArchSegmentOff arch, ArchSegmentOff arch)]
-> DiscoveryState arch -> DiscoveryState arch
forall arch.
[(ArchSegmentOff arch, ArchSegmentOff arch)]
-> DiscoveryState arch -> DiscoveryState arch
exploreMemPointers [(ArchSegmentOff arch, ArchSegmentOff arch)]
mem_words
    DiscoveryState arch
-> (DiscoveryState arch -> DiscoveryState arch)
-> DiscoveryState arch
forall a b. a -> (a -> b) -> b
& DiscoveryState arch -> DiscoveryState arch
forall arch. DiscoveryState arch -> DiscoveryState arch
analyzeDiscoveredFunctions

-- | Construct an empty discovery state and populate it by exploring from a
-- given set of function entry points
cfgFromAddrs ::
     forall arch
  .  ArchitectureInfo arch
     -- ^ Architecture-specific information needed for doing control-flow exploration.
  -> Memory (ArchAddrWidth arch)
     -- ^ Memory to use when decoding instructions.
  -> AddrSymMap (ArchAddrWidth arch)
     -- ^ Map from addresses to the associated symbol name.
  -> [ArchSegmentOff arch]
     -- ^ Initial function entry points.
     -> [(ArchSegmentOff arch, ArchSegmentOff arch)]
     -- ^ Function entry points in memory to be explored
     -- after exploring function entry points.
     --
     -- Each entry contains an address and the value stored in it.
  -> DiscoveryState arch
cfgFromAddrs :: forall arch.
ArchitectureInfo arch
-> Memory (ArchAddrWidth arch)
-> AddrSymMap (ArchAddrWidth arch)
-> [ArchSegmentOff arch]
-> [(ArchSegmentOff arch, ArchSegmentOff arch)]
-> DiscoveryState arch
cfgFromAddrs ArchitectureInfo arch
ainfo Memory (ArchAddrWidth arch)
mem AddrSymMap (ArchAddrWidth arch)
addrSymMap =
  DiscoveryState arch
-> [MemSegmentOff (ArchAddrWidth arch)]
-> [(MemSegmentOff (ArchAddrWidth arch),
     MemSegmentOff (ArchAddrWidth arch))]
-> DiscoveryState arch
forall arch.
DiscoveryState arch
-> [ArchSegmentOff arch]
-> [(ArchSegmentOff arch, ArchSegmentOff arch)]
-> DiscoveryState arch
cfgFromAddrsAndState (Memory (ArchAddrWidth arch)
-> AddrSymMap (ArchAddrWidth arch)
-> ArchitectureInfo arch
-> DiscoveryState arch
forall arch.
Memory (ArchAddrWidth arch)
-> AddrSymMap (ArchAddrWidth arch)
-> ArchitectureInfo arch
-> DiscoveryState arch
emptyDiscoveryState Memory (ArchAddrWidth arch)
mem AddrSymMap (ArchAddrWidth arch)
addrSymMap ArchitectureInfo arch
ainfo)

------------------------------------------------------------------------
-- DiscoveryOptions

-- | Options controlling 'completeDiscoveryState'.
data DiscoveryOptions
   = DiscoveryOptions { DiscoveryOptions -> Bool
exploreFunctionSymbols :: !Bool
                        -- ^ If @True@, 'completeDiscoveryState'
                        -- should automatically explore all addresses
                        -- in the address-to-symbol map.
                      , DiscoveryOptions -> Bool
exploreCodeAddrInMem :: !Bool
                        -- ^ If @True@, 'completeDiscoveryState' will
                        -- explore all potential code addresses in
                        -- memory after exploring other potential
                        -- functions.
                        --
                        -- This is effectively a hack that sometimes
                        -- allows discovering functions.  If you need
                        -- it, let the author's of Macaw know so that
                        -- we can find a more principled way.
                      , DiscoveryOptions -> Bool
logAtAnalyzeFunction  :: !Bool
                        -- ^ Print a message each time we apply
                        -- discovery analysis to a new function.
                      , DiscoveryOptions -> Bool
logAtAnalyzeBlock     :: !Bool
                        -- ^ Print a message each time we analyze a
                        -- block within a function.
                      }

-- | Some default options
defaultDiscoveryOptions :: DiscoveryOptions
defaultDiscoveryOptions :: DiscoveryOptions
defaultDiscoveryOptions =
  DiscoveryOptions { exploreFunctionSymbols :: Bool
exploreFunctionSymbols = Bool
True
                   , exploreCodeAddrInMem :: Bool
exploreCodeAddrInMem   = Bool
False
                   , logAtAnalyzeFunction :: Bool
logAtAnalyzeFunction   = Bool
True
                   , logAtAnalyzeBlock :: Bool
logAtAnalyzeBlock      = Bool
False
                   }

------------------------------------------------------------------------
-- Resolve functions with logging

-- | Events reported by discovery process.
data DiscoveryEvent arch
     -- | Report that discovery has now started analyzing the function at the given offset.
   = ReportAnalyzeFunction !(ArchSegmentOff arch)
     -- | @ReoptAnalyzeFunctionDone f@ we completed discovery and yielded function @f@.
   | forall ids . ReportAnalyzeFunctionDone (DiscoveryFunInfo arch ids)
     -- | @ReportIdentifyFunction src tgt rsn@ indicates Macaw identified a
     -- candidate funciton entry point @tgt@ from analyzing @src@ for the
     -- given reason @rsn@.
   | ReportIdentifyFunction
        !(ArchSegmentOff arch)
        !(ArchSegmentOff arch)
        !(FunctionExploreReason (ArchAddrWidth arch))
      -- | @ReportAnalyzeBlock faddr baddr reason@ indicates discovery
      -- identified a block at @baddr@ in @faddr@.  @reason@ is the reason why
      -- this block is explored (or sometimes re-explored).
      --
      -- N.B. This event is only emitted when `logAtAnalyzeBlock` is true.
   | ReportAnalyzeBlock
      !(ArchSegmentOff arch)
      !(ArchSegmentOff arch)
      !(Maybe (BlockExploreReason (ArchAddrWidth arch)))

ppSymbol :: MemWidth w => Maybe BSC.ByteString -> MemSegmentOff w -> String
ppSymbol :: forall (w :: Natural).
MemWidth w =>
Maybe ByteString -> MemSegmentOff w -> String
ppSymbol (Just ByteString
fnName) MemSegmentOff w
addr = MemSegmentOff w -> String
forall a. Show a => a -> String
show MemSegmentOff w
addr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
BSC.unpack ByteString
fnName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
ppSymbol Maybe ByteString
Nothing MemSegmentOff w
addr = MemSegmentOff w -> String
forall a. Show a => a -> String
show MemSegmentOff w
addr

logDiscoveryEvent :: MemWidth (ArchAddrWidth arch)
                  => AddrSymMap (ArchAddrWidth arch)
                  -> DiscoveryEvent arch
                  -> IO ()
logDiscoveryEvent :: forall arch.
MemWidth (ArchAddrWidth arch) =>
AddrSymMap (ArchAddrWidth arch) -> DiscoveryEvent arch -> IO ()
logDiscoveryEvent AddrSymMap (ArchAddrWidth arch)
symMap DiscoveryEvent arch
p =
  case DiscoveryEvent arch
p of
    ReportAnalyzeFunction MemSegmentOff (ArchAddrWidth arch)
addr -> do
      Handle -> String -> IO ()
IO.hPutStrLn Handle
IO.stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Analyzing function: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe ByteString -> MemSegmentOff (ArchAddrWidth arch) -> String
forall (w :: Natural).
MemWidth w =>
Maybe ByteString -> MemSegmentOff w -> String
ppSymbol (MemSegmentOff (ArchAddrWidth arch)
-> AddrSymMap (ArchAddrWidth arch) -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup MemSegmentOff (ArchAddrWidth arch)
addr AddrSymMap (ArchAddrWidth arch)
symMap) MemSegmentOff (ArchAddrWidth arch)
addr
      Handle -> IO ()
IO.hFlush Handle
IO.stderr
    ReportAnalyzeFunctionDone DiscoveryFunInfo arch ids
_ -> do
      () -> IO ()
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
    ReportIdentifyFunction MemSegmentOff (ArchAddrWidth arch)
_ MemSegmentOff (ArchAddrWidth arch)
tgt FunctionExploreReason (ArchAddrWidth arch)
rsn -> do
      Handle -> String -> IO ()
IO.hPutStrLn Handle
IO.stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  Identified candidate entry point "
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe ByteString -> MemSegmentOff (ArchAddrWidth arch) -> String
forall (w :: Natural).
MemWidth w =>
Maybe ByteString -> MemSegmentOff w -> String
ppSymbol (MemSegmentOff (ArchAddrWidth arch)
-> AddrSymMap (ArchAddrWidth arch) -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup MemSegmentOff (ArchAddrWidth arch)
tgt AddrSymMap (ArchAddrWidth arch)
symMap) MemSegmentOff (ArchAddrWidth arch)
tgt
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FunctionExploreReason (ArchAddrWidth arch) -> String
forall (w :: Natural). FunctionExploreReason w -> String
ppFunReason FunctionExploreReason (ArchAddrWidth arch)
rsn
      Handle -> IO ()
IO.hFlush Handle
IO.stderr
    ReportAnalyzeBlock MemSegmentOff (ArchAddrWidth arch)
_ MemSegmentOff (ArchAddrWidth arch)
baddr Maybe (BlockExploreReason (ArchAddrWidth arch))
_ -> do
      Handle -> String -> IO ()
IO.hPutStrLn Handle
IO.stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  Analyzing block: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MemSegmentOff (ArchAddrWidth arch) -> String
forall a. Show a => a -> String
show MemSegmentOff (ArchAddrWidth arch)
baddr
      Handle -> IO ()
IO.hFlush Handle
IO.stderr

resolveFuns :: DiscoveryOptions
               -- ^ Options controlling discovery
            -> DiscoveryState arch
            -> IncCompM (DiscoveryEvent arch) r (DiscoveryState arch)
resolveFuns :: forall arch r.
DiscoveryOptions
-> DiscoveryState arch
-> IncCompM (DiscoveryEvent arch) r (DiscoveryState arch)
resolveFuns DiscoveryOptions
disOpts DiscoveryState arch
info = DiscoveryState arch
-> IncCompM (DiscoveryEvent arch) r (DiscoveryState arch)
-> IncCompM (DiscoveryEvent arch) r (DiscoveryState arch)
forall a b. a -> b -> b
seq DiscoveryState arch
info (IncCompM (DiscoveryEvent arch) r (DiscoveryState arch)
 -> IncCompM (DiscoveryEvent arch) r (DiscoveryState arch))
-> IncCompM (DiscoveryEvent arch) r (DiscoveryState arch)
-> IncCompM (DiscoveryEvent arch) r (DiscoveryState arch)
forall a b. (a -> b) -> a -> b
$ ArchitectureInfo arch -> forall a. (ArchConstraints arch => a) -> a
forall arch.
ArchitectureInfo arch -> forall a. (ArchConstraints arch => a) -> a
withArchConstraints (DiscoveryState arch -> ArchitectureInfo arch
forall arch. DiscoveryState arch -> ArchitectureInfo arch
archInfo DiscoveryState arch
info) ((ArchConstraints arch =>
  IncCompM (DiscoveryEvent arch) r (DiscoveryState arch))
 -> IncCompM (DiscoveryEvent arch) r (DiscoveryState arch))
-> (ArchConstraints arch =>
    IncCompM (DiscoveryEvent arch) r (DiscoveryState arch))
-> IncCompM (DiscoveryEvent arch) r (DiscoveryState arch)
forall a b. (a -> b) -> a -> b
$ do
  case Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (FunctionExploreReason (RegAddrWidth (ArchReg arch)))
-> Maybe
     ((MemSegmentOff (RegAddrWidth (ArchReg arch)),
       FunctionExploreReason (RegAddrWidth (ArchReg arch))),
      Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (FunctionExploreReason (RegAddrWidth (ArchReg arch))))
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.minViewWithKey (DiscoveryState arch
infoDiscoveryState arch
-> Getting
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (FunctionExploreReason (RegAddrWidth (ArchReg arch))))
     (DiscoveryState arch)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (FunctionExploreReason (RegAddrWidth (ArchReg arch))))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (FunctionExploreReason (RegAddrWidth (ArchReg arch)))
forall s a. s -> Getting a s a -> a
^.Getting
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (FunctionExploreReason (RegAddrWidth (ArchReg arch))))
  (DiscoveryState arch)
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (FunctionExploreReason (RegAddrWidth (ArchReg arch))))
forall arch (f :: Type -> Type).
Functor f =>
(UnexploredFunctionMap arch -> f (UnexploredFunctionMap arch))
-> DiscoveryState arch -> f (DiscoveryState arch)
unexploredFunctions) of
    Maybe
  ((MemSegmentOff (RegAddrWidth (ArchReg arch)),
    FunctionExploreReason (RegAddrWidth (ArchReg arch))),
   Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (FunctionExploreReason (RegAddrWidth (ArchReg arch))))
Nothing -> DiscoveryState arch
-> IncCompM (DiscoveryEvent arch) r (DiscoveryState arch)
forall a. a -> IncCompM (DiscoveryEvent arch) r a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure DiscoveryState arch
info
    Just ((MemSegmentOff (RegAddrWidth (ArchReg arch))
addr, FunctionExploreReason (RegAddrWidth (ArchReg arch))
rsn), Map
  (MemSegmentOff (RegAddrWidth (ArchReg arch)))
  (FunctionExploreReason (RegAddrWidth (ArchReg arch)))
_) -> do
      Bool
-> IncCompM (DiscoveryEvent arch) r ()
-> IncCompM (DiscoveryEvent arch) r ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (DiscoveryOptions -> Bool
logAtAnalyzeFunction DiscoveryOptions
disOpts) (IncCompM (DiscoveryEvent arch) r ()
 -> IncCompM (DiscoveryEvent arch) r ())
-> IncCompM (DiscoveryEvent arch) r ()
-> IncCompM (DiscoveryEvent arch) r ()
forall a b. (a -> b) -> a -> b
$ do
        DiscoveryEvent arch -> IncCompM (DiscoveryEvent arch) r ()
forall l r. l -> IncCompM l r ()
incCompLog (MemSegmentOff (RegAddrWidth (ArchReg arch)) -> DiscoveryEvent arch
forall arch. ArchSegmentOff arch -> DiscoveryEvent arch
ReportAnalyzeFunction MemSegmentOff (RegAddrWidth (ArchReg arch))
addr)
      if MemSegmentOff (RegAddrWidth (ArchReg arch))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (Some (DiscoveryFunInfo arch))
-> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member MemSegmentOff (RegAddrWidth (ArchReg arch))
addr (DiscoveryState arch
infoDiscoveryState arch
-> Getting
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (Some (DiscoveryFunInfo arch)))
     (DiscoveryState arch)
     (Map
        (MemSegmentOff (RegAddrWidth (ArchReg arch)))
        (Some (DiscoveryFunInfo arch)))
-> Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (Some (DiscoveryFunInfo arch))
forall s a. s -> Getting a s a -> a
^.Getting
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (Some (DiscoveryFunInfo arch)))
  (DiscoveryState arch)
  (Map
     (MemSegmentOff (RegAddrWidth (ArchReg arch)))
     (Some (DiscoveryFunInfo arch)))
forall arch (f :: Type -> Type).
Functor f =>
(Map (ArchSegmentOff arch) (Some (DiscoveryFunInfo arch))
 -> f (Map (ArchSegmentOff arch) (Some (DiscoveryFunInfo arch))))
-> DiscoveryState arch -> f (DiscoveryState arch)
funInfo) then
        DiscoveryOptions
-> DiscoveryState arch
-> IncCompM (DiscoveryEvent arch) r (DiscoveryState arch)
forall arch r.
DiscoveryOptions
-> DiscoveryState arch
-> IncCompM (DiscoveryEvent arch) r (DiscoveryState arch)
resolveFuns DiscoveryOptions
disOpts DiscoveryState arch
info
       else do
        (DiscoveryState arch
info', Some DiscoveryFunInfo arch x
f) <- (DiscoveryEvent arch -> DiscoveryEvent arch)
-> IncComp
     (DiscoveryEvent arch)
     (DiscoveryState arch, Some (DiscoveryFunInfo arch))
-> IncCompM
     (DiscoveryEvent arch)
     r
     (DiscoveryState arch, Some (DiscoveryFunInfo arch))
forall l k a r. (l -> k) -> IncComp l a -> IncCompM k r a
liftIncComp DiscoveryEvent arch -> DiscoveryEvent arch
forall a. a -> a
id (IncComp
   (DiscoveryEvent arch)
   (DiscoveryState arch, Some (DiscoveryFunInfo arch))
 -> IncCompM
      (DiscoveryEvent arch)
      r
      (DiscoveryState arch, Some (DiscoveryFunInfo arch)))
-> IncComp
     (DiscoveryEvent arch)
     (DiscoveryState arch, Some (DiscoveryFunInfo arch))
-> IncCompM
     (DiscoveryEvent arch)
     r
     (DiscoveryState arch, Some (DiscoveryFunInfo arch))
forall a b. (a -> b) -> a -> b
$ DiscoveryOptions
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> FunctionExploreReason (RegAddrWidth (ArchReg arch))
-> DiscoveryState arch
-> [(MemSegmentOff (RegAddrWidth (ArchReg arch)),
     [MemSegmentOff (RegAddrWidth (ArchReg arch))])]
-> IncComp
     (DiscoveryEvent arch)
     (DiscoveryState arch, Some (DiscoveryFunInfo arch))
forall arch.
DiscoveryOptions
-> ArchSegmentOff arch
-> FunctionExploreReason (ArchAddrWidth arch)
-> DiscoveryState arch
-> [(ArchSegmentOff arch, [ArchSegmentOff arch])]
-> IncComp
     (DiscoveryEvent arch)
     (DiscoveryState arch, Some (DiscoveryFunInfo arch))
discoverFunction DiscoveryOptions
disOpts MemSegmentOff (RegAddrWidth (ArchReg arch))
addr FunctionExploreReason (RegAddrWidth (ArchReg arch))
rsn DiscoveryState arch
info []
        DiscoveryEvent arch -> IncCompM (DiscoveryEvent arch) r ()
forall l r. l -> IncCompM l r ()
incCompLog (DiscoveryEvent arch -> IncCompM (DiscoveryEvent arch) r ())
-> DiscoveryEvent arch -> IncCompM (DiscoveryEvent arch) r ()
forall a b. (a -> b) -> a -> b
$ DiscoveryFunInfo arch x -> DiscoveryEvent arch
forall arch ids. DiscoveryFunInfo arch ids -> DiscoveryEvent arch
ReportAnalyzeFunctionDone DiscoveryFunInfo arch x
f
        DiscoveryOptions
-> DiscoveryState arch
-> IncCompM (DiscoveryEvent arch) r (DiscoveryState arch)
forall arch r.
DiscoveryOptions
-> DiscoveryState arch
-> IncCompM (DiscoveryEvent arch) r (DiscoveryState arch)
resolveFuns DiscoveryOptions
disOpts DiscoveryState arch
info'

------------------------------------------------------------------------
-- Top-level discovery

-- | Explore until we have found all functions we can.
--
-- This function is a version of completeDiscoveryState that uses the
-- new incremental computation monad rather than IO.
incCompleteDiscovery :: forall arch r
                     .  DiscoveryState arch
                     -> DiscoveryOptions
                        -- ^ Options controlling discovery
                     -> IncCompM (DiscoveryEvent arch) r (DiscoveryState arch)
incCompleteDiscovery :: forall arch r.
DiscoveryState arch
-> DiscoveryOptions
-> IncCompM (DiscoveryEvent arch) r (DiscoveryState arch)
incCompleteDiscovery DiscoveryState arch
initState DiscoveryOptions
disOpt = do
 let ainfo :: ArchitectureInfo arch
ainfo = DiscoveryState arch -> ArchitectureInfo arch
forall arch. DiscoveryState arch -> ArchitectureInfo arch
archInfo DiscoveryState arch
initState
 let mem :: Memory (ArchAddrWidth arch)
mem = DiscoveryState arch -> Memory (ArchAddrWidth arch)
forall arch. DiscoveryState arch -> Memory (ArchAddrWidth arch)
memory DiscoveryState arch
initState
 let symMap :: AddrSymMap (ArchAddrWidth arch)
symMap = DiscoveryState arch -> AddrSymMap (ArchAddrWidth arch)
forall arch. DiscoveryState arch -> AddrSymMap (ArchAddrWidth arch)
symbolNames DiscoveryState arch
initState
 ArchitectureInfo arch -> forall a. (ArchConstraints arch => a) -> a
forall arch.
ArchitectureInfo arch -> forall a. (ArchConstraints arch => a) -> a
withArchConstraints ArchitectureInfo arch
ainfo ((ArchConstraints arch =>
  IncCompM (DiscoveryEvent arch) r (DiscoveryState arch))
 -> IncCompM (DiscoveryEvent arch) r (DiscoveryState arch))
-> (ArchConstraints arch =>
    IncCompM (DiscoveryEvent arch) r (DiscoveryState arch))
-> IncCompM (DiscoveryEvent arch) r (DiscoveryState arch)
forall a b. (a -> b) -> a -> b
$ do
  -- Add symbol table entries to discovery state if requested
  let postSymState :: DiscoveryState arch
postSymState
        | DiscoveryOptions -> Bool
exploreFunctionSymbols DiscoveryOptions
disOpt =
            DiscoveryState arch
initState DiscoveryState arch
-> (DiscoveryState arch -> DiscoveryState arch)
-> DiscoveryState arch
forall a b. a -> (a -> b) -> b
& FunctionExploreReason (ArchAddrWidth arch)
-> [ArchSegmentOff arch]
-> DiscoveryState arch
-> DiscoveryState arch
forall (t :: Type -> Type) arch.
Foldable t =>
FunctionExploreReason (ArchAddrWidth arch)
-> t (ArchSegmentOff arch)
-> DiscoveryState arch
-> DiscoveryState arch
markAddrsAsFunction FunctionExploreReason (ArchAddrWidth arch)
forall (w :: Natural). FunctionExploreReason w
InitAddr (AddrSymMap (ArchAddrWidth arch) -> [ArchSegmentOff arch]
forall k a. Map k a -> [k]
Map.keys AddrSymMap (ArchAddrWidth arch)
symMap)
        | Bool
otherwise = DiscoveryState arch
initState
  -- Discover functions
  DiscoveryState arch
postPhase1Discovery <- DiscoveryOptions
-> DiscoveryState arch
-> IncCompM (DiscoveryEvent arch) r (DiscoveryState arch)
forall arch r.
DiscoveryOptions
-> DiscoveryState arch
-> IncCompM (DiscoveryEvent arch) r (DiscoveryState arch)
resolveFuns DiscoveryOptions
disOpt DiscoveryState arch
postSymState
  -- Discovery functions from memory
  if DiscoveryOptions -> Bool
exploreCodeAddrInMem DiscoveryOptions
disOpt then do
    -- Execute hack of just searching for pointers in memory.
    let memContents :: [(ArchSegmentOff arch, ArchSegmentOff arch)]
memContents = ArchitectureInfo arch -> forall a. (ArchConstraints arch => a) -> a
forall arch.
ArchitectureInfo arch -> forall a. (ArchConstraints arch => a) -> a
withArchConstraints ArchitectureInfo arch
ainfo ((ArchConstraints arch =>
  [(ArchSegmentOff arch, ArchSegmentOff arch)])
 -> [(ArchSegmentOff arch, ArchSegmentOff arch)])
-> (ArchConstraints arch =>
    [(ArchSegmentOff arch, ArchSegmentOff arch)])
-> [(ArchSegmentOff arch, ArchSegmentOff arch)]
forall a b. (a -> b) -> a -> b
$ Memory (ArchAddrWidth arch)
-> Endianness -> [(ArchSegmentOff arch, ArchSegmentOff arch)]
forall (w :: Natural).
Memory w -> Endianness -> [(MemSegmentOff w, MemSegmentOff w)]
memAsAddrPairs Memory (ArchAddrWidth arch)
mem Endianness
LittleEndian
    DiscoveryOptions
-> DiscoveryState arch
-> IncCompM (DiscoveryEvent arch) r (DiscoveryState arch)
forall arch r.
DiscoveryOptions
-> DiscoveryState arch
-> IncCompM (DiscoveryEvent arch) r (DiscoveryState arch)
resolveFuns DiscoveryOptions
disOpt (DiscoveryState arch
 -> IncCompM (DiscoveryEvent arch) r (DiscoveryState arch))
-> DiscoveryState arch
-> IncCompM (DiscoveryEvent arch) r (DiscoveryState arch)
forall a b. (a -> b) -> a -> b
$ DiscoveryState arch
postPhase1Discovery DiscoveryState arch
-> (DiscoveryState arch -> DiscoveryState arch)
-> DiscoveryState arch
forall a b. a -> (a -> b) -> b
& [(ArchSegmentOff arch, ArchSegmentOff arch)]
-> DiscoveryState arch -> DiscoveryState arch
forall arch.
[(ArchSegmentOff arch, ArchSegmentOff arch)]
-> DiscoveryState arch -> DiscoveryState arch
exploreMemPointers [(ArchSegmentOff arch, ArchSegmentOff arch)]
memContents
   else
    DiscoveryState arch
-> IncCompM (DiscoveryEvent arch) r (DiscoveryState arch)
forall a. a -> IncCompM (DiscoveryEvent arch) r a
forall (m :: Type -> Type) a. Monad m => a -> m a
return DiscoveryState arch
postPhase1Discovery

-- | Explore until we have found all functions we can.
--
-- This function is intended to make it easy to explore functions, and
-- can be controlled via 'DiscoveryOptions'.
completeDiscoveryState :: forall arch
                       .  DiscoveryState arch
                       -> DiscoveryOptions
                          -- ^ Options controlling discovery
                       -> IO (DiscoveryState arch)
completeDiscoveryState :: forall arch.
DiscoveryState arch -> DiscoveryOptions -> IO (DiscoveryState arch)
completeDiscoveryState DiscoveryState arch
initState DiscoveryOptions
disOpt = do
  let ainfo :: ArchitectureInfo arch
ainfo = DiscoveryState arch -> ArchitectureInfo arch
forall arch. DiscoveryState arch -> ArchitectureInfo arch
archInfo DiscoveryState arch
initState
  let symMap :: AddrSymMap (ArchAddrWidth arch)
symMap = DiscoveryState arch -> AddrSymMap (ArchAddrWidth arch)
forall arch. DiscoveryState arch -> AddrSymMap (ArchAddrWidth arch)
symbolNames DiscoveryState arch
initState
  ArchitectureInfo arch -> forall a. (ArchConstraints arch => a) -> a
forall arch.
ArchitectureInfo arch -> forall a. (ArchConstraints arch => a) -> a
withArchConstraints ArchitectureInfo arch
ainfo ((ArchConstraints arch => IO (DiscoveryState arch))
 -> IO (DiscoveryState arch))
-> (ArchConstraints arch => IO (DiscoveryState arch))
-> IO (DiscoveryState arch)
forall a b. (a -> b) -> a -> b
$
    (DiscoveryEvent arch -> IO ())
-> IncComp (DiscoveryEvent arch) (DiscoveryState arch)
-> IO (DiscoveryState arch)
forall (m :: Type -> Type) l r.
Monad m =>
(l -> m ()) -> IncComp l r -> m r
processIncCompLogs (AddrSymMap (ArchAddrWidth arch) -> DiscoveryEvent arch -> IO ()
forall arch.
MemWidth (ArchAddrWidth arch) =>
AddrSymMap (ArchAddrWidth arch) -> DiscoveryEvent arch -> IO ()
logDiscoveryEvent AddrSymMap (ArchAddrWidth arch)
symMap) (IncComp (DiscoveryEvent arch) (DiscoveryState arch)
 -> IO (DiscoveryState arch))
-> IncComp (DiscoveryEvent arch) (DiscoveryState arch)
-> IO (DiscoveryState arch)
forall a b. (a -> b) -> a -> b
$ IncCompM
  (DiscoveryEvent arch) (DiscoveryState arch) (DiscoveryState arch)
-> IncComp (DiscoveryEvent arch) (DiscoveryState arch)
forall l r. IncCompM l r r -> IncComp l r
runIncCompM (IncCompM
   (DiscoveryEvent arch) (DiscoveryState arch) (DiscoveryState arch)
 -> IncComp (DiscoveryEvent arch) (DiscoveryState arch))
-> IncCompM
     (DiscoveryEvent arch) (DiscoveryState arch) (DiscoveryState arch)
-> IncComp (DiscoveryEvent arch) (DiscoveryState arch)
forall a b. (a -> b) -> a -> b
$
      DiscoveryState arch
-> DiscoveryOptions
-> IncCompM
     (DiscoveryEvent arch) (DiscoveryState arch) (DiscoveryState arch)
forall arch r.
DiscoveryState arch
-> DiscoveryOptions
-> IncCompM (DiscoveryEvent arch) r (DiscoveryState arch)
incCompleteDiscovery DiscoveryState arch
initState DiscoveryOptions
disOpt