diff options
Diffstat (limited to 'libraries')
| -rw-r--r-- | libraries/base/GHC/Conc.hs | 2 | ||||
| -rw-r--r-- | libraries/base/GHC/Conc/Sync.hs | 11 | ||||
| -rw-r--r-- | libraries/base/GHC/TopHandler.hs | 5 |
3 files changed, 11 insertions, 7 deletions
diff --git a/libraries/base/GHC/Conc.hs b/libraries/base/GHC/Conc.hs index afc0a97d30..74d14badf6 100644 --- a/libraries/base/GHC/Conc.hs +++ b/libraries/base/GHC/Conc.hs @@ -110,7 +110,7 @@ module GHC.Conc , setUncaughtExceptionHandler , getUncaughtExceptionHandler - , reportError, reportStackOverflow + , reportError, reportStackOverflow, reportHeapOverflow ) where import GHC.Conc.IO diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs index a70e103952..78a0334617 100644 --- a/libraries/base/GHC/Conc/Sync.hs +++ b/libraries/base/GHC/Conc/Sync.hs @@ -91,7 +91,7 @@ module GHC.Conc.Sync , setUncaughtExceptionHandler , getUncaughtExceptionHandler - , reportError, reportStackOverflow + , reportError, reportStackOverflow, reportHeapOverflow , sharedCAF ) where @@ -883,7 +883,7 @@ sharedCAF a get_or_set = reportStackOverflow :: IO () reportStackOverflow = do ThreadId tid <- myThreadId - callStackOverflowHook tid + c_reportStackOverflow tid reportError :: SomeException -> IO () reportError ex = do @@ -892,8 +892,11 @@ reportError ex = do -- SUP: Are the hooks allowed to re-enter Haskell land? If so, remove -- the unsafe below. -foreign import ccall unsafe "stackOverflow" - callStackOverflowHook :: ThreadId# -> IO () +foreign import ccall unsafe "reportStackOverflow" + c_reportStackOverflow :: ThreadId# -> IO () + +foreign import ccall unsafe "reportHeapOverflow" + reportHeapOverflow :: IO () {-# NOINLINE uncaughtExceptionHandler #-} uncaughtExceptionHandler :: IORef (SomeException -> IO ()) diff --git a/libraries/base/GHC/TopHandler.hs b/libraries/base/GHC/TopHandler.hs index f1c87e5110..58da871729 100644 --- a/libraries/base/GHC/TopHandler.hs +++ b/libraries/base/GHC/TopHandler.hs @@ -177,8 +177,9 @@ real_handler exit se = do Just UserInterrupt -> exitInterrupted - Just HeapOverflow -> exit 251 - -- the RTS has already emitted a message to stderr + Just HeapOverflow -> do + reportHeapOverflow + exit 251 _ -> case fromException se of -- only the main thread gets ExitException exceptions |