summaryrefslogtreecommitdiff
path: root/compiler/GHC/Driver
diff options
context:
space:
mode:
authorSylvain Henry <sylvain@haskus.fr>2021-01-07 14:25:15 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-02-13 21:27:34 -0500
commit8e2f85f6b4662676f0d7addaff9bf2c7d751bb63 (patch)
tree6a5bea5db12d907874cdf26d709d829a3f3216ba /compiler/GHC/Driver
parent40983d2331fe34c0af6925db7588d5ac6a19ae36 (diff)
downloadhaskell-8e2f85f6b4662676f0d7addaff9bf2c7d751bb63.tar.gz
Refactor Logger
Before this patch, the only way to override GHC's default logging behavior was to set `log_action`, `dump_action` and `trace_action` fields in DynFlags. This patch introduces a new Logger abstraction and stores it in HscEnv instead. This is part of #17957 (avoid storing state in DynFlags). DynFlags are duplicated and updated per-module (because of OPTIONS_GHC pragma), so we shouldn't store global state in them. This patch also fixes a race in parallel "--make" mode which updated the `generatedDumps` IORef concurrently. Bump haddock submodule The increase in MultilayerModules is tracked in #19293. Metric Increase: MultiLayerModules
Diffstat (limited to 'compiler/GHC/Driver')
-rw-r--r--compiler/GHC/Driver/Backpack.hs29
-rw-r--r--compiler/GHC/Driver/CodeOutput.hs54
-rw-r--r--compiler/GHC/Driver/Env.hs3
-rw-r--r--compiler/GHC/Driver/Env/Types.hs8
-rw-r--r--compiler/GHC/Driver/Errors.hs19
-rw-r--r--compiler/GHC/Driver/Main.hs143
-rw-r--r--compiler/GHC/Driver/Make.hs162
-rw-r--r--compiler/GHC/Driver/MakeFile.hs33
-rw-r--r--compiler/GHC/Driver/Monad.hs62
-rw-r--r--compiler/GHC/Driver/Pipeline.hs225
-rw-r--r--compiler/GHC/Driver/Pipeline/Monad.hs4
-rw-r--r--compiler/GHC/Driver/Session.hs149
12 files changed, 438 insertions, 453 deletions
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index 0a1a2b8bf7..5974cded53 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -55,6 +55,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Error
+import GHC.Utils.Logger
import GHC.Unit
import GHC.Unit.Env
@@ -90,6 +91,8 @@ import qualified Data.Set as Set
-- | Entry point to compile a Backpack file.
doBackpack :: [FilePath] -> Ghc ()
doBackpack [src_filename] = do
+ logger <- getLogger
+
-- Apply options from file to dflags
dflags0 <- getDynFlags
let dflags1 = dflags0
@@ -98,7 +101,7 @@ doBackpack [src_filename] = do
modifySession (\hsc_env -> hsc_env {hsc_dflags = dflags})
-- Cribbed from: preprocessFile / GHC.Driver.Pipeline
liftIO $ checkProcessArgsResult unhandled_flags
- liftIO $ handleFlagWarnings dflags warns
+ liftIO $ handleFlagWarnings logger dflags warns
-- TODO: Preprocessing not implemented
buf <- liftIO $ hGetStringBuffer src_filename
@@ -413,6 +416,7 @@ compileExe lunit = do
addUnit :: GhcMonad m => UnitInfo -> m ()
addUnit u = do
hsc_env <- getSession
+ logger <- getLogger
newdbs <- case hsc_unit_dbs hsc_env of
Nothing -> panic "addUnit: called too early"
Just dbs ->
@@ -421,7 +425,7 @@ addUnit u = do
, unitDatabaseUnits = [u]
}
in return (dbs ++ [newdb]) -- added at the end because ordering matters
- (dbs,unit_state,home_unit) <- liftIO $ initUnits (hsc_dflags hsc_env) (Just newdbs)
+ (dbs,unit_state,home_unit) <- liftIO $ initUnits logger (hsc_dflags hsc_env) (Just newdbs)
let unit_env = UnitEnv
{ ue_platform = targetPlatform (hsc_dflags hsc_env)
, ue_namever = ghcNameVersion (hsc_dflags hsc_env)
@@ -473,6 +477,9 @@ data BkpEnv
-- TODO: just make a proper new monad for BkpM, rather than use IOEnv
instance {-# OVERLAPPING #-} HasDynFlags BkpM where
getDynFlags = fmap hsc_dflags getSession
+instance {-# OVERLAPPING #-} HasLogger BkpM where
+ getLogger = fmap hsc_logger getSession
+
instance GhcMonad BkpM where
getSession = do
@@ -526,9 +533,9 @@ initBkpM file bkp m =
-- | Print a compilation progress message, but with indentation according
-- to @level@ (for nested compilation).
-backpackProgressMsg :: Int -> DynFlags -> SDoc -> IO ()
-backpackProgressMsg level dflags msg =
- compilationProgressMsg dflags $ text (replicate (level * 2) ' ') -- TODO: use GHC.Utils.Ppr.RStr
+backpackProgressMsg :: Int -> Logger -> DynFlags -> SDoc -> IO ()
+backpackProgressMsg level logger dflags msg =
+ compilationProgressMsg logger dflags $ text (replicate (level * 2) ' ') -- TODO: use GHC.Utils.Ppr.RStr
<> msg
-- | Creates a 'Messager' for Backpack compilation; this is basically
@@ -539,9 +546,10 @@ mkBackpackMsg = do
level <- getBkpLevel
return $ \hsc_env mod_index recomp node ->
let dflags = hsc_dflags hsc_env
+ logger = hsc_logger hsc_env
state = hsc_units hsc_env
showMsg msg reason =
- backpackProgressMsg level dflags $ pprWithUnitState state $
+ backpackProgressMsg level logger dflags $ pprWithUnitState state $
showModuleIndex mod_index <>
msg <> showModMsg dflags (recompileRequired recomp) node
<> reason
@@ -575,18 +583,20 @@ backpackStyle =
msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM ()
msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do
dflags <- getDynFlags
+ logger <- getLogger
level <- getBkpLevel
- liftIO . backpackProgressMsg level dflags
+ liftIO . backpackProgressMsg level logger dflags
$ showModuleIndex (i, n) <> text "Processing " <> ftext fs_pn
-- | Message when we instantiate a Backpack unit.
msgUnitId :: Unit -> BkpM ()
msgUnitId pk = do
dflags <- getDynFlags
+ logger <- getLogger
hsc_env <- getSession
level <- getBkpLevel
let state = hsc_units hsc_env
- liftIO . backpackProgressMsg level dflags
+ liftIO . backpackProgressMsg level logger dflags
$ pprWithUnitState state
$ text "Instantiating "
<> withPprStyle backpackStyle (ppr pk)
@@ -595,10 +605,11 @@ msgUnitId pk = do
msgInclude :: (Int,Int) -> Unit -> BkpM ()
msgInclude (i,n) uid = do
dflags <- getDynFlags
+ logger <- getLogger
hsc_env <- getSession
level <- getBkpLevel
let state = hsc_units hsc_env
- liftIO . backpackProgressMsg level dflags
+ liftIO . backpackProgressMsg level logger dflags
$ pprWithUnitState state
$ showModuleIndex (i, n) <> text "Including "
<> withPprStyle backpackStyle (ppr uid)
diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs
index b251794f1a..fb6d04afbf 100644
--- a/compiler/GHC/Driver/CodeOutput.hs
+++ b/compiler/GHC/Driver/CodeOutput.hs
@@ -40,6 +40,7 @@ import GHC.SysTools.FileCleanup
import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Logger
import GHC.Unit
import GHC.Unit.State
@@ -63,7 +64,8 @@ import System.IO
************************************************************************
-}
-codeOutput :: DynFlags
+codeOutput :: Logger
+ -> DynFlags
-> UnitState
-> Module
-> FilePath
@@ -78,7 +80,7 @@ codeOutput :: DynFlags
[(ForeignSrcLang, FilePath)]{-foreign_fps-},
a)
-codeOutput dflags unit_state this_mod filenm location foreign_stubs foreign_fps pkg_deps
+codeOutput logger dflags unit_state this_mod filenm location foreign_stubs foreign_fps pkg_deps
cmm_stream
=
do {
@@ -88,29 +90,29 @@ codeOutput dflags unit_state this_mod filenm location foreign_stubs foreign_fps
then Stream.mapM do_lint cmm_stream
else cmm_stream
- do_lint cmm = withTimingSilent
+ do_lint cmm = withTimingSilent logger
dflags
(text "CmmLint"<+>brackets (ppr this_mod))
(const ()) $ do
{ case cmmLint (targetPlatform dflags) cmm of
- Just err -> do { log_action dflags
+ Just err -> do { putLogMsg logger
dflags
NoReason
SevDump
noSrcSpan
$ withPprStyle defaultDumpStyle err
- ; ghcExit dflags 1
+ ; ghcExit logger dflags 1
}
Nothing -> return ()
; return cmm
}
- ; stubs_exist <- outputForeignStubs dflags unit_state this_mod location foreign_stubs
+ ; stubs_exist <- outputForeignStubs logger dflags unit_state this_mod location foreign_stubs
; a <- case backend dflags of
- NCG -> outputAsm dflags this_mod location filenm
+ NCG -> outputAsm logger dflags this_mod location filenm
linted_cmm_stream
- ViaC -> outputC dflags filenm linted_cmm_stream pkg_deps
- LLVM -> outputLlvm dflags filenm linted_cmm_stream
+ ViaC -> outputC logger dflags filenm linted_cmm_stream pkg_deps
+ LLVM -> outputLlvm logger dflags filenm linted_cmm_stream
Interpreter -> panic "codeOutput: Interpreter"
NoBackend -> panic "codeOutput: NoBackend"
; return (filenm, stubs_exist, foreign_fps, a)
@@ -127,13 +129,14 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
************************************************************************
-}
-outputC :: DynFlags
+outputC :: Logger
+ -> DynFlags
-> FilePath
-> Stream IO RawCmmGroup a
-> [UnitId]
-> IO a
-outputC dflags filenm cmm_stream packages =
- withTiming dflags (text "C codegen") (\a -> seq a () {- FIXME -}) $ do
+outputC logger dflags filenm cmm_stream packages =
+ withTiming logger dflags (text "C codegen") (\a -> seq a () {- FIXME -}) $ do
let pkg_names = map unitIdString packages
doOutput filenm $ \ h -> do
hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
@@ -141,7 +144,7 @@ outputC dflags filenm cmm_stream packages =
let platform = targetPlatform dflags
writeC cmm = do
let doc = cmmToC platform cmm
- dumpIfSet_dyn dflags Opt_D_dump_c_backend
+ dumpIfSet_dyn logger dflags Opt_D_dump_c_backend
"C backend output"
FormatC
doc
@@ -156,18 +159,19 @@ outputC dflags filenm cmm_stream packages =
************************************************************************
-}
-outputAsm :: DynFlags
+outputAsm :: Logger
+ -> DynFlags
-> Module
-> ModLocation
-> FilePath
-> Stream IO RawCmmGroup a
-> IO a
-outputAsm dflags this_mod location filenm cmm_stream = do
+outputAsm logger dflags this_mod location filenm cmm_stream = do
ncg_uniqs <- mkSplitUniqSupply 'n'
- debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm)
+ debugTraceMsg logger dflags 4 (text "Outputing asm to" <+> text filenm)
{-# SCC "OutputAsm" #-} doOutput filenm $
\h -> {-# SCC "NativeCodeGen" #-}
- nativeCodeGen dflags this_mod location h ncg_uniqs cmm_stream
+ nativeCodeGen logger dflags this_mod location h ncg_uniqs cmm_stream
{-
************************************************************************
@@ -177,11 +181,11 @@ outputAsm dflags this_mod location filenm cmm_stream = do
************************************************************************
-}
-outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a
-outputLlvm dflags filenm cmm_stream =
+outputLlvm :: Logger -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a
+outputLlvm logger dflags filenm cmm_stream =
{-# SCC "llvm_output" #-} doOutput filenm $
\f -> {-# SCC "llvm_CodeGen" #-}
- llvmCodeGen dflags f cmm_stream
+ llvmCodeGen logger dflags f cmm_stream
{-
************************************************************************
@@ -191,13 +195,13 @@ outputLlvm dflags filenm cmm_stream =
************************************************************************
-}
-outputForeignStubs :: DynFlags -> UnitState -> Module -> ModLocation -> ForeignStubs
+outputForeignStubs :: Logger -> DynFlags -> UnitState -> Module -> ModLocation -> ForeignStubs
-> IO (Bool, -- Header file created
Maybe FilePath) -- C file created
-outputForeignStubs dflags unit_state mod location stubs
+outputForeignStubs logger dflags unit_state mod location stubs
= do
let stub_h = mkStubPaths dflags (moduleName mod) location
- stub_c <- newTempName dflags TFL_CurrentModule "c"
+ stub_c <- newTempName logger dflags TFL_CurrentModule "c"
case stubs of
NoStubs ->
@@ -214,7 +218,7 @@ outputForeignStubs dflags unit_state mod location stubs
createDirectoryIfMissing True (takeDirectory stub_h)
- dumpIfSet_dyn dflags Opt_D_dump_foreign
+ dumpIfSet_dyn logger dflags Opt_D_dump_foreign
"Foreign export header file"
FormatC
stub_h_output_d
@@ -234,7 +238,7 @@ outputForeignStubs dflags unit_state mod location stubs
<- outputForeignStubs_help stub_h stub_h_output_w
("#include <HsFFI.h>\n" ++ cplusplus_hdr) cplusplus_ftr
- dumpIfSet_dyn dflags Opt_D_dump_foreign
+ dumpIfSet_dyn logger dflags Opt_D_dump_foreign
"Foreign export stubs" FormatC stub_c_output_d
stub_c_file_exists
diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs
index 50c2b5caf6..8d9aa961fb 100644
--- a/compiler/GHC/Driver/Env.hs
+++ b/compiler/GHC/Driver/Env.hs
@@ -68,7 +68,7 @@ import Data.IORef
runHsc :: HscEnv -> Hsc a -> IO a
runHsc hsc_env (Hsc hsc) = do
(a, w) <- hsc hsc_env emptyBag
- printOrThrowWarnings (hsc_dflags hsc_env) w
+ printOrThrowWarnings (hsc_logger hsc_env) (hsc_dflags hsc_env) w
return a
-- | Switches in the DynFlags and Plugins from the InteractiveContext
@@ -285,4 +285,3 @@ lookupIfaceByModule hpt pit mod
mainModIs :: HscEnv -> Module
mainModIs hsc_env = mkHomeModule (hsc_home_unit hsc_env) (mainModuleNameIs (hsc_dflags hsc_env))
-
diff --git a/compiler/GHC/Driver/Env/Types.hs b/compiler/GHC/Driver/Env/Types.hs
index f4ded1381c..cbd63c27cb 100644
--- a/compiler/GHC/Driver/Env/Types.hs
+++ b/compiler/GHC/Driver/Env/Types.hs
@@ -20,6 +20,7 @@ import GHC.Unit.Module.Graph
import GHC.Unit.Env
import GHC.Unit.State
import GHC.Unit.Types
+import GHC.Utils.Logger
import {-# SOURCE #-} GHC.Driver.Plugins
import Control.Monad ( ap )
@@ -45,6 +46,10 @@ instance MonadIO Hsc where
instance HasDynFlags Hsc where
getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w)
+instance HasLogger Hsc where
+ getLogger = Hsc $ \e w -> return (hsc_logger e, w)
+
+
-- | HscEnv is like 'GHC.Driver.Monad.Session', except that some of the fields are immutable.
-- An HscEnv is used to compile a single module from plain Haskell source
-- code (after preprocessing) to either C, assembly or C--. It's also used
@@ -147,5 +152,8 @@ data HscEnv
--
-- Initialized from the databases cached in 'hsc_unit_dbs' and
-- from the DynFlags.
+
+ , hsc_logger :: !Logger
+ -- ^ Logger
}
diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs
index 43f3dc859b..d779fc06f8 100644
--- a/compiler/GHC/Driver/Errors.hs
+++ b/compiler/GHC/Driver/Errors.hs
@@ -15,6 +15,7 @@ import GHC.Prelude
import GHC.Types.SrcLoc
import GHC.Types.Error
import GHC.Utils.Outputable ( text, withPprStyle, mkErrStyle )
+import GHC.Utils.Logger
import qualified GHC.Driver.CmdLine as CmdLine
-- | Converts a list of 'WarningMessages' into a tuple where the second element contains only
@@ -28,11 +29,11 @@ warningsToMessages dflags =
Right warn{ errMsgSeverity = SevError
, errMsgReason = ErrReason err_reason }
-printBagOfErrors :: RenderableDiagnostic a => DynFlags -> Bag (MsgEnvelope a) -> IO ()
-printBagOfErrors dflags bag_of_errors
+printBagOfErrors :: RenderableDiagnostic a => Logger -> DynFlags -> Bag (MsgEnvelope a) -> IO ()
+printBagOfErrors logger dflags bag_of_errors
= sequence_ [ let style = mkErrStyle unqual
ctx = initSDocContext dflags style
- in putLogMsg dflags reason sev s $
+ in putLogMsg logger dflags reason sev s $
withPprStyle style (formatBulleted ctx (renderDiagnostic doc))
| MsgEnvelope { errMsgSpan = s,
errMsgDiagnostic = doc,
@@ -41,8 +42,8 @@ printBagOfErrors dflags bag_of_errors
errMsgContext = unqual } <- sortMsgBag (Just dflags)
bag_of_errors ]
-handleFlagWarnings :: DynFlags -> [CmdLine.Warn] -> IO ()
-handleFlagWarnings dflags warns = do
+handleFlagWarnings :: Logger -> DynFlags -> [CmdLine.Warn] -> IO ()
+handleFlagWarnings logger dflags warns = do
let warns' = filter (shouldPrintWarning dflags . CmdLine.warnReason) warns
-- It would be nicer if warns :: [Located SDoc], but that
@@ -50,7 +51,7 @@ handleFlagWarnings dflags warns = do
bag = listToBag [ mkPlainWarnMsg loc (text warn)
| CmdLine.Warn _ (L loc warn) <- warns' ]
- printOrThrowWarnings dflags bag
+ printOrThrowWarnings logger dflags bag
-- | Checks if given 'WarnMsg' is a fatal warning.
isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag)
@@ -74,8 +75,8 @@ shouldPrintWarning _ _
-- | Given a bag of warnings, turn them into an exception if
-- -Werror is enabled, or print them out otherwise.
-printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO ()
-printOrThrowWarnings dflags warns = do
+printOrThrowWarnings :: Logger -> DynFlags -> Bag WarnMsg -> IO ()
+printOrThrowWarnings logger dflags warns = do
let (make_error, warns') =
mapAccumBagL
(\make_err warn ->
@@ -89,4 +90,4 @@ printOrThrowWarnings dflags warns = do
False warns
if make_error
then throwIO (mkSrcErr warns')
- else printBagOfErrors dflags warns
+ else printBagOfErrors logger dflags warns
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 4f7dcbcaea..bbf7a3336c 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -203,6 +203,7 @@ import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Exception
import GHC.Utils.Misc
+import GHC.Utils.Logger
import GHC.Data.FastString
import GHC.Data.Bag
@@ -243,10 +244,12 @@ newHscEnv dflags = do
nc_var <- newIORef (initNameCache us knownKeyNames)
fc_var <- newIORef emptyInstalledModuleEnv
emptyLoader <- uninitializedLoader
+ logger <- initLogger
-- FIXME: it's sad that we have so many "unitialized" fields filled with
-- empty stuff or lazy panics. We should have two kinds of HscEnv
-- (initialized or not) instead and less fields that are mutable over time.
return HscEnv { hsc_dflags = dflags
+ , hsc_logger = logger
, hsc_targets = []
, hsc_mod_graph = emptyMG
, hsc_IC = emptyInteractiveContext dflags
@@ -280,8 +283,9 @@ getHscEnv = Hsc $ \e w -> return (e, w)
handleWarnings :: Hsc ()
handleWarnings = do
dflags <- getDynFlags
+ logger <- getLogger
w <- getWarnings
- liftIO $ printOrThrowWarnings dflags w
+ liftIO $ printOrThrowWarnings logger dflags w
clearWarnings
-- | log warning in the monad, and if there are errors then
@@ -301,8 +305,9 @@ handleWarningsThrowErrors (warnings, errors) = do
errs = fmap pprError errors
logWarnings warns
dflags <- getDynFlags
+ logger <- getLogger
(wWarns, wErrs) <- warningsToMessages dflags <$> getWarnings
- liftIO $ printBagOfErrors dflags wWarns
+ liftIO $ printBagOfErrors logger dflags wWarns
throwErrors (unionBags errs wErrs)
-- | Deal with errors and warnings returned by a compilation step
@@ -388,10 +393,12 @@ hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary
hscParse' :: ModSummary -> Hsc HsParsedModule
hscParse' mod_summary
| Just r <- ms_parsed_mod mod_summary = return r
- | otherwise = {-# SCC "Parser" #-}
- withTimingD (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))
- (const ()) $ do
+ | otherwise = do
dflags <- getDynFlags
+ logger <- getLogger
+ {-# SCC "Parser" #-} withTiming logger dflags
+ (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))
+ (const ()) $ do
let src_filename = ms_hspp_file mod_summary
maybe_src_buf = ms_hspp_buf mod_summary
@@ -414,11 +421,11 @@ hscParse' mod_summary
POk pst rdr_module -> do
let (warns, errs) = bimap (fmap pprWarning) (fmap pprError) (getMessages pst)
logWarnings warns
- liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser"
+ liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser"
FormatHaskell (ppr rdr_module)
- liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST"
+ liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed_ast "Parser AST"
FormatHaskell (showAstData NoBlankSrcSpan rdr_module)
- liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
+ liftIO $ dumpIfSet_dyn logger dflags Opt_D_source_stats "Source Statistics"
FormatText (ppSourceStats False rdr_module)
when (not $ isEmptyBag errs) $ throwErrors errs
@@ -474,7 +481,8 @@ extract_renamed_stuff mod_summary tc_result = do
let rn_info = getRenamedStuff tc_result
dflags <- getDynFlags
- liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rn_ast "Renamer"
+ logger <- getLogger
+ liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_rn_ast "Renamer"
FormatHaskell (showAstData NoBlankSrcSpan rn_info)
-- Create HIE files
@@ -484,7 +492,7 @@ extract_renamed_stuff mod_summary tc_result = do
hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)
let out_file = ml_hie_file $ ms_location mod_summary
liftIO $ writeHieFile out_file hieFile
- liftIO $ dumpIfSet_dyn dflags Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile)
+ liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile)
-- Validate HIE files
when (gopt Opt_ValidateHie dflags) $ do
@@ -492,18 +500,18 @@ extract_renamed_stuff mod_summary tc_result = do
liftIO $ do
-- Validate Scopes
case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of
- [] -> putMsg dflags $ text "Got valid scopes"
+ [] -> putMsg logger dflags $ text "Got valid scopes"
xs -> do
- putMsg dflags $ text "Got invalid scopes"
- mapM_ (putMsg dflags) xs
+ putMsg logger dflags $ text "Got invalid scopes"
+ mapM_ (putMsg logger dflags) xs
-- Roundtrip testing
file' <- readHieFile (NCU $ updNameCache $ hsc_NC hs_env) out_file
case diffFile hieFile (hie_file_result file') of
[] ->
- putMsg dflags $ text "Got no roundtrip errors"
+ putMsg logger dflags $ text "Got no roundtrip errors"
xs -> do
- putMsg dflags $ text "Got roundtrip errors"
- mapM_ (putMsg (dopt_set dflags Opt_D_ppr_debug)) xs
+ putMsg logger dflags $ text "Got roundtrip errors"
+ mapM_ (putMsg logger (dopt_set dflags Opt_D_ppr_debug)) xs
return rn_info
@@ -844,8 +852,9 @@ finish :: ModSummary
-> Hsc HscStatus
finish summary tc_result mb_old_hash = do
hsc_env <- getHscEnv
- let dflags = hsc_dflags hsc_env
- bcknd = backend dflags
+ dflags <- getDynFlags
+ logger <- getLogger
+ let bcknd = backend dflags
hsc_src = ms_hsc_src summary
-- Desugar, if appropriate
@@ -889,7 +898,7 @@ finish summary tc_result mb_old_hash = do
(iface, mb_old_iface_hash, details) <- liftIO $
hscSimpleIface hsc_env tc_result mb_old_hash
- liftIO $ hscMaybeWriteIface dflags True iface mb_old_iface_hash (ms_location summary)
+ liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_iface_hash (ms_location summary)
return $ case bcknd of
NoBackend -> HscNotGeneratingCode iface details
@@ -943,8 +952,8 @@ suffixes. The interface file name can be overloaded with "-ohi", except when
-}
-- | Write interface files
-hscMaybeWriteIface :: DynFlags -> Bool -> ModIface -> Maybe Fingerprint -> ModLocation -> IO ()
-hscMaybeWriteIface dflags is_simple iface old_iface mod_location = do
+hscMaybeWriteIface :: Logger -> DynFlags -> Bool -> ModIface -> Maybe Fingerprint -> ModLocation -> IO ()
+hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do
let force_write_interface = gopt Opt_WriteInterface dflags
write_interface = case backend dflags of
NoBackend -> False
@@ -963,7 +972,7 @@ hscMaybeWriteIface dflags is_simple iface old_iface mod_location = do
write_iface dflags' iface =
{-# SCC "writeIface" #-}
- writeIface dflags' (buildIfName (hiSuf dflags')) iface
+ writeIface logger dflags' (buildIfName (hiSuf dflags')) iface
when (write_interface || force_write_interface) $ do
@@ -984,7 +993,7 @@ hscMaybeWriteIface dflags is_simple iface old_iface mod_location = do
dt <- dynamicTooState dflags
- when (dopt Opt_D_dump_if_trace dflags) $ putMsg dflags $
+ when (dopt Opt_D_dump_if_trace dflags) $ putMsg logger dflags $
hang (text "Writing interface(s):") 2 $ vcat
[ text "Kind:" <+> if is_simple then text "simple" else text "full"
, text "Hash change:" <+> ppr (not no_change)
@@ -1028,10 +1037,13 @@ oneShotMsg :: HscEnv -> RecompileRequired -> IO ()
oneShotMsg hsc_env recomp =
case recomp of
UpToDate ->
- compilationProgressMsg (hsc_dflags hsc_env) $
+ compilationProgressMsg logger dflags $
text "compilation IS NOT required"
_ ->
return ()
+ where
+ dflags = hsc_dflags hsc_env
+ logger = hsc_logger hsc_env
batchMsg :: Messager
batchMsg hsc_env mod_index recomp node = case node of
@@ -1039,20 +1051,21 @@ batchMsg hsc_env mod_index recomp node = case node of
case recomp of
MustCompile -> showMsg (text "Instantiating ") empty
UpToDate
- | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping ") empty
+ | verbosity dflags >= 2 -> showMsg (text "Skipping ") empty
| otherwise -> return ()
RecompBecause reason -> showMsg (text "Instantiating ") (text " [" <> text reason <> text "]")
ModuleNode _ ->
case recomp of
MustCompile -> showMsg (text "Compiling ") empty
UpToDate
- | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping ") empty
+ | verbosity dflags >= 2 -> showMsg (text "Skipping ") empty
| otherwise -> return ()
RecompBecause reason -> showMsg (text "Compiling ") (text " [" <> text reason <> text "]")
where
dflags = hsc_dflags hsc_env
+ logger = hsc_logger hsc_env
showMsg msg reason =
- compilationProgressMsg dflags $
+ compilationProgressMsg logger dflags $
(showModuleIndex mod_index <>
msg <> showModMsg dflags (recompileRequired recomp) node)
<> reason
@@ -1510,6 +1523,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
cg_dep_pkgs = dependencies,
cg_hpc_info = hpc_info } = cgguts
dflags = hsc_dflags hsc_env
+ logger = hsc_logger hsc_env
data_tycons = filter isDataTyCon tycons
-- cg_tycons includes newtypes, for the benefit of External Core,
-- but we don't generate any code for newtypes
@@ -1523,7 +1537,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
----------------- Convert to STG ------------------
(stg_binds, (caf_ccs, caf_cc_stacks))
<- {-# SCC "CoreToStg" #-}
- myCoreToStg dflags this_mod prepd_binds
+ myCoreToStg logger dflags this_mod prepd_binds
let cost_centre_info = (S.toList local_ccs ++ caf_ccs, caf_cc_stacks)
platform = targetPlatform dflags
@@ -1539,7 +1553,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
-- top-level function, so showPass isn't very useful here.
-- Hence we have one showPass for the whole backend, the
-- next showPass after this will be "Assembler".
- withTiming dflags
+ withTiming logger dflags
(text "CodeGen"<+>brackets (ppr this_mod))
(const ()) $ do
cmms <- {-# SCC "StgToCmm" #-}
@@ -1549,18 +1563,18 @@ hscGenHardCode hsc_env cgguts location output_filename = do
------------------ Code output -----------------------
rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
- lookupHook (\x -> cmmToRawCmmHook x)
- (\dflg _ -> cmmToRawCmm dflg) dflags dflags (Just this_mod) cmms
+ lookupHook (\a -> cmmToRawCmmHook a)
+ (\dflg _ -> cmmToRawCmm logger dflg) dflags dflags (Just this_mod) cmms
let dump a = do
unless (null a) $
- dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a)
+ dumpIfSet_dyn logger dflags Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a)
return a
rawcmms1 = Stream.mapM dump rawcmms0
(output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos)
<- {-# SCC "codeOutput" #-}
- codeOutput dflags (hsc_units hsc_env) this_mod output_filename location
+ codeOutput logger dflags (hsc_units hsc_env) this_mod output_filename location
foreign_stubs foreign_files dependencies rawcmms1
return (output_filename, stub_c_exists, foreign_fps, cg_infos)
@@ -1571,6 +1585,7 @@ hscInteractive :: HscEnv
-> IO (Maybe FilePath, CompiledByteCode, [SptEntry])
hscInteractive hsc_env cgguts location = do
let dflags = hsc_dflags hsc_env
+ let logger = hsc_logger hsc_env
let CgGuts{ -- This is the last use of the ModGuts in a compilation.
-- From now on, we just use the bits we need.
cg_module = this_mod,
@@ -1593,7 +1608,7 @@ hscInteractive hsc_env cgguts location = do
comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks
------------------ Create f-x-dynamic C-side stuff -----
(_istub_h_exists, istub_c_exists)
- <- outputForeignStubs dflags (hsc_units hsc_env) this_mod location foreign_stubs
+ <- outputForeignStubs logger dflags (hsc_units hsc_env) this_mod location foreign_stubs
return (istub_c_exists, comp_bc, spt_entries)
------------------------------
@@ -1601,15 +1616,16 @@ hscInteractive hsc_env cgguts location = do
hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO ()
hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
let dflags = hsc_dflags hsc_env
+ let logger = hsc_logger hsc_env
home_unit = hsc_home_unit hsc_env
platform = targetPlatform dflags
cmm <- ioMsgMaybe
$ do
- (warns,errs,cmm) <- withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())
+ (warns,errs,cmm) <- withTiming logger dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())
$ parseCmmFile dflags home_unit filename
return (mkMessages (fmap pprWarning warns `unionBags` fmap pprError errs), cmm)
liftIO $ do
- dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm)
+ dumpIfSet_dyn logger dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm)
let -- Make up a module name to give the NCG. We can't pass bottom here
-- lest we reproduce #11784.
mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename
@@ -1625,11 +1641,11 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
concatMapM (\cmm -> snd <$> cmmPipeline hsc_env (emptySRT cmm_mod) [cmm]) cmm
unless (null cmmgroup) $
- dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm"
+ dumpIfSet_dyn logger dflags Opt_D_dump_cmm "Output Cmm"
FormatCMM (pdoc platform cmmgroup)
rawCmms <- lookupHook (\x -> cmmToRawCmmHook x)
- (\dflgs _ -> cmmToRawCmm dflgs) dflags dflags Nothing (Stream.yield cmmgroup)
- _ <- codeOutput dflags (hsc_units hsc_env) cmm_mod output_filename no_loc NoStubs [] []
+ (\dflgs _ -> cmmToRawCmm logger dflgs) dflags dflags Nothing (Stream.yield cmmgroup)
+ _ <- codeOutput logger dflags (hsc_units hsc_env) cmm_mod output_filename no_loc NoStubs [] []
rawCmms
return ()
where
@@ -1669,16 +1685,17 @@ doCodeGen :: HscEnv -> Module -> [TyCon]
doCodeGen hsc_env this_mod data_tycons
cost_centre_info stg_binds hpc_info = do
let dflags = hsc_dflags hsc_env
+ let logger = hsc_logger hsc_env
platform = targetPlatform dflags
let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds
- dumpIfSet_dyn dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_fvs)
+ dumpIfSet_dyn logger dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_fvs)
let cmm_stream :: Stream IO CmmGroup ModuleLFInfos
-- See Note [Forcing of stg_binds]
cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-}
- lookupHook stgToCmmHook StgToCmm.codeGen dflags dflags this_mod data_tycons
+ lookupHook stgToCmmHook (StgToCmm.codeGen logger) dflags dflags this_mod data_tycons
cost_centre_info stg_binds_w_fvs hpc_info
-- codegen consumes a stream of CmmGroup, and produces a new
@@ -1688,7 +1705,7 @@ doCodeGen hsc_env this_mod data_tycons
let dump1 a = do
unless (null a) $
- dumpIfSet_dyn dflags Opt_D_dump_cmm_from_stg
+ dumpIfSet_dyn logger dflags Opt_D_dump_cmm_from_stg
"Cmm produced by codegen" FormatCMM (pdoc platform a)
return a
@@ -1705,22 +1722,22 @@ doCodeGen hsc_env this_mod data_tycons
dump2 a = do
unless (null a) $
- dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a)
+ dumpIfSet_dyn logger dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a)
return a
return (Stream.mapM dump2 pipeline_stream)
-myCoreToStg :: DynFlags -> Module -> CoreProgram
+myCoreToStg :: Logger -> DynFlags -> Module -> CoreProgram
-> IO ( [StgTopBinding] -- output program
, CollectedCCs ) -- CAF cost centre info (declared and used)
-myCoreToStg dflags this_mod prepd_binds = do
+myCoreToStg logger dflags this_mod prepd_binds = do
let (stg_binds, cost_centre_info)
= {-# SCC "Core2Stg" #-}
coreToStg dflags this_mod prepd_binds
stg_binds2
<- {-# SCC "Stg2Stg" #-}
- stg2stg dflags this_mod stg_binds
+ stg2stg logger dflags this_mod stg_binds
return (stg_binds2, cost_centre_info)
@@ -1977,25 +1994,26 @@ hscParseThing = hscParseThingWithLocation "<interactive>" 1
hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int
-> Lexer.P thing -> String -> Hsc thing
-hscParseThingWithLocation source linenumber parser str
- = withTimingD
+hscParseThingWithLocation source linenumber parser str = do
+ dflags <- getDynFlags
+ logger <- getLogger
+ withTiming logger dflags
(text "Parser [source]")
(const ()) $ {-# SCC "Parser" #-} do
- dflags <- getDynFlags
- let buf = stringToStringBuffer str
- loc = mkRealSrcLoc (fsLit source) linenumber 1
+ let buf = stringToStringBuffer str
+ loc = mkRealSrcLoc (fsLit source) linenumber 1
- case unP parser (initParserState (initParserOpts dflags) buf loc) of
- PFailed pst ->
- handleWarningsThrowErrors (getMessages pst)
- POk pst thing -> do
- logWarningsReportErrors (getMessages pst)
- liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser"
- FormatHaskell (ppr thing)
- liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST"
- FormatHaskell (showAstData NoBlankSrcSpan thing)
- return thing
+ case unP parser (initParserState (initParserOpts dflags) buf loc) of
+ PFailed pst ->
+ handleWarningsThrowErrors (getMessages pst)
+ POk pst thing -> do
+ logWarningsReportErrors (getMessages pst)
+ liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser"
+ FormatHaskell (ppr thing)
+ liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed_ast "Parser AST"
+ FormatHaskell (showAstData NoBlankSrcSpan thing)
+ return thing
{- **********************************************************************
@@ -2039,11 +2057,12 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr
dumpIfaceStats :: HscEnv -> IO ()
dumpIfaceStats hsc_env = do
eps <- readIORef (hsc_EPS hsc_env)
- dumpIfSet dflags (dump_if_trace || dump_rn_stats)
+ dumpIfSet logger dflags (dump_if_trace || dump_rn_stats)
"Interface statistics"
(ifaceStats eps)
where
dflags = hsc_dflags hsc_env
+ logger = hsc_logger hsc_env
dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
dump_if_trace = dopt Opt_D_dump_if_trace dflags
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 571aada57f..c36e11914e 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -82,6 +82,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Error
+import GHC.Utils.Logger
import GHC.SysTools.FileCleanup
import GHC.Types.Basic
@@ -207,9 +208,10 @@ depanalPartial excluded_mods allow_dup_roots = do
dflags = hsc_dflags hsc_env
targets = hsc_targets hsc_env
old_graph = hsc_mod_graph hsc_env
+ logger = hsc_logger hsc_env
- withTiming dflags (text "Chasing dependencies") (const ()) $ do
- liftIO $ debugTraceMsg dflags 2 (hcat [
+ withTiming logger dflags (text "Chasing dependencies") (const ()) $ do
+ liftIO $ debugTraceMsg logger dflags 2 (hcat [
text "Chasing modules from: ",
hcat (punctuate comma (map pprTarget targets))])
@@ -430,6 +432,7 @@ load' how_much mHscMessage mod_graph = do
let hpt1 = hsc_HPT hsc_env
let dflags = hsc_dflags hsc_env
+ let logger = hsc_logger hsc_env
-- The "bad" boot modules are the ones for which we have
-- B.hs-boot in the module graph, but no B.hs
@@ -454,8 +457,8 @@ load' how_much mHscMessage mod_graph = do
checkMod m and_then
| m `elementOfUniqSet` all_home_mods = and_then
| otherwise = do
- liftIO $ errorMsg dflags (text "no such module:" <+>
- quotes (ppr m))
+ liftIO $ errorMsg logger dflags
+ (text "no such module:" <+> quotes (ppr m))
return Failed
checkHowMuch how_much $ do
@@ -491,7 +494,7 @@ load' how_much mHscMessage mod_graph = do
-- write the pruned HPT to allow the old HPT to be GC'd.
setSession $ discardIC $ hsc_env { hsc_HPT = pruned_hpt }
- liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
+ liftIO $ debugTraceMsg logger dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
text "Stable BCO:" <+> ppr stable_bco)
-- Unload any modules which are going to be re-linked this time around.
@@ -566,8 +569,8 @@ load' how_much mHscMessage mod_graph = do
mg = fmap (fmap ModuleNode) stable_mg ++ unstable_mg
-- clean up between compilations
- let cleanup = cleanCurrentModuleTempFiles . hsc_dflags
- liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
+ let cleanup hsc_env = cleanCurrentModuleTempFiles (hsc_logger hsc_env) (hsc_dflags hsc_env)
+ liftIO $ debugTraceMsg logger dflags 2 (hang (text "Ready for upsweep")
2 (ppr mg))
n_jobs <- case parMakeCount dflags of
@@ -594,11 +597,11 @@ load' how_much mHscMessage mod_graph = do
then
-- Easy; just relink it all.
- do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.")
+ do liftIO $ debugTraceMsg logger dflags 2 (text "Upsweep completely successful.")
-- Clean up after ourselves
hsc_env1 <- getSession
- liftIO $ cleanCurrentModuleTempFiles dflags
+ liftIO $ cleanCurrentModuleTempFiles logger dflags
-- Issue a warning for the confusing case where the user
-- said '-o foo' but we're not going to do any linking.
@@ -615,11 +618,11 @@ load' how_much mHscMessage mod_graph = do
-- link everything together
unit_env <- hsc_unit_env <$> getSession
- linkresult <- liftIO $ link (ghcLink dflags) dflags unit_env do_linking (hsc_HPT hsc_env1)
+ linkresult <- liftIO $ link (ghcLink dflags) logger dflags unit_env do_linking (hsc_HPT hsc_env1)
if ghcLink dflags == LinkBinary && isJust ofile && not do_linking
then do
- liftIO $ errorMsg dflags $ text
+ liftIO $ errorMsg logger dflags $ text
("output was redirected with -o, " ++
"but no output will be generated\n" ++
"because there is no " ++
@@ -633,7 +636,7 @@ load' how_much mHscMessage mod_graph = do
-- Tricky. We need to back out the effects of compiling any
-- half-done cycles, both so as to clean up the top level envs
-- and to avoid telling the interactive linker to link them.
- do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.")
+ do liftIO $ debugTraceMsg logger dflags 2 (text "Upsweep partially successful.")
let modsDone_names
= map (ms_mod . emsModSummary) modsDone
@@ -658,7 +661,7 @@ load' how_much mHscMessage mod_graph = do
]
liftIO $
changeTempFilesLifetime dflags TFL_CurrentModule unneeded_temps
- liftIO $ cleanCurrentModuleTempFiles dflags
+ liftIO $ cleanCurrentModuleTempFiles logger dflags
let hpt5 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
hpt4
@@ -675,7 +678,7 @@ load' how_much mHscMessage mod_graph = do
-- Link everything together
unit_env <- hsc_unit_env <$> getSession
- linkresult <- liftIO $ link (ghcLink dflags) dflags unit_env False hpt5
+ linkresult <- liftIO $ link (ghcLink dflags) logger dflags unit_env False hpt5
modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 }
loadFinish Failed linkresult
@@ -1059,6 +1062,7 @@ parUpsweep
parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
hsc_env <- getSession
let dflags = hsc_dflags hsc_env
+ let logger = hsc_logger hsc_env
-- The bits of shared state we'll be using:
@@ -1130,6 +1134,12 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
liftIO $ label_self "main --make thread"
+
+ -- Make the logger thread_safe: we only make the "log" action thread-safe in
+ -- each worker by setting a LogAction hook, so we need to make the logger
+ -- thread-safe for other actions (DumpAction, TraceAction).
+ thread_safe_logger <- liftIO $ makeThreadSafe logger
+
-- For each module in the module graph, spawn a worker thread that will
-- compile this module.
let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) ->
@@ -1152,6 +1162,8 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
-- Replace the default log_action with one that writes each
-- message to the module's log_queue. The main thread will
-- deal with synchronously printing these messages.
+ let lcl_logger = pushLogHook (const (parLogAction log_queue)) thread_safe_logger
+
--
-- Use a local filesToClean var so that we can clean up
-- intermediate files in a timely fashion (as soon as
@@ -1159,8 +1171,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
-- worry about accidentally deleting a simultaneous compile's
-- important files.
lcl_files_to_clean <- newIORef emptyFilesToClean
- let lcl_dflags = dflags { log_action = parLogAction log_queue
- , filesToClean = lcl_files_to_clean }
+ let lcl_dflags = dflags { filesToClean = lcl_files_to_clean }
-- Unmask asynchronous exceptions and perform the thread-local
-- work to compile the module (see parUpsweep_one).
@@ -1172,7 +1183,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
pure Succeeded
ModuleNode ems ->
parUpsweep_one (emsModSummary ems) home_mod_map comp_graph_loops
- lcl_dflags (hsc_home_unit hsc_env)
+ lcl_logger lcl_dflags (hsc_home_unit hsc_env)
mHscMessage cleanup
par_sem hsc_env_var old_hpt_var
stable_mods mod_idx (length sccs)
@@ -1185,7 +1196,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
-- interrupt, and the user doesn't have to be informed
-- about that.
when (fromException exc /= Just ThreadKilled)
- (errorMsg lcl_dflags (text (show exc)))
+ (errorMsg lcl_logger lcl_dflags (text (show exc)))
return Failed
-- Populate the result MVar.
@@ -1216,7 +1227,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
-- Loop over each module in the compilation graph in order, printing
-- each message from its log_queue.
forM comp_graph $ \(mod,mvar,log_queue) -> do
- printLogs dflags log_queue
+ printLogs logger dflags log_queue
result <- readMVar mvar
if succeeded result then return (Just mod) else return Nothing
@@ -1229,7 +1240,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
-- of the upsweep.
case cycle of
Just mss -> do
- liftIO $ fatalErrorMsg dflags (cyclicModuleErr mss)
+ liftIO $ fatalErrorMsg logger dflags (cyclicModuleErr mss)
return (Failed,ok_results)
Nothing -> do
let success_flag = successIf (all isJust results)
@@ -1250,8 +1261,8 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
-- Print each message from the log_queue using the log_action from the
-- session's DynFlags.
- printLogs :: DynFlags -> LogQueue -> IO ()
- printLogs !dflags (LogQueue ref sem) = read_msgs
+ printLogs :: Logger -> DynFlags -> LogQueue -> IO ()
+ printLogs !logger !dflags (LogQueue ref sem) = read_msgs
where read_msgs = do
takeMVar sem
msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs)
@@ -1260,7 +1271,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
print_loop [] = read_msgs
print_loop (x:xs) = case x of
Just (reason,severity,srcSpan,msg) -> do
- putLogMsg dflags reason severity srcSpan msg
+ putLogMsg logger dflags reason severity srcSpan msg
print_loop xs
-- Exit the loop once we encounter the end marker.
Nothing -> return ()
@@ -1273,6 +1284,8 @@ parUpsweep_one
-- ^ The map of home modules and their result MVar
-> [[BuildModule]]
-- ^ The list of all module loops within the compilation graph.
+ -> Logger
+ -- ^ The thread-local Logger
-> DynFlags
-- ^ The thread-local DynFlags
-> HomeUnit
@@ -1295,7 +1308,7 @@ parUpsweep_one
-- ^ The total number of modules
-> IO SuccessFlag
-- ^ The result of this compile
-parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags home_unit mHscMessage cleanup par_sem
+parUpsweep_one mod home_mod_map comp_graph_loops lcl_logger lcl_dflags home_unit mHscMessage cleanup par_sem
hsc_env_var old_hpt_var stable_mods mod_index num_mods = do
let this_build_mod = mkBuildModule0 mod
@@ -1399,12 +1412,12 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags home_unit mHscMessag
hsc_env <- readMVar hsc_env_var
old_hpt <- readIORef old_hpt_var
- let logger err = printBagOfErrors lcl_dflags (srcErrorMessages err)
+ let logg err = printBagOfErrors lcl_logger lcl_dflags (srcErrorMessages err)
-- Limit the number of parallel compiles.
let withSem sem = MC.bracket_ (waitQSem sem) (signalQSem sem)
mb_mod_info <- withSem par_sem $
- handleSourceError (\err -> do logger err; return Nothing) $ do
+ handleSourceError (\err -> do logg err; return Nothing) $ do
-- Have the ModSummary and HscEnv point to our local log_action
-- and filesToClean var.
let lcl_mod = localize_mod mod
@@ -1464,13 +1477,12 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags home_unit mHscMessag
where
localize_mod mod
= mod { ms_hspp_opts = (ms_hspp_opts mod)
- { log_action = log_action lcl_dflags
- , filesToClean = filesToClean lcl_dflags } }
+ { filesToClean = filesToClean lcl_dflags } }
localize_hsc_env hsc_env
- = hsc_env { hsc_dflags = (hsc_dflags hsc_env)
- { log_action = log_action lcl_dflags
- , filesToClean = filesToClean lcl_dflags } }
+ = hsc_env { hsc_logger = lcl_logger
+ , hsc_dflags = (hsc_dflags hsc_env)
+ { filesToClean = filesToClean lcl_dflags } }
-- -----------------------------------------------------------------------------
--
@@ -1523,7 +1535,8 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do
when (not $ null dropped_ms) $ do
dflags <- getSessionDynFlags
- liftIO $ fatalErrorMsg dflags (keepGoingPruneErr $ dropped_ms)
+ logger <- getLogger
+ liftIO $ fatalErrorMsg logger dflags (keepGoingPruneErr $ dropped_ms)
(_, done') <- upsweep' old_hpt done mods' (mod_index+1) nmods'
return (Failed, done')
@@ -1541,7 +1554,8 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do
upsweep' _old_hpt done
(CyclicSCC ms : mods) mod_index nmods
= do dflags <- getSessionDynFlags
- liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)
+ logger <- getLogger
+ liftIO $ fatalErrorMsg logger dflags (cyclicModuleErr ms)
if gopt Opt_KeepGoing dflags
then keep_going (mkHomeBuildModule <$> ms) old_hpt done mods mod_index nmods
else return (Failed, done)
@@ -1557,7 +1571,7 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do
= do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
-- show (map (moduleUserString.moduleName.mi_module.hm_iface)
-- (moduleEnvElts (hsc_HPT hsc_env)))
- let logger _mod = defaultWarnErrLogger
+ let logg _mod = defaultWarnErrLogger
hsc_env <- getSession
@@ -1580,10 +1594,10 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do
mb_mod_info
<- handleSourceError
- (\err -> do logger mod (Just err); return Nothing) $ do
+ (\err -> do logg mod (Just err); return Nothing) $ do
mod_info <- liftIO $ upsweep_mod hsc_env2 mHscMessage old_hpt stable_mods
mod mod_index nmods
- logger mod Nothing -- log warnings
+ logg mod Nothing -- log warnings
return (Just mod_info)
case mb_mod_info of
@@ -1682,9 +1696,9 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind
-- We're using the dflags for this module now, obtained by
-- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.
- dflags = ms_hspp_opts summary
+ lcl_dflags = ms_hspp_opts summary
prevailing_backend = backend (hsc_dflags hsc_env)
- local_backend = backend dflags
+ local_backend = backend lcl_dflags
-- If OPTIONS_GHC contains -fasm or -fllvm, be careful that
-- we don't do anything dodgy: these should only work to change
@@ -1701,7 +1715,7 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind
_ -> prevailing_backend
-- store the corrected backend into the summary
- summary' = summary{ ms_hspp_opts = dflags { backend = bcknd } }
+ summary' = summary{ ms_hspp_opts = lcl_dflags { backend = bcknd } }
-- The old interface is ok if
-- a) we're compiling a source file, and the old HPT
@@ -1745,6 +1759,8 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind
implies False _ = True
implies True x = x
+ debug_trace n t = liftIO $ debugTraceMsg (hsc_logger hsc_env) (hsc_dflags hsc_env) n t
+
in
case () of
_
@@ -1752,15 +1768,13 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind
-- byte code, we can always use an existing object file
-- if it is *stable* (see checkStability).
| is_stable_obj, Just hmi <- old_hmi -> do
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
- (text "skipping stable obj mod:" <+> ppr this_mod_name)
+ debug_trace 5 (text "skipping stable obj mod:" <+> ppr this_mod_name)
return hmi
-- object is stable, and we have an entry in the
-- old HPT: nothing to do
| is_stable_obj, isNothing old_hmi -> do
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
- (text "compiling stable on-disk mod:" <+> ppr this_mod_name)
+ debug_trace 5 (text "compiling stable on-disk mod:" <+> ppr this_mod_name)
linkable <- liftIO $ findObjectLinkable this_mod obj_fn
(expectJust "upsweep1" mb_obj_date)
compile_it (Just linkable) SourceUnmodifiedAndStable
@@ -1771,8 +1785,7 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind
(bcknd /= NoBackend) `implies` not is_fake_linkable ->
ASSERT(isJust old_hmi) -- must be in the old_hpt
let Just hmi = old_hmi in do
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
- (text "skipping stable BCO mod:" <+> ppr this_mod_name)
+ debug_trace 5 (text "skipping stable BCO mod:" <+> ppr this_mod_name)
return hmi
-- BCO is stable: nothing to do
@@ -1782,8 +1795,7 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind
not (isObjectLinkable l),
(bcknd /= NoBackend) `implies` not is_fake_linkable,
linkableTime l >= ms_hs_date summary -> do
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
- (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)
+ debug_trace 5 (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)
compile_it (Just l) SourceUnmodified
-- we have an old BCO that is up to date with respect
-- to the source: do a recompilation check as normal.
@@ -1804,26 +1816,22 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind
Just hmi
| Just l <- hm_linkable hmi,
isObjectLinkable l && linkableTime l == obj_date -> do
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
- (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)
+ debug_trace 5 (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)
compile_it (Just l) SourceUnmodified
_otherwise -> do
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
- (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)
+ debug_trace 5 (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)
linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date
compile_it_discard_iface (Just linkable) SourceUnmodified
-- See Note [Recompilation checking in -fno-code mode]
- | writeInterfaceOnlyMode dflags,
+ | writeInterfaceOnlyMode lcl_dflags,
Just if_date <- mb_if_date,
if_date >= hs_date -> do
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
- (text "skipping tc'd mod:" <+> ppr this_mod_name)
+ debug_trace 5 (text "skipping tc'd mod:" <+> ppr this_mod_name)
compile_it Nothing SourceUnmodified
_otherwise -> do
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
- (text "compiling mod:" <+> ppr this_mod_name)
+ debug_trace 5 (text "compiling mod:" <+> ppr this_mod_name)
compile_it Nothing SourceModified
@@ -2009,7 +2017,7 @@ getModLoop ms graph appearsAsBoot
-- any duplicates get clobbered in addListToHpt and never get forced.
typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
typecheckLoop dflags hsc_env mods = do
- debugTraceMsg dflags 2 $
+ debugTraceMsg logger dflags 2 $
text "Re-typechecking loop: " <> ppr mods
new_hpt <-
fixIO $ \new_hpt -> do
@@ -2022,6 +2030,7 @@ typecheckLoop dflags hsc_env mods = do
return new_hpt
return hsc_env{ hsc_HPT = new_hpt }
where
+ logger = hsc_logger hsc_env
old_hpt = hsc_HPT hsc_env
hmis = map (expectJust "typecheckLoop" . lookupHpt old_hpt) mods
@@ -2255,8 +2264,8 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
let default_backend = platformDefaultBackend (targetPlatform dflags)
home_unit = hsc_home_unit hsc_env
map1 <- case backend dflags of
- NoBackend -> enableCodeGenForTH home_unit default_backend map0
- Interpreter -> enableCodeGenForUnboxedTuplesOrSums default_backend map0
+ NoBackend -> enableCodeGenForTH logger home_unit default_backend map0
+ Interpreter -> enableCodeGenForUnboxedTuplesOrSums logger default_backend map0
_ -> return map0
if null errs
then pure $ concat $ modNodeMapElems map1
@@ -2267,6 +2276,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
calcDeps (ExtendedModSummary ms _bkp_deps) = msDeps ms
dflags = hsc_dflags hsc_env
+ logger = hsc_logger hsc_env
roots = hsc_targets hsc_env
old_summary_map :: ModNodeMap ExtendedModSummary
@@ -2348,11 +2358,14 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
-- the specified target, disable optimization and change the .hi
-- and .o file locations to be temporary files.
-- See Note [-fno-code mode]
-enableCodeGenForTH :: HomeUnit -> Backend
+enableCodeGenForTH
+ :: Logger
+ -> HomeUnit
+ -> Backend
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
-enableCodeGenForTH home_unit =
- enableCodeGenWhen condition should_modify TFL_CurrentModule TFL_GhcSession
+enableCodeGenForTH logger home_unit =
+ enableCodeGenWhen logger condition should_modify TFL_CurrentModule TFL_GhcSession
where
condition = isTemplateHaskellOrQQNonBoot
should_modify (ModSummary { ms_hspp_opts = dflags }) =
@@ -2368,11 +2381,13 @@ enableCodeGenForTH home_unit =
--
-- This is used in order to load code that uses unboxed tuples
-- or sums into GHCi while still allowing some code to be interpreted.
-enableCodeGenForUnboxedTuplesOrSums :: Backend
+enableCodeGenForUnboxedTuplesOrSums
+ :: Logger
+ -> Backend
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
-enableCodeGenForUnboxedTuplesOrSums =
- enableCodeGenWhen condition should_modify TFL_GhcSession TFL_CurrentModule
+enableCodeGenForUnboxedTuplesOrSums logger =
+ enableCodeGenWhen logger condition should_modify TFL_GhcSession TFL_CurrentModule
where
condition ms =
unboxed_tuples_or_sums (ms_hspp_opts ms) &&
@@ -2390,14 +2405,15 @@ enableCodeGenForUnboxedTuplesOrSums =
-- modules. The second parameter is a condition to check before
-- marking modules for code generation.
enableCodeGenWhen
- :: (ModSummary -> Bool)
+ :: Logger
+ -> (ModSummary -> Bool)
-> (ModSummary -> Bool)
-> TempFileLifetime
-> TempFileLifetime
-> Backend
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
-enableCodeGenWhen condition should_modify staticLife dynLife bcknd nodemap =
+enableCodeGenWhen logger condition should_modify staticLife dynLife bcknd nodemap =
traverse (traverse (traverse enable_code_gen)) nodemap
where
enable_code_gen :: ExtendedModSummary -> IO ExtendedModSummary
@@ -2412,7 +2428,7 @@ enableCodeGenWhen condition should_modify staticLife dynLife bcknd nodemap =
, ms_mod `Set.member` needs_codegen_set
= do
let new_temp_file suf dynsuf = do
- tn <- newTempName dflags staticLife suf
+ tn <- newTempName logger dflags staticLife suf
let dyn_tn = tn -<.> dynsuf
addFilesToClean dflags dynLife [dyn_tn]
return tn
@@ -2862,9 +2878,10 @@ withDeferredDiagnostics f = do
warnings <- liftIO $ newIORef []
errors <- liftIO $ newIORef []
fatals <- liftIO $ newIORef []
+ logger <- getLogger
let deferDiagnostics _dflags !reason !severity !srcSpan !msg = do
- let action = putLogMsg dflags reason severity srcSpan msg
+ let action = putLogMsg logger dflags reason severity srcSpan msg
case severity of
SevWarning -> atomicModifyIORef' warnings $ \i -> (action: i, ())
SevError -> atomicModifyIORef' errors $ \i -> (action: i, ())
@@ -2878,12 +2895,9 @@ withDeferredDiagnostics f = do
actions <- atomicModifyIORef' ref $ \i -> ([], i)
sequence_ $ reverse actions
- setLogAction action = modifySession $ \hsc_env ->
- hsc_env{ hsc_dflags = (hsc_dflags hsc_env){ log_action = action } }
-
MC.bracket
- (setLogAction deferDiagnostics)
- (\_ -> setLogAction (log_action dflags) >> printDeferredDiagnostics)
+ (pushLogHookM (const deferDiagnostics))
+ (\_ -> popLogHookM >> printDeferredDiagnostics)
(\_ -> f)
noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope DecoratedSDoc
diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs
index 817556ee3e..57377212cb 100644
--- a/compiler/GHC/Driver/MakeFile.hs
+++ b/compiler/GHC/Driver/MakeFile.hs
@@ -42,6 +42,7 @@ import GHC.Unit.Finder
import GHC.Utils.Exception
import GHC.Utils.Error
+import GHC.Utils.Logger
import System.Directory
import System.FilePath
@@ -60,6 +61,8 @@ import qualified Data.Set as Set
doMkDependHS :: GhcMonad m => [FilePath] -> m ()
doMkDependHS srcs = do
+ logger <- getLogger
+
-- Initialisation
dflags0 <- GHC.getSessionDynFlags
@@ -79,7 +82,7 @@ doMkDependHS srcs = do
when (null (depSuffixes dflags)) $ liftIO $
throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix")
- files <- liftIO $ beginMkDependHS dflags
+ files <- liftIO $ beginMkDependHS logger dflags
-- Do the downsweep to find all the modules
targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs
@@ -92,7 +95,7 @@ doMkDependHS srcs = do
let sorted = GHC.topSortModuleGraph False module_graph Nothing
-- Print out the dependencies if wanted
- liftIO $ debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted)
+ liftIO $ debugTraceMsg logger dflags 2 (text "Module dependencies" $$ ppr sorted)
-- Process them one by one, dumping results into makefile
-- and complaining about cycles
@@ -101,10 +104,10 @@ doMkDependHS srcs = do
mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted
-- If -ddump-mod-cycles, show cycles in the module graph
- liftIO $ dumpModCycles dflags module_graph
+ liftIO $ dumpModCycles logger dflags module_graph
-- Tidy up
- liftIO $ endMkDependHS dflags files
+ liftIO $ endMkDependHS logger dflags files
-- Unconditional exiting is a bad idea. If an error occurs we'll get an
--exception; if that is not caught it's fine, but at least we have a
@@ -128,11 +131,11 @@ data MkDepFiles
mkd_tmp_file :: FilePath, -- Name of the temporary file
mkd_tmp_hdl :: Handle } -- Handle of the open temporary file
-beginMkDependHS :: DynFlags -> IO MkDepFiles
-beginMkDependHS dflags = do
+beginMkDependHS :: Logger -> DynFlags -> IO MkDepFiles
+beginMkDependHS logger dflags = do
-- open a new temp file in which to stuff the dependency info
-- as we go along.
- tmp_file <- newTempName dflags TFL_CurrentModule "dep"
+ tmp_file <- newTempName logger dflags TFL_CurrentModule "dep"
tmp_hdl <- openFile tmp_file WriteMode
-- open the makefile
@@ -338,9 +341,9 @@ insertSuffixes file_name extras
--
-----------------------------------------------------------------
-endMkDependHS :: DynFlags -> MkDepFiles -> IO ()
+endMkDependHS :: Logger -> DynFlags -> MkDepFiles -> IO ()
-endMkDependHS dflags
+endMkDependHS logger dflags
(MkDep { mkd_make_file = makefile, mkd_make_hdl = makefile_hdl,
mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl })
= do
@@ -366,27 +369,27 @@ endMkDependHS dflags
-- Create a backup of the original makefile
when (isJust makefile_hdl)
- (SysTools.copy dflags ("Backing up " ++ makefile)
+ (SysTools.copy logger dflags ("Backing up " ++ makefile)
makefile (makefile++".bak"))
-- Copy the new makefile in place
- SysTools.copy dflags "Installing new makefile" tmp_file makefile
+ SysTools.copy logger dflags "Installing new makefile" tmp_file makefile
-----------------------------------------------------------------
-- Module cycles
-----------------------------------------------------------------
-dumpModCycles :: DynFlags -> ModuleGraph -> IO ()
-dumpModCycles dflags module_graph
+dumpModCycles :: Logger -> DynFlags -> ModuleGraph -> IO ()
+dumpModCycles logger dflags module_graph
| not (dopt Opt_D_dump_mod_cycles dflags)
= return ()
| null cycles
- = putMsg dflags (text "No module cycles")
+ = putMsg logger dflags (text "No module cycles")
| otherwise
- = putMsg dflags (hang (text "Module cycles found:") 2 pp_cycles)
+ = putMsg logger dflags (hang (text "Module cycles found:") 2 pp_cycles)
where
topoSort = filterToposortToModules $
GHC.topSortModuleGraph True module_graph Nothing
diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs
index 51329aead1..2a4c2c04d6 100644
--- a/compiler/GHC/Driver/Monad.hs
+++ b/compiler/GHC/Driver/Monad.hs
@@ -19,6 +19,14 @@ module GHC.Driver.Monad (
Session(..), withSession, modifySession, modifySessionM,
withTempSession,
+ -- * Logger
+ modifyLogger,
+ pushLogHookM,
+ popLogHookM,
+ putLogMsgM,
+ putMsgM,
+ withTimingM,
+
-- ** Warnings
logWarnings, printException,
WarnErrLogger, defaultWarnErrLogger
@@ -33,7 +41,9 @@ import GHC.Driver.Errors ( printOrThrowWarnings, printBagOfErrors )
import GHC.Utils.Monad
import GHC.Utils.Exception
import GHC.Utils.Error
+import GHC.Utils.Logger
+import GHC.Types.SrcLoc
import GHC.Types.SourceError
import Control.Monad
@@ -57,7 +67,7 @@ import Data.IORef
-- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad'
-- before any call to the GHC API functions can occur.
--
-class (Functor m, ExceptionMonad m, HasDynFlags m) => GhcMonad m where
+class (Functor m, ExceptionMonad m, HasDynFlags m, HasLogger m ) => GhcMonad m where
getSession :: m HscEnv
setSession :: HscEnv -> m ()
@@ -92,13 +102,52 @@ withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a
withTempSession f m =
withSavedSession $ modifySession f >> m
+----------------------------------------
+-- Logging
+----------------------------------------
+
+-- | Modify the logger
+modifyLogger :: GhcMonad m => (Logger -> Logger) -> m ()
+modifyLogger f = modifySession $ \hsc_env ->
+ hsc_env { hsc_logger = f (hsc_logger hsc_env) }
+
+-- | Push a log hook on the stack
+pushLogHookM :: GhcMonad m => (LogAction -> LogAction) -> m ()
+pushLogHookM = modifyLogger . pushLogHook
+
+-- | Pop a log hook from the stack
+popLogHookM :: GhcMonad m => m ()
+popLogHookM = modifyLogger popLogHook
+
+-- | Put a log message
+putMsgM :: GhcMonad m => SDoc -> m ()
+putMsgM doc = do
+ dflags <- getDynFlags
+ logger <- getLogger
+ liftIO $ putMsg logger dflags doc
+
+-- | Put a log message
+putLogMsgM :: GhcMonad m => WarnReason -> Severity -> SrcSpan -> SDoc -> m ()
+putLogMsgM reason sev loc doc = do
+ dflags <- getDynFlags
+ logger <- getLogger
+ liftIO $ putLogMsg logger dflags reason sev loc doc
+
+-- | Time an action
+withTimingM :: GhcMonad m => SDoc -> (b -> ()) -> m b -> m b
+withTimingM doc force action = do
+ logger <- getLogger
+ dflags <- getDynFlags
+ withTiming logger dflags doc force action
+
-- -----------------------------------------------------------------------------
-- | A monad that allows logging of warnings.
logWarnings :: GhcMonad m => WarningMessages -> m ()
logWarnings warns = do
dflags <- getSessionDynFlags
- liftIO $ printOrThrowWarnings dflags warns
+ logger <- getLogger
+ liftIO $ printOrThrowWarnings logger dflags warns
-- -----------------------------------------------------------------------------
-- | A minimal implementation of a 'GhcMonad'. If you need a custom monad,
@@ -130,6 +179,9 @@ instance MonadFix Ghc where
instance HasDynFlags Ghc where
getDynFlags = getSessionDynFlags
+instance HasLogger Ghc where
+ getLogger = hsc_logger <$> getSession
+
instance GhcMonad Ghc where
getSession = Ghc $ \(Session r) -> readIORef r
setSession s' = Ghc $ \(Session r) -> writeIORef r s'
@@ -180,6 +232,9 @@ instance MonadIO m => MonadIO (GhcT m) where
instance MonadIO m => HasDynFlags (GhcT m) where
getDynFlags = GhcT $ \(Session r) -> liftM hsc_dflags (liftIO $ readIORef r)
+instance MonadIO m => HasLogger (GhcT m) where
+ getLogger = GhcT $ \(Session r) -> liftM hsc_logger (liftIO $ readIORef r)
+
instance ExceptionMonad m => GhcMonad (GhcT m) where
getSession = GhcT $ \(Session r) -> liftIO $ readIORef r
setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s'
@@ -190,7 +245,8 @@ instance ExceptionMonad m => GhcMonad (GhcT m) where
printException :: GhcMonad m => SourceError -> m ()
printException err = do
dflags <- getSessionDynFlags
- liftIO $ printBagOfErrors dflags (srcErrorMessages err)
+ logger <- getLogger
+ liftIO $ printBagOfErrors logger dflags (srcErrorMessages err)
-- | A function called to log warnings and errors.
type WarnErrLogger = forall m. GhcMonad m => Maybe SourceError -> m ()
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 760442bc19..f5cbebee51 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -75,6 +75,7 @@ import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Monad
import GHC.Utils.Exception as Exception
+import GHC.Utils.Logger
import GHC.CmmToLlvm ( llvmFixupAsm, llvmVersionList )
import qualified GHC.LanguageExtensions as LangExt
@@ -194,7 +195,8 @@ compileOne' m_tc_result mHscMessage
source_modified0
= do
- debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp)
+ let logger = hsc_logger hsc_env0
+ debugTraceMsg logger dflags1 2 (text "compile: input file" <+> text input_fnpp)
-- Run the pipeline up to codeGen (so everything up to, but not including, STG)
(status, plugin_hsc_env) <- hscIncrementalCompile
@@ -228,13 +230,13 @@ compileOne' m_tc_result mHscMessage
(HscUpdateBoot iface hmi_details, Interpreter) ->
return $! HomeModInfo iface hmi_details Nothing
(HscUpdateBoot iface hmi_details, _) -> do
- touchObjectFile dflags object_filename
+ touchObjectFile logger dflags object_filename
return $! HomeModInfo iface hmi_details Nothing
(HscUpdateSig iface hmi_details, Interpreter) -> do
let !linkable = LM (ms_hs_date summary) this_mod []
return $! HomeModInfo iface hmi_details (Just linkable)
(HscUpdateSig iface hmi_details, _) -> do
- output_fn <- getOutputFilename next_phase
+ output_fn <- getOutputFilename logger next_phase
(Temporary TFL_CurrentModule) basename dflags
next_phase (Just location)
@@ -262,7 +264,7 @@ compileOne' m_tc_result mHscMessage
-- In interpreted mode the regular codeGen backend is not run so we
-- generate a interface without codeGen info.
final_iface <- mkFullIface hsc_env' partial_iface Nothing
- liftIO $ hscMaybeWriteIface dflags True final_iface mb_old_iface_hash (ms_location summary)
+ liftIO $ hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash (ms_location summary)
(hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env' cgguts mod_location
@@ -284,7 +286,7 @@ compileOne' m_tc_result mHscMessage
(hs_unlinked ++ stub_o)
return $! HomeModInfo final_iface hmi_details (Just linkable)
(HscRecomp{}, _) -> do
- output_fn <- getOutputFilename next_phase
+ output_fn <- getOutputFilename logger next_phase
(Temporary TFL_CurrentModule)
basename dflags next_phase (Just location)
-- We're in --make mode: finish the compilation pipeline.
@@ -339,7 +341,6 @@ compileOne' m_tc_result mHscMessage
-- imports a _stub.h file that we created here.
current_dir = takeDirectory basename
old_paths = includePaths dflags2
- !prevailing_dflags = hsc_dflags hsc_env0
loadAsByteCode
| Just (Target _ obj _) <- findTarget summary (hsc_targets hsc_env0)
, not obj
@@ -355,14 +356,8 @@ compileOne' m_tc_result mHscMessage
= (Interpreter, dflags2 { backend = Interpreter })
| otherwise
= (backend dflags, dflags2)
- dflags =
- dflags3 { includePaths = addQuoteInclude old_paths [current_dir]
- , log_action = log_action prevailing_dflags }
- -- use the prevailing log_action / log_finaliser,
- -- not the one cached in the summary. This is so
- -- that we can change the log_action without having
- -- to re-summarize all the source files.
- hsc_env = hsc_env0 {hsc_dflags = dflags}
+ dflags = dflags3 { includePaths = addQuoteInclude old_paths [current_dir] }
+ hsc_env = hsc_env0 {hsc_dflags = dflags}
-- -fforce-recomp should also work with --make
force_recomp = gopt Opt_ForceRecomp dflags
@@ -422,7 +417,8 @@ compileEmptyStub dflags hsc_env basename location mod_name = do
-- so that ranlib on OS X doesn't complain, see
-- https://gitlab.haskell.org/ghc/ghc/issues/12673
-- and https://github.com/haskell/cabal/issues/2257
- empty_stub <- newTempName dflags TFL_CurrentModule "c"
+ let logger = hsc_logger hsc_env
+ empty_stub <- newTempName logger dflags TFL_CurrentModule "c"
let home_unit = hsc_home_unit hsc_env
src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"
writeFile empty_stub (showSDoc dflags (pprCode CStyle src))
@@ -487,6 +483,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do
-- folders, such that one runpath would be sufficient for multiple/all
-- libraries.
link :: GhcLink -- ^ interactive or batch
+ -> Logger -- ^ Logger
-> DynFlags -- ^ dynamic flags
-> UnitEnv -- ^ unit environment
-> Bool -- ^ attempt linking in batch mode?
@@ -500,38 +497,34 @@ link :: GhcLink -- ^ interactive or batch
-- exports main, i.e., we have good reason to believe that linking
-- will succeed.
-link ghcLink dflags unit_env
+link ghcLink logger dflags unit_env
= lookupHook linkHook l dflags ghcLink dflags
where
- l LinkInMemory _ _ _
- = if platformMisc_ghcWithInterpreter $ platformMisc dflags
- then -- Not Linking...(demand linker will do the job)
- return Succeeded
- else panicBadLink LinkInMemory
+ l k dflags batch_attempt_linking hpt = case k of
+ NoLink -> return Succeeded
+ LinkBinary -> link' logger dflags unit_env batch_attempt_linking hpt
+ LinkStaticLib -> link' logger dflags unit_env batch_attempt_linking hpt
+ LinkDynLib -> link' logger dflags unit_env batch_attempt_linking hpt
+ LinkInMemory
+ | platformMisc_ghcWithInterpreter $ platformMisc dflags
+ -> -- Not Linking...(demand linker will do the job)
+ return Succeeded
+ | otherwise
+ -> panicBadLink LinkInMemory
- l NoLink _ _ _
- = return Succeeded
-
- l LinkBinary dflags batch_attempt_linking hpt
- = link' dflags unit_env batch_attempt_linking hpt
-
- l LinkStaticLib dflags batch_attempt_linking hpt
- = link' dflags unit_env batch_attempt_linking hpt
-
- l LinkDynLib dflags batch_attempt_linking hpt
- = link' dflags unit_env batch_attempt_linking hpt
panicBadLink :: GhcLink -> a
panicBadLink other = panic ("link: GHC not built to link this way: " ++
show other)
-link' :: DynFlags -- ^ dynamic flags
+link' :: Logger
+ -> DynFlags -- ^ dynamic flags
-> UnitEnv -- ^ unit environment
-> Bool -- ^ attempt linking in batch mode?
-> HomePackageTable -- ^ what to link
-> IO SuccessFlag
-link' dflags unit_env batch_attempt_linking hpt
+link' logger dflags unit_env batch_attempt_linking hpt
| batch_attempt_linking
= do
let
@@ -547,11 +540,11 @@ link' dflags unit_env batch_attempt_linking hpt
-- the linkables to link
linkables = map (expectJust "link".hm_linkable) home_mod_infos
- debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables))
+ debugTraceMsg logger dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables))
-- check for the -no-link flag
if isNoLink (ghcLink dflags)
- then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).")
+ then do debugTraceMsg logger dflags 3 (text "link(batch): linking omitted (-c flag given).")
return Succeeded
else do
@@ -560,14 +553,14 @@ link' dflags unit_env batch_attempt_linking hpt
platform = targetPlatform dflags
exe_file = exeFileName platform staticLink (outputFile dflags)
- linking_needed <- linkingNeeded dflags unit_env staticLink linkables pkg_deps
+ linking_needed <- linkingNeeded logger dflags unit_env staticLink linkables pkg_deps
if not (gopt Opt_ForceRecomp dflags) && not linking_needed
- then do debugTraceMsg dflags 2 (text exe_file <+> text "is up to date, linking not required.")
+ then do debugTraceMsg logger dflags 2 (text exe_file <+> text "is up to date, linking not required.")
return Succeeded
else do
- compilationProgressMsg dflags (text "Linking " <> text exe_file <> text " ...")
+ compilationProgressMsg logger dflags (text "Linking " <> text exe_file <> text " ...")
-- Don't showPass in Batch mode; doLink will do that for us.
let link = case ghcLink dflags of
@@ -575,21 +568,21 @@ link' dflags unit_env batch_attempt_linking hpt
LinkStaticLib -> linkStaticLib
LinkDynLib -> linkDynLibCheck
other -> panicBadLink other
- link dflags unit_env obj_files pkg_deps
+ link logger dflags unit_env obj_files pkg_deps
- debugTraceMsg dflags 3 (text "link: done")
+ debugTraceMsg logger dflags 3 (text "link: done")
-- linkBinary only returns if it succeeds
return Succeeded
| otherwise
- = do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$
+ = do debugTraceMsg logger dflags 3 (text "link(batch): upsweep (partially) failed OR" $$
text " Main.main not exported; not linking.")
return Succeeded
-linkingNeeded :: DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO Bool
-linkingNeeded dflags unit_env staticLink linkables pkg_deps = do
+linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO Bool
+linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do
-- if the modification time on the executable is later than the
-- modification times on all of the objects and libraries, then omit
-- linking (unless the -fforce-recomp flag was given).
@@ -622,7 +615,7 @@ linkingNeeded dflags unit_env staticLink linkables pkg_deps = do
let (lib_errs,lib_times) = partitionEithers e_lib_times
if not (null lib_errs) || any (t <) lib_times
then return True
- else checkLinkInfo dflags unit_env pkg_deps exe_file
+ else checkLinkInfo logger dflags unit_env pkg_deps exe_file
findHSLib :: Platform -> Ways -> [String] -> String -> IO (Maybe FilePath)
findHSLib platform ws dirs lib = do
@@ -682,12 +675,13 @@ doLink hsc_env stop_phase o_files
| otherwise
= let
dflags = hsc_dflags hsc_env
+ logger = hsc_logger hsc_env
unit_env = hsc_unit_env hsc_env
in case ghcLink dflags of
NoLink -> return ()
- LinkBinary -> linkBinary dflags unit_env o_files []
- LinkStaticLib -> linkStaticLib dflags unit_env o_files []
- LinkDynLib -> linkDynLibCheck dflags unit_env o_files []
+ LinkBinary -> linkBinary logger dflags unit_env o_files []
+ LinkStaticLib -> linkStaticLib logger dflags unit_env o_files []
+ LinkDynLib -> linkDynLibCheck logger dflags unit_env o_files []
other -> panicBadLink other
@@ -723,6 +717,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase)
-- Decide where dump files should go based on the pipeline output
dflags = dflags0 { dumpPrefix = Just (basename ++ ".") }
hsc_env = hsc_env0 {hsc_dflags = dflags}
+ logger = hsc_logger hsc_env
(input_basename, suffix) = splitExtension input_fn
suffix' = drop 1 suffix -- strip off the .
@@ -770,7 +765,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase)
input_fn' <- case (start_phase, mb_input_buf) of
(RealPhase real_start_phase, Just input_buf) -> do
let suffix = phaseInputExt real_start_phase
- fn <- newTempName dflags TFL_CurrentModule suffix
+ fn <- newTempName logger dflags TFL_CurrentModule suffix
hdl <- openBinaryFile fn WriteMode
-- Add a LINE pragma so reported source locations will
-- mention the real input file, not this temp file.
@@ -780,7 +775,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase)
return fn
(_, _) -> return input_fn
- debugTraceMsg dflags 4 (text "Running the pipeline")
+ debugTraceMsg logger dflags 4 (text "Running the pipeline")
r <- runPipeline' start_phase hsc_env env input_fn'
maybe_loc foreign_os
@@ -810,13 +805,13 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase)
-- NB: Currently disabled on Windows (ref #7134, #8228, and #5987)
| OSMinGW32 <- platformOS (targetPlatform dflags) -> return ()
| otherwise -> do
- debugTraceMsg dflags 4
+ debugTraceMsg logger dflags 4
(text "Running the full pipeline again for -dynamic-too")
let dflags' = flip gopt_unset Opt_BuildDynamicToo
$ setDynamicNow
$ dflags
hsc_env' <- newHscEnv dflags'
- (dbs,unit_state,home_unit) <- initUnits dflags' Nothing
+ (dbs,unit_state,home_unit) <- initUnits logger dflags' Nothing
let unit_env = UnitEnv
{ ue_platform = targetPlatform dflags'
, ue_namever = ghcNameVersion dflags'
@@ -857,6 +852,7 @@ pipeLoop :: PhasePlus -> FilePath -> CompPipeline FilePath
pipeLoop phase input_fn = do
env <- getPipeEnv
dflags <- getDynFlags
+ logger <- getLogger
-- See Note [Partial ordering on phases]
let happensBefore' = happensBefore (targetPlatform dflags)
stopPhase = stop_phase env
@@ -872,13 +868,13 @@ pipeLoop phase input_fn = do
return input_fn
output ->
do pst <- getPipeState
- final_fn <- liftIO $ getOutputFilename
+ final_fn <- liftIO $ getOutputFilename logger
stopPhase output (src_basename env)
dflags stopPhase (maybe_loc pst)
when (final_fn /= input_fn) $ do
let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'")
line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n")
- liftIO $ copyWithHeader dflags msg line_prag input_fn final_fn
+ liftIO $ copyWithHeader logger dflags msg line_prag input_fn final_fn
return final_fn
@@ -891,7 +887,7 @@ pipeLoop phase input_fn = do
" but I wanted to stop at phase " ++ show stopPhase)
_
- -> do liftIO $ debugTraceMsg dflags 4
+ -> do liftIO $ debugTraceMsg logger dflags 4
(text "Running phase" <+> ppr phase)
case phase of
@@ -955,9 +951,10 @@ runHookedPhase pp input = do
phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath
phaseOutputFilename next_phase = do
PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv
- PipeState{maybe_loc, hsc_env} <- getPipeState
- let dflags = hsc_dflags hsc_env
- liftIO $ getOutputFilename stop_phase output_spec
+ PipeState{maybe_loc} <- getPipeState
+ dflags <- getDynFlags
+ logger <- getLogger
+ liftIO $ getOutputFilename logger stop_phase output_spec
src_basename dflags next_phase maybe_loc
-- | Computes the next output filename for something in the compilation
@@ -976,17 +973,17 @@ phaseOutputFilename next_phase = do
-- compiling; this can be used to override the default output
-- of an object file. (TODO: do we actually need this?)
getOutputFilename
- :: Phase -> PipelineOutput -> String
+ :: Logger -> Phase -> PipelineOutput -> String
-> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath
-getOutputFilename stop_phase output basename dflags next_phase maybe_location
+getOutputFilename logger stop_phase output basename dflags next_phase maybe_location
| is_last_phase, Persistent <- output = persistent_fn
| is_last_phase, SpecificFile <- output = case outputFile dflags of
Just f -> return f
Nothing ->
panic "SpecificFile: No filename"
| keep_this_output = persistent_fn
- | Temporary lifetime <- output = newTempName dflags lifetime suffix
- | otherwise = newTempName dflags TFL_CurrentModule
+ | Temporary lifetime <- output = newTempName logger dflags lifetime suffix
+ | otherwise = newTempName logger dflags TFL_CurrentModule
suffix
where
hcsuf = hcSuf dflags
@@ -1123,8 +1120,9 @@ runPhase (RealPhase (Unlit sf)) input_fn = do
, GHC.SysTools.FileOption "" output_fn
]
- dflags <- hsc_dflags <$> getPipeSession
- liftIO $ GHC.SysTools.runUnlit dflags flags
+ dflags <- getDynFlags
+ logger <- getLogger
+ liftIO $ GHC.SysTools.runUnlit logger dflags flags
return (RealPhase (Cpp sf), output_fn)
@@ -1135,6 +1133,7 @@ runPhase (RealPhase (Unlit sf)) input_fn = do
runPhase (RealPhase (Cpp sf)) input_fn
= do
dflags0 <- getDynFlags
+ logger <- getLogger
src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn
(dflags1, unhandled_flags, warns)
<- liftIO $ parseDynamicFilePragma dflags0 src_opts
@@ -1144,7 +1143,7 @@ runPhase (RealPhase (Cpp sf)) input_fn
if not (xopt LangExt.Cpp dflags1) then do
-- we have to be careful to emit warnings only once.
unless (gopt Opt_Pp dflags1) $
- liftIO $ handleFlagWarnings dflags1 warns
+ liftIO $ handleFlagWarnings logger dflags1 warns
-- no need to preprocess CPP, just pass input file along
-- to the next phase of the pipeline.
@@ -1152,7 +1151,7 @@ runPhase (RealPhase (Cpp sf)) input_fn
else do
output_fn <- phaseOutputFilename (HsPp sf)
hsc_env <- getPipeSession
- liftIO $ doCpp (hsc_dflags hsc_env) (hsc_unit_env hsc_env)
+ liftIO $ doCpp logger (hsc_dflags hsc_env) (hsc_unit_env hsc_env)
True{-raw-}
input_fn output_fn
-- re-read the pragmas now that we've preprocessed the file
@@ -1162,7 +1161,7 @@ runPhase (RealPhase (Cpp sf)) input_fn
<- liftIO $ parseDynamicFilePragma dflags0 src_opts
liftIO $ checkProcessArgsResult unhandled_flags
unless (gopt Opt_Pp dflags2) $
- liftIO $ handleFlagWarnings dflags2 warns
+ liftIO $ handleFlagWarnings logger dflags2 warns
-- the HsPp pass below will emit warnings
setDynFlags dflags2
@@ -1174,6 +1173,7 @@ runPhase (RealPhase (Cpp sf)) input_fn
runPhase (RealPhase (HsPp sf)) input_fn = do
dflags <- getDynFlags
+ logger <- getLogger
if not (gopt Opt_Pp dflags) then
-- no need to preprocess, just pass input file along
-- to the next phase of the pipeline.
@@ -1182,7 +1182,7 @@ runPhase (RealPhase (HsPp sf)) input_fn = do
PipeEnv{src_basename, src_suffix} <- getPipeEnv
let orig_fn = src_basename <.> src_suffix
output_fn <- phaseOutputFilename (Hsc sf)
- liftIO $ GHC.SysTools.runPp dflags
+ liftIO $ GHC.SysTools.runPp logger dflags
( [ GHC.SysTools.Option orig_fn
, GHC.SysTools.Option input_fn
, GHC.SysTools.FileOption "" output_fn
@@ -1195,7 +1195,7 @@ runPhase (RealPhase (HsPp sf)) input_fn = do
<- liftIO $ parseDynamicFilePragma dflags src_opts
setDynFlags dflags1
liftIO $ checkProcessArgsResult unhandled_flags
- liftIO $ handleFlagWarnings dflags1 warns
+ liftIO $ handleFlagWarnings logger dflags1 warns
return (RealPhase (Hsc sf), output_fn)
@@ -1311,6 +1311,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn
runPhase (HscOut src_flavour mod_name result) _ = do
dflags <- getDynFlags
+ logger <- getLogger
location <- getLocation src_flavour mod_name
setModLocation location
@@ -1322,7 +1323,7 @@ runPhase (HscOut src_flavour mod_name result) _ = do
return (RealPhase StopLn,
panic "No output filename from Hsc when no-code")
HscUpToDate _ _ ->
- do liftIO $ touchObjectFile dflags o_file
+ do liftIO $ touchObjectFile logger dflags o_file
-- The .o file must have a later modification date
-- than the source file (else we wouldn't get Nothing)
-- but we touch it anyway, to keep 'make' happy (we think).
@@ -1330,7 +1331,7 @@ runPhase (HscOut src_flavour mod_name result) _ = do
HscUpdateBoot _ _ ->
do -- In the case of hs-boot files, generate a dummy .o-boot
-- stamp file for the benefit of Make
- liftIO $ touchObjectFile dflags o_file
+ liftIO $ touchObjectFile logger dflags o_file
return (RealPhase StopLn, o_file)
HscUpdateSig _ _ ->
do -- We need to create a REAL but empty .o file
@@ -1363,7 +1364,7 @@ runPhase (HscOut src_flavour mod_name result) _ = do
setIface final_iface final_mod_details
-- See Note [Writing interface files]
- liftIO $ hscMaybeWriteIface dflags False final_iface mb_old_iface_hash mod_location
+ liftIO $ hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location
stub_o <- liftIO (mapM (compileStub hsc_env') mStub)
foreign_os <- liftIO $
@@ -1377,8 +1378,9 @@ runPhase (HscOut src_flavour mod_name result) _ = do
runPhase (RealPhase CmmCpp) input_fn = do
hsc_env <- getPipeSession
+ logger <- getLogger
output_fn <- phaseOutputFilename Cmm
- liftIO $ doCpp (hsc_dflags hsc_env) (hsc_unit_env hsc_env)
+ liftIO $ doCpp logger (hsc_dflags hsc_env) (hsc_unit_env hsc_env)
False{-not raw-}
input_fn output_fn
return (RealPhase Cmm, output_fn)
@@ -1478,7 +1480,8 @@ runPhase (RealPhase cc_phase) input_fn
ghcVersionH <- liftIO $ getGhcVersionPathName dflags unit_env
- liftIO $ GHC.SysTools.runCc (phaseForeignLanguage cc_phase) dflags (
+ logger <- getLogger
+ liftIO $ GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger dflags (
[ GHC.SysTools.FileOption "" input_fn
, GHC.SysTools.Option "-o"
, GHC.SysTools.FileOption "" output_fn
@@ -1535,6 +1538,7 @@ runPhase (RealPhase (As with_cpp)) input_fn
= do
hsc_env <- getPipeSession
let dflags = hsc_dflags hsc_env
+ let logger = hsc_logger hsc_env
let unit_env = hsc_unit_env hsc_env
let platform = ue_platform unit_env
@@ -1556,7 +1560,7 @@ runPhase (RealPhase (As with_cpp)) input_fn
-- might be a hierarchical module.
liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)
- ccInfo <- liftIO $ getCompilerInfo dflags
+ ccInfo <- liftIO $ getCompilerInfo logger dflags
let global_includes = [ GHC.SysTools.Option ("-I" ++ p)
| p <- includePathsGlobal cmdline_include_paths ]
let local_includes = [ GHC.SysTools.Option ("-iquote" ++ p)
@@ -1565,7 +1569,7 @@ runPhase (RealPhase (As with_cpp)) input_fn
= liftIO $
withAtomicRename outputFilename $ \temp_outputFilename ->
as_prog
- dflags
+ logger dflags
(local_includes ++ global_includes
-- See Note [-fPIC for assembler]
++ map GHC.SysTools.Option pic_c_flags
@@ -1598,7 +1602,7 @@ runPhase (RealPhase (As with_cpp)) input_fn
, GHC.SysTools.FileOption "" temp_outputFilename
])
- liftIO $ debugTraceMsg dflags 4 (text "Running the assembler")
+ liftIO $ debugTraceMsg logger dflags 4 (text "Running the assembler")
runAssembler input_fn output_fn
return (RealPhase next_phase, output_fn)
@@ -1607,9 +1611,9 @@ runPhase (RealPhase (As with_cpp)) input_fn
-----------------------------------------------------------------------------
-- LlvmOpt phase
runPhase (RealPhase LlvmOpt) input_fn = do
- hsc_env <- getPipeSession
- let dflags = hsc_dflags hsc_env
- -- we always (unless -optlo specified) run Opt since we rely on it to
+ dflags <- getDynFlags
+ logger <- getLogger
+ let -- we always (unless -optlo specified) run Opt since we rely on it to
-- fix up some pretty big deficiencies in the code we generate
optIdx = max 0 $ min 2 $ optLevel dflags -- ensure we're in [0,2]
llvmOpts = case lookup optIdx $ llvmPasses $ llvmConfig dflags of
@@ -1630,7 +1634,7 @@ runPhase (RealPhase LlvmOpt) input_fn = do
output_fn <- phaseOutputFilename LlvmLlc
- liftIO $ GHC.SysTools.runLlvmOpt dflags
+ liftIO $ GHC.SysTools.runLlvmOpt logger dflags
( optFlag
++ defaultOptions ++
[ GHC.SysTools.FileOption "" input_fn
@@ -1684,7 +1688,8 @@ runPhase (RealPhase LlvmLlc) input_fn = do
--
-- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa
--
- dflags <- hsc_dflags <$> getPipeSession
+ dflags <- getDynFlags
+ logger <- getLogger
let
llvmOpts = case optLevel dflags of
0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient.
@@ -1703,7 +1708,7 @@ runPhase (RealPhase LlvmLlc) input_fn = do
output_fn <- phaseOutputFilename next_phase
- liftIO $ GHC.SysTools.runLlvmLlc dflags
+ liftIO $ GHC.SysTools.runLlvmLlc logger dflags
( optFlag
++ defaultOptions
++ [ GHC.SysTools.FileOption "" input_fn
@@ -1722,8 +1727,9 @@ runPhase (RealPhase LlvmLlc) input_fn = do
runPhase (RealPhase LlvmMangle) input_fn = do
let next_phase = As False
output_fn <- phaseOutputFilename next_phase
- dflags <- hsc_dflags <$> getPipeSession
- liftIO $ llvmFixupAsm dflags input_fn output_fn
+ dflags <- getDynFlags
+ logger <- getLogger
+ liftIO $ llvmFixupAsm logger dflags input_fn output_fn
return (RealPhase next_phase, output_fn)
-----------------------------------------------------------------------------
@@ -1736,8 +1742,9 @@ runPhase (RealPhase MergeForeign) input_fn = do
if null foreign_os
then panic "runPhase(MergeForeign): no foreign objects"
else do
- dflags <- hsc_dflags <$> getPipeSession
- liftIO $ joinObjectFiles dflags (input_fn : foreign_os) output_fn
+ dflags <- getDynFlags
+ logger <- getLogger
+ liftIO $ joinObjectFiles logger dflags (input_fn : foreign_os) output_fn
return (RealPhase StopLn, output_fn)
-- warning suppression
@@ -1812,14 +1819,14 @@ getHCFilePackages filename =
return []
-linkDynLibCheck :: DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()
-linkDynLibCheck dflags unit_env o_files dep_units = do
+linkDynLibCheck :: Logger -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()
+linkDynLibCheck logger dflags unit_env o_files dep_units = do
when (haveRtsOptsFlags dflags) $
- putLogMsg dflags NoReason SevInfo noSrcSpan
+ putLogMsg logger dflags NoReason SevInfo noSrcSpan
$ withPprStyle defaultUserStyle
(text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$
text " Call hs_init_ghc() from your main() function to set these options.")
- linkDynLib dflags unit_env o_files dep_units
+ linkDynLib logger dflags unit_env o_files dep_units
-- -----------------------------------------------------------------------------
@@ -1828,8 +1835,8 @@ linkDynLibCheck dflags unit_env o_files dep_units = do
-- | Run CPP
--
-- UnitState is needed to compute MIN_VERSION macros
-doCpp :: DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO ()
-doCpp dflags unit_env raw input_fn output_fn = do
+doCpp :: Logger -> DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO ()
+doCpp logger dflags unit_env raw input_fn output_fn = do
let hscpp_opts = picPOpts dflags
let cmdline_include_paths = includePaths dflags
let unit_state = ue_units unit_env
@@ -1843,8 +1850,8 @@ doCpp dflags unit_env raw input_fn output_fn = do
let verbFlags = getVerbFlags dflags
- let cpp_prog args | raw = GHC.SysTools.runCpp dflags args
- | otherwise = GHC.SysTools.runCc Nothing dflags (GHC.SysTools.Option "-E" : args)
+ let cpp_prog args | raw = GHC.SysTools.runCpp logger dflags args
+ | otherwise = GHC.SysTools.runCc Nothing logger dflags (GHC.SysTools.Option "-E" : args)
let platform = targetPlatform dflags
targetArch = stringEncodeArch $ platformArch platform
@@ -1875,7 +1882,7 @@ doCpp dflags unit_env raw input_fn output_fn = do
[ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++
[ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]
- backend_defs <- getBackendDefs dflags
+ backend_defs <- getBackendDefs logger dflags
let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]
-- Default CPP defines in Haskell source
@@ -1887,7 +1894,7 @@ doCpp dflags unit_env raw input_fn output_fn = do
pkgs = catMaybes (map (lookupUnit unit_state) uids)
mb_macro_include <-
if not (null pkgs) && gopt Opt_VersionMacros dflags
- then do macro_stub <- newTempName dflags TFL_CurrentModule "h"
+ then do macro_stub <- newTempName logger dflags TFL_CurrentModule "h"
writeFile macro_stub (generatePackageVersionMacros pkgs)
-- Include version macros for every *exposed* package.
-- Without -hide-all-packages and with a package database
@@ -1927,9 +1934,9 @@ doCpp dflags unit_env raw input_fn output_fn = do
, GHC.SysTools.FileOption "" output_fn
])
-getBackendDefs :: DynFlags -> IO [String]
-getBackendDefs dflags | backend dflags == LLVM = do
- llvmVer <- figureLlvmVersion dflags
+getBackendDefs :: Logger -> DynFlags -> IO [String]
+getBackendDefs logger dflags | backend dflags == LLVM = do
+ llvmVer <- figureLlvmVersion logger dflags
return $ case fmap llvmVersionList llvmVer of
Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ]
Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]
@@ -1939,7 +1946,7 @@ getBackendDefs dflags | backend dflags == LLVM = do
| minor >= 100 = error "getBackendDefs: Unsupported minor version"
| otherwise = show $ (100 * major + minor :: Int) -- Contract is Int
-getBackendDefs _ =
+getBackendDefs _ _ =
return []
-- ---------------------------------------------------------------------------
@@ -2017,12 +2024,12 @@ via gcc.
-}
-joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO ()
-joinObjectFiles dflags o_files output_fn = do
+joinObjectFiles :: Logger -> DynFlags -> [FilePath] -> FilePath -> IO ()
+joinObjectFiles logger dflags o_files output_fn = do
let toolSettings' = toolSettings dflags
ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings'
osInfo = platformOS (targetPlatform dflags)
- ld_r args = GHC.SysTools.runMergeObjects dflags (
+ ld_r args = GHC.SysTools.runMergeObjects logger dflags (
-- See Note [Produce big objects on Windows]
concat
[ [GHC.SysTools.Option "--oformat", GHC.SysTools.Option "pe-bigobj-x86-64"]
@@ -2042,14 +2049,14 @@ joinObjectFiles dflags o_files output_fn = do
if ldIsGnuLd
then do
- script <- newTempName dflags TFL_CurrentModule "ldscript"
+ script <- newTempName logger dflags TFL_CurrentModule "ldscript"
cwd <- getCurrentDirectory
let o_files_abs = map (\x -> "\"" ++ (cwd </> x) ++ "\"") o_files
writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")"
ld_r [GHC.SysTools.FileOption "" script]
else if toolSettings_ldSupportsFilelist toolSettings'
then do
- filelist <- newTempName dflags TFL_CurrentModule "filelist"
+ filelist <- newTempName logger dflags TFL_CurrentModule "filelist"
writeFile filelist $ unlines o_files
ld_r [GHC.SysTools.Option "-filelist",
GHC.SysTools.FileOption "" filelist]
@@ -2088,10 +2095,10 @@ hscPostBackendPhase _ bcknd =
NoBackend -> StopLn
Interpreter -> StopLn
-touchObjectFile :: DynFlags -> FilePath -> IO ()
-touchObjectFile dflags path = do
+touchObjectFile :: Logger -> DynFlags -> FilePath -> IO ()
+touchObjectFile logger dflags path = do
createDirectoryIfMissing True $ takeDirectory path
- GHC.SysTools.touch dflags "Touching object file" path
+ GHC.SysTools.touch logger dflags "Touching object file" path
-- | Find out path to @ghcversion.h@ file
getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath
diff --git a/compiler/GHC/Driver/Pipeline/Monad.hs b/compiler/GHC/Driver/Pipeline/Monad.hs
index 88f19d8c2c..53d4e98b0d 100644
--- a/compiler/GHC/Driver/Pipeline/Monad.hs
+++ b/compiler/GHC/Driver/Pipeline/Monad.hs
@@ -15,6 +15,7 @@ import GHC.Prelude
import GHC.Utils.Monad
import GHC.Utils.Outputable
+import GHC.Utils.Logger
import GHC.Driver.Session
import GHC.Driver.Phases
@@ -118,6 +119,9 @@ getPipeSession = P $ \_env state -> return (state, hsc_env state)
instance HasDynFlags CompPipeline where
getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state))
+instance HasLogger CompPipeline where
+ getLogger = P $ \_env state -> return (state, hsc_logger (hsc_env state))
+
setDynFlags :: DynFlags -> CompPipeline ()
setDynFlags dflags = P $ \_env state ->
return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ())
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index cee4ba692b..7d32e7ad8a 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -24,7 +24,7 @@ module GHC.Driver.Session (
WarningFlag(..), WarnReason(..),
Language(..),
PlatformConstants(..),
- FatalMessager, LogAction, FlushOut(..), FlushErr(..),
+ FatalMessager, FlushOut(..), FlushErr(..),
ProfAuto(..),
glasgowExtsFlags,
warningGroups, warningHierarchies,
@@ -60,12 +60,11 @@ module GHC.Driver.Session (
optimisationFlags,
setFlagsFromEnvFile,
pprDynFlagsDiff,
+ flagSpecOf,
+ smallestGroups,
targetProfile,
- -- ** Log output
- putLogMsg,
-
-- ** Safe Haskell
safeHaskellOn, safeHaskellModeEnabled,
safeImportsOn, safeLanguageOn, safeInferOn,
@@ -150,9 +149,6 @@ module GHC.Driver.Session (
defaultWays,
initDynFlags, -- DynFlags -> IO DynFlags
defaultFatalMessager,
- defaultLogAction,
- defaultLogActionHPrintDoc,
- defaultLogActionHPutStrDoc,
defaultFlushOut,
defaultFlushErr,
@@ -249,7 +245,6 @@ import GHC.Utils.Misc
import GHC.Utils.GlobalVars
import GHC.Data.Maybe
import GHC.Utils.Monad
-import qualified GHC.Utils.Ppr as Pretty
import GHC.Types.SrcLoc
import GHC.Types.SafeHaskell
import GHC.Types.Basic ( Alignment, alignmentOf, IntWithInf, treatZeroAsInf )
@@ -260,11 +255,6 @@ import GHC.Settings
import GHC.CmmToAsm.CFG.Weight
import {-# SOURCE #-} GHC.Core.Opt.CallerCC
-import GHC.Types.Error
-import {-# SOURCE #-} GHC.Utils.Error
- ( DumpAction, TraceAction
- , defaultDumpAction, defaultTraceAction )
-import GHC.Utils.Json
import GHC.SysTools.Terminal ( stderrSupportsAnsiColors )
import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir )
@@ -599,11 +589,6 @@ data DynFlags = DynFlags {
-- The next available suffix to uniquely name a temp file, updated atomically
nextTempSuffix :: IORef Int,
- -- Names of files which were generated from -ddump-to-file; used to
- -- track which ones we need to truncate because it's our first run
- -- through
- generatedDumps :: IORef (Set FilePath),
-
-- hsc dynamic flags
dumpFlags :: EnumSet DumpFlag,
generalFlags :: EnumSet GeneralFlag,
@@ -645,10 +630,6 @@ data DynFlags = DynFlags {
ghciHistSize :: Int,
- -- | SDoc output action: use "GHC.Utils.Error" instead of this if you can
- log_action :: LogAction,
- dump_action :: DumpAction,
- trace_action :: TraceAction,
flushOut :: FlushOut,
flushErr :: FlushErr,
@@ -1084,7 +1065,6 @@ initDynFlags dflags = do
refNextTempSuffix <- newIORef 0
refFilesToClean <- newIORef emptyFilesToClean
refDirsToClean <- newIORef Map.empty
- refGeneratedDumps <- newIORef Set.empty
refRtldInfo <- newIORef Nothing
refRtccInfo <- newIORef Nothing
wrapperNum <- newIORef emptyModuleEnv
@@ -1108,7 +1088,6 @@ initDynFlags dflags = do
nextTempSuffix = refNextTempSuffix,
filesToClean = refFilesToClean,
dirsToClean = refDirsToClean,
- generatedDumps = refGeneratedDumps,
nextWrapperNum = wrapperNum,
useUnicode = useUnicode',
useColor = useColor',
@@ -1238,7 +1217,6 @@ defaultDynFlags mySettings llvmConfig =
nextTempSuffix = panic "defaultDynFlags: No nextTempSuffix",
filesToClean = panic "defaultDynFlags: No filesToClean",
dirsToClean = panic "defaultDynFlags: No dirsToClean",
- generatedDumps = panic "defaultDynFlags: No generatedDumps",
ghcVersionFile = Nothing,
haddockOptions = Nothing,
dumpFlags = EnumSet.empty,
@@ -1266,12 +1244,6 @@ defaultDynFlags mySettings llvmConfig =
ghciHistSize = 50, -- keep a log of length 50 by default
- -- Logging
-
- log_action = defaultLogAction,
- dump_action = defaultDumpAction,
- trace_action = defaultTraceAction,
-
flushOut = defaultFlushOut,
flushErr = defaultFlushErr,
pprUserLength = 5,
@@ -1312,119 +1284,13 @@ defaultWays settings = if pc_DYNAMIC_BY_DEFAULT (sPlatformConstants settings)
then Set.singleton WayDyn
else Set.empty
---------------------------------------------------------------------------
---
--- Note [JSON Error Messages]
---
--- When the user requests the compiler output to be dumped as json
--- we used to collect them all in an IORef and then print them at the end.
--- This doesn't work very well with GHCi. (See #14078) So instead we now
--- use the simpler method of just outputting a JSON document inplace to
--- stdout.
---
--- Before the compiler calls log_action, it has already turned the `ErrMsg`
--- into a formatted message. This means that we lose some possible
--- information to provide to the user but refactoring log_action is quite
--- invasive as it is called in many places. So, for now I left it alone
--- and we can refine its behaviour as users request different output.
type FatalMessager = String -> IO ()
-type LogAction = DynFlags
- -> WarnReason
- -> Severity
- -> SrcSpan
- -> SDoc
- -> IO ()
-
defaultFatalMessager :: FatalMessager
defaultFatalMessager = hPutStrLn stderr
--- See Note [JSON Error Messages]
---
-jsonLogAction :: LogAction
-jsonLogAction dflags reason severity srcSpan msg
- =
- defaultLogActionHPutStrDoc dflags True stdout
- (withPprStyle (PprCode CStyle) (doc $$ text ""))
- where
- str = renderWithContext (initSDocContext dflags defaultUserStyle) msg
- doc = renderJSON $
- JSObject [ ( "span", json srcSpan )
- , ( "doc" , JSString str )
- , ( "severity", json severity )
- , ( "reason" , json reason )
- ]
-
-
-defaultLogAction :: LogAction
-defaultLogAction dflags reason severity srcSpan msg
- = case severity of
- SevOutput -> printOut msg
- SevDump -> printOut (msg $$ blankLine)
- SevInteractive -> putStrSDoc msg
- SevInfo -> printErrs msg
- SevFatal -> printErrs msg
- SevWarning -> printWarns
- SevError -> printWarns
- where
- printOut = defaultLogActionHPrintDoc dflags False stdout
- printErrs = defaultLogActionHPrintDoc dflags False stderr
- putStrSDoc = defaultLogActionHPutStrDoc dflags False stdout
- -- Pretty print the warning flag, if any (#10752)
- message = mkLocMessageAnn flagMsg severity srcSpan msg
-
- printWarns = do
- hPutChar stderr '\n'
- caretDiagnostic <-
- if gopt Opt_DiagnosticsShowCaret dflags
- then getCaretDiagnostic severity srcSpan
- else pure empty
- printErrs $ getPprStyle $ \style ->
- withPprStyle (setStyleColoured True style)
- (message $+$ caretDiagnostic)
- -- careful (#2302): printErrs prints in UTF-8,
- -- whereas converting to string first and using
- -- hPutStr would just emit the low 8 bits of
- -- each unicode char.
-
- flagMsg =
- case reason of
- NoReason -> Nothing
- Reason wflag -> do
- spec <- flagSpecOf wflag
- return ("-W" ++ flagSpecName spec ++ warnFlagGrp wflag)
- ErrReason Nothing ->
- return "-Werror"
- ErrReason (Just wflag) -> do
- spec <- flagSpecOf wflag
- return $
- "-W" ++ flagSpecName spec ++ warnFlagGrp wflag ++
- ", -Werror=" ++ flagSpecName spec
-
- warnFlagGrp flag
- | gopt Opt_ShowWarnGroups dflags =
- case smallestGroups flag of
- [] -> ""
- groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")"
- | otherwise = ""
-
--- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.
-defaultLogActionHPrintDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO ()
-defaultLogActionHPrintDoc dflags asciiSpace h d
- = defaultLogActionHPutStrDoc dflags asciiSpace h (d $$ text "")
-
--- | The boolean arguments let's the pretty printer know if it can optimize indent
--- by writing ascii ' ' characters without going through decoding.
-defaultLogActionHPutStrDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO ()
-defaultLogActionHPutStrDoc dflags asciiSpace h d
- -- Don't add a newline at the end, so that successive
- -- calls to this log-action can output all on the same line
- = printSDoc ctx (Pretty.PageMode asciiSpace) h d
- where
- ctx = initSDocContext dflags defaultUserStyle
-
newtype FlushOut = FlushOut (IO ())
defaultFlushOut :: FlushOut
@@ -1793,9 +1659,6 @@ setOutputFile f d = d { outputFile_ = f}
setDynOutputFile f d = d { dynOutputFile_ = f}
setOutputHi f d = d { outputHi = f}
-setJsonLogAction :: DynFlags -> DynFlags
-setJsonLogAction d = d { log_action = jsonLogAction }
-
parseUnitInsts :: String -> Instantiations
parseUnitInsts str = case filter ((=="").snd) (readP_to_S parse str) of
[(r, "")] -> r
@@ -1979,10 +1842,6 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
return (dflags4, leftover, warns' ++ warns)
--- | Write an error or warning to the 'LogOutput'.
-putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> SDoc -> IO ()
-putLogMsg dflags = log_action dflags dflags
-
-- | Check (and potentially disable) any extensions that aren't allowed
-- in safe mode.
--
@@ -2648,7 +2507,7 @@ dynamic_flags_deps = [
, make_ord_flag defGhcFlag "ddump-debug"
(setDumpFlag Opt_D_dump_debug)
, make_ord_flag defGhcFlag "ddump-json"
- (noArg (flip dopt_set Opt_D_dump_json . setJsonLogAction ) )
+ (setDumpFlag Opt_D_dump_json )
, make_ord_flag defGhcFlag "dppr-debug"
(setDumpFlag Opt_D_ppr_debug)
, make_ord_flag defGhcFlag "ddebug-output"
View Lorry Controller Status