wipwip/stack-overflow-size

4 files changed, 27 insertions, 15 deletions

diff --git a/libraries/base/Control/Exception.hs b/libraries/base/Control/Exception.hs
index 2d79d81dde..3d12677d24 100644
--- a/libraries/base/Control/Exception.hs
+++ b/libraries/base/Control/Exception.hs
@@ -231,7 +231,7 @@ allowInterrupt = interruptible $ return ()
 
  #AsynchronousExceptions# Asynchronous exceptions are so-called because they arise due to
 external influences, and can be raised at any point during execution.
-'StackOverflow' and 'HeapOverflow' are two examples of
+'StackOverflow\'' and 'HeapOverflow' are two examples of
 system-generated asynchronous exceptions.
 
 The primary source of asynchronous exceptions, however, is
diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs
index b587da0785..9041850573 100644
--- a/libraries/base/GHC/Conc/Sync.hs
+++ b/libraries/base/GHC/Conc/Sync.hs
@@ -412,7 +412,7 @@ real_handler se
   | Just BlockedIndefinitelyOnMVar <- fromException se  =  return ()
   | Just BlockedIndefinitelyOnSTM  <- fromException se  =  return ()
   | Just ThreadKilled              <- fromException se  =  return ()
-  | Just StackOverflow             <- fromException se  =  reportStackOverflow
+  | Just (StackOverflow' num_words)<- fromException se  =  reportStackOverflow num_words
   | otherwise                                           =  reportError se
 
 {- | 'killThread' raises the 'ThreadKilled' exception in the given
@@ -938,10 +938,11 @@ sharedCAF a get_or_set =
         else do freeStablePtr stable_ref
                 deRefStablePtr (castPtrToStablePtr (castPtr ref2))
 
-reportStackOverflow :: IO ()
-reportStackOverflow = do
-     ThreadId tid <- myThreadId
-     c_reportStackOverflow tid
+{- | @since TODO
+-}
+reportStackOverflow :: Word# -> IO ()
+reportStackOverflow stack_size =
+  c_reportStackOverflow stack_size
 
 reportError :: SomeException -> IO ()
 reportError ex = do
@@ -951,7 +952,7 @@ reportError ex = do
 -- SUP: Are the hooks allowed to re-enter Haskell land?  If so, remove
 -- the unsafe below.
 foreign import ccall unsafe "reportStackOverflow"
-        c_reportStackOverflow :: ThreadId# -> IO ()
+        c_reportStackOverflow :: Word# -> IO ()
 
 foreign import ccall unsafe "reportHeapOverflow"
         reportHeapOverflow :: IO ()
diff --git a/libraries/base/GHC/IO/Exception.hs b/libraries/base/GHC/IO/Exception.hs
index 758a84bf32..e789774204 100644
--- a/libraries/base/GHC/IO/Exception.hs
+++ b/libraries/base/GHC/IO/Exception.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE DeriveGeneric, NoImplicitPrelude, MagicHash,
-             ExistentialQuantification, ImplicitParams #-}
+             ExistentialQuantification, ImplicitParams,
+             PatternSynonyms #-}
 {-# OPTIONS_GHC -funbox-strict-fields #-}
 {-# OPTIONS_HADDOCK not-home #-}
 
@@ -29,7 +30,7 @@ module GHC.IO.Exception (
 
   SomeAsyncException(..),
   asyncExceptionToException, asyncExceptionFromException,
-  AsyncException(..), stackOverflow, heapOverflow,
+  AsyncException(.., StackOverflow), heapOverflow,
 
   ArrayException(..),
   ExitCode(..),
@@ -196,12 +197,15 @@ asyncExceptionFromException x = do
 
 -- |Asynchronous exceptions.
 data AsyncException
-  = StackOverflow
+  = StackOverflow' Word#
         -- ^The current thread\'s stack exceeded its limit.
         -- Since an exception has been raised, the thread\'s stack
         -- will certainly be below its limit again, but the
         -- programmer should take remedial action
         -- immediately.
+        -- @since TODO
+        -- The Word# is the size of the stack when the exception
+        -- was thrown
   | HeapOverflow
         -- ^The program\'s heap is reaching its limit, and
         -- the program should take action to reduce the amount of
@@ -230,6 +234,12 @@ data AsyncException
            , Ord -- ^ @since 4.2.0.0
            )
 
+-- | Provided for backwards compatibility.
+-- @since TODO
+pattern StackOverflow :: AsyncException
+pattern StackOverflow <- StackOverflow' {}
+  where StackOverflow = StackOverflow' 0##
+
 -- | @since 4.7.0.0
 instance Exception AsyncException where
   toException = asyncExceptionToException
@@ -251,13 +261,14 @@ data ArrayException
 instance Exception ArrayException
 
 -- for the RTS
-stackOverflow, heapOverflow :: SomeException
-stackOverflow = toException StackOverflow
+-- TODO remove stackOverflow?
+heapOverflow :: SomeException
 heapOverflow  = toException HeapOverflow
 
 -- | @since 4.1.0.0
 instance Show AsyncException where
-  showsPrec _ StackOverflow   = showString "stack overflow"
+  showsPrec _ (StackOverflow' stack_size)
+    = showString $ "stack overflow: " ++ (show (W# stack_size)) ++ " words"
   showsPrec _ HeapOverflow    = showString "heap overflow"
   showsPrec _ ThreadKilled    = showString "thread killed"
   showsPrec _ UserInterrupt   = showString "user interrupt"
diff --git a/libraries/base/GHC/TopHandler.hs b/libraries/base/GHC/TopHandler.hs
index b2b29cf5d7..7da051a319 100644
--- a/libraries/base/GHC/TopHandler.hs
+++ b/libraries/base/GHC/TopHandler.hs
@@ -173,8 +173,8 @@ real_handler :: (Int -> IO a) -> SomeException -> IO a
 real_handler exit se = do
   flushStdHandles -- before any error output
   case fromException se of
-      Just StackOverflow -> do
-           reportStackOverflow
+      Just (StackOverflow' num_words) -> do
+           reportStackOverflow num_words
            exit 2
 
       Just UserInterrupt -> exitInterrupted