compiler/utils/BufWrite.hs

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