{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeApplications #-}
module Data.Macaw.Discovery.Classifier.JumpTable (
  jumpTableClassifier
  ) where

import           Control.Applicative ( Alternative((<|>)) )
import           Control.Lens ( (&), (^.) )
import           Control.Monad ( when, unless )
import qualified Control.Monad.Reader as CMR
import qualified Data.ByteString as BS
import qualified Data.Foldable as F
import           Data.Int ( Int32, Int64 )
import qualified Data.Map.Strict as Map
import           Data.Parameterized.Classes
import           Data.Parameterized.NatRepr
import           Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Traversable as T
import qualified Data.Vector as V
import           Data.Word ( Word64 )
import           Numeric ( showHex )
import           Numeric.Natural ( Natural )
import qualified Prettyprinter as PP

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

--------------------------------------------------------------------------------
-- Jump table recognition

-- | `extendDyn ext end bs` parses the bytestring using the extension
-- and endianness information, and returns the extended value.
extendDyn :: Parsed.Extension w -> Endianness -> BS.ByteString -> Integer
extendDyn :: forall (w :: Natural).
Extension w -> Endianness -> ByteString -> Integer
extendDyn (Parsed.Extension Bool
False AddrWidthRepr w
Addr32) Endianness
end ByteString
bs  = Word32 -> Integer
forall a. Integral a => a -> Integer
toInteger (Endianness -> ByteString -> Word32
bsWord32 Endianness
end ByteString
bs)
extendDyn (Parsed.Extension Bool
False AddrWidthRepr w
Addr64) Endianness
end ByteString
bs  = Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Endianness -> ByteString -> Word64
bsWord64 Endianness
end ByteString
bs)
extendDyn (Parsed.Extension Bool
True  AddrWidthRepr w
Addr32) Endianness
end ByteString
bs = Int32 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Endianness -> ByteString -> Word32
bsWord32 Endianness
end ByteString
bs) :: Int32)
extendDyn (Parsed.Extension Bool
True  AddrWidthRepr w
Addr64) Endianness
end ByteString
bs = Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Endianness -> ByteString -> Word64
bsWord64 Endianness
end ByteString
bs) :: Int64)

-- This function resolves jump table entries.
-- It is a recursive function that has an index into the jump table.
-- If the current index can be interpreted as a intra-procedural jump,
-- then it will add that to the current procedure.
-- This returns the last address read.
resolveRelativeJumps :: forall arch w
                        .  ( MemWidth (ArchAddrWidth arch)
                        , IPAlignment arch
                        , RegisterInfo (ArchReg arch)
                        )
                     => Memory (ArchAddrWidth arch)
                     -> ArchSegmentOff arch
                     -> Parsed.BoundedMemArray arch (BVType w)
                     -> Parsed.Extension w
                     -> Either String (V.Vector (ArchSegmentOff arch))
resolveRelativeJumps :: forall arch (w :: Natural).
(MemWidth (ArchAddrWidth arch), IPAlignment arch,
 RegisterInfo (ArchReg arch)) =>
Memory (ArchAddrWidth arch)
-> ArchSegmentOff arch
-> BoundedMemArray arch (BVType w)
-> Extension w
-> Either String (Vector (ArchSegmentOff arch))
resolveRelativeJumps Memory (ArchAddrWidth arch)
mem MemSegmentOff (ArchAddrWidth arch)
base BoundedMemArray arch (BVType w)
arrayRead Extension w
ext = do
  let slices :: Vector [MemChunk (ArchAddrWidth arch)]
slices = BoundedMemArray arch (BVType w)
-> Vector [MemChunk (ArchAddrWidth arch)]
forall arch (tp :: Type).
BoundedMemArray arch tp -> Vector [MemChunk (ArchAddrWidth arch)]
Parsed.arSlices BoundedMemArray arch (BVType w)
arrayRead
  let BVMemRepr NatRepr w
_ Endianness
endianness = BoundedMemArray arch (BVType w) -> MemRepr (BVType w)
forall arch (tp :: Type). BoundedMemArray arch tp -> MemRepr tp
Parsed.arEltType BoundedMemArray arch (BVType w)
arrayRead
  Vector [MemChunk (ArchAddrWidth arch)]
-> ([MemChunk (ArchAddrWidth arch)]
    -> Either String (MemSegmentOff (ArchAddrWidth arch)))
-> Either String (Vector (MemSegmentOff (ArchAddrWidth arch)))
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
T.forM Vector [MemChunk (ArchAddrWidth arch)]
slices (([MemChunk (ArchAddrWidth arch)]
  -> Either String (MemSegmentOff (ArchAddrWidth arch)))
 -> Either String (Vector (MemSegmentOff (ArchAddrWidth arch))))
-> ([MemChunk (ArchAddrWidth arch)]
    -> Either String (MemSegmentOff (ArchAddrWidth arch)))
-> Either String (Vector (MemSegmentOff (ArchAddrWidth arch)))
forall a b. (a -> b) -> a -> b
$ \[MemChunk (ArchAddrWidth arch)]
l -> do
    ByteString
bs <- case [MemChunk (ArchAddrWidth arch)]
l of
            [ByteRegion ByteString
bs] -> ByteString -> Either String ByteString
forall a b. b -> Either a b
Right ByteString
bs
            [MemChunk (ArchAddrWidth arch)]
_ -> String -> Either String ByteString
forall a b. a -> Either a b
Left (String -> Either String ByteString)
-> String -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ String
"Could not recognize slice: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [MemChunk (ArchAddrWidth arch)] -> String
forall a. Show a => a -> String
show [MemChunk (ArchAddrWidth arch)]
l
    let tgtAddr :: MemAddr (ArchAddrWidth arch)
tgtAddr = MemSegmentOff (ArchAddrWidth arch) -> MemAddr (ArchAddrWidth arch)
forall (w :: Natural). MemSegmentOff w -> MemAddr w
segoffAddr MemSegmentOff (ArchAddrWidth arch)
base MemAddr (ArchAddrWidth arch)
-> (MemAddr (ArchAddrWidth arch) -> MemAddr (ArchAddrWidth arch))
-> MemAddr (ArchAddrWidth arch)
forall a b. a -> (a -> b) -> b
& Integer
-> MemAddr (ArchAddrWidth arch) -> MemAddr (ArchAddrWidth arch)
forall (w :: Natural).
MemWidth w =>
Integer -> MemAddr w -> MemAddr w
incAddr (Extension w -> Endianness -> ByteString -> Integer
forall (w :: Natural).
Extension w -> Endianness -> ByteString -> Integer
extendDyn Extension w
ext Endianness
endianness ByteString
bs)

    let brRepr :: String
brRepr = [String] -> String
unwords [ Word8 -> String -> String
forall a. Integral a => a -> String -> String
showHex Word8
w String
"" | Word8
w <- ByteString -> [Word8]
BS.unpack ByteString
bs ]

    MemSegmentOff (ArchAddrWidth arch)
tgt <- case Memory (ArchAddrWidth arch)
-> MemAddr (ArchAddrWidth arch)
-> Maybe (MemSegmentOff (ArchAddrWidth arch))
forall (w :: Natural).
Memory w -> MemAddr w -> Maybe (MemSegmentOff w)
asSegmentOff Memory (ArchAddrWidth arch)
mem (forall arch.
IPAlignment arch =>
MemAddr (ArchAddrWidth arch) -> MemAddr (ArchAddrWidth arch)
toIPAligned @arch MemAddr (ArchAddrWidth arch)
tgtAddr) of
             Just MemSegmentOff (ArchAddrWidth arch)
tgt -> MemSegmentOff (ArchAddrWidth arch)
-> Either String (MemSegmentOff (ArchAddrWidth arch))
forall a b. b -> Either a b
Right MemSegmentOff (ArchAddrWidth arch)
tgt
             Maybe (MemSegmentOff (ArchAddrWidth arch))
_ -> String -> Either String (MemSegmentOff (ArchAddrWidth arch))
forall a b. a -> Either a b
Left (String -> Either String (MemSegmentOff (ArchAddrWidth arch)))
-> String -> Either String (MemSegmentOff (ArchAddrWidth arch))
forall a b. (a -> b) -> a -> b
$ String
"Could not resolve " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Extension w, Endianness, MemSegmentOff (ArchAddrWidth arch),
 String)
-> String
forall a. Show a => a -> String
show (Extension w
ext, Endianness
endianness, MemSegmentOff (ArchAddrWidth arch)
base, String
brRepr)

    Bool -> Either String () -> Either String ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (Flags -> Bool
Perm.isExecutable (MemSegment (ArchAddrWidth arch) -> Flags
forall (w :: Natural). MemSegment w -> Flags
segmentFlags (MemSegmentOff (ArchAddrWidth arch)
-> MemSegment (ArchAddrWidth arch)
forall (w :: Natural). MemSegmentOff w -> MemSegment w
segoffSegment MemSegmentOff (ArchAddrWidth arch)
tgt))) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$ do
      String -> Either String ()
forall a b. a -> Either a b
Left String
"Address is not executable."

    MemSegmentOff (ArchAddrWidth arch)
-> Either String (MemSegmentOff (ArchAddrWidth arch))
forall a b. b -> Either a b
Right MemSegmentOff (ArchAddrWidth arch)
tgt

sliceMemContents'
  :: MemWidth w
  => Int -- ^ Number of bytes in each slice.
  -> [[MemChunk w]] -- ^ Previous slices
  -> Integer -- ^ Number of slices to return
  -> [MemChunk w] -- ^ Ranges to process next
  -> Either (SplitError w) ([[MemChunk w]],[MemChunk w])
sliceMemContents' :: forall (w :: Natural).
MemWidth w =>
Int
-> [[MemChunk w]]
-> Integer
-> [MemChunk w]
-> Either (SplitError w) ([[MemChunk w]], [MemChunk w])
sliceMemContents' Int
stride [[MemChunk w]]
prev Integer
c [MemChunk w]
next
  | Integer
c Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0 = ([[MemChunk w]], [MemChunk w])
-> Either (SplitError w) ([[MemChunk w]], [MemChunk w])
forall a. a -> Either (SplitError w) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([[MemChunk w]] -> [[MemChunk w]]
forall a. [a] -> [a]
reverse [[MemChunk w]]
prev, [MemChunk w]
next)
  | Bool
otherwise =
    case [MemChunk w]
