compiler/utils/BufWrite.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Fast write-buffered Handles
   4 --
   5 -- (c) The University of Glasgow 2005-2006
   6 --
   7 -- This is a simple abstraction over Handles that offers very fast write
   8 -- buffering, but without the thread safety that Handles provide.  It's used
   9 -- to save time in Pretty.printDoc.
  10 --
  11 -----------------------------------------------------------------------------
  12
  13 module BufWrite (
  14         BufHandle(..),
  15         newBufHandle,
  16         bPutChar,
  17         bPutStr,
  18         bPutFS,
  19         bPutLitString,
  20         bFlush,
  21   ) where
  22
  23 #include "HsVersions.h"
  24
  25 import FastString
  26 import FastTypes
  27 import FastMutInt
  28
  29 import Control.Monad    ( when )
  30 import Data.Char        ( ord )
  31 import Foreign
  32 import System.IO
  33
  34 -- -----------------------------------------------------------------------------
  35
  36 data BufHandle = BufHandle {-#UNPACK#-}!(Ptr Word8)
  37                            {-#UNPACK#-}!FastMutInt
  38                            Handle
  39
  40 newBufHandle :: Handle -> IO BufHandle
  41 newBufHandle hdl = do
  42   ptr <- mallocBytes buf_size
  43   r <- newFastMutInt
  44   writeFastMutInt r 0
  45   return (BufHandle ptr r hdl)
  46
  47 buf_size :: Int
  48 buf_size = 8192
  49
  50 #define STRICT2(f) f a b | a `seq` b `seq` False = undefined
  51 #define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined
  52
  53 bPutChar :: BufHandle -> Char -> IO ()
  54 STRICT2(bPutChar)
  55 bPutChar b@(BufHandle buf r hdl) c = do
  56   i <- readFastMutInt r
  57   if (i >= buf_size)
  58         then do hPutBuf hdl buf buf_size
  59                 writeFastMutInt r 0
  60                 bPutChar b c
  61         else do pokeElemOff buf i (fromIntegral (ord c) :: Word8)
  62                 writeFastMutInt r (i+1)
  63
  64 bPutStr :: BufHandle -> String -> IO ()
  65 STRICT2(bPutStr)
  66 bPutStr (BufHandle buf r hdl) str = do
  67   i <- readFastMutInt r
  68   loop str i
  69   where loop _ i | i `seq` False = undefined
  70         loop "" i = do writeFastMutInt r i; return ()
  71         loop (c:cs) i
  72            | i >= buf_size = do
  73                 hPutBuf hdl buf buf_size
  74                 loop (c:cs) 0
  75            | otherwise = do
  76                 pokeElemOff buf i (fromIntegral (ord c))
  77                 loop cs (i+1)
  78
  79 bPutFS :: BufHandle -> FastString -> IO ()
  80 bPutFS b@(BufHandle buf r hdl) fs@(FastString _ len _ fp _) =
  81  withForeignPtr fp $ \ptr -> do
  82   i <- readFastMutInt r
  83   if (i + len) >= buf_size
  84         then do hPutBuf hdl buf i
  85                 writeFastMutInt r 0
  86                 if (len >= buf_size)
  87                     then hPutBuf hdl ptr len
  88                     else bPutFS b fs
  89         else do
  90                 copyBytes (buf `plusPtr` i) ptr len
  91                 writeFastMutInt r (i+len)
  92
  93 bPutLitString :: BufHandle -> LitString -> FastInt -> IO ()
  94 bPutLitString b@(BufHandle buf r hdl) a len_ = a `seq` do
  95   let len = iBox len_
  96   i <- readFastMutInt r
  97   if (i+len) >= buf_size
  98         then do hPutBuf hdl buf i
  99                 writeFastMutInt r 0
 100                 if (len >= buf_size)
 101                     then hPutBuf hdl a len
 102                     else bPutLitString b a len_
 103         else do
 104                 copyBytes (buf `plusPtr` i) a len
 105                 writeFastMutInt r (i+len)
 106
 107 bFlush :: BufHandle -> IO ()
 108 bFlush (BufHandle buf r hdl) = do
 109   i <- readFastMutInt r
 110   when (i > 0) $ hPutBuf hdl buf i
 111   free buf
 112   return ()
 113
 114 #if 0
 115 myPutBuf s hdl buf i =
 116   modifyIOError (\e -> ioeSetErrorString e (ioeGetErrorString e ++ ':':s ++ " (" ++ show buf ++ "," ++ show i ++ ")")) $
 117
 118   hPutBuf hdl buf i
 119 #endif