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

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