GHC/IO.hs

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