{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
-- | Macaw AST elements used after block classification
--
-- There are two stages of code discovery:
--
-- 1. Initial discovery with simple block terminators (unclassified block terminators like FetchAndExecute)
--
-- 2. Classified block terminators (e.g., branch, call, return, etc)
--
-- This module defines the AST elements for the latter case.
module Data.Macaw.Discovery.ParsedContents (
    ParsedTermStmt(..)
  , parsedTermSucc
  , ParsedBlock(..)
  , ParsedContents(..)
  , Extension(..)
  , BlockExploreReason(..)
  -- * JumpTableLayout
  , JumpTableLayout(..)
  , jtlBackingAddr
  , jtlBackingSize
  -- * BoundedMemArray
  , BoundedMemArray(..)
  , arByteCount
  , isReadOnlyBoundedMemArray
  -- * Pretty Printing
  , ppTermStmt
  ) where

import qualified Control.Lens as CL
import           Data.Maybe ( maybeToList )
import qualified Data.Parameterized.Map as MapF
import           Data.Text ( Text )
import qualified Data.Vector as V
import           Data.Word ( Word64 )
import qualified Prettyprinter as PP
import           Prettyprinter ( (<+>) )

import           Data.Macaw.AbsDomain.AbsState ( AbsBlockState )
import           Data.Macaw.CFG
import qualified Data.Macaw.AbsDomain.JumpBounds as Jmp
import qualified Data.Macaw.Memory.Permissions as Perm
import           Data.Macaw.Types

------------------------------------------------------------------------
-- BlockExploreReason

-- | This describes why we are exploring a given block within a function.
data BlockExploreReason w
   --   -- | Exploring because the given block writes it to memory.
   --  =- InWrite !(MemSegmentOff w)
     -- | Exploring because the given block jumps here.
   = NextIP !(MemSegmentOff w)
     -- | Identified as an entry point from initial information
   | FunctionEntryPoint
     -- | Added because the address split this block after it had been
     -- disassembled.  Also includes the reason we thought the block
     -- should be there before we split it.
   | SplitAt !(MemSegmentOff w) !(BlockExploreReason w)
     -- The user requested that we analyze this address as a function.
     -- UserRequest

  deriving (BlockExploreReason w -> BlockExploreReason w -> Bool
(BlockExploreReason w -> BlockExploreReason w -> Bool)
-> (BlockExploreReason w -> BlockExploreReason w -> Bool)
-> Eq (BlockExploreReason w)
forall (w :: Nat).
BlockExploreReason w -> BlockExploreReason w -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall (w :: Nat).
BlockExploreReason w -> BlockExploreReason w -> Bool
== :: BlockExploreReason w -> BlockExploreReason w -> Bool
$c/= :: forall (w :: Nat).
BlockExploreReason w -> BlockExploreReason w -> Bool
/= :: BlockExploreReason w -> BlockExploreReason w -> Bool
Eq, Int -> BlockExploreReason w -> ShowS
[BlockExploreReason w] -> ShowS
BlockExploreReason w -> String
(Int -> BlockExploreReason w -> ShowS)
-> (BlockExploreReason w -> String)
-> ([BlockExploreReason w] -> ShowS)
-> Show (BlockExploreReason w)
forall (w :: Nat).
MemWidth w =>
Int -> BlockExploreReason w -> ShowS
forall (w :: Nat). MemWidth w => [BlockExploreReason w] -> ShowS
forall (w :: Nat). MemWidth w => BlockExploreReason w -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall (w :: Nat).
MemWidth w =>
Int -> BlockExploreReason w -> ShowS
showsPrec :: Int -> BlockExploreReason w -> ShowS
$cshow :: forall (w :: Nat). MemWidth w => BlockExploreReason w -> String
show :: BlockExploreReason w -> String
$cshowList :: forall (w :: Nat). MemWidth w => [BlockExploreReason w] -> ShowS
showList :: [BlockExploreReason w] -> ShowS
Show)

instance MemWidth w => PP.Pretty (BlockExploreReason w) where
  pretty :: forall ann. BlockExploreReason w -> Doc ann
pretty (NextIP MemSegmentOff w
b) = Doc ann
"next address after block " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> MemSegmentOff w -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. MemSegmentOff w -> Doc ann
PP.pretty MemSegmentOff w
b
  pretty BlockExploreReason w
FunctionEntryPoint = Doc ann
"function entry point"
  pretty (SplitAt MemSegmentOff w
o BlockExploreReason w
prior) =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vcat
      [ Doc ann
"split at offset" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
PP.<+> MemSegmentOff w -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. MemSegmentOff w -> Doc ann
PP.pretty MemSegmentOff w
o Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
", previously reachable from:"
      , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
PP.indent Int
2 (BlockExploreReason w -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. BlockExploreReason w -> Doc ann
PP.pretty BlockExploreReason w
prior)
      ]

-------------------------------------------------------------------------------
-- BoundedMemArray

-- | This describes a region of memory dereferenced in some array read.
--
-- These regions may be be sparse, given an index @i@, the
-- the address given by @arBase@ + @arIx'*'arStride@.
data BoundedMemArray arch tp = BoundedMemArray
  { forall arch (tp :: Type).
BoundedMemArray arch tp -> ArchSegmentOff arch
arBase   :: !(ArchSegmentOff arch)
    -- ^ The base address for array accesses.
  , forall arch (tp :: Type). BoundedMemArray arch tp -> Word64
arStride :: !Word64
    -- ^ Space between elements of the array.
    --
    -- This will typically be the number of bytes denoted by `arEltType`,
    -- but may be larger for sparse arrays.  `matchBoundedMemArray` will fail
    -- if stride is less than the number of bytes read.
  , forall arch (tp :: Type). BoundedMemArray arch tp -> MemRepr tp
arEltType   :: !(MemRepr tp)
    -- ^ Resolved type of elements in this array.
  , forall arch (tp :: Type).
BoundedMemArray arch tp -> Vector [MemChunk (ArchAddrWidth arch)]
arSlices       :: !(V.Vector [MemChunk (ArchAddrWidth arch)])
    -- ^ The slices of memory in the array.
    --
    -- The `i`th element in the vector corresponds to the first `size`
    -- bytes at address `base + stride * i`.
    --
    -- The number of elements is the length of the array.
    --
    -- N.B.  With the size could be computed from the previous fields,
    -- but we check we can create it when creating the array read, so
    -- we store it to avoid recomputing it.
  }

deriving instance RegisterInfo (ArchReg arch) => Show (BoundedMemArray arch tp)

-- | Return number of bytes used by this array.
arByteCount :: BoundedMemArray arch tp -> Word64
arByteCount :: forall arch (tp :: Type). BoundedMemArray arch tp -> Word64
arByteCount BoundedMemArray arch tp
a = BoundedMemArray arch tp -> Word64
forall arch (tp :: Type). BoundedMemArray arch tp -> Word64
arStride BoundedMemArray arch tp
a Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Vector [MemChunk (RegAddrWidth (ArchReg arch))] -> Int
forall a. Vector a -> Int
V.length (BoundedMemArray arch tp
-> Vector [MemChunk (RegAddrWidth (ArchReg arch))]
forall arch (tp :: Type).
BoundedMemArray arch tp -> Vector [MemChunk (ArchAddrWidth arch)]
arSlices BoundedMemArray arch tp
a))

