Simon Peyton Jones pushed to branch wip/T27078 at Glasgow Haskell Compiler / GHC Commits: 78b20395 by Simon Peyton Jones at 2026-04-16T00:01:07+01:00 Wibble - - - - - 1 changed file: - compiler/GHC/Core/Lint.hs Changes: ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -517,10 +517,10 @@ lintRecBindings top_lvl pairs thing_inside ; return (a, ues) } where (bndrs, rhss) = unzip pairs - lint_pair bndr' rhs - = addLoc (RhsOf bndr') $ - do { (rhs_ty, ue) <- lintRhs bndr' rhs -- Check the rhs - ; lintLetBind top_lvl Recursive bndr' rhs rhs_ty + lint_pair bndr rhs + = addLoc (RhsOf bndr) $ + do { (rhs_ty, ue) <- lintRhs bndr rhs -- Check the rhs + ; lintLetBind top_lvl Recursive bndr rhs rhs_ty ; return ue } lintLetBody :: LintLocInfo -> [Id] -> CoreExpr -> LintM (Type, UsageEnv) @@ -605,14 +605,17 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty _ -> return () - ; addLoc (RuleOf binder) $ mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder) + -- Lint any RULES + ; addLoc (RuleOf binder) $ + mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder) + -- Lint the unfolding + -- Do this here, not in lintIdBinder, so that all the + -- binders of the letrec group are in scope ; addLoc (UnfoldingOf binder) $ lintIdUnfolding binder binder_ty (idUnfolding binder) - ; return () } - -- We should check the unfolding, if any, but this is tricky because - -- the unfolding is a SimplifiableCoreExpr. Give up for now. + ; return () } -- | Checks the RHS of bindings. It only differs from 'lintCoreExpr' -- in that it doesn't reject occurrences of the function 'makeStatic' when they @@ -669,17 +672,26 @@ lintIdUnfolding :: Id -> Type -> Unfolding -> LintM () lintIdUnfolding bndr bndr_ty uf | isStableUnfolding uf , Just rhs <- maybeUnfoldingTemplate uf - = noMultiplicityChecks $ -- Skip linearity checking for unfoldings - -- See Note [Linting linearity] - do { ty <- fst <$> (if isCompulsoryUnfolding uf - then noFixedRuntimeRepChecks $ lintRhs bndr rhs - -- ^^^^^^^^^^^^^^^^^^^^^^^ - -- See Note [Checking for representation polymorphism] - else lintRhs bndr rhs) - ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) } -lintIdUnfolding _ _ _ - = return () -- Do not Lint unstable unfoldings, because that leads - -- to exponential behaviour; c.f. GHC.Core.FVs.idUnfoldingVars + = do { -- Check the unfolding only if lf_check_stable_unfoldings is on + -- See (STL3) in Note [Substituting type-lets] + flags <- getLintFlags + ; when (lf_check_stable_unfoldings flags) $ + suppress_rr_checks $ + noMultiplicityChecks $ -- Skip linearity checking for unfoldings + -- See Note [Linting linearity] + do { (unf_ty, _unf_ue) <- lintRhs bndr rhs + ; ensureEqTys bndr_ty unf_ty (mkRhsMsg bndr (text "unfolding") unf_ty) } } + + | otherwise + = -- Do not Lint the body of an unstable unfolding, because that leads + -- to exponential behaviour; c.f. GHC.Core.FVs.idUnfoldingVars + return () + + where + -- See Note [Checking for representation polymorphism] + suppress_rr_checks thing_inside + | isCompulsoryUnfolding uf = noFixedRuntimeRepChecks thing_inside + | otherwise = thing_inside {- Note [Checking for INLINE loop breakers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -893,7 +905,7 @@ lintCoreExpr (Let (NonRec bndr rhs) body) = do { -- First Lint the RHS, before bringing the binder into scope (rhs_ty, let_ue) <- lintRhs bndr rhs - -- See Note [Multiplicity of let binders] in Var + -- See Note [Multiplicity of let binders] in Var -- Now lint the binder ; lintBinder LetBind bndr $ do { lintLetBind NotTopLevel NonRecursive bndr rhs rhs_ty @@ -1824,7 +1836,12 @@ lintIdBndr top_lvl bind_site id thing_inside ; lintL (not (isCoVarType id_ty)) (text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr id_ty) - ; lintLocalUnfolding bind_site id + -- Check that lambda-bound Ids have no unfolding; not even OtherCon + -- See #21496 + ; let unf = idUnfolding id + ; checkL (not (bind_site == LambdaBind && hasSomeUnfolding unf)) $ + hang (text "Lambda binder" <+> quotes (ppr id) <+> text "has an unfolding") + 2 (ppr unf) ; addLoc (IdTy id) (lintValueType id_ty) @@ -1837,28 +1854,6 @@ lintIdBndr top_lvl bind_site id thing_inside LetBind -> True _ -> False -lintLocalUnfolding :: BindingSite -> Id -> LintM () -lintLocalUnfolding bind_site id - | Just unf_rhs <- maybeUnfoldingTemplate unf - , isStableUnfolding unf - = do { checkL (bind_site == LetBind) $ - hang (text "Non-let-binder" <+> quotes (ppr id) <+> text "has a stable unfolding") - 2 (ppr unf) - ; flags <- getLintFlags - ; when (lf_check_stable_unfoldings flags) $ - do { (unf_ty, _unf_ue) <- lintCoreExpr unf_rhs - ; ensureEqTys (idType id) unf_ty $ - hang (text "Unfolding for:" <+> ppr id <+> dcolon <+> ppr (idType id)) - 2 (text "has type:" <+> ppr unf_ty) } } - - | otherwise - = do { -- Check that the lambda binder has no value or OtherCon unfolding. - -- See #21496 - ; lintL (not (bind_site == LambdaBind && isEvaldUnfolding (idUnfolding id))) - (text "Lambda binder with value or OtherCon unfolding.") } - where - unf = idUnfolding id - {- %************************************************************************ %* * View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/78b203955e230d7a297cda1692600373... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/78b203955e230d7a297cda1692600373... You're receiving this email because of your account on gitlab.haskell.org.