{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
-- | Definitions supporting block classification during code discovery
--
-- This module defines data types and helpers to build block control flow
-- classifiers.  It comes with a pre-defined set that work well for most
-- architectures.  A reasonable default classifier is provided for all supported
-- architectures.  This infrastructure is available to enable derived tools to
-- customize code discovery heuristics, and to enable architectures to provide
-- architecture-specific rules.
--
-- Note that this is necessary for generating architecture-specific block
-- terminators that can only be correctly injected based on analysis of values
-- after abstract interpretation is applied to the rest of the code.
module Data.Macaw.Discovery.Classifier (
  -- * Utilities
    isExecutableSegOff
  , identifyConcreteAddresses
  -- * Pre-defined classifiers
  , branchClassifier
  , callClassifier
  , returnClassifier
  , directJumpClassifier
  , noreturnCallClassifier
  , tailCallClassifier
  -- * Reusable helpers
  , branchBlockState
  , classifierEndBlock
  ) where

import           Control.Applicative ( Alternative(empty) )
import           Control.Lens ( (^.), (&), (.~) )
import           Control.Monad ( when, unless )
import qualified Control.Monad.Reader as CMR
import qualified Data.Foldable as F
import qualified Data.Map.Strict as Map
import           Data.Maybe ( maybeToList )
import qualified Data.Set as Set
import           Text.Printf (printf)

import           Data.Macaw.AbsDomain.AbsState
import qualified Data.Macaw.AbsDomain.JumpBounds as Jmp
import qualified Data.Macaw.AbsDomain.Refine as Refine
import           Data.Macaw.Architecture.Info as Info
import           Data.Macaw.CFG
import qualified Data.Macaw.Discovery.AbsEval as AbsEval
import qualified Data.Macaw.Discovery.ParsedContents as Parsed
import qualified Data.Macaw.Memory.Permissions as Perm
import           Data.Macaw.Types

------------------------------------------------------------------------
-- Utilities

isExecutableSegOff :: MemSegmentOff w -> Bool
isExecutableSegOff :: forall (w :: Nat). MemSegmentOff w -> Bool
isExecutableSegOff MemSegmentOff w
sa =
  MemSegment w -> Flags
forall (w :: Nat). MemSegment w -> Flags
segmentFlags (MemSegmentOff w -> MemSegment w
forall (w :: Nat). MemSegmentOff w -> MemSegment w
segoffSegment MemSegmentOff w
sa) Flags -> Flags -> Bool
`Perm.hasPerm` Flags
Perm.execute

-- | Get code pointers out of a abstract value.
identifyConcreteAddresses :: MemWidth w
                          => Memory w
                          -> AbsValue w (BVType w)
                          -> [MemSegmentOff w]
identifyConcreteAddresses :: forall (w :: Nat).
MemWidth w =>
Memory w -> AbsValue w (BVType w) -> [MemSegmentOff w]
identifyConcreteAddresses Memory w
mem (FinSet Set Integer
s) =
  let ins :: Integer -> [MemSegmentOff w] -> [MemSegmentOff w]
ins Integer
o [MemSegmentOff w]
r =
        case Memory w -> MemWord w -> Maybe (MemSegmentOff w)
forall (w :: Nat). Memory w -> MemWord w -> Maybe (MemSegmentOff w)
resolveAbsoluteAddr Memory w
mem (Integer -> MemWord w
forall a. Num a => Integer -> a
fromInteger Integer
o) of
          Just MemSegmentOff w
a | MemSegmentOff w -> Bool
forall (w :: Nat). MemSegmentOff w -> Bool
isExecutableSegOff MemSegmentOff w
a -> MemSegmentOff w
a MemSegmentOff w -> [MemSegmentOff w] -> [MemSegmentOff w]
forall a. a -> [a] -> [a]
: [MemSegmentOff w]
r
          Maybe (MemSegmentOff w)
_ -> [MemSegmentOff w]
r
   in (Integer -> [MemSegmentOff w] -> [MemSegmentOff w])
-> [MemSegmentOff w] -> Set Integer -> [MemSegmentOff w]
forall a b. (a -> b -> b) -> b -> Set a -> b
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Integer -> [MemSegmentOff w] -> [MemSegmentOff w]
ins [] Set Integer
s
identifyConcreteAddresses Memory w
_ (CodePointers Set (MemSegmentOff w)
s Bool
_) = (MemSegmentOff w -> Bool) -> [MemSegmentOff w] -> [MemSegmentOff w]
forall a. (a -> Bool) -> [a] -> [a]
filter MemSegmentOff w -> Bool
forall (w :: Nat). MemSegmentOff w -> Bool
isExecutableSegOff ([MemSegmentOff w] -> [MemSegmentOff w])
-> [MemSegmentOff w] -> [MemSegmentOff w]
forall a b. (a -> b) -> a -> b
$ Set (MemSegmentOff w) -> [MemSegmentOff w]
forall a. Set a -> [a]
Set.toList Set (MemSegmentOff w)
s
identifyConcreteAddresses Memory w
_mem StridedInterval{} = []
identifyConcreteAddresses Memory w
_mem AbsValue w (BVType w)
_ = []


-- | @normBool b q@ returns a pair where for each `NotApp` applied to @b@, we recursively
-- take the argument to `NotApp` and the Boolean.
--
-- This is used to compare if one value is equal to or the syntactic
-- complement of another value.
normBool :: Value arch ids BoolType -> Bool -> (Value arch ids BoolType, Bool)
normBool :: forall arch ids.
Value arch ids BoolType -> Bool -> (Value arch ids BoolType, Bool)
normBool Value arch ids BoolType
x Bool
b
  | AssignedValue Assignment arch ids BoolType
a <- Value arch ids BoolType
x
  , EvalApp (NotApp Value arch ids BoolType
xn) <- Assignment arch ids BoolType
-> AssignRhs arch (Value arch ids) BoolType
forall arch ids (tp :: Type).
Assignment arch ids tp -> AssignRhs arch (Value arch ids) tp
assignRhs Assignment arch ids BoolType
a =
      Value arch ids BoolType -> Bool -> (Value arch ids BoolType, Bool)
forall arch ids.
Value arch ids BoolType -> Bool -> (Value arch ids BoolType, Bool)
normBool Value arch ids BoolType
xn (Bool -> Bool
not Bool
b)
  | Bool
otherwise = (Value arch ids BoolType
x,Bool
b)

-- | This computes the abstract state for the start of a block for a
-- given branch target.  It is used so that we can make use of the
-- branch condition to simplify the abstract state.
branchBlockState :: forall a ids t
               .  ( Foldable t
                  )
               => Info.ArchitectureInfo a
               -> AbsProcessorState (ArchReg a) ids
               -> t (Stmt a ids)
               -> RegState (ArchReg a) (Value a ids)
                  -- ^  Register values
               -> Value a ids BoolType
                  -- ^ Branch condition
               -> Bool
                  -- ^ Flag indicating if branch is true or false.
               -> AbsBlockState (ArchReg a)
branchBlockState :: forall a ids (t :: Type -> Type).
Foldable t =>
ArchitectureInfo a
-> AbsProcessorState (ArchReg a) ids
-> t (Stmt a ids)
-> RegState (ArchReg a) (Value a ids)
-> Value a ids BoolType
-> Bool
-> AbsBlockState (ArchReg a)
branchBlockState ArchitectureInfo a
ainfo AbsProcessorState (ArchReg a) ids
ps0 t (Stmt a ids)
stmts RegState (ArchReg a) (Value a ids)
regs Value a ids BoolType
c0 Bool
isTrue0 =
  ArchitectureInfo a -> forall a. (ArchConstraints a => a) -> a
forall arch.
ArchitectureInfo arch -> forall a. (ArchConstraints arch => a) -> a
Info.withArchConstraints ArchitectureInfo a
ainfo ((ArchConstraints a => AbsBlockState (ArchReg a))
 -> AbsBlockState (ArchReg a))
-> (ArchConstraints a => AbsBlockState (ArchReg a))
-> AbsBlockState (ArchReg a)
forall a b. (a -> b) -> a -> b
$
    let (Value a ids BoolType
c,Bool
isTrue) = Value a ids BoolType -> Bool -> (Value a ids BoolType, Bool)
forall arch ids.
Value arch ids BoolType -> Bool -> (Value arch ids BoolType, Bool)
normBool Value a ids BoolType
c0 Bool
isTrue0
        ps :: AbsProcessorState (ArchReg a) ids
ps = Value a ids BoolType
-> Bool
-> AbsProcessorState (ArchReg a) ids
-> AbsProcessorState (ArchReg a) ids
forall arch ids.
(RegisterInfo (ArchReg arch), OrdF (ArchReg arch),
 HasRepr (ArchReg arch) TypeRepr) =>
Value arch ids BoolType
-> Bool
-> AbsProcessorState (ArchReg arch) ids
-> AbsProcessorState (ArchReg arch) ids
Refine.refineProcState Value a ids BoolType
c Bool
isTrue AbsProcessorState (ArchReg a) ids
ps0
        mapReg :: ArchReg a tp -> Value a ids tp -> Value a ids tp
        mapReg :: forall (tp :: Type).
ArchReg a tp -> Value a ids tp -> Value a ids tp
mapReg ArchReg a tp
_r Value a ids tp
v
          | AssignedValue Assignment a ids tp
a <- Value a ids tp
v
          , EvalApp (Mux TypeRepr tp
_ Value a ids BoolType
cv0 Value a ids tp
tv Value a ids tp
fv) <- Assignment a ids tp -> AssignRhs a (Value a ids) tp
forall arch ids (tp :: Type).
Assignment arch ids tp -> AssignRhs arch (Value arch ids) tp
assignRhs Assignment a ids tp
a
          , (Value a ids BoolType
cv, Bool
b) <- Value a ids BoolType -> Bool -> (Value a ids BoolType, Bool)
forall arch ids.
Value arch ids BoolType -> Bool -> (Value arch ids BoolType, Bool)
normBool Value a ids BoolType
cv0 Bool
isTrue
          , Value a ids BoolType
cv Value a ids BoolType -> Value a ids BoolType -> Bool
forall a. Eq a => a -> a -> Bool
== Value a ids BoolType
c =
              if Bool
b then Value a ids tp
tv else Value a ids tp
fv
          | Bool
otherwise =
              Value a ids tp
v
        refinedRegs :: RegState (ArchReg a) (Value a ids)
refinedRegs = (forall (tp :: Type).
 ArchReg a tp -> Value a ids tp -> Value a ids tp)
-> RegState (ArchReg a) (Value a ids)
-> RegState (ArchReg a) (Value a ids)
forall {k} (r :: k -> Type) (f :: k -> Type) (g :: k -> Type).
(forall (tp :: k). r tp -> f tp -> g tp)
-> RegState r f -> RegState r g
mapRegsWith ArchReg a tp -> Value a ids tp -> Value a ids tp
forall (tp :: Type).
ArchReg a tp -> Value a ids tp -> Value a ids tp
mapReg RegState (ArchReg a) (Value a ids)
regs
     in AbsProcessorState (ArchReg a) ids
-> RegState (ArchReg a) (Value a ids) -> AbsBlockState (ArchReg a)
forall a ids.
RegisterInfo (ArchReg a) =>
AbsProcessorState (ArchReg a) ids
-> RegState (ArchReg a) (Value a ids) -> AbsBlockState (ArchReg a)
finalAbsBlockState ((AbsProcessorState (ArchReg a) ids
 -> Stmt a ids -> AbsProcessorState (ArchReg a) ids)
-> AbsProcessorState (ArchReg a) ids
-> t (Stmt a ids)
-> AbsProcessorState (ArchReg a) ids
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' (ArchitectureInfo a
-> AbsProcessorState (ArchReg a) ids
-> Stmt a ids
-> AbsProcessorState (ArchReg a) ids
forall arch ids.
ArchitectureInfo arch
-> AbsProcessorState (ArchReg arch) ids
-> Stmt arch ids
-> AbsProcessorState (ArchReg arch) ids
AbsEval.absEvalStmt ArchitectureInfo a
ainfo) AbsProcessorState (ArchReg a) ids
ps t (Stmt a ids)
stmts) RegState (ArchReg a) (Value a ids)
refinedRegs

