Use a more efficient printer for code generation (#21853)wip/efficient-codegen

The changes in `GHC.Utils.Outputable` are the bulk of the patch
and drive the rest.
The types `HLine` and `HDoc` in Outputable can be used instead of `SDoc`
and support printing directly to a handle with `bPutHDoc`.
See Note [SDoc versus HDoc] and Note [HLine versus HDoc].

The classes `IsLine` and `IsDoc` are used to make the existing code polymorphic
over `HLine`/`HDoc` and `SDoc`. This is done for X86, PPC, AArch64, DWARF
and dependencies (printing module names, labels etc.).

Co-authored-by: Alexis King <lexi.lambda@gmail.com>

Metric Decrease:
    CoOpt_Read
    ManyAlternatives
    ManyConstructors
    T10421
    T12425
    T12707
    T13035
    T13056
    T13253
    T13379
    T18140
    T18282
    T18698a
    T18698b
    T1969
    T20049
    T21839c
    T21839r
    T3064
    T3294
    T4801
    T5321FD
    T5321Fun
    T5631
    T6048
    T783
    T9198
    T9233

4 files changed, 55 insertions, 33 deletions

diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs
index 6d4397e62b..5fd6378678 100644
--- a/compiler/GHC/Cmm/CLabel.hs
+++ b/compiler/GHC/Cmm/CLabel.hs
@@ -307,12 +307,14 @@ data ModuleLabelKind
     | MLK_IPEBuffer
     deriving (Eq, Ord)
 
-instance Outputable ModuleLabelKind where
-    ppr MLK_InitializerArray = text "init_arr"
-    ppr (MLK_Initializer s)  = text ("init__" ++ s)
-    ppr MLK_FinalizerArray   = text "fini_arr"
-    ppr (MLK_Finalizer s)    = text ("fini__" ++ s)
-    ppr MLK_IPEBuffer        = text "ipe_buf"
+pprModuleLabelKind :: IsLine doc => ModuleLabelKind -> doc
+pprModuleLabelKind MLK_InitializerArray = text "init_arr"
+pprModuleLabelKind (MLK_Initializer s)  = text ("init__" ++ s)
+pprModuleLabelKind MLK_FinalizerArray   = text "fini_arr"
+pprModuleLabelKind (MLK_Finalizer s)    = text ("fini__" ++ s)
+pprModuleLabelKind MLK_IPEBuffer        = text "ipe_buf"
+{-# SPECIALIZE pprModuleLabelKind :: ModuleLabelKind -> SDoc #-}
+{-# SPECIALIZE pprModuleLabelKind :: ModuleLabelKind -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
 
 isIdLabel :: CLabel -> Bool
 isIdLabel IdLabel{} = True
@@ -1416,7 +1418,7 @@ allocation.  Take care if you want to remove them!
 
 -}
 
-pprAsmLabel :: Platform -> CLabel -> SDoc
+pprAsmLabel :: IsLine doc => Platform -> CLabel -> doc
 pprAsmLabel platform lbl = pprCLabel platform AsmStyle lbl
 
 instance OutputableP Platform CLabel where
@@ -1426,19 +1428,19 @@ instance OutputableP Platform CLabel where
                           PprDump{} -> pprCLabel platform CStyle lbl
                           _         -> pprPanic "Labels in code should be printed with pprCLabel" (pprCLabel platform CStyle lbl)
 
-pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc
+pprCLabel :: forall doc. IsLine doc => Platform -> LabelStyle -> CLabel -> doc
 pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
   let
     !use_leading_underscores = platformLeadingUnderscore platform
 
     -- some platform (e.g. Darwin) require a leading "_" for exported asm
     -- symbols
-    maybe_underscore :: SDoc -> SDoc
+    maybe_underscore :: doc -> doc
     maybe_underscore doc = case sty of
       AsmStyle | use_leading_underscores -> pp_cSEP <> doc
       _                                  -> doc
 
-    tempLabelPrefixOrUnderscore :: SDoc
+    tempLabelPrefixOrUnderscore :: doc
     tempLabelPrefixOrUnderscore = case sty of
       AsmStyle -> asmTempLabelPrefix platform
       CStyle   -> char '_'
@@ -1490,14 +1492,14 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
 
 
    IdLabel name _cafs flavor -> case sty of
-      AsmStyle -> maybe_underscore $ internalNamePrefix <> ppr name <> ppIdFlavor flavor
+      AsmStyle -> maybe_underscore $ internalNamePrefix <> pprName name <> ppIdFlavor flavor
                    where
                       isRandomGenerated = not (isExternalName name)
                       internalNamePrefix =
                          if isRandomGenerated
                             then asmTempLabelPrefix platform
                             else empty
-      CStyle   -> ppr name <> ppIdFlavor flavor
+      CStyle   -> pprName name <> ppIdFlavor flavor
 
    SRTLabel u
       -> maybe_underscore $ tempLabelPrefixOrUnderscore <> pprUniqueAlways u <> pp_cSEP <> text "srt"
@@ -1534,7 +1536,7 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
                                  ]
 
    RtsLabel (RtsPrimOp primop)
-      -> maybe_underscore $ text "stg_" <> ppr primop
+      -> maybe_underscore $ text "stg_" <> pprPrimOp primop
 
    RtsLabel (RtsSlowFastTickyCtr pat)
       -> maybe_underscore $ text "SLOW_CALL_fast_" <> text pat <> text "_ctr"
@@ -1552,12 +1554,12 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
                             -- with a letter so the label will be legal assembly code.
 
    HpcTicksLabel mod
-      -> maybe_underscore $ text "_hpc_tickboxes_"  <> ppr mod <> text "_hpc"
+      -> maybe_underscore $ text "_hpc_tickboxes_"  <> pprModule mod <> text "_hpc"
 
-   CC_Label cc   -> maybe_underscore $ ppr cc
-   CCS_Label ccs -> maybe_underscore $ ppr ccs
-   IPE_Label (InfoProvEnt l _ _ m _) -> maybe_underscore $ (pprCLabel platform CStyle l <> text "_" <> ppr m <> text "_ipe")
-   ModuleLabel mod kind        -> maybe_underscore $ ppr mod <> text "_" <> ppr kind
+   CC_Label cc   -> maybe_underscore $ pprCostCentre cc
+   CCS_Label ccs -> maybe_underscore $ pprCostCentreStack ccs
+   IPE_Label (InfoProvEnt l _ _ m _) -> maybe_underscore $ (pprCLabel platform CStyle l <> text "_" <> pprModule m <> text "_ipe")
+   ModuleLabel mod kind        -> maybe_underscore $ pprModule mod <> text "_" <> pprModuleLabelKind kind
 
    CmmLabel _ _ fs CmmCode     -> maybe_underscore $ ftext fs
    CmmLabel _ _ fs CmmData     -> maybe_underscore $ ftext fs
@@ -1567,6 +1569,8 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
    CmmLabel _ _ fs CmmRetInfo  -> maybe_underscore $ ftext fs <> text "_info"
    CmmLabel _ _ fs CmmRet      -> maybe_underscore $ ftext fs <> text "_ret"
    CmmLabel _ _ fs CmmClosure  -> maybe_underscore $ ftext fs <> text "_closure"
+{-# SPECIALIZE pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc #-}
+{-# SPECIALIZE pprCLabel :: Platform -> LabelStyle -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
 
 -- Note [Internal proc labels]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1587,21 +1591,24 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
 -- | Generate a label for a procedure internal to a module (if
 -- 'Opt_ExposeAllSymbols' is enabled).
 -- See Note [Internal proc labels].
-ppInternalProcLabel :: Module     -- ^ the current module
+ppInternalProcLabel :: IsLine doc
+                    => Module     -- ^ the current module
                     -> CLabel
-                    -> Maybe SDoc -- ^ the internal proc label
+                    -> Maybe doc -- ^ the internal proc label
 ppInternalProcLabel this_mod (IdLabel nm _ flavour)
   | isInternalName nm
   = Just
-     $ text "_" <> ppr this_mod
+     $ text "_" <> pprModule this_mod
     <> char '_'
     <> ztext (zEncodeFS (occNameFS (occName nm)))
     <> char '_'
     <> pprUniqueAlways (getUnique nm)
     <> ppIdFlavor flavour
 ppInternalProcLabel _ _ = Nothing
+{-# SPECIALIZE ppInternalProcLabel :: Module -> CLabel -> Maybe SDoc #-}
+{-# SPECIALIZE ppInternalProcLabel :: Module -> CLabel -> Maybe HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
 
-ppIdFlavor :: IdLabelInfo -> SDoc
+ppIdFlavor :: IsLine doc => IdLabelInfo -> doc
 ppIdFlavor x = pp_cSEP <> case x of
    Closure          -> text "closure"
    InfoTable        -> text "info"
@@ -1612,22 +1619,22 @@ ppIdFlavor x = pp_cSEP <> case x of
    IdTickyInfo TickyRednCounts
       -> text "ct"
    IdTickyInfo (TickyInferedTag unique)
-      -> text "ct_inf_tag" <> char '_' <> ppr unique
+      -> text "ct_inf_tag" <> char '_' <> pprUniqueAlways unique
    ConEntry loc      ->
       case loc of
         DefinitionSite -> text "con_entry"
         UsageSite m n ->
-          ppr m <> pp_cSEP <> ppr n <> pp_cSEP <> text "con_entry"
+          pprModule m <> pp_cSEP <> int n <> pp_cSEP <> text "con_entry"
    ConInfoTable k   ->
     case k of
       DefinitionSite -> text "con_info"
       UsageSite m n ->
-        ppr m <> pp_cSEP <> ppr n <> pp_cSEP <> text "con_info"
+        pprModule m <> pp_cSEP <> int n <> pp_cSEP <> text "con_info"
    ClosureTable     -> text "closure_tbl"
    Bytes            -> text "bytes"
    BlockInfoTable   -> text "info"
 
-pp_cSEP :: SDoc
+pp_cSEP :: IsLine doc => doc
 pp_cSEP = char '_'
 
 
@@ -1641,13 +1648,13 @@ instance Outputable ForeignLabelSource where
 -- -----------------------------------------------------------------------------
 -- Machine-dependent knowledge about labels.
 
-asmTempLabelPrefix :: Platform -> SDoc  -- for formatting labels
+asmTempLabelPrefix :: IsLine doc => Platform -> doc  -- for formatting labels
 asmTempLabelPrefix !platform = case platformOS platform of
     OSDarwin -> text "L"
     OSAIX    -> text "__L" -- follow IBM XL C's convention
     _        -> text ".L"
 
-pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> SDoc -> SDoc
+pprDynamicLinkerAsmLabel :: IsLine doc => Platform -> DynamicLinkerLabelInfo -> doc -> doc
 pprDynamicLinkerAsmLabel !platform dllInfo ppLbl =
     case platformOS platform of
       OSDarwin
diff --git a/compiler/GHC/Cmm/CLabel.hs-boot b/compiler/GHC/Cmm/CLabel.hs-boot
index 8fb1b74423..4a5ec3dde3 100644
--- a/compiler/GHC/Cmm/CLabel.hs-boot
+++ b/compiler/GHC/Cmm/CLabel.hs-boot
@@ -5,5 +5,5 @@ import GHC.Platform
 
 data CLabel
 
-pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc
+pprCLabel :: IsLine doc => Platform -> LabelStyle -> CLabel -> doc
 
diff --git a/compiler/GHC/Cmm/DebugBlock.hs b/compiler/GHC/Cmm/DebugBlock.hs
index 3a7ceb7746..bfcb16bff9 100644
--- a/compiler/GHC/Cmm/DebugBlock.hs
+++ b/compiler/GHC/Cmm/DebugBlock.hs
@@ -29,7 +29,8 @@ module GHC.Cmm.DebugBlock (
 
   -- * Unwinding information
   UnwindTable, UnwindPoint(..),
-  UnwindExpr(..), toUnwindExpr
+  UnwindExpr(..), toUnwindExpr,
+  pprUnwindTable
   ) where
 
 import GHC.Prelude
@@ -38,6 +39,7 @@ import GHC.Platform
 import GHC.Cmm.BlockId
 import GHC.Cmm.CLabel
 import GHC.Cmm
+import GHC.Cmm.Reg ( pprGlobalReg )
 import GHC.Cmm.Utils
 import GHC.Data.FastString ( nilFS, mkFastString )
 import GHC.Unit.Module
@@ -522,10 +524,18 @@ data UnwindExpr = UwConst !Int                  -- ^ literal value
 instance OutputableP Platform UnwindExpr where
   pdoc = pprUnwindExpr 0
 
-pprUnwindExpr :: Rational -> Platform -> UnwindExpr -> SDoc
+pprUnwindTable :: IsLine doc => Platform -> UnwindTable -> doc
+pprUnwindTable platform u = brackets (fsep (punctuate comma (map print_entry (Map.toList u))))
+  where print_entry (reg, Nothing) =
+          parens (sep [pprGlobalReg reg, text "Nothing"])
+        print_entry (reg, Just x)  =
+          parens (sep [pprGlobalReg reg, text "Just" <+> pprUnwindExpr 0 platform x])
+  -- Follow instance Outputable (Map.Map GlobalReg (Maybe UnwindExpr))
+
+pprUnwindExpr :: IsLine doc => Rational -> Platform -> UnwindExpr -> doc
 pprUnwindExpr p env = \case
   UwConst i     -> int i
-  UwReg g 0     -> ppr g
+  UwReg g 0     -> pprGlobalReg g
   UwReg g x     -> pprUnwindExpr p env (UwPlus (UwReg g 0) (UwConst x))
   UwDeref e     -> char '*' <> pprUnwindExpr 3 env e
   UwLabel l     -> pprAsmLabel env l
@@ -536,6 +546,8 @@ pprUnwindExpr p env = \case
   UwTimes e0 e1
    | p <= 1     -> pprUnwindExpr 2 env e0 <> char '*' <> pprUnwindExpr 2 env e1
   other         -> parens (pprUnwindExpr 0 env other)
+{-# SPECIALIZE pprUnwindExpr :: Rational -> Platform -> UnwindExpr -> SDoc #-}
+{-# SPECIALIZE pprUnwindExpr :: Rational -> Platform -> UnwindExpr -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
 
 -- | Conversion of Cmm expressions to unwind expressions. We check for
 -- unsupported operator usages and simplify the expression as far as
diff --git a/compiler/GHC/Cmm/Reg.hs b/compiler/GHC/Cmm/Reg.hs
index 6c94ecb2eb..a9b3fce101 100644
--- a/compiler/GHC/Cmm/Reg.hs
+++ b/compiler/GHC/Cmm/Reg.hs
@@ -12,6 +12,7 @@ module GHC.Cmm.Reg
     , localRegType
       -- * Global registers
     , GlobalReg(..), isArgReg, globalRegType
+    , pprGlobalReg
     , spReg, hpReg, spLimReg, hpLimReg, nodeReg
     , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg
     , node, baseReg
@@ -296,7 +297,7 @@ instance Outputable GlobalReg where
 instance OutputableP env GlobalReg where
     pdoc _ = ppr
 
-pprGlobalReg :: GlobalReg -> SDoc
+pprGlobalReg :: IsLine doc => GlobalReg -> doc
 pprGlobalReg gr
     = case gr of
         VanillaReg n _ -> char 'R' <> int n
@@ -324,6 +325,8 @@ pprGlobalReg gr
         GCFun          -> text "stg_gc_fun"
         BaseReg        -> text "BaseReg"
         PicBaseReg     -> text "PicBaseReg"
+{-# SPECIALIZE pprGlobalReg :: GlobalReg -> SDoc #-}
+{-# SPECIALIZE pprGlobalReg :: GlobalReg -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
 
 
 -- convenient aliases