August 2026 - ghc-commits

[Git][ghc/ghc][wip/sjakobi/T16836-implicit-field-strictness] Add -Wimplicit-field-strictness (#16836)
by Simon Jakobi (＠sjakobi) 20 Aug '26

20 Aug '26

Simon Jakobi pushed to branch wip/sjakobi/T16836-implicit-field-strictness at Glasgow Haskell Compiler / GHC Commits: 32057e4e by Simon Jakobi at 2026-08-20T23:40:57+02:00 Add -Wimplicit-field-strictness (#16836) This opt-in warning fires when a data constructor field lacks an explicit strictness annotation (`!` or `~`). It complements the LazyFieldAnnotations extension (4762a8bf30f) from GHC proposal 752, which makes `~` annotations available for this purpose. One diagnostic is emitted per data declaration, grouped by constructor. Closes #16836. Assisted-by: Claude Fable 5 - - - - - 18 changed files: - + changelog.d/implicit-field-strictness-warning - changelog.d/lazy-field-annotations - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - docs/users_guide/exts/strict.rst - docs/users_guide/using-warnings.rst - + testsuite/tests/warnings/should_compile/T16836a.hs - + testsuite/tests/warnings/should_compile/T16836a.stderr - + testsuite/tests/warnings/should_compile/T16836b.hs - + testsuite/tests/warnings/should_compile/T16836c.hs - + testsuite/tests/warnings/should_compile/T16836c.stderr - testsuite/tests/warnings/should_compile/all.T Changes: ===================================== changelog.d/implicit-field-strictness-warning ===================================== @@ -0,0 +1,10 @@ +section: compiler +synopsis: Add `-Wimplicit-field-strictness` +issues: #16836 +mrs: !16555 + +description: { + The new opt-in warning :ghc-flag:`-Wimplicit-field-strictness` reports + data constructor fields that lack an explicit strictness annotation + (``!`` or ``~``). +} ===================================== changelog.d/lazy-field-annotations ===================================== @@ -11,4 +11,7 @@ description: { continues to control the default strictness of unannotated fields. See `GHC Proposal #752 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0752-l…>`_. + + Also note the new :ghc-flag:`-Wimplicit-field-strictness` warning, which + reports fields lacking an explicit annotation. } ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -1142,6 +1142,7 @@ data WarningFlag = | Opt_WarnUnrecognisedModifiers -- ^ @since 10.0 | Opt_WarnSemaphoreOpenFailure -- Since 10.0.1 | Opt_WarnDefaultedCallStack -- ^ @since 10.2 + | Opt_WarnImplicitFieldStrictness -- ^ @since 10.2 deriving (Eq, Ord, Show, Enum, Bounded) -- | Return the names of a WarningFlag @@ -1251,6 +1252,7 @@ warnFlagNames wflag = case wflag of Opt_WarnTypeEqualityRequiresOperators -> "type-equality-requires-operators" :| [] Opt_WarnMissingRoleAnnotations -> "missing-role-annotations" :| [] Opt_WarnImplicitRhsQuantification -> "implicit-rhs-quantification" :| [] + Opt_WarnImplicitFieldStrictness -> "implicit-field-strictness" :| [] Opt_WarnIncompleteExportWarnings -> "incomplete-export-warnings" :| [] Opt_WarnIncompleteRecordSelectors -> "incomplete-record-selectors" :| [] Opt_WarnBadlyLevelledTypes -> "badly-levelled-types" :| [] ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -2449,6 +2449,7 @@ wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of Opt_WarnUnrecognisedModifiers -> warnSpec x Opt_WarnSemaphoreOpenFailure -> warnSpec x Opt_WarnDefaultedCallStack -> warnSpec x + Opt_WarnImplicitFieldStrictness -> warnSpec x warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)] warningGroupsDeps = map mk warningGroups ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -1384,6 +1384,21 @@ instance Diagnostic TcRnMessage where hang (text "Missing role annotation" <> colon) 2 (text "type role" <+> ppr name <+> hsep (map ppr roles)) + TcRnImplicitFieldStrictness _name _lazy_anns cons -> mkSimpleDecorated $ + hang (text "Constructor fields without explicit strictness" <> colon) + 2 (vcat (map ppr_con cons)) + where + ppr_con (con, fields) = + bullet <+> text "In" <+> quotes (ppr con) <> colon <+> ppr_fields fields + ppr_fields fields + | let names = concat [ns | ImplicitStrictnessRecField _ ns <- fields] + , not (null names) + = text "field" <> plural names <+> quotedListWithAnd (map ppr names) + | otherwise + = let poss = [i | ImplicitStrictnessPosField _ i <- fields] + in text "the" <+> unquotedListWith (text "and") (map speakNth poss) + <+> text "field" <> plural poss + TcRnIllformedTypePattern p -> mkSimpleDecorated $ hang (text "Ill-formed type pattern:") 2 (ppr p) @@ -2693,6 +2708,8 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnMissingRoleAnnotation{} -> WarningWithFlag Opt_WarnMissingRoleAnnotations + TcRnImplicitFieldStrictness{} + -> WarningWithFlag Opt_WarnImplicitFieldStrictness TcRnIllegalInvisTyVarBndr{} -> ErrorWithoutFlag TcRnIllegalWildcardTyVarBndr{} @@ -3428,6 +3445,12 @@ instance Diagnostic TcRnMessage where -> noHints TcRnMissingRoleAnnotation{} -> noHints + TcRnImplicitFieldStrictness _ lazy_anns _ + -> SuggestExplicitFieldStrictness + : [ useExtensionInOrderTo + (text "to allow" <+> quotes (char '~') <+> text "annotations") + LangExt.LazyFieldAnnotations + | not lazy_anns ] TcRnIllegalInvisTyVarBndr{} -> [suggestExtension LangExt.TypeAbstractions] TcRnIllegalWildcardTyVarBndr{} ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -123,6 +123,7 @@ module GHC.Tc.Errors.Types ( , TypeSyntax(..) , typeSyntaxExtension , SuggestLinear(..) + , ImplicitStrictnessField(..) -- * Errors for hs-boot and signature files , BadBootDecls(..) @@ -4235,6 +4236,24 @@ data TcRnMessage where -} TcRnMissingRoleAnnotation :: Name -> [Role] -> TcRnMessage + + {-| TcRnImplicitFieldStrictness is a warning that occurs when a data + constructor field lacks an explicit strictness annotation (@!@ or @~@) + + Controlled by flags: + - Wimplicit-field-strictness + + Test cases: + T16836a, T16836b + + -} + TcRnImplicitFieldStrictness + :: Name -- ^ the type constructor + -> Bool -- ^ whether @LazyFieldAnnotations@ is enabled + -> [(Name, [ImplicitStrictnessField])] + -- ^ per data constructor, the fields lacking annotations + -> TcRnMessage + {-| TcRnPatersonCondFailure is an error that occurs when an instance declaration fails to conform to the Paterson conditions. Which particular condition fails depends on the constructor of PatersonCondFailure @@ -6399,6 +6418,14 @@ data PatSynInvalidRhsReason | PatSynUnboundVar !Name deriving (Generic) +-- | A constructor field lacking an explicit strictness annotation, as +-- reported by 'TcRnImplicitFieldStrictness'. +data ImplicitStrictnessField + -- | A record field group @x, y :: ty@ sharing one (absent) annotation + = ImplicitStrictnessRecField SrcSpan [RdrName] + -- | A positional argument (1-based index) + | ImplicitStrictnessPosField SrcSpan Int + data BadFieldAnnotationReason where {-| A lazy data type field annotation (~) was used without enabling the extension LazyFieldAnnotations. ===================================== compiler/GHC/Tc/TyCl.hs ===================================== @@ -4023,8 +4023,39 @@ dataDeclChecks tc_name mctxt cons ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? ; unless (not (null cons) || empty_data_decls || is_boot) $ addErrTc (TcRnEmptyDataDeclsDisabled tc_name) + + ; warn_implicit_strictness <- woptM Opt_WarnImplicitFieldStrictness + ; when warn_implicit_strictness $ case cons of + DataTypeCons False data_cons + | let offenders = concatMap conImplicitStrictnessFields data_cons + , not (null offenders) + -> do { lazy_anns <- xoptM LangExt.LazyFieldAnnotations + ; setSrcSpan (getSrcSpan tc_name) $ addDiagnosticTc $ + TcRnImplicitFieldStrictness tc_name lazy_anns offenders } + _ -> return () + ; return gadt_syntax } +conImplicitStrictnessFields :: LConDecl GhcRn -> [(Name, [ImplicitStrictnessField])] +conImplicitStrictnessFields (L _ con) + | null fields = [] + | otherwise = [ (unLoc n, fields) | n <- getConNames con ] + where + fields = case con of + ConDeclH98 { con_args = PrefixCon _ args } -> pos_fields args + ConDeclH98 { con_args = InfixCon _ a1 a2 } -> pos_fields [a1, a2] + ConDeclH98 { con_args = RecCon _ (L _ flds) } -> rec_fields flds + ConDeclGADT { con_g_args = PrefixConGADT _ args } -> pos_fields args + ConDeclGADT { con_g_args = RecConGADT _ (L _ flds) } -> rec_fields flds + + pos_fields args = [ ImplicitStrictnessPosField (getLocA (cdf_type f)) i + | (i, f) <- zip [1 :: Int ..] args + , NoSrcStrict <- [cdf_bang f] ] + rec_fields flds = [ ImplicitStrictnessRecField (getLocA (cdf_type spec)) + [ rdr | L _ (FieldOcc rdr _) <- names ] + | L _ (HsConDeclRecField _ names spec) <- flds + , NoSrcStrict <- [cdf_bang spec] ] + ----------------------------------- data DataDeclInfo ===================================== compiler/GHC/Types/Error/Codes.hs ===================================== @@ -542,6 +542,7 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "TcRnNegativeNumTypeLiteral" = 93632 GhcDiagnosticCode "TcRnUnusedQuantifiedTypeVar" = 54180 GhcDiagnosticCode "TcRnMissingRoleAnnotation" = 65490 + GhcDiagnosticCode "TcRnImplicitFieldStrictness" = 47032 GhcDiagnosticCode "TcRnUntickedPromotedThing" = 49957 GhcDiagnosticCode "TcRnIllegalBuiltinSyntax" = 39716 ===================================== compiler/GHC/Types/Hint.hs ===================================== @@ -343,6 +343,14 @@ data GhcHint -} | SuggestAddStandaloneKindSignature Name + {-| Suggests to annotate each constructor field with explicit strictness + (@!@ or @~@), without picking one. + + Triggered by: 'GHC.Tc.Errors.Types.TcRnImplicitFieldStrictness' + Test case(s): warnings/should_compile/T16836a + -} + | SuggestExplicitFieldStrictness + {-| Suggests the user to fill in the wildcard constraint to disambiguate which constraint that is. ===================================== compiler/GHC/Types/Hint/Ppr.hs ===================================== @@ -185,6 +185,9 @@ instance Outputable GhcHint where -> text "Use a standalone deriving declaration instead" SuggestAddStandaloneKindSignature name -> text "Add a standalone kind signature for" <+> quotes (ppr name) + SuggestExplicitFieldStrictness + -> text "Annotate each field with" <+> quotes (char '!') + <+> text "(strict) or" <+> quotes (char '~') <+> text "(lazy)" SuggestFillInWildcardConstraint -> text "Fill in the wildcard constraint yourself" SuggestAppropriateTHTick ns ===================================== docs/users_guide/exts/strict.rst ===================================== @@ -194,6 +194,9 @@ The ``~`` annotation must be written in prefix form:: See `GHC Proposal #229 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-w…>`__ for the precise rules. +See also :ghc-flag:`-Wimplicit-field-strictness`, which warns about +fields lacking an explicit annotation. + .. _strict-data: Strict-by-default data types ===================================== docs/users_guide/using-warnings.rst ===================================== @@ -2505,6 +2505,23 @@ of ``-W(no-)*``. In other words the type-class role cannot be accidentally left representational or phantom, which could affected the code correctness. +.. ghc-flag:: -Wimplicit-field-strictness + :shortdesc: warn when constructor fields lack explicit strictness annotations + :type: dynamic + :reverse: -Wno-implicit-field-strictness + :category: + + :since: 10.2.1 + :default: off + + .. index:: + single: strictness annotations, missing + + If you would like GHC to check that every data constructor field carries + an explicit strictness annotation — ``!`` (strict) or ``~`` (lazy) — use + the :ghc-flag:`-Wimplicit-field-strictness` option. It reports one warning + per data declaration, listing the unannotated fields of each constructor. + .. ghc-flag:: -Wimplicit-rhs-quantification :shortdesc: warn when type variables on the RHS of a type synonym are implicitly quantified :type: dynamic ===================================== testsuite/tests/warnings/should_compile/T16836a.hs ===================================== @@ -0,0 +1,37 @@ +{-# OPTIONS_GHC -Wimplicit-field-strictness #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module T16836a where + +-- plain multi-constructor data +-- warns for both constructors +data T a = MkT a Bool + | MkT2 !Int a + +-- record with a shared field group +-- warns for x, y and z; not for b +data R = MkR { x, y :: Int, z :: Char, b :: !Bool } + +-- infix constructor +-- warns for the first argument +data I = Int :+: !Bool + +-- GADT syntax +-- warns for the first argument +data G a where + MkG :: Int -> !Bool -> G a + +-- GADT record syntax +-- warns for gx +data GR a where + MkGR :: { gx :: Int, gy :: !Bool } -> GR a + +-- data family instance +-- warns +data family F a +data instance F Int = MkF Char + +-- fully annotated +-- doesn't warn +data S = MkS !Int !Bool ===================================== testsuite/tests/warnings/should_compile/T16836a.stderr ===================================== @@ -0,0 +1,55 @@ +T16836a.hs:9:1: warning: [GHC-47032] [-Wimplicit-field-strictness] + • Constructor fields without explicit strictness: + • In ‘MkT’: the first and second fields + • In ‘MkT2’: the second field + • In the data type declaration for ‘T’ + Suggested fixes: + • Annotate each field with ‘!’ (strict) or ‘~’ (lazy) + • Use the ‘LazyFieldAnnotations’ extension (implied by ‘StrictData’) + to allow ‘~’ annotations + +T16836a.hs:14:1: warning: [GHC-47032] [-Wimplicit-field-strictness] + • Constructor fields without explicit strictness: + • In ‘MkR’: fields ‘x’, ‘y’ and ‘z’ + • In the data type declaration for ‘R’ + Suggested fixes: + • Annotate each field with ‘!’ (strict) or ‘~’ (lazy) + • Use the ‘LazyFieldAnnotations’ extension (implied by ‘StrictData’) + to allow ‘~’ annotations + +T16836a.hs:18:1: warning: [GHC-47032] [-Wimplicit-field-strictness] + • Constructor fields without explicit strictness: + • In ‘:+:’: the first field + • In the data type declaration for ‘I’ + Suggested fixes: + • Annotate each field with ‘!’ (strict) or ‘~’ (lazy) + • Use the ‘LazyFieldAnnotations’ extension (implied by ‘StrictData’) + to allow ‘~’ annotations + +T16836a.hs:22:1: warning: [GHC-47032] [-Wimplicit-field-strictness] + • Constructor fields without explicit strictness: + • In ‘MkG’: the first field + • In the data type declaration for ‘G’ + Suggested fixes: + • Annotate each field with ‘!’ (strict) or ‘~’ (lazy) + • Use the ‘LazyFieldAnnotations’ extension (implied by ‘StrictData’) + to allow ‘~’ annotations + +T16836a.hs:27:1: warning: [GHC-47032] [-Wimplicit-field-strictness] + • Constructor fields without explicit strictness: + • In ‘MkGR’: field ‘gx’ + • In the data type declaration for ‘GR’ + Suggested fixes: + • Annotate each field with ‘!’ (strict) or ‘~’ (lazy) + • Use the ‘LazyFieldAnnotations’ extension (implied by ‘StrictData’) + to allow ‘~’ annotations + +T16836a.hs:32:1: warning: [GHC-47032] [-Wimplicit-field-strictness] + • Constructor fields without explicit strictness: + • In ‘MkF’: the first field + • In the data family instance declaration for ‘F’ + Suggested fixes: + • Annotate each field with ‘!’ (strict) or ‘~’ (lazy) + • Use the ‘LazyFieldAnnotations’ extension (implied by ‘StrictData’) + to allow ‘~’ annotations + ===================================== testsuite/tests/warnings/should_compile/T16836b.hs ===================================== @@ -0,0 +1,25 @@ +{-# OPTIONS_GHC -Wimplicit-field-strictness #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeData #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE LazyFieldAnnotations #-} +module T16836b where + +-- fully annotated declarations don't warn +data T a = MkT ~a !Bool +data R = MkR { x, y :: !Int, z :: ~Char } +data G a where + MkG :: !Int -> ~Bool -> G a +data family F a +data instance F Int = MkF !Char + +-- newtypes can't have annotations; exempt +newtype N = MkN Int + +-- 'type data' can't have annotations; exempt +type data TD = MkTD Bool + +-- no fields, nothing to annotate +data E +data Nullary = A | B ===================================== testsuite/tests/warnings/should_compile/T16836c.hs ===================================== @@ -0,0 +1,6 @@ +{-# OPTIONS_GHC -Wimplicit-field-strictness #-} +{-# LANGUAGE StrictData #-} +module T16836c where + +-- unannotated fields warn under StrictData too +data T a = MkT a !Bool ~Char ===================================== testsuite/tests/warnings/should_compile/T16836c.stderr ===================================== @@ -0,0 +1,6 @@ +T16836c.hs:6:1: warning: [GHC-47032] [-Wimplicit-field-strictness] + • Constructor fields without explicit strictness: + • In ‘MkT’: the first field + • In the data type declaration for ‘T’ + Suggested fix: Annotate each field with ‘!’ (strict) or ‘~’ (lazy) + ===================================== testsuite/tests/warnings/should_compile/all.T ===================================== @@ -91,3 +91,6 @@ test('T25901_imp_unused_3', [extra_files(['T25901_helper_3.hs'])], multimod_comp test('T25901_imp_unused_4', normal, compile, ['-Wunused-imports']) test('T25901_imp_dodgy_1', [extra_files(['T25901_helper_1.hs'])], multimod_compile, ['T25901_imp_dodgy_1', '-v0 -Wdodgy-imports']) test('T25901_imp_dodgy_2', [extra_files(['T25901_helper_2.hs'])], multimod_compile, ['T25901_imp_dodgy_2', '-v0 -Wdodgy-imports']) +test('T16836a', normal, compile, ['']) +test('T16836b', normal, compile, ['']) +test('T16836c', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/32057e4e619c1f55a9a8b21455c9b59… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/32057e4e619c1f55a9a8b21455c9b59… 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/sjakobi/T16836-implicit-field-strictness] Add -Wimplicit-field-strictness (#16836)
by Simon Jakobi (＠sjakobi) 20 Aug '26

20 Aug '26

Simon Jakobi pushed to branch wip/sjakobi/T16836-implicit-field-strictness at Glasgow Haskell Compiler / GHC Commits: 5aa98496 by Simon Jakobi at 2026-08-20T23:30:18+02:00 Add -Wimplicit-field-strictness (#16836) This opt-in warning fires when a data constructor field lacks an explicit strictness annotation (`!` or `~`). It complements the LazyFieldAnnotations extension (4762a8bf30f) from GHC proposal 752, which makes `~` annotations available for this purpose. One diagnostic is emitted per data declaration, grouped by constructor. Closes #16836. Assisted-by: Claude Fable 5 - - - - - 18 changed files: - + changelog.d/implicit-field-strictness-warning - changelog.d/lazy-field-annotations - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - docs/users_guide/exts/strict.rst - docs/users_guide/using-warnings.rst - + testsuite/tests/warnings/should_compile/T16836a.hs - + testsuite/tests/warnings/should_compile/T16836a.stderr - + testsuite/tests/warnings/should_compile/T16836b.hs - + testsuite/tests/warnings/should_compile/T16836c.hs - + testsuite/tests/warnings/should_compile/T16836c.stderr - testsuite/tests/warnings/should_compile/all.T Changes: ===================================== changelog.d/implicit-field-strictness-warning ===================================== @@ -0,0 +1,10 @@ +section: compiler +synopsis: Add `-Wimplicit-field-strictness` +issues: #16836 +mrs: !16555 + +description: { + The new opt-in warning :ghc-flag:`-Wimplicit-field-strictness` reports + data constructor fields that lack an explicit strictness annotation + (``!`` or ``~``). +} ===================================== changelog.d/lazy-field-annotations ===================================== @@ -11,4 +11,7 @@ description: { continues to control the default strictness of unannotated fields. See `GHC Proposal #752 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0752-l…>`_. + + Also note the new :ghc-flag:`-Wimplicit-field-strictness` warning, which + reports fields lacking an explicit annotation. } ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -1142,6 +1142,7 @@ data WarningFlag = | Opt_WarnUnrecognisedModifiers -- ^ @since 10.0 | Opt_WarnSemaphoreOpenFailure -- Since 10.0.1 | Opt_WarnDefaultedCallStack -- ^ @since 10.2 + | Opt_WarnImplicitFieldStrictness -- ^ @since 10.2 deriving (Eq, Ord, Show, Enum, Bounded) -- | Return the names of a WarningFlag @@ -1251,6 +1252,7 @@ warnFlagNames wflag = case wflag of Opt_WarnTypeEqualityRequiresOperators -> "type-equality-requires-operators" :| [] Opt_WarnMissingRoleAnnotations -> "missing-role-annotations" :| [] Opt_WarnImplicitRhsQuantification -> "implicit-rhs-quantification" :| [] + Opt_WarnImplicitFieldStrictness -> "implicit-field-strictness" :| [] Opt_WarnIncompleteExportWarnings -> "incomplete-export-warnings" :| [] Opt_WarnIncompleteRecordSelectors -> "incomplete-record-selectors" :| [] Opt_WarnBadlyLevelledTypes -> "badly-levelled-types" :| [] ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -2449,6 +2449,7 @@ wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of Opt_WarnUnrecognisedModifiers -> warnSpec x Opt_WarnSemaphoreOpenFailure -> warnSpec x Opt_WarnDefaultedCallStack -> warnSpec x + Opt_WarnImplicitFieldStrictness -> warnSpec x warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)] warningGroupsDeps = map mk warningGroups ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -1384,6 +1384,21 @@ instance Diagnostic TcRnMessage where hang (text "Missing role annotation" <> colon) 2 (text "type role" <+> ppr name <+> hsep (map ppr roles)) + TcRnImplicitFieldStrictness _name _lazy_anns cons -> mkSimpleDecorated $ + hang (text "Constructor fields without explicit strictness" <> colon) + 2 (vcat (map ppr_con cons)) + where + ppr_con (con, fields) = + bullet <+> text "In" <+> quotes (ppr con) <> colon <+> ppr_fields fields + ppr_fields fields + | let names = concat [ns | ImplicitStrictnessRecField _ ns <- fields] + , not (null names) + = text "field" <> plural names <+> quotedListWithAnd (map ppr names) + | otherwise + = let poss = [i | ImplicitStrictnessPosField _ i <- fields] + in text "the" <+> unquotedListWith (text "and") (map speakNth poss) + <+> text "field" <> plural poss + TcRnIllformedTypePattern p -> mkSimpleDecorated $ hang (text "Ill-formed type pattern:") 2 (ppr p) @@ -2693,6 +2708,8 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnMissingRoleAnnotation{} -> WarningWithFlag Opt_WarnMissingRoleAnnotations + TcRnImplicitFieldStrictness{} + -> WarningWithFlag Opt_WarnImplicitFieldStrictness TcRnIllegalInvisTyVarBndr{} -> ErrorWithoutFlag TcRnIllegalWildcardTyVarBndr{} @@ -3428,6 +3445,12 @@ instance Diagnostic TcRnMessage where -> noHints TcRnMissingRoleAnnotation{} -> noHints + TcRnImplicitFieldStrictness _ lazy_anns _ + -> SuggestExplicitFieldStrictness + : [ useExtensionInOrderTo + (text "to allow" <+> quotes (char '~') <+> text "annotations") + LangExt.LazyFieldAnnotations + | not lazy_anns ] TcRnIllegalInvisTyVarBndr{} -> [suggestExtension LangExt.TypeAbstractions] TcRnIllegalWildcardTyVarBndr{} ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -123,6 +123,7 @@ module GHC.Tc.Errors.Types ( , TypeSyntax(..) , typeSyntaxExtension , SuggestLinear(..) + , ImplicitStrictnessField(..) -- * Errors for hs-boot and signature files , BadBootDecls(..) @@ -4235,6 +4236,24 @@ data TcRnMessage where -} TcRnMissingRoleAnnotation :: Name -> [Role] -> TcRnMessage + + {-| TcRnImplicitFieldStrictness is a warning that occurs when a data + constructor field lacks an explicit strictness annotation (@!@ or @~@) + + Controlled by flags: + - Wimplicit-field-strictness + + Test cases: + T16836a, T16836b + + -} + TcRnImplicitFieldStrictness + :: Name -- ^ the type constructor + -> Bool -- ^ whether @LazyFieldAnnotations@ is enabled + -> [(Name, [ImplicitStrictnessField])] + -- ^ per data constructor, the fields lacking annotations + -> TcRnMessage + {-| TcRnPatersonCondFailure is an error that occurs when an instance declaration fails to conform to the Paterson conditions. Which particular condition fails depends on the constructor of PatersonCondFailure @@ -6399,6 +6418,14 @@ data PatSynInvalidRhsReason | PatSynUnboundVar !Name deriving (Generic) +-- | A constructor field lacking an explicit strictness annotation, as +-- reported by 'TcRnImplicitFieldStrictness'. +data ImplicitStrictnessField + = -- | A record field group @x, y :: ty@ sharing one (absent) annotation + ImplicitStrictnessRecField SrcSpan [RdrName] + | -- | A positional argument (1-based index) + ImplicitStrictnessPosField SrcSpan Int + data BadFieldAnnotationReason where {-| A lazy data type field annotation (~) was used without enabling the extension LazyFieldAnnotations. ===================================== compiler/GHC/Tc/TyCl.hs ===================================== @@ -4023,8 +4023,39 @@ dataDeclChecks tc_name mctxt cons ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? ; unless (not (null cons) || empty_data_decls || is_boot) $ addErrTc (TcRnEmptyDataDeclsDisabled tc_name) + + ; warn_implicit_strictness <- woptM Opt_WarnImplicitFieldStrictness + ; when warn_implicit_strictness $ case cons of + DataTypeCons False data_cons + | let offenders = concatMap conImplicitStrictnessFields data_cons + , not (null offenders) + -> do { lazy_anns <- xoptM LangExt.LazyFieldAnnotations + ; setSrcSpan (getSrcSpan tc_name) $ addDiagnosticTc $ + TcRnImplicitFieldStrictness tc_name lazy_anns offenders } + _ -> return () + ; return gadt_syntax } +conImplicitStrictnessFields :: LConDecl GhcRn -> [(Name, [ImplicitStrictnessField])] +conImplicitStrictnessFields (L _ con) + | null fields = [] + | otherwise = [ (unLoc n, fields) | n <- getConNames con ] + where + fields = case con of + ConDeclH98 { con_args = PrefixCon _ args } -> pos_fields args + ConDeclH98 { con_args = InfixCon _ a1 a2 } -> pos_fields [a1, a2] + ConDeclH98 { con_args = RecCon _ (L _ flds) } -> rec_fields flds + ConDeclGADT { con_g_args = PrefixConGADT _ args } -> pos_fields args + ConDeclGADT { con_g_args = RecConGADT _ (L _ flds) } -> rec_fields flds + + pos_fields args = [ ImplicitStrictnessPosField (getLocA (cdf_type f)) i + | (i, f) <- zip [1 :: Int ..] args + , NoSrcStrict <- [cdf_bang f] ] + rec_fields flds = [ ImplicitStrictnessRecField (getLocA (cdf_type spec)) + [ rdr | L _ (FieldOcc rdr _) <- names ] + | L _ (HsConDeclRecField _ names spec) <- flds + , NoSrcStrict <- [cdf_bang spec] ] + ----------------------------------- data DataDeclInfo ===================================== compiler/GHC/Types/Error/Codes.hs ===================================== @@ -542,6 +542,7 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "TcRnNegativeNumTypeLiteral" = 93632 GhcDiagnosticCode "TcRnUnusedQuantifiedTypeVar" = 54180 GhcDiagnosticCode "TcRnMissingRoleAnnotation" = 65490 + GhcDiagnosticCode "TcRnImplicitFieldStrictness" = 47032 GhcDiagnosticCode "TcRnUntickedPromotedThing" = 49957 GhcDiagnosticCode "TcRnIllegalBuiltinSyntax" = 39716 ===================================== compiler/GHC/Types/Hint.hs ===================================== @@ -343,6 +343,14 @@ data GhcHint -} | SuggestAddStandaloneKindSignature Name + {-| Suggests to annotate each constructor field with explicit strictness + (@!@ or @~@), without picking one. + + Triggered by: 'GHC.Tc.Errors.Types.TcRnImplicitFieldStrictness' + Test case(s): warnings/should_compile/T16836a + -} + | SuggestExplicitFieldStrictness + {-| Suggests the user to fill in the wildcard constraint to disambiguate which constraint that is. ===================================== compiler/GHC/Types/Hint/Ppr.hs ===================================== @@ -185,6 +185,9 @@ instance Outputable GhcHint where -> text "Use a standalone deriving declaration instead" SuggestAddStandaloneKindSignature name -> text "Add a standalone kind signature for" <+> quotes (ppr name) + SuggestExplicitFieldStrictness + -> text "Annotate each field with" <+> quotes (char '!') + <+> text "(strict) or" <+> quotes (char '~') <+> text "(lazy)" SuggestFillInWildcardConstraint -> text "Fill in the wildcard constraint yourself" SuggestAppropriateTHTick ns ===================================== docs/users_guide/exts/strict.rst ===================================== @@ -194,6 +194,9 @@ The ``~`` annotation must be written in prefix form:: See `GHC Proposal #229 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-w…>`__ for the precise rules. +See also :ghc-flag:`-Wimplicit-field-strictness`, which warns about +fields lacking an explicit annotation. + .. _strict-data: Strict-by-default data types ===================================== docs/users_guide/using-warnings.rst ===================================== @@ -2505,6 +2505,23 @@ of ``-W(no-)*``. In other words the type-class role cannot be accidentally left representational or phantom, which could affected the code correctness. +.. ghc-flag:: -Wimplicit-field-strictness + :shortdesc: warn when constructor fields lack explicit strictness annotations + :type: dynamic + :reverse: -Wno-implicit-field-strictness + :category: + + :since: 10.2.1 + :default: off + + .. index:: + single: strictness annotations, missing + + If you would like GHC to check that every data constructor field carries + an explicit strictness annotation — ``!`` (strict) or ``~`` (lazy) — use + the :ghc-flag:`-Wimplicit-field-strictness` option. It reports one warning + per data declaration, listing the unannotated fields of each constructor. + .. ghc-flag:: -Wimplicit-rhs-quantification :shortdesc: warn when type variables on the RHS of a type synonym are implicitly quantified :type: dynamic ===================================== testsuite/tests/warnings/should_compile/T16836a.hs ===================================== @@ -0,0 +1,37 @@ +{-# OPTIONS_GHC -Wimplicit-field-strictness #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module T16836a where + +-- plain multi-constructor data +-- warns for both constructors +data T a = MkT a Bool + | MkT2 !Int a + +-- record with a shared field group +-- warns for x, y and z; not for b +data R = MkR { x, y :: Int, z :: Char, b :: !Bool } + +-- infix constructor +-- warns for the first argument +data I = Int :+: !Bool + +-- GADT syntax +-- warns for the first argument +data G a where + MkG :: Int -> !Bool -> G a + +-- GADT record syntax +-- warns for gx +data GR a where + MkGR :: { gx :: Int, gy :: !Bool } -> GR a + +-- data family instance +-- warns +data family F a +data instance F Int = MkF Char + +-- fully annotated +-- doesn't warn +data S = MkS !Int !Bool ===================================== testsuite/tests/warnings/should_compile/T16836a.stderr ===================================== @@ -0,0 +1,55 @@ +T16836a.hs:9:1: warning: [GHC-47032] [-Wimplicit-field-strictness] + • Constructor fields without explicit strictness: + • In ‘MkT’: the first and second fields + • In ‘MkT2’: the second field + • In the data type declaration for ‘T’ + Suggested fixes: + • Annotate each field with ‘!’ (strict) or ‘~’ (lazy) + • Use the ‘LazyFieldAnnotations’ extension (implied by ‘StrictData’) + to allow ‘~’ annotations + +T16836a.hs:14:1: warning: [GHC-47032] [-Wimplicit-field-strictness] + • Constructor fields without explicit strictness: + • In ‘MkR’: fields ‘x’, ‘y’ and ‘z’ + • In the data type declaration for ‘R’ + Suggested fixes: + • Annotate each field with ‘!’ (strict) or ‘~’ (lazy) + • Use the ‘LazyFieldAnnotations’ extension (implied by ‘StrictData’) + to allow ‘~’ annotations + +T16836a.hs:18:1: warning: [GHC-47032] [-Wimplicit-field-strictness] + • Constructor fields without explicit strictness: + • In ‘:+:’: the first field + • In the data type declaration for ‘I’ + Suggested fixes: + • Annotate each field with ‘!’ (strict) or ‘~’ (lazy) + • Use the ‘LazyFieldAnnotations’ extension (implied by ‘StrictData’) + to allow ‘~’ annotations + +T16836a.hs:22:1: warning: [GHC-47032] [-Wimplicit-field-strictness] + • Constructor fields without explicit strictness: + • In ‘MkG’: the first field + • In the data type declaration for ‘G’ + Suggested fixes: + • Annotate each field with ‘!’ (strict) or ‘~’ (lazy) + • Use the ‘LazyFieldAnnotations’ extension (implied by ‘StrictData’) + to allow ‘~’ annotations + +T16836a.hs:27:1: warning: [GHC-47032] [-Wimplicit-field-strictness] + • Constructor fields without explicit strictness: + • In ‘MkGR’: field ‘gx’ + • In the data type declaration for ‘GR’ + Suggested fixes: + • Annotate each field with ‘!’ (strict) or ‘~’ (lazy) + • Use the ‘LazyFieldAnnotations’ extension (implied by ‘StrictData’) + to allow ‘~’ annotations + +T16836a.hs:32:1: warning: [GHC-47032] [-Wimplicit-field-strictness] + • Constructor fields without explicit strictness: + • In ‘MkF’: the first field + • In the data family instance declaration for ‘F’ + Suggested fixes: + • Annotate each field with ‘!’ (strict) or ‘~’ (lazy) + • Use the ‘LazyFieldAnnotations’ extension (implied by ‘StrictData’) + to allow ‘~’ annotations + ===================================== testsuite/tests/warnings/should_compile/T16836b.hs ===================================== @@ -0,0 +1,25 @@ +{-# OPTIONS_GHC -Wimplicit-field-strictness #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeData #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE LazyFieldAnnotations #-} +module T16836b where + +-- fully annotated declarations don't warn +data T a = MkT ~a !Bool +data R = MkR { x, y :: !Int, z :: ~Char } +data G a where + MkG :: !Int -> ~Bool -> G a +data family F a +data instance F Int = MkF !Char + +-- newtypes can't have annotations; exempt +newtype N = MkN Int + +-- 'type data' can't have annotations; exempt +type data TD = MkTD Bool + +-- no fields, nothing to annotate +data E +data Nullary = A | B ===================================== testsuite/tests/warnings/should_compile/T16836c.hs ===================================== @@ -0,0 +1,6 @@ +{-# OPTIONS_GHC -Wimplicit-field-strictness #-} +{-# LANGUAGE StrictData #-} +module T16836c where + +-- unannotated fields warn under StrictData too +data T a = MkT a !Bool ~Char ===================================== testsuite/tests/warnings/should_compile/T16836c.stderr ===================================== @@ -0,0 +1,6 @@ +T16836c.hs:6:1: warning: [GHC-47032] [-Wimplicit-field-strictness] + • Constructor fields without explicit strictness: + • In ‘MkT’: the first field + • In the data type declaration for ‘T’ + Suggested fix: Annotate each field with ‘!’ (strict) or ‘~’ (lazy) + ===================================== testsuite/tests/warnings/should_compile/all.T ===================================== @@ -91,3 +91,6 @@ test('T25901_imp_unused_3', [extra_files(['T25901_helper_3.hs'])], multimod_comp test('T25901_imp_unused_4', normal, compile, ['-Wunused-imports']) test('T25901_imp_dodgy_1', [extra_files(['T25901_helper_1.hs'])], multimod_compile, ['T25901_imp_dodgy_1', '-v0 -Wdodgy-imports']) test('T25901_imp_dodgy_2', [extra_files(['T25901_helper_2.hs'])], multimod_compile, ['T25901_imp_dodgy_2', '-v0 -Wdodgy-imports']) +test('T16836a', normal, compile, ['']) +test('T16836b', normal, compile, ['']) +test('T16836c', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5aa98496fdc90d631611a1234a2f941… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5aa98496fdc90d631611a1234a2f941… 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/epa-tidy-locatedxxx-19] EPA: Remove NoEpTok/NoEpUniTok, using an unhelpful SrcSpan instead
by Alan Zimmerman (＠alanz) 20 Aug '26

20 Aug '26

Alan Zimmerman pushed to branch wip/az/epa-tidy-locatedxxx-19 at Glasgow Haskell Compiler / GHC Commits: 1c164534 by Alan Zimmerman at 2026-08-20T21:02:11+01:00 EPA: Remove NoEpTok/NoEpUniTok, using an unhelpful SrcSpan instead Also introduce helper functions noEpTok and noEpUniTok to serve as simple replacements in code inserting an token annotation without location information. - - - - - 35 changed files: - compiler/GHC/Hs.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/Test20239.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr - testsuite/tests/module/mod185.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T14189.stderr - testsuite/tests/parser/should_compile/T15323.stderr - testsuite/tests/parser/should_compile/T20452.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20718b.stderr - testsuite/tests/parser/should_compile/T20846.stderr - testsuite/tests/parser/should_compile/T23315/T23315.stderr - testsuite/tests/printer/AnnotationNoListTuplePuns.stdout - testsuite/tests/printer/T18791.stderr - testsuite/tests/printer/Test20297.stdout - testsuite/tests/printer/Test24533.stdout - utils/check-exact/ExactPrint.hs - utils/check-exact/Parsers.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs - utils/haddock/haddock-api/src/Haddock/Types.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1c16453492ad87163dc4568027b289c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1c16453492ad87163dc4568027b289c… 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/az/epa-tidy-locatedxxx-19
by Alan Zimmerman (＠alanz) 20 Aug '26

20 Aug '26

Alan Zimmerman pushed new branch wip/az/epa-tidy-locatedxxx-19 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/az/epa-tidy-locatedxxx-19 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 LocatedBC / SrcSpanBF
by Marge Bot (＠marge-bot) 20 Aug '26

20 Aug '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 2ca87972 by Alan Zimmerman at 2026-08-20T14:58:36-04:00 EPA: Remove LocatedBC / SrcSpanBF The custom annotations are now in the BooleanFormula TTG extension points, so LBooleanFormula can now use the standard LocatedA. - - - - - 9 changed files: - compiler/GHC/Data/BooleanFormula.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Types.hs Changes: ===================================== compiler/GHC/Data/BooleanFormula.hs ===================================== @@ -25,7 +25,7 @@ import GHC.Types.Unique import GHC.Types.Unique.Set import GHC.Types.SrcLoc (unLoc) import GHC.Utils.Outputable -import GHC.Parser.Annotation ( SrcSpanAnnBF ) +import GHC.Parser.Annotation ( SrcSpanAnnA, EpToken(..) ) import GHC.Hs.Extension (GhcPass (..), OutputableBndrId) import Language.Haskell.Syntax.Extension (Anno, LIdP, IdP, noExtField, NoExtField, DataConCantHappen, @@ -38,12 +38,12 @@ import Language.Haskell.Syntax.BooleanFormula -- Boolean formula type and smart constructors ---------------------------------------------------------------------- -type instance Anno (BooleanFormula (GhcPass p)) = SrcSpanAnnBF +type instance Anno (BooleanFormula (GhcPass p)) = SrcSpanAnnA type instance XBFVar (GhcPass _) = NoExtField type instance XBFAnd (GhcPass _) = NoExtField type instance XBFOr (GhcPass _) = NoExtField -type instance XBFParens (GhcPass _) = NoExtField +type instance XBFParens (GhcPass _) = (EpToken "(", EpToken ")") type instance XXBooleanFormula (GhcPass _) = DataConCantHappen instance BooleanFormulaDefault (GhcPass p) where ===================================== compiler/GHC/Hs/Dump.hs ===================================== @@ -97,7 +97,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 `ext2Q` located `extQ` srcSpanAnnA `extQ` srcSpanAnnN - `extQ` srcSpanAnnBF where generic :: Data a => a -> SDoc generic t = parens $ text (showConstr (toConstr t)) @@ -396,10 +395,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 srcSpanAnnN :: EpAnn NameAnn -> SDoc srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN") - srcSpanAnnBF :: EpAnn AnnBooleanFormula -> SDoc - srcSpanAnnBF = locatedAnn'' (text "SrcSpanAnnBF") - - locatedAnn'' :: forall a. (Typeable a, Data a) => SDoc -> EpAnn a -> SDoc locatedAnn'' tag ss = parens $ ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -2081,7 +2081,7 @@ instance ToHie PendingRnSplice where toHie (PendingRnSplice _ e) = toHie e instance (HiePass p, Data (IdGhcP p)) - => ToHie (GenLocated SrcSpanAnnBF (BooleanFormula (GhcPass p))) where + => ToHie (GenLocated SrcSpanAnnA (BooleanFormula (GhcPass p))) where toHie (L span form) = concatM $ makeNode form (locA span) : case form of Var _ a -> [ toHie $ C Use a ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -1330,7 +1330,7 @@ pprIfaceDecl ss decl@(IfaceClass { ifName = clas fromIfaceBooleanFormula (IfVar nm ) = Var noExtField $ noLocA . mkUnboundName . mkVarOccFS . ifLclNameFS $ nm fromIfaceBooleanFormula (IfAnd bfs ) = And noExtField $ map (noLocA . fromIfaceBooleanFormula) bfs fromIfaceBooleanFormula (IfOr bfs ) = Or noExtField $ map (noLocA . fromIfaceBooleanFormula) bfs - fromIfaceBooleanFormula (IfParens bf) = Parens noExtField $ (noLocA . fromIfaceBooleanFormula) bf + fromIfaceBooleanFormula (IfParens bf) = Parens noAnn $ (noLocA . fromIfaceBooleanFormula) bf -- See Note [Suppressing binder signatures] in GHC.Iface.Type ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -121,7 +121,7 @@ import GHC.Types.Tickish import GHC.Types.TyThing import GHC.Types.Error -import GHC.Parser.Annotation (noLocA) +import GHC.Parser.Annotation (noLocA, noAnn) import GHC.Fingerprint @@ -885,7 +885,7 @@ tc_iface_decl _parent ignore_prags tc_boolean_formula :: IfaceBooleanFormula -> IfL (BooleanFormula GhcRn) tc_boolean_formula (IfAnd ibfs ) = BF.And NoExtField . map noLocA <$> traverse tc_boolean_formula ibfs tc_boolean_formula (IfOr ibfs ) = BF.Or NoExtField . map noLocA <$> traverse tc_boolean_formula ibfs - tc_boolean_formula (IfParens ibf) = BF.Parens NoExtField . noLocA <$> tc_boolean_formula ibf + tc_boolean_formula (IfParens ibf) = BF.Parens noAnn . noLocA <$> tc_boolean_formula ibf tc_boolean_formula (IfVar nm ) = BF.Var NoExtField . noLocA <$> (lookupIfaceTop . mkVarOccFS . ifLclNameFS $ nm) mk_sc_doc pred = text "Superclass" <+> ppr pred ===================================== compiler/GHC/Parser.y ===================================== @@ -3820,7 +3820,7 @@ name_boolformula_opt :: { LBooleanFormula GhcPs } name_boolformula :: { LBooleanFormula GhcPs } : name_boolformula_and { $1 } | name_boolformula_and '|' name_boolformula - {% do { h <- addTrailingVbarBF $1 (epTok $2) + {% do { h <- addTrailingVbarA $1 (epTok $2) ; return (sLLa $1 $> (Or noExtField [h,$3])) } } name_boolformula_and :: { LBooleanFormula GhcPs } @@ -3830,12 +3830,11 @@ name_boolformula_and :: { LBooleanFormula GhcPs } name_boolformula_and_list :: { NonEmpty (LBooleanFormula GhcPs) } : name_boolformula_atom { NE.singleton $1 } | name_boolformula_atom ',' name_boolformula_and_list - {% do { h <- addTrailingCommaBF $1 (epTok $2) + {% do { h <- addTrailingCommaA $1 (epTok $2) ; return (h NE.<| $3) } } name_boolformula_atom :: { LBooleanFormula GhcPs } - : '(' name_boolformula ')' {% amsr (sLL $1 $> (Parens noExtField $2)) - (AnnBooleanFormula (epTok $1) (epTok $3) []) } + : '(' name_boolformula ')' {% amsA' (sLL $1 $> (Parens (epTok $1, epTok $3) $2)) } | name_var { sL1a $1 (Var noExtField $1) } namelist :: { Located [LocatedN RdrName] } @@ -4794,20 +4793,6 @@ addTrailingAnnA (L anns a) tok ta = do -- ------------------------------------- -addTrailingVbarBF :: MonadP m => LocatedBF a -> EpToken "|" -> m (LocatedBF a) -addTrailingVbarBF la tok = addTrailingAnnBF la (AddVbarAnn tok) - -addTrailingCommaBF :: MonadP m => LocatedBF a -> EpToken "," -> m (LocatedBF a) -addTrailingCommaBF la tok = addTrailingAnnBF la (AddCommaAnn tok) - -addTrailingAnnBF :: MonadP m => LocatedBF a -> TrailingAnn -> m (LocatedBF a) -addTrailingAnnBF (L anns a) ta = do - !cs <- getCommentsFor (locA anns) - let anns' = addTrailingAnnToBF ta cs anns - return (L anns' a) - --- ------------------------------------- - -- Mostly use to add AnnComma, special case it to NOP if adding a zero-width annotation addTrailingCommaN :: MonadP m => LocatedN a -> SrcSpan -> m (LocatedN a) addTrailingCommaN (L anns a) span = do ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -28,23 +28,19 @@ module GHC.Parser.Annotation ( -- ** Annotations in 'GenLocated' LocatedA, LocatedN, LocatedAn, - LocatedBF, SrcSpanAnnA, SrcSpanAnnN, - SrcSpanAnnBF, -- ** Annotation data types used in 'GenLocated' AnnList(..), AnnListBrackets(..), AnnParen(..), AnnCType(..),AnnWarningTxt(..),AnnOverlap(..),AnnAnnDecl(..),AnnPragSCC(..), - AnnBooleanFormula(..), NameAnn(..), NameAdornment(..), NoEpAnns(..), -- ** Trailing annotations in lists TrailingAnn(..), ta_location, addTrailingAnnToA, addTrailingCommaToN, - addTrailingAnnToBF, noTrailingN, -- ** Utilities for converting between different 'GenLocated' when @@ -430,8 +426,6 @@ emptyComments = EpaComments [] type LocatedA = GenLocated SrcSpanAnnA type LocatedN = GenLocated SrcSpanAnnN -type LocatedBF = GenLocated SrcSpanAnnBF - -- | Annotation for items appearing in a list. They can have one or -- more trailing punctuations items, such as commas or semicolons. type SrcSpanAnnA = EpAnn [TrailingAnn] @@ -440,8 +434,6 @@ type SrcSpanAnnA = EpAnn [TrailingAnn] -- on the context, such as backticks. type SrcSpanAnnN = EpAnn NameAnn -type SrcSpanAnnBF = EpAnn AnnBooleanFormula - -- | General representation of a 'GenLocated' type carrying a -- parameterised annotation type. type LocatedAn an = GenLocated (EpAnn an) @@ -551,17 +543,6 @@ data AnnParen | AnnParensHash (EpToken "(#") (EpToken "#)") -- ^ '(#', '#)' deriving Data --- --------------------------------------------------------------------- --- | Exact print annotation for the 'BooleanFormula' data type. - -data AnnBooleanFormula - = AnnBooleanFormula { - abf_open :: (EpToken "("), -- ^ opening parenthesis. - abf_close :: (EpToken ")"), -- ^ closing parenthesis. - abf_trailing :: ![TrailingAnn] -- ^ items appearing after the - -- item, such as '|', ',' - } deriving (Data,Eq) - -- --------------------------------------------------------------------- -- Annotations for names -- --------------------------------------------------------------------- @@ -669,14 +650,6 @@ data AnnPragSCC -- --------------------------------------------------------------------- -addTrailingAnnToBF :: TrailingAnn -> EpAnnComments - -> EpAnn AnnBooleanFormula -> EpAnn AnnBooleanFormula -addTrailingAnnToBF t cs n = n { anns = addTrailing (anns n) - , comments = comments n <> cs } - where - -- See Note [list append in addTrailing*] - addTrailing n = n { abf_trailing = abf_trailing n ++ [t]} - -- | Helper function used in the parser to add a 'TrailingAnn' items -- to an existing annotation. addTrailingAnnToA :: TrailingAnn -> EpAnnComments @@ -1030,9 +1003,6 @@ instance (NoAnn ann) => NoAnn (EpAnn ann) where instance NoAnn NoEpAnns where noAnn = NoEpAnns -instance NoAnn AnnBooleanFormula where - noAnn = AnnBooleanFormula noAnn noAnn [] - instance NoAnn AnnList where noAnn = AnnList Nothing ListNone noAnn ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -353,10 +353,6 @@ instance HasTrailing (EpToken "{", EpToken "}") where trailing _ = [] setTrailing a _ = a -instance HasTrailing (AnnBooleanFormula) where - trailing bf = abf_trailing bf - setTrailing a ts = a { abf_trailing = ts } - -- --------------------------------------------------------------------- fromAnn' :: (HasEntry a) => a -> Entry @@ -2731,9 +2727,11 @@ instance ExactPrint (BF.BooleanFormula GhcPs) where exact (BF.And e ls) = do ls' <- mapM markAnnotated ls return (BF.And e ls') - exact (BF.Parens e x) = do + exact (BF.Parens (o,c) x) = do + o' <- markEpToken o x' <- markAnnotated x - return (BF.Parens e x') + c' <- markEpToken c + return (BF.Parens (o',c') x') -- --------------------------------------------------------------------- @@ -4474,17 +4472,6 @@ instance ExactPrint [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))] whe stmts' <- markAnnotated stmts return stmts' -instance ExactPrint (LocatedBF (BF.BooleanFormula GhcPs)) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn - exact (L an bf) = do - debugM $ "LocatedCB [LBooleanFormula" - let (AnnBooleanFormula op cp ta) = anns an - op' <- markEpToken op - bf' <- markAnnotated bf - cp' <- markEpToken cp - return (L (an {anns = AnnBooleanFormula op' cp' ta}) bf') - instance ExactPrint [Located HsDocStringChunk] where getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ _ = a ===================================== utils/haddock/haddock-api/src/Haddock/Types.hs ===================================== @@ -834,7 +834,7 @@ type instance Anno (HsDecl DocNameI) = SrcSpanAnnA type instance Anno (FamilyResultSig DocNameI) = EpAnn NoEpAnns type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA type instance Anno (HsSigType DocNameI) = SrcSpanAnnA -type instance Anno (BooleanFormula DocNameI) = SrcSpanAnnBF +type instance Anno (BooleanFormula DocNameI) = SrcSpanAnnA type instance Anno (OverlapMode DocNameI) = SrcSpanAnnA type instance Anno (CType DocNameI) = SrcSpanAnnA type instance Anno (Header DocNameI) = SrcSpanAnnA @@ -1041,7 +1041,7 @@ type instance XXHsContextDetails DocNameI = DataConCantHappen type instance XBFVar DocNameI = NoExtField type instance XBFAnd DocNameI = NoExtField type instance XBFOr DocNameI = NoExtField -type instance XBFParens DocNameI = NoExtField +type instance XBFParens DocNameI = (EpToken "(", EpToken ")") type instance XXBooleanFormula DocNameI = DataConCantHappen ----------------------------------------------------------------------------- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2ca87972f6dbcf9440eca80c46f19b7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2ca87972f6dbcf9440eca80c46f19b7… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][master] 3 commits: testsuite: Show baseline sample count and range in perf failures
by Marge Bot (＠marge-bot) 20 Aug '26

