[Git][ghc/ghc][wip/sjakobi/udfm-placement] 9 commits: testsuite: Don't crash on non-UTF-8 test output
by Simon Jakobi (＠sjakobi) 05 Aug '26
by Simon Jakobi (＠sjakobi) 05 Aug '26
05 Aug '26
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/a39e93e5f8141c0fd43631fba3fd05…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a39e93e5f8141c0fd43631fba3fd05…
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
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
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.
- - - - -
5 changed files:
- + 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
Changes:
=====================================
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, [''])
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/70b58c8f5a8ffa937bb3435610b038d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/70b58c8f5a8ffa937bb3435610b038d…
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][master] EPA: Remove LocatedP, last use in WarningTxt
by Marge Bot (＠marge-bot) 05 Aug '26
by Marge Bot (＠marge-bot) 05 Aug '26
05 Aug '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
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
- - - - -
9 changed files:
- 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
- utils/check-exact/ExactPrint.hs
Changes:
=====================================
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
=====================================
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/-/commit/b14d8d59d50527c8b396a3b768d6b92…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b14d8d59d50527c8b396a3b768d6b92…
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
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
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.
- - - - -
2 changed files:
- + testsuite/tests/th/T20902.hs
- testsuite/tests/th/all.T
Changes:
=====================================
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, [''])
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/126ce57446ac9afd3f095b3e539f074…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/126ce57446ac9afd3f095b3e539f074…
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][master] base: Don't drop exception context in SomeException(toException)
by Marge Bot (＠marge-bot) 05 Aug '26
by Marge Bot (＠marge-bot) 05 Aug '26
05 Aug '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
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
- - - - -
5 changed files:
- + changelog.d/T27455
- libraries/base/changelog.md
- libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs
- testsuite/tests/ghc-e/should_fail/T18441fail7.stderr
- testsuite/tests/ghc-e/should_run/ghc-e005.stderr
Changes:
=====================================
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>`.
+
=====================================
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/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
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2ab02c579a9625438f5281a258051cb…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2ab02c579a9625438f5281a258051cb…
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][master] 3 commits: testsuite: Don't crash on non-UTF-8 test output
by Marge Bot (＠marge-bot) 05 Aug '26
by Marge Bot (＠marge-bot) 05 Aug '26
05 Aug '26
Marge Bot pushed to branch master 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
- - - - -
4 changed files:
- .gitlab/ci.sh
- testsuite/driver/runtests.py
- testsuite/driver/term_color.py
- testsuite/driver/testlib.py
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=""
=====================================
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:
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d415f38a75cc88921a344220ad2eed…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d415f38a75cc88921a344220ad2eed…
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/jeltsch/textual-bytecode-output] 2 commits: Make final corrections and improvements
by Wolfgang Jeltsch (＠jeltsch) 05 Aug '26
by Wolfgang Jeltsch (＠jeltsch) 05 Aug '26
05 Aug '26
Wolfgang Jeltsch pushed to branch wip/jeltsch/textual-bytecode-output at Glasgow Haskell Compiler / GHC
Commits:
973d8aaa by Wolfgang Jeltsch at 2026-08-05T20:20:22+03:00
Make final corrections and improvements
- - - - -
01ff2ea4 by Wolfgang Jeltsch at 2026-08-05T20:29:43+03:00
Change the `emsdk` test output name suffix to `wasi`
- - - - -
6 changed files:
- compiler/GHC/ByteCode/Show.hs
- testsuite/tests/show-bytecode/Example.hs
- testsuite/tests/show-bytecode/normalize
- testsuite/tests/show-bytecode/show-bytecode-breakpoints.stdout-ghcjs → testsuite/tests/show-bytecode/show-bytecode-breakpoints.stdout-wasi
- testsuite/tests/show-bytecode/show-bytecode-hpc.stdout-ghcjs → testsuite/tests/show-bytecode/show-bytecode-hpc.stdout-wasi
- testsuite/tests/show-bytecode/show-bytecode-vanilla.stdout-ghcjs → testsuite/tests/show-bytecode/show-bytecode-vanilla.stdout-wasi
Changes:
=====================================
compiler/GHC/ByteCode/Show.hs
=====================================
@@ -6,6 +6,9 @@
-- of bytecode files. It is the backbone of the @--show-byte-code@ option.
module GHC.ByteCode.Show (showByteCode) where
+-- The output generated by 'showByteCode' shall follow some general guidelines.
+-- See Note [Guidelines for the output of @--show-byte-code@] for details.
+
-- Prelude
import GHC.Prelude
@@ -35,28 +38,29 @@ import GHC.Data.FastString (unpackFS)
import GHC.Data.FlatBag (FlatBag, elemsFlatBag)
import GHC.Fingerprint (Fingerprint)
import GHC.Types.SrcLoc (noSrcSpan)
-import GHC.Types.Name (Name, nameOccName)
-import GHC.Types.Name.Occurrence (OccName, isSymOcc)
+import GHC.Types.Name (Name)
+import GHC.Types.Name.Occurrence (OccName, HasOccName, occName, parenSymOcc)
import GHC.Types.Tickish (BreakTickIndex, BreakpointId (..))
import GHC.Types.SptEntry (SptEntry (..))
import GHC.Types.Error (MessageClass (MCDump))
import GHC.Utils.Panic.Plain (assert)
+import GHC.Utils.Encoding.UTF8 (utf8DecodeShortByteString, utf8DecodeByteString)
import GHC.Utils.Logger (Logger, logMsg)
import GHC.Utils.Binary (BinSrcSpan (..))
-import GHC.Utils.Encoding.UTF8 (utf8DecodeShortByteString, utf8DecodeByteString)
import GHC.Utils.Outputable
(
+ Outputable,
defaultDumpStyle,
SDoc,
text,
(<>),
(<+>),
- quotes,
hsep,
+ quotes,
vcat,
hang,
- withPprStyle,
- ppr
+ ppr,
+ withPprStyle
)
import GHC.Unit.Types (Module, moduleName)
import GHC.Iface.Type (IfaceType, IfaceTvBndr, IfaceIdBndr)
@@ -68,6 +72,7 @@ import Language.Haskell.Syntax.Module.Name (moduleNameString)
-- Basic things
import Control.Arrow ((>>>))
+import Data.Bool (bool)
import Data.List (zipWith4)
import Data.ByteString (ByteString)
import Data.ByteString.Short (ShortByteString)
@@ -101,9 +106,9 @@ rules:
literals are output without quotes, because they stick out by themselves.
* Infix operators are output with parentheses around them. To ensure that this
- is always the case, all textual representations of names are generated using
- the 'pprName' operation, defined in this module, instead of the 'ppr'
- operation.
+ is always the case, all textual representations of 'OccName' and 'Name'
+ values are generated using the 'pprNameProperly' operation, defined in this
+ module, instead of the 'pprNameProperly' operation.
-}
@@ -115,8 +120,6 @@ showByteCode logger env path = do
MCDump
noSrcSpan
(withPprStyle defaultDumpStyle $ pprOnDiskModuleByteCode byteCode)
--- The output generated by 'showByteCode' shall follow some general guidelines.
--- See Note [Guidelines for the output of @--show-byte-code@] for details.
-- | Constructs textual information about the contents of a bytecode file.
pprOnDiskModuleByteCode :: OnDiskModuleByteCode -> SDoc
@@ -139,48 +142,48 @@ pprOnDiskModuleByteCodeHash = entry (text "hash") . ppr
pprCompiledByteCode :: Module -- ^ The enclosing module
-> CompiledByteCode -- ^ The bytecode
-> SDoc -- ^ The textual information
-pprCompiledByteCode current_module CompiledByteCode {..}
+pprCompiledByteCode enclosing_module CompiledByteCode {..}
= vcat [
- pprByteCodeObjects current_module $ bc_bcos,
- pprDataConstructorInfoTables $ bc_itbls,
- pprTopLevelStrings $ bc_strs,
- pprBreakpoints current_module $ bc_breaks,
- pprStaticPointerTableEntries $ bc_spt_entries,
- pprHPCInfo current_module $ bc_hpc_info
+ pprByteCodeObjects enclosing_module $ bc_bcos,
+ pprDataConstructorInfoTables $ bc_itbls,
+ pprTopLevelStrings $ bc_strs,
+ pprBreakpoints enclosing_module $ bc_breaks,
+ pprStaticPointerTableEntries $ bc_spt_entries,
+ pprHPCInfo enclosing_module $ bc_hpc_info
]
-- | Constructs textual information about bytecode objects.
pprByteCodeObjects :: Module -- ^ The enlosing module
-> FlatBag UnlinkedBCO -- ^ The bytecode objects
-> SDoc -- ^ The textual information
-pprByteCodeObjects current_module = entry (text "objects") .
- vcatOrNone .
- map (pprByteCodeObject current_module) .
- elemsFlatBag
+pprByteCodeObjects enclosing_module = entry (text "objects") .
+ vcatOrNone .
+ map (pprByteCodeObject enclosing_module) .
+ elemsFlatBag
-- | Constructs textual information about a single bytecode object.
pprByteCodeObject :: Module -- ^ The enclosing module
-> UnlinkedBCO -- ^ The bytecode object
-> SDoc -- ^ The textual information
-pprByteCodeObject current_module byte_code_object = case byte_code_object of
+pprByteCodeObject enclosing_module byte_code_object = case byte_code_object of
UnlinkedBCO {..}
- -> entry (text "object" <+> quotes (pprName unlinkedBCOName)) $
+ -> entry (text "object" <+> quotes (pprNameProperly unlinkedBCOName)) $
vcat [
- pprArity $ unlinkedBCOArity,
- pprLiterals current_module $ unlinkedBCOLits,
- pprUsedItems current_module $ unlinkedBCOPtrs
+ pprArity $ unlinkedBCOArity,
+ pprLiterals enclosing_module $ unlinkedBCOLits,
+ pprUsedItems enclosing_module $ unlinkedBCOPtrs
]
UnlinkedStaticCon {..}
-> entry (
text "static-construction object" <+>
- quotes (pprName unlinkedStaticConName)
+ quotes (pprNameProperly unlinkedStaticConName)
)
$
vcat [
- pprDataConstructor $ unlinkedStaticConDataConName,
- pprLiftedness $ not unlinkedStaticConIsUnlifted,
- pprLiterals current_module $ unlinkedStaticConLits,
- pprUsedItems current_module $ unlinkedStaticConPtrs
+ pprDataConstructor $ unlinkedStaticConDataConName,
+ pprLiftedness $ not unlinkedStaticConIsUnlifted,
+ pprLiterals enclosing_module $ unlinkedStaticConLits,
+ pprUsedItems enclosing_module $ unlinkedStaticConPtrs
]
-- | Constructs textual information about the arity of a bytecode object.
@@ -190,7 +193,7 @@ pprArity = entry (text "arity") . ppr
-- | Constructs textual information about the data constructor of a
-- static-construction bytecode object.
pprDataConstructor :: Name -> SDoc
-pprDataConstructor = entry (text "data constructor") . pprName
+pprDataConstructor = entry (text "data constructor") . pprNameProperly
-- | Constructs textual information about the liftedness of a
-- static-construction bytecode object.
@@ -201,16 +204,16 @@ pprLiftedness = entry (text "lifted") . noOrYes
pprLiterals :: Module -- ^ The enclosing module
-> FlatBag BCONPtr -- ^ The literals
-> SDoc -- ^ The textual information
-pprLiterals current_module = entry (text "literals") .
- vcatOrNone .
- map (pprLiteral current_module) .
- elemsFlatBag
+pprLiterals enclosing_module = entry (text "literals") .
+ vcatOrNone .
+ map (pprLiteral enclosing_module) .
+ elemsFlatBag
-- | Constructs textual information about a single literal.
pprLiteral :: Module -- ^ The enclosing module
-> BCONPtr -- ^ The literal
-> SDoc -- ^ The textual information
-pprLiteral current_module literal = case literal of
+pprLiteral enclosing_module literal = case literal of
BCONPtrWord word
-> text "word" <+>
ppr word
@@ -219,10 +222,10 @@ pprLiteral current_module literal = case literal of
quotes (ppr label)
BCONPtrItbl infoTableName
-> text "info table of" <+>
- quotes (pprName infoTableName)
+ quotes (pprNameProperly infoTableName)
BCONPtrAddr addrName
-> text "address" <+>
- quotes (pprName addrName)
+ quotes (pprNameProperly addrName)
BCONPtrStr encoded_string
-> text "top-level string" <+>
text (show (utf8DecodeByteString encoded_string))
@@ -234,7 +237,7 @@ pprLiteral current_module literal = case literal of
quotes (pprFFIInfo ffiInfo)
BCONPtrCostCentre breakpointID
-> text "cost center of breakpoint" <+>
- pprInternalBreakpointID current_module breakpointID
+ pprInternalBreakpointID enclosing_module breakpointID
-- | Constructs textual information about FFI info.
pprFFIInfo :: FFIInfo -> SDoc
@@ -254,11 +257,11 @@ pprInternalBreakpointID
:: Module -- ^ The enclosing module
-> InternalBreakpointId -- ^ The ID of the bytecode breakpoint
-> SDoc -- ^ The textual information
-pprInternalBreakpointID current_module InternalBreakpointId {..}
- | ibi_info_mod == current_module = index_doc
- | otherwise = index_doc <+>
- text "in" <+>
- quotes (ppr ibi_info_mod)
+pprInternalBreakpointID enclosing_module InternalBreakpointId {..}
+ | ibi_info_mod == enclosing_module = index_doc
+ | otherwise = index_doc <+>
+ text "in" <+>
+ quotes (ppr ibi_info_mod)
where
index_doc :: SDoc
@@ -268,22 +271,22 @@ pprInternalBreakpointID current_module InternalBreakpointId {..}
pprUsedItems :: Module -- ^ The enclosing module
-> FlatBag BCOPtr -- ^ The used items
-> SDoc -- ^ The textual information
-pprUsedItems current_module = entry (text "used items") .
- vcatOrNone .
- map (pprUsedItem current_module) .
- elemsFlatBag
+pprUsedItems enclosing_module = entry (text "used items") .
+ vcatOrNone .
+ map (pprUsedItem enclosing_module) .
+ elemsFlatBag
-- | Constructs textual information about a single used item.
pprUsedItem :: Module -- ^ The enclosing module
-> BCOPtr -- ^ The used item
-> SDoc -- ^ The textual information
-pprUsedItem current_module usedItem = case usedItem of
+pprUsedItem enclosing_module used_item = case used_item of
BCOPtrName name
- -> text "named item" <+> quotes (pprName name)
+ -> text "named item" <+> quotes (pprNameProperly name)
BCOPtrPrimOp primOp
-> text "primitive operation" <+> quotes (ppr primOp)
BCOPtrBCO byte_code_object
- -> pprByteCodeObject current_module byte_code_object
+ -> pprByteCodeObject enclosing_module byte_code_object
BCOPtrBreakArray breakArrayModule
-> text "break array of module" <+> quotes (ppr breakArrayModule)
@@ -295,8 +298,8 @@ pprDataConstructorInfoTables = entry (text "data constructor info tables") .
-- | Constructs textual information about a single data constructor info table.
pprDataConstructorInfoTable :: Name -> ConInfoTable -> SDoc
-pprDataConstructorInfoTable dataConstrName ConInfoTable {..}
- = entry (text "info table of" <+> quotes (pprName dataConstrName)) $
+pprDataConstructorInfoTable data_constr_name ConInfoTable {..}
+ = entry (text "info table of" <+> quotes (pprNameProperly data_constr_name)) $
vcat [
pprPointerWordCount $ conItblPtrs,
pprNonPointerWordCount $ conItblNPtrs
@@ -318,37 +321,38 @@ pprTopLevelStrings = entry (text "top-level strings") .
-- | Constructs textual information about a single top-level string.
pprTopLevelString :: Name -> ByteString -> SDoc
-pprTopLevelString string_name encoded_string = entry (pprName string_name) $
- text $
- show $
- utf8DecodeByteString $
- encoded_string
+pprTopLevelString string_name encoded_string
+ = entry (pprNameProperly string_name) $
+ text $
+ show $
+ utf8DecodeByteString $
+ encoded_string
-- | Constructs textual information about breakpoints.
pprBreakpoints :: Module -- ^ The enclosing module
-> Maybe InternalModBreaks -- ^ The breakpoints
-> SDoc -- ^ The textual information
-pprBreakpoints current_module
+pprBreakpoints enclosing_module
= entry (text "breakpoints") .
- maybe (text "<none>") (pprActualBreakpoints current_module)
+ maybe (text "<none>") (pprActualBreakpoints enclosing_module)
-- | Constructs textual information about actual breakpoints.
pprActualBreakpoints :: Module -- ^ The enclosing module
-> InternalModBreaks -- ^ The actual breakpoints
-> SDoc -- ^ The textual information
-pprActualBreakpoints current_module InternalModBreaks {..}
+pprActualBreakpoints enclosing_module InternalModBreaks {..}
= vcat [
- pprSourceBreakpoints current_module $ imodBreaks_modBreaks,
- pprByteCodeBreakpoints current_module $ imodBreaks_breakInfo
+ pprSourceBreakpoints enclosing_module $ imodBreaks_modBreaks,
+ pprByteCodeBreakpoints enclosing_module $ imodBreaks_breakInfo
]
-- | Constructs textual information about source breakpoints.
pprSourceBreakpoints :: Module -- ^ The enclosing module
-> ModBreaks -- ^ The source breakpoints
-> SDoc -- ^ The textual information
-pprSourceBreakpoints current_module ModBreaks {..}
+pprSourceBreakpoints enclosing_module ModBreaks {..}
= entry (text "source breakpoints") $
- assert (modBreaks_module == current_module) $
+ assert (modBreaks_module == enclosing_module) $
assert (bounds modBreaks_locs_ == bounds modBreaks_decls) $
assert (bounds modBreaks_locs_ == bounds modBreaks_vars) $
vcatOrNone $
@@ -361,39 +365,43 @@ pprSourceBreakpoints current_module ModBreaks {..}
-- the source spans in 'modBreaks_locs_' and are therefore never shown.
-- | Constructs textual information about a single source breakpoint.
-pprSourceBreakpoint :: BreakTickIndex
- -> BinSrcSpan
- -> [String]
- -> [OccName]
- -> SDoc
-pprSourceBreakpoint ix srcSpan declarationPath freeVars
+pprSourceBreakpoint
+ :: BreakTickIndex -- ^ The index of the source breakpoint
+ -> BinSrcSpan -- ^ The source span of the source breakpoint
+ -> [String] -- ^ The names declared by the surrounding declarations
+ -> [OccName] -- ^ The free variables of the source breakpoint
+ -> SDoc -- ^ The textual information
+pprSourceBreakpoint ix src_span declaration_path free_vars
= entry (text "source breakpoint" <+> ppr ix) $
vcat [
- pprSrcSpan $ srcSpan,
- pprDeclarationPath $ declarationPath,
- pprFreeVariables $ freeVars
+ pprSrcSpan $ src_span,
+ pprDeclarationPath $ declaration_path,
+ pprFreeVariables $ free_vars
]
-- | Constructs textual information about a source span.
pprSrcSpan :: BinSrcSpan -> SDoc
pprSrcSpan = entry (text "source span") . ppr . unBinSrcSpan
--- | Constructs textual information about a declaration path.
+-- | Constructs textual information about a declaration path, which is the list
+-- of names declared by the declarations surrounding a source breakpoint.
pprDeclarationPath :: [String] -> SDoc
pprDeclarationPath = entry (text "declaration path") . vcatOrEmpty . map text
-- | Constructs textual information about free variables.
pprFreeVariables :: [OccName] -> SDoc
-pprFreeVariables = entry (text "free variables") . vcatOrNone . map ppr
+pprFreeVariables = entry (text "free variables") .
+ vcatOrNone .
+ map pprNameProperly
-- | Constructs textual information about bytecode breakpoints.
pprByteCodeBreakpoints :: Module -- ^ The enclosing module
-> IntMap CgBreakInfo -- ^ The bytecode breakpoints
-> SDoc -- ^ The textual information
-pprByteCodeBreakpoints current_module
- = entry (text "bytecode breakpoints") .
- vcatOrNone .
- map (uncurry (pprByteCodeBreakpoint current_module)) .
+pprByteCodeBreakpoints enclosing_module
+ = entry (text "bytecode breakpoints") .
+ vcatOrNone .
+ map (uncurry (pprByteCodeBreakpoint enclosing_module)) .
IntMap.toList
-- | Constructs textual information about a single bytecode breakpoint.
@@ -401,13 +409,13 @@ pprByteCodeBreakpoint :: Module -- ^ The enclosing module
-> Int -- ^ The index of the bytecode breakpoint
-> CgBreakInfo -- ^ The bytecode breakpoint
-> SDoc -- ^ The textual information
-pprByteCodeBreakpoint current_module ix CgBreakInfo {..}
+pprByteCodeBreakpoint enclosing_module ix CgBreakInfo {..}
= entry (text "bytecode breakpoint" <+> ppr ix) $
vcat [
- pprType $ cgb_resty,
- pprTypeVariables $ cgb_tyvars,
- pprVariables $ cgb_vars,
- pprCorrespondingSourceBreakpoint current_module $ cgb_tick_id
+ pprType $ cgb_resty,
+ pprTypeVariables $ cgb_tyvars,
+ pprVariables $ cgb_vars,
+ pprCorrespondingSourceBreakpoint enclosing_module $ cgb_tick_id
]
-- That the 'cgb_resty' field holds the type of the breakpoint is apparent
-- from the fact that this field is set by
@@ -453,20 +461,20 @@ pprCorrespondingSourceBreakpoint :: Module
-- ^ A reference to the source breakpoint
-> SDoc
-- ^ The textual information
-pprCorrespondingSourceBreakpoint current_module
+pprCorrespondingSourceBreakpoint enclosing_module
= entry (text "corresponding source breakpoint") .
- pprBreakpointID current_module .
+ pprBreakpointID enclosing_module .
either internalBreakLoc id
-- | Constructs textual information about the ID of a source breakpoint.
pprBreakpointID :: Module -- ^ The enclosing module
-> BreakpointId -- ^ The ID of the source breakpoint
-> SDoc -- ^ The textual information
-pprBreakpointID current_module BreakpointId {..}
- | bi_tick_mod == current_module = index_doc
- | otherwise = index_doc <+>
- text "in" <+>
- quotes (ppr bi_tick_mod)
+pprBreakpointID enclosing_module BreakpointId {..}
+ | bi_tick_mod == enclosing_module = index_doc
+ | otherwise = index_doc <+>
+ text "in" <+>
+ quotes (ppr bi_tick_mod)
where
index_doc :: SDoc
@@ -481,25 +489,25 @@ pprStaticPointerTableEntries = entry (text "static-pointer table entries") .
-- | Constructs textual information about a single static-pointer table entry.
pprStaticPointerTableEntry :: SptEntry -> SDoc
pprStaticPointerTableEntry (SptEntry name fingerprint)
- = ppr fingerprint <> text ":" <+> pprName name
+ = entry (ppr fingerprint) (pprNameProperly name)
-- | Constructs textual information about HPC info.
pprHPCInfo :: Module -- ^ The enclosing module
-> Strict.Maybe ByteCodeHpcInfo -- ^ The HPC info
-> SDoc -- ^ The textual information
-pprHPCInfo current_module
+pprHPCInfo enclosing_module
= entry (text "HPC information") .
- Strict.maybe (text "<none>") (pprActualHPCInfo current_module)
+ Strict.maybe (text "<none>") (pprActualHPCInfo enclosing_module)
-- | Constructs textual information about actual HPC info.
pprActualHPCInfo :: Module -- ^ The enclosing module
-> ByteCodeHpcInfo -- ^ The actual HPC info
-> SDoc -- ^ The textual information
-pprActualHPCInfo current_module ByteCodeHpcInfo {..}
+pprActualHPCInfo enclosing_module ByteCodeHpcInfo {..}
= assert (
utf8DecodeShortByteString bchi_module_name
==
- moduleNameString (moduleName current_module)
+ moduleNameString (moduleName enclosing_module)
)
$
vcat [
@@ -516,14 +524,15 @@ pprHPCInfoHash = entry (text "hash") . pprFixedSizeNatural . intToWord
pprTickBox :: ShortByteString -> SDoc
pprTickBox = entry (text "tick box") . text . utf8DecodeShortByteString
--- | Constructs textual information about a number of tick counts.
+-- | Constructs textual information about a number of ticks.
pprTickCount :: Int -> SDoc
pprTickCount = entry (text "number of ticks") . ppr
--- | Constructs the Haskell representation of a name.
-pprName :: Name -> SDoc
-pprName name | isSymOcc (nameOccName name) = text "(" <> ppr name <> text ")"
- | otherwise = ppr name
+-- | Constructs the Haskell representation of a name. This includes putting
+-- parentheses around operators. The given name is supposed to be of type
+-- 'OccName' or 'Name'.
+pprNameProperly :: (HasOccName a, Outputable a) => a -> SDoc
+pprNameProperly name = parenSymOcc (occName name) (ppr name)
-- | Constructs a hexadecimal representation of a natural number such that the
-- number of hexadecimal digits fits the number of bits used to represent the
@@ -547,22 +556,22 @@ intToWord (I# int#) = W# (int2Word# int#)
-- | Constructs a textual representation of a boolean, interpreting 'True' and
-- 'False' as “yes” and “no”, respectively.
noOrYes :: Bool -> SDoc
-noOrYes bool = text (if bool then "yes" else "no")
+noOrYes = text . bool "no" "yes"
-- | Constructs an entry in a list of textual data representations.
entry :: SDoc -- ^ The title of the entry
-> SDoc -- ^ The contents of the entry
-> SDoc -- ^ The entry
-entry title content = hang (title <> text ":") 2 content
+entry title contents = hang (title <> text ":") 2 contents
-- | Composes documents vertically in general, but presents an empty document
--- list as `<none`>.
+-- list as @<none>@.
vcatOrNone :: [SDoc] -> SDoc
vcatOrNone [] = text "<none>"
vcatOrNone docs = vcat docs
-- | Composes documents vertically in general, but presents an empty document
--- list as `<empty`>.
+-- list as @<empty>@.
vcatOrEmpty :: [SDoc] -> SDoc
vcatOrEmpty [] = text "<empty>"
vcatOrEmpty docs = vcat docs
=====================================
testsuite/tests/show-bytecode/Example.hs
=====================================
@@ -12,9 +12,9 @@
module Example where
import Numeric.Natural (Natural)
-import GHC.StaticPtr (StaticPtr)
-import Foreign.C.Types (CChar, CSize (CSize))
import Foreign.Ptr (Ptr)
+import Foreign.C.Types (CChar, CSize (CSize))
+import GHC.StaticPtr (StaticPtr)
fibonaccis :: [Natural]
fibonaccis = 0 : positiveFibonaccis where
=====================================
testsuite/tests/show-bytecode/normalize
=====================================
@@ -6,9 +6,9 @@ stabilize ()
{
sed -E -e '
s/_r[[:alnum:]]+/_@name_suffix@/g
- s/^( *hash: )[[:xdigit:]]+/\1@hash@/g
- s/^( *)[[:xdigit:]]+:/\1@hash@:/g
- s/word [[:digit:]]{2}[[:digit:]]*/word @large_word@/
+ s/^( *hash: )[[:xdigit:]]+/\1@hash@/
+ s/^( *)[[:xdigit:]]+:/\1@hash@:/
+ s/word [[:digit:]]{2}[[:digit:]]*/word @large_word@/g
'
}
=====================================
testsuite/tests/show-bytecode/show-bytecode-breakpoints.stdout-ghcjs → testsuite/tests/show-bytecode/show-bytecode-breakpoints.stdout-wasi
=====================================
=====================================
testsuite/tests/show-bytecode/show-bytecode-hpc.stdout-ghcjs → testsuite/tests/show-bytecode/show-bytecode-hpc.stdout-wasi
=====================================
=====================================
testsuite/tests/show-bytecode/show-bytecode-vanilla.stdout-ghcjs → testsuite/tests/show-bytecode/show-bytecode-vanilla.stdout-wasi
=====================================
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2471d88d1fe2faa4cc1aac0597d1fd…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2471d88d1fe2faa4cc1aac0597d1fd…
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
05 Aug '26
Simon Jakobi pushed new branch wip/sjakobi/slide-debug at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sjakobi/slide-debug
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
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
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