X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FPretty.lhs;h=ec8f1e75ad108e305fb25167047768bb537a904e;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=ab9864b68ba994810cb3a42228606f05c9e65226;hpb=9af77fa423926fbda946b31e174173d0ec5ebac8;p=ghc-hetmet.git

diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs
index ab9864b..ec8f1e7 100644
--- a/ghc/compiler/utils/Pretty.lhs
+++ b/ghc/compiler/utils/Pretty.lhs
@@ -177,27 +177,18 @@ module Pretty (
 
 #include "HsVersions.h"
 
+import BufWrite
 import FastString
-import PrimPacked 	( strLength )
 
 import GLAEXTS
 
 import Numeric (fromRat)
 import IO
 
-#if __GLASGOW_HASKELL__ < 503
-import IOExts		( hPutBufFull )
-#else
 import System.IO	( hPutBuf )
-#endif
 
-#if __GLASGOW_HASKELL__ < 503
-import PrelBase		( unpackCString# )
-#else
 import GHC.Base		( unpackCString# )
-#endif
-
-import PrimPacked	( Ptr(..) )
+import GHC.Ptr		( Ptr(..) )
 
 -- Don't import Util( assertPanic ) because it makes a loop in the module structure
 
@@ -492,7 +483,7 @@ no occurrences of @Union@ or @NoDoc@ represents just one layout.
 data Doc
  = Empty                                -- empty
  | NilAbove Doc                         -- text "" $$ x
- | TextBeside TextDetails INT Doc       -- text s <> x  
+ | TextBeside !TextDetails INT Doc       -- text s <> x  
  | Nest INT Doc                         -- nest k x
  | Union Doc Doc                        -- ul `union` ur
  | NoDoc                                -- The empty set of documents
@@ -508,7 +499,7 @@ reduceDoc (Above  p g q) = above  p g (reduceDoc q)
 reduceDoc p              = p
 
 
-data TextDetails = Chr  Char
+data TextDetails = Chr  {-#UNPACK#-}!Char
                  | Str  String
                  | PStr FastString	-- a hashed string
 		 | LStr Addr# Int#	-- a '\0'-terminated array of bytes
@@ -690,15 +681,15 @@ beside :: Doc -> Bool -> RDoc -> RDoc
 beside NoDoc               g q   = NoDoc
 beside (p1 `Union` p2)     g q   = (beside p1 g q) `union_` (beside p2 g q)
 beside Empty               g q   = q
-beside (Nest k p)          g q   = nest_ k (beside p g q)       -- p non-empty
+beside (Nest k p)          g q   = nest_ k $! beside p g q       -- p non-empty
 beside p@(Beside p1 g1 q1) g2 q2 
            {- (A `op1` B) `op2` C == A `op1` (B `op2` C)  iff op1 == op2 
                                                  [ && (op1 == <> || op1 == <+>) ] -}
-         | g1 == g2              = beside p1 g1 (beside q1 g2 q2)
+         | g1 == g2              = beside p1 g1 $! beside q1 g2 q2
          | otherwise             = beside (reduceDoc p) g2 q2
-beside p@(Above _ _ _)     g q   = beside (reduceDoc p) g q
-beside (NilAbove p)        g q   = nilAbove_ (beside p g q)
-beside (TextBeside s sl p) g q   = textBeside_ s sl rest
+beside p@(Above _ _ _)     g q   = let d = reduceDoc p in d `seq` beside d g q
+beside (NilAbove p)        g q   = nilAbove_ $! beside p g q
+beside (TextBeside s sl p) g q   = textBeside_ s sl $! rest
                                where
                                   rest = case p of
                                            Empty -> nilBeside g q
@@ -1013,9 +1004,11 @@ spaces n       = ' ' : spaces (n MINUS ILIT(1))
 \end{code}
 
 \begin{code}
-pprCols = (100 :: Int) -- could make configurable
+pprCols = (120 :: Int) -- could make configurable
 
 printDoc :: Mode -> Handle -> Doc -> IO ()
+printDoc LeftMode hdl doc
+  = do { printLeftRender hdl doc; hFlush hdl }
 printDoc mode hdl doc
   = do { fullRender mode pprCols 1.5 put done doc ;
 	 hFlush hdl }
@@ -1027,10 +1020,6 @@ printDoc mode hdl doc
 
     done = hPutChar hdl '\n'
 
-#if __GLASGOW_HASKELL__ < 503
-hPutBuf = hPutBufFull
-#endif
-
   -- some versions of hPutBuf will barf if the length is zero
 hPutLitString handle a# 0# = return ()
 hPutLitString handle a# l#
@@ -1039,4 +1028,48 @@ hPutLitString handle a# l#
 #else
   = hPutBuf handle (Ptr a#) (I# l#)
 #endif
+
+-- Printing output in LeftMode is performance critical: it's used when
+-- dumping C and assembly output, so we allow ourselves a few dirty
+-- hacks:
+--
+--	(1) we specialise fullRender for LeftMode with IO output.
+--
+--	(2) we add a layer of buffering on top of Handles.  Handles
+--	    don't perform well with lots of hPutChars, which is mostly
+--	    what we're doing here, because Handles have to be thread-safe
+--	    and async exception-safe.  We only have a single thread and don't
+--	    care about exceptions, so we add a layer of fast buffering
+--	    over the Handle interface.
+--
+--	(3) a few hacks in layLeft below to convince GHC to generate the right
+--	    code.
+
+printLeftRender :: Handle -> Doc -> IO ()
+printLeftRender hdl doc = do
+  b <- newBufHandle hdl
+  layLeft b (reduceDoc doc)
+  bFlush b
+
+-- 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.
+layLeft b _ | b `seq` False = undefined	-- make it strict in b
+layLeft b NoDoc               	= cant_fail
+layLeft b (Union p q) 		= return () >> layLeft b (first p q)
+layLeft b (Nest k p)          	= return () >> layLeft b p
+layLeft b Empty               	= bPutChar b '\n'
+layLeft b (NilAbove p)        	= bPutChar b '\n' >> layLeft b p
+layLeft b (TextBeside s sl p) 	= 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 (LStr s l) = bPutLitString b s l
+
+#if __GLASGOW_HASKELL__ < 503
+hPutBuf = hPutBufFull
+#endif
+
 \end{code}