GHC/IO.hsc

   1 {-# OPTIONS -fno-implicit-prelude #-}
   2
   3 #undef DEBUG_DUMP
   4
   5 -- -----------------------------------------------------------------------------
   6 -- $Id: IO.hsc,v 1.2 2001/07/31 12:46:17 simonmar Exp $
   7 --
   8 -- (c) The University of Glasgow, 1992-2001
   9 --
  10 -- Module GHC.IO
  11
  12 -- This module defines all basic IO operations.
  13 -- These are needed for the IO operations exported by Prelude,
  14 -- but as it happens they also do everything required by library
  15 -- module IO.
  16
  17 module GHC.IO where
  18
  19 #include "HsCore.h"
  20 #include "GHC/Handle_hsc.h"
  21
  22 import Foreign
  23 import Foreign.C
  24
  25 import Data.Maybe
  26 import Control.Monad
  27
  28 import GHC.ByteArr
  29 import GHC.Enum
  30 import GHC.Base
  31 import GHC.Posix
  32 import GHC.IOBase
  33 import GHC.Handle       -- much of the real stuff is in here
  34 import GHC.Real
  35 import GHC.Num
  36 import GHC.Show
  37 import GHC.List
  38 import GHC.Exception    ( ioError, catch, throw )
  39 import GHC.Conc
  40
  41 -- ---------------------------------------------------------------------------
  42 -- Simple input operations
  43
  44 -- Computation "hReady hdl" indicates whether at least
  45 -- one item is available for input from handle "hdl".
  46
  47 -- If hWaitForInput finds anything in the Handle's buffer, it
  48 -- immediately returns.  If not, it tries to read from the underlying
  49 -- OS handle. Notice that for buffered Handles connected to terminals
  50 -- this means waiting until a complete line is available.
  51
  52 hWaitForInput :: Handle -> Int -> IO Bool
  53 hWaitForInput h msecs = do
  54   wantReadableHandle "hReady" h $ \ handle_ -> do
  55   let ref = haBuffer handle_
  56   buf <- readIORef ref
  57
  58   if not (bufferEmpty buf)
  59         then return True
  60         else do
  61
  62   r <- throwErrnoIfMinus1Retry "hReady"
  63           (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs))
  64   return (r /= 0)
  65
  66 foreign import "inputReady"
  67   inputReady :: CInt -> CInt -> IO CInt
  68
  69 -- ---------------------------------------------------------------------------
  70 -- hGetChar
  71
  72 -- hGetChar reads the next character from a handle,
  73 -- blocking until a character is available.
  74
  75 hGetChar :: Handle -> IO Char
  76 hGetChar handle =
  77   wantReadableHandle "hGetChar" handle $ \handle_ -> do
  78
  79   let fd = haFD handle_
  80       ref = haBuffer handle_
  81
  82   buf <- readIORef ref
  83   if not (bufferEmpty buf)
  84         then hGetcBuffered fd ref buf
  85         else do
  86
  87   -- buffer is empty.
  88   case haBufferMode handle_ of
  89     LineBuffering    -> do
  90         new_buf <- fillReadBuffer fd True buf
  91         hGetcBuffered fd ref new_buf
  92     BlockBuffering _ -> do
  93         new_buf <- fillReadBuffer fd False buf
  94         hGetcBuffered fd ref new_buf
  95     NoBuffering -> do
  96         -- make use of the minimal buffer we already have
  97         let raw = bufBuf buf
  98         r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
  99                 (read_off (fromIntegral fd) raw 0 1)
 100                 (threadWaitRead fd)
 101         if r == 0
 102            then ioe_EOF
 103            else do (c,_) <- readCharFromBuffer raw 0
 104                    return c
 105
 106 hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
 107  = do (c,r) <- readCharFromBuffer b r
 108       let new_buf | r == w    = buf{ bufRPtr=0, bufWPtr=0 }
 109                   | otherwise = buf{ bufRPtr=r }
 110       writeIORef ref new_buf
 111       return c
 112
 113 -- ---------------------------------------------------------------------------
 114 -- hGetLine
 115
 116 -- If EOF is reached before EOL is encountered, ignore the EOF and
 117 -- return the partial line. Next attempt at calling hGetLine on the
 118 -- handle will yield an EOF IO exception though.
 119
 120 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
 121 -- the duration.
 122 hGetLine :: Handle -> IO String
 123 hGetLine h = do
 124   m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
 125         case haBufferMode handle_ of
 126            NoBuffering      -> return Nothing
 127            LineBuffering    -> do
 128               l <- hGetLineBuffered handle_
 129               return (Just l)
 130            BlockBuffering _ -> do
 131               l <- hGetLineBuffered handle_
 132               return (Just l)
 133   case m of
 134         Nothing -> hGetLineUnBuffered h
 135         Just l  -> return l
 136
 137
 138 hGetLineBuffered handle_ = do
 139   let ref = haBuffer handle_
 140   buf <- readIORef ref
 141   hGetLineBufferedLoop handle_ ref buf []
 142
 143
 144 hGetLineBufferedLoop handle_ ref
 145         buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
 146   let
 147         -- find the end-of-line character, if there is one
 148         loop raw r
 149            | r == w = return (False, w)
 150            | otherwise =  do
 151                 (c,r') <- readCharFromBuffer raw r
 152                 if c == '\n'
 153                    then return (True, r) -- NB. not r': don't include the '\n'
 154                    else loop raw r'
 155   in do
 156   (eol, off) <- loop raw r
 157
 158 #ifdef DEBUG_DUMP
 159   puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
 160 #endif
 161
 162   xs <- unpack raw r off
 163   if eol
 164         then do if w == off + 1
 165                    then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
 166                    else writeIORef ref buf{ bufRPtr = off + 1 }
 167                 return (concat (reverse (xs:xss)))
 168         else do
 169              maybe_buf <- maybeFillReadBuffer (haFD handle_) True
 170                                 buf{ bufWPtr=0, bufRPtr=0 }
 171              case maybe_buf of
 172                 -- Nothing indicates we caught an EOF, and we may have a
 173                 -- partial line to return.
 174                 Nothing -> let str = concat (reverse (xs:xss)) in
 175                            if not (null str)
 176                               then return str
 177                               else ioe_EOF
 178                 Just new_buf ->
 179                      hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
 180
 181
 182 maybeFillReadBuffer fd is_line buf
 183   = catch
 184      (do buf <- fillReadBuffer fd is_line buf
 185          return (Just buf)
 186      )
 187      (\e -> do if isEOFError e
 188                   then return Nothing
 189                   else throw e)
 190
 191
 192 unpack :: RawBuffer -> Int -> Int -> IO [Char]
 193 unpack buf r 0   = return ""
 194 unpack buf (I## r) (I## len) = IO $ \s -> unpack [] (len -## 1##) s
 195    where
 196     unpack acc i s
 197      | i <## r  = (## s, acc ##)
 198      | otherwise =
 199           case readCharArray## buf i s of
 200             (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
 201
 202
 203 hGetLineUnBuffered :: Handle -> IO String
 204 hGetLineUnBuffered h = do
 205   c <- hGetChar h
 206   if c == '\n' then
 207      return ""
 208    else do
 209     l <- getRest
 210     return (c:l)
 211  where
 212   getRest = do
 213     c <-
 214       catch
 215         (hGetChar h)
 216         (\ err -> do
 217           if isEOFError err then
 218              return '\n'
 219            else
 220              ioError err)
 221     if c == '\n' then
 222        return ""
 223      else do
 224        s <- getRest
 225        return (c:s)
 226
 227 -- -----------------------------------------------------------------------------
 228 -- hGetContents
 229
 230 -- hGetContents returns the list of characters corresponding to the
 231 -- unread portion of the channel or file managed by the handle, which
 232 -- is made semi-closed.
 233
 234 -- hGetContents on a DuplexHandle only affects the read side: you can
 235 -- carry on writing to it afterwards.
 236
 237 hGetContents :: Handle -> IO String
 238 hGetContents handle =
 239     withHandle "hGetContents" handle $ \handle_ ->
 240     case haType handle_ of
 241       ClosedHandle         -> ioe_closedHandle
 242       SemiClosedHandle     -> ioe_closedHandle
 243       AppendHandle         -> ioe_notReadable
 244       WriteHandle          -> ioe_notReadable
 245       _ -> do xs <- lazyRead handle
 246               return (handle_{ haType=SemiClosedHandle}, xs )
 247
 248 -- Note that someone may close the semi-closed handle (or change its
 249 -- buffering), so each time these lazy read functions are pulled on,
 250 -- they have to check whether the handle has indeed been closed.
 251
 252 lazyRead :: Handle -> IO String
 253 lazyRead handle =
 254    unsafeInterleaveIO $
 255         withHandle "lazyRead" handle $ \ handle_ -> do
 256         case haType handle_ of
 257           ClosedHandle     -> return (handle_, "")
 258           SemiClosedHandle -> lazyRead' handle handle_
 259           _ -> ioException
 260                   (IOError (Just handle) IllegalOperation "lazyRead"
 261                         "illegal handle type" Nothing)
 262
 263 lazyRead' h handle_ = do
 264   let ref = haBuffer handle_
 265       fd  = haFD handle_
 266
 267   -- even a NoBuffering handle can have a char in the buffer...
 268   -- (see hLookAhead)
 269   buf <- readIORef ref
 270   if not (bufferEmpty buf)
 271         then lazyReadHaveBuffer h handle_ fd ref buf
 272         else do
 273
 274   case haBufferMode handle_ of
 275      NoBuffering      -> do
 276         -- make use of the minimal buffer we already have
 277         let raw = bufBuf buf
 278             fd  = haFD handle_
 279         r <- throwErrnoIfMinus1RetryMayBlock "lazyRead"
 280                 (read_off (fromIntegral fd) raw 0 1)
 281                 (threadWaitRead fd)
 282         if r == 0
 283            then do handle_ <- hClose_help handle_
 284                    return (handle_, "")
 285            else do (c,_) <- readCharFromBuffer raw 0
 286                    rest <- lazyRead h
 287                    return (handle_, c : rest)
 288
 289      LineBuffering    -> lazyReadBuffered h handle_ fd ref buf
 290      BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
 291
 292 -- we never want to block during the read, so we call fillReadBuffer with
 293 -- is_line==True, which tells it to "just read what there is".
 294 lazyReadBuffered h handle_ fd ref buf = do
 295    catch
 296         (do buf <- fillReadBuffer fd True{-is_line-} buf
 297             lazyReadHaveBuffer h handle_ fd ref buf
 298         )
 299         -- all I/O errors are discarded.  Additionally, we close the handle.
 300         (\e -> do handle_ <- hClose_help handle_
 301                   return (handle_, "")
 302         )
 303
 304 lazyReadHaveBuffer h handle_ fd ref buf = do
 305    more <- lazyRead h
 306    writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
 307    s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
 308    return (handle_, s)
 309
 310
 311 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
 312 unpackAcc buf r 0 acc  = return ""
 313 unpackAcc buf (I## r) (I## len) acc = IO $ \s -> unpack acc (len -## 1##) s
 314    where
 315     unpack acc i s
 316      | i <## r  = (## s, acc ##)
 317      | otherwise =
 318           case readCharArray## buf i s of
 319             (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
 320
 321 -- ---------------------------------------------------------------------------
 322 -- hPutChar
 323
 324 -- `hPutChar hdl ch' writes the character `ch' to the file or channel
 325 -- managed by `hdl'.  Characters may be buffered if buffering is
 326 -- enabled for `hdl'.
 327
 328 hPutChar :: Handle -> Char -> IO ()
 329 hPutChar handle c =
 330     c `seq` do   -- must evaluate c before grabbing the handle lock
 331     wantWritableHandle "hPutChar" handle $ \ handle_  -> do
 332     let fd = haFD handle_
 333     case haBufferMode handle_ of
 334         LineBuffering    -> hPutcBuffered handle_ True  c
 335         BlockBuffering _ -> hPutcBuffered handle_ False c
 336         NoBuffering      ->
 337                 withObject (castCharToCChar c) $ \buf ->
 338                 throwErrnoIfMinus1RetryMayBlock_ "hPutChar"
 339                    (c_write (fromIntegral fd) buf 1)
 340                    (threadWaitWrite fd)
 341
 342
 343 hPutcBuffered handle_ is_line c = do
 344   let ref = haBuffer handle_
 345   buf <- readIORef ref
 346   let w = bufWPtr buf
 347   w'  <- writeCharIntoBuffer (bufBuf buf) w c
 348   let new_buf = buf{ bufWPtr = w' }
 349   if bufferFull new_buf || is_line && c == '\n'
 350      then do
 351         flushed_buf <- flushWriteBuffer (haFD handle_) new_buf
 352         writeIORef ref flushed_buf
 353      else do
 354         writeIORef ref new_buf
 355
 356
 357 hPutChars :: Handle -> [Char] -> IO ()
 358 hPutChars handle [] = return ()
 359 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
 360
 361 -- ---------------------------------------------------------------------------
 362 -- hPutStr
 363
 364 -- `hPutStr hdl s' writes the string `s' to the file or
 365 -- hannel managed by `hdl', buffering the output if needs be.
 366
 367 -- We go to some trouble to avoid keeping the handle locked while we're
 368 -- evaluating the string argument to hPutStr, in case doing so triggers another
 369 -- I/O operation on the same handle which would lead to deadlock.  The classic
 370 -- case is
 371 --
 372 --              putStr (trace "hello" "world")
 373 --
 374 -- so the basic scheme is this:
 375 --
 376 --      * copy the string into a fresh buffer,
 377 --      * "commit" the buffer to the handle.
 378 --
 379 -- Committing may involve simply copying the contents of the new
 380 -- buffer into the handle's buffer, flushing one or both buffers, or
 381 -- maybe just swapping the buffers over (if the handle's buffer was
 382 -- empty).  See commitBuffer below.
 383
 384 hPutStr :: Handle -> String -> IO ()
 385 hPutStr handle str = do
 386     buffer_mode <- wantWritableHandle "hPutStr" handle
 387                         (\ handle_ -> do getSpareBuffer handle_)
 388     case buffer_mode of
 389        (NoBuffering, _) -> do
 390             hPutChars handle str        -- v. slow, but we don't care
 391        (LineBuffering, buf) -> do
 392             writeLines handle buf str
 393        (BlockBuffering _, buf) -> do
 394             writeBlocks handle buf str
 395
 396
 397 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
 398 getSpareBuffer Handle__{haBuffer=ref,
 399                         haBuffers=spare_ref,
 400                         haBufferMode=mode}
 401  = do
 402    case mode of
 403      NoBuffering -> return (mode, error "no buffer!")
 404      _ -> do
 405           bufs <- readIORef spare_ref
 406           buf  <- readIORef ref
 407           case bufs of
 408             BufferListCons b rest -> do
 409                 writeIORef spare_ref rest
 410                 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
 411             BufferListNil -> do
 412                 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
 413                 return (mode, new_buf)
 414
 415
 416 writeLines :: Handle -> Buffer -> String -> IO ()
 417 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
 418   let
 419    shoveString :: Int -> [Char] -> IO ()
 420         -- check n == len first, to ensure that shoveString is strict in n.
 421    shoveString n cs | n == len = do
 422         new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
 423         writeBlocks hdl new_buf cs
 424    shoveString n [] = do
 425         commitBuffer hdl raw len n False{-no flush-} True{-release-}
 426         return ()
 427    shoveString n (c:cs) = do
 428         n' <- writeCharIntoBuffer raw n c
 429         shoveString n' cs
 430   in
 431   shoveString 0 s
 432
 433 writeBlocks :: Handle -> Buffer -> String -> IO ()
 434 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
 435   let
 436    shoveString :: Int -> [Char] -> IO ()
 437         -- check n == len first, to ensure that shoveString is strict in n.
 438    shoveString n cs | n == len = do
 439         new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
 440         writeBlocks hdl new_buf cs
 441    shoveString n [] = do
 442         commitBuffer hdl raw len n False{-no flush-} True{-release-}
 443         return ()
 444    shoveString n (c:cs) = do
 445         n' <- writeCharIntoBuffer raw n c
 446         shoveString n' cs
 447   in
 448   shoveString 0 s
 449
 450 -- -----------------------------------------------------------------------------
 451 -- commitBuffer handle buf sz count flush release
 452 --
 453 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
 454 -- 'count' bytes of data) to handle (handle must be block or line buffered).
 455 --
 456 -- Implementation:
 457 --
 458 --    for block/line buffering,
 459 --       1. If there isn't room in the handle buffer, flush the handle
 460 --          buffer.
 461 --
 462 --       2. If the handle buffer is empty,
 463 --               if flush,
 464 --                   then write buf directly to the device.
 465 --                   else swap the handle buffer with buf.
 466 --
 467 --       3. If the handle buffer is non-empty, copy buf into the
 468 --          handle buffer.  Then, if flush != 0, flush
 469 --          the buffer.
 470
 471 commitBuffer
 472         :: Handle                       -- handle to commit to
 473         -> RawBuffer -> Int             -- address and size (in bytes) of buffer
 474         -> Int                          -- number of bytes of data in buffer
 475         -> Bool                         -- flush the handle afterward?
 476         -> Bool                         -- release the buffer?
 477         -> IO Buffer
 478
 479 commitBuffer hdl raw sz count flush release = do
 480   wantWritableHandle "commitAndReleaseBuffer" hdl $
 481     \ handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } -> do
 482
 483 #ifdef DEBUG_DUMP
 484       puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
 485             ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
 486 #endif
 487
 488       old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
 489           <- readIORef ref
 490
 491       buf_ret <-
 492         -- enough room in handle buffer?
 493          if (not flush && (size - w > count))
 494                 -- The > is to be sure that we never exactly fill
 495                 -- up the buffer, which would require a flush.  So
 496                 -- if copying the new data into the buffer would
 497                 -- make the buffer full, we just flush the existing
 498                 -- buffer and the new data immediately, rather than
 499                 -- copying before flushing.
 500
 501                 -- not flushing, and there's enough room in the buffer:
 502                 -- just copy the data in and update bufWPtr.
 503             then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
 504                     writeIORef ref old_buf{ bufWPtr = w + count }
 505                     return (newEmptyBuffer raw WriteBuffer sz)
 506
 507                 -- else, we have to flush
 508             else do flushed_buf <- flushWriteBuffer fd old_buf
 509
 510                     let this_buf =
 511                             Buffer{ bufBuf=raw, bufState=WriteBuffer,
 512                                     bufRPtr=0, bufWPtr=count, bufSize=sz }
 513
 514                         -- if:  (a) we don't have to flush, and
 515                         --      (b) size(new buffer) == size(old buffer), and
 516                         --      (c) new buffer is not full,
 517                         -- we can just just swap them over...
 518                     if (not flush && sz == size && count /= sz)
 519                         then do
 520                           writeIORef ref this_buf
 521                           return flushed_buf
 522
 523                         -- otherwise, we have to flush the new data too,
 524                         -- and start with a fresh buffer
 525                         else do
 526                           flushWriteBuffer fd this_buf
 527                           writeIORef ref flushed_buf
 528                             -- if the sizes were different, then allocate
 529                             -- a new buffer of the correct size.
 530                           if sz == size
 531                              then return (newEmptyBuffer raw WriteBuffer sz)
 532                              else allocateBuffer size WriteBuffer
 533
 534       -- release the buffer if necessary
 535       if release && bufSize buf_ret == size
 536          then do
 537               spare_bufs <- readIORef spare_buf_ref
 538               writeIORef spare_buf_ref
 539                 (BufferListCons (bufBuf buf_ret) spare_bufs)
 540               return buf_ret
 541          else
 542               return buf_ret
 543
 544 -- ---------------------------------------------------------------------------
 545 -- Reading/writing sequences of bytes.
 546
 547 {-
 548 Semantics of hGetBuf:
 549
 550    - hGetBuf reads data into the buffer until either
 551
 552         (a) EOF is reached
 553         (b) the buffer is full
 554
 555      It returns the amount of data actually read.  This may
 556      be zero in case (a).  hGetBuf never raises
 557      an EOF exception, it always returns zero instead.
 558
 559      If the handle is a pipe or socket, and the writing end
 560      is closed, hGetBuf will behave as for condition (a).
 561
 562 Semantics of hPutBuf:
 563
 564     - hPutBuf writes data from the buffer to the handle
 565       until the buffer is empty.  It returns ().
 566
 567       If the handle is a pipe or socket, and the reading end is
 568       closed, hPutBuf will raise a ResourceVanished exception.
 569       (If this is a POSIX system, and the program has not
 570       asked to ignore SIGPIPE, then a SIGPIPE may be delivered
 571       instead, whose default action is to terminate the program).
 572 -}
 573
 574 -- ---------------------------------------------------------------------------
 575 -- hPutBuf
 576
 577 hPutBuf :: Handle                       -- handle to write to
 578         -> Ptr a                        -- address of buffer
 579         -> Int                          -- number of bytes of data in buffer
 580         -> IO ()
 581 hPutBuf handle ptr count
 582   | count <= 0 = illegalBufferSize handle "hPutBuf" count
 583   | otherwise =
 584     wantWritableHandle "hPutBuf" handle $
 585       \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> do
 586
 587         old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
 588           <- readIORef ref
 589
 590         -- enough room in handle buffer?
 591         if (size - w > count)
 592                 -- There's enough room in the buffer:
 593                 -- just copy the data in and update bufWPtr.
 594             then do memcpy_baoff_ptr old_raw w ptr (fromIntegral count)
 595                     writeIORef ref old_buf{ bufWPtr = w + count }
 596                     return ()
 597
 598                 -- else, we have to flush
 599             else do flushed_buf <- flushWriteBuffer fd old_buf
 600                     writeIORef ref flushed_buf
 601                     -- ToDo: should just memcpy instead of writing if possible
 602                     writeChunk fd ptr count
 603
 604 writeChunk :: FD -> Ptr a -> Int -> IO ()
 605 writeChunk fd ptr bytes = loop 0 bytes
 606  where
 607   loop :: Int -> Int -> IO ()
 608   loop _   bytes | bytes <= 0 = return ()
 609   loop off bytes = do
 610     r <- fromIntegral `liftM`
 611            throwErrnoIfMinus1RetryMayBlock "writeChunk"
 612             (c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes))
 613             (threadWaitWrite fd)
 614     -- write can't return 0
 615     loop (off + r) (bytes - r)
 616
 617 -- ---------------------------------------------------------------------------
 618 -- hGetBuf
 619
 620 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
 621 hGetBuf handle ptr count
 622   | count <= 0 = illegalBufferSize handle "hGetBuf" count
 623   | otherwise =
 624       wantReadableHandle "hGetBuf" handle $
 625         \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> do
 626         buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref
 627         if bufferEmpty buf
 628            then readChunk fd ptr count
 629            else do
 630                 let avail = w - r
 631                 copied <- if (count >= avail)
 632                             then do
 633                                 memcpy_ptr_baoff ptr raw r (fromIntegral avail)
 634                                 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
 635                                 return avail
 636                             else do
 637                                 memcpy_ptr_baoff ptr raw r (fromIntegral count)
 638                                 writeIORef ref buf{ bufRPtr = r + count }
 639                                 return count
 640
 641                 let remaining = count - copied
 642                 if remaining > 0
 643                    then do rest <- readChunk fd (ptr `plusPtr` copied) remaining
 644                            return (rest + count)
 645                    else return count
 646
 647 readChunk :: FD -> Ptr a -> Int -> IO Int
 648 readChunk fd ptr bytes = loop 0 bytes
 649  where
 650   loop :: Int -> Int -> IO Int
 651   loop off bytes | bytes <= 0 = return off
 652   loop off bytes = do
 653     r <- fromIntegral `liftM`
 654            throwErrnoIfMinus1RetryMayBlock "readChunk"
 655             (c_read (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes))
 656             (threadWaitRead fd)
 657     if r == 0
 658         then return off
 659         else loop (off + r) (bytes - r)
 660
 661 slurpFile :: FilePath -> IO (Ptr (), Int)
 662 slurpFile fname = do
 663   handle <- openFile fname ReadMode
 664   sz     <- hFileSize handle
 665   if sz > fromIntegral (maxBound::Int) then
 666     ioError (userError "slurpFile: file too big")
 667    else do
 668     let sz_i = fromIntegral sz
 669     chunk <- mallocBytes sz_i
 670     r <- hGetBuf handle chunk sz_i
 671     hClose handle
 672     return (chunk, r)
 673
 674 -- ---------------------------------------------------------------------------
 675 -- hGetBufBA
 676
 677 hGetBufBA :: Handle -> MutableByteArray RealWorld a -> Int -> IO Int
 678 hGetBufBA handle (MutableByteArray _ _ ptr) count
 679   | count <= 0 = illegalBufferSize handle "hGetBuf" count
 680   | otherwise =
 681       wantReadableHandle "hGetBuf" handle $
 682         \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> do
 683         buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref
 684         if bufferEmpty buf
 685            then readChunkBA fd ptr 0 count
 686            else do
 687                 let avail = w - r
 688                 copied <- if (count >= avail)
 689                             then do
 690                                 memcpy_ba_baoff ptr raw r (fromIntegral avail)
 691                                 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
 692                                 return avail
 693                             else do
 694                                 memcpy_ba_baoff ptr raw r (fromIntegral count)
 695                                 writeIORef ref buf{ bufRPtr = r + count }
 696                                 return count
 697
 698                 let remaining = count - copied
 699                 if remaining > 0
 700                    then do rest <- readChunkBA fd ptr copied remaining
 701                            return (rest + count)
 702                    else return count
 703
 704 readChunkBA :: FD -> RawBuffer -> Int -> Int -> IO Int
 705 readChunkBA fd ptr init_off bytes = loop init_off bytes
 706  where
 707   loop :: Int -> Int -> IO Int
 708   loop off bytes | bytes <= 0 = return (off - init_off)
 709   loop off bytes = do
 710     r <- fromIntegral `liftM`
 711            throwErrnoIfMinus1RetryMayBlock "readChunk"
 712             (readBA (fromIntegral fd) ptr
 713                 (fromIntegral off) (fromIntegral bytes))
 714             (threadWaitRead fd)
 715     if r == 0
 716         then return (off - init_off)
 717         else loop (off + r) (bytes - r)
 718
 719 foreign import "read_ba_wrap" unsafe
 720    readBA :: FD -> RawBuffer -> Int -> CInt -> IO CInt
 721 #def inline \
 722 int read_ba_wrap(int fd, void *ptr, HsInt off, int size) \
 723 { return read(fd, ptr + off, size); }
 724
 725 -- -----------------------------------------------------------------------------
 726 -- hPutBufBA
 727
 728 hPutBufBA
 729         :: Handle                       -- handle to write to
 730         -> MutableByteArray RealWorld a -- buffer
 731         -> Int                          -- number of bytes of data in buffer
 732         -> IO ()
 733
 734 hPutBufBA handle (MutableByteArray _ _ raw) count
 735   | count <= 0 = illegalBufferSize handle "hPutBufBA" count
 736   | otherwise = do
 737     wantWritableHandle "hPutBufBA" handle $
 738       \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> do
 739
 740         old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
 741           <- readIORef ref
 742
 743         -- enough room in handle buffer?
 744         if (size - w > count)
 745                 -- There's enough room in the buffer:
 746                 -- just copy the data in and update bufWPtr.
 747             then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
 748                     writeIORef ref old_buf{ bufWPtr = w + count }
 749                     return ()
 750
 751                 -- else, we have to flush
 752             else do flushed_buf <- flushWriteBuffer fd old_buf
 753                     writeIORef ref flushed_buf
 754                     let this_buf =
 755                             Buffer{ bufBuf=raw, bufState=WriteBuffer,
 756                                     bufRPtr=0, bufWPtr=count, bufSize=count }
 757                     flushWriteBuffer fd this_buf
 758                     return ()
 759
 760 -- ---------------------------------------------------------------------------
 761 -- memcpy wrappers
 762
 763 foreign import "memcpy_wrap_src_off" unsafe
 764    memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
 765 foreign import "memcpy_wrap_src_off" unsafe
 766    memcpy_ptr_baoff :: Ptr a -> RawBuffer -> Int -> CSize -> IO (Ptr ())
 767 foreign import "memcpy_wrap_dst_off" unsafe
 768    memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
 769 foreign import "memcpy_wrap_dst_off" unsafe
 770    memcpy_baoff_ptr :: RawBuffer -> Int -> Ptr a -> CSize -> IO (Ptr ())
 771
 772 #def inline \
 773 void *memcpy_wrap_dst_off(char *dst, int dst_off, char *src, size_t sz) \
 774 { return memcpy(dst+dst_off, src, sz); }
 775
 776 #def inline \
 777 void *memcpy_wrap_src_off(char *dst, char *src, int src_off, size_t sz) \
 778 { return memcpy(dst, src+src_off, sz); }
 779
 780 -----------------------------------------------------------------------------
 781 -- Internal Utils
 782
 783 illegalBufferSize :: Handle -> String -> Int -> IO a
 784 illegalBufferSize handle fn (sz :: Int) =
 785         ioException (IOError (Just handle)
 786                             InvalidArgument  fn
 787                             ("illegal buffer size " ++ showsPrec 9 sz [])
 788                             Nothing)