GHC/IO.hs

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