X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelHandle.lhs;h=d044bf850a69457c45abd682e1bb7e2da536ea18;hb=6ee2f67e582427f931c21c1fc58f62f8619d40b7;hp=caa8c50886f89d89e5c3bbf5836f0e86f1d91f9e;hpb=4864e32ad1c683c7fc569d6aa5f2c605076abdbe;p=ghc-hetmet.git diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs index caa8c50..d044bf8 100644 --- a/ghc/lib/std/PrelHandle.lhs +++ b/ghc/lib/std/PrelHandle.lhs @@ -15,20 +15,25 @@ which are supported for them. module PrelHandle where import PrelBase -import PrelArr ( newVar, readVar, writeVar, ByteArray ) +import PrelAddr ( Addr, nullAddr ) +import PrelArr ( newVar, readVar, writeVar, ByteArray(..) ) import PrelRead ( Read ) import PrelList ( span ) import PrelIOBase -import PrelException ( throw, ioError, catchException ) +import PrelException import PrelMaybe ( Maybe(..) ) +import PrelEnum +import PrelNum +import PrelShow import PrelAddr ( Addr, nullAddr ) -import PrelBounded () -- get at Bounded Int instance. -import PrelNum ( toInteger ) -import PrelWeak ( addForeignFinaliser ) +import PrelNum ( toInteger, toBig ) +import PrelPack ( packString ) +import PrelWeak ( addForeignFinalizer ) +import Ix + #if __CONCURRENT_HASKELL__ import PrelConc #endif -import Ix #ifndef __PARALLEL_HASKELL__ import PrelForeign ( makeForeignObj ) @@ -53,7 +58,6 @@ import PrelForeign ( makeForeignObj ) #else #define FILE_OBJECT Addr #endif - \end{code} %********************************************************* @@ -84,7 +88,7 @@ newHandle hc = newMVar hc >>= \ h -> -- exception occur while performing said op. withHandle (Handle h) act = do h_ <- takeMVar h - v <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex) + v <- catchNonIO (act h_) (\ ex -> putMVar h h_ >> throw ex) return v writeHandle (Handle h) hc = putMVar h hc @@ -104,7 +108,6 @@ withHandle (Handle h) act = do writeHandle (Handle h) hc = stToIO (writeVar h hc) #endif - \end{code} nullFile__ is only used for closed handles, plugging it in as a null @@ -139,7 +142,7 @@ mkErrorHandle__ ioe = %********************************************************* %* * -\subsection{Handle Finalisers} +\subsection{Handle Finalizers} %* * %********************************************************* @@ -190,7 +193,7 @@ stdout = unsafePerformIO (do #ifndef __PARALLEL_HASKELL__ fo <- makeForeignObj fo - addForeignFinaliser fo (freeStdFileObject fo) + addForeignFinalizer fo (freeStdFileObject fo) #endif #ifdef __HUGS__ @@ -224,7 +227,7 @@ stdin = unsafePerformIO (do #ifndef __PARALLEL_HASKELL__ fo <- makeForeignObj fo - addForeignFinaliser fo (freeStdFileObject fo) + addForeignFinalizer fo (freeStdFileObject fo) #endif (bm, bf_size) <- getBMode__ fo mkBuffer__ fo bf_size @@ -256,7 +259,7 @@ stderr = unsafePerformIO (do #ifndef __PARALLEL_HASKELL__ fo <- makeForeignObj fo - addForeignFinaliser fo (freeStdFileObject fo) + addForeignFinalizer fo (freeStdFileObject fo) #endif hdl <- newHandle (Handle__ fo WriteHandle NoBuffering "stderr") -- when stderr and stdout are both connected to a terminal, ensure @@ -297,7 +300,7 @@ openFileEx f m = do if fo /= nullAddr then do #ifndef __PARALLEL_HASKELL__ fo <- makeForeignObj fo - addForeignFinaliser fo (freeFileObject fo) + addForeignFinalizer fo (freeFileObject fo) #endif (bm, bf_size) <- getBMode__ fo mkBuffer__ fo bf_size @@ -367,7 +370,7 @@ hClose handle = ioError theError ClosedHandle -> do writeHandle handle handle_ - ioe_closedHandle "hClose" handle + return () _ -> do rc <- CCALL(closeFile) (haFO__ handle_) (1::Int){-flush if you can-} -- ConcHask: SAFE, won't block {- We explicitly close a file object so that we can be told @@ -375,7 +378,7 @@ hClose handle = has been performed, the ForeignObj embedded in the Handle is still lying around in the heap, so care is taken to avoid closing the file object when the ForeignObj - is finalised. (we overwrite the file ptr in the underlying + is finalized. (we overwrite the file ptr in the underlying FileObject with a NULL as part of closeFile()) -} if rc == (0::Int) @@ -436,12 +439,12 @@ hFileSize handle = -- For some reason, this fails to typecheck if converted to a do -- expression --SDM _casm_ ``%r = 1;'' >>= \(I# hack#) -> - case int2Integer hack# of - result@(J# _ _ d#) -> do - rc <- CCALL(fileSize) (haFO__ handle_) d# -- ConcHask: SAFE, won't block + case int2Integer# hack# of + (# s, d #) -> do + rc <- CCALL(fileSize) (haFO__ handle_) d -- ConcHask: SAFE, won't block writeHandle handle handle_ if rc == (0::Int) then - return result + return (J# s d) else constructErrorAndFail "hFileSize" #endif @@ -643,7 +646,8 @@ hSeek handle mode offset = let fo = haFO__ handle_ rc <- mayBlock fo (CCALL(seekFile_int64) fo whence (primIntegerToInt64 offset)) -- ConcHask: UNSAFE, may block #else -hSeek handle mode (J# _ s# d#) = +hSeek handle mode i@(S# _) = hSeek handle mode (toBig i) +hSeek handle mode (J# s# d#) = wantSeekableHandle "hSeek" handle $ \ handle_ -> do let fo = haFO__ handle_ rc <- mayBlock fo (CCALL(seekFile) fo whence (I# s#) d#) -- ConcHask: UNSAFE, may block @@ -888,7 +892,7 @@ hGetEcho handle = do hIsTerminalDevice :: Handle -> IO Bool hIsTerminalDevice handle = do withHandle handle $ \ handle_ -> do - case haType__ handle_ of + case haType__ handle_ of ErrorHandle theError -> do writeHandle handle handle_ ioError theError @@ -912,8 +916,8 @@ hConnectTo :: Handle -> Handle -> IO () hConnectTo hW hR = hConnectHdl_ hW hR 0{-connect regardless-} hConnectHdl_ :: Handle -> Handle -> Int -> IO () -hConnectHdl_ hW hR is_tty = - wantRWHandle "hConnectTo" hW $ \ hW_ -> do +hConnectHdl_ hW hR is_tty = + wantRWHandle "hConnectTo" hW $ \ hW_ -> wantRWHandle "hConnectTo" hR $ \ hR_ -> do CCALL(setConnectedTo) (haFO__ hR_) (haFO__ hW_) is_tty -- ConcHask: SAFE, won't block writeHandle hR hR_ @@ -1045,7 +1049,7 @@ the Handle contains.. \begin{code} getHandleFd :: Handle -> IO Int -getHandleFd handle = do +getHandleFd handle = withHandle handle $ \ handle_ -> do case (haType__ handle_) of ErrorHandle theError -> do @@ -1089,6 +1093,57 @@ ioeGetFileName (IOError _ _ _ str) = \end{code} +'Top-level' IO actions want to catch exceptions (e.g., forkIO and +PrelMain.mainIO) and report them - topHandler is the exception +handler they should use for this: + +\begin{code} +-- make sure we handle errors while reporting the error! +-- (e.g. evaluating the string passed to 'error' might generate +-- another error, etc.) +topHandler :: Bool -> Exception -> IO () +topHandler bombOut err = catchException (real_handler bombOut err) (topHandler bombOut) + +real_handler :: Bool -> Exception -> IO () +real_handler bombOut ex = + case ex of + AsyncException StackOverflow -> reportStackOverflow bombOut + ErrorCall s -> reportError bombOut s + other -> reportError bombOut (showsPrec 0 other "\n") + +reportStackOverflow :: Bool -> IO () +reportStackOverflow bombOut = do + (hFlush stdout) `catchException` (\ _ -> return ()) + callStackOverflowHook + if bombOut then + stg_exit 2 + else + return () + +reportError :: Bool -> String -> IO () +reportError bombOut str = do + (hFlush stdout) `catchException` (\ _ -> return ()) + let bs@(ByteArray (_,len) _) = packString str + writeErrString addrOf_ErrorHdrHook bs len + if bombOut then + stg_exit 1 + else + return () + +foreign label "ErrorHdrHook" + addrOf_ErrorHdrHook :: Addr + +foreign import ccall "writeErrString__" + writeErrString :: Addr -> ByteArray Int -> Int -> IO () + +foreign import ccall "stackOverflow" + callStackOverflowHook :: IO () + +foreign import ccall "stg_exit" + stg_exit :: Int -> IO () +\end{code} + + A number of operations want to get at a readable or writeable handle, and fail if it isn't: