module GHCi.InfoTable
(
mkConInfoTable
) where
import Prelude hiding (fail)
import Foreign
import Foreign.C
import GHC.Ptr
import GHC.Exts
import GHC.Exts.Heap
import Data.ByteString (ByteString)
import Control.Monad.Fail
import qualified Data.ByteString as BS
mkConInfoTable
:: Bool
-> Int
-> Int
-> Int
-> Int
-> ByteString
-> IO (Ptr StgInfoTable)
mkConInfoTable tables_next_to_code ptr_words nonptr_words tag ptrtag con_desc = do
let entry_addr = interpConstrEntry !! ptrtag
code' <- if tables_next_to_code
then Just <$> mkJumpToAddr entry_addr
else pure Nothing
let
itbl = StgInfoTable {
entry = if tables_next_to_code
then Nothing
else Just entry_addr,
ptrs = fromIntegral ptr_words,
nptrs = fromIntegral nonptr_words,
tipe = CONSTR,
srtlen = fromIntegral tag,
code = code'
}
castFunPtrToPtr <$> newExecConItbl tables_next_to_code itbl con_desc
funPtrToInt :: FunPtr a -> Int
funPtrToInt (FunPtr a) = I# (addr2Int# a)
data Arch = ArchSPARC
| ArchPPC
| ArchX86
| ArchX86_64
| ArchAlpha
| ArchARM
| ArchAArch64
| ArchPPC64
| ArchPPC64LE
| ArchS390X
deriving Show
mkJumpToAddr :: MonadFail m => EntryFunPtr-> m ItblCodes
mkJumpToAddr ptr = do
arch <- case mArch of
Just a -> pure a
Nothing ->
fail "mkJumpToAddr: Unknown obscure arch is not supported with TABLES_NEXT_TO_CODE"
pure $ mkJumpToAddr' arch ptr
mArch :: Maybe Arch
mArch =
Just ArchX86_64
mkJumpToAddr' :: Arch -> EntryFunPtr -> ItblCodes
mkJumpToAddr' platform a = case platform of
ArchSPARC ->
let w32 = fromIntegral (funPtrToInt a)
hi22, lo10 :: Word32 -> Word32
lo10 x = x .&. 0x3FF
hi22 x = (x `shiftR` 10) .&. 0x3FFFF
in Right [ 0x07000000 .|. (hi22 w32),
0x8610E000 .|. (lo10 w32),
0x81C0C000,
0x01000000 ]
ArchPPC ->
let w32 = fromIntegral (funPtrToInt a)
hi16 x = (x `shiftR` 16) .&. 0xFFFF
lo16 x = x .&. 0xFFFF
in Right [ 0x3D800000 .|. hi16 w32,
0x618C0000 .|. lo16 w32,
0x7D8903A6, 0x4E800420 ]
ArchX86 ->
let w32 = fromIntegral (funPtrToInt a) :: Word32
insnBytes :: [Word8]
insnBytes
= [0xB8, byte0 w32, byte1 w32,
byte2 w32, byte3 w32,
0xFF, 0xE0]
in
Left insnBytes
ArchX86_64 ->
let w64 = fromIntegral (funPtrToInt a) :: Word64
insnBytes :: [Word8]
insnBytes
= [0xff, 0x25, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,
byte0 w64, byte1 w64, byte2 w64, byte3 w64,
byte4 w64, byte5 w64, byte6 w64, byte7 w64]
in
Left insnBytes
ArchAlpha ->
let w64 = fromIntegral (funPtrToInt a) :: Word64
in Right [ 0xc3800000
, 0xa79c000c
, 0x6bfc0000
, 0x47ff041f
, fromIntegral (w64 .&. 0x0000FFFF)
, fromIntegral ((w64 `shiftR` 32) .&. 0x0000FFFF) ]
ArchARM { } ->
let w32 = fromIntegral (funPtrToInt a) :: Word32
in Left [ 0x00, 0x10, 0x9f, 0xe5
, 0x11, 0xff, 0x2f, 0xe1
, byte0 w32, byte1 w32, byte2 w32, byte3 w32]
ArchAArch64 { } ->
let w64 = fromIntegral (funPtrToInt a) :: Word64
in Right [ 0x58000041
, 0xd61f0020
, fromIntegral w64
, fromIntegral (w64 `shiftR` 32) ]
ArchPPC64 ->
let w32 = fromIntegral (funPtrToInt a)
hi16 x = (x `shiftR` 16) .&. 0xFFFF
lo16 x = x .&. 0xFFFF
in Right [ 0x3D800000 .|. hi16 w32,
0x618C0000 .|. lo16 w32,
0xE96C0000,
0xE84C0008,
0x7D6903A6,
0xE96C0010,
0x4E800420]
ArchPPC64LE ->
let w32 = fromIntegral (funPtrToInt a)
hi16 x = (x `shiftR` 16) .&. 0xFFFF
lo16 x = x .&. 0xFFFF
in Right [ 0x3D800000 .|. hi16 w32,
0x618C0000 .|. lo16 w32,
0x7D8903A6, 0x4E800420 ]
ArchS390X ->
let w64 = fromIntegral (funPtrToInt a) :: Word64
in Left [ 0xC0, 0x1E, byte7 w64, byte6 w64, byte5 w64, byte4 w64,
0xC0, 0x19, byte3 w64, byte2 w64, byte1 w64, byte0 w64,
0x07, 0xF1 ]
byte0 :: (Integral w) => w -> Word8
byte0 w = fromIntegral w
byte1, byte2, byte3, byte4, byte5, byte6, byte7
:: (Integral w, Bits w) => w -> Word8
byte1 w = fromIntegral (w `shiftR` 8)
byte2 w = fromIntegral (w `shiftR` 16)
byte3 w = fromIntegral (w `shiftR` 24)
byte4 w = fromIntegral (w `shiftR` 32)
byte5 w = fromIntegral (w `shiftR` 40)
byte6 w = fromIntegral (w `shiftR` 48)
byte7 w = fromIntegral (w `shiftR` 56)
foreign import ccall "&stg_interp_constr1_entry" stg_interp_constr1_entry :: EntryFunPtr
foreign import ccall "&stg_interp_constr2_entry" stg_interp_constr2_entry :: EntryFunPtr
foreign import ccall "&stg_interp_constr3_entry" stg_interp_constr3_entry :: EntryFunPtr
foreign import ccall "&stg_interp_constr4_entry" stg_interp_constr4_entry :: EntryFunPtr
foreign import ccall "&stg_interp_constr5_entry" stg_interp_constr5_entry :: EntryFunPtr
foreign import ccall "&stg_interp_constr6_entry" stg_interp_constr6_entry :: EntryFunPtr
foreign import ccall "&stg_interp_constr7_entry" stg_interp_constr7_entry :: EntryFunPtr
interpConstrEntry :: [EntryFunPtr]
interpConstrEntry = [ error "pointer tag 0"
, stg_interp_constr1_entry
, stg_interp_constr2_entry
, stg_interp_constr3_entry
, stg_interp_constr4_entry
, stg_interp_constr5_entry
, stg_interp_constr6_entry
, stg_interp_constr7_entry ]
data StgConInfoTable = StgConInfoTable {
conDesc :: Ptr Word8,
infoTable :: StgInfoTable
}
pokeConItbl
:: Bool -> Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable
-> IO ()
pokeConItbl tables_next_to_code wr_ptr _ex_ptr itbl = do
if tables_next_to_code
then do
let con_desc_offset = conDesc itbl `minusPtr` (_ex_ptr `plusPtr` conInfoTableSizeB)
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) wr_ptr con_desc_offset
else do
pokeByteOff wr_ptr itblSize (conDesc itbl)
pokeItbl (wr_ptr `plusPtr` ((8))) (infoTable itbl)
sizeOfEntryCode :: MonadFail m => Bool -> m Int
sizeOfEntryCode tables_next_to_code
| not tables_next_to_code = pure 0
| otherwise = do
code' <- mkJumpToAddr undefined
pure $ case code' of
Left xs -> sizeOf (head xs) * length xs
Right xs -> sizeOf (head xs) * length xs
newExecConItbl :: Bool -> StgInfoTable -> ByteString -> IO (FunPtr ())
newExecConItbl tables_next_to_code obj con_desc
= alloca $ \pcode -> do
sz0 <- sizeOfEntryCode tables_next_to_code
let lcon_desc = BS.length con_desc + 1
sz = fromIntegral $ conInfoTableSizeB + sz0
wr_ptr <- _allocateExec (sz + fromIntegral lcon_desc) pcode
ex_ptr <- peek pcode
let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz
, infoTable = obj }
pokeConItbl tables_next_to_code wr_ptr ex_ptr cinfo
BS.useAsCStringLen con_desc $ \(src, len) ->
copyBytes (castPtr wr_ptr `plusPtr` fromIntegral sz) src len
let null_off = fromIntegral sz + fromIntegral (BS.length con_desc)
poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8)
_flushExec sz ex_ptr
pure $ if tables_next_to_code
then castPtrToFunPtr $ ex_ptr `plusPtr` conInfoTableSizeB
else castPtrToFunPtr ex_ptr
foreign import ccall unsafe "allocateExec"
_allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)
foreign import ccall unsafe "flushExec"
_flushExec :: CUInt -> Ptr a -> IO ()
wORD_SIZE :: Int
wORD_SIZE = (8)
conInfoTableSizeB :: Int
conInfoTableSizeB = wORD_SIZE + itblSize