Minor SDoc-related cleanupwip/strings-refactor2

* Rename pprCLabel to pprCLabelStyle, and use the name pprCLabel
  for a function using CStyle (analogous to pprAsmLabel)
* Move LabelStyle to the CLabel module, it no longer needs to be in Outputable.
* Move calls to 'text' right next to literals, to make sure the text/str
  rule is triggered.
* Remove FastString/String roundtrip in Tc.Deriv.Generate
* Introduce showSDocForUser', which abstracts over a pattern in
  GHCi.UI

22 files changed, 138 insertions, 134 deletions

diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs
index 6d4397e62b..bf4214fed2 100644
--- a/compiler/GHC/Cmm/CLabel.hs
+++ b/compiler/GHC/Cmm/CLabel.hs
@@ -455,7 +455,7 @@ data ForeignLabelSource
 --      The regular Outputable instance only shows the label name, and not its other info.
 --
 pprDebugCLabel :: Platform -> CLabel -> SDoc
-pprDebugCLabel platform lbl = pprCLabel platform AsmStyle lbl <> parens extra
+pprDebugCLabel platform lbl = pprAsmLabel platform lbl <> parens extra
    where
       extra = case lbl of
          IdLabel _ _ info
@@ -1416,18 +1416,33 @@ allocation.  Take care if you want to remove them!
 
 -}
 
+-- | Style of label pretty-printing.
+--
+-- When we produce C sources or headers, we have to take into account that C
+-- compilers transform C labels when they convert them into symbols. For
+-- example, they can add prefixes (e.g., "_" on Darwin) or suffixes (size for
+-- stdcalls on Windows). So we provide two ways to pretty-print CLabels: C style
+-- or Asm style.
+--
+data LabelStyle
+   = CStyle   -- ^ C label style (used by C and LLVM backends)
+   | AsmStyle -- ^ Asm label style (used by NCG backend)
+
 pprAsmLabel :: Platform -> CLabel -> SDoc
-pprAsmLabel platform lbl = pprCLabel platform AsmStyle lbl
+pprAsmLabel platform lbl = pprCLabelStyle platform AsmStyle lbl
+
+pprCLabel :: Platform -> CLabel -> SDoc
+pprCLabel platform lbl = pprCLabelStyle platform CStyle lbl
 
 instance OutputableP Platform CLabel where
   {-# INLINE pdoc #-} -- see Note [Bangs in CLabel]
   pdoc !platform lbl = getPprStyle $ \pp_sty ->
                         case pp_sty of
-                          PprDump{} -> pprCLabel platform CStyle lbl
-                          _         -> pprPanic "Labels in code should be printed with pprCLabel" (pprCLabel platform CStyle lbl)
+                          PprDump{} -> pprCLabel platform lbl
+                          _         -> pprPanic "Labels in code should be printed with pprCLabel or pprAsmLabel" (pprCLabel platform lbl)
 
-pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc
-pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
+pprCLabelStyle :: Platform -> LabelStyle -> CLabel -> SDoc
+pprCLabelStyle !platform !sty lbl = -- see Note [Bangs in CLabel]
   let
     !use_leading_underscores = platformLeadingUnderscore platform
 
@@ -1456,11 +1471,11 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
       -> asmTempLabelPrefix platform
          <> case l of AsmTempLabel u    -> pprUniqueAlways u
                       LocalBlockLabel u -> pprUniqueAlways u
-                      _other            -> pprCLabel platform sty l
+                      _other            -> pprCLabelStyle platform sty l
          <> ftext suf
 
    DynamicLinkerLabel info lbl
-      -> pprDynamicLinkerAsmLabel platform info (pprCLabel platform AsmStyle lbl)
+      -> pprDynamicLinkerAsmLabel platform info (pprAsmLabel platform lbl)
 
    PicBaseLabel
       -> text "1b"
@@ -1473,7 +1488,7 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
          optional `_` (underscore) because this is how you mark non-temp symbols
          on some platforms (Darwin)
       -}
-      maybe_underscore $ text "dsp_" <> pprCLabel platform sty lbl <> text "_dsp"
+      maybe_underscore $ text "dsp_" <> pprCLabelStyle platform sty lbl <> text "_dsp"
 
    StringLitLabel u
       -> maybe_underscore $ pprUniqueAlways u <> text "_str"
@@ -1556,7 +1571,7 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
 
    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")
+   IPE_Label (InfoProvEnt l _ _ m _) -> maybe_underscore $ (pprCLabel platform l <> text "_" <> ppr m <> text "_ipe")
    ModuleLabel mod kind        -> maybe_underscore $ ppr mod <> text "_" <> ppr kind
 
    CmmLabel _ _ fs CmmCode     -> maybe_underscore $ ftext fs
diff --git a/compiler/GHC/Cmm/CLabel.hs-boot b/compiler/GHC/Cmm/CLabel.hs-boot
index 8fb1b74423..cca3ce684e 100644
--- a/compiler/GHC/Cmm/CLabel.hs-boot
+++ b/compiler/GHC/Cmm/CLabel.hs-boot
@@ -5,5 +5,4 @@ import GHC.Platform
 
 data CLabel
 
-pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc
-
+pprCLabel :: Platform -> CLabel -> SDoc
diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y
index 656de66848..553dd59f24 100644
--- a/compiler/GHC/Cmm/Parser.y
+++ b/compiler/GHC/Cmm/Parser.y
@@ -450,7 +450,7 @@ cmmproc :: { CmmParse () }
                          platform <- getPlatform;
                          ctx      <- getContext;
                          formals <- sequence (fromMaybe [] $3);
-                         withName (showSDocOneLine ctx (pprCLabel platform CStyle entry_ret_label))
+                         withName (showSDocOneLine ctx (pprCLabel platform entry_ret_label))
                            $4;
                          return (entry_ret_label, info, stk_formals, formals) }
                      let do_layout = isJust $3
diff --git a/compiler/GHC/CmmToAsm/Dwarf/Types.hs b/compiler/GHC/CmmToAsm/Dwarf/Types.hs
index 236ddb5ffc..55eb0246bf 100644
--- a/compiler/GHC/CmmToAsm/Dwarf/Types.hs
+++ b/compiler/GHC/CmmToAsm/Dwarf/Types.hs
@@ -163,8 +163,8 @@ pprDwarfInfo platform haveSrc d
 -- | Print a CLabel name in a ".stringz \"LABEL\""
 pprLabelString :: Platform -> CLabel -> SDoc
 pprLabelString platform label =
-   pprString'                         -- we don't need to escape the string as labels don't contain exotic characters
-    $ pprCLabel platform CStyle label -- pretty-print as C label (foreign labels may be printed differently in Asm)
+   pprString'                  -- we don't need to escape the string as labels don't contain exotic characters
+    $ pprCLabel platform label -- pretty-print as C label (foreign labels may be printed differently in Asm)
 
 -- | Prints assembler data corresponding to DWARF info records. Note
 -- that the binary format of this is parameterized in @abbrevDecls@ and
diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs
index 44d4657052..c492e6f1a3 100644
--- a/compiler/GHC/CmmToC.hs
+++ b/compiler/GHC/CmmToC.hs
@@ -88,7 +88,7 @@ pprTop platform = \case
            blankLine,
            extern_decls,
            (if (externallyVisibleCLabel clbl)
-                    then mkFN_ else mkIF_) (pprCLabel platform CStyle clbl) <+> lbrace,
+                    then mkFN_ else mkIF_) (pprCLabel platform clbl) <+> lbrace,
            nest 8 temp_decls,
            vcat (map (pprBBlock platform) blocks),
            rbrace ]
@@ -110,14 +110,14 @@ pprTop platform = \case
   (CmmData section (CmmStaticsRaw lbl [CmmString str])) ->
     pprExternDecl platform lbl $$
     hcat [
-      pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform CStyle lbl,
+      pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform lbl,
       text "[] = ", pprStringInCStyle str, semi
     ]
 
   (CmmData section (CmmStaticsRaw lbl [CmmUninitialised size])) ->
     pprExternDecl platform lbl $$
     hcat [
-      pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform CStyle lbl,
+      pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform lbl,
       brackets (int size), semi
     ]
 
@@ -153,7 +153,7 @@ pprWordArray platform is_ro lbl ds
   = -- TODO: align closures only
     pprExternDecl platform lbl $$
     hcat [ pprLocalness lbl, pprConstness is_ro, text "StgWord"
-         , space, pprCLabel platform CStyle lbl, text "[]"
+         , space, pprCLabel platform lbl, text "[]"
          -- See Note [StgWord alignment]
          , pprAlignment (wordWidth platform)
          , text "= {" ]
@@ -245,7 +245,7 @@ pprStmt platform stmt =
             case fn of
               CmmLit (CmmLabel lbl)
                 | StdCallConv <- cconv ->
-                    pprCall platform (pprCLabel platform CStyle lbl) cconv hresults hargs
+                    pprCall platform (pprCLabel platform lbl) cconv hresults hargs
                         -- stdcall functions must be declared with
                         -- a function type, otherwise the C compiler
                         -- doesn't add the @n suffix to the label.  We
@@ -254,7 +254,7 @@ pprStmt platform stmt =
                 | CmmNeverReturns <- ret ->
                     pprCall platform cast_fn cconv hresults hargs <> semi <> text "__builtin_unreachable();"
                 | not (isMathFun lbl) ->
-                    pprForeignCall platform (pprCLabel platform CStyle lbl) cconv hresults hargs
+                    pprForeignCall platform (pprCLabel platform lbl) cconv hresults hargs
               _ ->
                     pprCall platform cast_fn cconv hresults hargs <> semi
                         -- for a dynamic call, no declaration is necessary.
@@ -595,7 +595,7 @@ pprLit platform lit = case lit of
         -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i
 
     where
-        pprCLabelAddr lbl = char '&' <> pprCLabel platform CStyle lbl
+        pprCLabelAddr lbl = char '&' <> pprCLabel platform lbl
 
 pprLit1 :: Platform -> CmmLit -> SDoc
 pprLit1 platform lit = case lit of
@@ -1208,7 +1208,7 @@ pprExternDecl platform lbl
   | not (needsCDecl lbl) = empty
   | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz
   | otherwise =
