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