Refactor CLabel pretty-printing

* Don't depend on the selected backend to know if we print Asm or C
  labels: we already have PprStyle to determine this. Moreover even when
  a native backend is used (NCG, LLVM) we may want to C headers
  containing pretty-printed labels, so it wasn't a good predicate
  anyway.

* Make pretty-printing code clearer and avoid partiality

10 files changed, 203 insertions, 224 deletions

diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs
index 370e727930..9b5fc82c5e 100644
--- a/compiler/GHC/Cmm/CLabel.hs
+++ b/compiler/GHC/Cmm/CLabel.hs
@@ -17,8 +17,9 @@ module GHC.Cmm.CLabel (
         CLabel, -- abstract type
         NeedExternDecl (..),
         ForeignLabelSource(..),
-        pprDebugCLabel,
+        DynamicLinkerLabelInfo(..),
 
+        -- * Constructors
         mkClosureLabel,
         mkSRTLabel,
         mkInfoTableLabel,
@@ -68,7 +69,6 @@ module GHC.Cmm.CLabel (
 
         mkSelectorInfoLabel,
         mkSelectorEntryLabel,
-
         mkCmmInfoLabel,
         mkCmmEntryLabel,
         mkCmmRetInfoLabel,
@@ -77,44 +77,52 @@ module GHC.Cmm.CLabel (
         mkCmmDataLabel,
         mkRtsCmmDataLabel,
         mkCmmClosureLabel,
-
         mkRtsApFastLabel,
-
         mkPrimCallLabel,
-
         mkForeignLabel,
-        addLabelSize,
-
-        foreignLabelStdcallInfo,
-        isBytesLabel,
-        isForeignLabel,
-        isSomeRODataLabel,
-        isStaticClosureLabel,
-        mkCCLabel, mkCCSLabel,
-
-        DynamicLinkerLabelInfo(..),
+        mkCCLabel,
+        mkCCSLabel,
         mkDynamicLinkerLabel,
-        dynamicLinkerLabelInfo,
-
         mkPicBaseLabel,
         mkDeadStripPreventer,
-
         mkHpcTicksLabel,
 
         -- * Predicates
         hasCAF,
-        needsCDecl, maybeLocalBlockLabel, externallyVisibleCLabel,
+        needsCDecl,
+        maybeLocalBlockLabel,
+        externallyVisibleCLabel,
         isMathFun,
-        isCFunctionLabel, isGcPtrLabel, labelDynamic,
-        isLocalCLabel, mayRedirectTo,
+        isCFunctionLabel,
+        isGcPtrLabel,
+        labelDynamic,
+        isLocalCLabel,
+        mayRedirectTo,
+        isInfoTableLabel,
+        isConInfoTableLabel,
+        isIdLabel,
+        isTickyLabel,
+        hasHaskellName,
+        isBytesLabel,
+        isForeignLabel,
+        isSomeRODataLabel,
+        isStaticClosureLabel,
 
         -- * Conversions
-        toClosureLbl, toSlowEntryLbl, toEntryLbl, toInfoLbl, hasHaskellName,
+        toClosureLbl,
+        toSlowEntryLbl,
+        toEntryLbl,
+        toInfoLbl,
 
-        pprCLabel, pprCLabel_LLVM, pprCLabel_NCG, pprCLabel_ViaC,
-        isInfoTableLabel,
-        isConInfoTableLabel,
-        isIdLabel, isTickyLabel
+        -- * Pretty-printing
+        LabelStyle (..),
+        pprDebugCLabel,
+        pprCLabel,
+
+        -- * Others
+        dynamicLinkerLabelInfo,
+        addLabelSize,
+        foreignLabelStdcallInfo
     ) where
 
 #include "HsVersions.h"
@@ -133,7 +141,6 @@ import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Data.FastString
 import GHC.Driver.Session
-import GHC.Driver.Backend
 import GHC.Platform
 import GHC.Types.Unique.Set
 import GHC.Utils.Misc
@@ -403,23 +410,22 @@ data ForeignLabelSource
 --      The regular Outputable instance only shows the label name, and not its other info.
 --
 pprDebugCLabel :: Platform -> CLabel -> SDoc
-pprDebugCLabel platform lbl
- = case lbl of
-        IdLabel _ _ info-> pprCLabel_other platform lbl
-                           <> (parens $ text "IdLabel"
-                           <> whenPprDebug (text ":" <> text (show info)))
-        CmmLabel pkg _ext _name _info
-         -> pprCLabel_other platform lbl <> (parens $ text "CmmLabel" <+> ppr pkg)
+pprDebugCLabel platform lbl = pprCLabel platform AsmStyle lbl <> parens extra
+   where
+      extra = case lbl of
+         IdLabel _ _ info
+            -> text "IdLabel" <> whenPprDebug (text ":" <> text (show info))
+
+         CmmLabel pkg _ext _name _info
+            -> text "CmmLabel" <+> ppr pkg
 
-        RtsLabel{}      -> pprCLabel_other platform lbl <> (parens $ text "RtsLabel")
+         RtsLabel{}
+            -> text "RtsLabel"
 
-        ForeignLabel _name mSuffix src funOrData
-            -> pprCLabel_other platform lbl <> (parens $ text "ForeignLabel"
-                                        <+> ppr mSuffix
-                                        <+> ppr src
-                                        <+> ppr funOrData)
+         ForeignLabel _name mSuffix src funOrData
+             -> text "ForeignLabel" <+> ppr mSuffix <+> ppr src <+> ppr funOrData
 
-        _               -> pprCLabel_other platform lbl <> (parens $ text "other CLabel")
+         _  -> text "other CLabel"
 
 
 data IdLabelInfo
@@ -760,13 +766,13 @@ toClosureLbl :: Platform -> CLabel -> CLabel
 toClosureLbl platform lbl = case lbl of
    IdLabel n c _        -> IdLabel n c Closure
    CmmLabel m ext str _ -> CmmLabel m ext str CmmClosure
-   _                    -> pprPanic "toClosureLbl" (pprCLabel_other platform lbl)
+   _                    -> pprPanic "toClosureLbl" (pprDebugCLabel platform lbl)
 
 toSlowEntryLbl :: Platform -> CLabel -> CLabel
 toSlowEntryLbl platform lbl = case lbl of
    IdLabel n _ BlockInfoTable -> pprPanic "toSlowEntryLbl" (ppr n)
    IdLabel n c _              -> IdLabel n c Slow
-   _                          -> pprPanic "toSlowEntryLbl" (pprCLabel_other platform lbl)
+   _                          -> pprPanic "toSlowEntryLbl" (pprDebugCLabel platform lbl)
 
 toEntryLbl :: Platform -> CLabel -> CLabel
 toEntryLbl platform lbl = case lbl of
@@ -777,7 +783,7 @@ toEntryLbl platform lbl = case lbl of
    IdLabel n c _                 -> IdLabel n c Entry
    CmmLabel m ext str CmmInfo    -> CmmLabel m ext str CmmEntry
    CmmLabel m ext str CmmRetInfo -> CmmLabel m ext str CmmRet
-   _                             -> pprPanic "toEntryLbl" (pprCLabel_other platform lbl)
+   _                             -> pprPanic "toEntryLbl" (pprDebugCLabel platform lbl)
 
 toInfoLbl :: Platform -> CLabel -> CLabel
 toInfoLbl platform lbl = case lbl of
@@ -786,7 +792,7 @@ toInfoLbl platform lbl = case lbl of
    IdLabel n c _               -> IdLabel n c InfoTable
    CmmLabel m ext str CmmEntry -> CmmLabel m ext str CmmInfo
    CmmLabel m ext str CmmRet   -> CmmLabel m ext str CmmRetInfo
-   _                           -> pprPanic "CLabel.toInfoLbl" (pprCLabel_other platform lbl)
+   _                           -> pprPanic "CLabel.toInfoLbl" (pprDebugCLabel platform lbl)
 
 hasHaskellName :: CLabel -> Maybe Name
 hasHaskellName (IdLabel n _ _) = Just n
@@ -1214,36 +1220,32 @@ and are not externally visible.
 -}
 
 instance OutputableP Platform CLabel where
-  pdoc platform lbl = sdocWithDynFlags (\dflags -> pprCLabel (backend dflags) platform lbl)
-
-pprCLabel :: Backend -> Platform -> CLabel -> SDoc
-pprCLabel bcknd platform lbl =
-   case bcknd of
-      NCG  -> pprCLabel_NCG   platform lbl
-      LLVM -> pprCLabel_LLVM  platform lbl
-      ViaC -> pprCLabel_ViaC  platform lbl
-      _    -> pprCLabel_other platform lbl
-
-pprCLabel_LLVM :: Platform -> CLabel -> SDoc
-pprCLabel_LLVM = pprCLabel_NCG
-
-pprCLabel_ViaC :: Platform -> CLabel -> SDoc
-pprCLabel_ViaC = pprCLabel_other
-
-pprCLabel_NCG :: Platform -> CLabel -> SDoc
-pprCLabel_NCG platform lbl = getPprStyle $ \sty ->
+  pdoc platform lbl = getPprStyle $ \case
+                        PprCode CStyle   -> pprCLabel platform CStyle lbl
+                        PprCode AsmStyle -> pprCLabel platform AsmStyle lbl
+                        _                -> pprCLabel platform CStyle lbl
+                                            -- default to CStyle
+
+pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc
+pprCLabel platform sty lbl =
   let
     -- some platform (e.g. Darwin) require a leading "_" for exported asm
     -- symbols
     maybe_underscore :: SDoc -> SDoc
-    maybe_underscore doc =
-      if platformLeadingUnderscore platform
-      then pp_cSEP <> doc
-      else doc
+    maybe_underscore doc = case sty of
+      AsmStyle | platformLeadingUnderscore platform -> pp_cSEP <> doc
+      _                                             -> doc
+
+    tempLabelPrefixOrUnderscore :: Platform -> SDoc
+    tempLabelPrefixOrUnderscore platform = case sty of
+      AsmStyle -> ptext (asmTempLabelPrefix platform)
+      CStyle   -> char '_'
+
 
   in case lbl of
-   LocalBlockLabel u
-      -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u
+   LocalBlockLabel u -> case sty of
+      AsmStyle -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u
+      CStyle   -> tempLabelPrefixOrUnderscore platform <> text "blk_" <> pprUniqueAlways u
 
    AsmTempLabel u
       -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u
@@ -1252,11 +1254,11 @@ pprCLabel_NCG platform lbl = getPprStyle $ \sty ->
       -> ptext (asmTempLabelPrefix platform)
          <> case l of AsmTempLabel u    -> pprUniqueAlways u
                       LocalBlockLabel u -> pprUniqueAlways u
-                      _other            -> pprCLabel_NCG platform l
+                      _other            -> pprCLabel platform sty l
          <> ftext suf
 
    DynamicLinkerLabel info lbl
-      -> pprDynamicLinkerAsmLabel platform info lbl
+      -> pprDynamicLinkerAsmLabel platform info (pprCLabel platform AsmStyle lbl)
 
    PicBaseLabel
       -> text "1b"
@@ -1269,127 +1271,109 @@ pprCLabel_NCG platform lbl = getPprStyle $ \sty ->
          optional `_` (underscore) because this is how you mark non-temp symbols
          on some platforms (Darwin)
       -}
