{-|
This defines the architecture-specific information needed for code discovery.
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Macaw.Architecture.Info
  ( ArchitectureInfo(..)
  , postCallAbsState
  , DisassembleFn
   -- * Block classification
  , BlockClassifier
  , BlockClassifierM
  , runBlockClassifier
  , BlockClassifierContext(..)
  , Classifier(..)
  , classifierName
  , liftClassifier
  , ParseContext(..)
  , NoReturnFunStatus(..)
    -- * Unclassified blocks
  , module Data.Macaw.CFG.Block
  , rewriteBlock
  ) where

import           Control.Applicative ( Alternative(..), liftA )
import           Control.Monad ( ap )
import qualified Control.Monad.Fail as MF
import qualified Control.Monad.Reader as CMR
import qualified Control.Monad.Trans as CMT
import           Control.Monad.ST ( ST )
import           Data.Map ( Map )
import           Data.Parameterized.Nonce
import           Data.Parameterized.TraversableF
import           Data.Sequence (Seq)
import qualified Prettyprinter as PP

import           Data.Macaw.AbsDomain.AbsState as AbsState
import qualified Data.Macaw.AbsDomain.JumpBounds as Jmp
import           Data.Macaw.CFG.Block
import           Data.Macaw.CFG.Core
import           Data.Macaw.CFG.DemandSet
import           Data.Macaw.CFG.Rewriter
import qualified Data.Macaw.Discovery.ParsedContents as Parsed
import           Data.Macaw.Memory


------------------------------------------------------------------------
-- NoReturnFunStatus

-- | Flags whether a function is labeled no return or not.
data NoReturnFunStatus
  = NoReturnFun
    -- ^ Function labeled no return
  | MayReturnFun
    -- ^ Function may retun
  deriving (Int -> NoReturnFunStatus -> ShowS
[NoReturnFunStatus] -> ShowS
NoReturnFunStatus -> String
(Int -> NoReturnFunStatus -> ShowS)
-> (NoReturnFunStatus -> String)
-> ([NoReturnFunStatus] -> ShowS)
-> Show NoReturnFunStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NoReturnFunStatus -> ShowS
showsPrec :: Int -> NoReturnFunStatus -> ShowS
$cshow :: NoReturnFunStatus -> String
show :: NoReturnFunStatus -> String
$cshowList :: [NoReturnFunStatus] -> ShowS
showList :: [NoReturnFunStatus] -> ShowS
Show)

instance PP.Pretty NoReturnFunStatus where
  pretty :: forall ann. NoReturnFunStatus -> Doc ann
pretty = NoReturnFunStatus -> Doc ann
forall a ann. Show a => a -> Doc ann
PP.viaShow

type ClassificationError = String

-- | The result of block classification, which collects information about all of
-- the match failures to help diagnose shortcomings in the analysis
data Classifier o = ClassifyFailed    [ClassificationError]
                  | ClassifySucceeded [ClassificationError] o

-- | In the given context, set the name of the current classifier
--
-- This is used to improve the labels for each classifier failure
classifierName :: String -> BlockClassifierM arch ids a -> BlockClassifierM arch ids a
classifierName :: forall arch ids a.
String
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids a
classifierName String
nm (BlockClassifier (CMR.ReaderT BlockClassifierContext arch ids -> Classifier a
m)) = ReaderT (BlockClassifierContext arch ids) Classifier a
-> BlockClassifierM arch ids a
forall arch ids a.
ReaderT (BlockClassifierContext arch ids) Classifier a
-> BlockClassifierM arch ids a
BlockClassifier (ReaderT (BlockClassifierContext arch ids) Classifier a
 -> BlockClassifierM arch ids a)
-> ReaderT (BlockClassifierContext arch ids) Classifier a
-> BlockClassifierM arch ids a
forall a b. (a -> b) -> a -> b
$ (BlockClassifierContext arch ids -> Classifier a)
-> ReaderT (BlockClassifierContext arch ids) Classifier a
forall r (m :: Type -> Type) a. (r -> m a) -> ReaderT r m a
CMR.ReaderT ((BlockClassifierContext arch ids -> Classifier a)
 -> ReaderT (BlockClassifierContext arch ids) Classifier a)
-> (BlockClassifierContext arch ids -> Classifier a)
-> ReaderT (BlockClassifierContext arch ids) Classifier a
forall a b. (a -> b) -> a -> b
$ \BlockClassifierContext arch ids
i ->
  case BlockClassifierContext arch ids -> Classifier a
m BlockClassifierContext arch ids
i of
    ClassifyFailed [] -> [String] -> Classifier a
forall o. [String] -> Classifier o
ClassifyFailed [String
nm String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" classification failed."]
    ClassifyFailed [String]
l  -> [String] -> Classifier a
forall o. [String] -> Classifier o
ClassifyFailed (ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String
nm String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": ") String -> ShowS
forall a. [a] -> [a] -> [a]
++)  [String]
l)
    ClassifySucceeded [String]
l a
a -> [String] -> a -> Classifier a
forall o. [String] -> o -> Classifier o
ClassifySucceeded (ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String
nm String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": ") String -> ShowS
forall a. [a] -> [a] -> [a]
++)  [String]
l) a
a

classifyFail :: Classifier a
classifyFail :: forall a. Classifier a
classifyFail = [String] -> Classifier a
forall o. [String] -> Classifier o
ClassifyFailed []

classifySuccess :: a -> Classifier a
classifySuccess :: forall a. a -> Classifier a
classifySuccess = \a
x -> [String] -> a -> Classifier a
forall o. [String] -> o -> Classifier o
ClassifySucceeded [] a
x

classifyBind :: Classifier a -> (a -> Classifier b) -> Classifier b
classifyBind :: forall a b. Classifier a -> (a -> Classifier b) -> Classifier b
classifyBind Classifier a
m a -> Classifier b
f =
  case Classifier a
m of
    ClassifyFailed [String]
e -> [String] -> Classifier b
forall o. [String] -> Classifier o
ClassifyFailed [String]
e
    ClassifySucceeded [] a
a -> a -> Classifier b
f a
a
    ClassifySucceeded [String]
l a
a ->
      case a -> Classifier b
f a
a of
        ClassifyFailed    [String]
e   -> [String] -> Classifier b
forall o. [String] -> Classifier o
ClassifyFailed    ([String]
l[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++[String]
e)
        ClassifySucceeded [String]
e b
b -> [String] -> b -> Classifier b
forall o. [String] -> o -> Classifier o
ClassifySucceeded ([String]
l[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++[String]
e) b
b

classifyAppend :: Classifier a -> Classifier a -> Classifier a
classifyAppend :: forall a. Classifier a -> Classifier a -> Classifier a
classifyAppend Classifier a
m Classifier a
n =
  case Classifier a
m of
    ClassifySucceeded [String]
e a
a -> [String] -> a -> Classifier a
forall o. [String] -> o -> Classifier o
ClassifySucceeded [String]
e a
a
    ClassifyFailed [] -> Classifier a
n
    ClassifyFailed [String]
e ->
      case Classifier a
n of
        ClassifySucceeded [String]
f a
a -> [String] -> a -> Classifier a
forall o. [String] -> o -> Classifier o
ClassifySucceeded ([String]
e[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++[String]
f) a
a
        ClassifyFailed [String]
f      -> [String] -> Classifier a
forall o. [String] -> Classifier o
ClassifyFailed    ([String]
e[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++[String]
f)

instance Alternative Classifier where
  empty :: forall a. Classifier a
empty = Classifier a
forall a. Classifier a
classifyFail
  <|> :: forall a. Classifier a -> Classifier a -> Classifier a
(<|>) = Classifier a -> Classifier a -> Classifier a
forall a. Classifier a -> Classifier a -> Classifier a
classifyAppend

instance Functor Classifier where
  fmap :: forall a b. (a -> b) -> Classifier a -> Classifier b
fmap = (a -> b) -> Classifier a -> Classifier b
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> b) -> f a -> f b
liftA

instance Applicative Classifier where
  pure :: forall a. a -> Classifier a
pure = a -> Classifier a
forall a. a -> Classifier a
classifySuccess
  <*> :: forall a b. Classifier (a -> b) -> Classifier a -> Classifier b
(<*>) = Classifier (a -> b) -> Classifier a -> Classifier b
forall (m :: Type -> Type) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad Classifier where
  >>= :: forall a b. Classifier a -> (a -> Classifier b) -> Classifier b
(>>=) = Classifier a -> (a -> Classifier b) -> Classifier b
forall a b. Classifier a -> (a -> Classifier b) -> Classifier b
classifyBind

instance MF.MonadFail Classifier where
  fail :: forall a. String -> Classifier a
fail = \String
m -> [String] -> Classifier a
forall o. [String] -> Classifier o
ClassifyFailed [String
m]

------------------------------------------------------------------------
-- ParseContext

-- | Information needed to parse the processor state
data ParseContext arch ids =
  ParseContext { forall arch ids.
ParseContext arch ids -> Memory (ArchAddrWidth arch)
pctxMemory         :: !(Memory (ArchAddrWidth arch))
               , forall arch ids. ParseContext arch ids -> ArchitectureInfo arch
pctxArchInfo       :: !(ArchitectureInfo arch)
               , forall arch ids.
ParseContext arch ids
-> Map (ArchSegmentOff arch) NoReturnFunStatus
pctxKnownFnEntries :: !(Map (ArchSegmentOff arch) NoReturnFunStatus)
                 -- ^ Entry addresses for known functions (e.g. from
                 -- symbol information)
                 --
                 -- The discovery process will not create
                 -- intra-procedural jumps to the entry points of new
                 -- functions.
               , forall arch ids. ParseContext arch ids -> ArchSegmentOff arch
pctxFunAddr        :: !(ArchSegmentOff arch)
                 -- ^ Address of function containing this block.
               , forall arch ids. ParseContext arch ids -> ArchSegmentOff arch
pctxAddr           :: !(ArchSegmentOff arch)
                 -- ^ Address of the current block
               , forall arch ids.
ParseContext arch ids
-> [(ArchSegmentOff arch, [ArchSegmentOff arch])]
pctxExtResolution :: [(ArchSegmentOff arch, [ArchSegmentOff arch])]
                 -- ^ Externally-provided resolutions for classification
                 -- failures, which are used in parseFetchAndExecute
               }

{-| The fields of the 'BlockClassifierContext' are:

  [@ParseContext ...@]: The context for the parse

  [@RegState ...@]: Initial register values

  [@Seq (Stmt ...)@]: The statements in the block

  [@AbsProcessorState ...@]: Abstract state of registers prior to
                             terminator statement being executed.

  [@Jmp.IntraJumpBounds ...@]: Bounds prior to terminator statement
                               being executed.

  [@ArchSegmentOff arch@]: Address of all segments written to memory

  [@RegState ...@]: Final register values
-}
data BlockClassifierContext arch ids = BlockClassifierContext
  { forall arch ids.
BlockClassifierContext arch ids -> ParseContext arch ids
classifierParseContext  :: !(ParseContext arch ids)
  -- ^ Information needed to construct abstract processor states
  , forall arch ids.
BlockClassifierContext arch ids
-> RegState (ArchReg arch) (Value arch ids)
classifierInitRegState  :: !(RegState (ArchReg arch) (Value arch ids))
  -- ^ The (concrete) register state at the beginning of the block
  , forall arch ids.
BlockClassifierContext arch ids -> Seq (Stmt arch ids)
classifierStmts         :: !(Seq (Stmt arch ids))
  -- ^ The statements of the block (without the terminator)
  , forall arch ids. BlockClassifierContext arch ids -> Int
classifierBlockSize     :: !Int
    -- ^ Size of block being classified.
  , forall arch ids.
BlockClassifierContext arch ids
-> AbsProcessorState (ArchReg arch) ids
classifierAbsState      :: !(AbsProcessorState (ArchReg arch) ids)
  -- ^ The abstract processor state before the terminator is executed
  , forall arch ids.
BlockClassifierContext arch ids -> IntraJumpBounds arch ids
classifierJumpBounds    :: !(Jmp.IntraJumpBounds arch ids)
  -- ^ The relational abstract processor state before the terminator is executed
  , forall arch ids.
BlockClassifierContext arch ids -> [ArchSegmentOff arch]
classifierWrittenAddrs  :: !([ArchSegmentOff arch])
  -- ^ The addresses of observed memory writes in the block
  , forall arch ids.
BlockClassifierContext arch ids
-> RegState (ArchReg arch) (Value arch ids)
classifierFinalRegState :: !(RegState (ArchReg arch) (Value arch ids))
  -- ^ The final (concrete) register state before the terminator is executed
  }

type BlockClassifier arch ids = BlockClassifierM arch ids (Parsed.ParsedContents arch ids)

-- | The underlying monad for the 'BlockClassifier', which handles collecting
-- matching errors
newtype BlockClassifierM arch ids a =
  BlockClassifier { forall arch ids a.
BlockClassifierM arch ids a
-> ReaderT (BlockClassifierContext arch ids) Classifier a
unBlockClassifier :: CMR.ReaderT (BlockClassifierContext arch ids)
                                                     Classifier
                                                     a
                  }
  deriving ( (forall a b.
 (a -> b)
 -> BlockClassifierM arch ids a -> BlockClassifierM arch ids b)
-> (forall a b.
    a -> BlockClassifierM arch ids b -> BlockClassifierM arch ids a)
-> Functor (BlockClassifierM arch ids)
forall a b.
a -> BlockClassifierM arch ids b -> BlockClassifierM arch ids a
forall a b.
(a -> b)
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids b
forall arch ids a b.
a -> BlockClassifierM arch ids b -> BlockClassifierM arch ids a
forall arch ids a b.
(a -> b)
-> BlockClassifierM arch ids a -> BlockClassifierM arch 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 ids a b.
(a -> b)
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids b
fmap :: forall a b.
(a -> b)
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids b
$c<$ :: forall arch ids a b.
a -> BlockClassifierM arch ids b -> BlockClassifierM arch ids a
<$ :: forall a b.
a -> BlockClassifierM arch ids b -> BlockClassifierM arch ids a
Functor
           , Functor (BlockClassifierM arch ids)
Functor (BlockClassifierM arch ids) =>
(forall a. a -> BlockClassifierM arch ids a)
-> (forall a b.
    BlockClassifierM arch ids (a -> b)
    -> BlockClassifierM arch ids a -> BlockClassifierM arch ids b)
-> (forall a b c.
    (a -> b -> c)
    -> BlockClassifierM arch ids a
    -> BlockClassifierM arch ids b
    -> BlockClassifierM arch ids c)
-> (forall a b.
    BlockClassifierM arch ids a
    -> BlockClassifierM arch ids b -> BlockClassifierM arch ids b)
-> (forall a b.
    BlockClassifierM arch ids a
    -> BlockClassifierM arch ids b -> BlockClassifierM arch ids a)
-> Applicative (BlockClassifierM arch ids)
forall a. a -> BlockClassifierM arch ids a
forall arch ids. Functor (BlockClassifierM arch ids)
forall a b.
BlockClassifierM arch ids a
-> BlockClassifierM arch ids b -> BlockClassifierM arch ids a
forall a b.
BlockClassifierM arch ids a
-> BlockClassifierM arch ids b -> BlockClassifierM arch ids b
forall a b.
BlockClassifierM arch ids (a -> b)
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids b
forall arch ids a. a -> BlockClassifierM arch ids a
forall a b c.
(a -> b -> c)
-> BlockClassifierM arch ids a
-> BlockClassifierM arch ids b
-> BlockClassifierM arch ids c
forall arch ids a b.
BlockClassifierM arch ids a
-> BlockClassifierM arch ids b -> BlockClassifierM arch ids a
forall arch ids a b.
BlockClassifierM arch ids a
-> BlockClassifierM arch ids b -> BlockClassifierM arch ids b
forall arch ids a b.
BlockClassifierM arch ids (a -> b)
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids b
forall arch ids a b c.
(a -> b -> c)
-> BlockClassifierM arch ids a
-> BlockClassifierM arch ids b
-> BlockClassifierM arch 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 ids a. a -> BlockClassifierM arch ids a
pure :: forall a. a -> BlockClassifierM arch ids a
$c<*> :: forall arch ids a b.
BlockClassifierM arch ids (a -> b)
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids b
<*> :: forall a b.
BlockClassifierM arch ids (a -> b)
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids b
$cliftA2 :: forall arch ids a b c.
(a -> b -> c)
-> BlockClassifierM arch ids a
-> BlockClassifierM arch ids b
-> BlockClassifierM arch ids c
liftA2 :: forall a b c.
(a -> b -> c)
-> BlockClassifierM arch ids a
-> BlockClassifierM arch ids b
-> BlockClassifierM arch ids c
$c*> :: forall arch ids a b.
BlockClassifierM arch ids a
-> BlockClassifierM arch ids b -> BlockClassifierM arch ids b
*> :: forall a b.
BlockClassifierM arch ids a
-> BlockClassifierM arch ids b -> BlockClassifierM arch ids b
$c<* :: forall arch ids a b.
BlockClassifierM arch ids a
-> BlockClassifierM arch ids b -> BlockClassifierM arch ids a
<* :: forall a b.
BlockClassifierM arch ids a
-> BlockClassifierM arch ids b -> BlockClassifierM arch ids a
Applicative
           , Applicative (BlockClassifierM arch ids)
Applicative (BlockClassifierM arch ids) =>
(forall a. BlockClassifierM arch ids a)
-> (forall a.
    BlockClassifierM arch ids a
    -> BlockClassifierM arch ids a -> BlockClassifierM arch ids a)
-> (forall a.
    BlockClassifierM arch ids a -> BlockClassifierM arch ids [a])
-> (forall a.
    BlockClassifierM arch ids a -> BlockClassifierM arch ids [a])
-> Alternative (BlockClassifierM arch ids)
forall a. BlockClassifierM arch ids a
forall a.
BlockClassifierM arch ids a -> BlockClassifierM arch ids [a]
forall a.
BlockClassifierM arch ids a
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids a
forall arch ids. Applicative (BlockClassifierM arch ids)
forall arch ids a. BlockClassifierM arch ids a
forall arch ids a.
BlockClassifierM arch ids a -> BlockClassifierM arch ids [a]
forall arch ids a.
BlockClassifierM arch ids a
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids a
forall (f :: Type -> Type).
Applicative f =>
(forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
$cempty :: forall arch ids a. BlockClassifierM arch ids a
empty :: forall a. BlockClassifierM arch ids a
$c<|> :: forall arch ids a.
BlockClassifierM arch ids a
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids a
<|> :: forall a.
BlockClassifierM arch ids a
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids a
$csome :: forall arch ids a.
BlockClassifierM arch ids a -> BlockClassifierM arch ids [a]
some :: forall a.
BlockClassifierM arch ids a -> BlockClassifierM arch ids [a]
$cmany :: forall arch ids a.
BlockClassifierM arch ids a -> BlockClassifierM arch ids [a]
many :: forall a.
BlockClassifierM arch ids a -> BlockClassifierM arch ids [a]
Alternative
           , Applicative (BlockClassifierM arch ids)
Applicative (BlockClassifierM arch ids) =>
(forall a b.
 BlockClassifierM arch ids a
 -> (a -> BlockClassifierM arch ids b)
 -> BlockClassifierM arch ids b)
-> (forall a b.
    BlockClassifierM arch ids a
    -> BlockClassifierM arch ids b -> BlockClassifierM arch ids b)
-> (forall a. a -> BlockClassifierM arch ids a)
-> Monad (BlockClassifierM arch ids)
forall a. a -> BlockClassifierM arch ids a
forall arch ids. Applicative (BlockClassifierM arch ids)
forall a b.
BlockClassifierM arch ids a
-> BlockClassifierM arch ids b -> BlockClassifierM arch ids b
forall a b.
BlockClassifierM arch ids a
-> (a -> BlockClassifierM arch ids b)
-> BlockClassifierM arch ids b
forall arch ids a. a -> BlockClassifierM arch ids a
forall arch ids a b.
BlockClassifierM arch ids a
-> BlockClassifierM arch ids b -> BlockClassifierM arch ids b
forall arch ids a b.
BlockClassifierM arch ids a
-> (a -> BlockClassifierM arch ids b)
-> BlockClassifierM arch 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 ids a b.
BlockClassifierM arch ids a
-> (a -> BlockClassifierM arch ids b)
-> BlockClassifierM arch ids b
>>= :: forall a b.
BlockClassifierM arch ids a
-> (a -> BlockClassifierM arch ids b)
-> BlockClassifierM arch ids b
$c>> :: forall arch ids a b.
BlockClassifierM arch ids a
-> BlockClassifierM arch ids b -> BlockClassifierM arch ids b
>> :: forall a b.
BlockClassifierM arch ids a
-> BlockClassifierM arch ids b -> BlockClassifierM arch ids b
$creturn :: forall arch ids a. a -> BlockClassifierM arch ids a
return :: forall a. a -> BlockClassifierM arch ids a
Monad
           , Monad (BlockClassifierM arch ids)
Monad (BlockClassifierM arch ids) =>
(forall a. String -> BlockClassifierM arch ids a)
-> MonadFail (BlockClassifierM arch ids)
forall a. String -> BlockClassifierM arch ids a
forall arch ids. Monad (BlockClassifierM arch ids)
forall arch ids a. String -> BlockClassifierM arch ids a
forall (m :: Type -> Type).
Monad m =>
(forall a. String -> m a) -> MonadFail m
$cfail :: forall arch ids a. String -> BlockClassifierM arch ids a
fail :: forall a. String -> BlockClassifierM arch ids a
MF.MonadFail
           , CMR.MonadReader (BlockClassifierContext arch ids)
           )

-- | Run a classifier in a given block context
runBlockClassifier
  :: BlockClassifier arch ids
  -> BlockClassifierContext arch ids
  -> Classifier (Parsed.ParsedContents arch ids)
runBlockClassifier :: forall arch ids.
BlockClassifier arch ids
-> BlockClassifierContext arch ids
-> Classifier (ParsedContents arch ids)
runBlockClassifier BlockClassifier arch ids
cl = ReaderT
  (BlockClassifierContext arch ids)
  Classifier
  (ParsedContents arch ids)
-> BlockClassifierContext arch ids
-> Classifier (ParsedContents arch ids)
forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
CMR.runReaderT (BlockClassifier arch ids
-> ReaderT
     (BlockClassifierContext arch ids)
     Classifier
     (ParsedContents arch ids)
forall arch ids a.
BlockClassifierM arch ids a
-> ReaderT (BlockClassifierContext arch ids) Classifier a
unBlockClassifier BlockClassifier arch ids
cl)

liftClassifier :: Classifier a -> BlockClassifierM arch ids a
liftClassifier :: forall a arch ids. Classifier a -> BlockClassifierM arch ids a
liftClassifier Classifier a
c = ReaderT (BlockClassifierContext arch ids) Classifier a
-> BlockClassifierM arch ids a
forall arch ids a.
ReaderT (BlockClassifierContext arch ids) Classifier a
-> BlockClassifierM arch ids a
BlockClassifier (Classifier a
-> ReaderT (BlockClassifierContext arch ids) Classifier a
forall (m :: Type -> Type) a.
Monad m =>
m a -> ReaderT (BlockClassifierContext arch ids) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
CMT.lift Classifier a
c)

------------------------------------------------------------------------
-- ArchitectureInfo

-- | Function for disassembling a range of code (usually a function in
-- the target code image) into blocks.
--
-- A block is defined as a contiguous region of code with a single known
-- entrance and potentially multiple exits.
--
-- This returns the list of blocks, the number of bytes in the blocks,
-- and any potential error that prematurely terminated translating the
-- block.
type DisassembleFn arch
   = forall s ids
   .  NonceGenerator (ST s) ids
   -> ArchSegmentOff arch
      -- ^ The offset to start reading from.
   -> RegState (ArchReg arch) (Value arch ids)
      -- ^ Initial values to use for registers.
   -> Int
      -- ^ Maximum offset for this to read from.
   -> ST s (Block arch ids, Int)

-- | This records architecture specific functions for analysis.
data ArchitectureInfo arch
   = ArchitectureInfo
     { forall arch.
ArchitectureInfo arch -> forall a. (ArchConstraints arch => a) -> a
withArchConstraints :: forall a . (ArchConstraints arch => a) -> a
       -- ^ Provides the architecture constraints to any computation
       -- that needs it.
     , forall arch.
ArchitectureInfo arch -> AddrWidthRepr (ArchAddrWidth arch)
archAddrWidth :: !(AddrWidthRepr (ArchAddrWidth arch))
       -- ^ Architecture address width.
     , forall arch. ArchitectureInfo arch -> Endianness
archEndianness :: !Endianness
       -- ^ The byte order values are stored in.
     , forall arch.
ArchitectureInfo arch
-> ArchSegmentOff arch
-> AbsBlockState (ArchReg arch)
-> Either String (ArchBlockPrecond arch)
extractBlockPrecond :: !(ArchSegmentOff arch
                                -> AbsBlockState (ArchReg arch)
                                -> Either String (ArchBlockPrecond arch))
       -- ^ Attempt to use abstract domain information to extract
       -- information needed to translate block.
     , forall arch.
ArchitectureInfo arch
-> forall ids.
   ArchSegmentOff arch
   -> ArchBlockPrecond arch
   -> RegState (ArchReg arch) (Value arch ids)
initialBlockRegs :: !(forall ids
                             .  ArchSegmentOff arch
                             -> ArchBlockPrecond arch
                             -> RegState (ArchReg arch) (Value arch ids))
       -- ^ Create initial registers from address and precondition.
     , forall arch. ArchitectureInfo arch -> DisassembleFn arch
disassembleFn :: !(DisassembleFn arch)
       -- ^ Function for disassembling a block.
     , forall arch.
ArchitectureInfo arch
-> Memory (ArchAddrWidth arch)
-> ArchSegmentOff arch
-> AbsBlockState (ArchReg arch)
mkInitialAbsState :: !(Memory (ArchAddrWidth arch)
                         -> ArchSegmentOff arch
                         -> AbsBlockState (ArchReg arch))
       -- ^ Creates an abstract block state for representing the beginning of a
       -- function.
       --
       -- The address is the entry point of the function.
     , forall arch.
ArchitectureInfo arch
-> forall ids (tp :: Type).
   AbsProcessorState (ArchReg arch) ids
   -> ArchFn arch (Value arch ids) tp
   -> AbsValue (ArchAddrWidth arch) tp
absEvalArchFn :: !(forall ids tp
                          .  AbsProcessorState (ArchReg arch) ids
                          -> ArchFn arch (Value arch ids) tp
                          -> AbsValue (ArchAddrWidth arch) tp)
       -- ^ Evaluates an architecture-specific function
     , forall arch.
ArchitectureInfo arch
-> forall ids.
   AbsProcessorState (ArchReg arch) ids
   -> ArchStmt arch (Value arch ids)
   -> AbsProcessorState (ArchReg arch) ids
absEvalArchStmt :: !(forall ids
                            .  AbsProcessorState (ArchReg arch) ids
                            -> ArchStmt arch (Value arch ids)
                            -> AbsProcessorState (ArchReg arch) ids)
       -- ^ Evaluates an architecture-specific statement
     , forall arch.
ArchitectureInfo arch
-> forall ids.
   Memory (ArchAddrWidth arch)
   -> Seq (Stmt arch ids)
   -> RegState (ArchReg arch) (Value arch ids)
   -> Maybe (Seq (Stmt arch ids), ArchSegmentOff arch)
identifyCall :: forall ids
                    .  Memory (ArchAddrWidth arch)
                    -> Seq (Stmt arch ids)
                    -> RegState (ArchReg arch) (Value arch ids)
                    -> Maybe (Seq (Stmt arch ids), ArchSegmentOff arch)
       -- ^ Function for recognizing call statements.
       --
       -- Given a memory state, list of statements, and final register
       -- state, the should determine if this is a call, and if so,
       -- return the statements with any action to push the return
       -- value to the stack removed, and provide the return address that
       -- the function should return to.
     , forall arch. ArchitectureInfo arch -> CallParams (ArchReg arch)
archCallParams :: !(CallParams (ArchReg arch))
       -- ^ Update the abstract state after a function call returns

     , forall arch.
ArchitectureInfo arch
-> forall ids.
   RegState (ArchReg arch) (Value arch ids)
   -> AbsProcessorState (ArchReg arch) ids -> Bool
checkForReturnAddr :: forall ids
                          .  RegState (ArchReg arch) (Value arch ids)
                          -> AbsProcessorState (ArchReg arch) ids
                          -> Bool
       -- ^ @checkForReturnAddr regs s@ returns true if the location
       -- where the return address is normally stored in regs when
       -- calling a function does indeed contain the abstract value
       -- associated with return addresses.
       --
       -- For x86 this checks if the address just above the stack is the
       -- return address.  For ARM, this should check the link register.
       --
       -- This predicate is invoked when considering if a potential tail call
       -- is setup to return to the right location.
     , forall arch.
ArchitectureInfo arch
-> forall ids.
   Seq (Stmt arch ids)
   -> RegState (ArchReg arch) (Value arch ids)
   -> AbsProcessorState (ArchReg arch) ids
   -> Maybe (Seq (Stmt arch ids))
identifyReturn :: forall ids
                      .  Seq (Stmt arch ids)
                      -> RegState (ArchReg arch) (Value arch ids)
                      -> AbsProcessorState (ArchReg arch) ids
                      -> Maybe (Seq (Stmt arch ids))
       -- ^ Identify returns to the classifier.
       --
       -- Given a list of statements and the final state of the registers, this
       -- should return 'Just stmts' if this code looks like a function return.
       -- The stmts should be a subset of the statements, but may remove unneeded memory
       -- accesses like reading the stack pointer.
     , 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 :: (forall s src tgt tp
                         .  ArchFn arch (Value arch src) tp
                         -> Rewriter arch s src tgt (Value arch tgt tp))
       -- ^ This rewrites an architecture specific statement
     , forall arch.
ArchitectureInfo arch
-> forall s src tgt.
   ArchStmt arch (Value arch src) -> Rewriter arch s src tgt ()
rewriteArchStmt :: (forall s src tgt
                           .  ArchStmt arch (Value arch src)
                           -> Rewriter arch s src tgt ())
       -- ^ This rewrites an architecture specific statement
     , forall arch.
ArchitectureInfo arch
-> forall s src tgt.
   ArchTermStmt arch (Value arch src)
   -> Rewriter arch s src tgt (ArchTermStmt arch (Value arch tgt))
rewriteArchTermStmt :: (forall s src tgt . ArchTermStmt arch (Value arch src)
                                             -> Rewriter arch s src tgt (ArchTermStmt arch (Value arch tgt)))
       -- ^ This rewrites an architecture specific statement
     , forall arch. ArchitectureInfo arch -> DemandContext arch
archDemandContext :: !(DemandContext arch)
       -- ^ Provides architecture-specific information for computing which arguments must be
       -- evaluated when evaluating a statement.
     , 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 :: !(forall ids
                                     .  Memory (ArchAddrWidth arch)
                                        -- The abstract state when block terminates.
                                     -> AbsProcessorState (ArchReg arch) ids
                                        -- The registers before executing terminal statement
                                     -> Jmp.IntraJumpBounds arch ids
                                     -> RegState (ArchReg arch) (Value arch ids)
                                        -- The architecture-specific statement
                                     -> ArchTermStmt arch (Value arch ids)
                                     -> Maybe (Jmp.IntraJumpTarget arch))
       -- ^ This takes an abstract state from before executing an abs
       -- state, and an architecture-specific terminal statement.
       --
       -- If the statement does not return to this function, this
       -- function should return `Nothing`.  Otherwise, it should
       -- returns the next address within the procedure that the
       -- statement jumps to along with the updated abstract state.
       --
       -- Note that per their documentation, architecture specific
       -- statements may return to at most one location within a
       -- function.
     , forall arch.
ArchitectureInfo arch -> forall ids. BlockClassifier arch ids
archClassifier :: !(forall ids . BlockClassifier arch ids)
     -- ^ The block classifier to use for this architecture, which can be
     -- customized
     }

postCallAbsState :: ArchitectureInfo arch
                 -> AbsProcessorState (ArchReg arch) ids
                 -- ^ Processor state at call.
                 -> RegState (ArchReg arch) (Value arch ids)
                 -- ^  Register values when call occurs.
                 -> ArchSegmentOff arch
                 -- ^ Return address
                 -> AbsBlockState (ArchReg arch)
postCallAbsState :: forall arch ids.
ArchitectureInfo arch
-> AbsProcessorState (ArchReg arch) ids
-> RegState (ArchReg arch) (Value arch ids)
-> ArchSegmentOff arch
-> AbsBlockState (ArchReg arch)
postCallAbsState 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 =>
  AbsProcessorState (ArchReg arch) ids
  -> RegState (ArchReg arch) (Value arch ids)
  -> ArchSegmentOff arch
  -> AbsBlockState (ArchReg arch))
 -> AbsProcessorState (ArchReg arch) ids
 -> RegState (ArchReg arch) (Value arch ids)
 -> ArchSegmentOff arch
 -> AbsBlockState (ArchReg arch))
-> (ArchConstraints arch =>
    AbsProcessorState (ArchReg arch) ids
    -> RegState (ArchReg arch) (Value arch ids)
    -> ArchSegmentOff arch
    -> AbsBlockState (ArchReg arch))
-> AbsProcessorState (ArchReg arch) ids
-> RegState (ArchReg arch) (Value arch ids)
-> ArchSegmentOff arch
-> AbsBlockState (ArchReg arch)
forall a b. (a -> b) -> a -> b
$
  CallParams (ArchReg arch)
-> AbsProcessorState (ArchReg arch) ids
-> RegState (ArchReg arch) (Value arch ids)
-> ArchSegmentOff arch
-> AbsBlockState (ArchReg arch)
forall arch ids.
RegisterInfo (ArchReg arch) =>
CallParams (ArchReg arch)
-> AbsProcessorState (ArchReg arch) ids
-> RegState (ArchReg arch) (Value arch ids)
-> ArchSegmentOff arch
-> AbsBlockState (ArchReg arch)
absEvalCall (ArchitectureInfo arch -> CallParams (ArchReg arch)
forall arch. ArchitectureInfo arch -> CallParams (ArchReg arch)
archCallParams ArchitectureInfo arch
ainfo)

-- | Apply optimizations to a terminal statement.
rewriteTermStmt :: ArchitectureInfo arch
                -> TermStmt arch src
                -> Rewriter arch s src tgt (TermStmt arch tgt)
rewriteTermStmt :: forall arch src s tgt.
ArchitectureInfo arch
-> TermStmt arch src -> Rewriter arch s src tgt (TermStmt arch tgt)
rewriteTermStmt ArchitectureInfo arch
info TermStmt arch src
tstmt = do
  case TermStmt arch src
tstmt of
    FetchAndExecute RegState (ArchReg arch) (Value arch src)
regs ->
      RegState (ArchReg arch) (Value arch tgt) -> TermStmt arch tgt
forall arch ids.
RegState (ArchReg arch) (Value arch ids) -> TermStmt arch ids
FetchAndExecute (RegState (ArchReg arch) (Value arch tgt) -> TermStmt arch tgt)
-> Rewriter
     arch s src tgt (RegState (ArchReg arch) (Value arch tgt))
-> Rewriter arch s src tgt (TermStmt arch tgt)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (s :: Type).
 Value arch src s -> Rewriter arch s src tgt (Value arch tgt s))
-> RegState (ArchReg arch) (Value arch src)
-> Rewriter
     arch s src tgt (RegState (ArchReg arch) (Value arch tgt))
forall {k} (t :: (k -> Type) -> Type) (m :: Type -> Type)
       (e :: k -> Type) (f :: k -> Type).
(TraversableF t, Applicative m) =>
(forall (s :: k). e s -> m (f s)) -> t e -> m (t f)
forall (m :: Type -> Type) (e :: Type -> Type) (f :: Type -> Type).
Applicative m =>
(forall (s :: Type). e s -> m (f s))
-> RegState (ArchReg arch) e -> m (RegState (ArchReg arch) f)
traverseF Value arch src s -> Rewriter arch s src tgt (Value arch tgt s)
forall arch src (tp :: Type) s tgt.
Value arch src tp -> Rewriter arch s src tgt (Value arch tgt tp)
forall (s :: Type).
Value arch src s -> Rewriter arch s src tgt (Value arch tgt s)
rewriteValue RegState (ArchReg arch) (Value arch src)
regs
    TranslateError RegState (ArchReg arch) (Value arch src)
regs Text
msg ->
      RegState (ArchReg arch) (Value arch tgt)
-> Text -> TermStmt arch tgt
forall arch ids.
RegState (ArchReg arch) (Value arch ids)
-> Text -> TermStmt arch ids
TranslateError (RegState (ArchReg arch) (Value arch tgt)
 -> Text -> TermStmt arch tgt)
-> Rewriter
     arch s src tgt (RegState (ArchReg arch) (Value arch tgt))
-> Rewriter arch s src tgt (Text -> TermStmt arch tgt)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (s :: Type).
 Value arch src s -> Rewriter arch s src tgt (Value arch tgt s))