classifyDirectJump :: RegisterInfo (ArchReg arch)
                   => ParseContext arch ids
                   -> String
                   -> Value arch ids (BVType (ArchAddrWidth arch))
                   -> BlockClassifierM arch ids (ArchSegmentOff arch)
classifyDirectJump :: forall arch ids.
RegisterInfo (ArchReg arch) =>
ParseContext arch ids
-> String
-> Value arch ids (BVType (ArchAddrWidth arch))
-> BlockClassifierM arch ids (ArchSegmentOff arch)
classifyDirectJump ParseContext arch ids
ctx String
nm Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
v = do
  ma <- case Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
-> Maybe (MemAddr (RegAddrWidth (ArchReg arch)))
forall arch ids.
MemWidth (ArchAddrWidth arch) =>
BVValue arch ids (ArchAddrWidth arch) -> Maybe (ArchMemAddr arch)
valueAsMemAddr Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
v of
          Maybe (MemAddr (RegAddrWidth (ArchReg arch)))
Nothing ->  String
-> BlockClassifierM
     arch ids (MemAddr (RegAddrWidth (ArchReg arch)))
forall a. String -> BlockClassifierM arch ids a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
 -> BlockClassifierM
      arch ids (MemAddr (RegAddrWidth (ArchReg arch))))
-> String
-> BlockClassifierM
     arch ids (MemAddr (RegAddrWidth (ArchReg arch)))
forall a b. (a -> b) -> a -> b
$ String
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" value " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value arch ids (BVType (RegAddrWidth (ArchReg arch))) -> String
forall a. Show a => a -> String
show Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a valid address."
          Just MemAddr (RegAddrWidth (ArchReg arch))
a -> MemAddr (RegAddrWidth (ArchReg arch))
-> BlockClassifierM
     arch ids (MemAddr (RegAddrWidth (ArchReg arch)))
forall a. a -> BlockClassifierM arch ids a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure MemAddr (RegAddrWidth (ArchReg arch))
a
  a <- case asSegmentOff (pctxMemory ctx) ma of
         Maybe (MemSegmentOff (RegAddrWidth (ArchReg arch)))
Nothing ->
           String
-> BlockClassifierM
     arch ids (MemSegmentOff (RegAddrWidth (ArchReg arch)))
forall a. String -> BlockClassifierM arch ids a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
 -> BlockClassifierM
      arch ids (MemSegmentOff (RegAddrWidth (ArchReg arch))))
-> String
-> BlockClassifierM
     arch ids (MemSegmentOff (RegAddrWidth (ArchReg arch)))
forall a b. (a -> b) -> a -> b
$ String
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" value " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value arch ids (BVType (RegAddrWidth (ArchReg arch))) -> String
forall a. Show a => a -> String
show Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a segment offset in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Memory (RegAddrWidth (ArchReg arch)) -> String
forall a. Show a => a -> String
show (ParseContext arch ids -> Memory (RegAddrWidth (ArchReg arch))
forall arch ids.
ParseContext arch ids -> Memory (ArchAddrWidth arch)
pctxMemory ParseContext arch ids
ctx) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
         Just MemSegmentOff (RegAddrWidth (ArchReg arch))
