If exceptions are blocked, add stack overflow to blocked exceptions list. Fixes ...
[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 }
540 }
541
542
543 // We also want to avoid enlarging the stack if squeezing has
544 // already released some of it. However, we don't want to get into
545 // a pathological situation where a thread has a nearly full stack
546 // (near its current limit, but not near the absolute -K limit),
547 // keeps allocating a little bit, squeezing removes a little bit,
548 // and then it runs again. So to avoid this, if we squeezed *and*
549 // there is still less than BLOCK_SIZE_W words free, then we enlarge
550 // the stack anyway.
551 //
552 // NB: This reasoning only applies if the stack has been squeezed;
553 // if no squeezing has occurred, then BLOCK_SIZE_W free space does
554 // not mean there is enough stack to run; the thread may have
555 // requested a large amount of stack (see below). If the amount
556 // we squeezed is not enough to run the thread, we'll come back
557 // here (no squeezing will have occurred and thus we'll enlarge the
558 // stack.)
559 if ((tso->flags & TSO_SQUEEZED) &&
560 ((W_)(tso->stackobj->sp - tso->stackobj->stack) >= BLOCK_SIZE_W)) {
561 return;
562 }
563
564 old_stack = tso->stackobj;
565
566 // If we used less than half of the previous stack chunk, then we
567 // must have failed a stack check for a large amount of stack. In
568 // this case we allocate a double-sized chunk to try to
569 // accommodate the large stack request. If that also fails, the
570 // next chunk will be 4x normal size, and so on.
571 //
572 // It would be better to have the mutator tell us how much stack
573 // was needed, as we do with heap allocations, but this works for
574 // now.
575 //
576 if (old_stack->sp > old_stack->stack + old_stack->stack_size / 2)
577 {
578 chunk_size = stg_max(2 * (old_stack->stack_size + sizeofW(StgStack)),
579 RtsFlags.GcFlags.stkChunkSize);
580 }
581 else
582 {
583 chunk_size = RtsFlags.GcFlags.stkChunkSize;
584 }
585
586 debugTraceCap(DEBUG_sched, cap,
587 "allocating new stack chunk of size %d bytes",
588 chunk_size * sizeof(W_));
589
590 new_stack = (StgStack*) allocate(cap, chunk_size);
591 SET_HDR(new_stack, &stg_STACK_info, old_stack->header.prof.ccs);
592 TICK_ALLOC_STACK(chunk_size);
593
594 new_stack->dirty = 0; // begin clean, we'll mark it dirty below
595 new_stack->stack_size = chunk_size - sizeofW(StgStack);
596 new_stack->sp = new_stack->stack + new_stack->stack_size;
597
598 tso->tot_stack_size += new_stack->stack_size;
599
600 {
601 StgWord *sp;
602 W_ chunk_words, size;
603
604 // find the boundary of the chunk of old stack we're going to
605 // copy to the new stack. We skip over stack frames until we
606 // reach the smaller of
607 //
608 // * the chunk buffer size (+RTS -kb)
609 // * the end of the old stack
610 //
611 for (sp = old_stack->sp;
612 sp < stg_min(old_stack->sp + RtsFlags.GcFlags.stkChunkBufferSize,
613 old_stack->stack + old_stack->stack_size); )
614 {
615 size = stack_frame_sizeW((StgClosure*)sp);
616
617 // if including this frame would exceed the size of the
618 // new stack (taking into account the underflow frame),
619 // then stop at the previous frame.
620 if (sp + size > old_stack->stack + (new_stack->stack_size -
621 sizeofW(StgUnderflowFrame))) {
622 break;
623 }
624 sp += size;
625 }
626
627 if (sp == old_stack->stack + old_stack->stack_size) {
628 //
629 // the old stack chunk is now empty, so we do *not* insert
630 // an underflow frame pointing back to it. There are two
631 // cases: either the old stack chunk was the last one, in
632 // which case it ends with a STOP_FRAME, or it is not the
633 // last one, and it already ends with an UNDERFLOW_FRAME
634 // pointing to the previous chunk. In the latter case, we
635 // will copy the UNDERFLOW_FRAME into the new stack chunk.
636 // In both cases, the old chunk will be subsequently GC'd.
637 //
638 // With the default settings, -ki1k -kb1k, this means the
639 // first stack chunk will be discarded after the first
640 // overflow, being replaced by a non-moving 32k chunk.
641 //
642 } else {
643 new_stack->sp -= sizeofW(StgUnderflowFrame);
644 frame = (StgUnderflowFrame*)new_stack->sp;
645 frame->info = &stg_stack_underflow_frame_info;
646 frame->next_chunk = old_stack;
647 }
648
649 // copy the stack chunk between tso->sp and sp to
650 // new_tso->sp + (tso->sp - sp)
651 chunk_words = sp - old_stack->sp;
652
653 memcpy(/* dest */ new_stack->sp - chunk_words,
654 /* source */ old_stack->sp,
655 /* size */ chunk_words * sizeof(W_));
656
657 old_stack->sp += chunk_words;
658 new_stack->sp -= chunk_words;
659 }
660
661 tso->stackobj = new_stack;
662
663 // we're about to run it, better mark it dirty
664 dirty_STACK(cap, new_stack);
665
666 IF_DEBUG(sanity,checkTSO(tso));
667 // IF_DEBUG(scheduler,printTSO(new_tso));
668 }
669
670 /* Note [Throw to self when masked]
671 *
672 * When a StackOverflow occurs when the thread is masked, we want to
673 * defer the exception to when the thread becomes unmasked/hits an
674 * interruptible point. We already have a mechanism for doing this,
675 * the blocked_exceptions list, but the use here is a bit unusual,
676 * because an exception is normally only added to this list upon
677 * an asynchronous 'throwTo' call (with all of the relevant
678 * multithreaded nonsense). Morally, a stack overflow should be an
679 * asynchronous exception sent by a thread to itself, and it should
680 * have the same semantics. But there are a few key differences:
681 *
682 * - If you actually tried to send an asynchronous exception to
683 * yourself using throwTo, the exception would actually immediately
684 * be delivered. This is because throwTo itself is considered an
685 * interruptible point, so the exception is always deliverable. Thus,
686 * ordinarily, we never end up with a message to onesself in the
687 * blocked_exceptions queue.
688 *
689 * - In the case of a StackOverflow, we don't actually care about the
690 * wakeup semantics; when an exception is delivered, the thread that
691 * originally threw the exception should be woken up, since throwTo
692 * blocks until the exception is successfully thrown. Fortunately,
693 * it is harmless to wakeup a thread that doesn't actually need waking
694 * up, e.g. ourselves.
695 *
696 * - No synchronization is necessary, because we own the TSO and the
697 * capability. You can observe this by tracing through the execution
698 * of throwTo. We skip synchronizing the message and inter-capability
699 * communication.
700 *
701 * We think this doesn't break any invariants, but do be careful!
702 */
703
704
705 /* ---------------------------------------------------------------------------
706 Stack underflow - called from the stg_stack_underflow_info frame
707 ------------------------------------------------------------------------ */
708
709 W_ // returns offset to the return address
710 threadStackUnderflow (Capability *cap, StgTSO *tso)
711 {
712 StgStack *new_stack, *old_stack;
713 StgUnderflowFrame *frame;
714 nat retvals;
715
716 debugTraceCap(DEBUG_sched, cap, "stack underflow");
717
718 old_stack = tso->stackobj;
719
720 frame = (StgUnderflowFrame*)(old_stack->stack + old_stack->stack_size
721 - sizeofW(StgUnderflowFrame));
722 ASSERT(frame->info == &stg_stack_underflow_frame_info);
723
724 new_stack = (StgStack*)frame->next_chunk;
725 tso->stackobj = new_stack;
726
727 retvals = (P_)frame - old_stack->sp;
728 if (retvals != 0)
729 {
730 // we have some return values to copy to the old stack
731 if ((W_)(new_stack->sp - new_stack->stack) < retvals)
732 {
733 barf("threadStackUnderflow: not enough space for return values");
734 }
735
736 new_stack->sp -= retvals;
737
738 memcpy(/* dest */ new_stack->sp,
739 /* src */ old_stack->sp,
740 /* size */ retvals * sizeof(W_));
741 }
742
743 // empty the old stack. The GC may still visit this object
744 // because it is on the mutable list.
745 old_stack->sp = old_stack->stack + old_stack->stack_size;
746
747 // restore the stack parameters, and update tot_stack_size
748 tso->tot_stack_size -= old_stack->stack_size;
749
750 // we're about to run it, better mark it dirty
751 dirty_STACK(cap, new_stack);
752
753 return retvals;
754 }
755
756 /* ----------------------------------------------------------------------------
757 * Debugging: why is a thread blocked
758 * ------------------------------------------------------------------------- */
759
760 #if DEBUG
761 void
762 printThreadBlockage(StgTSO *tso)
763 {
764 switch (tso->why_blocked) {
765 #if defined(mingw32_HOST_OS)
766 case BlockedOnDoProc:
767 debugBelch("is blocked on proc (request: %u)", tso->block_info.async_result->reqID);
768 break;
769 #endif
770 #if !defined(THREADED_RTS)
771 case BlockedOnRead:
772 debugBelch("is blocked on read from fd %d", (int)(tso->block_info.fd));
773 break;
774 case BlockedOnWrite:
775 debugBelch("is blocked on write to fd %d", (int)(tso->block_info.fd));
776 break;
777 case BlockedOnDelay:
778 debugBelch("is blocked until %ld", (long)(tso->block_info.target));
779 break;
780 #endif
781 case BlockedOnMVar:
782 debugBelch("is blocked on an MVar @ %p", tso->block_info.closure);
783 break;
784 case BlockedOnMVarRead:
785 debugBelch("is blocked on atomic MVar read @ %p", tso->block_info.closure);
786 break;
787 case BlockedOnBlackHole:
788 debugBelch("is blocked on a black hole %p",
789 ((StgBlockingQueue*)tso->block_info.bh->bh));
790 break;
791 case BlockedOnMsgThrowTo:
792 debugBelch("is blocked on a throwto message");
793 break;
794 case NotBlocked:
795 debugBelch("is not blocked");
796 break;
797 case ThreadMigrating:
798 debugBelch("is runnable, but not on the run queue");
799 break;
800 case BlockedOnCCall:
801 debugBelch("is blocked on an external call");
802 break;
803 case BlockedOnCCall_Interruptible:
804 debugBelch("is blocked on an external call (but may be interrupted)");
805 break;
806 case BlockedOnSTM:
807 debugBelch("is blocked on an STM operation");
808 break;
809 default:
810 barf("printThreadBlockage: strange tso->why_blocked: %d for TSO %d (%d)",
811 tso->why_blocked, tso->id, tso);
812 }
813 }
814
815
816 void
817 printThreadStatus(StgTSO *t)
818 {
819 debugBelch("\tthread %4lu @ %p ", (unsigned long)t->id, (void *)t);
820 {
821 void *label = lookupThreadLabel(t->id);
822 if (label) debugBelch("[\"%s\"] ",(char *)label);
823 }
824 switch (t->what_next) {
825 case ThreadKilled:
826 debugBelch("has been killed");
827 break;
828 case ThreadComplete:
829 debugBelch("has completed");
830 break;
831 default:
832 printThreadBlockage(t);
833 }
834 if (t->dirty) {
835 debugBelch(" (TSO_DIRTY)");
836 }
837 debugBelch("\n");
838 }
839
840 void
841 printAllThreads(void)
842 {
843 StgTSO *t, *next;
844 nat i, g;
845 Capability *cap;
846
847 debugBelch("all threads:\n");
848
849 for (i = 0; i < n_capabilities; i++) {
850 cap = capabilities[i];
851 debugBelch("threads on capability %d:\n", cap->no);
852 for (t = cap->run_queue_hd; t != END_TSO_QUEUE; t = t->_link) {
853 printThreadStatus(t);
854 }
855 }
856
857 debugBelch("other threads:\n");
858 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
859 for (t = generations[g].threads; t != END_TSO_QUEUE; t = next) {
860 if (t->why_blocked != NotBlocked) {
861 printThreadStatus(t);
862 }
863 next = t->global_link;
864 }
865 }
866 }
867
868 // useful from gdb
869 void
870 printThreadQueue(StgTSO *t)
871 {
872 nat i = 0;
873 for (; t != END_TSO_QUEUE; t = t->_link) {
874 printThreadStatus(t);
875 i++;
876 }
877 debugBelch("%d threads on queue\n", i);
878 }
879
880 #endif /* DEBUG */