-      maybe_underscore $ text "dsp_" <> pprCLabel_NCG platform lbl <> text "_dsp"
+      maybe_underscore $ text "dsp_" <> pprCLabel platform sty lbl <> text "_dsp"
 
    StringLitLabel u
-      -> pprUniqueAlways u <> ptext (sLit "_str")
+      -> maybe_underscore $ pprUniqueAlways u <> ptext (sLit "_str")
 
    ForeignLabel fs (Just sz) _ _
-      | asmStyle sty
+      | AsmStyle <- sty
       , OSMinGW32 <- platformOS platform
       -> -- In asm mode, we need to put the suffix on a stdcall ForeignLabel.
          -- (The C compiler does this itself).
          maybe_underscore $ ftext fs <> char '@' <> int sz
 
-   _  | asmStyle sty -> maybe_underscore $ pprCLabel_common platform lbl
-      | otherwise    -> pprCLabel_common platform lbl
-
-pprCLabel_other :: Platform -> CLabel -> SDoc
-pprCLabel_other platform lbl =
-   case lbl of
-      LocalBlockLabel u
-         -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u
-
-      AsmTempLabel u
-         | not (platformUnregisterised platform)
-         -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u
-
-      lbl -> pprCLabel_common platform lbl
-
-
-pprCLabel_common :: Platform -> CLabel -> SDoc
-pprCLabel_common platform = \case
-   (StringLitLabel u)   -> pprUniqueAlways u <> text "_str"
-   (SRTLabel u)         -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u <> pp_cSEP <> text "srt"
-   (LargeBitmapLabel u) -> tempLabelPrefixOrUnderscore platform
-                           <> char 'b' <> pprUniqueAlways u <> pp_cSEP <> text "btm"
-                           -- Some bitmaps for tuple constructors have a numeric tag (e.g. '7')
-                           -- until that gets resolved we'll just force them to start
-                           -- with a letter so the label will be legal assembly code.
-
-   (CmmLabel _ _ str CmmCode)     -> ftext str
-   (CmmLabel _ _ str CmmData)     -> ftext str
-   (CmmLabel _ _ str CmmPrimCall) -> ftext str
-
-   (LocalBlockLabel u) -> tempLabelPrefixOrUnderscore platform <> text "blk_" <> pprUniqueAlways u
-
-   (RtsLabel (RtsApFast (NonDetFastString str))) -> ftext str <> text "_fast"
-
-   (RtsLabel (RtsSelectorInfoTable upd_reqd offset)) ->
-    hcat [text "stg_sel_", text (show offset),
-          ptext (if upd_reqd
-                 then (sLit "_upd_info")
-                 else (sLit "_noupd_info"))
-        ]
-
-   (RtsLabel (RtsSelectorEntry upd_reqd offset)) ->
-    hcat [text "stg_sel_", text (show offset),
-                ptext (if upd_reqd
-                        then (sLit "_upd_entry")
-                        else (sLit "_noupd_entry"))
-        ]
-
-   (RtsLabel (RtsApInfoTable upd_reqd arity)) ->
-    hcat [text "stg_ap_", text (show arity),
-                ptext (if upd_reqd
-                        then (sLit "_upd_info")
-                        else (sLit "_noupd_info"))
-        ]
-
-   (RtsLabel (RtsApEntry upd_reqd arity)) ->
-    hcat [text "stg_ap_", text (show arity),
-                ptext (if upd_reqd
-                        then (sLit "_upd_entry")
-                        else (sLit "_noupd_entry"))
-        ]
-
-   (CmmLabel _ _ fs CmmInfo)    -> ftext fs <> text "_info"
-   (CmmLabel _ _ fs CmmEntry)   -> ftext fs <> text "_entry"
-   (CmmLabel _ _ fs CmmRetInfo) -> ftext fs <> text "_info"
-   (CmmLabel _ _ fs CmmRet)     -> ftext fs <> text "_ret"
-   (CmmLabel _ _ fs CmmClosure) -> ftext fs <> text "_closure"
-
-   (RtsLabel (RtsPrimOp primop)) -> text "stg_" <> ppr primop
-   (RtsLabel (RtsSlowFastTickyCtr pat)) ->
-      text "SLOW_CALL_fast_" <> text pat <> ptext (sLit "_ctr")
-
-   (ForeignLabel str _ _ _) -> ftext str
-
-   (IdLabel name _cafs flavor) -> internalNamePrefix <> ppr name <> ppIdFlavor flavor
-                                    where
-                                       isRandomGenerated = not (isExternalName name)
-                                       internalNamePrefix = getPprStyle $ \ sty ->
-                                          if asmStyle sty && isRandomGenerated
-                                             then ptext (asmTempLabelPrefix platform)
-                                             else empty
-
-   (CC_Label cc)       -> ppr cc
-   (CCS_Label ccs)     -> ppr ccs
-   (HpcTicksLabel mod) -> text "_hpc_tickboxes_"  <> ppr mod <> ptext (sLit "_hpc")
-
-   (AsmTempLabel {})        -> panic "pprCLabel_common AsmTempLabel"
-   (AsmTempDerivedLabel {}) -> panic "pprCLabel_common AsmTempDerivedLabel"
-   (DynamicLinkerLabel {})  -> panic "pprCLabel_common DynamicLinkerLabel"
-   (PicBaseLabel {})        -> panic "pprCLabel_common PicBaseLabel"
-   (DeadStripPreventer {})  -> panic "pprCLabel_common DeadStripPreventer"
+   ForeignLabel fs _ _ _
+      -> maybe_underscore $ ftext fs
+
+
+   IdLabel name _cafs flavor -> case sty of
+      AsmStyle -> maybe_underscore $ internalNamePrefix <> ppr name <> ppIdFlavor flavor
+                   where
+                      isRandomGenerated = not (isExternalName name)
+                      internalNamePrefix =
+                         if isRandomGenerated
+                            then ptext (asmTempLabelPrefix platform)
+                            else empty
+      CStyle   -> ppr name <> ppIdFlavor flavor
+
+   SRTLabel u
+      -> maybe_underscore $ tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u <> pp_cSEP <> text "srt"
+
+   RtsLabel (RtsApFast (NonDetFastString str))
+      -> maybe_underscore $ ftext str <> text "_fast"
+
+   RtsLabel (RtsSelectorInfoTable upd_reqd offset)
+      -> maybe_underscore $ hcat [text "stg_sel_", text (show offset),
+                                  ptext (if upd_reqd
+                                         then (sLit "_upd_info")
+                                         else (sLit "_noupd_info"))
+                                 ]
+
+   RtsLabel (RtsSelectorEntry upd_reqd offset)
+      -> maybe_underscore $ hcat [text "stg_sel_", text (show offset),
+                                        ptext (if upd_reqd
+                                                then (sLit "_upd_entry")
+                                                else (sLit "_noupd_entry"))
+                                 ]
+
+   RtsLabel (RtsApInfoTable upd_reqd arity)
+      -> maybe_underscore $ hcat [text "stg_ap_", text (show arity),
+                                        ptext (if upd_reqd
+                                                then (sLit "_upd_info")
+                                                else (sLit "_noupd_info"))
+                                 ]
+
+   RtsLabel (RtsApEntry upd_reqd arity)
+      -> maybe_underscore $ hcat [text "stg_ap_", text (show arity),
+                                        ptext (if upd_reqd
+                                                then (sLit "_upd_entry")
+                                                else (sLit "_noupd_entry"))
+                                 ]
+
+   RtsLabel (RtsPrimOp primop)
+      -> maybe_underscore $ text "stg_" <> ppr primop
+
+   RtsLabel (RtsSlowFastTickyCtr pat)
+      -> maybe_underscore $ text "SLOW_CALL_fast_" <> text pat <> ptext (sLit "_ctr")
+
+   LargeBitmapLabel u
+      -> maybe_underscore $ tempLabelPrefixOrUnderscore platform
+                            <> char 'b' <> pprUniqueAlways u <> pp_cSEP <> text "btm"
+                            -- Some bitmaps for tuple constructors have a numeric tag (e.g. '7')
+                            -- until that gets resolved we'll just force them to start
+                            -- with a letter so the label will be legal assembly code.
+
+   HpcTicksLabel mod
+      -> maybe_underscore $ text "_hpc_tickboxes_"  <> ppr mod <> ptext (sLit "_hpc")
+
+   CC_Label cc   -> maybe_underscore $ ppr cc
+   CCS_Label ccs -> maybe_underscore $ ppr ccs
+
+   CmmLabel _ _ fs CmmCode     -> maybe_underscore $ ftext fs
+   CmmLabel _ _ fs CmmData     -> maybe_underscore $ ftext fs
+   CmmLabel _ _ fs CmmPrimCall -> maybe_underscore $ ftext fs
+   CmmLabel _ _ fs CmmInfo     -> maybe_underscore $ ftext fs <> text "_info"
+   CmmLabel _ _ fs CmmEntry    -> maybe_underscore $ ftext fs <> text "_entry"
+   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"
 
