{-|
Copyright   : Galois Inc, 2016-18
Maintainer  : jhendrix@galois.com

Operations for creating a view of memory from an elf file.
-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Data.Macaw.Memory.ElfLoader
  ( memoryForElf
  , memoryForElf'
  , memoryForElfAllSymbols
  , memoryForElfSections
  , memoryForElfSegments
  , memoryForElfSegments'
  , SectionIndexMap
  , MemLoadWarning(..)
  , RelocationError
  , SectionName
  , resolveElfContents
  , elfAddrWidth
  , adjustedLoadRegionIndex
    -- * Symbols
  , MemSymbol(..)
  , SymbolResolutionError(..)
  , SymbolTable(..)
    -- * Re-exports
  , module Data.Macaw.Memory.LoadCommon
  , module Data.Macaw.Memory
  , module Data.Macaw.Memory.Symbols
  ) where

import           Control.Lens
import           Control.Monad (when)
import           Control.Monad.Except (Except, ExceptT, MonadError(..), runExcept, runExceptT)
import           Control.Monad.State.Strict (State, StateT(..), execStateT, gets, modify, runState)
import           Data.Bits
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import           Data.ElfEdit.Prim
  ( ElfWidthConstraints
  , ElfWordType
  , ElfClass(..)

  , ElfSectionIndex(..)
  , ElfSectionFlags
  , ElfSegmentFlags
  )
import qualified Data.ElfEdit.Prim as Elf
import           Data.Foldable
import           Data.IntervalMap.Strict (Interval(..), IntervalMap)
import qualified Data.IntervalMap.Strict as IMap
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe
import           Data.Proxy (Proxy(..))
import           Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Vector as V
import           Data.Word
import           GHC.TypeLits (KnownNat, natVal)
import           Numeric (showHex)

import           Data.Macaw.Memory
import           Data.Macaw.Memory.LoadCommon
import qualified Data.Macaw.Memory.Permissions as Perm
import           Data.Macaw.Memory.Symbols

-- | Return a subrange of a bytestring.
slice :: Integral w => Elf.FileRange w -> BS.ByteString -> BS.ByteString
slice :: forall w. Integral w => FileRange w -> ByteString -> ByteString
slice (FileOffset w
i,w
c) = Int -> ByteString -> ByteString
BS.take (w -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral w
c) (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
BS.drop (FileOffset w -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral FileOffset w
i)

-- | Return the addr width repr associated with an elf class
elfAddrWidth :: ElfClass w -> AddrWidthRepr w
elfAddrWidth :: forall (w :: Nat). ElfClass w -> AddrWidthRepr w
elfAddrWidth ElfClass w
ELFCLASS32 = AddrWidthRepr w
forall (w :: Nat). (w ~ 32) => AddrWidthRepr w
Addr32
elfAddrWidth ElfClass w
ELFCLASS64 = AddrWidthRepr w
forall (w :: Nat). (w ~ 64) => AddrWidthRepr w
Addr64

------------------------------------------------------------------------
-- SectionIndexMap

-- | Maps section indices that are loaded in memory to their associated base
-- address and section contents.
--
-- The base address is expressed in terms of the underlying memory segment.
type SectionIndexMap w = Map Word16 (MemSegmentOff w)

------------------------------------------------------------------------
-- Flag conversion

-- | Create Reopt flags from elf flags.
flagsForSegmentFlags :: ElfSegmentFlags -> Perm.Flags
flagsForSegmentFlags :: ElfSegmentFlags -> Flags
flagsForSegmentFlags ElfSegmentFlags
f
    =   ElfSegmentFlags -> Flags -> Flags
flagIf ElfSegmentFlags
Elf.pf_r Flags
Perm.read
    Flags -> Flags -> Flags
forall a. Bits a => a -> a -> a
.|. ElfSegmentFlags -> Flags -> Flags
flagIf ElfSegmentFlags
Elf.pf_w Flags
Perm.write
    Flags -> Flags -> Flags
forall a. Bits a => a -> a -> a
.|. ElfSegmentFlags -> Flags -> Flags
flagIf ElfSegmentFlags
Elf.pf_x Flags
Perm.execute
  where flagIf :: ElfSegmentFlags -> Perm.Flags -> Perm.Flags
        flagIf :: ElfSegmentFlags -> Flags -> Flags
flagIf ElfSegmentFlags
ef Flags
pf | ElfSegmentFlags
f ElfSegmentFlags -> ElfSegmentFlags -> Bool
forall b. Bits b => b -> b -> Bool
`Elf.hasPermissions` ElfSegmentFlags
ef = Flags
pf
                     | Bool
otherwise = Flags
Perm.none

-- | Convert elf section flags to a segment flags.
flagsForSectionFlags :: forall w
                     .  (Num w, Bits w)
                     => ElfSectionFlags w
                     -> Perm.Flags
flagsForSectionFlags :: forall w. (Num w, Bits w) => ElfSectionFlags w -> Flags
flagsForSectionFlags ElfSectionFlags w
f =
    Flags
Perm.read Flags -> Flags -> Flags
forall a. Bits a => a -> a -> a
.|. ElfSectionFlags w -> Flags -> Flags
flagIf ElfSectionFlags w
forall w. Num w => ElfSectionFlags w
Elf.shf_write Flags
Perm.write Flags -> Flags -> Flags
forall a. Bits a => a -> a -> a
.|. ElfSectionFlags w -> Flags -> Flags
flagIf ElfSectionFlags w
forall w. Num w => ElfSectionFlags w
Elf.shf_execinstr Flags
Perm.execute
  where flagIf :: ElfSectionFlags w -> Perm.Flags -> Perm.Flags
        flagIf :: ElfSectionFlags w -> Flags -> Flags
flagIf ElfSectionFlags w
ef Flags
pf = if ElfSectionFlags w
f ElfSectionFlags w -> ElfSectionFlags w -> Bool
forall b. Bits b => b -> b -> Bool
`Elf.hasPermissions` ElfSectionFlags w
ef then Flags
pf else Flags
Perm.none

------------------------------------------------------------------------
-- RelocationError

data RelocationError
   = MissingSymbolTable
     -- ^ The file is missing a symbol table.
   | RelocationZeroSymbol
     -- ^ A relocation refers to the symbol index 0.
   | RelocationBadSymbolIndex !Int
     -- ^ A relocation entry referenced a bad symbol index.
   | RelocationUnsupportedType !String
     -- ^ We do not support this type of relocation.
   | RelocationFileUnsupported
     -- ^ We do not allow relocations to refer to the "file" as in Elf.
   | RelocationInvalidAddend !String !Integer !SymbolIdentifier
     -- ^ The relocation type given does not allow the adddend with the given value.
   | RelocationEvenAddend !String !Integer !BSC.ByteString !Integer
     -- ^ The relocation type must have an even addend.
   | RelocationDynamicError Elf.DynamicError
     -- ^ Parsing the dynamic section failed when resolving a symbol.

instance Show RelocationError where
  show :: RelocationError -> [Char]
show RelocationError
MissingSymbolTable =
    [Char]
"Relocations cannot be applied due to missing symbol table."
  show RelocationError
RelocationZeroSymbol =
    [Char]
"A relocation entry referred to invalid 0 symbol index."
  show (RelocationBadSymbolIndex Int
idx) =
    [Char]
"A relocation entry referred to invalid symbol index " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
idx [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"."
  show (RelocationUnsupportedType [Char]
tp) =
    [Char]
"Unsupported relocation type " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
tp
  show RelocationError
RelocationFileUnsupported =
    [Char]
"Do not support relocations referring to file entry."
  show (RelocationEvenAddend [Char]
tp Integer
addr ByteString
sym Integer
addend) =
    let tgt :: [Char]
tgt = ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
sym [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" + " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
addend
     in [Char]
"The " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
tp [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" relocation applied to " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
addr
        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" with target " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
tgt [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" must have an even addend."
  show (RelocationInvalidAddend [Char]
tp Integer
v SymbolIdentifier
sym) =
    [Char]
"Do not support addend of " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
v [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" with relocation type " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
tp [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" to " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ SymbolIdentifier -> [Char]
forall a. Show a => a -> [Char]
show SymbolIdentifier
sym [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"."
  show (RelocationDynamicError DynamicError
e) = DynamicError -> [Char]
forall a. Show a => a -> [Char]
show DynamicError
e

------------------------------------------------------------------------
-- MemLoader

type SectionName = BS.ByteString

data MemLoadWarning
  = SectionNotAlloc !SectionName
  | MultipleSectionsWithName !SectionName
  | MultipleDynamicSegments
  | OverlappingLoadableSegments
  | UnsupportedSection !SectionName
  | UnknownDefinedSymbolBinding   !SymbolName Elf.ElfSymbolBinding
  | UnknownDefinedSymbolType      !SymbolName Elf.ElfSymbolType
  | UnknownUndefinedSymbolBinding !SymbolName Elf.ElfSymbolBinding
  | UnknownUndefinedSymbolType    !SymbolName Elf.ElfSymbolType
  | ExpectedSectionSymbolNameEmpty !SymbolName
  | ExpectedSectionSymbolLocal
  | InvalidSectionSymbolIndex !Elf.ElfSectionIndex
  | UnsupportedProcessorSpecificSymbolIndex !SymbolName !ElfSectionIndex

  | MultipleRelocationTables
    -- ^ Issued if the file contains multiple relocation tables.
  | RelocationParseFailure !String
  | DynamicTagsOutOfRange !Elf.ElfDynamicTag !Elf.ElfDynamicTag !Word64 !Word64
    -- ^ The range referenced by the dynamic tags was  range.
  | DynamicTagPairMismatch !Elf.ElfDynamicTag !Elf.ElfDynamicTag
    -- ^ We expected either both tags or neither.
  | DynamicMultipleTags !Elf.ElfDynamicTag
    -- ^ We expected at most a single value of the given tag, but failed multiple.
  | AndroidRelWithNonzeroAddend
    -- ^ The `DT_ANDROID_REL` section contains Android relocations with non-zero addends.
  | AndroidRelDecodingError !Elf.ElfDynamicTag !Elf.AndroidDecodeError
    -- ^ We could not decode the table identified by the given dynamic tag.
  | MultipleRelocationsAtAddr !Word64
    -- ^ Multiple relocations at the given offset
  | IgnoreRelocation !RelocationError
    -- ^ @IgnoreRelocation err@ warns we ignored a relocation.
  | ShdrPhdrOverlap
    -- ^ A section header overlaps with a program header.

ppSymbol :: SymbolName -> String
ppSymbol :: ByteString -> [Char]
ppSymbol ByteString
"" = [Char]
"unnamed symbol"
ppSymbol ByteString
nm = [Char]
"symbol " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BSC.unpack ByteString
nm

instance Show MemLoadWarning where
  show :: MemLoadWarning -> [Char]
show (SectionNotAlloc ByteString
nm) =
    [Char]
"Section " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BSC.unpack ByteString
nm [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" was not marked as allocated."
  show (MultipleSectionsWithName ByteString
nm) =
    [Char]
"Found multiple sections named " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BSC.unpack ByteString
nm [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"; arbitrarily choosing first one encountered."
  show MemLoadWarning
MultipleDynamicSegments =
    [Char]
"Found multiple dynamic segments; choosing first one."
  show MemLoadWarning
OverlappingLoadableSegments =
    [Char]
"File segments containing overlapping addresses; skipping relocations."
  show (UnsupportedSection ByteString
nm) =
    [Char]
"Do not support section " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BSC.unpack ByteString
nm
  show (UnknownDefinedSymbolBinding ByteString
nm ElfSymbolBinding
bnd) =
    [Char]
"Unsupported binding " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ElfSymbolBinding -> [Char]
forall a. Show a => a -> [Char]
show ElfSymbolBinding
bnd [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" for defined " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
ppSymbol ByteString
nm
    [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"; Treating as a strong symbol."
  show (UnknownDefinedSymbolType ByteString
nm ElfSymbolType
tp) =
    [Char]
"Unsupported type " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ElfSymbolType -> [Char]
forall a. Show a => a -> [Char]
show ElfSymbolType
tp [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" for defined " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
ppSymbol ByteString
nm
    [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"; Treating as a strong symbol."
  show (UnknownUndefinedSymbolBinding ByteString
nm ElfSymbolBinding
bnd) =
    [Char]
"Unsupported binding " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ElfSymbolBinding -> [Char]
forall a. Show a => a -> [Char]
show ElfSymbolBinding
bnd [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" for undefined " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
ppSymbol ByteString
nm
    [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"; Treating as a required symbol."
  show (UnknownUndefinedSymbolType ByteString
nm ElfSymbolType
tp) =
    [Char]
"Unsupported type " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ElfSymbolType -> [Char]
forall a. Show a => a -> [Char]
show ElfSymbolType
tp [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" for undefined " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
ppSymbol ByteString
nm
    [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"; Treating as a strong symbol."
  show (ExpectedSectionSymbolNameEmpty ByteString
nm) =
    [Char]
"Expected section symbol to have empty name instead of " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
ppSymbol ByteString
nm [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"."
  show MemLoadWarning
ExpectedSectionSymbolLocal =
    [Char]
"Expected section symbol to have local visibility."
  show (InvalidSectionSymbolIndex ElfSectionIndex
idx) =
    [Char]
"Expected section symbol to have a valid index instead of " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ElfSectionIndex -> [Char]
forall a. Show a => a -> [Char]
show ElfSectionIndex
idx [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"."
  show (UnsupportedProcessorSpecificSymbolIndex ByteString
nm ElfSectionIndex
idx) =
    [Char]
"Could not resolve symbol index " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ElfSectionIndex -> [Char]
forall a. Show a => a -> [Char]
show ElfSectionIndex
idx [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" for symbol " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BSC.unpack ByteString
nm [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"."
  show MemLoadWarning
MultipleRelocationTables =
    [Char]
"File contains multiple relocation tables; these are being merged."
  show (RelocationParseFailure [Char]
msg) =
    [Char]
"Error parsing relocations: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
msg
  show (DynamicTagsOutOfRange ElfDynamicTag
offTag ElfDynamicTag
szTag Word64
off Word64
sz) =
    ElfDynamicTag -> [Char]
forall a. Show a => a -> [Char]
show ElfDynamicTag
offTag [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" and " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ElfDynamicTag -> [Char]
forall a. Show a => a -> [Char]
show ElfDynamicTag
szTag [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" referenced a range [" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
off)
    [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" to " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
off Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
sz) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"that is outside the file bounds."
  show (DynamicTagPairMismatch ElfDynamicTag
foundTag ElfDynamicTag
notfoundTag) =
    [Char]
"Found " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ElfDynamicTag -> [Char]
forall a. Show a => a -> [Char]
show ElfDynamicTag
foundTag [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" but missing " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ElfDynamicTag -> [Char]
forall a. Show a => a -> [Char]
show ElfDynamicTag
notfoundTag [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"."
  show (DynamicMultipleTags ElfDynamicTag
tag) =
    [Char]
"Multiple values assigned to " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ElfDynamicTag -> [Char]
forall a. Show a => a -> [Char]
show ElfDynamicTag
tag [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" in dynamic information."
  show MemLoadWarning
AndroidRelWithNonzeroAddend =
    [Char]
"The DT_ANDROID_REL region in the dynamic is ignoring relocations with non-zero addends."
  show (AndroidRelDecodingError ElfDynamicTag
tag AndroidDecodeError
nm) =
    [Char]
"The " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ElfDynamicTag -> [Char]
forall a. Show a => a -> [Char]
show ElfDynamicTag
tag [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" region generated decoding error: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ AndroidDecodeError -> [Char]
forall a. Show a => a -> [Char]
show AndroidDecodeError
nm
  show (MultipleRelocationsAtAddr Word64
addr) =
    [Char]
"Multiple relocations modify " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> ShowS
forall a. Integral a => a -> ShowS
showHex Word64
addr [Char]
"."
  show (IgnoreRelocation RelocationError
err) =
    RelocationError -> [Char]
forall a. Show a => a -> [Char]
show RelocationError
err
  show MemLoadWarning
ShdrPhdrOverlap =
    [Char]
"Found section header that overlaps with program header."

data MemLoaderState w = MLS { forall (w :: Nat). MemLoaderState w -> Memory w
_mlsMemory :: !(Memory w)
                            , forall (w :: Nat). MemLoaderState w -> Endianness
mlsEndianness :: !Endianness
                              -- ^ Endianness of elf file
                            , forall (w :: Nat). MemLoaderState w -> SectionIndexMap w
_mlsIndexMap :: !(SectionIndexMap w)
                            , forall (w :: Nat). MemLoaderState w -> [MemLoadWarning]
mlsWarnings :: ![MemLoadWarning]
                            }

mlsMemory :: Simple Lens (MemLoaderState w) (Memory w)
mlsMemory :: forall (w :: Nat) (f :: Type -> Type).
Functor f =>
(Memory w -> f (Memory w))
-> MemLoaderState w -> f (MemLoaderState w)
mlsMemory = (MemLoaderState w -> Memory w)
-> (MemLoaderState w -> Memory w -> MemLoaderState w)
-> Lens (MemLoaderState w) (MemLoaderState w) (Memory w) (Memory w)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens MemLoaderState w -> Memory w
forall (w :: Nat). MemLoaderState w -> Memory w
_mlsMemory (\MemLoaderState w
s Memory w
v -> MemLoaderState w
s { _mlsMemory = v })

-- | Map from elf section indices to their offset and section
mlsIndexMap :: Simple Lens (MemLoaderState w) (SectionIndexMap w)
mlsIndexMap :: forall (w :: Nat) (f :: Type -> Type).
Functor f =>
(SectionIndexMap w -> f (SectionIndexMap w))
-> MemLoaderState w -> f (MemLoaderState w)
mlsIndexMap = (MemLoaderState w -> SectionIndexMap w)
-> (MemLoaderState w -> SectionIndexMap w -> MemLoaderState w)
-> Lens
     (MemLoaderState w)
     (MemLoaderState w)
     (SectionIndexMap w)
     (SectionIndexMap w)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens MemLoaderState w -> SectionIndexMap w
forall (w :: Nat). MemLoaderState w -> SectionIndexMap w
_mlsIndexMap (\MemLoaderState w
s SectionIndexMap w
v -> MemLoaderState w
s { _mlsIndexMap = v })

addWarning :: MemLoadWarning -> MemLoader w ()
addWarning :: forall (w :: Nat). MemLoadWarning -> MemLoader w ()
addWarning MemLoadWarning
w = (MemLoaderState w -> MemLoaderState w)
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify ((MemLoaderState w -> MemLoaderState w)
 -> StateT (MemLoaderState w) (Except (LoadError w)) ())
-> (MemLoaderState w -> MemLoaderState w)
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
forall a b. (a -> b) -> a -> b
$ \MemLoaderState w
s -> MemLoaderState w
s { mlsWarnings = w : mlsWarnings s }

type MemLoader w = StateT (MemLoaderState w) (Except (LoadError w))

-- || Error occured from loading
data LoadError w
   = LoadInsertError !String !(InsertError w)
     -- ^ Error occurred in inserting a segment into memory.
   | UnsupportedArchitecture !String
     -- ^ Do not support relocations on given architecture.
   | FormatDynamicError !Elf.DynamicError
     -- ^ An error occured in parsing the dynamic segment.

instance MemWidth w => Show (LoadError w) where
  show :: LoadError w -> [Char]
show (LoadInsertError [Char]
nm (OverlapSegment MemSegment w
_ MemSegment w
old)) =
    [Char]
nm [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" overlaps with memory segment: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ MemWord w -> [Char]
forall a. Show a => a -> [Char]
show (MemSegment w -> MemWord w
forall (w :: Nat). MemSegment w -> MemWord w
segmentOffset MemSegment w
old)
  show (UnsupportedArchitecture [Char]
arch) =
    [Char]
"Dynamic libraries are not supported on " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
arch [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"."
  show (FormatDynamicError DynamicError
e) =
    [Char]
"Elf parsing error: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ DynamicError -> [Char]
forall a. Show a => a -> [Char]
show DynamicError
e

-- | This contains information needed to resolve elf symbol addresses.
data SymbolAddrResolver w =
  SymbolAddrResolver { forall (w :: Nat). SymbolAddrResolver w -> Word16
symSecCount :: Word16
                     , forall (w :: Nat).
SymbolAddrResolver w
-> Word16 -> ElfWordType w -> Maybe (MemSegmentOff w)
symResolver :: Word16 -> ElfWordType w -> Maybe (MemSegmentOff w)
                       -- ^ Given a section index and offset, this returns the memory addr
                       -- or nothing if that cannot be determined.
                     }

mkSymbolAddrResolver :: (MemWidth w, Integral (ElfWordType w))
                     => V.Vector (Elf.Shdr Word32 (Elf.ElfWordType w))
                     -> SectionIndexMap w
                     -> SymbolAddrResolver w
mkSymbolAddrResolver :: forall (w :: Nat).
(MemWidth w, Integral (ElfWordType w)) =>
Vector (Shdr Word32 (ElfWordType w))
-> SectionIndexMap w -> SymbolAddrResolver w
mkSymbolAddrResolver Vector (Shdr Word32 (ElfWordType w))
v SectionIndexMap w
m = do
  let resolveFn :: Word16 -> ElfWordType w -> Maybe (MemSegmentOff w)
resolveFn Word16
secIdx ElfWordType w
val = do
        case Word16 -> SectionIndexMap w -> Maybe (MemSegmentOff w)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Word16
secIdx SectionIndexMap w
m of
          Just MemSegmentOff w
base
            | Just Shdr Word32 (ElfWordType w)
s <- Vector (Shdr Word32 (ElfWordType w))
v Vector (Shdr Word32 (ElfWordType w))
-> Int -> Maybe (Shdr Word32 (ElfWordType w))
forall a. Vector a -> Int -> Maybe a
V.!? Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
secIdx
            , Shdr Word32 (ElfWordType w) -> ElfWordType w
forall nm w. Shdr nm w -> w
Elf.shdrAddr Shdr Word32 (ElfWordType w)
s ElfWordType w -> ElfWordType w -> Bool
forall a. Ord a => a -> a -> Bool
<= ElfWordType w
val Bool -> Bool -> Bool
&& (ElfWordType w
val ElfWordType w -> ElfWordType w -> ElfWordType w
forall a. Num a => a -> a -> a
- Shdr Word32 (ElfWordType w) -> ElfWordType w
forall nm w. Shdr nm w -> w
Elf.shdrAddr Shdr Word32 (ElfWordType w)
s) ElfWordType w -> ElfWordType w -> Bool
forall a. Ord a => a -> a -> Bool
< Shdr Word32 (ElfWordType w) -> ElfWordType w
forall nm w. Shdr nm w -> w
Elf.shdrSize Shdr Word32 (ElfWordType w)
s
            , Integer
off <- ElfWordType w -> Integer
forall a. Integral a => a -> Integer
toInteger (ElfWordType w
val ElfWordType w -> ElfWordType w -> ElfWordType w
forall a. Num a => a -> a -> a
- Shdr Word32 (ElfWordType w) -> ElfWordType w
forall nm w. Shdr nm w -> w
Elf.shdrAddr Shdr Word32 (ElfWordType w)
s) ->
              MemSegmentOff w -> Integer -> Maybe (MemSegmentOff w)
forall (w :: Nat).
MemWidth w =>
MemSegmentOff w -> Integer -> Maybe (MemSegmentOff w)
incSegmentOff MemSegmentOff w
base Integer
off
          Maybe (MemSegmentOff w)
_ -> Maybe (MemSegmentOff w)
forall a. Maybe a
Nothing
   in SymbolAddrResolver { symSecCount :: Word16
symSecCount = Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Vector (Shdr Word32 (ElfWordType w)) -> Int
forall a. Vector a -> Int
V.length Vector (Shdr Word32 (ElfWordType w))
v)
                         , symResolver :: Word16 -> ElfWordType w -> Maybe (MemSegmentOff w)
symResolver = Word16 -> ElfWordType w -> Maybe (MemSegmentOff w)
resolveFn
                         }

runMemLoader :: Endianness
             -> Memory  w
             -> MemLoader w ()
             -> Either String (Memory w, SectionIndexMap w, [MemLoadWarning])
runMemLoader :: forall (w :: Nat).
Endianness
-> Memory w
-> MemLoader w ()
-> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning])
runMemLoader Endianness
end Memory w
mem MemLoader w ()
m =
   let s :: MemLoaderState w
s = MLS { _mlsMemory :: Memory w
_mlsMemory = Memory w
mem
               , _mlsIndexMap :: SectionIndexMap w
_mlsIndexMap = SectionIndexMap w
forall k a. Map k a
Map.empty
               , mlsWarnings :: [MemLoadWarning]
mlsWarnings = []
               , mlsEndianness :: Endianness
mlsEndianness = Endianness
end
               }
    in case Except (LoadError w) (MemLoaderState w)
-> Either (LoadError w) (MemLoaderState w)
forall e a. Except e a -> Either e a
runExcept (Except (LoadError w) (MemLoaderState w)
 -> Either (LoadError w) (MemLoaderState w))
-> Except (LoadError w) (MemLoaderState w)
-> Either (LoadError w) (MemLoaderState w)
forall a b. (a -> b) -> a -> b
$ MemLoader w ()
-> MemLoaderState w -> Except (LoadError w) (MemLoaderState w)
forall (m :: Type -> Type) s a. Monad m => StateT s m a -> s -> m s
execStateT MemLoader w ()
m MemLoaderState w
s of
         Left LoadError w
e -> [Char]
-> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning])
forall a b. a -> Either a b
Left ([Char]
 -> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning]))
-> [Char]
-> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning])
forall a b. (a -> b) -> a -> b
$ AddrWidthRepr w -> (MemWidth w => [Char]) -> [Char]
forall (w :: Nat) a. AddrWidthRepr w -> (MemWidth w => a) -> a
addrWidthClass (Memory w -> AddrWidthRepr w
forall (w :: Nat). Memory w -> AddrWidthRepr w
memAddrWidth Memory w
mem) (LoadError w -> [Char]
forall a. Show a => a -> [Char]
show LoadError w
e)
         Right MemLoaderState w
mls -> do
           (Memory w, SectionIndexMap w, [MemLoadWarning])
-> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning])
forall a b. b -> Either a b
Right (MemLoaderState w
mlsMemLoaderState w
-> Getting (Memory w) (MemLoaderState w) (Memory w) -> Memory w
forall s a. s -> Getting a s a -> a
^.Getting (Memory w) (MemLoaderState w) (Memory w)
forall (w :: Nat) (f :: Type -> Type).
Functor f =>
(Memory w -> f (Memory w))
-> MemLoaderState w -> f (MemLoaderState w)
mlsMemory, MemLoaderState w
mlsMemLoaderState w
-> Getting
     (SectionIndexMap w) (MemLoaderState w) (SectionIndexMap w)
-> SectionIndexMap w
forall s a. s -> Getting a s a -> a
^.Getting (SectionIndexMap w) (MemLoaderState w) (SectionIndexMap w)
forall (w :: Nat) (f :: Type -> Type).
Functor f =>
(SectionIndexMap w -> f (SectionIndexMap w))
-> MemLoaderState w -> f (MemLoaderState w)
mlsIndexMap, [MemLoadWarning] -> [MemLoadWarning]
forall a. [a] -> [a]
reverse (MemLoaderState w -> [MemLoadWarning]
forall (w :: Nat). MemLoaderState w -> [MemLoadWarning]
mlsWarnings MemLoaderState w
mls))

-- | This adds a Macaw mem segment to the memory
loadMemSegment :: MemWidth w => String -> MemSegment w -> MemLoader w ()
loadMemSegment :: forall (w :: Nat).
MemWidth w =>
[Char] -> MemSegment w -> MemLoader w ()
loadMemSegment [Char]
nm MemSegment w
seg =
  (MemLoaderState w -> Except (LoadError w) ((), MemLoaderState w))
-> StateT (MemLoaderState w) (ExceptT (LoadError w) Identity) ()
forall s (m :: Type -> Type) a. (s -> m (a, s)) -> StateT s m a
StateT ((MemLoaderState w -> Except (LoadError w) ((), MemLoaderState w))
 -> StateT (MemLoaderState w) (ExceptT (LoadError w) Identity) ())
-> (MemLoaderState w
    -> Except (LoadError w) ((), MemLoaderState w))
-> StateT (MemLoaderState w) (ExceptT (LoadError w) Identity) ()
forall a b. (a -> b) -> a -> b
$ \MemLoaderState w
mls ->
    case MemSegment w -> Memory w -> Either (InsertError w) (Memory w)
forall (w :: Nat).
MemSegment w -> Memory w -> Either (InsertError w) (Memory w)
insertMemSegment MemSegment w
seg (MemLoaderState w
mlsMemLoaderState w
-> Getting (Memory w) (MemLoaderState w) (Memory w) -> Memory w
forall s a. s -> Getting a s a -> a
^.Getting (Memory w) (MemLoaderState w) (Memory w)
forall (w :: Nat) (f :: Type -> Type).
Functor f =>
(Memory w -> f (Memory w))
-> MemLoaderState w -> f (MemLoaderState w)
mlsMemory) of
      Left InsertError w
e ->
        LoadError w -> Except (LoadError w) ((), MemLoaderState w)
forall a. LoadError w -> ExceptT (LoadError w) Identity a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (LoadError w -> Except (LoadError w) ((), MemLoaderState w))
-> LoadError w -> Except (LoadError w) ((), MemLoaderState w)
forall a b. (a -> b) -> a -> b
$ [Char] -> InsertError w -> LoadError w
forall (w :: Nat). [Char] -> InsertError w -> LoadError w
LoadInsertError [Char]
nm InsertError w
e
      Right Memory w
mem' ->
        ((), MemLoaderState w)
-> Except (LoadError w) ((), MemLoaderState w)
forall a. a -> ExceptT (LoadError w) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((), MemLoaderState w
mls MemLoaderState w
-> (MemLoaderState w -> MemLoaderState w) -> MemLoaderState w
forall a b. a -> (a -> b) -> b
& (Memory w -> Identity (Memory w))
-> MemLoaderState w -> Identity (MemLoaderState w)
forall (w :: Nat) (f :: Type -> Type).
Functor f =>
(Memory w -> f (Memory w))
-> MemLoaderState w -> f (MemLoaderState w)
mlsMemory ((Memory w -> Identity (Memory w))
 -> MemLoaderState w -> Identity (MemLoaderState w))
-> Memory w -> MemLoaderState w -> MemLoaderState w
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Memory w
mem')

-- | Maps file offsets to the elf section
type ElfFileSectionMap v = IntervalMap v Word16

------------------------------------------------------------------------
-- SymbolResolver

type SymbolResolver a = ExceptT RelocationError (State [MemLoadWarning]) a

runSymbolResolver :: SymbolResolver a -> MemLoader w (Either RelocationError a)
runSymbolResolver :: forall a (w :: Nat).
SymbolResolver a -> MemLoader w (Either RelocationError a)
runSymbolResolver SymbolResolver a
m = do
  [MemLoadWarning]
warn <- (MemLoaderState w -> [MemLoadWarning])
-> StateT
     (MemLoaderState w) (Except (LoadError w)) [MemLoadWarning]
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets MemLoaderState w -> [MemLoadWarning]
forall (w :: Nat). MemLoaderState w -> [MemLoadWarning]
mlsWarnings
  let (Either RelocationError a
er, [MemLoadWarning]
warn') = State [MemLoadWarning] (Either RelocationError a)
-> [MemLoadWarning] -> (Either RelocationError a, [MemLoadWarning])
forall s a. State s a -> s -> (a, s)
runState (SymbolResolver a
-> State [MemLoadWarning] (Either RelocationError a)
forall e (m :: Type -> Type) a. ExceptT e m a -> m (Either e a)
runExceptT SymbolResolver a
m) [MemLoadWarning]
warn
  (MemLoaderState w -> MemLoaderState w)
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify ((MemLoaderState w -> MemLoaderState w)
 -> StateT (MemLoaderState w) (Except (LoadError w)) ())
-> (MemLoaderState w -> MemLoaderState w)
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
forall a b. (a -> b) -> a -> b
$ \MemLoaderState w
s -> MemLoaderState w
s { mlsWarnings = warn' }
  Either RelocationError a -> MemLoader w (Either RelocationError a)
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Either RelocationError a
er

symbolWarning :: MemLoadWarning -> SymbolResolver ()
symbolWarning :: MemLoadWarning -> SymbolResolver ()
symbolWarning MemLoadWarning
w = ([MemLoadWarning] -> [MemLoadWarning]) -> SymbolResolver ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify (([MemLoadWarning] -> [MemLoadWarning]) -> SymbolResolver ())
-> ([MemLoadWarning] -> [MemLoadWarning]) -> SymbolResolver ()
forall a b. (a -> b) -> a -> b
$ \[MemLoadWarning]
l -> MemLoadWarning
wMemLoadWarning -> [MemLoadWarning] -> [MemLoadWarning]
forall a. a -> [a] -> [a]
:[MemLoadWarning]
l

------------------------------------------------------------------------
-- SymbolTable

-- | This wraps a callback function that lets users lookup symbol information by index
-- from the Elf file.
--
-- It is implemented using a callback function as the Elf dynamic
-- section doesn't provide an explicit number of symbol table
-- elements, and we decided not to depend on meta data such as section
-- names that could be stripped from executables/shared objects.
data SymbolTable w
   = NoSymbolTable
   | StaticSymbolTable !(V.Vector (Elf.SymtabEntry BS.ByteString (Elf.ElfWordType w)))
   | DynamicSymbolTable !(Elf.DynamicSection w) !(Elf.VirtAddrMap w) !Elf.VersionDefMap !Elf.VersionReqMap

-- | Take a symbol entry and symbol version and return the identifier.
resolveSymbolId :: Elf.SymtabEntry BS.ByteString wtp
                -> SymbolVersion
                -> SymbolResolver SymbolIdentifier
resolveSymbolId :: forall wtp.
SymtabEntry ByteString wtp
-> SymbolVersion -> SymbolResolver SymbolIdentifier
resolveSymbolId SymtabEntry ByteString wtp
sym SymbolVersion
ver = do
  let nm :: ByteString
nm = SymtabEntry ByteString wtp -> ByteString
forall nm w. SymtabEntry nm w -> nm
Elf.steName SymtabEntry ByteString wtp
sym
  let idx :: ElfSectionIndex
idx = SymtabEntry ByteString wtp -> ElfSectionIndex
forall nm w. SymtabEntry nm w -> ElfSectionIndex
Elf.steIndex SymtabEntry ByteString wtp
sym
  case SymtabEntry ByteString wtp -> ElfSymbolType
forall nm w. SymtabEntry nm w -> ElfSymbolType
Elf.steType SymtabEntry ByteString wtp
sym of
    ElfSymbolType
Elf.STT_SECTION
      | ElfSectionIndex
idx ElfSectionIndex -> ElfSectionIndex -> Bool
forall a. Ord a => a -> a -> Bool
< ElfSectionIndex
Elf.SHN_LOPROC -> do
          Bool -> SymbolResolver () -> SymbolResolver ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (ByteString
nm ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"") (SymbolResolver () -> SymbolResolver ())
-> SymbolResolver () -> SymbolResolver ()
forall a b. (a -> b) -> a -> b
$
            MemLoadWarning -> SymbolResolver ()
symbolWarning (MemLoadWarning -> SymbolResolver ())
-> MemLoadWarning -> SymbolResolver ()
forall a b. (a -> b) -> a -> b
$ ByteString -> MemLoadWarning
ExpectedSectionSymbolNameEmpty ByteString
nm
          Bool -> SymbolResolver () -> SymbolResolver ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (SymtabEntry ByteString wtp -> ElfSymbolBinding
forall nm w. SymtabEntry nm w -> ElfSymbolBinding
Elf.steBind SymtabEntry ByteString wtp
sym ElfSymbolBinding -> ElfSymbolBinding -> Bool
forall a. Eq a => a -> a -> Bool
/= ElfSymbolBinding
Elf.STB_LOCAL) (SymbolResolver () -> SymbolResolver ())
-> SymbolResolver () -> SymbolResolver ()
forall a b. (a -> b) -> a -> b
$
            MemLoadWarning -> SymbolResolver ()
symbolWarning MemLoadWarning
ExpectedSectionSymbolLocal
          SymbolIdentifier -> SymbolResolver SymbolIdentifier
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (SymbolIdentifier -> SymbolResolver SymbolIdentifier)
-> SymbolIdentifier -> SymbolResolver SymbolIdentifier
forall a b. (a -> b) -> a -> b
$ Word16 -> SymbolIdentifier
SectionIdentifier (ElfSectionIndex -> Word16
Elf.fromElfSectionIndex ElfSectionIndex
idx)
      | Bool
otherwise -> do
          MemLoadWarning -> SymbolResolver ()
symbolWarning (MemLoadWarning -> SymbolResolver ())
-> MemLoadWarning -> SymbolResolver ()
forall a b. (a -> b) -> a -> b
$ ElfSectionIndex -> MemLoadWarning
InvalidSectionSymbolIndex ElfSectionIndex
idx
          SymbolIdentifier -> SymbolResolver SymbolIdentifier
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (SymbolIdentifier -> SymbolResolver SymbolIdentifier)
-> SymbolIdentifier -> SymbolResolver SymbolIdentifier
forall a b. (a -> b) -> a -> b
$ ByteString -> SymbolVersion -> SymbolIdentifier
SymbolRelocation ByteString
nm SymbolVersion
ver
    ElfSymbolType
Elf.STT_FILE -> do
      RelocationError -> SymbolResolver SymbolIdentifier
forall a.
RelocationError
-> ExceptT RelocationError (State [MemLoadWarning]) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError RelocationError
RelocationFileUnsupported
    ElfSymbolType
_tp -> do
      Bool -> SymbolResolver () -> SymbolResolver ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (ElfSectionIndex
idx ElfSectionIndex -> ElfSectionIndex -> Bool
forall a. Ord a => a -> a -> Bool
>= ElfSectionIndex
Elf.SHN_LOPROC Bool -> Bool -> Bool
&& ElfSectionIndex
idx ElfSectionIndex -> [ElfSectionIndex] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`notElem` [ElfSectionIndex
Elf.SHN_ABS, ElfSectionIndex
Elf.SHN_COMMON]) (SymbolResolver () -> SymbolResolver ())
-> SymbolResolver () -> SymbolResolver ()
forall a b. (a -> b) -> a -> b
$ do
        MemLoadWarning -> SymbolResolver ()
symbolWarning (MemLoadWarning -> SymbolResolver ())
-> MemLoadWarning -> SymbolResolver ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ElfSectionIndex -> MemLoadWarning
UnsupportedProcessorSpecificSymbolIndex ByteString
nm ElfSectionIndex
idx
      SymbolIdentifier -> SymbolResolver SymbolIdentifier
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (SymbolIdentifier -> SymbolResolver SymbolIdentifier)
-> SymbolIdentifier -> SymbolResolver SymbolIdentifier
forall a b. (a -> b) -> a -> b
$ ByteString -> SymbolVersion -> SymbolIdentifier
SymbolRelocation ByteString
nm SymbolVersion
ver

resolveSymbol :: SymbolTable w
              -> Word32
              -> SymbolResolver
                  ( Elf.SymtabEntry BS.ByteString (Elf.ElfWordType w)
                  , SymbolVersion
                  )
resolveSymbol :: forall (w :: Nat).
SymbolTable w
-> Word32
-> SymbolResolver
     (SymtabEntry ByteString (ElfWordType w), SymbolVersion)
resolveSymbol SymbolTable w
NoSymbolTable Word32
_symIdx =
  RelocationError
-> ExceptT
     RelocationError
     (State [MemLoadWarning])
     (SymtabEntry ByteString (ElfWordType w), SymbolVersion)
forall a.
RelocationError
-> ExceptT RelocationError (State [MemLoadWarning]) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError RelocationError
MissingSymbolTable
resolveSymbol (StaticSymbolTable Vector (SymtabEntry ByteString (ElfWordType w))
entries) Word32
symIdx = do
  Bool -> SymbolResolver () -> SymbolResolver ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Word32
symIdx Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0) (SymbolResolver () -> SymbolResolver ())
-> SymbolResolver () -> SymbolResolver ()
forall a b. (a -> b) -> a -> b
$
    RelocationError -> SymbolResolver ()
forall a.
RelocationError
-> ExceptT RelocationError (State [MemLoadWarning]) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError RelocationError
RelocationZeroSymbol
  case Vector (SymtabEntry ByteString (ElfWordType w))
entries Vector (SymtabEntry ByteString (ElfWordType w))
-> Int -> Maybe (SymtabEntry ByteString (ElfWordType w))
forall a. Vector a -> Int -> Maybe a
V.!? Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
symIdx of
    Maybe (SymtabEntry ByteString (ElfWordType w))
Nothing ->
      RelocationError
-> ExceptT
     RelocationError
     (State [MemLoadWarning])
     (SymtabEntry ByteString (ElfWordType w), SymbolVersion)
forall a.
RelocationError
-> ExceptT RelocationError (State [MemLoadWarning]) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (RelocationError
 -> ExceptT
      RelocationError
      (State [MemLoadWarning])
      (SymtabEntry ByteString (ElfWordType w), SymbolVersion))
-> RelocationError
-> ExceptT
     RelocationError
     (State [MemLoadWarning])
     (SymtabEntry ByteString (ElfWordType w), SymbolVersion)
forall a b. (a -> b) -> a -> b
$ Int -> RelocationError
RelocationBadSymbolIndex (Int -> RelocationError) -> Int -> RelocationError
forall a b. (a -> b) -> a -> b
$ Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
symIdx
    Just SymtabEntry ByteString (ElfWordType w)
sym ->
      -- Look for '@' as it is used to separate symbol name from version information
      -- in object files.
      case (Char -> Bool) -> ByteString -> Maybe Int
BSC.findIndex (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'@') (SymtabEntry ByteString (ElfWordType w) -> ByteString
forall nm w. SymtabEntry nm w -> nm
Elf.steName SymtabEntry ByteString (ElfWordType w)
sym) of
        Just Int
i -> do
          let nm :: ByteString
nm = SymtabEntry ByteString (ElfWordType w) -> ByteString
forall nm w. SymtabEntry nm w -> nm
Elf.steName SymtabEntry ByteString (ElfWordType w)
sym
                  -- If "@@" appears in the symbol, this is a default versioned symbol
          let ver :: SymbolVersion
ver | Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< ByteString -> Int
BSC.length ByteString
nm, ByteString -> Int -> Char
BSC.index ByteString
nm (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'@' =
                      ByteString -> SymbolVersion
ObjectDefaultSymbol (Int -> ByteString -> ByteString
BSC.drop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) ByteString
nm)
                  -- Otherwise "@" appears in the symbol, and this is a non-default symbol.
                  | Bool
otherwise =
                      ByteString -> SymbolVersion
ObjectNonDefaultSymbol (Int -> ByteString -> ByteString
BSC.drop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ByteString
nm)
          (SymtabEntry ByteString (ElfWordType w), SymbolVersion)
-> ExceptT
     RelocationError
     (State [MemLoadWarning])
     (SymtabEntry ByteString (ElfWordType w), SymbolVersion)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (SymtabEntry ByteString (ElfWordType w)
sym { Elf.steName = BSC.take i nm }, SymbolVersion
ver)
        Maybe Int
Nothing -> do
          (SymtabEntry ByteString (ElfWordType w), SymbolVersion)
-> ExceptT
     RelocationError
     (State [MemLoadWarning])
     (SymtabEntry ByteString (ElfWordType w), SymbolVersion)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (SymtabEntry ByteString (ElfWordType w)
sym, SymbolVersion
UnversionedSymbol)
resolveSymbol (DynamicSymbolTable DynamicSection w
ds VirtAddrMap w
virtMap VersionDefMap
verDefMap VersionDefMap
verReqMap) Word32
symIdx = do
  Bool -> SymbolResolver () -> SymbolResolver ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Word32
symIdx Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0) (SymbolResolver () -> SymbolResolver ())
-> SymbolResolver () -> SymbolResolver ()
forall a b. (a -> b) -> a -> b
$
    RelocationError -> SymbolResolver ()
forall a.
RelocationError
-> ExceptT RelocationError (State [MemLoadWarning]) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError RelocationError
RelocationZeroSymbol
  case DynamicSection w
-> VirtAddrMap w
-> VersionDefMap
-> VersionDefMap
-> Word32
-> Either DynamicError (VersionedSymbol (ElfWordType w))
forall (w :: Nat).
DynamicSection w
-> VirtAddrMap w
-> VersionDefMap
-> VersionDefMap
-> Word32
-> Either DynamicError (VersionedSymbol (ElfWordType w))
Elf.dynSymEntry DynamicSection w
ds VirtAddrMap w
virtMap VersionDefMap
verDefMap VersionDefMap
verReqMap Word32
symIdx of
    Left DynamicError
e -> RelocationError
-> ExceptT
     RelocationError
     (State [MemLoadWarning])
     (SymtabEntry ByteString (ElfWordType w), SymbolVersion)
forall a.
RelocationError
-> ExceptT RelocationError (State [MemLoadWarning]) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (DynamicError -> RelocationError
RelocationDynamicError DynamicError
e)
    Right (SymtabEntry ByteString (ElfWordType w)
sym, VersionTableValue
mverId) -> do
      let ver :: SymbolVersion
ver = case VersionTableValue
mverId of
                  VersionTableValue
Elf.VersionLocal -> SymbolVersion
UnversionedSymbol
                  VersionTableValue
Elf.VersionGlobal -> SymbolVersion
UnversionedSymbol
                  Elf.VersionSpecific VersionId
elfVer -> ByteString -> ByteString -> SymbolVersion
VersionedSymbol (VersionId -> ByteString
Elf.verFile VersionId
elfVer) (VersionId -> ByteString
Elf.verName VersionId
elfVer)
      (SymtabEntry ByteString (ElfWordType w), SymbolVersion)
-> ExceptT
     RelocationError
     (State [MemLoadWarning])
     (SymtabEntry ByteString (ElfWordType w), SymbolVersion)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (SymtabEntry ByteString (ElfWordType w)
sym, SymbolVersion
ver)

------------------------------------------------------------------------
-- Relocations

data RelFlag = IsRel | IsRela
  deriving (RelFlag -> RelFlag -> Bool
(RelFlag -> RelFlag -> Bool)
-> (RelFlag -> RelFlag -> Bool) -> Eq RelFlag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RelFlag -> RelFlag -> Bool
== :: RelFlag -> RelFlag -> Bool
$c/= :: RelFlag -> RelFlag -> Bool
/= :: RelFlag -> RelFlag -> Bool
Eq, Eq RelFlag
Eq RelFlag =>
(RelFlag -> RelFlag -> Ordering)
-> (RelFlag -> RelFlag -> Bool)
-> (RelFlag -> RelFlag -> Bool)
-> (RelFlag -> RelFlag -> Bool)
-> (RelFlag -> RelFlag -> Bool)
-> (RelFlag -> RelFlag -> RelFlag)
-> (RelFlag -> RelFlag -> RelFlag)
-> Ord RelFlag
RelFlag -> RelFlag -> Bool
RelFlag -> RelFlag -> Ordering
RelFlag -> RelFlag -> RelFlag
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 :: RelFlag -> RelFlag -> Ordering
compare :: RelFlag -> RelFlag -> Ordering
$c< :: RelFlag -> RelFlag -> Bool
< :: RelFlag -> RelFlag -> Bool
$c<= :: RelFlag -> RelFlag -> Bool
<= :: RelFlag -> RelFlag -> Bool
$c> :: RelFlag -> RelFlag -> Bool
> :: RelFlag -> RelFlag -> Bool
$c>= :: RelFlag -> RelFlag -> Bool
>= :: RelFlag -> RelFlag -> Bool
$cmax :: RelFlag -> RelFlag -> RelFlag
max :: RelFlag -> RelFlag -> RelFlag
$cmin :: RelFlag -> RelFlag -> RelFlag
min :: RelFlag -> RelFlag -> RelFlag
Ord, Int -> RelFlag -> ShowS
[RelFlag] -> ShowS
RelFlag -> [Char]
(Int -> RelFlag -> ShowS)
-> (RelFlag -> [Char]) -> ([RelFlag] -> ShowS) -> Show RelFlag
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RelFlag -> ShowS
showsPrec :: Int -> RelFlag -> ShowS
$cshow :: RelFlag -> [Char]
show :: RelFlag -> [Char]
$cshowList :: [RelFlag] -> ShowS
showList :: [RelFlag] -> ShowS
Show)

-- | A function that resolves the architecture-specific relocation-type
-- into a symbol reference.  The input
type RelocationResolver tp
  =  Maybe SegmentIndex
     -- ^ Index of segment in which this relocation will be applied if this is
     -- a dynamic relocation, and `Nothing` otherwise.
  -> SymbolTable (Elf.RelocationWidth tp)
  -> Elf.RelEntry tp
     -- ^ Relocation information
  -> MemWord (Elf.RelocationWidth tp)
     -- ^ Addend to add to symbol.
  -> RelFlag
     -- ^ Flag to indicate if this is a rela and rel relocation
     --
     -- Added because some relocations (i.e. PLT ones) will ignore
     -- Rel relocation addends.
  -> SymbolResolver (Relocation (Elf.RelocationWidth tp))

data SomeRelocationResolver w
  = forall tp
  . (Elf.IsRelocationType tp, w ~ Elf.RelocationWidth tp)
  => SomeRelocationResolver (RelocationResolver tp)

-- T is 1 if the target symbol S has type STT_FUNC and the symbol addresses a Thumb instruction; it is 0 otherwise.


-- | This attempts to resolve an index in the symbol table to the
-- identifier information needed to resolve its loaded address.
resolveRelocationSym :: SymbolTable w
                      -- ^ A vector mapping symbol indices to the
                      -- associated symbol information.
                      -> Word32
                      -- ^ Index in the symbol table this refers to.
                      -> SymbolResolver SymbolIdentifier
resolveRelocationSym :: forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable w
symtab Word32
symIdx = do
  (SymtabEntry ByteString (ElfWordType w)
symEntry, SymbolVersion
ver) <- SymbolTable w
-> Word32
-> ExceptT
     RelocationError
     (State [MemLoadWarning])
     (SymtabEntry ByteString (ElfWordType w), SymbolVersion)
forall (w :: Nat).
SymbolTable w
-> Word32
-> SymbolResolver
     (SymtabEntry ByteString (ElfWordType w), SymbolVersion)
resolveSymbol SymbolTable w
symtab Word32
symIdx
  SymtabEntry ByteString (ElfWordType w)
-> SymbolVersion -> SymbolResolver SymbolIdentifier
forall wtp.
SymtabEntry ByteString wtp
-> SymbolVersion -> SymbolResolver SymbolIdentifier
resolveSymbolId SymtabEntry ByteString (ElfWordType w)
symEntry SymbolVersion
ver


-- | Attempt to resolve an X86_64 specific symbol.
relaTargetX86_64 :: Maybe SegmentIndex
                 -> SymbolTable 64
                 -- ^ Symbol table to look up symbols in/
                 -> Elf.RelEntry Elf.X86_64_RelocationType
                 -> MemWord 64
                 -- ^ Addend to add to symbol.
                 -> RelFlag
                 -> SymbolResolver (Relocation 64)
relaTargetX86_64 :: Maybe Word16
-> SymbolTable 64
-> RelEntry X86_64_RelocationType
-> MemWord 64
-> RelFlag
-> SymbolResolver (Relocation 64)
relaTargetX86_64 Maybe Word16
_ SymbolTable 64
symtab RelEntry X86_64_RelocationType
rel MemWord 64
addend RelFlag
_isRel =
  case RelEntry X86_64_RelocationType -> X86_64_RelocationType
forall tp. RelEntry tp -> tp
Elf.relType RelEntry X86_64_RelocationType
rel of
    X86_64_RelocationType
Elf.R_X86_64_64 -> do
      SymbolIdentifier
sym <- SymbolTable 64 -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable 64
symtab (RelEntry X86_64_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry X86_64_RelocationType
rel)
      Relocation 64 -> SymbolResolver (Relocation 64)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation 64 -> SymbolResolver (Relocation 64))
-> Relocation 64 -> SymbolResolver (Relocation 64)
forall a b. (a -> b) -> a -> b
$ Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
sym
                        , relocationOffset :: MemWord 64
relocationOffset     = MemWord 64
addend
                        , relocationIsRel :: Bool
relocationIsRel      = Bool
False
                        , relocationSize :: Int
relocationSize       = Int
8
                        , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                        , relocationEndianness :: Endianness
relocationEndianness = Endianness
LittleEndian
                        , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
False
                        }
    X86_64_RelocationType
Elf.R_X86_64_PC32 -> do
      SymbolIdentifier
sym <- SymbolTable 64 -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable 64
symtab (RelEntry X86_64_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry X86_64_RelocationType
rel)
      Relocation 64 -> SymbolResolver (Relocation 64)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation 64 -> SymbolResolver (Relocation 64))
-> Relocation 64 -> SymbolResolver (Relocation 64)
forall a b. (a -> b) -> a -> b
$ Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
sym
                        , relocationOffset :: MemWord 64
relocationOffset     = MemWord 64
addend
                        , relocationIsRel :: Bool
relocationIsRel      = Bool
True
                        , relocationSize :: Int
relocationSize       = Int
4
                        , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                        , relocationEndianness :: Endianness
relocationEndianness = Endianness
LittleEndian
                        , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
False
                        }
    -- This is used for constructing relative jumps from a caller to the
    -- PLT stub for the function it is calling.  Such jumps typically modify
    -- a relative call instruction with four bytes for the distance, and so
    -- the distance must be an unsigned 4-byte value.
    X86_64_RelocationType
Elf.R_X86_64_PLT32 -> do
      SymbolIdentifier
sym <- SymbolTable 64 -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable 64
symtab (RelEntry X86_64_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry X86_64_RelocationType
rel)
      Relocation 64 -> SymbolResolver (Relocation 64)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation 64 -> SymbolResolver (Relocation 64))
-> Relocation 64 -> SymbolResolver (Relocation 64)
forall a b. (a -> b) -> a -> b
$ Relocation { relocationSym :: SymbolIdentifier
relocationSym    = SymbolIdentifier
sym
                        , relocationOffset :: MemWord 64
relocationOffset = MemWord 64
addend
                        , relocationIsRel :: Bool
relocationIsRel  = Bool
True
                        , relocationSize :: Int
relocationSize   = Int
4
                        , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                        , relocationEndianness :: Endianness
relocationEndianness = Endianness
LittleEndian
                        , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
True
                        }
    -- R_X86_64_GLOB_DAT are used to update GOT entries with their
    -- target address.  They are similar to R_x86_64_64 except appear
    -- inside dynamically linked executables/libraries, and are often
    -- loaded lazily.  We just use the eager AbsoluteRelocation here.
    X86_64_RelocationType
Elf.R_X86_64_GLOB_DAT -> do
      SymbolIdentifier
sym <- SymbolTable 64 -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable 64
symtab (RelEntry X86_64_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry X86_64_RelocationType
rel)
      Relocation 64 -> SymbolResolver (Relocation 64)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation 64 -> SymbolResolver (Relocation 64))
-> Relocation 64 -> SymbolResolver (Relocation 64)
forall a b. (a -> b) -> a -> b
$ Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
sym
                        , relocationOffset :: MemWord 64
relocationOffset     = MemWord 64
addend
                        , relocationIsRel :: Bool
relocationIsRel      = Bool
False
                        , relocationSize :: Int
relocationSize       = Int
8
                        , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                        , relocationEndianness :: Endianness
relocationEndianness = Endianness
LittleEndian
                        , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
False
                        }
    X86_64_RelocationType
Elf.R_X86_64_JUMP_SLOT -> do
      SymbolIdentifier
sym <- SymbolTable 64 -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable 64
symtab (RelEntry X86_64_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry X86_64_RelocationType
rel)
      Relocation 64 -> SymbolResolver (Relocation 64)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation 64 -> SymbolResolver (Relocation 64))
-> Relocation 64 -> SymbolResolver (Relocation 64)
forall a b. (a -> b) -> a -> b
$ Relocation { relocationSym :: SymbolIdentifier
relocationSym = SymbolIdentifier
sym
                        , relocationOffset :: MemWord 64
relocationOffset = MemWord 64
addend
                        , relocationIsRel :: Bool
relocationIsRel = Bool
False
                        , relocationSize :: Int
relocationSize  = Int
8
                        , relocationIsSigned :: Bool
relocationIsSigned = Bool
False
                        , relocationEndianness :: Endianness
relocationEndianness = Endianness
LittleEndian
                        , relocationJumpSlot :: Bool
relocationJumpSlot = Bool
True
                        }
    X86_64_RelocationType
Elf.R_X86_64_RELATIVE -> do
      -- This relocation has the value B + A where
      -- - A is the addend for the relocation, and
      -- - B resolves to the difference between the
      --   address at which the segment defining the symbol was
      --   loaded and the address at which it was linked.
      --
      -- Since the address at which it was linked is a constant, we
      -- create a non-relative address but subtract the link address
      -- from the offset.

      -- Get the address at which it was linked so we can subtract from offset.
      let linktimeAddr :: RelocationWord X86_64_RelocationType
linktimeAddr = RelEntry X86_64_RelocationType
-> RelocationWord X86_64_RelocationType
forall tp. RelEntry tp -> RelocationWord tp
Elf.relAddr RelEntry X86_64_RelocationType
rel

      Bool -> SymbolResolver () -> SymbolResolver ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (RelEntry X86_64_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry X86_64_RelocationType
rel Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0) (SymbolResolver () -> SymbolResolver ())
-> SymbolResolver () -> SymbolResolver ()
forall a b. (a -> b) -> a -> b
$ do
        RelocationError -> SymbolResolver ()
forall a.
RelocationError
-> ExceptT RelocationError (State [MemLoadWarning]) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (RelocationError -> SymbolResolver ())
-> RelocationError -> SymbolResolver ()
forall a b. (a -> b) -> a -> b
$ Int -> RelocationError
RelocationBadSymbolIndex (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (RelEntry X86_64_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry X86_64_RelocationType
rel))
      Relocation 64 -> SymbolResolver (Relocation 64)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation 64 -> SymbolResolver (Relocation 64))
-> Relocation 64 -> SymbolResolver (Relocation 64)
forall a b. (a -> b) -> a -> b
$ Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
LoadBaseAddr
                        , relocationOffset :: MemWord 64
relocationOffset     = MemWord 64
addend MemWord 64 -> MemWord 64 -> MemWord 64
forall a. Num a => a -> a -> a
- Word64 -> MemWord 64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
RelocationWord X86_64_RelocationType
linktimeAddr
                        , relocationIsRel :: Bool
relocationIsRel      = Bool
False
                        , relocationSize :: Int
relocationSize       = Int
8
                        , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                        , relocationEndianness :: Endianness
relocationEndianness = Endianness
LittleEndian
                        , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
False
                        }
    X86_64_RelocationType
Elf.R_X86_64_32 -> do
      SymbolIdentifier
sym <- SymbolTable 64 -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable 64
symtab (RelEntry X86_64_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry X86_64_RelocationType
rel)
      Relocation 64 -> SymbolResolver (Relocation 64)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation 64 -> SymbolResolver (Relocation 64))
-> Relocation 64 -> SymbolResolver (Relocation 64)
forall a b. (a -> b) -> a -> b
$ Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
sym
                        , relocationOffset :: MemWord 64
relocationOffset     = MemWord 64
addend
                        , relocationIsRel :: Bool
relocationIsRel      = Bool
False
                        , relocationSize :: Int
relocationSize       = Int
4
                        , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                        , relocationEndianness :: Endianness
relocationEndianness = Endianness
LittleEndian
                        , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
False
                        }
    X86_64_RelocationType
Elf.R_X86_64_32S -> do
      SymbolIdentifier
sym <- SymbolTable 64 -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable 64
symtab (RelEntry X86_64_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry X86_64_RelocationType
rel)
      Relocation 64 -> SymbolResolver (Relocation 64)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation 64 -> SymbolResolver (Relocation 64))
-> Relocation 64 -> SymbolResolver (Relocation 64)
forall a b. (a -> b) -> a -> b
$ Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
sym
                        , relocationOffset :: MemWord 64
relocationOffset     = MemWord 64
addend
                        , relocationIsRel :: Bool
relocationIsRel      = Bool
False
                        , relocationSize :: Int
relocationSize       = Int
4
                        , relocationIsSigned :: Bool
relocationIsSigned   = Bool
True
                        , relocationEndianness :: Endianness
relocationEndianness = Endianness
LittleEndian
                        , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
False
                        }
    X86_64_RelocationType
Elf.R_X86_64_COPY -> do
      SymbolIdentifier
sym <- SymbolTable 64 -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable 64
symtab (RelEntry X86_64_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry X86_64_RelocationType
rel)
      Bool -> SymbolResolver () -> SymbolResolver ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (MemWord 64
addend MemWord 64 -> MemWord 64 -> Bool
forall a. Eq a => a -> a -> Bool
/= MemWord 64
0) (SymbolResolver () -> SymbolResolver ())
-> SymbolResolver () -> SymbolResolver ()
forall a b. (a -> b) -> a -> b
$ do
        RelocationError -> SymbolResolver ()
forall a.
RelocationError
-> ExceptT RelocationError (State [MemLoadWarning]) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (RelocationError -> SymbolResolver ())
-> RelocationError -> SymbolResolver ()
forall a b. (a -> b) -> a -> b
$ [Char] -> RelocationError
RelocationUnsupportedType (X86_64_RelocationType -> [Char]
forall a. Show a => a -> [Char]
show (RelEntry X86_64_RelocationType -> X86_64_RelocationType
forall tp. RelEntry tp -> tp
Elf.relType RelEntry X86_64_RelocationType
rel))
      Relocation 64 -> SymbolResolver (Relocation 64)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation 64 -> SymbolResolver (Relocation 64))
-> Relocation 64 -> SymbolResolver (Relocation 64)
forall a b. (a -> b) -> a -> b
$ Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
sym
                        , relocationOffset :: MemWord 64
relocationOffset     = MemWord 64
0
                        , relocationIsRel :: Bool
relocationIsRel      = Bool
False
                        , relocationSize :: Int
relocationSize       = Int
8
                        , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                        , relocationEndianness :: Endianness
relocationEndianness = Endianness
LittleEndian
                        , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
False
                        }
    -- Jhx Note. These will be needed to support thread local variables.
    --   Elf.R_X86_64_TPOFF32 -> undefined
    --   Elf.R_X86_64_GOTTPOFF -> undefined

    X86_64_RelocationType
tp -> RelocationError -> SymbolResolver (Relocation 64)
forall a.
RelocationError
-> ExceptT RelocationError (State [MemLoadWarning]) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (RelocationError -> SymbolResolver (Relocation 64))
-> RelocationError -> SymbolResolver (Relocation 64)
forall a b. (a -> b) -> a -> b
$ [Char] -> RelocationError
RelocationUnsupportedType (X86_64_RelocationType -> [Char]
forall a. Show a => a -> [Char]
show X86_64_RelocationType
tp)

-- | Generate an absolute 32-bit relocation.
relocARM32Abs :: Endianness
              -> SymbolTable 32 -- ^ Symbol table
              -> Elf.RelEntry Elf.ARM32_RelocationType -- ^ Relocation entry
              -> MemWord 32
              -> SymbolResolver (Relocation 32)
relocARM32Abs :: Endianness
-> SymbolTable 32
-> RelEntry ARM32_RelocationType
-> MemWord 32
-> SymbolResolver (Relocation 32)
relocARM32Abs Endianness
end SymbolTable 32
symtab RelEntry ARM32_RelocationType
rel MemWord 32
addend = do
  (SymtabEntry ByteString Word32
symEntry, SymbolVersion
ver) <- SymbolTable 32
-> Word32
-> SymbolResolver
     (SymtabEntry ByteString (ElfWordType 32), SymbolVersion)
forall (w :: Nat).
SymbolTable w
-> Word32
-> SymbolResolver
     (SymtabEntry ByteString (ElfWordType w), SymbolVersion)
resolveSymbol SymbolTable 32
symtab (RelEntry ARM32_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry ARM32_RelocationType
rel)
  SymbolIdentifier
sym <- SymtabEntry ByteString Word32
-> SymbolVersion -> SymbolResolver SymbolIdentifier
forall wtp.
SymtabEntry ByteString wtp
-> SymbolVersion -> SymbolResolver SymbolIdentifier
resolveSymbolId SymtabEntry ByteString Word32
symEntry SymbolVersion
ver
  -- These relocation relocations can apply to code or data, but we
  -- want to ensure relocations do not change the thumb bit
  -- of the symbol.
  Bool -> SymbolResolver () -> SymbolResolver ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (SymtabEntry ByteString Word32 -> ElfSymbolType
forall nm w. SymtabEntry nm w -> ElfSymbolType
Elf.steType SymtabEntry ByteString Word32
symEntry ElfSymbolType -> ElfSymbolType -> Bool
forall a. Eq a => a -> a -> Bool
== ElfSymbolType
Elf.STT_FUNC Bool -> Bool -> Bool
&& MemWord 32
addend MemWord 32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
0) (SymbolResolver () -> SymbolResolver ())
-> SymbolResolver () -> SymbolResolver ()
forall a b. (a -> b) -> a -> b
$ do
    let tp :: [Char]
tp = ARM32_RelocationType -> [Char]
forall a. Show a => a -> [Char]
show (RelEntry ARM32_RelocationType -> ARM32_RelocationType
forall tp. RelEntry tp -> tp
Elf.relType RelEntry ARM32_RelocationType
rel)
    let addr :: Integer
addr = Word32 -> Integer
forall a. Integral a => a -> Integer
toInteger (RelEntry ARM32_RelocationType
-> RelocationWord ARM32_RelocationType
forall tp. RelEntry tp -> RelocationWord tp
Elf.relAddr RelEntry ARM32_RelocationType
rel)
    RelocationError -> SymbolResolver ()
forall a.
RelocationError
-> ExceptT RelocationError (State [MemLoadWarning]) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (RelocationError -> SymbolResolver ())
-> RelocationError -> SymbolResolver ()
forall a b. (a -> b) -> a -> b
$
      [Char] -> Integer -> ByteString -> Integer -> RelocationError
RelocationEvenAddend [Char]
tp Integer
addr (SymtabEntry ByteString Word32 -> ByteString
forall nm w. SymtabEntry nm w -> nm
Elf.steName SymtabEntry ByteString Word32
symEntry) (MemWord 32 -> Integer
forall a. Integral a => a -> Integer
toInteger MemWord 32
addend)
  Relocation 32 -> SymbolResolver (Relocation 32)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation 32 -> SymbolResolver (Relocation 32))
-> Relocation 32 -> SymbolResolver (Relocation 32)
forall a b. (a -> b) -> a -> b
$! Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
sym
                     , relocationOffset :: MemWord 32
relocationOffset     = MemWord 32
addend
                     , relocationIsRel :: Bool
relocationIsRel      = Bool
False
                     , relocationSize :: Int
relocationSize       = Int
4
                     , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                     , relocationEndianness :: Endianness
relocationEndianness = Endianness
end
                     , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
False
                     }

-- | Attempt to resolve an X86_64 specific symbol.
relaTargetARM32 :: Endianness
                 -- ^ Endianness of relocations
                -> Maybe SegmentIndex
                -- ^ Index of segment for dynamic relocations
                -> SymbolTable 32 -- ^ Symbol table
                -> Elf.RelEntry Elf.ARM32_RelocationType -- ^ Relocation entry
                -> MemWord 32
                -- ^ Addend of symbol
                -> RelFlag
                -> SymbolResolver (Relocation 32)
relaTargetARM32 :: Endianness
-> Maybe Word16
-> SymbolTable 32
-> RelEntry ARM32_RelocationType
-> MemWord 32
-> RelFlag
-> SymbolResolver (Relocation 32)
relaTargetARM32 Endianness
end Maybe Word16
msegIndex SymbolTable 32
symtab RelEntry ARM32_RelocationType
rel MemWord 32
addend RelFlag
relFlag =
  case RelEntry ARM32_RelocationType -> ARM32_RelocationType
forall tp. RelEntry tp -> tp
Elf.relType RelEntry ARM32_RelocationType
rel of
    -- A static 32-bit absolute relocation
    ARM32_RelocationType
Elf.R_ARM_ABS32 -> do
      Endianness
-> SymbolTable 32
-> RelEntry ARM32_RelocationType
-> MemWord 32
-> SymbolResolver (Relocation 32)
relocARM32Abs Endianness
end SymbolTable 32
symtab RelEntry ARM32_RelocationType
rel MemWord 32
addend
    -- A dynamic 32-bit absolute relocation that typically applies to data.
    ARM32_RelocationType
Elf.R_ARM_GLOB_DAT -> do
      Endianness
-> SymbolTable 32
-> RelEntry ARM32_RelocationType
-> MemWord 32
-> SymbolResolver (Relocation 32)
relocARM32Abs Endianness
end SymbolTable 32
symtab RelEntry ARM32_RelocationType
rel MemWord 32
addend
    ARM32_RelocationType
Elf.R_ARM_RELATIVE -> do
      -- This relocation has the value B(S) + A where
      -- - A is the addend for the relocation, and
      -- - B(S) with S ≠ 0 resolves to the difference between the
      --   address at which the segment defining the symbol S was
      --   loaded and the address at which it was linked.
      --  - B(S) with S = 0 resolves to the difference between the
      --    address at which the segment being relocated was loaded
      --    and the address at which it was linked.
      --
      -- Since the address at which it was linked is a constant, we
      -- create a non-relative address but subtract the link address
      -- from the offset.

      -- Get the address at which it was linked so we can subtract from offset.
      let linktimeAddr :: RelocationWord ARM32_RelocationType
linktimeAddr = RelEntry ARM32_RelocationType
-> RelocationWord ARM32_RelocationType
forall tp. RelEntry tp -> RelocationWord tp
Elf.relAddr RelEntry ARM32_RelocationType
rel

      -- Resolve the symbol using the index in the relocation.
      SymbolIdentifier
sym <-
        if RelEntry ARM32_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry ARM32_RelocationType
rel Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0 then do
          case Maybe Word16
msegIndex of
            Maybe Word16
Nothing -> do
              RelocationError -> SymbolResolver SymbolIdentifier
forall a.
RelocationError
-> ExceptT RelocationError (State [MemLoadWarning]) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (RelocationError -> SymbolResolver SymbolIdentifier)
-> RelocationError -> SymbolResolver SymbolIdentifier
forall a b. (a -> b) -> a -> b
$ RelocationError
RelocationZeroSymbol
            Just Word16
idx ->
              SymbolIdentifier -> SymbolResolver SymbolIdentifier
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (SymbolIdentifier -> SymbolResolver SymbolIdentifier)
-> SymbolIdentifier -> SymbolResolver SymbolIdentifier
forall a b. (a -> b) -> a -> b
$! Word16 -> SymbolIdentifier
SegmentBaseAddr Word16
idx
        else do
          SymbolTable 32 -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable 32
symtab (RelEntry ARM32_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry ARM32_RelocationType
rel)
      Relocation 32 -> SymbolResolver (Relocation 32)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation 32 -> SymbolResolver (Relocation 32))
-> Relocation 32 -> SymbolResolver (Relocation 32)
forall a b. (a -> b) -> a -> b
$! Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
sym
                         , relocationOffset :: MemWord 32
relocationOffset     = MemWord 32
addend MemWord 32 -> MemWord 32 -> MemWord 32
forall a. Num a => a -> a -> a
- Word32 -> MemWord 32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
RelocationWord ARM32_RelocationType
linktimeAddr
                         , relocationIsRel :: Bool
relocationIsRel      = Bool
False
                         , relocationSize :: Int
relocationSize       = Int
4
                         , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                         , relocationEndianness :: Endianness
relocationEndianness = Endianness
end
                         , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
False
                         }
    ARM32_RelocationType
Elf.R_ARM_JUMP_SLOT -> do
      -- This is a PLT relocation
      SymbolIdentifier
sym <- SymbolTable 32 -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable 32
symtab (RelEntry ARM32_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry ARM32_RelocationType
rel)
      -- For rela entries, check that addend is 0
      -- N.B. Rel entries read from the target bits, and these typically point to the
      -- start of the PLT, but are otherwise ignored for relocation purposes.
      Bool -> SymbolResolver () -> SymbolResolver ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (RelFlag
relFlag RelFlag -> RelFlag -> Bool
forall a. Eq a => a -> a -> Bool
== RelFlag
IsRela Bool -> Bool -> Bool
&& MemWord 32
addend MemWord 32 -> MemWord 32 -> Bool
forall a. Eq a => a -> a -> Bool
/= MemWord 32
0) (SymbolResolver () -> SymbolResolver ())
-> SymbolResolver () -> SymbolResolver ()
forall a b. (a -> b) -> a -> b
$ do
        RelocationError -> SymbolResolver ()
forall a.
RelocationError
-> ExceptT RelocationError (State [MemLoadWarning]) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (RelocationError -> SymbolResolver ())
-> RelocationError -> SymbolResolver ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Integer -> SymbolIdentifier -> RelocationError
RelocationInvalidAddend (ARM32_RelocationType -> [Char]
forall a. Show a => a -> [Char]
show (RelEntry ARM32_RelocationType -> ARM32_RelocationType
forall tp. RelEntry tp -> tp
Elf.relType RelEntry ARM32_RelocationType
rel)) (MemWord 32 -> Integer
forall a. Integral a => a -> Integer
toInteger MemWord 32
addend) SymbolIdentifier
sym
      Relocation 32 -> SymbolResolver (Relocation 32)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation 32 -> SymbolResolver (Relocation 32))
