GHC/IO.hs

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