- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: testsuite: Don't crash on non-UTF-8 test output
by Marge Bot (＠marge-bot) 05 Aug '26

05 Aug '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 0107ac17 by Simon Jakobi at 2026-08-05T10:43:19-04:00 testsuite: Don't crash on non-UTF-8 test output read_stdout, read_stderr_for, read_comp_stderr and read_diff decoded strictly (the first three with UTF-8, read_diff with the locale encoding), so a test emitting invalid UTF-8 (binary output, or a crash truncating a multi-byte character) raised UnicodeDecodeError and was reported as a framework failure instead of its actual result. Decode with errors='replace', like read_no_crs and safe_print. Assisted-by: Claude Fable 5 - - - - - b1ce96fe by Simon Jakobi at 2026-08-05T10:43:19-04:00 testsuite: Colorize the test summary, also in CI The summary headings were plain, and SUMMARY was colored unconditionally, so the escapes also ended up in the file written by --summary-file. Color is now decided per output sink via term_color.colored_if; see the comments in term_color. CI logs are not a tty, but GitLab's log viewer renders ANSI colors, so add --force-colors and pass it in .gitlab/ci.sh. Assisted-by: Claude Opus 5 - - - - - 76b9c848 by Simon Jakobi at 2026-08-05T10:43:19-04:00 testsuite: Repeat unexpected failure output in the summary Finding out why a test failed meant scrolling back through a possibly very long log to the point where the test ran. The summary now repeats the captured output of unexpected failures, before the statistics, so the most interesting part is at the end of the log (#16720). Output mismatches report their diff instead of the mismatching stream (see Note [Redundant output in test results]). The repeated output is bounded per stream, and skipped altogether beyond MAX_SUMMARY_OUTPUT_TESTS failure blocks. Tests failing identically in several ways share one block. Test results now report a source-relative directory, stable regardless of where the run was started from. Assisted-by: Claude Fable 5 - - - - - cf11be9b by Ben Gamari at 2026-08-05T10:43:20-04:00 base: Don't drop exception context in SomeException(toException) For reasons that are lost to time, the implementation of [CLC #200] that was merged inappropriately dropped `ExceptionContext` in the `toException` implementation given to `SomeException`. Fix this infelicity. [CLC #200]: https://github.com/haskell/core-libraries-committee/issues/200 - - - - - 128abdf7 by Vladislav Zavialov at 2026-08-05T10:43:21-04:00 Test case for #20902 Starting with GHC 9.14.1 (the first major release to include 51e3ec83), and from point releases GHC 9.10.2 and GHC 9.12.3 (backports cc4470be68 and b30f25591e), all examples in this ticket are handled as expected. - - - - - eef7745a by Alan Zimmerman at 2026-08-05T10:43:21-04:00 EPA: Remove LocatedP, last use in WarningTxt The last step of removing LocatedP, by moving the AnnPragma for WarningTxt into its TTG extension point instead. This also allows us to remove LocatedP and SrcSpanAnnP - - - - - 8f35ea68 by Vladislav Zavialov at 2026-08-05T10:43:22-04:00 Test cases for #18725 Starting with GHC 9.4 (the first release to include 268efcc9a4), the program in this ticket no longer panics. A standalone kind signature breaks the recursive loop, so the type constructor can be used in a kind within its own group. T18725a checks that this is accepted with the signature present, while T18725b confirms it is still rejected without it. - - - - - 25 changed files: - .gitlab/ci.sh - + changelog.d/T27455 - compiler/GHC/Builtin/Utils.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Warnings.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Unit/Module/Warnings.hs - libraries/base/changelog.md - libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs - testsuite/driver/runtests.py - testsuite/driver/term_color.py - testsuite/driver/testlib.py - testsuite/tests/ghc-e/should_fail/T18441fail7.stderr - testsuite/tests/ghc-e/should_run/ghc-e005.stderr - + testsuite/tests/saks/should_compile/T18725a.hs - testsuite/tests/saks/should_compile/all.T - + testsuite/tests/saks/should_fail/T18725b.hs - + testsuite/tests/saks/should_fail/T18725b.stderr - testsuite/tests/saks/should_fail/all.T - + testsuite/tests/th/T20902.hs - testsuite/tests/th/all.T - utils/check-exact/ExactPrint.hs Changes: ===================================== .gitlab/ci.sh ===================================== @@ -652,6 +652,10 @@ function test_hadrian() { check_msys2_deps _build/stage1/bin/ghc --version check_release_build + # GitLab's log viewer renders ANSI colors, but stdout here is not a tty, + # so the driver must be told to emit them. + RUNTEST_ARGS="${RUNTEST_ARGS:-} --force-colors" + # Ensure that statically-linked builds are actually static if [[ "${BUILD_FLAVOUR}" = *static* ]]; then bad_execs="" ===================================== changelog.d/T27455 ===================================== @@ -0,0 +1,8 @@ +section: base +issues: #27455 +mrs: !16274 +synopsis: + Don't drop `ExceptionContext` in `SomeException(toException)` +description: + Previously the implementation of ``Exception(toException)`` given to `SomeException` would inappropriately drop the carried `ExceptionContext`. Now ``toException = id``, faithfully implementing the semantics proposed in :ref:`CLC Proposal #200 <https://github.com/haskell/core-libraries-committee/issues/200>`. + ===================================== compiler/GHC/Builtin/Utils.hs ===================================== @@ -301,7 +301,7 @@ ghcPrimWarns = WarnSome [] where mk_txt msg = - DeprecatedTxt NoSourceText [noLocA $ WithHsDocIdentifiers (StringLiteral NoSourceText (fastStringToShortText msg)) []] + DeprecatedTxt (NoSourceText, noAnn) [noLocA $ WithHsDocIdentifiers (StringLiteral NoSourceText (fastStringToShortText msg)) []] mk_decl_dep (occ, msg) = (occ, mk_txt msg) ghcPrimFixities :: [(OccName,Fixity)] ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -1043,7 +1043,7 @@ cidDeprecation :: forall p. IsPass p cidDeprecation = fmap unLoc . decl_deprecation (ghcPass @p) where decl_deprecation :: GhcPass p -> ClsInstDecl (GhcPass p) - -> Maybe (LocatedP (WarningTxt (GhcPass p))) + -> Maybe (LocatedA (WarningTxt (GhcPass p))) decl_deprecation GhcPs (ClsInstDecl{ cid_ext = (depr, _) } ) = depr decl_deprecation GhcRn (ClsInstDecl{ cid_ext = (depr, _) }) @@ -1242,7 +1242,7 @@ derivDeprecation :: forall p. IsPass p derivDeprecation = fmap unLoc . decl_deprecation (ghcPass @p) where decl_deprecation :: GhcPass p -> DerivDecl (GhcPass p) - -> Maybe (LocatedP (WarningTxt (GhcPass p))) + -> Maybe (LocatedA (WarningTxt (GhcPass p))) decl_deprecation GhcPs (DerivDecl{ deriv_ext = (depr, _) }) = depr decl_deprecation GhcRn (DerivDecl{ deriv_ext = (depr, _) }) ===================================== compiler/GHC/Hs/Dump.hs ===================================== @@ -99,7 +99,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet `ext2Q` located `extQ` srcSpanAnnA - `extQ` srcSpanAnnP `extQ` srcSpanAnnN `extQ` srcSpanAnnBF @@ -409,9 +408,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 srcSpanAnnA :: EpAnn [TrailingAnn] -> SDoc srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA") - srcSpanAnnP :: EpAnn AnnPragma -> SDoc - srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP") - srcSpanAnnN :: EpAnn NameAnn -> SDoc srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN") ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -83,7 +83,7 @@ import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisForAllTyFlag ) import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..)) import GHC.Builtin.Types ( constraintKindTyConName ) import GHC.Stg.EnforceEpt.TagSig -import GHC.Parser.Annotation (noLocA) +import GHC.Parser.Annotation (noLocA, noAnn) import GHC.Hs.Extension ( GhcPass, GhcRn, GhcTc ) import GHC.Hs.Decls.Overlap ( OverlapFlag ) import GHC.Hs.Doc ( WithHsDocIdentifiers(..) ) @@ -666,8 +666,8 @@ fromIfaceWarnings = \case fromIfaceWarningTxt :: IfaceWarningTxt -> WarningTxt GhcRn fromIfaceWarningTxt = \case - IfWarningTxt src mb_cat strs -> WarningTxt src (noLocA . fromWarningCategory <$> mb_cat) (noLocA <$> map fromIfaceStringLiteralWithNames strs) - IfDeprecatedTxt src strs -> DeprecatedTxt src (noLocA <$> map fromIfaceStringLiteralWithNames strs) + IfWarningTxt src mb_cat strs -> WarningTxt (src, noAnn) (noLocA . fromWarningCategory <$> mb_cat) (noLocA <$> map fromIfaceStringLiteralWithNames strs) + IfDeprecatedTxt src strs -> DeprecatedTxt (src, noAnn) (noLocA <$> map fromIfaceStringLiteralWithNames strs) fromIfaceStringLiteralWithNames :: (IfaceStringLiteral, [IfExtName]) -> WithHsDocIdentifiers (StringLiteral GhcRn) GhcRn fromIfaceStringLiteralWithNames (str, names) = WithHsDocIdentifiers (fromIfaceStringLiteral str) (map noLocA names) ===================================== compiler/GHC/Iface/Warnings.hs ===================================== @@ -22,12 +22,11 @@ toIfaceWarnings (WarnSome vs ds) = IfWarnSome vs' ds' ds' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- ds] toIfaceWarningTxt :: WarningTxt GhcRn -> IfaceWarningTxt -toIfaceWarningTxt (WarningTxt src mb_cat strs) = IfWarningTxt src (unLoc . iwc_wc . unLoc <$> mb_cat) (map (toIfaceStringLiteralWithNames . unLoc) strs) -toIfaceWarningTxt (DeprecatedTxt src strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs) +toIfaceWarningTxt (WarningTxt (src, _) mb_cat strs) = IfWarningTxt src (unLoc . iwc_wc . unLoc <$> mb_cat) (map (toIfaceStringLiteralWithNames . unLoc) strs) +toIfaceWarningTxt (DeprecatedTxt (src, _) strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs) toIfaceStringLiteralWithNames :: WithHsDocIdentifiers (StringLiteral GhcRn) GhcRn -> (IfaceStringLiteral, [IfExtName]) toIfaceStringLiteralWithNames (WithHsDocIdentifiers src names) = (toIfaceStringLiteral src, map unLoc names) toIfaceStringLiteral :: StringLiteral GhcRn -> IfaceStringLiteral -toIfaceStringLiteral sLit = - IfStringLiteral (stringLitSourceText sLit) (sl_fs sLit) +toIfaceStringLiteral sLit = IfStringLiteral (stringLitSourceText sLit) (sl_fs sLit) ===================================== compiler/GHC/Parser.y ===================================== @@ -2077,11 +2077,13 @@ to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated. maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) } : '{-# DEPRECATED' strings '#-}' - {% fmap Just $ amsr (sLL $1 $> $ DeprecatedTxt (getDEPRECATED_PRAGs $1) (snd $ unLoc $2)) - (AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn) } + {% fmap Just $ amsA' (sLL $1 $> $ + DeprecatedTxt (getDEPRECATED_PRAGs $1, AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn) + (snd $ unLoc $2))} | '{-# WARNING' warning_category strings '#-}' - {% fmap Just $ amsr (sLL $1 $> $ WarningTxt (getWARNING_PRAGs $1) $2 (snd $ unLoc $3)) - (AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn)} + {% fmap Just $ amsA' (sLL $1 $> $ + WarningTxt (getWARNING_PRAGs $1, AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn) + $2 (snd $ unLoc $3))} | {- empty -} { Nothing } warning_category :: { Maybe (LocatedE (InWarningCategory GhcPs)) } @@ -2110,7 +2112,7 @@ warning :: { OrdList (LWarnDecl GhcPs) } : warning_category namespace_spec namelist strings {% fmap unitOL $ amsA' (L (comb4 $1 $2 $3 $4) (Warning (fst $ unLoc $4) (unLoc $2) (unLoc $3) - (WarningTxt NoSourceText $1 (snd $ unLoc $4)))) } + (WarningTxt (NoSourceText, noAnn) $1 (snd $ unLoc $4)))) } namespace_spec :: { Located (NamespaceSpecifier GhcPs) } : 'type' { sL1 $1 $ TypeNamespaceSpecifier (epTok $1) } @@ -2138,7 +2140,7 @@ deprecations :: { OrdList (LWarnDecl GhcPs) } deprecation :: { OrdList (LWarnDecl GhcPs) } : namespace_spec namelist strings {% fmap unitOL $ amsA' (sL (comb3 $1 $2 $>) $ (Warning (fst $ unLoc $3) (unLoc $1) (unLoc $2) - (DeprecatedTxt NoSourceText $ snd $ unLoc $3))) } + (DeprecatedTxt (NoSourceText, noAnn) $ snd $ unLoc $3))) } strings :: { Located ((EpToken "[", EpToken "]"), [LocatedA (WithHsDocIdentifiers (StringLiteral GhcPs) GhcPs)]) } : STRING { sL1 $1 (noAnn,[stringLiteralToHsDocWst (L (gl $1) (getStringLiteral $1))]) } ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -27,9 +27,9 @@ module GHC.Parser.Annotation ( EpAnnCO, -- ** Annotations in 'GenLocated' - LocatedA, LocatedN, LocatedAn, LocatedP, + LocatedA, LocatedN, LocatedAn, LocatedE, LocatedBF, - SrcSpanAnnA, SrcSpanAnnP, SrcSpanAnnN, + SrcSpanAnnA, SrcSpanAnnN, SrcSpanAnnBF, -- ** Annotation data types used in 'GenLocated' @@ -430,7 +430,6 @@ emptyComments = EpaComments [] type LocatedA = GenLocated SrcSpanAnnA type LocatedN = GenLocated SrcSpanAnnN -type LocatedP = GenLocated SrcSpanAnnP type LocatedBF = GenLocated SrcSpanAnnBF -- | Annotation for items appearing in a list. They can have one or @@ -441,7 +440,6 @@ type SrcSpanAnnA = EpAnn [TrailingAnn] -- on the context, such as backticks. type SrcSpanAnnN = EpAnn NameAnn -type SrcSpanAnnP = EpAnn AnnPragma type SrcSpanAnnBF = EpAnn AnnBooleanFormula type LocatedE = GenLocated EpaLocation ===================================== compiler/GHC/Unit/Module/Warnings.hs ===================================== @@ -158,8 +158,8 @@ warningTxtSame w1 w2 instance Outputable (InWarningCategory (GhcPass pass)) where ppr (InWarningCategory _ wt) = text "in" <+> doubleQuotes (ppr wt) -type instance XDeprecatedTxt (GhcPass _) = SourceText -type instance XWarningTxt (GhcPass _) = SourceText +type instance XDeprecatedTxt (GhcPass _) = (SourceText, AnnPragma) +type instance XWarningTxt (GhcPass _) = (SourceText, AnnPragma) type instance XXWarningTxt (GhcPass _) = DataConCantHappen type instance XInWarningCategory (GhcPass _) = (EpToken "in", SourceText) type instance XXInWarningCategory (GhcPass _) = DataConCantHappen @@ -167,7 +167,7 @@ type instance XXInWarningCategory (GhcPass _) = DataConCantHappen type instance Anno (WithHsDocIdentifiers (StringLiteral pass) pass) = SrcSpanAnnA type instance Anno (InWarningCategory (GhcPass pass)) = EpaLocation type instance Anno (WarningCategory) = EpaLocation -type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnP +type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnA deriving stock instance Eq (WarningTxt GhcPs) deriving stock instance Eq (WarningTxt GhcRn) @@ -190,15 +190,15 @@ deriving instance Outputable WarningCategory instance Outputable (WarningTxt (GhcPass pass)) where ppr (WarningTxt lsrc mcat ws) = case lsrc of - NoSourceText -> pp_ws ws - SourceText src -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}" + (NoSourceText, _) -> pp_ws ws + (SourceText src, _) -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}" where ctg_doc = maybe empty (\ctg -> ppr ctg) mcat ppr (DeprecatedTxt lsrc ds) = case lsrc of - NoSourceText -> pp_ws ds - SourceText src -> ftext src <+> pp_ws ds <+> text "#-}" + (NoSourceText, _) -> pp_ws ds + (SourceText src, _) -> ftext src <+> pp_ws ds <+> text "#-}" pp_ws :: [LocatedA (WithHsDocIdentifiers (StringLiteral (GhcPass p)) (GhcPass p))] -> SDoc pp_ws [l] = ppr $ unLoc l ===================================== libraries/base/changelog.md ===================================== @@ -38,6 +38,7 @@ * Show `ExceptionContext` in `displayExceptionAnnotation` implementation of `WhileHandling` ([GHC #27456](https://gitlab.haskell.org/ghc/ghc/-/issues/27456)) * Hide implementation details when throwing exceptions in throw and throwSTM. ([CLC proposal #387](https://github.com/haskell/core-libraries-committee/issues/387)) * Change `hIsReadable` and `hIsWritable` such that they always throw a respective exception when encountering a closed or semi-closed handle, not just in the case of a file handle. ([CLC proposal #371](github.com/haskell/core-libraries-committee/issues/371)) + * The implementation of `toException` in `SomeException`'s `Exception` instance no longer drops exception context, in keeping with the behavior originally proposed in [CLC Proposal #200](https://github.com/haskell/core-libraries-committee/issues/200). * Annotate `onException` continuation with `WhileHandling`. ([CLC Proposal #397](https://github.com/haskell/core-libraries-committee/issues/397)) * Improve error message for `Data.Char.chr`. ([CLC Proposal #384](https://github.com/haskell/core-libraries-committee/issues/384)) ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs ===================================== @@ -55,7 +55,7 @@ import GHC.Internal.Data.Maybe import GHC.Internal.Data.Typeable (Typeable, TypeRep, cast) import qualified GHC.Internal.Data.Typeable as Typeable -- loop: GHC.Internal.Data.Typeable -> GHC.Internal.Err -> GHC.Internal.Exception -import GHC.Internal.Base (String, Void, fmap, return, ($), (.), (++)) +import GHC.Internal.Base (String, Void, fmap, return, ($), (.), (++), id) import GHC.Internal.Show import GHC.Internal.Types (Bool(..)) import GHC.Internal.Exception.Context @@ -208,7 +208,16 @@ Caught MismatchedParentheses -} class (Typeable e, Show e) => Exception e where - -- | @toException@ should produce a 'SomeException' with no attached 'ExceptionContext'. + -- | 'toException' converts an exception into the existential 'SomeException' + -- wrapper type. + -- + -- In doing so, 'toException' should not /add/ an 'ExceptionContext'. + -- + -- - In most cases, the exception does not store its own 'ExceptionContext'. + -- The default implementation of 'toException' (which does not store any + -- 'ExceptionContext') is suitable for these cases. + -- - In the rare case that the exception itself stores an 'ExceptionContext', + -- this context should be preserved by 'toException'. toException :: e -> SomeException fromException :: SomeException -> Maybe e @@ -231,13 +240,11 @@ class (Typeable e, Show e) => Exception e where -- | @since base-4.8.0.0 instance Exception Void --- | This drops any attached 'ExceptionContext'. +-- | NB: this instance preserves the attached 'ExceptionContext'. -- -- @since base-3.0 instance Exception SomeException where - toException (SomeException e) = - let ?exceptionContext = emptyExceptionContext - in SomeException e + toException = id fromException = Just backtraceDesired (SomeException e) = backtraceDesired e displayException (SomeException e) = displayException e ===================================== testsuite/driver/runtests.py ===================================== @@ -94,6 +94,8 @@ parser.add_argument("--ignore-perf-failures", choices=['increases','decreases',' help="Do not fail due to out-of-tolerance perf tests") parser.add_argument("--only-report-hadrian-deps", type=Path, help="Dry run the testsuite and report all extra hadrian dependencies needed on the given file") +parser.add_argument("--force-colors", action="store_true", + help="emit ANSI colors even when stdout is not a tty (e.g. for CI logs)") args = parser.parse_args() @@ -259,7 +261,9 @@ def supports_colors(): return True config.supports_colors = supports_colors() -term_color.enable_color = config.supports_colors +# config.supports_colors deliberately stays tty-based: it also guards +# terminal-title updates, which must not end up in a CI log. +term_color.enable_color = config.supports_colors or args.force_colors # This has to come after arg parsing as the args can change the compiler get_compiler_info() @@ -587,7 +591,7 @@ else: print(Perf.allow_changes_string([(m.change, m.stat) for m in t.metrics])) print('-' * 25) - summary(t, sys.stdout, color=config.supports_colors) + summary(t, sys.stdout, color=term_color.enable_color, junit_path=args.junit) # Write perf stats if any exist or if a metrics file is specified. stats_metrics = [stat for (_, stat, __) in t.metrics] # type: List[PerfStat] ===================================== testsuite/driver/term_color.py ===================================== @@ -1,5 +1,6 @@ from enum import Enum +# Whether to emit color escapes; set in runtests.py. enable_color = True class Color(Enum): @@ -18,3 +19,7 @@ def colored(color: Color, s: str) -> str: else: return s +# For renderers that serve several sinks: `enabled` says whether *this* sink +# takes color (the summary is written both to stdout and to a plain-text file). +def colored_if(enabled: bool, color: Color, s: str) -> str: + return colored(color, s) if enabled else s ===================================== testsuite/driver/testlib.py ===================================== @@ -27,7 +27,7 @@ from testutil import strip_quotes, lndir, link_or_copy_file, passed, \ failBecause, testing_metrics, residency_testing_metrics, \ stable_perf_counters, \ PassFail, badResult, str_warn, str_removeprefix -from term_color import Color, colored +from term_color import Color, colored_if import testutil from cpu_features import have_cpu_feature import perf_notes as Perf @@ -1499,6 +1499,19 @@ def _newTestDir(name: TestName, opts: TestOptions, tempdir, dir): opts.testdir_raw = Path(os.path.join(tempdir, testdir, name + testdir_suffix)) opts.compiler_always_flags = config.compiler_always_flags +def _result_directory(opts: TestOptions) -> str: + # The test's source directory, relative to the GHC source root, so it reads + # the same regardless of which directory `make` was invoked from. + srcdir = opts.srcdir + if srcdir is None: + return '' + try: + return os.path.relpath(srcdir, config.top.parent) + except ValueError: + # No relative path exists (e.g. different Windows drives); the + # absolute path is still more useful than nothing. + return str(srcdir) + # ----------------------------------------------------------------------------- # Actually doing tests @@ -1823,7 +1836,7 @@ async def do_test(name: TestName, if opts.expect not in ['pass', 'fail', 'missing-lib']: framework_fail(name, way, 'bad expected ' + opts.expect) - directory = str_removeprefix(str_removeprefix(str(opts.testdir), './'), '.\\') + directory = _result_directory(opts) if way in opts.fragile_ways: if_verbose(1, '*** fragile test %s resulted in %s' % (full_name, 'pass' if result.passed else 'fail')) @@ -1877,7 +1890,7 @@ def framework_fail(name: Optional[TestName], way: Optional[WayName], reason: str # so we need to take care not to blow up with the wrong way # and report the actual reason for the failure. try: - directory = str_removeprefix(str_removeprefix(str(opts.testdir), './'), '.\\') + directory = _result_directory(opts) except: directory = '' full_name = '%s(%s)' % (name, way) @@ -1890,7 +1903,7 @@ def framework_fail(name: Optional[TestName], way: Optional[WayName], reason: str def framework_warn(name: TestName, way: WayName, reason: str) -> None: opts = getTestOpts() - directory = str_removeprefix(str_removeprefix(str(opts.testdir), './'), '.\\') + directory = _result_directory(opts) full_name = name + '(' + way + ')' if_verbose(1, '*** framework warning for %s %s ' % (full_name, reason)) t.framework_warnings.append(TestResult(directory, name, reason, way)) @@ -2445,19 +2458,23 @@ async def simple_run(name: TestName, way: WayName, prog: str, extra_run_opts: st dump_stdout(name) dump_stderr(name) message = format_bad_exit_code_message(exit_code) - return failBecause(message) + return failBecause(message, + stderr=read_stderr(name), + stdout=read_stdout(name)) stderr_match = CompareOutput(True) if (opts.ignore_stderr or opts.combined_output) else await stderr_ok(name, way) if not stderr_match: + # The diff already contains the mismatching stream; see Note [Redundant + # output in test results]. return failBecause('bad stderr', - stderr=read_stderr(name), + stderr=None if stderr_match.diff else read_stderr(name), stdout=read_stdout(name), diff=stderr_match.diff) stdout_match = CompareOutput(True) if opts.ignore_stdout else await stdout_ok(name, way) if not stdout_match: return failBecause('bad stdout', stderr=read_stderr(name), - stdout=read_stdout(name), + stdout=None if stdout_match.diff else read_stdout(name), diff=stdout_match.diff) check_hp = '-hT' in my_rts_flags and opts.check_hp @@ -2567,8 +2584,9 @@ async def interpreter_run(name: TestName, if not stderr_match: if _expect_pass(way): dump_stderr_for('comp', name) + # See Note [Redundant output in test results]. return failBecause('bad stderr', - stderr=read_stderr(name), + stderr=None if stderr_match.diff else read_stderr(name), stdout=read_stdout(name), diff=stderr_match.diff) stdout_match = CompareOutput(True) if opts.ignore_stdout else await stdout_ok(name, way) @@ -2577,7 +2595,7 @@ async def interpreter_run(name: TestName, dump_stderr_for('comp', name) return failBecause('bad stdout', stderr=read_stderr(name), - stdout=read_stdout(name), + stdout=None if stdout_match.diff else read_stdout(name), diff=stdout_match.diff) return passed() @@ -2635,13 +2653,13 @@ async def stdout_ok(name: TestName, way: WayName) -> CompareOutput: def read_stdout( name: TestName ) -> str: path = in_testdir(name, 'run.stdout') if path.exists(): - return path.read_text(encoding='UTF-8') + return path.read_text(encoding='UTF-8', errors='replace') else: return '' def read_diff( diff_file: Path ) -> Optional[str]: if diff_file.exists(): - diff = diff_file.read_text() + diff = diff_file.read_text(encoding='UTF-8', errors='replace') diff_file.unlink() return diff or None else: @@ -2665,14 +2683,14 @@ async def stderr_ok(name: TestName, way: WayName) -> CompareOutput: def read_comp_stderr( name: TestName ) -> str: path = in_testdir(name, 'comp.stderr') if path.exists(): - return path.read_text(encoding='UTF-8') + return path.read_text(encoding='UTF-8', errors='replace') else: return '' def read_stderr_for( phase: str, name: TestName ) -> str: path = in_testdir(name, phase + '.stderr') if path.exists(): - return path.read_text(encoding='UTF-8') + return path.read_text(encoding='UTF-8', errors='replace') else: return '' @@ -3571,12 +3589,50 @@ def findTFiles(roots: List[str]) -> Iterator[str]: # ----------------------------------------------------------------------------- # Output a test summary to the specified file object -def summary(t: TestRun, file: TextIO, color=False) -> None: +def summary(t: TestRun, file: TextIO, color=False, junit_path: Optional[Path]=None) -> None: file.write('\n') + + if t.unexpected_failures: + # Count output blocks rather than results: a test failing in many ways + # collapses to a single block. + groups = groupTestOutput(t.unexpected_failures) + if len(groups) <= MAX_SUMMARY_OUTPUT_TESTS: + printTestOutputSummary(file, groups, color, junit_path) + else: + where = '; see {}'.format(junit_path) if junit_path else '' + header = ('Unexpected failures (more than {}, output omitted{}):' + .format(MAX_SUMMARY_OUTPUT_TESTS, where)) + file.write(colored_if(color, Color.RED, header) + '\n') + printTestInfosSummary(file, t.unexpected_failures) + + if t.unexpected_passes: + header = 'Unexpected passes:' + file.write(colored_if(color, Color.RED, header) + '\n') + printTestInfosSummary(file, t.unexpected_passes) + + if t.unexpected_stat_failures: + header = 'Unexpected stat failures:' + file.write(colored_if(color, Color.RED, header) + '\n') + printTestInfosSummary(file, t.unexpected_stat_failures) + + if t.framework_failures: + header = 'Framework failures:' + file.write(colored_if(color, Color.RED, header) + '\n') + printTestInfosSummary(file, t.framework_failures) + + if t.framework_warnings: + header = 'Framework warnings:' + file.write(colored_if(color, Color.YELLOW, header) + '\n') + printTestInfosSummary(file, t.framework_warnings) + + if stopping(): + warning = 'WARNING: Testsuite run was terminated early' + file.write(colored_if(color, Color.YELLOW, warning) + '\n') + printUnexpectedTests(file, [t.unexpected_passes, t.unexpected_failures, - t.unexpected_stat_failures, t.framework_failures]) + t.unexpected_stat_failures, t.framework_failures], color) if len(t.unexpected_failures) > 0 or \ len(t.unexpected_stat_failures) > 0 or \ @@ -3587,7 +3643,8 @@ def summary(t: TestRun, file: TextIO, color=False) -> None: summary_color = Color.GREEN assert t.start_time is not None - file.write(colored(summary_color, 'SUMMARY') + ' for test run started at ' + summary_header = colored_if(color, summary_color, 'SUMMARY') + file.write(summary_header + ' for test run started at ' + t.start_time.strftime("%c %Z") + '\n' + str(datetime.datetime.now() - t.start_time).rjust(8) + ' spent to go through\n' @@ -3619,46 +3676,107 @@ def summary(t: TestRun, file: TextIO, color=False) -> None: + ' fragile tests\n' + '\n') - if t.unexpected_passes: - file.write('Unexpected passes:\n') - printTestInfosSummary(file, t.unexpected_passes) - - if t.unexpected_failures: - file.write('Unexpected failures:\n') - printTestInfosSummary(file, t.unexpected_failures) - - if t.unexpected_stat_failures: - file.write('Unexpected stat failures:\n') - printTestInfosSummary(file, t.unexpected_stat_failures) - - if t.framework_failures: - file.write('Framework failures:\n') - printTestInfosSummary(file, t.framework_failures) - - if t.framework_warnings: - file.write('Framework warnings:\n') - printTestInfosSummary(file, t.framework_warnings) - - if stopping(): - file.write('WARNING: Testsuite run was terminated early\n') - -def printUnexpectedTests(file: TextIO, testInfoss): +def printUnexpectedTests(file: TextIO, testInfoss, color=False): unexpected = set(result.testname for testInfos in testInfoss for result in testInfos if not result.testname.endswith('.T')) if unexpected: - file.write('Unexpected results from:\n') + header = 'Unexpected results from:' + file.write(colored_if(color, Color.RED, header) + '\n') file.write('TEST="' + ' '.join(sorted(unexpected)) + '"\n') file.write('\n') +# Per-stream cap on a failing test's output repeated in the final summary. +MAX_SUMMARY_OUTPUT_LINES = 100 + +# Above this many output blocks, skip repeating output entirely: the dump +# would drown out the summary. +MAX_SUMMARY_OUTPUT_TESTS = 20 + +# Note [Redundant output in test results] +# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +# A failing test result carries up to three pieces of output: `diff`, `stdout` +# and `stderr`. For an output mismatch these overlap: the diff's `+` lines are +# the very stream that mismatched, normalised. Reporting both would print the +# same text twice, so the mismatching stream is dropped at the call sites in +# favour of the diff, which additionally shows what was expected. The *other* +# stream is kept: on a stdout mismatch, stderr is independent context. +# +# The drop is conditional on there being a diff at all: compare_outputs only +# runs `diff` when config.verbose >= 1, so under -v0 the stream is the only +# output there is. +# +# Note that, since the drop happens at result construction, it also affects the +# JUnit report (junit.py). + +def strip_diff_header(diff: Optional[str]) -> Optional[str]: + # Drop diff(1)'s ---/+++ lines: they name normalised files in the test + # directory and carry timestamps, which would also keep otherwise + # identical failures from being grouped. + if diff is None: + return None + lines = diff.split('\n') + if len(lines) >= 2 and lines[0].startswith('--- ') and lines[1].startswith('+++ '): + return '\n'.join(lines[2:]) + return diff + +def sorted_results(testInfos: List[TestResult]) -> List[TestResult]: + return sorted(testInfos, key=lambda r: (r.testname.lower(), r.directory, r.way)) + +# A failure-output block: a representative result, its header-stripped diff, +# and the ways that share it. +OutputGroup = Tuple[TestResult, Optional[str], List[WayName]] + +# Tests that fail identically in several ways (e.g. normal and g1) share one +# output block, with the ways collected in the header. +def groupTestOutput(testInfos: List[TestResult]) -> List[OutputGroup]: + # Relies on dicts preserving insertion order. + groups = {} # type: Dict[Tuple, OutputGroup] + for result in sorted_results(testInfos): + diff = strip_diff_header(result.diff) + key = (result.testname, result.directory, result.reason, + diff, result.stdout, result.stderr) + groups.setdefault(key, (result, diff, []))[2].append(result.way) + return list(groups.values()) + +def printTestOutputSummary(file: TextIO, + groups: List[OutputGroup], + color: bool=False, + junit_path: Optional[Path]=None) -> None: + # Repeat failing tests' captured output in the summary, so one needn't + # hunt for it earlier in a possibly very long log; see #16720. + header = '=====> Unexpected failures output summary' + file.write(colored_if(color, Color.RED, header) + '\n\n') + + where = ', see {}'.format(junit_path) if junit_path else '' + for result, diff, ways in groups: + header = '=====> {}({}) ({}) [{}]'.format( + result.testname, ', '.join(ways), result.directory + os.sep, result.reason) + file.write(colored_if(color, Color.RED, header) + '\n') + # See Note [Redundant output in test results] for why these don't overlap. + for label, contents in [('Output diff (expected vs actual):', diff), + ('Captured stdout:', result.stdout), + ('Captured stderr:', result.stderr)]: + if contents and contents.strip(): + lines = contents.rstrip('\n').split('\n') + if len(lines) > MAX_SUMMARY_OUTPUT_LINES: + omitted = len(lines) - MAX_SUMMARY_OUTPUT_LINES + lines = lines[:MAX_SUMMARY_OUTPUT_LINES] \ + + ['... ({} more lines omitted{})'.format(omitted, where)] + s = colored_if(color, Color.CYAN, label) + '\n' \ + + ''.join(l + '\n' for l in lines) + # Test output can contain characters that file's encoding + # cannot represent; replace rather than crash (cf safe_print). + enc = getattr(file, 'encoding', None) or 'utf-8' + file.write(s.encode(enc, errors='replace').decode(enc)) + footer = '<===== end of unexpected failures output summary' + file.write(colored_if(color, Color.RED, footer) + '\n\n') + def printTestInfosSummary(file: TextIO, testInfos): - maxDirLen = max(len(tr.directory) for tr in testInfos) - for result in sorted(testInfos, key=lambda r: (r.testname.lower(), r.way, r.directory)): - directory = result.directory.ljust(maxDirLen) - file.write(' {directory} {r.testname} [{r.reason}] ({r.way})\n'.format( - r = result, - directory = directory)) + for result in sorted_results(testInfos): + path = os.path.join(result.directory, result.testname) + file.write(' {path} [{r.reason}] ({r.way})\n'.format(r=result, path=path)) file.write('\n') def modify_lines(s: str, f: Callable[[str], str]) -> str: ===================================== testsuite/tests/ghc-e/should_fail/T18441fail7.stderr ===================================== @@ -5,8 +5,12 @@ IO error: "Abcde" does not exist While handling ghc-10.1-inplace:GHC.Utils.Panic.GhcException: | | IO error: "Abcde" does not exist + | + | HasCallStack backtrace: + | throw, called at compiler/GHC/Utils/Panic.hs:180:21 in ghc-10.1-inplace:GHC.Utils.Panic + | throwGhcException, called at ghc/GHCi/UI.hs:2851:21 in ghc-bin-10.1.20260801-inplace:GHCi.UI HasCallStack backtrace: - throwIO, called at compiler\GHC\Utils\Error.hs:499:19 in ghc-10.1-inplace:GHC.Utils.Error + throwIO, called at compiler/GHC/Utils/Error.hs:513:19 in ghc-10.1-inplace:GHC.Utils.Error 1 ===================================== testsuite/tests/ghc-e/should_run/ghc-e005.stderr ===================================== @@ -4,3 +4,8 @@ foo HasCallStack backtrace: error, called at ghc-e005.hs:12:10 in main:Main + + +HasCallStack backtrace: + throwIO, called at ghc\GHCi\UI.hs:1655:31 in ghc-bin-10.1.20260629-inplace:GHCi.UI + ===================================== testsuite/tests/saks/should_compile/T18725a.hs ===================================== @@ -0,0 +1,10 @@ +{-# LANGUAGE ExplicitForAll, KindSignatures, StandaloneKindSignatures, + DataKinds, GADTs #-} + +module T18725a where + +import Data.Kind (Type) + +type U :: Type +data U where P :: forall u. E u -> U +data E (u :: U) ===================================== testsuite/tests/saks/should_compile/all.T ===================================== @@ -35,6 +35,7 @@ test('T16726', normal, compile, ['']) test('T16731', normal, compile, ['']) test('T16721', normal, ghci_script, ['T16721.script']) test('T16756a', normal, compile, ['']) +test('T18725a', normal, compile, ['']) test('saks027', req_th, compile, ['-v0 -ddump-splices -dsuppress-uniques']) test('saks028', req_th, compile, ['']) ===================================== testsuite/tests/saks/should_fail/T18725b.hs ===================================== @@ -0,0 +1,8 @@ +{-# LANGUAGE ExplicitForAll, KindSignatures, StandaloneKindSignatures, + DataKinds, GADTs #-} + +module T18725b where + +-- type U :: Type -- Rejected without the sig +data U where P :: forall u. E u -> U +data E (u :: U) ===================================== testsuite/tests/saks/should_fail/T18725b.stderr ===================================== @@ -0,0 +1,6 @@ +T18725b.hs:8:14: error: [GHC-85413] + • Type constructor ‘U’ cannot be used here + (it is defined and used in the same recursive group) + • In the kind ‘U’ + In the data type declaration for ‘E’ + ===================================== testsuite/tests/saks/should_fail/all.T ===================================== @@ -38,3 +38,5 @@ test('T18863d', normal, compile_fail, ['']) test('T20916', normal, compile_fail, ['']) test('saks018-fail', normal, compile_fail, ['']) test('saks021-fail', normal, compile_fail, ['']) +test('T18725b', normal, compile_fail, ['']) + ===================================== testsuite/tests/th/T20902.hs ===================================== @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} + +module T20902 where + +import Language.Haskell.TH + +data T = FU | FUN deriving Show + +expr1 = $( conE (mkName "FU") ) +expr2 = $( conE (mkName "FUN") ) +expr3 = $( [| FU |] ) +expr4 = $( [| FUN |] ) + ===================================== testsuite/tests/th/all.T ===================================== @@ -651,3 +651,5 @@ test('T26099', normal, compile_fail, ['']) test('T8306_th', only_ways(['ghci']), ghci_script, ['T8306_th.script']) test('T26862_th', only_ways(['ghci']), ghci_script, ['T26862_th.script']) test('T27022', normal, compile_and_run, ['']) +test('T20902', normal, compile, ['']) + ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -1555,26 +1555,26 @@ instance ExactPrint ModuleName where -- --------------------------------------------------------------------- -instance ExactPrint (LocatedP (WarningTxt GhcPs)) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn +instance ExactPrint (WarningTxt GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a - exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (WarningTxt src mb_cat ws)) = do + exact (WarningTxt (src, AnnPragma o c (os,cs) l1 l2 t m) mb_cat ws) = do o' <- markAnnOpen'' o src "{-# WARNING" mb_cat' <- markAnnotated mb_cat os' <- markEpToken os ws' <- mapM markAnnotated ws cs' <- markEpToken cs c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (WarningTxt src mb_cat' ws')) + return (WarningTxt (src, AnnPragma o' c' (os',cs') l1 l2 t m) mb_cat' ws') - exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (DeprecatedTxt src ws)) = do + exact (DeprecatedTxt (src, AnnPragma o c (os,cs) l1 l2 t m) ws) = do o' <- markAnnOpen'' o src "{-# DEPRECATED" os' <- markEpToken os ws' <- mapM markAnnotated ws cs' <- markEpToken cs c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (DeprecatedTxt src ws')) + return (DeprecatedTxt (src, AnnPragma o' c' (os',cs') l1 l2 t m) ws') instance ExactPrint (InWarningCategory GhcPs) where getAnnotationEntry _ = NoEntryVal View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/15244d80213547dce7b2ac3b97bc49… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/15244d80213547dce7b2ac3b97bc49… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/andreask/arm-ffi] compiler: refactor truncation to be able to control whether or not registers are alloated
by Magnus (＠MangoIV) 05 Aug '26

05 Aug '26

Magnus pushed to branch wip/andreask/arm-ffi at Glasgow Haskell Compiler / GHC Commits: fe018c21 by mangoiv at 2026-08-05T12:10:35+02:00 compiler: refactor truncation to be able to control whether or not registers are alloated - - - - - 1 changed file: - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs Changes: ===================================== compiler/GHC/CmmToAsm/AArch64/CodeGen.hs ===================================== @@ -1,5 +1,8 @@ {-# language GADTs, LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} module GHC.CmmToAsm.AArch64.CodeGen ( cmmTopCodeGen @@ -923,18 +926,23 @@ getRegister' config plat expr -- XX Conversion CmmMachOp (MO_XX_Conv from to) [e] -> do register <- getRegister e - if to >= W32 || to > from - then case register of - -- Reuse computation, casting width. - Any _fmt code -> pure $ Any (intFormat to) code - Fixed _fmt reg code -> pure $ Fixed (intFormat to) reg code - else case register of - Any _fmt code -> - pure $ Any (intFormat to) $ \dst -> do - code dst `appOL` truncateSubwordRegInplace to dst - Fixed _fmt reg code -> do - (trunc_reg, trunc_code) <- truncateSubwordReg to reg - pure $ Fixed (intFormat to) trunc_reg (code `appOL` trunc_code) + -- if to >= W32 || to > from + -- -- don't do anything in the word case or + -- -- when the target register width is larger + -- -- than the origin register width; e.g. + -- -- mangoiv: what we the tradeoff to not truncate here, too? + -- then case register of + -- -- Reuse computation, casting width. + -- Any _fmt code -> pure $ Any (intFormat to) code + -- Fixed _fmt reg code -> pure $ Fixed (intFormat to) reg code + -- else + case register of + Any _fmt code -> + pure $ Any (intFormat to) $ \dst -> do + code dst `appOL` truncateSubwordRegInplace to dst + Fixed _fmt reg code -> do + (trunc_reg, trunc_code) <- truncateSubwordReg SMayClobberSubwordArgReg to reg + pure $ Fixed (intFormat to) trunc_reg (code `appOL` trunc_code) CmmMachOp op [e] -> do (reg, _format, code) <- getSomeReg e case op of @@ -1233,7 +1241,7 @@ getRegister' config plat expr -- sign-extend both arguments to 32-bits. -- See Note [Signed arithmetic on AArch64]. intOpImm :: Bool -> Width -> (Operand -> Operand -> Operand -> OrdList Instr) -> (Integer -> Width -> Maybe Operand) -> NatM (Register) - intOpImm {- is signed -} True w op _encode_imm = intOp True w op + intOpImm True w op _encode_imm = intOp True w op {- is signed -} intOpImm False w op encode_imm = do -- compute x<m> <- x -- compute x<o> <- y @@ -1272,8 +1280,9 @@ getRegister' config plat expr let w' = opRegWidth w signExt r -- See Note [Signed arithmetic on AArch64] and #27430 - | w >= W32 = pure (r, nilOL) - | not is_signed = truncateSubwordReg w r + | not is_signed = truncateSubwordReg SMayClobberSubwordArgReg w r + -- TODO(mangoiv) in the signed case if w> W32, + -- this should be a noop | otherwise = signExtendReg w w' r (reg_x_sx, code_x_sx) <- signExt reg_x (reg_y_sx, code_y_sx) <- signExt reg_y @@ -1914,38 +1923,97 @@ signExtendReg w w' r = r' <- getNewRegNat (intFormat w') return (r', unitOL $ instr (OpReg w' r') (OpReg w r)) --- | Truncate/zero extend the subwords high bits and store the --- result in a new register. Must be called with w==8 or w==16 -truncateSubwordReg :: Width -> Reg -> NatM (Reg, OrdList Instr) -truncateSubwordReg w_to r = do - massertPpr (w_to == W8 || w_to == W16) (text "truncateSubwordReg:unexpectedWidth") - case w_to of - -- Asserted false, but be defensive for non-debug builds. - W64 -> trunc W64 MOV - W32 -> trunc W32 MOV - - -- Actual truncation - W16 -> trunc W32 UXTH - W8 -> trunc W32 UXTB - _ -> panic "truncateSubwordReg:unexpectedWidth" - where - trunc w instr = do - r' <- getNewRegNat (intFormat w_to) - return (r', unitOL $ instr (OpReg w r') (OpReg w r)) +-- | Whether the argument register may be clobbered +-- 'NeverClobbers' is an optimization +data ArgumentClobbering + = NeverClobbers + | MayClobberArgReg + +-- TODO(mangoiv): come up with better names for these two data strucutes + +data SArgumentClobbering (a :: ArgumentClobbering) where + SMayClobberSubwordArgReg :: SArgumentClobbering MayClobberArgReg + -- ^ the usual case: the register that holds a subword argument may be + -- clobbered by the truncation operation; >=W32 is not affected since + -- it is a noop + + SAlwaysAllocateReg :: SArgumentClobbering MayClobberArgReg + -- ^ subwords may be clobbered, but >=W32 want to allocate a new register + -- anyway; to avoid having to allocate twice in the subword case, we + -- always allocate a new register + -- This is at worst a pessimisation of allocating one more registeer + -- in case we don't actually need this. + + SNeverClobbers :: SArgumentClobbering NeverClobbers + -- ^ if we are sure that the register is fresh and clobbering doesn't + -- matter, we don't have to allocate a new register, ever + + +data SArgumentClobbered (a :: ArgumentClobbering) where + SNeverClobbered :: OrdList Instr -> SArgumentClobbered NeverClobbers + -- ^ just returns the instructions; since we never clobber, this is pure since + -- we never have to return a new register + + SUnclobbered :: NatM (Reg, OrdList Instr) -> SArgumentClobbered MayClobberArgReg + -- ^ return code to allocate a new register and instructions that may depend on it, that is: + -- - a new register if we pass a subword register with the potential to be clobbered + -- - the input register if we pass a word sized argument with no need to always allocate + -- a new register + -- - a new register if we were to always create a new register + +instrsWithUnclobberedReg :: SArgumentClobbered MayClobberArgReg -> NatM (Reg, OrdList Instr) +instrsWithUnclobberedReg (SUnclobbered a) = a + +instrsNonclobberedCode :: SArgumentClobbered NeverClobbers -> OrdList Instr +instrsNonclobberedCode (SNeverClobbered a) = a + +-- | full words +pattern WFull :: Width +pattern WFull <- (\case W32 -> True; W64 -> True; _ -> False -> True) + +-- | subwords +pattern WSub :: (Operand -> Operand -> Instr) -> Width +pattern WSub {truncInstr} <- (\case W16 -> Just UXTH; W8 -> Just UXTB; _ -> Nothing -> (Just truncInstr)) --- | Like @truncateSubwordReg@, but modifes the argument register in place if we --- need to truncate. truncateSubwordRegInplace :: Width -> Reg -> OrdList Instr -truncateSubwordRegInplace w_to r = do - case w_to of - W64 -> nilOL - W32 -> nilOL - W16 -> trunc UXTH - W8 -> trunc UXTB - _ -> panic "truncateSubwordRegInplace:unexpectedWidth" +truncateSubwordRegInplace w_to r = instrsNonclobberedCode (truncateSubwordReg' SNeverClobbers w_to r) + +truncateSubwordReg :: SArgumentClobbering MayClobberArgReg -> Width -> Reg -> NatM (Reg, OrdList Instr) +truncateSubwordReg clobbering w_to r = instrsWithUnclobberedReg (truncateSubwordReg' clobbering w_to r) + +-- | Truncate/zero extend the subwords high bits and store the +-- result in a new register. +truncateSubwordReg' :: SArgumentClobbering a -> Width -> Reg -> SArgumentClobbered a +truncateSubwordReg' clobbering w_to r = case clobbering of + SMayClobberSubwordArgReg + -- return the input register + | WFull <- w_to -> SUnclobbered $ pure (r, nilOL) + -- allocate a new register + | WSub {truncInstr} <- w_to -> SUnclobbered $ do + freshReg <- getNewRegNat (intFormat w_to) + pure (freshReg, pureTrunc truncInstr W32 freshReg r) + + -- always allocate a new register as the surrounding code + -- would allocate one anyways and we don't want to allocate + -- multiple times; this may be a pessimation when we don't + -- want to allocate a new register for non-subwords + SAlwaysAllocateReg -> SUnclobbered $ do + freshReg <- getNewRegNat (intFormat w_to) + let instrs + | WFull <- w_to = nilOL + | WSub {truncInstr} <- w_to = pureTrunc truncInstr W32 freshReg r + | otherwise = panicUnexpectedWidth + pure (freshReg, instrs) + SNeverClobbers + -- noop + | WFull <- w_to -> SNeverClobbered nilOL + -- same register + | WSub {truncInstr} <- w_to -> SNeverClobbered $ pureTrunc truncInstr W32 r r + _ -> panicUnexpectedWidth where - trunc instr = do - unitOL $ instr (OpReg W32 r) (OpReg W32 r) + pureTrunc instr targetWidth destinationReg originReg + = unitOL $ instr (OpReg targetWidth destinationReg) (OpReg targetWidth originReg) + panicUnexpectedWidth = panic "truncateSubwordReg:unexpectedWidth" -- ----------------------------------------------------------------------------- -- The 'Amode' type: Memory addressing modes passed up the tree. @@ -3027,7 +3095,7 @@ data BlockInRange = InRange | NotInRange Target -- See Note [AArch64 far jumps] makeFarBranches :: Platform -> LabelMap RawCmmStatics -> [NatBasicBlock Instr] -> UniqDSM [NatBasicBlock Instr] -makeFarBranches {- only used when debugging -} _platform statics basic_blocks = do +makeFarBranches _platform statics basic_blocks = do -- All offsets/positions are counted in multiples of 4 bytes (the size of AArch64 instructions) -- That is an offset of 1 represents a 4-byte/one instruction offset. let (func_size, lblMap) = foldl' calc_lbl_positions (0, mapEmpty) basic_blocks @@ -3143,4 +3211,4 @@ makeFarBranches {- only used when debugging -} _platform statics basic_blocks = CBZ{} -> Just long_bz_jump_size CBNZ{} -> Just long_bz_jump_size BCOND{} -> Just long_bc_jump_size - _ -> Nothing + _ -> Nothing {- only used when debugging -} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fe018c21619b811736c23000690b36b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fe018c21619b811736c23000690b36b… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/andreask/arm-ffi] compiler: refactor truncation to be able to control whether or not registers are alloated
by Magnus (＠MangoIV) 05 Aug '26

05 Aug '26

Magnus pushed to branch wip/andreask/arm-ffi at Glasgow Haskell Compiler / GHC Commits: 961ca176 by mangoiv at 2026-08-05T11:58:35+02:00 compiler: refactor truncation to be able to control whether or not registers are alloated - - - - - 1 changed file: - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs Changes: ===================================== compiler/GHC/CmmToAsm/AArch64/CodeGen.hs ===================================== @@ -1,5 +1,8 @@ {-# language GADTs, LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} module GHC.CmmToAsm.AArch64.CodeGen ( cmmTopCodeGen @@ -923,18 +926,23 @@ getRegister' config plat expr -- XX Conversion CmmMachOp (MO_XX_Conv from to) [e] -> do register <- getRegister e - if to >= W32 || to > from - then case register of - -- Reuse computation, casting width. - Any _fmt code -> pure $ Any (intFormat to) code - Fixed _fmt reg code -> pure $ Fixed (intFormat to) reg code - else case register of - Any _fmt code -> - pure $ Any (intFormat to) $ \dst -> do - code dst `appOL` truncateSubwordRegInplace to dst - Fixed _fmt reg code -> do - (trunc_reg, trunc_code) <- truncateSubwordReg to reg - pure $ Fixed (intFormat to) trunc_reg (code `appOL` trunc_code) + -- if to >= W32 || to > from + -- -- don't do anything in the word case or + -- -- when the target register width is larger + -- -- than the origin register width; e.g. + -- -- mangoiv: what we the tradeoff to not truncate here, too? + -- then case register of + -- -- Reuse computation, casting width. + -- Any _fmt code -> pure $ Any (intFormat to) code + -- Fixed _fmt reg code -> pure $ Fixed (intFormat to) reg code + -- else + case register of + Any _fmt code -> + pure $ Any (intFormat to) $ \dst -> do + code dst `appOL` truncateSubwordRegInplace to dst + Fixed _fmt reg code -> do + (trunc_reg, trunc_code) <- truncateSubwordReg SMayClobberSubwordArgReg to reg + pure $ Fixed (intFormat to) trunc_reg (code `appOL` trunc_code) CmmMachOp op [e] -> do (reg, _format, code) <- getSomeReg e case op of @@ -1233,7 +1241,7 @@ getRegister' config plat expr -- sign-extend both arguments to 32-bits. -- See Note [Signed arithmetic on AArch64]. intOpImm :: Bool -> Width -> (Operand -> Operand -> Operand -> OrdList Instr) -> (Integer -> Width -> Maybe Operand) -> NatM (Register) - intOpImm {- is signed -} True w op _encode_imm = intOp True w op + intOpImm True w op _encode_imm = intOp True w op {- is signed -} intOpImm False w op encode_imm = do -- compute x<m> <- x -- compute x<o> <- y @@ -1272,8 +1280,9 @@ getRegister' config plat expr let w' = opRegWidth w signExt r -- See Note [Signed arithmetic on AArch64] and #27430 - | w >= W32 = pure (r, nilOL) - | not is_signed = truncateSubwordReg w r + | not is_signed = truncateSubwordReg SMayClobberSubwordArgReg w r + -- TODO(mangoiv) in the signed case if w> W32, + -- this should be a noop | otherwise = signExtendReg w w' r (reg_x_sx, code_x_sx) <- signExt reg_x (reg_y_sx, code_y_sx) <- signExt reg_y @@ -1914,38 +1923,97 @@ signExtendReg w w' r = r' <- getNewRegNat (intFormat w') return (r', unitOL $ instr (OpReg w' r') (OpReg w r)) --- | Truncate/zero extend the subwords high bits and store the --- result in a new register. Must be called with w==8 or w==16 -truncateSubwordReg :: Width -> Reg -> NatM (Reg, OrdList Instr) -truncateSubwordReg w_to r = do - massertPpr (w_to == W8 || w_to == W16) (text "truncateSubwordReg:unexpectedWidth") - case w_to of - -- Asserted false, but be defensive for non-debug builds. - W64 -> trunc W64 MOV - W32 -> trunc W32 MOV - - -- Actual truncation - W16 -> trunc W32 UXTH - W8 -> trunc W32 UXTB - _ -> panic "truncateSubwordReg:unexpectedWidth" - where - trunc w instr = do - r' <- getNewRegNat (intFormat w_to) - return (r', unitOL $ instr (OpReg w r') (OpReg w r)) +-- | Whether the argument register may be clobbered +-- 'NeverClobbers' is an optimization +data ArgumentClobbering + = NeverClobbers + | MayClobberArgReg + +-- TODO(mangoiv): come up with better names for these two data strucutes + +data SArgumentClobbering (a :: ArgumentClobbering) where + SMayClobberSubwordArgReg :: SArgumentClobbering MayClobberArgReg + -- ^ the usual case: the register that holds a subword argument may be + -- clobbered by the truncation operation; >=W32 is not affected since + -- it is a noop + + SAlwaysAllocateReg :: SArgumentClobbering MayClobberArgReg + -- ^ subwords may be clobbered, but >=W32 want to allocate a new register + -- anyway; to avoid having to allocate twice in the subword case, we + -- always allocate a new register + -- This is at worst a pessimisation of allocating one more registeer + -- in case we don't actually need this. + + SNeverClobbers :: SArgumentClobbering NeverClobbers + -- ^ if we are sure that the register is fresh and clobbering doesn't + -- matter, we don't have to allocate a new register, ever + + +data SArgumentClobbered (a :: ArgumentClobbering) where + SNeverClobbered :: OrdList Instr -> SArgumentClobbered NeverClobbers + -- ^ just returns the instructions; since we never clobber, this is pure since + -- we never have to return a new register + + SUnclobbered :: NatM (Reg, OrdList Instr) -> SArgumentClobbered MayClobberArgReg + -- ^ return code to allocate a new register and instructions that may depend on it, that is: + -- - a new register if we pass a subword register with the potential to be clobbered + -- - the input register if we pass a word sized argument with no need to always allocate + -- a new register + -- - a new register if we were to always create a new register + +instrsWithUnclobberedReg :: SArgumentClobbered MayClobberArgReg -> NatM (Reg, OrdList Instr) +instrsWithUnclobberedReg (SUnclobbered a) = a + +instrsNonclobberedCode :: SArgumentClobbered NeverClobbers -> OrdList Instr +instrsNonclobberedCode (SNeverClobbered a) = a + +-- | full words +pattern WFull :: Width +pattern WFull <- (\case W32 -> True; W64 -> True; _ -> False -> True) + +-- | subwords +pattern WSub :: (Operand -> Operand -> Instr) -> Width +pattern WSub {truncInstr} <- (\case W16 -> Just UXTH; W8 -> Just UXTB; _ -> Nothing -> (Just truncInstr)) --- | Like @truncateSubwordReg@, but modifes the argument register in place if we --- need to truncate. truncateSubwordRegInplace :: Width -> Reg -> OrdList Instr -truncateSubwordRegInplace w_to r = do - case w_to of - W64 -> nilOL - W32 -> nilOL - W16 -> trunc UXTH - W8 -> trunc UXTB - _ -> panic "truncateSubwordRegInplace:unexpectedWidth" +truncateSubwordRegInplace w_to r = instrsNonclobberedCode (truncateSubwordReg' SNeverClobbers w_to r) + +truncateSubwordReg :: SArgumentClobbering MayClobberArgReg -> Width -> Reg -> NatM (Reg, OrdList Instr) +truncateSubwordReg clobbering w_to r = instrsWithUnclobberedReg (truncateSubwordReg' clobbering w_to r) + +-- | Truncate/zero extend the subwords high bits and store the +-- result in a new register. +truncateSubwordReg' :: SArgumentClobbering a -> Width -> Reg -> SArgumentClobbered a +truncateSubwordReg' clobbering w_to r = case clobbering of + SMayClobberSubwordArgReg + -- return the input register + | WFull <- w_to -> SUnclobbered $ pure (r, nilOL) + -- allocate a new register + | WSub {truncInstr} <- w_to -> SUnclobbered $ do + freshReg <- getNewRegNat (intFormat w_to) + pure (freshReg, pureTrunc truncInstr W32 freshReg r) + + -- always allocate a new register as the surrounding code + -- would allocate one anyways and we don't want to allocate + -- multiple times; this may be a pessimation when we don't + -- want to allocate a new register for non-subwords + SAlwaysAllocateReg -> SUnclobbered $ do + freshReg <- getNewRegNat (intFormat w_to) + let instrs + | WFull <- w_to = nilOL + | WSub {truncInstr} <- w_to = pureTrunc truncInstr W32 freshReg r + | otherwise = panicUnexpectedWidth + pure (freshReg, instrs) + SNeverClobbers + -- noop + | WFull <- w_to -> SNeverClobbered nilOL + -- same register + | WSub {truncInstr} <- w_to -> SNeverClobbered $ pureTrunc truncInstr W32 r r + _ -> panicUnexpectedWidth where - trunc instr = do - unitOL $ instr (OpReg W32 r) (OpReg W32 r) + pureTrunc instr targetWidth destinationReg originReg + = unitOL $ instr (OpReg targetWidth destinationReg) (OpReg targetWidth originReg) + panicUnexpectedWidth = panic "truncateSubwordReg:unexpectedWidth" -- ----------------------------------------------------------------------------- -- The 'Amode' type: Memory addressing modes passed up the tree. @@ -3027,7 +3095,7 @@ data BlockInRange = InRange | NotInRange Target -- See Note [AArch64 far jumps] makeFarBranches :: Platform -> LabelMap RawCmmStatics -> [NatBasicBlock Instr] -> UniqDSM [NatBasicBlock Instr] -makeFarBranches {- only used when debugging -} _platform statics basic_blocks = do +makeFarBranches _platform statics basic_blocks = do -- All offsets/positions are counted in multiples of 4 bytes (the size of AArch64 instructions) -- That is an offset of 1 represents a 4-byte/one instruction offset. let (func_size, lblMap) = foldl' calc_lbl_positions (0, mapEmpty) basic_blocks @@ -3143,4 +3211,4 @@ makeFarBranches {- only used when debugging -} _platform statics basic_blocks = CBZ{} -> Just long_bz_jump_size CBNZ{} -> Just long_bz_jump_size BCOND{} -> Just long_bc_jump_size - _ -> Nothing + _ -> Nothing {- only used when debugging -} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/961ca1768dfd8f343cbfb32b24ad7fe… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/961ca1768dfd8f343cbfb32b24ad7fe… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/andreask/arm-ffi] fixup! compiler: refactor truncation to be able to control whether or not registers are alloated
by Magnus (＠MangoIV) 05 Aug '26

05 Aug '26

Magnus pushed to branch wip/andreask/arm-ffi at Glasgow Haskell Compiler / GHC Commits: b894fde8 by mangoiv at 2026-08-05T11:57:01+02:00 fixup! compiler: refactor truncation to be able to control whether or not registers are alloated - - - - - 1 changed file: - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs Changes: ===================================== compiler/GHC/CmmToAsm/AArch64/CodeGen.hs ===================================== @@ -939,9 +939,9 @@ getRegister' config plat expr case register of Any _fmt code -> pure $ Any (intFormat to) $ \dst -> do - code dst `appOL` instrsNonclobberedCode (truncateSubwordReg SNeverClobbers to dst) + code dst `appOL` truncateSubwordRegInplace to dst Fixed _fmt reg code -> do - (trunc_reg, trunc_code) <- instrsWithUnclobberedReg $ truncateSubwordReg SMayClobberSubwordArgReg to reg + (trunc_reg, trunc_code) <- truncateSubwordReg SMayClobberSubwordArgReg to reg pure $ Fixed (intFormat to) trunc_reg (code `appOL` trunc_code) CmmMachOp op [e] -> do (reg, _format, code) <- getSomeReg e @@ -1280,8 +1280,9 @@ getRegister' config plat expr let w' = opRegWidth w signExt r -- See Note [Signed arithmetic on AArch64] and #27430 - | w >= W32 = pure (r, nilOL) - | not is_signed = truncateSubwordReg w r + | not is_signed = truncateSubwordReg SMayClobberSubwordArgReg w r + -- TODO(mangoiv) in the signed case if w> W32, + -- this should be a noop | otherwise = signExtendReg w w' r (reg_x_sx, code_x_sx) <- signExt reg_x (reg_y_sx, code_y_sx) <- signExt reg_y @@ -1974,10 +1975,16 @@ pattern WFull <- (\case W32 -> True; W64 -> True; _ -> False -> True) pattern WSub :: (Operand -> Operand -> Instr) -> Width pattern WSub {truncInstr} <- (\case W16 -> Just UXTH; W8 -> Just UXTB; _ -> Nothing -> (Just truncInstr)) +truncateSubwordRegInplace :: Width -> Reg -> OrdList Instr +truncateSubwordRegInplace w_to r = instrsNonclobberedCode (truncateSubwordReg' SNeverClobbers w_to r) + +truncateSubwordReg :: SArgumentClobbering MayClobberArgReg -> Width -> Reg -> NatM (Reg, OrdList Instr) +truncateSubwordReg clobbering w_to r = instrsWithUnclobberedReg (truncateSubwordReg' clobbering w_to r) + -- | Truncate/zero extend the subwords high bits and store the -- result in a new register. -truncateSubwordReg :: SArgumentClobbering a -> Width -> Reg -> SArgumentClobbered a -truncateSubwordReg clobbering w_to r = case clobbering of +truncateSubwordReg' :: SArgumentClobbering a -> Width -> Reg -> SArgumentClobbered a +truncateSubwordReg' clobbering w_to r = case clobbering of SMayClobberSubwordArgReg -- return the input register | WFull <- w_to -> SUnclobbered $ pure (r, nilOL) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b894fde8292bdb13d856db43d4b54a8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b894fde8292bdb13d856db43d4b54a8… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc] Pushed new branch wip/fendor/T18425-hie-validate-bug
by Hannes Siebenhandl (＠fendor) 05 Aug '26

05 Aug '26

Hannes Siebenhandl pushed new branch wip/fendor/T18425-hie-validate-bug at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/fendor/T18425-hie-validate-bug You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/andreask/arm-ffi] compiler: refactor truncation to be able to control whether or not registers are alloated
by Magnus (＠MangoIV) 05 Aug '26

05 Aug '26

Magnus pushed to branch wip/andreask/arm-ffi at Glasgow Haskell Compiler / GHC Commits: c758cca3 by mangoiv at 2026-08-05T11:46:12+02:00 compiler: refactor truncation to be able to control whether or not registers are alloated - - - - - 1 changed file: - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs Changes: ===================================== compiler/GHC/CmmToAsm/AArch64/CodeGen.hs ===================================== @@ -1,5 +1,8 @@ {-# language GADTs, LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} module GHC.CmmToAsm.AArch64.CodeGen ( cmmTopCodeGen @@ -923,18 +926,23 @@ getRegister' config plat expr -- XX Conversion CmmMachOp (MO_XX_Conv from to) [e] -> do register <- getRegister e - if to >= W32 || to > from - then case register of - -- Reuse computation, casting width. - Any _fmt code -> pure $ Any (intFormat to) code - Fixed _fmt reg code -> pure $ Fixed (intFormat to) reg code - else case register of - Any _fmt code -> - pure $ Any (intFormat to) $ \dst -> do - code dst `appOL` truncateSubwordRegInplace to dst - Fixed _fmt reg code -> do - (trunc_reg, trunc_code) <- truncateSubwordReg to reg - pure $ Fixed (intFormat to) trunc_reg (code `appOL` trunc_code) + -- if to >= W32 || to > from + -- -- don't do anything in the word case or + -- -- when the target register width is larger + -- -- than the origin register width; e.g. + -- -- mangoiv: what we the tradeoff to not truncate here, too? + -- then case register of + -- -- Reuse computation, casting width. + -- Any _fmt code -> pure $ Any (intFormat to) code + -- Fixed _fmt reg code -> pure $ Fixed (intFormat to) reg code + -- else + case register of + Any _fmt code -> + pure $ Any (intFormat to) $ \dst -> do + code dst `appOL` instrsNonclobberedCode (truncateSubwordReg SNeverClobbers to dst) + Fixed _fmt reg code -> do + (trunc_reg, trunc_code) <- instrsWithUnclobberedReg $ truncateSubwordReg SMayClobberSubwordArgReg to reg + pure $ Fixed (intFormat to) trunc_reg (code `appOL` trunc_code) CmmMachOp op [e] -> do (reg, _format, code) <- getSomeReg e case op of @@ -1233,7 +1241,7 @@ getRegister' config plat expr -- sign-extend both arguments to 32-bits. -- See Note [Signed arithmetic on AArch64]. intOpImm :: Bool -> Width -> (Operand -> Operand -> Operand -> OrdList Instr) -> (Integer -> Width -> Maybe Operand) -> NatM (Register) - intOpImm {- is signed -} True w op _encode_imm = intOp True w op + intOpImm True w op _encode_imm = intOp True w op {- is signed -} intOpImm False w op encode_imm = do -- compute x<m> <- x -- compute x<o> <- y @@ -1914,38 +1922,91 @@ signExtendReg w w' r = r' <- getNewRegNat (intFormat w') return (r', unitOL $ instr (OpReg w' r') (OpReg w r)) +-- | Whether the argument register may be clobbered +-- 'NeverClobbers' is an optimization +data ArgumentClobbering + = NeverClobbers + | MayClobberArgReg + +-- TODO(mangoiv): come up with better names for these two data strucutes + +data SArgumentClobbering (a :: ArgumentClobbering) where + SMayClobberSubwordArgReg :: SArgumentClobbering MayClobberArgReg + -- ^ the usual case: the register that holds a subword argument may be + -- clobbered by the truncation operation; >=W32 is not affected since + -- it is a noop + + SAlwaysAllocateReg :: SArgumentClobbering MayClobberArgReg + -- ^ subwords may be clobbered, but >=W32 want to allocate a new register + -- anyway; to avoid having to allocate twice in the subword case, we + -- always allocate a new register + -- This is at worst a pessimisation of allocating one more registeer + -- in case we don't actually need this. + + SNeverClobbers :: SArgumentClobbering NeverClobbers + -- ^ if we are sure that the register is fresh and clobbering doesn't + -- matter, we don't have to allocate a new register, ever + + +data SArgumentClobbered (a :: ArgumentClobbering) where + SNeverClobbered :: OrdList Instr -> SArgumentClobbered NeverClobbers + -- ^ just returns the instructions; since we never clobber, this is pure since + -- we never have to return a new register + + SUnclobbered :: NatM (Reg, OrdList Instr) -> SArgumentClobbered MayClobberArgReg + -- ^ return code to allocate a new register and instructions that may depend on it, that is: + -- - a new register if we pass a subword register with the potential to be clobbered + -- - the input register if we pass a word sized argument with no need to always allocate + -- a new register + -- - a new register if we were to always create a new register + +instrsWithUnclobberedReg :: SArgumentClobbered MayClobberArgReg -> NatM (Reg, OrdList Instr) +instrsWithUnclobberedReg (SUnclobbered a) = a + +instrsNonclobberedCode :: SArgumentClobbered NeverClobbers -> OrdList Instr +instrsNonclobberedCode (SNeverClobbered a) = a + +-- | full words +pattern WFull :: Width +pattern WFull <- (\case W32 -> True; W64 -> True; _ -> False -> True) + +-- | subwords +pattern WSub :: (Operand -> Operand -> Instr) -> Width +pattern WSub {truncInstr} <- (\case W16 -> Just UXTH; W8 -> Just UXTB; _ -> Nothing -> (Just truncInstr)) + -- | Truncate/zero extend the subwords high bits and store the --- result in a new register. Must be called with w==8 or w==16 -truncateSubwordReg :: Width -> Reg -> NatM (Reg, OrdList Instr) -truncateSubwordReg w_to r = do - massertPpr (w_to == W8 || w_to == W16) (text "truncateSubwordReg:unexpectedWidth") - case w_to of - -- Asserted false, but be defensive for non-debug builds. - W64 -> trunc W64 MOV - W32 -> trunc W32 MOV - - -- Actual truncation - W16 -> trunc W32 UXTH - W8 -> trunc W32 UXTB - _ -> panic "truncateSubwordReg:unexpectedWidth" - where - trunc w instr = do - r' <- getNewRegNat (intFormat w_to) - return (r', unitOL $ instr (OpReg w r') (OpReg w r)) - --- | Like @truncateSubwordReg@, but modifes the argument register in place if we --- need to truncate. -truncateSubwordRegInplace :: Width -> Reg -> OrdList Instr -truncateSubwordRegInplace w_to r = do - case w_to of - W64 -> nilOL - W32 -> nilOL - W16 -> trunc UXTH - W8 -> trunc UXTB - _ -> panic "truncateSubwordRegInplace:unexpectedWidth" +-- result in a new register. +truncateSubwordReg :: SArgumentClobbering a -> Width -> Reg -> SArgumentClobbered a +truncateSubwordReg clobbering w_to r = case clobbering of + SMayClobberSubwordArgReg + -- return the input register + | WFull <- w_to -> SUnclobbered $ pure (r, nilOL) + -- allocate a new register + | WSub {truncInstr} <- w_to -> SUnclobbered $ do + freshReg <- getNewRegNat (intFormat w_to) + pure (freshReg, pureTrunc truncInstr W32 freshReg r) + + -- always allocate a new register as the surrounding code + -- would allocate one anyways and we don't want to allocate + -- multiple times; this may be a pessimation when we don't + -- want to allocate a new register for non-subwords + SAlwaysAllocateReg -> SUnclobbered $ do + freshReg <- getNewRegNat (intFormat w_to) + let instrs + | WFull <- w_to = nilOL + | WSub {truncInstr} <- w_to = pureTrunc truncInstr W32 freshReg r + | otherwise = panicUnexpectedWidth + pure (freshReg, instrs) + SNeverClobbers + -- noop + | WFull <- w_to -> SNeverClobbered nilOL + -- same register + | WSub {truncInstr} <- w_to -> SNeverClobbered $ pureTrunc truncInstr W32 r r + _ -> panicUnexpectedWidth where - trunc instr = do - unitOL $ instr (OpReg W32 r) (OpReg W32 r) + pureTrunc instr targetWidth destinationReg originReg + = unitOL $ instr (OpReg targetWidth destinationReg) (OpReg targetWidth originReg) + panicUnexpectedWidth = panic "truncateSubwordReg:unexpectedWidth" -- ----------------------------------------------------------------------------- -- The 'Amode' type: Memory addressing modes passed up the tree. @@ -3027,7 +3088,7 @@ data BlockInRange = InRange | NotInRange Target -- See Note [AArch64 far jumps] makeFarBranches :: Platform -> LabelMap RawCmmStatics -> [NatBasicBlock Instr] -> UniqDSM [NatBasicBlock Instr] -makeFarBranches {- only used when debugging -} _platform statics basic_blocks = do +makeFarBranches _platform statics basic_blocks = do -- All offsets/positions are counted in multiples of 4 bytes (the size of AArch64 instructions) -- That is an offset of 1 represents a 4-byte/one instruction offset. let (func_size, lblMap) = foldl' calc_lbl_positions (0, mapEmpty) basic_blocks @@ -3143,4 +3204,4 @@ makeFarBranches {- only used when debugging -} _platform statics basic_blocks = CBZ{} -> Just long_bz_jump_size CBNZ{} -> Just long_bz_jump_size BCOND{} -> Just long_bc_jump_size - _ -> Nothing + _ -> Nothing {- only used when debugging -} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c758cca3c882d2e4bdff7c5f13b1dd7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c758cca3c882d2e4bdff7c5f13b1dd7… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: testsuite: Don't crash on non-UTF-8 test output
by Marge Bot (＠marge-bot) 05 Aug '26

05 Aug '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: b831ab31 by Simon Jakobi at 2026-08-05T05:21:25-04:00 testsuite: Don't crash on non-UTF-8 test output read_stdout, read_stderr_for, read_comp_stderr and read_diff decoded strictly (the first three with UTF-8, read_diff with the locale encoding), so a test emitting invalid UTF-8 (binary output, or a crash truncating a multi-byte character) raised UnicodeDecodeError and was reported as a framework failure instead of its actual result. Decode with errors='replace', like read_no_crs and safe_print. Assisted-by: Claude Fable 5 - - - - - 693503ec by Simon Jakobi at 2026-08-05T05:21:25-04:00 testsuite: Colorize the test summary, also in CI The summary headings were plain, and SUMMARY was colored unconditionally, so the escapes also ended up in the file written by --summary-file. Color is now decided per output sink via term_color.colored_if; see the comments in term_color. CI logs are not a tty, but GitLab's log viewer renders ANSI colors, so add --force-colors and pass it in .gitlab/ci.sh. Assisted-by: Claude Opus 5 - - - - - cd41db96 by Simon Jakobi at 2026-08-05T05:21:25-04:00 testsuite: Repeat unexpected failure output in the summary Finding out why a test failed meant scrolling back through a possibly very long log to the point where the test ran. The summary now repeats the captured output of unexpected failures, before the statistics, so the most interesting part is at the end of the log (#16720). Output mismatches report their diff instead of the mismatching stream (see Note [Redundant output in test results]). The repeated output is bounded per stream, and skipped altogether beyond MAX_SUMMARY_OUTPUT_TESTS failure blocks. Tests failing identically in several ways share one block. Test results now report a source-relative directory, stable regardless of where the run was started from. Assisted-by: Claude Fable 5 - - - - - 8274828d by Ben Gamari at 2026-08-05T05:21:26-04:00 base: Don't drop exception context in SomeException(toException) For reasons that are lost to time, the implementation of [CLC #200] that was merged inappropriately dropped `ExceptionContext` in the `toException` implementation given to `SomeException`. Fix this infelicity. [CLC #200]: https://github.com/haskell/core-libraries-committee/issues/200 - - - - - d6d1e0fc by Vladislav Zavialov at 2026-08-05T05:21:26-04:00 Test case for #20902 Starting with GHC 9.14.1 (the first major release to include 51e3ec83), and from point releases GHC 9.10.2 and GHC 9.12.3 (backports cc4470be68 and b30f25591e), all examples in this ticket are handled as expected. - - - - - 3efd9085 by Alan Zimmerman at 2026-08-05T05:21:27-04:00 EPA: Remove LocatedP, last use in WarningTxt The last step of removing LocatedP, by moving the AnnPragma for WarningTxt into its TTG extension point instead. This also allows us to remove LocatedP and SrcSpanAnnP - - - - - 15244d80 by Vladislav Zavialov at 2026-08-05T05:21:28-04:00 Test cases for #18725 Starting with GHC 9.4 (the first release to include 268efcc9a4), the program in this ticket no longer panics. A standalone kind signature breaks the recursive loop, so the type constructor can be used in a kind within its own group. T18725a checks that this is accepted with the signature present, while T18725b confirms it is still rejected without it. - - - - - 25 changed files: - .gitlab/ci.sh - + changelog.d/T27455 - compiler/GHC/Builtin/Utils.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Warnings.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Unit/Module/Warnings.hs - libraries/base/changelog.md - libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs - testsuite/driver/runtests.py - testsuite/driver/term_color.py - testsuite/driver/testlib.py - testsuite/tests/ghc-e/should_fail/T18441fail7.stderr - testsuite/tests/ghc-e/should_run/ghc-e005.stderr - + testsuite/tests/saks/should_compile/T18725a.hs - testsuite/tests/saks/should_compile/all.T - + testsuite/tests/saks/should_fail/T18725b.hs - + testsuite/tests/saks/should_fail/T18725b.stderr - testsuite/tests/saks/should_fail/all.T - + testsuite/tests/th/T20902.hs - testsuite/tests/th/all.T - utils/check-exact/ExactPrint.hs Changes: ===================================== .gitlab/ci.sh ===================================== @@ -652,6 +652,10 @@ function test_hadrian() { check_msys2_deps _build/stage1/bin/ghc --version check_release_build + # GitLab's log viewer renders ANSI colors, but stdout here is not a tty, + # so the driver must be told to emit them. + RUNTEST_ARGS="${RUNTEST_ARGS:-} --force-colors" + # Ensure that statically-linked builds are actually static if [[ "${BUILD_FLAVOUR}" = *static* ]]; then bad_execs="" ===================================== changelog.d/T27455 ===================================== @@ -0,0 +1,8 @@ +section: base +issues: #27455 +mrs: !16274 +synopsis: + Don't drop `ExceptionContext` in `SomeException(toException)` +description: + Previously the implementation of ``Exception(toException)`` given to `SomeException` would inappropriately drop the carried `ExceptionContext`. Now ``toException = id``, faithfully implementing the semantics proposed in :ref:`CLC Proposal #200 <https://github.com/haskell/core-libraries-committee/issues/200>`. + ===================================== compiler/GHC/Builtin/Utils.hs ===================================== @@ -301,7 +301,7 @@ ghcPrimWarns = WarnSome [] where mk_txt msg = - DeprecatedTxt NoSourceText [noLocA $ WithHsDocIdentifiers (StringLiteral NoSourceText (fastStringToShortText msg)) []] + DeprecatedTxt (NoSourceText, noAnn) [noLocA $ WithHsDocIdentifiers (StringLiteral NoSourceText (fastStringToShortText msg)) []] mk_decl_dep (occ, msg) = (occ, mk_txt msg) ghcPrimFixities :: [(OccName,Fixity)] ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -1043,7 +1043,7 @@ cidDeprecation :: forall p. IsPass p cidDeprecation = fmap unLoc . decl_deprecation (ghcPass @p) where decl_deprecation :: GhcPass p -> ClsInstDecl (GhcPass p) - -> Maybe (LocatedP (WarningTxt (GhcPass p))) + -> Maybe (LocatedA (WarningTxt (GhcPass p))) decl_deprecation GhcPs (ClsInstDecl{ cid_ext = (depr, _) } ) = depr decl_deprecation GhcRn (ClsInstDecl{ cid_ext = (depr, _) }) @@ -1242,7 +1242,7 @@ derivDeprecation :: forall p. IsPass p derivDeprecation = fmap unLoc . decl_deprecation (ghcPass @p) where decl_deprecation :: GhcPass p -> DerivDecl (GhcPass p) - -> Maybe (LocatedP (WarningTxt (GhcPass p))) + -> Maybe (LocatedA (WarningTxt (GhcPass p))) decl_deprecation GhcPs (DerivDecl{ deriv_ext = (depr, _) }) = depr decl_deprecation GhcRn (DerivDecl{ deriv_ext = (depr, _) }) ===================================== compiler/GHC/Hs/Dump.hs ===================================== @@ -99,7 +99,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet `ext2Q` located `extQ` srcSpanAnnA - `extQ` srcSpanAnnP `extQ` srcSpanAnnN `extQ` srcSpanAnnBF @@ -409,9 +408,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 srcSpanAnnA :: EpAnn [TrailingAnn] -> SDoc srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA") - srcSpanAnnP :: EpAnn AnnPragma -> SDoc - srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP") - srcSpanAnnN :: EpAnn NameAnn -> SDoc srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN") ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -83,7 +83,7 @@ import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisForAllTyFlag ) import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..)) import GHC.Builtin.Types ( constraintKindTyConName ) import GHC.Stg.EnforceEpt.TagSig -import GHC.Parser.Annotation (noLocA) +import GHC.Parser.Annotation (noLocA, noAnn) import GHC.Hs.Extension ( GhcPass, GhcRn, GhcTc ) import GHC.Hs.Decls.Overlap ( OverlapFlag ) import GHC.Hs.Doc ( WithHsDocIdentifiers(..) ) @@ -666,8 +666,8 @@ fromIfaceWarnings = \case fromIfaceWarningTxt :: IfaceWarningTxt -> WarningTxt GhcRn fromIfaceWarningTxt = \case - IfWarningTxt src mb_cat strs -> WarningTxt src (noLocA . fromWarningCategory <$> mb_cat) (noLocA <$> map fromIfaceStringLiteralWithNames strs) - IfDeprecatedTxt src strs -> DeprecatedTxt src (noLocA <$> map fromIfaceStringLiteralWithNames strs) + IfWarningTxt src mb_cat strs -> WarningTxt (src, noAnn) (noLocA . fromWarningCategory <$> mb_cat) (noLocA <$> map fromIfaceStringLiteralWithNames strs) + IfDeprecatedTxt src strs -> DeprecatedTxt (src, noAnn) (noLocA <$> map fromIfaceStringLiteralWithNames strs) fromIfaceStringLiteralWithNames :: (IfaceStringLiteral, [IfExtName]) -> WithHsDocIdentifiers (StringLiteral GhcRn) GhcRn fromIfaceStringLiteralWithNames (str, names) = WithHsDocIdentifiers (fromIfaceStringLiteral str) (map noLocA names) ===================================== compiler/GHC/Iface/Warnings.hs ===================================== @@ -22,12 +22,11 @@ toIfaceWarnings (WarnSome vs ds) = IfWarnSome vs' ds' ds' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- ds] toIfaceWarningTxt :: WarningTxt GhcRn -> IfaceWarningTxt -toIfaceWarningTxt (WarningTxt src mb_cat strs) = IfWarningTxt src (unLoc . iwc_wc . unLoc <$> mb_cat) (map (toIfaceStringLiteralWithNames . unLoc) strs) -toIfaceWarningTxt (DeprecatedTxt src strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs) +toIfaceWarningTxt (WarningTxt (src, _) mb_cat strs) = IfWarningTxt src (unLoc . iwc_wc . unLoc <$> mb_cat) (map (toIfaceStringLiteralWithNames . unLoc) strs) +toIfaceWarningTxt (DeprecatedTxt (src, _) strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs) toIfaceStringLiteralWithNames :: WithHsDocIdentifiers (StringLiteral GhcRn) GhcRn -> (IfaceStringLiteral, [IfExtName]) toIfaceStringLiteralWithNames (WithHsDocIdentifiers src names) = (toIfaceStringLiteral src, map unLoc names) toIfaceStringLiteral :: StringLiteral GhcRn -> IfaceStringLiteral -toIfaceStringLiteral sLit = - IfStringLiteral (stringLitSourceText sLit) (sl_fs sLit) +toIfaceStringLiteral sLit = IfStringLiteral (stringLitSourceText sLit) (sl_fs sLit) ===================================== compiler/GHC/Parser.y ===================================== @@ -2077,11 +2077,13 @@ to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated. maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) } : '{-# DEPRECATED' strings '#-}' - {% fmap Just $ amsr (sLL $1 $> $ DeprecatedTxt (getDEPRECATED_PRAGs $1) (snd $ unLoc $2)) - (AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn) } + {% fmap Just $ amsA' (sLL $1 $> $ + DeprecatedTxt (getDEPRECATED_PRAGs $1, AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn) + (snd $ unLoc $2))} | '{-# WARNING' warning_category strings '#-}' - {% fmap Just $ amsr (sLL $1 $> $ WarningTxt (getWARNING_PRAGs $1) $2 (snd $ unLoc $3)) - (AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn)} + {% fmap Just $ amsA' (sLL $1 $> $ + WarningTxt (getWARNING_PRAGs $1, AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn) + $2 (snd $ unLoc $3))} | {- empty -} { Nothing } warning_category :: { Maybe (LocatedE (InWarningCategory GhcPs)) } @@ -2110,7 +2112,7 @@ warning :: { OrdList (LWarnDecl GhcPs) } : warning_category namespace_spec namelist strings {% fmap unitOL $ amsA' (L (comb4 $1 $2 $3 $4) (Warning (fst $ unLoc $4) (unLoc $2) (unLoc $3) - (WarningTxt NoSourceText $1 (snd $ unLoc $4)))) } + (WarningTxt (NoSourceText, noAnn) $1 (snd $ unLoc $4)))) } namespace_spec :: { Located (NamespaceSpecifier GhcPs) } : 'type' { sL1 $1 $ TypeNamespaceSpecifier (epTok $1) } @@ -2138,7 +2140,7 @@ deprecations :: { OrdList (LWarnDecl GhcPs) } deprecation :: { OrdList (LWarnDecl GhcPs) } : namespace_spec namelist strings {% fmap unitOL $ amsA' (sL (comb3 $1 $2 $>) $ (Warning (fst $ unLoc $3) (unLoc $1) (unLoc $2) - (DeprecatedTxt NoSourceText $ snd $ unLoc $3))) } + (DeprecatedTxt (NoSourceText, noAnn) $ snd $ unLoc $3))) } strings :: { Located ((EpToken "[", EpToken "]"), [LocatedA (WithHsDocIdentifiers (StringLiteral GhcPs) GhcPs)]) } : STRING { sL1 $1 (noAnn,[stringLiteralToHsDocWst (L (gl $1) (getStringLiteral $1))]) } ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -27,9 +27,9 @@ module GHC.Parser.Annotation ( EpAnnCO, -- ** Annotations in 'GenLocated' - LocatedA, LocatedN, LocatedAn, LocatedP, + LocatedA, LocatedN, LocatedAn, LocatedE, LocatedBF, - SrcSpanAnnA, SrcSpanAnnP, SrcSpanAnnN, + SrcSpanAnnA, SrcSpanAnnN, SrcSpanAnnBF, -- ** Annotation data types used in 'GenLocated' @@ -430,7 +430,6 @@ emptyComments = EpaComments [] type LocatedA = GenLocated SrcSpanAnnA type LocatedN = GenLocated SrcSpanAnnN -type LocatedP = GenLocated SrcSpanAnnP type LocatedBF = GenLocated SrcSpanAnnBF -- | Annotation for items appearing in a list. They can have one or @@ -441,7 +440,6 @@ type SrcSpanAnnA = EpAnn [TrailingAnn] -- on the context, such as backticks. type SrcSpanAnnN = EpAnn NameAnn -type SrcSpanAnnP = EpAnn AnnPragma type SrcSpanAnnBF = EpAnn AnnBooleanFormula type LocatedE = GenLocated EpaLocation ===================================== compiler/GHC/Unit/Module/Warnings.hs ===================================== @@ -158,8 +158,8 @@ warningTxtSame w1 w2 instance Outputable (InWarningCategory (GhcPass pass)) where ppr (InWarningCategory _ wt) = text "in" <+> doubleQuotes (ppr wt) -type instance XDeprecatedTxt (GhcPass _) = SourceText -type instance XWarningTxt (GhcPass _) = SourceText +type instance XDeprecatedTxt (GhcPass _) = (SourceText, AnnPragma) +type instance XWarningTxt (GhcPass _) = (SourceText, AnnPragma) type instance XXWarningTxt (GhcPass _) = DataConCantHappen type instance XInWarningCategory (GhcPass _) = (EpToken "in", SourceText) type instance XXInWarningCategory (GhcPass _) = DataConCantHappen @@ -167,7 +167,7 @@ type instance XXInWarningCategory (GhcPass _) = DataConCantHappen type instance Anno (WithHsDocIdentifiers (StringLiteral pass) pass) = SrcSpanAnnA type instance Anno (InWarningCategory (GhcPass pass)) = EpaLocation type instance Anno (WarningCategory) = EpaLocation -type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnP +type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnA deriving stock instance Eq (WarningTxt GhcPs) deriving stock instance Eq (WarningTxt GhcRn) @@ -190,15 +190,15 @@ deriving instance Outputable WarningCategory instance Outputable (WarningTxt (GhcPass pass)) where ppr (WarningTxt lsrc mcat ws) = case lsrc of - NoSourceText -> pp_ws ws - SourceText src -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}" + (NoSourceText, _) -> pp_ws ws + (SourceText src, _) -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}" where ctg_doc = maybe empty (\ctg -> ppr ctg) mcat ppr (DeprecatedTxt lsrc ds) = case lsrc of - NoSourceText -> pp_ws ds - SourceText src -> ftext src <+> pp_ws ds <+> text "#-}" + (NoSourceText, _) -> pp_ws ds + (SourceText src, _) -> ftext src <+> pp_ws ds <+> text "#-}" pp_ws :: [LocatedA (WithHsDocIdentifiers (StringLiteral (GhcPass p)) (GhcPass p))] -> SDoc pp_ws [l] = ppr $ unLoc l ===================================== libraries/base/changelog.md ===================================== @@ -38,6 +38,7 @@ * Show `ExceptionContext` in `displayExceptionAnnotation` implementation of `WhileHandling` ([GHC #27456](https://gitlab.haskell.org/ghc/ghc/-/issues/27456)) * Hide implementation details when throwing exceptions in throw and throwSTM. ([CLC proposal #387](https://github.com/haskell/core-libraries-committee/issues/387)) * Change `hIsReadable` and `hIsWritable` such that they always throw a respective exception when encountering a closed or semi-closed handle, not just in the case of a file handle. ([CLC proposal #371](github.com/haskell/core-libraries-committee/issues/371)) + * The implementation of `toException` in `SomeException`'s `Exception` instance no longer drops exception context, in keeping with the behavior originally proposed in [CLC Proposal #200](https://github.com/haskell/core-libraries-committee/issues/200). * Annotate `onException` continuation with `WhileHandling`. ([CLC Proposal #397](https://github.com/haskell/core-libraries-committee/issues/397)) * Improve error message for `Data.Char.chr`. ([CLC Proposal #384](https://github.com/haskell/core-libraries-committee/issues/384)) ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs ===================================== @@ -55,7 +55,7 @@ import GHC.Internal.Data.Maybe import GHC.Internal.Data.Typeable (Typeable, TypeRep, cast) import qualified GHC.Internal.Data.Typeable as Typeable -- loop: GHC.Internal.Data.Typeable -> GHC.Internal.Err -> GHC.Internal.Exception -import GHC.Internal.Base (String, Void, fmap, return, ($), (.), (++)) +import GHC.Internal.Base (String, Void, fmap, return, ($), (.), (++), id) import GHC.Internal.Show import GHC.Internal.Types (Bool(..)) import GHC.Internal.Exception.Context @@ -208,7 +208,16 @@ Caught MismatchedParentheses -} class (Typeable e, Show e) => Exception e where - -- | @toException@ should produce a 'SomeException' with no attached 'ExceptionContext'. + -- | 'toException' converts an exception into the existential 'SomeException' + -- wrapper type. + -- + -- In doing so, 'toException' should not /add/ an 'ExceptionContext'. + -- + -- - In most cases, the exception does not store its own 'ExceptionContext'. + -- The default implementation of 'toException' (which does not store any + -- 'ExceptionContext') is suitable for these cases. + -- - In the rare case that the exception itself stores an 'ExceptionContext', + -- this context should be preserved by 'toException'. toException :: e -> SomeException fromException :: SomeException -> Maybe e @@ -231,13 +240,11 @@ class (Typeable e, Show e) => Exception e where -- | @since base-4.8.0.0 instance Exception Void --- | This drops any attached 'ExceptionContext'. +-- | NB: this instance preserves the attached 'ExceptionContext'. -- -- @since base-3.0 instance Exception SomeException where - toException (SomeException e) = - let ?exceptionContext = emptyExceptionContext - in SomeException e + toException = id fromException = Just backtraceDesired (SomeException e) = backtraceDesired e displayException (SomeException e) = displayException e ===================================== testsuite/driver/runtests.py ===================================== @@ -94,6 +94,8 @@ parser.add_argument("--ignore-perf-failures", choices=['increases','decreases',' help="Do not fail due to out-of-tolerance perf tests") parser.add_argument("--only-report-hadrian-deps", type=Path, help="Dry run the testsuite and report all extra hadrian dependencies needed on the given file") +parser.add_argument("--force-colors", action="store_true", + help="emit ANSI colors even when stdout is not a tty (e.g. for CI logs)") args = parser.parse_args() @@ -259,7 +261,9 @@ def supports_colors(): return True config.supports_colors = supports_colors() -term_color.enable_color = config.supports_colors +# config.supports_colors deliberately stays tty-based: it also guards +# terminal-title updates, which must not end up in a CI log. +term_color.enable_color = config.supports_colors or args.force_colors # This has to come after arg parsing as the args can change the compiler get_compiler_info() @@ -587,7 +591,7 @@ else: print(Perf.allow_changes_string([(m.change, m.stat) for m in t.metrics])) print('-' * 25) - summary(t, sys.stdout, color=config.supports_colors) + summary(t, sys.stdout, color=term_color.enable_color, junit_path=args.junit) # Write perf stats if any exist or if a metrics file is specified. stats_metrics = [stat for (_, stat, __) in t.metrics] # type: List[PerfStat] ===================================== testsuite/driver/term_color.py ===================================== @@ -1,5 +1,6 @@ from enum import Enum +# Whether to emit color escapes; set in runtests.py. enable_color = True class Color(Enum): @@ -18,3 +19,7 @@ def colored(color: Color, s: str) -> str: else: return s +# For renderers that serve several sinks: `enabled` says whether *this* sink +# takes color (the summary is written both to stdout and to a plain-text file). +def colored_if(enabled: bool, color: Color, s: str) -> str: + return colored(color, s) if enabled else s ===================================== testsuite/driver/testlib.py ===================================== @@ -27,7 +27,7 @@ from testutil import strip_quotes, lndir, link_or_copy_file, passed, \ failBecause, testing_metrics, residency_testing_metrics, \ stable_perf_counters, \ PassFail, badResult, str_warn, str_removeprefix -from term_color import Color, colored +from term_color import Color, colored_if import testutil from cpu_features import have_cpu_feature import perf_notes as Perf @@ -1499,6 +1499,19 @@ def _newTestDir(name: TestName, opts: TestOptions, tempdir, dir): opts.testdir_raw = Path(os.path.join(tempdir, testdir, name + testdir_suffix)) opts.compiler_always_flags = config.compiler_always_flags +def _result_directory(opts: TestOptions) -> str: + # The test's source directory, relative to the GHC source root, so it reads + # the same regardless of which directory `make` was invoked from. + srcdir = opts.srcdir + if srcdir is None: + return '' + try: + return os.path.relpath(srcdir, config.top.parent) + except ValueError: + # No relative path exists (e.g. different Windows drives); the + # absolute path is still more useful than nothing. + return str(srcdir) + # ----------------------------------------------------------------------------- # Actually doing tests @@ -1823,7 +1836,7 @@ async def do_test(name: TestName, if opts.expect not in ['pass', 'fail', 'missing-lib']: framework_fail(name, way, 'bad expected ' + opts.expect) - directory = str_removeprefix(str_removeprefix(str(opts.testdir), './'), '.\\') + directory = _result_directory(opts) if way in opts.fragile_ways: if_verbose(1, '*** fragile test %s resulted in %s' % (full_name, 'pass' if result.passed else 'fail')) @@ -1877,7 +1890,7 @@ def framework_fail(name: Optional[TestName], way: Optional[WayName], reason: str # so we need to take care not to blow up with the wrong way # and report the actual reason for the failure. try: - directory = str_removeprefix(str_removeprefix(str(opts.testdir), './'), '.\\') + directory = _result_directory(opts) except: directory = '' full_name = '%s(%s)' % (name, way) @@ -1890,7 +1903,7 @@ def framework_fail(name: Optional[TestName], way: Optional[WayName], reason: str def framework_warn(name: TestName, way: WayName, reason: str) -> None: opts = getTestOpts() - directory = str_removeprefix(str_removeprefix(str(opts.testdir), './'), '.\\') + directory = _result_directory(opts) full_name = name + '(' + way + ')' if_verbose(1, '*** framework warning for %s %s ' % (full_name, reason)) t.framework_warnings.append(TestResult(directory, name, reason, way)) @@ -2445,19 +2458,23 @@ async def simple_run(name: TestName, way: WayName, prog: str, extra_run_opts: st dump_stdout(name) dump_stderr(name) message = format_bad_exit_code_message(exit_code) - return failBecause(message) + return failBecause(message, + stderr=read_stderr(name), + stdout=read_stdout(name)) stderr_match = CompareOutput(True) if (opts.ignore_stderr or opts.combined_output) else await stderr_ok(name, way) if not stderr_match: + # The diff already contains the mismatching stream; see Note [Redundant + # output in test results]. return failBecause('bad stderr', - stderr=read_stderr(name), + stderr=None if stderr_match.diff else read_stderr(name), stdout=read_stdout(name), diff=stderr_match.diff) stdout_match = CompareOutput(True) if opts.ignore_stdout else await stdout_ok(name, way) if not stdout_match: return failBecause('bad stdout', stderr=read_stderr(name), - stdout=read_stdout(name), + stdout=None if stdout_match.diff else read_stdout(name), diff=stdout_match.diff) check_hp = '-hT' in my_rts_flags and opts.check_hp @@ -2567,8 +2584,9 @@ async def interpreter_run(name: TestName, if not stderr_match: if _expect_pass(way): dump_stderr_for('comp', name) + # See Note [Redundant output in test results]. return failBecause('bad stderr', - stderr=read_stderr(name), + stderr=None if stderr_match.diff else read_stderr(name), stdout=read_stdout(name), diff=stderr_match.diff) stdout_match = CompareOutput(True) if opts.ignore_stdout else await stdout_ok(name, way) @@ -2577,7 +2595,7 @@ async def interpreter_run(name: TestName, dump_stderr_for('comp', name) return failBecause('bad stdout', stderr=read_stderr(name), - stdout=read_stdout(name), + stdout=None if stdout_match.diff else read_stdout(name), diff=stdout_match.diff) return passed() @@ -2635,13 +2653,13 @@ async def stdout_ok(name: TestName, way: WayName) -> CompareOutput: def read_stdout( name: TestName ) -> str: path = in_testdir(name, 'run.stdout') if path.exists(): - return path.read_text(encoding='UTF-8') + return path.read_text(encoding='UTF-8', errors='replace') else: return '' def read_diff( diff_file: Path ) -> Optional[str]: if diff_file.exists(): - diff = diff_file.read_text() + diff = diff_file.read_text(encoding='UTF-8', errors='replace') diff_file.unlink() return diff or None else: @@ -2665,14 +2683,14 @@ async def stderr_ok(name: TestName, way: WayName) -> CompareOutput: def read_comp_stderr( name: TestName ) -> str: path = in_testdir(name, 'comp.stderr') if path.exists(): - return path.read_text(encoding='UTF-8') + return path.read_text(encoding='UTF-8', errors='replace') else: return '' def read_stderr_for( phase: str, name: TestName ) -> str: path = in_testdir(name, phase + '.stderr') if path.exists(): - return path.read_text(encoding='UTF-8') + return path.read_text(encoding='UTF-8', errors='replace') else: return '' @@ -3571,12 +3589,50 @@ def findTFiles(roots: List[str]) -> Iterator[str]: # ----------------------------------------------------------------------------- # Output a test summary to the specified file object -def summary(t: TestRun, file: TextIO, color=False) -> None: +def summary(t: TestRun, file: TextIO, color=False, junit_path: Optional[Path]=None) -> None: file.write('\n') + + if t.unexpected_failures: + # Count output blocks rather than results: a test failing in many ways + # collapses to a single block. + groups = groupTestOutput(t.unexpected_failures) + if len(groups) <= MAX_SUMMARY_OUTPUT_TESTS: + printTestOutputSummary(file, groups, color, junit_path) + else: + where = '; see {}'.format(junit_path) if junit_path else '' + header = ('Unexpected failures (more than {}, output omitted{}):' + .format(MAX_SUMMARY_OUTPUT_TESTS, where)) + file.write(colored_if(color, Color.RED, header) + '\n') + printTestInfosSummary(file, t.unexpected_failures) + + if t.unexpected_passes: + header = 'Unexpected passes:' + file.write(colored_if(color, Color.RED, header) + '\n') + printTestInfosSummary(file, t.unexpected_passes) + + if t.unexpected_stat_failures: + header = 'Unexpected stat failures:' + file.write(colored_if(color, Color.RED, header) + '\n') + printTestInfosSummary(file, t.unexpected_stat_failures) + + if t.framework_failures: + header = 'Framework failures:' + file.write(colored_if(color, Color.RED, header) + '\n') + printTestInfosSummary(file, t.framework_failures) + + if t.framework_warnings: + header = 'Framework warnings:' + file.write(colored_if(color, Color.YELLOW, header) + '\n') + printTestInfosSummary(file, t.framework_warnings) + + if stopping(): + warning = 'WARNING: Testsuite run was terminated early' + file.write(colored_if(color, Color.YELLOW, warning) + '\n') + printUnexpectedTests(file, [t.unexpected_passes, t.unexpected_failures, - t.unexpected_stat_failures, t.framework_failures]) + t.unexpected_stat_failures, t.framework_failures], color) if len(t.unexpected_failures) > 0 or \ len(t.unexpected_stat_failures) > 0 or \ @@ -3587,7 +3643,8 @@ def summary(t: TestRun, file: TextIO, color=False) -> None: summary_color = Color.GREEN assert t.start_time is not None - file.write(colored(summary_color, 'SUMMARY') + ' for test run started at ' + summary_header = colored_if(color, summary_color, 'SUMMARY') + file.write(summary_header + ' for test run started at ' + t.start_time.strftime("%c %Z") + '\n' + str(datetime.datetime.now() - t.start_time).rjust(8) + ' spent to go through\n' @@ -3619,46 +3676,107 @@ def summary(t: TestRun, file: TextIO, color=False) -> None: + ' fragile tests\n' + '\n') - if t.unexpected_passes: - file.write('Unexpected passes:\n') - printTestInfosSummary(file, t.unexpected_passes) - - if t.unexpected_failures: - file.write('Unexpected failures:\n') - printTestInfosSummary(file, t.unexpected_failures) - - if t.unexpected_stat_failures: - file.write('Unexpected stat failures:\n') - printTestInfosSummary(file, t.unexpected_stat_failures) - - if t.framework_failures: - file.write('Framework failures:\n') - printTestInfosSummary(file, t.framework_failures) - - if t.framework_warnings: - file.write('Framework warnings:\n') - printTestInfosSummary(file, t.framework_warnings) - - if stopping(): - file.write('WARNING: Testsuite run was terminated early\n') - -def printUnexpectedTests(file: TextIO, testInfoss): +def printUnexpectedTests(file: TextIO, testInfoss, color=False): unexpected = set(result.testname for testInfos in testInfoss for result in testInfos if not result.testname.endswith('.T')) if unexpected: - file.write('Unexpected results from:\n') + header = 'Unexpected results from:' + file.write(colored_if(color, Color.RED, header) + '\n') file.write('TEST="' + ' '.join(sorted(unexpected)) + '"\n') file.write('\n') +# Per-stream cap on a failing test's output repeated in the final summary. +MAX_SUMMARY_OUTPUT_LINES = 100 + +# Above this many output blocks, skip repeating output entirely: the dump +# would drown out the summary. +MAX_SUMMARY_OUTPUT_TESTS = 20 + +# Note [Redundant output in test results] +# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +# A failing test result carries up to three pieces of output: `diff`, `stdout` +# and `stderr`. For an output mismatch these overlap: the diff's `+` lines are +# the very stream that mismatched, normalised. Reporting both would print the +# same text twice, so the mismatching stream is dropped at the call sites in +# favour of the diff, which additionally shows what was expected. The *other* +# stream is kept: on a stdout mismatch, stderr is independent context. +# +# The drop is conditional on there being a diff at all: compare_outputs only +# runs `diff` when config.verbose >= 1, so under -v0 the stream is the only +# output there is. +# +# Note that, since the drop happens at result construction, it also affects the +# JUnit report (junit.py). + +def strip_diff_header(diff: Optional[str]) -> Optional[str]: + # Drop diff(1)'s ---/+++ lines: they name normalised files in the test + # directory and carry timestamps, which would also keep otherwise + # identical failures from being grouped. + if diff is None: + return None + lines = diff.split('\n') + if len(lines) >= 2 and lines[0].startswith('--- ') and lines[1].startswith('+++ '): + return '\n'.join(lines[2:]) + return diff + +def sorted_results(testInfos: List[TestResult]) -> List[TestResult]: + return sorted(testInfos, key=lambda r: (r.testname.lower(), r.directory, r.way)) + +# A failure-output block: a representative result, its header-stripped diff, +# and the ways that share it. +OutputGroup = Tuple[TestResult, Optional[str], List[WayName]] + +# Tests that fail identically in several ways (e.g. normal and g1) share one +# output block, with the ways collected in the header. +def groupTestOutput(testInfos: List[TestResult]) -> List[OutputGroup]: + # Relies on dicts preserving insertion order. + groups = {} # type: Dict[Tuple, OutputGroup] + for result in sorted_results(testInfos): + diff = strip_diff_header(result.diff) + key = (result.testname, result.directory, result.reason, + diff, result.stdout, result.stderr) + groups.setdefault(key, (result, diff, []))[2].append(result.way) + return list(groups.values()) + +def printTestOutputSummary(file: TextIO, + groups: List[OutputGroup], + color: bool=False, + junit_path: Optional[Path]=None) -> None: + # Repeat failing tests' captured output in the summary, so one needn't + # hunt for it earlier in a possibly very long log; see #16720. + header = '=====> Unexpected failures output summary' + file.write(colored_if(color, Color.RED, header) + '\n\n') + + where = ', see {}'.format(junit_path) if junit_path else '' + for result, diff, ways in groups: + header = '=====> {}({}) ({}) [{}]'.format( + result.testname, ', '.join(ways), result.directory + os.sep, result.reason) + file.write(colored_if(color, Color.RED, header) + '\n') + # See Note [Redundant output in test results] for why these don't overlap. + for label, contents in [('Output diff (expected vs actual):', diff), + ('Captured stdout:', result.stdout), + ('Captured stderr:', result.stderr)]: + if contents and contents.strip(): + lines = contents.rstrip('\n').split('\n') + if len(lines) > MAX_SUMMARY_OUTPUT_LINES: + omitted = len(lines) - MAX_SUMMARY_OUTPUT_LINES + lines = lines[:MAX_SUMMARY_OUTPUT_LINES] \ + + ['... ({} more lines omitted{})'.format(omitted, where)] + s = colored_if(color, Color.CYAN, label) + '\n' \ + + ''.join(l + '\n' for l in lines) + # Test output can contain characters that file's encoding + # cannot represent; replace rather than crash (cf safe_print). + enc = getattr(file, 'encoding', None) or 'utf-8' + file.write(s.encode(enc, errors='replace').decode(enc)) + footer = '<===== end of unexpected failures output summary' + file.write(colored_if(color, Color.RED, footer) + '\n\n') + def printTestInfosSummary(file: TextIO, testInfos): - maxDirLen = max(len(tr.directory) for tr in testInfos) - for result in sorted(testInfos, key=lambda r: (r.testname.lower(), r.way, r.directory)): - directory = result.directory.ljust(maxDirLen) - file.write(' {directory} {r.testname} [{r.reason}] ({r.way})\n'.format( - r = result, - directory = directory)) + for result in sorted_results(testInfos): + path = os.path.join(result.directory, result.testname) + file.write(' {path} [{r.reason}] ({r.way})\n'.format(r=result, path=path)) file.write('\n') def modify_lines(s: str, f: Callable[[str], str]) -> str: ===================================== testsuite/tests/ghc-e/should_fail/T18441fail7.stderr ===================================== @@ -5,8 +5,12 @@ IO error: "Abcde" does not exist While handling ghc-10.1-inplace:GHC.Utils.Panic.GhcException: | | IO error: "Abcde" does not exist + | + | HasCallStack backtrace: + | throw, called at compiler/GHC/Utils/Panic.hs:180:21 in ghc-10.1-inplace:GHC.Utils.Panic + | throwGhcException, called at ghc/GHCi/UI.hs:2851:21 in ghc-bin-10.1.20260801-inplace:GHCi.UI HasCallStack backtrace: - throwIO, called at compiler\GHC\Utils\Error.hs:499:19 in ghc-10.1-inplace:GHC.Utils.Error + throwIO, called at compiler/GHC/Utils/Error.hs:513:19 in ghc-10.1-inplace:GHC.Utils.Error 1 ===================================== testsuite/tests/ghc-e/should_run/ghc-e005.stderr ===================================== @@ -4,3 +4,8 @@ foo HasCallStack backtrace: error, called at ghc-e005.hs:12:10 in main:Main + + +HasCallStack backtrace: + throwIO, called at ghc\GHCi\UI.hs:1655:31 in ghc-bin-10.1.20260629-inplace:GHCi.UI + ===================================== testsuite/tests/saks/should_compile/T18725a.hs ===================================== @@ -0,0 +1,10 @@ +{-# LANGUAGE ExplicitForAll, KindSignatures, StandaloneKindSignatures, + DataKinds, GADTs #-} + +module T18725a where + +import Data.Kind (Type) + +type U :: Type +data U where P :: forall u. E u -> U +data E (u :: U) ===================================== testsuite/tests/saks/should_compile/all.T ===================================== @@ -35,6 +35,7 @@ test('T16726', normal, compile, ['']) test('T16731', normal, compile, ['']) test('T16721', normal, ghci_script, ['T16721.script']) test('T16756a', normal, compile, ['']) +test('T18725a', normal, compile, ['']) test('saks027', req_th, compile, ['-v0 -ddump-splices -dsuppress-uniques']) test('saks028', req_th, compile, ['']) ===================================== testsuite/tests/saks/should_fail/T18725b.hs ===================================== @@ -0,0 +1,8 @@ +{-# LANGUAGE ExplicitForAll, KindSignatures, StandaloneKindSignatures, + DataKinds, GADTs #-} + +module T18725b where + +-- type U :: Type -- Rejected without the sig +data U where P :: forall u. E u -> U +data E (u :: U) ===================================== testsuite/tests/saks/should_fail/T18725b.stderr ===================================== @@ -0,0 +1,6 @@ +T18725b.hs:8:14: error: [GHC-85413] + • Type constructor ‘U’ cannot be used here + (it is defined and used in the same recursive group) + • In the kind ‘U’ + In the data type declaration for ‘E’ + ===================================== testsuite/tests/saks/should_fail/all.T ===================================== @@ -38,3 +38,5 @@ test('T18863d', normal, compile_fail, ['']) test('T20916', normal, compile_fail, ['']) test('saks018-fail', normal, compile_fail, ['']) test('saks021-fail', normal, compile_fail, ['']) +test('T18725b', normal, compile_fail, ['']) + ===================================== testsuite/tests/th/T20902.hs ===================================== @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} + +module T20902 where + +import Language.Haskell.TH + +data T = FU | FUN deriving Show + +expr1 = $( conE (mkName "FU") ) +expr2 = $( conE (mkName "FUN") ) +expr3 = $( [| FU |] ) +expr4 = $( [| FUN |] ) + ===================================== testsuite/tests/th/all.T ===================================== @@ -651,3 +651,5 @@ test('T26099', normal, compile_fail, ['']) test('T8306_th', only_ways(['ghci']), ghci_script, ['T8306_th.script']) test('T26862_th', only_ways(['ghci']), ghci_script, ['T26862_th.script']) test('T27022', normal, compile_and_run, ['']) +test('T20902', normal, compile, ['']) + ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -1555,26 +1555,26 @@ instance ExactPrint ModuleName where -- --------------------------------------------------------------------- -instance ExactPrint (LocatedP (WarningTxt GhcPs)) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn +instance ExactPrint (WarningTxt GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a - exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (WarningTxt src mb_cat ws)) = do + exact (WarningTxt (src, AnnPragma o c (os,cs) l1 l2 t m) mb_cat ws) = do o' <- markAnnOpen'' o src "{-# WARNING" mb_cat' <- markAnnotated mb_cat os' <- markEpToken os ws' <- mapM markAnnotated ws cs' <- markEpToken cs c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (WarningTxt src mb_cat' ws')) + return (WarningTxt (src, AnnPragma o' c' (os',cs') l1 l2 t m) mb_cat' ws') - exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (DeprecatedTxt src ws)) = do + exact (DeprecatedTxt (src, AnnPragma o c (os,cs) l1 l2 t m) ws) = do o' <- markAnnOpen'' o src "{-# DEPRECATED" os' <- markEpToken os ws' <- mapM markAnnotated ws cs' <- markEpToken cs c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (DeprecatedTxt src ws')) + return (DeprecatedTxt (src, AnnPragma o' c' (os',cs') l1 l2 t m) ws') instance ExactPrint (InWarningCategory GhcPs) where getAnnotationEntry _ = NoEntryVal View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1a2bc8f4d302166c3d13c258c24223… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1a2bc8f4d302166c3d13c258c24223… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/hie-file-improvements] 2 commits: hie files: Dump the type table when dumping with -ddump-hie
by Hannes Siebenhandl (＠fendor) 05 Aug '26

05 Aug '26

Hannes Siebenhandl pushed to branch wip/hie-file-improvements at Glasgow Haskell Compiler / GHC Commits: 84281173 by Zubin Duggal at 2026-08-05T09:57:18+02:00 hie files: Dump the type table when dumping with -ddump-hie - - - - - 8d9e95e9 by Zubin Duggal at 2026-08-05T09:57:18+02:00 hie files: Take evidence for quantified constraints into account when saving evidence terms to the hie ast Fixes #25709 - - - - - 6 changed files: - compiler/GHC/Driver/Main/Passes.hs - compiler/GHC/Iface/Ext/Types.hs - testsuite/tests/hiefile/should_compile/T24493.stderr - + testsuite/tests/hiefile/should_run/T25709.hs - + testsuite/tests/hiefile/should_run/T25709.stdout - testsuite/tests/hiefile/should_run/all.T Changes: ===================================== compiler/GHC/Driver/Main/Passes.hs ===================================== @@ -92,7 +92,7 @@ import GHC.Iface.Make import GHC.Iface.Recomp import GHC.Iface.Tidy import GHC.Iface.Ext.Ast ( mkHieFile ) -import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module ) +import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module, hie_types ) import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result) import GHC.Iface.Ext.Debug ( diffFile, validateScopes ) @@ -167,7 +167,7 @@ import GHC.Data.StringBuffer import GHC.Data.Maybe import qualified GHC.Data.Strict as Strict - +import qualified Data.Array as A import Data.List ( nub, isPrefixOf, partition ) import qualified Data.List.NonEmpty as NE import Control.Monad @@ -332,7 +332,10 @@ extract_renamed_stuff mod_summary tc_result = do hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info) let out_file = ml_hie_file $ ms_location mod_summary liftIO $ writeHieFile out_file hieFile - liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile) + let hie_doc = + ppr (hie_asts hieFile) + $+$ ppr (A.assocs $ hie_types hieFile) + liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell hie_doc -- Validate HIE files when (gopt Opt_ValidateHie dflags) $ do ===================================== compiler/GHC/Iface/Ext/Types.hs ===================================== @@ -159,6 +159,18 @@ data HieType a | HCoercionTy deriving (Functor, Foldable, Traversable, Eq) +instance Outputable a => Outputable (HieType a) where + ppr (HTyVarTy name) = ppr name + ppr (HAppTy fun arg) = parens $ ppr fun <+> ppr arg + ppr (HTyConApp tc args) = parens $ ppr tc <+> ppr args + ppr (HForAllTy ((name, ty), flag) body) = + text "forall" <+> ppr flag <+> ppr name O.<> text ":" <+> ppr ty O.<> text "." <+> ppr body + ppr (HFunTy mult arg res) = parens $ ppr arg <+> arrow <+> ppr res <+> ppr mult + ppr (HQualTy ctxt ty) = parens $ ppr ctxt <+> text "=>" <+> ppr ty + ppr (HLitTy lit) = ppr lit + ppr (HCastTy ty) = text "cast" <+> ppr ty + ppr HCoercionTy = text "<coercion>" + type HieTypeFlat = HieType TypeIndex -- | Roughly isomorphic to the original core 'Type'. @@ -222,6 +234,10 @@ instance Binary (HieArgs TypeIndex) where put_ bh (HieArgs xs) = put_ bh xs get bh = HieArgs <$> get bh +instance Outputable a => Outputable (HieArgs a) where + ppr (HieArgs args) = braces $ hsep $ punctuate comma $ map pprArg args + where pprArg (vis, ty) = (if vis then id else parens) (ppr ty) + -- A HiePath is just a lexical FastString. We use a lexical FastString to avoid -- non-determinism when printing or storing HieASTs which are sorted by their ===================================== testsuite/tests/hiefile/should_compile/T24493.stderr ===================================== @@ -1,3 +1,4 @@ + ==================== HIE AST ==================== File: T24493.hs Node@T24493.hs:(1,8)-(3,8): Source: From source @@ -25,9 +26,10 @@ Node@T24493.hs:(1,8)-(3,8): Source: From source Node@T24493.hs:3:6-8: Source: From source {(annotations: {(HsLit, HsExpr)}), (types: [0]), (identifier info: {})} - + +[(0, (GHC.Internal.Base.String {}))] Got valid scopes -Got no roundtrip errors \ No newline at end of file +Got no roundtrip errors ===================================== testsuite/tests/hiefile/should_run/T25709.hs ===================================== @@ -0,0 +1,40 @@ +{-# LANGUAGE QuantifiedConstraints#-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +module Main where + +import TestUtils +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import Data.Either +import Data.Maybe +import Data.Bifunctor (first) +import GHC.Plugins (moduleNameString, nameStableString, nameOccName, occNameString, isDerivedOccName) +import GHC.Iface.Ext.Types + + +import Data.Typeable + +data Some c where + Some :: c a => a -> Some c + +extractSome :: (Typeable a, forall x. c x => Typeable x) => Some c -> Maybe a +extractSome (Some a) = cast a + +f :: (forall x. Ord x => Eq [x]) => () +f = () +{-# NOINLINE f #-} + +g :: () +g = f + +useQC :: forall c a. (c a, forall x. c x => Show x) => a -> String +useQC x = show x + +points :: [(Int,Int)] +points = [(22,26),(29, 5), (32, 13)] + +main = do + (df, hf) <- readTestHie "T25709.hie" + let refmap = generateReferencesMap $ getAsts $ hie_asts hf + traverse (explainEv df hf refmap) points ===================================== testsuite/tests/hiefile/should_run/T25709.stdout ===================================== @@ -0,0 +1,110 @@ +========================== +At point (22,26), we found: +========================== +┌ +│ $dTypeable at T25709.hs:22:14-19, of type: Typeable a +│ is an evidence variable bound by a let, depending on: [$dTypeable] +│ with scope: LocalScope T25709.hs:22:14-29 +│ +│ Defined at <no location info> +└ +| +`- ┌ + │ $dTypeable at T25709.hs:22:1-29, of type: Typeable a + │ is an evidence variable bound by a HsWrapper + │ with scope: LocalScope T25709.hs:22:1-29 + │ bound at: T25709.hs:22:1-29 + │ Defined at <no location info> + └ + +┌ +│ $dTypeable at T25709.hs:22:14-19, of type: Typeable a +│ is an evidence variable bound by a let, depending on: [df, irred] +│ with scope: LocalScope T25709.hs:22:14-29 +│ +│ Defined at <no location info> +└ +| ++- ┌ +| │ df at T25709.hs:22:1-29, of type: forall x. c x => Typeable x +| │ is an evidence variable bound by a HsWrapper +| │ with scope: LocalScope T25709.hs:22:1-29 +| │ bound at: T25709.hs:22:1-29 +| │ Defined at <no location info> +| └ +| +`- ┌ + │ irred at T25709.hs:22:14-19, of type: c a + │ is an evidence variable bound by a let, depending on: [irred] + │ with scope: LocalScope T25709.hs:22:14-29 + │ + │ Defined at <no location info> + └ + | + `- ┌ + │ irred at T25709.hs:22:14-19, of type: c a + │ is an evidence variable bound by a pattern + │ with scope: LocalScope T25709.hs:22:14-29 + │ + │ Defined at <no location info> + └ + +========================== +At point (29,5), we found: +========================== +┌ +│ df at T25709.hs:1:1, of type: forall x. Ord x => Eq [x] +│ is an evidence variable bound by a let, depending on: [$p1Ord, +│ $fEqList] +│ with scope: ModuleScope +│ +│ Defined at <no location info> +└ +| ++- ┌ +| │ $p1Ord at T25709.hs:1:1, of type: forall a. Ord a => Eq a +| │ is a usage of an external evidence variable +| │ Defined in `GHC.Internal.Classes' +| └ +| +`- ┌ + │ $fEqList at T25709.hs:1:1, of type: forall a. Eq a => Eq [a] + │ is a usage of an external evidence variable + │ Defined in `GHC.Internal.Classes' + └ + +========================== +At point (32,13), we found: +========================== +┌ +│ $dShow at T25709.hs:32:1-16, of type: Show a +│ is an evidence variable bound by a let, depending on: [df, irred] +│ with scope: LocalScope T25709.hs:32:1-16 +│ bound at: T25709.hs:32:1-16 +│ Defined at <no location info> +└ +| ++- ┌ +| │ df at T25709.hs:32:1-16, of type: forall x. c x => Show x +| │ is an evidence variable bound by a HsWrapper +| │ with scope: LocalScope T25709.hs:32:1-16 +| │ bound at: T25709.hs:32:1-16 +| │ Defined at <no location info> +| └ +| +`- ┌ + │ irred at T25709.hs:32:1-16, of type: c a + │ is an evidence variable bound by a let, depending on: [irred] + │ with scope: LocalScope T25709.hs:32:1-16 + │ bound at: T25709.hs:32:1-16 + │ Defined at <no location info> + └ + | + `- ┌ + │ irred at T25709.hs:32:1-16, of type: c a + │ is an evidence variable bound by a HsWrapper + │ with scope: LocalScope T25709.hs:32:1-16 + │ bound at: T25709.hs:32:1-16 + │ Defined at <no location info> + └ + ===================================== testsuite/tests/hiefile/should_run/all.T ===================================== @@ -8,4 +8,5 @@ test('HieVdq', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUti test('T23540', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info']) test('T23120', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info']) test('T24544', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info']) -test('HieGadtConSigs', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info']) \ No newline at end of file +test('HieGadtConSigs', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info']) +test('T25709', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9d32d5479bcf272021b24068330201… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9d32d5479bcf272021b24068330201… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sg/enter-data] StgToCmm: force lifted data through stg_enter_data
by Sebastian Graf (＠sgraf812) 05 Aug '26

05 Aug '26

Sebastian Graf pushed to branch wip/sg/enter-data at Glasgow Haskell Compiler / GHC Commits: add5a749 by Sebastian Graf at 2026-08-05T09:35:16+02:00 StgToCmm: force lifted data through stg_enter_data emitEnter's Return case entered the closure unconditionally, so a thunk that had been evaluated already got entered anyway. It now jumps to stg_enter_data, a new RTS stub that tests the tag first and returns the pointer when it is set. See Note [Forcing lifted data] in GHC.StgToCmm.Expr. Implements #27594, unblocks #23173. nofib imaginary+spectral is a wash: allocations unchanged, instructions +0.07% geometric mean, compile time unchanged. - - - - - 5 changed files: - + changelog.d/27594 - compiler/GHC/StgToCmm/Expr.hs - rts/Apply.cmm - rts/RtsSymbols.c - rts/include/stg/MiscClosures.h Changes: ===================================== changelog.d/27594 ===================================== @@ -0,0 +1,10 @@ +section: codegen +synopsis: Returning lifted, already evaluated data no longer enters its closure +issues: #27594 +mrs: !16445 +description: + In ``f (Just x) = x``, GHC must evaluate ``x`` before returning it, and used + to do so by entering ``x``'s closure unconditionally. It now tests ``x``'s + pointer tag first and returns ``x`` directly when it is evaluated already, + entering the closure only otherwise. Scrutinising a value, as in + ``case x of ...``, has always tested the tag this way. ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -36,6 +36,8 @@ import GHC.Cmm.BlockId import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info import GHC.Cmm.Utils ( cmmTagMask, mkWordCLit ) +import GHC.Cmm.CLabel ( mkCmmCodeLabel ) +import GHC.Unit ( rtsUnitId ) import GHC.Platform.Tag ( mAX_PTR_TAG ) import GHC.Core import GHC.Core.DataCon @@ -1183,6 +1185,47 @@ cgIdApp fun_id args = do -- DynFlags, then passed to StgToCmmConfig for this phase. +{- Note [Forcing lifted data] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + f :: Maybe Bool -> Bool + f (Just x) = x + +After `f` pattern-matches on the `Just` it must then evaluate `x` and +return it to the caller. It could do so by unconditionally entering the +code in x's closure, but we don't want to do so for two reasons: + +* If the RHS had been `case x of (a,b) -> blah`, GHC generates an inline test + for EPT; for non-tagged pointers, it then pushes a return address and + enters it (see the AssignTo case of emitEnter, below). It would be + consistent to do the same for tail calls too. + +* Finally, if we adopt the design described in #23173, if x is untagged, its + entry code might warn or panic. In that case we definitely should not to enter + it. + +Where are these decisions taken? getCallMethod (GHC.StgToCmm.Closure) +classifies the application and cgIdApp dispatches on the result. +Since `Bool` is not a function type and `x` is not statically EPT +(See Note [EPT enforcement]), we land in the EnterIt case under a Return +sequel. In that case, emitEnter emits a jump to the RTS stub stg_enter_data +(rts/Apply.cmm), which tests the tag, returns the pointer if it is set and +enters the closure otherwise. + +Why a stub here, when the AssignTo case inlines it? There the continuation is +a known address that the code can directly jump to. If we were creating a stub +as well, it would become a register-indirect jump that would be difficult to +predict by the CPU. +Under Return, the continuation's address is unknown, so inlining the stub has +no specialisation effect, yet incur more code to generate and place in +potentially tight loops. +That costs 2.6% more compiler allocation on eval-heavy T13960 and about 19 bytes +per site, while nofib stays within +-0.2% runtime either way. + +See #27594. +-} + emitEnter :: CmmExpr -> FCode ReturnKind emitEnter fun = do { platform <- getPlatform @@ -1190,22 +1233,14 @@ emitEnter fun = do ; adjustHpBackwards ; sequel <- getSequel ; updfr_off <- getUpdFrameOff - ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig ; case sequel of - -- For a return, we have the option of generating a tag-test or - -- not. If the value is tagged, we can return directly, which - -- is quicker than entering the value. This is a code - -- size/speed trade-off: when optimising for speed rather than - -- size we could generate the tag test. - -- - -- Right now, we do what the old codegen did, and omit the tag - -- test, just generating an enter. + -- For a return we jump to stg_enter_data, which returns an already + -- tagged pointer to our caller and enters an untagged one. + -- See Note [Forcing lifted data] Return -> do - { let entry = entryCode platform - $ closureInfoPtr platform align_check - $ CmmReg (nodeReg platform) - ; emit $ mkJump profile NativeNodeCall entry - [cmmUntag platform fun] updfr_off + { let enter_data = CmmLit (CmmLabel + (mkCmmCodeLabel rtsUnitId (fsLit "stg_enter_data"))) + ; emit $ mkJump profile NativeNodeCall enter_data [fun] updfr_off ; return AssignedDirectly } ===================================== rts/Apply.cmm ===================================== @@ -47,6 +47,21 @@ import CLOSURE stg_apply_interp_info; import CLOSURE stg_restore_cccs_eval_info; #endif +/* Force a lifted closure whose type rules out functions: return it if it is already + * tagged, enter it otherwise. The code generator jumps here to evaluate + * lifted data in tail position; see Note [Forcing lifted data] in + * GHC.StgToCmm.Expr for why. + * NB: Function-typed closures must go through the more general stg_ap_0_fast. + */ + +stg_enter_data ( P_ x ) +{ + if (GETTAG(x) != 0) { + return (x); + } + jump %GET_ENTRY(x) (x); +} + /* ---------------------------------------------------------------------------- * Evaluate a closure and return it. * ===================================== rts/RtsSymbols.c ===================================== @@ -842,6 +842,7 @@ extern char **environ; SymI_HasDataProto(stg_ap_ppppp_info) \ SymI_HasDataProto(stg_ap_pppppp_info) \ SymI_HasDataProto(stg_ap_0_fast) \ + SymI_HasDataProto(stg_enter_data) \ SymI_HasDataProto(stg_ap_v_fast) \ SymI_HasDataProto(stg_ap_f_fast) \ SymI_HasDataProto(stg_ap_d_fast) \ ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -300,6 +300,7 @@ RTS_RET(stg_ap_ppppp); RTS_RET(stg_ap_pppppp); RTS_FUN_DECL(stg_ap_0_fast); +RTS_FUN_DECL(stg_enter_data); RTS_FUN_DECL(stg_ap_v_fast); RTS_FUN_DECL(stg_ap_f_fast); RTS_FUN_DECL(stg_ap_d_fast); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/add5a749088a82191bad32524242aab… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/add5a749088a82191bad32524242aab… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 10 commits: testsuite: Don't crash on non-UTF-8 test output
by Marge Bot (＠marge-bot) 05 Aug '26

05 Aug '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 1e38fe22 by Simon Jakobi at 2026-08-04T20:34:57-04:00 testsuite: Don't crash on non-UTF-8 test output read_stdout, read_stderr_for, read_comp_stderr and read_diff decoded strictly (the first three with UTF-8, read_diff with the locale encoding), so a test emitting invalid UTF-8 (binary output, or a crash truncating a multi-byte character) raised UnicodeDecodeError and was reported as a framework failure instead of its actual result. Decode with errors='replace', like read_no_crs and safe_print. Assisted-by: Claude Fable 5 - - - - - b257b75c by Simon Jakobi at 2026-08-04T20:34:57-04:00 testsuite: Colorize the test summary, also in CI The summary headings were plain, and SUMMARY was colored unconditionally, so the escapes also ended up in the file written by --summary-file. Color is now decided per output sink via term_color.colored_if; see the comments in term_color. CI logs are not a tty, but GitLab's log viewer renders ANSI colors, so add --force-colors and pass it in .gitlab/ci.sh. Assisted-by: Claude Opus 5 - - - - - 86527622 by Simon Jakobi at 2026-08-04T20:34:57-04:00 testsuite: Repeat unexpected failure output in the summary Finding out why a test failed meant scrolling back through a possibly very long log to the point where the test ran. The summary now repeats the captured output of unexpected failures, before the statistics, so the most interesting part is at the end of the log (#16720). Output mismatches report their diff instead of the mismatching stream (see Note [Redundant output in test results]). The repeated output is bounded per stream, and skipped altogether beyond MAX_SUMMARY_OUTPUT_TESTS failure blocks. Tests failing identically in several ways share one block. Test results now report a source-relative directory, stable regardless of where the run was started from. Assisted-by: Claude Fable 5 - - - - - f6970cb9 by Ben Gamari at 2026-08-04T20:34:57-04:00 base: Don't drop exception context in SomeException(toException) For reasons that are lost to time, the implementation of [CLC #200] that was merged inappropriately dropped `ExceptionContext` in the `toException` implementation given to `SomeException`. Fix this infelicity. [CLC #200]: https://github.com/haskell/core-libraries-committee/issues/200 - - - - - d745133d by Simon Jakobi at 2026-08-04T20:34:59-04:00 Cmm: print unreachable blocks under -dppr-debug (#27368) Unreachable blocks linger in a CmmGraph's block map for most of the Cmm pipeline, but pprCmmGraph only ever printed the blocks reachable from the entry, so dumps looked consistent while the graph was not. Issues like #27368 were hard to debug due to this. pprCmmGraph now appends the stored-but-unreachable blocks under a "// unreachable blocks:" heading when -dppr-debug is on. See Note [unreachable blocks] in GHC.Cmm.Pipeline. Assisted-by: Claude Opus 5 - - - - - 9b74e7f1 by Cheng Shao at 2026-08-04T20:35:00-04:00 compiler: always run cmm lint on parsed cmm when compiling .cmm input This patch makes ghc always run cmm lint on parsed cmm when compiling .cmm input. Hand-written cmm is extremely error-prone and they take just a small fraction of time when compiling ghc or user libraries anyway, hence it's beneficial to enforce a lint even if -dcmm-lint is not explicitly turned on. Closes #8372. Co-authored-by: Codex <codex(a)openai.com> - - - - - 9a957874 by Simon Peyton Jones at 2026-08-04T20:35:01-04:00 Fix three bugs related to required type args and INLINE pragmas * `GHC.Core.Opt.Arity.mkEtaForAllMCo` got the visibility flags back to front, leading to a Lint error (#27557) * The arity in an InlineSaturation is the VisArity not the Arity; the two can differ when we have "required" type arguments. This made the INLINE pragma argument counting go wrong in `makeCorePair` (#27590). * When a simple binding has a type signature, we take special path in `tcPolyCheck`, leading to an outer `AbsBinds` that has no dictionaries, even when the binding is in fact overloaded. That confused the inline-arity computation in `makeCorePair` (#27589). The latter two are fixed using the new function `GHC.HsToCore.Binds.findSatArity`. That actually simplifies the API of `makeCorePair`, which is nice. The first bug is fixed by swapping the visiblity flags in `GHC.Core.Opt.Arity.mkEtaForAllMCo` Getting the INLINE behaviour right led to some perf changes: * Runtime /halved/ on T7954 due to better specialisation * Compile time increased by 6% in T21839c because a bit more inlining happened, as it always should have done. Geometric mean effect on our compile time benchmarks is +0.1%. Metric Decrease: T7954 Metric Increase: T21839c - - - - - 5cb7a47e by Vladislav Zavialov at 2026-08-04T20:35:02-04:00 Test case for #20902 Starting with GHC 9.14.1 (the first major release to include 51e3ec83), and from point releases GHC 9.10.2 and GHC 9.12.3 (backports cc4470be68 and b30f25591e), all examples in this ticket are handled as expected. - - - - - c5d2270f by Alan Zimmerman at 2026-08-04T20:35:03-04:00 EPA: Remove LocatedP, last use in WarningTxt The last step of removing LocatedP, by moving the AnnPragma for WarningTxt into its TTG extension point instead. This also allows us to remove LocatedP and SrcSpanAnnP - - - - - 1a2bc8f4 by Vladislav Zavialov at 2026-08-04T20:35:04-04:00 Test cases for #18725 Starting with GHC 9.4 (the first release to include 268efcc9a4), the program in this ticket no longer panics. A standalone kind signature breaks the recursive loop, so the type constructor can be used in a kind within its own group. T18725a checks that this is accepted with the signature present, while T18725b confirms it is still rejected without it. - - - - - 56 changed files: - .gitlab/ci.sh - + changelog.d/T27368-ppr-unreachable-cmm-blocks.md - + changelog.d/T27455 - + changelog.d/T27557 - + changelog.d/T27589 - + changelog.d/always-lint-cmm-file - compiler/GHC/Builtin/Utils.hs - compiler/GHC/Cmm.hs - compiler/GHC/Cmm/Pipeline.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Driver/Main/Compile.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Warnings.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Types/Arity.hs - compiler/GHC/Types/InlinePragma.hs - compiler/GHC/Types/Var.hs - compiler/GHC/Unit/Module/Warnings.hs - docs/users_guide/debugging.rst - libraries/base/changelog.md - libraries/base/tests/perf/ElemFusionUnknownList_O1.stderr - libraries/base/tests/perf/ElemFusionUnknownList_O2.stderr - libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs - testsuite/driver/runtests.py - testsuite/driver/term_color.py - testsuite/driver/testlib.py - testsuite/tests/cmm/should_compile/Makefile - + testsuite/tests/cmm/should_compile/T27368-ppr-debug.cmm - + testsuite/tests/cmm/should_compile/T27368-ppr-debug.stdout - testsuite/tests/cmm/should_compile/all.T - testsuite/tests/ghc-e/should_fail/T18441fail7.stderr - testsuite/tests/ghc-e/should_run/ghc-e005.stderr - + testsuite/tests/saks/should_compile/T18725a.hs - testsuite/tests/saks/should_compile/all.T - + testsuite/tests/saks/should_fail/T18725b.hs - + testsuite/tests/saks/should_fail/T18725b.stderr - testsuite/tests/saks/should_fail/all.T - + testsuite/tests/simplCore/should_compile/T27589.hs - + testsuite/tests/simplCore/should_compile/T27589.stderr - + testsuite/tests/simplCore/should_compile/T27590.hs - + testsuite/tests/simplCore/should_compile/T27590.stderr - testsuite/tests/simplCore/should_compile/all.T - + testsuite/tests/th/T20902.hs - testsuite/tests/th/all.T - + testsuite/tests/typecheck/should_compile/T27557.hs - testsuite/tests/typecheck/should_compile/all.T - utils/check-exact/ExactPrint.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/97145b38ff250042802d9d568343a4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/97145b38ff250042802d9d568343a4… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0