Sasha Bogicevic pushed to branch wip/27323 at Glasgow Haskell Compiler / GHC Commits: 708c671a by Sasha Bogicevic at 2026-07-22T19:35:14+02:00 Don't report -XStrict-generated bangs under -Wredundant-bang-patterns XBangPat GhcTc is now Origin: user bangs are FromSource, bangs added by decideBangHood are Generated. The pattern-match checker attaches no SrcInfo to generated bangs, so they are divergence-checked but never reported as redundant. Fixes #27323 - - - - - 9 changed files: - + changelog.d/T27323 - compiler/GHC/Hs/Pat.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Pmc/Check.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Tc/Gen/Pat.hs - + testsuite/tests/pmcheck/should_compile/T27323.hs - testsuite/tests/pmcheck/should_compile/all.T Changes: ===================================== changelog.d/T27323 ===================================== @@ -0,0 +1,15 @@ +section: compiler +synopsis: Don't report compiler-generated bang patterns under -Wredundant-bang-patterns +description: + With ``-XStrict``, GHC inserts bang patterns on binders. When such a bang + cannot force anything - for instance on a binder of unlifted type such as + ``Int#`` - it was reported by ``-Wredundant-bang-patterns``, even though + there is no bang in the source to remove. The warning now only reports + bangs the user actually wrote. + + As part of this change, the ``XBangPat GhcTc`` extension field of + ``BangPat`` changed from ``NoExtField`` to ``Origin``, recording whether a + bang was user-written or compiler-generated. GHC API users constructing or + matching typechecked bang patterns may need a one-line adjustment. +mrs: !16395 +issues: #27323 ===================================== compiler/GHC/Hs/Pat.hs ===================================== @@ -102,7 +102,11 @@ type instance XParPat GhcTc = NoExtField type instance XBangPat GhcPs = EpToken "!" type instance XBangPat GhcRn = NoExtField -type instance XBangPat GhcTc = NoExtField +-- | Was this bang written by the user, or inserted by 'decideBangHood' +-- because of -XStrict? Consulted by the pattern-match checker, which +-- only reports user-written bangs under -Wredundant-bang-patterns. +-- See Note [Dead bang patterns] in GHC.HsToCore.Pmc.Check. +type instance XBangPat GhcTc = Origin type instance XListPat GhcPs = AnnList () -- After parsing, ListPat can refer to a built-in Haskell list pattern ===================================== compiler/GHC/HsToCore/Match.hs ===================================== @@ -414,7 +414,7 @@ tidy1 :: Id -- The Id being scrutinised tidy1 v g (ParPat _ pat) = tidy1 v g (unLoc pat) tidy1 v g (SigPat _ pat _) = tidy1 v g (unLoc pat) tidy1 _ _ (WildPat ty) = return (idDsWrapper, WildPat ty) -tidy1 v g (BangPat _ (L l p)) = tidy_bang_pat v g l p +tidy1 v g (BangPat o (L l p)) = tidy_bang_pat v g o l p tidy1 v g (ModifiedPat _ _ pat) = tidy1 v g (unLoc pat) -- case v of { x -> mr[] } @@ -530,30 +530,30 @@ tidy1 _ _ non_interesting_pat = return (idDsWrapper, non_interesting_pat) -------------------- -tidy_bang_pat :: Id -> Bool -> SrcSpanAnnA -> Pat GhcTc +tidy_bang_pat :: Id -> Bool -> Origin -> SrcSpanAnnA -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc) -- Discard par/sig under a bang -tidy_bang_pat v g _ (ParPat _ (L l p)) = tidy_bang_pat v g l p -tidy_bang_pat v g _ (SigPat _ (L l p) _) = tidy_bang_pat v g l p +tidy_bang_pat v g o _ (ParPat _ (L l p)) = tidy_bang_pat v g o l p +tidy_bang_pat v g o _ (SigPat _ (L l p) _) = tidy_bang_pat v g o l p -- Push the bang-pattern inwards, in the hope that -- it may disappear next time -tidy_bang_pat v g l (AsPat x v' p) - = tidy1 v g (AsPat x v' (L l (BangPat noExtField p))) -tidy_bang_pat v g l (XPat (CoPat w p t)) - = tidy1 v g (XPat $ CoPat w (BangPat noExtField (L l p)) t) -tidy_bang_pat v g l (OrPat x (p:|ps)) -- push bang into first pat alt - = tidy1 v g (OrPat x (L l (BangPat noExtField p) :| ps)) +tidy_bang_pat v g o l (AsPat x v' p) + = tidy1 v g (AsPat x v' (L l (BangPat o p))) +tidy_bang_pat v g o l (XPat (CoPat w p t)) + = tidy1 v g (XPat $ CoPat w (BangPat o (L l p)) t) +tidy_bang_pat v g o l (OrPat x (p:|ps)) -- push bang into first pat alt + = tidy1 v g (OrPat x (L l (BangPat o p) :| ps)) -- Discard bang around strict pattern -tidy_bang_pat v g _ p@(LitPat {}) = tidy1 v g p -tidy_bang_pat v g _ p@(ListPat {}) = tidy1 v g p -tidy_bang_pat v g _ p@(TuplePat {}) = tidy1 v g p -tidy_bang_pat v g _ p@(SumPat {}) = tidy1 v g p +tidy_bang_pat v g _ _ p@(LitPat {}) = tidy1 v g p +tidy_bang_pat v g _ _ p@(ListPat {}) = tidy1 v g p +tidy_bang_pat v g _ _ p@(TuplePat {}) = tidy1 v g p +tidy_bang_pat v g _ _ p@(SumPat {}) = tidy1 v g p -- Data/newtype constructors -tidy_bang_pat v g l p@(ConPat { pat_con = L _ (RealDataCon dc) +tidy_bang_pat v g o l p@(ConPat { pat_con = L _ (RealDataCon dc) , pat_args = args , pat_con_ext = ConPatTc { cpt_arg_tys = arg_tys @@ -562,7 +562,7 @@ tidy_bang_pat v g l p@(ConPat { pat_con = L _ (RealDataCon dc) -- Newtypes: push bang inwards (#9844) = if isNewTyCon (dataConTyCon dc) - then tidy1 v g (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args }) + then tidy1 v g (p { pat_args = push_bang_into_newtype_arg l o (scaledThing ty) args }) else tidy1 v g p -- Data types: discard the bang where (ty:_) = dataConInstArgTys dc arg_tys @@ -582,28 +582,29 @@ tidy_bang_pat v g l p@(ConPat { pat_con = L _ (RealDataCon dc) -- -- NB: SigPatIn, ConPatIn should not happen -tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (L l p)) +tidy_bang_pat _ _ o l p = return (idDsWrapper, BangPat o (L l p)) ------------------- push_bang_into_newtype_arg :: SrcSpanAnnA + -> Origin -> Type -- The type of the argument we are pushing -- onto -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc -- See Note [Bang patterns and newtypes] -- We are transforming !(N p) into (N !p) -push_bang_into_newtype_arg l _ty (PrefixCon x (arg:args)) +push_bang_into_newtype_arg l o _ty (PrefixCon x (arg:args)) = assert (null args) $ - PrefixCon x [L l (BangPat noExtField arg)] -push_bang_into_newtype_arg l _ty (RecCon x rf) + PrefixCon x [L l (BangPat o arg)] +push_bang_into_newtype_arg l o _ty (RecCon x rf) | HsRecFields { rec_flds = L lf fld : flds } <- rf , HsFieldBind { hfbRHS = arg } <- fld = assert (null flds) $ RecCon x (rf { rec_flds = [L lf (fld { hfbRHS - = L l (BangPat noExtField arg) })] }) -push_bang_into_newtype_arg l ty (RecCon _ rf) -- If a user writes !(T {}) + = L l (BangPat o arg) })] }) +push_bang_into_newtype_arg l o ty (RecCon _ rf) -- If a user writes !(T {}) | HsRecFields { rec_flds = [] } <- rf - = PrefixCon noExtField [L l (BangPat noExtField (noLocA (WildPat ty)))] -push_bang_into_newtype_arg _ _ cd + = PrefixCon noExtField [L l (BangPat o (noLocA (WildPat ty)))] +push_bang_into_newtype_arg _ _ _ cd = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd) {- ===================================== compiler/GHC/HsToCore/Pmc/Check.hs ===================================== @@ -128,7 +128,9 @@ checkGrd grd = CA $ \inc -> case grd of div <- addPhiCtNablas inc (PhiBotCt x) matched <- addPhiCtNablas inc (PhiNotBotCt x) -- See Note [Dead bang patterns] - -- mb_info = Just info <==> PmBang originates from bang pattern in source + -- mb_info = Just info <==> the PmBang originates from a user-written + -- bang pattern. Bangs inserted by -XStrict carry no info and are thus + -- never reported as redundant (#27323). let bangs | Just info <- mb_info = unitOL (div, info) | otherwise = NilOL tracePm "check:Bang" (ppr x <+> ppr div) @@ -267,6 +269,22 @@ dead. So for a source bang, we add the refined Nabla and the source info to the 'RedSet's 'rs_bangs'. When collecting stuff to warn, we test that Nabla for inhabitants. If it's empty, we'll warn that it's redundant. +Crucially, we only ever warn about bangs the user wrote. With -XStrict, the +compiler inserts bangs itself ('decideBangHood' in GHC.HsToCore.Utils), and +such a bang is often dead. Consider (#27323) + + {-# LANGUAGE MagicHash, Strict #-} + idInt# :: Int# -> Int# + idInt# x = x + +The binder `x` has unlifted type, so the bang that -XStrict inserts on it can +never force anything. But warning would be deeply confusing: there is no bang +in the source to delete! Whether a bang was user-written is recorded in the +'XBangPat GhcTc' extension field ('Origin'); generated bangs desugar to a +'PmBang' with no 'SrcInfo', so they still take part in divergence checking +(that matters for the inaccessible-RHS warnings of #21761) but never end up +in 'rs_bangs'. + Note that we don't want to warn for a dead bang that appears on a redundant clause. That is because in that case, we recommend to delete the clause wholly, including its leading pattern match. ===================================== compiler/GHC/HsToCore/Pmc/Desugar.hs ===================================== @@ -18,6 +18,7 @@ import GHC.Data.FastString (unpackFS, lengthFS, mkFastStringShortText) import GHC.Driver.DynFlags import GHC.Hs import GHC.Tc.Utils.TcMType (shortCutLit) +import GHC.Types.Basic (isGenerated) import GHC.Types.Id import GHC.Core.ConLike import GHC.Types.Name @@ -154,11 +155,11 @@ desugarPat x pat = case pat of VarPat _ y -> pure (mkPmLetVar (unLoc y) x) ParPat _ p -> desugarLPat x p LazyPat _ _ -> pure GdEnd -- like a wildcard - BangPat _ p@(L l p') -> + BangPat orig p@(L l p') -> -- Add the bang in front of the list, because it will happen before any -- nested stuff. consGrdDag (PmBang x pm_loc) <$> desugarLPat x p - where pm_loc = Just (SrcInfo (L (locA l) (ppr p'))) + where pm_loc = if isGenerated orig then Nothing else Just (SrcInfo (L (locA l) (ppr p'))) -- (x@pat) ==> Desugar pat with x as match var and handle impedance -- mismatch with incoming match var @@ -649,4 +650,12 @@ user *had* written a bang: + In an equation for ‘idV’: idV !v = ... So we live with the duplication. + +There is one wrinkle (#27323): the bang inserted by 'decideBangHood' is +compiler-generated, marked 'Generated' in its 'XBangPat GhcTc' field. When +'desugarPat' sees such a bang, it emits a 'PmBang' without 'SrcInfo', so +that the checker performs the usual divergence check (giving the +inaccessible-RHS warning above) but never reports the bang under +-Wredundant-bang-patterns. See Note [Dead bang patterns] in +GHC.HsToCore.Pmc.Check. -} ===================================== compiler/GHC/HsToCore/Utils.hs ===================================== @@ -53,6 +53,7 @@ import GHC.HsToCore.Monad import GHC.Core.Utils import GHC.Core.Make +import GHC.Types.Basic (Origin(Generated), GenReason(OtherExpansion), DoPmc(..)) import GHC.Types.Id.Make import GHC.Types.Id import GHC.Types.Literal @@ -956,6 +957,12 @@ Specifically: !pat => !pat -- always pat => !pat -- when -XStrict pat => pat -- otherwise + +The bangs we add here are compiler-generated: we record 'Generated' in the +'XBangPat GhcTc' extension field, whereas a user-written bang is typechecked +to 'FromSource' (GHC.Tc.Gen.Pat). The pattern-match checker consults this +field so that -Wredundant-bang-patterns only reports bangs that the user +actually wrote (#27323). See Note [Dead bang patterns] in GHC.HsToCore.Pmc.Check. -} @@ -975,7 +982,7 @@ decideBangHood dflags lpat ParPat x p -> L l (ParPat x (go p)) LazyPat _ lp' -> lp' BangPat _ _ -> lp - _ -> L l (BangPat noExtField lp) + _ -> L l (BangPat (Generated OtherExpansion DoPmc) lp) isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr) ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -31,6 +31,7 @@ import GHC.Tc.Gen.Sig( TcPragEnv, lookupPragEnv, addInlinePrags ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Instantiate import GHC.Types.FieldLabel +import GHC.Types.Basic (Origin (FromSource)) import GHC.Types.Id import GHC.Types.Var import GHC.Types.Name @@ -627,9 +628,9 @@ tc_pat scaled_exp_pat_ty@(Scaled w_pat exp_pat_ty) penv ps_pat thing_inside = { (pat', res) <- tc_lpat scaled_exp_pat_ty penv pat thing_inside ; return (ParPat x pat', res) } - BangPat x pat -> do + BangPat _ pat -> do { (pat', res) <- tc_lpat scaled_exp_pat_ty penv pat thing_inside - ; return (BangPat x pat', res) } + ; return (BangPat FromSource pat', res) } OrPat _ pats -> do -- See Note [Implementation of OrPatterns], Typechecker (1) { let pats_list = NE.toList pats ===================================== testsuite/tests/pmcheck/should_compile/T27323.hs ===================================== @@ -0,0 +1,9 @@ +{-# LANGUAGE MagicHash, Strict #-} +{-# OPTIONS_GHC -Wredundant-bang-patterns #-} + +import GHC.Prim (Int#) + +idInt# :: Int# -> Int# +idInt# x = x + +main = pure () ===================================== testsuite/tests/pmcheck/should_compile/all.T ===================================== @@ -190,4 +190,5 @@ test('T24845', [], compile, [overlapping_incomplete]) test('T22652', [], compile, [overlapping_incomplete]) test('T22652a', [], compile, [overlapping_incomplete]) test('T24867', [], compile_fail, [overlapping_incomplete]) +test('T27323', normal, compile, ['-Wredundant-bang-patterns']) test('T27360', normal, compile, [overlapping_incomplete + '-g3']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/708c671a5d57bc746d8c11c5ff01a60c... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/708c671a5d57bc746d8c11c5ff01a60c... 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