- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/sol/remove-ddump-json] 2 commits: Get rid of MessageClass
by Simon Hengel (＠sol) 22 Aug '25

22 Aug '25

Simon Hengel pushed to branch wip/sol/remove-ddump-json at Glasgow Haskell Compiler / GHC Commits: 2ae6c686 by Simon Hengel at 2025-08-22T22:54:49+07:00 Get rid of MessageClass - - - - - 71d60bcd by Simon Hengel at 2025-08-22T22:57:14+07:00 Remove JSON logging - - - - - 12 changed files: - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Driver/Errors.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Monad.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Utils/Error.hs - compiler/GHC/Utils/Logger.hs - ghc/GHCi/UI.hs - testsuite/tests/ghc-api/T7478/T7478.hs Changes: ===================================== compiler/GHC/Core/Opt/Monad.hs ===================================== @@ -362,18 +362,22 @@ we aren't using annotations heavily. ************************************************************************ -} -msg :: MessageClass -> SDoc -> CoreM () -msg msg_class doc = do +msg :: Message -> CoreM () +msg msg = do logger <- getLogger name_ppr_ctx <- getNamePprCtx - let sty = case msg_class of - MCDiagnostic _ _ _ _ -> err_sty - MCDump -> dump_sty - _ -> user_sty - err_sty = mkErrStyle name_ppr_ctx - user_sty = mkUserStyle name_ppr_ctx AllTheWay - dump_sty = mkDumpStyle name_ppr_ctx - liftIO $ logMsg logger (Message msg_class (withPprStyle sty doc)) + let m = case msg of + UnsafeMCDiagnostic span severity reason code doc json -> UnsafeMCDiagnostic span severity reason code (err_sty doc) json + MCDump doc -> MCDump (dump_sty doc) + MCOutput doc -> MCOutput (user_sty doc) + MCFatal doc -> MCFatal (user_sty doc) + MCInteractive doc -> MCInteractive (user_sty doc) + MCInfo doc -> MCInfo (user_sty doc) + + err_sty = withPprStyle $ mkErrStyle name_ppr_ctx + user_sty = withPprStyle $ mkUserStyle name_ppr_ctx AllTheWay + dump_sty = withPprStyle $ mkDumpStyle name_ppr_ctx + liftIO $ logMsg logger m -- | Output a String message to the screen putMsgS :: String -> CoreM () @@ -381,7 +385,7 @@ putMsgS = putMsg . text -- | Output a message to the screen putMsg :: SDoc -> CoreM () -putMsg = msg MCInfo +putMsg = msg . MCInfo diagnostic :: DiagnosticReason -> SDoc -> CoreM () diagnostic reason doc = do @@ -406,7 +410,7 @@ fatalErrorMsgS = fatalErrorMsg . text -- | Output a fatal error to the screen. Does not cause the compiler to die. fatalErrorMsg :: SDoc -> CoreM () -fatalErrorMsg = msg MCFatal +fatalErrorMsg = msg . MCFatal -- | Output a string debugging message at verbosity level of @-v@ or higher debugTraceMsgS :: String -> CoreM () @@ -414,4 +418,4 @@ debugTraceMsgS = debugTraceMsg . text -- | Outputs a debugging message at verbosity level of @-v@ or higher debugTraceMsg :: SDoc -> CoreM () -debugTraceMsg = msg MCDump +debugTraceMsg = msg . MCDump ===================================== compiler/GHC/Driver/Errors.hs ===================================== @@ -47,18 +47,15 @@ printMessages logger msg_opts opts = mapM_ (printMessage logger msg_opts opts) . printMessage :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> MsgEnvelope a -> IO () printMessage logger msg_opts opts message = do - decorated <- decorateDiagnostic logflags messageClass location doc - if log_diags_as_json then do - let - rendered :: String - rendered = renderWithContext (log_default_user_context logflags) decorated - - jsonMessage :: JsonDoc - jsonMessage = jsonDiagnostic rendered message - - logJsonMsg logger messageClass jsonMessage - else do - logMsg logger (Message messageClass decorated) + decorated <- decorateDiagnostic logflags location severity reason code doc + let + rendered :: String + rendered = renderWithContext (log_default_user_context logflags) decorated + + jsonMessage :: JsonDoc + jsonMessage = jsonDiagnostic rendered message + + logMsg logger $ UnsafeMCDiagnostic location severity reason code decorated jsonMessage where logflags :: LogFlags logflags = logFlags logger @@ -66,9 +63,6 @@ printMessage logger msg_opts opts message = do doc :: SDoc doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic) - messageClass :: MessageClass - messageClass = UnsafeMCDiagnostic location severity (errMsgReason message) (diagnosticCode diagnostic) - style :: PprStyle style = mkErrStyle (errMsgContext message) @@ -84,6 +78,12 @@ printMessage logger msg_opts opts message = do severity :: Severity severity = errMsgSeverity message + reason :: ResolvedDiagnosticReason + reason = errMsgReason message + + code :: Maybe DiagnosticCode + code = diagnosticCode diagnostic + messageWithHints :: a -> SDoc messageWithHints e = let main_msg = formatBulleted $ diagnosticMessage msg_opts e @@ -93,21 +93,18 @@ printMessage logger msg_opts opts message = do hs -> main_msg $$ hang (text "Suggested fixes:") 2 (formatBulleted $ mkDecorated . map ppr $ hs) - log_diags_as_json :: Bool - log_diags_as_json = log_diagnostics_as_json (logFlags logger) - -decorateDiagnostic :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO SDoc -decorateDiagnostic logflags msg_class srcSpan msg = addCaret +decorateDiagnostic :: LogFlags -> SrcSpan -> Severity -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> SDoc -> IO SDoc +decorateDiagnostic logflags span severity reason code doc = addCaret where -- Pretty print the warning flag, if any (#10752) message :: SDoc - message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg + message = formatDiagnostic (log_show_warn_groups logflags) span severity reason code doc addCaret :: IO SDoc addCaret = do caretDiagnostic <- if log_show_caret logflags - then getCaretDiagnostic msg_class srcSpan + then getCaretDiagnostic severity span else pure empty return $ getPprStyle $ \style -> withPprStyle (setStyleColoured True style) ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -1846,7 +1846,8 @@ markUnsafeInfer tcg_env whyUnsafe = do badInst ins | checkOverlap (overlapMode (is_flag ins)) = [formatLocMessage (nameSrcSpan $ getName $ is_dfun ins) $ ppr (overlapMode $ is_flag ins) <+> - text "overlap mode isn't allowed in Safe Haskell"] + text "overlap mode isn't allowed in Safe Haskell" + ] | otherwise = [] -- | Figure out the final correct safe haskell mode ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -1447,11 +1447,11 @@ withDeferredDiagnostics f = do let deferDiagnostics _dflags !msg = do let action = logMsg logger msg case msg of - Message (MCDiagnostic _ SevWarning _reason _code) _ + MCDiagnostic _ SevWarning _reason _code -> atomicModifyIORef' warnings $ \(!i) -> (action: i, ()) - Message (MCDiagnostic _ SevError _reason _code) _ + MCDiagnostic _ SevError _reason _code -> atomicModifyIORef' errors $ \(!i) -> (action: i, ()) - Message MCFatal _ + MCFatal _ -> atomicModifyIORef' fatals $ \(!i) -> (action: i, ()) _ -> action ===================================== compiler/GHC/Driver/Monad.hs ===================================== @@ -23,8 +23,6 @@ module GHC.Driver.Monad ( modifyLogger, pushLogHookM, popLogHookM, - pushJsonLogHookM, - popJsonLogHookM, putLogMsgM, putMsgM, withTimingM, @@ -47,7 +45,6 @@ import GHC.Utils.Exception import GHC.Utils.Error import GHC.Utils.Logger -import GHC.Types.Error ( Message ) import GHC.Types.SourceError import Control.Monad @@ -123,12 +120,6 @@ pushLogHookM = modifyLogger . pushLogHook popLogHookM :: GhcMonad m => m () popLogHookM = modifyLogger popLogHook -pushJsonLogHookM :: GhcMonad m => (LogJsonAction -> LogJsonAction) -> m () -pushJsonLogHookM = modifyLogger . pushJsonLogHook - -popJsonLogHookM :: GhcMonad m => m () -popJsonLogHookM = modifyLogger popJsonLogHook - -- | Put a log message putMsgM :: GhcMonad m => SDoc -> m () putMsgM doc = do ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -96,7 +96,6 @@ import GHC.Types.TypeEnv import GHC.Types.Unique.DSet import GHC.Types.TyThing import GHC.Types.PkgQual -import GHC.Types.Error (Message(..)) import GHC.Unit.External import GHC.Unit.Module @@ -1119,7 +1118,7 @@ showIface logger dflags unit_state name_cache filename = do neverQualifyModules neverQualifyPackages alwaysPrintPromTick - logMsg logger $ Message MCDump + logMsg logger $ MCDump $ withPprStyle (mkDumpStyle name_ppr_ctx) $ pprModIface unit_state iface ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -72,7 +72,6 @@ import GHC.Types.Name.Env import GHC.Types.SrcLoc import GHC.Types.Unique.DSet import GHC.Types.Unique.DFM -import GHC.Types.Error (Message(..)) import GHC.Utils.Outputable import GHC.Utils.Panic @@ -1639,7 +1638,7 @@ addEnvPaths name list maybePutSDoc :: Logger -> SDoc -> IO () maybePutSDoc logger s = when (logVerbAtLeast logger 2) $ - logMsg logger $ Message + logMsg logger $ MCInteractive $ withPprStyle defaultUserStyle s ===================================== compiler/GHC/Types/Error.hs ===================================== @@ -26,8 +26,7 @@ module GHC.Types.Error -- * Classifying Messages - , Message (..) - , MessageClass (MCDiagnostic, ..) + , Message (MCDiagnostic, ..) , Severity (..) , Diagnostic (..) , UnknownDiagnostic (..) @@ -71,7 +70,6 @@ module GHC.Types.Error , mapDecoratedSDoc , pprMessageBag - , mkLocMessageWarningGroups , formatLocMessage , formatFatalLocMessage , formatDiagnostic @@ -478,27 +476,25 @@ data MsgEnvelope e = MsgEnvelope -- See Note [Warnings controlled by multiple flags] } deriving (Functor, Foldable, Traversable) -data Message = Message MessageClass SDoc - -- | The class for a diagnostic message. The main purpose is to classify a -- message within GHC, to distinguish it from a debug/dump message vs a proper -- diagnostic, for which we include a 'DiagnosticReason'. -data MessageClass - = MCOutput - | MCFatal - | MCInteractive +data Message + = MCOutput SDoc + | MCFatal SDoc + | MCInteractive SDoc - | MCDump + | MCDump SDoc -- ^ Log message intended for compiler developers -- No file\/line\/column stuff - | MCInfo + | MCInfo SDoc -- ^ Log messages intended for end users. -- No file\/line\/column stuff. - | UnsafeMCDiagnostic SrcSpan Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) + | UnsafeMCDiagnostic SrcSpan Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) SDoc JsonDoc -- ^ Diagnostics from the compiler. This constructor is very powerful as - -- it allows the construction of a 'MessageClass' with a completely + -- it allows the construction of a 'Message' with a completely -- arbitrary permutation of 'Severity' and 'DiagnosticReason'. As such, -- users are encouraged to use higher level primitives -- instead. Use this constructor directly only if you need to construct @@ -512,8 +508,8 @@ data MessageClass -- should always have a 'DiagnosticCode'. See Note [Diagnostic codes]. {-# COMPLETE MCOutput, MCFatal, MCInteractive, MCDump, MCInfo, MCDiagnostic #-} -pattern MCDiagnostic :: SrcSpan -> Severity -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> MessageClass -pattern MCDiagnostic span severity reason code <- UnsafeMCDiagnostic span severity reason code +pattern MCDiagnostic :: SrcSpan -> Severity -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> Message +pattern MCDiagnostic span severity reason code <- UnsafeMCDiagnostic span severity reason code _diagnostic _json {- Note [Suppressing Messages] @@ -638,23 +634,9 @@ showMsgEnvelope err = pprMessageBag :: Bag SDoc -> SDoc pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) --- | Make an error message with location info, specifying whether to show --- warning groups (if applicable). -mkLocMessageWarningGroups - :: Bool -- ^ Print warning groups (if applicable)? - -> MessageClass -- ^ What kind of message? - -> SrcSpan -- ^ location - -> SDoc -- ^ message - -> SDoc -mkLocMessageWarningGroups show_warn_groups msg_class locn msg - = case msg_class of - MCDiagnostic span severity reason code -> formatDiagnostic show_warn_groups span severity reason code msg - MCFatal -> formatFatalLocMessage locn msg - _ -> formatLocMessage locn msg - formatFatalLocMessage :: SrcSpan -> SDoc -> SDoc formatFatalLocMessage locn msg = sdocOption sdocColScheme $ \col_scheme -> - let msg_title = coloured (fatalColour col_scheme) $ text "fatal" + let msg_title = coloured (Col.sFatal col_scheme) $ text "fatal" in formatLocMessageWarningGroups locn msg_title empty empty msg formatLocMessage :: SrcSpan -> SDoc -> SDoc @@ -769,16 +751,7 @@ formatLocMessageWarningGroups locn msg_title code_doc warning_flag_doc msg code_doc <+> warning_flag_doc in coloured (Col.sMessage col_scheme) - (hang (coloured (Col.sHeader col_scheme) header) 4 - msg) - -getMessageClassColour :: MessageClass -> Col.Scheme -> Col.PprColour -getMessageClassColour (MCDiagnostic _span severity _reason _code) = getSeverityColour severity -getMessageClassColour MCFatal = fatalColour -getMessageClassColour _ = const mempty - -fatalColour :: Col.Scheme -> Col.PprColour -fatalColour = Col.sFatal + $ hang (coloured (Col.sHeader col_scheme) header) 4 msg getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour getSeverityColour severity = case severity of @@ -786,9 +759,9 @@ getSeverityColour severity = case severity of SevWarning -> Col.sWarning SevIgnore -> const mempty -getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc +getCaretDiagnostic :: Severity -> SrcSpan -> IO SDoc getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty -getCaretDiagnostic msg_class (RealSrcSpan span _) = +getCaretDiagnostic severity (RealSrcSpan span _) = caretDiagnostic <$> getSrcLine (srcSpanFile span) row where getSrcLine fn i = @@ -821,7 +794,7 @@ getCaretDiagnostic msg_class (RealSrcSpan span _) = caretDiagnostic Nothing = empty caretDiagnostic (Just srcLineWithNewline) = sdocOption sdocColScheme$ \col_scheme -> - let sevColour = getMessageClassColour msg_class col_scheme + let sevColour = getSeverityColour severity col_scheme marginColour = Col.sMargin col_scheme in coloured marginColour (text marginSpace) <> ===================================== compiler/GHC/Utils/Error.hs ===================================== @@ -14,7 +14,7 @@ module GHC.Utils.Error ( -- * Messages Diagnostic(..), MsgEnvelope(..), - MessageClass(..), + Message(..), SDoc, DecoratedSDoc(unDecorated), Messages, @@ -313,7 +313,7 @@ ghcExit logger val fatalErrorMsg :: Logger -> SDoc -> IO () fatalErrorMsg logger msg = - logMsg logger $ Message MCFatal (withPprStyle defaultErrStyle msg) + logMsg logger $ MCFatal (withPprStyle defaultErrStyle msg) compilationProgressMsg :: Logger -> SDoc -> IO () compilationProgressMsg logger msg = do @@ -474,11 +474,11 @@ printOutputForUser logger name_ppr_ctx msg = logOutput logger (withUserStyle name_ppr_ctx AllTheWay msg) logInfo :: Logger -> SDoc -> IO () -logInfo logger = logMsg logger . Message MCInfo +logInfo logger = logMsg logger . MCInfo -- | Like 'logInfo' but with 'SevOutput' rather then 'SevInfo' logOutput :: Logger -> SDoc -> IO () -logOutput logger = logMsg logger . Message MCOutput +logOutput logger = logMsg logger . MCOutput prettyPrintGhcErrors :: ExceptionMonad m => Logger -> m a -> m a ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -24,7 +24,6 @@ module GHC.Utils.Logger -- * Logger setup , initLogger , LogAction - , LogJsonAction , DumpAction , TraceAction , DumpFormat (..) @@ -32,8 +31,6 @@ module GHC.Utils.Logger -- ** Hooks , popLogHook , pushLogHook - , popJsonLogHook - , pushJsonLogHook , popDumpHook , pushDumpHook , popTraceHook @@ -55,11 +52,9 @@ module GHC.Utils.Logger , putLogMsg , defaultLogAction , defaultLogActionWithHandles - , defaultLogJsonAction , defaultLogActionHPrintDoc , defaultLogActionHPutStrDoc , logMsg - , logJsonMsg , logDumpMsg -- * Dumping @@ -86,8 +81,8 @@ import GHC.Types.Error import qualified GHC.Utils.Ppr as Pretty import GHC.Utils.Outputable -import GHC.Utils.Json import GHC.Utils.Panic +import GHC.Utils.Json (renderJSON) import GHC.Data.EnumSet (EnumSet) import qualified GHC.Data.EnumSet as EnumSet @@ -181,11 +176,6 @@ type LogAction = LogFlags -> Message -> IO () -type LogJsonAction = LogFlags - -> MessageClass - -> JsonDoc - -> IO () - type DumpAction = LogFlags -> PprStyle -> DumpFlag @@ -223,9 +213,6 @@ data Logger = Logger { log_hook :: [LogAction -> LogAction] -- ^ Log hooks stack - , json_log_hook :: [LogJsonAction -> LogJsonAction] - -- ^ Json log hooks stack - , dump_hook :: [DumpAction -> DumpAction] -- ^ Dump hooks stack @@ -261,7 +248,6 @@ initLogger = do dumps <- newMVar Map.empty return $ Logger { log_hook = [] - , json_log_hook = [] , dump_hook = [] , trace_hook = [] , generated_dumps = dumps @@ -273,10 +259,6 @@ initLogger = do putLogMsg :: Logger -> LogAction putLogMsg logger = foldr ($) defaultLogAction (log_hook logger) --- | Log a JsonDoc -putJsonLogMsg :: Logger -> LogJsonAction -putJsonLogMsg logger = foldr ($) defaultLogJsonAction (json_log_hook logger) - -- | Dump something putDumpFile :: Logger -> DumpAction putDumpFile logger = @@ -301,15 +283,6 @@ popLogHook logger = case log_hook logger of [] -> panic "popLogHook: empty hook stack" _:hs -> logger { log_hook = hs } --- | Push a json log hook -pushJsonLogHook :: (LogJsonAction -> LogJsonAction) -> Logger -> Logger -pushJsonLogHook h logger = logger { json_log_hook = h:json_log_hook logger } - -popJsonLogHook :: Logger -> Logger -popJsonLogHook logger = case json_log_hook logger of - [] -> panic "popJsonLogHook: empty hook stack" - _:hs -> logger { json_log_hook = hs} - -- | Push a dump hook pushDumpHook :: (DumpAction -> DumpAction) -> Logger -> Logger pushDumpHook h logger = logger { dump_hook = h:dump_hook logger } @@ -353,22 +326,6 @@ makeThreadSafe logger = do $ pushTraceHook trc $ logger -defaultLogJsonAction :: LogJsonAction -defaultLogJsonAction logflags msg_class jsdoc = - case msg_class of - MCOutput -> printOut msg - MCDump -> printOut (msg $$ blankLine) - MCInteractive -> putStrSDoc msg - MCInfo -> printErrs msg - MCFatal -> printErrs msg - MCDiagnostic _ SevIgnore _ _ -> pure () -- suppress the message - MCDiagnostic _span _sev _rea _code -> printErrs msg - where - printOut = defaultLogActionHPrintDoc logflags False stdout - printErrs = defaultLogActionHPrintDoc logflags False stderr - putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout - msg = renderJSON jsdoc - -- | The default 'LogAction' prints to 'stdout' and 'stderr'. -- -- To replicate the default log action behaviour with different @out@ and @err@ @@ -381,13 +338,17 @@ defaultLogAction = defaultLogActionWithHandles stdout stderr defaultLogActionWithHandles :: Handle {-^ Handle for standard output -} -> Handle {-^ Handle for standard errors -} -> LogAction defaultLogActionWithHandles out err logflags message = case message of - Message MCOutput msg -> printOut msg - Message MCDump msg -> printOut (msg $$ blankLine) - Message MCInteractive msg -> putStrSDoc msg - Message MCInfo msg -> printErrs msg - Message MCFatal msg -> printErrs msg - Message (MCDiagnostic _ SevIgnore _ _) _ -> pure () -- suppress the message - Message (MCDiagnostic _span _sev _rea _code) msg -> printErrs msg + MCOutput msg -> printOut msg + MCDump msg -> printOut (msg $$ blankLine) + MCInteractive msg -> putStrSDoc msg + MCInfo msg -> printErrs msg + MCFatal msg -> printErrs msg + MCDiagnostic _ SevIgnore _ _ -> pure () -- suppress the message + UnsafeMCDiagnostic _span _severity _reason _code doc json -> do + if log_diagnostics_as_json logflags then do + printErrs (renderJSON json) + else do + printErrs doc where printOut = defaultLogActionHPrintDoc logflags False out printErrs = defaultLogActionHPrintDoc logflags False err @@ -438,10 +399,10 @@ dumpSDocWithStyle dumps log_action sty logflags flag hdr doc = -- write the dump to stdout writeDump Nothing = do - let (doc', msg_class) - | null hdr = (doc, MCOutput) - | otherwise = (mkDumpDoc hdr doc, MCDump) - log_action logflags (Message msg_class (withPprStyle sty doc')) + let message + | null hdr = MCOutput (withPprStyle sty doc) + | otherwise = MCDump (withPprStyle sty $ mkDumpDoc hdr doc) + log_action logflags message -- | Run an action with the handle of a 'DumpFlag' if we are outputting to a @@ -534,9 +495,6 @@ defaultTraceAction logflags title doc x = logMsg :: Logger -> Message -> IO () logMsg logger = putLogMsg logger (logFlags logger) -logJsonMsg :: Logger -> MessageClass -> JsonDoc -> IO () -logJsonMsg logger mc = putJsonLogMsg logger (logFlags logger) mc - -- | Dump something logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () logDumpFile logger = putDumpFile logger (logFlags logger) @@ -547,7 +505,7 @@ logTraceMsg logger hdr doc a = putTraceMsg logger (logFlags logger) hdr doc a -- | Log a dump message (not a dump file) logDumpMsg :: Logger -> String -> SDoc -> IO () -logDumpMsg logger hdr doc = logMsg logger $ Message MCDump +logDumpMsg logger hdr doc = logMsg logger $ MCDump (withPprStyle defaultDumpStyle (mkDumpDoc hdr doc)) ===================================== ghc/GHCi/UI.hs ===================================== @@ -836,7 +836,7 @@ ghciLogAction lastErrLocations old_log_action dflags msg = do old_log_action dflags msg case msg of - Message (MCDiagnostic srcSpan SevError _reason _code) _ -> case srcSpan of + MCDiagnostic srcSpan SevError _reason _code -> case srcSpan of RealSrcSpan rsp _ -> modifyIORef lastErrLocations (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))]) _ -> return () ===================================== testsuite/tests/ghc-api/T7478/T7478.hs ===================================== @@ -24,7 +24,7 @@ compileInGhc targets handlerOutput = do flags0 <- getSessionDynFlags let flags = flags0 {verbosity = 1 } setSessionDynFlags flags - let collectSrcError _flags (Message MCOutput msg) + let collectSrcError _flags (MCOutput msg) = handlerOutput $ GHC.showSDocForUser flags emptyUnitState alwaysQualify msg collectSrcError _ _ = return () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a7cb010c8b8e0bf8c1239818328a95… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a7cb010c8b8e0bf8c1239818328a95… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sol/remove-ddump-json] 30 commits: testsuite: Fix T20006b
by Simon Hengel (＠sol) 22 Aug '25

22 Aug '25

Simon Hengel pushed to branch wip/sol/remove-ddump-json at Glasgow Haskell Compiler / GHC Commits: 54be78ef by Ben Gamari at 2025-08-19T16:28:05-04:00 testsuite: Fix T20006b This test is supposed to fail for non-threaded ways yet it was previously marked as only failing in `normal`. Fix this. - - - - - f4bac607 by Simon Peyton Jones at 2025-08-19T16:28:47-04:00 Take yet more care with reporting redundant constraints This small patch fixes #25992, which relates to reporting redundant constraints on default-method declarations. See (TRC5) in Note [Tracking redundant constraints] - - - - - ab130fec by fendor at 2025-08-19T16:29:29-04:00 Bump dependencies of hadrian-bootstrap-gen to use GHC 9.6.7 - - - - - 6d02ac6f by fendor at 2025-08-19T16:29:29-04:00 Bump required GHC version for test-bootstrap jobs to 9.10.1 Include test-bootstrap job for GHC 9.12.2. Update hadrian bootstrap plans use GHC 9.10 and 9.12 Remove older GHC bootstrap configurations. We require at least GHC 9.10.1 to build GHC. Adds plans for: * 9.10.1 * 9.10.2 * 9.12.1 * 9.12.2 - - - - - 9e857171 by Brandon Chinn at 2025-08-20T11:47:46-04:00 Don't warn unused-imports with used generated imports Fixes #21730 * The old notion of "implicit" import has been renamed to "generated". See Note [Generated imports] in GHC.Hs.ImpExp. * ImportMap now keeps track of generated and user-written imports separately. This avoids the fake SrcSpan we used to give the implicit Prelude import, and the hack that went with it. * -ddump-minimal-imports now considers generated imports (but still only warns on + prints user-written imports) * bestImport considers generated imports to take priority over user-written imports. - - - - - 9fb3bad4 by Ben Gamari at 2025-08-20T11:48:31-04:00 mailmap: Use ben(a)well-typed.com more liberally Nearly all of this work was done while working for Well-Typed. - - - - - 774fec37 by Ben Gamari at 2025-08-20T11:49:15-04:00 Add primop to annotate the call stack with arbitrary data We introduce a new primop `annotateStack#` which allows us to push arbitrary data onto the call-stack. This allows us to extract the data later when decoding the stack, for example when an exception is thrown, showing more information to the user without having to annotate the full call-stack with `HasCallStack` constraints. A new stack frame value is introduced `AnnFrame`, which consists of nothing but a generic payload. The primop has a small wrapper API that allows users to annotate their call-stack in programs. There is a pure API and an IO-based one. The former is a little bit dubious, as it affects the evaluation of a program, so use with care. The latter is "safe", as it doesn't change the evaluation of the program. The stack annotation mechanism is similarly implemented to the `ExceptionAnnotation` and `Exception`, there is a typeclass to indicate something can be pushed onto the call-stack and all values are wrapped in the existential `SomeStackAnnotation`, which recover the type of the annotation payload. There is currently no builtin way to show the stack annotations when `Backtraces` are displayed (i.e., when showing stack traces to the user), which we will address in a follow-up MR. ------------------------- Metric Increase: ghc_experimental_so ------------------------- We increase the size of the package, so this is not unreasonable. Co-Authored-By: fendor <fendor(a)posteo.de> Co-Authored-By: Ben Gamari <bgamari.foss(a)gmail.com> - - - - - fdfa3892 by Ben Gamari at 2025-08-20T11:49:57-04:00 testsuite: Add regression test for #24606 - - - - - 39b2e382 by Cheng Shao at 2025-08-20T11:50:40-04:00 compiler: only use `Name` instead of `Id` in `SptEntry` As a part of #26298, this patch refactors `SptEntry` to only carry a `Name` instead of `Id`: we do not care about extra information like caffyness or type at all in any static pointer related codegen logic. This is necessary to make `SptEntry` serializable, as a part of the grand plan of serializable bytecode. Co-authored-by: Codex <codex(a)openai.com> - - - - - 276f8ea8 by Vekhir -- at 2025-08-20T11:51:35-04:00 Bump Cabal dependency - - - - - 0b9c7437 by Zubin Duggal at 2025-08-20T11:52:18-04:00 ci: Teach ci.sh to fetch FreeBSD artifacts from ghcup unofficial bindists and bootstrap compiler on FreeBSD to 9.10.1 Also refactor fetch_ghc logic in ci.sh, renaming the GHC_VERSION enviorment configuration variable to FETCH_GHC_VERSION, making it clear that it is intended for use on platforms like Windows and FreeBSD where we don't want to use the GHC excecutable from the platform environment and instead need to download and install GHC-$FETCH_GHC_VERSION from a release bindist. Fixes #26296 - - - - - b2914797 by Cheng Shao at 2025-08-20T11:53:00-04:00 driver: use UniqSet for hiddenModules in DynFlags/FinderOpts This patch replaces Set ModuleName with UniqSet ModuleName in DynFlags.hiddenModules and FinderOpts.finder_hiddenModules for improved efficiency. Co-authored-by: Codex <codex(a)openai.com> - - - - - 0335d899 by Cheng Shao at 2025-08-20T11:53:00-04:00 driver: use UniqMap ModuleName in the finder This patch replaces Map ModuleName with UniqMap ModuleName in the finder for improved efficiency. Co-authored-by: Codex <codex(a)openai.com> - - - - - 91f4faaa by Cheng Shao at 2025-08-20T11:53:43-04:00 configure: check python3 version and require minimal 3.7 Since !9515, the testsuite driver requires python3 version to be at least 3.7, though this has never been checked by configure logic. This patch implements the version check. Fixes #23234. Co-authored-by: Codex <codex(a)openai.com> - - - - - df4ee9b4 by Cheng Shao at 2025-08-20T11:54:25-04:00 compiler: use zero cost coerce in GHC.CmmToAsm.CFG.loopInfo This patch refactors GHC.CmmToAsm.CFG.loopInfo to use zero cost coerce and thus addresses the TODO. For coerce to work, constructors of Label/LabelMap/LabelSet from GHC.Cmm.Dataflow.Label are exposed, though I believe it's a worthy tradeoff to avoid unnecessary runtime cost without using unsafeCoerce, since the latter could be a landmine for future refactoring. Co-authored-by: Codex <codex(a)openai.com> - - - - - ccda188d by Simon Peyton Jones at 2025-08-20T11:55:07-04:00 Start with empty inerts in shortcut solving When short-cut solving we were starting with an inert set that had unsolved Wanteds. This caused an infinite loop (#26314), because a typechecker plugin kept being given that unsolved Wanted. It's better just to start with an empty inert set - - - - - c8882ed7 by Ben Gamari at 2025-08-20T11:55:49-04:00 configure: Bump minimal bootstrap GHC version to 9.8 - - - - - f0a19d74 by fendor at 2025-08-20T19:55:00-04:00 Remove deprecated functions from the ghci package - - - - - ebeb991b by fendor at 2025-08-20T19:55:00-04:00 base: Remove unstable heap representation details from GHC.Exts - - - - - e368e247 by Rodrigo Mesquita at 2025-08-20T19:55:42-04:00 bytecode: Use 32bits for breakpoint index Fixes #26325 - - - - - 42724462 by Simon Hengel at 2025-08-21T17:52:11-04:00 Serialize wired-in names as external names when creating HIE files Note that the domain of de-serialized names stays the same. Specifically, for known-key names, before `lookupKnownKeyName` was used, while now this is handled by `lookupOrigNameCache` which captures the same range provided that the OrigNameCache has been initialized with `knownKeyNames` (which is the case by default). (fixes #26238) - - - - - 6a43f8ec by Cheng Shao at 2025-08-21T17:52:52-04:00 compiler: fix closure C type in SPT init code This patch fixes the closure C type in SPT init code to StgClosure, instead of the previously incorrect StgPtr. Having an incorrect C type makes SPT init code not compatible with other foreign stub generation logic, which may also emit their own extern declarations for the same closure symbols and thus will clash with the incorrect prototypes in SPT init code. - - - - - 0663d132 by Simon Hengel at 2025-08-22T22:50:01+07:00 Rename MCDiagnostic to UnsafeMCDiagnostic - - - - - ae98eb9c by Simon Hengel at 2025-08-22T22:50:01+07:00 Remove -ddump-json (fixes #24113) - - - - - 637fa398 by Simon Hengel at 2025-08-22T22:50:01+07:00 Add SrcSpan to MCDiagnostic - - - - - 2a3f0752 by Simon Hengel at 2025-08-22T22:50:01+07:00 Refactoring: More consistently use logOutput, logInfo, fatalErrorMsg - - - - - 3515f312 by Simon Hengel at 2025-08-22T22:50:01+07:00 Get rid of mkLocMessage - - - - - 285c4fd1 by Simon Hengel at 2025-08-22T22:50:02+07:00 Add Message data type - - - - - 934039e0 by Simon Hengel at 2025-08-22T22:50:02+07:00 Get rid of MessageClass - - - - - a7cb010c by Simon Hengel at 2025-08-22T22:50:02+07:00 Remove JSON logging - - - - - 208 changed files: - .gitlab-ci.yml - .gitlab/ci.sh - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - .mailmap - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/Cmm/Dataflow/Label.hs - compiler/GHC/CmmToAsm/CFG.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Config/Finder.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Errors.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Monad.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Pipeline/LogQueue.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Ext/Binary.hs - compiler/GHC/Iface/Ext/Types.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Tidy/StaticPtrTable.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Parser/Header.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Runtime/Debugger.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/StgToJS/StaticPtr.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Types/Name/Cache.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/SourceError.hs - compiler/GHC/Types/SptEntry.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Finder/Types.hs - compiler/GHC/Utils/Error.hs - compiler/GHC/Utils/Logger.hs - configure.ac - docs/users_guide/debugging.rst - ghc/GHCi/UI.hs - ghc/GHCi/UI/Exception.hs - hadrian/bootstrap/generate_bootstrap_plans - hadrian/bootstrap/hadrian-bootstrap-gen.cabal - hadrian/bootstrap/plan-9_10_1.json - hadrian/bootstrap/plan-9_6_5.json → hadrian/bootstrap/plan-9_10_2.json - hadrian/bootstrap/plan-9_6_6.json → hadrian/bootstrap/plan-9_12_1.json - hadrian/bootstrap/plan-9_6_4.json → hadrian/bootstrap/plan-9_12_2.json - − hadrian/bootstrap/plan-9_6_1.json - − hadrian/bootstrap/plan-9_6_2.json - − hadrian/bootstrap/plan-9_6_3.json - − hadrian/bootstrap/plan-9_8_1.json - − hadrian/bootstrap/plan-9_8_2.json - hadrian/bootstrap/plan-bootstrap-9_10_1.json - hadrian/bootstrap/plan-bootstrap-9_6_5.json → hadrian/bootstrap/plan-bootstrap-9_10_2.json - hadrian/bootstrap/plan-bootstrap-9_6_6.json → hadrian/bootstrap/plan-bootstrap-9_12_1.json - hadrian/bootstrap/plan-bootstrap-9_8_1.json → hadrian/bootstrap/plan-bootstrap-9_12_2.json - − hadrian/bootstrap/plan-bootstrap-9_6_1.json - − hadrian/bootstrap/plan-bootstrap-9_6_2.json - − hadrian/bootstrap/plan-bootstrap-9_6_3.json - − hadrian/bootstrap/plan-bootstrap-9_6_4.json - − hadrian/bootstrap/plan-bootstrap-9_8_2.json - hadrian/bootstrap/src/Main.hs - hadrian/hadrian.cabal - libraries/base/changelog.md - libraries/base/src/GHC/Exts.hs - libraries/ghc-experimental/ghc-experimental.cabal.in - + libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs - libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - libraries/ghc-heap/GHC/Exts/Stack.hs - libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc - libraries/ghc-heap/GHC/Exts/Stack/Decode.hs - + libraries/ghc-heap/tests/stack-annotation/Makefile - + libraries/ghc-heap/tests/stack-annotation/TestUtils.hs - + libraries/ghc-heap/tests/stack-annotation/all.T - + libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs - + libraries/ghc-heap/tests/stack-annotation/ann_frame001.stdout - + libraries/ghc-heap/tests/stack-annotation/ann_frame002.hs - + libraries/ghc-heap/tests/stack-annotation/ann_frame002.stdout - + libraries/ghc-heap/tests/stack-annotation/ann_frame003.hs - + libraries/ghc-heap/tests/stack-annotation/ann_frame003.stdout - + libraries/ghc-heap/tests/stack-annotation/ann_frame004.hs - + libraries/ghc-heap/tests/stack-annotation/ann_frame004.stdout - libraries/ghc-internal/src/GHC/Internal/ClosureTypes.hs - libraries/ghci/GHCi/CreateBCO.hs - libraries/ghci/GHCi/TH.hs - libraries/ghci/ghci.cabal.in - m4/find_python.m4 - rts/ClosureFlags.c - rts/Disassembler.c - rts/Interpreter.c - rts/LdvProfile.c - rts/PrimOps.cmm - rts/Printer.c - rts/RetainerProfile.c - rts/RtsSymbols.c - rts/TraverseHeap.c - rts/include/rts/storage/ClosureTypes.h - rts/include/rts/storage/Closures.h - rts/include/stg/MiscClosures.h - rts/js/profiling.js - rts/sm/Compact.c - rts/sm/Evac.c - rts/sm/NonMovingMark.c - rts/sm/Sanity.c - rts/sm/Scav.c - testsuite/tests/driver/T16167.stderr - − testsuite/tests/driver/T16167.stdout - testsuite/tests/driver/all.T - testsuite/tests/driver/json2.stderr - − testsuite/tests/driver/json_dump.hs - − testsuite/tests/driver/json_dump.stderr - testsuite/tests/gadt/T12468.stderr - testsuite/tests/ghc-api/T7478/T7478.hs - testsuite/tests/ghc-e/should_fail/T24172.stderr - testsuite/tests/ghci/scripts/T8353.stderr - testsuite/tests/ghci/scripts/ghci038.stdout - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 - testsuite/tests/interface-stability/ghc-prim-exports.stdout - testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32 - − testsuite/tests/module/T21752.stderr - testsuite/tests/module/mod150.stderr - testsuite/tests/module/mod151.stderr - testsuite/tests/module/mod152.stderr - testsuite/tests/module/mod153.stderr - testsuite/tests/overloadedrecflds/should_fail/T18999_NoDisambiguateRecordFields.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/T14189.stderr - testsuite/tests/parser/should_compile/T19082.stderr - testsuite/tests/perf/compiler/hard_hole_fits.stderr - testsuite/tests/plugins/Makefile - + testsuite/tests/plugins/T21730-plugin/Makefile - + testsuite/tests/plugins/T21730-plugin/Setup.hs - + testsuite/tests/plugins/T21730-plugin/T21730-plugin.cabal - + testsuite/tests/plugins/T21730-plugin/T21730_Plugin.hs - + testsuite/tests/plugins/T21730.hs - testsuite/tests/plugins/all.T - testsuite/tests/plugins/hooks-plugin/Hooks/LogPlugin.hs - testsuite/tests/quotes/LiftErrMsg.stderr - testsuite/tests/quotes/LiftErrMsgDefer.stderr - testsuite/tests/quotes/LiftErrMsgTyped.stderr - testsuite/tests/rename/should_compile/T22513d.stderr - testsuite/tests/rename/should_compile/T22513e.stderr - testsuite/tests/rename/should_compile/T22513f.stderr - testsuite/tests/rename/should_compile/T22513g.stderr - testsuite/tests/rename/should_compile/T22513h.stderr - testsuite/tests/rename/should_compile/T22513i.stderr - testsuite/tests/rename/should_compile/rn039.ghc.stderr - testsuite/tests/rename/should_fail/T15487.stderr - testsuite/tests/rename/should_fail/T18740a.stderr - testsuite/tests/rename/should_fail/rnfail044.stderr - testsuite/tests/rts/flags/all.T - testsuite/tests/safeHaskell/flags/SafeFlags17.stderr - + testsuite/tests/simplCore/should_compile/T24606.hs - testsuite/tests/simplCore/should_compile/all.T - testsuite/tests/th/T10267.stderr - testsuite/tests/th/T14627.stderr - testsuite/tests/th/T15321.stderr - testsuite/tests/typecheck/should_compile/T13050.stderr - testsuite/tests/typecheck/should_compile/T14273.stderr - testsuite/tests/typecheck/should_compile/T14590.stderr - testsuite/tests/typecheck/should_compile/T25180.stderr - + testsuite/tests/typecheck/should_compile/T25992a.hs - testsuite/tests/typecheck/should_compile/T9497a.stderr - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/typecheck/should_compile/refinement_hole_fits.stderr - testsuite/tests/typecheck/should_compile/subsumption_sort_hole_fits.stderr - testsuite/tests/typecheck/should_fail/T14884.stderr - testsuite/tests/typecheck/should_fail/T21130.stderr - testsuite/tests/typecheck/should_fail/T23739b.stderr - testsuite/tests/typecheck/should_fail/T23739c.stderr - testsuite/tests/typecheck/should_fail/T9497d.stderr - testsuite/tests/typecheck/should_fail/tcfail037.stderr - testsuite/tests/typecheck/should_run/T9497a-run.stderr - testsuite/tests/typecheck/should_run/T9497b-run.stderr - testsuite/tests/typecheck/should_run/T9497c-run.stderr - testsuite/tests/vdq-rta/should_fail/T23738_fail_pun.stderr - utils/check-exact/Main.hs - utils/check-exact/Preprocess.hs - utils/deriveConstants/Main.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs - utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/19596062d4b721039e6e2a1b2e6292… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/19596062d4b721039e6e2a1b2e6292… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sol/remove-ddump-json] 6 commits: Add SrcSpan to MCDiagnostic
by Simon Hengel (＠sol) 22 Aug '25

22 Aug '25

Simon Hengel pushed to branch wip/sol/remove-ddump-json at Glasgow Haskell Compiler / GHC Commits: 6188871b by Simon Hengel at 2025-08-22T22:29:11+07:00 Add SrcSpan to MCDiagnostic - - - - - a05761aa by Simon Hengel at 2025-08-22T22:29:19+07:00 Refactoring: More consistently use logOutput, logInfo, fatalErrorMsg - - - - - b11ad603 by Simon Hengel at 2025-08-22T22:29:19+07:00 Get rid of mkLocMessage - - - - - a45d2551 by Simon Hengel at 2025-08-22T22:30:01+07:00 Add Message data type - - - - - 97bb1ca0 by Simon Hengel at 2025-08-22T22:41:01+07:00 Get rid of MessageClass - - - - - 19596062 by Simon Hengel at 2025-08-22T22:48:55+07:00 Remove JSON logging - - - - - 21 changed files: - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Errors.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Monad.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Pipeline/LogQueue.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Runtime/Debugger.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Utils/Error.hs - compiler/GHC/Utils/Logger.hs - ghc/GHCi/UI.hs - testsuite/tests/ghc-api/T7478/T7478.hs - testsuite/tests/plugins/hooks-plugin/Hooks/LogPlugin.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/Core/Opt/Monad.hs ===================================== @@ -362,19 +362,22 @@ we aren't using annotations heavily. ************************************************************************ -} -msg :: MessageClass -> SDoc -> CoreM () -msg msg_class doc = do +msg :: Message -> CoreM () +msg msg = do logger <- getLogger - loc <- getSrcSpanM name_ppr_ctx <- getNamePprCtx - let sty = case msg_class of - MCDiagnostic _ _ _ -> err_sty - MCDump -> dump_sty - _ -> user_sty - err_sty = mkErrStyle name_ppr_ctx - user_sty = mkUserStyle name_ppr_ctx AllTheWay - dump_sty = mkDumpStyle name_ppr_ctx - liftIO $ logMsg logger msg_class loc (withPprStyle sty doc) + let m = case msg of + MCDump doc -> MCDump (dump_sty doc) + UnsafeMCDiagnostic span severity reason code doc diagnostic -> UnsafeMCDiagnostic span severity reason code (err_sty doc) diagnostic + MCOutput doc -> MCOutput (user_sty doc) + MCFatal doc -> MCFatal (user_sty doc) + MCInteractive doc -> MCInteractive (user_sty doc) + MCInfo doc -> MCInfo (user_sty doc) + + err_sty = withPprStyle $ mkErrStyle name_ppr_ctx + user_sty = withPprStyle $ mkUserStyle name_ppr_ctx AllTheWay + dump_sty = withPprStyle $ mkDumpStyle name_ppr_ctx + liftIO $ logMsg logger m -- | Output a String message to the screen putMsgS :: String -> CoreM () @@ -382,7 +385,7 @@ putMsgS = putMsg . text -- | Output a message to the screen putMsg :: SDoc -> CoreM () -putMsg = msg MCInfo +putMsg = msg . MCInfo diagnostic :: DiagnosticReason -> SDoc -> CoreM () diagnostic reason doc = do @@ -407,7 +410,7 @@ fatalErrorMsgS = fatalErrorMsg . text -- | Output a fatal error to the screen. Does not cause the compiler to die. fatalErrorMsg :: SDoc -> CoreM () -fatalErrorMsg = msg MCFatal +fatalErrorMsg = msg . MCFatal -- | Output a string debugging message at verbosity level of @-v@ or higher debugTraceMsgS :: String -> CoreM () @@ -415,4 +418,4 @@ debugTraceMsgS = debugTraceMsg . text -- | Outputs a debugging message at verbosity level of @-v@ or higher debugTraceMsg :: SDoc -> CoreM () -debugTraceMsg = msg MCDump +debugTraceMsg = msg . MCDump ===================================== 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/Errors.hs ===================================== @@ -46,19 +46,16 @@ printMessages logger msg_opts opts = mapM_ (printMessage logger msg_opts opts) . sortMessages = sortMsgBag (Just opts) . getMessages printMessage :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> MsgEnvelope a -> IO () -printMessage logger msg_opts opts message - | log_diags_as_json = do - decorated <- decorateDiagnostic logflags messageClass location doc - let - rendered :: String - rendered = renderWithContext (log_default_user_context logflags) decorated - - jsonMessage :: JsonDoc - jsonMessage = jsonDiagnostic rendered message +printMessage logger msg_opts opts message = do + decorated <- decorateDiagnostic logflags location severity reason code doc + let + rendered :: String + rendered = renderWithContext (log_default_user_context logflags) decorated - logJsonMsg logger messageClass jsonMessage + jsonMessage :: JsonDoc + jsonMessage = jsonDiagnostic rendered message - | otherwise = logMsg logger messageClass location doc + logMsg logger $ UnsafeMCDiagnostic location severity reason code decorated jsonMessage where logflags :: LogFlags logflags = logFlags logger @@ -66,9 +63,6 @@ printMessage logger msg_opts opts message doc :: SDoc doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic) - messageClass :: MessageClass - messageClass = UnsafeMCDiagnostic severity (errMsgReason message) (diagnosticCode diagnostic) - style :: PprStyle style = mkErrStyle (errMsgContext message) @@ -84,6 +78,12 @@ printMessage logger msg_opts opts message severity :: Severity severity = errMsgSeverity message + reason :: ResolvedDiagnosticReason + reason = errMsgReason message + + code :: Maybe DiagnosticCode + code = diagnosticCode diagnostic + messageWithHints :: a -> SDoc messageWithHints e = let main_msg = formatBulleted $ diagnosticMessage msg_opts e @@ -93,8 +93,22 @@ printMessage logger msg_opts opts message hs -> main_msg $$ hang (text "Suggested fixes:") 2 (formatBulleted $ mkDecorated . map ppr $ hs) - log_diags_as_json :: Bool - log_diags_as_json = log_diagnostics_as_json (logFlags logger) +decorateDiagnostic :: LogFlags -> SrcSpan -> Severity -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> SDoc -> IO SDoc +decorateDiagnostic logflags span severity reason code doc = addCaret + where + -- Pretty print the warning flag, if any (#10752) + message :: SDoc + message = formatDiagnostic (log_show_warn_groups logflags) span severity reason code doc + + addCaret :: IO SDoc + addCaret = do + caretDiagnostic <- + if log_show_caret logflags + then getCaretDiagnostic severity span + else pure empty + return $ getPprStyle $ \style -> + withPprStyle (setStyleColoured True style) + (message $+$ caretDiagnostic $+$ blankLine) -- | Given a bag of diagnostics, turn them into an exception if -- any has 'SevError', or print them out otherwise. ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -1835,7 +1835,7 @@ markUnsafeInfer tcg_env whyUnsafe = do ] badFlags df = concatMap (badFlag df) unsafeFlagsForInfer badFlag df (ext,loc,on,_) - | on df = [mkLocMessage MCOutput (loc df) $ + | on df = [formatLocMessage (loc df) $ text "-X" <> ppr ext <+> text "is not allowed in Safe Haskell"] | otherwise = [] badInsts insts = concatMap badInst insts @@ -1844,9 +1844,10 @@ markUnsafeInfer tcg_env whyUnsafe = do checkOverlap _ = True badInst ins | checkOverlap (overlapMode (is_flag ins)) - = [mkLocMessage MCOutput (nameSrcSpan $ getName $ is_dfun ins) $ + = [formatLocMessage (nameSrcSpan $ getName $ is_dfun ins) $ ppr (overlapMode $ is_flag ins) <+> - text "overlap mode isn't allowed in Safe Haskell"] + text "overlap mode isn't allowed in Safe Haskell" + ] | otherwise = [] -- | Figure out the final correct safe haskell mode ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -1442,14 +1442,14 @@ withDeferredDiagnostics f = do fatals <- liftIO $ newIORef [] logger <- getLogger - let deferDiagnostics _dflags !msgClass !srcSpan !msg = do - let action = logMsg logger msgClass srcSpan msg - case msgClass of - MCDiagnostic SevWarning _reason _code + let deferDiagnostics _dflags !msg = do + let action = logMsg logger msg + case msg of + MCDiagnostic _ SevWarning _reason _code -> atomicModifyIORef' warnings $ \(!i) -> (action: i, ()) - MCDiagnostic SevError _reason _code + MCDiagnostic _ SevError _reason _code -> atomicModifyIORef' errors $ \(!i) -> (action: i, ()) - MCFatal + MCFatal _ -> atomicModifyIORef' fatals $ \(!i) -> (action: i, ()) _ -> action ===================================== compiler/GHC/Driver/Monad.hs ===================================== @@ -23,8 +23,6 @@ module GHC.Driver.Monad ( modifyLogger, pushLogHookM, popLogHookM, - pushJsonLogHookM, - popJsonLogHookM, putLogMsgM, putMsgM, withTimingM, @@ -47,7 +45,6 @@ import GHC.Utils.Exception import GHC.Utils.Error import GHC.Utils.Logger -import GHC.Types.SrcLoc import GHC.Types.SourceError import Control.Monad @@ -123,12 +120,6 @@ pushLogHookM = modifyLogger . pushLogHook popLogHookM :: GhcMonad m => m () popLogHookM = modifyLogger popLogHook -pushJsonLogHookM :: GhcMonad m => (LogJsonAction -> LogJsonAction) -> m () -pushJsonLogHookM = modifyLogger . pushJsonLogHook - -popJsonLogHookM :: GhcMonad m => m () -popJsonLogHookM = modifyLogger popJsonLogHook - -- | Put a log message putMsgM :: GhcMonad m => SDoc -> m () putMsgM doc = do @@ -136,10 +127,10 @@ putMsgM doc = do liftIO $ putMsg logger doc -- | Put a log message -putLogMsgM :: GhcMonad m => MessageClass -> SrcSpan -> SDoc -> m () -putLogMsgM msg_class loc doc = do +putLogMsgM :: GhcMonad m => Message -> m () +putLogMsgM message = do logger <- getLogger - liftIO $ logMsg logger msg_class loc doc + liftIO $ logMsg logger message -- | Time an action withTimingM :: GhcMonad m => SDoc -> (b -> ()) -> m b -> m b ===================================== 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/Driver/Pipeline/LogQueue.hs ===================================== @@ -18,7 +18,6 @@ import GHC.Prelude import Control.Concurrent import Data.IORef import GHC.Types.Error -import GHC.Types.SrcLoc import GHC.Utils.Logger import qualified Data.IntMap as IM import Control.Concurrent.STM @@ -30,7 +29,7 @@ import Control.Monad -- to. A 'Nothing' value contains the result of compilation, and denotes the -- end of the message queue. data LogQueue = LogQueue { logQueueId :: !Int - , logQueueMessages :: !(IORef [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]) + , logQueueMessages :: !(IORef [Maybe (Message, LogFlags)]) , logQueueSemaphore :: !(MVar ()) } @@ -45,12 +44,12 @@ finishLogQueue lq = do writeLogQueueInternal lq Nothing -writeLogQueue :: LogQueue -> (MessageClass,SrcSpan,SDoc, LogFlags) -> IO () +writeLogQueue :: LogQueue -> (Message, LogFlags) -> IO () writeLogQueue lq msg = do writeLogQueueInternal lq (Just msg) -- | Internal helper for writing log messages -writeLogQueueInternal :: LogQueue -> Maybe (MessageClass,SrcSpan,SDoc, LogFlags) -> IO () +writeLogQueueInternal :: LogQueue -> Maybe (Message, LogFlags) -> IO () writeLogQueueInternal (LogQueue _n ref sem) msg = do atomicModifyIORef' ref $ \msgs -> (msg:msgs,()) _ <- tryPutMVar sem () @@ -59,8 +58,8 @@ writeLogQueueInternal (LogQueue _n ref sem) msg = do -- The log_action callback that is used to synchronize messages from a -- worker thread. parLogAction :: LogQueue -> LogAction -parLogAction log_queue log_flags !msgClass !srcSpan !msg = - writeLogQueue log_queue (msgClass,srcSpan,msg, log_flags) +parLogAction log_queue log_flags !msg = + writeLogQueue log_queue (msg, log_flags) -- Print each message from the log_queue using the global logger printLogs :: Logger -> LogQueue -> IO () @@ -72,8 +71,8 @@ printLogs !logger (LogQueue _n ref sem) = read_msgs print_loop [] = read_msgs print_loop (x:xs) = case x of - Just (msgClass,srcSpan,msg,flags) -> do - logMsg (setLogFlags logger flags) msgClass srcSpan msg + Just (msg,flags) -> do + logMsg (setLogFlags logger flags) msg print_loop xs -- Exit the loop once we encounter the end marker. Nothing -> return () ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -94,7 +94,6 @@ import GHC.Types.SourceFile import GHC.Types.SafeHaskell import GHC.Types.TypeEnv import GHC.Types.Unique.DSet -import GHC.Types.SrcLoc import GHC.Types.TyThing import GHC.Types.PkgQual @@ -1105,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. @@ -1119,7 +1118,7 @@ showIface logger dflags unit_state name_cache filename = do neverQualifyModules neverQualifyPackages alwaysPrintPromTick - logMsg logger MCDump noSrcSpan + logMsg logger $ MCDump $ withPprStyle (mkDumpStyle name_ppr_ctx) $ pprModIface unit_state iface ===================================== compiler/GHC/Linker/Deps.hs ===================================== @@ -25,6 +25,7 @@ import GHC.Linker.Types import GHC.Types.SrcLoc import GHC.Types.Unique.DSet import GHC.Types.Unique.DFM +import GHC.Types.Error (formatFatalLocMessage) import GHC.Utils.Outputable import GHC.Utils.Panic @@ -231,7 +232,7 @@ splice point about what we would prefer. -} dieWith :: LinkDepsOpts -> SrcSpan -> SDoc -> IO a -dieWith opts span msg = throwProgramError opts (mkLocMessage MCFatal span msg) +dieWith opts span msg = throwProgramError opts (formatFatalLocMessage span msg) throwProgramError :: LinkDepsOpts -> SDoc -> IO a throwProgramError opts doc = throwGhcExceptionIO (ProgramError (renderWithContext (ldPprOpts opts) doc)) ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -507,7 +507,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 @@ -1638,9 +1638,8 @@ addEnvPaths name list maybePutSDoc :: Logger -> SDoc -> IO () maybePutSDoc logger s = when (logVerbAtLeast logger 2) $ - logMsg logger + logMsg logger $ MCInteractive - noSrcSpan $ withPprStyle defaultUserStyle s maybePutStr :: Logger -> String -> IO () ===================================== compiler/GHC/Runtime/Debugger.hs ===================================== @@ -209,7 +209,7 @@ showTerm term = do setSession new_env -- this disables logging of errors - let noop_log _ _ _ _ = return () + let noop_log _ _ = return () pushLogHookM (const noop_log) return (hsc_env, bname) ===================================== 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 ===================================== @@ -864,7 +864,7 @@ wrapDocLoc doc = do if logHasDumpFlag logger Opt_D_ppr_debug then do loc <- getSrcSpanM - return (mkLocMessage MCOutput loc doc) + return (formatLocMessage loc doc) else return doc @@ -2343,8 +2343,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 -------------------- @@ -2376,10 +2375,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" } } ===================================== compiler/GHC/Types/Error.hs ===================================== @@ -26,7 +26,7 @@ module GHC.Types.Error -- * Classifying Messages - , MessageClass (MCDiagnostic, ..) + , Message (MCDiagnostic, ..) , Severity (..) , Diagnostic (..) , UnknownDiagnostic (..) @@ -70,8 +70,8 @@ module GHC.Types.Error , mapDecoratedSDoc , pprMessageBag - , mkLocMessage - , mkLocMessageWarningGroups + , formatLocMessage + , formatFatalLocMessage , formatDiagnostic , getCaretDiagnostic @@ -479,22 +479,22 @@ data MsgEnvelope e = MsgEnvelope -- | The class for a diagnostic message. The main purpose is to classify a -- message within GHC, to distinguish it from a debug/dump message vs a proper -- diagnostic, for which we include a 'DiagnosticReason'. -data MessageClass - = MCOutput - | MCFatal - | MCInteractive +data Message + = MCOutput SDoc + | MCFatal SDoc + | MCInteractive SDoc - | MCDump + | MCDump SDoc -- ^ Log message intended for compiler developers -- No file\/line\/column stuff - | MCInfo + | MCInfo SDoc -- ^ Log messages intended for end users. -- No file\/line\/column stuff. - | UnsafeMCDiagnostic Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) + | UnsafeMCDiagnostic SrcSpan Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) SDoc JsonDoc -- ^ Diagnostics from the compiler. This constructor is very powerful as - -- it allows the construction of a 'MessageClass' with a completely + -- it allows the construction of a 'Message' with a completely -- arbitrary permutation of 'Severity' and 'DiagnosticReason'. As such, -- users are encouraged to use higher level primitives -- instead. Use this constructor directly only if you need to construct @@ -508,8 +508,8 @@ data MessageClass -- should always have a 'DiagnosticCode'. See Note [Diagnostic codes]. {-# COMPLETE MCOutput, MCFatal, MCInteractive, MCDump, MCInfo, MCDiagnostic #-} -pattern MCDiagnostic :: Severity -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> MessageClass -pattern MCDiagnostic severity reason code <- UnsafeMCDiagnostic severity reason code +pattern MCDiagnostic :: SrcSpan -> Severity -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> Message +pattern MCDiagnostic span severity reason code <- UnsafeMCDiagnostic span severity reason code _diagnostic _json {- Note [Suppressing Messages] @@ -538,9 +538,6 @@ the "SevIgnore one" for a number of reasons: -- | Used to describe warnings and errors --- o The message has a file\/line\/column heading, --- plus "warning:" or "error:", --- added by mkLocMessage -- o With 'SevIgnore' the message is suppressed -- o Output is intended for end users data Severity @@ -637,35 +634,14 @@ showMsgEnvelope err = pprMessageBag :: Bag SDoc -> SDoc pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) -mkLocMessage - :: MessageClass -- ^ What kind of message? - -> SrcSpan -- ^ location - -> SDoc -- ^ message - -> SDoc -mkLocMessage = mkLocMessageWarningGroups True - --- | Make an error message with location info, specifying whether to show --- warning groups (if applicable). -mkLocMessageWarningGroups - :: Bool -- ^ Print warning groups (if applicable)? - -> MessageClass -- ^ What kind of message? - -> SrcSpan -- ^ location - -> SDoc -- ^ message - -> SDoc -mkLocMessageWarningGroups show_warn_groups msg_class locn msg - = case msg_class of - MCDiagnostic severity reason code -> formatDiagnostic show_warn_groups locn severity reason code msg - _ -> sdocOption sdocColScheme $ \col_scheme -> - let - msg_colour = getMessageClassColour msg_class col_scheme - - msg_title = coloured msg_colour $ - case msg_class of - MCFatal -> text "fatal" - _ -> empty - +formatFatalLocMessage :: SrcSpan -> SDoc -> SDoc +formatFatalLocMessage locn msg = sdocOption sdocColScheme $ \col_scheme -> + let msg_title = coloured (Col.sFatal col_scheme) $ text "fatal" in formatLocMessageWarningGroups locn msg_title empty empty msg +formatLocMessage :: SrcSpan -> SDoc -> SDoc +formatLocMessage span = formatLocMessageWarningGroups span empty empty empty + formatDiagnostic :: Bool -- ^ Print warning groups? -> SrcSpan -- ^ location @@ -775,13 +751,7 @@ formatLocMessageWarningGroups locn msg_title code_doc warning_flag_doc msg code_doc <+> warning_flag_doc in coloured (Col.sMessage col_scheme) - (hang (coloured (Col.sHeader col_scheme) header) 4 - msg) - -getMessageClassColour :: MessageClass -> Col.Scheme -> Col.PprColour -getMessageClassColour (MCDiagnostic severity _reason _code) = getSeverityColour severity -getMessageClassColour MCFatal = Col.sFatal -getMessageClassColour _ = const mempty + $ hang (coloured (Col.sHeader col_scheme) header) 4 msg getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour getSeverityColour severity = case severity of @@ -789,9 +759,9 @@ getSeverityColour severity = case severity of SevWarning -> Col.sWarning SevIgnore -> const mempty -getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc +getCaretDiagnostic :: Severity -> SrcSpan -> IO SDoc getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty -getCaretDiagnostic msg_class (RealSrcSpan span _) = +getCaretDiagnostic severity (RealSrcSpan span _) = caretDiagnostic <$> getSrcLine (srcSpanFile span) row where getSrcLine fn i = @@ -824,7 +794,7 @@ getCaretDiagnostic msg_class (RealSrcSpan span _) = caretDiagnostic Nothing = empty caretDiagnostic (Just srcLineWithNewline) = sdocOption sdocColScheme$ \col_scheme -> - let sevColour = getMessageClassColour msg_class col_scheme + let sevColour = getSeverityColour severity col_scheme marginColour = Col.sMargin col_scheme in coloured marginColour (text marginSpace) <> ===================================== compiler/GHC/Utils/Error.hs ===================================== @@ -14,7 +14,7 @@ module GHC.Utils.Error ( -- * Messages Diagnostic(..), MsgEnvelope(..), - MessageClass(..), + Message(..), SDoc, DecoratedSDoc(unDecorated), Messages, @@ -28,7 +28,7 @@ module GHC.Utils.Error ( -- ** Construction DiagOpts (..), emptyDiagOpts, diag_wopt, diag_fatal_wopt, - emptyMessages, mkDecorated, mkLocMessage, + emptyMessages, mkDecorated, mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope, mkErrorMsgEnvelope, mkLintWarning, diagReasonSeverity, @@ -282,9 +282,8 @@ unsafePprLocMsgEnvelope opts (MsgEnvelope { errMsgSpan = s , errMsgContext = name_ppr_ctx , errMsgReason = reason }) = withErrStyle name_ppr_ctx $ - mkLocMessage - (UnsafeMCDiagnostic sev reason (diagnosticCode e)) - s + formatDiagnostic True + s sev reason (diagnosticCode e) (formatBulleted $ diagnosticMessage opts e) sortMsgBag :: Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e] @@ -314,7 +313,7 @@ ghcExit logger val fatalErrorMsg :: Logger -> SDoc -> IO () fatalErrorMsg logger msg = - logMsg logger MCFatal noSrcSpan $ withPprStyle defaultErrStyle msg + logMsg logger $ MCFatal (withPprStyle defaultErrStyle msg) compilationProgressMsg :: Logger -> SDoc -> IO () compilationProgressMsg logger msg = do @@ -475,11 +474,11 @@ printOutputForUser logger name_ppr_ctx msg = logOutput logger (withUserStyle name_ppr_ctx AllTheWay msg) logInfo :: Logger -> SDoc -> IO () -logInfo logger msg = logMsg logger MCInfo noSrcSpan msg +logInfo logger = logMsg logger . MCInfo -- | Like 'logInfo' but with 'SevOutput' rather then 'SevInfo' logOutput :: Logger -> SDoc -> IO () -logOutput logger msg = logMsg logger MCOutput noSrcSpan msg +logOutput logger = logMsg logger . MCOutput prettyPrintGhcErrors :: ExceptionMonad m => Logger -> m a -> m a ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -24,7 +24,6 @@ module GHC.Utils.Logger -- * Logger setup , initLogger , LogAction - , LogJsonAction , DumpAction , TraceAction , DumpFormat (..) @@ -32,8 +31,6 @@ module GHC.Utils.Logger -- ** Hooks , popLogHook , pushLogHook - , popJsonLogHook - , pushJsonLogHook , popDumpHook , pushDumpHook , popTraceHook @@ -55,15 +52,11 @@ module GHC.Utils.Logger , putLogMsg , defaultLogAction , defaultLogActionWithHandles - , defaultLogJsonAction , defaultLogActionHPrintDoc , defaultLogActionHPutStrDoc , logMsg - , logJsonMsg , logDumpMsg - , decorateDiagnostic - -- * Dumping , defaultDumpAction , putDumpFile @@ -85,12 +78,11 @@ where import GHC.Prelude import GHC.Driver.Flags import GHC.Types.Error -import GHC.Types.SrcLoc import qualified GHC.Utils.Ppr as Pretty import GHC.Utils.Outputable -import GHC.Utils.Json import GHC.Utils.Panic +import GHC.Utils.Json (renderJSON) import GHC.Data.EnumSet (EnumSet) import qualified GHC.Data.EnumSet as EnumSet @@ -181,16 +173,9 @@ setLogFlags logger flags = logger { logFlags = flags } --------------------------------------------------------------- type LogAction = LogFlags - -> MessageClass - -> SrcSpan - -> SDoc + -> Message -> IO () -type LogJsonAction = LogFlags - -> MessageClass - -> JsonDoc - -> IO () - type DumpAction = LogFlags -> PprStyle -> DumpFlag @@ -228,9 +213,6 @@ data Logger = Logger { log_hook :: [LogAction -> LogAction] -- ^ Log hooks stack - , json_log_hook :: [LogJsonAction -> LogJsonAction] - -- ^ Json log hooks stack - , dump_hook :: [DumpAction -> DumpAction] -- ^ Dump hooks stack @@ -266,7 +248,6 @@ initLogger = do dumps <- newMVar Map.empty return $ Logger { log_hook = [] - , json_log_hook = [] , dump_hook = [] , trace_hook = [] , generated_dumps = dumps @@ -278,10 +259,6 @@ initLogger = do putLogMsg :: Logger -> LogAction putLogMsg logger = foldr ($) defaultLogAction (log_hook logger) --- | Log a JsonDoc -putJsonLogMsg :: Logger -> LogJsonAction -putJsonLogMsg logger = foldr ($) defaultLogJsonAction (json_log_hook logger) - -- | Dump something putDumpFile :: Logger -> DumpAction putDumpFile logger = @@ -306,15 +283,6 @@ popLogHook logger = case log_hook logger of [] -> panic "popLogHook: empty hook stack" _:hs -> logger { log_hook = hs } --- | Push a json log hook -pushJsonLogHook :: (LogJsonAction -> LogJsonAction) -> Logger -> Logger -pushJsonLogHook h logger = logger { json_log_hook = h:json_log_hook logger } - -popJsonLogHook :: Logger -> Logger -popJsonLogHook logger = case json_log_hook logger of - [] -> panic "popJsonLogHook: empty hook stack" - _:hs -> logger { json_log_hook = hs} - -- | Push a dump hook pushDumpHook :: (DumpAction -> DumpAction) -> Logger -> Logger pushDumpHook h logger = logger { dump_hook = h:dump_hook logger } @@ -343,8 +311,8 @@ makeThreadSafe logger = do with_lock :: forall a. IO a -> IO a with_lock act = withMVar lock (const act) - log action logflags msg_class loc doc = - with_lock (action logflags msg_class loc doc) + log action logflags message = + with_lock (action logflags message) dmp action logflags sty opts str fmt doc = with_lock (action logflags sty opts str fmt doc) @@ -358,22 +326,6 @@ makeThreadSafe logger = do $ pushTraceHook trc $ logger -defaultLogJsonAction :: LogJsonAction -defaultLogJsonAction logflags msg_class jsdoc = - case msg_class of - MCOutput -> printOut msg - MCDump -> printOut (msg $$ blankLine) - MCInteractive -> putStrSDoc msg - MCInfo -> printErrs msg - MCFatal -> printErrs msg - MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message - MCDiagnostic _sev _rea _code -> printErrs msg - where - printOut = defaultLogActionHPrintDoc logflags False stdout - printErrs = defaultLogActionHPrintDoc logflags False stderr - putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout - msg = renderJSON jsdoc - -- | The default 'LogAction' prints to 'stdout' and 'stderr'. -- -- To replicate the default log action behaviour with different @out@ and @err@ @@ -384,71 +336,24 @@ defaultLogAction = defaultLogActionWithHandles stdout stderr -- | The default 'LogAction' parametrized over the standard output and standard error handles. -- Allows clients to replicate the log message formatting of GHC with custom handles. defaultLogActionWithHandles :: Handle {-^ Handle for standard output -} -> Handle {-^ Handle for standard errors -} -> LogAction -defaultLogActionWithHandles out err logflags msg_class srcSpan msg - = case msg_class of - MCOutput -> printOut msg - MCDump -> printOut (msg $$ blankLine) - MCInteractive -> putStrSDoc msg - MCInfo -> printErrs msg - MCFatal -> printErrs msg - MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message - MCDiagnostic _sev _rea _code -> decorateDiagnostic logflags msg_class srcSpan msg >>= printErrs +defaultLogActionWithHandles out err logflags message + = case message of + MCOutput msg -> printOut msg + MCDump msg -> printOut (msg $$ blankLine) + MCInteractive msg -> putStrSDoc msg + MCInfo msg -> printErrs msg + MCFatal msg -> printErrs msg + MCDiagnostic _ SevIgnore _ _ -> pure () -- suppress the message + UnsafeMCDiagnostic _span _severity _reason _code doc json -> do + if log_diagnostics_as_json logflags then do + printErrs (renderJSON json) + else do + printErrs doc where printOut = defaultLogActionHPrintDoc logflags False out printErrs = defaultLogActionHPrintDoc logflags False err putStrSDoc = defaultLogActionHPutStrDoc logflags False out --- This function is used by `defaultLogActionWithHandles` for non-JSON output, --- and also by `GHC.Driver.Errors.printMessages` to produce the `rendered` --- message on `-fdiagnostics-as-json`. --- --- We would want to eventually consolidate this. However, this is currently --- not feasible for the following reasons: --- --- 1. Some parts of the compiler sidestep `printMessages`, for that reason we --- can not decorate the message in `printMessages`. --- --- 2. GHC uses two different code paths for JSON and non-JSON diagnostics. For --- that reason we can not decorate the message in `defaultLogActionWithHandles`. --- --- See also Note [JSON Error Messages]: --- --- `jsonLogAction` should be removed along with -ddump-json --- --- Also note that (1) is the reason why some parts of the compiler produce --- diagnostics that don't respect `-fdiagnostics-as-json`. --- --- The plan as I see it is as follows: --- --- 1. Refactor all places in the compiler that report diagnostics to go --- through `GHC.Driver.Errors.printMessages`. --- --- (It's easy to find all those places by looking for who creates --- MCDiagnostic, either directly or via `mkMCDiagnostic` or --- `errorDiagnostic`.) --- --- 2. Get rid of `-ddump-json`, `jsonLogAction` and consolidate message --- decoration at one place (either `printMessages` or --- `defaultLogActionWithHandles`) --- --- This story is tracked by #24113. -decorateDiagnostic :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO SDoc -decorateDiagnostic logflags msg_class srcSpan msg = addCaret - where - -- Pretty print the warning flag, if any (#10752) - message :: SDoc - message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg - - addCaret :: IO SDoc - addCaret = do - caretDiagnostic <- - if log_show_caret logflags - then getCaretDiagnostic msg_class srcSpan - else pure empty - return $ getPprStyle $ \style -> - withPprStyle (setStyleColoured True style) - (message $+$ caretDiagnostic $+$ blankLine) - -- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline. defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO () defaultLogActionHPrintDoc logflags asciiSpace h d @@ -494,10 +399,10 @@ dumpSDocWithStyle dumps log_action sty logflags flag hdr doc = -- write the dump to stdout writeDump Nothing = do - let (doc', msg_class) - | null hdr = (doc, MCOutput) - | otherwise = (mkDumpDoc hdr doc, MCDump) - log_action logflags msg_class noSrcSpan (withPprStyle sty doc') + let message + | null hdr = MCOutput (withPprStyle sty doc) + | otherwise = MCDump (withPprStyle sty $ mkDumpDoc hdr doc) + log_action logflags message -- | Run an action with the handle of a 'DumpFlag' if we are outputting to a @@ -587,11 +492,8 @@ defaultTraceAction logflags title doc x = -- | Log something -logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO () -logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg - -logJsonMsg :: Logger -> MessageClass -> JsonDoc -> IO () -logJsonMsg logger mc = putJsonLogMsg logger (logFlags logger) mc +logMsg :: Logger -> Message -> IO () +logMsg logger = putLogMsg logger (logFlags logger) -- | Dump something logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () @@ -603,7 +505,7 @@ logTraceMsg logger hdr doc a = putTraceMsg logger (logFlags logger) hdr doc a -- | Log a dump message (not a dump file) logDumpMsg :: Logger -> String -> SDoc -> IO () -logDumpMsg logger hdr doc = logMsg logger MCDump noSrcSpan +logDumpMsg logger hdr doc = logMsg logger $ MCDump (withPprStyle defaultDumpStyle (mkDumpDoc hdr doc)) ===================================== ghc/GHCi/UI.hs ===================================== @@ -833,10 +833,10 @@ resetLastErrorLocations = do ghciLogAction :: IORef [(FastString, Int)] -> LogAction -> LogAction ghciLogAction lastErrLocations old_log_action - dflags msg_class srcSpan msg = do - old_log_action dflags msg_class srcSpan msg - case msg_class of - MCDiagnostic SevError _reason _code -> case srcSpan of + dflags msg = do + old_log_action dflags msg + case msg of + MCDiagnostic srcSpan SevError _reason _code -> case srcSpan of RealSrcSpan rsp _ -> modifyIORef lastErrLocations (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))]) _ -> return () ===================================== testsuite/tests/ghc-api/T7478/T7478.hs ===================================== @@ -24,11 +24,11 @@ compileInGhc targets handlerOutput = do flags0 <- getSessionDynFlags let flags = flags0 {verbosity = 1 } setSessionDynFlags flags - let collectSrcError handlerOutput _flags MCOutput _srcspan msg + let collectSrcError _flags (MCOutput msg) = handlerOutput $ GHC.showSDocForUser flags emptyUnitState alwaysQualify msg - collectSrcError _ _ _ _ _ + collectSrcError _ _ = return () - pushLogHookM (const (collectSrcError handlerOutput)) + pushLogHookM (const collectSrcError) -- Set up targets. oldTargets <- getTargets let oldFiles = map fileFromTarget oldTargets ===================================== testsuite/tests/plugins/hooks-plugin/Hooks/LogPlugin.hs ===================================== @@ -19,6 +19,6 @@ hooksP opts hsc_env = do return hsc_env' logHook :: LogAction -> LogAction -logHook action logFlags messageClass srcSpan msgDoc = do +logHook action logFlags message = do putStrLn "Log hook called" - action logFlags messageClass srcSpan msgDoc + action logFlags message View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/95790a5cf4ed5599112f405c29b609… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/95790a5cf4ed5599112f405c29b609… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/remove-stg_stackDecode] 4 commits: Move stack decoding logic from ghc-heap to ghc-internal
by Hannes Siebenhandl (＠fendor) 22 Aug '25

22 Aug '25

Hannes Siebenhandl pushed to branch wip/fendor/remove-stg_stackDecode at Glasgow Haskell Compiler / GHC Commits: 8a6cdac4 by fendor at 2025-08-22T16:56:55+02:00 Move stack decoding logic from ghc-heap to ghc-internal The stack decoding logic in `ghc-heap` is more sophisticated than the one currently employed in `CloneStack`. We want to use the stack decoding implementation from `ghc-heap` in `base`. We cannot simply depend on `ghc-heap` in `base` due do bootstrapping issues. Thus, we move the code that is necessary to implement stack decoding to `ghc-internal`. This is the right location, as we don't want to add a new API to `base`. Moving the stack decoding logic and re-exposing it in ghc-heap is insufficient, though, as we have a dependency cycle between. * ghc-heap depends on stage1:ghc-internal * stage0:ghc depends on stage0:ghc-heap To fix this, we remove ghc-heap from the set of `stage0` dependencies. This is not entirely straight-forward, as a couple of boot dependencies, such as `ghci` depend on `ghc-heap`. Luckily, the boot compiler of GHC is now >=9.10, so we can migrate `ghci` to use `ghc-internal` instead of `ghc-heap`, which already exports the relevant modules. However, we cannot 100% remove ghc's dependency on `ghc-heap`, since when we compile `stage0:ghc`, `stage1:ghc-internal` is not yet available. Thus, when we compile with the boot-compiler, we still depend on an older version of `ghc-heap`, and only use the modules from `ghc-internal`, if the `ghc-internal` version is recent enough. ------------------------- Metric Increase: size_hello_artifact size_hello_artifact_gzip size_hello_unicode size_hello_unicode_gzip ------------------------- These metric increases are unfortunate, they are most likely caused by the larger (literally in terms of lines of code) stack decoder implementation that are now linked into hello-word binaries. On linux, it is almost a 10% increase, which is considerable. - - - - - 9310dfba by fendor at 2025-08-22T16:56:55+02:00 Implement `decode` in terms of `decodeStackWithIpe` Uses the more efficient stack decoder implementation. - - - - - 54459e4b by fendor at 2025-08-22T16:56:55+02:00 Remove stg_decodeStackzh - - - - - b1ef001a by fendor at 2025-08-22T16:56:55+02:00 Remove ghcHeap from list of toolTargets - - - - - 53 changed files: - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Runtime/Heap/Inspect.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/ghc.cabal.in - hadrian/src/Rules/ToolArgs.hs - hadrian/src/Settings/Default.hs - libraries/base/src/GHC/Stack/CloneStack.hs - libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - + libraries/ghc-heap/GHC/Exts/Heap/Constants.hs - + libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hs - + libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hs - + libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hs - libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs - + libraries/ghc-heap/GHC/Exts/Stack/Constants.hs - libraries/ghc-heap/GHC/Exts/Stack/Decode.hs - libraries/ghc-heap/ghc-heap.cabal.in - libraries/ghc-heap/cbits/HeapPrim.cmm → libraries/ghc-internal/cbits/HeapPrim.cmm - libraries/ghc-heap/cbits/Stack.cmm → libraries/ghc-internal/cbits/Stack.cmm - libraries/ghc-internal/cbits/StackCloningDecoding.cmm - libraries/ghc-heap/cbits/Stack_c.c → libraries/ghc-internal/cbits/Stack_c.c - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/jsbits/base.js - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs - + libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs - libraries/ghc-heap/GHC/Exts/Heap/Constants.hsc → libraries/ghc-internal/src/GHC/Internal/Heap/Constants.hsc - libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc → libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc - libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc → libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable/Types.hsc - libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc → libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc - + libraries/ghc-internal/src/GHC/Internal/Heap/ProfInfo/Types.hs - libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs - libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc → libraries/ghc-internal/src/GHC/Internal/Stack/Constants.hsc - + libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - libraries/ghc-heap/tests/stack-annotation/Makefile → libraries/ghc-internal/tests/stack-annotation/Makefile - libraries/ghc-heap/tests/stack-annotation/TestUtils.hs → libraries/ghc-internal/tests/stack-annotation/TestUtils.hs - libraries/ghc-heap/tests/stack-annotation/all.T → libraries/ghc-internal/tests/stack-annotation/all.T - libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs → libraries/ghc-internal/tests/stack-annotation/ann_frame001.hs - libraries/ghc-heap/tests/stack-annotation/ann_frame001.stdout → libraries/ghc-internal/tests/stack-annotation/ann_frame001.stdout - libraries/ghc-heap/tests/stack-annotation/ann_frame002.hs → libraries/ghc-internal/tests/stack-annotation/ann_frame002.hs - libraries/ghc-heap/tests/stack-annotation/ann_frame002.stdout → libraries/ghc-internal/tests/stack-annotation/ann_frame002.stdout - libraries/ghc-heap/tests/stack-annotation/ann_frame003.hs → libraries/ghc-internal/tests/stack-annotation/ann_frame003.hs - libraries/ghc-heap/tests/stack-annotation/ann_frame003.stdout → libraries/ghc-internal/tests/stack-annotation/ann_frame003.stdout - libraries/ghc-heap/tests/stack-annotation/ann_frame004.hs → libraries/ghc-internal/tests/stack-annotation/ann_frame004.hs - libraries/ghc-heap/tests/stack-annotation/ann_frame004.stdout → libraries/ghc-internal/tests/stack-annotation/ann_frame004.stdout - libraries/ghci/GHCi/Message.hs - libraries/ghci/ghci.cabal.in - rts/CloneStack.c - rts/CloneStack.h - rts/RtsSymbols.c - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c727e33c30dbbea024a309d25adaba… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c727e33c30dbbea024a309d25adaba… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sol/remove-ddump-json] 8 commits: Remove -ddump-json (fixes #24113)
by Simon Hengel (＠sol) 22 Aug '25

22 Aug '25

Simon Hengel pushed to branch wip/sol/remove-ddump-json at Glasgow Haskell Compiler / GHC Commits: 961bb596 by Simon Hengel at 2025-08-22T21:38:01+07:00 Remove -ddump-json (fixes #24113) - - - - - e991a4f1 by Simon Hengel at 2025-08-22T21:38:01+07:00 Add SrcSpan to MCDiagnostic - - - - - 2aa43ad0 by Simon Hengel at 2025-08-22T21:38:01+07:00 Refactoring: More consistently use logOutput, logInfo, fatalErrorMsg - - - - - 54009c0e by Simon Hengel at 2025-08-22T21:38:01+07:00 Get rid of mkLocMessage - - - - - d8a4c402 by Simon Hengel at 2025-08-22T21:38:01+07:00 Add Message data type - - - - - 638ca476 by Simon Hengel at 2025-08-22T21:38:02+07:00 Get rid of MessageClass - - - - - 3c86056e by Simon Hengel at 2025-08-22T21:38:02+07:00 Remove JSON logging - - - - - 95790a5c by Simon Hengel at 2025-08-22T21:38:02+07:00 Update `testsuite/tests/plugins/hooks-plugin/Hooks/LogPlugin.hs` - - - - - 30 changed files: - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Errors.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Monad.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Pipeline/LogQueue.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Runtime/Debugger.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Utils/Error.hs - compiler/GHC/Utils/Logger.hs - docs/users_guide/debugging.rst - ghc/GHCi/UI.hs - testsuite/tests/driver/T16167.stderr - − testsuite/tests/driver/T16167.stdout - testsuite/tests/driver/all.T - testsuite/tests/driver/json2.stderr - − testsuite/tests/driver/json_dump.hs - − testsuite/tests/driver/json_dump.stderr - testsuite/tests/ghc-api/T7478/T7478.hs - testsuite/tests/plugins/hooks-plugin/Hooks/LogPlugin.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/Core/Opt/Monad.hs ===================================== @@ -362,19 +362,22 @@ we aren't using annotations heavily. ************************************************************************ -} -msg :: MessageClass -> SDoc -> CoreM () -msg msg_class doc = do +msg :: Message -> CoreM () +msg msg = do logger <- getLogger - loc <- getSrcSpanM name_ppr_ctx <- getNamePprCtx - let sty = case msg_class of - MCDiagnostic _ _ _ -> err_sty - MCDump -> dump_sty - _ -> user_sty - err_sty = mkErrStyle name_ppr_ctx - user_sty = mkUserStyle name_ppr_ctx AllTheWay - dump_sty = mkDumpStyle name_ppr_ctx - liftIO $ logMsg logger msg_class loc (withPprStyle sty doc) + let m = case msg of + MCDump doc -> MCDump (dump_sty doc) + UnsafeMCDiagnostic span severity reason code doc diagnostic -> UnsafeMCDiagnostic span severity reason code (err_sty doc) diagnostic + MCOutput doc -> MCOutput (user_sty doc) + MCFatal doc -> MCFatal (user_sty doc) + MCInteractive doc -> MCInteractive (user_sty doc) + MCInfo doc -> MCInfo (user_sty doc) + + err_sty = withPprStyle $ mkErrStyle name_ppr_ctx + user_sty = withPprStyle $ mkUserStyle name_ppr_ctx AllTheWay + dump_sty = withPprStyle $ mkDumpStyle name_ppr_ctx + liftIO $ logMsg logger m -- | Output a String message to the screen putMsgS :: String -> CoreM () @@ -382,7 +385,7 @@ putMsgS = putMsg . text -- | Output a message to the screen putMsg :: SDoc -> CoreM () -putMsg = msg MCInfo +putMsg = msg . MCInfo diagnostic :: DiagnosticReason -> SDoc -> CoreM () diagnostic reason doc = do @@ -407,7 +410,7 @@ fatalErrorMsgS = fatalErrorMsg . text -- | Output a fatal error to the screen. Does not cause the compiler to die. fatalErrorMsg :: SDoc -> CoreM () -fatalErrorMsg = msg MCFatal +fatalErrorMsg = msg . MCFatal -- | Output a string debugging message at verbosity level of @-v@ or higher debugTraceMsgS :: String -> CoreM () @@ -415,4 +418,4 @@ debugTraceMsgS = debugTraceMsg . text -- | Outputs a debugging message at verbosity level of @-v@ or higher debugTraceMsg :: SDoc -> CoreM () -debugTraceMsg = msg MCDump +debugTraceMsg = msg . MCDump ===================================== 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/Errors.hs ===================================== @@ -46,19 +46,16 @@ printMessages logger msg_opts opts = mapM_ (printMessage logger msg_opts opts) . sortMessages = sortMsgBag (Just opts) . getMessages printMessage :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> MsgEnvelope a -> IO () -printMessage logger msg_opts opts message - | log_diags_as_json = do - decorated <- decorateDiagnostic logflags messageClass location doc - let - rendered :: String - rendered = renderWithContext (log_default_user_context logflags) decorated - - jsonMessage :: JsonDoc - jsonMessage = jsonDiagnostic rendered message +printMessage logger msg_opts opts message = do + decorated <- decorateDiagnostic logflags location severity reason code doc + let + rendered :: String + rendered = renderWithContext (log_default_user_context logflags) decorated - logJsonMsg logger messageClass jsonMessage + jsonMessage :: JsonDoc + jsonMessage = jsonDiagnostic rendered message - | otherwise = logMsg logger messageClass location doc + logMsg logger $ UnsafeMCDiagnostic location severity reason code decorated jsonMessage where logflags :: LogFlags logflags = logFlags logger @@ -66,9 +63,6 @@ printMessage logger msg_opts opts message doc :: SDoc doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic) - messageClass :: MessageClass - messageClass = UnsafeMCDiagnostic severity (errMsgReason message) (diagnosticCode diagnostic) - style :: PprStyle style = mkErrStyle (errMsgContext message) @@ -84,6 +78,12 @@ printMessage logger msg_opts opts message severity :: Severity severity = errMsgSeverity message + reason :: ResolvedDiagnosticReason + reason = errMsgReason message + + code :: Maybe DiagnosticCode + code = diagnosticCode diagnostic + messageWithHints :: a -> SDoc messageWithHints e = let main_msg = formatBulleted $ diagnosticMessage msg_opts e @@ -93,8 +93,22 @@ printMessage logger msg_opts opts message hs -> main_msg $$ hang (text "Suggested fixes:") 2 (formatBulleted $ mkDecorated . map ppr $ hs) - log_diags_as_json :: Bool - log_diags_as_json = log_diagnostics_as_json (logFlags logger) +decorateDiagnostic :: LogFlags -> SrcSpan -> Severity -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> SDoc -> IO SDoc +decorateDiagnostic logflags span severity reason code doc = addCaret + where + -- Pretty print the warning flag, if any (#10752) + message :: SDoc + message = formatDiagnostic (log_show_warn_groups logflags) span severity reason code doc + + addCaret :: IO SDoc + addCaret = do + caretDiagnostic <- + if log_show_caret logflags + then getCaretDiagnostic severity span + else pure empty + return $ getPprStyle $ \style -> + withPprStyle (setStyleColoured True style) + (message $+$ caretDiagnostic $+$ blankLine) -- | Given a bag of diagnostics, turn them into an exception if -- any has 'SevError', or print them out otherwise. ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -526,7 +526,6 @@ data DumpFlag | Opt_D_dump_view_pattern_commoning | Opt_D_verbose_core2core | Opt_D_dump_debug - | Opt_D_dump_json | Opt_D_ppr_debug | Opt_D_no_debug_output | Opt_D_dump_faststrings ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -1835,7 +1835,7 @@ markUnsafeInfer tcg_env whyUnsafe = do ] badFlags df = concatMap (badFlag df) unsafeFlagsForInfer badFlag df (ext,loc,on,_) - | on df = [mkLocMessage MCOutput (loc df) $ + | on df = [formatLocMessage (loc df) $ text "-X" <> ppr ext <+> text "is not allowed in Safe Haskell"] | otherwise = [] badInsts insts = concatMap badInst insts @@ -1844,9 +1844,10 @@ markUnsafeInfer tcg_env whyUnsafe = do checkOverlap _ = True badInst ins | checkOverlap (overlapMode (is_flag ins)) - = [mkLocMessage MCOutput (nameSrcSpan $ getName $ is_dfun ins) $ + = [formatLocMessage (nameSrcSpan $ getName $ is_dfun ins) $ ppr (overlapMode $ is_flag ins) <+> - text "overlap mode isn't allowed in Safe Haskell"] + text "overlap mode isn't allowed in Safe Haskell" + ] | otherwise = [] -- | Figure out the final correct safe haskell mode ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -1442,14 +1442,14 @@ withDeferredDiagnostics f = do fatals <- liftIO $ newIORef [] logger <- getLogger - let deferDiagnostics _dflags !msgClass !srcSpan !msg = do - let action = logMsg logger msgClass srcSpan msg - case msgClass of - MCDiagnostic SevWarning _reason _code + let deferDiagnostics _dflags !msg = do + let action = logMsg logger msg + case msg of + MCDiagnostic _ SevWarning _reason _code -> atomicModifyIORef' warnings $ \(!i) -> (action: i, ()) - MCDiagnostic SevError _reason _code + MCDiagnostic _ SevError _reason _code -> atomicModifyIORef' errors $ \(!i) -> (action: i, ()) - MCFatal + MCFatal _ -> atomicModifyIORef' fatals $ \(!i) -> (action: i, ()) _ -> action ===================================== compiler/GHC/Driver/Monad.hs ===================================== @@ -23,8 +23,6 @@ module GHC.Driver.Monad ( modifyLogger, pushLogHookM, popLogHookM, - pushJsonLogHookM, - popJsonLogHookM, putLogMsgM, putMsgM, withTimingM, @@ -47,7 +45,6 @@ import GHC.Utils.Exception import GHC.Utils.Error import GHC.Utils.Logger -import GHC.Types.SrcLoc import GHC.Types.SourceError import Control.Monad @@ -123,12 +120,6 @@ pushLogHookM = modifyLogger . pushLogHook popLogHookM :: GhcMonad m => m () popLogHookM = modifyLogger popLogHook -pushJsonLogHookM :: GhcMonad m => (LogJsonAction -> LogJsonAction) -> m () -pushJsonLogHookM = modifyLogger . pushJsonLogHook - -popJsonLogHookM :: GhcMonad m => m () -popJsonLogHookM = modifyLogger popJsonLogHook - -- | Put a log message putMsgM :: GhcMonad m => SDoc -> m () putMsgM doc = do @@ -136,10 +127,10 @@ putMsgM doc = do liftIO $ putMsg logger doc -- | Put a log message -putLogMsgM :: GhcMonad m => MessageClass -> SrcSpan -> SDoc -> m () -putLogMsgM msg_class loc doc = do +putLogMsgM :: GhcMonad m => Message -> m () +putLogMsgM message = do logger <- getLogger - liftIO $ logMsg logger msg_class loc doc + liftIO $ logMsg logger message -- | Time an action withTimingM :: GhcMonad m => SDoc -> (b -> ()) -> m b -> m b ===================================== 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/Driver/Pipeline/LogQueue.hs ===================================== @@ -18,7 +18,6 @@ import GHC.Prelude import Control.Concurrent import Data.IORef import GHC.Types.Error -import GHC.Types.SrcLoc import GHC.Utils.Logger import qualified Data.IntMap as IM import Control.Concurrent.STM @@ -30,7 +29,7 @@ import Control.Monad -- to. A 'Nothing' value contains the result of compilation, and denotes the -- end of the message queue. data LogQueue = LogQueue { logQueueId :: !Int - , logQueueMessages :: !(IORef [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]) + , logQueueMessages :: !(IORef [Maybe (Message, LogFlags)]) , logQueueSemaphore :: !(MVar ()) } @@ -45,12 +44,12 @@ finishLogQueue lq = do writeLogQueueInternal lq Nothing -writeLogQueue :: LogQueue -> (MessageClass,SrcSpan,SDoc, LogFlags) -> IO () +writeLogQueue :: LogQueue -> (Message, LogFlags) -> IO () writeLogQueue lq msg = do writeLogQueueInternal lq (Just msg) -- | Internal helper for writing log messages -writeLogQueueInternal :: LogQueue -> Maybe (MessageClass,SrcSpan,SDoc, LogFlags) -> IO () +writeLogQueueInternal :: LogQueue -> Maybe (Message, LogFlags) -> IO () writeLogQueueInternal (LogQueue _n ref sem) msg = do atomicModifyIORef' ref $ \msgs -> (msg:msgs,()) _ <- tryPutMVar sem () @@ -59,8 +58,8 @@ writeLogQueueInternal (LogQueue _n ref sem) msg = do -- The log_action callback that is used to synchronize messages from a -- worker thread. parLogAction :: LogQueue -> LogAction -parLogAction log_queue log_flags !msgClass !srcSpan !msg = - writeLogQueue log_queue (msgClass,srcSpan,msg, log_flags) +parLogAction log_queue log_flags !msg = + writeLogQueue log_queue (msg, log_flags) -- Print each message from the log_queue using the global logger printLogs :: Logger -> LogQueue -> IO () @@ -72,8 +71,8 @@ printLogs !logger (LogQueue _n ref sem) = read_msgs print_loop [] = read_msgs print_loop (x:xs) = case x of - Just (msgClass,srcSpan,msg,flags) -> do - logMsg (setLogFlags logger flags) msgClass srcSpan msg + Just (msg,flags) -> do + logMsg (setLogFlags logger flags) msg print_loop xs -- Exit the loop once we encounter the end marker. Nothing -> return () ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -1657,9 +1657,6 @@ dynamic_flags_deps = [ (NoArg (setGeneralFlag Opt_NoTypeableBinds)) , make_ord_flag defGhcFlag "ddump-debug" (setDumpFlag Opt_D_dump_debug) - , make_dep_flag defGhcFlag "ddump-json" - (setDumpFlag Opt_D_dump_json) - "Use `-fdiagnostics-as-json` instead" , make_ord_flag defGhcFlag "dppr-debug" (setDumpFlag Opt_D_ppr_debug) , make_ord_flag defGhcFlag "ddebug-output" ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -94,7 +94,6 @@ import GHC.Types.SourceFile import GHC.Types.SafeHaskell import GHC.Types.TypeEnv import GHC.Types.Unique.DSet -import GHC.Types.SrcLoc import GHC.Types.TyThing import GHC.Types.PkgQual @@ -1105,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. @@ -1119,7 +1118,7 @@ showIface logger dflags unit_state name_cache filename = do neverQualifyModules neverQualifyPackages alwaysPrintPromTick - logMsg logger MCDump noSrcSpan + logMsg logger $ MCDump $ withPprStyle (mkDumpStyle name_ppr_ctx) $ pprModIface unit_state iface ===================================== compiler/GHC/Linker/Deps.hs ===================================== @@ -25,6 +25,7 @@ import GHC.Linker.Types import GHC.Types.SrcLoc import GHC.Types.Unique.DSet import GHC.Types.Unique.DFM +import GHC.Types.Error (formatFatalLocMessage) import GHC.Utils.Outputable import GHC.Utils.Panic @@ -231,7 +232,7 @@ splice point about what we would prefer. -} dieWith :: LinkDepsOpts -> SrcSpan -> SDoc -> IO a -dieWith opts span msg = throwProgramError opts (mkLocMessage MCFatal span msg) +dieWith opts span msg = throwProgramError opts (formatFatalLocMessage span msg) throwProgramError :: LinkDepsOpts -> SDoc -> IO a throwProgramError opts doc = throwGhcExceptionIO (ProgramError (renderWithContext (ldPprOpts opts) doc)) ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -507,7 +507,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 @@ -1638,9 +1638,8 @@ addEnvPaths name list maybePutSDoc :: Logger -> SDoc -> IO () maybePutSDoc logger s = when (logVerbAtLeast logger 2) $ - logMsg logger + logMsg logger $ MCInteractive - noSrcSpan $ withPprStyle defaultUserStyle s maybePutStr :: Logger -> String -> IO () ===================================== compiler/GHC/Runtime/Debugger.hs ===================================== @@ -209,7 +209,7 @@ showTerm term = do setSession new_env -- this disables logging of errors - let noop_log _ _ _ _ = return () + let noop_log _ _ = return () pushLogHookM (const noop_log) return (hsc_env, bname) ===================================== 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 ===================================== @@ -864,7 +864,7 @@ wrapDocLoc doc = do if logHasDumpFlag logger Opt_D_ppr_debug then do loc <- getSrcSpanM - return (mkLocMessage MCOutput loc doc) + return (formatLocMessage loc doc) else return doc @@ -2343,8 +2343,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 -------------------- @@ -2376,10 +2375,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" } } ===================================== compiler/GHC/Types/Error.hs ===================================== @@ -26,7 +26,7 @@ module GHC.Types.Error -- * Classifying Messages - , MessageClass (MCDiagnostic, ..) + , Message (MCDiagnostic, ..) , Severity (..) , Diagnostic (..) , UnknownDiagnostic (..) @@ -70,8 +70,8 @@ module GHC.Types.Error , mapDecoratedSDoc , pprMessageBag - , mkLocMessage - , mkLocMessageWarningGroups + , formatLocMessage + , formatFatalLocMessage , formatDiagnostic , getCaretDiagnostic @@ -479,22 +479,22 @@ data MsgEnvelope e = MsgEnvelope -- | The class for a diagnostic message. The main purpose is to classify a -- message within GHC, to distinguish it from a debug/dump message vs a proper -- diagnostic, for which we include a 'DiagnosticReason'. -data MessageClass - = MCOutput - | MCFatal - | MCInteractive +data Message + = MCOutput SDoc + | MCFatal SDoc + | MCInteractive SDoc - | MCDump + | MCDump SDoc -- ^ Log message intended for compiler developers -- No file\/line\/column stuff - | MCInfo + | MCInfo SDoc -- ^ Log messages intended for end users. -- No file\/line\/column stuff. - | UnsafeMCDiagnostic Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) + | UnsafeMCDiagnostic SrcSpan Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) SDoc JsonDoc -- ^ Diagnostics from the compiler. This constructor is very powerful as - -- it allows the construction of a 'MessageClass' with a completely + -- it allows the construction of a 'Message' with a completely -- arbitrary permutation of 'Severity' and 'DiagnosticReason'. As such, -- users are encouraged to use higher level primitives -- instead. Use this constructor directly only if you need to construct @@ -508,8 +508,8 @@ data MessageClass -- should always have a 'DiagnosticCode'. See Note [Diagnostic codes]. {-# COMPLETE MCOutput, MCFatal, MCInteractive, MCDump, MCInfo, MCDiagnostic #-} -pattern MCDiagnostic :: Severity -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> MessageClass -pattern MCDiagnostic severity reason code <- UnsafeMCDiagnostic severity reason code +pattern MCDiagnostic :: SrcSpan -> Severity -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> Message +pattern MCDiagnostic span severity reason code <- UnsafeMCDiagnostic span severity reason code _diagnostic _json {- Note [Suppressing Messages] @@ -538,9 +538,6 @@ the "SevIgnore one" for a number of reasons: -- | Used to describe warnings and errors --- o The message has a file\/line\/column heading, --- plus "warning:" or "error:", --- added by mkLocMessage -- o With 'SevIgnore' the message is suppressed -- o Output is intended for end users data Severity @@ -563,15 +560,6 @@ instance ToJson Severity where json SevWarning = JSString "Warning" json SevError = JSString "Error" -instance ToJson MessageClass where - json MCOutput = JSString "MCOutput" - json MCFatal = JSString "MCFatal" - json MCInteractive = JSString "MCInteractive" - json MCDump = JSString "MCDump" - json MCInfo = JSString "MCInfo" - json (MCDiagnostic sev reason code) = - JSString $ renderWithContext defaultSDocContext (ppr $ text "MCDiagnostic" <+> ppr sev <+> ppr reason <+> ppr code) - instance ToJson DiagnosticCode where json c = JSInt (fromIntegral (diagnosticCodeNumber c)) @@ -646,35 +634,14 @@ showMsgEnvelope err = pprMessageBag :: Bag SDoc -> SDoc pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) -mkLocMessage - :: MessageClass -- ^ What kind of message? - -> SrcSpan -- ^ location - -> SDoc -- ^ message - -> SDoc -mkLocMessage = mkLocMessageWarningGroups True - --- | Make an error message with location info, specifying whether to show --- warning groups (if applicable). -mkLocMessageWarningGroups - :: Bool -- ^ Print warning groups (if applicable)? - -> MessageClass -- ^ What kind of message? - -> SrcSpan -- ^ location - -> SDoc -- ^ message - -> SDoc -mkLocMessageWarningGroups show_warn_groups msg_class locn msg - = case msg_class of - MCDiagnostic severity reason code -> formatDiagnostic show_warn_groups locn severity reason code msg - _ -> sdocOption sdocColScheme $ \col_scheme -> - let - msg_colour = getMessageClassColour msg_class col_scheme - - msg_title = coloured msg_colour $ - case msg_class of - MCFatal -> text "fatal" - _ -> empty - +formatFatalLocMessage :: SrcSpan -> SDoc -> SDoc +formatFatalLocMessage locn msg = sdocOption sdocColScheme $ \col_scheme -> + let msg_title = coloured (Col.sFatal col_scheme) $ text "fatal" in formatLocMessageWarningGroups locn msg_title empty empty msg +formatLocMessage :: SrcSpan -> SDoc -> SDoc +formatLocMessage span = formatLocMessageWarningGroups span empty empty empty + formatDiagnostic :: Bool -- ^ Print warning groups? -> SrcSpan -- ^ location @@ -784,13 +751,7 @@ formatLocMessageWarningGroups locn msg_title code_doc warning_flag_doc msg code_doc <+> warning_flag_doc in coloured (Col.sMessage col_scheme) - (hang (coloured (Col.sHeader col_scheme) header) 4 - msg) - -getMessageClassColour :: MessageClass -> Col.Scheme -> Col.PprColour -getMessageClassColour (MCDiagnostic severity _reason _code) = getSeverityColour severity -getMessageClassColour MCFatal = Col.sFatal -getMessageClassColour _ = const mempty + $ hang (coloured (Col.sHeader col_scheme) header) 4 msg getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour getSeverityColour severity = case severity of @@ -798,9 +759,9 @@ getSeverityColour severity = case severity of SevWarning -> Col.sWarning SevIgnore -> const mempty -getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc +getCaretDiagnostic :: Severity -> SrcSpan -> IO SDoc getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty -getCaretDiagnostic msg_class (RealSrcSpan span _) = +getCaretDiagnostic severity (RealSrcSpan span _) = caretDiagnostic <$> getSrcLine (srcSpanFile span) row where getSrcLine fn i = @@ -833,7 +794,7 @@ getCaretDiagnostic msg_class (RealSrcSpan span _) = caretDiagnostic Nothing = empty caretDiagnostic (Just srcLineWithNewline) = sdocOption sdocColScheme$ \col_scheme -> - let sevColour = getMessageClassColour msg_class col_scheme + let sevColour = getSeverityColour severity col_scheme marginColour = Col.sMargin col_scheme in coloured marginColour (text marginSpace) <> ===================================== compiler/GHC/Utils/Error.hs ===================================== @@ -14,7 +14,7 @@ module GHC.Utils.Error ( -- * Messages Diagnostic(..), MsgEnvelope(..), - MessageClass(..), + Message(..), SDoc, DecoratedSDoc(unDecorated), Messages, @@ -28,7 +28,7 @@ module GHC.Utils.Error ( -- ** Construction DiagOpts (..), emptyDiagOpts, diag_wopt, diag_fatal_wopt, - emptyMessages, mkDecorated, mkLocMessage, + emptyMessages, mkDecorated, mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope, mkErrorMsgEnvelope, mkLintWarning, diagReasonSeverity, @@ -282,9 +282,8 @@ unsafePprLocMsgEnvelope opts (MsgEnvelope { errMsgSpan = s , errMsgContext = name_ppr_ctx , errMsgReason = reason }) = withErrStyle name_ppr_ctx $ - mkLocMessage - (UnsafeMCDiagnostic sev reason (diagnosticCode e)) - s + formatDiagnostic True + s sev reason (diagnosticCode e) (formatBulleted $ diagnosticMessage opts e) sortMsgBag :: Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e] @@ -314,7 +313,7 @@ ghcExit logger val fatalErrorMsg :: Logger -> SDoc -> IO () fatalErrorMsg logger msg = - logMsg logger MCFatal noSrcSpan $ withPprStyle defaultErrStyle msg + logMsg logger $ MCFatal (withPprStyle defaultErrStyle msg) compilationProgressMsg :: Logger -> SDoc -> IO () compilationProgressMsg logger msg = do @@ -475,11 +474,11 @@ printOutputForUser logger name_ppr_ctx msg = logOutput logger (withUserStyle name_ppr_ctx AllTheWay msg) logInfo :: Logger -> SDoc -> IO () -logInfo logger msg = logMsg logger MCInfo noSrcSpan msg +logInfo logger = logMsg logger . MCInfo -- | Like 'logInfo' but with 'SevOutput' rather then 'SevInfo' logOutput :: Logger -> SDoc -> IO () -logOutput logger msg = logMsg logger MCOutput noSrcSpan msg +logOutput logger = logMsg logger . MCOutput prettyPrintGhcErrors :: ExceptionMonad m => Logger -> m a -> m a ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -24,7 +24,6 @@ module GHC.Utils.Logger -- * Logger setup , initLogger , LogAction - , LogJsonAction , DumpAction , TraceAction , DumpFormat (..) @@ -32,8 +31,6 @@ module GHC.Utils.Logger -- ** Hooks , popLogHook , pushLogHook - , popJsonLogHook - , pushJsonLogHook , popDumpHook , pushDumpHook , popTraceHook @@ -55,15 +52,11 @@ module GHC.Utils.Logger , putLogMsg , defaultLogAction , defaultLogActionWithHandles - , defaultLogJsonAction , defaultLogActionHPrintDoc , defaultLogActionHPutStrDoc , logMsg - , logJsonMsg , logDumpMsg - , decorateDiagnostic - -- * Dumping , defaultDumpAction , putDumpFile @@ -85,16 +78,14 @@ where import GHC.Prelude import GHC.Driver.Flags import GHC.Types.Error -import GHC.Types.SrcLoc import qualified GHC.Utils.Ppr as Pretty import GHC.Utils.Outputable -import GHC.Utils.Json import GHC.Utils.Panic +import GHC.Utils.Json (renderJSON) import GHC.Data.EnumSet (EnumSet) import qualified GHC.Data.EnumSet as EnumSet -import GHC.Data.FastString import System.Directory import System.FilePath ( takeDirectory, (</>) ) @@ -182,16 +173,9 @@ setLogFlags logger flags = logger { logFlags = flags } --------------------------------------------------------------- type LogAction = LogFlags - -> MessageClass - -> SrcSpan - -> SDoc + -> Message -> IO () -type LogJsonAction = LogFlags - -> MessageClass - -> JsonDoc - -> IO () - type DumpAction = LogFlags -> PprStyle -> DumpFlag @@ -229,9 +213,6 @@ data Logger = Logger { log_hook :: [LogAction -> LogAction] -- ^ Log hooks stack - , json_log_hook :: [LogJsonAction -> LogJsonAction] - -- ^ Json log hooks stack - , dump_hook :: [DumpAction -> DumpAction] -- ^ Dump hooks stack @@ -267,7 +248,6 @@ initLogger = do dumps <- newMVar Map.empty return $ Logger { log_hook = [] - , json_log_hook = [] , dump_hook = [] , trace_hook = [] , generated_dumps = dumps @@ -279,10 +259,6 @@ initLogger = do putLogMsg :: Logger -> LogAction putLogMsg logger = foldr ($) defaultLogAction (log_hook logger) --- | Log a JsonDoc -putJsonLogMsg :: Logger -> LogJsonAction -putJsonLogMsg logger = foldr ($) defaultLogJsonAction (json_log_hook logger) - -- | Dump something putDumpFile :: Logger -> DumpAction putDumpFile logger = @@ -307,15 +283,6 @@ popLogHook logger = case log_hook logger of [] -> panic "popLogHook: empty hook stack" _:hs -> logger { log_hook = hs } --- | Push a json log hook -pushJsonLogHook :: (LogJsonAction -> LogJsonAction) -> Logger -> Logger -pushJsonLogHook h logger = logger { json_log_hook = h:json_log_hook logger } - -popJsonLogHook :: Logger -> Logger -popJsonLogHook logger = case json_log_hook logger of - [] -> panic "popJsonLogHook: empty hook stack" - _:hs -> logger { json_log_hook = hs} - -- | Push a dump hook pushDumpHook :: (DumpAction -> DumpAction) -> Logger -> Logger pushDumpHook h logger = logger { dump_hook = h:dump_hook logger } @@ -344,8 +311,8 @@ makeThreadSafe logger = do with_lock :: forall a. IO a -> IO a with_lock act = withMVar lock (const act) - log action logflags msg_class loc doc = - with_lock (action logflags msg_class loc doc) + log action logflags message = + with_lock (action logflags message) dmp action logflags sty opts str fmt doc = with_lock (action logflags sty opts str fmt doc) @@ -359,49 +326,6 @@ makeThreadSafe logger = do $ pushTraceHook trc $ logger --- See Note [JSON Error Messages] -defaultLogJsonAction :: LogJsonAction -defaultLogJsonAction logflags msg_class jsdoc = - case msg_class of - MCOutput -> printOut msg - MCDump -> printOut (msg $$ blankLine) - MCInteractive -> putStrSDoc msg - MCInfo -> printErrs msg - MCFatal -> printErrs msg - MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message - MCDiagnostic _sev _rea _code -> printErrs msg - where - printOut = defaultLogActionHPrintDoc logflags False stdout - printErrs = defaultLogActionHPrintDoc logflags False stderr - putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout - msg = renderJSON jsdoc - --- See Note [JSON Error Messages] --- this is to be removed -jsonLogActionWithHandle :: Handle {-^ Standard out -} -> LogAction -jsonLogActionWithHandle _ _ (MCDiagnostic SevIgnore _ _) _ _ = return () -- suppress the message -jsonLogActionWithHandle out logflags msg_class srcSpan msg - = - defaultLogActionHPutStrDoc logflags True out - (withPprStyle PprCode (doc $$ text "")) - where - str = renderWithContext (log_default_user_context logflags) msg - doc = renderJSON $ - JSObject [ ( "span", spanToDumpJSON srcSpan ) - , ( "doc" , JSString str ) - , ( "messageClass", json msg_class ) - ] - spanToDumpJSON :: SrcSpan -> JsonDoc - spanToDumpJSON s = case s of - (RealSrcSpan rss _) -> JSObject [ ("file", json file) - , ("startLine", json $ srcSpanStartLine rss) - , ("startCol", json $ srcSpanStartCol rss) - , ("endLine", json $ srcSpanEndLine rss) - , ("endCol", json $ srcSpanEndCol rss) - ] - where file = unpackFS $ srcSpanFile rss - UnhelpfulSpan _ -> JSNull - -- | The default 'LogAction' prints to 'stdout' and 'stderr'. -- -- To replicate the default log action behaviour with different @out@ and @err@ @@ -412,72 +336,24 @@ defaultLogAction = defaultLogActionWithHandles stdout stderr -- | The default 'LogAction' parametrized over the standard output and standard error handles. -- Allows clients to replicate the log message formatting of GHC with custom handles. defaultLogActionWithHandles :: Handle {-^ Handle for standard output -} -> Handle {-^ Handle for standard errors -} -> LogAction -defaultLogActionWithHandles out err logflags msg_class srcSpan msg - | log_dopt Opt_D_dump_json logflags = jsonLogActionWithHandle out logflags msg_class srcSpan msg - | otherwise = case msg_class of - MCOutput -> printOut msg - MCDump -> printOut (msg $$ blankLine) - MCInteractive -> putStrSDoc msg - MCInfo -> printErrs msg - MCFatal -> printErrs msg - MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message - MCDiagnostic _sev _rea _code -> decorateDiagnostic logflags msg_class srcSpan msg >>= printErrs +defaultLogActionWithHandles out err logflags message + = case message of + MCOutput msg -> printOut msg + MCDump msg -> printOut (msg $$ blankLine) + MCInteractive msg -> putStrSDoc msg + MCInfo msg -> printErrs msg + MCFatal msg -> printErrs msg + MCDiagnostic _ SevIgnore _ _ -> pure () -- suppress the message + UnsafeMCDiagnostic _span _severity _reason _code doc json -> do + if log_diagnostics_as_json logflags then do + printErrs (renderJSON json) + else do + printErrs doc where printOut = defaultLogActionHPrintDoc logflags False out printErrs = defaultLogActionHPrintDoc logflags False err putStrSDoc = defaultLogActionHPutStrDoc logflags False out --- This function is used by `defaultLogActionWithHandles` for non-JSON output, --- and also by `GHC.Driver.Errors.printMessages` to produce the `rendered` --- message on `-fdiagnostics-as-json`. --- --- We would want to eventually consolidate this. However, this is currently --- not feasible for the following reasons: --- --- 1. Some parts of the compiler sidestep `printMessages`, for that reason we --- can not decorate the message in `printMessages`. --- --- 2. GHC uses two different code paths for JSON and non-JSON diagnostics. For --- that reason we can not decorate the message in `defaultLogActionWithHandles`. --- --- See also Note [JSON Error Messages]: --- --- `jsonLogAction` should be removed along with -ddump-json --- --- Also note that (1) is the reason why some parts of the compiler produce --- diagnostics that don't respect `-fdiagnostics-as-json`. --- --- The plan as I see it is as follows: --- --- 1. Refactor all places in the compiler that report diagnostics to go --- through `GHC.Driver.Errors.printMessages`. --- --- (It's easy to find all those places by looking for who creates --- MCDiagnostic, either directly or via `mkMCDiagnostic` or --- `errorDiagnostic`.) --- --- 2. Get rid of `-ddump-json`, `jsonLogAction` and consolidate message --- decoration at one place (either `printMessages` or --- `defaultLogActionWithHandles`) --- --- This story is tracked by #24113. -decorateDiagnostic :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO SDoc -decorateDiagnostic logflags msg_class srcSpan msg = addCaret - where - -- Pretty print the warning flag, if any (#10752) - message :: SDoc - message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg - - addCaret :: IO SDoc - addCaret = do - caretDiagnostic <- - if log_show_caret logflags - then getCaretDiagnostic msg_class srcSpan - else pure empty - return $ getPprStyle $ \style -> - withPprStyle (setStyleColoured True style) - (message $+$ caretDiagnostic $+$ blankLine) - -- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline. defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO () defaultLogActionHPrintDoc logflags asciiSpace h d @@ -491,28 +367,6 @@ defaultLogActionHPutStrDoc logflags asciiSpace h d -- calls to this log-action can output all on the same line = printSDoc (log_default_user_context logflags) (Pretty.PageMode asciiSpace) h d --- --- 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. --- --- The recent work here replaces the purpose of flag -ddump-json with --- -fdiagnostics-as-json. For temporary backwards compatibility while --- -ddump-json is being deprecated, `jsonLogAction` has been added in, but --- it should be removed along with -ddump-json. Similarly, the guard in --- `defaultLogAction` should be removed. This cleanup is tracked in #24113. - -- | Default action for 'dumpAction' hook defaultDumpAction :: DumpCache -> LogAction -> DumpAction defaultDumpAction dumps log_action logflags sty flag title _fmt doc = @@ -545,10 +399,10 @@ dumpSDocWithStyle dumps log_action sty logflags flag hdr doc = -- write the dump to stdout writeDump Nothing = do - let (doc', msg_class) - | null hdr = (doc, MCOutput) - | otherwise = (mkDumpDoc hdr doc, MCDump) - log_action logflags msg_class noSrcSpan (withPprStyle sty doc') + let message + | null hdr = MCOutput (withPprStyle sty doc) + | otherwise = MCDump (withPprStyle sty $ mkDumpDoc hdr doc) + log_action logflags message -- | Run an action with the handle of a 'DumpFlag' if we are outputting to a @@ -638,11 +492,8 @@ defaultTraceAction logflags title doc x = -- | Log something -logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO () -logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg - -logJsonMsg :: Logger -> MessageClass -> JsonDoc -> IO () -logJsonMsg logger mc = putJsonLogMsg logger (logFlags logger) mc +logMsg :: Logger -> Message -> IO () +logMsg logger = putLogMsg logger (logFlags logger) -- | Dump something logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () @@ -654,7 +505,7 @@ logTraceMsg logger hdr doc a = putTraceMsg logger (logFlags logger) hdr doc a -- | Log a dump message (not a dump file) logDumpMsg :: Logger -> String -> SDoc -> IO () -logDumpMsg logger hdr doc = logMsg logger MCDump noSrcSpan +logDumpMsg logger hdr doc = logMsg logger $ MCDump (withPprStyle defaultDumpStyle (mkDumpDoc hdr doc)) ===================================== docs/users_guide/debugging.rst ===================================== @@ -55,13 +55,6 @@ Dumping out compiler intermediate structures ``Main.p.dump-simpl`` and ``Main.dump-simpl`` instead of overwriting the output of one way with the output of another. -.. ghc-flag:: -ddump-json - :shortdesc: *(deprecated)* Use :ghc-flag:`-fdiagnostics-as-json` instead - :type: dynamic - - This flag was previously used to generated JSON formatted GHC diagnostics, - but has been deprecated. Instead, use :ghc-flag:`-fdiagnostics-as-json`. - .. ghc-flag:: -dshow-passes :shortdesc: Print out each pass name as it happens :type: dynamic ===================================== ghc/GHCi/UI.hs ===================================== @@ -498,8 +498,6 @@ interactiveUI config srcs maybe_exprs = do installInteractiveHomeUnits - -- Update the LogAction. Ensure we don't override the user's log action lest - -- we break -ddump-json (#14078) lastErrLocationsRef <- liftIO $ newIORef [] pushLogHookM (ghciLogAction lastErrLocationsRef) @@ -835,10 +833,10 @@ resetLastErrorLocations = do ghciLogAction :: IORef [(FastString, Int)] -> LogAction -> LogAction ghciLogAction lastErrLocations old_log_action - dflags msg_class srcSpan msg = do - old_log_action dflags msg_class srcSpan msg - case msg_class of - MCDiagnostic SevError _reason _code -> case srcSpan of + dflags msg = do + old_log_action dflags msg + case msg of + MCDiagnostic srcSpan SevError _reason _code -> case srcSpan of RealSrcSpan rsp _ -> modifyIORef lastErrLocations (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))]) _ -> return () ===================================== testsuite/tests/driver/T16167.stderr ===================================== @@ -1 +1,2 @@ +{"version":"1.2","ghcVersion":"ghc-9.15.20250819","span":{"file":"T16167.hs","start":{"line":1,"column":8},"end":{"line":1,"column":9}},"severity":"Error","code":58481,"rendered":"T16167.hs:1:8: error: [GHC-58481] parse error on input \u2018f\u2019\n","message":["parse error on input \u2018f\u2019"],"hints":[]} *** Exception: ExitFailure 1 ===================================== testsuite/tests/driver/T16167.stdout deleted ===================================== @@ -1,2 +0,0 @@ -{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"} -{"span":{"file":"T16167.hs","startLine":1,"startCol":8,"endLine":1,"endCol":9},"doc":"parse error on input \u2018f\u2019","messageClass":"MCDiagnostic SevError ErrorWithoutFlag Just GHC-58481"} ===================================== testsuite/tests/driver/all.T ===================================== @@ -274,12 +274,11 @@ test('T12752pass', normal, compile, ['-DSHOULD_PASS=1 -Wcpp-undef']) test('T12955', normal, makefile_test, []) test('T12971', [when(opsys('mingw32'), fragile(17945)), ignore_stdout], makefile_test, []) -test('json_dump', normal, compile_fail, ['-ddump-json']) test('json', normalise_version('ghc'), compile_fail, ['-fdiagnostics-as-json']) test('json_warn', normalise_version('ghc'), compile, ['-fdiagnostics-as-json -Wunused-matches -Wx-partial']) -test('json2', normalise_version('ghc-internal', 'base','ghc-prim'), compile, ['-ddump-types -ddump-json -Wno-unsupported-llvm-version']) +test('json2', normalise_version('ghc-internal', 'base','ghc-prim'), compile, ['-ddump-types -fdiagnostics-as-json -Wno-unsupported-llvm-version']) test('T16167', [normalise_version('ghc'),req_interp,exit_code(1)], run_command, - ['{compiler} -x hs -e ":set prog T16167.hs" -ddump-json T16167.hs']) + ['{compiler} -x hs -e ":set prog T16167.hs" -fdiagnostics-as-json T16167.hs']) test('T13604', [], makefile_test, []) test('T13604a', [ js_broken(22261) # require HPC support ===================================== testsuite/tests/driver/json2.stderr ===================================== @@ -1,2 +1,4 @@ -{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"} -{"span":null,"doc":"TYPE SIGNATURES\n foo :: forall a. a -> a\nDependent modules: []\nDependent packages: [(normal, base-4.21.0.0)]","messageClass":"MCOutput"} +TYPE SIGNATURES + foo :: forall a. a -> a +Dependent modules: [] +Dependent packages: [(normal, base-4.21.0.0)] ===================================== testsuite/tests/driver/json_dump.hs deleted ===================================== @@ -1,6 +0,0 @@ -module Foo where - -import Data.List - -id1 :: a -> a -id1 = 5 ===================================== testsuite/tests/driver/json_dump.stderr deleted ===================================== @@ -1,2 +0,0 @@ -{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"} -{"span":{"file":"json_dump.hs","startLine":6,"startCol":7,"endLine":6,"endCol":8},"doc":"\u2022 No instance for \u2018Num (a -> a)\u2019 arising from the literal \u20185\u2019\n (maybe you haven't applied a function to enough arguments?)\n\u2022 In the expression: 5\n In an equation for \u2018id1\u2019: id1 = 5","messageClass":"MCDiagnostic SevError ErrorWithoutFlag Just GHC-39999"} ===================================== testsuite/tests/ghc-api/T7478/T7478.hs ===================================== @@ -24,11 +24,11 @@ compileInGhc targets handlerOutput = do flags0 <- getSessionDynFlags let flags = flags0 {verbosity = 1 } setSessionDynFlags flags - let collectSrcError handlerOutput _flags MCOutput _srcspan msg + let collectSrcError _flags (MCOutput msg) = handlerOutput $ GHC.showSDocForUser flags emptyUnitState alwaysQualify msg - collectSrcError _ _ _ _ _ + collectSrcError _ _ = return () - pushLogHookM (const (collectSrcError handlerOutput)) + pushLogHookM (const collectSrcError) -- Set up targets. oldTargets <- getTargets let oldFiles = map fileFromTarget oldTargets ===================================== testsuite/tests/plugins/hooks-plugin/Hooks/LogPlugin.hs ===================================== @@ -19,6 +19,6 @@ hooksP opts hsc_env = do return hsc_env' logHook :: LogAction -> LogAction -logHook action logFlags messageClass srcSpan msgDoc = do +logHook action logFlags message = do putStrLn "Log hook called" - action logFlags messageClass srcSpan msgDoc + action logFlags message View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0465d8c6c112b8c0dbfae85a7af30e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0465d8c6c112b8c0dbfae85a7af30e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/hoopl-coerce
by Cheng Shao (＠TerrorJack) 21 Aug '25

21 Aug '25

Cheng Shao pushed new branch wip/hoopl-coerce at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/hoopl-coerce You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] compiler: fix closure C type in SPT init code
by Marge Bot (＠marge-bot) 21 Aug '25

21 Aug '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 6a43f8ec by Cheng Shao at 2025-08-21T17:52:52-04:00 compiler: fix closure C type in SPT init code This patch fixes the closure C type in SPT init code to StgClosure, instead of the previously incorrect StgPtr. Having an incorrect C type makes SPT init code not compatible with other foreign stub generation logic, which may also emit their own extern declarations for the same closure symbols and thus will clash with the incorrect prototypes in SPT init code. - - - - - 1 changed file: - compiler/GHC/Iface/Tidy/StaticPtrTable.hs Changes: ===================================== compiler/GHC/Iface/Tidy/StaticPtrTable.hs ===================================== @@ -17,18 +17,18 @@ -- > static void hs_hpc_init_Main(void) { -- > -- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL}; --- > extern StgPtr Main_r2wb_closure; +-- > extern StgClosure Main_r2wb_closure; -- > hs_spt_insert(k0, &Main_r2wb_closure); -- > -- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL}; --- > extern StgPtr Main_r2wc_closure; +-- > extern StgClosure Main_r2wc_closure; -- > hs_spt_insert(k1, &Main_r2wc_closure); -- > -- > } -- -- where the constants are fingerprints produced from the static forms. -- --- The linker must find the definitions matching the @extern StgPtr <name>@ +-- The linker must find the definitions matching the @extern StgClosure <name>@ -- declarations. For this to work, the identifiers of static pointers need to be -- exported. This is done in 'GHC.Core.Opt.SetLevels.newLvlVar'. -- @@ -263,7 +263,7 @@ sptModuleInitCode platform this_mod entries -- CLabel. Regardless, MayHaveCafRefs/NoCafRefs wouldn't make -- any difference here, they would pretty-print to the same -- foreign stub content. - $$ text "extern StgPtr " + $$ text "extern StgClosure " <> (pprCLabel platform $ mkClosureLabel n MayHaveCafRefs) <> semi $$ text "hs_spt_insert" <> parens (hcat $ punctuate comma View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6a43f8ec2e679d1240ddf6de597bc2f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6a43f8ec2e679d1240ddf6de597bc2f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Serialize wired-in names as external names when creating HIE files
by Marge Bot (＠marge-bot) 21 Aug '25

21 Aug '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 42724462 by Simon Hengel at 2025-08-21T17:52:11-04:00 Serialize wired-in names as external names when creating HIE files Note that the domain of de-serialized names stays the same. Specifically, for known-key names, before `lookupKnownKeyName` was used, while now this is handled by `lookupOrigNameCache` which captures the same range provided that the OrigNameCache has been initialized with `knownKeyNames` (which is the case by default). (fixes #26238) - - - - - 4 changed files: - compiler/GHC/Iface/Ext/Binary.hs - compiler/GHC/Iface/Ext/Types.hs - compiler/GHC/Types/Name/Cache.hs - utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs Changes: ===================================== compiler/GHC/Iface/Ext/Binary.hs ===================================== @@ -17,7 +17,6 @@ where import GHC.Prelude -import GHC.Builtin.Utils import GHC.Settings.Utils ( maybeRead ) import GHC.Settings.Config ( cProjectVersion ) import GHC.Utils.Binary @@ -28,10 +27,8 @@ import GHC.Iface.Binary ( putAllTables ) import GHC.Types.Name import GHC.Types.Name.Cache import GHC.Types.SrcLoc as SrcLoc -import GHC.Types.Unique import GHC.Types.Unique.FM import qualified GHC.Utils.Binary as Binary -import GHC.Utils.Outputable import GHC.Utils.Panic import qualified Data.Array as A @@ -290,6 +287,9 @@ fromHieName nc hie_name = do case hie_name of ExternalName mod occ span -> updateNameCache nc mod occ $ \cache -> do case lookupOrigNameCache cache mod occ of + -- Note that this may be a wired-in name (provided that the NameCache + -- was initialized with known-key names, which is always the case if you + -- use `newNameCache`). Just name -> pure (cache, name) Nothing -> do uniq <- takeUniqFromNameCache nc @@ -302,11 +302,6 @@ fromHieName nc hie_name = do -- don't update the NameCache for local names pure $ mkInternalName uniq occ span - KnownKeyName u -> case lookupKnownKeyName u of - Nothing -> pprPanic "fromHieName:unknown known-key unique" - (ppr u) - Just n -> pure n - -- ** Reading and writing `HieName`'s putHieName :: WriteBinHandle -> HieName -> IO () @@ -316,9 +311,6 @@ putHieName bh (ExternalName mod occ span) = do putHieName bh (LocalName occName span) = do putByte bh 1 put_ bh (occName, BinSrcSpan span) -putHieName bh (KnownKeyName uniq) = do - putByte bh 2 - put_ bh $ unpkUnique uniq getHieName :: ReadBinHandle -> IO HieName getHieName bh = do @@ -330,7 +322,4 @@ getHieName bh = do 1 -> do (occ, span) <- get bh return $ LocalName occ $ unBinSrcSpan span - 2 -> do - (c,i) <- get bh - return $ KnownKeyName $ mkUnique c i _ -> panic "GHC.Iface.Ext.Binary.getHieName: invalid tag" ===================================== compiler/GHC/Iface/Ext/Types.hs ===================================== @@ -19,14 +19,12 @@ import GHC.Prelude import GHC.Settings.Config import GHC.Utils.Binary import GHC.Data.FastString -import GHC.Builtin.Utils import GHC.Iface.Type import GHC.Unit.Module ( ModuleName, Module ) import GHC.Types.Name import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Types.SrcLoc import GHC.Types.Avail -import GHC.Types.Unique import qualified GHC.Utils.Outputable as O ( (<>) ) import GHC.Utils.Panic import GHC.Core.ConLike ( ConLike(..) ) @@ -766,7 +764,6 @@ instance Binary TyVarScope where data HieName = ExternalName !Module !OccName !SrcSpan | LocalName !OccName !SrcSpan - | KnownKeyName !Unique deriving (Eq) instance Ord HieName where @@ -774,34 +771,28 @@ instance Ord HieName where -- TODO (int-index): Perhaps use RealSrcSpan in HieName? compare (LocalName a b) (LocalName c d) = compare a c S.<> leftmost_smallest b d -- TODO (int-index): Perhaps use RealSrcSpan in HieName? - compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b - -- Not actually non deterministic as it is a KnownKey compare ExternalName{} _ = LT compare LocalName{} ExternalName{} = GT - compare LocalName{} _ = LT - compare KnownKeyName{} _ = GT instance Outputable HieName where ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp - ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u hieNameOcc :: HieName -> OccName hieNameOcc (ExternalName _ occ _) = occ hieNameOcc (LocalName occ _) = occ -hieNameOcc (KnownKeyName u) = - case lookupKnownKeyName u of - Just n -> nameOccName n - Nothing -> pprPanic "hieNameOcc:unknown known-key unique" - (ppr u) toHieName :: Name -> HieName -toHieName name - | isKnownKeyName name = KnownKeyName (nameUnique name) - | isExternalName name = ExternalName (nameModule name) - (nameOccName name) - (removeBufSpan $ nameSrcSpan name) - | otherwise = LocalName (nameOccName name) (removeBufSpan $ nameSrcSpan name) +toHieName name = + case nameModule_maybe name of + Nothing -> LocalName occName span + Just m -> ExternalName m occName span + where + occName :: OccName + occName = nameOccName name + + span :: SrcSpan + span = removeBufSpan $ nameSrcSpan name {- Note [Capture Entity Information] ===================================== compiler/GHC/Types/Name/Cache.hs ===================================== @@ -101,9 +101,14 @@ OrigNameCache at all? Good question; after all, 3) Loading of interface files encodes names via Uniques, as detailed in Note [Symbol table representation of names] in GHC.Iface.Binary -It turns out that we end up looking up built-in syntax in the cache when we -generate Haddock documentation. E.g. if we don't find tuple data constructors -there, hyperlinks won't work as expected. Test case: haddockHtmlTest (Bug923.hs) + +However note that: + 1) It turns out that we end up looking up built-in syntax in the cache when + we generate Haddock documentation. E.g. if we don't find tuple data + constructors there, hyperlinks won't work as expected. Test case: + haddockHtmlTest (Bug923.hs) + 2) HIE de-serialization relies on wired-in names, including built-in syntax, + being present in the OrigNameCache. -} -- | The NameCache makes sure that there is just one Unique assigned for ===================================== utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs ===================================== @@ -229,10 +229,7 @@ writeInterfaceFile filename iface = do return () freshNameCache :: IO NameCache -freshNameCache = - initNameCache - 'a' -- ?? - [] +freshNameCache = newNameCache -- | Read a Haddock (@.haddock@) interface file. Return either an -- 'InterfaceFile' or an error message. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/42724462e3cfaba426882711c869e4f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/42724462e3cfaba426882711c869e4f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/remove-stg_stackDecode] 4 commits: Move stack decoding logic from ghc-heap to ghc-internal
by Hannes Siebenhandl (＠fendor) 21 Aug '25

21 Aug '25

Hannes Siebenhandl pushed to branch wip/fendor/remove-stg_stackDecode at Glasgow Haskell Compiler / GHC Commits: 2267763e by fendor at 2025-08-21T23:18:35+02:00 Move stack decoding logic from ghc-heap to ghc-internal The stack decoding logic in `ghc-heap` is more sophisticated than the one currently employed in `CloneStack`. We want to use the stack decoding implementation from `ghc-heap` in `base`. We cannot simply depend on `ghc-heap` in `base` due do bootstrapping issues. Thus, we move the code that is necessary to implement stack decoding to `ghc-internal`. This is the right location, as we don't want to add a new API to `base`. Moving the stack decoding logic and re-exposing it in ghc-heap is insufficient, though, as we have a dependency cycle between. * ghc-heap depends on stage1:ghc-internal * stage0:ghc depends on stage0:ghc-heap To fix this, we remove ghc-heap from the set of `stage0` dependencies. This is not entirely straight-forward, as a couple of boot dependencies, such as `ghci` depend on `ghc-heap`. Luckily, the boot compiler of GHC is now >=9.10, so we can migrate `ghci` to use `ghc-internal` instead of `ghc-heap`, which already exports the relevant modules. However, we cannot 100% remove ghc's dependency on `ghc-heap`, since when we compile `stage0:ghc`, `stage1:ghc-internal` is not yet available. Thus, when we compile with the boot-compiler, we still depend on an older version of `ghc-heap`, and only use the modules from `ghc-internal`, if the `ghc-internal` version is recent enough. ------------------------- Metric Increase: size_hello_artifact size_hello_artifact_gzip size_hello_unicode size_hello_unicode_gzip ------------------------- These metric increases are unfortunate, they are most likely caused by the larger (literally in terms of lines of code) stack decoder implementation that are now linked into hello-word binaries. On linux, it is almost a 10% increase, which is considerable. - - - - - b0ce7b46 by fendor at 2025-08-21T23:18:35+02:00 Implement `decode` in terms of `decodeStackWithIpe` Uses the more efficient stack decoder implementation. - - - - - d98da02a by fendor at 2025-08-21T23:18:35+02:00 Remove stg_decodeStackzh - - - - - c727e33c by fendor at 2025-08-21T23:18:35+02:00 Remove ghcHeap from list of toolTargets - - - - - 53 changed files: - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Runtime/Heap/Inspect.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/ghc.cabal.in - hadrian/src/Rules/ToolArgs.hs - hadrian/src/Settings/Default.hs - libraries/base/src/GHC/Stack/CloneStack.hs - libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - + libraries/ghc-heap/GHC/Exts/Heap/Constants.hs - + libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hs - + libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hs - + libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hs - libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs - + libraries/ghc-heap/GHC/Exts/Stack/Constants.hs - libraries/ghc-heap/GHC/Exts/Stack/Decode.hs - libraries/ghc-heap/ghc-heap.cabal.in - libraries/ghc-heap/cbits/HeapPrim.cmm → libraries/ghc-internal/cbits/HeapPrim.cmm - libraries/ghc-heap/cbits/Stack.cmm → libraries/ghc-internal/cbits/Stack.cmm - libraries/ghc-internal/cbits/StackCloningDecoding.cmm - libraries/ghc-heap/cbits/Stack_c.c → libraries/ghc-internal/cbits/Stack_c.c - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/jsbits/base.js - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs - + libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs - libraries/ghc-heap/GHC/Exts/Heap/Constants.hsc → libraries/ghc-internal/src/GHC/Internal/Heap/Constants.hsc - libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc → libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc - libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc → libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable/Types.hsc - libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc → libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc - + libraries/ghc-internal/src/GHC/Internal/Heap/ProfInfo/Types.hs - libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs - libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc → libraries/ghc-internal/src/GHC/Internal/Stack/Constants.hsc - + libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - libraries/ghc-heap/tests/stack-annotation/Makefile → libraries/ghc-internal/tests/stack-annotation/Makefile - libraries/ghc-heap/tests/stack-annotation/TestUtils.hs → libraries/ghc-internal/tests/stack-annotation/TestUtils.hs - libraries/ghc-heap/tests/stack-annotation/all.T → libraries/ghc-internal/tests/stack-annotation/all.T - libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs → libraries/ghc-internal/tests/stack-annotation/ann_frame001.hs - libraries/ghc-heap/tests/stack-annotation/ann_frame001.stdout → libraries/ghc-internal/tests/stack-annotation/ann_frame001.stdout - libraries/ghc-heap/tests/stack-annotation/ann_frame002.hs → libraries/ghc-internal/tests/stack-annotation/ann_frame002.hs - libraries/ghc-heap/tests/stack-annotation/ann_frame002.stdout → libraries/ghc-internal/tests/stack-annotation/ann_frame002.stdout - libraries/ghc-heap/tests/stack-annotation/ann_frame003.hs → libraries/ghc-internal/tests/stack-annotation/ann_frame003.hs - libraries/ghc-heap/tests/stack-annotation/ann_frame003.stdout → libraries/ghc-internal/tests/stack-annotation/ann_frame003.stdout - libraries/ghc-heap/tests/stack-annotation/ann_frame004.hs → libraries/ghc-internal/tests/stack-annotation/ann_frame004.hs - libraries/ghc-heap/tests/stack-annotation/ann_frame004.stdout → libraries/ghc-internal/tests/stack-annotation/ann_frame004.stdout - libraries/ghci/GHCi/Message.hs - libraries/ghci/ghci.cabal.in - rts/CloneStack.c - rts/CloneStack.h - rts/RtsSymbols.c - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f255aff17d7dc7d043771fd9f7e060… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f255aff17d7dc7d043771fd9f7e060… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Remove deprecated functions from the ghci package
by Marge Bot (＠marge-bot) 21 Aug '25

21 Aug '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: f0a19d74 by fendor at 2025-08-20T19:55:00-04:00 Remove deprecated functions from the ghci package - - - - - ebeb991b by fendor at 2025-08-20T19:55:00-04:00 base: Remove unstable heap representation details from GHC.Exts - - - - - e368e247 by Rodrigo Mesquita at 2025-08-20T19:55:42-04:00 bytecode: Use 32bits for breakpoint index Fixes #26325 - - - - - c938ca38 by Simon Hengel at 2025-08-21T14:01:47-04:00 Serialize wired-in names as external names when creating HIE files Note that the domain of de-serialized names stays the same. Specifically, for known-key names, before `lookupKnownKeyName` was used, while now this is handled by `lookupOrigNameCache` which captures the same range provided that the OrigNameCache has been initialized with `knownKeyNames` (which is the case by default). (fixes #26238) - - - - - b5431ced by Cheng Shao at 2025-08-21T14:01:51-04:00 compiler: fix closure C type in SPT init code This patch fixes the closure C type in SPT init code to StgClosure, instead of the previously incorrect StgPtr. Having an incorrect C type makes SPT init code not compatible with other foreign stub generation logic, which may also emit their own extern declarations for the same closure symbols and thus will clash with the incorrect prototypes in SPT init code. - - - - - 14 changed files: - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/Iface/Ext/Binary.hs - compiler/GHC/Iface/Ext/Types.hs - compiler/GHC/Iface/Tidy/StaticPtrTable.hs - compiler/GHC/Types/Name/Cache.hs - libraries/base/changelog.md - libraries/base/src/GHC/Exts.hs - libraries/ghci/GHCi/CreateBCO.hs - libraries/ghci/GHCi/TH.hs - libraries/ghci/ghci.cabal.in - rts/Disassembler.c - rts/Interpreter.c - − testsuite/tests/module/T21752.stderr - utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs Changes: ===================================== compiler/GHC/ByteCode/Asm.hs ===================================== @@ -843,16 +843,18 @@ assembleI platform i = case i of BRK_FUN ibi@(InternalBreakpointId info_mod infox) -> do p1 <- ptr $ BCOPtrBreakArray info_mod - let -- cast that checks that round-tripping through Word16 doesn't change the value - toW16 x = let r = fromIntegral x :: Word16 - in if fromIntegral r == x + let -- cast that checks that round-tripping through Word32 doesn't change the value + infoW32 = let r = fromIntegral infox :: Word32 + in if fromIntegral r == infox then r - else pprPanic "schemeER_wrk: breakpoint tick/info index too large!" (ppr x) + else pprPanic "schemeER_wrk: breakpoint tick/info index too large!" (ppr infox) + ix_hi = fromIntegral (infoW32 `shiftR` 16) + ix_lo = fromIntegral (infoW32 .&. 0xffff) info_addr <- lit1 $ BCONPtrFS $ moduleNameFS $ moduleName info_mod info_unitid_addr <- lit1 $ BCONPtrFS $ unitIdFS $ moduleUnitId info_mod np <- lit1 $ BCONPtrCostCentre ibi emit_ bci_BRK_FUN [ Op p1, Op info_addr, Op info_unitid_addr - , SmallOp (toW16 infox), Op np ] + , SmallOp ix_hi, SmallOp ix_lo, Op np ] BRK_ALTS active -> emit_ bci_BRK_ALTS [SmallOp (if active then 1 else 0)] ===================================== compiler/GHC/Iface/Ext/Binary.hs ===================================== @@ -17,7 +17,6 @@ where import GHC.Prelude -import GHC.Builtin.Utils import GHC.Settings.Utils ( maybeRead ) import GHC.Settings.Config ( cProjectVersion ) import GHC.Utils.Binary @@ -28,10 +27,8 @@ import GHC.Iface.Binary ( putAllTables ) import GHC.Types.Name import GHC.Types.Name.Cache import GHC.Types.SrcLoc as SrcLoc -import GHC.Types.Unique import GHC.Types.Unique.FM import qualified GHC.Utils.Binary as Binary -import GHC.Utils.Outputable import GHC.Utils.Panic import qualified Data.Array as A @@ -290,6 +287,9 @@ fromHieName nc hie_name = do case hie_name of ExternalName mod occ span -> updateNameCache nc mod occ $ \cache -> do case lookupOrigNameCache cache mod occ of + -- Note that this may be a wired-in name (provided that the NameCache + -- was initialized with known-key names, which is always the case if you + -- use `newNameCache`). Just name -> pure (cache, name) Nothing -> do uniq <- takeUniqFromNameCache nc @@ -302,11 +302,6 @@ fromHieName nc hie_name = do -- don't update the NameCache for local names pure $ mkInternalName uniq occ span - KnownKeyName u -> case lookupKnownKeyName u of - Nothing -> pprPanic "fromHieName:unknown known-key unique" - (ppr u) - Just n -> pure n - -- ** Reading and writing `HieName`'s putHieName :: WriteBinHandle -> HieName -> IO () @@ -316,9 +311,6 @@ putHieName bh (ExternalName mod occ span) = do putHieName bh (LocalName occName span) = do putByte bh 1 put_ bh (occName, BinSrcSpan span) -putHieName bh (KnownKeyName uniq) = do - putByte bh 2 - put_ bh $ unpkUnique uniq getHieName :: ReadBinHandle -> IO HieName getHieName bh = do @@ -330,7 +322,4 @@ getHieName bh = do 1 -> do (occ, span) <- get bh return $ LocalName occ $ unBinSrcSpan span - 2 -> do - (c,i) <- get bh - return $ KnownKeyName $ mkUnique c i _ -> panic "GHC.Iface.Ext.Binary.getHieName: invalid tag" ===================================== compiler/GHC/Iface/Ext/Types.hs ===================================== @@ -19,14 +19,12 @@ import GHC.Prelude import GHC.Settings.Config import GHC.Utils.Binary import GHC.Data.FastString -import GHC.Builtin.Utils import GHC.Iface.Type import GHC.Unit.Module ( ModuleName, Module ) import GHC.Types.Name import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Types.SrcLoc import GHC.Types.Avail -import GHC.Types.Unique import qualified GHC.Utils.Outputable as O ( (<>) ) import GHC.Utils.Panic import GHC.Core.ConLike ( ConLike(..) ) @@ -766,7 +764,6 @@ instance Binary TyVarScope where data HieName = ExternalName !Module !OccName !SrcSpan | LocalName !OccName !SrcSpan - | KnownKeyName !Unique deriving (Eq) instance Ord HieName where @@ -774,34 +771,28 @@ instance Ord HieName where -- TODO (int-index): Perhaps use RealSrcSpan in HieName? compare (LocalName a b) (LocalName c d) = compare a c S.<> leftmost_smallest b d -- TODO (int-index): Perhaps use RealSrcSpan in HieName? - compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b - -- Not actually non deterministic as it is a KnownKey compare ExternalName{} _ = LT compare LocalName{} ExternalName{} = GT - compare LocalName{} _ = LT - compare KnownKeyName{} _ = GT instance Outputable HieName where ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp - ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u hieNameOcc :: HieName -> OccName hieNameOcc (ExternalName _ occ _) = occ hieNameOcc (LocalName occ _) = occ -hieNameOcc (KnownKeyName u) = - case lookupKnownKeyName u of - Just n -> nameOccName n - Nothing -> pprPanic "hieNameOcc:unknown known-key unique" - (ppr u) toHieName :: Name -> HieName -toHieName name - | isKnownKeyName name = KnownKeyName (nameUnique name) - | isExternalName name = ExternalName (nameModule name) - (nameOccName name) - (removeBufSpan $ nameSrcSpan name) - | otherwise = LocalName (nameOccName name) (removeBufSpan $ nameSrcSpan name) +toHieName name = + case nameModule_maybe name of + Nothing -> LocalName occName span + Just m -> ExternalName m occName span + where + occName :: OccName + occName = nameOccName name + + span :: SrcSpan + span = removeBufSpan $ nameSrcSpan name {- Note [Capture Entity Information] ===================================== compiler/GHC/Iface/Tidy/StaticPtrTable.hs ===================================== @@ -17,18 +17,18 @@ -- > static void hs_hpc_init_Main(void) { -- > -- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL}; --- > extern StgPtr Main_r2wb_closure; +-- > extern StgClosure Main_r2wb_closure; -- > hs_spt_insert(k0, &Main_r2wb_closure); -- > -- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL}; --- > extern StgPtr Main_r2wc_closure; +-- > extern StgClosure Main_r2wc_closure; -- > hs_spt_insert(k1, &Main_r2wc_closure); -- > -- > } -- -- where the constants are fingerprints produced from the static forms. -- --- The linker must find the definitions matching the @extern StgPtr <name>@ +-- The linker must find the definitions matching the @extern StgClosure <name>@ -- declarations. For this to work, the identifiers of static pointers need to be -- exported. This is done in 'GHC.Core.Opt.SetLevels.newLvlVar'. -- @@ -263,7 +263,7 @@ sptModuleInitCode platform this_mod entries -- CLabel. Regardless, MayHaveCafRefs/NoCafRefs wouldn't make -- any difference here, they would pretty-print to the same -- foreign stub content. - $$ text "extern StgPtr " + $$ text "extern StgClosure " <> (pprCLabel platform $ mkClosureLabel n MayHaveCafRefs) <> semi $$ text "hs_spt_insert" <> parens (hcat $ punctuate comma ===================================== compiler/GHC/Types/Name/Cache.hs ===================================== @@ -101,9 +101,14 @@ OrigNameCache at all? Good question; after all, 3) Loading of interface files encodes names via Uniques, as detailed in Note [Symbol table representation of names] in GHC.Iface.Binary -It turns out that we end up looking up built-in syntax in the cache when we -generate Haddock documentation. E.g. if we don't find tuple data constructors -there, hyperlinks won't work as expected. Test case: haddockHtmlTest (Bug923.hs) + +However note that: + 1) It turns out that we end up looking up built-in syntax in the cache when + we generate Haddock documentation. E.g. if we don't find tuple data + constructors there, hyperlinks won't work as expected. Test case: + haddockHtmlTest (Bug923.hs) + 2) HIE de-serialization relies on wired-in names, including built-in syntax, + being present in the OrigNameCache. -} -- | The NameCache makes sure that there is just one Unique assigned for ===================================== libraries/base/changelog.md ===================================== @@ -1,6 +1,7 @@ # Changelog for [`base` package](http://hackage.haskell.org/package/base) ## 4.23.0.0 *TBA* + * Remove deprecated, unstable heap representation details from `GHC.Exts` ([CLC proposal #212](https://github.com/haskell/core-libraries-committee/issues/212)) * Add `Data.List.NonEmpty.mapMaybe`. ([CLC proposal #337](https://github.com/haskell/core-libraries-committee/issues/337)) * Fix issues with toRational for types capable to represent infinite and not-a-number values ([CLC proposal #338](https://github.com/haskell/core-libraries-committee/issues/338)) * Modify the implementation of `Data.List.sortOn` to use `(>)` instead of `compare`. ([CLC proposal #332](https://github.com/haskell/core-libraries-committee/issues/332)) ===================================== libraries/base/src/GHC/Exts.hs ===================================== @@ -26,12 +26,6 @@ module GHC.Exts -- ** Legacy interface for arrays of arrays module GHC.Internal.ArrayArray, -- * Primitive operations - {-# DEPRECATED ["The BCO, mkApUpd0#, and newBCO# re-exports from GHC.Exts have been deprecated and will be removed in 9.14", "These symbols should be imported from ghc-internal instead if needed."] #-} - Prim.BCO, - {-# DEPRECATED ["The BCO, mkApUpd0#, and newBCO# re-exports from GHC.Exts have been deprecated and will be removed in 9.14", "These symbols should be imported from ghc-internal instead if needed."] #-} - Prim.mkApUpd0#, - {-# DEPRECATED ["The BCO, mkApUpd0#, and newBCO# re-exports from GHC.Exts have been deprecated and will be removed in 9.14", "These symbols should be imported from ghc-internal instead if needed."] #-} - Prim.newBCO#, module GHC.Prim, module GHC.Prim.Ext, -- ** Running 'RealWorld' state thread @@ -130,9 +124,6 @@ import GHC.Prim hiding , whereFrom# , isByteArrayWeaklyPinned#, isMutableByteArrayWeaklyPinned# - -- deprecated - , BCO, mkApUpd0#, newBCO# - -- Don't re-export vector FMA instructions , fmaddFloatX4# , fmsubFloatX4# @@ -255,8 +246,6 @@ import GHC.Prim hiding , minWord8X32# , minWord8X64# ) -import qualified GHC.Prim as Prim - ( BCO, mkApUpd0#, newBCO# ) import GHC.Prim.Ext ===================================== libraries/ghci/GHCi/CreateBCO.hs ===================================== @@ -6,10 +6,6 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wno-warnings-deprecations #-} --- TODO We want to import GHC.Internal.Base (BCO, mkApUpd0#, newBCO#) instead --- of from GHC.Exts when we can require of the bootstrap compiler to have --- ghc-internal. -- -- (c) The University of Glasgow 2002-2006 @@ -30,7 +26,8 @@ import Data.Array.Base import Foreign hiding (newArray) import Unsafe.Coerce (unsafeCoerce) import GHC.Arr ( Array(..) ) -import GHC.Exts +import GHC.Exts hiding ( BCO, mkApUpd0#, newBCO# ) +import GHC.Internal.Base ( BCO, mkApUpd0#, newBCO# ) import GHC.IO import Control.Exception ( ErrorCall(..) ) ===================================== libraries/ghci/GHCi/TH.hs ===================================== @@ -1,9 +1,6 @@ {-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, DeriveGeneric, TupleSections, RecordWildCards, InstanceSigs, CPP #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -Wno-warnings-deprecations #-} --- TODO We want to import GHC.Internal.Desugar instead of GHC.Desugar when we --- can require of the bootstrap compiler to have ghc-internal. -- | -- Running TH splices @@ -112,7 +109,7 @@ import Data.IORef import Data.Map (Map) import qualified Data.Map as M import Data.Maybe -import GHC.Desugar (AnnotationWrapper(..)) +import GHC.Internal.Desugar (AnnotationWrapper(..)) import qualified GHC.Boot.TH.Syntax as TH import Unsafe.Coerce ===================================== libraries/ghci/ghci.cabal.in ===================================== @@ -86,11 +86,7 @@ library rts, array == 0.5.*, base >= 4.8 && < 4.23, - -- ghc-internal == @ProjectVersionForLib@.* - -- TODO: Use GHC.Internal.Desugar and GHC.Internal.Base from - -- ghc-internal instead of ignoring the deprecation warning in GHCi.TH - -- and GHCi.CreateBCO when we require ghc-internal of the bootstrap - -- compiler + ghc-internal >= 9.1001.0 && <=@ProjectVersionForLib@.0, ghc-prim >= 0.5.0 && < 0.14, binary == 0.8.*, bytestring >= 0.10 && < 0.13, ===================================== rts/Disassembler.c ===================================== @@ -89,7 +89,7 @@ disInstr ( StgBCO *bco, int pc ) p1 = BCO_GET_LARGE_ARG; info_mod = BCO_GET_LARGE_ARG; info_unit_id = BCO_GET_LARGE_ARG; - info_wix = BCO_NEXT; + info_wix = BCO_READ_NEXT_32; np = BCO_GET_LARGE_ARG; debugBelch ("BRK_FUN " ); printPtr( ptrs[p1] ); debugBelch("%" FMT_Word, literals[info_mod] ); ===================================== rts/Interpreter.c ===================================== @@ -720,7 +720,7 @@ interpretBCO (Capability* cap) arg1_brk_array = BCO_GET_LARGE_ARG; /* info_mod_name = */ BCO_GET_LARGE_ARG; /* info_mod_id = */ BCO_GET_LARGE_ARG; - arg4_info_index = BCO_NEXT; + arg4_info_index = BCO_READ_NEXT_32; StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]); StgArrBytes* breakPoints = (StgArrBytes *) BCO_PTR(arg1_brk_array); @@ -1542,7 +1542,7 @@ run_BCO: arg1_brk_array = BCO_GET_LARGE_ARG; arg2_info_mod_name = BCO_GET_LARGE_ARG; arg3_info_mod_id = BCO_GET_LARGE_ARG; - arg4_info_index = BCO_NEXT; + arg4_info_index = BCO_READ_NEXT_32; #if defined(PROFILING) arg5_cc = BCO_GET_LARGE_ARG; #else ===================================== testsuite/tests/module/T21752.stderr deleted ===================================== @@ -1,32 +0,0 @@ -T21752A.hs:4:5: warning: [GHC-68441] [-Wdeprecations (in -Wextended-warnings)] - In the use of ‘newBCO#’ (imported from GHC.Exts): - Deprecated: "The BCO, mkApUpd0#, and newBCO# re-exports from GHC.Exts have been deprecated and will be removed in 9.14 - These symbols should be imported from ghc-internal instead if needed." - -T21752A.hs:4:5: warning: [GHC-68441] [-Wdeprecations (in -Wextended-warnings)] - In the use of ‘newBCO#’ (imported from GHC.Exts): - Deprecated: "The BCO, mkApUpd0#, and newBCO# re-exports from GHC.Exts have been deprecated and will be removed in 9.14 - These symbols should be imported from ghc-internal instead if needed." - -T21752A.hs:4:5: warning: [GHC-68441] [-Wdeprecations (in -Wextended-warnings)] - In the use of ‘mkApUpd0#’ (imported from GHC.Exts): - Deprecated: "The BCO, mkApUpd0#, and newBCO# re-exports from GHC.Exts have been deprecated and will be removed in 9.14 - These symbols should be imported from ghc-internal instead if needed." - -T21752A.hs:4:5: warning: [GHC-68441] [-Wdeprecations (in -Wextended-warnings)] - In the use of ‘mkApUpd0#’ (imported from GHC.Exts): - Deprecated: "The BCO, mkApUpd0#, and newBCO# re-exports from GHC.Exts have been deprecated and will be removed in 9.14 - These symbols should be imported from ghc-internal instead if needed." - -T21752A.hs:4:5: warning: [GHC-68441] [-Wdeprecations (in -Wextended-warnings)] - In the use of type constructor or class ‘BCO’ - (imported from GHC.Exts): - Deprecated: "The BCO, mkApUpd0#, and newBCO# re-exports from GHC.Exts have been deprecated and will be removed in 9.14 - These symbols should be imported from ghc-internal instead if needed." - -T21752A.hs:4:5: warning: [GHC-68441] [-Wdeprecations (in -Wextended-warnings)] - In the use of type constructor or class ‘BCO’ - (imported from GHC.Exts): - Deprecated: "The BCO, mkApUpd0#, and newBCO# re-exports from GHC.Exts have been deprecated and will be removed in 9.14 - These symbols should be imported from ghc-internal instead if needed." - ===================================== utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs ===================================== @@ -229,10 +229,7 @@ writeInterfaceFile filename iface = do return () freshNameCache :: IO NameCache -freshNameCache = - initNameCache - 'a' -- ?? - [] +freshNameCache = newNameCache -- | Read a Haddock (@.haddock@) interface file. Return either an -- 'InterfaceFile' or an error message. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1bfe81288fe9932253919504b969d5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1bfe81288fe9932253919504b969d5… You're receiving this email because of your account on gitlab.haskell.org.

1 0