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