-> Relocation 32 -> SymbolResolver (Relocation 32)
forall a b. (a -> b) -> a -> b
$! Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
sym
                         , relocationOffset :: MemWord 32
relocationOffset     = MemWord 32
0
                         , relocationIsRel :: Bool
relocationIsRel      = Bool
False
                         , relocationSize :: Int
relocationSize       = Int
4
                         , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                         , relocationEndianness :: Endianness
relocationEndianness = Endianness
end
                         , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
True
                         }
    ARM32_RelocationType
Elf.R_ARM_COPY -> do
      SymbolIdentifier
sym <- SymbolTable 32 -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable 32
symtab (RelEntry ARM32_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry ARM32_RelocationType
rel)
      Bool -> SymbolResolver () -> SymbolResolver ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (MemWord 32
addend MemWord 32 -> MemWord 32 -> Bool
forall a. Eq a => a -> a -> Bool
/= MemWord 32
0) (SymbolResolver () -> SymbolResolver ())
-> SymbolResolver () -> SymbolResolver ()
forall a b. (a -> b) -> a -> b
$ do
        RelocationError -> SymbolResolver ()
forall a.
RelocationError
-> ExceptT RelocationError (State [MemLoadWarning]) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (RelocationError -> SymbolResolver ())
-> RelocationError -> SymbolResolver ()
forall a b. (a -> b) -> a -> b
$ [Char] -> RelocationError
RelocationUnsupportedType (ARM32_RelocationType -> [Char]
forall a. Show a => a -> [Char]
show (RelEntry ARM32_RelocationType -> ARM32_RelocationType
forall tp. RelEntry tp -> tp
Elf.relType RelEntry ARM32_RelocationType
rel))
      Relocation 32 -> SymbolResolver (Relocation 32)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation 32 -> SymbolResolver (Relocation 32))
-> Relocation 32 -> SymbolResolver (Relocation 32)
forall a b. (a -> b) -> a -> b
$ Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
sym
                        , relocationOffset :: MemWord 32
relocationOffset     = MemWord 32
0
                        , relocationIsRel :: Bool
relocationIsRel      = Bool
False
                        , relocationSize :: Int
relocationSize       = Int
4
                        , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                        , relocationEndianness :: Endianness
relocationEndianness = Endianness
end
                        , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
False
                        }
    ARM32_RelocationType
tp -> do
      RelocationError -> SymbolResolver (Relocation 32)
forall a.
RelocationError
-> ExceptT RelocationError (State [MemLoadWarning]) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (RelocationError -> SymbolResolver (Relocation 32))
-> RelocationError -> SymbolResolver (Relocation 32)
forall a b. (a -> b) -> a -> b
$ [Char] -> RelocationError
RelocationUnsupportedType (ARM32_RelocationType -> [Char]
forall a. Show a => a -> [Char]
show ARM32_RelocationType
tp)



-- | Attempt to resolve an X86_64 specific symbol.
relaTargetARM64 :: Endianness
                   -- ^ Endianness of relocations
                -> Maybe SegmentIndex
                   -- ^ Index of segment for dynamic relocations
                -> SymbolTable 64 -- ^ Symbol table
                -> Elf.RelEntry Elf.AArch64_RelocationType -- ^ Relocaiton entry
                -> MemWord 64
                   -- ^ Addend of symbol
                -> RelFlag
                -> SymbolResolver (Relocation 64)
relaTargetARM64 :: Endianness
-> Maybe Word16
-> SymbolTable 64
-> RelEntry AArch64_RelocationType
-> MemWord 64
-> RelFlag
-> SymbolResolver (Relocation 64)
relaTargetARM64 Endianness
end Maybe Word16
msegIndex SymbolTable 64
symtab RelEntry AArch64_RelocationType
rel MemWord 64
addend RelFlag
relFlag =
  case RelEntry AArch64_RelocationType -> AArch64_RelocationType
forall tp. RelEntry tp -> tp
Elf.relType RelEntry AArch64_RelocationType
rel of
    AArch64_RelocationType
Elf.R_AARCH64_ABS64 -> do
      SymbolIdentifier
sym <- SymbolTable 64 -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable 64
symtab (RelEntry AArch64_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry AArch64_RelocationType
rel)
      Relocation 64 -> SymbolResolver (Relocation 64)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation 64 -> SymbolResolver (Relocation 64))
-> Relocation 64 -> SymbolResolver (Relocation 64)
forall a b. (a -> b) -> a -> b
$! Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
sym
                         , relocationOffset :: MemWord 64
relocationOffset     = MemWord 64
addend
                         , relocationIsRel :: Bool
relocationIsRel      = Bool
False
                         , relocationSize :: Int
relocationSize       = Int
8
                         , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                         , relocationEndianness :: Endianness
relocationEndianness = Endianness
end
                         , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
False
                         }
    AArch64_RelocationType
Elf.R_AARCH64_GLOB_DAT -> do
      SymbolIdentifier
sym <- SymbolTable 64 -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable 64
symtab (RelEntry AArch64_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry AArch64_RelocationType
rel)
      Relocation 64 -> SymbolResolver (Relocation 64)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation 64 -> SymbolResolver (Relocation 64))
-> Relocation 64 -> SymbolResolver (Relocation 64)
forall a b. (a -> b) -> a -> b
$! Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
sym
                         , relocationOffset :: MemWord 64
relocationOffset     = MemWord 64
addend
                         , relocationIsRel :: Bool
relocationIsRel      = Bool
False
                         , relocationSize :: Int
relocationSize       = Int
8
                         , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                         , relocationEndianness :: Endianness
relocationEndianness = Endianness
end
                         , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
False
                         }
    AArch64_RelocationType
Elf.R_AARCH64_RELATIVE -> do
      -- This relocation has the value B(S) + A where
      -- - A is the addend for the relocation, and
      -- - B(S) with S ≠ 0 resolves to the difference between the
      --   address at which the segment defining the symbol S was
      --   loaded and the address at which it was linked.
      --  - B(S) with S = 0 resolves to the difference between the
      --    address at which the segment being relocated was loaded
      --    and the address at which it was linked.
      --
      -- Since the address at which it was linked is a constant, we
      -- create a non-relative address but subtract the link address
      -- from the offset.

      -- Get the address at which it was linked so we can subtract from offset.
      let linktimeAddr :: RelocationWord AArch64_RelocationType
linktimeAddr = RelEntry AArch64_RelocationType
-> RelocationWord AArch64_RelocationType
forall tp. RelEntry tp -> RelocationWord tp
Elf.relAddr RelEntry AArch64_RelocationType
rel

      -- Resolve the symbol using the index in the relocation.
      SymbolIdentifier
sym <-
        if RelEntry AArch64_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry AArch64_RelocationType
rel Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0 then do
          case Maybe Word16
msegIndex of
            Maybe Word16
Nothing -> do
              RelocationError -> SymbolResolver SymbolIdentifier
forall a.
RelocationError
-> ExceptT RelocationError (State [MemLoadWarning]) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (RelocationError -> SymbolResolver SymbolIdentifier)
-> RelocationError -> SymbolResolver SymbolIdentifier
forall a b. (a -> b) -> a -> b
$ RelocationError
RelocationZeroSymbol
            Just Word16
idx ->
              SymbolIdentifier -> SymbolResolver SymbolIdentifier
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (SymbolIdentifier -> SymbolResolver SymbolIdentifier)
-> SymbolIdentifier -> SymbolResolver SymbolIdentifier
forall a b. (a -> b) -> a -> b
$! Word16 -> SymbolIdentifier
SegmentBaseAddr Word16
idx
        else do
          SymbolTable 64 -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable 64
symtab (RelEntry AArch64_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry AArch64_RelocationType
rel)
      Relocation 64 -> SymbolResolver (Relocation 64)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation 64 -> SymbolResolver (Relocation 64))
-> Relocation 64 -> SymbolResolver (Relocation 64)
forall a b. (a -> b) -> a -> b
$! Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
sym
                         , relocationOffset :: MemWord 64
relocationOffset     = MemWord 64
addend MemWord 64 -> MemWord 64 -> MemWord 64
forall a. Num a => a -> a -> a
- Word64 -> MemWord 64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
RelocationWord AArch64_RelocationType
linktimeAddr
                         , relocationIsRel :: Bool
relocationIsRel      = Bool
False
                         , relocationSize :: Int
relocationSize       = Int
8
                         , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                         , relocationEndianness :: Endianness
relocationEndianness = Endianness
end
                         , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
False
                         }

    AArch64_RelocationType
Elf.R_AARCH64_JUMP_SLOT -> do
      -- This is a PLT relocation
      SymbolIdentifier
sym <- SymbolTable 64 -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable 64
symtab (RelEntry AArch64_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry AArch64_RelocationType
rel)
      -- For rela entries, check that addend is 0
      -- N.B. Rel entries read from the target bits, and these typically point to the
      -- start of the PLT, but are otherwise ignored for relocation purposes.
      Bool -> SymbolResolver () -> SymbolResolver ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (RelFlag
relFlag RelFlag -> RelFlag -> Bool
forall a. Eq a => a -> a -> Bool
== RelFlag
IsRela Bool -> Bool -> Bool
&& MemWord 64
addend MemWord 64 -> MemWord 64 -> Bool
forall a. Eq a => a -> a -> Bool
/= MemWord 64
0) (SymbolResolver () -> SymbolResolver ())
-> SymbolResolver () -> SymbolResolver ()
forall a b. (a -> b) -> a -> b
$ do
        RelocationError -> SymbolResolver ()
forall a.
RelocationError
-> ExceptT RelocationError (State [MemLoadWarning]) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (RelocationError -> SymbolResolver ())
-> RelocationError -> SymbolResolver ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Integer -> SymbolIdentifier -> RelocationError
RelocationInvalidAddend (AArch64_RelocationType -> [Char]
forall a. Show a => a -> [Char]
show (RelEntry AArch64_RelocationType -> AArch64_RelocationType
forall tp. RelEntry tp -> tp
Elf.relType RelEntry AArch64_RelocationType
rel)) (MemWord 64 -> Integer
forall a. Integral a => a -> Integer
toInteger MemWord 64
addend) SymbolIdentifier
sym
      Relocation 64 -> SymbolResolver (Relocation 64)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation 64 -> SymbolResolver (Relocation 64))
-> Relocation 64 -> SymbolResolver (Relocation 64)
forall a b. (a -> b) -> a -> b
$! Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
sym
                         , relocationOffset :: MemWord 64
relocationOffset     = MemWord 64
0
                         , relocationIsRel :: Bool
relocationIsRel      = Bool
False
                         , relocationSize :: Int
relocationSize       = Int
8
                         , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                         , relocationEndianness :: Endianness
relocationEndianness = Endianness
end
                         , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
True
                         }
    AArch64_RelocationType
tp -> do
      RelocationError -> SymbolResolver (Relocation 64)
forall a.
RelocationError
-> ExceptT RelocationError (State [MemLoadWarning]) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (RelocationError -> SymbolResolver (Relocation 64))
-> RelocationError -> SymbolResolver (Relocation 64)
forall a b. (a -> b) -> a -> b
$ [Char] -> RelocationError
RelocationUnsupportedType (AArch64_RelocationType -> [Char]
forall a. Show a => a -> [Char]
show AArch64_RelocationType
tp)

-- | Attempt to resolve a PPC32-specific symbol.
relaTargetPPC32 :: Endianness
                -- ^ Endianness of relocations
                -> Maybe SegmentIndex
                -- ^ Index of segment for dynamic relocations
                -> SymbolTable 32 -- ^ Symbol table
                -> Elf.RelEntry Elf.PPC32_RelocationType -- ^ Relocation entry
                -> MemWord 32
                -- ^ Addend of symbol
                -> RelFlag
                -> SymbolResolver (Relocation 32)
relaTargetPPC32 :: Endianness
-> Maybe Word16
-> SymbolTable 32
-> RelEntry PPC32_RelocationType
-> MemWord 32
-> RelFlag
-> SymbolResolver (Relocation 32)
relaTargetPPC32 Endianness
end Maybe Word16
msegIndex SymbolTable 32
symtab RelEntry PPC32_RelocationType
rel MemWord 32
addend RelFlag
_relFlag =
  case RelEntry PPC32_RelocationType -> PPC32_RelocationType
forall tp. RelEntry tp -> tp
Elf.relType RelEntry PPC32_RelocationType
rel of
    PPC32_RelocationType
Elf.R_PPC_ADDR32 -> do
      SymbolIdentifier
sym <- SymbolTable 32 -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable 32
symtab (RelEntry PPC32_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry PPC32_RelocationType
rel)
      Relocation 32 -> SymbolResolver (Relocation 32)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation 32 -> SymbolResolver (Relocation 32))
-> Relocation 32 -> SymbolResolver (Relocation 32)
forall a b. (a -> b) -> a -> b
$! Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
sym
                         , relocationOffset :: MemWord 32
relocationOffset     = MemWord 32
addend
                         , relocationIsRel :: Bool
relocationIsRel      = Bool
False
                         , relocationSize :: Int
relocationSize       = Int
4
                         , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                         , relocationEndianness :: Endianness
relocationEndianness = Endianness
end
                         , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
False
                         }
    PPC32_RelocationType
Elf.R_PPC_GLOB_DAT -> do
      SymbolIdentifier
sym <- SymbolTable 32 -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable 32
symtab (RelEntry PPC32_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry PPC32_RelocationType
rel)
      Relocation 32 -> SymbolResolver (Relocation 32)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation 32 -> SymbolResolver (Relocation 32))
-> Relocation 32 -> SymbolResolver (Relocation 32)
forall a b. (a -> b) -> a -> b
$! Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
sym
                         , relocationOffset :: MemWord 32
relocationOffset     = MemWord 32
addend
                         , relocationIsRel :: Bool
relocationIsRel      = Bool
False
                         , relocationSize :: Int
relocationSize       = Int
4
                         , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                         , relocationEndianness :: Endianness
relocationEndianness = Endianness
end
                         , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
False
                         }
    PPC32_RelocationType
Elf.R_PPC_RELATIVE -> do
      -- This relocation has the value B + A where
      -- - A is the addend for the relocation, and
      -- - B resolves to the difference between the
      --   address at which the segment defining the symbol was
      --   loaded and the address at which it was linked.
      --
      -- Since the address at which it was linked is a constant, we
      -- create a non-relative address but subtract the link address
      -- from the offset.

      -- Get the address at which it was linked so we can subtract from offset.
      let linktimeAddr :: RelocationWord PPC32_RelocationType
linktimeAddr = RelEntry PPC32_RelocationType
-> RelocationWord PPC32_RelocationType
forall tp. RelEntry tp -> RelocationWord tp
Elf.relAddr RelEntry PPC32_RelocationType
rel

      -- Resolve the symbol using the index in the relocation.
      SymbolIdentifier
sym <-
        if RelEntry PPC32_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry PPC32_RelocationType
rel Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0 then do
          case Maybe Word16
msegIndex of
            Maybe Word16
Nothing -> do
              RelocationError -> SymbolResolver SymbolIdentifier
forall a.
RelocationError
-> ExceptT RelocationError (State [MemLoadWarning]) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (RelocationError -> SymbolResolver SymbolIdentifier)
-> RelocationError -> SymbolResolver SymbolIdentifier
forall a b. (a -> b) -> a -> b
$ RelocationError
RelocationZeroSymbol
            Just Word16
idx ->
              SymbolIdentifier -> SymbolResolver SymbolIdentifier
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (SymbolIdentifier -> SymbolResolver SymbolIdentifier)
-> SymbolIdentifier -> SymbolResolver SymbolIdentifier
forall a b. (a -> b) -> a -> b
$! Word16 -> SymbolIdentifier
SegmentBaseAddr Word16
idx
        else do
          SymbolTable 32 -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable 32
symtab (RelEntry PPC32_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry PPC32_RelocationType
rel)
      Relocation 32 -> SymbolResolver (Relocation 32)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation 32 -> SymbolResolver (Relocation 32))
-> Relocation 32 -> SymbolResolver (Relocation 32)
forall a b. (a -> b) -> a -> b
$! Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
sym
                         , relocationOffset :: MemWord 32
relocationOffset     = MemWord 32
addend MemWord 32 -> MemWord 32 -> MemWord 32
forall a. Num a => a -> a -> a
- Word32 -> MemWord 32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
RelocationWord PPC32_RelocationType
linktimeAddr
                         , relocationIsRel :: Bool
relocationIsRel      = Bool
False
                         , relocationSize :: Int
relocationSize       = Int
4
                         , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                         , relocationEndianness :: Endianness
relocationEndianness = Endianness
end
                         , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
False
                         }
    PPC32_RelocationType
Elf.R_PPC_JMP_SLOT -> do
      -- This is a PLT relocation
      SymbolIdentifier
sym <- SymbolTable 32 -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable 32
symtab (RelEntry PPC32_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry PPC32_RelocationType
rel)
      Relocation 32 -> SymbolResolver (Relocation 32)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation 32 -> SymbolResolver (Relocation 32))
-> Relocation 32 -> SymbolResolver (Relocation 32)
forall a b. (a -> b) -> a -> b
$! Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
sym
                         , relocationOffset :: MemWord 32
relocationOffset     = MemWord 32
addend
                         , relocationIsRel :: Bool
relocationIsRel      = Bool
False
                         , relocationSize :: Int
relocationSize       = Int
4
                         , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                         , relocationEndianness :: Endianness
relocationEndianness = Endianness
end
                         , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
True
                         }
    PPC32_RelocationType
tp ->
      RelocationError -> SymbolResolver (Relocation 32)
forall a.
RelocationError
-> ExceptT RelocationError (State [MemLoadWarning]) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (RelocationError -> SymbolResolver (Relocation 32))
-> RelocationError -> SymbolResolver (Relocation 32)
forall a b. (a -> b) -> a -> b
$ [Char] -> RelocationError
RelocationUnsupportedType (PPC32_RelocationType -> [Char]
forall a. Show a => a -> [Char]
show PPC32_RelocationType
tp)

-- | Attempt to resolve a PPC64-specific symbol.
relaTargetPPC64 :: Endianness
                -- ^ Endianness of relocations
                -> Maybe SegmentIndex
                -- ^ Index of segment for dynamic relocations
                -> SymbolTable 64 -- ^ Symbol table
                -> Elf.RelEntry Elf.PPC64_RelocationType -- ^ Relocation entry
                -> MemWord 64
                -- ^ Addend of symbol
                -> RelFlag
                -> SymbolResolver (Relocation 64)
relaTargetPPC64 :: Endianness
-> Maybe Word16
-> SymbolTable 64
-> RelEntry PPC64_RelocationType
-> MemWord 64
-> RelFlag
-> SymbolResolver (Relocation 64)
relaTargetPPC64 Endianness
end Maybe Word16
msegIndex SymbolTable 64
symtab RelEntry PPC64_RelocationType
rel MemWord 64
addend RelFlag
_relFlag =
  case RelEntry PPC64_RelocationType -> PPC64_RelocationType
forall tp. RelEntry tp -> tp
Elf.relType RelEntry PPC64_RelocationType
rel of
    PPC64_RelocationType
Elf.R_PPC64_ADDR64 -> do
      SymbolIdentifier
sym <- SymbolTable 64 -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable 64
symtab (RelEntry PPC64_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry PPC64_RelocationType
rel)
      Relocation 64 -> SymbolResolver (Relocation 64)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation 64 -> SymbolResolver (Relocation 64))
-> Relocation 64 -> SymbolResolver (Relocation 64)
forall a b. (a -> b) -> a -> b
$! Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
sym
                         , relocationOffset :: MemWord 64
relocationOffset     = MemWord 64
addend
                         , relocationIsRel :: Bool
relocationIsRel      = Bool
False
                         , relocationSize :: Int
relocationSize       = Int
8
                         , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                         , relocationEndianness :: Endianness
relocationEndianness = Endianness
end
                         , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
False
                         }
    PPC64_RelocationType
Elf.R_PPC64_GLOB_DAT -> do
      SymbolIdentifier
sym <- SymbolTable 64 -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable 64
symtab (RelEntry PPC64_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry PPC64_RelocationType
rel)
      Relocation 64 -> SymbolResolver (Relocation 64)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation 64 -> SymbolResolver (Relocation 64))
-> Relocation 64 -> SymbolResolver (Relocation 64)
forall a b. (a -> b) -> a -> b
$! Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
sym
                         , relocationOffset :: MemWord 64
relocationOffset     = MemWord 64
addend
                         , relocationIsRel :: Bool
relocationIsRel      = Bool
False
                         , relocationSize :: Int
relocationSize       = Int
8
                         , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                         , relocationEndianness :: Endianness
relocationEndianness = Endianness
end
                         , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
False
                         }
    PPC64_RelocationType
Elf.R_PPC64_RELATIVE -> do
      -- This relocation has the value B + A where
      -- - A is the addend for the relocation, and
      -- - B resolves to the difference between the
      --   address at which the segment defining the symbol was
      --   loaded and the address at which it was linked.
      --
      -- Since the address at which it was linked is a constant, we
      -- create a non-relative address but subtract the link address
      -- from the offset.

      -- Get the address at which it was linked so we can subtract from offset.
      let linktimeAddr :: RelocationWord PPC64_RelocationType
linktimeAddr = RelEntry PPC64_RelocationType
-> RelocationWord PPC64_RelocationType
forall tp. RelEntry tp -> RelocationWord tp
Elf.relAddr RelEntry PPC64_RelocationType
rel

      -- Resolve the symbol using the index in the relocation.
      SymbolIdentifier
sym <-
        if RelEntry PPC64_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry PPC64_RelocationType
rel Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0 then do
          case Maybe Word16
msegIndex of
            Maybe Word16
Nothing -> do
              RelocationError -> SymbolResolver SymbolIdentifier
forall a.
RelocationError
-> ExceptT RelocationError (State [MemLoadWarning]) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (RelocationError -> SymbolResolver SymbolIdentifier)
-> RelocationError -> SymbolResolver SymbolIdentifier
forall a b. (a -> b) -> a -> b
$ RelocationError
RelocationZeroSymbol
            Just Word16
idx ->
              SymbolIdentifier -> SymbolResolver SymbolIdentifier
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (SymbolIdentifier -> SymbolResolver SymbolIdentifier)
-> SymbolIdentifier -> SymbolResolver SymbolIdentifier
forall a b. (a -> b) -> a -> b
$! Word16 -> SymbolIdentifier
SegmentBaseAddr Word16
idx
        else do
          SymbolTable 64 -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable 64
symtab (RelEntry PPC64_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry PPC64_RelocationType
rel)
      Relocation 64 -> SymbolResolver (Relocation 64)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation 64 -> SymbolResolver (Relocation 64))
-> Relocation 64 -> SymbolResolver (Relocation 64)
forall a b. (a -> b) -> a -> b
$! Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
sym
                         , relocationOffset :: MemWord 64
relocationOffset     = MemWord 64
addend MemWord 64 -> MemWord 64 -> MemWord 64
forall a. Num a => a -> a -> a
- Word64 -> MemWord 64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
RelocationWord PPC64_RelocationType
linktimeAddr
                         , relocationIsRel :: Bool
relocationIsRel      = Bool
False
                         , relocationSize :: Int
relocationSize       = Int
8
                         , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                         , relocationEndianness :: Endianness
relocationEndianness = Endianness
end
                         , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
False
                         }
    PPC64_RelocationType
Elf.R_PPC64_JMP_SLOT -> do
      -- This is a PLT relocation
      SymbolIdentifier
sym <- SymbolTable 64 -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable 64
symtab (RelEntry PPC64_RelocationType -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry PPC64_RelocationType
rel)
      Relocation 64 -> SymbolResolver (Relocation 64)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation 64 -> SymbolResolver (Relocation 64))
-> Relocation 64 -> SymbolResolver (Relocation 64)
forall a b. (a -> b) -> a -> b
$! Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
sym
                         , relocationOffset :: MemWord 64
relocationOffset     = MemWord 64
addend
                         , relocationIsRel :: Bool
relocationIsRel      = Bool
False
                         , relocationSize :: Int
relocationSize       = Int
8
                         , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                         , relocationEndianness :: Endianness
relocationEndianness = Endianness
end
                         , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
True
                         }
    PPC64_RelocationType
tp ->
      RelocationError -> SymbolResolver (Relocation 64)
forall a.
RelocationError
-> ExceptT RelocationError (State [MemLoadWarning]) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (RelocationError -> SymbolResolver (Relocation 64))
-> RelocationError -> SymbolResolver (Relocation 64)
forall a b. (a -> b) -> a -> b
$ [Char] -> RelocationError
RelocationUnsupportedType (PPC64_RelocationType -> [Char]
forall a. Show a => a -> [Char]
show PPC64_RelocationType
tp)

-- | Attempt to resolve a RISC-V–specific symbol.
relaTargetRISCV :: forall w
                 . (ElfWidthConstraints w, KnownNat w, MemWidth w)
                => Endianness
                -- ^ Endianness of relocations
                -> Maybe SegmentIndex
                -- ^ Index of segment for dynamic relocations
                -> SymbolTable w -- ^ Symbol table
                -> Elf.RelEntry (Elf.RISCV_RelocationType w) -- ^ Relocation entry
                -> MemWord w
                -- ^ Addend of symbol
                -> RelFlag
                -> SymbolResolver (Relocation w)
relaTargetRISCV :: forall (w :: Nat).
(ElfWidthConstraints w, KnownNat w, MemWidth w) =>
Endianness
-> Maybe Word16
-> SymbolTable w
-> RelEntry (RISCV_RelocationType w)
-> MemWord w
-> RelFlag
-> SymbolResolver (Relocation w)
relaTargetRISCV Endianness
end Maybe Word16
msegIndex SymbolTable w
symtab RelEntry (RISCV_RelocationType w)
rel MemWord w
addend RelFlag
_relFlag =
  let wordSize :: Int
      wordSize :: Int
wordSize = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Proxy w -> Integer
forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Integer
natVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @w) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
8 in
  case RelEntry (RISCV_RelocationType w) -> RISCV_RelocationType w
forall tp. RelEntry tp -> tp
Elf.relType RelEntry (RISCV_RelocationType w)
rel of
    RISCV_RelocationType w
Elf.R_RISCV_32 -> do
      SymbolIdentifier
sym <- SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable w
symtab (RelEntry (RISCV_RelocationType w) -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry (RISCV_RelocationType w)
rel)
      Relocation w -> SymbolResolver (Relocation w)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation w -> SymbolResolver (Relocation w))
-> Relocation w -> SymbolResolver (Relocation w)
forall a b. (a -> b) -> a -> b
$! Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
sym
                         , relocationOffset :: MemWord w
relocationOffset     = MemWord w
addend
                         , relocationIsRel :: Bool
relocationIsRel      = Bool
False
                         , relocationSize :: Int
relocationSize       = Int
4
                         , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                         , relocationEndianness :: Endianness
relocationEndianness = Endianness
end
                         , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
False
                         }
    RISCV_RelocationType w
Elf.R_RISCV_64 -> do
      SymbolIdentifier
sym <- SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable w
symtab (RelEntry (RISCV_RelocationType w) -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry (RISCV_RelocationType w)
rel)
      Relocation w -> SymbolResolver (Relocation w)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation w -> SymbolResolver (Relocation w))
-> Relocation w -> SymbolResolver (Relocation w)
forall a b. (a -> b) -> a -> b
$! Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
sym
                         , relocationOffset :: MemWord w
relocationOffset     = MemWord w
addend
                         , relocationIsRel :: Bool
relocationIsRel      = Bool
False
                         , relocationSize :: Int
relocationSize       = Int
8
                         , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                         , relocationEndianness :: Endianness
relocationEndianness = Endianness
end
                         , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
False
                         }
    RISCV_RelocationType w
Elf.R_RISCV_RELATIVE -> do
      -- This relocation has the value B + A where
      -- - A is the addend for the relocation, and
      -- - B resolves to the difference between the
      --   address at which the segment defining the symbol was
      --   loaded and the address at which it was linked.
      --
      -- Since the address at which it was linked is a constant, we
      -- create a non-relative address but subtract the link address
      -- from the offset.

      -- Get the address at which it was linked so we can subtract from offset.
      let linktimeAddr :: RelocationWord (RISCV_RelocationType w)
linktimeAddr = RelEntry (RISCV_RelocationType w)
-> RelocationWord (RISCV_RelocationType w)
forall tp. RelEntry tp -> RelocationWord tp
Elf.relAddr RelEntry (RISCV_RelocationType w)
rel

      -- Resolve the symbol using the index in the relocation.
      SymbolIdentifier
sym <-
        if RelEntry (RISCV_RelocationType w) -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry (RISCV_RelocationType w)
rel Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0 then do
          case Maybe Word16
msegIndex of
            Maybe Word16
Nothing -> do
              RelocationError -> SymbolResolver SymbolIdentifier
forall a.
RelocationError
-> ExceptT RelocationError (State [MemLoadWarning]) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (RelocationError -> SymbolResolver SymbolIdentifier)
-> RelocationError -> SymbolResolver SymbolIdentifier
forall a b. (a -> b) -> a -> b
$ RelocationError
RelocationZeroSymbol
            Just Word16
idx ->
              SymbolIdentifier -> SymbolResolver SymbolIdentifier
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (SymbolIdentifier -> SymbolResolver SymbolIdentifier)
-> SymbolIdentifier -> SymbolResolver SymbolIdentifier
forall a b. (a -> b) -> a -> b
$! Word16 -> SymbolIdentifier
SegmentBaseAddr Word16
idx
        else do
          SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable w
symtab (RelEntry (RISCV_RelocationType w) -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry (RISCV_RelocationType w)
rel)
      Relocation w -> SymbolResolver (Relocation w)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation w -> SymbolResolver (Relocation w))
-> Relocation w -> SymbolResolver (Relocation w)
forall a b. (a -> b) -> a -> b
$! Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
sym
                         , relocationOffset :: MemWord w
relocationOffset     = MemWord w
addend MemWord w -> MemWord w -> MemWord w
forall a. Num a => a -> a -> a
- ElfWordType w -> MemWord w
forall a b. (Integral a, Num b) => a -> b
fromIntegral ElfWordType w
RelocationWord (RISCV_RelocationType w)
linktimeAddr
                         , relocationIsRel :: Bool
relocationIsRel      = Bool
False
                         , relocationSize :: Int
relocationSize       = Int
wordSize
                         , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                         , relocationEndianness :: Endianness
relocationEndianness = Endianness
end
                         , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
False
                         }
    RISCV_RelocationType w
Elf.R_RISCV_JUMP_SLOT -> do
      -- This is a PLT relocation
      SymbolIdentifier
sym <- SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
forall (w :: Nat).
SymbolTable w -> Word32 -> SymbolResolver SymbolIdentifier
resolveRelocationSym SymbolTable w
symtab (RelEntry (RISCV_RelocationType w) -> Word32
forall tp. RelEntry tp -> Word32
Elf.relSym RelEntry (RISCV_RelocationType w)
rel)
      Relocation w -> SymbolResolver (Relocation w)
forall a. a -> ExceptT RelocationError (State [MemLoadWarning]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Relocation w -> SymbolResolver (Relocation w))
-> Relocation w -> SymbolResolver (Relocation w)
forall a b. (a -> b) -> a -> b
$! Relocation { relocationSym :: SymbolIdentifier
relocationSym        = SymbolIdentifier
sym
                         , relocationOffset :: MemWord w
relocationOffset     = MemWord w
addend
                         , relocationIsRel :: Bool
relocationIsRel      = Bool
False
                         , relocationSize :: Int
relocationSize       = Int
wordSize
                         , relocationIsSigned :: Bool
relocationIsSigned   = Bool
False
                         , relocationEndianness :: Endianness
relocationEndianness = Endianness
end
                         , relocationJumpSlot :: Bool
relocationJumpSlot   = Bool
True
                         }
    RISCV_RelocationType w
tp ->
      RelocationError -> SymbolResolver (Relocation w)
forall a.
RelocationError
-> ExceptT RelocationError (State [MemLoadWarning]) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (RelocationError -> SymbolResolver (Relocation w))
-> RelocationError -> SymbolResolver (Relocation w)
forall a b. (a -> b) -> a -> b
$ [Char] -> RelocationError
RelocationUnsupportedType (RISCV_RelocationType w -> [Char]
forall a. Show a => a -> [Char]
show RISCV_RelocationType w
tp)

toEndianness :: Elf.ElfData -> Endianness
toEndianness :: ElfData -> Endianness
toEndianness ElfData
Elf.ELFDATA2LSB = Endianness
LittleEndian
toEndianness ElfData
Elf.ELFDATA2MSB = Endianness
BigEndian

-- | Creates a relocation map from the contents of a dynamic section.
getRelocationResolver
  :: forall w
  .  Elf.ElfHeader w
  -> MemLoader w (SomeRelocationResolver w)
getRelocationResolver :: forall (w :: Nat).
ElfHeader w -> MemLoader w (SomeRelocationResolver w)
getRelocationResolver ElfHeader w
hdr =
  case (ElfHeader w -> ElfClass w
forall (w :: Nat). ElfHeader w -> ElfClass w
Elf.headerClass ElfHeader w
hdr, ElfHeader w -> ElfMachine
forall (w :: Nat). ElfHeader w -> ElfMachine
Elf.headerMachine ElfHeader w
hdr) of
    (ElfClass w
Elf.ELFCLASS64, ElfMachine
Elf.EM_X86_64) ->
      SomeRelocationResolver w -> MemLoader w (SomeRelocationResolver w)
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (SomeRelocationResolver w
 -> MemLoader w (SomeRelocationResolver w))
-> SomeRelocationResolver w
-> MemLoader w (SomeRelocationResolver w)
forall a b. (a -> b) -> a -> b
$ RelocationResolver X86_64_RelocationType
-> SomeRelocationResolver w
forall (w :: Nat) tp.
(IsRelocationType tp, w ~ RelocationWidth tp) =>
RelocationResolver tp -> SomeRelocationResolver w
SomeRelocationResolver Maybe Word16
-> SymbolTable 64
-> RelEntry X86_64_RelocationType
-> MemWord 64
-> RelFlag
-> SymbolResolver (Relocation 64)
RelocationResolver X86_64_RelocationType
relaTargetX86_64
    (ElfClass w
Elf.ELFCLASS32, ElfMachine
Elf.EM_ARM) ->
      SomeRelocationResolver w -> MemLoader w (SomeRelocationResolver w)
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (SomeRelocationResolver w
 -> MemLoader w (SomeRelocationResolver w))
-> SomeRelocationResolver w
-> MemLoader w (SomeRelocationResolver w)
forall a b. (a -> b) -> a -> b
$ RelocationResolver ARM32_RelocationType -> SomeRelocationResolver w
forall (w :: Nat) tp.
(IsRelocationType tp, w ~ RelocationWidth tp) =>
RelocationResolver tp -> SomeRelocationResolver w
SomeRelocationResolver (RelocationResolver ARM32_RelocationType
 -> SomeRelocationResolver w)
-> RelocationResolver ARM32_RelocationType
-> SomeRelocationResolver w
forall a b. (a -> b) -> a -> b
$ Endianness
-> Maybe Word16
-> SymbolTable 32
-> RelEntry ARM32_RelocationType
-> MemWord 32
-> RelFlag
-> SymbolResolver (Relocation 32)
relaTargetARM32 Endianness
end
    (ElfClass w
Elf.ELFCLASS64, ElfMachine
Elf.EM_AARCH64) ->
      SomeRelocationResolver w -> MemLoader w (SomeRelocationResolver w)
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (SomeRelocationResolver w
 -> MemLoader w (SomeRelocationResolver w))
-> SomeRelocationResolver w
-> MemLoader w (SomeRelocationResolver w)
forall a b. (a -> b) -> a -> b
$ RelocationResolver AArch64_RelocationType
-> SomeRelocationResolver w
forall (w :: Nat) tp.
(IsRelocationType tp, w ~ RelocationWidth tp) =>
RelocationResolver tp -> SomeRelocationResolver w
SomeRelocationResolver (RelocationResolver AArch64_RelocationType
 -> SomeRelocationResolver w)
-> RelocationResolver AArch64_RelocationType
-> SomeRelocationResolver w
forall a b. (a -> b) -> a -> b
$ Endianness
-> Maybe Word16
-> SymbolTable 64
-> RelEntry AArch64_RelocationType
-> MemWord 64
-> RelFlag
-> SymbolResolver (Relocation 64)
relaTargetARM64 Endianness
end
    (ElfClass w
Elf.ELFCLASS32, ElfMachine
Elf.EM_PPC) ->
      SomeRelocationResolver w -> MemLoader w (SomeRelocationResolver w)
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (SomeRelocationResolver w
 -> MemLoader w (SomeRelocationResolver w))
-> SomeRelocationResolver w
-> MemLoader w (SomeRelocationResolver w)
forall a b. (a -> b) -> a -> b
$ RelocationResolver PPC32_RelocationType -> SomeRelocationResolver w
forall (w :: Nat) tp.
(IsRelocationType tp, w ~ RelocationWidth tp) =>
RelocationResolver tp -> SomeRelocationResolver w
SomeRelocationResolver (RelocationResolver PPC32_RelocationType
 -> SomeRelocationResolver w)
-> RelocationResolver PPC32_RelocationType
-> SomeRelocationResolver w
forall a b. (a -> b) -> a -> b
$ Endianness
-> Maybe Word16
-> SymbolTable 32
-> RelEntry PPC32_RelocationType
-> MemWord 32
-> RelFlag
-> SymbolResolver (Relocation 32)
relaTargetPPC32 Endianness
end
    (ElfClass w
Elf.ELFCLASS64, ElfMachine
Elf.EM_PPC64) ->
      SomeRelocationResolver w -> MemLoader w (SomeRelocationResolver w)
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (SomeRelocationResolver w
 -> MemLoader w (SomeRelocationResolver w))
-> SomeRelocationResolver w
-> MemLoader w (SomeRelocationResolver w)
forall a b. (a -> b) -> a -> b
$ RelocationResolver PPC64_RelocationType -> SomeRelocationResolver w
forall (w :: Nat) tp.
(IsRelocationType tp, w ~ RelocationWidth tp) =>
RelocationResolver tp -> SomeRelocationResolver w
SomeRelocationResolver (RelocationResolver PPC64_RelocationType
 -> SomeRelocationResolver w)
-> RelocationResolver PPC64_RelocationType
-> SomeRelocationResolver w
forall a b. (a -> b) -> a -> b
$ Endianness
-> Maybe Word16
-> SymbolTable 64
-> RelEntry PPC64_RelocationType
-> MemWord 64
-> RelFlag
-> SymbolResolver (Relocation 64)
relaTargetPPC64 Endianness
end
    (ElfClass w
Elf.ELFCLASS32, ElfMachine
Elf.EM_RISCV) ->
      SomeRelocationResolver w -> MemLoader w (SomeRelocationResolver w)
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (SomeRelocationResolver w
 -> MemLoader w (SomeRelocationResolver w))
-> SomeRelocationResolver w
-> MemLoader w (SomeRelocationResolver w)
forall a b. (a -> b) -> a -> b
$ RelocationResolver (RISCV_RelocationType 32)
-> SomeRelocationResolver w
forall (w :: Nat) tp.
(IsRelocationType tp, w ~ RelocationWidth tp) =>
RelocationResolver tp -> SomeRelocationResolver w
SomeRelocationResolver (RelocationResolver (RISCV_RelocationType 32)
 -> SomeRelocationResolver w)
-> RelocationResolver (RISCV_RelocationType 32)
-> SomeRelocationResolver w
forall a b. (a -> b) -> a -> b
$ Endianness
-> Maybe Word16
-> SymbolTable 32
-> RelEntry (RISCV_RelocationType 32)
-> MemWord 32
-> RelFlag
-> SymbolResolver (Relocation 32)
forall (w :: Nat).
(ElfWidthConstraints w, KnownNat w, MemWidth w) =>
Endianness
-> Maybe Word16
-> SymbolTable w
-> RelEntry (RISCV_RelocationType w)
-> MemWord w
-> RelFlag
-> SymbolResolver (Relocation w)
relaTargetRISCV Endianness
end
    (ElfClass w
Elf.ELFCLASS64, ElfMachine
Elf.EM_RISCV) ->
      SomeRelocationResolver w -> MemLoader w (SomeRelocationResolver w)
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (SomeRelocationResolver w
 -> MemLoader w (SomeRelocationResolver w))
-> SomeRelocationResolver w
-> MemLoader w (SomeRelocationResolver w)
forall a b. (a -> b) -> a -> b
$ RelocationResolver (RISCV_RelocationType 64)
-> SomeRelocationResolver w
forall (w :: Nat) tp.
(IsRelocationType tp, w ~ RelocationWidth tp) =>
RelocationResolver tp -> SomeRelocationResolver w
SomeRelocationResolver (RelocationResolver (RISCV_RelocationType 64)
 -> SomeRelocationResolver w)
-> RelocationResolver (RISCV_RelocationType 64)
-> SomeRelocationResolver w
forall a b. (a -> b) -> a -> b
$ Endianness
-> Maybe Word16
-> SymbolTable 64
-> RelEntry (RISCV_RelocationType 64)
-> MemWord 64
-> RelFlag
-> SymbolResolver (Relocation 64)
forall (w :: Nat).
(ElfWidthConstraints w, KnownNat w, MemWidth w) =>
Endianness
-> Maybe Word16
-> SymbolTable w
-> RelEntry (RISCV_RelocationType w)
-> MemWord w
-> RelFlag
-> SymbolResolver (Relocation w)
relaTargetRISCV Endianness
end
    (ElfClass w
_,ElfMachine
mach) -> LoadError w -> MemLoader w (SomeRelocationResolver w)
forall a.
LoadError w -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (LoadError w -> MemLoader w (SomeRelocationResolver w))
-> LoadError w -> MemLoader w (SomeRelocationResolver w)
forall a b. (a -> b) -> a -> b
$ [Char] -> LoadError w
forall (w :: Nat). [Char] -> LoadError w
UnsupportedArchitecture (ElfMachine -> [Char]
forall a. Show a => a -> [Char]
show ElfMachine
mach)
  where
    end :: Endianness
end = ElfData -> Endianness
toEndianness (ElfHeader w -> ElfData
forall (w :: Nat). ElfHeader w -> ElfData
Elf.headerData ElfHeader w
hdr)

resolveRela :: ( MemWidth w
               , Elf.RelocationWidth tp ~ w
               , Elf.IsRelocationType tp
               , Integral (Elf.ElfIntType w)
               )
            => SymbolTable w
            -> RelocationResolver tp
            -> Integer -- ^ Index of relocation
            -> Elf.RelaEntry tp
            -> ResolveFn (MemLoader w) w
resolveRela :: forall (w :: Nat) tp.
(MemWidth w, RelocationWidth tp ~ w, IsRelocationType tp,
 Integral (ElfIntType w)) =>
SymbolTable w
-> RelocationResolver tp
-> Integer
-> RelaEntry tp
-> ResolveFn (MemLoader w) w
resolveRela SymbolTable w
symtab RelocationResolver tp
resolver Integer
_relaIdx RelaEntry tp
rela Maybe Word16
msegIdx ByteString
_ = do
  Either RelocationError (Relocation w)
er <- SymbolResolver (Relocation (RelocationWidth tp))
-> MemLoader
     w (Either RelocationError (Relocation (RelocationWidth tp)))
forall a (w :: Nat).
SymbolResolver a -> MemLoader w (Either RelocationError a)
runSymbolResolver (SymbolResolver (Relocation (RelocationWidth tp))
 -> MemLoader
      w (Either RelocationError (Relocation (RelocationWidth tp))))
-> SymbolResolver (Relocation (RelocationWidth tp))
-> MemLoader
     w (Either RelocationError (Relocation (RelocationWidth tp)))
forall a b. (a -> b) -> a -> b
$
          RelocationResolver tp
resolver Maybe Word16
msegIdx SymbolTable w
SymbolTable (RelocationWidth tp)
symtab (RelaEntry tp -> RelEntry tp
forall tp. RelaEntry tp -> RelEntry tp
Elf.relaToRel RelaEntry tp
rela) (ElfIntType w -> MemWord w
forall a b. (Integral a, Num b) => a -> b
fromIntegral (RelaEntry tp -> RelocationInt tp
forall tp. RelaEntry tp -> RelocationInt tp
Elf.relaAddend RelaEntry tp
rela)) RelFlag
IsRela
  case Either RelocationError (Relocation w)
er of
    Left RelocationError
e -> do
      MemLoadWarning -> MemLoader w ()
forall (w :: Nat). MemLoadWarning -> MemLoader w ()
addWarning (RelocationError -> MemLoadWarning
IgnoreRelocation RelocationError
e)
      Maybe (Relocation w) -> MemLoader w (Maybe (Relocation w))
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe (Relocation w)
forall a. Maybe a
Nothing
    Right Relocation w
r ->
      Maybe (Relocation w) -> MemLoader w (Maybe (Relocation w))
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe (Relocation w) -> MemLoader w (Maybe (Relocation w)))
-> Maybe (Relocation w) -> MemLoader w (Maybe (Relocation w))
forall a b. (a -> b) -> a -> b
$ Relocation w -> Maybe (Relocation w)
forall a. a -> Maybe a
Just Relocation w
r

resolveRel :: ( MemWidth w
              , Elf.RelocationWidth tp ~ w
              , Elf.IsRelocationType tp
              )
           => Endianness -- ^ Endianness of Elf file
           -> SymbolTable w -- ^ Symbol table
           -> RelocationResolver tp
           -> Integer -- ^ Index of relocation
           -> Elf.RelEntry tp
           -> ResolveFn (MemLoader w) w
resolveRel :: forall (w :: Nat) tp.
(MemWidth w, RelocationWidth tp ~ w, IsRelocationType tp) =>
Endianness
-> SymbolTable w
-> RelocationResolver tp
-> Integer
-> RelEntry tp
-> ResolveFn (MemLoader w) w
resolveRel Endianness
end SymbolTable w
symtab RelocationResolver tp
resolver Integer
_relIdx RelEntry tp
rel Maybe Word16
msegIdx ByteString
bytes = do
  -- Get the number of bits in the addend
  let bits :: Int
bits = tp -> Int
forall tp. IsRelocationType tp => tp -> Int
Elf.relocTargetBits (RelEntry tp -> tp
forall tp. RelEntry tp -> tp
Elf.relType RelEntry tp
rel)
  -- Compute the addended by masking off the low order bits, and
  -- then sign extending them.
  let mask :: Integer
mask = (Integer
1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` (Int
bits Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1
  let uaddend :: Integer
uaddend = Endianness -> ByteString -> Integer
bytesToInteger Endianness
end ByteString
bytes Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. Integer
mask

  -- Convert uaddend as signed by looking at most-significant bit.
  let saddend :: Integer
saddend | Integer
uaddend Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` (Int
bits Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) =
                  Integer
uaddend Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- (Integer
1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
bits)
              | Bool
otherwise =
                  Integer
uaddend
  -- Update the resolver.
  Either RelocationError (Relocation w)
er <- SymbolResolver (Relocation (RelocationWidth tp))
-> MemLoader
     w (Either RelocationError (Relocation (RelocationWidth tp)))
forall a (w :: Nat).
SymbolResolver a -> MemLoader w (Either RelocationError a)
runSymbolResolver (SymbolResolver (Relocation (RelocationWidth tp))
 -> MemLoader
      w (Either RelocationError (Relocation (RelocationWidth tp))))
-> SymbolResolver (Relocation (RelocationWidth tp))
-> MemLoader
     w (Either RelocationError (Relocation (RelocationWidth tp)))
forall a b. (a -> b) -> a -> b
$ RelocationResolver tp
resolver Maybe Word16
msegIdx SymbolTable w
SymbolTable (RelocationWidth tp)
symtab RelEntry tp
rel (Integer -> MemWord w
forall a. Num a => Integer -> a
fromInteger Integer
saddend) RelFlag
IsRel
  case Either RelocationError (Relocation w)
er of
    Left RelocationError
e -> do
      MemLoadWarning -> MemLoader w ()
forall (w :: Nat). MemLoadWarning -> MemLoader w ()
addWarning (RelocationError -> MemLoadWarning
IgnoreRelocation RelocationError
e)
      Maybe (Relocation w) -> MemLoader w (Maybe (Relocation w))
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe (Relocation w)
forall a. Maybe a
Nothing
    Right Relocation w
r -> do
      Maybe (Relocation w) -> MemLoader w (Maybe (Relocation w))
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe (Relocation w) -> MemLoader w (Maybe (Relocation w)))
-> Maybe (Relocation w) -> MemLoader w (Maybe (Relocation w))
forall a b. (a -> b) -> a -> b
$ Relocation w -> Maybe (Relocation w)
forall a. a -> Maybe a
Just Relocation w
r

relocTargetBytes :: (Elf.IsRelocationType tp, MemWidth (Elf.RelocationWidth tp))
                 => tp
                 -> MemWord (Elf.RelocationWidth tp)
relocTargetBytes :: forall tp.
(IsRelocationType tp, MemWidth (RelocationWidth tp)) =>
tp -> MemWord (RelocationWidth tp)
relocTargetBytes tp
tp = Int -> MemWord (RelocationWidth tp)
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> MemWord (RelocationWidth tp))
-> Int -> MemWord (RelocationWidth tp)
forall a b. (a -> b) -> a -> b
$ (tp -> Int
forall tp. IsRelocationType tp => tp -> Int
Elf.relocTargetBits tp
tp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
3


-- | Maps address that relocations apply to to the relocation information.
type RelocMap w = Map (MemWord w) (RelocEntry (MemLoader w) w)

-- | Add a relocation entry to the map.
addRelocEntry :: RelocMap w
              -> MemWord w
              -> RelocEntry (MemLoader w) w
              -> MemLoader w (RelocMap w)
addRelocEntry :: forall (w :: Nat).
RelocMap w
-> MemWord w
-> RelocEntry (MemLoader w) w
-> MemLoader w (RelocMap w)
addRelocEntry RelocMap w
m MemWord w
addr RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w
e =
  case (MemWord w
 -> RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w
 -> RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w
 -> RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
-> MemWord w
-> RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w
-> RelocMap w
-> (Maybe
      (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w),
    RelocMap w)
forall k a.
Ord k =>
(k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a)
Map.insertLookupWithKey (\MemWord w
_k RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w
_new RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w
old -> RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w
old) MemWord w
addr RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w
e RelocMap w
m of
    (Maybe
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
Nothing, RelocMap w
m') -> RelocMap w -> MemLoader w (RelocMap w)
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure RelocMap w
m'
    (Just RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w
_, RelocMap w
_) -> do
      MemLoadWarning -> MemLoader w ()
forall (w :: Nat). MemLoadWarning -> MemLoader w ()
addWarning (MemLoadWarning -> MemLoader w ())
-> MemLoadWarning -> MemLoader w ()
forall a b. (a -> b) -> a -> b
$ Word64 -> MemLoadWarning
MultipleRelocationsAtAddr (MemWord w -> Word64
forall (w :: Nat). MemWord w -> Word64
memWordValue MemWord w
addr)
      RelocMap w -> MemLoader w (RelocMap w)
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure RelocMap w
m

-- | Add a relocation entry to the map.
addRelaEntry :: (Elf.IsRelocationType tp, w ~ Elf.RelocationWidth tp)
            => SymbolTable w
            -> RelocationResolver tp
            -> (Integer, RelocMap w)
            -> Elf.RelaEntry tp
            -> MemLoader w (Integer, RelocMap w)
addRelaEntry :: forall tp (w :: Nat).
(IsRelocationType tp, w ~ RelocationWidth tp) =>
SymbolTable w
-> RelocationResolver tp
-> (Integer, RelocMap w)
-> RelaEntry tp
-> MemLoader w (Integer, RelocMap w)
addRelaEntry SymbolTable w
symtab RelocationResolver tp
resolver (Integer
idx,RelocMap w
m) RelaEntry tp
r = do
  AddrWidthRepr w
w <- LensLike' (Const (AddrWidthRepr w)) (MemLoaderState w) (Memory w)
-> (Memory w -> AddrWidthRepr w)
-> StateT
     (MemLoaderState w) (Except (LoadError w)) (AddrWidthRepr w)
forall s (m :: Type -> Type) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses LensLike' (Const (AddrWidthRepr w)) (MemLoaderState w) (Memory w)
forall (w :: Nat) (f :: Type -> Type).
Functor f =>
(Memory w -> f (Memory w))
-> MemLoaderState w -> f (MemLoaderState w)
mlsMemory Memory w -> AddrWidthRepr w
forall (w :: Nat). Memory w -> AddrWidthRepr w
memAddrWidth
  AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    MemLoader w (Integer, RelocMap w))
-> MemLoader w (Integer, RelocMap w)
forall (w :: Nat) a.
AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    a)
-> a
reprConstraints AddrWidthRepr w
w (((Bits (ElfWordType w), Bounded (ElfIntType w),
   Integral (ElfIntType w), Bounded (ElfWordType w),
   Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
  MemLoader w (Integer, RelocMap w))
 -> MemLoader w (Integer, RelocMap w))
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    MemLoader w (Integer, RelocMap w))
-> MemLoader w (Integer, RelocMap w)
forall a b. (a -> b) -> a -> b
$ do
    let addr :: MemWord w
addr = ElfWordType w -> MemWord w
forall a b. (Integral a, Num b) => a -> b
fromIntegral (RelaEntry tp -> RelocationWord tp
forall tp. RelaEntry tp -> RelocationWord tp
Elf.relaAddr RelaEntry tp
r)
        e :: RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w
e =  RelocEntry { relocEntrySize :: MemWord w
relocEntrySize = tp -> MemWord (RelocationWidth tp)
forall tp.
(IsRelocationType tp, MemWidth (RelocationWidth tp)) =>
tp -> MemWord (RelocationWidth tp)
relocTargetBytes (RelaEntry tp -> tp
forall tp. RelaEntry tp -> tp
Elf.relaType RelaEntry tp
r)
                        , applyReloc :: ResolveFn (StateT (MemLoaderState w) (Except (LoadError w))) w
applyReloc = SymbolTable w
-> RelocationResolver tp
-> Integer
-> RelaEntry tp
-> ResolveFn (StateT (MemLoaderState w) (Except (LoadError w))) w
forall (w :: Nat) tp.
(MemWidth w, RelocationWidth tp ~ w, IsRelocationType tp,
 Integral (ElfIntType w)) =>
SymbolTable w
-> RelocationResolver tp
-> Integer
-> RelaEntry tp
-> ResolveFn (MemLoader w) w
resolveRela SymbolTable w
symtab RelocationResolver tp
resolver Integer
idx RelaEntry tp
r
                        }
    (Integer
idxInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1,) (RelocMap w -> (Integer, RelocMap w))
-> StateT (MemLoaderState w) (Except (LoadError w)) (RelocMap w)
-> MemLoader w (Integer, RelocMap w)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> RelocMap w
-> MemWord w
-> RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w
-> StateT (MemLoaderState w) (Except (LoadError w)) (RelocMap w)
forall (w :: Nat).
RelocMap w
-> MemWord w
-> RelocEntry (MemLoader w) w
-> MemLoader w (RelocMap w)
addRelocEntry RelocMap w
m MemWord w
addr RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w
e

addRelaEntries :: (Elf.IsRelocationType tp, w ~ Elf.RelocationWidth tp)
              => RelocMap w
              -> SymbolTable w
              -- ^ Map from symbol indices to associated symbol
              -> RelocationResolver tp
                 -- Resolver for relocations
              -> [Elf.RelaEntry tp]
              -- ^ Buffer containing relocation entries in Rel format
              -> MemLoader w (RelocMap w)
addRelaEntries :: forall tp (w :: Nat).
(IsRelocationType tp, w ~ RelocationWidth tp) =>
RelocMap w
-> SymbolTable w
-> RelocationResolver tp
-> [RelaEntry tp]
-> MemLoader w (RelocMap w)
addRelaEntries RelocMap w
m SymbolTable w
symtab RelocationResolver tp
resolver [RelaEntry tp]
entries = do
  (Integer, RelocMap w) -> RelocMap w
forall a b. (a, b) -> b
snd ((Integer, RelocMap w) -> RelocMap w)
-> StateT
     (MemLoaderState w) (Except (LoadError w)) (Integer, RelocMap w)
-> MemLoader w (RelocMap w)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Integer, RelocMap w)
 -> RelaEntry tp
 -> StateT
      (MemLoaderState w) (Except (LoadError w)) (Integer, RelocMap w))
-> (Integer, RelocMap w)
-> [RelaEntry tp]
-> StateT
     (MemLoaderState w) (Except (LoadError w)) (Integer, RelocMap w)
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (SymbolTable w
-> RelocationResolver tp
-> (Integer, RelocMap w)
-> RelaEntry tp
-> StateT
     (MemLoaderState w) (Except (LoadError w)) (Integer, RelocMap w)
forall tp (w :: Nat).
(IsRelocationType tp, w ~ RelocationWidth tp) =>
SymbolTable w
-> RelocationResolver tp
-> (Integer, RelocMap w)
-> RelaEntry tp
-> MemLoader w (Integer, RelocMap w)
addRelaEntry SymbolTable w
symtab RelocationResolver tp
resolver) (Integer
0,RelocMap w
m) [RelaEntry tp]
entries

-- | Add rela relocation entries to map.
addElfRelaEntries :: (Elf.IsRelocationType tp, w ~ Elf.RelocationWidth tp)
                  => RelocMap w
                  -> Elf.ElfData
                  -- ^ Endianness
                  -> RelocationResolver tp
                  -> SymbolTable w
                  -- ^ Map from symbol indices to associated symbol
                  -> Maybe BS.ByteString
                  -- ^ Buffer containing relocation entries in Rela format
                  -> MemLoader w (RelocMap w)
addElfRelaEntries :: forall tp (w :: Nat).
(IsRelocationType tp, w ~ RelocationWidth tp) =>
RelocMap w
-> ElfData
-> RelocationResolver tp
-> SymbolTable w
-> Maybe ByteString
-> MemLoader w (RelocMap w)
addElfRelaEntries RelocMap w
m ElfData
_ RelocationResolver tp
_ SymbolTable w
_ Maybe ByteString
Nothing =
  RelocMap w
-> StateT (MemLoaderState w) (Except (LoadError w)) (RelocMap w)
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure RelocMap w
m
addElfRelaEntries RelocMap w
m ElfData
dta RelocationResolver tp
resolver SymbolTable w
symtab (Just ByteString
relaBuffer) = do
  AddrWidthRepr w
w <- LensLike' (Const (AddrWidthRepr w)) (MemLoaderState w) (Memory w)
-> (Memory w -> AddrWidthRepr w)
-> StateT
     (MemLoaderState w) (Except (LoadError w)) (AddrWidthRepr w)
forall s (m :: Type -> Type) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses LensLike' (Const (AddrWidthRepr w)) (MemLoaderState w) (Memory w)
forall (w :: Nat) (f :: Type -> Type).
Functor f =>
(Memory w -> f (Memory w))
-> MemLoaderState w -> f (MemLoaderState w)
mlsMemory Memory w -> AddrWidthRepr w
forall (w :: Nat). Memory w -> AddrWidthRepr w
memAddrWidth
  AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    StateT (MemLoaderState w) (Except (LoadError w)) (RelocMap w))
-> StateT (MemLoaderState w) (Except (LoadError w)) (RelocMap w)
forall (w :: Nat) a.
AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    a)
-> a
reprConstraints AddrWidthRepr w
w (((Bits (ElfWordType w), Bounded (ElfIntType w),
   Integral (ElfIntType w), Bounded (ElfWordType w),
   Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
  StateT (MemLoaderState w) (Except (LoadError w)) (RelocMap w))
 -> StateT (MemLoaderState w) (Except (LoadError w)) (RelocMap w))
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    StateT (MemLoaderState w) (Except (LoadError w)) (RelocMap w))
-> StateT (MemLoaderState w) (Except (LoadError w)) (RelocMap w)
forall a b. (a -> b) -> a -> b
$ do
    case ElfData -> ByteString -> Either [Char] [RelaEntry tp]
forall tp.
IsRelocationType tp =>
ElfData -> ByteString -> Either [Char] [RelaEntry tp]
Elf.decodeRelaEntries ElfData
dta ByteString
relaBuffer of
      Left [Char]
msg -> do
        MemLoadWarning -> MemLoader w ()
forall (w :: Nat). MemLoadWarning -> MemLoader w ()
addWarning ([Char] -> MemLoadWarning
RelocationParseFailure [Char]
msg)
        RelocMap w
-> StateT (MemLoaderState w) (Except (LoadError w)) (RelocMap w)
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure RelocMap w
m
      Right [RelaEntry tp]
entries -> do
        RelocMap w
-> SymbolTable w
-> RelocationResolver tp
-> [RelaEntry tp]
-> StateT (MemLoaderState w) (Except (LoadError w)) (RelocMap w)
forall tp (w :: Nat).
(IsRelocationType tp, w ~ RelocationWidth tp) =>
RelocMap w
-> SymbolTable w
-> RelocationResolver tp
-> [RelaEntry tp]
-> MemLoader w (RelocMap w)
addRelaEntries RelocMap w
m SymbolTable w
symtab RelocationResolver tp
resolver [RelaEntry tp]
entries

-- | Add a relocation entry to the map.
addRelEntry :: (Elf.IsRelocationType tp, w ~ Elf.RelocationWidth tp)
            => Endianness
            -> SymbolTable w
            -> RelocationResolver tp
            -> (Integer, RelocMap w)
            -> Elf.RelEntry tp
            -> MemLoader w (Integer, RelocMap w)
addRelEntry :: forall tp (w :: Nat).
(IsRelocationType tp, w ~ RelocationWidth tp) =>
Endianness
-> SymbolTable w
-> RelocationResolver tp
-> (Integer, RelocMap w)
-> RelEntry tp
-> MemLoader w (Integer, RelocMap w)
addRelEntry Endianness
end SymbolTable w
symtab RelocationResolver tp
resolver (Integer
idx,RelocMap w
m) RelEntry tp
r = do
  AddrWidthRepr w
w <- LensLike' (Const (AddrWidthRepr w)) (MemLoaderState w) (Memory w)
-> (Memory w -> AddrWidthRepr w)
-> StateT
     (MemLoaderState w) (Except (LoadError w)) (AddrWidthRepr w)
forall s (m :: Type -> Type) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses LensLike' (Const (AddrWidthRepr w)) (MemLoaderState w) (Memory w)
forall (w :: Nat) (f :: Type -> Type).
Functor f =>
(Memory w -> f (Memory w))
-> MemLoaderState w -> f (MemLoaderState w)
mlsMemory Memory w -> AddrWidthRepr w
forall (w :: Nat). Memory w -> AddrWidthRepr w
memAddrWidth
  AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    MemLoader w (Integer, RelocMap w))
-> MemLoader w (Integer, RelocMap w)
forall (w :: Nat) a.
AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    a)
-> a
reprConstraints AddrWidthRepr w
w (((Bits (ElfWordType w), Bounded (ElfIntType w),
   Integral (ElfIntType w), Bounded (ElfWordType w),
   Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
  MemLoader w (Integer, RelocMap w))
 -> MemLoader w (Integer, RelocMap w))
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    MemLoader w (Integer, RelocMap w))
-> MemLoader w (Integer, RelocMap w)
forall a b. (a -> b) -> a -> b
$ do
    let addr :: MemWord w
addr = ElfWordType w -> MemWord w
forall a b. (Integral a, Num b) => a -> b
fromIntegral (RelEntry tp -> RelocationWord tp
forall tp. RelEntry tp -> RelocationWord tp
Elf.relAddr RelEntry tp
r)
        e :: RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w
e =  RelocEntry { relocEntrySize :: MemWord w
relocEntrySize = tp -> MemWord (RelocationWidth tp)
forall tp.
(IsRelocationType tp, MemWidth (RelocationWidth tp)) =>
tp -> MemWord (RelocationWidth tp)
relocTargetBytes (RelEntry tp -> tp
forall tp. RelEntry tp -> tp
Elf.relType RelEntry tp
r)
                        , applyReloc :: ResolveFn (StateT (MemLoaderState w) (Except (LoadError w))) w
applyReloc = Endianness
-> SymbolTable w
-> RelocationResolver tp
-> Integer
-> RelEntry tp
-> ResolveFn (StateT (MemLoaderState w) (Except (LoadError w))) w
forall (w :: Nat) tp.
(MemWidth w, RelocationWidth tp ~ w, IsRelocationType tp) =>
Endianness
-> SymbolTable w
-> RelocationResolver tp
-> Integer
-> RelEntry tp
-> ResolveFn (MemLoader w) w
resolveRel Endianness
end SymbolTable w
symtab RelocationResolver tp
resolver Integer
idx RelEntry tp
r
                        }
    (Integer
idxInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1,) (RelocMap w -> (Integer, RelocMap w))
-> StateT (MemLoaderState w) (Except (LoadError w)) (RelocMap w)
-> MemLoader w (Integer, RelocMap w)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> RelocMap w
-> MemWord w
-> RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w
-> StateT (MemLoaderState w) (Except (LoadError w)) (RelocMap w)
forall (w :: Nat).
RelocMap w
-> MemWord w
-> RelocEntry (MemLoader w) w
-> MemLoader w (RelocMap w)
addRelocEntry RelocMap w
m MemWord w
addr RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w
e

addRelEntries :: (Elf.IsRelocationType tp, w ~ Elf.RelocationWidth tp)
              => RelocMap w
              -> Elf.ElfData
              -- ^ Endianness
              -> SymbolTable w
              -- ^ Map from symbol indices to associated symbol
              -> RelocationResolver tp
                 -- Resolver for relocations
              -> [Elf.RelEntry tp]
              -- ^ Buffer containing relocation entries in Rel format
              -> MemLoader w (RelocMap w)
addRelEntries :: forall tp (w :: Nat).
(IsRelocationType tp, w ~ RelocationWidth tp) =>
RelocMap w
-> ElfData
-> SymbolTable w
-> RelocationResolver tp
-> [RelEntry tp]
-> MemLoader w (RelocMap w)
addRelEntries RelocMap w
m ElfData
dta SymbolTable w
symtab RelocationResolver tp
resolver [RelEntry tp]
entries =
  (Integer, RelocMap w) -> RelocMap w
forall a b. (a, b) -> b
snd ((Integer, RelocMap w) -> RelocMap w)
-> StateT
     (MemLoaderState w) (Except (LoadError w)) (Integer, RelocMap w)
-> StateT (MemLoaderState w) (Except (LoadError w)) (RelocMap w)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Integer, RelocMap w)
 -> RelEntry tp
 -> StateT
      (MemLoaderState w) (Except (LoadError w)) (Integer, RelocMap w))
-> (Integer, RelocMap w)
-> [RelEntry tp]
-> StateT
     (MemLoaderState w) (Except (LoadError w)) (Integer, RelocMap w)
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (Endianness
-> SymbolTable w
-> RelocationResolver tp
-> (Integer, RelocMap w)
-> RelEntry tp
-> StateT
     (MemLoaderState w) (Except (LoadError w)) (Integer, RelocMap w)
forall tp (w :: Nat).
(IsRelocationType tp, w ~ RelocationWidth tp) =>
Endianness
-> SymbolTable w
-> RelocationResolver tp
-> (Integer, RelocMap w)
-> RelEntry tp
-> MemLoader w (Integer, RelocMap w)
addRelEntry (ElfData -> Endianness
toEndianness ElfData
dta) SymbolTable w
symtab RelocationResolver tp
resolver) (Integer
0,RelocMap w
m) [RelEntry tp]
entries

-- | Add rel relocation entries to map.
addElfRelEntries :: (Elf.IsRelocationType tp, w ~ Elf.RelocationWidth tp)
                 => RelocMap w
                 -> Elf.ElfData
                 -- ^ Endianness
                 -> RelocationResolver tp
                 -> SymbolTable w
                 -- ^ Map from symbol indices to associated symbol
                 -> Maybe BS.ByteString
                 -- ^ Buffer containing relocation entries in Rel format
                 -> MemLoader w (RelocMap w)
addElfRelEntries :: forall tp (w :: Nat).
(IsRelocationType tp, w ~ RelocationWidth tp) =>
RelocMap w
-> ElfData
-> RelocationResolver tp
-> SymbolTable w
-> Maybe ByteString
-> MemLoader w (RelocMap w)
addElfRelEntries RelocMap w
m ElfData
_ RelocationResolver tp
_ SymbolTable w
_ Maybe ByteString
Nothing =
  RelocMap w
-> StateT (MemLoaderState w) (Except (LoadError w)) (RelocMap w)
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure RelocMap w
m
addElfRelEntries RelocMap w
m ElfData
dta RelocationResolver tp
resolver SymbolTable w
symtab (Just ByteString
relBuffer) = do
  AddrWidthRepr w
w <- LensLike' (Const (AddrWidthRepr w)) (MemLoaderState w) (Memory w)
-> (Memory w -> AddrWidthRepr w)
-> StateT
     (MemLoaderState w) (Except (LoadError w)) (AddrWidthRepr w)
forall s (m :: Type -> Type) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses LensLike' (Const (AddrWidthRepr w)) (MemLoaderState w) (Memory w)
forall (w :: Nat) (f :: Type -> Type).
Functor f =>
(Memory w -> f (Memory w))
-> MemLoaderState w -> f (MemLoaderState w)
mlsMemory Memory w -> AddrWidthRepr w
forall (w :: Nat). Memory w -> AddrWidthRepr w
memAddrWidth
  AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    StateT (MemLoaderState w) (Except (LoadError w)) (RelocMap w))
-> StateT (MemLoaderState w) (Except (LoadError w)) (RelocMap w)
forall (w :: Nat) a.
AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    a)
-> a
reprConstraints AddrWidthRepr w
w (((Bits (ElfWordType w), Bounded (ElfIntType w),
   Integral (ElfIntType w), Bounded (ElfWordType w),
   Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
  StateT (MemLoaderState w) (Except (LoadError w)) (RelocMap w))
 -> StateT (MemLoaderState w) (Except (LoadError w)) (RelocMap w))
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    StateT (MemLoaderState w) (Except (LoadError w)) (RelocMap w))
-> StateT (MemLoaderState w) (Except (LoadError w)) (RelocMap w)
forall a b. (a -> b) -> a -> b
$ do
    case ElfData -> ByteString -> Either [Char] [RelEntry tp]
forall tp.
IsRelocationType tp =>
ElfData -> ByteString -> Either [Char] [RelEntry tp]
Elf.decodeRelEntries ElfData
dta ByteString
relBuffer of
      Left [Char]
msg -> do
        MemLoadWarning -> MemLoader w ()
forall (w :: Nat). MemLoadWarning -> MemLoader w ()
addWarning ([Char] -> MemLoadWarning
RelocationParseFailure [Char]
msg)
        RelocMap w
-> StateT (MemLoaderState w) (Except (LoadError w)) (RelocMap w)
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure RelocMap w
forall k a. Map k a
Map.empty
      Right [RelEntry tp]
entries -> do
        RelocMap w
-> ElfData
-> SymbolTable w
-> RelocationResolver tp
-> [RelEntry tp]
-> StateT (MemLoaderState w) (Except (LoadError w)) (RelocMap w)
forall tp (w :: Nat).
(IsRelocationType tp, w ~ RelocationWidth tp) =>
RelocMap w
-> ElfData
-> SymbolTable w
-> RelocationResolver tp
-> [RelEntry tp]
-> MemLoader w (RelocMap w)
addRelEntries RelocMap w
m ElfData
dta SymbolTable w
symtab RelocationResolver tp
resolver [RelEntry tp]
entries

-- | This checks a computation that returns a dynamic error or succeeds.
runDynamic :: Either Elf.DynamicError a -> MemLoader w a
runDynamic :: forall a (w :: Nat). Either DynamicError a -> MemLoader w a
runDynamic (Left DynamicError
e) = LoadError w -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall a.
LoadError w -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (DynamicError -> LoadError w
forall (w :: Nat). DynamicError -> LoadError w
FormatDynamicError DynamicError
e)
runDynamic (Right a
r) = a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
r


-- | Attempt to extract bytestring from region identified by two tags,
-- and call a continuation if succesful or return a default value if not.
withDynamicBytes :: Elf.DynamicMap w -- ^ Dynamic map
                 -> Elf.VirtAddrMap w -- ^ Virtual address map for loading files.
                 -> Elf.ElfDynamicTag -- ^ Offset
                 -> Elf.ElfDynamicTag -- ^ Size
                 -> a -- ^ Value to return if loading fails.
                 -> (BS.ByteString -> MemLoader w a)
                 -- ^ Continutation to run with bytes.
                 -> MemLoader w a
withDynamicBytes :: forall (w :: Nat) a.
DynamicMap w
-> VirtAddrMap w
-> ElfDynamicTag
-> ElfDynamicTag
-> a
-> (ByteString -> MemLoader w a)
-> MemLoader w a
withDynamicBytes DynamicMap w
dmap VirtAddrMap w
virtMap ElfDynamicTag
offTag ElfDynamicTag
sizeTag a
failVal ByteString -> MemLoader w a
cont = do
  case ([ElfWordType w] -> ElfDynamicTag -> DynamicMap w -> [ElfWordType w]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] ElfDynamicTag
offTag DynamicMap w
dmap, [ElfWordType w] -> ElfDynamicTag -> DynamicMap w -> [ElfWordType w]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] ElfDynamicTag
sizeTag DynamicMap w
dmap) of
    ([ElfWordType w
off], [ElfWordType w
sz]) -> do
      AddrWidthRepr w
w <- LensLike' (Const (AddrWidthRepr w)) (MemLoaderState w) (Memory w)
-> (Memory w -> AddrWidthRepr w)
-> StateT
     (MemLoaderState w) (Except (LoadError w)) (AddrWidthRepr w)
forall s (m :: Type -> Type) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses LensLike' (Const (AddrWidthRepr w)) (MemLoaderState w) (Memory w)
forall (w :: Nat) (f :: Type -> Type).
Functor f =>
(Memory w -> f (Memory w))
-> MemLoaderState w -> f (MemLoaderState w)
mlsMemory Memory w -> AddrWidthRepr w
forall (w :: Nat). Memory w -> AddrWidthRepr w
memAddrWidth
      AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    MemLoader w a)
-> MemLoader w a
forall (w :: Nat) a.
AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    a)
-> a
reprConstraints AddrWidthRepr w
w (((Bits (ElfWordType w), Bounded (ElfIntType w),
   Integral (ElfIntType w), Bounded (ElfWordType w),
   Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
  MemLoader w a)
 -> MemLoader w a)
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    MemLoader w a)
-> MemLoader w a
forall a b. (a -> b) -> a -> b
$
        case ElfWordType w -> VirtAddrMap w -> Maybe ByteString
forall (w :: Nat).
Integral (ElfWordType w) =>
ElfWordType w -> VirtAddrMap w -> Maybe ByteString
Elf.lookupVirtAddrContents ElfWordType w
off VirtAddrMap w
virtMap of
          Just ByteString
relocStartBytes
            | Int -> Integer
forall a. Integral a => a -> Integer
toInteger (ByteString -> Int
BS.length ByteString
relocStartBytes) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= ElfWordType w -> Integer
forall a. Integral a => a -> Integer
toInteger ElfWordType w
sz ->
                ByteString -> MemLoader w a
cont (ByteString -> MemLoader w a) -> ByteString -> MemLoader w a
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take (ElfWordType w -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ElfWordType w
sz) ByteString
relocStartBytes
          Maybe ByteString
_ -> do
            MemLoadWarning -> MemLoader w ()
forall (w :: Nat). MemLoadWarning -> MemLoader w ()
addWarning (MemLoadWarning -> MemLoader w ())
-> MemLoadWarning -> MemLoader w ()
forall a b. (a -> b) -> a -> b
$ ElfDynamicTag
-> ElfDynamicTag -> Word64 -> Word64 -> MemLoadWarning
DynamicTagsOutOfRange ElfDynamicTag
offTag ElfDynamicTag
sizeTag (ElfWordType w -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral ElfWordType w
off) (ElfWordType w -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral ElfWordType w
sz)
            a -> MemLoader w a
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
failVal
    (ElfWordType w
_:ElfWordType w
_:[ElfWordType w]
_, [ElfWordType w]
_) -> do
      MemLoadWarning -> MemLoader w ()
forall (w :: Nat). MemLoadWarning -> MemLoader w ()
addWarning (MemLoadWarning -> MemLoader w ())
-> MemLoadWarning -> MemLoader w ()
forall a b. (a -> b) -> a -> b
$ ElfDynamicTag -> MemLoadWarning
DynamicMultipleTags ElfDynamicTag
offTag
      a -> MemLoader w a
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
failVal
    ([ElfWordType w]
_, ElfWordType w
_:ElfWordType w
_:[ElfWordType w]
_) -> do
      MemLoadWarning -> MemLoader w ()
forall (w :: Nat). MemLoadWarning -> MemLoader w ()
addWarning (MemLoadWarning -> MemLoader w ())
-> MemLoadWarning -> MemLoader w ()
forall a b. (a -> b) -> a -> b
$ ElfDynamicTag -> MemLoadWarning
DynamicMultipleTags ElfDynamicTag
sizeTag
      a -> MemLoader w a
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
failVal
    ([ElfWordType w
_], []) -> do
      MemLoadWarning -> MemLoader w ()
forall (w :: Nat). MemLoadWarning -> MemLoader w ()
addWarning (MemLoadWarning -> MemLoader w ())
-> MemLoadWarning -> MemLoader w ()
forall a b. (a -> b) -> a -> b
$ ElfDynamicTag -> ElfDynamicTag -> MemLoadWarning
DynamicTagPairMismatch ElfDynamicTag
offTag ElfDynamicTag
sizeTag
      a -> MemLoader w a
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
failVal
    ([], [ElfWordType w
_]) -> do
      MemLoadWarning -> MemLoader w ()
forall (w :: Nat). MemLoadWarning -> MemLoader w ()
addWarning (MemLoadWarning -> MemLoader w ())
-> MemLoadWarning -> MemLoader w ()
forall a b. (a -> b) -> a -> b
$ ElfDynamicTag -> ElfDynamicTag -> MemLoadWarning
DynamicTagPairMismatch ElfDynamicTag
sizeTag ElfDynamicTag
offTag
      a -> MemLoader w a
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
failVal
    ([], []) ->
      a -> MemLoader w a
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
failVal

-- | Attempt to extract relocations in Android's compressed format
-- from a region identified by two tags, and call a continuation if
-- succesful or return a default value if not.
withAndroidRelaEntries :: ( w ~ Elf.RelocationWidth tp
                          , Elf.IsRelocationType tp
                          )
                       => Elf.DynamicMap w -- ^ Dynamic map
                       -> Elf.VirtAddrMap w -- ^ Virtual address map for loading files.
                       -> Elf.ElfDynamicTag -- ^ Offset
                       -> Elf.ElfDynamicTag -- ^ Size
                       -> a -- ^ Value to return if loading fails.
                       -> (V.Vector (Elf.RelaEntry tp) -> MemLoader w a)
                       -- ^ Continutation to run with bytes.
                       -> MemLoader w a
withAndroidRelaEntries :: forall (w :: Nat) tp a.
(w ~ RelocationWidth tp, IsRelocationType tp) =>
DynamicMap w
-> VirtAddrMap w
-> ElfDynamicTag
-> ElfDynamicTag
-> a
-> (Vector (RelaEntry tp) -> MemLoader w a)
-> MemLoader w a
withAndroidRelaEntries DynamicMap w
dmap VirtAddrMap w
virtMap ElfDynamicTag
offTag ElfDynamicTag
sizeTag a
failVal Vector (RelaEntry tp) -> MemLoader w a
cont =
  DynamicMap w
-> VirtAddrMap w
-> ElfDynamicTag
-> ElfDynamicTag
-> a
-> (ByteString -> MemLoader w a)
-> MemLoader w a
forall (w :: Nat) a.
DynamicMap w
-> VirtAddrMap w
-> ElfDynamicTag
-> ElfDynamicTag
-> a
-> (ByteString -> MemLoader w a)
-> MemLoader w a
withDynamicBytes DynamicMap w
dmap VirtAddrMap w
virtMap ElfDynamicTag
offTag ElfDynamicTag
sizeTag a
failVal ((ByteString -> MemLoader w a) -> MemLoader w a)
-> (ByteString -> MemLoader w a) -> MemLoader w a
forall a b. (a -> b) -> a -> b
$ \ByteString
bytes -> do
    AddrWidthRepr w
w <- LensLike' (Const (AddrWidthRepr w)) (MemLoaderState w) (Memory w)
-> (Memory w -> AddrWidthRepr w)
-> StateT
     (MemLoaderState w) (Except (LoadError w)) (AddrWidthRepr w)
forall s (m :: Type -> Type) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses LensLike' (Const (AddrWidthRepr w)) (MemLoaderState w) (Memory w)
forall (w :: Nat) (f :: Type -> Type).
Functor f =>
(Memory w -> f (Memory w))
-> MemLoaderState w -> f (MemLoaderState w)
mlsMemory Memory w -> AddrWidthRepr w
forall (w :: Nat). Memory w -> AddrWidthRepr w
memAddrWidth
    AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    MemLoader w a)
-> MemLoader w a
forall (w :: Nat) a.
AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    a)
-> a
reprConstraints AddrWidthRepr w
w (((Bits (ElfWordType w), Bounded (ElfIntType w),
   Integral (ElfIntType w), Bounded (ElfWordType w),
   Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
  MemLoader w a)
 -> MemLoader w a)
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    MemLoader w a)
-> MemLoader w a
forall a b. (a -> b) -> a -> b
$
      case ByteString -> Either AndroidDecodeError (Vector (RelaEntry tp))
forall a.
(IsRelocationType a, Integral (ElfIntType (RelocationWidth a)),
 Bounded (ElfIntType (RelocationWidth a)),
 Integral (ElfWordType (RelocationWidth a)),
 Bounded (ElfWordType (RelocationWidth a))) =>
ByteString -> Either AndroidDecodeError (Vector (RelaEntry a))
Elf.decodeAndroidRelaEntries ByteString
bytes of
        Left AndroidDecodeError
e -> do
          MemLoadWarning -> MemLoader w ()
forall (w :: Nat). MemLoadWarning -> MemLoader w ()
addWarning (MemLoadWarning -> MemLoader w ())
-> MemLoadWarning -> MemLoader w ()
forall a b. (a -> b) -> a -> b
$ ElfDynamicTag -> AndroidDecodeError -> MemLoadWarning
AndroidRelDecodingError ElfDynamicTag
offTag AndroidDecodeError
e
          a -> MemLoader w a
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
failVal
        Right Vector (RelaEntry tp)
v ->
          Vector (RelaEntry tp) -> MemLoader w a
cont Vector (RelaEntry tp)
v

-- | Create a relocation map from the dynamic loader information.
dynamicRelocationMap :: Elf.ElfHeader w
                     -> V.Vector (Elf.Phdr w)
                     -> BS.ByteString -- ^ Contents of file.
                     -> MemLoader w (Map (MemWord w) (RelocEntry (MemLoader w) w))
dynamicRelocationMap :: forall (w :: Nat).
ElfHeader w
-> Vector (Phdr w)
-> ByteString
-> MemLoader w (Map (MemWord w) (RelocEntry (MemLoader w) w))
dynamicRelocationMap ElfHeader w
hdr Vector (Phdr w)
phdrs ByteString
contents = do
  let dynPhdrs :: Vector (Phdr w)
dynPhdrs = (Phdr w -> Bool) -> Vector (Phdr w) -> Vector (Phdr w)
forall a. (a -> Bool) -> Vector a -> Vector a
V.filter (\Phdr w
p -> Phdr w -> PhdrType
forall (w :: Nat). Phdr w -> PhdrType
Elf.phdrSegmentType Phdr w
p PhdrType -> PhdrType -> Bool
forall a. Eq a => a -> a -> Bool
== PhdrType
Elf.PT_DYNAMIC) Vector (Phdr w)
phdrs
  case Vector (Phdr w) -> [Phdr w]
forall a. Vector a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList Vector (Phdr w)
dynPhdrs of
    [] -> Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
-> MemLoader
     w
     (Map
        (MemWord w)
        (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w))
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Map
   (MemWord w)
   (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
 -> MemLoader
      w
      (Map
         (MemWord w)
         (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)))
-> Map
     (MemWord w)
     (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
-> MemLoader
     w
     (Map
        (MemWord w)
        (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w))
forall a b. (a -> b) -> a -> b
$ Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
forall k a. Map k a
Map.empty
    Phdr w
dynPhdr:[Phdr w]
dynRest -> do
      Bool
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([Phdr w] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Phdr w]
dynRest)) (StateT (MemLoaderState w) (Except (LoadError w)) ()
 -> StateT (MemLoaderState w) (Except (LoadError w)) ())
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
forall a b. (a -> b) -> a -> b
$ do
        MemLoadWarning
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
forall (w :: Nat). MemLoadWarning -> MemLoader w ()
addWarning MemLoadWarning
MultipleDynamicSegments
      AddrWidthRepr w
w <- LensLike' (Const (AddrWidthRepr w)) (MemLoaderState w) (Memory w)
-> (Memory w -> AddrWidthRepr w)
-> StateT
     (MemLoaderState w) (Except (LoadError w)) (AddrWidthRepr w)
forall s (m :: Type -> Type) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses LensLike' (Const (AddrWidthRepr w)) (MemLoaderState w) (Memory w)
forall (w :: Nat) (f :: Type -> Type).
Functor f =>
(Memory w -> f (Memory w))
-> MemLoaderState w -> f (MemLoaderState w)
mlsMemory Memory w -> AddrWidthRepr w
forall (w :: Nat). Memory w -> AddrWidthRepr w
memAddrWidth
      AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    MemLoader
      w
      (Map
         (MemWord w)
         (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)))
-> MemLoader
     w
     (Map
        (MemWord w)
        (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w))
forall (w :: Nat) a.
AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    a)
-> a
reprConstraints AddrWidthRepr w
w (((Bits (ElfWordType w), Bounded (ElfIntType w),
   Integral (ElfIntType w), Bounded (ElfWordType w),
   Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
  MemLoader
    w
    (Map
       (MemWord w)
       (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)))
 -> MemLoader
      w
      (Map
         (MemWord w)
         (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)))
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    MemLoader
      w
      (Map
         (MemWord w)
         (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)))
-> MemLoader
     w
     (Map
        (MemWord w)
        (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w))
forall a b. (a -> b) -> a -> b
$ do
        -- Build virtual address map so that we can resolve
        -- elf virtual addresses to their program header offset.
        let phdrList :: [Phdr w]
phdrList = Vector (Phdr w) -> [Phdr w]
forall a. Vector a -> [a]
V.toList Vector (Phdr w)
phdrs
        case ByteString -> [Phdr w] -> Maybe (VirtAddrMap w)
forall (t :: Type -> Type) (w :: Nat).
(Foldable t, Integral (ElfWordType w)) =>
ByteString -> t (Phdr w) -> Maybe (VirtAddrMap w)
Elf.virtAddrMap ByteString
contents [Phdr w]
phdrList of
          Maybe (VirtAddrMap w)
Nothing -> do
            MemLoadWarning
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
forall (w :: Nat). MemLoadWarning -> MemLoader w ()
addWarning MemLoadWarning
OverlappingLoadableSegments
            Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
-> MemLoader
     w
     (Map
        (MemWord w)
        (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w))
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
forall k a. Map k a
Map.empty
          Just VirtAddrMap w
virtMap -> do
            let dynContents :: ByteString
dynContents = FileRange (ElfWordType w) -> ByteString -> ByteString
forall w. Integral w => FileRange w -> ByteString -> ByteString
slice (Phdr w -> FileRange (ElfWordType w)
forall (w :: Nat). Phdr w -> FileRange (ElfWordType w)
Elf.phdrFileRange Phdr w
dynPhdr) ByteString
contents
            -- Find the dynamic section from the contents.
            DynamicSection w
dynSection <- Either DynamicError (DynamicSection w)
-> MemLoader w (DynamicSection w)
forall a (w :: Nat). Either DynamicError a -> MemLoader w a
runDynamic (Either DynamicError (DynamicSection w)
 -> MemLoader w (DynamicSection w))
-> Either DynamicError (DynamicSection w)
-> MemLoader w (DynamicSection w)
forall a b. (a -> b) -> a -> b
$
              ElfData
-> ElfClass w
-> ByteString
-> Either DynamicError (DynamicSection w)
forall (w :: Nat).
ElfData
-> ElfClass w
-> ByteString
-> Either DynamicError (DynamicSection w)
Elf.dynamicEntries (ElfHeader w -> ElfData
forall (w :: Nat). ElfHeader w -> ElfData
Elf.headerData ElfHeader w
hdr) (ElfHeader w -> ElfClass w
forall (w :: Nat). ElfHeader w -> ElfClass w
Elf.headerClass ElfHeader w
hdr) ByteString
dynContents
            let dta :: ElfData
dta = ElfHeader w -> ElfData
forall (w :: Nat). ElfHeader w -> ElfData
Elf.headerData ElfHeader w
hdr
            SomeRelocationResolver (RelocationResolver tp
resolver :: RelocationResolver tp) <- ElfHeader w -> MemLoader w (SomeRelocationResolver w)
forall (w :: Nat).
ElfHeader w -> MemLoader w (SomeRelocationResolver w)
getRelocationResolver ElfHeader w
hdr
            VersionDefMap
verDefMap <- Either DynamicError VersionDefMap -> MemLoader w VersionDefMap
forall a (w :: Nat). Either DynamicError a -> MemLoader w a
runDynamic (Either DynamicError VersionDefMap -> MemLoader w VersionDefMap)
-> Either DynamicError VersionDefMap -> MemLoader w VersionDefMap
forall a b. (a -> b) -> a -> b
$ DynamicSection w
-> VirtAddrMap w -> Either DynamicError VersionDefMap
forall (w :: Nat).
DynamicSection w
-> VirtAddrMap w -> Either DynamicError VersionDefMap
Elf.dynVersionDefMap DynamicSection w
dynSection VirtAddrMap w
virtMap
            VersionDefMap
verReqMap <- Either DynamicError VersionDefMap -> MemLoader w VersionDefMap
forall a (w :: Nat). Either DynamicError a -> MemLoader w a
runDynamic (Either DynamicError VersionDefMap -> MemLoader w VersionDefMap)
-> Either DynamicError VersionDefMap -> MemLoader w VersionDefMap
forall a b. (a -> b) -> a -> b
$ DynamicSection w
-> VirtAddrMap w -> Either DynamicError VersionDefMap
forall (w :: Nat).
DynamicSection w
-> VirtAddrMap w -> Either DynamicError VersionDefMap
Elf.dynVersionReqMap DynamicSection w
dynSection VirtAddrMap w
virtMap
            let symtab :: SymbolTable w
symtab = DynamicSection w
-> VirtAddrMap w -> VersionDefMap -> VersionDefMap -> SymbolTable w
forall (w :: Nat).
DynamicSection w
-> VirtAddrMap w -> VersionDefMap -> VersionDefMap -> SymbolTable w
DynamicSymbolTable DynamicSection w
dynSection VirtAddrMap w
virtMap VersionDefMap
verDefMap VersionDefMap
verReqMap
            -- Parse relocations
            Maybe ByteString
mRelaBuffer <- Either DynamicError (Maybe ByteString)
-> MemLoader w (Maybe ByteString)
forall a (w :: Nat). Either DynamicError a -> MemLoader w a
runDynamic (Either DynamicError (Maybe ByteString)
 -> MemLoader w (Maybe ByteString))
-> Either DynamicError (Maybe ByteString)
-> MemLoader w (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ DynamicSection w
-> VirtAddrMap w -> Either DynamicError (Maybe ByteString)
forall (w :: Nat).
DynamicSection w
-> VirtAddrMap w -> Either DynamicError (Maybe ByteString)
Elf.dynRelaBuffer DynamicSection w
dynSection VirtAddrMap w
virtMap
            let rc0 :: Int
rc0 = if Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust Maybe ByteString
mRelaBuffer then Int
1 else Int
0
            Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
relocs0 <- Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
-> ElfData
-> RelocationResolver tp
-> SymbolTable w
-> Maybe ByteString
-> MemLoader
     w
     (Map
        (MemWord w)
        (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w))
forall tp (w :: Nat).
(IsRelocationType tp, w ~ RelocationWidth tp) =>
RelocMap w
-> ElfData
-> RelocationResolver tp
-> SymbolTable w
-> Maybe ByteString
-> MemLoader w (RelocMap w)
addElfRelaEntries Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
forall k a. Map k a
Map.empty ElfData
dta RelocationResolver tp
resolver SymbolTable w
symtab Maybe ByteString
mRelaBuffer

            Maybe ByteString
mRelBuffer  <- Either DynamicError (Maybe ByteString)
-> MemLoader w (Maybe ByteString)
forall a (w :: Nat). Either DynamicError a -> MemLoader w a
runDynamic (Either DynamicError (Maybe ByteString)
 -> MemLoader w (Maybe ByteString))
-> Either DynamicError (Maybe ByteString)
-> MemLoader w (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ DynamicSection w
-> VirtAddrMap w -> Either DynamicError (Maybe ByteString)
forall (w :: Nat).
DynamicSection w
-> VirtAddrMap w -> Either DynamicError (Maybe ByteString)
Elf.dynRelBuffer  DynamicSection w
dynSection VirtAddrMap w
virtMap
            let rc1 :: Int
rc1 = if Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust Maybe ByteString
mRelBuffer then Int
1 else Int
0
            Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
relocs1 <-Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
-> ElfData
-> RelocationResolver tp
-> SymbolTable w
-> Maybe ByteString
-> MemLoader
     w
     (Map
        (MemWord w)
        (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w))
forall tp (w :: Nat).
(IsRelocationType tp, w ~ RelocationWidth tp) =>
RelocMap w
-> ElfData
-> RelocationResolver tp
-> SymbolTable w
-> Maybe ByteString
-> MemLoader w (RelocMap w)
addElfRelEntries  Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
relocs0  ElfData
dta RelocationResolver tp
resolver SymbolTable w
symtab Maybe ByteString
mRelBuffer

            let dmap :: DynamicMap w
dmap = DynamicSection w -> DynamicMap w
forall (w :: Nat). DynamicSection w -> DynamicMap w
Elf.dynMap DynamicSection w
dynSection
            (Int
rc2,Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
relocs2) <- do
              let relocMap :: Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
relocMap = Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
relocs1
              let offTag :: ElfDynamicTag
offTag  = ElfDynamicTag
Elf.DT_ANDROID_RELA
              let sizeTag :: ElfDynamicTag
sizeTag = ElfDynamicTag
Elf.DT_ANDROID_RELASZ
              DynamicMap w
-> VirtAddrMap w
-> ElfDynamicTag
-> ElfDynamicTag
-> (Int,
    Map
      (MemWord w)
      (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w))
-> (Vector (RelaEntry tp)
    -> StateT
         (MemLoaderState w)
         (Except (LoadError w))
         (Int,
          Map
            (MemWord w)
            (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)))
-> StateT
     (MemLoaderState w)
     (Except (LoadError w))
     (Int,
      Map
        (MemWord w)
        (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w))
forall (w :: Nat) tp a.
(w ~ RelocationWidth tp, IsRelocationType tp) =>
DynamicMap w
-> VirtAddrMap w
-> ElfDynamicTag
-> ElfDynamicTag
-> a
-> (Vector (RelaEntry tp) -> MemLoader w a)
-> MemLoader w a
withAndroidRelaEntries DynamicMap w
dmap VirtAddrMap w
virtMap ElfDynamicTag
offTag ElfDynamicTag
sizeTag (Int
0,Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
relocMap) ((Vector (RelaEntry tp)
  -> StateT
       (MemLoaderState w)
       (Except (LoadError w))
       (Int,
        Map
          (MemWord w)
          (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)))
 -> StateT
      (MemLoaderState w)
      (Except (LoadError w))
      (Int,
       Map
         (MemWord w)
         (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)))
-> (Vector (RelaEntry tp)
    -> StateT
         (MemLoaderState w)
         (Except (LoadError w))
         (Int,
          Map
            (MemWord w)
            (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)))
-> StateT
     (MemLoaderState w)
     (Except (LoadError w))
     (Int,
      Map
        (MemWord w)
        (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w))
forall a b. (a -> b) -> a -> b
$ \Vector (RelaEntry tp)
entryVec -> do
                let entries :: [RelaEntry tp]
entries = Vector (RelaEntry tp) -> [RelaEntry tp]
forall a. Vector a -> [a]
V.toList Vector (RelaEntry tp)
entryVec
                Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
relocMap' <- Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
-> SymbolTable w
-> RelocationResolver tp
-> [RelaEntry tp]
-> MemLoader
     w
     (Map
        (MemWord w)
        (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w))
forall tp (w :: Nat).
(IsRelocationType tp, w ~ RelocationWidth tp) =>
RelocMap w
-> SymbolTable w
-> RelocationResolver tp
-> [RelaEntry tp]
-> MemLoader w (RelocMap w)
addRelaEntries Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
relocMap SymbolTable w
symtab RelocationResolver tp
resolver [RelaEntry tp]
entries
                (Int,
 Map
   (MemWord w)
   (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w))
-> StateT
     (MemLoaderState w)
     (Except (LoadError w))
     (Int,
      Map
        (MemWord w)
        (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w))
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Int
1, Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
relocMap')
            (Int
rc3,Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
relocs3) <- do
              let relocMap :: Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
relocMap = Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
relocs2
              let offTag :: ElfDynamicTag
offTag  = ElfDynamicTag
Elf.DT_ANDROID_REL
              let sizeTag :: ElfDynamicTag
sizeTag = ElfDynamicTag
Elf.DT_ANDROID_RELSZ
              DynamicMap w
-> VirtAddrMap w
-> ElfDynamicTag
-> ElfDynamicTag
-> (Int,
    Map
      (MemWord w)
      (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w))
-> (Vector (RelaEntry tp)
    -> StateT
         (MemLoaderState w)
         (Except (LoadError w))
         (Int,
          Map
            (MemWord w)
            (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)))
-> StateT
     (MemLoaderState w)
     (Except (LoadError w))
     (Int,
      Map
        (MemWord w)
        (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w))
forall (w :: Nat) tp a.
(w ~ RelocationWidth tp, IsRelocationType tp) =>
DynamicMap w
-> VirtAddrMap w
-> ElfDynamicTag
-> ElfDynamicTag
-> a
-> (Vector (RelaEntry tp) -> MemLoader w a)
-> MemLoader w a
withAndroidRelaEntries DynamicMap w
dmap VirtAddrMap w
virtMap ElfDynamicTag
offTag ElfDynamicTag
sizeTag (Int
0,Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
relocMap) ((Vector (RelaEntry tp)
  -> StateT
       (MemLoaderState w)
       (Except (LoadError w))
       (Int,
        Map
          (MemWord w)
          (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)))
 -> StateT
      (MemLoaderState w)
      (Except (LoadError w))
      (Int,
       Map
         (MemWord w)
         (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)))
-> (Vector (RelaEntry tp)
    -> StateT
         (MemLoaderState w)
         (Except (LoadError w))
         (Int,
          Map
            (MemWord w)
            (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)))
-> StateT
     (MemLoaderState w)
     (Except (LoadError w))
     (Int,
      Map
        (MemWord w)
        (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w))
forall a b. (a -> b) -> a -> b
$ \Vector (RelaEntry tp)
entryVec -> do
                Bool
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when ((RelaEntry tp -> Bool) -> Vector (RelaEntry tp) -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (\RelaEntry tp
r -> RelaEntry tp -> RelocationInt tp
forall tp. RelaEntry tp -> RelocationInt tp
Elf.relaAddend RelaEntry tp
r ElfIntType w -> ElfIntType w -> Bool
forall a. Eq a => a -> a -> Bool
/= ElfIntType w
0) Vector (RelaEntry tp)
entryVec) (StateT (MemLoaderState w) (Except (LoadError w)) ()
 -> StateT (MemLoaderState w) (Except (LoadError w)) ())
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
forall a b. (a -> b) -> a -> b
$ do
                  MemLoadWarning
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
forall (w :: Nat). MemLoadWarning -> MemLoader w ()
addWarning (MemLoadWarning
 -> StateT (MemLoaderState w) (Except (LoadError w)) ())
-> MemLoadWarning
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
forall a b. (a -> b) -> a -> b
$ MemLoadWarning
AndroidRelWithNonzeroAddend
                let entries :: [RelEntry tp]
entries = Vector (RelEntry tp) -> [RelEntry tp]
forall a. Vector a -> [a]
V.toList (Vector (RelEntry tp) -> [RelEntry tp])
-> Vector (RelEntry tp) -> [RelEntry tp]
forall a b. (a -> b) -> a -> b
$ RelaEntry tp -> RelEntry tp
forall tp. RelaEntry tp -> RelEntry tp
Elf.relaToRel (RelaEntry tp -> RelEntry tp)
-> Vector (RelaEntry tp) -> Vector (RelEntry tp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector (RelaEntry tp)
entryVec
                Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
relocMap' <- Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
-> ElfData
-> SymbolTable w
-> RelocationResolver tp
-> [RelEntry tp]
-> MemLoader
     w
     (Map
        (MemWord w)
        (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w))
forall tp (w :: Nat).
(IsRelocationType tp, w ~ RelocationWidth tp) =>
RelocMap w
-> ElfData
-> SymbolTable w
-> RelocationResolver tp
-> [RelEntry tp]
-> MemLoader w (RelocMap w)
addRelEntries Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
relocMap ElfData
dta SymbolTable w
symtab RelocationResolver tp
resolver [RelEntry tp]
entries
                (Int,
 Map
   (MemWord w)
   (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w))
-> StateT
     (MemLoaderState w)
     (Except (LoadError w))
     (Int,
      Map
        (MemWord w)
        (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w))
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Int
1, Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
relocMap')
            Bool
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Int
rc0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rc1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rc2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rc3 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> (Int
1 :: Int)) (StateT (MemLoaderState w) (Except (LoadError w)) ()
 -> StateT (MemLoaderState w) (Except (LoadError w)) ())
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
forall a b. (a -> b) -> a -> b
$ do
              MemLoadWarning
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
forall (w :: Nat). MemLoadWarning -> MemLoader w ()
addWarning (MemLoadWarning
 -> StateT (MemLoaderState w) (Except (LoadError w)) ())
-> MemLoadWarning
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
forall a b. (a -> b) -> a -> b
$ MemLoadWarning
MultipleRelocationTables

            case DynamicSection (RelocationWidth tp)
-> VirtAddrMap (RelocationWidth tp)
-> Either DynamicError (PLTEntries tp)
forall tp.
IsRelocationType tp =>
DynamicSection (RelocationWidth tp)
-> VirtAddrMap (RelocationWidth tp)
-> Either DynamicError (PLTEntries tp)
Elf.dynPLTRel DynamicSection w
DynamicSection (RelocationWidth tp)
dynSection VirtAddrMap w
VirtAddrMap (RelocationWidth tp)
virtMap of
              Left DynamicError
e -> do
                MemLoadWarning
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
forall (w :: Nat). MemLoadWarning -> MemLoader w ()
addWarning (MemLoadWarning
 -> StateT (MemLoaderState w) (Except (LoadError w)) ())
-> MemLoadWarning
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
forall a b. (a -> b) -> a -> b
$ [Char] -> MemLoadWarning
RelocationParseFailure (DynamicError -> [Char]
forall a. Show a => a -> [Char]
show DynamicError
e)
                Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
-> MemLoader
     w
     (Map
        (MemWord w)
        (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w))
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Map
   (MemWord w)
   (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
 -> MemLoader
      w
      (Map
         (MemWord w)
         (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)))
-> Map
     (MemWord w)
     (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
-> MemLoader
     w
     (Map
        (MemWord w)
        (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w))
forall a b. (a -> b) -> a -> b
$! Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
relocs1
              Right PLTEntries tp
Elf.PLTEmpty ->
                Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
-> MemLoader
     w
     (Map
        (MemWord w)
        (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w))
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Map
   (MemWord w)
   (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
 -> MemLoader
      w
      (Map
         (MemWord w)
         (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)))
-> Map
     (MemWord w)
     (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
-> MemLoader
     w
     (Map
        (MemWord w)
        (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w))
forall a b. (a -> b) -> a -> b
$! Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
relocs1
              Right (Elf.PLTRel [RelEntry tp]
entries) ->
                Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
-> ElfData
-> SymbolTable w
-> RelocationResolver tp
-> [RelEntry tp]
-> MemLoader
     w
     (Map
        (MemWord w)
        (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w))
forall tp (w :: Nat).
(IsRelocationType tp, w ~ RelocationWidth tp) =>
RelocMap w
-> ElfData
-> SymbolTable w
-> RelocationResolver tp
-> [RelEntry tp]
-> MemLoader w (RelocMap w)
addRelEntries Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
relocs3 ElfData
dta SymbolTable w
symtab RelocationResolver tp
resolver [RelEntry tp]
entries
              Right (Elf.PLTRela [RelaEntry tp]
entries) ->
                Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
-> SymbolTable w
-> RelocationResolver tp
-> [RelaEntry tp]
-> MemLoader
     w
     (Map
        (MemWord w)
        (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w))
forall tp (w :: Nat).
(IsRelocationType tp, w ~ RelocationWidth tp) =>
RelocMap w
-> SymbolTable w
-> RelocationResolver tp
-> [RelaEntry tp]
-> MemLoader w (RelocMap w)
addRelaEntries Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
relocs3 SymbolTable w
symtab RelocationResolver tp
resolver [RelaEntry tp]
entries

------------------------------------------------------------------------
-- Elf segment loading

reprConstraints :: AddrWidthRepr w
                -> ((Bits (ElfWordType w)
                    , Bounded  (Elf.ElfIntType w)
                    , Integral (Elf.ElfIntType w)
                    , Bounded  (Elf.ElfWordType w)
                    , Integral (Elf.ElfWordType w)
                    , Show (ElfWordType w)
                    , MemWidth w) => a)
                -> a
reprConstraints :: forall (w :: Nat) a.
AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    a)
-> a
reprConstraints AddrWidthRepr w
Addr32 (Bits (ElfWordType w), Bounded (ElfIntType w),
 Integral (ElfIntType w), Bounded (ElfWordType w),
 Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
a
x = a
(Bits (ElfWordType w), Bounded (ElfIntType w),
 Integral (ElfIntType w), Bounded (ElfWordType w),
 Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
a
x
reprConstraints AddrWidthRepr w
Addr64 (Bits (ElfWordType w), Bounded (ElfIntType w),
 Integral (ElfIntType w), Bounded (ElfWordType w),
 Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
a
x = a
(Bits (ElfWordType w), Bounded (ElfIntType w),
 Integral (ElfIntType w), Bounded (ElfWordType w),
 Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
a
x

-- | Load an elf file into memory.
insertElfSegment :: RegionIndex
                    -- ^ Region for elf segment
                 -> Integer
                    -- ^ Amount to add to linktime virtual address for this memory.
                 -> ElfFileSectionMap (Elf.FileOffset (ElfWordType w))
                 -> BS.ByteString
                    -- ^ Contents of elf file
                 -> Map (MemWord w) (RelocEntry (MemLoader w) w)
                    -- ^ Relocations to apply when inserting segment.
                 -> Elf.Phdr w
                 -> MemLoader w ()
insertElfSegment :: forall (w :: Nat).
Int
-> Integer
-> ElfFileSectionMap (FileOffset (ElfWordType w))
-> ByteString
-> Map (MemWord w) (RelocEntry (MemLoader w) w)
-> Phdr w
-> MemLoader w ()
insertElfSegment Int
regIdx Integer
addrOff ElfFileSectionMap (FileOffset (ElfWordType w))
shdrMap ByteString
contents Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
relocMap Phdr w
phdr = do
  AddrWidthRepr w
w <- LensLike' (Const (AddrWidthRepr w)) (MemLoaderState w) (Memory w)
-> (Memory w -> AddrWidthRepr w)
-> StateT
     (MemLoaderState w) (Except (LoadError w)) (AddrWidthRepr w)
forall s (m :: Type -> Type) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses LensLike' (Const (AddrWidthRepr w)) (MemLoaderState w) (Memory w)
forall (w :: Nat) (f :: Type -> Type).
Functor f =>
(Memory w -> f (Memory w))
-> MemLoaderState w -> f (MemLoaderState w)
mlsMemory Memory w -> AddrWidthRepr w
forall (w :: Nat). Memory w -> AddrWidthRepr w
memAddrWidth
  AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    MemLoader w ())
-> MemLoader w ()
forall (w :: Nat) a.
AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    a)
-> a
reprConstraints AddrWidthRepr w
w (((Bits (ElfWordType w), Bounded (ElfIntType w),
   Integral (ElfIntType w), Bounded (ElfWordType w),
   Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
  MemLoader w ())
 -> MemLoader w ())
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    MemLoader w ())
-> MemLoader w ()
forall a b. (a -> b) -> a -> b
$
   Bool -> MemLoader w () -> MemLoader w ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Phdr w -> ElfWordType w
forall (w :: Nat). Phdr w -> ElfWordType w
Elf.phdrMemSize Phdr w
phdr ElfWordType w -> ElfWordType w -> Bool
forall a. Ord a => a -> a -> Bool
> ElfWordType w
0) (MemLoader w () -> MemLoader w ())
-> MemLoader w () -> MemLoader w ()
forall a b. (a -> b) -> a -> b
$ do
    let segIdx :: Word16
segIdx = Phdr w -> Word16
forall (w :: Nat). Phdr w -> Word16
Elf.phdrSegmentIndex Phdr w
phdr
    MemSegment w
seg <- do
      let linkBaseOff :: MemWord w
linkBaseOff = ElfWordType w -> MemWord w
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Phdr w -> ElfWordType w
forall (w :: Nat). Phdr w -> ElfWordType w
Elf.phdrSegmentVirtAddr Phdr w
phdr)
      let flags :: Flags
flags = ElfSegmentFlags -> Flags
flagsForSegmentFlags (Phdr w -> ElfSegmentFlags
forall (w :: Nat). Phdr w -> ElfSegmentFlags
Elf.phdrSegmentFlags Phdr w
phdr)
      let dta :: ByteString
dta = FileRange (ElfWordType w) -> ByteString -> ByteString
forall w. Integral w => FileRange w -> ByteString -> ByteString
slice (Phdr w -> FileRange (ElfWordType w)
forall (w :: Nat). Phdr w -> FileRange (ElfWordType w)
Elf.phdrFileRange Phdr w
phdr) ByteString
contents
      let sz :: MemWord w
sz = ElfWordType w -> MemWord w
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ElfWordType w -> MemWord w) -> ElfWordType w -> MemWord w
forall a b. (a -> b) -> a -> b
$ Phdr w -> ElfWordType w
forall (w :: Nat). Phdr w -> ElfWordType w
Elf.phdrMemSize Phdr w
phdr
      Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
-> Int
-> Integer
-> Maybe Word16
-> MemWord w
-> Flags
-> ByteString
-> MemWord w
-> StateT (MemLoaderState w) (Except (LoadError w)) (MemSegment w)
forall (m :: Type -> Type) (w :: Nat).
(Monad m, MemWidth w) =>
Map (MemWord w) (RelocEntry m w)
-> Int
-> Integer
-> Maybe Word16
-> MemWord w
-> Flags
-> ByteString
-> MemWord w
-> m (MemSegment w)
memSegment Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
relocMap Int
regIdx Integer
addrOff (Word16 -> Maybe Word16
forall a. a -> Maybe a
Just Word16
segIdx) MemWord w
linkBaseOff Flags
flags ByteString
dta MemWord w
sz
    [Char] -> MemSegment w -> MemLoader w ()
forall (w :: Nat).
MemWidth w =>
[Char] -> MemSegment w -> MemLoader w ()
loadMemSegment ([Char]
"Segment " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Word16 -> [Char]
forall a. Show a => a -> [Char]
show Word16
segIdx) MemSegment w
seg
    let phdrOffset :: FileOffset (ElfWordType w)
phdrOffset = Phdr w -> FileOffset (ElfWordType w)
forall (w :: Nat). Phdr w -> FileOffset (ElfWordType w)
Elf.phdrFileStart Phdr w
phdr
    let phdrEnd :: FileOffset (ElfWordType w)
phdrEnd = FileOffset (ElfWordType w)
phdrOffset FileOffset (ElfWordType w)
-> ElfWordType w -> FileOffset (ElfWordType w)
forall w. Num w => FileOffset w -> w -> FileOffset w
`Elf.incOffset` Phdr w -> ElfWordType w
forall (w :: Nat). Phdr w -> ElfWordType w
Elf.phdrFileSize Phdr w
phdr
    -- Add segment index to address mapping to memory object.
    (Memory w -> Identity (Memory w))
-> MemLoaderState w -> Identity (MemLoaderState w)
forall (w :: Nat) (f :: Type -> Type).
Functor f =>
(Memory w -> f (Memory w))
-> MemLoaderState w -> f (MemLoaderState w)
mlsMemory ((Memory w -> Identity (Memory w))
 -> MemLoaderState w -> Identity (MemLoaderState w))
-> (Memory w -> Memory w) -> MemLoader w ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Word16 -> MemSegment w -> Memory w -> Memory w
forall (w :: Nat). Word16 -> MemSegment w -> Memory w -> Memory w
memBindSegmentIndex Word16
segIdx MemSegment w
seg
    -- Iterative through sections
    let l :: [(Interval (FileOffset (ElfWordType w)), Word16)]
l = ElfFileSectionMap (FileOffset (ElfWordType w))
-> [(Interval (FileOffset (ElfWordType w)), Word16)]
forall k v. IntervalMap k v -> [(k, v)]
IMap.toList (ElfFileSectionMap (FileOffset (ElfWordType w))
 -> [(Interval (FileOffset (ElfWordType w)), Word16)])
-> ElfFileSectionMap (FileOffset (ElfWordType w))
-> [(Interval (FileOffset (ElfWordType w)), Word16)]
forall a b. (a -> b) -> a -> b
$ ElfFileSectionMap (FileOffset (ElfWordType w))
-> Interval (FileOffset (ElfWordType w))
-> ElfFileSectionMap (FileOffset (ElfWordType w))
forall k e v.
Interval k e =>
IntervalMap k v -> k -> IntervalMap k v
IMap.intersecting ElfFileSectionMap (FileOffset (ElfWordType w))
shdrMap (FileOffset (ElfWordType w)
-> FileOffset (ElfWordType w)
-> Interval (FileOffset (ElfWordType w))
forall a. a -> a -> Interval a
IntervalCO FileOffset (ElfWordType w)
phdrOffset FileOffset (ElfWordType w)
phdrEnd)
    [(Interval (FileOffset (ElfWordType w)), Word16)]
-> ((Interval (FileOffset (ElfWordType w)), Word16)
    -> MemLoader w ())
-> MemLoader w ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Interval (FileOffset (ElfWordType w)), Word16)]
l (((Interval (FileOffset (ElfWordType w)), Word16)
  -> MemLoader w ())
 -> MemLoader w ())