sa -> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> BlockClassifierM
     arch ids (MemSegmentOff (RegAddrWidth (ArchReg arch)))
forall a. a -> BlockClassifierM arch ids a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure MemSegmentOff (RegAddrWidth (ArchReg arch))
sa
  unless (segmentFlags (segoffSegment a) `Perm.hasPerm` Perm.execute) $ do
    fail $ nm ++ " value " ++ show a ++ " is not executable."
  when (a == pctxFunAddr ctx) $ do
    fail $ nm ++ " value " ++ show a ++ " refers to function start."
  when (a `Map.member` pctxKnownFnEntries ctx) $ do
    fail $ nm ++ " value " ++ show a ++ " is a known function entry."
  pure a

-- | The classifier for conditional and unconditional branches
--
-- Note that this classifier can convert a conditional branch to an
-- unconditional branch if (and only if) the condition is syntactically true or
-- false after constant propagation. It never attempts sophisticated path
-- trimming.
branchClassifier :: BlockClassifier arch ids
branchClassifier :: forall arch ids. BlockClassifier arch ids
branchClassifier = String
-> BlockClassifierM arch ids (ParsedContents arch ids)
-> BlockClassifierM arch ids (ParsedContents arch ids)
forall arch ids a.
String
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids a
classifierName String
"Branch" (BlockClassifierM arch ids (ParsedContents arch ids)
 -> BlockClassifierM arch ids (ParsedContents arch ids))
-> BlockClassifierM arch ids (ParsedContents arch ids)
-> BlockClassifierM arch ids (ParsedContents arch ids)
forall a b. (a -> b) -> a -> b
$ do
  bcc <- BlockClassifierM arch ids (BlockClassifierContext arch ids)
forall r (m :: Type -> Type). MonadReader r m => m r
CMR.ask
  let ctx = BlockClassifierContext arch ids -> ParseContext arch ids
forall arch ids.
BlockClassifierContext arch ids -> ParseContext arch ids
classifierParseContext BlockClassifierContext arch ids
bcc
  let 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 writtenAddrs = BlockClassifierContext arch ids -> [ArchSegmentOff arch]
forall arch ids.
BlockClassifierContext arch ids -> [ArchSegmentOff arch]
classifierWrittenAddrs BlockClassifierContext arch ids
bcc
  let absState = BlockClassifierContext arch ids
-> AbsProcessorState (ArchReg arch) ids
forall arch ids.
BlockClassifierContext arch ids
-> AbsProcessorState (ArchReg arch) ids
classifierAbsState BlockClassifierContext arch ids
bcc
  let stmts = BlockClassifierContext arch ids -> Seq (Stmt arch ids)
forall arch ids.
BlockClassifierContext arch ids -> Seq (Stmt arch ids)
classifierStmts BlockClassifierContext arch ids
bcc
  let ainfo = ParseContext arch ids -> ArchitectureInfo arch
forall arch ids. ParseContext arch ids -> ArchitectureInfo arch
pctxArchInfo ParseContext arch ids
ctx
  Info.withArchConstraints ainfo $ do
    -- The block ends with a Mux, so we turn this into a `ParsedBranch` statement.
    let ipVal = RegState (ArchReg arch) (Value arch ids)
