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