-> ((Interval (FileOffset (ElfWordType w)), Word16)
    -> MemLoader w ())
-> MemLoader w ()
forall a b. (a -> b) -> a -> b
$ \(Interval (FileOffset (ElfWordType w))
i, Word16
elfIdx) -> do
      case Interval (FileOffset (ElfWordType w))
i of
        IntervalCO FileOffset (ElfWordType w)
shdr_start FileOffset (ElfWordType w)
_
          | FileOffset (ElfWordType w)
phdrOffset FileOffset (ElfWordType w) -> FileOffset (ElfWordType w) -> Bool
forall a. Ord a => a -> a -> Bool
> FileOffset (ElfWordType w)
shdr_start ->
              MemLoadWarning -> MemLoader w ()
forall (w :: Nat). MemLoadWarning -> MemLoader w ()
addWarning MemLoadWarning
ShdrPhdrOverlap
          | Bool
otherwise -> do
              let sec_offset :: MemWord w
sec_offset = FileOffset (ElfWordType w) -> MemWord w
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FileOffset (ElfWordType w) -> MemWord w)
-> FileOffset (ElfWordType w) -> MemWord w
forall a b. (a -> b) -> a -> b
$ FileOffset (ElfWordType w)
shdr_start FileOffset (ElfWordType w)
-> FileOffset (ElfWordType w) -> FileOffset (ElfWordType w)
forall a. Num a => a -> a -> a
- FileOffset (ElfWordType w)
phdrOffset
              MemSegmentOff w
addr <- case MemSegment w -> MemWord w -> Maybe (MemSegmentOff w)
forall (w :: Nat).
MemWidth w =>
MemSegment w -> MemWord w -> Maybe (MemSegmentOff w)
resolveSegmentOff MemSegment w
seg MemWord w
sec_offset of
                        Just MemSegmentOff w
addr -> MemSegmentOff w
-> StateT
     (MemLoaderState w) (Except (LoadError w)) (MemSegmentOff w)
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure MemSegmentOff w
addr
                        Maybe (MemSegmentOff w)
Nothing -> [Char]
-> StateT
     (MemLoaderState w) (Except (LoadError w)) (MemSegmentOff w)
forall a. HasCallStack => [Char] -> a
error ([Char]
 -> StateT
      (MemLoaderState w) (Except (LoadError w)) (MemSegmentOff w))
-> [Char]
-> StateT
     (MemLoaderState w) (Except (LoadError w)) (MemSegmentOff w)
forall a b. (a -> b) -> a -> b
$ [Char]
"insertElfSegment: Failed to resolve segment offset at "
                                        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ MemWord w -> [Char]
forall a. Show a => a -> [Char]
show MemWord w
sec_offset
              (Memory w -> Identity (Memory w))
-> MemLoaderState w -> Identity (MemLoaderState w)
forall (w :: Nat) (f :: Type -> Type).
Functor f =>
(Memory w -> f (Memory w))
-> MemLoaderState w -> f (MemLoaderState w)
mlsMemory   ((Memory w -> Identity (Memory w))
 -> MemLoaderState w -> Identity (MemLoaderState w))
-> (Memory w -> Memory w) -> MemLoader w ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Word16 -> MemSegmentOff w -> Memory w -> Memory w
forall (w :: Nat).
Word16 -> MemSegmentOff w -> Memory w -> Memory w
memBindSectionIndex Word16
elfIdx MemSegmentOff w
addr
              (SectionIndexMap w -> Identity (SectionIndexMap w))
-> MemLoaderState w -> Identity (MemLoaderState w)
forall (w :: Nat) (f :: Type -> Type).
Functor f =>
(SectionIndexMap w -> f (SectionIndexMap w))
-> MemLoaderState w -> f (MemLoaderState w)
mlsIndexMap ((SectionIndexMap w -> Identity (SectionIndexMap w))
 -> MemLoaderState w -> Identity (MemLoaderState w))
-> (SectionIndexMap w -> SectionIndexMap w) -> MemLoader w ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Word16 -> MemSegmentOff w -> SectionIndexMap w -> SectionIndexMap w
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Word16
elfIdx MemSegmentOff w
addr
        Interval (FileOffset (ElfWordType w))
_ -> [Char] -> MemLoader w ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Unexpected shdr interval"

-- | Load an elf file into memory by parsing segments.
memoryForElfSegments'
  :: forall w
  .  RegionIndex
  -> Integer
  -> Elf.ElfHeaderInfo w
  -> Either String (Memory w -- Memory
                   , SectionIndexMap w -- Section index map
                   , [MemLoadWarning] -- Warnings from load
                   )
memoryForElfSegments' :: forall (w :: Nat).
Int
-> Integer
-> ElfHeaderInfo w
-> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning])
memoryForElfSegments' Int
regIndex Integer
addrOff ElfHeaderInfo w
elf = do
  let hdr :: ElfHeader w
hdr = ElfHeaderInfo w -> ElfHeader w
forall (w :: Nat). ElfHeaderInfo w -> ElfHeader w
Elf.header ElfHeaderInfo w
elf
  let cl :: ElfClass w
cl = ElfHeader w -> ElfClass w
forall (w :: Nat). ElfHeader w -> ElfClass w
Elf.headerClass ElfHeader w
hdr
  let w :: AddrWidthRepr w
w =  ElfClass w -> AddrWidthRepr w
forall (w :: Nat). ElfClass w -> AddrWidthRepr w
elfAddrWidth ElfClass w
cl
  let contents :: ByteString
contents = ElfHeaderInfo w -> ByteString
forall (w :: Nat). ElfHeaderInfo w -> ByteString
Elf.headerFileContents ElfHeaderInfo w
elf
  let phdrs :: Vector (Phdr w)
phdrs = Int -> (Int -> Phdr w) -> Vector (Phdr w)
forall a. Int -> (Int -> a) -> Vector a
V.generate (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ElfHeaderInfo w -> Word16
forall (w :: Nat). ElfHeaderInfo w -> Word16
Elf.phdrCount ElfHeaderInfo w
elf)) ((Int -> Phdr w) -> Vector (Phdr w))
-> (Int -> Phdr w) -> Vector (Phdr w)
forall a b. (a -> b) -> a -> b
$ \Int
i ->
                ElfHeaderInfo w -> Word16 -> Phdr w
forall (w :: Nat). ElfHeaderInfo w -> Word16 -> Phdr w
Elf.phdrByIndex ElfHeaderInfo w
elf (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)

  Endianness
-> Memory w
-> MemLoader w ()
-> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning])
forall (w :: Nat).
Endianness
-> Memory w
-> MemLoader w ()
-> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning])
runMemLoader (ElfData -> Endianness
toEndianness (ElfHeader w -> ElfData
forall (w :: Nat). ElfHeader w -> ElfData
Elf.headerData ElfHeader w
hdr)) (AddrWidthRepr w -> Memory w
forall (w :: Nat). AddrWidthRepr w -> Memory w
emptyMemory AddrWidthRepr w
w) (MemLoader w ()
 -> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning]))
-> MemLoader w ()
-> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning])
forall a b. (a -> b) -> a -> b
$ AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    MemLoader w ())
-> MemLoader w ()
forall (w :: Nat) a.
AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    a)
-> a
reprConstraints AddrWidthRepr w
w (((Bits (ElfWordType w), Bounded (ElfIntType w),
   Integral (ElfIntType w), Bounded (ElfWordType w),
   Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
  MemLoader w ())
 -> MemLoader w ())
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    MemLoader w ())
-> MemLoader w ()
forall a b. (a -> b) -> a -> b
$ do
      -- Create relocation map
      Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
relocMap <- ElfHeader w
-> Vector (Phdr w)
-> ByteString
-> MemLoader
     w
     (Map
        (MemWord w)
        (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w))
forall (w :: Nat).
ElfHeader w
-> Vector (Phdr w)
-> ByteString
-> MemLoader w (Map (MemWord w) (RelocEntry (MemLoader w) w))
dynamicRelocationMap ElfHeader w
hdr Vector (Phdr w)
phdrs ByteString
contents
      let intervals :: ElfFileSectionMap (Elf.FileOffset (ElfWordType w))
          intervals :: ElfFileSectionMap (FileOffset (ElfWordType w))
intervals = [(Interval (FileOffset (ElfWordType w)), Word16)]
-> ElfFileSectionMap (FileOffset (ElfWordType w))
forall k e v. (Interval k e, Ord k) => [(k, v)] -> IntervalMap k v
IMap.fromList ([(Interval (FileOffset (ElfWordType w)), Word16)]
 -> ElfFileSectionMap (FileOffset (ElfWordType w)))
-> [(Interval (FileOffset (ElfWordType w)), Word16)]
-> ElfFileSectionMap (FileOffset (ElfWordType w))
forall a b. (a -> b) -> a -> b
$
            [ (FileOffset (ElfWordType w)
-> FileOffset (ElfWordType w)
-> Interval (FileOffset (ElfWordType w))
forall a. a -> a -> Interval a
IntervalCO (Shdr Word32 (ElfWordType w) -> FileOffset (ElfWordType w)
forall nm w. Shdr nm w -> FileOffset w
Elf.shdrOff Shdr Word32 (ElfWordType w)
shdr) FileOffset (ElfWordType w)
end, Word16
idxWord16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
-Word16
1)
            | Word16
idx <- [Word16
1..ElfHeaderInfo w -> Word16
forall (w :: Nat). ElfHeaderInfo w -> Word16
Elf.shdrCount ElfHeaderInfo w
elf]
            , let shdr :: Shdr Word32 (ElfWordType w)
shdr = ElfHeaderInfo w -> Word16 -> Shdr Word32 (ElfWordType w)
forall (w :: Nat).
ElfHeaderInfo w -> Word16 -> Shdr Word32 (ElfWordType w)
Elf.shdrByIndex ElfHeaderInfo w
elf (Word16
idxWord16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
-Word16
1)
            , let end :: FileOffset (ElfWordType w)
end = FileOffset (ElfWordType w)
-> ElfWordType w -> FileOffset (ElfWordType w)
forall w. Num w => FileOffset w -> w -> FileOffset w
Elf.incOffset (Shdr Word32 (ElfWordType w) -> FileOffset (ElfWordType w)
forall nm w. Shdr nm w -> FileOffset w
Elf.shdrOff Shdr Word32 (ElfWordType w)
shdr) (Shdr Word32 (ElfWordType w) -> ElfWordType w
forall w nm. Num w => Shdr nm w -> w
Elf.shdrFileSize Shdr Word32 (ElfWordType w)
shdr)
            ]
      Vector (Phdr w) -> (Phdr w -> MemLoader w ()) -> MemLoader w ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Vector (Phdr w)
phdrs ((Phdr w -> MemLoader w ()) -> MemLoader w ())
-> (Phdr w -> MemLoader w ()) -> MemLoader w ()
forall a b. (a -> b) -> a -> b
$ \Phdr w
p -> do
        Bool -> MemLoader w () -> MemLoader w ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Phdr w -> PhdrType
forall (w :: Nat). Phdr w -> PhdrType
Elf.phdrSegmentType Phdr w
p PhdrType -> PhdrType -> Bool
forall a. Eq a => a -> a -> Bool
== PhdrType
Elf.PT_LOAD) (MemLoader w () -> MemLoader w ())
-> MemLoader w () -> MemLoader w ()
forall a b. (a -> b) -> a -> b
$ do
          Int
-> Integer
-> ElfFileSectionMap (FileOffset (ElfWordType w))
-> ByteString
-> Map
     (MemWord w)
     (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
-> Phdr w
-> MemLoader w ()
forall (w :: Nat).
Int
-> Integer
-> ElfFileSectionMap (FileOffset (ElfWordType w))
-> ByteString
-> Map (MemWord w) (RelocEntry (MemLoader w) w)
-> Phdr w
-> MemLoader w ()
insertElfSegment Int
regIndex Integer
addrOff ElfFileSectionMap (FileOffset (ElfWordType w))
intervals ByteString
contents Map
  (MemWord w)
  (RelocEntry (StateT (MemLoaderState w) (Except (LoadError w))) w)
relocMap Phdr w
p

-- | Load an elf file into memory by parsing segments.
memoryForElfSegments
  :: forall w
  .  LoadOptions
  -> Elf.ElfHeaderInfo w
  -> Either String (Memory w -- Memory
                   , SectionIndexMap w -- Section index map
                   , [MemLoadWarning] -- Warnings from load
                   )
memoryForElfSegments :: forall (w :: Nat).
LoadOptions
-> ElfHeaderInfo w
-> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning])
memoryForElfSegments LoadOptions
opt ElfHeaderInfo w
elf = do
  let regIndex :: Int
regIndex = ElfType -> LoadOptions -> Int
adjustedLoadRegionIndex (ElfHeader w -> ElfType
forall (w :: Nat). ElfHeader w -> ElfType
Elf.headerType (ElfHeaderInfo w -> ElfHeader w
forall (w :: Nat). ElfHeaderInfo w -> ElfHeader w
Elf.header ElfHeaderInfo w
elf)) LoadOptions
opt
  let addrOff :: Integer
addrOff = LoadOptions -> Integer
loadRegionBaseOffset LoadOptions
opt
  Int
-> Integer
-> ElfHeaderInfo w
-> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning])
forall (w :: Nat).
Int
-> Integer
-> ElfHeaderInfo w
-> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning])
memoryForElfSegments' Int
regIndex Integer
addrOff ElfHeaderInfo w
elf

------------------------------------------------------------------------
-- Elf section loading

-- | Contains the name of a section we allocate and whether
-- relocations are used.
type AllocatedSectionInfo = (BS.ByteString, Bool)

allocatedNames :: AllocatedSectionInfo -> [BS.ByteString]
allocatedNames :: AllocatedSectionInfo -> [ByteString]
allocatedNames (ByteString
nm,Bool
False) = [ByteString
nm]
allocatedNames (ByteString
nm,Bool
True) = [ByteString
nm, ByteString
".rela" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
nm]

allocatedSectionInfo :: [AllocatedSectionInfo]
allocatedSectionInfo :: [AllocatedSectionInfo]
allocatedSectionInfo =
  [ (,) ByteString
".text"     Bool
True
  , (,) ByteString
".eh_frame" Bool
True
  , (,) ByteString
".data"     Bool
True
  , (,) ByteString
".bss"      Bool
False
  , (,) ByteString
".rodata"   Bool
True
  ]

allowedSectionNames :: Set BS.ByteString
allowedSectionNames :: Set ByteString
allowedSectionNames = [ByteString] -> Set ByteString
forall a. Ord a => [a] -> Set a
Set.fromList
  ([ByteString] -> Set ByteString) -> [ByteString] -> Set ByteString
forall a b. (a -> b) -> a -> b
$ (AllocatedSectionInfo -> [ByteString])
-> [AllocatedSectionInfo] -> [ByteString]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap AllocatedSectionInfo -> [ByteString]
allocatedNames [AllocatedSectionInfo]
allocatedSectionInfo
  [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ ByteString
""
     , ByteString
".text.hot"
     , ByteString
".text.unlikely"
     , ByteString
".tbss"
     , ByteString
".tdata", ByteString
".rela.tdata"
     , ByteString
".comment"
     , ByteString
".note.GNU-stack"
     , ByteString
".shstrtab"
     , ByteString
".symtab"
     , ByteString
".strtab"
     , ByteString
".llvm_addrsig"
     ]

-- | Map from section names to index and section header.
type ShdrNameMap w =  Map SectionName [(Word16, Elf.Shdr Word32 (ElfWordType w))]

findShdr ::ShdrNameMap w
         -> SectionName
         -> MemLoader w (Maybe (Word16, Elf.Shdr Word32 (ElfWordType w)))
findShdr :: forall (w :: Nat).
ShdrNameMap w
-> ByteString
-> MemLoader w (Maybe (Word16, Shdr Word32 (ElfWordType w)))
findShdr ShdrNameMap w
shdrMap ByteString
nm =
  case ByteString
-> ShdrNameMap w -> Maybe [(Word16, Shdr Word32 (ElfWordType w))]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
nm ShdrNameMap w
shdrMap of
    Maybe [(Word16, Shdr Word32 (ElfWordType w))]
Nothing -> Maybe (Word16, Shdr Word32 (ElfWordType w))
-> MemLoader w (Maybe (Word16, Shdr Word32 (ElfWordType w)))
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe (Word16, Shdr Word32 (ElfWordType w))
forall a. Maybe a
Nothing
    Just [] -> Maybe (Word16, Shdr Word32 (ElfWordType w))
-> MemLoader w (Maybe (Word16, Shdr Word32 (ElfWordType w)))
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe (Word16, Shdr Word32 (ElfWordType w))
forall a. Maybe a
Nothing
    Just ((Word16, Shdr Word32 (ElfWordType w))
s:[(Word16, Shdr Word32 (ElfWordType w))]
rest) -> do
      Bool
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([(Word16, Shdr Word32 (ElfWordType w))] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [(Word16, Shdr Word32 (ElfWordType w))]
rest)) (StateT (MemLoaderState w) (Except (LoadError w)) ()
 -> StateT (MemLoaderState w) (Except (LoadError w)) ())
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
forall a b. (a -> b) -> a -> b
$ do
        MemLoadWarning
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
forall (w :: Nat). MemLoadWarning -> MemLoader w ()
addWarning (MemLoadWarning
 -> StateT (MemLoaderState w) (Except (LoadError w)) ())
-> MemLoadWarning
-> StateT (MemLoaderState w) (Except (LoadError w)) ()
forall a b. (a -> b) -> a -> b
$ ByteString -> MemLoadWarning
MultipleSectionsWithName ByteString
nm
      Maybe (Word16, Shdr Word32 (ElfWordType w))
-> MemLoader w (Maybe (Word16, Shdr Word32 (ElfWordType w)))
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Word16, Shdr Word32 (ElfWordType w))
-> Maybe (Word16, Shdr Word32 (ElfWordType w))
forall a. a -> Maybe a
Just (Word16, Shdr Word32 (ElfWordType w))
s)

shdrData :: Integral w => BS.ByteString -> Elf.Shdr nm w -> BS.ByteString
shdrData :: forall w nm. Integral w => ByteString -> Shdr nm w -> ByteString
shdrData ByteString
contents Shdr nm w
shdr = FileRange w -> ByteString -> ByteString
forall w. Integral w => FileRange w -> ByteString -> ByteString
slice (Shdr nm w -> FileRange w
forall w nm. Num w => Shdr nm w -> FileRange w
Elf.shdrFileRange Shdr nm w
shdr) ByteString
contents

-- | Add a section to the current memory
insertAllocatedShdr :: Elf.ElfHeader w
                    -> BS.ByteString -- ^ File contents
                    -> SymbolTable w
                    -> ShdrNameMap w
                    -> RegionIndex
                       -- ^ Region for section (should be unique)
                    -> SectionName
                       -- ^ Name of section
                    -> MemLoader w ()
insertAllocatedShdr :: forall (w :: Nat).
ElfHeader w
-> ByteString
-> SymbolTable w
-> ShdrNameMap w
-> Int
-> ByteString
-> MemLoader w ()
insertAllocatedShdr ElfHeader w
hdr ByteString
contents SymbolTable w
symtab ShdrNameMap w
shdrMap Int
regIdx ByteString
nm = do
  AddrWidthRepr w
w <- LensLike' (Const (AddrWidthRepr w)) (MemLoaderState w) (Memory w)
-> (Memory w -> AddrWidthRepr w)
-> StateT
     (MemLoaderState w) (Except (LoadError w)) (AddrWidthRepr w)
forall s (m :: Type -> Type) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses LensLike' (Const (AddrWidthRepr w)) (MemLoaderState w) (Memory w)
forall (w :: Nat) (f :: Type -> Type).
Functor f =>
(Memory w -> f (Memory w))
-> MemLoaderState w -> f (MemLoaderState w)
mlsMemory Memory w -> AddrWidthRepr w
forall (w :: Nat). Memory w -> AddrWidthRepr w
memAddrWidth
  AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    MemLoader w ())
-> MemLoader w ()
forall (w :: Nat) a.
AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    a)
-> a
reprConstraints AddrWidthRepr w
w (((Bits (ElfWordType w), Bounded (ElfIntType w),
   Integral (ElfIntType w), Bounded (ElfWordType w),
   Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
  MemLoader w ())
 -> MemLoader w ())
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    MemLoader w ())
-> MemLoader w ()
forall a b. (a -> b) -> a -> b
$ do
   Maybe (Word16, Shdr Word32 (ElfWordType w))
mshdr <- ShdrNameMap w
-> ByteString
-> StateT
     (MemLoaderState w)
     (Except (LoadError w))
     (Maybe (Word16, Shdr Word32 (ElfWordType w)))
forall (w :: Nat).
ShdrNameMap w
-> ByteString
-> MemLoader w (Maybe (Word16, Shdr Word32 (ElfWordType w)))
findShdr ShdrNameMap w
shdrMap ByteString
nm
   case Maybe (Word16, Shdr Word32 (ElfWordType w))
mshdr of
    Maybe (Word16, Shdr Word32 (ElfWordType w))
Nothing -> () -> MemLoader w ()
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
    Just (Word16
idx, Shdr Word32 (ElfWordType w)
shdr) -> do
      Maybe ByteString
mRelBuffer  <- (Maybe (Word16, Shdr Word32 (ElfWordType w)) -> Maybe ByteString)
-> StateT
     (MemLoaderState w)
     (Except (LoadError w))
     (Maybe (Word16, Shdr Word32 (ElfWordType w)))
-> StateT
     (MemLoaderState w) (Except (LoadError w)) (Maybe ByteString)
forall a b.
(a -> b)
-> StateT (MemLoaderState w) (Except (LoadError w)) a
-> StateT (MemLoaderState w) (Except (LoadError w)) b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Word16, Shdr Word32 (ElfWordType w)) -> ByteString)
-> Maybe (Word16, Shdr Word32 (ElfWordType w)) -> Maybe ByteString
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Shdr Word32 (ElfWordType w) -> ByteString
forall w nm. Integral w => ByteString -> Shdr nm w -> ByteString
shdrData ByteString
contents (Shdr Word32 (ElfWordType w) -> ByteString)
-> ((Word16, Shdr Word32 (ElfWordType w))
    -> Shdr Word32 (ElfWordType w))
-> (Word16, Shdr Word32 (ElfWordType w))
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word16, Shdr Word32 (ElfWordType w))
-> Shdr Word32 (ElfWordType w)
forall a b. (a, b) -> b
snd)) (StateT
   (MemLoaderState w)
   (Except (LoadError w))
   (Maybe (Word16, Shdr Word32 (ElfWordType w)))
 -> StateT
      (MemLoaderState w) (Except (LoadError w)) (Maybe ByteString))
-> StateT
     (MemLoaderState w)
     (Except (LoadError w))
     (Maybe (Word16, Shdr Word32 (ElfWordType w)))
-> StateT
     (MemLoaderState w) (Except (LoadError w)) (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ShdrNameMap w
-> ByteString
-> StateT
     (MemLoaderState w)
     (Except (LoadError w))
     (Maybe (Word16, Shdr Word32 (ElfWordType w)))
forall (w :: Nat).
ShdrNameMap w
-> ByteString
-> MemLoader w (Maybe (Word16, Shdr Word32 (ElfWordType w)))
findShdr ShdrNameMap w
shdrMap (ByteString
".rel" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
nm)
      Maybe ByteString
mRelaBuffer <- (Maybe (Word16, Shdr Word32 (ElfWordType w)) -> Maybe ByteString)
-> StateT
     (MemLoaderState w)
     (Except (LoadError w))
     (Maybe (Word16, Shdr Word32 (ElfWordType w)))
-> StateT
     (MemLoaderState w) (Except (LoadError w)) (Maybe ByteString)
forall a b.
(a -> b)
-> StateT (MemLoaderState w) (Except (LoadError w)) a
-> StateT (MemLoaderState w) (Except (LoadError w)) b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Word16, Shdr Word32 (ElfWordType w)) -> ByteString)
-> Maybe (Word16, Shdr Word32 (ElfWordType w)) -> Maybe ByteString
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Shdr Word32 (ElfWordType w) -> ByteString
forall w nm. Integral w => ByteString -> Shdr nm w -> ByteString
shdrData ByteString
contents (Shdr Word32 (ElfWordType w) -> ByteString)
-> ((Word16, Shdr Word32 (ElfWordType w))
    -> Shdr Word32 (ElfWordType w))
-> (Word16, Shdr Word32 (ElfWordType w))
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word16, Shdr Word32 (ElfWordType w))
-> Shdr Word32 (ElfWordType w)
forall a b. (a, b) -> b
snd)) (StateT
   (MemLoaderState w)
   (Except (LoadError w))
   (Maybe (Word16, Shdr Word32 (ElfWordType w)))
 -> StateT
      (MemLoaderState w) (Except (LoadError w)) (Maybe ByteString))
-> StateT
     (MemLoaderState w)
     (Except (LoadError w))
     (Maybe (Word16, Shdr Word32 (ElfWordType w)))
-> StateT
     (MemLoaderState w) (Except (LoadError w)) (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ShdrNameMap w
-> ByteString
-> StateT
     (MemLoaderState w)
     (Except (LoadError w))
     (Maybe (Word16, Shdr Word32 (ElfWordType w)))
forall (w :: Nat).
ShdrNameMap w
-> ByteString
-> MemLoader w (Maybe (Word16, Shdr Word32 (ElfWordType w)))
findShdr ShdrNameMap w
shdrMap (ByteString
".rela" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
nm)
      -- Build relocation map
      -- Get size of section
      let secSize :: ElfWordType w
secSize = Shdr Word32 (ElfWordType w) -> ElfWordType w
forall nm w. Shdr nm w -> w
Elf.shdrSize Shdr Word32 (ElfWordType w)
shdr
      -- Check if we should load section
      Bool -> MemLoader w () -> MemLoader w ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Shdr Word32 (ElfWordType w) -> ElfSectionFlags (ElfWordType w)
forall nm w. Shdr nm w -> ElfSectionFlags w
Elf.shdrFlags Shdr Word32 (ElfWordType w)
shdr ElfSectionFlags (ElfWordType w)
-> ElfSectionFlags (ElfWordType w) -> Bool
forall b. Bits b => b -> b -> Bool
`Elf.hasPermissions` ElfSectionFlags (ElfWordType w)
forall w. Num w => ElfSectionFlags w
Elf.shf_alloc)) (MemLoader w () -> MemLoader w ())
-> MemLoader w () -> MemLoader w ()
forall a b. (a -> b) -> a -> b
$ do
        MemLoadWarning -> MemLoader w ()
forall (w :: Nat). MemLoadWarning -> MemLoader w ()
addWarning (MemLoadWarning -> MemLoader w ())
-> MemLoadWarning -> MemLoader w ()
forall a b. (a -> b) -> a -> b
$ ByteString -> MemLoadWarning
SectionNotAlloc ByteString
nm
      Bool -> MemLoader w () -> MemLoader w ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (ElfWordType w
secSize ElfWordType w -> ElfWordType w -> Bool
forall a. Ord a => a -> a -> Bool
> ElfWordType w
0) (MemLoader w () -> MemLoader w ())
-> MemLoader w () -> MemLoader w ()
forall a b. (a -> b) -> a -> b
$ do
        -- Get base address
        let base :: ElfWordType w
