wipwip/stack-overflow-size

11 files changed, 60 insertions, 26 deletions

diff --git a/docs/users_guide/9.6.1-notes.rst b/docs/users_guide/9.6.1-notes.rst
index dfd800d11b..70bd546318 100644
--- a/docs/users_guide/9.6.1-notes.rst
+++ b/docs/users_guide/9.6.1-notes.rst
@@ -151,6 +151,12 @@ Runtime system
   case properties and are more intuitive than :base-ref:`Data.Char.isUpper` and 
   :base-ref:`Data.Char.isLower`.
 
+- ``GHC.IO.Exceptions.AsyncException.StackOverflow`` has been replaced with a
+  new constructor ``GHC.IO.Exceptions.AsyncException.StackOverflow'`` holding a
+  new ``Word#`` communicating the size of the stack when the overflow occurred.
+  A new pattern synonym ``GHC.IO.Exceptions.StackOverflow`` is bundled with
+  ``GHC.IO.Exceptions.AsyncException``, so no changes to programs are required.
+
 ``ghc-prim`` library
 ~~~~~~~~~~~~~~~~~~~~
 
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
diff --git a/rts/Prelude.h b/rts/Prelude.h
index a474771f5d..be6743f76d 100644
--- a/rts/Prelude.h
+++ b/rts/Prelude.h
@@ -40,7 +40,6 @@ extern W_ ZCMain_main_closure[];
 extern StgClosure ZCMain_main_closure;
 #endif
 
-PRELUDE_CLOSURE(base_GHCziIOziException_stackOverflow_closure);
 PRELUDE_CLOSURE(base_GHCziIOziException_heapOverflow_closure);
 PRELUDE_CLOSURE(base_GHCziIOziException_allocationLimitExceeded_closure);
 PRELUDE_CLOSURE(base_GHCziIOziException_blockedIndefinitelyOnMVar_closure);
@@ -86,6 +85,7 @@ PRELUDE_INFO(base_GHCziWord_W16zh_con_info);
 PRELUDE_INFO(base_GHCziWord_W32zh_con_info);
 PRELUDE_INFO(base_GHCziWord_W64zh_con_info);
 PRELUDE_INFO(base_GHCziStable_StablePtr_con_info);
+PRELUDE_INFO(base_GHCziIOziException_StackOverflowzq_con_info);
 
 #define Unit_closure              DLL_IMPORT_DATA_REF(ghczmprim_GHCziTupleziPrim_Z0T_closure)
 #define True_closure              DLL_IMPORT_DATA_REF(ghczmprim_GHCziTypes_True_closure)
@@ -106,7 +106,6 @@ PRELUDE_INFO(base_GHCziStable_StablePtr_con_info);
 #define flushStdHandles_closure   DLL_IMPORT_DATA_REF(base_GHCziTopHandler_flushStdHandles_closure)
 #define runMainIO_closure   DLL_IMPORT_DATA_REF(base_GHCziTopHandler_runMainIO_closure)
 
-#define stackOverflow_closure     DLL_IMPORT_DATA_REF(base_GHCziIOziException_stackOverflow_closure)
 #define heapOverflow_closure      DLL_IMPORT_DATA_REF(base_GHCziIOziException_heapOverflow_closure)
 #define allocationLimitExceeded_closure DLL_IMPORT_DATA_REF(base_GHCziIOziException_allocationLimitExceeded_closure)
 #define blockedIndefinitelyOnMVar_closure DLL_IMPORT_DATA_REF(base_GHCziIOziException_blockedIndefinitelyOnMVar_closure)
@@ -142,3 +141,4 @@ PRELUDE_INFO(base_GHCziStable_StablePtr_con_info);
 #define FunPtr_con_info           DLL_IMPORT_DATA_REF(base_GHCziPtr_FunPtr_con_info)
 #define StablePtr_static_info     DLL_IMPORT_DATA_REF(base_GHCziStable_StablePtr_static_info)
 #define StablePtr_con_info        DLL_IMPORT_DATA_REF(base_GHCziStable_StablePtr_con_info)
