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