Simon Jakobi pushed to branch wip/sjakobi/udfm-placement at Glasgow Haskell Compiler / GHC Commits: 8fc6f882 by Simon Jakobi at 2026-08-05T14:53:41-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 - - - - - 56534866 by Simon Jakobi at 2026-08-05T14:53:41-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 - - - - - bceb541a by Simon Jakobi at 2026-08-05T14:53:42-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 - - - - - 2ab02c57 by Ben Gamari at 2026-08-05T14:54:24-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 - - - - - 126ce574 by Vladislav Zavialov at 2026-08-05T14:55:05-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. - - - - - b14d8d59 by Alan Zimmerman at 2026-08-05T14:55:46-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 - - - - - 70b58c8f by Vladislav Zavialov at 2026-08-05T14:56:27-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. - - - - - 1dd10a13 by Simon Jakobi at 2026-08-05T21:18:35+02:00 Word64Map: add compareSize compareSize m c compares the size of a map to an Int, but unlike compare (size m) c it stops traversing the map once the outcome is determined. Based on https://github.com/haskell/containers/pull/1139 Assisted-by: Claude Opus 5 - - - - - f5392a90 by Simon Jakobi at 2026-08-05T21:18:35+02:00 Use a pigeonhole sort for deterministic UniqDFM iteration Deterministic UniqDFM iteration used a list mergesort, allocating O(n log n) cons cells and contributing significantly to compiler allocations (#27459). Use a pigeonhole sort where appropriate, while retaining the mergesort fallback. See Note [Sorting a UDFM] and Note [Cost of deterministic iteration]. ------------------------- Metric Decrease: InstanceMatching InstanceMatching1 ManyAlternatives T12707 T13379 T13719 T24471 T5321FD T5321Fun T783 ------------------------- Assisted-by: gpt-5.6-sol via Codex CLI - - - - - 30 changed files: - .gitlab/ci.sh - + changelog.d/T27455 - compiler/GHC/Builtin/Utils.hs - compiler/GHC/Data/Word64Map/Internal.hs - compiler/GHC/Data/Word64Map/Lazy.hs - compiler/GHC/Data/Word64Map/Strict.hs - compiler/GHC/Data/Word64Map/Strict/Internal.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/Types/Unique/DFM.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/Data/Word64Map/Internal.hs ===================================== @@ -72,6 +72,7 @@ module GHC.Data.Word64Map.Internal ( -- * Query , null , size + , compareSize , member , notMember , lookup @@ -169,6 +170,7 @@ module GHC.Data.Word64Map.Internal ( , map , mapWithKey , traverseWithKey + , traverseWithKey_ , traverseMaybeWithKey , mapAccum , mapAccumWithKey @@ -522,6 +524,8 @@ null _ = False -- > size empty == 0 -- > size (singleton 1 'a') == 1 -- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3 +-- +-- See also: 'compareSize' size :: Word64Map a -> Int size = go 0 where @@ -529,6 +533,23 @@ size = go 0 go acc (Tip _ _) = 1 + acc go acc Nil = acc +-- | \(O(\min(n,c))\). Compare the number of entries in the map to an @Int@. +-- +-- @compareSize m c@ returns the same result as @compare ('size' m) c@ but is +-- more efficient when @c@ is smaller than the size of the map. +compareSize :: Word64Map a -> Int -> Ordering +compareSize Nil c0 = compare 0 c0 +compareSize _ c0 | c0 <= 0 = GT +compareSize t c0 = compare 0 (go t (c0 - 1)) + where + go (Bin _ _ _ _) 0 = -1 + go (Bin _ _ l r) c + | c' < 0 = c' + | otherwise = go r c' + where + c' = go l (c - 1) + go _ c = c -- Must be Tip (Nil is never a child of Bin) + -- | \(O(\min(n,W))\). Is the key a member of the map? -- -- > member 5 (fromList [(5,'a'), (3,'b')]) == True @@ -2500,6 +2521,16 @@ traverseWithKey f = go | otherwise = liftA2 (Bin p m) (go l) (go r) {-# INLINE traverseWithKey #-} +-- | \(O(n)\). Visit each key\/value pair in ascending key order, discarding +-- the results. +traverseWithKey_ :: Applicative t => (Key -> a -> t ()) -> Word64Map a -> t () +traverseWithKey_ f = go + where + go Nil = pure () + go (Tip k v) = f k v + go (Bin _ _ l r) = go l *> go r +{-# INLINE traverseWithKey_ #-} + -- | \(O(n)\). The function @'mapAccum'@ threads an accumulating -- argument through the map in ascending order of keys. -- ===================================== compiler/GHC/Data/Word64Map/Lazy.hs ===================================== @@ -113,6 +113,7 @@ module GHC.Data.Word64Map.Lazy ( -- ** Size , WM.null , size + , compareSize -- * Combine @@ -148,6 +149,7 @@ module GHC.Data.Word64Map.Lazy ( , WM.map , mapWithKey , traverseWithKey + , traverseWithKey_ , traverseMaybeWithKey , mapAccum , mapAccumWithKey ===================================== compiler/GHC/Data/Word64Map/Strict.hs ===================================== @@ -130,6 +130,7 @@ module GHC.Data.Word64Map.Strict ( -- ** Size , null , size + , compareSize -- * Combine @@ -165,6 +166,7 @@ module GHC.Data.Word64Map.Strict ( , map , mapWithKey , traverseWithKey + , traverseWithKey_ , traverseMaybeWithKey , mapAccum , mapAccumWithKey ===================================== compiler/GHC/Data/Word64Map/Strict/Internal.hs ===================================== @@ -132,6 +132,7 @@ module GHC.Data.Word64Map.Strict.Internal ( -- ** Size , null , size + , compareSize -- * Combine @@ -167,6 +168,7 @@ module GHC.Data.Word64Map.Strict.Internal ( , map , mapWithKey , traverseWithKey + , traverseWithKey_ , traverseMaybeWithKey , mapAccum , mapAccumWithKey @@ -322,12 +324,14 @@ import GHC.Data.Word64Map.Internal , spanAntitone , restrictKeys , size + , compareSize , split , splitLookup , splitRoot , toAscList , toDescList , toList + , traverseWithKey_ , union , unions , withoutKeys ===================================== 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/Types/Unique/DFM.hs ===================================== @@ -14,6 +14,9 @@ See Note [Unique Determinism] in GHC.Types.Unique for explanation why @Unique@ o is not deterministic. -} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + {-# OPTIONS_GHC -Wall #-} module GHC.Types.Unique.DFM ( @@ -79,6 +82,9 @@ import Data.Functor.Classes (Eq1 (..)) import Data.List (sortBy) import Data.Function (on) import GHC.Types.Unique.FM (UniqFM, nonDetUFMToList, ufmToIntMap, unsafeIntMapToUFM) +import GHC.Data.SmallArray +import GHC.Exts (State#, build) +import GHC.ST (ST(..), runST) import Unsafe.Coerce import qualified GHC.Data.Word64Set as W @@ -96,10 +102,10 @@ import qualified GHC.Data.Word64Set as W -- This means `alterUDFM` consistent with `addToUDFM` and `adjustUDFM`, -- so that for example `alterUDFM id k = id` and `alterUDFM (fmap f) k = adjustUDFM f k` -- --- There is an implementation cost: each element is given a serial number --- as it is added, and `udfmToList` sorts its result by this serial --- number. So you should only use `UniqDFM` if you need the deterministic --- property. +-- There is an implementation cost: each element is given an insertion tag +-- as it is added, and functions like `udfmToList` or `eltsUDFM` order their +-- results by this tag (see Note [Cost of deterministic iteration]). So you +-- should only use `UniqDFM` if you need the deterministic property. -- -- `foldUDFM` also preserves determinism. -- @@ -112,7 +118,7 @@ import qualified GHC.Data.Word64Set as W -- -- -- There's more than one way to implement this. The implementation here tags --- every value with the insertion time that can later be used to sort the +-- every value with its insertion tag that can later be used to sort the -- values when asked to convert to a list. -- -- Updating an existing key keeps the old tag. This keeps the order stable for @@ -125,7 +131,7 @@ import qualified GHC.Data.Word64Set as W -- -- An alternative would be to have -- --- data UniqDFM ele = UDFM (M.IntMap ele) [ele] +-- data UniqDFM ele = UDFM (Word64Map ele) [ele] -- -- where the list determines the order. This makes deletion tricky as we'd -- only accumulate elements in that list, but makes merging easier as you @@ -133,11 +139,11 @@ import qualified GHC.Data.Word64Set as W -- Deletion can probably be done in amortized fashion when the size of the -- list is twice the size of the set. --- | A type of values tagged with insertion time +-- | A type of values carrying an insertion tag data TaggedVal val = TaggedVal !val - {-# UNPACK #-} !Int -- ^ insertion time + {-# UNPACK #-} !Int -- ^ insertion tag deriving stock (Data, Functor, Foldable, Traversable) taggedFst :: TaggedVal val -> val @@ -159,18 +165,30 @@ instance Eq val => Eq (TaggedVal val) where data UniqDFM key ele = UDFM !(M.Word64Map (TaggedVal ele)) -- A map where keys are Unique's values and - -- values are tagged with insertion time. - -- The invariant is that all the tags will - -- be distinct within a single map - {-# UNPACK #-} !Int -- Upper bound on the values' insertion - -- time. See Note [Overflow on plusUDFM] + -- values carry an insertion tag. + {-# UNPACK #-} !Int -- Upper bound on the values' insertion + -- tags. See Note [Overflow on plusUDFM] + -- See Note [UDFM invariants] deriving (Data, Functor) --- | Deterministic, in O(n log n). +{- Note [UDFM invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~ +In a map (UDFM m ub): + + (a) The insertion tags of the elements of m are distinct. + (b) Every tag lies in [0, ub). + +Consequently ub >= size m. + +The tags determine the order of deterministic iteration (eltsUDFM, +udfmToList). See Note [Sorting a UDFM]. +-} + +-- | Deterministic. See Note [Cost of deterministic iteration]. instance Foldable (UniqDFM key) where foldr = foldUDFM --- | Deterministic, in O(n log n). +-- | Deterministic. See Note [Cost of deterministic iteration]. instance Traversable (UniqDFM key) where traverse f = fmap listToUDFM_Directly . traverse (\(u,a) -> (u,) <$> f a) @@ -264,8 +282,8 @@ plusUDFM_CK f udfml@(UDFM _ i) udfmr@(UDFM _ j) -- Note [Overflow on plusUDFM] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- There are multiple ways of implementing plusUDFM. --- The main problem that needs to be solved is overlap on times of --- insertion between different keys in two maps. +-- The main problem that needs to be solved is overlap on insertion +-- tags between different keys in two maps. -- Consider: -- -- A = fromList [(a, (x, 1))] @@ -325,13 +343,27 @@ elemUDFM :: Uniquable key => key -> UniqDFM key elt -> Bool elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m -- | Performs a deterministic fold over the UniqDFM. --- It's O(n log n) while the corresponding function on `UniqFM` is O(n). +-- +-- O(n) in the common case, with an O(n log n) fallback. +-- +-- See Note [Cost of deterministic iteration]. foldUDFM :: (elt -> a -> a) -> a -> UniqDFM key elt -> a {-# INLINE foldUDFM #-} --- This INLINE prevents a regression in !10568 -foldUDFM k z m = foldr k z (eltsUDFM m) - --- | Like 'foldUDFM' but the function also receives a key +-- Specialises k and z into M.foldr on the small-map path. +foldUDFM k z (UDFM m ub) + | M.compareSize m 1 /= GT = M.foldr (k . taggedFst) z m + | otherwise = fold_udfm k z m ub + +fold_udfm :: (elt -> a -> a) -> a -> M.Word64Map (TaggedVal elt) -> Int -> a +{-# NOINLINE fold_udfm #-} +-- Kept out of line so that foldUDFM's consumers don't inline the sort machinery. +fold_udfm k z m ub + | usePigeonholeSort m ub = foldr k z (pigeonholeSort ub (\_ tv -> tv) m) + | otherwise = foldr k z (map taggedFst (sort_it m)) + +-- | Like 'foldUDFM' but the function also receives a key. +-- +-- See Note [Cost of deterministic iteration]. foldWithKeyUDFM :: (Unique -> elt -> a -> a) -> a -> UniqDFM key elt -> a {-# INLINE foldWithKeyUDFM #-} -- This INLINE was copied from foldUDFM @@ -346,14 +378,113 @@ nonDetStrictFoldUDFM k z (UDFM m _i) = foldl' k' z m where k' acc (TaggedVal v _) = k v acc +{- Note [Cost of deterministic iteration] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Deterministic iteration -- foldUDFM, eltsUDFM, udfmToList, and everything +built on them -- orders elements by insertion tag. The element with the +smallest tag can sit anywhere in the map, so every tag must be inspected, +and, given a @UDFM m ub@ on the pigeonhole-sort path, an array with ub slots +must be filled, before the first element can be emitted (see +Note [Sorting a UDFM]). So beyond maps of a single element, deterministic +iteration cannot stream: demanding any of the result processes the whole +map. #27459 shows that cost hitting a consumer that only needed to know +whether the result was non-empty. + +So: to test for emptiness, use isNullUDFM rather than null on eltsUDFM; +for order-oblivious queries, prefer short-circuiting anyUDFM/allUDFM; and +if you don't need the deterministic order at all, use nonDetStrictFoldUDFM. +-} + +-- | Deterministic, in order of insertion. +-- +-- See Note [Sorting a UDFM] and Note [Cost of deterministic iteration]. eltsUDFM :: UniqDFM key elt -> [elt] -{-# INLINE eltsUDFM #-} --- The INLINE makes it a good producer (from the map) -eltsUDFM (UDFM m _i) = map taggedFst (sort_it m) +{-# INLINE eltsUDFM #-} -- so the small case is a good producer + -- This matters for T13719. +eltsUDFM (UDFM m ub) + | M.compareSize m 1 /= GT = build (\c n -> M.foldr (c . taggedFst) n m) + | otherwise = elts_udfm m ub + +elts_udfm :: M.Word64Map (TaggedVal elt) -> Int -> [elt] +{-# NOINLINE elts_udfm #-} +-- Kept out of line so that eltsUDFM's consumers don't inline the sort machinery. +elts_udfm m ub + | usePigeonholeSort m ub = pigeonholeSort ub (\_ tv -> tv) m + | otherwise = map taggedFst (sort_it m) sort_it :: M.Word64Map (TaggedVal elt) -> [TaggedVal elt] sort_it m = sortBy (compare `on` taggedSnd) (M.elems m) + +{- Note [Sorting a UDFM] +~~~~~~~~~~~~~~~~~~~~~~~~ +Deterministic iteration must yield a map's elements in order of their +insertion tags. The obvious way is to sort on the tags, but we can do better: +in (UDFM m ub) the tags are distinct indices into [0, ub) (see +Note [UDFM invariants]), so each element can simply be placed at its own +tag in an ub-slot array, which is then read back in index order. This is +pigeonhole sort, with one element per hole. + +Cost: writing the elements is O(n) for n = M.size m, while allocating the +array and reading it back are O(ub). Since n <= ub the total is O(ub). No +comparisons are made. + +So the method wins only while the array stays dense, and ub never shrinks +(overwrites keep bumping it, delete/filter shrink n but not ub). +usePigeonholeSort therefore takes this path only when ub <= 4 * n, which +bounds its cost at O(n), and falls back to the O(n log n) comparison sort +otherwise. + +Unfilled slots contain a TaggedVal with tag -1 and value +@unsafeCoerce () :: r@. This is safe because the value is never used: only +slots with non-negative tags are read. + +pigeonholeSort also avoids intermediate lists: it fills the array by +traversing the map directly, and emits its readout with 'build', so the foldr +in fold_udfm fuses with it. This contributes significantly to the allocation +reductions in InstanceMatching1 in !16292. +-} + +-- | @ub <= 4 * size m@, computed without a full 'M.size' traversal. +usePigeonholeSort :: M.Word64Map a -> Int -> Bool +usePigeonholeSort m ub = M.compareSize m ceil_ub_div_4 /= LT + where + ceil_ub_div_4 = (ub + 3) `div` 4 -- ceil(ub/4): ub <= 4*n iff n >= ceil(ub/4) + +-- | Order the map's elements by tag. The tags must be distinct and in +-- @[0, ub)@, and @mk@ must preserve them. See Note [Sorting a UDFM]. +pigeonholeSort :: forall e r. Int + -> (M.Key -> TaggedVal e -> TaggedVal r) + -> M.Word64Map (TaggedVal e) + -> [r] +{-# INLINE pigeonholeSort #-} -- Specialise mk and enable foldr/build fusion. +pigeonholeSort ub mk m = build gen + where + -- The tag -1 marks unfilled slots; the value field is never read, but it + -- is strict, so it needs a WHNF value of type r. See Note [Sorting a UDFM]. + hole :: TaggedVal r + hole = TaggedVal (unsafeCoerce ()) (-1) + + fill :: SmallMutableArray s (TaggedVal r) -> State# s -> (# State# s, () #) + fill marr s = case M.traverseWithKey_ write m of ST st -> st s + where + write k tv = ST (\s' -> + (# writeSmallArray marr (taggedSnd tv) (mk k tv) s', () #)) + + gen :: forall b. (r -> b -> b) -> b -> b + gen cons nil = runST (ST (\s0 -> + case newSmallArray ub hole s0 of + (# s1, marr #) -> case fill marr s1 of + (# s2, () #) -> case unsafeFreezeSmallArray marr s2 of + (# s3, arr #) -> (# s3, readout arr 0 #))) + where + readout :: SmallArray (TaggedVal r) -> Int -> b + readout arr j + | j >= ub = nil + | t < 0 = readout arr (j + 1) + | otherwise = cons v (readout arr (j + 1)) + where TaggedVal v t = indexSmallArray arr j + filterUDFM :: (elt -> Bool) -> UniqDFM key elt -> UniqDFM key elt filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i @@ -371,11 +502,22 @@ udfmRestrictKeysSet (UDFM val_set i) set = in UDFM (M.restrictKeys val_set key_set) i -- | Converts `UniqDFM` to a list, with elements in deterministic order. --- It's O(n log n) while the corresponding function on `UniqFM` is O(n). +-- +-- O(n) in the common case, with an O(n log n) fallback. +-- +-- See Note [Cost of deterministic iteration]. udfmToList :: UniqDFM key elt -> [(Unique, elt)] -udfmToList (UDFM m _i) = - [ (mkUniqueGrimily k, taggedFst v) - | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ] +-- NB: no INLINE, unlike eltsUDFM. udfmToList's one hot consumer is +-- traverseUSDFM in the pattern-match checker, which doesn't fuse. Inlining +-- the size dispatch into it regresses T17836. +udfmToList (UDFM m ub) + | M.compareSize m 1 /= GT = + M.foldrWithKey (\k tv r -> (mkUniqueGrimily k, taggedFst tv) : r) [] m + | usePigeonholeSort m ub = pigeonholeSort ub + (\k tv -> TaggedVal (mkUniqueGrimily k, taggedFst tv) (taggedSnd tv)) m + | otherwise = + [ (mkUniqueGrimily k, taggedFst v) + | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ] -- Determines whether two 'UniqDFM's contain the same keys. equalKeysUDFM :: UniqDFM key a -> UniqDFM key b -> Bool ===================================== 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/a39e93e5f8141c0fd43631fba3fd055... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a39e93e5f8141c0fd43631fba3fd055... 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