[project @ 2004-02-12 21:23:48 by krasimir]

Added interface to set/get handler for uncatched exceptions.
The handler is invoked from the GHC.TopHandler.topHandler or
Control.Concurrent.childHandler when an exception is catched.

diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs
index bcabdf2..f299133 100644 (file)
--- a/Control/Concurrent.hs
+++ b/Control/Concurrent.hs
@@ -229,8 +229,7 @@ real_handler ex =
 
        -- report all others:
        AsyncException StackOverflow -> reportStackOverflow False
-       ErrorCall s -> reportError False s
-       other       -> reportError False (showsPrec 0 other "\n")
+       other       -> reportError False other
 
 #endif /* __GLASGOW_HASKELL__ */
 

diff --git a/Control/Exception.hs b/Control/Exception.hs
index 087f6fd..51bd404 100644 (file)
--- a/Control/Exception.hs
+++ b/Control/Exception.hs
@@ -105,14 +105,18 @@ module Control.Exception (
        bracket_,       -- :: IO a -> IO b -> IO c -> IO ()
 
        finally,        -- :: IO a -> IO b -> IO a
-
+       
+       setUncatchedExceptionHandler,      -- :: (Exception -> IO ()) -> IO ()
+       getUncatchedExceptionHandler       -- :: IO (Exception -> IO ())
   ) 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 GHC.IOBase      ( IO(..), IORef(..), newIORef, readIORef, writeIORef )
+import GHC.Handle       ( stdout, hFlush )
+import Foreign.C.String ( CString, withCStringLen )
 #endif
 
 #ifdef __HUGS__
@@ -505,3 +509,26 @@ assert :: Bool -> a -> a
 assert True x = x
 assert False _ = throw (AssertionFailed "")
 #endif
+
+
+{-# NOINLINE uncatchedExceptionHandler #-}
+uncatchedExceptionHandler :: IORef (Exception -> IO ())
+uncatchedExceptionHandler = 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 ()
+
+setUncatchedExceptionHandler :: (Exception -> IO ()) -> IO ()
+setUncatchedExceptionHandler = writeIORef uncatchedExceptionHandler
+
+getUncatchedExceptionHandler :: IO (Exception -> IO ())
+getUncatchedExceptionHandler = readIORef uncatchedExceptionHandler

diff --git a/GHC/TopHandler.lhs b/GHC/TopHandler.lhs
index 5fc3236..884fcf1 100644 (file)
--- a/GHC/TopHandler.lhs
+++ b/GHC/TopHandler.lhs
@@ -15,12 +15,13 @@
 -----------------------------------------------------------------------------
 
 module GHC.TopHandler (
-   runIO, runNonIO, reportStackOverflow, reportError 
+   runIO, runNonIO, reportStackOverflow, reportError
   ) where
 
 import Prelude
 
 import System.IO
+import Control.Exception
 
 import Foreign.C.String
 import Foreign.Ptr
@@ -60,11 +61,8 @@ real_handler ex =
        ExitException ExitSuccess     -> safe_exit 0
        ExitException (ExitFailure n) -> safe_exit n
 
-       Deadlock    -> reportError True 
-                       "no threads to run:  infinite loop or deadlock?"
-  
-       ErrorCall s -> reportError True s
-       other       -> reportError True (showsPrec 0 other "\n")
+       other       -> reportError True other
+          
 
 reportStackOverflow :: Bool -> IO a
 reportStackOverflow bombOut = do
@@ -74,23 +72,13 @@ reportStackOverflow bombOut = do
        then exit 2
        else return undefined
 
-reportError :: Bool -> String -> IO a
-reportError bombOut str = do
-   (hFlush stdout) `catchException` (\ _ -> return ())
-   withCStringLen str $ \(cstr,len) -> do
-     writeErrString errorHdrHook cstr len
-     if bombOut 
-       then exit 1
-        else return undefined
-
-#ifndef ILX
-foreign import ccall "&ErrorHdrHook" errorHdrHook :: Ptr ()
-#else
-foreign import ccall "ErrorHdrHook" errorHdrHook :: Ptr ()
-#endif
-
-foreign import ccall unsafe "writeErrString__"
-       writeErrString :: Ptr () -> CString -> Int -> IO ()
+reportError :: Bool -> Exception -> IO a
+reportError bombOut ex = do
+   handler <- getUncatchedExceptionHandler
+   handler ex
+   if bombOut
+      then exit 1
+      else return undefined
 
 -- SUP: Are the hooks allowed to re-enter Haskell land?  If so, remove
 -- the unsafe below.

diff --git a/cbits/writeError.c b/cbits/writeError.c
index d3a3b4b..a5cd700 100644 (file)
--- a/cbits/writeError.c
+++ b/cbits/writeError.c
@@ -1,7 +1,7 @@
-/* 
+/*
  * (c) The University of Glasgow 2002
  *
- * $Id: writeError.c,v 1.5 2002/02/07 11:13:30 simonmar Exp $
+ * $Id: writeError.c,v 1.6 2004/02/12 21:23:49 krasimir Exp $
  *
  * hPutStr Runtime Support
  */
@@ -21,7 +21,7 @@ implementation in one or two places.)
 #include "HsBase.h"
 
 void
