Throw an exception on heap overflow
authorDemi Obenour <demiobenour@gmail.com>
Tue, 10 Jan 2017 18:33:31 +0000 (13:33 -0500)
committerBen Gamari <ben@smart-cactus.org>
Tue, 10 Jan 2017 18:33:38 +0000 (13:33 -0500)
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

17 files changed:
docs/users_guide/8.2.1-notes.rst
docs/users_guide/runtime_control.rst
includes/rts/Flags.h
libraries/base/GHC/IO/Exception.hs
libraries/base/GHC/TopHandler.hs
rts/RtsFlags.c
rts/RtsStartup.c
rts/RtsSymbols.c
rts/Schedule.c
rts/TopHandler.c [new file with mode: 0644]
rts/TopHandler.h [new file with mode: 0644]
testsuite/tests/rts/T1791/Makefile [new file with mode: 0644]
testsuite/tests/rts/T1791/T1791.hs [new file with mode: 0644]
testsuite/tests/rts/T1791/T1791.stderr [new file with mode: 0644]
testsuite/tests/rts/T1791/T1791.stdout [new file with mode: 0644]
testsuite/tests/rts/T1791/all.T [new file with mode: 0644]
testsuite/tests/rts/T5644/T5644.stdout [new file with mode: 0644]

index 3011a29..2c237db 100644 (file)
@@ -14,10 +14,17 @@ The highlights since the 8.0 branch are:
 
 - TODO FIXME
 - SCC annotations can now be used for declarations.
+- Heap overflow throws an exception in certain circumstances.
 
 Full details
 ------------
 
+- Heap overflow throws a catchable exception, provided that it was detected
+  by the RTS during a GC cycle due to the program exceeding a limit set by
+  ``+RTS -M``, and not due to an allocation being refused by the operating
+  system.  This exception is thrown to the same thread that receives
+  ``UserInterrupt`` exceptions, and may be caught by user programs.
+
 Language
 ~~~~~~~~
 
index 54c7508..4bde81a 100644 (file)
@@ -644,6 +644,20 @@ performance.
     ``-F`` parameter will be reduced in order to avoid exceeding the
     maximum heap size.
 
+.. rts-flag:: -Mgrace= ⟨size⟩
+
+    :default: 1M
+
+    .. index::
+       single: heap size, grace
+
+    If the program's heap exceeds the value set by :rts-flag:`-M`, the
+    RTS throws an exception to the program, and the program gets an
+    additional quota of allocation before the exception is raised
+    again, the idea being so that the program can execute its
+    exception handlers. ``-Mgrace=`` controls the size of this
+    additional quota.
+
 .. rts-flag:: --numa
               --numa=<mask>
 
index 62d0800..0412415 100644 (file)
 #define RTS_FLAGS_H
 
 #include <stdio.h>
+#include <stdint.h>
+#include <stdbool.h>
+#include "stg/Types.h"
+#include "Time.h"
 
 /* For defaults, see the @initRtsFlagsDefaults@ routine. */
 