-        hcat [ visibility, label_type lbl , lparen, pprCLabel platform CStyle lbl, text ");"
+        hcat [ visibility, label_type lbl , lparen, pprCLabel platform lbl, text ");"
              -- occasionally useful to see label type
              -- , text "/* ", pprDebugCLabel lbl, text " */"
              ]
@@ -1231,7 +1231,7 @@ pprExternDecl platform lbl
   -- we must generate an appropriate prototype for it, so that the C compiler will
   -- add the @n suffix to the label (#2276)
   stdcall_decl sz =
-        text "extern __attribute__((stdcall)) void " <> pprCLabel platform CStyle lbl
+        text "extern __attribute__((stdcall)) void " <> pprCLabel platform lbl
         <> parens (commafy (replicate (sz `quot` platformWordSizeInBytes platform) (machRep_U_CType platform (wordWidth platform))))
         <> semi
 
@@ -1501,8 +1501,8 @@ pprCtorArray platform initOrFini lbls =
     <> text "void _hs_" <> attribute <> text "()"
     <> braces body
   where
-    body = vcat [ pprCLabel platform CStyle lbl <> text " ();" | lbl <- lbls ]
-    decls = vcat [ text "void" <+> pprCLabel platform CStyle lbl <> text " (void);" | lbl <- lbls ]
+    body = vcat [ pprCLabel platform lbl <> text " ();" | lbl <- lbls ]
+    decls = vcat [ text "void" <+> pprCLabel platform lbl <> text " (void);" | lbl <- lbls ]
     attribute = case initOrFini of
                   IsInitArray -> text "constructor"
                   IsFiniArray -> text "destructor"
diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs
index d891fd17b3..17fa7394a7 100644
--- a/compiler/GHC/CmmToLlvm/Base.hs
+++ b/compiler/GHC/CmmToLlvm/Base.hs
@@ -440,7 +440,7 @@ strCLabel_llvm :: CLabel -> LlvmM LMString
 strCLabel_llvm lbl = do
     ctx <- llvmCgContext <$> getConfig
     platform <- getPlatform
-    let sdoc = pprCLabel platform CStyle lbl
+    let sdoc = pprCLabel platform lbl
         str = Outp.showSDocOneLine ctx sdoc
     return (fsLit str)
 
diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs
index 5ac447883a..da328da1ce 100644
--- a/compiler/GHC/Core/Opt/SetLevels.hs
+++ b/compiler/GHC/Core/Opt/SetLevels.hs
@@ -95,7 +95,7 @@ import GHC.Types.Literal      ( litIsTrivial )
 import GHC.Types.Demand       ( DmdSig, prependArgsDmdSig )
 import GHC.Types.Cpr          ( CprSig, prependArgsCprSig )
 import GHC.Types.Name         ( getOccName, mkSystemVarName )
-import GHC.Types.Name.Occurrence ( occNameString )
+import GHC.Types.Name.Occurrence ( occNameFS )
 import GHC.Types.Unique       ( hasKey )
 import GHC.Types.Tickish      ( tickishIsCode )
 import GHC.Types.Unique.Supply
@@ -1697,9 +1697,9 @@ newPolyBndrs dest_lvl
 
     mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in GHC.Types.Id
                              transfer_join_info bndr $
-                             mkSysLocal (mkFastString str) uniq (idMult bndr) poly_ty
+                             mkSysLocal str uniq (idMult bndr) poly_ty
                            where
-                             str     = "poly_" ++ occNameString (getOccName bndr)
+                             str     = fsLit "poly_" `appendFS` occNameFS (getOccName bndr)
                              poly_ty = mkLamTypes abs_vars (substTyUnchecked subst (idType bndr))
 
     -- If we are floating a join point to top level, it stops being
diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs
index 09315c4f05..448c4c864e 100644
--- a/compiler/GHC/Driver/CodeOutput.hs
+++ b/compiler/GHC/Driver/CodeOutput.hs
@@ -330,7 +330,7 @@ profilingInitCode platform this_mod (local_CCs, singleton_CCSs)
  = {-# SCC profilingInitCode #-}
    initializerCStub platform fn_name decls body
  where
-   pdocC = pprCLabel platform CStyle
+   pdocC = pprCLabel platform
    fn_name = mkInitializerStubLabel this_mod "prof_init"
    decls = vcat
         $  map emit_cc_decl local_CCs
@@ -378,7 +378,7 @@ ipInitCode do_info_table platform this_mod
 
    body = text "registerInfoProvList" <> parens (text "&" <> ipe_buffer_label) <> semi
 
-   ipe_buffer_label = pprCLabel platform CStyle (mkIPELabel this_mod)
+   ipe_buffer_label = pprCLabel platform (mkIPELabel this_mod)
 
    ipe_buffer_decl =
        text "extern IpeBufferListNode" <+> ipe_buffer_label <> text ";"
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index a130fed062..c2e69a4087 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -2481,7 +2481,7 @@ hscTidy hsc_env guts = do
   -- on, print now
   unless (logHasDumpFlag logger Opt_D_dump_simpl) $
     putDumpFileMaybe logger Opt_D_dump_rules
-      (renderWithContext defaultSDocContext (ppr CoreTidy <+> text "rules"))
+      "Tidy Core rules"
       FormatText
       (pprRulesForUser tidy_rules)
 
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index eb708cd295..6e8814321c 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -66,7 +66,7 @@ module GHC.Hs.Utils(
   spanHsLocaLBinds,
 
   -- * Literals
-  mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit,
+  mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringFS, mkHsStringPrimLit,
   mkHsCharPrimLit,
 
   -- * Patterns
@@ -454,6 +454,9 @@ mkHsOpApp e1 op e2 = OpApp noAnn e1 (noLocA (HsVar noExtField (noLocA op))) e2
 mkHsString :: String -> HsLit (GhcPass p)
 mkHsString s = HsString NoSourceText (mkFastString s)
 
+mkHsStringFS :: FastString -> HsLit (GhcPass p)
+mkHsStringFS s = HsString NoSourceText s
+
 mkHsStringPrimLit :: FastString -> HsLit (GhcPass p)
 mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs)
 
diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs
index cec5a581de..9e2619db65 100644
--- a/compiler/GHC/HsToCore/Coverage.hs
+++ b/compiler/GHC/HsToCore/Coverage.hs
@@ -126,7 +126,7 @@ hpcInitCode platform this_mod (HpcInfo tickCount hashNo)
                   tickboxes
                 ])) <> semi
 
