GaloisInc/macaw
1
1
Fork 0
mirror of https://github.com/GaloisInc/macaw.git synced 2024-12-29 17:17:05 +03:00
Code Issues Projects Releases Wiki Activity

Change memory addresses.

Browse Source 
This changes the way memory addresses are represented to fix bugs
that could arrise if one can jump between two segments.  It replaces
the SegmentAddr type with two types:

* `MemAddr w` represents an address that is not necessarily valid.  It
  could either be an absolute address or an address relative to some
  non-fixed segment.
* `MemSegmentOff w` represents a legal offset into a memory segment.
  It must point to at least one valid byte of memory.
This commit is contained in:
Joe Hendrix 2017-07-17 15:37:05 -07:00
parent 0e66a3dfea
commit 2eaa823372
No known key found for this signature in database
GPG Key ID: 8DFA5FF784098C4F
15 changed files with 637 additions and 574 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
macaw-symbolic/src/Data/Macaw/Symbolic/App.hs
View File

@ -173,7 +173,7 @@ liftST :: ST s r -> CrucGen arch ids s r
liftST m = CrucGen $ \s cont -> m >>= cont s
getPos :: CrucGen arch ids s C.Position
getPos = undefined
getPos = C.BinaryPos <$> gets binaryPath <*> gets codeAddr
addStmt :: C.Stmt s -> CrucGen arch ids s ()
addStmt stmt = seq stmt $ do

157
src/Data/Macaw/AbsDomain/AbsState.hs
View File

