summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/main/DynFlags.hs30
-rw-r--r--compiler/main/DynFlags.hs-boot2
-rw-r--r--compiler/main/GHC.hs2
-rw-r--r--compiler/main/StaticFlags.hs21
-rw-r--r--compiler/utils/Outputable.lhs8
5 files changed, 33 insertions, 30 deletions
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index ccaf814dbf..9639e2e7c7 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -114,8 +114,6 @@ module DynFlags (
-- exposes the appropriate runtime boolean
rtsIsProfiled,
#endif
- -- ** Only for use in the tracing functions in Outputable
- tracingDynFlags,
#include "../includes/dist-derivedconstants/header/GHCConstantsHaskellExports.hs"
bLOCK_SIZE_W,
@@ -137,8 +135,10 @@ import Config
import CmdLineParser
import Constants
import Panic
+import StaticFlags
import Util
import Maybes ( orElse )
+import MonadUtils
import qualified Pretty
import SrcLoc
import FastString
@@ -1186,24 +1186,6 @@ defaultDynFlags mySettings =
}
--------------------------------------------------------------------------
--- Do not use tracingDynFlags!
--- tracingDynFlags 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. It will not reflect options set
--- by the commandline flags, and all fields may be either wrong or
--- undefined.
-tracingDynFlags :: DynFlags
-tracingDynFlags = defaultDynFlags tracingSettings
-
-tracingSettings :: Settings
-tracingSettings = trace "panic: Settings not defined in tracingDynFlags" $
- Settings { sTargetPlatform = tracingPlatform }
- -- Missing flags give a nice error
-
-tracingPlatform :: Platform
-tracingPlatform = Platform { platformWordSize = 4, platformOS = OSUnknown }
- -- Missing flags give a nice error
---------------------------------------------------------------------------
type FatalMessager = String -> IO ()
type LogAction = DynFlags -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
@@ -1604,7 +1586,7 @@ getStgToDo dflags
-- the parsed 'DynFlags', the left-over arguments, and a list of warnings.
-- Throws a 'UsageError' if errors occurred during parsing (such as unknown
-- flags or missing arguments).
-parseDynamicFlagsCmdLine :: Monad m => DynFlags -> [Located String]
+parseDynamicFlagsCmdLine :: MonadIO m => DynFlags -> [Located String]
-> m (DynFlags, [Located String], [Located String])
-- ^ Updated 'DynFlags', left-over arguments, and
-- list of warnings.
@@ -1614,7 +1596,7 @@ parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True
-- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags
-- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-db).
-- Used to parse flags set in a modules pragma.
-parseDynamicFilePragma :: Monad m => DynFlags -> [Located String]
+parseDynamicFilePragma :: MonadIO m => DynFlags -> [Located String]
-> m (DynFlags, [Located String], [Located String])
-- ^ Updated 'DynFlags', left-over arguments, and
-- list of warnings.
@@ -1625,7 +1607,7 @@ parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False
-- the dynamic flag parser that the other methods simply wrap. It allows
-- saying which flags are valid flags and indicating if we are parsing
-- arguments from the command line or from a file pragma.
-parseDynamicFlagsFull :: Monad m
+parseDynamicFlagsFull :: MonadIO m
=> [Flag (CmdLineP DynFlags)] -- ^ valid flags to match against
-> Bool -- ^ are the arguments from the command line?
-> DynFlags -- ^ current dynamic flags
@@ -1665,6 +1647,8 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
let (dflags4, consistency_warnings) = makeDynFlagsConsistent dflags3
+ liftIO $ setUnsafeGlobalDynFlags dflags4
+
return (dflags4, leftover, consistency_warnings ++ sh_warns ++ warns)
diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot
index 9f14d41600..9f22439661 100644
--- a/compiler/main/DynFlags.hs-boot
+++ b/compiler/main/DynFlags.hs-boot
@@ -5,8 +5,6 @@ import Platform
data DynFlags
-tracingDynFlags :: DynFlags
-
targetPlatform :: DynFlags -> Platform
pprUserLength :: DynFlags -> Int
pprCols :: DynFlags -> Int
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 06b3ecaf23..b1729ecb2d 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -524,7 +524,7 @@ getInteractiveDynFlags :: GhcMonad m => m DynFlags
getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h))
-parseDynamicFlags :: Monad m =>
+parseDynamicFlags :: MonadIO m =>
DynFlags -> [Located String]
-> m (DynFlags, [Located String], [Located String])
parseDynamicFlags = parseDynamicFlagsCmdLine
diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs
index fa4b61e287..68954a87e0 100644
--- a/compiler/main/StaticFlags.hs
+++ b/compiler/main/StaticFlags.hs
@@ -20,6 +20,8 @@
-----------------------------------------------------------------------------
module StaticFlags (
+ unsafeGlobalDynFlags, setUnsafeGlobalDynFlags,
+
staticFlags,
initStaticOpts,
@@ -70,6 +72,8 @@ module StaticFlags (
#include "HsVersions.h"
+import {-# SOURCE #-} DynFlags (DynFlags)
+
import FastString
import Util
import Maybes ( firstJusts )
@@ -80,6 +84,23 @@ import Data.IORef
import System.IO.Unsafe ( unsafePerformIO )
import Data.List
+--------------------------------------------------------------------------
+-- 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!
+
+GLOBAL_VAR(v_unsafeGlobalDynFlags, panic "v_unsafeGlobalDynFlags: not initialised", DynFlags)
+
+unsafeGlobalDynFlags :: DynFlags
+unsafeGlobalDynFlags = unsafePerformIO $ readIORef v_unsafeGlobalDynFlags
+
+setUnsafeGlobalDynFlags :: DynFlags -> IO ()
+setUnsafeGlobalDynFlags = writeIORef v_unsafeGlobalDynFlags
+
-----------------------------------------------------------------------------
-- Static flags
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index 09cf6e84ec..7e5c180d1b 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -70,7 +70,7 @@ module Outputable (
pprDebugAndThen,
) where
-import {-# SOURCE #-} DynFlags( DynFlags, tracingDynFlags,
+import {-# SOURCE #-} DynFlags( DynFlags,
targetPlatform, pprUserLength, pprCols )
import {-# SOURCE #-} Module( Module, ModuleName, moduleName )
import {-# SOURCE #-} Name( Name, nameModule )
@@ -914,7 +914,7 @@ pprTrace :: String -> SDoc -> a -> a
-- ^ If debug output is on, show some 'SDoc' on the screen
pprTrace str doc x
| opt_NoDebugOutput = x
- | otherwise = pprDebugAndThen tracingDynFlags trace str doc x
+ | otherwise = pprDebugAndThen unsafeGlobalDynFlags trace str doc x
pprPanicFastInt :: String -> SDoc -> FastInt
-- ^ Specialization of pprPanic that can be safely used with 'FastInt'
@@ -927,9 +927,9 @@ warnPprTrace _ _ _ _ x | not debugIsOn = x
warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x
warnPprTrace False _file _line _msg x = x
warnPprTrace True file line msg x
- = pprDebugAndThen tracingDynFlags trace str msg x
+ = pprDebugAndThen unsafeGlobalDynFlags trace str msg x
where
- str = showSDoc tracingDynFlags (hsep [text "WARNING: file", text file <> comma, text "line", int line])
+ str = showSDoc unsafeGlobalDynFlags (hsep [text "WARNING: file", text file <> comma, text "line", int line])
assertPprPanic :: String -> Int -> SDoc -> a
-- ^ Panic with an assertation failure, recording the given file and line number.
View Lorry Controller Status