20 Aug '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: b9160962 by Simon Jakobi at 2026-08-20T14:57:52-04:00 testsuite: Show baseline sample count and range in perf failures A perf baseline is the mean of all samples recorded for a commit, and it prints as a single number, hiding how far the samples spread. When the spread is wide, this can indicate an unstable metric that isn't actually useful as a signal for the perf tests. For example, in #27602, T27336's peak_megabytes_allocated baseline showed as 757 when the underlying samples were 605 and 909. When the baseline is averaged from more than one sample, say so in the failure output: the one-line stat-failure reason shows the sample range, and the detail block lists the raw samples. Single-sample baselines print exactly as before. Context: #27602 Assisted-by: Claude Fable 5 - - - - - a4979877 by Simon Jakobi at 2026-08-20T14:57:52-04:00 testsuite: Fold Baseline into CommitMetric A Baseline was just a CommitMetric plus the commit it came from, built by copying fields across. Since get_commit_metric already knows that commit, record it on CommitMetric itself and drop Baseline. This also collapses both branches of find_baseline into plain returns. Assisted-by: Claude Fable 5 - - - - - 99fb8d68 by Simon Jakobi at 2026-08-20T14:57:52-04:00 ci: Clarify comment on pushing perf notes after failures Context: #27602 Assisted-by: Claude Fable 5 - - - - - 3 changed files: - .gitlab/ci.sh - testsuite/driver/perf_notes.py - testsuite/driver/testglobals.py Changes: ===================================== .gitlab/ci.sh ===================================== @@ -1120,9 +1120,10 @@ case ${1:-help} in setup) setup && cleanup_submodules ;; configure) time_it "configure" configure ;; build_hadrian) time_it "build" build_hadrian ;; - # N.B. Always push notes, even if the build fails. This is okay to do as the - # testsuite driver doesn't record notes for tests that fail due to - # correctness. + # N.B. Always push notes, even if the build fails. Metrics from runs failing + # a perf stat check are deliberately recorded too — discarding them would + # bias the baseline towards whichever sample came first. Only correctness + # failures record nothing. test_hadrian) fetch_perf_notes res=0 ===================================== testsuite/driver/perf_notes.py ===================================== @@ -83,9 +83,13 @@ PerfStat = NamedTuple('PerfStat', [('test_env', TestEnv), ('metric', MetricName), ('value', float)]) -# A baseline recovered form stored metrics. -Baseline = NamedTuple('Baseline', [('perfStat', PerfStat), - ('commit', GitHash)]) +# A test's metric recovered from a commit's git note: the raw sample values +# recorded there, and a PerfStat whose value is their mean. Serves as the +# baseline when comparing a test run against an earlier commit. +class CommitMetric(NamedTuple): + perfStat: PerfStat + commit: GitHash + samples: List[float] # The type of exceptions which are thrown when computing the current stat value # fails. @@ -460,10 +464,10 @@ def get_allowed_changes(baseline_ref: Optional[GitRef]) -> Dict[TestName, List[A else: return get_allowed_perf_changes() -# Cache of baseline values. This is a dict of dicts indexed on: -# (useCiNamespace, commit) -> (test_env, test, metric, way) -> baseline -# (bool , str ) -> (str , str , str , str) -> float -_commit_metric_cache = {} # type: ignore +# Cache of commit metrics. +_commit_metric_cache: Dict[Tuple[NoteNamespace, GitHash], + Dict[Tuple[TestEnv, TestName, MetricName, WayName], + CommitMetric]] = {} # Get the baseline of a test at a given commit. This is the expected value # *before* the commit is applied (i.e. on the parent commit). @@ -477,7 +481,7 @@ _commit_metric_cache = {} # type: ignore # instead when looking for ci results) # metric: str - test metric # way: str - test way -# returns: the Baseline or None if no metric was found within +# returns: the baseline CommitMetric or None if no metric was found within # BaselineSearchDepth commits and since the last expected change # (ignoring any expected change in the given commit). def baseline_metric(commit: GitHash, @@ -486,7 +490,7 @@ def baseline_metric(commit: GitHash, metric: MetricName, way: WayName, baseline_ref: Optional[GitRef] - ) -> Optional[Baseline]: + ) -> Optional[CommitMetric]: # For performance reasons (in order to avoid calling commit_hash), we assert # commit is already a commit hash. assert is_commit_hash(commit) @@ -502,20 +506,16 @@ def baseline_metric(commit: GitHash, # Searches through previous commits trying local then ci for each commit in. def find_baseline(namespace: NoteNamespace, test_env: TestEnv - ) -> Optional[Baseline]: + ) -> Optional[CommitMetric]: if baseline_commit is not None: - current_metric = get_commit_metric(namespace, baseline_commit, test_env, name, metric, way) - if current_metric is not None: - return Baseline(current_metric, baseline_commit) - else: - return None + return get_commit_metric(namespace, baseline_commit, test_env, name, metric, way) for depth, current_commit in list(enumerate(commit_hashes)): if current_commit == commit: continue # Check for a metric on this commit. current_metric = get_commit_metric(namespace, current_commit, test_env, name, metric, way) if current_metric is not None: - return Baseline(current_metric, current_commit) + return current_metric # Stop if there is an expected change at this commit. In that case # metrics on ancestor commits will not be a valid baseline. @@ -527,7 +527,7 @@ def baseline_metric(commit: GitHash, # Test environment to use when comparing against CI namespace ci_test_env = best_fit_ci_test_env() - baseline = find_baseline(LocalNamespace, test_env) # type: Optional[Baseline] + baseline = find_baseline(LocalNamespace, test_env) # type: Optional[CommitMetric] if baseline is None and ci_test_env is not None: baseline = find_baseline(CiNamespace, ci_test_env) @@ -545,23 +545,23 @@ def get_commit_metric_value_str_or_none(gitNoteRef, result = get_commit_metric(gitNoteRef, commit, test_env, name, metric, way) if result is None: return None - return str(result.value) + return str(result.perfStat.value) -# gets the average commit metric from git notes. +# gets the commit metric (average and raw samples) from git notes. # gitNoteRef: git notes ref space e.g. "perf" or "ci/perf" # ref: git commit # test_env: test environment # name: test name # metric: test metric # way: test way -# returns: PerfStat | None if stats don't exist for the given input +# returns: CommitMetric | None if stats don't exist for the given input def get_commit_metric(gitNoteRef, ref: Union[GitRef, GitHash], test_env: TestEnv, name: TestName, metric: MetricName, way: WayName - ) -> Optional[PerfStat]: + ) -> Optional[CommitMetric]: global _commit_metric_cache assert test_env != None commit = commit_hash(ref) @@ -573,9 +573,9 @@ def get_commit_metric(gitNoteRef, return _commit_metric_cache[cacheKeyA].get(cacheKeyB) # Cache miss. - # Calculate baselines from the current commit's git note. + # Calculate metrics from the current commit's git note. # Note that the git note may contain data for other tests. All tests' - # baselines will be collected and cached for future use. + # metrics will be collected and cached for future use. allCommitMetrics = get_perf_stats(ref, gitNoteRef) # Collect recorded values by cacheKeyB. @@ -586,22 +586,32 @@ def get_commit_metric(gitNoteRef, currentValues = values_by_cache_key_b.setdefault(currentCacheKey, []) currentValues.append(float(perfStat.value)) - # Calculate and baseline (average of values) by cacheKeyB. - baseline_by_cache_key_b = {} + # Calculate the metric (average of values, plus the values themselves) + # by cacheKeyB. + metric_by_cache_key_b = {} for currentCacheKey, currentValues in values_by_cache_key_b.items(): - baseline_by_cache_key_b[currentCacheKey] = PerfStat( \ - currentCacheKey[0], - currentCacheKey[1], - currentCacheKey[3], - currentCacheKey[2], - sum(currentValues) / len(currentValues)) - - # Save baselines to the cache. - _commit_metric_cache[cacheKeyA] = baseline_by_cache_key_b - return baseline_by_cache_key_b.get(cacheKeyB) + metric_by_cache_key_b[currentCacheKey] = CommitMetric( + PerfStat( + currentCacheKey[0], + currentCacheKey[1], + currentCacheKey[3], + currentCacheKey[2], + sum(currentValues) / len(currentValues)), + commit, + currentValues) + + # Save metrics to the cache. + _commit_metric_cache[cacheKeyA] = metric_by_cache_key_b + return metric_by_cache_key_b.get(cacheKeyB) + +def format_sample(s: float) -> str: + return str(int(s)) if s == int(s) else str(s) + +def format_samples(samples: List[float]) -> str: + return ', '.join(format_sample(s) for s in samples) def check_stats_change(actual: PerfStat, - baseline: Baseline, + baseline: CommitMetric, acceptance_window: MetricAcceptanceWindow, allowed_perf_changes: Dict[TestName, List[AllowedPerfChange]] = {}, force_print = False @@ -611,8 +621,8 @@ def check_stats_change(actual: PerfStat, Parameters: actual: the PerfStat with actual value - baseline: the expected Baseline value (this should generally be derived - from baseline_metric()) + baseline: the CommitMetric to compare against (this should generally be + derived from baseline_metric()) acceptance_window: allowed deviation of the actual value from the expected value. allowed_perf_changes: allowed changes in stats. This is a dictionary as @@ -654,9 +664,17 @@ def check_stats_change(actual: PerfStat, ' baseline @ %s' % baseline.commit print(actual.metric, error + ':') dev = 100.0 if expected_val == 0 else round(((float(actual.value) * 100) / int(expected_val)) - 100, 1) + # Show the sample spread so unreliable baselines become visible (#27602). + if len(baseline.samples) > 1: + samples_note = ('; baseline is mean of %d samples spanning %s..%s' + % (len(baseline.samples), + format_sample(min(baseline.samples)), + format_sample(max(baseline.samples)))) + else: + samples_note = '' change_line = (f'{actual.metric} {change.value} from {baseline.perfStat.test_env} ' f'baseline @ {baseline.commit[:7]}: {expected_val} -> {actual.value} ' - f'({dev:+g}%, allowed {acceptance_window.describe()})') + f'({dev:+g}%, allowed {acceptance_window.describe()}{samples_note})') result = failBecause('stat ' + change_line, tag='stat') if not change_allowed or force_print: @@ -666,6 +684,10 @@ def check_stats_change(actual: PerfStat, print(descr, str(val).rjust(length), extra) display(' Expected ' + full_name + ' ' + actual.metric + ':', expected_val, acceptance_window.describe()) + if len(baseline.samples) > 1: + display(' Samples ' + full_name + ' ' + actual.metric + ':', + len(baseline.samples), + '(' + format_samples(baseline.samples) + ')') display(' Lower bound ' + full_name + ' ' + actual.metric + ':', lowerBound, '') display(' Upper bound ' + full_name + ' ' + actual.metric + ':', upperBound, '') display(' Actual ' + full_name + ' ' + actual.metric + ':', actual.value, '') @@ -866,7 +888,7 @@ def main() -> None: # HEAD~2 21234 21234 # HEAD~3 20000 20000 def strMetric(x): - return '{:.2f}'.format(x.value) if x != None else "" + return '{:.2f}'.format(x.perfStat.value) if x != None else "" # Data is in column major format, so transpose and pass to print_table. T = TypeVar('T') def transpose(xss: List[List[T]]) -> List[List[T]]: ===================================== testsuite/driver/testglobals.py ===================================== @@ -4,7 +4,7 @@ from my_typing import * from pathlib import Path -from perf_notes import MetricChange, PerfStat, Baseline, GitRef +from perf_notes import MetricChange, PerfStat, CommitMetric, GitRef from datetime import datetime # ----------------------------------------------------------------------------- @@ -312,7 +312,7 @@ class TestResult: PerfMetric = NamedTuple('PerfMetric', [('change', MetricChange), ('stat', PerfStat), - ('baseline', Optional[Baseline]) ]) + ('baseline', Optional[CommitMetric]) ]) class TestRun: def __init__(self) -> None: View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/eb0dfb011b43451e88181fb6b98071… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/eb0dfb011b43451e88181fb6b98071… 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/27627] 3 commits: Specialise: don't drop a dead arg that the stable unfolding uses
by Zubin (＠wz1000) 20 Aug '26