finalRegsRegState (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
    (c,t,f) <- case valueAsApp ipVal of
                 Just (Mux TypeRepr (BVType (RegAddrWidth (ArchReg arch)))
_ Value arch ids BoolType
c Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
t Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
f) -> (Value arch ids BoolType,
 Value arch ids (BVType (RegAddrWidth (ArchReg arch))),
 Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
-> BlockClassifierM
     arch
     ids
     (Value arch ids BoolType,
      Value arch ids (BVType (RegAddrWidth (ArchReg arch))),
      Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
forall a. a -> BlockClassifierM arch ids a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Value arch ids BoolType
c,Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
t,Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
f)
                 Maybe (App (Value arch ids) (BVType (RegAddrWidth (ArchReg arch))))
_ -> String
-> BlockClassifierM
     arch
     ids
     (Value arch ids BoolType,
      Value arch ids (BVType (RegAddrWidth (ArchReg arch))),
      Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
forall a. String -> BlockClassifierM arch ids a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
 -> BlockClassifierM
      arch
      ids
      (Value arch ids BoolType,
       Value arch ids (BVType (RegAddrWidth (ArchReg arch))),
       Value arch ids (BVType (RegAddrWidth (ArchReg arch)))))
-> String
-> BlockClassifierM
     arch
     ids
     (Value arch ids BoolType,
      Value arch ids (BVType (RegAddrWidth (ArchReg arch))),
      Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
forall a b. (a -> b) -> a -> b
$ String
"IP is not an mux:\n"
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc (ZonkAny 0) -> String
forall a. Show a => a -> String
show (Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
-> Doc (ZonkAny 0)
forall arch ids (tp :: Type) ann.
ArchConstraints arch =>
Value arch ids tp -> Doc ann
ppValueAssignments Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
ipVal)
    trueTgtAddr  <- classifyDirectJump ctx "True branch"  t
    falseTgtAddr <- classifyDirectJump ctx "False branch" f

    let trueRegs  = RegState (ArchReg arch) (Value arch ids)
finalRegs RegState (ArchReg arch) (Value arch ids)
-> (RegState (ArchReg arch) (Value arch ids)
    -> RegState (ArchReg arch) (Value arch ids))
-> RegState (ArchReg arch) (Value arch ids)
forall a b. a -> (a -> b) -> b
& 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 ((Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
  -> Identity
       (Value arch ids (BVType (RegAddrWidth (ArchReg arch)))))
 -> RegState (ArchReg arch) (Value arch ids)
 -> Identity (RegState (ArchReg arch) (Value arch ids)))
-> Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
-> RegState (ArchReg arch) (Value arch ids)
-> RegState (ArchReg arch) (Value arch ids)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
t
    let falseRegs = RegState (ArchReg arch) (Value arch ids)
finalRegs RegState (ArchReg arch) (Value arch ids)
-> (RegState (ArchReg arch) (Value arch ids)
    -> RegState (ArchReg arch) (Value arch ids))
-> RegState (ArchReg arch) (Value arch ids)
forall a b. a -> (a -> b) -> b
& 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 ((Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
  -> Identity
       (Value arch ids (BVType (RegAddrWidth (ArchReg arch)))))
 -> RegState (ArchReg arch) (Value arch ids)
 -> Identity (RegState (ArchReg arch) (Value arch ids)))
-> Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
-> RegState (ArchReg arch) (Value arch ids)
-> RegState (ArchReg arch) (Value arch ids)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
f

    let trueAbsState  = ArchitectureInfo arch
-> AbsProcessorState (ArchReg arch) ids
-> Seq (Stmt arch ids)
-> RegState (ArchReg arch) (Value arch ids)
-> Value arch ids BoolType
-> Bool
-> AbsBlockState (ArchReg arch)
forall a ids (t :: Type -> Type).
Foldable t =>
ArchitectureInfo a
-> AbsProcessorState (ArchReg a) ids
-> t (Stmt a ids)
-> RegState (ArchReg a) (Value a ids)
-> Value a ids BoolType
-> Bool
-> AbsBlockState (ArchReg a)
branchBlockState ArchitectureInfo arch
ainfo AbsProcessorState (ArchReg arch) ids
absState Seq (Stmt arch ids)
stmts RegState (ArchReg arch) (Value arch ids)
trueRegs Value arch ids BoolType
c Bool
True
    let falseAbsState = ArchitectureInfo arch
-> AbsProcessorState (ArchReg arch) ids
-> Seq (Stmt arch ids)
-> RegState (ArchReg arch) (Value arch ids)
-> Value arch ids BoolType
-> Bool
-> AbsBlockState (ArchReg arch)
forall a ids (t :: Type -> Type).
Foldable t =>
ArchitectureInfo a
-> AbsProcessorState (ArchReg a) ids
-> t (Stmt a ids)
-> RegState (ArchReg a) (Value a ids)
-> Value a ids BoolType
-> Bool
-> AbsBlockState (ArchReg a)
branchBlockState ArchitectureInfo arch
ainfo AbsProcessorState (ArchReg arch) ids
absState Seq (Stmt arch ids)
stmts RegState (ArchReg arch) (Value arch ids)
falseRegs Value arch ids BoolType
c Bool
False
    let jmpBounds = BlockClassifierContext arch ids -> IntraJumpBounds arch ids
forall arch ids.
BlockClassifierContext arch ids -> IntraJumpBounds arch ids
classifierJumpBounds BlockClassifierContext arch ids
bcc
    case Jmp.postBranchBounds jmpBounds finalRegs c of
      Jmp.BothFeasibleBranch InitJumpBounds arch
trueJmpState InitJumpBounds arch
falseJmpState -> do
        ParsedContents arch ids
-> BlockClassifierM arch ids (ParsedContents arch ids)
forall a. a -> BlockClassifierM arch ids a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ParsedContents arch ids
 -> BlockClassifierM arch ids (ParsedContents arch ids))
-> ParsedContents arch ids
-> BlockClassifierM arch ids (ParsedContents arch ids)
forall a b. (a -> b) -> a -> b
$ Parsed.ParsedContents { parsedNonterm :: [Stmt arch ids]
Parsed.parsedNonterm = Seq (Stmt arch ids) -> [Stmt arch ids]
forall a. Seq a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
F.toList Seq (Stmt arch ids)
stmts
                                  , parsedTerm :: ParsedTermStmt arch ids
Parsed.parsedTerm  =
                                    RegState (ArchReg arch) (Value arch ids)
-> Value arch ids BoolType
-> ArchSegmentOff arch
-> ArchSegmentOff arch
-> ParsedTermStmt arch ids
forall arch ids.
RegState (ArchReg arch) (Value arch ids)
-> Value arch ids BoolType
-> ArchSegmentOff arch
-> ArchSegmentOff arch
-> ParsedTermStmt arch ids
Parsed.ParsedBranch RegState (ArchReg arch) (Value arch ids)
finalRegs Value arch ids BoolType
c ArchSegmentOff arch
trueTgtAddr ArchSegmentOff arch
falseTgtAddr
                                  , writtenCodeAddrs :: [ArchSegmentOff arch]
Parsed.writtenCodeAddrs = [ArchSegmentOff arch]
writtenAddrs
                                  , intraJumpTargets :: [IntraJumpTarget arch]
Parsed.intraJumpTargets =
                                    [ (ArchSegmentOff arch
trueTgtAddr,  AbsBlockState (ArchReg arch)
trueAbsState,  InitJumpBounds arch
trueJmpState)
                                    , (ArchSegmentOff arch
falseTgtAddr, AbsBlockState (ArchReg arch)
falseAbsState, InitJumpBounds arch
falseJmpState)
                                    ]
                                  , newFunctionAddrs :: [ArchSegmentOff arch]
Parsed.newFunctionAddrs = []
                                  }
      -- The false branch is impossible.
      Jmp.TrueFeasibleBranch InitJumpBounds arch
trueJmpState -> do
        ParsedContents arch ids
-> BlockClassifierM arch ids (ParsedContents arch ids)
forall a. a -> BlockClassifierM arch ids a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ParsedContents arch ids
 -> BlockClassifierM arch ids (ParsedContents arch ids))
-> ParsedContents arch ids
-> BlockClassifierM arch ids (ParsedContents arch ids)
forall a b. (a -> b) -> a -> b
$ Parsed.ParsedContents { parsedNonterm :: [Stmt arch ids]
Parsed.parsedNonterm = Seq (Stmt arch ids) -> [Stmt arch ids]
forall a. Seq a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
F.toList Seq (Stmt arch ids)
stmts
                                  , parsedTerm :: ParsedTermStmt arch ids
Parsed.parsedTerm  = RegState (ArchReg arch) (Value arch ids)
-> ArchSegmentOff arch -> ParsedTermStmt arch ids
forall arch ids.
RegState (ArchReg arch) (Value arch ids)
-> ArchSegmentOff arch -> ParsedTermStmt arch ids
Parsed.ParsedJump RegState (ArchReg arch) (Value arch ids)
finalRegs ArchSegmentOff arch
trueTgtAddr
                                  , writtenCodeAddrs :: [ArchSegmentOff arch]
Parsed.writtenCodeAddrs = [ArchSegmentOff arch]
writtenAddrs
                                  , intraJumpTargets :: [IntraJumpTarget arch]
Parsed.intraJumpTargets =
                                    [(ArchSegmentOff arch
trueTgtAddr, AbsBlockState (ArchReg arch)
trueAbsState, InitJumpBounds arch
trueJmpState)]
                                  , newFunctionAddrs :: [ArchSegmentOff arch]
Parsed.newFunctionAddrs = []
                                  }
      -- The true branch is impossible.
      Jmp.FalseFeasibleBranch InitJumpBounds arch
falseJmpState -> do
        ParsedContents arch ids
-> BlockClassifierM arch ids (ParsedContents arch ids)
forall a. a -> BlockClassifierM arch ids a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ParsedContents arch ids
 -> BlockClassifierM arch ids (ParsedContents arch ids))
-> ParsedContents arch ids
-> BlockClassifierM arch ids (ParsedContents arch ids)
forall a b. (a -> b) -> a -> b
$ Parsed.ParsedContents { parsedNonterm :: [Stmt arch ids]
Parsed.parsedNonterm = Seq (Stmt arch ids) -> [Stmt arch ids]
forall a. Seq a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
F.toList Seq (Stmt arch ids)
stmts
                                  , parsedTerm :: ParsedTermStmt arch ids
Parsed.parsedTerm  = RegState (ArchReg arch) (Value arch ids)
-> ArchSegmentOff arch -> ParsedTermStmt arch ids
forall arch ids.
RegState (ArchReg arch) (Value arch ids)
-> ArchSegmentOff arch -> ParsedTermStmt arch ids
Parsed.ParsedJump RegState (ArchReg arch) (Value arch ids)
finalRegs ArchSegmentOff arch
falseTgtAddr
                                  , writtenCodeAddrs :: [ArchSegmentOff arch]
Parsed.writtenCodeAddrs = [ArchSegmentOff arch]
writtenAddrs
                                  , intraJumpTargets :: [IntraJumpTarget arch]
Parsed.intraJumpTargets =
                                    [(ArchSegmentOff arch
falseTgtAddr, AbsBlockState (ArchReg arch)
falseAbsState, InitJumpBounds arch
falseJmpState)]
                                  , newFunctionAddrs :: [ArchSegmentOff arch]
Parsed.newFunctionAddrs = []
                              }
      -- Both branches were deemed impossible
      BranchBounds arch
Jmp.InfeasibleBranch -> do
        String -> BlockClassifierM arch ids (ParsedContents arch ids)
forall a. String -> BlockClassifierM arch ids a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Branch targets are both unreachable."

-- | Identify new potential function entry points by looking at IP.
identifyCallTargets :: forall arch ids
                    .  (RegisterInfo (ArchReg arch))
                    => Memory (ArchAddrWidth arch)
                    -> AbsProcessorState (ArchReg arch) ids
                       -- ^ Abstract processor state just before call.
                    -> RegState (ArchReg arch) (Value arch ids)
                    -> [ArchSegmentOff arch]
identifyCallTargets :: forall arch ids.
RegisterInfo (ArchReg arch) =>
Memory (ArchAddrWidth arch)
-> AbsProcessorState (ArchReg arch) ids
-> RegState (ArchReg arch) (Value arch ids)
-> [ArchSegmentOff arch]
identifyCallTargets Memory (RegAddrWidth (ArchReg arch))
mem AbsProcessorState (ArchReg arch) ids
absState RegState (ArchReg arch) (Value arch ids)
regs = do
  -- Code pointers from abstract domains.
  let def :: [ArchSegmentOff arch]
def = Memory (RegAddrWidth (ArchReg arch))
-> AbsValue
     (RegAddrWidth (ArchReg arch))
     (BVType (RegAddrWidth (ArchReg arch)))
-> [ArchSegmentOff arch]
forall (w :: Nat).
MemWidth w =>
Memory w -> AbsValue w (BVType w) -> [MemSegmentOff w]
identifyConcreteAddresses Memory (RegAddrWidth (ArchReg arch))
mem (AbsValue
   (RegAddrWidth (ArchReg arch))
   (BVType (RegAddrWidth (ArchReg arch)))
 -> [ArchSegmentOff arch])
-> AbsValue
     (RegAddrWidth (ArchReg arch))
     (BVType (RegAddrWidth (ArchReg arch)))
