-- GENERATED by C->Haskell Compiler, version 0.28.6 Switcheroo, 25 November 2017 (Haskell)
-- Edit the ORIGNAL .chs file instead!


{-# LINE 1 "src/Data/Array/Accelerate/LLVM/Native/Link/MachO.chs" #-}
{-# LANGUAGE CPP                      #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE MagicHash                #-}
{-# LANGUAGE RecordWildCards          #-}
{-# LANGUAGE TemplateHaskell          #-}
-- |
-- Module      : Data.Array.Accelerate.LLVM.Native.Link.MachO
-- Copyright   : [2017..2020] The Accelerate Team
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--

module Data.Array.Accelerate.LLVM.Native.Link.MachO (

  loadObject,

) where



import Data.Array.Accelerate.Error
import Data.Array.Accelerate.LLVM.Native.Link.Object
import Data.Array.Accelerate.Lifetime
import qualified Data.Array.Accelerate.Debug              as Debug

import Control.Applicative
import Control.Monad
import Data.Bits
import Data.ByteString                                    ( ByteString )
import Data.Maybe                                         ( catMaybes )
import Data.Serialize.Get
import Data.Vector                                        ( Vector )
import Data.Word
import Foreign.C
import Foreign.ForeignPtr
import Foreign.ForeignPtr.Unsafe
import Foreign.Marshal
import Foreign.Ptr
import Foreign.Storable
import GHC.ForeignPtr                                     ( mallocPlainForeignPtrAlignedBytes )
import GHC.Prim                                           ( addr2Int#, int2Word# )
import GHC.Ptr                                            ( Ptr(..) )
import GHC.Word                                           ( Word64(..) )
import System.IO.Unsafe
import System.Posix.DynamicLinker
import Text.Printf
import qualified Data.ByteString                          as B
import qualified Data.ByteString.Char8                    as B8
import qualified Data.ByteString.Internal                 as B
import qualified Data.ByteString.Short                    as BS
import qualified Data.ByteString.Unsafe                   as B
import qualified Data.Vector                              as V
import Prelude                                            as P









-- Dynamic object loading
-- ----------------------

-- Load a Mach-O object file and return pointers to the executable functions
-- defined within. The executable sections are aligned appropriately, as
-- specified in the object file, and are ready to be executed on the target
-- architecture.
--
loadObject :: HasCallStack => ByteString -> IO (FunctionTable, ObjectCode)
loadObject :: ByteString -> IO (FunctionTable, ObjectCode)
loadObject ByteString
obj =
  case ByteString -> Either String (Vector Symbol, Vector LoadSegment)
parseObject ByteString
obj of
    Left String
err            -> String -> IO (FunctionTable, ObjectCode)
forall a. HasCallStack => String -> a
internalError String
err
    Right (Vector Symbol
symtab, Vector LoadSegment
lcs) -> HasCallStack =>
ByteString
-> Vector Symbol
-> Vector LoadSegment
-> IO (FunctionTable, ObjectCode)
ByteString
-> Vector Symbol
-> Vector LoadSegment
-> IO (FunctionTable, ObjectCode)
loadSegments ByteString
obj Vector Symbol
symtab Vector LoadSegment
lcs


-- Execute the load segment commands and return function pointers to the
-- executable code in the target memory space.
--
loadSegments :: HasCallStack => ByteString -> Vector Symbol -> Vector LoadSegment -> IO (FunctionTable, ObjectCode)
loadSegments :: ByteString
-> Vector Symbol
-> Vector LoadSegment
-> IO (FunctionTable, ObjectCode)
loadSegments ByteString
obj Vector Symbol
symtab Vector LoadSegment
lcs = do
  -- Load the segments into executable memory.
  --
  Vector Segment
segs  <- (LoadSegment -> IO Segment)
-> Vector LoadSegment -> IO (Vector Segment)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
V.mapM (HasCallStack =>
ByteString -> Vector Symbol -> LoadSegment -> IO Segment
ByteString -> Vector Symbol -> LoadSegment -> IO Segment
loadSegment ByteString
obj Vector Symbol
symtab) Vector LoadSegment
lcs

  -- Resolve the external symbols defined in the sections of this object into
  -- function pointers.
  --
  -- Note that in order to support ahead-of-time compilation, the generated
  -- functions are given unique names by appending with an underscore followed
  -- by a unique ID. The execution phase doesn't need to know about this
  -- however, so un-mangle the name to the basic "map", "fold", etc.
  --
  let extern :: Symbol -> Bool
extern Symbol{Bool
Word8
Word64
ByteString
sym_extern :: Symbol -> Bool
sym_segment :: Symbol -> Word8
sym_value :: Symbol -> Word64
sym_name :: Symbol -> ByteString
sym_extern :: Bool
sym_segment :: Word8
sym_value :: Word64
sym_name :: ByteString
..}   = Bool
sym_extern Bool -> Bool -> Bool
&& Word8
sym_segment Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
0
      resolve :: Symbol -> (ShortByteString, FunPtr b)
resolve Symbol{Bool
Word8
Word64
ByteString
sym_extern :: Bool
sym_segment :: Word8
sym_value :: Word64
sym_name :: ByteString
sym_extern :: Symbol -> Bool
sym_segment :: Symbol -> Word8
sym_value :: Symbol -> Word64
sym_name :: Symbol -> ByteString
..}  =
        let Segment Int
_ ForeignPtr Word8
fp  = Vector Segment
segs Vector Segment -> Int -> Segment
forall a. Vector a -> Int -> a
V.! (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
sym_segmentWord8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
-Word8
1))
            name :: ShortByteString
name          = ByteString -> ShortByteString
BS.toShort (Int -> ByteString -> ByteString
B8.take (ByteString -> Int
B8.length ByteString
sym_name Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
65) ByteString
sym_name)
            addr :: FunPtr b
addr          = Ptr Any -> FunPtr b
forall a b. Ptr a -> FunPtr b
castPtrToFunPtr (ForeignPtr Word8 -> Ptr Word8
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr Word8
fp Ptr Word8 -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
sym_value)
        in
        (ShortByteString
name, FunPtr b
forall b. FunPtr b
addr)
      --
      funtab :: FunctionTable
funtab              = [Function] -> FunctionTable
FunctionTable ([Function] -> FunctionTable) -> [Function] -> FunctionTable
forall a b. (a -> b) -> a -> b
$ Vector Function -> [Function]
forall a. Vector a -> [a]
V.toList (Vector Function -> [Function]) -> Vector Function -> [Function]
forall a b. (a -> b) -> a -> b
$ (Symbol -> Function) -> Vector Symbol -> Vector Function
forall a b. (a -> b) -> Vector a -> Vector b
V.map Symbol -> Function
forall b. Symbol -> (ShortByteString, FunPtr b)
resolve ((Symbol -> Bool) -> Vector Symbol -> Vector Symbol
forall a. (a -> Bool) -> Vector a -> Vector a
V.filter Symbol -> Bool
extern Vector Symbol
symtab)
      objectcode :: [Segment]
objectcode          = Vector Segment -> [Segment]
forall a. Vector a -> [a]
V.toList Vector Segment
segs

  -- The executable pages were allocated on the GC heap. When the pages are
  -- finalised, unset the executable bit and mark them as read/write so that
  -- they can be reused.
  --
  ObjectCode
objectcode' <- [Segment] -> IO ObjectCode
forall a. a -> IO (Lifetime a)
newLifetime [Segment]
objectcode
  ObjectCode -> IO () -> IO ()
forall a. Lifetime a -> IO () -> IO ()
addFinalizer ObjectCode
objectcode' (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Flag -> String -> IO ()
Debug.traceIO Flag
Debug.dump_gc (String
"gc: unload module: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FunctionTable -> String
forall a. Show a => a -> String
show FunctionTable
funtab)
    [Segment] -> (Segment -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Segment]
objectcode ((Segment -> IO ()) -> IO ()) -> (Segment -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Segment Int
vmsize ForeignPtr Word8
oc_fp) -> do
      ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
oc_fp ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
oc_p -> do
        Ptr Word8 -> Int -> Int -> IO ()
mprotect Ptr Word8
oc_p Int
vmsize (Int
0x1 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
0x2)

  (FunctionTable, ObjectCode) -> IO (FunctionTable, ObjectCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (FunctionTable
funtab, ObjectCode
objectcode')


-- Load a segment and all its sections into memory.
--
-- Extra jump islands are added directly after the segment. On x86_64
-- PC-relative jumps and accesses to the global offset table (GOT) are limited
-- to 32-bit (+-2GB). If we need to go outside of this range then we must do so
-- via the jump islands.
--
-- NOTE: This puts all the sections into a single block of memory. Technically
-- this is incorrect because we then have both text and data sections together,
-- meaning that data sections are marked as execute when they really shouldn't
-- be. These would need to live in different pages in order to be mprotect-ed
-- properly.
--
loadSegment :: HasCallStack => ByteString -> Vector Symbol -> LoadSegment -> IO Segment
loadSegment :: ByteString -> Vector Symbol -> LoadSegment -> IO Segment
loadSegment ByteString
obj Vector Symbol
symtab seg :: LoadSegment
seg@LoadSegment{Int
ByteString
Vector LoadSection
seg_sections :: LoadSegment -> Vector LoadSection
seg_filesize :: LoadSegment -> Int
seg_fileoff :: LoadSegment -> Int
seg_vmsize :: LoadSegment -> Int
seg_vmaddr :: LoadSegment -> Int
seg_name :: LoadSegment -> ByteString
seg_sections :: Vector LoadSection
seg_filesize :: Int
seg_fileoff :: Int
seg_vmsize :: Int
seg_vmaddr :: Int
seg_name :: ByteString
..} = do
  let
      pagesize :: Int
pagesize    = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
c_getpagesize

      -- round up to next multiple of given alignment
      pad :: a -> a -> a
pad a
align a
n = (a
n a -> a -> a
forall a. Num a => a -> a -> a
+ a
align a -> a -> a
forall a. Num a => a -> a -> a
- a
1) a -> a -> a
forall a. Bits a => a -> a -> a
.&. (a -> a
forall a. Bits a => a -> a
complement (a
align a -> a -> a
forall a. Num a => a -> a -> a
- a
1))

      seg_vmsize' :: Int
seg_vmsize' = Int -> Int -> Int
forall a. (Bits a, Num a) => a -> a -> a
pad Int
16 Int
seg_vmsize                                   -- align jump islands to 16 bytes
      segsize :: Int
segsize     = Int -> Int -> Int
forall a. (Bits a, Num a) => a -> a -> a
pad Int
pagesize (Int
seg_vmsize' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Vector Symbol -> Int
forall a. Vector a -> Int
V.length Vector Symbol
symtab Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16)) -- jump entries are 16 bytes each (x86_64)
  --
  ForeignPtr Word8
seg_fp  <- Int -> Int -> IO (ForeignPtr Word8)
forall a. Int -> Int -> IO (ForeignPtr a)
mallocPlainForeignPtrAlignedBytes Int
segsize Int
pagesize
  ()
_       <- ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
seg_fp ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
seg_p -> do
              -- Just in case, clear out the segment data (corresponds to NOP)
              Ptr Word8 -> Word8 -> Int -> IO ()
forall a. Ptr a -> Word8 -> Int -> IO ()
fillBytes Ptr Word8
seg_p Word8
0 Int
segsize

              -- Jump tables are placed directly after the segment data
              let jump_p :: Ptr b
jump_p = Ptr Word8
seg_p Ptr Word8 -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
seg_vmsize'
              (Int -> Symbol -> IO ()) -> Vector Symbol -> IO ()
forall (m :: * -> *) a b.
Monad m =>
(Int -> a -> m b) -> Vector a -> m ()
V.imapM_ (Ptr Word8 -> Int -> Symbol -> IO ()
makeJumpIsland Ptr Word8
forall b. Ptr b
jump_p) Vector Symbol
symtab

              -- Process each of the sections of this segment
              (LoadSection -> IO ()) -> Vector LoadSection -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Vector a -> m ()
V.mapM_ (HasCallStack =>
ByteString
-> Vector Symbol
-> LoadSegment
-> Ptr Word8
-> Ptr Word8
-> LoadSection
-> IO ()
ByteString
-> Vector Symbol
-> LoadSegment
-> Ptr Word8
-> Ptr Word8
-> LoadSection
-> IO ()
loadSection ByteString
obj Vector Symbol
symtab LoadSegment
seg Ptr Word8
seg_p Ptr Word8
forall b. Ptr b
jump_p) Vector LoadSection
seg_sections

              -- Mark the page as executable and read-only
              Ptr Word8 -> Int -> Int -> IO ()
mprotect Ptr Word8
seg_p Int
segsize (Int
0x1 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
0x4)
  --
  Segment -> IO Segment
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ForeignPtr Word8 -> Segment
Segment Int
segsize ForeignPtr Word8
seg_fp)


-- Add the jump-table entries directly to each external undefined symbol.
--
makeJumpIsland :: Ptr Word8 -> Int -> Symbol -> IO ()
makeJumpIsland :: Ptr Word8 -> Int -> Symbol -> IO ()
makeJumpIsland Ptr Word8
jump_p Int
symbolnum Symbol{Bool
Word8
Word64
ByteString
sym_extern :: Bool
sym_segment :: Word8
sym_value :: Word64
sym_name :: ByteString
sym_extern :: Symbol -> Bool
sym_segment :: Symbol -> Word8
sym_value :: Symbol -> Word64
sym_name :: Symbol -> ByteString
..} = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
sym_extern Bool -> Bool -> Bool
&& Word8
sym_segment Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let
        target :: Ptr Word64
target  = Ptr Word8
jump_p Ptr Word8 -> Int -> Ptr Word64
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
symbolnum Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16) :: Ptr Word64
        instr :: Ptr Word8
instr   = Ptr Word64
target Ptr Word64 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
8                :: Ptr Word8
    --
    Ptr Word64 -> Word64 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word64
target Word64
sym_value
    Ptr Word8 -> [Word8] -> IO ()
forall a. Storable a => Ptr a -> [a] -> IO ()
pokeArray Ptr Word8
instr [ Word8
0xFF, Word8
0x25, Word8
0xF2, Word8
0xFF, Word8
0xFF, Word8
0xFF ]  -- jmp *-14(%rip)
  () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- Load a section at the correct offset into the given segment, and apply
-- relocations.
--
loadSection :: HasCallStack => ByteString -> Vector Symbol -> LoadSegment -> Ptr Word8 -> Ptr Word8 -> LoadSection -> IO ()
loadSection :: ByteString
-> Vector Symbol
-> LoadSegment
-> Ptr Word8
-> Ptr Word8
-> LoadSection
-> IO ()
loadSection ByteString
obj Vector Symbol
symtab LoadSegment
seg Ptr Word8
seg_p Ptr Word8
jump_p sec :: LoadSection
sec@LoadSection{Int
ByteString
Vector RelocationInfo
sec_relocs :: LoadSection -> Vector RelocationInfo
sec_align :: LoadSection -> Int
sec_offset :: LoadSection -> Int
sec_size :: LoadSection -> Int
sec_addr :: LoadSection -> Int
sec_segname :: LoadSection -> ByteString
sec_secname :: LoadSection -> ByteString
sec_relocs :: Vector RelocationInfo
sec_align :: Int
sec_offset :: Int
sec_size :: Int
sec_addr :: Int
sec_segname :: ByteString
sec_secname :: ByteString
..} = do
  let (ForeignPtr Word8
obj_fp, Int
obj_offset, Int
_) = ByteString -> (ForeignPtr Word8, Int, Int)
B.toForeignPtr ByteString
obj
  --
  ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
obj_fp ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
obj_p -> do
    -- Copy this section's data to the appropriate place in the segment
    let src :: Ptr b
src = Ptr Word8
obj_p Ptr Word8 -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
obj_offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sec_offset)
        dst :: Ptr b
dst = Ptr Word8
seg_p Ptr Word8 -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
sec_addr
    --
    Ptr Any -> Ptr Any -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr Any
forall b. Ptr b
dst Ptr Any
forall b. Ptr b
src Int
sec_size
    (RelocationInfo -> IO ()) -> Vector RelocationInfo -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Vector a -> m ()
V.mapM_ (HasCallStack =>
Vector Symbol
-> LoadSegment
-> Ptr Word8
-> Ptr Word8
-> LoadSection
-> RelocationInfo
-> IO ()
Vector Symbol
-> LoadSegment
-> Ptr Word8
-> Ptr Word8
-> LoadSection
-> RelocationInfo
-> IO ()
processRelocation Vector Symbol
symtab LoadSegment
seg Ptr Word8
seg_p Ptr Word8
jump_p LoadSection
sec) Vector RelocationInfo
sec_relocs


-- Process both local and external relocations. The former are probably not
-- necessary since we load all sections into the same memory segment at the
-- correct offsets.
--
processRelocation :: HasCallStack => Vector Symbol -> LoadSegment -> Ptr Word8 -> Ptr Word8 -> LoadSection -> RelocationInfo -> IO ()
processRelocation :: Vector Symbol
-> LoadSegment
-> Ptr Word8
-> Ptr Word8
-> LoadSection
-> RelocationInfo
-> IO ()
processRelocation Vector Symbol
symtab LoadSegment{} Ptr Word8
seg_p Ptr Word8
jump_p LoadSection
sec RelocationInfo{Bool
Int
RelocationType
ri_type :: RelocationInfo -> RelocationType
ri_extern :: RelocationInfo -> Bool
ri_pcrel :: RelocationInfo -> Bool
ri_length :: RelocationInfo -> Int
ri_symbolnum :: RelocationInfo -> Int
ri_address :: RelocationInfo -> Int
ri_type :: RelocationType
ri_extern :: Bool
ri_pcrel :: Bool
ri_length :: Int
ri_symbolnum :: Int
ri_address :: Int
..}
  -- Relocation through global offset table
  --
  | RelocationType
ri_type RelocationType -> RelocationType -> Bool
forall a. Eq a => a -> a -> Bool
== RelocationType
X86_64_RELOC_GOT Bool -> Bool -> Bool
||
    RelocationType
ri_type RelocationType -> RelocationType -> Bool
forall a. Eq a => a -> a -> Bool
== RelocationType
X86_64_RELOC_GOT_LOAD
  = String -> IO ()
forall a. HasCallStack => String -> a
internalError String
"Global offset table relocations not handled yet"

  -- External symbols, both those defined in the sections of this object, and
  -- undefined externals. For the latter, the symbol might be outside of the
  -- range of 32-bit pc-relative addressing, in which case we need to go via the
  -- jump tables.
  --
  | Bool
ri_extern
  = let value :: Word64
value     = Symbol -> Word64
sym_value (Vector Symbol
symtab Vector Symbol -> Int -> Symbol
forall a. Vector a -> Int -> a
V.! Int
ri_symbolnum)
        value_rel :: Word64
value_rel = Word64
value Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
pc' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
2 Word64 -> Int -> Word64
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
ri_length -- also subtract size of instruction from PC
    in
    case Bool
ri_pcrel of
      Bool
False -> Word64 -> IO ()
relocate Word64
value
      Bool
True  -> if (Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
value_rel::Word32) :: Word64) Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
value_rel
                 then Word64 -> IO ()
relocate Word64
value_rel
                 else do
                   let value' :: Word64
value'     = Ptr Any -> Word64
forall a. Ptr a -> Word64
castPtrToWord64 (Ptr Word8
jump_p Ptr Word8 -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
ri_symbolnum Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
8))
                       value'_rel :: Word64
value'_rel = Word64
value' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
pc' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
2 Word64 -> Int -> Word64
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
ri_length
                   --
                   -- message (printf "relocating %s via jump table" (B8.unpack (sym_name (symtab V.! ri_symbolnum))))
                   Word64 -> IO ()
relocate Word64
value'_rel

  -- Internal relocation (to constant sections, for example). Since the sections
  -- are loaded at the appropriate offsets in a single contiguous segment, this
  -- is unnecessary.
  --
  | Bool
otherwise
  = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  where
    pc :: Ptr Word8
    pc :: Ptr Word8
pc  = Ptr Word8
seg_p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (LoadSection -> Int
sec_addr LoadSection
sec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ri_address)
    pc' :: Word64
pc' = Ptr Word8 -> Word64
forall a. Ptr a -> Word64
castPtrToWord64 Ptr Word8
pc

    -- Include the addend value already encoded in the instruction
    addend :: (Integral a, Storable a) => Ptr a -> Word64 -> IO a
    addend :: Ptr a -> Word64 -> IO a
addend Ptr a
p Word64
x = do
      a
base <- Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek Ptr a
p
      case RelocationType
ri_type of
        RelocationType
X86_64_RELOC_SUBTRACTOR -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ Word64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
base Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
x)
        RelocationType
