X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FIO.lhs;h=aeb30253cb9e7fe1ff04833b508c3f939bc3e198;hb=d392968d909449a16d02e0e70a5eb9eddb1c07ab;hp=4c40d943d1cd59120c2915658f77ba46c03ca163;hpb=bbe9c55569ffa1ea660a02d7349afb4ba659072d;p=ghc-hetmet.git diff --git a/ghc/lib/std/IO.lhs b/ghc/lib/std/IO.lhs index 4c40d94..aeb3025 100644 --- a/ghc/lib/std/IO.lhs +++ b/ghc/lib/std/IO.lhs @@ -10,6 +10,7 @@ definition. \begin{code} {-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-} +#ifndef BODY /* Hugs just includes this in PreludeBuiltin so no header needed */ module IO ( Handle, -- abstract, instance of: Eq, Show. HandlePosn(..), -- abstract, instance of: Eq, Show. @@ -62,6 +63,14 @@ module IO ( -- Non-standard extension (but will hopefully become standard with 1.5) is -- to export the Prelude io functions via IO (in addition to exporting them -- from the prelude...for now.) + IO, + FilePath, -- :: String + IOError, + ioError, -- :: IOError -> IO a + userError, -- :: String -> IOError + catch, -- :: IO a -> (IOError -> IO a) -> IO a + interact, -- :: (String -> String) -> IO () + putChar, -- :: Char -> IO () putStr, -- :: String -> IO () putStrLn, -- :: String -> IO () @@ -69,27 +78,28 @@ module IO ( getChar, -- :: IO Char getLine, -- :: IO String getContents, -- :: IO String - interact, -- :: (String -> String) -> IO () readFile, -- :: FilePath -> IO String writeFile, -- :: FilePath -> String -> IO () appendFile, -- :: FilePath -> String -> IO () readIO, -- :: Read a => String -> IO a readLn, -- :: Read a => IO a - FilePath, -- :: String - fail, -- :: IOError -> IO a - catch, -- :: IO a -> (IOError -> IO a) -> IO a - userError, -- :: String -> IOError - - IO, -- non-standard, amazingly enough. - IOError, -- ditto -- extensions hPutBuf, +#ifndef __HUGS__ hPutBufBA, +#endif slurpFile ) where +#ifdef __HUGS__ + +import PreludeBuiltin + +#else + +--import PrelST import PrelBase import PrelIOBase @@ -98,12 +108,12 @@ import PrelHandle -- much of the real stuff is in here import PrelRead ( readParen, Read(..), reads, lex, readIO ) ---import PrelNum ( toInteger ) -import PrelBounded () -- Bounded Int instance. -import PrelEither ( Either(..) ) +import PrelShow +import PrelMaybe ( Either(..), Maybe(..) ) import PrelAddr ( Addr(..), nullAddr ) import PrelArr ( ByteArray ) import PrelPack ( unpackNBytesAccST ) +import PrelException ( ioError, catch ) #ifndef __PARALLEL_HASKELL__ import PrelForeign ( ForeignObj ) @@ -111,6 +121,24 @@ import PrelForeign ( ForeignObj ) import Char ( ord, chr ) +#endif /* ndef __HUGS__ */ +#endif /* ndef BODY */ + +#ifndef HEAD + +#ifdef __HUGS__ +#define cat2(x,y) x/**/y +#define CCALL(fun) cat2(prim_,fun) +#define __CONCURRENT_HASKELL__ +#define stToIO id +#define unpackNBytesAccST primUnpackCStringAcc +#else +#define CCALL(fun) _ccall_ fun +#define ref_freeStdFileObject (``&freeStdFileObject''::Addr) +#define ref_freeFileObject (``&freeFileObject''::Addr) +#define const_BUFSIZ ``BUFSIZ'' +#endif + \end{code} Standard instances for @Handle@: @@ -130,7 +158,7 @@ instance Eq HandlePosn where -- Type declared in IOBase, instance here because it -- depends on PrelRead.(Read Maybe) instance. instance Read BufferMode where - readsPrec p = + readsPrec _ = readParen False (\r -> let lr = lex r in @@ -163,11 +191,10 @@ hReady :: Handle -> IO Bool hReady h = hWaitForInput h 0 hWaitForInput :: Handle -> Int -> IO Bool -hWaitForInput handle msecs = do - handle_ <- wantReadableHandle "hWaitForInput" handle - rc <- _ccall_ inputReady (haFO__ handle_) (msecs::Int) -- ConcHask: SAFE, won't block - writeHandle handle handle_ - case rc of +hWaitForInput handle msecs = + wantReadableHandle "hWaitForInput" handle $ \ handle_ -> do + rc <- CCALL(inputReady) (haFO__ handle_) (msecs::Int) -- ConcHask: SAFE, won't block + case (rc::Int) of 0 -> return False 1 -> return True _ -> constructErrorAndFail "hWaitForInput" @@ -178,23 +205,42 @@ blocking until a character is available. \begin{code} hGetChar :: Handle -> IO Char -hGetChar handle = do - handle_ <- wantReadableHandle "hGetChar" handle +hGetChar handle = + wantReadableHandle "hGetChar" handle $ \ handle_ -> do let fo = haFO__ handle_ - intc <- mayBlock fo (_ccall_ fileGetc fo) -- ConcHask: UNSAFE, may block - writeHandle handle handle_ - if intc /= (-1) + intc <- mayBlock fo (CCALL(fileGetc) fo) -- ConcHask: UNSAFE, may block + if intc /= ((-1)::Int) then return (chr intc) else constructErrorAndFail "hGetChar" +{- + If EOF is reached before EOL is encountered, ignore the + EOF and return the partial line. Next attempt at calling + hGetLine on the handle will yield an EOF IO exception though. +-} hGetLine :: Handle -> IO String hGetLine h = do c <- hGetChar h - if c == '\n' - then return "" + if c == '\n' then + return "" else do - s <- hGetLine h - return (c:s) + l <- getRest + return (c:l) + where + getRest = do + c <- + catch + (hGetChar h) + (\ err -> do + if isEOFError err then + return '\n' + else + ioError err) + if c == '\n' then + return "" + else do + s <- getRest + return (c:s) \end{code} @@ -204,11 +250,10 @@ character is available. \begin{code} hLookAhead :: Handle -> IO Char -hLookAhead handle = do - handle_ <- wantReadableHandle "hLookAhead" handle +hLookAhead handle = + wantReadableHandle "hLookAhead" handle $ \ handle_ -> do let fo = haFO__ handle_ - intc <- mayBlock fo (_ccall_ fileLookAhead fo) -- ConcHask: UNSAFE, may block - writeHandle handle handle_ + intc <- mayBlock fo (CCALL(fileLookAhead) fo) -- ConcHask: UNSAFE, may block if intc /= (-1) then return (chr intc) else constructErrorAndFail "hLookAhead" @@ -228,19 +273,37 @@ which is made semi-closed. \begin{code} hGetContents :: Handle -> IO String -hGetContents handle = do - handle_ <- wantReadableHandle "hGetContents" handle - {- - To avoid introducing an extra layer of buffering here, - we provide three lazy read methods, based on character, - line, and block buffering. - -} - writeHandle handle (handle_{ haType__ = SemiClosedHandle }) - case (haBufferMode__ handle_) of - LineBuffering -> unsafeInterleaveIO (lazyReadLine handle (haFO__ handle_)) - BlockBuffering _ -> unsafeInterleaveIO (lazyReadBlock handle (haFO__ handle_)) - NoBuffering -> unsafeInterleaveIO (lazyReadChar handle (haFO__ handle_)) - +hGetContents handle = + -- can't use wantReadableHandle here, because we want to side effect + -- the handle. + withHandle handle $ \ handle_ -> do + case haType__ handle_ of + ErrorHandle theError -> ioError theError + ClosedHandle -> ioe_closedHandle "hGetContents" handle + SemiClosedHandle -> ioe_closedHandle "hGetContents" handle + AppendHandle -> ioError not_readable_error + WriteHandle -> ioError not_readable_error + _ -> do + {- + To avoid introducing an extra layer of buffering here, + we provide three lazy read methods, based on character, + line, and block buffering. + -} + let handle_' = handle_{ haType__ = SemiClosedHandle } + case (haBufferMode__ handle_) of + LineBuffering -> do + str <- unsafeInterleaveIO (lazyReadLine handle (haFO__ handle_)) + return (handle_', str) + BlockBuffering _ -> do + str <- unsafeInterleaveIO (lazyReadBlock handle (haFO__ handle_)) + return (handle_', str) + NoBuffering -> do + str <- unsafeInterleaveIO (lazyReadChar handle (haFO__ handle_)) + return (handle_', str) + where + not_readable_error = + IOError (Just handle) IllegalOperation "hGetContents" + ("handle is not open for reading") \end{code} Note that someone may close the semi-closed handle (or change its buffering), @@ -259,54 +322,54 @@ lazyReadChar :: Handle -> Addr -> IO String #endif lazyReadBlock handle fo = do - buf <- _ccall_ getBufStart fo (0::Int) - bytes <- mayBlock fo (_ccall_ readBlock fo) -- ConcHask: UNSAFE, may block. - case bytes of + buf <- CCALL(getBufStart) fo (0::Int) + bytes <- mayBlock fo (CCALL(readBlock) fo) -- ConcHask: UNSAFE, may block. + case (bytes::Int) of -3 -> -- buffering has been turned off, use lazyReadChar instead lazyReadChar handle fo -2 -> return "" - -1 -> do -- an error occurred, close the handle - handle_ <- readHandle handle - _ccall_ closeFile (haFO__ handle_) 0{-don't bother flushing-} -- ConcHask: SAFE, won't block. - writeHandle handle (handle_ { haType__ = ClosedHandle, - haFO__ = nullFile__ }) - return "" + -1 -> -- an error occurred, close the handle + withHandle handle $ \ handle_ -> do + CCALL(closeFile) (haFO__ handle_) (0::Int){-don't bother flushing-} -- ConcHask: SAFE, won't block. + return (handle_ { haType__ = ClosedHandle, + haFO__ = nullFile__ }, + "") _ -> do more <- unsafeInterleaveIO (lazyReadBlock handle fo) stToIO (unpackNBytesAccST buf bytes more) lazyReadLine handle fo = do - bytes <- mayBlock fo (_ccall_ readLine fo) -- ConcHask: UNSAFE, may block. - case bytes of + bytes <- mayBlock fo (CCALL(readLine) fo) -- ConcHask: UNSAFE, may block. + case (bytes::Int) of -3 -> -- buffering has been turned off, use lazyReadChar instead lazyReadChar handle fo -2 -> return "" -- handle closed by someone else, stop reading. - -1 -> do -- an error occurred, close the handle - handle_ <- readHandle handle - _ccall_ closeFile (haFO__ handle_) 0{- don't bother flushing-} -- ConcHask: SAFE, won't block - writeHandle handle (handle_ { haType__ = ClosedHandle, - haFO__ = nullFile__ }) - return "" + -1 -> -- an error occurred, close the handle + withHandle handle $ \ handle_ -> do + CCALL(closeFile) (haFO__ handle_) (0::Int){- don't bother flushing-} -- ConcHask: SAFE, won't block + return (handle_ { haType__ = ClosedHandle, + haFO__ = nullFile__ }, + "") _ -> do more <- unsafeInterleaveIO (lazyReadLine handle fo) - buf <- _ccall_ getBufStart fo bytes -- ConcHask: won't block + buf <- CCALL(getBufStart) fo bytes -- ConcHask: won't block stToIO (unpackNBytesAccST buf bytes more) lazyReadChar handle fo = do - char <- mayBlock fo (_ccall_ readChar fo) -- ConcHask: UNSAFE, may block. - case char of + char <- mayBlock fo (CCALL(readChar) fo) -- ConcHask: UNSAFE, may block. + case (char::Int) of -4 -> -- buffering is now block-buffered, use lazyReadBlock instead lazyReadBlock handle fo -3 -> -- buffering is now line-buffered, use lazyReadLine instead lazyReadLine handle fo -2 -> return "" - -1 -> do -- error, silently close handle. - handle_ <- readHandle handle - _ccall_ closeFile (haFO__ handle_) 0{-don't bother flusing-} -- ConcHask: SAFE, won't block - writeHandle handle (handle_{ haType__ = ClosedHandle, - haFO__ = nullFile__ }) - return "" + -1 -> -- error, silently close handle. + withHandle handle $ \ handle_ -> do + CCALL(closeFile) (haFO__ handle_) (0::Int){-don't bother flusing-} -- ConcHask: SAFE, won't block + return (handle_{ haType__ = ClosedHandle, + haFO__ = nullFile__ }, + "") _ -> do more <- unsafeInterleaveIO (lazyReadChar handle fo) return (chr char : more) @@ -326,12 +389,11 @@ buffering is enabled for @hdl@ \begin{code} hPutChar :: Handle -> Char -> IO () -hPutChar handle c = do - handle_ <- wantWriteableHandle "hPutChar" handle +hPutChar handle c = + wantWriteableHandle "hPutChar" handle $ \ handle_ -> do let fo = haFO__ handle_ - flushConnectedHandle fo - rc <- mayBlock fo (_ccall_ filePutc fo c) -- ConcHask: UNSAFE, may block. - writeHandle handle handle_ + flushConnectedBuf fo + rc <- mayBlock fo (CCALL(filePutc) fo c) -- ConcHask: UNSAFE, may block. if rc == 0 then return () else constructErrorAndFail "hPutChar" @@ -343,25 +405,23 @@ channel managed by @hdl@, buffering the output if needs be. \begin{code} hPutStr :: Handle -> String -> IO () -hPutStr handle str = do - handle_ <- wantWriteableHandle "hPutStr" handle +hPutStr handle str = + wantWriteableHandle "hPutStr" handle $ \ handle_ -> do let fo = haFO__ handle_ - flushConnectedHandle fo + flushConnectedBuf fo case haBufferMode__ handle_ of LineBuffering -> do - buf <- _ccall_ getWriteableBuf fo - pos <- _ccall_ getBufWPtr fo - bsz <- _ccall_ getBufSize fo + buf <- CCALL(getWriteableBuf) fo + pos <- CCALL(getBufWPtr) fo + bsz <- CCALL(getBufSize) fo writeLines fo buf bsz pos str BlockBuffering _ -> do - buf <- _ccall_ getWriteableBuf fo - pos <- _ccall_ getBufWPtr fo - bsz <- _ccall_ getBufSize fo + buf <- CCALL(getWriteableBuf) fo + pos <- CCALL(getBufWPtr) fo + bsz <- CCALL(getBufSize) fo writeBlocks fo buf bsz pos str NoBuffering -> do writeChars fo str - writeHandle handle handle_ - \end{code} Going across the border between Haskell and C is relatively costly, @@ -369,25 +429,74 @@ so for block writes we pack the character strings on the Haskell-side before passing the external write routine a pointer to the buffer. \begin{code} +#ifdef __HUGS__ + +#ifdef __CONCURRENT_HASKELL__ +/* See comment in shoveString below for explanation */ +#warning delayed update of buffer disnae work with killThread +#endif #ifndef __PARALLEL_HASKELL__ writeLines :: ForeignObj -> Addr -> Int -> Int -> String -> IO () #else writeLines :: Addr -> Addr -> Int -> Int -> String -> IO () #endif -writeLines obj buf bf@(I# bufLen) (I# initPos#) s = +writeLines obj buf bufLen initPos s = + let + shoveString :: Int -> [Char] -> IO () + shoveString n ls = + case ls of + [] -> + if n == 0 then + CCALL(setBufWPtr) obj (0::Int) + else do + {- + At the end of a buffer write, update the buffer position + in the underlying file object, so that if the handle + is subsequently dropped by the program, the whole + buffer will be properly flushed. + + There's one case where this delayed up-date of the buffer + position can go wrong: if a thread is killed, it might be + in the middle of filling up a buffer, with the result that + the partial buffer update is lost upon finalisation. Not + that killing of threads is supported at the moment. + + -} + CCALL(setBufWPtr) obj n + + (x:xs) -> do + primWriteCharOffAddr buf n x + {- Flushing on buffer exhaustion or newlines (even if it isn't the last one) -} + if n == bufLen || x == '\n' + then do + rc <- mayBlock obj (CCALL(writeFileObject) obj (n + 1)) -- ConcHask: UNSAFE, may block. + if rc == 0 + then shoveString 0 xs + else constructErrorAndFail "writeLines" + else + shoveString (n + 1) xs + in + shoveString initPos s +#else /* ndef __HUGS__ */ +#ifndef __PARALLEL_HASKELL__ +writeLines :: ForeignObj -> Addr -> Int -> Int -> String -> IO () +#else +writeLines :: Addr -> Addr -> Int -> Int -> String -> IO () +#endif +writeLines obj buf (I# bufLen) (I# initPos#) s = let write_char :: Addr -> Int# -> Char# -> IO () - write_char (A# buf) n# c# = + write_char (A# buf#) n# c# = IO $ \ s# -> - case (writeCharOffAddr# buf n# c# s#) of s2# -> IOok s2# () + case (writeCharOffAddr# buf# n# c# s#) of s2# -> (# s2#, () #) shoveString :: Int# -> [Char] -> IO () shoveString n ls = case ls of [] -> if n ==# 0# then - _ccall_ setBufWPtr obj (0::Int) + CCALL(setBufWPtr) obj (0::Int) else do {- At the end of a buffer write, update the buffer position @@ -402,14 +511,14 @@ writeLines obj buf bf@(I# bufLen) (I# initPos#) s = that killing of threads is supported at the moment. -} - _ccall_ setBufWPtr obj (I# n) + CCALL(setBufWPtr) obj (I# n) ((C# x):xs) -> do write_char buf n x {- Flushing on buffer exhaustion or newlines (even if it isn't the last one) -} if n ==# bufLen || x `eqChar#` '\n'# then do - rc <- mayBlock obj (_ccall_ writeFileObject obj (I# (n +# 1#))) -- ConcHask: UNSAFE, may block. + rc <- mayBlock obj (CCALL(writeFileObject) obj (I# (n +# 1#))) -- ConcHask: UNSAFE, may block. if rc == 0 then shoveString 0# xs else constructErrorAndFail "writeLines" @@ -417,25 +526,71 @@ writeLines obj buf bf@(I# bufLen) (I# initPos#) s = shoveString (n +# 1#) xs in shoveString initPos# s +#endif /* ndef __HUGS__ */ + +#ifdef __HUGS__ +#ifndef __PARALLEL_HASKELL__ +writeBlocks :: ForeignObj -> Addr -> Int -> Int -> String -> IO () +#else +writeBlocks :: Addr -> Addr -> Int -> Int -> String -> IO () +#endif +writeBlocks obj buf bufLen initPos s = + let + shoveString :: Int -> [Char] -> IO () + shoveString n ls = + case ls of + [] -> + if n == 0 then + CCALL(setBufWPtr) obj (0::Int) + else do + {- + At the end of a buffer write, update the buffer position + in the underlying file object, so that if the handle + is subsequently dropped by the program, the whole + buffer will be properly flushed. + + There's one case where this delayed up-date of the buffer + position can go wrong: if a thread is killed, it might be + in the middle of filling up a buffer, with the result that + the partial buffer update is lost upon finalisation. However, + by the time killThread is supported, Haskell finalisers are also + likely to be in, which means the 'IOFileObject' hack can go + alltogether. + + -} + CCALL(setBufWPtr) obj n + (x:xs) -> do + primWriteCharOffAddr buf n x + if n == bufLen + then do + rc <- mayBlock obj (CCALL(writeFileObject) obj (n + 1)) -- ConcHask: UNSAFE, may block. + if rc == 0 + then shoveString 0 xs + else constructErrorAndFail "writeChunks" + else + shoveString (n + 1) xs + in + shoveString initPos s +#else /* ndef __HUGS__ */ #ifndef __PARALLEL_HASKELL__ writeBlocks :: ForeignObj -> Addr -> Int -> Int -> String -> IO () #else writeBlocks :: Addr -> Addr -> Int -> Int -> String -> IO () #endif -writeBlocks obj buf bf@(I# bufLen) (I# initPos#) s = +writeBlocks obj buf (I# bufLen) (I# initPos#) s = let write_char :: Addr -> Int# -> Char# -> IO () - write_char (A# buf) n# c# = + write_char (A# buf#) n# c# = IO $ \ s# -> - case (writeCharOffAddr# buf n# c# s#) of s2# -> IOok s2# () + case (writeCharOffAddr# buf# n# c# s#) of s2# -> (# s2#, () #) shoveString :: Int# -> [Char] -> IO () shoveString n ls = case ls of [] -> if n ==# 0# then - _ccall_ setBufWPtr obj (0::Int) + CCALL(setBufWPtr) obj (0::Int) else do {- At the end of a buffer write, update the buffer position @@ -452,13 +607,13 @@ writeBlocks obj buf bf@(I# bufLen) (I# initPos#) s = alltogether. -} - _ccall_ setBufWPtr obj (I# n) + CCALL(setBufWPtr) obj (I# n) ((C# x):xs) -> do write_char buf n x if n ==# bufLen then do - rc <- mayBlock obj (_ccall_ writeFileObject obj (I# (n +# 1#))) -- ConcHask: UNSAFE, may block. + rc <- mayBlock obj (CCALL(writeFileObject) obj (I# (n +# 1#))) -- ConcHask: UNSAFE, may block. if rc == 0 then shoveString 0# xs else constructErrorAndFail "writeChunks" @@ -466,15 +621,16 @@ writeBlocks obj buf bf@(I# bufLen) (I# initPos#) s = shoveString (n +# 1#) xs in shoveString initPos# s +#endif /* ndef __HUGS__ */ #ifndef __PARALLEL_HASKELL__ writeChars :: ForeignObj -> String -> IO () #else writeChars :: Addr -> String -> IO () #endif -writeChars fo "" = return () +writeChars _fo "" = return () writeChars fo (c:cs) = do - rc <- mayBlock fo (_ccall_ filePutc fo c) -- ConcHask: UNSAFE, may block. + rc <- mayBlock fo (CCALL(filePutc) fo c) -- ConcHask: UNSAFE, may block. if rc == 0 then writeChars fo cs else constructErrorAndFail "writeChars" @@ -489,7 +645,7 @@ hdl}. \begin{code} hPrint :: Show a => Handle -> a -> IO () -hPrint hdl = hPutStr hdl . show +hPrint hdl = hPutStrLn hdl . show \end{code} Derived action @hPutStrLn hdl str@ writes the string \tr{str} to @@ -526,7 +682,7 @@ bracket before after m = do after x case rs of Right r -> return r - Left e -> fail e + Left e -> ioError e -- variant of the above where middle computation doesn't want x bracket_ :: IO a -> (a -> IO b) -> IO c -> IO c @@ -536,7 +692,7 @@ bracket_ before after m = do after x case rs of Right r -> return r - Left e -> fail e + Left e -> ioError e \end{code} %********************************************************* @@ -595,4 +751,7 @@ readLn :: Read a => IO a readLn = do l <- getLine r <- readIO l return r + +#endif /* ndef HEAD */ + \end{code}