GHC/IO.hs

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