From 6ba3d614390f83c32e97593c4ae03a6b0355f474 Mon Sep 17 00:00:00 2001
From: Simon Marlow <marlowsd@gmail.com>
Date: Mon, 2 Feb 2009 14:50:13 +0000
Subject: [PATCH] Optimise writing out the .s file 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.
---
 compiler/nativeGen/AsmCodeGen.lhs |   11 ++++++++---
 compiler/utils/Pretty.lhs         |    8 ++++++--
 2 files changed, 14 insertions(+), 5 deletions(-)

diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 29f4be4..70b042b 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -53,6 +53,7 @@ import Module
 
 import Digraph
 import qualified Pretty
+import BufWrite
 import Outputable
 import FastString
 import UniqSet
@@ -127,8 +128,12 @@ nativeCodeGen dflags h us 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
@@ -186,7 +191,7 @@ cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc count
  	(us', native, imports, colorStats, linearStats)
 		<- cmmNativeGen dflags us cmm count
 
-	Pretty.printDoc Pretty.LeftMode h
+	Pretty.bufLeftRender h
 		$ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map pprNatCmmTop native
 
 	let lsPprNative =
diff --git a/compiler/utils/Pretty.lhs b/compiler/utils/Pretty.lhs
index 7aec715..3e08814 100644
--- a/compiler/utils/Pretty.lhs
+++ b/compiler/utils/Pretty.lhs
@@ -176,7 +176,8 @@ module Pretty (
         hang, punctuate,
 
 --      renderStyle,            -- Haskell 1.3 only
-        render, fullRender, printDoc, showDocWith
+        render, fullRender, printDoc, showDocWith,
+        bufLeftRender -- performance hack
   ) where
 
 import BufWrite
@@ -1042,9 +1043,12 @@ hPutLitString handle a l = if l ==# _ILIT(0)
 printLeftRender :: Handle -> Doc -> IO ()
 printLeftRender hdl doc = do
   b <- newBufHandle hdl
-  layLeft b (reduceDoc doc)
+  bufLeftRender b doc
   bFlush b
 
+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.
-- 
1.7.10.4