diff options
Diffstat (limited to 'libraries/ghci/GHCi/InfoTable.hsc')
| -rw-r--r-- | libraries/ghci/GHCi/InfoTable.hsc | 138 |
1 files changed, 67 insertions, 71 deletions
diff --git a/libraries/ghci/GHCi/InfoTable.hsc b/libraries/ghci/GHCi/InfoTable.hsc index ab13485e28..4886577d6e 100644 --- a/libraries/ghci/GHCi/InfoTable.hsc +++ b/libraries/ghci/GHCi/InfoTable.hsc @@ -13,27 +13,23 @@ 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 -#if defined(TABLES_NEXT_TO_CODE) -ghciTablesNextToCode = True -#else -ghciTablesNextToCode = False -#endif - -- NOTE: Must return a pointer acceptable for use in the header of a closure. -- If tables_next_to_code is enabled, then it must point the the 'code' field. -- Otherwise, it should point to the start of the StgInfoTable. mkConInfoTable - :: Int -- ptr words + :: Bool -- TABLES_NEXT_TO_CODE + -> Int -- ptr words -> Int -- non-ptr words -> Int -- constr tag -> Int -- pointer tag @@ -42,23 +38,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 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 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 tables_next_to_code itbl con_desc -- ----------------------------------------------------------------------------- @@ -76,39 +72,46 @@ data Arch = ArchSPARC | ArchARM64 | ArchPPC64 | ArchPPC64LE - | 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 #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. @@ -268,11 +271,6 @@ mkJumpToAddr a = case platform of 0x618C0000 .|. lo16 w32, 0x7D8903A6, 0x4E800420 ] - -- 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 @@ -316,38 +314,40 @@ data StgConInfoTable = StgConInfoTable { pokeConItbl - :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable + :: Bool -> 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 +pokeConItbl tables_next_to_code wr_ptr _ex_ptr itbl = do + 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 - | not ghciTablesNextToCode = 0 - | otherwise = - case mkJumpToAddr undefined of +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 -- Note: Must return proper pointer for use in a closure -newExecConItbl :: StgInfoTable -> ByteString -> IO (FunPtr ()) -newExecConItbl obj con_desc +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{- 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 @@ -356,17 +356,13 @@ newExecConItbl obj con_desc ex_ptr <- peek pcode let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz , infoTable = obj } - pokeConItbl wr_ptr ex_ptr cinfo + 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 -- Cache flush (if needed) -#if defined(TABLES_NEXT_TO_CODE) - return (castPtrToFunPtr (ex_ptr `plusPtr` conInfoTableSizeB)) -#else - return (castPtrToFunPtr ex_ptr) -#endif + if tables_next_to_code + then return (castPtrToFunPtr (ex_ptr `plusPtr` conInfoTableSizeB)) + else return (castPtrToFunPtr ex_ptr) foreign import ccall unsafe "allocateExec" _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a) |