Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: b2f6aad0 by Simon Hengel at 2025-09-03T04:36:10-04:00 Refactoring: More consistently use logOutput, logInfo, fatalErrorMsg - - - - - 7 changed files: - compiler/GHC/Core/Lint.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/Tc/Utils/Monad.hs Changes: ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -26,6 +26,7 @@ module GHC.Core.Lint ( -- ** Debug output EndPassConfig (..), endPassIO, + lintMessage, displayLintResults, dumpPassResult ) where @@ -309,11 +310,6 @@ path does not result in allocation in the hot path. This can be surprisingly impactful. Changing `lint_app` reduced allocations for one test program I was looking at by ~4%. -Note [MCInfo for Lint] -~~~~~~~~~~~~~~~~~~~~~~ -When printing a Lint message, use the MCInfo severity so that the -message is printed on stderr rather than stdout (#13342). - ************************************************************************ * * Beginning and ending passes @@ -321,6 +317,12 @@ message is printed on stderr rather than stdout (#13342). ************************************************************************ -} +lintMessage :: Logger -> SDoc -> IO () +lintMessage logger = + -- Note: Use logInfo when printing a Lint message, so that the message is + -- printed on stderr rather than stdout (#13342). + logInfo logger . withPprStyle defaultDumpStyle + -- | Configuration for boilerplate operations at the end of a -- compilation pass producing Core. data EndPassConfig = EndPassConfig @@ -436,8 +438,7 @@ displayLintResults :: Logger -> IO () displayLintResults logger display_warnings pp_what pp_pgm (warns, errs) | not (isEmptyBag errs) - = do { logMsg logger Err.MCInfo noSrcSpan -- See Note [MCInfo for Lint] - $ withPprStyle defaultDumpStyle + = do { lintMessage logger (vcat [ lint_banner "errors" pp_what, Err.pprMessageBag errs , text "*** Offending Program ***" , pp_pgm @@ -447,8 +448,7 @@ displayLintResults logger display_warnings pp_what pp_pgm (warns, errs) | not (isEmptyBag warns) , log_enable_debug (logFlags logger) , display_warnings - = logMsg logger Err.MCInfo noSrcSpan -- See Note [MCInfo for Lint] - $ withPprStyle defaultDumpStyle + = lintMessage logger (lint_banner "warnings" pp_what $$ Err.pprMessageBag (mapBag ($$ blankLine) warns)) | otherwise = return () ===================================== compiler/GHC/Driver/CodeOutput.hs ===================================== @@ -18,6 +18,7 @@ import GHC.Prelude import GHC.Platform import GHC.ForeignSrcLang import GHC.Data.FastString +import GHC.Core.Lint ( lintMessage ) import GHC.CmmToAsm ( nativeCodeGen ) import GHC.CmmToLlvm ( llvmCodeGen ) @@ -55,7 +56,6 @@ import GHC.Utils.Panic.Plain ( pgmError ) import GHC.Unit import GHC.Unit.Finder ( mkStubPaths ) -import GHC.Types.SrcLoc import GHC.Types.CostCentre import GHC.Types.ForeignStubs import GHC.Types.Unique.DSM @@ -109,10 +109,7 @@ codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location g (text "CmmLint"<+>brackets (ppr this_mod)) (const ()) $ do { case cmmLint (targetPlatform dflags) cmm of - Just err -> do { logMsg logger - MCInfo -- See Note [MCInfo for Lint] in "GHC.Core.Lint" - noSrcSpan - $ withPprStyle defaultDumpStyle err + Just err -> do { lintMessage logger err ; ghcExit logger 1 } Nothing -> return () ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -1162,7 +1162,7 @@ getHCFilePackages filename = linkDynLibCheck :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () linkDynLibCheck logger tmpfs dflags unit_env o_files dep_units = do when (haveRtsOptsFlags dflags) $ - logMsg logger MCInfo noSrcSpan + logInfo logger $ 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.") ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -1104,7 +1104,7 @@ For some background on this choice see #15269. showIface :: Logger -> DynFlags -> UnitState -> NameCache -> FilePath -> IO () showIface logger dflags unit_state name_cache filename = do let profile = targetProfile dflags - printer = logMsg logger MCOutput noSrcSpan . withPprStyle defaultDumpStyle + printer = logOutput logger . withPprStyle defaultDumpStyle -- skip the hi way check; we don't want to worry about profiled vs. -- non-profiled interfaces, for example. ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -508,7 +508,7 @@ classifyLdInput logger platform f | isObjectFilename platform f = return (Just (Objects [f])) | isDynLibFilename platform f = return (Just (DLLPath f)) | otherwise = do - logMsg logger MCInfo noSrcSpan + logInfo logger $ withPprStyle defaultUserStyle (text ("Warning: ignoring unrecognised input `" ++ f ++ "'")) return Nothing ===================================== compiler/GHC/Stg/Lint.hs ===================================== @@ -104,6 +104,7 @@ import GHC.Stg.Utils import GHC.Core.DataCon import GHC.Core ( AltCon(..) ) import GHC.Core.Type +import GHC.Core.Lint ( lintMessage ) import GHC.Types.Basic ( TopLevelFlag(..), isTopLevel, isMarkedCbv ) import GHC.Types.CostCentre ( isCurrentCCS ) @@ -148,8 +149,7 @@ lintStgTopBindings platform logger diag_opts opts extra_vars this_mod unarised w Nothing -> return () Just msg -> do - logMsg logger Err.MCInfo noSrcSpan -- See Note [MCInfo for Lint] in "GHC.Core.Lint" - $ withPprStyle defaultDumpStyle + lintMessage logger (vcat [ text "*** Stg Lint ErrMsgs: in" <+> text whodunit <+> text "***", msg, ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -2351,8 +2351,7 @@ failIfM msg = do env <- getLclEnv let full_msg = (if_loc env <> colon) $$ nest 2 msg logger <- getLogger - liftIO (logMsg logger MCFatal - noSrcSpan $ withPprStyle defaultErrStyle full_msg) + liftIO $ fatalErrorMsg logger full_msg failM -------------------- @@ -2384,10 +2383,7 @@ forkM doc thing_inside logger <- getLogger let msg = hang (text "forkM failed:" <+> doc) 2 (text (show exn)) - liftIO $ logMsg logger - MCFatal - noSrcSpan - $ withPprStyle defaultErrStyle msg + liftIO $ fatalErrorMsg logger msg ; traceIf (text "} ending fork (badly)" <+> doc) ; pgmError "Cannot continue after interface file error" } } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b2f6aad074c00526b850d91d02479889... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b2f6aad074c00526b850d91d02479889... You're receiving this email because of your account on gitlab.haskell.org.