GHC/IO.hs

   1 {-# OPTIONS_GHC -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 -- #hide
  20 module GHC.IO (
  21    hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
  22    commitBuffer',       -- hack, see below
  23    hGetcBuffered,       -- needed by ghc/compiler/utils/StringBuffer.lhs
  24    hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, slurpFile,
  25    memcpy_ba_baoff,
  26    memcpy_ptr_baoff,
  27    memcpy_baoff_ba,
  28    memcpy_baoff_ptr,
  29  ) where
  30
  31 import Foreign
  32 import Foreign.C
  33
  34 import System.IO.Error
  35 import Data.Maybe
  36 import Control.Monad
  37 import System.Posix.Internals
  38
  39 import GHC.Enum
  40 import GHC.Base
  41 import GHC.IOBase
  42 import GHC.Handle       -- much of the real stuff is in here
  43 import GHC.Real
  44 import GHC.Num
  45 import GHC.Show
  46 import GHC.List
  47 import GHC.Exception    ( ioError, catch )
  48
  49 #ifdef mingw32_HOST_OS
  50 import GHC.Conc
  51 #endif
  52
  53 -- ---------------------------------------------------------------------------
  54 -- Simple input operations
  55
  56 -- If hWaitForInput finds anything in the Handle's buffer, it
  57 -- immediately returns.  If not, it tries to read from the underlying
  58 -- OS handle. Notice that for buffered Handles connected to terminals
  59 -- this means waiting until a complete line is available.
  60
  61 -- | Computation 'hWaitForInput' @hdl t@
  62 -- waits until input is available on handle @hdl@.
  63 -- It returns 'True' as soon as input is available on @hdl@,
  64 -- or 'False' if no input is available within @t@ milliseconds.
  65 --
  66 -- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely.
  67 -- NOTE: in the current implementation, this is the only case that works
  68 -- correctly (if @t@ is non-zero, then all other concurrent threads are
  69 -- blocked until data is available).
  70 --
  71 -- This operation may fail with:
  72 --
  73 --  * 'isEOFError' if the end of file has been reached.
  74
  75 hWaitForInput :: Handle -> Int -> IO Bool
  76 hWaitForInput h msecs = do
  77   wantReadableHandle "hWaitForInput" h $ \ handle_ -> do
  78   let ref = haBuffer handle_
  79   buf <- readIORef ref
  80
  81   if not (bufferEmpty buf)
  82         then return True
  83         else do
  84
  85   if msecs < 0
  86         then do buf' <- fillReadBuffer (haFD handle_) True
  87                                 (haIsStream handle_) buf
  88                 writeIORef ref buf'
  89                 return True
  90         else do r <- throwErrnoIfMinus1Retry "hWaitForInput" $
  91                         inputReady (fromIntegral (haFD handle_))
  92                            (fromIntegral msecs) (haIsStream handle_)
  93                 return (r /= 0)
  94
  95 foreign import ccall safe "inputReady"
  96   inputReady :: CInt -> CInt -> Bool -> IO CInt
  97
  98 -- ---------------------------------------------------------------------------
  99 -- hGetChar
 100
 101 -- | Computation 'hGetChar' @hdl@ reads a character from the file or
 102 -- channel managed by @hdl@, blocking until a character is available.
 103 --
 104 -- This operation may fail with:
 105 --
 106 --  * 'isEOFError' if the end of file has been reached.
 107
 108 hGetChar :: Handle -> IO Char
 109 hGetChar handle =
 110   wantReadableHandle "hGetChar" handle $ \handle_ -> do
 111
 112   let fd = haFD handle_
 113       ref = haBuffer handle_
 114
 115   buf <- readIORef ref
 116   if not (bufferEmpty buf)
 117         then hGetcBuffered fd ref buf
 118         else do
 119
 120   -- buffer is empty.
 121   case haBufferMode handle_ of
 122     LineBuffering    -> do
 123         new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
 124         hGetcBuffered fd ref new_buf
 125     BlockBuffering _ -> do
 126         new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
 127                 --                   ^^^^
 128                 -- don't wait for a completely full buffer.
 129         hGetcBuffered fd ref new_buf
 130     NoBuffering -> do
 131         -- make use of the minimal buffer we already have
 132         let raw = bufBuf buf
 133         r <- readRawBuffer "hGetChar" (fromIntegral fd) (haIsStream handle_) raw 0 1
 134         if r == 0
 135            then ioe_EOF
 136            else do (c,_) <- readCharFromBuffer raw 0
 137                    return c
 138
 139 hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
 140  = do (c,r) <- readCharFromBuffer b r
 141       let new_buf | r == w    = buf{ bufRPtr=0, bufWPtr=0 }
 142                   | otherwise = buf{ bufRPtr=r }
 143       writeIORef ref new_buf
 144       return c
 145
 146 -- ---------------------------------------------------------------------------
 147 -- hGetLine
 148
 149 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
 150 -- the duration.
 151
 152 -- | Computation 'hGetLine' @hdl@ reads a line from the file or
 153 -- channel managed by @hdl@.
 154 --
 155 -- This operation may fail with:
 156 --
 157 --  * 'isEOFError' if the end of file is encountered when reading
 158 --    the /first/ character of the line.
 159 --
 160 -- If 'hGetLine' encounters end-of-file at any other point while reading
 161 -- in a line, it is treated as a line terminator and the (partial)
 162 -- line is returned.
 163
 164 hGetLine :: Handle -> IO String
 165 hGetLine h = do
 166   m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
 167         case haBufferMode handle_ of
 168            NoBuffering      -> return Nothing
 169            LineBuffering    -> do
 170               l <- hGetLineBuffered handle_
 171               return (Just l)
 172            BlockBuffering _ -> do
 173               l <- hGetLineBuffered handle_
 174               return (Just l)
 175   case m of
 176         Nothing -> hGetLineUnBuffered h
 177         Just l  -> return l
 178
 179
 180 hGetLineBuffered handle_ = do
 181   let ref = haBuffer handle_
 182   buf <- readIORef ref
 183   hGetLineBufferedLoop handle_ ref buf []
 184
 185
 186 hGetLineBufferedLoop handle_ ref
 187         buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
 188   let
 189         -- find the end-of-line character, if there is one
 190         loop raw r
 191            | r == w = return (False, w)
 192            | otherwise =  do
 193                 (c,r') <- readCharFromBuffer raw r
 194                 if c == '\n'
 195                    then return (True, r) -- NB. not r': don't include the '\n'
 196                    else loop raw r'
 197   in do
 198   (eol, off) <- loop raw r
 199
 200 #ifdef DEBUG_DUMP
 201   puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
 202 #endif
 203
 204   xs <- unpack raw r off
 205
 206   -- if eol == True, then off is the offset of the '\n'
 207   -- otherwise off == w and the buffer is now empty.
 208   if eol
 209         then do if (w == off + 1)
 210                         then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
 211                         else writeIORef ref buf{ bufRPtr = off + 1 }
 212                 return (concat (reverse (xs:xss)))
 213         else do
 214              maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
 215                                 buf{ bufWPtr=0, bufRPtr=0 }
 216              case maybe_buf of
 217                 -- Nothing indicates we caught an EOF, and we may have a
 218                 -- partial line to return.
 219                 Nothing -> do
 220                      writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
 221                      let str = concat (reverse (xs:xss))
 222                      if not (null str)
 223                         then return str
 224                         else ioe_EOF
 225                 Just new_buf ->
 226                      hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
 227
 228
 229 maybeFillReadBuffer fd is_line is_stream buf
 230   = catch
 231      (do buf <- fillReadBuffer fd is_line is_stream buf
 232          return (Just buf)
 233      )
 234      (\e -> do if isEOFError e
 235                   then return Nothing
 236                   else ioError e)
 237
 238
 239 unpack :: RawBuffer -> Int -> Int -> IO [Char]
 240 unpack buf r 0   = return ""
 241 unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s
 242    where
 243     unpack acc i s
 244      | i <# r  = (# s, acc #)
 245      | otherwise =
 246           case readCharArray# buf i s of
 247             (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
 248
 249
 250 hGetLineUnBuffered :: Handle -> IO String
 251 hGetLineUnBuffered h = do
 252   c <- hGetChar h
 253   if c == '\n' then
 254      return ""
 255    else do
 256     l <- getRest
 257     return (c:l)
 258  where
 259   getRest = do
 260     c <-
 261       catch
 262         (hGetChar h)
 263         (\ err -> do
 264           if isEOFError err then
 265              return '\n'
 266            else
 267              ioError err)
 268     if c == '\n' then
 269        return ""
 270      else do
 271        s <- getRest
 272        return (c:s)
 273
 274 -- -----------------------------------------------------------------------------
 275 -- hGetContents
 276
 277 -- hGetContents on a DuplexHandle only affects the read side: you can
 278 -- carry on writing to it afterwards.
 279
 280 -- | Computation 'hGetContents' @hdl@ returns the list of characters
 281 -- corresponding to the unread portion of the channel or file managed
 282 -- by @hdl@, which is put into an intermediate state, /semi-closed/.
 283 -- In this state, @hdl@ is effectively closed,
 284 -- but items are read from @hdl@ on demand and accumulated in a special
 285 -- list returned by 'hGetContents' @hdl@.
 286 --
 287 -- Any operation that fails because a handle is closed,
 288 -- also fails if a handle is semi-closed.  The only exception is 'hClose'.
 289 -- A semi-closed handle becomes closed:
 290 --
 291 --  * if 'hClose' is applied to it;
 292 --
 293 --  * if an I\/O error occurs when reading an item from the handle;
 294 --
 295 --  * or once the entire contents of the handle has been read.
 296 --
 297 -- Once a semi-closed handle becomes closed, the contents of the
 298 -- associated list becomes fixed.  The contents of this final list is
 299 -- only partially specified: it will contain at least all the items of
 300 -- the stream that were evaluated prior to the handle becoming closed.
 301 --
 302 -- Any I\/O errors encountered while a handle is semi-closed are simply
 303 -- discarded.
 304 --
 305 -- This operation may fail with:
 306 --
 307 --  * 'isEOFError' if the end of file has been reached.
 308
 309 hGetContents :: Handle -> IO String
 310 hGetContents handle =
 311     withHandle "hGetContents" handle $ \handle_ ->
 312     case haType handle_ of
 313       ClosedHandle         -> ioe_closedHandle
 314       SemiClosedHandle     -> ioe_closedHandle
 315       AppendHandle         -> ioe_notReadable
 316       WriteHandle          -> ioe_notReadable
 317       _ -> do xs <- lazyRead handle
 318               return (handle_{ haType=SemiClosedHandle}, xs )
 319
 320 -- Note that someone may close the semi-closed handle (or change its
 321 -- buffering), so each time these lazy read functions are pulled on,
 322 -- they have to check whether the handle has indeed been closed.
 323
 324 lazyRead :: Handle -> IO String
 325 lazyRead handle =
 326    unsafeInterleaveIO $
 327         withHandle "lazyRead" handle $ \ handle_ -> do
 328         case haType handle_ of
 329           ClosedHandle     -> return (handle_, "")
 330           SemiClosedHandle -> lazyRead' handle handle_
 331           _ -> ioException
 332                   (IOError (Just handle) IllegalOperation "lazyRead"
 333                         "illegal handle type" Nothing)
 334
 335 lazyRead' h handle_ = do
 336   let ref = haBuffer handle_
 337       fd  = haFD handle_
 338
 339   -- even a NoBuffering handle can have a char in the buffer...
 340   -- (see hLookAhead)
 341   buf <- readIORef ref
 342   if not (bufferEmpty buf)
 343         then lazyReadHaveBuffer h handle_ fd ref buf
 344         else do
 345
 346   case haBufferMode handle_ of
 347      NoBuffering      -> do
 348         -- make use of the minimal buffer we already have
 349         let raw = bufBuf buf
 350         r <- readRawBuffer "lazyRead" (fromIntegral fd) (haIsStream handle_) raw 0 1
 351         if r == 0
 352            then do handle_ <- hClose_help handle_
 353                    return (handle_, "")
 354            else do (c,_) <- readCharFromBuffer raw 0
 355                    rest <- lazyRead h
 356                    return (handle_, c : rest)
 357
 358      LineBuffering    -> lazyReadBuffered h handle_ fd ref buf
 359      BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
 360
 361 -- we never want to block during the read, so we call fillReadBuffer with
 362 -- is_line==True, which tells it to "just read what there is".
 363 lazyReadBuffered h handle_ fd ref buf = do
 364    catch
 365         (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
 366             lazyReadHaveBuffer h handle_ fd ref buf
 367         )
 368         -- all I/O errors are discarded.  Additionally, we close the handle.
 369         (\e -> do handle_ <- hClose_help handle_
 370                   return (handle_, "")
 371         )
 372
 373 lazyReadHaveBuffer h handle_ fd ref buf = do
 374    more <- lazyRead h
 375    writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
 376    s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
 377    return (handle_, s)
 378
 379
 380 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
 381 unpackAcc buf r 0 acc  = return acc
 382 unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
 383    where
 384     unpack acc i s
 385      | i <# r  = (# s, acc #)
 386      | otherwise =
 387           case readCharArray# buf i s of
 388             (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
 389
 390 -- ---------------------------------------------------------------------------
 391 -- hPutChar
 392
 393 -- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the
 394 -- file or channel managed by @hdl@.  Characters may be buffered if
 395 -- buffering is enabled for @hdl@.
 396 --
 397 -- This operation may fail with:
 398 --
 399 --  * 'isFullError' if the device is full; or
 400 --
 401 --  * 'isPermissionError' if another system resource limit would be exceeded.
 402
 403 hPutChar :: Handle -> Char -> IO ()
 404 hPutChar handle c =
 405     c `seq` do   -- must evaluate c before grabbing the handle lock
 406     wantWritableHandle "hPutChar" handle $ \ handle_  -> do
 407     let fd = haFD handle_
 408     case haBufferMode handle_ of
 409         LineBuffering    -> hPutcBuffered handle_ True  c
 410         BlockBuffering _ -> hPutcBuffered handle_ False c
 411         NoBuffering      ->
 412                 with (castCharToCChar c) $ \buf -> do
 413                   writeRawBufferPtr "hPutChar" (fromIntegral fd) (haIsStream handle_) buf 0 1
 414                   return ()
 415
 416 hPutcBuffered handle_ is_line c = do
 417   let ref = haBuffer handle_
 418   buf <- readIORef ref
 419   let w = bufWPtr buf
 420   w'  <- writeCharIntoBuffer (bufBuf buf) w c
 421   let new_buf = buf{ bufWPtr = w' }
 422   if bufferFull new_buf || is_line && c == '\n'
 423      then do
 424         flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf
 425         writeIORef ref flushed_buf
 426      else do
 427         writeIORef ref new_buf
 428
 429
 430 hPutChars :: Handle -> [Char] -> IO ()
 431 hPutChars handle [] = return ()
 432 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
 433
 434 -- ---------------------------------------------------------------------------
 435 -- hPutStr
 436
 437 -- We go to some trouble to avoid keeping the handle locked while we're
 438 -- evaluating the string argument to hPutStr, in case doing so triggers another
 439 -- I/O operation on the same handle which would lead to deadlock.  The classic
 440 -- case is
 441 --
 442 --              putStr (trace "hello" "world")
 443 --
 444 -- so the basic scheme is this:
 445 --
 446 --      * copy the string into a fresh buffer,
 447 --      * "commit" the buffer to the handle.
 448 --
 449 -- Committing may involve simply copying the contents of the new
 450 -- buffer into the handle's buffer, flushing one or both buffers, or
 451 -- maybe just swapping the buffers over (if the handle's buffer was
 452 -- empty).  See commitBuffer below.
 453
 454 -- | Computation 'hPutStr' @hdl s@ writes the string
 455 -- @s@ to the file or channel managed by @hdl@.
 456 --
 457 -- This operation may fail with:
 458 --
 459 --  * 'isFullError' if the device is full; or
 460 --
 461 --  * 'isPermissionError' if another system resource limit would be exceeded.
 462
 463 hPutStr :: Handle -> String -> IO ()
 464 hPutStr handle str = do
 465     buffer_mode <- wantWritableHandle "hPutStr" handle
 466                         (\ handle_ -> do getSpareBuffer handle_)
 467     case buffer_mode of
 468        (NoBuffering, _) -> do
 469             hPutChars handle str        -- v. slow, but we don't care
 470        (LineBuffering, buf) -> do
 471             writeLines handle buf str
 472        (BlockBuffering _, buf) -> do
 473             writeBlocks handle buf str
 474
 475
 476 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
 477 getSpareBuffer Handle__{haBuffer=ref,
 478                         haBuffers=spare_ref,
 479                         haBufferMode=mode}
 480  = do
 481    case mode of
 482      NoBuffering -> return (mode, error "no buffer!")
 483      _ -> do
 484           bufs <- readIORef spare_ref
 485           buf  <- readIORef ref
 486           case bufs of
 487             BufferListCons b rest -> do
 488                 writeIORef spare_ref rest
 489                 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
 490             BufferListNil -> do
 491                 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
 492                 return (mode, new_buf)
 493
 494
 495 writeLines :: Handle -> Buffer -> String -> IO ()
 496 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
 497   let
 498    shoveString :: Int -> [Char] -> IO ()
 499         -- check n == len first, to ensure that shoveString is strict in n.
 500    shoveString n cs | n == len = do
 501         new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
 502         writeLines hdl new_buf cs
 503    shoveString n [] = do
 504         commitBuffer hdl raw len n False{-no flush-} True{-release-}
 505         return ()
 506    shoveString n (c:cs) = do
 507         n' <- writeCharIntoBuffer raw n c
 508         if (c == '\n')
 509          then do
 510               new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
 511               writeLines hdl new_buf cs
 512          else
 513               shoveString n' cs
 514   in
 515   shoveString 0 s
 516
 517 writeBlocks :: Handle -> Buffer -> String -> IO ()
 518 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
 519   let
 520    shoveString :: Int -> [Char] -> IO ()
 521         -- check n == len first, to ensure that shoveString is strict in n.
 522    shoveString n cs | n == len = do
 523         new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
 524         writeBlocks hdl new_buf cs
 525    shoveString n [] = do
 526         commitBuffer hdl raw len n False{-no flush-} True{-release-}
 527         return ()
 528    shoveString n (c:cs) = do
 529         n' <- writeCharIntoBuffer raw n c
 530         shoveString n' cs
 531   in
 532   shoveString 0 s
 533
 534 -- -----------------------------------------------------------------------------
 535 -- commitBuffer handle buf sz count flush release
 536 --
 537 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
 538 -- 'count' bytes of data) to handle (handle must be block or line buffered).
 539 --
 540 -- Implementation:
 541 --
 542 --    for block/line buffering,
 543 --       1. If there isn't room in the handle buffer, flush the handle
 544 --          buffer.
 545 --
 546 --       2. If the handle buffer is empty,
 547 --               if flush,
 548 --                   then write buf directly to the device.
 549 --                   else swap the handle buffer with buf.
 550 --
 551 --       3. If the handle buffer is non-empty, copy buf into the
 552 --          handle buffer.  Then, if flush != 0, flush
 553 --          the buffer.
 554
 555 commitBuffer
 556         :: Handle                       -- handle to commit to
 557         -> RawBuffer -> Int             -- address and size (in bytes) of buffer
 558         -> Int                          -- number of bytes of data in buffer
 559         -> Bool                         -- True <=> flush the handle afterward
 560         -> Bool                         -- release the buffer?
 561         -> IO Buffer
 562
 563 commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
 564   wantWritableHandle "commitAndReleaseBuffer" hdl $
 565      commitBuffer' raw sz count flush release
 566
 567 -- Explicitly lambda-lift this function to subvert GHC's full laziness
 568 -- optimisations, which otherwise tends to float out subexpressions
 569 -- past the \handle, which is really a pessimisation in this case because
 570 -- that lambda is a one-shot lambda.
 571 --
 572 -- Don't forget to export the function, to stop it being inlined too
 573 -- (this appears to be better than NOINLINE, because the strictness
 574 -- analyser still gets to worker-wrapper it).
 575 --
 576 -- This hack is a fairly big win for hPutStr performance.  --SDM 18/9/2001
 577 --
 578 commitBuffer' raw sz@(I# _) count@(I# _) flush release
 579   handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
 580
 581 #ifdef DEBUG_DUMP
 582       puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
 583             ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
 584 #endif
 585
 586       old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
 587           <- readIORef ref
 588
 589       buf_ret <-
 590         -- enough room in handle buffer?
 591          if (not flush && (size - w > count))
 592                 -- The > is to be sure that we never exactly fill
 593                 -- up the buffer, which would require a flush.  So
 594                 -- if copying the new data into the buffer would
 595                 -- make the buffer full, we just flush the existing
 596                 -- buffer and the new data immediately, rather than
 597                 -- copying before flushing.
 598
 599                 -- not flushing, and there's enough room in the buffer:
 600                 -- just copy the data in and update bufWPtr.
 601             then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
 602                     writeIORef ref old_buf{ bufWPtr = w + count }
 603                     return (newEmptyBuffer raw WriteBuffer sz)
 604
 605                 -- else, we have to flush
 606             else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf
 607
 608                     let this_buf =
 609                             Buffer{ bufBuf=raw, bufState=WriteBuffer,
 610                                     bufRPtr=0, bufWPtr=count, bufSize=sz }
 611
 612                         -- if:  (a) we don't have to flush, and
 613                         --      (b) size(new buffer) == size(old buffer), and
 614                         --      (c) new buffer is not full,
 615                         -- we can just just swap them over...
 616                     if (not flush && sz == size && count /= sz)
 617                         then do
 618                           writeIORef ref this_buf
 619                           return flushed_buf
 620
 621                         -- otherwise, we have to flush the new data too,
 622                         -- and start with a fresh buffer
 623                         else do
 624                           flushWriteBuffer fd (haIsStream handle_) this_buf
 625                           writeIORef ref flushed_buf
 626                             -- if the sizes were different, then allocate
 627                             -- a new buffer of the correct size.
 628                           if sz == size
 629                              then return (newEmptyBuffer raw WriteBuffer sz)
 630                              else allocateBuffer size WriteBuffer
 631
 632       -- release the buffer if necessary
 633       case buf_ret of
 634         Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
 635           if release && buf_ret_sz == size
 636             then do
 637               spare_bufs <- readIORef spare_buf_ref
 638               writeIORef spare_buf_ref
 639                 (BufferListCons buf_ret_raw spare_bufs)
 640               return buf_ret
 641             else
 642               return buf_ret
 643
 644 -- ---------------------------------------------------------------------------
 645 -- Reading/writing sequences of bytes.
 646
 647 -- ---------------------------------------------------------------------------
 648 -- hPutBuf
 649
 650 -- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the
 651 -- buffer @buf@ to the handle @hdl@.  It returns ().
 652 --
 653 -- This operation may fail with:
 654 --
 655 --  * 'ResourceVanished' if the handle is a pipe or socket, and the
 656 --    reading end is closed.  (If this is a POSIX system, and the program
 657 --    has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered
 658 --    instead, whose default action is to terminate the program).
 659
 660 hPutBuf :: Handle                       -- handle to write to
 661         -> Ptr a                        -- address of buffer
 662         -> Int                          -- number of bytes of data in buffer
 663         -> IO ()
 664 hPutBuf h ptr count = do hPutBuf' h ptr count True; return ()
 665
 666 hPutBufNonBlocking
 667         :: Handle                       -- handle to write to
 668         -> Ptr a                        -- address of buffer
 669         -> Int                          -- number of bytes of data in buffer
 670         -> IO Int                       -- returns: number of bytes written
 671 hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False
 672
 673 hPutBuf':: Handle                       -- handle to write to
 674         -> Ptr a                        -- address of buffer
 675         -> Int                          -- number of bytes of data in buffer
 676         -> Bool                         -- allow blocking?
 677         -> IO Int
 678 hPutBuf' handle ptr count can_block
 679   | count == 0 = return 0
 680   | count <  0 = illegalBufferSize handle "hPutBuf" count
 681   | otherwise =
 682     wantWritableHandle "hPutBuf" handle $
 683       \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } ->
 684           bufWrite fd ref is_stream ptr count can_block
 685
 686 bufWrite fd ref is_stream ptr count can_block =
 687   seq count $ seq fd $ do  -- strictness hack
 688   old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
 689      <- readIORef ref
 690
 691   -- enough room in handle buffer?
 692   if (size - w > count)
 693         -- There's enough room in the buffer:
 694         -- just copy the data in and update bufWPtr.
 695         then do memcpy_baoff_ptr old_raw w ptr (fromIntegral count)
 696                 writeIORef ref old_buf{ bufWPtr = w + count }
 697                 return count
 698
 699         -- else, we have to flush
 700         else do flushed_buf <- flushWriteBuffer fd is_stream old_buf
 701                         -- TODO: we should do a non-blocking flush here
 702                 writeIORef ref flushed_buf
 703                 -- if we can fit in the buffer, then just loop
 704                 if count < size
 705                    then bufWrite fd ref is_stream ptr count can_block
 706                    else if can_block
 707                            then do writeChunk fd is_stream (castPtr ptr) count
 708                                    return count
 709                            else writeChunkNonBlocking fd is_stream ptr count
 710
 711 writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO ()
 712 writeChunk fd is_stream ptr bytes = loop 0 bytes
 713  where
 714   loop :: Int -> Int -> IO ()
 715   loop _   bytes | bytes <= 0 = return ()
 716   loop off bytes = do
 717     r <- fromIntegral `liftM`
 718            writeRawBufferPtr "writeChunk" (fromIntegral fd) is_stream ptr
 719                              off (fromIntegral bytes)
 720     -- write can't return 0
 721     loop (off + r) (bytes - r)
 722
 723 writeChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
 724 writeChunkNonBlocking fd is_stream ptr bytes = loop 0 bytes
 725  where
 726   loop :: Int -> Int -> IO Int
 727   loop off bytes | bytes <= 0 = return off
 728   loop off bytes = do
 729 #ifndef mingw32_HOST_OS
 730     ssize <- c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes)
 731     let r = fromIntegral ssize :: Int
 732     if (r == -1)
 733       then do errno <- getErrno
 734               if (errno == eAGAIN || errno == eWOULDBLOCK)
 735                  then return off
 736                  else throwErrno "writeChunk"
 737       else loop (off + r) (bytes - r)
 738 #else
 739     (ssize, rc) <- asyncWrite fd (fromIntegral $ fromEnum is_stream)
 740                                  (fromIntegral bytes)
 741                                  (ptr `plusPtr` off)
 742     let r = fromIntegral ssize :: Int
 743     if r == (-1)
 744       then ioError (errnoToIOError "hPutBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing)
 745       else loop (off + r) (bytes - r)
 746 #endif
 747
 748 -- ---------------------------------------------------------------------------
 749 -- hGetBuf
 750
 751 -- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@
 752 -- into the buffer @buf@ until either EOF is reached or
 753 -- @count@ 8-bit bytes have been read.
 754 -- It returns the number of bytes actually read.  This may be zero if
 755 -- EOF was reached before any data was read (or if @count@ is zero).
 756 --
 757 -- 'hGetBuf' never raises an EOF exception, instead it returns a value
 758 -- smaller than @count@.
 759 --
 760 -- If the handle is a pipe or socket, and the writing end
 761 -- is closed, 'hGetBuf' will behave as if EOF was reached.
 762
 763 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
 764 hGetBuf h ptr count
 765   | count == 0 = return 0
 766   | count <  0 = illegalBufferSize h "hGetBuf" count
 767   | otherwise =
 768       wantReadableHandle "hGetBuf" h $
 769         \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
 770             bufRead fd ref is_stream ptr 0 count
 771
 772 -- small reads go through the buffer, large reads are satisfied by
 773 -- taking data first from the buffer and then direct from the file
 774 -- descriptor.
 775 bufRead fd ref is_stream ptr so_far count =
 776   seq fd $ seq so_far $ seq count $ do -- strictness hack
 777   buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
 778   if bufferEmpty buf
 779      then if count > sz  -- small read?
 780                 then do rest <- readChunk fd is_stream ptr count
 781                         return (so_far + rest)
 782                 else do mb_buf <- maybeFillReadBuffer fd True is_stream buf
 783                         case mb_buf of
 784                           Nothing -> return so_far -- got nothing, we're done
 785                           Just buf' -> do
 786                                 writeIORef ref buf'
 787                                 bufRead fd ref is_stream ptr so_far count
 788      else do
 789         let avail = w - r
 790         if (count == avail)
 791            then do
 792                 memcpy_ptr_baoff ptr raw r (fromIntegral count)
 793                 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
 794                 return (so_far + count)
 795            else do
 796         if (count < avail)
 797            then do
 798                 memcpy_ptr_baoff ptr raw r (fromIntegral count)
 799                 writeIORef ref buf{ bufRPtr = r + count }
 800                 return (so_far + count)
 801            else do
 802
 803         memcpy_ptr_baoff ptr raw r (fromIntegral avail)
 804         writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
 805         let remaining = count - avail
 806             so_far' = so_far + avail
 807             ptr' = ptr `plusPtr` avail
 808
 809         if remaining < sz
 810            then bufRead fd ref is_stream ptr' so_far' remaining
 811            else do
 812
 813         rest <- readChunk fd is_stream ptr' remaining
 814         return (so_far' + rest)
 815
 816 readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int
 817 readChunk fd is_stream ptr bytes = loop 0 bytes
 818  where
 819   loop :: Int -> Int -> IO Int
 820   loop off bytes | bytes <= 0 = return off
 821   loop off bytes = do
 822     r <- fromIntegral `liftM`
 823            readRawBufferPtr "readChunk" (fromIntegral fd) is_stream
 824                             (castPtr ptr) off (fromIntegral bytes)
 825     if r == 0
 826         then return off
 827         else loop (off + r) (bytes - r)
 828
 829
 830 -- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@
 831 -- into the buffer @buf@ until either EOF is reached, or
 832 -- @count@ 8-bit bytes have been read, or there is no more data available
 833 -- to read immediately.
 834 --
 835 -- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will
 836 -- never block waiting for data to become available, instead it returns
 837 -- only whatever data is available.  To wait for data to arrive before
 838 -- calling 'hGetBufNonBlocking', use 'hWaitForInput'.
 839 --
 840 -- If the handle is a pipe or socket, and the writing end
 841 -- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.
 842 --
 843 hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
 844 hGetBufNonBlocking h ptr count
 845   | count == 0 = return 0
 846   | count <  0 = illegalBufferSize h "hGetBufNonBlocking" count
 847   | otherwise =
 848       wantReadableHandle "hGetBufNonBlocking" h $
 849         \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
 850             bufReadNonBlocking fd ref is_stream ptr 0 count
 851
 852 bufReadNonBlocking fd ref is_stream ptr so_far count =
 853   seq fd $ seq so_far $ seq count $ do -- strictness hack
 854   buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
 855   if bufferEmpty buf
 856      then if count > sz  -- large read?
 857                 then do rest <- readChunkNonBlocking fd is_stream ptr count
 858                         return (so_far + rest)
 859                 else do buf' <- fillReadBufferWithoutBlocking fd is_stream buf
 860                         case buf' of { Buffer{ bufWPtr=w }  ->
 861                         if (w == 0)
 862                            then return so_far
 863                            else do writeIORef ref buf'
 864                                    bufReadNonBlocking fd ref is_stream ptr
 865                                          so_far (min count w)
 866                                   -- NOTE: new count is 'min count w'
 867                                   -- so we will just copy the contents of the
 868                                   -- buffer in the recursive call, and not
 869                                   -- loop again.
 870                         }
 871      else do
 872         let avail = w - r
 873         if (count == avail)
 874            then do
 875                 memcpy_ptr_baoff ptr raw r (fromIntegral count)
 876                 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
 877                 return (so_far + count)
 878            else do
 879         if (count < avail)
 880            then do
 881                 memcpy_ptr_baoff ptr raw r (fromIntegral count)
 882                 writeIORef ref buf{ bufRPtr = r + count }
 883                 return (so_far + count)
 884            else do
 885
 886         memcpy_ptr_baoff ptr raw r (fromIntegral avail)
 887         writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
 888         let remaining = count - avail
 889             so_far' = so_far + avail
 890             ptr' = ptr `plusPtr` avail
 891
 892         -- we haven't attempted to read anything yet if we get to here.
 893         if remaining < sz
 894            then bufReadNonBlocking fd ref is_stream ptr' so_far' remaining
 895            else do
 896
 897         rest <- readChunkNonBlocking fd is_stream ptr' remaining
 898         return (so_far' + rest)
 899
 900
 901 readChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
 902 readChunkNonBlocking fd is_stream ptr bytes = do
 903 #ifndef mingw32_HOST_OS
 904     ssize <- c_read (fromIntegral fd) (castPtr ptr) (fromIntegral bytes)
 905     let r = fromIntegral ssize :: Int
 906     if (r == -1)
 907       then do errno <- getErrno
 908               if (errno == eAGAIN || errno == eWOULDBLOCK)
 909                  then return 0
 910                  else throwErrno "readChunk"
 911       else return r
 912 #else
 913     (ssize, rc) <- asyncRead fd (fromIntegral $ fromEnum is_stream)
 914                                (fromIntegral bytes) ptr
 915     let r = fromIntegral ssize :: Int
 916     if r == (-1)
 917      then ioError (errnoToIOError "hGetBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing)
 918      else return r
 919 #endif
 920
 921 slurpFile :: FilePath -> IO (Ptr (), Int)
 922 slurpFile fname = do
 923   handle <- openFile fname ReadMode
 924   sz     <- hFileSize handle
 925   if sz > fromIntegral (maxBound::Int) then
 926     ioError (userError "slurpFile: file too big")
 927    else do
 928     let sz_i = fromIntegral sz
 929     if sz_i == 0 then return (nullPtr, 0) else do
 930     chunk <- mallocBytes sz_i
 931     r <- hGetBuf handle chunk sz_i
 932     hClose handle
 933     return (chunk, r)
 934
 935 -- ---------------------------------------------------------------------------
 936 -- memcpy wrappers
 937
 938 foreign import ccall unsafe "__hscore_memcpy_src_off"
 939    memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
 940 foreign import ccall unsafe "__hscore_memcpy_src_off"
 941    memcpy_ptr_baoff :: Ptr a -> RawBuffer -> Int -> CSize -> IO (Ptr ())
 942 foreign import ccall unsafe "__hscore_memcpy_dst_off"
 943    memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
 944 foreign import ccall unsafe "__hscore_memcpy_dst_off"
 945    memcpy_baoff_ptr :: RawBuffer -> Int -> Ptr a -> CSize -> IO (Ptr ())
 946
 947 -----------------------------------------------------------------------------
 948 -- Internal Utils
 949
 950 illegalBufferSize :: Handle -> String -> Int -> IO a
 951 illegalBufferSize handle fn (sz :: Int) =
 952         ioException (IOError (Just handle)
 953                             InvalidArgument  fn
 954                             ("illegal buffer size " ++ showsPrec 9 sz [])
 955                             Nothing)