-> RegState (ArchReg arch) (Value arch src)
-> Rewriter
     arch s src tgt (RegState (ArchReg arch) (Value arch tgt))
forall {k} (t :: (k -> Type) -> Type) (m :: Type -> Type)
       (e :: k -> Type) (f :: k -> Type).
(TraversableF t, Applicative m) =>
(forall (s :: k). e s -> m (f s)) -> t e -> m (t f)
forall (m :: Type -> Type) (e :: Type -> Type) (f :: Type -> Type).
Applicative m =>
(forall (s :: Type). e s -> m (f s))
-> RegState (ArchReg arch) e -> m (RegState (ArchReg arch) f)
traverseF Value arch src s -> Rewriter arch s src tgt (Value arch tgt s)
forall arch src (tp :: Type) s tgt.
Value arch src tp -> Rewriter arch s src tgt (Value arch tgt tp)
forall (s :: Type).
Value arch src s -> Rewriter arch s src tgt (Value arch tgt s)
rewriteValue RegState (ArchReg arch) (Value arch src)
regs
                     Rewriter arch s src tgt (Text -> TermStmt arch tgt)
-> Rewriter arch s src tgt Text
-> Rewriter arch s src tgt (TermStmt arch tgt)
forall a b.
Rewriter arch s src tgt (a -> b)
-> Rewriter arch s src tgt a -> Rewriter arch s src tgt b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Text -> Rewriter arch s src tgt Text
forall a. a -> Rewriter arch s src tgt a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Text
msg
    ArchTermStmt ArchTermStmt arch (Value arch src)
ts RegState (ArchReg arch) (Value arch src)
regs ->
      ArchTermStmt arch (Value arch tgt)
-> RegState (ArchReg arch) (Value arch tgt) -> TermStmt arch tgt
forall arch ids.
ArchTermStmt arch (Value arch ids)
-> RegState (ArchReg arch) (Value arch ids) -> TermStmt arch ids
ArchTermStmt (ArchTermStmt arch (Value arch tgt)
 -> RegState (ArchReg arch) (Value arch tgt) -> TermStmt arch tgt)
-> Rewriter arch s src tgt (ArchTermStmt arch (Value arch tgt))
-> Rewriter
     arch
     s
     src
     tgt
     (RegState (ArchReg arch) (Value arch tgt) -> TermStmt arch tgt)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ArchitectureInfo arch
-> forall s src tgt.
   ArchTermStmt arch (Value arch src)
   -> Rewriter arch s src tgt (ArchTermStmt arch (Value arch tgt))
forall arch.
ArchitectureInfo arch
-> forall s src tgt.
   ArchTermStmt arch (Value arch src)
   -> Rewriter arch s src tgt (ArchTermStmt arch (Value arch tgt))
rewriteArchTermStmt ArchitectureInfo arch
info ArchTermStmt arch (Value arch src)
ts
                   Rewriter
  arch
  s
  src
  tgt
  (RegState (ArchReg arch) (Value arch tgt) -> TermStmt arch tgt)
