Commit b0534f78 authored by Simon Marlow's avatar Simon Marlow
Browse files

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)
......
...@@ -7,12 +7,15 @@ ...@@ -7,12 +7,15 @@
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module StgCmmForeign ( module StgCmmForeign (
cgForeignCall, loadThreadState, saveThreadState, cgForeignCall,
emitPrimCall, emitCCall, emitPrimCall, emitCCall,
emitForeignCall, -- For CmmParse emitForeignCall, -- For CmmParse
emitSaveThreadState, -- will be needed by the Cmm parser emitSaveThreadState,
emitLoadThreadState, -- ditto saveThreadState,
emitCloseNursery, emitOpenNursery emitLoadThreadState,
loadThreadState,
emitOpenNursery,
emitCloseNursery,
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -264,94 +267,215 @@ maybe_assign_temp e = do ...@@ -264,94 +267,215 @@ maybe_assign_temp e = do
-- This stuff can't be done in suspendThread/resumeThread, because it -- This stuff can't be done in suspendThread/resumeThread, because it
-- refers to global registers which aren't available in the C world. -- refers to global registers which aren't available in the C world.
saveThreadState :: DynFlags -> CmmAGraph
saveThreadState dflags =
-- CurrentTSO->stackobj->sp = Sp;
mkStore (cmmOffset dflags (CmmLoad (cmmOffset dflags stgCurrentTSO (tso_stackobj dflags)) (bWord dflags)) (stack_SP dflags)) stgSp
<*> closeNursery dflags
-- and save the current cost centre stack in the TSO when profiling:
<*> if gopt Opt_SccProfilingOn dflags then
mkStore (cmmOffset dflags stgCurrentTSO (tso_CCCS dflags)) curCCS
else mkNop
emitSaveThreadState :: FCode () emitSaveThreadState :: FCode ()
emitSaveThreadState = do emitSaveThreadState = do
dflags <- getDynFlags dflags <- getDynFlags
emit (saveThreadState dflags) tso <- newTemp (gcWord dflags)
cn <- newTemp (bWord dflags)
emit $ saveThreadState dflags tso cn
-- saveThreadState must be usable from the stack layout pass, where we
-- don't have FCode. Therefore it takes LocalRegs as arguments, so
-- the caller can create these.
saveThreadState :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph
saveThreadState dflags tso cn =
catAGraphs [
-- tso = CurrentTSO;
mkAssign (CmmLocal tso) stgCurrentTSO,
-- tso->stackobj->sp = Sp;
mkStore (cmmOffset dflags (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)) (stack_SP dflags)) stgSp,
closeNursery dflags tso cn,
-- and save the current cost centre stack in the TSO when profiling:
if gopt Opt_SccProfilingOn dflags then
mkStore (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) curCCS
else mkNop
]
emitCloseNursery :: FCode () emitCloseNursery :: FCode ()
emitCloseNursery = do emitCloseNursery = do
df <- getDynFlags dflags <- getDynFlags
emit (closeNursery df) tso <- newTemp (gcWord dflags)
cn <- newTemp (bWord dflags)
emit $ mkAssign (CmmLocal tso) stgCurrentTSO <*>
closeNursery dflags tso cn
{-
Closing the nursery corresponds to the following code:
tso = CurrentTSO;
cn = CurrentNuresry;
-- CurrentNursery->free = Hp+1; // Update the allocation limit for the current thread. We don't
closeNursery :: DynFlags -> CmmAGraph // check to see whether it has overflowed at this point, that check is
closeNursery dflags = mkStore (nursery_bdescr_free dflags) (cmmOffsetW dflags stgHp 1) // made when we run out of space in the current heap block (stg_gc_noregs)
// and in the scheduler when context switching (schedulePostRunThread).
tso->alloc_limit -= Hp + WDS(1) - cn->start;
loadThreadState :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph // Set cn->free to the next unoccupied word in the block
loadThreadState dflags tso stack = do cn->free = Hp + WDS(1);
-}
closeNursery :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph
closeNursery df tso cn =
let
tsoreg = CmmLocal tso
cnreg = CmmLocal cn
in
catAGraphs [ catAGraphs [
-- tso = CurrentTSO; mkAssign cnreg stgCurrentNursery,
mkAssign (CmmLocal tso) stgCurrentTSO,
-- stack = tso->stackobj; let alloc =
mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)), CmmMachOp (mo_wordSub df)
-- Sp = stack->sp; [ cmmOffsetW df stgHp 1
mkAssign sp (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)), , CmmLoad (nursery_bdescr_start df cnreg) (bWord df)
-- SpLim = stack->stack + RESERVED_STACK_WORDS; ]
mkAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags))
(rESERVED_STACK_WORDS dflags)), alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)
-- HpAlloc = 0; in
-- HpAlloc is assumed to be set to non-zero only by a failed
-- a heap check, see HeapStackCheck.cmm:GC_GENERIC -- tso->alloc_limit += alloc
mkAssign hpAlloc (zeroExpr dflags), mkStore alloc_limit (CmmMachOp (mo_wordSub df)
[ CmmLoad alloc_limit b64
openNursery dflags, , alloc ]),
-- and load the current cost centre stack from the TSO when profiling:
if gopt Opt_SccProfilingOn dflags then -- CurrentNursery->free = Hp+1;
storeCurCCS mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW df stgHp 1)
(CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) (ccsType dflags)) ]
else mkNop]
emitLoadThreadState :: FCode () emitLoadThreadState :: FCode ()
emitLoadThreadState = do emitLoadThreadState = do
dflags <- getDynFlags dflags <- getDynFlags
load_tso <- newTemp (gcWord dflags) tso <- newTemp (gcWord dflags)
load_stack <- newTemp (gcWord dflags) stack <- newTemp (gcWord dflags)
emit $ loadThreadState dflags load_tso load_stack cn <- newTemp (bWord dflags)
bdfree <- newTemp (bWord dflags)
bdstart <- newTemp (bWord dflags)
emit $ loadThreadState dflags tso stack cn bdfree bdstart
-- loadThreadState must be usable from the stack layout pass, where we
-- don't have FCode. Therefore it takes LocalRegs as arguments, so
-- the caller can create these.
loadThreadState :: DynFlags
-> LocalReg -> LocalReg -> LocalReg -> LocalReg -> LocalReg
-> CmmAGraph
loadThreadState dflags tso stack cn bdfree bdstart =
catAGraphs [
-- tso = CurrentTSO;
mkAssign (CmmLocal tso) stgCurrentTSO,
-- stack = tso->stackobj;
mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)),
-- Sp = stack->sp;
mkAssign sp (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)),
-- SpLim = stack->stack + RESERVED_STACK_WORDS;
mkAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags))
(rESERVED_STACK_WORDS dflags)),
-- HpAlloc = 0;
-- HpAlloc is assumed to be set to non-zero only by a failed
-- a heap check, see HeapStackCheck.cmm:GC_GENERIC
mkAssign hpAlloc (zeroExpr dflags),
openNursery dflags tso cn bdfree bdstart,
-- and load the current cost centre stack from the TSO when profiling:
if gopt Opt_SccProfilingOn dflags
then storeCurCCS
(CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso))
(tso_CCCS dflags)) (ccsType dflags))
else mkNop
]
emitOpenNursery :: FCode () emitOpenNursery :: FCode ()
emitOpenNursery = do emitOpenNursery = do
df <- getDynFlags dflags <- getDynFlags
emit (openNursery df) tso <- newTemp (gcWord dflags)
cn <- newTemp (bWord dflags)
openNursery :: DynFlags -> CmmAGraph bdfree <- newTemp (bWord dflags)
openNursery dflags = catAGraphs [ bdstart <- newTemp (bWord dflags)
-- Hp = CurrentNursery->free - 1; emit $ mkAssign (CmmLocal tso) stgCurrentTSO <*>
mkAssign hp (cmmOffsetW dflags (CmmLoad (nursery_bdescr_free dflags) (bWord dflags)) (-1)), openNursery dflags tso cn bdfree bdstart
-- HpLim = CurrentNursery->start + {-
-- CurrentNursery->blocks*BLOCK_SIZE_W - 1; Opening the nursery corresponds to the following code:
mkAssign hpLim
(cmmOffsetExpr dflags tso = CurrentTSO;
(CmmLoad (nursery_bdescr_start dflags) (bWord dflags)) cn = CurrentNursery;
(cmmOffset dflags bdfree = CurrentNuresry->free;
(CmmMachOp (mo_wordMul dflags) [ bdstart = CurrentNuresry->start;
CmmMachOp (MO_SS_Conv W32 (wordWidth dflags))
[CmmLoad (nursery_bdescr_blocks dflags) b32], // We *add* the currently occupied portion of the nursery block to
mkIntExpr dflags (bLOCK_SIZE dflags) // the allocation limit, because we will subtract it again in
]) // closeNursery.
(-1) tso->alloc_limit += bdfree - bdstart;
)
) // Set Hp to the last occupied word of the heap block. Why not the
// next unocupied word? Doing it this way means that we get to use
// an offset of zero more often, which might lead to slightly smaller
// code on some architectures.
Hp = bdfree - WDS(1);
// Set HpLim to the end of the current nursery block (note that this block
// might be a block group, consisting of several adjacent blocks.
HpLim = bdstart + CurrentNursery->blocks*BLOCK_SIZE_W - 1;
-}
openNursery :: DynFlags
-> LocalReg -> LocalReg -> LocalReg -> LocalReg
-> CmmAGraph
openNursery df tso cn bdfree bdstart =
let
tsoreg = CmmLocal tso
cnreg = CmmLocal cn
bdfreereg = CmmLocal bdfree
bdstartreg = CmmLocal bdstart
in
catAGraphs [
mkAssign cnreg stgCurrentNursery,
mkAssign bdfreereg (CmmLoad (nursery_bdescr_free df cnreg) (bWord df)),
mkAssign bdstartreg (CmmLoad (nursery_bdescr_start df cnreg) (bWord df)),
-- alloc = bd->free - bd->start
let alloc =
CmmMachOp (mo_wordSub df) [CmmReg bdfreereg, CmmReg bdstartreg]
alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)
in
-- tso->alloc_limit += alloc
mkStore alloc_limit (CmmMachOp (mo_wordAdd df)
[ CmmLoad alloc_limit b64
, alloc ]),
-- Hp = CurrentNursery->free - 1;
mkAssign hp (cmmOffsetW df (CmmReg bdfreereg) (-1)),
-- HpLim = CurrentNursery->start +
-- CurrentNursery->blocks*BLOCK_SIZE_W - 1;
mkAssign hpLim
(cmmOffsetExpr df
(CmmReg bdstartreg)
(cmmOffset df
(CmmMachOp (mo_wordMul df) [
CmmMachOp (MO_SS_Conv W32 (wordWidth df))
[CmmLoad (nursery_bdescr_blocks df cnreg) b32],
mkIntExpr df (bLOCK_SIZE df)
])
(-1)
)
)
] ]
nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: DynFlags -> CmmExpr nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks
nursery_bdescr_free dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_free dflags) :: DynFlags -> CmmReg -> CmmExpr
nursery_bdescr_start dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_start dflags) nursery_bdescr_free dflags cn =
nursery_bdescr_blocks dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_blocks dflags) cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_free dflags)
nursery_bdescr_start dflags cn =
cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_start dflags)
nursery_bdescr_blocks dflags cn =
cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_blocks dflags)
tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: DynFlags -> ByteOff tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: DynFlags -> ByteOff
tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags) tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags)
tso_alloc_limit dflags = closureField dflags (oFFSET_StgTSO_alloc_limit dflags)
tso_CCCS dflags = closureField dflags (oFFSET_StgTSO_cccs dflags) tso_CCCS dflags = closureField dflags (oFFSET_StgTSO_cccs dflags)
stack_STACK dflags = closureField dflags (oFFSET_StgStack_stack dflags) stack_STACK dflags = closureField dflags (oFFSET_StgStack_stack dflags)
stack_SP dflags = closureField dflags (oFFSET_StgStack_sp dflags) stack_SP dflags = closureField dflags (oFFSET_StgStack_sp dflags)
......
...@@ -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.