_                       -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ Word64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
base Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
x)

    -- Write the new relocated address
    relocate :: Word64 -> IO ()
    relocate :: Word64 -> IO ()
relocate Word64
x =
      case Int
ri_length of
        Int
0 -> let p' :: Ptr Word8
p' = Ptr Word8 -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
pc :: Ptr Word8  in Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
p' (Word8 -> IO ()) -> IO Word8 -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr Word8 -> Word64 -> IO Word8
forall a. (Integral a, Storable a) => Ptr a -> Word64 -> IO a
addend Ptr Word8
p' Word64
x
        Int
1 -> let p' :: Ptr Word16
p' = Ptr Word8 -> Ptr Word16
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
pc :: Ptr Word16 in Ptr Word16 -> Word16 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word16
p' (Word16 -> IO ()) -> IO Word16 -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr Word16 -> Word64 -> IO Word16
forall a. (Integral a, Storable a) => Ptr a -> Word64 -> IO a
addend Ptr Word16
p' Word64
x
        Int
2 -> let p' :: Ptr Word32
p' = Ptr Word8 -> Ptr Word32
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
pc :: Ptr Word32 in Ptr Word32 -> Word32 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word32
p' (Word32 -> IO ()) -> IO Word32 -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr Word32 -> Word64 -> IO Word32
forall a. (Integral a, Storable a) => Ptr a -> Word64 -> IO a
addend Ptr Word32
p' Word64
x
        Int
_ -> String -> IO ()
forall a. HasCallStack => String -> a
internalError String
"unhandled relocation size"



-- Object file parser
-- ------------------

-- Parsing depends on whether the Mach-O file is 64-bit and whether it should be
-- read as big- or little-endian.
--
data Peek = Peek
    { Peek -> Bool
is64Bit   :: !Bool
    , Peek -> Get Word16
getWord16 :: !(Get Word16)
    , Peek -> Get Word32
getWord32 :: !(Get Word32)
    , Peek -> Get Word64
getWord64 :: !(Get Word64)
    }

