GHC/IO.hsc

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