Simon Hengel pushed to branch wip/sol/driver-diagnostics at Glasgow Haskell Compiler / GHC Commits: 99e86cdb by Simon Hengel at 2025-07-25T03:40:43+07:00 Respect `-fdiagnostics-as-json` for core diagnostics (see #24113) - - - - - 459bce88 by Simon Hengel at 2025-07-25T03:40:43+07:00 Don't use MCDiagnostic for `ghcExit` This changes the error message of `ghcExit` from ``` <no location info>: error: Compilation had errors ``` to ``` Compilation had errors ``` - - - - - 9d8559ce by Simon Hengel at 2025-07-25T03:40:43+07:00 Respect `-fdiagnostics-as-json` for driver diagnostics (see #24113) - - - - - 8 changed files: - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/SysTools/Tasks.hs - compiler/GHC/Utils/Error.hs - testsuite/tests/corelint/T21115b.stderr Changes: ===================================== compiler/GHC/Core/Opt/Monad.hs ===================================== @@ -33,7 +33,7 @@ module GHC.Core.Opt.Monad ( getAnnotations, getFirstAnnotations, -- ** Screen output - putMsg, putMsgS, errorMsg, msg, + putMsg, putMsgS, errorMsg, msg, diagnostic, fatalErrorMsg, fatalErrorMsgS, debugTraceMsg, debugTraceMsgS, ) where @@ -41,6 +41,8 @@ module GHC.Core.Opt.Monad ( import GHC.Prelude hiding ( read ) import GHC.Driver.DynFlags +import GHC.Driver.Errors ( reportDiagnostic, reportError ) +import GHC.Driver.Config.Diagnostic ( initDiagOpts ) import GHC.Driver.Env import GHC.Core.Rules ( RuleBase, RuleEnv, mkRuleEnv ) @@ -52,7 +54,6 @@ import GHC.Types.Name.Env import GHC.Types.SrcLoc import GHC.Types.Error -import GHC.Utils.Error ( errorDiagnostic ) import GHC.Utils.Outputable as Outputable import GHC.Utils.Logger import GHC.Utils.Monad @@ -383,9 +384,22 @@ putMsgS = putMsg . text putMsg :: SDoc -> CoreM () putMsg = msg MCInfo +diagnostic :: DiagnosticReason -> SDoc -> CoreM () +diagnostic reason doc = do + logger <- getLogger + loc <- getSrcSpanM + name_ppr_ctx <- getNamePprCtx + diag_opts <- initDiagOpts <$> getDynFlags + liftIO $ reportDiagnostic logger name_ppr_ctx diag_opts loc reason doc + -- | Output an error to the screen. Does not cause the compiler to die. errorMsg :: SDoc -> CoreM () -errorMsg doc = msg errorDiagnostic doc +errorMsg doc = do + logger <- getLogger + loc <- getSrcSpanM + name_ppr_ctx <- getNamePprCtx + diag_opts <- initDiagOpts <$> getDynFlags + liftIO $ reportError logger name_ppr_ctx diag_opts loc doc -- | Output a fatal error to the screen. Does not cause the compiler to die. fatalErrorMsgS :: String -> CoreM () ===================================== compiler/GHC/Core/Opt/SpecConstr.hs ===================================== @@ -45,7 +45,7 @@ import GHC.Core.Make ( mkImpossibleExpr ) import GHC.Unit.Module import GHC.Unit.Module.ModGuts -import GHC.Types.Error (MessageClass(..), Severity(..), DiagnosticReason(WarningWithoutFlag), ResolvedDiagnosticReason (..)) +import GHC.Types.Error (DiagnosticReason(..)) import GHC.Types.Literal ( litIsLifted ) import GHC.Types.Id import GHC.Types.Id.Info ( IdDetails(..) ) @@ -783,12 +783,11 @@ specConstrProgram guts ; let (_usg, binds', warnings) = initUs_ us $ scTopBinds env0 (mg_binds guts) - ; when (not (null warnings)) $ msg specConstr_warn_class (warn_msg warnings) + ; when (not (null warnings)) $ diagnostic WarningWithoutFlag (warn_msg warnings) ; return (guts { mg_binds = binds' }) } where - specConstr_warn_class = MCDiagnostic SevWarning (ResolvedDiagnosticReason WarningWithoutFlag) Nothing warn_msg :: SpecFailWarnings -> SDoc warn_msg warnings = text "SpecConstr encountered one or more function(s) with a SPEC argument that resulted in too many arguments," $$ text "which resulted in no specialization being generated for these functions:" $$ ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -12,7 +12,6 @@ import GHC.Prelude import GHC.Driver.DynFlags import GHC.Driver.Config -import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Core.Rules ( initRuleOpts ) import GHC.Core.Type hiding( substTy, substCo, extendTvSubst, zapSubst ) @@ -55,7 +54,6 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Error -import GHC.Utils.Error ( mkMCDiagnostic ) import GHC.Utils.Monad ( foldlM ) import GHC.Utils.Misc import GHC.Utils.Outputable @@ -938,10 +936,12 @@ tryWarnMissingSpecs dflags callers fn calls_for_fn | wopt Opt_WarnAllMissedSpecs dflags = doWarn $ WarningWithFlag Opt_WarnAllMissedSpecs | otherwise = return () where + allCallersInlined :: Bool allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers - diag_opts = initDiagOpts dflags + + doWarn :: DiagnosticReason -> CoreM () doWarn reason = - msg (mkMCDiagnostic diag_opts reason Nothing) + diagnostic reason (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn)) 2 (vcat [ text "when specialising" <+> quotes (ppr caller) | caller <- callers]) ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -1552,7 +1552,7 @@ wrapAction msg_wrapper hsc_env k = do -- ThreadKilled in particular needs to actually kill the thread. -- So rethrow that and the other async exceptions Just (err :: SomeAsyncException) -> throwIO err - _ -> errorMsg lcl_logger (text (show exc)) + _ -> reportError lcl_logger neverQualify emptyDiagOpts noSrcSpan (text (show exc)) return Nothing ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -43,6 +43,7 @@ import GHC.Settings import GHC.Platform import GHC.Platform.Ways +import GHC.Driver.Errors import GHC.Driver.Phases import GHC.Driver.Env import GHC.Driver.Session @@ -50,7 +51,7 @@ import GHC.Driver.Ppr import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Finder -import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Monad hiding (reportDiagnostic) import GHC.Runtime.Interpreter import GHCi.BreakArray @@ -1307,9 +1308,9 @@ load_dyn interp hsc_env crash_early dll = do then cmdLineErrorIO err else do when (diag_wopt Opt_WarnMissedExtraSharedLib diag_opts) - $ logMsg logger - (mkMCDiagnostic diag_opts (WarningWithFlag Opt_WarnMissedExtraSharedLib) Nothing) - noSrcSpan $ withPprStyle defaultUserStyle (note err) + $ reportDiagnostic logger + neverQualify diag_opts + noSrcSpan (WarningWithFlag Opt_WarnMissedExtraSharedLib) $ withPprStyle defaultUserStyle (note err) pure Nothing where diag_opts = initDiagOpts (hsc_dflags hsc_env) @@ -1497,8 +1498,7 @@ locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib0 , not loading_dynamic_hs_libs , interpreterProfiled interp = do - let diag = mkMCDiagnostic diag_opts WarningWithoutFlag Nothing - logMsg logger diag noSrcSpan $ withPprStyle defaultErrStyle $ + reportDiagnostic logger neverQualify diag_opts noSrcSpan WarningWithoutFlag $ withPprStyle defaultErrStyle $ text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$ text " \tTrying dynamic library instead. If this fails try to rebuild" <+> text "libraries with profiling support." ===================================== compiler/GHC/SysTools/Tasks.hs ===================================== @@ -55,7 +55,7 @@ import GHC.Driver.Config.Diagnostic import GHC.Driver.Errors import GHC.Driver.Errors.Types (GhcMessage(..), DriverMessage (DriverNoConfiguredLLVMToolchain)) import GHC.Driver.CmdLine (warnsToMessages) -import GHC.Types.SrcLoc (noLoc) +import GHC.Types.SrcLoc (noLoc, noSrcSpan) {- ************************************************************************ @@ -346,7 +346,7 @@ figureLlvmVersion logger dflags = traceSystoolCommand logger "llc" $ do debugTraceMsg logger 2 (text "Error (figuring out LLVM version):" <+> text (show err)) - errorMsg logger $ vcat + reportError logger neverQualify emptyDiagOpts noSrcSpan $ vcat [ text "Warning:", nest 9 $ text "Couldn't figure out LLVM version!" $$ text ("Make sure you have installed LLVM between [" ===================================== compiler/GHC/Utils/Error.hs ===================================== @@ -32,7 +32,7 @@ module GHC.Utils.Error ( emptyMessages, mkDecorated, mkLocMessage, mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope, mkErrorMsgEnvelope, - mkMCDiagnostic, errorDiagnostic, diagReasonSeverity, + mkMCDiagnostic, diagReasonSeverity, mkPlainError, mkPlainDiagnostic, @@ -46,7 +46,6 @@ module GHC.Utils.Error ( -- * Issuing messages during compilation putMsg, printInfoForUser, printOutputForUser, logInfo, logOutput, - errorMsg, fatalErrorMsg, compilationProgressMsg, showPass, @@ -168,11 +167,6 @@ mkMCDiagnostic opts reason code = MCDiagnostic sev reason' code where (sev, reason') = diag_reason_severity opts reason --- | Varation of 'mkMCDiagnostic' which can be used when we are /sure/ the --- input 'DiagnosticReason' /is/ 'ErrorWithoutFlag' and there is no diagnostic code. -errorDiagnostic :: MessageClass -errorDiagnostic = MCDiagnostic SevError (ResolvedDiagnosticReason ErrorWithoutFlag) Nothing - -- -- Creating MsgEnvelope(s) -- @@ -318,17 +312,12 @@ sortMsgBag mopts = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList ghcExit :: Logger -> Int -> IO () ghcExit logger val | val == 0 = exitWith ExitSuccess - | otherwise = do errorMsg logger (text "\nCompilation had errors\n\n") + | otherwise = do fatalErrorMsg logger (text "\nCompilation had errors\n\n") exitWith (ExitFailure val) -- ----------------------------------------------------------------------------- -- Outputting messages from the compiler -errorMsg :: Logger -> SDoc -> IO () -errorMsg logger msg - = logMsg logger errorDiagnostic noSrcSpan $ - withPprStyle defaultErrStyle msg - fatalErrorMsg :: Logger -> SDoc -> IO () fatalErrorMsg logger msg = logMsg logger MCFatal noSrcSpan $ withPprStyle defaultErrStyle msg ===================================== testsuite/tests/corelint/T21115b.stderr ===================================== @@ -30,6 +30,6 @@ end Rec } *** End of Offense *** - -<no location info>: error: Compilation had errors + + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6d3ddb0086ab4bad48450011e008d77... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6d3ddb0086ab4bad48450011e008d77... You're receiving this email because of your account on gitlab.haskell.org.