{-# LINE 1 "libraries/ghci/GHCi/InfoTable.hsc" #-}
{-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-}
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
import GHC.Platform.Host (hostPlatformArch)
import GHC.Platform.ArchOS
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)
mkJumpToAddr :: MonadFail m => EntryFunPtr-> m ItblCodes
mkJumpToAddr a = case hostPlatformArch of
ArchSPARC -> pure $
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 -> pure $
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 -> pure $
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 -> pure $
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 -> pure $
let w64 = fromIntegral (funPtrToInt a) :: Word64
in Right [ 0xc3800000
, 0xa79c000c
, 0x6bfc0000
, 0x47ff041f
, fromIntegral (w64 .&. 0x0000FFFF)
, fromIntegral ((w64 `shiftR` 32) .&. 0x0000FFFF) ]
ArchARM {} -> pure $
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 {} -> pure $
let w64 = fromIntegral (funPtrToInt a) :: Word64
in Right [ 0x58000041
, 0xd61f0020
, fromIntegral w64
, fromIntegral (w64 `shiftR` 32) ]
ArchPPC_64 ELF_V1 -> pure $
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]
ArchPPC_64 ELF_V2 -> pure $
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 -> pure $
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 ]
arch ->
fail $ "mkJumpToAddr: arch is not supported with TABLES_NEXT_TO_CODE ("
++ show arch ++ ")"
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
{-# LINE 302 "libraries/ghci/GHCi/InfoTable.hsc" #-}
else do
pokeByteOff wr_ptr itblSize (conDesc itbl)
pokeItbl (wr_ptr `plusPtr` ((8))) (infoTable itbl)
{-# LINE 308 "libraries/ghci/GHCi/InfoTable.hsc" #-}
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 = do
sz0 <- sizeOfEntryCode tables_next_to_code
let lcon_desc = BS.length con_desc + 1
sz = fromIntegral $ conInfoTableSizeB + sz0
ex_ptr <- fillExecBuffer (sz + fromIntegral lcon_desc) $ \wr_ptr ex_ptr -> do
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)
pure $ if tables_next_to_code
then castPtrToFunPtr $ ex_ptr `plusPtr` conInfoTableSizeB
else castPtrToFunPtr ex_ptr
fillExecBuffer :: CSize -> (Ptr a -> Ptr a -> IO ()) -> IO (Ptr a)
{-# LINE 350 "libraries/ghci/GHCi/InfoTable.hsc" #-}
data ExecPage
foreign import ccall unsafe "allocateExecPage"
_allocateExecPage :: IO (Ptr ExecPage)
foreign import ccall unsafe "freezeExecPage"
_freezeExecPage :: Ptr ExecPage -> IO ()
fillExecBuffer sz cont
| sz > 4096 = fail "withExecBuffer: Too large"
| otherwise = do
pg <- _allocateExecPage
cont (castPtr pg) (castPtr pg)
_freezeExecPage pg
return (castPtr pg)
{-# LINE 389 "libraries/ghci/GHCi/InfoTable.hsc" #-}
wORD_SIZE :: Int
wORD_SIZE = (8)
{-# LINE 395 "libraries/ghci/GHCi/InfoTable.hsc" #-}
conInfoTableSizeB :: Int
conInfoTableSizeB = wORD_SIZE + itblSize