diff options
author | Ben Gamari <ben@smart-cactus.org> | 2021-01-07 17:39:03 -0500 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-02-18 13:47:32 -0500 |
commit | b5db34576d9b659366b2790ef98e08a854721ef5 (patch) | |
tree | e541317afe56d6b944276fdffe762ba96343bdc4 | |
parent | 4dc2bcca2e0576512ad55e20651eb9e18e2a0da4 (diff) | |
download | haskell-b5db34576d9b659366b2790ef98e08a854721ef5.tar.gz |
Extend nullary TyConApp optimisation to all TyCons
See Note [Sharing nullary TyConApps] in GHC.Core.TyCon.
Closes #19367.
Metric Decrease:
T9872a
T9872b
T9872c
-rw-r--r-- | compiler/GHC/Builtin/Types.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Builtin/Types/Prim.hs | 1 | ||||
-rw-r--r-- | compiler/GHC/Core/TyCo/Rep.hs | 60 | ||||
-rw-r--r-- | compiler/GHC/Core/TyCo/Rep.hs-boot | 2 | ||||
-rw-r--r-- | compiler/GHC/Core/TyCo/Subst.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Core/TyCon.hs | 293 | ||||
-rw-r--r-- | compiler/GHC/Core/Type.hs | 28 | ||||
-rw-r--r-- | compiler/GHC/Core/Type.hs-boot | 2 |
8 files changed, 218 insertions, 174 deletions
diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs index 9957e0bed7..924ce6648d 100644 --- a/compiler/GHC/Builtin/Types.hs +++ b/compiler/GHC/Builtin/Types.hs @@ -692,9 +692,9 @@ constraintKindTyCon = pcTyCon constraintKindTyConName Nothing [] [] -- See Note [Prefer Type over TYPE 'LiftedRep] in GHC.Core.TyCo.Rep. liftedTypeKind, typeToTypeKind, constraintKind :: Kind -liftedTypeKind = TyCoRep.TyConApp liftedTypeKindTyCon [] +liftedTypeKind = mkTyConTy liftedTypeKindTyCon typeToTypeKind = liftedTypeKind `mkVisFunTyMany` liftedTypeKind -constraintKind = mkTyConApp constraintKindTyCon [] +constraintKind = mkTyConTy constraintKindTyCon {- ************************************************************************ diff --git a/compiler/GHC/Builtin/Types/Prim.hs b/compiler/GHC/Builtin/Types/Prim.hs index 61f341a0bb..89093a2350 100644 --- a/compiler/GHC/Builtin/Types/Prim.hs +++ b/compiler/GHC/Builtin/Types/Prim.hs @@ -126,6 +126,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Core.TyCo.Rep -- Doesn't need special access, but this is easier to avoid -- import loops which show up if you import Type instead +import {-# SOURCE #-} GHC.Core.Type ( mkTyConTy ) import Data.Char diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs index 7414bc18da..2d9867e427 100644 --- a/compiler/GHC/Core/TyCo/Rep.hs +++ b/compiler/GHC/Core/TyCo/Rep.hs @@ -42,7 +42,7 @@ module GHC.Core.TyCo.Rep ( MCoercion(..), MCoercionR, MCoercionN, -- * Functions over types - mkTyConTy, mkTyVarTy, mkTyVarTys, + mkTyConTy_, mkTyVarTy, mkTyVarTys, mkTyCoVarTy, mkTyCoVarTys, mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkForAllTy, mkForAllTys, mkInvisForAllTys, @@ -51,7 +51,6 @@ module GHC.Core.TyCo.Rep ( mkScaledFunTy, mkVisFunTyMany, mkVisFunTysMany, mkInvisFunTyMany, mkInvisFunTysMany, - mkTyConApp, tYPE, -- * Functions over binders @@ -91,8 +90,8 @@ import GHC.Core.TyCon import GHC.Core.Coercion.Axiom -- others -import GHC.Builtin.Names ( liftedTypeKindTyConKey, liftedRepDataConKey, manyDataConKey, tYPETyConKey ) -import {-# SOURCE #-} GHC.Builtin.Types ( liftedTypeKindTyCon, liftedTypeKind, manyDataConTy ) +import GHC.Builtin.Names ( liftedRepDataConKey ) +import {-# SOURCE #-} GHC.Builtin.Types ( liftedTypeKind, manyDataConTy ) import {-# SOURCE #-} GHC.Builtin.Types.Prim ( tYPETyCon ) import GHC.Types.Basic ( LeftOrRight(..), pickLR ) import GHC.Types.Unique ( hasKey, Uniquable(..) ) @@ -1004,35 +1003,11 @@ mkPiTy (Named (Bndr tv vis)) ty = mkForAllTy tv vis ty mkPiTys :: [TyCoBinder] -> Type -> Type mkPiTys tbs ty = foldr mkPiTy ty tbs --- | Create the plain type constructor type which has been applied to no type arguments at all. -mkTyConTy :: TyCon -> Type -mkTyConTy tycon = TyConApp tycon [] - --- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to --- its arguments. Applies its arguments to the constructor from left to right. -mkTyConApp :: TyCon -> [Type] -> Type -mkTyConApp tycon tys - | isFunTyCon tycon - , [w, _rep1,_rep2,ty1,ty2] <- tys - -- The FunTyCon (->) is always a visible one - = FunTy { ft_af = VisArg, ft_mult = w, ft_arg = ty1, ft_res = ty2 } - - -- See Note [Prefer Type over TYPE 'LiftedRep] - | tycon `hasKey` liftedTypeKindTyConKey - = ASSERT2( null tys, ppr tycon $$ ppr tys ) - liftedTypeKindTyConApp - | tycon `hasKey` manyDataConKey - -- There are a lot of occurrences of 'Many' so it's a small optimisation to - -- avoid reboxing every time `mkTyConApp` is called. - = ASSERT2( null tys, ppr tycon $$ ppr tys ) - manyDataConTy - -- See Note [Prefer Type over TYPE 'LiftedRep]. - | tycon `hasKey` tYPETyConKey - , [rep] <- tys - = tYPE rep - -- The catch-all case - | otherwise - = TyConApp tycon tys +-- | Create a nullary 'TyConApp'. In general you should rather use +-- 'GHC.Core.Type.mkTyConTy'. This merely exists to break the import cycle +-- between 'GHC.Core.TyCon' and this module. +mkTyConTy_ :: TyCon -> Type +mkTyConTy_ tycon = TyConApp tycon [] {- Note [Prefer Type over TYPE 'LiftedRep] @@ -1079,16 +1054,9 @@ To accomplish these we use a number of tricks: (namely 'GHC.Builtin.Types.Prim.liftedTypeKind'), ensuring that we don't need to allocate such types (goal (a)). - 3. To avoid allocating 'TyConApp' constructors the - 'GHC.Builtin.Types.Prim.tYPE' function catches the lifted case and returns - `liftedTypeKind` instead of building an application (goal (a)). - - 4. Similarly, 'Type.mkTyConApp' catches applications of `TYPE` and - handles them using 'GHC.Builtin.Types.Prim.tYPE', ensuring - that it benefits from the optimisation described above (goal (a)). - -Note that it's quite important that we do not define 'liftedTypeKind' in terms -of 'mkTyConApp' since this tricks (1) and (4) would then result in a loop. + 3. We use the sharing mechanism described in Note [Sharing nullary TyConApps] + in GHC.Core.TyCon to ensure that we never need to allocate such + nullary applications (goal (a)). See #17958. -} @@ -1101,12 +1069,6 @@ tYPE (TyConApp tc []) | tc `hasKey` liftedRepDataConKey = liftedTypeKind -- TYPE 'LiftedRep tYPE rr = TyConApp tYPETyCon [rr] --- This is a single, global definition of the type `Type` --- Defined here so it is only allocated once. --- See Note [Prefer Type over TYPE 'LiftedRep] in this module. -liftedTypeKindTyConApp :: Type -liftedTypeKindTyConApp = TyConApp liftedTypeKindTyCon [] - {- %************************************************************************ %* * diff --git a/compiler/GHC/Core/TyCo/Rep.hs-boot b/compiler/GHC/Core/TyCo/Rep.hs-boot index cb675327b7..614a596bbe 100644 --- a/compiler/GHC/Core/TyCo/Rep.hs-boot +++ b/compiler/GHC/Core/TyCo/Rep.hs-boot @@ -3,6 +3,7 @@ module GHC.Core.TyCo.Rep where import GHC.Utils.Outputable ( Outputable ) import Data.Data ( Data ) import {-# SOURCE #-} GHC.Types.Var( Var, ArgFlag, AnonArgFlag ) +import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) data Type data Coercion @@ -22,6 +23,7 @@ type MCoercionN = MCoercion mkFunTyMany :: AnonArgFlag -> Type -> Type -> Type mkForAllTy :: Var -> ArgFlag -> Type -> Type +mkTyConTy_ :: TyCon -> Type instance Data Type -- To support Data instances in GHC.Core.Coercion.Axiom instance Outputable Type diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs index 7ea61bdae2..6394879e8c 100644 --- a/compiler/GHC/Core/TyCo/Subst.hs +++ b/compiler/GHC/Core/TyCo/Subst.hs @@ -57,7 +57,7 @@ module GHC.Core.TyCo.Subst import GHC.Prelude import {-# SOURCE #-} GHC.Core.Type - ( mkCastTy, mkAppTy, isCoercionTy ) + ( mkCastTy, mkAppTy, isCoercionTy, mkTyConApp ) import {-# SOURCE #-} GHC.Core.Coercion ( mkCoVarCo, mkKindCo, mkNthCo, mkTransCo , mkNomReflCo, mkSubCo, mkSymCo diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index 2684a4d6d4..babcbce347 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -88,6 +88,7 @@ module GHC.Core.TyCon( tyConFamilySize, tyConStupidTheta, tyConArity, + tyConNullaryTy, tyConRoles, tyConFlavour, tyConTuple_maybe, tyConClass_maybe, tyConATs, @@ -135,7 +136,7 @@ import GHC.Prelude import GHC.Platform import {-# SOURCE #-} GHC.Core.TyCo.Rep - ( Kind, Type, PredType, mkForAllTy, mkFunTyMany ) + ( Kind, Type, PredType, mkForAllTy, mkFunTyMany, mkTyConTy_ ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType ) import {-# SOURCE #-} GHC.Builtin.Types @@ -417,6 +418,20 @@ See also: * [Verifying injectivity annotation] in GHC.Core.FamInstEnv * [Type inference for type families with injectivity] in GHC.Tc.Solver.Interact +Note [Sharing nullary TyConApps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Nullary type constructor applications are extremely common. For this reason +each TyCon carries with it a @TyConApp tycon []@. This ensures that +'mkTyConTy' does not need to allocate and eliminates quite a bit of heap +residency. Furthermore, we use 'mkTyConTy' in the nullary case of 'mkTyConApp', +ensuring that this function also benefits from sharing. + +This optimisation improves allocations in the Cabal test by around 0.3% and +decreased cache misses measurably. + +See #19367. + + ************************************************************************ * * TyConBinder, TyConTyCoBinder @@ -718,6 +733,7 @@ data TyCon tyConResKind :: Kind, -- ^ Result kind tyConKind :: Kind, -- ^ Kind of this TyCon tyConArity :: Arity, -- ^ Arity + tyConNullaryTy :: Type, tcRepName :: TyConRepName } @@ -748,6 +764,7 @@ data TyCon tyConResKind :: Kind, -- ^ Result kind tyConKind :: Kind, -- ^ Kind of this TyCon tyConArity :: Arity, -- ^ Arity + tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@ -- The tyConTyVars scope over: -- @@ -805,6 +822,7 @@ data TyCon tyConResKind :: Kind, -- ^ Result kind tyConKind :: Kind, -- ^ Kind of this TyCon tyConArity :: Arity, -- ^ Arity + tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@ -- tyConTyVars scope over: synTcRhs tcRoles :: [Role], -- ^ The role for each type variable @@ -843,6 +861,7 @@ data TyCon tyConResKind :: Kind, -- ^ Result kind tyConKind :: Kind, -- ^ Kind of this TyCon tyConArity :: Arity, -- ^ Arity + tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@ -- tyConTyVars connect an associated family TyCon -- with its parent class; see GHC.Tc.Validity.checkConsistentFamInst @@ -879,6 +898,7 @@ data TyCon tyConResKind :: Kind, -- ^ Result kind tyConKind :: Kind, -- ^ Kind of this TyCon tyConArity :: Arity, -- ^ Arity + tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@ tcRoles :: [Role], -- ^ The role for each type variable -- This list has length = tyConArity @@ -904,6 +924,7 @@ data TyCon tyConResKind :: Kind, -- ^ Result kind tyConKind :: Kind, -- ^ Kind of this TyCon tyConArity :: Arity, -- ^ Arity + tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@ tcRoles :: [Role], -- ^ Roles: N for kind vars, R for type vars dataCon :: DataCon, -- ^ Corresponding data constructor @@ -923,6 +944,7 @@ data TyCon tyConResKind :: Kind, -- ^ Result kind tyConKind :: Kind, -- ^ Kind of this TyCon tyConArity :: Arity, -- ^ Arity + tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@ -- NB: the TyConArity of a TcTyCon must match -- the number of Required (positional, user-specified) @@ -1602,15 +1624,18 @@ So we compromise, and move their Kind calculation to the call site. -- this functionality mkFunTyCon :: Name -> [TyConBinder] -> Name -> TyCon mkFunTyCon name binders rep_nm - = FunTyCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConBinders = binders, - tyConResKind = liftedTypeKind, - tyConKind = mkTyConKind binders liftedTypeKind, - tyConArity = length binders, - tcRepName = rep_nm - } + = let tc = + FunTyCon { + tyConUnique = nameUnique name, + tyConName = name, + tyConBinders = binders, + tyConResKind = liftedTypeKind, + tyConKind = mkTyConKind binders liftedTypeKind, + tyConArity = length binders, + tyConNullaryTy = mkTyConTy_ tc, + tcRepName = rep_nm + } + in tc -- | This is the making of an algebraic 'TyCon'. mkAlgTyCon :: Name @@ -1626,22 +1651,25 @@ mkAlgTyCon :: Name -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? -> TyCon mkAlgTyCon name binders res_kind roles cType stupid rhs parent gadt_syn - = AlgTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConBinders = binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = length binders, - tyConTyVars = binderVars binders, - tcRoles = roles, - tyConCType = cType, - algTcStupidTheta = stupid, - algTcRhs = rhs, - algTcFields = fieldsOfAlgTcRhs rhs, - algTcParent = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent, - algTcGadtSyntax = gadt_syn - } + = let tc = + AlgTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tyConBinders = binders, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = length binders, + tyConNullaryTy = mkTyConTy_ tc, + tyConTyVars = binderVars binders, + tcRoles = roles, + tyConCType = cType, + algTcStupidTheta = stupid, + algTcRhs = rhs, + algTcFields = fieldsOfAlgTcRhs rhs, + algTcParent = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent, + algTcGadtSyntax = gadt_syn + } + in tc -- | Simpler specialization of 'mkAlgTyCon' for classes mkClassTyCon :: Name -> [TyConBinder] @@ -1661,23 +1689,26 @@ mkTupleTyCon :: Name -> AlgTyConFlav -> TyCon mkTupleTyCon name binders res_kind arity con sort parent - = AlgTyCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConBinders = binders, - tyConTyVars = binderVars binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = arity, - tcRoles = replicate arity Representational, - tyConCType = Nothing, - algTcGadtSyntax = False, - algTcStupidTheta = [], - algTcRhs = TupleTyCon { data_con = con, - tup_sort = sort }, - algTcFields = emptyDFsEnv, - algTcParent = parent - } + = let tc = + AlgTyCon { + tyConUnique = nameUnique name, + tyConName = name, + tyConBinders = binders, + tyConTyVars = binderVars binders, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = arity, + tyConNullaryTy = mkTyConTy_ tc, + tcRoles = replicate arity Representational, + tyConCType = Nothing, + algTcGadtSyntax = False, + algTcStupidTheta = [], + algTcRhs = TupleTyCon { data_con = con, + tup_sort = sort }, + algTcFields = emptyDFsEnv, + algTcParent = parent + } + in tc mkSumTyCon :: Name -> [TyConBinder] @@ -1688,22 +1719,25 @@ mkSumTyCon :: Name -> AlgTyConFlav -> TyCon mkSumTyCon name binders res_kind arity tyvars cons parent - = AlgTyCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConBinders = binders, - tyConTyVars = tyvars, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = arity, - tcRoles = replicate arity Representational, - tyConCType = Nothing, - algTcGadtSyntax = False, - algTcStupidTheta = [], - algTcRhs = mkSumTyConRhs cons, - algTcFields = emptyDFsEnv, - algTcParent = parent - } + = let tc = + AlgTyCon { + tyConUnique = nameUnique name, + tyConName = name, + tyConBinders = binders, + tyConTyVars = tyvars, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = arity, + tyConNullaryTy = mkTyConTy_ tc, + tcRoles = replicate arity Representational, + tyConCType = Nothing, + algTcGadtSyntax = False, + algTcStupidTheta = [], + algTcRhs = mkSumTyConRhs cons, + algTcFields = emptyDFsEnv, + algTcParent = parent + } + in tc -- | Makes a tycon suitable for use during type-checking. It stores -- a variety of details about the definition of the TyCon, but no @@ -1721,16 +1755,19 @@ mkTcTyCon :: Name -> TyConFlavour -- ^ What sort of 'TyCon' this represents -> TyCon mkTcTyCon name binders res_kind scoped_tvs poly flav - = TcTyCon { tyConUnique = getUnique name - , tyConName = name - , tyConTyVars = binderVars binders - , tyConBinders = binders - , tyConResKind = res_kind - , tyConKind = mkTyConKind binders res_kind - , tyConArity = length binders - , tcTyConScopedTyVars = scoped_tvs - , tcTyConIsPoly = poly - , tcTyConFlavour = flav } + = let tc = + TcTyCon { tyConUnique = getUnique name + , tyConName = name + , tyConTyVars = binderVars binders + , tyConBinders = binders + , tyConResKind = res_kind + , tyConKind = mkTyConKind binders res_kind + , tyConArity = length binders + , tyConNullaryTy = mkTyConTy_ tc + , tcTyConScopedTyVars = scoped_tvs + , tcTyConIsPoly = poly + , tcTyConFlavour = flav } + in tc -- | No scoped type variables (to be used with mkTcTyCon). noTcTyConScopedTyVars :: [(Name, TcTyVar)] @@ -1767,55 +1804,64 @@ mkPrimTyCon' :: Name -> [TyConBinder] -> [Role] -> Bool -> Maybe TyConRepName -> TyCon mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm - = PrimTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConBinders = binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = length roles, - tcRoles = roles, - isUnlifted = is_unlifted, - primRepName = rep_nm - } + = let tc = + PrimTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tyConBinders = binders, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = length roles, + tyConNullaryTy = mkTyConTy_ tc, + tcRoles = roles, + isUnlifted = is_unlifted, + primRepName = rep_nm + } + in tc -- | Create a type synonym 'TyCon' mkSynonymTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind -> [Role] -> Type -> Bool -> Bool -> Bool -> TyCon mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free is_forgetful - = SynonymTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConBinders = binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = length binders, - tyConTyVars = binderVars binders, - tcRoles = roles, - synTcRhs = rhs, - synIsTau = is_tau, - synIsFamFree = is_fam_free, - synIsForgetful = is_forgetful - } + = let tc = + SynonymTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tyConBinders = binders, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = length binders, + tyConNullaryTy = mkTyConTy_ tc, + tyConTyVars = binderVars binders, + tcRoles = roles, + synTcRhs = rhs, + synIsTau = is_tau, + synIsFamFree = is_fam_free, + synIsForgetful = is_forgetful + } + in tc -- | Create a type family 'TyCon' mkFamilyTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind -> Maybe Name -> FamTyConFlav -> Maybe Class -> Injectivity -> TyCon mkFamilyTyCon name binders res_kind resVar flav parent inj - = FamilyTyCon - { tyConUnique = nameUnique name - , tyConName = name - , tyConBinders = binders - , tyConResKind = res_kind - , tyConKind = mkTyConKind binders res_kind - , tyConArity = length binders - , tyConTyVars = binderVars binders - , famTcResVar = resVar - , famTcFlav = flav - , famTcParent = classTyCon <$> parent - , famTcInj = inj - } + = let tc = + FamilyTyCon + { tyConUnique = nameUnique name + , tyConName = name + , tyConBinders = binders + , tyConResKind = res_kind + , tyConKind = mkTyConKind binders res_kind + , tyConArity = length binders + , tyConNullaryTy = mkTyConTy_ tc + , tyConTyVars = binderVars binders + , famTcResVar = resVar + , famTcFlav = flav + , famTcParent = classTyCon <$> parent + , famTcInj = inj + } + in tc -- | Create a promoted data constructor 'TyCon' @@ -1826,18 +1872,21 @@ mkPromotedDataCon :: DataCon -> Name -> TyConRepName -> [TyConTyCoBinder] -> Kind -> [Role] -> RuntimeRepInfo -> TyCon mkPromotedDataCon con name rep_name binders res_kind roles rep_info - = PromotedDataCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConArity = length roles, - tcRoles = roles, - tyConBinders = binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - dataCon = con, - tcRepName = rep_name, - promDcRepInfo = rep_info - } + = let tc = + PromotedDataCon { + tyConUnique = nameUnique name, + tyConName = name, + tyConArity = length roles, + tyConNullaryTy = mkTyConTy_ tc, + tcRoles = roles, + tyConBinders = binders, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + dataCon = con, + tcRepName = rep_name, + promDcRepInfo = rep_info + } + in tc isFunTyCon :: TyCon -> Bool isFunTyCon (FunTyCon {}) = True @@ -2217,7 +2266,11 @@ setTcTyConKind :: TyCon -> Kind -> TyCon -- The new kind is always a zonked version of its previous -- kind, so we don't need to update any other fields. -- See Note [The Purely Kinded Invariant] in GHC.Tc.Gen.HsType -setTcTyConKind tc@(TcTyCon {}) kind = tc { tyConKind = kind } +setTcTyConKind tc@(TcTyCon {}) kind = let tc' = tc { tyConKind = kind + , tyConNullaryTy = mkTyConTy_ tc' + -- see Note [Sharing nullary TyCons] + } + in tc' setTcTyConKind tc _ = pprPanic "setTcTyConKind" (ppr tc) -- | Could this TyCon ever be levity-polymorphic when fully applied? diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index 7032b97939..6a9eeed6fa 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -1490,6 +1490,31 @@ tyConBindersTyCoBinders = map to_tyb to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis) to_tyb (Bndr tv (AnonTCB af)) = Anon af (tymult (varType tv)) +-- | Create the plain type constructor type which has been applied to no type arguments at all. +mkTyConTy :: TyCon -> Type +mkTyConTy tycon = tyConNullaryTy tycon + -- see Note [Sharing nullary TyConApps] in GHC.Core.TyCon + +-- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to +-- its arguments. Applies its arguments to the constructor from left to right. +mkTyConApp :: TyCon -> [Type] -> Type +mkTyConApp tycon tys + | [] <- tys + = mkTyConTy tycon + + | isFunTyCon tycon + , [w, _rep1,_rep2,ty1,ty2] <- tys + -- The FunTyCon (->) is always a visible one + = FunTy { ft_af = VisArg, ft_mult = w, ft_arg = ty1, ft_res = ty2 } + + -- See Note [Prefer Type over TYPE 'LiftedRep]. + | tycon `hasKey` tYPETyConKey + , [rep] <- tys + = tYPE rep + -- The catch-all case + | otherwise + = TyConApp tycon tys + {- -------------------------------------------------------------------- @@ -2254,7 +2279,6 @@ But the left is an AppTy while the right is a TyConApp. The solution is to use repSplitAppTy_maybe to break up the TyConApp into its pieces and then continue. Easy to do, but also easy to forget to do. - Note [Comparing nullary type synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the task of testing equality between two 'Type's of the form @@ -2281,7 +2305,7 @@ We perform this optimisation in a number of places: This optimisation is especially helpful for the ubiquitous GHC.Types.Type, since GHC prefers to use the type synonym over @TYPE 'LiftedRep@ applications -whenever possible. See [Prefer Type over TYPE 'LiftedRep] in +whenever possible. See Note [Prefer Type over TYPE 'LiftedRep] in GHC.Core.TyCo.Rep for details. -} diff --git a/compiler/GHC/Core/Type.hs-boot b/compiler/GHC/Core/Type.hs-boot index bada997f3b..8afa22c771 100644 --- a/compiler/GHC/Core/Type.hs-boot +++ b/compiler/GHC/Core/Type.hs-boot @@ -12,6 +12,8 @@ isCoercionTy :: Type -> Bool mkAppTy :: Type -> Type -> Type mkCastTy :: Type -> Coercion -> Type +mkTyConTy :: TyCon -> Type +mkTyConApp :: TyCon -> [Type] -> Type piResultTy :: HasDebugCallStack => Type -> Type -> Type coreView :: Type -> Maybe Type |