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