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