+#define StackOverflow_con_info    DLL_IMPORT_DATA_REF(base_GHCziIOziException_StackOverflowzq_con_info)
diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c
index 7e0afe5f92..af05fb800a 100644
--- a/rts/RtsStartup.c
+++ b/rts/RtsStartup.c
@@ -192,7 +192,6 @@ static void initBuiltinGcRoots(void)
 
     getStablePtr((StgPtr)runFinalizerBatch_closure);
 
-    getStablePtr((StgPtr)stackOverflow_closure);
     getStablePtr((StgPtr)heapOverflow_closure);
     getStablePtr((StgPtr)unpackCString_closure);
     getStablePtr((StgPtr)blockedIndefinitelyOnMVar_closure);
diff --git a/rts/RtsUtils.c b/rts/RtsUtils.c
index d3dcdf3092..6c5f499336 100644
--- a/rts/RtsUtils.c
+++ b/rts/RtsUtils.c
@@ -133,9 +133,9 @@ stgFree(void* p)
    -------------------------------------------------------------------------- */
 
 void
-reportStackOverflow(StgTSO* tso)
+reportStackOverflow(StgWord words)
 {
-    rtsConfig.stackOverflowHook(tso->tot_stack_size * sizeof(W_));
+    rtsConfig.stackOverflowHook(words * sizeof(W_));
 
 #if defined(TICKY_TICKY)
     if (RtsFlags.TickyFlags.showTickyStats) PrintTickyInfo();
diff --git a/rts/Threads.c b/rts/Threads.c
index 07d0d0a180..5df69a53d4 100644
--- a/rts/Threads.c
+++ b/rts/Threads.c
@@ -528,6 +528,24 @@ isThreadBound(StgTSO* tso USED_IF_THREADS)
   return false;
 }
 
+static StgClosure*
+mkStackOverflowException(Capability *cap, StgWord stack_words) {
+    const size_t e_size = CONSTR_sizeW(0, 1);
+    ASSERT(sizeW_fromITBL(INFO_PTR_TO_STRUCT(StackOverflow_con_info)) == e_size);
+
+    debugBelch("new StackOverflow': size: %"FMT_Word " stack words: %"FMT_Word"\n", (StgWord)e_size, stack_words);
+    debugBelch("sizeW_fromITBL: %" FMT_Word "\n", sizeW_fromITBL(INFO_PTR_TO_STRUCT(StackOverflow_con_info)));
+
+    StgClosure * const e = (StgClosure*)allocate(cap, e_size);
+    *(StgWord*)e->payload = stack_words;
+    SET_HDR_RELEASE(e, StackOverflow_con_info, CCS_SYSTEM);
+    // TODO We should bump a ticky counter for this allocation
+    #if defined(DEBUG)
+    printClosure(e);
+    #endif
+    return TAG_CLOSURE(INFO_PTR_TO_STRUCT(StackOverflow_con_info)->srt,e);
+}
+
 /* -----------------------------------------------------------------------------
    Stack overflow
 
@@ -536,7 +554,6 @@ isThreadBound(StgTSO* tso USED_IF_THREADS)
    relocate the TSO into a larger chunk of memory and adjust its stack
    size appropriately.
    -------------------------------------------------------------------------- */
-
 void
 threadStackOverflow (Capability *cap, StgTSO *tso)
 {
@@ -564,7 +581,7 @@ threadStackOverflow (Capability *cap, StgTSO *tso)
         debugTrace(DEBUG_gc,
                    "threadStackOverflow of TSO %" FMT_StgThreadID " (%p): stack"
                    " too large (now %ld; max is %ld)", tso->id, tso,
-                   (long)tso->stackobj->stack_size, RtsFlags.GcFlags.maxStkSize);
+                   (long)tso->tot_stack_size, RtsFlags.GcFlags.maxStkSize);
         IF_DEBUG(gc,
                  /* If we're debugging, just print out the top of the stack */
                  printStackChunk(tso->stackobj->sp,
@@ -572,7 +589,7 @@ threadStackOverflow (Capability *cap, StgTSO *tso)
                                          tso->stackobj->sp+64)));
 
         // See Note [Throw to self when masked], also #767 and #8303.
