Commit f51efc4b authored by Joachim Breitner's avatar Joachim Breitner Committed by John Ericson
Browse files

Prepare to use run-time tablesNextToCode in compiler exclusively

Factor out CPP as much as possible to prepare for runtime
determinattion.

Progress towards #15548
parent eb2162c8
......@@ -31,10 +31,10 @@ type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ()))
-- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/storage/InfoTables.h>
-- for more details on this data structure.
data StgInfoTable = StgInfoTable {
entry :: Maybe EntryFunPtr, -- Just <=> not ghciTablesNextToCode
entry :: Maybe EntryFunPtr, -- Just <=> not TABLES_NEXT_TO_CODE
ptrs :: HalfWord,
nptrs :: HalfWord,
tipe :: ClosureType,
srtlen :: HalfWord,
code :: Maybe ItblCodes -- Just <=> ghciTablesNextToCode
code :: Maybe ItblCodes -- Just <=> TABLES_NEXT_TO_CODE
} deriving (Show, Generic)
......@@ -13,20 +13,22 @@ module GHCi.InfoTable
mkConInfoTable
) where
import Prelude -- See note [Why do we import Prelude here?]
import Prelude hiding (fail) -- See note [Why do we import Prelude here?]
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
ghciTablesNextToCode :: Bool
tables_next_to_code :: Bool
#if defined(TABLES_NEXT_TO_CODE)
ghciTablesNextToCode = True
tables_next_to_code = True
#else
ghciTablesNextToCode = False
tables_next_to_code = False
#endif
-- NOTE: Must return a pointer acceptable for use in the header of a closure.
......@@ -42,23 +44,23 @@ mkConInfoTable
-- resulting info table is allocated with allocateExec(), and
-- should be freed with freeExec().
mkConInfoTable ptr_words nonptr_words tag ptrtag con_desc =
castFunPtrToPtr <$> newExecConItbl itbl con_desc
where
entry_addr = interpConstrEntry !! ptrtag
code' = mkJumpToAddr entry_addr
mkConInfoTable 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 ghciTablesNextToCode
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 = if ghciTablesNextToCode
then Just code'
else Nothing
code = code'
}
castFunPtrToPtr <$> newExecConItbl itbl con_desc
-- -----------------------------------------------------------------------------
......@@ -77,41 +79,48 @@ data Arch = ArchSPARC
| ArchPPC64
| ArchPPC64LE
| ArchS390X
| ArchUnknown
deriving Show
platform :: Arch
platform =
mkJumpToAddr :: MonadFail m => EntryFunPtr-> m ItblCodes
mkJumpToAddr ptr = do
arch <- case mArch of
Just a -> pure a
Nothing ->
-- This code must not be called. You either need to add your
-- architecture as a distinct case to 'Arch' and 'mArch', or use
-- non-TABLES_NEXT_TO_CODE mode.
fail "mkJumpToAddr: Unknown obscure arch is not supported with TABLES_NEXT_TO_CODE"
pure $ mkJumpToAddr' arch ptr
-- | 'Just' if it's a known OS, or 'Nothing' otherwise.
mArch :: Maybe Arch
mArch =
#if defined(sparc_HOST_ARCH)
ArchSPARC
Just ArchSPARC
#elif defined(powerpc_HOST_ARCH)
ArchPPC
Just ArchPPC
#elif defined(i386_HOST_ARCH)
ArchX86
Just ArchX86
#elif defined(x86_64_HOST_ARCH)
ArchX86_64
Just ArchX86_64
#elif defined(alpha_HOST_ARCH)
ArchAlpha
Just ArchAlpha
#elif defined(arm_HOST_ARCH)
ArchARM
Just ArchARM
#elif defined(aarch64_HOST_ARCH)
ArchARM64
Just ArchARM64
#elif defined(powerpc64_HOST_ARCH)
ArchPPC64
Just ArchPPC64
#elif defined(powerpc64le_HOST_ARCH)
ArchPPC64LE
Just ArchPPC64LE
#elif defined(s390x_HOST_ARCH)
ArchS390X
Just ArchS390X
#else
# if defined(TABLES_NEXT_TO_CODE)
# error Unimplemented architecture
# else
ArchUnknown
# endif
Nothing
#endif
mkJumpToAddr :: EntryFunPtr -> ItblCodes
mkJumpToAddr a = case platform of
mkJumpToAddr' :: Arch -> EntryFunPtr -> ItblCodes
mkJumpToAddr' platform a = case platform of
ArchSPARC ->
-- After some consideration, we'll try this, where
-- 0x55555555 stands in for the address to jump to.
......@@ -285,11 +294,6 @@ mkJumpToAddr a = case platform of
0xC0, 0x19, byte3 w64, byte2 w64, byte1 w64, byte0 w64,
0x07, 0xF1 ]
-- This code must not be called. You either need to
-- add your architecture as a distinct case or
-- use non-TABLES_NEXT_TO_CODE mode
ArchUnknown -> error "mkJumpToAddr: ArchUnknown is unsupported"
byte0 :: (Integral w) => w -> Word8
byte0 w = fromIntegral w
......@@ -336,24 +340,25 @@ pokeConItbl
:: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable
-> IO ()
pokeConItbl wr_ptr _ex_ptr itbl = do
#if defined(TABLES_NEXT_TO_CODE)
-- Write the offset to the con_desc from the end of the standard InfoTable
-- at the first byte.
let con_desc_offset = conDesc itbl `minusPtr` (_ex_ptr `plusPtr` conInfoTableSizeB)
(#poke StgConInfoTable, con_desc) wr_ptr con_desc_offset
#else
-- Write the con_desc address after the end of the info table.
-- Use itblSize because CPP will not pick up PROFILING when calculating
-- the offset.
pokeByteOff wr_ptr itblSize (conDesc itbl)
#endif
if tables_next_to_code
then do
-- Write the offset to the con_desc from the end of the standard InfoTable
-- at the first byte.
let con_desc_offset = conDesc itbl `minusPtr` (_ex_ptr `plusPtr` conInfoTableSizeB)
(#poke StgConInfoTable, con_desc) wr_ptr con_desc_offset
else do
-- Write the con_desc address after the end of the info table.
-- Use itblSize because CPP will not pick up PROFILING when calculating
-- the offset.
pokeByteOff wr_ptr itblSize (conDesc itbl)
pokeItbl (wr_ptr `plusPtr` (#offset StgConInfoTable, i)) (infoTable itbl)
sizeOfEntryCode :: Int
sizeOfEntryCode :: MonadFail m => m Int
sizeOfEntryCode
| not ghciTablesNextToCode = 0
| otherwise =
case mkJumpToAddr undefined of
| 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
......@@ -361,10 +366,11 @@ sizeOfEntryCode
newExecConItbl :: StgInfoTable -> ByteString -> IO (FunPtr ())
newExecConItbl obj con_desc
= alloca $ \pcode -> do
sz0 <- sizeOfEntryCode
let lcon_desc = BS.length con_desc + 1{- null terminator -}
-- SCARY
-- This size represents the number of bytes in an StgConInfoTable.
sz = fromIntegral (conInfoTableSizeB + sizeOfEntryCode)
sz = fromIntegral $ conInfoTableSizeB + sz0
-- Note: we need to allocate the conDesc string next to the info
-- table, because on a 64-bit platform we reference this string
-- with a 32-bit offset relative to the info table, so if we
......@@ -379,11 +385,9 @@ newExecConItbl obj con_desc
let null_off = fromIntegral sz + fromIntegral (BS.length con_desc)
poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8)
_flushExec sz ex_ptr -- Cache flush (if needed)
#if defined(TABLES_NEXT_TO_CODE)
return (castPtrToFunPtr (ex_ptr `plusPtr` conInfoTableSizeB))
#else
return (castPtrToFunPtr ex_ptr)
#endif
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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment