summaryrefslogtreecommitdiff
path: root/compiler/GHC/Driver
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Driver')
-rw-r--r--compiler/GHC/Driver/Ppr.hs30
-rw-r--r--compiler/GHC/Driver/Session.hs49
-rw-r--r--compiler/GHC/Driver/Session.hs-boot1
3 files changed, 24 insertions, 56 deletions
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
View Lorry Controller Status