{-|
Copyright   : (c) Galois Inc, 2015-2018
Maintainer  : Ryan Scott <rscott@galois.com>, Langston Barrett <langston@galois.com>

Declares 'Memory', a type for representing pre-loader memory with permissions.
This datatype provides an abstraction that is intended to support different
architectures, executable formats, and object file formats. Crucially, 'Memory' is
capable of representing relocatable (i.e., position-independent) code and data.

A 'Memory' is essentially a collection of /segments/, each of which belongs
to one /region/. A region is identified by a 'RegionIndex' and represents some
address that would be chosen at runtime by the loader (e.g., the virtual address
of an ELF segment containing position-independent code). Thus, in this module,
an address ('MemAddr') consists of a pair of a 'RegionIndex' and an offset into
that region. A 'MemAddr' with a 'RegionIndex' of 0 represents an /absolute/
address.

A segment ('MemSegment') is a contiguous sequence of bytes that will be loaded
into runtime memory. Segments do not necessarily have a known runtime address.
Instead, they use some 'RegionIndex' as a "base" address and are located at some
fixed offset from that base. Multiple segments can have the same 'RegionIndex'
as their base; this indicates that they will have a fixed offset relative to one
another at runtime. A 'MemSegment' with a 'RegionIndex' of 0 has a statically
known address, which is exactly its 'segmentOffset'. This notion of segment
is similar to an ELF segment. It is unrelated to the x86 notion of memory
segmentation.

= Addresses and related types

As described above, an address ('MemAddr') consists of a base ('RegionIndex')
and an offset. This section describes a few types that are adjacent to this one,
along with their intended use-cases.

A @'MemWord' w@ is a @w@-bit machine word. This may be treated as an absolute
address when @w@ is the width of a pointer ('absoluteAddr').

A 'MemSegmentOff' is notionally a pair @('MemSegment', offset)@, where @offset@
is an offset into the 'MemSegment'. The 'MemSegmentOff's produced by this module
are guaranteed to be valid, making it possible to look up the contents of the
memory they point to.

Each of the above types is parameterized by the number of bits in an address.
Most have an alias prefixed with @Arch@ that is instead parameterized by
architecture, with the width parameter filled in according to the declared width
of the architecture (e.g., 'Data.Macaw.CFG.AssignRhs.ArchMemAddr').
-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableSuperClasses #-}
module Data.Macaw.Memory
  ( Memory
    -- * Inspecting memory
  , memAddrWidth
  , memWidth
  , memSegments
  , memAsAddrPairs
    -- * Constructing memory
  , emptyMemory
  , insertMemSegment
  , InsertError(..)
  , showInsertError
    -- * Load values
  , memBaseAddr
  , memSetBaseAddr
  , memBindSectionIndex
  , memSectionIndexMap
  , memSegmentIndexMap
  , memBindSegmentIndex
    -- * Memory segments
  , MemSegment
  , memSegment
  , segmentBase
  , RegionIndex
  , segmentOffset
  , segmentFlags
  , segmentSize
  , ppMemSegment
    -- ** MemChunk
  , MemChunk(..)
  , Relocation(..)
  , module Data.BinarySymbols
    -- ** MemChunk operations
  , forcedTakeMemChunks
  , splitMemChunks
  , SplitError(..)
    -- * MemWidth
  , MemWidth(..)
  , memWidthNatRepr
    -- * MemWord
  , MemWord
  , zeroMemWord
  , memWord
  , memWordValue
  , memWordToUnsigned
  , memWordToSigned
  , addrRead
    -- * MemInt
  , MemInt
  , memInt
  , memIntValue
    -- * Addresses
  , MemAddr(..)
  , absoluteAddr
  , segmentOffAddr
  , asAbsoluteAddr
  , diffAddr
  , incAddr
  , addrLeastBit
  , clearAddrLeastBit
  , asSegmentOff
    -- * Segment offsets
  , MemSegmentOff
    -- ** Queries
  , segoffSegment
  , segoffOffset
  , segoffAddr
  , segoffAsAbsoluteAddr
  , segoffBytesLeft
  , segoffContentsAfter
    -- ** Construction segment offsets.
  , resolveRegionOff
  , resolveAbsoluteAddr
  , resolveSegmentOff
    -- ** Modifying
  , incSegmentOff
  , diffSegmentOff
  , clearSegmentOffLeastBit
    -- * Reading
  , MemoryError(..)
  , addrContentsAfter
  , readByteString
  , readAddr
  , readSegmentOff
  , readWord8
  , readWord16be
  , readWord16le
  , readWord32be
  , readWord32le
  , readWord64be
  , readWord64le
  , NullTermString(..)
  , readNullTermString
    -- * AddrWidthRepr
  , AddrWidthRepr(..)
  , addrWidthReprByteCount
  , addrWidthNatRepr
  , addrWidthClass
    -- * Endianness
  , Endianness(..)
  , bytesToInteger
  , bsWord8
  , ElfBS.bsWord16be
  , ElfBS.bsWord16le
  , bsWord32
  , ElfBS.bsWord32be
  , ElfBS.bsWord32le
  , bsWord64
  , ElfBS.bsWord64be
  , ElfBS.bsWord64le
    -- * Memory search
  , findByteStringMatches
  , relativeSegmentContents
    -- * Generating [MemChunk] values from relocations.
  , RelocEntry(..)
  , ResolveFn
    -- * Deprecated declarations
  , SegmentRange
  , takeSegmentPrefix
  , splitSegmentRangeList
  , dropSegmentRangeListBytes
  , dropErrorAsMemError
  , executableSegments
  , readonlySegments
  , memWordInteger
  , memWordSigned
  , resolveAddr
  , relativeSegmentAddr
  , msegAddr
  , contentsAfterSegmentOff
  , msegSegment
  , msegOffset
  , msegByteCountAfter
  , relativeAddr
  ) where

import           Control.Monad
import           Data.BinarySymbols
import           Data.Bits
import qualified Data.ByteString as BS
import qualified Data.ElfEdit.ByteString as ElfBS
import           Data.Int (Int32, Int64)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Monoid
import           Data.Proxy
import           Data.Word
import           GHC.Natural
import           GHC.TypeLits
import           Language.Haskell.TH.Syntax
import           Numeric (showHex)
import           Prettyprinter

import           Data.Parameterized.Classes
import           Data.Parameterized.NatRepr

import qualified Data.Macaw.Memory.Permissions as Perm

import           Prelude

------------------------------------------------------------------------
-- AddrWidthRepr

-- | An address width
data AddrWidthRepr w
   = (w ~ 32) => Addr32
     -- ^ A 32-bit address
   | (w ~ 64) => Addr64
     -- ^ A 64-bit address

deriving instance Show (AddrWidthRepr w)

instance TestEquality AddrWidthRepr where
  testEquality :: forall (a :: Natural) (b :: Natural).
AddrWidthRepr a -> AddrWidthRepr b -> Maybe (a :~: b)
testEquality AddrWidthRepr a
Addr32 AddrWidthRepr b
Addr32 = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality AddrWidthRepr a
Addr64 AddrWidthRepr b
Addr64 = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality AddrWidthRepr a
_ AddrWidthRepr b
_ = Maybe (a :~: b)
forall a. Maybe a
Nothing

instance OrdF AddrWidthRepr where
  compareF :: forall (x :: Natural) (y :: Natural).
AddrWidthRepr x -> AddrWidthRepr y -> OrderingF x y
compareF AddrWidthRepr x
Addr32 AddrWidthRepr y
Addr32 = OrderingF x x
OrderingF x y
forall {k} (x :: k). OrderingF x x
EQF
  compareF AddrWidthRepr x
Addr32 AddrWidthRepr y
Addr64 = OrderingF x y
forall {k} (x :: k) (y :: k). OrderingF x y
LTF
  compareF AddrWidthRepr x
Addr64 AddrWidthRepr y
Addr32 = OrderingF x y
forall {k} (x :: k) (y :: k). OrderingF x y
GTF
  compareF AddrWidthRepr x
Addr64 AddrWidthRepr y
Addr64 = OrderingF x x
OrderingF x y
forall {k} (x :: k). OrderingF x x
EQF

-- | Number of bytes in addr width repr.
addrWidthReprByteCount :: AddrWidthRepr w -> Natural
addrWidthReprByteCount :: forall (w :: Natural). AddrWidthRepr w -> Natural
addrWidthReprByteCount AddrWidthRepr w
Addr32 = Natural
4
addrWidthReprByteCount AddrWidthRepr w
Addr64 = Natural
8

-- | The nat representation of this address.
addrWidthNatRepr :: AddrWidthRepr w -> NatRepr w
addrWidthNatRepr :: forall (w :: Natural). AddrWidthRepr w -> NatRepr w
addrWidthNatRepr AddrWidthRepr w
Addr32 = NatRepr w
forall (n :: Natural). KnownNat n => NatRepr n
knownNat
addrWidthNatRepr AddrWidthRepr w
Addr64 = NatRepr w
forall (n :: Natural). KnownNat n => NatRepr n
knownNat

------------------------------------------------------------------------
-- Endianness

-- | Indicates whether bytes are stored in big or little endian representation.
--
-- In a big endian representation, the most significant byte is stored first;
-- In a little endian representation, the most significant byte is stored last.
data Endianness = BigEndian | LittleEndian
  deriving (Endianness -> Endianness -> Bool
(Endianness -> Endianness -> Bool)
-> (Endianness -> Endianness -> Bool) -> Eq Endianness
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Endianness -> Endianness -> Bool
== :: Endianness -> Endianness -> Bool
$c/= :: Endianness -> Endianness -> Bool
/= :: Endianness -> Endianness -> Bool
Eq, Eq Endianness
Eq Endianness =>
(Endianness -> Endianness -> Ordering)
-> (Endianness -> Endianness -> Bool)
-> (Endianness -> Endianness -> Bool)
-> (Endianness -> Endianness -> Bool)
-> (Endianness -> Endianness -> Bool)
-> (Endianness -> Endianness -> Endianness)
-> (Endianness -> Endianness -> Endianness)
-> Ord Endianness
Endianness -> Endianness -> Bool
Endianness -> Endianness -> Ordering
Endianness -> Endianness -> Endianness
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Endianness -> Endianness -> Ordering
compare :: Endianness -> Endianness -> Ordering
$c< :: Endianness -> Endianness -> Bool
< :: Endianness -> Endianness -> Bool
$c<= :: Endianness -> Endianness -> Bool
<= :: Endianness -> Endianness -> Bool
$c> :: Endianness -> Endianness -> Bool
> :: Endianness -> Endianness -> Bool
$c>= :: Endianness -> Endianness -> Bool
>= :: Endianness -> Endianness -> Bool
$cmax :: Endianness -> Endianness -> Endianness
max :: Endianness -> Endianness -> Endianness
$cmin :: Endianness -> Endianness -> Endianness
min :: Endianness -> Endianness -> Endianness
Ord, Int -> Endianness -> ShowS
[Endianness] -> ShowS
Endianness -> String
(Int -> Endianness -> ShowS)
-> (Endianness -> String)
-> ([Endianness] -> ShowS)
-> Show Endianness
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Endianness -> ShowS
showsPrec :: Int -> Endianness -> ShowS
$cshow :: Endianness -> String
show :: Endianness -> String
$cshowList :: [Endianness] -> ShowS
showList :: [Endianness] -> ShowS
Show, (forall (m :: Type -> Type). Quote m => Endianness -> m Exp)
-> (forall (m :: Type -> Type).
    Quote m =>
    Endianness -> Code m Endianness)
-> Lift Endianness
forall t.
(forall (m :: Type -> Type). Quote m => t -> m Exp)
-> (forall (m :: Type -> Type). Quote m => t -> Code m t) -> Lift t
forall (m :: Type -> Type). Quote m => Endianness -> m Exp
forall (m :: Type -> Type).
Quote m =>
Endianness -> Code m Endianness
$clift :: forall (m :: Type -> Type). Quote m => Endianness -> m Exp
lift :: forall (m :: Type -> Type). Quote m => Endianness -> m Exp
$cliftTyped :: forall (m :: Type -> Type).
Quote m =>
Endianness -> Code m Endianness
liftTyped :: forall (m :: Type -> Type).
Quote m =>
Endianness -> Code m Endianness
Lift)

instance Hashable Endianness where
  hashWithSalt :: Int -> Endianness -> Int
hashWithSalt Int
s Endianness
BigEndian    = Int
s Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
0::Int)
  hashWithSalt Int
s Endianness
LittleEndian = Int
s Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
1::Int)

-- | Convert a byte string to an integer using the provided
-- endianness.
bytesToInteger :: Endianness -> BS.ByteString -> Integer
bytesToInteger :: Endianness -> ByteString -> Integer
bytesToInteger Endianness
BigEndian = (Integer -> Word8 -> Integer) -> Integer -> ByteString -> Integer
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' Integer -> Word8 -> Integer
forall {a}. Integral a => Integer -> a -> Integer
f Integer
0
  where f :: Integer -> a -> Integer
f Integer
x a
w = (Integer
x Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
8) Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. a -> Integer
forall a. Integral a => a -> Integer
toInteger a
w
bytesToInteger Endianness
LittleEndian = (Word8 -> Integer -> Integer) -> Integer -> ByteString -> Integer
forall a. (Word8 -> a -> a) -> a -> ByteString -> a
BS.foldr' Word8 -> Integer -> Integer
forall {a}. Integral a => a -> Integer -> Integer
f Integer
0
  where f :: a -> Integer -> Integer
f a
w Integer
x = (Integer
x Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
8) Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. a -> Integer
forall a. Integral a => a -> Integer
toInteger a
w

------------------------------------------------------------------------
-- Utilities

-- | Split a bytestring into an equivalent list of byte strings with a given size.
--
-- This drops the last bits if the total length is not a multiple of the size.
regularChunks :: Int -> BS.ByteString -> [BS.ByteString]
regularChunks :: Int -> ByteString -> [ByteString]
regularChunks Int
sz ByteString
bs
  | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
sz = []
  | Bool
otherwise = Int -> ByteString -> ByteString
BS.take Int
sz ByteString
bs ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: Int -> ByteString -> [ByteString]
regularChunks Int
sz (Int -> ByteString -> ByteString
BS.drop Int
sz ByteString
bs)

bsWord8 :: BS.ByteString -> Word8
bsWord8 :: ByteString -> Word8
bsWord8 ByteString
bs
    | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1 = String -> Word8
forall a. HasCallStack => String -> a
error String
"bsWord8 given bytestring with bad length."
    | Bool
otherwise = HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
bs Int
0

-- | Convert a bytestring to an unsigned with the given endianness.
bsWord32 :: Endianness -> BS.ByteString -> Word32
bsWord32 :: Endianness -> ByteString -> Word32
bsWord32 Endianness
BigEndian    = HasCallStack => ByteString -> Word32
ByteString -> Word32
ElfBS.bsWord32be
bsWord32 Endianness
LittleEndian = HasCallStack => ByteString -> Word32
ByteString -> Word32
ElfBS.bsWord32le

bsWord64 :: Endianness -> BS.ByteString -> Word64
bsWord64 :: Endianness -> ByteString -> Word64
bsWord64 Endianness
BigEndian    = HasCallStack => ByteString -> Word64
ByteString -> Word64
ElfBS.bsWord64be
bsWord64 Endianness
LittleEndian = HasCallStack => ByteString -> Word64
ByteString -> Word64
ElfBS.bsWord64le

------------------------------------------------------------------------
-- MemWord

-- | This represents a bitvector value with `w` bits.
--
-- Operations on it require the `MemWidth` constraint to be satisfied, so in practice
-- this only works for 32 and 64-bit values.
newtype MemWord (w :: Nat) = MemWord { forall (w :: Natural). MemWord w -> Word64
memWordValue :: Word64 }

-- | Equal to 0
zeroMemWord :: MemWord w
zeroMemWord :: forall (w :: Natural). MemWord w
zeroMemWord = Word64 -> MemWord w
forall (w :: Natural). Word64 -> MemWord w
MemWord Word64
0

-- | Convert word64 @x@ into mem word @x mod 2^w-1@.
memWord :: forall w . MemWidth w => Word64 -> MemWord w
memWord :: forall (w :: Natural). MemWidth w => Word64 -> MemWord w
memWord Word64
x = Word64 -> MemWord w
forall (w :: Natural). Word64 -> MemWord w
MemWord (Word64
x Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Proxy w -> Word64
forall (w :: Natural) (p :: Natural -> Type).
MemWidth w =>
p w -> Word64
forall (p :: Natural -> Type). p w -> Word64
addrWidthMask Proxy w
p)
  where p :: Proxy w
        p :: Proxy w
p = Proxy w
forall {k} (t :: k). Proxy t
Proxy

instance Hashable (MemWord w) where
  hashWithSalt :: Int -> MemWord w -> Int
hashWithSalt Int
s (MemWord Word64
w) = Int
s Int -> Word64 -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Word64
w

instance Show (MemWord w) where
  showsPrec :: Int -> MemWord w -> ShowS
showsPrec Int
_ (MemWord Word64
w) = String -> ShowS
showString String
"0x" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ShowS
forall a. Integral a => a -> ShowS
showHex Word64
w

instance Pretty (MemWord w) where
  pretty :: forall ann. MemWord w -> Doc ann
pretty = MemWord w -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow

instance Eq (MemWord w) where
  MemWord Word64
x == :: MemWord w -> MemWord w -> Bool
== MemWord Word64
y = Word64
x Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
y

instance Ord (MemWord w) where
  compare :: MemWord w -> MemWord w -> Ordering
compare (MemWord Word64
x) (MemWord Word64
y) = Word64 -> Word64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Word64
x Word64
y

-- | Typeclass for widths supported by memory addresses.
--
-- This only will work for 32 and 64bit values due to requirement
-- to implement `addrWidthRepr`.
class (1 <= w) => MemWidth w where

  -- | Returns @AddrWidthRepr@ to identify width of pointer.
  --
  -- The argument is ignored.
  addrWidthRepr :: p w -> AddrWidthRepr w

  -- | Returns number of bytes in addr.
  --
  -- The argument is not evaluated.
  addrSize :: p w -> Int

  -- | @addrWidthMask w@ returns @2^(8 * addrSize w) - 1@.
  addrWidthMask :: p w -> Word64

  -- | Rotates the value by the given index.
  addrRotate :: MemWord w -> Int -> MemWord w

memWidthNatRepr :: MemWidth w => NatRepr w
memWidthNatRepr :: forall (w :: Natural). MemWidth w => NatRepr w
memWidthNatRepr = AddrWidthRepr w -> NatRepr w
forall (w :: Natural). AddrWidthRepr w -> NatRepr w
addrWidthNatRepr (NatRepr w -> AddrWidthRepr w
forall (w :: Natural) (p :: Natural -> Type).
MemWidth w =>
p w -> AddrWidthRepr w
forall (p :: Natural -> Type). p w -> AddrWidthRepr w
addrWidthRepr NatRepr w
forall (w :: Natural). MemWidth w => NatRepr w
memWidthNatRepr)

-- | Read an address with the given endianess.
--
-- This returns nothing if the bytestring is too short.
addrRead :: forall w . MemWidth w => Endianness -> BS.ByteString -> Maybe (MemWord w)
addrRead :: forall (w :: Natural).
MemWidth w =>
Endianness -> ByteString -> Maybe (MemWord w)
addrRead Endianness
e ByteString
s =
  case Proxy w -> AddrWidthRepr w
forall (w :: Natural) (p :: Natural -> Type).
MemWidth w =>
p w -> AddrWidthRepr w
forall (p :: Natural -> Type). p w -> AddrWidthRepr w
addrWidthRepr (Proxy w
forall {k} (t :: k). Proxy t
Proxy :: Proxy w) of
    AddrWidthRepr w
Addr32 | ByteString -> Int
BS.length ByteString
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4 -> Maybe (MemWord w)
forall a. Maybe a
Nothing
           | Bool
otherwise -> MemWord w -> Maybe (MemWord w)
forall a. a -> Maybe a
Just (MemWord w -> Maybe (MemWord w)) -> MemWord w -> Maybe (MemWord w)
forall a b. (a -> b) -> a -> b
$ Word64 -> MemWord w
forall (w :: Natural). Word64 -> MemWord w
MemWord (Word64 -> MemWord w) -> Word64 -> MemWord w
forall a b. (a -> b) -> a -> b
$ Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word64) -> Word32 -> Word64
forall a b. (a -> b) -> a -> b
$ Endianness -> ByteString -> Word32
bsWord32 Endianness
e ByteString
s
    AddrWidthRepr w
Addr64 | ByteString -> Int
BS.length ByteString
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
8 -> Maybe (MemWord w)
forall a. Maybe a
Nothing
           | Bool
otherwise -> MemWord w -> Maybe (MemWord w)
forall a. a -> Maybe a
Just (MemWord w -> Maybe (MemWord w)) -> MemWord w -> Maybe (MemWord w)
forall a b. (a -> b) -> a -> b
$ Word64 -> MemWord w
forall (w :: Natural). Word64 -> MemWord w
MemWord (Word64 -> MemWord w) -> Word64 -> MemWord w
forall a b. (a -> b) -> a -> b
$ Endianness -> ByteString -> Word64
bsWord64 Endianness
e ByteString
s


-- | Return the value represented by the MemWord as an unsigned integer.
memWordToUnsigned  :: MemWord w -> Integer
memWordToUnsigned :: forall (w :: Natural). MemWord w -> Integer
memWordToUnsigned = Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Integer)
-> (MemWord w -> Word64) -> MemWord w -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemWord w -> Word64
forall (w :: Natural). MemWord w -> Word64
memWordValue

-- | Treat the word as a signed integer.
memWordToSigned :: MemWidth w => MemWord w -> Integer
memWordToSigned :: forall (w :: Natural). MemWidth w => MemWord w -> Integer
memWordToSigned MemWord w
w = if Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
bound then Integer
iInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
2Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
bound else Integer
i
  where i :: Integer
i = MemWord w -> Integer
forall (w :: Natural). MemWord w -> Integer
memWordInteger MemWord w
w
        bound :: Integer
bound = Integer
2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(MemWord w -> Int
forall (w :: Natural) (p :: Natural -> Type).
MemWidth w =>
p w -> Int
addrBitSize MemWord w
wInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)

