Do not copy stack after stack overflow, fixes #8435
[ghc.git] / rts / Threads.c
1 /* ---------------------------------------------------------------------------
2 *
3 * (c) The GHC Team, 2006
4 *
5 * Thread-related functionality
6 *
7 * --------------------------------------------------------------------------*/
8
9 #include "PosixSource.h"
10 #include "Rts.h"
11
12 #include "Capability.h"
13 #include "Updates.h"
14 #include "Threads.h"
15 #include "STM.h"
16 #include "Schedule.h"
17 #include "Trace.h"
18 #include "ThreadLabels.h"
19 #include "Updates.h"
20 #include "Messages.h"
21 #include "RaiseAsync.h"
22 #include "Prelude.h"
23 #include "Printer.h"
24 #include "sm/Sanity.h"
25 #include "sm/Storage.h"
26
27 #include <string.h>
28
29 /* Next thread ID to allocate.
30 * LOCK: sched_mutex
31 */
32 static StgThreadID next_thread_id = 1;
33
34 /* The smallest stack size that makes any sense is:
35 * RESERVED_STACK_WORDS (so we can get back from the stack overflow)
36 * + sizeofW(StgStopFrame) (the stg_stop_thread_info frame)
37 * + 1 (the closure to enter)
38 * + 1 (stg_ap_v_ret)
39 * + 1 (spare slot req'd by stg_ap_v_ret)
40 *
41 * A thread with this stack will bomb immediately with a stack
42 * overflow, which will increase its stack size.
43 */
44 #define MIN_STACK_WORDS (RESERVED_STACK_WORDS + sizeofW(StgStopFrame) + 3)
45
46 /* ---------------------------------------------------------------------------
47 Create a new thread.
48
49 The new thread starts with the given stack size. Before the
50 scheduler can run, however, this thread needs to have a closure
51 (and possibly some arguments) pushed on its stack. See
52 pushClosure() in Schedule.h.
53
54 createGenThread() and createIOThread() (in SchedAPI.h) are
55 convenient packaged versions of this function.
56
57 currently pri (priority) is only used in a GRAN setup -- HWL
58 ------------------------------------------------------------------------ */
59 StgTSO *
60 createThread(Capability *cap, W_ size)
61 {
62 StgTSO *tso;
63 StgStack *stack;
64 nat stack_size;
65
66 /* sched_mutex is *not* required */
67
68 /* catch ridiculously small stack sizes */
69 if (size < MIN_STACK_WORDS + sizeofW(StgStack) + sizeofW(StgTSO)) {
70 size = MIN_STACK_WORDS + sizeofW(StgStack) + sizeofW(StgTSO);
71 }
72
73 /* The size argument we are given includes all the per-thread
74 * overheads:
75 *
76 * - The TSO structure
77 * - The STACK header
78 *
79 * This is so that we can use a nice round power of 2 for the
80 * default stack size (e.g. 1k), and if we're allocating lots of
81 * threads back-to-back they'll fit nicely in a block. It's a bit
82 * of a benchmark hack, but it doesn't do any harm.
83 */
84 stack_size = round_to_mblocks(size - sizeofW(StgTSO));
85 stack = (StgStack *)allocate(cap, stack_size);
86 TICK_ALLOC_STACK(stack_size);
87 SET_HDR(stack, &stg_STACK_info, cap->r.rCCCS);
88 stack->stack_size = stack_size - sizeofW(StgStack);
89 stack->sp = stack->stack + stack->stack_size;
90 stack->dirty = 1;
91
92 tso = (StgTSO *)allocate(cap, sizeofW(StgTSO));
93 TICK_ALLOC_TSO();
94 SET_HDR(tso, &stg_TSO_info, CCS_SYSTEM);
95
96 // Always start with the compiled code evaluator
97 tso->what_next = ThreadRunGHC;
98 tso->why_blocked = NotBlocked;
99 tso->block_info.closure = (StgClosure *)END_TSO_QUEUE;
100 tso->blocked_exceptions = END_BLOCKED_EXCEPTIONS_QUEUE;
101 tso->bq = (StgBlockingQueue *)END_TSO_QUEUE;
102 tso->flags = 0;
103 tso->dirty = 1;
104 tso->_link = END_TSO_QUEUE;
105
106 tso->saved_errno = 0;
107 tso->bound = NULL;
108 tso->cap = cap;
109
110 tso->stackobj = stack;
111 tso->tot_stack_size = stack->stack_size;
112
113 tso->trec = NO_TREC;
114
115 #ifdef PROFILING
116 tso->prof.cccs = CCS_MAIN;
117 #endif
118
119 // put a stop frame on the stack
120 stack->sp -= sizeofW(StgStopFrame);
121 SET_HDR((StgClosure*)stack->sp,
122 (StgInfoTable *)&stg_stop_thread_info,CCS_SYSTEM);
123
124 /* Link the new thread on the global thread list.
125 */
126 ACQUIRE_LOCK(&sched_mutex);
127 tso->id = next_thread_id++; // while we have the mutex
128 tso->global_link = g0->threads;
129 g0->threads = tso;
130 RELEASE_LOCK(&sched_mutex);
131
132 // ToDo: report the stack size in the event?
133 traceEventCreateThread(cap, tso);
134
135 return tso;
136 }
137
138 /* ---------------------------------------------------------------------------
139 * Comparing Thread ids.
140 *
141 * This is used from STG land in the implementation of the
142 * instances of Eq/Ord for ThreadIds.
143 * ------------------------------------------------------------------------ */
144
145 int
146 cmp_thread(StgPtr tso1, StgPtr tso2)
147 {
148 StgThreadID id1 = ((StgTSO *)tso1)->id;
149 StgThreadID id2 = ((StgTSO *)tso2)->id;
150
151 if (id1 < id2) return (-1);
152 if (id1 > id2) return 1;
153 return 0;
154 }
155
156 /* ---------------------------------------------------------------------------
157 * Fetching the ThreadID from an StgTSO.
158 *
159 * This is used in the implementation of Show for ThreadIds.
160 * ------------------------------------------------------------------------ */
161 int
162 rts_getThreadId(StgPtr tso)
163 {
164 return ((StgTSO *)tso)->id;
165 }
166
167 /* -----------------------------------------------------------------------------
168 Remove a thread from a queue.
169 Fails fatally if the TSO is not on the queue.
170 -------------------------------------------------------------------------- */
171
172 rtsBool // returns True if we modified queue
173 removeThreadFromQueue (Capability *cap, StgTSO **queue, StgTSO *tso)
174 {
175 StgTSO *t, *prev;
176
177 prev = NULL;
178 for (t = *queue; t != END_TSO_QUEUE; prev = t, t = t->_link) {
179 if (t == tso) {
180 if (prev) {
181 setTSOLink(cap,prev,t->_link);
182 t->_link = END_TSO_QUEUE;
183 return rtsFalse;
184 } else {
185 *queue = t->_link;
186 t->_link = END_TSO_QUEUE;
187 return rtsTrue;
188 }
189 }
190 }
191 barf("removeThreadFromQueue: not found");
192 }
193
194 rtsBool // returns True if we modified head or tail
195 removeThreadFromDeQueue (Capability *cap,
196 StgTSO **head, StgTSO **tail, StgTSO *tso)
197 {
198 StgTSO *t, *prev;
199 rtsBool flag = rtsFalse;
200
201 prev = NULL;
202 for (t = *head; t != END_TSO_QUEUE; prev = t, t = t->_link) {
203 if (t == tso) {
204 if (prev) {
205 setTSOLink(cap,prev,t->_link);
206 flag = rtsFalse;
207 } else {
208 *head = t->_link;
209 flag = rtsTrue;
210 }
211 t->_link = END_TSO_QUEUE;
212 if (*tail == tso) {
213 if (prev) {
214 *tail = prev;
215 } else {
216 *tail = END_TSO_QUEUE;
217 }
218 return rtsTrue;
219 } else {
220 return flag;
221 }
222 }
223 }
224 barf("removeThreadFromMVarQueue: not found");
225 }
226
227 /* ----------------------------------------------------------------------------
228 tryWakeupThread()
229
230 Attempt to wake up a thread. tryWakeupThread is idempotent: it is
231 always safe to call it too many times, but it is not safe in
232 general to omit a call.
233
234 ------------------------------------------------------------------------- */
235
236 void
237 tryWakeupThread (Capability *cap, StgTSO *tso)
238 {
239 traceEventThreadWakeup (cap, tso, tso->cap->no);
240
241 #ifdef THREADED_RTS
242 if (tso->cap != cap)
243 {
244 MessageWakeup *msg;
245 msg = (MessageWakeup *)allocate(cap,sizeofW(MessageWakeup));
246 SET_HDR(msg, &stg_MSG_TRY_WAKEUP_info, CCS_SYSTEM);
247 msg->tso = tso;
248 sendMessage(cap, tso->cap, (Message*)msg);
249 debugTraceCap(DEBUG_sched, cap, "message: try wakeup thread %ld on cap %d",
250 (W_)tso->id, tso->cap->no);
251 return;
252 }
253 #endif
254
255 switch (tso->why_blocked)
256 {
257 case BlockedOnMVar:
258 case BlockedOnMVarRead:
259 {
260 if (tso->_link == END_TSO_QUEUE) {
261 tso->block_info.closure = (StgClosure*)END_TSO_QUEUE;
262 goto unblock;
263 } else {
264 return;
265 }
266 }
267
268 case BlockedOnMsgThrowTo:
269 {
270 const StgInfoTable *i;
271
272 i = lockClosure(tso->block_info.closure);
273 unlockClosure(tso->block_info.closure, i);
274 if (i != &stg_MSG_NULL_info) {
275 debugTraceCap(DEBUG_sched, cap, "thread %ld still blocked on throwto (%p)",
276 (W_)tso->id, tso->block_info.throwto->header.info);
277 return;
278 }
279
280 // remove the block frame from the stack
281 ASSERT(tso->stackobj->sp[0] == (StgWord)&stg_block_throwto_info);
282 tso->stackobj->sp += 3;
283 goto unblock;
284 }
285
286 case BlockedOnBlackHole:
287 case BlockedOnSTM:
288 case ThreadMigrating:
289 goto unblock;
290
291 default:
292 // otherwise, do nothing
293 return;
294 }
295
296 unblock:
297 // just run the thread now, if the BH is not really available,
298 // we'll block again.
299 tso->why_blocked = NotBlocked;
300 appendToRunQueue(cap,tso);
301
302 // We used to set the context switch flag here, which would
303 // trigger a context switch a short time in the future (at the end
304 // of the current nursery block). The idea is that we have just
305 // woken up a thread, so we may need to load-balance and migrate
306 // threads to other CPUs. On the other hand, setting the context
307 // switch flag here unfairly penalises the current thread by
308 // yielding its time slice too early.
309 //
310 // The synthetic benchmark nofib/smp/chan can be used to show the
311 // difference quite clearly.
312
313 // cap->context_switch = 1;
314 }
315
316 /* ----------------------------------------------------------------------------
317 migrateThread
318 ------------------------------------------------------------------------- */
319
320 void
321 migrateThread (Capability *from, StgTSO *tso, Capability *to)
322 {
323 traceEventMigrateThread (from, tso, to->no);
324 // ThreadMigrating tells the target cap that it needs to be added to
325 // the run queue when it receives the MSG_TRY_WAKEUP.
326 tso->why_blocked = ThreadMigrating;
327 tso->cap = to;
328 tryWakeupThread(from, tso);
329 }
330
331 /* ----------------------------------------------------------------------------
332 awakenBlockedQueue
333
334 wakes up all the threads on the specified queue.
335 ------------------------------------------------------------------------- */
336
337 void
338 wakeBlockingQueue(Capability *cap, StgBlockingQueue *bq)
339 {
340 MessageBlackHole *msg;
341 const StgInfoTable *i;
342
343 ASSERT(bq->header.info == &stg_BLOCKING_QUEUE_DIRTY_info ||
344 bq->header.info == &stg_BLOCKING_QUEUE_CLEAN_info );
345
346 for (msg = bq->queue; msg != (MessageBlackHole*)END_TSO_QUEUE;
347 msg = msg->link) {
348 i = msg->header.info;
349 if (i != &stg_IND_info) {
350 ASSERT(i == &stg_MSG_BLACKHOLE_info);
351 tryWakeupThread(cap,msg->tso);
352 }
353 }
354
355 // overwrite the BQ with an indirection so it will be
356 // collected at the next GC.
357 #if defined(DEBUG) && !defined(THREADED_RTS)
358 // XXX FILL_SLOP, but not if THREADED_RTS because in that case
359 // another thread might be looking at this BLOCKING_QUEUE and
360 // checking the owner field at the same time.
361 bq->bh = 0; bq->queue = 0; bq->owner = 0;
362 #endif
363 OVERWRITE_INFO(bq, &stg_IND_info);
364 }
365
366 // If we update a closure that we know we BLACKHOLE'd, and the closure
367 // no longer points to the current TSO as its owner, then there may be
368 // an orphaned BLOCKING_QUEUE closure with blocked threads attached to
369 // it. We therefore traverse the BLOCKING_QUEUEs attached to the
370 // current TSO to see if any can now be woken up.
371 void
372 checkBlockingQueues (Capability *cap, StgTSO *tso)
373 {
374 StgBlockingQueue *bq, *next;
375 StgClosure *p;
376
377 debugTraceCap(DEBUG_sched, cap,
378 "collision occurred; checking blocking queues for thread %ld",
379 (W_)tso->id);
380
381 for (bq = tso->bq; bq != (StgBlockingQueue*)END_TSO_QUEUE; bq = next) {
382 next = bq->link;
383
384 if (bq->header.info == &stg_IND_info) {
385 // ToDo: could short it out right here, to avoid
386 // traversing this IND multiple times.
387 continue;
388 }
389
390 p = bq->bh;
391
392 if (p->header.info != &stg_BLACKHOLE_info ||
393 ((StgInd *)p)->indirectee != (StgClosure*)bq)
394 {
395 wakeBlockingQueue(cap,bq);
396 }
397 }
398 }
399
400 /* ----------------------------------------------------------------------------
401 updateThunk
402
403 Update a thunk with a value. In order to do this, we need to know
404 which TSO owns (or is evaluating) the thunk, in case we need to
405 awaken any threads that are blocked on it.
406 ------------------------------------------------------------------------- */
407
408 void
409 updateThunk (Capability *cap, StgTSO *tso, StgClosure *thunk, StgClosure *val)
410 {
411 StgClosure *v;
412 StgTSO *owner;
413 const StgInfoTable *i;
414
415 i = thunk->header.info;
416 if (i != &stg_BLACKHOLE_info &&
417 i != &stg_CAF_BLACKHOLE_info &&
418 i != &__stg_EAGER_BLACKHOLE_info &&
419 i != &stg_WHITEHOLE_info) {
420 updateWithIndirection(cap, thunk, val);
421 return;
422 }
423
424 v = ((StgInd*)thunk)->indirectee;
425
426 updateWithIndirection(cap, thunk, val);
427
428 // sometimes the TSO is locked when we reach here, so its header
429 // might be WHITEHOLE. Hence check for the correct owner using
430 // pointer equality first.
431 if ((StgTSO*)v == tso) {
432 return;
433 }
434
435 i = v->header.info;
436 if (i == &stg_TSO_info) {
437 checkBlockingQueues(cap, tso);
438 return;
439 }
440
441 if (i != &stg_BLOCKING_QUEUE_CLEAN_info &&
442 i != &stg_BLOCKING_QUEUE_DIRTY_info) {
443 checkBlockingQueues(cap, tso);
444 return;
445 }
446
447 owner = ((StgBlockingQueue*)v)->owner;
448
449 if (owner != tso) {
450 checkBlockingQueues(cap, tso);
451 } else {
452 wakeBlockingQueue(cap, (StgBlockingQueue*)v);
453 }
454 }
455
456 /* ---------------------------------------------------------------------------
457 * rtsSupportsBoundThreads(): is the RTS built to support bound threads?
458 * used by Control.Concurrent for error checking.
459 * ------------------------------------------------------------------------- */
460
461 HsBool
462 rtsSupportsBoundThreads(void)
463 {
464 #if defined(THREADED_RTS)
465 return HS_BOOL_TRUE;
466 #else
467 return HS_BOOL_FALSE;
468 #endif
469 }
470
471 /* ---------------------------------------------------------------------------
472 * isThreadBound(tso): check whether tso is bound to an OS thread.
473 * ------------------------------------------------------------------------- */
474
475 StgBool
476 isThreadBound(StgTSO* tso USED_IF_THREADS)
477 {
478 #if defined(THREADED_RTS)
479 return (tso->bound != NULL);
480 #endif
481 return rtsFalse;
482 }
483
484 /* -----------------------------------------------------------------------------
485 Stack overflow
486
487 If the thread has reached its maximum stack size, then raise the
488 StackOverflow exception in the offending thread. Otherwise
489 relocate the TSO into a larger chunk of memory and adjust its stack
490 size appropriately.
491 -------------------------------------------------------------------------- */
492
493 void
494 threadStackOverflow (Capability *cap, StgTSO *tso)
495 {
496 StgStack *new_stack, *old_stack;
497 StgUnderflowFrame *frame;
498 W_ chunk_size;
499
500 IF_DEBUG(sanity,checkTSO(tso));
501
502 if (tso->tot_stack_size >= RtsFlags.GcFlags.maxStkSize) {
503 // #3677: In a stack overflow situation, stack squeezing may
504 // reduce the stack size, but we don't know whether it has been
505 // reduced enough for the stack check to succeed if we try
506 // again. Fortunately stack squeezing is idempotent, so all we
507 // need to do is record whether *any* squeezing happened. If we
508 // are at the stack's absolute -K limit, and stack squeezing
509 // happened, then we try running the thread again. The
510 // TSO_SQUEEZED flag is set by threadPaused() to tell us whether
511 // squeezing happened or not.
512 if (tso->flags & TSO_SQUEEZED) {
513 return;
514 }
515
516 debugTrace(DEBUG_gc,
517 "threadStackOverflow of TSO %ld (%p): stack too large (now %ld; max is %ld)",
518 (long)tso->id, tso, (long)tso->stackobj->stack_size,
519 RtsFlags.GcFlags.maxStkSize);
520 IF_DEBUG(gc,
521 /* If we're debugging, just print out the top of the stack */
522 printStackChunk(tso->stackobj->sp,
523 stg_min(tso->stackobj->stack + tso->stackobj->stack_size,
524 tso->stackobj->sp+64)));
525
526 if (tso->flags & TSO_BLOCKEX) {
527 // NB. StackOverflow exceptions must be deferred if the thread is
528 // inside Control.Exception.mask. See bug #767 and bug #8303.
529 // This implementation is a minor hack, see Note [Throw to self when masked]
530 MessageThrowTo *msg = (MessageThrowTo*)allocate(cap, sizeofW(MessageThrowTo));
531 SET_HDR(msg, &stg_MSG_THROWTO_info, CCS_SYSTEM);
532 msg->source = tso;
533 msg->target = tso;
534 msg->exception = (StgClosure *)stackOverflow_closure;
535 blockedThrowTo(cap, tso, msg);
536 } else {
537 // Send this thread the StackOverflow exception
538 throwToSingleThreaded(cap, tso, (StgClosure *)stackOverflow_closure);
539 return;
540 }
541 }
542
543
544 // We also want to avoid enlarging the stack if squeezing has
545 // already released some of it. However, we don't want to get into
546 // a pathological situation where a thread has a nearly full stack
547 // (near its current limit, but not near the absolute -K limit),
548 // keeps allocating a little bit, squeezing removes a little bit,
549 // and then it runs again. So to avoid this, if we squeezed *and*
550 // there is still less than BLOCK_SIZE_W words free, then we enlarge
551 // the stack anyway.
552 //
553 // NB: This reasoning only applies if the stack has been squeezed;
554 // if no squeezing has occurred, then BLOCK_SIZE_W free space does
555 // not mean there is enough stack to run; the thread may have
556 // requested a large amount of stack (see below). If the amount
557 // we squeezed is not enough to run the thread, we'll come back
558 // here (no squeezing will have occurred and thus we'll enlarge the
559 // stack.)
560 if ((tso->flags & TSO_SQUEEZED) &&
561 ((W_)(tso->stackobj->sp - tso->stackobj->stack) >= BLOCK_SIZE_W)) {
562 return;
563 }
564
565 old_stack = tso->stackobj;
566
567 // If we used less than half of the previous stack chunk, then we
568 // must have failed a stack check for a large amount of stack. In
569 // this case we allocate a double-sized chunk to try to
570 // accommodate the large stack request. If that also fails, the
571 // next chunk will be 4x normal size, and so on.
572 //
573 // It would be better to have the mutator tell us how much stack
574 // was needed, as we do with heap allocations, but this works for
575 // now.
576 //
577 if (old_stack->sp > old_stack->stack + old_stack->stack_size / 2)
578 {
579 chunk_size = stg_max(2 * (old_stack->stack_size + sizeofW(StgStack)),
580 RtsFlags.GcFlags.stkChunkSize);
581 }
582 else
583 {
584 chunk_size = RtsFlags.GcFlags.stkChunkSize;
585 }
586
587 debugTraceCap(DEBUG_sched, cap,
588 "allocating new stack chunk of size %d bytes",
589 chunk_size * sizeof(W_));
590
591 new_stack = (StgStack*) allocate(cap, chunk_size);
592 SET_HDR(new_stack, &stg_STACK_info, old_stack->header.prof.ccs);
593 TICK_ALLOC_STACK(chunk_size);
594
595 new_stack->dirty = 0; // begin clean, we'll mark it dirty below
596 new_stack->stack_size = chunk_size - sizeofW(StgStack);
597 new_stack->sp = new_stack->stack + new_stack->stack_size;
598
599 tso->tot_stack_size += new_stack->stack_size;
600
601 {
602 StgWord *sp;
603 W_ chunk_words, size;
604
605 // find the boundary of the chunk of old stack we're going to
606 // copy to the new stack. We skip over stack frames until we
607 // reach the smaller of
608 //
609 // * the chunk buffer size (+RTS -kb)
610 // * the end of the old stack
611 //
612 for (sp = old_stack->sp;
613 sp < stg_min(old_stack->sp + RtsFlags.GcFlags.stkChunkBufferSize,
614 old_stack->stack + old_stack->stack_size); )
615 {
616 size = stack_frame_sizeW((StgClosure*)sp);
617
618 // if including this frame would exceed the size of the
619 // new stack (taking into account the underflow frame),
620 // then stop at the previous frame.
621 if (sp + size > old_stack->stack + (new_stack->stack_size -
622 sizeofW(StgUnderflowFrame))) {
623 break;
624 }
625 sp += size;
626 }
627
628 if (sp == old_stack->stack + old_stack->stack_size) {
629 //
630 // the old stack chunk is now empty, so we do *not* insert
631 // an underflow frame pointing back to it. There are two
632 // cases: either the old stack chunk was the last one, in
633 // which case it ends with a STOP_FRAME, or it is not the
634 // last one, and it already ends with an UNDERFLOW_FRAME
635 // pointing to the previous chunk. In the latter case, we
636 // will copy the UNDERFLOW_FRAME into the new stack chunk.
637 // In both cases, the old chunk will be subsequently GC'd.
638 //
639 // With the default settings, -ki1k -kb1k, this means the
640 // first stack chunk will be discarded after the first
641 // overflow, being replaced by a non-moving 32k chunk.
642 //
643 } else {
644 new_stack->sp -= sizeofW(StgUnderflowFrame);
645 frame = (StgUnderflowFrame*)new_stack->sp;
646 frame->info = &stg_stack_underflow_frame_info;
647 frame->next_chunk = old_stack;
648 }
649
650 // copy the stack chunk between tso->sp and sp to
651 // new_tso->sp + (tso->sp - sp)
652 chunk_words = sp - old_stack->sp;
653
654 memcpy(/* dest */ new_stack->sp - chunk_words,
655 /* source */ old_stack->sp,
656 /* size */ chunk_words * sizeof(W_));
657
658 old_stack->sp += chunk_words;
659 new_stack->sp -= chunk_words;
660 }
661
662 tso->stackobj = new_stack;
663
664 // we're about to run it, better mark it dirty
665 dirty_STACK(cap, new_stack);
666
667 IF_DEBUG(sanity,checkTSO(tso));
668 // IF_DEBUG(scheduler,printTSO(new_tso));
669 }
670
671 /* Note [Throw to self when masked]
672 *
673 * When a StackOverflow occurs when the thread is masked, we want to
674 * defer the exception to when the thread becomes unmasked/hits an
675 * interruptible point. We already have a mechanism for doing this,
676 * the blocked_exceptions list, but the use here is a bit unusual,
677 * because an exception is normally only added to this list upon
678 * an asynchronous 'throwTo' call (with all of the relevant
679 * multithreaded nonsense). Morally, a stack overflow should be an
680 * asynchronous exception sent by a thread to itself, and it should
681 * have the same semantics. But there are a few key differences:
682 *
683 * - If you actually tried to send an asynchronous exception to
684 * yourself using throwTo, the exception would actually immediately
685 * be delivered. This is because throwTo itself is considered an
686 * interruptible point, so the exception is always deliverable. Thus,
687 * ordinarily, we never end up with a message to onesself in the
688 * blocked_exceptions queue.
689 *
690 * - In the case of a StackOverflow, we don't actually care about the
691 * wakeup semantics; when an exception is delivered, the thread that
692 * originally threw the exception should be woken up, since throwTo
693 * blocks until the exception is successfully thrown. Fortunately,
694 * it is harmless to wakeup a thread that doesn't actually need waking
695 * up, e.g. ourselves.
696 *
697 * - No synchronization is necessary, because we own the TSO and the
698 * capability. You can observe this by tracing through the execution
699 * of throwTo. We skip synchronizing the message and inter-capability
700 * communication.
701 *
702 * We think this doesn't break any invariants, but do be careful!
703 */
704
705
706 /* ---------------------------------------------------------------------------
707 Stack underflow - called from the stg_stack_underflow_info frame
708 ------------------------------------------------------------------------ */
709
710 W_ // returns offset to the return address
711 threadStackUnderflow (Capability *cap, StgTSO *tso)
712 {
713 StgStack *new_stack, *old_stack;
714 StgUnderflowFrame *frame;
715 nat retvals;
716
717 debugTraceCap(DEBUG_sched, cap, "stack underflow");
718
719 old_stack = tso->stackobj;
720
721 frame = (StgUnderflowFrame*)(old_stack->stack + old_stack->stack_size
722 - sizeofW(StgUnderflowFrame));
723 ASSERT(frame->info == &stg_stack_underflow_frame_info);
724
725 new_stack = (StgStack*)frame->next_chunk;
726 tso->stackobj = new_stack;
727
728 retvals = (P_)frame - old_stack->sp;
729 if (retvals != 0)
730 {
731 // we have some return values to copy to the old stack
732 if ((W_)(new_stack->sp - new_stack->stack) < retvals)
733 {
734 barf("threadStackUnderflow: not enough space for return values");
735 }
736
737 new_stack->sp -= retvals;
738
739 memcpy(/* dest */ new_stack->sp,
740 /* src */ old_stack->sp,
741 /* size */ retvals * sizeof(W_));
742 }
743
744 // empty the old stack. The GC may still visit this object
745 // because it is on the mutable list.
746 old_stack->sp = old_stack->stack + old_stack->stack_size;
747
748 // restore the stack parameters, and update tot_stack_size
749 tso->tot_stack_size -= old_stack->stack_size;
750
751 // we're about to run it, better mark it dirty
752 dirty_STACK(cap, new_stack);
753
754 return retvals;
755 }
756
757 /* ----------------------------------------------------------------------------
758 * Debugging: why is a thread blocked
759 * ------------------------------------------------------------------------- */
760
761 #if DEBUG
762 void
763 printThreadBlockage(StgTSO *tso)
764 {
765 switch (tso->why_blocked) {
766 #if defined(mingw32_HOST_OS)
767 case BlockedOnDoProc:
768 debugBelch("is blocked on proc (request: %u)", tso->block_info.async_result->reqID);
769 break;
770 #endif
771 #if !defined(THREADED_RTS)
772 case BlockedOnRead:
773 debugBelch("is blocked on read from fd %d", (int)(tso->block_info.fd));
774 break;
775 case BlockedOnWrite:
776 debugBelch("is blocked on write to fd %d", (int)(tso->block_info.fd));
777 break;
778 case BlockedOnDelay:
779 debugBelch("is blocked until %ld", (long)(tso->block_info.target));
780 break;
781 #endif
782 case BlockedOnMVar:
783 debugBelch("is blocked on an MVar @ %p", tso->block_info.closure);
784 break;
785 case BlockedOnMVarRead:
786 debugBelch("is blocked on atomic MVar read @ %p", tso->block_info.closure);
787 break;
788 case BlockedOnBlackHole:
789 debugBelch("is blocked on a black hole %p",
790 ((StgBlockingQueue*)tso->block_info.bh->bh));
791 break;
792 case BlockedOnMsgThrowTo:
793 debugBelch("is blocked on a throwto message");
794 break;
795 case NotBlocked:
796 debugBelch("is not blocked");
797 break;
798 case ThreadMigrating:
799 debugBelch("is runnable, but not on the run queue");
800 break;
801 case BlockedOnCCall:
802 debugBelch("is blocked on an external call");
803 break;
804 case BlockedOnCCall_Interruptible:
805 debugBelch("is blocked on an external call (but may be interrupted)");
806 break;
807 case BlockedOnSTM:
808 debugBelch("is blocked on an STM operation");
809 break;
810 default:
811 barf("printThreadBlockage: strange tso->why_blocked: %d for TSO %d (%d)",
812 tso->why_blocked, tso->id, tso);
813 }
814 }
815
816
817 void
818 printThreadStatus(StgTSO *t)
819 {
820 debugBelch("\tthread %4lu @ %p ", (unsigned long)t->id, (void *)t);
821 {
822 void *label = lookupThreadLabel(t->id);
823 if (label) debugBelch("[\"%s\"] ",(char *)label);
824 }
825 switch (t->what_next) {
826 case ThreadKilled:
827 debugBelch("has been killed");
828 break;
829 case ThreadComplete:
830 debugBelch("has completed");
831 break;
832 default:
833 printThreadBlockage(t);
834 }
835 if (t->dirty) {
836 debugBelch(" (TSO_DIRTY)");
837 }
838 debugBelch("\n");
839 }
840
841 void
842 printAllThreads(void)
843 {
844 StgTSO *t, *next;
845 nat i, g;
846 Capability *cap;
847
848 debugBelch("all threads:\n");
849
850 for (i = 0; i < n_capabilities; i++) {
851 cap = capabilities[i];
852 debugBelch("threads on capability %d:\n", cap->no);
853 for (t = cap->run_queue_hd; t != END_TSO_QUEUE; t = t->_link) {
854 printThreadStatus(t);
855 }
856 }
857
858 debugBelch("other threads:\n");
859 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
860 for (t = generations[g].threads; t != END_TSO_QUEUE; t = next) {
861 if (t->why_blocked != NotBlocked) {
862 printThreadStatus(t);
863 }
864 next = t->global_link;
865 }
866 }
867 }
868
869 // useful from gdb
870 void
871 printThreadQueue(StgTSO *t)
872 {
873 nat i = 0;
874 for (; t != END_TSO_QUEUE; t = t->_link) {
875 printThreadStatus(t);
876 i++;
877 }
878 debugBelch("%d threads on queue\n", i);
879 }
880
881 #endif /* DEBUG */