From f57616ff540fcc45da3eff03dadcb81e76bbdb15 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Sun, 20 Jan 2019 19:25:26 -0500 Subject: Use run-time tablesNextToCode in compiler exclusively (#15548) Summary: - There is no more use of the TABLES_NEXT_TO_CODE CPP macro in `compiler/`. GHCI_TABLES_NEXT_TO_CODE is also removed entirely. The field within `PlatformMisc` within `DynFlags` is used instead. - The field is still not exposed as a CLI flag. We might consider some way to ensure the right RTS / libraries are used before doing that. Original reviewers: Original subscribers: TerrorJack, rwbarton, carter Original Differential Revision: https://phabricator.haskell.org/D5082 --- compiler/ghc.mk | 8 -- compiler/ghci/ByteCodeItbls.hs | 4 +- compiler/utils/Util.hs | 8 -- hadrian/src/Settings/Packages.hs | 4 - .../ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc | 4 +- libraries/ghci/GHCi/InfoTable.hsc | 138 ++++++++++----------- libraries/ghci/GHCi/Message.hs | 7 +- libraries/ghci/GHCi/Run.hs | 4 +- testsuite/tests/codeGen/should_compile/jmp_tbl.hs | 2 +- 9 files changed, 79 insertions(+), 100 deletions(-) diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 70765011b8..6e1d7ca761 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -272,14 +272,6 @@ endif ifeq "$(GhcWithInterpreter)" "YES" compiler_stage2_CONFIGURE_OPTS += --flags=ghci -ifeq "$(TablesNextToCode)" "YES" -# 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 diff --git a/compiler/ghci/ByteCodeItbls.hs b/compiler/ghci/ByteCodeItbls.hs index 7381c8f926..c17f213365 100644 --- a/compiler/ghci/ByteCodeItbls.hs +++ b/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) diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs index aa4afa5451..4a2fdc586b 100644 --- a/compiler/utils/Util.hs +++ b/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 @@ -205,13 +204,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 diff --git a/hadrian/src/Settings/Packages.hs b/hadrian/src/Settings/Packages.hs index 22cc4f86f2..ea32971e1e 100644 --- a/hadrian/src/Settings/Packages.hs +++ b/hadrian/src/Settings/Packages.hs @@ -61,10 +61,6 @@ packageArgs = do , notM ghcWithSMP ? arg "--ghc-option=-optc-DNOSMP" , (any (wayUnit Threaded) rtsWays) ? notStage0 ? arg "--ghc-option=-optc-DTHREADED_RTS" - , ghcWithInterpreter ? - flag TablesNextToCode ? - notM (flag GhcUnregisterised) ? - notStage0 ? arg "--ghc-option=-DGHCI_TABLES_NEXT_TO_CODE" , ghcWithInterpreter ? ghciWithDebugger <$> flavour ? notStage0 ? arg "--ghc-option=-DDEBUGGER" 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 ())) -- -- 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 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) diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs index 319eebdfc0..6654ee6b84 100644 --- a/libraries/ghci/GHCi/Message.hs +++ b/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 diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs index a931e620cc..76f56019b2 100644 --- a/libraries/ghci/GHCi/Run.hs +++ b/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 diff --git a/testsuite/tests/codeGen/should_compile/jmp_tbl.hs b/testsuite/tests/codeGen/should_compile/jmp_tbl.hs index 5274ff29f3..c7211b0ebd 100644 --- a/testsuite/tests/codeGen/should_compile/jmp_tbl.hs +++ b/testsuite/tests/codeGen/should_compile/jmp_tbl.hs @@ -4,7 +4,7 @@ This funny module was reduced from a failing build of stage2 using the new code generator and the linear register allocator, with this bug: -"inplace/bin/ghc-stage1" -fPIC -dynamic -H32m -O -Wall -H64m -O0 -package-name ghc-7.1.20110414 -hide-all-packages -i -icompiler/basicTypes -icompiler/cmm -icompiler/codeGen -icompiler/coreSyn -icompiler/deSugar -icompiler/ghci -icompiler/hsSyn -icompiler/iface -icompiler/llvmGen -icompiler/main -icompiler/nativeGen -icompiler/parser -icompiler/prelude -icompiler/profiling -icompiler/rename -icompiler/simplCore -icompiler/simplStg -icompiler/specialise -icompiler/stgSyn -icompiler/stranal -icompiler/typecheck -icompiler/types -icompiler/utils -icompiler/vectorise -icompiler/stage2/build -icompiler/stage2/build/autogen -Icompiler/stage2/build -Icompiler/stage2/build/autogen -Icompiler/../libffi/build/include -Icompiler/stage2 -Icompiler/../libraries/base/cbits -Icompiler/../libraries/base/include -Icompiler/. -Icompiler/parser -Icompiler/utils -optP-DHAVE_INTERNAL_INTERPRETER -optP-include -optPcompiler/stage2/build/autogen/cabal_macros.h -package Cabal-1.11.0 -package array-0.3.0.2 -package base-4.3.1.0 -package ghc-boot-0.0.0.0 -package bytestring-0.9.1.10 -package containers-0.4.0.0 -package directory-1.1.0.0 -package filepath-1.2.0.0 -package hoopl-3.8.7.0 -package hpc-0.5.0.6 -package old-time-1.0.0.6 -package process-1.0.1.4 -package template-haskell-2.5.0.0 -package unix-2.4.1.0 -Wall -fno-warn-name-shadowing -fno-warn-orphans -XHaskell98 -XNondecreasingIndentation -XCPP -XMagicHash -XUnboxedTuples -XPatternGuards -XForeignFunctionInterface -XEmptyDataDecls -XTypeSynonymInstances -XMultiParamTypeClasses -XFlexibleInstances -XRank2Types -XScopedTypeVariables -XDeriveDataTypeable -DGHCI_TABLES_NEXT_TO_CODE -DSTAGE=2 -O2 -O -DGHC_DEFAULT_NEW_CODEGEN -no-user-package-db -rtsopts -odir compiler/stage2/build -hidir compiler/stage2/build -stubdir compiler/stage2/build -hisuf dyn_hi -osuf dyn_o -hcsuf dyn_hc -c compiler/main/DriverPipeline.hs -o compiler/stage2/build/DriverPipeline.dyn_o -fforce-recomp -dno-debug-output -fno-warn-unused-binds +"inplace/bin/ghc-stage1" -fPIC -dynamic -H32m -O -Wall -H64m -O0 -package-name ghc-7.1.20110414 -hide-all-packages -i -icompiler/basicTypes -icompiler/cmm -icompiler/codeGen -icompiler/coreSyn -icompiler/deSugar -icompiler/ghci -icompiler/hsSyn -icompiler/iface -icompiler/llvmGen -icompiler/main -icompiler/nativeGen -icompiler/parser -icompiler/prelude -icompiler/profiling -icompiler/rename -icompiler/simplCore -icompiler/simplStg -icompiler/specialise -icompiler/stgSyn -icompiler/stranal -icompiler/typecheck -icompiler/types -icompiler/utils -icompiler/vectorise -icompiler/stage2/build -icompiler/stage2/build/autogen -Icompiler/stage2/build -Icompiler/stage2/build/autogen -Icompiler/../libffi/build/include -Icompiler/stage2 -Icompiler/../libraries/base/cbits -Icompiler/../libraries/base/include -Icompiler/. -Icompiler/parser -Icompiler/utils -optP-DHAVE_INTERNAL_INTERPRETER -optP-include -optPcompiler/stage2/build/autogen/cabal_macros.h -package Cabal-1.11.0 -package array-0.3.0.2 -package base-4.3.1.0 -package ghc-boot-0.0.0.0 -package bytestring-0.9.1.10 -package containers-0.4.0.0 -package directory-1.1.0.0 -package filepath-1.2.0.0 -package hoopl-3.8.7.0 -package hpc-0.5.0.6 -package old-time-1.0.0.6 -package process-1.0.1.4 -package template-haskell-2.5.0.0 -package unix-2.4.1.0 -Wall -fno-warn-name-shadowing -fno-warn-orphans -XHaskell98 -XNondecreasingIndentation -XCPP -XMagicHash -XUnboxedTuples -XPatternGuards -XForeignFunctionInterface -XEmptyDataDecls -XTypeSynonymInstances -XMultiParamTypeClasses -XFlexibleInstances -XRank2Types -XScopedTypeVariables -XDeriveDataTypeable -DSTAGE=2 -O2 -O -DGHC_DEFAULT_NEW_CODEGEN -no-user-package-db -rtsopts -odir compiler/stage2/build -hidir compiler/stage2/build -stubdir compiler/stage2/build -hisuf dyn_hi -osuf dyn_o -hcsuf dyn_hc -c compiler/main/DriverPipeline.hs -o compiler/stage2/build/DriverPipeline.dyn_o -fforce-recomp -dno-debug-output -fno-warn-unused-binds ghc-stage1: panic! (the 'impossible' happened) (GHC version 7.1.20110414 for x86_64-unknown-linux): -- cgit v1.2.1