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