-> Int -> Either (SplitError w) ([MemChunk w], [MemChunk w])
forall (w :: Natural).
MemWidth w =>
[MemChunk w]
-> Int -> Either (SplitError w) ([MemChunk w], [MemChunk w])
splitMemChunks [MemChunk w]
next Int
stride of
      Left SplitError w
e -> SplitError w
-> Either (SplitError w) ([[MemChunk w]], [MemChunk w])
forall a b. a -> Either a b
Left SplitError w
e
      Right ([MemChunk w]
this, [MemChunk w]
rest) -> Int
-> [[MemChunk w]]
-> Integer
-> [MemChunk w]
-> Either (SplitError w) ([[MemChunk w]], [MemChunk w])
forall (w :: Natural).
MemWidth w =>
Int
-> [[MemChunk w]]
-> Integer
-> [MemChunk w]
-> Either (SplitError w) ([[MemChunk w]], [MemChunk w])
sliceMemContents' Int
stride ([MemChunk w]
this[MemChunk w] -> [[MemChunk w]] -> [[MemChunk w]]
forall a. a -> [a] -> [a]
:[[MemChunk w]]
prev) (Integer
cInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1) [MemChunk w]
rest

-- | @sliceMemContents stride cnt contents@ splits contents up into @cnt@
-- memory regions each with size @stride@.
sliceMemContents
  :: MemWidth w
  => Int -- ^ Number of bytes in each slice.
  -> Integer -- ^ Number of slices to return
  -> [MemChunk w] -- ^ Ranges to process next
  -> Either (SplitError w) ([[MemChunk w]],[MemChunk w])
sliceMemContents :: forall (w :: Natural).
MemWidth w =>
Int
-> Integer
-> [MemChunk w]
-> Either (SplitError w) ([[MemChunk w]], [MemChunk w])
sliceMemContents Int
stride Integer
c [MemChunk w]
next = Int
-> [[MemChunk w]]
-> Integer
-> [MemChunk w]
-> Either (SplitError w) ([[MemChunk w]], [MemChunk w])
forall (w :: Natural).
MemWidth w =>
Int
-> [[MemChunk w]]
-> Integer
-> [MemChunk w]
-> Either (SplitError w) ([[MemChunk w]], [MemChunk w])
sliceMemContents' Int
stride [] Integer
c [MemChunk w]
next

-------------------------------------------------------------------------------
-- BoundedMemArray recognition

absValueAsSegmentOff
  :: forall w
  .  Memory w
  -> AbsValue w (BVType  w)
  -> Maybe (MemSegmentOff w)
absValueAsSegmentOff :: forall (w :: Natural).
Memory w -> AbsValue w (BVType w) -> Maybe (MemSegmentOff w)
absValueAsSegmentOff Memory w
mem AbsValue w (BVType w)
av = case AbsValue w (BVType w)
av of
  FinSet Set Integer
s | Set Integer -> Int
forall a. Set a -> Int
Set.size Set Integer
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> Integer -> Maybe (MemSegmentOff w)
resolveAbsoluteIntegerAddr (Set Integer -> Integer
forall a. Set a -> a
shead Set Integer
s)
  CodePointers Set (MemSegmentOff w)
s Bool
False | Set (MemSegmentOff w) -> Int
forall a. Set a -> Int
Set.size Set (MemSegmentOff w)
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> MemSegmentOff w -> Maybe (MemSegmentOff w)
forall a. a -> Maybe a
Just (Set (MemSegmentOff w) -> MemSegmentOff w
forall a. Set a -> a
shead Set (MemSegmentOff w)
s)
  CodePointers Set (MemSegmentOff w)
s Bool
True  | Set (MemSegmentOff w) -> Int
forall a. Set a -> Int
Set.size Set (MemSegmentOff w)
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> Integer -> Maybe (MemSegmentOff w)
resolveAbsoluteIntegerAddr Integer
0
  StridedInterval StridedInterval n
si -> StridedInterval n -> Maybe Integer
forall (w :: Natural). StridedInterval w -> Maybe Integer
SI.isSingleton StridedInterval n
si Maybe Integer
-> (Integer -> Maybe (MemSegmentOff w)) -> Maybe (MemSegmentOff w)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= Integer -> Maybe (MemSegmentOff w)
resolveAbsoluteIntegerAddr
  AbsValue w (BVType w)
_ -> Maybe (MemSegmentOff w)
forall a. Maybe a
Nothing
  where
  shead :: Set a -> a
  shead :: forall a. Set a -> a
shead = Set a -> a
forall a. Set a -> a
Set.findMin

  resolveAbsoluteIntegerAddr :: Integer -> Maybe (MemSegmentOff w)
  resolveAbsoluteIntegerAddr :: Integer -> Maybe (MemSegmentOff w)
