Various performance improvements

This implements several general performance improvements to GHC,
to offset the effect of the linear types change.

General optimisations:
- Add a `coreFullView` function which iterates `coreView` on the
  head. This avoids making function recursive solely because the
  iterate `coreView` themselves. As a consequence, this functions can
  be inlined, and trigger case-of-known constructor (_e.g._
  `kindRep_maybe`, `isLiftedRuntimeRep`, `isMultiplicityTy`,
  `getTyVar_maybe`, `splitAppTy_maybe`, `splitFunType_maybe`,
  `tyConAppTyCon_maybe`). The common pattern about all these functions
  is that they are almost always used as views, and immediately
  consumed by a case expression. This commit also mark them asx `INLINE`.
- In `subst_ty` add a special case for nullary `TyConApp`, which avoid
  allocations altogether.
- Use `mkTyConApp` in `subst_ty` for the general `TyConApp`. This
  required quite a bit of module shuffling.
  case. `myTyConApp` enforces crucial sharing, which was lost during
  substitution. See also !2952 .
- Make `subst_ty` stricter.
- In `eqType` (specifically, in `nonDetCmpType`), add a special case,
  tested first, for the very common case of nullary `TyConApp`.
  `nonDetCmpType` has been made `INLINE` otherwise it is actually a
  regression. This is similar to the optimisations in !2952.

Linear-type specific optimisations:
- Use `tyConAppTyCon_maybe` instead of the more complex `eqType` in
  the definition of the pattern synonyms `One` and `Many`.
- Break the `hs-boot` cycles between `Multiplicity.hs` and `Type.hs`:
  `Multiplicity` now import `Type` normally, rather than from the
  `hs-boot`. This way `tyConAppTyCon_maybe` can inline properly in the
  `One` and `Many` pattern synonyms.
- Make `updateIdTypeAndMult` strict in its type and multiplicity
- The `scaleIdBy` gets a specialised definition rather than being an
  alias to `scaleVarBy`
- `splitFunTy_maybe` is given the type `Type -> Maybe (Mult, Type,
  Type)` instead of `Type -> Maybe (Scaled Type, Type)`
- Remove the `MultMul` pattern synonym in favour of a view `isMultMul`
  because pattern synonyms appear not to inline well.
- in `eqType`, in a `FunTy`, compare multiplicities last: they are
  almost always both `Many`, so it helps failing faster.
- Cache `manyDataConTy` in `mkTyConApp`, to make sure that all the
  instances of `TyConApp ManyDataConTy []` are physically the same.

This commit has been authored by
* Richard Eisenberg
* Krzysztof Gogolewski
* Arnaud Spiwack

Metric Decrease:
    haddock.base
    T12227
    T12545
    T12990
    T1969
    T3064
    T5030
    T9872b

Metric Increase:
    haddock.base
    haddock.Cabal
    haddock.compiler
    T12150
    T12234
    T12425
    T12707
    T13035
    T13056
    T15164
    T16190
    T18304
    T1969
    T3064
    T3294
    T5631
    T5642
    T5837
    T6048
    T9020
    T9233
    T9675
    T9872a
    T9961
    WWRec

6 files changed, 130 insertions, 22 deletions

