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

16 files changed, 21 insertions, 29 deletions

diff --git a/compiler/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs
index a1af9166fe..3ccfb83cf7 100644
--- a/compiler/GHC/Tc/Deriv/Functor.hs
+++ b/compiler/GHC/Tc/Deriv/Functor.hs
@@ -40,7 +40,6 @@ import GHC.Tc.Utils.TcType
 import GHC.Core.TyCon
 import GHC.Core.TyCo.Rep
 import GHC.Core.Type
-import GHC.Core.Multiplicity
 import GHC.Utils.Misc
 import GHC.Types.Var
 import GHC.Types.Var.Set
diff --git a/compiler/GHC/Tc/Deriv/Infer.hs b/compiler/GHC/Tc/Deriv/Infer.hs
index 17eff9a74b..f110b8c7f2 100644
--- a/compiler/GHC/Tc/Deriv/Infer.hs
+++ b/compiler/GHC/Tc/Deriv/Infer.hs
@@ -41,7 +41,6 @@ import GHC.Tc.Utils.TcType
 import GHC.Core.TyCon
 import GHC.Core.TyCo.Ppr (pprTyVars)
 import GHC.Core.Type
-import GHC.Core.Multiplicity
 import GHC.Tc.Solver
 import GHC.Tc.Validity (validDerivPred)
 import GHC.Tc.Utils.Unify (buildImplicationFor, checkConstraints)
diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs
index 2edce28eac..ebfe1e3003 100644
--- a/compiler/GHC/Tc/Errors/Hole.hs
+++ b/compiler/GHC/Tc/Errors/Hole.hs
@@ -462,7 +462,7 @@ pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) =
            -- into [m, a]
            unwrapTypeVars :: Type -> [TyCoVarBinder]
            unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of
-                               Just (_, unfunned) -> unwrapTypeVars unfunned
+                               Just (_, _, unfunned) -> unwrapTypeVars unfunned
                                _ -> []
              where (vars, unforalled) = splitForAllVarBndrs t
        holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) hfMatches
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index fecd8b9b2e..d0da974326 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -88,7 +88,6 @@ import GHC.Core.TyCo.Ppr
 import GHC.Tc.Errors      ( reportAllUnsolved )
 import GHC.Tc.Utils.TcType
 import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBinder )
-import GHC.Core.Multiplicity
 import GHC.Core.Type
 import GHC.Builtin.Types.Prim
 import GHC.Types.Name.Reader( lookupLocalRdrOcc )
diff --git a/compiler/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs
index 49de48cebd..723c07ec50 100644
--- a/compiler/GHC/Tc/Gen/Rule.hs
+++ b/compiler/GHC/Tc/Gen/Rule.hs
@@ -28,7 +28,6 @@ import GHC.Tc.Utils.Unify( buildImplicationFor )
 import GHC.Tc.Types.Evidence( mkTcCoVarCo )
 import GHC.Core.Type
 import GHC.Core.TyCon( isTypeFamilyTyCon )
-import GHC.Core.Multiplicity
 import GHC.Types.Id
 import GHC.Types.Var( EvVar )
 import GHC.Types.Var.Set
diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs
index 642e303442..f2f4065bc0 100644
--- a/compiler/GHC/Tc/Instance/Class.hs
+++ b/compiler/GHC/Tc/Instance/Class.hs
@@ -32,7 +32,6 @@ import GHC.Builtin.Names
 
 import GHC.Types.Id
 import GHC.Core.Type
-import GHC.Core.Multiplicity
 import GHC.Core.Make ( mkStringExprFS, mkNaturalExpr )
 
 import GHC.Types.Name   ( Name, pprDefinedAt )
@@ -423,7 +422,7 @@ matchTypeable clas [k,t]  -- clas = Typeable
   | k `eqType` typeNatKind                 = doTyLit knownNatClassName         t
   | k `eqType` typeSymbolKind              = doTyLit knownSymbolClassName      t
   | tcIsConstraintKind t                   = doTyConApp clas t constraintKindTyCon []
