GHC/IO.hs

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