Use https links in user-facing startup and error messages
[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 StgTSO *
58 createThread(Capability *cap, W_ size)
59 {
60 StgTSO *tso;
61 StgStack *stack;
62 uint32_t stack_size;
63
64 /* sched_mutex is *not* required */
65
66 /* catch ridiculously small stack sizes */
67 if (size < MIN_STACK_WORDS + sizeofW(StgStack) + sizeofW(StgTSO)) {
68 size = MIN_STACK_WORDS + sizeofW(StgStack) + sizeofW(StgTSO);
69 }
70
71 /* The size argument we are given includes all the per-thread
72 * overheads:
73 *
74 * - The TSO structure
75 * - The STACK header
76 *
77 * This is so that we can use a nice round power of 2 for the
78 * default stack size (e.g. 1k), and if we're allocating lots of
79 * threads back-to-back they'll fit nicely in a block. It's a bit
80 * of a benchmark hack, but it doesn't do any harm.
81 */
82 stack_size = round_to_mblocks(size - sizeofW(StgTSO));
83 stack = (StgStack *)allocate(cap, stack_size);
84 TICK_ALLOC_STACK(stack_size);
85 SET_HDR(stack, &stg_STACK_info, cap->r.rCCCS);
86 stack->stack_size = stack_size - sizeofW(StgStack);
87 stack->sp = stack->stack + stack->stack_size;
88 stack->dirty = 1;
89
90 tso = (StgTSO *)allocate(cap, sizeofW(StgTSO));
91 TICK_ALLOC_TSO();
92 SET_HDR(tso, &stg_TSO_info, CCS_SYSTEM);
93
94 // Always start with the compiled code evaluator
95 tso->what_next = ThreadRunGHC;
96 tso->why_blocked = NotBlocked;
97 tso->block_info.closure = (StgClosure *)END_TSO_QUEUE;
98 tso->blocked_exceptions = END_BLOCKED_EXCEPTIONS_QUEUE;
99 tso->bq = (StgBlockingQueue *)END_TSO_QUEUE;
100 tso->flags = 0;
101 tso->dirty = 1;
102 tso->_link = END_TSO_QUEUE;
103
104 tso->saved_errno = 0;
105 tso->bound = NULL;
106 tso->cap = cap;
107
108 tso->stackobj = stack;
109 tso->tot_stack_size = stack->stack_size;
110
111 ASSIGN_Int64((W_*)&(tso->alloc_limit), 0);
112
113 tso->trec = NO_TREC;
114
115 #if defined(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 * Enabling and disabling the thread allocation limit
169 * ------------------------------------------------------------------------ */
170
171 void rts_enableThreadAllocationLimit(StgPtr tso)
172 {
173 ((StgTSO *)tso)->flags |= TSO_ALLOC_LIMIT;
174 }
175
176 void rts_disableThreadAllocationLimit(StgPtr tso)
177 {
178 ((StgTSO *)tso)->flags &= ~TSO_ALLOC_LIMIT;
179 }
180
181 /* -----------------------------------------------------------------------------
182 Remove a thread from a queue.
183 Fails fatally if the TSO is not on the queue.
184 -------------------------------------------------------------------------- */
185
186 bool // returns true if we modified queue
187 removeThreadFromQueue (Capability *cap, StgTSO **queue, StgTSO *tso)
188 {
189 StgTSO *t, *prev;
190
191 prev = NULL;
192 for (t = *queue; t != END_TSO_QUEUE; prev = t, t = t->_link) {
193 if (t == tso) {
194 if (prev) {
195 setTSOLink(cap,prev,t->_link);
196 t->_link = END_TSO_QUEUE;
197 return false;
198 } else {
199 *queue = t->_link;
200 t->_link = END_TSO_QUEUE;
201 return true;
202 }
203 }
204 }
205 barf("removeThreadFromQueue: not found");
206 }
207
208 bool // returns true if we modified head or tail
209 removeThreadFromDeQueue (Capability *cap,
210 StgTSO **head, StgTSO **tail, StgTSO *tso)
211 {
212 StgTSO *t, *prev;
213 bool flag = false;
214
215 prev = NULL;
216 for (t = *head; t != END_TSO_QUEUE; prev = t, t = t->_link) {
217 if (t == tso) {
218 if (prev) {
219 setTSOLink(cap,prev,t->_link);
220 flag = false;
221 } else {
222 *head = t->_link;
223 flag = true;
224 }
225 t->_link = END_TSO_QUEUE;
226 if (*tail == tso) {
227 if (prev) {
228 *tail = prev;
229 } else {
230 *tail = END_TSO_QUEUE;
231 }
232 return true;
233 } else {
234 return flag;
235 }
236 }
237 }
238 barf("removeThreadFromDeQueue: not found");
239 }
240
241 /* ----------------------------------------------------------------------------
242 tryWakeupThread()
243
244 Attempt to wake up a thread. tryWakeupThread is idempotent: it is
245 always safe to call it too many times, but it is not safe in
246 general to omit a call.
247
248 ------------------------------------------------------------------------- */
249
250 void
251 tryWakeupThread (Capability *cap, StgTSO *tso)
252 {
253 traceEventThreadWakeup (cap, tso, tso->cap->no);
254
255 #if defined(THREADED_RTS)
256 if (tso->cap != cap)
257 {
258 MessageWakeup *msg;
259 msg = (MessageWakeup *)allocate(cap,sizeofW(MessageWakeup));
260 SET_HDR(msg, &stg_MSG_TRY_WAKEUP_info, CCS_SYSTEM);
261 msg->tso = tso;
262 sendMessage(cap, tso->cap, (Message*)msg);
263 debugTraceCap(DEBUG_sched, cap, "message: try wakeup thread %ld on cap %d",
264 (W_)tso->id, tso->cap->no);
265 return;
266 }
267 #endif
268
269 switch (tso->why_blocked)
270 {
271 case BlockedOnMVar:
272 case BlockedOnMVarRead:
273 {
274 if (tso->_link == END_TSO_QUEUE) {
275 tso->block_info.closure = (StgClosure*)END_TSO_QUEUE;
276 goto unblock;
277 } else {
278 return;
279 }
280 }
281
282 case BlockedOnMsgThrowTo:
283 {
284 const StgInfoTable *i;
285
286 i = lockClosure(tso->block_info.closure);
287 unlockClosure(tso->block_info.closure, i);
288 if (i != &stg_MSG_NULL_info) {
289 debugTraceCap(DEBUG_sched, cap, "thread %ld still blocked on throwto (%p)",
290 (W_)tso->id, tso->block_info.throwto->header.info);
291 return;
292 }
293
294 // remove the block frame from the stack
295 ASSERT(tso->stackobj->sp[0] == (StgWord)&stg_block_throwto_info);
296 tso->stackobj->sp += 3;
297 goto unblock;
298 }
299
300 case BlockedOnSTM:
301 tso->block_info.closure = &stg_STM_AWOKEN_closure;
302 goto unblock;
303
304 case BlockedOnBlackHole:
305 case ThreadMigrating:
306 goto unblock;
307
308 default:
309 // otherwise, do nothing
310 return;
311 }
312
313 unblock:
314 // just run the thread now, if the BH is not really available,
315 // we'll block again.
316 tso->why_blocked = NotBlocked;
317 appendToRunQueue(cap,tso);
318
319 // We used to set the context switch flag here, which would
320 // trigger a context switch a short time in the future (at the end
321 // of the current nursery block). The idea is that we have just
322 // woken up a thread, so we may need to load-balance and migrate
323 // threads to other CPUs. On the other hand, setting the context
324 // switch flag here unfairly penalises the current thread by
325 // yielding its time slice too early.
326 //
327 // The synthetic benchmark nofib/smp/chan can be used to show the
328 // difference quite clearly.
329
330 // cap->context_switch = 1;
331 }
332
333 /* ----------------------------------------------------------------------------
334 migrateThread
335 ------------------------------------------------------------------------- */
336
337 void
338 migrateThread (Capability *from, StgTSO *tso, Capability *to)
339 {
340 traceEventMigrateThread (from, tso, to->no);
341 // ThreadMigrating tells the target cap that it needs to be added to
342 // the run queue when it receives the MSG_TRY_WAKEUP.
343 tso->why_blocked = ThreadMigrating;
344 tso->cap = to;
345 tryWakeupThread(from, tso);
346 }
347
348 /* ----------------------------------------------------------------------------
349 awakenBlockedQueue
350
351 wakes up all the threads on the specified queue.
352 ------------------------------------------------------------------------- */
353
354 static void
355 wakeBlockingQueue(Capability *cap, StgBlockingQueue *bq)
356 {
357 MessageBlackHole *msg;
358 const StgInfoTable *i;
359
360 ASSERT(bq->header.info == &stg_BLOCKING_QUEUE_DIRTY_info ||
361 bq->header.info == &stg_BLOCKING_QUEUE_CLEAN_info );
362
363 for (msg = bq->queue; msg != (MessageBlackHole*)END_TSO_QUEUE;
364 msg = msg->link) {
365 i = msg->header.info;
366 if (i != &stg_IND_info) {
367 ASSERT(i == &stg_MSG_BLACKHOLE_info);
368 tryWakeupThread(cap,msg->tso);
369 }
370 }
371
372 // overwrite the BQ with an indirection so it will be
373 // collected at the next GC.
374 OVERWRITE_INFO(bq, &stg_IND_info);
375 }
376
377 // If we update a closure that we know we BLACKHOLE'd, and the closure
378 // no longer points to the current TSO as its owner, then there may be
379 // an orphaned BLOCKING_QUEUE closure with blocked threads attached to
380 // it. We therefore traverse the BLOCKING_QUEUEs attached to the
381 // current TSO to see if any can now be woken up.
382 void
383 checkBlockingQueues (Capability *cap, StgTSO *tso)
384 {
385 StgBlockingQueue *bq, *next;
386 StgClosure *p;
387
388 debugTraceCap(DEBUG_sched, cap,
389 "collision occurred; checking blocking queues for thread %ld",
390 (W_)tso->id);
391
392 for (bq = tso->bq; bq != (StgBlockingQueue*)END_TSO_QUEUE; bq = next) {
393 next = bq->link;
394
395 if (bq->header.info == &stg_IND_info) {
396 // ToDo: could short it out right here, to avoid
397 // traversing this IND multiple times.
398 continue;
399 }
400
401 p = bq->bh;
402
403 if (p->header.info != &stg_BLACKHOLE_info ||
404 ((StgInd *)p)->indirectee != (StgClosure*)bq)
405 {
406 wakeBlockingQueue(cap,bq);
407 }
408 }
409 }
410
411 /* ----------------------------------------------------------------------------
412 updateThunk
413
414 Update a thunk with a value. In order to do this, we need to know
415 which TSO owns (or is evaluating) the thunk, in case we need to
416 awaken any threads that are blocked on it.
417 ------------------------------------------------------------------------- */
418
419 void
420 updateThunk (Capability *cap, StgTSO *tso, StgClosure *thunk, StgClosure *val)
421 {
422 StgClosure *v;
423 StgTSO *owner;
424 const StgInfoTable *i;
425
426 i = thunk->header.info;
427 if (i != &stg_BLACKHOLE_info &&
428 i != &stg_CAF_BLACKHOLE_info &&
429 i != &__stg_EAGER_BLACKHOLE_info &&
430 i != &stg_WHITEHOLE_info) {
431 updateWithIndirection(cap, thunk, val);
432 return;
433 }
434
435 v = UNTAG_CLOSURE(((StgInd*)thunk)->indirectee);
436
437 updateWithIndirection(cap, thunk, val);
438
439 // sometimes the TSO is locked when we reach here, so its header
440 // might be WHITEHOLE. Hence check for the correct owner using
441 // pointer equality first.
442 if ((StgTSO*)v == tso) {
443 return;
444 }
445
446 i = v->header.info;
447 if (i == &stg_TSO_info) {
448 checkBlockingQueues(cap, tso);
449 return;
450 }
451
452 if (i != &stg_BLOCKING_QUEUE_CLEAN_info &&
453 i != &stg_BLOCKING_QUEUE_DIRTY_info) {
454 checkBlockingQueues(cap, tso);
455 return;
456 }
457
458 owner = ((StgBlockingQueue*)v)->owner;
459
460 if (owner != tso) {
461 checkBlockingQueues(cap, tso);
462 } else {
463 wakeBlockingQueue(cap, (StgBlockingQueue*)v);
464 }
465 }
466
467 /* ---------------------------------------------------------------------------
468 * rtsSupportsBoundThreads(): is the RTS built to support bound threads?
469 * used by Control.Concurrent for error checking.
470 * ------------------------------------------------------------------------- */
471
472 HsBool
473 rtsSupportsBoundThreads(void)
474 {
475 #if defined(THREADED_RTS)
476 return HS_BOOL_TRUE;
477 #else
478 return HS_BOOL_FALSE;
479 #endif
480 }
481
482 /* ---------------------------------------------------------------------------
483 * isThreadBound(tso): check whether tso is bound to an OS thread.
484 * ------------------------------------------------------------------------- */
485
486 StgBool
487 isThreadBound(StgTSO* tso USED_IF_THREADS)
488 {
489 #if defined(THREADED_RTS)
490 return (tso->bound != NULL);
491 #endif
492 return false;
493 }
494
495 /* -----------------------------------------------------------------------------
496 Stack overflow
497
498 If the thread has reached its maximum stack size, then raise the
499 StackOverflow exception in the offending thread. Otherwise
500 relocate the TSO into a larger chunk of memory and adjust its stack
501 size appropriately.
502 -------------------------------------------------------------------------- */
503
504 void
505 threadStackOverflow (Capability *cap, StgTSO *tso)
506 {
507 StgStack *new_stack, *old_stack;
508 StgUnderflowFrame *frame;
509 W_ chunk_size;
510
511 IF_DEBUG(sanity,checkTSO(tso));
512
513 if (RtsFlags.GcFlags.maxStkSize > 0
514 && tso->tot_stack_size >= RtsFlags.GcFlags.maxStkSize) {
515 // #3677: In a stack overflow situation, stack squeezing may
516 // reduce the stack size, but we don't know whether it has been
517 // reduced enough for the stack check to succeed if we try
518 // again. Fortunately stack squeezing is idempotent, so all we
519 // need to do is record whether *any* squeezing happened. If we
520 // are at the stack's absolute -K limit, and stack squeezing
521 // happened, then we try running the thread again. The
522 // TSO_SQUEEZED flag is set by threadPaused() to tell us whether
523 // squeezing happened or not.
524 if (tso->flags & TSO_SQUEEZED) {
525 return;
526 }
527
528 debugTrace(DEBUG_gc,
529 "threadStackOverflow of TSO %ld (%p): stack too large (now %ld; max is %ld)",
530 (long)tso->id, tso, (long)tso->stackobj->stack_size,
531 RtsFlags.GcFlags.maxStkSize);
532 IF_DEBUG(gc,
533 /* If we're debugging, just print out the top of the stack */
534 printStackChunk(tso->stackobj->sp,
535 stg_min(tso->stackobj->stack + tso->stackobj->stack_size,
536 tso->stackobj->sp+64)));
537
538 // Note [Throw to self when masked], also #767 and #8303.
539 throwToSelf(cap, tso, (StgClosure *)stackOverflow_closure);
540 return;
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 // Charge the current thread for allocating stack. Stack usage is
592 // non-deterministic, because the chunk boundaries might vary from
593 // run to run, but accounting for this is better than not
594 // accounting for it, since a deep recursion will otherwise not be
595 // subject to allocation limits.
596 cap->r.rCurrentTSO = tso;
597 new_stack = (StgStack*) allocate(cap, chunk_size);
598 cap->r.rCurrentTSO = NULL;
599
600 SET_HDR(new_stack, &stg_STACK_info, old_stack->header.prof.ccs);
601 TICK_ALLOC_STACK(chunk_size);
602
603 new_stack->dirty = 0; // begin clean, we'll mark it dirty below
604 new_stack->stack_size = chunk_size - sizeofW(StgStack);
605 new_stack->sp = new_stack->stack + new_stack->stack_size;
606
607 tso->tot_stack_size += new_stack->stack_size;
608
609 {
610 StgWord *sp;
611 W_ chunk_words, size;
612
613 // find the boundary of the chunk of old stack we're going to
614 // copy to the new stack. We skip over stack frames until we
615 // reach the smaller of
616 //
617 // * the chunk buffer size (+RTS -kb)
618 // * the end of the old stack
619 //
620 for (sp = old_stack->sp;
621 sp < stg_min(old_stack->sp + RtsFlags.GcFlags.stkChunkBufferSize,
622 old_stack->stack + old_stack->stack_size); )
623 {
624 size = stack_frame_sizeW((StgClosure*)sp);
625
626 // if including this frame would exceed the size of the
627 // new stack (taking into account the underflow frame),
628 // then stop at the previous frame.
629 if (sp + size > old_stack->sp + (new_stack->stack_size -
630 sizeofW(StgUnderflowFrame))) {
631 break;
632 }
633 sp += size;
634 }
635
636 if (sp == old_stack->stack + old_stack->stack_size) {
637 //
638 // the old stack chunk is now empty, so we do *not* insert
639 // an underflow frame pointing back to it. There are two
640 // cases: either the old stack chunk was the last one, in
641 // which case it ends with a STOP_FRAME, or it is not the
642 // last one, and it already ends with an UNDERFLOW_FRAME
643 // pointing to the previous chunk. In the latter case, we
644 // will copy the UNDERFLOW_FRAME into the new stack chunk.
645 // In both cases, the old chunk will be subsequently GC'd.
646 //
647 // With the default settings, -ki1k -kb1k, this means the
648 // first stack chunk will be discarded after the first
649 // overflow, being replaced by a non-moving 32k chunk.
650 //
651 } else {
652 new_stack->sp -= sizeofW(StgUnderflowFrame);
653 frame = (StgUnderflowFrame*)new_stack->sp;
654 frame->info = &stg_stack_underflow_frame_info;
655 frame->next_chunk = old_stack;
656 }
657
658 // copy the stack chunk between tso->sp and sp to
659 // new_tso->sp + (tso->sp - sp)
660 chunk_words = sp - old_stack->sp;
661
662 memcpy(/* dest */ new_stack->sp - chunk_words,
663 /* source */ old_stack->sp,
664 /* size */ chunk_words * sizeof(W_));
665
666 old_stack->sp += chunk_words;
667 new_stack->sp -= chunk_words;
668 }
669
670 tso->stackobj = new_stack;
671
672 // we're about to run it, better mark it dirty
673 dirty_STACK(cap, new_stack);
674
675 IF_DEBUG(sanity,checkTSO(tso));
676 // IF_DEBUG(scheduler,printTSO(new_tso));
677 }
678
679
680
681 /* ---------------------------------------------------------------------------
682 Stack underflow - called from the stg_stack_underflow_info frame
683 ------------------------------------------------------------------------ */
684
685 W_ // returns offset to the return address
686 threadStackUnderflow (Capability *cap, StgTSO *tso)
687 {
688 StgStack *new_stack, *old_stack;
689 StgUnderflowFrame *frame;
690 uint32_t retvals;
691
692 debugTraceCap(DEBUG_sched, cap, "stack underflow");
693
694 old_stack = tso->stackobj;
695
696 frame = (StgUnderflowFrame*)(old_stack->stack + old_stack->stack_size
697 - sizeofW(StgUnderflowFrame));
698 ASSERT(frame->info == &stg_stack_underflow_frame_info);
699
700 new_stack = (StgStack*)frame->next_chunk;
701 tso->stackobj = new_stack;
702
703 retvals = (P_)frame - old_stack->sp;
704 if (retvals != 0)
705 {
706 // we have some return values to copy to the old stack
707 if ((W_)(new_stack->sp - new_stack->stack) < retvals)
708 {
709 barf("threadStackUnderflow: not enough space for return values");
710 }
711
712 new_stack->sp -= retvals;
713
714 memcpy(/* dest */ new_stack->sp,
715 /* src */ old_stack->sp,
716 /* size */ retvals * sizeof(W_));
717 }
718
719 // empty the old stack. The GC may still visit this object
720 // because it is on the mutable list.
721 old_stack->sp = old_stack->stack + old_stack->stack_size;
722
723 // restore the stack parameters, and update tot_stack_size
724 tso->tot_stack_size -= old_stack->stack_size;
725
726 // we're about to run it, better mark it dirty
727 dirty_STACK(cap, new_stack);
728
729 return retvals;
730 }
731
732 /* ----------------------------------------------------------------------------
733 Implementation of tryPutMVar#
734
735 NOTE: this should be kept in sync with stg_tryPutMVarzh in PrimOps.cmm
736 ------------------------------------------------------------------------- */
737
738 bool performTryPutMVar(Capability *cap, StgMVar *mvar, StgClosure *value)
739 {
740 const StgInfoTable *info;
741 StgMVarTSOQueue *q;
742 StgTSO *tso;
743
744 info = lockClosure((StgClosure*)mvar);
745
746 if (mvar->value != &stg_END_TSO_QUEUE_closure) {
747 #if defined(THREADED_RTS)
748 unlockClosure((StgClosure*)mvar, info);
749 #endif
750 return false;
751 }
752
753 q = mvar->head;
754 loop:
755 if (q == (StgMVarTSOQueue*)&stg_END_TSO_QUEUE_closure) {
756 /* No further takes, the MVar is now full. */
757 if (info == &stg_MVAR_CLEAN_info) {
758 dirty_MVAR(&cap->r, (StgClosure*)mvar);
759 }
760
761 mvar->value = value;
762 unlockClosure((StgClosure*)mvar, &stg_MVAR_DIRTY_info);
763 return true;
764 }
765 if (q->header.info == &stg_IND_info ||
766 q->header.info == &stg_MSG_NULL_info) {
767 q = (StgMVarTSOQueue*)((StgInd*)q)->indirectee;
768 goto loop;
769 }
770
771 // There are takeMVar(s) waiting: wake up the first one
772 tso = q->tso;
773 mvar->head = q->link;
774 if (mvar->head == (StgMVarTSOQueue*)&stg_END_TSO_QUEUE_closure) {
775 mvar->tail = (StgMVarTSOQueue*)&stg_END_TSO_QUEUE_closure;
776 }
777
778 ASSERT(tso->block_info.closure == (StgClosure*)mvar);
779 // save why_blocked here, because waking up the thread destroys
780 // this information
781 StgWord why_blocked = tso->why_blocked;
782
783 // actually perform the takeMVar
784 StgStack* stack = tso->stackobj;
785 stack->sp[1] = (W_)value;
786 stack->sp[0] = (W_)&stg_ret_p_info;
787
788 // indicate that the MVar operation has now completed.
789 tso->_link = (StgTSO*)&stg_END_TSO_QUEUE_closure;
790
791 if (stack->dirty == 0) {
792 dirty_STACK(cap, stack);
793 }
794
795 tryWakeupThread(cap, tso);
796
797 // If it was a readMVar, then we can still do work,
798 // so loop back. (XXX: This could take a while)
799 if (why_blocked == BlockedOnMVarRead) {
800 q = ((StgMVarTSOQueue*)q)->link;
801 goto loop;
802 }
803
804 ASSERT(why_blocked == BlockedOnMVar);
805
806 unlockClosure((StgClosure*)mvar, info);
807
808 return true;
809 }
810
811 /* ----------------------------------------------------------------------------
812 * Debugging: why is a thread blocked
813 * ------------------------------------------------------------------------- */
814
815 #if defined(DEBUG)
816 void
817 printThreadBlockage(StgTSO *tso)
818 {
819 switch (tso->why_blocked) {
820 #if defined(mingw32_HOST_OS)
821 case BlockedOnDoProc:
822 debugBelch("is blocked on proc (request: %u)", tso->block_info.async_result->reqID);
823 break;
824 #endif
825 #if !defined(THREADED_RTS)
826 case BlockedOnRead:
827 debugBelch("is blocked on read from fd %d", (int)(tso->block_info.fd));
828 break;
829 case BlockedOnWrite:
830 debugBelch("is blocked on write to fd %d", (int)(tso->block_info.fd));
831 break;
832 case BlockedOnDelay:
833 debugBelch("is blocked until %ld", (long)(tso->block_info.target));
834 break;
835 #endif
836 case BlockedOnMVar:
837 debugBelch("is blocked on an MVar @ %p", tso->block_info.closure);
838 break;
839 case BlockedOnMVarRead:
840 debugBelch("is blocked on atomic MVar read @ %p", tso->block_info.closure);
841 break;
842 case BlockedOnBlackHole:
843 debugBelch("is blocked on a black hole %p",
844 ((StgBlockingQueue*)tso->block_info.bh->bh));
845 break;
846 case BlockedOnMsgThrowTo:
847 debugBelch("is blocked on a throwto message");
848 break;
849 case NotBlocked:
850 debugBelch("is not blocked");
851 break;
852 case ThreadMigrating:
853 debugBelch("is runnable, but not on the run queue");
854 break;
855 case BlockedOnCCall:
856 debugBelch("is blocked on an external call");
857 break;
858 case BlockedOnCCall_Interruptible:
859 debugBelch("is blocked on an external call (but may be interrupted)");
860 break;
861 case BlockedOnSTM:
862 debugBelch("is blocked on an STM operation");
863 break;
864 default:
865 barf("printThreadBlockage: strange tso->why_blocked: %d for TSO %d (%p)",
866 tso->why_blocked, tso->id, tso);
867 }
868 }
869
870
871 void
872 printThreadStatus(StgTSO *t)
873 {
874 debugBelch("\tthread %4lu @ %p ", (unsigned long)t->id, (void *)t);
875 {
876 void *label = lookupThreadLabel(t->id);
877 if (label) debugBelch("[\"%s\"] ",(char *)label);
878 }
879 switch (t->what_next) {
880 case ThreadKilled:
881 debugBelch("has been killed");
882 break;
883 case ThreadComplete:
884 debugBelch("has completed");
885 break;
886 default:
887 printThreadBlockage(t);
888 }
889 if (t->dirty) {
890 debugBelch(" (TSO_DIRTY)");
891 }
892 debugBelch("\n");
893 }
894
895 void
896 printAllThreads(void)
897 {
898 StgTSO *t, *next;
899 uint32_t i, g;
900 Capability *cap;
901
902 debugBelch("all threads:\n");
903
904 for (i = 0; i < n_capabilities; i++) {
905 cap = capabilities[i];
906 debugBelch("threads on capability %d:\n", cap->no);
907 for (t = cap->run_queue_hd; t != END_TSO_QUEUE; t = t->_link) {
908 printThreadStatus(t);
909 }
910 }
911
912 debugBelch("other threads:\n");
913 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
914 for (t = generations[g].threads; t != END_TSO_QUEUE; t = next) {
915 if (t->why_blocked != NotBlocked) {
916 printThreadStatus(t);
917 }
918 next = t->global_link;
919 }
920 }
921 }
922
923 // useful from gdb
924 void
925 printThreadQueue(StgTSO *t)
926 {
927 uint32_t i = 0;
928 for (; t != END_TSO_QUEUE; t = t->_link) {
929 printThreadStatus(t);
930 i++;
931 }
932 debugBelch("%d threads on queue\n", i);
933 }
934
935 #endif /* DEBUG */