Sasha Bogicevic pushed to branch wip/27323 at Glasgow Haskell Compiler / GHC Commits: fd8be410 by Sasha Bogicevic at 2026-10-09T11:21:49+02:00 Don't report -XStrict-generated bangs under -Wredundant-bang-patterns -Wredundant-bang-patterns could warn about bangs inserted by -XStrict, including those on unlifted function arguments and local tuple bindings, even though there is no user-written bang to remove. Mark bangs inserted by decideBangHood with generatedSrcSpan and track generated code in DsLclEnv through putSrcSpanDs. The pattern-match checker emits these bangs without SrcInfo, suppressing redundant-bang warnings while retaining divergence checks and inaccessible-RHS warnings. Update tidy1 and tidy_bang_pat to use the monadic context instead of threading a Boolean. Push sub-pattern locations when descending, and consult inGeneratedCodeDs when checking literal overflow. Preserve located patterns through matchSinglePatVar, pmcPatBind and desugarPatBind, using desugarLPat so pattern bindings retain their generated-code information. Add regression tests T27323 and T27323b and a changelog entry. - - - - - 10 changed files: - + changelog.d/T27323 - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Pmc.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/T27323b.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/Match.hs ===================================== @@ -383,12 +383,14 @@ tidyEqnInfo :: MatchId -> EquationInfo tidyEqnInfo _ eqn@(EqnDone {}) = return (idDsWrapper, eqn) -tidyEqnInfo v eqn@(EqnMatch { eqn_pat = (L loc pat) }) = do - (wrap, pat') <- tidy1 v (not . isGoodSrcSpan . locA $ loc) pat +tidyEqnInfo v eqn@(EqnMatch { eqn_pat = p@(L loc _) }) = do + (wrap, pat') <- tidyLPat v p return (wrap, eqn{eqn_pat = L loc pat' }) +tidyLPat :: MatchId -> LPat GhcTc -> DsM (DsWrapper, Pat GhcTc) +tidyLPat v (L loc pat) = putSrcSpanDsA loc (tidy1 v pat) + tidy1 :: MatchId -- The scrutinee - -> Bool -- `True` if the pattern was generated, `False` if it was user-written -> Pat GhcTc -- The pattern against which it is to be matched -> DsM (DsWrapper, -- Extra bindings to do before the match Pat GhcTc) -- Equivalent pattern @@ -399,21 +401,22 @@ tidy1 :: MatchId -- The scrutinee -- It eliminates many pattern forms (as-patterns, variable patterns, -- list patterns, etc) and returns any created bindings in the wrapper. -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 (ModifiedPat _ _ pat) = tidy1 v g (unLoc pat) +tidy1 v (ParPat _ pat) = tidyLPat v pat +tidy1 v (SigPat _ pat _) = tidyLPat v pat +tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty) +tidy1 v (BangPat _ (L l p)) = putSrcSpanDsA l $ tidy_bang_pat v l p +tidy1 v (ModifiedPat _ _ pat) = tidyLPat v pat -- case v of { x -> mr[] } -- = case v of { _ -> let x=v in mr[] } -tidy1 v _ (VarPat _ (L _ var)) +tidy1 v (VarPat _ (L _ var)) = return (bindMatchId var v, WildPat (idType var)) -- case v of { x@p -> mr[] } -- = case v of { p -> let x=v in mr[] } -tidy1 v g (AsPat _ (L _ var) pat) - = do { (wrap, pat') <- tidy1 v g (unLoc pat) +tidy1 v (AsPat _ (L _ var) pat) + + = do { (wrap, pat') <- tidyLPat v pat ; return (bindMatchId var v . wrap, pat') } {- now, here we handle lazy patterns: @@ -427,7 +430,7 @@ tidy1 v g (AsPat _ (L _ var) pat) The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr -} -tidy1 v _ (LazyPat _ pat) +tidy1 v (LazyPat _ pat) -- This is a convenient place to check for unlifted types under a lazy pattern. -- Doing this check during type-checking is unsatisfactory because we may -- not fully know the zonked types yet. We sure do here. @@ -441,14 +444,14 @@ tidy1 v _ (LazyPat _ pat) ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] ; return (mkCoreLets sel_binds, WildPat (matchIdType v)) } -tidy1 _ _ (ListPat ty pats) +tidy1 _ (ListPat ty pats) = return (idDsWrapper, unLoc list_ConPat) where list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty]) (mkNilPat ty) pats -tidy1 _ _ (TuplePat tys pats boxity) +tidy1 _ (TuplePat tys pats boxity) = return (idDsWrapper, unLoc tuple_ConPat) where arity = length pats @@ -458,34 +461,37 @@ tidy1 _ _ (TuplePat tys pats boxity) Boxed -> tys -- See Note [Unboxed tuple RuntimeRep vars] in TyCon -tidy1 _ _ (SumPat tys pat alt arity) +tidy1 _ (SumPat tys pat alt arity) = return (idDsWrapper, unLoc sum_ConPat) where sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] (map getRuntimeRep tys ++ tys) -- See Note [Unboxed tuple RuntimeRep vars] in TyCon -- LitPats: we *might* be able to replace these w/ a simpler form -tidy1 _ g (LitPat _ lit) - = do { unless g $ +tidy1 _ (LitPat _ lit) + = do { in_gen <- inGeneratedCodeDs; + unless in_gen $ warnAboutOverflowedLit lit ; return (idDsWrapper, tidyLitPat lit) } -- NPats: we *might* be able to replace these w/ a simpler form -tidy1 _ g (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq) - = do { unless g $ +tidy1 _ (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq) + = do { in_gen <- inGeneratedCodeDs; + unless in_gen $ let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v } | otherwise = lit in warnAboutOverflowedOverLit lit' ; return (idDsWrapper, tidyNPat lit mb_neg eq ty) } -- NPlusKPat: we may want to warn about the literals -tidy1 _ g n@(NPlusKPat _ _ (L _ lit1) lit2 _ _) - = do { unless g $ do +tidy1 _ n@(NPlusKPat _ _ (L _ lit1) lit2 _ _) + = do { in_gen <- inGeneratedCodeDs; + unless in_gen $ do warnAboutOverflowedOverLit lit1 warnAboutOverflowedOverLit lit2 ; return (idDsWrapper, n) } -tidy1 _ _ (OrPat ty lpats) +tidy1 _ (OrPat ty lpats) -- See Note [Implementation of OrPatterns]. We desugar -- (1; 2; 3) -- to @@ -514,44 +520,44 @@ tidy1 _ _ (OrPat ty lpats) single_grhs e = GRHSs emptyComments [noLocA $ GRHS noAnn [] e] (EmptyLocalBinds noExtField) -- Everything else goes through unchanged... -tidy1 _ _ non_interesting_pat +tidy1 _ non_interesting_pat = return (idDsWrapper, non_interesting_pat) -------------------- -tidy_bang_pat :: MatchId -> Bool -> SrcSpanAnnA -> Pat GhcTc +tidy_bang_pat :: MatchId -> 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 _ (ParPat _ (L l p)) = putSrcSpanDsA l $ tidy_bang_pat v l p +tidy_bang_pat v _ (SigPat _ (L l p) _) = putSrcSpanDsA l $ tidy_bang_pat v 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 l (AsPat x v' p) + = tidy1 v (AsPat x v' (L l (BangPat noExtField p))) +tidy_bang_pat v l (XPat (CoPat w p t)) + = tidy1 v (XPat $ CoPat w (BangPat noExtField (L l p)) t) +tidy_bang_pat v l (OrPat x (p:|ps)) -- push bang into first pat alt + = tidy1 v (OrPat x (L l (BangPat noExtField 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 _ p@(LitPat {}) = tidy1 v p +tidy_bang_pat v _ p@(ListPat {}) = tidy1 v p +tidy_bang_pat v _ p@(TuplePat {}) = tidy1 v p +tidy_bang_pat v _ p@(SumPat {}) = tidy1 v p -- Data/newtype constructors -tidy_bang_pat v g l p@(ConPat { pat_con = L _ (RealDataCon dc) - , pat_args = args - , pat_con_ext = ConPatTc - { cpt_arg_tys = arg_tys - } - }) +tidy_bang_pat v l p@(ConPat { pat_con = L _ (RealDataCon dc) + , pat_args = args + , pat_con_ext = ConPatTc + { cpt_arg_tys = arg_tys + } + }) -- 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 }) - else tidy1 v g p -- Data types: discard the bang + then tidy1 v (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args }) + else tidy1 v p -- Data types: discard the bang where (ty:_) = dataConInstArgTys dc arg_tys @@ -570,7 +576,7 @@ 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 _ l p = return (idDsWrapper, BangPat noExtField (L l p)) ------------------- push_bang_into_newtype_arg :: SrcSpanAnnA @@ -954,7 +960,7 @@ matchSinglePatVar var mb_scrut ctx pat ty match_result ; ldi_nablas <- if isMatchContextPmChecked_SinglePat dflags FromSource ctx pat then addCoreScrutTmCs (maybeToList mb_scrut) [var] $ - pmcPatBind (DsMatchContext ctx locn) var (unLoc pat) + pmcPatBind (DsMatchContext ctx locn) var pat else getLdiNablas ; let eqn_info = EqnMatch { eqn_pat = decideBangHood dflags pat ===================================== 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.hs ===================================== @@ -104,7 +104,7 @@ whenDoingPmc no_pmc thing_inside Ldi nablas -> thing_inside nablas } -- | Check a pattern binding (let, where) for exhaustiveness. -pmcPatBind :: DsMatchContext -> Id -> Pat GhcTc -> DsM LdiNablas +pmcPatBind :: DsMatchContext -> Id -> LPat GhcTc -> DsM LdiNablas pmcPatBind ctxt@(DsMatchContext match_ctxt loc) var p = whenDoingPmc NoPmc $ \ !missing -> mb_discard_warnings $ do ===================================== 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) @@ -374,11 +378,11 @@ desugarConPatOut x con univ_tys ex_tvs dicts = \case -- tracePm "ConPatOut" (ppr x $$ ppr con $$ ppr arg_ids) pure (con_grd `consGrdDag` arg_grds) -desugarPatBind :: SrcSpan -> Id -> Pat GhcTc -> DsM (PmPatBind Pre) +desugarPatBind :: SrcSpan -> Id -> LPat GhcTc -> DsM (PmPatBind Pre) -- See 'GrdPatBind' for how this simply repurposes GrdGRHS. -- See Note [Suppress warnings in PMC desugaring] desugarPatBind loc var pat = discardWarningsDs $ - PmPatBind . flip PmGRHS (SrcInfo (L loc (ppr pat))) <$> desugarPat var pat + PmPatBind . flip PmGRHS (SrcInfo (L loc (ppr pat))) <$> desugarLPat var pat desugarEmptyCase :: Id -> DsM PmEmptyCase desugarEmptyCase var = pure PmEmptyCase { pe_var = var } @@ -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 ===================================== @@ -1025,6 +1025,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 @@ -1040,7 +1043,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/T27323b.hs ===================================== @@ -0,0 +1,6 @@ +{-# LANGUAGE Strict, MonoLocalBinds #-} +{-# OPTIONS_GHC -Wredundant-bang-patterns #-} +module T27323b where + +f :: Int -> Int +f x = let (a, b) = (x, x) in a + b ===================================== testsuite/tests/pmcheck/should_compile/all.T ===================================== @@ -190,4 +190,6 @@ 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('T27323b', normal, compile, ['-Wredundant-bang-patterns']) test('T27360', normal, compile, [overlapping_incomplete + '-g3']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fd8be410628df71b57532897f95f680d... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fd8be410628df71b57532897f95f680d... 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