diff options
Diffstat (limited to 'compiler/utils/Pretty.hs')
| -rw-r--r-- | compiler/utils/Pretty.hs | 150 |
1 files changed, 104 insertions, 46 deletions
diff --git a/compiler/utils/Pretty.hs b/compiler/utils/Pretty.hs index a4d67f03a0..1a8bc23205 100644 --- a/compiler/utils/Pretty.hs +++ b/compiler/utils/Pretty.hs @@ -72,7 +72,7 @@ module Pretty ( -- ** Converting values into documents char, text, ftext, ptext, ztext, sizedText, zeroWidthText, - int, integer, float, double, rational, + int, integer, float, double, rational, hex, -- ** Simple derived documents semi, comma, colon, space, equals, @@ -103,7 +103,7 @@ module Pretty ( Mode(..), -- ** General rendering - fullRender, + fullRender, txtPrinter, -- ** GHC-specific rendering printDoc, printDoc_, @@ -111,14 +111,16 @@ module Pretty ( ) where +import GhcPrelude hiding (error) + import BufWrite import FastString import Panic import System.IO -import Prelude hiding (error) +import Numeric (showHex) --for a RULES -import GHC.Base ( unpackCString# ) +import GHC.Base ( unpackCString#, unpackNBytes#, Int(..) ) import GHC.Ptr ( Ptr(..) ) -- Don't import Util( assertPanic ) because it makes a loop in the module structure @@ -268,8 +270,10 @@ data TextDetails = Chr {-# UNPACK #-} !Char -- ^ A single Char fragment | Str String -- ^ A whole String fragment | PStr FastString -- a hashed string | ZStr FastZString -- a z-encoded string - | LStr {-# UNPACK #-} !LitString {-#UNPACK #-} !Int + | LStr {-# UNPACK #-} !LitString -- a '\0'-terminated array of bytes + | RStr {-# UNPACK #-} !Int {-# UNPACK #-} !Char + -- a repeated character (e.g., ' ') instance Show Doc where showsPrec _ doc cont = fullRender (mode style) (lineLength style) @@ -294,25 +298,28 @@ char c = textBeside_ (Chr c) 1 Empty -- The side condition on the last law is necessary because @'text' \"\"@ -- has height 1, while 'empty' has no height. text :: String -> Doc -text s = case length s of {sl -> textBeside_ (Str s) sl Empty} +text s = textBeside_ (Str s) (length s) Empty {-# NOINLINE [0] text #-} -- Give the RULE a chance to fire -- It must wait till after phase 1 when -- the unpackCString first is manifested -- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the -- intermediate packing/unpacking of the string. -{-# RULES - "text/str" forall a. text (unpackCString# a) = ptext (Ptr a) - #-} +{-# RULES "text/str" + forall a. text (unpackCString# a) = ptext (mkLitString# a) + #-} +{-# RULES "text/unpackNBytes#" + forall p n. text (unpackNBytes# p n) = ptext (LitString (Ptr p) (I# n)) + #-} ftext :: FastString -> Doc -ftext s = case lengthFS s of {sl -> textBeside_ (PStr s) sl Empty} +ftext s = textBeside_ (PStr s) (lengthFS s) Empty ptext :: LitString -> Doc -ptext s = case lengthLS s of {sl -> textBeside_ (LStr s sl) sl Empty} +ptext s = textBeside_ (LStr s) (lengthLS s) Empty ztext :: FastZString -> Doc -ztext s = case lengthFZS s of {sl -> textBeside_ (ZStr s) sl Empty} +ztext s = textBeside_ (ZStr s) (lengthFZS s) Empty -- | Some text with any width. (@text s = sizedText (length s) s@) sizedText :: Int -> String -> Doc @@ -334,12 +341,6 @@ isEmpty :: Doc -> Bool isEmpty Empty = True isEmpty _ = False --- | Produce spacing for indenting the amount specified. --- --- an old version inserted tabs being 8 columns apart in the output. -spaces :: Int -> String -spaces !n = replicate n ' ' - {- Q: What is the reason for negative indentation (i.e. argument to indent is < 0) ? @@ -403,11 +404,18 @@ integer :: Integer -> Doc -- ^ @integer n = text (show n)@ float :: Float -> Doc -- ^ @float n = text (show n)@ double :: Double -> Doc -- ^ @double n = text (show n)@ rational :: Rational -> Doc -- ^ @rational n = text (show n)@ +hex :: Integer -> Doc -- ^ See Note [Print Hexadecimal Literals] int n = text (show n) integer n = text (show n) float n = text (show n) double n = text (show n) rational n = text (show n) +hex n = text ('0' : 'x' : padded) + where + str = showHex n "" + strLen = max 1 (length str) + len = 2 ^ (ceiling (logBase 2 (fromIntegral strLen :: Double)) :: Int) + padded = replicate (len - strLen) '0' ++ str parens :: Doc -> Doc -- ^ Wrap document in @(...)@ brackets :: Doc -> Doc -- ^ Wrap document in @[...]@ @@ -422,6 +430,57 @@ parens p = char '(' <> p <> char ')' brackets p = char '[' <> p <> char ']' braces p = char '{' <> p <> char '}' +{- +Note [Print Hexadecimal Literals] + +Relevant discussions: + * Phabricator: https://phabricator.haskell.org/D4465 + * GHC Trac: https://ghc.haskell.org/trac/ghc/ticket/14872 + +There is a flag `-dword-hex-literals` that causes literals of +type `Word#` or `Word64#` to be displayed in hexadecimal instead +of decimal when dumping GHC core. It also affects the presentation +of these in GHC's error messages. Additionally, the hexadecimal +encoding of these numbers is zero-padded so that its length is +a power of two. As an example of what this does, +consider the following haskell file `Literals.hs`: + + module Literals where + + alpha :: Int + alpha = 100 + 200 + + beta :: Word -> Word + beta x = x + div maxBound 255 + div 0xFFFFFFFF 255 + 0x0202 + +We get the following dumped core when we compile on a 64-bit +machine with ghc -O2 -fforce-recomp -ddump-simpl -dsuppress-all +-dhex-word-literals literals.hs: + + ==================== Tidy Core ==================== + + ... omitted for brevity ... + + -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} + alpha + alpha = I# 300# + + -- RHS size: {terms: 12, types: 3, coercions: 0, joins: 0/0} + beta + beta + = \ x_aYE -> + case x_aYE of { W# x#_a1v0 -> + W# + (plusWord# + (plusWord# (plusWord# x#_a1v0 0x0101010101010101##) 0x01010101##) + 0x0202##) + } + +Notice that the word literals are in hexadecimals and that they have +been padded with zeroes so that their lengths are 16, 8, and 4, respectively. + +-} + -- | Apply 'parens' to 'Doc' if boolean is true. maybeParens :: Bool -> Doc -> Doc maybeParens False = id @@ -432,8 +491,8 @@ maybeParens True = parens -- | Perform some simplification of a built up @GDoc@. reduceDoc :: Doc -> RDoc -reduceDoc (Beside p g q) = beside p g (reduceDoc q) -reduceDoc (Above p g q) = above p g (reduceDoc q) +reduceDoc (Beside p g q) = p `seq` g `seq` (beside p g $! reduceDoc q) +reduceDoc (Above p g q) = p `seq` g `seq` (above p g $! reduceDoc q) reduceDoc p = p -- | List version of '<>'. @@ -595,7 +654,7 @@ nilAboveNest _ _ Empty = Empty -- Here's why the "text s <>" is in the spec! nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q nilAboveNest g k q | not g && k > 0 -- No newline if no overlap - = textBeside_ (Str (spaces k)) k q + = textBeside_ (RStr k ' ') k q | otherwise -- Put them really above = nilAbove_ (mkNest k q) @@ -878,11 +937,12 @@ renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s) -- | Default TextDetails printer txtPrinter :: TextDetails -> String -> String -txtPrinter (Chr c) s = c:s -txtPrinter (Str s1) s2 = s1 ++ s2 -txtPrinter (PStr s1) s2 = unpackFS s1 ++ s2 -txtPrinter (ZStr s1) s2 = zString s1 ++ s2 -txtPrinter (LStr s1 _) s2 = unpackLitString s1 ++ s2 +txtPrinter (Chr c) s = c:s +txtPrinter (Str s1) s2 = s1 ++ s2 +txtPrinter (PStr s1) s2 = unpackFS s1 ++ s2 +txtPrinter (ZStr s1) s2 = zString s1 ++ s2 +txtPrinter (LStr s1) s2 = unpackLitString s1 ++ s2 +txtPrinter (RStr n c) s2 = replicate n c ++ s2 -- | The general rendering interface. fullRender :: Mode -- ^ Rendering mode @@ -968,10 +1028,7 @@ display m !page_width !ribbon_width txt end doc lay2 _ NoDoc = error "display lay2 NoDoc" lay2 _ (Union {}) = error "display lay2 Union" - -- optimise long indentations using LitString chunks of 8 spaces - indent !n r | n >= 8 = LStr (sLit " ") 8 `txt` - indent (n - 8) r - | otherwise = Str (spaces n) `txt` r + indent !n r = RStr n ' ' `txt` r in lay 0 doc }} @@ -990,21 +1047,21 @@ printDoc_ mode pprCols hdl doc = do { fullRender mode pprCols 1.5 put done doc ; hFlush hdl } where - put (Chr c) next = hPutChar hdl c >> next - put (Str s) next = hPutStr hdl s >> next - put (PStr s) next = hPutStr hdl (unpackFS s) >> next - -- NB. not hPutFS, we want this to go through - -- the I/O library's encoding layer. (#3398) - put (ZStr s) next = hPutFZS hdl s >> next - put (LStr s l) next = hPutLitString hdl s l >> next + put (Chr c) next = hPutChar hdl c >> next + put (Str s) next = hPutStr hdl s >> next + put (PStr s) next = hPutStr hdl (unpackFS s) >> next + -- NB. not hPutFS, we want this to go through + -- the I/O library's encoding layer. (#3398) + put (ZStr s) next = hPutFZS hdl s >> next + put (LStr s) next = hPutLitString hdl s >> next + put (RStr n c) next = hPutStr hdl (replicate n c) >> next done = return () -- hPutChar hdl '\n' -- some versions of hPutBuf will barf if the length is zero -hPutLitString :: Handle -> Ptr a -> Int -> IO () -hPutLitString handle a l = if l == 0 - then return () - else hPutBuf handle a l +hPutLitString :: Handle -> LitString -> IO () +hPutLitString _handle (LitString _ 0) = return () +hPutLitString handle (LitString a l) = hPutBuf handle a l -- Printing output in LeftMode is performance critical: it's used when -- dumping C and assembly output, so we allow ourselves a few dirty @@ -1031,18 +1088,19 @@ bufLeftRender b doc = layLeft b (reduceDoc doc) layLeft :: BufHandle -> Doc -> IO () layLeft b _ | b `seq` False = undefined -- make it strict in b layLeft _ NoDoc = error "layLeft: NoDoc" -layLeft b (Union p q) = layLeft b (first p q) -layLeft b (Nest _ p) = layLeft b p +layLeft b (Union p q) = layLeft b $! first p q +layLeft b (Nest _ p) = layLeft b $! p layLeft b Empty = bPutChar b '\n' -layLeft b (NilAbove p) = bPutChar b '\n' >> layLeft b p -layLeft b (TextBeside s _ p) = put b s >> layLeft b p +layLeft b (NilAbove p) = p `seq` (bPutChar b '\n' >> layLeft b p) +layLeft b (TextBeside s _ p) = s `seq` (put b s >> layLeft b p) where put b _ | b `seq` False = undefined put b (Chr c) = bPutChar b c put b (Str s) = bPutStr b s put b (PStr s) = bPutFS b s put b (ZStr s) = bPutFZS b s - put b (LStr s l) = bPutLitString b s l + put b (LStr s) = bPutLitString b s + put b (RStr n c) = bPutReplicate b n c layLeft _ _ = panic "layLeft: Unhandled case" -- Define error=panic, for easier comparison with libraries/pretty. |