-- | Treat the word as an integer.
memWordInteger :: MemWord w -> Integer
memWordInteger :: forall (w :: Natural). MemWord w -> Integer
memWordInteger = MemWord w -> Integer
forall (w :: Natural). MemWord w -> Integer
memWordToUnsigned
{-# DEPRECATED memWordInteger "Use memWordToUnsigned" #-}

-- | Treat the word as a signed integer.
memWordSigned :: MemWidth w => MemWord w -> Integer
memWordSigned :: forall (w :: Natural). MemWidth w => MemWord w -> Integer
memWordSigned = MemWord w -> Integer
forall (w :: Natural). MemWidth w => MemWord w -> Integer
memWordToSigned

-- | Returns number of bits in address.
addrBitSize :: MemWidth w => p w -> Int
addrBitSize :: forall (w :: Natural) (p :: Natural -> Type).
MemWidth w =>
p w -> Int
addrBitSize p w
w = Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* p w -> Int
forall (w :: Natural) (p :: Natural -> Type).
MemWidth w =>
p w -> Int
forall (p :: Natural -> Type). p w -> Int
addrSize p w
w

instance MemWidth w => Num (MemWord w) where
  MemWord Word64
x + :: MemWord w -> MemWord w -> MemWord w
+ MemWord Word64
y = Word64 -> MemWord w
forall (w :: Natural). MemWidth w => Word64 -> MemWord w
memWord (Word64 -> MemWord w) -> Word64 -> MemWord w
forall a b. (a -> b) -> a -> b
$ Word64
x Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
y
  MemWord Word64
x - :: MemWord w -> MemWord w -> MemWord w
- MemWord Word64
y = Word64 -> MemWord w
forall (w :: Natural). MemWidth w => Word64 -> MemWord w
memWord (Word64 -> MemWord w) -> Word64 -> MemWord w
forall a b. (a -> b) -> a -> b
$ Word64
x Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
y
  MemWord Word64
x * :: MemWord w -> MemWord w -> MemWord w
* MemWord Word64
y = Word64 -> MemWord w
forall (w :: Natural). MemWidth w => Word64 -> MemWord w
memWord (Word64 -> MemWord w) -> Word64 -> MemWord w
forall a b. (a -> b) -> a -> b
$ Word64
x Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
y
  abs :: MemWord w -> MemWord w
abs = MemWord w -> MemWord w
forall a. a -> a
id
  fromInteger :: Integer -> MemWord w
fromInteger = Word64 -> MemWord w
forall (w :: Natural). MemWidth w => Word64 -> MemWord w
memWord (Word64 -> MemWord w)
-> (Integer -> Word64) -> Integer -> MemWord w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Word64
forall a. Num a => Integer -> a
fromInteger
  negate :: MemWord w -> MemWord w
negate (MemWord Word64
x) = Word64 -> MemWord w
forall (w :: Natural). MemWidth w => Word64 -> MemWord w
memWord (Word64 -> Word64
forall a. Num a => a -> a
negate Word64
x)
  signum :: MemWord w -> MemWord w
signum (MemWord Word64
x) = Word64 -> MemWord w
forall (w :: Natural). MemWidth w => Word64 -> MemWord w
memWord (Word64 -> Word64
forall a. Num a => a -> a
signum Word64
x)

instance MemWidth w => Bits (MemWord w) where

  MemWord Word64
x .&. :: MemWord w -> MemWord w -> MemWord w
.&. MemWord Word64
y = Word64 -> MemWord w
forall (w :: Natural). MemWidth w => Word64 -> MemWord w
memWord (Word64
x Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
y)
  MemWord Word64
x .|. :: MemWord w -> MemWord w -> MemWord w
.|. MemWord Word64
y = Word64 -> MemWord w
forall (w :: Natural). MemWidth w => Word64 -> MemWord w
memWord (Word64
x Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
y)
  MemWord Word64
x xor :: MemWord w -> MemWord w -> MemWord w
`xor` MemWord Word64
y = Word64 -> MemWord w
forall (w :: Natural). MemWidth w => Word64 -> MemWord w
memWord (Word64
x Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
y)
  complement :: MemWord w -> MemWord w
complement (MemWord Word64
x) = Word64 -> MemWord w
forall (w :: Natural). MemWidth w => Word64 -> MemWord w
memWord (Word64 -> Word64
forall a. Bits a => a -> a
complement Word64
x)
  MemWord Word64
x shift :: MemWord w -> Int -> MemWord w
`shift` Int
i = Word64 -> MemWord w
forall (w :: Natural). MemWidth w => Word64 -> MemWord w
memWord (Word64
x Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shift` Int
i)
  MemWord w
x rotate :: MemWord w -> Int -> MemWord w
`rotate` Int
i = MemWord w -> Int -> MemWord w
forall (w :: Natural). MemWidth w => MemWord w -> Int -> MemWord w
addrRotate MemWord w
x Int
i
  bitSize :: MemWord w -> Int
bitSize = MemWord w -> Int
forall (w :: Natural) (p :: Natural -> Type).
MemWidth w =>
p w -> Int
addrBitSize
  bitSizeMaybe :: MemWord w -> Maybe Int
bitSizeMaybe MemWord w
x = Int -> Maybe Int
forall a. a -> Maybe a
Just (MemWord w -> Int
forall (w :: Natural) (p :: Natural -> Type).
MemWidth w =>
p w -> Int
addrBitSize MemWord w
x)
  isSigned :: MemWord w -> Bool
isSigned MemWord w
_ = Bool
False
  MemWord Word64
x testBit :: MemWord w -> Int -> Bool
`testBit` Int
i = Word64
x Word64 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
i
  bit :: Int -> MemWord w
bit Int
i = Word64 -> MemWord w
forall (w :: Natural). MemWidth w => Word64 -> MemWord w
memWord (Int -> Word64
forall a. Bits a => Int -> a
bit Int
i)
  popCount :: MemWord w -> Int
popCount (MemWord Word64
x) = Word64 -> Int
forall a. Bits a => a -> Int
popCount Word64
x

instance MemWidth w => Enum (MemWord w) where
  toEnum :: Int -> MemWord w
toEnum = Word64 -> MemWord w
forall (w :: Natural). MemWidth w => Word64 -> MemWord w
memWord (Word64 -> MemWord w) -> (Int -> Word64) -> Int -> MemWord w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  fromEnum :: MemWord w -> Int
fromEnum (MemWord Word64
x) = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
x

instance MemWidth w => Real (MemWord w) where
  toRational :: MemWord w -> Rational
toRational (MemWord Word64
x) = Word64 -> Rational
forall a. Real a => a -> Rational
toRational Word64
x

instance MemWidth w => Integral (MemWord w) where
  MemWord Word64
x quotRem :: MemWord w -> MemWord w -> (MemWord w, MemWord w)
`quotRem` MemWord Word64
y = (Word64 -> MemWord w
forall (w :: Natural). Word64 -> MemWord w
MemWord Word64
q, Word64 -> MemWord w
forall (w :: Natural). Word64 -> MemWord w
MemWord Word64
r)
    where (Word64
q,Word64
r) = Word64
x Word64 -> Word64 -> (Word64, Word64)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Word64
y
  toInteger :: MemWord w -> Integer
toInteger (MemWord Word64
x) = Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
x

instance MemWidth w => Bounded (MemWord w) where
  minBound :: MemWord w
minBound = MemWord w
0
  maxBound :: MemWord w
maxBound = Word64 -> MemWord w
forall (w :: Natural). Word64 -> MemWord w
MemWord (Proxy w -> Word64
forall (w :: Natural) (p :: Natural -> Type).
MemWidth w =>
p w -> Word64
forall (p :: Natural -> Type). p w -> Word64
addrWidthMask (Proxy w
forall {k} (t :: k). Proxy t
Proxy :: Proxy w))

instance MemWidth 32 where
  addrWidthRepr :: forall (p :: Natural -> Type). p 32 -> AddrWidthRepr 32
addrWidthRepr p 32
_ = AddrWidthRepr 32
forall (w :: Natural). (w ~ 32) => AddrWidthRepr w
Addr32
  addrWidthMask :: forall (p :: Natural -> Type). p 32 -> Word64
addrWidthMask p 32
_ = Word64
0xffffffff
  addrRotate :: MemWord 32 -> Int -> MemWord 32
addrRotate (MemWord Word64
w) Int
i =
    Word64 -> MemWord 32
forall (w :: Natural). Word64 -> MemWord w
MemWord (Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w :: Word32) Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`rotate` Int
i))
  addrSize :: forall (p :: Natural -> Type). p 32 -> Int
addrSize p 32
_ = Int
4

instance MemWidth 64 where
  addrWidthRepr :: forall (p :: Natural -> Type). p 64 -> AddrWidthRepr 64
addrWidthRepr p 64
_ = AddrWidthRepr 64
forall (w :: Natural). (w ~ 64) => AddrWidthRepr w
Addr64
  addrWidthMask :: forall (p :: Natural -> Type). p 64 -> Word64
addrWidthMask p 64
_ = Word64
0xffffffffffffffff
  addrRotate :: MemWord 64 -> Int -> MemWord 64
addrRotate (MemWord Word64
w) Int
i = Word64 -> MemWord 64
forall (w :: Natural). Word64 -> MemWord w
MemWord (Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`rotate` Int
i)
  addrSize :: forall (p :: Natural -> Type). p 64 -> Int
addrSize p 64
_ = Int
8

-- | Number of bytes in an address
addrWidthClass :: AddrWidthRepr w -> (MemWidth w => a) -> a
addrWidthClass :: forall (w :: Natural) a. AddrWidthRepr w -> (MemWidth w => a) -> a
addrWidthClass AddrWidthRepr w
Addr32 MemWidth w => a
x = a
MemWidth w => a
x
addrWidthClass AddrWidthRepr w
Addr64 MemWidth w => a
x = a
MemWidth w => a
x

------------------------------------------------------------------------
-- MemInt

-- | A signed integer with the given width.
newtype MemInt (w::Nat) = MemInt { forall (w :: Natural). MemInt w -> Int64
memIntValue :: Int64 }

-- | Convert `Int64` @x@ into mem word @x mod 2^w-1@.
memInt :: forall w . MemWidth w => Int64 -> MemInt w
memInt :: forall (w :: Natural). MemWidth w => Int64 -> MemInt w
memInt =
  case Proxy w -> AddrWidthRepr w
forall (w :: Natural) (p :: Natural -> Type).
MemWidth w =>
p w -> AddrWidthRepr w
forall (p :: Natural -> Type). p w -> AddrWidthRepr w
addrWidthRepr (Proxy w
forall {k} (t :: k). Proxy t
Proxy :: Proxy w) of
    AddrWidthRepr w
Addr32 -> \Int64
x -> Int64 -> MemInt w
forall (w :: Natural). Int64 -> MemInt w
MemInt (Int32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
x :: Int32))
    AddrWidthRepr w
Addr64 -> \Int64
x -> Int64 -> MemInt w
forall (w :: Natural). Int64 -> MemInt w
MemInt Int64
x

instance Eq (MemInt w) where
  MemInt w
x == :: MemInt w -> MemInt w -> Bool
== MemInt w
y = MemInt w -> Int64
forall (w :: Natural). MemInt w -> Int64
memIntValue MemInt w
x Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== MemInt w -> Int64
forall (w :: Natural). MemInt w -> Int64
memIntValue MemInt w
y

instance Ord (MemInt w) where
  compare :: MemInt w -> MemInt w -> Ordering
compare MemInt w
x MemInt w
y = Int64 -> Int64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (MemInt w -> Int64
forall (w :: Natural). MemInt w -> Int64
memIntValue MemInt w
x) (MemInt w -> Int64
forall (w :: Natural). MemInt w -> Int64
memIntValue MemInt w
y)

instance Hashable (MemInt w) where
  hashWithSalt :: Int -> MemInt w -> Int
hashWithSalt Int
s (MemInt Int64
w) = Int
s Int -> Int64 -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Int64
w

instance Pretty (MemInt w) where
  pretty :: forall ann. MemInt w -> Doc ann
pretty = Int64 -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (Int64 -> Doc ann) -> (MemInt w -> Int64) -> MemInt w -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemInt w -> Int64
forall (w :: Natural). MemInt w -> Int64
memIntValue

instance Show (MemInt w) where
  showsPrec :: Int -> MemInt w -> ShowS
showsPrec Int
p (MemInt Int64
i) = Int -> Int64 -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p Int64
i

instance MemWidth w => Bounded (MemInt w) where
  minBound :: MemInt w
minBound =
    case Proxy w -> AddrWidthRepr w
forall (w :: Natural) (p :: Natural -> Type).
MemWidth w =>
p w -> AddrWidthRepr w
forall (p :: Natural -> Type). p w -> AddrWidthRepr w
addrWidthRepr (Proxy w
forall {k} (t :: k). Proxy t
Proxy :: Proxy w) of
      AddrWidthRepr w
Addr32 -> Int64 -> MemInt w
forall (w :: Natural). Int64 -> MemInt w
MemInt (Int32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32
forall a. Bounded a => a
minBound :: Int32))
      AddrWidthRepr w
Addr64 -> Int64 -> MemInt w
forall (w :: Natural). Int64 -> MemInt w
MemInt Int64
forall a. Bounded a => a
minBound
  maxBound :: MemInt w
maxBound =
    case Proxy w -> AddrWidthRepr w
forall (w :: Natural) (p :: Natural -> Type).
MemWidth w =>
p w -> AddrWidthRepr w
forall (p :: Natural -> Type). p w -> AddrWidthRepr w
addrWidthRepr (Proxy w
forall {k} (t :: k). Proxy t
Proxy :: Proxy w) of
      AddrWidthRepr w
Addr32 -> Int64 -> MemInt w
forall (w :: Natural). Int64 -> MemInt w
MemInt (Int32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32
forall a. Bounded a => a
maxBound :: Int32))
      AddrWidthRepr w
Addr64 -> Int64 -> MemInt w
forall (w :: Natural). Int64 -> MemInt w
MemInt Int64
forall a. Bounded a => a
maxBound

instance MemWidth w => Num (MemInt w) where
  MemInt w
x + :: MemInt w -> MemInt w -> MemInt w
+ MemInt w
y = Int64 -> MemInt w
forall (w :: Natural). MemWidth w => Int64 -> MemInt w
memInt (Int64 -> MemInt w) -> Int64 -> MemInt w
forall a b. (a -> b) -> a -> b
$ MemInt w -> Int64
forall (w :: Natural). MemInt w -> Int64
memIntValue MemInt w
x Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ MemInt w -> Int64
forall (w :: Natural). MemInt w -> Int64
memIntValue MemInt w
y
  MemInt w
x - :: MemInt w -> MemInt w -> MemInt w
- MemInt w
y = Int64 -> MemInt w
forall (w :: Natural). MemWidth w => Int64 -> MemInt w
memInt (Int64 -> MemInt w) -> Int64 -> MemInt w
forall a b. (a -> b) -> a -> b
$ MemInt w -> Int64
forall (w :: Natural). MemInt w -> Int64
memIntValue MemInt w
x Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- MemInt w -> Int64
forall (w :: Natural). MemInt w -> Int64
memIntValue MemInt w
y
  MemInt w
x * :: MemInt w -> MemInt w -> MemInt w
* MemInt w
y = Int64 -> MemInt w
forall (w :: Natural). MemWidth w => Int64 -> MemInt w
memInt (Int64 -> MemInt w) -> Int64 -> MemInt w
forall a b. (a -> b) -> a -> b
$ MemInt w -> Int64
forall (w :: Natural). MemInt w -> Int64
memIntValue MemInt w
x Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* MemInt w -> Int64
forall (w :: Natural). MemInt w -> Int64
memIntValue MemInt w
y
  abs :: MemInt w -> MemInt w
abs = Int64 -> MemInt w
forall (w :: Natural). MemWidth w => Int64 -> MemInt w
memInt (Int64 -> MemInt w) -> (MemInt w -> Int64) -> MemInt w -> MemInt w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int64
forall a. Num a => a -> a
abs (Int64 -> Int64) -> (MemInt w -> Int64) -> MemInt w -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemInt w -> Int64
forall (w :: Natural). MemInt w -> Int64
memIntValue
  fromInteger :: Integer -> MemInt w
fromInteger = Int64 -> MemInt w
forall (w :: Natural). MemWidth w => Int64 -> MemInt w
memInt (Int64 -> MemInt w) -> (Integer -> Int64) -> Integer -> MemInt w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int64
forall a. Num a => Integer -> a
fromInteger
  negate :: MemInt w -> MemInt w
negate = Int64 -> MemInt w
forall (w :: Natural). MemWidth w => Int64 -> MemInt w
memInt (Int64 -> MemInt w) -> (MemInt w -> Int64) -> MemInt w -> MemInt w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int64
forall a. Num a => a -> a
negate (Int64 -> Int64) -> (MemInt w -> Int64) -> MemInt w -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemInt w -> Int64
forall (w :: Natural). MemInt w -> Int64
memIntValue
  signum :: MemInt w -> MemInt w
signum = Int64 -> MemInt w
forall (w :: Natural). MemWidth w => Int64 -> MemInt w
memInt (Int64 -> MemInt w) -> (MemInt w -> Int64) -> MemInt w -> MemInt w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int64
forall a. Num a => a -> a
signum (Int64 -> Int64) -> (MemInt w -> Int64) -> MemInt w -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemInt w -> Int64
forall (w :: Natural). MemInt w -> Int64
memIntValue

instance MemWidth w => Enum (MemInt w) where
  toEnum :: Int -> MemInt w
toEnum   = Int64 -> MemInt w
forall (w :: Natural). MemWidth w => Int64 -> MemInt w
memInt (Int64 -> MemInt w) -> (Int -> Int64) -> Int -> MemInt w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  fromEnum :: MemInt w -> Int
fromEnum = Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> (MemInt w -> Int64) -> MemInt w -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemInt w -> Int64
forall (w :: Natural). MemInt w -> Int64
memIntValue

instance MemWidth w => Real (MemInt w) where
  toRational :: MemInt w -> Rational
toRational = Int64 -> Rational
forall a. Real a => a -> Rational
toRational (Int64 -> Rational) -> (MemInt w -> Int64) -> MemInt w -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemInt w -> Int64
forall (w :: Natural). MemInt w -> Int64
memIntValue

instance MemWidth w => Integral (MemInt w) where
  MemInt w
x quotRem :: MemInt w -> MemInt w -> (MemInt w, MemInt w)
`quotRem` MemInt w
y = (Int64 -> MemInt w
forall (w :: Natural). Int64 -> MemInt w
MemInt Int64
q, Int64 -> MemInt w
forall (w :: Natural). Int64 -> MemInt w
MemInt Int64
r)
    where (Int64
q,Int64
r) = MemInt w -> Int64
forall (w :: Natural). MemInt w -> Int64
memIntValue MemInt w
x Int64 -> Int64 -> (Int64, Int64)
forall a. Integral a => a -> a -> (a, a)
`quotRem` MemInt w -> Int64
forall (w :: Natural). MemInt w -> Int64
memIntValue MemInt w
y
  toInteger :: MemInt w -> Integer
toInteger = Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Int64 -> Integer) -> (MemInt w -> Int64) -> MemInt w -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemInt w -> Int64
forall (w :: Natural). MemInt w -> Int64
memIntValue

instance MemWidth w => Bits (MemInt w) where
  MemInt Int64
x .&. :: MemInt w -> MemInt w -> MemInt w
.&. MemInt Int64
y = Int64 -> MemInt w
forall (w :: Natural). MemWidth w => Int64 -> MemInt w
memInt (Int64
x Int64 -> Int64 -> Int64
forall a. Bits a => a -> a -> a
.&. Int64
y)
  MemInt Int64
x .|. :: MemInt w -> MemInt w -> MemInt w
.|. MemInt Int64
y = Int64 -> MemInt w
forall (w :: Natural). MemWidth w => Int64 -> MemInt w
memInt (Int64
x Int64 -> Int64 -> Int64
forall a. Bits a => a -> a -> a
.|. Int64
y)
  MemInt Int64
x xor :: MemInt w -> MemInt w -> MemInt w
`xor` MemInt Int64
y = Int64 -> MemInt w
forall (w :: Natural). MemWidth w => Int64 -> MemInt w
memInt (Int64
x Int64 -> Int64 -> Int64
forall a. Bits a => a -> a -> a
`xor` Int64
y)
  complement :: MemInt w -> MemInt w
complement (MemInt Int64
x) = Int64 -> MemInt w
forall (w :: Natural). MemWidth w => Int64 -> MemInt w
memInt (Int64 -> Int64
forall a. Bits a => a -> a
complement Int64
x)
  MemInt Int64
x shift :: MemInt w -> Int -> MemInt w
`shift` Int
i = Int64 -> MemInt w
forall (w :: Natural). MemWidth w => Int64 -> MemInt w
memInt (Int64
x Int64 -> Int -> Int64
forall a. Bits a => a -> Int -> a
`shift` Int
i)
  MemInt Int64
x rotate :: MemInt w -> Int -> MemInt w
`rotate` Int
i = Int64 -> MemInt w
forall (w :: Natural). MemWidth w => Int64 -> MemInt w
memInt (Int64
x Int64 -> Int -> Int64
forall a. Bits a => a -> Int -> a
`rotate` Int
i)
  bitSize :: MemInt w -> Int
bitSize = MemInt w -> Int
forall (w :: Natural) (p :: Natural -> Type).
MemWidth w =>
p w -> Int
addrBitSize
  bitSizeMaybe :: MemInt w -> Maybe Int
bitSizeMaybe MemInt w
x = Int -> Maybe Int
forall a. a -> Maybe a
Just (MemInt w -> Int
forall (w :: Natural) (p :: Natural -> Type).
MemWidth w =>
p w -> Int
addrBitSize MemInt w
x)
  isSigned :: MemInt w -> Bool
isSigned MemInt w
_ = Bool
True
  MemInt Int64
x testBit :: MemInt w -> Int -> Bool
`testBit` Int
i = Int64
x Int64 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
i
  bit :: Int -> MemInt w
bit Int
i = Int64 -> MemInt w
forall (w :: Natural). MemWidth w => Int64 -> MemInt w
memInt (Int -> Int64
forall a. Bits a => Int -> a
bit Int
i)
  popCount :: MemInt w -> Int
popCount (MemInt Int64
x) = Int64 -> Int
forall a. Bits a => a -> Int
popCount Int64
x

------------------------------------------------------------------------
-- Relocation

-- | Information about a relocation.  This essentially is a region of
-- memory in a binary whose contents are unknown when the binary is
-- generated.
--
-- For object files, relocations are created for symbol names, as the
-- address they are stored at is assigned by the linker.  The
-- relocation generated by the compiler provides the linker with the
-- information it needs to perform relocations.
--
-- For dynamic executables and shared libraries, relocation values are
-- generated to allow the loader to load the file at a specific address.
-- These may be assigned during loading, or in the case of functions,
-- when first being invoked.
--
-- This structure contains the information needed to compute the value
-- stored in memory, and whether there are constraints on that value.
--
-- The value to be stored in a relocation @r@, is the integer computed by
-- @base + off - rel@ where
--
--  * @base@ is the address of the symbol identified by @relocationSym r@;
--
--  * @off@ is the offset @relocationOffset r@; and
--
--  * @rel@ is the address the relocation is stored at if @relocationIsRel r@
--    is true, and @0@ otherwise.
--
-- The integer value stored is encoded in a bitvector with
-- @relocationSize r@ bytes.  This is interpreted as a signed number
-- using two's complement encoding when @relocationIsSigned r@ is
-- true, and an unsigned number otherwise.  The byte order is
-- determined by @relocationEndiness r@.
--
-- Because the integer value are stored in fixed width bitvectors that
-- cannot represent all legal integer values, the code doing the
-- relocation is not allowed to place symbols at arbitrary addresses.
-- The integer value computed must fit within the given number of
-- bytes, and so relocations effectively are implicit constraints on
-- where code may be stored in memory.
data Relocation w
   = Relocation { forall (w :: Natural). Relocation w -> SymbolIdentifier
relocationSym :: !SymbolIdentifier
                  -- ^ The symbol whose address is used as the base
                  -- of the value to store.
                , forall (w :: Natural). Relocation w -> MemWord w
relocationOffset :: !(MemWord w)
                  -- ^ A constant value to add to the base
                  -- to compute the relocation
                , forall (w :: Natural). Relocation w -> Bool
relocationIsRel :: !Bool
                  -- ^ If this is true, then the value stored in the relocation
                  -- will be the difference between the relocation symbol and
                  -- offset and the address of the relocation.
                  --
                  -- If false, then the value stored is just the address of the
                  -- symbol plus the offset.
                , forall (w :: Natural). Relocation w -> Int
relocationSize :: !Int
                  -- ^ Number of bytes in memory that this relocation is
                  -- stored at.
                , forall (w :: Natural). Relocation w -> Bool
relocationIsSigned :: !Bool
                  -- ^ This indicates if the value stored will be
                  -- interpreted as an signed or unsigned number.
                , forall (w :: Natural). Relocation w -> Endianness
relocationEndianness :: !Endianness
                  -- ^ The byte order used to encode the relocation in
                  -- memory.
                , forall (w :: Natural). Relocation w -> Bool
relocationJumpSlot :: !Bool
                  -- ^ Returns true if this is a jump slot relocation.
                  --
                  -- This relocation is specifically used for global
                  -- offset table entries, and are typically resolved
                  -- when the function is first called rather than at
                  -- load time.  The address will be initially the
                  -- entry sequence stub, and will be updated once
                  -- resolved by the stub.
                }

-- | Short encoding of endianness for relocation pretty printing
showEnd :: Endianness -> ShowS
showEnd :: Endianness -> ShowS
showEnd Endianness
LittleEndian = String -> ShowS
showString String
"LE"
showEnd Endianness
BigEndian = String -> ShowS
showString String
"BE"

instance Show (Relocation w) where
  showsPrec :: Int -> Relocation w -> ShowS
showsPrec Int
_ Relocation w
r =
    String -> ShowS
showString String
"[areloc,"
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymbolIdentifier -> ShowS
forall a. Show a => a -> ShowS
shows (Relocation w -> SymbolIdentifier
forall (w :: Natural). Relocation w -> SymbolIdentifier
relocationSym Relocation w
r)
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
','
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> ShowS
forall a. Integral a => a -> ShowS
showHex (MemWord w -> Integer
forall (w :: Natural). MemWord w -> Integer
memWordInteger (Relocation w -> MemWord w
forall (w :: Natural). Relocation w -> MemWord w
relocationOffset Relocation w
r))
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
','
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows (Int
8Int -> Int -> Int
forall a. Num a => a -> a -> a
*Relocation w -> Int
forall (w :: Natural). Relocation w -> Int
relocationSize Relocation w
r)
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Relocation w -> Bool
forall (w :: Natural). Relocation w -> Bool
relocationIsRel Relocation w
r then String -> ShowS
showString String
",PC" else ShowS
forall a. a -> a
id)
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Relocation w -> Bool
forall (w :: Natural). Relocation w -> Bool
relocationIsSigned Relocation w
r then String -> ShowS
showString String
",S" else ShowS
forall a. a -> a
id)
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
',' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Endianness -> ShowS
showEnd (Relocation w -> Endianness
forall (w :: Natural). Relocation w -> Endianness
relocationEndianness Relocation w
r)
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
']'

------------------------------------------------------------------------
-- MemChunk

-- | A memory chunk describes a contiguous sequence of bytes within a segment.
--
-- The parameter denotes the width of a memory address.
--
-- Note that the term \"region\" in this type is not related to the notion of
-- \"region\" described in the module-level documentation (i.e., the @Region@
-- in 'RegionIndex').
data MemChunk (w :: Nat)
   = ByteRegion !BS.ByteString
     -- ^ A region with specific bytes
   | RelocationRegion !(Relocation w)
     -- ^ A region whose contents are computed using the expression
     -- denoted by the relocation.
   | BSSRegion !(MemWord w)
     -- ^ A region containing the given number of zero-initialized
     -- bytes.

type SegmentRange = MemChunk
{-# DEPRECATED SegmentRange "Use MemChunk" #-}

ppByte :: Word8 -> String -> String
ppByte :: Word8 -> ShowS
ppByte Word8
w | Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
16    = Char -> ShowS
showChar Char
'0' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ShowS
forall a. Integral a => a -> ShowS
showHex Word8
w
         | Bool
otherwise = Word8 -> ShowS
forall a. Integral a => a -> ShowS
showHex Word8
w

instance Show (MemChunk w) where
  showsPrec :: Int -> MemChunk w -> ShowS
showsPrec Int
_ (ByteRegion ByteString
bs)      = \String
s -> (Word8 -> ShowS) -> String -> [Word8] -> String
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Word8 -> ShowS
ppByte String
s (ByteString -> [Word8]
BS.unpack ByteString
bs)
  showsPrec Int
p (RelocationRegion Relocation w
r) = Int -> Relocation w -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p Relocation w
r
  showsPrec Int
_ (BSSRegion MemWord w
sz)       = String -> ShowS
showString String
"[bss," ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemWord w -> ShowS
forall a. Show a => a -> ShowS
shows MemWord w
sz ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
']'

  showList :: [MemChunk w] -> ShowS
showList [] = ShowS
forall a. a -> a
id
  showList (MemChunk w
h : [MemChunk w]
r) = Int -> MemChunk w -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
10 MemChunk w
h ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MemChunk w] -> ShowS
forall a. Show a => [a] -> ShowS
showList [MemChunk w]
r

------------------------------------------------------------------------
-- SegmentContents

-- | This represents the memory contents in a segment.
newtype SegmentContents w = SegmentContents { forall (w :: Natural).
SegmentContents w -> Map (MemWord w) (MemChunk w)
segContentsMap :: Map.Map (MemWord w) (MemChunk w) }

chunkSize :: forall w . MemWidth w => MemChunk w -> Word64
chunkSize :: forall (w :: Natural). MemWidth w => MemChunk w -> Word64
chunkSize (ByteRegion ByteString
bs) = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
bs)
chunkSize (RelocationRegion Relocation w
r) = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Relocation w -> Int
forall (w :: Natural). Relocation w -> Int
relocationSize Relocation w
r)
chunkSize (BSSRegion MemWord w
sz)  = MemWord w -> Word64
forall (w :: Natural). MemWord w -> Word64
memWordValue MemWord w
sz

contentsSize :: MemWidth w => SegmentContents w -> MemWord w
contentsSize :: forall (w :: Natural). MemWidth w => SegmentContents w -> MemWord w
contentsSize (SegmentContents Map (MemWord w) (MemChunk w)
m) =
  case Map (MemWord w) (MemChunk w)
-> Maybe ((MemWord w, MemChunk w), Map (MemWord w) (MemChunk w))
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.maxViewWithKey Map (MemWord w) (MemChunk w)
m of
    Maybe ((MemWord w, MemChunk w), Map (MemWord w) (MemChunk w))
Nothing -> MemWord w
0
    Just ((MemWord w
start, MemChunk w
c),Map (MemWord w) (MemChunk w)
_) -> Word64 -> MemWord w
forall (w :: Natural). MemWidth w => Word64 -> MemWord w
memWord (MemWord w -> Word64
forall (w :: Natural). MemWord w -> Word64
memWordValue MemWord w
start Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ MemChunk w -> Word64
forall (w :: Natural). MemWidth w => MemChunk w -> Word64
chunkSize MemChunk w
c)

-- | Deconstruct a 'SegmentContents' into its constituent ranges
contentsRanges :: SegmentContents w -> [(MemWord w, MemChunk w)]
contentsRanges :: forall (w :: Natural).
SegmentContents w -> [(MemWord w, MemChunk w)]
contentsRanges = Map (MemWord w) (MemChunk w) -> [(MemWord w, MemChunk w)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map (MemWord w) (MemChunk w) -> [(MemWord w, MemChunk w)])
-> (SegmentContents w -> Map (MemWord w) (MemChunk w))
-> SegmentContents w
-> [(MemWord w, MemChunk w)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SegmentContents w -> Map (MemWord w) (MemChunk w)
forall (w :: Natural).
SegmentContents w -> Map (MemWord w) (MemChunk w)
segContentsMap

------------------------------------------------------------------------
-- Presymbol data

-- | Contents of segment/section before symbol folded in.
data PresymbolData = PresymbolData { PresymbolData -> ByteString
preBytes :: !BS.ByteString
                                   , PresymbolData -> Integer
preBSS :: !Integer
                                   }

-- | Return number of presymbol bytes remaining
presymbolBytesLeft :: PresymbolData -> Integer
presymbolBytesLeft :: PresymbolData -> Integer
presymbolBytesLeft PresymbolData
p = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (ByteString -> Int
BS.length (PresymbolData -> ByteString
preBytes PresymbolData
p)) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ PresymbolData -> Integer
preBSS PresymbolData
p

mkPresymbolData :: BS.ByteString -> Integer -> PresymbolData
mkPresymbolData :: ByteString -> Integer -> PresymbolData
mkPresymbolData ByteString
contents0 Integer
sz
  | Integer
sz Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> Integer
forall a. Integral a => a -> Integer
toInteger (ByteString -> Int
BS.length ByteString
contents0) =
      PresymbolData { preBytes :: ByteString
preBytes = Int -> ByteString -> ByteString
BS.take (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
sz) ByteString
contents0
                    , preBSS :: Integer
preBSS = Integer
0
                    }
  | Bool
otherwise =
      PresymbolData { preBytes :: ByteString
preBytes = ByteString
contents0
                    , preBSS :: Integer
preBSS = Integer
sz Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Int -> Integer
forall a. Integral a => a -> Integer
toInteger (ByteString -> Int
BS.length ByteString
contents0)
                    }

-- | @bssSegment cnt@ creates a BSS region with size @cnt@.
bssSegment :: MemWidth w
           => MemWord w
           -> Integer
           -> [(MemWord w, MemChunk w)]
           -> [(MemWord w, MemChunk w)]
bssSegment :: forall (w :: Natural).
MemWidth w =>
MemWord w
-> Integer
-> [(MemWord w, MemChunk w)]
-> [(MemWord w, MemChunk w)]
bssSegment MemWord w
o Integer
c | Integer
c Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0 = [(MemWord w, MemChunk w)] -> [(MemWord w, MemChunk w)]
forall a. a -> a
id
               | Bool
otherwise = ((MemWord w
o, MemWord w -> MemChunk w
forall (w :: Natural). MemWord w -> MemChunk w
BSSRegion (Integer -> MemWord w
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
c)) (MemWord w, MemChunk w)
-> [(MemWord w, MemChunk w)] -> [(MemWord w, MemChunk w)]
forall a. a -> [a] -> [a]
:)

-- | Return all segment ranges from remainder of data.
allSymbolData :: MemWidth w
              => MemWord w -- ^ Number of bytes read so far.
              -> PresymbolData
              -> [(MemWord w, MemChunk w)]
              -> [(MemWord w, MemChunk w)]
allSymbolData :: forall (w :: Natural).
MemWidth w =>
MemWord w
-> PresymbolData
-> [(MemWord w, MemChunk w)]
-> [(MemWord w, MemChunk w)]
allSymbolData MemWord w
off (PresymbolData ByteString
contents Integer
bssSize)
  | ByteString -> Bool
BS.null ByteString
contents = MemWord w
-> Integer
-> [(MemWord w, MemChunk w)]
-> [(MemWord w, MemChunk w)]
forall (w :: Natural).
MemWidth w =>
MemWord w
-> Integer
-> [(MemWord w, MemChunk w)]
-> [(MemWord w, MemChunk w)]
bssSegment MemWord w
off Integer
bssSize
  | Bool
otherwise =
    MemWord w
-> Integer
-> [(MemWord w, MemChunk w)]
-> [(MemWord w, MemChunk w)]
forall (w :: Natural).
MemWidth w =>
MemWord w
-> Integer
-> [(MemWord w, MemChunk w)]
-> [(MemWord w, MemChunk w)]
bssSegment (MemWord w
off MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
+ Int -> MemWord w
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
contents)) Integer
bssSize
      ([(MemWord w, MemChunk w)] -> [(MemWord w, MemChunk w)])
-> ([(MemWord w, MemChunk w)] -> [(MemWord w, MemChunk w)])
-> [(MemWord w, MemChunk w)]
-> [(MemWord w, MemChunk w)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((MemWord w
off,  ByteString -> MemChunk w
forall (w :: Natural). ByteString -> MemChunk w
ByteRegion ByteString
contents) (MemWord w, MemChunk w)
-> [(MemWord w, MemChunk w)] -> [(MemWord w, MemChunk w)]
forall a. a -> [a] -> [a]
:)


-- | Take the difference between given amount of data out of presymbol data.
splitSegment :: MemWidth w
             => MemWord w -- ^ Base address of segment
             -> [(MemWord w, MemChunk w)] -- ^ Symbols added so far.
             -> MemWord w -- ^ Current address
             -> MemWord w -- ^ Target address (can assume at least target addresss
             -> PresymbolData
             -> ([(MemWord w, MemChunk w)], PresymbolData)
splitSegment :: forall (w :: Natural).
MemWidth w =>
MemWord w
-> [(MemWord w, MemChunk w)]
-> MemWord w
-> MemWord w
-> PresymbolData
-> ([(MemWord w, MemChunk w)], PresymbolData)
splitSegment MemWord w
_baseAddr [(MemWord w, MemChunk w)]
pre MemWord w
curAddr MemWord w
targetAddr PresymbolData
dta
  | MemWord w
targetAddr MemWord w -> MemWord w -> Bool
forall a. Ord a => a -> a -> Bool
< MemWord w
curAddr = String -> ([(MemWord w, MemChunk w)], PresymbolData)
forall a. HasCallStack => String -> a
error String
"TargetAddress less that curAddr"
  | MemWord w
targetAddr MemWord w -> MemWord w -> Bool
forall a. Eq a => a -> a -> Bool
== MemWord w
curAddr = ([(MemWord w, MemChunk w)]
pre, PresymbolData
dta)
splitSegment MemWord w
baseAddr [(MemWord w, MemChunk w)]
pre MemWord w
curAddr MemWord w
targetAddr (PresymbolData ByteString
contents Integer
bssSize)
   -- Case where relocation is contained within regular contents
  | MemWord w -> Integer
forall a. Integral a => a -> Integer
toInteger MemWord w
cnt Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Integer
forall a. Integral a => a -> Integer
toInteger (ByteString -> Int
BS.length ByteString
contents) =
    ( (MemWord w
curAddr MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
- MemWord w
baseAddr, ByteString -> MemChunk w
forall (w :: Natural). ByteString -> MemChunk w
ByteRegion (Int -> ByteString -> ByteString
BS.take (MemWord w -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral MemWord w
cnt) ByteString
contents)) (MemWord w, MemChunk w)
-> [(MemWord w, MemChunk w)] -> [(MemWord w, MemChunk w)]
forall a. a -> [a] -> [a]
: [(MemWord w, MemChunk w)]
pre
    , ByteString -> Integer -> PresymbolData
PresymbolData (Int -> ByteString -> ByteString
BS.drop (MemWord w -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral MemWord w
cnt) ByteString
contents) Integer
bssSize
    )
  -- If contents is empty, then we just have BSS.
  | ByteString -> Bool
BS.null ByteString
contents =
      if Integer
bssSize Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< MemWord w -> Integer
forall a. Integral a => a -> Integer
toInteger (MemWord w
targetAddr MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
- MemWord w
curAddr) then
        String -> ([(MemWord w, MemChunk w)], PresymbolData)
forall a. HasCallStack => String -> a
error String
"Out of bytes"
      else
        ( (MemWord w
curAddr MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
- MemWord w
baseAddr, MemWord w -> MemChunk w
forall (w :: Natural). MemWord w -> MemChunk w
BSSRegion MemWord w
cnt) (MemWord w, MemChunk w)
-> [(MemWord w, MemChunk w)] -> [(MemWord w, MemChunk w)]
forall a. a -> [a] -> [a]
: [(MemWord w, MemChunk w)]
pre
        , ByteString -> Integer -> PresymbolData
PresymbolData ByteString
BS.empty (Integer
bssSize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- MemWord w -> Integer
forall a. Integral a => a -> Integer
toInteger MemWord w
cnt)
        )
  -- We take all of file-based data and at least some BSS.
  | Bool
otherwise =
      ( [ ( MemWord w
curAddr MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
- MemWord w
baseAddr MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
+ Int -> MemWord w
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
contents)
          , MemWord w -> MemChunk w
forall (w :: Natural). MemWord w -> MemChunk w
BSSRegion (MemWord w
cnt MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
- Int -> MemWord w
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
contents))
          )
        , (MemWord w
curAddr MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
- MemWord w
baseAddr, ByteString -> MemChunk w
forall (w :: Natural). ByteString -> MemChunk w
ByteRegion ByteString
contents)
        ] [(MemWord w, MemChunk w)]
-> [(MemWord w, MemChunk w)] -> [(MemWord w, MemChunk w)]
forall a. [a] -> [a] -> [a]
++ [(MemWord w, MemChunk w)]
pre
      , ByteString -> Integer -> PresymbolData
PresymbolData ByteString
BS.empty (Integer
bssSize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- (MemWord w -> Integer
forall a. Integral a => a -> Integer
toInteger MemWord w
cnt Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Int -> Integer
forall a. Integral a => a -> Integer
toInteger (ByteString -> Int
BS.length ByteString
contents)))
      )
 where cnt :: MemWord w
cnt = MemWord w
targetAddr MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
- MemWord w
curAddr

-- | @dropSegment cnt dta@ drops @cnt@ bytes from @dta@.
dropSegment :: Int -> PresymbolData -> PresymbolData
dropSegment :: Int -> PresymbolData -> PresymbolData
dropSegment Int
cnt (PresymbolData ByteString
contents Integer
bssSize)
  | Int
cnt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= ByteString -> Int
BS.length ByteString
contents = ByteString -> Integer -> PresymbolData
PresymbolData (Int -> ByteString -> ByteString
BS.drop Int
cnt ByteString
contents) Integer
bssSize
  | Bool
otherwise = ByteString -> Integer -> PresymbolData
PresymbolData ByteString
BS.empty (Integer
bssSize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
contents))

-- | Return the given bytes
takePresymbolBytes :: Int -> PresymbolData -> Maybe BS.ByteString
takePresymbolBytes :: Int -> PresymbolData -> Maybe ByteString
takePresymbolBytes Int
cnt PresymbolData
p
  | Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
cnt  Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= PresymbolData -> Integer
presymbolBytesLeft PresymbolData
p =
      ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
cnt (PresymbolData -> ByteString
preBytes PresymbolData
p)
          ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> Word8 -> ByteString
BS.replicate (Int
cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length (PresymbolData -> ByteString
preBytes PresymbolData
p)) Word8
0
  | Bool
otherwise =
      Maybe ByteString
forall a. Maybe a
Nothing


------------------------------------------------------------------------
-- Relocation processing

-- | Function for resolving the new contents of a relocation entry given an optional
-- index for the current segment and the existing contents.
--
-- The segment index is used for dynamic relocations and set to
-- `Nothing` for static relocations.
type ResolveFn m w = Maybe SegmentIndex -> BS.ByteString -> m (Maybe (Relocation w))

-- | Information about a relocation sufficient to know how many bytes
-- are affected, and how to replaces the existing bytes.
data RelocEntry m w = RelocEntry { forall (m :: Type -> Type) (w :: Natural).
RelocEntry m w -> MemWord w
relocEntrySize :: !(MemWord w)
                                   -- ^ Number of bytes in relocation
                                 , forall (m :: Type -> Type) (w :: Natural).
RelocEntry m w -> ResolveFn m w
applyReloc :: !(ResolveFn m w)
                                 }

-- | This takes a list of symbols and an address and coerces into a memory contents.
--
-- If the size is different from the length of file contents, then the file content
-- buffer is truncated or zero-extended as in a BSS.
applyRelocsToBytes :: (Monad m, MemWidth w)
                   => MemWord w
                      -- ^ Virtual offset of segment.
                   -> Maybe SegmentIndex
                   -- ^ Identifier for this segment in relocation if this is created from so/exe.
                   -> [(MemWord w, MemChunk w)]
                      -- ^ Chunks so far.
                   -> MemWord w
                      -- ^ Current virtual address (must be greater than linkBaseOff)
                   -> [(MemWord w, RelocEntry m w)]
                      -- ^ List of relocations to process in order.
                      -- Each offset should be at offset.
                   -> PresymbolData
                   -- ^ The remaining bytes in memory including
                   -- a number extra bss.
                   -> m (SegmentContents w)
applyRelocsToBytes :: forall (m :: Type -> Type) (w :: Natural).
(Monad m, MemWidth w) =>
MemWord w
-> Maybe SegmentIndex
-> [(MemWord w, MemChunk w)]
-> MemWord w
-> [(MemWord w, RelocEntry m w)]
-> PresymbolData
-> m (SegmentContents w)
applyRelocsToBytes MemWord w
baseAddr Maybe SegmentIndex
msegIdx [(MemWord w, MemChunk w)]
pre MemWord w
ioff ((MemWord w
addr,RelocEntry m w
v):[(MemWord w, RelocEntry m w)]
rest) PresymbolData
buffer
  -- We only consider relocations that are in the range of this segment,
  -- so we require the difference between the address and baseAddr is
  -- less than regionSize
  | MemWord w
addr MemWord w -> MemWord w -> Bool
forall a. Ord a => a -> a -> Bool
< MemWord w
ioff = String -> m (SegmentContents w)
forall a. HasCallStack => String -> a
error String
"Encountered overlapping relocations."
  -- The R_X86_64_COPY is currently only barely supported.  In
  -- particular, it has 0 size (the actual size depends on the size of
  -- the associated symbol), which causes all sorts of issues here (in
  -- particular, we get multiple entries at the same address).
  | RelocEntry m w -> MemWord w
forall (m :: Type -> Type) (w :: Natural).
RelocEntry m w -> MemWord w
relocEntrySize RelocEntry m w
v MemWord w -> MemWord w -> Bool
forall a. Eq a => a -> a -> Bool
== MemWord w
0 = MemWord w
-> Maybe SegmentIndex
-> [(MemWord w, MemChunk w)]
-> MemWord w
-> [(MemWord w, RelocEntry m w)]
-> PresymbolData
-> m (SegmentContents w)
forall (m :: Type -> Type) (w :: Natural).
(Monad m, MemWidth w) =>
MemWord w
-> Maybe SegmentIndex
-> [(MemWord w, MemChunk w)]
-> MemWord w
-> [(MemWord w, RelocEntry m w)]
-> PresymbolData
-> m (SegmentContents w)
applyRelocsToBytes MemWord w
baseAddr Maybe SegmentIndex
msegIdx [(MemWord w, MemChunk w)]
pre MemWord w
ioff [(MemWord w, RelocEntry m w)]
rest PresymbolData
buffer
    -- Check start of relocation is in range.
  | MemWord w -> Integer
forall a. Integral a => a -> Integer
toInteger (MemWord w
addr MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
- MemWord w
ioff) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< PresymbolData -> Integer
presymbolBytesLeft PresymbolData
buffer  = do

      let ([(MemWord w, MemChunk w)]
preRelocChunks, PresymbolData
atRelocContents) = MemWord w
-> [(MemWord w, MemChunk w)]
-> MemWord w
-> MemWord w
-> PresymbolData
-> ([(MemWord w, MemChunk w)], PresymbolData)
forall (w :: Natural).
MemWidth w =>
MemWord w
-> [(MemWord w, MemChunk w)]
-> MemWord w
-> MemWord w
-> PresymbolData
-> ([(MemWord w, MemChunk w)], PresymbolData)
splitSegment MemWord w
baseAddr [(MemWord w, MemChunk w)]
pre MemWord w
ioff MemWord w
addr PresymbolData
buffer
      -- Get relocation size.
      let rsz :: MemWord w
rsz = RelocEntry m w -> MemWord w
forall (m :: Type -> Type) (w :: Natural).
RelocEntry m w -> MemWord w
relocEntrySize RelocEntry m w
v
      case Int -> PresymbolData -> Maybe ByteString
takePresymbolBytes (MemWord w -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral MemWord w
rsz) PresymbolData
atRelocContents of
        Maybe ByteString
Nothing -> do
          String -> m (SegmentContents w)
forall a. HasCallStack => String -> a
error (String -> m (SegmentContents w))
-> String -> m (SegmentContents w)
forall a b. (a -> b) -> a -> b
$ String
"Relocation at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ MemWord w -> String
forall a. Show a => a -> String
show MemWord w
addr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" needs "
                  String -> ShowS
forall a. [a] -> [a] -> [a]
++ MemWord w -> String
forall a. Show a => a -> String
show MemWord w
rsz String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" bytes, but only " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show (PresymbolData -> Integer
presymbolBytesLeft PresymbolData
atRelocContents)
                  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" bytes remaining."
        Just ByteString
bytes -> do
          Maybe (Relocation w)
mr <- RelocEntry m w -> ResolveFn m w
forall (m :: Type -> Type) (w :: Natural).
RelocEntry m w -> ResolveFn m w
applyReloc RelocEntry m w
v Maybe SegmentIndex
msegIdx ByteString
bytes
          case Maybe (Relocation w)
mr of
            Just Relocation w
r -> do
              -- Get number of bytes between this address offset and the current offset."
              let pre' :: [(MemWord w, MemChunk w)]
pre' = (MemWord w
addr MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
- MemWord w
baseAddr,  Relocation w -> MemChunk w
forall (w :: Natural). Relocation w -> MemChunk w
RelocationRegion Relocation w
r)(MemWord w, MemChunk w)
-> [(MemWord w, MemChunk w)] -> [(MemWord w, MemChunk w)]
forall a. a -> [a] -> [a]
: [(MemWord w, MemChunk w)]
preRelocChunks
              let post :: PresymbolData
post = Int -> PresymbolData -> PresymbolData
dropSegment (MemWord w -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral MemWord w
rsz) PresymbolData
atRelocContents
              MemWord w
-> Maybe SegmentIndex
-> [(MemWord w, MemChunk w)]
-> MemWord w
-> [(MemWord w, RelocEntry m w)]
-> PresymbolData
-> m (SegmentContents w)
forall (m :: Type -> Type) (w :: Natural).
(Monad m, MemWidth w) =>
MemWord w
-> Maybe SegmentIndex
-> [(MemWord w, MemChunk w)]
-> MemWord w
-> [(MemWord w, RelocEntry m w)]
-> PresymbolData
-> m (SegmentContents w)
applyRelocsToBytes MemWord w
baseAddr Maybe SegmentIndex
msegIdx [(MemWord w, MemChunk w)]
pre' (MemWord w
addr MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
+ MemWord w
rsz) [(MemWord w, RelocEntry m w)]
rest PresymbolData
post
            Maybe (Relocation w)
Nothing -> do
              -- Skipping relocation
              MemWord w
-> Maybe SegmentIndex
-> [(MemWord w, MemChunk w)]
-> MemWord w
-> [(MemWord w, RelocEntry m w)]
-> PresymbolData
-> m (SegmentContents w)
forall (m :: Type -> Type) (w :: Natural).
(Monad m, MemWidth w) =>
MemWord w
-> Maybe SegmentIndex
-> [(MemWord w, MemChunk w)]
-> MemWord w
-> [(MemWord w, RelocEntry m w)]
-> PresymbolData
-> m (SegmentContents w)
applyRelocsToBytes MemWord w
baseAddr Maybe SegmentIndex
msegIdx [(MemWord w, MemChunk w)]
pre MemWord w
ioff [(MemWord w, RelocEntry m w)]
rest PresymbolData
buffer
applyRelocsToBytes MemWord w
baseAddr Maybe SegmentIndex
_ [(MemWord w, MemChunk w)]
pre MemWord w
ioff [(MemWord w, RelocEntry m w)]
_ PresymbolData
buffer =
  SegmentContents w -> m (SegmentContents w)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (SegmentContents w -> m (SegmentContents w))
-> SegmentContents w -> m (SegmentContents w)
forall a b. (a -> b) -> a -> b
$ Map (MemWord w) (MemChunk w) -> SegmentContents w
forall (w :: Natural).
Map (MemWord w) (MemChunk w) -> SegmentContents w
SegmentContents (Map (MemWord w) (MemChunk w) -> SegmentContents w)
-> Map (MemWord w) (MemChunk w) -> SegmentContents w
forall a b. (a -> b) -> a -> b
$ [(MemWord w, MemChunk w)] -> Map (MemWord w) (MemChunk w)
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromDescList ([(MemWord w, MemChunk w)] -> Map (MemWord w) (MemChunk w))
-> [(MemWord w, MemChunk w)] -> Map (MemWord w) (MemChunk w)
forall a b. (a -> b) -> a -> b
$
    MemWord w
-> PresymbolData
-> [(MemWord w, MemChunk w)]
-> [(MemWord w, MemChunk w)]
forall (w :: Natural).
MemWidth w =>
MemWord w
-> PresymbolData
-> [(MemWord w, MemChunk w)]
-> [(MemWord w, MemChunk w)]
allSymbolData (MemWord w
ioff MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
- MemWord w
baseAddr) PresymbolData
buffer [(MemWord w, MemChunk w)]
pre

------------------------------------------------------------------------
-- MemSegment

-- | An identifier used to support relocatable (i.e., position-independent) code.
--
-- See the module-level documentation for an overview.
--
-- Non-zero region indices represent addresses that would be chosen at runtime
-- by the loader (e.g., the virtual address of an ELF segment containing
-- position-independent code).
--
-- The region index 0 indicates an absolute address:
--
-- * A 'MemAddr' with an 'addrBase' of 0 is an absolute address.
-- * A 'MemSegment' with a 'segmentBase' of 0 has an absolute address in its
--   'segmentOffset'.
type RegionIndex = Int

-- | Information about a contiguous sequence of bytes in memory.
--
-- See the module-level documentation for an overview.
--
-- Our memory model supports relocatable code, and so segments may have either
-- fixed (absolute) or floating addresses. Floating addresses are represented as
-- an offset from an abstract base address ('segmentBase'). When 'segmentBase'
-- is 0, 'segmentOffset' is the absolute address of the segment. Binaries may
-- have floating segments that are fixed relative to each other, and this can be
-- modeled by creating different segments with the same non-zero `segmentBase`
-- identifier.
data MemSegment w
   = MemSegment { forall (w :: Natural). MemSegment w -> Int
segmentBase  :: !RegionIndex
                  -- ^ Base for this segment
                  --
                  -- N.B. 0 indicates a fixed base address of zero.
                , forall (w :: Natural). MemSegment w -> MemWord w
segmentOffset :: !(MemWord w)
                  -- ^ Offset of segment relative to segmentBase
                , forall (w :: Natural). MemSegment w -> Flags
segmentFlags :: !Perm.Flags
                                  -- ^ Permission flags
                , forall (w :: Natural). MemSegment w -> SegmentContents w
segmentContents :: !(SegmentContents w)
                                     -- ^ Map from offsets to the contents of
                                     -- the segment.
                }

instance Eq (MemSegment w) where
  MemSegment w
x == :: MemSegment w -> MemSegment w -> Bool
== MemSegment w
y = MemSegment w -> Int
forall (w :: Natural). MemSegment w -> Int
segmentBase   MemSegment w
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== MemSegment w -> Int
forall (w :: Natural). MemSegment w -> Int
segmentBase MemSegment w
y
        Bool -> Bool -> Bool
&& MemSegment w -> MemWord w
forall (w :: Natural). MemSegment w -> MemWord w
segmentOffset MemSegment w
x MemWord w -> MemWord w -> Bool
forall a. Eq a => a -> a -> Bool
== MemSegment w -> MemWord w
forall (w :: Natural). MemSegment w -> MemWord w
segmentOffset MemSegment w
y

instance Ord (MemSegment w) where
  compare :: MemSegment w -> MemSegment w -> Ordering
compare MemSegment w
x MemSegment w
y
    =  Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (MemSegment w -> Int
forall (w :: Natural). MemSegment w -> Int
segmentBase MemSegment w
x)   (MemSegment w -> Int
forall (w :: Natural). MemSegment w -> Int
segmentBase MemSegment w
y)
    Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> MemWord w -> MemWord w -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (MemSegment w -> MemWord w
forall (w :: Natural). MemSegment w -> MemWord w
segmentOffset MemSegment w
x) (MemSegment w -> MemWord w
forall (w :: Natural). MemSegment w -> MemWord w
segmentOffset MemSegment w
y)

-- | This creates a memory segment from a buffer after applying
-- relocations and options for
memSegment :: forall m w
           .  (Monad m, MemWidth w)
           => Map (MemWord w) (RelocEntry m w)
              -- ^ Map from region offset to relocation entry for segment.
           -> RegionIndex
              -- ^ Index of base (0=absolute address)
           -> Integer
              -- ^ Offset to add to linktime address for this segment.
           -> Maybe SegmentIndex
              -- ^ Identifier for this segment in relocation if this is created from so/exe.
           -> MemWord w
              -- ^ Linktime address of segment.
           -> Perm.Flags
              -- ^ Permissions for segment.
           -> BS.ByteString
           -- ^ File contents for segment.
           -> MemWord w
           -- ^ Expected size (must be positive)
           -> m (MemSegment w)
memSegment :: forall (m :: Type -> Type) (w :: Natural).
(Monad m, MemWidth w) =>
Map (MemWord w) (RelocEntry m w)
-> Int
-> Integer
-> Maybe SegmentIndex
-> MemWord w
-> Flags
-> ByteString
-> MemWord w
-> m (MemSegment w)
memSegment Map (MemWord w) (RelocEntry m w)
relocMap Int
regionIndex Integer
regionOff Maybe SegmentIndex
msegIdx MemWord w
linkBaseOff Flags
flags ByteString
bytes MemWord w
sz
      -- Return nothing if size is not positive
    | MemWord w
sz MemWord w -> MemWord w -> Bool
forall a. Ord a => a -> a -> Bool
<= MemWord w
0 = String -> m (MemSegment w)
forall a. HasCallStack => String -> a
error String
"Memory segments must have a positive size."
      -- Make sure end of segment does not overflow.
    | Integer
regionOff Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ MemWord w -> Integer
forall a. Integral a => a -> Integer
toInteger MemWord w
linkBaseOff Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ MemWord w -> Integer
forall a. Integral a => a -> Integer
toInteger MemWord w
sz Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> MemWord w -> Integer
forall a. Integral a => a -> Integer
toInteger (MemWord w
forall a. Bounded a => a
maxBound :: MemWord w) =
      String -> m (MemSegment w)
forall a. HasCallStack => String -> a
error String
"Contents too large for base."
    | Bool
otherwise = do
      let symbolPairs :: [(MemWord w, RelocEntry m w)]
          symbolPairs :: [(MemWord w, RelocEntry m w)]
symbolPairs
            = Map (MemWord w) (RelocEntry m w) -> [(MemWord w, RelocEntry m w)]
forall k a. Map k a -> [(k, a)]
Map.toList
            (Map (MemWord w) (RelocEntry m w) -> [(MemWord w, RelocEntry m w)])
-> Map (MemWord w) (RelocEntry m w)
-> [(MemWord w, RelocEntry m w)]
forall a b. (a -> b) -> a -> b
$ (MemWord w -> Bool)
-> Map (MemWord w) (RelocEntry m w)
-> Map (MemWord w) (RelocEntry m w)
forall k a. (k -> Bool) -> Map k a -> Map k a
Map.dropWhileAntitone (MemWord w -> MemWord w -> Bool
forall a. Ord a => a -> a -> Bool
< MemWord w
linkBaseOff) Map (MemWord w) (RelocEntry m w)
relocMap

      SegmentContents w
contents <- MemWord w
-> Maybe SegmentIndex
-> [(MemWord w, MemChunk w)]
-> MemWord w
-> [(MemWord w, RelocEntry m w)]
-> PresymbolData
-> m (SegmentContents w)
forall (m :: Type -> Type) (w :: Natural).
(Monad m, MemWidth w) =>
MemWord w
-> Maybe SegmentIndex
-> [(MemWord w, MemChunk w)]
-> MemWord w
-> [(MemWord w, RelocEntry m w)]
-> PresymbolData
-> m (SegmentContents w)
applyRelocsToBytes MemWord w
linkBaseOff Maybe SegmentIndex
msegIdx [] MemWord w
linkBaseOff [(MemWord w, RelocEntry m w)]
symbolPairs
                    (ByteString -> Integer -> PresymbolData
mkPresymbolData ByteString
bytes (MemWord w -> Integer
forall a. Integral a => a -> Integer
toInteger MemWord w
sz))
      let off :: MemWord w
off = Integer -> MemWord w
forall a. Num a => Integer -> a
fromInteger Integer
regionOff MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
+ MemWord w
linkBaseOff
      MemSegment w -> m (MemSegment w)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (MemSegment w -> m (MemSegment w))
-> MemSegment w -> m (MemSegment w)
forall a b. (a -> b) -> a -> b
$! MemSegment { segmentBase :: Int
segmentBase = Int
regionIndex
                         , segmentOffset :: MemWord w
segmentOffset = MemWord w
off
                         , segmentFlags :: Flags
segmentFlags = Flags
flags
                         , segmentContents :: SegmentContents w
segmentContents = SegmentContents w
contents
                         }

-- | Return the size of the segment data.
segmentSize :: MemWidth w => MemSegment w -> MemWord w
segmentSize :: forall (w :: Natural). MemWidth w => MemSegment w -> MemWord w
segmentSize = SegmentContents w -> MemWord w
forall (w :: Natural). MemWidth w => SegmentContents w -> MemWord w
contentsSize (SegmentContents w -> MemWord w)
-> (MemSegment w -> SegmentContents w) -> MemSegment w -> MemWord w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemSegment w -> SegmentContents w
forall (w :: Natural). MemSegment w -> SegmentContents w
segmentContents

-- | Pretty print a memory segment.
ppMemSegment :: MemWidth w => MemSegment w -> Doc ann
ppMemSegment :: forall (w :: Natural) ann. MemWidth w => MemSegment w -> Doc ann
ppMemSegment MemSegment w
s =
  Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat [ Doc ann
"base   =" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (MemSegment w -> Int
forall (w :: Natural). MemSegment w -> Int
segmentBase MemSegment w
s)
               , Doc ann
"offset =" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> MemWord w -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (MemSegment w -> MemWord w
forall (w :: Natural). MemSegment w -> MemWord w
segmentOffset MemSegment w
s)
               , Doc ann
"flags  =" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Flags -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (MemSegment w -> Flags
forall (w :: Natural). MemSegment w -> Flags
segmentFlags MemSegment w
s)
               , Doc ann
"size   =" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> MemWord w -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (MemSegment w -> MemWord w
forall (w :: Natural). MemWidth w => MemSegment w -> MemWord w
segmentSize MemSegment w
s)
               ]

instance MemWidth w => Show (MemSegment w) where
  show :: MemSegment w -> String
show = Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String)
-> (MemSegment w -> Doc Any) -> MemSegment w -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemSegment w -> Doc Any
forall (w :: Natural) ann. MemWidth w => MemSegment w -> Doc ann
ppMemSegment

------------------------------------------------------------------------
-- MemSegmentOff

-- | A pair containing a segment and offset.
--
-- Functions that return a segment-offset pair enforce that the offset
-- is strictly less than the size of the memory segment in bytes.
data MemSegmentOff w = MemSegmentOff { forall (w :: Natural). MemSegmentOff w -> MemSegment w
segoffSegment :: !(MemSegment w)
                                       -- ^ The segment this is an offset of
                                     , forall (w :: Natural). MemSegmentOff w -> MemWord w
segoffOffset :: !(MemWord w)
                                       -- ^ The offset within the segment.
                                     }
  deriving (MemSegmentOff w -> MemSegmentOff w -> Bool
(MemSegmentOff w -> MemSegmentOff w -> Bool)
-> (MemSegmentOff w -> MemSegmentOff w -> Bool)
-> Eq (MemSegmentOff w)
forall (w :: Natural). MemSegmentOff w -> MemSegmentOff w -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall (w :: Natural). MemSegmentOff w -> MemSegmentOff w -> Bool
== :: MemSegmentOff w -> MemSegmentOff w -> Bool
$c/= :: forall (w :: Natural). MemSegmentOff w -> MemSegmentOff w -> Bool
/= :: MemSegmentOff w -> MemSegmentOff w -> Bool
Eq, Eq (MemSegmentOff w)
Eq (MemSegmentOff w) =>
(MemSegmentOff w -> MemSegmentOff w -> Ordering)
-> (MemSegmentOff w -> MemSegmentOff w -> Bool)
-> (MemSegmentOff w -> MemSegmentOff w -> Bool)
-> (MemSegmentOff w -> MemSegmentOff w -> Bool)
-> (MemSegmentOff w -> MemSegmentOff w -> Bool)
-> (MemSegmentOff w -> MemSegmentOff w -> MemSegmentOff w)
-> (MemSegmentOff w -> MemSegmentOff w -> MemSegmentOff w)
-> Ord (MemSegmentOff w)
MemSegmentOff w -> MemSegmentOff w -> Bool
MemSegmentOff w -> MemSegmentOff w -> Ordering
MemSegmentOff w -> MemSegmentOff w -> MemSegmentOff w
forall (w :: Natural). Eq (MemSegmentOff w)
forall (w :: Natural). MemSegmentOff w -> MemSegmentOff w -> Bool
forall (w :: Natural).
MemSegmentOff w -> MemSegmentOff w -> Ordering
forall (w :: Natural).
MemSegmentOff w -> MemSegmentOff w -> MemSegmentOff w
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: forall (w :: Natural).
MemSegmentOff w -> MemSegmentOff w -> Ordering
compare :: MemSegmentOff w -> MemSegmentOff w -> Ordering
$c< :: forall (w :: Natural). MemSegmentOff w -> MemSegmentOff w -> Bool
< :: MemSegmentOff w -> MemSegmentOff w -> Bool
$c<= :: forall (w :: Natural). MemSegmentOff w -> MemSegmentOff w -> Bool
<= :: MemSegmentOff w -> MemSegmentOff w -> Bool
$c> :: forall (w :: Natural). MemSegmentOff w -> MemSegmentOff w -> Bool
> :: MemSegmentOff w -> MemSegmentOff w -> Bool
$c>= :: forall (w :: Natural). MemSegmentOff w -> MemSegmentOff w -> Bool
>= :: MemSegmentOff w -> MemSegmentOff w -> Bool
$cmax :: forall (w :: Natural).
MemSegmentOff w -> MemSegmentOff w -> MemSegmentOff w
max :: MemSegmentOff w -> MemSegmentOff w -> MemSegmentOff w
$cmin :: forall (w :: Natural).
MemSegmentOff w -> MemSegmentOff w -> MemSegmentOff w
min :: MemSegmentOff w -> MemSegmentOff w -> MemSegmentOff w
Ord)

------------------------------------------------------------------------
-- Memory

-- | Map from region index to map of offset to segment.
--
-- See the module-level documentation.
type SegmentOffsetMap w = Map.Map RegionIndex (Map.Map (MemWord w) (MemSegment w))

-- | A datatype for describing the memory layout of binaries.
--
-- See the module-level documentation for an overview.
--
-- Region indices ('RegionIndex') may not correspond precisely with segments
-- or section indices ('SectionIndex', 'SegmentIndex') within the binary,
-- and so we also maintain mappings so that one can map both sections and
-- segments in the binary to the address it is loaded at ('memSectionIndexMap',
-- 'memSegmentIndexMap').
data Memory w = Memory { forall (w :: Natural). Memory w -> AddrWidthRepr w
memAddrWidth :: !(AddrWidthRepr w)
                         -- ^ Address width of the memory
                       , forall (w :: Natural). Memory w -> SegmentOffsetMap w
memSegmentMap :: !(SegmentOffsetMap w)
                         -- ^ Segment map
                       , forall (w :: Natural).
Memory w -> Map SegmentIndex (MemSegmentOff w)
memSectionIndexMap :: !(Map SectionIndex (MemSegmentOff w))
                         -- ^ Map from registered section indices to the segment offset it is loaded at.
                       , forall (w :: Natural). Memory w -> Map SegmentIndex (MemSegment w)
memSegmentIndexMap  :: !(Map SegmentIndex (MemSegment w))
                         -- ^ Map from registered segment indices to associated segment.
                       , forall (w :: Natural). Memory w -> Maybe (MemAddr w)
memBaseAddr :: !(Maybe (MemAddr w))
                         -- ^ This denotes the base region for loads.
                       }

-- | Return the set of memory segments in memory.
memSegments :: Memory w -> [MemSegment w]
memSegments :: forall (w :: Natural). Memory w -> [MemSegment w]
memSegments Memory w
m = (Map (MemWord w) (MemSegment w) -> [MemSegment w])
-> [Map (MemWord w) (MemSegment w)] -> [MemSegment w]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap Map (MemWord w) (MemSegment w) -> [MemSegment w]
forall k a. Map k a -> [a]
Map.elems (Map Int (Map (MemWord w) (MemSegment w))
-> [Map (MemWord w) (MemSegment w)]
forall k a. Map k a -> [a]
Map.elems (Memory w -> Map Int (Map (MemWord w) (MemSegment w))
forall (w :: Natural). Memory w -> SegmentOffsetMap w
memSegmentMap Memory w
m))

instance MemWidth w => Show (Memory w) where
  show :: Memory w -> String
show = Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> (Memory w -> Doc Any) -> Memory w -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc Any] -> Doc Any
forall ann. [Doc ann] -> Doc ann
list ([Doc Any] -> Doc Any)
-> (Memory w -> [Doc Any]) -> Memory w -> Doc Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemSegment w -> Doc Any) -> [MemSegment w] -> [Doc Any]
forall a b. (a -> b) -> [a] -> [b]
map MemSegment w -> Doc Any
forall (w :: Natural) ann. MemWidth w => MemSegment w -> Doc ann
ppMemSegment ([MemSegment w] -> [Doc Any])
-> (Memory w -> [MemSegment w]) -> Memory w -> [Doc Any]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Memory w -> [MemSegment w]
forall (w :: Natural). Memory w -> [MemSegment w]
memSegments

-- | Return the number of bytes in an address.
memWidth :: Memory w -> NatRepr w
memWidth :: forall (w :: Natural). Memory w -> NatRepr w
memWidth = AddrWidthRepr w -> NatRepr w
forall (w :: Natural). AddrWidthRepr w -> NatRepr w
addrWidthNatRepr (AddrWidthRepr w -> NatRepr w)
-> (Memory w -> AddrWidthRepr w) -> Memory w -> NatRepr w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Memory w -> AddrWidthRepr w
forall (w :: Natural). Memory w -> AddrWidthRepr w
memAddrWidth

-- | Add a new section index to address entry.
memBindSectionIndex :: SectionIndex -> MemSegmentOff w -> Memory w -> Memory w
memBindSectionIndex :: forall (w :: Natural).
SegmentIndex -> MemSegmentOff w -> Memory w -> Memory w
memBindSectionIndex SegmentIndex
idx MemSegmentOff w
addr Memory w
mem
  | SegmentIndex -> Map SegmentIndex (MemSegmentOff w) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member SegmentIndex
idx (Memory w -> Map SegmentIndex (MemSegmentOff w)
forall (w :: Natural).
Memory w -> Map SegmentIndex (MemSegmentOff w)
memSectionIndexMap Memory w
mem) =
      String -> Memory w
forall a. HasCallStack => String -> a
error (String -> Memory w) -> String -> Memory w
forall a b. (a -> b) -> a -> b
$ String
"memBindSectionIndex: duplicate index " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SegmentIndex -> String
forall a. Show a => a -> String
show SegmentIndex
idx
  | Bool
otherwise =
      Memory w
mem { memSectionIndexMap = Map.insert idx addr (memSectionIndexMap mem) }

-- | Record binding from the segment index to the segment.
memBindSegmentIndex :: SegmentIndex -> MemSegment w -> Memory w -> Memory w
memBindSegmentIndex :: forall (w :: Natural).
SegmentIndex -> MemSegment w -> Memory w -> Memory w
memBindSegmentIndex SegmentIndex
idx MemSegment w
seg Memory w
mem
  | SegmentIndex -> Map SegmentIndex (MemSegment w) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member SegmentIndex
idx (Memory w -> Map SegmentIndex (MemSegment w)
forall (w :: Natural). Memory w -> Map SegmentIndex (MemSegment w)
memSegmentIndexMap Memory w
mem) =
      String -> Memory w
forall a. HasCallStack => String -> a
error (String -> Memory w) -> String -> Memory w
forall a b. (a -> b) -> a -> b
$ String
"memBindSegmentIndex: duplicate index " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SegmentIndex -> String
forall a. Show a => a -> String
show SegmentIndex
idx
  | Bool
otherwise =
      Memory w
mem { memSegmentIndexMap = Map.insert idx seg (memSegmentIndexMap mem) }

-- | Set the region index used or the load addresses.
memSetBaseAddr :: MemAddr w -> Memory w -> Memory w
memSetBaseAddr :: forall (w :: Natural). MemAddr w -> Memory w -> Memory w
memSetBaseAddr MemAddr w
r Memory w
m = Memory w
m { memBaseAddr = Just r }

-- | A memory with no segments.
emptyMemory :: AddrWidthRepr w -> Memory w
emptyMemory :: forall (w :: Natural). AddrWidthRepr w -> Memory w
emptyMemory AddrWidthRepr w
w = Memory { memAddrWidth :: AddrWidthRepr w
memAddrWidth       = AddrWidthRepr w
w
                       , memSegmentMap :: SegmentOffsetMap w
memSegmentMap      = SegmentOffsetMap w
forall k a. Map k a
Map.empty
                       , memSectionIndexMap :: Map SegmentIndex (MemSegmentOff w)
memSectionIndexMap = Map SegmentIndex (MemSegmentOff w)
forall k a. Map k a
Map.empty
                       , memSegmentIndexMap :: Map SegmentIndex (MemSegment w)
memSegmentIndexMap = Map SegmentIndex (MemSegment w)
forall k a. Map k a
Map.empty
                       , memBaseAddr :: Maybe (MemAddr w)
memBaseAddr        = Maybe (MemAddr w)
forall a. Maybe a
Nothing
                       }

-- | Return segments with executable permissions.
executableSegments :: Memory w -> [MemSegment w]
executableSegments :: forall (w :: Natural). Memory w -> [MemSegment w]
executableSegments = (MemSegment w -> Bool) -> [MemSegment w] -> [MemSegment w]
forall a. (a -> Bool) -> [a] -> [a]
filter (Flags -> Bool
Perm.isExecutable (Flags -> Bool) -> (MemSegment w -> Flags) -> MemSegment w -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemSegment w -> Flags
forall (w :: Natural). MemSegment w -> Flags
segmentFlags) ([MemSegment w] -> [MemSegment w])
-> (Memory w -> [MemSegment w]) -> Memory w -> [MemSegment w]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Memory w -> [MemSegment w]
forall (w :: Natural). Memory w -> [MemSegment w]
memSegments
{-# DEPRECATED executableSegments "Use filter (Perm.isExecutable . segmentFlags) . memSegments." #-}

-- | Return segments with read-only permissions.
readonlySegments :: Memory w -> [MemSegment w]
readonlySegments :: forall (w :: Natural). Memory w -> [MemSegment w]
readonlySegments = (MemSegment w -> Bool) -> [MemSegment w] -> [MemSegment w]
forall a. (a -> Bool) -> [a] -> [a]
filter (Flags -> Bool
Perm.isReadonly (Flags -> Bool) -> (MemSegment w -> Flags) -> MemSegment w -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemSegment w -> Flags
forall (w :: Natural). MemSegment w -> Flags
segmentFlags) ([MemSegment w] -> [MemSegment w])
-> (Memory w -> [MemSegment w]) -> Memory w -> [MemSegment w]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Memory w -> [MemSegment w]
forall (w :: Natural). Memory w -> [MemSegment w]
memSegments
{-# DEPRECATED readonlySegments "Filter memSegments directly." #-}

-- | Describes why we could not insert segment into memory.
data InsertError w
   = OverlapSegment (MemSegment w) (MemSegment w)
     -- ^ The inserted segment overlaps with the given segment.

-- | Print description of insertion error.
showInsertError :: InsertError w -> String
showInsertError :: forall (w :: Natural). InsertError w -> String
showInsertError (OverlapSegment MemSegment w
_base MemSegment w
_seg) = String
"overlaps with memory segment."

-- | Insert segment into memory or fail if this overlaps with another
-- segment in memory.
insertMemSegment :: MemSegment w
                 -> Memory w
                 -> Either (InsertError w) (Memory w)
insertMemSegment :: forall (w :: Natural).
MemSegment w -> Memory w -> Either (InsertError w) (Memory w)
insertMemSegment MemSegment w
seg Memory w
mem = AddrWidthRepr w
-> (MemWidth w => Either (InsertError w) (Memory w))
-> Either (InsertError w) (Memory 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 => Either (InsertError w) (Memory w))
 -> Either (InsertError w) (Memory w))
-> (MemWidth w => Either (InsertError w) (Memory w))
-> Either (InsertError w) (Memory w)
forall a b. (a -> b) -> a -> b
$ do
  let segOffMap :: SegmentOffsetMap w
segOffMap = Memory w -> SegmentOffsetMap w
forall (w :: Natural). Memory w -> SegmentOffsetMap w
memSegmentMap Memory w
mem
  let base :: Int
base = MemSegment w -> Int
forall (w :: Natural). MemSegment w -> Int
segmentBase MemSegment w
seg
      m :: Map (MemWord w) (MemSegment w)
m = Map (MemWord w) (MemSegment w)
-> Int -> SegmentOffsetMap w -> Map (MemWord w) (MemSegment w)
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map (MemWord w) (MemSegment w)
forall k a. Map k a
Map.empty Int
base SegmentOffsetMap w
segOffMap
  case MemWord w
-> Map (MemWord w) (MemSegment w)
-> Maybe (MemWord w, MemSegment w)
forall k v. Ord k => k -> Map k v -> Maybe (k, v)
Map.lookupGE (MemSegment w -> MemWord w
forall (w :: Natural). MemSegment w -> MemWord w
segmentOffset MemSegment w
seg) Map (MemWord w) (MemSegment w)
m of
    Just (MemWord w
next,MemSegment w
old) | MemWord w
next MemWord w -> MemWord w -> Bool
forall a. Ord a => a -> a -> Bool
< MemSegment w -> MemWord w
forall (w :: Natural). MemSegment w -> MemWord w
segmentOffset MemSegment w
seg MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
+ MemSegment w -> MemWord w
forall (w :: Natural). MemWidth w => MemSegment w -> MemWord w
segmentSize MemSegment w
seg ->
     InsertError w -> Either (InsertError w) (Memory w)
forall a b. a -> Either a b
Left (InsertError w -> Either (InsertError w) (Memory w))
-> InsertError w -> Either (InsertError w) (Memory w)
forall a b. (a -> b) -> a -> b
$ MemSegment w -> MemSegment w -> InsertError w
forall (w :: Natural).
MemSegment w -> MemSegment w -> InsertError w
OverlapSegment MemSegment w
seg MemSegment w
old
    Maybe (MemWord w, MemSegment w)
_ -> do
      let absMap :: SegmentOffsetMap w
absMap = Int
-> Map (MemWord w) (MemSegment w)
-> SegmentOffsetMap w
-> SegmentOffsetMap w
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
base (MemWord w
-> MemSegment w
-> Map (MemWord w) (MemSegment w)
-> Map (MemWord w) (MemSegment w)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (MemSegment w -> MemWord w
forall (w :: Natural). MemSegment w -> MemWord w
segmentOffset MemSegment w
seg) MemSegment w
seg Map (MemWord w) (MemSegment w)
m) SegmentOffsetMap w
segOffMap
      Memory w -> Either (InsertError w) (Memory w)
forall a. a -> Either (InsertError w) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Memory w -> Either (InsertError w) (Memory w))
-> Memory w -> Either (InsertError w) (Memory w)
forall a b. (a -> b) -> a -> b
$ Memory w
mem { memSegmentMap = absMap }

------------------------------------------------------------------------
-- MemAddr

-- | An address in memory, represented by a base ('RegionIndex') and an offset.
--
-- See the module-level documentation for an overview.
--
-- 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
   = MemAddr { forall (w :: Natural). MemAddr w -> Int
addrBase :: {-# UNPACK #-} !RegionIndex
             , forall (w :: Natural). MemAddr w -> MemWord w
addrOffset :: {-# UNPACK #-} !(MemWord w)
             }
  deriving (MemAddr w -> MemAddr w -> Bool
(MemAddr w -> MemAddr w -> Bool)
-> (MemAddr w -> MemAddr w -> Bool) -> Eq (MemAddr w)
forall (w :: Natural). MemAddr w -> MemAddr w -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall (w :: Natural). MemAddr w -> MemAddr w -> Bool
== :: MemAddr w -> MemAddr w -> Bool
$c/= :: forall (w :: Natural). MemAddr w -> MemAddr w -> Bool
/= :: MemAddr w -> MemAddr w -> Bool
Eq, Eq (MemAddr w)
Eq (MemAddr w) =>
(MemAddr w -> MemAddr w -> Ordering)
-> (MemAddr w -> MemAddr w -> Bool)
-> (MemAddr w -> MemAddr w -> Bool)
-> (MemAddr w -> MemAddr w -> Bool)
-> (MemAddr w -> MemAddr w -> Bool)
-> (MemAddr w -> MemAddr w -> MemAddr w)
-> (MemAddr w -> MemAddr w -> MemAddr w)
-> Ord (MemAddr w)
MemAddr w -> MemAddr w -> Bool
MemAddr w -> MemAddr w -> Ordering
MemAddr w -> MemAddr w -> MemAddr w
forall (w :: Natural). Eq (MemAddr w)
forall (w :: Natural). MemAddr w -> MemAddr w -> Bool
forall (w :: Natural). MemAddr w -> MemAddr w -> Ordering
forall (w :: Natural). MemAddr w -> MemAddr w -> MemAddr w
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: forall (w :: Natural). MemAddr w -> MemAddr w -> Ordering
compare :: MemAddr w -> MemAddr w -> Ordering
$c< :: forall (w :: Natural). MemAddr w -> MemAddr w -> Bool
< :: MemAddr w -> MemAddr w -> Bool
$c<= :: forall (w :: Natural). MemAddr w -> MemAddr w -> Bool
<= :: MemAddr w -> MemAddr w -> Bool
$c> :: forall (w :: Natural). MemAddr w -> MemAddr w -> Bool
> :: MemAddr w -> MemAddr w -> Bool
$c>= :: forall (w :: Natural). MemAddr w -> MemAddr w -> Bool
>= :: MemAddr w -> MemAddr w -> Bool
$cmax :: forall (w :: Natural). MemAddr w -> MemAddr w -> MemAddr w
max :: MemAddr w -> MemAddr w -> MemAddr w
$cmin :: forall (w :: Natural). MemAddr w -> MemAddr w -> MemAddr w
min :: MemAddr w -> MemAddr w -> MemAddr w
Ord)

instance Hashable (MemAddr w) where
  hashWithSalt :: Int -> MemAddr w -> Int
hashWithSalt Int
s MemAddr w
a = Int
s Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` MemAddr w -> Int
forall (w :: Natural). MemAddr w -> Int
addrBase MemAddr w
a  Int -> MemWord w -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` MemAddr w -> MemWord w
forall (w :: Natural). MemAddr w -> MemWord w
addrOffset MemAddr w
a

instance Show (MemAddr w) where
  showsPrec :: Int -> MemAddr w -> ShowS
showsPrec Int
_ (MemAddr Int
0 MemWord w
a) = MemWord w -> ShowS
forall a. Show a => a -> ShowS
shows MemWord w
a
  showsPrec Int
p (MemAddr Int
i MemWord w
off) =
    Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
6)
    (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"segment"
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
i
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"+"
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemWord w -> ShowS
forall a. Show a => a -> ShowS
shows MemWord w
off

instance Pretty (MemAddr w) where
  pretty :: forall ann. MemAddr w -> Doc ann
pretty = MemAddr w -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow

-- | Treat a machine word as an absolute address (with a 'addrBase' of 0).
absoluteAddr :: MemWord w -> MemAddr w
absoluteAddr :: forall (w :: Natural). MemWord w -> MemAddr w
absoluteAddr MemWord w
o = MemAddr { addrBase :: Int
addrBase = Int
0, addrOffset :: MemWord w
addrOffset = MemWord w
o }

-- | Construct an address from an offset from a memory segment.
segmentOffAddr :: MemWidth w => MemSegment w -> MemWord w -> MemAddr w
segmentOffAddr :: forall (w :: Natural).
MemWidth w =>
MemSegment w -> MemWord w -> MemAddr w
segmentOffAddr MemSegment w
seg MemWord w
off = MemAddr { addrBase :: Int
addrBase = MemSegment w -> Int
forall (w :: Natural). MemSegment w -> Int
segmentBase MemSegment w
seg, addrOffset :: MemWord w
addrOffset = MemSegment w -> MemWord w
forall (w :: Natural). MemSegment w -> MemWord w
segmentOffset MemSegment w
seg MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
+ MemWord w
off }

-- | Construct an address relative to an existing memory segment.
relativeAddr :: MemWidth w => MemSegment w -> MemWord w -> MemAddr w
relativeAddr :: forall (w :: Natural).
MemWidth w =>
MemSegment w -> MemWord w -> MemAddr w
relativeAddr = MemSegment w -> MemWord w -> MemAddr w
forall (w :: Natural).
MemWidth w =>
MemSegment w -> MemWord w -> MemAddr w
segmentOffAddr
{-# DEPRECATED relativeAddr "Use segmentOffAddr" #-}

-- | Return an absolute address if the region of the 'MemAddr' is 0.
asAbsoluteAddr :: MemWidth w => MemAddr w -> Maybe (MemWord w)
asAbsoluteAddr :: forall (w :: Natural). MemWidth w => MemAddr w -> Maybe (MemWord w)
asAbsoluteAddr (MemAddr Int
i MemWord w
w) = if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then MemWord w -> Maybe (MemWord w)
forall a. a -> Maybe a
Just MemWord w
w else Maybe (MemWord w)
forall a. Maybe a
Nothing

-- | Clear the least significant bit of an address.
clearAddrLeastBit :: MemAddr w -> MemAddr w
clearAddrLeastBit :: forall (w :: Natural). MemAddr w -> MemAddr w
clearAddrLeastBit (MemAddr Int
i (MemWord Word64
off)) = Int -> MemWord w -> MemAddr w
forall (w :: Natural). Int -> MemWord w -> MemAddr w
MemAddr Int
i (Word64 -> MemWord w
forall (w :: Natural). Word64 -> MemWord w
MemWord (Word64
off Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64 -> Word64
forall a. Bits a => a -> a
complement Word64
1))

-- | Return True if least-significant bit in addr is set.
addrLeastBit :: MemAddr w -> Bool
addrLeastBit :: forall (w :: Natural). MemAddr w -> Bool
addrLeastBit (MemAddr Int
_ (MemWord Word64
off)) = Word64
off Word64 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
0

-- | Increment an address by a fixed amount.
incAddr :: MemWidth w => Integer -> MemAddr w -> MemAddr w
incAddr :: forall (w :: Natural).
MemWidth w =>
Integer -> MemAddr w -> MemAddr w
incAddr Integer
o MemAddr w
a = MemAddr w
a { addrOffset = addrOffset a + fromInteger o }

-- | Returns the number of bytes between two addresses if they point to
-- the same region and `Nothing` if they are different segments.
diffAddr :: MemWidth w => MemAddr w -> MemAddr w -> Maybe Integer
diffAddr :: forall (w :: Natural).
MemWidth w =>
MemAddr w -> MemAddr w -> Maybe Integer
diffAddr (MemAddr Int
xb MemWord w
xoff) (MemAddr Int
yb MemWord w
yoff)
  | Int
xb Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
yb = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ MemWord w -> Integer
forall a. Integral a => a -> Integer
toInteger MemWord w
xoff Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- MemWord w -> Integer
forall a. Integral a => a -> Integer
toInteger MemWord w
yoff
  | Bool
otherwise = Maybe Integer
forall a. Maybe a
Nothing

------------------------------------------------------------------------
-- MemSegmentOff operations

-- | Return the number of bytes in the segment after this address.
segoffBytesLeft :: MemWidth w => MemSegmentOff w -> Integer
segoffBytesLeft :: forall (w :: Natural). MemWidth w => MemSegmentOff w -> Integer
segoffBytesLeft MemSegmentOff w
segOff = Integer
sz Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
off
  where sz :: Integer
sz = MemWord w -> Integer
forall a. Integral a => a -> Integer
toInteger (MemSegment w -> MemWord w
forall (w :: Natural). MemWidth w => MemSegment w -> MemWord w
segmentSize (MemSegmentOff w -> MemSegment w
forall (w :: Natural). MemSegmentOff w -> MemSegment w
segoffSegment MemSegmentOff w
segOff))
        off :: Integer
off = MemWord w -> Integer
forall a. Integral a => a -> Integer
toInteger (MemSegmentOff w -> MemWord w
forall (w :: Natural). MemSegmentOff w -> MemWord w
segoffOffset MemSegmentOff w
segOff)

-- | Make a segment offset pair after ensuring the offset is valid
resolveSegmentOff :: MemWidth w => MemSegment w -> MemWord w -> Maybe (MemSegmentOff w)
resolveSegmentOff :: forall (w :: Natural).
MemWidth w =>
MemSegment w -> MemWord w -> Maybe (MemSegmentOff w)
resolveSegmentOff MemSegment w
seg MemWord w
off
  | MemWord w
off MemWord w -> MemWord w -> Bool
forall a. Ord a => a -> a -> Bool
< MemSegment w -> MemWord w
forall (w :: Natural). MemWidth w => MemSegment w -> MemWord w
segmentSize MemSegment w
seg = MemSegmentOff w -> Maybe (MemSegmentOff w)
forall a. a -> Maybe a
Just MemSegmentOff { segoffSegment :: MemSegment w
segoffSegment = MemSegment w
seg, segoffOffset :: MemWord w
segoffOffset = MemWord w
off }
  | Bool
otherwise = Maybe (MemSegmentOff w)
forall a. Maybe a
Nothing

-- | Return the segment offset associated with the given region offset if any.
resolveRegionOff :: Memory w -> RegionIndex -> MemWord w -> Maybe (MemSegmentOff w)
resolveRegionOff :: forall (w :: Natural).
Memory w -> Int -> MemWord w -> Maybe (MemSegmentOff w)
resolveRegionOff Memory w
mem Int
idx MemWord w
addr = AddrWidthRepr w
-> (MemWidth w => Maybe (MemSegmentOff w))
-> Maybe (MemSegmentOff 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 (MemSegmentOff w))
 -> Maybe (MemSegmentOff w))
-> (MemWidth w => Maybe (MemSegmentOff w))
-> Maybe (MemSegmentOff w)
forall a b. (a -> b) -> a -> b
$ do
  Map (MemWord w) (MemSegment w)
m <- Int
-> Map Int (Map (MemWord w) (MemSegment w))
-> Maybe (Map (MemWord w) (MemSegment w))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
idx (Memory w -> Map Int (Map (MemWord w) (MemSegment w))
forall (w :: Natural). Memory w -> SegmentOffsetMap w
memSegmentMap Memory w
mem)
  (MemWord w
base, MemSegment w
seg) <- MemWord w
-> Map (MemWord w) (MemSegment w)
-> Maybe (MemWord w, MemSegment w)
forall k v. Ord k => k -> Map k v -> Maybe (k, v)
Map.lookupLE MemWord w
addr Map (MemWord w) (MemSegment w)
m
  MemSegment w -> MemWord w -> Maybe (MemSegmentOff w)
forall (w :: Natural).
MemWidth w =>
MemSegment w -> MemWord w -> Maybe (MemSegmentOff w)
resolveSegmentOff MemSegment w
seg (MemWord w
addr MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
- MemWord w
base)

-- | Return the segment offset associated with the given region offset if any.
resolveAddr :: Memory w -> RegionIndex -> MemWord w -> Maybe (MemSegmentOff w)
resolveAddr :: forall (w :: Natural).
Memory w -> Int -> MemWord w -> Maybe (MemSegmentOff w)
resolveAddr = Memory w -> Int -> MemWord w -> Maybe (MemSegmentOff w)
forall (w :: Natural).
Memory w -> Int -> MemWord w -> Maybe (MemSegmentOff w)
resolveRegionOff
{-# DEPRECATED resolveAddr "Use resolveRegionOff" #-}

-- | Return the address of a segment offset.
segoffAddr :: MemSegmentOff w -> MemAddr w
segoffAddr :: forall (w :: Natural). MemSegmentOff w -> MemAddr w
segoffAddr (MemSegmentOff MemSegment w
seg MemWord w
off) =
  MemAddr { addrBase :: Int
addrBase = MemSegment w -> Int
forall (w :: Natural). MemSegment w -> Int
segmentBase MemSegment w
seg
          , addrOffset :: MemWord w
addrOffset = Word64 -> MemWord w
forall (w :: Natural). Word64 -> MemWord w
MemWord (Word64 -> MemWord w) -> Word64 -> MemWord w
forall a b. (a -> b) -> a -> b
$ MemWord w -> Word64
forall (w :: Natural). MemWord w -> Word64
memWordValue (MemSegment w -> MemWord w
forall (w :: Natural). MemSegment w -> MemWord w
segmentOffset MemSegment w
seg) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ MemWord w -> Word64
forall (w :: Natural). MemWord w -> Word64
memWordValue MemWord w
off
          }

-- | Return the segment associated with the given address if well-defined.
resolveAbsoluteAddr :: Memory w -> MemWord w -> Maybe (MemSegmentOff w)
resolveAbsoluteAddr :: forall (w :: Natural).
Memory w -> MemWord w -> Maybe (MemSegmentOff w)
resolveAbsoluteAddr Memory w
mem MemWord w
addr = Memory w -> Int -> MemWord w -> Maybe (MemSegmentOff w)
forall (w :: Natural).
Memory w -> Int -> MemWord w -> Maybe (MemSegmentOff w)
resolveRegionOff Memory w
mem Int
0 MemWord w
addr

-- | Return the absolute address associated with the segment offset pair (if any)
segoffAsAbsoluteAddr :: MemWidth w => MemSegmentOff w -> Maybe (MemWord w)
segoffAsAbsoluteAddr :: forall (w :: Natural).
MemWidth w =>
MemSegmentOff w -> Maybe (MemWord w)
segoffAsAbsoluteAddr MemSegmentOff w
mseg = do
  let seg :: MemSegment w
seg = MemSegmentOff w -> MemSegment w
forall (w :: Natural). MemSegmentOff w -> MemSegment w
segoffSegment MemSegmentOff w
mseg
   in if MemSegment w -> Int
forall (w :: Natural). MemSegment w -> Int
segmentBase MemSegment w
seg Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then
        -- We do not need to normalize, because the overflow was checked when the segment offset
        -- was created.
        MemWord w -> Maybe (MemWord w)
forall a. a -> Maybe a
Just (MemWord w -> Maybe (MemWord w)) -> MemWord w -> Maybe (MemWord w)
forall a b. (a -> b) -> a -> b
$! Word64 -> MemWord w
forall (w :: Natural). Word64 -> MemWord w
MemWord (MemWord w -> Word64
forall (w :: Natural). MemWord w -> Word64
memWordValue (MemSegment w -> MemWord w
forall (w :: Natural). MemSegment w -> MemWord w
segmentOffset MemSegment w
seg) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ MemWord w -> Word64
forall (w :: Natural). MemWord w -> Word64
memWordValue (MemSegmentOff w -> MemWord w
forall (w :: Natural). MemSegmentOff w -> MemWord w
segoffOffset MemSegmentOff w
mseg))
       else
        Maybe (MemWord w)
forall a. Maybe a
Nothing

-- | Return the absolute address associated with the segment offset pair (if any)
msegAddr :: MemWidth w => MemSegmentOff w -> Maybe (MemWord w)
msegAddr :: forall (w :: Natural).
MemWidth w =>
MemSegmentOff w -> Maybe (MemWord w)
msegAddr = MemSegmentOff w -> Maybe (MemWord w)
forall (w :: Natural).
MemWidth w =>
MemSegmentOff w -> Maybe (MemWord w)
segoffAsAbsoluteAddr
{-# DEPRECATED msegAddr "Use segoffAsAbsoluteAddr" #-}

-- | Clear the least-significant bit of an segment offset.
clearSegmentOffLeastBit :: MemWidth w => MemSegmentOff w -> MemSegmentOff w
clearSegmentOffLeastBit :: forall (w :: Natural).
MemWidth w =>
MemSegmentOff w -> MemSegmentOff w
clearSegmentOffLeastBit (MemSegmentOff MemSegment w
seg MemWord w
off) = MemSegment w -> MemWord w -> MemSegmentOff w
forall (w :: Natural). MemSegment w -> MemWord w -> MemSegmentOff w
MemSegmentOff MemSegment w
seg (MemWord w
off MemWord w -> MemWord w -> MemWord w
forall a. Bits a => a -> a -> a
.&. MemWord w -> MemWord w
forall a. Bits a => a -> a
complement MemWord w
1)

-- | 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 :: forall (w :: Natural).
MemWidth w =>
MemSegmentOff w -> Integer -> Maybe (MemSegmentOff w)
incSegmentOff (MemSegmentOff MemSegment w
seg MemWord w
off) Integer
inc
  | Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
next Bool -> Bool -> Bool
&& Integer
next Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= MemWord w -> Integer
forall a. Integral a => a -> Integer
toInteger (MemSegment w -> MemWord w
forall (w :: Natural). MemWidth w => MemSegment w -> MemWord w
segmentSize MemSegment w
seg) =
      MemSegmentOff w -> Maybe (MemSegmentOff w)
forall a. a -> Maybe a
Just (MemSegmentOff w -> Maybe (MemSegmentOff w))
-> MemSegmentOff w -> Maybe (MemSegmentOff w)
forall a b. (a -> b) -> a -> b
$ MemSegment w -> MemWord w -> MemSegmentOff w
forall (w :: Natural). MemSegment w -> MemWord w -> MemSegmentOff w
MemSegmentOff MemSegment w
seg (Integer -> MemWord w
forall a. Num a => Integer -> a
fromInteger Integer
next)
  | Bool
otherwise = Maybe (MemSegmentOff w)
forall a. Maybe a
Nothing
  where next :: Integer
next = MemWord w -> Integer
forall a. Integral a => a -> Integer
toInteger MemWord w
off Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
inc

-- | Return the difference between two segment offsets pairs or `Nothing` if undefined.
diffSegmentOff :: MemWidth w => MemSegmentOff w -> MemSegmentOff w -> Maybe Integer
diffSegmentOff :: forall (w :: Natural).
MemWidth w =>
MemSegmentOff w -> MemSegmentOff w -> Maybe Integer
diffSegmentOff (MemSegmentOff MemSegment w
xseg MemWord w
xoff) (MemSegmentOff MemSegment w
yseg MemWord w
yoff)
  | MemSegment w -> Int
forall (w :: Natural). MemSegment w -> Int
segmentBase MemSegment w
xseg Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== MemSegment w -> Int
forall (w :: Natural). MemSegment w -> Int
segmentBase MemSegment w
yseg =
    Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ MemWord w -> Integer
forall a. Integral a => a -> Integer
toInteger (MemSegment w -> MemWord w
forall (w :: Natural). MemSegment w -> MemWord w
segmentOffset MemSegment w
xseg MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
+ MemWord w
xoff) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- MemWord w -> Integer
forall a. Integral a => a -> Integer
toInteger (MemSegment w -> MemWord w
forall (w :: Natural). MemSegment w -> MemWord w
segmentOffset MemSegment w
yseg MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
+ MemWord w
yoff)
  | Bool
otherwise = Maybe Integer
forall a. Maybe a
Nothing

instance MemWidth w => Show (MemSegmentOff w) where
  showsPrec :: Int -> MemSegmentOff w -> ShowS
showsPrec Int
p (MemSegmentOff MemSegment w
seg MemWord w
off) =
    if MemSegment w -> Int
forall (w :: Natural). MemSegment w -> Int
segmentBase MemSegment w
seg Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then
      String -> ShowS
showString String
"0x" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemWord w -> ShowS
forall a. Integral a => a -> ShowS
showHex (MemSegment w -> MemWord w
forall (w :: Natural). MemSegment w -> MemWord w
segmentOffset MemSegment w
seg MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
+ MemWord w
off)
     else
       Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
6)
        (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"segment"
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows (MemSegment w -> Int
forall (w :: Natural). MemSegment w -> Int
segmentBase MemSegment w
seg)
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"+"
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemWord w -> ShowS
forall a. Show a => a -> ShowS
shows (MemSegment w -> MemWord w
forall (w :: Natural). MemSegment w -> MemWord w
segmentOffset MemSegment w
seg MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
+ MemWord w
off)

instance MemWidth w => Pretty (MemSegmentOff w) where
  pretty :: forall ann. MemSegmentOff w -> Doc ann
pretty = MemSegmentOff w -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow

-- | This walks through all the memory regions and looks at each
-- address size block of memory that is aligned at a multiple of the
-- address size.
--
-- It returns a list of all offset and value pairs that can be
-- interpreted as a valid offset within a memory segment.
memAsAddrPairs :: Memory w
               -> Endianness
               -> [(MemSegmentOff w, MemSegmentOff w)]
memAsAddrPairs :: forall (w :: Natural).
Memory w -> Endianness -> [(MemSegmentOff w, MemSegmentOff w)]
memAsAddrPairs Memory w
mem Endianness
end = AddrWidthRepr w
-> (MemWidth w => [(MemSegmentOff w, MemSegmentOff w)])
-> [(MemSegmentOff w, MemSegmentOff 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 => [(MemSegmentOff w, MemSegmentOff w)])
 -> [(MemSegmentOff w, MemSegmentOff w)])
-> (MemWidth w => [(MemSegmentOff w, MemSegmentOff w)])
-> [(MemSegmentOff w, MemSegmentOff w)]
forall a b. (a -> b) -> a -> b
$ do
  MemSegment w
seg <- Memory w -> [MemSegment w]
forall (w :: Natural). Memory w -> [MemSegment w]
memSegments Memory w
mem
  (MemWord w
contentsOffset,MemChunk w
r) <- SegmentContents w -> [(MemWord w, MemChunk w)]
forall (w :: Natural).
SegmentContents w -> [(MemWord w, MemChunk w)]
contentsRanges (MemSegment w -> SegmentContents w
forall (w :: Natural). MemSegment w -> SegmentContents w
segmentContents MemSegment w
seg)
  let sz :: Int
      sz :: Int
sz = Memory w -> Int
forall (w :: Natural) (p :: Natural -> Type).
MemWidth w =>
p w -> Int
forall (p :: Natural -> Type). p w -> Int
addrSize Memory w
mem
  case MemChunk w
r of
    ByteRegion ByteString
bs -> do
      -- Split bytes into sequence of pairs with offset and value.
      (MemWord w
byteOff,ByteString
w) <-
        [MemWord w] -> [ByteString] -> [(MemWord w, ByteString)]
forall a b. [a] -> [b] -> [(a, b)]
zip [MemWord w
contentsOffset,MemWord w
contentsOffsetMemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
+Int -> MemWord w
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz..]
            (Int -> ByteString -> [ByteString]
regularChunks Int
sz ByteString
bs)
      -- Attempt to read bytes as a valid segment offset.
      let val :: MemWord w
val = case Endianness -> ByteString -> Maybe (MemWord w)
forall (w :: Natural).
MemWidth w =>
Endianness -> ByteString -> Maybe (MemWord w)
addrRead Endianness
end ByteString
w of
                  Just MemWord w
val' -> MemWord w
val'
                  Maybe (MemWord w)
Nothing -> String -> MemWord w
forall a. HasCallStack => String -> a
error String
"memAsAddrPairs internal error: regularChunks result too short."
      case Memory w -> MemWord w -> Maybe (MemSegmentOff w)
forall (w :: Natural).
Memory w -> MemWord w -> Maybe (MemSegmentOff w)
resolveAbsoluteAddr Memory w
mem MemWord w
val of
        Just MemSegmentOff w
segOffVal ->
          [(MemSegment w -> MemWord w -> MemSegmentOff w
forall (w :: Natural). MemSegment w -> MemWord w -> MemSegmentOff w
MemSegmentOff MemSegment w
seg MemWord w
byteOff, MemSegmentOff w
segOffVal)]
        Maybe (MemSegmentOff w)
Nothing ->
          []
    RelocationRegion{} -> []
    BSSRegion{} -> []

------------------------------------------------------------------------
-- SegmentOff deprecated

-- | Return segment this is offset of.
msegSegment :: MemSegmentOff w -> MemSegment w
msegSegment :: forall (w :: Natural). MemSegmentOff w -> MemSegment w
msegSegment = MemSegmentOff w -> MemSegment w
forall (w :: Natural). MemSegmentOff w -> MemSegment w
segoffSegment
{-# DEPRECATED msegSegment "Use segoffSegment" #-}

-- | Return offset of segment
msegOffset :: MemSegmentOff w -> MemWord w
msegOffset :: forall (w :: Natural). MemSegmentOff w -> MemWord w
msegOffset = MemSegmentOff w -> MemWord w
forall (w :: Natural). MemSegmentOff w -> MemWord w
segoffOffset
{-# DEPRECATED msegOffset "Use segoffOffset" #-}

-- | Return the number of bytes in the segment after this address.
msegByteCountAfter :: MemWidth w => MemSegmentOff w -> Integer
msegByteCountAfter :: forall (w :: Natural). MemWidth w => MemSegmentOff w -> Integer
msegByteCountAfter = MemSegmentOff w -> Integer
forall (w :: Natural). MemWidth w => MemSegmentOff w -> Integer
segoffBytesLeft
{-# DEPRECATED msegByteCountAfter "Use segoffBytesLeft" #-}

-- | Convert the segment offset to an address.
relativeSegmentAddr :: MemWidth w => MemSegmentOff w -> MemAddr w
relativeSegmentAddr :: forall (w :: Natural). MemWidth w => MemSegmentOff w -> MemAddr w
relativeSegmentAddr = MemSegmentOff w -> MemAddr w
forall (w :: Natural). MemSegmentOff w -> MemAddr w
segoffAddr
{-# DEPRECATED relativeSegmentAddr "Use segoffAddr" #-}

-- | Return a segment offset from the address if defined.
asSegmentOff :: Memory w -> MemAddr w -> Maybe (MemSegmentOff w)
asSegmentOff :: forall (w :: Natural).
Memory w -> MemAddr w -> Maybe (MemSegmentOff w)
asSegmentOff Memory w
mem (MemAddr Int
i MemWord w
addr) = Memory w -> Int -> MemWord w -> Maybe (MemSegmentOff w)
forall (w :: Natural).
Memory w -> Int -> MemWord w -> Maybe (MemSegmentOff w)
resolveAddr Memory w
mem Int
i MemWord w
addr

------------------------------------------------------------------------
-- MemoryError

-- | Type of errors that may occur when reading memory.
data MemoryError w
   = AccessViolation !(MemAddr w)
     -- ^ Memory could not be read, because it was not defined.
   | PermissionsError !(MemAddr w)
     -- ^ Memory could not be read due to insufficient permissions.
   | UnexpectedRelocation !(MemAddr w) !(Relocation w)
     -- ^ Read from location that partially overlaps a relocated entry
   | UnexpectedByteRelocation !(MemAddr w) !(Relocation w)
     -- ^ An relocation appeared when reading a byte.
   | Unsupported32ImmRelocation !(MemAddr w) !(Relocation w)
     -- ^ An unsupported relocation appeared when reading a 32-bit immediate.
   | UnsupportedJumpOffsetRelocation !(MemAddr w) !(Relocation w)
     -- ^ An unsupported relocation appeared when reading a jump offset.
   | UnexpectedBSS !(MemAddr w)
     -- ^ We unexpectedly encountered a BSS segment/section.
   | InvalidAddr !(MemAddr w)
     -- ^ The data at the given address did not refer to a valid memory location.
   | InvalidRead !(MemSegmentOff w) !Word64
     -- ^ Can't read the given number of bytes from the offset as that is outside
     -- allocated memory.

instance MemWidth w => Show (MemoryError w) where
  show :: MemoryError w -> String
show MemoryError w
err =
    case MemoryError w
err of
      AccessViolation MemAddr w
a ->
        String
"Access violation at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ MemAddr w -> String
forall a. Show a => a -> String
show MemAddr w
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
      PermissionsError MemAddr w
a ->
        String
"Insufficient permissions at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ MemAddr w -> String
forall a. Show a => a -> String
show MemAddr w
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
      UnexpectedRelocation MemAddr w
a Relocation w
r ->
        String
"Attempt to read an unexpected relocation entry at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ MemAddr w -> String
forall a. Show a => a -> String
show MemAddr w
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":\n"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Relocation w -> String
forall a. Show a => a -> String
show Relocation w
r
      UnexpectedByteRelocation MemAddr w
a Relocation w
r ->
        String
"Attempt to read a relocation as a byte at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ MemAddr w -> String
forall a. Show a => a -> String
show MemAddr w
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":\n"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Relocation w -> String
forall a. Show a => a -> String
show Relocation w
r
      Unsupported32ImmRelocation MemAddr w
a Relocation w
r ->
        String
"Attempt to read an unsupported relocation as a 32-bit immediate at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ MemAddr w -> String
forall a. Show a => a -> String
show MemAddr w
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":\n"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Relocation w -> String
forall a. Show a => a -> String
show Relocation w
r
      UnsupportedJumpOffsetRelocation MemAddr w
a Relocation w
r ->
        String
"Attempt to read an unsupported relocation as a jump offset at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ MemAddr w -> String
forall a. Show a => a -> String
show MemAddr w
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":\n"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Relocation w -> String
forall a. Show a => a -> String
show Relocation w
r
      UnexpectedBSS MemAddr w
a ->
        String
"Attempt to read zero initialized BSS memory at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ MemAddr w -> String
forall a. Show a => a -> String
show MemAddr w
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
      InvalidAddr MemAddr w
a ->
        String
"Attempt to interpret an invalid address: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ MemAddr w -> String
forall a. Show a => a -> String
show MemAddr w
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
      InvalidRead MemSegmentOff w
a Word64
c ->
        String
"Read " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show Word64
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" bytes if after defined memory " String -> ShowS
forall a. [a] -> [a] -> [a]
++ MemSegmentOff w -> String
forall a. Show a => a -> String
show MemSegmentOff w
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."

------------------------------------------------------------------------
-- Reading contents

-- | Return the memory contents from a given offset, that is, the 'MemChunk' at
-- the given offset, then the following 'MemChunk's until the end of the
-- segment.  Returns a 'MemoryError' if the requested offset falls within a
-- relocation, which we cannot partition.
segoffContentsAfter :: MemWidth w
                    => MemSegmentOff w
                    -> Either (MemoryError w) [MemChunk w]
segoffContentsAfter :: forall (w :: Natural).
MemWidth w =>
MemSegmentOff w -> Either (MemoryError w) [MemChunk w]
segoffContentsAfter MemSegmentOff w
mseg = do
  -- Get offset within segment to get
  let off :: MemWord w
off = MemSegmentOff w -> MemWord w
forall (w :: Natural). MemSegmentOff w -> MemWord w
segoffOffset MemSegmentOff w
mseg
  -- Get complete contents of segment
  let contents :: SegmentContents w
contents = MemSegment w -> SegmentContents w
forall (w :: Natural). MemSegment w -> SegmentContents w
segmentContents (MemSegmentOff w -> MemSegment w
forall (w :: Natural). MemSegmentOff w -> MemSegment w
segoffSegment MemSegmentOff w
mseg)
  -- Split the map into all segments starting strictly before offset,
  -- memory starting at offset (if any), and contents strictly after offset.
  let (Map (MemWord w) (MemChunk w)
premap,Maybe (MemChunk w)
mv,Map (MemWord w) (MemChunk w)
post) = MemWord w
-> Map (MemWord w) (MemChunk w)
-> (Map (MemWord w) (MemChunk w), Maybe (MemChunk w),
    Map (MemWord w) (MemChunk w))
forall k a. Ord k => k -> Map k a -> (Map k a, Maybe a, Map k a)
Map.splitLookup MemWord w
off (SegmentContents w -> Map (MemWord w) (MemChunk w)
forall (w :: Natural).
SegmentContents w -> Map (MemWord w) (MemChunk w)
segContentsMap SegmentContents w
contents)
  case Maybe (MemChunk w)
mv of
    -- If something starts at offset, then return it and everything after.
    Just MemChunk w
v -> [MemChunk w] -> Either (MemoryError w) [MemChunk w]
forall a b. b -> Either a b
Right ([MemChunk w] -> Either (MemoryError w) [MemChunk w])
-> [MemChunk w] -> Either (MemoryError w) [MemChunk w]
forall a b. (a -> b) -> a -> b
$ MemChunk w
v MemChunk w -> [MemChunk w] -> [MemChunk w]
forall a. a -> [a] -> [a]
: Map (MemWord w) (MemChunk w) -> [MemChunk w]
forall k a. Map k a -> [a]
Map.elems Map (MemWord w) (MemChunk w)
post
    -- If no memory starts exactly at offset, then
    -- look at the last segment starting before offset.
    Maybe (MemChunk w)
Nothing ->
      case Map (MemWord w) (MemChunk w)
-> Maybe ((MemWord w, MemChunk w), Map (MemWord w) (MemChunk w))
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.maxViewWithKey Map (MemWord w) (MemChunk w)
premap of
        -- This implies nothing starts before the segment offset, which should not be
        -- allowed
        Maybe ((MemWord w, MemChunk w), Map (MemWord w) (MemChunk w))
Nothing -> String -> Either (MemoryError w) [MemChunk w]
forall a. HasCallStack => String -> a
error String
"Memory.segoffContentsAfter invalid contents"
        -- If last segment is a byte region then we drop elements before offset.
        Just ((MemWord w
preOff, ByteRegion ByteString
bs),Map (MemWord w) (MemChunk w)
_) -> do
          let v :: MemChunk w
v = ByteString -> MemChunk w
forall (w :: Natural). ByteString -> MemChunk w
ByteRegion (Int -> ByteString -> ByteString
BS.drop (MemWord w -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (MemWord w
off MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
- MemWord w
preOff)) ByteString
bs)
          [MemChunk w] -> Either (MemoryError w) [MemChunk w]
forall a b. b -> Either a b
Right ([MemChunk w] -> Either (MemoryError w) [MemChunk w])
-> [MemChunk w] -> Either (MemoryError w) [MemChunk w]
forall a b. (a -> b) -> a -> b
$ MemChunk w
v MemChunk w -> [MemChunk w] -> [MemChunk w]
forall a. a -> [a] -> [a]
: Map (MemWord w) (MemChunk w) -> [MemChunk w]
forall k a. Map k a -> [a]
Map.elems Map (MemWord w) (MemChunk w)
post
        -- If last segment is a BSS region, then we drop elements before offset.
        Just ((MemWord w
preOff, BSSRegion MemWord w
sz),Map (MemWord w) (MemChunk w)
_) -> do
          let v :: MemChunk w
v = MemWord w -> MemChunk w
forall (w :: Natural). MemWord w -> MemChunk w
BSSRegion (MemWord w
sz MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
- MemWord w -> MemWord w
forall a b. (Integral a, Num b) => a -> b
fromIntegral (MemWord w
off MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
- MemWord w
preOff))
          [MemChunk w] -> Either (MemoryError w) [MemChunk w]
forall a b. b -> Either a b
Right ([MemChunk w] -> Either (MemoryError w) [MemChunk w])
-> [MemChunk w] -> Either (MemoryError w) [MemChunk w]
forall a b. (a -> b) -> a -> b
$ MemChunk w
v MemChunk w -> [MemChunk w] -> [MemChunk w]
forall a. a -> [a] -> [a]
: Map (MemWord w) (MemChunk w) -> [MemChunk w]
forall k a. Map k a -> [a]
Map.elems Map (MemWord w) (MemChunk w)
post
        -- If last segment is a symbolic reference, then the code is asking
        -- us to partition a symbolic reference in two, which we cannot do.
        Just ((MemWord w
_, RelocationRegion Relocation w
r),Map (MemWord w) (MemChunk w)
_) ->
          MemoryError w -> Either (MemoryError w) [MemChunk w]
forall a b. a -> Either a b
Left (MemoryError w -> Either (MemoryError w) [MemChunk w])
-> MemoryError w -> Either (MemoryError w) [MemChunk w]
forall a b. (a -> b) -> a -> b
$ MemAddr w -> Relocation w -> MemoryError w
forall (w :: Natural). MemAddr w -> Relocation w -> MemoryError w
UnexpectedRelocation (MemSegmentOff w -> MemAddr w
forall (w :: Natural). MemWidth w => MemSegmentOff w -> MemAddr w
relativeSegmentAddr MemSegmentOff w
mseg) Relocation w
r

contentsAfterSegmentOff :: MemWidth w
                        => MemSegmentOff w
                        -> Either (MemoryError w) [MemChunk w]
contentsAfterSegmentOff :: forall (w :: Natural).
MemWidth w =>
MemSegmentOff w -> Either (MemoryError w) [MemChunk w]
contentsAfterSegmentOff = MemSegmentOff w -> Either (MemoryError w) [MemChunk w]
forall (w :: Natural).
MemWidth w =>
MemSegmentOff w -> Either (MemoryError w) [MemChunk w]
segoffContentsAfter
{-# DEPRECATED contentsAfterSegmentOff "Use segoffContentsAfter" #-}

------------------------------------------------------------------------
-- Split segment range list.

-- | @forcedTakeMemChunks ranges cnt@ attempts to read @cnt@ bytes from
-- @ranges@.
--
-- It is a total function, and will return @ranges@ if it contains
-- less than @cnt@ bytes.  It may also return more than @cnt@ bytes as
-- if a relocation region spans across the break, it will return the
-- region.
forcedTakeMemChunks :: forall w
                  .  MemWidth w => [MemChunk w] -> MemWord w -> [MemChunk w]
forcedTakeMemChunks :: forall (w :: Natural).
MemWidth w =>
[MemChunk w] -> MemWord w -> [MemChunk w]
forcedTakeMemChunks [MemChunk w]
_ MemWord w
0 = []
forcedTakeMemChunks [MemChunk w]
rngs MemWord w
c = do
  let rest :: [MemChunk w] -> MemWord w -> [MemChunk w]
      rest :: [MemChunk w] -> MemWord w -> [MemChunk w]
rest [MemChunk w]
l MemWord w
d | MemWord w
c MemWord w -> MemWord w -> Bool
forall a. Ord a => a -> a -> Bool
> MemWord w
d = [MemChunk w] -> MemWord w -> [MemChunk w]
forall (w :: Natural).
MemWidth w =>
[MemChunk w] -> MemWord w -> [MemChunk w]
forcedTakeMemChunks [MemChunk w]
l (MemWord w
c MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
- MemWord w
d)
               | Bool
otherwise = []
  case [MemChunk w]
rngs of
    [] -> []
    ByteRegion ByteString
b : [MemChunk w]
l ->
      ByteString -> MemChunk w
forall (w :: Natural). ByteString -> MemChunk w
ByteRegion (Int -> ByteString -> ByteString
BS.take (MemWord w -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral MemWord w
c) ByteString
b)
      MemChunk w -> [MemChunk w] -> [MemChunk w]
forall a. a -> [a] -> [a]
: [MemChunk w] -> MemWord w -> [MemChunk w]
rest [MemChunk w]
l (Int -> MemWord w
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
b))
    RelocationRegion Relocation w
r : [MemChunk w]
l ->
      Relocation w -> MemChunk w
forall (w :: Natural). Relocation w -> MemChunk w
RelocationRegion Relocation w
r
      MemChunk w -> [MemChunk w] -> [MemChunk w]
forall a. a -> [a] -> [a]
: [MemChunk w] -> MemWord w -> [MemChunk w]
rest [MemChunk w]
l (Int -> MemWord w
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Relocation w -> Int
forall (w :: Natural). Relocation w -> Int
relocationSize Relocation w
r))
    BSSRegion MemWord w
d : [MemChunk w]
l ->
      MemWord w -> MemChunk w
forall (w :: Natural). MemWord w -> MemChunk w
BSSRegion (MemWord w -> MemWord w -> MemWord w
forall a. Ord a => a -> a -> a
min MemWord w
d MemWord w
c)
      MemChunk w -> [MemChunk w] -> [MemChunk w]
forall a. a -> [a] -> [a]
: [MemChunk w] -> MemWord w -> [MemChunk w]
rest [MemChunk w]
l MemWord w
d

takeSegmentPrefix :: forall w
                  .  MemWidth w => [MemChunk w] -> MemWord w -> [MemChunk w]
takeSegmentPrefix :: forall (w :: Natural).
MemWidth w =>
[MemChunk w] -> MemWord w -> [MemChunk w]
takeSegmentPrefix = [MemChunk w] -> MemWord w -> [MemChunk w]
forall (w :: Natural).
MemWidth w =>
[MemChunk w] -> MemWord w -> [MemChunk w]
forcedTakeMemChunks
{-# DEPRECATED takeSegmentPrefix "Use forcedTakeMemChunks" #-}


-- | Describes why we could not split the memory chunks.
data SplitError w
   = SplitUnexpectedRelocation !(Relocation w)
     -- ^ A relocation was right in the middle of where we tried to split chunks.
   | SplitInvalidAddr
     -- ^ The byte count to split at was longer than the number of chunks.

-- | Convert `SplitError` to equivalent `MemoryError`.
--
-- Note. External code does not use this, so unless we get feedback
-- otherwise, it will be dropped in a future Macaw release.
dropErrorAsMemError :: MemAddr w -> SplitError w -> MemoryError w
dropErrorAsMemError :: forall (w :: Natural). MemAddr w -> SplitError w -> MemoryError w
dropErrorAsMemError MemAddr w
a (SplitUnexpectedRelocation Relocation w
r) = MemAddr w -> Relocation w -> MemoryError w
forall (w :: Natural). MemAddr w -> Relocation w -> MemoryError w
UnexpectedRelocation MemAddr w
a Relocation w
r
dropErrorAsMemError MemAddr w
a SplitError w
SplitInvalidAddr = MemAddr w -> MemoryError w
forall (w :: Natural). MemAddr w -> MemoryError w
InvalidAddr MemAddr w
a

{-# DEPRECATED dropErrorAsMemError "dropErrorAsMemError is not being used by the rest of Macaw, and a candidate for deletion." #-}

splitMemChunks' :: MemWidth w
                       => [MemChunk w]
                       -> Int
                       -> [MemChunk w]
                       -> Either (SplitError w) ([MemChunk w], [MemChunk w])
splitMemChunks' :: forall (w :: Natural).
MemWidth w =>
[MemChunk w]
-> Int
-> [MemChunk w]
-> Either (SplitError w) ([MemChunk w], [MemChunk w])
splitMemChunks' [MemChunk w]
prev Int
c [MemChunk w]
next
  | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = ([MemChunk w], [MemChunk w])
-> Either (SplitError w) ([MemChunk w], [MemChunk w])
forall a b. b -> Either a b
Right ([MemChunk w] -> [MemChunk w]
forall a. [a] -> [a]
reverse [MemChunk w]
prev, [MemChunk w]
next)
splitMemChunks' [MemChunk w]
_ Int
_ [] = SplitError w -> Either (SplitError w) ([MemChunk w], [MemChunk w])
forall a b. a -> Either a b
Left SplitError w
forall (w :: Natural). SplitError w
SplitInvalidAddr
splitMemChunks' [MemChunk w]
prev Int
cnt (reg :: MemChunk w
reg@(ByteRegion ByteString
bs) : [MemChunk w]
rest) = do
  let sz :: Int
sz = ByteString -> Int
BS.length ByteString
bs
  if Int
cnt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
sz then do
    let taken :: [MemChunk w]
taken   = ByteString -> MemChunk w
forall (w :: Natural). ByteString -> MemChunk w
ByteRegion (Int -> ByteString -> ByteString
BS.take Int
cnt ByteString
bs)MemChunk w -> [MemChunk w] -> [MemChunk w]
forall a. a -> [a] -> [a]
:[MemChunk w]
prev
    let dropped :: [MemChunk w]
dropped = ByteString -> MemChunk w
forall (w :: Natural). ByteString -> MemChunk w
ByteRegion (Int -> ByteString -> ByteString
BS.drop Int
cnt ByteString
bs) MemChunk w -> [MemChunk w] -> [MemChunk w]
forall a. a -> [a] -> [a]
: [MemChunk w]
rest
    ([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]
taken, [MemChunk w]
dropped)
   else do
    [MemChunk w]
-> Int
-> [MemChunk w]
-> Either (SplitError w) ([MemChunk w], [MemChunk w])
forall (w :: Natural).
MemWidth w =>
[MemChunk w]
-> Int
-> [MemChunk w]
-> Either (SplitError w) ([MemChunk w], [MemChunk w])
splitMemChunks' (MemChunk w
regMemChunk w -> [MemChunk w] -> [MemChunk w]
forall a. a -> [a] -> [a]
:[MemChunk w]
prev) (Int
cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sz) [MemChunk w]
rest
splitMemChunks' [MemChunk w]
prev Int
cnt (reg :: MemChunk w
reg@(RelocationRegion Relocation w
r):[MemChunk w]
rest) = do
  let sz :: Int
sz = Relocation w -> Int
forall (w :: Natural). Relocation w -> Int
relocationSize Relocation w
r
  if Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
cnt Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
sz then
    SplitError w -> Either (SplitError w) ([MemChunk w], [MemChunk w])
forall a b. a -> Either a b
Left (Relocation w -> SplitError w
forall (w :: Natural). Relocation w -> SplitError w
SplitUnexpectedRelocation Relocation w
r)
   else do
    [MemChunk w]
-> Int
-> [MemChunk w]
-> Either (SplitError w) ([MemChunk w], [MemChunk w])
forall (w :: Natural).
MemWidth w =>
[MemChunk w]
-> Int
-> [MemChunk w]
-> Either (SplitError w) ([MemChunk w], [MemChunk w])
splitMemChunks' (MemChunk w
regMemChunk w -> [MemChunk w] -> [MemChunk w]
forall a. a -> [a] -> [a]
:[MemChunk w]
prev) (Int
cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz) [MemChunk w]
rest
splitMemChunks' [MemChunk w]
prev Int
cnt (reg :: MemChunk w
reg@(BSSRegion MemWord w
sz): [MemChunk w]
rest) =
  if Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
cnt Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< MemWord w -> Integer
forall a. Integral a => a -> Integer
toInteger MemWord w
sz then do
    let taken :: [MemChunk w]
taken   = MemWord w -> MemChunk w
forall (w :: Natural). MemWord w -> MemChunk w
BSSRegion (Int -> MemWord w
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
cnt)MemChunk w -> [MemChunk w] -> [MemChunk w]
forall a. a -> [a] -> [a]
:[MemChunk w]
prev
    let dropped :: [MemChunk w]
dropped = MemWord w -> MemChunk w
forall (w :: Natural). MemWord w -> MemChunk w
BSSRegion (MemWord w
sz MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
- Int -> MemWord w
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
cnt) MemChunk w -> [MemChunk w] -> [MemChunk w]
forall a. a -> [a] -> [a]
: [MemChunk w]
rest
    ([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]
taken, [MemChunk w]
dropped)
   else
    [MemChunk w]
-> Int
-> [MemChunk w]
-> Either (SplitError w) ([MemChunk w], [MemChunk w])
forall (w :: Natural).
MemWidth w =>
[MemChunk w]
-> Int
-> [MemChunk w]
-> Either (SplitError w) ([MemChunk w], [MemChunk w])
splitMemChunks' (MemChunk w
regMemChunk w -> [MemChunk w] -> [MemChunk w]
forall a. a -> [a] -> [a]
:[MemChunk w]
prev) (Int
cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
- MemWord w -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral MemWord w
sz) [MemChunk w]
rest

-- | Given a contiguous sequence of memory chunks and a number of
-- bytes `c`, this partitions the data in two data regions.  The first
-- contains the first `c` bytes in the data; the second contains the
-- rest of the data.
--
-- This will return an error if the size of the data is too small
-- or the partition would split a relocation entry.
splitMemChunks :: MemWidth w
               => [MemChunk w]
               -> Int
               -> Either (SplitError w) ([MemChunk w], [MemChunk w])
splitMemChunks :: forall (w :: Natural).
MemWidth w =>
[MemChunk w]
-> Int -> Either (SplitError w) ([MemChunk w], [MemChunk w])
splitMemChunks [MemChunk w]
l Int
c = [MemChunk w]
-> Int
-> [MemChunk w]
-> Either (SplitError w) ([MemChunk w], [MemChunk w])
forall (w :: Natural).
MemWidth w =>
[MemChunk w]
-> Int
-> [MemChunk w]
-> Either (SplitError w) ([MemChunk w], [MemChunk w])
splitMemChunks' [] Int
c [MemChunk w]
l

-- | Given a segment data and a number of bytes `c`, this partitions the data in
-- two data regions.  The first contains the first `c` bytes in the data; the second
-- contains the rest of the data.
--
-- This will return an exception if the size of the data is too small or the partition
-- would split a relocation entry.
splitSegmentRangeList :: MemWidth w
                      => [MemChunk w]
                      -> Int
                      -> Either (SplitError w) ([MemChunk w], [MemChunk w])
splitSegmentRangeList :: forall (w :: Natural).
MemWidth w =>
[MemChunk w]
-> Int -> Either (SplitError w) ([MemChunk w], [MemChunk w])
splitSegmentRangeList = [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
{-# DEPRECATED splitSegmentRangeList "Use splitMemChunks" #-}


-- | Given a contiguous list of segment ranges and a number of bytes to drop, this
-- returns the remaining segment ranges or throws an error.
dropSegmentRangeListBytes :: forall w
                          .  MemWidth w
                          => [MemChunk w]
                          -> Int
                          -> Either (SplitError w) [MemChunk w]
dropSegmentRangeListBytes :: forall (w :: Natural).
MemWidth w =>
[MemChunk w] -> Int -> Either (SplitError w) [MemChunk w]
dropSegmentRangeListBytes [MemChunk w]
l Int
c = ([MemChunk w], [MemChunk w]) -> [MemChunk w]
forall a b. (a, b) -> b
snd (([MemChunk w], [MemChunk w]) -> [MemChunk w])
-> Either (SplitError w) ([MemChunk w], [MemChunk w])
-> Either (SplitError w) [MemChunk w]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [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]
l Int
c
{-# DEPRECATED dropSegmentRangeListBytes "Use splitMemChunks" #-}

------------------------------------------------------------------------
-- Memory reading utilities

-- | This resolves a memory address into a segment offset pair if it
-- points to a valid pair.
resolveMemAddr :: Memory w -> MemAddr w -> Either (MemoryError w) (MemSegmentOff w)
resolveMemAddr :: forall (w :: Natural).
Memory w -> MemAddr w -> Either (MemoryError w) (MemSegmentOff w)
resolveMemAddr Memory w
mem MemAddr w
addr =
  case Memory w -> MemAddr w -> Maybe (MemSegmentOff w)
forall (w :: Natural).
Memory w -> MemAddr w -> Maybe (MemSegmentOff w)
asSegmentOff Memory w
mem MemAddr w
addr of
    Just MemSegmentOff w
p -> MemSegmentOff w -> Either (MemoryError w) (MemSegmentOff w)
forall a b. b -> Either a b
Right MemSegmentOff w
p
    Maybe (MemSegmentOff w)
Nothing -> MemoryError w -> Either (MemoryError w) (MemSegmentOff w)
forall a b. a -> Either a b
Left (MemAddr w -> MemoryError w
forall (w :: Natural). MemAddr w -> MemoryError w
InvalidAddr MemAddr w
addr)

-- | Return contents starting from location or throw a memory error if there
-- is an unaligned relocation.
addrContentsAfter :: Memory w
                  -> MemAddr w
                  -> Either (MemoryError w) [MemChunk w]
addrContentsAfter :: forall (w :: Natural).
Memory w -> MemAddr w -> Either (MemoryError w) [MemChunk w]
addrContentsAfter Memory w
mem MemAddr w
addr = do
  AddrWidthRepr w
-> (MemWidth w => Either (MemoryError w) [MemChunk w])
-> Either (MemoryError w) [MemChunk 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 => Either (MemoryError w) [MemChunk w])
 -> Either (MemoryError w) [MemChunk w])
-> (MemWidth w => Either (MemoryError w) [MemChunk w])
-> Either (MemoryError w) [MemChunk w]
forall a b. (a -> b) -> a -> b
$
    MemSegmentOff w -> Either (MemoryError w) [MemChunk w]
forall (w :: Natural).
MemWidth w =>
MemSegmentOff w -> Either (MemoryError w) [MemChunk w]
segoffContentsAfter (MemSegmentOff w -> Either (MemoryError w) [MemChunk w])
-> Either (MemoryError w) (MemSegmentOff w)
-> Either (MemoryError w) [MemChunk w]
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Memory w -> MemAddr w -> Either (MemoryError w) (MemSegmentOff w)
forall (w :: Natural).
Memory w -> MemAddr w -> Either (MemoryError w) (MemSegmentOff w)
resolveMemAddr Memory w
mem MemAddr w
addr

-- | Attempt to read a bytestring of the given length
readByteString' :: RegionIndex
                   -- ^ Region we are in.
                -> BS.ByteString
                   -- ^ Bytestring read so far.
                -> Word64
                   -- ^ Bytes read so far.
                -> [MemChunk w]
                  -- ^ Remaining memory chunks to read from.
                -> Word64
                   -- ^ Total remaining number of bytes to read.
                -> Either (MemoryError w) BS.ByteString
readByteString' :: forall (w :: Natural).
Int
-> ByteString
-> Word64
-> [MemChunk w]
-> Word64
-> Either (MemoryError w) ByteString
readByteString' Int
_ ByteString
prev Word64
_ [MemChunk w]
_ Word64
0 =
  ByteString -> Either (MemoryError w) ByteString
forall a. a -> Either (MemoryError w) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ByteString -> Either (MemoryError w) ByteString)
-> ByteString -> Either (MemoryError w) ByteString
forall a b. (a -> b) -> a -> b
$! ByteString
prev
readByteString' Int
_ ByteString
_ Word64
_ [] Word64
_ = String -> Either (MemoryError w) ByteString
forall a. HasCallStack => String -> a
error String
"internal: readByteString' given too many bytes."
readByteString' Int
reg ByteString
prev Word64
off (ByteRegion ByteString
bs:[MemChunk w]
rest) Word64
cnt = do
  let sz :: Word64
sz = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
bs)
  if Word64
cnt Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
sz then
    ByteString -> Either (MemoryError w) ByteString
forall a. a -> Either (MemoryError w) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ByteString -> Either (MemoryError w) ByteString)
-> ByteString -> Either (MemoryError w) ByteString
forall a b. (a -> b) -> a -> b
$! ByteString
prev ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> ByteString -> ByteString
BS.take (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
cnt) ByteString
bs
   else do
    let off' :: Word64
off' = Word64
off Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
sz
    let cnt' :: Word64
cnt' = Word64
cnt Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
sz
    Word64
-> Either (MemoryError w) ByteString
-> Either (MemoryError w) ByteString
forall a b. a -> b -> b
seq Word64
cnt' (Either (MemoryError w) ByteString
 -> Either (MemoryError w) ByteString)
-> Either (MemoryError w) ByteString
-> Either (MemoryError w) ByteString
forall a b. (a -> b) -> a -> b
$ Word64
-> Either (MemoryError w) ByteString
-> Either (MemoryError w) ByteString
forall a b. a -> b -> b
seq Word64
off' (Either (MemoryError w) ByteString
 -> Either (MemoryError w) ByteString)
-> Either (MemoryError w) ByteString
-> Either (MemoryError w) ByteString
forall a b. (a -> b) -> a -> b
$ Int
-> ByteString
-> Word64
-> [MemChunk w]
-> Word64
-> Either (MemoryError w) ByteString
forall (w :: Natural).
Int
-> ByteString
-> Word64
-> [MemChunk w]
-> Word64
-> Either (MemoryError w) ByteString
readByteString' Int
reg (ByteString
prev ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
bs) Word64
off' [MemChunk w]
rest Word64
cnt'
readByteString' Int
reg ByteString
_ Word64
off (RelocationRegion Relocation w
r:[MemChunk w]
_) Word64
_ = do
  let addr :: MemAddr w
addr = MemAddr { addrBase :: Int
addrBase = Int
reg, addrOffset :: MemWord w
addrOffset = Word64 -> MemWord w
forall (w :: Natural). Word64 -> MemWord w
MemWord Word64
off }
  MemoryError w -> Either (MemoryError w) ByteString
forall a b. a -> Either a b
Left (MemoryError w -> Either (MemoryError w) ByteString)
-> MemoryError w -> Either (MemoryError w) ByteString
forall a b. (a -> b) -> a -> b
$! MemAddr w -> Relocation w -> MemoryError w
forall (w :: Natural). MemAddr w -> Relocation w -> MemoryError w
UnexpectedRelocation MemAddr w
addr Relocation w
r
readByteString' Int
reg ByteString
prev Word64
off (BSSRegion MemWord w
sz0:[MemChunk w]
rest) Word64
cnt = do
  let sz :: Word64
      sz :: Word64
sz = MemWord w -> Word64
forall (w :: Natural). MemWord w -> Word64
memWordValue MemWord w
sz0
  if Word64
cnt Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
sz then do
    Bool -> Either (MemoryError w) () -> Either (MemoryError w) ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Word64
cnt Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
forall a. Bounded a => a
maxBound :: Int)) (Either (MemoryError w) () -> Either (MemoryError w) ())
-> Either (MemoryError w) () -> Either (MemoryError w) ()
forall a b. (a -> b) -> a -> b
$ do
      String -> Either (MemoryError w) ()
forall a. HasCallStack => String -> a
error (String -> Either (MemoryError w) ())
-> String -> Either (MemoryError w) ()
forall a b. (a -> b) -> a -> b
$ String
"Illegal size " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show Word64
cnt
    ByteString -> Either (MemoryError w) ByteString
forall a. a -> Either (MemoryError w) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ByteString -> Either (MemoryError w) ByteString)
-> ByteString -> Either (MemoryError w) ByteString
forall a b. (a -> b) -> a -> b
$! ByteString
prev ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> Word8 -> ByteString
BS.replicate (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
cnt) Word8
0
   else do
    Bool -> Either (MemoryError w) () -> Either (MemoryError w) ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Word64
sz Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
forall a. Bounded a => a
maxBound :: Int)) (Either (MemoryError w) () -> Either (MemoryError w) ())
-> Either (MemoryError w) () -> Either (MemoryError w) ()
forall a b. (a -> b) -> a -> b
$ do
      String -> Either (MemoryError w) ()
forall a. HasCallStack => String -> a
error (String -> Either (MemoryError w) ())
-> String -> Either (MemoryError w) ()
forall a b. (a -> b) -> a -> b
$ String
"Illegal size " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show Word64
cnt
    let bs :: ByteString
bs = Int -> Word8 -> ByteString
BS.replicate (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
sz) Word8
0
    let off' :: Word64
off' = Word64
off Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
sz
    let cnt' :: Word64
cnt' = Word64
cnt Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
sz
    Word64
-> Either (MemoryError w) ByteString
-> Either (MemoryError w) ByteString
forall a b. a -> b -> b
seq Word64
cnt' (Either (MemoryError w) ByteString
 -> Either (MemoryError w) ByteString)
-> Either (MemoryError w) ByteString
-> Either (MemoryError w) ByteString
forall a b. (a -> b) -> a -> b
$ Word64
-> Either (MemoryError w) ByteString
-> Either (MemoryError w) ByteString
forall a b. a -> b -> b
seq Word64
off' (Either (MemoryError w) ByteString
 -> Either (MemoryError w) ByteString)
-> Either (MemoryError w) ByteString
-> Either (MemoryError w) ByteString
forall a b. (a -> b) -> a -> b
$ Int
-> ByteString
-> Word64
-> [MemChunk w]
-> Word64
-> Either (MemoryError w) ByteString
forall (w :: Natural).
Int
-> ByteString
-> Word64
-> [MemChunk w]
-> Word64
-> Either (MemoryError w) ByteString
readByteString' Int
reg (ByteString
prev ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
bs) Word64
off' [MemChunk w]
rest Word64
cnt'

-- | Attempt to read a bytestring of the given length
readByteString :: Memory w
               -> MemAddr w
               -> Word64 -- ^ Number of bytes to read
               -> Either (MemoryError w) BS.ByteString
readByteString :: forall (w :: Natural).
Memory w
-> MemAddr w -> Word64 -> Either (MemoryError w) ByteString
readByteString Memory w
mem MemAddr w
addr Word64
cnt = AddrWidthRepr w
-> (MemWidth w => Either (MemoryError w) ByteString)
-> Either (MemoryError w) ByteString
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 => Either (MemoryError w) ByteString)
 -> Either (MemoryError w) ByteString)
-> (MemWidth w => Either (MemoryError w) ByteString)
-> Either (MemoryError w) ByteString
forall a b. (a -> b) -> a -> b
$ do
  MemSegmentOff w
segOff <- Memory w -> MemAddr w -> Either (MemoryError w) (MemSegmentOff w)
forall (w :: Natural).
Memory w -> MemAddr w -> Either (MemoryError w) (MemSegmentOff w)
resolveMemAddr Memory w
mem MemAddr w
addr
  -- Check read is in range.
  Bool -> Either (MemoryError w) () -> Either (MemoryError w) ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
cnt Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> MemSegmentOff w -> Integer
forall (w :: Natural). MemWidth w => MemSegmentOff w -> Integer
segoffBytesLeft MemSegmentOff w
segOff) (Either (MemoryError w) () -> Either (MemoryError w) ())
-> Either (MemoryError w) () -> Either (MemoryError w) ()
forall a b. (a -> b) -> a -> b
$ do
    MemoryError w -> Either (MemoryError w) ()
forall a b. a -> Either a b
Left (MemoryError w -> Either (MemoryError w) ())
-> MemoryError w -> Either (MemoryError w) ()
forall a b. (a -> b) -> a -> b
$! MemSegmentOff w -> Word64 -> MemoryError w
forall (w :: Natural). MemSegmentOff w -> Word64 -> MemoryError w
InvalidRead MemSegmentOff w
segOff Word64
cnt
  -- Get contents after segment
  [MemChunk w]
l      <- MemSegmentOff w -> Either (MemoryError w) [MemChunk w]
forall (w :: Natural).
MemWidth w =>
MemSegmentOff w -> Either (MemoryError w) [MemChunk w]
segoffContentsAfter MemSegmentOff w
segOff
  Int
-> ByteString
-> Word64
-> [MemChunk w]
-> Word64
-> Either (MemoryError w) ByteString
forall (w :: Natural).
Int
-> ByteString
-> Word64
-> [MemChunk w]
-> Word64
-> Either (MemoryError w) ByteString
readByteString' (MemAddr w -> Int
forall (w :: Natural). MemAddr w -> Int
addrBase MemAddr w
addr) ByteString
BS.empty (MemWord w -> Word64
forall (w :: Natural). MemWord w -> Word64
memWordValue (MemAddr w -> MemWord w
forall (w :: Natural). MemAddr w -> MemWord w
addrOffset MemAddr w
addr)) [MemChunk w]
l Word64
cnt

-- | 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 :: forall (w :: Natural).
Memory w
-> Endianness -> MemAddr w -> Either (MemoryError w) (MemAddr w)
readAddr Memory w
mem Endianness
end MemAddr w
addr = AddrWidthRepr w
-> (MemWidth w => Either (MemoryError w) (MemAddr w))
-> Either (MemoryError w) (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 => Either (MemoryError w) (MemAddr w))
 -> Either (MemoryError w) (MemAddr w))
-> (MemWidth w => Either (MemoryError w) (MemAddr w))
-> Either (MemoryError w) (MemAddr w)
forall a b. (a -> b) -> a -> b
$ do
  let sz :: Word64
sz = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (MemAddr w -> Int
forall (w :: Natural) (p :: Natural -> Type).
MemWidth w =>
p w -> Int
forall (p :: Natural -> Type). p w -> Int
addrSize MemAddr w
addr)
  ByteString
bs <- Memory w
-> MemAddr w -> Word64 -> Either (MemoryError w) ByteString
forall (w :: Natural).
Memory w
-> MemAddr w -> Word64 -> Either (MemoryError w) ByteString
readByteString Memory w
mem MemAddr w
addr Word64
sz
  case Endianness -> ByteString -> Maybe (MemWord w)
forall (w :: Natural).
MemWidth w =>
Endianness -> ByteString -> Maybe (MemWord w)
addrRead Endianness
end ByteString
bs of
    Just MemWord w
val -> MemAddr w -> Either (MemoryError w) (MemAddr w)
forall a b. b -> Either a b
Right (MemAddr w -> Either (MemoryError w) (MemAddr w))
-> MemAddr w -> Either (MemoryError w) (MemAddr w)
forall a b. (a -> b) -> a -> b
$ Int -> MemWord w -> MemAddr w
forall (w :: Natural). Int -> MemWord w -> MemAddr w
MemAddr Int
0 MemWord w
val
    Maybe (MemWord w)
Nothing -> String -> Either (MemoryError w) (MemAddr w)
forall a. HasCallStack => String -> a
error String
"readAddr internal error: readByteString result too short."

-- | Read the given address as a reference to a memory segment offset, or report a
-- memory read error.
readSegmentOff :: Memory w
               -> Endianness
               -> MemAddr w
               -> Either (MemoryError w) (MemSegmentOff w)
readSegmentOff :: forall (w :: Natural).
Memory w
-> Endianness
-> MemAddr w
-> Either (MemoryError w) (MemSegmentOff w)
readSegmentOff Memory w
mem Endianness
end MemAddr w
addr = AddrWidthRepr w
-> (MemWidth w => Either (MemoryError w) (MemSegmentOff w))
-> Either (MemoryError w) (MemSegmentOff 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 => Either (MemoryError w) (MemSegmentOff w))
 -> Either (MemoryError w) (MemSegmentOff w))
-> (MemWidth w => Either (MemoryError w) (MemSegmentOff w))
-> Either (MemoryError w) (MemSegmentOff w)
forall a b. (a -> b) -> a -> b
$ do
  let sz :: Word64
sz = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (MemAddr w -> Int
forall (w :: Natural) (p :: Natural -> Type).
MemWidth w =>
p w -> Int
forall (p :: Natural -> Type). p w -> Int
addrSize MemAddr w
addr)
  ByteString
bs <- Memory w
-> MemAddr w -> Word64 -> Either (MemoryError w) ByteString
forall (w :: Natural).
Memory w
-> MemAddr w -> Word64 -> Either (MemoryError w) ByteString
readByteString Memory w
mem MemAddr w
addr Word64
sz
  case Endianness -> ByteString -> Maybe (MemWord w)
forall (w :: Natural).
MemWidth w =>
Endianness -> ByteString -> Maybe (MemWord w)
addrRead Endianness
end ByteString
bs of
    Just MemWord w
val -> do
      let addrInMem :: MemAddr w
addrInMem = Int -> MemWord w -> MemAddr w
forall (w :: Natural). Int -> MemWord w -> MemAddr w
MemAddr Int
0 MemWord w
val
      case Memory w -> MemAddr w -> Maybe (MemSegmentOff w)
forall (w :: Natural).
Memory w -> MemAddr w -> Maybe (MemSegmentOff w)
asSegmentOff Memory w
mem MemAddr w
addrInMem of
        Just MemSegmentOff w
res -> MemSegmentOff w -> Either (MemoryError w) (MemSegmentOff w)
forall a. a -> Either (MemoryError w) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure MemSegmentOff w
res
        Maybe (MemSegmentOff w)
Nothing -> MemoryError w -> Either (MemoryError w) (MemSegmentOff w)
forall a b. a -> Either a b
Left (MemAddr w -> MemoryError w
forall (w :: Natural). MemAddr w -> MemoryError w
InvalidAddr MemAddr w
addrInMem)
    Maybe (MemWord w)
Nothing -> String -> Either (MemoryError w) (MemSegmentOff w)
forall a. HasCallStack => String -> a
error String
"readSegmentOff internal error: readByteString result too short."

-- | Read a single byte.
readWord8 :: Memory w -> MemAddr w -> Either (MemoryError w) Word8
readWord8 :: forall (w :: Natural).
Memory w -> MemAddr w -> Either (MemoryError w) Word8
readWord8 Memory w
mem MemAddr w
addr = ByteString -> Word8
bsWord8 (ByteString -> Word8)
-> Either (MemoryError w) ByteString
-> Either (MemoryError w) Word8
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Memory w
-> MemAddr w -> Word64 -> Either (MemoryError w) ByteString
forall (w :: Natural).
Memory w
-> MemAddr w -> Word64 -> Either (MemoryError w) ByteString
readByteString Memory w
mem MemAddr w
addr Word64
1

-- | Read a big endian word16
readWord16be :: Memory w -> MemAddr w -> Either (MemoryError w) Word16
readWord16be :: forall (w :: Natural).
Memory w -> MemAddr w -> Either (MemoryError w) SegmentIndex
readWord16be Memory w
mem MemAddr w
addr = HasCallStack => ByteString -> SegmentIndex
ByteString -> SegmentIndex
ElfBS.bsWord16be (ByteString -> SegmentIndex)
-> Either (MemoryError w) ByteString
-> Either (MemoryError w) SegmentIndex
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Memory w
-> MemAddr w -> Word64 -> Either (MemoryError w) ByteString
forall (w :: Natural).
Memory w
-> MemAddr w -> Word64 -> Either (MemoryError w) ByteString
readByteString Memory w
mem MemAddr w
addr Word64
2

-- | Read a little endian word16
readWord16le :: Memory w -> MemAddr w -> Either (MemoryError w) Word16
readWord16le :: forall (w :: Natural).
Memory w -> MemAddr w -> Either (MemoryError w) SegmentIndex
readWord16le Memory w
mem MemAddr w
addr = HasCallStack => ByteString -> SegmentIndex
ByteString -> SegmentIndex
ElfBS.bsWord16le (ByteString -> SegmentIndex)
-> Either (MemoryError w) ByteString
-> Either (MemoryError w) SegmentIndex
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Memory w
-> MemAddr w -> Word64 -> Either (MemoryError w) ByteString
forall (w :: Natural).
Memory w
-> MemAddr w -> Word64 -> Either (MemoryError w) ByteString
readByteString Memory w
mem MemAddr w
addr Word64
2

-- | Read a big endian word32
readWord32be :: Memory w -> MemAddr w -> Either (MemoryError w) Word32
readWord32be :: forall (w :: Natural).
Memory w -> MemAddr w -> Either (MemoryError w) Word32
readWord32be Memory w
mem MemAddr w
addr = HasCallStack => ByteString -> Word32
ByteString -> Word32
ElfBS.bsWord32be (ByteString -> Word32)
-> Either (MemoryError w) ByteString
-> Either (MemoryError w) Word32
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Memory w
-> MemAddr w -> Word64 -> Either (MemoryError w) ByteString
forall (w :: Natural).
Memory w
-> MemAddr w -> Word64 -> Either (MemoryError w) ByteString
readByteString Memory w
mem MemAddr w
addr Word64
4

-- | Read a little endian word32
readWord32le :: Memory w -> MemAddr w -> Either (MemoryError w) Word32
readWord32le :: forall (w :: Natural).
Memory w -> MemAddr w -> Either (MemoryError w) Word32
readWord32le Memory w
mem MemAddr w
addr = HasCallStack => ByteString -> Word32
ByteString -> Word32
ElfBS.bsWord32le (ByteString -> Word32)
-> Either (MemoryError w) ByteString
-> Either (MemoryError w) Word32
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Memory w
-> MemAddr w -> Word64 -> Either (MemoryError w) ByteString
forall (w :: Natural).
Memory w
-> MemAddr w -> Word64 -> Either (MemoryError w) ByteString
readByteString Memory w
mem MemAddr w
addr Word64
4

-- | Read a big endian word64
readWord64be :: Memory w -> MemAddr w -> Either (MemoryError w) Word64
readWord64be :: forall (w :: Natural).
Memory w -> MemAddr w -> Either (MemoryError w) Word64
readWord64be Memory w
mem MemAddr w
addr = HasCallStack => ByteString -> Word64
ByteString -> Word64
ElfBS.bsWord64be (ByteString -> Word64)
-> Either (MemoryError w) ByteString
-> Either (MemoryError w) Word64
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Memory w
-> MemAddr w -> Word64 -> Either (MemoryError w) ByteString
forall (w :: Natural).
Memory w
-> MemAddr w -> Word64 -> Either (MemoryError w) ByteString
readByteString Memory w
mem MemAddr w
addr Word64
8

-- | Read a little endian word64
readWord64le :: Memory w -> MemAddr w -> Either (MemoryError w) Word64
readWord64le :: forall (w :: Natural).
Memory w -> MemAddr w -> Either (MemoryError w) Word64
readWord64le Memory w
mem MemAddr w
addr = HasCallStack => ByteString -> Word64
ByteString -> Word64
ElfBS.bsWord64le (ByteString -> Word64)
-> Either (MemoryError w) ByteString
-> Either (MemoryError w) Word64
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Memory w
-> MemAddr w -> Word64 -> Either (MemoryError w) ByteString
forall (w :: Natural).
Memory w
-> MemAddr w -> Word64 -> Either (MemoryError w) ByteString
readByteString Memory w
mem MemAddr w
addr Word64
8

data NullTermString w
   = NullTermString !BS.ByteString
   | NoNullTerm
   | RelocationBeforeNull !(MemAddr w)
   | NullTermMemoryError !(MemoryError w)

-- | Attempt to read a null terminated bytesting.
readNullTermString :: MemWidth w
                  => MemSegmentOff w
                  -> NullTermString w
readNullTermString :: forall (w :: Natural).
MemWidth w =>
MemSegmentOff w -> NullTermString w
readNullTermString MemSegmentOff w
addr = do
  let seg :: MemSegment w
seg = MemSegmentOff w -> MemSegment w
forall (w :: Natural). MemSegmentOff w -> MemSegment w
segoffSegment MemSegmentOff w
addr
  let reg :: Int
reg = MemSegment w -> Int
forall (w :: Natural). MemSegment w -> Int
segmentBase MemSegment w
seg
  let off :: Word64
off = MemWord w -> Word64
forall (w :: Natural). MemWord w -> Word64
memWordValue (MemSegment w -> MemWord w
forall (w :: Natural). MemSegment w -> MemWord w
segmentOffset MemSegment w
seg) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ MemWord w -> Word64
forall (w :: Natural). MemWord w -> Word64
memWordValue (MemSegmentOff w -> MemWord w
forall (w :: Natural). MemSegmentOff w -> MemWord w
segoffOffset MemSegmentOff w
addr)
  case MemSegmentOff w -> Either (MemoryError w) [MemChunk w]
forall (w :: Natural).
MemWidth w =>
MemSegmentOff w -> Either (MemoryError w) [MemChunk w]
segoffContentsAfter MemSegmentOff w
addr of
    Left MemoryError w
e -> MemoryError w -> NullTermString w
forall (w :: Natural). MemoryError w -> NullTermString w
NullTermMemoryError MemoryError w
e
    Right [] -> NullTermString w
forall (w :: Natural). NullTermString w
NoNullTerm
    Right (ByteRegion ByteString
bs:[MemChunk w]
rest) -> do
      let bs' :: ByteString
bs' = (Word8 -> Bool) -> ByteString -> ByteString
BS.takeWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0) ByteString
bs
      if ByteString -> Int
BS.length ByteString
bs' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Int
BS.length ByteString
bs then
        case [MemChunk w]
rest of
          [] -> NullTermString w
forall (w :: Natural). NullTermString w
NoNullTerm
          ByteRegion ByteString
_:[MemChunk w]
_ -> String -> NullTermString w
forall a. HasCallStack => String -> a
error String
"Misformed memory chunks"
          RelocationRegion Relocation w
_r:[MemChunk w]
_ ->
            let off' :: Word64
off' = Word64
off Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
bs)
                relAddr :: MemAddr w
relAddr = MemAddr { addrBase :: Int
addrBase = Int
reg, addrOffset :: MemWord w
addrOffset = Word64 -> MemWord w
forall (w :: Natural). Word64 -> MemWord w
MemWord Word64
off' }
             in MemAddr w -> NullTermString w
forall (w :: Natural). MemAddr w -> NullTermString w
RelocationBeforeNull MemAddr w
relAddr
          BSSRegion MemWord w
_:[MemChunk w]
_ ->
            ByteString -> NullTermString w
forall (w :: Natural). ByteString -> NullTermString w
NullTermString ByteString
bs
      else
        ByteString -> NullTermString w
forall (w :: Natural). ByteString -> NullTermString w
NullTermString ByteString
bs'
    Right (RelocationRegion Relocation w
_r:[MemChunk w]
_) ->
      let relAddr :: MemAddr w
relAddr = MemAddr { addrBase :: Int
addrBase = Int
reg, addrOffset :: MemWord w
addrOffset = Word64 -> MemWord w
forall (w :: Natural). Word64 -> MemWord w
MemWord Word64
off }
       in MemAddr w -> NullTermString w
forall (w :: Natural). MemAddr w -> NullTermString w
RelocationBeforeNull MemAddr w
relAddr
    Right (BSSRegion MemWord w
_:[MemChunk w]
_) ->
      ByteString -> NullTermString w
forall (w :: Natural). ByteString -> NullTermString w
NullTermString ByteString
BS.empty

------------------------------------------------------------------------
-- Memory finding utilities

-- | Return list of segment content memory segment ranges with its
-- content's address offset relative to segment offsets
relativeSegmentContents :: (MemWidth w) => [MemSegment w] -> [(MemAddr w, MemChunk w)]
relativeSegmentContents :: forall (w :: Natural).
MemWidth w =>
[MemSegment w] -> [(MemAddr w, MemChunk w)]
relativeSegmentContents [MemSegment w]
memSegs = (MemSegment w -> [(MemAddr w, MemChunk w)])
-> [MemSegment w] -> [(MemAddr w, MemChunk w)]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap MemSegment w -> [(MemAddr w, MemChunk w)]
forall (w :: Natural).
MemWidth w =>
MemSegment w -> [(MemAddr w, MemChunk w)]
relativeOffset [MemSegment w]
memSegs
  where
    -- Each MemSegment has a segmentOffset indicating the offset from segmentBase its located.
    -- This makes the offsets within the MemChunk relative to that segmentOffset.
    relativeOffset :: (MemWidth w) => MemSegment w -> [(MemAddr w, MemChunk w)]
    relativeOffset :: forall (w :: Natural).
MemWidth w =>
MemSegment w -> [(MemAddr w, MemChunk w)]
relativeOffset MemSegment w
seg = ((MemWord w, MemChunk w) -> (MemAddr w, MemChunk w))
-> [(MemWord w, MemChunk w)] -> [(MemAddr w, MemChunk w)]
forall a b. (a -> b) -> [a] -> [b]
map (\(MemWord w
contentOffset,MemChunk w
r) -> (MemSegment w -> MemWord w -> MemAddr w
forall (w :: Natural).
MemWidth w =>
MemSegment w -> MemWord w -> MemAddr w
segmentOffAddr MemSegment w
seg MemWord w
contentOffset, MemChunk w
r)) ([(MemWord w, MemChunk w)] -> [(MemAddr w, MemChunk w)])
-> [(MemWord w, MemChunk w)] -> [(MemAddr w, MemChunk w)]
forall a b. (a -> b) -> a -> b
$ (SegmentContents w -> [(MemWord w, MemChunk w)]
forall (w :: Natural).
SegmentContents w -> [(MemWord w, MemChunk w)]
contentsRanges (SegmentContents w -> [(MemWord w, MemChunk w)])
-> (MemSegment w -> SegmentContents w)
-> MemSegment w
-> [(MemWord w, MemChunk w)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemSegment w -> SegmentContents w
forall (w :: Natural). MemSegment w -> SegmentContents w
segmentContents) MemSegment w
seg

-- | Naive string matching algorithm identifies matches to given
-- pattern within the list of memory segments and their corresponding
-- offset within memory. Relocations are treated as wildcards.
findByteStringMatches :: MemWidth w
                      => BS.ByteString
                      -- ^ Pattern to search for within memory segments
                      -> Integer
                      -- ^ Offset within the contents region where search is to start
                      -> [(MemAddr w, MemChunk w)]
                      -- ^ Contents of memory along with its relative
                      -- address from the segment base address.
                      -> [MemAddr w]
findByteStringMatches :: forall (w :: Natural).
MemWidth w =>
ByteString -> Integer -> [(MemAddr w, MemChunk w)] -> [MemAddr w]
findByteStringMatches ByteString
_ Integer
_ [] = []
findByteStringMatches ByteString
pat Integer
curIndex segs :: [(MemAddr w, MemChunk w)]
segs@((MemAddr w
relOffset, MemChunk w
chunk) : [(MemAddr w, MemChunk w)]
rest)
  | ByteString -> Int
BS.length ByteString
pat Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = []
  | Bool
otherwise =
    if ByteString -> [MemChunk w] -> Bool
forall (w :: Natural).
MemWidth w =>
ByteString -> [MemChunk w] -> Bool
matchPrefix ByteString
pat (((MemAddr w, MemChunk w) -> MemChunk w)
-> [(MemAddr w, MemChunk w)] -> [MemChunk w]
forall a b. (a -> b) -> [a] -> [b]
map (MemAddr w, MemChunk w) -> MemChunk w
forall a b. (a, b) -> b
snd [(MemAddr w, MemChunk w)]
segs) then
      MemAddr w
currentAddr MemAddr w -> [MemAddr w] -> [MemAddr w]
forall a. a -> [a] -> [a]
: ByteString -> Integer -> [(MemAddr w, MemChunk w)] -> [MemAddr w]
forall (w :: Natural).
MemWidth w =>
ByteString -> Integer -> [(MemAddr w, MemChunk w)] -> [MemAddr w]
findByteStringMatches ByteString
pat Integer
nextIndex [(MemAddr w, MemChunk w)]
remainingElems
    else
      ByteString -> Integer -> [(MemAddr w, MemChunk w)] -> [MemAddr w]
forall (w :: Natural).
MemWidth w =>
ByteString -> Integer -> [(MemAddr w, MemChunk w)] -> [MemAddr w]
findByteStringMatches ByteString
pat Integer
nextIndex [(MemAddr w, MemChunk w)]
remainingElems
  where
    currentAddr :: MemAddr w
currentAddr = Integer -> MemAddr w -> MemAddr w
forall (w :: Natural).
MemWidth w =>
Integer -> MemAddr w -> MemAddr w
incAddr Integer
curIndex MemAddr w
relOffset
    (Integer
nextIndex, [(MemAddr w, MemChunk w)]
remainingElems) = case MemChunk w
chunk of
      -- drop byte in region
      ByteRegion ByteString
bs ->
        if ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then
          (Integer
curIndex Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1, (MemAddr w
relOffset, ByteString -> MemChunk w
forall (w :: Natural). ByteString -> MemChunk w
ByteRegion (Int -> ByteString -> ByteString
BS.drop Int
1 ByteString
bs)) (MemAddr w, MemChunk w)
-> [(MemAddr w, MemChunk w)] -> [(MemAddr w, MemChunk w)]
forall a. a -> [a] -> [a]
: [(MemAddr w, MemChunk w)]
rest)
        else (Integer
0, [(MemAddr w, MemChunk w)]
rest)
      -- TODO: Increments within a relocation region
      MemChunk w
_  -> (Integer
0, [(MemAddr w, MemChunk w)]
rest)


-- | Returns True when the given ByteString matches the bytes at the
-- beginning of this segment range and false otherwise.
matchPrefix :: MemWidth w => BS.ByteString -> [MemChunk w] -> Bool
matchPrefix :: forall (w :: Natural).
MemWidth w =>
ByteString -> [MemChunk w] -> Bool
matchPrefix ByteString
_ [] = Bool
False
matchPrefix ByteString
_ (BSSRegion MemWord w
_ : [MemChunk w]
_) = Bool
False
matchPrefix ByteString
pat (rel :: MemChunk w
rel@(RelocationRegion Relocation w
_r) : [MemChunk w]
rest)
  -- When pattern is greater than size of the relocation, skip
  -- relocation bytes in the pattern and look for match in beginning
  -- of the next range.
  | ByteString -> Int
BS.length ByteString
pat Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
sz = ByteString -> [MemChunk w] -> Bool
forall (w :: Natural).
MemWidth w =>
ByteString -> [MemChunk w] -> Bool
matchPrefix (Int -> ByteString -> ByteString
BS.drop (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
sz) ByteString
pat) [MemChunk w]
rest
  -- When length of pattern is less than or equal to the size of the relocation => match
  | Bool
otherwise = Bool
True
  where sz :: Word64
sz = MemChunk w -> Word64
forall (w :: Natural). MemWidth w => MemChunk w -> Word64
chunkSize MemChunk w
rel
matchPrefix ByteString
pat (ByteRegion ByteString
bs : [MemChunk w]
rest)
  -- Enough bytes in region to check for match directly.  This also
  -- returns true when the search pattern is empty and stops recursion
  | Int
matchLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
prefixLen = ByteString
pat ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
regionPrefix
    -- There aren't enough bytes in region; we need to check that
    -- the elems that do exist match the pattern prefix and
    -- that a following regions contain the remaining search pattern.
    -- NOTE: Assumes the regions are adjacent to each other.
  | Bool
otherwise = ByteString
regionPrefix ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> ByteString -> ByteString
BS.take Int
prefixLen ByteString
pat Bool -> Bool -> Bool
&& ByteString -> [MemChunk w] -> Bool
forall (w :: Natural).
MemWidth w =>
ByteString -> [MemChunk w] -> Bool
matchPrefix (Int -> ByteString -> ByteString
BS.drop Int
prefixLen ByteString
pat) [MemChunk w]
rest
  where
    matchLen :: Int
matchLen     = ByteString -> Int
BS.length ByteString
pat
    regionPrefix :: ByteString
regionPrefix = Int -> ByteString -> ByteString
BS.take Int
matchLen ByteString
bs
    prefixLen :: Int
prefixLen    = ByteString -> Int
BS.length ByteString
regionPrefix