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 ===================================== @@ -0,0 +1,7 @@ +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 ===================================== @@ -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/f14b27ba9cd7043cb32c00ad0e522e84... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f14b27ba9cd7043cb32c00ad0e522e84... 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