-- | Return true if the address stored is readable and not writable.
isReadOnlyBoundedMemArray :: BoundedMemArray arch  tp -> Bool
isReadOnlyBoundedMemArray :: forall arch (tp :: Type). BoundedMemArray arch tp -> Bool
isReadOnlyBoundedMemArray = Flags -> Bool
Perm.isReadonly (Flags -> Bool)
-> (BoundedMemArray arch tp -> Flags)
-> BoundedMemArray arch tp
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemSegment (RegAddrWidth (ArchReg arch)) -> Flags
forall (w :: Nat). MemSegment w -> Flags
segmentFlags (MemSegment (RegAddrWidth (ArchReg arch)) -> Flags)
-> (BoundedMemArray arch tp
    -> MemSegment (RegAddrWidth (ArchReg arch)))
-> BoundedMemArray arch tp
-> Flags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemSegmentOff (RegAddrWidth (ArchReg arch))
-> MemSegment (RegAddrWidth (ArchReg arch))
forall (w :: Nat). MemSegmentOff w -> MemSegment w
segoffSegment (MemSegmentOff (RegAddrWidth (ArchReg arch))
 -> MemSegment (RegAddrWidth (ArchReg arch)))
-> (BoundedMemArray arch tp
    -> MemSegmentOff (RegAddrWidth (ArchReg arch)))
