GHC/IO.hs

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