Sasha Bogicevic pushed to branch wip/27323 at Glasgow Haskell Compiler / GHC Commits: 15ece296 by mangoiv at 2026-10-08T15:14:56-04:00 ci: move hadrian/ghci into the lint category so it can be picked up by more runners Fixes #27817 - - - - - c0823135 by mangoiv at 2026-10-08T15:14:56-04:00 ci: make lint-adjacent jobs into platform independent - move lint jobs into lint-anyarch tag - unify lint jobs under the same platform independent container - - - - - f76464cf by Zubin Duggal at 2026-10-08T15:15:39-04:00 DmdAnal: Make AbsDmd neutral in maxDmd fixes #27845 - - - - - 2605998f by Sasha Bogicevic at 2026-10-09T13:08:06+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. - - - - - 20 changed files: - .gitlab-ci.yml - + changelog.d/27845 - + 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 - compiler/GHC/Types/Demand.hs - + testsuite/tests/dmdanal/should_run/T27845.hs - + testsuite/tests/dmdanal/should_run/T27845.stdout - + testsuite/tests/dmdanal/should_run/T27845_Lib.hs - + testsuite/tests/dmdanal/should_run/T27845b.hs - + testsuite/tests/dmdanal/should_run/T27845b.stdout - + testsuite/tests/dmdanal/should_run/T27845b_Lib.hs - testsuite/tests/dmdanal/should_run/all.T - + testsuite/tests/pmcheck/should_compile/T27323.hs - + testsuite/tests/pmcheck/should_compile/T27323b.hs - testsuite/tests/pmcheck/should_compile/all.T Changes: ===================================== .gitlab-ci.yml ===================================== @@ -137,15 +137,37 @@ workflow: .lint: stage: tool-lint tags: - - lint - before_script: - # Allow Git to read from the runner-owned checkout. This is needed - # for example by the lint-author job. - - git config --global --add safe.directory "$CI_PROJECT_DIR" + - lint-anyarch + image: debian:13 rules: - *drafts-can-fail-lint - when: always +.install-ghc-toolchain: &install-ghc-toolchain + - apt update + - apt install -qy build-essential curl libffi-dev libffi8 libgmp-dev libgmp10 libncurses-dev libncurses6 libtinfo6 pkg-config python3 cmake git happy alex autoconf automake python3 libgmp-dev libnuma-dev libncurses-dev + - curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_MINIMAL=1 sh + - source /root/.ghcup/env + - ghcup --no-verbose install ghc --set --install-targets 'install_bin install_lib update_package_db' '9.10' + - ghcup --no-verbose install cabal --set + - ghc --info + - cabal --version + +# linting but we need a boot toolchain +.lint-ghc-toolchain: + extends: .lint + before_script: + - *install-ghc-toolchain + - git config --global --add safe.directory "$CI_PROJECT_DIR" + +# linting but we need python +.lint-python: + extends: .lint + before_script: + - apt update + - apt install -qy python3 mypy shellcheck git + - git config --global --add safe.directory "$CI_PROJECT_DIR" + .nightly: &nightly variables: XZ_OPT: "-9" @@ -217,11 +239,11 @@ not-interruptible: stage: not-interruptible script: "true" interruptible: false - image: "debian:13" + image: debian:13 variables: GIT_STRATEGY: none tags: - - lint + - lint-anyarch rules: # - if: '$CI_COMMIT_BRANCH == "master"' # when: always @@ -242,7 +264,6 @@ include: '.gitlab/jobs.yaml' ghc-linters: stage: tool-lint - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb13:$DOCKER_REV" extends: .lint-params variables: BUILD_FLAVOUR: default @@ -258,16 +279,11 @@ ghc-linters: # Skipped if the MR has the ~"no-changelog" label. lint-changelog: stage: tool-lint - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb13:$DOCKER_REV" - extends: .lint + extends: .lint-ghc-toolchain variables: CHANGELOG_EXPECT_MR: "$CI_MERGE_REQUEST_IID" GIT_DEPTH: 1 GIT_SUBMODULE_STRATEGY: none - before_script: - - export PATH="/opt/toolchain/bin:$PATH" - # workaround for docker permissions - - sudo chown ghc:ghc -R . script: - .gitlab/ci.sh lint_changelog dependencies: [] @@ -279,42 +295,30 @@ lint-changelog: # Run mypy Python typechecker on linter scripts. lint-linters: - image: "registry.gitlab.haskell.org/ghc/ci-images/linters:$DOCKER_REV" - extends: .lint + extends: .lint-python variables: GIT_DEPTH: 1 GIT_SUBMODULE_STRATEGY: none - before_script: - # workaround for docker permissions - - sudo chown ghc:ghc -R . script: - mypy testsuite/tests/linters/regex-linters/*.py dependencies: [] # Check that .T files all parse by listing broken tests. lint-testsuite: - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb13:$DOCKER_REV" - extends: .lint + extends: .lint-ghc-toolchain variables: GIT_DEPTH: 1 GIT_SUBMODULE_STRATEGY: none - before_script: - # workaround for docker permissions - - sudo chown ghc:ghc -R . script: - - make -Ctestsuite list_broken TEST_HC=$GHC + - make -Ctestsuite list_broken TEST_HC=$(which ghc) dependencies: [] # Run mypy Python typechecker on testsuite driver typecheck-testsuite: - image: "registry.gitlab.haskell.org/ghc/ci-images/linters:$DOCKER_REV" - extends: .lint + extends: .lint-python variables: GIT_DEPTH: 1 GIT_SUBMODULE_STRATEGY: none - before_script: - # workaround for docker permissions - - sudo chown ghc:ghc -R . script: - mypy testsuite/driver/runtests.py dependencies: [] @@ -323,7 +327,6 @@ typecheck-testsuite: # accommodate, e.g., haddock changes not yet upstream) but not on `master` or # Marge jobs. .lint-submods: - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb13:$DOCKER_REV" extends: .lint-params variables: BUILD_FLAVOUR: default @@ -341,13 +344,9 @@ typecheck-testsuite: # Check that commits in an MR were not authored with the identity that CI uses # when it needs to create commits itself. This only needs Git history. lint-author: - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb13:$DOCKER_REV" - extends: .lint + extends: .lint-python variables: GIT_SUBMODULE_STRATEGY: none - before_script: - # workaround for docker permissions - - sudo chown ghc:ghc -R . script: - git fetch "$CI_MERGE_REQUEST_PROJECT_URL" $CI_MERGE_REQUEST_TARGET_BRANCH_NAME - base="$(git merge-base FETCH_HEAD $CI_COMMIT_SHA)" @@ -425,12 +424,9 @@ lint-submods-branch: .lint-params: needs: [] - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb13:$DOCKER_REV" extends: .lint before_script: - - export PATH="/opt/toolchain/bin:$PATH" - # workaround for docker permissions - - sudo chown ghc:ghc -R . + - *install-ghc-toolchain - .gitlab/ci.sh setup after_script: - .gitlab/ci.sh save_cache @@ -448,18 +444,13 @@ lint-submods-branch: hadrian-ghc-in-ghci: stage: quick-build + extends: .lint-ghc-toolchain needs: - job: lint-linters - job: lint-submods optional: true - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb13:$DOCKER_REV" - before_script: - # workaround for docker permissions - - sudo chown ghc:ghc -R . variables: GHC_FLAGS: -Werror -Wwarn=unused-imports - tags: - - x86_64-linux script: - git clean -xdf && git submodule foreach git clean -xdf - . .gitlab/ci.sh setup @@ -544,6 +535,7 @@ stack-hadrian-build: extends: hadrian-ghc-in-ghci stage: quick-build script: + - ghcup --no-verbose install stack --set - . .gitlab/ci.sh setup - . .gitlab/ci.sh configure - hadrian/build-stack --version ===================================== changelog.d/27845 ===================================== @@ -0,0 +1,5 @@ +section: compiler +synopsis: Fix a bug where an argument used lazily only by a function's stable + unfolding could be treated as strict in its fields. +mrs: !16746 +issues: #27845 ===================================== 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) ===================================== compiler/GHC/Types/Demand.hs ===================================== @@ -924,6 +924,8 @@ maxCard (Card a) (Card b) = Card ((a .&. b .&. 0b001) .|. ((a .|. b) .&. 0b110)) maxDmd :: Demand -> Demand -> Demand maxDmd BotDmd dmd2 = dmd2 maxDmd dmd1 BotDmd = dmd1 +maxDmd AbsDmd dmd2 = dmd2 +maxDmd dmd1 AbsDmd = dmd1 maxDmd (n1 :* sd1) (n2 :* sd2) = maxCard n1 n2 :* maxSubDmd sd1 sd2 ===================================== testsuite/tests/dmdanal/should_run/T27845.hs ===================================== @@ -0,0 +1,14 @@ +module Main where +import T27845_Lib (f) +import System.Environment (getArgs) + +{-# NOINLINE mkArg #-} +mkArg :: Int -> Int +mkArg n | n < 0 = n + | otherwise = error ("boom " ++ show n) + +main :: IO () +main = do + n <- length <$> getArgs + let x = mkArg n + print (length (f (x, x) n)) ===================================== testsuite/tests/dmdanal/should_run/T27845.stdout ===================================== @@ -0,0 +1 @@ +0 ===================================== testsuite/tests/dmdanal/should_run/T27845_Lib.hs ===================================== @@ -0,0 +1,11 @@ +module T27845_Lib where + +{-# INLINABLE [2] f #-} +f :: a -> Int -> [a] +f p x = lazyUse p x ++ lazyUse p (x + 1) ++ lazyUse p (x + 2) + +{-# NOINLINE lazyUse #-} +lazyUse :: a -> Int -> [a] +lazyUse p x = p `seq` replicate x p + +{-# RULES "lazyUse" [1] forall p x. lazyUse p x = [] #-} ===================================== testsuite/tests/dmdanal/should_run/T27845b.hs ===================================== @@ -0,0 +1,14 @@ +module Main where +import T27845b_Lib (outer) +import System.Environment (getArgs) + +{-# NOINLINE mkArg #-} +mkArg :: Int -> Int +mkArg n | n < 0 = n + | otherwise = error ("boom " ++ show n) + +main :: IO () +main = do + n <- length <$> getArgs + let x = mkArg n + print (length (outer (x, x) n)) ===================================== testsuite/tests/dmdanal/should_run/T27845b.stdout ===================================== @@ -0,0 +1 @@ +0 ===================================== testsuite/tests/dmdanal/should_run/T27845b_Lib.hs ===================================== @@ -0,0 +1,14 @@ +module T27845b_Lib where + +outer :: a -> Int -> [a] +outer a n = + let {-# INLINABLE [2] g #-} + g x = lazyUse a (x + 0) ++ lazyUse a (x + 1) ++ lazyUse a (x + 2) + in g n ++ g (n + 1) ++ g (n + 2) +{-# NOINLINE outer #-} + +{-# NOINLINE lazyUse #-} +lazyUse :: a -> Int -> [a] +lazyUse p x = p `seq` replicate x p + +{-# RULES "lazyUse" [1] forall p x. lazyUse p x = [] #-} ===================================== testsuite/tests/dmdanal/should_run/all.T ===================================== @@ -37,3 +37,5 @@ test('T25439', normal, compile_and_run, ['']) test('T26748', normal, compile_and_run, ['']) test('T26416', [extra_files(['M1.hs'])], multimod_compile_and_run, ['T26416','M1.hs']) test('T27626', [extra_files(['M2.hs'])], multimod_compile_and_run, ['T27626','M2.hs']) +test('T27845', [extra_files(['T27845_Lib.hs'])], multimod_compile_and_run, ['T27845','T27845_Lib.hs']) +test('T27845b', [extra_files(['T27845b_Lib.hs'])], multimod_compile_and_run, ['T27845b','T27845b_Lib.hs']) ===================================== 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/-/compare/fd8be410628df71b57532897f95f680... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fd8be410628df71b57532897f95f680... 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