recSelError, recConError, irrefutPatError, runtimeError,
nonExhaustiveGuardsError, patError, noMethodBindingError,
assertError,
-
-#ifdef __GLASGOW_HASKELL__
- setUncaughtExceptionHandler, -- :: (Exception -> IO ()) -> IO ()
- getUncaughtExceptionHandler -- :: IO (Exception -> IO ())
-#endif
) where
#ifdef __GLASGOW_HASKELL__
import GHC.Base
import GHC.IOBase
-import {-# SOURCE #-} GHC.Handle
import GHC.List
import GHC.Num
import GHC.Show
import GHC.IOBase as ExceptionBase
import GHC.Exception hiding ( Exception )
-import {-# SOURCE #-} GHC.Conc ( ThreadId(ThreadId) )
+import GHC.Conc ( ThreadId(ThreadId) )
import Foreign.C.String ( CString, withCString )
#endif
assert False _ = throw (AssertionFailed "")
#endif
-
-#ifdef __GLASGOW_HASKELL__
-{-# NOINLINE uncaughtExceptionHandler #-}
-uncaughtExceptionHandler :: IORef (SomeException -> IO ())
-uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
- where
- defaultHandler :: SomeException -> IO ()
- defaultHandler se@(SomeException ex) = do
- (hFlush stdout) `catchAny` (\ _ -> return ())
- let msg = case cast ex of
- Just Deadlock -> "no threads to run: infinite loop or deadlock?"
- _ -> case cast ex of
- Just (ErrorCall s) -> s
- _ -> showsPrec 0 se ""
- withCString "%s" $ \cfmt ->
- withCString msg $ \cmsg ->
- errorBelch cfmt cmsg
-
--- don't use errorBelch() directly, because we cannot call varargs functions
--- using the FFI.
-foreign import ccall unsafe "HsBase.h errorBelch2"
- errorBelch :: CString -> CString -> IO ()
-
-setUncaughtExceptionHandler :: (SomeException -> IO ()) -> IO ()
-setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler
-
-getUncaughtExceptionHandler :: IO (SomeException -> IO ())
-getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler
-#endif
-
recSelError, recConError, irrefutPatError, runtimeError,
nonExhaustiveGuardsError, patError, noMethodBindingError
:: Addr# -> a -- All take a UTF8-encoded C string
-----
-data Deadlock = Deadlock
-INSTANCE_TYPEABLE0(Deadlock,deadlockTc,"Deadlock")
-
-instance Exception Deadlock
-
-instance Show Deadlock where
- showsPrec _ Deadlock = showString "<<deadlock>>"
-
------
-
data NestedAtomically = NestedAtomically
INSTANCE_TYPEABLE0(NestedAtomically,nestedAtomicallyTc,"NestedAtomically")
, win32ConsoleHandler
, toWin32ConsoleEvent
#endif
+ , setUncaughtExceptionHandler -- :: (Exception -> IO ()) -> IO ()
+ , getUncaughtExceptionHandler -- :: IO (Exception -> IO ())
+
, reportError, reportStackOverflow
) where
import Data.Maybe
import GHC.Base
+import {-# SOURCE #-} GHC.Handle
import GHC.IOBase
import GHC.Num ( Num(..) )
import GHC.Real ( fromIntegral, div )
import GHC.Show ( Show(..), showString )
import Data.Typeable
import GHC.Err
-import Control.Exception hiding (throwTo)
infixr 0 `par`, `pseq`
\end{code}
-- the unsafe below.
foreign import ccall unsafe "stackOverflow"
callStackOverflowHook :: IO ()
+
+{-# NOINLINE uncaughtExceptionHandler #-}
+uncaughtExceptionHandler :: IORef (SomeException -> IO ())
+uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
+ where
+ defaultHandler :: SomeException -> IO ()
+ defaultHandler se@(SomeException ex) = do
+ (hFlush stdout) `catchAny` (\ _ -> return ())
+ let msg = case cast ex of
+ Just Deadlock -> "no threads to run: infinite loop or deadlock?"
+ _ -> case cast ex of
+ Just (ErrorCall s) -> s
+ _ -> showsPrec 0 se ""
+ withCString "%s" $ \cfmt ->
+ withCString msg $ \cmsg ->
+ errorBelch cfmt cmsg
+
+-- don't use errorBelch() directly, because we cannot call varargs functions
+-- using the FFI.
+foreign import ccall unsafe "HsBase.h errorBelch2"
+ errorBelch :: CString -> CString -> IO ()
+
+setUncaughtExceptionHandler :: (SomeException -> IO ()) -> IO ()
+setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler
+
+getUncaughtExceptionHandler :: IO (SomeException -> IO ())
+getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler
\end{code}
throwIO, block, unblock, blocked, catchAny, catchException,
evaluate,
ErrorCall(..), ArithException(..), AsyncException(..),
- BlockedOnDeadMVar(..), BlockedIndefinitely(..),
+ BlockedOnDeadMVar(..), BlockedIndefinitely(..), Deadlock(..)
) where
import GHC.ST
-----
+data Deadlock = Deadlock
+ deriving Typeable
+
+instance Exception Deadlock
+
+instance Show Deadlock where
+ showsPrec _ Deadlock = showString "<<deadlock>>"
+
+-----
+
-- |The type of arithmetic exceptions
data ArithException
= Overflow