-ppIdFlavor :: IdLabelInfo -> SDoc
-ppIdFlavor x = pp_cSEP <> text
-               (case x of
-                       Closure          -> "closure"
-                       InfoTable        -> "info"
-                       LocalInfoTable   -> "info"
-                       Entry            -> "entry"
-                       LocalEntry       -> "entry"
-                       Slow             -> "slow"
-                       RednCounts       -> "ct"
-                       ConEntry         -> "con_entry"
-                       ConInfoTable     -> "con_info"
-                       ClosureTable     -> "closure_tbl"
-                       Bytes            -> "bytes"
-                       BlockInfoTable   -> "info"
-                      )
 
+ppIdFlavor :: IdLabelInfo -> SDoc
+ppIdFlavor x = pp_cSEP <> case x of
+   Closure          -> text "closure"
+   InfoTable        -> text "info"
+   LocalInfoTable   -> text "info"
+   Entry            -> text "entry"
+   LocalEntry       -> text "entry"
+   Slow             -> text "slow"
+   RednCounts       -> text "ct"
+   ConEntry         -> text "con_entry"
+   ConInfoTable     -> text "con_info"
+   ClosureTable     -> text "closure_tbl"
+   Bytes            -> text "bytes"
+   BlockInfoTable   -> text "info"
 
 pp_cSEP :: SDoc
 pp_cSEP = char '_'
