1 {-# OPTIONS -fno-implicit-prelude -#include "HsCore.h" #-}
5 -- -----------------------------------------------------------------------------
6 -- $Id: IO.hs,v 1.3 2002/02/05 17:32:26 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
21 import System.IO.Error
29 import GHC.Handle -- much of the real stuff is in here
34 import GHC.Exception ( ioError, catch, throw )
37 -- ---------------------------------------------------------------------------
38 -- Simple input operations
40 -- Computation "hReady hdl" indicates whether at least
41 -- one item is available for input from handle "hdl".
43 -- If hWaitForInput finds anything in the Handle's buffer, it
44 -- immediately returns. If not, it tries to read from the underlying
45 -- OS handle. Notice that for buffered Handles connected to terminals
46 -- this means waiting until a complete line is available.
48 hWaitForInput :: Handle -> Int -> IO Bool
49 hWaitForInput h msecs = do
50 wantReadableHandle "hWaitForInput" h $ \ handle_ -> do
51 let ref = haBuffer handle_
54 if not (bufferEmpty buf)
58 r <- throwErrnoIfMinus1Retry "hWaitForInput"
59 (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs) (haIsStream handle_))
62 foreign import ccall unsafe "inputReady"
63 inputReady :: CInt -> CInt -> Bool -> IO CInt
65 -- ---------------------------------------------------------------------------
68 -- hGetChar reads the next character from a handle,
69 -- blocking until a character is available.
71 hGetChar :: Handle -> IO Char
73 wantReadableHandle "hGetChar" handle $ \handle_ -> do
76 ref = haBuffer handle_
79 if not (bufferEmpty buf)
80 then hGetcBuffered fd ref buf
84 case haBufferMode handle_ of
86 new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
87 hGetcBuffered fd ref new_buf
88 BlockBuffering _ -> do
89 new_buf <- fillReadBuffer fd False (haIsStream handle_) buf
90 hGetcBuffered fd ref new_buf
92 -- make use of the minimal buffer we already have
94 r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
95 (read_off_ba (fromIntegral fd) (haIsStream handle_) raw 0 1)
99 else do (c,_) <- readCharFromBuffer raw 0
102 hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
103 = do (c,r) <- readCharFromBuffer b r
104 let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
105 | otherwise = buf{ bufRPtr=r }
106 writeIORef ref new_buf
109 -- ---------------------------------------------------------------------------
112 -- If EOF is reached before EOL is encountered, ignore the EOF and
113 -- return the partial line. Next attempt at calling hGetLine on the
114 -- handle will yield an EOF IO exception though.
116 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
118 hGetLine :: Handle -> IO String
120 m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
121 case haBufferMode handle_ of
122 NoBuffering -> return Nothing
124 l <- hGetLineBuffered handle_
126 BlockBuffering _ -> do
127 l <- hGetLineBuffered handle_
130 Nothing -> hGetLineUnBuffered h
134 hGetLineBuffered handle_ = do
135 let ref = haBuffer handle_
137 hGetLineBufferedLoop handle_ ref buf []
140 hGetLineBufferedLoop handle_ ref
141 buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
143 -- find the end-of-line character, if there is one
145 | r == w = return (False, w)
147 (c,r') <- readCharFromBuffer raw r
149 then return (True, r) -- NB. not r': don't include the '\n'
152 (eol, off) <- loop raw r
155 puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
158 xs <- unpack raw r off
160 then do if w == off + 1
161 then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
162 else writeIORef ref buf{ bufRPtr = off + 1 }
163 return (concat (reverse (xs:xss)))
165 maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
166 buf{ bufWPtr=0, bufRPtr=0 }
168 -- Nothing indicates we caught an EOF, and we may have a
169 -- partial line to return.
170 Nothing -> let str = concat (reverse (xs:xss)) in
175 hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
178 maybeFillReadBuffer fd is_line is_stream buf
180 (do buf <- fillReadBuffer fd is_line is_stream buf
183 (\e -> do if isEOFError e
188 unpack :: RawBuffer -> Int -> Int -> IO [Char]
189 unpack buf r 0 = return ""
190 unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s
193 | i <# r = (# s, acc #)
195 case readCharArray# buf i s of
196 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
199 hGetLineUnBuffered :: Handle -> IO String
200 hGetLineUnBuffered h = do
213 if isEOFError err then
223 -- -----------------------------------------------------------------------------
226 -- hGetContents returns the list of characters corresponding to the
227 -- unread portion of the channel or file managed by the handle, which
228 -- is made semi-closed.
230 -- hGetContents on a DuplexHandle only affects the read side: you can
231 -- carry on writing to it afterwards.
233 hGetContents :: Handle -> IO String
234 hGetContents handle =
235 withHandle "hGetContents" handle $ \handle_ ->
236 case haType handle_ of
237 ClosedHandle -> ioe_closedHandle
238 SemiClosedHandle -> ioe_closedHandle
239 AppendHandle -> ioe_notReadable
240 WriteHandle -> ioe_notReadable
241 _ -> do xs <- lazyRead handle
242 return (handle_{ haType=SemiClosedHandle}, xs )
244 -- Note that someone may close the semi-closed handle (or change its
245 -- buffering), so each time these lazy read functions are pulled on,
246 -- they have to check whether the handle has indeed been closed.
248 lazyRead :: Handle -> IO String
251 withHandle "lazyRead" handle $ \ handle_ -> do
252 case haType handle_ of
253 ClosedHandle -> return (handle_, "")
254 SemiClosedHandle -> lazyRead' handle handle_
256 (IOError (Just handle) IllegalOperation "lazyRead"
257 "illegal handle type" Nothing)
259 lazyRead' h handle_ = do
260 let ref = haBuffer handle_
263 -- even a NoBuffering handle can have a char in the buffer...
266 if not (bufferEmpty buf)
267 then lazyReadHaveBuffer h handle_ fd ref buf
270 case haBufferMode handle_ of
272 -- make use of the minimal buffer we already have
274 r <- throwErrnoIfMinus1RetryMayBlock "lazyRead"
275 (read_off_ba (fromIntegral fd) (haIsStream handle_) raw 0 1)
278 then do handle_ <- hClose_help handle_
280 else do (c,_) <- readCharFromBuffer raw 0
282 return (handle_, c : rest)
284 LineBuffering -> lazyReadBuffered h handle_ fd ref buf
285 BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
287 -- we never want to block during the read, so we call fillReadBuffer with
288 -- is_line==True, which tells it to "just read what there is".
289 lazyReadBuffered h handle_ fd ref buf = do
291 (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
292 lazyReadHaveBuffer h handle_ fd ref buf
294 -- all I/O errors are discarded. Additionally, we close the handle.
295 (\e -> do handle_ <- hClose_help handle_
299 lazyReadHaveBuffer h handle_ fd ref buf = do
301 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
302 s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
306 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
307 unpackAcc buf r 0 acc = return ""
308 unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
311 | i <# r = (# s, acc #)
313 case readCharArray# buf i s of
314 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
316 -- ---------------------------------------------------------------------------
319 -- `hPutChar hdl ch' writes the character `ch' to the file or channel
320 -- managed by `hdl'. Characters may be buffered if buffering is
321 -- enabled for `hdl'.
323 hPutChar :: Handle -> Char -> IO ()
325 c `seq` do -- must evaluate c before grabbing the handle lock
326 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
327 let fd = haFD handle_
328 case haBufferMode handle_ of
329 LineBuffering -> hPutcBuffered handle_ True c
330 BlockBuffering _ -> hPutcBuffered handle_ False c
332 withObject (castCharToCChar c) $ \buf ->
333 throwErrnoIfMinus1RetryMayBlock_ "hPutChar"
334 (write_off (fromIntegral fd) (haIsStream handle_) buf 0 1)
338 hPutcBuffered handle_ is_line c = do
339 let ref = haBuffer handle_
342 w' <- writeCharIntoBuffer (bufBuf buf) w c
343 let new_buf = buf{ bufWPtr = w' }
344 if bufferFull new_buf || is_line && c == '\n'
346 flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf
347 writeIORef ref flushed_buf
349 writeIORef ref new_buf
352 hPutChars :: Handle -> [Char] -> IO ()
353 hPutChars handle [] = return ()
354 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
356 -- ---------------------------------------------------------------------------
359 -- `hPutStr hdl s' writes the string `s' to the file or
360 -- hannel managed by `hdl', buffering the output if needs be.
362 -- We go to some trouble to avoid keeping the handle locked while we're
363 -- evaluating the string argument to hPutStr, in case doing so triggers another
364 -- I/O operation on the same handle which would lead to deadlock. The classic
367 -- putStr (trace "hello" "world")
369 -- so the basic scheme is this:
371 -- * copy the string into a fresh buffer,
372 -- * "commit" the buffer to the handle.
374 -- Committing may involve simply copying the contents of the new
375 -- buffer into the handle's buffer, flushing one or both buffers, or
376 -- maybe just swapping the buffers over (if the handle's buffer was
377 -- empty). See commitBuffer below.
379 hPutStr :: Handle -> String -> IO ()
380 hPutStr handle str = do
381 buffer_mode <- wantWritableHandle "hPutStr" handle
382 (\ handle_ -> do getSpareBuffer handle_)
384 (NoBuffering, _) -> do
385 hPutChars handle str -- v. slow, but we don't care
386 (LineBuffering, buf) -> do
387 writeLines handle buf str
388 (BlockBuffering _, buf) -> do
389 writeBlocks handle buf str
392 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
393 getSpareBuffer Handle__{haBuffer=ref,
398 NoBuffering -> return (mode, error "no buffer!")
400 bufs <- readIORef spare_ref
403 BufferListCons b rest -> do
404 writeIORef spare_ref rest
405 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
407 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
408 return (mode, new_buf)
411 writeLines :: Handle -> Buffer -> String -> IO ()
412 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
414 shoveString :: Int -> [Char] -> IO ()
415 -- check n == len first, to ensure that shoveString is strict in n.
416 shoveString n cs | n == len = do
417 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
418 writeLines hdl new_buf cs
419 shoveString n [] = do
420 commitBuffer hdl raw len n False{-no flush-} True{-release-}
422 shoveString n (c:cs) = do
423 n' <- writeCharIntoBuffer raw n c
426 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
427 writeLines hdl new_buf cs
433 writeBlocks :: Handle -> Buffer -> String -> IO ()
434 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
436 shoveString :: Int -> [Char] -> IO ()
437 -- check n == len first, to ensure that shoveString is strict in n.
438 shoveString n cs | n == len = do
439 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
440 writeBlocks hdl new_buf cs
441 shoveString n [] = do
442 commitBuffer hdl raw len n False{-no flush-} True{-release-}
444 shoveString n (c:cs) = do
445 n' <- writeCharIntoBuffer raw n c
450 -- -----------------------------------------------------------------------------
451 -- commitBuffer handle buf sz count flush release
453 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
454 -- 'count' bytes of data) to handle (handle must be block or line buffered).
458 -- for block/line buffering,
459 -- 1. If there isn't room in the handle buffer, flush the handle
462 -- 2. If the handle buffer is empty,
464 -- then write buf directly to the device.
465 -- else swap the handle buffer with buf.
467 -- 3. If the handle buffer is non-empty, copy buf into the
468 -- handle buffer. Then, if flush != 0, flush
472 :: Handle -- handle to commit to
473 -> RawBuffer -> Int -- address and size (in bytes) of buffer
474 -> Int -- number of bytes of data in buffer
475 -> Bool -- True <=> flush the handle afterward
476 -> Bool -- release the buffer?
479 commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
480 wantWritableHandle "commitAndReleaseBuffer" hdl $
481 commitBuffer' hdl raw sz count flush release
483 -- Explicitly lambda-lift this function to subvert GHC's full laziness
484 -- optimisations, which otherwise tends to float out subexpressions
485 -- past the \handle, which is really a pessimisation in this case because
486 -- that lambda is a one-shot lambda.
488 -- Don't forget to export the function, to stop it being inlined too
489 -- (this appears to be better than NOINLINE, because the strictness
490 -- analyser still gets to worker-wrapper it).
492 -- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
494 commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release
495 handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
498 puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
499 ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
502 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
506 -- enough room in handle buffer?
507 if (not flush && (size - w > count))
508 -- The > is to be sure that we never exactly fill
509 -- up the buffer, which would require a flush. So
510 -- if copying the new data into the buffer would
511 -- make the buffer full, we just flush the existing
512 -- buffer and the new data immediately, rather than
513 -- copying before flushing.
515 -- not flushing, and there's enough room in the buffer:
516 -- just copy the data in and update bufWPtr.
517 then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
518 writeIORef ref old_buf{ bufWPtr = w + count }
519 return (newEmptyBuffer raw WriteBuffer sz)
521 -- else, we have to flush
522 else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf
525 Buffer{ bufBuf=raw, bufState=WriteBuffer,
526 bufRPtr=0, bufWPtr=count, bufSize=sz }
528 -- if: (a) we don't have to flush, and
529 -- (b) size(new buffer) == size(old buffer), and
530 -- (c) new buffer is not full,
531 -- we can just just swap them over...
532 if (not flush && sz == size && count /= sz)
534 writeIORef ref this_buf
537 -- otherwise, we have to flush the new data too,
538 -- and start with a fresh buffer
540 flushWriteBuffer fd (haIsStream handle_) this_buf
541 writeIORef ref flushed_buf
542 -- if the sizes were different, then allocate
543 -- a new buffer of the correct size.
545 then return (newEmptyBuffer raw WriteBuffer sz)
546 else allocateBuffer size WriteBuffer
548 -- release the buffer if necessary
550 Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
551 if release && buf_ret_sz == size
553 spare_bufs <- readIORef spare_buf_ref
554 writeIORef spare_buf_ref
555 (BufferListCons buf_ret_raw spare_bufs)
560 -- ---------------------------------------------------------------------------
561 -- Reading/writing sequences of bytes.
564 Semantics of hGetBuf:
566 - hGetBuf reads data into the buffer until either
569 (b) the buffer is full
571 It returns the amount of data actually read. This may
572 be zero in case (a). hGetBuf never raises
573 an EOF exception, it always returns zero instead.
575 If the handle is a pipe or socket, and the writing end
576 is closed, hGetBuf will behave as for condition (a).
578 Semantics of hPutBuf:
580 - hPutBuf writes data from the buffer to the handle
581 until the buffer is empty. It returns ().
583 If the handle is a pipe or socket, and the reading end is
584 closed, hPutBuf will raise a ResourceVanished exception.
585 (If this is a POSIX system, and the program has not
586 asked to ignore SIGPIPE, then a SIGPIPE may be delivered
587 instead, whose default action is to terminate the program).
590 -- ---------------------------------------------------------------------------
593 hPutBuf :: Handle -- handle to write to
594 -> Ptr a -- address of buffer
595 -> Int -- number of bytes of data in buffer
597 hPutBuf handle ptr count
598 | count <= 0 = illegalBufferSize handle "hPutBuf" count
600 wantWritableHandle "hPutBuf" handle $
601 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
603 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
606 -- enough room in handle buffer?
607 if (size - w > count)
608 -- There's enough room in the buffer:
609 -- just copy the data in and update bufWPtr.
610 then do memcpy_baoff_ptr old_raw w ptr (fromIntegral count)
611 writeIORef ref old_buf{ bufWPtr = w + count }
614 -- else, we have to flush
615 else do flushed_buf <- flushWriteBuffer fd is_stream old_buf
616 writeIORef ref flushed_buf
617 -- ToDo: should just memcpy instead of writing if possible
618 writeChunk fd ptr count
620 writeChunk :: FD -> Ptr a -> Int -> IO ()
621 writeChunk fd ptr bytes = loop 0 bytes
623 loop :: Int -> Int -> IO ()
624 loop _ bytes | bytes <= 0 = return ()
626 r <- fromIntegral `liftM`
627 throwErrnoIfMinus1RetryMayBlock "writeChunk"
628 (c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes))
630 -- write can't return 0
631 loop (off + r) (bytes - r)
633 -- ---------------------------------------------------------------------------
636 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
637 hGetBuf handle ptr count
638 | count <= 0 = illegalBufferSize handle "hGetBuf" count
640 wantReadableHandle "hGetBuf" handle $
641 \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> do
642 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref
644 then readChunk fd ptr count
647 copied <- if (count >= avail)
649 memcpy_ptr_baoff ptr raw r (fromIntegral avail)
650 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
653 memcpy_ptr_baoff ptr raw r (fromIntegral count)
654 writeIORef ref buf{ bufRPtr = r + count }
657 let remaining = count - copied
659 then do rest <- readChunk fd (ptr `plusPtr` copied) remaining
660 return (rest + copied)
663 readChunk :: FD -> Ptr a -> Int -> IO Int
664 readChunk fd ptr bytes = loop 0 bytes
666 loop :: Int -> Int -> IO Int
667 loop off bytes | bytes <= 0 = return off
669 r <- fromIntegral `liftM`
670 throwErrnoIfMinus1RetryMayBlock "readChunk"
671 (c_read (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes))
675 else loop (off + r) (bytes - r)
677 slurpFile :: FilePath -> IO (Ptr (), Int)
679 handle <- openFile fname ReadMode
680 sz <- hFileSize handle
681 if sz > fromIntegral (maxBound::Int) then
682 ioError (userError "slurpFile: file too big")
684 let sz_i = fromIntegral sz
685 chunk <- mallocBytes sz_i
686 r <- hGetBuf handle chunk sz_i
690 -- ---------------------------------------------------------------------------
693 foreign import ccall unsafe "__hscore_memcpy_src_off"
694 memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
695 foreign import ccall unsafe "__hscore_memcpy_src_off"
696 memcpy_ptr_baoff :: Ptr a -> RawBuffer -> Int -> CSize -> IO (Ptr ())
697 foreign import ccall unsafe "__hscore_memcpy_dst_off"
698 memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
699 foreign import ccall unsafe "__hscore_memcpy_dst_off"
700 memcpy_baoff_ptr :: RawBuffer -> Int -> Ptr a -> CSize -> IO (Ptr ())
702 -----------------------------------------------------------------------------
705 illegalBufferSize :: Handle -> String -> Int -> IO a
706 illegalBufferSize handle fn (sz :: Int) =
707 ioException (IOError (Just handle)
709 ("illegal buffer size " ++ showsPrec 9 sz [])