-    tickboxes = pprCLabel platform CStyle (mkHpcTicksLabel $ this_mod)
+    tickboxes = pprCLabel platform (mkHpcTicksLabel $ this_mod)
 
     module_name  = hcat (map (text.charToC) $ BS.unpack $
                          bytesFS (moduleNameFS (moduleName this_mod)))
diff --git a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
index 63297f4ad2..cf37095041 100644
--- a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
+++ b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
@@ -249,11 +249,11 @@ sptModuleInitCode platform this_mod entries =
         [  text "static StgWord64 k" <> int i <> text "[2] = "
            <> pprFingerprint fp <> semi
         $$ text "extern StgPtr "
-           <> (pprCLabel platform CStyle $ mkClosureLabel (idName n) (idCafInfo n)) <> semi
+           <> (pprCLabel platform $ mkClosureLabel (idName n) (idCafInfo n)) <> semi
         $$ text "hs_spt_insert" <> parens
              (hcat $ punctuate comma
                 [ char 'k' <> int i
-                , char '&' <> pprCLabel platform CStyle (mkClosureLabel (idName n) (idCafInfo n))
+                , char '&' <> pprCLabel platform (mkClosureLabel (idName n) (idCafInfo n))
                 ]
              )
         <> semi
diff --git a/compiler/GHC/Linker/ExtraObj.hs b/compiler/GHC/Linker/ExtraObj.hs
index 90cf2466e5..97f2bd5b07 100644
--- a/compiler/GHC/Linker/ExtraObj.hs
+++ b/compiler/GHC/Linker/ExtraObj.hs
@@ -124,13 +124,13 @@ mkExtraObjToLinkIntoBinary logger tmpfs dflags unit_state = do
         text " __conf.rts_opts_enabled = "
             <> text (show (rtsOptsEnabled dflags)) <> semi,
         text " __conf.rts_opts_suggestions = "
-            <> text (if rtsOptsSuggestions dflags
-                        then "true"
-                        else "false") <> semi,
+            <> (if rtsOptsSuggestions dflags
+                then text "true"
+                else text "false") <> semi,
         text "__conf.keep_cafs = "
-            <> text (if gopt Opt_KeepCAFs dflags
-                       then "true"
-                       else "false") <> semi,
+            <> (if gopt Opt_KeepCAFs dflags
+                then text "true"
+                else text "false") <> semi,
         case rtsOpts dflags of
             Nothing   -> Outputable.empty
             Just opts -> text "    __conf.rts_opts= " <>
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index f2f8bfd769..1263d5104b 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -77,20 +77,20 @@ instance Diagnostic PsMessage where
     PsWarnTransitionalLayout reason
       -> mkSimpleDecorated $
             text "transitional layout will not be accepted in the future:"
-            $$ text (case reason of
-               TransLayout_Where -> "`where' clause at the same depth as implicit layout block"
-               TransLayout_Pipe  -> "`|' at the same depth as implicit layout block"
+            $$ (case reason of
+               TransLayout_Where -> text "`where' clause at the same depth as implicit layout block"
+               TransLayout_Pipe  -> text "`|' at the same depth as implicit layout block"
             )
     PsWarnOperatorWhitespaceExtConflict sym
       -> let mk_prefix_msg extension_name syntax_meaning =
                   text "The prefix use of a" <+> quotes (pprOperatorWhitespaceSymbol sym)
-                    <+> text "would denote" <+> text syntax_meaning
-               $$ nest 2 (text "were the" <+> text extension_name <+> text "extension enabled.")
+                    <+> text "would denote" <+> syntax_meaning
+               $$ nest 2 (text "were the" <+> extension_name <+> text "extension enabled.")
          in mkSimpleDecorated $
          case sym of
-           OperatorWhitespaceSymbol_PrefixPercent -> mk_prefix_msg "LinearTypes" "a multiplicity annotation"
-           OperatorWhitespaceSymbol_PrefixDollar -> mk_prefix_msg "TemplateHaskell" "an untyped splice"
-           OperatorWhitespaceSymbol_PrefixDollarDollar -> mk_prefix_msg "TemplateHaskell" "a typed splice"
+           OperatorWhitespaceSymbol_PrefixPercent -> mk_prefix_msg (text "LinearTypes") (text "a multiplicity annotation")
+           OperatorWhitespaceSymbol_PrefixDollar -> mk_prefix_msg (text "TemplateHaskell") (text "an untyped splice")
+           OperatorWhitespaceSymbol_PrefixDollarDollar -> mk_prefix_msg (text "TemplateHaskell") (text "a typed splice")
     PsWarnOperatorWhitespace sym occ_type
       -> let mk_msg occ_type_str =
                   text "The" <+> text occ_type_str <+> text "use of a" <+> quotes (ftext sym)
@@ -124,21 +124,21 @@ instance Diagnostic PsMessage where
 
     PsErrLexer err kind
       -> mkSimpleDecorated $ hcat
-           [ text $ case err of
-              LexError               -> "lexical error"
-              LexUnknownPragma       -> "unknown pragma"
-              LexErrorInPragma       -> "lexical error in pragma"
-              LexNumEscapeRange      -> "numeric escape sequence out of range"
-              LexStringCharLit       -> "lexical error in string/character literal"
-              LexStringCharLitEOF    -> "unexpected end-of-file in string/character literal"
-              LexUnterminatedComment -> "unterminated `{-'"
-              LexUnterminatedOptions -> "unterminated OPTIONS pragma"
-              LexUnterminatedQQ      -> "unterminated quasiquotation"
+           [ case err of
+              LexError               -> text "lexical error"
+              LexUnknownPragma       -> text "unknown pragma"
+              LexErrorInPragma       -> text "lexical error in pragma"
+              LexNumEscapeRange      -> text "numeric escape sequence out of range"
+              LexStringCharLit       -> text "lexical error in string/character literal"
+              LexStringCharLitEOF    -> text "unexpected end-of-file in string/character literal"
+              LexUnterminatedComment -> text "unterminated `{-'"
+              LexUnterminatedOptions -> text "unterminated OPTIONS pragma"
+              LexUnterminatedQQ      -> text "unterminated quasiquotation"
 
-           , text $ case kind of
-              LexErrKind_EOF    -> " at end of input"
-              LexErrKind_UTF8   -> " (UTF-8 decoding error)"
-              LexErrKind_Char c -> " at character " ++ show c
+           , case kind of
+              LexErrKind_EOF    -> text " at end of input"
+              LexErrKind_UTF8   -> text " (UTF-8 decoding error)"
+              LexErrKind_Char c -> text $ " at character " ++ show c
            ]
     PsErrParse token _details
       | null token
diff --git a/compiler/GHC/Stg/Lift/Monad.hs b/compiler/GHC/Stg/Lift/Monad.hs
index a07c89b513..8e16dd922c 100644
--- a/compiler/GHC/Stg/Lift/Monad.hs
+++ b/compiler/GHC/Stg/Lift/Monad.hs
@@ -276,13 +276,13 @@ withSubstBndrs = runContT . traverse (ContT . withSubstBndr)
 withLiftedBndr :: DIdSet -> Id -> (Id -> LiftM a) -> LiftM a
 withLiftedBndr abs_ids bndr inner = do
   uniq <- getUniqueM
-  let str = "$l" ++ occNameString (getOccName bndr)
+  let str = fsLit "$l" `appendFS` occNameFS (getOccName bndr)
   let ty = mkLamTypes (dVarSetElems abs_ids) (idType bndr)
   let bndr'
         -- See Note [transferPolyIdInfo] in GHC.Types.Id. We need to do this at least
         -- for arity information.
         = transferPolyIdInfo bndr (dVarSetElems abs_ids)
-        . mkSysLocal (mkFastString str) uniq Many
+        . mkSysLocal str uniq Many
         $ ty
   LiftM $ RWS.local
     (\e -> e
diff --git a/compiler/GHC/StgToCmm/InfoTableProv.hs b/compiler/GHC/StgToCmm/InfoTableProv.hs
index 11e5552af8..22fd2308b4 100644
--- a/compiler/GHC/StgToCmm/InfoTableProv.hs
+++ b/compiler/GHC/StgToCmm/InfoTableProv.hs
@@ -64,7 +64,7 @@ emitIpeBufferListNode this_mod ents = do
 
 toCgIPE :: Platform -> SDocContext -> StrTabOffset -> InfoProvEnt -> State StringTable CgInfoProvEnt
 toCgIPE platform ctx module_name ipe = do
-    table_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (pprCLabel platform CStyle (infoTablePtr ipe))
+    table_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (pprCLabel platform (infoTablePtr ipe))
     closure_desc <- lookupStringTable $ ST.pack $ show (infoProvEntClosureType ipe)
     type_desc <- lookupStringTable $ ST.pack $ infoTableType ipe
     let label_str = maybe "" snd (infoTableProv ipe)
diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs
index feefb05ac1..8284aba4f7 100644
--- a/compiler/GHC/Tc/Deriv.hs
+++ b/compiler/GHC/Tc/Deriv.hs
@@ -201,7 +201,6 @@ tcDeriving deriv_infos deriv_decls
         ; famInsts2 <- concatMapM genFamInsts infer_specs
         ; let famInsts = famInsts1 ++ famInsts2
 
-        ; dflags <- getDynFlags
         ; logger <- getLogger
 
           -- We must put all the derived type family instances (from both
@@ -229,7 +228,7 @@ tcDeriving deriv_infos deriv_decls
 
         ; let (_, aux_specs, fvs) = unzip3 (given_inst_binds ++ infer_inst_binds)
         ; loc <- getSrcSpanM
-        ; let aux_binds = genAuxBinds dflags loc (unionManyBags aux_specs)
+        ; let aux_binds = genAuxBinds loc (unionManyBags aux_specs)
 
         ; let infer_inst_infos = map fstOf3 infer_inst_binds
         ; let inst_infos = given_inst_infos ++ infer_inst_infos
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index e51eee9841..259d7ce20f 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -54,7 +54,6 @@ import GHC.Core.DataCon
 import GHC.Types.Name
 import GHC.Types.SourceText
 
-import GHC.Driver.Session
 import GHC.Tc.Instance.Family
 import GHC.Core.FamInstEnv
 import GHC.Builtin.Names
@@ -1170,14 +1169,14 @@ gen_Read_binds get_fixity loc dit@(DerivInstTys{dit_rep_tc = tycon})
         where
           lbl_str = unpackFS lbl
           mk_read_field read_field_rdr lbl
-              = nlHsApps read_field_rdr [nlHsLit (mkHsString lbl)]
+              = nlHsApps read_field_rdr [nlHsLit (mkHsStringFS lbl)]
           read_field
               | isSym lbl_str
-              = mk_read_field readSymField_RDR lbl_str
+              = mk_read_field readSymField_RDR lbl
               | Just (ss, '#') <- snocView lbl_str -- #14918
-              = mk_read_field readFieldHash_RDR ss
+              = mk_read_field readFieldHash_RDR (mkFastString ss)
               | otherwise
-              = mk_read_field readField_RDR lbl_str
+              = mk_read_field readField_RDR lbl
 
 {-
 ************************************************************************
@@ -2156,9 +2155,9 @@ fiddling around.
 
 -- | Generate the full code for an auxiliary binding.
 -- See @Note [Auxiliary binders] (Wrinkle: Reducing code duplication)@.
-genAuxBindSpecOriginal :: DynFlags -> SrcSpan -> AuxBindSpec
+genAuxBindSpecOriginal :: SrcSpan -> AuxBindSpec
                        -> (LHsBind GhcPs, LSig GhcPs)
-genAuxBindSpecOriginal dflags loc spec
+genAuxBindSpecOriginal loc spec
   = (gen_bind spec,
      L loca (TypeSig noAnn [L locn (auxBindSpecRdrName spec)]
            (genAuxBindSpecSig loc spec)))
@@ -2183,11 +2182,10 @@ genAuxBindSpecOriginal dflags loc spec
       = mkHsVarBind loc dataT_RDR rhs
       where
         tc_name = tyConName tycon
-        tc_name_string = occNameString (getOccName tc_name)
-        definition_mod_name = moduleNameString (moduleName (expectJust "gen_bind DerivDataDataType" $ nameModule_maybe tc_name))
-        ctx = initDefaultSDocContext dflags
+        tc_name_string = occNameFS (getOccName tc_name)
+        definition_mod_name = moduleNameFS (moduleName (expectJust "gen_bind DerivDataDataType" $ nameModule_maybe tc_name))
         rhs = nlHsVar mkDataType_RDR
-              `nlHsApp` nlHsLit (mkHsString (showSDocOneLine ctx (text definition_mod_name <> dot <> text tc_name_string)))
+              `nlHsApp` nlHsLit (mkHsStringFS (concatFS [definition_mod_name, fsLit ".", tc_name_string]))
               `nlHsApp` nlList (map nlHsVar dataC_RDRs)
 
     gen_bind (DerivDataConstr dc dataC_RDR dataT_RDR)
@@ -2197,12 +2195,12 @@ genAuxBindSpecOriginal dflags loc spec
 
         constr_args
            = [ nlHsVar dataT_RDR                            -- DataType
-             , nlHsLit (mkHsString (occNameString dc_occ))  -- Constructor name
+             , nlHsLit (mkHsStringFS (occNameFS dc_occ))    -- Constructor name
              , nlHsIntLit (toInteger (dataConTag dc))       -- Constructor tag
              , nlList  labels                               -- Field labels
              , nlHsVar fixity ]                             -- Fixity
 
-        labels   = map (nlHsLit . mkHsString . unpackFS . field_label . flLabel)
+        labels   = map (nlHsLit . mkHsStringFS . field_label . flLabel)
                        (dataConFieldLabels dc)
         dc_occ   = getOccName dc
         is_infix = isDataSymOcc dc_occ
@@ -2243,9 +2241,9 @@ genAuxBindSpecSig loc spec = case spec of
 -- | Take a 'Bag' of 'AuxBindSpec's and generate the code for auxiliary
 -- bindings based on the declarative descriptions in the supplied
 -- 'AuxBindSpec's. See @Note [Auxiliary binders]@.
-genAuxBinds :: DynFlags -> SrcSpan -> Bag AuxBindSpec
+genAuxBinds :: SrcSpan -> Bag AuxBindSpec
             -> Bag (LHsBind GhcPs, LSig GhcPs)
-genAuxBinds dflags loc = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag)
+genAuxBinds loc = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag)
  where
   -- Perform a CSE-like pass over the generated auxiliary bindings to avoid
   -- code duplication, as described in
@@ -2259,7 +2257,7 @@ genAuxBinds dflags loc = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag)
     case lookupOccEnv original_rdr_name_env spec_occ of
       Nothing
         -> ( extendOccEnv original_rdr_name_env spec_occ spec_rdr_name
-           , genAuxBindSpecOriginal dflags loc spec `consBag` spec_bag )
+           , genAuxBindSpecOriginal loc spec `consBag` spec_bag )
       Just original_rdr_name
         -> ( original_rdr_name_env
            , genAuxBindSpecDup loc original_rdr_name spec `consBag` spec_bag )
@@ -2363,7 +2361,7 @@ mkRdrFunBindSE arity fun@(L loc fun_rdr) matches
                             (replicate arity nlWildPat)
                             (error_Expr str) emptyLocalBinds]
               else matches
-   str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
+   str = fsLit "Void " `appendFS` occNameFS (rdrNameOcc fun_rdr)
 
 
 box ::         String           -- The class involved
@@ -2550,8 +2548,8 @@ nested_compose_Expr (e:es)
 
 -- impossible_Expr is used in case RHSs that should never happen.
 -- We generate these to keep the desugarer from complaining that they *might* happen!
-error_Expr :: String -> LHsExpr GhcPs
-error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
+error_Expr :: FastString -> LHsExpr GhcPs
+error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsStringFS string))
 
 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
 -- method. It is currently only used by Enum.{succ,pred}
