Simon Peyton Jones pushed to branch wip/T24464 at Glasgow Haskell Compiler / GHC Commits: 7e9b196e by Simon Peyton Jones at 2026-01-16T00:05:30+00:00 More [skip ci] - - - - - 12 changed files: - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/BasicTypes.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Zonk/TcType.hs - compiler/GHC/Tc/Zonk/Type.hs Changes: ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -3063,17 +3063,12 @@ Note [Checking StaticPtrs] ~~~~~~~~~~~~~~~~~~~~~~~~~~ See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview. -Every occurrence of the function 'makeStatic' should be moved to the -top level by the FloatOut pass. It's vital that we don't have nested -'makeStatic' occurrences after CorePrep, because we populate the Static -Pointer Table from the top-level bindings. See SimplCore Note [Grand -plan for static forms]. - -The linter checks that no occurrence is left behind, nested within an -expression. The check is enabled only after the FloatOut, CorePrep, -and CoreTidy passes and only if the module uses the StaticPointers -language extension. Checking more often doesn't help since the condition -doesn't hold until after the first FloatOut pass. +Every occurrence of the function 'makeStatic' should be at top level. +It's vital that we don't have nested 'makeStatic' occurrences after +CorePrep, because we populate the Static Pointer Table from the +top-level bindings. See SimplCore Note [Grand plan for static forms]. + +The linter checks that no occurrence or `makeStatic` occurs nested. Note [Type substitution] ~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Core/Opt/Pipeline.hs ===================================== @@ -64,7 +64,6 @@ import GHC.Types.Var ( Var ) import GHC.Types.Unique.Supply ( UniqueTag(..) ) import Control.Monad -import qualified GHC.LanguageExtensions as LangExt import GHC.Unit.Module {- @@ -206,14 +205,14 @@ getCoreToDo dflags hpt_rule_base extra_vars -- so that overloaded functions have all their dictionary lambdas manifest runWhen do_specialise CoreDoSpecialising, - runWhen full_laziness $ - CoreDoFloatOutwards $ FloatOutSwitches + runWhen full_laziness + (CoreDoFloatOutwards $ FloatOutSwitches { floatOutLambdas = Just 0 , floatOutConstants = True , floatOutOverSatApps = False , floatToTopLevelOnly = False , floatJoinsToTop = False -- Initially, don't float join points at all - } + }), -- I have no idea why, but not floating constants to -- top level is very bad in some cases. -- ===================================== compiler/GHC/Core/Opt/SetLevels.hs ===================================== @@ -109,7 +109,7 @@ import GHC.Types.Var.Env import GHC.Types.Literal ( litIsTrivial ) import GHC.Types.Demand ( DmdSig, prependArgsDmdSig ) import GHC.Types.Cpr ( CprSig, prependArgsCprSig ) -import GHC.Types.Name ( getOccName, mkSystemVarName ) +import GHC.Types.Name ( getOccName ) import GHC.Types.Name.Occurrence ( occNameFS ) import GHC.Types.Unique ( hasKey ) import GHC.Types.Tickish ( tickishIsCode ) ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -5504,7 +5504,7 @@ suggestAddSig ctxt ty1 _ty2 find [] _ _ = [] find (implic:implics) seen_eqs tv | tv `elem` ic_skols implic - , InferSkol _ prs <- ic_info implic + , InferSkol prs <- ic_info implic , seen_eqs = map fst prs | otherwise @@ -5578,7 +5578,7 @@ ctxtFixes (CEC {cec_encl = implics}) has_ambig_tvs pred , isTyVarClassPred pred -- Don't suggest adding (Eq T) to the context, say , (skol:skols) <- usefulContext implics pred , let what | null skols - , SigSkol _ (PatSynCtxt {}) _ _ <- skol + , SigSkol (PatSynCtxt {}) _ _ <- skol = text "\"required\"" | otherwise = empty @@ -5618,7 +5618,7 @@ usefulContext implics pred | implausible_info (ic_info ic) = True | otherwise = False - implausible_info (SigSkol _ (InfSigCtxt {}) _ _) = True + implausible_info (SigSkol (InfSigCtxt {}) _ _) = True implausible_info _ = False -- Do not suggest adding constraints to an *inferred* type signature @@ -5713,17 +5713,17 @@ tidySkolemInfo env (SkolemInfo u sk_anon) = SkolemInfo u (tidySkolemInfoAnon env ---------------- tidySkolemInfoAnon :: TidyEnv -> SkolemInfoAnon -> SkolemInfoAnon tidySkolemInfoAnon env (DerivSkol ty) = DerivSkol (tidyType env ty) -tidySkolemInfoAnon env (SigSkol st cx ty tv_prs) = tidySigSkol env st cx ty tv_prs -tidySkolemInfoAnon env (InferSkol st ids) = InferSkol st (mapSnd (tidyType env) ids) +tidySkolemInfoAnon env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs +tidySkolemInfoAnon env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids) tidySkolemInfoAnon env (UnifyForAllSkol ty) = UnifyForAllSkol (tidyType env ty) tidySkolemInfoAnon _ info = info -tidySigSkol :: TidyEnv -> StaticFlag -> UserTypeCtxt +tidySigSkol :: TidyEnv -> UserTypeCtxt -> TcType -> [(Name,TcTyVar)] -> SkolemInfoAnon -- We need to take special care when tidying SigSkol -- See Note [SigSkol SkolemInfo] in "GHC.Tc.Types.Origin" -tidySigSkol env st cx ty tv_prs - = SigSkol st cx (tidy_ty env ty) tv_prs' +tidySigSkol env cx ty tv_prs + = SigSkol cx (tidy_ty env ty) tv_prs' where tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs inst_env = mkNameEnv tv_prs' ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -23,7 +23,6 @@ module GHC.Tc.Errors.Types ( , SuggestUnliftedTypes(..) , DataSort(..), ppDataSort , AllowedDataResKind(..) - , NotClosedReason(..) , SuggestPartialTypeSignatures(..) , suggestPartialTypeSignatures , DeriveInstanceErrReason(..) @@ -1829,7 +1828,7 @@ data TcRnMessage where Test cases: rename/should_fail/RnStaticPointersFail01 rename/should_fail/RnStaticPointersFail03 -} - TcRnStaticFormNotClosed :: Name -> NotClosedReason -> TcRnMessage + TcRnStaticFormNotClosed :: Name -> TcRnMessage {-| TcRnUselessTypeable is a warning (controlled by -Wderiving-typeable) that occurs when trying to derive an instance of the 'Typeable' class. Deriving @@ -4627,12 +4626,6 @@ data AllowedDataResKind | AnyBoxedKind | LiftedKind --- | A data type to describe why a variable is not closed. --- See Note [Not-closed error messages] in GHC.Tc.Gen.Expr -data NotClosedReason = NotLetBoundReason - | NotTypeClosed VarSet - | NotClosed Name NotClosedReason - data SuggestPartialTypeSignatures = YesSuggestPartialTypeSignatures | NoSuggestPartialTypeSignatures @@ -5533,8 +5526,8 @@ discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens] | otherwise = givens where - discard n (Implic { ic_info = SigSkol _ (PatSynCtxt n') _ _ }) = n == n' - discard _ _ = False + discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n' + discard _ _ = False -- | An error reported after constraint solving. ===================================== compiler/GHC/Tc/Types.hs ===================================== @@ -45,8 +45,7 @@ module GHC.Tc.Types( TcTypeEnv, TcBinderStack, TcBinder(..), TcTyThing(..), tcTyThingTyCon_maybe, PromotionErr(..), - IdBindingInfo(..), ClosedTypeId, RhsNames, - IsGroupClosed(..), + IdBindingInfo(..), ClosedTypeId, SelfBootInfo(..), bootExports, tcTyThingCategory, pprTcTyThingCategory, peCategory, pprPECategory, ===================================== compiler/GHC/Tc/Types/BasicTypes.hs ===================================== @@ -14,8 +14,6 @@ module GHC.Tc.Types.BasicTypes ( -- * TcTyThing , TcTyThing(..) , IdBindingInfo(..) - , IsGroupClosed(..) - , RhsNames , ClosedTypeId , tcTyThingCategory , tcTyThingTyCon_maybe @@ -33,11 +31,8 @@ import GHC.Types.Var import GHC.Types.SrcLoc import GHC.Types.Name import GHC.Types.TyThing -import GHC.Types.Name.Env -import GHC.Types.Name.Set import GHC.Hs.Extension ( GhcRn ) -import GHC.Hs.Binds ( StaticFlag ) import Language.Haskell.Syntax.Type ( LHsSigWcType ) @@ -505,10 +500,9 @@ in the type environment. -} instance Outputable IdBindingInfo where - ppr NotLetBound = text "NotLetBound" - ppr (LetBound { lb_static = top_lvl, lb_fvs = fvs, lb_closed = cls }) - = text "LetBound" <> braces (sep [ ppr top_lvl, text "closed-type=" <+> ppr cls - , ppr fvs ]) + ppr NotLetBound = text "NotLetBound" + ppr (LetBound cls) = text "LetBound" + <> if cls then text "(closed)" else text "(not-closed)" -------------- pprTcTyThingCategory :: TcTyThing -> SDoc ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -2158,8 +2158,8 @@ checkSkolInfoAnon :: SkolemInfoAnon -- From the implication -- So it doesn't matter much if its's incomplete checkSkolInfoAnon sk1 sk2 = go sk1 sk2 where - go (SigSkol _ c1 t1 s1) (SigSkol _ c2 t2 s2) = c1==c2 && t1 `tcEqType` t2 && s1==s2 - go (InferSkol _ ids1) (InferSkol _ ids2) = equalLength ids1 ids2 && + go (SigSkol c1 t1 s1) (SigSkol c2 t2 s2) = c1==c2 && t1 `tcEqType` t2 && s1==s2 + go (InferSkol ids1) (InferSkol ids2) = equalLength ids1 ids2 && and (zipWith eq_pr ids1 ids2) go (SigTypeSkol cx1) (SigTypeSkol cx2) = cx1==cx2 ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -262,14 +262,12 @@ data SkolemInfoAnon -- a programmer-supplied type signature -- Location of the binding site is on the TyVar -- See Note [SigSkol SkolemInfo] - StaticFlag UserTypeCtxt -- What sort of signature TcType -- Original type signature (before skolemisation) [(Name,TcTyVar)] -- Maps the original name of the skolemised tyvar -- to its instantiated version | InferSkol - StaticFlag [(Name,TcType)] -- We have inferred a type for these (mutually recursive) -- polymorphic Ids, and are now checking that their RHS -- constraints are satisfied. @@ -364,7 +362,7 @@ instance Outputable SkolemInfoAnon where pprSkolInfo :: SkolemInfoAnon -> SDoc -- Complete the sentence "is a rigid type variable bound by..." -pprSkolInfo (SigSkol _ cx ty _) = pprSigSkolInfo cx ty +pprSkolInfo (SigSkol cx ty _) = pprSigSkolInfo cx ty pprSkolInfo (SigTypeSkol cx) = pprUserTypeCtxt cx pprSkolInfo (ForAllSkol tvs) = text "an explicit forall" <+> ppr tvs pprSkolInfo (IPSkol ips) = text "the implicit-parameter binding" <> plural ips <+> text "for" @@ -382,7 +380,7 @@ pprSkolInfo (RuleSkol name) = text "the RULE" <+> pprRuleName name pprSkolInfo (SpecESkol name) = text "a SPECIALISE pragma for" <+> quotes (ppr name) pprSkolInfo (PatSkol cl mc) = sep [ pprPatSkolInfo cl , text "in" <+> pprMatchContext mc ] -pprSkolInfo (InferSkol _ ids) = hang (text "the inferred type" <> plural ids <+> text "of") +pprSkolInfo (InferSkol ids) = hang (text "the inferred type" <> plural ids <+> text "of") 2 (vcat [ ppr name <+> dcolon <+> ppr ty | (name,ty) <- ids ]) pprSkolInfo (UnifyForAllSkol ty) = text "the type" <+> ppr ty @@ -462,10 +460,8 @@ in the right place. So we proceed as follows: -} isStaticSkolInfo :: SkolemInfoAnon -> Bool -isStaticSkolInfo StaticFormSkol = True -isStaticSkolInfo (SigSkol IsStatic _ _ _) = True -isStaticSkolInfo (InferSkol IsStatic _) = True -isStaticSkolInfo _ = False +isStaticSkolInfo StaticFormSkol = True +isStaticSkolInfo _ = False {- ********************************************************************* ===================================== compiler/GHC/Tc/Utils/Env.hs ===================================== @@ -116,7 +116,7 @@ import GHC.Utils.Misc ( HasDebugCallStack ) import GHC.Data.FastString import GHC.Data.List.SetOps -import GHC.Data.Maybe( MaybeErr(..), orElse, maybeToList, fromMaybe ) +import GHC.Data.Maybe( MaybeErr(..), maybeToList, fromMaybe ) import GHC.Types.SrcLoc import GHC.Types.Basic hiding( SuccessFlag(..) ) @@ -671,12 +671,12 @@ tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a -- Does not extend the TcBinderStack tcExtendRecIds pairs thing_inside = tc_extend_local_env NotTopLevel - [ (name, ATcId { tct_id = let_id - , tct_info = LetBound { lb_static = NotStatic - , lb_fvs = emptyNameSet - , lb_closed = False } }) + [ (name, ATcId { tct_id = let_id, tct_info = info }) | (name, let_id) <- pairs ] $ thing_inside + where + is_closed = False + info = LetBound is_closed tcExtendSigIds :: TopLevelFlag -> [TcId] -> TcM a -> TcM a -- Used for binding the Ids that have a complete user type signature @@ -688,32 +688,22 @@ tcExtendSigIds top_lvl sig_ids thing_inside , tct_info = info }) | id <- sig_ids , let closed = isTypeClosedLetBndr id - info = LetBound { lb_static = NotStatic - , lb_fvs = emptyNameSet - , lb_closed = closed } ] + info = LetBound closed ] thing_inside -tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed +tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> ClosedTypeId -> [Scaled TcId] -> TcM a -> TcM a -- Used for both top-level value bindings and nested let/where-bindings -- Used for a single NonRec or a single Rec -- Adds to the TcBinderStack too -tcExtendLetEnv top_lvl _sig_fn - (IsGroupClosed {gc_static = group_static, gc_fvs = fv_env}) - ids thing_inside +tcExtendLetEnv top_lvl _sig_fn closed ids thing_inside = tcExtendBinderStack [TcIdBndr id top_lvl | Scaled _ id <- ids] $ tc_extend_local_env top_lvl - [ (idName id, ATcId { tct_id = id - , tct_info = mk_tct_info id }) + [ (idName id, ATcId { tct_id = id, tct_info = LetBound closed }) | Scaled _ id <- ids ] $ foldr tcCheckUsage thing_inside ids - where - mk_tct_info id - = LetBound { lb_static = group_static - , lb_fvs = lookupNameEnv fv_env (idName id) `orElse` emptyNameSet - , lb_closed = isTypeClosedLetBndr id } tcExtendIdEnv :: [TcId] -> TcM a -> TcM a -- For lambda-bound and case-bound Ids ===================================== compiler/GHC/Tc/Zonk/TcType.hs ===================================== @@ -521,10 +521,10 @@ zonkSkolemInfo :: SkolemInfo -> ZonkM SkolemInfo zonkSkolemInfo (SkolemInfo u sk) = SkolemInfo u <$> zonkSkolemInfoAnon sk zonkSkolemInfoAnon :: SkolemInfoAnon -> ZonkM SkolemInfoAnon -zonkSkolemInfoAnon (SigSkol st cx ty tv_prs) = do { ty' <- zonkTcType ty - ; return (SigSkol st cx ty' tv_prs) } -zonkSkolemInfoAnon (InferSkol st ntys) = do { ntys' <- mapM do_one ntys - ; return (InferSkol st ntys') } +zonkSkolemInfoAnon (SigSkol cx ty tv_prs) = do { ty' <- zonkTcType ty + ; return (SigSkol cx ty' tv_prs) } +zonkSkolemInfoAnon (InferSkol ntys) = do { ntys' <- mapM do_one ntys + ; return (InferSkol ntys') } where do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') } zonkSkolemInfoAnon skol_info = return skol_info ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -681,7 +681,7 @@ zonkLocalBinds (HsValBinds x (XValBindsLR (HsVBG binds sigs))) = do { new_binds <- mapM go binds ; return (HsValBinds x (XValBindsLR (HsVBG new_binds sigs))) } where - go (r,b,s) = do { b' <- zonkRecMonoBinds b; return (r,b',s) } + go (r,b) = do { b' <- zonkRecMonoBinds b; return (r,b') } zonkLocalBinds (HsIPBinds x (IPBinds dict_binds binds )) = do new_binds <- noBinders $ mapM (wrapLocZonkMA zonk_ip_bind) binds View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7e9b196e2be4342022dbefa801287506... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7e9b196e2be4342022dbefa801287506... You're receiving this email because of your account on gitlab.haskell.org.