[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
[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:
961ca176 by mangoiv at 2026-08-05T11:58:35+02:00
compiler: refactor truncation to be able to control whether or not registers are alloated
- - - - -
1 changed file:
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
Changes:
=====================================
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
=====================================
@@ -1,5 +1,8 @@
{-# language GADTs, LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
module GHC.CmmToAsm.AArch64.CodeGen (
cmmTopCodeGen
@@ -923,18 +926,23 @@ getRegister' config plat expr
-- XX Conversion
CmmMachOp (MO_XX_Conv from to) [e] -> do
register <- getRegister e
- if to >= W32 || to > from
- then case register of
- -- Reuse computation, casting width.
- Any _fmt code -> pure $ Any (intFormat to) code
- Fixed _fmt reg code -> pure $ Fixed (intFormat to) reg code
- else case register of
- Any _fmt code ->
- pure $ Any (intFormat to) $ \dst -> do
- code dst `appOL` truncateSubwordRegInplace to dst
- Fixed _fmt reg code -> do
- (trunc_reg, trunc_code) <- truncateSubwordReg to reg
- pure $ Fixed (intFormat to) trunc_reg (code `appOL` trunc_code)
+ -- if to >= W32 || to > from
+ -- -- don't do anything in the word case or
+ -- -- when the target register width is larger
+ -- -- than the origin register width; e.g.
+ -- -- mangoiv: what we the tradeoff to not truncate here, too?
+ -- then case register of
+ -- -- Reuse computation, casting width.
+ -- Any _fmt code -> pure $ Any (intFormat to) code
+ -- Fixed _fmt reg code -> pure $ Fixed (intFormat to) reg code
+ -- else
+ case register of
+ Any _fmt code ->
+ pure $ Any (intFormat to) $ \dst -> do
+ code dst `appOL` truncateSubwordRegInplace to dst
+ Fixed _fmt reg code -> do
+ (trunc_reg, trunc_code) <- truncateSubwordReg SMayClobberSubwordArgReg to reg
+ pure $ Fixed (intFormat to) trunc_reg (code `appOL` trunc_code)
CmmMachOp op [e] -> do
(reg, _format, code) <- getSomeReg e
case op of
@@ -1233,7 +1241,7 @@ getRegister' config plat expr
-- sign-extend both arguments to 32-bits.
-- See Note [Signed arithmetic on AArch64].
intOpImm :: Bool -> Width -> (Operand -> Operand -> Operand -> OrdList Instr) -> (Integer -> Width -> Maybe Operand) -> NatM (Register)
- intOpImm {- is signed -} True w op _encode_imm = intOp True w op
+ intOpImm True w op _encode_imm = intOp True w op {- is signed -}
intOpImm False w op encode_imm = do
-- compute x<m> <- x
-- compute x<o> <- y
@@ -1272,8 +1280,9 @@ getRegister' config plat expr
let w' = opRegWidth w
signExt r
-- See Note [Signed arithmetic on AArch64] and #27430
- | w >= W32 = pure (r, nilOL)
- | not is_signed = truncateSubwordReg w r
+ | not is_signed = truncateSubwordReg SMayClobberSubwordArgReg w r
+ -- TODO(mangoiv) in the signed case if w> W32,
+ -- this should be a noop
| otherwise = signExtendReg w w' r
(reg_x_sx, code_x_sx) <- signExt reg_x
(reg_y_sx, code_y_sx) <- signExt reg_y
@@ -1914,38 +1923,97 @@ signExtendReg w w' r =
r' <- getNewRegNat (intFormat w')
return (r', unitOL $ instr (OpReg w' r') (OpReg w r))
--- | Truncate/zero extend the subwords high bits and store the
--- result in a new register. Must be called with w==8 or w==16
-truncateSubwordReg :: Width -> Reg -> NatM (Reg, OrdList Instr)
-truncateSubwordReg w_to r = do
- massertPpr (w_to == W8 || w_to == W16) (text "truncateSubwordReg:unexpectedWidth")
- case w_to of
- -- Asserted false, but be defensive for non-debug builds.
- W64 -> trunc W64 MOV
- W32 -> trunc W32 MOV
-
- -- Actual truncation
- W16 -> trunc W32 UXTH
- W8 -> trunc W32 UXTB
- _ -> panic "truncateSubwordReg:unexpectedWidth"
- where
- trunc w instr = do
- r' <- getNewRegNat (intFormat w_to)
- return (r', unitOL $ instr (OpReg w r') (OpReg w r))
+-- | Whether the argument register may be clobbered
+-- 'NeverClobbers' is an optimization
+data ArgumentClobbering
+ = NeverClobbers
+ | MayClobberArgReg
+
+-- TODO(mangoiv): come up with better names for these two data strucutes
+
+data SArgumentClobbering (a :: ArgumentClobbering) where
+ SMayClobberSubwordArgReg :: SArgumentClobbering MayClobberArgReg
+ -- ^ the usual case: the register that holds a subword argument may be
+ -- clobbered by the truncation operation; >=W32 is not affected since
+ -- it is a noop
+
+ SAlwaysAllocateReg :: SArgumentClobbering MayClobberArgReg
+ -- ^ subwords may be clobbered, but >=W32 want to allocate a new register
+ -- anyway; to avoid having to allocate twice in the subword case, we
+ -- always allocate a new register
+ -- This is at worst a pessimisation of allocating one more registeer
+ -- in case we don't actually need this.
+
+ SNeverClobbers :: SArgumentClobbering NeverClobbers
+ -- ^ if we are sure that the register is fresh and clobbering doesn't
+ -- matter, we don't have to allocate a new register, ever
+
+
+data SArgumentClobbered (a :: ArgumentClobbering) where
+ SNeverClobbered :: OrdList Instr -> SArgumentClobbered NeverClobbers
+ -- ^ just returns the instructions; since we never clobber, this is pure since
+ -- we never have to return a new register
+
+ SUnclobbered :: NatM (Reg, OrdList Instr) -> SArgumentClobbered MayClobberArgReg
+ -- ^ return code to allocate a new register and instructions that may depend on it, that is:
+ -- - a new register if we pass a subword register with the potential to be clobbered
+ -- - the input register if we pass a word sized argument with no need to always allocate
+ -- a new register
+ -- - a new register if we were to always create a new register
+
+instrsWithUnclobberedReg :: SArgumentClobbered MayClobberArgReg -> NatM (Reg, OrdList Instr)
+instrsWithUnclobberedReg (SUnclobbered a) = a
+
+instrsNonclobberedCode :: SArgumentClobbered NeverClobbers -> OrdList Instr
+instrsNonclobberedCode (SNeverClobbered a) = a
+
+-- | full words
+pattern WFull :: Width
+pattern WFull <- (\case W32 -> True; W64 -> True; _ -> False -> True)
+
+-- | subwords
+pattern WSub :: (Operand -> Operand -> Instr) -> Width
+pattern WSub {truncInstr} <- (\case W16 -> Just UXTH; W8 -> Just UXTB; _ -> Nothing -> (Just truncInstr))
--- | Like @truncateSubwordReg@, but modifes the argument register in place if we
--- need to truncate.
truncateSubwordRegInplace :: Width -> Reg -> OrdList Instr
-truncateSubwordRegInplace w_to r = do
- case w_to of
- W64 -> nilOL
- W32 -> nilOL
- W16 -> trunc UXTH
- W8 -> trunc UXTB
- _ -> panic "truncateSubwordRegInplace:unexpectedWidth"
+truncateSubwordRegInplace w_to r = instrsNonclobberedCode (truncateSubwordReg' SNeverClobbers w_to r)
+
+truncateSubwordReg :: SArgumentClobbering MayClobberArgReg -> Width -> Reg -> NatM (Reg, OrdList Instr)
+truncateSubwordReg clobbering w_to r = instrsWithUnclobberedReg (truncateSubwordReg' clobbering w_to r)
+
+-- | Truncate/zero extend the subwords high bits and store the
+-- result in a new register.
+truncateSubwordReg' :: SArgumentClobbering a -> Width -> Reg -> SArgumentClobbered a
+truncateSubwordReg' clobbering w_to r = case clobbering of
+ SMayClobberSubwordArgReg
+ -- return the input register
+ | WFull <- w_to -> SUnclobbered $ pure (r, nilOL)
+ -- allocate a new register
+ | WSub {truncInstr} <- w_to -> SUnclobbered $ do
+ freshReg <- getNewRegNat (intFormat w_to)
+ pure (freshReg, pureTrunc truncInstr W32 freshReg r)
+
+ -- always allocate a new register as the surrounding code
+ -- would allocate one anyways and we don't want to allocate
+ -- multiple times; this may be a pessimation when we don't
+ -- want to allocate a new register for non-subwords
+ SAlwaysAllocateReg -> SUnclobbered $ do
+ freshReg <- getNewRegNat (intFormat w_to)
+ let instrs
+ | WFull <- w_to = nilOL
+ | WSub {truncInstr} <- w_to = pureTrunc truncInstr W32 freshReg r
+ | otherwise = panicUnexpectedWidth
+ pure (freshReg, instrs)
+ SNeverClobbers
+ -- noop
+ | WFull <- w_to -> SNeverClobbered nilOL
+ -- same register
+ | WSub {truncInstr} <- w_to -> SNeverClobbered $ pureTrunc truncInstr W32 r r
+ _ -> panicUnexpectedWidth
where
- trunc instr = do
- unitOL $ instr (OpReg W32 r) (OpReg W32 r)
+ pureTrunc instr targetWidth destinationReg originReg
+ = unitOL $ instr (OpReg targetWidth destinationReg) (OpReg targetWidth originReg)
+ panicUnexpectedWidth = panic "truncateSubwordReg:unexpectedWidth"
-- -----------------------------------------------------------------------------
-- The 'Amode' type: Memory addressing modes passed up the tree.
@@ -3027,7 +3095,7 @@ data BlockInRange = InRange | NotInRange Target
-- See Note [AArch64 far jumps]
makeFarBranches :: Platform -> LabelMap RawCmmStatics -> [NatBasicBlock Instr]
-> UniqDSM [NatBasicBlock Instr]
-makeFarBranches {- only used when debugging -} _platform statics basic_blocks = do
+makeFarBranches _platform statics basic_blocks = do
-- All offsets/positions are counted in multiples of 4 bytes (the size of AArch64 instructions)
-- That is an offset of 1 represents a 4-byte/one instruction offset.
let (func_size, lblMap) = foldl' calc_lbl_positions (0, mapEmpty) basic_blocks
@@ -3143,4 +3211,4 @@ makeFarBranches {- only used when debugging -} _platform statics basic_blocks =
CBZ{} -> Just long_bz_jump_size
CBNZ{} -> Just long_bz_jump_size
BCOND{} -> Just long_bc_jump_size
- _ -> Nothing
+ _ -> Nothing {- only used when debugging -}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/961ca1768dfd8f343cbfb32b24ad7fe…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/961ca1768dfd8f343cbfb32b24ad7fe…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/andreask/arm-ffi] fixup! compiler: refactor truncation to be able to control whether or not registers are alloated
by Magnus (＠MangoIV) 05 Aug '26
by Magnus (＠MangoIV) 05 Aug '26
05 Aug '26
Magnus pushed to branch wip/andreask/arm-ffi at Glasgow Haskell Compiler / GHC
Commits:
b894fde8 by mangoiv at 2026-08-05T11:57:01+02:00
fixup! compiler: refactor truncation to be able to control whether or not registers are alloated
- - - - -
1 changed file:
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
Changes:
=====================================
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
=====================================
@@ -939,9 +939,9 @@ getRegister' config plat expr
case register of
Any _fmt code ->
pure $ Any (intFormat to) $ \dst -> do
- code dst `appOL` instrsNonclobberedCode (truncateSubwordReg SNeverClobbers to dst)
+ code dst `appOL` truncateSubwordRegInplace to dst
Fixed _fmt reg code -> do
- (trunc_reg, trunc_code) <- instrsWithUnclobberedReg $ truncateSubwordReg SMayClobberSubwordArgReg to reg
+ (trunc_reg, trunc_code) <- truncateSubwordReg SMayClobberSubwordArgReg to reg
pure $ Fixed (intFormat to) trunc_reg (code `appOL` trunc_code)
CmmMachOp op [e] -> do
(reg, _format, code) <- getSomeReg e
@@ -1280,8 +1280,9 @@ getRegister' config plat expr
let w' = opRegWidth w
signExt r
-- See Note [Signed arithmetic on AArch64] and #27430
- | w >= W32 = pure (r, nilOL)
- | not is_signed = truncateSubwordReg w r
+ | not is_signed = truncateSubwordReg SMayClobberSubwordArgReg w r
+ -- TODO(mangoiv) in the signed case if w> W32,
+ -- this should be a noop
| otherwise = signExtendReg w w' r
(reg_x_sx, code_x_sx) <- signExt reg_x
(reg_y_sx, code_y_sx) <- signExt reg_y
@@ -1974,10 +1975,16 @@ pattern WFull <- (\case W32 -> True; W64 -> True; _ -> False -> True)
pattern WSub :: (Operand -> Operand -> Instr) -> Width
pattern WSub {truncInstr} <- (\case W16 -> Just UXTH; W8 -> Just UXTB; _ -> Nothing -> (Just truncInstr))
+truncateSubwordRegInplace :: Width -> Reg -> OrdList Instr
+truncateSubwordRegInplace w_to r = instrsNonclobberedCode (truncateSubwordReg' SNeverClobbers w_to r)
+
+truncateSubwordReg :: SArgumentClobbering MayClobberArgReg -> Width -> Reg -> NatM (Reg, OrdList Instr)
+truncateSubwordReg clobbering w_to r = instrsWithUnclobberedReg (truncateSubwordReg' clobbering w_to r)
+
-- | Truncate/zero extend the subwords high bits and store the
-- result in a new register.
-truncateSubwordReg :: SArgumentClobbering a -> Width -> Reg -> SArgumentClobbered a
-truncateSubwordReg clobbering w_to r = case clobbering of
+truncateSubwordReg' :: SArgumentClobbering a -> Width -> Reg -> SArgumentClobbered a
+truncateSubwordReg' clobbering w_to r = case clobbering of
SMayClobberSubwordArgReg
-- return the input register
| WFull <- w_to -> SUnclobbered $ pure (r, nilOL)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b894fde8292bdb13d856db43d4b54a8…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b894fde8292bdb13d856db43d4b54a8…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc] Pushed new branch wip/fendor/T18425-hie-validate-bug
by Hannes Siebenhandl (＠fendor) 05 Aug '26
by Hannes Siebenhandl (＠fendor) 05 Aug '26
05 Aug '26
Hannes Siebenhandl pushed new branch wip/fendor/T18425-hie-validate-bug at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/fendor/T18425-hie-validate-bug
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/andreask/arm-ffi] compiler: refactor truncation to be able to control whether or not registers are alloated
by Magnus (＠MangoIV) 05 Aug '26
by Magnus (＠MangoIV) 05 Aug '26
05 Aug '26
Magnus pushed to branch wip/andreask/arm-ffi at Glasgow Haskell Compiler / GHC
Commits:
c758cca3 by mangoiv at 2026-08-05T11:46:12+02:00
compiler: refactor truncation to be able to control whether or not registers are alloated
- - - - -
1 changed file:
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
Changes:
=====================================
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
=====================================
@@ -1,5 +1,8 @@
{-# language GADTs, LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
module GHC.CmmToAsm.AArch64.CodeGen (
cmmTopCodeGen
@@ -923,18 +926,23 @@ getRegister' config plat expr
-- XX Conversion
CmmMachOp (MO_XX_Conv from to) [e] -> do
register <- getRegister e
- if to >= W32 || to > from
- then case register of
- -- Reuse computation, casting width.
- Any _fmt code -> pure $ Any (intFormat to) code
- Fixed _fmt reg code -> pure $ Fixed (intFormat to) reg code
- else case register of
- Any _fmt code ->
- pure $ Any (intFormat to) $ \dst -> do
- code dst `appOL` truncateSubwordRegInplace to dst
- Fixed _fmt reg code -> do
- (trunc_reg, trunc_code) <- truncateSubwordReg to reg
- pure $ Fixed (intFormat to) trunc_reg (code `appOL` trunc_code)
+ -- if to >= W32 || to > from
+ -- -- don't do anything in the word case or
+ -- -- when the target register width is larger
+ -- -- than the origin register width; e.g.
+ -- -- mangoiv: what we the tradeoff to not truncate here, too?
+ -- then case register of
+ -- -- Reuse computation, casting width.
+ -- Any _fmt code -> pure $ Any (intFormat to) code
+ -- Fixed _fmt reg code -> pure $ Fixed (intFormat to) reg code
+ -- else
+ case register of
+ Any _fmt code ->
+ pure $ Any (intFormat to) $ \dst -> do
+ code dst `appOL` instrsNonclobberedCode (truncateSubwordReg SNeverClobbers to dst)
+ Fixed _fmt reg code -> do
+ (trunc_reg, trunc_code) <- instrsWithUnclobberedReg $ truncateSubwordReg SMayClobberSubwordArgReg to reg
+ pure $ Fixed (intFormat to) trunc_reg (code `appOL` trunc_code)
CmmMachOp op [e] -> do
(reg, _format, code) <- getSomeReg e
case op of
@@ -1233,7 +1241,7 @@ getRegister' config plat expr
-- sign-extend both arguments to 32-bits.
-- See Note [Signed arithmetic on AArch64].
intOpImm :: Bool -> Width -> (Operand -> Operand -> Operand -> OrdList Instr) -> (Integer -> Width -> Maybe Operand) -> NatM (Register)
- intOpImm {- is signed -} True w op _encode_imm = intOp True w op
+ intOpImm True w op _encode_imm = intOp True w op {- is signed -}
intOpImm False w op encode_imm = do
-- compute x<m> <- x
-- compute x<o> <- y
@@ -1914,38 +1922,91 @@ signExtendReg w w' r =
r' <- getNewRegNat (intFormat w')
return (r', unitOL $ instr (OpReg w' r') (OpReg w r))
+-- | Whether the argument register may be clobbered
+-- 'NeverClobbers' is an optimization
+data ArgumentClobbering
+ = NeverClobbers
+ | MayClobberArgReg
+
+-- TODO(mangoiv): come up with better names for these two data strucutes
+
+data SArgumentClobbering (a :: ArgumentClobbering) where
+ SMayClobberSubwordArgReg :: SArgumentClobbering MayClobberArgReg
+ -- ^ the usual case: the register that holds a subword argument may be
+ -- clobbered by the truncation operation; >=W32 is not affected since
+ -- it is a noop
+
+ SAlwaysAllocateReg :: SArgumentClobbering MayClobberArgReg
+ -- ^ subwords may be clobbered, but >=W32 want to allocate a new register
+ -- anyway; to avoid having to allocate twice in the subword case, we
+ -- always allocate a new register
+ -- This is at worst a pessimisation of allocating one more registeer
+ -- in case we don't actually need this.
+
+ SNeverClobbers :: SArgumentClobbering NeverClobbers
+ -- ^ if we are sure that the register is fresh and clobbering doesn't
+ -- matter, we don't have to allocate a new register, ever
+
+
+data SArgumentClobbered (a :: ArgumentClobbering) where
+ SNeverClobbered :: OrdList Instr -> SArgumentClobbered NeverClobbers
+ -- ^ just returns the instructions; since we never clobber, this is pure since
+ -- we never have to return a new register
+
+ SUnclobbered :: NatM (Reg, OrdList Instr) -> SArgumentClobbered MayClobberArgReg
+ -- ^ return code to allocate a new register and instructions that may depend on it, that is:
+ -- - a new register if we pass a subword register with the potential to be clobbered
+ -- - the input register if we pass a word sized argument with no need to always allocate
+ -- a new register
+ -- - a new register if we were to always create a new register
+
+instrsWithUnclobberedReg :: SArgumentClobbered MayClobberArgReg -> NatM (Reg, OrdList Instr)
+instrsWithUnclobberedReg (SUnclobbered a) = a
+
+instrsNonclobberedCode :: SArgumentClobbered NeverClobbers -> OrdList Instr
+instrsNonclobberedCode (SNeverClobbered a) = a
+
+-- | full words
+pattern WFull :: Width
+pattern WFull <- (\case W32 -> True; W64 -> True; _ -> False -> True)
+
+-- | subwords
+pattern WSub :: (Operand -> Operand -> Instr) -> Width
+pattern WSub {truncInstr} <- (\case W16 -> Just UXTH; W8 -> Just UXTB; _ -> Nothing -> (Just truncInstr))
+
-- | Truncate/zero extend the subwords high bits and store the
--- result in a new register. Must be called with w==8 or w==16
-truncateSubwordReg :: Width -> Reg -> NatM (Reg, OrdList Instr)
-truncateSubwordReg w_to r = do
- massertPpr (w_to == W8 || w_to == W16) (text "truncateSubwordReg:unexpectedWidth")
- case w_to of
- -- Asserted false, but be defensive for non-debug builds.
- W64 -> trunc W64 MOV
- W32 -> trunc W32 MOV
-
- -- Actual truncation
- W16 -> trunc W32 UXTH
- W8 -> trunc W32 UXTB
- _ -> panic "truncateSubwordReg:unexpectedWidth"
- where
- trunc w instr = do
- r' <- getNewRegNat (intFormat w_to)
- return (r', unitOL $ instr (OpReg w r') (OpReg w r))
-
--- | Like @truncateSubwordReg@, but modifes the argument register in place if we
--- need to truncate.
-truncateSubwordRegInplace :: Width -> Reg -> OrdList Instr
-truncateSubwordRegInplace w_to r = do
- case w_to of
- W64 -> nilOL
- W32 -> nilOL
- W16 -> trunc UXTH
- W8 -> trunc UXTB
- _ -> panic "truncateSubwordRegInplace:unexpectedWidth"
+-- result in a new register.
+truncateSubwordReg :: SArgumentClobbering a -> Width -> Reg -> SArgumentClobbered a
+truncateSubwordReg clobbering w_to r = case clobbering of
+ SMayClobberSubwordArgReg
+ -- return the input register
+ | WFull <- w_to -> SUnclobbered $ pure (r, nilOL)
+ -- allocate a new register
+ | WSub {truncInstr} <- w_to -> SUnclobbered $ do
+ freshReg <- getNewRegNat (intFormat w_to)
+ pure (freshReg, pureTrunc truncInstr W32 freshReg r)
+
+ -- always allocate a new register as the surrounding code
+ -- would allocate one anyways and we don't want to allocate
+ -- multiple times; this may be a pessimation when we don't
+ -- want to allocate a new register for non-subwords
+ SAlwaysAllocateReg -> SUnclobbered $ do
+ freshReg <- getNewRegNat (intFormat w_to)
+ let instrs
+ | WFull <- w_to = nilOL
+ | WSub {truncInstr} <- w_to = pureTrunc truncInstr W32 freshReg r
+ | otherwise = panicUnexpectedWidth
+ pure (freshReg, instrs)
+ SNeverClobbers
+ -- noop
+ | WFull <- w_to -> SNeverClobbered nilOL
+ -- same register
+ | WSub {truncInstr} <- w_to -> SNeverClobbered $ pureTrunc truncInstr W32 r r
+ _ -> panicUnexpectedWidth
where
- trunc instr = do
- unitOL $ instr (OpReg W32 r) (OpReg W32 r)
+ pureTrunc instr targetWidth destinationReg originReg
+ = unitOL $ instr (OpReg targetWidth destinationReg) (OpReg targetWidth originReg)
+ panicUnexpectedWidth = panic "truncateSubwordReg:unexpectedWidth"
-- -----------------------------------------------------------------------------
-- The 'Amode' type: Memory addressing modes passed up the tree.
@@ -3027,7 +3088,7 @@ data BlockInRange = InRange | NotInRange Target
-- See Note [AArch64 far jumps]
makeFarBranches :: Platform -> LabelMap RawCmmStatics -> [NatBasicBlock Instr]
-> UniqDSM [NatBasicBlock Instr]
-makeFarBranches {- only used when debugging -} _platform statics basic_blocks = do
+makeFarBranches _platform statics basic_blocks = do
-- All offsets/positions are counted in multiples of 4 bytes (the size of AArch64 instructions)
-- That is an offset of 1 represents a 4-byte/one instruction offset.
let (func_size, lblMap) = foldl' calc_lbl_positions (0, mapEmpty) basic_blocks
@@ -3143,4 +3204,4 @@ makeFarBranches {- only used when debugging -} _platform statics basic_blocks =
CBZ{} -> Just long_bz_jump_size
CBNZ{} -> Just long_bz_jump_size
BCOND{} -> Just long_bc_jump_size
- _ -> Nothing
+ _ -> Nothing {- only used when debugging -}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c758cca3c882d2e4bdff7c5f13b1dd7…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c758cca3c882d2e4bdff7c5f13b1dd7…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: testsuite: Don't crash on non-UTF-8 test output
by Marge Bot (＠marge-bot) 05 Aug '26
by Marge Bot (＠marge-bot) 05 Aug '26
05 Aug '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
b831ab31 by Simon Jakobi at 2026-08-05T05:21:25-04:00
testsuite: Don't crash on non-UTF-8 test output
read_stdout, read_stderr_for, read_comp_stderr and read_diff decoded
strictly (the first three with UTF-8, read_diff with the locale
encoding), so a test emitting invalid UTF-8 (binary output, or a crash
truncating a multi-byte character) raised UnicodeDecodeError and was
reported as a framework failure instead of its actual result.
Decode with errors='replace', like read_no_crs and safe_print.
Assisted-by: Claude Fable 5
- - - - -
693503ec by Simon Jakobi at 2026-08-05T05:21:25-04:00
testsuite: Colorize the test summary, also in CI
The summary headings were plain, and SUMMARY was colored unconditionally,
so the escapes also ended up in the file written by --summary-file.
Color is now decided per output sink via term_color.colored_if; see the
comments in term_color.
CI logs are not a tty, but GitLab's log viewer renders ANSI colors, so
add --force-colors and pass it in .gitlab/ci.sh.
Assisted-by: Claude Opus 5
- - - - -
cd41db96 by Simon Jakobi at 2026-08-05T05:21:25-04:00
testsuite: Repeat unexpected failure output in the summary
Finding out why a test failed meant scrolling back through a possibly
very long log to the point where the test ran. The summary now repeats
the captured output of unexpected failures, before the statistics, so
the most interesting part is at the end of the log (#16720).
Output mismatches report their diff instead of the mismatching stream
(see Note [Redundant output in test results]). The repeated output is
bounded per stream, and skipped altogether beyond
MAX_SUMMARY_OUTPUT_TESTS failure blocks. Tests failing identically in
several ways share one block.
Test results now report a source-relative directory, stable regardless
of where the run was started from.
Assisted-by: Claude Fable 5
- - - - -
8274828d by Ben Gamari at 2026-08-05T05:21:26-04:00
base: Don't drop exception context in SomeException(toException)
For reasons that are lost to time, the implementation of [CLC #200]
that was merged inappropriately dropped `ExceptionContext` in the
`toException` implementation given to `SomeException`.
Fix this infelicity.
[CLC #200]: https://github.com/haskell/core-libraries-committee/issues/200
- - - - -
d6d1e0fc by Vladislav Zavialov at 2026-08-05T05:21:26-04:00
Test case for #20902
Starting with GHC 9.14.1 (the first major release to include 51e3ec83),
and from point releases GHC 9.10.2 and GHC 9.12.3 (backports cc4470be68
and b30f25591e), all examples in this ticket are handled as expected.
- - - - -
3efd9085 by Alan Zimmerman at 2026-08-05T05:21:27-04:00
EPA: Remove LocatedP, last use in WarningTxt
The last step of removing LocatedP, by moving the AnnPragma for
WarningTxt into its TTG extension point instead.
This also allows us to remove LocatedP and SrcSpanAnnP
- - - - -
15244d80 by Vladislav Zavialov at 2026-08-05T05:21:28-04:00
Test cases for #18725
Starting with GHC 9.4 (the first release to include 268efcc9a4), the program in
this ticket no longer panics. A standalone kind signature breaks the recursive
loop, so the type constructor can be used in a kind within its own group.
T18725a checks that this is accepted with the signature present, while T18725b
confirms it is still rejected without it.
- - - - -
25 changed files:
- .gitlab/ci.sh
- + changelog.d/T27455
- compiler/GHC/Builtin/Utils.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Warnings.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Unit/Module/Warnings.hs
- libraries/base/changelog.md
- libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs
- testsuite/driver/runtests.py
- testsuite/driver/term_color.py
- testsuite/driver/testlib.py
- testsuite/tests/ghc-e/should_fail/T18441fail7.stderr
- testsuite/tests/ghc-e/should_run/ghc-e005.stderr
- + testsuite/tests/saks/should_compile/T18725a.hs
- testsuite/tests/saks/should_compile/all.T
- + testsuite/tests/saks/should_fail/T18725b.hs
- + testsuite/tests/saks/should_fail/T18725b.stderr
- testsuite/tests/saks/should_fail/all.T
- + testsuite/tests/th/T20902.hs
- testsuite/tests/th/all.T
- utils/check-exact/ExactPrint.hs
Changes:
=====================================
.gitlab/ci.sh
=====================================
@@ -652,6 +652,10 @@ function test_hadrian() {
check_msys2_deps _build/stage1/bin/ghc --version
check_release_build
+ # GitLab's log viewer renders ANSI colors, but stdout here is not a tty,
+ # so the driver must be told to emit them.
+ RUNTEST_ARGS="${RUNTEST_ARGS:-} --force-colors"
+
# Ensure that statically-linked builds are actually static
if [[ "${BUILD_FLAVOUR}" = *static* ]]; then
bad_execs=""
=====================================
changelog.d/T27455
=====================================
@@ -0,0 +1,8 @@
+section: base
+issues: #27455
+mrs: !16274
+synopsis:
+ Don't drop `ExceptionContext` in `SomeException(toException)`
+description:
+ Previously the implementation of ``Exception(toException)`` given to `SomeException` would inappropriately drop the carried `ExceptionContext`. Now ``toException = id``, faithfully implementing the semantics proposed in :ref:`CLC Proposal #200 <https://github.com/haskell/core-libraries-committee/issues/200>`.
+
=====================================
compiler/GHC/Builtin/Utils.hs
=====================================
@@ -301,7 +301,7 @@ ghcPrimWarns = WarnSome
[]
where
mk_txt msg =
- DeprecatedTxt NoSourceText [noLocA $ WithHsDocIdentifiers (StringLiteral NoSourceText (fastStringToShortText msg)) []]
+ DeprecatedTxt (NoSourceText, noAnn) [noLocA $ WithHsDocIdentifiers (StringLiteral NoSourceText (fastStringToShortText msg)) []]
mk_decl_dep (occ, msg) = (occ, mk_txt msg)
ghcPrimFixities :: [(OccName,Fixity)]
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -1043,7 +1043,7 @@ cidDeprecation :: forall p. IsPass p
cidDeprecation = fmap unLoc . decl_deprecation (ghcPass @p)
where
decl_deprecation :: GhcPass p -> ClsInstDecl (GhcPass p)
- -> Maybe (LocatedP (WarningTxt (GhcPass p)))
+ -> Maybe (LocatedA (WarningTxt (GhcPass p)))
decl_deprecation GhcPs (ClsInstDecl{ cid_ext = (depr, _) } )
= depr
decl_deprecation GhcRn (ClsInstDecl{ cid_ext = (depr, _) })
@@ -1242,7 +1242,7 @@ derivDeprecation :: forall p. IsPass p
derivDeprecation = fmap unLoc . decl_deprecation (ghcPass @p)
where
decl_deprecation :: GhcPass p -> DerivDecl (GhcPass p)
- -> Maybe (LocatedP (WarningTxt (GhcPass p)))
+ -> Maybe (LocatedA (WarningTxt (GhcPass p)))
decl_deprecation GhcPs (DerivDecl{ deriv_ext = (depr, _) })
= depr
decl_deprecation GhcRn (DerivDecl{ deriv_ext = (depr, _) })
=====================================
compiler/GHC/Hs/Dump.hs
=====================================
@@ -99,7 +99,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
`extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet
`ext2Q` located
`extQ` srcSpanAnnA
- `extQ` srcSpanAnnP
`extQ` srcSpanAnnN
`extQ` srcSpanAnnBF
@@ -409,9 +408,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
srcSpanAnnA :: EpAnn [TrailingAnn] -> SDoc
srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA")
- srcSpanAnnP :: EpAnn AnnPragma -> SDoc
- srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP")
-
srcSpanAnnN :: EpAnn NameAnn -> SDoc
srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN")
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -83,7 +83,7 @@ import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisForAllTyFlag )
import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..))
import GHC.Builtin.Types ( constraintKindTyConName )
import GHC.Stg.EnforceEpt.TagSig
-import GHC.Parser.Annotation (noLocA)
+import GHC.Parser.Annotation (noLocA, noAnn)
import GHC.Hs.Extension ( GhcPass, GhcRn, GhcTc )
import GHC.Hs.Decls.Overlap ( OverlapFlag )
import GHC.Hs.Doc ( WithHsDocIdentifiers(..) )
@@ -666,8 +666,8 @@ fromIfaceWarnings = \case
fromIfaceWarningTxt :: IfaceWarningTxt -> WarningTxt GhcRn
fromIfaceWarningTxt = \case
- IfWarningTxt src mb_cat strs -> WarningTxt src (noLocA . fromWarningCategory <$> mb_cat) (noLocA <$> map fromIfaceStringLiteralWithNames strs)
- IfDeprecatedTxt src strs -> DeprecatedTxt src (noLocA <$> map fromIfaceStringLiteralWithNames strs)
+ IfWarningTxt src mb_cat strs -> WarningTxt (src, noAnn) (noLocA . fromWarningCategory <$> mb_cat) (noLocA <$> map fromIfaceStringLiteralWithNames strs)
+ IfDeprecatedTxt src strs -> DeprecatedTxt (src, noAnn) (noLocA <$> map fromIfaceStringLiteralWithNames strs)
fromIfaceStringLiteralWithNames :: (IfaceStringLiteral, [IfExtName]) -> WithHsDocIdentifiers (StringLiteral GhcRn) GhcRn
fromIfaceStringLiteralWithNames (str, names) = WithHsDocIdentifiers (fromIfaceStringLiteral str) (map noLocA names)
=====================================
compiler/GHC/Iface/Warnings.hs
=====================================
@@ -22,12 +22,11 @@ toIfaceWarnings (WarnSome vs ds) = IfWarnSome vs' ds'
ds' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- ds]
toIfaceWarningTxt :: WarningTxt GhcRn -> IfaceWarningTxt
-toIfaceWarningTxt (WarningTxt src mb_cat strs) = IfWarningTxt src (unLoc . iwc_wc . unLoc <$> mb_cat) (map (toIfaceStringLiteralWithNames . unLoc) strs)
-toIfaceWarningTxt (DeprecatedTxt src strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs)
+toIfaceWarningTxt (WarningTxt (src, _) mb_cat strs) = IfWarningTxt src (unLoc . iwc_wc . unLoc <$> mb_cat) (map (toIfaceStringLiteralWithNames . unLoc) strs)
+toIfaceWarningTxt (DeprecatedTxt (src, _) strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs)
toIfaceStringLiteralWithNames :: WithHsDocIdentifiers (StringLiteral GhcRn) GhcRn -> (IfaceStringLiteral, [IfExtName])
toIfaceStringLiteralWithNames (WithHsDocIdentifiers src names) = (toIfaceStringLiteral src, map unLoc names)
toIfaceStringLiteral :: StringLiteral GhcRn -> IfaceStringLiteral
-toIfaceStringLiteral sLit =
- IfStringLiteral (stringLitSourceText sLit) (sl_fs sLit)
+toIfaceStringLiteral sLit = IfStringLiteral (stringLitSourceText sLit) (sl_fs sLit)
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2077,11 +2077,13 @@ to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated.
maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) }
: '{-# DEPRECATED' strings '#-}'
- {% fmap Just $ amsr (sLL $1 $> $ DeprecatedTxt (getDEPRECATED_PRAGs $1) (snd $ unLoc $2))
- (AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn) }
+ {% fmap Just $ amsA' (sLL $1 $> $
+ DeprecatedTxt (getDEPRECATED_PRAGs $1, AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn)
+ (snd $ unLoc $2))}
| '{-# WARNING' warning_category strings '#-}'
- {% fmap Just $ amsr (sLL $1 $> $ WarningTxt (getWARNING_PRAGs $1) $2 (snd $ unLoc $3))
- (AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn)}
+ {% fmap Just $ amsA' (sLL $1 $> $
+ WarningTxt (getWARNING_PRAGs $1, AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn)
+ $2 (snd $ unLoc $3))}
| {- empty -} { Nothing }
warning_category :: { Maybe (LocatedE (InWarningCategory GhcPs)) }
@@ -2110,7 +2112,7 @@ warning :: { OrdList (LWarnDecl GhcPs) }
: warning_category namespace_spec namelist strings
{% fmap unitOL $ amsA' (L (comb4 $1 $2 $3 $4)
(Warning (fst $ unLoc $4) (unLoc $2) (unLoc $3)
- (WarningTxt NoSourceText $1 (snd $ unLoc $4)))) }
+ (WarningTxt (NoSourceText, noAnn) $1 (snd $ unLoc $4)))) }
namespace_spec :: { Located (NamespaceSpecifier GhcPs) }
: 'type' { sL1 $1 $ TypeNamespaceSpecifier (epTok $1) }
@@ -2138,7 +2140,7 @@ deprecations :: { OrdList (LWarnDecl GhcPs) }
deprecation :: { OrdList (LWarnDecl GhcPs) }
: namespace_spec namelist strings
{% fmap unitOL $ amsA' (sL (comb3 $1 $2 $>) $ (Warning (fst $ unLoc $3) (unLoc $1) (unLoc $2)
- (DeprecatedTxt NoSourceText $ snd $ unLoc $3))) }
+ (DeprecatedTxt (NoSourceText, noAnn) $ snd $ unLoc $3))) }
strings :: { Located ((EpToken "[", EpToken "]"), [LocatedA (WithHsDocIdentifiers (StringLiteral GhcPs) GhcPs)]) }
: STRING { sL1 $1 (noAnn,[stringLiteralToHsDocWst (L (gl $1) (getStringLiteral $1))]) }
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -27,9 +27,9 @@ module GHC.Parser.Annotation (
EpAnnCO,
-- ** Annotations in 'GenLocated'
- LocatedA, LocatedN, LocatedAn, LocatedP,
+ LocatedA, LocatedN, LocatedAn,
LocatedE, LocatedBF,
- SrcSpanAnnA, SrcSpanAnnP, SrcSpanAnnN,
+ SrcSpanAnnA, SrcSpanAnnN,
SrcSpanAnnBF,
-- ** Annotation data types used in 'GenLocated'
@@ -430,7 +430,6 @@ emptyComments = EpaComments []
type LocatedA = GenLocated SrcSpanAnnA
type LocatedN = GenLocated SrcSpanAnnN
-type LocatedP = GenLocated SrcSpanAnnP
type LocatedBF = GenLocated SrcSpanAnnBF
-- | Annotation for items appearing in a list. They can have one or
@@ -441,7 +440,6 @@ type SrcSpanAnnA = EpAnn [TrailingAnn]
-- on the context, such as backticks.
type SrcSpanAnnN = EpAnn NameAnn
-type SrcSpanAnnP = EpAnn AnnPragma
type SrcSpanAnnBF = EpAnn AnnBooleanFormula
type LocatedE = GenLocated EpaLocation
=====================================
compiler/GHC/Unit/Module/Warnings.hs
=====================================
@@ -158,8 +158,8 @@ warningTxtSame w1 w2
instance Outputable (InWarningCategory (GhcPass pass)) where
ppr (InWarningCategory _ wt) = text "in" <+> doubleQuotes (ppr wt)
-type instance XDeprecatedTxt (GhcPass _) = SourceText
-type instance XWarningTxt (GhcPass _) = SourceText
+type instance XDeprecatedTxt (GhcPass _) = (SourceText, AnnPragma)
+type instance XWarningTxt (GhcPass _) = (SourceText, AnnPragma)
type instance XXWarningTxt (GhcPass _) = DataConCantHappen
type instance XInWarningCategory (GhcPass _) = (EpToken "in", SourceText)
type instance XXInWarningCategory (GhcPass _) = DataConCantHappen
@@ -167,7 +167,7 @@ type instance XXInWarningCategory (GhcPass _) = DataConCantHappen
type instance Anno (WithHsDocIdentifiers (StringLiteral pass) pass) = SrcSpanAnnA
type instance Anno (InWarningCategory (GhcPass pass)) = EpaLocation
type instance Anno (WarningCategory) = EpaLocation
-type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnP
+type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnA
deriving stock instance Eq (WarningTxt GhcPs)
deriving stock instance Eq (WarningTxt GhcRn)
@@ -190,15 +190,15 @@ deriving instance Outputable WarningCategory
instance Outputable (WarningTxt (GhcPass pass)) where
ppr (WarningTxt lsrc mcat ws)
= case lsrc of
- NoSourceText -> pp_ws ws
- SourceText src -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}"
+ (NoSourceText, _) -> pp_ws ws
+ (SourceText src, _) -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}"
where
ctg_doc = maybe empty (\ctg -> ppr ctg) mcat
ppr (DeprecatedTxt lsrc ds)
= case lsrc of
- NoSourceText -> pp_ws ds
- SourceText src -> ftext src <+> pp_ws ds <+> text "#-}"
+ (NoSourceText, _) -> pp_ws ds
+ (SourceText src, _) -> ftext src <+> pp_ws ds <+> text "#-}"
pp_ws :: [LocatedA (WithHsDocIdentifiers (StringLiteral (GhcPass p)) (GhcPass p))] -> SDoc
pp_ws [l] = ppr $ unLoc l
=====================================
libraries/base/changelog.md
=====================================
@@ -38,6 +38,7 @@
* Show `ExceptionContext` in `displayExceptionAnnotation` implementation of `WhileHandling` ([GHC #27456](https://gitlab.haskell.org/ghc/ghc/-/issues/27456))
* Hide implementation details when throwing exceptions in throw and throwSTM. ([CLC proposal #387](https://github.com/haskell/core-libraries-committee/issues/387))
* Change `hIsReadable` and `hIsWritable` such that they always throw a respective exception when encountering a closed or semi-closed handle, not just in the case of a file handle. ([CLC proposal #371](github.com/haskell/core-libraries-committee/issues/371))
+ * The implementation of `toException` in `SomeException`'s `Exception` instance no longer drops exception context, in keeping with the behavior originally proposed in [CLC Proposal #200](https://github.com/haskell/core-libraries-committee/issues/200).
* Annotate `onException` continuation with `WhileHandling`. ([CLC Proposal #397](https://github.com/haskell/core-libraries-committee/issues/397))
* Improve error message for `Data.Char.chr`. ([CLC Proposal #384](https://github.com/haskell/core-libraries-committee/issues/384))
=====================================
libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs
=====================================
@@ -55,7 +55,7 @@ import GHC.Internal.Data.Maybe
import GHC.Internal.Data.Typeable (Typeable, TypeRep, cast)
import qualified GHC.Internal.Data.Typeable as Typeable
-- loop: GHC.Internal.Data.Typeable -> GHC.Internal.Err -> GHC.Internal.Exception
-import GHC.Internal.Base (String, Void, fmap, return, ($), (.), (++))
+import GHC.Internal.Base (String, Void, fmap, return, ($), (.), (++), id)
import GHC.Internal.Show
import GHC.Internal.Types (Bool(..))
import GHC.Internal.Exception.Context
@@ -208,7 +208,16 @@ Caught MismatchedParentheses
-}
class (Typeable e, Show e) => Exception e where
- -- | @toException@ should produce a 'SomeException' with no attached 'ExceptionContext'.
+ -- | 'toException' converts an exception into the existential 'SomeException'
+ -- wrapper type.
+ --
+ -- In doing so, 'toException' should not /add/ an 'ExceptionContext'.
+ --
+ -- - In most cases, the exception does not store its own 'ExceptionContext'.
+ -- The default implementation of 'toException' (which does not store any
+ -- 'ExceptionContext') is suitable for these cases.
+ -- - In the rare case that the exception itself stores an 'ExceptionContext',
+ -- this context should be preserved by 'toException'.
toException :: e -> SomeException
fromException :: SomeException -> Maybe e
@@ -231,13 +240,11 @@ class (Typeable e, Show e) => Exception e where
-- | @since base-4.8.0.0
instance Exception Void
--- | This drops any attached 'ExceptionContext'.
+-- | NB: this instance preserves the attached 'ExceptionContext'.
--
-- @since base-3.0
instance Exception SomeException where
- toException (SomeException e) =
- let ?exceptionContext = emptyExceptionContext
- in SomeException e
+ toException = id
fromException = Just
backtraceDesired (SomeException e) = backtraceDesired e
displayException (SomeException e) = displayException e
=====================================
testsuite/driver/runtests.py
=====================================
@@ -94,6 +94,8 @@ parser.add_argument("--ignore-perf-failures", choices=['increases','decreases','
help="Do not fail due to out-of-tolerance perf tests")
parser.add_argument("--only-report-hadrian-deps", type=Path,
help="Dry run the testsuite and report all extra hadrian dependencies needed on the given file")
+parser.add_argument("--force-colors", action="store_true",
+ help="emit ANSI colors even when stdout is not a tty (e.g. for CI logs)")
args = parser.parse_args()
@@ -259,7 +261,9 @@ def supports_colors():
return True
config.supports_colors = supports_colors()
-term_color.enable_color = config.supports_colors
+# config.supports_colors deliberately stays tty-based: it also guards
+# terminal-title updates, which must not end up in a CI log.
+term_color.enable_color = config.supports_colors or args.force_colors
# This has to come after arg parsing as the args can change the compiler
get_compiler_info()
@@ -587,7 +591,7 @@ else:
print(Perf.allow_changes_string([(m.change, m.stat) for m in t.metrics]))
print('-' * 25)
- summary(t, sys.stdout, color=config.supports_colors)
+ summary(t, sys.stdout, color=term_color.enable_color, junit_path=args.junit)
# Write perf stats if any exist or if a metrics file is specified.
stats_metrics = [stat for (_, stat, __) in t.metrics] # type: List[PerfStat]
=====================================
testsuite/driver/term_color.py
=====================================
@@ -1,5 +1,6 @@
from enum import Enum
+# Whether to emit color escapes; set in runtests.py.
enable_color = True
class Color(Enum):
@@ -18,3 +19,7 @@ def colored(color: Color, s: str) -> str:
else:
return s
+# For renderers that serve several sinks: `enabled` says whether *this* sink
+# takes color (the summary is written both to stdout and to a plain-text file).
+def colored_if(enabled: bool, color: Color, s: str) -> str:
+ return colored(color, s) if enabled else s
=====================================
testsuite/driver/testlib.py
=====================================
@@ -27,7 +27,7 @@ from testutil import strip_quotes, lndir, link_or_copy_file, passed, \
failBecause, testing_metrics, residency_testing_metrics, \
stable_perf_counters, \
PassFail, badResult, str_warn, str_removeprefix
-from term_color import Color, colored
+from term_color import Color, colored_if
import testutil
from cpu_features import have_cpu_feature
import perf_notes as Perf
@@ -1499,6 +1499,19 @@ def _newTestDir(name: TestName, opts: TestOptions, tempdir, dir):
opts.testdir_raw = Path(os.path.join(tempdir, testdir, name + testdir_suffix))
opts.compiler_always_flags = config.compiler_always_flags
+def _result_directory(opts: TestOptions) -> str:
+ # The test's source directory, relative to the GHC source root, so it reads
+ # the same regardless of which directory `make` was invoked from.
+ srcdir = opts.srcdir
+ if srcdir is None:
+ return ''
+ try:
+ return os.path.relpath(srcdir, config.top.parent)
+ except ValueError:
+ # No relative path exists (e.g. different Windows drives); the
+ # absolute path is still more useful than nothing.
+ return str(srcdir)
+
# -----------------------------------------------------------------------------
# Actually doing tests
@@ -1823,7 +1836,7 @@ async def do_test(name: TestName,
if opts.expect not in ['pass', 'fail', 'missing-lib']:
framework_fail(name, way, 'bad expected ' + opts.expect)
- directory = str_removeprefix(str_removeprefix(str(opts.testdir), './'), '.\\')
+ directory = _result_directory(opts)
if way in opts.fragile_ways:
if_verbose(1, '*** fragile test %s resulted in %s' % (full_name, 'pass' if result.passed else 'fail'))
@@ -1877,7 +1890,7 @@ def framework_fail(name: Optional[TestName], way: Optional[WayName], reason: str
# so we need to take care not to blow up with the wrong way
# and report the actual reason for the failure.
try:
- directory = str_removeprefix(str_removeprefix(str(opts.testdir), './'), '.\\')
+ directory = _result_directory(opts)
except:
directory = ''
full_name = '%s(%s)' % (name, way)
@@ -1890,7 +1903,7 @@ def framework_fail(name: Optional[TestName], way: Optional[WayName], reason: str
def framework_warn(name: TestName, way: WayName, reason: str) -> None:
opts = getTestOpts()
- directory = str_removeprefix(str_removeprefix(str(opts.testdir), './'), '.\\')
+ directory = _result_directory(opts)
full_name = name + '(' + way + ')'
if_verbose(1, '*** framework warning for %s %s ' % (full_name, reason))
t.framework_warnings.append(TestResult(directory, name, reason, way))
@@ -2445,19 +2458,23 @@ async def simple_run(name: TestName, way: WayName, prog: str, extra_run_opts: st
dump_stdout(name)
dump_stderr(name)
message = format_bad_exit_code_message(exit_code)
- return failBecause(message)
+ return failBecause(message,
+ stderr=read_stderr(name),
+ stdout=read_stdout(name))
stderr_match = CompareOutput(True) if (opts.ignore_stderr or opts.combined_output) else await stderr_ok(name, way)
if not stderr_match:
+ # The diff already contains the mismatching stream; see Note [Redundant
+ # output in test results].
return failBecause('bad stderr',
- stderr=read_stderr(name),
+ stderr=None if stderr_match.diff else read_stderr(name),
stdout=read_stdout(name),
diff=stderr_match.diff)
stdout_match = CompareOutput(True) if opts.ignore_stdout else await stdout_ok(name, way)
if not stdout_match:
return failBecause('bad stdout',
stderr=read_stderr(name),
- stdout=read_stdout(name),
+ stdout=None if stdout_match.diff else read_stdout(name),
diff=stdout_match.diff)
check_hp = '-hT' in my_rts_flags and opts.check_hp
@@ -2567,8 +2584,9 @@ async def interpreter_run(name: TestName,
if not stderr_match:
if _expect_pass(way):
dump_stderr_for('comp', name)
+ # See Note [Redundant output in test results].
return failBecause('bad stderr',
- stderr=read_stderr(name),
+ stderr=None if stderr_match.diff else read_stderr(name),
stdout=read_stdout(name),
diff=stderr_match.diff)
stdout_match = CompareOutput(True) if opts.ignore_stdout else await stdout_ok(name, way)
@@ -2577,7 +2595,7 @@ async def interpreter_run(name: TestName,
dump_stderr_for('comp', name)
return failBecause('bad stdout',
stderr=read_stderr(name),
- stdout=read_stdout(name),
+ stdout=None if stdout_match.diff else read_stdout(name),
diff=stdout_match.diff)
return passed()
@@ -2635,13 +2653,13 @@ async def stdout_ok(name: TestName, way: WayName) -> CompareOutput:
def read_stdout( name: TestName ) -> str:
path = in_testdir(name, 'run.stdout')
if path.exists():
- return path.read_text(encoding='UTF-8')
+ return path.read_text(encoding='UTF-8', errors='replace')
else:
return ''
def read_diff( diff_file: Path ) -> Optional[str]:
if diff_file.exists():
- diff = diff_file.read_text()
+ diff = diff_file.read_text(encoding='UTF-8', errors='replace')
diff_file.unlink()
return diff or None
else:
@@ -2665,14 +2683,14 @@ async def stderr_ok(name: TestName, way: WayName) -> CompareOutput:
def read_comp_stderr( name: TestName ) -> str:
path = in_testdir(name, 'comp.stderr')
if path.exists():
- return path.read_text(encoding='UTF-8')
+ return path.read_text(encoding='UTF-8', errors='replace')
else:
return ''
def read_stderr_for( phase: str, name: TestName ) -> str:
path = in_testdir(name, phase + '.stderr')
if path.exists():
- return path.read_text(encoding='UTF-8')
+ return path.read_text(encoding='UTF-8', errors='replace')
else:
return ''
@@ -3571,12 +3589,50 @@ def findTFiles(roots: List[str]) -> Iterator[str]:
# -----------------------------------------------------------------------------
# Output a test summary to the specified file object
-def summary(t: TestRun, file: TextIO, color=False) -> None:
+def summary(t: TestRun, file: TextIO, color=False, junit_path: Optional[Path]=None) -> None:
file.write('\n')
+
+ if t.unexpected_failures:
+ # Count output blocks rather than results: a test failing in many ways
+ # collapses to a single block.
+ groups = groupTestOutput(t.unexpected_failures)
+ if len(groups) <= MAX_SUMMARY_OUTPUT_TESTS:
+ printTestOutputSummary(file, groups, color, junit_path)
+ else:
+ where = '; see {}'.format(junit_path) if junit_path else ''
+ header = ('Unexpected failures (more than {}, output omitted{}):'
+ .format(MAX_SUMMARY_OUTPUT_TESTS, where))
+ file.write(colored_if(color, Color.RED, header) + '\n')
+ printTestInfosSummary(file, t.unexpected_failures)
+
+ if t.unexpected_passes:
+ header = 'Unexpected passes:'
+ file.write(colored_if(color, Color.RED, header) + '\n')
+ printTestInfosSummary(file, t.unexpected_passes)
+
+ if t.unexpected_stat_failures:
+ header = 'Unexpected stat failures:'
+ file.write(colored_if(color, Color.RED, header) + '\n')
+ printTestInfosSummary(file, t.unexpected_stat_failures)
+
+ if t.framework_failures:
+ header = 'Framework failures:'
+ file.write(colored_if(color, Color.RED, header) + '\n')
+ printTestInfosSummary(file, t.framework_failures)
+
+ if t.framework_warnings:
+ header = 'Framework warnings:'
+ file.write(colored_if(color, Color.YELLOW, header) + '\n')
+ printTestInfosSummary(file, t.framework_warnings)
+
+ if stopping():
+ warning = 'WARNING: Testsuite run was terminated early'
+ file.write(colored_if(color, Color.YELLOW, warning) + '\n')
+
printUnexpectedTests(file,
[t.unexpected_passes, t.unexpected_failures,
- t.unexpected_stat_failures, t.framework_failures])
+ t.unexpected_stat_failures, t.framework_failures], color)
if len(t.unexpected_failures) > 0 or \
len(t.unexpected_stat_failures) > 0 or \
@@ -3587,7 +3643,8 @@ def summary(t: TestRun, file: TextIO, color=False) -> None:
summary_color = Color.GREEN
assert t.start_time is not None
- file.write(colored(summary_color, 'SUMMARY') + ' for test run started at '
+ summary_header = colored_if(color, summary_color, 'SUMMARY')
+ file.write(summary_header + ' for test run started at '
+ t.start_time.strftime("%c %Z") + '\n'
+ str(datetime.datetime.now() - t.start_time).rjust(8)
+ ' spent to go through\n'
@@ -3619,46 +3676,107 @@ def summary(t: TestRun, file: TextIO, color=False) -> None:
+ ' fragile tests\n'
+ '\n')
- if t.unexpected_passes:
- file.write('Unexpected passes:\n')
- printTestInfosSummary(file, t.unexpected_passes)
-
- if t.unexpected_failures:
- file.write('Unexpected failures:\n')
- printTestInfosSummary(file, t.unexpected_failures)
-
- if t.unexpected_stat_failures:
- file.write('Unexpected stat failures:\n')
- printTestInfosSummary(file, t.unexpected_stat_failures)
-
- if t.framework_failures:
- file.write('Framework failures:\n')
- printTestInfosSummary(file, t.framework_failures)
-
- if t.framework_warnings:
- file.write('Framework warnings:\n')
- printTestInfosSummary(file, t.framework_warnings)
-
- if stopping():
- file.write('WARNING: Testsuite run was terminated early\n')
-
-def printUnexpectedTests(file: TextIO, testInfoss):
+def printUnexpectedTests(file: TextIO, testInfoss, color=False):
unexpected = set(result.testname
for testInfos in testInfoss
for result in testInfos
if not result.testname.endswith('.T'))
if unexpected:
- file.write('Unexpected results from:\n')
+ header = 'Unexpected results from:'
+ file.write(colored_if(color, Color.RED, header) + '\n')
file.write('TEST="' + ' '.join(sorted(unexpected)) + '"\n')
file.write('\n')
+# Per-stream cap on a failing test's output repeated in the final summary.
+MAX_SUMMARY_OUTPUT_LINES = 100
+
+# Above this many output blocks, skip repeating output entirely: the dump
+# would drown out the summary.
+MAX_SUMMARY_OUTPUT_TESTS = 20
+
+# Note [Redundant output in test results]
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+# A failing test result carries up to three pieces of output: `diff`, `stdout`
+# and `stderr`. For an output mismatch these overlap: the diff's `+` lines are
+# the very stream that mismatched, normalised. Reporting both would print the
+# same text twice, so the mismatching stream is dropped at the call sites in
+# favour of the diff, which additionally shows what was expected. The *other*
+# stream is kept: on a stdout mismatch, stderr is independent context.
+#
+# The drop is conditional on there being a diff at all: compare_outputs only
+# runs `diff` when config.verbose >= 1, so under -v0 the stream is the only
+# output there is.
+#
+# Note that, since the drop happens at result construction, it also affects the
+# JUnit report (junit.py).
+
+def strip_diff_header(diff: Optional[str]) -> Optional[str]:
+ # Drop diff(1)'s ---/+++ lines: they name normalised files in the test
+ # directory and carry timestamps, which would also keep otherwise
+ # identical failures from being grouped.
+ if diff is None:
+ return None
+ lines = diff.split('\n')
+ if len(lines) >= 2 and lines[0].startswith('--- ') and lines[1].startswith('+++ '):
+ return '\n'.join(lines[2:])
+ return diff
+
+def sorted_results(testInfos: List[TestResult]) -> List[TestResult]:
+ return sorted(testInfos, key=lambda r: (r.testname.lower(), r.directory, r.way))
+
+# A failure-output block: a representative result, its header-stripped diff,
+# and the ways that share it.
+OutputGroup = Tuple[TestResult, Optional[str], List[WayName]]
+
+# Tests that fail identically in several ways (e.g. normal and g1) share one
+# output block, with the ways collected in the header.
+def groupTestOutput(testInfos: List[TestResult]) -> List[OutputGroup]:
+ # Relies on dicts preserving insertion order.
+ groups = {} # type: Dict[Tuple, OutputGroup]
+ for result in sorted_results(testInfos):
+ diff = strip_diff_header(result.diff)
+ key = (result.testname, result.directory, result.reason,
+ diff, result.stdout, result.stderr)
+ groups.setdefault(key, (result, diff, []))[2].append(result.way)
+ return list(groups.values())
+
+def printTestOutputSummary(file: TextIO,
+ groups: List[OutputGroup],
+ color: bool=False,
+ junit_path: Optional[Path]=None) -> None:
+ # Repeat failing tests' captured output in the summary, so one needn't
+ # hunt for it earlier in a possibly very long log; see #16720.
+ header = '=====> Unexpected failures output summary'
+ file.write(colored_if(color, Color.RED, header) + '\n\n')
+
+ where = ', see {}'.format(junit_path) if junit_path else ''
+ for result, diff, ways in groups:
+ header = '=====> {}({}) ({}) [{}]'.format(
+ result.testname, ', '.join(ways), result.directory + os.sep, result.reason)
+ file.write(colored_if(color, Color.RED, header) + '\n')
+ # See Note [Redundant output in test results] for why these don't overlap.
+ for label, contents in [('Output diff (expected vs actual):', diff),
+ ('Captured stdout:', result.stdout),
+ ('Captured stderr:', result.stderr)]:
+ if contents and contents.strip():
+ lines = contents.rstrip('\n').split('\n')
+ if len(lines) > MAX_SUMMARY_OUTPUT_LINES:
+ omitted = len(lines) - MAX_SUMMARY_OUTPUT_LINES
+ lines = lines[:MAX_SUMMARY_OUTPUT_LINES] \
+ + ['... ({} more lines omitted{})'.format(omitted, where)]
+ s = colored_if(color, Color.CYAN, label) + '\n' \
+ + ''.join(l + '\n' for l in lines)
+ # Test output can contain characters that file's encoding
+ # cannot represent; replace rather than crash (cf safe_print).
+ enc = getattr(file, 'encoding', None) or 'utf-8'
+ file.write(s.encode(enc, errors='replace').decode(enc))
+ footer = '<===== end of unexpected failures output summary'
+ file.write(colored_if(color, Color.RED, footer) + '\n\n')
+
def printTestInfosSummary(file: TextIO, testInfos):
- maxDirLen = max(len(tr.directory) for tr in testInfos)
- for result in sorted(testInfos, key=lambda r: (r.testname.lower(), r.way, r.directory)):
- directory = result.directory.ljust(maxDirLen)
- file.write(' {directory} {r.testname} [{r.reason}] ({r.way})\n'.format(
- r = result,
- directory = directory))
+ for result in sorted_results(testInfos):
+ path = os.path.join(result.directory, result.testname)
+ file.write(' {path} [{r.reason}] ({r.way})\n'.format(r=result, path=path))
file.write('\n')
def modify_lines(s: str, f: Callable[[str], str]) -> str:
=====================================
testsuite/tests/ghc-e/should_fail/T18441fail7.stderr
=====================================
@@ -5,8 +5,12 @@ IO error: "Abcde" does not exist
While handling ghc-10.1-inplace:GHC.Utils.Panic.GhcException:
|
| IO error: "Abcde" does not exist
+ |
+ | HasCallStack backtrace:
+ | throw, called at compiler/GHC/Utils/Panic.hs:180:21 in ghc-10.1-inplace:GHC.Utils.Panic
+ | throwGhcException, called at ghc/GHCi/UI.hs:2851:21 in ghc-bin-10.1.20260801-inplace:GHCi.UI
HasCallStack backtrace:
- throwIO, called at compiler\GHC\Utils\Error.hs:499:19 in ghc-10.1-inplace:GHC.Utils.Error
+ throwIO, called at compiler/GHC/Utils/Error.hs:513:19 in ghc-10.1-inplace:GHC.Utils.Error
1
=====================================
testsuite/tests/ghc-e/should_run/ghc-e005.stderr
=====================================
@@ -4,3 +4,8 @@ foo
HasCallStack backtrace:
error, called at ghc-e005.hs:12:10 in main:Main
+
+
+HasCallStack backtrace:
+ throwIO, called at ghc\GHCi\UI.hs:1655:31 in ghc-bin-10.1.20260629-inplace:GHCi.UI
+
=====================================
testsuite/tests/saks/should_compile/T18725a.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE ExplicitForAll, KindSignatures, StandaloneKindSignatures,
+ DataKinds, GADTs #-}
+
+module T18725a where
+
+import Data.Kind (Type)
+
+type U :: Type
+data U where P :: forall u. E u -> U
+data E (u :: U)
=====================================
testsuite/tests/saks/should_compile/all.T
=====================================
@@ -35,6 +35,7 @@ test('T16726', normal, compile, [''])
test('T16731', normal, compile, [''])
test('T16721', normal, ghci_script, ['T16721.script'])
test('T16756a', normal, compile, [''])
+test('T18725a', normal, compile, [''])
test('saks027', req_th, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('saks028', req_th, compile, [''])
=====================================
testsuite/tests/saks/should_fail/T18725b.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE ExplicitForAll, KindSignatures, StandaloneKindSignatures,
+ DataKinds, GADTs #-}
+
+module T18725b where
+
+-- type U :: Type -- Rejected without the sig
+data U where P :: forall u. E u -> U
+data E (u :: U)
=====================================
testsuite/tests/saks/should_fail/T18725b.stderr
=====================================
@@ -0,0 +1,6 @@
+T18725b.hs:8:14: error: [GHC-85413]
+ • Type constructor ‘U’ cannot be used here
+ (it is defined and used in the same recursive group)
+ • In the kind ‘U’
+ In the data type declaration for ‘E’
+
=====================================
testsuite/tests/saks/should_fail/all.T
=====================================
@@ -38,3 +38,5 @@ test('T18863d', normal, compile_fail, [''])
test('T20916', normal, compile_fail, [''])
test('saks018-fail', normal, compile_fail, [''])
test('saks021-fail', normal, compile_fail, [''])
+test('T18725b', normal, compile_fail, [''])
+
=====================================
testsuite/tests/th/T20902.hs
=====================================
@@ -0,0 +1,13 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module T20902 where
+
+import Language.Haskell.TH
+
+data T = FU | FUN deriving Show
+
+expr1 = $( conE (mkName "FU") )
+expr2 = $( conE (mkName "FUN") )
+expr3 = $( [| FU |] )
+expr4 = $( [| FUN |] )
+
=====================================
testsuite/tests/th/all.T
=====================================
@@ -651,3 +651,5 @@ test('T26099', normal, compile_fail, [''])
test('T8306_th', only_ways(['ghci']), ghci_script, ['T8306_th.script'])
test('T26862_th', only_ways(['ghci']), ghci_script, ['T26862_th.script'])
test('T27022', normal, compile_and_run, [''])
+test('T20902', normal, compile, [''])
+
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -1555,26 +1555,26 @@ instance ExactPrint ModuleName where
-- ---------------------------------------------------------------------
-instance ExactPrint (LocatedP (WarningTxt GhcPs)) where
- getAnnotationEntry = entryFromLocatedA
- setAnnotationAnchor = setAnchorAn
+instance ExactPrint (WarningTxt GhcPs) where
+ getAnnotationEntry _ = NoEntryVal
+ setAnnotationAnchor a _ _ _ = a
- exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (WarningTxt src mb_cat ws)) = do
+ exact (WarningTxt (src, AnnPragma o c (os,cs) l1 l2 t m) mb_cat ws) = do
o' <- markAnnOpen'' o src "{-# WARNING"
mb_cat' <- markAnnotated mb_cat
os' <- markEpToken os
ws' <- mapM markAnnotated ws
cs' <- markEpToken cs
c' <- markEpToken c
- return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (WarningTxt src mb_cat' ws'))
+ return (WarningTxt (src, AnnPragma o' c' (os',cs') l1 l2 t m) mb_cat' ws')
- exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (DeprecatedTxt src ws)) = do
+ exact (DeprecatedTxt (src, AnnPragma o c (os,cs) l1 l2 t m) ws) = do
o' <- markAnnOpen'' o src "{-# DEPRECATED"
os' <- markEpToken os
ws' <- mapM markAnnotated ws
cs' <- markEpToken cs
c' <- markEpToken c
- return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (DeprecatedTxt src ws'))
+ return (DeprecatedTxt (src, AnnPragma o' c' (os',cs') l1 l2 t m) ws')
instance ExactPrint (InWarningCategory GhcPs) where
getAnnotationEntry _ = NoEntryVal
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1a2bc8f4d302166c3d13c258c24223…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1a2bc8f4d302166c3d13c258c24223…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/hie-file-improvements] 2 commits: hie files: Dump the type table when dumping with -ddump-hie
by Hannes Siebenhandl (＠fendor) 05 Aug '26
by Hannes Siebenhandl (＠fendor) 05 Aug '26
05 Aug '26
Hannes Siebenhandl pushed to branch wip/hie-file-improvements at Glasgow Haskell Compiler / GHC
Commits:
84281173 by Zubin Duggal at 2026-08-05T09:57:18+02:00
hie files: Dump the type table when dumping with -ddump-hie
- - - - -
8d9e95e9 by Zubin Duggal at 2026-08-05T09:57:18+02:00
hie files: Take evidence for quantified constraints into account when saving evidence terms to the hie ast
Fixes #25709
- - - - -
6 changed files:
- compiler/GHC/Driver/Main/Passes.hs
- compiler/GHC/Iface/Ext/Types.hs
- testsuite/tests/hiefile/should_compile/T24493.stderr
- + testsuite/tests/hiefile/should_run/T25709.hs
- + testsuite/tests/hiefile/should_run/T25709.stdout
- testsuite/tests/hiefile/should_run/all.T
Changes:
=====================================
compiler/GHC/Driver/Main/Passes.hs
=====================================
@@ -92,7 +92,7 @@ import GHC.Iface.Make
import GHC.Iface.Recomp
import GHC.Iface.Tidy
import GHC.Iface.Ext.Ast ( mkHieFile )
-import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module )
+import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module, hie_types )
import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result)
import GHC.Iface.Ext.Debug ( diffFile, validateScopes )
@@ -167,7 +167,7 @@ import GHC.Data.StringBuffer
import GHC.Data.Maybe
import qualified GHC.Data.Strict as Strict
-
+import qualified Data.Array as A
import Data.List ( nub, isPrefixOf, partition )
import qualified Data.List.NonEmpty as NE
import Control.Monad
@@ -332,7 +332,10 @@ extract_renamed_stuff mod_summary tc_result = do
hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)
let out_file = ml_hie_file $ ms_location mod_summary
liftIO $ writeHieFile out_file hieFile
- liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile)
+ let hie_doc =
+ ppr (hie_asts hieFile)
+ $+$ ppr (A.assocs $ hie_types hieFile)
+ liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell hie_doc
-- Validate HIE files
when (gopt Opt_ValidateHie dflags) $ do
=====================================
compiler/GHC/Iface/Ext/Types.hs
=====================================
@@ -159,6 +159,18 @@ data HieType a
| HCoercionTy
deriving (Functor, Foldable, Traversable, Eq)
+instance Outputable a => Outputable (HieType a) where
+ ppr (HTyVarTy name) = ppr name
+ ppr (HAppTy fun arg) = parens $ ppr fun <+> ppr arg
+ ppr (HTyConApp tc args) = parens $ ppr tc <+> ppr args
+ ppr (HForAllTy ((name, ty), flag) body) =
+ text "forall" <+> ppr flag <+> ppr name O.<> text ":" <+> ppr ty O.<> text "." <+> ppr body
+ ppr (HFunTy mult arg res) = parens $ ppr arg <+> arrow <+> ppr res <+> ppr mult
+ ppr (HQualTy ctxt ty) = parens $ ppr ctxt <+> text "=>" <+> ppr ty
+ ppr (HLitTy lit) = ppr lit
+ ppr (HCastTy ty) = text "cast" <+> ppr ty
+ ppr HCoercionTy = text "<coercion>"
+
type HieTypeFlat = HieType TypeIndex
-- | Roughly isomorphic to the original core 'Type'.
@@ -222,6 +234,10 @@ instance Binary (HieArgs TypeIndex) where
put_ bh (HieArgs xs) = put_ bh xs
get bh = HieArgs <$> get bh
+instance Outputable a => Outputable (HieArgs a) where
+ ppr (HieArgs args) = braces $ hsep $ punctuate comma $ map pprArg args
+ where pprArg (vis, ty) = (if vis then id else parens) (ppr ty)
+
-- A HiePath is just a lexical FastString. We use a lexical FastString to avoid
-- non-determinism when printing or storing HieASTs which are sorted by their
=====================================
testsuite/tests/hiefile/should_compile/T24493.stderr
=====================================
@@ -1,3 +1,4 @@
+
==================== HIE AST ====================
File: T24493.hs
Node@T24493.hs:(1,8)-(3,8): Source: From source
@@ -25,9 +26,10 @@ Node@T24493.hs:(1,8)-(3,8): Source: From source
Node@T24493.hs:3:6-8: Source: From source
{(annotations: {(HsLit, HsExpr)}), (types: [0]),
(identifier info: {})}
-
+
+[(0, (GHC.Internal.Base.String {}))]
Got valid scopes
-Got no roundtrip errors
\ No newline at end of file
+Got no roundtrip errors
=====================================
testsuite/tests/hiefile/should_run/T25709.hs
=====================================
@@ -0,0 +1,40 @@
+{-# LANGUAGE QuantifiedConstraints#-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+module Main where
+
+import TestUtils
+import qualified Data.Map.Strict as M
+import qualified Data.Set as S
+import Data.Either
+import Data.Maybe
+import Data.Bifunctor (first)
+import GHC.Plugins (moduleNameString, nameStableString, nameOccName, occNameString, isDerivedOccName)
+import GHC.Iface.Ext.Types
+
+
+import Data.Typeable
+
+data Some c where
+ Some :: c a => a -> Some c
+
+extractSome :: (Typeable a, forall x. c x => Typeable x) => Some c -> Maybe a
+extractSome (Some a) = cast a
+
+f :: (forall x. Ord x => Eq [x]) => ()
+f = ()
+{-# NOINLINE f #-}
+
+g :: ()
+g = f
+
+useQC :: forall c a. (c a, forall x. c x => Show x) => a -> String
+useQC x = show x
+
+points :: [(Int,Int)]
+points = [(22,26),(29, 5), (32, 13)]
+
+main = do
+ (df, hf) <- readTestHie "T25709.hie"
+ let refmap = generateReferencesMap $ getAsts $ hie_asts hf
+ traverse (explainEv df hf refmap) points
=====================================
testsuite/tests/hiefile/should_run/T25709.stdout
=====================================
@@ -0,0 +1,110 @@
+==========================
+At point (22,26), we found:
+==========================
+┌
+│ $dTypeable at T25709.hs:22:14-19, of type: Typeable a
+│ is an evidence variable bound by a let, depending on: [$dTypeable]
+│ with scope: LocalScope T25709.hs:22:14-29
+│
+│ Defined at <no location info>
+└
+|
+`- ┌
+ │ $dTypeable at T25709.hs:22:1-29, of type: Typeable a
+ │ is an evidence variable bound by a HsWrapper
+ │ with scope: LocalScope T25709.hs:22:1-29
+ │ bound at: T25709.hs:22:1-29
+ │ Defined at <no location info>
+ └
+
+┌
+│ $dTypeable at T25709.hs:22:14-19, of type: Typeable a
+│ is an evidence variable bound by a let, depending on: [df, irred]
+│ with scope: LocalScope T25709.hs:22:14-29
+│
+│ Defined at <no location info>
+└
+|
++- ┌
+| │ df at T25709.hs:22:1-29, of type: forall x. c x => Typeable x
+| │ is an evidence variable bound by a HsWrapper
+| │ with scope: LocalScope T25709.hs:22:1-29
+| │ bound at: T25709.hs:22:1-29
+| │ Defined at <no location info>
+| └
+|
+`- ┌
+ │ irred at T25709.hs:22:14-19, of type: c a
+ │ is an evidence variable bound by a let, depending on: [irred]
+ │ with scope: LocalScope T25709.hs:22:14-29
+ │
+ │ Defined at <no location info>
+ └
+ |
+ `- ┌
+ │ irred at T25709.hs:22:14-19, of type: c a
+ │ is an evidence variable bound by a pattern
+ │ with scope: LocalScope T25709.hs:22:14-29
+ │
+ │ Defined at <no location info>
+ └
+
+==========================
+At point (29,5), we found:
+==========================
+┌
+│ df at T25709.hs:1:1, of type: forall x. Ord x => Eq [x]
+│ is an evidence variable bound by a let, depending on: [$p1Ord,
+│ $fEqList]
+│ with scope: ModuleScope
+│
+│ Defined at <no location info>
+└
+|
++- ┌
+| │ $p1Ord at T25709.hs:1:1, of type: forall a. Ord a => Eq a
+| │ is a usage of an external evidence variable
+| │ Defined in `GHC.Internal.Classes'
+| └
+|
+`- ┌
+ │ $fEqList at T25709.hs:1:1, of type: forall a. Eq a => Eq [a]
+ │ is a usage of an external evidence variable
+ │ Defined in `GHC.Internal.Classes'
+ └
+
+==========================
+At point (32,13), we found:
+==========================
+┌
+│ $dShow at T25709.hs:32:1-16, of type: Show a
+│ is an evidence variable bound by a let, depending on: [df, irred]
+│ with scope: LocalScope T25709.hs:32:1-16
+│ bound at: T25709.hs:32:1-16
+│ Defined at <no location info>
+└
+|
++- ┌
+| │ df at T25709.hs:32:1-16, of type: forall x. c x => Show x
+| │ is an evidence variable bound by a HsWrapper
+| │ with scope: LocalScope T25709.hs:32:1-16
+| │ bound at: T25709.hs:32:1-16
+| │ Defined at <no location info>
+| └
+|
+`- ┌
+ │ irred at T25709.hs:32:1-16, of type: c a
+ │ is an evidence variable bound by a let, depending on: [irred]
+ │ with scope: LocalScope T25709.hs:32:1-16
+ │ bound at: T25709.hs:32:1-16
+ │ Defined at <no location info>
+ └
+ |
+ `- ┌
+ │ irred at T25709.hs:32:1-16, of type: c a
+ │ is an evidence variable bound by a HsWrapper
+ │ with scope: LocalScope T25709.hs:32:1-16
+ │ bound at: T25709.hs:32:1-16
+ │ Defined at <no location info>
+ └
+
=====================================
testsuite/tests/hiefile/should_run/all.T
=====================================
@@ -8,4 +8,5 @@ test('HieVdq', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUti
test('T23540', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
test('T23120', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
test('T24544', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
-test('HieGadtConSigs', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
\ No newline at end of file
+test('HieGadtConSigs', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
+test('T25709', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9d32d5479bcf272021b24068330201…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9d32d5479bcf272021b24068330201…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0