base = Shdr Word32 (ElfWordType w) -> ElfWordType w
forall nm w. Shdr nm w -> w
Elf.shdrAddr Shdr Word32 (ElfWordType w)
shdr
        -- Get section flags
        let flags :: Flags
flags = ElfSectionFlags (ElfWordType w) -> Flags
forall w. (Num w, Bits w) => ElfSectionFlags w -> Flags
flagsForSectionFlags (Shdr Word32 (ElfWordType w) -> ElfSectionFlags (ElfWordType w)
forall nm w. Shdr nm w -> ElfSectionFlags w
Elf.shdrFlags Shdr Word32 (ElfWordType w)
shdr)
        -- Get bytes in section
        let bytes :: ByteString
bytes = ByteString -> Shdr Word32 (ElfWordType w) -> ByteString
forall w nm. Integral w => ByteString -> Shdr nm w -> ByteString
shdrData ByteString
contents Shdr Word32 (ElfWordType w)
shdr
        -- Create memory segment
        SomeRelocationResolver RelocationResolver tp
resolver <- ElfHeader w -> MemLoader w (SomeRelocationResolver w)
forall (w :: Nat).
ElfHeader w -> MemLoader w (SomeRelocationResolver w)
getRelocationResolver ElfHeader w
hdr
        Bool -> MemLoader w () -> MemLoader w ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust Maybe ByteString
mRelBuffer Bool -> Bool -> Bool
&& Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust Maybe ByteString
mRelaBuffer) (MemLoader w () -> MemLoader w ())
-> MemLoader w () -> MemLoader w ()
forall a b. (a -> b) -> a -> b
$ do
          MemLoadWarning -> MemLoader w ()
forall (w :: Nat). MemLoadWarning -> MemLoader w ()
addWarning (MemLoadWarning -> MemLoader w ())
-> MemLoadWarning -> MemLoader w ()
forall a b. (a -> b) -> a -> b
$ MemLoadWarning
MultipleRelocationTables
        RelocMap w
relocMap <- do
          let dta :: ElfData
dta = ElfHeader w -> ElfData
forall (w :: Nat). ElfHeader w -> ElfData
Elf.headerData ElfHeader w
hdr
          RelocMap w
m1 <- RelocMap w
-> ElfData
-> RelocationResolver tp
-> SymbolTable w
-> Maybe ByteString
-> StateT (MemLoaderState w) (Except (LoadError w)) (RelocMap w)
forall tp (w :: Nat).
(IsRelocationType tp, w ~ RelocationWidth tp) =>
RelocMap w
-> ElfData
-> RelocationResolver tp
-> SymbolTable w
-> Maybe ByteString
-> MemLoader w (RelocMap w)
addElfRelaEntries RelocMap w
forall k a. Map k a
Map.empty ElfData
dta RelocationResolver tp
resolver SymbolTable w
symtab Maybe ByteString
mRelaBuffer
          RelocMap w
-> ElfData
-> RelocationResolver tp
-> SymbolTable w
-> Maybe ByteString
-> StateT (MemLoaderState w) (Except (LoadError w)) (RelocMap w)
forall tp (w :: Nat).
(IsRelocationType tp, w ~ RelocationWidth tp) =>
RelocMap w
-> ElfData
-> RelocationResolver tp
-> SymbolTable w
-> Maybe ByteString
-> MemLoader w (RelocMap w)
addElfRelEntries        RelocMap w
m1        ElfData
dta RelocationResolver tp
resolver SymbolTable w
symtab Maybe ByteString
mRelBuffer
        MemSegment w
seg <-
          RelocMap w
-> Int
-> Integer
-> Maybe Word16
-> MemWord w
-> Flags
-> ByteString
-> MemWord w
-> StateT (MemLoaderState w) (Except (LoadError w)) (MemSegment w)
forall (m :: Type -> Type) (w :: Nat).
(Monad m, MemWidth w) =>
Map (MemWord w) (RelocEntry m w)
-> Int
-> Integer
-> Maybe Word16
-> MemWord w
-> Flags
-> ByteString
-> MemWord w
-> m (MemSegment w)
memSegment RelocMap w
relocMap Int
regIdx Integer
0 Maybe Word16
forall a. Maybe a
Nothing (ElfWordType w -> MemWord w
forall a b. (Integral a, Num b) => a -> b
fromIntegral ElfWordType w
base) Flags
flags ByteString
bytes (ElfWordType w -> MemWord w
forall a b. (Integral a, Num b) => a -> b
fromIntegral ElfWordType w
secSize)
        -- Load memory segment.
        [Char] -> MemSegment w -> MemLoader w ()
forall (w :: Nat).
MemWidth w =>
[Char] -> MemSegment w -> MemLoader w ()
loadMemSegment ([Char]
"Section " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BSC.unpack ByteString
nm) MemSegment w
seg
        -- Add entry to map elf section index to start in segment.
        MemSegmentOff w
addr <- case MemSegment w -> MemWord w -> Maybe (MemSegmentOff w)
forall (w :: Nat).
MemWidth w =>
MemSegment w -> MemWord w -> Maybe (MemSegmentOff w)
resolveSegmentOff MemSegment w
seg MemWord w
0 of
                  Just MemSegmentOff w
addr -> MemSegmentOff w
-> StateT
     (MemLoaderState w) (Except (LoadError w)) (MemSegmentOff w)
forall a. a -> StateT (MemLoaderState w) (Except (LoadError w)) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure MemSegmentOff w
addr
                  Maybe (MemSegmentOff w)
Nothing -> [Char]
-> StateT
     (MemLoaderState w) (Except (LoadError w)) (MemSegmentOff w)
forall a. HasCallStack => [Char] -> a
error [Char]
"insertAllocatedShdr: Failed to resolve starting segment offset"
        (Memory w -> Identity (Memory w))
-> MemLoaderState w -> Identity (MemLoaderState w)
forall (w :: Nat) (f :: Type -> Type).
Functor f =>
(Memory w -> f (Memory w))
-> MemLoaderState w -> f (MemLoaderState w)
mlsMemory   ((Memory w -> Identity (Memory w))
 -> MemLoaderState w -> Identity (MemLoaderState w))
-> (Memory w -> Memory w) -> MemLoader w ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Word16 -> MemSegmentOff w -> Memory w -> Memory w
forall (w :: Nat).
Word16 -> MemSegmentOff w -> Memory w -> Memory w
memBindSectionIndex Word16
idx MemSegmentOff w
addr
        (SectionIndexMap w -> Identity (SectionIndexMap w))
-> MemLoaderState w -> Identity (MemLoaderState w)
forall (w :: Nat) (f :: Type -> Type).
Functor f =>
(SectionIndexMap w -> f (SectionIndexMap w))
-> MemLoaderState w -> f (MemLoaderState w)
mlsIndexMap ((SectionIndexMap w -> Identity (SectionIndexMap w))
 -> MemLoaderState w -> Identity (MemLoaderState w))
-> (SectionIndexMap w -> SectionIndexMap w) -> MemLoader w ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Word16 -> MemSegmentOff w -> SectionIndexMap w -> SectionIndexMap w
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Word16
idx MemSegmentOff w
addr

-- | Find and get static symbol table entries from an ELF binary.
elfStaticSymbolTable :: Integral (ElfWordType w)
                     => Elf.ElfHeaderInfo w
                     -> Maybe (V.Vector (Elf.SymtabEntry BS.ByteString (ElfWordType w)))
elfStaticSymbolTable :: forall (w :: Nat).
Integral (ElfWordType w) =>
ElfHeaderInfo w
-> Maybe (Vector (SymtabEntry ByteString (ElfWordType w)))
elfStaticSymbolTable ElfHeaderInfo w
elf = do
  Either SymtabError (Symtab w)
symtab <- ElfHeaderInfo w -> Maybe (Either SymtabError (Symtab w))
forall (w :: Nat).
ElfHeaderInfo w -> Maybe (Either SymtabError (Symtab w))
Elf.decodeHeaderSymtab ElfHeaderInfo w
elf
  case Either SymtabError (Symtab w)
symtab of
    Left SymtabError
_ -> Maybe (Vector (SymtabEntry ByteString (ElfWordType w)))
forall a. Maybe a
Nothing
    Right Symtab w
v -> Vector (SymtabEntry ByteString (ElfWordType w))
-> Maybe (Vector (SymtabEntry ByteString (ElfWordType w)))
forall a. a -> Maybe a
Just (Symtab w -> Vector (SymtabEntry ByteString (ElfWordType w))
forall (w :: Nat).
Symtab w -> Vector (SymtabEntry ByteString (ElfWordType w))
Elf.symtabEntries Symtab w
v)

-- | Find and get dynamic symbol table entries from an ELF binary.
elfDynamicSymbolTable :: Integral (ElfWordType w)
                      => Elf.ElfHeaderInfo w
                      -> Maybe (V.Vector (Elf.SymtabEntry BS.ByteString (ElfWordType w)))
elfDynamicSymbolTable :: forall (w :: Nat).
Integral (ElfWordType w) =>
ElfHeaderInfo w
-> Maybe (Vector (SymtabEntry ByteString (ElfWordType w)))
elfDynamicSymbolTable ElfHeaderInfo w
elf = do
  Either SymtabError (Symtab w)
symtab <- ElfHeaderInfo w -> Maybe (Either SymtabError (Symtab w))
forall (w :: Nat).
ElfHeaderInfo w -> Maybe (Either SymtabError (Symtab w))
Elf.decodeHeaderDynsym ElfHeaderInfo w
elf
  case Either SymtabError (Symtab w)
symtab of
    Left SymtabError
_ -> Maybe (Vector (SymtabEntry ByteString (ElfWordType w)))
forall a. Maybe a
Nothing
    Right Symtab w
v -> Vector (SymtabEntry ByteString (ElfWordType w))
-> Maybe (Vector (SymtabEntry ByteString (ElfWordType w)))
forall a. a -> Maybe a
Just (Symtab w -> Vector (SymtabEntry ByteString (ElfWordType w))
forall (w :: Nat).
Symtab w -> Vector (SymtabEntry ByteString (ElfWordType w))
Elf.symtabEntries Symtab w
v)

-- | Load allocated Elf sections into memory.
--
-- This is only used for object files.
memoryForElfSections :: forall w
                     .  Elf.ElfHeaderInfo w
                     -> Either String (Memory w, SectionIndexMap w, [MemLoadWarning])
memoryForElfSections :: forall (w :: Nat).
ElfHeaderInfo w
-> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning])
memoryForElfSections ElfHeaderInfo w
elf = AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning]))
-> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning])
forall (w :: Nat) a.
AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    a)
-> a
reprConstraints (ElfClass w -> AddrWidthRepr w
forall (w :: Nat). ElfClass w -> AddrWidthRepr w
elfAddrWidth (ElfHeader w -> ElfClass w
forall (w :: Nat). ElfHeader w -> ElfClass w
Elf.headerClass (ElfHeaderInfo w -> ElfHeader w
forall (w :: Nat). ElfHeaderInfo w -> ElfHeader w
Elf.header ElfHeaderInfo w
elf))) (((Bits (ElfWordType w), Bounded (ElfIntType w),
   Integral (ElfIntType w), Bounded (ElfWordType w),
   Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
  Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning]))
 -> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning]))
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning]))
-> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning])
forall a b. (a -> b) -> a -> b
$ do
  let hdr :: ElfHeader w
hdr = ElfHeaderInfo w -> ElfHeader w
forall (w :: Nat). ElfHeaderInfo w -> ElfHeader w
Elf.header ElfHeaderInfo w
elf
  let contents :: ByteString
contents = ElfHeaderInfo w -> ByteString
forall (w :: Nat). ElfHeaderInfo w -> ByteString
Elf.headerFileContents ElfHeaderInfo w
elf
  let shdrs :: Vector (Shdr Word32 (ElfWordType w))
shdrs = ElfHeaderInfo w -> Vector (Shdr Word32 (ElfWordType w))
forall (w :: Nat).
ElfHeaderInfo w -> Vector (Shdr Word32 (ElfWordType w))
Elf.headerShdrs ElfHeaderInfo w
elf

  -- Get string table for section header table.
  let (FileRange (ElfWordType w)
_, ByteString
shstrtab) = ElfHeaderInfo w -> (FileRange (ElfWordType w), ByteString)
forall (w :: Nat).
HasCallStack =>
ElfHeaderInfo w -> (FileRange (ElfWordType w), ByteString)
Elf.shstrtabRangeAndData ElfHeaderInfo w
elf

  let shdrMap :: ShdrNameMap w
      shdrMap :: ShdrNameMap w
shdrMap = (ShdrNameMap w
 -> Int -> Shdr Word32 (ElfWordType w) -> ShdrNameMap w)
-> ShdrNameMap w
-> Vector (Shdr Word32 (ElfWordType w))
-> ShdrNameMap w
forall a b. (a -> Int -> b -> a) -> a -> Vector b -> a
V.ifoldl' ShdrNameMap w
-> Int -> Shdr Word32 (ElfWordType w) -> ShdrNameMap w
insSec ShdrNameMap w
forall k a. Map k a
Map.empty Vector (Shdr Word32 (ElfWordType w))
shdrs
        where insSec :: ShdrNameMap w
-> Int -> Shdr Word32 (ElfWordType w) -> ShdrNameMap w
insSec ShdrNameMap w
m Int
idx Shdr Word32 (ElfWordType w)
shdr =
                case Word32 -> ByteString -> Either LookupStringError ByteString
Elf.lookupString (Shdr Word32 (ElfWordType w) -> Word32
forall nm w. Shdr nm w -> nm
Elf.shdrName Shdr Word32 (ElfWordType w)
shdr) ByteString
shstrtab of
                  Left LookupStringError
_ -> ShdrNameMap w
m
                  Right ByteString
nm ->
                    ([(Word16, Shdr Word32 (ElfWordType w))]
 -> [(Word16, Shdr Word32 (ElfWordType w))]
 -> [(Word16, Shdr Word32 (ElfWordType w))])
-> ByteString
-> [(Word16, Shdr Word32 (ElfWordType w))]
-> ShdrNameMap w
-> ShdrNameMap w
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (\[(Word16, Shdr Word32 (ElfWordType w))]
new [(Word16, Shdr Word32 (ElfWordType w))]
old -> [(Word16, Shdr Word32 (ElfWordType w))]
old [(Word16, Shdr Word32 (ElfWordType w))]
-> [(Word16, Shdr Word32 (ElfWordType w))]
-> [(Word16, Shdr Word32 (ElfWordType w))]
forall a. [a] -> [a] -> [a]
++ [(Word16, Shdr Word32 (ElfWordType w))]
new) ByteString
nm [(Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
idx, Shdr Word32 (ElfWordType w)
shdr)] ShdrNameMap w
m

  let symtab :: SymbolTable w
symtab =
        case ElfHeaderInfo w
-> Maybe (Vector (SymtabEntry ByteString (ElfWordType w)))
forall (w :: Nat).
Integral (ElfWordType w) =>
ElfHeaderInfo w
-> Maybe (Vector (SymtabEntry ByteString (ElfWordType w)))
elfStaticSymbolTable ElfHeaderInfo w
elf of
          Maybe (Vector (SymtabEntry ByteString (ElfWordType w)))
Nothing -> SymbolTable w
forall (w :: Nat). SymbolTable w
NoSymbolTable
          Just Vector (SymtabEntry ByteString (ElfWordType w))
v -> Vector (SymtabEntry ByteString (ElfWordType w)) -> SymbolTable w
forall (w :: Nat).
Vector (SymtabEntry ByteString (ElfWordType w)) -> SymbolTable w
StaticSymbolTable Vector (SymtabEntry ByteString (ElfWordType w))
v
  -- Create memory for elf sections
  ElfHeader w
-> ByteString
-> ShdrNameMap w
-> SymbolTable w
-> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning])
forall (w :: Nat).
ElfHeader w
-> ByteString
-> ShdrNameMap w
-> SymbolTable w
-> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning])
memoryForElfSections' ElfHeader w
hdr ByteString
contents ShdrNameMap w
shdrMap SymbolTable w
symtab

-- | Load allocated Elf sections into memory.
--
-- This is only used for object files.  This version uses low-level types
-- for less complex parsing.
memoryForElfSections' :: forall w
                      .  Elf.ElfHeader w -- ^ Header for elf
                      -> BS.ByteString
                      -> ShdrNameMap    w -- ^ Map from section names to section headers
                      -> SymbolTable w -- ^ Symbol table for names.
                      -> Either String (Memory w, SectionIndexMap w, [MemLoadWarning])
memoryForElfSections' :: forall (w :: Nat).
ElfHeader w
-> ByteString
-> ShdrNameMap w
-> SymbolTable w
-> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning])
memoryForElfSections' ElfHeader w
hdr ByteString
contents ShdrNameMap w
shdrMap SymbolTable w
symtab =
  Endianness
-> Memory w
-> MemLoader w ()
-> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning])
forall (w :: Nat).
Endianness
-> Memory w
-> MemLoader w ()
-> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning])
runMemLoader (ElfData -> Endianness
toEndianness (ElfHeader w -> ElfData
forall (w :: Nat). ElfHeader w -> ElfData
Elf.headerData ElfHeader w
hdr)) (AddrWidthRepr w -> Memory w
forall (w :: Nat). AddrWidthRepr w -> Memory w
emptyMemory (ElfClass w -> AddrWidthRepr w
forall (w :: Nat). ElfClass w -> AddrWidthRepr w
elfAddrWidth (ElfHeader w -> ElfClass w
forall (w :: Nat). ElfHeader w -> ElfClass w
Elf.headerClass ElfHeader w
hdr))) (MemLoader w ()
 -> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning]))
-> MemLoader w ()
-> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning])
forall a b. (a -> b) -> a -> b
$ do
    -- Insert sections
    [(Int, AllocatedSectionInfo)]
-> ((Int, AllocatedSectionInfo) -> MemLoader w ())
-> MemLoader w ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [AllocatedSectionInfo] -> [(Int, AllocatedSectionInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [AllocatedSectionInfo]
allocatedSectionInfo) (((Int, AllocatedSectionInfo) -> MemLoader w ()) -> MemLoader w ())
-> ((Int, AllocatedSectionInfo) -> MemLoader w ())
-> MemLoader w ()
forall a b. (a -> b) -> a -> b
$ \(Int
idx, (ByteString
nm,Bool
_)) -> do
      ElfHeader w
-> ByteString
-> SymbolTable w
-> ShdrNameMap w
-> Int
-> ByteString
-> MemLoader w ()
forall (w :: Nat).
ElfHeader w
-> ByteString
-> SymbolTable w
-> ShdrNameMap w
-> Int
-> ByteString
-> MemLoader w ()
insertAllocatedShdr ElfHeader w
hdr ByteString
contents SymbolTable w
symtab ShdrNameMap w
shdrMap Int
idx ByteString
nm
    -- TODO: Figure out what to do about .tdata and .tbss
    -- Check for other section names that we do not support."
    let unsupportedKeys :: Set ByteString
unsupportedKeys = ShdrNameMap w -> Set ByteString
forall k a. Map k a -> Set k
Map.keysSet ShdrNameMap w
shdrMap `Set.difference ` Set ByteString
allowedSectionNames
    Set ByteString -> (ByteString -> MemLoader w ()) -> MemLoader w ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Set ByteString
unsupportedKeys ((ByteString -> MemLoader w ()) -> MemLoader w ())
-> (ByteString -> MemLoader w ()) -> MemLoader w ()
forall a b. (a -> b) -> a -> b
$ \ByteString
k -> do
      MemLoadWarning -> MemLoader w ()
forall (w :: Nat). MemLoadWarning -> MemLoader w ()
addWarning (MemLoadWarning -> MemLoader w ())
-> MemLoadWarning -> MemLoader w ()
forall a b. (a -> b) -> a -> b
$ ByteString -> MemLoadWarning
UnsupportedSection ByteString
k

------------------------------------------------------------------------
-- Index for elf

-- | Return default region index to use when loading.
adjustedLoadRegionIndex :: Elf.ElfType -> LoadOptions -> RegionIndex
adjustedLoadRegionIndex :: ElfType -> LoadOptions -> Int
adjustedLoadRegionIndex ElfType
tp LoadOptions
loadOpts =
  case LoadOptions -> Maybe Word64
loadOffset LoadOptions
loadOpts of
    Just Word64
_ -> Int
0
    Maybe Word64
Nothing ->
      case ElfType
tp of
        ElfType
Elf.ET_REL -> Int
1
        -- This is only for non-position independent exectuables.
        ElfType
Elf.ET_EXEC -> Int
0
        -- This is for shared libraries or position-independent executablkes.
        ElfType
Elf.ET_DYN -> Int
1
        ElfType
_ -> Int
0

------------------------------------------------------------------------
-- Memory symbol

-- | Type for representing a symbol that has a defined location in
-- this memory.
data MemSymbol w = MemSymbol { forall (w :: Nat). MemSymbol w -> ByteString
memSymbolName :: !BS.ByteString
                               -- ^ Name of symbol
                             , forall (w :: Nat). MemSymbol w -> MemSegmentOff w
memSymbolStart :: !(MemSegmentOff w)
                               -- ^ Address that symbol starts up.
                             , forall (w :: Nat). MemSymbol w -> MemWord w
memSymbolSize :: !(MemWord w)
                               -- ^ Size of symbol as defined in table.
                             }
  deriving (Int -> MemSymbol w -> ShowS
[MemSymbol w] -> ShowS
MemSymbol w -> [Char]
(Int -> MemSymbol w -> ShowS)
-> (MemSymbol w -> [Char])
-> ([MemSymbol w] -> ShowS)
-> Show (MemSymbol w)
forall (w :: Nat). MemWidth w => Int -> MemSymbol w -> ShowS
forall (w :: Nat). MemWidth w => [MemSymbol w] -> ShowS
forall (w :: Nat). MemWidth w => MemSymbol w -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall (w :: Nat). MemWidth w => Int -> MemSymbol w -> ShowS
showsPrec :: Int -> MemSymbol w -> ShowS
$cshow :: forall (w :: Nat). MemWidth w => MemSymbol w -> [Char]
show :: MemSymbol w -> [Char]
$cshowList :: forall (w :: Nat). MemWidth w => [MemSymbol w] -> ShowS
showList :: [MemSymbol w] -> ShowS
Show)

instance Eq (MemSymbol w) where
  MemSymbol w
x == :: MemSymbol w -> MemSymbol w -> Bool
== MemSymbol w
y = MemSymbol w -> MemSegmentOff w
forall (w :: Nat). MemSymbol w -> MemSegmentOff w
memSymbolStart MemSymbol w
x MemSegmentOff w -> MemSegmentOff w -> Bool
forall a. Eq a => a -> a -> Bool
== MemSymbol w -> MemSegmentOff w
forall (w :: Nat). MemSymbol w -> MemSegmentOff w
memSymbolStart MemSymbol w
y
        Bool -> Bool -> Bool
&& MemSymbol w -> ByteString
forall (w :: Nat). MemSymbol w -> ByteString
memSymbolName  MemSymbol w
x ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== MemSymbol w -> ByteString
forall (w :: Nat). MemSymbol w -> ByteString
memSymbolName  MemSymbol w
y
        Bool -> Bool -> Bool
&& MemSymbol w -> MemWord w
forall (w :: Nat). MemSymbol w -> MemWord w
memSymbolSize  MemSymbol w
x MemWord w -> MemWord w -> Bool
forall a. Eq a => a -> a -> Bool
== MemSymbol w -> MemWord w
forall (w :: Nat). MemSymbol w -> MemWord w
memSymbolSize  MemSymbol w
y

-- Sort by address, size, then name
instance Ord (MemSymbol w) where
  compare :: MemSymbol w -> MemSymbol w -> Ordering
compare MemSymbol w
x MemSymbol w
y
    =  MemSegmentOff w -> MemSegmentOff w -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (MemSymbol w -> MemSegmentOff w
forall (w :: Nat). MemSymbol w -> MemSegmentOff w
memSymbolStart MemSymbol w
x) (MemSymbol w -> MemSegmentOff w
forall (w :: Nat). MemSymbol w -> MemSegmentOff w
memSymbolStart MemSymbol 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 (MemSymbol w -> MemWord w
forall (w :: Nat). MemSymbol w -> MemWord w
memSymbolSize  MemSymbol w
x) (MemSymbol w -> MemWord w
forall (w :: Nat). MemSymbol w -> MemWord w
memSymbolSize  MemSymbol w
y)
    Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (MemSymbol w -> ByteString
forall (w :: Nat). MemSymbol w -> ByteString
memSymbolName  MemSymbol w
x) (MemSymbol w -> ByteString
forall (w :: Nat). MemSymbol w -> ByteString
memSymbolName  MemSymbol w
y)

------------------------------------------------------------------------
-- memoryForElf

elfHeaderConstraints :: Elf.ElfHeaderInfo w
                     ->  ((Bits (ElfWordType w)
                          , Bounded  (Elf.ElfIntType w)
                          , Integral (Elf.ElfIntType w)
                          , Bounded  (Elf.ElfWordType w)
                          , Integral (Elf.ElfWordType w)
                          , Show (ElfWordType w)
                          , MemWidth w) => a)
                     -> a
elfHeaderConstraints :: forall (w :: Nat) a.
ElfHeaderInfo w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    a)
-> a
elfHeaderConstraints ElfHeaderInfo w
elf = AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    a)
-> a
forall (w :: Nat) a.
AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    a)
-> a
reprConstraints (ElfClass w -> AddrWidthRepr w
forall (w :: Nat). ElfClass w -> AddrWidthRepr w
elfAddrWidth (ElfHeader w -> ElfClass w
forall (w :: Nat). ElfHeader w -> ElfClass w
Elf.headerClass (ElfHeaderInfo w -> ElfHeader w
forall (w :: Nat). ElfHeaderInfo w -> ElfHeader w
Elf.header ElfHeaderInfo w
elf)))

{-# DEPRECATED memoryForElf' "Use memoryForElf" #-}
memoryForElf' :: LoadOptions
              -> Elf.ElfHeaderInfo w
              -> (Elf.SymtabEntry BS.ByteString (ElfWordType w) -> Bool)
              -- ^ Filter on symbol table entries
              -> Either String  ( Memory w
                                , [MemSymbol w] -- Function symbols
                                , [MemLoadWarning]
                                , [SymbolResolutionError]
                                )
memoryForElf' :: forall (w :: Nat).
LoadOptions
-> ElfHeaderInfo w
-> (SymtabEntry ByteString (ElfWordType w) -> Bool)
-> Either
     [Char]
     (Memory w, [MemSymbol w], [MemLoadWarning],
      [SymbolResolutionError])
memoryForElf' LoadOptions
opt ElfHeaderInfo w
elf SymtabEntry ByteString (ElfWordType w) -> Bool
isRelevant = ElfHeaderInfo w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    Either
      [Char]
      (Memory w, [MemSymbol w], [MemLoadWarning],
       [SymbolResolutionError]))
-> Either
     [Char]
     (Memory w, [MemSymbol w], [MemLoadWarning],
      [SymbolResolutionError])
forall (w :: Nat) a.
ElfHeaderInfo w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    a)
-> a
elfHeaderConstraints ElfHeaderInfo w
elf (((Bits (ElfWordType w), Bounded (ElfIntType w),
   Integral (ElfIntType w), Bounded (ElfWordType w),
   Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
  Either
    [Char]
    (Memory w, [MemSymbol w], [MemLoadWarning],
     [SymbolResolutionError]))
 -> Either
      [Char]
      (Memory w, [MemSymbol w], [MemLoadWarning],
       [SymbolResolutionError]))
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    Either
      [Char]
      (Memory w, [MemSymbol w], [MemLoadWarning],
       [SymbolResolutionError]))
-> Either
     [Char]
     (Memory w, [MemSymbol w], [MemLoadWarning],
      [SymbolResolutionError])
forall a b. (a -> b) -> a -> b
$ do
  let shdrs :: Vector (Shdr Word32 (ElfWordType w))
shdrs = ElfHeaderInfo w -> Vector (Shdr Word32 (ElfWordType w))
forall (w :: Nat).
ElfHeaderInfo w -> Vector (Shdr Word32 (ElfWordType w))
Elf.headerShdrs ElfHeaderInfo w
elf
  -- Get the elf memory, section map, warnings based on type.
  (Memory w
mem, SectionIndexMap w
secMap, [MemLoadWarning]
warnings) <-
    case ElfHeader w -> ElfType
forall (w :: Nat). ElfHeader w -> ElfType
Elf.headerType (ElfHeaderInfo w -> ElfHeader w
forall (w :: Nat). ElfHeaderInfo w -> ElfHeader w
Elf.header ElfHeaderInfo w
elf) of
      -- We load object files by section
      ElfType
Elf.ET_REL -> do
        Bool -> Either [Char] () -> Either [Char] ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Maybe Word64 -> Bool
forall a. Maybe a -> Bool
isJust (LoadOptions -> Maybe Word64
loadOffset LoadOptions
opt)) (Either [Char] () -> Either [Char] ())
-> Either [Char] () -> Either [Char] ()
forall a b. (a -> b) -> a -> b
$ do
          [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left ([Char] -> Either [Char] ()) -> [Char] -> Either [Char] ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Object file sections have multiple offsets, and do not support loading at address."
        ElfHeaderInfo w
-> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning])
forall (w :: Nat).
ElfHeaderInfo w
-> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning])
memoryForElfSections ElfHeaderInfo w
elf
      ElfType
Elf.ET_EXEC ->
        LoadOptions
-> ElfHeaderInfo w
-> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning])
forall (w :: Nat).
LoadOptions
-> ElfHeaderInfo w
-> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning])
memoryForElfSegments LoadOptions
opt ElfHeaderInfo w
elf
      -- Dynamic include dynamic information
      ElfType
_ ->
        LoadOptions
-> ElfHeaderInfo w
-> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning])
forall (w :: Nat).
LoadOptions
-> ElfHeaderInfo w
-> Either [Char] (Memory w, SectionIndexMap w, [MemLoadWarning])
memoryForElfSegments LoadOptions
opt ElfHeaderInfo w
elf
  -- Get dynamic symbol table entries
  -- Resolve elf symbol table information
  let ([SymbolResolutionError]
symErrs, [MemSymbol w]
funcSymbols) = Memory w
-> Vector (Shdr Word32 (ElfWordType w))
-> SectionIndexMap w
-> (SymtabEntry ByteString (ElfWordType w) -> Bool)
-> ElfHeaderInfo w
-> ([SymbolResolutionError], [MemSymbol w])
forall (w :: Nat).
(MemWidth w, Integral (ElfWordType w)) =>
Memory w
-> Vector (Shdr Word32 (ElfWordType w))
-> SectionIndexMap w
-> (SymtabEntry ByteString (ElfWordType w) -> Bool)
-> ElfHeaderInfo w
-> ([SymbolResolutionError], [MemSymbol w])
resolveElfFuncSymbols Memory w
mem Vector (Shdr Word32 (ElfWordType w))
shdrs SectionIndexMap w
secMap SymtabEntry ByteString (ElfWordType w) -> Bool
isRelevant ElfHeaderInfo w
elf
  (Memory w, [MemSymbol w], [MemLoadWarning],
 [SymbolResolutionError])
-> Either
     [Char]
     (Memory w, [MemSymbol w], [MemLoadWarning],
      [SymbolResolutionError])
forall a. a -> Either [Char] a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Memory w
mem, [MemSymbol w]
funcSymbols, [MemLoadWarning]
warnings, [SymbolResolutionError]
symErrs)

-- | Load allocated Elf sections into memory, using the section table
-- information map.
--
-- Normally, Elf uses segments for loading, but the section
-- information tends to be more precise.
--
-- The return value includes a list of all function symbols (STT_FUNC
-- Symbol table entry types).
memoryForElf :: LoadOptions
             -> Elf.ElfHeaderInfo w
             -> Either String ( Memory w
                              , [MemSymbol w] -- Function symbols
                              , [MemLoadWarning]
                              , [SymbolResolutionError]
                              )
memoryForElf :: forall (w :: Nat).
LoadOptions
-> ElfHeaderInfo w
-> Either
     [Char]
     (Memory w, [MemSymbol w], [MemLoadWarning],
      [SymbolResolutionError])
memoryForElf LoadOptions
opt ElfHeaderInfo w
elf =
  let isRelevant :: SymtabEntry nm w -> Bool
isRelevant SymtabEntry nm w
ste = SymtabEntry nm w -> ElfSymbolType
forall nm w. SymtabEntry nm w -> ElfSymbolType
Elf.steType SymtabEntry nm w
ste ElfSymbolType -> ElfSymbolType -> Bool
forall a. Eq a => a -> a -> Bool
== ElfSymbolType
Elf.STT_FUNC
   in LoadOptions
-> ElfHeaderInfo w
-> (SymtabEntry ByteString (ElfWordType w) -> Bool)
-> Either
     [Char]
     (Memory w, [MemSymbol w], [MemLoadWarning],
      [SymbolResolutionError])
forall (w :: Nat).
LoadOptions
-> ElfHeaderInfo w
-> (SymtabEntry ByteString (ElfWordType w) -> Bool)
-> Either
     [Char]
     (Memory w, [MemSymbol w], [MemLoadWarning],
      [SymbolResolutionError])
memoryForElf' LoadOptions
opt ElfHeaderInfo w
elf SymtabEntry ByteString (ElfWordType w) -> Bool
forall {nm} {w}. SymtabEntry nm w -> Bool
isRelevant

-- | Load allocated Elf sections into memory, using the section table
-- information map.
--
-- Normally, Elf uses segments for loading, but the section
-- information tends to be more precise.
--
-- The return value includes a list of *all* symbols, whether they
-- are functions or not.
memoryForElfAllSymbols :: LoadOptions
                       -> Elf.ElfHeaderInfo w
                       -> Either String ( Memory w
                                        , [MemSymbol w] -- Function symbols
                                        , [MemLoadWarning]
                                        , [SymbolResolutionError]
                                        )
memoryForElfAllSymbols :: forall (w :: Nat).
LoadOptions
-> ElfHeaderInfo w
-> Either
     [Char]
     (Memory w, [MemSymbol w], [MemLoadWarning],
      [SymbolResolutionError])
memoryForElfAllSymbols LoadOptions
opt ElfHeaderInfo w
elf = LoadOptions
-> ElfHeaderInfo w
-> (SymtabEntry ByteString (ElfWordType w) -> Bool)
-> Either
     [Char]
     (Memory w, [MemSymbol w], [MemLoadWarning],
      [SymbolResolutionError])
forall (w :: Nat).
LoadOptions
-> ElfHeaderInfo w
-> (SymtabEntry ByteString (ElfWordType w) -> Bool)
-> Either
     [Char]
     (Memory w, [MemSymbol w], [MemLoadWarning],
      [SymbolResolutionError])
memoryForElf' LoadOptions
opt ElfHeaderInfo w
elf (\SymtabEntry ByteString (ElfWordType w)
_ -> Bool
True)

------------------------------------------------------------------------
-- Elf symbol utilities

-- | Error when resolving symbols.
data SymbolResolutionError
   = EmptySymbolName !Int !Elf.ElfSymbolType
     -- ^ Symbol names must be non-empty
   | UndefSymbol !BSC.ByteString
     -- ^ Symbol was in the undefined section.
   | CouldNotResolveAddr !BSC.ByteString
     -- ^ Symbol address could not be resolved.
   | MultipleSymbolTables
     -- ^ The elf file contained multiple symbol tables

instance Show SymbolResolutionError where
  show :: SymbolResolutionError -> [Char]
show (EmptySymbolName Int
idx ElfSymbolType
tp ) =
    [Char]