-  | Just (arg,ret) <- splitFunTy_maybe t   = doFunTy    clas t arg ret
+  | Just (mult,arg,ret) <- splitFunTy_maybe t   = doFunTy    clas t mult arg ret
   | Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)]
   , onlyNamedBndrsApplied tc ks            = doTyConApp clas t tc ks
   | Just (f,kt)   <- splitAppTy_maybe t    = doTyApp    clas t f kt
@@ -431,8 +430,8 @@ matchTypeable clas [k,t]  -- clas = Typeable
 matchTypeable _ _ = return NoInstance
 
 -- | Representation for a type @ty@ of the form @arg -> ret@.
-doFunTy :: Class -> Type -> Scaled Type -> Type -> TcM ClsInstResult
-doFunTy clas ty (Scaled mult arg_ty) ret_ty
+doFunTy :: Class -> Type -> Mult -> Type -> Type -> TcM ClsInstResult
+doFunTy clas ty mult arg_ty ret_ty
   = return $ OneInst { cir_new_theta = preds
                      , cir_mk_ev     = mk_ev
                      , cir_what      = BuiltinInstance }
diff --git a/compiler/GHC/Tc/Instance/Typeable.hs b/compiler/GHC/Tc/Instance/Typeable.hs
index a7b3d83e09..bed5779a8d 100644
--- a/compiler/GHC/Tc/Instance/Typeable.hs
+++ b/compiler/GHC/Tc/Instance/Typeable.hs
@@ -34,7 +34,6 @@ import GHC.Types.Id
 import GHC.Core.Type
 import GHC.Core.TyCon
 import GHC.Core.DataCon
-import GHC.Core.Multiplicity
 import GHC.Unit.Module
 import GHC.Hs
 import GHC.Driver.Session
diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs
index 79b42d29d5..cf0255b6c5 100644
--- a/compiler/GHC/Tc/Solver/Canonical.hs
+++ b/compiler/GHC/Tc/Solver/Canonical.hs
@@ -2526,7 +2526,7 @@ unify_derived loc role    orig_ty1 orig_ty2
     go (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2)
       = do { unify_derived loc role s1 s2
            ; unify_derived loc role t1 t2
-           ; unify_derived loc role w1 w2 }
+           ; unify_derived loc Nominal w1 w2 }
     go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
       | tc1 == tc2, tys1 `equalLength` tys2
       , isInjectiveTyCon tc1 role
diff --git a/compiler/GHC/Tc/Solver/Flatten.hs b/compiler/GHC/Tc/Solver/Flatten.hs
index 48249caa5c..2c3f020f68 100644
--- a/compiler/GHC/Tc/Solver/Flatten.hs
+++ b/compiler/GHC/Tc/Solver/Flatten.hs
@@ -39,8 +39,6 @@ import Data.Foldable ( foldrM )
 
 import Control.Arrow ( first )
 
-import GHC.Core.Multiplicity
-
 {-
 Note [The flattening story]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1180,7 +1178,7 @@ flatten_one (TyConApp tc tys)
 flatten_one ty@(FunTy { ft_mult = mult, ft_arg = ty1, ft_res = ty2 })
   = do { (xi1,co1) <- flatten_one ty1
        ; (xi2,co2) <- flatten_one ty2
-       ; (xi3,co3) <- flatten_one mult
+       ; (xi3,co3) <- setEqRel NomEq $ flatten_one mult
        ; role <- getRole
        ; return (ty { ft_mult = xi3, ft_arg = xi1, ft_res = xi2 }
                 , mkFunCo role co3 co1 co2) }
@@ -1921,12 +1919,14 @@ Flatten using the fun-eqs first.
 split_pi_tys' :: Type -> ([TyCoBinder], Type, Bool)
 split_pi_tys' ty = split ty ty
   where
-  split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty'
+     -- put common cases first
   split _       (ForAllTy b res) = let (bs, ty, _) = split res res
                                    in  (Named b : bs, ty, True)
   split _       (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res })
                                  = let (bs, ty, named) = split res res
                                    in  (Anon af (mkScaled w arg) : bs, ty, named)
