From ac88f113abdec1edbffb6d2f97323e81f82908e7 Mon Sep 17 00:00:00 2001 From: simonmar Date: Tue, 26 Jul 2005 12:14:03 +0000 Subject: [PATCH] [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. --- ghc/compiler/utils/BufWrite.hs | 138 +++++++++++++++++++++++++++++++++++++ ghc/compiler/utils/Pretty.lhs | 77 ++++++++++++++------- ghc/compiler/utils/PrimPacked.lhs | 2 +- 3 files changed, 190 insertions(+), 27 deletions(-) create mode 100644 ghc/compiler/utils/BufWrite.hs diff --git a/ghc/compiler/utils/BufWrite.hs b/ghc/compiler/utils/BufWrite.hs new file mode 100644 index 0000000..6d00e46 --- /dev/null +++ b/ghc/compiler/utils/BufWrite.hs @@ -0,0 +1,138 @@ +----------------------------------------------------------------------------- +-- +-- 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 diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs index 6f3f1ea..916755e 100644 --- a/ghc/compiler/utils/Pretty.lhs +++ b/ghc/compiler/utils/Pretty.lhs @@ -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} diff --git a/ghc/compiler/utils/PrimPacked.lhs b/ghc/compiler/utils/PrimPacked.lhs index c3b62ed..45177dc 100644 --- a/ghc/compiler/utils/PrimPacked.lhs +++ b/ghc/compiler/utils/PrimPacked.lhs @@ -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 -> -- 1.7.10.4