-> BoundedMemArray arch tp
-> MemSegment (RegAddrWidth (ArchReg arch))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoundedMemArray arch tp
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
forall arch (tp :: Type).
BoundedMemArray arch tp -> ArchSegmentOff arch
arBase

------------------------------------------------------------------------
-- Extension

-- | Information about a value that is the signed or unsigned extension of another
-- value.
--
-- This is used for jump tables, and only supports widths that are in memory
data Extension w = Extension { forall (w :: Nat). Extension w -> Bool
_extIsSigned :: !Bool
                             , forall (w :: Nat). Extension w -> AddrWidthRepr w
_extWidth :: !(AddrWidthRepr w)
                               -- ^ Width of argument. is to.
                             }
  deriving (Int -> Extension w -> ShowS
[Extension w] -> ShowS
Extension w -> String
(Int -> Extension w -> ShowS)
-> (Extension w -> String)
-> ([Extension w] -> ShowS)
-> Show (Extension w)
forall (w :: Nat). Int -> Extension w -> ShowS
forall (w :: Nat). [Extension w] -> ShowS
forall (w :: Nat). Extension w -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall (w :: Nat). Int -> Extension w -> ShowS
showsPrec :: Int -> Extension w -> ShowS
$cshow :: forall (w :: Nat). Extension w -> String
show :: Extension w -> String
$cshowList :: forall (w :: Nat). [Extension w] -> ShowS
showList :: [Extension w] -> ShowS
Show)


------------------------------------------------------------------------
-- JumpTableLayout

-- | This describes the layout of a jump table.
-- Beware: on some architectures, after reading from the jump table, the
-- resulting addresses must be aligned. See the IPAlignment class.
data JumpTableLayout arch
  = AbsoluteJumpTable !(BoundedMemArray arch (BVType (ArchAddrWidth arch)))
  -- ^ @AbsoluteJumpTable r@ describes a jump table where the jump
  -- target is directly stored in the array read @r@.
  | forall w . RelativeJumpTable !(ArchSegmentOff arch)
                                 !(BoundedMemArray arch (BVType w))
                                 !(Extension w)
  -- ^ @RelativeJumpTable base read ext@ describes information about a
  -- jump table where all jump targets are relative to a fixed base
  -- address.
  --
  -- The value is computed as @baseVal + readVal@ where
  --
  -- @baseVal = fromMaybe 0 base@, @readVal@ is the value stored at
  -- the memory read described by @read@ with the sign of @ext@.

deriving instance RegisterInfo (ArchReg arch) => Show (JumpTableLayout arch)

-- | Return base address of table storing contents of jump table.
jtlBackingAddr :: JumpTableLayout arch ->  ArchSegmentOff arch
jtlBackingAddr :: forall arch. JumpTableLayout arch -> ArchSegmentOff arch
jtlBackingAddr (AbsoluteJumpTable BoundedMemArray arch (BVType (ArchAddrWidth arch))
a) = BoundedMemArray arch (BVType (ArchAddrWidth arch))
-> MemSegmentOff (ArchAddrWidth arch)
forall arch (tp :: Type).
BoundedMemArray arch tp -> ArchSegmentOff arch
arBase BoundedMemArray arch (BVType (ArchAddrWidth arch))
a
jtlBackingAddr (RelativeJumpTable MemSegmentOff (ArchAddrWidth arch)
_ BoundedMemArray arch (BVType w)
a Extension w
_) = BoundedMemArray arch (BVType w)
-> MemSegmentOff (ArchAddrWidth arch)
forall arch (tp :: Type).
BoundedMemArray arch tp -> ArchSegmentOff arch
arBase BoundedMemArray arch (BVType w)
a

-- | Returns the number of bytes in the layout
jtlBackingSize :: JumpTableLayout arch -> Word64
jtlBackingSize :: forall arch. JumpTableLayout arch -> Word64
jtlBackingSize (AbsoluteJumpTable BoundedMemArray arch (BVType (ArchAddrWidth arch))
a) = BoundedMemArray arch (BVType (ArchAddrWidth arch)) -> Word64
forall arch (tp :: Type). BoundedMemArray arch tp -> Word64
arByteCount BoundedMemArray arch (BVType (ArchAddrWidth arch))
a
jtlBackingSize (RelativeJumpTable ArchSegmentOff arch
_ BoundedMemArray arch (BVType w)
a Extension w
_) = BoundedMemArray arch (BVType w) -> Word64
forall arch (tp :: Type). BoundedMemArray arch tp -> Word64
arByteCount BoundedMemArray arch (BVType w)
a

------------------------------------------------------------------------
-- ParsedTermStmt

-- | This term statement is used to describe higher level expressions
-- of how block ending with a a FetchAndExecute statement should be
-- interpreted.
data ParsedTermStmt arch ids
  -- | A call with the current register values and location to return
  -- to or 'Nothing' if this is a tail call.
  --
  -- Note that the semantics of this instruction assume that the
  -- program has already stored the return address in the appropriate
  -- location (which depends on the ABI).  For example on X86_64 this
  -- is the top of the stack while on ARM this is the link register.
  = ParsedCall !(RegState (ArchReg arch) (Value arch ids))
               !(Maybe (ArchSegmentOff arch))
    -- | @PLTStub regs addr sym symVer@ denotes a terminal statement that
    -- has been identified as a PLT stub for jumping to the given symbol
    -- (with optional version information).
    --
    -- This is a special case of a tail call.  It has been added
    -- separately because it occurs frequently in dynamically linked
    -- code, and we can use this to recognize PLT stubs.
    --
    -- The first argument maps registers that were changed to their
    -- value.  Other registers have the initial value.  This should
    -- typically be empty on @X86_64@ PLT stubs.
    --
    -- The second argument is the address in the .GOT that the target
    -- function is stored at.  The PLT stub sets the PC to the address
    -- stored here.
    --
    -- The third and fourth arguments are used to resolve where the
    -- function should jump to.
  | PLTStub !(MapF.MapF (ArchReg arch) (Value arch ids))
            !(ArchSegmentOff arch)
            !VersionedSymbol
  -- | A jump to an explicit address within a function.
  | ParsedJump !(RegState (ArchReg arch) (Value arch ids)) !(ArchSegmentOff arch)
  -- | @ParsedBranch regs cond trueAddr falseAddr@ represents a conditional
  -- branch that jumps to @trueAddr@ if @cond@ is true and @falseAddr@ otherwise.
  --
  -- The value assigned to the IP in @regs@ should reflect this if-then-else
  -- structure.
  | ParsedBranch !(RegState (ArchReg arch) (Value arch ids))
                 !(Value arch ids BoolType)
                 !(ArchSegmentOff arch)
                 !(ArchSegmentOff arch)
  -- | A lookup table that branches to one of a vector of addresses.
  --
  -- The registers store the registers, the value contains the index to jump
  -- to, and the possible addresses as a table.  If the index (when interpreted as
  -- an unsigned number) is larger than the number of entries in the vector, then the
  -- result is undefined.
  | ParsedLookupTable !(JumpTableLayout arch)
                      !(RegState (ArchReg arch) (Value arch ids))
                      !(ArchAddrValue arch ids)
                      !(V.Vector (ArchSegmentOff arch))
  -- | A return with the given registers.
  | ParsedReturn !(RegState (ArchReg arch) (Value arch ids))
  -- | An architecture-specific statement with the registers prior to execution, and
  -- the given next control flow address.
  | ParsedArchTermStmt !(ArchTermStmt arch (Value arch ids))
                       !(RegState (ArchReg arch) (Value arch ids))
                       !(Maybe (ArchSegmentOff arch))
  -- | An error occured in translating the block
  | ParsedTranslateError !Text
  -- | The classifier failed to identity the block.
  -- Includes registers with list of reasons for each classifer to fail
  | ClassifyFailure !(RegState (ArchReg arch) (Value arch ids)) [String]

ppTermStmt :: ArchConstraints arch
           => ParsedTermStmt arch ids
           -> PP.Doc ann
ppTermStmt :: forall arch ids ann.
ArchConstraints arch =>
ParsedTermStmt arch ids -> Doc ann
ppTermStmt ParsedTermStmt arch ids
tstmt =
  case ParsedTermStmt arch ids
tstmt of
    ParsedCall RegState (ArchReg arch) (Value arch ids)
s Maybe (MemSegmentOff (RegAddrWidth (ArchReg arch)))
Nothing ->
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vcat
      [ Doc ann
"tail_call"
      , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
PP.indent Int
2 (RegState (ArchReg arch) (Value arch ids) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. RegState (ArchReg arch) (Value arch ids) -> Doc ann
PP.pretty RegState (ArchReg arch) (Value arch ids)
s) ]
    ParsedCall RegState (ArchReg arch) (Value arch ids)
