diff options
| -rw-r--r-- | docs/users_guide/8.2.1-notes.rst | 7 | ||||
| -rw-r--r-- | docs/users_guide/runtime_control.rst | 14 | ||||
| -rw-r--r-- | includes/rts/Flags.h | 10 | ||||
| -rw-r--r-- | libraries/base/GHC/IO/Exception.hs | 9 | ||||
| -rw-r--r-- | libraries/base/GHC/TopHandler.hs | 31 | ||||
| -rw-r--r-- | rts/RtsFlags.c | 23 | ||||
| -rw-r--r-- | rts/RtsStartup.c | 7 | ||||
| -rw-r--r-- | rts/RtsSymbols.c | 2 | ||||
| -rw-r--r-- | rts/Schedule.c | 68 | ||||
| -rw-r--r-- | rts/TopHandler.c | 62 | ||||
| -rw-r--r-- | rts/TopHandler.h | 27 | ||||
| -rw-r--r-- | testsuite/tests/rts/T1791/Makefile | 6 | ||||
| -rw-r--r-- | testsuite/tests/rts/T1791/T1791.hs | 20 | ||||
| -rw-r--r-- | testsuite/tests/rts/T1791/T1791.stderr | 3 | ||||
| -rw-r--r-- | testsuite/tests/rts/T1791/T1791.stdout | 1 | ||||
| -rw-r--r-- | testsuite/tests/rts/T1791/all.T | 4 | ||||
| -rw-r--r-- | testsuite/tests/rts/T5644/T5644.stdout | 2 |
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" |