@@ -1402,14 +1386,6 @@ instance Outputable ForeignLabelSource where
         ForeignLabelInThisPackage       -> parens $ text "this package"
         ForeignLabelInExternalPackage   -> parens $ text "external package"
 
-tempLabelPrefixOrUnderscore :: Platform -> SDoc
-tempLabelPrefixOrUnderscore platform =
-  getPprStyle $ \ sty ->
-   if asmStyle sty then
-      ptext (asmTempLabelPrefix platform)
-   else
-      char '_'
-
 -- -----------------------------------------------------------------------------
 -- Machine-dependent knowledge about labels.
 
@@ -1419,8 +1395,8 @@ asmTempLabelPrefix platform = case platformOS platform of
     OSAIX    -> sLit "__L" -- follow IBM XL C's convention
     _        -> sLit ".L"
 
-pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> CLabel -> SDoc
-pprDynamicLinkerAsmLabel platform dllInfo lbl =
+pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> SDoc -> SDoc
+pprDynamicLinkerAsmLabel platform dllInfo ppLbl =
     case platformOS platform of
       OSDarwin
         | platformArch platform == ArchX86_64 ->
@@ -1449,7 +1425,6 @@ pprDynamicLinkerAsmLabel platform dllInfo lbl =
 
       _ -> panic "pprDynamicLinkerAsmLabel"
   where
