From 9de205be967c365976bc440722f969f0dfe1db54 Mon Sep 17 00:00:00 2001 From: Krzysztof Gogolewski Date: Tue, 26 Jul 2022 21:43:06 +0200 Subject: Always use code style in pprCLabel --- compiler/GHC/Cmm/CLabel.hs | 6 +++--- compiler/GHC/Types/CostCentre.hs | 17 ++++++++++++----- compiler/GHC/Types/Name.hs | 10 ++++++++++ compiler/GHC/Unit/Types.hs | 9 ++++++++- compiler/GHC/Utils/Outputable.hs | 3 +++ 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 ----------------------------------------------------------------------- -- cgit v1.2.1