X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FException.hs;h=aed144b55335948113d9cbe5eb921ddfe8e3c6c7;hb=95edd0503390f7437e7c1597b26fe1fe2a189189;hp=2db472f5fa9fefdf442439db2b0e3e1f3d9d2fab;hpb=ee695cc16336b7f2a6bca5bc74606c702837361d;p=ghc-base.git

diff --git a/Control/Exception.hs b/Control/Exception.hs
index 2db472f..aed144b 100644
--- a/Control/Exception.hs
+++ b/Control/Exception.hs
@@ -105,14 +105,20 @@ module Control.Exception (
 	bracket_, 	-- :: IO a -> IO b -> IO c -> IO ()
 
 	finally, 	-- :: IO a -> IO b -> IO a
-
+	
+#ifdef __GLASGOW_HASKELL__
+	setUncaughtExceptionHandler,      -- :: (Exception -> IO ()) -> IO ()
+	getUncaughtExceptionHandler       -- :: IO (Exception -> IO ())
+#endif
   ) where
 
 #ifdef __GLASGOW_HASKELL__
 import GHC.Base		( assert )
 import GHC.Exception 	as ExceptionBase hiding (catch)
 import GHC.Conc		( throwTo, ThreadId )
-import GHC.IOBase	( IO(..) )
+import Data.IORef	( IORef, newIORef, readIORef, writeIORef )
+import Foreign.C.String ( CString, withCStringLen )
+import System.IO	( stdout, hFlush )
 #endif
 
 #ifdef __HUGS__
@@ -185,7 +191,7 @@ catch =  ExceptionBase.catchException
 -- exceptions: 'ioErrors', 'arithExceptions', and so on.  For example,
 -- to catch just calls to the 'error' function, we could use
 --
--- >   result \<- catchJust errorCalls thing_to_try handler
+-- >   result <- catchJust errorCalls thing_to_try handler
 --
 -- Any other exceptions which are not matched by the predicate
 -- are re-raised, and may be caught by an enclosing
@@ -214,25 +220,6 @@ handleJust :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a
 handleJust p =  flip (catchJust p)
 
 -----------------------------------------------------------------------------
--- evaluate
-
--- | Forces its argument to be evaluated, and returns the result in
--- the 'IO' monad.  It can be used to order evaluation with respect to
--- other 'IO' operations; its semantics are given by
---
--- >   evaluate undefined `seq` return ()  ==> return ()
--- >   catch (evaluate undefined) (\e -> return ())  ==> return ()
---
--- NOTE: @(evaluate a)@ is /not/ the same as @(a \`seq\` return a)@.
-#ifdef __GLASGOW_HASKELL__
-evaluate :: a -> IO a
-evaluate a = IO $ \s -> case a `seq` () of () -> (# s, a #)
-	-- NB. can't write  
-	-- 	a `seq` (# s, a #)
-	-- because we can't have an unboxed tuple as a function argument
-#endif
-
------------------------------------------------------------------------------
 -- 'mapException'
 
 -- | This function maps one exception into another as proposed in the
@@ -460,8 +447,10 @@ in an asynchronous-exception-safe way, you will need to use
 Some operations are /interruptible/, which means that they can receive
 asynchronous exceptions even in the scope of a 'block'.  Any function
 which may itself block is defined as interruptible; this includes
-'takeMVar' (but not 'tryTakeMVar'), and most operations which perform
-some I\/O with the outside world..  The reason for having
+'Control.Concurrent.MVar.takeMVar'
+(but not 'Control.Concurrent.MVar.tryTakeMVar'),
+and most operations which perform
+some I\/O with the outside world.  The reason for having
 interruptible operations is so that we can write things like
 
 >      block (
@@ -470,14 +459,15 @@ interruptible operations is so that we can write things like
 >               (\e -> ...)
 >      )
 
-if the 'takeMVar' was not interruptible, then this particular
+if the 'Control.Concurrent.MVar.takeMVar' was not interruptible,
+then this particular
 combination could lead to deadlock, because the thread itself would be
 blocked in a state where it can\'t receive any asynchronous exceptions.
-With 'takeMVar' interruptible, however, we can be
+With 'Control.Concurrent.MVar.takeMVar' interruptible, however, we can be
 safe in the knowledge that the thread can receive exceptions right up
-until the point when the 'takeMVar' succeeds.
+until the point when the 'Control.Concurrent.MVar.takeMVar' succeeds.
 Similar arguments apply for other interruptible operations like
-'GHC.Handle.openFile'.
+'System.IO.openFile'.
 -}
 
 -- -----------------------------------------------------------------------------
@@ -485,7 +475,7 @@ Similar arguments apply for other interruptible operations like
 
 #ifdef __HADDOCK__
 -- | If the first argument evaluates to 'True', then the result is the
--- second argument.  Otherwise an 'Assertion' exception is raised,
+-- second argument.  Otherwise an 'AssertionFailed' exception is raised,
 -- containing a 'String' with the source file and line number of the
 -- call to assert.
 --
@@ -502,3 +492,28 @@ assert :: Bool -> a -> a
 assert True x = x
 assert False _ = throw (AssertionFailed "")
 #endif
+
+
+#ifdef __GLASGOW_HASKELL__
+{-# NOINLINE uncaughtExceptionHandler #-}
+uncaughtExceptionHandler :: IORef (Exception -> IO ())
+uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
+   where
+      defaultHandler :: Exception -> IO ()
+      defaultHandler ex = do
+         (hFlush stdout) `catchException` (\ _ -> return ())
+         let msg = case ex of
+               Deadlock    -> "no threads to run:  infinite loop or deadlock?"
+               ErrorCall s -> s
+               other       -> showsPrec 0 other "\n"
+         withCStringLen ("Fail: "++msg) $ \(cstr,len) -> writeErrString cstr len
+         
+foreign import ccall unsafe "writeErrString__"
+	writeErrString :: CString -> Int -> IO ()
+
+setUncaughtExceptionHandler :: (Exception -> IO ()) -> IO ()
+setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler
+
+getUncaughtExceptionHandler :: IO (Exception -> IO ())
+getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler
+#endif