summaryrefslogtreecommitdiff
path: root/compiler/GHC/Core
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Core')
-rw-r--r--compiler/GHC/Core/Lint.hs9
-rw-r--r--compiler/GHC/Core/Opt/Simplify.hs6
-rw-r--r--compiler/GHC/Core/Opt/WorkWrap/Utils.hs2
-rw-r--r--compiler/GHC/Core/TyCo/Rep.hs14
-rw-r--r--compiler/GHC/Core/TyCo/Rep.hs-boot2
-rw-r--r--compiler/GHC/Core/TyCo/Subst.hs4
-rw-r--r--compiler/GHC/Core/TyCon.hs24
-rw-r--r--compiler/GHC/Core/Type.hs293
-rw-r--r--compiler/GHC/Core/Type.hs-boot2
9 files changed, 235 insertions, 121 deletions
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index 7e3b472a95..899ba20fb0 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -1272,13 +1272,12 @@ lintTyApp fun_ty arg_ty
lintValApp :: CoreExpr -> LintedType -> LintedType -> UsageEnv -> UsageEnv -> LintM (LintedType, UsageEnv)
lintValApp arg fun_ty arg_ty fun_ue arg_ue
| Just (w, arg_ty', res_ty') <- splitFunTy_maybe fun_ty
- = do { ensureEqTys arg_ty' arg_ty err1
+ = do { ensureEqTys arg_ty' arg_ty (mkAppMsg arg_ty' arg_ty arg)
; let app_ue = addUE fun_ue (scaleUE w arg_ue)
; return (res_ty', app_ue) }
| otherwise
= failWithL err2
where
- err1 = mkAppMsg fun_ty arg_ty arg
err2 = mkNonFunAppMsg fun_ty arg_ty arg
lintTyKind :: OutTyVar -> LintedType -> LintM ()
@@ -3099,10 +3098,10 @@ mkNewTyDataConAltMsg scrut_ty alt
-- Other error messages
mkAppMsg :: Type -> Type -> CoreExpr -> SDoc
-mkAppMsg fun_ty arg_ty arg
+mkAppMsg expected_arg_ty actual_arg_ty arg
= vcat [text "Argument value doesn't match argument type:",
- hang (text "Fun type:") 4 (ppr fun_ty),
- hang (text "Arg type:") 4 (ppr arg_ty),
+ hang (text "Expected arg type:") 4 (ppr expected_arg_ty),
+ hang (text "Actual arg type:") 4 (ppr actual_arg_ty),
hang (text "Arg:") 4 (ppr arg)]
mkNonFunAppMsg :: Type -> Type -> CoreExpr -> SDoc
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index 8ce2eb857a..1398bfd6e7 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -932,7 +932,7 @@ completeBind env top_lvl mb_cont old_bndr new_bndr new_rhs
-- substitution will happen, since we are going to discard the binding
else -- Keep the binding; do cast worker/wrapper
- -- pprTrace "Binding" (ppr final_bndr <+> ppr new_unfolding) $
+ -- pprTrace "Binding" (ppr new_bndr <+> ppr new_unfolding) $
tryCastWorkerWrapper env top_lvl old_bndr occ_info new_bndr_w_info eta_rhs }
addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId
@@ -1082,7 +1082,7 @@ simplExprC :: SimplEnv
-> SimplM OutExpr
-- Simplify an expression, given a continuation
simplExprC env expr cont
- = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seLetFloats env) ) $
+ = -- pprTrace "simplExprC" (ppr expr $$ ppr cont) $
do { (floats, expr') <- simplExprF env expr cont
; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $
-- pprTrace "simplExprC ret3" (ppr (seInScope env')) $
@@ -3015,7 +3015,7 @@ simplAlts env0 scrut case_bndr alts cont'
-- by the caller (rebuildCase) in the missingAlt function
; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts
- ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $
+-- ; pprTrace "simplAlts" (ppr case_bndr $$ ppr alts $$ ppr cont') $ return ()
; let alts_ty' = contResultType cont'
-- See Note [Avoiding space leaks in OutType]
diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
index c2287916db..ce02f46e45 100644
--- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
@@ -271,7 +271,7 @@ mkWwBodies opts fun_id arg_vars res_ty demands res_cpr
only_one_void_argument
| [d] <- demands
, [v] <- filter isId arg_vars
- , isAbsDmd d && isVoidTy (idType v)
+ , isAbsDmd d && isZeroBitTy (idType v)
= True
| otherwise
= False
diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs
index b9986e0a36..bb7280dd0d 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,
+ mkNakedTyConTy, mkTyVarTy, mkTyVarTys,
mkTyCoVarTy, mkTyCoVarTys,
mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys,
mkForAllTy, mkForAllTys, mkInvisForAllTys,
@@ -1062,11 +1062,13 @@ mkPiTy (Named (Bndr tv vis)) ty = mkForAllTy tv vis ty
mkPiTys :: [TyCoBinder] -> Type -> Type
mkPiTys tbs ty = foldr mkPiTy ty tbs
--- | 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 []
+-- | 'mkNakedTyConTy' creates a nullary 'TyConApp'. In general you
+-- should rather use 'GHC.Core.Type.mkTyConTy', which picks the shared
+-- nullary TyConApp from inside the TyCon (via tyConNullaryTy. But
+-- we have to build the TyConApp tc [] in that TyCon field; that's
+-- what 'mkNakedTyConTy' is for.
+mkNakedTyConTy :: TyCon -> Type
+mkNakedTyConTy tycon = TyConApp tycon []
{-
%************************************************************************
diff --git a/compiler/GHC/Core/TyCo/Rep.hs-boot b/compiler/GHC/Core/TyCo/Rep.hs-boot
index 0c89a2f077..f2e59d534f 100644
--- a/compiler/GHC/Core/TyCo/Rep.hs-boot
+++ b/compiler/GHC/Core/TyCo/Rep.hs-boot
@@ -24,7 +24,7 @@ type MCoercionN = MCoercion
mkFunTyMany :: AnonArgFlag -> Type -> Type -> Type
mkForAllTy :: Var -> ArgFlag -> Type -> Type
-mkTyConTy_ :: TyCon -> Type
+mkNakedTyConTy :: 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 5d060cb7cd..ec77cd2671 100644
--- a/compiler/GHC/Core/TyCo/Subst.hs
+++ b/compiler/GHC/Core/TyCo/Subst.hs
@@ -746,8 +746,8 @@ subst_ty subst ty
go (TyConApp tc tys) = (mkTyConApp $! tc) $! strictMap go tys
-- NB: mkTyConApp, not TyConApp.
-- mkTyConApp has optimizations.
- -- See Note [Prefer Type over TYPE 'LiftedRep]
- -- in GHC.Core.TyCo.Rep
+ -- See Note [Using synonyms to compress types]
+ -- in GHC.Core.Type
go ty@(FunTy { ft_mult = mult, ft_arg = arg, ft_res = res })
= let !mult' = go mult
!arg' = go arg
diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs
index fd5b3df534..24807945cc 100644
--- a/compiler/GHC/Core/TyCon.hs
+++ b/compiler/GHC/Core/TyCon.hs
@@ -138,7 +138,7 @@ import GHC.Prelude
import GHC.Platform
import {-# SOURCE #-} GHC.Core.TyCo.Rep
- ( Kind, Type, PredType, mkForAllTy, mkFunTyMany, mkTyConTy_ )
+ ( Kind, Type, PredType, mkForAllTy, mkFunTyMany, mkNakedTyConTy )
import {-# SOURCE #-} GHC.Core.TyCo.Ppr
( pprType )
import {-# SOURCE #-} GHC.Builtin.Types
@@ -1819,7 +1819,7 @@ So we compromise, and move their Kind calculation to the call site.
-}
-- | Given the name of the function type constructor and it's kind, create the
--- corresponding 'TyCon'. It is recommended to use 'GHC.Core.TyCo.Rep.funTyCon' if you want
+-- corresponding 'TyCon'. It is recommended to use 'GHC.Builtin.Types.funTyCon' if you want
-- this functionality
mkFunTyCon :: Name -> [TyConBinder] -> Name -> TyCon
mkFunTyCon name binders rep_nm
@@ -1831,7 +1831,7 @@ mkFunTyCon name binders rep_nm
tyConResKind = liftedTypeKind,
tyConKind = mkTyConKind binders liftedTypeKind,
tyConArity = length binders,
- tyConNullaryTy = mkTyConTy_ tc,
+ tyConNullaryTy = mkNakedTyConTy tc,
tcRepName = rep_nm
}
in tc
@@ -1858,7 +1858,7 @@ mkAlgTyCon name binders res_kind roles cType stupid rhs parent gadt_syn
tyConResKind = res_kind,
tyConKind = mkTyConKind binders res_kind,
tyConArity = length binders,
- tyConNullaryTy = mkTyConTy_ tc,
+ tyConNullaryTy = mkNakedTyConTy tc,
tyConTyVars = binderVars binders,
tcRoles = roles,
tyConCType = cType,
@@ -1897,7 +1897,7 @@ mkTupleTyCon name binders res_kind arity con sort parent
tyConResKind = res_kind,
tyConKind = mkTyConKind binders res_kind,
tyConArity = arity,
- tyConNullaryTy = mkTyConTy_ tc,
+ tyConNullaryTy = mkNakedTyConTy tc,
tcRoles = replicate arity Representational,
tyConCType = Nothing,
algTcGadtSyntax = False,
@@ -1927,7 +1927,7 @@ mkSumTyCon name binders res_kind arity tyvars cons parent
tyConResKind = res_kind,
tyConKind = mkTyConKind binders res_kind,
tyConArity = arity,
- tyConNullaryTy = mkTyConTy_ tc,
+ tyConNullaryTy = mkNakedTyConTy tc,
tcRoles = replicate arity Representational,
tyConCType = Nothing,
algTcGadtSyntax = False,
@@ -1962,7 +1962,7 @@ mkTcTyCon name binders res_kind scoped_tvs poly flav
, tyConResKind = res_kind
, tyConKind = mkTyConKind binders res_kind
, tyConArity = length binders
- , tyConNullaryTy = mkTyConTy_ tc
+ , tyConNullaryTy = mkNakedTyConTy tc
, tcTyConScopedTyVars = scoped_tvs
, tcTyConIsPoly = poly
, tcTyConFlavour = flav }
@@ -2013,7 +2013,7 @@ mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm
tyConResKind = res_kind,
tyConKind = mkTyConKind binders res_kind,
tyConArity = length roles,
- tyConNullaryTy = mkTyConTy_ tc,
+ tyConNullaryTy = mkNakedTyConTy tc,
tcRoles = roles,
isUnlifted = is_unlifted,
primRepName = rep_nm
@@ -2032,7 +2032,7 @@ mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free is_forgetful
tyConResKind = res_kind,
tyConKind = mkTyConKind binders res_kind,
tyConArity = length binders,
- tyConNullaryTy = mkTyConTy_ tc,
+ tyConNullaryTy = mkNakedTyConTy tc,
tyConTyVars = binderVars binders,
tcRoles = roles,
synTcRhs = rhs,
@@ -2055,7 +2055,7 @@ mkFamilyTyCon name binders res_kind resVar flav parent inj
, tyConResKind = res_kind
, tyConKind = mkTyConKind binders res_kind
, tyConArity = length binders
- , tyConNullaryTy = mkTyConTy_ tc
+ , tyConNullaryTy = mkNakedTyConTy tc
, tyConTyVars = binderVars binders
, famTcResVar = resVar
, famTcFlav = flav
@@ -2078,7 +2078,7 @@ mkPromotedDataCon con name rep_name binders res_kind roles rep_info
tyConUnique = nameUnique name,
tyConName = name,
tyConArity = length roles,
- tyConNullaryTy = mkTyConTy_ tc,
+ tyConNullaryTy = mkNakedTyConTy tc,
tcRoles = roles,
tyConBinders = binders,
tyConResKind = res_kind,
@@ -2468,7 +2468,7 @@ setTcTyConKind :: TyCon -> Kind -> TyCon
-- 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 = let tc' = tc { tyConKind = kind
- , tyConNullaryTy = mkTyConTy_ tc'
+ , tyConNullaryTy = mkNakedTyConTy tc'
-- see Note [Sharing nullary TyCons]
}
in tc'
diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index 16688cf287..cf671657b0 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/compiler/GHC/Core/Type.hs
@@ -36,7 +36,7 @@ module GHC.Core.Type (
splitFunTy, splitFunTy_maybe,
splitFunTys, funResultTy, funArgTy,
- mkTyConApp, mkTyConTy, tYPE,
+ mkTyConApp, mkTyConTy, mkTYPEapp,
tyConAppTyCon_maybe, tyConAppTyConPicky_maybe,
tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs,
splitTyConApp_maybe, splitTyConApp, tyConAppArgN,
@@ -259,8 +259,8 @@ import GHC.Builtin.Types.Prim
import {-# SOURCE #-} GHC.Builtin.Types
( charTy, naturalTy, listTyCon
, typeSymbolKind, liftedTypeKind, unliftedTypeKind
- , liftedRepTyCon, unliftedRepTyCon
- , constraintKind
+ , liftedRepTy, unliftedRepTy, zeroBitRepTy
+ , constraintKind, zeroBitTypeKind
, unrestrictedFunTyCon
, manyDataConTy, oneDataConTy )
import GHC.Types.Name( Name )
@@ -290,6 +290,7 @@ import GHC.Types.Unique ( nonDetCmpUnique )
import GHC.Data.Maybe ( orElse, expectJust )
import Data.Maybe ( isJust )
import Control.Monad ( guard )
+-- import GHC.Utils.Trace
-- $type_classification
-- #type_classification#
@@ -457,38 +458,58 @@ coreView _ = Nothing
-- instantiated at arguments @tys@, or returns 'Nothing' if @tc@ is not a
-- synonym.
expandSynTyConApp_maybe :: TyCon -> [Type] -> Maybe Type
-expandSynTyConApp_maybe tc tys
+{-# INLINE expandSynTyConApp_maybe #-}
+-- This INLINE will inline the call to expandSynTyConApp_maybe in coreView,
+-- which will eliminate the allocat ion Just/Nothing in the result
+-- Don't be tempted to make `expand_syn` (which is NOINLIN) return the
+-- Just/Nothing, else you'll increase allocation
+expandSynTyConApp_maybe tc arg_tys
| Just (tvs, rhs) <- synTyConDefn_maybe tc
- , tys `lengthAtLeast` arity
- = Just (expand_syn arity tvs rhs tys)
+ , arg_tys `lengthAtLeast` (tyConArity tc)
+ = Just (expand_syn tvs rhs arg_tys)
| otherwise
= Nothing
- where
- arity = tyConArity tc
--- Without this INLINE the call to expandSynTyConApp_maybe in coreView
--- will result in an avoidable allocation.
-{-# INLINE expandSynTyConApp_maybe #-}
-- | A helper for 'expandSynTyConApp_maybe' to avoid inlining this cold path
-- into call-sites.
-expand_syn :: Int -- ^ the arity of the synonym
- -> [TyVar] -- ^ the variables bound by the synonym
+--
+-- Precondition: the call is saturated or over-saturated;
+-- i.e. length tvs <= length arg_tys
+expand_syn :: [TyVar] -- ^ the variables bound by the synonym
-> Type -- ^ the RHS of the synonym
-> [Type] -- ^ the type arguments the synonym is instantiated at.
-> Type
-expand_syn arity tvs rhs tys
- | tys `lengthExceeds` arity = mkAppTys rhs' (drop arity tys)
- | otherwise = rhs'
+{-# NOINLINE expand_syn #-} -- We never want to inline this cold-path.
+
+expand_syn tvs rhs arg_tys
+ -- No substitution necessary if either tvs or tys is empty
+ -- This is both more efficient, and steers clear of an infinite
+ -- loop; see Note [Care using synonyms to compress types]
+ | null arg_tys = assert (null tvs) rhs
+ | null tvs = mkAppTys rhs arg_tys
+ | otherwise = go empty_subst tvs arg_tys
where
- rhs' = substTy (mkTvSubstPrs (tvs `zip` tys)) rhs
- -- The free vars of 'rhs' should all be bound by 'tenv', so it's
- -- ok to use 'substTy' here (which is what expandSynTyConApp_maybe does).
- -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst.
- -- Its important to use mkAppTys, rather than (foldl AppTy),
- -- because the function part might well return a
- -- partially-applied type constructor; indeed, usually will!
--- We never want to inline this cold-path.
-{-# INLINE expand_syn #-}
+ empty_subst = mkEmptyTCvSubst in_scope
+ in_scope = mkInScopeSet $ shallowTyCoVarsOfTypes $ arg_tys
+ -- The free vars of 'rhs' should all be bound by 'tenv',
+ -- so we only need the free vars of tys
+ -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst.
+
+ go subst [] tys
+ | null tys = rhs' -- Exactly Saturated
+ | otherwise = mkAppTys rhs' tys
+ -- Its important to use mkAppTys, rather than (foldl AppTy),
+ -- because the function part might well return a
+ -- partially-applied type constructor; indeed, usually will!
+ where
+ rhs' = substTy subst rhs
+
+ go subst (tv:tvs) (ty:tys) = go (extendTvSubst subst tv ty) tvs tys
+
+ go _ (_:_) [] = pprPanic "expand_syn" (ppr tvs $$ ppr rhs $$ ppr arg_tys)
+ -- Under-saturated, precondition failed
+
+
coreFullView :: Type -> Type
-- ^ Iterates 'coreView' until there is no more to synonym to expand.
@@ -1635,55 +1656,137 @@ 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 tc) returns (TyConApp tc [])
+-- but arranges to share that TyConApp among all calls
+-- See Note [Sharing nullary TyConApps] in GHC.Core.TyCon
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
- | null 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
+mkTyConApp tycon []
+ = -- See Note [Sharing nullary TyConApps] in GHC.Core.TyCon
+ mkTyConTy tycon
+
+mkTyConApp tycon tys@(ty1:rest)
+ | key == funTyConKey
+ = case tys of
+ [w, _rep1,_rep2,arg,res] -> FunTy { ft_af = VisArg, ft_mult = w
+ , ft_arg = arg, ft_res = res }
+ _ -> bale_out
+
+ -- See Note [Using synonyms to compress types]
+ | key == tYPETyConKey
+ = assert (null rest) $
+-- mkTYPEapp_maybe ty1 `orElse` bale_out
+ case mkTYPEapp_maybe ty1 of
+ Just ty -> ty -- pprTrace "mkTYPEapp:yes" (ppr ty) ty
+ Nothing -> bale_out -- pprTrace "mkTYPEapp:no" (ppr bale_out) bale_out
+
+ -- See Note [Using synonyms to compress types]
+ | key == boxedRepDataConTyConKey
+ = assert (null rest) $
+-- mkBoxedRepApp_maybe ty1 `orElse` bale_out
+ case mkBoxedRepApp_maybe ty1 of
+ Just ty -> ty -- pprTrace "mkBoxedRepApp:yes" (ppr ty) ty
+ Nothing -> bale_out -- pprTrace "mkBoxedRepApp:no" (ppr bale_out) bale_out
+
+ | key == tupleRepDataConTyConKey
+ = case mkTupleRepApp_maybe ty1 of
+ Just ty -> ty -- pprTrace "mkTupleRepApp:yes" (ppr ty) ty
+ Nothing -> bale_out -- pprTrace "mkTupleRepApp:no" (ppr bale_out) bale_out
+
-- The catch-all case
| otherwise
- = TyConApp tycon tys
+ = bale_out
+ where
+ key = tyConUnique tycon
+ bale_out = TyConApp tycon tys
+
+mkTYPEapp :: Type -> Type
+mkTYPEapp rr
+ = case mkTYPEapp_maybe rr of
+ Just ty -> ty
+ Nothing -> TyConApp tYPETyCon [rr]
+
+mkTYPEapp_maybe :: Type -> Maybe Type
+-- ^ Given a @RuntimeRep@, applies @TYPE@ to it.
+-- On the fly it rewrites
+-- TYPE LiftedRep --> liftedTypeKind (a synonym)
+-- TYPE UnliftedRep --> unliftedTypeKind (ditto)
+-- TYPE ZeroBitRep --> zeroBitTypeKind (ditto)
+-- NB: no need to check for TYPE (BoxedRep Lifted), TYPE (BoxedRep Unlifted)
+-- because those inner types should already have been rewritten
+-- to LiftedRep and UnliftedRep respectively, by mkTyConApp
+--
+-- see Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim.
+-- See Note [Using synonyms to compress types] in GHC.Core.Type
+{-# NOINLINE mkTYPEapp_maybe #-}
+mkTYPEapp_maybe (TyConApp tc args)
+ | key == liftedRepTyConKey = assert (null args) $ Just liftedTypeKind -- TYPE LiftedRep
+ | key == unliftedRepTyConKey = assert (null args) $ Just unliftedTypeKind -- TYPE UnliftedRep
+ | key == zeroBitRepTyConKey = assert (null args) $ Just zeroBitTypeKind -- TYPE ZeroBitRep
+ where
+ key = tyConUnique tc
+mkTYPEapp_maybe _ = Nothing
+
+mkBoxedRepApp_maybe :: Type -> Maybe Type
+-- ^ Given a `Levity`, apply `BoxedRep` to it
+-- On the fly, rewrite
+-- BoxedRep Lifted --> liftedRepTy (a synonym)
+-- BoxedRep Unlifted --> unliftedRepTy (ditto)
+-- See Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim.
+-- See Note [Using synonyms to compress types] in GHC.Core.Type
+{-# NOINLINE mkBoxedRepApp_maybe #-}
+mkBoxedRepApp_maybe (TyConApp tc args)
+ | key == liftedDataConKey = assert (null args) $ Just liftedRepTy -- BoxedRep Lifted
+ | key == unliftedDataConKey = assert (null args) $ Just unliftedRepTy -- BoxedRep Unlifted
+ where
+ key = tyConUnique tc
+mkBoxedRepApp_maybe _ = Nothing
-{-
-Note [Prefer Type over TYPE 'LiftedRep]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The Core of nearly any program will have numerous occurrences of
-@TYPE 'LiftedRep@ (and, equivalently, 'Type') floating about. Concretely, while
-investigating #17292 we found that these constituting a majority of TyConApp
-constructors on the heap:
-
-```
-(From a sample of 100000 TyConApp closures)
-0x45f3523 - 28732 - `Type`
-0x420b840702 - 9629 - generic type constructors
-0x42055b7e46 - 9596
-0x420559b582 - 9511
-0x420bb15a1e - 9509
-0x420b86c6ba - 9501
-0x42055bac1e - 9496
-0x45e68fd - 538 - `TYPE ...`
-```
+mkTupleRepApp_maybe :: Type -> Maybe Type
+-- ^ Given a `[RuntimeRep]`, apply `TupleRep` to it
+-- On the fly, rewrite
+-- TupleRep [] -> zeroBitRepTy (a synonym)
+-- See Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim.
+-- See Note [Using synonyms to compress types] in GHC.Core.Type
+{-# NOINLINE mkTupleRepApp_maybe #-}
+mkTupleRepApp_maybe (TyConApp tc args)
+ | key == nilDataConKey = assert (isSingleton args) $ Just zeroBitRepTy -- ZeroBitRep
+ where
+ key = tyConUnique tc
+mkTupleRepApp_maybe _ = Nothing
+
+{- Note [Using synonyms to compress types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Was: Prefer Type over TYPE (BoxedRep Lifted)]
+
+The Core of nearly any program will have numerous occurrences of the Types
+
+ TyConApp BoxedRep [TyConApp Lifted []] -- Synonym LiftedRep
+ TyConApp BoxedRep [TyConApp Unlifted []] -- Synonym UnliftedREp
+ TyConApp TYPE [TyConApp LiftedRep []] -- Synonym Type
+ TyConApp TYPE [TyConApp UnliftedRep []] -- Synonym UnliftedType
+
+While investigating #17292 we found that these constituted a majority
+of all TyConApp constructors on the heap:
+
+ (From a sample of 100000 TyConApp closures)
+ 0x45f3523 - 28732 - `Type`
+ 0x420b840702 - 9629 - generic type constructors
+ 0x42055b7e46 - 9596
+ 0x420559b582 - 9511
+ 0x420bb15a1e - 9509
+ 0x420b86c6ba - 9501
+ 0x42055bac1e - 9496
+ 0x45e68fd - 538 - `TYPE ...`
Consequently, we try hard to ensure that operations on such types are
efficient. Specifically, we strive to
- a. Avoid heap allocation of such types
+ a. Avoid heap allocation of such types; use a single static TyConApp
b. Use a small (shallow in the tree-depth sense) representation
for such types
@@ -1693,41 +1796,51 @@ Comparison in particular takes special advantage of nullary type synonym
applications (e.g. things like @TyConApp typeTyCon []@), Note [Comparing
nullary type synonyms] in "GHC.Core.Type".
-To accomplish these we use a number of tricks:
+To accomplish these we use a number of tricks, implemented by mkTyConApp.
+
+ 1. Instead of (TyConApp BoxedRep [TyConApp Lifted []]),
+ we prefer a statically-allocated (TyConApp LiftedRep [])
+ where `LiftedRep` is a type synonym:
+ type LiftedRep = BoxedRep Lifted
+ Similarly for UnliftedRep
- 1. Instead of representing the lifted kind as
- @TyConApp tYPETyCon [liftedRepDataCon]@ we rather prefer to
- use the 'GHC.Types.Type' type synonym (represented as a nullary TyConApp).
- This serves goal (b) since there are no applied type arguments to traverse,
- e.g., during comparison.
+ 2. Instead of (TyConApp TYPE [TyConApp LiftedRep []])
+ we prefer the statically-allocated (TyConApp Type [])
+ where `Type` is a type synonym
+ type Type = TYPE LiftedRep
+ Similarly for UnliftedType
- 2. We have a top-level binding to represent `TyConApp GHC.Types.Type []`
- (namely 'GHC.Builtin.Types.Prim.liftedTypeKind'), ensuring that we
- don't need to allocate such types (goal (a)).
+These serve goal (b) since there are no applied type arguments to traverse,
+e.g., during comparison.
- 3. We use the sharing mechanism described in Note [Sharing nullary TyConApps]
+ 3. We have a single, statically allocated top-level binding to
+ represent `TyConApp GHC.Types.Type []` (namely
+ 'GHC.Builtin.Types.Prim.liftedTypeKind'), ensuring that we don't
+ need to allocate such types (goal (a)). See functions
+ mkTYPEapp and mkBoxedRepApp
+
+ 4. 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.
--}
+See #17958, #20541
+Note [Care using synonyms to compress types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Using a synonym to compress a types has a tricky wrinkle. Consider
+coreView applied to (TyConApp LiftedRep [])
+
+* coreView expands the LiftedRep synonym:
+ type LiftedRep = BoxedRep Lifted
+
+* Danger: we might apply the empty substitution to the RHS of the
+ synonym. And substTy calls mkTyConApp BoxedRep [Lifted]. And
+ mkTyConApp compresses that back to LiftedRep. Loop!
+
+* Solution: in expandSynTyConApp_maybe, don't call substTy for nullary
+ type synonyms. That's more efficient anyway.
+-}
--- | Given a @RuntimeRep@, applies @TYPE@ to it.
--- See Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim.
-tYPE :: Type -> Type
-tYPE rr@(TyConApp tc [arg])
- -- See Note [Prefer Type of TYPE 'LiftedRep]
- | tc `hasKey` boxedRepDataConKey
- , TyConApp tc' [] <- arg
- = if | tc' `hasKey` liftedDataConKey -> liftedTypeKind -- TYPE (BoxedRep 'Lifted)
- | tc' `hasKey` unliftedDataConKey -> unliftedTypeKind -- TYPE (BoxedRep 'Unlifted)
- | otherwise -> TyConApp tYPETyCon [rr]
- | tc == liftedRepTyCon -- TYPE LiftedRep
- = liftedTypeKind
- | tc == unliftedRepTyCon -- TYPE UnliftedRep
- = unliftedTypeKind
-tYPE rr = TyConApp tYPETyCon [rr]
{-
@@ -2528,8 +2641,8 @@ 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 Note [Prefer Type over TYPE 'LiftedRep] in
-GHC.Core.TyCo.Rep for details.
+whenever possible. See Note [Using synonyms to compress types] in
+GHC.Core.Type for details.
-}
diff --git a/compiler/GHC/Core/Type.hs-boot b/compiler/GHC/Core/Type.hs-boot
index e17cab9a40..94f9e34f83 100644
--- a/compiler/GHC/Core/Type.hs-boot
+++ b/compiler/GHC/Core/Type.hs-boot
@@ -22,7 +22,7 @@ isRuntimeRepTy :: Type -> Bool
isLevityTy :: Type -> Bool
isMultiplicityTy :: Type -> Bool
isLiftedTypeKind :: Type -> Bool
-tYPE :: Type -> Type
+mkTYPEapp :: Type -> Type
splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])
tyConAppTyCon_maybe :: Type -> Maybe TyCon
View Lorry Controller Status