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


{-# LINE 1 "src/Data/Array/Accelerate/LLVM/Native/Link/ELF.chs" #-}
{-# LANGUAGE CPP                      #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE MagicHash                #-}
{-# LANGUAGE RecordWildCards          #-}
{-# LANGUAGE TemplateHaskell          #-}
-- |
-- Module      : Data.Array.Accelerate.LLVM.Native.Link.ELF
-- Copyright   : [2017] Trevor L. McDonell
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--

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

  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.Char
import Data.Int
import Data.List
import Data.Serialize.Get
import Data.Vector                                        ( Vector )
import Data.Word
import Foreign.C
import Foreign.ForeignPtr
import Foreign.Marshal
import Foreign.Ptr
import Foreign.Storable
import GHC.Prim                                           ( addr2Int#, int2Word#, int2Addr# )
import GHC.Ptr                                            ( Ptr(..) )
import GHC.Word                                           ( Word64(..) )
import System.IO.Unsafe
import System.Posix.DynamicLinker
import System.Posix.Types                                 ( COff(..) )
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 an ELF 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 :: ByteString -> IO (FunctionTable, ObjectCode)
loadObject obj =
  case parseObject obj of
    Left err                              -> $internalError "loadObject" err
    Right (secs, symbols, relocs, strtab) -> do
      -- Load the sections into executable memory
      --
      (funtab, oc) <- loadSegment obj strtab secs symbols relocs

      -- Unmap the executable pages when they are no longer required
      --
      objectcode <- newLifetime [oc]
      addFinalizer objectcode $ do
        Debug.traceIO Debug.dump_gc ("gc: unload module: " ++ show funtab)
        case oc of
          Segment vmsize oc_fp ->
            withForeignPtr oc_fp $ \oc_p ->
              munmap oc_p vmsize

      return (funtab, objectcode)


-- Load the sections into memory.
--
-- Extra jump islands are added directly after the section data. On x86_64
-- PC-relative jumps and accesses to the global offset table are limited to
-- 32-bits (+-2GB). If we need to go outside of this range than 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
    :: ByteString
    -> ByteString
    -> Vector SectionHeader
    -> Vector Symbol
    -> Vector Relocation
    -> IO (FunctionTable, Segment)
loadSegment obj strtab secs symtab relocs = do
  let
      pagesize    = fromIntegral c_getpagesize

      -- round up to next multiple of given alignment
      pad align n = (n + align - 1) .&. (complement (align - 1))

      -- determine where each section should be placed in memory, respecting
      -- alignment requirements. SectionHeaders which do not correspond to
      -- program data (e.g. systab) just carry along the previous offset value.
      -- This is to avoid filtering the list of sections, so that section
      -- indices (e.g. in relocations) remain valid.
      --
      nsecs       = V.length secs
      offsets     = V.constructN (nsecs + 1) $ \v ->
                      case V.length v of
                        0 -> 0
                        n -> let this     = secs V.! n
                                 prev     = secs V.! (n-1)
                                 alloc s  = testBit (sh_flags s) 1  -- SHF_ALLOC: section occupies memory at execution?
                                 --
                                 align | n >= nsecs       = 16
                                       | not (alloc this) = 1
                                       | otherwise        = sh_align this
                                 --
                                 size  | alloc prev       = sh_size prev
                                       | otherwise        = 0
                             in
                             pad align (size + v V.! (n-1))

      -- The section at index `i` should place its data beginning at page boundary
      -- offset given by offsets!i.
      --
      vmsize'     = V.last offsets                                  -- bytes required to store all sections
      vmsize      = pad pagesize (vmsize' + (V.length symtab * 16)) -- sections + jump tables

  -- Allocate new pages to store the executable code. This is allocated in
  -- the lower 2GB so that 32-bit relocations should work without needing
  -- to go via the jump tables.
  --
  -- The memory is implicitly initialised to zero (corresponding to NOP).
  -- This also takes care of .bss sections.
  --
  seg_p   <- mmap vmsize
  seg_fp  <- newForeignPtr_ seg_p

  -- Jump tables are placed directly after the segment data
  let jump_p = seg_p `plusPtr` vmsize'
  V.imapM_ (makeJumpIsland jump_p) symtab

  -- Copy over section data
  V.izipWithM_ (loadSection obj strtab seg_p) offsets secs

  -- Process relocations
  V.mapM_ (processRelocation symtab offsets seg_p jump_p) relocs

  -- Mark the page as executable and read-only
  mprotect seg_p vmsize (0x1 .|. 0x4)

  -- Resolve external symbols defined in the sections 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 funtab              = FunctionTable $ V.toList (V.map resolve (V.filter extern symtab))
      extern Symbol{..}   = sym_binding == Global && sym_type == Func
      resolve Symbol{..}  =
        let name  = BS.toShort (B8.take (B8.length sym_name - 65) sym_name)
            addr  = castPtrToFunPtr (seg_p `plusPtr` (fromIntegral sym_value + offsets V.! sym_section))
        in
        (name, addr)
  --
  return (funtab, Segment vmsize seg_fp)


-- Add the jump-table entries directly to each external undefined symbol.
--
makeJumpIsland :: Ptr Word8 -> Int -> Symbol -> IO ()
makeJumpIsland jump_p symbolnum Symbol{..} = do
  when (sym_binding == Global && sym_section == 0) $ do
    let
        target  = jump_p `plusPtr` (symbolnum * 16) :: Ptr Word64   -- addr
        instr   = target `plusPtr` 8                :: Ptr Word8    -- jumpIsland
    --
    poke target sym_value
    pokeArray instr [ 0xFF, 0x25, 0xF2, 0xFF, 0xFF, 0xFF ]  -- jmp *-14(%rip)
  return ()


-- Load the section at the correct offset into the given segment
--
loadSection :: ByteString -> ByteString -> Ptr Word8 -> Int -> Int -> SectionHeader -> IO ()
loadSection obj strtab seg_p sec_num sec_addr SectionHeader{..} =
  when (sh_type == ProgBits && sh_size > 0) $ do
    message (printf "section %d: Mem: 0x%09x-0x%09x         %s" sec_num sec_addr (sec_addr+sh_size) (B8.unpack (indexStringTable strtab sh_name)))
    let (obj_fp, obj_offset, _) = B.toForeignPtr obj
    --
    withForeignPtr obj_fp $ \obj_p -> do
      -- Copy this section's data to the appropriate place in the segment
      let src = obj_p `plusPtr` (obj_offset + sh_offset)
          dst = seg_p `plusPtr` sec_addr
      --
      copyBytes dst src sh_size


-- Process local and external relocations.
--
processRelocation :: Vector Symbol -> Vector Int -> Ptr Word8 -> Ptr Word8 -> Relocation -> IO ()
processRelocation symtab sec_offset seg_p jump_p Relocation{..} = do
  message (printf "relocation: 0x%04x to symbol %d in section %d, type=%-14s value=%s%+d" r_offset r_symbol r_section (show r_type) (B8.unpack sym_name) r_addend)
  case r_type of
    R_X86_64_None -> return ()
    R_X86_64_64   -> relocate value

    R_X86_64_PC32 ->
      let offset :: Int64
          offset = fromIntegral (value - pc')
      in
      if offset >= 0x7fffffff || offset < -0x80000000
        then
          let jump'   = castPtrToWord64 (jump_p `plusPtr` (r_symbol * 16 + 8))
              offset' = fromIntegral jump' + r_addend - fromIntegral pc'
          in
          relocate (fromIntegral offset' :: Word32)
        else
          relocate (fromIntegral offset  :: Word32)

    R_X86_64_PC64 ->
      let offset :: Int64
          offset = fromIntegral (value - pc')
      in
      relocate (fromIntegral offset :: Word32)

    R_X86_64_32 ->
      if value >= 0x7fffffff
        then
          let jump'   = castPtrToWord64 (jump_p `plusPtr` (r_symbol * 16 + 8))
              value'  = fromIntegral jump' + r_addend
          in
          relocate (fromIntegral value' :: Word32)
        else
          relocate (fromIntegral value  :: Word32)

    R_X86_64_32S ->
      let values :: Int64
          values = fromIntegral value
      in
      if values > 0x7fffffff || values < -0x80000000
        then
          let jump'   = castPtrToWord64 (jump_p `plusPtr` (r_symbol * 16 + 8))
              value'  = fromIntegral jump' + r_addend
          in
          relocate (fromIntegral value' :: Int32)
        else
          relocate (fromIntegral value  :: Int32)

    R_X86_64_PLT32 ->
      let offset :: Int64
          offset  = fromIntegral (value - pc')
      in
      if offset >= 0x7fffffff || offset < -0x80000000
        then
          let jump'   = castPtrToWord64 (jump_p `plusPtr` (r_symbol * 16 + 8))
              offset' = fromIntegral jump' + r_addend - fromIntegral pc'
          in
          relocate (fromIntegral offset' :: Word32)
        else
          relocate (fromIntegral offset  :: Word32)

  where
    pc :: Ptr Word8
    pc  = seg_p `plusPtr` (fromIntegral r_offset + sec_offset V.! r_section)
    pc' = castPtrToWord64 pc

    value :: Word64
    value = symval + fromIntegral r_addend

    symval :: Word64
    symval =
      case sym_binding of
        Local   -> castPtrToWord64 (seg_p `plusPtr` (sec_offset V.! sym_section + fromIntegral sym_value))
        Global  -> sym_value
        Weak    -> $internalError "processRelocation" "unhandled weak symbol"

    Symbol{..} = symtab V.! r_symbol

    relocate :: Storable a => a -> IO ()
    relocate x = poke (castPtr pc) x



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

-- Parse an ELF object file and return the set of section load commands, as well
-- as the symbols defined within the sections of the object.
--
-- Actually loading the sections into executable memory happens separately.
--
parseObject :: ByteString -> Either String (Vector SectionHeader, Vector Symbol, Vector Relocation, ByteString)
parseObject obj = do
  (p, tph, tsec, strix) <- runGet readHeader obj

  -- As this is an object file, we do not expect any program headers
  unless (tb_entries tph == 0) $ fail "unhandled program header(s)"

  -- Read the object file headers
  secs    <- runGet (V.replicateM (tb_entries tsec) (readSectionHeader p)) (B.drop (tb_fileoff tsec) obj)
  strtab  <- readStringTable obj (secs V.! strix)

  let symtab  = V.toList . V.filter (\s -> sh_type s == SymTab)
      reloc   = V.toList . V.filter (\s -> sh_type s == Rel || sh_type s == RelA)

  symbols <- V.concat <$> sequence [ readSymbolTable p secs obj sh | sh <- symtab secs ]
  relocs  <- V.concat <$> sequence [ readRelocations p      obj sh | sh <- reloc secs ]

  return (secs, symbols, relocs, strtab)


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

data Table = Table
    { tb_fileoff    :: {-# UNPACK #-} !Int    -- byte offset to start of table (array)
    , tb_entries    :: {-# UNPACK #-} !Int    -- number of entries in the table (array)
    , tb_entrysize  :: {-# UNPACK #-} !Int    -- size in bytes per entry
    }

{--
data ProgramHeader = ProgramHeader
    { prog_vmaddr   :: {-# UNPACK #-} !Int    -- virtual address
    , prog_vmsize   :: {-# UNPACK #-} !Int    -- size in memory
    , prog_fileoff  :: {-# UNPACK #-} !Int    -- file offset
    , prog_filesize :: {-# UNPACK #-} !Int    -- size in file
    , prog_align    :: {-# UNPACK #-} !Int    -- alignment
    , prog_paddr    :: {-# UNPACK #-} !Int    -- physical address
    }
--}

data SectionHeader = SectionHeader
    { sh_name       :: {-# UNPACK #-} !Int    -- string table index
    , sh_addr       :: {-# UNPACK #-} !Word64 -- virtual memory address
    , sh_size       :: {-# UNPACK #-} !Int    -- section size in bytes
    , sh_offset     :: {-# UNPACK #-} !Int    -- file offset in bytes
    , sh_align      :: {-# UNPACK #-} !Int
    , sh_link       :: {-# UNPACK #-} !Int
    , sh_info       :: {-# UNPACK #-} !Int    -- additional section info
    , sh_entsize    :: {-# UNPACK #-} !Int    -- entry size, if section holds table
    , sh_flags      :: {-# UNPACK #-} !Word64
    , sh_type       :: !SectionType
    }
    deriving Show

data SectionType = NullSection
                 | ProgBits
                 | SymTab
                 | StrTab
                 | RelA
                 | Hash
                 | Dynamic
                 | Note
                 | NoBits
                 | Rel
                 | DynSym
  deriving (Eq,Show)
instance Enum SectionType where
  succ NullSection = ProgBits
  succ ProgBits = SymTab
  succ SymTab = StrTab
  succ StrTab = RelA
  succ RelA = Hash
  succ Hash = Dynamic
  succ Dynamic = Note
  succ Note = NoBits
  succ NoBits = Rel
  succ Rel = DynSym
  succ DynSym = error "SectionType.succ: DynSym has no successor"

  pred ProgBits = NullSection
  pred SymTab = ProgBits
  pred StrTab = SymTab
  pred RelA = StrTab
  pred Hash = RelA
  pred Dynamic = Hash
  pred Note = Dynamic
  pred NoBits = Note
  pred Rel = NoBits
  pred DynSym = Rel
  pred NullSection = error "SectionType.pred: NullSection has no predecessor"

  enumFromTo from to = go from
    where
      end = fromEnum to
      go v = case compare (fromEnum v) end of
                 LT -> v : go (succ v)
                 EQ -> [v]
                 GT -> []

  enumFrom from = enumFromTo from DynSym

  fromEnum NullSection = 0
  fromEnum ProgBits = 1
  fromEnum SymTab = 2
  fromEnum StrTab = 3
  fromEnum RelA = 4
  fromEnum Hash = 5
  fromEnum Dynamic = 6
  fromEnum Note = 7
  fromEnum NoBits = 8
  fromEnum Rel = 9
  fromEnum DynSym = 11

  toEnum 0 = NullSection
  toEnum 1 = ProgBits
  toEnum 2 = SymTab
  toEnum 3 = StrTab
  toEnum 4 = RelA
  toEnum 5 = Hash
  toEnum 6 = Dynamic
  toEnum 7 = Note
  toEnum 8 = NoBits
  toEnum 9 = Rel
  toEnum 11 = DynSym
  toEnum unmatched = error ("SectionType.toEnum: Cannot match " ++ show unmatched)

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


data Symbol = Symbol
    { sym_name      :: {-# UNPACK #-} !ByteString
    , sym_value     :: {-# UNPACK #-} !Word64
    , sym_section   :: {-# UNPACK #-} !Int
    , sym_binding   :: !SymbolBinding
    , sym_type      :: !SymbolType
    }
    deriving Show

data SymbolBinding = Local
                   | Global
                   | Weak
  deriving (Eq,Show)
instance Enum SymbolBinding where
  succ Local = Global
  succ Global = Weak
  succ Weak = error "SymbolBinding.succ: Weak has no successor"

  pred Global = Local
  pred Weak = Global
  pred Local = error "SymbolBinding.pred: Local has no predecessor"

  enumFromTo from to = go from
    where
      end = fromEnum to
      go v = case compare (fromEnum v) end of
                 LT -> v : go (succ v)
                 EQ -> [v]
                 GT -> []

  enumFrom from = enumFromTo from Weak

  fromEnum Local = 0
  fromEnum Global = 1
  fromEnum Weak = 2

  toEnum 0 = Local
  toEnum 1 = Global
  toEnum 2 = Weak
  toEnum unmatched = error ("SymbolBinding.toEnum: Cannot match " ++ show unmatched)

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


data SymbolType = NoType
                | Object
                | Func
                | Section
                | File
                | Common
                | TLS
  deriving (Eq,Show)
instance Enum SymbolType where
  succ NoType = Object
  succ Object = Func
  succ Func = Section
  succ Section = File
  succ File = Common
  succ Common = TLS
  succ TLS = error "SymbolType.succ: TLS has no successor"

  pred Object = NoType
  pred Func = Object
  pred Section = Func
  pred File = Section
  pred Common = File
  pred TLS = Common
  pred NoType = error "SymbolType.pred: NoType has no predecessor"

  enumFromTo from to = go from
    where
      end = fromEnum to
      go v = case compare (fromEnum v) end of
                 LT -> v : go (succ v)
                 EQ -> [v]
                 GT -> []

  enumFrom from = enumFromTo from TLS

  fromEnum NoType = 0
  fromEnum Object = 1
  fromEnum Func = 2
  fromEnum Section = 3
  fromEnum File = 4
  fromEnum Common = 5
  fromEnum TLS = 6

  toEnum 0 = NoType
  toEnum 1 = Object
  toEnum 2 = Func
  toEnum 3 = Section
  toEnum 4 = File
  toEnum 5 = Common
  toEnum 6 = TLS
  toEnum unmatched = error ("SymbolType.toEnum: Cannot match " ++ show unmatched)

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


data Relocation = Relocation
    { r_offset      :: {-# UNPACK #-} !Word64
    , r_symbol      :: {-# UNPACK #-} !Int
    , r_section     :: {-# UNPACK #-} !Int
    , r_addend      :: {-# UNPACK #-} !Int64
    , r_type        :: !RelocationType
    }
    deriving Show

data RelocationType = R_X86_64_None
                    | R_X86_64_64
                    | R_X86_64_PC32
                    | R_X86_64_PLT32
                    | R_X86_64_32
                    | R_X86_64_32S
                    | R_X86_64_PC64
  deriving (Eq,Show)
instance Enum RelocationType where
  succ R_X86_64_None = R_X86_64_64
  succ R_X86_64_64 = R_X86_64_PC32
  succ R_X86_64_PC32 = R_X86_64_PLT32
  succ R_X86_64_PLT32 = R_X86_64_32
  succ R_X86_64_32 = R_X86_64_32S
  succ R_X86_64_32S = R_X86_64_PC64
  succ R_X86_64_PC64 = error "RelocationType.succ: R_X86_64_PC64 has no successor"

  pred R_X86_64_64 = R_X86_64_None
  pred R_X86_64_PC32 = R_X86_64_64
  pred R_X86_64_PLT32 = R_X86_64_PC32
  pred R_X86_64_32 = R_X86_64_PLT32
  pred R_X86_64_32S = R_X86_64_32
  pred R_X86_64_PC64 = R_X86_64_32S
  pred R_X86_64_None = error "RelocationType.pred: R_X86_64_None has no predecessor"

  enumFromTo from to = go from
    where
      end = fromEnum to
      go v = case compare (fromEnum v) end of
                 LT -> v : go (succ v)
                 EQ -> [v]
                 GT -> []

  enumFrom from = enumFromTo from R_X86_64_PC64

  fromEnum R_X86_64_None = 0
  fromEnum R_X86_64_64 = 1
  fromEnum R_X86_64_PC32 = 2
  fromEnum R_X86_64_PLT32 = 4
  fromEnum R_X86_64_32 = 10
  fromEnum R_X86_64_32S = 11
  fromEnum R_X86_64_PC64 = 24

  toEnum 0 = R_X86_64_None
  toEnum 1 = R_X86_64_64
  toEnum 2 = R_X86_64_PC32
  toEnum 4 = R_X86_64_PLT32
  toEnum 10 = R_X86_64_32
  toEnum 11 = R_X86_64_32S
  toEnum 24 = R_X86_64_PC64
  toEnum unmatched = error ("RelocationType.toEnum: Cannot match " ++ show unmatched)

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


-- The ELF file header appears at the start of every file.
--
readHeader :: Get (Peek, Table, Table, Int)
readHeader = do
  p@Peek{..}            <- readIdent
  (_, phs, secs, shstr) <- case is64Bit of
                             True  -> readHeader64 p
                             False -> readHeader32 p
  return (p, phs, secs, shstr)


readHeader32 :: Peek -> Get (Int, Table, Table, Int)
readHeader32 _ = fail "TODO: readHeader32"

readHeader64 :: Peek -> Get (Int, Table, Table, Int)
readHeader64 p@Peek{..} = do
  readType p
  readMachine p
  skip 4      -- e_version
  e_entry     <- getWord64        -- entry point virtual address (page offset?)
  e_phoff     <- getWord64        -- program header table file offset
  e_shoff     <- getWord64        -- section header table file offset
  skip (4+2)    -- e_flags + e_ehsize
  e_phentsize <- getWord16        -- byte size per program header entry
  e_phnum     <- getWord16        -- #program header entries
  e_shentsize <- getWord16
  e_shnum     <- getWord16
  e_shstrndx  <- getWord16
  return ( fromIntegral e_entry
         , Table { tb_fileoff = fromIntegral e_phoff, tb_entries = fromIntegral e_phnum, tb_entrysize = fromIntegral e_phentsize }
         , Table { tb_fileoff = fromIntegral e_shoff, tb_entries = fromIntegral e_shnum, tb_entrysize = fromIntegral e_shentsize }
         , fromIntegral e_shstrndx
         )


readIdent :: Get Peek
readIdent = do
  ei_magic    <- getBytes 4
  unless (ei_magic == B8.pack [chr 0x7f, 'E', 'L', 'F']) $
    fail "invalid magic number"

  ei_class    <- getWord8
  is64Bit     <- case ei_class of
                   1 -> return False
                   2 -> return True
                   _                    -> fail "invalid class"
  ei_data     <- getWord8
  p           <- case ei_data of
                   1 -> return $ Peek { getWord16 = getWord16le, getWord32 = getWord32le, getWord64 = getWord64le, .. }
                   2 -> return $ Peek { getWord16 = getWord16be, getWord32 = getWord32be, getWord64 = getWord64be, .. }
                   _                     -> fail "invalid data layout"
  ei_version  <- getWord8
  unless (ei_version == 1) $ fail "invalid version"
  skip (1+1+16-9) -- ABI, ABI version, padding
  return p


readType :: Peek -> Get ()
readType Peek{..} = do
  e_type    <- getWord16
  case e_type of
    1  -> return ()
    _                 -> fail "expected relocatable object file"

readMachine :: Peek -> Get ()
readMachine Peek{..} = do
  e_machine <- getWord16
  case e_machine of
    62 -> return ()
    _                   -> fail "expected host architecture object file"


{--
-- Program headers define how the ELF program behaves once it has been loaded,
-- as well as runtime linking information.
--
-- TLM: Since we are loading object files we shouldn't get any program headers.
--
readProgramHeader :: Peek -> Get ProgramHeader
readProgramHeader p@Peek{..} =
  case is64Bit of
    True  -> readProgramHeader64 p
    False -> readProgramHeader32 p

readProgramHeader32 :: Peek -> Get ProgramHeader
readProgramHeader32 _ = fail "TODO: readProgramHeader32"

readProgramHeader64 :: Peek -> Get ProgramHeader
readProgramHeader64 _ = fail "TODO: readProgramHeader64"
--}

-- Section headers contain information such as the section name, size, and
-- location in the object file. The list of all the section headers in the ELF
-- file is known as the section header table.
--
readSectionHeader :: Peek -> Get SectionHeader
readSectionHeader p@Peek{..} =
  case is64Bit of
    True  -> readSectionHeader64 p
    False -> readSectionHeader32 p

readSectionHeader32 :: Peek -> Get SectionHeader
readSectionHeader32 _ = fail "TODO: readSectionHeader32"

readSectionHeader64 :: Peek -> Get SectionHeader
readSectionHeader64 Peek{..} = do
  sh_name     <- fromIntegral <$> getWord32
  sh_type     <- toEnum . fromIntegral <$> getWord32
  sh_flags    <- getWord64
  sh_addr     <- getWord64
  sh_offset   <- fromIntegral <$> getWord64
  sh_size     <- fromIntegral <$> getWord64
  sh_link     <- fromIntegral <$> getWord32
  sh_info     <- fromIntegral <$> getWord32
  sh_align    <- fromIntegral <$> getWord64
  sh_entsize  <- fromIntegral <$> getWord64
  return SectionHeader {..}


indexStringTable :: ByteString -> Int -> ByteString
indexStringTable strtab ix = B.takeWhile (/= 0) (B.drop ix strtab)

readStringTable :: ByteString -> SectionHeader -> Either String ByteString
readStringTable obj SectionHeader{..} =
  case sh_type of
    StrTab -> Right $ B.take sh_size (B.drop sh_offset obj)
    _      -> Left "expected string table"


readRelocations :: Peek -> ByteString -> SectionHeader -> Either String (Vector Relocation)
readRelocations p@Peek{..} obj SectionHeader{..} = do
  unless (sh_type == Rel || sh_type == RelA) $ fail "expected relocation section"
  --
  let nrel = sh_size `quot` sh_entsize
  runGet (V.replicateM nrel (readRel p sh_type sh_info)) (B.drop sh_offset obj)


readRel :: Peek -> SectionType -> Int -> Get Relocation
readRel p@Peek{..} sh_type r_section =
  case is64Bit of
    True  -> readRel64 p sh_type r_section
    False -> readRel32 p sh_type r_section

readRel32 :: Peek -> SectionType -> Int -> Get Relocation
readRel32 _ _ _ = fail "TODO: readRel32"

readRel64 :: Peek -> SectionType -> Int -> Get Relocation
readRel64 Peek{..} sh_type r_section = do
  r_offset  <- getWord64
  r_info    <- getWord64
  r_addend  <- case sh_type of
                 RelA -> fromIntegral <$> getWord64
                 _    -> return 0
  let r_type    = toEnum (fromIntegral (r_info .&. 0xffffffff))
      r_symbol  = fromIntegral (r_info `shiftR` 32) - 1
  --
  return Relocation {..}


readSymbolTable :: Peek -> Vector SectionHeader -> ByteString -> SectionHeader -> Either String (Vector Symbol)
readSymbolTable p@Peek{..} secs obj SectionHeader{..} = do
  unless (sh_type == SymTab) $ fail "expected symbol table"

  let nsym    = sh_size `quot` sh_entsize
      offset  = sh_offset + sh_entsize  -- First symbol in the table is always null; skip it.
                                        -- Make sure to update relocation indices
  strtab  <- readStringTable obj (secs V.! sh_link)
  symbols <- runGet (V.replicateM (nsym-1) (readSymbol p secs strtab)) (B.drop offset obj)
  return symbols

readSymbol :: Peek -> Vector SectionHeader -> ByteString -> Get Symbol
readSymbol p@Peek{..} secs strtab =
  case is64Bit of
    True  -> readSymbol64 p secs strtab
    False -> readSymbol32 p secs strtab

readSymbol32 :: Peek -> Vector SectionHeader -> ByteString -> Get Symbol
readSymbol32 _ _ _ = fail "TODO: readSymbol32"

readSymbol64 :: Peek -> Vector SectionHeader -> ByteString -> Get Symbol
readSymbol64 Peek{..} secs strtab = do
  st_strx     <- fromIntegral <$> getWord32
  st_info     <- getWord8
  skip 1 -- st_other  <- getWord8
  sym_section <- fromIntegral <$> getWord16
  sym_value   <- getWord64
  skip 8 -- st_size   <- getWord64

  let sym_name
        | sym_type == Section = indexStringTable strtab (sh_name (secs V.! sym_section))
        | st_strx == 0        = B.empty
        | otherwise           = indexStringTable strtab st_strx

      sym_binding = toEnum $ fromIntegral ((st_info .&. 0xF0) `shiftR` 4)
      sym_type    = toEnum $ fromIntegral (st_info .&. 0x0F)

  case sym_section of
    -- External symbol; lookup value
    0 | not (B.null sym_name) -> do
        funptr <- resolveSymbol sym_name
        message (printf "%s: external symbol found at %s" (B8.unpack sym_name) (show funptr))
        return Symbol { sym_value = castPtrToWord64 (castFunPtrToPtr funptr), .. }

    -- Internally defined symbol
    n | n < 0xff00 -> do
        message (printf "%s: local symbol in section %d at 0x%02x" (B8.unpack sym_name) sym_section sym_value)
        return Symbol {..}

    0xfff1 | sym_type == File -> return Symbol {..}
    0xfff1 -> fail "unhandled absolute symbol"
    _                 -> fail "unhandled symbol section"


-- Return the address binding the named symbol
--
resolveSymbol :: ByteString -> Get (FunPtr ())
resolveSymbol name
  = unsafePerformIO
  $ B.unsafeUseAsCString name $ \c_name -> do
      addr <- c_dlsym (packDL Default) c_name
      if addr == nullFunPtr
        then do
          err <- dlerror
          return (fail $ printf "failed to resolve symbol %s: %s" (B8.unpack name) err)
        else do
          return (return addr)


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

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


-- c-bits
-- ------

-- Control the protection of pages
--
mprotect :: Ptr Word8 -> Int -> Int -> IO ()
mprotect addr len prot
  = throwErrnoIfMinus1_ "mprotect"
  $ c_mprotect addr (fromIntegral len) (fromIntegral prot)

-- Allocate memory pages in the lower 2GB
--
mmap :: Int -> IO (Ptr Word8)
mmap len
  = throwErrnoIf (== _MAP_FAILED) "mmap"
  $ c_mmap nullPtr (fromIntegral len) prot flags (-1) 0
  where
    prot        = 0x1 .|. 0x2
{-# LINE 718 "src/Data/Array/Accelerate/LLVM/Native/Link/ELF.chs" #-}

    flags       = 0x20 .|. 0x2 .|. 0x40
{-# LINE 719 "src/Data/Array/Accelerate/LLVM/Native/Link/ELF.chs" #-}

    _MAP_FAILED = Ptr (int2Addr# (-1#))

-- Remove a memory mapping
--
munmap :: Ptr Word8 -> Int -> IO ()
munmap addr len
  = throwErrnoIfMinus1_ "munmap"
  $ c_munmap addr (fromIntegral len)

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

foreign import ccall unsafe "mmap"
  c_mmap :: Ptr a -> CSize -> CInt -> CInt -> CInt -> COff -> IO (Ptr a)

foreign import ccall unsafe "munmap"
  c_munmap :: Ptr a -> CSize -> IO CInt

foreign import ccall unsafe "getpagesize"
  c_getpagesize :: CInt


-- Debug
-- -----

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

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