Always use code style in pprCLabelwip/cleanup-printing

5 files changed, 36 insertions, 9 deletions

diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs
index a09a7777f4..a9a787626a 100644
--- a/compiler/GHC/Cmm/CLabel.hs
+++ b/compiler/GHC/Cmm/CLabel.hs
@@ -1468,7 +1468,7 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
                          if isRandomGenerated
                             then asmTempLabelPrefix platform
                             else empty
-      CStyle   -> ppr name <> ppIdFlavor flavor
+      CStyle   -> pprCodeName name <> ppIdFlavor flavor
 
    SRTLabel u
       -> maybe_underscore $ tempLabelPrefixOrUnderscore <> pprUniqueAlways u <> pp_cSEP <> text "srt"
@@ -1520,8 +1520,8 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
    HpcTicksLabel mod
       -> maybe_underscore $ text "_hpc_tickboxes_"  <> ppr mod <> text "_hpc"
 
-   CC_Label cc   -> maybe_underscore $ ppr cc
-   CCS_Label ccs -> maybe_underscore $ ppr ccs
+   CC_Label cc   -> maybe_underscore $ pprCodeCostCentre cc
+   CCS_Label ccs -> maybe_underscore $ pprCodeCostCentreStack 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
 
diff --git a/compiler/GHC/Types/CostCentre.hs b/compiler/GHC/Types/CostCentre.hs
index 61f6b87c88..8e32a3e896 100644
--- a/compiler/GHC/Types/CostCentre.hs
+++ b/compiler/GHC/Types/CostCentre.hs
@@ -8,11 +8,13 @@ module GHC.Types.CostCentre (
         currentCCS, dontCareCCS,
         isCurrentCCS,
         maybeSingletonCCS,
+        pprCodeCostCentreStack,
 
         mkUserCC, mkAutoCC, mkAllCafsCC,
         mkSingletonCCS,
         isCafCCS, isCafCC, isSccCountCC, sccAbleCC, ccFromThisModule,
 
+        pprCodeCostCentre,
         pprCostCentreCore,
         costCentreUserName, costCentreUserNameFS,
         costCentreSrcSpan,
@@ -233,10 +235,12 @@ mkSingletonCCS cc = SingletonCCS cc
 -- expression.
 
 instance Outputable CostCentreStack where
-  ppr CurrentCCS        = text "CCCS"
-  ppr DontCareCCS       = text "CCS_DONT_CARE"
-  ppr (SingletonCCS cc) = ppr cc <> text "_ccs"
+  ppr = pprCodeCostCentreStack
 
+pprCodeCostCentreStack :: CostCentreStack -> SDoc
+pprCodeCostCentreStack CurrentCCS        = text "CCCS"
+pprCodeCostCentreStack DontCareCCS       = text "CCS_DONT_CARE"
+pprCodeCostCentreStack (SingletonCCS cc) = pprCodeCostCentre cc <> text "_ccs"
 
 -----------------------------------------------------------------------------
 -- Printing Cost Centres
@@ -258,6 +262,9 @@ instance Outputable CostCentre where
            then ppCostCentreLbl cc
            else text (costCentreUserName cc)
 
+pprCodeCostCentre :: CostCentre -> SDoc
+pprCodeCostCentre = ppCostCentreLbl
+
 -- Printing in Core
 pprCostCentreCore :: CostCentre -> SDoc
 pprCostCentreCore (AllCafsCC {cc_mod = m})
@@ -282,9 +289,9 @@ pprIdxCore idx = whenPprDebug $ ppr idx
 
 -- Printing as a C label
 ppCostCentreLbl :: CostCentre -> SDoc
-ppCostCentreLbl (AllCafsCC  {cc_mod = m}) = ppr m <> text "_CAFs_cc"
+ppCostCentreLbl (AllCafsCC  {cc_mod = m}) = pprCodeModule m <> text "_CAFs_cc"
 ppCostCentreLbl (NormalCC {cc_flavour = f, cc_name = n, cc_mod = m})
-  = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <>
+  = pprCodeModule m <> char '_' <> ztext (zEncodeFS n) <> char '_' <>
         ppFlavourLblComponent f <> text "_cc"
 
 -- ^ Print the flavour component of a C label
diff --git a/compiler/GHC/Types/Name.hs b/compiler/GHC/Types/Name.hs
index 3d18d7bbb0..cfb4815c53 100644
--- a/compiler/GHC/Types/Name.hs
+++ b/compiler/GHC/Types/Name.hs
@@ -58,6 +58,7 @@ module GHC.Types.Name (
 
         nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt,
         pprFullName, pprTickyName,
+        pprCodeName,
 
         -- ** Predicates on 'Name's
         isSystemName, isInternalName, isExternalName,
@@ -640,6 +641,15 @@ pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ})
     handlePuns True (Just pun) _ = ftext pun
     handlePuns _    _          r = r
 
+pprCodeName :: Name -> SDoc
+pprCodeName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) =
+  -- TODO: might have to treat puns (namePun_maybe).
+  case sort of
+    WiredIn mod _ builtin -> pprCodeModule mod <> char '_' <> ppr_z_occ_name occ
+    External mod          -> pprCodeModule mod <> char '_' <> ppr_z_occ_name occ
+    System                -> pprUniqueAlways uniq
+    Internal              -> pprUniqueAlways uniq
+
 -- | Print fully qualified name (with unit-id, module and unique)
 pprFullName :: Module -> Name -> SDoc
 pprFullName this_mod Name{n_sort = sort, n_uniq = uniq, n_occ = occ} =
diff --git a/compiler/GHC/Unit/Types.hs b/compiler/GHC/Unit/Types.hs
index f71ce9c02e..f87e41a305 100644
--- a/compiler/GHC/Unit/Types.hs
+++ b/compiler/GHC/Unit/Types.hs
@@ -21,6 +21,7 @@ module GHC.Unit.Types
    , mkModule
    , moduleUnitId
    , pprModule
+   , pprCodeModule
    , pprInstantiatedModule
    , moduleFreeHoles
 
@@ -203,7 +204,7 @@ pprModule mod@(Module p n)  = getPprStyle doc
         (if p == mainUnit
                 then empty -- never qualify the main package in code
                 else ztext (zEncodeFS (unitFS p)) <> char '_')
-            <> pprModuleName n
+            <> pprCodeModuleName n
     | qualModule sty mod =
         case p of
           HoleUnit -> angleBrackets (pprModuleName n)
@@ -211,6 +212,12 @@ pprModule mod@(Module p n)  = getPprStyle doc
     | otherwise =
         pprModuleName n
 
+pprCodeModule :: Module -> SDoc
+pprCodeModule mod@(Module p n) =
+    (if p == mainUnit
+            then empty -- never qualify the main package in code
+            else ztext (zEncodeFS (unitFS p)) <> char '_')
+        <> pprCodeModuleName n
 
 pprInstantiatedModule :: InstantiatedModule -> SDoc
 pprInstantiatedModule (Module uid m) =
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs
index 6ff57e5775..96ddbe592a 100644
--- a/compiler/GHC/Utils/Outputable.hs
+++ b/compiler/GHC/Utils/Outputable.hs
@@ -79,6 +79,7 @@ module GHC.Utils.Outputable (
         pprFastFilePath, pprFilePathString,
 
         pprModuleName,
+        pprCodeModuleName,
 
         -- * Controlling the style in which output is printed
         BindingSite(..),
@@ -1051,6 +1052,8 @@ pprModuleName (ModuleName nm) =
         then ztext (zEncodeFS nm)
         else ftext nm
 
+pprCodeModuleName :: ModuleName -> SDoc
+pprCodeModuleName (ModuleName nm) = ztext (zEncodeFS nm)
 -----------------------------------------------------------------------
 -- The @OutputableP@ class
 -----------------------------------------------------------------------