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