s (Just MemSegmentOff (RegAddrWidth (ArchReg arch))
next) ->
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vcat
      [ Doc ann
"call and return to" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> MemSegmentOff (RegAddrWidth (ArchReg arch)) -> Doc ann
forall a ann. Show a => a -> Doc ann
PP.viaShow MemSegmentOff (RegAddrWidth (ArchReg arch))
next
      , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
PP.indent Int
2 (RegState (ArchReg arch) (Value arch ids) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. RegState (ArchReg arch) (Value arch ids) -> Doc ann
PP.pretty RegState (ArchReg arch) (Value arch ids)
s) ]
    PLTStub MapF (ArchReg arch) (Value arch ids)
regs MemSegmentOff (RegAddrWidth (ArchReg arch))
addr VersionedSymbol
sym ->
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vcat
      [ Doc ann
"call_via_got" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> VersionedSymbol -> Doc ann
forall a ann. Show a => a -> Doc ann
PP.viaShow VersionedSymbol
sym Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"(at" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> MemSegmentOff (RegAddrWidth (ArchReg arch)) -> Doc ann
forall a ann. Show a => a -> Doc ann
PP.viaShow MemSegmentOff (RegAddrWidth (ArchReg arch))
addr Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
PP.<> Doc ann
")"
      , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
PP.indent Int
2 (MapF (ArchReg arch) (Value arch ids) -> Doc ann
forall (r :: Type -> Type) (v :: Type -> Type) ann.
PrettyRegValue r v =>
MapF r v -> Doc ann
ppRegMap MapF (ArchReg arch) (Value arch ids)
regs) ]
    ParsedJump RegState (ArchReg arch) (Value arch ids)
s MemSegmentOff (RegAddrWidth (ArchReg arch))
addr ->
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vcat
      [ Doc ann
"jump" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> MemSegmentOff (RegAddrWidth (ArchReg arch)) -> Doc ann
forall a ann. Show a => a -> Doc ann
PP.viaShow MemSegmentOff (RegAddrWidth (ArchReg arch))
addr
      , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
PP.indent Int
2 (RegState (ArchReg arch) (Value arch ids) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. RegState (ArchReg arch) (Value arch ids) -> Doc ann
PP.pretty RegState (ArchReg arch) (Value arch ids)
s) ]
    ParsedBranch RegState (ArchReg arch) (Value arch ids)
r Value arch ids BoolType
c MemSegmentOff (RegAddrWidth (ArchReg arch))
t MemSegmentOff (RegAddrWidth (ArchReg arch))
f  ->
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vcat
      [ Doc ann
"branch" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Value arch ids BoolType -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Value arch ids BoolType -> Doc ann
PP.pretty Value arch ids BoolType
c Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> MemSegmentOff (RegAddrWidth (ArchReg arch)) -> Doc ann
forall a ann. Show a => a -> Doc ann
PP.viaShow MemSegmentOff (RegAddrWidth (ArchReg arch))
t Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> MemSegmentOff (RegAddrWidth (ArchReg arch)) -> Doc ann
forall a ann. Show a => a -> Doc ann
PP.viaShow MemSegmentOff (RegAddrWidth (ArchReg arch))
f
      , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
PP.indent Int
2 (RegState (ArchReg arch) (Value arch ids) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. RegState (ArchReg arch) (Value arch ids) -> Doc ann
PP.pretty RegState (ArchReg arch) (Value arch ids)
r) ]
    ParsedLookupTable JumpTableLayout arch
_layout RegState (ArchReg arch) (Value arch ids)
s BVValue arch ids (RegAddrWidth (ArchReg arch))
idx Vector (MemSegmentOff (RegAddrWidth (ArchReg arch)))
entries ->
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vcat
      [ Doc ann
"ijump" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> BVValue arch ids (RegAddrWidth (ArchReg arch)) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann.
BVValue arch ids (RegAddrWidth (ArchReg arch)) -> Doc ann
PP.pretty BVValue arch ids (RegAddrWidth (ArchReg arch))
idx
      , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
PP.indent Int
2 ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vcat ((Int -> MemSegmentOff (RegAddrWidth (ArchReg arch)) -> Doc ann)
-> [MemSegmentOff (RegAddrWidth (ArchReg arch))] -> [Doc ann]
forall a b. (Int -> a -> b) -> [a] -> [b]
forall i (f :: Type -> Type) a b.
FunctorWithIndex i f =>
(i -> a -> b) -> f a -> f b
CL.imap (\Int
i MemSegmentOff (RegAddrWidth (ArchReg arch))
v -> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty Int
i Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
":->" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> MemSegmentOff (RegAddrWidth (ArchReg arch)) -> Doc ann
forall a ann. Show a => a -> Doc ann
PP.viaShow MemSegmentOff (RegAddrWidth (ArchReg arch))
v)
                             (Vector (MemSegmentOff (RegAddrWidth (ArchReg arch)))
-> [MemSegmentOff (RegAddrWidth (ArchReg arch))]
forall a. Vector a -> [a]
V.toList Vector (MemSegmentOff (RegAddrWidth (ArchReg arch)))
entries)))
      , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
