summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc4
-rw-r--r--libraries/ghci/GHCi/InfoTable.hsc122
2 files changed, 65 insertions, 61 deletions
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc b/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc
index 783744f26a..943a234391 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc
+++ b/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc
@@ -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)
diff --git a/libraries/ghci/GHCi/InfoTable.hsc b/libraries/ghci/GHCi/InfoTable.hsc
index 587e39bbed..09970e0370 100644
--- a/libraries/ghci/GHCi/InfoTable.hsc
+++ b/libraries/ghci/GHCi/InfoTable.hsc
@@ -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)
View Lorry Controller Status