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