PP.indent Int
2 (RegState (ArchReg arch) (Value arch ids) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. RegState (ArchReg arch) (Value arch ids) -> Doc ann
PP.pretty RegState (ArchReg arch) (Value arch ids)
s) ]
    ParsedReturn RegState (ArchReg arch) (Value arch ids)
s ->
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vcat
      [ Doc ann
"return"
      , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
PP.indent Int
2 (RegState (ArchReg arch) (Value arch ids) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. RegState (ArchReg arch) (Value arch ids) -> Doc ann
PP.pretty RegState (ArchReg arch) (Value arch ids)
s) ]
    ParsedArchTermStmt ArchTermStmt arch (Value arch ids)
ts RegState (ArchReg arch) (Value arch ids)
s Maybe (MemSegmentOff (RegAddrWidth (ArchReg arch)))
maddr ->
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vcat
      [ (forall (u :: Type). Value arch ids u -> Doc ann)
-> ArchTermStmt arch (Value arch ids) -> Doc ann
forall (v :: Type -> Type) ann.
(forall (u :: Type). v u -> Doc ann)
-> ArchTermStmt arch v -> Doc ann
forall (f :: (Type -> Type) -> Type) (v :: Type -> Type) ann.
IsArchTermStmt f =>
(forall (u :: Type). v u -> Doc ann) -> f v -> Doc ann
ppArchTermStmt Value arch ids u -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Value arch ids u -> Doc ann
forall (u :: Type). Value arch ids u -> Doc ann
PP.pretty ArchTermStmt arch (Value arch ids)
ts Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
addrDoc
      , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
PP.indent Int
2 (RegState (ArchReg arch) (Value arch ids) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. RegState (ArchReg arch) (Value arch ids) -> Doc ann
PP.pretty RegState (ArchReg arch) (Value arch ids)
s) ]
      where
          addrDoc :: Doc ann
addrDoc = case Maybe (MemSegmentOff (RegAddrWidth (ArchReg arch)))
maddr of
                      Just MemSegmentOff (RegAddrWidth (ArchReg arch))
a -> Doc ann
", return to" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> MemSegmentOff (RegAddrWidth (ArchReg arch)) -> Doc ann
forall a ann. Show a => a -> Doc ann
PP.viaShow MemSegmentOff (RegAddrWidth (ArchReg arch))
a
                      Maybe (MemSegmentOff (RegAddrWidth (ArchReg arch)))
Nothing -> Doc ann
""
    ParsedTranslateError Text
msg ->
      Doc ann
"translation error" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Text -> Doc ann
PP.pretty Text
msg
    ClassifyFailure RegState (ArchReg arch) (Value arch ids)
s [String]
rsns ->
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vcat
      [ Doc ann
"classify failure"
      , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
PP.indent Int
2 (RegState (ArchReg arch) (Value arch ids) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. RegState (ArchReg arch) (Value arch ids) -> Doc ann
PP.pretty RegState (ArchReg arch) (Value arch ids)
s)
      , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
PP.indent Int
2 ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vcat (String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (String -> Doc ann) -> [String] -> [Doc ann]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
rsns)) ]

instance ArchConstraints arch => Show (ParsedTermStmt arch ids) where
  show :: ParsedTermStmt arch ids -> String
show = Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String)
-> (ParsedTermStmt arch ids -> Doc Any)
-> ParsedTermStmt arch ids
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedTermStmt arch ids -> Doc Any
forall arch ids ann.
ArchConstraints arch =>
ParsedTermStmt arch ids -> Doc ann
ppTermStmt

