Optimise nullary type constructor usage

During the compilation of programs GHC very frequently deals with
the `Type` type, which is a synonym of `TYPE 'LiftedRep`. This patch
teaches GHC to avoid expanding the `Type` synonym (and other nullary
type synonyms) during type comparisons, saving a good amount of work.
This optimisation is described in `Note [Comparing nullary type
synonyms]`.

To maximize the impact of this optimisation, we introduce a few
special-cases to reduce `TYPE 'LiftedRep` to `Type`. See
`Note [Prefer Type over TYPE 'LiftedPtrRep]`.

Closes #17958.

Metric Decrease:
   T18698b
   T1969
   T12227
   T12545
   T12707
   T14683
   T3064
   T5631
   T5642
   T9020
   T9630
   T9872a
   T13035
   haddock.Cabal
   haddock.base

5 files changed, 172 insertions, 45 deletions

diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs
index 0be6824b9d..be7bdb3aef 100644
--- a/compiler/GHC/Core/TyCo/Rep.hs
+++ b/compiler/GHC/Core/TyCo/Rep.hs
@@ -52,6 +52,7 @@ module GHC.Core.TyCo.Rep (
         mkVisFunTyMany, mkVisFunTysMany,
         mkInvisFunTyMany, mkInvisFunTysMany,
         mkTyConApp,
+        tYPE,
 
         -- * Functions over binders
         TyCoBinder(..), TyCoVarBinder, TyBinder,
@@ -90,8 +91,9 @@ import GHC.Core.TyCon
 import GHC.Core.Coercion.Axiom
 
 -- others
-import GHC.Builtin.Names ( liftedTypeKindTyConKey, manyDataConKey )
-import {-# SOURCE #-} GHC.Builtin.Types ( liftedTypeKindTyCon, manyDataConTy )
+import GHC.Builtin.Names ( liftedTypeKindTyConKey, liftedRepDataConKey, manyDataConKey, tYPETyConKey )
+import {-# SOURCE #-} GHC.Builtin.Types ( liftedTypeKindTyCon, liftedTypeKind, manyDataConTy )
+import {-# SOURCE #-} GHC.Builtin.Types.Prim ( tYPETyCon )
 import GHC.Types.Basic ( LeftOrRight(..), pickLR )
 import GHC.Types.Unique ( hasKey, Uniquable(..) )
 import GHC.Utils.Outputable
@@ -1009,7 +1011,7 @@ mkTyConApp tycon tys
   -- The FunTyCon (->) is always a visible one
   = FunTy { ft_af = VisArg, ft_mult = w, ft_arg = ty1, ft_res = ty2 }
 
-  -- Note [mkTyConApp and Type]
+  -- See Note [Prefer Type over TYPE 'LiftedRep]
   | tycon `hasKey` liftedTypeKindTyConKey
   = ASSERT2( null tys, ppr tycon $$ ppr tys )
     liftedTypeKindTyConApp
@@ -1018,21 +1020,21 @@ mkTyConApp tycon tys
   -- 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
 
--- This is a single, global definition of the type `Type`
--- Defined here so it is only allocated once.
--- See Note [mkTyConApp and Type]
-liftedTypeKindTyConApp :: Type
-liftedTypeKindTyConApp = TyConApp liftedTypeKindTyCon []
-
 {-
-Note [mkTyConApp and Type]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Whilst benchmarking it was observed in #17292 that GHC allocated a lot
-of `TyConApp` constructors. Upon further inspection a large number of these
-TyConApp constructors were all duplicates of `Type` applied to no arguments.
+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)
@@ -1046,12 +1048,59 @@ TyConApp constructors were all duplicates of `Type` applied to no arguments.
 0x45e68fd    - 538 - `TYPE ...`
 ```
 
-Therefore in `mkTyConApp` we have a special case for `Type` to ensure that
-only one `TyConApp 'Type []` closure is allocated during the course of
-compilation. In order to avoid a potentially expensive series of checks in
-`mkTyConApp` only this egregious case is special cased at the moment.
+Consequently, we try hard to ensure that operations on such types are
+efficient. Specifically, we strive to
+
+ a. Avoid heap allocation of such types
+ b. Use a small (shallow in the tree-depth sense) representation
+    for such types
+
+Goal (b) is particularly useful as it makes traversals (e.g. free variable
+traversal, substitution, and comparison) more efficient.
+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:
+
+ 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. 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)).
+
+ 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.
+
+See #17958.
 -}
 
+-- | Given a RuntimeRep, applies TYPE to it.
+-- See Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim.
+tYPE :: Type -> Type
+tYPE (TyConApp tc [])
+  -- See Note [Prefer Type of TYPE 'LiftedRep]
+  | 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/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs
index 64e0c9ccbb..bc6632f1bf 100644
--- a/compiler/GHC/Core/TyCo/Subst.hs
+++ b/compiler/GHC/Core/TyCo/Subst.hs
@@ -424,6 +424,7 @@ zipTCvSubst tcvs tys
 -- | Generates the in-scope set for the 'TCvSubst' from the types in the
 -- incoming environment. No CoVars, please!
 mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst
+mkTvSubstPrs []  = emptyTCvSubst
 mkTvSubstPrs prs =
     ASSERT2( onlyTyVarsAndNoCoercionTy, text "prs" <+> ppr prs )
     mkTvSubst in_scope tenv
@@ -741,7 +742,8 @@ subst_ty subst ty
     go (TyConApp tc tys) = (mkTyConApp $! tc) $! strictMap go tys
                                -- NB: mkTyConApp, not TyConApp.
                                -- mkTyConApp has optimizations.
-                               -- See Note [mkTyConApp and Type] in GHC.Core.TyCo.Rep
+                               -- See Note [Prefer Type over TYPE 'LiftedRep]
+                               -- in GHC.Core.TyCo.Rep
     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 198b66959b..a038fd646c 100644
--- a/compiler/GHC/Core/TyCon.hs
+++ b/compiler/GHC/Core/TyCon.hs
@@ -2327,12 +2327,14 @@ expandSynTyCon_maybe
 -- ^ Expand a type synonym application, if any
 expandSynTyCon_maybe tc tys
   | SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc
-  = case tys `listLengthCmp` arity of
-        GT -> Just (tvs `zip` tys, rhs, drop arity tys)
-        EQ -> Just (tvs `zip` tys, rhs, [])
-        LT -> Nothing
-  | otherwise
-  = Nothing
+  = case tys of
+      [] -> Just ([], rhs, []) -- Avoid a bit of work in the case of nullary synonyms
+      _  -> case tys `listLengthCmp` arity of
+              GT -> Just (tvs `zip` tys, rhs, drop arity tys)
+              EQ -> Just (tvs `zip` tys, rhs, [])
+              LT -> Nothing
+   | otherwise
+   = Nothing
 
 ----------------
 
diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index 3164e2626b..e5d0da93fd 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/compiler/GHC/Core/Type.hs
@@ -383,34 +383,28 @@ how roles in kinds might work out.
 -}
 
 -- | Gives the typechecker view of a type. This unwraps synonyms but
--- leaves 'Constraint' alone. c.f. coreView, which turns Constraint into
--- TYPE LiftedRep. Returns Nothing if no unwrapping happens.
+-- leaves 'Constraint' alone. c.f. 'coreView', which turns 'Constraint' into
+-- 'Type'. Returns 'Nothing' if no unwrapping happens.
 -- See also Note [coreView vs tcView]
-{-# INLINE tcView #-}
 tcView :: Type -> Maybe Type
-tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys
-  = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys')
-               -- The free vars of 'rhs' should all be bound by 'tenv', so it's
-               -- ok to use 'substTy' here.
-               -- 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!
+tcView (TyConApp tc tys)
+  | res@(Just _) <- expandSynTyConApp_maybe tc tys
+  = res
 tcView _ = Nothing
+-- See Note [Inlining coreView].
+{-# INLINE tcView #-}
 
-{-# INLINE coreView #-}
 coreView :: Type -> Maybe Type
--- ^ This function Strips off the /top layer only/ of a type synonym
+-- ^ This function strips off the /top layer only/ of a type synonym
 -- application (if any) its underlying representation type.
--- Returns Nothing if there is nothing to look through.
--- This function considers 'Constraint' to be a synonym of @TYPE LiftedRep@.
+-- Returns 'Nothing' if there is nothing to look through.
+-- This function considers 'Constraint' to be a synonym of @Type@.
 --
 -- By being non-recursive and inlined, this case analysis gets efficiently
 -- joined onto the case analysis that the caller is already doing
 coreView ty@(TyConApp tc tys)
-  | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys
-  = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys')
-    -- This equation is exactly like tcView
+  | res@(Just _) <- expandSynTyConApp_maybe tc tys
+  = res
 
   -- At the Core level, Constraint = Type
   -- See Note [coreView vs tcView]
@@ -419,8 +413,48 @@ coreView ty@(TyConApp tc tys)
     Just liftedTypeKind
 
 coreView _ = Nothing
+-- See Note [Inlining coreView].
+{-# INLINE coreView #-}
+
+-----------------------------------------------
+
+-- | @expandSynTyConApp_maybe tc tys@ expands the RHS of type synonym @tc@
+-- instantiated at arguments @tys@, or returns 'Nothing' if @tc@ is not a
+-- synonym.
+expandSynTyConApp_maybe :: TyCon -> [Type] -> Maybe Type
+expandSynTyConApp_maybe tc tys
+  | Just (tvs, rhs) <- synTyConDefn_maybe tc
+  , tys `lengthAtLeast` arity
+  = Just (expand_syn arity tvs rhs 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
+           -> 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'
+  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 #-}
 
-{-# INLINE coreFullView #-}
 coreFullView :: Type -> Type
 -- ^ Iterates 'coreView' until there is no more to synonym to expand.
 -- See Note [Inlining coreView].
@@ -432,6 +466,7 @@ coreFullView ty@(TyConApp tc _)
       | otherwise = ty
 
 coreFullView ty = ty
+{-# INLINE coreFullView #-}
 
 {- Note [Inlining coreView] in GHC.Core.Type
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2207,6 +2242,36 @@ 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
+
+  TyConApp tc []
+
+where @tc@ is a type synonym. A naive way to perform this comparison these
+would first expand the synonym and then compare the resulting expansions.
+
+However, this is obviously wasteful and the RHS of @tc@ may be large; it is
+much better to rather compare the TyCons directly. Consequently, before
+expanding type synonyms in type comparisons we first look for a nullary
+TyConApp and simply compare the TyCons if we find one. Of course, if we find
+that the TyCons are *not* equal then we still need to perform the expansion as
+their RHSs may still be equal.
+
+We perform this optimisation in a number of places:
+
+ * GHC.Core.Types.eqType
+ * GHC.Core.Types.nonDetCmpType
+ * GHC.Core.Unify.unify_ty
+ * TcCanonical.can_eq_nc'
+ * TcUnify.uType
+
+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
+GHC.Core.TyCo.Rep for details.
+
 -}
 
 eqType :: Type -> Type -> Bool
@@ -2318,6 +2383,10 @@ nonDetCmpTypeX env orig_t1 orig_t2 =
     -- Returns both the resulting ordering relation between the two types
     -- and whether either contains a cast.
     go :: RnEnv2 -> Type -> Type -> TypeOrdering
+    -- See Note [Comparing nullary type synonyms].
+    go _   (TyConApp tc1 []) (TyConApp tc2 [])
+      | tc1 == tc2
+      = TEQ
     go env t1 t2
       | Just t1' <- coreView t1 = go env t1' t2
       | Just t2' <- coreView t2 = go env t1 t2'
diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs
index 709ccf10b4..29d2ae975c 100644
--- a/compiler/GHC/Core/Unify.hs
+++ b/compiler/GHC/Core/Unify.hs
@@ -957,7 +957,12 @@ unify_ty :: UMEnv
 -- Respects newtypes, PredTypes
 
 unify_ty env ty1 ty2 kco
-    -- Use tcView, not coreView. See Note [coreView vs tcView] in GHC.Core.Type.
+  -- See Note [Comparing nullary type synonyms] in GHC.Core.Type.
+  | TyConApp tc1 [] <- ty1
+  , TyConApp tc2 [] <- ty2
+  , tc1 == tc2                = return ()
+
+    -- TODO: More commentary needed here
   | Just ty1' <- tcView ty1   = unify_ty env ty1' ty2 kco
   | Just ty2' <- tcView ty2   = unify_ty env ty1 ty2' kco
   | CastTy ty1' co <- ty1     = if um_unif env