[Git][ghc/ghc][master] Cleanups around pretty-printing
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Aug 9 06:32:39 UTC 2022
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
e9dfd26a by Krzysztof Gogolewski at 2022-08-09T02:32:24-04:00
Cleanups around pretty-printing
* Remove hack when printing OccNames. No longer needed since e3dcc0d5
* Remove unused `pprCmms` and `instance Outputable Instr`
* Simplify `pprCLabel` (no need to pass platform)
* Remove evil `Show`/`Eq` instances for `SDoc`. They were needed by
ImmLit, but that can take just a String instead.
* Remove instance `Outputable CLabel` - proper output of labels
needs a platform, and is done by the `OutputableP` instance
- - - - -
13 changed files:
- compiler/GHC/Cmm.hs
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/CmmToAsm/AArch64/Ppr.hs
- compiler/GHC/CmmToAsm/AArch64/Regs.hs
- compiler/GHC/CmmToAsm/PPC/CodeGen.hs
- compiler/GHC/CmmToAsm/PPC/Ppr.hs
- compiler/GHC/CmmToAsm/PPC/Regs.hs
- compiler/GHC/CmmToAsm/X86/Ppr.hs
- compiler/GHC/CmmToAsm/X86/Regs.hs
- compiler/GHC/StgToCmm/Ticky.hs
- compiler/GHC/Types/Name/Occurrence.hs
- compiler/GHC/Unit/Types.hs
- testsuite/tests/linters/notes.stdout
Changes:
=====================================
compiler/GHC/Cmm.hs
=====================================
@@ -33,7 +33,7 @@ module GHC.Cmm (
module GHC.Cmm.Expr,
-- * Pretty-printing
- pprCmms, pprCmmGroup, pprSection, pprStatic
+ pprCmmGroup, pprSection, pprStatic
) where
import GHC.Prelude
@@ -379,12 +379,6 @@ pprBBlock (BasicBlock ident stmts) =
--
-- These conventions produce much more readable Cmm output.
-pprCmms :: (OutputableP Platform info, OutputableP Platform g)
- => Platform -> [GenCmmGroup RawCmmStatics info g] -> SDoc
-pprCmms platform cmms = pprCode CStyle (vcat (intersperse separator $ map (pdoc platform) cmms))
- where
- separator = space $$ text "-------------------" $$ space
-
pprCmmGroup :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform g)
=> Platform -> GenCmmGroup d info g -> SDoc
pprCmmGroup platform tops
=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -294,9 +294,6 @@ data CLabel
instance Show CLabel where
show = showPprUnsafe . pprDebugCLabel genericPlatform
-instance Outputable CLabel where
- ppr = text . show
-
data ModuleLabelKind
= MLK_Initializer String
| MLK_InitializerArray
@@ -1412,19 +1409,19 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
AsmStyle | use_leading_underscores -> pp_cSEP <> doc
_ -> doc
- tempLabelPrefixOrUnderscore :: Platform -> SDoc
- tempLabelPrefixOrUnderscore platform = case sty of
+ tempLabelPrefixOrUnderscore :: SDoc
+ tempLabelPrefixOrUnderscore = case sty of
AsmStyle -> asmTempLabelPrefix platform
CStyle -> char '_'
in case lbl of
LocalBlockLabel u -> case sty of
- AsmStyle -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u
- CStyle -> tempLabelPrefixOrUnderscore platform <> text "blk_" <> pprUniqueAlways u
+ AsmStyle -> tempLabelPrefixOrUnderscore <> pprUniqueAlways u
+ CStyle -> tempLabelPrefixOrUnderscore <> text "blk_" <> pprUniqueAlways u
AsmTempLabel u
- -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u
+ -> tempLabelPrefixOrUnderscore <> pprUniqueAlways u
AsmTempDerivedLabel l suf
-> asmTempLabelPrefix platform
@@ -1474,7 +1471,7 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
CStyle -> ppr name <> ppIdFlavor flavor
SRTLabel u
- -> maybe_underscore $ tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u <> pp_cSEP <> text "srt"
+ -> maybe_underscore $ tempLabelPrefixOrUnderscore <> pprUniqueAlways u <> pp_cSEP <> text "srt"
RtsLabel (RtsApFast (NonDetFastString str))
-> maybe_underscore $ ftext str <> text "_fast"
@@ -1514,7 +1511,7 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
-> maybe_underscore $ text "SLOW_CALL_fast_" <> text pat <> text "_ctr"
LargeBitmapLabel u
- -> maybe_underscore $ tempLabelPrefixOrUnderscore platform
+ -> maybe_underscore $ tempLabelPrefixOrUnderscore
<> 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
=====================================
compiler/GHC/CmmToAsm/AArch64/Ppr.hs
=====================================
@@ -50,14 +50,14 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed
vcat (map (pprBasicBlock config top_info) blocks) $$
(if ncgDwarfEnabled config
- then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$
+ then pdoc platform (mkAsmTempEndLabel lbl) <> char ':' else empty) $$
pprSizeDecl platform lbl
Just (CmmStaticsRaw info_lbl _) ->
pprSectionAlign config (Section Text info_lbl) $$
-- pprProcAlignment config $$
(if platformHasSubsectionsViaSymbols platform
- then ppr (mkDeadStripPreventer info_lbl) <> char ':'
+ then pdoc platform (mkDeadStripPreventer info_lbl) <> char ':'
else empty) $$
vcat (map (pprBasicBlock config top_info) blocks) $$
-- above: Even the first block gets a label, because with branch-chain
@@ -65,9 +65,9 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
(if platformHasSubsectionsViaSymbols platform
then -- See Note [Subsections Via Symbols]
text "\t.long "
- <+> ppr info_lbl
+ <+> pdoc platform info_lbl
<+> char '-'
- <+> ppr (mkDeadStripPreventer info_lbl)
+ <+> pdoc platform (mkDeadStripPreventer info_lbl)
else empty) $$
pprSizeDecl platform info_lbl
@@ -87,9 +87,6 @@ pprAlignForSection _platform _seg
-- .balign is stable, whereas .align is platform dependent.
= text "\t.balign 8" -- always 8
-instance Outputable Instr where
- ppr = pprInstr genericPlatform
-
-- | Print section header and appropriate alignment for that section.
--
-- This one will emit the header:
@@ -118,7 +115,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
pprLabel platform asmLbl $$
vcat (map (pprInstr platform) (id {-detectTrivialDeadlock-} optInstrs)) $$
(if ncgDwarfEnabled config
- then ppr (mkAsmTempEndLabel asmLbl) <> char ':'
+ then pdoc platform (mkAsmTempEndLabel asmLbl) <> char ':'
else empty
)
where
@@ -138,7 +135,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
pprLabel platform info_lbl $$
c $$
(if ncgDwarfEnabled config
- then ppr (mkAsmTempEndLabel info_lbl) <> char ':'
+ then pdoc platform (mkAsmTempEndLabel info_lbl) <> char ':'
else empty)
-- Make sure the info table has the right .loc for the block
-- coming right after it. See Note [Info Offset]
@@ -235,7 +232,7 @@ pprImm _ (ImmInt i) = int i
pprImm _ (ImmInteger i) = integer i
pprImm p (ImmCLbl l) = pdoc p l
pprImm p (ImmIndex l i) = pdoc p l <> char '+' <> int i
-pprImm _ (ImmLit s) = s
+pprImm _ (ImmLit s) = text s
-- TODO: See pprIm below for why this is a bad idea!
pprImm _ (ImmFloat f)
=====================================
compiler/GHC/CmmToAsm/AArch64/Regs.hs
=====================================
@@ -59,7 +59,7 @@ data Imm
= ImmInt Int
| ImmInteger Integer -- Sigh.
| ImmCLbl CLabel -- AbstractC Label (with baggage)
- | ImmLit SDoc -- Simple string
+ | ImmLit String
| ImmIndex CLabel Int
| ImmFloat Rational
| ImmDouble Rational
@@ -67,14 +67,8 @@ data Imm
| ImmConstantDiff Imm Imm
deriving (Eq, Show)
-instance Show SDoc where
- show = showPprUnsafe . ppr
-
-instance Eq SDoc where
- lhs == rhs = show lhs == show rhs
-
strImmLit :: String -> Imm
-strImmLit s = ImmLit (text s)
+strImmLit s = ImmLit s
litToImm :: CmmLit -> Imm
=====================================
compiler/GHC/CmmToAsm/PPC/CodeGen.hs
=====================================
@@ -407,7 +407,7 @@ getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' _ platform (CmmReg (CmmGlobal PicBaseReg))
| OSAIX <- platformOS platform = do
let code dst = toOL [ LD II32 dst tocAddr ]
- tocAddr = AddrRegImm toc (ImmLit (text "ghc_toc_table[TC]"))
+ tocAddr = AddrRegImm toc (ImmLit "ghc_toc_table[TC]")
return (Any II32 code)
| target32Bit platform = do
reg <- getPicBaseNat $ archWordFormat (target32Bit platform)
=====================================
compiler/GHC/CmmToAsm/PPC/Ppr.hs
=====================================
@@ -240,7 +240,7 @@ pprImm platform = \case
ImmInteger i -> integer i
ImmCLbl l -> pdoc platform l
ImmIndex l i -> pdoc platform l <> char '+' <> int i
- ImmLit s -> s
+ ImmLit s -> text s
ImmFloat f -> float $ fromRational f
ImmDouble d -> double $ fromRational d
ImmConstantSum a b -> pprImm platform a <> char '+' <> pprImm platform b
=====================================
compiler/GHC/CmmToAsm/PPC/Regs.hs
=====================================
@@ -133,7 +133,7 @@ data Imm
= ImmInt Int
| ImmInteger Integer -- Sigh.
| ImmCLbl CLabel -- AbstractC Label (with baggage)
- | ImmLit SDoc -- Simple string
+ | ImmLit String
| ImmIndex CLabel Int
| ImmFloat Rational
| ImmDouble Rational
@@ -147,7 +147,7 @@ data Imm
strImmLit :: String -> Imm
-strImmLit s = ImmLit (text s)
+strImmLit s = ImmLit s
litToImm :: CmmLit -> Imm
=====================================
compiler/GHC/CmmToAsm/X86/Ppr.hs
=====================================
@@ -432,7 +432,7 @@ pprImm platform = \case
ImmInteger i -> integer i
ImmCLbl l -> pdoc platform l
ImmIndex l i -> pdoc platform l <> char '+' <> int i
- ImmLit s -> s
+ ImmLit s -> text s
ImmFloat f -> float $ fromRational f
ImmDouble d -> double $ fromRational d
ImmConstantSum a b -> pprImm platform a <> char '+' <> pprImm platform b
=====================================
compiler/GHC/CmmToAsm/X86/Regs.hs
=====================================
@@ -55,7 +55,6 @@ import GHC.Platform.Reg.Class
import GHC.Cmm
import GHC.Cmm.CLabel ( CLabel )
-import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Platform
@@ -111,7 +110,7 @@ data Imm
= ImmInt Int
| ImmInteger Integer -- Sigh.
| ImmCLbl CLabel -- AbstractC Label (with baggage)
- | ImmLit SDoc -- Simple string
+ | ImmLit String
| ImmIndex CLabel Int
| ImmFloat Rational
| ImmDouble Rational
@@ -119,7 +118,7 @@ data Imm
| ImmConstantDiff Imm Imm
strImmLit :: String -> Imm
-strImmLit s = ImmLit (text s)
+strImmLit s = ImmLit s
litToImm :: CmmLit -> Imm
=====================================
compiler/GHC/StgToCmm/Ticky.hs
=====================================
@@ -363,7 +363,7 @@ emitTickyCounter cloType tickee
Just (CgIdInfo { cg_lf = cg_lf })
| isLFThunk cg_lf
-> return $! CmmLabel $ mkClosureInfoTableLabel (profilePlatform profile) tickee cg_lf
- _ -> pprTraceDebug "tickyThunkUnknown" (text t <> colon <> ppr name <+> ppr (mkInfoTableLabel name NoCafRefs))
+ _ -> pprTraceDebug "tickyThunkUnknown" (text t <> colon <> ppr name <+> pdoc (profilePlatform profile) (mkInfoTableLabel name NoCafRefs))
return $! zeroCLit platform
TickyLNE {} -> return $! zeroCLit platform
=====================================
compiler/GHC/Types/Name/Occurrence.hs
=====================================
@@ -6,7 +6,6 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE LambdaCase #-}
-- |
-- #name_types#
@@ -282,24 +281,9 @@ pprOccName (OccName sp occ)
= getPprStyle $ \ sty ->
if codeStyle sty
then ztext (zEncodeFS occ)
- else pp_occ <> whenPprDebug (braces (pprNameSpaceBrief sp))
- where
- pp_occ = sdocOption sdocSuppressUniques $ \case
- True -> text (strip_th_unique (unpackFS occ))
- False -> ftext occ
-
- -- See Note [Suppressing uniques in OccNames]
- strip_th_unique ('[' : c : _) | isAlphaNum c = []
- strip_th_unique (c : cs) = c : strip_th_unique cs
- strip_th_unique [] = []
+ else ftext occ <> whenPprDebug (braces (pprNameSpaceBrief sp))
{-
-Note [Suppressing uniques in OccNames]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-This is a hack to de-wobblify the OccNames that contain uniques from
-Template Haskell that have been turned into a string in the OccName.
-See Note [Unique OccNames from Template Haskell] in "GHC.ThToHs"
-
************************************************************************
* *
\subsection{Construction}
=====================================
compiler/GHC/Unit/Types.hs
=====================================
@@ -207,7 +207,7 @@ pprModule mod@(Module p n) = getPprStyle doc
| qualModule sty mod =
case p of
HoleUnit -> angleBrackets (pprModuleName n)
- _ -> ppr (moduleUnit mod) <> char ':' <> pprModuleName n
+ _ -> ppr p <> char ':' <> pprModuleName n
| otherwise =
pprModuleName n
=====================================
testsuite/tests/linters/notes.stdout
=====================================
@@ -44,7 +44,6 @@ ref compiler/GHC/Tc/Types.hs:702:33: Note [Extra dependencies from .hs-bo
ref compiler/GHC/Tc/Types.hs:1433:47: Note [Care with plugin imports]
ref compiler/GHC/Tc/Types/Constraint.hs:253:34: Note [NonCanonical Semantics]
ref compiler/GHC/Types/Demand.hs:308:25: Note [Preserving Boxity of results is rarely a win]
-ref compiler/GHC/Types/Name/Occurrence.hs:301:4: Note [Unique OccNames from Template Haskell]
ref compiler/GHC/Unit/Module/Deps.hs:82:13: Note [Structure of dep_boot_mods]
ref compiler/GHC/Utils/Monad.hs:391:34: Note [multiShotIO]
ref compiler/Language/Haskell/Syntax/Binds.hs:204:31: Note [fun_id in Match]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e9dfd26a38182e9c284b7db16cb10fc889eedf9e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e9dfd26a38182e9c284b7db16cb10fc889eedf9e
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220809/df6bc2f1/attachment-0001.html>
More information about the ghc-commits
mailing list