-- | Get all successor blocks for the given list of statements.
parsedTermSucc :: ParsedTermStmt arch ids -> [ArchSegmentOff arch]
parsedTermSucc :: forall arch ids. ParsedTermStmt arch ids -> [ArchSegmentOff arch]
parsedTermSucc ParsedTermStmt arch ids
ts = do
  case ParsedTermStmt arch ids
ts of
    ParsedCall RegState (ArchReg arch) (Value arch ids)
_ (Just ArchSegmentOff arch
ret_addr) -> [ArchSegmentOff arch
ret_addr]
    ParsedCall RegState (ArchReg arch) (Value arch ids)
_ Maybe (ArchSegmentOff arch)
Nothing -> []
    PLTStub{} -> []
    ParsedJump RegState (ArchReg arch) (Value arch ids)
_ ArchSegmentOff arch
tgt -> [ArchSegmentOff arch
tgt]
    ParsedBranch RegState (ArchReg arch) (Value arch ids)
_ Value arch ids BoolType
_ ArchSegmentOff arch
t ArchSegmentOff arch
f -> [ArchSegmentOff arch
t,ArchSegmentOff arch
f]
    ParsedLookupTable JumpTableLayout arch
_layout RegState (ArchReg arch) (Value arch ids)
_ ArchAddrValue arch ids
_ Vector (ArchSegmentOff arch)
v -> Vector (ArchSegmentOff arch) -> [ArchSegmentOff arch]
forall a. Vector a -> [a]
V.toList Vector (ArchSegmentOff arch)
v
    ParsedReturn{} -> []
    ParsedArchTermStmt ArchTermStmt arch (Value arch ids)
_ RegState (ArchReg arch) (Value arch ids)
_ Maybe (ArchSegmentOff arch)
ret -> Maybe (ArchSegmentOff arch) -> [ArchSegmentOff arch]
forall a. Maybe a -> [a]
maybeToList Maybe (ArchSegmentOff arch)
ret
    ParsedTranslateError{} -> []
    ClassifyFailure{} -> []

------------------------------------------------------------------------
-- ParsedBlock

-- | A contiguous region of instructions in memory.
data ParsedBlock arch ids
   = ParsedBlock { forall arch ids. ParsedBlock arch ids -> ArchSegmentOff arch
pblockAddr :: !(ArchSegmentOff arch)
                   -- ^ Address of region
                 , forall arch ids.
ParsedBlock arch ids -> Either String (ArchBlockPrecond arch)
pblockPrecond :: !(Either String (ArchBlockPrecond arch))
                   -- ^ Architecture-specificic information assumed to
                   -- be true when jumping to this block, or error why this
                   -- information could not be obtained.
                 , forall arch ids. ParsedBlock arch ids -> Int
blockSize :: !Int
                   -- ^ The size of the region of memory covered by this.
                 , forall arch ids.
ParsedBlock arch ids -> BlockExploreReason (ArchAddrWidth arch)
blockReason :: !(BlockExploreReason (ArchAddrWidth arch))
                   -- ^ Reason that we marked this address as
                   -- the start of a basic block.
                 , forall arch ids.
ParsedBlock arch ids -> AbsBlockState (ArchReg arch)
blockAbstractState :: !(AbsBlockState (ArchReg arch))
                   -- ^ Abstract state prior to the execution of
                   -- this region.
                 , forall arch ids. ParsedBlock arch ids -> InitJumpBounds arch
blockJumpBounds :: !(Jmp.InitJumpBounds arch)
                   -- ^ Structure for computing bounds on jump tables.
                 , forall arch ids. ParsedBlock arch ids -> [Stmt arch ids]
pblockStmts :: ![Stmt arch ids]
                     -- ^ The non-terminal statements in the block
                 , forall arch ids. ParsedBlock arch ids -> ParsedTermStmt arch ids
pblockTermStmt  :: !(ParsedTermStmt arch ids)
                   -- ^ The terminal statement in the block.
                 }

deriving instance (ArchConstraints arch, Show (ArchBlockPrecond arch))
  => Show (ParsedBlock arch ids)

instance ArchConstraints arch
      => PP.Pretty (ParsedBlock arch ids) where
  pretty :: forall ann. ParsedBlock arch ids -> Doc ann
