- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: ci: Actually pass --ignore-perf-failures to the testsuite driver
by Marge Bot (＠marge-bot) 12 Sep '26

12 Sep '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 4e9297ea by Simon Jakobi at 2026-09-11T08:32:45-04:00 ci: Actually pass --ignore-perf-failures to the testsuite driver 684c0018d9 changed the IGNORE_PERF_FAILURES handling to append to RUNTEST_ARGS with bash array syntax, but the three use sites still expand RUNTEST_ARGS as a scalar, which yields only the first array element. The appended flag was therefore dropped in every job, so perf improvements kept failing Marge Bot batches and master pipelines, contrary to #19562. Append as a string instead, matching the existing --force-colors append in test_hadrian. Fixes #27563. Assisted-by: Claude Fable 5.1 - - - - - 4f78dfdf by Simon Jakobi at 2026-09-11T08:33:24-04:00 testsuite: Give T26537 a 1.5x compile timeout Its -fregs-graph compile step tends to time out in unoptimized builds (#27188, #27776). Assisted-by: Claude Fable 5.1 - - - - - 130286e3 by Alan Zimmerman at 2026-09-11T08:34:08-04:00 EPA: Remove ListBanana / ListParens from AnnListBrackets This is a step towards making AnnList only represent lists of items which can have either braces or layout. - - - - - cc447dac by Simon Jakobi at 2026-09-11T14:43:13-04:00 Reject ~, UNPACK and multiplicity annotations on type data fields Only `!` was rejected so far. `~`, UNPACK and multiplicity annotations were silently accepted. None of them make sense at the type level, so restriction (R3) of Note [Type data declarations] now covers all of them. Fixes #27732. Assisted-by: Claude Fable 5.1 - - - - - da7bb249 by Alan Zimmerman at 2026-09-11T14:43:14-04:00 EPA: Add a Note for the exact print main loop - - - - - 29 changed files: - .gitlab/ci.sh - + changelog.d/27732 - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Tc/Errors/Types.hs - docs/users_guide/exts/type_data.rst - testsuite/tests/codeGen/should_run/all.T - testsuite/tests/ghc-api/T25121_status.stdout - + testsuite/tests/type-data/should_fail/T27732a.hs - + testsuite/tests/type-data/should_fail/T27732a.stderr - + testsuite/tests/type-data/should_fail/T27732b.hs - + testsuite/tests/type-data/should_fail/T27732b.stderr - + testsuite/tests/type-data/should_fail/T27732c.hs - + testsuite/tests/type-data/should_fail/T27732c.stderr - + testsuite/tests/type-data/should_fail/T27732d.hs - + testsuite/tests/type-data/should_fail/T27732d.stderr - + testsuite/tests/type-data/should_fail/T27732e.hs - + testsuite/tests/type-data/should_fail/T27732e.stderr - + testsuite/tests/type-data/should_fail/T27732f.hs - + testsuite/tests/type-data/should_fail/T27732f.stderr - testsuite/tests/type-data/should_fail/TDStrictnessGADT.stderr - testsuite/tests/type-data/should_fail/TDStrictnessH98.stderr - testsuite/tests/type-data/should_fail/all.T - utils/check-exact/ExactPrint.hs - utils/check-exact/Utils.hs Changes: ===================================== .gitlab/ci.sh ===================================== @@ -1106,7 +1106,7 @@ if [ "${CI_COMMIT_BRANCH:-}" == "master" ] && [ "${CI_PROJECT_PATH:-}" == "ghc/ fi fi if [ -n "${IGNORE_PERF_FAILURES:-}" ]; then - RUNTEST_ARGS=( "${RUNTEST_ARGS[@]:-}" "--ignore-perf-failures=$IGNORE_PERF_FAILURES" ) + RUNTEST_ARGS="${RUNTEST_ARGS:-} --ignore-perf-failures=$IGNORE_PERF_FAILURES" fi if [[ -z ${BIGNUM_BACKEND:-} ]]; then BIGNUM_BACKEND=gmp; fi ===================================== changelog.d/27732 ===================================== @@ -0,0 +1,8 @@ +section: language +synopsis: Reject ``~``, ``UNPACK`` and multiplicity annotations on ``type data`` fields +description: + ``type data`` declarations (:extension:`TypeData`) now reject any + strictness, unpackedness or multiplicity annotation on constructor + fields. Previously only ``!`` was rejected. +mrs: !16563 +issues: #27732 ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -294,7 +294,7 @@ type instance XDo GhcPs = (AnnList, EpaLocation) type instance XDo GhcRn = NoExtField type instance XDo GhcTc = Type -type instance XExplicitList GhcPs = AnnList +type instance XExplicitList GhcPs = (EpToken "[", EpToken "]") type instance XExplicitList GhcRn = NoExtField type instance XExplicitList GhcTc = Type -- GhcPs: ExplicitList includes all source-level @@ -1440,7 +1440,7 @@ type instance XCmdArrApp GhcPs = (IsUnicodeSyntax, EpaLocation) type instance XCmdArrApp GhcRn = NoExtField type instance XCmdArrApp GhcTc = Type -type instance XCmdArrForm GhcPs = AnnList +type instance XCmdArrForm GhcPs = (EpUniToken "(|" "⦇", EpUniToken "|)" "⦈") -- | fixity (filled in by the renamer), for forms that were converted from -- OpApp's by the renamer type instance XCmdArrForm GhcRn = Maybe Fixity ===================================== compiler/GHC/Hs/Pat.hs ===================================== @@ -104,7 +104,7 @@ type instance XBangPat GhcPs = EpToken "!" type instance XBangPat GhcRn = NoExtField type instance XBangPat GhcTc = NoExtField -type instance XListPat GhcPs = AnnList +type instance XListPat GhcPs = (EpToken "[", EpToken "]") -- After parsing, ListPat can refer to a built-in Haskell list pattern -- or an overloaded list pattern. type instance XListPat GhcRn = NoExtField ===================================== compiler/GHC/Parser.y ===================================== @@ -3282,7 +3282,7 @@ aexp2 :: { ECP } -- arrow notation extension | '(|' aexp cmdargs '|)' {% runPV (unECP $2) >>= \ $2 -> fmap ecpFromCmd $ - amsA' (sLL $1 $> $ HsCmdArrForm (AnnList (glRM $1) (ListBanana (epUniTok $1) (epUniTok $4)) []) $2 Prefix + amsA' (sLL $1 $> $ HsCmdArrForm (epUniTok $1, epUniTok $4) $2 Prefix (reverse $3)) } projection :: { Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))) } @@ -3414,9 +3414,9 @@ tup_tail :: { forall b. DisambECP b => PV [Either (EpAnn Bool) (LocatedA b)] } -- Never empty. list :: { forall b. DisambECP b => SrcSpan -> (EpaLocation, EpaLocation) -> PV (LocatedA b) } : texp { \loc (ao,ac) -> unECP $1 >>= \ $1 -> - mkHsExplicitListPV loc [$1] (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) []) } + mkHsExplicitListPV loc [$1] (EpTok ao, EpTok ac) } | lexps { \loc (ao,ac) -> $1 >>= \ $1 -> - mkHsExplicitListPV loc (reverse $1) (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) []) } + mkHsExplicitListPV loc (reverse $1) (EpTok ao, EpTok ac) } | texp '..' { \loc (ao,ac) -> unECP $1 >>= \ $1 -> amsA' (L loc $ ArithSeq (AnnArithSeq (EpTok ao) Nothing (epTok $2) (EpTok ac)) Nothing (From $1)) >>= ecpFromExp' } ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -519,10 +519,8 @@ data AnnList } deriving (Data,Eq) data AnnListBrackets - = ListParens (EpToken "(") (EpToken ")") - | ListBraces (EpToken "{") (EpToken "}") + = ListBraces (EpToken "{") (EpToken "}") | ListSquare (EpToken "[") (EpToken "]") - | ListBanana (EpUniToken "(|" "⦇") (EpUniToken "|)" "⦈") | ListNone deriving (Data,Eq) @@ -1094,10 +1092,8 @@ instance Outputable AnnList where = text "AnnList" <+> ppr l <+> ppr p <+> ppr s instance Outputable AnnListBrackets where - ppr (ListParens o c) = text "ListParens" <+> ppr o <+> ppr c ppr (ListBraces o c) = text "ListBraces" <+> ppr o <+> ppr c ppr (ListSquare o c) = text "ListSquare" <+> ppr o <+> ppr c - ppr (ListBanana o c) = text "ListBanana" <+> ppr o <+> ppr c ppr ListNone = text "ListNone" instance Outputable AnnCType where ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -1827,7 +1827,7 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where mkHsTySigPV :: SrcSpanAnnA -> LocatedA b -> LHsType GhcPs -> TokDcolon -> PV (LocatedA b) -- | Disambiguate "[a,b,c]" (list syntax) - mkHsExplicitListPV :: SrcSpan -> [LocatedA b] -> AnnList -> PV (LocatedA b) + mkHsExplicitListPV :: SrcSpan -> [LocatedA b] -> (EpToken "[", EpToken "]") -> PV (LocatedA b) -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices) mkHsSplicePV :: Located (HsUntypedSplice GhcPs) -> PV (LocatedA b) -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates) ===================================== compiler/GHC/Rename/Module.hs ===================================== @@ -71,7 +71,6 @@ import GHC.Data.Graph.Directed ( SCC, flattenSCC, Node(..) , stronglyConnCompFromEdgedVerticesUniq ) import GHC.Data.OrdList import qualified GHC.LanguageExtensions as LangExt -import GHC.Core.DataCon ( isSrcStrict ) import Control.Monad import Data.Bifunctor ( first ) @@ -2116,8 +2115,8 @@ rnDataDefn doc (HsDataDefn { dd_cType = cType, dd_ctxt = context, dd_cons = cond = do { ; when (has_labelled_fields condecl) $ failWith $ TcRnTypeDataForbids TypeDataForbidsLabelledFields - ; when (has_strictness_flags condecl) $ - failWith $ TcRnTypeDataForbids TypeDataForbidsStrictnessAnnotations + ; when (has_field_annotations condecl) $ + failWith $ TcRnTypeDataForbids TypeDataForbidsFieldAnnotations } has_labelled_fields (ConDeclGADT { con_g_args = RecConGADT _ _ }) = True @@ -2125,13 +2124,19 @@ rnDataDefn doc (HsDataDefn { dd_cType = cType, dd_ctxt = context, dd_cons = cond = not (null (unLoc flds)) has_labelled_fields _ = False - has_strictness_flags condecl - = any isSrcStrict (con_arg_bangs condecl) + has_field_annotations condecl + = not (all unannotated (con_arg_fields condecl)) + where + unannotated (CDF { cdf_bang = NoSrcStrict + , cdf_unpack = NoSrcUnpack + , cdf_multiplicity = HsModifiedFunArr _ [] (HsStandardArr _) }) + = True + unannotated _ = False - con_arg_bangs (ConDeclGADT { con_g_args = PrefixConGADT _ args }) = map cdf_bang args - con_arg_bangs (ConDeclH98 { con_args = PrefixCon _ args }) = map cdf_bang args - con_arg_bangs (ConDeclH98 { con_args = InfixCon _ arg1 arg2 }) = [cdf_bang arg1, cdf_bang arg2] - con_arg_bangs _ = [] + con_arg_fields (ConDeclGADT { con_g_args = PrefixConGADT _ args }) = args + con_arg_fields (ConDeclH98 { con_args = PrefixCon _ args }) = args + con_arg_fields (ConDeclH98 { con_args = InfixCon _ arg1 arg2 }) = [arg1, arg2] + con_arg_fields _ = [] {- Note [Type data declarations] @@ -2166,8 +2171,9 @@ preceded by `type`, with the following restrictions: (R2) There are no labelled fields. Perhaps these could be supported using type families, but they are omitted for now. -(R3) There are no strictness flags, because they don't make sense at - the type level. +(R3) There are no strictness, unpackedness or multiplicity annotations + (!, ~, {-# UNPACK #-}, {-# NOUNPACK #-}, %m ->, ⊸), because they + don't make sense at the type level. (R4) The types of the constructors contain no constraints. ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -2866,6 +2866,12 @@ data TcRnMessage where type-data/should_fail/TDRecordsH98 type-data/should_fail/TDStrictnessGADT type-data/should_fail/TDStrictnessH98 + type-data/should_fail/T27732a + type-data/should_fail/T27732b + type-data/should_fail/T27732c + type-data/should_fail/T27732d + type-data/should_fail/T27732e + type-data/should_fail/T27732f -} TcRnTypeDataForbids :: !TypeDataForbids -> TcRnMessage @@ -4541,15 +4547,15 @@ data ZonkerMessage where data TypeDataForbids = TypeDataForbidsDatatypeContexts | TypeDataForbidsLabelledFields - | TypeDataForbidsStrictnessAnnotations + | TypeDataForbidsFieldAnnotations | TypeDataForbidsDerivingClauses deriving Generic instance Outputable TypeDataForbids where - ppr TypeDataForbidsDatatypeContexts = text "Data type contexts" - ppr TypeDataForbidsLabelledFields = text "Labelled fields" - ppr TypeDataForbidsStrictnessAnnotations = text "Strictness flags" - ppr TypeDataForbidsDerivingClauses = text "Deriving clauses" + ppr TypeDataForbidsDatatypeContexts = text "Data type contexts" + ppr TypeDataForbidsLabelledFields = text "Labelled fields" + ppr TypeDataForbidsFieldAnnotations = text "Strictness, unpackedness or multiplicity annotations" + ppr TypeDataForbidsDerivingClauses = text "Deriving clauses" -- | Specifies which back ends can handle a requested foreign import or export type ExpectedBackends = [Backend] ===================================== docs/users_guide/exts/type_data.rst ===================================== @@ -33,7 +33,8 @@ either an ordinary algebraic data type or a GADT, prefixed with the keyword ``type``, except that it may not contain a datatype context (even with :extension:`DatatypeContexts`), labelled fields, -strictness flags, or +:ref:`strictness <strict-haskell>`, :ref:`unpackedness <unpack-pragma>` or +:ref:`multiplicity <linear-types>` annotations, or a ``deriving`` clause. The only constraints permitted in the types of constructors are ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -258,7 +258,7 @@ test('T24893', normal, compile_and_run, ['-O']) test('CCallConv', [req_c], compile_and_run, ['CCallConv_c.c']) test('T25364', normal, compile_and_run, ['']) test('T26061', normal, compile_and_run, ['']) -test('T26537', normal, compile_and_run, ['-O2 -fregs-graph']) +test('T26537', compile_timeout_multiplier(1.5), compile_and_run, ['-O2 -fregs-graph']) test('T24016', normal, compile_and_run, ['-O1 -fPIC']) test('T27046', [ req_cmm ===================================== testsuite/tests/ghc-api/T25121_status.stdout ===================================== @@ -15,7 +15,7 @@ X(FunArr) match = NoExtField X(ExprWithTySig) match = EpUniToken "::" "\8759" X(UntypedSplice) match = NoExtField X(ExplicitList) mismatch - >>> AnnList + >>> ((EpToken "["),(EpToken "]")) <<< ((EpToken "'"),(EpToken "["),(EpToken "]")) X(ExplicitTuple) mismatch >>> AnnParen ===================================== testsuite/tests/type-data/should_fail/T27732a.hs ===================================== @@ -0,0 +1,4 @@ +{-# LANGUAGE TypeData, LazyFieldAnnotations #-} +module T27732a where + +type data T a = Cons ~a ===================================== testsuite/tests/type-data/should_fail/T27732a.stderr ===================================== @@ -0,0 +1,3 @@ +T27732a.hs:4:17: error: [GHC-67297] + Strictness, unpackedness or multiplicity annotations are not allowed in type data declarations. + ===================================== testsuite/tests/type-data/should_fail/T27732b.hs ===================================== @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeData, LazyFieldAnnotations #-} +module T27732b where + +type data T a where + Cons :: ~a -> T a ===================================== testsuite/tests/type-data/should_fail/T27732b.stderr ===================================== @@ -0,0 +1,3 @@ +T27732b.hs:5:6: error: [GHC-67297] + Strictness, unpackedness or multiplicity annotations are not allowed in type data declarations. + ===================================== testsuite/tests/type-data/should_fail/T27732c.hs ===================================== @@ -0,0 +1,4 @@ +{-# LANGUAGE TypeData #-} +module T27732c where + +type data T a = Cons {-# UNPACK #-} a ===================================== testsuite/tests/type-data/should_fail/T27732c.stderr ===================================== @@ -0,0 +1,3 @@ +T27732c.hs:4:17: error: [GHC-67297] + Strictness, unpackedness or multiplicity annotations are not allowed in type data declarations. + ===================================== testsuite/tests/type-data/should_fail/T27732d.hs ===================================== @@ -0,0 +1,4 @@ +{-# LANGUAGE TypeData #-} +module T27732d where + +type data T a = Cons {-# NOUNPACK #-} a ===================================== testsuite/tests/type-data/should_fail/T27732d.stderr ===================================== @@ -0,0 +1,3 @@ +T27732d.hs:4:17: error: [GHC-67297] + Strictness, unpackedness or multiplicity annotations are not allowed in type data declarations. + ===================================== testsuite/tests/type-data/should_fail/T27732e.hs ===================================== @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeData, LinearTypes #-} +module T27732e where + +type data T where + MkT :: Int %1 -> T ===================================== testsuite/tests/type-data/should_fail/T27732e.stderr ===================================== @@ -0,0 +1,3 @@ +T27732e.hs:5:3: error: [GHC-67297] + Strictness, unpackedness or multiplicity annotations are not allowed in type data declarations. + ===================================== testsuite/tests/type-data/should_fail/T27732f.hs ===================================== @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeData, LinearTypes, UnicodeSyntax #-} +module T27732f where + +type data T where + MkT :: Int ⊸ T ===================================== testsuite/tests/type-data/should_fail/T27732f.stderr ===================================== @@ -0,0 +1,3 @@ +T27732f.hs:5:3: error: [GHC-67297] + Strictness, unpackedness or multiplicity annotations are not allowed in type data declarations. + ===================================== testsuite/tests/type-data/should_fail/TDStrictnessGADT.stderr ===================================== @@ -1,3 +1,3 @@ +TDStrictnessGADT.hs:5:6: error: [GHC-67297] + Strictness, unpackedness or multiplicity annotations are not allowed in type data declarations. -TDStrictnessGADT.hs:5:6: [GHC-67297] - Strictness flags are not allowed in type data declarations. ===================================== testsuite/tests/type-data/should_fail/TDStrictnessH98.stderr ===================================== @@ -1,3 +1,3 @@ +TDStrictnessH98.hs:4:17: error: [GHC-67297] + Strictness, unpackedness or multiplicity annotations are not allowed in type data declarations. -TDStrictnessH98.hs:4:17: [GHC-67297] - Strictness flags are not allowed in type data declarations. ===================================== testsuite/tests/type-data/should_fail/all.T ===================================== @@ -13,3 +13,9 @@ test('TDStrictnessGADT', normal, compile_fail, ['']) test('TDStrictnessH98', normal, compile_fail, ['']) test('TDTagToEnum', normal, compile_fail, ['']) test('T22332b', normal, compile_fail, ['']) +test('T27732a', normal, compile_fail, ['']) +test('T27732b', normal, compile_fail, ['']) +test('T27732c', normal, compile_fail, ['']) +test('T27732d', normal, compile_fail, ['']) +test('T27732e', normal, compile_fail, ['']) +test('T27732f', normal, compile_fail, ['']) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -140,9 +140,9 @@ defaultEPState = EPState -- | The R part of RWS. The environment. Updated via 'local' as we -- enter a new AST element, having a different anchor point. -data EPOptions m a = EPOptions - { epTokenPrint :: String -> m a - , epWhitespacePrint :: String -> m a +data EPOptions m w = EPOptions + { epTokenPrint :: String -> m w + , epWhitespacePrint :: String -> m w } -- | Helper to create a 'EPOptions' @@ -163,8 +163,7 @@ stringOptions = epOptions return return deltaOptions :: EPOptions Identity () deltaOptions = epOptions (\_ -> return ()) (\_ -> return ()) -data EPWriter a = EPWriter - { output :: !a } +data EPWriter w = EPWriter { output :: !w } instance Monoid w => Semigroup (EPWriter w) where (EPWriter a) <> (EPWriter b) = EPWriter (a <> b) @@ -239,7 +238,220 @@ setAnchorEpaL (EpAnn _ an _) anc ts cs = EpAnn anc (setTrailing (an {al_anchor = -- | Key entry point. Switches to an independent AST element with its -- own annotation, calculating new offsets, etc markAnnotated :: (Monad m, Monoid w, ExactPrint a) => a -> EP w m a -markAnnotated a = enterAnn (getAnnotationEntry a) a +markAnnotated a = enterAnn (getAnnotationEntry a) a -- See Note [Exact print main loop] + +{- +Note [Exact print main loop] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Exact printing is the process of taking the ParsedSource, or some +subtree from it, and rendering it to a string, which accurately +reflects the original source that was parsed, except detail of +whitespace (such as spaces vs tabs) is discarded. + +The ParsedSource or fragment from it must implement the ExactPrint +class, and this file does that, as well as supporting machinery to +drive the process. The ExactPrint class is described later in this +note. + +The entry point for exact printing is the exactPrint function, defined +as + + exactPrint :: ExactPrint ast => ast -> String + exactPrint ast = snd $ runIdentity (runEP stringOptions (markAnnotated ast)) + + type EP w m a = RWST (EPOptions m w) (EPWriter w) EPState m a + + runEP :: (Monad m) => EPOptions m w -> EP w m a -> m (a, w) + runEP epReader action = do + (ast, w) <- evalRWST action epReader defaultEPState + return (ast, output w) + + data EPWriter w = EPWriter { output :: !w } + + data EPOptions m w = EPOptions + { epTokenPrint :: String -> m w + , epWhitespacePrint :: String -> m w + } + +This offers some flexibility in how the output is produced, in that +the EpWriter and EPOptions work together, defining an output type and +a function to render whitespace and non-whitepace. + +In normal operation (via exactPrint) these are simply returning the +string unchanged and accumulating a larger string. But it has also been +used to render an HTML version of the source as it prints. + +The main reason exact print exists is to make it easier for tool +writers to manipulate the ParsedSource, and render this back to the +original source, except for the changed parts. One manipulation is to +simply take say a FunBind with its signature from one place in the +code to another. When doing this, the original parsed locations are no +longer useful when rendering the source back to a string. To enable +this, we have another entry point, for converting all absolute +locations to relative ones, using DeltaPos, which captures the line +and col offset relative to the prior output. + +The function to do this is + + makeDeltaAst :: ExactPrint ast => ast -> ast + makeDeltaAst ast = fst $ runIdentity (runEP deltaOptions (markAnnotated ast)) + +The implementation is practically identical for exactPrint and +makeDeltaAst, they simply return the second or first part of the same +calculation. + +This simplifies the implementation of the required ExactPrint +implmentations, in that we only need one per ast item, which encodes +how to print it, and this print process does bookkeeping to keep track +of what spacing it used when doing the print, so it can return the +updated item, with the original absolute SrcSpan's converted to +DeltaPos values instead. + +This information is captured in the XRec/Anno instances used in GHC +Hs, which are mostly LocatedA a, defined as + + GenLocated (EpAnn [TrailingAnn]) a + + data EpAnn ann + = EpAnn { entry :: !EpaLocation + , anns :: !ann + , comments :: !EpAnnComments + } + + data EpaLocation = EpaSpan !SrcSpan + | EpaDelta !SrcSpan !DeltaPos [LEpaComment] + +When parsed, the entry EpaLocation captures an EpaSpan with the parsed +absolute location. After makeDeltaAst, this instead uses EpaDelta, +including the original SrcSpan, the relative spaceing as a DeltaPos, +and any comments that may come before the item, e.g. comments before a +semicolon. + +Both exactPrint and makeDeltaAst call markAnnotated on the item to be +printed, inside the monad machinery. + + markAnnotated :: (Monad m, Monoid w, ExactPrint a) => a -> EP w m a + markAnnotated a = enterAnn (getAnnotationEntry a) a + +This makes use of the ExactPrint instance for the ParsedSource and +for every other part of the ParsedSource as a tree. + + class (Typeable a) => ExactPrint a where + getAnnotationEntry :: a -> Entry + exact :: (Monad m, Monoid w) => a -> EP w m a + setAnnotationAnchor :: a -> EpaLocation -> [TrailingAnn] -> EpAnnComments -> a + +- getAnnotationEntry : returns the Entry information, normally derived + directly from the EpAnn in the LocatedA enclosing the item. + Entry contains + - The location of the first non-comment part of the item to be printed. + - Any [TrailingAnn] (semis, commas, etc) to follow the item. + - Any comments associated with the item, but not with enclosed items. + These comments may also precede or follow the entry location + - Some technical flags, relating to flushing remaining comments at the + last (topmost) item, and if the anchor can be updated (see below). + +- exact : Do the actual printing of the item, having been put in the right + place in terms of print location by the main loop, based on a call to + getAnnotationEntry for it. This printing normally comprises making nested + markAnnotated calls on the nested items in the current one, e.g. + + exact (HsApp an e1 e2) = do + e1' <- markAnnotated e1 + e2' <- markAnnotated e2 + return (HsApp an e1' e2') + +- setAnnotationAnchor : the main loop printing does two things: + - produce output, reflecting the items being printed + - convert all the locations in the item (each an EpaLocation) from its + EpaSpan version to an EpaDelta one, which is independent of absolute + location, being the spacing from the previous print output to this + entry point + To allow these updated locations to be captured, the item implements + the setAnnotationAnchor method, which updates the fields of the Entry + returned by getAnnotationEntry + +You will recall + + markAnnotated a = enterAnn (getAnnotationEntry a) a + enterAnn :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a + +enterAnn is the part that is repeatedly called via markAnnotated, to +manage the bookkeeping around printing and calculating the updated +delta positions. + +It manages the printing state, adding the new comments from the Entry, +positioning the print head to the entry point, takes account of whether +it is an absolute span or a delta, and prints any comments that must come +before this location. + +At this print location, it calls the `exact` method on the item. This +is the only place `exact` can be called. Within `exact` implementations +the `markAnnotated` function should be used instead, to ensure the state +is managed properly for printing. + +Once the item is printed via its `exact` method, which normally +recurses via `markAnnotated` into any nested items inside it, the +`enterAnn` function prints any [TrailingAnn] from the entry and any +trailing comments. It then wraps up by calling +`setAnnotationAnchor`with the updated (now delta-based) values for the +Entry + +Printing Complicated Items +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Sometimes we need to print a sub-item which does not map cleanly onto the +ExactPrint class, usually because there are parts spread through the item +that need to be managed together while printing. + +An example is in +https://gitlab.haskell.org/ghc/ghc/-/merge_requests/16321, where +ConDeclGADT needs to print its inner_bindings, but the these in turn +may have parens, e.g. + + data V a where + MkV4 :: forall a. ((forall b. (Show a => a -> (b -> V a)))) + +Here there are inner bindings for the first forall, the multiple +parens around the second forall, and the second forall, wrapping the +inner content within this. + +But the inner content `Show a => a -> (b -> V a)` had to be printed "inside" +the inner_bindings, to correctly close the nested parens. + +The approach in !16321 modified `enterAnn`, to pass in alternate versions +of the `exact` implementation. This works, but it makes an already +complicated function even more complicated. + +An ExactPrint-idiomatic approach is to create a helper data structure +to represent this nested organisation, and provide ExactPrint +instances for that. + +This is done in +https://gitlab.haskell.org/ghc/ghc/-/merge_requests/16644, using + + data InnerBindings + = InnerMore (LHsGadtTelescope GhcPs) InnerBindings + | InnerDone (Maybe (LHsContext GhcPs), HsConDeclGADTDetails GhcPs, LHsType GhcPs) + +The key part of the ExactPrint instance for this is + + exact (InnerMore (L l (HsGadtPar (lp, rp))) xs) = do + lp' <- markEpToken lp + xs' <- markAnnotated xs + rp' <- markEpToken rp + return (InnerMore (L l (HsGadtPar (lp',rp'))) xs') + +This first prints the opening paren, prints the balance of the cons list, then +prints the closing paren. + +Conversions to and from this structure populate the initial values from +the ConDeclGADT, and retrieve the updated delta-based values after +printing. + +Another use of this technique involves HsModuleImpDecls. + +-} -- | For HsModule, because we do not have a proper SrcSpan, we must -- indicate to flush trailing comments when done. @@ -377,6 +589,7 @@ cua NoCanUpdateAnchor _ = return [] -- This is combination of the ghc=exactprint Delta.withAST and -- Print.exactPC functions and effectively does the delta processing -- immediately followed by the print processing. JIT ghc-exactprint. +-- See Note [Exact print main loop] enterAnn :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a enterAnn NoEntryVal a = do p <- getPosP @@ -764,18 +977,12 @@ markLensBracketsO' :: (Monad m, Monoid w) => a -> Lens a AnnListBrackets -> EP w m a markLensBracketsO' a l = case view l a of - ListParens o c -> do - o' <- markEpToken o - return (set l (ListParens o' c) a) ListBraces o c -> do o' <- markEpToken o return (set l (ListBraces o' c) a) ListSquare o c -> do o' <- markEpToken o return (set l (ListSquare o' c) a) - ListBanana o c -> do - o' <- markEpUniToken o - return (set l (ListBanana o' c) a) ListNone -> return (set l ListNone a) markLensBracketsC :: (Monad m, Monoid w) @@ -786,18 +993,12 @@ markLensBracketsC' :: (Monad m, Monoid w) => a -> Lens a AnnListBrackets -> EP w m a markLensBracketsC' a l = case view l a of - ListParens o c -> do - c' <- markEpToken c - return (set l (ListParens o c') a) ListBraces o c -> do c' <- markEpToken c return (set l (ListBraces o c') a) ListSquare o c -> do c' <- markEpToken c return (set l (ListSquare o c') a) - ListBanana o c -> do - c' <- markEpUniToken c - return (set l (ListBanana o c') a) ListNone -> return (set l ListNone a) -- ------------------------------------- @@ -2919,13 +3120,13 @@ instance ExactPrint (HsExpr GhcPs) where (an',l',stmts') <- exactDo (an,l) do_or_list_comp stmts return (HsDo (an',l') do_or_list_comp stmts') - exact (ExplicitList an es) = do + exact (ExplicitList (o,c) es) = do debugM $ "ExplicitList start" - an0 <- markLensBracketsO' an lal_brackets + o' <- markEpToken o es' <- mapM markAnnotated es - an1 <- markLensBracketsC' an0 lal_brackets + c' <- markEpToken c debugM $ "ExplicitList end" - return (ExplicitList an1 es') + return (ExplicitList (o',c') es') exact (RecordCon x con_id binds) = do con_id' <- markAnnotated con_id binds' <- markAnnotated binds @@ -3335,8 +3536,8 @@ instance ExactPrint (HsCmd GhcPs) where arr' <- markAnnotated arr return (HsCmdArrApp (isU, l') arr' arg' HsHigherOrderApp False) - exact (HsCmdArrForm an e fixity cs) = do - an0 <- markLensBracketsO' an lal_brackets + exact (HsCmdArrForm (o,c) e fixity cs) = do + o' <- markEpUniToken o (e',cs') <- case (fixity, cs) of (Infix, (arg1:argrest)) -> do arg1' <- markAnnotated arg1 @@ -3348,8 +3549,8 @@ instance ExactPrint (HsCmd GhcPs) where cs' <- mapM markAnnotated cs return (e', cs') (Infix, []) -> error "Not possible" - an1 <- markLensBracketsC' an0 lal_brackets - return (HsCmdArrForm an1 e' fixity cs') + c' <- markEpUniToken c + return (HsCmdArrForm (o',c') e' fixity cs') exact (HsCmdApp an e1 e2) = do e1' <- markAnnotated e1 @@ -4671,9 +4872,11 @@ instance ExactPrint (Pat GhcPs) where pat' <- markAnnotated pat return (BangPat an0 pat') - exact (ListPat an pats) = do - (an', pats') <- markAnnList' an (mapM markAnnotated pats) - return (ListPat an' pats') + exact (ListPat (os,cs) pats) = do + os' <- markEpToken os + pats' <- mapM markAnnotated pats + cs' <- markEpToken cs + return (ListPat (os',cs') pats') exact (TuplePat an pats boxity) = do an0 <- markOpeningParen an ===================================== utils/check-exact/Utils.hs ===================================== @@ -342,10 +342,8 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports (xs',rest') = allocPreceding xs rest annListBracketsLocs :: AnnListBrackets -> (EpaLocation,EpaLocation) -annListBracketsLocs (ListParens o c) = (getEpTokenLoc o, getEpTokenLoc c) annListBracketsLocs (ListBraces o c) = (getEpTokenLoc o, getEpTokenLoc c) annListBracketsLocs (ListSquare o c) = (getEpTokenLoc o, getEpTokenLoc c) -annListBracketsLocs (ListBanana o c) = (getEpUniTokenLoc o, getEpUniTokenLoc c) annListBracketsLocs ListNone = (noAnn, noAnn) data SplitWhere = Before | After View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dac5eca9e828f86c6390f0b1ad27fa… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dac5eca9e828f86c6390f0b1ad27fa… 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/apk/unfold-dicts] Try discounting args applied to a result of a class op
by Andreas Klebinger (＠AndreasK) 12 Sep '26

12 Sep '26

Andreas Klebinger pushed to branch wip/apk/unfold-dicts at Glasgow Haskell Compiler / GHC Commits: 6a40d4b6 by Andreas Klebinger at 2026-09-11T20:24:24+02:00 Try discounting args applied to a result of a class op - - - - - 1 changed file: - compiler/GHC/Core/Unfold.hs Changes: ===================================== compiler/GHC/Core/Unfold.hs ===================================== @@ -42,7 +42,7 @@ import GHC.Core.Utils import GHC.Core.DataCon import GHC.Core.Type import GHC.Core.Class( Class ) -import GHC.Core.Predicate( isUnaryClass ) +import GHC.Core.Predicate( isUnaryClass, isDictId ) import GHC.Types.Id import GHC.Types.Literal @@ -782,7 +782,7 @@ classOpSize :: UnfoldingOpts -> Class -> [Id] -> [CoreExpr] -> ExprSize classOpSize _opts _cls _top_args [] = sizeZero -- A non-applied classop classOpSize opts cls top_args (dict_arg:other_val_args) - = SizeIs size (dict_arg_discount dict_arg) 0 + = SizeIs size dict_arg_discount 0 where -- See (UCM4) in Note [Unary class magic] in GHC.Core.TyCon op_app_size = if isUnaryClass cls then 0 else 20 @@ -797,8 +797,8 @@ classOpSize opts cls top_args (dict_arg:other_val_args) -- give it a discount, to encourage the inlining of this function dict_arg_discount = case getIdFromTrivialExpr_maybe dict_arg of Nothing -> emptyBag - Just var - | var `elem` top_args = unitBag (dict, dict_discount) + Just dict + | dict `elem` top_args -> unitBag (dict, dict_discount) | otherwise -> emptyBag -- If we have (class-op d arg1 .. argn) then it's super-good to inline @@ -808,7 +808,15 @@ classOpSize opts cls top_args (dict_arg:other_val_args) -- See the discussion on #26831, esp "Delicate inlining". dict_discount | null other_val_args = unfoldingDictDiscount opts - | otherwise = unfoldingDictDiscount opts + unfoldingFunAppDiscount opts + | otherwise = unfoldingDictDiscount opts + unfoldingFunAppDiscount opts + + -- Just trying things. + 5 * numTopDictArgs + numTopDictArgs = (count (isTopArgDict) other_val_args) + isTopArgDict expr + | Just v <- getIdFromTrivialExpr_maybe expr + , v `elem` top_args + = isDictId v + | otherwise = False -- | The size of a function call callSize View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6a40d4b68d3bdfd7c5d3f9f1627ed32… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6a40d4b68d3bdfd7c5d3f9f1627ed32… 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/apk/unfold-dicts
by Andreas Klebinger (＠AndreasK) 12 Sep '26

12 Sep '26

Andreas Klebinger pushed new branch wip/apk/unfold-dicts at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/apk/unfold-dicts 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/T27724] 2 commits: Wibbles
by Simon Peyton Jones (＠simonpj) 12 Sep '26

12 Sep '26

Simon Peyton Jones pushed to branch wip/T27724 at Glasgow Haskell Compiler / GHC Commits: 43b12541 by Simon Peyton Jones at 2026-09-11T17:23:27+01:00 Wibbles - - - - - 13341b88 by Simon Peyton Jones at 2026-09-11T17:41:12+01:00 Improve strictness - - - - - 12 changed files: - + changelog.d/T27724 - compiler/GHC/Builtin/WiredIn/Ids.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Type.hs - libraries/ghc-internal/src/GHC/Internal/Magic.hs - + testsuite/tests/dmdanal/should_compile/T23911.hs - testsuite/tests/dmdanal/should_compile/all.T - + testsuite/tests/simplCore/should_compile/T27724a.hs - + testsuite/tests/simplCore/should_compile/T27724a.stderr - + testsuite/tests/simplCore/should_compile/T27803.hs - + testsuite/tests/simplCore/should_compile/T27803.stderr - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== changelog.d/T27724 ===================================== @@ -0,0 +1,17 @@ +section: compiler +synopsis: ``noinline`` now works with specialisation and demand analysis +issues: #18396, #23911, 16588, #27724 +mrs: !16658 +description: { + Saying ``(noinline f x)`` previously meant that the call would no longer be + type-class specialised, nor would it be recognised as strict, nor would RULEs + fire. Now all of these things work. + + Moreover you can also say ``noinline (f <arg>)`` if you prefer, with the argument + inside the ``noinline`` call. Then ``f`` will not be inlined, but inlining within + ``<arg>>`` is unaffected. + + Moreover, previously there was a danger that if ``f`` was defined trivially as + ``f = Just`` (say) then it would be inlined anyway, despite the ``noinline``. + Now ``noinline`` is fully respected. +} ===================================== compiler/GHC/Builtin/WiredIn/Ids.hs ===================================== @@ -55,6 +55,7 @@ import GHC.Types.Literal import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Id +import GHC.Types.Demand import GHC.Types.Id.Info import GHC.Types.InlinePragma import GHC.Types.Var (VarBndr(Bndr), invisArgConstraintLike, tyVarName) @@ -275,6 +276,12 @@ noinlineId :: Id -- See Note [noinlineId magic] noinlineId = pcMiscPrelId noinlineIdName ty info where info = noCafIdInfo + `setArityInfo` 1 + `setDmdSigInfo` strict_sig + + -- noinline certainly calls its argument! + strict_sig = mkClosedDmdSig [seqDmd] topDiv + -- noinline :: forall r (a :: TYPE r). a -> a ty = mkInfForAllTy runtimeRep1TyVar $ mkSpecForAllTys [rrPolyTyVar1] $ ===================================== compiler/GHC/Core/Opt/SetLevels.hs ===================================== @@ -110,14 +110,13 @@ import GHC.Types.Demand ( DmdSig, prependArgsDmdSig ) import GHC.Types.Cpr ( CprSig, prependArgsCprSig ) import GHC.Types.Name ( getOccName ) import GHC.Types.Name.Occurrence ( occNameFS ) -import GHC.Types.Unique ( hasKey ) import GHC.Types.Tickish ( tickishIsCode ) import GHC.Types.Unique.Supply import GHC.Types.Unique.DFM import GHC.Types.Basic ( Arity, RecFlag(..), isRec ) import GHC.Builtin.WiredIn.Types -import GHC.Builtin.KnownKeys ( runRWKey ) +import GHC.Builtin.KnownKeys import GHC.Data.FastString @@ -394,11 +393,14 @@ lvlApp :: LevelEnv -> (CoreExprWithFVs, [CoreExprWithFVs]) -- Input application -> LvlM LevelledExpr -- Result expression lvlApp env orig_expr ((_,AnnVar fn), args) - -- Try to ensure that runRW#'s continuation isn't floated out. - -- See Note [Simplification of runRW#]. - | fn `hasKey` runRWKey + -- Do not float out from the argument(s) of these magic Ids + -- E.g. if we have (noinline (f x)) we definitely do not want to get + -- let lvl = f x in noinline lvl + -- Ditto `lazy (f x)`, and `runRW# (\s -> blah)` and `oneShot (\x.e)` + | idUnique fn `elem` [ runRWKey, noinlineIdKey, lazyIdKey + , oneShotKey, nospecIdKey ] = do { args' <- mapM (lvlExpr env) args - ; return (foldl' App (lookupVar env fn) args') } + ; return (foldl' App (Var fn) args') } | floatOverSat env -- See Note [Floating over-saturated applications] , arity > 0 ===================================== compiler/GHC/Core/Type.hs ===================================== @@ -949,7 +949,9 @@ mapTyCoX (TyCoMapper { tcm_tyvar = tyvar <*> go_ty env t1 <*> go_ty env t2 go_co !env (SymCo co) = mkSymCo <$> go_co env co go_co !env (TransCo c1 c2) = mkTransCo <$> go_co env c1 <*> go_co env c2 - go_co !env (AxiomCo r cos) = mkAxiomCo r <$> go_cos env cos + go_co !env (AxiomCo r cos) = AxiomCo r <$> go_cos env cos + -- We could call mkAxiomCo, but it's a no-op, + -- and doing so builds an extra thunk go_co !env (SelCo i co) = mkSelCo i <$> go_co env co go_co !env (LRCo lr co) = mkLRCo lr <$> go_co env co go_co !env (InstCo co arg) = mkInstCo <$> go_co env co <*> go_co env arg ===================================== libraries/ghc-internal/src/GHC/Internal/Magic.hs ===================================== @@ -62,6 +62,13 @@ inline x = x -- | The call @noinline f@ arranges that @f@ will not be inlined. -- It is removed during CorePrep so that its use imposes no overhead -- (besides the fact that it blocks inlining.) +-- +-- You can write @noinline f e1 e2@, or @noinline (f e1 e2)@, or +-- even @noinline (f e1) e1@. In all cases, @f@ is not inlined, but +-- optimisation of @e1@ and @e2@ is unaffected. +-- +-- In all cases, type-class specialisation, and demand analysis, and +-- RULE rewriting, are unaffected. noinline :: forall (r :: RuntimeRep) (a :: TYPE r). a -> a {-# NOINLINE noinline #-} ===================================== testsuite/tests/dmdanal/should_compile/T23911.hs ===================================== @@ -0,0 +1,16 @@ +module T23911 where + +import GHC.Exts( noinline ) + +{-# NOINLINE foo #-} +foo x y = (noinline const) x y + +{-# NOINLINE bar #-} +bar x y = const x y + + +{-# NOINLINE sfoo #-} +sfoo x y = (noinline (+)) x y :: Int + +{-# NOINLINE sbar #-} +sbar x y = x + y :: Int ===================================== testsuite/tests/dmdanal/should_compile/all.T ===================================== @@ -107,3 +107,4 @@ test('T23398', normal, compile, ['-dsuppress-uniques -ddump-simpl -dno-typeable- test('T24623', normal, compile, ['']) test('T25196', [ req_th, collect_compiler_stats('bytes allocated', 10) ], multimod_compile, ['T25196', '-v0']) +test('T23911', [ grep_errmsg(r'Str') ], compile, ['-dsuppress-uniques -ddump-dmdanal']) ===================================== testsuite/tests/simplCore/should_compile/T27724a.hs ===================================== @@ -0,0 +1,18 @@ +module T27724a where + +import GHC.Exts + +class C a where + op :: a -> Int + +instance C Int where + {-# INLINE op #-} + op x = x + +f :: C a => a -> Int -> Int +f x 0 = op x +f x n = op x + f x (n - 1) + +foo :: IO () +-- foo = print (f (1 :: Int) 10) -- Specialises +foo = print (noinline f (1 :: Int) 10) -- Doesn't specialise ===================================== testsuite/tests/simplCore/should_compile/T27724a.stderr ===================================== @@ -0,0 +1,5 @@ +Rule fired: Class op + (BUILTIN) +Rule fired: Class op - (BUILTIN) +Rule fired: Class op show (BUILTIN) +Rule fired: SPEC f @Int (T27724a) +Rule fired: SPEC f @Int (T27724a) ===================================== testsuite/tests/simplCore/should_compile/T27803.hs ===================================== @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -Wno-inline-rule-shadowing #-} +-- Switch off the (perfectly legitimate) warning + +module T27803 where + +import GHC.Exts( noinline ) + +f = Just + +-- Make the rule run in phase 0 (last phase) +{-# RULES "fTrue" [0] f True = Just False #-} +wombat x = noinline f True ===================================== testsuite/tests/simplCore/should_compile/T27803.stderr ===================================== @@ -0,0 +1 @@ +Rule fired: fTrue (T27803) ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -618,3 +618,5 @@ test('T27556', [only_ways('ghci'), extra_hc_opts('-O -fno-unoptimized-core-for-i test('T27749', multiline_grep_errmsg(r'ordering\n.*\n(\s+src<[^>]*>\n)+'), compile, ['-O -g3 -ddump-simpl -dsuppress-uniques']) +test('T27724a', [grep_errmsg(r'SPEC')], compile, ['-O -drule-firings']) +test('T27803', [grep_errmsg(r'SPEC')], compile, ['-O -drule-firings']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5b405cd7ed126c62a9568e3682e93a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5b405cd7ed126c62a9568e3682e93a… 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/torsten.schmits/mwb-26-09/abstract-linkables
by Torsten Schmits (＠torsten.schmits) 11 Sep '26

11 Sep '26

Torsten Schmits pushed new branch wip/torsten.schmits/mwb-26-09/abstract-linkables at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/torsten.schmits/mwb-26-09/abs… 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/az/exactprint-main-loop-note] 4 commits: ci: Actually pass --ignore-perf-failures to the testsuite driver
by Alan Zimmerman (＠alanz) 11 Sep '26

11 Sep '26

Alan Zimmerman pushed to branch wip/az/exactprint-main-loop-note at Glasgow Haskell Compiler / GHC Commits: 4e9297ea by Simon Jakobi at 2026-09-11T08:32:45-04:00 ci: Actually pass --ignore-perf-failures to the testsuite driver 684c0018d9 changed the IGNORE_PERF_FAILURES handling to append to RUNTEST_ARGS with bash array syntax, but the three use sites still expand RUNTEST_ARGS as a scalar, which yields only the first array element. The appended flag was therefore dropped in every job, so perf improvements kept failing Marge Bot batches and master pipelines, contrary to #19562. Append as a string instead, matching the existing --force-colors append in test_hadrian. Fixes #27563. Assisted-by: Claude Fable 5.1 - - - - - 4f78dfdf by Simon Jakobi at 2026-09-11T08:33:24-04:00 testsuite: Give T26537 a 1.5x compile timeout Its -fregs-graph compile step tends to time out in unoptimized builds (#27188, #27776). Assisted-by: Claude Fable 5.1 - - - - - 130286e3 by Alan Zimmerman at 2026-09-11T08:34:08-04:00 EPA: Remove ListBanana / ListParens from AnnListBrackets This is a step towards making AnnList only represent lists of items which can have either braces or layout. - - - - - 4798aab1 by Alan Zimmerman at 2026-09-11T14:14:52+00:00 EPA: Add a Note for the exact print main loop - - - - - 10 changed files: - .gitlab/ci.sh - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - testsuite/tests/codeGen/should_run/all.T - testsuite/tests/ghc-api/T25121_status.stdout - utils/check-exact/ExactPrint.hs - utils/check-exact/Utils.hs Changes: ===================================== .gitlab/ci.sh ===================================== @@ -1106,7 +1106,7 @@ if [ "${CI_COMMIT_BRANCH:-}" == "master" ] && [ "${CI_PROJECT_PATH:-}" == "ghc/ fi fi if [ -n "${IGNORE_PERF_FAILURES:-}" ]; then - RUNTEST_ARGS=( "${RUNTEST_ARGS[@]:-}" "--ignore-perf-failures=$IGNORE_PERF_FAILURES" ) + RUNTEST_ARGS="${RUNTEST_ARGS:-} --ignore-perf-failures=$IGNORE_PERF_FAILURES" fi if [[ -z ${BIGNUM_BACKEND:-} ]]; then BIGNUM_BACKEND=gmp; fi ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -294,7 +294,7 @@ type instance XDo GhcPs = (AnnList, EpaLocation) type instance XDo GhcRn = NoExtField type instance XDo GhcTc = Type -type instance XExplicitList GhcPs = AnnList +type instance XExplicitList GhcPs = (EpToken "[", EpToken "]") type instance XExplicitList GhcRn = NoExtField type instance XExplicitList GhcTc = Type -- GhcPs: ExplicitList includes all source-level @@ -1440,7 +1440,7 @@ type instance XCmdArrApp GhcPs = (IsUnicodeSyntax, EpaLocation) type instance XCmdArrApp GhcRn = NoExtField type instance XCmdArrApp GhcTc = Type -type instance XCmdArrForm GhcPs = AnnList +type instance XCmdArrForm GhcPs = (EpUniToken "(|" "⦇", EpUniToken "|)" "⦈") -- | fixity (filled in by the renamer), for forms that were converted from -- OpApp's by the renamer type instance XCmdArrForm GhcRn = Maybe Fixity ===================================== compiler/GHC/Hs/Pat.hs ===================================== @@ -104,7 +104,7 @@ type instance XBangPat GhcPs = EpToken "!" type instance XBangPat GhcRn = NoExtField type instance XBangPat GhcTc = NoExtField -type instance XListPat GhcPs = AnnList +type instance XListPat GhcPs = (EpToken "[", EpToken "]") -- After parsing, ListPat can refer to a built-in Haskell list pattern -- or an overloaded list pattern. type instance XListPat GhcRn = NoExtField ===================================== compiler/GHC/Parser.y ===================================== @@ -3282,7 +3282,7 @@ aexp2 :: { ECP } -- arrow notation extension | '(|' aexp cmdargs '|)' {% runPV (unECP $2) >>= \ $2 -> fmap ecpFromCmd $ - amsA' (sLL $1 $> $ HsCmdArrForm (AnnList (glRM $1) (ListBanana (epUniTok $1) (epUniTok $4)) []) $2 Prefix + amsA' (sLL $1 $> $ HsCmdArrForm (epUniTok $1, epUniTok $4) $2 Prefix (reverse $3)) } projection :: { Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))) } @@ -3414,9 +3414,9 @@ tup_tail :: { forall b. DisambECP b => PV [Either (EpAnn Bool) (LocatedA b)] } -- Never empty. list :: { forall b. DisambECP b => SrcSpan -> (EpaLocation, EpaLocation) -> PV (LocatedA b) } : texp { \loc (ao,ac) -> unECP $1 >>= \ $1 -> - mkHsExplicitListPV loc [$1] (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) []) } + mkHsExplicitListPV loc [$1] (EpTok ao, EpTok ac) } | lexps { \loc (ao,ac) -> $1 >>= \ $1 -> - mkHsExplicitListPV loc (reverse $1) (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) []) } + mkHsExplicitListPV loc (reverse $1) (EpTok ao, EpTok ac) } | texp '..' { \loc (ao,ac) -> unECP $1 >>= \ $1 -> amsA' (L loc $ ArithSeq (AnnArithSeq (EpTok ao) Nothing (epTok $2) (EpTok ac)) Nothing (From $1)) >>= ecpFromExp' } ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -519,10 +519,8 @@ data AnnList } deriving (Data,Eq) data AnnListBrackets - = ListParens (EpToken "(") (EpToken ")") - | ListBraces (EpToken "{") (EpToken "}") + = ListBraces (EpToken "{") (EpToken "}") | ListSquare (EpToken "[") (EpToken "]") - | ListBanana (EpUniToken "(|" "⦇") (EpUniToken "|)" "⦈") | ListNone deriving (Data,Eq) @@ -1094,10 +1092,8 @@ instance Outputable AnnList where = text "AnnList" <+> ppr l <+> ppr p <+> ppr s instance Outputable AnnListBrackets where - ppr (ListParens o c) = text "ListParens" <+> ppr o <+> ppr c ppr (ListBraces o c) = text "ListBraces" <+> ppr o <+> ppr c ppr (ListSquare o c) = text "ListSquare" <+> ppr o <+> ppr c - ppr (ListBanana o c) = text "ListBanana" <+> ppr o <+> ppr c ppr ListNone = text "ListNone" instance Outputable AnnCType where ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -1827,7 +1827,7 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where mkHsTySigPV :: SrcSpanAnnA -> LocatedA b -> LHsType GhcPs -> TokDcolon -> PV (LocatedA b) -- | Disambiguate "[a,b,c]" (list syntax) - mkHsExplicitListPV :: SrcSpan -> [LocatedA b] -> AnnList -> PV (LocatedA b) + mkHsExplicitListPV :: SrcSpan -> [LocatedA b] -> (EpToken "[", EpToken "]") -> PV (LocatedA b) -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices) mkHsSplicePV :: Located (HsUntypedSplice GhcPs) -> PV (LocatedA b) -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates) ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -258,7 +258,7 @@ test('T24893', normal, compile_and_run, ['-O']) test('CCallConv', [req_c], compile_and_run, ['CCallConv_c.c']) test('T25364', normal, compile_and_run, ['']) test('T26061', normal, compile_and_run, ['']) -test('T26537', normal, compile_and_run, ['-O2 -fregs-graph']) +test('T26537', compile_timeout_multiplier(1.5), compile_and_run, ['-O2 -fregs-graph']) test('T24016', normal, compile_and_run, ['-O1 -fPIC']) test('T27046', [ req_cmm ===================================== testsuite/tests/ghc-api/T25121_status.stdout ===================================== @@ -15,7 +15,7 @@ X(FunArr) match = NoExtField X(ExprWithTySig) match = EpUniToken "::" "\8759" X(UntypedSplice) match = NoExtField X(ExplicitList) mismatch - >>> AnnList + >>> ((EpToken "["),(EpToken "]")) <<< ((EpToken "'"),(EpToken "["),(EpToken "]")) X(ExplicitTuple) mismatch >>> AnnParen ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -140,9 +140,9 @@ defaultEPState = EPState -- | The R part of RWS. The environment. Updated via 'local' as we -- enter a new AST element, having a different anchor point. -data EPOptions m a = EPOptions - { epTokenPrint :: String -> m a - , epWhitespacePrint :: String -> m a +data EPOptions m w = EPOptions + { epTokenPrint :: String -> m w + , epWhitespacePrint :: String -> m w } -- | Helper to create a 'EPOptions' @@ -163,8 +163,7 @@ stringOptions = epOptions return return deltaOptions :: EPOptions Identity () deltaOptions = epOptions (\_ -> return ()) (\_ -> return ()) -data EPWriter a = EPWriter - { output :: !a } +data EPWriter w = EPWriter { output :: !w } instance Monoid w => Semigroup (EPWriter w) where (EPWriter a) <> (EPWriter b) = EPWriter (a <> b) @@ -239,7 +238,220 @@ setAnchorEpaL (EpAnn _ an _) anc ts cs = EpAnn anc (setTrailing (an {al_anchor = -- | Key entry point. Switches to an independent AST element with its -- own annotation, calculating new offsets, etc markAnnotated :: (Monad m, Monoid w, ExactPrint a) => a -> EP w m a -markAnnotated a = enterAnn (getAnnotationEntry a) a +markAnnotated a = enterAnn (getAnnotationEntry a) a -- See Note [Exact print main loop] + +{- +Note [Exact print main loop] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Exact printing is the process of taking the ParsedSource, or some +subtree from it, and rendering it to a string, which accurately +reflects the original source that was parsed, except detail of +whitespace (such as spaces vs tabs) is discarded. + +The ParsedSource or fragment from it must implement the ExactPrint +class, and this file does that, as well as supporting machinery to +drive the process. The ExactPrint class is described later in this +note. + +The entry point for exact printing is the exactPrint function, defined +as + + exactPrint :: ExactPrint ast => ast -> String + exactPrint ast = snd $ runIdentity (runEP stringOptions (markAnnotated ast)) + + type EP w m a = RWST (EPOptions m w) (EPWriter w) EPState m a + + runEP :: (Monad m) => EPOptions m w -> EP w m a -> m (a, w) + runEP epReader action = do + (ast, w) <- evalRWST action epReader defaultEPState + return (ast, output w) + + data EPWriter w = EPWriter { output :: !w } + + data EPOptions m w = EPOptions + { epTokenPrint :: String -> m w + , epWhitespacePrint :: String -> m w + } + +This offers some flexibility in how the output is produced, in that +the EpWriter and EPOptions work together, defining an output type and +a function to render whitespace and non-whitepace. + +In normal operation (via exactPrint) these are simply returning the +string unchanged and accumulating a larger string. But it has also been +used to render an HTML version of the source as it prints. + +The main reason exact print exists is to make it easier for tool +writers to manipulate the ParsedSource, and render this back to the +original source, except for the changed parts. One manipulation is to +simply take say a FunBind with its signature from one place in the +code to another. When doing this, the original parsed locations are no +longer useful when rendering the source back to a string. To enable +this, we have another entry point, for converting all absolute +locations to relative ones, using DeltaPos, which captures the line +and col offset relative to the prior output. + +The function to do this is + + makeDeltaAst :: ExactPrint ast => ast -> ast + makeDeltaAst ast = fst $ runIdentity (runEP deltaOptions (markAnnotated ast)) + +The implementation is practically identical for exactPrint and +makeDeltaAst, they simply return the second or first part of the same +calculation. + +This simplifies the implementation of the required ExactPrint +implmentations, in that we only need one per ast item, which encodes +how to print it, and this print process does bookkeeping to keep track +of what spacing it used when doing the print, so it can return the +updated item, with the original absolute SrcSpan's converted to +DeltaPos values instead. + +This information is captured in the XRec/Anno instances used in GHC +Hs, which are mostly LocatedA a, defined as + + GenLocated (EpAnn [TrailingAnn]) a + + data EpAnn ann + = EpAnn { entry :: !EpaLocation + , anns :: !ann + , comments :: !EpAnnComments + } + + data EpaLocation = EpaSpan !SrcSpan + | EpaDelta !SrcSpan !DeltaPos [LEpaComment] + +When parsed, the entry EpaLocation captures an EpaSpan with the parsed +absolute location. After makeDeltaAst, this instead uses EpaDelta, +including the original SrcSpan, the relative spaceing as a DeltaPos, +and any comments that may come before the item, e.g. comments before a +semicolon. + +Both exactPrint and makeDeltaAst call markAnnotated on the item to be +printed, inside the monad machinery. + + markAnnotated :: (Monad m, Monoid w, ExactPrint a) => a -> EP w m a + markAnnotated a = enterAnn (getAnnotationEntry a) a + +This makes use of the ExactPrint instance for the ParsedSource and +for every other part of the ParsedSource as a tree. + + class (Typeable a) => ExactPrint a where + getAnnotationEntry :: a -> Entry + exact :: (Monad m, Monoid w) => a -> EP w m a + setAnnotationAnchor :: a -> EpaLocation -> [TrailingAnn] -> EpAnnComments -> a + +- getAnnotationEntry : returns the Entry information, normally derived + directly from the EpAnn in the LocatedA enclosing the item. + Entry contains + - The location of the first non-comment part of the item to be printed. + - Any [TrailingAnn] (semis, commas, etc) to follow the item. + - Any comments associated with the item, but not with enclosed items. + These comments may also precede or follow the entry location + - Some technical flags, relating to flushing remaining comments at the + last (topmost) item, and if the anchor can be updated (see below). + +- exact : Do the actual printing of the item, having been put in the right + place in terms of print location by the main loop, based on a call to + getAnnotationEntry for it. This printing normally comprises making nested + markAnnotated calls on the nested items in the current one, e.g. + + exact (HsApp an e1 e2) = do + e1' <- markAnnotated e1 + e2' <- markAnnotated e2 + return (HsApp an e1' e2') + +- setAnnotationAnchor : the main loop printing does two things: + - produce output, reflecting the items being printed + - convert all the locations in the item (each an EpaLocation) from its + EpaSpan version to an EpaDelta one, which is independent of absolute + location, being the spacing from the previous print output to this + entry point + To allow these updated locations to be captured, the item implements + the setAnnotationAnchor method, which updates the fields of the Entry + returned by getAnnotationEntry + +You will recall + + markAnnotated a = enterAnn (getAnnotationEntry a) a + enterAnn :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a + +enterAnn is the part that is repeatedly called via markAnnotated, to +manage the bookkeeping around printing and calculating the updated +delta positions. + +It manages the printing state, adding the new comments from the Entry, +positioning the print head to the entry point, takes account of whether +it is an absolute span or a delta, and prints any comments that must come +before this location. + +At this print location, it calls the `exact` method on the item. This +is the only place `exact` can be called. Within `exact` implementations +the `markAnnotated` function should be used instead, to ensure the state +is managed properly for printing. + +Once the item is printed via its `exact` method, which normally +recurses via `markAnnotated` into any nested items inside it, the +`enterAnn` function prints any [TrailingAnn] from the entry and any +trailing comments. It then wraps up by calling +`setAnnotationAnchor`with the updated (now delta-based) values for the +Entry + +Printing Complicated Items +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Sometimes we need to print a sub-item which does not map cleanly onto the +ExactPrint class, usually because there are parts spread through the item +that need to be managed together while printing. + +An example is in +https://gitlab.haskell.org/ghc/ghc/-/merge_requests/16321, where +ConDeclGADT needs to print its inner_bindings, but the these in turn +may have parens, e.g. + + data V a where + MkV4 :: forall a. ((forall b. (Show a => a -> (b -> V a)))) + +Here there are inner bindings for the first forall, the multiple +parens around the second forall, and the second forall, wrapping the +inner content within this. + +But the inner content `Show a => a -> (b -> V a)` had to be printed "inside" +the inner_bindings, to correctly close the nested parens. + +The approach in !16321 modified `enterAnn`, to pass in alternate versions +of the `exact` implementation. This works, but it makes an already +complicated function even more complicated. + +An ExactPrint-idiomatic approach is to create a helper data structure +to represent this nested organisation, and provide ExactPrint +instances for that. + +This is done in +https://gitlab.haskell.org/ghc/ghc/-/merge_requests/16644, using + + data InnerBindings + = InnerMore (LHsGadtTelescope GhcPs) InnerBindings + | InnerDone (Maybe (LHsContext GhcPs), HsConDeclGADTDetails GhcPs, LHsType GhcPs) + +The key part of the ExactPrint instance for this is + + exact (InnerMore (L l (HsGadtPar (lp, rp))) xs) = do + lp' <- markEpToken lp + xs' <- markAnnotated xs + rp' <- markEpToken rp + return (InnerMore (L l (HsGadtPar (lp',rp'))) xs') + +This first prints the opening paren, prints the balance of the cons list, then +prints the closing paren. + +Conversions to and from this structure populate the initial values from +the ConDeclGADT, and retrieve the updated delta-based values after +printing. + +Another use of this technique involves HsModuleImpDecls. + +-} -- | For HsModule, because we do not have a proper SrcSpan, we must -- indicate to flush trailing comments when done. @@ -377,6 +589,7 @@ cua NoCanUpdateAnchor _ = return [] -- This is combination of the ghc=exactprint Delta.withAST and -- Print.exactPC functions and effectively does the delta processing -- immediately followed by the print processing. JIT ghc-exactprint. +-- See Note [Exact print main loop] enterAnn :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a enterAnn NoEntryVal a = do p <- getPosP @@ -764,18 +977,12 @@ markLensBracketsO' :: (Monad m, Monoid w) => a -> Lens a AnnListBrackets -> EP w m a markLensBracketsO' a l = case view l a of - ListParens o c -> do - o' <- markEpToken o - return (set l (ListParens o' c) a) ListBraces o c -> do o' <- markEpToken o return (set l (ListBraces o' c) a) ListSquare o c -> do o' <- markEpToken o return (set l (ListSquare o' c) a) - ListBanana o c -> do - o' <- markEpUniToken o - return (set l (ListBanana o' c) a) ListNone -> return (set l ListNone a) markLensBracketsC :: (Monad m, Monoid w) @@ -786,18 +993,12 @@ markLensBracketsC' :: (Monad m, Monoid w) => a -> Lens a AnnListBrackets -> EP w m a markLensBracketsC' a l = case view l a of - ListParens o c -> do - c' <- markEpToken c - return (set l (ListParens o c') a) ListBraces o c -> do c' <- markEpToken c return (set l (ListBraces o c') a) ListSquare o c -> do c' <- markEpToken c return (set l (ListSquare o c') a) - ListBanana o c -> do - c' <- markEpUniToken c - return (set l (ListBanana o c') a) ListNone -> return (set l ListNone a) -- ------------------------------------- @@ -2919,13 +3120,13 @@ instance ExactPrint (HsExpr GhcPs) where (an',l',stmts') <- exactDo (an,l) do_or_list_comp stmts return (HsDo (an',l') do_or_list_comp stmts') - exact (ExplicitList an es) = do + exact (ExplicitList (o,c) es) = do debugM $ "ExplicitList start" - an0 <- markLensBracketsO' an lal_brackets + o' <- markEpToken o es' <- mapM markAnnotated es - an1 <- markLensBracketsC' an0 lal_brackets + c' <- markEpToken c debugM $ "ExplicitList end" - return (ExplicitList an1 es') + return (ExplicitList (o',c') es') exact (RecordCon x con_id binds) = do con_id' <- markAnnotated con_id binds' <- markAnnotated binds @@ -3335,8 +3536,8 @@ instance ExactPrint (HsCmd GhcPs) where arr' <- markAnnotated arr return (HsCmdArrApp (isU, l') arr' arg' HsHigherOrderApp False) - exact (HsCmdArrForm an e fixity cs) = do - an0 <- markLensBracketsO' an lal_brackets + exact (HsCmdArrForm (o,c) e fixity cs) = do + o' <- markEpUniToken o (e',cs') <- case (fixity, cs) of (Infix, (arg1:argrest)) -> do arg1' <- markAnnotated arg1 @@ -3348,8 +3549,8 @@ instance ExactPrint (HsCmd GhcPs) where cs' <- mapM markAnnotated cs return (e', cs') (Infix, []) -> error "Not possible" - an1 <- markLensBracketsC' an0 lal_brackets - return (HsCmdArrForm an1 e' fixity cs') + c' <- markEpUniToken c + return (HsCmdArrForm (o',c') e' fixity cs') exact (HsCmdApp an e1 e2) = do e1' <- markAnnotated e1 @@ -4671,9 +4872,11 @@ instance ExactPrint (Pat GhcPs) where pat' <- markAnnotated pat return (BangPat an0 pat') - exact (ListPat an pats) = do - (an', pats') <- markAnnList' an (mapM markAnnotated pats) - return (ListPat an' pats') + exact (ListPat (os,cs) pats) = do + os' <- markEpToken os + pats' <- mapM markAnnotated pats + cs' <- markEpToken cs + return (ListPat (os',cs') pats') exact (TuplePat an pats boxity) = do an0 <- markOpeningParen an ===================================== utils/check-exact/Utils.hs ===================================== @@ -342,10 +342,8 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports (xs',rest') = allocPreceding xs rest annListBracketsLocs :: AnnListBrackets -> (EpaLocation,EpaLocation) -annListBracketsLocs (ListParens o c) = (getEpTokenLoc o, getEpTokenLoc c) annListBracketsLocs (ListBraces o c) = (getEpTokenLoc o, getEpTokenLoc c) annListBracketsLocs (ListSquare o c) = (getEpTokenLoc o, getEpTokenLoc c) -annListBracketsLocs (ListBanana o c) = (getEpUniTokenLoc o, getEpUniTokenLoc c) annListBracketsLocs ListNone = (noAnn, noAnn) data SplitWhere = Before | After View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9867fdad28e85133e043724946a351… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9867fdad28e85133e043724946a351… 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/fendor/full-eventlog-live] Support for `ghc-stack-profiler`
by Hannes Siebenhandl (＠fendor) 11 Sep '26

11 Sep '26

Hannes Siebenhandl pushed to branch wip/fendor/full-eventlog-live at Glasgow Haskell Compiler / GHC Commits: 6b613b77 by fendor at 2026-09-11T15:48:13+02:00 Support for `ghc-stack-profiler` This adds the +ghc-stack-profiler feature flag. If set, GHC is instrumented with GHC Stack Profiler. - - - - - 10 changed files: - .gitmodules - + ghc-stack-profiler - ghc/Main.hs - ghc/ghc-bin.cabal.in - hadrian/src/Packages.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Packages.hs - + libraries/async - + libraries/hashable - + libraries/unordered-containers Changes: ===================================== .gitmodules ===================================== @@ -125,3 +125,15 @@ [submodule "eventlog-socket"] path = eventlog-socket url = https://github.com/well-typed/eventlog-socket.git +[submodule "ghc-stack-profiler"] + path = ghc-stack-profiler + url = https://github.com/well-typed/ghc-stack-profiler +[submodule "libraries/async"] + path = libraries/async + url = https://github.com/fendor/async.git +[submodule "libraries/unordered-containers"] + path = libraries/unordered-containers + url = https://github.com/fendor/unordered-containers.git +[submodule "libraries/hashable"] + path = libraries/hashable + url = https://github.com/fendor/hashable ===================================== ghc-stack-profiler ===================================== @@ -0,0 +1 @@ +Subproject commit 389d886a1494cd019ee93c72c8f19cf7f9dc1664 ===================================== ghc/Main.hs ===================================== @@ -97,6 +97,10 @@ import qualified Data.List.NonEmpty as NE import qualified GHC.Eventlog.Socket #endif +#if defined(GHC_STACK_PROFILER) +import qualified GHC.Stack.Profiler +#endif + startEventlogSocketFromEnv :: IO () #if defined(EVENTLOG_SOCKET) startEventlogSocketFromEnv = GHC.Eventlog.Socket.startFromEnv @@ -104,6 +108,13 @@ startEventlogSocketFromEnv = GHC.Eventlog.Socket.startFromEnv startEventlogSocketFromEnv = pure () #endif +startGhcStackProfilerFromEnv :: IO () -> IO () +#if defined(GHC_STACK_PROFILER) +startGhcStackProfilerFromEnv act = GHC.Stack.Profiler.withProfilerFromEnv (const act) +#else +startGhcStackProfilerFromEnv = id +#endif + ----------------------------------------------------------------------------- -- ToDo: @@ -117,7 +128,7 @@ startEventlogSocketFromEnv = pure () -- GHC's command-line interface main :: IO () -main = do +main = startGhcStackProfilerFromEnv $ do startEventlogSocketFromEnv hSetBuffering stdout LineBuffering ===================================== ghc/ghc-bin.cabal.in ===================================== @@ -37,6 +37,11 @@ Flag threaded Default: True Manual: True +Flag ghc-stack-profiler + Description: Build with support for ghc-stack-profiler + Default: False + Manual: True + Executable ghc Default-Language: GHC2024 @@ -102,6 +107,10 @@ Executable ghc build-depends: eventlog-socket CPP-OPTIONS: -DEVENTLOG_SOCKET + if flag(ghc-stack-profiler) + build-depends: ghc-stack-profiler + CPP-OPTIONS: -DGHC_STACK_PROFILER + Other-Extensions: CPP NondecreasingIndentation ===================================== hadrian/src/Packages.hs ===================================== @@ -14,6 +14,7 @@ module Packages ( lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace, eventlogSocket, eventlogSocketControl, ghcPackages, isGhcPackage, + async, hashable, unorderedContainers, ghc_stack_profiler, ghc_stack_profiler_core, -- * Package information crossPrefix, programBasename, programName, nonHsMainPackage, programPath, timeoutPath, @@ -44,7 +45,9 @@ ghcPackages = , timeout , eventlogSocketControl, eventlogSocket , lintersCommon - , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace ] + , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace + , async, hashable, unorderedContainers, ghc_stack_profiler_core, ghc_stack_profiler + ] -- TODO: Optimise by switching to sets of packages. isGhcPackage :: Package -> Bool @@ -139,6 +142,11 @@ win32 = lib "Win32" xhtml = lib "xhtml" eventlogSocket = lib "eventlog-socket" `setPath` "eventlog-socket/eventlog-socket" eventlogSocketControl = lib "eventlog-socket-control" `setPath` "eventlog-socket/eventlog-socket-control" +async = lib "async" +hashable = lib "hashable" +unorderedContainers = lib "unordered-containers" +ghc_stack_profiler = lib "ghc-stack-profiler" `setPath` "ghc-stack-profiler/ghc-stack-profiler" +ghc_stack_profiler_core = lib "ghc-stack-profiler-core" `setPath` "ghc-stack-profiler/ghc-stack-profiler-core" lintersCommon = lib "linters-common" `setPath` "linters/linters-common" lintNotes = linter "lint-notes" ===================================== hadrian/src/Settings/Default.hs ===================================== @@ -192,6 +192,11 @@ stagedPackages stage = do , hpcBin , if winTarget then win32 else unix , runGhc + , ghc_stack_profiler + , ghc_stack_profiler_core + , async + , hashable + , unorderedContainers ] , when (winTarget && not cross) [ -- See Note [Hadrian's ghci-wrapper package] ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -105,6 +105,14 @@ packageArgs = do , builder (Haddock BuildPackage) ? arg ("--optghc=-I" ++ path) ] + , package ghc_stack_profiler ? mconcat + [ builder (Cabal Flags) ? mconcat + [ arg "-use-ghc-trace-events" + -- Add support for eventlog-socket commands + , arg "+control" + ] + ] + , package eventlogSocket ? mconcat [ builder (Cabal Flags) ? mconcat [ @@ -123,6 +131,7 @@ packageArgs = do [ andM [expr (ghcWithInterpreter stage), orM [expr (notM cross), stage1]] `cabalFlag` "interpreter" , andM [expr (ghcWithInterpreter stage), notM (expr cross)] `cabalFlag` "internal-interpreter" , notStage0 `cabalFlag` "eventlog-socket" + , notStage0 `cabalFlag` "ghc-stack-profiler" , ifM stage0 -- We build a threaded stage 1 if the bootstrapping compiler -- supports it. ===================================== libraries/async ===================================== @@ -0,0 +1 @@ +Subproject commit 474fc7f612b74e73e24e91474fa75af18eede7b7 ===================================== libraries/hashable ===================================== @@ -0,0 +1 @@ +Subproject commit d56d62eb2a9ff4376e7119d925ececa60959d9ec ===================================== libraries/unordered-containers ===================================== @@ -0,0 +1 @@ +Subproject commit 368ea40488bf3c644e9c36d996302029fb0fc227 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6b613b772c45ade12c6f3456581405f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6b613b772c45ade12c6f3456581405f… 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/fendor/full-eventlog-live] Support for `ghc-stack-profiler`
by Hannes Siebenhandl (＠fendor) 11 Sep '26

11 Sep '26

Hannes Siebenhandl pushed to branch wip/fendor/full-eventlog-live at Glasgow Haskell Compiler / GHC Commits: fe6cefbe by fendor at 2026-09-11T15:43:08+02:00 Support for `ghc-stack-profiler` This adds the +ghc-stack-profiler feature flag. If set, GHC is instrumented with GHC Stack Profiler. - - - - - 10 changed files: - .gitmodules - + ghc-stack-profiler - ghc/Main.hs - ghc/ghc-bin.cabal.in - hadrian/src/Packages.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Packages.hs - + libraries/async - + libraries/hashable - + libraries/unordered-containers Changes: ===================================== .gitmodules ===================================== @@ -125,3 +125,15 @@ [submodule "eventlog-socket"] path = eventlog-socket url = https://github.com/well-typed/eventlog-socket.git +[submodule "ghc-stack-profiler"] + path = ghc-stack-profiler + url = https://github.com/well-typed/ghc-stack-profiler +[submodule "libraries/async"] + path = libraries/async + url = https://github.com/fendor/async.git +[submodule "libraries/unordered-containers"] + path = libraries/unordered-containers + url = https://github.com/fendor/unordered-containers.git +[submodule "libraries/hashable"] + path = libraries/hashable + url = https://github.com/fendor/hashable ===================================== ghc-stack-profiler ===================================== @@ -0,0 +1 @@ +Subproject commit 389d886a1494cd019ee93c72c8f19cf7f9dc1664 ===================================== ghc/Main.hs ===================================== @@ -97,6 +97,10 @@ import qualified Data.List.NonEmpty as NE import qualified GHC.Eventlog.Socket #endif +#if defined(GHC_STACK_PROFILER) +import qualified GHC.Stack.Profiler +#endif + startEventlogSocketFromEnv :: IO () #if defined(EVENTLOG_SOCKET) startEventlogSocketFromEnv = GHC.Eventlog.Socket.startFromEnv @@ -104,6 +108,13 @@ startEventlogSocketFromEnv = GHC.Eventlog.Socket.startFromEnv startEventlogSocketFromEnv = pure () #endif +startGhcStackProfilerFromEnv :: IO () -> IO () +#if defined(GHC_STACK_PROFILER) +startGhcStackProfilerFromEnv act = GHC.Stack.Profiler.withProfilerFromEnv (const act) +#else +startGhcStackProfilerFromEnv = id +#endif + ----------------------------------------------------------------------------- -- ToDo: @@ -117,7 +128,7 @@ startEventlogSocketFromEnv = pure () -- GHC's command-line interface main :: IO () -main = do +main = startGhcStackProfilerFromEnv $ do startEventlogSocketFromEnv hSetBuffering stdout LineBuffering ===================================== ghc/ghc-bin.cabal.in ===================================== @@ -37,6 +37,11 @@ Flag threaded Default: True Manual: True +Flag ghc-stack-profiler + Description: Build with support for ghc-stack-profiler + Default: False + Manual: True + Executable ghc Default-Language: GHC2024 @@ -102,6 +107,10 @@ Executable ghc build-depends: eventlog-socket CPP-OPTIONS: -DEVENTLOG_SOCKET + if flag(ghc-stack-profiler) + build-depends: ghc-stack-profiler + CPP-OPTIONS: -DGHC_STACK_PROFILER + Other-Extensions: CPP NondecreasingIndentation ===================================== hadrian/src/Packages.hs ===================================== @@ -14,6 +14,7 @@ module Packages ( lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace, eventlogSocket, eventlogSocketControl, ghcPackages, isGhcPackage, + async, hashable, unorderedContainers, ghc_stack_profiler, ghc_stack_profiler_core, -- * Package information crossPrefix, programBasename, programName, nonHsMainPackage, programPath, timeoutPath, @@ -44,7 +45,9 @@ ghcPackages = , timeout , eventlogSocketControl, eventlogSocket , lintersCommon - , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace ] + , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace + , async, hashable, unorderedContainers, ghc_stack_profiler_core, ghc_stack_profiler + ] -- TODO: Optimise by switching to sets of packages. isGhcPackage :: Package -> Bool @@ -139,6 +142,11 @@ win32 = lib "Win32" xhtml = lib "xhtml" eventlogSocket = lib "eventlog-socket" `setPath` "eventlog-socket/eventlog-socket" eventlogSocketControl = lib "eventlog-socket-control" `setPath` "eventlog-socket/eventlog-socket-control" +async = lib "async" +hashable = lib "hashable" +unorderedContainers = lib "unordered-containers" +ghc_stack_profiler = lib "ghc-stack-profiler" `setPath` "ghc-stack-profiler/ghc-stack-profiler" +ghc_stack_profiler_core = lib "ghc-stack-profiler-core" `setPath` "ghc-stack-profiler/ghc-stack-profiler-core" lintersCommon = lib "linters-common" `setPath` "linters/linters-common" lintNotes = linter "lint-notes" ===================================== hadrian/src/Settings/Default.hs ===================================== @@ -192,6 +192,11 @@ stagedPackages stage = do , hpcBin , if winTarget then win32 else unix , runGhc + , ghc_stack_profiler + , ghc_stack_profiler_core + , async + , hashable + , unorderedContainers ] , when (winTarget && not cross) [ -- See Note [Hadrian's ghci-wrapper package] ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -105,6 +105,14 @@ packageArgs = do , builder (Haddock BuildPackage) ? arg ("--optghc=-I" ++ path) ] + , package ghc_stack_profiler ? mconcat + [ builder (Cabal Flags) ? mconcat + [ arg "-use-ghc-trace-events" + -- Add support for eventlog-socket commands + , arg "+control" + ] + ] + , package eventlogSocket ? mconcat [ builder (Cabal Flags) ? mconcat [ @@ -123,6 +131,7 @@ packageArgs = do [ andM [expr (ghcWithInterpreter stage), orM [expr (notM cross), stage1]] `cabalFlag` "interpreter" , andM [expr (ghcWithInterpreter stage), notM (expr cross)] `cabalFlag` "internal-interpreter" , notStage0 `cabalFlag` "eventlog-socket" + , notStage0 `cabalFlag` "sampleTracer" , ifM stage0 -- We build a threaded stage 1 if the bootstrapping compiler -- supports it. ===================================== libraries/async ===================================== @@ -0,0 +1 @@ +Subproject commit 474fc7f612b74e73e24e91474fa75af18eede7b7 ===================================== libraries/hashable ===================================== @@ -0,0 +1 @@ +Subproject commit d56d62eb2a9ff4376e7119d925ececa60959d9ec ===================================== libraries/unordered-containers ===================================== @@ -0,0 +1 @@ +Subproject commit 368ea40488bf3c644e9c36d996302029fb0fc227 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fe6cefbeb7900c63a49a83fb19d8e91… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fe6cefbeb7900c63a49a83fb19d8e91… 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/apk/unary-dfuns
by Andreas Klebinger (＠AndreasK) 11 Sep '26

11 Sep '26

Andreas Klebinger pushed new branch wip/apk/unary-dfuns at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/apk/unary-dfuns You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][master] EPA: Remove ListBanana / ListParens from AnnListBrackets
by Marge Bot (＠marge-bot) 11 Sep '26

11 Sep '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 130286e3 by Alan Zimmerman at 2026-09-11T08:34:08-04:00 EPA: Remove ListBanana / ListParens from AnnListBrackets This is a step towards making AnnList only represent lists of items which can have either braces or layout. - - - - - 8 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - testsuite/tests/ghc-api/T25121_status.stdout - utils/check-exact/ExactPrint.hs - utils/check-exact/Utils.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -294,7 +294,7 @@ type instance XDo GhcPs = (AnnList, EpaLocation) type instance XDo GhcRn = NoExtField type instance XDo GhcTc = Type -type instance XExplicitList GhcPs = AnnList +type instance XExplicitList GhcPs = (EpToken "[", EpToken "]") type instance XExplicitList GhcRn = NoExtField type instance XExplicitList GhcTc = Type -- GhcPs: ExplicitList includes all source-level @@ -1440,7 +1440,7 @@ type instance XCmdArrApp GhcPs = (IsUnicodeSyntax, EpaLocation) type instance XCmdArrApp GhcRn = NoExtField type instance XCmdArrApp GhcTc = Type -type instance XCmdArrForm GhcPs = AnnList +type instance XCmdArrForm GhcPs = (EpUniToken "(|" "⦇", EpUniToken "|)" "⦈") -- | fixity (filled in by the renamer), for forms that were converted from -- OpApp's by the renamer type instance XCmdArrForm GhcRn = Maybe Fixity ===================================== compiler/GHC/Hs/Pat.hs ===================================== @@ -104,7 +104,7 @@ type instance XBangPat GhcPs = EpToken "!" type instance XBangPat GhcRn = NoExtField type instance XBangPat GhcTc = NoExtField -type instance XListPat GhcPs = AnnList +type instance XListPat GhcPs = (EpToken "[", EpToken "]") -- After parsing, ListPat can refer to a built-in Haskell list pattern -- or an overloaded list pattern. type instance XListPat GhcRn = NoExtField ===================================== compiler/GHC/Parser.y ===================================== @@ -3282,7 +3282,7 @@ aexp2 :: { ECP } -- arrow notation extension | '(|' aexp cmdargs '|)' {% runPV (unECP $2) >>= \ $2 -> fmap ecpFromCmd $ - amsA' (sLL $1 $> $ HsCmdArrForm (AnnList (glRM $1) (ListBanana (epUniTok $1) (epUniTok $4)) []) $2 Prefix + amsA' (sLL $1 $> $ HsCmdArrForm (epUniTok $1, epUniTok $4) $2 Prefix (reverse $3)) } projection :: { Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))) } @@ -3414,9 +3414,9 @@ tup_tail :: { forall b. DisambECP b => PV [Either (EpAnn Bool) (LocatedA b)] } -- Never empty. list :: { forall b. DisambECP b => SrcSpan -> (EpaLocation, EpaLocation) -> PV (LocatedA b) } : texp { \loc (ao,ac) -> unECP $1 >>= \ $1 -> - mkHsExplicitListPV loc [$1] (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) []) } + mkHsExplicitListPV loc [$1] (EpTok ao, EpTok ac) } | lexps { \loc (ao,ac) -> $1 >>= \ $1 -> - mkHsExplicitListPV loc (reverse $1) (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) []) } + mkHsExplicitListPV loc (reverse $1) (EpTok ao, EpTok ac) } | texp '..' { \loc (ao,ac) -> unECP $1 >>= \ $1 -> amsA' (L loc $ ArithSeq (AnnArithSeq (EpTok ao) Nothing (epTok $2) (EpTok ac)) Nothing (From $1)) >>= ecpFromExp' } ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -519,10 +519,8 @@ data AnnList } deriving (Data,Eq) data AnnListBrackets - = ListParens (EpToken "(") (EpToken ")") - | ListBraces (EpToken "{") (EpToken "}") + = ListBraces (EpToken "{") (EpToken "}") | ListSquare (EpToken "[") (EpToken "]") - | ListBanana (EpUniToken "(|" "⦇") (EpUniToken "|)" "⦈") | ListNone deriving (Data,Eq) @@ -1094,10 +1092,8 @@ instance Outputable AnnList where = text "AnnList" <+> ppr l <+> ppr p <+> ppr s instance Outputable AnnListBrackets where - ppr (ListParens o c) = text "ListParens" <+> ppr o <+> ppr c ppr (ListBraces o c) = text "ListBraces" <+> ppr o <+> ppr c ppr (ListSquare o c) = text "ListSquare" <+> ppr o <+> ppr c - ppr (ListBanana o c) = text "ListBanana" <+> ppr o <+> ppr c ppr ListNone = text "ListNone" instance Outputable AnnCType where ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -1827,7 +1827,7 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where mkHsTySigPV :: SrcSpanAnnA -> LocatedA b -> LHsType GhcPs -> TokDcolon -> PV (LocatedA b) -- | Disambiguate "[a,b,c]" (list syntax) - mkHsExplicitListPV :: SrcSpan -> [LocatedA b] -> AnnList -> PV (LocatedA b) + mkHsExplicitListPV :: SrcSpan -> [LocatedA b] -> (EpToken "[", EpToken "]") -> PV (LocatedA b) -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices) mkHsSplicePV :: Located (HsUntypedSplice GhcPs) -> PV (LocatedA b) -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates) ===================================== testsuite/tests/ghc-api/T25121_status.stdout ===================================== @@ -15,7 +15,7 @@ X(FunArr) match = NoExtField X(ExprWithTySig) match = EpUniToken "::" "\8759" X(UntypedSplice) match = NoExtField X(ExplicitList) mismatch - >>> AnnList + >>> ((EpToken "["),(EpToken "]")) <<< ((EpToken "'"),(EpToken "["),(EpToken "]")) X(ExplicitTuple) mismatch >>> AnnParen ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -764,18 +764,12 @@ markLensBracketsO' :: (Monad m, Monoid w) => a -> Lens a AnnListBrackets -> EP w m a markLensBracketsO' a l = case view l a of - ListParens o c -> do - o' <- markEpToken o - return (set l (ListParens o' c) a) ListBraces o c -> do o' <- markEpToken o return (set l (ListBraces o' c) a) ListSquare o c -> do o' <- markEpToken o return (set l (ListSquare o' c) a) - ListBanana o c -> do - o' <- markEpUniToken o - return (set l (ListBanana o' c) a) ListNone -> return (set l ListNone a) markLensBracketsC :: (Monad m, Monoid w) @@ -786,18 +780,12 @@ markLensBracketsC' :: (Monad m, Monoid w) => a -> Lens a AnnListBrackets -> EP w m a markLensBracketsC' a l = case view l a of - ListParens o c -> do - c' <- markEpToken c - return (set l (ListParens o c') a) ListBraces o c -> do c' <- markEpToken c return (set l (ListBraces o c') a) ListSquare o c -> do c' <- markEpToken c return (set l (ListSquare o c') a) - ListBanana o c -> do - c' <- markEpUniToken c - return (set l (ListBanana o c') a) ListNone -> return (set l ListNone a) -- ------------------------------------- @@ -2919,13 +2907,13 @@ instance ExactPrint (HsExpr GhcPs) where (an',l',stmts') <- exactDo (an,l) do_or_list_comp stmts return (HsDo (an',l') do_or_list_comp stmts') - exact (ExplicitList an es) = do + exact (ExplicitList (o,c) es) = do debugM $ "ExplicitList start" - an0 <- markLensBracketsO' an lal_brackets + o' <- markEpToken o es' <- mapM markAnnotated es - an1 <- markLensBracketsC' an0 lal_brackets + c' <- markEpToken c debugM $ "ExplicitList end" - return (ExplicitList an1 es') + return (ExplicitList (o',c') es') exact (RecordCon x con_id binds) = do con_id' <- markAnnotated con_id binds' <- markAnnotated binds @@ -3335,8 +3323,8 @@ instance ExactPrint (HsCmd GhcPs) where arr' <- markAnnotated arr return (HsCmdArrApp (isU, l') arr' arg' HsHigherOrderApp False) - exact (HsCmdArrForm an e fixity cs) = do - an0 <- markLensBracketsO' an lal_brackets + exact (HsCmdArrForm (o,c) e fixity cs) = do + o' <- markEpUniToken o (e',cs') <- case (fixity, cs) of (Infix, (arg1:argrest)) -> do arg1' <- markAnnotated arg1 @@ -3348,8 +3336,8 @@ instance ExactPrint (HsCmd GhcPs) where cs' <- mapM markAnnotated cs return (e', cs') (Infix, []) -> error "Not possible" - an1 <- markLensBracketsC' an0 lal_brackets - return (HsCmdArrForm an1 e' fixity cs') + c' <- markEpUniToken c + return (HsCmdArrForm (o',c') e' fixity cs') exact (HsCmdApp an e1 e2) = do e1' <- markAnnotated e1 @@ -4671,9 +4659,11 @@ instance ExactPrint (Pat GhcPs) where pat' <- markAnnotated pat return (BangPat an0 pat') - exact (ListPat an pats) = do - (an', pats') <- markAnnList' an (mapM markAnnotated pats) - return (ListPat an' pats') + exact (ListPat (os,cs) pats) = do + os' <- markEpToken os + pats' <- mapM markAnnotated pats + cs' <- markEpToken cs + return (ListPat (os',cs') pats') exact (TuplePat an pats boxity) = do an0 <- markOpeningParen an ===================================== utils/check-exact/Utils.hs ===================================== @@ -342,10 +342,8 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports (xs',rest') = allocPreceding xs rest annListBracketsLocs :: AnnListBrackets -> (EpaLocation,EpaLocation) -annListBracketsLocs (ListParens o c) = (getEpTokenLoc o, getEpTokenLoc c) annListBracketsLocs (ListBraces o c) = (getEpTokenLoc o, getEpTokenLoc c) annListBracketsLocs (ListSquare o c) = (getEpTokenLoc o, getEpTokenLoc c) -annListBracketsLocs (ListBanana o c) = (getEpUniTokenLoc o, getEpUniTokenLoc c) annListBracketsLocs ListNone = (noAnn, noAnn) data SplitWhere = Before | After View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/130286e3913601edcee7aeb5d2d0077… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/130286e3913601edcee7aeb5d2d0077… 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