diff options
| -rw-r--r-- | compiler/GHC/Cmm/CLabel.hs | 31 | ||||
| -rw-r--r-- | compiler/GHC/CmmToAsm/Ppr.hs | 71 | ||||
| -rw-r--r-- | compiler/GHC/Utils/Outputable.hs | 78 | ||||
| -rw-r--r-- | compiler/GHC/Utils/Ppr.hs | 14 |
4 files changed, 136 insertions, 58 deletions
diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs index e2f7ce82bc..4d6c66066c 100644 --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -8,7 +8,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} @@ -1304,24 +1303,34 @@ the fact that it was derived from a block ID in `IdLabelInfo` as The info table label and the local block label are both local labels and are not externally visible. + +Note [Bangs in CLabel] +~~~~~~~~~~~~~~~~~~~~~~ +There are some carefully placed strictness annotations in this module, +which were discovered in !5226 to significantly reduce compile-time +allocation. Take care if you want to remove them! + -} instance OutputableP Platform CLabel where - pdoc platform lbl = getPprStyle $ \case - PprCode CStyle -> pprCLabel platform CStyle lbl - PprCode AsmStyle -> pprCLabel platform AsmStyle lbl - _ -> pprCLabel platform CStyle lbl - -- default to CStyle + {-# INLINE pdoc #-} -- see Note [Bangs in CLabel] + pdoc !platform lbl = getPprStyle $ \pp_sty -> + let !sty = case pp_sty of + PprCode sty -> sty + _ -> CStyle + in pprCLabel platform sty lbl pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc -pprCLabel platform sty lbl = +pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel] let + !use_leading_underscores = platformLeadingUnderscore platform + -- some platform (e.g. Darwin) require a leading "_" for exported asm -- symbols maybe_underscore :: SDoc -> SDoc maybe_underscore doc = case sty of - AsmStyle | platformLeadingUnderscore platform -> pp_cSEP <> doc - _ -> doc + AsmStyle | use_leading_underscores -> pp_cSEP <> doc + _ -> doc tempLabelPrefixOrUnderscore :: Platform -> SDoc tempLabelPrefixOrUnderscore platform = case sty of @@ -1520,13 +1529,13 @@ instance Outputable ForeignLabelSource where -- Machine-dependent knowledge about labels. asmTempLabelPrefix :: Platform -> PtrString -- for formatting labels -asmTempLabelPrefix platform = case platformOS platform of +asmTempLabelPrefix !platform = case platformOS platform of OSDarwin -> sLit "L" OSAIX -> sLit "__L" -- follow IBM XL C's convention _ -> sLit ".L" pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> SDoc -> SDoc -pprDynamicLinkerAsmLabel platform dllInfo ppLbl = +pprDynamicLinkerAsmLabel !platform dllInfo ppLbl = case platformOS platform of OSDarwin | platformArch platform == ArchX86_64 -> diff --git a/compiler/GHC/CmmToAsm/Ppr.hs b/compiler/GHC/CmmToAsm/Ppr.hs index dd656a9906..a2382705ae 100644 --- a/compiler/GHC/CmmToAsm/Ppr.hs +++ b/compiler/GHC/CmmToAsm/Ppr.hs @@ -25,7 +25,8 @@ import GHC.Cmm.CLabel import GHC.Cmm import GHC.CmmToAsm.Config import GHC.Data.FastString -import GHC.Utils.Outputable +import GHC.Utils.Outputable as SDoc +import qualified GHC.Utils.Ppr as Pretty import GHC.Utils.Panic import GHC.Platform @@ -94,28 +95,34 @@ pprASCII str -- the literal SDoc directly. -- See #14741 -- and Note [Pretty print ASCII when AsmCodeGen] - = text $ BS.foldr (\w s -> do1 w ++ s) "" str + -- + -- We work with a `Doc` instead of an `SDoc` because there is no need to carry + -- an `SDocContext` that we don't use. It leads to nicer (STG) code. + = docToSDoc (BS.foldr f Pretty.empty str) where - do1 :: Word8 -> String - do1 w | 0x09 == w = "\\t" - | 0x0A == w = "\\n" - | 0x22 == w = "\\\"" - | 0x5C == w = "\\\\" + f :: Word8 -> Pretty.Doc -> Pretty.Doc + f w s = do1 w Pretty.<> s + + do1 :: Word8 -> Pretty.Doc + do1 w | 0x09 == w = Pretty.text "\\t" + | 0x0A == w = Pretty.text "\\n" + | 0x22 == w = Pretty.text "\\\"" + | 0x5C == w = Pretty.text "\\\\" -- ASCII printable characters range - | w >= 0x20 && w <= 0x7E = [chr' w] - | otherwise = '\\' : octal w + | w >= 0x20 && w <= 0x7E = Pretty.char (chr' w) + | otherwise = Pretty.sizedText 4 xs + where + !xs = [ '\\', x0, x1, x2] -- octal + !x0 = chr' (ord0 + (w `unsafeShiftR` 6) .&. 0x07) + !x1 = chr' (ord0 + (w `unsafeShiftR` 3) .&. 0x07) + !x2 = chr' (ord0 + w .&. 0x07) + !ord0 = 0x30 -- = ord '0' -- we know that the Chars we create are in the ASCII range -- so we bypass the check in "chr" chr' :: Word8 -> Char chr' (W8# w#) = C# (chr# (word2Int# (word8ToWord# w#))) - octal :: Word8 -> String - octal w = [ chr' (ord0 + (w `unsafeShiftR` 6) .&. 0x07) - , chr' (ord0 + (w `unsafeShiftR` 3) .&. 0x07) - , chr' (ord0 + w .&. 0x07) - ] - ord0 = 0x30 -- = ord '0' -- | Emit a ".string" directive pprString :: ByteString -> SDoc @@ -191,37 +198,39 @@ pprSectionHeader config (Section t suffix) = case platformOS (ncgPlatform config) of OSAIX -> pprXcoffSectionHeader t OSDarwin -> pprDarwinSectionHeader t - OSMinGW32 -> pprGNUSectionHeader config (char '$') t suffix - _ -> pprGNUSectionHeader config (char '.') t suffix + _ -> pprGNUSectionHeader config t suffix -pprGNUSectionHeader :: NCGConfig -> SDoc -> SectionType -> CLabel -> SDoc -pprGNUSectionHeader config sep t suffix = - text ".section " <> ptext header <> subsection <> flags +pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> SDoc +pprGNUSectionHeader config t suffix = + hcat [text ".section ", header, subsection, flags] where + sep + | OSMinGW32 <- platformOS platform = char '$' + | otherwise = char '.' platform = ncgPlatform config splitSections = ncgSplitSections config subsection | splitSections = sep <> pdoc platform suffix | otherwise = empty header = case t of - Text -> sLit ".text" - Data -> sLit ".data" + Text -> text ".text" + Data -> text ".data" ReadOnlyData | OSMinGW32 <- platformOS platform - -> sLit ".rdata" - | otherwise -> sLit ".rodata" + -> text ".rdata" + | otherwise -> text ".rodata" RelocatableReadOnlyData | OSMinGW32 <- platformOS platform -- Concept does not exist on Windows, -- So map these to R/O data. - -> sLit ".rdata$rel.ro" - | otherwise -> sLit ".data.rel.ro" - UninitialisedData -> sLit ".bss" + -> text ".rdata$rel.ro" + | otherwise -> text ".data.rel.ro" + UninitialisedData -> text ".bss" ReadOnlyData16 | OSMinGW32 <- platformOS platform - -> sLit ".rdata$cst16" - | otherwise -> sLit ".rodata.cst16" + -> text ".rdata$cst16" + | otherwise -> text ".rodata.cst16" CString | OSMinGW32 <- platformOS platform - -> sLit ".rdata" - | otherwise -> sLit ".rodata.str" + -> text ".rdata" + | otherwise -> text ".rodata.str" OtherSection _ -> panic "PprBase.pprGNUSectionHeader: unknown section type" flags = case t of diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index 5fe2d20d6b..6f04ba9ad4 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -159,7 +159,7 @@ data PprStyle -- Does not assume tidied code: non-external names -- are printed with uniques. - | PprCode LabelStyle -- ^ Print code; either C or assembler + | PprCode !LabelStyle -- ^ Print code; either C or assembler -- | Style of label pretty-printing. -- @@ -443,6 +443,7 @@ defaultSDocContext = SDC } withPprStyle :: PprStyle -> SDoc -> SDoc +{-# INLINE CONLIKE withPprStyle #-} withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty} pprDeeper :: SDoc -> SDoc @@ -485,15 +486,19 @@ pprSetDepth depth doc = SDoc $ \ctx -> runSDoc doc ctx getPprStyle :: (PprStyle -> SDoc) -> SDoc +{-# INLINE CONLIKE getPprStyle #-} getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx sdocWithContext :: (SDocContext -> SDoc) -> SDoc +{-# INLINE CONLIKE sdocWithContext #-} sdocWithContext f = SDoc $ \ctx -> runSDoc (f ctx) ctx sdocOption :: (SDocContext -> a) -> (a -> SDoc) -> SDoc +{-# INLINE CONLIKE sdocOption #-} sdocOption f g = sdocWithContext (g . f) updSDocContext :: (SDocContext -> SDocContext) -> SDoc -> SDoc +{-# INLINE CONLIKE updSDocContext #-} updSDocContext upd doc = SDoc $ \ctx -> runSDoc doc (upd ctx) @@ -535,14 +540,17 @@ userStyle _other = False -- | Indicate if -dppr-debug mode is enabled getPprDebug :: (Bool -> SDoc) -> SDoc +{-# INLINE CONLIKE getPprDebug #-} getPprDebug d = sdocWithContext $ \ctx -> d (sdocPprDebug ctx) -- | Says what to do with and without -dppr-debug ifPprDebug :: SDoc -> SDoc -> SDoc +{-# INLINE CONLIKE ifPprDebug #-} ifPprDebug yes no = getPprDebug $ \dbg -> if dbg then yes else no -- | Says what to do with -dppr-debug; without, return empty whenPprDebug :: SDoc -> SDoc -- Empty for non-debug style +{-# INLINE CONLIKE whenPprDebug #-} whenPprDebug d = ifPprDebug d empty -- | The analog of 'Pretty.printDoc_' for 'SDoc', which tries to make sure the @@ -569,6 +577,7 @@ bufLeftRenderSDoc ctx bufHandle doc = Pretty.bufLeftRender bufHandle (runSDoc doc ctx) pprCode :: LabelStyle -> SDoc -> SDoc +{-# INLINE CONLIKE pprCode #-} pprCode cs d = withPprStyle (PprCode cs) d renderWithContext :: SDocContext -> SDoc -> String @@ -606,21 +615,32 @@ float :: Float -> SDoc double :: Double -> SDoc rational :: Rational -> SDoc +{-# INLINE CONLIKE empty #-} empty = docToSDoc $ Pretty.empty +{-# INLINE CONLIKE char #-} char c = docToSDoc $ Pretty.char c +{-# INLINE CONLIKE text #-} -- Inline so that the RULE Pretty.text will fire text s = docToSDoc $ Pretty.text s -{-# INLINE text #-} -- Inline so that the RULE Pretty.text will fire +{-# INLINE CONLIKE ftext #-} ftext s = docToSDoc $ Pretty.ftext s +{-# INLINE CONLIKE ptext #-} ptext s = docToSDoc $ Pretty.ptext s +{-# INLINE CONLIKE ztext #-} ztext s = docToSDoc $ Pretty.ztext s +{-# INLINE CONLIKE int #-} int n = docToSDoc $ Pretty.int n +{-# INLINE CONLIKE integer #-} integer n = docToSDoc $ Pretty.integer n +{-# INLINE CONLIKE float #-} float n = docToSDoc $ Pretty.float n +{-# INLINE CONLIKE double #-} double n = docToSDoc $ Pretty.double n +{-# INLINE CONLIKE rational #-} rational n = docToSDoc $ Pretty.rational n -- See Note [Print Hexadecimal Literals] in GHC.Utils.Ppr +{-# INLINE CONLIKE word #-} word n = sdocOption sdocHexWordLiterals $ \case True -> docToSDoc $ Pretty.hex n False -> docToSDoc $ Pretty.integer n @@ -633,14 +653,21 @@ doublePrec p n = text (showFFloat (Just p) n "") parens, braces, brackets, quotes, quote, doubleQuotes, angleBrackets :: SDoc -> SDoc +{-# INLINE CONLIKE parens #-} parens d = SDoc $ Pretty.parens . runSDoc d +{-# INLINE CONLIKE braces #-} braces d = SDoc $ Pretty.braces . runSDoc d +{-# INLINE CONLIKE brackets #-} brackets d = SDoc $ Pretty.brackets . runSDoc d +{-# INLINE CONLIKE quote #-} quote d = SDoc $ Pretty.quote . runSDoc d +{-# INLINE CONLIKE doubleQuotes #-} doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d +{-# INLINE CONLIKE angleBrackets #-} angleBrackets d = char '<' <> d <> char '>' cparen :: Bool -> SDoc -> SDoc +{-# INLINE CONLIKE cparen #-} cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d -- 'quotes' encloses something in single quotes... @@ -661,7 +688,7 @@ semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, lambda :: SDoc lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc -blankLine = docToSDoc $ Pretty.text "" +blankLine = docToSDoc Pretty.emptyText dcolon = unicodeSyntax (char '∷') (docToSDoc $ Pretty.text "::") arrow = unicodeSyntax (char '→') (docToSDoc $ Pretty.text "->") lollipop = unicodeSyntax (char '⊸') (docToSDoc $ Pretty.text "%1 ->") @@ -722,11 +749,16 @@ nest :: Int -> SDoc -> SDoc ($+$) :: SDoc -> SDoc -> SDoc -- ^ Join two 'SDoc' together vertically +{-# INLINE CONLIKE nest #-} nest n d = SDoc $ Pretty.nest n . runSDoc d -(<>) d1 d2 = SDoc $ \sty -> (Pretty.<>) (runSDoc d1 sty) (runSDoc d2 sty) -(<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty) -($$) d1 d2 = SDoc $ \sty -> (Pretty.$$) (runSDoc d1 sty) (runSDoc d2 sty) -($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty) +{-# INLINE CONLIKE (<>) #-} +(<>) d1 d2 = SDoc $ \ctx -> (Pretty.<>) (runSDoc d1 ctx) (runSDoc d2 ctx) +{-# INLINE CONLIKE (<+>) #-} +(<+>) d1 d2 = SDoc $ \ctx -> (Pretty.<+>) (runSDoc d1 ctx) (runSDoc d2 ctx) +{-# INLINE CONLIKE ($$) #-} +($$) d1 d2 = SDoc $ \ctx -> (Pretty.$$) (runSDoc d1 ctx) (runSDoc d2 ctx) +{-# INLINE CONLIKE ($+$) #-} +($+$) d1 d2 = SDoc $ \ctx -> (Pretty.$+$) (runSDoc d1 ctx) (runSDoc d2 ctx) hcat :: [SDoc] -> SDoc -- ^ Concatenate 'SDoc' horizontally @@ -745,25 +777,37 @@ fcat :: [SDoc] -> SDoc -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>' -hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds] -hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds] -vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds] -sep ds = SDoc $ \sty -> Pretty.sep [runSDoc d sty | d <- ds] -cat ds = SDoc $ \sty -> Pretty.cat [runSDoc d sty | d <- ds] -fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds] -fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds] +-- Inline all those wrappers to help ensure we create lists of Doc, not of SDoc +-- later applied to the same SDocContext. It helps the worker/wrapper +-- transformation extracting only the required fields from the SDocContext. +{-# INLINE CONLIKE hcat #-} +hcat ds = SDoc $ \ctx -> Pretty.hcat [runSDoc d ctx | d <- ds] +{-# INLINE CONLIKE hsep #-} +hsep ds = SDoc $ \ctx -> Pretty.hsep [runSDoc d ctx | d <- ds] +{-# INLINE CONLIKE vcat #-} +vcat ds = SDoc $ \ctx -> Pretty.vcat [runSDoc d ctx | d <- ds] +{-# INLINE CONLIKE sep #-} +sep ds = SDoc $ \ctx -> Pretty.sep [runSDoc d ctx | d <- ds] +{-# INLINE CONLIKE cat #-} +cat ds = SDoc $ \ctx -> Pretty.cat [runSDoc d ctx | d <- ds] +{-# INLINE CONLIKE fsep #-} +fsep ds = SDoc $ \ctx -> Pretty.fsep [runSDoc d ctx | d <- ds] +{-# INLINE CONLIKE fcat #-} +fcat ds = SDoc $ \ctx -> Pretty.fcat [runSDoc d ctx | d <- ds] hang :: SDoc -- ^ The header -> Int -- ^ Amount to indent the hung body -> SDoc -- ^ The hung body, indented and placed below the header -> SDoc +{-# INLINE CONLIKE hang #-} hang d1 n d2 = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty) -- | This behaves like 'hang', but does not indent the second document -- when the header is empty. hangNotEmpty :: SDoc -> Int -> SDoc -> SDoc +{-# INLINE CONLIKE hangNotEmpty #-} hangNotEmpty d1 n d2 = - SDoc $ \sty -> Pretty.hangNotEmpty (runSDoc d1 sty) n (runSDoc d2 sty) + SDoc $ \ctx -> Pretty.hangNotEmpty (runSDoc d1 ctx) n (runSDoc d2 ctx) punctuate :: SDoc -- ^ The punctuation -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements @@ -775,17 +819,21 @@ punctuate p (d:ds) = go d ds go d (e:es) = (d <> p) : go e es ppWhen, ppUnless :: Bool -> SDoc -> SDoc +{-# INLINE CONLIKE ppWhen #-} ppWhen True doc = doc ppWhen False _ = empty +{-# INLINE CONLIKE ppUnless #-} ppUnless True _ = empty ppUnless False doc = doc +{-# INLINE CONLIKE ppWhenOption #-} ppWhenOption :: (SDocContext -> Bool) -> SDoc -> SDoc ppWhenOption f doc = sdocOption f $ \case True -> doc False -> empty +{-# INLINE CONLIKE ppUnlessOption #-} ppUnlessOption :: (SDocContext -> Bool) -> SDoc -> SDoc ppUnlessOption f doc = sdocOption f $ \case True -> empty diff --git a/compiler/GHC/Utils/Ppr.hs b/compiler/GHC/Utils/Ppr.hs index 8871f98cef..e64c6e61f1 100644 --- a/compiler/GHC/Utils/Ppr.hs +++ b/compiler/GHC/Utils/Ppr.hs @@ -71,7 +71,7 @@ module GHC.Utils.Ppr ( -- * Constructing documents -- ** Converting values into documents - char, text, ftext, ptext, ztext, sizedText, zeroWidthText, + char, text, ftext, ptext, ztext, sizedText, zeroWidthText, emptyText, int, integer, float, double, rational, hex, -- ** Simple derived documents @@ -309,6 +309,12 @@ text s = textBeside_ (Str s) (length s) Empty forall p n. text (unpackNBytes# p n) = ptext (PtrString (Ptr p) (I# n)) #-} +-- Empty strings are desugared into [] (not "unpackCString#..."), hence they are +-- not matched by the text/str rule above. +{-# RULES "text/[]" + text [] = emptyText + #-} + ftext :: FastString -> Doc ftext s = textBeside_ (PStr s) (lengthFS s) Empty @@ -327,6 +333,12 @@ sizedText l s = textBeside_ (Str s) l Empty zeroWidthText :: String -> Doc zeroWidthText = sizedText 0 +-- | Empty text (one line high but no width). (@emptyText = text ""@) +emptyText :: Doc +emptyText = sizedText 0 [] + -- defined as a CAF. Sharing occurs especially via the text/[] rule above. + -- Every use of `text ""` in user code should be replaced with this. + -- | 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. |