pretty ParsedBlock arch ids
b =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vcat
    [ MemSegmentOff (RegAddrWidth (ArchReg arch)) -> Doc ann
forall a ann. Show a => a -> Doc ann
PP.viaShow (ParsedBlock arch ids -> MemSegmentOff (RegAddrWidth (ArchReg arch))
forall arch ids. ParsedBlock arch ids -> ArchSegmentOff arch
pblockAddr ParsedBlock arch ids
b) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
PP.<> Doc ann
":"
    , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
PP.indent Int
2 ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vcat ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (Doc ann
"; " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>) (Doc ann -> Doc ann) -> [Doc ann] -> [Doc ann]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> InitJumpBounds arch -> [Doc ann]
forall arch ann.
ShowF (ArchReg arch) =>
InitJumpBounds arch -> [Doc ann]
Jmp.ppInitJumpBounds (ParsedBlock arch ids -> InitJumpBounds arch
forall arch ids. ParsedBlock arch ids -> InitJumpBounds arch
blockJumpBounds ParsedBlock arch ids
b))
    , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
PP.indent Int
2 ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vcat [[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vcat ((MemWord (RegAddrWidth (ArchReg arch)) -> Doc ann)
-> Stmt arch ids -> Doc ann
forall arch ann ids.
ArchConstraints arch =>
(ArchAddrWord arch -> Doc ann) -> Stmt arch ids -> Doc ann
ppStmt MemWord (RegAddrWidth (ArchReg arch)) -> Doc ann
ppOff (Stmt arch ids -> Doc ann) -> [Stmt arch ids] -> [Doc ann]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsedBlock arch ids -> [Stmt arch ids]
forall arch ids. ParsedBlock arch ids -> [Stmt arch ids]
pblockStmts ParsedBlock arch ids
b), ParsedTermStmt arch ids -> Doc ann
forall arch ids ann.
ArchConstraints arch =>
ParsedTermStmt arch ids -> Doc ann
ppTermStmt (ParsedBlock arch ids -> ParsedTermStmt arch ids
forall arch ids. ParsedBlock arch ids -> ParsedTermStmt arch ids
pblockTermStmt ParsedBlock arch ids
b)])
    ]
    where ppOff :: MemWord (RegAddrWidth (ArchReg arch)) -> Doc ann
ppOff MemWord (RegAddrWidth (ArchReg arch))
o = MemAddr (RegAddrWidth (ArchReg arch)) -> Doc ann
forall a ann. Show a => a -> Doc ann
PP.viaShow (Integer
-> MemAddr (RegAddrWidth (ArchReg arch))
-> MemAddr (RegAddrWidth (ArchReg arch))
forall (w :: Nat). MemWidth w => Integer -> MemAddr w -> MemAddr w
incAddr (MemWord (RegAddrWidth (ArchReg arch)) -> Integer
forall a. Integral a => a -> Integer
toInteger MemWord (RegAddrWidth (ArchReg arch))
o) (MemSegmentOff (RegAddrWidth (ArchReg arch))
-> MemAddr (RegAddrWidth (ArchReg arch))
forall (w :: Nat). MemSegmentOff w -> MemAddr w
segoffAddr (ParsedBlock arch ids -> MemSegmentOff (RegAddrWidth (ArchReg arch))
forall arch ids. ParsedBlock arch ids -> ArchSegmentOff arch
pblockAddr ParsedBlock arch ids
b)))

-- | Stores the main block features that may changes from parsing a block.
data ParsedContents arch ids =
  ParsedContents { forall arch ids. ParsedContents arch ids -> [Stmt arch ids]
parsedNonterm :: ![Stmt arch ids]
                   -- ^ The non-terminal statements in the block
                 , forall arch ids. ParsedContents arch ids -> ParsedTermStmt arch ids
parsedTerm  :: !(ParsedTermStmt arch ids)
                   -- ^ The terminal statement in the block.
                 , forall arch ids. ParsedContents arch ids -> [ArchSegmentOff arch]
writtenCodeAddrs :: ![ArchSegmentOff arch]
                 -- ^ Addresses marked executable that were written to memory.
                 , forall arch ids. ParsedContents arch ids -> [IntraJumpTarget arch]
intraJumpTargets :: ![Jmp.IntraJumpTarget arch]
                 , forall arch ids. ParsedContents arch ids -> [ArchSegmentOff arch]
newFunctionAddrs :: ![ArchSegmentOff arch]
                   -- ^ List of candidate functions found when parsing block.
                   --
                   -- Note. In a binary, these could denote the non-executable
                   -- segments, so they are filtered before traversing.
                 }