Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Implement stack chunks and separate TSO/STACK objects

This patch makes two changes to the way stacks are managed:

1. The stack is now stored in a separate object from the TSO.

This means that it is easier to replace the stack object for a thread
when the stack overflows or underflows; we don't have to leave behind
the old TSO as an indirection any more.  Consequently, we can remove
ThreadRelocated and deRefTSO(), which were a pain.

This is obviously the right thing, but the last time I tried to do it
it made performance worse.  This time I seem to have cracked it.

2. Stacks are now represented as a chain of chunks, rather than
   a single monolithic object.

The big advantage here is that individual chunks are marked clean or
dirty according to whether they contain pointers to the young
generation, and the GC can avoid traversing clean stack chunks during
a young-generation collection.  This means that programs with deep
stacks will see a big saving in GC overhead when using the default GC
settings.

A secondary advantage is that there is much less copying involved as
the stack grows.  Programs that quickly grow a deep stack will see big
improvements.

In some ways the implementation is simpler, as nothing special needs
to be done to reclaim stack as the stack shrinks (the GC just recovers
the dead stack chunks).  On the other hand, we have to manage stack
underflow between chunks, so there's a new stack frame
(UNDERFLOW_FRAME), and we now have separate TSO and STACK objects.
The total amount of code is probably about the same as before.

There are new RTS flags:

   -ki<size> Sets the initial thread stack size (default 1k)  Egs: -ki4k -ki2m
   -kc<size> Sets the stack chunk size (default 32k)
   -kb<size> Sets the stack chunk buffer size (default 1k)

-ki was previously called just -k, and the old name is still accepted
for backwards compatibility.  These new options are documented.
  • Loading branch information...
commit f30d527344db528618f64a25250a3be557d9f287 1 parent 99b6e6a
@simonmar simonmar authored
Showing with 1,043 additions and 961 deletions.
  1. +2 −2 compiler/cmm/CmmCPSGen.hs
  2. +21 −23 compiler/codeGen/CgForeignCall.hs
  3. +4 −2 compiler/codeGen/StgCmmForeign.hs
  4. +87 −16 docs/users_guide/runtime_control.xml
  5. +6 −0 includes/Cmm.h
  6. +6 −3 includes/mkDerivedConstants.c
  7. +1 −7 includes/rts/Constants.h
  8. +2 −0  includes/rts/Flags.h
  9. +0 −9 includes/rts/prof/LDV.h
  10. +66 −6 includes/rts/storage/ClosureMacros.h
  11. +24 −22 includes/rts/storage/ClosureTypes.h
  12. +5 −0 includes/rts/storage/Closures.h
  13. +41 −41 includes/rts/storage/TSO.h
  14. +3 −0  includes/stg/MiscClosures.h
  15. +2 −1  includes/stg/Ticky.h
  16. +53 −0 rts/Apply.cmm
  17. +6 −4 rts/ClosureFlags.c
  18. +6 −9 rts/Exception.cmm
  19. +9 −9 rts/Interpreter.c
  20. +1 −0  rts/LdvProfile.c
  21. +7 −5 rts/Messages.c
  22. +11 −0 rts/Messages.h
  23. +30 −51 rts/PrimOps.cmm
  24. +16 −7 rts/Printer.c
  25. +20 −4 rts/ProfHeap.c
  26. +0 −1  rts/ProfHeap.h
  27. +90 −55 rts/RaiseAsync.c
  28. +18 −21 rts/RetainerProfile.c
  29. +2 −2 rts/RtsAPI.c
  30. +30 −4 rts/RtsFlags.c
  31. +36 −247 rts/Schedule.c
  32. +1 −1  rts/Schedule.h
  33. +20 −0 rts/StgMiscClosures.cmm
  34. +28 −30 rts/ThreadPaused.c
  35. +242 −46 rts/Threads.c
  36. +4 −3 rts/Threads.h
  37. +1 −1  rts/Trace.h
  38. +3 −94 rts/Updates.h
  39. +1 −9 rts/posix/Select.c
  40. +0 −42 rts/sm/BlockAlloc.c
  41. +20 −9 rts/sm/Compact.c
  42. +17 −26 rts/sm/Evac.c
  43. +1 −13 rts/sm/GCAux.c
  44. +0 −6 rts/sm/MarkWeak.c
  45. +35 −20 rts/sm/Sanity.c
  46. +46 −48 rts/sm/Scav.c
  47. +17 −47 rts/sm/Storage.c
  48. +1 −1  rts/sm/Storage.h
  49. +1 −14 rts/win32/AsyncIO.c
