ghc/lib/std/PrelIO.hsc

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