Commit f7cd14fd authored by ian@well-typed.com's avatar ian@well-typed.com

Put the DynFlags in a global variable for tracing; fixes #7304

This is an ugly kludge to make a DynFlags value available for the
'trace' functions. It may not be the value we really ought to use,
but it'll be good enough for the pretty-printer to use.

Ideally we'd pass the real DynFlags down to all the trace calls,
but this will do for now at least.
parent a94144b8
......@@ -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)
......
......@@ -5,8 +5,6 @@ import Platform
data DynFlags
tracingDynFlags :: DynFlags
targetPlatform :: DynFlags -> Platform
pprUserLength :: DynFlags -> Int
pprCols :: DynFlags -> Int
......
......@@ -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
......
......@@ -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
......
......@@ -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.
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment