Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 0776ffe0 by Simon Hengel at 2025-07-26T04:54:20-04:00 Respect `-fdiagnostics-as-json` for core diagnostics (see #24113) - - - - - 3 changed files: - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/Specialise.hs 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 ) @@ -53,7 +52,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.FV @@ -935,10 +933,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]) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0776ffe0bac0dc2525d4b5759634553f... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0776ffe0bac0dc2525d4b5759634553f... You're receiving this email because of your account on gitlab.haskell.org.