From 740432bcb906959a6742ddde36946f6737e9447a Mon Sep 17 00:00:00 2001 From: krasimir Date: Thu, 12 Feb 2004 21:23:49 +0000 Subject: [PATCH] [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. --- Control/Concurrent.hs | 3 +-- Control/Exception.hs | 31 +++++++++++++++++++++++++++++-- GHC/TopHandler.lhs | 34 +++++++++++----------------------- cbits/writeError.c | 11 +++-------- include/HsBase.h | 10 +++++----- 5 files changed, 49 insertions(+), 40 deletions(-) diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs index bcabdf2..f299133 100644 --- 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 --- 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 --- 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 --- 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 --- 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 -- 1.7.10.4