1 {-# OPTIONS -fno-implicit-prelude -#include "HsCore.h" #-}
5 -- -----------------------------------------------------------------------------
6 -- $Id: IO.hs,v 1.1 2001/12/21 15:07:23 simonmar Exp $
8 -- (c) The University of Glasgow, 1992-2001
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
18 putChar, putStr, putStrLn, print, getChar, getLine, getContents,
19 interact, readFile, writeFile, appendFile, readLn, readIO, hReady,
20 hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
22 commitBuffer', -- hack, see below
23 hGetcBuffered, -- needed by ghc/compiler/utils/StringBuffer.lhs
24 hGetBuf, hPutBuf, slurpFile
37 import GHC.Handle -- much of the real stuff is in here
42 import GHC.Exception ( ioError, catch, throw )
45 -- ---------------------------------------------------------------------------
46 -- Simple input operations
48 -- Computation "hReady hdl" indicates whether at least
49 -- one item is available for input from handle "hdl".
51 -- If hWaitForInput finds anything in the Handle's buffer, it
52 -- immediately returns. If not, it tries to read from the underlying
53 -- OS handle. Notice that for buffered Handles connected to terminals
54 -- this means waiting until a complete line is available.
56 hWaitForInput :: Handle -> Int -> IO Bool
57 hWaitForInput h msecs = do
58 wantReadableHandle "hReady" h $ \ handle_ -> do
59 let ref = haBuffer handle_
62 if not (bufferEmpty buf)
66 r <- throwErrnoIfMinus1Retry "hReady"
67 (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs) (haIsStream handle_))
70 foreign import "inputReady" unsafe
71 inputReady :: CInt -> CInt -> Bool -> IO CInt
73 -- ---------------------------------------------------------------------------
76 -- hGetChar reads the next character from a handle,
77 -- blocking until a character is available.
79 hGetChar :: Handle -> IO Char
81 wantReadableHandle "hGetChar" handle $ \handle_ -> do
84 ref = haBuffer handle_
87 if not (bufferEmpty buf)
88 then hGetcBuffered fd ref buf
92 case haBufferMode handle_ of
94 new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
95 hGetcBuffered fd ref new_buf
96 BlockBuffering _ -> do
97 new_buf <- fillReadBuffer fd False (haIsStream handle_) buf
98 hGetcBuffered fd ref new_buf
100 -- make use of the minimal buffer we already have
102 r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
103 (read_off (fromIntegral fd) (haIsStream handle_) raw 0 1)
107 else do (c,_) <- readCharFromBuffer raw 0
110 hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
111 = do (c,r) <- readCharFromBuffer b r
112 let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
113 | otherwise = buf{ bufRPtr=r }
114 writeIORef ref new_buf
117 -- ---------------------------------------------------------------------------
120 -- If EOF is reached before EOL is encountered, ignore the EOF and
121 -- return the partial line. Next attempt at calling hGetLine on the
122 -- handle will yield an EOF IO exception though.
124 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
126 hGetLine :: Handle -> IO String
128 m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
129 case haBufferMode handle_ of
130 NoBuffering -> return Nothing
132 l <- hGetLineBuffered handle_
134 BlockBuffering _ -> do
135 l <- hGetLineBuffered handle_
138 Nothing -> hGetLineUnBuffered h
142 hGetLineBuffered handle_ = do
143 let ref = haBuffer handle_
145 hGetLineBufferedLoop handle_ ref buf []
148 hGetLineBufferedLoop handle_ ref
149 buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
151 -- find the end-of-line character, if there is one
153 | r == w = return (False, w)
155 (c,r') <- readCharFromBuffer raw r
157 then return (True, r) -- NB. not r': don't include the '\n'
160 (eol, off) <- loop raw r
163 puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
166 xs <- unpack raw r off
168 then do if w == off + 1
169 then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
170 else writeIORef ref buf{ bufRPtr = off + 1 }
171 return (concat (reverse (xs:xss)))
173 maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
174 buf{ bufWPtr=0, bufRPtr=0 }
176 -- Nothing indicates we caught an EOF, and we may have a
177 -- partial line to return.
178 Nothing -> let str = concat (reverse (xs:xss)) in
183 hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
186 maybeFillReadBuffer fd is_line is_stream buf
188 (do buf <- fillReadBuffer fd is_line is_stream buf
191 (\e -> do if isEOFError e
196 unpack :: RawBuffer -> Int -> Int -> IO [Char]
197 unpack buf r 0 = return ""
198 unpack buf (I## r) (I## len) = IO $ \s -> unpack [] (len -## 1##) s
201 | i <## r = (## s, acc ##)
203 case readCharArray## buf i s of
204 (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
207 hGetLineUnBuffered :: Handle -> IO String
208 hGetLineUnBuffered h = do
221 if isEOFError err then
231 -- -----------------------------------------------------------------------------
234 -- hGetContents returns the list of characters corresponding to the
235 -- unread portion of the channel or file managed by the handle, which
236 -- is made semi-closed.
238 -- hGetContents on a DuplexHandle only affects the read side: you can
239 -- carry on writing to it afterwards.
241 hGetContents :: Handle -> IO String
242 hGetContents handle =
243 withHandle "hGetContents" handle $ \handle_ ->
244 case haType handle_ of
245 ClosedHandle -> ioe_closedHandle
246 SemiClosedHandle -> ioe_closedHandle
247 AppendHandle -> ioe_notReadable
248 WriteHandle -> ioe_notReadable
249 _ -> do xs <- lazyRead handle
250 return (handle_{ haType=SemiClosedHandle}, xs )
252 -- Note that someone may close the semi-closed handle (or change its
253 -- buffering), so each time these lazy read functions are pulled on,
254 -- they have to check whether the handle has indeed been closed.
256 lazyRead :: Handle -> IO String
259 withHandle "lazyRead" handle $ \ handle_ -> do
260 case haType handle_ of
261 ClosedHandle -> return (handle_, "")
262 SemiClosedHandle -> lazyRead' handle handle_
264 (IOError (Just handle) IllegalOperation "lazyRead"
265 "illegal handle type" Nothing)
267 lazyRead' h handle_ = do
268 let ref = haBuffer handle_
271 -- even a NoBuffering handle can have a char in the buffer...
274 if not (bufferEmpty buf)
275 then lazyReadHaveBuffer h handle_ fd ref buf
278 case haBufferMode handle_ of
280 -- make use of the minimal buffer we already have
282 r <- throwErrnoIfMinus1RetryMayBlock "lazyRead"
283 (read_off (fromIntegral fd) (haIsStream handle_) raw 0 1)
286 then do handle_ <- hClose_help handle_
288 else do (c,_) <- readCharFromBuffer raw 0
290 return (handle_, c : rest)
292 LineBuffering -> lazyReadBuffered h handle_ fd ref buf
293 BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
295 -- we never want to block during the read, so we call fillReadBuffer with
296 -- is_line==True, which tells it to "just read what there is".
297 lazyReadBuffered h handle_ fd ref buf = do
299 (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
300 lazyReadHaveBuffer h handle_ fd ref buf
302 -- all I/O errors are discarded. Additionally, we close the handle.
303 (\e -> do handle_ <- hClose_help handle_
307 lazyReadHaveBuffer h handle_ fd ref buf = do
309 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
310 s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
314 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
315 unpackAcc buf r 0 acc = return ""
316 unpackAcc buf (I## r) (I## len) acc = IO $ \s -> unpack acc (len -## 1##) s
319 | i <## r = (## s, acc ##)
321 case readCharArray## buf i s of
322 (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
324 -- ---------------------------------------------------------------------------
327 -- `hPutChar hdl ch' writes the character `ch' to the file or channel
328 -- managed by `hdl'. Characters may be buffered if buffering is
329 -- enabled for `hdl'.
331 hPutChar :: Handle -> Char -> IO ()
333 c `seq` do -- must evaluate c before grabbing the handle lock
334 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
335 let fd = haFD handle_
336 case haBufferMode handle_ of
337 LineBuffering -> hPutcBuffered handle_ True c
338 BlockBuffering _ -> hPutcBuffered handle_ False c
340 withObject (castCharToCChar c) $ \buf ->
341 throwErrnoIfMinus1RetryMayBlock_ "hPutChar"
342 (c_write (fromIntegral fd) buf 1)
346 hPutcBuffered handle_ is_line c = do
347 let ref = haBuffer handle_
350 w' <- writeCharIntoBuffer (bufBuf buf) w c
351 let new_buf = buf{ bufWPtr = w' }
352 if bufferFull new_buf || is_line && c == '\n'
354 flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf
355 writeIORef ref flushed_buf
357 writeIORef ref new_buf
360 hPutChars :: Handle -> [Char] -> IO ()
361 hPutChars handle [] = return ()
362 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
364 -- ---------------------------------------------------------------------------
367 -- `hPutStr hdl s' writes the string `s' to the file or
368 -- hannel managed by `hdl', buffering the output if needs be.
370 -- We go to some trouble to avoid keeping the handle locked while we're
371 -- evaluating the string argument to hPutStr, in case doing so triggers another
372 -- I/O operation on the same handle which would lead to deadlock. The classic
375 -- putStr (trace "hello" "world")
377 -- so the basic scheme is this:
379 -- * copy the string into a fresh buffer,
380 -- * "commit" the buffer to the handle.
382 -- Committing may involve simply copying the contents of the new
383 -- buffer into the handle's buffer, flushing one or both buffers, or
384 -- maybe just swapping the buffers over (if the handle's buffer was
385 -- empty). See commitBuffer below.
387 hPutStr :: Handle -> String -> IO ()
388 hPutStr handle str = do
389 buffer_mode <- wantWritableHandle "hPutStr" handle
390 (\ handle_ -> do getSpareBuffer handle_)
392 (NoBuffering, _) -> do
393 hPutChars handle str -- v. slow, but we don't care
394 (LineBuffering, buf) -> do
395 writeLines handle buf str
396 (BlockBuffering _, buf) -> do
397 writeBlocks handle buf str
400 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
401 getSpareBuffer Handle__{haBuffer=ref,
406 NoBuffering -> return (mode, error "no buffer!")
408 bufs <- readIORef spare_ref
411 BufferListCons b rest -> do
412 writeIORef spare_ref rest
413 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
415 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
416 return (mode, new_buf)
419 writeLines :: Handle -> Buffer -> String -> IO ()
420 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
422 shoveString :: Int -> [Char] -> IO ()
423 -- check n == len first, to ensure that shoveString is strict in n.
424 shoveString n cs | n == len = do
425 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
426 writeLines hdl new_buf cs
427 shoveString n [] = do
428 commitBuffer hdl raw len n False{-no flush-} True{-release-}
430 shoveString n (c:cs) = do
431 n' <- writeCharIntoBuffer raw n c
434 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
435 writeLines hdl new_buf cs
441 writeBlocks :: Handle -> Buffer -> String -> IO ()
442 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
444 shoveString :: Int -> [Char] -> IO ()
445 -- check n == len first, to ensure that shoveString is strict in n.
446 shoveString n cs | n == len = do
447 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
448 writeBlocks hdl new_buf cs
449 shoveString n [] = do
450 commitBuffer hdl raw len n False{-no flush-} True{-release-}
452 shoveString n (c:cs) = do
453 n' <- writeCharIntoBuffer raw n c
458 -- -----------------------------------------------------------------------------
459 -- commitBuffer handle buf sz count flush release
461 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
462 -- 'count' bytes of data) to handle (handle must be block or line buffered).
466 -- for block/line buffering,
467 -- 1. If there isn't room in the handle buffer, flush the handle
470 -- 2. If the handle buffer is empty,
472 -- then write buf directly to the device.
473 -- else swap the handle buffer with buf.
475 -- 3. If the handle buffer is non-empty, copy buf into the
476 -- handle buffer. Then, if flush != 0, flush
480 :: Handle -- handle to commit to
481 -> RawBuffer -> Int -- address and size (in bytes) of buffer
482 -> Int -- number of bytes of data in buffer
483 -> Bool -- True <=> flush the handle afterward
484 -> Bool -- release the buffer?
487 commitBuffer hdl raw sz@(I## _) count@(I## _) flush release = do
488 wantWritableHandle "commitAndReleaseBuffer" hdl $
489 commitBuffer' hdl raw sz count flush release
491 -- Explicitly lambda-lift this function to subvert GHC's full laziness
492 -- optimisations, which otherwise tends to float out subexpressions
493 -- past the \handle, which is really a pessimisation in this case because
494 -- that lambda is a one-shot lambda.
496 -- Don't forget to export the function, to stop it being inlined too
497 -- (this appears to be better than NOINLINE, because the strictness
498 -- analyser still gets to worker-wrapper it).
500 -- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
502 commitBuffer' hdl raw sz@(I## _) count@(I## _) flush release
503 handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
506 puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
507 ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
510 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
514 -- enough room in handle buffer?
515 if (not flush && (size - w > count))
516 -- The > is to be sure that we never exactly fill
517 -- up the buffer, which would require a flush. So
518 -- if copying the new data into the buffer would
519 -- make the buffer full, we just flush the existing
520 -- buffer and the new data immediately, rather than
521 -- copying before flushing.
523 -- not flushing, and there's enough room in the buffer:
524 -- just copy the data in and update bufWPtr.
525 then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
526 writeIORef ref old_buf{ bufWPtr = w + count }
527 return (newEmptyBuffer raw WriteBuffer sz)
529 -- else, we have to flush
530 else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf
533 Buffer{ bufBuf=raw, bufState=WriteBuffer,
534 bufRPtr=0, bufWPtr=count, bufSize=sz }
536 -- if: (a) we don't have to flush, and
537 -- (b) size(new buffer) == size(old buffer), and
538 -- (c) new buffer is not full,
539 -- we can just just swap them over...
540 if (not flush && sz == size && count /= sz)
542 writeIORef ref this_buf
545 -- otherwise, we have to flush the new data too,
546 -- and start with a fresh buffer
548 flushWriteBuffer fd (haIsStream handle_) this_buf
549 writeIORef ref flushed_buf
550 -- if the sizes were different, then allocate
551 -- a new buffer of the correct size.
553 then return (newEmptyBuffer raw WriteBuffer sz)
554 else allocateBuffer size WriteBuffer
556 -- release the buffer if necessary
558 Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
559 if release && buf_ret_sz == size
561 spare_bufs <- readIORef spare_buf_ref
562 writeIORef spare_buf_ref
563 (BufferListCons buf_ret_raw spare_bufs)
568 -- ---------------------------------------------------------------------------
569 -- Reading/writing sequences of bytes.
572 Semantics of hGetBuf:
574 - hGetBuf reads data into the buffer until either
577 (b) the buffer is full
579 It returns the amount of data actually read. This may
580 be zero in case (a). hGetBuf never raises
581 an EOF exception, it always returns zero instead.
583 If the handle is a pipe or socket, and the writing end
584 is closed, hGetBuf will behave as for condition (a).
586 Semantics of hPutBuf:
588 - hPutBuf writes data from the buffer to the handle
589 until the buffer is empty. It returns ().
591 If the handle is a pipe or socket, and the reading end is
592 closed, hPutBuf will raise a ResourceVanished exception.
593 (If this is a POSIX system, and the program has not
594 asked to ignore SIGPIPE, then a SIGPIPE may be delivered
595 instead, whose default action is to terminate the program).
598 -- ---------------------------------------------------------------------------
601 hPutBuf :: Handle -- handle to write to
602 -> Ptr a -- address of buffer
603 -> Int -- number of bytes of data in buffer
605 hPutBuf handle ptr count
606 | count <= 0 = illegalBufferSize handle "hPutBuf" count
608 wantWritableHandle "hPutBuf" handle $
609 \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> do
611 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
614 -- enough room in handle buffer?
615 if (size - w > count)
616 -- There's enough room in the buffer:
617 -- just copy the data in and update bufWPtr.
618 then do memcpy_baoff_ptr old_raw w ptr (fromIntegral count)
619 writeIORef ref old_buf{ bufWPtr = w + count }
622 -- else, we have to flush
623 else do flushed_buf <- flushWriteBuffer fd old_buf
624 writeIORef ref flushed_buf
625 -- ToDo: should just memcpy instead of writing if possible
626 writeChunk fd ptr count
628 writeChunk :: FD -> Ptr a -> Int -> IO ()
629 writeChunk fd ptr bytes = loop 0 bytes
631 loop :: Int -> Int -> IO ()
632 loop _ bytes | bytes <= 0 = return ()
634 r <- fromIntegral `liftM`
635 throwErrnoIfMinus1RetryMayBlock "writeChunk"
636 (c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes))
638 -- write can't return 0
639 loop (off + r) (bytes - r)
641 -- ---------------------------------------------------------------------------
644 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
645 hGetBuf handle ptr count
646 | count <= 0 = illegalBufferSize handle "hGetBuf" count
648 wantReadableHandle "hGetBuf" handle $
649 \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> do
650 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref
652 then readChunk fd ptr count
655 copied <- if (count >= avail)
657 memcpy_ptr_baoff ptr raw r (fromIntegral avail)
658 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
661 memcpy_ptr_baoff ptr raw r (fromIntegral count)
662 writeIORef ref buf{ bufRPtr = r + count }
665 let remaining = count - copied
667 then do rest <- readChunk fd (ptr `plusPtr` copied) remaining
668 return (rest + count)
671 readChunk :: FD -> Ptr a -> Int -> IO Int
672 readChunk fd ptr bytes = loop 0 bytes
674 loop :: Int -> Int -> IO Int
675 loop off bytes | bytes <= 0 = return off
677 r <- fromIntegral `liftM`
678 throwErrnoIfMinus1RetryMayBlock "readChunk"
679 (c_read (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes))
683 else loop (off + r) (bytes - r)
685 slurpFile :: FilePath -> IO (Ptr (), Int)
687 handle <- openFile fname ReadMode
688 sz <- hFileSize handle
689 if sz > fromIntegral (maxBound::Int) then
690 ioError (userError "slurpFile: file too big")
692 let sz_i = fromIntegral sz
693 chunk <- mallocBytes sz_i
694 r <- hGetBuf handle chunk sz_i
698 -- ---------------------------------------------------------------------------
701 foreign import "__hscore_memcpy_src_off" unsafe
702 memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
703 foreign import "__hscore_memcpy_src_off" unsafe
704 memcpy_ptr_baoff :: Ptr a -> RawBuffer -> Int -> CSize -> IO (Ptr ())
705 foreign import "__hscore_memcpy_dst_off" unsafe
706 memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
707 foreign import "__hscore_memcpy_dst_off" unsafe
708 memcpy_baoff_ptr :: RawBuffer -> Int -> Ptr a -> CSize -> IO (Ptr ())
710 -----------------------------------------------------------------------------
713 illegalBufferSize :: Handle -> String -> Int -> IO a
714 illegalBufferSize handle fn (sz :: Int) =
715 ioException (IOError (Just handle)
717 ("illegal buffer size " ++ showsPrec 9 sz [])