-        throwToSelf(cap, tso, (StgClosure *)stackOverflow_closure);
+        throwToSelf(cap, tso, mkStackOverflowException(cap, tso->tot_stack_size));
         return;
     }
 
diff --git a/rts/include/Rts.h b/rts/include/Rts.h
index 90d8e5b324..fdca14f43c 100644
--- a/rts/include/Rts.h
+++ b/rts/include/Rts.h
@@ -287,7 +287,7 @@ DLL_IMPORT_RTS extern char **prog_argv; /* so we can get at these from Haskell *
 DLL_IMPORT_RTS extern int    prog_argc;
 DLL_IMPORT_RTS extern char  *prog_name;
 
-void reportStackOverflow(StgTSO* tso);
+void reportStackOverflow(StgWord);
 void reportHeapOverflow(void);
 
 void stg_exit(int n) STG_NORETURN;
diff --git a/rts/rts.cabal.in b/rts/rts.cabal.in
index 34da06a365..73147ad76e 100644
--- a/rts/rts.cabal.in
+++ b/rts/rts.cabal.in
@@ -263,7 +263,6 @@ library
          "-Wl,-u,_ghczmprim_GHCziTypes_False_closure"
          "-Wl,-u,_base_GHCziPack_unpackCString_closure"
          "-Wl,-u,_base_GHCziWeakziFinalizze_runFinalizzerBatch_closure"
-         "-Wl,-u,_base_GHCziIOziException_stackOverflow_closure"
          "-Wl,-u,_base_GHCziIOziException_heapOverflow_closure"
          "-Wl,-u,_base_GHCziIOziException_allocationLimitExceeded_closure"
          "-Wl,-u,_base_GHCziIOziException_blockedIndefinitelyOnMVar_closure"
@@ -298,6 +297,7 @@ library
          "-Wl,-u,_base_GHCziWord_W32zh_con_info"
          "-Wl,-u,_base_GHCziWord_W64zh_con_info"
          "-Wl,-u,_base_GHCziStable_StablePtr_con_info"
+         "-Wl,-u,_base_GHCziIOziException_StackOverflowzq_con_info"
          "-Wl,-u,_hs_atomic_add8"
          "-Wl,-u,_hs_atomic_add16"
          "-Wl,-u,_hs_atomic_add32"
@@ -346,7 +346,6 @@ library
          "-Wl,-u,ghczmprim_GHCziTypes_False_closure"
          "-Wl,-u,base_GHCziPack_unpackCString_closure"
          "-Wl,-u,base_GHCziWeakziFinalizze_runFinalizzerBatch_closure"
-         "-Wl,-u,base_GHCziIOziException_stackOverflow_closure"
          "-Wl,-u,base_GHCziIOziException_heapOverflow_closure"
          "-Wl,-u,base_GHCziIOziException_allocationLimitExceeded_closure"
          "-Wl,-u,base_GHCziIOziException_blockedIndefinitelyOnMVar_closure"
@@ -381,6 +380,7 @@ library
          "-Wl,-u,base_GHCziWord_W32zh_con_info"
          "-Wl,-u,base_GHCziWord_W64zh_con_info"
          "-Wl,-u,base_GHCziStable_StablePtr_con_info"
+         "-Wl,-u,base_GHCziIOziException_StackOverflowzq_con_info"
          "-Wl,-u,hs_atomic_add8"
          "-Wl,-u,hs_atomic_add16"
          "-Wl,-u,hs_atomic_add32"