Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
-
9c630dd5
by Simon Hengel at 2025-07-26T00:13:16-04:00
-
79236c00
by Andrew Lelechenko at 2025-07-26T00:13:17-04:00
4 changed files:
- compiler/GHC/Core/Opt/Monad.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Core/Opt/Specialise.hs
- libraries/base/src/Data/List/NonEmpty.hs
Changes:
| ... | ... | @@ -33,7 +33,7 @@ module GHC.Core.Opt.Monad ( |
| 33 | 33 | getAnnotations, getFirstAnnotations,
|
| 34 | 34 | |
| 35 | 35 | -- ** Screen output
|
| 36 | - putMsg, putMsgS, errorMsg, msg,
|
|
| 36 | + putMsg, putMsgS, errorMsg, msg, diagnostic,
|
|
| 37 | 37 | fatalErrorMsg, fatalErrorMsgS,
|
| 38 | 38 | debugTraceMsg, debugTraceMsgS,
|
| 39 | 39 | ) where
|
| ... | ... | @@ -41,6 +41,8 @@ module GHC.Core.Opt.Monad ( |
| 41 | 41 | import GHC.Prelude hiding ( read )
|
| 42 | 42 | |
| 43 | 43 | import GHC.Driver.DynFlags
|
| 44 | +import GHC.Driver.Errors ( reportDiagnostic, reportError )
|
|
| 45 | +import GHC.Driver.Config.Diagnostic ( initDiagOpts )
|
|
| 44 | 46 | import GHC.Driver.Env
|
| 45 | 47 | |
| 46 | 48 | import GHC.Core.Rules ( RuleBase, RuleEnv, mkRuleEnv )
|
| ... | ... | @@ -52,7 +54,6 @@ import GHC.Types.Name.Env |
| 52 | 54 | import GHC.Types.SrcLoc
|
| 53 | 55 | import GHC.Types.Error
|
| 54 | 56 | |
| 55 | -import GHC.Utils.Error ( errorDiagnostic )
|
|
| 56 | 57 | import GHC.Utils.Outputable as Outputable
|
| 57 | 58 | import GHC.Utils.Logger
|
| 58 | 59 | import GHC.Utils.Monad
|
| ... | ... | @@ -383,9 +384,22 @@ putMsgS = putMsg . text |
| 383 | 384 | putMsg :: SDoc -> CoreM ()
|
| 384 | 385 | putMsg = msg MCInfo
|
| 385 | 386 | |
| 387 | +diagnostic :: DiagnosticReason -> SDoc -> CoreM ()
|
|
| 388 | +diagnostic reason doc = do
|
|
| 389 | + logger <- getLogger
|
|
| 390 | + loc <- getSrcSpanM
|
|
| 391 | + name_ppr_ctx <- getNamePprCtx
|
|
| 392 | + diag_opts <- initDiagOpts <$> getDynFlags
|
|
| 393 | + liftIO $ reportDiagnostic logger name_ppr_ctx diag_opts loc reason doc
|
|
| 394 | + |
|
| 386 | 395 | -- | Output an error to the screen. Does not cause the compiler to die.
|
| 387 | 396 | errorMsg :: SDoc -> CoreM ()
|
| 388 | -errorMsg doc = msg errorDiagnostic doc
|
|
| 397 | +errorMsg doc = do
|
|
| 398 | + logger <- getLogger
|
|
| 399 | + loc <- getSrcSpanM
|
|
| 400 | + name_ppr_ctx <- getNamePprCtx
|
|
| 401 | + diag_opts <- initDiagOpts <$> getDynFlags
|
|
| 402 | + liftIO $ reportError logger name_ppr_ctx diag_opts loc doc
|
|
| 389 | 403 | |
| 390 | 404 | -- | Output a fatal error to the screen. Does not cause the compiler to die.
|
| 391 | 405 | fatalErrorMsgS :: String -> CoreM ()
|
| ... | ... | @@ -45,7 +45,7 @@ import GHC.Core.Make ( mkImpossibleExpr ) |
| 45 | 45 | import GHC.Unit.Module
|
| 46 | 46 | import GHC.Unit.Module.ModGuts
|
| 47 | 47 | |
| 48 | -import GHC.Types.Error (MessageClass(..), Severity(..), DiagnosticReason(WarningWithoutFlag), ResolvedDiagnosticReason (..))
|
|
| 48 | +import GHC.Types.Error (DiagnosticReason(..))
|
|
| 49 | 49 | import GHC.Types.Literal ( litIsLifted )
|
| 50 | 50 | import GHC.Types.Id
|
| 51 | 51 | import GHC.Types.Id.Info ( IdDetails(..) )
|
| ... | ... | @@ -783,12 +783,11 @@ specConstrProgram guts |
| 783 | 783 | ; let (_usg, binds', warnings) = initUs_ us $
|
| 784 | 784 | scTopBinds env0 (mg_binds guts)
|
| 785 | 785 | |
| 786 | - ; when (not (null warnings)) $ msg specConstr_warn_class (warn_msg warnings)
|
|
| 786 | + ; when (not (null warnings)) $ diagnostic WarningWithoutFlag (warn_msg warnings)
|
|
| 787 | 787 | |
| 788 | 788 | ; return (guts { mg_binds = binds' }) }
|
| 789 | 789 | |
| 790 | 790 | where
|
| 791 | - specConstr_warn_class = MCDiagnostic SevWarning (ResolvedDiagnosticReason WarningWithoutFlag) Nothing
|
|
| 792 | 791 | warn_msg :: SpecFailWarnings -> SDoc
|
| 793 | 792 | warn_msg warnings = text "SpecConstr encountered one or more function(s) with a SPEC argument that resulted in too many arguments," $$
|
| 794 | 793 | text "which resulted in no specialization being generated for these functions:" $$
|
| ... | ... | @@ -12,7 +12,6 @@ import GHC.Prelude |
| 12 | 12 | |
| 13 | 13 | import GHC.Driver.DynFlags
|
| 14 | 14 | import GHC.Driver.Config
|
| 15 | -import GHC.Driver.Config.Diagnostic
|
|
| 16 | 15 | import GHC.Driver.Config.Core.Rules ( initRuleOpts )
|
| 17 | 16 | |
| 18 | 17 | import GHC.Core.Type hiding( substTy, substCo, extendTvSubst, zapSubst )
|
| ... | ... | @@ -53,7 +52,6 @@ import GHC.Types.Id |
| 53 | 52 | import GHC.Types.Id.Info
|
| 54 | 53 | import GHC.Types.Error
|
| 55 | 54 | |
| 56 | -import GHC.Utils.Error ( mkMCDiagnostic )
|
|
| 57 | 55 | import GHC.Utils.Monad ( foldlM )
|
| 58 | 56 | import GHC.Utils.Misc
|
| 59 | 57 | import GHC.Utils.FV
|
| ... | ... | @@ -935,10 +933,12 @@ tryWarnMissingSpecs dflags callers fn calls_for_fn |
| 935 | 933 | | wopt Opt_WarnAllMissedSpecs dflags = doWarn $ WarningWithFlag Opt_WarnAllMissedSpecs
|
| 936 | 934 | | otherwise = return ()
|
| 937 | 935 | where
|
| 936 | + allCallersInlined :: Bool
|
|
| 938 | 937 | allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers
|
| 939 | - diag_opts = initDiagOpts dflags
|
|
| 938 | + |
|
| 939 | + doWarn :: DiagnosticReason -> CoreM ()
|
|
| 940 | 940 | doWarn reason =
|
| 941 | - msg (mkMCDiagnostic diag_opts reason Nothing)
|
|
| 941 | + diagnostic reason
|
|
| 942 | 942 | (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn))
|
| 943 | 943 | 2 (vcat [ text "when specialising" <+> quotes (ppr caller)
|
| 944 | 944 | | caller <- callers])
|
| ... | ... | @@ -449,6 +449,8 @@ filter p = List.filter p . toList |
| 449 | 449 | -- something of type @'Maybe' b@. If this is 'Nothing', no element
|
| 450 | 450 | -- is added on to the result list. If it is @'Just' b@, then @b@ is
|
| 451 | 451 | -- included in the result list.
|
| 452 | +--
|
|
| 453 | +-- @since 4.23.0.0
|
|
| 452 | 454 | mapMaybe :: (a -> Maybe b) -> NonEmpty a -> [b]
|
| 453 | 455 | mapMaybe f (x :| xs) = maybe id (:) (f x) $ List.mapMaybe f xs
|
| 454 | 456 |