1 {-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-}
5 -- -----------------------------------------------------------------------------
6 -- $Id: IO.hs,v 1.5 2002/02/11 12:28:31 simonmar Exp $
8 -- (c) The University of Glasgow, 1992-2001
12 hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
13 commitBuffer', -- hack, see below
14 hGetcBuffered, -- needed by ghc/compiler/utils/StringBuffer.lhs
15 hGetBuf, hPutBuf, slurpFile,
25 import System.IO.Error
33 import GHC.Handle -- much of the real stuff is in here
38 import GHC.Exception ( ioError, catch, throw )
41 -- ---------------------------------------------------------------------------
42 -- Simple input operations
44 -- Computation "hReady hdl" indicates whether at least
45 -- one item is available for input from handle "hdl".
47 -- If hWaitForInput finds anything in the Handle's buffer, it
48 -- immediately returns. If not, it tries to read from the underlying
49 -- OS handle. Notice that for buffered Handles connected to terminals
50 -- this means waiting until a complete line is available.
52 hWaitForInput :: Handle -> Int -> IO Bool
53 hWaitForInput h msecs = do
54 wantReadableHandle "hWaitForInput" h $ \ handle_ -> do
55 let ref = haBuffer handle_
58 if not (bufferEmpty buf)
62 r <- throwErrnoIfMinus1Retry "hWaitForInput"
63 (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs) (haIsStream handle_))
66 foreign import ccall unsafe "inputReady"
67 inputReady :: CInt -> CInt -> Bool -> IO CInt
69 -- ---------------------------------------------------------------------------
72 -- hGetChar reads the next character from a handle,
73 -- blocking until a character is available.
75 hGetChar :: Handle -> IO Char
77 wantReadableHandle "hGetChar" handle $ \handle_ -> do
80 ref = haBuffer handle_
83 if not (bufferEmpty buf)
84 then hGetcBuffered fd ref buf
88 case haBufferMode handle_ of
90 new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
91 hGetcBuffered fd ref new_buf
92 BlockBuffering _ -> do
93 new_buf <- fillReadBuffer fd False (haIsStream handle_) buf
94 hGetcBuffered fd ref new_buf
96 -- make use of the minimal buffer we already have
98 r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
99 (read_off_ba (fromIntegral fd) (haIsStream handle_) raw 0 1)
103 else do (c,_) <- readCharFromBuffer raw 0
106 hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
107 = do (c,r) <- readCharFromBuffer b r
108 let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
109 | otherwise = buf{ bufRPtr=r }
110 writeIORef ref new_buf
113 -- ---------------------------------------------------------------------------
116 -- If EOF is reached before EOL is encountered, ignore the EOF and
117 -- return the partial line. Next attempt at calling hGetLine on the
118 -- handle will yield an EOF IO exception though.
120 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
122 hGetLine :: Handle -> IO String
124 m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
125 case haBufferMode handle_ of
126 NoBuffering -> return Nothing
128 l <- hGetLineBuffered handle_
130 BlockBuffering _ -> do
131 l <- hGetLineBuffered handle_
134 Nothing -> hGetLineUnBuffered h
138 hGetLineBuffered handle_ = do
139 let ref = haBuffer handle_
141 hGetLineBufferedLoop handle_ ref buf []
144 hGetLineBufferedLoop handle_ ref
145 buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
147 -- find the end-of-line character, if there is one
149 | r == w = return (False, w)
151 (c,r') <- readCharFromBuffer raw r
153 then return (True, r) -- NB. not r': don't include the '\n'
156 (eol, off) <- loop raw r
159 puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
162 xs <- unpack raw r off
164 then do if w == off + 1
165 then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
166 else writeIORef ref buf{ bufRPtr = off + 1 }
167 return (concat (reverse (xs:xss)))
169 maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
170 buf{ bufWPtr=0, bufRPtr=0 }
172 -- Nothing indicates we caught an EOF, and we may have a
173 -- partial line to return.
174 Nothing -> let str = concat (reverse (xs:xss)) in
179 hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
182 maybeFillReadBuffer fd is_line is_stream buf
184 (do buf <- fillReadBuffer fd is_line is_stream buf
187 (\e -> do if isEOFError e
192 unpack :: RawBuffer -> Int -> Int -> IO [Char]
193 unpack buf r 0 = return ""
194 unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s
197 | i <# r = (# s, acc #)
199 case readCharArray# buf i s of
200 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
203 hGetLineUnBuffered :: Handle -> IO String
204 hGetLineUnBuffered h = do
217 if isEOFError err then
227 -- -----------------------------------------------------------------------------
230 -- hGetContents returns the list of characters corresponding to the
231 -- unread portion of the channel or file managed by the handle, which
232 -- is made semi-closed.
234 -- hGetContents on a DuplexHandle only affects the read side: you can
235 -- carry on writing to it afterwards.
237 hGetContents :: Handle -> IO String
238 hGetContents handle =
239 withHandle "hGetContents" handle $ \handle_ ->
240 case haType handle_ of
241 ClosedHandle -> ioe_closedHandle
242 SemiClosedHandle -> ioe_closedHandle
243 AppendHandle -> ioe_notReadable
244 WriteHandle -> ioe_notReadable
245 _ -> do xs <- lazyRead handle
246 return (handle_{ haType=SemiClosedHandle}, xs )
248 -- Note that someone may close the semi-closed handle (or change its
249 -- buffering), so each time these lazy read functions are pulled on,
250 -- they have to check whether the handle has indeed been closed.
252 lazyRead :: Handle -> IO String
255 withHandle "lazyRead" handle $ \ handle_ -> do
256 case haType handle_ of
257 ClosedHandle -> return (handle_, "")
258 SemiClosedHandle -> lazyRead' handle handle_
260 (IOError (Just handle) IllegalOperation "lazyRead"
261 "illegal handle type" Nothing)
263 lazyRead' h handle_ = do
264 let ref = haBuffer handle_
267 -- even a NoBuffering handle can have a char in the buffer...
270 if not (bufferEmpty buf)
271 then lazyReadHaveBuffer h handle_ fd ref buf
274 case haBufferMode handle_ of
276 -- make use of the minimal buffer we already have
278 r <- throwErrnoIfMinus1RetryMayBlock "lazyRead"
279 (read_off_ba (fromIntegral fd) (haIsStream handle_) raw 0 1)
282 then do handle_ <- hClose_help handle_
284 else do (c,_) <- readCharFromBuffer raw 0
286 return (handle_, c : rest)
288 LineBuffering -> lazyReadBuffered h handle_ fd ref buf
289 BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
291 -- we never want to block during the read, so we call fillReadBuffer with
292 -- is_line==True, which tells it to "just read what there is".
293 lazyReadBuffered h handle_ fd ref buf = do
295 (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
296 lazyReadHaveBuffer h handle_ fd ref buf
298 -- all I/O errors are discarded. Additionally, we close the handle.
299 (\e -> do handle_ <- hClose_help handle_
303 lazyReadHaveBuffer h handle_ fd ref buf = do
305 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
306 s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
310 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
311 unpackAcc buf r 0 acc = return ""
312 unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
315 | i <# r = (# s, acc #)
317 case readCharArray# buf i s of
318 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
320 -- ---------------------------------------------------------------------------
323 -- `hPutChar hdl ch' writes the character `ch' to the file or channel
324 -- managed by `hdl'. Characters may be buffered if buffering is
325 -- enabled for `hdl'.
327 hPutChar :: Handle -> Char -> IO ()
329 c `seq` do -- must evaluate c before grabbing the handle lock
330 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
331 let fd = haFD handle_
332 case haBufferMode handle_ of
333 LineBuffering -> hPutcBuffered handle_ True c
334 BlockBuffering _ -> hPutcBuffered handle_ False c
336 withObject (castCharToCChar c) $ \buf ->
337 throwErrnoIfMinus1RetryMayBlock_ "hPutChar"
338 (write_off (fromIntegral fd) (haIsStream handle_) buf 0 1)
342 hPutcBuffered handle_ is_line c = do
343 let ref = haBuffer handle_
346 w' <- writeCharIntoBuffer (bufBuf buf) w c
347 let new_buf = buf{ bufWPtr = w' }
348 if bufferFull new_buf || is_line && c == '\n'
350 flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf
351 writeIORef ref flushed_buf
353 writeIORef ref new_buf
356 hPutChars :: Handle -> [Char] -> IO ()
357 hPutChars handle [] = return ()
358 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
360 -- ---------------------------------------------------------------------------
363 -- `hPutStr hdl s' writes the string `s' to the file or
364 -- hannel managed by `hdl', buffering the output if needs be.
366 -- We go to some trouble to avoid keeping the handle locked while we're
367 -- evaluating the string argument to hPutStr, in case doing so triggers another
368 -- I/O operation on the same handle which would lead to deadlock. The classic
371 -- putStr (trace "hello" "world")
373 -- so the basic scheme is this:
375 -- * copy the string into a fresh buffer,
376 -- * "commit" the buffer to the handle.
378 -- Committing may involve simply copying the contents of the new
379 -- buffer into the handle's buffer, flushing one or both buffers, or
380 -- maybe just swapping the buffers over (if the handle's buffer was
381 -- empty). See commitBuffer below.
383 hPutStr :: Handle -> String -> IO ()
384 hPutStr handle str = do
385 buffer_mode <- wantWritableHandle "hPutStr" handle
386 (\ handle_ -> do getSpareBuffer handle_)
388 (NoBuffering, _) -> do
389 hPutChars handle str -- v. slow, but we don't care
390 (LineBuffering, buf) -> do
391 writeLines handle buf str
392 (BlockBuffering _, buf) -> do
393 writeBlocks handle buf str
396 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
397 getSpareBuffer Handle__{haBuffer=ref,
402 NoBuffering -> return (mode, error "no buffer!")
404 bufs <- readIORef spare_ref
407 BufferListCons b rest -> do
408 writeIORef spare_ref rest
409 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
411 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
412 return (mode, new_buf)
415 writeLines :: Handle -> Buffer -> String -> IO ()
416 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
418 shoveString :: Int -> [Char] -> IO ()
419 -- check n == len first, to ensure that shoveString is strict in n.
420 shoveString n cs | n == len = do
421 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
422 writeLines hdl new_buf cs
423 shoveString n [] = do
424 commitBuffer hdl raw len n False{-no flush-} True{-release-}
426 shoveString n (c:cs) = do
427 n' <- writeCharIntoBuffer raw n c
430 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
431 writeLines hdl new_buf cs
437 writeBlocks :: Handle -> Buffer -> String -> IO ()
438 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
440 shoveString :: Int -> [Char] -> IO ()
441 -- check n == len first, to ensure that shoveString is strict in n.
442 shoveString n cs | n == len = do
443 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
444 writeBlocks hdl new_buf cs
445 shoveString n [] = do
446 commitBuffer hdl raw len n False{-no flush-} True{-release-}
448 shoveString n (c:cs) = do
449 n' <- writeCharIntoBuffer raw n c
454 -- -----------------------------------------------------------------------------
455 -- commitBuffer handle buf sz count flush release
457 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
458 -- 'count' bytes of data) to handle (handle must be block or line buffered).
462 -- for block/line buffering,
463 -- 1. If there isn't room in the handle buffer, flush the handle
466 -- 2. If the handle buffer is empty,
468 -- then write buf directly to the device.
469 -- else swap the handle buffer with buf.
471 -- 3. If the handle buffer is non-empty, copy buf into the
472 -- handle buffer. Then, if flush != 0, flush
476 :: Handle -- handle to commit to
477 -> RawBuffer -> Int -- address and size (in bytes) of buffer
478 -> Int -- number of bytes of data in buffer
479 -> Bool -- True <=> flush the handle afterward
480 -> Bool -- release the buffer?
483 commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
484 wantWritableHandle "commitAndReleaseBuffer" hdl $
485 commitBuffer' hdl raw sz count flush release
487 -- Explicitly lambda-lift this function to subvert GHC's full laziness
488 -- optimisations, which otherwise tends to float out subexpressions
489 -- past the \handle, which is really a pessimisation in this case because
490 -- that lambda is a one-shot lambda.
492 -- Don't forget to export the function, to stop it being inlined too
493 -- (this appears to be better than NOINLINE, because the strictness
494 -- analyser still gets to worker-wrapper it).
496 -- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
498 commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release
499 handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
502 puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
503 ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
506 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
510 -- enough room in handle buffer?
511 if (not flush && (size - w > count))
512 -- The > is to be sure that we never exactly fill
513 -- up the buffer, which would require a flush. So
514 -- if copying the new data into the buffer would
515 -- make the buffer full, we just flush the existing
516 -- buffer and the new data immediately, rather than
517 -- copying before flushing.
519 -- not flushing, and there's enough room in the buffer:
520 -- just copy the data in and update bufWPtr.
521 then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
522 writeIORef ref old_buf{ bufWPtr = w + count }
523 return (newEmptyBuffer raw WriteBuffer sz)
525 -- else, we have to flush
526 else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf
529 Buffer{ bufBuf=raw, bufState=WriteBuffer,
530 bufRPtr=0, bufWPtr=count, bufSize=sz }
532 -- if: (a) we don't have to flush, and
533 -- (b) size(new buffer) == size(old buffer), and
534 -- (c) new buffer is not full,
535 -- we can just just swap them over...
536 if (not flush && sz == size && count /= sz)
538 writeIORef ref this_buf
541 -- otherwise, we have to flush the new data too,
542 -- and start with a fresh buffer
544 flushWriteBuffer fd (haIsStream handle_) this_buf
545 writeIORef ref flushed_buf
546 -- if the sizes were different, then allocate
547 -- a new buffer of the correct size.
549 then return (newEmptyBuffer raw WriteBuffer sz)
550 else allocateBuffer size WriteBuffer
552 -- release the buffer if necessary
554 Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
555 if release && buf_ret_sz == size
557 spare_bufs <- readIORef spare_buf_ref
558 writeIORef spare_buf_ref
559 (BufferListCons buf_ret_raw spare_bufs)
564 -- ---------------------------------------------------------------------------
565 -- Reading/writing sequences of bytes.
568 Semantics of hGetBuf:
570 - hGetBuf reads data into the buffer until either
573 (b) the buffer is full
575 It returns the amount of data actually read. This may
576 be zero in case (a). hGetBuf never raises
577 an EOF exception, it always returns zero instead.
579 If the handle is a pipe or socket, and the writing end
580 is closed, hGetBuf will behave as for condition (a).
582 Semantics of hPutBuf:
584 - hPutBuf writes data from the buffer to the handle
585 until the buffer is empty. It returns ().
587 If the handle is a pipe or socket, and the reading end is
588 closed, hPutBuf will raise a ResourceVanished exception.
589 (If this is a POSIX system, and the program has not
590 asked to ignore SIGPIPE, then a SIGPIPE may be delivered
591 instead, whose default action is to terminate the program).
594 -- ---------------------------------------------------------------------------
597 hPutBuf :: Handle -- handle to write to
598 -> Ptr a -- address of buffer
599 -> Int -- number of bytes of data in buffer
601 hPutBuf handle ptr count
602 | count <= 0 = illegalBufferSize handle "hPutBuf" count
604 wantWritableHandle "hPutBuf" handle $
605 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
607 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
610 -- enough room in handle buffer?
611 if (size - w > count)
612 -- There's enough room in the buffer:
613 -- just copy the data in and update bufWPtr.
614 then do memcpy_baoff_ptr old_raw w ptr (fromIntegral count)
615 writeIORef ref old_buf{ bufWPtr = w + count }
618 -- else, we have to flush
619 else do flushed_buf <- flushWriteBuffer fd is_stream old_buf
620 writeIORef ref flushed_buf
621 -- ToDo: should just memcpy instead of writing if possible
622 writeChunk fd ptr count
624 writeChunk :: FD -> Ptr a -> Int -> IO ()
625 writeChunk fd ptr bytes = loop 0 bytes
627 loop :: Int -> Int -> IO ()
628 loop _ bytes | bytes <= 0 = return ()
630 r <- fromIntegral `liftM`
631 throwErrnoIfMinus1RetryMayBlock "writeChunk"
632 (c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes))
634 -- write can't return 0
635 loop (off + r) (bytes - r)
637 -- ---------------------------------------------------------------------------
640 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
641 hGetBuf handle ptr count
642 | count <= 0 = illegalBufferSize handle "hGetBuf" count
644 wantReadableHandle "hGetBuf" handle $
645 \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> do
646 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref
648 then readChunk fd ptr count
651 copied <- if (count >= avail)
653 memcpy_ptr_baoff ptr raw r (fromIntegral avail)
654 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
657 memcpy_ptr_baoff ptr raw r (fromIntegral count)
658 writeIORef ref buf{ bufRPtr = r + count }
661 let remaining = count - copied
663 then do rest <- readChunk fd (ptr `plusPtr` copied) remaining
664 return (rest + copied)
667 readChunk :: FD -> Ptr a -> Int -> IO Int
668 readChunk fd ptr bytes = loop 0 bytes
670 loop :: Int -> Int -> IO Int
671 loop off bytes | bytes <= 0 = return off
673 r <- fromIntegral `liftM`
674 throwErrnoIfMinus1RetryMayBlock "readChunk"
675 (c_read (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes))
679 else loop (off + r) (bytes - r)
681 slurpFile :: FilePath -> IO (Ptr (), Int)
683 handle <- openFile fname ReadMode
684 sz <- hFileSize handle
685 if sz > fromIntegral (maxBound::Int) then
686 ioError (userError "slurpFile: file too big")
688 let sz_i = fromIntegral sz
689 chunk <- mallocBytes sz_i
690 r <- hGetBuf handle chunk sz_i
694 -- ---------------------------------------------------------------------------
697 foreign import ccall unsafe "__hscore_memcpy_src_off"
698 memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
699 foreign import ccall unsafe "__hscore_memcpy_src_off"
700 memcpy_ptr_baoff :: Ptr a -> RawBuffer -> Int -> CSize -> IO (Ptr ())
701 foreign import ccall unsafe "__hscore_memcpy_dst_off"
702 memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
703 foreign import ccall unsafe "__hscore_memcpy_dst_off"
704 memcpy_baoff_ptr :: RawBuffer -> Int -> Ptr a -> CSize -> IO (Ptr ())
706 -----------------------------------------------------------------------------
709 illegalBufferSize :: Handle -> String -> Int -> IO a
710 illegalBufferSize handle fn (sz :: Int) =
711 ioException (IOError (Just handle)
713 ("illegal buffer size " ++ showsPrec 9 sz [])