[Git][ghc/ghc][wip/D5082] Make tablesNextToCode a proper dynamic flag (#15548)
John Ericson
gitlab at gitlab.haskell.org
Fri Apr 5 20:28:12 UTC 2019
John Ericson pushed to branch wip/D5082 at Glasgow Haskell Compiler / GHC
Commits:
e7369f6b by Joachim Breitner at 2019-04-05T20:28:04Z
Make tablesNextToCode a proper dynamic flag (#15548)
Summary:
There is no more use of the TABLES_NEXT_TO_CODE CPP macro in
`compiler/`. The default value of `tablesNextToCode` is calculated as
before, but now users of the GHCI API can modify this flag.
Reviewers:
Subscribers: TerrorJack, rwbarton, carter
GHC Trac Issues: #15548
Differential Revision: https://phabricator.haskell.org/D5082
- - - - -
9 changed files:
- compiler/ghc.mk
- compiler/ghci/ByteCodeItbls.hs
- compiler/main/DynFlags.hs
- compiler/main/SysTools.hs
- compiler/utils/Util.hs
- hadrian/src/Settings/Packages.hs
- libraries/ghci/GHCi/InfoTable.hsc
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/Run.hs
Changes:
=====================================
compiler/ghc.mk
=====================================
@@ -330,14 +330,6 @@ endif
ifeq "$(GhcWithInterpreter)" "YES"
compiler_stage2_CONFIGURE_OPTS += --flags=ghci
-ifeq "$(GhcEnableTablesNextToCode) $(GhcUnregisterised)" "YES NO"
-# Should GHCI be building info tables in the TABLES_NEXT_TO_CODE style
-# or not?
-# XXX This should logically be a CPP option, but there doesn't seem to
-# be a flag for that
-compiler_stage2_CONFIGURE_OPTS += --ghc-option=-DGHCI_TABLES_NEXT_TO_CODE
-endif
-
# Should the debugger commands be enabled?
ifeq "$(GhciWithDebugger)" "YES"
compiler_stage2_CONFIGURE_OPTS += --ghc-option=-DDEBUGGER
=====================================
compiler/ghci/ByteCodeItbls.hs
=====================================
@@ -71,6 +71,8 @@ make_constr_itbls hsc_env cons =
descr = dataConIdentity dcon
- r <- iservCmd hsc_env (MkConInfoTable ptrs' nptrs_really
+ tables_next_to_code = tablesNextToCode dflags
+
+ r <- iservCmd hsc_env (MkConInfoTable tables_next_to_code ptrs' nptrs_really
conNo (tagForCon dflags dcon) descr)
return (getName dcon, ItblPtr r)
=====================================
compiler/main/DynFlags.hs
=====================================
@@ -58,7 +58,6 @@ module DynFlags (
fFlags, fLangFlags, xFlags,
wWarningFlags,
dynFlagDependencies,
- tablesNextToCode, mkTablesNextToCode,
makeDynFlagsConsistent,
shouldUseColor,
shouldUseHexWordLiterals,
@@ -876,6 +875,10 @@ data DynFlags = DynFlags {
integerLibrary :: IntegerLibrary,
-- ^ IntegerGMP or IntegerSimple. Set at configure time, but may be overriden
-- by GHC-API users. See Note [The integer library] in PrelNames
+ tablesNextToCode :: Bool,
+ -- ^ Determines whether we will be compiling info tables that reside just
+ -- before the entry code, or with an indirection to the entry code. See
+ -- TABLES_NEXT_TO_CODE in includes/rts/storage/InfoTables.h.
llvmTargets :: LlvmTargets,
llvmPasses :: LlvmPasses,
verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels]
@@ -1614,18 +1617,6 @@ defaultObjectTarget platform
| cGhcWithNativeCodeGen == "YES" = HscAsm
| otherwise = HscLlvm
-tablesNextToCode :: DynFlags -> Bool
-tablesNextToCode dflags
- = mkTablesNextToCode (platformUnregisterised (targetPlatform dflags))
-
--- Determines whether we will be compiling
--- info tables that reside just before the entry code, or with an
--- indirection to the entry code. See TABLES_NEXT_TO_CODE in
--- includes/rts/storage/InfoTables.h.
-mkTablesNextToCode :: Bool -> Bool
-mkTablesNextToCode unregisterised
- = not unregisterised && cGhcEnableTablesNextToCode == "YES"
-
data DynLibLoader
= Deployable
| SystemDependent
@@ -1874,6 +1865,9 @@ defaultDynFlags mySettings (myLlvmTargets, myLlvmPasses) =
ghcLink = LinkBinary,
hscTarget = defaultHscTarget (sTargetPlatform mySettings),
integerLibrary = cIntegerLibraryType,
+ tablesNextToCode =
+ not (platformUnregisterised $ sTargetPlatform mySettings) &&
+ cGhcEnableTablesNextToCode == "YES",
verbosity = 0,
optLevel = 0,
debugLevel = 0,
=====================================
compiler/main/SysTools.hs
=====================================
@@ -199,15 +199,9 @@ initSysTools top_dir
let unreg_gcc_args = if targetUnregisterised
then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
else []
- -- TABLES_NEXT_TO_CODE affects the info table layout.
- tntc_gcc_args
- | mkTablesNextToCode targetUnregisterised
- = ["-DTABLES_NEXT_TO_CODE"]
- | otherwise = []
cpp_args= map Option (words cpp_args_str)
gcc_args = map Option (words gcc_args_str
- ++ unreg_gcc_args
- ++ tntc_gcc_args)
+ ++ unreg_gcc_args)
ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"
ldSupportsBuildId <- getBooleanSetting "ld supports build-id"
ldSupportsFilelist <- getBooleanSetting "ld supports filelist"
=====================================
compiler/utils/Util.hs
=====================================
@@ -11,7 +11,6 @@
module Util (
-- * Flags dependent on the compiler build
ghciSupported, debugIsOn, ncgDebugIsOn,
- ghciTablesNextToCode,
isWindowsHost, isDarwinHost,
-- * General list processing
@@ -208,13 +207,6 @@ ncgDebugIsOn = True
ncgDebugIsOn = False
#endif
-ghciTablesNextToCode :: Bool
-#if defined(GHCI_TABLES_NEXT_TO_CODE)
-ghciTablesNextToCode = True
-#else
-ghciTablesNextToCode = False
-#endif
-
isWindowsHost :: Bool
#if defined(mingw32_HOST_OS)
isWindowsHost = True
=====================================
hadrian/src/Settings/Packages.hs
=====================================
@@ -57,10 +57,6 @@ packageArgs = do
, notM ghcWithSMP ? arg "--ghc-option=-optc-DNOSMP"
, (any (wayUnit Threaded) rtsWays) ?
notStage0 ? arg "--ghc-option=-optc-DTHREADED_RTS"
- , ghcWithInterpreter ?
- ghcEnableTablesNextToCode ?
- notM (flag GhcUnregisterised) ?
- notStage0 ? arg "--ghc-option=-DGHCI_TABLES_NEXT_TO_CODE"
, ghcWithInterpreter ?
ghciWithDebugger <$> flavour ?
notStage0 ? arg "--ghc-option=-DDEBUGGER"
=====================================
libraries/ghci/GHCi/InfoTable.hsc
=====================================
@@ -26,19 +26,13 @@ import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
#endif
-ghciTablesNextToCode :: Bool
-#ifdef TABLES_NEXT_TO_CODE
-ghciTablesNextToCode = True
-#else
-ghciTablesNextToCode = False
-#endif
-
#ifdef GHCI /* To end */
-- 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
@@ -47,23 +41,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
-- -----------------------------------------------------------------------------
@@ -81,39 +75,46 @@ data Arch = ArchSPARC
| ArchARM64
| ArchPPC64
| ArchPPC64LE
- | ArchUnknown
deriving Show
-platform :: Arch
-platform =
+mkJumpToAddr :: Monad 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.
@@ -273,11 +274,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
@@ -321,38 +317,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 :: Monad m => Bool -> m Int
+sizeOfEntryCode tables_next_to_code = do
+ | 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
@@ -361,17 +359,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)
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -104,7 +104,8 @@ data Message a where
-- | Create an info table for a constructor
MkConInfoTable
- :: Int -- ptr words
+ :: Bool -- TABLES_NEXT_TO_CODE
+ -> Int -- ptr words
-> Int -- non-ptr words
-> Int -- constr tag
-> Int -- pointer tag
@@ -468,7 +469,7 @@ getMessage = do
15 -> Msg <$> MallocStrings <$> get
16 -> Msg <$> (PrepFFI <$> get <*> get <*> get)
17 -> Msg <$> FreeFFI <$> get
- 18 -> Msg <$> (MkConInfoTable <$> get <*> get <*> get <*> get <*> get)
+ 18 -> Msg <$> (MkConInfoTable <$> get <*> get <*> get <*> get <*> get <*> get)
19 -> Msg <$> (EvalStmt <$> get <*> get)
20 -> Msg <$> (ResumeStmt <$> get <*> get)
21 -> Msg <$> (AbandonStmt <$> get)
@@ -510,7 +511,7 @@ putMessage m = case m of
MallocStrings bss -> putWord8 15 >> put bss
PrepFFI conv args res -> putWord8 16 >> put conv >> put args >> put res
FreeFFI p -> putWord8 17 >> put p
- MkConInfoTable p n t pt d -> putWord8 18 >> put p >> put n >> put t >> put pt >> put d
+ MkConInfoTable tc p n t pt d -> putWord8 18 >> put tc >> put p >> put n >> put t >> put pt >> put d
EvalStmt opts val -> putWord8 19 >> put opts >> put val
ResumeStmt opts val -> putWord8 20 >> put opts >> put val
AbandonStmt val -> putWord8 21 >> put val
=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -89,8 +89,8 @@ run m = case m of
MallocStrings bss -> mapM mkString0 bss
PrepFFI conv args res -> toRemotePtr <$> prepForeignCall conv args res
FreeFFI p -> freeForeignCallInfo (fromRemotePtr p)
- MkConInfoTable ptrs nptrs tag ptrtag desc ->
- toRemotePtr <$> mkConInfoTable ptrs nptrs tag ptrtag desc
+ MkConInfoTable tc ptrs nptrs tag ptrtag desc ->
+ toRemotePtr <$> mkConInfoTable tc ptrs nptrs tag ptrtag desc
StartTH -> startTH
GetClosure ref -> do
clos <- getClosureData =<< localRef ref
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/e7369f6bf0351ab9fe0752afe27e71f6e691d694
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/e7369f6bf0351ab9fe0752afe27e71f6e691d694
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190405/ade7e4ef/attachment-0001.html>
More information about the ghc-commits
mailing list