GHC/IO.hs

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