From 7e9debd4ceb068effe8ac81892d2cabcb8f55850 Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Tue, 24 Mar 2020 13:13:43 -0400
Subject: [PATCH] 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
---
compiler/GHC/Builtin/Types.hs | 9 +-
compiler/GHC/Builtin/Types/Prim.hs | 4 -
compiler/GHC/Builtin/Types/Prim.hs-boot | 5 +
compiler/GHC/Core/TyCo/Rep.hs | 85 +++++++++++---
compiler/GHC/Core/TyCo/Subst.hs | 4 +-
compiler/GHC/Core/TyCon.hs | 14 ++-
compiler/GHC/Core/Type.hs | 107 ++++++++++++++----
compiler/GHC/Core/Unify.hs | 7 +-
compiler/GHC/Tc/Solver/Canonical.hs | 5 +
compiler/GHC/Tc/Utils/TcMType.hs | 1 -
compiler/GHC/Tc/Utils/TcType.hs | 5 +
.../tests/deSugar/should_compile/T2431.stderr | 6 +-
.../deriving/should_compile/T14578.stderr | 7 +-
testsuite/tests/plugins/plugins09.stdout | 1 -
testsuite/tests/plugins/plugins10.stdout | 1 -
testsuite/tests/plugins/plugins11.stdout | 1 -
testsuite/tests/plugins/static-plugins.stdout | 4 +-
testsuite/tests/printer/T18052a.stderr | 6 +-
.../simplCore/should_compile/T13143.stderr | 6 +-
.../simplCore/should_compile/T18013.stderr | 4 +-
.../simplCore/should_compile/T7360.stderr | 4 +-
.../typecheck/should_compile/T13032.stderr | 4 +-
utils/haddock | 2 +-
23 files changed, 214 insertions(+), 78 deletions(-)
create mode 100644 compiler/GHC/Builtin/Types/Prim.hs-boot
diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs
index d06bc4a12b4c..3339e0a02079 100644
--- a/compiler/GHC/Builtin/Types.hs
+++ b/compiler/GHC/Builtin/Types.hs
@@ -170,6 +170,7 @@ import GHC.Types.Var (VarBndr (Bndr))
import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE )
import GHC.Unit.Module ( Module )
import GHC.Core.Type
+import qualified GHC.Core.TyCo.Rep as TyCoRep (Type(TyConApp))
import GHC.Types.RepType
import GHC.Core.DataCon
import GHC.Core.ConLike
@@ -688,8 +689,9 @@ constraintKindTyCon :: TyCon
-- 'TyCon.isConstraintKindCon' assumes that this is an AlgTyCon!
constraintKindTyCon = pcTyCon constraintKindTyConName Nothing [] []
+-- See Note [Prefer Type over TYPE 'LiftedRep] in GHC.Core.TyCo.Rep.
liftedTypeKind, typeToTypeKind, constraintKind :: Kind
-liftedTypeKind = tYPE liftedRepTy
+liftedTypeKind = TyCoRep.TyConApp liftedTypeKindTyCon []
typeToTypeKind = liftedTypeKind `mkVisFunTyMany` liftedTypeKind
constraintKind = mkTyConApp constraintKindTyCon []
@@ -1410,11 +1412,12 @@ runtimeRepTy :: Type
runtimeRepTy = mkTyConTy runtimeRepTyCon
-- Type synonyms; see Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim
+-- and Note [Prefer Type over TYPE 'LiftedRep] in GHC.Core.TyCo.Rep.
-- type Type = tYPE 'LiftedRep
liftedTypeKindTyCon :: TyCon
liftedTypeKindTyCon = buildSynTyCon liftedTypeKindTyConName
- [] liftedTypeKind []
- (tYPE liftedRepTy)
+ [] liftedTypeKind [] rhs
+ where rhs = TyCoRep.TyConApp tYPETyCon [liftedRepTy]
runtimeRepTyCon :: TyCon
runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing []
diff --git a/compiler/GHC/Builtin/Types/Prim.hs b/compiler/GHC/Builtin/Types/Prim.hs
index fc74596e45c3..61f341a0bb6e 100644
--- a/compiler/GHC/Builtin/Types/Prim.hs
+++ b/compiler/GHC/Builtin/Types/Prim.hs
@@ -551,10 +551,6 @@ mkPrimTcName built_in_syntax occ key tycon
= mkWiredInName gHC_PRIM (mkTcOccFS occ) key (mkATyCon tycon) built_in_syntax
-----------------------------
--- | Given a RuntimeRep, applies TYPE to it.
--- see Note [TYPE and RuntimeRep]
-tYPE :: Type -> Type
-tYPE rr = TyConApp tYPETyCon [rr]
-- Given a Multiplicity, applies FUN to it.
functionWithMultiplicity :: Type -> Type
diff --git a/compiler/GHC/Builtin/Types/Prim.hs-boot b/compiler/GHC/Builtin/Types/Prim.hs-boot
new file mode 100644
index 000000000000..28326fcc8bca
--- /dev/null
+++ b/compiler/GHC/Builtin/Types/Prim.hs-boot
@@ -0,0 +1,5 @@
+module GHC.Builtin.Types.Prim where
+
+import GHC.Core.TyCon
+
+tYPETyCon :: TyCon
diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs
index 0be6824b9da9..be7bdb3aef5c 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 64e0c9ccbb81..bc6632f1bf3a 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 198b66959bb3..a038fd646cd8 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 3164e2626beb..e5d0da93fd88 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 709ccf10b48d..29d2ae975ceb 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
diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs
index fd608c33149d..ce8bf2463296 100644
--- a/compiler/GHC/Tc/Solver/Canonical.hs
+++ b/compiler/GHC/Tc/Solver/Canonical.hs
@@ -956,6 +956,11 @@ can_eq_nc'
-> Type -> Type -- RHS, after and before type-synonym expansion, resp
-> TcS (StopOrContinue Ct)
+-- See Note [Comparing nullary type synonyms] in GHC.Core.Type.
+can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1@(TyConApp tc1 []) _ps_ty1 (TyConApp tc2 []) _ps_ty2
+ | tc1 == tc2
+ = canEqReflexive ev eq_rel ty1
+
-- Expand synonyms first; see Note [Type synonyms and canonicalization]
can_eq_nc' rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
| Just ty1' <- tcView ty1 = can_eq_nc' rewritten rdr_env envs ev eq_rel ty1' ps_ty1 ty2 ps_ty2
diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs
index ccb9152e01a1..e688dd568526 100644
--- a/compiler/GHC/Tc/Utils/TcMType.hs
+++ b/compiler/GHC/Tc/Utils/TcMType.hs
@@ -120,7 +120,6 @@ import GHC.Types.Id as Id
import GHC.Types.Name
import GHC.Types.Var.Set
import GHC.Builtin.Types
-import GHC.Builtin.Types.Prim
import GHC.Types.Var.Env
import GHC.Types.Name.Env
import GHC.Utils.Misc
diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs
index 3e52419772b4..6e4eea8f19ce 100644
--- a/compiler/GHC/Tc/Utils/TcType.hs
+++ b/compiler/GHC/Tc/Utils/TcType.hs
@@ -1581,6 +1581,11 @@ tc_eq_type keep_syns vis_only orig_ty1 orig_ty2
= go orig_env orig_ty1 orig_ty2
where
go :: RnEnv2 -> Type -> Type -> Bool
+ -- See Note [Comparing nullary type synonyms] in GHC.Core.Type.
+ go _ (TyConApp tc1 []) (TyConApp tc2 [])
+ | tc1 == tc2
+ = True
+
go env t1 t2 | not keep_syns, Just t1' <- tcView t1 = go env t1' t2
go env t1 t2 | not keep_syns, Just t2' <- tcView t2 = go env t1 t2'
diff --git a/testsuite/tests/deSugar/should_compile/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr
index 86d74c2d3560..6e7df6c5de8e 100644
--- a/testsuite/tests/deSugar/should_compile/T2431.stderr
+++ b/testsuite/tests/deSugar/should_compile/T2431.stderr
@@ -1,9 +1,9 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 63, types: 43, coercions: 1, joins: 0/0}
+ = {terms: 63, types: 39, coercions: 1, joins: 0/0}
--- RHS size: {terms: 2, types: 4, coercions: 1, joins: 0/0}
+-- RHS size: {terms: 2, types: 3, coercions: 1, joins: 0/0}
T2431.$WRefl [InlPrag=INLINE[final] CONLIKE] :: forall a. a :~: a
[GblId[DataConWrapper],
Caf=NoCafRefs,
@@ -15,7 +15,7 @@ T2431.$WRefl [InlPrag=INLINE[final] CONLIKE] :: forall a. a :~: a
T2431.$WRefl
= \ (@a) -> T2431.Refl @a @a @~(<a>_N :: a GHC.Prim.~# a)
--- RHS size: {terms: 4, types: 8, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 4, types: 7, coercions: 0, joins: 0/0}
absurd :: forall a. (Int :~: Bool) -> a
[GblId, Arity=1, Str=<U>b, Cpr=b, Unf=OtherCon []]
absurd = \ (@a) (x :: Int :~: Bool) -> case x of { }
diff --git a/testsuite/tests/deriving/should_compile/T14578.stderr b/testsuite/tests/deriving/should_compile/T14578.stderr
index 0018ebe569ea..d93f12c34cec 100644
--- a/testsuite/tests/deriving/should_compile/T14578.stderr
+++ b/testsuite/tests/deriving/should_compile/T14578.stderr
@@ -16,13 +16,12 @@ Derived class instances:
= GHC.Prim.coerce
@(T14578.App (Data.Functor.Compose.Compose f g) a
-> T14578.App (Data.Functor.Compose.Compose f g) a
- -> T14578.App (Data.Functor.Compose.Compose f g) a)
+ -> T14578.App (Data.Functor.Compose.Compose f g) a)
@(T14578.Wat f g a -> T14578.Wat f g a -> T14578.Wat f g a)
((GHC.Base.<>) @(T14578.App (Data.Functor.Compose.Compose f g) a))
GHC.Base.sconcat
= GHC.Prim.coerce
- @(GHC.Base.NonEmpty
- (T14578.App (Data.Functor.Compose.Compose f g) a)
+ @(GHC.Base.NonEmpty (T14578.App (Data.Functor.Compose.Compose f g) a)
-> T14578.App (Data.Functor.Compose.Compose f g) a)
@(GHC.Base.NonEmpty (T14578.Wat f g a) -> T14578.Wat f g a)
(GHC.Base.sconcat
@@ -31,7 +30,7 @@ Derived class instances:
= GHC.Prim.coerce
@(b
-> T14578.App (Data.Functor.Compose.Compose f g) a
- -> T14578.App (Data.Functor.Compose.Compose f g) a)
+ -> T14578.App (Data.Functor.Compose.Compose f g) a)
@(b -> T14578.Wat f g a -> T14578.Wat f g a)
(GHC.Base.stimes
@(T14578.App (Data.Functor.Compose.Compose f g) a))
diff --git a/testsuite/tests/plugins/plugins09.stdout b/testsuite/tests/plugins/plugins09.stdout
index 04019417345d..61f96283ff34 100644
--- a/testsuite/tests/plugins/plugins09.stdout
+++ b/testsuite/tests/plugins/plugins09.stdout
@@ -3,6 +3,5 @@ interfacePlugin: Prelude
interfacePlugin: GHC.Float
interfacePlugin: GHC.Base
typeCheckPlugin (rn)
-interfacePlugin: GHC.Types
typeCheckPlugin (tc)
interfacePlugin: GHC.Num.BigNat
diff --git a/testsuite/tests/plugins/plugins10.stdout b/testsuite/tests/plugins/plugins10.stdout
index ed31df86f1fe..37f424b07696 100644
--- a/testsuite/tests/plugins/plugins10.stdout
+++ b/testsuite/tests/plugins/plugins10.stdout
@@ -6,7 +6,6 @@ interfacePlugin: GHC.Float
interfacePlugin: GHC.Base
interfacePlugin: Language.Haskell.TH.Syntax
typeCheckPlugin (rn)
-interfacePlugin: GHC.Types
typeCheckPlugin (tc)
interfacePlugin: GHC.Num.BigNat
parsePlugin(a)
diff --git a/testsuite/tests/plugins/plugins11.stdout b/testsuite/tests/plugins/plugins11.stdout
index b273bc7a106f..6bab3559b192 100644
--- a/testsuite/tests/plugins/plugins11.stdout
+++ b/testsuite/tests/plugins/plugins11.stdout
@@ -3,6 +3,5 @@ interfacePlugin: Prelude
interfacePlugin: GHC.Float
interfacePlugin: GHC.Base
typeCheckPlugin (rn)
-interfacePlugin: GHC.Types
typeCheckPlugin (tc)
interfacePlugin: GHC.Num.BigNat
diff --git a/testsuite/tests/plugins/static-plugins.stdout b/testsuite/tests/plugins/static-plugins.stdout
index 632af0076cea..032992824f1d 100644
--- a/testsuite/tests/plugins/static-plugins.stdout
+++ b/testsuite/tests/plugins/static-plugins.stdout
@@ -5,11 +5,11 @@ interfacePlugin: GHC.Float
interfacePlugin: GHC.Base
interfacePlugin: System.IO
typeCheckPlugin (rn)
-interfacePlugin: GHC.Prim
-interfacePlugin: GHC.Show
interfacePlugin: GHC.Types
+interfacePlugin: GHC.Show
interfacePlugin: GHC.TopHandler
typeCheckPlugin (tc)
+interfacePlugin: GHC.Prim
interfacePlugin: GHC.CString
interfacePlugin: GHC.Num.BigNat
==pure.1
diff --git a/testsuite/tests/printer/T18052a.stderr b/testsuite/tests/printer/T18052a.stderr
index 582a14a32c64..28c96670cdf5 100644
--- a/testsuite/tests/printer/T18052a.stderr
+++ b/testsuite/tests/printer/T18052a.stderr
@@ -10,9 +10,9 @@ Dependent packages: [base-4.16.0.0, ghc-bignum-1.0, ghc-prim-0.8.0]
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 24, types: 61, coercions: 0, joins: 0/0}
+ = {terms: 24, types: 52, coercions: 0, joins: 0/0}
--- RHS size: {terms: 7, types: 8, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 7, types: 6, coercions: 0, joins: 0/0}
T18052a.$b:||: :: forall {a} {b}. a -> b -> (a, b)
[GblId, Arity=2, Unf=OtherCon []]
T18052a.$b:||: = \ (@a) (@b) (x :: a) (y :: b) -> (x, y)
@@ -22,7 +22,7 @@ T18052a.$b:||: = \ (@a) (@b) (x :: a) (y :: b) -> (x, y)
[GblId]
(+++) = ++
--- RHS size: {terms: 13, types: 20, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 13, types: 18, coercions: 0, joins: 0/0}
T18052a.$m:||:
:: forall {rep :: GHC.Types.RuntimeRep} {r :: TYPE rep} {a} {b}.
(a, b) -> (a -> b -> r) -> ((# #) -> r) -> r
diff --git a/testsuite/tests/simplCore/should_compile/T13143.stderr b/testsuite/tests/simplCore/should_compile/T13143.stderr
index 44ab56542580..c2bc42a87235 100644
--- a/testsuite/tests/simplCore/should_compile/T13143.stderr
+++ b/testsuite/tests/simplCore/should_compile/T13143.stderr
@@ -1,17 +1,17 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 71, types: 44, coercions: 0, joins: 0/0}
+ = {terms: 71, types: 40, coercions: 0, joins: 0/0}
Rec {
--- RHS size: {terms: 4, types: 4, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 4, types: 3, coercions: 0, joins: 0/0}
T13143.$wf [InlPrag=NOINLINE, Occ=LoopBreaker]
:: forall {a}. (# #) -> a
[GblId, Arity=1, Str=<B>b, Cpr=b, Unf=OtherCon []]
T13143.$wf = \ (@a) _ [Occ=Dead] -> T13143.$wf @a GHC.Prim.(##)
end Rec }
--- RHS size: {terms: 4, types: 4, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 4, types: 3, coercions: 0, joins: 0/0}
f [InlPrag=[final]] :: forall a. Int -> a
[GblId,
Arity=1,
diff --git a/testsuite/tests/simplCore/should_compile/T18013.stderr b/testsuite/tests/simplCore/should_compile/T18013.stderr
index 51e30a9f75e8..20cb606cb498 100644
--- a/testsuite/tests/simplCore/should_compile/T18013.stderr
+++ b/testsuite/tests/simplCore/should_compile/T18013.stderr
@@ -129,9 +129,9 @@ Rule fired: Class op fmap (BUILTIN)
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 52, types: 106, coercions: 17, joins: 0/1}
+ = {terms: 52, types: 101, coercions: 17, joins: 0/1}
--- RHS size: {terms: 37, types: 87, coercions: 17, joins: 0/1}
+-- RHS size: {terms: 37, types: 84, coercions: 17, joins: 0/1}
mapMaybeRule
:: forall a b. Rule IO a b -> Rule IO (Maybe a) (Maybe b)
[GblId,
diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr
index 73bafb04f636..21fe15d4f544 100644
--- a/testsuite/tests/simplCore/should_compile/T7360.stderr
+++ b/testsuite/tests/simplCore/should_compile/T7360.stderr
@@ -1,7 +1,7 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 106, types: 47, coercions: 0, joins: 0/0}
+ = {terms: 106, types: 45, coercions: 0, joins: 0/0}
-- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0}
T7360.$WFoo3 [InlPrag=INLINE[final] CONLIKE] :: Int %1 -> Foo
@@ -31,7 +31,7 @@ T7360.fun4 :: ()
WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 20 0}]
T7360.fun4 = fun1 T7360.Foo1
--- RHS size: {terms: 11, types: 8, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 11, types: 7, coercions: 0, joins: 0/0}
fun2 :: forall {a}. [a] -> ((), Int)
[GblId,
Arity=1,
diff --git a/testsuite/tests/typecheck/should_compile/T13032.stderr b/testsuite/tests/typecheck/should_compile/T13032.stderr
index 596d09a927a2..3855f728c5b7 100644
--- a/testsuite/tests/typecheck/should_compile/T13032.stderr
+++ b/testsuite/tests/typecheck/should_compile/T13032.stderr
@@ -1,9 +1,9 @@
==================== Desugar (after optimization) ====================
Result size of Desugar (after optimization)
- = {terms: 13, types: 24, coercions: 0, joins: 0/0}
+ = {terms: 13, types: 18, coercions: 0, joins: 0/0}
--- RHS size: {terms: 6, types: 11, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 6, types: 8, coercions: 0, joins: 0/0}
f :: forall a b. (a ~ b) => a -> b -> Bool
[LclIdX,
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
diff --git a/utils/haddock b/utils/haddock
index acf235d60787..48c4982646b7 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit acf235d607879eb9542127eb0ddb42a250b5b850
+Subproject commit 48c4982646b7fe6343ccdf1581c97a7735fe8940
--
GitLab