Commit b0534f78 authored by Simon Marlow's avatar Simon Marlow

Per-thread allocation counters and limits

This tracks the amount of memory allocation by each thread in a
counter stored in the TSO.  Optionally, when the counter drops below
zero (it counts down), the thread can be sent an asynchronous
exception: AllocationLimitExceeded.  When this happens, given a small
additional limit so that it can handle the exception.  See
documentation in GHC.Conc for more details.

Allocation limits are similar to timeouts, but

  - timeouts use real time, not CPU time.  Allocation limits do not
    count anything while the thread is blocked or in foreign code.

  - timeouts don't re-trigger if the thread catches the exception,
    allocation limits do.

  - timeouts can catch non-allocating loops, if you use
    -fno-omit-yields.  This doesn't work for allocation limits.

I couldn't measure any impact on benchmarks with these changes, even
for nofib/smp.
parent 34db5ccf
...@@ -988,9 +988,12 @@ lowerSafeForeignCall dflags block ...@@ -988,9 +988,12 @@ lowerSafeForeignCall dflags block
id <- newTemp (bWord dflags) id <- newTemp (bWord dflags)
new_base <- newTemp (cmmRegType dflags (CmmGlobal BaseReg)) new_base <- newTemp (cmmRegType dflags (CmmGlobal BaseReg))
let (caller_save, caller_load) = callerSaveVolatileRegs dflags let (caller_save, caller_load) = callerSaveVolatileRegs dflags
load_tso <- newTemp (gcWord dflags)
load_stack <- newTemp (gcWord dflags) load_stack <- newTemp (gcWord dflags)
let suspend = saveThreadState dflags <*> tso <- newTemp (gcWord dflags)
cn <- newTemp (bWord dflags)
bdfree <- newTemp (bWord dflags)
bdstart <- newTemp (bWord dflags)
let suspend = saveThreadState dflags tso cn <*>
caller_save <*> caller_save <*>
mkMiddle (callSuspendThread dflags id intrbl) mkMiddle (callSuspendThread dflags id intrbl)
midCall = mkUnsafeCall tgt res args midCall = mkUnsafeCall tgt res args
...@@ -999,7 +1002,7 @@ lowerSafeForeignCall dflags block ...@@ -999,7 +1002,7 @@ lowerSafeForeignCall dflags block
-- might now have a different Capability! -- might now have a different Capability!
mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*> mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*>
caller_load <*> caller_load <*>
loadThreadState dflags load_tso load_stack loadThreadState dflags tso load_stack cn bdfree bdstart
(_, regs, copyout) = (_, regs, copyout) =
copyOutOflow dflags NativeReturn Jump (Young succ) copyOutOflow dflags NativeReturn Jump (Young succ)
......
This diff is collapsed.
...@@ -741,10 +741,8 @@ globalRegMaybe CurrentTSO = Just (RealRegSingle REG_CurrentTSO) ...@@ -741,10 +741,8 @@ globalRegMaybe CurrentTSO = Just (RealRegSingle REG_CurrentTSO)
# ifdef REG_CurrentNursery # ifdef REG_CurrentNursery
globalRegMaybe CurrentNursery = Just (RealRegSingle REG_CurrentNursery) globalRegMaybe CurrentNursery = Just (RealRegSingle REG_CurrentNursery)
# endif # endif
globalRegMaybe _ = Nothing
#else
globalRegMaybe = panic "globalRegMaybe not defined for this platform"
#endif #endif
globalRegMaybe _ = Nothing
freeReg :: RegNo -> FastBool freeReg :: RegNo -> FastBool
......
...@@ -274,6 +274,12 @@ ...@@ -274,6 +274,12 @@
*/ */
#define TSO_SQUEEZED 128 #define TSO_SQUEEZED 128
/*
* Enables the AllocationLimitExceeded exception when the thread's
* allocation limit goes negative.
*/
#define TSO_ALLOC_LIMIT 256
/* /*
* The number of times we spin in a spin lock before yielding (see * The number of times we spin in a spin lock before yielding (see
* #3758). To tune this value, use the benchmark in #3758: run the * #3758). To tune this value, use the benchmark in #3758: run the
......
...@@ -56,6 +56,14 @@ struct GC_FLAGS { ...@@ -56,6 +56,14 @@ struct GC_FLAGS {
rtsBool doIdleGC; rtsBool doIdleGC;
StgWord heapBase; /* address to ask the OS for memory */ StgWord heapBase; /* address to ask the OS for memory */
StgWord allocLimitGrace; /* units: *blocks*
* After an AllocationLimitExceeded
* exception has been raised, how much
* extra space is given to the thread
* to handle the exception before we
* raise it again.
*/
}; };
struct DEBUG_FLAGS { struct DEBUG_FLAGS {
......
...@@ -42,8 +42,12 @@ StgRegTable * resumeThread (void *); ...@@ -42,8 +42,12 @@ StgRegTable * resumeThread (void *);
// //
// Thread operations from Threads.c // Thread operations from Threads.c
// //
int cmp_thread (StgPtr tso1, StgPtr tso2); int cmp_thread (StgPtr tso1, StgPtr tso2);
int rts_getThreadId (StgPtr tso); int rts_getThreadId (StgPtr tso);
HsInt64 rts_getThreadAllocationCounter (StgPtr tso);
void rts_setThreadAllocationCounter (StgPtr tso, HsInt64 i);
void rts_enableThreadAllocationLimit (StgPtr tso);
void rts_disableThreadAllocationLimit (StgPtr tso);
#if !defined(mingw32_HOST_OS) #if !defined(mingw32_HOST_OS)
pid_t forkProcess (HsStablePtr *entry); pid_t forkProcess (HsStablePtr *entry);
......
...@@ -145,15 +145,18 @@ typedef struct StgTSO_ { ...@@ -145,15 +145,18 @@ typedef struct StgTSO_ {
*/ */
struct StgBlockingQueue_ *bq; struct StgBlockingQueue_ *bq;
#ifdef TICKY_TICKY /*
/* TICKY-specific stuff would go here. */ * The allocation limit for this thread, which is updated as the
#endif * thread allocates. If the value drops below zero, and
#ifdef PROFILING * TSO_ALLOC_LIMIT is set in flags, we raise an exception in the
StgTSOProfInfo prof; * thread, and give the thread a little more space to handle the
#endif * exception before we raise the exception again.
#ifdef mingw32_HOST_OS *
StgWord32 saved_winerror; * This is an integer, because we might update it in a place where
#endif * it isn't convenient to raise the exception, so we want it to
* stay negative until we get around to checking it.
*/
StgInt64 alloc_limit; /* in bytes */
/* /*
* sum of the sizes of all stack chunks (in words), used to decide * sum of the sizes of all stack chunks (in words), used to decide
...@@ -168,6 +171,16 @@ typedef struct StgTSO_ { ...@@ -168,6 +171,16 @@ typedef struct StgTSO_ {
*/ */
StgWord32 tot_stack_size; StgWord32 tot_stack_size;
#ifdef TICKY_TICKY
/* TICKY-specific stuff would go here. */
#endif
#ifdef PROFILING
StgTSOProfInfo prof;
#endif
#ifdef mingw32_HOST_OS
StgWord32 saved_winerror;
#endif
} *StgTSOPtr; } *StgTSOPtr;
typedef struct StgStack_ { typedef struct StgStack_ {
......
...@@ -48,6 +48,7 @@ module Control.Exception ( ...@@ -48,6 +48,7 @@ module Control.Exception (
NestedAtomically(..), NestedAtomically(..),
BlockedIndefinitelyOnMVar(..), BlockedIndefinitelyOnMVar(..),
BlockedIndefinitelyOnSTM(..), BlockedIndefinitelyOnSTM(..),
AllocationLimitExceeded(..),
Deadlock(..), Deadlock(..),
NoMethodError(..), NoMethodError(..),
PatternMatchFail(..), PatternMatchFail(..),
......
...@@ -31,6 +31,7 @@ module Control.Exception.Base ( ...@@ -31,6 +31,7 @@ module Control.Exception.Base (
NestedAtomically(..), NestedAtomically(..),
BlockedIndefinitelyOnMVar(..), BlockedIndefinitelyOnMVar(..),
BlockedIndefinitelyOnSTM(..), BlockedIndefinitelyOnSTM(..),
AllocationLimitExceeded(..),
Deadlock(..), Deadlock(..),
NoMethodError(..), NoMethodError(..),
PatternMatchFail(..), PatternMatchFail(..),
......
...@@ -60,6 +60,12 @@ module GHC.Conc ...@@ -60,6 +60,12 @@ module GHC.Conc
, threadWaitWriteSTM , threadWaitWriteSTM
, closeFdWith , closeFdWith
-- * Allocation counter and limit
, setAllocationCounter
, getAllocationCounter
, enableAllocationLimit
, disableAllocationLimit
-- * TVars -- * TVars
, STM(..) , STM(..)
, atomically , atomically
......
...@@ -61,6 +61,12 @@ module GHC.Conc.Sync ...@@ -61,6 +61,12 @@ module GHC.Conc.Sync
, threadStatus , threadStatus
, threadCapability , threadCapability
-- * Allocation counter and quota
, setAllocationCounter
, getAllocationCounter
, enableAllocationLimit
, disableAllocationLimit
-- * TVars -- * TVars
, STM(..) , STM(..)
, atomically , atomically
...@@ -177,16 +183,92 @@ instance Eq ThreadId where ...@@ -177,16 +183,92 @@ instance Eq ThreadId where
instance Ord ThreadId where instance Ord ThreadId where
compare = cmpThread compare = cmpThread
-- | Every thread has an allocation counter that tracks how much
-- memory has been allocated by the thread. The counter is
-- initialized to zero, and 'setAllocationCounter' sets the current
-- value. The allocation counter counts *down*, so in the absence of
-- a call to 'setAllocationCounter' its value is the negation of the
-- number of bytes of memory allocated by the thread.
--
-- There are two things that you can do with this counter:
--
-- * Use it as a simple profiling mechanism, with
-- 'getAllocationCounter'.
--
-- * Use it as a resource limit. See 'enableAllocationLimit'.
--
-- Allocation accounting is accurate only to about 4Kbytes.
--
setAllocationCounter :: Int64 -> IO ()
setAllocationCounter i = do
ThreadId t <- myThreadId
rts_setThreadAllocationCounter t i
-- | Return the current value of the allocation counter for the
-- current thread.
getAllocationCounter :: IO Int64
getAllocationCounter = do
ThreadId t <- myThreadId
rts_getThreadAllocationCounter t
-- | Enables the allocation counter to be treated as a limit for the
-- current thread. When the allocation limit is enabled, if the
-- allocation counter counts down below zero, the thread will be sent
-- the 'AllocationLimitExceeded' asynchronous exception. When this
-- happens, the counter is reinitialised (by default
-- to 100K, but tunable with the @+RTS -xq@ option) so that it can handle
-- the exception and perform any necessary clean up. If it exhausts
-- this additional allowance, another 'AllocationLimitExceeded' exception
-- is sent, and so forth.
--
-- Note that memory allocation is unrelated to /live memory/, also
-- known as /heap residency/. A thread can allocate a large amount of
-- memory and retain anything between none and all of it. It is
-- better to think of the allocation limit as a limit on
-- /CPU time/, rather than a limit on memory.
--
-- Compared to using timeouts, allocation limits don't count time
-- spent blocked or in foreign calls.
--
enableAllocationLimit :: IO ()
enableAllocationLimit = do
ThreadId t <- myThreadId
rts_enableThreadAllocationLimit t
-- | Disable allocation limit processing for the current thread.
disableAllocationLimit :: IO ()
disableAllocationLimit = do
ThreadId t <- myThreadId
rts_disableThreadAllocationLimit t
-- We cannot do these operations safely on another thread, because on
-- a 32-bit machine we cannot do atomic operations on a 64-bit value.
-- Therefore, we only expose APIs that allow getting and setting the
-- limit of the current thread.
foreign import ccall unsafe "rts_setThreadAllocationCounter"
rts_setThreadAllocationCounter :: ThreadId# -> Int64 -> IO ()
foreign import ccall unsafe "rts_getThreadAllocationCounter"
rts_getThreadAllocationCounter :: ThreadId# -> IO Int64
foreign import ccall unsafe "rts_enableThreadAllocationLimit"
rts_enableThreadAllocationLimit :: ThreadId# -> IO ()
foreign import ccall unsafe "rts_disableThreadAllocationLimit"
rts_disableThreadAllocationLimit :: ThreadId# -> IO ()
{- | {- |
Sparks off a new thread to run the 'IO' computation passed as the Creates a new thread to run the 'IO' computation passed as the
first argument, and returns the 'ThreadId' of the newly created first argument, and returns the 'ThreadId' of the newly created
thread. thread.
The new thread will be a lightweight thread; if you want to use a foreign The new thread will be a lightweight, /unbound/ thread. Foreign calls
library that uses thread-local storage, use 'Control.Concurrent.forkOS' instead. made by this thread are not guaranteed to be made by any particular OS
thread; if you need foreign calls to be made by a particular OS
thread, then use 'Control.Concurrent.forkOS' instead.
GHC note: the new thread inherits the /masked/ state of the parent The new thread inherits the /masked/ state of the parent (see
(see 'Control.Exception.mask'). 'Control.Exception.mask').
The newly created thread has an exception handler that discards the The newly created thread has an exception handler that discards the
exceptions 'BlockedIndefinitelyOnMVar', 'BlockedIndefinitelyOnSTM', and exceptions 'BlockedIndefinitelyOnMVar', 'BlockedIndefinitelyOnSTM', and
......
...@@ -22,6 +22,7 @@ module GHC.IO.Exception ( ...@@ -22,6 +22,7 @@ module GHC.IO.Exception (
BlockedIndefinitelyOnMVar(..), blockedIndefinitelyOnMVar, BlockedIndefinitelyOnMVar(..), blockedIndefinitelyOnMVar,
BlockedIndefinitelyOnSTM(..), blockedIndefinitelyOnSTM, BlockedIndefinitelyOnSTM(..), blockedIndefinitelyOnSTM,
Deadlock(..), Deadlock(..),
AllocationLimitExceeded(..), allocationLimitExceeded,
AssertionFailed(..), AssertionFailed(..),
SomeAsyncException(..), SomeAsyncException(..),
...@@ -99,6 +100,23 @@ instance Show Deadlock where ...@@ -99,6 +100,23 @@ instance Show Deadlock where
----- -----
-- |This thread has exceeded its allocation limit. See
-- 'GHC.Conc.setAllocationCounter' and
-- 'GHC.Conc.enableAllocationLimit'.
data AllocationLimitExceeded = AllocationLimitExceeded
deriving Typeable
instance Exception AllocationLimitExceeded
instance Show AllocationLimitExceeded where
showsPrec _ AllocationLimitExceeded =
showString "allocation limit exceeded"
allocationLimitExceeded :: SomeException -- for the RTS
allocationLimitExceeded = toException AllocationLimitExceeded
-----
-- |'assert' was applied to 'False'. -- |'assert' was applied to 'False'.
data AssertionFailed = AssertionFailed String data AssertionFailed = AssertionFailed String
deriving Typeable deriving Typeable
...@@ -175,7 +193,8 @@ data ArrayException ...@@ -175,7 +193,8 @@ data ArrayException
instance Exception ArrayException instance Exception ArrayException
stackOverflow, heapOverflow :: SomeException -- for the RTS -- for the RTS
stackOverflow, heapOverflow :: SomeException
stackOverflow = toException StackOverflow stackOverflow = toException StackOverflow
heapOverflow = toException HeapOverflow heapOverflow = toException HeapOverflow
......
...@@ -100,7 +100,9 @@ stg_gc_noregs ...@@ -100,7 +100,9 @@ stg_gc_noregs
CurrentNursery = bdescr_link(CurrentNursery); CurrentNursery = bdescr_link(CurrentNursery);
OPEN_NURSERY(); OPEN_NURSERY();
if (Capability_context_switch(MyCapability()) != 0 :: CInt || if (Capability_context_switch(MyCapability()) != 0 :: CInt ||
Capability_interrupt(MyCapability()) != 0 :: CInt) { Capability_interrupt(MyCapability()) != 0 :: CInt ||
(StgTSO_alloc_limit(CurrentTSO) `lt` 0 &&
(TO_W_(StgTSO_flags(CurrentTSO)) & TSO_ALLOC_LIMIT) != 0)) {
ret = ThreadYielding; ret = ThreadYielding;
goto sched; goto sched;
} else { } else {
......
...@@ -1230,6 +1230,10 @@ typedef struct _RtsSymbolVal { ...@@ -1230,6 +1230,10 @@ typedef struct _RtsSymbolVal {
SymI_HasProto(rts_getFunPtr) \ SymI_HasProto(rts_getFunPtr) \
SymI_HasProto(rts_getStablePtr) \ SymI_HasProto(rts_getStablePtr) \
SymI_HasProto(rts_getThreadId) \ SymI_HasProto(rts_getThreadId) \
SymI_HasProto(rts_getThreadAllocationCounter) \
SymI_HasProto(rts_setThreadAllocationCounter) \
SymI_HasProto(rts_enableThreadAllocationLimit) \
SymI_HasProto(rts_disableThreadAllocationLimit) \
SymI_HasProto(rts_getWord) \ SymI_HasProto(rts_getWord) \
SymI_HasProto(rts_getWord8) \ SymI_HasProto(rts_getWord8) \
SymI_HasProto(rts_getWord16) \ SymI_HasProto(rts_getWord16) \
......
...@@ -37,6 +37,7 @@ extern StgClosure ZCMain_main_closure; ...@@ -37,6 +37,7 @@ extern StgClosure ZCMain_main_closure;
PRELUDE_CLOSURE(base_GHCziIOziException_stackOverflow_closure); PRELUDE_CLOSURE(base_GHCziIOziException_stackOverflow_closure);
PRELUDE_CLOSURE(base_GHCziIOziException_heapOverflow_closure); PRELUDE_CLOSURE(base_GHCziIOziException_heapOverflow_closure);
PRELUDE_CLOSURE(base_GHCziIOziException_allocationLimitExceeded_closure);
PRELUDE_CLOSURE(base_GHCziIOziException_blockedIndefinitelyOnThrowTo_closure); PRELUDE_CLOSURE(base_GHCziIOziException_blockedIndefinitelyOnThrowTo_closure);
PRELUDE_CLOSURE(base_GHCziIOziException_blockedIndefinitelyOnMVar_closure); PRELUDE_CLOSURE(base_GHCziIOziException_blockedIndefinitelyOnMVar_closure);
PRELUDE_CLOSURE(base_GHCziIOziException_blockedIndefinitelyOnSTM_closure); PRELUDE_CLOSURE(base_GHCziIOziException_blockedIndefinitelyOnSTM_closure);
...@@ -100,6 +101,7 @@ PRELUDE_INFO(base_GHCziStable_StablePtr_con_info); ...@@ -100,6 +101,7 @@ PRELUDE_INFO(base_GHCziStable_StablePtr_con_info);
#define stackOverflow_closure DLL_IMPORT_DATA_REF(base_GHCziIOziException_stackOverflow_closure) #define stackOverflow_closure DLL_IMPORT_DATA_REF(base_GHCziIOziException_stackOverflow_closure)
#define heapOverflow_closure DLL_IMPORT_DATA_REF(base_GHCziIOziException_heapOverflow_closure) #define heapOverflow_closure DLL_IMPORT_DATA_REF(base_GHCziIOziException_heapOverflow_closure)
#define allocationLimitExceeded_closure DLL_IMPORT_DATA_REF(base_GHCziIOziException_allocationLimitExceeded_closure)
#define blockedIndefinitelyOnMVar_closure DLL_IMPORT_DATA_REF(base_GHCziIOziException_blockedIndefinitelyOnMVar_closure) #define blockedIndefinitelyOnMVar_closure DLL_IMPORT_DATA_REF(base_GHCziIOziException_blockedIndefinitelyOnMVar_closure)
#define blockedIndefinitelyOnSTM_closure DLL_IMPORT_DATA_REF(base_GHCziIOziException_blockedIndefinitelyOnSTM_closure) #define blockedIndefinitelyOnSTM_closure DLL_IMPORT_DATA_REF(base_GHCziIOziException_blockedIndefinitelyOnSTM_closure)
#define nonTermination_closure DLL_IMPORT_DATA_REF(base_ControlziExceptionziBase_nonTermination_closure) #define nonTermination_closure DLL_IMPORT_DATA_REF(base_ControlziExceptionziBase_nonTermination_closure)
......
...@@ -88,6 +88,60 @@ suspendComputation (Capability *cap, StgTSO *tso, StgUpdateFrame *stop_here) ...@@ -88,6 +88,60 @@ suspendComputation (Capability *cap, StgTSO *tso, StgUpdateFrame *stop_here)
throwToSingleThreaded__ (cap, tso, NULL, rtsFalse, stop_here); throwToSingleThreaded__ (cap, tso, NULL, rtsFalse, stop_here);
} }
/* -----------------------------------------------------------------------------
throwToSelf
Useful for throwing an async exception in a thread from the
runtime. It handles unlocking the throwto message returned by
throwTo().
Note [Throw to self when masked]
When a StackOverflow occurs when the thread is masked, we want to
defer the exception to when the thread becomes unmasked/hits an
interruptible point. We already have a mechanism for doing this,
the blocked_exceptions list, but the use here is a bit unusual,
because an exception is normally only added to this list upon
an asynchronous 'throwTo' call (with all of the relevant
multithreaded nonsense). Morally, a stack overflow should be an
asynchronous exception sent by a thread to itself, and it should
have the same semantics. But there are a few key differences:
- If you actually tried to send an asynchronous exception to
yourself using throwTo, the exception would actually immediately
be delivered. This is because throwTo itself is considered an
interruptible point, so the exception is always deliverable. Thus,
ordinarily, we never end up with a message to onesself in the
blocked_exceptions queue.
- In the case of a StackOverflow, we don't actually care about the
wakeup semantics; when an exception is delivered, the thread that
originally threw the exception should be woken up, since throwTo
blocks until the exception is successfully thrown. Fortunately,
it is harmless to wakeup a thread that doesn't actually need waking
up, e.g. ourselves.
- No synchronization is necessary, because we own the TSO and the
capability. You can observe this by tracing through the execution
of throwTo. We skip synchronizing the message and inter-capability
communication.
We think this doesn't break any invariants, but do be careful!
-------------------------------------------------------------------------- */
void
throwToSelf (Capability *cap, StgTSO *tso, StgClosure *exception)
{
MessageThrowTo *m;
m = throwTo(cap, tso, tso, exception);
if (m != NULL) {
// throwTo leaves it locked
unlockClosure((StgClosure*)m, &stg_MSG_THROWTO_info);
}
}
/* ----------------------------------------------------------------------------- /* -----------------------------------------------------------------------------
throwTo throwTo
......
...@@ -28,7 +28,11 @@ void throwToSingleThreaded_ (Capability *cap, ...@@ -28,7 +28,11 @@ void throwToSingleThreaded_ (Capability *cap,
StgClosure *exception, StgClosure *exception,
rtsBool stop_at_atomically); rtsBool stop_at_atomically);
void suspendComputation (Capability *cap, void throwToSelf (Capability *cap,
StgTSO *tso,
StgClosure *exception);
void suspendComputation (Capability *cap,
StgTSO *tso, StgTSO *tso,
StgUpdateFrame *stop_here); StgUpdateFrame *stop_here);
......
...@@ -137,6 +137,7 @@ void initRtsFlagsDefaults(void) ...@@ -137,6 +137,7 @@ void initRtsFlagsDefaults(void)
#else #else
RtsFlags.GcFlags.heapBase = 0; /* means don't care */ RtsFlags.GcFlags.heapBase = 0; /* means don't care */
#endif #endif
RtsFlags.GcFlags.allocLimitGrace = (100*1024) / BLOCK_SIZE;
#ifdef DEBUG #ifdef DEBUG
RtsFlags.DebugFlags.scheduler = rtsFalse; RtsFlags.DebugFlags.scheduler = rtsFalse;
...@@ -402,6 +403,8 @@ usage_text[] = { ...@@ -402,6 +403,8 @@ usage_text[] = {
" +PAPI_EVENT - collect papi preset event PAPI_EVENT", " +PAPI_EVENT - collect papi preset event PAPI_EVENT",
" #NATIVE_EVENT - collect native event NATIVE_EVENT (in hex)", " #NATIVE_EVENT - collect native event NATIVE_EVENT (in hex)",
#endif #endif
" -xq The allocation limit given to a thread after it receives",
" an AllocationLimitExceeded exception. (default: 100k)",
"", "",
"RTS options may also be specified using the GHCRTS environment variable.", "RTS options may also be specified using the GHCRTS environment variable.",
"", "",
...@@ -1360,6 +1363,13 @@ error = rtsTrue; ...@@ -1360,6 +1363,13 @@ error = rtsTrue;
/* The option prefix '-xx' is reserved for future extension. KSW 1999-11. */ /* The option prefix '-xx' is reserved for future extension. KSW 1999-11. */
case 'q':
OPTION_UNSAFE;
RtsFlags.GcFlags.allocLimitGrace
= decodeSize(rts_argv[arg], 3, BLOCK_SIZE, HS_INT_MAX)
/ BLOCK_SIZE;
break;
default: default:
OPTION_SAFE; OPTION_SAFE;
errorBelch("unknown RTS option: %s",rts_argv[arg]); errorBelch("unknown RTS option: %s",rts_argv[arg]);
......
...@@ -208,6 +208,7 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config) ...@@ -208,6 +208,7 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config)
getStablePtr((StgPtr)blockedIndefinitelyOnMVar_closure); getStablePtr((StgPtr)blockedIndefinitelyOnMVar_closure);
getStablePtr((StgPtr)nonTermination_closure); getStablePtr((StgPtr)nonTermination_closure);
getStablePtr((StgPtr)blockedIndefinitelyOnSTM_closure); getStablePtr((StgPtr)blockedIndefinitelyOnSTM_closure);
getStablePtr((StgPtr)allocationLimitExceeded_closure);
getStablePtr((StgPtr)nestedAtomically_closure); getStablePtr((StgPtr)nestedAtomically_closure);
getStablePtr((StgPtr)runSparks_closure); getStablePtr((StgPtr)runSparks_closure);
......
...@@ -481,6 +481,10 @@ run_thread: ...@@ -481,6 +481,10 @@ run_thread:
// happened. So find the new location: // happened. So find the new location:
t = cap->r.rCurrentTSO; t = cap->r.rCurrentTSO;
// cap->r.rCurrentTSO is charged for calls to allocate(), so we
// don't want it set during scheduler operations.
cap->r.rCurrentTSO = NULL;
// And save the current errno in this thread. // And save the current errno in this thread.
// XXX: possibly bogus for SMP because this thread might already // XXX: possibly bogus for SMP because this thread might already
// be running again, see code below. // be running again, see code below.
...@@ -1078,6 +1082,21 @@ schedulePostRunThread (Capability *cap, StgTSO *t) ...@@ -1078,6 +1082,21 @@ schedulePostRunThread (Capability *cap, StgTSO *t)
} }
} }
//
// If the current thread's allocation limit has run out, send it
// the AllocationLimitExceeded exception.
if (t->alloc_limit < 0 && (t->flags & TSO_ALLOC_LIMIT)) {
// Use a throwToSelf rather than a throwToSingleThreaded, because
// it correctly handles the case where the thread is currently
// inside mask. Also the thread might be blocked (e.g. on an
// MVar), and throwToSingleThreaded doesn't unblock it
// correctly in that case.
throwToSelf(cap, t, allocationLimitExceeded_closure);
t->alloc_limit = (StgInt64)RtsFlags.GcFlags.allocLimitGrace
* BLOCK_SIZE;
}
/* some statistics gathering in the parallel case */ /* some statistics gathering in the parallel case */
} }
......
...@@ -110,6 +110,8 @@ createThread(Capability *cap, W_ size) ...@@ -110,6 +110,8 @@ createThread(Capability *cap, W_ size)
tso->stackobj = stack; tso->stackobj = stack;
tso->tot_stack_size = stack->stack_size; tso->tot_stack_size = stack->stack_size;
tso->alloc_limit = 0;
tso->trec = NO_TREC; tso->trec = NO_TREC;
#ifdef PROFILING #ifdef PROFILING
...@@ -164,6 +166,31 @@ rts_getThreadId(StgPtr tso) ...@@ -164,6 +166,31 @@ rts_getThreadId(StgPtr tso)
return ((StgTSO *)tso)->id; return ((StgTSO *)tso)->id;
} }
/* ---------------------------------------------------------------------------
* Getting & setting the thread allocation limit
* ------------------------------------------------------------------------ */
HsInt64 rts_getThreadAllocationCounter(StgPtr tso)
{
// NB. doesn't take into account allocation in the current nursery
// block, so it might be off by up to 4k.
return ((StgTSO *)tso)->alloc_limit;
}
void rts_setThreadAllocationCounter(StgPtr tso, HsInt64 i)
{
((StgTSO *)tso)->alloc_limit = i;
}
void rts_enableThreadAllocationLimit(StgPtr tso)
{
((StgTSO *)tso)->flags |= TSO_ALLOC_LIMIT;
}
void rts_disableThreadAllocationLimit(StgPtr tso)
{
((StgTSO *)tso)->flags &= ~TSO_ALLOC_LIMIT;
}
/* ----------------------------------------------------------------------------- /* -----------------------------------------------------------------------------
Remove a thread from a queue. Remove a thread from a queue.
Fails fatally if the TSO is not on the queue. Fails fatally if the TSO is not on the queue.
...@@ -524,21 +551,8 @@ threadStackOverflow (Capability *cap, StgTSO *tso) ...@@ -524,21 +551,8 @@ threadStackOverflow (Capability *cap, StgTSO *tso)
stg_min(tso->stackobj->stack + tso->stackobj->stack_size, stg_min(tso->stackobj->stack + tso->stackobj->stack_size,
tso->stackobj->sp+64))); tso->stackobj->sp+64)));
if (tso->flags & TSO_BLOCKEX) { // Note [Throw to self when masked], also #767 and #8303.
// NB. StackOverflow exceptions must be deferred if the thread is throwToSelf(cap, tso, (StgClosure *)stackOverflow_closure);
// inside Control.Exception.mask. See bug #767 and bug #8303.
// This implementation is a minor hack, see Note [Throw to self when masked]
MessageThrowTo *msg = (MessageThrowTo*)allocate(cap, sizeofW(MessageThrowTo));
SET_HDR(msg, &stg_MSG_THROWTO_info, CCS_SYSTEM);
msg->source = tso;
msg->target = tso;
msg->exception = (StgClosure *)stackOverflow_closure;
blockedThrowTo(cap, tso, msg);
} else {
// Send this thread the StackOverflow exception
throwToSingleThreaded(cap, tso, (StgClosure *)stackOverflow_closure);
return;
}
} }
...@@ -669,39 +683,6 @@ threadStackOverflow (Capability *cap, StgTSO *tso) ...@@ -669,39 +683,6 @@ threadStackOverflow (Capability *cap, StgTSO *tso)
// IF_DEBUG(scheduler,printTSO(new_tso)); // IF_DEBUG(scheduler,printTSO(new_tso));
} }
/* Note [Throw to self when masked]
*
* When a StackOverflow occurs when the thread is masked, we want to
* defer the exception to when the thread becomes unmasked/hits an
* interruptible point. We already have a mechanism for doing this,
* the blocked_exceptions list, but the use here is a bit unusual,
* because an exception is normally only added to this list upon
* an asynchronous 'throwTo' call (with all of the relevant