-> Rewriter
     arch s src tgt (RegState (ArchReg arch) (Value arch tgt))
-> Rewriter arch s src tgt (TermStmt arch tgt)
forall a b.
Rewriter arch s src tgt (a -> b)
-> Rewriter arch s src tgt a -> Rewriter arch s src tgt b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (forall (s :: Type).
 Value arch src s -> Rewriter arch s src tgt (Value arch tgt s))
-> RegState (ArchReg arch) (Value arch src)
-> Rewriter
     arch s src tgt (RegState (ArchReg arch) (Value arch tgt))
forall {k} (t :: (k -> Type) -> Type) (m :: Type -> Type)
       (e :: k -> Type) (f :: k -> Type).
(TraversableF t, Applicative m) =>
(forall (s :: k). e s -> m (f s)) -> t e -> m (t f)
forall (m :: Type -> Type) (e :: Type -> Type) (f :: Type -> Type).
Applicative m =>
(forall (s :: Type). e s -> m (f s))
-> RegState (ArchReg arch) e -> m (RegState (ArchReg arch) f)
traverseF Value arch src s -> Rewriter arch s src tgt (Value arch tgt s)
forall arch src (tp :: Type) s tgt.
Value arch src tp -> Rewriter arch s src tgt (Value arch tgt tp)
forall (s :: Type).
Value arch src s -> Rewriter arch s src tgt (Value arch tgt s)
rewriteValue RegState (ArchReg arch) (Value arch src)
regs

