[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
Thu Mar 26 22:04:00 UTC 2020
Sebastian Graf pushed to branch wip/ftext-no-length at Glasgow Haskell Compiler / GHC
Commits:
fb415b18 by Sebastian Graf at 2020-03-26T23:03:33+01: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/utils/Outputable.hs
- compiler/utils/Pretty.hs
Changes:
=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -1177,7 +1177,7 @@ pprCLabel dynFlags (AsmTempDerivedLabel l suf)
<> case l of AsmTempLabel u -> pprUniqueAlways u
LocalBlockLabel u -> pprUniqueAlways u
_other -> pprCLabel dynFlags l
- <> ftext suf
+ <> zeroWidthFText suf
pprCLabel dynFlags (DynamicLinkerLabel info lbl)
| platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags
@@ -1220,7 +1220,7 @@ pprAsmCLbl platform (ForeignLabel fs (Just sz) _ _)
| platformOS platform == OSMinGW32
-- In asm mode, we need to put the suffix on a stdcall ForeignLabel.
-- (The C compiler does this itself).
- = ftext fs <> char '@' <> int sz
+ = zeroWidthFText fs <> char '@' <> int sz
pprAsmCLbl _ lbl
= pprCLbl lbl
@@ -1239,14 +1239,14 @@ pprCLbl (LargeBitmapLabel u) =
-- with a letter so the label will be legal assembly code.
-pprCLbl (CmmLabel _ str CmmCode) = ftext str
-pprCLbl (CmmLabel _ str CmmData) = ftext str
-pprCLbl (CmmLabel _ str CmmPrimCall) = ftext str
+pprCLbl (CmmLabel _ str CmmCode) = zeroWidthFText str
+pprCLbl (CmmLabel _ str CmmData) = zeroWidthFText str
+pprCLbl (CmmLabel _ str CmmPrimCall) = zeroWidthFText str
pprCLbl (LocalBlockLabel u) =
tempLabelPrefixOrUnderscore <> text "blk_" <> pprUniqueAlways u
-pprCLbl (RtsLabel (RtsApFast str)) = ftext str <> text "_fast"
+pprCLbl (RtsLabel (RtsApFast str)) = zeroWidthFText str <> text "_fast"
pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset))
= sdocWithDynFlags $ \dflags ->
@@ -1285,19 +1285,19 @@ pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
]
pprCLbl (CmmLabel _ fs CmmInfo)
- = ftext fs <> text "_info"
+ = zeroWidthFText fs <> text "_info"
pprCLbl (CmmLabel _ fs CmmEntry)
- = ftext fs <> text "_entry"
+ = zeroWidthFText fs <> text "_entry"
pprCLbl (CmmLabel _ fs CmmRetInfo)
- = ftext fs <> text "_info"
+ = zeroWidthFText fs <> text "_info"
pprCLbl (CmmLabel _ fs CmmRet)
- = ftext fs <> text "_ret"
+ = zeroWidthFText fs <> text "_ret"
pprCLbl (CmmLabel _ fs CmmClosure)
- = ftext fs <> text "_closure"
+ = zeroWidthFText fs <> text "_closure"
pprCLbl (RtsLabel (RtsPrimOp primop))
= text "stg_" <> ppr primop
@@ -1306,7 +1306,7 @@ pprCLbl (RtsLabel (RtsSlowFastTickyCtr pat))
= text "SLOW_CALL_fast_" <> text pat <> ptext (sLit "_ctr")
pprCLbl (ForeignLabel str _ _ _)
- = ftext str
+ = zeroWidthFText str
pprCLbl (IdLabel name _cafs flavor) =
internalNamePrefix name <> ppr name <> ppIdFlavor flavor
=====================================
compiler/GHC/Cmm/Ppr.hs
=====================================
@@ -195,7 +195,7 @@ pprNode platform node = pp_node <+> pp_debug
<+> ppUnlessOption sdocSuppressTicks (text "//" <+> ppr tscope)
-- // text
- CmmComment s -> text "//" <+> ftext s
+ CmmComment s -> text "//" <+> zeroWidthFText s
-- //tick bla<...>
CmmTick t -> ppUnlessOption sdocSuppressTicks
=====================================
compiler/utils/Outputable.hs
=====================================
@@ -24,6 +24,7 @@ module 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,
@@ -622,6 +623,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/utils/Pretty.hs
=====================================
@@ -71,7 +71,8 @@ module Pretty (
-- * 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,33 @@ 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
+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'.
+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 +344,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/fb415b18baf61b8f7aeec4a01652de6154f08850
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fb415b18baf61b8f7aeec4a01652de6154f08850
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/20200326/049c931c/attachment-0001.html>
More information about the ghc-commits
mailing list