Per-thread allocation counters and limits
authorSimon Marlow <marlowsd@gmail.com>
Mon, 28 Apr 2014 15:55:47 +0000 (16:55 +0100)
committerSimon Marlow <marlowsd@gmail.com>
Fri, 2 May 2014 13:49:22 +0000 (14:49 +0100)
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.

32 files changed:
compiler/cmm/CmmLayoutStack.hs
compiler/codeGen/StgCmmForeign.hs
includes/CodeGen.Platform.hs
includes/rts/Constants.h
includes/rts/Flags.h
includes/rts/Threads.h
includes/rts/storage/TSO.h
libraries/base/Control/Exception.hs
libraries/base/Control/Exception/Base.hs
libraries/base/GHC/Conc.lhs
libraries/base/GHC/Conc/Sync.lhs
libraries/base/GHC/IO/Exception.hs
rts/HeapStackCheck.cmm
rts/Linker.c
rts/Prelude.h
rts/RaiseAsync.c
rts/RaiseAsync.h
rts/RtsFlags.c
rts/RtsStartup.c
rts/Schedule.c
rts/Threads.c
rts/package.conf.in
rts/sm/Storage.c
testsuite/tests/concurrent/should_run/all.T
testsuite/tests/concurrent/should_run/allocLimit1.hs [new file with mode: 0644]
testsuite/tests/concurrent/should_run/allocLimit1.stderr [new file with mode: 0644]
testsuite/tests/concurrent/should_run/allocLimit2.hs [new file with mode: 0644]
testsuite/tests/concurrent/should_run/allocLimit3.hs [new file with mode: 0644]
testsuite/tests/concurrent/should_run/allocLimit3.stderr [new file with mode: 0644]
testsuite/tests/concurrent/should_run/allocLimit3.stdout [new file with mode: 0644]
testsuite/tests/concurrent/should_run/allocLimit4.hs [new file with mode: 0644]
utils/deriveConstants/DeriveConstants.hs

index bdc9478..e7d57d5 100644 (file)
@@ -988,9 +988,12 @@ lowerSafeForeignCall dflags block
     id <- newTemp (bWord dflags)
     new_base <- newTemp (cmmRegType dflags (CmmGlobal BaseReg))
     let (caller_save, caller_load) = callerSaveVolatileRegs dflags
-    load_tso <- 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 <*>
                   mkMiddle (callSuspendThread dflags id intrbl)
         midCall = mkUnsafeCall tgt res args
@@ -999,7 +1002,7 @@ lowerSafeForeignCall dflags block
                   -- might now have a different Capability!
                   mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*>
                   caller_load <*>
-                  loadThreadState dflags load_tso load_stack
+                  loadThreadState dflags tso load_stack cn bdfree bdstart
 
         (_, regs, copyout) =
              copyOutOflow dflags NativeReturn Jump (Young succ)
index bf88f1c..2730275 100644 (file)
@@ -7,12 +7,15 @@
 -----------------------------------------------------------------------------
 
 module StgCmmForeign (
-  cgForeignCall, loadThreadState, saveThreadState,
+  cgForeignCall,
   emitPrimCall, emitCCall,
   emitForeignCall,     -- For CmmParse
-  emitSaveThreadState, -- will be needed by the Cmm parser
-  emitLoadThreadState, -- ditto
-  emitCloseNursery, emitOpenNursery
+  emitSaveThreadState,
+  saveThreadState,
+  emitLoadThreadState,
+  loadThreadState,
+  emitOpenNursery,
+  emitCloseNursery,
  ) where
 
 #include "HsVersions.h"
@@ -264,94 +267,215 @@ maybe_assign_temp e = do
 -- This stuff can't be done in suspendThread/resumeThread, because it
 -- 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 = do
   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 = do
-  df <- getDynFlags
-  emit (closeNursery df)
+  dflags <- getDynFlags
+  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;
-closeNursery :: DynFlags -> CmmAGraph
-closeNursery dflags = mkStore (nursery_bdescr_free dflags) (cmmOffsetW dflags stgHp 1)
+  // Update the allocation limit for the current thread.  We don't
+  // check to see whether it has overflowed at this point, that check is
+  // 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
-loadThreadState dflags tso stack = do
+  // Set cn->free to the next unoccupied word in the block
+  cn->free = Hp + WDS(1);
+-}
+
+closeNursery :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph
+closeNursery df tso cn =
+  let
+      tsoreg     = CmmLocal tso
+      cnreg      = CmmLocal cn
+  in
   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,
-        -- 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]
+    mkAssign cnreg stgCurrentNursery,
+
+    let alloc =
+           CmmMachOp (mo_wordSub df)
+              [ cmmOffsetW df stgHp 1
+              , CmmLoad (nursery_bdescr_start df cnreg) (bWord df)
+              ]
+
+        alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)
+    in
+
+    -- tso->alloc_limit += alloc
+    mkStore alloc_limit (CmmMachOp (mo_wordSub df)
+                               [ CmmLoad alloc_limit b64
+                               , alloc ]),
+
+    -- CurrentNursery->free = Hp+1;
+    mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW df stgHp 1)
+   ]
 
 emitLoadThreadState :: FCode ()
 emitLoadThreadState = do
   dflags <- getDynFlags
-  load_tso <- newTemp (gcWord dflags)
-  load_stack <- newTemp (gcWord dflags)
-  emit $ loadThreadState dflags load_tso load_stack
+  tso <- newTemp (gcWord dflags)
+  stack <- newTemp (gcWord dflags)
+  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 = do
-  df <- getDynFlags
-  emit (openNursery df)
-
-openNursery :: DynFlags -> CmmAGraph
-openNursery dflags = catAGraphs [
-        -- Hp = CurrentNursery->free - 1;
-        mkAssign hp (cmmOffsetW dflags (CmmLoad (nursery_bdescr_free dflags) (bWord dflags)) (-1)),
-
-        -- HpLim = CurrentNursery->start +
-        --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
-        mkAssign hpLim
-            (cmmOffsetExpr dflags
-                (CmmLoad (nursery_bdescr_start dflags) (bWord dflags))
-                (cmmOffset dflags
-                  (CmmMachOp (mo_wordMul dflags) [
-                    CmmMachOp (MO_SS_Conv W32 (wordWidth dflags))
-                      [CmmLoad (nursery_bdescr_blocks dflags) b32],
-                    mkIntExpr dflags (bLOCK_SIZE dflags)
-                   ])
-                  (-1)
-                )
-            )
+  dflags <- getDynFlags
+  tso <- newTemp (gcWord dflags)
+  cn <- newTemp (bWord dflags)
+  bdfree <- newTemp (bWord dflags)
+  bdstart <- newTemp (bWord dflags)
+  emit $ mkAssign (CmmLocal tso) stgCurrentTSO <*>
+         openNursery dflags tso cn bdfree bdstart
+
+{-
+Opening the nursery corresponds to the following code:
+
+   tso = CurrentTSO;
+   cn = CurrentNursery;
+   bdfree = CurrentNuresry->free;
+   bdstart = CurrentNuresry->start;
+
+   // We *add* the currently occupied portion of the nursery block to
+   // the allocation limit, because we will subtract it again in
+   // closeNursery.
+   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   dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_free dflags)
-nursery_bdescr_start  dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_start dflags)
-nursery_bdescr_blocks dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_blocks dflags)
+nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks
+  :: DynFlags -> CmmReg -> CmmExpr
+nursery_bdescr_free   dflags cn =
+  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_alloc_limit dflags = closureField dflags (oFFSET_StgTSO_alloc_limit dflags)
 tso_CCCS     dflags = closureField dflags (oFFSET_StgTSO_cccs dflags)
 stack_STACK  dflags = closureField dflags (oFFSET_StgStack_stack dflags)
 stack_SP     dflags = closureField dflags (oFFSET_StgStack_sp dflags)
index 3d6dd41..f3abb3d 100644 (file)
@@ -741,10 +741,8 @@ globalRegMaybe CurrentTSO               = Just (RealRegSingle REG_CurrentTSO)
 # ifdef REG_CurrentNursery
 globalRegMaybe CurrentNursery           = Just (RealRegSingle REG_CurrentNursery)
 # endif
-globalRegMaybe _                        = Nothing
-#else
-globalRegMaybe = panic "globalRegMaybe not defined for this platform"
 #endif
+globalRegMaybe _                        = Nothing
 
 freeReg :: RegNo -> FastBool
 
index 842c37b..a7eef0f 100644 (file)
 #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
  * #3758).  To tune this value, use the benchmark in #3758: run the
  * server with -N2 and the client both on a dual-core.  Also make sure
index bf6a7f3..ec54270 100644 (file)
@@ -56,6 +56,14 @@ struct GC_FLAGS {
     rtsBool doIdleGC;
 
     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 {  
index da6f7a4..f6264ad 100644 (file)
@@ -42,8 +42,12 @@ StgRegTable * resumeThread  (void *);
 //
 // Thread operations from Threads.c
 //
-int    cmp_thread      (StgPtr tso1, StgPtr tso2);
-int    rts_getThreadId (StgPtr tso);
+int     cmp_thread                       (StgPtr tso1, StgPtr tso2);
+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)
 pid_t  forkProcess     (HsStablePtr *entry);
index 187b668..b933067 100644 (file)
@@ -145,15 +145,18 @@ typedef struct StgTSO_ {
     */
     struct StgBlockingQueue_ *bq;
 
-#ifdef TICKY_TICKY
-    /* TICKY-specific stuff would go here. */
-#endif
-#ifdef PROFILING
-    StgTSOProfInfo prof;
-#endif
-#ifdef mingw32_HOST_OS
-    StgWord32 saved_winerror;
-#endif
+    /*
+     * The allocation limit for this thread, which is updated as the
+     * thread allocates.  If the value drops below zero, and
+     * TSO_ALLOC_LIMIT is set in flags, we raise an exception in the
+     * thread, and give the thread a little more space to handle the
+     * exception before we raise the exception again.
+     *
+     * This is an integer, because we might update it in a place where
+     * 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
@@ -168,6 +171,16 @@ typedef struct StgTSO_ {
      */
     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;
 
 typedef struct StgStack_ {
index 7c019eb..e13a0e9 100644 (file)
@@ -48,6 +48,7 @@ module Control.Exception (
         NestedAtomically(..),
         BlockedIndefinitelyOnMVar(..),
         BlockedIndefinitelyOnSTM(..),
+        AllocationLimitExceeded(..),
         Deadlock(..),
         NoMethodError(..),
         PatternMatchFail(..),
index d8a0d96..be9f4e5 100644 (file)
@@ -31,6 +31,7 @@ module Control.Exception.Base (
         NestedAtomically(..),
         BlockedIndefinitelyOnMVar(..),
         BlockedIndefinitelyOnSTM(..),
+        AllocationLimitExceeded(..),
         Deadlock(..),
         NoMethodError(..),
         PatternMatchFail(..),
index 1ba17f2..804fd15 100644 (file)
@@ -60,6 +60,12 @@ module GHC.Conc
         , threadWaitWriteSTM
         , closeFdWith
 
+        -- * Allocation counter and limit
+        , setAllocationCounter
+        , getAllocationCounter
+        , enableAllocationLimit
+        , disableAllocationLimit
+
         -- * TVars
         , STM(..)
         , atomically
index ebb7226..6d786f5 100644 (file)
@@ -61,6 +61,12 @@ module GHC.Conc.Sync
         , threadStatus
         , threadCapability
 
+        -- * Allocation counter and quota
+        , setAllocationCounter
+        , getAllocationCounter
+        , enableAllocationLimit
+        , disableAllocationLimit
+
         -- * TVars
         , STM(..)
         , atomically
@@ -177,16 +183,92 @@ instance Eq ThreadId where
 instance Ord ThreadId where
    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
 thread.
 
-The new thread will be a lightweight thread; if you want to use a foreign
-library that uses thread-local storage, use 'Control.Concurrent.forkOS' instead.
+The new thread will be a lightweight, /unbound/ thread.  Foreign calls
+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
-(see 'Control.Exception.mask').
+The new thread inherits the /masked/ state of the parent (see
+'Control.Exception.mask').
 
 The newly created thread has an exception handler that discards the
 exceptions 'BlockedIndefinitelyOnMVar', 'BlockedIndefinitelyOnSTM', and
index 7f5bc4e..af9e766 100644 (file)
@@ -22,6 +22,7 @@ module GHC.IO.Exception (
   BlockedIndefinitelyOnMVar(..), blockedIndefinitelyOnMVar,
   BlockedIndefinitelyOnSTM(..), blockedIndefinitelyOnSTM,
   Deadlock(..),
+  AllocationLimitExceeded(..), allocationLimitExceeded,
   AssertionFailed(..),
 
   SomeAsyncException(..),
@@ -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'.
 data AssertionFailed = AssertionFailed String
     deriving Typeable
@@ -175,7 +193,8 @@ data ArrayException
 
 instance Exception ArrayException
 
-stackOverflow, heapOverflow :: SomeException -- for the RTS
+-- for the RTS
+stackOverflow, heapOverflow :: SomeException
 stackOverflow = toException StackOverflow
 heapOverflow  = toException HeapOverflow
 
index 12bcfb2..2808203 100644 (file)
@@ -100,7 +100,9 @@ stg_gc_noregs
             CurrentNursery = bdescr_link(CurrentNursery);
             OPEN_NURSERY();
             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;
                 goto sched;
             } else {
index ea7c1c6..6ddf4be 100644 (file)
@@ -1230,6 +1230,10 @@ typedef struct _RtsSymbolVal {
       SymI_HasProto(rts_getFunPtr)                                      \
       SymI_HasProto(rts_getStablePtr)                                   \
       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_getWord8)                                       \
       SymI_HasProto(rts_getWord16)                                      \
index 89e80a0..ca08e2c 100644 (file)
@@ -37,6 +37,7 @@ extern StgClosure ZCMain_main_closure;
 
 PRELUDE_CLOSURE(base_GHCziIOziException_stackOverflow_closure);
 PRELUDE_CLOSURE(base_GHCziIOziException_heapOverflow_closure);
+PRELUDE_CLOSURE(base_GHCziIOziException_allocationLimitExceeded_closure);
 PRELUDE_CLOSURE(base_GHCziIOziException_blockedIndefinitelyOnThrowTo_closure);
 PRELUDE_CLOSURE(base_GHCziIOziException_blockedIndefinitelyOnMVar_closure);
 PRELUDE_CLOSURE(base_GHCziIOziException_blockedIndefinitelyOnSTM_closure);
@@ -100,6 +101,7 @@ PRELUDE_INFO(base_GHCziStable_StablePtr_con_info);
 
 #define stackOverflow_closure     DLL_IMPORT_DATA_REF(base_GHCziIOziException_stackOverflow_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 blockedIndefinitelyOnSTM_closure DLL_IMPORT_DATA_REF(base_GHCziIOziException_blockedIndefinitelyOnSTM_closure)
 #define nonTermination_closure    DLL_IMPORT_DATA_REF(base_ControlziExceptionziBase_nonTermination_closure)
index a5440e4..847076b 100644 (file)
@@ -89,6 +89,60 @@ suspendComputation (Capability *cap, StgTSO *tso, StgUpdateFrame *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
 
    This function may be used to throw an exception from one thread to
index 1f61b8c..65ca4f5 100644 (file)
@@ -28,7 +28,11 @@ void throwToSingleThreaded_ (Capability *cap,
                             StgClosure *exception, 
                             rtsBool stop_at_atomically);
 
-void suspendComputation (Capability *cap, 
+void throwToSelf (Capability *cap,
+                  StgTSO *tso,
+                  StgClosure *exception);
+
+void suspendComputation (Capability *cap,
                         StgTSO *tso, 
                         StgUpdateFrame *stop_here);
 
index af1b204..fb1e2ec 100644 (file)
@@ -137,6 +137,7 @@ void initRtsFlagsDefaults(void)
 #else
     RtsFlags.GcFlags.heapBase           = 0;   /* means don't care */
 #endif
+    RtsFlags.GcFlags.allocLimitGrace    = (100*1024) / BLOCK_SIZE;
 
 #ifdef DEBUG
     RtsFlags.DebugFlags.scheduler       = rtsFalse;
@@ -402,6 +403,8 @@ usage_text[] = {
 "            +PAPI_EVENT   - collect papi preset event PAPI_EVENT",
 "            #NATIVE_EVENT - collect native event NATIVE_EVENT (in hex)",
 #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.",
 "",
@@ -1360,6 +1363,13 @@ error = rtsTrue;
 
                   /* 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:
                     OPTION_SAFE;
                     errorBelch("unknown RTS option: %s",rts_argv[arg]);
index aa7306f..640811f 100644 (file)
@@ -208,6 +208,7 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config)
     getStablePtr((StgPtr)blockedIndefinitelyOnMVar_closure);
     getStablePtr((StgPtr)nonTermination_closure);
     getStablePtr((StgPtr)blockedIndefinitelyOnSTM_closure);
+    getStablePtr((StgPtr)allocationLimitExceeded_closure);
     getStablePtr((StgPtr)nestedAtomically_closure);
 
     getStablePtr((StgPtr)runSparks_closure);
index adf2b5c..b1b489a 100644 (file)
@@ -481,6 +481,10 @@ run_thread:
     // happened.  So find the new location:
     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.
     // XXX: possibly bogus for SMP because this thread might already
     // be running again, see code below.
@@ -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 */
 }
 
index af4353f..b822952 100644 (file)
@@ -110,6 +110,8 @@ createThread(Capability *cap, W_ size)
     tso->stackobj       = stack;
     tso->tot_stack_size = stack->stack_size;
 
+    tso->alloc_limit = 0;
+
     tso->trec = NO_TREC;
 
 #ifdef PROFILING
@@ -164,6 +166,31 @@ rts_getThreadId(StgPtr tso)
   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.
    Fails fatally if the TSO is not on the queue.
@@ -524,21 +551,8 @@ threadStackOverflow (Capability *cap, StgTSO *tso)
                                  stg_min(tso->stackobj->stack + tso->stackobj->stack_size,
                                          tso->stackobj->sp+64)));
 
-        if (tso->flags & TSO_BLOCKEX) {
-            // NB. StackOverflow exceptions must be deferred if the thread is
-            // 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;
-        }
+        // Note [Throw to self when masked], also #767 and #8303.
+        throwToSelf(cap, tso, (StgClosure *)stackOverflow_closure);
     }
 
 
@@ -669,39 +683,6 @@ threadStackOverflow (Capability *cap, StgTSO *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
- * 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!
- */
 
 
 /* ---------------------------------------------------------------------------
index 4c8686f..25fb5eb 100644 (file)
@@ -98,6 +98,7 @@ ld-options:
          , "-Wl,-u,_base_ControlziExceptionziBase_nonTermination_closure"
          , "-Wl,-u,_base_GHCziIOziException_blockedIndefinitelyOnMVar_closure"
          , "-Wl,-u,_base_GHCziIOziException_blockedIndefinitelyOnSTM_closure"
+         , "-Wl,-u,_base_GHCziIOziException_allocationQuotaExceeded_closure"
          , "-Wl,-u,_base_ControlziExceptionziBase_nestedAtomically_closure"
          , "-Wl,-u,_base_GHCziWeak_runFinalizzerBatch_closure"
          , "-Wl,-u,_base_GHCziTopHandler_flushStdHandles_closure"
@@ -138,6 +139,7 @@ ld-options:
          , "-Wl,-u,base_ControlziExceptionziBase_nonTermination_closure"
          , "-Wl,-u,base_GHCziIOziException_blockedIndefinitelyOnMVar_closure"
          , "-Wl,-u,base_GHCziIOziException_blockedIndefinitelyOnSTM_closure"
+         , "-Wl,-u,base_GHCziIOziException_allocationQuotaExceeded_closure"
          , "-Wl,-u,base_ControlziExceptionziBase_nestedAtomically_closure"
          , "-Wl,-u,base_GHCziWeak_runFinalizzerBatch_closure"
          , "-Wl,-u,base_GHCziTopHandler_flushStdHandles_closure"
index 86bd1c2..865a890 100644 (file)
@@ -684,7 +684,10 @@ StgPtr allocate (Capability *cap, W_ n)
 
     TICK_ALLOC_HEAP_NOCTR(WDS(n));
     CCS_ALLOC(cap->r.rCCCS,n);
-    
+    if (cap->r.rCurrentTSO != NULL) {
+        cap->r.rCurrentTSO->alloc_limit -= n*sizeof(W_);
+    }
+
     if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
         W_ req_blocks =  (W_)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE;
 
@@ -821,6 +824,9 @@ allocatePinned (Capability *cap, W_ n)
 
     TICK_ALLOC_HEAP_NOCTR(WDS(n));
     CCS_ALLOC(cap->r.rCCCS,n);
+    if (cap->r.rCurrentTSO != NULL) {
+        cap->r.rCurrentTSO->alloc_limit -= n*sizeof(W_);
+    }
 
     bd = cap->pinned_object_block;
     
index d4e76c6..f8f583e 100644 (file)
@@ -81,6 +81,12 @@ test('tryReadMVar1', normal, compile_and_run, [''])
 
 test('T7970', normal, compile_and_run, [''])
 
+test('allocLimit1', exit_code(1), compile_and_run, [''])
+test('allocLimit2', normal, compile_and_run, [''])
+test('allocLimit3', exit_code(1), compile_and_run, [''])
+test('allocLimit4', [ extra_run_opts('+RTS -xq300k -RTS') ],
+                    compile_and_run, [''])
+
 # -----------------------------------------------------------------------------
 # These tests we only do for a full run
 
@@ -245,3 +251,4 @@ test('setnumcapabilities001',
 
 # omit ghci, which can't handle unboxed tuples:
 test('compareAndSwap', [omit_ways(['ghci','hpc']), reqlib('primitive')], compile_and_run, [''])
+
diff --git a/testsuite/tests/concurrent/should_run/allocLimit1.hs b/testsuite/tests/concurrent/should_run/allocLimit1.hs
new file mode 100644 (file)
index 0000000..b1c8fa6
--- /dev/null
@@ -0,0 +1,9 @@
+module Main (main) where
+
+import GHC.Conc
+
+main = do
+  setAllocationCounter (10*1024)
+  enableAllocationLimit
+  print (length [1..])
+
diff --git a/testsuite/tests/concurrent/should_run/allocLimit1.stderr b/testsuite/tests/concurrent/should_run/allocLimit1.stderr
new file mode 100644 (file)
index 0000000..2133e14
--- /dev/null
@@ -0,0 +1 @@
+allocLimit1: allocation limit exceeded
diff --git a/testsuite/tests/concurrent/should_run/allocLimit2.hs b/testsuite/tests/concurrent/should_run/allocLimit2.hs
new file mode 100644 (file)
index 0000000..4fd117b
--- /dev/null
@@ -0,0 +1,17 @@
+module Main (main) where
+
+import GHC.Conc
+import Control.Concurrent
+import Control.Exception
+import System.Exit
+
+main = do
+  m <- newEmptyMVar
+  let action =  do setAllocationCounter (10*1024)
+                   enableAllocationLimit
+                   print (length [1..])
+  forkFinally action (putMVar m)
+  r <- takeMVar m
+  case r of
+    Left e | Just AllocationLimitExceeded <- fromException e -> return ()
+    _ -> print r >> exitFailure
diff --git a/testsuite/tests/concurrent/should_run/allocLimit3.hs b/testsuite/tests/concurrent/should_run/allocLimit3.hs
new file mode 100644 (file)
index 0000000..28881dc
--- /dev/null
@@ -0,0 +1,15 @@
+module Main (main) where
+
+import GHC.Conc
+import Control.Concurrent
+import Control.Exception
+
+main = do
+  setAllocationCounter (10*1024)
+  enableAllocationLimit
+
+  -- alloc limit overflow while masked: should successfully print the
+  -- result, and then immediately raise the exception
+  r <- mask_ $ try $ print (length [1..100000])
+
+  print (r :: Either SomeException ())
diff --git a/testsuite/tests/concurrent/should_run/allocLimit3.stderr b/testsuite/tests/concurrent/should_run/allocLimit3.stderr
new file mode 100644 (file)
index 0000000..27ae0a9
--- /dev/null
@@ -0,0 +1 @@
+allocLimit3: allocation limit exceeded
diff --git a/testsuite/tests/concurrent/should_run/allocLimit3.stdout b/testsuite/tests/concurrent/should_run/allocLimit3.stdout
new file mode 100644 (file)
index 0000000..f7393e8
--- /dev/null
@@ -0,0 +1 @@
+100000
diff --git a/testsuite/tests/concurrent/should_run/allocLimit4.hs b/testsuite/tests/concurrent/should_run/allocLimit4.hs
new file mode 100644 (file)
index 0000000..b589ffa
--- /dev/null
@@ -0,0 +1,31 @@
+module Main (main) where
+
+import GHC.Conc
+import Control.Concurrent
+import Control.Exception
+import System.Exit
+import Control.Monad
+
+-- check that +RTS -xq is doing the right thing: the test requires
+-- +RTS -xq300k
+
+main = do
+  m <- newEmptyMVar
+  let action = do
+         e <- try $ do
+          setAllocationCounter (10*1024)
+          enableAllocationLimit
+          print (length [1..])
+         case e of
+           Left AllocationLimitExceeded{} -> do
+             c <- getAllocationCounter
+             when (c < 250*1024 || c > 350*1024) $ fail "wrong limit grace"
+             print (length [2..])
+           Right _ ->
+             fail "didn't catch AllocationLimitExceeded"
+
+  forkFinally action (putMVar m)
+  r <- takeMVar m
+  case r of
+    Left e | Just AllocationLimitExceeded <- fromException e -> return ()
+    _ -> print r >> exitFailure
index 8c943f0..0ed18bc 100644 (file)
@@ -411,6 +411,7 @@ wanteds = concat
           ,closureField  C    "StgTSO"      "flags"
           ,closureField  C    "StgTSO"      "dirty"
           ,closureField  C    "StgTSO"      "bq"
+          ,closureField  Both "StgTSO"      "alloc_limit"
           ,closureField_ Both "StgTSO_cccs" "StgTSO" "prof.cccs"
           ,closureField  Both "StgTSO"      "stackobj"