-    ppLbl = pprCLabel_NCG platform lbl
     elfLabel
       | platformArch platform == ArchPPC
       = case dllInfo of
diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs
index 6c142ed9d8..18590a3ee8 100644
--- a/compiler/GHC/CmmToAsm.hs
+++ b/compiler/GHC/CmmToAsm.hs
@@ -803,7 +803,7 @@ makeImportsDoc dflags imports
 
         doPpr lbl = (lbl, renderWithContext
                               (ncgAsmContext config)
-                              (pprCLabel_NCG platform lbl))
+                              (pprCLabel platform AsmStyle lbl))
 
 -- -----------------------------------------------------------------------------
 -- Generate jump tables
@@ -1149,7 +1149,7 @@ cmmExprNative referenceKind expr = do
 initNCGConfig :: DynFlags -> NCGConfig
 initNCGConfig dflags = NCGConfig
    { ncgPlatform              = targetPlatform dflags
-   , ncgAsmContext            = initSDocContext dflags (mkCodeStyle AsmStyle)
+   , ncgAsmContext            = initSDocContext dflags (PprCode AsmStyle)
    , ncgProcAlignment         = cmmProcAlignment dflags
    , ncgExternalDynamicRefs   = gopt Opt_ExternalDynamicRefs dflags
    , ncgPIC                   = positionIndependent dflags
diff --git a/compiler/GHC/CmmToAsm/Dwarf/Types.hs b/compiler/GHC/CmmToAsm/Dwarf/Types.hs
index c4748b00cd..449ba4a737 100644
--- a/compiler/GHC/CmmToAsm/Dwarf/Types.hs
+++ b/compiler/GHC/CmmToAsm/Dwarf/Types.hs
@@ -164,9 +164,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
-    $ withPprStyle (mkCodeStyle CStyle) -- force CStyle (foreign labels may be printed differently in AsmStyle)
-    $ pprCLabel_NCG 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)
 
 -- | 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/CmmToAsm/PIC.hs b/compiler/GHC/CmmToAsm/PIC.hs
index d776b1addb..450a01b7fd 100644
--- a/compiler/GHC/CmmToAsm/PIC.hs
+++ b/compiler/GHC/CmmToAsm/PIC.hs
@@ -699,7 +699,7 @@ pprImportedSymbol config importedLbl = case (arch,os) of
    _ -> panic "PIC.pprImportedSymbol: no match"
  where
    platform = ncgPlatform config
-   ppr_lbl  = pprCLabel_NCG platform
+   ppr_lbl  = pprCLabel     platform AsmStyle
    arch     = platformArch  platform
    os       = platformOS    platform
    pic      = ncgPIC config
diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs
index db93ef8df8..6aa4f9b729 100644
--- a/compiler/GHC/CmmToC.hs
+++ b/compiler/GHC/CmmToC.hs
@@ -91,7 +91,7 @@ pprTop platform = \case
            blankLine,
            extern_decls,
            (if (externallyVisibleCLabel clbl)
-                    then mkFN_ else mkIF_) (pprCLabel_ViaC platform clbl) <+> lbrace,
+                    then mkFN_ else mkIF_) (pprCLabel platform CStyle 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_ViaC platform lbl,
+      pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform CStyle lbl,
       text "[] = ", pprStringInCStyle str, semi
     ]
 
   (CmmData section (CmmStaticsRaw lbl [CmmUninitialised size])) ->
     pprExternDecl platform lbl $$
     hcat [
-      pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel_ViaC platform lbl,
+      pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform CStyle 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_ViaC platform lbl, text "[]"
+         , space, pprCLabel platform CStyle lbl, text "[]"
          -- See Note [StgWord alignment]
          , pprAlignment (wordWidth platform)
          , text "= {" ]