-- | Apply optimizations to code in the block
rewriteBlock :: ArchitectureInfo arch
             -> RewriteContext arch s src tgt
             -> Block arch src
             -> ST s (RewriteContext arch s src tgt, Block arch tgt)
rewriteBlock :: 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
info RewriteContext arch s src tgt
rwctx Block arch src
b = do
  (RewriteContext arch s src tgt
rwctx', [Stmt arch tgt]
tgtStmts, TermStmt arch tgt
tgtTermStmt) <- RewriteContext arch s src tgt
-> Rewriter arch s src tgt (TermStmt arch tgt)
-> ST
     s
     (RewriteContext arch s src tgt, [Stmt arch tgt], TermStmt arch tgt)
forall arch s src tgt.
RewriteContext arch s src tgt
-> Rewriter arch s src tgt (TermStmt arch tgt)
-> ST
     s
     (RewriteContext arch s src tgt, [Stmt arch tgt], TermStmt arch tgt)
runRewriter RewriteContext arch s src tgt
rwctx (Rewriter arch s src tgt (TermStmt arch tgt)
 -> ST
      s
      (RewriteContext arch s src tgt, [Stmt arch tgt],
       TermStmt arch tgt))
-> Rewriter arch s src tgt (TermStmt arch tgt)
-> ST
     s
     (RewriteContext arch s src tgt, [Stmt arch tgt], TermStmt arch tgt)
