Increase type sharingwip/T20541

Fixes #20541 by making mkTyConApp do more sharing of types.
In particular, replace

* BoxedRep Lifted    ==>  LiftedRep
* BoxedRep Unlifted  ==>  UnliftedRep
* TupleRep '[]       ==>  ZeroBitRep
* TYPE ZeroBitRep    ==>  ZeroBitType

In each case, the thing on the right is a type synonym
for the thing on the left, declared in ghc-prim:GHC.Types.
See Note [Using synonyms to compress types] in GHC.Core.Type.

The synonyms for ZeroBitRep and ZeroBitType are new, but absolutely
in the same spirit as the other ones.   (These synonyms are mainly
for internal use, though the programmer can use them too.)

I also renamed GHC.Core.Ty.Rep.isVoidTy to isZeroBitTy, to be
compatible with the "zero-bit" nomenclature above.  See discussion
on !6806.

There is a tricky wrinkle: see GHC.Core.Types
  Note [Care using synonyms to compress types]

Compiler allocation decreases by up to 0.8%.

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