Enhance pretty-printing perf

A few refactorings made after looking at Core/STG

* Use Doc instead of SDoc in pprASCII to avoid passing the SDocContext
  that is never used.

* Inline every SDoc wrappers in GHC.Utils.Outputable to expose Doc
  constructs

* Add text/[] rule for empty strings (i.e., text "")

* Use a single occurrence of pprGNUSectionHeader

* Use bangs on Platform parameters and some others

Metric Decrease:
    ManyAlternatives
    ManyConstructors
    T12707
    T13035
    T13379
    T18698a
    T18698b
    T1969
    T3294
    T4801
    T5321FD
    T783

4 files changed, 136 insertions, 58 deletions

diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs
index e2f7ce82bc..4d6c66066c 100644
--- a/compiler/GHC/Cmm/CLabel.hs
+++ b/compiler/GHC/Cmm/CLabel.hs
@@ -8,7 +8,6 @@
 
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances #-}
 
@@ -1304,24 +1303,34 @@ the fact that it was derived from a block ID in `IdLabelInfo` as
 
 The info table label and the local block label are both local labels
 and are not externally visible.
+
+Note [Bangs in CLabel]
+~~~~~~~~~~~~~~~~~~~~~~
+There are some carefully placed strictness annotations in this module,
+which were discovered in !5226 to significantly reduce compile-time
+allocation.  Take care if you want to remove them!
+
 -}
 
 instance OutputableP Platform CLabel where