@@ -71,6 +75,12 @@ typedef struct _GC_FLAGS {
                                  * to handle the exception before we
                                  * raise it again.
                                  */
+    StgWord heapLimitGrace;     /* units: *blocks*
+                                 * After a HeapOverflow exception has
+                                 * been raised, how much extra space is
+                                 * given to the thread to handle the
+                                 * exception before we raise it again.
+                                 */
 
     bool numa;                   /* Use NUMA */
     StgWord numaMask;
index 3c08852..17eda3d 100644 (file)
@@ -207,8 +207,15 @@ data AsyncException
         -- live data it has. Notes:
         --
         --   * It is undefined which thread receives this exception.
+        --     GHC currently throws this to the same thread that
+        --     receives 'UserInterrupt', but this may change in the
+        --     future.
         --
-        --   * GHC currently does not throw 'HeapOverflow' exceptions.
+        --   * The GHC RTS currently can only recover from heap overflow
+        --     if it detects that an explicit memory limit (set via RTS flags).
+        --     has been exceeded.  Currently, failure to allocate memory from
+        --     the operating system results in immediate termination of the
+        --     program.
   | ThreadKilled
         -- ^This exception is raised by another thread
         -- calling 'Control.Concurrent.killThread', or by the system
index 05c905f..f1c87e5 100644 (file)
@@ -3,6 +3,7 @@
            , NoImplicitPrelude
            , MagicHash
            , UnboxedTuples
+           , UnliftedFFITypes
   #-}
 {-# OPTIONS_HADDOCK hide #-}
 
@@ -50,6 +51,30 @@ import GHC.ConsoleHandler
 import Data.Dynamic (toDyn)
 #endif
 
+-- Note [rts_setMainThread must be called unsafely]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- rts_setMainThread must be called as unsafe, because it
+-- dereferences the Weak# and manipulates the raw Haskell value
+-- behind it.  Therefore, it must not race with a garbage collection.
+
+-- Note [rts_setMainThread has an unsound type]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- 'rts_setMainThread' is imported with type Weak# ThreadId -> IO (),
+-- but this is an unsound type for it: it grabs the /key/ of the
+-- 'Weak#' object, which isn't tracked by the type at all.
+-- That this works at all is a consequence of the fact that
+-- 'mkWeakThreadId' produces a 'Weak#' with a 'ThreadId#' as the key
+-- This is fairly robust, in that 'mkWeakThreadId' wouldn't work
+-- otherwise, but it still is sufficiently non-trivial to justify an
+-- ASSERT in rts/TopHandler.c.
+
+-- see Note [rts_setMainThread must be called unsafely] and
+-- Note [rts_setMainThread has an unsound type]
+foreign import ccall unsafe "rts_setMainThread"
+  setMainThread :: Weak# ThreadId -> IO ()
+
 -- | 'runMainIO' is wrapped around 'Main.main' (or whatever main is
 -- called in the program).  It catches otherwise uncaught exceptions,
 -- and also flushes stdout\/stderr before exiting.
@@ -58,6 +83,7 @@ runMainIO main =
     do
       main_thread_id <- myThreadId
       weak_tid <- mkWeakThreadId main_thread_id
+      case weak_tid of (Weak w) -> setMainThread w
       install_interrupt_handler $ do
            m <- deRefWeak weak_tid
            case m of
@@ -149,7 +175,10 @@ real_handler exit se = do
            reportStackOverflow
            exit 2
 
-      Just UserInterrupt  -> exitInterrupted
+      Just UserInterrupt -> exitInterrupted
+
+      Just HeapOverflow -> exit 251
+           -- the RTS has already emitted a message to stderr
 
       _ -> case fromException se of
            -- only the main thread gets ExitException exceptions
index 1368082..c9da13b 100644 (file)
@@ -129,7 +129,7 @@ void initRtsFlagsDefaults(void)
         maxStkSize = 8 * 1024 * 1024;
 
     RtsFlags.GcFlags.statsFile          = NULL;
-    RtsFlags.GcFlags.giveStats          = NO_GC_STATS;
+    RtsFlags.GcFlags.giveStats          = COLLECT_GC_STATS;
 
     RtsFlags.GcFlags.maxStkSize         = maxStkSize / sizeof(W_);
     RtsFlags.GcFlags.initialStkSize     = 1024 / sizeof(W_);
@@ -141,6 +141,7 @@ void initRtsFlagsDefaults(void)
     RtsFlags.GcFlags.nurseryChunkSize   = 0;
     RtsFlags.GcFlags.minOldGenSize      = (1024 * 1024)       / BLOCK_SIZE;
     RtsFlags.GcFlags.maxHeapSize        = 0;    /* off by default */
+    RtsFlags.GcFlags.heapLimitGrace     = (1024 * 1024);
     RtsFlags.GcFlags.heapSizeSuggestion = 0;    /* none */
     RtsFlags.GcFlags.heapSizeSuggestionAuto = false;
     RtsFlags.GcFlags.pcFreeHeap         = 3;    /* 3% */
@@ -428,6 +429,11 @@ usage_text[] = {
 "  -xq       The allocation limit given to a thread after it receives",
 "            an AllocationLimitExceeded exception. (default: 100k)",
 "",
+"  -Mgrace=<n>",
+"            The amount of allocation after the program receives a",
+"            HeapOverflow exception before the exception is thrown again, if",
+"            the program is still exceeding the heap limit.",
+"",
 "RTS options may also be specified using the GHCRTS environment variable.",
 "",
 "Other RTS options may be available for programs compiled a different way.",
@@ -905,11 +911,16 @@ error = true;
 
               case 'M':
                   OPTION_UNSAFE;
-                  RtsFlags.GcFlags.maxHeapSize =
-                      decodeSize(rts_argv[arg], 2, BLOCK_SIZE, HS_WORD_MAX)
-                      / BLOCK_SIZE;
-                  /* user give size in *bytes* but "maxHeapSize" is in
-                   * *blocks* */
+                  if (0 == strncmp("grace=", rts_argv[arg] + 2, 6)) {
+                      RtsFlags.GcFlags.heapLimitGrace =
+                          decodeSize(rts_argv[arg], 8, BLOCK_SIZE, HS_WORD_MAX);
+                  } else {
+                      RtsFlags.GcFlags.maxHeapSize =
+                          decodeSize(rts_argv[arg], 2, BLOCK_SIZE, HS_WORD_MAX)
+                          / BLOCK_SIZE;
+                      // user give size in *bytes* but "maxHeapSize" is in
+                      // *blocks*
+                  }
                   break;
 
               case 'm':
index 955ad13..98c1dd2 100644 (file)
@@ -36,6 +36,7 @@
 #include "LinkerInternals.h"
 #include "LibdwPool.h"
 #include "sm/CNF.h"
+#include "TopHandler.h"
 
 #if defined(PROFILING)
 # include "ProfHeap.h"
@@ -242,6 +243,9 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config)
     getStablePtr((StgPtr)runHandlersPtr_closure);
 #endif
 
+    // Initialize the top-level handler system
+    initTopHandler();
+
     /* initialise the shared Typeable store */
     initGlobalStore();
 
@@ -414,6 +418,9 @@ hs_exit_(bool wait_foreign)
     /* free the Static Pointer Table */
     exitStaticPtrTable();
 
+    /* remove the top-level handler */
+    exitTopHandler();
+
     /* free the stable pointer table */
     exitStableTables();
 
index 28479fb..4c21c2a 100644 (file)
@@ -10,6 +10,7 @@
 #include "RtsSymbols.h"
 
 #include "Rts.h"
+#include "TopHandler.h"
 #include "HsFFI.h"
 
 #include "sm/Storage.h"
       SymI_HasProto(rts_setThreadAllocationCounter)                     \
       SymI_HasProto(rts_enableThreadAllocationLimit)                    \
       SymI_HasProto(rts_disableThreadAllocationLimit)                   \
+      SymI_HasProto(rts_setMainThread)                                  \
       SymI_HasProto(setProgArgv)                                        \
       SymI_HasProto(startupHaskell)                                     \
       SymI_HasProto(shutdownHaskell)                                    \
index 49687b5..02d8137 100644 (file)
@@ -42,6 +42,7 @@
 #include "ThreadPaused.h"
 #include "Messages.h"
 #include "Stable.h"
+#include "TopHandler.h"
 
 #ifdef HAVE_SYS_TYPES_H
 #include <sys/types.h>
@@ -72,9 +73,14 @@ StgTSO *blocked_queue_tl = NULL;
 StgTSO *sleeping_queue = NULL;    // perhaps replace with a hash table?
 #endif
 
-/* Set to true when the latest garbage collection failed to reclaim
- * enough space, and the runtime should proceed to shut itself down in
- * an orderly fashion (emitting profiling info etc.)
+// Bytes allocated since the last time a HeapOverflow exception was thrown by
+// the RTS
+uint64_t allocated_bytes_at_heapoverflow = 0;
+
+/* Set to true when the latest garbage collection failed to reclaim enough
+ * space, and the runtime should proceed to shut itself down in an orderly
+ * fashion (emitting profiling info etc.), OR throw an exception to the main
+ * thread, if it is still alive.
  */
 bool heap_overflow = false;
 
@@ -1888,24 +1894,46 @@ delete_threads_and_gc:
         releaseGCThreads(cap, idle_cap);
     }
 #endif
-
     if (heap_overflow && sched_state < SCHED_INTERRUPTING) {
-        // GC set the heap_overflow flag, so we should proceed with
-        // an orderly shutdown now.  Ultimately we want the main
-        // thread to return to its caller with HeapExhausted, at which
-        // point the caller should call hs_exit().  The first step is
-        // to delete all the threads.
-        //
-        // Another way to do this would be to raise an exception in
-        // the main thread, which we really should do because it gives
-        // the program a chance to clean up.  But how do we find the
-        // main thread?  It should presumably be the same one that
-        // gets ^C exceptions, but that's all done on the Haskell side
-        // (GHC.TopHandler).
-        sched_state = SCHED_INTERRUPTING;
-        goto delete_threads_and_gc;
-    }
+        // GC set the heap_overflow flag.  We should throw an exception if we
+        // can, or shut down otherwise.
+
+        // Get the thread to which Ctrl-C is thrown
+        StgTSO *main_thread = getTopHandlerThread();
+        if (main_thread == NULL) {
+            // GC set the heap_overflow flag, and there is no main thread to
+            // throw an exception to, so we should proceed with an orderly
+            // shutdown now.  Ultimately we want the main thread to return to
+            // its caller with HeapExhausted, at which point the caller should
+            // call hs_exit().  The first step is to delete all the threads.
+            sched_state = SCHED_INTERRUPTING;
+            goto delete_threads_and_gc;
+        }
 
+        heap_overflow = false;
+        const uint64_t allocation_count = getAllocations();
+        if (RtsFlags.GcFlags.heapLimitGrace <
+              allocation_count - allocated_bytes_at_heapoverflow ||
+              allocated_bytes_at_heapoverflow == 0) {
+            allocated_bytes_at_heapoverflow = allocation_count;
+            // We used to simply exit, but throwing an exception gives the
+            // program a chance to clean up.  It also lets the exception be
+            // caught.
+
+            // FIXME this is not a good way to tell a program to release
+            // resources.  It is neither reliable (the RTS crashes if it fails
+            // to allocate memory from the OS) nor very usable (it is always
+            // thrown to the main thread, which might not be able to do anything
+            // useful with it).  We really should have a more general way to
+            // release resources in low-memory conditions.  Nevertheless, this
+            // is still a big improvement over just exiting.
+
+            // FIXME again: perhaps we should throw a synchronous exception
+            // instead an asynchronous one, or have a way for the program to
+            // register a handler to be called when heap overflow happens.
+            throwToSelf(cap, main_thread, heapOverflow_closure);
+        }
+    }
 #ifdef SPARKBALANCE
     /* JB
        Once we are all together... this would be the place to balance all
@@ -2608,6 +2636,8 @@ initScheduler(void)
 
   ACQUIRE_LOCK(&sched_mutex);
 
+  allocated_bytes_at_heapoverflow = 0;
+
   /* A capability holds the state a native thread needs in
    * order to execute STG code. At least one capability is
    * floating around (only THREADED_RTS builds have more than one).
diff --git a/rts/TopHandler.c b/rts/TopHandler.c
new file mode 100644 (file)
index 0000000..ff53b32
--- /dev/null
@@ -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
+}
diff --git a/rts/TopHandler.h b/rts/TopHandler.h
new file mode 100644 (file)
index 0000000..fddebb0
--- /dev/null
@@ -0,0 +1,27 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2016
+ *
+ * Top-level handler support
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include <BeginPrivate.h>
+#include <rts/Types.h>
+#include <rts/storage/Closures.h>
+#include <stg/Types.h>
+#include <rts/Stable.h>
+// Initialize the top handler subsystem
+void initTopHandler(void);
+
+// Exit the top handler subsystem
+void exitTopHandler(void);
+
+// Get the thread that handles ctrl-c, etc
+// Returns NULL if there is no such thread
+StgTSO *getTopHandlerThread(void);
+
+#include <EndPrivate.h>
+
+// Called from Haskell
+void rts_setMainThread(StgWeak *ptr);
diff --git a/testsuite/tests/rts/T1791/Makefile b/testsuite/tests/rts/T1791/Makefile
new file mode 100644 (file)
index 0000000..6190047
--- /dev/null
@@ -0,0 +1,6 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+T1791:
+       '$(TEST_HC)' T1791.hs -o T1791 -O -rtsopts
diff --git a/testsuite/tests/rts/T1791/T1791.hs b/testsuite/tests/rts/T1791/T1791.hs
new file mode 100644 (file)
index 0000000..196b215
--- /dev/null
@@ -0,0 +1,20 @@
+import Control.Exception
+force :: [a] -> [a]
+force [] = []
+force x@(a:b) = x `seq` a : force b
+
+{-# NOINLINE infiniteList #-}
+infiniteList :: [Int]
+infiniteList = [1..]
+
+
+heapOverflow :: IO ()
+heapOverflow = do
+  evaluate $ length infiniteList -- Force the list
+  evaluate infiniteList -- So that the list cannot be garbage collected.
+  return ()
+
+main :: IO ()
+main = heapOverflow `catch` \x -> case x of
+  HeapOverflow -> putStrLn "Heap overflow caught!"
+  _ -> throwIO x
diff --git a/testsuite/tests/rts/T1791/T1791.stderr b/testsuite/tests/rts/T1791/T1791.stderr
new file mode 100644 (file)
index 0000000..fa8ef2d
--- /dev/null
@@ -0,0 +1,3 @@
+T1791: Heap exhausted;
+T1791: Current maximum heap size is 8388608 bytes (8 MB).
+T1791: Use `+RTS -M<size>' to increase it.
diff --git a/testsuite/tests/rts/T1791/T1791.stdout b/testsuite/tests/rts/T1791/T1791.stdout
new file mode 100644 (file)
index 0000000..1b04d8a
--- /dev/null
@@ -0,0 +1 @@
+Heap overflow caught!
diff --git a/testsuite/tests/rts/T1791/all.T b/testsuite/tests/rts/T1791/all.T
new file mode 100644 (file)
index 0000000..25fb4d1
--- /dev/null
@@ -0,0 +1,4 @@
+test('T1791',
+     [ exit_code(0), extra_clean(['T1791.hi', 'T1791']) ],
+     run_command,
+     ['''"$MAKE" -s --no-print-directory T1791 >/dev/null && ./T1791 +RTS -M8M'''])
diff --git a/testsuite/tests/rts/T5644/T5644.stdout b/testsuite/tests/rts/T5644/T5644.stdout
new file mode 100644 (file)
index 0000000..cc288ea
--- /dev/null
@@ -0,0 +1,2 @@
+
+"Test.ManyQueue.testManyQueue'1P3C"