path: root/libraries/base/GHC/IO.hs

{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-}
{-# OPTIONS_HADDOCK hide #-}

#undef DEBUG_DUMP

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.IO
-- Copyright   :  (c) The University of Glasgow, 1992-2001
-- License     :  see libraries/base/LICENSE
-- 
-- Maintainer  :  libraries@haskell.org
-- Stability   :  internal
-- Portability :  non-portable
--
-- String I\/O functions
--
-----------------------------------------------------------------------------

-- #hide
module GHC.IO ( 
   hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
   commitBuffer',       -- hack, see below
   hGetcBuffered,       -- needed by ghc/compiler/utils/StringBuffer.lhs
   hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, slurpFile,
   memcpy_ba_baoff,
   memcpy_ptr_baoff,
   memcpy_baoff_ba,
   memcpy_baoff_ptr,
 ) where

import Foreign
import Foreign.C

import System.IO.Error
import Data.Maybe
import Control.Monad
import System.Posix.Internals

import GHC.Enum
import GHC.Base
import GHC.IOBase
import GHC.Handle       -- much of the real stuff is in here
import GHC.Real
import GHC.Num
import GHC.Show
import GHC.List

#ifdef mingw32_HOST_OS
import GHC.Conc
#endif

-- ---------------------------------------------------------------------------
-- Simple input operations

-- If hWaitForInput finds anything in the Handle's buffer, it
-- immediately returns.  If not, it tries to read from the underlying
-- OS handle. Notice that for buffered Handles connected to terminals
-- this means waiting until a complete line is available.

-- | Computation 'hWaitForInput' @hdl t@
-- waits until input is available on handle @hdl@.
-- It returns 'True' as soon as input is available on @hdl@,
-- or 'False' if no input is available within @t@ milliseconds.
--
-- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely.
--
-- This operation may fail with:
--
--  * 'isEOFError' if the end of file has been reached.
--
-- NOTE for GHC users: unless you use the @-threaded@ flag,
-- @hWaitForInput t@ where @t >= 0@ will block all other Haskell
-- threads for the duration of the call.  It behaves like a
-- @safe@ foreign call in this respect.

hWaitForInput :: Handle -> Int -> IO Bool
hWaitForInput h msecs = do
  wantReadableHandle "hWaitForInput" h $ \ handle_ -> do
  let ref = haBuffer handle_
  buf <- readIORef ref

  if not (bufferEmpty buf)
        then return True
        else do

  if msecs < 0 
        then do buf' <- fillReadBuffer (haFD handle_) True 
                                (haIsStream handle_) buf
                writeIORef ref buf'
                return True
        else do r <- throwErrnoIfMinus1Retry "hWaitForInput" $
                     fdReady (haFD handle_) 0 {- read -}
                                (fromIntegral msecs)
                                (fromIntegral $ fromEnum $ haIsStream handle_)
                if r /= 0 then do -- Call hLookAhead' to throw an EOF
                                  -- exception if appropriate
                                  hLookAhead' handle_
                                  return True
                          else return False

foreign import ccall safe "fdReady"
  fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt

-- ---------------------------------------------------------------------------
-- hGetChar

-- | Computation 'hGetChar' @hdl@ reads a character from the file or
-- channel managed by @hdl@, blocking until a character is available.
--
-- This operation may fail with:
--
--  * 'isEOFError' if the end of file has been reached.

hGetChar :: Handle -> IO Char
hGetChar handle =
  wantReadableHandle "hGetChar" handle $ \handle_ -> do

  let fd = haFD handle_
      ref = haBuffer handle_

  buf <- readIORef ref
  if not (bufferEmpty buf)
        then hGetcBuffered fd ref buf
        else do

  -- buffer is empty.
  case haBufferMode handle_ of
    LineBuffering    -> do
        new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
        hGetcBuffered fd ref new_buf
    BlockBuffering _ -> do
        new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
                --                   ^^^^
                -- don't wait for a completely full buffer.
        hGetcBuffered fd ref new_buf
    NoBuffering -> do
        -- make use of the minimal buffer we already have
        let raw = bufBuf buf
        r <- readRawBuffer "hGetChar" fd (haIsStream handle_) raw 0 1
        if r == 0
           then ioe_EOF
           else do (c,_) <- readCharFromBuffer raw 0
                   return c

hGetcBuffered :: FD -> IORef Buffer -> Buffer -> IO Char
hGetcBuffered _ ref buf@Buffer{ bufBuf=b, bufRPtr=r0, bufWPtr=w }
 = do (c, r) <- readCharFromBuffer b r0
      let new_buf | r == w    = buf{ bufRPtr=0, bufWPtr=0 }
                  | otherwise = buf{ bufRPtr=r }
      writeIORef ref new_buf
      return c

-- ---------------------------------------------------------------------------
-- hGetLine

-- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
-- the duration.

-- | Computation 'hGetLine' @hdl@ reads a line from the file or
-- channel managed by @hdl@.
--
-- This operation may fail with:
--
--  * 'isEOFError' if the end of file is encountered when reading
--    the /first/ character of the line.
--
-- If 'hGetLine' encounters end-of-file at any other point while reading
-- in a line, it is treated as a line terminator and the (partial)
-- line is returned.

hGetLine :: Handle -> IO String
hGetLine h = do
  m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
        case haBufferMode handle_ of
           NoBuffering      -> return Nothing
           LineBuffering    -> do
              l <- hGetLineBuffered handle_
              return (Just l)
           BlockBuffering _ -> do 
              l <- hGetLineBuffered handle_
              return (Just l)
  case m of
        Nothing -> hGetLineUnBuffered h
        Just l  -> return l

hGetLineBuffered :: Handle__ -> IO String
hGetLineBuffered handle_ = do
  let ref = haBuffer handle_
  buf <- readIORef ref
  hGetLineBufferedLoop handle_ ref buf []

hGetLineBufferedLoop :: Handle__ -> IORef Buffer -> Buffer -> [String]
                     -> IO String
hGetLineBufferedLoop handle_ ref
        buf@Buffer{ bufRPtr=r0, bufWPtr=w, bufBuf=raw0 } xss =
  let
        -- find the end-of-line character, if there is one
        loop raw r
           | r == w = return (False, w)
           | otherwise =  do
                (c,r') <- readCharFromBuffer raw r
                if c == '\n'
                   then return (True, r) -- NB. not r': don't include the '\n'
                   else loop raw r'
  in do
  (eol, off) <- loop raw0 r0

#ifdef DEBUG_DUMP
  puts ("hGetLineBufferedLoop: r=" ++ show r0 ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
#endif

  xs <- unpack raw0 r0 off

  -- if eol == True, then off is the offset of the '\n'
  -- otherwise off == w and the buffer is now empty.
  if eol
        then do if (w == off + 1)
                        then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
                        else writeIORef ref buf{ bufRPtr = off + 1 }
                return (concat (reverse (xs:xss)))
        else do
             maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
                                buf{ bufWPtr=0, bufRPtr=0 }
             case maybe_buf of
                -- Nothing indicates we caught an EOF, and we may have a
                -- partial line to return.
                Nothing -> do
                     writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
                     let str = concat (reverse (xs:xss))
                     if not (null str)
                        then return str
                        else ioe_EOF
                Just new_buf ->
                     hGetLineBufferedLoop handle_ ref new_buf (xs:xss)

maybeFillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO (Maybe Buffer)
maybeFillReadBuffer fd is_line is_stream buf
  = catch 
     (do buf' <- fillReadBuffer fd is_line is_stream buf
         return (Just buf')
     )
     (\e -> do if isEOFError e 
                  then return Nothing 
                  else ioError e)


unpack :: RawBuffer -> Int -> Int -> IO [Char]
unpack _   _      0        = return ""
unpack buf (I# r) (I# len) = IO $ \s -> unpackRB [] (len -# 1#) s
   where
    unpackRB acc i s
     | i <# r  = (# s, acc #)
     | otherwise = 
          case readCharArray# buf i s of
          (# s', ch #) -> unpackRB (C# ch : acc) (i -# 1#) s'


hGetLineUnBuffered :: Handle -> IO String
hGetLineUnBuffered h = do
  c <- hGetChar h
  if c == '\n' then
     return ""
   else do
    l <- getRest
    return (c:l)
 where
  getRest = do
    c <- 
      catch 
        (hGetChar h)
        (\ err -> do
          if isEOFError err then
             return '\n'
           else
             ioError err)
    if c == '\n' then
       return ""
     else do
       s <- getRest
       return (c:s)

-- -----------------------------------------------------------------------------
-- hGetContents

-- hGetContents on a DuplexHandle only affects the read side: you can
-- carry on writing to it afterwards.

-- | Computation 'hGetContents' @hdl@ returns the list of characters
-- corresponding to the unread portion of the channel or file managed
-- by @hdl@, which is put into an intermediate state, /semi-closed/.
-- In this state, @hdl@ is effectively closed,
-- but items are read from @hdl@ on demand and accumulated in a special
-- list returned by 'hGetContents' @hdl@.
--
-- Any operation that fails because a handle is closed,
-- also fails if a handle is semi-closed.  The only exception is 'hClose'.
-- A semi-closed handle becomes closed:
--
--  * if 'hClose' is applied to it;
--
--  * if an I\/O error occurs when reading an item from the handle;
--
--  * or once the entire contents of the handle has been read.
--
-- Once a semi-closed handle becomes closed, the contents of the
-- associated list becomes fixed.  The contents of this final list is
-- only partially specified: it will contain at least all the items of
-- the stream that were evaluated prior to the handle becoming closed.
--
-- Any I\/O errors encountered while a handle is semi-closed are simply
-- discarded.
--
-- This operation may fail with:
--
--  * 'isEOFError' if the end of file has been reached.

hGetContents :: Handle -> IO String
hGetContents handle = 
    withHandle "hGetContents" handle $ \handle_ ->
    case haType handle_ of 
      ClosedHandle         -> ioe_closedHandle
      SemiClosedHandle     -> ioe_closedHandle
      AppendHandle         -> ioe_notReadable
      WriteHandle          -> ioe_notReadable
      _ -> do xs <- lazyRead handle
              return (handle_{ haType=SemiClosedHandle}, xs )

-- Note that someone may close the semi-closed handle (or change its
-- buffering), so each time these lazy read functions are pulled on,
-- they have to check whether the handle has indeed been closed.

lazyRead :: Handle -> IO String
lazyRead handle = 
   unsafeInterleaveIO $
        withHandle "lazyRead" handle $ \ handle_ -> do
        case haType handle_ of
          ClosedHandle     -> return (handle_, "")
          SemiClosedHandle -> lazyRead' handle handle_
          _ -> ioException 
                  (IOError (Just handle) IllegalOperation "lazyRead"
                        "illegal handle type" Nothing)

lazyRead' :: Handle -> Handle__ -> IO (Handle__, [Char])
lazyRead' h handle_ = do
  let ref = haBuffer handle_
      fd  = haFD handle_

  -- even a NoBuffering handle can have a char in the buffer... 
  -- (see hLookAhead)
  buf <- readIORef ref
  if not (bufferEmpty buf)
        then lazyReadHaveBuffer h handle_ fd ref buf
        else do

  case haBufferMode handle_ of
     NoBuffering      -> do
        -- make use of the minimal buffer we already have
        let raw = bufBuf buf
        r <- readRawBuffer "lazyRead" fd (haIsStream handle_) raw 0 1
        if r == 0
           then do (handle_', _) <- hClose_help handle_ 
                   return (handle_', "")
           else do (c,_) <- readCharFromBuffer raw 0
                   rest <- lazyRead h
                   return (handle_, c : rest)

     LineBuffering    -> lazyReadBuffered h handle_ fd ref buf
     BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf

-- we never want to block during the read, so we call fillReadBuffer with
-- is_line==True, which tells it to "just read what there is".
lazyReadBuffered :: Handle -> Handle__ -> FD -> IORef Buffer -> Buffer
                 -> IO (Handle__, [Char])
lazyReadBuffered h handle_ fd ref buf = do
   catch 
        (do buf' <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
            lazyReadHaveBuffer h handle_ fd ref buf'
        )
        -- all I/O errors are discarded.  Additionally, we close the handle.
        (\_ -> do (handle_', _) <- hClose_help handle_
                  return (handle_', "")
        )

lazyReadHaveBuffer :: Handle -> Handle__ -> FD -> IORef Buffer -> Buffer -> IO (Handle__, [Char])
lazyReadHaveBuffer h handle_ _ ref buf = do
   more <- lazyRead h
   writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
   s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
   return (handle_, s)


unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
unpackAcc _   _      0        acc  = return acc
unpackAcc buf (I# r) (I# len) acc0 = IO $ \s -> unpackRB acc0 (len -# 1#) s
   where
    unpackRB acc i s
     | i <# r  = (# s, acc #)
     | otherwise = 
          case readCharArray# buf i s of
          (# s', ch #) -> unpackRB (C# ch : acc) (i -# 1#) s'

-- ---------------------------------------------------------------------------
-- hPutChar

-- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the
-- file or channel managed by @hdl@.  Characters may be buffered if
-- buffering is enabled for @hdl@.
--
-- This operation may fail with:
--
--  * 'isFullError' if the device is full; or
--
--  * 'isPermissionError' if another system resource limit would be exceeded.

hPutChar :: Handle -> Char -> IO ()
hPutChar handle c = do
    c `seq` return ()
    wantWritableHandle "hPutChar" handle $ \ handle_  -> do
    let fd = haFD handle_
    case haBufferMode handle_ of
        LineBuffering    -> hPutcBuffered handle_ True  c
        BlockBuffering _ -> hPutcBuffered handle_ False c
        NoBuffering      ->
                with (castCharToCChar c) $ \buf -> do
                  writeRawBufferPtr "hPutChar" fd (haIsStream handle_) buf 0 1
                  return ()

hPutcBuffered :: Handle__ -> Bool -> Char -> IO ()
hPutcBuffered handle_ is_line c = do
  let ref = haBuffer handle_
  buf <- readIORef ref
  let w = bufWPtr buf
  w'  <- writeCharIntoBuffer (bufBuf buf) w c
  let new_buf = buf{ bufWPtr = w' }
  if bufferFull new_buf || is_line && c == '\n'
     then do 
        flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf
        writeIORef ref flushed_buf
     else do 
        writeIORef ref new_buf


hPutChars :: Handle -> [Char] -> IO ()
hPutChars _      [] = return ()
hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs

-- ---------------------------------------------------------------------------
-- hPutStr

-- We go to some trouble to avoid keeping the handle locked while we're
-- evaluating the string argument to hPutStr, in case doing so triggers another
-- I/O operation on the same handle which would lead to deadlock.  The classic
-- case is
--
--              putStr (trace "hello" "world")
--
-- so the basic scheme is this:
--
--      * copy the string into a fresh buffer,
--      * "commit" the buffer to the handle.
--
-- Committing may involve simply copying the contents of the new
-- buffer into the handle's buffer, flushing one or both buffers, or
-- maybe just swapping the buffers over (if the handle's buffer was
-- empty).  See commitBuffer below.

-- | Computation 'hPutStr' @hdl s@ writes the string
-- @s@ to the file or channel managed by @hdl@.
--
-- This operation may fail with:
--
--  * 'isFullError' if the device is full; or
--
--  * 'isPermissionError' if another system resource limit would be exceeded.

hPutStr :: Handle -> String -> IO ()
hPutStr handle str = do
    buffer_mode <- wantWritableHandle "hPutStr" handle 
                        (\ handle_ -> do getSpareBuffer handle_)
    case buffer_mode of
       (NoBuffering, _) -> do
            hPutChars handle str        -- v. slow, but we don't care
       (LineBuffering, buf) -> do
            writeLines handle buf str
       (BlockBuffering _, buf) -> do
            writeBlocks handle buf str


getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
getSpareBuffer Handle__{haBuffer=ref, 
                        haBuffers=spare_ref,
                        haBufferMode=mode}
 = do
   case mode of
     NoBuffering -> return (mode, error "no buffer!")
     _ -> do
          bufs <- readIORef spare_ref
          buf  <- readIORef ref
          case bufs of
            BufferListCons b rest -> do
                writeIORef spare_ref rest
                return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
            BufferListNil -> do
                new_buf <- allocateBuffer (bufSize buf) WriteBuffer
                return (mode, new_buf)


writeLines :: Handle -> Buffer -> String -> IO ()
writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
  let
   shoveString :: Int -> [Char] -> IO ()
        -- check n == len first, to ensure that shoveString is strict in n.
   shoveString n cs | n == len = do
        new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
        writeLines hdl new_buf cs
   shoveString n [] = do
        commitBuffer hdl raw len n False{-no flush-} True{-release-}
        return ()
   shoveString n (c:cs) = do
        n' <- writeCharIntoBuffer raw n c
        if (c == '\n') 
         then do 
              new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
              writeLines hdl new_buf cs
         else 
              shoveString n' cs
  in
  shoveString 0 s

writeBlocks :: Handle -> Buffer -> String -> IO ()
writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
  let
   shoveString :: Int -> [Char] -> IO ()
        -- check n == len first, to ensure that shoveString is strict in n.
   shoveString n cs | n == len = do
        new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
        writeBlocks hdl new_buf cs
   shoveString n [] = do
        commitBuffer hdl raw len n False{-no flush-} True{-release-}
        return ()
   shoveString n (c:cs) = do
        n' <- writeCharIntoBuffer raw n c
        shoveString n' cs
  in
  shoveString 0 s

-- -----------------------------------------------------------------------------
-- commitBuffer handle buf sz count flush release
-- 
-- Write the contents of the buffer 'buf' ('sz' bytes long, containing
-- 'count' bytes of data) to handle (handle must be block or line buffered).
-- 
-- Implementation:
-- 
--    for block/line buffering,
--       1. If there isn't room in the handle buffer, flush the handle
--          buffer.
-- 
--       2. If the handle buffer is empty,
--               if flush, 
--                   then write buf directly to the device.
--                   else swap the handle buffer with buf.
-- 
--       3. If the handle buffer is non-empty, copy buf into the
--          handle buffer.  Then, if flush != 0, flush
--          the buffer.

commitBuffer
        :: Handle                       -- handle to commit to
        -> RawBuffer -> Int             -- address and size (in bytes) of buffer
        -> Int                          -- number of bytes of data in buffer
        -> Bool                         -- True <=> flush the handle afterward
        -> Bool                         -- release the buffer?
        -> IO Buffer

commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
  wantWritableHandle "commitAndReleaseBuffer" hdl $
     commitBuffer' raw sz count flush release

-- Explicitly lambda-lift this function to subvert GHC's full laziness
-- optimisations, which otherwise tends to float out subexpressions
-- past the \handle, which is really a pessimisation in this case because
-- that lambda is a one-shot lambda.
--
-- Don't forget to export the function, to stop it being inlined too
-- (this appears to be better than NOINLINE, because the strictness
-- analyser still gets to worker-wrapper it).
--
-- This hack is a fairly big win for hPutStr performance.  --SDM 18/9/2001
--
commitBuffer' :: RawBuffer -> Int -> Int -> Bool -> Bool -> Handle__
              -> IO Buffer
commitBuffer' raw sz@(I# _) count@(I# _) flush release
  handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do

#ifdef DEBUG_DUMP
      puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
            ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
#endif

      old_buf@Buffer{ bufBuf=old_raw, bufWPtr=w, bufSize=size }
          <- readIORef ref

      buf_ret <-
        -- enough room in handle buffer?
         if (not flush && (size - w > count))
                -- The > is to be sure that we never exactly fill
                -- up the buffer, which would require a flush.  So
                -- if copying the new data into the buffer would
                -- make the buffer full, we just flush the existing
                -- buffer and the new data immediately, rather than
                -- copying before flushing.

                -- not flushing, and there's enough room in the buffer:
                -- just copy the data in and update bufWPtr.
            then do memcpy_baoff_ba old_raw (fromIntegral w) raw (fromIntegral count)
                    writeIORef ref old_buf{ bufWPtr = w + count }
                    return (newEmptyBuffer raw WriteBuffer sz)

                -- else, we have to flush
            else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf

                    let this_buf = 
                            Buffer{ bufBuf=raw, bufState=WriteBuffer, 
                                    bufRPtr=0, bufWPtr=count, bufSize=sz }

                        -- if:  (a) we don't have to flush, and
                        --      (b) size(new buffer) == size(old buffer), and
                        --      (c) new buffer is not full,
                        -- we can just just swap them over...
                    if (not flush && sz == size && count /= sz)
                        then do 
                          writeIORef ref this_buf
                          return flushed_buf                         

                        -- otherwise, we have to flush the new data too,
                        -- and start with a fresh buffer
                        else do
                          flushWriteBuffer fd (haIsStream handle_) this_buf
                          writeIORef ref flushed_buf
                            -- if the sizes were different, then allocate
                            -- a new buffer of the correct size.
                          if sz == size
                             then return (newEmptyBuffer raw WriteBuffer sz)
                             else allocateBuffer size WriteBuffer

      -- release the buffer if necessary
      case buf_ret of
        Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
          if release && buf_ret_sz == size
            then do
              spare_bufs <- readIORef spare_buf_ref
              writeIORef spare_buf_ref 
                (BufferListCons buf_ret_raw spare_bufs)
              return buf_ret
            else
              return buf_ret

-- ---------------------------------------------------------------------------
-- Reading/writing sequences of bytes.

-- ---------------------------------------------------------------------------
-- hPutBuf

-- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the
-- buffer @buf@ to the handle @hdl@.  It returns ().
--
-- This operation may fail with:
--
--  * 'ResourceVanished' if the handle is a pipe or socket, and the
--    reading end is closed.  (If this is a POSIX system, and the program
--    has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered
--    instead, whose default action is to terminate the program).

hPutBuf :: Handle                       -- handle to write to
        -> Ptr a                        -- address of buffer
        -> Int                          -- number of bytes of data in buffer
        -> IO ()
hPutBuf h ptr count = do hPutBuf' h ptr count True; return ()

hPutBufNonBlocking
        :: Handle                       -- handle to write to
        -> Ptr a                        -- address of buffer
        -> Int                          -- number of bytes of data in buffer
        -> IO Int                       -- returns: number of bytes written
hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False

hPutBuf':: Handle                       -- handle to write to
        -> Ptr a                        -- address of buffer
        -> Int                          -- number of bytes of data in buffer
        -> Bool                         -- allow blocking?
        -> IO Int
hPutBuf' handle ptr count can_block
  | count == 0 = return 0
  | count <  0 = illegalBufferSize handle "hPutBuf" count
  | otherwise = 
    wantWritableHandle "hPutBuf" handle $ 
      \ Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> 
          bufWrite fd ref is_stream ptr count can_block

bufWrite :: FD -> IORef Buffer -> Bool -> Ptr a -> Int -> Bool -> IO Int
bufWrite fd ref is_stream ptr count can_block =
  seq count $ seq fd $ do  -- strictness hack
  old_buf@Buffer{ bufBuf=old_raw, bufWPtr=w, bufSize=size }
     <- readIORef ref

  -- enough room in handle buffer?
  if (size - w > count)
        -- There's enough room in the buffer:
        -- just copy the data in and update bufWPtr.
        then do memcpy_baoff_ptr old_raw (fromIntegral w) ptr (fromIntegral count)
                writeIORef ref old_buf{ bufWPtr = w + count }
                return count

        -- else, we have to flush
        else do flushed_buf <- flushWriteBuffer fd is_stream old_buf
                        -- TODO: we should do a non-blocking flush here
                writeIORef ref flushed_buf
                -- if we can fit in the buffer, then just loop  
                if count < size
                   then bufWrite fd ref is_stream ptr count can_block
                   else if can_block
                           then do writeChunk fd is_stream (castPtr ptr) count
                                   return count
                           else writeChunkNonBlocking fd is_stream ptr count

writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO ()
writeChunk fd is_stream ptr bytes0 = loop 0 bytes0
 where
  loop :: Int -> Int -> IO ()
  loop _   bytes | bytes <= 0 = return ()
  loop off bytes = do
    r <- fromIntegral `liftM`
           writeRawBufferPtr "writeChunk" fd is_stream ptr
                             off (fromIntegral bytes)
    -- write can't return 0
    loop (off + r) (bytes - r)

writeChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
writeChunkNonBlocking fd
#ifndef mingw32_HOST_OS
                         _
#else
                         is_stream
#endif
                                   ptr bytes0 = loop 0 bytes0
 where
  loop :: Int -> Int -> IO Int
  loop off bytes | bytes <= 0 = return off
  loop off bytes = do
#ifndef mingw32_HOST_OS
    ssize <- c_write fd (ptr `plusPtr` off) (fromIntegral bytes)
    let r = fromIntegral ssize :: Int
    if (r == -1)
      then do errno <- getErrno
              if (errno == eAGAIN || errno == eWOULDBLOCK)
                 then return off
                 else throwErrno "writeChunk"
      else loop (off + r) (bytes - r)
#else
    (ssize, rc) <- asyncWrite (fromIntegral fd)
                              (fromIntegral $ fromEnum is_stream)
                                 (fromIntegral bytes)
                                 (ptr `plusPtr` off)
    let r = fromIntegral ssize :: Int
    if r == (-1)
      then ioError (errnoToIOError "hPutBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing)
      else loop (off + r) (bytes - r)
#endif

-- ---------------------------------------------------------------------------
-- hGetBuf

-- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@
-- into the buffer @buf@ until either EOF is reached or
-- @count@ 8-bit bytes have been read.
-- It returns the number of bytes actually read.  This may be zero if
-- EOF was reached before any data was read (or if @count@ is zero).
--
-- 'hGetBuf' never raises an EOF exception, instead it returns a value
-- smaller than @count@.
--
-- If the handle is a pipe or socket, and the writing end
-- is closed, 'hGetBuf' will behave as if EOF was reached.

hGetBuf :: Handle -> Ptr a -> Int -> IO Int
hGetBuf h ptr count
  | count == 0 = return 0
  | count <  0 = illegalBufferSize h "hGetBuf" count
  | otherwise = 
      wantReadableHandle "hGetBuf" h $ 
        \ Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
            bufRead fd ref is_stream ptr 0 count

-- small reads go through the buffer, large reads are satisfied by
-- taking data first from the buffer and then direct from the file
-- descriptor.
bufRead :: FD -> IORef Buffer -> Bool -> Ptr a -> Int -> Int -> IO Int
bufRead fd ref is_stream ptr so_far count =
  seq fd $ seq so_far $ seq count $ do -- strictness hack
  buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
  if bufferEmpty buf
     then if count > sz  -- small read?
                then do rest <- readChunk fd is_stream ptr count
                        return (so_far + rest)
                else do mb_buf <- maybeFillReadBuffer fd True is_stream buf
                        case mb_buf of
                          Nothing -> return so_far -- got nothing, we're done
                          Just buf' -> do
                                writeIORef ref buf'
                                bufRead fd ref is_stream ptr so_far count
     else do 
        let avail = w - r
        if (count == avail)
           then do 
                memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)
                writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
                return (so_far + count)
           else do
        if (count < avail)
           then do 
                memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)
                writeIORef ref buf{ bufRPtr = r + count }
                return (so_far + count)
           else do
  
        memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral avail)
        writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
        let remaining = count - avail
            so_far' = so_far + avail
            ptr' = ptr `plusPtr` avail

        if remaining < sz
           then bufRead fd ref is_stream ptr' so_far' remaining
           else do 

        rest <- readChunk fd is_stream ptr' remaining
        return (so_far' + rest)

readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int
readChunk fd is_stream ptr bytes0 = loop 0 bytes0
 where
  loop :: Int -> Int -> IO Int
  loop off bytes | bytes <= 0 = return off
  loop off bytes = do
    r <- fromIntegral `liftM`
           readRawBufferPtr "readChunk" fd is_stream 
                            (castPtr ptr) off (fromIntegral bytes)
    if r == 0
        then return off
        else loop (off + r) (bytes - r)


-- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@
-- into the buffer @buf@ until either EOF is reached, or
-- @count@ 8-bit bytes have been read, or there is no more data available
-- to read immediately.
--
-- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will
-- never block waiting for data to become available, instead it returns
-- only whatever data is available.  To wait for data to arrive before
-- calling 'hGetBufNonBlocking', use 'hWaitForInput'.
--
-- If the handle is a pipe or socket, and the writing end
-- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.
--
hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
hGetBufNonBlocking h ptr count
  | count == 0 = return 0
  | count <  0 = illegalBufferSize h "hGetBufNonBlocking" count
  | otherwise = 
      wantReadableHandle "hGetBufNonBlocking" h $ 
        \ Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
            bufReadNonBlocking fd ref is_stream ptr 0 count

bufReadNonBlocking :: FD -> IORef Buffer -> Bool -> Ptr a -> Int -> Int
                   -> IO Int
bufReadNonBlocking fd ref is_stream ptr so_far count =
  seq fd $ seq so_far $ seq count $ do -- strictness hack
  buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
  if bufferEmpty buf
     then if count > sz  -- large read?
                then do rest <- readChunkNonBlocking fd is_stream ptr count
                        return (so_far + rest)
                else do buf' <- fillReadBufferWithoutBlocking fd is_stream buf
                        case buf' of { Buffer{ bufWPtr=w' }  ->
                        if (w' == 0) 
                           then return so_far
                           else do writeIORef ref buf'
                                   bufReadNonBlocking fd ref is_stream ptr
                                         so_far (min count w')
                                  -- NOTE: new count is    min count w'
                                  -- so we will just copy the contents of the
                                  -- buffer in the recursive call, and not
                                  -- loop again.
                        }
     else do
        let avail = w - r
        if (count == avail)
           then do 
                memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)
                writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
                return (so_far + count)
           else do
        if (count < avail)
           then do 
                memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)
                writeIORef ref buf{ bufRPtr = r + count }
                return (so_far + count)
           else do

        memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral avail)
        writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
        let remaining = count - avail
            so_far' = so_far + avail
            ptr' = ptr `plusPtr` avail

        -- we haven't attempted to read anything yet if we get to here.
        if remaining < sz
           then bufReadNonBlocking fd ref is_stream ptr' so_far' remaining
           else do 

        rest <- readChunkNonBlocking fd is_stream ptr' remaining
        return (so_far' + rest)


readChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
readChunkNonBlocking fd is_stream ptr bytes = do
    fromIntegral `liftM`
        readRawBufferPtrNoBlock "readChunkNonBlocking" fd is_stream 
                            (castPtr ptr) 0 (fromIntegral bytes)

    -- we don't have non-blocking read support on Windows, so just invoke
    -- the ordinary low-level read which will block until data is available,
    -- but won't wait for the whole buffer to fill.

slurpFile :: FilePath -> IO (Ptr (), Int)
slurpFile fname = do
  handle <- openFile fname ReadMode
  sz     <- hFileSize handle
  if sz > fromIntegral (maxBound::Int) then 
    ioError (userError "slurpFile: file too big")
   else do
    let sz_i = fromIntegral sz
    if sz_i == 0 then return (nullPtr, 0) else do
    chunk <- mallocBytes sz_i
    r <- hGetBuf handle chunk sz_i
    hClose handle
    return (chunk, r)

-- ---------------------------------------------------------------------------
-- memcpy wrappers

foreign import ccall unsafe "__hscore_memcpy_src_off"
   memcpy_ba_baoff :: RawBuffer -> RawBuffer -> CInt -> CSize -> IO (Ptr ())
foreign import ccall unsafe "__hscore_memcpy_src_off"
   memcpy_ptr_baoff :: Ptr a -> RawBuffer -> CInt -> CSize -> IO (Ptr ())
foreign import ccall unsafe "__hscore_memcpy_dst_off"
   memcpy_baoff_ba :: RawBuffer -> CInt -> RawBuffer -> CSize -> IO (Ptr ())
foreign import ccall unsafe "__hscore_memcpy_dst_off"
   memcpy_baoff_ptr :: RawBuffer -> CInt -> Ptr a -> CSize -> IO (Ptr ())

-----------------------------------------------------------------------------
-- Internal Utils

illegalBufferSize :: Handle -> String -> Int -> IO a
illegalBufferSize handle fn sz =
        ioException (IOError (Just handle)
                            InvalidArgument  fn
                            ("illegal buffer size " ++ showsPrec 9 sz [])
                            Nothing)