diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2020-09-24 16:10:16 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-09-30 02:49:41 -0400 |
commit | df3f58807580bc2762086e063e3823b05de6fd64 (patch) | |
tree | 1c59f841d9eb351c20b1abe76e7db82634cc8056 | |
parent | 6527fc57b8e099703f5bdb5ec7f1dfd421651972 (diff) | |
download | haskell-df3f58807580bc2762086e063e3823b05de6fd64.tar.gz |
Remove unsafeGlobalDynFlags (#17957, #14597)
There are still global variables but only 3 booleans instead of a single
DynFlags.
-rw-r--r-- | compiler/GHC/Core/Unfold.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Driver/Ppr.hs | 30 | ||||
-rw-r--r-- | compiler/GHC/Driver/Session.hs | 49 | ||||
-rw-r--r-- | compiler/GHC/Driver/Session.hs-boot | 1 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Bind.hs | 11 | ||||
-rw-r--r-- | compiler/GHC/Types/Id.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Utils/Error.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Utils/GlobalVars.hs | 112 | ||||
-rw-r--r-- | compiler/GHC/Utils/Misc.hs | 48 | ||||
-rw-r--r-- | compiler/GHC/Utils/Panic.hs | 20 | ||||
-rw-r--r-- | compiler/HsVersions.h | 8 | ||||
-rw-r--r-- | compiler/ghc.cabal.in | 1 | ||||
-rw-r--r-- | includes/rts/Globals.h | 4 | ||||
-rw-r--r-- | rts/Globals.c | 8 | ||||
-rw-r--r-- | rts/RtsSymbols.c | 4 | ||||
-rw-r--r-- | testsuite/tests/plugins/LinkerTicklingPlugin.hs | 13 | ||||
-rw-r--r-- | testsuite/tests/plugins/all.T | 2 |
17 files changed, 186 insertions, 140 deletions
diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs index 2e1b1f6d61..89e4580351 100644 --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -1156,7 +1156,8 @@ tryUnfolding dflags id lone_variable , extra_doc , text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"] - str = "Considering inlining: " ++ showSDocDump dflags (ppr id) + ctx = initSDocContext dflags defaultDumpStyle + str = "Considering inlining: " ++ showSDocDump ctx (ppr id) n_val_args = length arg_infos -- some_benefit is used when the RHS is small enough diff --git a/compiler/GHC/Driver/Ppr.hs b/compiler/GHC/Driver/Ppr.hs index 5920acc959..2ea371f223 100644 --- a/compiler/GHC/Driver/Ppr.hs +++ b/compiler/GHC/Driver/Ppr.hs @@ -29,6 +29,7 @@ import GHC.Utils.Exception import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.GlobalVars import GHC.Utils.Ppr ( Mode(..) ) import {-# SOURCE #-} GHC.Unit.State @@ -43,7 +44,7 @@ showPpr :: Outputable a => DynFlags -> a -> String showPpr dflags thing = showSDoc dflags (ppr thing) showPprUnsafe :: Outputable a => a -> String -showPprUnsafe a = showPpr unsafeGlobalDynFlags a +showPprUnsafe a = renderWithContext defaultSDocContext (ppr a) -- | Allows caller to specify the PrintUnqualified to use showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String @@ -53,8 +54,8 @@ showSDocForUser dflags unqual doc = renderWithContext (initSDocContext dflags st unit_state = unitState dflags doc' = pprWithUnitState unit_state doc -showSDocDump :: DynFlags -> SDoc -> String -showSDocDump dflags d = renderWithContext (initSDocContext dflags defaultDumpStyle) d +showSDocDump :: SDocContext -> SDoc -> String +showSDocDump ctx d = renderWithContext ctx (withPprStyle defaultDumpStyle d) showSDocDebug :: DynFlags -> SDoc -> String showSDocDebug dflags d = renderWithContext ctx d @@ -75,9 +76,9 @@ printForC dflags handle doc = printSDocLn ctx LeftMode handle doc where ctx = initSDocContext dflags (PprCode CStyle) -pprDebugAndThen :: DynFlags -> (String -> a) -> SDoc -> SDoc -> a -pprDebugAndThen dflags cont heading pretty_msg - = cont (showSDocDump dflags doc) +pprDebugAndThen :: SDocContext -> (String -> a) -> SDoc -> SDoc -> a +pprDebugAndThen ctx cont heading pretty_msg + = cont (showSDocDump ctx doc) where doc = sep [heading, nest 2 pretty_msg] @@ -85,19 +86,22 @@ pprDebugAndThen dflags cont heading pretty_msg pprTraceWithFlags :: DynFlags -> String -> SDoc -> a -> a pprTraceWithFlags dflags str doc x | hasNoDebugOutput dflags = x - | otherwise = pprDebugAndThen dflags trace (text str) doc x + | otherwise = pprDebugAndThen (initSDocContext dflags defaultDumpStyle) + trace (text str) doc x -- | If debug output is on, show some 'SDoc' on the screen pprTrace :: String -> SDoc -> a -> a -pprTrace str doc x = pprTraceWithFlags unsafeGlobalDynFlags str doc x +pprTrace str doc x + | unsafeHasNoDebugOutput = x + | otherwise = pprDebugAndThen defaultSDocContext trace (text str) doc x pprTraceM :: Applicative f => String -> SDoc -> f () pprTraceM str doc = pprTrace str doc (pure ()) pprTraceDebug :: String -> SDoc -> a -> a pprTraceDebug str doc x - | debugIsOn && hasPprDebug unsafeGlobalDynFlags = pprTrace str doc x - | otherwise = x + | debugIsOn && unsafeHasPprDebug = pprTrace str doc x + | otherwise = x -- | @pprTraceWith desc f x@ is equivalent to @pprTrace desc (f x) x@. -- This allows you to print details from the returned value as well as from @@ -114,7 +118,7 @@ pprTraceIt desc x = pprTraceWith desc ppr x pprTraceException :: ExceptionMonad m => String -> SDoc -> m a -> m a pprTraceException heading doc = handleGhcException $ \exc -> liftIO $ do - putStrLn $ showSDocDump unsafeGlobalDynFlags (sep [text heading, nest 2 doc]) + putStrLn $ showSDocDump defaultSDocContext (sep [text heading, nest 2 doc]) throwGhcExceptionIO exc -- | If debug output is on, show some 'SDoc' on the screen along @@ -127,10 +131,10 @@ warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a -- Should typically be accessed with the WARN macros warnPprTrace _ _ _ _ x | not debugIsOn = x warnPprTrace _ _file _line _msg x - | hasNoDebugOutput unsafeGlobalDynFlags = x + | unsafeHasNoDebugOutput = x warnPprTrace False _file _line _msg x = x warnPprTrace True file line msg x - = pprDebugAndThen unsafeGlobalDynFlags trace heading + = pprDebugAndThen defaultSDocContext trace heading (msg $$ callStackDoc ) x where diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 2e37d5847d..a5df52d2b2 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -15,8 +15,6 @@ -- ------------------------------------------------------------------------------- -{-# OPTIONS_GHC -fno-cse #-} --- -fno-cse is needed for GLOBAL_VAR's to behave properly {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Driver.Session ( @@ -199,7 +197,7 @@ module GHC.Driver.Session ( wordAlignment, - unsafeGlobalDynFlags, setUnsafeGlobalDynFlags, + setUnsafeGlobalDynFlags, -- * SSE and AVX isSseEnabled, @@ -256,6 +254,7 @@ import GHC.Settings.Constants import GHC.Utils.Panic import qualified GHC.Utils.Ppr.Colour as Col import GHC.Utils.Misc +import GHC.Utils.GlobalVars import GHC.Data.Maybe import GHC.Utils.Monad import qualified GHC.Utils.Ppr as Pretty @@ -275,7 +274,6 @@ import GHC.Utils.Json import GHC.SysTools.Terminal ( stderrSupportsAnsiColors ) import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir ) -import System.IO.Unsafe ( unsafePerformIO ) import Data.IORef import Control.Arrow ((&&&)) import Control.Monad @@ -305,11 +303,6 @@ import qualified GHC.Data.EnumSet as EnumSet import GHC.Foreign (withCString, peekCString) import qualified GHC.LanguageExtensions as LangExt -#if GHC_STAGE >= 2 --- used by SHARED_GLOBAL_VAR -import Foreign (Ptr) -#endif - -- Note [Updating flag description in the User's Guide] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- @@ -4892,40 +4885,12 @@ makeDynFlagsConsistent dflags os = platformOS platform --------------------------------------------------------------------------- --- Do not use unsafeGlobalDynFlags! --- --- unsafeGlobalDynFlags is a hack, necessary because we need to be able --- to show SDocs when tracing, but we don't always have DynFlags --- available. --- --- Do not use it if you can help it. You may get the wrong value, or this --- panic! - --- | This is the value that 'unsafeGlobalDynFlags' takes before it is --- initialized. -defaultGlobalDynFlags :: DynFlags -defaultGlobalDynFlags = - (defaultDynFlags settings llvmConfig) { verbosity = 2 } - where - settings = panic "v_unsafeGlobalDynFlags: settings not initialised" - llvmConfig = panic "v_unsafeGlobalDynFlags: llvmConfig not initialised" - -#if GHC_STAGE < 2 -GLOBAL_VAR(v_unsafeGlobalDynFlags, defaultGlobalDynFlags, DynFlags) -#else -SHARED_GLOBAL_VAR( v_unsafeGlobalDynFlags - , getOrSetLibHSghcGlobalDynFlags - , "getOrSetLibHSghcGlobalDynFlags" - , defaultGlobalDynFlags - , DynFlags ) -#endif - -unsafeGlobalDynFlags :: DynFlags -unsafeGlobalDynFlags = unsafePerformIO $ readIORef v_unsafeGlobalDynFlags - setUnsafeGlobalDynFlags :: DynFlags -> IO () -setUnsafeGlobalDynFlags = writeIORef v_unsafeGlobalDynFlags +setUnsafeGlobalDynFlags dflags = do + writeIORef v_unsafeHasPprDebug (hasPprDebug dflags) + writeIORef v_unsafeHasNoDebugOutput (hasNoDebugOutput dflags) + writeIORef v_unsafeHasNoStateHack (hasNoStateHack dflags) + -- ----------------------------------------------------------------------------- -- SSE and AVX diff --git a/compiler/GHC/Driver/Session.hs-boot b/compiler/GHC/Driver/Session.hs-boot index 41daf4d3b2..2550782d37 100644 --- a/compiler/GHC/Driver/Session.hs-boot +++ b/compiler/GHC/Driver/Session.hs-boot @@ -9,7 +9,6 @@ data DynFlags targetPlatform :: DynFlags -> Platform unitState :: DynFlags -> UnitState -unsafeGlobalDynFlags :: DynFlags hasPprDebug :: DynFlags -> Bool hasNoDebugOutput :: DynFlags -> Bool initSDocContext :: DynFlags -> PprStyle -> SDocContext diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs index dbb32aa0d5..ca39b7b362 100644 --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -755,14 +755,15 @@ link_caf node = do -- name of the data constructor itself. Otherwise it is determined by -- @closureDescription@ from the let binding information. -closureDescription :: DynFlags - -> Module -- Module - -> Name -- Id of closure binding - -> String +closureDescription + :: DynFlags + -> Module -- Module + -> Name -- Id of closure binding + -> String -- Not called for StgRhsCon which have global info tables built in -- CgConTbls.hs with a description generated from the data constructor closureDescription dflags mod_name name - = showSDocDump dflags (char '<' <> + = showSDocDump (initSDocContext dflags defaultDumpStyle) (char '<' <> (if isExternalName name then ppr name -- ppr will include the module name prefix else pprModule mod_name <> char '.' <> ppr name) <> diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs index 2d6198dd64..2a45bd3389 100644 --- a/compiler/GHC/Types/Id.hs +++ b/compiler/GHC/Types/Id.hs @@ -123,7 +123,6 @@ module GHC.Types.Id ( import GHC.Prelude -import GHC.Driver.Session import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding, isCompulsoryUnfolding, Unfolding( NoUnfolding ) ) @@ -161,6 +160,7 @@ import GHC.Core.Multiplicity import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.GlobalVars import GHC.Driver.Ppr @@ -843,7 +843,7 @@ typeOneShot ty isStateHackType :: Type -> Bool isStateHackType ty - | hasNoStateHack unsafeGlobalDynFlags + | unsafeHasNoStateHack = False | otherwise = case tyConAppTyCon_maybe ty of diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs index 654c4b91a9..bad8a8b092 100644 --- a/compiler/GHC/Utils/Error.hs +++ b/compiler/GHC/Utils/Error.hs @@ -820,13 +820,15 @@ prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a prettyPrintGhcErrors dflags = MC.handle $ \e -> case e of PprPanic str doc -> - pprDebugAndThen dflags panic (text str) doc + pprDebugAndThen ctx panic (text str) doc PprSorry str doc -> - pprDebugAndThen dflags sorry (text str) doc + pprDebugAndThen ctx sorry (text str) doc PprProgramError str doc -> - pprDebugAndThen dflags pgmError (text str) doc + pprDebugAndThen ctx pgmError (text str) doc _ -> liftIO $ throwIO e + where + ctx = initSDocContext dflags defaultUserStyle -- | Checks if given 'WarnMsg' is a fatal warning. isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag) diff --git a/compiler/GHC/Utils/GlobalVars.hs b/compiler/GHC/Utils/GlobalVars.hs new file mode 100644 index 0000000000..5556a7e4f1 --- /dev/null +++ b/compiler/GHC/Utils/GlobalVars.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly + +module GHC.Utils.GlobalVars + ( v_unsafeHasPprDebug + , v_unsafeHasNoDebugOutput + , v_unsafeHasNoStateHack + , unsafeHasPprDebug + , unsafeHasNoDebugOutput + , unsafeHasNoStateHack + + , global + , consIORef + , globalM + , sharedGlobal + , sharedGlobalM + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Conc.Sync ( sharedCAF ) + +import System.IO.Unsafe +import Data.IORef +import Foreign (Ptr) + + +-------------------------------------------------------------------------- +-- Do not use global variables! +-- +-- Global variables are a hack. Do not use them if you can help it. + +#if GHC_STAGE < 2 + +GLOBAL_VAR(v_unsafeHasPprDebug, False, Bool) +GLOBAL_VAR(v_unsafeHasNoDebugOutput, False, Bool) +GLOBAL_VAR(v_unsafeHasNoStateHack, False, Bool) + +#else +SHARED_GLOBAL_VAR( v_unsafeHasPprDebug + , getOrSetLibHSghcGlobalHasPprDebug + , "getOrSetLibHSghcGlobalHasPprDebug" + , False + , Bool ) +SHARED_GLOBAL_VAR( v_unsafeHasNoDebugOutput + , getOrSetLibHSghcGlobalHasNoDebugOutput + , "getOrSetLibHSghcGlobalHasNoDebugOutput" + , False + , Bool ) +SHARED_GLOBAL_VAR( v_unsafeHasNoStateHack + , getOrSetLibHSghcGlobalHasNoStateHack + , "getOrSetLibHSghcGlobalHasNoStateHack" + , False + , Bool ) +#endif + +unsafeHasPprDebug :: Bool +unsafeHasPprDebug = unsafePerformIO $ readIORef v_unsafeHasPprDebug + +unsafeHasNoDebugOutput :: Bool +unsafeHasNoDebugOutput = unsafePerformIO $ readIORef v_unsafeHasNoDebugOutput + +unsafeHasNoStateHack :: Bool +unsafeHasNoStateHack = unsafePerformIO $ readIORef v_unsafeHasNoStateHack + +{- +************************************************************************ +* * + Globals and the RTS +* * +************************************************************************ + +When a plugin is loaded, it currently gets linked against a *newly +loaded* copy of the GHC package. This would not be a problem, except +that the new copy has its own mutable state that is not shared with +that state that has already been initialized by the original GHC +package. + +(Note that if the GHC executable was dynamically linked this +wouldn't be a problem, because we could share the GHC library it +links to; this is only a problem if DYNAMIC_GHC_PROGRAMS=NO.) + +The solution is to make use of @sharedCAF@ through @sharedGlobal@ +for globals that are shared between multiple copies of ghc packages. +-} + +-- Global variables: + +global :: a -> IORef a +global a = unsafePerformIO (newIORef a) + +consIORef :: IORef [a] -> a -> IO () +consIORef var x = do + atomicModifyIORef' var (\xs -> (x:xs,())) + +globalM :: IO a -> IORef a +globalM ma = unsafePerformIO (ma >>= newIORef) + +-- Shared global variables: + +sharedGlobal :: a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a +sharedGlobal a get_or_set = unsafePerformIO $ + newIORef a >>= flip sharedCAF get_or_set + +sharedGlobalM :: IO a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a +sharedGlobalM ma get_or_set = unsafePerformIO $ + ma >>= newIORef >>= flip sharedCAF get_or_set diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs index 522ec3f007..7436487739 100644 --- a/compiler/GHC/Utils/Misc.hs +++ b/compiler/GHC/Utils/Misc.hs @@ -107,9 +107,6 @@ module GHC.Utils.Misc ( modificationTimeIfExists, withAtomicRename, - global, consIORef, globalM, - sharedGlobal, sharedGlobalM, - -- * Filenames and paths Suffix, splitLongestPrefix, @@ -143,8 +140,6 @@ import GHC.Utils.Exception import GHC.Utils.Panic.Plain import Data.Data -import Data.IORef ( IORef, newIORef, atomicModifyIORef' ) -import System.IO.Unsafe ( unsafePerformIO ) import Data.List hiding (group) import Data.List.NonEmpty ( NonEmpty(..) ) @@ -154,7 +149,6 @@ import GHC.Stack (HasCallStack) import Control.Applicative ( liftA2 ) import Control.Monad ( liftM, guard ) import Control.Monad.IO.Class ( MonadIO, liftIO ) -import GHC.Conc.Sync ( sharedCAF ) import System.IO.Error as IO ( isDoesNotExistError ) import System.Directory ( doesDirectoryExist, getModificationTime, renameFile ) import System.FilePath @@ -1070,48 +1064,6 @@ strictMap f (x : xs) = in x' : xs' -{- -************************************************************************ -* * - Globals and the RTS -* * -************************************************************************ - -When a plugin is loaded, it currently gets linked against a *newly -loaded* copy of the GHC package. This would not be a problem, except -that the new copy has its own mutable state that is not shared with -that state that has already been initialized by the original GHC -package. - -(Note that if the GHC executable was dynamically linked this -wouldn't be a problem, because we could share the GHC library it -links to; this is only a problem if DYNAMIC_GHC_PROGRAMS=NO.) - -The solution is to make use of @sharedCAF@ through @sharedGlobal@ -for globals that are shared between multiple copies of ghc packages. --} - --- Global variables: - -global :: a -> IORef a -global a = unsafePerformIO (newIORef a) - -consIORef :: IORef [a] -> a -> IO () -consIORef var x = do - atomicModifyIORef' var (\xs -> (x:xs,())) - -globalM :: IO a -> IORef a -globalM ma = unsafePerformIO (ma >>= newIORef) - --- Shared global variables: - -sharedGlobal :: a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a -sharedGlobal a get_or_set = unsafePerformIO $ - newIORef a >>= flip sharedCAF get_or_set - -sharedGlobalM :: IO a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a -sharedGlobalM ma get_or_set = unsafePerformIO $ - ma >>= newIORef >>= flip sharedCAF get_or_set -- Module names: diff --git a/compiler/GHC/Utils/Panic.hs b/compiler/GHC/Utils/Panic.hs index 9f7d81abab..eba104e5b8 100644 --- a/compiler/GHC/Utils/Panic.hs +++ b/compiler/GHC/Utils/Panic.hs @@ -47,8 +47,6 @@ import GHC.Prelude import GHC.Stack import GHC.Utils.Outputable -import {-# SOURCE #-} GHC.Driver.Session (DynFlags, unsafeGlobalDynFlags) -import {-# SOURCE #-} GHC.Driver.Ppr (showSDoc) import GHC.Utils.Panic.Plain import GHC.Utils.Exception as Exception @@ -146,16 +144,14 @@ safeShowException e = do -- | Append a description of the given exception to this string. -- --- Note that this uses 'GHC.Driver.Session.unsafeGlobalDynFlags', which may have some --- uninitialized fields if invoked before 'GHC.initGhcMonad' has been called. --- If the error message to be printed includes a pretty-printer document --- which forces one of these fields this call may bottom. +-- Note that this uses 'defaultSDocContext', which doesn't use the options +-- set by the user via DynFlags. showGhcExceptionUnsafe :: GhcException -> ShowS -showGhcExceptionUnsafe = showGhcException unsafeGlobalDynFlags +showGhcExceptionUnsafe = showGhcException defaultSDocContext -- | Append a description of the given exception to this string. -showGhcException :: DynFlags -> GhcException -> ShowS -showGhcException dflags = showPlainGhcException . \case +showGhcException :: SDocContext -> GhcException -> ShowS +showGhcException ctx = showPlainGhcException . \case Signal n -> PlainSignal n UsageError str -> PlainUsageError str CmdLineError str -> PlainCmdLineError str @@ -165,11 +161,11 @@ showGhcException dflags = showPlainGhcException . \case ProgramError str -> PlainProgramError str PprPanic str sdoc -> PlainPanic $ - concat [str, "\n\n", showSDoc dflags sdoc] + concat [str, "\n\n", renderWithContext ctx sdoc] PprSorry str sdoc -> PlainProgramError $ - concat [str, "\n\n", showSDoc dflags sdoc] + concat [str, "\n\n", renderWithContext ctx sdoc] PprProgramError str sdoc -> PlainProgramError $ - concat [str, "\n\n", showSDoc dflags sdoc] + concat [str, "\n\n", renderWithContext ctx sdoc] throwGhcException :: GhcException -> a throwGhcException = Exception.throw diff --git a/compiler/HsVersions.h b/compiler/HsVersions.h index 3f9f28df21..e472b10002 100644 --- a/compiler/HsVersions.h +++ b/compiler/HsVersions.h @@ -15,25 +15,25 @@ you will screw up the layout where they are used in case expressions! #define GLOBAL_VAR(name,value,ty) \ {-# NOINLINE name #-}; \ name :: IORef (ty); \ -name = GHC.Utils.Misc.global (value); +name = GHC.Utils.GlobalVars.global (value); #define GLOBAL_VAR_M(name,value,ty) \ {-# NOINLINE name #-}; \ name :: IORef (ty); \ -name = GHC.Utils.Misc.globalM (value); +name = GHC.Utils.GlobalVars.globalM (value); #define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \ {-# NOINLINE name #-}; \ name :: IORef (ty); \ -name = GHC.Utils.Misc.sharedGlobal (value) (accessor); \ +name = GHC.Utils.GlobalVars.sharedGlobal (value) (accessor);\ foreign import ccall unsafe saccessor \ accessor :: Ptr (IORef a) -> IO (Ptr (IORef a)); #define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty) \ {-# NOINLINE name #-}; \ name :: IORef (ty); \ -name = GHC.Utils.Misc.sharedGlobalM (value) (accessor); \ +name = GHC.Utils.GlobalVars.sharedGlobalM (value) (accessor); \ foreign import ccall unsafe saccessor \ accessor :: Ptr (IORef a) -> IO (Ptr (IORef a)); diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index dbc5be050c..0266513a13 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -177,6 +177,7 @@ Library GHC.Types.Cpr GHC.Cmm.DebugBlock GHC.Utils.Exception + GHC.Utils.GlobalVars GHC.Types.FieldLabel GHC.Driver.Monad GHC.Driver.Hooks diff --git a/includes/rts/Globals.h b/includes/rts/Globals.h index ff36572c56..15d8e19f93 100644 --- a/includes/rts/Globals.h +++ b/includes/rts/Globals.h @@ -31,6 +31,8 @@ mkStoreAccessorPrototype(SystemTimerThreadIOManagerThreadStore) mkStoreAccessorPrototype(LibHSghcFastStringTable) mkStoreAccessorPrototype(LibHSghcPersistentLinkerState) mkStoreAccessorPrototype(LibHSghcInitLinkerDone) -mkStoreAccessorPrototype(LibHSghcGlobalDynFlags) +mkStoreAccessorPrototype(LibHSghcGlobalHasPprDebug) +mkStoreAccessorPrototype(LibHSghcGlobalHasNoDebugOutput) +mkStoreAccessorPrototype(LibHSghcGlobalHasNoStateHack) mkStoreAccessorPrototype(LibHSghcStaticOptions) mkStoreAccessorPrototype(LibHSghcStaticOptionsReady) diff --git a/rts/Globals.c b/rts/Globals.c index c9980d9a3a..4a8657dedc 100644 --- a/rts/Globals.c +++ b/rts/Globals.c @@ -35,7 +35,9 @@ typedef enum { LibHSghcFastStringTable, LibHSghcPersistentLinkerState, LibHSghcInitLinkerDone, - LibHSghcGlobalDynFlags, + LibHSghcGlobalHasPprDebug, + LibHSghcGlobalHasNoDebugOutput, + LibHSghcGlobalHasNoStateHack, LibHSghcStaticOptions, LibHSghcStaticOptionsReady, MaxStoreKey @@ -108,6 +110,8 @@ mkStoreAccessor(SystemTimerThreadIOManagerThreadStore) mkStoreAccessor(LibHSghcFastStringTable) mkStoreAccessor(LibHSghcPersistentLinkerState) mkStoreAccessor(LibHSghcInitLinkerDone) -mkStoreAccessor(LibHSghcGlobalDynFlags) +mkStoreAccessor(LibHSghcGlobalHasPprDebug) +mkStoreAccessor(LibHSghcGlobalHasNoDebugOutput) +mkStoreAccessor(LibHSghcGlobalHasNoStateHack) mkStoreAccessor(LibHSghcStaticOptions) mkStoreAccessor(LibHSghcStaticOptionsReady) diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c index d14bdbc662..e10cef6cad 100644 --- a/rts/RtsSymbols.c +++ b/rts/RtsSymbols.c @@ -644,7 +644,9 @@ SymI_HasProto(getRTSStatsEnabled) \ SymI_HasProto(getOrSetLibHSghcPersistentLinkerState) \ SymI_HasProto(getOrSetLibHSghcInitLinkerDone) \ - SymI_HasProto(getOrSetLibHSghcGlobalDynFlags) \ + SymI_HasProto(getOrSetLibHSghcGlobalHasPprDebug) \ + SymI_HasProto(getOrSetLibHSghcGlobalHasNoDebugOutput) \ + SymI_HasProto(getOrSetLibHSghcGlobalHasNoStateHack) \ SymI_HasProto(genericRaise) \ SymI_HasProto(getProgArgv) \ SymI_HasProto(getFullProgArgv) \ diff --git a/testsuite/tests/plugins/LinkerTicklingPlugin.hs b/testsuite/tests/plugins/LinkerTicklingPlugin.hs index 7b7fc12a62..34ff7e3c64 100644 --- a/testsuite/tests/plugins/LinkerTicklingPlugin.hs +++ b/testsuite/tests/plugins/LinkerTicklingPlugin.hs @@ -2,14 +2,19 @@ module LinkerTicklingPlugin where import GHC.Plugins import GHC.Driver.Session +import GHC.Utils.GlobalVars plugin :: Plugin -plugin = defaultPlugin { - installCoreToDos = install - } +plugin = defaultPlugin + { installCoreToDos = install + } -- This tests whether plugins are linking against the *running* GHC or a new -- instance of it. If it is a new instance (settings unsafeGlobalDynFlags) won't -- have been initialised, so we'll get a GHC panic here: install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] -install _options todos = settings unsafeGlobalDynFlags `seq` return todos +install _options todos = io `seq` return todos + where + io = if not unsafeHasPprDebug + then error "unsafePprDebug should be set: plugin linked against a different GHC?" + else () diff --git a/testsuite/tests/plugins/all.T b/testsuite/tests/plugins/all.T index 891246b228..e02681d7c0 100644 --- a/testsuite/tests/plugins/all.T +++ b/testsuite/tests/plugins/all.T @@ -44,7 +44,7 @@ test('plugins06', [extra_files(['LinkerTicklingPlugin.hs']), unless(have_dynamic(), skip), only_ways([config.ghc_plugin_way])], - multimod_compile_and_run, ['plugins06', '-package ghc']) + multimod_compile_and_run, ['plugins06', '-package ghc -dppr-debug']) test('plugins07', [extra_files(['rule-defining-plugin/']), |