GHC/IO.hs

   1 {-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-}
   2
   3 #undef DEBUG_DUMP
   4
   5 -----------------------------------------------------------------------------
   6 -- |
   7 -- Module      :  GHC.IO
   8 -- Copyright   :  (c) The University of Glasgow, 1992-2001
   9 -- License     :  see libraries/base/LICENSE
  10 --
  11 -- Maintainer  :  libraries@haskell.org
  12 -- Stability   :  internal
  13 -- Portability :  non-portable
  14 --
  15 -- String I\/O functions
  16 --
  17 -----------------------------------------------------------------------------
  18
  19 module GHC.IO (
  20    hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
  21    commitBuffer',       -- hack, see below
  22    hGetcBuffered,       -- needed by ghc/compiler/utils/StringBuffer.lhs
  23    hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, slurpFile,
  24    createPipe, createPipeEx,
  25    memcpy_ba_baoff,
  26    memcpy_ptr_baoff,
  27    memcpy_baoff_ba,
  28    memcpy_baoff_ptr,
  29  ) where
  30
  31 #include "config.h"
  32
  33 import Foreign
  34 import Foreign.C
  35
  36 import System.IO.Error
  37 import Data.Maybe
  38 import Control.Monad
  39 import System.Posix.Internals
  40
  41 import GHC.Enum
  42 import GHC.Base
  43 import GHC.IOBase
  44 import GHC.Handle       -- much of the real stuff is in here
  45 import GHC.Real
  46 import GHC.Num
  47 import GHC.Show
  48 import GHC.List
  49 import GHC.Exception    ( ioError, catch )
  50 import GHC.Conc
  51
  52 -- ---------------------------------------------------------------------------
  53 -- Simple input operations
  54
  55 -- If hWaitForInput finds anything in the Handle's buffer, it
  56 -- immediately returns.  If not, it tries to read from the underlying
  57 -- OS handle. Notice that for buffered Handles connected to terminals
  58 -- this means waiting until a complete line is available.
  59
  60 -- | Computation 'hWaitForInput' @hdl t@
  61 -- waits until input is available on handle @hdl@.
  62 -- It returns 'True' as soon as input is available on @hdl@,
  63 -- or 'False' if no input is available within @t@ milliseconds.
  64 --
  65 -- This operation may fail with:
  66 --
  67 --  * 'isEOFError' if the end of file has been reached.
  68
  69 hWaitForInput :: Handle -> Int -> IO Bool
  70 hWaitForInput h msecs = do
  71   wantReadableHandle "hWaitForInput" h $ \ handle_ -> do
  72   let ref = haBuffer handle_
  73   buf <- readIORef ref
  74
  75   if not (bufferEmpty buf)
  76         then return True
  77         else do
  78
  79   r <- throwErrnoIfMinus1Retry "hWaitForInput"
  80           (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs) (haIsStream handle_))
  81   return (r /= 0)
  82
  83 foreign import ccall unsafe "inputReady"
  84   inputReady :: CInt -> CInt -> Bool -> IO CInt
  85
  86 -- ---------------------------------------------------------------------------
  87 -- hGetChar
  88
  89 -- | Computation 'hGetChar' @hdl@ reads a character from the file or
  90 -- channel managed by @hdl@, blocking until a character is available.
  91 --
  92 -- This operation may fail with:
  93 --
  94 --  * 'isEOFError' if the end of file has been reached.
  95
  96 hGetChar :: Handle -> IO Char
  97 hGetChar handle =
  98   wantReadableHandle "hGetChar" handle $ \handle_ -> do
  99
 100   let fd = haFD handle_
 101       ref = haBuffer handle_
 102
 103   buf <- readIORef ref
 104   if not (bufferEmpty buf)
 105         then hGetcBuffered fd ref buf
 106         else do
 107
 108   -- buffer is empty.
 109   case haBufferMode handle_ of
 110     LineBuffering    -> do
 111         new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
 112         hGetcBuffered fd ref new_buf
 113     BlockBuffering _ -> do
 114         new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
 115                 --                   ^^^^
 116                 -- don't wait for a completely full buffer.
 117         hGetcBuffered fd ref new_buf
 118     NoBuffering -> do
 119         -- make use of the minimal buffer we already have
 120         let raw = bufBuf buf
 121         r <- readRawBuffer "hGetChar" (fromIntegral fd) (haIsStream handle_) raw 0 1
 122         if r == 0
 123            then ioe_EOF
 124            else do (c,_) <- readCharFromBuffer raw 0
 125                    return c
 126
 127 hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
 128  = do (c,r) <- readCharFromBuffer b r
 129       let new_buf | r == w    = buf{ bufRPtr=0, bufWPtr=0 }
 130                   | otherwise = buf{ bufRPtr=r }
 131       writeIORef ref new_buf
 132       return c
 133
 134 -- ---------------------------------------------------------------------------
 135 -- hGetLine
 136
 137 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
 138 -- the duration.
 139
 140 -- | Computation 'hGetLine' @hdl@ reads a line from the file or
 141 -- channel managed by @hdl@.
 142 --
 143 -- This operation may fail with:
 144 --
 145 --  * 'isEOFError' if the end of file is encountered when reading
 146 --    the /first/ character of the line.
 147 --
 148 -- If 'hGetLine' encounters end-of-file at any other point while reading
 149 -- in a line, it is treated as a line terminator and the (partial)
 150 -- line is returned.
 151
 152 hGetLine :: Handle -> IO String
 153 hGetLine h = do
 154   m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
 155         case haBufferMode handle_ of
 156            NoBuffering      -> return Nothing
 157            LineBuffering    -> do
 158               l <- hGetLineBuffered handle_
 159               return (Just l)
 160            BlockBuffering _ -> do
 161               l <- hGetLineBuffered handle_
 162               return (Just l)
 163   case m of
 164         Nothing -> hGetLineUnBuffered h
 165         Just l  -> return l
 166
 167
 168 hGetLineBuffered handle_ = do
 169   let ref = haBuffer handle_
 170   buf <- readIORef ref
 171   hGetLineBufferedLoop handle_ ref buf []
 172
 173
 174 hGetLineBufferedLoop handle_ ref
 175         buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
 176   let
 177         -- find the end-of-line character, if there is one
 178         loop raw r
 179            | r == w = return (False, w)
 180            | otherwise =  do
 181                 (c,r') <- readCharFromBuffer raw r
 182                 if c == '\n'
 183                    then return (True, r) -- NB. not r': don't include the '\n'
 184                    else loop raw r'
 185   in do
 186   (eol, off) <- loop raw r
 187
 188 #ifdef DEBUG_DUMP
 189   puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
 190 #endif
 191
 192   xs <- unpack raw r off
 193
 194   -- if eol == True, then off is the offset of the '\n'
 195   -- otherwise off == w and the buffer is now empty.
 196   if eol
 197         then do if (w == off + 1)
 198                         then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
 199                         else writeIORef ref buf{ bufRPtr = off + 1 }
 200                 return (concat (reverse (xs:xss)))
 201         else do
 202              maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
 203                                 buf{ bufWPtr=0, bufRPtr=0 }
 204              case maybe_buf of
 205                 -- Nothing indicates we caught an EOF, and we may have a
 206                 -- partial line to return.
 207                 Nothing -> do
 208                      writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
 209                      let str = concat (reverse (xs:xss))
 210                      if not (null str)
 211                         then return str
 212                         else ioe_EOF
 213                 Just new_buf ->
 214                      hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
 215
 216
 217 maybeFillReadBuffer fd is_line is_stream buf
 218   = catch
 219      (do buf <- fillReadBuffer fd is_line is_stream buf
 220          return (Just buf)
 221      )
 222      (\e -> do if isEOFError e
 223                   then return Nothing
 224                   else ioError e)
 225
 226
 227 unpack :: RawBuffer -> Int -> Int -> IO [Char]
 228 unpack buf r 0   = return ""
 229 unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s
 230    where
 231     unpack acc i s
 232      | i <# r  = (# s, acc #)
 233      | otherwise =
 234           case readCharArray# buf i s of
 235             (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
 236
 237
 238 hGetLineUnBuffered :: Handle -> IO String
 239 hGetLineUnBuffered h = do
 240   c <- hGetChar h
 241   if c == '\n' then
 242      return ""
 243    else do
 244     l <- getRest
 245     return (c:l)
 246  where
 247   getRest = do
 248     c <-
 249       catch
 250         (hGetChar h)
 251         (\ err -> do
 252           if isEOFError err then
 253              return '\n'
 254            else
 255              ioError err)
 256     if c == '\n' then
 257        return ""
 258      else do
 259        s <- getRest
 260        return (c:s)
 261
 262 -- -----------------------------------------------------------------------------
 263 -- hGetContents
 264
 265 -- hGetContents on a DuplexHandle only affects the read side: you can
 266 -- carry on writing to it afterwards.
 267
 268 -- | Computation 'hGetContents' @hdl@ returns the list of characters
 269 -- corresponding to the unread portion of the channel or file managed
 270 -- by @hdl@, which is put into an intermediate state, /semi-closed/.
 271 -- In this state, @hdl@ is effectively closed,
 272 -- but items are read from @hdl@ on demand and accumulated in a special
 273 -- list returned by 'hGetContents' @hdl@.
 274 --
 275 -- Any operation that fails because a handle is closed,
 276 -- also fails if a handle is semi-closed.  The only exception is 'hClose'.
 277 -- A semi-closed handle becomes closed:
 278 --
 279 --  * if 'hClose' is applied to it;
 280 --
 281 --  * if an I\/O error occurs when reading an item from the handle;
 282 --
 283 --  * or once the entire contents of the handle has been read.
 284 --
 285 -- Once a semi-closed handle becomes closed, the contents of the
 286 -- associated list becomes fixed.  The contents of this final list is
 287 -- only partially specified: it will contain at least all the items of
 288 -- the stream that were evaluated prior to the handle becoming closed.
 289 --
 290 -- Any I\/O errors encountered while a handle is semi-closed are simply
 291 -- discarded.
 292 --
 293 -- This operation may fail with:
 294 --
 295 --  * 'isEOFError' if the end of file has been reached.
 296
 297 hGetContents :: Handle -> IO String
 298 hGetContents handle =
 299     withHandle "hGetContents" handle $ \handle_ ->
 300     case haType handle_ of
 301       ClosedHandle         -> ioe_closedHandle
 302       SemiClosedHandle     -> ioe_closedHandle
 303       AppendHandle         -> ioe_notReadable
 304       WriteHandle          -> ioe_notReadable
 305       _ -> do xs <- lazyRead handle
 306               return (handle_{ haType=SemiClosedHandle}, xs )
 307
 308 -- Note that someone may close the semi-closed handle (or change its
 309 -- buffering), so each time these lazy read functions are pulled on,
 310 -- they have to check whether the handle has indeed been closed.
 311
 312 lazyRead :: Handle -> IO String
 313 lazyRead handle =
 314    unsafeInterleaveIO $
 315         withHandle "lazyRead" handle $ \ handle_ -> do
 316         case haType handle_ of
 317           ClosedHandle     -> return (handle_, "")
 318           SemiClosedHandle -> lazyRead' handle handle_
 319           _ -> ioException
 320                   (IOError (Just handle) IllegalOperation "lazyRead"
 321                         "illegal handle type" Nothing)
 322
 323 lazyRead' h handle_ = do
 324   let ref = haBuffer handle_
 325       fd  = haFD handle_
 326
 327   -- even a NoBuffering handle can have a char in the buffer...
 328   -- (see hLookAhead)
 329   buf <- readIORef ref
 330   if not (bufferEmpty buf)
 331         then lazyReadHaveBuffer h handle_ fd ref buf
 332         else do
 333
 334   case haBufferMode handle_ of
 335      NoBuffering      -> do
 336         -- make use of the minimal buffer we already have
 337         let raw = bufBuf buf
 338         r <- readRawBuffer "lazyRead" (fromIntegral fd) (haIsStream handle_) raw 0 1
 339         if r == 0
 340            then do handle_ <- hClose_help handle_
 341                    return (handle_, "")
 342            else do (c,_) <- readCharFromBuffer raw 0
 343                    rest <- lazyRead h
 344                    return (handle_, c : rest)
 345
 346      LineBuffering    -> lazyReadBuffered h handle_ fd ref buf
 347      BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
 348
 349 -- we never want to block during the read, so we call fillReadBuffer with
 350 -- is_line==True, which tells it to "just read what there is".
 351 lazyReadBuffered h handle_ fd ref buf = do
 352    catch
 353         (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
 354             lazyReadHaveBuffer h handle_ fd ref buf
 355         )
 356         -- all I/O errors are discarded.  Additionally, we close the handle.
 357         (\e -> do handle_ <- hClose_help handle_
 358                   return (handle_, "")
 359         )
 360
 361 lazyReadHaveBuffer h handle_ fd ref buf = do
 362    more <- lazyRead h
 363    writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
 364    s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
 365    return (handle_, s)
 366
 367
 368 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
 369 unpackAcc buf r 0 acc  = return acc
 370 unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
 371    where
 372     unpack acc i s
 373      | i <# r  = (# s, acc #)
 374      | otherwise =
 375           case readCharArray# buf i s of
 376             (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
 377
 378 -- ---------------------------------------------------------------------------
 379 -- hPutChar
 380
 381 -- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the
 382 -- file or channel managed by @hdl@.  Characters may be buffered if
 383 -- buffering is enabled for @hdl@.
 384 --
 385 -- This operation may fail with:
 386 --
 387 --  * 'isFullError' if the device is full; or
 388 --
 389 --  * 'isPermissionError' if another system resource limit would be exceeded.
 390
 391 hPutChar :: Handle -> Char -> IO ()
 392 hPutChar handle c =
 393     c `seq` do   -- must evaluate c before grabbing the handle lock
 394     wantWritableHandle "hPutChar" handle $ \ handle_  -> do
 395     let fd = haFD handle_
 396     case haBufferMode handle_ of
 397         LineBuffering    -> hPutcBuffered handle_ True  c
 398         BlockBuffering _ -> hPutcBuffered handle_ False c
 399         NoBuffering      ->
 400                 withObject (castCharToCChar c) $ \buf -> do
 401                   writeRawBufferPtr "hPutChar" (fromIntegral fd) (haIsStream handle_) buf 0 1
 402                   return ()
 403
 404 hPutcBuffered handle_ is_line c = do
 405   let ref = haBuffer handle_
 406   buf <- readIORef ref
 407   let w = bufWPtr buf
 408   w'  <- writeCharIntoBuffer (bufBuf buf) w c
 409   let new_buf = buf{ bufWPtr = w' }
 410   if bufferFull new_buf || is_line && c == '\n'
 411      then do
 412         flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf
 413         writeIORef ref flushed_buf
 414      else do
 415         writeIORef ref new_buf
 416
 417
 418 hPutChars :: Handle -> [Char] -> IO ()
 419 hPutChars handle [] = return ()
 420 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
 421
 422 -- ---------------------------------------------------------------------------
 423 -- hPutStr
 424
 425 -- We go to some trouble to avoid keeping the handle locked while we're
 426 -- evaluating the string argument to hPutStr, in case doing so triggers another
 427 -- I/O operation on the same handle which would lead to deadlock.  The classic
 428 -- case is
 429 --
 430 --              putStr (trace "hello" "world")
 431 --
 432 -- so the basic scheme is this:
 433 --
 434 --      * copy the string into a fresh buffer,
 435 --      * "commit" the buffer to the handle.
 436 --
 437 -- Committing may involve simply copying the contents of the new
 438 -- buffer into the handle's buffer, flushing one or both buffers, or
 439 -- maybe just swapping the buffers over (if the handle's buffer was
 440 -- empty).  See commitBuffer below.
 441
 442 -- | Computation 'hPutStr' @hdl s@ writes the string
 443 -- @s@ to the file or channel managed by @hdl@.
 444 --
 445 -- This operation may fail with:
 446 --
 447 --  * 'isFullError' if the device is full; or
 448 --
 449 --  * 'isPermissionError' if another system resource limit would be exceeded.
 450
 451 hPutStr :: Handle -> String -> IO ()
 452 hPutStr handle str = do
 453     buffer_mode <- wantWritableHandle "hPutStr" handle
 454                         (\ handle_ -> do getSpareBuffer handle_)
 455     case buffer_mode of
 456        (NoBuffering, _) -> do
 457             hPutChars handle str        -- v. slow, but we don't care
 458        (LineBuffering, buf) -> do
 459             writeLines handle buf str
 460        (BlockBuffering _, buf) -> do
 461             writeBlocks handle buf str
 462
 463
 464 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
 465 getSpareBuffer Handle__{haBuffer=ref,
 466                         haBuffers=spare_ref,
 467                         haBufferMode=mode}
 468  = do
 469    case mode of
 470      NoBuffering -> return (mode, error "no buffer!")
 471      _ -> do
 472           bufs <- readIORef spare_ref
 473           buf  <- readIORef ref
 474           case bufs of
 475             BufferListCons b rest -> do
 476                 writeIORef spare_ref rest
 477                 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
 478             BufferListNil -> do
 479                 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
 480                 return (mode, new_buf)
 481
 482
 483 writeLines :: Handle -> Buffer -> String -> IO ()
 484 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
 485   let
 486    shoveString :: Int -> [Char] -> IO ()
 487         -- check n == len first, to ensure that shoveString is strict in n.
 488    shoveString n cs | n == len = do
 489         new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
 490         writeLines hdl new_buf cs
 491    shoveString n [] = do
 492         commitBuffer hdl raw len n False{-no flush-} True{-release-}
 493         return ()
 494    shoveString n (c:cs) = do
 495         n' <- writeCharIntoBuffer raw n c
 496         if (c == '\n')
 497          then do
 498               new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
 499               writeLines hdl new_buf cs
 500          else
 501               shoveString n' cs
 502   in
 503   shoveString 0 s
 504
 505 writeBlocks :: Handle -> Buffer -> String -> IO ()
 506 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
 507   let
 508    shoveString :: Int -> [Char] -> IO ()
 509         -- check n == len first, to ensure that shoveString is strict in n.
 510    shoveString n cs | n == len = do
 511         new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
 512         writeBlocks hdl new_buf cs
 513    shoveString n [] = do
 514         commitBuffer hdl raw len n False{-no flush-} True{-release-}
 515         return ()
 516    shoveString n (c:cs) = do
 517         n' <- writeCharIntoBuffer raw n c
 518         shoveString n' cs
 519   in
 520   shoveString 0 s
 521
 522 -- -----------------------------------------------------------------------------
 523 -- commitBuffer handle buf sz count flush release
 524 --
 525 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
 526 -- 'count' bytes of data) to handle (handle must be block or line buffered).
 527 --
 528 -- Implementation:
 529 --
 530 --    for block/line buffering,
 531 --       1. If there isn't room in the handle buffer, flush the handle
 532 --          buffer.
 533 --
 534 --       2. If the handle buffer is empty,
 535 --               if flush,
 536 --                   then write buf directly to the device.
 537 --                   else swap the handle buffer with buf.
 538 --
 539 --       3. If the handle buffer is non-empty, copy buf into the
 540 --          handle buffer.  Then, if flush != 0, flush
 541 --          the buffer.
 542
 543 commitBuffer
 544         :: Handle                       -- handle to commit to
 545         -> RawBuffer -> Int             -- address and size (in bytes) of buffer
 546         -> Int                          -- number of bytes of data in buffer
 547         -> Bool                         -- True <=> flush the handle afterward
 548         -> Bool                         -- release the buffer?
 549         -> IO Buffer
 550
 551 commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
 552   wantWritableHandle "commitAndReleaseBuffer" hdl $
 553      commitBuffer' hdl raw sz count flush release
 554
 555 -- Explicitly lambda-lift this function to subvert GHC's full laziness
 556 -- optimisations, which otherwise tends to float out subexpressions
 557 -- past the \handle, which is really a pessimisation in this case because
 558 -- that lambda is a one-shot lambda.
 559 --
 560 -- Don't forget to export the function, to stop it being inlined too
 561 -- (this appears to be better than NOINLINE, because the strictness
 562 -- analyser still gets to worker-wrapper it).
 563 --
 564 -- This hack is a fairly big win for hPutStr performance.  --SDM 18/9/2001
 565 --
 566 commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release
 567   handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
 568
 569 #ifdef DEBUG_DUMP
 570       puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
 571             ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
 572 #endif
 573
 574       old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
 575           <- readIORef ref
 576
 577       buf_ret <-
 578         -- enough room in handle buffer?
 579          if (not flush && (size - w > count))
 580                 -- The > is to be sure that we never exactly fill
 581                 -- up the buffer, which would require a flush.  So
 582                 -- if copying the new data into the buffer would
 583                 -- make the buffer full, we just flush the existing
 584                 -- buffer and the new data immediately, rather than
 585                 -- copying before flushing.
 586
 587                 -- not flushing, and there's enough room in the buffer:
 588                 -- just copy the data in and update bufWPtr.
 589             then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
 590                     writeIORef ref old_buf{ bufWPtr = w + count }
 591                     return (newEmptyBuffer raw WriteBuffer sz)
 592
 593                 -- else, we have to flush
 594             else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf
 595
 596                     let this_buf =
 597                             Buffer{ bufBuf=raw, bufState=WriteBuffer,
 598                                     bufRPtr=0, bufWPtr=count, bufSize=sz }
 599
 600                         -- if:  (a) we don't have to flush, and
 601                         --      (b) size(new buffer) == size(old buffer), and
 602                         --      (c) new buffer is not full,
 603                         -- we can just just swap them over...
 604                     if (not flush && sz == size && count /= sz)
 605                         then do
 606                           writeIORef ref this_buf
 607                           return flushed_buf
 608
 609                         -- otherwise, we have to flush the new data too,
 610                         -- and start with a fresh buffer
 611                         else do
 612                           flushWriteBuffer fd (haIsStream handle_) this_buf
 613                           writeIORef ref flushed_buf
 614                             -- if the sizes were different, then allocate
 615                             -- a new buffer of the correct size.
 616                           if sz == size
 617                              then return (newEmptyBuffer raw WriteBuffer sz)
 618                              else allocateBuffer size WriteBuffer
 619
 620       -- release the buffer if necessary
 621       case buf_ret of
 622         Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
 623           if release && buf_ret_sz == size
 624             then do
 625               spare_bufs <- readIORef spare_buf_ref
 626               writeIORef spare_buf_ref
 627                 (BufferListCons buf_ret_raw spare_bufs)
 628               return buf_ret
 629             else
 630               return buf_ret
 631
 632 -- ---------------------------------------------------------------------------
 633 -- Reading/writing sequences of bytes.
 634
 635 -- ---------------------------------------------------------------------------
 636 -- hPutBuf
 637
 638 -- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the
 639 -- buffer @buf@ to the handle @hdl@.  It returns ().
 640 --
 641 -- This operation may fail with:
 642 --
 643 --  * 'ResourceVanished' if the handle is a pipe or socket, and the
 644 --    reading end is closed.  (If this is a POSIX system, and the program
 645 --    has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered
 646 --    instead, whose default action is to terminate the program).
 647
 648 hPutBuf :: Handle                       -- handle to write to
 649         -> Ptr a                        -- address of buffer
 650         -> Int                          -- number of bytes of data in buffer
 651         -> IO ()
 652 hPutBuf h ptr count = do hPutBuf' h ptr count True; return ()
 653
 654 hPutBufNonBlocking
 655         :: Handle                       -- handle to write to
 656         -> Ptr a                        -- address of buffer
 657         -> Int                          -- number of bytes of data in buffer
 658         -> IO Int                       -- returns: number of bytes written
 659 hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False
 660
 661 hPutBuf':: Handle                       -- handle to write to
 662         -> Ptr a                        -- address of buffer
 663         -> Int                          -- number of bytes of data in buffer
 664         -> Bool                         -- allow blocking?
 665         -> IO Int
 666 hPutBuf' handle ptr count can_block
 667   | count == 0 = return 0
 668   | count <  0 = illegalBufferSize handle "hPutBuf" count
 669   | otherwise =
 670     wantWritableHandle "hPutBuf" handle $
 671       \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } ->
 672           bufWrite fd ref is_stream ptr count can_block
 673
 674 bufWrite fd ref is_stream ptr count can_block =
 675   seq count $ seq fd $ do  -- strictness hack
 676   old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
 677      <- readIORef ref
 678
 679   -- enough room in handle buffer?
 680   if (size - w > count)
 681         -- There's enough room in the buffer:
 682         -- just copy the data in and update bufWPtr.
 683         then do memcpy_baoff_ptr old_raw w ptr (fromIntegral count)
 684                 writeIORef ref old_buf{ bufWPtr = w + count }
 685                 return count
 686
 687         -- else, we have to flush
 688         else do flushed_buf <- flushWriteBuffer fd is_stream old_buf
 689                 writeIORef ref flushed_buf
 690                 -- if we can fit in the buffer, then just loop
 691                 if count < size
 692                    then bufWrite fd ref is_stream ptr count can_block
 693                    else if can_block
 694                            then do writeChunk fd is_stream (castPtr ptr) count
 695                                    return count
 696                            else writeChunkNonBlocking fd ptr count
 697
 698 writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO ()
 699 writeChunk fd is_stream ptr bytes = loop 0 bytes
 700  where
 701   loop :: Int -> Int -> IO ()
 702   loop _   bytes | bytes <= 0 = return ()
 703   loop off bytes = do
 704     r <- fromIntegral `liftM`
 705            writeRawBufferPtr "writeChunk" (fromIntegral fd) is_stream ptr
 706                              off (fromIntegral bytes)
 707     -- write can't return 0
 708     loop (off + r) (bytes - r)
 709
 710 writeChunkNonBlocking :: FD -> Ptr a -> Int -> IO Int
 711 writeChunkNonBlocking fd ptr bytes = loop 0 bytes
 712  where
 713   loop :: Int -> Int -> IO Int
 714   loop off bytes | bytes <= 0 = return off
 715   loop off bytes = do
 716     ssize <- c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes)
 717     let r = fromIntegral ssize :: Int
 718     if (r == -1)
 719       then do errno <- getErrno
 720               if (errno == eAGAIN || errno == eWOULDBLOCK)
 721                  then return off
 722                  else throwErrno "writeChunk"
 723       else loop (off + r) (bytes - r)
 724
 725 -- ---------------------------------------------------------------------------
 726 -- hGetBuf
 727
 728 -- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@
 729 -- into the buffer @buf@ until either EOF is reached or
 730 -- @count@ 8-bit bytes have been read.
 731 -- It returns the number of bytes actually read.  This may be zero if
 732 -- EOF was reached before any data was read (or if @count@ is zero).
 733 --
 734 -- 'hGetBuf' never raises an EOF exception, instead it returns a value
 735 -- smaller than @count@.
 736 --
 737 -- If the handle is a pipe or socket, and the writing end
 738 -- is closed, 'hGetBuf' will behave as if EOF was reached.
 739
 740 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
 741 hGetBuf h ptr count = hGetBuf' h ptr count True
 742
 743 hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
 744 hGetBufNonBlocking h ptr count = hGetBuf' h ptr count False
 745
 746 hGetBuf' :: Handle -> Ptr a -> Int -> Bool -> IO Int
 747 hGetBuf' handle ptr count can_block
 748   | count == 0 = return 0
 749   | count <  0 = illegalBufferSize handle "hGetBuf" count
 750   | otherwise =
 751       wantReadableHandle "hGetBuf" handle $
 752         \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
 753             bufRead fd ref is_stream ptr 0 count can_block
 754
 755 bufRead fd ref is_stream ptr so_far count can_block =
 756   seq fd $ seq so_far $ seq count $ do -- strictness hack
 757   buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
 758   if bufferEmpty buf
 759      then if count < sz
 760                 then do
 761                    mb_buf <- maybeFillReadBuffer fd (not can_block) is_stream buf
 762                    case mb_buf of
 763                        Nothing -> return 0
 764                        Just new_buf -> do
 765                           writeIORef ref new_buf
 766                           bufRead fd ref is_stream ptr so_far count can_block
 767                 else if can_block
 768                         then readChunk fd is_stream ptr count
 769                         else readChunkNonBlocking fd is_stream ptr count
 770      else do
 771         let avail = w - r
 772         if (count == avail)
 773            then do
 774                 memcpy_ptr_baoff ptr raw r (fromIntegral count)
 775                 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
 776                 return (so_far + count)
 777            else do
 778         if (count < avail)
 779            then do
 780                 memcpy_ptr_baoff ptr raw r (fromIntegral count)
 781                 writeIORef ref buf{ bufRPtr = r + count }
 782                 return (so_far + count)
 783            else do
 784
 785         memcpy_ptr_baoff ptr raw r (fromIntegral avail)
 786         writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
 787
 788         let remaining = count - avail
 789             so_far' = so_far + avail
 790             ptr' = ptr `plusPtr` avail
 791
 792         if remaining < sz
 793            then bufRead fd ref is_stream ptr' so_far' remaining can_block
 794            else do
 795
 796         rest <- if can_block
 797                         then readChunk fd is_stream ptr' remaining
 798                         else readChunkNonBlocking fd is_stream ptr' remaining
 799         return (so_far' + rest)
 800
 801 readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int
 802 readChunk fd is_stream ptr bytes = loop 0 bytes
 803  where
 804   loop :: Int -> Int -> IO Int
 805   loop off bytes | bytes <= 0 = return off
 806   loop off bytes = do
 807     r <- fromIntegral `liftM`
 808            readRawBufferPtr "readChunk" (fromIntegral fd) is_stream
 809                             (castPtr ptr) off (fromIntegral bytes)
 810     if r == 0
 811         then return off
 812         else loop (off + r) (bytes - r)
 813
 814 readChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
 815 readChunkNonBlocking fd is_stream ptr bytes = loop 0 bytes
 816  where
 817   loop :: Int -> Int -> IO Int
 818   loop off bytes | bytes <= 0 = return off
 819   loop off bytes = do
 820     ssize <- c_read (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes)
 821     let r = fromIntegral ssize :: Int
 822     if (r == -1)
 823       then do errno <- getErrno
 824               if (errno == eAGAIN || errno == eWOULDBLOCK)
 825                  then return off
 826                  else throwErrno "readChunk"
 827       else if (r == 0)
 828                 then return off
 829                 else loop (off + r) (bytes - r)
 830
 831 slurpFile :: FilePath -> IO (Ptr (), Int)
 832 slurpFile fname = do
 833   handle <- openFile fname ReadMode
 834   sz     <- hFileSize handle
 835   if sz > fromIntegral (maxBound::Int) then
 836     ioError (userError "slurpFile: file too big")
 837    else do
 838     let sz_i = fromIntegral sz
 839     if sz_i == 0 then return (nullPtr, 0) else do
 840     chunk <- mallocBytes sz_i
 841     r <- hGetBuf handle chunk sz_i
 842     hClose handle
 843     return (chunk, r)
 844
 845 -- ---------------------------------------------------------------------------
 846 -- memcpy wrappers
 847
 848 foreign import ccall unsafe "__hscore_memcpy_src_off"
 849    memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
 850 foreign import ccall unsafe "__hscore_memcpy_src_off"
 851    memcpy_ptr_baoff :: Ptr a -> RawBuffer -> Int -> CSize -> IO (Ptr ())
 852 foreign import ccall unsafe "__hscore_memcpy_dst_off"
 853    memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
 854 foreign import ccall unsafe "__hscore_memcpy_dst_off"
 855    memcpy_baoff_ptr :: RawBuffer -> Int -> Ptr a -> CSize -> IO (Ptr ())
 856
 857 -----------------------------------------------------------------------------
 858 -- Internal Utils
 859
 860 illegalBufferSize :: Handle -> String -> Int -> IO a
 861 illegalBufferSize handle fn (sz :: Int) =
 862         ioException (IOError (Just handle)
 863                             InvalidArgument  fn
 864                             ("illegal buffer size " ++ showsPrec 9 sz [])
 865                             Nothing)