{-# 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
    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 = 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] -> String
unwords [ Word8 -> String -> String
forall a. Integral a => a -> String -> String
showHex Word8
w String
"" | Word8
w <- ByteString -> [Word8]
BS.unpack ByteString
bs ]

    tgt <- case asSegmentOff mem (toIPAligned @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)

    unless (Perm.isExecutable (segmentFlags (segoffSegment tgt))) $ do
      Left "Address is not executable."

    Right 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
            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)
            pure $! segoffAddr addr & incAddr (toInteger (relocationOffset r))
          SegmentBaseAddr SectionIndex
idx -> do
            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)
            pure $! segmentOffAddr seg (relocationOffset 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) ZonkAny 0 (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
  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 (ZonkAny 1) -> String
forall a. Show a => a -> String
show (BVValue arch ids idxWidth -> Doc (ZonkAny 1)
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 (ZonkAny 2) -> String
forall a. Show a => a -> String
show (IntraJumpBounds arch ids -> Doc (ZonkAny 2)
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 contents <- pure $ segoffContentsAfter base
  -- Break up contents into a list of slices each with size stide
  Right (strideSlices,_) <- pure $ sliceMemContents (fromIntegral stride) cnt contents
  -- Get memory slices
  Right slices <-
    pure $ 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)))
                    (V.fromList strideSlices)
  pure 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 _ (ReadMem addr 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 (base, offset) <- pure $ valueAsMemOffset mem aps addr
  Just (stride, ixVal) <- pure $ valueAsStaticMultiplication offset
   -- Check stride covers at least number of bytes read.
  when (memReprBytes tp > stride) $ do
    fail "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 = Natural -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
stride
  -- Take the given number of bytes out of each slices
  slices <- extractJumpTableSlices jmpBounds base stride ixVal tp

  let 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
          }
  pure  (r, 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
  bcc <- BlockClassifierM arch ids (BlockClassifierContext arch ids)
forall r (m :: Type -> Type). MonadReader r m => m r
CMR.ask
  let 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 = 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 = 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 = 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
  (arrayRead, idx) <- Info.liftClassifier $ matchBoundedMemArray mem aps jmpBounds ip
  unless (Parsed.isReadOnlyBoundedMemArray arrayRead) $ do
    fail "Bounded mem array is not read only."
  endianness <-
    case Parsed.arEltType 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
entryIndex [MemChunk (RegAddrWidth (ArchReg arch))]
contents = do
        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."
        tgt <- case asSegmentOff mem (toIPAligned @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
        unless (Perm.isExecutable (segmentFlags (segoffSegment tgt))) $
          fail $ "Jump table contents non-executable."
        pure tgt
  tbl <- Info.liftClassifier $ V.zipWithM go (V.generate (V.length (Parsed.arSlices arrayRead)) id) (Parsed.arSlices arrayRead)
  pure (Parsed.AbsoluteJumpTable arrayRead, tbl, 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
  bcc <- BlockClassifierM arch ids (BlockClassifierContext arch ids)
forall r (m :: Type -> Type). MonadReader r m => m r
CMR.ask
  let 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 = 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 = 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 = 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 unalignedIP <- pure $ fromIPAligned ip
  (tgtBase, tgtOffset) <-
    case valueAsMemOffset mem aps 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 shortOffset ext <- pure $ matchExtension tgtOffset
  (arrayRead, idx) <- Info.liftClassifier $ matchBoundedMemArray mem aps jmpBounds shortOffset
  unless (Parsed.isReadOnlyBoundedMemArray arrayRead) $ do
    fail $ "Jump table memory array must be read only."
  tbl <- case resolveRelativeJumps mem tgtBase arrayRead 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
  pure (Parsed.RelativeJumpTable tgtBase arrayRead ext, tbl, 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
  bcc <- BlockClassifierM arch ids (BlockClassifierContext arch ids)
forall r (m :: Type -> Type). MonadReader r m => m r
CMR.ask
  let ctx = BlockClassifierContext arch ids -> ParseContext arch ids
forall arch ids.
BlockClassifierContext arch ids -> ParseContext arch ids
Info.classifierParseContext BlockClassifierContext arch ids
bcc
  let ainfo = ParseContext arch ids -> ArchitectureInfo arch
forall arch ids. ParseContext arch ids -> ArchitectureInfo arch
Info.pctxArchInfo ParseContext arch ids
ctx
  let jmpBounds = BlockClassifierContext arch ids -> IntraJumpBounds arch ids
forall arch ids.
BlockClassifierContext arch ids -> IntraJumpBounds arch ids
Info.classifierJumpBounds BlockClassifierContext arch ids
bcc
  Info.withArchConstraints ainfo $ do
    let 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
    (layout, entries, jumpIndex) <- jumpTableClassifiers

    let 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 = 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 = 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
    pure $ seq abst $
      Parsed.ParsedContents { Parsed.parsedNonterm = F.toList (Info.classifierStmts bcc)
                         , Parsed.parsedTerm = term
                         , Parsed.writtenCodeAddrs = Info.classifierWrittenAddrs bcc
                         , Parsed.intraJumpTargets =
                           [ (tgtAddr, abst & setAbsIP tgtAddr, nextBnds)
                           | tgtAddr <- V.toList entries
                           ]
                         , Parsed.newFunctionAddrs = []
                         }