X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelHandle.lhs;h=6d3e4c74d42719089331add3e766bc09af382573;hb=a23a8116c3bab9340e1bee39ef80c83969d67101;hp=1731cbf4ce8e2ff48951b301f97344f2a27dd9f3;hpb=5a21d20b0f25de3d829de90d219cb66855f91d58;p=ghc-hetmet.git diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs index 1731cbf..6d3e4c7 100644 --- a/ghc/lib/std/PrelHandle.lhs +++ b/ghc/lib/std/PrelHandle.lhs @@ -1,5 +1,7 @@ +% ------------------------------------------------------------------------------ +% $Id: PrelHandle.lhs,v 1.64 2001/01/10 16:28:15 qrczak Exp $ % -% (c) The AQUA Project, Glasgow University, 1994-1996 +% (c) The AQUA Project, Glasgow University, 1994-2000 % \section[PrelHandle]{Module @PrelHandle@} @@ -8,7 +10,7 @@ This module defines Haskell {\em handles} and the basic operations which are supported for them. \begin{code} -{-# OPTIONS -fcompiling-prelude -fno-implicit-prelude -#include "cbits/stgio.h" #-} +{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-} #include "cbits/stgerror.h" #ifndef __HUGS__ /* Hugs just includes this in PreludeBuiltin so no header needed */ @@ -17,12 +19,12 @@ module PrelHandle where import PrelArr import PrelBase import PrelAddr ( Addr, nullAddr ) -import PrelByteArr ( ByteArray(..), MutableByteArray(..) ) +import PrelByteArr ( ByteArray(..) ) import PrelRead ( Read ) -import PrelList ( span ) +import PrelList ( break ) import PrelIOBase -import PrelException import PrelMaybe ( Maybe(..) ) +import PrelException import PrelEnum import PrelNum ( toBig, Integer(..), Num(..) ) import PrelShow @@ -53,6 +55,20 @@ import PrelForeign ( makeForeignObj, mkForeignObj ) #endif \end{code} +\begin{code} +mkBuffer__ :: FILE_OBJECT -> Int -> IO () +mkBuffer__ fo sz_in_bytes = do + chunk <- + case sz_in_bytes of + 0 -> return nullAddr -- this has the effect of overwriting the pointer to the old buffer. + _ -> do + chunk <- malloc sz_in_bytes + if chunk == nullAddr + then ioException (IOError Nothing ResourceExhausted "mkBuffer__" "not enough virtual memory") + else return chunk + setBuf fo chunk sz_in_bytes +\end{code} + %********************************************************* %* * \subsection{Types @Handle@, @Handle__@} @@ -100,7 +116,7 @@ but we might want to revisit this in the future --SDM ]. withHandle :: Handle -> (Handle__ -> IO (Handle__,a)) -> IO a {-# INLINE withHandle #-} withHandle (Handle h) act = - blockAsyncExceptions $ do + block $ do h_ <- takeMVar h (h',v) <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex) putMVar h h' @@ -109,7 +125,7 @@ withHandle (Handle h) act = withHandle_ :: Handle -> (Handle__ -> IO a) -> IO a {-# INLINE withHandle_ #-} withHandle_ (Handle h) act = - blockAsyncExceptions $ do + block $ do h_ <- takeMVar h v <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex) putMVar h h_ @@ -118,7 +134,7 @@ withHandle_ (Handle h) act = withHandle__ :: Handle -> (Handle__ -> IO Handle__) -> IO () {-# INLINE withHandle__ #-} withHandle__ (Handle h) act = - blockAsyncExceptions $ do + block $ do h_ <- takeMVar h h' <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex) putMVar h h' @@ -146,15 +162,6 @@ mkClosedHandle__ = haFilePath__ = "closed file", haBuffers__ = [] } - -mkErrorHandle__ :: IOError -> Handle__ -mkErrorHandle__ ioe = - Handle__ { haFO__ = nullFile__, - haType__ = (ErrorHandle ioe), - haBufferMode__ = NoBuffering, - haFilePath__ = "error handle", - haBuffers__ = [] - } \end{code} %********************************************************* @@ -235,8 +242,7 @@ stdout = unsafePerformIO (do #endif return hdl - _ -> do ioError <- constructError "stdout" - newHandle (mkErrorHandle__ ioError) + _ -> constructErrorAndFail "stdout" ) stdin = unsafePerformIO (do @@ -261,8 +267,7 @@ stdin = unsafePerformIO (do #endif hConnectTerms stdout hdl return hdl - _ -> do ioError <- constructError "stdin" - newHandle (mkErrorHandle__ ioError) + _ -> constructErrorAndFail "stdin" ) @@ -287,8 +292,7 @@ stderr = unsafePerformIO (do hConnectTo stdout hdl return hdl - _ -> do ioError <- constructError "stderr" - newHandle (mkErrorHandle__ ioError) + _ -> constructErrorAndFail "stderr" ) \end{code} @@ -379,7 +383,6 @@ hClose :: Handle -> IO () hClose handle = withHandle__ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError ClosedHandle -> return handle_ _ -> do rc <- closeFile (haFO__ handle_) @@ -400,7 +403,6 @@ hClose handle = -- associated with this handle. else do freeBuffers (haBuffers__ handle_) return (handle_{ haType__ = ClosedHandle, - haFO__ = nullFile__, haBuffers__ = [] }) \end{code} @@ -424,7 +426,6 @@ hFileSize :: Handle -> IO Integer hFileSize handle = withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError ClosedHandle -> ioe_closedHandle "hFileSize" handle SemiClosedHandle -> ioe_closedHandle "hFileSize" handle #ifdef __HUGS__ @@ -515,15 +516,15 @@ hSetBuffering :: Handle -> BufferMode -> IO () hSetBuffering handle mode = case mode of BlockBuffering (Just n) - | n <= 0 -> ioError + | n <= 0 -> ioException (IOError (Just handle) InvalidArgument "hSetBuffering" - ("illegal buffer size " ++ showsPrec 9 n [])) -- 9 => should be parens'ified. + ("illegal buffer size " ++ showsPrec 9 n [])) + -- 9 => should be parens'ified. _ -> withHandle__ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError ClosedHandle -> ioe_closedHandle "hSetBuffering" handle _ -> do {- Note: @@ -697,7 +698,6 @@ hIsOpen :: Handle -> IO Bool hIsOpen handle = withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError ClosedHandle -> return False SemiClosedHandle -> return False _ -> return True @@ -706,7 +706,6 @@ hIsClosed :: Handle -> IO Bool hIsClosed handle = withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError ClosedHandle -> return True _ -> return False @@ -724,7 +723,6 @@ hIsReadable :: Handle -> IO Bool hIsReadable handle = withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError ClosedHandle -> ioe_closedHandle "hIsReadable" handle SemiClosedHandle -> ioe_closedHandle "hIsReadable" handle htype -> return (isReadable htype) @@ -737,7 +735,6 @@ hIsWritable :: Handle -> IO Bool hIsWritable handle = withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError ClosedHandle -> ioe_closedHandle "hIsWritable" handle SemiClosedHandle -> ioe_closedHandle "hIsWritable" handle htype -> return (isWritable htype) @@ -769,7 +766,6 @@ hGetBuffering :: Handle -> IO BufferMode hGetBuffering handle = withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError ClosedHandle -> ioe_closedHandle "hGetBuffering" handle _ -> {- @@ -784,7 +780,6 @@ hIsSeekable :: Handle -> IO Bool hIsSeekable handle = withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError ClosedHandle -> ioe_closedHandle "hIsSeekable" handle SemiClosedHandle -> ioe_closedHandle "hIsSeekable" handle AppendHandle -> return False @@ -815,7 +810,6 @@ hSetEcho handle on = do else withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError ClosedHandle -> ioe_closedHandle "hSetEcho" handle _ -> do rc <- setTerminalEcho (haFO__ handle_) (if on then 1 else 0) -- ConcHask: SAFE, won't block @@ -831,7 +825,6 @@ hGetEcho handle = do else withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError ClosedHandle -> ioe_closedHandle "hGetEcho" handle _ -> do rc <- getTerminalEcho (haFO__ handle_) -- ConcHask: SAFE, won't block @@ -844,7 +837,6 @@ hIsTerminalDevice :: Handle -> IO Bool hIsTerminalDevice handle = do withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError ClosedHandle -> ioe_closedHandle "hIsTerminalDevice" handle _ -> do rc <- isTerminalDevice (haFO__ handle_) -- ConcHask: SAFE, won't block @@ -898,7 +890,7 @@ slurpFile fname = do ioError (userError "slurpFile: file too big") else do let sz_i = fromInteger sz - chunk <- allocMemory__ sz_i + chunk <- malloc sz_i if chunk == nullAddr then do hClose handle @@ -923,7 +915,6 @@ getHandleFd :: Handle -> IO Int getHandleFd handle = withHandle_ handle $ \ handle_ -> do case (haType__ handle_) of - ErrorHandle theError -> ioError theError ClosedHandle -> ioe_closedHandle "getHandleFd" handle _ -> do fd <- getFileFd (haFO__ handle_) @@ -946,17 +937,23 @@ ioeGetFileName :: IOError -> Maybe FilePath ioeGetErrorString :: IOError -> String ioeGetHandle :: IOError -> Maybe Handle -ioeGetHandle (IOError h _ _ _) = h -ioeGetErrorString (IOError _ iot _ str) = - case iot of - EOF -> "end of file" - _ -> str - -ioeGetFileName (IOError _ _ _ str) = - case span (/=':') str of - (_,[]) -> Nothing - (fs,_) -> Just fs - +ioeGetHandle (IOException (IOError h _ _ _)) = h +ioeGetHandle (UserError _) = Nothing +ioeGetHandle _ = error "IO.ioeGetHandle: not an IO error" + +ioeGetErrorString (IOException (IOError _ iot _ str)) = + case iot of + EOF -> "end of file" + _ -> str +ioeGetErrorString (UserError str) = str +ioeGetErrorString _ = error "IO.ioeGetErrorString: not an IO error" + +ioeGetFileName (IOException (IOError _ _ _ str)) = + case break (== ':') str of + (_, []) -> Nothing + (_, _:' ':fs)-> Just fs +ioeGetFileName (UserError _) = Nothing +ioeGetFileName _ = error "IO.ioeGetFileName: not an IO error" \end{code} 'Top-level' IO actions want to catch exceptions (e.g., forkIO and @@ -996,16 +993,17 @@ reportError bombOut str = do else return () -foreign label "ErrorHdrHook" +foreign import ccall "addrOf_ErrorHdrHook" unsafe addrOf_ErrorHdrHook :: Addr foreign import ccall "writeErrString__" unsafe writeErrString :: Addr -> ByteArray Int -> Int -> IO () -foreign import ccall "stackOverflow" +-- SUP: Are the hooks allowed to re-enter Haskell land? If yes, remove the unsafe below. +foreign import ccall "stackOverflow" unsafe callStackOverflowHook :: IO () -foreign import ccall "stg_exit" +foreign import ccall "stg_exit" unsafe stg_exit :: Int -> IO () \end{code} @@ -1018,11 +1016,10 @@ wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a wantReadableHandle fun handle act = withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError ClosedHandle -> ioe_closedHandle fun handle SemiClosedHandle -> ioe_closedHandle fun handle - AppendHandle -> ioError not_readable_error - WriteHandle -> ioError not_readable_error + AppendHandle -> ioException not_readable_error + WriteHandle -> ioException not_readable_error _ -> act handle_ where not_readable_error = @@ -1041,21 +1038,19 @@ wantWriteableHandle_ fun handle act = checkWriteableHandle fun handle handle_ act = case haType__ handle_ of - ErrorHandle theError -> ioError theError ClosedHandle -> ioe_closedHandle fun handle SemiClosedHandle -> ioe_closedHandle fun handle ReadHandle -> ioError not_writeable_error _ -> act where not_writeable_error = - IOError (Just handle) IllegalOperation fun - ("handle is not open for writing") + IOException (IOError (Just handle) IllegalOperation fun + ("handle is not open for writing")) wantRWHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a wantRWHandle fun handle act = withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError ClosedHandle -> ioe_closedHandle fun handle SemiClosedHandle -> ioe_closedHandle fun handle _ -> act handle_ @@ -1064,16 +1059,9 @@ wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a wantSeekableHandle fun handle act = withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> ioError theError ClosedHandle -> ioe_closedHandle fun handle SemiClosedHandle -> ioe_closedHandle fun handle _ -> act handle_ - where - not_seekable_error = - IOError (Just handle) - IllegalOperation fun - ("handle is not seekable") - \end{code} Internal function for creating an @IOError@ representing the @@ -1081,7 +1069,8 @@ access to a closed file. \begin{code} ioe_closedHandle :: String -> Handle -> IO a -ioe_closedHandle fun h = ioError (IOError (Just h) IllegalOperation fun "handle is closed") +ioe_closedHandle fun h = ioError (IOException (IOError (Just h) IllegalOperation fun + "handle is closed")) \end{code} Internal helper functions for Concurrent Haskell implementation @@ -1107,10 +1096,10 @@ mayBlock fo act = do _ -> do return rc -data MayBlock +data MayBlock a = BlockRead Int | BlockWrite Int - | NoBlock Int + | NoBlock a mayBlockRead :: String -> Handle -> (FILE_OBJECT -> IO Int) -> IO Int mayBlockRead fname handle fn = do @@ -1140,6 +1129,38 @@ mayBlockRead fname handle fn = do mayBlockRead fname handle fn NoBlock c -> return c +mayBlockRead' :: String -> Handle + -> (FILE_OBJECT -> IO Int) + -> (FILE_OBJECT -> Int -> IO a) + -> IO a +mayBlockRead' fname handle fn io = do + r <- wantReadableHandle fname handle $ \ handle_ -> do + let fo = haFO__ handle_ + rc <- fn fo + case rc of + -5 -> do -- (possibly blocking) read + fd <- getFileFd fo + return (BlockRead fd) + -6 -> do -- (possibly blocking) write + fd <- getFileFd fo + return (BlockWrite fd) + -7 -> do -- (possibly blocking) write on connected handle + fd <- getConnFileFd fo + return (BlockWrite fd) + _ -> + if rc >= 0 + then do a <- io fo rc + return (NoBlock a) + else constructErrorAndFail fname + case r of + BlockRead fd -> do + threadWaitRead fd + mayBlockRead' fname handle fn io + BlockWrite fd -> do + threadWaitWrite fd + mayBlockRead' fname handle fn io + NoBlock c -> return c + mayBlockWrite :: String -> Handle -> (FILE_OBJECT -> IO Int) -> IO Int mayBlockWrite fname handle fn = do r <- wantWriteableHandle fname handle $ \ handle_ -> do @@ -1269,7 +1290,7 @@ foreign import "libHS_cbits" "openFile" unsafe foreign import "libHS_cbits" "const_BUFSIZ" unsafe const_BUFSIZ :: Int -foreign import "libHS_cbits" "setBinaryMode__" +foreign import "libHS_cbits" "setBinaryMode__" unsafe setBinaryMode :: FILE_OBJECT -> Int -> IO Int \end{code}