diff --git a/compiler/GHC/Types/ForeignCall.hs b/compiler/GHC/Types/ForeignCall.hs
index 41918f34db..e4c8018bb7 100644
--- a/compiler/GHC/Types/ForeignCall.hs
+++ b/compiler/GHC/Types/ForeignCall.hs
@@ -219,8 +219,8 @@ instance Outputable CCallSpec where
              | otherwise       = text "_unsafe"
 
       ppr_fun (StaticTarget st lbl mPkgId isFun)
-        = text (if isFun then "__ffi_static_ccall"
-                         else "__ffi_static_ccall_value")
+        = (if isFun then text "__ffi_static_ccall"
+                    else text "__ffi_static_ccall_value")
        <> gc_suf
        <+> (case mPkgId of
             Nothing -> empty
diff --git a/compiler/GHC/Types/ForeignStubs.hs b/compiler/GHC/Types/ForeignStubs.hs
index b92bfd9b64..f366ddbf4a 100644
--- a/compiler/GHC/Types/ForeignStubs.hs
+++ b/compiler/GHC/Types/ForeignStubs.hs
@@ -44,7 +44,7 @@ functionCStub platform clbl declarations body =
   where
     body' = vcat
         [ declarations
-        , hsep [text "void", pprCLabel platform CStyle clbl, text "(void)"]
+        , hsep [text "void", pprCLabel platform clbl, text "(void)"]
         , braces body
         ]
 
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs
index 1c6126d208..4e174ff4d0 100644
--- a/compiler/GHC/Utils/Outputable.hs
+++ b/compiler/GHC/Utils/Outputable.hs
@@ -83,7 +83,7 @@ module GHC.Utils.Outputable (
         -- * Controlling the style in which output is printed
         BindingSite(..),
 
-        PprStyle(..), LabelStyle(..), PrintUnqualified(..),
+        PprStyle(..), PrintUnqualified(..),
         QueryQualifyName, QueryQualifyModule, QueryQualifyPackage,
         reallyAlwaysQualify, reallyAlwaysQualifyNames,
         alwaysQualify, alwaysQualifyNames, alwaysQualifyModules,
@@ -173,19 +173,6 @@ data PprStyle
 
   | PprCode -- ^ Print code; either C or assembler
 
--- | Style of label pretty-printing.
---
--- When we produce C sources or headers, we have to take into account that C
--- compilers transform C labels when they convert them into symbols. For
--- example, they can add prefixes (e.g., "_" on Darwin) or suffixes (size for
--- stdcalls on Windows). So we provide two ways to pretty-print CLabels: C style
--- or Asm style.
---
-data LabelStyle
-   = CStyle   -- ^ C label style (used by C and LLVM backends)
-   | AsmStyle -- ^ Asm label style (used by NCG backend)
-   deriving (Eq,Ord,Show)
-
 data Depth
    = AllTheWay
    | PartWay Int  -- ^ 0 => stop
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 519049cad7..f697073763 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -298,6 +298,20 @@ flagWordBreakChars :: String
 flagWordBreakChars = " \t\n"
 
 
+showSDocForUser' :: GHC.GhcMonad m => SDoc -> m String
+showSDocForUser' doc = do
+    dflags <- getDynFlags
+    unit_state <- hsc_units <$> GHC.getSession
+    unqual <- GHC.getPrintUnqual
+    pure $ showSDocForUser dflags unit_state unqual doc
+
+showSDocForUserQualify :: GHC.GhcMonad m => SDoc -> m String
+showSDocForUserQualify doc = do
+    dflags <- getDynFlags
+    unit_state <- hsc_units <$> GHC.getSession
+    pure $ showSDocForUser dflags unit_state alwaysQualify doc
+
+
 keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi CmdExecOutcome)
 keepGoing a str = keepGoing' (lift . a) str
 
@@ -1572,11 +1586,10 @@ help _ = do
 info :: GHC.GhcMonad m => Bool -> String -> m ()
 info _ "" = throwGhcException (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
 info allInfo s  = handleSourceError GHC.printException $ do
-    unqual <- GHC.getPrintUnqual
-    dflags <- getDynFlags
-    sdocs  <- mapM (infoThing allInfo) (words s)
-    unit_state <- hsc_units <$> GHC.getSession
-    mapM_ (liftIO . putStrLn . showSDocForUser dflags unit_state unqual) sdocs
+    forM_ (words s) $ \thing -> do
+      sdoc <- infoThing allInfo thing
+      rendered <- showSDocForUser' sdoc
+      liftIO (putStrLn rendered)
 
 infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc
 infoThing allInfo str = do
@@ -1906,10 +1919,8 @@ docCmd s  = do
 
   let sdocs = pprDocs docs
       sdocs' = vcat (intersperse (text "") sdocs)
-  unqual <- GHC.getPrintUnqual
-  dflags <- getDynFlags
-  unit_state <- hsc_units <$> GHC.getSession
-  (liftIO . putStrLn . showSDocForUser dflags unit_state unqual) sdocs'
+  sdoc <- showSDocForUser' sdocs'
+  liftIO (putStrLn sdoc)
 
 data DocComponents =
   DocComponents
@@ -2264,9 +2275,6 @@ keepPackageImports = filterM is_pkg_import
 modulesLoadedMsg :: GHC.GhcMonad m => SuccessFlag -> [GHC.ModSummary] -> m ()
 modulesLoadedMsg ok mods = do
   dflags <- getDynFlags
-  unit_state <- hsc_units <$> GHC.getSession
-  unqual <- GHC.getPrintUnqual
-
   msg <- if gopt Opt_ShowLoadedModules dflags
          then do
                mod_names <- mapM mod_name mods
@@ -2278,8 +2286,9 @@ modulesLoadedMsg ok mods = do
                return $ status <> text ","
                     <+> speakNOf (length mods) (text "module") <+> "loaded."
 
-  when (verbosity dflags > 0) $
-     liftIO $ putStrLn $ showSDocForUser dflags unit_state unqual msg
+  when (verbosity dflags > 0) $ do
+     rendered_msg <- showSDocForUser' msg
+     liftIO $ putStrLn rendered_msg
   where
     status = case ok of
                   Failed    -> text "Failed"
@@ -2302,9 +2311,8 @@ runExceptGhciMonad act = handleSourceError GHC.printException $
                          runExceptT act
   where
     handleErr sdoc = do
-        dflags <- getDynFlags
-        unit_state <- hsc_units <$> GHC.getSession
-        liftIO . hPutStrLn stderr . showSDocForUser dflags unit_state alwaysQualify $ sdoc
+        rendered <- showSDocForUserQualify sdoc
+        liftIO $ hPutStrLn stderr rendered
         failIfExprEvalMode
 
 -- | Inverse of 'runExceptT' for \"pure\" computations
@@ -2369,11 +2377,8 @@ allTypesCmd _ = runExceptGhciMonad $ do
   where
     printSpan span'
       | Just ty <- spaninfoType span' = do
-        hsc_env <- GHC.getSession
-        let tyInfo = unwords . words $
-                     showSDocForUser (hsc_dflags hsc_env)
-                                     (hsc_units  hsc_env)
-                                     alwaysQualify (pprSigmaType ty)
+        tyInfo <- (unwords . words) <$>
+                  showSDocForUserQualify (pprSigmaType ty)
         liftIO . putStrLn $
             showRealSrcSpan (spaninfoSrcSpan span') ++ ": " ++ tyInfo
       | otherwise = return ()
@@ -2618,15 +2623,11 @@ guessCurrentModule cmd
 -- with sorted, sort items alphabetically
 browseModule :: GHC.GhcMonad m => Bool -> Module -> Bool -> m ()
 browseModule bang modl exports_only = do
-  -- :browse reports qualifiers wrt current context
-  unqual <- GHC.getPrintUnqual
-
   mb_mod_info <- GHC.getModuleInfo modl
   case mb_mod_info of
     Nothing -> throwGhcException (CmdLineError ("unknown module: " ++
                                 GHC.moduleNameString (GHC.moduleName modl)))
     Just mod_info -> do
-        dflags <- getDynFlags
         let names
                | exports_only = GHC.modInfoExports mod_info
                | otherwise    = GHC.modInfoTopLevelScope mod_info
@@ -2685,8 +2686,10 @@ browseModule bang modl exports_only = do
             prettyThings = map pretty things
             prettyThings' | bang      = annotate $ zip modNames prettyThings
                           | otherwise = prettyThings
-        unit_state <- hsc_units <$> GHC.getSession
-        liftIO $ putStrLn $ showSDocForUser dflags unit_state unqual (vcat prettyThings')
+
+        -- :browse reports qualifiers wrt current context
+        rendered_things <- showSDocForUser' (vcat prettyThings')
+        liftIO $ putStrLn rendered_things
         -- ToDo: modInfoInstances currently throws an exception for
         -- package modules.  When it works, we can do this:
         --        $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))