GHC/IO.hs

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