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