GitLab

Sasha Bogicevic pushed to branch wip/27323 at Glasgow Haskell Compiler / GHC

Commits:

f14b27ba

by Sasha Bogicevic at 2026-09-03T11:28:23+02:00

Don't report -XStrict-generated bangs under -Wredundant-bang-patterns

With -XStrict, decideBangHood inserts bang patterns on binders. When
such a bang cannot force anything (e.g. on a binder of unlifted type),
-Wredundant-bang-patterns reported it, even though there is no bang in
the source to remove.

The desugarer now tracks whether it is desugaring compiler-generated
code, mirroring tcl_in_gen_code in the typechecker:

* decideBangHood places the bangs it inserts at a generatedSrcSpan.
* DsLclEnv gains a dsl_in_generated_code field, maintained solely by
  putSrcSpanDs: a real span clears it, a generated span sets it.
* The pattern-match checker's desugaring (desugarLPat) pushes each
  pattern's location, and on a bang in generated code emits a PmBang
  with no SrcInfo: it is still divergence-checked (so inaccessible-RHS
  warnings under -XStrict survive, #21761), but never reported as
  redundant.

See Note [Desugaring -XStrict matches in Pmc] in GHC.HsToCore.Pmc.Desugar.
Making these bangs proper expanded patterns instead is tracked as #27677.

7 changed files:

+ changelog.d/T27323
compiler/GHC/HsToCore/Monad.hs
compiler/GHC/HsToCore/Pmc/Desugar.hs
compiler/GHC/HsToCore/Types.hs
compiler/GHC/HsToCore/Utils.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 ``-XStrict``-generated bang patterns under ``-Wredundant-bang-patterns``
 +description:
 +  Bangs introduced by ``-XStrict`` are no longer reported as redundant under
 +  ``-Wredundant-bang-patterns``, as they are not user-written.
 +issues: #27323
 +mrs: !16395

compiler/GHC/HsToCore/Monad.hs

@@ -15,7 +15,7 @@ module GHC.HsToCore.Monad (
          duplicateLocalDs, newSysLocalDs, newSysLocalsDs,
          newSysLocalMDs, newSysLocalsMDs, newFailLocalMDs,
          newUniqueId, newPredVarDs, newStaticId,
 -        getSrcSpanDs, putSrcSpanDs, putSrcSpanDsA,
 +        getSrcSpanDs, inGeneratedCodeDs, putSrcSpanDs, putSrcSpanDsA,
          mkNamePprCtxDs,
          newUnique,
          UniqSupply, newUniqueSupply,
@@ -584,6 +584,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env tcm_plugins ptc msg_var
                             , dsl_loc         = real_span
                             , dsl_nablas      = Ldi initNablas
                             , dsl_unspecables = Just emptyVarSet
 +                           , dsl_in_generated_code = False
+                            }
      in (gbl_env, lcl_env)
@@ -676,13 +677,17 @@ getSrcSpanDs :: DsM SrcSpan
  getSrcSpanDs = do { env <- getLclEnv
                    ; return (RealSrcSpan (dsl_loc env) Strict.Nothing) }
 +-- | See 'dsl_in_generated_code'
 +inGeneratedCodeDs :: DsM Bool
 +inGeneratedCodeDs = dsl_in_generated_code <$> getLclEnv
++
  putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
  putSrcSpanDs (RealSrcSpan real_span _) thing_inside
 -  = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside
 +  = updLclEnv (\ env -> env {dsl_loc = real_span, dsl_in_generated_code = False}) thing_inside
  putSrcSpanDs UnhelpfulSpan{} thing_inside
    = thing_inside
  putSrcSpanDs GeneratedSrcSpan{} thing_inside
 -  = thing_inside
 +  = updLclEnv (\ env -> env {dsl_in_generated_code = True}) thing_inside
  putSrcSpanDsA :: EpAnn ann -> DsM a -> DsM a
  putSrcSpanDsA loc = putSrcSpanDs (locA loc)

compiler/GHC/HsToCore/Pmc/Desugar.hs

@@ -155,11 +155,15 @@ 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 _ p@(L l p') -> do
      -- Add the bang in front of the list, because it will happen before any
      -- nested stuff.
 +    in_gen <- inGeneratedCodeDs
 +    -- A bang inserted by -XStrict (decideBangHood) has no SrcInfo: it is
 +    -- divergence-checked but never reported as redundant (#27323).
 +    let pm_loc | in_gen    = Nothing
 +               | otherwise = Just (SrcInfo (L (locA l) (ppr p')))
      consGrdDag (PmBang x pm_loc) <$> desugarLPat x p
 -      where pm_loc = Just (SrcInfo (L (locA l) (ppr p')))
    -- (x@pat)   ==>   Desugar pat with x as match var and handle impedance
    --                 mismatch with incoming match var
@@ -311,7 +315,7 @@ desugarPatV pat = do
    pure (x, grds)
  desugarLPat :: Id -> LPat GhcTc -> DsM GrdDag
 -desugarLPat x = desugarPat x . unLoc
 +desugarLPat x (L loc pat) = putSrcSpanDsA loc (desugarPat x pat)
  -- | 'desugarLPat', but also select and return a new match var.
  desugarLPatV :: LPat GhcTc -> DsM (Id, GrdDag)
@@ -650,4 +654,19 @@ user *had* written a bang:
  +    In an equation for ‘idV’: idV !v = ...
  So we live with the duplication.
++
 +Note that 'decideBangHood' places the bangs it inserts at a 'generatedSrcSpan'.
 +When 'desugarLPat' enters such a span, 'putSrcSpanDs' (GHC.HsToCore.Monad)
 +records in 'dsl_in_generated_code' that we are desugaring compiler-generated
 +code. For a bang in generated code, 'desugarPat' emits a 'PmBang' with no
 +'SrcInfo': the checker still performs the divergence check (so the
 +inaccessible-RHS warning above survives), but -Wredundant-bang-patterns only
 +ever reports bangs the user actually wrote (#27323). See
 +Note [Dead bang patterns] in GHC.HsToCore.Pmc.Check.
++
 +Eventually the bangs inserted by -XStrict should become expanded patterns,
 +following Note [Handling overloaded and rebindable constructs] in
 +GHC.Rename.Expr. That would let warnings always display the original
 +user-written code, making the decideBangHood duplication described above
 +unnecessary. This is tracked as #27677.
  -}

compiler/GHC/HsToCore/Types.hs

@@ -11,7 +11,7 @@ module GHC.HsToCore.Types (
          DsMetaEnv, DsMetaVal(..), CompleteMatches
      ) where
 -import GHC.Prelude (Int)
 +import GHC.Prelude (Bool, Int)
  import Data.IORef
@@ -125,6 +125,7 @@ data DsLclEnv
    -- ^ See Note [Desugaring non-canonical evidence]
    -- This field collects all un-specialisable evidence variables in scope.
    -- Nothing <=> don't collect this info (used for the LHS of Rules)
 +  , dsl_in_generated_code :: Bool -- Desugaring compiler-generated or user-written code
+   }
  -- Inside [| |] brackets, the desugarer looks

compiler/GHC/HsToCore/Utils.hs

@@ -951,6 +951,9 @@ Specifically:
  -- | Use -XStrict to add a ! or remove a ~
 +-- The bang we insert is compiler-generated, so we put it at a generatedSrcSpan.
 +-- The pattern-match checker uses this (via dsl_in_generated_code) to avoid reporting
 +-- such bangs under -Wredundant-bang-patterns (#27323).
  -- See Note [decideBangHood]
  decideBangHood :: DynFlags
                 -> LPat GhcTc  -- ^ Original pattern
@@ -966,7 +969,7 @@ decideBangHood dflags lpat
             ParPat x p -> L l (ParPat x (go p))
             LazyPat _ lp' -> lp'
             BangPat _ _   -> lp
 -           _             -> L l (BangPat noExtField lp)
 +           _             -> L (noAnnSrcSpan generatedSrcSpan) (BangPat noExtField lp)
  isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)

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'])