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