1 /* ---------------------------------------------------------------------------
3 * (c) The GHC Team, 2006
5 * Thread-related functionality
7 * --------------------------------------------------------------------------*/
9 #include "PosixSource.h"
16 #include "ThreadLabels.h"
18 /* Next thread ID to allocate.
21 static StgThreadID next_thread_id = 1;
23 /* The smallest stack size that makes any sense is:
24 * RESERVED_STACK_WORDS (so we can get back from the stack overflow)
25 * + sizeofW(StgStopFrame) (the stg_stop_thread_info frame)
26 * + 1 (the closure to enter)
28 * + 1 (spare slot req'd by stg_ap_v_ret)
30 * A thread with this stack will bomb immediately with a stack
31 * overflow, which will increase its stack size.
33 #define MIN_STACK_WORDS (RESERVED_STACK_WORDS + sizeofW(StgStopFrame) + 3)
35 /* ---------------------------------------------------------------------------
38 The new thread starts with the given stack size. Before the
39 scheduler can run, however, this thread needs to have a closure
40 (and possibly some arguments) pushed on its stack. See
41 pushClosure() in Schedule.h.
43 createGenThread() and createIOThread() (in SchedAPI.h) are
44 convenient packaged versions of this function.
46 currently pri (priority) is only used in a GRAN setup -- HWL
47 ------------------------------------------------------------------------ */
49 createThread(Capability *cap, nat size)
54 /* sched_mutex is *not* required */
56 /* First check whether we should create a thread at all */
58 // ToDo: check whether size = stack_size - TSO_STRUCT_SIZEW
60 /* catch ridiculously small stack sizes */
61 if (size < MIN_STACK_WORDS + TSO_STRUCT_SIZEW) {
62 size = MIN_STACK_WORDS + TSO_STRUCT_SIZEW;
65 size = round_to_mblocks(size);
66 tso = (StgTSO *)allocate(cap, size);
68 stack_size = size - TSO_STRUCT_SIZEW;
69 TICK_ALLOC_TSO(stack_size, 0);
71 SET_HDR(tso, &stg_TSO_info, CCS_SYSTEM);
73 // Always start with the compiled code evaluator
74 tso->what_next = ThreadRunGHC;
76 tso->why_blocked = NotBlocked;
77 tso->blocked_exceptions = END_BLOCKED_EXCEPTIONS_QUEUE;
85 tso->stack_size = stack_size;
86 tso->max_stack_size = round_to_mblocks(RtsFlags.GcFlags.maxStkSize)
88 tso->sp = (P_)&(tso->stack) + stack_size;
93 tso->prof.CCCS = CCS_MAIN;
96 /* put a stop frame on the stack */
97 tso->sp -= sizeofW(StgStopFrame);
98 SET_HDR((StgClosure*)tso->sp,(StgInfoTable *)&stg_stop_thread_info,CCS_SYSTEM);
99 tso->_link = END_TSO_QUEUE;
101 /* Link the new thread on the global thread list.
103 ACQUIRE_LOCK(&sched_mutex);
104 tso->id = next_thread_id++; // while we have the mutex
105 tso->global_link = g0->threads;
107 RELEASE_LOCK(&sched_mutex);
109 // ToDo: report the stack size in the event?
110 traceEventCreateThread(cap, tso);
115 /* ---------------------------------------------------------------------------
116 * Comparing Thread ids.
118 * This is used from STG land in the implementation of the
119 * instances of Eq/Ord for ThreadIds.
120 * ------------------------------------------------------------------------ */
123 cmp_thread(StgPtr tso1, StgPtr tso2)
125 StgThreadID id1 = ((StgTSO *)tso1)->id;
126 StgThreadID id2 = ((StgTSO *)tso2)->id;
128 if (id1 < id2) return (-1);
129 if (id1 > id2) return 1;
133 /* ---------------------------------------------------------------------------
134 * Fetching the ThreadID from an StgTSO.
136 * This is used in the implementation of Show for ThreadIds.
137 * ------------------------------------------------------------------------ */
139 rts_getThreadId(StgPtr tso)
141 return ((StgTSO *)tso)->id;
144 /* -----------------------------------------------------------------------------
145 Remove a thread from a queue.
146 Fails fatally if the TSO is not on the queue.
147 -------------------------------------------------------------------------- */
150 removeThreadFromQueue (Capability *cap, StgTSO **queue, StgTSO *tso)
155 for (t = *queue; t != END_TSO_QUEUE; prev = t, t = t->_link) {
158 setTSOLink(cap,prev,t->_link);
165 barf("removeThreadFromQueue: not found");
169 removeThreadFromDeQueue (Capability *cap,
170 StgTSO **head, StgTSO **tail, StgTSO *tso)
175 for (t = *head; t != END_TSO_QUEUE; prev = t, t = t->_link) {
178 setTSOLink(cap,prev,t->_link);
186 *tail = END_TSO_QUEUE;
192 barf("removeThreadFromMVarQueue: not found");
196 removeThreadFromMVarQueue (Capability *cap, StgMVar *mvar, StgTSO *tso)
198 removeThreadFromDeQueue (cap, &mvar->head, &mvar->tail, tso);
201 /* ----------------------------------------------------------------------------
204 unblock a single thread.
205 ------------------------------------------------------------------------- */
208 unblockOne (Capability *cap, StgTSO *tso)
210 return unblockOne_(cap,tso,rtsTrue); // allow migration
214 unblockOne_ (Capability *cap, StgTSO *tso,
215 rtsBool allow_migrate USED_IF_THREADS)
219 // NO, might be a WHITEHOLE: ASSERT(get_itbl(tso)->type == TSO);
220 ASSERT(tso->why_blocked != NotBlocked);
221 ASSERT(tso->why_blocked != BlockedOnMsgWakeup ||
222 tso->block_info.closure->header.info == &stg_IND_info);
225 tso->_link = END_TSO_QUEUE;
227 #if defined(THREADED_RTS)
228 if (tso->cap == cap || (!tsoLocked(tso) &&
230 RtsFlags.ParFlags.wakeupMigrate)) {
231 // We are waking up this thread on the current Capability, which
232 // might involve migrating it from the Capability it was last on.
234 ASSERT(tso->bound->task->cap == tso->cap);
235 tso->bound->task->cap = cap;
240 tso->why_blocked = NotBlocked;
241 appendToRunQueue(cap,tso);
243 // context-switch soonish so we can migrate the new thread if
244 // necessary. NB. not contextSwitchCapability(cap), which would
245 // force a context switch immediately.
246 cap->context_switch = 1;
248 // we'll try to wake it up on the Capability it was last on.
249 wakeupThreadOnCapability(cap, tso->cap, tso);
252 tso->why_blocked = NotBlocked;
253 appendToRunQueue(cap,tso);
255 // context-switch soonish so we can migrate the new thread if
256 // necessary. NB. not contextSwitchCapability(cap), which would
257 // force a context switch immediately.
258 cap->context_switch = 1;
261 traceEventThreadWakeup (cap, tso, tso->cap->no);
266 /* ----------------------------------------------------------------------------
269 wakes up all the threads on the specified queue.
270 ------------------------------------------------------------------------- */
273 awakenBlockedQueue(Capability *cap, StgTSO *tso)
275 while (tso != END_TSO_QUEUE) {
276 tso = unblockOne(cap,tso);
280 /* ---------------------------------------------------------------------------
281 * rtsSupportsBoundThreads(): is the RTS built to support bound threads?
282 * used by Control.Concurrent for error checking.
283 * ------------------------------------------------------------------------- */
286 rtsSupportsBoundThreads(void)
288 #if defined(THREADED_RTS)
291 return HS_BOOL_FALSE;
295 /* ---------------------------------------------------------------------------
296 * isThreadBound(tso): check whether tso is bound to an OS thread.
297 * ------------------------------------------------------------------------- */
300 isThreadBound(StgTSO* tso USED_IF_THREADS)
302 #if defined(THREADED_RTS)
303 return (tso->bound != NULL);
308 /* ----------------------------------------------------------------------------
309 * Debugging: why is a thread blocked
310 * ------------------------------------------------------------------------- */
314 printThreadBlockage(StgTSO *tso)
316 switch (tso->why_blocked) {
318 debugBelch("is blocked on read from fd %d", (int)(tso->block_info.fd));
321 debugBelch("is blocked on write to fd %d", (int)(tso->block_info.fd));
323 #if defined(mingw32_HOST_OS)
324 case BlockedOnDoProc:
325 debugBelch("is blocked on proc (request: %u)", tso->block_info.async_result->reqID);
329 debugBelch("is blocked until %ld", (long)(tso->block_info.target));
332 debugBelch("is blocked on an MVar @ %p", tso->block_info.closure);
334 case BlockedOnBlackHole:
335 debugBelch("is blocked on a black hole");
337 case BlockedOnMsgWakeup:
338 debugBelch("is blocked on a wakeup message");
340 case BlockedOnMsgThrowTo:
341 debugBelch("is blocked on a throwto message");
344 debugBelch("is not blocked");
347 debugBelch("is blocked on an external call");
349 case BlockedOnCCall_NoUnblockExc:
350 debugBelch("is blocked on an external call (exceptions were already blocked)");
353 debugBelch("is blocked on an STM operation");
356 barf("printThreadBlockage: strange tso->why_blocked: %d for TSO %d (%d)",
357 tso->why_blocked, tso->id, tso);
363 printThreadStatus(StgTSO *t)
365 debugBelch("\tthread %4lu @ %p ", (unsigned long)t->id, (void *)t);
367 void *label = lookupThreadLabel(t->id);
368 if (label) debugBelch("[\"%s\"] ",(char *)label);
370 if (t->what_next == ThreadRelocated) {
371 debugBelch("has been relocated...\n");
373 switch (t->what_next) {
375 debugBelch("has been killed");
378 debugBelch("has completed");
381 printThreadBlockage(t);
384 debugBelch(" (TSO_DIRTY)");
385 } else if (t->flags & TSO_LINK_DIRTY) {
386 debugBelch(" (TSO_LINK_DIRTY)");
393 printAllThreads(void)
399 debugBelch("all threads:\n");
401 for (i = 0; i < n_capabilities; i++) {
402 cap = &capabilities[i];
403 debugBelch("threads on capability %d:\n", cap->no);
404 for (t = cap->run_queue_hd; t != END_TSO_QUEUE; t = t->_link) {
405 printThreadStatus(t);
409 debugBelch("other threads:\n");
410 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
411 for (t = generations[g].threads; t != END_TSO_QUEUE; t = next) {
412 if (t->why_blocked != NotBlocked) {
413 printThreadStatus(t);
415 if (t->what_next == ThreadRelocated) {
418 next = t->global_link;
426 printThreadQueue(StgTSO *t)
429 for (; t != END_TSO_QUEUE; t = t->_link) {
430 printThreadStatus(t);
433 debugBelch("%d threads on queue\n", i);