GitLab

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

 +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

 +{-# 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'])