Improve accuracy of get/setAllocationCounter
[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 BlockedOnBlackHole:
301 case BlockedOnSTM:
302 case ThreadMigrating:
303 goto unblock;
304
305 default:
306 // otherwise, do nothing
307 return;
308 }
309
310 unblock:
311 // just run the thread now, if the BH is not really available,
312 // we'll block again.
313 tso->why_blocked = NotBlocked;
314 appendToRunQueue(cap,tso);
315
316 // We used to set the context switch flag here, which would
317 // trigger a context switch a short time in the future (at the end
318 // of the current nursery block). The idea is that we have just
319 // woken up a thread, so we may need to load-balance and migrate
320 // threads to other CPUs. On the other hand, setting the context
321 // switch flag here unfairly penalises the current thread by
322 // yielding its time slice too early.
323 //
324 // The synthetic benchmark nofib/smp/chan can be used to show the
325 // difference quite clearly.
326
327 // cap->context_switch = 1;
328 }
329
330 /* ----------------------------------------------------------------------------
331 migrateThread
332 ------------------------------------------------------------------------- */
333
334 void
335 migrateThread (Capability *from, StgTSO *tso, Capability *to)
336 {
337 traceEventMigrateThread (from, tso, to->no);
338 // ThreadMigrating tells the target cap that it needs to be added to
339 // the run queue when it receives the MSG_TRY_WAKEUP.
340 tso->why_blocked = ThreadMigrating;
341 tso->cap = to;
342 tryWakeupThread(from, tso);
343 }
344
345 /* ----------------------------------------------------------------------------
346 awakenBlockedQueue
347
348 wakes up all the threads on the specified queue.
349 ------------------------------------------------------------------------- */
350
351 static void
352 wakeBlockingQueue(Capability *cap, StgBlockingQueue *bq)
353 {
354 MessageBlackHole *msg;
355 const StgInfoTable *i;
356
357 ASSERT(bq->header.info == &stg_BLOCKING_QUEUE_DIRTY_info ||
358 bq->header.info == &stg_BLOCKING_QUEUE_CLEAN_info );
359
360 for (msg = bq->queue; msg != (MessageBlackHole*)END_TSO_QUEUE;
361 msg = msg->link) {
362 i = msg->header.info;
363 if (i != &stg_IND_info) {
364 ASSERT(i == &stg_MSG_BLACKHOLE_info);
365 tryWakeupThread(cap,msg->tso);
366 }
367 }
368
369 // overwrite the BQ with an indirection so it will be
370 // collected at the next GC.
371 #if defined(DEBUG) && !defined(THREADED_RTS)
372 // XXX FILL_SLOP, but not if THREADED_RTS because in that case
373 // another thread might be looking at this BLOCKING_QUEUE and
374 // checking the owner field at the same time.
375 bq->bh = 0; bq->queue = 0; bq->owner = 0;
376 #endif
377 OVERWRITE_INFO(bq, &stg_IND_info);
378 }
379
380 // If we update a closure that we know we BLACKHOLE'd, and the closure
381 // no longer points to the current TSO as its owner, then there may be
382 // an orphaned BLOCKING_QUEUE closure with blocked threads attached to
383 // it. We therefore traverse the BLOCKING_QUEUEs attached to the
384 // current TSO to see if any can now be woken up.
385 void
386 checkBlockingQueues (Capability *cap, StgTSO *tso)
387 {
388 StgBlockingQueue *bq, *next;
389 StgClosure *p;
390
391 debugTraceCap(DEBUG_sched, cap,
392 "collision occurred; checking blocking queues for thread %ld",
393 (W_)tso->id);
394
395 for (bq = tso->bq; bq != (StgBlockingQueue*)END_TSO_QUEUE; bq = next) {
396 next = bq->link;
397
398 if (bq->header.info == &stg_IND_info) {
399 // ToDo: could short it out right here, to avoid
400 // traversing this IND multiple times.
401 continue;
402 }
403
404 p = bq->bh;
405
406 if (p->header.info != &stg_BLACKHOLE_info ||
407 ((StgInd *)p)->indirectee != (StgClosure*)bq)
408 {
409 wakeBlockingQueue(cap,bq);
410 }
411 }
412 }
413
414 /* ----------------------------------------------------------------------------
415 updateThunk
416
417 Update a thunk with a value. In order to do this, we need to know
418 which TSO owns (or is evaluating) the thunk, in case we need to
419 awaken any threads that are blocked on it.
420 ------------------------------------------------------------------------- */
421
422 void
423 updateThunk (Capability *cap, StgTSO *tso, StgClosure *thunk, StgClosure *val)
424 {
425 StgClosure *v;
426 StgTSO *owner;
427 const StgInfoTable *i;
428
429 i = thunk->header.info;
430 if (i != &stg_BLACKHOLE_info &&
431 i != &stg_CAF_BLACKHOLE_info &&
432 i != &__stg_EAGER_BLACKHOLE_info &&
433 i != &stg_WHITEHOLE_info) {
434 updateWithIndirection(cap, thunk, val);
435 return;
436 }
437
438 v = UNTAG_CLOSURE(((StgInd*)thunk)->indirectee);
439
440 updateWithIndirection(cap, thunk, val);
441
442 // sometimes the TSO is locked when we reach here, so its header
443 // might be WHITEHOLE. Hence check for the correct owner using
444 // pointer equality first.
445 if ((StgTSO*)v == tso) {
446 return;
447 }
448
449 i = v->header.info;
450 if (i == &stg_TSO_info) {
451 checkBlockingQueues(cap, tso);
452 return;
453 }
454
455 if (i != &stg_BLOCKING_QUEUE_CLEAN_info &&
456 i != &stg_BLOCKING_QUEUE_DIRTY_info) {
457 checkBlockingQueues(cap, tso);
458 return;
459 }
460
461 owner = ((StgBlockingQueue*)v)->owner;
462
463 if (owner != tso) {
464 checkBlockingQueues(cap, tso);
465 } else {
466 wakeBlockingQueue(cap, (StgBlockingQueue*)v);
467 }
468 }
469
470 /* ---------------------------------------------------------------------------
471 * rtsSupportsBoundThreads(): is the RTS built to support bound threads?
472 * used by Control.Concurrent for error checking.
473 * ------------------------------------------------------------------------- */
474
475 HsBool
476 rtsSupportsBoundThreads(void)
477 {
478 #if defined(THREADED_RTS)
479 return HS_BOOL_TRUE;
480 #else
481 return HS_BOOL_FALSE;
482 #endif
483 }
484
485 /* ---------------------------------------------------------------------------
486 * isThreadBound(tso): check whether tso is bound to an OS thread.
487 * ------------------------------------------------------------------------- */
488
489 StgBool
490 isThreadBound(StgTSO* tso USED_IF_THREADS)
491 {
492 #if defined(THREADED_RTS)
493 return (tso->bound != NULL);
494 #endif
495 return false;
496 }
497
498 /* -----------------------------------------------------------------------------
499 Stack overflow
500
501 If the thread has reached its maximum stack size, then raise the
502 StackOverflow exception in the offending thread. Otherwise
503 relocate the TSO into a larger chunk of memory and adjust its stack
504 size appropriately.
505 -------------------------------------------------------------------------- */
506
507 void
508 threadStackOverflow (Capability *cap, StgTSO *tso)
509 {
510 StgStack *new_stack, *old_stack;
511 StgUnderflowFrame *frame;
512 W_ chunk_size;
513
514 IF_DEBUG(sanity,checkTSO(tso));
515
516 if (RtsFlags.GcFlags.maxStkSize > 0
517 && tso->tot_stack_size >= RtsFlags.GcFlags.maxStkSize) {
518 // #3677: In a stack overflow situation, stack squeezing may
519 // reduce the stack size, but we don't know whether it has been
520 // reduced enough for the stack check to succeed if we try
521 // again. Fortunately stack squeezing is idempotent, so all we
522 // need to do is record whether *any* squeezing happened. If we
523 // are at the stack's absolute -K limit, and stack squeezing
524 // happened, then we try running the thread again. The
525 // TSO_SQUEEZED flag is set by threadPaused() to tell us whether
526 // squeezing happened or not.
527 if (tso->flags & TSO_SQUEEZED) {
528 return;
529 }
530
531 debugTrace(DEBUG_gc,
532 "threadStackOverflow of TSO %ld (%p): stack too large (now %ld; max is %ld)",
533 (long)tso->id, tso, (long)tso->stackobj->stack_size,
534 RtsFlags.GcFlags.maxStkSize);
535 IF_DEBUG(gc,
536 /* If we're debugging, just print out the top of the stack */
537 printStackChunk(tso->stackobj->sp,
538 stg_min(tso->stackobj->stack + tso->stackobj->stack_size,
539 tso->stackobj->sp+64)));
540
541 // Note [Throw to self when masked], also #767 and #8303.
542 throwToSelf(cap, tso, (StgClosure *)stackOverflow_closure);
543 return;
544 }
545
546
547 // We also want to avoid enlarging the stack if squeezing has
548 // already released some of it. However, we don't want to get into
549 // a pathological situation where a thread has a nearly full stack
550 // (near its current limit, but not near the absolute -K limit),
551 // keeps allocating a little bit, squeezing removes a little bit,
552 // and then it runs again. So to avoid this, if we squeezed *and*
553 // there is still less than BLOCK_SIZE_W words free, then we enlarge
554 // the stack anyway.
555 //
556 // NB: This reasoning only applies if the stack has been squeezed;
557 // if no squeezing has occurred, then BLOCK_SIZE_W free space does
558 // not mean there is enough stack to run; the thread may have
559 // requested a large amount of stack (see below). If the amount
560 // we squeezed is not enough to run the thread, we'll come back
561 // here (no squeezing will have occurred and thus we'll enlarge the
562 // stack.)
563 if ((tso->flags & TSO_SQUEEZED) &&
564 ((W_)(tso->stackobj->sp - tso->stackobj->stack) >= BLOCK_SIZE_W)) {
565 return;
566 }
567
568 old_stack = tso->stackobj;
569
570 // If we used less than half of the previous stack chunk, then we
571 // must have failed a stack check for a large amount of stack. In
572 // this case we allocate a double-sized chunk to try to
573 // accommodate the large stack request. If that also fails, the
574 // next chunk will be 4x normal size, and so on.
575 //
576 // It would be better to have the mutator tell us how much stack
577 // was needed, as we do with heap allocations, but this works for
578 // now.
579 //
580 if (old_stack->sp > old_stack->stack + old_stack->stack_size / 2)
581 {
582 chunk_size = stg_max(2 * (old_stack->stack_size + sizeofW(StgStack)),
583 RtsFlags.GcFlags.stkChunkSize);
584 }
585 else
586 {
587 chunk_size = RtsFlags.GcFlags.stkChunkSize;
588 }
589
590 debugTraceCap(DEBUG_sched, cap,
591 "allocating new stack chunk of size %d bytes",
592 chunk_size * sizeof(W_));
593
594 // Charge the current thread for allocating stack. Stack usage is
595 // non-deterministic, because the chunk boundaries might vary from
596 // run to run, but accounting for this is better than not
597 // accounting for it, since a deep recursion will otherwise not be
598 // subject to allocation limits.
599 cap->r.rCurrentTSO = tso;
600 new_stack = (StgStack*) allocate(cap, chunk_size);
601 cap->r.rCurrentTSO = NULL;
602
603 SET_HDR(new_stack, &stg_STACK_info, old_stack->header.prof.ccs);
604 TICK_ALLOC_STACK(chunk_size);
605
606 new_stack->dirty = 0; // begin clean, we'll mark it dirty below
607 new_stack->stack_size = chunk_size - sizeofW(StgStack);
608 new_stack->sp = new_stack->stack + new_stack->stack_size;
609
610 tso->tot_stack_size += new_stack->stack_size;
611
612 {
613 StgWord *sp;
614 W_ chunk_words, size;
615
616 // find the boundary of the chunk of old stack we're going to
617 // copy to the new stack. We skip over stack frames until we
618 // reach the smaller of
619 //
620 // * the chunk buffer size (+RTS -kb)
621 // * the end of the old stack
622 //
623 for (sp = old_stack->sp;
624 sp < stg_min(old_stack->sp + RtsFlags.GcFlags.stkChunkBufferSize,
625 old_stack->stack + old_stack->stack_size); )
626 {
627 size = stack_frame_sizeW((StgClosure*)sp);
628
629 // if including this frame would exceed the size of the
630 // new stack (taking into account the underflow frame),
631 // then stop at the previous frame.
632 if (sp + size > old_stack->sp + (new_stack->stack_size -
633 sizeofW(StgUnderflowFrame))) {
634 break;
635 }
636 sp += size;
637 }
638
639 if (sp == old_stack->stack + old_stack->stack_size) {
640 //
641 // the old stack chunk is now empty, so we do *not* insert
642 // an underflow frame pointing back to it. There are two
643 // cases: either the old stack chunk was the last one, in
644 // which case it ends with a STOP_FRAME, or it is not the
645 // last one, and it already ends with an UNDERFLOW_FRAME
646 // pointing to the previous chunk. In the latter case, we
647 // will copy the UNDERFLOW_FRAME into the new stack chunk.
648 // In both cases, the old chunk will be subsequently GC'd.
649 //
650 // With the default settings, -ki1k -kb1k, this means the
651 // first stack chunk will be discarded after the first
652 // overflow, being replaced by a non-moving 32k chunk.
653 //
654 } else {
655 new_stack->sp -= sizeofW(StgUnderflowFrame);
656 frame = (StgUnderflowFrame*)new_stack->sp;
657 frame->info = &stg_stack_underflow_frame_info;
658 frame->next_chunk = old_stack;
659 }
660
661 // copy the stack chunk between tso->sp and sp to
662 // new_tso->sp + (tso->sp - sp)
663 chunk_words = sp - old_stack->sp;
664
665 memcpy(/* dest */ new_stack->sp - chunk_words,
666 /* source */ old_stack->sp,
667 /* size */ chunk_words * sizeof(W_));
668
669 old_stack->sp += chunk_words;
670 new_stack->sp -= chunk_words;
671 }
672
673 tso->stackobj = new_stack;
674
675 // we're about to run it, better mark it dirty
676 dirty_STACK(cap, new_stack);
677
678 IF_DEBUG(sanity,checkTSO(tso));
679 // IF_DEBUG(scheduler,printTSO(new_tso));
680 }
681
682
683
684 /* ---------------------------------------------------------------------------
685 Stack underflow - called from the stg_stack_underflow_info frame
686 ------------------------------------------------------------------------ */
687
688 W_ // returns offset to the return address
689 threadStackUnderflow (Capability *cap, StgTSO *tso)
690 {
691 StgStack *new_stack, *old_stack;
692 StgUnderflowFrame *frame;
693 uint32_t retvals;
694
695 debugTraceCap(DEBUG_sched, cap, "stack underflow");
696
697 old_stack = tso->stackobj;
698
699 frame = (StgUnderflowFrame*)(old_stack->stack + old_stack->stack_size
700 - sizeofW(StgUnderflowFrame));
701 ASSERT(frame->info == &stg_stack_underflow_frame_info);
702
703 new_stack = (StgStack*)frame->next_chunk;
704 tso->stackobj = new_stack;
705
706 retvals = (P_)frame - old_stack->sp;
707 if (retvals != 0)
708 {
709 // we have some return values to copy to the old stack
710 if ((W_)(new_stack->sp - new_stack->stack) < retvals)
711 {
712 barf("threadStackUnderflow: not enough space for return values");
713 }
714
715 new_stack->sp -= retvals;
716
717 memcpy(/* dest */ new_stack->sp,
718 /* src */ old_stack->sp,
719 /* size */ retvals * sizeof(W_));
720 }
721
722 // empty the old stack. The GC may still visit this object
723 // because it is on the mutable list.
724 old_stack->sp = old_stack->stack + old_stack->stack_size;
725
726 // restore the stack parameters, and update tot_stack_size
727 tso->tot_stack_size -= old_stack->stack_size;
728
729 // we're about to run it, better mark it dirty
730 dirty_STACK(cap, new_stack);
731
732 return retvals;
733 }
734
735 /* ----------------------------------------------------------------------------
736 Implementation of tryPutMVar#
737
738 NOTE: this should be kept in sync with stg_tryPutMVarzh in PrimOps.cmm
739 ------------------------------------------------------------------------- */
740
741 bool performTryPutMVar(Capability *cap, StgMVar *mvar, StgClosure *value)
742 {
743 const StgInfoTable *info;
744 StgMVarTSOQueue *q;
745 StgTSO *tso;
746
747 info = lockClosure((StgClosure*)mvar);
748
749 if (mvar->value != &stg_END_TSO_QUEUE_closure) {
750 #if defined(THREADED_RTS)
751 unlockClosure((StgClosure*)mvar, info);
752 #endif
753 return false;
754 }
755
756 q = mvar->head;
757 loop:
758 if (q == (StgMVarTSOQueue*)&stg_END_TSO_QUEUE_closure) {
759 /* No further takes, the MVar is now full. */
760 if (info == &stg_MVAR_CLEAN_info) {
761 dirty_MVAR(&cap->r, (StgClosure*)mvar);
762 }
763
764 mvar->value = value;
765 unlockClosure((StgClosure*)mvar, &stg_MVAR_DIRTY_info);
766 return true;
767 }
768 if (q->header.info == &stg_IND_info ||
769 q->header.info == &stg_MSG_NULL_info) {
770 q = (StgMVarTSOQueue*)((StgInd*)q)->indirectee;
771 goto loop;
772 }
773
774 // There are takeMVar(s) waiting: wake up the first one
775 tso = q->tso;
776 mvar->head = q->link;
777 if (mvar->head == (StgMVarTSOQueue*)&stg_END_TSO_QUEUE_closure) {
778 mvar->tail = (StgMVarTSOQueue*)&stg_END_TSO_QUEUE_closure;
779 }
780
781 ASSERT(tso->block_info.closure == (StgClosure*)mvar);
782 // save why_blocked here, because waking up the thread destroys
783 // this information
784 StgWord why_blocked = tso->why_blocked;
785
786 // actually perform the takeMVar
787 StgStack* stack = tso->stackobj;
788 stack->sp[1] = (W_)value;
789 stack->sp[0] = (W_)&stg_ret_p_info;
790
791 // indicate that the MVar operation has now completed.
792 tso->_link = (StgTSO*)&stg_END_TSO_QUEUE_closure;
793
794 if (stack->dirty == 0) {
795 dirty_STACK(cap, stack);
796 }
797
798 tryWakeupThread(cap, tso);
799
800 // If it was a readMVar, then we can still do work,
801 // so loop back. (XXX: This could take a while)
802 if (why_blocked == BlockedOnMVarRead) {
803 q = ((StgMVarTSOQueue*)q)->link;
804 goto loop;
805 }
806
807 ASSERT(why_blocked == BlockedOnMVar);
808
809 unlockClosure((StgClosure*)mvar, info);
810
811 return true;
812 }
813
814 /* ----------------------------------------------------------------------------
815 * Debugging: why is a thread blocked
816 * ------------------------------------------------------------------------- */
817
818 #if defined(DEBUG)
819 void
820 printThreadBlockage(StgTSO *tso)
821 {
822 switch (tso->why_blocked) {
823 #if defined(mingw32_HOST_OS)
824 case BlockedOnDoProc:
825 debugBelch("is blocked on proc (request: %u)", tso->block_info.async_result->reqID);
826 break;
827 #endif
828 #if !defined(THREADED_RTS)
829 case BlockedOnRead:
830 debugBelch("is blocked on read from fd %d", (int)(tso->block_info.fd));
831 break;
832 case BlockedOnWrite:
833 debugBelch("is blocked on write to fd %d", (int)(tso->block_info.fd));
834 break;
835 case BlockedOnDelay:
836 debugBelch("is blocked until %ld", (long)(tso->block_info.target));
837 break;
838 #endif
839 case BlockedOnMVar:
840 debugBelch("is blocked on an MVar @ %p", tso->block_info.closure);
841 break;
842 case BlockedOnMVarRead:
843 debugBelch("is blocked on atomic MVar read @ %p", tso->block_info.closure);
844 break;
845 case BlockedOnBlackHole:
846 debugBelch("is blocked on a black hole %p",
847 ((StgBlockingQueue*)tso->block_info.bh->bh));
848 break;
849 case BlockedOnMsgThrowTo:
850 debugBelch("is blocked on a throwto message");
851 break;
852 case NotBlocked:
853 debugBelch("is not blocked");
854 break;
855 case ThreadMigrating:
856 debugBelch("is runnable, but not on the run queue");
857 break;
858 case BlockedOnCCall:
859 debugBelch("is blocked on an external call");
860 break;
861 case BlockedOnCCall_Interruptible:
862 debugBelch("is blocked on an external call (but may be interrupted)");
863 break;
864 case BlockedOnSTM:
865 debugBelch("is blocked on an STM operation");
866 break;
867 default:
868 barf("printThreadBlockage: strange tso->why_blocked: %d for TSO %d (%d)",
869 tso->why_blocked, tso->id, tso);
870 }
871 }
872
873
874 void
875 printThreadStatus(StgTSO *t)
876 {
877 debugBelch("\tthread %4lu @ %p ", (unsigned long)t->id, (void *)t);
878 {
879 void *label = lookupThreadLabel(t->id);
880 if (label) debugBelch("[\"%s\"] ",(char *)label);
881 }
882 switch (t->what_next) {
883 case ThreadKilled:
884 debugBelch("has been killed");
885 break;
886 case ThreadComplete:
887 debugBelch("has completed");
888 break;
889 default:
890 printThreadBlockage(t);
891 }
892 if (t->dirty) {
893 debugBelch(" (TSO_DIRTY)");
894 }
895 debugBelch("\n");
896 }
897
898 void
899 printAllThreads(void)
900 {
901 StgTSO *t, *next;
902 uint32_t i, g;
903 Capability *cap;
904
905 debugBelch("all threads:\n");
906
907 for (i = 0; i < n_capabilities; i++) {
908 cap = capabilities[i];
909 debugBelch("threads on capability %d:\n", cap->no);
910 for (t = cap->run_queue_hd; t != END_TSO_QUEUE; t = t->_link) {
911 printThreadStatus(t);
912 }
913 }
914
915 debugBelch("other threads:\n");
916 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
917 for (t = generations[g].threads; t != END_TSO_QUEUE; t = next) {
918 if (t->why_blocked != NotBlocked) {
919 printThreadStatus(t);
920 }
921 next = t->global_link;
922 }
923 }
924 }
925
926 // useful from gdb
927 void
928 printThreadQueue(StgTSO *t)
929 {
930 uint32_t i = 0;
931 for (; t != END_TSO_QUEUE; t = t->_link) {
932 printThreadStatus(t);
933 i++;
934 }
935 debugBelch("%d threads on queue\n", i);
936 }
937
938 #endif /* DEBUG */