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