Throw an exception on heap overflow

This changes heap overflow to throw a HeapOverflow exception instead of
killing the process.

Test Plan: GHC CI

Reviewers: simonmar, austin, hvr, erikd, bgamari

Reviewed By: simonmar, bgamari

Subscribers: thomie

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

GHC Trac Issues: #1791

1 files changed, 62 insertions, 0 deletions

diff --git a/rts/TopHandler.c b/rts/TopHandler.c
new file mode 100644
index 0000000000..ff53b32338
--- /dev/null
+++ b/rts/TopHandler.c
@@ -0,0 +1,62 @@
+#include "Rts.h"
+#include "Stable.h"
+#include "TopHandler.h"
+
+#ifdef THREADED_RTS
+static Mutex m; // Protects the operations on topHandlerPtr,
+                // which aren't atomic
+#endif
+static StgStablePtr topHandlerPtr;
+
+void rts_setMainThread(StgWeak *weak) {
+    ACQUIRE_LOCK(&m);
+    if (topHandlerPtr != NULL) {
+        freeStablePtr(topHandlerPtr); // OK to do under the lock
+    }
+    topHandlerPtr = getStablePtr((StgPtr)weak);
+    // referent is a Weak#
+    ASSERT(weak->header.info == &stg_WEAK_info);
+
+    // See Note [rts_setMainThread has an unsound type] in
+    // libraries/base/GHC/TopHandler.hs.
+    ASSERT(weak->key->header.info == &stg_TSO_info);
+
+    RELEASE_LOCK(&m);
+}
+
+StgTSO *getTopHandlerThread(void) {
+    ACQUIRE_LOCK(&m);
+    StgWeak *weak = (StgWeak*)deRefStablePtr(topHandlerPtr);
+    RELEASE_LOCK(&m);
+    const StgInfoTable *info = weak->header.info;
+    if (info == &stg_WEAK_info) {
+        StgClosure *key = ((StgWeak*)weak)->key;
+
+        // See Note [rts_setMainThread has an unsound type] in
+        // libraries/base/GHC/TopHandler.hs.
+        ASSERT(key->header.info == &stg_TSO_info);
+
+        return (StgTSO *)key;
+    } else if (info == &stg_DEAD_WEAK_info) {
+        return NULL;
+    } else {
+        barf("getTopHandlerThread: neither a WEAK nor a DEAD_WEAK: %p %p %d",
+             weak, info, info->type);
+        return NULL;
+    }
+}
+
+void initTopHandler(void) {
+#ifdef THREADED_RTS
+    initMutex(&m);
+#endif
+    topHandlerPtr = NULL;
+}
+
+void exitTopHandler(void) {
+    freeStablePtr(topHandlerPtr);
+    topHandlerPtr = NULL;
+#ifdef THREADED_RTS
+    closeMutex(&m);
+#endif
+}