ghc/lib/std/PrelIO.hsc

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