never executed always true always false

    1 {-# LANGUAGE BangPatterns #-}
    2 
    3 -----------------------------------------------------------------------------
    4 --
    5 -- Fast write-buffered Handles
    6 --
    7 -- (c) The University of Glasgow 2005-2006
    8 --
    9 -- This is a simple abstraction over Handles that offers very fast write
   10 -- buffering, but without the thread safety that Handles provide.  It's used
   11 -- to save time in GHC.Utils.Ppr.printDoc.
   12 --
   13 -----------------------------------------------------------------------------
   14 
   15 module GHC.Utils.BufHandle (
   16         BufHandle(..),
   17         newBufHandle,
   18         bPutChar,
   19         bPutStr,
   20         bPutFS,
   21         bPutFZS,
   22         bPutPtrString,
   23         bPutReplicate,
   24         bFlush,
   25   ) where
   26 
   27 import GHC.Prelude
   28 
   29 import GHC.Data.FastString
   30 import GHC.Data.FastMutInt
   31 
   32 import Control.Monad    ( when )
   33 import Data.ByteString (ByteString)
   34 import qualified Data.ByteString.Unsafe as BS
   35 import Data.Char        ( ord )
   36 import Foreign
   37 import Foreign.C.String
   38 import System.IO
   39 
   40 -- -----------------------------------------------------------------------------
   41 
   42 data BufHandle = BufHandle {-#UNPACK#-}!(Ptr Word8)
   43                            {-#UNPACK#-}!FastMutInt
   44                            Handle
   45 
   46 newBufHandle :: Handle -> IO BufHandle
   47 newBufHandle hdl = do
   48   ptr <- mallocBytes buf_size
   49   r <- newFastMutInt 0
   50   return (BufHandle ptr r hdl)
   51 
   52 buf_size :: Int
   53 buf_size = 8192
   54 
   55 bPutChar :: BufHandle -> Char -> IO ()
   56 bPutChar b@(BufHandle buf r hdl) !c = do
   57   i <- readFastMutInt r
   58   if (i >= buf_size)
   59         then do hPutBuf hdl buf buf_size
   60                 writeFastMutInt r 0
   61                 bPutChar b c
   62         else do pokeElemOff buf i (fromIntegral (ord c) :: Word8)
   63                 writeFastMutInt r (i+1)
   64 
   65 bPutStr :: BufHandle -> String -> IO ()
   66 bPutStr (BufHandle buf r hdl) !str = do
   67   i <- readFastMutInt r
   68   loop str i
   69   where loop "" !i = do writeFastMutInt r i; return ()
   70         loop (c:cs) !i
   71            | i >= buf_size = do
   72                 hPutBuf hdl buf buf_size
   73                 loop (c:cs) 0
   74            | otherwise = do
   75                 pokeElemOff buf i (fromIntegral (ord c))
   76                 loop cs (i+1)
   77 
   78 bPutFS :: BufHandle -> FastString -> IO ()
   79 bPutFS b fs = bPutBS b $ bytesFS fs
   80 
   81 bPutFZS :: BufHandle -> FastZString -> IO ()
   82 bPutFZS b fs = bPutBS b $ fastZStringToByteString fs
   83 
   84 bPutBS :: BufHandle -> ByteString -> IO ()
   85 bPutBS b bs = BS.unsafeUseAsCStringLen bs $ bPutCStringLen b
   86 
   87 bPutCStringLen :: BufHandle -> CStringLen -> IO ()
   88 bPutCStringLen b@(BufHandle buf r hdl) cstr@(ptr, len) = do
   89   i <- readFastMutInt r
   90   if (i + len) >= buf_size
   91         then do hPutBuf hdl buf i
   92                 writeFastMutInt r 0
   93                 if (len >= buf_size)
   94                     then hPutBuf hdl ptr len
   95                     else bPutCStringLen b cstr
   96         else do
   97                 copyBytes (buf `plusPtr` i) ptr len
   98                 writeFastMutInt r (i + len)
   99 
  100 bPutPtrString :: BufHandle -> PtrString -> IO ()
  101 bPutPtrString b@(BufHandle buf r hdl) l@(PtrString a len) = l `seq` do
  102   i <- readFastMutInt r
  103   if (i+len) >= buf_size
  104         then do hPutBuf hdl buf i
  105                 writeFastMutInt r 0
  106                 if (len >= buf_size)
  107                     then hPutBuf hdl a len
  108                     else bPutPtrString b l
  109         else do
  110                 copyBytes (buf `plusPtr` i) a len
  111                 writeFastMutInt r (i+len)
  112 
  113 -- | Replicate an 8-bit character
  114 bPutReplicate :: BufHandle -> Int -> Char -> IO ()
  115 bPutReplicate (BufHandle buf r hdl) len c = do
  116   i <- readFastMutInt r
  117   let oc = fromIntegral (ord c)
  118   if (i+len) < buf_size
  119     then do
  120       fillBytes (buf `plusPtr` i) oc len
  121       writeFastMutInt r (i+len)
  122     else do
  123       -- flush the current buffer
  124       when (i /= 0) $ hPutBuf hdl buf i
  125       if (len < buf_size)
  126         then do
  127           fillBytes buf oc len
  128           writeFastMutInt r len
  129         else do
  130           -- fill a full buffer
  131           fillBytes buf oc buf_size
  132           -- flush it as many times as necessary
  133           let go n | n >= buf_size = do
  134                                        hPutBuf hdl buf buf_size
  135                                        go (n-buf_size)
  136                    | otherwise     = writeFastMutInt r n
  137           go len
  138 
  139 bFlush :: BufHandle -> IO ()
  140 bFlush (BufHandle buf r hdl) = do
  141   i <- readFastMutInt r
  142   when (i > 0) $ hPutBuf hdl buf i
  143   free buf
  144   return ()