diff --git a/compiler/GHC/Core/TyCo/Ppr.hs b/compiler/GHC/Core/TyCo/Ppr.hs
index c6bf57e6d2..44899be2ac 100644
--- a/compiler/GHC/Core/TyCo/Ppr.hs
+++ b/compiler/GHC/Core/TyCo/Ppr.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE PatternSynonyms #-}
+
 -- | Pretty-printing types and coercions.
 module GHC.Core.TyCo.Ppr
   (
@@ -34,10 +36,8 @@ import {-# SOURCE #-} GHC.CoreToIface
 import {-# SOURCE #-} GHC.Core.DataCon
    ( dataConFullSig , dataConUserTyVarBinders
    , DataCon )
-import GHC.Core.Multiplicity
 
-import {-# SOURCE #-} GHC.Core.Type
-   ( isLiftedTypeKind )
+import GHC.Core.Type ( isLiftedTypeKind, pattern One, pattern Many )
 
 import GHC.Core.TyCon
 import GHC.Core.TyCo.Rep
diff --git a/compiler/GHC/Core/TyCo/Ppr.hs-boot b/compiler/GHC/Core/TyCo/Ppr.hs-boot
index 8e89c334ea..2b1a787f1f 100644
--- a/compiler/GHC/Core/TyCo/Ppr.hs-boot
+++ b/compiler/GHC/Core/TyCo/Ppr.hs-boot
@@ -1,10 +1,11 @@
 module GHC.Core.TyCo.Ppr where
 
+import {-# SOURCE #-} GHC.Types.Var ( TyVar )
 import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind, Coercion, TyLit)
-import GHC.Utils.Outputable
+import GHC.Utils.Outputable ( SDoc )
 
 pprType :: Type -> SDoc
 pprKind :: Kind -> SDoc
 pprCo :: Coercion -> SDoc
 pprTyLit :: TyLit -> SDoc
-
+pprTyVar :: TyVar -> SDoc
diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs
index e201dcfea3..e72284477a 100644
--- a/compiler/GHC/Core/TyCo/Rep.hs
+++ b/compiler/GHC/Core/TyCo/Rep.hs
@@ -25,10 +25,7 @@ module GHC.Core.TyCo.Rep (
         TyThing(..), tyThingCategory, pprTyThingCategory, pprShortTyThing,
 
         -- * Types
-        Type( TyVarTy, AppTy, TyConApp, ForAllTy
-            , LitTy, CastTy, CoercionTy
-            , FunTy, ft_mult, ft_arg, ft_res, ft_af
-            ),  -- Export the type synonym FunTy too
+        Type(..),
 
         TyLit(..),
         KindOrType, Kind,
@@ -53,6 +50,7 @@ module GHC.Core.TyCo.Rep (
         mkScaledFunTy,
         mkVisFunTyMany, mkVisFunTysMany,
         mkInvisFunTyMany, mkInvisFunTysMany,
+        mkTyConApp,
 
         -- * Functions over binders
         TyCoBinder(..), TyCoVarBinder, TyBinder,
@@ -69,7 +67,10 @@ module GHC.Core.TyCo.Rep (
         TyCoFolder(..), foldTyCo,
 
         -- * Sizes
-        typeSize, coercionSize, provSize
+        typeSize, coercionSize, provSize,
+
+        -- * Multiplicities
+        Scaled(..), scaledMult, scaledThing, mapScaledType, Mult
     ) where
 
 #include "HsVersions.h"
@@ -87,12 +88,14 @@ import GHC.Iface.Type
 import GHC.Types.Var
 import GHC.Types.Var.Set
 import GHC.Types.Name hiding ( varName )
-import GHC.Core.Multiplicity
 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.Types.Basic ( LeftOrRight(..), pickLR )
+import GHC.Types.Unique ( hasKey )
 import GHC.Utils.Outputable
 import GHC.Data.FastString
 import GHC.Utils.Misc
@@ -1003,14 +1006,14 @@ mkVisFunTy   = mkFunTy VisArg
 mkInvisFunTy = mkFunTy InvisArg
 
 mkFunTyMany :: AnonArgFlag -> Type -> Type -> Type
-mkFunTyMany af = mkFunTy af Many
+mkFunTyMany af = mkFunTy af manyDataConTy
 
 -- | Special, common, case: Arrow type with mult Many
 mkVisFunTyMany :: Type -> Type -> Type
-mkVisFunTyMany = mkVisFunTy Many
+mkVisFunTyMany = mkVisFunTy manyDataConTy
 
 mkInvisFunTyMany :: Type -> Type -> Type
-mkInvisFunTyMany = mkInvisFunTy Many
+mkInvisFunTyMany = mkInvisFunTy manyDataConTy
 
 -- | Make nested arrow types
 mkVisFunTys :: [Scaled Type] -> Type -> Type
@@ -1046,6 +1049,58 @@ mkPiTys tbs ty = foldr mkPiTy ty tbs
 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 }
+
+  -- Note [mkTyConApp and Type]
+  | 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
+  | 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.
+
+```
+(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 ...`
+```
+
+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.
+-}
+
 {-
 %************************************************************************
 %*                                                                      *
@@ -1954,3 +2009,50 @@ provSize :: UnivCoProvenance -> Int
 provSize (PhantomProv co)    = 1 + coercionSize co
 provSize (ProofIrrelProv co) = 1 + coercionSize co
 provSize (PluginProv _)      = 1
+
+{-
+************************************************************************
+*                                                                      *
+                    Multiplicities
+*                                                                      *
+************************************************************************
+
+These definitions are here to avoid module loops, and to keep
+GHC.Core.Multiplicity above this module.
+
+-}
+
+-- | A shorthand for data with an attached 'Mult' element (the multiplicity).
+data Scaled a = Scaled Mult a
+  deriving (Data.Data)
+
+instance (Outputable a) => Outputable (Scaled a) where
+   ppr (Scaled _cnt t) = ppr t
+     -- Do not print the multiplicity here because it tends to be too verbose
+
+scaledMult :: Scaled a -> Mult
+scaledMult (Scaled m _) = m
+
+scaledThing :: Scaled a -> a
+scaledThing (Scaled _ t) = t
+
+-- | Apply a function to both the Mult and the Type in a 'Scaled Type'
+mapScaledType :: (Type -> Type) -> Scaled Type -> Scaled Type
+mapScaledType f (Scaled m t) = Scaled (f m) (f t)
+
+{- |
+Mult is a type alias for Type.
+
+Mult must contain Type because multiplicity variables are mere type variables
+(of kind Multiplicity) in Haskell. So the simplest implementation is to make
+Mult be Type.
+
+Multiplicities can be formed with:
+- One: GHC.Types.One (= oneDataCon)
+- Many: GHC.Types.Many (= manyDataCon)
+- Multiplication: GHC.Types.MultMul (= multMulTyCon)
+
+So that Mult feels a bit more structured, we provide pattern synonyms and smart
+constructors for these.
+-}
+type Mult = Type
diff --git a/compiler/GHC/Core/TyCo/Rep.hs-boot b/compiler/GHC/Core/TyCo/Rep.hs-boot
index 25a22435cf..7bc1eb4f81 100644
--- a/compiler/GHC/Core/TyCo/Rep.hs-boot
+++ b/compiler/GHC/Core/TyCo/Rep.hs-boot
@@ -12,6 +12,9 @@ data TyLit
 data TyCoBinder
 data MCoercion
 
+data Scaled a
+type Mult = Type
+
 type PredType = Type
 type Kind = Type
 type ThetaType = [PredType]
diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs
index 88799c2414..b3f51739b5 100644
--- a/compiler/GHC/Core/TyCo/Subst.hs
+++ b/compiler/GHC/Core/TyCo/Subst.hs
@@ -65,11 +65,10 @@ import {-# SOURCE #-} GHC.Core.Coercion
    , mkInstCo, mkLRCo, mkTyConAppCo
    , mkCoercionType
    , coercionKind, coercionLKind, coVarKindsTypesRole )
+import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprTyVar )
 
 import GHC.Core.TyCo.Rep
 import GHC.Core.TyCo.FVs
-import GHC.Core.TyCo.Ppr
-import GHC.Core.Multiplicity
 
 import GHC.Types.Var
 import GHC.Types.Var.Set
@@ -733,12 +732,15 @@ subst_ty subst ty
    = go ty
   where
     go (TyVarTy tv)      = substTyVar subst tv
-    go (AppTy fun arg)   = mkAppTy (go fun) $! (go arg)
+    go (AppTy fun arg)   = (mkAppTy $! (go fun)) $! (go arg)
                 -- The mkAppTy smart constructor is important
                 -- we might be replacing (a Int), represented with App
                 -- by [Int], represented with TyConApp
-    go (TyConApp tc tys) = let args = map go tys
-                           in  args `seqList` TyConApp tc args
+    go ty@(TyConApp tc []) = tc `seq` ty  -- avoid allocation in this common case
+    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
     go ty@(FunTy { ft_mult = mult, ft_arg = arg, ft_res = res })
       = let !mult' = go mult
             !arg' = go arg
@@ -846,7 +848,7 @@ subst_co subst co
 
     -- See Note [Substituting in a coercion hole]
     go_hole h@(CoercionHole { ch_co_var = cv })
-      = h { ch_co_var = updateVarTypeAndMult go_ty cv }
+      = h { ch_co_var = updateVarType go_ty cv }
 
 substForAllCoBndr :: TCvSubst -> TyCoVar -> KindCoercion
                   -> (TCvSubst, TyCoVar, Coercion)
diff --git a/compiler/GHC/Core/TyCo/Tidy.hs b/compiler/GHC/Core/TyCo/Tidy.hs
index bc586d77c8..dd07a2775f 100644
--- a/compiler/GHC/Core/TyCo/Tidy.hs
+++ b/compiler/GHC/Core/TyCo/Tidy.hs
@@ -52,7 +52,7 @@ tidyVarBndr tidy_env@(occ_env, subst) var
       (occ_env', occ') -> ((occ_env', subst'), var')
         where
           subst' = extendVarEnv subst var var'
-          var'   = updateVarTypeAndMult (tidyType tidy_env) (setVarName var name')
+          var'   = updateVarType (tidyType tidy_env) (setVarName var name')
           name'  = tidyNameOcc name occ'
           name   = varName var
 
@@ -119,7 +119,7 @@ tidyOpenTyCoVar env@(_, subst) tyvar
 tidyTyCoVarOcc :: TidyEnv -> TyCoVar -> TyCoVar
 tidyTyCoVarOcc env@(_, subst) tv
   = case lookupVarEnv subst tv of
-        Nothing  -> updateVarTypeAndMult (tidyType env) tv
+        Nothing  -> updateVarType (tidyType env) tv
         Just tv' -> tv'
 
 ---------------