-  pdoc platform lbl = getPprStyle $ \case
-                        PprCode CStyle   -> pprCLabel platform CStyle lbl
-                        PprCode AsmStyle -> pprCLabel platform AsmStyle lbl
-                        _                -> pprCLabel platform CStyle lbl
-                                            -- default to CStyle
+  {-# INLINE pdoc #-} -- see Note [Bangs in CLabel]
+  pdoc !platform lbl = getPprStyle $ \pp_sty ->
+                        let !sty = case pp_sty of
+                                    PprCode sty -> sty
+                                    _           -> CStyle
+                        in pprCLabel platform sty lbl
 
 pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc
-pprCLabel platform sty lbl =
+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 = case sty of
-      AsmStyle | platformLeadingUnderscore platform -> pp_cSEP <> doc
-      _                                             -> doc
+      AsmStyle | use_leading_underscores -> pp_cSEP <> doc
+      _                                  -> doc
 
     tempLabelPrefixOrUnderscore :: Platform -> SDoc
     tempLabelPrefixOrUnderscore platform = case sty of
@@ -1520,13 +1529,13 @@ instance Outputable ForeignLabelSource where
 -- Machine-dependent knowledge about labels.
 
 asmTempLabelPrefix :: Platform -> PtrString  -- for formatting labels
-asmTempLabelPrefix platform = case platformOS platform of
+asmTempLabelPrefix !platform = case platformOS platform of
     OSDarwin -> sLit "L"
     OSAIX    -> sLit "__L" -- follow IBM XL C's convention
     _        -> sLit ".L"
 
 pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> SDoc -> SDoc
-pprDynamicLinkerAsmLabel platform dllInfo ppLbl =
+pprDynamicLinkerAsmLabel !platform dllInfo ppLbl =
     case platformOS platform of
       OSDarwin
         | platformArch platform == ArchX86_64 ->
diff --git a/compiler/GHC/CmmToAsm/Ppr.hs b/compiler/GHC/CmmToAsm/Ppr.hs
index dd656a9906..a2382705ae 100644
--- a/compiler/GHC/CmmToAsm/Ppr.hs
+++ b/compiler/GHC/CmmToAsm/Ppr.hs
@@ -25,7 +25,8 @@ import GHC.Cmm.CLabel
 import GHC.Cmm
 import GHC.CmmToAsm.Config
 import GHC.Data.FastString
-import GHC.Utils.Outputable
+import GHC.Utils.Outputable as SDoc
+import qualified GHC.Utils.Ppr as Pretty
 import GHC.Utils.Panic
 import GHC.Platform
 
@@ -94,28 +95,34 @@ pprASCII str
   -- the literal SDoc directly.
   -- See #14741
   -- and Note [Pretty print ASCII when AsmCodeGen]
-  = text $ BS.foldr (\w s -> do1 w ++ s) "" str
+  --
+  -- We work with a `Doc` instead of an `SDoc` because there is no need to carry
+  -- an `SDocContext` that we don't use. It leads to nicer (STG) code.
+  = docToSDoc (BS.foldr f Pretty.empty str)
     where
-       do1 :: Word8 -> String
-       do1 w | 0x09 == w = "\\t"
-             | 0x0A == w = "\\n"
-             | 0x22 == w = "\\\""
-             | 0x5C == w = "\\\\"
+       f :: Word8 -> Pretty.Doc -> Pretty.Doc
+       f w s = do1 w Pretty.<> s
+
+       do1 :: Word8 -> Pretty.Doc
+       do1 w | 0x09 == w = Pretty.text "\\t"
+             | 0x0A == w = Pretty.text "\\n"
+             | 0x22 == w = Pretty.text "\\\""
+             | 0x5C == w = Pretty.text "\\\\"
                -- ASCII printable characters range
-             | w >= 0x20 && w <= 0x7E = [chr' w]
-             | otherwise = '\\' : octal w
+             | w >= 0x20 && w <= 0x7E = Pretty.char (chr' w)
+             | otherwise = Pretty.sizedText 4 xs
+                where
+                 !xs = [ '\\', x0, x1, x2] -- octal
+                 !x0 = chr' (ord0 + (w `unsafeShiftR` 6) .&. 0x07)
+                 !x1 = chr' (ord0 + (w `unsafeShiftR` 3) .&. 0x07)
+                 !x2 = chr' (ord0 + w .&. 0x07)
+                 !ord0 = 0x30 -- = ord '0'
 
        -- we know that the Chars we create are in the ASCII range
        -- so we bypass the check in "chr"
        chr' :: Word8 -> Char
        chr' (W8# w#) = C# (chr# (word2Int# (word8ToWord# w#)))
 
-       octal :: Word8 -> String
-       octal w = [ chr' (ord0 + (w `unsafeShiftR` 6) .&. 0x07)
-                 , chr' (ord0 + (w `unsafeShiftR` 3) .&. 0x07)
-                 , chr' (ord0 + w .&. 0x07)
-                 ]
-       ord0 = 0x30 -- = ord '0'
 
 -- | Emit a ".string" directive
 pprString :: ByteString -> SDoc
@@ -191,37 +198,39 @@ pprSectionHeader config (Section t suffix) =
  case platformOS (ncgPlatform config) of
    OSAIX     -> pprXcoffSectionHeader t
    OSDarwin  -> pprDarwinSectionHeader t
-   OSMinGW32 -> pprGNUSectionHeader config (char '$') t suffix
-   _         -> pprGNUSectionHeader config (char '.') t suffix
+   _         -> pprGNUSectionHeader config t suffix
 
-pprGNUSectionHeader :: NCGConfig -> SDoc -> SectionType -> CLabel -> SDoc
-pprGNUSectionHeader config sep t suffix =
-  text ".section " <> ptext header <> subsection <> flags
+pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> SDoc
+pprGNUSectionHeader config t suffix =
+  hcat [text ".section ", header, subsection, flags]
   where
+    sep
+      | OSMinGW32 <- platformOS platform = char '$'
+      | otherwise                        = char '.'
     platform      = ncgPlatform config
     splitSections = ncgSplitSections config
     subsection
       | splitSections = sep <> pdoc platform suffix
       | otherwise     = empty
     header = case t of
-      Text -> sLit ".text"
-      Data -> sLit ".data"
+      Text -> text ".text"
+      Data -> text ".data"
       ReadOnlyData  | OSMinGW32 <- platformOS platform
-                                -> sLit ".rdata"
-                    | otherwise -> sLit ".rodata"
+                                -> text ".rdata"
+                    | otherwise -> text ".rodata"
       RelocatableReadOnlyData | OSMinGW32 <- platformOS platform
                                 -- Concept does not exist on Windows,
                                 -- So map these to R/O data.
-                                          -> sLit ".rdata$rel.ro"
-                              | otherwise -> sLit ".data.rel.ro"
-      UninitialisedData -> sLit ".bss"
+                                          -> text ".rdata$rel.ro"
+                              | otherwise -> text ".data.rel.ro"
+      UninitialisedData -> text ".bss"
       ReadOnlyData16 | OSMinGW32 <- platformOS platform
-                                 -> sLit ".rdata$cst16"
-                     | otherwise -> sLit ".rodata.cst16"
+                                 -> text ".rdata$cst16"
+                     | otherwise -> text ".rodata.cst16"
       CString
         | OSMinGW32 <- platformOS platform
-                    -> sLit ".rdata"
-        | otherwise -> sLit ".rodata.str"
+                    -> text ".rdata"
+        | otherwise -> text ".rodata.str"
       OtherSection _ ->
         panic "PprBase.pprGNUSectionHeader: unknown section type"
     flags = case t of
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs
index 5fe2d20d6b..6f04ba9ad4 100644
--- a/compiler/GHC/Utils/Outputable.hs
+++ b/compiler/GHC/Utils/Outputable.hs
@@ -159,7 +159,7 @@ data PprStyle
                 -- Does not assume tidied code: non-external names
                 -- are printed with uniques.
 
-  | PprCode LabelStyle -- ^ Print code; either C or assembler
+  | PprCode !LabelStyle -- ^ Print code; either C or assembler
 
 -- | Style of label pretty-printing.
 --
@@ -443,6 +443,7 @@ defaultSDocContext = SDC
   }
 
 withPprStyle :: PprStyle -> SDoc -> SDoc
+{-# INLINE CONLIKE withPprStyle #-}
 withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty}
 
 pprDeeper :: SDoc -> SDoc
@@ -485,15 +486,19 @@ pprSetDepth depth doc = SDoc $ \ctx ->
             runSDoc doc ctx
 
 getPprStyle :: (PprStyle -> SDoc) -> SDoc
+{-# INLINE CONLIKE getPprStyle #-}
 getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx
 
 sdocWithContext :: (SDocContext -> SDoc) -> SDoc
+{-# INLINE CONLIKE sdocWithContext #-}
 sdocWithContext f = SDoc $ \ctx -> runSDoc (f ctx) ctx
 
 sdocOption :: (SDocContext -> a) -> (a -> SDoc) -> SDoc
+{-# INLINE CONLIKE sdocOption #-}
 sdocOption f g = sdocWithContext (g . f)
 
 updSDocContext :: (SDocContext -> SDocContext) -> SDoc -> SDoc
+{-# INLINE CONLIKE updSDocContext #-}
 updSDocContext upd doc
   = SDoc $ \ctx -> runSDoc doc (upd ctx)
 
@@ -535,14 +540,17 @@ userStyle _other       = False
 
 -- | Indicate if -dppr-debug mode is enabled
 getPprDebug :: (Bool -> SDoc) -> SDoc
+{-# INLINE CONLIKE getPprDebug #-}
 getPprDebug d = sdocWithContext $ \ctx -> d (sdocPprDebug ctx)
 
 -- | Says what to do with and without -dppr-debug
 ifPprDebug :: SDoc -> SDoc -> SDoc
+{-# INLINE CONLIKE ifPprDebug #-}
 ifPprDebug yes no = getPprDebug $ \dbg -> if dbg then yes else no
 
 -- | Says what to do with -dppr-debug; without, return empty
 whenPprDebug :: SDoc -> SDoc        -- Empty for non-debug style
+{-# INLINE CONLIKE whenPprDebug #-}
 whenPprDebug d = ifPprDebug d empty
 
 -- | The analog of 'Pretty.printDoc_' for 'SDoc', which tries to make sure the
@@ -569,6 +577,7 @@ bufLeftRenderSDoc ctx bufHandle doc =
   Pretty.bufLeftRender bufHandle (runSDoc doc ctx)
 
 pprCode :: LabelStyle -> SDoc -> SDoc
+{-# INLINE CONLIKE pprCode #-}
 pprCode cs d = withPprStyle (PprCode cs) d
 
 renderWithContext :: SDocContext -> SDoc -> String
@@ -606,21 +615,32 @@ float    :: Float      -> SDoc
 double   :: Double     -> SDoc
 rational :: Rational   -> SDoc
 
+{-# INLINE CONLIKE empty #-}
 empty       = docToSDoc $ Pretty.empty
+{-# INLINE CONLIKE char #-}
 char c      = docToSDoc $ Pretty.char c
 
+{-# INLINE CONLIKE text #-}   -- Inline so that the RULE Pretty.text will fire
 text s      = docToSDoc $ Pretty.text s
-{-# INLINE text #-}   -- Inline so that the RULE Pretty.text will fire
 
+{-# INLINE CONLIKE ftext #-}
 ftext s     = docToSDoc $ Pretty.ftext s
+{-# INLINE CONLIKE ptext #-}
 ptext s     = docToSDoc $ Pretty.ptext s
+{-# INLINE CONLIKE ztext #-}
 ztext s     = docToSDoc $ Pretty.ztext s
+{-# INLINE CONLIKE int #-}
 int n       = docToSDoc $ Pretty.int n
+{-# INLINE CONLIKE integer #-}
 integer n   = docToSDoc $ Pretty.integer n
+{-# INLINE CONLIKE float #-}
 float n     = docToSDoc $ Pretty.float n
+{-# INLINE CONLIKE double #-}
 double n    = docToSDoc $ Pretty.double n
+{-# INLINE CONLIKE rational #-}
 rational n  = docToSDoc $ Pretty.rational n
               -- See Note [Print Hexadecimal Literals] in GHC.Utils.Ppr
+{-# INLINE CONLIKE word #-}
 word n      = sdocOption sdocHexWordLiterals $ \case
                True  -> docToSDoc $ Pretty.hex n
                False -> docToSDoc $ Pretty.integer n
@@ -633,14 +653,21 @@ doublePrec p n = text (showFFloat (Just p) n "")
 parens, braces, brackets, quotes, quote,
         doubleQuotes, angleBrackets :: SDoc -> SDoc
 
+{-# INLINE CONLIKE parens #-}
 parens d        = SDoc $ Pretty.parens . runSDoc d
+{-# INLINE CONLIKE braces #-}
 braces d        = SDoc $ Pretty.braces . runSDoc d
+{-# INLINE CONLIKE brackets #-}
 brackets d      = SDoc $ Pretty.brackets . runSDoc d
+{-# INLINE CONLIKE quote #-}
 quote d         = SDoc $ Pretty.quote . runSDoc d
+{-# INLINE CONLIKE doubleQuotes #-}
 doubleQuotes d  = SDoc $ Pretty.doubleQuotes . runSDoc d
+{-# INLINE CONLIKE angleBrackets #-}
 angleBrackets d = char '<' <> d <> char '>'
 
 cparen :: Bool -> SDoc -> SDoc
+{-# INLINE CONLIKE cparen #-}
 cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d
 
 -- 'quotes' encloses something in single quotes...
@@ -661,7 +688,7 @@ semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc
 arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, lambda :: SDoc
 lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
 
-blankLine  = docToSDoc $ Pretty.text ""
+blankLine  = docToSDoc Pretty.emptyText
 dcolon     = unicodeSyntax (char '∷') (docToSDoc $ Pretty.text "::")
 arrow      = unicodeSyntax (char '→') (docToSDoc $ Pretty.text "->")
 lollipop   = unicodeSyntax (char '⊸') (docToSDoc $ Pretty.text "%1 ->")
@@ -722,11 +749,16 @@ nest :: Int -> SDoc -> SDoc
 ($+$) :: SDoc -> SDoc -> SDoc
 -- ^ Join two 'SDoc' together vertically
 
+{-# INLINE CONLIKE nest #-}
 nest n d    = SDoc $ Pretty.nest n . runSDoc d
-(<>) d1 d2  = SDoc $ \sty -> (Pretty.<>)  (runSDoc d1 sty) (runSDoc d2 sty)
-(<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty)
-($$) d1 d2  = SDoc $ \sty -> (Pretty.$$)  (runSDoc d1 sty) (runSDoc d2 sty)
-($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty)
+{-# INLINE CONLIKE (<>) #-}
+(<>) d1 d2  = SDoc $ \ctx -> (Pretty.<>)  (runSDoc d1 ctx) (runSDoc d2 ctx)
+{-# INLINE CONLIKE (<+>) #-}
+(<+>) d1 d2 = SDoc $ \ctx -> (Pretty.<+>) (runSDoc d1 ctx) (runSDoc d2 ctx)
+{-# INLINE CONLIKE ($$) #-}
+($$) d1 d2  = SDoc $ \ctx -> (Pretty.$$)  (runSDoc d1 ctx) (runSDoc d2 ctx)
+{-# INLINE CONLIKE ($+$) #-}
+($+$) d1 d2 = SDoc $ \ctx -> (Pretty.$+$) (runSDoc d1 ctx) (runSDoc d2 ctx)
 
 hcat :: [SDoc] -> SDoc
 -- ^ Concatenate 'SDoc' horizontally
@@ -745,25 +777,37 @@ fcat :: [SDoc] -> SDoc
 -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
 
 
-hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds]
-hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds]
-vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds]
-sep ds  = SDoc $ \sty -> Pretty.sep  [runSDoc d sty | d <- ds]
-cat ds  = SDoc $ \sty -> Pretty.cat  [runSDoc d sty | d <- ds]
-fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds]
-fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds]
+-- Inline all those wrappers to help ensure we create lists of Doc, not of SDoc
+-- later applied to the same SDocContext. It helps the worker/wrapper
+-- transformation extracting only the required fields from the SDocContext.
+{-# INLINE CONLIKE hcat #-}
+hcat ds = SDoc $ \ctx -> Pretty.hcat [runSDoc d ctx | d <- ds]
+{-# INLINE CONLIKE hsep #-}
+hsep ds = SDoc $ \ctx -> Pretty.hsep [runSDoc d ctx | d <- ds]
+{-# INLINE CONLIKE vcat #-}
+vcat ds = SDoc $ \ctx -> Pretty.vcat [runSDoc d ctx | d <- ds]
+{-# INLINE CONLIKE sep #-}
+sep ds  = SDoc $ \ctx -> Pretty.sep  [runSDoc d ctx | d <- ds]
+{-# INLINE CONLIKE cat #-}
+cat ds  = SDoc $ \ctx -> Pretty.cat  [runSDoc d ctx | d <- ds]
+{-# INLINE CONLIKE fsep #-}
+fsep ds = SDoc $ \ctx -> Pretty.fsep [runSDoc d ctx | d <- ds]
+{-# INLINE CONLIKE fcat #-}
+fcat ds = SDoc $ \ctx -> Pretty.fcat [runSDoc d ctx | d <- ds]
 
 hang :: SDoc  -- ^ The header
       -> Int  -- ^ Amount to indent the hung body
       -> SDoc -- ^ The hung body, indented and placed below the header
       -> SDoc
+{-# INLINE CONLIKE hang #-}
 hang d1 n d2   = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty)
 
 -- | This behaves like 'hang', but does not indent the second document
 -- when the header is empty.
 hangNotEmpty :: SDoc -> Int -> SDoc -> SDoc
+{-# INLINE CONLIKE hangNotEmpty #-}
 hangNotEmpty d1 n d2 =
-    SDoc $ \sty -> Pretty.hangNotEmpty (runSDoc d1 sty) n (runSDoc d2 sty)
+    SDoc $ \ctx -> Pretty.hangNotEmpty (runSDoc d1 ctx) n (runSDoc d2 ctx)
 
 punctuate :: SDoc   -- ^ The punctuation
           -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
@@ -775,17 +819,21 @@ punctuate p (d:ds) = go d ds
                      go d (e:es) = (d <> p) : go e es
 
 ppWhen, ppUnless :: Bool -> SDoc -> SDoc
+{-# INLINE CONLIKE ppWhen #-}
 ppWhen True  doc = doc
 ppWhen False _   = empty
 
+{-# INLINE CONLIKE ppUnless #-}
 ppUnless True  _   = empty
 ppUnless False doc = doc
 
+{-# INLINE CONLIKE ppWhenOption #-}
 ppWhenOption :: (SDocContext -> Bool) -> SDoc -> SDoc
 ppWhenOption f doc = sdocOption f $ \case
    True  -> doc
    False -> empty
 
+{-# INLINE CONLIKE ppUnlessOption #-}
 ppUnlessOption :: (SDocContext -> Bool) -> SDoc -> SDoc
 ppUnlessOption f doc = sdocOption f $ \case
    True  -> empty
diff --git a/compiler/GHC/Utils/Ppr.hs b/compiler/GHC/Utils/Ppr.hs
index 8871f98cef..e64c6e61f1 100644
--- a/compiler/GHC/Utils/Ppr.hs
+++ b/compiler/GHC/Utils/Ppr.hs
@@ -71,7 +71,7 @@ module GHC.Utils.Ppr (
         -- * Constructing documents
 
         -- ** Converting values into documents
-        char, text, ftext, ptext, ztext, sizedText, zeroWidthText,
+        char, text, ftext, ptext, ztext, sizedText, zeroWidthText, emptyText,
         int, integer, float, double, rational, hex,
 
         -- ** Simple derived documents
@@ -309,6 +309,12 @@ text s = textBeside_ (Str s) (length s) Empty
     forall p n. text (unpackNBytes# p n) = ptext (PtrString (Ptr p) (I# n))
   #-}
 
+-- Empty strings are desugared into [] (not "unpackCString#..."), hence they are
+-- not matched by the text/str rule above.
+{-# RULES "text/[]"
+    text [] = emptyText
+  #-}
+
 ftext :: FastString -> Doc
 ftext s = textBeside_ (PStr s) (lengthFS s) Empty
 
@@ -327,6 +333,12 @@ sizedText l s = textBeside_ (Str s) l Empty
 zeroWidthText :: String -> Doc
 zeroWidthText = sizedText 0
 
+-- | Empty text (one line high but no width). (@emptyText = text ""@)
+emptyText :: Doc
+emptyText = sizedText 0 []
+  -- defined as a CAF. Sharing occurs especially via the text/[] rule above.
+  -- Every use of `text ""` in user code should be replaced with this.
+
 -- | The empty document, with no height and no width.
 -- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere
 -- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc.