{-# 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
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)
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
-> [[MemChunk w]]
-> Integer
-> [MemChunk w]
-> 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
:: MemWidth w
=> Int
-> Integer
-> [MemChunk w]
-> 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
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
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)
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)
| 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
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
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 :: 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))
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)
extractJumpTableSlices :: ArchConstraints arch
=> Jmp.IntraJumpBounds arch ids
-> ArchSegmentOff arch
-> Natural
-> BVValue arch ids idxWidth
-> MemRepr tp
-> Info.Classifier (V.Vector [MemChunk (ArchAddrWidth arch)])
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)
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
Right contents <- pure $ segoffContentsAfter base
Right (strideSlices,_) <- pure $ sliceMemContents (fromIntegral stride) cnt contents
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
:: ArchConstraints arch
=> Memory (ArchAddrWidth arch)
-> AbsProcessorState (ArchReg arch) ids
-> Jmp.IntraJumpBounds arch ids
-> Value arch ids tp
-> 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
when (memReprBytes tp > stride) $ do
fail "Stride does not cover size of relocation."
let stridew :: Word64
stridew = Natural -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
stride
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
:: 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
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)
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
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
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)
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 = []
}