"Symbol Num " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
idx [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ElfSymbolType -> [Char]
forall a. Show a => a -> [Char]
show ElfSymbolType
tp [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" has an empty name."
  show (UndefSymbol ByteString
nm) = [Char]
"Symbol " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BSC.unpack ByteString
nm [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" is in the text section."
  show (CouldNotResolveAddr ByteString
sym) = [Char]
"Could not resolve address of " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BSC.unpack ByteString
sym [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"."
  show SymbolResolutionError
MultipleSymbolTables = [Char]
"Elf contains multiple symbol tables."


-- | Map a symbol table entry in .symtab to the associated symbol information.
--
-- This drops undefined symbols by returning `Nothing, and returns
-- either the symbol information or an error message if we cannot
-- resolve the address.
resolveElfSymbol :: Integral (ElfWordType w)
                 => Memory w -- ^ Memory object from Elf file.
                 -> SymbolAddrResolver w -- ^ Section index mp from memory
                 -> Int -- ^ Index of symbol
                 -> Elf.SymtabEntry BS.ByteString (ElfWordType w)
                 -> Maybe (Either SymbolResolutionError (MemSymbol w))
resolveElfSymbol :: forall (w :: Nat).
Integral (ElfWordType w) =>
Memory w
-> SymbolAddrResolver w
-> Int
-> SymtabEntry ByteString (ElfWordType w)
-> Maybe (Either SymbolResolutionError (MemSymbol w))
resolveElfSymbol Memory w
mem SymbolAddrResolver w
resolver Int
idx SymtabEntry ByteString (ElfWordType w)
ste
    -- Check symbol is defined
  | SymtabEntry ByteString (ElfWordType w) -> ElfSectionIndex
forall nm w. SymtabEntry nm w -> ElfSectionIndex
Elf.steIndex SymtabEntry ByteString (ElfWordType w)
ste ElfSectionIndex -> ElfSectionIndex -> Bool
forall a. Eq a => a -> a -> Bool
== ElfSectionIndex
Elf.SHN_UNDEF = Maybe (Either SymbolResolutionError (MemSymbol w))
forall a. Maybe a
Nothing
  -- Check symbol name is non-empty
  | SymtabEntry ByteString (ElfWordType w) -> ByteString
forall nm w. SymtabEntry nm w -> nm
Elf.steName SymtabEntry ByteString (ElfWordType w)
ste ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"" = Either SymbolResolutionError (MemSymbol w)
-> Maybe (Either SymbolResolutionError (MemSymbol w))
forall a. a -> Maybe a
Just (Either SymbolResolutionError (MemSymbol w)
 -> Maybe (Either SymbolResolutionError (MemSymbol w)))
-> Either SymbolResolutionError (MemSymbol w)
-> Maybe (Either SymbolResolutionError (MemSymbol w))
forall a b. (a -> b) -> a -> b
$ SymbolResolutionError -> Either SymbolResolutionError (MemSymbol w)
forall a b. a -> Either a b
Left (SymbolResolutionError
 -> Either SymbolResolutionError (MemSymbol w))
-> SymbolResolutionError
-> Either SymbolResolutionError (MemSymbol w)
forall a b. (a -> b) -> a -> b
$ Int -> ElfSymbolType -> SymbolResolutionError
EmptySymbolName Int
idx (SymtabEntry ByteString (ElfWordType w) -> ElfSymbolType
forall nm w. SymtabEntry nm w -> ElfSymbolType
Elf.steType SymtabEntry ByteString (ElfWordType w)
ste)
  -- Lookup absolute symbol
  | SymtabEntry ByteString (ElfWordType w) -> ElfSectionIndex
forall nm w. SymtabEntry nm w -> ElfSectionIndex
Elf.steIndex SymtabEntry ByteString (ElfWordType w)
ste ElfSectionIndex -> ElfSectionIndex -> Bool
forall a. Eq a => a -> a -> Bool
== ElfSectionIndex
Elf.SHN_ABS = AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    Maybe (Either SymbolResolutionError (MemSymbol w)))
-> Maybe (Either SymbolResolutionError (MemSymbol w))
forall (w :: Nat) a.
AddrWidthRepr w
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    a)
-> a
reprConstraints (Memory w -> AddrWidthRepr w
forall (w :: Nat). Memory w -> AddrWidthRepr w
memAddrWidth Memory w
mem) (((Bits (ElfWordType w), Bounded (ElfIntType w),
   Integral (ElfIntType w), Bounded (ElfWordType w),
   Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
  Maybe (Either SymbolResolutionError (MemSymbol w)))
 -> Maybe (Either SymbolResolutionError (MemSymbol w)))
-> ((Bits (ElfWordType w), Bounded (ElfIntType w),
     Integral (ElfIntType w), Bounded (ElfWordType w),
     Integral (ElfWordType w), Show (ElfWordType w), MemWidth w) =>
    Maybe (Either SymbolResolutionError (MemSymbol w)))
-> Maybe (Either SymbolResolutionError (MemSymbol w))
forall a b. (a -> b) -> a -> b
$ do
      let val :: ElfWordType w
val = SymtabEntry ByteString (ElfWordType w) -> ElfWordType w
forall nm w. SymtabEntry nm w -> w
Elf.steValue SymtabEntry ByteString (ElfWordType w)
ste
      case Memory w -> MemWord w -> Maybe (MemSegmentOff w)
forall (w :: Nat). Memory w -> MemWord w -> Maybe (MemSegmentOff w)
resolveAbsoluteAddr Memory w
mem (ElfWordType w -> MemWord w
forall a b. (Integral a, Num b) => a -> b
fromIntegral ElfWordType w
val) of
        Just MemSegmentOff w
addr -> Either SymbolResolutionError (MemSymbol w)
-> Maybe (Either SymbolResolutionError (MemSymbol w))
forall a. a -> Maybe a
Just (Either SymbolResolutionError (MemSymbol w)
 -> Maybe (Either SymbolResolutionError (MemSymbol w)))
-> Either SymbolResolutionError (MemSymbol w)
-> Maybe (Either SymbolResolutionError (MemSymbol w))
forall a b. (a -> b) -> a -> b
$ MemSymbol w -> Either SymbolResolutionError (MemSymbol w)
forall a b. b -> Either a b
Right (MemSymbol w -> Either SymbolResolutionError (MemSymbol w))
-> MemSymbol w -> Either SymbolResolutionError (MemSymbol w)
forall a b. (a -> b) -> a -> b
$
          MemSymbol { memSymbolName :: ByteString
memSymbolName = SymtabEntry ByteString (ElfWordType w) -> ByteString
forall nm w. SymtabEntry nm w -> nm
Elf.steName SymtabEntry ByteString (ElfWordType w)
ste
                    , memSymbolStart :: MemSegmentOff w
memSymbolStart = MemSegmentOff w
addr
                    , memSymbolSize :: MemWord w
memSymbolSize = ElfWordType w -> MemWord w
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SymtabEntry ByteString (ElfWordType w) -> ElfWordType w
forall nm w. SymtabEntry nm w -> w
Elf.steSize SymtabEntry ByteString (ElfWordType w)
ste)
                    }
        Maybe (MemSegmentOff w)
Nothing   -> Either SymbolResolutionError (MemSymbol w)
-> Maybe (Either SymbolResolutionError (MemSymbol w))
forall a. a -> Maybe a
Just (Either SymbolResolutionError (MemSymbol w)
 -> Maybe (Either SymbolResolutionError (MemSymbol w)))
-> Either SymbolResolutionError (MemSymbol w)
-> Maybe (Either SymbolResolutionError (MemSymbol w))
forall a b. (a -> b) -> a -> b
$ SymbolResolutionError -> Either SymbolResolutionError (MemSymbol w)
forall a b. a -> Either a b
Left (SymbolResolutionError
 -> Either SymbolResolutionError (MemSymbol w))
-> SymbolResolutionError
-> Either SymbolResolutionError (MemSymbol w)
forall a b. (a -> b) -> a -> b
$ ByteString -> SymbolResolutionError
CouldNotResolveAddr (SymtabEntry ByteString (ElfWordType w) -> ByteString
forall nm w. SymtabEntry nm w -> nm
Elf.steName SymtabEntry ByteString (ElfWordType w)
ste)
  -- Lookup symbol stored in specific section
  | Word16
secIdx <- ElfSectionIndex -> Word16
Elf.fromElfSectionIndex (SymtabEntry ByteString (ElfWordType w) -> ElfSectionIndex
forall nm w. SymtabEntry nm w -> ElfSectionIndex
Elf.steIndex SymtabEntry ByteString (ElfWordType w)
ste)
  , Word16
secIdx Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
< SymbolAddrResolver w -> Word16
forall (w :: Nat). SymbolAddrResolver w -> Word16
symSecCount SymbolAddrResolver w
resolver
  , Just MemSegmentOff w
addr <- SymbolAddrResolver w
-> Word16 -> ElfWordType w -> Maybe (MemSegmentOff w)
forall (w :: Nat).
SymbolAddrResolver w
-> Word16 -> ElfWordType w -> Maybe (MemSegmentOff w)
symResolver SymbolAddrResolver w
resolver Word16
secIdx (SymtabEntry ByteString (ElfWordType w) -> ElfWordType w
forall nm w. SymtabEntry nm w -> w
Elf.steValue SymtabEntry ByteString (ElfWordType w)
ste) = AddrWidthRepr w
-> (MemWidth w =>
    Maybe (Either SymbolResolutionError (MemSymbol w)))
-> Maybe (Either SymbolResolutionError (MemSymbol w))
forall (w :: Nat) a. AddrWidthRepr w -> (MemWidth w => a) -> a
addrWidthClass (Memory w -> AddrWidthRepr w
forall (w :: Nat). Memory w -> AddrWidthRepr w
memAddrWidth Memory w
mem) ((MemWidth w => Maybe (Either SymbolResolutionError (MemSymbol w)))
 -> Maybe (Either SymbolResolutionError (MemSymbol w)))
-> (MemWidth w =>
    Maybe (Either SymbolResolutionError (MemSymbol w)))
-> Maybe (Either SymbolResolutionError (MemSymbol w))
forall a b. (a -> b) -> a -> b
$
      Either SymbolResolutionError (MemSymbol w)
-> Maybe (Either SymbolResolutionError (MemSymbol w))
forall a. a -> Maybe a
Just (Either SymbolResolutionError (MemSymbol w)
 -> Maybe (Either SymbolResolutionError (MemSymbol w)))
-> Either SymbolResolutionError (MemSymbol w)
-> Maybe (Either SymbolResolutionError (MemSymbol w))
forall a b. (a -> b) -> a -> b
$ MemSymbol w -> Either SymbolResolutionError (MemSymbol w)
forall a b. b -> Either a b
Right (MemSymbol w -> Either SymbolResolutionError (MemSymbol w))
-> MemSymbol w -> Either SymbolResolutionError (MemSymbol w)
forall a b. (a -> b) -> a -> b
$ MemSymbol { memSymbolName :: ByteString
memSymbolName = SymtabEntry ByteString (ElfWordType w) -> ByteString
forall nm w. SymtabEntry nm w -> nm
Elf.steName SymtabEntry ByteString (ElfWordType w)
ste
                               , memSymbolStart :: MemSegmentOff w
memSymbolStart = MemSegmentOff w
addr
                               , memSymbolSize :: MemWord w
memSymbolSize = ElfWordType w -> MemWord w
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SymtabEntry ByteString (ElfWordType w) -> ElfWordType w
forall nm w. SymtabEntry nm w -> w
Elf.steSize SymtabEntry ByteString (ElfWordType w)
ste)
                               }

  | Bool
otherwise = Either SymbolResolutionError (MemSymbol w)
-> Maybe (Either SymbolResolutionError (MemSymbol w))
forall a. a -> Maybe a
Just (Either SymbolResolutionError (MemSymbol w)
 -> Maybe (Either SymbolResolutionError (MemSymbol w)))
-> Either SymbolResolutionError (MemSymbol w)
-> Maybe (Either SymbolResolutionError (MemSymbol w))
forall a b. (a -> b) -> a -> b
$ SymbolResolutionError -> Either SymbolResolutionError (MemSymbol w)
forall a b. a -> Either a b
Left (SymbolResolutionError
 -> Either SymbolResolutionError (MemSymbol w))
-> SymbolResolutionError
-> Either SymbolResolutionError (MemSymbol w)
forall a b. (a -> b) -> a -> b
$ ByteString -> SymbolResolutionError
CouldNotResolveAddr (SymtabEntry ByteString (ElfWordType w) -> ByteString
forall nm w. SymtabEntry nm w -> nm
Elf.steName SymtabEntry ByteString (ElfWordType w)
ste)

data ResolvedSymbols w = ResolvedSymbols { forall (w :: Nat). ResolvedSymbols w -> [SymbolResolutionError]
resolutionErrors :: ![SymbolResolutionError]
                                         , forall (w :: Nat). ResolvedSymbols w -> Set (MemSymbol w)
resolvedSymbols :: !(Set (MemSymbol w))
                                         }

instance Semigroup (ResolvedSymbols w) where
  ResolvedSymbols w
x <> :: ResolvedSymbols w -> ResolvedSymbols w -> ResolvedSymbols w
<> ResolvedSymbols w
y = ResolvedSymbols { resolutionErrors :: [SymbolResolutionError]
resolutionErrors = ResolvedSymbols w -> [SymbolResolutionError]
forall (w :: Nat). ResolvedSymbols w -> [SymbolResolutionError]
resolutionErrors ResolvedSymbols w
x [SymbolResolutionError]
-> [SymbolResolutionError] -> [SymbolResolutionError]
forall a. Semigroup a => a -> a -> a
<> ResolvedSymbols w -> [SymbolResolutionError]
forall (w :: Nat). ResolvedSymbols w -> [SymbolResolutionError]
resolutionErrors ResolvedSymbols w
y
                           , resolvedSymbols :: Set (MemSymbol w)
resolvedSymbols   = ResolvedSymbols w -> Set (MemSymbol w)
forall (w :: Nat). ResolvedSymbols w -> Set (MemSymbol w)
resolvedSymbols ResolvedSymbols w
x Set (MemSymbol w) -> Set (MemSymbol w) -> Set (MemSymbol w)
forall a. Semigroup a => a -> a -> a
<> ResolvedSymbols w -> Set (MemSymbol w)
forall (w :: Nat). ResolvedSymbols w -> Set (MemSymbol w)
resolvedSymbols ResolvedSymbols w
y
                           }

instance Monoid (ResolvedSymbols w) where
  mempty :: ResolvedSymbols w
mempty = ResolvedSymbols { resolutionErrors :: [SymbolResolutionError]
resolutionErrors = []
                           , resolvedSymbols :: Set (MemSymbol w)
resolvedSymbols = Set (MemSymbol w)
forall a. Set a
Set.empty
                           }

resolutionError :: SymbolResolutionError -> ResolvedSymbols w
resolutionError :: forall (w :: Nat). SymbolResolutionError -> ResolvedSymbols w
resolutionError SymbolResolutionError
e = ResolvedSymbols w
forall a. Monoid a => a
mempty { resolutionErrors = [e] }

resolvedSymbol :: MemSymbol w -> ResolvedSymbols w
resolvedSymbol :: forall (w :: Nat). MemSymbol w -> ResolvedSymbols w
resolvedSymbol MemSymbol w
s = ResolvedSymbols Any
forall a. Monoid a => a
mempty { resolvedSymbols = Set.singleton s }

-- | Construct a resolve symbol entry.
ofResolvedSymbol :: Maybe (Either SymbolResolutionError (MemSymbol w))
                 -> ResolvedSymbols w
ofResolvedSymbol :: forall (w :: Nat).
Maybe (Either SymbolResolutionError (MemSymbol w))
-> ResolvedSymbols w
ofResolvedSymbol Maybe (Either SymbolResolutionError (MemSymbol w))
Nothing = ResolvedSymbols w
forall a. Monoid a => a
mempty
ofResolvedSymbol (Just (Left SymbolResolutionError
e)) = SymbolResolutionError -> ResolvedSymbols w
forall (w :: Nat). SymbolResolutionError -> ResolvedSymbols w
resolutionError SymbolResolutionError
e
ofResolvedSymbol (Just (Right MemSymbol w
s)) = MemSymbol w -> ResolvedSymbols w
forall (w :: Nat). MemSymbol w -> ResolvedSymbols w
resolvedSymbol MemSymbol w
s

-- | Resolve symbol table entries defined in this Elf file to
-- a mem symbol.
resolveElfFuncSymbols
  :: forall w
  .  (MemWidth w, Integral (ElfWordType w))
  => Memory w
     -- ^ Memory loaded
  -> V.Vector (Elf.Shdr Word32 (Elf.ElfWordType w))
     -- ^ Section headers for symbol table
  -> SectionIndexMap w
     -- ^ Map from s
  -> (Elf.SymtabEntry BS.ByteString (ElfWordType w) -> Bool)
     -- ^ Filter on symbol table entries
  -> Elf.ElfHeaderInfo w
     -- ^ elf header information
  -> ([SymbolResolutionError], [MemSymbol w])
resolveElfFuncSymbols :: forall (w :: Nat).
(MemWidth w, Integral (ElfWordType w)) =>
Memory w
-> Vector (Shdr Word32 (ElfWordType w))
-> SectionIndexMap w
-> (SymtabEntry ByteString (ElfWordType w) -> Bool)
-> ElfHeaderInfo w
-> ([SymbolResolutionError], [MemSymbol w])
resolveElfFuncSymbols Memory w
mem Vector (Shdr Word32 (ElfWordType w))
shdrs SectionIndexMap w
secMap SymtabEntry ByteString (ElfWordType w) -> Bool
p ElfHeaderInfo w
elf =
   let resolver :: SymbolAddrResolver w
resolver = Vector (Shdr Word32 (ElfWordType w))
-> SectionIndexMap w -> SymbolAddrResolver w
forall (w :: Nat).
(MemWidth w, Integral (ElfWordType w)) =>
Vector (Shdr Word32 (ElfWordType w))
-> SectionIndexMap w -> SymbolAddrResolver w
mkSymbolAddrResolver Vector (Shdr Word32 (ElfWordType w))
shdrs SectionIndexMap w
secMap

       staticEntries :: [(Int, SymtabEntry ByteString (ElfWordType w))]
staticEntries =
         case ElfHeaderInfo w
-> Maybe (Vector (SymtabEntry ByteString (ElfWordType w)))
forall (w :: Nat).
Integral (ElfWordType w) =>
ElfHeaderInfo w
-> Maybe (Vector (SymtabEntry ByteString (ElfWordType w)))
elfStaticSymbolTable ElfHeaderInfo w
elf of
           Maybe (Vector (SymtabEntry ByteString (ElfWordType w)))
Nothing -> []
           Just Vector (SymtabEntry ByteString (ElfWordType w))
v -> Vector (Int, SymtabEntry ByteString (ElfWordType w))
-> [(Int, SymtabEntry ByteString (ElfWordType w))]
forall a. Vector a -> [a]
V.toList (Vector (Int, SymtabEntry ByteString (ElfWordType w))
 -> [(Int, SymtabEntry ByteString (ElfWordType w))])
-> Vector (Int, SymtabEntry ByteString (ElfWordType w))
-> [(Int, SymtabEntry ByteString (ElfWordType w))]
forall a b. (a -> b) -> a -> b
$ (Int
 -> SymtabEntry ByteString (ElfWordType w)
 -> (Int, SymtabEntry ByteString (ElfWordType w)))
-> Vector (SymtabEntry ByteString (ElfWordType w))
-> Vector (Int, SymtabEntry ByteString (ElfWordType w))
forall a b. (Int -> a -> b) -> Vector a -> Vector b
V.imap (\Int
i SymtabEntry ByteString (ElfWordType w)
s-> (Int
i, SymtabEntry ByteString (ElfWordType w)
s)) Vector (SymtabEntry ByteString (ElfWordType w))
v

       dynamicEntries :: [(Int, SymtabEntry ByteString (ElfWordType w))]
dynamicEntries =
         case ElfHeaderInfo w
-> Maybe (Vector (SymtabEntry ByteString (ElfWordType w)))
forall (w :: Nat).
Integral (ElfWordType w) =>
ElfHeaderInfo w
-> Maybe (Vector (SymtabEntry ByteString (ElfWordType w)))
elfDynamicSymbolTable ElfHeaderInfo w
elf of
           Maybe (Vector (SymtabEntry ByteString (ElfWordType w)))
Nothing -> []
           Just Vector (SymtabEntry ByteString (ElfWordType w))
v -> Vector (Int, SymtabEntry ByteString (ElfWordType w))
-> [(Int, SymtabEntry ByteString (ElfWordType w))]
forall a. Vector a -> [a]
V.toList (Vector (Int, SymtabEntry ByteString (ElfWordType w))
 -> [(Int, SymtabEntry ByteString (ElfWordType w))])
-> Vector (Int, SymtabEntry ByteString (ElfWordType w))
-> [(Int, SymtabEntry ByteString (ElfWordType w))]
forall a b. (a -> b) -> a -> b
$ (Int
 -> SymtabEntry ByteString (ElfWordType w)
 -> (Int, SymtabEntry ByteString (ElfWordType w)))
-> Vector (SymtabEntry ByteString (ElfWordType w))
-> Vector (Int, SymtabEntry ByteString (ElfWordType w))
forall a b. (Int -> a -> b) -> Vector a -> Vector b
V.imap (\Int
i SymtabEntry ByteString (ElfWordType w)
s-> (Int
i, SymtabEntry ByteString (ElfWordType w)
s)) Vector (SymtabEntry ByteString (ElfWordType w))
v

       allEntries :: [(Int, Elf.SymtabEntry BS.ByteString (ElfWordType w))]
       allEntries :: [(Int, SymtabEntry ByteString (ElfWordType w))]
allEntries = [(Int, SymtabEntry ByteString (ElfWordType w))]
staticEntries [(Int, SymtabEntry ByteString (ElfWordType w))]
-> [(Int, SymtabEntry ByteString (ElfWordType w))]
-> [(Int, SymtabEntry ByteString (ElfWordType w))]
forall a. [a] -> [a] -> [a]
++ [(Int, SymtabEntry ByteString (ElfWordType w))]
dynamicEntries

       r :: ResolvedSymbols w
       r :: ResolvedSymbols w
r = [ResolvedSymbols w] -> ResolvedSymbols w
forall a. Monoid a => [a] -> a
mconcat
         ([ResolvedSymbols w] -> ResolvedSymbols w)
-> [ResolvedSymbols w] -> ResolvedSymbols w
forall a b. (a -> b) -> a -> b
$ ((Int, SymtabEntry ByteString (ElfWordType w))
 -> ResolvedSymbols w)
-> [(Int, SymtabEntry ByteString (ElfWordType w))]
-> [ResolvedSymbols w]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Int
idx, SymtabEntry ByteString (ElfWordType w)
s) -> Maybe (Either SymbolResolutionError (MemSymbol w))
-> ResolvedSymbols w
forall (w :: Nat).
Maybe (Either SymbolResolutionError (MemSymbol w))
-> ResolvedSymbols w
ofResolvedSymbol (Memory w
-> SymbolAddrResolver w
-> Int
-> SymtabEntry ByteString (ElfWordType w)
-> Maybe (Either SymbolResolutionError (MemSymbol w))
forall (w :: Nat).
Integral (ElfWordType w) =>
Memory w
-> SymbolAddrResolver w
-> Int
-> SymtabEntry ByteString (ElfWordType w)
-> Maybe (Either SymbolResolutionError (MemSymbol w))
resolveElfSymbol Memory w
mem SymbolAddrResolver w
resolver Int
idx SymtabEntry ByteString (ElfWordType w)
s))
         ([(Int, SymtabEntry ByteString (ElfWordType w))]
 -> [ResolvedSymbols w])
-> [(Int, SymtabEntry ByteString (ElfWordType w))]
-> [ResolvedSymbols w]
forall a b. (a -> b) -> a -> b
$ ((Int, SymtabEntry ByteString (ElfWordType w)) -> Bool)
-> [(Int, SymtabEntry ByteString (ElfWordType w))]
-> [(Int, SymtabEntry ByteString (ElfWordType w))]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Int
_,SymtabEntry ByteString (ElfWordType w)
s) -> SymtabEntry ByteString (ElfWordType w) -> Bool
p SymtabEntry ByteString (ElfWordType w)
s) [(Int, SymtabEntry ByteString (ElfWordType w))]
allEntries

   in (ResolvedSymbols w -> [SymbolResolutionError]
forall (w :: Nat). ResolvedSymbols w -> [SymbolResolutionError]
resolutionErrors ResolvedSymbols w
r, Set (MemSymbol w) -> [MemSymbol w]
forall a. Set a -> [a]
Set.toList (ResolvedSymbols w -> Set (MemSymbol w)
forall (w :: Nat). ResolvedSymbols w -> Set (MemSymbol w)
resolvedSymbols ResolvedSymbols w
r))

------------------------------------------------------------------------
-- resolveElfContents

-- | Return the segment offset of the elf file entry point or fail if undefined.
getElfEntry ::  LoadOptions
            -> Memory w
            -> RegionIndex
            -> Elf.ElfHeader w
            -> ([String], Maybe (MemSegmentOff w))
getElfEntry :: forall (w :: Nat).
LoadOptions
-> Memory w
-> Int
-> ElfHeader w
-> ([[Char]], Maybe (MemSegmentOff w))
getElfEntry LoadOptions
loadOpts Memory w
mem Int
regIdx ElfHeader w
hdr =  AddrWidthRepr w
-> (MemWidth w => ([[Char]], Maybe (MemSegmentOff w)))
-> ([[Char]], Maybe (MemSegmentOff w))
forall (w :: Nat) a. AddrWidthRepr w -> (MemWidth w => a) -> a
addrWidthClass (Memory w -> AddrWidthRepr w
forall (w :: Nat). Memory w -> AddrWidthRepr w
memAddrWidth Memory w
mem) ((MemWidth w => ([[Char]], Maybe (MemSegmentOff w)))
 -> ([[Char]], Maybe (MemSegmentOff w)))
-> (MemWidth w => ([[Char]], Maybe (MemSegmentOff w)))
-> ([[Char]], Maybe (MemSegmentOff w))
forall a b. (a -> b) -> a -> b
$ do
  ElfClass w
-> (ElfWidthConstraints w => ([[Char]], Maybe (MemSegmentOff w)))
-> ([[Char]], Maybe (MemSegmentOff w))
forall (w :: Nat) a.
ElfClass w -> (ElfWidthConstraints w => a) -> a
Elf.elfClassInstances (ElfHeader w -> ElfClass w
forall (w :: Nat). ElfHeader w -> ElfClass w
Elf.headerClass ElfHeader w
hdr) ((ElfWidthConstraints w => ([[Char]], Maybe (MemSegmentOff w)))
 -> ([[Char]], Maybe (MemSegmentOff w)))
-> (ElfWidthConstraints w => ([[Char]], Maybe (MemSegmentOff w)))
-> ([[Char]], Maybe (MemSegmentOff w))
forall a b. (a -> b) -> a -> b
$ do
    let adjAddr :: Integer
adjAddr =
          case LoadOptions -> Maybe Word64
loadOffset LoadOptions
loadOpts of
            Maybe Word64
Nothing -> ElfWordType w -> Integer
forall a. Integral a => a -> Integer
toInteger (ElfHeader w -> ElfWordType w
forall (w :: Nat). ElfHeader w -> ElfWordType w
Elf.headerEntry ElfHeader w
hdr)
            Just Word64
o -> Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
o Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ ElfWordType w -> Integer
forall a. Integral a => a -> Integer
toInteger (ElfHeader w -> ElfWordType w
forall (w :: Nat). ElfHeader w -> ElfWordType w
Elf.headerEntry ElfHeader w
hdr)
    case Memory w -> Int -> MemWord w -> Maybe (MemSegmentOff w)
forall (w :: Nat).
Memory w -> Int -> MemWord w -> Maybe (MemSegmentOff w)
resolveRegionOff Memory w
mem Int
regIdx (Integer -> MemWord w
forall a. Num a => Integer -> a
fromInteger Integer
adjAddr) of
      Maybe (MemSegmentOff w)
Nothing ->
        ( [[Char]
"Could not resolve entry point: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ElfWordType w -> ShowS
forall a. Integral a => a -> ShowS
showHex (ElfHeader w -> ElfWordType w
forall (w :: Nat). ElfHeader w -> ElfWordType w
Elf.headerEntry ElfHeader w
hdr) [Char]
""]
        , Maybe (MemSegmentOff w)
forall a. Maybe a
Nothing
        )
      Just MemSegmentOff w
v  -> ([], MemSegmentOff w -> Maybe (MemSegmentOff w)
forall a. a -> Maybe a
Just MemSegmentOff w
v)

-- | This interprets the Elf file to construct the initial memory,
-- entry points, and functions symbols.
--
-- If it encounters a fatal error it returns the error message in the
-- left value, and otherwise it returns the interpreted information as
-- a 4-tuple of: warnings, the initial memory image, possible entry
-- points (e.g. for an executable or shared library), and function
-- symbols.
resolveElfContents :: LoadOptions
                        -- ^ Options for loading contents
                   -> Elf.ElfHeaderInfo w
                   -> Either String
                             ( [String] -- Warnings
                             , Memory w -- Initial memory
                             , Maybe (MemSegmentOff w) -- Entry point(s)
                             , [MemSymbol w] -- Function symbols
                             )
resolveElfContents :: forall (w :: Nat).
LoadOptions
-> ElfHeaderInfo w
-> Either
     [Char] ([[Char]], Memory w, Maybe (MemSegmentOff w), [MemSymbol w])
resolveElfContents LoadOptions
loadOpts ElfHeaderInfo w
elf = do
  let hdr :: ElfHeader w
hdr = ElfHeaderInfo w -> ElfHeader w
forall (w :: Nat). ElfHeaderInfo w -> ElfHeader w
Elf.header ElfHeaderInfo w
elf
  let regIdx :: Int
regIdx = ElfType -> LoadOptions -> Int
adjustedLoadRegionIndex (ElfHeader w -> ElfType
forall (w :: Nat). ElfHeader w -> ElfType
Elf.headerType ElfHeader w
hdr) LoadOptions
loadOpts
  case ElfHeader w -> ElfType
forall (w :: Nat). ElfHeader w -> ElfType
Elf.headerType ElfHeader w
hdr of
    ElfType
Elf.ET_REL -> do
      (Memory w
mem, [MemSymbol w]
funcSymbols, [MemLoadWarning]
warnings, [SymbolResolutionError]
symErrs) <- LoadOptions
-> ElfHeaderInfo w
-> Either
     [Char]
     (Memory w, [MemSymbol w], [MemLoadWarning],
      [SymbolResolutionError])
forall (w :: Nat).
LoadOptions
-> ElfHeaderInfo w
-> Either
     [Char]
     (Memory w, [MemSymbol w], [MemLoadWarning],
      [SymbolResolutionError])
memoryForElf LoadOptions
loadOpts ElfHeaderInfo w
elf
      ([[Char]], Memory w, Maybe (MemSegmentOff w), [MemSymbol w])
-> Either
     [Char] ([[Char]], Memory w, Maybe (MemSegmentOff w), [MemSymbol w])
forall a. a -> Either [Char] a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((MemLoadWarning -> [Char]) -> [MemLoadWarning] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap MemLoadWarning -> [Char]
forall a. Show a => a -> [Char]
show [MemLoadWarning]
warnings [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (SymbolResolutionError -> [Char])
-> [SymbolResolutionError] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap SymbolResolutionError -> [Char]
forall a. Show a => a -> [Char]
show [SymbolResolutionError]
symErrs, Memory w
mem, Maybe (MemSegmentOff w)
forall a. Maybe a
Nothing, [MemSymbol w]
funcSymbols)
    ElfType
Elf.ET_EXEC -> do
      (Memory w
mem, [MemSymbol w]
funcSymbols, [MemLoadWarning]
warnings, [SymbolResolutionError]
symErrs) <- LoadOptions
-> ElfHeaderInfo w
-> Either
     [Char]
     (Memory w, [MemSymbol w], [MemLoadWarning],
      [SymbolResolutionError])
forall (w :: Nat).
LoadOptions
-> ElfHeaderInfo w
-> Either
     [Char]
     (Memory w, [MemSymbol w], [MemLoadWarning],
      [SymbolResolutionError])
memoryForElf LoadOptions
loadOpts ElfHeaderInfo w
elf
      let ([[Char]]
entryWarn, Maybe (MemSegmentOff w)
mentry) = LoadOptions
-> Memory w
-> Int
-> ElfHeader w
-> ([[Char]], Maybe (MemSegmentOff w))
forall (w :: Nat).
LoadOptions
-> Memory w
-> Int
-> ElfHeader w
-> ([[Char]], Maybe (MemSegmentOff w))
getElfEntry LoadOptions
loadOpts Memory w
mem Int
regIdx ElfHeader w
hdr
      ([[Char]], Memory w, Maybe (MemSegmentOff w), [MemSymbol w])
-> Either
     [Char] ([[Char]], Memory w, Maybe (MemSegmentOff w), [MemSymbol w])
forall a b. b -> Either a b
Right ((MemLoadWarning -> [Char]) -> [MemLoadWarning] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap MemLoadWarning -> [Char]
forall a. Show a => a -> [Char]
show [MemLoadWarning]
warnings [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (SymbolResolutionError -> [Char])
-> [SymbolResolutionError] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap SymbolResolutionError -> [Char]
forall a. Show a => a -> [Char]
show [SymbolResolutionError]
symErrs [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
entryWarn, Memory w
mem, Maybe (MemSegmentOff w)
mentry, [MemSymbol w]
funcSymbols)
    ElfType
Elf.ET_DYN -> do
      -- This is a shared library or position-independent executable.
      (Memory w
mem, [MemSymbol w]
funcSymbols, [MemLoadWarning]
warnings, [SymbolResolutionError]
symErrs) <- LoadOptions
-> ElfHeaderInfo w
-> Either
     [Char]
     (Memory w, [MemSymbol w], [MemLoadWarning],
      [SymbolResolutionError])
forall (w :: Nat).
LoadOptions
-> ElfHeaderInfo w
-> Either
     [Char]
     (Memory w, [MemSymbol w], [MemLoadWarning],
      [SymbolResolutionError])
memoryForElf LoadOptions
loadOpts ElfHeaderInfo w
elf
      let ([[Char]]
entryWarn, Maybe (MemSegmentOff w)
mentry) = LoadOptions
-> Memory w
-> Int
-> ElfHeader w
-> ([[Char]], Maybe (MemSegmentOff w))
forall (w :: Nat).
LoadOptions
-> Memory w
-> Int
-> ElfHeader w
-> ([[Char]], Maybe (MemSegmentOff w))
getElfEntry LoadOptions
loadOpts Memory w
mem Int
regIdx ElfHeader w
hdr
      ([[Char]], Memory w, Maybe (MemSegmentOff w), [MemSymbol w])
-> Either
     [Char] ([[Char]], Memory w, Maybe (MemSegmentOff w), [MemSymbol w])
forall a. a -> Either [Char] a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((MemLoadWarning -> [Char]) -> [MemLoadWarning] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap MemLoadWarning -> [Char]
forall a. Show a => a -> [Char]
show [MemLoadWarning]
warnings [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (SymbolResolutionError -> [Char])
-> [SymbolResolutionError] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap SymbolResolutionError -> [Char]
forall a. Show a => a -> [Char]
show [SymbolResolutionError]
symErrs [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
entryWarn, Memory w
mem, Maybe (MemSegmentOff w)
mentry, [MemSymbol w]
funcSymbols)
    ElfType
Elf.ET_CORE ->
      [Char]
-> Either
     [Char] ([[Char]], Memory w, Maybe (MemSegmentOff w), [MemSymbol w])
forall a b. a -> Either a b
Left [Char]
"No support for loading core files (Macaw)."
    ElfType
tp ->
      [Char]
-> Either
     [Char] ([[Char]], Memory w, Maybe (MemSegmentOff w), [MemSymbol w])
forall a b. a -> Either a b
Left ([Char]
 -> Either
      [Char]
      ([[Char]], Memory w, Maybe (MemSegmentOff w), [MemSymbol w]))
-> [Char]
-> Either
     [Char] ([[Char]], Memory w, Maybe (MemSegmentOff w), [MemSymbol w])
forall a b. (a -> b) -> a -> b
$ [Char]
"No support for loading ELF files with type " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ElfType -> [Char]
forall a. Show a => a -> [Char]
show ElfType
tp [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" (Macaw)."