diff options
| -rw-r--r-- | compiler/GHC/Driver/Ppr.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Session.hs | 27 | ||||
| -rw-r--r-- | compiler/GHC/Utils/Error.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/Utils/Outputable.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Utils/Ppr.hs | 50 | ||||
| m--------- | utils/haddock | 0 |
6 files changed, 65 insertions, 19 deletions
diff --git a/compiler/GHC/Driver/Ppr.hs b/compiler/GHC/Driver/Ppr.hs index 9d430f0466..fbaf145fa2 100644 --- a/compiler/GHC/Driver/Ppr.hs +++ b/compiler/GHC/Driver/Ppr.hs @@ -65,7 +65,7 @@ showSDocDebug dflags d = renderWithContext ctx d printForUser :: DynFlags -> Handle -> PrintUnqualified -> Depth -> SDoc -> IO () printForUser dflags handle unqual depth doc - = printSDocLn ctx PageMode handle doc + = printSDocLn ctx (PageMode False) handle doc where ctx = initSDocContext dflags (mkUserStyle unqual depth) -- | Like 'printSDocLn' but specialized with 'LeftMode' and diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index a1075f1cdb..c4b28b1210 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -1344,7 +1344,7 @@ defaultFatalMessager = hPutStrLn stderr jsonLogAction :: LogAction jsonLogAction dflags reason severity srcSpan msg = - defaultLogActionHPutStrDoc dflags stdout + defaultLogActionHPutStrDoc dflags True stdout (withPprStyle (PprCode CStyle) (doc $$ text "")) where str = renderWithContext (initSDocContext dflags defaultUserStyle) msg @@ -1367,9 +1367,9 @@ defaultLogAction dflags reason severity srcSpan msg SevWarning -> printWarns SevError -> printWarns where - printOut = defaultLogActionHPrintDoc dflags stdout - printErrs = defaultLogActionHPrintDoc dflags stderr - putStrSDoc = defaultLogActionHPutStrDoc dflags stdout + printOut = defaultLogActionHPrintDoc dflags False stdout + printErrs = defaultLogActionHPrintDoc dflags False stderr + putStrSDoc = defaultLogActionHPutStrDoc dflags False stdout -- Pretty print the warning flag, if any (#10752) message = mkLocMessageAnn flagMsg severity srcSpan msg @@ -1409,16 +1409,19 @@ defaultLogAction dflags reason severity srcSpan msg | otherwise = "" -- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline. -defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> IO () -defaultLogActionHPrintDoc dflags h d - = defaultLogActionHPutStrDoc dflags h (d $$ text "") - -defaultLogActionHPutStrDoc :: DynFlags -> Handle -> SDoc -> IO () -defaultLogActionHPutStrDoc dflags h d +defaultLogActionHPrintDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO () +defaultLogActionHPrintDoc dflags asciiSpace h d + = defaultLogActionHPutStrDoc dflags asciiSpace h (d $$ text "") + +-- | The boolean arguments let's the pretty printer know if it can optimize indent +-- by writing ascii ' ' characters without going through decoding. +defaultLogActionHPutStrDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO () +defaultLogActionHPutStrDoc dflags asciiSpace h d -- Don't add a newline at the end, so that successive -- calls to this log-action can output all on the same line - = printSDoc ctx Pretty.PageMode h d - where ctx = initSDocContext dflags defaultUserStyle + = printSDoc ctx (Pretty.PageMode asciiSpace) h d + where + ctx = initSDocContext dflags defaultUserStyle newtype FlushOut = FlushOut (IO ()) diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs index 43c2cae4ad..1051a731c5 100644 --- a/compiler/GHC/Utils/Error.hs +++ b/compiler/GHC/Utils/Error.hs @@ -327,7 +327,8 @@ dumpSDocWithStyle sty dflags dumpOpt hdr doc = $$ blankLine $$ doc return $ mkDumpDoc hdr d - defaultLogActionHPrintDoc dflags handle (withPprStyle sty doc') + -- When we dump to files we use UTF8. Which allows ascii spaces. + defaultLogActionHPrintDoc dflags True handle (withPprStyle sty doc') -- write the dump to stdout writeDump Nothing = do diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index e88d9c42b6..ecef33ae86 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -567,7 +567,7 @@ pprCode cs d = withPprStyle (PprCode cs) d renderWithContext :: SDocContext -> SDoc -> String renderWithContext ctx sdoc - = let s = Pretty.style{ Pretty.mode = PageMode, + = let s = Pretty.style{ Pretty.mode = PageMode False, Pretty.lineLength = sdocLineLength ctx } in Pretty.renderStyle s $ runSDoc sdoc ctx diff --git a/compiler/GHC/Utils/Ppr.hs b/compiler/GHC/Utils/Ppr.hs index 3fa84850b8..8871f98cef 100644 --- a/compiler/GHC/Utils/Ppr.hs +++ b/compiler/GHC/Utils/Ppr.hs @@ -917,16 +917,26 @@ data Style , ribbonsPerLine :: Float -- ^ Ratio of line length to ribbon length } --- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@). +-- | The default style (@mode=PageMode False, lineLength=100, ribbonsPerLine=1.5@). style :: Style -style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode } +style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode False } -- | Rendering mode. -data Mode = PageMode -- ^ Normal +data Mode = PageMode { asciiSpace :: Bool } -- ^ Normal | ZigZagMode -- ^ With zig-zag cuts | LeftMode -- ^ No indentation, infinitely long lines | OneLineMode -- ^ All on one line +-- | Can we output an ascii space character for spaces? +-- Mostly true, but not for e.g. UTF16 +-- See Note [putSpaces optimizations] for why we bother +-- to track this. +hasAsciiSpace :: Mode -> Bool +hasAsciiSpace mode = + case mode of + PageMode asciiSpace -> asciiSpace + _ -> False + -- | Render the @Doc@ to a String using the given @Style@. renderStyle :: Style -> Doc -> String renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s) @@ -1034,6 +1044,20 @@ printDoc :: Mode -> Int -> Handle -> Doc -> IO () -- printDoc adds a newline to the end printDoc mode cols hdl doc = printDoc_ mode cols hdl (doc $$ text "") +{- Note [putSpaces optimizations] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When using dump flags a lot of what we are dumping ends up being whitespace. +This is especially true for Core/Stg dumps. Enough so that it's worth optimizing. + +Especially in the common case of writing to an UTF8 or similarly encoded file +where space is equal to ascii space we use hPutBuf to write a preallocated +buffer to the file. This avoids a fair bit of allocation. + +For other cases we fall back to the old and slow path for simplicity. + +-} + printDoc_ :: Mode -> Int -> Handle -> Doc -> IO () -- printDoc_ does not add a newline at the end, so that -- successive calls can output stuff on the same line @@ -1051,9 +1075,27 @@ printDoc_ mode pprCols hdl doc -- the I/O library's encoding layer. (#3398) put (ZStr s) next = hPutFZS hdl s >> next put (LStr s) next = hPutPtrString hdl s >> next - put (RStr n c) next = hPutStr hdl (replicate n c) >> next + put (RStr n c) next + | c == ' ' + = putSpaces n >> next + | otherwise + = hPutStr hdl (replicate n c) >> next + putSpaces n + -- If we use ascii spaces we are allowed to use hPutBuf + -- See Note [putSpaces optimizations] + | hasAsciiSpace mode + , n <= 100 + = hPutBuf hdl (Ptr spaces') n + | hasAsciiSpace mode + , n > 100 + = hPutBuf hdl (Ptr spaces') 100 >> putSpaces (n-100) + + | otherwise = hPutStr hdl (replicate n ' ') done = return () -- hPutChar hdl '\n' + -- 100 spaces, so we avoid the allocation of replicate n ' ' + spaces' = " "# + -- some versions of hPutBuf will barf if the length is zero hPutPtrString :: Handle -> PtrString -> IO () diff --git a/utils/haddock b/utils/haddock -Subproject 284c9a0c304faf9c186421a62da5d8b4dc73a8a +Subproject ef0375d6dc3d786c48067ecd6b84a58130829ac |