I noticed while working on the new IO library that GHC was writing out
the .s file in lots of little chunks. It turns out that this is a
result of using multiple printDocs to avoid space leaks in the NCG,
where each printDoc is finishing up with an hFlush.
What's worse, is that this makes poor use of the optimisation inside
printDoc that uses its own buffering to avoid hitting the Handle all
the time.
So I hacked around this by making the buffering optimisation inside
Pretty visible from the outside, for use in the NCG. The changes are
quite small.
import Digraph
import qualified Pretty
import Digraph
import qualified Pretty
import Outputable
import FastString
import UniqSet
import Outputable
import FastString
import UniqSet
= do
let split_cmms = concat $ map add_split cmms
= do
let split_cmms = concat $ map add_split cmms
- (imports, prof)
- <- cmmNativeGens dflags h us split_cmms [] [] 0
+ -- BufHandle is a performance hack. We could hide it inside
+ -- Pretty if it weren't for the fact that we do lots of little
+ -- printDocs here (in order to do codegen in constant space).
+ bufh <- newBufHandle h
+ (imports, prof) <- cmmNativeGens dflags bufh us split_cmms [] [] 0
+ bFlush bufh
let (native, colorStats, linearStats)
= unzip3 prof
let (native, colorStats, linearStats)
= unzip3 prof
(us', native, imports, colorStats, linearStats)
<- cmmNativeGen dflags us cmm count
(us', native, imports, colorStats, linearStats)
<- cmmNativeGen dflags us cmm count
- Pretty.printDoc Pretty.LeftMode h
$ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map pprNatCmmTop native
let lsPprNative =
$ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map pprNatCmmTop native
let lsPprNative =
hang, punctuate,
-- renderStyle, -- Haskell 1.3 only
hang, punctuate,
-- renderStyle, -- Haskell 1.3 only
- render, fullRender, printDoc, showDocWith
+ render, fullRender, printDoc, showDocWith,
+ bufLeftRender -- performance hack
printLeftRender :: Handle -> Doc -> IO ()
printLeftRender hdl doc = do
b <- newBufHandle hdl
printLeftRender :: Handle -> Doc -> IO ()
printLeftRender hdl doc = do
b <- newBufHandle hdl
- layLeft b (reduceDoc doc)
+bufLeftRender :: BufHandle -> Doc -> IO ()
+bufLeftRender b doc = layLeft b (reduceDoc doc)
+
-- HACK ALERT! the "return () >>" below convinces GHC to eta-expand
-- this function with the IO state lambda. Otherwise we end up with
-- closures in all the case branches.
-- HACK ALERT! the "return () >>" below convinces GHC to eta-expand
-- this function with the IO state lambda. Otherwise we end up with
-- closures in all the case branches.