[Git][ghc/ghc][wip/ftext-no-length] Add Pretty.zeroWidth{F,P}Text, use it in Cmm Ppr
Sebastian Graf
gitlab at gitlab.haskell.org
Tue Sep 1 09:57:17 UTC 2020
Sebastian Graf pushed to branch wip/ftext-no-length at Glasgow Haskell Compiler / GHC
Commits:
0300613c by Sebastian Graf at 2020-09-01T11:57:07+02:00
Add Pretty.zeroWidth{F,P}Text, use it in Cmm Ppr
This is ultimately so that we can drop the length field of `FastString`.
The Cmm pretty printer doesn't look at the width anyway, so eagerly
computing it is redundant.
There are a multitude of occurrences of `text` in `compiler/GHC/Cmm`,
but they mostly rewrite to `ptext` anyway, where computing the length
isn't particularly expensive, so I refrained from changing these
occurrences to `zeroWidthText` for the time being.
>From the three proposed approaches in
https://gitlab.haskell.org/ghc/ghc/issues/17069#note_259689
this one seemed like the simplest and least intrusive; plus, there is
already precedent with `Pretty.zeroWidthText`.
Fixes #17069.
- - - - -
4 changed files:
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/Cmm/Ppr.hs
- compiler/GHC/Utils/Outputable.hs
- compiler/GHC/Utils/Ppr.hs
Changes:
=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -1248,7 +1248,7 @@ pprCLabel_NCG platform lbl = getPprStyle $ \sty ->
<> case l of AsmTempLabel u -> pprUniqueAlways u
LocalBlockLabel u -> pprUniqueAlways u
_other -> pprCLabel_NCG platform l
- <> ftext suf
+ <> zeroWidthFText suf
DynamicLinkerLabel info lbl
-> pprDynamicLinkerAsmLabel platform info lbl
@@ -1274,7 +1274,7 @@ pprCLabel_NCG platform lbl = getPprStyle $ \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
+ maybe_underscore $ zeroWidthFText fs <> char '@' <> int sz
_ | asmStyle sty -> maybe_underscore $ pprCLabel_common platform lbl
| otherwise -> pprCLabel_common platform lbl
@@ -1302,13 +1302,13 @@ pprCLabel_common platform = \case
-- 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
+ (CmmLabel _ _ str CmmCode) -> zeroWidthFText str
+ (CmmLabel _ _ str CmmData) -> zeroWidthFText str
+ (CmmLabel _ _ str CmmPrimCall) -> zeroWidthFText str
(LocalBlockLabel u) -> tempLabelPrefixOrUnderscore platform <> text "blk_" <> pprUniqueAlways u
- (RtsLabel (RtsApFast str)) -> ftext str <> text "_fast"
+ (RtsLabel (RtsApFast str)) -> zeroWidthFText str <> text "_fast"
(RtsLabel (RtsSelectorInfoTable upd_reqd offset)) ->
hcat [text "stg_sel_", text (show offset),
@@ -1338,17 +1338,17 @@ pprCLabel_common platform = \case
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"
+ (CmmLabel _ _ fs CmmInfo) -> zeroWidthFText fs <> text "_info"
+ (CmmLabel _ _ fs CmmEntry) -> zeroWidthFText fs <> text "_entry"
+ (CmmLabel _ _ fs CmmRetInfo) -> zeroWidthFText fs <> text "_info"
+ (CmmLabel _ _ fs CmmRet) -> zeroWidthFText fs <> text "_ret"
+ (CmmLabel _ _ fs CmmClosure) -> zeroWidthFText 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
+ (ForeignLabel str _ _ _) -> zeroWidthFText str
(IdLabel name _cafs flavor) -> internalNamePrefix platform name <> ppr name <> ppIdFlavor flavor
=====================================
compiler/GHC/Cmm/Ppr.hs
=====================================
@@ -194,7 +194,8 @@ pprNode platform node = pp_node <+> pp_debug
<+> ppUnlessOption sdocSuppressTicks (text "//" <+> ppr tscope)
-- // text
- CmmComment s -> text "//" <+> ftext s
+ -- See Note [zeroWidthFText in Cmm]
+ CmmComment s -> text "//" <+> zeroWidthFText s
-- //tick bla<...>
CmmTick t -> ppUnlessOption sdocSuppressTicks
@@ -308,3 +309,11 @@ pprNode platform node = pp_node <+> pp_debug
commafy :: [SDoc] -> SDoc
commafy xs = hsep $ punctuate comma xs
+
+{- Note [zeroWidthFText in Cmm]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In an effort to remove the length field of 'FastString' (!1675), we decided to
+use 'zeroWidthFText' when pretty-printing Cmm, even though the involved strings
+are not actually of zero width. That works because the Cmm pretty-printer
+assumes an infinite ribbon anyway, so will never insert line breaks itself.
+-}
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -25,6 +25,7 @@ module GHC.Utils.Outputable (
empty, isEmpty, nest,
char,
text, ftext, ptext, ztext,
+ zeroWidthText, zeroWidthFText, zeroWidthPText,
int, intWithCommas, integer, word, float, double, rational, doublePrec,
parens, cparen, brackets, braces, quotes, quote,
doubleQuotes, angleBrackets,
@@ -611,6 +612,14 @@ word n = sdocOption sdocHexWordLiterals $ \case
True -> docToSDoc $ Pretty.hex n
False -> docToSDoc $ Pretty.integer n
+zeroWidthText :: String -> SDoc
+zeroWidthFText :: FastString -> SDoc
+zeroWidthPText :: PtrString -> SDoc
+
+zeroWidthText s = docToSDoc $ Pretty.zeroWidthText s
+zeroWidthFText s = docToSDoc $ Pretty.zeroWidthFText s
+zeroWidthPText s = docToSDoc $ Pretty.zeroWidthPText s
+
-- | @doublePrec p n@ shows a floating point number @n@ with @p@
-- digits of precision after the decimal point.
doublePrec :: Int -> Double -> SDoc
=====================================
compiler/GHC/Utils/Ppr.hs
=====================================
@@ -71,7 +71,8 @@ module GHC.Utils.Ppr (
-- * Constructing documents
-- ** Converting values into documents
- char, text, ftext, ptext, ztext, sizedText, zeroWidthText,
+ char, text, ftext, ptext, ztext, sizedText,
+ zeroWidthText, zeroWidthFText, zeroWidthPText,
int, integer, float, double, rational, hex,
-- ** Simple derived documents
@@ -309,12 +310,38 @@ text s = textBeside_ (Str s) (length s) Empty
forall p n. text (unpackNBytes# p n) = ptext (PtrString (Ptr p) (I# n))
#-}
+-- | Some text, but without any width. Use for non-printing text
+-- such as a HTML or Latex tags.
+--
+-- Also useful if you plan to have an infinite ribbon anyway.
+-- Note [zeroWidthFText in Cmm] in "GHC.Cmm.Ppr" describes that use case.
+zeroWidthText :: String -> Doc
+zeroWidthText = sizedText 0
+{-# NOINLINE [0] zeroWidthText #-}
+
+{-# RULES "zeroWidthText/str"
+ forall a. zeroWidthText (unpackCString# a) = zeroWidthPText (mkPtrString# a)
+ #-}
+{-# RULES "zeroWidthText/unpackNBytes#"
+ forall p n. zeroWidthText (unpackNBytes# p n) = zeroWidthPText (PtrString (Ptr p) (I# n))
+ #-}
+
ftext :: FastString -> Doc
ftext s = textBeside_ (PStr s) (lengthFS s) Empty
+-- | Like 'zeroWidthText', but for 'FastString'.
+--
+-- See also Note [zeroWidthFText in Cmm] in "GHC.Cmm.Ppr".
+zeroWidthFText :: FastString -> Doc
+zeroWidthFText s = textBeside_ (PStr s) 0 Empty
+
ptext :: PtrString -> Doc
ptext s = textBeside_ (LStr s) (lengthPS s) Empty
+-- | Like 'zeroWidthText', but for 'PtrString'.
+zeroWidthPText :: PtrString -> Doc
+zeroWidthPText s = textBeside_ (LStr s) 0 Empty
+
ztext :: FastZString -> Doc
ztext s = textBeside_ (ZStr s) (lengthFZS s) Empty
@@ -322,11 +349,6 @@ ztext s = textBeside_ (ZStr s) (lengthFZS s) Empty
sizedText :: Int -> String -> Doc
sizedText l s = textBeside_ (Str s) l Empty
--- | Some text, but without any width. Use for non-printing text
--- such as a HTML or Latex tags
-zeroWidthText :: String -> Doc
-zeroWidthText = sizedText 0
-
-- | The empty document, with no height and no width.
-- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere
-- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0300613c4f361e655c1c6ac7da3cefea3c6089b6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0300613c4f361e655c1c6ac7da3cefea3c6089b6
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/20200901/125406f1/attachment-0001.html>
More information about the ghc-commits
mailing list