@@ -238,7 +238,7 @@ pprStmt platform stmt =
             case fn of
               CmmLit (CmmLabel lbl)
                 | StdCallConv <- cconv ->
-                    pprCall platform (pprCLabel_ViaC platform lbl) cconv hresults hargs
+                    pprCall platform (pprCLabel platform CStyle 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
@@ -247,7 +247,7 @@ pprStmt platform stmt =
                 | CmmNeverReturns <- ret ->
                     pprCall platform cast_fn cconv hresults hargs <> semi
                 | not (isMathFun lbl) ->
-                    pprForeignCall platform (pprCLabel_ViaC platform lbl) cconv hresults hargs
+                    pprForeignCall platform (pprCLabel platform CStyle lbl) cconv hresults hargs
               _ ->
                     pprCall platform cast_fn cconv hresults hargs <> semi
                         -- for a dynamic call, no declaration is necessary.
@@ -487,7 +487,7 @@ pprLit platform lit = case lit of
         -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i
 
     where
-        pprCLabelAddr lbl = char '&' <> pprCLabel_ViaC platform lbl
+        pprCLabelAddr lbl = char '&' <> pprCLabel platform CStyle lbl
 
 pprLit1 :: Platform -> CmmLit -> SDoc
 pprLit1 platform lit = case lit of
@@ -1047,7 +1047,7 @@ pprExternDecl platform lbl
   | not (needsCDecl lbl) = empty
   | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz
   | otherwise =
-        hcat [ visibility, label_type lbl , lparen, pprCLabel_ViaC platform lbl, text ");"
+        hcat [ visibility, label_type lbl , lparen, pprCLabel platform CStyle lbl, text ");"
              -- occasionally useful to see label type
              -- , text "/* ", pprDebugCLabel lbl, text " */"
              ]
@@ -1070,7 +1070,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_ViaC platform lbl
+        text "extern __attribute__((stdcall)) void " <> pprCLabel platform CStyle lbl
         <> parens (commafy (replicate (sz `quot` platformWordSizeInBytes platform) (machRep_U_CType platform (wordWidth platform))))
         <> semi
 
diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs
index d7667bb073..43eaab424e 100644
--- a/compiler/GHC/CmmToLlvm/Base.hs
+++ b/compiler/GHC/CmmToLlvm/Base.hs
@@ -435,7 +435,7 @@ renderLlvm sdoc = do
     -- Write to output
     dflags <- getDynFlags
     out <- getEnv envOutput
-    let ctx = initSDocContext dflags (Outp.mkCodeStyle Outp.CStyle)
+    let ctx = initSDocContext dflags (Outp.PprCode Outp.CStyle)
     liftIO $ Outp.bufLeftRenderSDoc ctx out sdoc
 
     -- Dump, if requested
@@ -497,9 +497,9 @@ strCLabel_llvm :: CLabel -> LlvmM LMString
 strCLabel_llvm lbl = do
     dflags <- getDynFlags
     platform <- getPlatform
-    let sdoc = pprCLabel_LLVM platform lbl
+    let sdoc = pprCLabel platform CStyle lbl
         str = Outp.renderWithContext
-                  (initSDocContext dflags (Outp.mkCodeStyle Outp.CStyle))
+                  (initSDocContext dflags (Outp.PprCode Outp.CStyle))
                   sdoc
     return (fsLit str)
 
diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs
index 34d0353681..78f22e5710 100644
--- a/compiler/GHC/CmmToLlvm/CodeGen.hs
+++ b/compiler/GHC/CmmToLlvm/CodeGen.hs
@@ -1565,7 +1565,7 @@ genMachOp_slow opt op [x, y] = case op of
                 else do
                     -- Error. Continue anyway so we can debug the generated ll file.
                     dflags <- getDynFlags
-                    let style = mkCodeStyle CStyle
+                    let style = PprCode CStyle
                         toString doc = renderWithContext (initSDocContext dflags style) doc
                         cmmToStr = (lines . toString . PprCmm.pprExpr platform)
                     statement $ Comment $ map fsLit $ cmmToStr x
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index b72d579e33..7cab547af2 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -1384,7 +1384,7 @@ jsonLogAction :: LogAction
 jsonLogAction dflags reason severity srcSpan msg
   = do
     defaultLogActionHPutStrDoc dflags stdout
-      (withPprStyle (mkCodeStyle CStyle) (doc $$ text ""))
+      (withPprStyle (PprCode CStyle) (doc $$ text ""))
     where
       doc = renderJSON $
               JSObject [ ( "span", json srcSpan )
diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs
index 9c3cb8db9d..59c0bfb4ed 100644
--- a/compiler/GHC/HsToCore/Coverage.hs
+++ b/compiler/GHC/HsToCore/Coverage.hs
@@ -1334,8 +1334,7 @@ hpcInitCode dflags this_mod (HpcInfo tickCount hashNo)
     ]
   where
     platform  = targetPlatform dflags
-    bcknd     = backend dflags
-    tickboxes = pprCLabel bcknd platform (mkHpcTicksLabel $ this_mod)
+    tickboxes = pprCLabel platform CStyle (mkHpcTicksLabel $ this_mod)
 
     module_name  = hcat (map (text.charToC) $ BS.unpack $
                          bytesFS (moduleNameFS (moduleName this_mod)))
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs
index abb3e94615..c0537e4dc0 100644
--- a/compiler/GHC/Utils/Outputable.hs
+++ b/compiler/GHC/Utils/Outputable.hs
@@ -51,7 +51,7 @@ module GHC.Utils.Outputable (
         -- * Converting 'SDoc' into strings and outputting it
         printSDoc, printSDocLn,
         bufLeftRenderSDoc,
-        pprCode, mkCodeStyle,
+        pprCode,
         showSDocOneLine,
         renderWithContext,
 
@@ -68,7 +68,7 @@ module GHC.Utils.Outputable (
         -- * Controlling the style in which output is printed
         BindingSite(..),
 
-        PprStyle(..), CodeStyle(..), PrintUnqualified(..),
+        PprStyle(..), LabelStyle(..), PrintUnqualified(..),
         QueryQualifyName, QueryQualifyModule, QueryQualifyPackage,
         reallyAlwaysQualify, reallyAlwaysQualifyNames,
         alwaysQualify, alwaysQualifyNames, alwaysQualifyModules,
@@ -150,11 +150,20 @@ data PprStyle
                 -- Does not assume tidied code: non-external names
                 -- are printed with uniques.
 
-  | PprCode CodeStyle
-                -- Print code; either C or assembler
+  | PprCode LabelStyle -- ^ Print code; either C or assembler
 
-data CodeStyle = CStyle         -- The format of labels differs for C and assembler
-               | AsmStyle
+-- | 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
@@ -556,12 +565,9 @@ bufLeftRenderSDoc :: SDocContext -> BufHandle -> SDoc -> IO ()
 bufLeftRenderSDoc ctx bufHandle doc =
   Pretty.bufLeftRender bufHandle (runSDoc doc ctx)
 
-pprCode :: CodeStyle -> SDoc -> SDoc
+pprCode :: LabelStyle -> SDoc -> SDoc
 pprCode cs d = withPprStyle (PprCode cs) d
 
-mkCodeStyle :: CodeStyle -> PprStyle
-mkCodeStyle = PprCode
-
 renderWithContext :: SDocContext -> SDoc -> String
 renderWithContext ctx sdoc
   = let s = Pretty.style{ Pretty.mode       = PageMode,