Report heap overflow in the same way as stack overflow

Now that we throw an exception for heap overflow, we should only print
the heap overflow message in the main thread when the HeapOverflow
exception is caught, rather than as a side effect in the GC.

Stack overflows were already done this way, I just made heap overflow
consistent with stack overflow, and did some related cleanup.

Fixes broken T2592(profasm) which was reporting the heap overflow
message twice (you would only notice when building with profiling
libs enabled).

Test Plan: validate

Reviewers: bgamari, niteria, austin, DemiMarie, hvr, erikd

Reviewed By: bgamari

Subscribers: rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3394

11 files changed, 35 insertions, 31 deletions

diff --git a/includes/Rts.h b/includes/Rts.h
index fc010d4d97..be49b326f2 100644
--- a/includes/Rts.h
+++ b/includes/Rts.h
@@ -218,7 +218,8 @@ void getWin32ProgArgv(int *argc, wchar_t **argv[]);
 void setWin32ProgArgv(int argc, wchar_t *argv[]);
 #endif
 
-void stackOverflow(StgTSO* tso);
+void reportStackOverflow(StgTSO* tso);
+void reportHeapOverflow(void);
 
 void stg_exit(int n) GNU_ATTRIBUTE(__noreturn__);
 
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
diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c
index 0180554437..7db5a27cf1 100644
--- a/rts/RtsSymbols.c
+++ b/rts/RtsSymbols.c
@@ -755,7 +755,8 @@
       SymI_HasProto(shutdownHaskellAndExit)                             \
       SymI_HasProto(stable_name_table)                                  \
       SymI_HasProto(stable_ptr_table)                                   \
-      SymI_HasProto(stackOverflow)                                      \
+      SymI_HasProto(reportStackOverflow)                                \
+      SymI_HasProto(reportHeapOverflow)                                 \
       SymI_HasProto(stg_CAF_BLACKHOLE_info)                             \
       SymI_HasProto(stg_BLACKHOLE_info)                                 \
       SymI_HasProto(__stg_EAGER_BLACKHOLE_info)                         \
diff --git a/rts/RtsUtils.c b/rts/RtsUtils.c
index 31dc060244..85f951addd 100644
--- a/rts/RtsUtils.c
+++ b/rts/RtsUtils.c
@@ -131,13 +131,11 @@ stgFree(void* p)
 }
 
 /* -----------------------------------------------------------------------------
-   Stack overflow
-
-   Not sure if this belongs here.
+   Stack/heap overflow
    -------------------------------------------------------------------------- */
 
 void
-stackOverflow(StgTSO* tso)
+reportStackOverflow(StgTSO* tso)
 {
     rtsConfig.stackOverflowHook(tso->tot_stack_size * sizeof(W_));
 
@@ -147,16 +145,11 @@ stackOverflow(StgTSO* tso)
 }
 
 void
-heapOverflow(void)
+reportHeapOverflow(void)
 {
-    if (!heap_overflow)
-    {
-        /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
-        rtsConfig.outOfHeapHook(0/*unknown request size*/,
-                                (W_)RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE);
-
-        heap_overflow = true;
-    }
+    /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
+    rtsConfig.outOfHeapHook(0/*unknown request size*/,
+                            (W_)RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE);
 }
 
 /* -----------------------------------------------------------------------------
@@ -351,4 +344,3 @@ void checkFPUStack(void)
     }
 #endif
 }
-
diff --git a/rts/RtsUtils.h b/rts/RtsUtils.h
index 8f4e8066f2..6514e351d1 100644
--- a/rts/RtsUtils.h
+++ b/rts/RtsUtils.h
@@ -34,8 +34,6 @@ void stgFree(void* p);
  * Misc other utilities
  * -------------------------------------------------------------------------- */
 
-void heapOverflow(void);
-
 char *time_str(void);
 char *showStgWord64(StgWord64, char *, bool);
 
diff --git a/rts/sm/CNF.c b/rts/sm/CNF.c
index 7dfaced7ef..624dba30b2 100644
--- a/rts/sm/CNF.c
+++ b/rts/sm/CNF.c
@@ -176,8 +176,8 @@ compactAllocateBlockInternal(Capability            *cap,
         n_blocks >= HS_INT32_MAX)   // avoid overflow when
                                     // calling allocGroup() below
     {
-        heapOverflow();
-        // heapOverflow() doesn't exit (see #2592), but we aren't
+        reportHeapOverflow();
+        // reportHeapOverflow() doesn't exit (see #2592), but we aren't
         // in a position to do a clean shutdown here: we
         // either have to allocate the memory or exit now.
         // Allocating the memory would be bad, because the user
diff --git a/rts/sm/GC.c b/rts/sm/GC.c
index 358700e499..0dafb8c3ea 100644
--- a/rts/sm/GC.c
+++ b/rts/sm/GC.c
@@ -157,6 +157,7 @@ static void wakeup_gc_threads       (uint32_t me, bool idle_cap[]);
 static void shutdown_gc_threads     (uint32_t me, bool idle_cap[]);
 static void collect_gct_blocks      (void);
 static void collect_pinned_object_blocks (void);
+static void heapOverflow            (void);
 
 #if defined(DEBUG)
 static void gcCAFs                  (void);
@@ -796,6 +797,16 @@ GarbageCollect (uint32_t collect_gen,
 }
 
 /* -----------------------------------------------------------------------------
+   Heap overflow is indicated by setting a flag that the caller of
+   GarbageCollect can check.  (not ideal, TODO: better)
+   -------------------------------------------------------------------------- */
+
+static void heapOverflow(void)
+{
+    heap_overflow = true;
+}
+
+/* -----------------------------------------------------------------------------
    Initialise the gc_thread structures.
    -------------------------------------------------------------------------- */
 
diff --git a/rts/sm/Storage.c b/rts/sm/Storage.c
index a527e4f962..43f67f4899 100644
--- a/rts/sm/Storage.c
+++ b/rts/sm/Storage.c
@@ -845,7 +845,7 @@ allocate (Capability *cap, W_ n)
             req_blocks >= HS_INT32_MAX)   // avoid overflow when
                                           // calling allocGroup() below
         {
-            heapOverflow();
+            reportHeapOverflow();
             // heapOverflow() doesn't exit (see #2592), but we aren't
             // in a position to do a clean shutdown here: we
             // either have to allocate the memory or exit now.
diff --git a/testsuite/tests/rts/T1791/T1791.stderr b/testsuite/tests/rts/T1791/T1791.stderr
deleted file mode 100644
index fa8ef2df3a..0000000000
--- a/testsuite/tests/rts/T1791/T1791.stderr
+++ /dev/null
@@ -1,3 +0,0 @@
-T1791: Heap exhausted;
-T1791: Current maximum heap size is 8388608 bytes (8 MB).
-T1791: Use `+RTS -M<size>' to increase it.