+
+  split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty'
   split orig_ty _                = ([], orig_ty, False)
 {-# INLINE split_pi_tys' #-}
 
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index a4a56c0a14..edf7456b2c 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -824,9 +824,9 @@ swizzleTcTyConBndrs tc_infos
     swizzle_var :: Var -> Var
     swizzle_var v
       | Just nm <- lookupVarEnv swizzle_env v
-      = updateVarTypeAndMult swizzle_ty (v `setVarName` nm)
+      = updateVarType swizzle_ty (v `setVarName` nm)
       | otherwise
-      = updateVarTypeAndMult swizzle_ty v
+      = updateVarType swizzle_ty v
 
     (map_type, _, _, _) = mapTyCo swizzleMapper
     swizzle_ty ty = runIdentity (map_type ty)
@@ -4563,7 +4563,7 @@ checkValidRoles tc
       >> check_ty_roles env Nominal ty2
 
     check_ty_roles env role (FunTy _ w ty1 ty2)
-      =  check_ty_roles env role w
+      =  check_ty_roles env Nominal w
       >> check_ty_roles env role ty1
       >> check_ty_roles env role ty2
 
diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
index b49e81ddd2..a9557a2351 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
@@ -600,7 +600,7 @@ irType = go
                                           lcls' = extendVarSet lcls tv
                                     ; markNominal lcls (tyVarKind tv)
                                     ; go lcls' ty }
-    go lcls (FunTy _ w arg res)  = go lcls w >> go lcls arg >> go lcls res
+    go lcls (FunTy _ w arg res)  = markNominal lcls w >> go lcls arg >> go lcls res
     go _    (LitTy {})         = return ()
       -- See Note [Coercions in role inference]
     go lcls (CastTy ty _)      = go lcls ty
diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs
index 55c0ad4e67..eebe9eb8ed 100644
--- a/compiler/GHC/Tc/Utils/Env.hs
+++ b/compiler/GHC/Tc/Utils/Env.hs
@@ -113,7 +113,6 @@ import GHC.Data.Bag
 import GHC.Data.List.SetOps
 import GHC.Utils.Error
 import GHC.Data.Maybe( MaybeErr(..), orElse )
-import GHC.Core.Multiplicity
 import qualified GHC.LanguageExtensions as LangExt
 import GHC.Utils.Misc ( HasDebugCallStack )
 
diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs
index c33c335ac7..d2afbfb4ca 100644
--- a/compiler/GHC/Tc/Utils/TcMType.hs
+++ b/compiler/GHC/Tc/Utils/TcMType.hs
@@ -127,7 +127,6 @@ import GHC.Data.FastString
 import GHC.Data.Bag
 import GHC.Data.Pair
 import GHC.Types.Unique.Set
-import GHC.Core.Multiplicity
 import GHC.Driver.Session
 import qualified GHC.LanguageExtensions as LangExt
 import GHC.Types.Basic ( TypeOrKind(..) )
@@ -2040,7 +2039,7 @@ zonkImplication implic@(Implic { ic_skols  = skols
                         , ic_info   = info' }) }
 
 zonkEvVar :: EvVar -> TcM EvVar
-zonkEvVar var = updateVarTypeAndMultM zonkTcType var
+zonkEvVar var = updateIdTypeAndMultM zonkTcType var
 
 
 zonkWC :: WantedConstraints -> TcM WantedConstraints
@@ -2315,7 +2314,7 @@ tidyHole env h@(Hole { hole_ty = ty }) = h { hole_ty = tidyType env ty }
 
 ----------------
 tidyEvVar :: TidyEnv -> EvVar -> EvVar
-tidyEvVar env var = updateVarTypeAndMult (tidyType env) var
+tidyEvVar env var = updateIdTypeAndMult (tidyType env) var
 
 ----------------
 tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo
diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs
index f06cdd7d31..da6e71547f 100644
--- a/compiler/GHC/Tc/Utils/TcType.hs
+++ b/compiler/GHC/Tc/Utils/TcType.hs
@@ -200,7 +200,6 @@ import GHC.Core.TyCo.Subst ( mkTvSubst, substTyWithCoVars )
 import GHC.Core.TyCo.FVs
 import GHC.Core.TyCo.Ppr
 import GHC.Core.Class
-import GHC.Core.Multiplicity
 import GHC.Types.Var
 import GHC.Types.ForeignCall
 import GHC.Types.Var.Set
@@ -869,7 +868,7 @@ anyRewritableTyVar ignore_cos role pred ty
     go rl bvs (TyConApp tc tys)  = go_tc rl bvs tc tys
     go rl bvs (AppTy fun arg)    = go rl bvs fun || go NomEq bvs arg
     go rl bvs (FunTy _ w arg res)  = go NomEq bvs arg_rep || go NomEq bvs res_rep ||
-                                     go rl bvs arg || go rl bvs res || go rl bvs w
+                                     go rl bvs arg || go rl bvs res || go NomEq bvs w
       where arg_rep = getRuntimeRep arg -- forgetting these causes #17024
             res_rep = getRuntimeRep res
     go rl bvs (ForAllTy tv ty)   = go rl (bvs `extendVarSet` binderVar tv) ty
diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs
index a6711abcc1..75f4e83979 100644
--- a/compiler/GHC/Tc/Utils/Unify.hs
+++ b/compiler/GHC/Tc/Utils/Unify.hs
@@ -622,7 +622,7 @@ tc_sub_type unify inst_orig ctxt ty_actual ty_expected
   where
     possibly_poly ty
       | isForAllTy ty                        = True
-      | Just (_, res) <- splitFunTy_maybe ty = possibly_poly res
+      | Just (_, _, res) <- splitFunTy_maybe ty = possibly_poly res
       | otherwise                            = False
       -- NB *not* tcSplitFunTy, because here we want
       -- to decompose type-class arguments too
@@ -746,7 +746,8 @@ to a UserTypeCtxt of GenSigCtxt.  Why?
 -- only produce trivial evidence, then this check would happen in the constraint
 -- solver.
 tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper
-tcSubMult origin (MultMul w1 w2) w_expected =
+tcSubMult origin w_actual w_expected
+  | Just (w1, w2) <- isMultMul w_actual =
   do { w1 <- tcSubMult origin w1 w_expected
      ; w2 <- tcSubMult origin w2 w_expected
      ; return (w1 <.> w2) }
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 05eb4d9ba4..6dd6026841 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -402,7 +402,7 @@ zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
 -- Works for dictionaries and coercions
 -- Does not extend the ZonkEnv
 zonkEvBndr env var
-  = updateVarTypeAndMultM ({-# SCC "zonkEvBndr_zonkTcTypeToType" #-} zonkTcTypeToTypeX env) var
+  = updateIdTypeAndMultM ({-# SCC "zonkEvBndr_zonkTcTypeToType" #-} zonkTcTypeToTypeX env) var
 
 {-
 zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm
@@ -583,7 +583,7 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
       , (L loc bind@(FunBind { fun_id      = (L mloc mono_id)
                              , fun_matches = ms
                              , fun_ext     = co_fn })) <- lbind
-      = do { new_mono_id <- updateVarTypeAndMultM (zonkTcTypeToTypeX env) mono_id
+      = do { new_mono_id <- updateIdTypeAndMultM (zonkTcTypeToTypeX env) mono_id
                             -- Specifically /not/ zonkIdBndr; we do not
                             -- want to complain about a levity-polymorphic binder
            ; (env', new_co_fn) <- zonkCoFn env co_fn