20 Aug '26

Zubin pushed to branch wip/27627 at Glasgow Haskell Compiler / GHC Commits: 5d1e5e02 by Zubin Duggal at 2026-08-20T20:14:48+05:30 Specialise: don't drop a dead arg that the stable unfolding uses specHeader decides an argument is dead by calling isDeadBinder on a binder of the /optimised RHS/, then applies the filler to the /stable unfolding/ template instead. The two may differ, so the argument can be dead in the RHS and not in the template. The specialised function's unfolding then has an absent filler, and any call site that inlines it evaluates the error thunk. Thread the template's binders through specHeader alongside the RHS binders and make a filler only when the argument is dead in both. See Note [Dead args and stable unfoldings]. Fixes #27703 - - - - - efd3a5cf by Zubin Duggal at 2026-08-20T20:14:48+05:30 Never make an absent filler at a constraint type, isDictTy doesn't catch constraints hidden behind unreduced type family applications Example: type family F a :: Constraint type instance F W = TC W a :: F W => Int -> Int -- (F W) argument is absent Oops! Entered absent arg Arg: irred Type: F W also in the test T27627f Use `ConstraintLike <- typeTypeOrConstraint arg_ty` instead??? - - - - - a307ee3b by Zubin Duggal at 2026-08-20T20:14:48+05:30 CorePrep: don't speculate a call across an hs-boot edge We take care not to evaluate things that might be bottom, like a looping dictionary group, but our analysis is defeated by boot files. We only track recursion within a module, so two dictionaries that depend on each other across a module loop each look non-recursive, and we might speculate them. Any recursion we cannot see must cross an hs-boot edge, so refuse to speculate calls that cross one. Fixes #27717 - - - - - 20 changed files: - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/CoreToStg/Prep.hs - + testsuite/tests/core-to-stg/T27627f/Callee.hs - + testsuite/tests/core-to-stg/T27627f/Caller.hs - + testsuite/tests/core-to-stg/T27627f/Inst.hs - + testsuite/tests/core-to-stg/T27627f/Main.hs - + testsuite/tests/core-to-stg/T27627f/T27627f.stdout - + testsuite/tests/core-to-stg/T27627f/all.T - + testsuite/tests/core-to-stg/T27717/Callee.hs - + testsuite/tests/core-to-stg/T27717/Callee.hs-boot - + testsuite/tests/core-to-stg/T27717/Main.hs - + testsuite/tests/core-to-stg/T27717/Mid.hs - + testsuite/tests/core-to-stg/T27717/T27717.stdout - + testsuite/tests/core-to-stg/T27717/Ty.hs - + testsuite/tests/core-to-stg/T27717/all.T - + testsuite/tests/simplCore/should_run/T27703/Lib.hs - + testsuite/tests/simplCore/should_run/T27703/Main.hs - + testsuite/tests/simplCore/should_run/T27703/T27703.stdout - + testsuite/tests/simplCore/should_run/T27703/all.T Changes: ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -1647,6 +1647,14 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs (rhs_bndrs, rhs_body) = collectBindersPushingCo rhs -- See Note [Account for casts in binding] + -- Binders of the stable unfolding template, if there is one. + -- See Note [Dead args and stable unfoldings] + unf_bndrs | isStableUnfolding fn_unf + , Just tmpl <- maybeUnfoldingTemplate fn_unf + = Just (fst (collectBinders tmpl)) + | otherwise + = Nothing + -- Copy InlinePragma information from the parent Id. -- So if f has INLINE[1] so does spec_fn spec_inl_prag @@ -1670,7 +1678,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs | otherwise = UnspecArg ; (useful, subst', rule_bndrs, rule_lhs_args, spec_bndrs, dx_binds, spec_args) - <- specHeader this_mod subst rhs_bndrs all_call_args + <- specHeader this_mod subst rhs_bndrs unf_bndrs all_call_args ; let env' = env { se_subst = subst' } -- Check for (a) usefulness and (b) not already covered @@ -2049,10 +2057,26 @@ Wrinkles * If the function has a stable unfolding, specHeader has to come up with arguments to pass to that stable unfolding, when building the stable unfolding of the specialised function: this is the last field in specHeader's - big result tuple. + big result tuple. We pass an absent filler, but only once we have checked + that the unfolding does not use the argument either. + See Note [Dead args and stable unfoldings] + +Note [Dead args and stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +specHeader decides an argument is dead with isDeadBinder on a binder of the +optimised RHS, then applies the filler to the stable unfolding template instead. +The two may differ, so the argument can be dead in the RHS and not in the +template. See #27703 for an instance of this. The specialised function's +unfolding then contains the filler, and any call site that inlines it evaluates +the error thunk. - The right thing to do is to produce a LitRubbish; it should rapidly - disappear. Rather like GHC.Core.Opt.WorkWrap.Utils.mk_absent_let. +It is not enough to ask whether the RHS binder occurs free in the template: the +template has its own binders, so it never does. We must walk the arguments in +lockstep. If the template runs out of binders, the RHS was eta-expanded past +it, and we assume the argument is used. + +DmdAnal does the same job in addUnfoldingDemands. See Wrinkle (W3) of +Note [Absence analysis for stable unfoldings and RULES]. Note [Specialisation modulo dictionary selectors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2577,6 +2601,9 @@ specHeader :: Module -- The module being compiled, for mkAbsentFiller -> Core.Subst -- This substitution applies to the [InBndr] -> [InBndr] -- Binders from the original function `f` + -> Maybe [InBndr] + -- Binders of f's stable unfolding template, if it has one + -- See Note [Dead args and stable unfoldings] -> [SpecArg] -- From the CallInfo -> SpecM ( Bool -- True <=> some useful specialisation happened -- Not the same as any (isSpecDict args) because @@ -2600,13 +2627,13 @@ specHeader -- If we run out of binders, stop immediately -- See Note [Specialisation Must Preserve Sharing] -specHeader _ subst [] _ = pure (False, subst, [], [], [], [], []) -specHeader _ subst _ [] = pure (False, subst, [], [], [], [], []) +specHeader _ subst [] _ _ = pure (False, subst, [], [], [], [], []) +specHeader _ subst _ _ [] = pure (False, subst, [], [], [], [], []) -- We want to specialise on type 'T1', and so we must construct a substitution -- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding -- details. -specHeader mod subst (bndr:bndrs) (SpecType ty : args) +specHeader mod subst (bndr:bndrs) unf_bndrs (SpecType ty : args) = do { -- Find free_tvs, the type variables to add to the binders for the rule -- Namely those deeply free in `ty` that aren't in scope -- See (MP2) in Note [Specialising polymorphic dictionaries] @@ -2619,7 +2646,7 @@ specHeader mod subst (bndr:bndrs) (SpecType ty : args) ; let subst2 = Core.extendTvSubst subst1 bndr ty ; (useful, subst3, rule_bs, rule_args, spec_bs, dx, spec_args) - <- specHeader mod subst2 bndrs args + <- specHeader mod subst2 bndrs (fmap (drop 1) unf_bndrs) args ; pure ( useful, subst3 , free_tvs ++ rule_bs, Type ty : rule_args , free_tvs ++ spec_bs, dx, Type ty : spec_args ) } @@ -2628,17 +2655,19 @@ specHeader mod subst (bndr:bndrs) (SpecType ty : args) -- a substitution on it (in case the type refers to 'a'). Additionally, we need -- to produce a binder, LHS argument and RHS argument for the resulting rule, -- /and/ a binder for the specialised body. -specHeader mod subst (bndr:bndrs) (UnspecType : args) +specHeader mod subst (bndr:bndrs) unf_bndrs (UnspecType : args) = do { let (subst1, bndr') = Core.substBndr subst bndr ; (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) - <- specHeader mod subst1 bndrs args + <- specHeader mod subst1 bndrs (fmap (drop 1) unf_bndrs) args ; let ty_e' = Type (mkTyVarTy bndr') ; pure ( useful, subst2 , bndr' : rule_bs, ty_e' : rule_es , bndr' : spec_bs, dx, ty_e' : spec_args ) } -specHeader mod subst (bndr:bndrs) (_ : args) +specHeader mod subst (bndr:bndrs) unf_bndrs (_ : args) | isDeadBinder bndr + , dead_in_unfolding unf_bndrs + -- See Note [Dead args and stable unfoldings] , let (subst1, bndr') = Core.substBndr subst (zapIdOccInfo bndr) , Just filler <- mkAbsentFiller mod bndr' NotMarkedStrict -- NB: mkAbsentFiller returns Nothing for a terminating type (e.g. a @@ -2647,7 +2676,8 @@ specHeader mod subst (bndr:bndrs) (_ : args) -- See Note [Don't make fillers for dictionary types] -- in GHC.Core.Opt.WorkWrap.Utils = -- See Note [Drop dead args from specialisations] - do { (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader mod subst1 bndrs args + do { (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) + <- specHeader mod subst1 bndrs (fmap (drop 1) unf_bndrs) args ; pure ( useful, subst2 , bndr' : rule_bs, Var bndr' : rule_es , spec_bs, dx, filler : spec_args ) } @@ -2655,7 +2685,7 @@ specHeader mod subst (bndr:bndrs) (_ : args) -- Next we want to specialise the 'Eq a' dict away. We need to construct -- a wildcard binder to match the dictionary (See Note [Specialising Calls] for -- the nitty-gritty), as a LHS rule and unfolding details. -specHeader mod subst (bndr:bndrs) (SpecDict dict_arg : args) +specHeader mod subst (bndr:bndrs) unf_bndrs (SpecDict dict_arg : args) = do { -- Make up a fresh binder to use in the RULE -- It might turn into a dict binding (via bindAuxiliaryDict) which we -- then float, so we use cloneIdBndr to get a completely fresh binder @@ -2666,7 +2696,8 @@ specHeader mod subst (bndr:bndrs) (SpecDict dict_arg : args) -- Extend the substitution to map bndr :-> dict_arg, for use in the RHS ; let (subst2, dx_bind, spec_dict) = bindAuxiliaryDict subst1 bndr bndr' dict_arg - ; (_, subst3, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader mod subst2 bndrs args + ; (_, subst3, rule_bs, rule_es, spec_bs, dx, spec_args) + <- specHeader mod subst2 bndrs (fmap (drop 1) unf_bndrs) args ; let dx' = case dx_bind of { Nothing -> dx; Just d -> d : dx } ; pure ( True, subst3 -- Ha! A useful specialisation! @@ -2681,10 +2712,11 @@ specHeader mod subst (bndr:bndrs) (SpecDict dict_arg : args) -- why 'i' doesn't appear in our RULE above. But we have no guarantee that -- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so -- this case must be here. -specHeader mod subst (bndr:bndrs) (UnspecArg : args) +specHeader mod subst (bndr:bndrs) unf_bndrs (UnspecArg : args) = do { let (subst1, bndr') = Core.substBndr subst (zapIdOccInfo bndr) -- zapIdOccInfo: see Note [Zap occ info in rule binders] - ; (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader mod subst1 bndrs args + ; (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) + <- specHeader mod subst1 bndrs (fmap (drop 1) unf_bndrs) args ; let dummy_arg = varToCoreExpr bndr' -- dummy_arg is usually just (Var bndr), @@ -2698,6 +2730,14 @@ specHeader mod subst (bndr:bndrs) (UnspecArg : args) , bndrs ++ spec_bs, dx, dummy_arg : spec_args ) } +dead_in_unfolding :: Maybe [InBndr] -> Bool +-- ^ Is the argument at this position dead in the stable unfolding template? +-- Nothing means there is no stable unfolding, so no filler can escape into one. +-- If the template runs out of binders we cannot tell, so we say No. +dead_in_unfolding Nothing = True +dead_in_unfolding (Just (unf_bndr : _)) = isDeadBinder unf_bndr +dead_in_unfolding (Just []) = False + -- | Binds a dictionary argument to a fresh name, to preserve sharing bindAuxiliaryDict :: Subst ===================================== compiler/GHC/Core/Opt/WorkWrap/Utils.hs ===================================== @@ -32,7 +32,7 @@ import GHC.Core.Multiplicity import GHC.Core.Coercion import GHC.Core.Reduction import GHC.Core.FamInstEnv -import GHC.Core.Predicate( isEqualityClass, isDictTy ) +import GHC.Core.Predicate( isEqualityClass ) import GHC.Core.TyCon import GHC.Core.TyCon.Set import GHC.Core.TyCon.RecWalk @@ -1072,7 +1072,7 @@ mkAbsentFiller mod arg str -- evaluated or have a field projected out of it. -- See (AF4) in Note [Absent fillers], and -- Note [Don't make fillers for dictionary types]. - | isDictTy arg_ty + | ConstraintLike <- typeTypeOrConstraint arg_ty = Nothing -- The lifted case: bind 'absentError'. See (AF1) in Note [Absent fillers] ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -1977,6 +1977,26 @@ prep up `rhs1`, we have to include not only `f1`, but all binders of the group `f1..fn` in this set, otherwise our fix is not robust wrt. mutual recursive DFuns. +cpe_rec_ids is module-local, so it does not catch a recursion that goes through +an hs-boot import. Suppose Mid and Callee form a module loop, and Mid sees +Callee through its hs-boot file: + + -- Mid.hs + $fCAT = \ @a $dCB -> C:CA ($fxCBT $dCB) ... + -- Callee.hs + $fCBT = \ @a $dCB -> C:CB ($fCAT $dCB) ... + +Neither module can see that these two call each other, so each looks +non-recursive, and we speculate the inner call in both: + + $fCAT = \ @a $dCB -> case $fxCBT $dCB of s { __DEFAULT -> C:CA s ... } + $fCBT = \ @a $dCB -> case $fCAT $dCB of s { __DEFAULT -> C:CB s ... } + +Now each forces the other and the program loops. Such a cycle must cross an +hs-boot edge, so we do not speculate a call whose callee has a BootUnfolding. +Note [Inlining and hs-boot files] in GHC.CoreToIface does the same for +infinite inlining. + NB: If at some point we decide to have a termination analysis for general functions (#8655, !1866), we need to take similar precautions for (guarded) recursive functions: @@ -2323,10 +2343,13 @@ mkNonRecFloat env lev bndr rhs -- See Note [Controlling Speculative Evaluation] call_ok_for_spec x | is_rec_call x = False + | is_boot_call x = False | not (cp_specEval cfg) = False | not (cp_specEvalDFun cfg) && isDFunId x = False | otherwise = True - is_rec_call = (`elemUnVarSet` cpe_rec_ids env) + is_rec_call = (`elemUnVarSet` cpe_rec_ids env) + is_boot_call = isBootUnfolding . realIdUnfolding + -- See Note [Speculative evaluation], Very Nasty Wrinkle -- See Note [Pin evaluatedness on floats] bndr' | is_hnf = bndr `setIdUnfolding` evaldUnfolding ===================================== testsuite/tests/core-to-stg/T27627f/Callee.hs ===================================== @@ -0,0 +1,24 @@ +{-# LANGUAGE GADTs, ConstraintKinds, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-worker-wrapper #-} +module Callee where + +-- Not unary: a superclass field and a method field, so (Eq a) can be +-- speculatively selected out of a (TC a) dictionary. +class Eq a => TC a where + tcDummy :: a -> Int + +data W = W +instance Eq W where _ == _ = True + +data Dict c where + Dict :: c => Dict c + +{-# NOINLINE discard #-} +discard :: Dict c -> Int +discard _ = 42 + +-- Never forces its dictionary, so demand analysis marks it absent, and +-- Caller's `a` inherits that absence. +{-# NOINLINE b #-} +b :: forall a. TC a => a -> Int +b _ = discard (Dict :: Dict (Eq a)) ===================================== testsuite/tests/core-to-stg/T27627f/Caller.hs ===================================== @@ -0,0 +1,19 @@ +{-# LANGUAGE TypeFamilies, ConstraintKinds, FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +module Caller where + +import Callee +import Data.Kind (Constraint) + +-- A Constraint-kinded type family. It reduces to (TC W), so the dictionary +-- `a` receives really is a (TC W) dictionary; but (F W) is not class-headed, +-- so isDictTy says False. Worker/wrapper must still not replace it with a +-- filler: Callee speculates a superclass selection out of it. +type family F a :: Constraint +type instance F W = TC W + +-- Note there is no `instance TC W` in scope here: `b W` must take its +-- dictionary from this Given, rather than from an instance. +{-# NOINLINE a #-} +a :: F W => Int -> Int +a x = b W + x ===================================== testsuite/tests/core-to-stg/T27627f/Inst.hs ===================================== @@ -0,0 +1,6 @@ +module Inst where + +import Callee + +-- Deliberately not in Callee or Caller: see the comment in Caller.hs +instance TC W where tcDummy _ = 7 ===================================== testsuite/tests/core-to-stg/T27627f/Main.hs ===================================== @@ -0,0 +1,7 @@ +module Main where + +import Caller +import Inst () + +main :: IO () +main = print (a 1) ===================================== testsuite/tests/core-to-stg/T27627f/T27627f.stdout ===================================== @@ -0,0 +1 @@ +43 ===================================== testsuite/tests/core-to-stg/T27627f/all.T ===================================== @@ -0,0 +1,4 @@ +test('T27627f', + [extra_files(['Main.hs', 'Inst.hs', 'Caller.hs', 'Callee.hs'])], + multimod_compile_and_run, + ['Main', '-O']) ===================================== testsuite/tests/core-to-stg/T27717/Callee.hs ===================================== @@ -0,0 +1,11 @@ +{-# LANGUAGE UndecidableInstances, FlexibleInstances, FlexibleContexts #-} +module Callee where + +import Ty +import Mid + +instance CB a => CB (T a) where + opB _ = 2 + +instance CB Int where + opB _ = 8 ===================================== testsuite/tests/core-to-stg/T27717/Callee.hs-boot ===================================== @@ -0,0 +1,7 @@ +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} +module Callee where + +import Ty + +instance CB a => CB (T a) +instance CB Int ===================================== testsuite/tests/core-to-stg/T27717/Main.hs ===================================== @@ -0,0 +1,6 @@ +module Main where +import Mid +import Callee () + +main :: IO () +main = print (g (1 :: Int)) ===================================== testsuite/tests/core-to-stg/T27717/Mid.hs ===================================== @@ -0,0 +1,26 @@ +{-# LANGUAGE UndecidableInstances, FlexibleInstances, FlexibleContexts #-} +{-# LANGUAGE GADTs, ConstraintKinds, ScopedTypeVariables #-} +module Mid where + +import Ty +import {-# SOURCE #-} Callee + +-- $fCATa calls Callee's $fxCBT, and that calls this one back. The cycle runs +-- through the hs-boot import, so both dfuns are NonRec in their own module and +-- cpe_rec_ids cannot see it. Speculating either one loops. +instance CB a => CA (T a) where + opA _ = 1 + +instance CA Int where + opA _ = 9 + +data Dict c where + Dict :: c => Dict c + +{-# NOINLINE keep #-} +keep :: [Dict c] -> Int +keep xs = length xs + 41 + +{-# NOINLINE g #-} +g :: forall a. CB a => a -> Int +g _ = keep [Dict :: Dict (CA (T a))] ===================================== testsuite/tests/core-to-stg/T27717/T27717.stdout ===================================== @@ -0,0 +1 @@ +42 ===================================== testsuite/tests/core-to-stg/T27717/Ty.hs ===================================== @@ -0,0 +1,10 @@ +{-# LANGUAGE UndecidableSuperClasses #-} +module Ty where + +data T a = MkT a + +class CB a => CA a where + opA :: a -> Int + +class CA a => CB a where + opB :: a -> Int ===================================== testsuite/tests/core-to-stg/T27717/all.T ===================================== @@ -0,0 +1,4 @@ +test('T27717', + [extra_files(['Main.hs', 'Mid.hs', 'Ty.hs', 'Callee.hs', 'Callee.hs-boot'])], + multimod_compile_and_run, + ['Main', '-O -fspec-eval-dictfun']) ===================================== testsuite/tests/simplCore/should_run/T27703/Lib.hs ===================================== @@ -0,0 +1,18 @@ +{-# LANGUAGE RankNTypes #-} +module Lib (g) where + +{-# NOINLINE consume #-} +consume :: Int -> Int +consume n = n `seq` 0 + +{-# RULES "consume/drop" [~1] forall n. consume n = 0 #-} + +-- A dead value argument (n) that comes *before* the dictionary we +-- specialise on. No implicit parameters involved. +{-# INLINE [1] f #-} +f :: forall a. Int -> Show a => a -> String +f n y = show y ++ replicate (consume n) '!' + +{-# NOINLINE g #-} +g :: Bool -> String +g b = f 7 b ++ "." ===================================== testsuite/tests/simplCore/should_run/T27703/Main.hs ===================================== @@ -0,0 +1,5 @@ +module Main where +import Lib + +main :: IO () +main = putStrLn (g True) ===================================== testsuite/tests/simplCore/should_run/T27703/T27703.stdout ===================================== @@ -0,0 +1 @@ +True. ===================================== testsuite/tests/simplCore/should_run/T27703/all.T ===================================== @@ -0,0 +1,4 @@ +test('T27703', + [extra_files(['Main.hs', 'Lib.hs'])], + multimod_compile_and_run, + ['Main', '-O']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e3618220bed95ae0b965f1be3b7e22… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e3618220bed95ae0b965f1be3b7e22… 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] 4 commits: testsuite: Show baseline sample count and range in perf failures
by Marge Bot (＠marge-bot) 20 Aug '26

20 Aug '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 1ffe999f by Simon Jakobi at 2026-08-20T08:07:25-04:00 testsuite: Show baseline sample count and range in perf failures A perf baseline is the mean of all samples recorded for a commit, and it prints as a single number, hiding how far the samples spread. When the spread is wide, this can indicate an unstable metric that isn't actually useful as a signal for the perf tests. For example, in #27602, T27336's peak_megabytes_allocated baseline showed as 757 when the underlying samples were 605 and 909. When the baseline is averaged from more than one sample, say so in the failure output: the one-line stat-failure reason shows the sample range, and the detail block lists the raw samples. Single-sample baselines print exactly as before. Context: #27602 Assisted-by: Claude Fable 5 - - - - - 3827f24e by Simon Jakobi at 2026-08-20T08:07:25-04:00 testsuite: Fold Baseline into CommitMetric A Baseline was just a CommitMetric plus the commit it came from, built by copying fields across. Since get_commit_metric already knows that commit, record it on CommitMetric itself and drop Baseline. This also collapses both branches of find_baseline into plain returns. Assisted-by: Claude Fable 5 - - - - - ed4d3273 by Simon Jakobi at 2026-08-20T08:07:26-04:00 ci: Clarify comment on pushing perf notes after failures Context: #27602 Assisted-by: Claude Fable 5 - - - - - 8bb8a88e by Alan Zimmerman at 2026-08-20T08:07:26-04:00 EPA: Remove LocatedBC / SrcSpanBF The custom annotations are now in the BooleanFormula TTG extension points, so LBooleanFormula can now use the standard LocatedA. - - - - - 12 changed files: - .gitlab/ci.sh - compiler/GHC/Data/BooleanFormula.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - testsuite/driver/perf_notes.py - testsuite/driver/testglobals.py - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Types.hs Changes: ===================================== .gitlab/ci.sh ===================================== @@ -1120,9 +1120,10 @@ case ${1:-help} in setup) setup && cleanup_submodules ;; configure) time_it "configure" configure ;; build_hadrian) time_it "build" build_hadrian ;; - # N.B. Always push notes, even if the build fails. This is okay to do as the - # testsuite driver doesn't record notes for tests that fail due to - # correctness. + # N.B. Always push notes, even if the build fails. Metrics from runs failing + # a perf stat check are deliberately recorded too — discarding them would + # bias the baseline towards whichever sample came first. Only correctness + # failures record nothing. test_hadrian) fetch_perf_notes res=0 ===================================== compiler/GHC/Data/BooleanFormula.hs ===================================== @@ -25,7 +25,7 @@ import GHC.Types.Unique import GHC.Types.Unique.Set import GHC.Types.SrcLoc (unLoc) import GHC.Utils.Outputable -import GHC.Parser.Annotation ( SrcSpanAnnBF ) +import GHC.Parser.Annotation ( SrcSpanAnnA, EpToken(..) ) import GHC.Hs.Extension (GhcPass (..), OutputableBndrId) import Language.Haskell.Syntax.Extension (Anno, LIdP, IdP, noExtField, NoExtField, DataConCantHappen, @@ -38,12 +38,12 @@ import Language.Haskell.Syntax.BooleanFormula -- Boolean formula type and smart constructors ---------------------------------------------------------------------- -type instance Anno (BooleanFormula (GhcPass p)) = SrcSpanAnnBF +type instance Anno (BooleanFormula (GhcPass p)) = SrcSpanAnnA type instance XBFVar (GhcPass _) = NoExtField type instance XBFAnd (GhcPass _) = NoExtField type instance XBFOr (GhcPass _) = NoExtField -type instance XBFParens (GhcPass _) = NoExtField +type instance XBFParens (GhcPass _) = (EpToken "(", EpToken ")") type instance XXBooleanFormula (GhcPass _) = DataConCantHappen instance BooleanFormulaDefault (GhcPass p) where ===================================== compiler/GHC/Hs/Dump.hs ===================================== @@ -97,7 +97,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 `ext2Q` located `extQ` srcSpanAnnA `extQ` srcSpanAnnN - `extQ` srcSpanAnnBF where generic :: Data a => a -> SDoc generic t = parens $ text (showConstr (toConstr t)) @@ -396,10 +395,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 srcSpanAnnN :: EpAnn NameAnn -> SDoc srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN") - srcSpanAnnBF :: EpAnn AnnBooleanFormula -> SDoc - srcSpanAnnBF = locatedAnn'' (text "SrcSpanAnnBF") - - locatedAnn'' :: forall a. (Typeable a, Data a) => SDoc -> EpAnn a -> SDoc locatedAnn'' tag ss = parens $ ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -2081,7 +2081,7 @@ instance ToHie PendingRnSplice where toHie (PendingRnSplice _ e) = toHie e instance (HiePass p, Data (IdGhcP p)) - => ToHie (GenLocated SrcSpanAnnBF (BooleanFormula (GhcPass p))) where + => ToHie (GenLocated SrcSpanAnnA (BooleanFormula (GhcPass p))) where toHie (L span form) = concatM $ makeNode form (locA span) : case form of Var _ a -> [ toHie $ C Use a ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -1330,7 +1330,7 @@ pprIfaceDecl ss decl@(IfaceClass { ifName = clas fromIfaceBooleanFormula (IfVar nm ) = Var noExtField $ noLocA . mkUnboundName . mkVarOccFS . ifLclNameFS $ nm fromIfaceBooleanFormula (IfAnd bfs ) = And noExtField $ map (noLocA . fromIfaceBooleanFormula) bfs fromIfaceBooleanFormula (IfOr bfs ) = Or noExtField $ map (noLocA . fromIfaceBooleanFormula) bfs - fromIfaceBooleanFormula (IfParens bf) = Parens noExtField $ (noLocA . fromIfaceBooleanFormula) bf + fromIfaceBooleanFormula (IfParens bf) = Parens noAnn $ (noLocA . fromIfaceBooleanFormula) bf -- See Note [Suppressing binder signatures] in GHC.Iface.Type ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -121,7 +121,7 @@ import GHC.Types.Tickish import GHC.Types.TyThing import GHC.Types.Error -import GHC.Parser.Annotation (noLocA) +import GHC.Parser.Annotation (noLocA, noAnn) import GHC.Fingerprint @@ -885,7 +885,7 @@ tc_iface_decl _parent ignore_prags tc_boolean_formula :: IfaceBooleanFormula -> IfL (BooleanFormula GhcRn) tc_boolean_formula (IfAnd ibfs ) = BF.And NoExtField . map noLocA <$> traverse tc_boolean_formula ibfs tc_boolean_formula (IfOr ibfs ) = BF.Or NoExtField . map noLocA <$> traverse tc_boolean_formula ibfs - tc_boolean_formula (IfParens ibf) = BF.Parens NoExtField . noLocA <$> tc_boolean_formula ibf + tc_boolean_formula (IfParens ibf) = BF.Parens noAnn . noLocA <$> tc_boolean_formula ibf tc_boolean_formula (IfVar nm ) = BF.Var NoExtField . noLocA <$> (lookupIfaceTop . mkVarOccFS . ifLclNameFS $ nm) mk_sc_doc pred = text "Superclass" <+> ppr pred ===================================== compiler/GHC/Parser.y ===================================== @@ -3820,7 +3820,7 @@ name_boolformula_opt :: { LBooleanFormula GhcPs } name_boolformula :: { LBooleanFormula GhcPs } : name_boolformula_and { $1 } | name_boolformula_and '|' name_boolformula - {% do { h <- addTrailingVbarBF $1 (epTok $2) + {% do { h <- addTrailingVbarA $1 (epTok $2) ; return (sLLa $1 $> (Or noExtField [h,$3])) } } name_boolformula_and :: { LBooleanFormula GhcPs } @@ -3830,12 +3830,11 @@ name_boolformula_and :: { LBooleanFormula GhcPs } name_boolformula_and_list :: { NonEmpty (LBooleanFormula GhcPs) } : name_boolformula_atom { NE.singleton $1 } | name_boolformula_atom ',' name_boolformula_and_list - {% do { h <- addTrailingCommaBF $1 (epTok $2) + {% do { h <- addTrailingCommaA $1 (epTok $2) ; return (h NE.<| $3) } } name_boolformula_atom :: { LBooleanFormula GhcPs } - : '(' name_boolformula ')' {% amsr (sLL $1 $> (Parens noExtField $2)) - (AnnBooleanFormula (epTok $1) (epTok $3) []) } + : '(' name_boolformula ')' {% amsA' (sLL $1 $> (Parens (epTok $1, epTok $3) $2)) } | name_var { sL1a $1 (Var noExtField $1) } namelist :: { Located [LocatedN RdrName] } @@ -4794,20 +4793,6 @@ addTrailingAnnA (L anns a) tok ta = do -- ------------------------------------- -addTrailingVbarBF :: MonadP m => LocatedBF a -> EpToken "|" -> m (LocatedBF a) -addTrailingVbarBF la tok = addTrailingAnnBF la (AddVbarAnn tok) - -addTrailingCommaBF :: MonadP m => LocatedBF a -> EpToken "," -> m (LocatedBF a) -addTrailingCommaBF la tok = addTrailingAnnBF la (AddCommaAnn tok) - -addTrailingAnnBF :: MonadP m => LocatedBF a -> TrailingAnn -> m (LocatedBF a) -addTrailingAnnBF (L anns a) ta = do - !cs <- getCommentsFor (locA anns) - let anns' = addTrailingAnnToBF ta cs anns - return (L anns' a) - --- ------------------------------------- - -- Mostly use to add AnnComma, special case it to NOP if adding a zero-width annotation addTrailingCommaN :: MonadP m => LocatedN a -> SrcSpan -> m (LocatedN a) addTrailingCommaN (L anns a) span = do ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -28,23 +28,19 @@ module GHC.Parser.Annotation ( -- ** Annotations in 'GenLocated' LocatedA, LocatedN, LocatedAn, - LocatedBF, SrcSpanAnnA, SrcSpanAnnN, - SrcSpanAnnBF, -- ** Annotation data types used in 'GenLocated' AnnList(..), AnnListBrackets(..), AnnParen(..), AnnCType(..),AnnWarningTxt(..),AnnOverlap(..),AnnAnnDecl(..),AnnPragSCC(..), - AnnBooleanFormula(..), NameAnn(..), NameAdornment(..), NoEpAnns(..), -- ** Trailing annotations in lists TrailingAnn(..), ta_location, addTrailingAnnToA, addTrailingCommaToN, - addTrailingAnnToBF, noTrailingN, -- ** Utilities for converting between different 'GenLocated' when @@ -430,8 +426,6 @@ emptyComments = EpaComments [] type LocatedA = GenLocated SrcSpanAnnA type LocatedN = GenLocated SrcSpanAnnN -type LocatedBF = GenLocated SrcSpanAnnBF - -- | Annotation for items appearing in a list. They can have one or -- more trailing punctuations items, such as commas or semicolons. type SrcSpanAnnA = EpAnn [TrailingAnn] @@ -440,8 +434,6 @@ type SrcSpanAnnA = EpAnn [TrailingAnn] -- on the context, such as backticks. type SrcSpanAnnN = EpAnn NameAnn -type SrcSpanAnnBF = EpAnn AnnBooleanFormula - -- | General representation of a 'GenLocated' type carrying a -- parameterised annotation type. type LocatedAn an = GenLocated (EpAnn an) @@ -551,17 +543,6 @@ data AnnParen | AnnParensHash (EpToken "(#") (EpToken "#)") -- ^ '(#', '#)' deriving Data --- --------------------------------------------------------------------- --- | Exact print annotation for the 'BooleanFormula' data type. - -data AnnBooleanFormula - = AnnBooleanFormula { - abf_open :: (EpToken "("), -- ^ opening parenthesis. - abf_close :: (EpToken ")"), -- ^ closing parenthesis. - abf_trailing :: ![TrailingAnn] -- ^ items appearing after the - -- item, such as '|', ',' - } deriving (Data,Eq) - -- --------------------------------------------------------------------- -- Annotations for names -- --------------------------------------------------------------------- @@ -669,14 +650,6 @@ data AnnPragSCC -- --------------------------------------------------------------------- -addTrailingAnnToBF :: TrailingAnn -> EpAnnComments - -> EpAnn AnnBooleanFormula -> EpAnn AnnBooleanFormula -addTrailingAnnToBF t cs n = n { anns = addTrailing (anns n) - , comments = comments n <> cs } - where - -- See Note [list append in addTrailing*] - addTrailing n = n { abf_trailing = abf_trailing n ++ [t]} - -- | Helper function used in the parser to add a 'TrailingAnn' items -- to an existing annotation. addTrailingAnnToA :: TrailingAnn -> EpAnnComments @@ -1030,9 +1003,6 @@ instance (NoAnn ann) => NoAnn (EpAnn ann) where instance NoAnn NoEpAnns where noAnn = NoEpAnns -instance NoAnn AnnBooleanFormula where - noAnn = AnnBooleanFormula noAnn noAnn [] - instance NoAnn AnnList where noAnn = AnnList Nothing ListNone noAnn ===================================== testsuite/driver/perf_notes.py ===================================== @@ -83,9 +83,13 @@ PerfStat = NamedTuple('PerfStat', [('test_env', TestEnv), ('metric', MetricName), ('value', float)]) -# A baseline recovered form stored metrics. -Baseline = NamedTuple('Baseline', [('perfStat', PerfStat), - ('commit', GitHash)]) +# A test's metric recovered from a commit's git note: the raw sample values +# recorded there, and a PerfStat whose value is their mean. Serves as the +# baseline when comparing a test run against an earlier commit. +class CommitMetric(NamedTuple): + perfStat: PerfStat + commit: GitHash + samples: List[float] # The type of exceptions which are thrown when computing the current stat value # fails. @@ -460,10 +464,10 @@ def get_allowed_changes(baseline_ref: Optional[GitRef]) -> Dict[TestName, List[A else: return get_allowed_perf_changes() -# Cache of baseline values. This is a dict of dicts indexed on: -# (useCiNamespace, commit) -> (test_env, test, metric, way) -> baseline -# (bool , str ) -> (str , str , str , str) -> float -_commit_metric_cache = {} # type: ignore +# Cache of commit metrics. +_commit_metric_cache: Dict[Tuple[NoteNamespace, GitHash], + Dict[Tuple[TestEnv, TestName, MetricName, WayName], + CommitMetric]] = {} # Get the baseline of a test at a given commit. This is the expected value # *before* the commit is applied (i.e. on the parent commit). @@ -477,7 +481,7 @@ _commit_metric_cache = {} # type: ignore # instead when looking for ci results) # metric: str - test metric # way: str - test way -# returns: the Baseline or None if no metric was found within +# returns: the baseline CommitMetric or None if no metric was found within # BaselineSearchDepth commits and since the last expected change # (ignoring any expected change in the given commit). def baseline_metric(commit: GitHash, @@ -486,7 +490,7 @@ def baseline_metric(commit: GitHash, metric: MetricName, way: WayName, baseline_ref: Optional[GitRef] - ) -> Optional[Baseline]: + ) -> Optional[CommitMetric]: # For performance reasons (in order to avoid calling commit_hash), we assert # commit is already a commit hash. assert is_commit_hash(commit) @@ -502,20 +506,16 @@ def baseline_metric(commit: GitHash, # Searches through previous commits trying local then ci for each commit in. def find_baseline(namespace: NoteNamespace, test_env: TestEnv - ) -> Optional[Baseline]: + ) -> Optional[CommitMetric]: if baseline_commit is not None: - current_metric = get_commit_metric(namespace, baseline_commit, test_env, name, metric, way) - if current_metric is not None: - return Baseline(current_metric, baseline_commit) - else: - return None + return get_commit_metric(namespace, baseline_commit, test_env, name, metric, way) for depth, current_commit in list(enumerate(commit_hashes)): if current_commit == commit: continue # Check for a metric on this commit. current_metric = get_commit_metric(namespace, current_commit, test_env, name, metric, way) if current_metric is not None: - return Baseline(current_metric, current_commit) + return current_metric # Stop if there is an expected change at this commit. In that case # metrics on ancestor commits will not be a valid baseline. @@ -527,7 +527,7 @@ def baseline_metric(commit: GitHash, # Test environment to use when comparing against CI namespace ci_test_env = best_fit_ci_test_env() - baseline = find_baseline(LocalNamespace, test_env) # type: Optional[Baseline] + baseline = find_baseline(LocalNamespace, test_env) # type: Optional[CommitMetric] if baseline is None and ci_test_env is not None: baseline = find_baseline(CiNamespace, ci_test_env) @@ -545,23 +545,23 @@ def get_commit_metric_value_str_or_none(gitNoteRef, result = get_commit_metric(gitNoteRef, commit, test_env, name, metric, way) if result is None: return None - return str(result.value) + return str(result.perfStat.value) -# gets the average commit metric from git notes. +# gets the commit metric (average and raw samples) from git notes. # gitNoteRef: git notes ref space e.g. "perf" or "ci/perf" # ref: git commit # test_env: test environment # name: test name # metric: test metric # way: test way -# returns: PerfStat | None if stats don't exist for the given input +# returns: CommitMetric | None if stats don't exist for the given input def get_commit_metric(gitNoteRef, ref: Union[GitRef, GitHash], test_env: TestEnv, name: TestName, metric: MetricName, way: WayName - ) -> Optional[PerfStat]: + ) -> Optional[CommitMetric]: global _commit_metric_cache assert test_env != None commit = commit_hash(ref) @@ -573,9 +573,9 @@ def get_commit_metric(gitNoteRef, return _commit_metric_cache[cacheKeyA].get(cacheKeyB) # Cache miss. - # Calculate baselines from the current commit's git note. + # Calculate metrics from the current commit's git note. # Note that the git note may contain data for other tests. All tests' - # baselines will be collected and cached for future use. + # metrics will be collected and cached for future use. allCommitMetrics = get_perf_stats(ref, gitNoteRef) # Collect recorded values by cacheKeyB. @@ -586,22 +586,32 @@ def get_commit_metric(gitNoteRef, currentValues = values_by_cache_key_b.setdefault(currentCacheKey, []) currentValues.append(float(perfStat.value)) - # Calculate and baseline (average of values) by cacheKeyB. - baseline_by_cache_key_b = {} + # Calculate the metric (average of values, plus the values themselves) + # by cacheKeyB. + metric_by_cache_key_b = {} for currentCacheKey, currentValues in values_by_cache_key_b.items(): - baseline_by_cache_key_b[currentCacheKey] = PerfStat( \ - currentCacheKey[0], - currentCacheKey[1], - currentCacheKey[3], - currentCacheKey[2], - sum(currentValues) / len(currentValues)) - - # Save baselines to the cache. - _commit_metric_cache[cacheKeyA] = baseline_by_cache_key_b - return baseline_by_cache_key_b.get(cacheKeyB) + metric_by_cache_key_b[currentCacheKey] = CommitMetric( + PerfStat( + currentCacheKey[0], + currentCacheKey[1], + currentCacheKey[3], + currentCacheKey[2], + sum(currentValues) / len(currentValues)), + commit, + currentValues) + + # Save metrics to the cache. + _commit_metric_cache[cacheKeyA] = metric_by_cache_key_b + return metric_by_cache_key_b.get(cacheKeyB) + +def format_sample(s: float) -> str: + return str(int(s)) if s == int(s) else str(s) + +def format_samples(samples: List[float]) -> str: + return ', '.join(format_sample(s) for s in samples) def check_stats_change(actual: PerfStat, - baseline: Baseline, + baseline: CommitMetric, acceptance_window: MetricAcceptanceWindow, allowed_perf_changes: Dict[TestName, List[AllowedPerfChange]] = {}, force_print = False @@ -611,8 +621,8 @@ def check_stats_change(actual: PerfStat, Parameters: actual: the PerfStat with actual value - baseline: the expected Baseline value (this should generally be derived - from baseline_metric()) + baseline: the CommitMetric to compare against (this should generally be + derived from baseline_metric()) acceptance_window: allowed deviation of the actual value from the expected value. allowed_perf_changes: allowed changes in stats. This is a dictionary as @@ -654,9 +664,17 @@ def check_stats_change(actual: PerfStat, ' baseline @ %s' % baseline.commit print(actual.metric, error + ':') dev = 100.0 if expected_val == 0 else round(((float(actual.value) * 100) / int(expected_val)) - 100, 1) + # Show the sample spread so unreliable baselines become visible (#27602). + if len(baseline.samples) > 1: + samples_note = ('; baseline is mean of %d samples spanning %s..%s' + % (len(baseline.samples), + format_sample(min(baseline.samples)), + format_sample(max(baseline.samples)))) + else: + samples_note = '' change_line = (f'{actual.metric} {change.value} from {baseline.perfStat.test_env} ' f'baseline @ {baseline.commit[:7]}: {expected_val} -> {actual.value} ' - f'({dev:+g}%, allowed {acceptance_window.describe()})') + f'({dev:+g}%, allowed {acceptance_window.describe()}{samples_note})') result = failBecause('stat ' + change_line, tag='stat') if not change_allowed or force_print: @@ -666,6 +684,10 @@ def check_stats_change(actual: PerfStat, print(descr, str(val).rjust(length), extra) display(' Expected ' + full_name + ' ' + actual.metric + ':', expected_val, acceptance_window.describe()) + if len(baseline.samples) > 1: + display(' Samples ' + full_name + ' ' + actual.metric + ':', + len(baseline.samples), + '(' + format_samples(baseline.samples) + ')') display(' Lower bound ' + full_name + ' ' + actual.metric + ':', lowerBound, '') display(' Upper bound ' + full_name + ' ' + actual.metric + ':', upperBound, '') display(' Actual ' + full_name + ' ' + actual.metric + ':', actual.value, '') @@ -866,7 +888,7 @@ def main() -> None: # HEAD~2 21234 21234 # HEAD~3 20000 20000 def strMetric(x): - return '{:.2f}'.format(x.value) if x != None else "" + return '{:.2f}'.format(x.perfStat.value) if x != None else "" # Data is in column major format, so transpose and pass to print_table. T = TypeVar('T') def transpose(xss: List[List[T]]) -> List[List[T]]: ===================================== testsuite/driver/testglobals.py ===================================== @@ -4,7 +4,7 @@ from my_typing import * from pathlib import Path -from perf_notes import MetricChange, PerfStat, Baseline, GitRef +from perf_notes import MetricChange, PerfStat, CommitMetric, GitRef from datetime import datetime # ----------------------------------------------------------------------------- @@ -312,7 +312,7 @@ class TestResult: PerfMetric = NamedTuple('PerfMetric', [('change', MetricChange), ('stat', PerfStat), - ('baseline', Optional[Baseline]) ]) + ('baseline', Optional[CommitMetric]) ]) class TestRun: def __init__(self) -> None: ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -353,10 +353,6 @@ instance HasTrailing (EpToken "{", EpToken "}") where trailing _ = [] setTrailing a _ = a -instance HasTrailing (AnnBooleanFormula) where - trailing bf = abf_trailing bf - setTrailing a ts = a { abf_trailing = ts } - -- --------------------------------------------------------------------- fromAnn' :: (HasEntry a) => a -> Entry @@ -2731,9 +2727,11 @@ instance ExactPrint (BF.BooleanFormula GhcPs) where exact (BF.And e ls) = do ls' <- mapM markAnnotated ls return (BF.And e ls') - exact (BF.Parens e x) = do + exact (BF.Parens (o,c) x) = do + o' <- markEpToken o x' <- markAnnotated x - return (BF.Parens e x') + c' <- markEpToken c + return (BF.Parens (o',c') x') -- --------------------------------------------------------------------- @@ -4474,17 +4472,6 @@ instance ExactPrint [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))] whe stmts' <- markAnnotated stmts return stmts' -instance ExactPrint (LocatedBF (BF.BooleanFormula GhcPs)) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn - exact (L an bf) = do - debugM $ "LocatedCB [LBooleanFormula" - let (AnnBooleanFormula op cp ta) = anns an - op' <- markEpToken op - bf' <- markAnnotated bf - cp' <- markEpToken cp - return (L (an {anns = AnnBooleanFormula op' cp' ta}) bf') - instance ExactPrint [Located HsDocStringChunk] where getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ _ = a ===================================== utils/haddock/haddock-api/src/Haddock/Types.hs ===================================== @@ -834,7 +834,7 @@ type instance Anno (HsDecl DocNameI) = SrcSpanAnnA type instance Anno (FamilyResultSig DocNameI) = EpAnn NoEpAnns type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA type instance Anno (HsSigType DocNameI) = SrcSpanAnnA -type instance Anno (BooleanFormula DocNameI) = SrcSpanAnnBF +type instance Anno (BooleanFormula DocNameI) = SrcSpanAnnA type instance Anno (OverlapMode DocNameI) = SrcSpanAnnA type instance Anno (CType DocNameI) = SrcSpanAnnA type instance Anno (Header DocNameI) = SrcSpanAnnA @@ -1041,7 +1041,7 @@ type instance XXHsContextDetails DocNameI = DataConCantHappen type instance XBFVar DocNameI = NoExtField type instance XBFAnd DocNameI = NoExtField type instance XBFOr DocNameI = NoExtField -type instance XBFParens DocNameI = NoExtField +type instance XBFParens DocNameI = (EpToken "(", EpToken ")") type instance XXBooleanFormula DocNameI = DataConCantHappen ----------------------------------------------------------------------------- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e5bba7555255766786a65148a61f5f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e5bba7555255766786a65148a61f5f… 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-annotation-rationalisation] 11 commits: EPA some tests for layout. WIP
by Alan Zimmerman (＠alanz) 19 Aug '26

19 Aug '26

Alan Zimmerman pushed to branch wip/az/exactprint-annotation-rationalisation at Glasgow Haskell Compiler / GHC Commits: 4f559864 by Alan Zimmerman at 2026-08-19T19:26:35+01:00 EPA some tests for layout. WIP - - - - - 2d8be72c by Alan Zimmerman at 2026-08-19T19:26:35+01:00 Exactprint layout scope plan. Do not commit - - - - - 2543b267 by Alan Zimmerman at 2026-08-19T21:29:45+01:00 EPA: tidy up a bit. Combine somewhere else - - - - - ad343bd7 by Alan Zimmerman at 2026-08-19T22:08:50+01:00 EPA: Introduce LayoutFrame stacks in ExactPrint state - - - - - 95da65b9 by Alan Zimmerman at 2026-08-19T22:10:10+01:00 Plan update DO NOT COMMIT - - - - - a7a02608 by Alan Zimmerman at 2026-08-19T22:10:16+01:00 EPA: First pass implementation of HsList, for ClassDecls Just as a straight list replacement to start with, no payload. This shows the scope and invasiveness of the initial change - - - - - 0ba9d11b by Alan Zimmerman at 2026-08-19T22:10:16+01:00 EPA: HsList attempt WIP - - - - - 0d6e519e by Alan Zimmerman at 2026-08-19T22:10:16+01:00 Enable ppr test for Haddock1. It currently fails - - - - - ed79f702 by Alan Zimmerman at 2026-08-19T22:10:16+01:00 WIP on removing NoEpAnn. Likely abandon - - - - - 1bb4b198 by Alan Zimmerman at 2026-08-19T22:10:16+01:00 EPA: Add an overview doc for exact printing - - - - - 10be628d by Simon Peyton Jones at 2026-08-19T22:10:16+01:00 Added an intro section - - - - - 44 changed files: - ANNLIST-LAYOUT-PLAN.md - + ExactPrint.md - + LAYOUT-SCOPE-PLAN.md - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Main/Interactive.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/DocString.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Stats.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/ThToHs.hs - compiler/Language/Haskell/Syntax.hs - compiler/Language/Haskell/Syntax/Basic.hs - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Expr.hs - ghc/GHCi/UI.hs - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.hs - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/T20452.stderr - + testsuite/tests/printer/Layout.hs - testsuite/tests/printer/Makefile - testsuite/tests/printer/Test24533.stdout - testsuite/tests/printer/all.T - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Parsers.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Types.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/57acfce1ee5cd3c01600c9ba6bc6f8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/57acfce1ee5cd3c01600c9ba6bc6f8… 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/sjakobi/T16836-implicit-field-strictness] Add -Wimplicit-field-strictness (#16836)
by Simon Jakobi (＠sjakobi) 19 Aug '26

19 Aug '26

Simon Jakobi pushed to branch wip/sjakobi/T16836-implicit-field-strictness at Glasgow Haskell Compiler / GHC Commits: 1dfbf23a by Simon Jakobi at 2026-08-19T23:34:20+02:00 Add -Wimplicit-field-strictness (#16836) This opt-in warning fires when a data constructor field lacks an explicit strictness annotation (! or ~), so that users can insulate themselves against changes to the strictness default, e.g. via StrictData. It complements the LazyFieldAnnotations extension (4762a8bf30f) from GHC proposal 752, which makes ~ annotations available for this purpose. One diagnostic is emitted per data declaration, grouped by constructor. The hint deliberately names both ! and ~ without picking one: the choice is the user's. Newtypes and 'type data' declarations are exempt since strictness annotations are rejected there. Fixes #16836. Assisted-by: Claude Fable 5 - - - - - 16 changed files: - + changelog.d/implicit-field-strictness-warning - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - docs/users_guide/using-warnings.rst - + testsuite/tests/warnings/should_compile/T16836a.hs - + testsuite/tests/warnings/should_compile/T16836a.stderr - + testsuite/tests/warnings/should_compile/T16836b.hs - + testsuite/tests/warnings/should_compile/T16836c.hs - + testsuite/tests/warnings/should_compile/T16836c.stderr - testsuite/tests/warnings/should_compile/all.T Changes: ===================================== changelog.d/implicit-field-strictness-warning ===================================== @@ -0,0 +1,10 @@ +section: compiler +synopsis: Add `-Wimplicit-field-strictness` +issues: #16836 + +description: { + The new opt-in warning :ghc-flag:`-Wimplicit-field-strictness` reports + data constructor fields that lack an explicit strictness annotation + (``!`` or ``~``). Writing ``~`` requires + :extension:`LazyFieldAnnotations`. +} ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -1142,6 +1142,7 @@ data WarningFlag = | Opt_WarnUnrecognisedModifiers -- ^ @since 10.0 | Opt_WarnSemaphoreOpenFailure -- Since 10.0.1 | Opt_WarnDefaultedCallStack -- ^ @since 10.2 + | Opt_WarnImplicitFieldStrictness -- ^ @since 10.2 deriving (Eq, Ord, Show, Enum, Bounded) -- | Return the names of a WarningFlag @@ -1251,6 +1252,7 @@ warnFlagNames wflag = case wflag of Opt_WarnTypeEqualityRequiresOperators -> "type-equality-requires-operators" :| [] Opt_WarnMissingRoleAnnotations -> "missing-role-annotations" :| [] Opt_WarnImplicitRhsQuantification -> "implicit-rhs-quantification" :| [] + Opt_WarnImplicitFieldStrictness -> "implicit-field-strictness" :| [] Opt_WarnIncompleteExportWarnings -> "incomplete-export-warnings" :| [] Opt_WarnIncompleteRecordSelectors -> "incomplete-record-selectors" :| [] Opt_WarnBadlyLevelledTypes -> "badly-levelled-types" :| [] ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -2449,6 +2449,7 @@ wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of Opt_WarnUnrecognisedModifiers -> warnSpec x Opt_WarnSemaphoreOpenFailure -> warnSpec x Opt_WarnDefaultedCallStack -> warnSpec x + Opt_WarnImplicitFieldStrictness -> warnSpec x warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)] warningGroupsDeps = map mk warningGroups ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -1384,6 +1384,24 @@ instance Diagnostic TcRnMessage where hang (text "Missing role annotation" <> colon) 2 (text "type role" <+> ppr name <+> hsep (map ppr roles)) + TcRnImplicitFieldStrictness _name _lazy_anns cons -> mkSimpleDecorated $ + hang (text "Constructor fields without explicit strictness" <> colon) + 2 (vcat (map ppr_con cons)) + where + ppr_con (con, fields) = + bullet <+> text "In" <+> quotes (ppr con) <> colon <+> ppr_fields fields + ppr_fields fields + | let names = concat [ns | ImplicitStrictnessRecField _ ns <- fields] + , not (null names) + = text "field" <> plural names <+> and_list (map (quotes . ppr) names) + | otherwise + = let poss = [i | ImplicitStrictnessPosField _ i <- fields] + in text "the" <+> and_list (map speakNth poss) + <+> text "field" <> plural poss + and_list [] = empty + and_list [x] = x + and_list xs = hsep (punctuate comma (init xs)) <+> text "and" <+> last xs + TcRnIllformedTypePattern p -> mkSimpleDecorated $ hang (text "Ill-formed type pattern:") 2 (ppr p) @@ -2693,6 +2711,8 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnMissingRoleAnnotation{} -> WarningWithFlag Opt_WarnMissingRoleAnnotations + TcRnImplicitFieldStrictness{} + -> WarningWithFlag Opt_WarnImplicitFieldStrictness TcRnIllegalInvisTyVarBndr{} -> ErrorWithoutFlag TcRnIllegalWildcardTyVarBndr{} @@ -3428,6 +3448,12 @@ instance Diagnostic TcRnMessage where -> noHints TcRnMissingRoleAnnotation{} -> noHints + TcRnImplicitFieldStrictness _ lazy_anns _ + -> SuggestExplicitFieldStrictness + : [ useExtensionInOrderTo + (text "to allow" <+> quotes (char '~') <+> text "annotations") + LangExt.LazyFieldAnnotations + | not lazy_anns ] TcRnIllegalInvisTyVarBndr{} -> [suggestExtension LangExt.TypeAbstractions] TcRnIllegalWildcardTyVarBndr{} ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -123,6 +123,7 @@ module GHC.Tc.Errors.Types ( , TypeSyntax(..) , typeSyntaxExtension , SuggestLinear(..) + , ImplicitStrictnessField(..) -- * Errors for hs-boot and signature files , BadBootDecls(..) @@ -4235,6 +4236,24 @@ data TcRnMessage where -} TcRnMissingRoleAnnotation :: Name -> [Role] -> TcRnMessage + + {-| TcRnImplicitFieldStrictness is a warning that occurs when a data + constructor field lacks an explicit strictness annotation (@!@ or @~@) + + Controlled by flags: + - Wimplicit-field-strictness + + Test cases: + T16836a, T16836b + + -} + TcRnImplicitFieldStrictness + :: Name -- ^ the type constructor + -> Bool -- ^ whether @LazyFieldAnnotations@ is enabled + -> [(Name, [ImplicitStrictnessField])] + -- ^ per data constructor, the fields lacking annotations + -> TcRnMessage + {-| TcRnPatersonCondFailure is an error that occurs when an instance declaration fails to conform to the Paterson conditions. Which particular condition fails depends on the constructor of PatersonCondFailure @@ -6399,6 +6418,14 @@ data PatSynInvalidRhsReason | PatSynUnboundVar !Name deriving (Generic) +-- | A constructor field lacking an explicit strictness annotation, as +-- reported by 'TcRnImplicitFieldStrictness'. +data ImplicitStrictnessField + = -- | A record field group @x, y :: ty@ sharing one (absent) annotation + ImplicitStrictnessRecField SrcSpan [RdrName] + | -- | A positional argument (1-based index) + ImplicitStrictnessPosField SrcSpan Int + data BadFieldAnnotationReason where {-| A lazy data type field annotation (~) was used without enabling the extension LazyFieldAnnotations. ===================================== compiler/GHC/Tc/TyCl.hs ===================================== @@ -4023,8 +4023,39 @@ dataDeclChecks tc_name mctxt cons ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? ; unless (not (null cons) || empty_data_decls || is_boot) $ addErrTc (TcRnEmptyDataDeclsDisabled tc_name) + + ; warn_implicit_strictness <- woptM Opt_WarnImplicitFieldStrictness + ; when warn_implicit_strictness $ case cons of + DataTypeCons False data_cons + | let offenders = concatMap conImplicitStrictnessFields data_cons + , not (null offenders) + -> do { lazy_anns <- xoptM LangExt.LazyFieldAnnotations + ; setSrcSpan (getSrcSpan tc_name) $ addDiagnosticTc $ + TcRnImplicitFieldStrictness tc_name lazy_anns offenders } + _ -> return () + ; return gadt_syntax } +conImplicitStrictnessFields :: LConDecl GhcRn -> [(Name, [ImplicitStrictnessField])] +conImplicitStrictnessFields (L _ con) + | null fields = [] + | otherwise = [ (unLoc n, fields) | n <- getConNames con ] + where + fields = case con of + ConDeclH98 { con_args = PrefixCon _ args } -> pos_fields args + ConDeclH98 { con_args = InfixCon _ a1 a2 } -> pos_fields [a1, a2] + ConDeclH98 { con_args = RecCon _ (L _ flds) } -> rec_fields flds + ConDeclGADT { con_g_args = PrefixConGADT _ args } -> pos_fields args + ConDeclGADT { con_g_args = RecConGADT _ (L _ flds) } -> rec_fields flds + + pos_fields args = [ ImplicitStrictnessPosField (getLocA (cdf_type f)) i + | (i, f) <- zip [1 :: Int ..] args + , NoSrcStrict <- [cdf_bang f] ] + rec_fields flds = [ ImplicitStrictnessRecField (getLocA (cdf_type spec)) + [ rdr | L _ (FieldOcc rdr _) <- names ] + | L _ (HsConDeclRecField _ names spec) <- flds + , NoSrcStrict <- [cdf_bang spec] ] + ----------------------------------- data DataDeclInfo ===================================== compiler/GHC/Types/Error/Codes.hs ===================================== @@ -542,6 +542,7 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "TcRnNegativeNumTypeLiteral" = 93632 GhcDiagnosticCode "TcRnUnusedQuantifiedTypeVar" = 54180 GhcDiagnosticCode "TcRnMissingRoleAnnotation" = 65490 + GhcDiagnosticCode "TcRnImplicitFieldStrictness" = 47032 GhcDiagnosticCode "TcRnUntickedPromotedThing" = 49957 GhcDiagnosticCode "TcRnIllegalBuiltinSyntax" = 39716 ===================================== compiler/GHC/Types/Hint.hs ===================================== @@ -343,6 +343,14 @@ data GhcHint -} | SuggestAddStandaloneKindSignature Name + {-| Suggests to annotate each constructor field with explicit strictness + (@!@ or @~@), without picking one. + + Triggered by: 'GHC.Tc.Errors.Types.TcRnImplicitFieldStrictness' + Test case(s): warnings/should_compile/T16836a + -} + | SuggestExplicitFieldStrictness + {-| Suggests the user to fill in the wildcard constraint to disambiguate which constraint that is. ===================================== compiler/GHC/Types/Hint/Ppr.hs ===================================== @@ -185,6 +185,9 @@ instance Outputable GhcHint where -> text "Use a standalone deriving declaration instead" SuggestAddStandaloneKindSignature name -> text "Add a standalone kind signature for" <+> quotes (ppr name) + SuggestExplicitFieldStrictness + -> text "Annotate each field with" <+> quotes (char '!') + <+> text "(strict) or" <+> quotes (char '~') <+> text "(lazy)" SuggestFillInWildcardConstraint -> text "Fill in the wildcard constraint yourself" SuggestAppropriateTHTick ns ===================================== docs/users_guide/using-warnings.rst ===================================== @@ -2505,6 +2505,28 @@ of ``-W(no-)*``. In other words the type-class role cannot be accidentally left representational or phantom, which could affected the code correctness. +.. ghc-flag:: -Wimplicit-field-strictness + :shortdesc: warn when constructor fields lack explicit strictness annotations + :type: dynamic + :reverse: -Wno-implicit-field-strictness + :category: + + :since: 10.2.1 + :default: off + + .. index:: + single: strictness annotations, missing + + If you would like GHC to check that every data constructor field carries + an explicit strictness annotation — ``!`` (strict) or ``~`` (lazy) — use + the :ghc-flag:`-Wimplicit-field-strictness` option. It reports one warning + per data declaration, listing the unannotated fields of each constructor. + Writing ``~`` requires :extension:`LazyFieldAnnotations`. + + The warning applies to ``data`` and ``data instance`` declarations, + including GADT syntax. Newtypes and ``type data`` declarations are exempt, + as strictness annotations are rejected there. + .. ghc-flag:: -Wimplicit-rhs-quantification :shortdesc: warn when type variables on the RHS of a type synonym are implicitly quantified :type: dynamic ===================================== testsuite/tests/warnings/should_compile/T16836a.hs ===================================== @@ -0,0 +1,37 @@ +{-# OPTIONS_GHC -Wimplicit-field-strictness #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module T16836a where + +-- plain multi-constructor data +-- warns for both constructors +data T a = MkT a Bool + | MkT2 !Int a + +-- record with a shared field group +-- warns for x, y and z; not for b +data R = MkR { x, y :: Int, z :: Char, b :: !Bool } + +-- infix constructor +-- warns for the first argument +data I = Int :+: !Bool + +-- GADT syntax +-- warns for the first argument +data G a where + MkG :: Int -> !Bool -> G a + +-- GADT record syntax +-- warns for gx +data GR a where + MkGR :: { gx :: Int, gy :: !Bool } -> GR a + +-- data family instance +-- warns +data family F a +data instance F Int = MkF Char + +-- fully annotated +-- doesn't warn +data S = MkS !Int !Bool ===================================== testsuite/tests/warnings/should_compile/T16836a.stderr ===================================== @@ -0,0 +1,55 @@ +T16836a.hs:9:1: warning: [GHC-47032] [-Wimplicit-field-strictness] + • Constructor fields without explicit strictness: + • In ‘MkT’: the first and second fields + • In ‘MkT2’: the second field + • In the data type declaration for ‘T’ + Suggested fixes: + • Annotate each field with ‘!’ (strict) or ‘~’ (lazy) + • Use the ‘LazyFieldAnnotations’ extension (implied by ‘StrictData’) + to allow ‘~’ annotations + +T16836a.hs:14:1: warning: [GHC-47032] [-Wimplicit-field-strictness] + • Constructor fields without explicit strictness: + • In ‘MkR’: fields ‘x’, ‘y’ and ‘z’ + • In the data type declaration for ‘R’ + Suggested fixes: + • Annotate each field with ‘!’ (strict) or ‘~’ (lazy) + • Use the ‘LazyFieldAnnotations’ extension (implied by ‘StrictData’) + to allow ‘~’ annotations + +T16836a.hs:18:1: warning: [GHC-47032] [-Wimplicit-field-strictness] + • Constructor fields without explicit strictness: + • In ‘:+:’: the first field + • In the data type declaration for ‘I’ + Suggested fixes: + • Annotate each field with ‘!’ (strict) or ‘~’ (lazy) + • Use the ‘LazyFieldAnnotations’ extension (implied by ‘StrictData’) + to allow ‘~’ annotations + +T16836a.hs:22:1: warning: [GHC-47032] [-Wimplicit-field-strictness] + • Constructor fields without explicit strictness: + • In ‘MkG’: the first field + • In the data type declaration for ‘G’ + Suggested fixes: + • Annotate each field with ‘!’ (strict) or ‘~’ (lazy) + • Use the ‘LazyFieldAnnotations’ extension (implied by ‘StrictData’) + to allow ‘~’ annotations + +T16836a.hs:27:1: warning: [GHC-47032] [-Wimplicit-field-strictness] + • Constructor fields without explicit strictness: + • In ‘MkGR’: field ‘gx’ + • In the data type declaration for ‘GR’ + Suggested fixes: + • Annotate each field with ‘!’ (strict) or ‘~’ (lazy) + • Use the ‘LazyFieldAnnotations’ extension (implied by ‘StrictData’) + to allow ‘~’ annotations + +T16836a.hs:32:1: warning: [GHC-47032] [-Wimplicit-field-strictness] + • Constructor fields without explicit strictness: + • In ‘MkF’: the first field + • In the data family instance declaration for ‘F’ + Suggested fixes: + • Annotate each field with ‘!’ (strict) or ‘~’ (lazy) + • Use the ‘LazyFieldAnnotations’ extension (implied by ‘StrictData’) + to allow ‘~’ annotations + ===================================== testsuite/tests/warnings/should_compile/T16836b.hs ===================================== @@ -0,0 +1,25 @@ +{-# OPTIONS_GHC -Wimplicit-field-strictness #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeData #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE LazyFieldAnnotations #-} +module T16836b where + +-- fully annotated declarations don't warn +data T a = MkT ~a !Bool +data R = MkR { x, y :: !Int, z :: ~Char } +data G a where + MkG :: !Int -> ~Bool -> G a +data family F a +data instance F Int = MkF !Char + +-- newtypes can't have annotations; exempt +newtype N = MkN Int + +-- 'type data' can't have annotations; exempt +type data TD = MkTD Bool + +-- no fields, nothing to annotate +data E +data Nullary = A | B ===================================== testsuite/tests/warnings/should_compile/T16836c.hs ===================================== @@ -0,0 +1,6 @@ +{-# OPTIONS_GHC -Wimplicit-field-strictness #-} +{-# LANGUAGE StrictData #-} +module T16836c where + +-- unannotated fields warn under StrictData too +data T a = MkT a !Bool ~Char ===================================== testsuite/tests/warnings/should_compile/T16836c.stderr ===================================== @@ -0,0 +1,6 @@ +T16836c.hs:6:1: warning: [GHC-47032] [-Wimplicit-field-strictness] + • Constructor fields without explicit strictness: + • In ‘MkT’: the first field + • In the data type declaration for ‘T’ + Suggested fix: Annotate each field with ‘!’ (strict) or ‘~’ (lazy) + ===================================== testsuite/tests/warnings/should_compile/all.T ===================================== @@ -91,3 +91,6 @@ test('T25901_imp_unused_3', [extra_files(['T25901_helper_3.hs'])], multimod_comp test('T25901_imp_unused_4', normal, compile, ['-Wunused-imports']) test('T25901_imp_dodgy_1', [extra_files(['T25901_helper_1.hs'])], multimod_compile, ['T25901_imp_dodgy_1', '-v0 -Wdodgy-imports']) test('T25901_imp_dodgy_2', [extra_files(['T25901_helper_2.hs'])], multimod_compile, ['T25901_imp_dodgy_2', '-v0 -Wdodgy-imports']) +test('T16836a', normal, compile, ['']) +test('T16836b', normal, compile, ['']) +test('T16836c', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1dfbf23afd2e0603e84cb889f906998… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1dfbf23afd2e0603e84cb889f906998… 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