IfaceToType: Ensure that IfaceTyConInfo is shared

In #19194 mpickering detailed that there are a LOT of allocations
of IfaceTyConInfo:

There are just two main cases: IfaceTyConInfo IsPromoted IfaceNormalTyCon
and IfaceTyConInfo NotPromoted IfaceNormalTyCon. These should be made into
CAFs and shared. From my analysis, the most common case is
IfaceTyConInfo NotPromoted IfaceNormalTyCon (53 000)
then IfaceTyConInfo IsPromoted IfaceNormalTyCon (28 000).

This patch makes it so these are properly shared by using a smart
constructor.

Fixes #19194.

3 files changed, 18 insertions, 9 deletions

diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs
index 1437208925..d48686b615 100644
--- a/compiler/GHC/CoreToIface.hs
+++ b/compiler/GHC/CoreToIface.hs
@@ -194,7 +194,7 @@ toIfaceTypeX fr (TyConApp tc tys)
 
   | tc `elem` [ eqPrimTyCon, eqReprPrimTyCon, heqTyCon ]
   , (k1:k2:_) <- tys
-  = let info = IfaceTyConInfo NotPromoted sort
+  = let info = mkIfaceTyConInfo NotPromoted sort
         sort | k1 `eqType` k2 = IfaceEqualityTyCon
              | otherwise      = IfaceNormalTyCon
     in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgsX fr tc tys)
@@ -224,7 +224,7 @@ toIfaceTyCon tc
   = IfaceTyCon tc_name info
   where
     tc_name = tyConName tc
-    info    = IfaceTyConInfo promoted sort
+    info    = mkIfaceTyConInfo promoted sort
     promoted | isPromotedDataCon tc = IsPromoted
              | otherwise            = NotPromoted
 
@@ -252,7 +252,7 @@ toIfaceTyCon tc
 
 toIfaceTyCon_name :: Name -> IfaceTyCon
 toIfaceTyCon_name n = IfaceTyCon n info
-  where info = IfaceTyConInfo NotPromoted IfaceNormalTyCon
+  where info = mkIfaceTyConInfo NotPromoted IfaceNormalTyCon
   -- Used for the "rough-match" tycon stuff,
   -- where pretty-printing is not an issue
 
diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs
index 21b4274cc7..908d105de0 100644
--- a/compiler/GHC/Iface/Syntax.hs
+++ b/compiler/GHC/Iface/Syntax.hs
@@ -802,7 +802,7 @@ pprClassStandaloneKindSig ss clas =
 
 constraintIfaceKind :: IfaceKind
 constraintIfaceKind =
-  IfaceTyConApp (IfaceTyCon constraintKindTyConName (IfaceTyConInfo NotPromoted IfaceNormalTyCon)) IA_Nil
+  IfaceTyConApp (IfaceTyCon constraintKindTyConName (mkIfaceTyConInfo NotPromoted IfaceNormalTyCon)) IA_Nil
 
 pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc
 -- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi
diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs
index ae0d592959..b90676f062 100644
--- a/compiler/GHC/Iface/Type.hs
+++ b/compiler/GHC/Iface/Type.hs
@@ -21,7 +21,9 @@ module GHC.Iface.Type (
         IfaceMCoercion(..),
         IfaceUnivCoProv(..),
         IfaceMult,
-        IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyConSort(..),
+        IfaceTyCon(..),
+        IfaceTyConInfo(..), mkIfaceTyConInfo,
+        IfaceTyConSort(..),
         IfaceTyLit(..), IfaceAppArgs(..),
         IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr,
         IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder,
@@ -355,6 +357,13 @@ data IfaceTyConInfo   -- Used to guide pretty-printing
                    , ifaceTyConSort       :: IfaceTyConSort }
     deriving (Eq)
 
+-- This smart constructor allows sharing of the two most common
+-- cases. See #19194
+mkIfaceTyConInfo :: PromotionFlag -> IfaceTyConSort -> IfaceTyConInfo
+mkIfaceTyConInfo IsPromoted  IfaceNormalTyCon = IfaceTyConInfo IsPromoted  IfaceNormalTyCon
+mkIfaceTyConInfo NotPromoted IfaceNormalTyCon = IfaceTyConInfo NotPromoted IfaceNormalTyCon
+mkIfaceTyConInfo prom        sort             = IfaceTyConInfo prom        sort
+
 data IfaceMCoercion
   = IfaceMRefl
   | IfaceMCo IfaceCoercion
@@ -1102,12 +1111,12 @@ liftedRep_ty =
   IfaceTyConApp liftedRep IA_Nil
   where
     liftedRep :: IfaceTyCon
-    liftedRep = IfaceTyCon tc_name (IfaceTyConInfo NotPromoted IfaceNormalTyCon)
+    liftedRep = IfaceTyCon tc_name (mkIfaceTyConInfo NotPromoted IfaceNormalTyCon)
       where tc_name = getName liftedRepTyCon
 
 many_ty :: IfaceType
 many_ty =
-    IfaceTyConApp (IfaceTyCon dc_name (IfaceTyConInfo IsPromoted IfaceNormalTyCon))
+    IfaceTyConApp (IfaceTyCon dc_name (mkIfaceTyConInfo IsPromoted IfaceNormalTyCon))
                   IA_Nil
   where dc_name = getName manyDataConTyCon
 
@@ -1629,7 +1638,7 @@ pprTuple ctxt_prec sort promoted args =
         -- `Solo x`, not `(x)`
       | [_] <- args_wo_runtime_reps
       , BoxedTuple <- sort
-      = let unit_tc_info = IfaceTyConInfo promoted IfaceNormalTyCon
+      = let unit_tc_info = mkIfaceTyConInfo promoted IfaceNormalTyCon
             unit_tc = IfaceTyCon (tupleTyConName sort 1) unit_tc_info in
         pprPrecIfaceType ctxt_prec $ IfaceTyConApp unit_tc args
       | otherwise
@@ -1780,7 +1789,7 @@ instance Binary IfaceTyConSort where
 instance Binary IfaceTyConInfo where
    put_ bh (IfaceTyConInfo i s) = put_ bh i >> put_ bh s
 
-   get bh = IfaceTyConInfo <$> get bh <*> get bh
+   get bh = mkIfaceTyConInfo <$> get bh <*> get bh
 
 instance Outputable IfaceTyLit where
   ppr = pprIfaceTyLit