GHC/IO.hs

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