GHC/IO.hs

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