-- Load commands directly follow the Mach-O header.
--
data LoadCommand
    = LC_Segment     {-# UNPACK #-} !LoadSegment
    | LC_SymbolTable {-# UNPACK #-} !(Vector Symbol)

-- Indicates that a part of this file is to be mapped into the task's
-- address space. The size of the segment in memory, vmsize, must be equal
-- to or larger than the amount to map from this file, filesize. The file is
-- mapped starting at fileoff to the beginning of the segment in memory,
-- vmaddr. If the segment has sections then the section structures directly
-- follow the segment command.
--
-- For compactness object files contain only one (unnamed) segment, which
-- contains all the sections.
--
data LoadSegment = LoadSegment
    { LoadSegment -> ByteString
seg_name      :: {-# UNPACK #-} !ByteString
    , LoadSegment -> Int
seg_vmaddr    :: {-# UNPACK #-} !Int                      -- starting virtual memory address of the segment
    , LoadSegment -> Int
seg_vmsize    :: {-# UNPACK #-} !Int                      -- size (bytes) of virtual memory occupied by the segment
    , LoadSegment -> Int
seg_fileoff   :: {-# UNPACK #-} !Int                      -- offset in the file for the data mapped at 'seg_vmaddr'
    , LoadSegment -> Int
seg_filesize  :: {-# UNPACK #-} !Int                      -- size (bytes) of the segment in the file
    , LoadSegment -> Vector LoadSection
seg_sections  :: {-# UNPACK #-} !(Vector LoadSection)     -- the sections of this segment
    }
    deriving Int -> LoadSegment -> String -> String
[LoadSegment] -> String -> String
LoadSegment -> String
(Int -> LoadSegment -> String -> String)
-> (LoadSegment -> String)
-> ([LoadSegment] -> String -> String)
-> Show LoadSegment
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [LoadSegment] -> String -> String
$cshowList :: [LoadSegment] -> String -> String
show :: LoadSegment -> String
$cshow :: LoadSegment -> String
showsPrec :: Int -> LoadSegment -> String -> String
$cshowsPrec :: Int -> LoadSegment -> String -> String
Show

data LoadSection = LoadSection
    { LoadSection -> ByteString
sec_secname   :: {-# UNPACK #-} !ByteString
    , LoadSection -> ByteString
sec_segname   :: {-# UNPACK #-} !ByteString
    , LoadSection -> Int
sec_addr      :: {-# UNPACK #-} !Int                      -- virtual memory address of this section
    , LoadSection -> Int
sec_size      :: {-# UNPACK #-} !Int                      -- size in bytes
    , LoadSection -> Int
sec_offset    :: {-# UNPACK #-} !Int                      -- offset of this section in the file
    , LoadSection -> Int
sec_align     :: {-# UNPACK #-} !Int
    , LoadSection -> Vector RelocationInfo
sec_relocs    :: {-# UNPACK #-} !(Vector RelocationInfo)
    }
    deriving Int -> LoadSection -> String -> String
[LoadSection] -> String -> String
LoadSection -> String
(Int -> LoadSection -> String -> String)
-> (LoadSection -> String)
-> ([LoadSection] -> String -> String)
-> Show LoadSection
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [LoadSection] -> String -> String
$cshowList :: [LoadSection] -> String -> String
show :: LoadSection -> String
$cshow :: LoadSection -> String
showsPrec :: Int -> LoadSection -> String -> String
$cshowsPrec :: Int -> LoadSection -> String -> String
Show

data RelocationInfo = RelocationInfo
    { RelocationInfo -> Int
ri_address    :: {-# UNPACK #-} !Int                      -- offset from start of the section
    , RelocationInfo -> Int
ri_symbolnum  :: {-# UNPACK #-} !Int                      -- index into the symbol table (when ri_extern=True) else section number (??)
    , RelocationInfo -> Int
ri_length     :: {-# UNPACK #-} !Int                      -- length of address (bytes) to be relocated
    , RelocationInfo -> Bool
ri_pcrel      :: !Bool                                    -- item containing the address to be relocated uses PC-relative addressing
    , RelocationInfo -> Bool
ri_extern     :: !Bool
    , RelocationInfo -> RelocationType
ri_type       :: !RelocationType                          -- type of relocation
    }
    deriving Int -> RelocationInfo -> String -> String
[RelocationInfo] -> String -> String
RelocationInfo -> String
(Int -> RelocationInfo -> String -> String)
-> (RelocationInfo -> String)
-> ([RelocationInfo] -> String -> String)
-> Show RelocationInfo
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [RelocationInfo] -> String -> String
$cshowList :: [RelocationInfo] -> String -> String
show :: RelocationInfo -> String
$cshow :: RelocationInfo -> String
showsPrec :: Int -> RelocationInfo -> String -> String
$cshowsPrec :: Int -> RelocationInfo -> String -> String
Show

-- A symbol defined in the sections of this object
--
data Symbol = Symbol
    { Symbol -> ByteString
sym_name      :: {-# UNPACK #-} !ByteString
    , Symbol -> Word64
sym_value     :: {-# UNPACK #-} !Word64
    , Symbol -> Word8
sym_segment   :: {-# UNPACK #-} !Word8
    , Symbol -> Bool
sym_extern    :: !Bool
    }
    deriving Int -> Symbol -> String -> String
[Symbol] -> String -> String
Symbol -> String
(Int -> Symbol -> String -> String)
-> (Symbol -> String)
-> ([Symbol] -> String -> String)
-> Show Symbol
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Symbol] -> String -> String
$cshowList :: [Symbol] -> String -> String
show :: Symbol -> String
$cshow :: Symbol -> String
showsPrec :: Int -> Symbol -> String -> String
$cshowsPrec :: Int -> Symbol -> String -> String
Show

data RelocationType = X86_64_RELOC_UNSIGNED
                    | X86_64_RELOC_SIGNED
                    | X86_64_RELOC_BRANCH
                    | X86_64_RELOC_GOT_LOAD
                    | X86_64_RELOC_GOT
                    | X86_64_RELOC_SUBTRACTOR
                    | X86_64_RELOC_SIGNED_1
                    | X86_64_RELOC_SIGNED_2
                    | X86_64_RELOC_SIGNED_4
                    | X86_64_RELOC_TLV
  deriving (Int -> RelocationType
RelocationType -> Int
RelocationType -> [RelocationType]
RelocationType -> RelocationType
RelocationType -> RelocationType -> [RelocationType]
RelocationType
-> RelocationType -> RelocationType -> [RelocationType]
(RelocationType -> RelocationType)
-> (RelocationType -> RelocationType)
-> (Int -> RelocationType)
-> (RelocationType -> Int)
-> (RelocationType -> [RelocationType])
-> (RelocationType -> RelocationType -> [RelocationType])
-> (RelocationType -> RelocationType -> [RelocationType])
-> (RelocationType
    -> RelocationType -> RelocationType -> [RelocationType])
-> Enum RelocationType
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: RelocationType
-> RelocationType -> RelocationType -> [RelocationType]
$cenumFromThenTo :: RelocationType
-> RelocationType -> RelocationType -> [RelocationType]
enumFromTo :: RelocationType -> RelocationType -> [RelocationType]
$cenumFromTo :: RelocationType -> RelocationType -> [RelocationType]
enumFromThen :: RelocationType -> RelocationType -> [RelocationType]
$cenumFromThen :: RelocationType -> RelocationType -> [RelocationType]
enumFrom :: RelocationType -> [RelocationType]
$cenumFrom :: RelocationType -> [RelocationType]
fromEnum :: RelocationType -> Int
$cfromEnum :: RelocationType -> Int
toEnum :: Int -> RelocationType
$ctoEnum :: Int -> RelocationType
pred :: RelocationType -> RelocationType
$cpred :: RelocationType -> RelocationType
succ :: RelocationType -> RelocationType
$csucc :: RelocationType -> RelocationType
Enum,RelocationType -> RelocationType -> Bool
(RelocationType -> RelocationType -> Bool)
-> (RelocationType -> RelocationType -> Bool) -> Eq RelocationType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RelocationType -> RelocationType -> Bool
$c/= :: RelocationType -> RelocationType -> Bool
== :: RelocationType -> RelocationType -> Bool
$c== :: RelocationType -> RelocationType -> Bool
Eq,Int -> RelocationType -> String -> String
[RelocationType] -> String -> String
RelocationType -> String
(Int -> RelocationType -> String -> String)
-> (RelocationType -> String)
-> ([RelocationType] -> String -> String)
-> Show RelocationType
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [RelocationType] -> String -> String
$cshowList :: [RelocationType] -> String -> String
show :: RelocationType -> String
$cshow :: RelocationType -> String
showsPrec :: Int -> RelocationType -> String -> String
$cshowsPrec :: Int -> RelocationType -> String -> String
Show)

{-# LINE 346 "src/Data/Array/Accelerate/LLVM/Native/Link/MachO.chs" #-}



-- Parse the Mach-O object file and return the set of section load commands, as
-- well as the symbols defined within the sections of this object.
--
-- Actually _executing_ the load commands, which entails copying the pointed-to
-- segments into an appropriate VM image in the target address space, happens
-- separately.
--
parseObject :: ByteString -> Either String (Vector Symbol, Vector LoadSegment)
parseObject :: ByteString -> Either String (Vector Symbol, Vector LoadSegment)
parseObject ByteString
obj = do
  ((Peek
p, Int
ncmd, Int
_), ByteString
rest)  <- Get (Peek, Int, Int)
-> ByteString
-> Int
-> Either String ((Peek, Int, Int), ByteString)
forall a.
Get a -> ByteString -> Int -> Either String (a, ByteString)
runGetState Get (Peek, Int, Int)
readHeader ByteString
obj Int
0
  [LoadCommand]
cmds                  <- [Maybe LoadCommand] -> [LoadCommand]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe LoadCommand] -> [LoadCommand])
-> Either String [Maybe LoadCommand] -> Either String [LoadCommand]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get [Maybe LoadCommand]
-> ByteString -> Either String [Maybe LoadCommand]
forall a. Get a -> ByteString -> Either String a
runGet (Int -> Get (Maybe LoadCommand) -> Get [Maybe LoadCommand]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
ncmd (Peek -> ByteString -> Get (Maybe LoadCommand)
readLoadCommand Peek
p ByteString
obj)) ByteString
rest
  let
      lc :: [LoadSegment]
lc = [ LoadSegment
x | LC_Segment     LoadSegment
x <- [LoadCommand]
cmds ]
      st :: [Vector Symbol]
st = [ Vector Symbol
x | LC_SymbolTable Vector Symbol
x <- [LoadCommand]
cmds ]
  --
  (Vector Symbol, Vector LoadSegment)
-> Either String (Vector Symbol, Vector LoadSegment)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Vector Symbol] -> Vector Symbol
forall a. [Vector a] -> Vector a
V.concat [Vector Symbol]
st, Int -> [LoadSegment] -> Vector LoadSegment
forall a. Int -> [a] -> Vector a
V.fromListN Int
ncmd [LoadSegment]
lc)


-- The Mach-O file consists of a header block, a number of load commands,
-- followed by the segment data.
--
--   +-------------------+
--   |   Mach-O header   |
--   +-------------------+  <- sizeofheader
--   |   Load command    |
--   |   Load command    |
--   |        ...        |
--   +-------------------+  <- sizeofcmds + sizeofheader
--   |   Segment data    |
--   |   Segment data    |
--   |        ...        |
--   +-------------------+
--
readHeader :: Get (Peek, Int, Int)
readHeader :: Get (Peek, Int, Int)
readHeader = do
  Word32
magic       <- Get Word32
getWord32le
  p :: Peek
p@Peek{Bool
Get Word16
Get Word32
Get Word64
getWord64 :: Get Word64
getWord32 :: Get Word32
getWord16 :: Get Word16
is64Bit :: Bool
getWord64 :: Peek -> Get Word64
getWord32 :: Peek -> Get Word32
getWord16 :: Peek -> Get Word16
is64Bit :: Peek -> Bool
..}  <- case Word32
magic of
                   Word32
0xfeedface    -> Peek -> Get Peek
forall (m :: * -> *) a. Monad m => a -> m a
return (Peek -> Get Peek) -> Peek -> Get Peek
forall a b. (a -> b) -> a -> b
$ Bool -> Get Word16 -> Get Word32 -> Get Word64 -> Peek
Peek Bool
False Get Word16
getWord16le Get Word32
getWord32le Get Word64
getWord64le
                   Word32
0xcefaedfe    -> Peek -> Get Peek
forall (m :: * -> *) a. Monad m => a -> m a
return (Peek -> Get Peek) -> Peek -> Get Peek
forall a b. (a -> b) -> a -> b
$ Bool -> Get Word16 -> Get Word32 -> Get Word64 -> Peek
Peek Bool
False Get Word16
getWord16be Get Word32
getWord32be Get Word64
getWord64be
                   Word32
0xfeedfacf -> Peek -> Get Peek
forall (m :: * -> *) a. Monad m => a -> m a
return (Peek -> Get Peek) -> Peek -> Get Peek
forall a b. (a -> b) -> a -> b
$ Bool -> Get Word16 -> Get Word32 -> Get Word64 -> Peek
Peek Bool
True  Get Word16
getWord16le Get Word32
getWord32le Get Word64
getWord64le
                   Word32
0xcffaedfe -> Peek -> Get Peek
forall (m :: * -> *) a. Monad m => a -> m a
return (Peek -> Get Peek) -> Peek -> Get Peek
forall a b. (a -> b) -> a -> b
$ Bool -> Get Word16 -> Get Word32 -> Get Word64 -> Peek
Peek Bool
True  Get Word16
getWord16be Get Word32
getWord32be Get Word64
getWord64be
                   Word32
m                     -> String -> Get Peek
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Word32 -> String
forall r. PrintfType r => String -> r
printf String
"unknown magic: %x" Word32
m)
  Word32
cpu_type    <- Get Word32
getWord32
  -- c2HS has trouble with the CPU_TYPE_* macros due to the type cast
  Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
cpu_type Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0x1000007) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$ String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected x86_64 object file"
  Int -> Get ()
skip Int
4
{-# LINE 404 "src/Data/Array/Accelerate/LLVM/Native/Link/MachO.chs" #-}

  Word32
filetype    <- Get Word32
getWord32
  case Word32
filetype of
    Word32
0x1 -> () -> Get ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Word32
_                   -> String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected object file"
  Int
ncmds       <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32
  Int
sizeofcmds  <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32
  Int -> Get ()
skip (Int -> Get ()) -> Int -> Get ()
forall a b. (a -> b) -> a -> b
$ case Bool
is64Bit of
           Bool
True  -> Int
8 -- flags + reserved
           Bool
False -> Int
4 -- flags
  (Peek, Int, Int) -> Get (Peek, Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Peek
p, Int
ncmds, Int
sizeofcmds)


-- Read a segment load command from the Mach-O file.
--
-- The only thing we are interested in are the symbol table, which tell us which
-- external symbols are defined by this object, and the load commands, which
-- indicate part of the file is to be mapped into the target address space.
-- These will tell us everything we need to know about the generated machine
-- code in order to execute it.
--
-- Since we are only concerned with loading object files, there should really
-- only be one of each of these.
--
readLoadCommand :: Peek -> ByteString -> Get (Maybe LoadCommand)
readLoadCommand :: Peek -> ByteString -> Get (Maybe LoadCommand)
readLoadCommand p :: Peek
p@Peek{Bool
Get Word16
Get Word32
Get Word64
getWord64 :: Get Word64
getWord32 :: Get Word32
getWord16 :: Get Word16
is64Bit :: Bool
getWord64 :: Peek -> Get Word64
getWord32 :: Peek -> Get Word32
getWord16 :: Peek -> Get Word16
is64Bit :: Peek -> Bool
..} ByteString
obj = do
  Word32
cmd     <- Get Word32
getWord32
  Int
cmdsize <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32
  --
  let required :: Bool
required = Word32 -> Bool
forall a. (Eq a, Num a) => a -> Bool
toBool (Word32 -> Bool) -> Word32 -> Bool
forall a b. (a -> b) -> a -> b
$ Word32
cmd Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x80000000
{-# LINE 433 "src/Data/Array/Accelerate/LLVM/Native/Link/MachO.chs" #-}

  --
  case Word32
cmd Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. (Word32 -> Word32
forall a. Bits a => a -> a
complement Word32
0x80000000) of
    Word32
0x1    -> LoadCommand -> Maybe LoadCommand
forall a. a -> Maybe a
Just (LoadCommand -> Maybe LoadCommand)
-> (LoadSegment -> LoadCommand) -> LoadSegment -> Maybe LoadCommand
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadSegment -> LoadCommand
LC_Segment     (LoadSegment -> Maybe LoadCommand)
-> Get LoadSegment -> Get (Maybe LoadCommand)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Peek -> ByteString -> Get LoadSegment
readLoadSegment Peek
p ByteString
obj
    Word32
0x19 -> LoadCommand -> Maybe LoadCommand
forall a. a -> Maybe a
Just (LoadCommand -> Maybe LoadCommand)
-> (LoadSegment -> LoadCommand) -> LoadSegment -> Maybe LoadCommand
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadSegment -> LoadCommand
LC_Segment     (LoadSegment -> Maybe LoadCommand)
-> Get LoadSegment -> Get (Maybe LoadCommand)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Peek -> ByteString -> Get LoadSegment
readLoadSegment Peek
p ByteString
obj
    Word32
0x2     -> LoadCommand -> Maybe LoadCommand
forall a. a -> Maybe a
Just (LoadCommand -> Maybe LoadCommand)
-> (Vector Symbol -> LoadCommand)
-> Vector Symbol
-> Maybe LoadCommand
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Symbol -> LoadCommand
LC_SymbolTable (Vector Symbol -> Maybe LoadCommand)
-> Get (Vector Symbol) -> Get (Maybe LoadCommand)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Peek -> ByteString -> Get (Vector Symbol)
readLoadSymbolTable Peek
p ByteString
obj
    Word32
0xb   -> Maybe LoadCommand -> () -> Maybe LoadCommand
forall a b. a -> b -> a
const Maybe LoadCommand
forall a. Maybe a
Nothing         (() -> Maybe LoadCommand) -> Get () -> Get (Maybe LoadCommand)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Peek -> ByteString -> Get ()
readDynamicSymbolTable Peek
p ByteString
obj
    Word32
0xc -> String -> Get (Maybe LoadCommand)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unhandled LC_LOAD_DYLIB"
    Word32
this                    -> do if Bool
required
                                    then String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail    (String -> Word32 -> String
forall r. PrintfType r => String -> r
printf String
"unknown load command required for execution: 0x%x" Word32
this)
                                    else String -> Get ()
forall (m :: * -> *). Monad m => String -> m ()
message (String -> Word32 -> String
forall r. PrintfType r => String -> r
printf String
"skipping load command: 0x%x" Word32
this)
                                  Int -> Get ()
skip (Int
cmdsize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
8)
                                  Maybe LoadCommand -> Get (Maybe LoadCommand)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe LoadCommand
forall a. Maybe a
Nothing


-- Read a load segment command, including any relocation entries.
--
readLoadSegment :: Peek -> ByteString -> Get LoadSegment
readLoadSegment :: Peek -> ByteString -> Get LoadSegment
readLoadSegment p :: Peek
p@Peek{Bool
Get Word16
Get Word32
Get Word64
getWord64 :: Get Word64
getWord32 :: Get Word32
getWord16 :: Get Word16
is64Bit :: Bool
getWord64 :: Peek -> Get Word64
getWord32 :: Peek -> Get Word32
getWord16 :: Peek -> Get Word16
is64Bit :: Peek -> Bool
..} ByteString
obj =
  if Bool
is64Bit
    then Peek -> ByteString -> Get LoadSegment
readLoadSegment64 Peek
p ByteString
obj
    else Peek -> ByteString -> Get LoadSegment
readLoadSegment32 Peek
p ByteString
obj

readLoadSegment32 :: Peek -> ByteString -> Get LoadSegment
readLoadSegment32 :: Peek -> ByteString -> Get LoadSegment
readLoadSegment32 p :: Peek
p@Peek{Bool
Get Word16
Get Word32
Get Word64
getWord64 :: Get Word64
getWord32 :: Get Word32
getWord16 :: Get Word16
is64Bit :: Bool
getWord64 :: Peek -> Get Word64
getWord32 :: Peek -> Get Word32
getWord16 :: Peek -> Get Word16
is64Bit :: Peek -> Bool
..} ByteString
obj = do
  ByteString
name      <- (Word8 -> Bool) -> ByteString -> ByteString
B.takeWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0) (ByteString -> ByteString) -> Get ByteString -> Get ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getBytes Int
16
  Int
vmaddr    <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32
  Int
vmsize    <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32
  Int
fileoff   <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32
  Int
filesize  <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32
  Int -> Get ()
skip (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4) -- maxprot, initprot
  Int
nsect     <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32
  Int -> Get ()
skip Int
4    -- flags
  --
  String -> Get ()
forall (m :: * -> *). Monad m => String -> m ()
message (String -> Int -> Int -> String
forall r. PrintfType r => String -> r
printf String
"LC_SEGMENT:            Mem: 0x%09x-0x09%x" Int
vmaddr (Int
vmaddr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
vmsize))
  Vector LoadSection
secs      <- Int -> Get LoadSection -> Get (Vector LoadSection)
forall (m :: * -> *) a. Monad m => Int -> m a -> m (Vector a)
V.replicateM Int
nsect (Peek -> ByteString -> Get LoadSection
readLoadSection32 Peek
p ByteString
obj)
  --
  LoadSegment -> Get LoadSegment
forall (m :: * -> *) a. Monad m => a -> m a
return LoadSegment :: ByteString
-> Int -> Int -> Int -> Int -> Vector LoadSection -> LoadSegment
LoadSegment
          { seg_name :: ByteString
seg_name     = ByteString
name
          , seg_vmaddr :: Int
seg_vmaddr   = Int
vmaddr
          , seg_vmsize :: Int
seg_vmsize   = Int
vmsize
          , seg_fileoff :: Int
seg_fileoff  = Int
fileoff
          , seg_filesize :: Int
seg_filesize = Int
filesize
          , seg_sections :: Vector LoadSection
seg_sections = Vector LoadSection
secs
          }

readLoadSegment64 :: Peek -> ByteString -> Get LoadSegment
readLoadSegment64 :: Peek -> ByteString -> Get LoadSegment
readLoadSegment64 p :: Peek
p@Peek{Bool
Get Word16
Get Word32
Get Word64
getWord64 :: Get Word64
getWord32 :: Get Word32
getWord16 :: Get Word16
is64Bit :: Bool
getWord64 :: Peek -> Get Word64
getWord32 :: Peek -> Get Word32
getWord16 :: Peek -> Get Word16
is64Bit :: Peek -> Bool
..} ByteString
obj = do
  ByteString
name      <- (Word8 -> Bool) -> ByteString -> ByteString
B.takeWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0) (ByteString -> ByteString) -> Get ByteString -> Get ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getBytes Int
16
  Int
vmaddr    <- Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Get Word64 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
getWord64
  Int
vmsize    <- Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Get Word64 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
getWord64
  Int
fileoff   <- Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Get Word64 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
getWord64
  Int
filesize  <- Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Get Word64 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
getWord64
  Int -> Get ()
skip (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4) -- maxprot, initprot
  Int
nsect     <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32
  Int -> Get ()
skip Int
4    -- flags
  --
  String -> Get ()
forall (m :: * -> *). Monad m => String -> m ()
message (String -> Int -> Int -> String
forall r. PrintfType r => String -> r
printf String
"LC_SEGMENT_64:         Mem: 0x%09x-0x%09x" Int
vmaddr (Int
vmaddr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
vmsize))
  Vector LoadSection
secs      <- Int -> Get LoadSection -> Get (Vector LoadSection)
forall (m :: * -> *) a. Monad m => Int -> m a -> m (Vector a)
V.replicateM Int
nsect (Peek -> ByteString -> Get LoadSection
readLoadSection64 Peek
p ByteString
obj)
  --
  LoadSegment -> Get LoadSegment
forall (m :: * -> *) a. Monad m => a -> m a
return LoadSegment :: ByteString
-> Int -> Int -> Int -> Int -> Vector LoadSection -> LoadSegment
LoadSegment
          { seg_name :: ByteString
seg_name     = ByteString
name
          , seg_vmaddr :: Int
seg_vmaddr   = Int
vmaddr
          , seg_vmsize :: Int
seg_vmsize   = Int
vmsize
          , seg_fileoff :: Int
seg_fileoff  = Int
fileoff
          , seg_filesize :: Int
seg_filesize = Int
filesize
          , seg_sections :: Vector LoadSection
seg_sections = Vector LoadSection
secs
          }

readLoadSection32 :: Peek -> ByteString -> Get LoadSection
readLoadSection32 :: Peek -> ByteString -> Get LoadSection
readLoadSection32 p :: Peek
p@Peek{Bool
Get Word16
Get Word32
Get Word64
getWord64 :: Get Word64
getWord32 :: Get Word32
getWord16 :: Get Word16
is64Bit :: Bool
getWord64 :: Peek -> Get Word64
getWord32 :: Peek -> Get Word32
getWord16 :: Peek -> Get Word16
is64Bit :: Peek -> Bool
..} ByteString
obj = do
  ByteString
secname   <- (Word8 -> Bool) -> ByteString -> ByteString
B.takeWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0) (ByteString -> ByteString) -> Get ByteString -> Get ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getBytes Int
16
  ByteString
segname   <- (Word8 -> Bool) -> ByteString -> ByteString
B.takeWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0) (ByteString -> ByteString) -> Get ByteString -> Get ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getBytes Int
16
  Int
addr      <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32
  Int
size      <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32
  Int
offset    <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32
  Int
align     <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32
  Int
reloff    <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32
  Int
nreloc    <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32
  Int -> Get ()
skip Int
12   -- flags, reserved1, reserved2
  --
  String -> Get ()
forall (m :: * -> *). Monad m => String -> m ()
message (String -> Int -> Int -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"  Mem: 0x%09x-0x%09x         %s.%s" Int
addr (Int
addrInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
size) (ByteString -> String
B8.unpack ByteString
segname) (ByteString -> String
B8.unpack ByteString
secname))
  Vector RelocationInfo
relocs    <- (String -> Get (Vector RelocationInfo))
-> (Vector RelocationInfo -> Get (Vector RelocationInfo))
-> Either String (Vector RelocationInfo)
-> Get (Vector RelocationInfo)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Get (Vector RelocationInfo)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail Vector RelocationInfo -> Get (Vector RelocationInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (Vector RelocationInfo)
 -> Get (Vector RelocationInfo))
-> Either String (Vector RelocationInfo)
-> Get (Vector RelocationInfo)
forall a b. (a -> b) -> a -> b
$ Get (Vector RelocationInfo)
-> ByteString -> Either String (Vector RelocationInfo)
forall a. Get a -> ByteString -> Either String a
runGet (Int -> Get RelocationInfo -> Get (Vector RelocationInfo)
forall (m :: * -> *) a. Monad m => Int -> m a -> m (Vector a)
V.replicateM Int
nreloc (Peek -> Get RelocationInfo
loadRelocation Peek
p)) (Int -> ByteString -> ByteString
B.drop Int
reloff ByteString
obj)
  --
  LoadSection -> Get LoadSection
forall (m :: * -> *) a. Monad m => a -> m a
return LoadSection :: ByteString
-> ByteString
-> Int
-> Int
-> Int
-> Int
-> Vector RelocationInfo
-> LoadSection
LoadSection
          { sec_secname :: ByteString
sec_secname = ByteString
secname
          , sec_segname :: ByteString
sec_segname = ByteString
segname
          , sec_addr :: Int
sec_addr    = Int
addr
          , sec_size :: Int
sec_size    = Int
size
          , sec_offset :: Int
sec_offset  = Int
offset
          , sec_align :: Int
sec_align   = Int
align
          , sec_relocs :: Vector RelocationInfo
sec_relocs  = Vector RelocationInfo
relocs
          }

readLoadSection64 :: Peek -> ByteString -> Get LoadSection
readLoadSection64 :: Peek -> ByteString -> Get LoadSection
readLoadSection64 p :: Peek
p@Peek{Bool
Get Word16
Get Word32
Get Word64
getWord64 :: Get Word64
getWord32 :: Get Word32
getWord16 :: Get Word16
is64Bit :: Bool
getWord64 :: Peek -> Get Word64
getWord32 :: Peek -> Get Word32
getWord16 :: Peek -> Get Word16
is64Bit :: Peek -> Bool
..} ByteString
obj = do
  ByteString
secname   <- (Word8 -> Bool) -> ByteString -> ByteString
B.takeWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0) (ByteString -> ByteString) -> Get ByteString -> Get ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getBytes Int
16
  ByteString
segname   <- (Word8 -> Bool) -> ByteString -> ByteString
B.takeWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0) (ByteString -> ByteString) -> Get ByteString -> Get ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getBytes Int
16
  Int
addr      <- Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Get Word64 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
getWord64
  Int
size      <- Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Get Word64 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
getWord64
  Int
offset    <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32
  Int
align     <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32
  Int
reloff    <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32
  Int
nreloc    <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32
  Int -> Get ()
skip Int
16   -- flags, reserved1, reserved2, reserved3
  String -> Get ()
forall (m :: * -> *). Monad m => String -> m ()
message (String -> Int -> Int -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"  Mem: 0x%09x-0x%09x         %s.%s" Int
addr (Int
addrInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
size) (ByteString -> String
B8.unpack ByteString
segname) (ByteString -> String
B8.unpack ByteString
secname))
  Vector RelocationInfo
relocs    <- (String -> Get (Vector RelocationInfo))
-> (Vector RelocationInfo -> Get (Vector RelocationInfo))
-> Either String (Vector RelocationInfo)
-> Get (Vector RelocationInfo)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Get (Vector RelocationInfo)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail Vector RelocationInfo -> Get (Vector RelocationInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (Vector RelocationInfo)
 -> Get (Vector RelocationInfo))
-> Either String (Vector RelocationInfo)
-> Get (Vector RelocationInfo)
forall a b. (a -> b) -> a -> b
$ Get (Vector RelocationInfo)
-> ByteString -> Either String (Vector RelocationInfo)
forall a. Get a -> ByteString -> Either String a
runGet (Int -> Get RelocationInfo -> Get (Vector RelocationInfo)
forall (m :: * -> *) a. Monad m => Int -> m a -> m (Vector a)
V.replicateM Int
nreloc (Peek -> Get RelocationInfo
loadRelocation Peek
p)) (Int -> ByteString -> ByteString
B.drop Int
reloff ByteString
obj)
  --
  LoadSection -> Get LoadSection
forall (m :: * -> *) a. Monad m => a -> m a
return LoadSection :: ByteString
-> ByteString
-> Int
-> Int
-> Int
-> Int
-> Vector RelocationInfo
-> LoadSection
LoadSection
          { sec_secname :: ByteString
sec_secname = ByteString
secname
          , sec_segname :: ByteString
sec_segname = ByteString
segname
          , sec_addr :: Int
sec_addr    = Int
addr
          , sec_size :: Int
sec_size    = Int
size
          , sec_offset :: Int
sec_offset  = Int
offset
          , sec_align :: Int
sec_align   = Int
align
          , sec_relocs :: Vector RelocationInfo
sec_relocs  = Vector RelocationInfo
relocs
          }

loadRelocation :: Peek -> Get RelocationInfo
loadRelocation :: Peek -> Get RelocationInfo
loadRelocation Peek{Bool
Get Word16
Get Word32
Get Word64
getWord64 :: Get Word64
getWord32 :: Get Word32
getWord16 :: Get Word16
is64Bit :: Bool
getWord64 :: Peek -> Get Word64
getWord32 :: Peek -> Get Word32
getWord16 :: Peek -> Get Word16
is64Bit :: Peek -> Bool
..} = do
  Int
addr    <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32
  Word32
val     <- Get Word32
getWord32
  let symbol :: Word32
symbol  = Word32
val Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFFFFFF
      pcrel :: Bool
pcrel   = Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word32
val Int
24
      extern :: Bool
extern  = Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word32
val Int
27
      len :: Word32
len     = (Word32
val Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
25) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x3
      rtype :: Word32
rtype   = (Word32
val Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
28) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xF
      rtype' :: RelocationType
rtype'  = Int -> RelocationType
forall a. Enum a => Int -> a
toEnum (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
rtype)
  --
  Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> Bool
forall a. (Eq a, Num a) => a -> Bool
toBool (Int -> Bool) -> Int -> Bool
forall a b. (a -> b) -> a -> b
$ Int
addr Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x80000000) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$ String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unhandled scatted relocation info"
  String -> Get ()
forall (m :: * -> *). Monad m => String -> m ()
message (String
-> Int -> String -> Word32 -> Word32 -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"    Reloc: 0x%04x to %s %d: length=%d, pcrel=%s, type=%s" Int
addr (if Bool
extern then String
"symbol" else String
"section") Word32
symbol Word32
len (Bool -> String
forall a. Show a => a -> String
show Bool
pcrel) (RelocationType -> String
forall a. Show a => a -> String
show RelocationType
rtype'))
  --
  RelocationInfo -> Get RelocationInfo
forall (m :: * -> *) a. Monad m => a -> m a
return RelocationInfo :: Int
-> Int -> Int -> Bool -> Bool -> RelocationType -> RelocationInfo
RelocationInfo
          { ri_address :: Int
ri_address   = Int
addr
          , ri_symbolnum :: Int
ri_symbolnum = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
symbol
          , ri_pcrel :: Bool
ri_pcrel     = Bool
pcrel
          , ri_extern :: Bool
ri_extern    = Bool
extern
          , ri_length :: Int
ri_length    = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
len
          , ri_type :: RelocationType
ri_type      = RelocationType
rtype'
          }


readLoadSymbolTable :: Peek -> ByteString -> Get (Vector Symbol)
readLoadSymbolTable :: Peek -> ByteString -> Get (Vector Symbol)
readLoadSymbolTable p :: Peek
p@Peek{Bool
Get Word16
Get Word32
Get Word64
getWord64 :: Get Word64
getWord32 :: Get Word32
getWord16 :: Get Word16
is64Bit :: Bool
getWord64 :: Peek -> Get Word64
getWord32 :: Peek -> Get Word32
getWord16 :: Peek -> Get Word16
is64Bit :: Peek -> Bool
..} ByteString
obj = do
  Int
symoff  <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32
  Int
nsyms   <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32
  Int
stroff  <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32
  Word32
strsize <- Get Word32
getWord32
  String -> Get ()
forall (m :: * -> *). Monad m => String -> m ()
message String
"LC_SYMTAB"
  String -> Get ()
forall (m :: * -> *). Monad m => String -> m ()
message (String -> Int -> Int -> Int -> String
forall r. PrintfType r => String -> r
printf String
"  symbol table is at offset 0x%x (%d), %d entries" Int
symoff Int
symoff Int
nsyms)
  String -> Get ()
forall (m :: * -> *). Monad m => String -> m ()
message (String -> Int -> Int -> Word32 -> String
forall r. PrintfType r => String -> r
printf String
"  string table is at offset 0x%x (%d), %d bytes" Int
stroff Int
stroff Word32
strsize)
  --
  let symbols :: ByteString
symbols = Int -> ByteString -> ByteString
B.drop Int
symoff ByteString
obj
      strtab :: ByteString
strtab  = Int -> ByteString -> ByteString
B.drop Int
stroff ByteString
obj
  --
  (String -> Get (Vector Symbol))
-> (Vector Symbol -> Get (Vector Symbol))
-> Either String (Vector Symbol)
-> Get (Vector Symbol)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Get (Vector Symbol)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail Vector Symbol -> Get (Vector Symbol)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (Vector Symbol) -> Get (Vector Symbol))
-> Either String (Vector Symbol) -> Get (Vector Symbol)
forall a b. (a -> b) -> a -> b
$ Get (Vector Symbol) -> ByteString -> Either String (Vector Symbol)
forall a. Get a -> ByteString -> Either String a
runGet (Int -> Get Symbol -> Get (Vector Symbol)
forall (m :: * -> *) a. Monad m => Int -> m a -> m (Vector a)
V.replicateM Int
nsyms (Peek -> ByteString -> Get Symbol
loadSymbol Peek
p ByteString
strtab)) ByteString
symbols


readDynamicSymbolTable :: Peek -> ByteString -> Get ()
readDynamicSymbolTable :: Peek -> ByteString -> Get ()
readDynamicSymbolTable Peek{Bool
Get Word16
Get Word32
Get Word64
getWord64 :: Get Word64
getWord32 :: Get Word32
getWord16 :: Get Word16
is64Bit :: Bool
getWord64 :: Peek -> Get Word64
getWord32 :: Peek -> Get Word32
getWord16 :: Peek -> Get Word16
is64Bit :: Peek -> Bool
..} ByteString
_obj = do
  if Bool -> Bool
not Bool
Debug.debuggingIsEnabled
    then Int -> Get ()
skip (Int
80 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
8)
    else do
      Word32
ilocalsym     <- Get Word32
getWord32
      Word32
nlocalsym     <- Get Word32
getWord32
      Word32
iextdefsym    <- Get Word32
getWord32
      Word32
nextdefsym    <- Get Word32
getWord32
      Word32
iundefsym     <- Get Word32
getWord32
      Word32
nundefsym     <- Get Word32
getWord32
      Int -> Get ()
skip Int
4        -- tocoff
      Word32
ntoc          <- Get Word32
getWord32
      Int -> Get ()
skip Int
4        -- modtaboff
      Word32
nmodtab       <- Get Word32
getWord32
      Int -> Get ()
skip Int
12       -- extrefsymoff, nextrefsyms, indirectsymoff,
      Word32
nindirectsyms <- Get Word32
getWord32
      Int -> Get ()
skip Int
16       -- extreloff, nextrel, locreloff, nlocrel,
      String -> Get ()
forall (m :: * -> *). Monad m => String -> m ()
message String
"LC_DYSYMTAB:"
      --
      if Word32
nlocalsym Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
0
        then String -> Get ()
forall (m :: * -> *). Monad m => String -> m ()
message (String -> Word32 -> Word32 -> String
forall r. PrintfType r => String -> r
printf String
"  %d local symbols at index %d" Word32
nlocalsym Word32
ilocalsym)
        else String -> Get ()
forall (m :: * -> *). Monad m => String -> m ()
message (String -> String
forall r. PrintfType r => String -> r
printf String
"  No local symbols")
      if Word32
nextdefsym Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
0
        then String -> Get ()
forall (m :: * -> *). Monad m => String -> m ()
message (String -> Word32 -> Word32 -> String
forall r. PrintfType r => String -> r
printf String
"  %d external symbols at index %d" Word32
nextdefsym Word32
iextdefsym)
        else String -> Get ()
forall (m :: * -> *). Monad m => String -> m ()
message (String -> String
forall r. PrintfType r => String -> r
printf String
"  No external symbols")
      if Word32
nundefsym Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
0
        then String -> Get ()
forall (m :: * -> *). Monad m => String -> m ()
message (String -> Word32 -> Word32 -> String
forall r. PrintfType r => String -> r
printf String
"  %d undefined symbols at index %d" Word32
nundefsym Word32
iundefsym)
        else String -> Get ()
forall (m :: * -> *). Monad m => String -> m ()
message (String -> String
forall r. PrintfType r => String -> r
printf String
"  No undefined symbols")
      if Word32
ntoc Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
0
        then String -> Get ()
forall (m :: * -> *). Monad m => String -> m ()
message (String -> Word32 -> String
forall r. PrintfType r => String -> r
printf String
"  %d table of contents entries" Word32
ntoc)
        else String -> Get ()
forall (m :: * -> *). Monad m => String -> m ()
message (String -> String
forall r. PrintfType r => String -> r
printf String
"  No table of contents")
      if Word32
nmodtab Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
0
        then String -> Get ()
forall (m :: * -> *). Monad m => String -> m ()
message (String -> Word32 -> String
forall r. PrintfType r => String -> r
printf String
"  %d module table entries" Word32
nmodtab)
        else String -> Get ()
forall (m :: * -> *). Monad m => String -> m ()
message (String -> String
forall r. PrintfType r => String -> r
printf String
"  No module table")
      if Word32
nindirectsyms Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
0
        then String -> Get ()
forall (m :: * -> *). Monad m => String -> m ()
message (String -> Word32 -> String
forall r. PrintfType r => String -> r
printf String
"  %d indirect symbols" Word32
nindirectsyms)
        else String -> Get ()
forall (m :: * -> *). Monad m => String -> m ()
message (String -> String
forall r. PrintfType r => String -> r
printf String
"  No indirect symbols")

loadSymbol :: Peek -> ByteString -> Get Symbol
loadSymbol :: Peek -> ByteString -> Get Symbol
loadSymbol Peek{Bool
Get Word16
Get Word32
Get Word64
getWord64 :: Get Word64
getWord32 :: Get Word32
getWord16 :: Get Word16
is64Bit :: Bool
getWord64 :: Peek -> Get Word64
getWord32 :: Peek -> Get Word32
getWord16 :: Peek -> Get Word16
is64Bit :: Peek -> Bool
..} ByteString
strtab = do
  Int
n_strx  <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32
  Word8
n_flag  <- Get Word8
getWord8
  Word8
n_sect  <- Get Word8
getWord8
  Int -> Get ()
skip Int
2  -- n_desc
  Word64
n_value <- case Bool
is64Bit of
               Bool
True  -> Word64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word64) -> Get Word64 -> Get Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
getWord64
               Bool
False -> Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word64) -> Get Word32 -> Get Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32

  let -- Symbols with string table index zero are defined to have a null
      -- name (""). Otherwise, drop the leading underscore.
      str :: ByteString
str | Int
n_strx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = ByteString
B.empty
          | Bool
otherwise   = (Word8 -> Bool) -> ByteString -> ByteString
B.takeWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0) (Int -> ByteString -> ByteString
B.drop Int
n_strx ByteString
strtab)
      name :: ByteString
name
          | ByteString -> Int
B.length ByteString
str Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& ByteString -> Char
B8.head ByteString
str Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'  = ByteString -> ByteString
B.tail ByteString
str
          | Bool
otherwise                               = ByteString
str

      -- Extract the four bit fields of the type flag
      -- n_pext  = n_flag .&. {#const N_PEXT#}  -- private external symbol bit
      n_stab :: Word8
n_stab  = Word8
n_flag Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xe0  -- if any bits set, a symbolic debugging entry
      n_type :: Word8
n_type  = Word8
n_flag Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xe  -- mask for type bits
      n_ext :: Word8
n_ext   = Word8
n_flag Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x1   -- external symbol bit

  Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word8
n_stab Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$ String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unhandled symbolic debugging entry (stab)"

  case Word8
n_type of
    Word8
0x0 -> do
        FunPtr ()
funptr <- ByteString -> Get (FunPtr ())
resolveSymbol ByteString
name
        String -> Get ()
forall (m :: * -> *). Monad m => String -> m ()
message (String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"    %s: external symbol found at %s" (ByteString -> String
B8.unpack ByteString
name) (FunPtr () -> String
forall a. Show a => a -> String
show FunPtr ()
funptr))
        Symbol -> Get Symbol
forall (m :: * -> *) a. Monad m => a -> m a
return Symbol :: ByteString -> Word64 -> Word8 -> Bool -> Symbol
Symbol
                { sym_name :: ByteString
sym_name    = ByteString
name
                , sym_extern :: Bool
sym_extern  = Word8 -> Bool
forall a. (Eq a, Num a) => a -> Bool
toBool Word8
n_ext
                , sym_segment :: Word8
sym_segment = Word8
n_sect
                , sym_value :: Word64
sym_value   = Ptr Any -> Word64
forall a. Ptr a -> Word64
castPtrToWord64 (FunPtr () -> Ptr Any
forall a b. FunPtr a -> Ptr b
castFunPtrToPtr FunPtr ()
funptr)
                }

    Word8
0xe -> do
        String -> Get ()
forall (m :: * -> *). Monad m => String -> m ()
message (String -> String -> Word8 -> Word64 -> String
forall r. PrintfType r => String -> r
printf String
"    %s: local symbol in section %d at 0x%02x" (ByteString -> String
B8.unpack ByteString
name) Word8
n_sect Word64
n_value)
        Symbol -> Get Symbol
forall (m :: * -> *) a. Monad m => a -> m a
return Symbol :: ByteString -> Word64 -> Word8 -> Bool -> Symbol
Symbol
                { sym_name :: ByteString
sym_name    = ByteString
name
                , sym_extern :: Bool
sym_extern  = Word8 -> Bool
forall a. (Eq a, Num a) => a -> Bool
toBool Word8
n_ext
                , sym_segment :: Word8
sym_segment = Word8
n_sect
                , sym_value :: Word64
sym_value   = Word64
n_value
                }

    Word8
0x2  -> String -> Get Symbol
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unhandled absolute symbol"
    Word8
0xc -> String -> Get Symbol
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unhandled prebound (dylib) symbol"
    Word8
0xa -> String -> Get Symbol
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unhandled indirect symbol"
    Word8
_                -> String -> Get Symbol
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unknown symbol type"


-- Return the address binding the named symbol
--
resolveSymbol :: ByteString -> Get (FunPtr ())
resolveSymbol :: ByteString -> Get (FunPtr ())
resolveSymbol ByteString
name
  = IO (Get (FunPtr ())) -> Get (FunPtr ())
forall a. IO a -> a
unsafePerformIO
  (IO (Get (FunPtr ())) -> Get (FunPtr ()))
-> IO (Get (FunPtr ())) -> Get (FunPtr ())
forall a b. (a -> b) -> a -> b
$ ByteString
-> (CString -> IO (Get (FunPtr ()))) -> IO (Get (FunPtr ()))
forall a. ByteString -> (CString -> IO a) -> IO a
B.unsafeUseAsCString ByteString
name ((CString -> IO (Get (FunPtr ()))) -> IO (Get (FunPtr ())))
-> (CString -> IO (Get (FunPtr ()))) -> IO (Get (FunPtr ()))
forall a b. (a -> b) -> a -> b
$ \CString
c_name -> do
      FunPtr ()
addr <- Ptr () -> CString -> IO (FunPtr ())
forall a. Ptr () -> CString -> IO (FunPtr a)
c_dlsym (DL -> Ptr ()
packDL DL
Default) CString
c_name
      if FunPtr ()
addr FunPtr () -> FunPtr () -> Bool
forall a. Eq a => a -> a -> Bool
== FunPtr ()
forall b. FunPtr b
nullFunPtr
        then do
          String
err <- IO String
dlerror
          Get (FunPtr ()) -> IO (Get (FunPtr ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Get (FunPtr ())
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get (FunPtr ())) -> String -> Get (FunPtr ())
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"failed to resolve symbol %s: %s" (ByteString -> String
B8.unpack ByteString
name) String
err)
        else do
          Get (FunPtr ()) -> IO (Get (FunPtr ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (FunPtr () -> Get (FunPtr ())
forall (m :: * -> *) a. Monad m => a -> m a
return FunPtr ()
addr)


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

-- Get the address of a pointer as a Word64
--
castPtrToWord64 :: Ptr a -> Word64
castPtrToWord64 :: Ptr a -> Word64
castPtrToWord64 (Ptr Addr#
addr#) = Word# -> Word64
W64# (Int# -> Word#
int2Word# (Addr# -> Int#
addr2Int# Addr#
addr#))


-- C-bits
-- ------

-- Control the protection of pages
--
mprotect :: Ptr Word8 -> Int -> Int -> IO ()
mprotect :: Ptr Word8 -> Int -> Int -> IO ()
mprotect Ptr Word8
addr Int
len Int
prot
  = String -> IO CInt -> IO ()
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1_ String
"mprotect"
  (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr () -> CSize -> CInt -> IO CInt
c_mprotect (Ptr Word8 -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
addr) (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
prot)

foreign import ccall unsafe "mprotect"
  c_mprotect :: Ptr () -> CSize -> CInt -> IO CInt

foreign import ccall unsafe "getpagesize"
  c_getpagesize :: CInt


-- Debug
-- -----

{-# INLINE trace #-}
trace :: String -> a -> a
trace :: String -> a -> a
trace String
msg = Flag -> String -> a -> a
forall a. Flag -> String -> a -> a
Debug.trace Flag
Debug.dump_ld (String
"ld: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg)

{-# INLINE message #-}
message :: Monad m => String -> m ()
message :: String -> m ()
message String
msg = String -> m () -> m ()
forall a. String -> a -> a
trace String
msg (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())