diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2021-01-07 14:25:15 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-02-13 21:27:34 -0500 |
| commit | 8e2f85f6b4662676f0d7addaff9bf2c7d751bb63 (patch) | |
| tree | 6a5bea5db12d907874cdf26d709d829a3f3216ba /compiler/GHC/Driver | |
| parent | 40983d2331fe34c0af6925db7588d5ac6a19ae36 (diff) | |
| download | haskell-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.hs | 29 | ||||
| -rw-r--r-- | compiler/GHC/Driver/CodeOutput.hs | 54 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Env.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Env/Types.hs | 8 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Errors.hs | 19 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Main.hs | 143 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Make.hs | 162 | ||||
| -rw-r--r-- | compiler/GHC/Driver/MakeFile.hs | 33 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Monad.hs | 62 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Pipeline.hs | 225 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Pipeline/Monad.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Session.hs | 149 |
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" |