-> [ArchSegmentOff arch]
forall a b. (a -> b) -> a -> b
$ AbsProcessorState (ArchReg arch) ids
-> Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
-> AbsValue
     (RegAddrWidth (ArchReg arch))
     (BVType (RegAddrWidth (ArchReg 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 (RegState (ArchReg arch) (Value arch ids)
regsRegState (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)
  case RegState (ArchReg arch) (Value arch ids)
regsRegState (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 of
    BVValue NatRepr n
_ Integer
x ->
      Maybe (ArchSegmentOff arch) -> [ArchSegmentOff arch]
forall a. Maybe a -> [a]
maybeToList (Maybe (ArchSegmentOff arch) -> [ArchSegmentOff arch])
-> Maybe (ArchSegmentOff arch) -> [ArchSegmentOff arch]
forall a b. (a -> b) -> a -> b
$ Memory n -> MemWord n -> Maybe (MemSegmentOff n)
forall (w :: Nat). Memory w -> MemWord w -> Maybe (MemSegmentOff w)
resolveAbsoluteAddr Memory n
Memory (RegAddrWidth (ArchReg arch))
mem (Integer -> MemWord n
forall a. Num a => Integer -> a
fromInteger Integer
x)
    RelocatableValue AddrWidthRepr (RegAddrWidth (ArchReg arch))
_ MemAddr (RegAddrWidth (ArchReg arch))
a ->
      Maybe (ArchSegmentOff arch) -> [ArchSegmentOff arch]
forall a. Maybe a -> [a]
maybeToList (Maybe (ArchSegmentOff arch) -> [ArchSegmentOff arch])
-> Maybe (ArchSegmentOff arch) -> [ArchSegmentOff arch]
forall a b. (a -> b) -> a -> b
$ Memory (RegAddrWidth (ArchReg arch))
-> MemAddr (RegAddrWidth (ArchReg arch))
-> Maybe (ArchSegmentOff arch)
forall (w :: Nat). Memory w -> MemAddr w -> Maybe (MemSegmentOff w)
asSegmentOff Memory (RegAddrWidth (ArchReg arch))
mem MemAddr (RegAddrWidth (ArchReg arch))
a
    SymbolValue{} -> []
    AssignedValue Assignment arch ids (BVType (RegAddrWidth (ArchReg arch)))
a ->
      case Assignment arch ids (BVType (RegAddrWidth (ArchReg arch)))
-> AssignRhs
     arch (Value arch ids) (BVType (RegAddrWidth (ArchReg arch)))
forall arch ids (tp :: Type).
Assignment arch ids tp -> AssignRhs arch (Value arch ids) tp
assignRhs Assignment arch ids (BVType (RegAddrWidth (ArchReg arch)))
a of
        -- See if we can get a value out of a concrete memory read.
        ReadMem Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
addr (BVMemRepr NatRepr w
_ Endianness
end)
          | Just MemAddr (RegAddrWidth (ArchReg arch))
laddr <- Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
-> Maybe (MemAddr (RegAddrWidth (ArchReg arch)))
forall arch ids.
MemWidth (ArchAddrWidth arch) =>
BVValue arch ids (ArchAddrWidth arch) -> Maybe (ArchMemAddr arch)
valueAsMemAddr Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
addr
          , Right ArchSegmentOff arch
val <- Memory (RegAddrWidth (ArchReg arch))
-> Endianness
-> MemAddr (RegAddrWidth (ArchReg arch))
-> Either
     (MemoryError (RegAddrWidth (ArchReg arch))) (ArchSegmentOff arch)
forall (w :: Nat).
Memory w
-> Endianness
-> MemAddr w
-> Either (MemoryError w) (MemSegmentOff w)
readSegmentOff Memory (RegAddrWidth (ArchReg arch))
mem Endianness
end MemAddr (RegAddrWidth (ArchReg arch))
laddr ->
            ArchSegmentOff arch
val ArchSegmentOff arch
-> [ArchSegmentOff arch] -> [ArchSegmentOff arch]
forall a. a -> [a] -> [a]
: [ArchSegmentOff arch]
def
        AssignRhs
  arch (Value arch ids) (BVType (RegAddrWidth (ArchReg arch)))
_ -> [ArchSegmentOff arch]
def
    Initial ArchReg arch (BVType (RegAddrWidth (ArchReg arch)))
_ -> [ArchSegmentOff arch]
def

-- |  Use the architecture-specific callback to check if last statement was a call.
--
-- Note that in some cases the call is known not to return, and thus this code
-- will never jump to the return value; in that case, the
-- 'noreturnCallClassifier' should fire. As such, 'callClassifier' should always
-- be attempted *after* 'noreturnCallClassifier'.
callClassifier :: BlockClassifier arch ids
callClassifier :: forall arch ids. BlockClassifier arch ids
callClassifier = String
-> BlockClassifierM arch ids (ParsedContents arch ids)
-> BlockClassifierM arch ids (ParsedContents arch ids)
forall arch ids a.
String
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids a
classifierName String
"Call" (BlockClassifierM arch ids (ParsedContents arch ids)
 -> BlockClassifierM arch ids (ParsedContents arch ids))
-> BlockClassifierM arch ids (ParsedContents arch ids)
-> BlockClassifierM arch ids (ParsedContents arch ids)
forall a b. (a -> b) -> a -> b
$ do
  bcc <- BlockClassifierM arch ids (BlockClassifierContext arch ids)
forall r (m :: Type -> Type). MonadReader r m => m r
CMR.ask
  let ctx = BlockClassifierContext arch ids -> ParseContext arch ids
forall arch ids.
BlockClassifierContext arch ids -> ParseContext arch ids
classifierParseContext BlockClassifierContext arch ids
bcc
  let 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 ainfo = ParseContext arch ids -> ArchitectureInfo arch
forall arch ids. ParseContext arch ids -> ArchitectureInfo arch
pctxArchInfo ParseContext arch ids
ctx
  let mem = ParseContext arch ids -> Memory (ArchAddrWidth arch)
forall arch ids.
ParseContext arch ids -> Memory (ArchAddrWidth arch)
pctxMemory ParseContext arch ids
ctx
  ret <- case Info.identifyCall ainfo mem (classifierStmts bcc) finalRegs of
           Just (Seq (Stmt arch ids)
_prev_stmts, MemSegmentOff (ArchAddrWidth arch)
ret) -> MemSegmentOff (ArchAddrWidth arch)
-> BlockClassifierM arch ids (MemSegmentOff (ArchAddrWidth arch))
forall a. a -> BlockClassifierM arch ids a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure MemSegmentOff (ArchAddrWidth arch)
ret
           Maybe (Seq (Stmt arch ids), MemSegmentOff (ArchAddrWidth arch))
Nothing -> String
-> BlockClassifierM arch ids (MemSegmentOff (ArchAddrWidth arch))
forall a. String -> BlockClassifierM arch ids a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Call classifier failed."
  Info.withArchConstraints ainfo $ do
    pure $ Parsed.ParsedContents { Parsed.parsedNonterm = F.toList (classifierStmts bcc)
                              , Parsed.parsedTerm  = Parsed.ParsedCall finalRegs (Just ret)
                              -- The return address may be written to
                              -- stack, but is highly unlikely to be
                              -- a function entry point.
                              , Parsed.writtenCodeAddrs = filter (/= ret) (classifierWrittenAddrs bcc)
                              --Include return target
                              , Parsed.intraJumpTargets =
                                [( ret
                                 , Info.postCallAbsState ainfo (classifierAbsState bcc) finalRegs ret
                                 , Jmp.postCallBounds (Info.archCallParams ainfo) (classifierJumpBounds bcc) finalRegs
                                 )]
                              -- Use the abstract domain to look for new code pointers for the current IP.
                              , Parsed.newFunctionAddrs = identifyCallTargets mem (classifierAbsState bcc) finalRegs
                              }

-- | Check this block ends with a return as identified by the
-- architecture-specific processing.  Basic return identification
-- can be performed by detecting when the Instruction Pointer
-- (ip_reg) contains the 'ReturnAddr' symbolic value (initially
-- placed on the top of the stack or in the Link Register by the
-- architecture-specific state initializer).  However, some
-- architectures perform expression evaluations on this value before
-- loading the IP (e.g. ARM will clear the low bit in T32 mode or
-- the low 2 bits in A32 mode), so the actual detection process is
-- deferred to architecture-specific functionality.
returnClassifier :: BlockClassifier arch ids
returnClassifier :: forall arch ids. BlockClassifier arch ids
returnClassifier = String
-> BlockClassifierM arch ids (ParsedContents arch ids)
-> BlockClassifierM arch ids (ParsedContents arch ids)
forall arch ids a.
String
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids a
classifierName String
"Return" (BlockClassifierM arch ids (ParsedContents arch ids)
 -> BlockClassifierM arch ids (ParsedContents arch ids))
-> BlockClassifierM arch ids (ParsedContents arch ids)
-> BlockClassifierM arch ids (ParsedContents arch ids)
forall a b. (a -> b) -> a -> b
$ do
  bcc <- BlockClassifierM arch ids (BlockClassifierContext arch ids)
forall r (m :: Type -> Type). MonadReader r m => m r
CMR.ask
  let ainfo = ParseContext arch ids -> ArchitectureInfo arch
forall arch ids. ParseContext arch ids -> ArchitectureInfo arch
pctxArchInfo (BlockClassifierContext arch ids -> ParseContext arch ids
forall arch ids.
BlockClassifierContext arch ids -> ParseContext arch ids
classifierParseContext BlockClassifierContext arch ids
bcc)
  Info.withArchConstraints ainfo $ do
    Just prevStmts <-
      pure $ Info.identifyReturn ainfo
                            (classifierStmts bcc)
                            (classifierFinalRegState bcc)
                            (classifierAbsState bcc)
    pure $ Parsed.ParsedContents { Parsed.parsedNonterm = F.toList prevStmts
                              , Parsed.parsedTerm = Parsed.ParsedReturn (classifierFinalRegState bcc)
                              , Parsed.writtenCodeAddrs = classifierWrittenAddrs bcc
                              , Parsed.intraJumpTargets = []
                              , Parsed.newFunctionAddrs = []
                              }

-- | Classifies jumps to concrete addresses as unconditional jumps.  Note that
-- this logic is substantially similar to the 'tailCallClassifier' in cases
-- where the function does not establish a stack frame (i.e., leaf functions).
--
-- Note that known call targets are not eligible to be intra-procedural jump
-- targets (see 'classifyDirectJump'). This means that we need to conservatively
-- prefer to mis-classify terminators as jumps rather than tail calls. The
-- downside of this choice is that code that could be considered a tail-called
-- function may be duplicated in some cases (i.e., considered part of multiple
-- functions).
--
-- The alternative interpretation (eagerly preferring tail calls) can cause a
-- section of a function to be marked as a tail-called function, thereby
-- blocking the 'directJumpClassifier' or the 'branchClassifier' from
-- recognizing the "callee" as an intra-procedural jump. This results in
-- classification failures that we don't have any mitigations for.
directJumpClassifier :: BlockClassifier arch ids
directJumpClassifier :: forall arch ids. BlockClassifier arch ids
directJumpClassifier = String
-> BlockClassifierM arch ids (ParsedContents arch ids)
-> BlockClassifierM arch ids (ParsedContents arch ids)
forall arch ids a.
String
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids a
classifierName String
"Jump" (BlockClassifierM arch ids (ParsedContents arch ids)
 -> BlockClassifierM arch ids (ParsedContents arch ids))
-> BlockClassifierM arch ids (ParsedContents arch ids)
-> BlockClassifierM arch ids (ParsedContents arch ids)
forall a b. (a -> b) -> a -> b
$ do
  bcc <- BlockClassifierM arch ids (BlockClassifierContext arch ids)
forall r (m :: Type -> Type). MonadReader r m => m r
CMR.ask
  let ctx = BlockClassifierContext arch ids -> ParseContext arch ids
forall arch ids.
BlockClassifierContext arch ids -> ParseContext arch ids
classifierParseContext BlockClassifierContext arch ids
bcc
  let ainfo = ParseContext arch ids -> ArchitectureInfo arch
forall arch ids. ParseContext arch ids -> ArchitectureInfo arch
pctxArchInfo ParseContext arch ids
ctx
  Info.withArchConstraints ainfo $ do

    tgtMSeg <- classifyDirectJump ctx "Jump" (classifierFinalRegState bcc ^. boundValue ip_reg)

    let abst = 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 (BlockClassifierContext arch ids
-> AbsProcessorState (ArchReg arch) ids
forall arch ids.
BlockClassifierContext arch ids
-> AbsProcessorState (ArchReg arch) ids
classifierAbsState BlockClassifierContext arch ids
bcc) (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 abst' = AbsBlockState (ArchReg arch)
abst AbsBlockState (ArchReg arch)
-> (AbsBlockState (ArchReg arch) -> AbsBlockState (ArchReg arch))
-> AbsBlockState (ArchReg arch)
forall a b. a -> (a -> b) -> b
& MemSegmentOff (RegAddrWidth (ArchReg arch))
-> AbsBlockState (ArchReg arch) -> AbsBlockState (ArchReg arch)
forall (r :: Type -> Type).
RegisterInfo r =>
MemSegmentOff (RegAddrWidth r)
-> AbsBlockState r -> AbsBlockState r
setAbsIP MemSegmentOff (RegAddrWidth (ArchReg arch))
tgtMSeg
    let tgtBnds = 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 (BlockClassifierContext arch ids -> IntraJumpBounds arch ids
forall arch ids.
BlockClassifierContext arch ids -> IntraJumpBounds arch ids
classifierJumpBounds BlockClassifierContext arch ids
bcc) (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)
    pure $ Parsed.ParsedContents { Parsed.parsedNonterm = F.toList (classifierStmts bcc)
                              , Parsed.parsedTerm  = Parsed.ParsedJump (classifierFinalRegState bcc) tgtMSeg
                              , Parsed.writtenCodeAddrs = classifierWrittenAddrs bcc
                              , Parsed.intraJumpTargets = [(tgtMSeg, abst', tgtBnds)]
                              , Parsed.newFunctionAddrs = []
                              }

classifierEndBlock :: BlockClassifierContext arch ids
                   -> MemAddr (ArchAddrWidth arch)
classifierEndBlock :: forall arch ids.
BlockClassifierContext arch ids -> MemAddr (ArchAddrWidth arch)
classifierEndBlock BlockClassifierContext arch ids
ctx = ArchitectureInfo arch -> forall a. (ArchConstraints arch => a) -> a
forall arch.
ArchitectureInfo arch -> forall a. (ArchConstraints arch => a) -> a
Info.withArchConstraints (ParseContext arch ids -> ArchitectureInfo arch
forall arch ids. ParseContext arch ids -> ArchitectureInfo arch
pctxArchInfo (BlockClassifierContext arch ids -> ParseContext arch ids
forall arch ids.
BlockClassifierContext arch ids -> ParseContext arch ids
classifierParseContext BlockClassifierContext arch ids
ctx)) ((ArchConstraints arch => MemAddr (ArchAddrWidth arch))
 -> MemAddr (ArchAddrWidth arch))
-> (ArchConstraints arch => MemAddr (ArchAddrWidth arch))
-> MemAddr (ArchAddrWidth arch)
forall a b. (a -> b) -> a -> b
$
  let blockStart :: MemAddr (ArchAddrWidth arch)
blockStart = MemSegmentOff (ArchAddrWidth arch) -> MemAddr (ArchAddrWidth arch)
forall (w :: Nat). MemSegmentOff w -> MemAddr w
segoffAddr (ParseContext arch ids -> MemSegmentOff (ArchAddrWidth arch)
forall arch ids. ParseContext arch ids -> ArchSegmentOff arch
pctxAddr (BlockClassifierContext arch ids -> ParseContext arch ids
forall arch ids.
BlockClassifierContext arch ids -> ParseContext arch ids
classifierParseContext BlockClassifierContext arch ids
ctx))
   in Integer
-> MemAddr (ArchAddrWidth arch) -> MemAddr (ArchAddrWidth arch)
forall (w :: Nat). MemWidth w => Integer -> MemAddr w -> MemAddr w
incAddr (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (BlockClassifierContext arch ids -> Int
forall arch ids. BlockClassifierContext arch ids -> Int
classifierBlockSize BlockClassifierContext arch ids
ctx)) MemAddr (ArchAddrWidth arch)
blockStart

noreturnCallParsedContents :: BlockClassifierContext arch ids -> Parsed.ParsedContents arch ids
noreturnCallParsedContents :: forall arch ids.
BlockClassifierContext arch ids -> ParsedContents arch ids
noreturnCallParsedContents BlockClassifierContext arch ids
bcc =
  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
      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
      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
      regs :: RegState (ArchReg arch) (Value arch ids)
regs = 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
      blockEnd :: MemAddr (ArchAddrWidth arch)
blockEnd = BlockClassifierContext arch ids -> MemAddr (ArchAddrWidth arch)
forall arch ids.
BlockClassifierContext arch ids -> MemAddr (ArchAddrWidth arch)
classifierEndBlock BlockClassifierContext arch ids
bcc
   in ArchitectureInfo arch -> forall a. (ArchConstraints arch => a) -> a
forall arch.
ArchitectureInfo arch -> forall a. (ArchConstraints arch => a) -> a
Info.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
$
        Parsed.ParsedContents { parsedNonterm :: [Stmt arch ids]
Parsed.parsedNonterm = Seq (Stmt arch ids) -> [Stmt arch ids]
forall a. Seq a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
F.toList (BlockClassifierContext arch ids -> Seq (Stmt arch ids)
forall arch ids.
BlockClassifierContext arch ids -> Seq (Stmt arch ids)
classifierStmts BlockClassifierContext arch ids
bcc)
                           , parsedTerm :: ParsedTermStmt arch ids
Parsed.parsedTerm  = RegState (ArchReg arch) (Value arch ids)
-> Maybe (ArchSegmentOff arch) -> ParsedTermStmt arch ids
forall arch ids.
RegState (ArchReg arch) (Value arch ids)
-> Maybe (ArchSegmentOff arch) -> ParsedTermStmt arch ids
Parsed.ParsedCall RegState (ArchReg arch) (Value arch ids)
regs Maybe (ArchSegmentOff arch)
forall a. Maybe a
Nothing
                           , writtenCodeAddrs :: [ArchSegmentOff arch]
Parsed.writtenCodeAddrs =
                             (ArchSegmentOff arch -> Bool)
-> [ArchSegmentOff arch] -> [ArchSegmentOff arch]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ArchSegmentOff arch
a -> ArchSegmentOff arch -> MemAddr (ArchAddrWidth arch)
forall (w :: Nat). MemSegmentOff w -> MemAddr w
segoffAddr ArchSegmentOff arch
a MemAddr (ArchAddrWidth arch)
-> MemAddr (ArchAddrWidth arch) -> Bool
forall a. Eq a => a -> a -> Bool
/= MemAddr (ArchAddrWidth arch)
blockEnd) ([ArchSegmentOff arch] -> [ArchSegmentOff arch])
-> [ArchSegmentOff arch] -> [ArchSegmentOff arch]
forall a b. (a -> b) -> a -> b
$
                             BlockClassifierContext arch ids -> [ArchSegmentOff arch]
forall arch ids.
BlockClassifierContext arch ids -> [ArchSegmentOff arch]
classifierWrittenAddrs BlockClassifierContext arch ids
bcc
                           , intraJumpTargets :: [IntraJumpTarget arch]
Parsed.intraJumpTargets = []
                           , newFunctionAddrs :: [ArchSegmentOff arch]
Parsed.newFunctionAddrs = Memory (ArchAddrWidth arch)
-> AbsProcessorState (ArchReg arch) ids
-> RegState (ArchReg arch) (Value arch ids)
-> [ArchSegmentOff arch]
forall arch ids.
RegisterInfo (ArchReg arch) =>
Memory (ArchAddrWidth arch)
-> AbsProcessorState (ArchReg arch) ids
-> RegState (ArchReg arch) (Value arch ids)
-> [ArchSegmentOff arch]
identifyCallTargets Memory (ArchAddrWidth arch)
mem AbsProcessorState (ArchReg arch) ids
absState RegState (ArchReg arch) (Value arch ids)
regs
                           }

-- | Attempt to recognize a call to a function that is known to not
-- return. These are effectively tail calls, even if the compiler did not
-- obviously generate a tail call instruction sequence.
--
-- This classifier is important because compilers often place garbage
-- instructions (for alignment, or possibly the next function) after calls to
-- no-return functions. Without knowledge of no-return functions, macaw would
-- otherwise think that the callee could return to the garbage instructions,
-- causing later classification failures.
--
-- This functionality depends on a set of known non-return functions are
-- specified as an input to the code discovery process (see 'pctxKnownFnEntries').
--
-- Note that this classifier should always be run before the 'callClassifier'.
noreturnCallClassifier :: BlockClassifier arch ids
noreturnCallClassifier :: forall arch ids. BlockClassifier arch ids
noreturnCallClassifier = String
-> BlockClassifierM arch ids (ParsedContents arch ids)
-> BlockClassifierM arch ids (ParsedContents arch ids)
forall arch ids a.
String
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids a
classifierName String
"No return call" (BlockClassifierM arch ids (ParsedContents arch ids)
 -> BlockClassifierM arch ids (ParsedContents arch ids))
-> BlockClassifierM arch ids (ParsedContents arch ids)
-> BlockClassifierM arch ids (ParsedContents arch ids)
forall a b. (a -> b) -> a -> b
$ do
  bcc <- BlockClassifierM arch ids (BlockClassifierContext arch ids)
forall r (m :: Type -> Type). MonadReader r m => m r
CMR.ask
  let ctx = BlockClassifierContext arch ids -> ParseContext arch ids
forall arch ids.
BlockClassifierContext arch ids -> ParseContext arch ids
classifierParseContext BlockClassifierContext arch ids
bcc
  -- Check for tail call when the calling convention seems to be satisfied.
  Info.withArchConstraints (pctxArchInfo ctx) $ do
    let regs = 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 ipVal = RegState (ArchReg arch) (Value arch ids)
regs 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
    -- Get memory address
    ma <-
      case valueAsMemAddr ipVal of
        Maybe (MemAddr (RegAddrWidth (ArchReg arch)))
Nothing ->  String
-> BlockClassifierM
     arch ids (MemAddr (RegAddrWidth (ArchReg arch)))
forall a. String -> BlockClassifierM arch ids a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
 -> BlockClassifierM
      arch ids (MemAddr (RegAddrWidth (ArchReg arch))))
-> String
-> BlockClassifierM
     arch ids (MemAddr (RegAddrWidth (ArchReg arch)))
forall a b. (a -> b) -> a -> b
$ String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Noreturn target %s is not a valid address." (Value arch ids (BVType (RegAddrWidth (ArchReg arch))) -> String
forall a. Show a => a -> String
show Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
ipVal)
        Just MemAddr (RegAddrWidth (ArchReg arch))
a -> MemAddr (RegAddrWidth (ArchReg arch))
-> BlockClassifierM
     arch ids (MemAddr (RegAddrWidth (ArchReg arch)))
forall a. a -> BlockClassifierM arch ids a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure MemAddr (RegAddrWidth (ArchReg arch))
a
    -- Get address
    a <- case asSegmentOff (pctxMemory ctx) ma of
           Maybe (MemSegmentOff (RegAddrWidth (ArchReg arch)))
Nothing ->
             String
-> BlockClassifierM
     arch ids (MemSegmentOff (RegAddrWidth (ArchReg arch)))
forall a. String -> BlockClassifierM arch ids a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
 -> BlockClassifierM
      arch ids (MemSegmentOff (RegAddrWidth (ArchReg arch))))
-> String
-> BlockClassifierM
     arch ids (MemSegmentOff (RegAddrWidth (ArchReg arch)))
forall a b. (a -> b) -> a -> b
$ String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Noreturn target %s is not a segment offset." (Value arch ids (BVType (RegAddrWidth (ArchReg arch))) -> String
forall a. Show a => a -> String
show Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
ipVal)
           Just MemSegmentOff (RegAddrWidth (ArchReg arch))
sa -> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> BlockClassifierM
     arch ids (MemSegmentOff (RegAddrWidth (ArchReg arch)))
forall a. a -> BlockClassifierM arch ids a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure MemSegmentOff (RegAddrWidth (ArchReg arch))
sa
    -- Check function labeled noreturn
    case Map.lookup a (pctxKnownFnEntries ctx) of
      Maybe NoReturnFunStatus
Nothing -> String -> BlockClassifierM arch ids ()
forall a. String -> BlockClassifierM arch ids a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> BlockClassifierM arch ids ())
-> String -> BlockClassifierM arch ids ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Noreturn target %s is not a known function entry." (MemSegmentOff (RegAddrWidth (ArchReg arch)) -> String
forall a. Show a => a -> String
show MemSegmentOff (RegAddrWidth (ArchReg arch))
a)
      Just NoReturnFunStatus
MayReturnFun -> String -> BlockClassifierM arch ids ()
forall a. String -> BlockClassifierM arch ids a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> BlockClassifierM arch ids ())
-> String -> BlockClassifierM arch ids ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Return target %s labeled mayreturn." (MemSegmentOff (RegAddrWidth (ArchReg arch)) -> String
forall a. Show a => a -> String
show MemSegmentOff (RegAddrWidth (ArchReg arch))
a)
      Just NoReturnFunStatus
NoReturnFun -> () -> BlockClassifierM arch ids ()
forall a. a -> BlockClassifierM arch ids a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
    -- Return no
    pure $! noreturnCallParsedContents bcc

-- | Attempt to recognize tail call
--
-- The current heuristic is that the target looks like a call, except the stack
-- height in the caller is 0.
--
-- Note that, in leaf functions (i.e., with no stack usage), tail calls and
-- jumps look substantially similar. We typically apply the jump classifier
-- first to prefer them, which means that we very rarely recognize tail calls in
-- leaf functions.
tailCallClassifier :: BlockClassifier arch ids
tailCallClassifier :: forall arch ids. BlockClassifier arch ids
tailCallClassifier = String
-> BlockClassifierM arch ids (ParsedContents arch ids)
-> BlockClassifierM arch ids (ParsedContents arch ids)
forall arch ids a.
String
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids a
classifierName String
"Tail call" (BlockClassifierM arch ids (ParsedContents arch ids)
 -> BlockClassifierM arch ids (ParsedContents arch ids))
-> BlockClassifierM arch ids (ParsedContents arch ids)
-> BlockClassifierM arch ids (ParsedContents arch ids)
forall a b. (a -> b) -> a -> b
$ do
  bcc <- BlockClassifierM arch ids (BlockClassifierContext arch ids)
forall r (m :: Type -> Type). MonadReader r m => m r
CMR.ask
  let ctx = BlockClassifierContext arch ids -> ParseContext arch ids
forall arch ids.
BlockClassifierContext arch ids -> ParseContext arch ids
classifierParseContext BlockClassifierContext arch ids
bcc
  let ainfo = ParseContext arch ids -> ArchitectureInfo arch
forall arch ids. ParseContext arch ids -> ArchitectureInfo arch
pctxArchInfo ParseContext arch ids
ctx
  -- Check for tail call when the calling convention seems to be satisfied.
  Info.withArchConstraints ainfo $ do

    let spVal = 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 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))
sp_reg
    -- Check to see if the stack pointer points to an offset of the initial stack.
    o <-
      case transferValue (classifierAbsState bcc) spVal of
        StackOffsetAbsVal MemAddr (RegAddrWidth (ArchReg arch))
_ Int64
o -> Int64 -> BlockClassifierM arch ids Int64
forall a. a -> BlockClassifierM arch ids a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Int64
o
        ArchAbsValue arch (BVType (RegAddrWidth (ArchReg arch)))
_ -> String -> BlockClassifierM arch ids Int64
forall a. String -> BlockClassifierM arch ids a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Not a stack offset"
    -- Stack stack is back to height when function was called.
    unless (o == 0) $
      fail "Expected stack height of 0"
    -- Return address is pushed
    unless (Info.checkForReturnAddr ainfo (classifierFinalRegState bcc) (classifierAbsState bcc)) empty
    pure $! noreturnCallParsedContents bcc