summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--docs/users_guide/8.2.1-notes.rst7
-rw-r--r--docs/users_guide/runtime_control.rst14
-rw-r--r--includes/rts/Flags.h10
-rw-r--r--libraries/base/GHC/IO/Exception.hs9
-rw-r--r--libraries/base/GHC/TopHandler.hs31
-rw-r--r--rts/RtsFlags.c23
-rw-r--r--rts/RtsStartup.c7
-rw-r--r--rts/RtsSymbols.c2
-rw-r--r--rts/Schedule.c68
-rw-r--r--rts/TopHandler.c62
-rw-r--r--rts/TopHandler.h27
-rw-r--r--testsuite/tests/rts/T1791/Makefile6
-rw-r--r--testsuite/tests/rts/T1791/T1791.hs20
-rw-r--r--testsuite/tests/rts/T1791/T1791.stderr3
-rw-r--r--testsuite/tests/rts/T1791/T1791.stdout1
-rw-r--r--testsuite/tests/rts/T1791/all.T4
-rw-r--r--testsuite/tests/rts/T5644/T5644.stdout2
17 files changed, 269 insertions, 27 deletions
diff --git a/docs/users_guide/8.2.1-notes.rst b/docs/users_guide/8.2.1-notes.rst
index 3011a29700..2c237db4e6 100644
--- a/docs/users_guide/8.2.1-notes.rst
+++ b/docs/users_guide/8.2.1-notes.rst
@@ -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
~~~~~~~~
diff --git a/docs/users_guide/runtime_control.rst b/docs/users_guide/runtime_control.rst
index 54c7508ba8..4bde81a9d8 100644
--- a/docs/users_guide/runtime_control.rst
+++ b/docs/users_guide/runtime_control.rst
@@ -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>
diff --git a/includes/rts/Flags.h b/includes/rts/Flags.h
index 62d0800e68..0412415aca 100644
--- a/includes/rts/Flags.h
+++ b/includes/rts/Flags.h
@@ -15,6 +15,10 @@
#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;
diff --git a/libraries/base/GHC/IO/Exception.hs b/libraries/base/GHC/IO/Exception.hs
index 3c088520cc..17eda3d61f 100644
--- a/libraries/base/GHC/IO/Exception.hs
+++ b/libraries/base/GHC/IO/Exception.hs
@@ -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
diff --git a/libraries/base/GHC/TopHandler.hs b/libraries/base/GHC/TopHandler.hs
index 05c905f7c1..f1c87e5110 100644
--- a/libraries/base/GHC/TopHandler.hs
+++ b/libraries/base/GHC/TopHandler.hs
@@ -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
diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c
index 1368082730..c9da13bafc 100644
--- a/rts/RtsFlags.c
+++ b/rts/RtsFlags.c
@@ -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':
diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c
index 955ad13b4b..98c1dd290c 100644
--- a/rts/RtsStartup.c
+++ b/rts/RtsStartup.c
@@ -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();
diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c
index 28479fb508..4c21c2ac52 100644
--- a/rts/RtsSymbols.c
+++ b/rts/RtsSymbols.c
@@ -10,6 +10,7 @@
#include "RtsSymbols.h"
#include "Rts.h"
+#include "TopHandler.h"
#include "HsFFI.h"
#include "sm/Storage.h"
@@ -747,6 +748,7 @@
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) \
diff --git a/rts/Schedule.c b/rts/Schedule.c
index 49687b577a..02d8137a2c 100644
--- a/rts/Schedule.c
+++ b/rts/Schedule.c
@@ -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
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
+}
diff --git a/rts/TopHandler.h b/rts/TopHandler.h
new file mode 100644
index 0000000000..fddebb05ef
--- /dev/null
+++ b/rts/TopHandler.h
@@ -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
index 0000000000..61900477f9
--- /dev/null
+++ b/testsuite/tests/rts/T1791/Makefile
@@ -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
index 0000000000..196b2151d7
--- /dev/null
+++ b/testsuite/tests/rts/T1791/T1791.hs
@@ -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
index 0000000000..fa8ef2df3a
--- /dev/null
+++ b/testsuite/tests/rts/T1791/T1791.stderr
@@ -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
index 0000000000..1b04d8a31c
--- /dev/null
+++ b/testsuite/tests/rts/T1791/T1791.stdout
@@ -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
index 0000000000..25fb4d1124
--- /dev/null
+++ b/testsuite/tests/rts/T1791/all.T
@@ -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
index 0000000000..cc288ea038
--- /dev/null
+++ b/testsuite/tests/rts/T5644/T5644.stdout
@@ -0,0 +1,2 @@
+
+"Test.ManyQueue.testManyQueue'1P3C"
View Lorry Controller Status