@ -39,6 +39,7 @@ module Data.Macaw.AbsDomain.AbsState
, codePointerSet
, AbsDomain(..)
, AbsProcessorState
, absMem
, curAbsStack
, absInitialRegs
, indexBounds
@ -68,7 +69,7 @@ import Data.Int
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Parameterized.Classes (EqF(..), OrdF(..), ShowF(..))
import Data.Parameterized.Classes (EqF(..), ShowF(..))
import Data.Parameterized.Map (MapF)
import qualified Data.Parameterized.Map as MapF
import Data.Parameterized.NatRepr
@ -137,13 +138,15 @@ data AbsValue w (tp :: Type)
-- ^ A Boolean constant
| forall n . (tp ~ BVType n) => FinSet !(Set Integer)
-- ^ Denotes that this value can take any one of the fixed set.
| (tp ~ BVType w) => CodePointers !(Set (SegmentedAddr w)) !Bool
-- ^ A possibly empty set of values that either point to a code segment.
-- This Boolean indicates whether this set contains the address 0.
| (tp ~ BVType w) => StackOffset !(SegmentedAddr w) !(Set Int64)
| (tp ~ BVType w) => CodePointers !(Set (MemSegmentOff w)) !Bool
-- ^ Represents that all values point to a bounded set of
-- addresses in an executable segment or the constant zero. The
-- set contains the possible addresses, and the Boolean indicates
-- whether this set contains the address 0.
| (tp ~ BVType w) => StackOffset !(MemAddr w) !(Set Int64)
-- ^ Offset of stack from the beginning of the block at the given address.
-- First argument is address of block.
| (tp ~ BVType w) => SomeStackOffset !(SegmentedAddr w)
| (tp ~ BVType w) => SomeStackOffset !(MemAddr w)
-- ^ An offset to the stack at some offset.
| forall n . (tp ~ BVType n) => StridedInterval !(SI.StridedInterval n)
-- ^ A strided interval
@ -172,16 +175,15 @@ data SomeFinSet tp where
-- | Given a segmented addr and flag indicating if zero is contained return the underlying
-- integer set and the set of addresses that had no base.
partitionAbsoluteAddrs :: MemWidth w
=> Set (SegmentedAddr w)
=> Set (MemSegmentOff w)
-> Bool
-> (Set Integer, Set (SegmentedAddr w))
-> (Set Integer, Set (MemSegmentOff w))
partitionAbsoluteAddrs addrSet b = foldl' f (s0, Set.empty) addrSet
where s0 = if b then Set.singleton 0 else Set.empty
f (intSet,badSet) addr =
case segmentBase (addrSegment addr) of
Just base -> seq intSet' $ (intSet', badSet)
where intSet' = Set.insert w intSet
w = toInteger base + toInteger (addr^.addrOffset)
case msegAddr addr of
Just addrVal -> seq intSet' $ (intSet', badSet)
where intSet' = Set.insert (toInteger addrVal) intSet
Nothing -> seq badSet' $ (intSet, badSet')
where badSet' = Set.insert addr badSet
@ -197,13 +199,11 @@ asFinSet _ (CodePointers s True)
| Set.null s = IsFin (Set.singleton 0)
asFinSet nm (CodePointers addrSet b) = go (Set.toList addrSet) $! s0
where s0 = if b then Set.singleton 0 else Set.empty
go :: [SegmentedAddr w] -> Set Integer -> SomeFinSet (BVType w)
go :: [MemSegmentOff w] -> Set Integer -> SomeFinSet (BVType w)
go [] s = debug DAbsInt ("dropping Codeptr " ++ nm) $ IsFin s
go (a:r) s =
case segmentBase (addrSegment a) of
Just base -> go r $! s'
where v = toInteger base + toInteger (a^.addrOffset)
s' = Set.insert v s
go (seg_off: r) s =
case msegAddr seg_off of
Just addr -> go r $! Set.insert (toInteger addr) s
Nothing -> NotFin
asFinSet _ _ = NotFin
@ -214,7 +214,7 @@ asFinSet _ _ = NotFin
-- | otherwise = debug DAbsInt ("dropping Codeptr " ++ nm) $ Just s
-- asFinSet64 _ _ = Nothing
codePointerSet :: AbsValue w tp -> Set (SegmentedAddr w)
codePointerSet :: AbsValue w tp -> Set (MemSegmentOff w)
codePointerSet (CodePointers s _) = s
codePointerSet _ = Set.empty
@ -240,10 +240,10 @@ instance Eq (AbsValue w tp) where
instance EqF (AbsValue w) where
eqF = (==)
instance Show (AbsValue w tp) where
instance MemWidth w => Show (AbsValue w tp) where
show = show . pretty
instance Pretty (AbsValue w tp) where
instance MemWidth w => Pretty (AbsValue w tp) where
pretty (BoolConst b) = text (show b)
pretty (FinSet s) = text "finset" <+> ppIntegerSet s
pretty (CodePointers s b) = text "code" <+> ppSet (s0 ++ sd)
@ -277,9 +277,9 @@ ppIntegerSet s = ppSet (ppv <$> Set.toList s)
concretize :: MemWidth w => AbsValue w tp -> Maybe (Set Integer)
concretize (FinSet s) = Just s
concretize (CodePointers s b) = Just $ Set.fromList $
[ toInteger base + toInteger (addr^.addrOffset)
| addr <- Set.toList s
, base <- maybeToList (segmentBase (addrSegment addr))
[ toInteger addr
| mseg <- Set.toList s
, addr <- maybeToList (msegAddr mseg)
]
++ (if b then [0] else [])
concretize (SubValue _ _) = Nothing -- we know nothing about _all_ values
@ -331,9 +331,6 @@ isEmpty _ = False
-------------------------------------------------------------------------------
-- Joining abstract values
ppSegAddrSet :: Set (SegmentedAddr w) -> Doc
ppSegAddrSet s = ppSet (text . show <$> Set.toList s)
-- | Join the old and new states and return the updated state iff
-- the result is larger than the old state.
-- This also returns any addresses that are discarded during joining.
@ -345,9 +342,9 @@ joinAbsValue x y
| Set.null s = r
| otherwise = debug DAbsInt ("dropping " ++ show dropped ++ "\n" ++ show x ++ "\n" ++ show y ++ "\n") r
where (r,s) = runState (joinAbsValue' x y) Set.empty
dropped = ppSegAddrSet s
dropped = ppSet (text . show <$> Set.toList s)
addWords :: Set (SegmentedAddr w) -> State (Set (SegmentedAddr w)) ()
addWords :: Set (MemSegmentOff w) -> State (Set (MemSegmentOff w)) ()
addWords s = modify $ Set.union s
-- | Join the old and new states and return the updated state iff
@ -356,7 +353,7 @@ addWords s = modify $ Set.union s
joinAbsValue' :: MemWidth w
=> AbsValue w tp
-> AbsValue w tp
-> State (Set (SegmentedAddr w)) (Maybe (AbsValue w tp))
-> State (Set (MemSegmentOff w)) (Maybe (AbsValue w tp))
joinAbsValue' TopV x = do
addWords (codePointerSet x)
return $! Nothing
@ -630,7 +627,7 @@ bvsub :: forall w u
-> AbsValue w (BVType u)
-> AbsValue w (BVType u)
-> AbsValue w (BVType u)
bvsub _mem w (CodePointers s b) (FinSet t)
bvsub mem w (CodePointers s b) (FinSet t)
-- If we just have zero.
| Set.null s && b = FinSet (Set.map (toUnsigned w . negate) t)
| all isJust vals && (not b || Set.singleton 0 == t) =
@ -639,15 +636,16 @@ bvsub _mem w (CodePointers s b) (FinSet t)
-- TODO: Fix this.
-- debug DAbsInt ("drooping " ++ show (ppIntegerSet s) ++ " " ++ show (ppIntegerSet t)) $
-- setL (stridedInterval . SI.fromFoldable w) FinSet (toInteger <$> vals)
where vals :: [Maybe (SegmentedAddr w)]
where vals :: [Maybe (MemSegmentOff w)]
vals = do
x <- Set.toList s
y <- Set.toList t
if toInteger (x^.addrOffset) >= y then
return $ Just $ x & addrOffset -~ fromInteger y
else
return $ Nothing
let z = relativeSegmentAddr x & incAddr (negate y)
case asSegmentOff mem z of
Just z_mseg | segmentFlags (msegSegment z_mseg) `Perm.hasPerm` Perm.execute ->
pure (Just z_mseg)
_ ->
pure Nothing
bvsub _ _ xv@(CodePointers xs xb) (CodePointers ys yb)
-- If we just have zero.
| Set.null ys && yb = xv
@ -665,10 +663,7 @@ bvsub _ _ xv@(CodePointers xs xb) (CodePointers ys yb)
vals = do
x <- Set.toList xs
y <- Set.toList ys
if segmentIndex (addrSegment x) == segmentIndex (addrSegment y) then
pure $ Just $ toInteger (x^.addrOffset) - toInteger (y^.addrOffset)
else do
pure $ Nothing
pure (relativeSegmentAddr x `diffAddr` relativeSegmentAddr y)
bvsub _ w (FinSet s) (asFinSet "bvsub3" -> IsFin t) =
setL (stridedInterval . SI.fromFoldable w) FinSet $ do
x <- Set.toList s
@ -719,10 +714,12 @@ bvmul _ _ _ = TopV
bvand :: MemWidth w
=> NatRepr u
-> AbsValue w (BVType u)
-> AbsValue w (BVType u)
-> AbsValue w (BVType u)
bvand _w (asFinSet "bvand" -> IsFin s) (asConcreteSingleton -> Just v) = FinSet (Set.map (flip (.&.) v) s)
bvand _w (asConcreteSingleton -> Just v) (asFinSet "bvand" -> IsFin s) = FinSet (Set.map ((.&.) v) s)
-> AbsValue w (BVType u)
bvand _w (asFinSet "bvand" -> IsFin s) (asConcreteSingleton -> Just v) =
FinSet (Set.map (flip (.&.) v) s)
bvand _w (asConcreteSingleton -> Just v) (asFinSet "bvand" -> IsFin s) =
FinSet (Set.map ((.&.) v) s)
bvand _ _ _ = TopV
-- FIXME: generalise
@ -738,12 +735,12 @@ bitop doOp _w (asConcreteSingleton -> Just v) (asFinSet "bvand" -> IsFin s)
= FinSet (Set.map (doOp v) s)
bitop _ _ _ _ = TopV
ppAbsValue :: AbsValue w tp -> Maybe Doc
ppAbsValue :: MemWidth w => AbsValue w tp -> Maybe Doc
ppAbsValue TopV = Nothing
ppAbsValue v = Just (pretty v)
-- | Print a list of Docs vertically separated.
instance ShowF r => PrettyRegValue r (AbsValue w) where
instance (MemWidth w, ShowF r) => PrettyRegValue r (AbsValue w) where
ppValueEq _ TopV = Nothing
ppValueEq r v = Just (text (showF r) <+> text "=" <+> pretty v)
@ -757,23 +754,21 @@ absFalse = BoolConst False
-- | This returns the smallest abstract value that contains the
-- given unsigned integer.
abstractSingleton :: MemWidth w
=> NatRepr w
=> Memory w
-- ^ Width of code pointer
-> (MemWord w -> Maybe (SegmentedAddr w))
-- ^ Predicate that recognizes if the given value is a code
-- pointer.
-> NatRepr n
-> Integer
-> AbsValue w (BVType n)
abstractSingleton code_w is_code w i
| Just Refl <- testEquality w code_w
abstractSingleton mem w i
| Just Refl <- testEquality w (memWidth mem)
, 0 <= i && i <= maxUnsigned w
, Just sa <- is_code (fromInteger i) =
, Just sa <- resolveAbsoluteAddr mem (fromInteger i)
, segmentFlags (msegSegment sa) `Perm.hasPerm` Perm.execute =
CodePointers (Set.singleton sa) False
| 0 <= i && i <= maxUnsigned w = FinSet (Set.singleton i)
| otherwise = error $ "abstractSingleton given bad value: " ++ show i ++ " " ++ show w
concreteStackOffset :: SegmentedAddr w -> Integer -> AbsValue w (BVType w)
concreteStackOffset :: MemAddr w -> Integer -> AbsValue w (BVType w)
concreteStackOffset a o = StackOffset a (Set.singleton (fromInteger o))
------------------------------------------------------------------------
@ -869,7 +864,7 @@ type AbsBlockStack w = Map Int64 (StackEntry w)
absStackJoinD :: MemWidth w
=> AbsBlockStack w
-> AbsBlockStack w
-> State (Bool,Set (SegmentedAddr w)) (AbsBlockStack w)
-> State (Bool,Set (MemSegmentOff w)) (AbsBlockStack w)
absStackJoinD y x = do
-- This attempts to merge information from the new state into the old state.
let entryLeq (o, StackEntry y_tp y_v) =
@ -912,7 +907,7 @@ showSignedHex :: Integer -> ShowS
showSignedHex x | x < 0 = showString "-0x" . showHex (negate x)
| otherwise = showString "0x" . showHex x
ppAbsStack :: AbsBlockStack w -> Doc
ppAbsStack :: MemWidth w => AbsBlockStack w -> Doc
ppAbsStack m = vcat (pp <$> Map.toDescList m)
where pp (o,StackEntry _ v) = text (showSignedHex (toInteger o) " :=") <+> pretty v
@ -978,6 +973,7 @@ instance ( RegisterInfo r
}
instance ( ShowF r
, MemWidth (RegAddrWidth r)
) => Pretty (AbsBlockState r) where
pretty s =
text "registers:" <$$>
@ -990,12 +986,12 @@ instance ( ShowF r
indent 2 (ppAbsStack stack)
jmp_bnds = pretty (s^.initIndexBounds)
instance ShowF r => Show (AbsBlockState r) where
instance (ShowF r, MemWidth (RegAddrWidth r)) => Show (AbsBlockState r) where
show = show . pretty
-- | Update the block state to point to a specific IP address.
setAbsIP :: RegisterInfo r
=> SegmentedAddr (RegAddrWidth r)
=> MemSegmentOff (RegAddrWidth r)
-- ^ The address to set.
-> AbsBlockState r
-> AbsBlockState r
@ -1031,10 +1027,6 @@ data AbsProcessorState r ids
, _indexBounds :: !(Jmp.IndexBounds r ids)
}
-- | The width of an address
absCodeWidth :: AbsProcessorState r ids -> NatRepr (RegAddrWidth r)
absCodeWidth = memWidth . absMem
absInitialRegs :: Simple Lens (AbsProcessorState r ids)
(RegState r (AbsValue (RegAddrWidth r)))
absInitialRegs = lens _absInitialRegs (\s v -> s { _absInitialRegs = v })
@ -1050,12 +1042,8 @@ curAbsStack = lens _curAbsStack (\s v -> s { _curAbsStack = v })
indexBounds :: Simple Lens (AbsProcessorState r ids) (Jmp.IndexBounds r ids)
indexBounds = lens _indexBounds (\s v -> s { _indexBounds = v })
instance ShowF r
=> Show (AbsProcessorState r ids) where
show = show . pretty
-- FIXME
instance (ShowF r)
instance (ShowF r, MemWidth (RegAddrWidth r))
=> Pretty (AbsProcessorState r ids) where
pretty s =
text "registers:" <$$>
@ -1066,6 +1054,10 @@ instance (ShowF r)
| otherwise = text "stack:" <$$>
indent 2 (ppAbsStack stack)
instance (ShowF r, MemWidth (RegAddrWidth r))
=> Show (AbsProcessorState r ids) where
show = show . pretty
initAbsProcessorState :: Memory (RegAddrWidth r)
-- ^ Current state of memory in the processor.
--
@ -1111,31 +1103,30 @@ pruneStack = Map.filter f
-- Transfer Value
-- | Compute abstract value from value and current registers.
transferValue :: ( OrdF (ArchReg a)
, ShowF (ArchReg a)
, MemWidth (ArchAddrWidth a)
transferValue :: forall a ids tp
. ( RegisterInfo (ArchReg a)
, HasCallStack
)
=> AbsProcessorState (ArchReg a) ids
-> Value a ids tp
-> ArchAbsValue a tp
transferValue c v = do
let code_width = absCodeWidth c
is_code addr = do
sa <- absoluteAddrSegment (absMem c) addr
if segmentFlags (addrSegment sa) `Perm.hasPerm` Perm.execute then
Just $! sa
else
Nothing
amap = c^.absAssignments
let amap = c^.absAssignments
aregs = c^.absInitialRegs
case v of
BoolValue b -> BoolConst b
BVValue w i
| 0 <= i && i <= maxUnsigned w -> abstractSingleton code_width is_code w i
| 0 <= i && i <= maxUnsigned w -> abstractSingleton (absMem c) w i
| otherwise -> error $ "transferValue given illegal value " ++ show (pretty v)
-- TODO: Ensure a relocatable value is in code.
RelocatableValue _w i -> CodePointers (Set.singleton i) False
RelocatableValue _w i
| Just addr <- asSegmentOff (absMem c) i
, segmentFlags (msegSegment addr) `Perm.hasPerm` Perm.execute ->
CodePointers (Set.singleton addr) False
| Just addr <- asAbsoluteAddr i ->
FinSet $ Set.singleton $ toInteger addr
| otherwise ->
TopV
-- Invariant: v is in m
AssignedValue a ->
fromMaybe (error $ "Missing assignment for " ++ show (assignId a))
@ -1212,9 +1203,7 @@ finalAbsBlockState c s =
------------------------------------------------------------------------
-- Transfer functions
transferApp :: ( OrdF (ArchReg a)
, ShowF (ArchReg a)
, MemWidth (ArchAddrWidth a)
transferApp :: ( RegisterInfo (ArchReg a)
, HasCallStack
)
=> AbsProcessorState (ArchReg a) ids
@ -1248,7 +1237,7 @@ absEvalCall :: forall r
-- ^ Configuration
-> AbsBlockState r
-- ^ State before call
-> SegmentedAddr (RegAddrWidth r)
-> MemSegmentOff (RegAddrWidth r)
-- ^ Address we are jumping to
-> AbsBlockState r
absEvalCall params ab0 addr =

9
src/Data/Macaw/AbsDomain/Refine.hs
View File

@ -24,15 +24,14 @@ import Data.Parameterized.NatRepr
import Data.Macaw.AbsDomain.AbsState
import Data.Macaw.CFG
import Data.Macaw.Memory (MemWidth)
import Data.Macaw.Types
-- | Constraints needed for refinement on abstract states.
type RefineConstraints arch
= ( OrdF (ArchReg arch)
, ShowF (ArchReg arch)
, HasRepr (ArchReg arch) TypeRepr
, MemWidth (ArchAddrWidth arch)
= ( RegisterInfo (ArchReg arch)
-- , ShowF (ArchReg arch)
-- , HasRepr (ArchReg arch) TypeRepr
-- , MemWidth (ArchAddrWidth arch)
)
-- FIXME: if val \notin av then we should return bottom

17
src/Data/Macaw/Architecture/Info.hs
View File

@ -36,10 +36,11 @@ import Data.Macaw.Memory
-- block.
type DisassembleFn arch
= forall ids
. NonceGenerator (ST ids) ids
-> SegmentedAddr (ArchAddrWidth arch)
-- ^ Segment that we are disassembling from
-> MemWord (ArchAddrWidth arch)
. Memory (ArchAddrWidth arch)
-> NonceGenerator (ST ids) ids
-> ArchSegmentOff arch
-- ^ The offset to start reading from.
-> ArchAddrWord arch
-- ^ Maximum offset for this to read from.
-> AbsBlockState (ArchReg arch)
-- ^ Abstract state associated with address that we are disassembling
@ -66,10 +67,12 @@ data ArchitectureInfo arch
-- ^ Return true if architecture register should be preserved across a system call.
, mkInitialAbsState :: !(Memory (RegAddrWidth (ArchReg arch))
-> SegmentedAddr (RegAddrWidth (ArchReg arch))
-> ArchSegmentOff arch
-> AbsBlockState (ArchReg arch))
-- ^ Creates an abstract block state for representing the beginning of a
-- function.
--
-- The address is the entry point of the function.
, absEvalArchFn :: !(forall ids tp
. AbsProcessorState (ArchReg arch) ids
-> ArchFn arch ids tp
@ -81,7 +84,7 @@ data ArchitectureInfo arch
-> AbsProcessorState (ArchReg arch) ids)
-- ^ Evaluates an architecture-specific statement
, postCallAbsState :: AbsBlockState (ArchReg arch)
-> SegmentedAddr (RegAddrWidth (ArchReg arch))
-> ArchSegmentOff arch
-> AbsBlockState (ArchReg arch)
-- ^ Update the abstract state after a function call returns
, identifyReturn :: forall ids
@ -106,7 +109,7 @@ data ArchitectureInfo arch
archPostSyscallAbsState :: ArchitectureInfo arch
-- ^ Architecture information
-> AbsBlockState (ArchReg arch)
-> SegmentedAddr (RegAddrWidth (ArchReg arch))
-> ArchSegmentOff arch
-> AbsBlockState (ArchReg arch)
archPostSyscallAbsState info = withArchConstraints info $ AbsState.absEvalCall params
where params = CallParams { postCallStackDelta = 0

2
src/Data/Macaw/CFG.hs
View File

@ -7,7 +7,7 @@ This exports the main CFG modules
module Data.Macaw.CFG
( module Data.Macaw.CFG.Core
, module Data.Macaw.CFG.App
, Data.Macaw.Memory.SegmentedAddr
, Data.Macaw.Memory.MemAddr
) where
import Data.Macaw.CFG.App

13
src/Data/Macaw/CFG/Block.hs
View File

@ -8,10 +8,10 @@ types.
{-# LANGUAGE FlexibleContexts #-}
module Data.Macaw.CFG.Block
( Block(..)
, ppBlock
, TermStmt(..)
) where
import Data.Parameterized.Classes
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Word
@ -44,8 +44,7 @@ data TermStmt arch ids
-- occured and the error message recorded.
| TranslateError !(RegState (ArchReg arch) (Value arch ids)) !Text
instance ( OrdF (ArchReg arch)
, ShowF (ArchReg arch)
instance ( RegisterInfo(ArchReg arch)
)
=> Pretty (TermStmt arch ids) where
pretty (FetchAndExecute s) =
@ -75,7 +74,7 @@ data Block arch ids
-- ^ The last statement in the block.
}
instance ArchConstraints arch => Pretty (Block arch ids) where
pretty b = do
text (show (blockLabel b)) PP.<> text ":" <$$>
indent 2 (vcat (pretty <$> blockStmts b) <$$> pretty (blockTerm b))
ppBlock :: ArchConstraints arch => Block arch ids -> Doc
ppBlock b =
text (show (blockLabel b)) PP.<> text ":" <$$>
indent 2 (vcat (ppStmt (text . show) <$> blockStmts b) <$$> pretty (blockTerm b))

81
src/Data/Macaw/CFG/Core.hs
View File

@ -54,16 +54,15 @@ module Data.Macaw.CFG.Core
, ppAssignId
, ppLit
, ppValue
, ppStmt
, PrettyF(..)
, ArchConstraints(..)
, PrettyRegValue(..)
-- * Architecture type families
, ArchAddr
, ArchSegmentedAddr
, ArchFn
, ArchReg
, ArchStmt
, RegAddr
, RegAddrWord
, RegAddrWidth
-- * RegisterInfo
, RegisterInfo(..)
@ -77,6 +76,9 @@ module Data.Macaw.CFG.Core
-- ** Synonyms
, ArchAddrWidth
, ArchAddrValue
, ArchAddrWord
, ArchMemAddr
, ArchSegmentOff
) where
import Control.Exception (assert)
@ -103,7 +105,7 @@ import Numeric (showHex)
import Text.PrettyPrint.ANSI.Leijen as PP hiding ((<$>))
import Data.Macaw.CFG.App
import Data.Macaw.Memory (MemWord, MemWidth, SegmentedAddr(..), Endianness(..))
import Data.Macaw.Memory (MemWord, MemWidth, MemAddr, MemSegmentOff, Endianness(..))
import Data.Macaw.Types
-- Note:
@ -172,8 +174,8 @@ instance Show (AssignId ids tp) where
-- | Width of register used to store addresses.
type family RegAddrWidth (r :: Type -> *) :: Nat
-- | The value used to store
type RegAddr r = MemWord (RegAddrWidth r)
-- | A word for the given architecture register type.
type RegAddrWord r = MemWord (RegAddrWidth r)
-- | Type family for defining what a "register" is for this architecture.
--
@ -194,18 +196,19 @@ type family ArchFn (arch :: *) :: * -> Type -> *
--
-- The second type parameter is the ids phantom type used to provide
-- uniqueness of Nonce values that identify assignments.
--
type family ArchStmt (arch :: *) :: * -> *
-- | The type to use for addresses on the architecutre.
type ArchAddr arch = RegAddr (ArchReg arch)
-- | Number of bits in addreses for architecture.
-- | Number of bits in addreses for architecture.
type ArchAddrWidth arch = RegAddrWidth (ArchReg arch)
-- | A segmented addr for a given architecture.
type ArchSegmentedAddr arch = SegmentedAddr (ArchAddrWidth arch)
-- | A word for the given architecture bitwidth.
type ArchAddrWord arch = RegAddrWord (ArchReg arch)
-- | A segmented addr for a given architecture.
type ArchMemAddr arch = MemAddr (ArchAddrWidth arch)
-- | A pair containing a segment and valid offset within the segment.
type ArchSegmentOff arch = MemSegmentOff (ArchAddrWidth arch)
------------------------------------------------------------------------
-- Value, Assignment, AssignRhs declarations.
@ -222,8 +225,8 @@ data Value arch ids tp
| ( tp ~ BVType (ArchAddrWidth arch)
, 1 <= ArchAddrWidth arch
)
=> RelocatableValue !(NatRepr (ArchAddrWidth arch)) !(ArchSegmentedAddr arch)
-- ^ A given memory address.
=> RelocatableValue !(NatRepr (ArchAddrWidth arch)) !(ArchMemAddr arch)
-- ^ A legal memory address
| AssignedValue !(Assignment arch ids tp)
-- ^ Value from an assignment statement.
| Initial !(ArchReg arch tp)
@ -493,7 +496,7 @@ mkRegStateM f = RegState . MapF.fromList <$> traverse g archRegs
where g (Some r) = MapF.Pair r <$> f r
-- Create a pure register state
mkRegState :: RegisterInfo r -- AbsRegState r
mkRegState :: RegisterInfo r
=> (forall tp . r tp -> f tp)
-> RegState r f
mkRegState f = runIdentity (mkRegStateM (return . f))
@ -530,20 +533,20 @@ ppLit w i
| otherwise = error "ppLit given negative value"
-- | Pretty print a value.
ppValue :: ShowF (ArchReg arch) => Prec -> Value arch ids tp -> Doc
ppValue :: RegisterInfo (ArchReg arch) => Prec -> Value arch ids tp -> Doc
ppValue _ (BoolValue b) = text $ if b then "true" else "false"
ppValue p (BVValue w i) = assert (i >= 0) $ parenIf (p > colonPrec) $ ppLit w i
ppValue p (RelocatableValue _ a) = parenIf (p > plusPrec) $ text (show a)
ppValue _ (AssignedValue a) = ppAssignId (assignId a)
ppValue _ (Initial r) = text (showF r) PP.<> text "_0"
instance ShowF (ArchReg arch) => PrettyPrec (Value arch ids tp) where
instance RegisterInfo (ArchReg arch) => PrettyPrec (Value arch ids tp) where
prettyPrec = ppValue
instance ShowF (ArchReg arch) => Pretty (Value arch ids tp) where
instance RegisterInfo (ArchReg arch) => Pretty (Value arch ids tp) where
pretty = ppValue 0
instance ShowF (ArchReg arch) => Show (Value arch ids tp) where
instance RegisterInfo (ArchReg arch) => Show (Value arch ids tp) where
show = show . pretty
class ( RegisterInfo (ArchReg arch)
@ -648,8 +651,7 @@ instance ( PrettyRegValue r f
=> Show (RegState r f) where
show s = show (pretty s)
instance ( OrdF r
, ShowF r
instance ( RegisterInfo r
, r ~ ArchReg arch
)
=> PrettyRegValue r (Value arch ids) where
@ -668,22 +670,39 @@ data Stmt arch ids
-- ^ This denotes a write to memory, and consists of an address to write to, a `MemRepr` defining
-- how the value should be stored in memory, and the value to be written.
| PlaceHolderStmt !([Some (Value arch ids)]) !String
-- ^ A placeholder to indicate something the
-- architecture-specific backend does not support.
--
-- Note that we plan to remove this eventually
| InstructionStart !(ArchAddrWord arch) !Text
-- ^ The start of an instruction
--
-- The information includes the offset relative to the start of the block and the
-- disassembler output if available (or empty string if unavailable)
| Comment !Text
-- ^ A user-level comment
| ExecArchStmt !(ArchStmt arch ids)
-- ^ Execute an architecture specific statement
instance ArchConstraints arch => Pretty (Stmt arch ids) where
pretty (AssignStmt a) = pretty a
pretty (WriteMem a _ rhs) = text "*" PP.<> prettyPrec 11 a <+> text ":=" <+> ppValue 0 rhs
pretty (PlaceHolderStmt vals name) = text ("PLACEHOLDER: " ++ name)
<+> parens (hcat $ punctuate comma
$ map (viewSome (ppValue 0)) vals)
pretty (Comment s) = text $ "# " ++ Text.unpack s
pretty (ExecArchStmt s) = prettyF s
ppStmt :: ArchConstraints arch
=> (ArchAddrWord arch -> Doc)
-- ^ Function for pretty printing an offset
-> Stmt arch ids
-> Doc
ppStmt ppOff stmt =
case stmt of
AssignStmt a -> pretty a
WriteMem a _ rhs -> text "*" PP.<> prettyPrec 11 a <+> text ":=" <+> ppValue 0 rhs
PlaceHolderStmt vals name ->
text ("PLACEHOLDER: " ++ name)
<+> parens (hcat $ punctuate comma $ viewSome (ppValue 0) <$> vals)
InstructionStart off mnem -> text "#" <+> ppOff off <+> text (Text.unpack mnem)
Comment s -> text $ "# " ++ Text.unpack s
ExecArchStmt s -> prettyF s
instance ArchConstraints arch => Show (Stmt arch ids) where
show = show . pretty
show = show . ppStmt (\w -> text (show w))
------------------------------------------------------------------------
-- References

3
src/Data/Macaw/CFG/DemandSet.hs
View File

@ -110,6 +110,8 @@ addStmtDemands s =
addValueDemands val
PlaceHolderStmt l _ ->
mapM_ (\(Some v) -> addValueDemands v) l
InstructionStart{} ->
pure ()
Comment _ ->
pure ()
ExecArchStmt astmt -> do
@ -126,5 +128,6 @@ stmtNeeded demandSet stmt =
AssignStmt a -> Set.member (Some (assignId a)) demandSet
WriteMem{} -> True
PlaceHolderStmt{} -> True
InstructionStart{} -> True
Comment{} -> True
ExecArchStmt{} -> True

9
src/Data/Macaw/CFG/Rewriter.hs
View File

@ -325,11 +325,14 @@ rewriteStmt s =
WriteMem addr repr val -> do
tgtAddr <- rewriteValue addr
tgtVal <- rewriteValue val
appendRewrittenStmt (WriteMem tgtAddr repr tgtVal)
appendRewrittenStmt $ WriteMem tgtAddr repr tgtVal
PlaceHolderStmt args nm -> do
args' <- traverse (traverseSome rewriteValue) args
appendRewrittenStmt (PlaceHolderStmt args' nm)
Comment cmt -> appendRewrittenStmt (Comment cmt)
appendRewrittenStmt $ PlaceHolderStmt args' nm
Comment cmt ->
appendRewrittenStmt $ Comment cmt
InstructionStart off mnem ->
appendRewrittenStmt $ InstructionStart off mnem
ExecArchStmt astmt -> do
f <- Rewriter $ gets $ rwctxArchStmt . rwContext
f astmt

204
src/Data/Macaw/Discovery.hs
View File

@ -48,7 +48,6 @@ module Data.Macaw.Discovery
, State.symbolAddrs
) where
import Control.Exception
import Control.Lens
import Control.Monad.ST
import Control.Monad.State.Strict
@ -94,18 +93,17 @@ import Data.Macaw.Types
concretizeAbsCodePointers :: MemWidth w
=> Memory w
-> AbsValue w (BVType w)
-> [SegmentedAddr w]
-> [MemSegmentOff w]
concretizeAbsCodePointers mem (FinSet s) =
[ sa
| a <- Set.toList s
, Just sa <- [absoluteAddrSegment mem (fromInteger a)]
, Perm.isExecutable (segmentFlags (addrSegment sa))
, sa <- maybeToList (resolveAbsoluteAddr mem (fromInteger a))
, segmentFlags (msegSegment sa) `Perm.hasPerm` Perm.execute
]
concretizeAbsCodePointers mem (CodePointers s _) =
concretizeAbsCodePointers _ (CodePointers s _) =
[ sa
| a <- Set.toList s
, Just sa <- [absoluteAddrSegment mem (_addrOffset a)]
, Perm.isExecutable (segmentFlags (addrSegment sa))
| sa <- Set.toList s
, segmentFlags (msegSegment sa) `Perm.hasPerm` Perm.execute
]
-- FIXME: this is dangerous !!
concretizeAbsCodePointers _mem StridedInterval{} = [] -- FIXME: this case doesn't make sense
@ -114,8 +112,8 @@ concretizeAbsCodePointers _mem StridedInterval{} = [] -- FIXME: this case doesn'
concretizeAbsCodePointers _mem _ = []
{-
printAddrBacktrace :: Map (ArchSegmentedAddr arch) (FoundAddr arch)
-> ArchSegmentedAddr arch
printAddrBacktrace :: Map (ArchMemAddr arch) (FoundAddr arch)
-> ArchMemAddr arch
-> CodeAddrReason (ArchAddrWidth arch)
-> [String]
printAddrBacktrace found_map addr rsn = do
@ -131,14 +129,13 @@ printAddrBacktrace found_map addr rsn = do
InitAddr -> [pp "Initial entry point."]
CodePointerInMem src -> [pp ("Memory address " ++ show src ++ " contained code.")]
SplitAt src -> pp ("Split from read of " ++ show src ++ ".") : prev src
InterProcedureJump src -> pp ("Reference from external address " ++ show src ++ ".") : prev src
-- | Return true if this address was added because of the contents of a global address
-- in memory initially.
--
-- This heuristic is not very accurate, so we avoid printing errors when it leads to
-- issues.
cameFromUnsoundReason :: Map (ArchSegmentedAddr arch) (FoundAddr arch)
cameFromUnsoundReason :: Map (ArchMemAddr arch) (FoundAddr arch)
-> CodeAddrReason (ArchAddrWidth arch)
-> Bool
cameFromUnsoundReason found_map rsn = do
@ -153,7 +150,6 @@ cameFromUnsoundReason found_map rsn = do
SplitAt src -> prev src
InitAddr -> False
CodePointerInMem{} -> True
InterProcedureJump src -> prev src
-}
------------------------------------------------------------------------
@ -221,14 +217,15 @@ elimDeadBlockStmts demandSet b =
-- Memory utilities
-- | Return true if range is entirely contained within a single read only segment.Q
rangeInReadonlySegment :: MemWidth w
=> SegmentedAddr w -- ^ Start of range
rangeInReadonlySegment :: Memory w
-> MemAddr w -- ^ Start of range
-> MemWord w -- ^ The size of the range
-> Bool
rangeInReadonlySegment base size
= base^.addrOffset + size <= segmentSize seg
&& Perm.isReadonly (segmentFlags seg)
where seg = addrSegment base
rangeInReadonlySegment mem base size = addrWidthClass (memAddrWidth mem) $
case asSegmentOff mem base of
Just mseg -> size <= segmentSize (msegSegment mseg) - msegOffset mseg
&& Perm.isReadonly (segmentFlags (msegSegment mseg))
Nothing -> False
------------------------------------------------------------------------
-- DiscoveryState utilities
@ -238,7 +235,7 @@ markAddrAsFunction :: CodeAddrReason (ArchAddrWidth arch)
-- ^ Information about why the code address was discovered
--
-- Used for debugging
-> ArchSegmentedAddr arch
-> ArchSegmentOff arch
-> DiscoveryState arch
-> DiscoveryState arch
markAddrAsFunction rsn addr s
@ -247,7 +244,7 @@ markAddrAsFunction rsn addr s
-- | Mark a list of addresses as function entries with the same reason.
markAddrsAsFunction :: CodeAddrReason (ArchAddrWidth arch)
-> [ArchSegmentedAddr arch]
-> [ArchSegmentOff arch]
-> DiscoveryState arch
-> DiscoveryState arch
markAddrsAsFunction rsn addrs s0 = foldl' (\s a -> markAddrAsFunction rsn a s) s0 addrs
@ -270,17 +267,17 @@ data FoundAddr arch
-- | The state for the function explroation monad
data FunState arch ids
= FunState { funNonceGen :: !(NonceGenerator (ST ids) ids)
, curFunAddr :: !(ArchSegmentedAddr arch)
, curFunAddr :: !(ArchSegmentOff arch)
, _curFunCtx :: !(DiscoveryState arch)
-- ^ Discovery state without this function
, _curFunBlocks :: !(Map (ArchSegmentedAddr arch) (ParsedBlock arch ids))
, _curFunBlocks :: !(Map (ArchSegmentOff arch) (ParsedBlock arch ids))
-- ^ Maps an address to the blocks associated with that address.
, _foundAddrs :: !(Map (ArchSegmentedAddr arch) (FoundAddr arch))
, _foundAddrs :: !(Map (ArchSegmentOff arch) (FoundAddr arch))
-- ^ Maps found address to the pre-state for that block.
, _reverseEdges :: !(ReverseEdgeMap arch)
-- ^ Maps each code address to the list of predecessors that
-- affected its abstract state.
, _frontier :: !(Set (ArchSegmentedAddr arch))
, _frontier :: !(Set (ArchSegmentOff arch))
-- ^ Addresses to explore next.
}
@ -289,26 +286,24 @@ curFunCtx :: Simple Lens (FunState arch ids) (DiscoveryState arch)
curFunCtx = lens _curFunCtx (\s v -> s { _curFunCtx = v })
-- | Information about current function we are working on
curFunBlocks :: Simple Lens (FunState arch ids) (Map (ArchSegmentedAddr arch) (ParsedBlock arch ids))
curFunBlocks :: Simple Lens (FunState arch ids) (Map (ArchSegmentOff arch) (ParsedBlock arch ids))
curFunBlocks = lens _curFunBlocks (\s v -> s { _curFunBlocks = v })
foundAddrs :: Simple Lens (FunState arch ids) (Map (ArchSegmentedAddr arch) (FoundAddr arch))
foundAddrs :: Simple Lens (FunState arch ids) (Map (ArchSegmentOff arch) (FoundAddr arch))
foundAddrs = lens _foundAddrs (\s v -> s { _foundAddrs = v })
type ReverseEdgeMap arch = Map (ArchSegmentedAddr arch) (Set (ArchSegmentedAddr arch))
type ReverseEdgeMap arch = Map (ArchSegmentOff arch) (Set (ArchSegmentOff arch))
-- | Maps each code address to the list of predecessors that
-- affected its abstract state.
reverseEdges :: Simple Lens (FunState arch ids) (ReverseEdgeMap arch)
reverseEdges = lens _reverseEdges (\s v -> s { _reverseEdges = v })
-- | Set of addresses to explore next.
--
-- This is a map so that we can associate a reason why a code address
-- was added to the frontier.
frontier :: Simple Lens (FunState arch ids) (Set (ArchSegmentedAddr arch))
frontier :: Simple Lens (FunState arch ids) (Set (ArchSegmentOff arch))
frontier = lens _frontier (\s v -> s { _frontier = v })
------------------------------------------------------------------------
@ -330,11 +325,11 @@ liftST = FunM . lift
-- | Joins in the new abstract state and returns the locations for
-- which the new state is changed.
mergeIntraJump :: ArchSegmentedAddr arch
mergeIntraJump :: ArchSegmentOff arch
-- ^ Source label that we are jumping from.
-> AbsBlockState (ArchReg arch)
-- ^ Block state after executing instructions.
-> ArchSegmentedAddr arch
-> ArchSegmentOff arch
-- ^ Address we are trying to reach.
-> FunM arch ids ()
mergeIntraJump src ab tgt = do
@ -373,15 +368,16 @@ mergeIntraJump src ab tgt = do
matchJumpTable :: MemWidth (ArchAddrWidth arch)
=> Memory (ArchAddrWidth arch)
-> BVValue arch ids (ArchAddrWidth arch) -- ^ Memory address that IP is read from.
-> Maybe (ArchSegmentedAddr arch, BVValue arch ids (ArchAddrWidth arch))
-> Maybe (ArchMemAddr arch, BVValue arch ids (ArchAddrWidth arch))
matchJumpTable mem read_addr
-- Turn the read address into base + offset.
| Just (BVAdd _ offset base_val) <- valueAsApp read_addr
, Just base <- asLiteralAddr mem base_val
, Just base <- asLiteralAddr base_val
-- Turn the offset into a multiple by an index.
, Just (BVMul _ (BVValue _ mul) jump_index) <- valueAsApp offset
, mul == toInteger (addrSize (memAddrWidth mem))
, Perm.isReadonly (segmentFlags (addrSegment base)) = do
, Just mseg <- asSegmentOff mem base
, Perm.isReadonly (segmentFlags (msegSegment mseg)) = do
Just (base, jump_index)
matchJumpTable _ _ =
Nothing
@ -409,15 +405,16 @@ showJumpTableBoundsError err =
-- table.
getJumpTableBounds :: ArchitectureInfo a
-> AbsProcessorState (ArchReg a) ids -- ^ Current processor registers.
-> ArchSegmentedAddr a -- ^ Base
-> ArchMemAddr a -- ^ Base
-> BVValue a ids (ArchAddrWidth a) -- ^ Index in jump table
-> Either (JumpTableBoundsError a ids) (ArchAddr a)
-> Either (JumpTableBoundsError a ids) (ArchAddrWord a)
-- ^ One past last index in jump table or nothing
getJumpTableBounds info regs base jump_index = withArchConstraints info $
case transferValue regs jump_index of
StridedInterval (SI.StridedInterval _ index_base index_range index_stride) -> do
let mem = absMem regs
let index_end = index_base + (index_range + 1) * index_stride
if rangeInReadonlySegment base (jumpTableEntrySize info * fromInteger index_end) then
if rangeInReadonlySegment mem base (jumpTableEntrySize info * fromInteger index_end) then
case Jmp.unsignedUpperBound (regs^.indexBounds) jump_index of
Right (Jmp.IntegerUpperBound bnd) | bnd == index_range -> Right $! fromInteger index_end
Right bnd -> Left (UpperBoundMismatch bnd index_range)
@ -430,18 +427,6 @@ getJumpTableBounds info regs base jump_index = withArchConstraints info $
------------------------------------------------------------------------
--
tryLookupBlock :: String
-> ArchSegmentedAddr arch
-> Map Word64 (Block arch ids)
-> Word64
-> Block arch ids
tryLookupBlock ctx base block_map idx =
case Map.lookup idx block_map of
Nothing ->
error $ "internal error: tryLookupBlock " ++ ctx ++ " " ++ show base
++ " given invalid index " ++ show idx
Just b -> b
refineProcStateBounds :: ( OrdF (ArchReg arch)
, HasRepr (ArchReg arch) TypeRepr
)
@ -458,20 +443,20 @@ refineProcStateBounds v isTrue ps =
-- ParseState
data ParseState arch ids =
ParseState { _writtenCodeAddrs :: ![ArchSegmentedAddr arch]
ParseState { _writtenCodeAddrs :: ![ArchSegmentOff arch]
-- ^ Addresses marked executable that were written to memory.
, _intraJumpTargets ::
![(ArchSegmentedAddr arch, AbsBlockState (ArchReg arch))]
, _newFunctionAddrs :: ![ArchSegmentedAddr arch]
![(ArchSegmentOff arch, AbsBlockState (ArchReg arch))]
, _newFunctionAddrs :: ![ArchSegmentOff arch]
}
writtenCodeAddrs :: Simple Lens (ParseState arch ids) [ArchSegmentedAddr arch]
writtenCodeAddrs :: Simple Lens (ParseState arch ids) [ArchSegmentOff arch]
writtenCodeAddrs = lens _writtenCodeAddrs (\s v -> s { _writtenCodeAddrs = v })
intraJumpTargets :: Simple Lens (ParseState arch ids) [(ArchSegmentedAddr arch, AbsBlockState (ArchReg arch))]
intraJumpTargets :: Simple Lens (ParseState arch ids) [(ArchSegmentOff arch, AbsBlockState (ArchReg arch))]
intraJumpTargets = lens _intraJumpTargets (\s v -> s { _intraJumpTargets = v })
newFunctionAddrs :: Simple Lens (ParseState arch ids) [ArchSegmentedAddr arch]
newFunctionAddrs :: Simple Lens (ParseState arch ids) [ArchSegmentOff arch]
newFunctionAddrs = lens _newFunctionAddrs (\s v -> s { _newFunctionAddrs = v })
@ -500,7 +485,7 @@ identifyCall :: ( RegConstraint (ArchReg a)
=> Memory (ArchAddrWidth a)
-> [Stmt a ids]
-> RegState (ArchReg a) (Value a ids)
-> Maybe (Seq (Stmt a ids), ArchSegmentedAddr a)
-> Maybe (Seq (Stmt a ids), ArchSegmentOff a)
identifyCall mem stmts0 s = go (Seq.fromList stmts0) Seq.empty
where -- Get value of stack pointer
next_sp = s^.boundValue sp_reg
@ -516,10 +501,11 @@ identifyCall mem stmts0 s = go (Seq.fromList stmts0) Seq.empty
-- Check this is the right length.
, Just Refl <- testEquality (typeRepr next_sp) (typeRepr val)
-- Check if value is a valid literal address
, Just val_a <- asLiteralAddr mem val
, Just val_a <- asLiteralAddr val
-- Check if segment of address is marked as executable.
, Perm.isExecutable (segmentFlags (addrSegment val_a)) ->
Just (prev Seq.>< after, val_a)
, Just ret_addr <- asSegmentOff mem val_a
, segmentFlags (msegSegment ret_addr) `Perm.hasPerm` Perm.execute ->
Just (prev Seq.>< after, ret_addr)
-- Stop if we hit any architecture specific instructions prior to
-- identifying return address since they may have side effects.
| ExecArchStmt _ <- stmt -> Nothing
@ -531,9 +517,9 @@ identifyCall mem stmts0 s = go (Seq.fromList stmts0) Seq.empty
data ParseContext arch ids = ParseContext { pctxMemory :: !(Memory (ArchAddrWidth arch))
, pctxArchInfo :: !(ArchitectureInfo arch)
, pctxFunAddr :: !(ArchSegmentedAddr arch)
, pctxFunAddr :: !(ArchSegmentOff arch)
-- ^ Address of function this block is being parsed as
, pctxAddr :: !(ArchSegmentedAddr arch)
, pctxAddr :: !(ArchSegmentOff arch)
-- ^ Address of the current block
, pctxBlockMap :: !(Map Word64 (Block arch ids))
}
@ -567,7 +553,7 @@ parseFetchAndExecute ctx lbl_idx stmts regs s' = do
-- The last statement was a call.
-- Note that in some cases the call is known not to return, and thus
-- this code will never jump to the return value.
_ | Just (prev_stmts, ret) <- identifyCall mem stmts s' -> do
_ | Just (prev_stmts, ret) <- identifyCall mem stmts s' -> do
mapM_ (recordWriteStmt arch_info mem absProcState') prev_stmts
let abst = finalAbsBlockState absProcState' s'
seq abst $ do
@ -596,17 +582,18 @@ parseFetchAndExecute ctx lbl_idx stmts regs s' = do
--
-- Note, we disallow jumps back to function entry point thus forcing them to be treated
-- as tail calls or unclassified if the stack has changed size.
| Just tgt_addr <- asLiteralAddr mem (s'^.boundValue ip_reg)
, tgt_addr /= pctxFunAddr ctx -> do
assert (segmentFlags (addrSegment tgt_addr) `Perm.hasPerm` Perm.execute) $ do
| Just tgt_addr <- asLiteralAddr (s'^.boundValue ip_reg)
, Just tgt_mseg <- asSegmentOff mem tgt_addr
, segmentFlags (msegSegment tgt_mseg) `Perm.hasPerm` Perm.execute
, tgt_mseg /= pctxFunAddr ctx -> do
mapM_ (recordWriteStmt arch_info mem absProcState') stmts
-- Merge block state and add intra jump target.
let abst = finalAbsBlockState absProcState' s'
let abst' = abst & setAbsIP tgt_addr
intraJumpTargets %= ((tgt_addr, abst'):)
let abst' = abst & setAbsIP tgt_mseg
intraJumpTargets %= ((tgt_mseg, abst'):)
pure StatementList { stmtsIdent = lbl_idx
, stmtsNonterm = stmts
, stmtsTerm = ParsedJump s' tgt_addr
, stmtsTerm = ParsedJump s' tgt_mseg
, stmtsAbsState = absProcState'
}
-- Block ends with what looks like a jump table.
@ -635,24 +622,25 @@ parseFetchAndExecute ctx lbl_idx stmts regs s' = do
-- 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.
let resolveJump :: [ArchSegmentedAddr arch]
let resolveJump :: [ArchSegmentOff arch]
-- /\ Addresses in jump table in reverse order
-> ArchAddr arch
-> ArchAddrWord arch
-- /\ Current index
-> State (ParseState arch ids) [ArchSegmentedAddr arch]
-> State (ParseState arch ids) [ArchSegmentOff arch]
resolveJump prev idx | idx == read_end = do
-- Stop jump table when we have reached computed bounds.
return (reverse prev)
resolveJump prev idx = do
let read_addr = base & addrOffset +~ 8 * idx
let read_addr = base & incAddr (toInteger (8 * idx))
case readAddr mem (archEndianness arch_info) read_addr of
Right tgt_addr
| Perm.isReadonly (segmentFlags (addrSegment read_addr)) -> do
let flags = segmentFlags (addrSegment tgt_addr)
assert (flags `Perm.hasPerm` Perm.execute) $ do
let abst' = abst & setAbsIP tgt_addr
intraJumpTargets %= ((tgt_addr, abst'):)
resolveJump (tgt_addr:prev) (idx+1)
| Just read_mseg <- asSegmentOff mem read_addr
, Perm.isReadonly (segmentFlags (msegSegment read_mseg))
, Just tgt_mseg <- asSegmentOff mem tgt_addr
, Perm.isExecutable (segmentFlags (msegSegment tgt_mseg)) -> do
let abst' = abst & setAbsIP tgt_mseg
intraJumpTargets %= ((tgt_mseg, abst'):)
resolveJump (tgt_mseg:prev) (idx+1)
_ -> do
debug DCFG ("Stop jump table: " ++ show idx ++ " " ++ show read_end) $ do
return (reverse prev)
@ -707,7 +695,6 @@ parseBlock ctx b regs = do
let mem = pctxMemory ctx
let arch_info = pctxArchInfo ctx
withArchConstraints arch_info $ do
let src = pctxAddr ctx
let idx = blockLabel b
let block_map = pctxBlockMap ctx
-- FIXME: we should propagate c back to the initial block, not just b
@ -716,9 +703,9 @@ parseBlock ctx b regs = do
Branch c lb rb -> do
mapM_ (recordWriteStmt arch_info mem absProcState') (blockStmts b)
let l = tryLookupBlock "left branch" src block_map lb
let Just l = Map.lookup lb block_map
let l_regs = refineProcStateBounds c True $ refineProcState c absTrue absProcState'
let r = tryLookupBlock "right branch" src block_map rb
let Just r = Map.lookup rb block_map
let r_regs = refineProcStateBounds c False $ refineProcState c absFalse absProcState'
let l_regs' = absEvalStmts arch_info l_regs (blockStmts b)
@ -764,11 +751,11 @@ parseBlock ctx b regs = do
-- | This evalutes the statements in a block to expand the information known
-- about control flow targets of this block.
transferBlocks :: ArchSegmentedAddr arch
transferBlocks :: ArchSegmentOff arch
-- ^ Address of theze blocks
-> FoundAddr arch
-- ^ State leading to explore block
-> ArchAddr arch
-> ArchAddrWord arch
-- ^ Size of the region these blocks cover.
-> Map Word64 (Block arch ids)
-- ^ Map from labelIndex to associated block
@ -805,24 +792,27 @@ transferBlocks src finfo sz block_map =
mapM_ (\(addr, abs_state) -> mergeIntraJump src abs_state addr) (ps^.intraJumpTargets)
transfer :: ArchSegmentedAddr arch
transfer :: ArchSegmentOff arch
-> FunM arch ids ()
transfer addr = do
mfinfo <- use $ foundAddrs . at addr
let finfo = fromMaybe (error $ "getBlock called on unfound address " ++ show addr ++ ".") $
mfinfo
ainfo <- uses curFunCtx archInfo
withArchConstraints ainfo $ do
mfinfo <- use $ foundAddrs . at addr
let finfo = fromMaybe (error $ "transfer called on unfound address " ++ show addr ++ ".") $
mfinfo
mem <- uses curFunCtx memory
nonceGen <- gets funNonceGen
prev_block_map <- use $ curFunBlocks
-- Get maximum number of bytes to disassemble
let seg = msegSegment addr
off = msegOffset addr
let max_size =
case Map.lookupGT addr prev_block_map of
Just (next,_) | addrSegment next == addrSegment addr -> next^.addrOffset - addr^.addrOffset
_ -> segmentSize (addrSegment addr) - addr^.addrOffset
Just (next,_) | Just o <- diffSegmentOff next addr -> fromInteger o
_ -> segmentSize seg - off
let ab = foundAbstractState finfo
(bs0, sz, maybeError) <-
liftST $ disassembleFn ainfo nonceGen addr max_size ab
liftST $ disassembleFn ainfo mem nonceGen addr max_size ab
let ctx = RewriteContext { rwctxNonceGen = nonceGen
, rwctxArchFn = rewriteArchFn ainfo
@ -842,7 +832,7 @@ transfer addr = do
let -- TODO: Fix this to work with segmented memory
w = addrWidthNatRepr (archAddrWidth ainfo)
errState = mkRegState Initial
& boundValue ip_reg .~ RelocatableValue w addr
& boundValue ip_reg .~ RelocatableValue w (relativeSegmentAddr addr)
errMsg = Text.pack $ fromMaybe "Unknown error" maybeError
errBlock = Block { blockLabel = 0
, blockStmts = []
@ -873,7 +863,7 @@ analyzeBlocks = do
--
-- This returns the updated state and the discovered control flow
-- graph for this function.
analyzeFunction :: ArchSegmentedAddr arch
analyzeFunction :: ArchSegmentOff arch
-- ^ The address to explore
-> CodeAddrReason (ArchAddrWidth arch)
-- ^ Reason to provide for why we are analyzing this function
@ -883,12 +873,13 @@ analyzeFunction :: ArchSegmentedAddr arch
-> DiscoveryState arch
-- ^ The current binary information.
-> (DiscoveryState arch, Some (DiscoveryFunInfo arch))
analyzeFunction addr rsn s =
analyzeFunction addr rsn s = do
case Map.lookup addr (s^.funInfo) of
Just finfo -> (s, finfo)
Nothing -> do
withGlobalSTNonceGenerator $ \gen -> do
let info = archInfo s
withArchConstraints info $ do
withGlobalSTNonceGenerator $ \gen -> do
let mem = memory s
let faddr = FoundAddr { foundReason = rsn
@ -926,27 +917,26 @@ analyzeDiscoveredFunctions info =
analyzeDiscoveredFunctions $! fst (analyzeFunction addr rsn info)
-- | This returns true if the address is writable and value is executable.
isDataCodePointer :: SegmentedAddr w -> SegmentedAddr w -> Bool
isDataCodePointer :: MemSegmentOff w -> MemSegmentOff w -> Bool
isDataCodePointer a v
= segmentFlags (addrSegment a) `Perm.hasPerm` Perm.write
&& segmentFlags (addrSegment v) `Perm.hasPerm` Perm.execute
= segmentFlags (msegSegment a) `Perm.hasPerm` Perm.write
&& segmentFlags (msegSegment v) `Perm.hasPerm` Perm.execute
addMemCodePointer :: (ArchSegmentedAddr arch, ArchSegmentedAddr arch)
addMemCodePointer :: (ArchSegmentOff arch, ArchSegmentOff arch)
-> DiscoveryState arch
-> DiscoveryState arch
addMemCodePointer (src,val) = markAddrAsFunction (CodePointerInMem src) val
exploreMemPointers :: [(ArchSegmentedAddr arch, ArchSegmentedAddr arch)]
exploreMemPointers :: [(ArchSegmentOff arch, ArchSegmentOff arch)]
-- ^ List of addresses and value pairs to use for
-- considering possible addresses.
-> DiscoveryState arch
-> DiscoveryState arch
exploreMemPointers mem_words info =
flip execState info $ do
let mem_addrs =
filter (uncurry isDataCodePointer) $
mem_words
let mem_addrs
= filter (\(a,v) -> isDataCodePointer a v)
$ mem_words
mapM_ (modify . addMemCodePointer) mem_addrs
-- | Construct a discovery info by starting with exploring from a given set of
@ -958,9 +948,9 @@ cfgFromAddrs :: forall arch
-- ^ Memory to use when decoding instructions.
-> SymbolAddrMap (ArchAddrWidth arch)
-- ^ Map from addresses to the associated symbol name.
-> [ArchSegmentedAddr arch]
-> [ArchSegmentOff arch]
-- ^ Initial function entry points.
-> [(ArchSegmentedAddr arch, ArchSegmentedAddr arch)]
-> [(ArchSegmentOff arch, ArchSegmentOff arch)]
-- ^ Function entry points in memory to be explored
-- after exploring function entry points.
--

16
src/Data/Macaw/Discovery/AbsEval.hs
View File

@ -23,15 +23,13 @@ import Data.Macaw.AbsDomain.AbsState
import Data.Macaw.Architecture.Info
import Data.Macaw.CFG
import Data.Macaw.Memory
-- | Get the absolute value associated with an address.
absEvalReadMem :: (OrdF (ArchReg a), ShowF (ArchReg a), MemWidth (RegAddrWidth (ArchReg a)))
=> AbsProcessorState (ArchReg a) ids
-> ArchAddrValue a ids
-> MemRepr tp
-- ^ Information about the memory layout for the value.
-> ArchAbsValue a tp
absEvalReadMem :: RegisterInfo (ArchReg a)
=> AbsProcessorState (ArchReg a) ids
-> ArchAddrValue a ids
-> MemRepr tp
-- ^ Information about the memory layout for the value.
-> ArchAbsValue a tp
absEvalReadMem r a tp
| StackOffset _ s <- transferValue r a
, [o] <- Set.toList s
@ -74,6 +72,8 @@ absEvalStmt info stmt = withArchConstraints info $
modify $ addMemWrite addr memRepr v
PlaceHolderStmt{} ->
pure ()
InstructionStart _ _ ->
pure ()
Comment{} ->
pure ()
ExecArchStmt astmt ->

164
src/Data/Macaw/Discovery/State.hs
View File

@ -75,20 +75,18 @@ import Data.Macaw.Types
-- | This describes the source of an address that was marked as containing code.
data CodeAddrReason w
= InWrite !(SegmentedAddr w)
= InWrite !(MemSegmentOff w)
-- ^ Exploring because the given block writes it to memory.
| NextIP !(SegmentedAddr w)
| NextIP !(MemSegmentOff w)
-- ^ Exploring because the given block jumps here.
| CallTarget !(SegmentedAddr w)
| CallTarget !(MemSegmentOff w)
-- ^ Exploring because address terminates with a call that jumps here.
| InitAddr
-- ^ Identified as an entry point from initial information
| CodePointerInMem !(SegmentedAddr w)
| CodePointerInMem !(MemSegmentOff w)
-- ^ A code pointer that was stored at the given address.
| SplitAt !(SegmentedAddr w)
| SplitAt !(MemAddr w)
-- ^ Added because the address split this block after it had been disassembled.
| InterProcedureJump !(SegmentedAddr w)
-- ^ A jump from an address in another function.
| UserRequest
-- ^ The user requested that we analyze this address as a function.
deriving (Show)
@ -97,18 +95,18 @@ data CodeAddrReason w
-- SymbolAddrMap
-- | Map from addresses to the associated symbol name.
newtype SymbolAddrMap w = SymbolAddrMap { symbolAddrsAsMap :: Map (SegmentedAddr w) BSC.ByteString }
newtype SymbolAddrMap w = SymbolAddrMap { symbolAddrsAsMap :: Map (MemSegmentOff w) BSC.ByteString }
-- | Return an empty symbol addr map
emptySymbolAddrMap :: SymbolAddrMap w
emptySymbolAddrMap = SymbolAddrMap Map.empty
-- | Return addresses in symbol name map
symbolAddrs :: SymbolAddrMap w -> [SegmentedAddr w]
symbolAddrs :: SymbolAddrMap w -> [MemSegmentOff w]
symbolAddrs = Map.keys . symbolAddrsAsMap
-- | Return the symbol at the given map.
symbolAtAddr :: SegmentedAddr w -> SymbolAddrMap w -> Maybe BSC.ByteString
symbolAtAddr :: MemSegmentOff w -> SymbolAddrMap w -> Maybe BSC.ByteString
symbolAtAddr a m = Map.lookup a (symbolAddrsAsMap m)
-- | Check that a symbol name is well formed, returning an error message if not.
@ -125,26 +123,8 @@ checkSymbolName sym_nm =
--
-- It returns either an error message or the map.
symbolAddrMap :: forall w
. Map (SegmentedAddr w) BSC.ByteString
. Map (MemSegmentOff w) BSC.ByteString
-> Either String (SymbolAddrMap w)
{-
symbolAddrMap symbols
| Map.size symbol_names /= Map.size symbols = do
let l = filter isMulti (Map.toList symbol_names)
in Left $ "Duplicate symbol names in symbol name map:\n" ++ show l
where symbol_names :: Map BSC.ByteString [SegmentedAddr w]
symbol_names = foldl insPair Map.empty (Map.toList symbols)
isMulti :: (BSC.ByteString, [SegmentedAddr w])
-> Bool
isMulti (_,[_]) = False
isMulti (_,_) = True
insPair :: Map BSC.ByteString [SegmentedAddr w]
-> (SegmentedAddr w, BSC.ByteString)
-> Map BSC.ByteString [SegmentedAddr w]
insPair m (a,nm) = Map.insertWith (++) nm [a] m
-}
symbolAddrMap symbols = do
mapM_ checkSymbolName (Map.elems symbols)
pure $! SymbolAddrMap symbols
@ -173,13 +153,13 @@ instance (Integral w, Show w) => Show (GlobalDataInfo w) where
-- interpreted.
data ParsedTermStmt arch ids
= ParsedCall !(RegState (ArchReg arch) (Value arch ids))
!(Maybe (ArchSegmentedAddr arch))
!(Maybe (ArchSegmentOff arch))
-- ^ A call with the current register values and location to return to or 'Nothing' if this is a tail call.
| ParsedJump !(RegState (ArchReg arch) (Value arch ids)) !(ArchSegmentedAddr arch)
| ParsedJump !(RegState (ArchReg arch) (Value arch ids)) !(ArchSegmentOff arch)
-- ^ A jump to an explicit address within a function.
| ParsedLookupTable !(RegState (ArchReg arch) (Value arch ids))
!(BVValue arch ids (ArchAddrWidth arch))
!(V.Vector (ArchSegmentedAddr arch))
!(V.Vector (ArchSegmentOff arch))
-- ^ A lookup table that branches to one of a vector of addresses.
--
-- The registers store the registers, the value contains the index to jump
@ -189,7 +169,7 @@ data ParsedTermStmt arch ids
| ParsedIte !(Value arch ids BoolType) !(StatementList arch ids) !(StatementList arch ids)
-- ^ An if-then-else
| ParsedSyscall !(RegState (ArchReg arch) (Value arch ids))
!(ArchSegmentedAddr arch)
!(ArchSegmentOff arch)
-- ^ A system call with the registers prior to call and given return address.
| ParsedTranslateError !Text
-- ^ An error occured in translating the block
@ -199,41 +179,49 @@ data ParsedTermStmt arch ids
deriving instance ArchConstraints arch => Show (ParsedTermStmt arch ids)
-- | Pretty print the block contents indented inside brackets.
ppStatementList :: ArchConstraints arch => StatementList arch ids -> Doc
ppStatementList b =
ppStatementList :: ArchConstraints arch => (ArchAddrWord arch -> Doc) -> StatementList arch ids -> Doc
ppStatementList ppOff b =
text "{" <$$>
indent 2 (vcat (pretty <$> stmtsNonterm b) <$$> pretty (stmtsTerm b)) <$$>
indent 2 (vcat (ppStmt ppOff <$> stmtsNonterm b) <$$>
ppTermStmt ppOff (stmtsTerm b)) <$$>
text "}"
instance ArchConstraints arch => Pretty (ParsedTermStmt arch ids) where
pretty (ParsedCall s Nothing) =
text "tail call" <$$>
indent 2 (pretty s)
pretty (ParsedCall s (Just next)) =
text "call and return to" <+> text (show next) <$$>
indent 2 (pretty s)
pretty (ParsedJump s addr) =
text "jump" <+> text (show addr) <$$>
indent 2 (pretty s)
pretty (ParsedLookupTable s idx entries) =
text "ijump" <+> pretty idx <$$>
indent 2 (vcat (imap (\i v -> int i <+> text ":->" <+> text (show v)) (V.toList entries))) <$$>
indent 2 (pretty s)
pretty (ParsedReturn s) =
text "return" <$$>
indent 2 (pretty s)
pretty (ParsedIte c t f) =
text "ite" <+> pretty c <$$>
ppStatementList t <$$>
ppStatementList f
pretty (ParsedSyscall s addr) =
text "syscall, return to" <+> text (show addr) <$$>
indent 2 (pretty s)
pretty (ParsedTranslateError msg) =
text "translation error" <+> text (Text.unpack msg)
pretty (ClassifyFailure s) =
text "unknown transfer" <$$>
indent 2 (pretty s)
ppTermStmt :: ArchConstraints arch
=> (ArchAddrWord arch -> Doc)
-- ^ Given an address offset, this prints the value
-> ParsedTermStmt arch ids
-> Doc
ppTermStmt ppOff tstmt =
case tstmt of
ParsedCall s Nothing ->
text "tail call" <$$>
indent 2 (pretty s)
ParsedCall s (Just next) ->
text "call and return to" <+> text (show next) <$$>
indent 2 (pretty s)
ParsedJump s addr ->
text "jump" <+> text (show addr) <$$>
indent 2 (pretty s)
ParsedLookupTable s idx entries ->
text "ijump" <+> pretty idx <$$>
indent 2 (vcat (imap (\i v -> int i <+> text ":->" <+> text (show v))
(V.toList entries))) <$$>
indent 2 (pretty s)
ParsedReturn s ->
text "return" <$$>
indent 2 (pretty s)
ParsedIte c t f ->
text "ite" <+> pretty c <$$>
ppStatementList ppOff t <$$>
ppStatementList ppOff f
ParsedSyscall s addr ->
text "syscall, return to" <+> text (show addr) <$$>
indent 2 (pretty s)
ParsedTranslateError msg ->
text "translation error" <+> text (Text.unpack msg)
ClassifyFailure s ->
text "unknown transfer" <$$>
indent 2 (pretty s)
------------------------------------------------------------------------
-- StatementList
@ -307,9 +295,9 @@ rewriteStatementList b = do
-- | A contiguous region of instructions in memory.
data ParsedBlock arch ids
= ParsedBlock { blockAddr :: !(ArchSegmentedAddr arch)
= ParsedBlock { blockAddr :: !(ArchSegmentOff arch)
-- ^ Address of region
, blockSize :: !(ArchAddr arch)
, blockSize :: !(ArchAddrWord arch)
-- ^ The size of the region of memory covered by this.
, blockReason :: !(CodeAddrReason (ArchAddrWidth arch))
-- ^ Reason that we marked this address as
@ -326,25 +314,26 @@ deriving instance ArchConstraints arch
instance ArchConstraints arch
=> Pretty (ParsedBlock arch ids) where
pretty r =
let b = blockStatementList r
in text (show (blockAddr r)) PP.<> text ":" <$$>
indent 2 (vcat (pretty <$> stmtsNonterm b) <$$> pretty (stmtsTerm b))
pretty b =
let sl = blockStatementList b
ppOff o = text (show (incAddr (toInteger o) (relativeSegmentAddr (blockAddr b))))
in text (show (blockAddr b)) PP.<> text ":" <$$>
indent 2 (vcat (ppStmt ppOff <$> stmtsNonterm sl) <$$> ppTermStmt ppOff (stmtsTerm sl))
------------------------------------------------------------------------
-- DiscoveryFunInfo
-- | Information discovered about a particular function
data DiscoveryFunInfo arch ids
= DiscoveryFunInfo { discoveredFunAddr :: !(ArchSegmentedAddr arch)
= DiscoveryFunInfo { discoveredFunAddr :: !(ArchSegmentOff arch)
-- ^ Address of function entry block.
, discoveredFunName :: !BSC.ByteString
-- ^ Name of function should be unique for program
, _parsedBlocks :: !(Map (ArchSegmentedAddr arch) (ParsedBlock arch ids))
, _parsedBlocks :: !(Map (ArchSegmentOff arch) (ParsedBlock arch ids))
-- ^ Maps an address to the blocks associated with that address.
}
parsedBlocks :: Simple Lens (DiscoveryFunInfo arch ids) (Map (ArchSegmentedAddr arch) (ParsedBlock arch ids))
parsedBlocks :: Simple Lens (DiscoveryFunInfo arch ids) (Map (ArchSegmentOff arch) (ParsedBlock arch ids))
parsedBlocks = lens _parsedBlocks (\s v -> s { _parsedBlocks = v })
instance ArchConstraints arch => Pretty (DiscoveryFunInfo arch ids) where
@ -363,13 +352,13 @@ data DiscoveryState arch
-- ^ Map addresses to known symbol names
, archInfo :: !(ArchitectureInfo arch)
-- ^ Architecture-specific information needed for discovery.
, _globalDataMap :: !(Map (ArchSegmentedAddr arch)
(GlobalDataInfo (ArchSegmentedAddr arch)))
, _globalDataMap :: !(Map (ArchMemAddr arch)
(GlobalDataInfo (ArchMemAddr arch)))
-- ^ Maps each address that appears to be global data to information
-- inferred about it.
, _funInfo :: !(Map (ArchSegmentedAddr arch) (Some (DiscoveryFunInfo arch)))
, _funInfo :: !(Map (ArchSegmentOff arch) (Some (DiscoveryFunInfo arch)))
-- ^ Map from function addresses to discovered information about function
, _unexploredFunctions :: !(Map (ArchSegmentedAddr arch) (CodeAddrReason (ArchAddrWidth arch)))
, _unexploredFunctions :: !(Map (ArchSegmentOff arch) (CodeAddrReason (ArchAddrWidth arch)))
-- ^ This maps addresses that have been marked as
-- functions, but not yet analyzed to the reason
-- they are analyzed.
@ -413,17 +402,16 @@ emptyDiscoveryState mem symbols info =
-- | Map each jump table start to the address just after the end.
globalDataMap :: Simple Lens (DiscoveryState arch)
(Map (ArchSegmentedAddr arch)
(GlobalDataInfo (ArchSegmentedAddr arch)))
(Map (ArchMemAddr arch) (GlobalDataInfo (ArchMemAddr arch)))
globalDataMap = lens _globalDataMap (\s v -> s { _globalDataMap = v })
-- | List of functions to explore next.
unexploredFunctions :: Simple Lens (DiscoveryState arch)
(Map (ArchSegmentedAddr arch) (CodeAddrReason (ArchAddrWidth arch)))
(Map (ArchSegmentOff arch) (CodeAddrReason (ArchAddrWidth arch)))
unexploredFunctions = lens _unexploredFunctions (\s v -> s { _unexploredFunctions = v })
-- | Get information for specific functions
funInfo :: Simple Lens (DiscoveryState arch) (Map (ArchSegmentedAddr arch) (Some (DiscoveryFunInfo arch)))
funInfo :: Simple Lens (DiscoveryState arch) (Map (ArchSegmentOff arch) (Some (DiscoveryFunInfo arch)))
funInfo = lens _funInfo (\s v -> s { _funInfo = v })
------------------------------------------------------------------------
@ -435,10 +423,8 @@ type RegConstraint r = (OrdF r, HasRepr r TypeRepr, RegisterInfo r, ShowF r)
-- | This returns a segmented address if the value can be interpreted as a literal memory
-- address, and returns nothing otherwise.
asLiteralAddr :: MemWidth (ArchAddrWidth arch)
=> Memory (ArchAddrWidth arch)
-> BVValue arch ids (ArchAddrWidth arch)
-> Maybe (ArchSegmentedAddr arch)
asLiteralAddr mem (BVValue _ val) =
absoluteAddrSegment mem (fromInteger val)
asLiteralAddr _ (RelocatableValue _ i) = Just i
asLiteralAddr _ _ = Nothing
=> BVValue arch ids (ArchAddrWidth arch)
-> Maybe (ArchMemAddr arch)
asLiteralAddr (BVValue _ val) = Just $ absoluteAddr (fromInteger val)
asLiteralAddr (RelocatableValue _ i) = Just i
asLiteralAddr _ = Nothing

4
src/Data/Macaw/Fold.hs
View File

@ -59,7 +59,7 @@ foldValueCached :: forall m arch ids tp
. (Monoid m, CanFoldValues arch)
=> (forall n. NatRepr n -> Integer -> m)
-- ^ Function for literals
-> (forall n. NatRepr n -> ArchSegmentedAddr arch -> m)
-> (ArchMemAddr arch -> m)
-- ^ Function for memwords
-> (forall utp . ArchReg arch utp -> m)
-- ^ Function for input registers
@ -76,7 +76,7 @@ foldValueCached litf rwf initf assignf = getStateMonadMonoid . go
case v of
BoolValue b -> return (litf (knownNat :: NatRepr 1) (if b then 1 else 0))
BVValue sz i -> return $ litf sz i
RelocatableValue w a -> pure $ rwf w a
RelocatableValue _ a -> pure $ rwf a
Initial r -> return $ initf r
AssignedValue (Assignment a_id rhs) -> do
m <- get

489
src/Data/Macaw/Memory.hs
View File

@ -13,7 +13,6 @@ n-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Macaw.Memory
@ -28,13 +27,6 @@ module Data.Macaw.Memory
, memSegments
, executableSegments
, readonlySegments
, readAddr
, segmentOfRange
, addrPermissions
, isCodeAddr
, isCodeAddrOrNull
, absoluteAddrSegment
, memAsAddrPairs
-- * AddrWidthRepr
, AddrWidthRepr(..)
, addrWidthNatRepr
@ -52,26 +44,38 @@ module Data.Macaw.Memory
, ppMemSegment
, segmentSize
, SegmentRange(..)
-- * MemWord
, MemWord
, MemWidth(..)
, memWord
-- * Segment offsets
, MemSegmentOff
, resolveAbsoluteAddr
, resolveSegmentOff
, msegSegment
, msegOffset
, msegAddr
, incSegmentOff
, diffSegmentOff
, memAsAddrPairs
-- * Symbols
, SymbolRef(..)
, SymbolVersion(..)
-- * Address and offset.
, MemWidth(..)
, MemWord
, memWord
-- * Segmented Addresses
, SegmentedAddr(..)
, addrOffset
-- * General purposes addrs
, MemAddr
, absoluteAddr
, relativeAddr
, relativeSegmentAddr
, asAbsoluteAddr
, asSegmentOff
, diffAddr
, incAddr
, clearAddrLeastBit
-- * Reading
, MemoryError(..)
, addrContentsAfter
, addrBase
, addrValue
, bsWord8
, bsWord16be
, bsWord16le
, bsWord32be
, bsWord32le
, bsWord64be
, bsWord64le
, readByteString
, readAddr
, readWord8
, readWord16be
, readWord16le
@ -79,18 +83,22 @@ module Data.Macaw.Memory
, readWord32le
, readWord64be
, readWord64le
-- * Memory addrs
, MemoryError(..)
-- * Utilities
, bsWord8
, bsWord16be
, bsWord16le
, bsWord32be
, bsWord32le
, bsWord64be
, bsWord64le
) where
import Control.Exception (assert)
import Control.Lens
import Data.Bits
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.Foldable as Fold
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Proxy
import Data.Word
import GHC.TypeLits
@ -178,12 +186,16 @@ bsWord64le bs
------------------------------------------------------------------------
-- MemBase
newtype MemWord (n :: Nat) = MemWord { memWordValue :: Word64 }
-- ^ A value in memory.
-- | This represents a particular numeric address in memory.
--
newtype MemWord (w :: Nat) = MemWord { _memWordValue :: Word64 }
instance Show (MemWord w) where
showsPrec _ (MemWord w) = showString "0x" . showHex w
instance Pretty (MemWord w) where
pretty = text . show
instance Eq (MemWord w) where
MemWord x == MemWord y = x == y
@ -280,8 +292,6 @@ addrWidthClass :: AddrWidthRepr w -> (MemWidth w => a) -> a
addrWidthClass Addr32 x = x
addrWidthClass Addr64 x = x
$(pure [])
-- | A unique identifier for a segment.
type SegmentIndex = Int
@ -369,7 +379,10 @@ data MemSegment w
= MemSegment { segmentIndex :: !SegmentIndex
-- ^ Unique index for this segment
, segmentBase :: !(Maybe (MemWord w))
-- ^ Base for this segment
-- ^ Base for this segment
--
-- Note that the current code assumes that segments are
-- always on even addresses even if the base is omitted.
, segmentFlags :: !Perm.Flags
-- ^ Permisison flags
, segmentContents :: !(SegmentContents w)
@ -377,6 +390,11 @@ data MemSegment w
-- the segment.
}
-- | Check base plus size of segment does not overflow
checkBaseAndSize :: MemWidth w => Maybe (MemWord w) -> MemWord w -> Bool
checkBaseAndSize Nothing _ = True
checkBaseAndSize (Just b) sz = b + sz >= b
-- | Create a memory segment with the given values.
memSegment :: MemWidth w
=> SegmentIndex
@ -388,12 +406,18 @@ memSegment :: MemWidth w
-> [SegmentRange w]
-- ^ Range of vlaues.
-> MemSegment w
memSegment idx base flags contents =
MemSegment { segmentIndex = idx
, segmentBase = base
, segmentFlags = flags
, segmentContents = contentsFromList contents
}
memSegment idx mbase flags contentsl
| checkBaseAndSize mbase (contentsSize contents) =
MemSegment { segmentIndex = idx
, segmentBase = mbase
, segmentFlags = flags
, segmentContents = contents
}
| otherwise =
error "Contents two large for base."
where contents = contentsFromList contentsl
instance Eq (MemSegment w) where
x == y = segmentIndex x == segmentIndex y
@ -417,60 +441,6 @@ ppMemSegment s =
instance MemWidth w => Show (MemSegment w) where
show = show . ppMemSegment
------------------------------------------------------------------------
-- SegmentedAddr
-- | A memory address is a reference to memory that uses an explicit segment plus
-- offset representation.
data SegmentedAddr w = SegmentedAddr { addrSegment :: !(MemSegment w)
, _addrOffset :: !(MemWord w)
}
deriving (Eq, Ord)
addrOffset :: Simple Lens (SegmentedAddr w) (MemWord w)
addrOffset = lens _addrOffset (\s v -> s { _addrOffset = v })
-- | Return the base value of an address or 0 if undefined.
addrBase :: MemWidth w => SegmentedAddr w -> MemWord w
addrBase addr = fromMaybe 0 (segmentBase (addrSegment addr))
-- | Return the offset of the address after adding the base segment value if defined.
addrValue :: MemWidth w => SegmentedAddr w -> MemWord w
addrValue addr = addrBase addr + addr^.addrOffset
instance Show (SegmentedAddr w) where
showsPrec p a =
case segmentBase (addrSegment a) of
Just b ->
showString "0x" . showHex (memWordValue b + memWordValue (a^.addrOffset))
Nothing ->
showParen (p > 6)
$ showString "segment"
. shows (segmentIndex (addrSegment a))
. showString "+"
. shows (a^.addrOffset)
-- | Given a segemnted addr this returns the offset and range at that offset.
nextRegion :: MemWidth w
=> SegmentedAddr w
-> Maybe (MemWord w, SegmentRange w)
nextRegion addr = do
let i = addr^.addrOffset
let SegmentContents m = segmentContents (addrSegment addr)
(k,r) <- Map.lookupLE (addr^.addrOffset) m
Just (i-k,r)
-- | Return contents starting from location or throw a memory error if there
-- is an unaligned relocation.
addrContentsAfter :: MemWidth w
=> SegmentedAddr w
-> Either (MemoryError w) [SegmentRange w]
addrContentsAfter addr =
case contentsAfter (addr^.addrOffset) (segmentContents (addrSegment addr)) of
Nothing -> Left (UnexpectedRelocation addr)
Just l -> Right l
------------------------------------------------------------------------
-- Memory
@ -503,70 +473,17 @@ emptyMemory w = Memory { memAddrWidth = w
memSegments :: Memory w -> [MemSegment w]
memSegments m = Map.elems (memAllSegments m)
-- | Return segment with given index in memory.
lookupSegment :: Memory w -> SegmentIndex -> Maybe (MemSegment w)
lookupSegment m i = Map.lookup i (memAllSegments m)
-- | Return list of segmented address values in memory.
--
-- Each address includes the value and the base.
memAsAddrPairs :: Memory w
-> Endianness
-> [(SegmentedAddr w, SegmentedAddr w)]
memAsAddrPairs mem end = addrWidthClass (memAddrWidth mem) $ do
seg <- memSegments mem
(contents_offset,r) <- contentsList (segmentContents seg)
let addr = SegmentedAddr seg contents_offset
let sz = addrSize mem
case r of
ByteRegion bs -> assert (BS.length bs `rem` fromIntegral sz == 0) $ do
w <- regularChunks (fromIntegral sz) bs
let Just val = addrRead end w
case Map.lookupLE val (memAbsoluteSegments mem) of
Just (base, value_seg) | val <= base + segmentSize value_seg -> do
let seg_val = SegmentedAddr value_seg (val - base)
in [(addr,seg_val)]
_ -> []
SymbolicRef{} -> []
-- | Get executable segments.
executableSegments :: Memory w -> [MemSegment w]
executableSegments = filter (Perm.isExecutable . segmentFlags) . memSegments
-- | Get readonly segments
readonlySegments :: Memory w -> [MemSegment w]
readonlySegments = filter (Perm.isReadonly . segmentFlags) . memSegments
-- | Given an absolute address, this returns a segment and offset into the segment.
absoluteAddrSegment :: Memory w -> MemWord w -> Maybe (SegmentedAddr w)
absoluteAddrSegment mem addr = addrWidthClass (memAddrWidth mem) $
case Map.lookupLE addr (memAbsoluteSegments mem) of
Just (base, seg) | addr < base + segmentSize seg ->
Just $! SegmentedAddr { addrSegment = seg
, _addrOffset = addr - base
}
_ -> Nothing
-- | Read an address from the value in the segment or report a memory error.
readAddr :: Memory w
-> Endianness
-> SegmentedAddr w
-> Either (MemoryError w) (SegmentedAddr w)
readAddr mem end addr = addrWidthClass (memAddrWidth mem) $ do
let sz = fromIntegral (addrSize addr)
case nextRegion addr of
Just (MemWord offset, ByteRegion bs)
| offset + sz >= offset -- Check for no overfow
, offset + sz <= fromIntegral (BS.length bs) -> do -- Check length
let Just val = addrRead end (BS.take (fromIntegral sz) (BS.drop (fromIntegral offset) bs))
case Map.lookupLE val (memAbsoluteSegments mem) of
Just (base, seg) | val <= base + segmentSize seg -> Right $
SegmentedAddr { addrSegment = seg
, _addrOffset = val - base
}
_ -> Left (InvalidAddr addr)
_ | otherwise ->
Left (AccessViolation addr)
-- | Return segment with given index in memory.
lookupSegment :: Memory w -> SegmentIndex -> Maybe (MemSegment w)
lookupSegment m i = Map.lookup i (memAllSegments m)
data InsertError w
= OverlapSegment (MemWord w) (MemSegment w)
@ -616,53 +533,188 @@ insertMemSegment seg mem = addrWidthClass (memAddrWidth mem) $ do
, memAllSegments = allMap
}
-- | Return segment if range is entirely contained within a single segment
-- and 'Nothing' otherwise.
segmentOfRange :: MemWord w -- ^ Start of range
-> MemWord w -- ^ One past last index in range.
-> Memory w
-> Maybe (MemSegment w)
segmentOfRange base end mem = addrWidthClass (memAddrWidth mem) $ do
case Map.lookupLE base (memAbsoluteSegments mem) of
Just (seg_base, seg) | end <= seg_base + segmentSize seg -> Just seg
------------------------------------------------------------------------
-- MemSegmentOff
-- | A pair containing a segment and offset.
--
-- Constructrs enforce that the offset is valid
data MemSegmentOff w = MemSegmentOff { msegSegment :: !(MemSegment w)
, msegOffset :: !(MemWord w)
}
deriving (Eq, Ord)
-- | Return the segment associated with the given address if well-defined.
resolveAbsoluteAddr :: Memory w -> MemWord w -> Maybe (MemSegmentOff w)
resolveAbsoluteAddr mem addr = addrWidthClass (memAddrWidth mem) $
case Map.lookupLE addr (memAbsoluteSegments mem) of
Just (base, seg) | addr - base < segmentSize seg ->
Just $! MemSegmentOff seg (addr - base)
_ -> Nothing
-- | Return true if address satisfies permissions check.
addrPermissions :: MemWord w -> Memory w -> Perm.Flags
addrPermissions addr mem = addrWidthClass (memAddrWidth mem) $
case Map.lookupLE addr (memAbsoluteSegments mem) of
Just (base, seg) | addr < base + segmentSize seg -> segmentFlags seg
_ -> Perm.none
-- | Indicates if address is a code pointer.
isCodeAddr :: Memory w -> MemWord w -> Bool
isCodeAddr mem val =
addrPermissions val mem `Perm.hasPerm` Perm.execute
-- | Make a segment offset pair after ensuring the offset is valid
resolveSegmentOff :: MemWidth w => MemSegment w -> MemWord w -> Maybe (MemSegmentOff w)
resolveSegmentOff seg off
| off < segmentSize seg = Just (MemSegmentOff seg off)
| otherwise = Nothing
-- | Indicates if address is an address in code segment or null.
isCodeAddrOrNull :: Memory w -> MemWord w -> Bool
isCodeAddrOrNull _ (MemWord 0) = True
isCodeAddrOrNull mem a = isCodeAddr mem a
-- | Return the absolute address associated with the segment offset pair (if any)
msegAddr :: MemWidth w => MemSegmentOff w -> Maybe (MemWord w)
msegAddr (MemSegmentOff seg off) = (+ off) <$> segmentBase seg
-- | Increment a segment offset by a given amount.
--
-- Returns 'Nothing' if the result would be out of range.
incSegmentOff :: MemWidth w => MemSegmentOff w -> Integer -> Maybe (MemSegmentOff w)
incSegmentOff (MemSegmentOff seg off) inc
| 0 <= next && next <= toInteger (segmentSize seg) = Just $ MemSegmentOff seg (fromInteger next)
| otherwise = Nothing
where next = toInteger off + inc
-- | Return the difference between two segment offsets pairs or `Nothing` if undefined.
diffSegmentOff :: MemWidth w => MemSegmentOff w -> MemSegmentOff w -> Maybe Integer
diffSegmentOff (MemSegmentOff xseg xoff) (MemSegmentOff yseg yoff)
| xseg == yseg = Just $ toInteger xoff - toInteger yoff
| Just xb <- segmentBase xseg
, Just yb <- segmentBase yseg =
Just ((toInteger xb + toInteger xoff) - (toInteger yb + toInteger yoff))
| otherwise = Nothing
instance MemWidth w => Show (MemSegmentOff w) where
showsPrec p (MemSegmentOff seg off) =
case segmentBase seg of
Just base -> showString "0x" . showHex (base+off)
Nothing ->
showParen (p > 6)
$ showString "segment"
. shows (segmentIndex seg)
. showString "+"
. shows off
instance MemWidth w => Pretty (MemSegmentOff w) where
pretty = text . show
-- | Return list of segmented address values in memory.
--
-- Each address includes the value and the base.
memAsAddrPairs :: Memory w
-> Endianness
-> [(MemSegmentOff w, MemSegmentOff w)]
memAsAddrPairs mem end = addrWidthClass (memAddrWidth mem) $ do
seg <- memSegments mem
(contents_offset,r) <- contentsList (segmentContents seg)
let sz = addrSize mem
case r of
ByteRegion bs -> assert (BS.length bs `rem` fromIntegral sz == 0) $ do
(off,w) <-
zip [contents_offset..]
(regularChunks (fromIntegral sz) bs)
let Just val = addrRead end w
case resolveAbsoluteAddr mem val of
Just val_ref -> do
pure (MemSegmentOff seg off, val_ref)
_ -> []
SymbolicRef{} -> []
------------------------------------------------------------------------
-- MemAddr
-- | A memory address is either an absolute value in memory or an offset of segment that
-- could be relocated.
--
-- This representation does not require that the address is mapped to
-- actual memory (see `MemSegmentOff` for an address representation
-- that ensures the reference points to allocated memory).
data MemAddr w
= AbsoluteAddr (MemWord w)
-- ^ An address formed from a specific value.
| RelativeAddr !(MemSegment w) !(MemWord w)
-- ^ An address that is relative to some specific segment.
--
-- Note that the segment base value of this segment should be nothing.
deriving (Eq, Ord)
-- | Given an absolute address, this returns a segment and offset into the segment.
absoluteAddr :: MemWord w -> MemAddr w
absoluteAddr = AbsoluteAddr
-- | Return an address relative to a known memory segment
-- if the memory is unmapped.
relativeAddr :: MemWidth w => MemSegment w -> MemWord w -> MemAddr w
relativeAddr seg off =
case segmentBase seg of
Just base -> AbsoluteAddr (base + off)
Nothing -> RelativeAddr seg off
-- | Return a segmented addr using the offset of an existing segment, or 'Nothing'
-- if the memory is unmapped.
relativeSegmentAddr :: MemWidth w => MemSegmentOff w -> MemAddr w
relativeSegmentAddr (MemSegmentOff seg off) = relativeAddr seg off
-- | Return the offset of the address after adding the base segment value if defined.
asAbsoluteAddr :: MemWidth w => MemAddr w -> Maybe (MemWord w)
asAbsoluteAddr (AbsoluteAddr w) = Just w
asAbsoluteAddr RelativeAddr{} = Nothing
-- | Return the resolved segment offset reference from an address.
asSegmentOff :: Memory w -> MemAddr w -> Maybe (MemSegmentOff w)
asSegmentOff mem (AbsoluteAddr addr) = resolveAbsoluteAddr mem addr
asSegmentOff mem (RelativeAddr seg off) =
addrWidthClass (memAddrWidth mem) $
resolveSegmentOff seg off
-- | Clear the least significant bit of an address.
clearAddrLeastBit :: MemWidth w => MemAddr w -> MemAddr w
clearAddrLeastBit sa =
case sa of
AbsoluteAddr a -> AbsoluteAddr (a .&. complement 1)
RelativeAddr seg off -> RelativeAddr seg (off .&. complement 1)
-- | Increment an address by a fixed amount.
incAddr :: MemWidth w => Integer -> MemAddr w -> MemAddr w
incAddr o (AbsoluteAddr a) = AbsoluteAddr (a + fromInteger o)
incAddr o (RelativeAddr seg off) = RelativeAddr seg (off + fromInteger o)
-- | Returns the number of bytes between two addresses if they are comparable
-- or 'Nothing' if they are not.
diffAddr :: MemWidth w => MemAddr w -> MemAddr w -> Maybe Integer
diffAddr (AbsoluteAddr x) (AbsoluteAddr y) =
Just $ toInteger x - toInteger y
diffAddr (RelativeAddr xseg xoff) (RelativeAddr yseg yoff) | xseg == yseg =
Just $ toInteger xoff - toInteger yoff
diffAddr _ _ = Nothing
instance MemWidth w => Show (MemAddr w) where
showsPrec _ (AbsoluteAddr a) = showString "0x" . showHex a
showsPrec p (RelativeAddr seg off) =
showParen (p > 6)
$ showString "segment"
. shows (segmentIndex seg)
. showString "+"
. shows off
instance MemWidth w => Pretty (MemAddr w) where
pretty = text . show
------------------------------------------------------------------------
-- MemoryError
-- | Type of errors that may occur when reading memory.
data MemoryError w
= UserMemoryError (SegmentedAddr w) !String
= UserMemoryError (MemAddr w) !String
-- ^ the memory reader threw an unspecified error at the given location.
| InvalidInstruction (SegmentedAddr w) ![SegmentRange w]
| InvalidInstruction (MemAddr w) ![SegmentRange w]
-- ^ The memory reader could not parse the value starting at the given address.
| AccessViolation (SegmentedAddr w)
| AccessViolation (MemAddr w)
-- ^ Memory could not be read, because it was not defined.
| PermissionsError (SegmentedAddr w)
| PermissionsError (MemAddr w)
-- ^ Memory could not be read due to insufficient permissions.
| UnexpectedRelocation (SegmentedAddr w)
| UnexpectedRelocation (MemAddr w)
-- ^ Read from location that partially overlaps a relocated entry
| InvalidAddr (SegmentedAddr w)
| InvalidAddr (MemAddr w)
-- ^ The data at the given address did not refer to a valid memory location.
instance Show (MemoryError w) where
instance MemWidth w => Show (MemoryError w) where
show (UserMemoryError _ msg) = msg
show (InvalidInstruction start contents) =
"Invalid instruction at " ++ show start ++ ": " ++ showList contents ""
@ -676,45 +728,72 @@ instance Show (MemoryError w) where
"Attempt to interpret an invalid address: " ++ show a ++ "."
------------------------------------------------------------------------
-- Meory reading utilities
-- Memory reading utilities
-- | Return contents starting from location or throw a memory error if there
-- is an unaligned relocation.
addrContentsAfter :: Memory w
-> MemAddr w
-> Either (MemoryError w) [SegmentRange w]
addrContentsAfter mem addr = addrWidthClass (memAddrWidth mem) $ do
MemSegmentOff seg off <-
case asSegmentOff mem addr of
Just p -> pure p
Nothing -> Left (InvalidAddr addr)
case contentsAfter off (segmentContents seg) of
Just l -> Right l
Nothing -> Left (UnexpectedRelocation addr)
-- | Attemtp to read a bytestring of the given length
readByteString :: MemWidth w => SegmentedAddr w -> Word64 -> Either (MemoryError w) BS.ByteString
readByteString addr sz =
case nextRegion addr of
Nothing -> Left (InvalidAddr addr)
Just (MemWord offset, ByteRegion bs)
| offset + sz >= offset -- Check for no overfow
, offset + sz <= fromIntegral (BS.length bs) -> do -- Check length
Right $ (BS.take (fromIntegral sz) (BS.drop (fromIntegral offset) bs))
| otherwise -> Left (InvalidAddr addr)
Just (_, SymbolicRef{}) ->
readByteString :: Memory w -> MemAddr w -> Word64 -> Either (MemoryError w) BS.ByteString
readByteString mem addr sz = do
l <- addrContentsAfter mem addr
case l of
ByteRegion bs:_
| sz <= fromIntegral (BS.length bs) -> do -- Check length
Right (BS.take (fromIntegral sz) bs)
| otherwise ->
Left (InvalidAddr addr)
SymbolicRef{}:_ ->
Left (UnexpectedRelocation addr)
[] ->
Left (InvalidAddr addr)
-- | Read an address from the value in the segment or report a memory error.
readAddr :: Memory w
-> Endianness
-> MemAddr w
-> Either (MemoryError w) (MemAddr w)
readAddr mem end addr = addrWidthClass (memAddrWidth mem) $ do
let sz = fromIntegral (addrSize addr)
bs <- readByteString mem addr sz
let Just val = addrRead end bs
Right $ AbsoluteAddr val
-- | Read a big endian word16
readWord8 :: MemWidth w => SegmentedAddr w -> Either (MemoryError w) Word8
readWord8 addr = bsWord8 <$> readByteString addr 8
readWord8 :: Memory w -> MemAddr w -> Either (MemoryError w) Word8
readWord8 mem addr = bsWord8 <$> readByteString mem addr 1
-- | Read a big endian word16
readWord16be :: MemWidth w => SegmentedAddr w -> Either (MemoryError w) Word16
readWord16be addr = bsWord16be <$> readByteString addr 8
readWord16be :: Memory w -> MemAddr w -> Either (MemoryError w) Word16
readWord16be mem addr = bsWord16be <$> readByteString mem addr 2
-- | Read a little endian word16
readWord16le :: MemWidth w => SegmentedAddr w -> Either (MemoryError w) Word16
readWord16le addr = bsWord16le <$> readByteString addr 8
readWord16le :: Memory w -> MemAddr w -> Either (MemoryError w) Word16
readWord16le mem addr = bsWord16le <$> readByteString mem addr 2
-- | Read a big endian word32
readWord32be :: MemWidth w => SegmentedAddr w -> Either (MemoryError w) Word32
readWord32be addr = bsWord32be <$> readByteString addr 8
readWord32be :: Memory w -> MemAddr w -> Either (MemoryError w) Word32
readWord32be mem addr = bsWord32be <$> readByteString mem addr 4
-- | Read a little endian word32
readWord32le :: MemWidth w => SegmentedAddr w -> Either (MemoryError w) Word32
readWord32le addr = bsWord32le <$> readByteString addr 8
readWord32le :: Memory w -> MemAddr w -> Either (MemoryError w) Word32
readWord32le mem addr = bsWord32le <$> readByteString mem addr 4
-- | Read a big endian word64
readWord64be :: MemWidth w => SegmentedAddr w -> Either (MemoryError w) Word64
readWord64be addr = bsWord64be <$> readByteString addr 8
readWord64be :: Memory w -> MemAddr w -> Either (MemoryError w) Word64
readWord64be mem addr = bsWord64be <$> readByteString mem addr 8
-- | Read a little endian word64
readWord64le :: MemWidth w => SegmentedAddr w -> Either (MemoryError w) Word64
readWord64le addr = bsWord64le <$> readByteString addr 8
readWord64le :: Memory w -> MemAddr w -> Either (MemoryError w) Word64
readWord64le mem addr = bsWord64le <$> readByteString mem addr 8

41
src/Data/Macaw/Memory/ElfLoader.hs
View File

@ -11,6 +11,7 @@ Operations for creating a view of memory from an elf file.
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Macaw.Memory.ElfLoader
( SectionIndexMap
@ -32,7 +33,6 @@ import Data.Bits
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as L
import Data.Either (partitionEithers)
import Data.ElfEdit
import Data.Foldable
import Data.IntervalMap.Strict (Interval(..), IntervalMap)
@ -60,7 +60,7 @@ sliceL (i,c) = L.take (fromIntegral c) . L.drop (fromIntegral i)
-- address and section contents.
--
-- The base address is expressed in terms of the underlying memory segment.
type SectionIndexMap w = Map ElfSectionIndex (SegmentedAddr w, ElfSection (ElfWordType w))
type SectionIndexMap w = Map ElfSectionIndex (MemSegmentOff w, ElfSection (ElfWordType w))
------------------------------------------------------------------------
-- Flag conversion
@ -333,8 +333,8 @@ insertElfSegment opt shdrMap contents relocMap phdr = do
when (phdr_offset > shdr_start) $ do
fail $ "Found section header that overlaps with program header."
let sec_offset = fromIntegral $ shdr_start - phdr_offset
let pair = (SegmentedAddr seg sec_offset, sec)
mlsIndexMap %= Map.insert elfIdx pair
let Just addr = resolveSegmentOff seg sec_offset
mlsIndexMap %= Map.insert elfIdx (addr, sec)
_ -> fail "Unexpected shdr interval"
@ -398,8 +398,8 @@ insertElfSection sec = do
let seg = memSegmentForElfSection idx sec
loadMemSegment ("Section " ++ BSC.unpack (elfSectionName sec)) seg
let elfIdx = ElfSectionIndex (elfSectionIndex sec)
let pair = (SegmentedAddr seg 0, sec)
mlsIndexMap %= Map.insert elfIdx pair
let Just addr = resolveSegmentOff seg 0
mlsIndexMap %= Map.insert elfIdx (addr, sec)
-- | Load allocated Elf sections into memory.
--
@ -462,29 +462,22 @@ loadExecutable opt path = do
------------------------------------------------------------------------
-- Elf symbol utilities
-- | The takes the elf symbol table map and attempts to identify segmented addresses for each one.
--
-- It returns a two maps, the first contains entries that could not be resolved; the second
-- contains those that could.
-- | The takes the elf symbol table map, creates a map from function
-- symbol addresses to the associated symbol name.
resolvedSegmentedElfFuncSymbols :: forall w
. Memory w
-> [ElfSymbolTableEntry (ElfWordType w)]
-> (Map (MemWord w) [BS.ByteString], Map (SegmentedAddr w) [BS.ByteString])
-> Map (MemSegmentOff w) [BS.ByteString]
resolvedSegmentedElfFuncSymbols mem entries = reprConstraints (memAddrWidth mem) $
let -- Filter out just function entries
isCodeFuncSymbol ste = steType ste == STT_FUNC
&& isCodeAddr mem (fromIntegral (steValue ste))
func_entries = filter isCodeFuncSymbol entries
-- Build absolute address map
absAddrMap :: Map (MemWord w) [BS.ByteString]
absAddrMap = Map.fromListWith (++) $ [ (fromIntegral (steValue ste), [steName ste]) | ste <- func_entries ]
-- Resolve addresses
resolve (v,nms) =
case absoluteAddrSegment mem v of
Nothing -> Left (v, nms)
Just sv -> Right (sv, nms)
(u,r) = partitionEithers $ resolve <$> Map.toList absAddrMap
in (Map.fromList u, Map.fromList r)
func_entries =
[ (addr, [steName ste])
| ste <- entries
, steType ste == STT_FUNC
, addr <- maybeToList $ resolveAbsoluteAddr mem (fromIntegral (steValue ste))
, segmentFlags (msegSegment addr) `Perm.hasPerm` Perm.execute
]
in Map.fromListWith (++) func_entries
ppElfUnresolvedSymbols :: forall w
. MemWidth w