GHC/IO.hsc

   1 {-# OPTIONS -fno-implicit-prelude #-}
   2
   3 #undef DEBUG_DUMP
   4
   5 -- -----------------------------------------------------------------------------
   6 -- $Id: IO.hsc,v 1.1 2001/06/28 14:15:03 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 #include "GHC/Handle_hsc.h"
  21
  22 import Foreign
  23 import Foreign.C
  24
  25 import Data.Maybe
  26 import Control.Monad
  27
  28 import GHC.ByteArr
  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 "hReady" 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 "hReady"
  63           (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs))
  64   return (r /= 0)
  65
  66 foreign import "inputReady"
  67   inputReady :: CInt -> CInt -> 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 buf
  91         hGetcBuffered fd ref new_buf
  92     BlockBuffering _ -> do
  93         new_buf <- fillReadBuffer fd False 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 (fromIntegral fd) 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
 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 unpack :: RawBuffer -> Int -> Int -> IO [Char]
 183 unpack buf r 0   = return ""
 184 unpack buf (I## r) (I## len) = IO $ \s -> unpack [] (len -## 1##) s
 185    where
 186     unpack acc i s
 187      | i <## r  = (## s, acc ##)
 188      | otherwise =
 189           case readCharArray## buf i s of
 190             (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
 191
 192
 193 hGetLineUnBuffered :: Handle -> IO String
 194 hGetLineUnBuffered h = do
 195   c <- hGetChar h
 196   if c == '\n' then
 197      return ""
 198    else do
 199     l <- getRest
 200     return (c:l)
 201  where
 202   getRest = do
 203     c <-
 204       catch
 205         (hGetChar h)
 206         (\ err -> do
 207           if isEOFError err then
 208              return '\n'
 209            else
 210              ioError err)
 211     if c == '\n' then
 212        return ""
 213      else do
 214        s <- getRest
 215        return (c:s)
 216
 217 -- -----------------------------------------------------------------------------
 218 -- hGetContents
 219
 220 -- hGetContents returns the list of characters corresponding to the
 221 -- unread portion of the channel or file managed by the handle, which
 222 -- is made semi-closed.
 223
 224 -- hGetContents on a DuplexHandle only affects the read side: you can
 225 -- carry on writing to it afterwards.
 226
 227 hGetContents :: Handle -> IO String
 228 hGetContents handle@(DuplexHandle r w)
 229   = withHandle' "hGetContents" handle r (hGetContents' handle)
 230 hGetContents handle@(FileHandle m)
 231   = withHandle' "hGetContents" handle m (hGetContents' handle)
 232
 233 hGetContents' handle handle_ =
 234     case haType handle_ of
 235       ClosedHandle         -> ioe_closedHandle
 236       SemiClosedHandle     -> ioe_closedHandle
 237       AppendHandle         -> ioe_notReadable
 238       WriteHandle          -> ioe_notReadable
 239       _ -> do xs <- lazyRead handle
 240               return (handle_{ haType=SemiClosedHandle}, xs )
 241
 242 -- Note that someone may close the semi-closed handle (or change its
 243 -- buffering), so each time these lazy read functions are pulled on,
 244 -- they have to check whether the handle has indeed been closed.
 245
 246 lazyRead :: Handle -> IO String
 247 lazyRead handle =
 248    unsafeInterleaveIO $
 249         withHandle_ "lazyRead" handle $ \ handle_ -> do
 250         case haType handle_ of
 251           ClosedHandle     -> return ""
 252           SemiClosedHandle -> lazyRead' handle handle_
 253           _ -> ioException
 254                   (IOError (Just handle) IllegalOperation "lazyRead"
 255                         "illegal handle type" Nothing)
 256
 257 lazyRead' h handle_ = do
 258   let ref = haBuffer handle_
 259       fd  = haFD handle_
 260
 261   -- even a NoBuffering handle can have a char in the buffer...
 262   -- (see hLookAhead)
 263   buf <- readIORef ref
 264   if not (bufferEmpty buf)
 265         then lazyReadBuffered h fd ref buf
 266         else do
 267
 268   case haBufferMode handle_ of
 269      NoBuffering      -> do
 270         -- make use of the minimal buffer we already have
 271         let raw = bufBuf buf
 272             fd  = haFD handle_
 273         r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
 274                 (read_off (fromIntegral fd) raw 0 1)
 275                 (threadWaitRead fd)
 276         if r == 0
 277            then return ""
 278            else do (c,_) <- readCharFromBuffer raw 0
 279                    rest <- lazyRead h
 280                    return (c : rest)
 281
 282      LineBuffering    -> lazyReadBuffered h fd ref buf
 283      BlockBuffering _ -> lazyReadBuffered h fd ref buf
 284
 285 -- we never want to block during the read, so we call fillReadBuffer with
 286 -- is_line==True, which tells it to "just read what there is".
 287 lazyReadBuffered h fd ref buf = do
 288    maybe_new_buf <-
 289         if bufferEmpty buf
 290            then maybeFillReadBuffer fd True buf
 291            else return (Just buf)
 292    case maybe_new_buf of
 293         Nothing  -> return ""
 294         Just buf -> do
 295            more <- lazyRead h
 296            writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
 297            unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
 298
 299
 300 maybeFillReadBuffer fd is_line buf
 301   = catch
 302      (do buf <- fillReadBuffer fd is_line buf
 303          return (Just buf)
 304      )
 305      (\e -> if isEOFError e
 306                 then return Nothing
 307                 else throw e)
 308
 309
 310 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
 311 unpackAcc buf r 0 acc  = return ""
 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                    (c_write (fromIntegral fd) buf 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_) 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         writeBlocks 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         shoveString n' cs
 429   in
 430   shoveString 0 s
 431
 432 writeBlocks :: Handle -> Buffer -> String -> IO ()
 433 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
 434   let
 435    shoveString :: Int -> [Char] -> IO ()
 436         -- check n == len first, to ensure that shoveString is strict in n.
 437    shoveString n cs | n == len = do
 438         new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
 439         writeBlocks hdl new_buf cs
 440    shoveString n [] = do
 441         commitBuffer hdl raw len n False{-no flush-} True{-release-}
 442         return ()
 443    shoveString n (c:cs) = do
 444         n' <- writeCharIntoBuffer raw n c
 445         shoveString n' cs
 446   in
 447   shoveString 0 s
 448
 449 -- -----------------------------------------------------------------------------
 450 -- commitBuffer handle buf sz count flush release
 451 --
 452 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
 453 -- 'count' bytes of data) to handle (handle must be block or line buffered).
 454 --
 455 -- Implementation:
 456 --
 457 --    for block/line buffering,
 458 --       1. If there isn't room in the handle buffer, flush the handle
 459 --          buffer.
 460 --
 461 --       2. If the handle buffer is empty,
 462 --               if flush,
 463 --                   then write buf directly to the device.
 464 --                   else swap the handle buffer with buf.
 465 --
 466 --       3. If the handle buffer is non-empty, copy buf into the
 467 --          handle buffer.  Then, if flush != 0, flush
 468 --          the buffer.
 469
 470 commitBuffer
 471         :: Handle                       -- handle to commit to
 472         -> RawBuffer -> Int             -- address and size (in bytes) of buffer
 473         -> Int                          -- number of bytes of data in buffer
 474         -> Bool                         -- flush the handle afterward?
 475         -> Bool                         -- release the buffer?
 476         -> IO Buffer
 477
 478 commitBuffer hdl raw sz count flush release = do
 479   wantWritableHandle "commitAndReleaseBuffer" hdl $
 480     \ handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } -> do
 481
 482 #ifdef DEBUG_DUMP
 483       puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
 484             ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
 485 #endif
 486
 487       old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
 488           <- readIORef ref
 489
 490       buf_ret <-
 491         -- enough room in handle buffer?
 492          if (not flush && (size - w > count))
 493                 -- The > is to be sure that we never exactly fill
 494                 -- up the buffer, which would require a flush.  So
 495                 -- if copying the new data into the buffer would
 496                 -- make the buffer full, we just flush the existing
 497                 -- buffer and the new data immediately, rather than
 498                 -- copying before flushing.
 499
 500                 -- not flushing, and there's enough room in the buffer:
 501                 -- just copy the data in and update bufWPtr.
 502             then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
 503                     writeIORef ref old_buf{ bufWPtr = w + count }
 504                     return (newEmptyBuffer raw WriteBuffer sz)
 505
 506                 -- else, we have to flush
 507             else do flushed_buf <- flushWriteBuffer fd old_buf
 508
 509                     let this_buf =
 510                             Buffer{ bufBuf=raw, bufState=WriteBuffer,
 511                                     bufRPtr=0, bufWPtr=count, bufSize=sz }
 512
 513                         -- if:  (a) we don't have to flush, and
 514                         --      (b) size(new buffer) == size(old buffer), and
 515                         --      (c) new buffer is not full,
 516                         -- we can just just swap them over...
 517                     if (not flush && sz == size && count /= sz)
 518                         then do
 519                           writeIORef ref this_buf
 520                           return flushed_buf
 521
 522                         -- otherwise, we have to flush the new data too,
 523                         -- and start with a fresh buffer
 524                         else do
 525                           flushWriteBuffer fd this_buf
 526                           writeIORef ref flushed_buf
 527                             -- if the sizes were different, then allocate
 528                             -- a new buffer of the correct size.
 529                           if sz == size
 530                              then return (newEmptyBuffer raw WriteBuffer sz)
 531                              else allocateBuffer size WriteBuffer
 532
 533       -- release the buffer if necessary
 534       if release && bufSize buf_ret == size
 535          then do
 536               spare_bufs <- readIORef spare_buf_ref
 537               writeIORef spare_buf_ref
 538                 (BufferListCons (bufBuf buf_ret) spare_bufs)
 539               return buf_ret
 540          else
 541               return buf_ret
 542
 543 -- ---------------------------------------------------------------------------
 544 -- Reading/writing sequences of bytes.
 545
 546 {-
 547 Semantics of hGetBuf:
 548
 549    - hGetBuf reads data into the buffer until either
 550
 551         (a) EOF is reached
 552         (b) the buffer is full
 553
 554      It returns the amount of data actually read.  This may
 555      be zero in case (a).  hGetBuf never raises
 556      an EOF exception, it always returns zero instead.
 557
 558      If the handle is a pipe or socket, and the writing end
 559      is closed, hGetBuf will behave as for condition (a).
 560
 561 Semantics of hPutBuf:
 562
 563     - hPutBuf writes data from the buffer to the handle
 564       until the buffer is empty.  It returns ().
 565
 566       If the handle is a pipe or socket, and the reading end is
 567       closed, hPutBuf will raise a ResourceVanished exception.
 568       (If this is a POSIX system, and the program has not
 569       asked to ignore SIGPIPE, then a SIGPIPE may be delivered
 570       instead, whose default action is to terminate the program).
 571 -}
 572
 573 -- ---------------------------------------------------------------------------
 574 -- hPutBuf
 575
 576 hPutBuf :: Handle                       -- handle to write to
 577         -> Ptr a                        -- address of buffer
 578         -> Int                          -- number of bytes of data in buffer
 579         -> IO ()
 580 hPutBuf handle ptr count
 581   | count <= 0 = illegalBufferSize handle "hPutBuf" count
 582   | otherwise =
 583     wantWritableHandle "hPutBuf" handle $
 584       \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> do
 585
 586         old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
 587           <- readIORef ref
 588
 589         -- enough room in handle buffer?
 590         if (size - w > count)
 591                 -- There's enough room in the buffer:
 592                 -- just copy the data in and update bufWPtr.
 593             then do memcpy_baoff_ptr old_raw w ptr (fromIntegral count)
 594                     writeIORef ref old_buf{ bufWPtr = w + count }
 595                     return ()
 596
 597                 -- else, we have to flush
 598             else do flushed_buf <- flushWriteBuffer fd old_buf
 599                     writeIORef ref flushed_buf
 600                     -- ToDo: should just memcpy instead of writing if possible
 601                     writeChunk fd ptr count
 602
 603 writeChunk :: FD -> Ptr a -> Int -> IO ()
 604 writeChunk fd ptr bytes = loop 0 bytes
 605  where
 606   loop :: Int -> Int -> IO ()
 607   loop _   bytes | bytes <= 0 = return ()
 608   loop off bytes = do
 609     r <- fromIntegral `liftM`
 610            throwErrnoIfMinus1RetryMayBlock "writeChunk"
 611             (c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes))
 612             (threadWaitWrite fd)
 613     -- write can't return 0
 614     loop (off + r) (bytes - r)
 615
 616 -- ---------------------------------------------------------------------------
 617 -- hGetBuf
 618
 619 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
 620 hGetBuf handle ptr count
 621   | count <= 0 = illegalBufferSize handle "hGetBuf" count
 622   | otherwise =
 623       wantReadableHandle "hGetBuf" handle $
 624         \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> do
 625         buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref
 626         if bufferEmpty buf
 627            then readChunk fd ptr count
 628            else do
 629                 let avail = w - r
 630                 copied <- if (count >= avail)
 631                             then do
 632                                 memcpy_ptr_baoff ptr raw r (fromIntegral avail)
 633                                 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
 634                                 return avail
 635                             else do
 636                                 memcpy_ptr_baoff ptr raw r (fromIntegral count)
 637                                 writeIORef ref buf{ bufRPtr = r + count }
 638                                 return count
 639
 640                 let remaining = count - copied
 641                 if remaining > 0
 642                    then do rest <- readChunk fd (ptr `plusPtr` copied) remaining
 643                            return (rest + count)
 644                    else return count
 645
 646 readChunk :: FD -> Ptr a -> Int -> IO Int
 647 readChunk fd ptr bytes = loop 0 bytes
 648  where
 649   loop :: Int -> Int -> IO Int
 650   loop off bytes | bytes <= 0 = return off
 651   loop off bytes = do
 652     r <- fromIntegral `liftM`
 653            throwErrnoIfMinus1RetryMayBlock "readChunk"
 654             (c_read (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes))
 655             (threadWaitRead fd)
 656     if r == 0
 657         then return off
 658         else loop (off + r) (bytes - r)
 659
 660 slurpFile :: FilePath -> IO (Ptr (), Int)
 661 slurpFile fname = do
 662   handle <- openFile fname ReadMode
 663   sz     <- hFileSize handle
 664   if sz > fromIntegral (maxBound::Int) then
 665     ioError (userError "slurpFile: file too big")
 666    else do
 667     let sz_i = fromIntegral sz
 668     chunk <- mallocBytes sz_i
 669     r <- hGetBuf handle chunk sz_i
 670     hClose handle
 671     return (chunk, r)
 672
 673 -- ---------------------------------------------------------------------------
 674 -- hGetBufBA
 675
 676 hGetBufBA :: Handle -> MutableByteArray RealWorld a -> Int -> IO Int
 677 hGetBufBA handle (MutableByteArray _ _ ptr) count
 678   | count <= 0 = illegalBufferSize handle "hGetBuf" count
 679   | otherwise =
 680       wantReadableHandle "hGetBuf" handle $
 681         \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> do
 682         buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref
 683         if bufferEmpty buf
 684            then readChunkBA fd ptr 0 count
 685            else do
 686                 let avail = w - r
 687                 copied <- if (count >= avail)
 688                             then do
 689                                 memcpy_ba_baoff ptr raw r (fromIntegral avail)
 690                                 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
 691                                 return avail
 692                             else do
 693                                 memcpy_ba_baoff ptr raw r (fromIntegral count)
 694                                 writeIORef ref buf{ bufRPtr = r + count }
 695                                 return count
 696
 697                 let remaining = count - copied
 698                 if remaining > 0
 699                    then do rest <- readChunkBA fd ptr copied remaining
 700                            return (rest + count)
 701                    else return count
 702
 703 readChunkBA :: FD -> RawBuffer -> Int -> Int -> IO Int
 704 readChunkBA fd ptr init_off bytes = loop init_off bytes
 705  where
 706   loop :: Int -> Int -> IO Int
 707   loop off bytes | bytes <= 0 = return (off - init_off)
 708   loop off bytes = do
 709     r <- fromIntegral `liftM`
 710            throwErrnoIfMinus1RetryMayBlock "readChunk"
 711             (readBA (fromIntegral fd) ptr
 712                 (fromIntegral off) (fromIntegral bytes))
 713             (threadWaitRead fd)
 714     if r == 0
 715         then return (off - init_off)
 716         else loop (off + r) (bytes - r)
 717
 718 foreign import "read_ba_wrap" unsafe
 719    readBA :: FD -> RawBuffer -> Int -> CInt -> IO CInt
 720 #def inline \
 721 int read_ba_wrap(int fd, void *ptr, HsInt off, int size) \
 722 { return read(fd, ptr + off, size); }
 723
 724 -- -----------------------------------------------------------------------------
 725 -- hPutBufBA
 726
 727 hPutBufBA
 728         :: Handle                       -- handle to write to
 729         -> MutableByteArray RealWorld a -- buffer
 730         -> Int                          -- number of bytes of data in buffer
 731         -> IO ()
 732
 733 hPutBufBA handle (MutableByteArray _ _ raw) count
 734   | count <= 0 = illegalBufferSize handle "hPutBufBA" count
 735   | otherwise = do
 736     wantWritableHandle "hPutBufBA" handle $
 737       \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> do
 738
 739         old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
 740           <- readIORef ref
 741
 742         -- enough room in handle buffer?
 743         if (size - w > count)
 744                 -- There's enough room in the buffer:
 745                 -- just copy the data in and update bufWPtr.
 746             then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
 747                     writeIORef ref old_buf{ bufWPtr = w + count }
 748                     return ()
 749
 750                 -- else, we have to flush
 751             else do flushed_buf <- flushWriteBuffer fd old_buf
 752                     writeIORef ref flushed_buf
 753                     let this_buf =
 754                             Buffer{ bufBuf=raw, bufState=WriteBuffer,
 755                                     bufRPtr=0, bufWPtr=count, bufSize=count }
 756                     flushWriteBuffer fd this_buf
 757                     return ()
 758
 759 -- ---------------------------------------------------------------------------
 760 -- memcpy wrappers
 761
 762 foreign import "memcpy_wrap_src_off" unsafe
 763    memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
 764 foreign import "memcpy_wrap_src_off" unsafe
 765    memcpy_ptr_baoff :: Ptr a -> RawBuffer -> Int -> CSize -> IO (Ptr ())
 766 foreign import "memcpy_wrap_dst_off" unsafe
 767    memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
 768 foreign import "memcpy_wrap_dst_off" unsafe
 769    memcpy_baoff_ptr :: RawBuffer -> Int -> Ptr a -> CSize -> IO (Ptr ())
 770
 771 #def inline \
 772 void *memcpy_wrap_dst_off(char *dst, int dst_off, char *src, size_t sz) \
 773 { return memcpy(dst+dst_off, src, sz); }
 774
 775 #def inline \
 776 void *memcpy_wrap_src_off(char *dst, char *src, int src_off, size_t sz) \
 777 { return memcpy(dst, src+src_off, sz); }
 778
 779 -----------------------------------------------------------------------------
 780 -- Internal Utils
 781
 782 illegalBufferSize :: Handle -> String -> Int -> IO a
 783 illegalBufferSize handle fn (sz :: Int) =
 784         ioException (IOError (Just handle)
 785                             InvalidArgument  fn
 786                             ("illegal buffer size " ++ showsPrec 9 sz [])
 787                             Nothing)