View
4 compiler/cmm/CmmCPSGen.hs
@@ -331,8 +331,8 @@ nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
tso_SP, tso_STACK, tso_CCCS :: ByteOff
-tso_SP = tsoFieldB oFFSET_StgTSO_sp
-tso_STACK = tsoFieldB oFFSET_StgTSO_stack
+tso_SP = tsoFieldB undefined --oFFSET_StgTSO_sp
+tso_STACK = tsoFieldB undefined --oFFSET_StgTSO_stack
tso_CCCS = tsoProfFieldB oFFSET_StgTSO_CCCS
-- The TSO struct has a variable header, and an optional StgTSOProfInfo in
View
44 compiler/codeGen/CgForeignCall.hs
@@ -202,8 +202,9 @@ maybe_assign_temp e
emitSaveThreadState :: Code
emitSaveThreadState = do
- -- CurrentTSO->sp = Sp;
- stmtC $ CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp
+ -- CurrentTSO->stackobj->sp = Sp;
+ stmtC $ CmmStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO tso_stackobj) bWord)
+ stack_SP) stgSp
emitCloseNursery
-- and save the current cost centre stack in the TSO when profiling:
when opt_SccProfilingOn $
@@ -216,14 +217,17 @@ emitCloseNursery = stmtC $ CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
emitLoadThreadState :: Code
emitLoadThreadState = do
tso <- newTemp bWord -- TODO FIXME NOW
+ stack <- newTemp bWord -- TODO FIXME NOW
stmtsC [
- -- tso = CurrentTSO;
- CmmAssign (CmmLocal tso) stgCurrentTSO,
- -- Sp = tso->sp;
- CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
- bWord),
- -- SpLim = tso->stack + RESERVED_STACK_WORDS;
- CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
+ -- tso = CurrentTSO
+ CmmAssign (CmmLocal tso) stgCurrentTSO,
+ -- stack = tso->stackobj
+ CmmAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_stackobj) bWord),
+ -- Sp = stack->sp;
+ CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) stack_SP)
+ bWord),
+ -- SpLim = stack->stack + RESERVED_STACK_WORDS;
+ CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) stack_STACK)
rESERVED_STACK_WORDS),
-- HpAlloc = 0;
-- HpAlloc is assumed to be set to non-zero only by a failed
@@ -234,7 +238,7 @@ emitLoadThreadState = do
-- and load the current cost centre stack from the TSO when profiling:
when opt_SccProfilingOn $
stmtC (CmmStore curCCSAddr
- (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) bWord))
+ (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) bWord))
emitOpenNursery :: Code
emitOpenNursery = stmtsC [
@@ -262,20 +266,14 @@ nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free
nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
-tso_SP, tso_STACK, tso_CCCS :: ByteOff
-tso_SP = tsoFieldB oFFSET_StgTSO_sp
-tso_STACK = tsoFieldB oFFSET_StgTSO_stack
-tso_CCCS = tsoProfFieldB oFFSET_StgTSO_CCCS
+tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: ByteOff
+tso_stackobj = closureField oFFSET_StgTSO_stackobj
+tso_CCCS = closureField oFFSET_StgTSO_CCCS
+stack_STACK = closureField oFFSET_StgStack_stack
+stack_SP = closureField oFFSET_StgStack_sp
--- The TSO struct has a variable header, and an optional StgTSOProfInfo in
--- the middle. The fields we're interested in are after the StgTSOProfInfo.
-tsoFieldB :: ByteOff -> ByteOff
-tsoFieldB off
- | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
- | otherwise = off + fixedHdrSize * wORD_SIZE
-
-tsoProfFieldB :: ByteOff -> ByteOff
-tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
+closureField :: ByteOff -> ByteOff
+closureField off = off + fixedHdrSize * wORD_SIZE
stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
stgSp = CmmReg sp
View
6 compiler/codeGen/StgCmmForeign.hs
@@ -243,10 +243,12 @@ nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
tso_SP, tso_STACK, tso_CCCS :: ByteOff
-tso_SP = tsoFieldB oFFSET_StgTSO_sp
-tso_STACK = tsoFieldB oFFSET_StgTSO_stack
tso_CCCS = tsoProfFieldB oFFSET_StgTSO_CCCS
+ --ToDo: needs merging with changes to CgForeign
+tso_STACK = tsoFieldB undefined
+tso_SP = tsoFieldB undefined
+
-- The TSO struct has a variable header, and an optional StgTSOProfInfo in
-- the middle. The fields we're interested in are after the StgTSOProfInfo.
tsoFieldB :: ByteOff -> ByteOff
View
103 docs/users_guide/runtime_control.xml
@@ -424,22 +424,88 @@
<varlistentry>
<term>
- <option>-k</option><replaceable>size</replaceable>
+ <option>-ki</option><replaceable>size</replaceable>
<indexterm><primary><option>-k</option></primary><secondary>RTS option</secondary></indexterm>
- <indexterm><primary>stack, minimum size</primary></indexterm>
+ <indexterm><primary>stack, initial size</primary></indexterm>
</term>
<listitem>
- <para>&lsqb;Default: 1k&rsqb; Set the initial stack size for
- new threads. Thread stacks (including the main thread's
- stack) live on the heap, and grow as required. The default
- value is good for concurrent applications with lots of small
- threads; if your program doesn't fit this model then
- increasing this option may help performance.</para>
-
- <para>The main thread is normally started with a slightly
- larger heap to cut down on unnecessary stack growth while
- the program is starting up.</para>
- </listitem>
+ <para>
+ &lsqb;Default: 1k&rsqb; Set the initial stack size for new
+ threads. (Note: this flag used to be
+ simply <option>-k</option>, but was renamed
+ to <option>-ki</option> in GHC 7.2.1. The old name is
+ still accepted for backwards compatibility, but that may
+ be removed in a future version).
+ </para>
+
+ <para>
+ Thread stacks (including the main thread's stack) live on
+ the heap. As the stack grows, new stack chunks are added
+ as required; if the stack shrinks again, these extra stack
+ chunks are reclaimed by the garbage collector. The
+ default initial stack size is deliberately small, in order
+ to keep the time and space overhead for thread creation to
+ a minimum, and to make it practical to spawn threads for
+ even tiny pieces of work.
+ </para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term>
+ <option>-kc</option><replaceable>size</replaceable>
+ <indexterm><primary><option>-kc</option></primary><secondary>RTS
+ option</secondary></indexterm>
+ <indexterm><primary>stack</primary><secondary>chunk size</secondary></indexterm>
+ </term>
+ <listitem>
+ <para>
+ &lsqb;Default: 32k&rsqb; Set the size of &ldquo;stack
+ chunks&rdquo;. When a thread's current stack overflows, a
+ new stack chunk is created and added to the thread's
+ stack, until the limit set by <option>-K</option> is
+ reached.
+ </para>
+
+ <para>
+ The advantage of smaller stack chunks is that the garbage
+ collector can avoid traversing stack chunks if they are
+ known to be unmodified since the last collection, so
+ reducing the chunk size means that the garbage collector
+ can identify more stack as unmodified, and the GC overhead
+ might be reduced. On the other hand, making stack chunks
+ too small adds some overhead as there will be more
+ overflow/underflow between chunks. The default setting of
+ 32k appears to be a reasonable compromise in most cases.
+ </para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term>
+ <option>-kb</option><replaceable>size</replaceable>
+ <indexterm><primary><option>-kc</option></primary><secondary>RTS
+ option</secondary></indexterm>
+ <indexterm><primary>stack</primary><secondary>chunk buffer size</secondary></indexterm>
+ </term>
+ <listitem>
+ <para>
+ &lsqb;Default: 1k&rsqb; Sets the stack chunk buffer size.
+ When a stack chunk overflows and a new stack chunk is
+ created, some of the data from the previous stack chunk is
+ moved into the new chunk, to avoid an immediate underflow
+ and repeated overflow/underflow at the boundary. The
+ amount of stack moved is set by the <option>-kb</option>
+ option.
+ </para>
+ <para>
+ Note that to avoid wasting space, this value should
+ typically be less than 10&percnt; of the size of a stack
+ chunk (<option>-kc</option>), because in a chain of stack
+ chunks, each chunk will have a gap of unused space of this
+ size.
+ </para>
+ </listitem>
</varlistentry>
<varlistentry>
@@ -451,9 +517,14 @@
<listitem>
<para>&lsqb;Default: 8M&rsqb; Set the maximum stack size for
an individual thread to <replaceable>size</replaceable>
- bytes. This option is there purely to stop the program
- eating up all the available memory in the machine if it gets
- into an infinite loop.</para>
+ bytes. If the thread attempts to exceed this limit, it will
+ be send the <literal>StackOverflow</literal> exception.
+ </para>
+ <para>
+ This option is there mainly to stop the program eating up
+ all the available memory in the machine if it gets into an
+ infinite loop.
+ </para>
</listitem>
</varlistentry>
View
6 includes/Cmm.h
@@ -467,6 +467,12 @@
#define mutArrPtrsCardWords(n) \
ROUNDUP_BYTES_TO_WDS(((n) + (1 << MUT_ARR_PTRS_CARD_BITS) - 1) >> MUT_ARR_PTRS_CARD_BITS)
+#if defined(PROFILING) || (!defined(THREADED_RTS) && defined(DEBUG))
+#define OVERWRITING_CLOSURE(c) foreign "C" overwritingClosure(c "ptr")
+#else
+#define OVERWRITING_CLOSURE(c) /* nothing */
+#endif
+
/* -----------------------------------------------------------------------------
Voluntary Yields/Blocks
View
9 includes/mkDerivedConstants.c
@@ -296,9 +296,12 @@ main(int argc, char *argv[])
closure_field(StgTSO, dirty);
closure_field(StgTSO, bq);
closure_field_("StgTSO_CCCS", StgTSO, prof.CCCS);
- tso_field(StgTSO, sp);
- tso_field_offset(StgTSO, stack);
- tso_field(StgTSO, stack_size);
+ closure_field(StgTSO, stackobj);
+
+ closure_field(StgStack, sp);
+ closure_field_offset(StgStack, stack);
+ closure_field(StgStack, stack_size);
+ closure_field(StgStack, dirty);
struct_size(StgTSOProfInfo);
View
8 includes/rts/Constants.h
@@ -198,8 +198,7 @@
#define ThreadRunGHC 1 /* return to address on top of stack */
#define ThreadInterpret 2 /* interpret this thread */
#define ThreadKilled 3 /* thread has died, don't run it */
-#define ThreadRelocated 4 /* thread has moved, link points to new locn */
-#define ThreadComplete 5 /* thread has finished */
+#define ThreadComplete 4 /* thread has finished */
/*
* Constants for the why_blocked field of a TSO
@@ -266,11 +265,6 @@
#define TSO_STOPPED_ON_BREAKPOINT 16
/*
- * TSO_LINK_DIRTY is set when a TSO's link field is modified
- */
-#define TSO_LINK_DIRTY 32
-
-/*
* Used by the sanity checker to check whether TSOs are on the correct
* mutable list.
*/
View
2  includes/rts/Flags.h
@@ -29,6 +29,8 @@ struct GC_FLAGS {
nat maxStkSize; /* in *words* */
nat initialStkSize; /* in *words* */
+ nat stkChunkSize; /* in *words* */
+ nat stkChunkBufferSize; /* in *words* */
nat maxHeapSize; /* in *blocks* */
nat minAllocAreaSize; /* in *blocks* */
View
9 includes/rts/prof/LDV.h
@@ -31,25 +31,16 @@
#ifdef CMINUSMINUS
-#define LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(c) \
- foreign "C" LDV_recordDead_FILL_SLOP_DYNAMIC(c "ptr")
-
#else
#define LDV_RECORD_CREATE(c) \
LDVW((c)) = ((StgWord)RTS_DEREF(era) << LDV_SHIFT) | LDV_STATE_CREATE
-void LDV_recordDead_FILL_SLOP_DYNAMIC( StgClosure *p );
-
-#define LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(c) \
- LDV_recordDead_FILL_SLOP_DYNAMIC(c)
-
#endif
#else /* !PROFILING */
#define LDV_RECORD_CREATE(c) /* nothing */
-#define LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(c) /* nothing */
#endif /* PROFILING */
View
72 includes/rts/storage/ClosureMacros.h
@@ -131,9 +131,9 @@
// Use when changing a closure from one kind to another
#define OVERWRITE_INFO(c, new_info) \
- LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC((StgClosure *)(c)); \
- SET_INFO((c), (new_info)); \
- LDV_RECORD_CREATE(c);
+ OVERWRITING_CLOSURE((StgClosure *)(c)); \
+ SET_INFO((c), (new_info)); \
+ LDV_RECORD_CREATE(c);
/* -----------------------------------------------------------------------------
How to get hold of the static link field for a static closure.
@@ -289,8 +289,8 @@ INLINE_HEADER StgOffset arr_words_sizeW( StgArrWords* x )
INLINE_HEADER StgOffset mut_arr_ptrs_sizeW( StgMutArrPtrs* x )
{ return sizeofW(StgMutArrPtrs) + x->size; }
-INLINE_HEADER StgWord tso_sizeW ( StgTSO *tso )
-{ return TSO_STRUCT_SIZEW + tso->stack_size; }
+INLINE_HEADER StgWord stack_sizeW ( StgStack *stack )
+{ return sizeofW(StgStack) + stack->stack_size; }
INLINE_HEADER StgWord bco_sizeW ( StgBCO *bco )
{ return bco->size; }
@@ -339,7 +339,9 @@ closure_sizeW_ (StgClosure *p, StgInfoTable *info)
case MUT_ARR_PTRS_FROZEN0:
return mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
case TSO:
- return tso_sizeW((StgTSO *)p);
+ return sizeofW(StgTSO);
+ case STACK:
+ return stack_sizeW((StgStack*)p);
case BCO:
return bco_sizeW((StgBCO *)p);
case TREC_CHUNK:
@@ -417,4 +419,62 @@ INLINE_HEADER StgWord8 *mutArrPtrsCard (StgMutArrPtrs *a, lnat n)
return ((StgWord8 *)&(a->payload[a->ptrs]) + n);
}
+/* -----------------------------------------------------------------------------
+ Replacing a closure with a different one. We must call
+ OVERWRITING_CLOSURE(p) on the old closure that is about to be
+ overwritten.
+
+ In PROFILING mode, LDV profiling requires that we fill the slop
+ with zeroes, and record the old closure as dead (LDV_recordDead()).
+
+ In DEBUG mode, we must overwrite the slop with zeroes, because the
+ sanity checker wants to walk through the heap checking all the
+ pointers.
+
+ In multicore mode, we *cannot* overwrite slop with zeroes, because
+ another thread might be reading it. So,
+
+ PROFILING is not compatible with +RTS -N<n> (for n > 1)
+
+ THREADED_RTS can be used with DEBUG, but full heap sanity
+ checking is disabled.
+
+ -------------------------------------------------------------------------- */
+
+#if defined(PROFILING) || (!defined(THREADED_RTS) && defined(DEBUG))
+#define OVERWRITING_CLOSURE(c) overwritingClosure(c)
+#else
+#define OVERWRITING_CLOSURE(c) /* nothing */
+#endif
+
+#ifdef PROFILING
+void LDV_recordDead (StgClosure *c, nat size);
+#endif
+
+#ifdef KEEP_INLINES
+void overwritingClosure (StgClosure *p);
+#else
+INLINE_HEADER
+#endif
+void
+overwritingClosure (StgClosure *p)
+{
+ nat size, i;
+
+#if defined(PROFILING)
+ if (era <= 0) return;
+#endif
+
+ size = closure_sizeW(p);
+
+ // For LDV profiling, we need to record the closure as dead
+#if defined(PROFILING)
+ LDV_recordDead((StgClosure *)(p), size);
+#endif
+
+ for (i = 0; i < size - sizeofW(StgThunkHeader); i++) {
+ ((StgThunk *)(p))->payload[i] = 0;
+ }
+}
+
#endif /* RTS_STORAGE_CLOSUREMACROS_H */
View
46 includes/rts/storage/ClosureTypes.h
@@ -56,27 +56,29 @@
#define RET_FUN 35
#define UPDATE_FRAME 36
#define CATCH_FRAME 37
-#define STOP_FRAME 38
-#define BLOCKING_QUEUE 39
-#define BLACKHOLE 40
-#define MVAR_CLEAN 41
-#define MVAR_DIRTY 42
-#define ARR_WORDS 43
-#define MUT_ARR_PTRS_CLEAN 44
-#define MUT_ARR_PTRS_DIRTY 45
-#define MUT_ARR_PTRS_FROZEN0 46
-#define MUT_ARR_PTRS_FROZEN 47
-#define MUT_VAR_CLEAN 48
-#define MUT_VAR_DIRTY 49
-#define WEAK 50
-#define PRIM 51
-#define MUT_PRIM 52
-#define TSO 53
-#define TREC_CHUNK 54
-#define ATOMICALLY_FRAME 55
-#define CATCH_RETRY_FRAME 56
-#define CATCH_STM_FRAME 57
-#define WHITEHOLE 58
-#define N_CLOSURE_TYPES 59
+#define UNDERFLOW_FRAME 38
+#define STOP_FRAME 39
+#define BLOCKING_QUEUE 40
+#define BLACKHOLE 41
+#define MVAR_CLEAN 42
+#define MVAR_DIRTY 43
+#define ARR_WORDS 44
+#define MUT_ARR_PTRS_CLEAN 45
+#define MUT_ARR_PTRS_DIRTY 46
+#define MUT_ARR_PTRS_FROZEN0 47
+#define MUT_ARR_PTRS_FROZEN 48
+#define MUT_VAR_CLEAN 49
+#define MUT_VAR_DIRTY 50
+#define WEAK 51
+#define PRIM 52
+#define MUT_PRIM 53
+#define TSO 54
+#define STACK 55
+#define TREC_CHUNK 56
+#define ATOMICALLY_FRAME 57
+#define CATCH_RETRY_FRAME 58
+#define CATCH_STM_FRAME 59
+#define WHITEHOLE 60
+#define N_CLOSURE_TYPES 61
#endif /* RTS_STORAGE_CLOSURETYPES_H */
View
5 includes/rts/storage/Closures.h
@@ -166,6 +166,11 @@ typedef struct {
} StgCatchFrame;
typedef struct {
+ const StgInfoTable* info;
+ struct StgStack_ *next_chunk;
+} StgUnderflowFrame;
+
+typedef struct {
StgHeader header;
} StgStopFrame;
View
82 includes/rts/storage/TSO.h
@@ -83,7 +83,7 @@ typedef struct StgTSO_ {
Currently used for linking TSOs on:
* cap->run_queue_{hd,tl}
* (non-THREADED_RTS); the blocked_queue
- * and pointing to the relocated version of a ThreadRelocated
+ * and pointing to the next chunk for a ThreadOldStack
NOTE!!! do not modify _link directly, it is subject to
a write barrier for generational GC. Instead use the
@@ -97,7 +97,11 @@ typedef struct StgTSO_ {
struct StgTSO_* global_link; // Links threads on the
// generation->threads lists
- StgWord dirty; /* non-zero => dirty */
+ /*
+ * The thread's stack
+ */
+ struct StgStack_ *stackobj;
+
/*
* The tso->dirty flag indicates that this TSO's stack should be
* scanned during garbage collection. It also indicates that this
@@ -110,10 +114,6 @@ typedef struct StgTSO_ {
*
* tso->dirty is set by dirty_TSO(), and unset by the garbage
* collector (only).
- *
- * The link field has a separate dirty bit of its own, namely the
- * bit TSO_LINK_DIRTY in the tso->flags field, set by
- * setTSOLink().
*/
StgWord16 what_next; // Values defined in Constants.h
@@ -121,21 +121,21 @@ typedef struct StgTSO_ {
StgWord32 flags; // Values defined in Constants.h
StgTSOBlockInfo block_info;
StgThreadID id;
- int saved_errno;
+ StgWord32 saved_errno;
+ StgWord32 dirty; /* non-zero => dirty */
struct InCall_* bound;
struct Capability_* cap;
+
struct StgTRecHeader_ * trec; /* STM transaction record */
/*
- A list of threads blocked on this TSO waiting to throw
- exceptions. In order to access this field, the TSO must be
- locked using lockClosure/unlockClosure (see SMP.h).
+ * A list of threads blocked on this TSO waiting to throw exceptions.
*/
struct MessageThrowTo_ * blocked_exceptions;
/*
- A list of StgBlockingQueue objects, representing threads blocked
- on thunks that are under evaluation by this thread.
+ * A list of StgBlockingQueue objects, representing threads
+ * blocked on thunks that are under evaluation by this thread.
*/
struct StgBlockingQueue_ *bq;
@@ -149,14 +149,36 @@ typedef struct StgTSO_ {
StgWord32 saved_winerror;
#endif
- /* The thread stack... */
- StgWord32 stack_size; /* stack size in *words* */
- StgWord32 max_stack_size; /* maximum stack size in *words* */
- StgPtr sp;
-
- StgWord stack[FLEXIBLE_ARRAY];
+ /*
+ * sum of the sizes of all stack chunks (in words), used to decide
+ * whether to throw the StackOverflow exception when the stack
+ * overflows, or whether to just chain on another stack chunk.
+ *
+ * Note that this overestimates the real stack size, because each
+ * chunk will have a gap at the end, of +RTS -kb<size> words.
+ * This means stack overflows are not entirely accurate, because
+ * the more gaps there are, the sooner the stack will run into the
+ * hard +RTS -K<size> limit.
+ */
+ StgWord32 tot_stack_size;
+
} *StgTSOPtr;
+typedef struct StgStack_ {
+ StgHeader header;
+ StgWord32 stack_size; // stack size in *words*
+ StgWord32 dirty; // non-zero => dirty
+ StgPtr sp; // current stack pointer
+ StgWord stack[FLEXIBLE_ARRAY];
+} StgStack;
+
+// Calculate SpLim from a TSO (reads tso->stackobj, but no fields from
+// the stackobj itself).
+INLINE_HEADER StgPtr tso_SpLim (StgTSO* tso)
+{
+ return tso->stackobj->stack + RESERVED_STACK_WORDS;
+}
+
/* -----------------------------------------------------------------------------
functions
-------------------------------------------------------------------------- */
@@ -165,17 +187,7 @@ void dirty_TSO (Capability *cap, StgTSO *tso);
void setTSOLink (Capability *cap, StgTSO *tso, StgTSO *target);
void setTSOPrev (Capability *cap, StgTSO *tso, StgTSO *target);
-// Apply to a TSO before looking at it if you are not sure whether it
-// might be ThreadRelocated or not (basically, that's most of the time
-// unless the TSO is the current TSO).
-//
-INLINE_HEADER StgTSO * deRefTSO(StgTSO *tso)
-{
- while (tso->what_next == ThreadRelocated) {
- tso = tso->_link;
- }
- return tso;
-}
+void dirty_STACK (Capability *cap, StgStack *stack);
/* -----------------------------------------------------------------------------
Invariants:
@@ -232,18 +244,6 @@ INLINE_HEADER StgTSO * deRefTSO(StgTSO *tso)
---------------------------------------------------------------------------- */
-/* Workaround for a bug/quirk in gcc on certain architectures.
- * symptom is that (&tso->stack - &tso->header) /= sizeof(StgTSO)
- * in other words, gcc pads the structure at the end.
- */
-
-extern StgTSO dummy_tso;
-
-#define TSO_STRUCT_SIZE \
- ((char *)&dummy_tso.stack - (char *)&dummy_tso.header)
-
-#define TSO_STRUCT_SIZEW (TSO_STRUCT_SIZE / sizeof(W_))
-
/* this is the NIL ptr for a TSO queue (e.g. runnable queue) */
#define END_TSO_QUEUE ((StgTSO *)(void*)&stg_END_TSO_QUEUE_closure)
View
3  includes/stg/MiscClosures.h
@@ -61,6 +61,7 @@ RTS_RET(stg_catch_stm_frame);
RTS_RET(stg_unmaskAsyncExceptionszh_ret);
RTS_RET(stg_maskUninterruptiblezh_ret);
RTS_RET(stg_maskAsyncExceptionszh_ret);
+RTS_RET(stg_stack_underflow_frame);
// RTS_FUN(stg_interp_constr_entry);
//
@@ -100,6 +101,7 @@ RTS_ENTRY(stg_STABLE_NAME);
RTS_ENTRY(stg_MVAR_CLEAN);
RTS_ENTRY(stg_MVAR_DIRTY);
RTS_ENTRY(stg_TSO);
+RTS_ENTRY(stg_STACK);
RTS_ENTRY(stg_ARR_WORDS);
RTS_ENTRY(stg_MUT_ARR_WORDS);
RTS_ENTRY(stg_MUT_ARR_PTRS_CLEAN);
@@ -119,6 +121,7 @@ RTS_ENTRY(stg_PAP);
RTS_ENTRY(stg_AP);
RTS_ENTRY(stg_AP_NOUPD);
RTS_ENTRY(stg_AP_STACK);
+RTS_ENTRY(stg_AP_STACK_NOUPD);
RTS_ENTRY(stg_dummy_ret);
RTS_ENTRY(stg_raise);
RTS_ENTRY(stg_raise_ret);
View
3  includes/stg/Ticky.h
@@ -190,7 +190,8 @@ EXTERN StgInt RET_SEMI_loads_avoided INIT(0);
#define TICK_UPD_SQUEEZED()
#define TICK_ALLOC_HEAP_NOCTR(x)
#define TICK_GC_FAILED_PROMOTION()
-#define TICK_ALLOC_TSO(g,s)
+#define TICK_ALLOC_TSO()
+#define TICK_ALLOC_STACK(g)
#define TICK_ALLOC_UP_THK(g,s)
#define TICK_ALLOC_SE_THK(g,s)
View
53 rts/Apply.cmm
@@ -350,3 +350,56 @@ for:
ENTER();
}
+
+/* -----------------------------------------------------------------------------
+ AP_STACK_NOUPD - exactly like AP_STACK, but doesn't push an update frame.
+ -------------------------------------------------------------------------- */
+
+INFO_TABLE(stg_AP_STACK_NOUPD,/*special layout*/0,0,AP_STACK,
+ "AP_STACK_NOUPD","AP_STACK_NOUPD")
+{
+ W_ Words;
+ W_ ap;
+
+ ap = R1;
+
+ Words = StgAP_STACK_size(ap);
+
+ /*
+ * Check for stack overflow. IMPORTANT: use a _NP check here,
+ * because if the check fails, we might end up blackholing this very
+ * closure, in which case we must enter the blackhole on return rather
+ * than continuing to evaluate the now-defunct closure.
+ */
+ STK_CHK_NP(WDS(Words) + WDS(AP_STACK_SPLIM));
+ /* ensure there is at least AP_STACK_SPLIM words of headroom available
+ * after unpacking the AP_STACK. See bug #1466 */
+
+ Sp = Sp - WDS(Words);
+
+ TICK_ENT_AP();
+ LDV_ENTER(ap);
+
+ // Enter PAP cost centre
+ ENTER_CCS_PAP_CL(ap); // ToDo: ENTER_CC_AP_CL
+
+ // Reload the stack
+ W_ i;
+ W_ p;
+ p = ap + SIZEOF_StgHeader + OFFSET_StgAP_STACK_payload;
+ i = 0;
+for:
+ if (i < Words) {
+ Sp(i) = W_[p];
+ p = p + WDS(1);
+ i = i + 1;
+ goto for;
+ }
+
+ // Off we go!
+ TICK_ENT_VIA_NODE();
+
+ R1 = StgAP_STACK_fun(ap);
+
+ ENTER();
+}
View
10 rts/ClosureFlags.c
@@ -59,8 +59,9 @@ StgWord16 closure_flags[] = {
[RET_FUN] = ( 0 ),
[UPDATE_FRAME] = ( _BTM ),
[CATCH_FRAME] = ( _BTM ),
- [STOP_FRAME] = ( _BTM ),
- [BLACKHOLE] = ( _NS| _UPT ),
+ [UNDERFLOW_FRAME] = ( _BTM ),
+ [STOP_FRAME] = ( _BTM ),
+ [BLACKHOLE] = ( _NS| _UPT ),
[BLOCKING_QUEUE] = ( _NS| _MUT|_UPT ),
[MVAR_CLEAN] = (_HNF| _NS| _MUT|_UPT ),
[MVAR_DIRTY] = (_HNF| _NS| _MUT|_UPT ),
@@ -74,7 +75,8 @@ StgWord16 closure_flags[] = {
[WEAK] = (_HNF| _NS| _UPT ),
[PRIM] = (_HNF| _NS| _UPT ),
[MUT_PRIM] = (_HNF| _NS| _MUT|_UPT ),
- [TSO] = (_HNF| _NS| _MUT|_UPT ),
+ [TSO] = (_HNF| _NS| _MUT|_UPT ),
+ [STACK] = (_HNF| _NS| _MUT|_UPT ),
[TREC_CHUNK] = ( _NS| _MUT|_UPT ),
[ATOMICALLY_FRAME] = ( _BTM ),
[CATCH_RETRY_FRAME] = ( _BTM ),
@@ -82,6 +84,6 @@ StgWord16 closure_flags[] = {
[WHITEHOLE] = ( 0 )
};
-#if N_CLOSURE_TYPES != 59
+#if N_CLOSURE_TYPES != 61
#error Closure types changed: update ClosureFlags.c!
#endif
View
15 rts/Exception.cmm
@@ -283,11 +283,6 @@ stg_killThreadzh
* If the exception went to a catch frame, we'll just continue from
* the handler.
*/
- loop:
- if (StgTSO_what_next(target) == ThreadRelocated::I16) {
- target = StgTSO__link(target);
- goto loop;
- }
if (target == CurrentTSO) {
/*
* So what should happen if a thread calls "throwTo self" inside
@@ -436,9 +431,9 @@ stg_raisezh
#endif
retry_pop_stack:
- StgTSO_sp(CurrentTSO) = Sp;
+ SAVE_THREAD_STATE();
(frame_type) = foreign "C" raiseExceptionHelper(BaseReg "ptr", CurrentTSO "ptr", exception "ptr") [];
- Sp = StgTSO_sp(CurrentTSO);
+ LOAD_THREAD_STATE();
if (frame_type == ATOMICALLY_FRAME) {
/* The exception has reached the edge of a memory transaction. Check that
* the transaction is valid. If not then perhaps the exception should
@@ -511,8 +506,10 @@ retry_pop_stack:
* We will leave the stack in a GC'able state, see the stg_stop_thread
* entry code in StgStartup.cmm.
*/
- Sp = CurrentTSO + TSO_OFFSET_StgTSO_stack
- + WDS(TO_W_(StgTSO_stack_size(CurrentTSO))) - WDS(2);
+ W_ stack;
+ stack = StgTSO_stackobj(CurrentTSO);
+ Sp = stack + OFFSET_StgStack_stack
+ + WDS(TO_W_(StgStack_stack_size(stack))) - WDS(2);
Sp(1) = exception; /* save the exception */
Sp(0) = stg_enter_info; /* so that GC can traverse this stack */
StgTSO_what_next(CurrentTSO) = ThreadKilled::I16;
View
18 rts/Interpreter.c
@@ -65,13 +65,13 @@
#define BCO_LIT(n) literals[n]
#define LOAD_STACK_POINTERS \
- Sp = cap->r.rCurrentTSO->sp; \
+ Sp = cap->r.rCurrentTSO->stackobj->sp; \
/* We don't change this ... */ \
- SpLim = cap->r.rCurrentTSO->stack + RESERVED_STACK_WORDS;
+ SpLim = tso_SpLim(cap->r.rCurrentTSO);
#define SAVE_STACK_POINTERS \
ASSERT(Sp > SpLim); \
- cap->r.rCurrentTSO->sp = Sp
+ cap->r.rCurrentTSO->stackobj->sp = Sp
#define RETURN_TO_SCHEDULER(todo,retcode) \
SAVE_STACK_POINTERS; \
@@ -266,7 +266,7 @@ interpretBCO (Capability* cap)
debugBelch("Sp = %p\n", Sp);
debugBelch("\n" );
- printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
+ printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
debugBelch("\n\n");
);
@@ -381,11 +381,11 @@ interpretBCO (Capability* cap)
debugBelch("Returning: "); printObj(obj);
debugBelch("Sp = %p\n", Sp);
debugBelch("\n" );
- printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
+ printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
debugBelch("\n\n");
);
- IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size));
+ IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size));
switch (get_itbl((StgClosure *)Sp)->type) {
@@ -466,7 +466,7 @@ interpretBCO (Capability* cap)
INTERP_TICK(it_retto_other);
IF_DEBUG(interpreter,
debugBelch("returning to unknown frame -- yielding to sched\n");
- printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
+ printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
);
Sp -= 2;
Sp[1] = (W_)tagged_obj;
@@ -529,8 +529,8 @@ interpretBCO (Capability* cap)
INTERP_TICK(it_retto_other);
IF_DEBUG(interpreter,
debugBelch("returning to unknown frame -- yielding to sched\n");
- printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size);
- );
+ printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
+ );
RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
}
}
View
1  rts/LdvProfile.c
@@ -168,6 +168,7 @@ processHeapClosureForDead( StgClosure *c )
// stack objects
case UPDATE_FRAME:
case CATCH_FRAME:
+ case UNDERFLOW_FRAME:
case STOP_FRAME:
case RET_DYN:
case RET_BCO:
View
12 rts/Messages.c
@@ -98,11 +98,13 @@ executeMessage (Capability *cap, Message *m)
r = throwToMsg(cap, t);
switch (r) {
- case THROWTO_SUCCESS:
+ case THROWTO_SUCCESS: {
// this message is done
- unlockClosure((StgClosure*)m, &stg_MSG_NULL_info);
- tryWakeupThread(cap, t->source);
+ StgTSO *source = t->source;
+ doneWithMsgThrowTo(t);
+ tryWakeupThread(cap, source);
break;
+ }
case THROWTO_BLOCKED:
// unlock the message
unlockClosure((StgClosure*)m, &stg_MSG_THROWTO_info);
@@ -203,7 +205,7 @@ nat messageBlackHole(Capability *cap, MessageBlackHole *msg)
else if (info == &stg_TSO_info)
{
- owner = deRefTSO((StgTSO *)p);
+ owner = (StgTSO*)p;
#ifdef THREADED_RTS
if (owner->cap != cap) {
@@ -265,7 +267,7 @@ nat messageBlackHole(Capability *cap, MessageBlackHole *msg)
ASSERT(bq->bh == bh);
- owner = deRefTSO(bq->owner);
+ owner = bq->owner;
ASSERT(owner != END_TSO_QUEUE);
View
11 rts/Messages.h
@@ -15,4 +15,15 @@ void executeMessage (Capability *cap, Message *m);
void sendMessage (Capability *from_cap, Capability *to_cap, Message *msg);
#endif
+#include "Capability.h"
+#include "Updates.h" // for DEBUG_FILL_SLOP
+
+INLINE_HEADER void
+doneWithMsgThrowTo (MessageThrowTo *m)
+{
+ OVERWRITING_CLOSURE((StgClosure*)m);
+ unlockClosure((StgClosure*)m, &stg_MSG_NULL_info);
+ LDV_RECORD_CREATE(m);
+}
+
#include "EndPrivate.h"
View
81 rts/PrimOps.cmm
@@ -634,11 +634,6 @@ stg_threadStatuszh
W_ ret;
tso = R1;
- loop:
- if (TO_W_(StgTSO_what_next(tso)) == ThreadRelocated) {
- tso = StgTSO__link(tso);
- goto loop;
- }
what_next = TO_W_(StgTSO_what_next(tso));
why_blocked = TO_W_(StgTSO_why_blocked(tso));
@@ -939,9 +934,9 @@ stg_retryzh
// Find the enclosing ATOMICALLY_FRAME or CATCH_RETRY_FRAME
retry_pop_stack:
- StgTSO_sp(CurrentTSO) = Sp;
- (frame_type) = foreign "C" findRetryFrameHelper(CurrentTSO "ptr") [];
- Sp = StgTSO_sp(CurrentTSO);
+ SAVE_THREAD_STATE();
+ (frame_type) = foreign "C" findRetryFrameHelper(MyCapability(), CurrentTSO "ptr") [];
+ LOAD_THREAD_STATE();
frame = Sp;
trec = StgTSO_trec(CurrentTSO);
outer = StgTRecHeader_enclosing_trec(trec);
@@ -1138,13 +1133,13 @@ stg_newMVarzh
}
-#define PerformTake(tso, value) \
- W_[StgTSO_sp(tso) + WDS(1)] = value; \
- W_[StgTSO_sp(tso) + WDS(0)] = stg_gc_unpt_r1_info;
+#define PerformTake(stack, value) \
+ W_[StgStack_sp(stack) + WDS(1)] = value; \
+ W_[StgStack_sp(stack) + WDS(0)] = stg_gc_unpt_r1_info;
-#define PerformPut(tso,lval) \
- StgTSO_sp(tso) = StgTSO_sp(tso) + WDS(3); \
- lval = W_[StgTSO_sp(tso) - WDS(1)];
+#define PerformPut(stack,lval) \
+ StgStack_sp(stack) = StgStack_sp(stack) + WDS(3); \
+ lval = W_[StgStack_sp(stack) - WDS(1)];
stg_takeMVarzh
{
@@ -1224,24 +1219,20 @@ loop:
StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
}
-loop2:
- if (TO_W_(StgTSO_what_next(tso)) == ThreadRelocated) {
- tso = StgTSO__link(tso);
- goto loop2;
- }
-
ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16);
ASSERT(StgTSO_block_info(tso) == mvar);
// actually perform the putMVar for the thread that we just woke up
- PerformPut(tso,StgMVar_value(mvar));
+ W_ stack;
+ stack = StgTSO_stackobj(tso);
+ PerformPut(stack, StgMVar_value(mvar));
// indicate that the MVar operation has now completed.
StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
// no need to mark the TSO dirty, we have only written END_TSO_QUEUE.
- foreign "C" tryWakeupThread_(MyCapability() "ptr", tso) [];
+ foreign "C" tryWakeupThread(MyCapability() "ptr", tso) [];
unlockClosure(mvar, stg_MVAR_DIRTY_info);
RET_P(val);
@@ -1303,24 +1294,20 @@ loop:
StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
}
-loop2:
- if (TO_W_(StgTSO_what_next(tso)) == ThreadRelocated) {
- tso = StgTSO__link(tso);
- goto loop2;
- }
-
ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16);
ASSERT(StgTSO_block_info(tso) == mvar);
// actually perform the putMVar for the thread that we just woke up
- PerformPut(tso,StgMVar_value(mvar));
+ W_ stack;
+ stack = StgTSO_stackobj(tso);
+ PerformPut(stack, StgMVar_value(mvar));
// indicate that the MVar operation has now completed.
StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
// no need to mark the TSO dirty, we have only written END_TSO_QUEUE.
- foreign "C" tryWakeupThread_(MyCapability() "ptr", tso) [];
+ foreign "C" tryWakeupThread(MyCapability() "ptr", tso) [];
unlockClosure(mvar, stg_MVAR_DIRTY_info);
RET_NP(1,val);
@@ -1395,26 +1382,22 @@ loop:
StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
}
-loop2:
- if (TO_W_(StgTSO_what_next(tso)) == ThreadRelocated) {
- tso = StgTSO__link(tso);
- goto loop2;
- }
-
ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16);
ASSERT(StgTSO_block_info(tso) == mvar);
// actually perform the takeMVar
- PerformTake(tso, val);
+ W_ stack;
+ stack = StgTSO_stackobj(tso);
+ PerformTake(stack, val);
// indicate that the MVar operation has now completed.
StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
-
- if (TO_W_(StgTSO_dirty(tso)) == 0) {
- foreign "C" dirty_TSO(MyCapability() "ptr", tso "ptr") [];
+
+ if (TO_W_(StgStack_dirty(stack)) == 0) {
+ foreign "C" dirty_STACK(MyCapability() "ptr", stack "ptr") [];
}
- foreign "C" tryWakeupThread_(MyCapability() "ptr", tso) [];
+ foreign "C" tryWakeupThread(MyCapability() "ptr", tso) [];
unlockClosure(mvar, stg_MVAR_DIRTY_info);
jump %ENTRY_CODE(Sp(0));
@@ -1468,26 +1451,22 @@ loop:
StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
}
-loop2:
- if (TO_W_(StgTSO_what_next(tso)) == ThreadRelocated) {
- tso = StgTSO__link(tso);
- goto loop2;
- }
-
ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16);
ASSERT(StgTSO_block_info(tso) == mvar);
// actually perform the takeMVar
- PerformTake(tso, val);
+ W_ stack;
+ stack = StgTSO_stackobj(tso);
+ PerformTake(stack, val);
// indicate that the MVar operation has now completed.
StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
- if (TO_W_(StgTSO_dirty(tso)) == 0) {
- foreign "C" dirty_TSO(MyCapability() "ptr", tso "ptr") [];
+ if (TO_W_(StgStack_dirty(stack)) == 0) {
+ foreign "C" dirty_STACK(MyCapability() "ptr", stack "ptr") [];
}
- foreign "C" tryWakeupThread_(MyCapability() "ptr", tso) [];
+ foreign "C" tryWakeupThread(MyCapability() "ptr", tso) [];
unlockClosure(mvar, stg_MVAR_DIRTY_info);
RET_N(1);
View
23 rts/Printer.c
@@ -276,6 +276,15 @@ printClosure( StgClosure *obj )
break;
}
+ case UNDERFLOW_FRAME:
+ {
+ StgUnderflowFrame* u = (StgUnderflowFrame*)obj;
+ debugBelch("UNDERFLOW_FRAME(");
+ printPtr((StgPtr)u->next_chunk);
+ debugBelch(")\n");
+ break;
+ }
+
case STOP_FRAME:
{
StgStopFrame* u = (StgStopFrame*)obj;
@@ -461,13 +470,11 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
case UPDATE_FRAME:
case CATCH_FRAME:
- printObj((StgClosure*)sp);
+ case UNDERFLOW_FRAME:
+ case STOP_FRAME:
+ printObj((StgClosure*)sp);
continue;
- case STOP_FRAME:
- printObj((StgClosure*)sp);
- return;
-
case RET_DYN:
{
StgRetDyn* r;
@@ -559,7 +566,8 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
void printTSO( StgTSO *tso )
{
- printStackChunk( tso->sp, tso->stack+tso->stack_size);
+ printStackChunk( tso->stackobj->sp,
+ tso->stackobj->stack+tso->stackobj->stack_size);
}
/* --------------------------------------------------------------------------
@@ -1039,7 +1047,6 @@ char *what_next_strs[] = {
[ThreadRunGHC] = "ThreadRunGHC",
[ThreadInterpret] = "ThreadInterpret",
[ThreadKilled] = "ThreadKilled",
- [ThreadRelocated] = "ThreadRelocated",
[ThreadComplete] = "ThreadComplete"
};
@@ -1102,6 +1109,7 @@ char *closure_type_names[] = {
[RET_FUN] = "RET_FUN",
[UPDATE_FRAME] = "UPDATE_FRAME",
[CATCH_FRAME] = "CATCH_FRAME",
+ [UNDERFLOW_FRAME] = "UNDERFLOW_FRAME",
[STOP_FRAME] = "STOP_FRAME",
[BLACKHOLE] = "BLACKHOLE",
[BLOCKING_QUEUE] = "BLOCKING_QUEUE",
@@ -1118,6 +1126,7 @@ char *closure_type_names[] = {
[PRIM] = "PRIM",
[MUT_PRIM] = "MUT_PRIM",
[TSO] = "TSO",
+ [STACK] = "STACK",
[TREC_CHUNK] = "TREC_CHUNK",
[ATOMICALLY_FRAME] = "ATOMICALLY_FRAME",
[CATCH_RETRY_FRAME] = "CATCH_RETRY_FRAME",
View
24 rts/ProfHeap.c
@@ -947,19 +947,35 @@ heapCensusChain( Census *census, bdescr *bd )
prim = rtsTrue;
#ifdef PROFILING
if (RtsFlags.ProfFlags.includeTSOs) {
- size = tso_sizeW((StgTSO *)p);
+ size = sizeofW(StgTSO);
break;
} else {
// Skip this TSO and move on to the next object
- p += tso_sizeW((StgTSO *)p);
+ p += sizeofW(StgTSO);
continue;
}
#else
- size = tso_sizeW((StgTSO *)p);
+ size = sizeofW(StgTSO);
break;
#endif
- case TREC_CHUNK:
+ case STACK:
+ prim = rtsTrue;
+#ifdef PROFILING
+ if (RtsFlags.ProfFlags.includeTSOs) {
+ size = stack_sizeW((StgStack*)p);
+ break;
+ } else {
+ // Skip this TSO and move on to the next object
+ p += stack_sizeW((StgStack*)p);
+ continue;
+ }
+#else
+ size = stack_sizeW((StgStack*)p);
+ break;
+#endif
+
+ case TREC_CHUNK:
prim = rtsTrue;
size = sizeofW(StgTRecChunk);
break;
View
1  rts/ProfHeap.h
@@ -14,7 +14,6 @@
void heapCensus (void);
nat initHeapProfiling (void);
void endHeapProfiling (void);
-void LDV_recordDead (StgClosure *c, nat size);
rtsBool strMatchesSelector (char* str, char* sel);
#include "EndPrivate.h"
View
145 rts/RaiseAsync.c
@@ -23,11 +23,11 @@
#include "win32/IOManager.h"
#endif
-static void raiseAsync (Capability *cap,
- StgTSO *tso,
- StgClosure *exception,
- rtsBool stop_at_atomically,
- StgUpdateFrame *stop_here);
+static StgTSO* raiseAsync (Capability *cap,
+ StgTSO *tso,
+ StgClosure *exception,
+ rtsBool stop_at_atomically,
+ StgUpdateFrame *stop_here);
static void removeFromQueues(Capability *cap, StgTSO *tso);
@@ -61,11 +61,9 @@ static void
throwToSingleThreaded__ (Capability *cap, StgTSO *tso, StgClosure *exception,
rtsBool stop_at_atomically, StgUpdateFrame *stop_here)
{
- tso = deRefTSO(tso);
-
// Thread already dead?
if (tso->what_next == ThreadComplete || tso->what_next == ThreadKilled) {
- return;
+ return;
}
// Remove it from any blocking queues
@@ -81,13 +79,13 @@ throwToSingleThreaded (Capability *cap, StgTSO *tso, StgClosure *exception)
}
void
-throwToSingleThreaded_ (Capability *cap, StgTSO *tso, StgClosure *exception,
+throwToSingleThreaded_ (Capability *cap, StgTSO *tso, StgClosure *exception,
rtsBool stop_at_atomically)
{
throwToSingleThreaded__ (cap, tso, exception, stop_at_atomically, NULL);
}
-void
+void // cannot return a different TSO
suspendComputation (Capability *cap, StgTSO *tso, StgUpdateFrame *stop_here)
{
throwToSingleThreaded__ (cap, tso, NULL, rtsFalse, stop_here);
@@ -192,9 +190,6 @@ throwToMsg (Capability *cap, MessageThrowTo *msg)
check_target:
ASSERT(target != END_TSO_QUEUE);
- // follow ThreadRelocated links in the target first
- target = deRefTSO(target);
-
// Thread already dead?
if (target->what_next == ThreadComplete
|| target->what_next == ThreadKilled) {
@@ -268,7 +263,7 @@ throwToMsg (Capability *cap, MessageThrowTo *msg)
// might as well just do it now. The message will
// be a no-op when it arrives.
unlockClosure((StgClosure*)m, i);
- tryWakeupThread_(cap, target);
+ tryWakeupThread(cap, target);
goto retry;
}
@@ -286,7 +281,7 @@ throwToMsg (Capability *cap, MessageThrowTo *msg)
}
// nobody else can wake up this TSO after we claim the message
- unlockClosure((StgClosure*)m, &stg_MSG_NULL_info);
+ doneWithMsgThrowTo(m);
raiseAsync(cap, target, msg->exception, rtsFalse, NULL);
return THROWTO_SUCCESS;
@@ -315,12 +310,7 @@ throwToMsg (Capability *cap, MessageThrowTo *msg)
info = lockClosure((StgClosure *)mvar);
- if (target->what_next == ThreadRelocated) {
- target = target->_link;
- unlockClosure((StgClosure *)mvar,info);
- goto retry;
- }
- // we have the MVar, let's check whether the thread
+ // we have the MVar, let's check whether the thread
// is still blocked on the same MVar.
if (target->why_blocked != BlockedOnMVar
|| (StgMVar *)target->block_info.closure != mvar) {
@@ -334,7 +324,7 @@ throwToMsg (Capability *cap, MessageThrowTo *msg)
// thread now anyway and ignore the message when it
// arrives.
unlockClosure((StgClosure *)mvar, info);
- tryWakeupThread_(cap, target);
+ tryWakeupThread(cap, target);
goto retry;
}
@@ -505,7 +495,8 @@ maybePerformBlockedException (Capability *cap, StgTSO *tso)
{
MessageThrowTo *msg;
const StgInfoTable *i;
-
+ StgTSO *source;
+
if (tso->what_next == ThreadComplete || tso->what_next == ThreadFinished) {
if (tso->blocked_exceptions != END_BLOCKED_EXCEPTIONS_QUEUE) {
awakenBlockedExceptionQueue(cap,tso);
@@ -537,8 +528,9 @@ maybePerformBlockedException (Capability *cap, StgTSO *tso)
}
throwToSingleThreaded(cap, msg->target, msg->exception);
- unlockClosure((StgClosure*)msg,&stg_MSG_NULL_info);
- tryWakeupThread(cap, msg->source);
+ source = msg->source;
+ doneWithMsgThrowTo(msg);
+ tryWakeupThread(cap, source);
return 1;
}
return 0;
@@ -552,13 +544,15 @@ awakenBlockedExceptionQueue (Capability *cap, StgTSO *tso)
{
MessageThrowTo *msg;
const StgInfoTable *i;
+ StgTSO *source;
for (msg = tso->blocked_exceptions; msg != END_BLOCKED_EXCEPTIONS_QUEUE;
msg = (MessageThrowTo*)msg->link) {
i = lockClosure((StgClosure *)msg);
if (i != &stg_MSG_NULL_info) {
- unlockClosure((StgClosure *)msg,&stg_MSG_NULL_info);
- tryWakeupThread(cap, msg->source);
+ source = msg->source;
+ doneWithMsgThrowTo(msg);
+ tryWakeupThread(cap, source);
} else {
unlockClosure((StgClosure *)msg,i);
}
@@ -653,7 +647,7 @@ removeFromQueues(Capability *cap, StgTSO *tso)
// ASSERT(m->header.info == &stg_WHITEHOLE_info);
// unlock and revoke it at the same time
- unlockClosure((StgClosure*)m,&stg_MSG_NULL_info);
+ doneWithMsgThrowTo(m);
break;
}
@@ -724,7 +718,7 @@ removeFromQueues(Capability *cap, StgTSO *tso)
*
* -------------------------------------------------------------------------- */
-static void
+static StgTSO *
raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
rtsBool stop_at_atomically, StgUpdateFrame *stop_here)
{
@@ -732,6 +726,7 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
StgPtr sp, frame;
StgClosure *updatee;
nat i;
+ StgStack *stack;
debugTraceCap(DEBUG_sched, cap,
"raising exception in thread %ld.", (long)tso->id);
@@ -747,25 +742,21 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
fprintCCS_stderr(tso->prof.CCCS);
}
#endif
- // ASSUMES: the thread is not already complete or dead, or
- // ThreadRelocated. Upper layers should deal with that.
+ // ASSUMES: the thread is not already complete or dead
+ // Upper layers should deal with that.
ASSERT(tso->what_next != ThreadComplete &&
- tso->what_next != ThreadKilled &&
- tso->what_next != ThreadRelocated);
+ tso->what_next != ThreadKilled);
// only if we own this TSO (except that deleteThread() calls this
ASSERT(tso->cap == cap);
- // wake it up
- if (tso->why_blocked != NotBlocked) {
- tso->why_blocked = NotBlocked;
- appendToRunQueue(cap,tso);
- }
+ stack = tso->stackobj;
// mark it dirty; we're about to change its stack.
dirty_TSO(cap, tso);
+ dirty_STACK(cap, stack);
- sp = tso->sp;
+ sp = stack->sp;
if (stop_here != NULL) {
updatee = stop_here->updatee;
@@ -801,10 +792,13 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
//
// 5. If it's a STOP_FRAME, then kill the thread.
//
- // NB: if we pass an ATOMICALLY_FRAME then abort the associated
+ // 6. If it's an UNDERFLOW_FRAME, then continue with the next
+ // stack chunk.
+ //
+ // NB: if we pass an ATOMICALLY_FRAME then abort the associated
// transaction
- info = get_ret_itbl((StgClosure *)frame);
+ info = get_ret_itbl((StgClosure *)frame);
switch (info->i.type) {
@@ -859,12 +853,46 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
continue; //no need to bump frame
}
- case STOP_FRAME:
+ case UNDERFLOW_FRAME:
+ {
+ StgAP_STACK * ap;
+ nat words;
+
+ // First build an AP_STACK consisting of the stack chunk above the
+ // current update frame, with the top word on the stack as the
+ // fun field.
+ //
+ words = frame - sp - 1;
+ ap = (StgAP_STACK *)allocate(cap,AP_STACK_sizeW(words));
+
+ ap->size = words;
+ ap->fun = (StgClosure *)sp[0];
+ sp++;
+ for(i=0; i < (nat)words; ++i) {
+ ap->payload[i] = (StgClosure *)*sp++;
+ }
+
+ SET_HDR(ap,&stg_AP_STACK_NOUPD_info,
+ ((StgClosure *)frame)->header.prof.ccs /* ToDo */);
+ TICK_ALLOC_SE_THK(words+1,0);
+
+ stack->sp = sp;
+ threadStackUnderflow(cap,tso);
+ stack = tso->stackobj;
+ sp = stack->sp;
+
+ sp--;
+ sp[0] = (W_)ap;
+ frame = sp + 1;
+ continue;
+ }
+
+ case STOP_FRAME:
{
// We've stripped the entire stack, the thread is now dead.
tso->what_next = ThreadKilled;
- tso->sp = frame + sizeofW(StgStopFrame);
- return;
+ stack->sp = frame + sizeofW(StgStopFrame);
+ goto done;
}
case CATCH_FRAME:
@@ -906,17 +934,16 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
*/
sp[0] = (W_)raise;
sp[-1] = (W_)&stg_enter_info;
- tso->sp = sp-1;
+ stack->sp = sp-1;
tso->what_next = ThreadRunGHC;
- IF_DEBUG(sanity, checkTSO(tso));
- return;
+ goto done;
}
case ATOMICALLY_FRAME:
if (stop_at_atomically) {
ASSERT(tso->trec->enclosing_trec == NO_TREC);
stmCondemnTransaction(cap, tso -> trec);
- tso->sp = frame - 2;
+ stack->sp = frame - 2;
// The ATOMICALLY_FRAME expects to be returned a
// result from the transaction, which it stores in the
// stack frame. Hence we arrange to return a dummy
@@ -925,10 +952,10 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
// ATOMICALLY_FRAME instance for condemned
// transactions, but I don't fully understand the
// interaction with STM invariants.
- tso->sp[1] = (W_)&stg_NO_TREC_closure;
- tso->sp[0] = (W_)&stg_gc_unpt_r1_info;
- tso->what_next = ThreadRunGHC;
- return;
+ stack->sp[1] = (W_)&stg_NO_TREC_closure;
+ stack->sp[0] = (W_)&stg_gc_unpt_r1_info;
+ tso->what_next = ThreadRunGHC;
+ goto done;
}
// Not stop_at_atomically... fall through and abort the
// transaction.
@@ -950,7 +977,7 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
stmAbortTransaction(cap, trec);
stmFreeAbortedTRec(cap, trec);
tso -> trec = outer;
- break;
+ break;
};
default:
@@ -961,8 +988,16 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
frame += stack_frame_sizeW((StgClosure *)frame);
}
- // if we got here, then we stopped at stop_here
- ASSERT(stop_here != NULL);
+done:
+ IF_DEBUG(sanity, checkTSO(tso));
+
+ // wake it up
+ if (tso->why_blocked != NotBlocked) {
+ tso->why_blocked = NotBlocked;
+ appendToRunQueue(cap,tso);
+ }
+
+ return tso;
}
View
39 rts/RetainerProfile.c
@@ -597,11 +597,13 @@ push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
case AP:
case AP_STACK:
case TSO:
+ case STACK:
case IND_STATIC:
case CONSTR_NOCAF_STATIC:
// stack objects
case UPDATE_FRAME:
case CATCH_FRAME:
+ case UNDERFLOW_FRAME:
case STOP_FRAME:
case RET_DYN:
case RET_BCO:
@@ -925,13 +927,15 @@ pop( StgClosure **c, StgClosure **cp, retainer *r )
case AP:
case AP_STACK:
case TSO:
- case IND_STATIC:
+ case STACK:
+ case IND_STATIC:
case CONSTR_NOCAF_STATIC:
// stack objects
case RET_DYN:
case UPDATE_FRAME:
case CATCH_FRAME:
- case STOP_FRAME:
+ case UNDERFLOW_FRAME:
+ case STOP_FRAME:
case RET_BCO:
case RET_SMALL:
case RET_BIG:
@@ -1001,6 +1005,7 @@ isRetainer( StgClosure *c )
//
// TSOs MUST be retainers: they constitute the set of roots.
case TSO:
+ case STACK:
// mutable objects
case MUT_PRIM:
@@ -1080,6 +1085,7 @@ isRetainer( StgClosure *c )
// legal objects during retainer profiling.
case UPDATE_FRAME:
case CATCH_FRAME:
+ case UNDERFLOW_FRAME:
case STOP_FRAME:
case RET_DYN:
case RET_BCO:
@@ -1257,8 +1263,8 @@ retainSRT (StgClosure **srt, nat srt_bitmap, StgClosure *c, retainer c_child_r)
* RSET(c) and RSET(c_child_r) are valid, i.e., their
* interpretation conforms to the current value of flip (even when they
* are interpreted to be NULL).
- * If *c is TSO, its state is not any of ThreadRelocated, ThreadComplete,
- * or ThreadKilled, which means that its stack is ready to process.
+ * If *c is TSO, its state is not ThreadComplete,or ThreadKilled,
+ * which means that its stack is ready to process.
* Note:
* This code was almost plagiarzied from GC.c! For each pointer,
* retainClosure() is invoked instead of evacuate().
@@ -1291,11 +1297,8 @@ retainStack( StgClosure *c, retainer c_child_r,
// debugBelch("retainStack() called: oldStackBoundary = 0x%x, currentStackBoundary = 0x%x\n", oldStackBoundary, currentStackBoundary);
#endif
- ASSERT(get_itbl(c)->type != TSO ||
- (((StgTSO *)c)->what_next != ThreadRelocated &&
- ((StgTSO *)c)->what_next != ThreadComplete &&
- ((StgTSO *)c)->what_next != ThreadKilled));
-
+ ASSERT(get_itbl(c)->type == STACK);
+
p = stackStart;
while (p < stackEnd) {
info = get_ret_itbl((StgClosure *)p);
@@ -1307,7 +1310,8 @@ retainStack( StgClosure *c, retainer c_child_r,
p += sizeofW(StgUpdateFrame);
continue;
- case STOP_FRAME:
+ case UNDERFLOW_FRAME:
+ case STOP_FRAME:
case CATCH_FRAME:
case CATCH_STM_FRAME:
case CATCH_RETRY_FRAME:
@@ -1560,14 +1564,7 @@ retainClosure( StgClosure *c0, StgClosure *cp0, retainer r0 )
#endif
goto loop;
}
- if (((StgTSO *)c)->what_next == ThreadRelocated) {
-#ifdef DEBUG_RETAINER
- debugBelch("ThreadRelocated encountered in retainClosure()\n");
-#endif
- c = (StgClosure *)((StgTSO *)c)->_link;
- goto inner_loop;
- }
- break;
+ break;
case IND_STATIC:
// We just skip IND_STATIC, so its retainer set is never computed.
@@ -1681,10 +1678,10 @@ retainClosure( StgClosure *c0, StgClosure *cp0, retainer r0 )
// than attempting to save the current position, because doing so
// would be hard.
switch (typeOfc) {
- case TSO:
+ case STACK:
retainStack(c, c_child_r,
- ((StgTSO *)c)->sp,
- ((StgTSO *)c)->stack + ((StgTSO *)c)->stack_size);
+ ((StgStack *)c)->sp,
+ ((StgStack *)c)->stack + ((StgStack *)c)->stack_size);
goto loop;
case PAP:
View
4 rts/RtsAPI.c
@@ -375,8 +375,8 @@ rts_getBool (HaskellObj p)
-------------------------------------------------------------------------- */
INLINE_HEADER void pushClosure (StgTSO *tso, StgWord c) {
- tso->sp--;
- tso->sp[0] = (W_) c;
+ tso->stackobj->sp--;
+ tso->stackobj->sp[0] = (W_) c;
}
StgTSO *
View
34 rts/RtsFlags.c
@@ -69,6 +69,8 @@ void initRtsFlagsDefaults(void)
RtsFlags.GcFlags.maxStkSize = (8 * 1024 * 1024) / sizeof(W_);
RtsFlags.GcFlags.initialStkSize = 1024 / sizeof(W_);
+ RtsFlags.GcFlags.stkChunkSize = (32 * 1024) / sizeof(W_);
+ RtsFlags.GcFlags.stkChunkBufferSize = (1 * 1024) / sizeof(W_);
RtsFlags.GcFlags.minAllocAreaSize = (512 * 1024) / BLOCK_SIZE;
RtsFlags.GcFlags.minOldGenSize = (1024 * 1024) / BLOCK_SIZE;
@@ -194,7 +196,9 @@ usage_text[] = {
" --info Print information about the RTS used by this program",
"",
" -K<size> Sets the maximum stack size (default 8M) Egs: -K32k -K512k",
-" -k<size> Sets the initial thread stack size (default 1k) Egs: -k4k -k2m",
+" -ki<size> Sets the initial thread stack size (default 1k) Egs: -ki4k -ki2m",
+" -kc<size> Sets the stack chunk size (default 32k)",
+" -kb<size> Sets the stack chunk buffer size (default 1k)",
"",
" -A<size> Sets the minimum allocation area size (default 512k) Egs: -A1m -A10k",
" -M<size> Sets the maximum heap size (default unlimited) Egs: -M256k -M1G",
@@ -693,15 +697,31 @@ error = rtsTrue;
case 'K':
RtsFlags.GcFlags.maxStkSize =
- decodeSize(rts_argv[arg], 2, 1, HS_WORD_MAX) / sizeof(W_);
+ decodeSize(rts_argv[arg], 2, sizeof(W_), HS_WORD_MAX) / sizeof(W_);
break;
case 'k':
+ switch(rts_argv[arg][2]) {
+ case 'c':
+ RtsFlags.GcFlags.stkChunkSize =
+ decodeSize(rts_argv[arg], 3, sizeof(W_), HS_WORD_MAX) / sizeof(W_);
+ break;
+ case 'b':
+ RtsFlags.GcFlags.stkChunkBufferSize =
+ decodeSize(rts_argv[arg], 3, sizeof(W_), HS_WORD_MAX) / sizeof(W_);
+ break;
+ case 'i':
+ RtsFlags.GcFlags.initialStkSize =
+ decodeSize(rts_argv[arg], 3, sizeof(W_), HS_WORD_MAX) / sizeof(W_);
+ break;
+ default:
RtsFlags.GcFlags.initialStkSize =
- decodeSize(rts_argv[arg], 2, 1, HS_WORD_MAX) / sizeof(W_);
+ decodeSize(rts_argv[arg], 2, sizeof(W_), HS_WORD_MAX) / sizeof(W_);
break;
+ }
+ break;
- case 'M':
+ case 'M':
RtsFlags.GcFlags.maxHeapSize =
decodeSize(rts_argv[arg], 2, BLOCK_SIZE, HS_WORD_MAX) / BLOCK_SIZE;
/* user give size in *bytes* but "maxHeapSize" is in *blocks* */
@@ -1203,6 +1223,12 @@ error = rtsTrue;
RtsFlags.ProfFlags.profileIntervalTicks = 0;
}
+ if (RtsFlags.GcFlags.stkChunkBufferSize >
+ RtsFlags.GcFlags.stkChunkSize / 2) {
+ errorBelch("stack chunk buffer size (-kb) must be less than 50%% of the stack chunk size (-kc)");
+ error = rtsTrue;
+ }
+
if (error) {
const char **p;
View
283 rts/Schedule.c
@@ -140,9 +140,7 @@ static void scheduleActivateSpark(Capability *cap);
#endif
static void schedulePostRunThread(Capability *cap, StgTSO *t);
static rtsBool scheduleHandleHeapOverflow( Capability *cap, StgTSO *t );
-static void scheduleHandleStackOverflow( Capability *cap, Task *task,
- StgTSO *t);
-static rtsBool scheduleHandleYield( Capability *cap, StgTSO *t,
+static rtsBool scheduleHandleYield( Capability *cap, StgTSO *t,
nat prev_what_next );
static void scheduleHandleThreadBlocked( StgTSO *t );
static rtsBool scheduleHandleThreadFinished( Capability *cap, Task *task,
@@ -151,9 +149,6 @@ static rtsBool scheduleNeedHeapProfile(rtsBool ready_to_gc);
static Capability *scheduleDoGC(Capability *cap, Task *task,
rtsBool force_major);
-static StgTSO *threadStackOverflow(Capability *cap, StgTSO *tso);
-static StgTSO *threadStackUnderflow(Capability *cap, Task *task, StgTSO *tso);
-
static void deleteThread (Capability *cap, StgTSO *tso);
static void deleteAllThreads (Capability *cap);
@@ -426,6 +421,7 @@ schedule (Capability *initialCapability, Task *task)
cap->in_haskell = rtsTrue;
dirty_TSO(cap,t);
+ dirty_STACK(cap,t->stackobj);
#if defined(THREADED_RTS)
if (recent_activity == ACTIVITY_DONE_GC) {
@@ -503,10 +499,6 @@ schedule (Capability *initialCapability, Task *task)
schedulePostRunThread(cap,t);
- if (ret != StackOverflow) {
- t = threadStackUnderflow(cap,task,t);
- }
-
ready_to_gc = rtsFalse;
switch (ret) {
@@ -515,8 +507,11 @@ schedule (Capability *initialCapability, Task *task)
break;
case StackOverflow:
- scheduleHandleStackOverflow(cap,task,t);
- break;
+ // just adjust the stack for this thread, then pop it back
+ // on the run queue.
+ threadStackOverflow(cap, t);
+ pushOnRunQueue(cap,t);
+ break;
case ThreadYielding:
if (scheduleHandleYield(cap, t, prev_what_next)) {
@@ -729,8 +724,7 @@ schedulePushWork(Capability *cap USED_IF_THREADS,
for (; t != END_TSO_QUEUE; t = next) {
next = t->_link;
t->_link = END_TSO_QUEUE;
- if (t->what_next == ThreadRelocated
- || t->bound == task->incall // don't move my bound thread
+ if (t->bound == task->incall // don't move my bound thread
|| tsoLocked(t)) { // don't move a locked thread
setTSOLink(cap, prev, t);
setTSOPrev(cap, t, prev);
@@ -1098,30 +1092,6 @@ scheduleHandleHeapOverflow( Capability *cap, StgTSO *t )
}
/* -----------------------------------------------------------------------------
- * Handle a thread that returned to the scheduler with ThreadStackOverflow
- * -------------------------------------------------------------------------- */
-
-static void
-scheduleHandleStackOverflow (Capability *cap, Task *task, StgTSO *t)
-{
- /* just adjust the stack for this thread, then pop it back
- * on the run queue.
- */
- {
- /* enlarge the stack */
- StgTSO *new_t = threadStackOverflow(cap, t);
-
- /* The TSO attached to this Task may have moved, so update the
- * pointer to it.
- */
- if (task->incall->tso == t) {
- task->incall->tso = new_t;
- }
- pushOnRunQueue(cap,new_t);
- }
-}
-
-/* -----------------------------------------------------------------------------
* Handle a thread that returned to the scheduler with ThreadYielding
* -------------------------------------------------------------------------- */
@@ -1241,8 +1211,8 @@ scheduleHandleThreadFinished (Capability *cap STG_UNUSED, Task *task, StgTSO *t)
if (t->what_next == ThreadComplete) {
if (task->incall->ret) {
- // NOTE: return val is tso->sp[1] (see StgStartup.hc)
- *(task->incall->ret) = (StgClosure *)task->incall->tso->sp[1];
+ // NOTE: return val is stack->sp[1] (see StgStartup.hc)
+ *(task->incall->ret) = (StgClosure *)task->incall->tso->stackobj->sp[1];
}
task->incall->stat = Success;
} else {
@@ -1578,10 +1548,7 @@ forkProcess(HsStablePtr *entry
for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
for (t = generations[g].threads; t != END_TSO_QUEUE; t = next) {
- if (t->what_next == ThreadRelocated) {
- next = t->_link;
- } else {
- next = t->global_link;
+ next = t->global_link;
// don't allow threads to catch the ThreadKilled
// exception, but we do want to raiseAsync() because these
// threads may be evaluating thunks that we need later.
@@ -1593,7 +1560,6 @@ forkProcess(HsStablePtr *entry
// won't get a chance to exit in the usual way (see
// also scheduleHandleThreadFinished).
t->bound = NULL;
- }
}
}
@@ -1661,12 +1627,8 @@ deleteAllThreads ( Capability *cap )
debugTrace(DEBUG_sched,"deleting all threads");
for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
for (t = generations[g].threads; t != END_TSO_QUEUE; t = next) {
- if (t->what_next == ThreadRelocated) {
- next = t->_link;
- } else {
next = t->global_link;
deleteThread(cap,t);
- }
}
}
@@ -1850,6 +1812,7 @@ resumeThread (void *task_)
/* We might have GC'd, mark the TSO dirty again */
dirty_TSO(cap,tso);
+ dirty_STACK(cap,tso->stackobj);
IF_DEBUG(sanity, checkTSO(tso));
@@ -2108,189 +2071,6 @@ performMajorGC(void)
performGC_(rtsTrue);
}
-/* -----------------------------------------------------------------------------
- Stack overflow
-
- If the thread has reached its maximum stack size, then raise the
- StackOverflow exception in the offending thread. Otherwise
- relocate the TSO into a larger chunk of memory and adjust its stack
- size appropriately.
- -------------------------------------------------------------------------- */
-
-static StgTSO *
-threadStackOverflow(Capability *cap, StgTSO *tso)
-{
- nat new_stack_size, stack_words;
- lnat new_tso_size;
- StgPtr new_sp;
- StgTSO *dest;
-
- IF_DEBUG(sanity,checkTSO(tso));
-
- if (tso->stack_size >= tso->max_stack_size
- && !(tso->flags & TSO_BLOCKEX)) {
- // NB. never raise a StackOverflow exception if the thread is
- // inside Control.Exceptino.block. It is impractical to protect
- // against stack overflow exceptions, since virtually anything
- // can raise one (even 'catch'), so this is the only sensible
- // thing to do here. See bug #767.
- //
-
- if (tso->flags & TSO_SQUEEZED) {
- return tso;
- }
- // #3677: In a stack overflow situation, stack squeezing may
- // reduce the stack size, but we don't know whether it has been
- // reduced enough for the stack check to succeed if we try
- // again. Fortunately stack squeezing is idempotent, so all we
- // need to do is record whether *any* squeezing happened. If we
- // are at the stack's absolute -K limit, and stack squeezing
- // happened, then we try running the thread again. The
- // TSO_SQUEEZED flag is set by threadPaused() to tell us whether
- // squeezing happened or not.
-
- debugTrace(DEBUG_gc,
- "threadStackOverflow of TSO %ld (%p): stack too large (now %ld; max is %ld)",
- (long)tso->id, tso, (long)tso->stack_size, (long)tso->max_stack_size);
- IF_DEBUG(gc,
- /* If we're debugging, just print out the top of the stack */
- printStackChunk(tso->sp, stg_min(tso->stack+tso->stack_size,
- tso->sp+64)));
-
- // Send this thread the StackOverflow exception
- throwToSingleThreaded(cap, tso, (StgClosure *)stackOverflow_closure);
- return tso;
- }
-
-
- // We also want to avoid enlarging the stack if squeezing has
- // already released some of it. However, we don't want to get into
- // a pathalogical situation where a thread has a nearly full stack
- // (near its current limit, but not near the absolute -K limit),
- // keeps allocating a little bit, squeezing removes a little bit,
- // and then it runs again. So to avoid this, if we squeezed *and*
- // there is still less than BLOCK_SIZE_W words free, then we enlarge
- // the stack anyway.
- if ((tso->flags & TSO_SQUEEZED) &&
- ((W_)(tso->sp - tso->stack) >= BLOCK_SIZE_W)) {
- return tso;
- }
-
- /* Try to double the current stack size. If that takes us over the
- * maximum stack size for this thread, then use the maximum instead
- * (that is, unless we're already at or over the max size and we
- * can't raise the StackOverflow exception (see above), in which
- * case just double the size). Finally round up so the TSO ends up as
- * a whole number of blocks.
- */
- if (tso->stack_size >= tso->max_stack_size) {
- new_stack_size = tso->stack_size * 2;
- } else {
- new_stack_size = stg_min(tso->stack_size * 2, tso->max_stack_size);
- }
- new_tso_size = (lnat)BLOCK_ROUND_UP(new_stack_size * sizeof(W_) +
- TSO_STRUCT_SIZE)/sizeof(W_);
- new_tso_size = round_to_mblocks(new_tso_size); /* Be MBLOCK-friendly */
- new_stack_size = new_tso_size - TSO_STRUCT_SIZEW;
-
- debugTrace(DEBUG_sched,
- "increasing stack size from %ld words to %d.",
- (long)tso->stack_size, new_stack_size);
-
- dest = (StgTSO *)allocate(cap,new_tso_size);
- TICK_ALLOC_TSO(new_stack_size,0);
-
- /* copy the TSO block and the old stack into the new area */
- memcpy(dest,tso,TSO_STRUCT_SIZE);
- stack_words = tso->stack + tso->stack_size - tso->sp;
- new_sp = (P_)dest + new_tso_size - stack_words;
- memcpy(new_sp, tso->sp, stack_words * sizeof(W_));
-
- /* relocate the stack pointers... */
- dest->sp = new_sp;
- dest->stack_size = new_stack_size;
-
- /* Mark the old TSO as relocated. We have to check for relocated
- * TSOs in the garbage collector and any primops that deal with TSOs.
- *
- * It's important to set the sp value to just beyond the end
- * of the stack, so we don't attempt to scavenge any part of the
- * dead TSO's stack.
- */
- setTSOLink(cap,tso,dest);
- write_barrier(); // other threads seeing ThreadRelocated will look at _link
- tso->what_next = ThreadRelocated;
- tso->sp = (P_)&(tso->stack[tso->stack_size]);
- tso->why_blocked = NotBlocked;
-
- IF_DEBUG(sanity,checkTSO(dest));
-#if 0
- IF_DEBUG(scheduler,printTSO(dest));
-#endif
-
- return dest;
-}
-
-static StgTSO *
-threadStackUnderflow (Capability *cap, Task *task, StgTSO *tso)
-{
- bdescr *bd, *new_bd;
- lnat free_w, tso_size_w;
- StgTSO *new_tso;
-
- tso_size_w = tso_sizeW(tso);
-
- if (tso_size_w < MBLOCK_SIZE_W ||
- // TSO is less than 2 mblocks (since the first mblock is
- // shorter than MBLOCK_SIZE_W)
- (tso_size_w - BLOCKS_PER_MBLOCK*BLOCK_SIZE_W) % MBLOCK_SIZE_W != 0 ||
- // or TSO is not a whole number of megablocks (ensuring
- // precondition of splitLargeBlock() below)
- (tso_size_w <= round_up_to_mblocks(RtsFlags.GcFlags.initialStkSize)) ||
- // or TSO is smaller than the minimum stack size (rounded up)
- (nat)(tso->stack + tso->stack_size - tso->sp) > tso->stack_size / 4)
- // or stack is using more than 1/4 of the available space
- {
- // then do nothing
- return tso;
- }
-
- // this is the number of words we'll free
- free_w = round_to_mblocks(tso_size_w/2);
-
- bd = Bdescr((StgPtr)tso);
- new_bd = splitLargeBlock(bd, free_w / BLOCK_SIZE_W);
- bd->free = bd->start + TSO_STRUCT_SIZEW;
-
- new_tso = (StgTSO *)new_bd->start;
- memcpy(new_tso,tso,TSO_STRUCT_SIZE);
- new_tso->stack_size = new_bd->free - new_tso->stack;
-
- // The original TSO was dirty and probably on the mutable
- // list. The new TSO is not yet on the mutable list, so we better
- // put it there.
- new_tso->dirty = 0;
- new_tso->flags &= ~TSO_LINK_DIRTY;
- dirty_TSO(cap, new_tso);
-
- debugTrace(DEBUG_sched, "thread %ld: reducing TSO size from %lu words to %lu",
- (long)tso->id, tso_size_w, tso_sizeW(new_tso));
-
- tso->_link = new_tso; // no write barrier reqd: same generation
- write_barrier(); // other threads seeing ThreadRelocated will look at _link
- tso->what_next = ThreadRelocated;
-
- // The TSO attached to this Task may have moved, so update the
- // pointer to it.
- if (task->incall->tso == tso) {
- task->incall->tso = new_tso;
- }
-
- IF_DEBUG(sanity,checkTSO(new_tso));
-
- return new_tso;
-}
-
/* ---------------------------------------------------------------------------
Interrupt execution
- usually called inside a signal handler so it mustn't do anything fancy.
@@ -2337,7 +2117,7 @@ void wakeUpRts(void)
exception.
-------------------------------------------------------------------------- */
-static void
+static void
deleteThread (Capability *cap STG_UNUSED, StgTSO *tso)
{
// NOTE: must only be called on a TSO that we have exclusive
@@ -2347,12 +2127,12 @@ deleteThread (Capability *cap STG_UNUSED, StgTSO *tso)
if (tso->why_blocked != BlockedOnCCall &&
tso->why_blocked != BlockedOnCCall_Interruptible) {
- throwToSingleThreaded(tso->cap,tso,NULL);
+ throwToSingleThreaded(tso->cap,tso,NULL);
}
}
#ifdef FORKPROCESS_PRIMOP_SUPPORTED
-static void
+static void
deleteThread_(Capability *cap, StgTSO *tso)
{