-writeErrString__(HsAddr msg_hdr, HsAddr msg, HsInt len)
+writeErrString__(HsAddr msg, HsInt len)
 {
   int count = 0;
   char* p  = (char*)msg;
@@ -31,11 +31,6 @@ writeErrString__(HsAddr msg_hdr, HsAddr msg, HsInt len)
   resetNonBlockingFd(2);
 #endif
 
-  /* Print error msg header */
-  if (msg_hdr) {
-    ((void (*)(int))msg_hdr)(2/*stderr*/);
-  }
-
   while ( (count = write(2,p,len)) < len) {
      if (errno != EINTR ) {
         return;

diff --git a/include/HsBase.h b/include/HsBase.h
index 6c68618..a63c087 100644 (file)
--- a/include/HsBase.h
+++ b/include/HsBase.h
@@ -128,7 +128,7 @@ HsInt rawSystem(HsAddr cmd, HsAddr args);
 int inputReady(int fd, int msecs, int isSock);
 
 /* in writeError.c */
-void writeErrString__(HsAddr msg_hdr, HsAddr msg, HsInt len);
+void writeErrString__(HsAddr msg, HsInt len);
 
 /* in Signals.c */
 extern HsInt nocldstop;
@@ -390,7 +390,7 @@ __hscore_setmode( HsInt fd, HsBool toBin )
   return setmode(fd,(toBin == HS_BOOL_TRUE) ? _O_BINARY : _O_TEXT);
 #else
   return 0;
-#endif  
+#endif
 }
 
 INLINE HsInt
@@ -467,7 +467,7 @@ INLINE mode_t __hscore_S_IXUSR() { return S_IXUSR; }
 #if !defined(_MSC_VER)
 INLINE HsAddr
 __hscore_d_name( struct dirent* d )
-{ 
+{
 #if !defined(mingw32_TARGET_OS) && !defined(_MSC_VER)
   return (HsAddr)(&d->d_name);
 #else
@@ -483,7 +483,7 @@ __hscore_end_of_dir( void )
   return 0;
 #else
   return ENOENT;
-#endif  
+#endif
 }
 
 INLINE void
@@ -513,7 +513,7 @@ INLINE void
 __hscore_poke_lflag( struct termios* ts, tcflag_t t ) { ts->c_lflag = t; }
 
 INLINE unsigned char*
-__hscore_ptr_c_cc( struct termios* ts ) 
+__hscore_ptr_c_cc( struct termios* ts )
 { return (unsigned char*) &ts->c_cc; }
 
 INLINE HsInt