[Git][ghc/ghc][wip/T21623-faster] Better implementation of typeKind
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Sat Nov 12 23:07:43 UTC 2022
Simon Peyton Jones pushed to branch wip/T21623-faster at Glasgow Haskell Compiler / GHC
Commits:
5bf6af99 by Simon Peyton Jones at 2022-11-12T23:07:02+00:00
Better implementation of typeKind
- - - - -
5 changed files:
- + compiler/GHC/Core/TyCo/FVs.hs-boot
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/Utils/TcType.hs
Changes:
=====================================
compiler/GHC/Core/TyCo/FVs.hs-boot
=====================================
@@ -0,0 +1,6 @@
+module GHC.Core.TyCo.FVs where
+
+import GHC.Prelude ( Bool )
+import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type )
+
+noFreeVarsOfType :: Type -> Bool
=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -105,6 +105,7 @@ module GHC.Core.TyCon(
tyConPromDataConInfo,
tyConBinders, tyConResKind, tyConInvisTVBinders,
tcTyConScopedTyVars, tcTyConIsPoly,
+ tyConHasClosedResKind, tyConTypeKindPieces,
mkTyConTagMap,
-- ** Manipulating TyCons
@@ -138,6 +139,8 @@ import GHC.Platform
import {-# SOURCE #-} GHC.Core.TyCo.Rep
( Kind, Type, PredType, mkForAllTy, mkNakedKindFunTy, mkNakedTyConTy )
+import {-# SOURCE #-} GHC.Core.TyCo.FVs
+ ( noFreeVarsOfType )
import {-# SOURCE #-} GHC.Core.TyCo.Ppr
( pprType )
import {-# SOURCE #-} GHC.Builtin.Types
@@ -803,6 +806,7 @@ data TyCon =
tyConKind :: Kind, -- ^ Kind of this TyCon
tyConArity :: Arity, -- ^ Arity
tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@
+ tyConHasClosedResKind :: Bool,
-- The tyConTyVars scope over:
--
@@ -864,6 +868,7 @@ data TyCon =
tyConKind :: Kind, -- ^ Kind of this TyCon
tyConArity :: Arity, -- ^ Arity
tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@
+ tyConHasClosedResKind :: Bool,
-- tyConTyVars scope over: synTcRhs
tcRoles :: [Role], -- ^ The role for each type variable
@@ -903,6 +908,7 @@ data TyCon =
tyConKind :: Kind, -- ^ Kind of this TyCon
tyConArity :: Arity, -- ^ Arity
tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@
+ tyConHasClosedResKind :: Bool,
-- tyConTyVars connect an associated family TyCon
-- with its parent class; see GHC.Tc.Validity.checkConsistentFamInst
@@ -940,6 +946,7 @@ data TyCon =
tyConKind :: Kind, -- ^ Kind of this TyCon
tyConArity :: Arity, -- ^ Arity
tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@
+ tyConHasClosedResKind :: Bool,
tcRoles :: [Role], -- ^ The role for each type variable
-- This list has length = tyConArity
@@ -962,6 +969,7 @@ data TyCon =
tyConKind :: Kind, -- ^ Kind of this TyCon
tyConArity :: Arity, -- ^ Arity
tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@
+ tyConHasClosedResKind :: Bool,
tcRoles :: [Role], -- ^ Roles: N for kind vars, R for type vars
dataCon :: DataCon, -- ^ Corresponding data constructor
@@ -982,6 +990,7 @@ data TyCon =
tyConKind :: Kind, -- ^ Kind of this TyCon
tyConArity :: Arity, -- ^ Arity
tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@
+ tyConHasClosedResKind :: Bool,
-- NB: the tyConArity of a TcTyCon must match
-- the number of Required (positional, user-specified)
@@ -994,7 +1003,10 @@ data TyCon =
-- MonoTcTyCon only: see Note [Scoped tyvars in a TcTyCon]
tcTyConIsPoly :: Bool, -- ^ Is this TcTyCon already generalized?
- -- Used only to make zonking more efficient
+ -- True for PolyTcTyCon, False for MonoTcTyCon
+ -- Used only to make zonking more efficient
+ -- See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in
+ -- GHC.Tc.Utils.TcType
tcTyConFlavour :: TyConFlavour
-- ^ What sort of 'TyCon' this represents.
@@ -1043,7 +1055,7 @@ to know, given a TyCon 'T' of arity 'n', does
always have a fixed RuntimeRep? That is, is it always the case
that this application has a kind of the form
-
+v
T a_1 ... a_n :: TYPE rep
in which 'rep' is a concrete 'RuntimeRep'?
@@ -1856,6 +1868,7 @@ mkAlgTyCon name binders res_kind roles cType stupid rhs parent gadt_syn
tyConKind = mkTyConKind binders res_kind,
tyConArity = length binders,
tyConNullaryTy = mkNakedTyConTy tc,
+ tyConHasClosedResKind = noFreeVarsOfType res_kind,
tyConTyVars = binderVars binders,
tcRoles = roles,
tyConCType = cType,
@@ -1895,6 +1908,7 @@ mkTupleTyCon name binders res_kind arity con sort parent
tyConKind = mkTyConKind binders res_kind,
tyConArity = arity,
tyConNullaryTy = mkNakedTyConTy tc,
+ tyConHasClosedResKind = noFreeVarsOfType res_kind,
tcRoles = replicate arity Representational,
tyConCType = Nothing,
algTcGadtSyntax = False,
@@ -1925,6 +1939,7 @@ mkSumTyCon name binders res_kind arity tyvars cons parent
tyConKind = mkTyConKind binders res_kind,
tyConArity = arity,
tyConNullaryTy = mkNakedTyConTy tc,
+ tyConHasClosedResKind = noFreeVarsOfType res_kind,
tcRoles = replicate arity Representational,
tyConCType = Nothing,
algTcGadtSyntax = False,
@@ -1960,6 +1975,7 @@ mkTcTyCon name binders res_kind scoped_tvs poly flav
, tyConKind = mkTyConKind binders res_kind
, tyConArity = length binders
, tyConNullaryTy = mkNakedTyConTy tc
+ , tyConHasClosedResKind = noFreeVarsOfType res_kind
, tcTyConScopedTyVars = scoped_tvs
, tcTyConIsPoly = poly
, tcTyConFlavour = flav }
@@ -1989,6 +2005,7 @@ mkPrimTyCon name binders res_kind roles
tyConKind = mkTyConKind binders res_kind,
tyConArity = length roles,
tyConNullaryTy = mkNakedTyConTy tc,
+ tyConHasClosedResKind = noFreeVarsOfType res_kind,
tcRoles = roles,
primRepName = mkPrelTyConRepName name
}
@@ -2007,6 +2024,7 @@ mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free is_forgetful
tyConKind = mkTyConKind binders res_kind,
tyConArity = length binders,
tyConNullaryTy = mkNakedTyConTy tc,
+ tyConHasClosedResKind = noFreeVarsOfType res_kind,
tyConTyVars = binderVars binders,
tcRoles = roles,
synTcRhs = rhs,
@@ -2030,6 +2048,7 @@ mkFamilyTyCon name binders res_kind resVar flav parent inj
, tyConKind = mkTyConKind binders res_kind
, tyConArity = length binders
, tyConNullaryTy = mkNakedTyConTy tc
+ , tyConHasClosedResKind = noFreeVarsOfType res_kind
, tyConTyVars = binderVars binders
, famTcResVar = resVar
, famTcFlav = flav
@@ -2053,6 +2072,7 @@ mkPromotedDataCon con name rep_name binders res_kind roles rep_info
tyConName = name,
tyConArity = length roles,
tyConNullaryTy = mkNakedTyConTy tc,
+ tyConHasClosedResKind = noFreeVarsOfType res_kind,
tcRoles = roles,
tyConBinders = binders,
tyConResKind = res_kind,
@@ -2435,6 +2455,16 @@ isTcTyCon :: TyCon -> Bool
isTcTyCon (TcTyCon {}) = True
isTcTyCon _ = False
+tyConTypeKindPieces :: TyCon -> ([TyConBinder], Kind, Bool)
+-- This rather specialised function returns the bits needed for typeKind
+tyConTypeKindPieces tc
+ | TcTyCon { tyConKind = kind, tcTyConIsPoly = False } <- tc
+ = -- For MonoTcTyCons we must use the tyConKind
+ -- because only that is zonked. See setTcTyConKind
+ ([], kind, False)
+ | otherwise
+ = (tyConBinders tc, tyConResKind tc, tyConHasClosedResKind tc)
+
setTcTyConKind :: TyCon -> Kind -> TyCon
-- Update the Kind of a TcTyCon
-- The new kind is always a zonked version of its previous
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -1444,7 +1444,7 @@ piResultTys ty orig_args@(arg:args)
= piResultTys res args
| ForAllTy (Bndr tv _) res <- ty
- = go (extendTCvSubst init_subst tv arg) res args
+ = piResultTysX (extendTCvSubst init_subst tv arg) res args
| Just ty' <- coreView ty
= piResultTys ty' orig_args
@@ -1454,31 +1454,57 @@ piResultTys ty orig_args@(arg:args)
where
init_subst = mkEmptySubst $ mkInScopeSet (tyCoVarsOfTypes (ty:orig_args))
- go :: Subst -> Type -> [Type] -> Type
- go subst ty [] = substTyUnchecked subst ty
-
- go subst ty all_args@(arg:args)
- | FunTy { ft_res = res } <- ty
- = go subst res args
+piResultTysX :: Subst -> Type -> [Type] -> Type
+piResultTysX subst ty [] = substTy subst ty
+piResultTysX subst ty all_args@(arg:args)
+ | FunTy { ft_res = res } <- ty
+ = piResultTysX subst res args
- | ForAllTy (Bndr tv _) res <- ty
- = go (extendTCvSubst subst tv arg) res args
+ | ForAllTy (Bndr tv _) res <- ty
+ = piResultTysX (extendTCvSubst subst tv arg) res args
- | Just ty' <- coreView ty
- = go subst ty' all_args
+ | Just ty' <- coreView ty
+ = piResultTysX subst ty' all_args
- | not (isEmptyTCvSubst subst) -- See Note [Care with kind instantiation]
- = go init_subst
- (substTy subst ty)
- all_args
+ | not (isEmptyTCvSubst subst) -- See Note [Care with kind instantiation]
+ = piResultTysX (zapSubst subst) (substTy subst ty) all_args
- | otherwise
- = -- We have not run out of arguments, but the function doesn't
- -- have the right kind to apply to them; so panic.
- -- Without the explicit isEmptyVarEnv test, an ill-kinded type
- -- would give an infinite loop, which is very unhelpful
- -- c.f. #15473
- pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args)
+ | otherwise
+ = -- We have not run out of arguments, but the function doesn't
+ -- have the right kind to apply to them; so panic.
+ -- Without the explicit isEmptyTCvSubst test, an ill-kinded type
+ -- would give an infinite loop, which is very unhelpful
+ -- c.f. #15473
+ pprPanic "piResultTys2" (ppr ty $$ ppr all_args)
+
+tyConAppResKind :: TyCon -> [Type] -> Kind
+-- This is a hot function, so we give it special code.
+-- Its specification is:
+-- tyConAppResKind tc tys = piResultTys (tyConKind tc) tys
+tyConAppResKind tc args
+ | null args = tyConKind tc
+ | otherwise
+ = go1 tc_bndrs args
+ where
+ !(tc_bndrs, tc_res_kind, closed_res_kind) = tyConTypeKindPieces tc
+ init_subst = mkEmptySubst $ mkInScopeSet (tyCoVarsOfTypes args)
+
+ go1 :: [TyConBinder] -> [Type] -> Type
+ go1 [] [] = tc_res_kind
+ go1 [] args = piResultTys tc_res_kind args
+ go1 bndrs [] = mkTyConKind bndrs tc_res_kind
+ go1 (Bndr tv vis : bndrs) (arg:args)
+ | AnonTCB {} <- vis = go1 bndrs args
+ | NamedTCB {} <- vis = go2 (extendTCvSubst init_subst tv arg) bndrs args
+
+ go2 :: Subst -> [TyConBinder] -> [Type] -> Type
+ go2 subst [] [] | closed_res_kind = tc_res_kind
+ | otherwise = substTy subst tc_res_kind
+ go2 subst [] args = piResultTysX subst tc_res_kind args
+ go2 subst bndrs [] = substTy subst (mkTyConKind bndrs tc_res_kind)
+ go2 subst (Bndr tv vis : bndrs) (arg:args)
+ | AnonTCB {} <- vis = go2 subst bndrs args
+ | NamedTCB {} <- vis = go2 (extendTCvSubst subst tv arg) bndrs args
applyTysX :: [TyVar] -> Type -> [Type] -> Type
-- applyTysX beta-reduces (/\tvs. body_ty) arg_tys
@@ -2550,7 +2576,7 @@ See #14939.
-----------------------------
typeKind :: HasDebugCallStack => Type -> Kind
-- No need to expand synonyms
-typeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys
+typeKind (TyConApp tc tys) = tyConAppResKind tc tys
typeKind (LitTy l) = typeLiteralKind l
typeKind (FunTy { ft_af = af }) = case funTyFlagResultTypeOrConstraint af of
TypeLike -> liftedTypeKind
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -400,6 +400,8 @@ See also Note [Kind checking recursive type and class declarations]
Note [How TcTyCons work]
~~~~~~~~~~~~~~~~~~~~~~~~
+See also Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.Utils.TcType
+
TcTyCons are used for two distinct purposes
1. When recovering from a type error in a type declaration,
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -396,7 +396,7 @@ type TcTyCoVarSet = TyCoVarSet
type TcDTyVarSet = DTyVarSet
type TcDTyCoVarSet = DTyCoVarSet
-{- Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon]
+{- Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon]o
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See Note [How TcTyCons work] in GHC.Tc.TyCl
@@ -425,6 +425,11 @@ Invariants:
and so allows up to distinguish between the Specified and Required elements of
tyConScopedTyVars.
+ - When zonking (which is necesary because, uniquely, MonoTcTyCons have unification
+ variables), we set tyConKind, but leave the binders and tyConResKind un-zonked.
+ See GHC.Core.TyCon.setTcTyConKind.
+
+
* PolyTcTyCon:
- Flag tcTyConIsPoly = True; this is used only to short-cut zonking
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5bf6af995037edf53457a134e951765de4a46e8b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5bf6af995037edf53457a134e951765de4a46e8b
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221112/dfb8889f/attachment-0001.html>
More information about the ghc-commits
mailing list