Commit ac88f113 authored by simonmar's avatar simonmar

[project @ 2005-07-26 12:14:03 by simonmar]

Add a layer of write buffering over Handle when dumping the output:
this saves a lot of time because we're doing a lot of small writes,
and Handle operations have a non-trivial constant overhead due to the
thread-safety, exception-safety etc.

This improvement results in about a 10% reduction in compile time for
non-optimised, somewhat less for optimised compilation.
parent a28e9d84
-----------------------------------------------------------------------------
--
-- Fast write-buffered Handles
--
-- (c) The University of Glasgow 2005
--
-- This is a simple abstraction over Handles that offers very fast write
-- buffering, but without the thread safety that Handles provide. It's used
-- to save time in Pretty.printDoc.
--
-----------------------------------------------------------------------------
module BufWrite (
BufHandle(..),
newBufHandle,
bPutChar,
bPutStr,
bPutFS,
bPutLitString,
bFlush,
) where
#include "HsVersions.h"
import FastString
import FastMutInt
import Panic ( panic )
import Monad ( when )
import Char ( ord )
import Foreign
import IO
#if __GLASGOW_HASKELL__ < 503
import PrelIOBase ( IO(..) )
import IOExts ( hPutBufFull )
#else
import GHC.IOBase ( IO(..) )
import System.IO ( hPutBuf )
#endif
import GLAEXTS ( touch#, byteArrayContents#, Int(..), Int#, Addr# )
import PrimPacked ( Ptr(..) )
-- -----------------------------------------------------------------------------
data BufHandle = BufHandle {-#UNPACK#-}!(Ptr Word8)
{-#UNPACK#-}!FastMutInt
Handle
newBufHandle :: Handle -> IO BufHandle
newBufHandle hdl = do
ptr <- mallocBytes buf_size
r <- newFastMutInt
writeFastMutInt r 0
return (BufHandle ptr r hdl)
buf_size = 8192 :: Int
#define STRICT2(f) f a b | a `seq` b `seq` False = undefined
#define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined
bPutChar :: BufHandle -> Char -> IO ()
STRICT2(bPutChar)
bPutChar b@(BufHandle buf r hdl) c = do
i <- readFastMutInt r
if (i >= buf_size)
then do hPutBuf hdl buf buf_size
writeFastMutInt r 0
bPutChar b c
else do pokeElemOff buf i (fromIntegral (ord c) :: Word8)
writeFastMutInt r (i+1)
bPutStr :: BufHandle -> String -> IO ()
STRICT2(bPutStr)
bPutStr b@(BufHandle buf r hdl) str = do
i <- readFastMutInt r
loop str i
where loop _ i | i `seq` False = undefined
loop "" i = do writeFastMutInt r i; return ()
loop (c:cs) i
| i >= buf_size = do
hPutBuf hdl buf buf_size
loop (c:cs) 0
| otherwise = do
pokeElemOff buf i (fromIntegral (ord c))
loop cs (i+1)
bPutFS :: BufHandle -> FastString -> IO ()
bPutFS b@(BufHandle buf r hdl) fs@(FastString _ len# arr#) = do
let len = I# len#
i <- readFastMutInt r
if (i + len) >= buf_size
then do hPutBuf hdl buf i
writeFastMutInt r 0
if (len >= buf_size)
then do
let a# = byteArrayContents# arr#
hPutBuf hdl (Ptr a#) len
touch fs
else bPutFS b fs
else do
let a# = byteArrayContents# arr#
copyBytes (buf `plusPtr` i) (Ptr a#) len
touch fs
writeFastMutInt r (i+len)
bPutFS _ _ = panic "bPutFS"
bPutLitString :: BufHandle -> Addr# -> Int# -> IO ()
bPutLitString b@(BufHandle buf r hdl) a# len# = do
let len = I# len#
i <- readFastMutInt r
if (i+len) >= buf_size
then do hPutBuf hdl buf i
writeFastMutInt r 0
if (len >= buf_size)
then hPutBuf hdl (Ptr a#) len
else bPutLitString b a# len#
else do
copyBytes (buf `plusPtr` i) (Ptr a#) len
writeFastMutInt r (i+len)
bFlush :: BufHandle -> IO ()
bFlush b@(BufHandle buf r hdl) = do
i <- readFastMutInt r
when (i > 0) $ hPutBuf hdl buf i
free buf
return ()
touch r = IO $ \s -> case touch# r s of s -> (# s, () #)
#if 0
myPutBuf s hdl buf i =
modifyIOError (\e -> ioeSetErrorString e (ioeGetErrorString e ++ ':':s ++ " (" ++ show buf ++ "," ++ show i ++ ")")) $
hPutBuf hdl buf i
#endif
......@@ -177,6 +177,7 @@ module Pretty (
#include "HsVersions.h"
import BufWrite
import FastString
import PrimPacked ( strLength )
......@@ -508,7 +509,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 +691,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
......@@ -1029,26 +1030,6 @@ printDoc mode hdl doc
done = hPutChar hdl '\n'
-- basically a specialised version of fullRender for LeftMode with IO output.
printLeftRender :: Handle -> Doc -> IO ()
printLeftRender hdl doc = lay (reduceDoc doc)
where
lay NoDoc = cant_fail
lay (Union p q) = lay (first p q)
lay (Nest k p) = lay p
lay Empty = hPutChar hdl '\n'
lay (NilAbove p) = hPutChar hdl '\n' >> lay p
lay (TextBeside s sl p) = put s >> lay p
put (Chr c) = hPutChar hdl c
put (Str s) = hPutStr hdl s
put (PStr s) = hPutFS hdl s
put (LStr s l) = hPutLitString hdl s l
#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#
......@@ -1057,4 +1038,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}
......@@ -185,7 +185,7 @@ freeze_ps_array :: MBA s -> Int# -> ST s BA
#if __GLASGOW_HASKELL__ < 411
#define NEW_BYTE_ARRAY newCharArray#
#else
#define NEW_BYTE_ARRAY newByteArray#
#define NEW_BYTE_ARRAY newPinnedByteArray#
#endif
new_ps_array size = ST $ \ s ->
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment