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