forall a b. (a -> b) -> a -> b
$ do
    (Stmt arch src -> Rewriter arch s src tgt ())
-> [Stmt arch src] -> Rewriter arch s src tgt ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Stmt arch src -> Rewriter arch s src tgt ()
forall arch src s tgt. Stmt arch src -> Rewriter arch s src tgt ()
rewriteStmt (Block arch src -> [Stmt arch src]
forall arch ids. Block arch ids -> [Stmt arch ids]
blockStmts Block arch src
b)
    ArchitectureInfo arch
-> TermStmt arch src -> Rewriter arch s src tgt (TermStmt arch tgt)
forall arch src s tgt.
ArchitectureInfo arch
-> TermStmt arch src -> Rewriter arch s src tgt (TermStmt arch tgt)
rewriteTermStmt ArchitectureInfo arch
info (Block arch src -> TermStmt arch src
forall arch ids. Block arch ids -> TermStmt arch ids
blockTerm Block arch src
b)
  -- Return rewritten block and any new blocks
  let rwBlock :: Block arch tgt
rwBlock = Block { blockStmts :: [Stmt arch tgt]
blockStmts = [Stmt arch tgt]
tgtStmts
                      , blockTerm :: TermStmt arch tgt
blockTerm  = TermStmt arch tgt
tgtTermStmt
                      }
  (RewriteContext arch s src tgt, Block arch tgt)
-> ST s (RewriteContext arch s src tgt, Block arch tgt)
forall a. a -> ST s a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (RewriteContext arch s src tgt
rwctx', Block arch tgt
rwBlock)