resolveAbsoluteIntegerAddr = Memory w -> MemWord w -> Maybe (MemSegmentOff w)
forall (w :: Natural).
Memory w -> MemWord w -> Maybe (MemSegmentOff w)
resolveAbsoluteAddr Memory w
mem (MemWord w -> Maybe (MemSegmentOff w))
-> (Integer -> MemWord w) -> Integer -> Maybe (MemSegmentOff w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AddrWidthRepr w
-> (MemWidth w => Integer -> MemWord w) -> Integer -> MemWord w
forall (w :: Natural) a. AddrWidthRepr w -> (MemWidth w => a) -> a
addrWidthClass (Memory w -> AddrWidthRepr w
forall (w :: Natural). Memory w -> AddrWidthRepr w
memAddrWidth Memory w
mem) Integer -> MemWord w
MemWidth w => Integer -> MemWord w
forall a. Num a => Integer -> a
fromInteger

-- | This attempts to interpret a value as a memory segment offset
-- using the memory and abstract interpretation of value.
valueAsSegmentOffWithTransfer
  :: forall arch ids
  .  RegisterInfo (ArchReg arch)
  => Memory (ArchAddrWidth arch)
  -> AbsProcessorState (ArchReg arch) ids
  -> BVValue arch ids (ArchAddrWidth arch)
  -> Maybe (ArchSegmentOff arch)
valueAsSegmentOffWithTransfer :: forall arch ids.
RegisterInfo (ArchReg arch) =>
Memory (ArchAddrWidth arch)
-> AbsProcessorState (ArchReg arch) ids
-> BVValue arch ids (ArchAddrWidth arch)
-> Maybe (ArchSegmentOff arch)
valueAsSegmentOffWithTransfer Memory (ArchAddrWidth arch)
mem AbsProcessorState (ArchReg arch) ids
aps BVValue arch ids (ArchAddrWidth arch)
base
  =   Memory (ArchAddrWidth arch)
-> BVValue arch ids (ArchAddrWidth arch)
-> Maybe (MemSegmentOff (ArchAddrWidth arch))
forall arch ids.
Memory (ArchAddrWidth arch)
-> BVValue arch ids (ArchAddrWidth arch)
-> Maybe (ArchSegmentOff arch)
valueAsSegmentOff Memory (ArchAddrWidth arch)
mem BVValue arch ids (ArchAddrWidth arch)
base
  Maybe (MemSegmentOff (ArchAddrWidth arch))
-> Maybe (MemSegmentOff (ArchAddrWidth arch))
-> Maybe (MemSegmentOff (ArchAddrWidth arch))
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> Memory (ArchAddrWidth arch)
-> AbsValue (ArchAddrWidth arch) (BVType (ArchAddrWidth arch))
-> Maybe (MemSegmentOff (ArchAddrWidth arch))
forall (w :: Natural).
Memory w -> AbsValue w (BVType w) -> Maybe (MemSegmentOff w)
absValueAsSegmentOff Memory (ArchAddrWidth arch)
mem (AbsProcessorState (ArchReg arch) ids
-> BVValue arch ids (ArchAddrWidth arch)
-> AbsValue (ArchAddrWidth arch) (BVType (ArchAddrWidth arch))
forall a ids (tp :: Type).
(RegisterInfo (ArchReg a), HasCallStack) =>
AbsProcessorState (ArchReg a) ids
-> Value a ids tp -> ArchAbsValue a tp
transferValue AbsProcessorState (ArchReg arch) ids
aps BVValue arch ids (ArchAddrWidth arch)
base)

-- | This attempts to pattern match a value as a memory address plus a value.
valueAsMemOffset
  :: RegisterInfo (ArchReg arch)
  => Memory (ArchAddrWidth arch)
  -> AbsProcessorState (ArchReg arch) ids
  -> ArchAddrValue arch ids
  -> Maybe (ArchSegmentOff arch, ArchAddrValue arch ids)
valueAsMemOffset :: forall arch ids.
RegisterInfo (ArchReg arch) =>
Memory (ArchAddrWidth arch)
-> AbsProcessorState (ArchReg arch) ids
-> ArchAddrValue arch ids
-> Maybe (ArchSegmentOff arch, ArchAddrValue arch ids)
valueAsMemOffset Memory (ArchAddrWidth arch)
mem AbsProcessorState (ArchReg arch) ids
aps ArchAddrValue arch ids
v
  | Just (BVAdd NatRepr n
_ Value arch ids ('BVType n)
base Value arch ids ('BVType n)
offset) <- ArchAddrValue arch ids
-> Maybe (App (Value arch ids) (BVType (ArchAddrWidth arch)))
forall arch ids (tp :: Type).
Value arch ids tp -> Maybe (App (Value arch ids) tp)
valueAsApp ArchAddrValue arch ids
v
  , Just ArchSegmentOff arch
ptr <- Memory (ArchAddrWidth arch)
-> AbsProcessorState (ArchReg arch) ids
-> ArchAddrValue arch ids
-> Maybe (ArchSegmentOff arch)
forall arch ids.
RegisterInfo (ArchReg arch) =>
Memory (ArchAddrWidth arch)
-> AbsProcessorState (ArchReg arch) ids
-> BVValue arch ids (ArchAddrWidth arch)
-> Maybe (ArchSegmentOff arch)
valueAsSegmentOffWithTransfer Memory (ArchAddrWidth arch)
mem AbsProcessorState (ArchReg arch) ids
aps Value arch ids ('BVType n)
ArchAddrValue arch ids
base
  = (MemSegmentOff n, Value arch ids ('BVType n))
-> Maybe (MemSegmentOff n, Value arch ids ('BVType n))
forall a. a -> Maybe a
Just (MemSegmentOff n
ArchSegmentOff arch
ptr, Value arch ids ('BVType n)
offset)

  -- and with the other argument order
  | Just (BVAdd NatRepr n
_ Value arch ids ('BVType n)
offset Value arch ids ('BVType n)
base) <- ArchAddrValue arch ids
-> Maybe (App (Value arch ids) (BVType (ArchAddrWidth arch)))
forall arch ids (tp :: Type).
Value arch ids tp -> Maybe (App (Value arch ids) tp)
valueAsApp ArchAddrValue arch ids
v
  , Just ArchSegmentOff arch
ptr <- Memory (ArchAddrWidth arch)
-> AbsProcessorState (ArchReg arch) ids
-> ArchAddrValue arch ids
-> Maybe (ArchSegmentOff arch)
forall arch ids.
RegisterInfo (ArchReg arch) =>
Memory (ArchAddrWidth arch)
-> AbsProcessorState (ArchReg arch) ids
-> BVValue arch ids (ArchAddrWidth arch)
-> Maybe (ArchSegmentOff arch)
valueAsSegmentOffWithTransfer Memory (ArchAddrWidth arch)
mem AbsProcessorState (ArchReg arch) ids
aps Value arch ids ('BVType n)
ArchAddrValue arch ids
base
  = (MemSegmentOff n, Value arch ids ('BVType n))
-> Maybe (MemSegmentOff n, Value arch ids ('BVType n))
forall a. a -> Maybe a
Just (MemSegmentOff n
ArchSegmentOff arch
ptr, Value arch ids ('BVType n)
offset)

  | Bool
otherwise = Maybe (ArchSegmentOff arch, ArchAddrValue arch ids)
forall a. Maybe a
Nothing

-- This function resolves jump table entries.
-- It is a recursive function that has an index into the jump table.
-- If the current index can be interpreted as a intra-procedural jump,
-- then it will add that to the current procedure.
-- This returns the last address read.
resolveAsAddr :: forall w
              .  Memory w
              -> Endianness
              -> [MemChunk w]
              -> Maybe (MemAddr w)
resolveAsAddr :: forall (w :: Natural).
Memory w -> Endianness -> [MemChunk w] -> Maybe (MemAddr w)
resolveAsAddr Memory w
mem Endianness
endianness [MemChunk w]
l = AddrWidthRepr w
-> (MemWidth w => Maybe (MemAddr w)) -> Maybe (MemAddr w)
forall (w :: Natural) a. AddrWidthRepr w -> (MemWidth w => a) -> a
addrWidthClass (Memory w -> AddrWidthRepr w
forall (w :: Natural). Memory w -> AddrWidthRepr w
memAddrWidth Memory w
mem) ((MemWidth w => Maybe (MemAddr w)) -> Maybe (MemAddr w))
-> (MemWidth w => Maybe (MemAddr w)) -> Maybe (MemAddr w)
forall a b. (a -> b) -> a -> b
$
  case [MemChunk w]
l of
    [ByteRegion ByteString
bs] ->
      case Endianness -> ByteString -> Maybe (MemWord w)
forall (w :: Natural).
MemWidth w =>
Endianness -> ByteString -> Maybe (MemWord w)
addrRead Endianness
endianness ByteString
bs of
        Just MemWord w
a -> MemAddr w -> Maybe (MemAddr w)
forall a. a -> Maybe a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (MemAddr w -> Maybe (MemAddr w)) -> MemAddr w -> Maybe (MemAddr w)
forall a b. (a -> b) -> a -> b
$! MemWord w -> MemAddr w
forall (w :: Natural). MemWord w -> MemAddr w
absoluteAddr MemWord w
a
        Maybe (MemWord w)
Nothing -> String -> Maybe (MemAddr w)
forall a. HasCallStack => String -> a
error (String -> Maybe (MemAddr w)) -> String -> Maybe (MemAddr w)
forall a b. (a -> b) -> a -> b
$ String
"internal: resolveAsAddr given short chunk list."
    [RelocationRegion Relocation w
r] -> do
        Bool -> Maybe () -> Maybe ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Relocation w -> Bool
forall (w :: Natural). Relocation w -> Bool
relocationIsRel Relocation w
r) (Maybe () -> Maybe ()) -> Maybe () -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Maybe ()
forall a. Maybe a
Nothing
        case Relocation w -> SymbolIdentifier
forall (w :: Natural). Relocation w -> SymbolIdentifier
relocationSym Relocation w
r of
          SymbolRelocation{} -> Maybe (MemAddr w)
forall a. Maybe a
Nothing
          SectionIdentifier SectionIndex
idx -> do
            MemSegmentOff w
addr <- SectionIndex
-> Map SectionIndex (MemSegmentOff w) -> Maybe (MemSegmentOff w)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SectionIndex
idx (Memory w -> Map SectionIndex (MemSegmentOff w)
forall (w :: Natural).
Memory w -> Map SectionIndex (MemSegmentOff w)
memSectionIndexMap Memory w
mem)
            MemAddr w -> Maybe (MemAddr w)
forall a. a -> Maybe a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (MemAddr w -> Maybe (MemAddr w)) -> MemAddr w -> Maybe (MemAddr w)
forall a b. (a -> b) -> a -> b
$! MemSegmentOff w -> MemAddr w
forall (w :: Natural). MemSegmentOff w -> MemAddr w
segoffAddr MemSegmentOff w
addr MemAddr w -> (MemAddr w -> MemAddr w) -> MemAddr w
forall a b. a -> (a -> b) -> b
& Integer -> MemAddr w -> MemAddr w
forall (w :: Natural).
MemWidth w =>
Integer -> MemAddr w -> MemAddr w
incAddr (MemWord w -> Integer
forall a. Integral a => a -> Integer
toInteger (Relocation w -> MemWord w
forall (w :: Natural). Relocation w -> MemWord w
relocationOffset Relocation w
r))
          SegmentBaseAddr SectionIndex
idx -> do
            MemSegment w
seg <- SectionIndex
-> Map SectionIndex (MemSegment w) -> Maybe (MemSegment w)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SectionIndex
idx (Memory w -> Map SectionIndex (MemSegment w)
forall (w :: Natural). Memory w -> Map SectionIndex (MemSegment w)
memSegmentIndexMap Memory w
mem)
            MemAddr w -> Maybe (MemAddr w)
forall a. a -> Maybe a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (MemAddr w -> Maybe (MemAddr w)) -> MemAddr w -> Maybe (MemAddr w)
forall a b. (a -> b) -> a -> b
$! MemSegment w -> MemWord w -> MemAddr w
forall (w :: Natural).
MemWidth w =>
MemSegment w -> MemWord w -> MemAddr w
segmentOffAddr MemSegment w
seg (Relocation w -> MemWord w
forall (w :: Natural). Relocation w -> MemWord w
relocationOffset Relocation w
r)
          SymbolIdentifier
LoadBaseAddr -> do
            Memory w -> Maybe (MemAddr w)
forall (w :: Natural). Memory w -> Maybe (MemAddr w)
memBaseAddr Memory w
mem
    [MemChunk w]
_ -> Maybe (MemAddr w)
forall a. Maybe a
Nothing

-- | Just like Some (BVValue arch ids), but doesn't run into trouble with
-- partially applying the BVValue type synonym.
data SomeExt arch ids = forall m . SomeExt !(BVValue arch ids m) !(Parsed.Extension m)

matchAddr :: NatRepr w -> Maybe (AddrWidthRepr w)
matchAddr :: forall (w :: Natural). NatRepr w -> Maybe (AddrWidthRepr w)
matchAddr NatRepr w
w
  | Just w :~: 32
Refl <- NatRepr w -> NatRepr 32 -> Maybe (w :~: 32)
forall (a :: Natural) (b :: Natural).
NatRepr a -> NatRepr b -> Maybe (a :~: b)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality NatRepr w
w NatRepr 32
n32 = AddrWidthRepr w -> Maybe (AddrWidthRepr w)
forall a. a -> Maybe a
Just AddrWidthRepr w
forall (w :: Natural). (w ~ 32) => AddrWidthRepr w
Addr32
  | Just w :~: 64
Refl <- NatRepr w -> NatRepr 64 -> Maybe (w :~: 64)
forall (a :: Natural) (b :: Natural).
NatRepr a -> NatRepr b -> Maybe (a :~: b)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality NatRepr w
w NatRepr 64
n64 = AddrWidthRepr w -> Maybe (AddrWidthRepr w)
forall a. a -> Maybe a
Just AddrWidthRepr w
forall (w :: Natural). (w ~ 64) => AddrWidthRepr w
Addr64
  | Bool
otherwise = Maybe (AddrWidthRepr w)
forall a. Maybe a
Nothing

-- | @matchExtension x@ matches in @x@ has the form @uext y w@ or @sext y w@ and returns
-- a description about the extension as well as the pattern @y@.
matchExtension :: forall arch ids
               .  ( MemWidth (ArchAddrWidth arch)
                  , HasRepr (ArchReg arch) TypeRepr)
               => ArchAddrValue arch ids
               -> SomeExt arch ids
matchExtension :: forall arch ids.
(MemWidth (ArchAddrWidth arch), HasRepr (ArchReg arch) TypeRepr) =>
ArchAddrValue arch ids -> SomeExt arch ids
matchExtension ArchAddrValue arch ids
val =
  case ArchAddrValue arch ids
-> Maybe (App (Value arch ids) (BVType (ArchAddrWidth arch)))
forall arch ids (tp :: Type).
Value arch ids tp -> Maybe (App (Value arch ids) tp)
valueAsApp ArchAddrValue arch ids
val of
    Just (SExt Value arch ids (BVType m)
val' NatRepr n
_w) | Just AddrWidthRepr m
repr <- NatRepr m -> Maybe (AddrWidthRepr m)
forall (w :: Natural). NatRepr w -> Maybe (AddrWidthRepr w)
matchAddr (Value arch ids (BVType m) -> NatRepr m
forall (f :: Type -> Type) (w :: Natural).
HasRepr f TypeRepr =>
f (BVType w) -> NatRepr w
typeWidth Value arch ids (BVType m)
val') -> Value arch ids (BVType m) -> Extension m -> SomeExt arch ids
forall arch ids (m :: Natural).
BVValue arch ids m -> Extension m -> SomeExt arch ids
SomeExt Value arch ids (BVType m)
val' (Bool -> AddrWidthRepr m -> Extension m
forall (w :: Natural). Bool -> AddrWidthRepr w -> Extension w
Parsed.Extension Bool
True  AddrWidthRepr m
repr)
    Just (UExt Value arch ids (BVType m)
val' NatRepr n
_w) | Just AddrWidthRepr m
repr <- NatRepr m -> Maybe (AddrWidthRepr m)
forall (w :: Natural). NatRepr w -> Maybe (AddrWidthRepr w)
matchAddr (Value arch ids (BVType m) -> NatRepr m
forall (f :: Type -> Type) (w :: Natural).
HasRepr f TypeRepr =>
f (BVType w) -> NatRepr w
typeWidth Value arch ids (BVType m)
val') -> Value arch ids (BVType m) -> Extension m -> SomeExt arch ids
forall arch ids (m :: Natural).
BVValue arch ids m -> Extension m -> SomeExt arch ids
SomeExt Value arch ids (BVType m)
val' (Bool -> AddrWidthRepr m -> Extension m
forall (w :: Natural). Bool -> AddrWidthRepr w -> Extension w
Parsed.Extension Bool
False AddrWidthRepr m
repr)
    Maybe (App (Value arch ids) (BVType (ArchAddrWidth arch)))
_ -> ArchAddrValue arch ids
-> Extension (ArchAddrWidth arch) -> SomeExt arch ids
forall arch ids (m :: Natural).
BVValue arch ids m -> Extension m -> SomeExt arch ids
SomeExt ArchAddrValue arch ids
val (Bool
-> AddrWidthRepr (ArchAddrWidth arch)
-> Extension (ArchAddrWidth arch)
forall (w :: Natural). Bool -> AddrWidthRepr w -> Extension w
Parsed.Extension Bool
False (forall (w :: Natural) (p :: Natural -> Type).
MemWidth w =>
p w -> AddrWidthRepr w
addrWidthRepr @(ArchAddrWidth arch) Any (ArchAddrWidth arch)
forall a. HasCallStack => a
undefined))

-- | Contains information about jump table layout, addresses and index
-- in a recognized jump table.
type JumpTableClassifierResult arch ids =
   (Parsed.JumpTableLayout arch, V.Vector (ArchSegmentOff arch), ArchAddrValue arch ids)

type JumpTableClassifier arch ids s =
  Info.BlockClassifierM arch ids (JumpTableClassifierResult arch ids)

-- | This operation extracts chunks of memory for a jump table.
extractJumpTableSlices :: ArchConstraints arch
                       => Jmp.IntraJumpBounds arch ids
                       -- ^ Bounds for jump table
                       -> ArchSegmentOff arch -- ^ Base address
                       -> Natural -- ^ Stride
                       -> BVValue arch ids idxWidth
                       -> MemRepr tp -- ^ Type of values
                       -> Info.Classifier (V.Vector [MemChunk (ArchAddrWidth arch)])
extractJumpTableSlices :: forall arch ids (idxWidth :: Natural) (tp :: Type).
ArchConstraints arch =>
IntraJumpBounds arch ids
-> ArchSegmentOff arch
-> Natural
-> BVValue arch ids idxWidth
-> MemRepr tp
-> Classifier (Vector [MemChunk (ArchAddrWidth arch)])
extractJumpTableSlices IntraJumpBounds arch ids
jmpBounds ArchSegmentOff arch
base Natural
stride BVValue arch ids idxWidth
ixVal MemRepr tp
tp = do
  Integer
cnt <-
    case IntraJumpBounds arch ids
-> BVValue arch ids idxWidth -> Maybe Natural
forall arch ids (tp :: Type).
(OrdF (ArchReg arch), ShowF (ArchReg arch),
 RegisterInfo (ArchReg arch)) =>
IntraJumpBounds arch ids -> Value arch ids tp -> Maybe Natural
Jmp.unsignedUpperBound IntraJumpBounds arch ids
jmpBounds BVValue arch ids idxWidth
ixVal of
      Maybe Natural
Nothing -> String -> Classifier Integer
forall a. String -> Classifier a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Classifier Integer) -> String -> Classifier Integer
forall a b. (a -> b) -> a -> b
$ String
"Upper bounds failed:\n"
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (BVValue arch ids idxWidth -> Doc Any
forall arch ids (tp :: Type) ann.
ArchConstraints arch =>
Value arch ids tp -> Doc ann
ppValueAssignments BVValue arch ids idxWidth
ixVal) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (IntraJumpBounds arch ids -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. IntraJumpBounds arch ids -> Doc ann
PP.pretty IntraJumpBounds arch ids
jmpBounds)
      Just Natural
bnd -> do
        let cnt :: Integer
cnt = Natural -> Integer
forall a. Integral a => a -> Integer
toInteger (Natural
bndNatural -> Natural -> Natural
forall a. Num a => a -> a -> a
+Natural
1)
        -- Check array actually fits in memory.
        Bool -> Classifier () -> Classifier ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Integer
cnt Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Natural -> Integer
forall a. Integral a => a -> Integer
toInteger Natural
stride Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> ArchSegmentOff arch -> Integer
forall (w :: Natural). MemWidth w => MemSegmentOff w -> Integer
segoffBytesLeft ArchSegmentOff arch
base) (Classifier () -> Classifier ()) -> Classifier () -> Classifier ()
forall a b. (a -> b) -> a -> b
$ do
          String -> Classifier ()
forall a. String -> Classifier a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Size is too large."
        Integer -> Classifier Integer
forall a. a -> Classifier a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Integer
cnt

  -- Get memory contents after base
  Right [MemChunk (RegAddrWidth (ArchReg arch))]
contents <- Either
  (MemoryError (RegAddrWidth (ArchReg arch)))
  [MemChunk (RegAddrWidth (ArchReg arch))]
-> Classifier
     (Either
        (MemoryError (RegAddrWidth (ArchReg arch)))
        [MemChunk (RegAddrWidth (ArchReg arch))])
forall a. a -> Classifier a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either
   (MemoryError (RegAddrWidth (ArchReg arch)))
   [MemChunk (RegAddrWidth (ArchReg arch))]
 -> Classifier
      (Either
         (MemoryError (RegAddrWidth (ArchReg arch)))
         [MemChunk (RegAddrWidth (ArchReg arch))]))
-> Either
     (MemoryError (RegAddrWidth (ArchReg arch)))
     [MemChunk (RegAddrWidth (ArchReg arch))]
-> Classifier
     (Either
        (MemoryError (RegAddrWidth (ArchReg arch)))
        [MemChunk (RegAddrWidth (ArchReg arch))])
forall a b. (a -> b) -> a -> b
$ ArchSegmentOff arch
-> Either
     (MemoryError (RegAddrWidth (ArchReg arch)))
     [MemChunk (RegAddrWidth (ArchReg arch))]
forall (w :: Natural).
MemWidth w =>
MemSegmentOff w -> Either (MemoryError w) [MemChunk w]
segoffContentsAfter ArchSegmentOff arch
base
  -- Break up contents into a list of slices each with size stide
  Right ([[MemChunk (RegAddrWidth (ArchReg arch))]]
strideSlices,[MemChunk (RegAddrWidth (ArchReg arch))]
_) <- Either
  (SplitError (RegAddrWidth (ArchReg arch)))
  ([[MemChunk (RegAddrWidth (ArchReg arch))]],
   [MemChunk (RegAddrWidth (ArchReg arch))])
-> Classifier
     (Either
        (SplitError (RegAddrWidth (ArchReg arch)))
        ([[MemChunk (RegAddrWidth (ArchReg arch))]],
         [MemChunk (RegAddrWidth (ArchReg arch))]))
forall a. a -> Classifier a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either
   (SplitError (RegAddrWidth (ArchReg arch)))
   ([[MemChunk (RegAddrWidth (ArchReg arch))]],
    [MemChunk (RegAddrWidth (ArchReg arch))])
 -> Classifier
      (Either
         (SplitError (RegAddrWidth (ArchReg arch)))
         ([[MemChunk (RegAddrWidth (ArchReg arch))]],
          [MemChunk (RegAddrWidth (ArchReg arch))])))
-> Either
     (SplitError (RegAddrWidth (ArchReg arch)))
     ([[MemChunk (RegAddrWidth (ArchReg arch))]],
      [MemChunk (RegAddrWidth (ArchReg arch))])
-> Classifier
     (Either
        (SplitError (RegAddrWidth (ArchReg arch)))
        ([[MemChunk (RegAddrWidth (ArchReg arch))]],
         [MemChunk (RegAddrWidth (ArchReg arch))]))
forall a b. (a -> b) -> a -> b
$ Int
-> Integer
-> [MemChunk (RegAddrWidth (ArchReg arch))]
-> Either
     (SplitError (RegAddrWidth (ArchReg arch)))
     ([[MemChunk (RegAddrWidth (ArchReg arch))]],
      [MemChunk (RegAddrWidth (ArchReg arch))])
forall (w :: Natural).
MemWidth w =>
Int
-> Integer
-> [MemChunk w]
-> Either (SplitError w) ([[MemChunk w]], [MemChunk w])
sliceMemContents (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
stride) Integer
cnt [MemChunk (RegAddrWidth (ArchReg arch))]
contents
  -- Get memory slices
  Right Vector [MemChunk (RegAddrWidth (ArchReg arch))]
slices <-
    Either
  (SplitError (RegAddrWidth (ArchReg arch)))
  (Vector [MemChunk (RegAddrWidth (ArchReg arch))])
-> Classifier
     (Either
        (SplitError (RegAddrWidth (ArchReg arch)))
        (Vector [MemChunk (RegAddrWidth (ArchReg arch))]))
forall a. a -> Classifier a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either
   (SplitError (RegAddrWidth (ArchReg arch)))
   (Vector [MemChunk (RegAddrWidth (ArchReg arch))])
 -> Classifier
      (Either
         (SplitError (RegAddrWidth (ArchReg arch)))
         (Vector [MemChunk (RegAddrWidth (ArchReg arch))])))
-> Either
     (SplitError (RegAddrWidth (ArchReg arch)))
     (Vector [MemChunk (RegAddrWidth (ArchReg arch))])
-> Classifier
     (Either
        (SplitError (RegAddrWidth (ArchReg arch)))
        (Vector [MemChunk (RegAddrWidth (ArchReg arch))]))
forall a b. (a -> b) -> a -> b
$ ([MemChunk (RegAddrWidth (ArchReg arch))]
 -> Either
      (SplitError (RegAddrWidth (ArchReg arch)))
      [MemChunk (RegAddrWidth (ArchReg arch))])
-> Vector [MemChunk (RegAddrWidth (ArchReg arch))]
-> Either
     (SplitError (RegAddrWidth (ArchReg arch)))
     (Vector [MemChunk (RegAddrWidth (ArchReg arch))])
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> Vector a -> f (Vector b)
traverse (\[MemChunk (RegAddrWidth (ArchReg arch))]
s -> ([MemChunk (RegAddrWidth (ArchReg arch))],
 [MemChunk (RegAddrWidth (ArchReg arch))])
-> [MemChunk (RegAddrWidth (ArchReg arch))]
forall a b. (a, b) -> a
fst (([MemChunk (RegAddrWidth (ArchReg arch))],
  [MemChunk (RegAddrWidth (ArchReg arch))])
 -> [MemChunk (RegAddrWidth (ArchReg arch))])
-> Either
     (SplitError (RegAddrWidth (ArchReg arch)))
     ([MemChunk (RegAddrWidth (ArchReg arch))],
      [MemChunk (RegAddrWidth (ArchReg arch))])
-> Either
     (SplitError (RegAddrWidth (ArchReg arch)))
     [MemChunk (RegAddrWidth (ArchReg arch))]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [MemChunk (RegAddrWidth (ArchReg arch))]
-> Int
-> Either
     (SplitError (RegAddrWidth (ArchReg arch)))
     ([MemChunk (RegAddrWidth (ArchReg arch))],
      [MemChunk (RegAddrWidth (ArchReg arch))])
forall (w :: Natural).
MemWidth w =>
[MemChunk w]
-> Int -> Either (SplitError w) ([MemChunk w], [MemChunk w])
splitMemChunks [MemChunk (RegAddrWidth (ArchReg arch))]
s (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (MemRepr tp -> Natural
forall (tp :: Type). MemRepr tp -> Natural
memReprBytes MemRepr tp
tp)))
                    ([[MemChunk (RegAddrWidth (ArchReg arch))]]
-> Vector [MemChunk (RegAddrWidth (ArchReg arch))]
forall a. [a] -> Vector a
V.fromList [[MemChunk (RegAddrWidth (ArchReg arch))]]
strideSlices)
  Vector [MemChunk (RegAddrWidth (ArchReg arch))]
-> Classifier (Vector [MemChunk (RegAddrWidth (ArchReg arch))])
forall a. a -> Classifier a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Vector [MemChunk (RegAddrWidth (ArchReg arch))]
slices

-- | @matchBoundedMemArray mem aps bnds val@ checks to try to interpret
-- @val@ as a memory read where
--
-- * the address read has the form @base + stride * ixVal@,
-- * @base@ is a valid `MemSegmentOff`,
-- * @stride@ is a natural number and,
-- * @ixVal@ is a arbitrary value.
matchBoundedMemArray
  :: ArchConstraints arch
  => Memory (ArchAddrWidth arch)
  -> AbsProcessorState (ArchReg arch) ids
  -> Jmp.IntraJumpBounds arch ids
     -- ^ Bounds for jump table
  -> Value arch ids tp  -- ^ Value to interpret
  -> Info.Classifier (Parsed.BoundedMemArray arch tp, ArchAddrValue arch ids)
matchBoundedMemArray :: forall arch ids (tp :: Type).
ArchConstraints arch =>
Memory (ArchAddrWidth arch)
-> AbsProcessorState (ArchReg arch) ids
-> IntraJumpBounds arch ids
-> Value arch ids tp
-> Classifier (BoundedMemArray arch tp, ArchAddrValue arch ids)
matchBoundedMemArray Memory (ArchAddrWidth arch)
mem AbsProcessorState (ArchReg arch) ids
aps IntraJumpBounds arch ids
jmpBounds Value arch ids tp
val = do
  AssignedValue (Assignment AssignId ids tp
_ (ReadMem ArchAddrValue arch ids
addr MemRepr tp
tp)) <- Value arch ids tp -> Classifier (Value arch ids tp)
forall a. a -> Classifier a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Value arch ids tp
val
  Just (MemSegmentOff (ArchAddrWidth arch)
base, ArchAddrValue arch ids
offset) <- Maybe (MemSegmentOff (ArchAddrWidth arch), ArchAddrValue arch ids)
-> Classifier
     (Maybe
        (MemSegmentOff (ArchAddrWidth arch), ArchAddrValue arch ids))
forall a. a -> Classifier a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe (MemSegmentOff (ArchAddrWidth arch), ArchAddrValue arch ids)
 -> Classifier
      (Maybe
         (MemSegmentOff (ArchAddrWidth arch), ArchAddrValue arch ids)))
-> Maybe
     (MemSegmentOff (ArchAddrWidth arch), ArchAddrValue arch ids)
-> Classifier
     (Maybe
        (MemSegmentOff (ArchAddrWidth arch), ArchAddrValue arch ids))
forall a b. (a -> b) -> a -> b
$ Memory (ArchAddrWidth arch)
-> AbsProcessorState (ArchReg arch) ids
-> ArchAddrValue arch ids
-> Maybe
     (MemSegmentOff (ArchAddrWidth arch), ArchAddrValue arch ids)
forall arch ids.
RegisterInfo (ArchReg arch) =>
Memory (ArchAddrWidth arch)
-> AbsProcessorState (ArchReg arch) ids
-> ArchAddrValue arch ids
-> Maybe (ArchSegmentOff arch, ArchAddrValue arch ids)
valueAsMemOffset Memory (ArchAddrWidth arch)
mem AbsProcessorState (ArchReg arch) ids
aps ArchAddrValue arch ids
addr
  Just (Natural
stride, ArchAddrValue arch ids
ixVal) <- Maybe (Natural, ArchAddrValue arch ids)
-> Classifier (Maybe (Natural, ArchAddrValue arch ids))
forall a. a -> Classifier a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe (Natural, ArchAddrValue arch ids)
 -> Classifier (Maybe (Natural, ArchAddrValue arch ids)))
-> Maybe (Natural, ArchAddrValue arch ids)
-> Classifier (Maybe (Natural, ArchAddrValue arch ids))
forall a b. (a -> b) -> a -> b
$ ArchAddrValue arch ids -> Maybe (Natural, ArchAddrValue arch ids)
forall arch ids (w :: Natural).
BVValue arch ids w -> Maybe (Natural, BVValue arch ids w)
valueAsStaticMultiplication ArchAddrValue arch ids
offset
   -- Check stride covers at least number of bytes read.
  Bool -> Classifier () -> Classifier ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (MemRepr tp -> Natural
forall (tp :: Type). MemRepr tp -> Natural
memReprBytes MemRepr tp
tp Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
stride) (Classifier () -> Classifier ()) -> Classifier () -> Classifier ()
forall a b. (a -> b) -> a -> b
$ do
    String -> Classifier ()
forall a. String -> Classifier a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Stride does not cover size of relocation."
  -- Convert stride to word64 (must be lossless due to as memory is at most 64-bits)
  let stridew :: Word64
      stridew :: Word64
stridew = Natural -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
stride
  -- Take the given number of bytes out of each slices
  Vector [MemChunk (ArchAddrWidth arch)]
slices <- IntraJumpBounds arch ids
-> MemSegmentOff (ArchAddrWidth arch)
-> Natural
-> ArchAddrValue arch ids
-> MemRepr tp
-> Classifier (Vector [MemChunk (ArchAddrWidth arch)])
forall arch ids (idxWidth :: Natural) (tp :: Type).
ArchConstraints arch =>
IntraJumpBounds arch ids
-> ArchSegmentOff arch
-> Natural
-> BVValue arch ids idxWidth
-> MemRepr tp
-> Classifier (Vector [MemChunk (ArchAddrWidth arch)])
extractJumpTableSlices IntraJumpBounds arch ids
jmpBounds MemSegmentOff (ArchAddrWidth arch)
base Natural
stride ArchAddrValue arch ids
ixVal MemRepr tp
tp

  let r :: BoundedMemArray arch tp
r = Parsed.BoundedMemArray
          { arBase :: MemSegmentOff (ArchAddrWidth arch)
Parsed.arBase     = MemSegmentOff (ArchAddrWidth arch)
base
          , arStride :: Word64
Parsed.arStride   = Word64
stridew
          , arEltType :: MemRepr tp
Parsed.arEltType  = MemRepr tp
tp
          , arSlices :: Vector [MemChunk (ArchAddrWidth arch)]
Parsed.arSlices   = Vector [MemChunk (ArchAddrWidth arch)]
slices
          }
  (BoundedMemArray arch tp, ArchAddrValue arch ids)
-> Classifier (BoundedMemArray arch tp, ArchAddrValue arch ids)
forall a. a -> Classifier a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure  (BoundedMemArray arch tp
r, ArchAddrValue arch ids
ixVal)

-- | @matchAbsoluteJumpTable@ tries to match the control flow transfer
-- as a jump table where the addresses in the jump table are absolute
-- memory addresses.
matchAbsoluteJumpTable
  :: forall arch ids s
  .  ArchConstraints arch
  => JumpTableClassifier arch ids s
matchAbsoluteJumpTable :: forall arch ids s.
ArchConstraints arch =>
JumpTableClassifier arch ids s
matchAbsoluteJumpTable = String
-> BlockClassifierM arch ids (JumpTableClassifierResult arch ids)
-> BlockClassifierM arch ids (JumpTableClassifierResult arch ids)
forall arch ids a.
String
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids a
Info.classifierName String
"Absolute jump table" (BlockClassifierM arch ids (JumpTableClassifierResult arch ids)
 -> BlockClassifierM arch ids (JumpTableClassifierResult arch ids))
-> BlockClassifierM arch ids (JumpTableClassifierResult arch ids)
-> BlockClassifierM arch ids (JumpTableClassifierResult arch ids)
forall a b. (a -> b) -> a -> b
$ do
  BlockClassifierContext arch ids
bcc <- BlockClassifierM arch ids (BlockClassifierContext arch ids)
forall r (m :: Type -> Type). MonadReader r m => m r
CMR.ask
  let mem :: Memory (RegAddrWidth (ArchReg arch))
mem = ParseContext arch ids -> Memory (RegAddrWidth (ArchReg arch))
forall arch ids.
ParseContext arch ids -> Memory (ArchAddrWidth arch)
Info.pctxMemory (BlockClassifierContext arch ids -> ParseContext arch ids
forall arch ids.
BlockClassifierContext arch ids -> ParseContext arch ids
Info.classifierParseContext BlockClassifierContext arch ids
bcc)
  let aps :: AbsProcessorState (ArchReg arch) ids
aps = BlockClassifierContext arch ids
-> AbsProcessorState (ArchReg arch) ids
forall arch ids.
BlockClassifierContext arch ids
-> AbsProcessorState (ArchReg arch) ids
Info.classifierAbsState BlockClassifierContext arch ids
bcc
  let jmpBounds :: IntraJumpBounds arch ids
jmpBounds = BlockClassifierContext arch ids -> IntraJumpBounds arch ids
forall arch ids.
BlockClassifierContext arch ids -> IntraJumpBounds arch ids
Info.classifierJumpBounds BlockClassifierContext arch ids
bcc
  -- Get IP value to interpret as a jump table index.
  let ip :: Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
ip = BlockClassifierContext arch ids
-> RegState (ArchReg arch) (Value arch ids)
forall arch ids.
BlockClassifierContext arch ids
-> RegState (ArchReg arch) (Value arch ids)
Info.classifierFinalRegState BlockClassifierContext arch ids
bccRegState (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
^.Getting
  (Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
  (RegState (ArchReg arch) (Value arch ids))
  (Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
Lens'
  (RegState (ArchReg arch) (Value arch ids))
  (Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
forall (r :: Type -> Type) (f :: Type -> Type).
RegisterInfo r =>
Lens' (RegState r f) (f (BVType (RegAddrWidth r)))
curIP
  (BoundedMemArray arch (BVType (RegAddrWidth (ArchReg arch)))
arrayRead, Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
idx) <- Classifier
  (BoundedMemArray arch (BVType (RegAddrWidth (ArchReg arch))),
   Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
-> BlockClassifierM
     arch
     ids
     (BoundedMemArray arch (BVType (RegAddrWidth (ArchReg arch))),
      Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
forall a arch ids. Classifier a -> BlockClassifierM arch ids a
Info.liftClassifier (Classifier
   (BoundedMemArray arch (BVType (RegAddrWidth (ArchReg arch))),
    Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
 -> BlockClassifierM
      arch
      ids
      (BoundedMemArray arch (BVType (RegAddrWidth (ArchReg arch))),
       Value arch ids (BVType (RegAddrWidth (ArchReg arch)))))
-> Classifier
     (BoundedMemArray arch (BVType (RegAddrWidth (ArchReg arch))),
      Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
-> BlockClassifierM
     arch
     ids
     (BoundedMemArray arch (BVType (RegAddrWidth (ArchReg arch))),
      Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
forall a b. (a -> b) -> a -> b
$ Memory (RegAddrWidth (ArchReg arch))
-> AbsProcessorState (ArchReg arch) ids
-> IntraJumpBounds arch ids
-> Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
-> Classifier
     (BoundedMemArray arch (BVType (RegAddrWidth (ArchReg arch))),
      Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
forall arch ids (tp :: Type).
ArchConstraints arch =>
Memory (ArchAddrWidth arch)
-> AbsProcessorState (ArchReg arch) ids
-> IntraJumpBounds arch ids
-> Value arch ids tp
-> Classifier (BoundedMemArray arch tp, ArchAddrValue arch ids)
matchBoundedMemArray Memory (RegAddrWidth (ArchReg arch))
mem AbsProcessorState (ArchReg arch) ids
aps IntraJumpBounds arch ids
jmpBounds Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
ip
  Bool
-> BlockClassifierM arch ids () -> BlockClassifierM arch ids ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (BoundedMemArray arch (BVType (RegAddrWidth (ArchReg arch))) -> Bool
forall arch (tp :: Type). BoundedMemArray arch tp -> Bool
Parsed.isReadOnlyBoundedMemArray BoundedMemArray arch (BVType (RegAddrWidth (ArchReg arch)))
arrayRead) (BlockClassifierM arch ids () -> BlockClassifierM arch ids ())
-> BlockClassifierM arch ids () -> BlockClassifierM arch ids ()
forall a b. (a -> b) -> a -> b
$ do
    String -> BlockClassifierM arch ids ()
forall a. String -> BlockClassifierM arch ids a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Bounded mem array is not read only."
  Endianness
endianness <-
    case BoundedMemArray arch (BVType (RegAddrWidth (ArchReg arch)))
-> MemRepr (BVType (RegAddrWidth (ArchReg arch)))
forall arch (tp :: Type). BoundedMemArray arch tp -> MemRepr tp
Parsed.arEltType BoundedMemArray arch (BVType (RegAddrWidth (ArchReg arch)))
arrayRead of
      BVMemRepr NatRepr w
_arByteCount Endianness
e -> Endianness -> BlockClassifierM arch ids Endianness
forall a. a -> BlockClassifierM arch ids a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Endianness
e
  let go :: Int
         -> [MemChunk (ArchAddrWidth arch)]
         -> Info.Classifier (ArchSegmentOff arch)
      go :: Int
-> [MemChunk (RegAddrWidth (ArchReg arch))]
-> Classifier (ArchSegmentOff arch)
go Int
entryIndex [MemChunk (RegAddrWidth (ArchReg arch))]
contents = do
        MemAddr (RegAddrWidth (ArchReg arch))
addr <- case Memory (RegAddrWidth (ArchReg arch))
-> Endianness
-> [MemChunk (RegAddrWidth (ArchReg arch))]
-> Maybe (MemAddr (RegAddrWidth (ArchReg arch)))
forall (w :: Natural).
Memory w -> Endianness -> [MemChunk w] -> Maybe (MemAddr w)
resolveAsAddr Memory (RegAddrWidth (ArchReg arch))
mem Endianness
endianness [MemChunk (RegAddrWidth (ArchReg arch))]
contents of
                  Just MemAddr (RegAddrWidth (ArchReg arch))
a -> MemAddr (RegAddrWidth (ArchReg arch))
-> Classifier (MemAddr (RegAddrWidth (ArchReg arch)))
forall a. a -> Classifier a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure MemAddr (RegAddrWidth (ArchReg arch))
a
                  Maybe (MemAddr (RegAddrWidth (ArchReg arch)))
Nothing -> String -> Classifier (MemAddr (RegAddrWidth (ArchReg arch)))
forall a. String -> Classifier a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Could not resolve jump table contents as absolute address."
        ArchSegmentOff arch
tgt <- case Memory (RegAddrWidth (ArchReg arch))
-> MemAddr (RegAddrWidth (ArchReg arch))
-> Maybe (ArchSegmentOff arch)
forall (w :: Natural).
Memory w -> MemAddr w -> Maybe (MemSegmentOff w)
asSegmentOff Memory (RegAddrWidth (ArchReg arch))
mem (forall arch.
IPAlignment arch =>
MemAddr (ArchAddrWidth arch) -> MemAddr (ArchAddrWidth arch)
toIPAligned @arch MemAddr (RegAddrWidth (ArchReg arch))
addr) of
                 Just ArchSegmentOff arch
t -> ArchSegmentOff arch -> Classifier (ArchSegmentOff arch)
forall a. a -> Classifier a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ArchSegmentOff arch
t
                 Maybe (ArchSegmentOff arch)
Nothing ->
                   String -> Classifier (ArchSegmentOff arch)
forall a. String -> Classifier a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Classifier (ArchSegmentOff arch))
-> String -> Classifier (ArchSegmentOff arch)
forall a b. (a -> b) -> a -> b
$
                     String
"Could not resolve jump table entry " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
entryIndex
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" value " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MemAddr (RegAddrWidth (ArchReg arch)) -> String
forall a. Show a => a -> String
show MemAddr (RegAddrWidth (ArchReg arch))
addr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" as segment offset.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Memory (RegAddrWidth (ArchReg arch)) -> String
forall a. Show a => a -> String
show Memory (RegAddrWidth (ArchReg arch))
mem
        Bool -> Classifier () -> Classifier ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (Flags -> Bool
Perm.isExecutable (MemSegment (RegAddrWidth (ArchReg arch)) -> Flags
forall (w :: Natural). MemSegment w -> Flags
segmentFlags (ArchSegmentOff arch -> MemSegment (RegAddrWidth (ArchReg arch))
forall (w :: Natural). MemSegmentOff w -> MemSegment w
segoffSegment ArchSegmentOff arch
tgt))) (Classifier () -> Classifier ()) -> Classifier () -> Classifier ()
forall a b. (a -> b) -> a -> b
$
          String -> Classifier ()
forall a. String -> Classifier a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Classifier ()) -> String -> Classifier ()
forall a b. (a -> b) -> a -> b
$ String
"Jump table contents non-executable."
        ArchSegmentOff arch -> Classifier (ArchSegmentOff arch)
forall a. a -> Classifier a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ArchSegmentOff arch
tgt
  Vector (ArchSegmentOff arch)
tbl <- Classifier (Vector (ArchSegmentOff arch))
-> BlockClassifierM arch ids (Vector (ArchSegmentOff arch))
forall a arch ids. Classifier a -> BlockClassifierM arch ids a
Info.liftClassifier (Classifier (Vector (ArchSegmentOff arch))
 -> BlockClassifierM arch ids (Vector (ArchSegmentOff arch)))
-> Classifier (Vector (ArchSegmentOff arch))
-> BlockClassifierM arch ids (Vector (ArchSegmentOff arch))
forall a b. (a -> b) -> a -> b
$ (Int
 -> [MemChunk (RegAddrWidth (ArchReg arch))]
 -> Classifier (ArchSegmentOff arch))
-> Vector Int
-> Vector [MemChunk (RegAddrWidth (ArchReg arch))]
-> Classifier (Vector (ArchSegmentOff arch))
forall (m :: Type -> Type) a b c.
Monad m =>
(a -> b -> m c) -> Vector a -> Vector b -> m (Vector c)
V.zipWithM Int
-> [MemChunk (RegAddrWidth (ArchReg arch))]
-> Classifier (ArchSegmentOff arch)
go (Int -> (Int -> Int) -> Vector Int
forall a. Int -> (Int -> a) -> Vector a
V.generate (Vector [MemChunk (RegAddrWidth (ArchReg arch))] -> Int
forall a. Vector a -> Int
V.length (BoundedMemArray arch (BVType (RegAddrWidth (ArchReg arch)))
-> Vector [MemChunk (RegAddrWidth (ArchReg arch))]
forall arch (tp :: Type).
BoundedMemArray arch tp -> Vector [MemChunk (ArchAddrWidth arch)]
Parsed.arSlices BoundedMemArray arch (BVType (RegAddrWidth (ArchReg arch)))
arrayRead)) Int -> Int
forall a. a -> a
id) (BoundedMemArray arch (BVType (RegAddrWidth (ArchReg arch)))
-> Vector [MemChunk (RegAddrWidth (ArchReg arch))]
forall arch (tp :: Type).
BoundedMemArray arch tp -> Vector [MemChunk (ArchAddrWidth arch)]
Parsed.arSlices BoundedMemArray arch (BVType (RegAddrWidth (ArchReg arch)))
arrayRead)
  JumpTableClassifierResult arch ids
-> BlockClassifierM arch ids (JumpTableClassifierResult arch ids)
forall a. a -> BlockClassifierM arch ids a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (BoundedMemArray arch (BVType (RegAddrWidth (ArchReg arch)))
-> JumpTableLayout arch
forall arch.
BoundedMemArray arch (BVType (ArchAddrWidth arch))
-> JumpTableLayout arch
Parsed.AbsoluteJumpTable BoundedMemArray arch (BVType (RegAddrWidth (ArchReg arch)))
arrayRead, Vector (ArchSegmentOff arch)
tbl, Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
idx)

-- | @matchAbsoluteJumpTable@ tries to match the control flow transfer
-- as a jump table where the addresses in the jump table are IP relative jumps.
matchRelativeJumpTable
  :: forall arch ids s
  .  ArchConstraints arch
  => JumpTableClassifier arch ids s
matchRelativeJumpTable :: forall arch ids s.
ArchConstraints arch =>
JumpTableClassifier arch ids s
matchRelativeJumpTable = String
-> BlockClassifierM arch ids (JumpTableClassifierResult arch ids)
-> BlockClassifierM arch ids (JumpTableClassifierResult arch ids)
forall arch ids a.
String
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids a
Info.classifierName String
"Relative jump table" (BlockClassifierM arch ids (JumpTableClassifierResult arch ids)
 -> BlockClassifierM arch ids (JumpTableClassifierResult arch ids))
-> BlockClassifierM arch ids (JumpTableClassifierResult arch ids)
-> BlockClassifierM arch ids (JumpTableClassifierResult arch ids)
forall a b. (a -> b) -> a -> b
$ do
  BlockClassifierContext arch ids
bcc <- BlockClassifierM arch ids (BlockClassifierContext arch ids)
forall r (m :: Type -> Type). MonadReader r m => m r
CMR.ask
  let mem :: Memory (RegAddrWidth (ArchReg arch))
mem = ParseContext arch ids -> Memory (RegAddrWidth (ArchReg arch))
forall arch ids.
ParseContext arch ids -> Memory (ArchAddrWidth arch)
Info.pctxMemory (BlockClassifierContext arch ids -> ParseContext arch ids
forall arch ids.
BlockClassifierContext arch ids -> ParseContext arch ids
Info.classifierParseContext BlockClassifierContext arch ids
bcc)
  let aps :: AbsProcessorState (ArchReg arch) ids
aps = BlockClassifierContext arch ids
-> AbsProcessorState (ArchReg arch) ids
forall arch ids.
BlockClassifierContext arch ids
-> AbsProcessorState (ArchReg arch) ids
Info.classifierAbsState BlockClassifierContext arch ids
bcc
  let jmpBounds :: IntraJumpBounds arch ids
jmpBounds = BlockClassifierContext arch ids -> IntraJumpBounds arch ids
forall arch ids.
BlockClassifierContext arch ids -> IntraJumpBounds arch ids
Info.classifierJumpBounds BlockClassifierContext arch ids
bcc
  -- Get IP value to interpret as a jump table index.
  let ip :: Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
ip = BlockClassifierContext arch ids
-> RegState (ArchReg arch) (Value arch ids)
forall arch ids.
BlockClassifierContext arch ids
-> RegState (ArchReg arch) (Value arch ids)
Info.classifierFinalRegState BlockClassifierContext arch ids
bccRegState (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
^.Getting
  (Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
  (RegState (ArchReg arch) (Value arch ids))
  (Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
Lens'
  (RegState (ArchReg arch) (Value arch ids))
  (Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
forall (r :: Type -> Type) (f :: Type -> Type).
RegisterInfo r =>
Lens' (RegState r f) (f (BVType (RegAddrWidth r)))
curIP

  -- gcc-style PIC jump tables on x86 use, roughly,
  --     ip = jmptbl + jmptbl[index]
  -- where jmptbl is a pointer to the lookup table.
  Just Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
unalignedIP <- Maybe (Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
-> BlockClassifierM
     arch
     ids
     (Maybe (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 (Maybe (Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
 -> BlockClassifierM
      arch
      ids
      (Maybe (Value arch ids (BVType (RegAddrWidth (ArchReg arch))))))
-> Maybe (Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
-> BlockClassifierM
     arch
     ids
     (Maybe (Value arch ids (BVType (RegAddrWidth (ArchReg arch)))))
forall a b. (a -> b) -> a -> b
$ Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
-> Maybe (Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
forall arch ids.
IPAlignment arch =>
ArchAddrValue arch ids -> Maybe (ArchAddrValue arch ids)
forall ids.
ArchAddrValue arch ids -> Maybe (ArchAddrValue arch ids)
fromIPAligned Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
ip
  (MemSegmentOff (RegAddrWidth (ArchReg arch))
tgtBase, Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
tgtOffset) <-
    case Memory (RegAddrWidth (ArchReg arch))
-> AbsProcessorState (ArchReg arch) ids
-> Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
-> Maybe
     (MemSegmentOff (RegAddrWidth (ArchReg arch)),
      Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
forall arch ids.
RegisterInfo (ArchReg arch) =>
Memory (ArchAddrWidth arch)
-> AbsProcessorState (ArchReg arch) ids
-> ArchAddrValue arch ids
-> Maybe (ArchSegmentOff arch, ArchAddrValue arch ids)
valueAsMemOffset Memory (RegAddrWidth (ArchReg arch))
mem AbsProcessorState (ArchReg arch) ids
aps Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
unalignedIP of
      Just (MemSegmentOff (RegAddrWidth (ArchReg arch)),
 Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
p -> (MemSegmentOff (RegAddrWidth (ArchReg arch)),
 Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
-> BlockClassifierM
     arch
     ids
     (MemSegmentOff (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 (MemSegmentOff (RegAddrWidth (ArchReg arch)),
 Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
p
      Maybe
  (MemSegmentOff (RegAddrWidth (ArchReg arch)),
   Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
Nothing -> String
-> BlockClassifierM
     arch
     ids
     (MemSegmentOff (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
      (MemSegmentOff (RegAddrWidth (ArchReg arch)),
       Value arch ids (BVType (RegAddrWidth (ArchReg arch)))))
-> String
-> BlockClassifierM
     arch
     ids
     (MemSegmentOff (RegAddrWidth (ArchReg arch)),
      Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
forall a b. (a -> b) -> a -> b
$ String
"Unaligned IP not a mem offset: " String -> String -> String
forall a. Semigroup 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)))
unalignedIP
  SomeExt BVValue arch ids m
shortOffset Extension m
ext <- SomeExt arch ids -> BlockClassifierM arch ids (SomeExt arch ids)
forall a. a -> BlockClassifierM arch ids a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (SomeExt arch ids -> BlockClassifierM arch ids (SomeExt arch ids))
-> SomeExt arch ids -> BlockClassifierM arch ids (SomeExt arch ids)
forall a b. (a -> b) -> a -> b
$ Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
-> SomeExt arch ids
forall arch ids.
(MemWidth (ArchAddrWidth arch), HasRepr (ArchReg arch) TypeRepr) =>
ArchAddrValue arch ids -> SomeExt arch ids
matchExtension Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
tgtOffset
  (BoundedMemArray arch (BVType m)
arrayRead, Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
idx) <- Classifier
  (BoundedMemArray arch (BVType m),
   Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
-> BlockClassifierM
     arch
     ids
     (BoundedMemArray arch (BVType m),
      Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
forall a arch ids. Classifier a -> BlockClassifierM arch ids a
Info.liftClassifier (Classifier
   (BoundedMemArray arch (BVType m),
    Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
 -> BlockClassifierM
      arch
      ids
      (BoundedMemArray arch (BVType m),
       Value arch ids (BVType (RegAddrWidth (ArchReg arch)))))
-> Classifier
     (BoundedMemArray arch (BVType m),
      Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
-> BlockClassifierM
     arch
     ids
     (BoundedMemArray arch (BVType m),
      Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
forall a b. (a -> b) -> a -> b
$ Memory (RegAddrWidth (ArchReg arch))
-> AbsProcessorState (ArchReg arch) ids
-> IntraJumpBounds arch ids
-> BVValue arch ids m
-> Classifier
     (BoundedMemArray arch (BVType m),
      Value arch ids (BVType (RegAddrWidth (ArchReg arch))))
forall arch ids (tp :: Type).
ArchConstraints arch =>
Memory (ArchAddrWidth arch)
-> AbsProcessorState (ArchReg arch) ids
-> IntraJumpBounds arch ids
-> Value arch ids tp
-> Classifier (BoundedMemArray arch tp, ArchAddrValue arch ids)
matchBoundedMemArray Memory (RegAddrWidth (ArchReg arch))
mem AbsProcessorState (ArchReg arch) ids
aps IntraJumpBounds arch ids
jmpBounds BVValue arch ids m
shortOffset
  Bool
-> BlockClassifierM arch ids () -> BlockClassifierM arch ids ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (BoundedMemArray arch (BVType m) -> Bool
forall arch (tp :: Type). BoundedMemArray arch tp -> Bool
Parsed.isReadOnlyBoundedMemArray BoundedMemArray arch (BVType m)
arrayRead) (BlockClassifierM arch ids () -> BlockClassifierM arch ids ())
-> BlockClassifierM arch ids () -> BlockClassifierM arch ids ()
forall a b. (a -> b) -> a -> b
$ do
    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
"Jump table memory array must be read only."
  Vector (MemSegmentOff (RegAddrWidth (ArchReg arch)))
tbl <- case Memory (RegAddrWidth (ArchReg arch))
-> MemSegmentOff (RegAddrWidth (ArchReg arch))
-> BoundedMemArray arch (BVType m)
-> Extension m
-> Either
     String (Vector (MemSegmentOff (RegAddrWidth (ArchReg arch))))
forall arch (w :: Natural).
(MemWidth (ArchAddrWidth arch), IPAlignment arch,
 RegisterInfo (ArchReg arch)) =>
Memory (ArchAddrWidth arch)
-> ArchSegmentOff arch
-> BoundedMemArray arch (BVType w)
-> Extension w
-> Either String (Vector (ArchSegmentOff arch))
resolveRelativeJumps Memory (RegAddrWidth (ArchReg arch))
mem MemSegmentOff (RegAddrWidth (ArchReg arch))
tgtBase BoundedMemArray arch (BVType m)
arrayRead Extension m
ext of
           Left String
msg -> String
-> BlockClassifierM
     arch ids (Vector (MemSegmentOff (RegAddrWidth (ArchReg arch))))
forall a. String -> BlockClassifierM arch ids a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
msg
           Right Vector (MemSegmentOff (RegAddrWidth (ArchReg arch)))
tbl -> Vector (MemSegmentOff (RegAddrWidth (ArchReg arch)))
-> BlockClassifierM
     arch ids (Vector (MemSegmentOff (RegAddrWidth (ArchReg arch))))
forall a. a -> BlockClassifierM arch ids a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Vector (MemSegmentOff (RegAddrWidth (ArchReg arch)))
tbl
  JumpTableClassifierResult arch ids
-> BlockClassifierM arch ids (JumpTableClassifierResult arch ids)
forall a. a -> BlockClassifierM arch ids a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (MemSegmentOff (RegAddrWidth (ArchReg arch))
-> BoundedMemArray arch (BVType m)
-> Extension m
-> JumpTableLayout arch
forall arch (w :: Natural).
ArchSegmentOff arch
-> BoundedMemArray arch (BVType w)
-> Extension w
-> JumpTableLayout arch
Parsed.RelativeJumpTable MemSegmentOff (RegAddrWidth (ArchReg arch))
tgtBase BoundedMemArray arch (BVType m)
arrayRead Extension m
ext, Vector (MemSegmentOff (RegAddrWidth (ArchReg arch)))
tbl, Value arch ids (BVType (RegAddrWidth (ArchReg arch)))
idx)

-- | A classifier for jump tables
--
-- This classifier employs a number of heuristics, but is of course incomplete
jumpTableClassifier :: forall arch ids . Info.BlockClassifier arch ids
jumpTableClassifier :: forall arch ids. BlockClassifier arch ids
jumpTableClassifier = 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
Info.classifierName String
"Jump table" (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
  BlockClassifierContext arch ids
bcc <- BlockClassifierM arch ids (BlockClassifierContext arch ids)
forall r (m :: Type -> Type). MonadReader r m => m r
CMR.ask
  let ctx :: ParseContext arch ids
ctx = BlockClassifierContext arch ids -> ParseContext arch ids
forall arch ids.
BlockClassifierContext arch ids -> ParseContext arch ids
Info.classifierParseContext BlockClassifierContext arch ids
bcc
  let ainfo :: ArchitectureInfo arch
ainfo = ParseContext arch ids -> ArchitectureInfo arch
forall arch ids. ParseContext arch ids -> ArchitectureInfo arch
Info.pctxArchInfo ParseContext arch ids
ctx
  let jmpBounds :: IntraJumpBounds arch ids
jmpBounds = BlockClassifierContext arch ids -> IntraJumpBounds arch ids
forall arch ids.
BlockClassifierContext arch ids -> IntraJumpBounds arch ids
Info.classifierJumpBounds BlockClassifierContext arch ids
bcc
  ArchitectureInfo arch -> forall a. (ArchConstraints arch => a) -> a
forall arch.
ArchitectureInfo arch -> forall a. (ArchConstraints arch => a) -> a
Info.withArchConstraints ArchitectureInfo arch
ainfo ((ArchConstraints arch =>
  BlockClassifierM arch ids (ParsedContents arch ids))
 -> BlockClassifierM arch ids (ParsedContents arch ids))
-> (ArchConstraints arch =>
    BlockClassifierM arch ids (ParsedContents arch ids))
-> BlockClassifierM arch ids (ParsedContents arch ids)
forall a b. (a -> b) -> a -> b
$ do
    let jumpTableClassifiers :: BlockClassifierM
  arch
  ids
  (JumpTableLayout arch,
   Vector (MemSegmentOff (RegAddrWidth (ArchReg arch))),
   BVValue arch ids (RegAddrWidth (ArchReg arch)))
jumpTableClassifiers
          =   BlockClassifierM
  arch
  ids
  (JumpTableLayout arch,
   Vector (MemSegmentOff (RegAddrWidth (ArchReg arch))),
   BVValue arch ids (RegAddrWidth (ArchReg arch)))
forall arch ids s.
ArchConstraints arch =>
JumpTableClassifier arch ids s
matchAbsoluteJumpTable
          BlockClassifierM
  arch
  ids
  (JumpTableLayout arch,
   Vector (MemSegmentOff (RegAddrWidth (ArchReg arch))),
   BVValue arch ids (RegAddrWidth (ArchReg arch)))
-> BlockClassifierM
     arch
     ids
     (JumpTableLayout arch,
      Vector (MemSegmentOff (RegAddrWidth (ArchReg arch))),
      BVValue arch ids (RegAddrWidth (ArchReg arch)))
-> BlockClassifierM
     arch
     ids
     (JumpTableLayout arch,
      Vector (MemSegmentOff (RegAddrWidth (ArchReg arch))),
      BVValue arch ids (RegAddrWidth (ArchReg arch)))
forall a.
BlockClassifierM arch ids a
-> BlockClassifierM arch ids a -> BlockClassifierM arch ids a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> BlockClassifierM
  arch
  ids
  (JumpTableLayout arch,
   Vector (MemSegmentOff (RegAddrWidth (ArchReg arch))),
   BVValue arch ids (RegAddrWidth (ArchReg arch)))
forall arch ids s.
ArchConstraints arch =>
JumpTableClassifier arch ids s
matchRelativeJumpTable
    (JumpTableLayout arch
layout, Vector (MemSegmentOff (RegAddrWidth (ArchReg arch)))
entries, BVValue arch ids (RegAddrWidth (ArchReg arch))
jumpIndex) <- BlockClassifierM
  arch
  ids
  (JumpTableLayout arch,
   Vector (MemSegmentOff (RegAddrWidth (ArchReg arch))),
   BVValue arch ids (RegAddrWidth (ArchReg arch)))
forall {ids}.
BlockClassifierM
  arch
  ids
  (JumpTableLayout arch,
   Vector (MemSegmentOff (RegAddrWidth (ArchReg arch))),
   BVValue arch ids (RegAddrWidth (ArchReg arch)))
jumpTableClassifiers

    let abst :: AbsBlockState (ArchReg arch)
        abst :: AbsBlockState (ArchReg arch)
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
Info.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)
Info.classifierFinalRegState BlockClassifierContext arch ids
bcc)
    let nextBnds :: InitJumpBounds arch
nextBnds = IntraJumpBounds arch ids
-> RegState (ArchReg arch) (Value arch ids) -> InitJumpBounds arch
forall arch ids.
RegisterInfo (ArchReg arch) =>
IntraJumpBounds arch ids
-> RegState (ArchReg arch) (Value arch ids) -> InitJumpBounds arch
Jmp.postJumpBounds IntraJumpBounds arch ids
jmpBounds (BlockClassifierContext arch ids
-> RegState (ArchReg arch) (Value arch ids)
forall arch ids.
BlockClassifierContext arch ids
-> RegState (ArchReg arch) (Value arch ids)
Info.classifierFinalRegState BlockClassifierContext arch ids
bcc)
    let term :: ParsedTermStmt arch ids
term = JumpTableLayout arch
-> RegState (ArchReg arch) (Value arch ids)
-> BVValue arch ids (RegAddrWidth (ArchReg arch))
-> Vector (MemSegmentOff (RegAddrWidth (ArchReg arch)))
-> ParsedTermStmt arch ids
forall arch ids.
JumpTableLayout arch
-> RegState (ArchReg arch) (Value arch ids)
-> ArchAddrValue arch ids
-> Vector (ArchSegmentOff arch)
-> ParsedTermStmt arch ids
Parsed.ParsedLookupTable JumpTableLayout arch
layout (BlockClassifierContext arch ids
-> RegState (ArchReg arch) (Value arch ids)
forall arch ids.
BlockClassifierContext arch ids
-> RegState (ArchReg arch) (Value arch ids)
Info.classifierFinalRegState BlockClassifierContext arch ids
bcc) BVValue arch ids (RegAddrWidth (ArchReg arch))
jumpIndex Vector (MemSegmentOff (RegAddrWidth (ArchReg arch)))
entries
    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
$ AbsBlockState (ArchReg arch)
-> ParsedContents arch ids -> ParsedContents arch ids
forall a b. a -> b -> b
seq AbsBlockState (ArchReg arch)
abst (ParsedContents arch ids -> ParsedContents arch ids)
-> 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)
Info.classifierStmts BlockClassifierContext arch ids
bcc)
                         , parsedTerm :: ParsedTermStmt arch ids
Parsed.parsedTerm = ParsedTermStmt arch ids
term
                         , writtenCodeAddrs :: [MemSegmentOff (RegAddrWidth (ArchReg arch))]
Parsed.writtenCodeAddrs = BlockClassifierContext arch ids
-> [MemSegmentOff (RegAddrWidth (ArchReg arch))]
forall arch ids.
BlockClassifierContext arch ids -> [ArchSegmentOff arch]
Info.classifierWrittenAddrs BlockClassifierContext arch ids
bcc
                         , intraJumpTargets :: [IntraJumpTarget arch]
Parsed.intraJumpTargets =
                           [ (MemSegmentOff (RegAddrWidth (ArchReg arch))
tgtAddr, 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))
tgtAddr, InitJumpBounds arch
nextBnds)
                           | MemSegmentOff (RegAddrWidth (ArchReg arch))
tgtAddr <- Vector (MemSegmentOff (RegAddrWidth (ArchReg arch)))
-> [MemSegmentOff (RegAddrWidth (ArchReg arch))]
forall a. Vector a -> [a]
V.toList Vector (MemSegmentOff (RegAddrWidth (ArchReg arch)))
entries
                           ]
                         , newFunctionAddrs :: [MemSegmentOff (RegAddrWidth (ArchReg arch))]
Parsed.newFunctionAddrs = []
                         }