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 *)allocateLocal(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_TSO_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 = g0s0->threads;
107 RELEASE_LOCK(&sched_mutex);
109 postEvent (cap, EVENT_CREATE_THREAD, tso->id, 0);
111 debugTrace(DEBUG_sched,
112 "created thread %ld, stack size = %lx words",
113 (long)tso->id, (long)tso->stack_size);
117 /* ---------------------------------------------------------------------------
118 * Comparing Thread ids.
120 * This is used from STG land in the implementation of the
121 * instances of Eq/Ord for ThreadIds.
122 * ------------------------------------------------------------------------ */
125 cmp_thread(StgPtr tso1, StgPtr tso2)
127 StgThreadID id1 = ((StgTSO *)tso1)->id;
128 StgThreadID id2 = ((StgTSO *)tso2)->id;
130 if (id1 < id2) return (-1);
131 if (id1 > id2) return 1;
135 /* ---------------------------------------------------------------------------
136 * Fetching the ThreadID from an StgTSO.
138 * This is used in the implementation of Show for ThreadIds.
139 * ------------------------------------------------------------------------ */
141 rts_getThreadId(StgPtr tso)
143 return ((StgTSO *)tso)->id;
146 /* -----------------------------------------------------------------------------
147 Remove a thread from a queue.
148 Fails fatally if the TSO is not on the queue.
149 -------------------------------------------------------------------------- */
152 removeThreadFromQueue (Capability *cap, StgTSO **queue, StgTSO *tso)
157 for (t = *queue; t != END_TSO_QUEUE; prev = t, t = t->_link) {
160 setTSOLink(cap,prev,t->_link);
167 barf("removeThreadFromQueue: not found");
171 removeThreadFromDeQueue (Capability *cap,
172 StgTSO **head, StgTSO **tail, StgTSO *tso)
177 for (t = *head; t != END_TSO_QUEUE; prev = t, t = t->_link) {
180 setTSOLink(cap,prev,t->_link);
188 *tail = END_TSO_QUEUE;
194 barf("removeThreadFromMVarQueue: not found");
198 removeThreadFromMVarQueue (Capability *cap, StgMVar *mvar, StgTSO *tso)
200 removeThreadFromDeQueue (cap, &mvar->head, &mvar->tail, tso);
203 /* ----------------------------------------------------------------------------
206 unblock a single thread.
207 ------------------------------------------------------------------------- */
210 unblockOne (Capability *cap, StgTSO *tso)
212 return unblockOne_(cap,tso,rtsTrue); // allow migration
216 unblockOne_ (Capability *cap, StgTSO *tso,
217 rtsBool allow_migrate USED_IF_THREADS)
221 // NO, might be a WHITEHOLE: ASSERT(get_itbl(tso)->type == TSO);
222 ASSERT(tso->why_blocked != NotBlocked);
224 tso->why_blocked = NotBlocked;
226 tso->_link = END_TSO_QUEUE;
228 #if defined(THREADED_RTS)
229 if (tso->cap == cap || (!tsoLocked(tso) &&
231 RtsFlags.ParFlags.wakeupMigrate)) {
232 // We are waking up this thread on the current Capability, which
233 // might involve migrating it from the Capability it was last on.
235 ASSERT(tso->bound->cap == tso->cap);
236 tso->bound->cap = cap;
240 appendToRunQueue(cap,tso);
242 // context-switch soonish so we can migrate the new thread if
243 // necessary. NB. not contextSwitchCapability(cap), which would
244 // force a context switch immediately.
245 cap->context_switch = 1;
247 // we'll try to wake it up on the Capability it was last on.
248 wakeupThreadOnCapability(cap, tso->cap, tso);
251 appendToRunQueue(cap,tso);
253 // context-switch soonish so we can migrate the new thread if
254 // necessary. NB. not contextSwitchCapability(cap), which would
255 // force a context switch immediately.
256 cap->context_switch = 1;
259 postEvent (cap, EVENT_THREAD_WAKEUP, tso->id, tso->cap->no);
261 debugTrace(DEBUG_sched, "waking up thread %ld on cap %d",
262 (long)tso->id, tso->cap->no);
267 /* ----------------------------------------------------------------------------
270 wakes up all the threads on the specified queue.
271 ------------------------------------------------------------------------- */
274 awakenBlockedQueue(Capability *cap, StgTSO *tso)
276 while (tso != END_TSO_QUEUE) {
277 tso = unblockOne(cap,tso);
281 /* ---------------------------------------------------------------------------
282 * rtsSupportsBoundThreads(): is the RTS built to support bound threads?
283 * used by Control.Concurrent for error checking.
284 * ------------------------------------------------------------------------- */
287 rtsSupportsBoundThreads(void)
289 #if defined(THREADED_RTS)
292 return HS_BOOL_FALSE;
296 /* ---------------------------------------------------------------------------
297 * isThreadBound(tso): check whether tso is bound to an OS thread.
298 * ------------------------------------------------------------------------- */
301 isThreadBound(StgTSO* tso USED_IF_THREADS)
303 #if defined(THREADED_RTS)
304 return (tso->bound != NULL);
309 /* ----------------------------------------------------------------------------
310 * Debugging: why is a thread blocked
311 * ------------------------------------------------------------------------- */
315 printThreadBlockage(StgTSO *tso)
317 switch (tso->why_blocked) {
319 debugBelch("is blocked on read from fd %d", (int)(tso->block_info.fd));
322 debugBelch("is blocked on write to fd %d", (int)(tso->block_info.fd));
324 #if defined(mingw32_HOST_OS)
325 case BlockedOnDoProc:
326 debugBelch("is blocked on proc (request: %u)", tso->block_info.async_result->reqID);
330 debugBelch("is blocked until %ld", (long)(tso->block_info.target));
333 debugBelch("is blocked on an MVar @ %p", tso->block_info.closure);
335 case BlockedOnException:
336 debugBelch("is blocked on delivering an exception to thread %lu",
337 (unsigned long)tso->block_info.tso->id);
339 case BlockedOnBlackHole:
340 debugBelch("is blocked on a black hole");
343 debugBelch("is not blocked");
346 debugBelch("is blocked on an external call");
348 case BlockedOnCCall_NoUnblockExc:
349 debugBelch("is blocked on an external call (exceptions were already blocked)");
352 debugBelch("is blocked on an STM operation");
355 barf("printThreadBlockage: strange tso->why_blocked: %d for TSO %d (%d)",
356 tso->why_blocked, tso->id, tso);
361 printThreadStatus(StgTSO *t)
363 debugBelch("\tthread %4lu @ %p ", (unsigned long)t->id, (void *)t);
365 void *label = lookupThreadLabel(t->id);
366 if (label) debugBelch("[\"%s\"] ",(char *)label);
368 if (t->what_next == ThreadRelocated) {
369 debugBelch("has been relocated...\n");
371 switch (t->what_next) {
373 debugBelch("has been killed");
376 debugBelch("has completed");
379 printThreadBlockage(t);
382 debugBelch(" (TSO_DIRTY)");
383 } else if (t->flags & TSO_LINK_DIRTY) {
384 debugBelch(" (TSO_LINK_DIRTY)");
391 printAllThreads(void)
398 char time_string[TIME_STR_LEN], node_str[NODE_STR_LEN];
399 ullong_format_string(TIME_ON_PROC(CurrentProc),
400 time_string, rtsFalse/*no commas!*/);
402 debugBelch("all threads at [%s]:\n", time_string);
403 # elif defined(PARALLEL_HASKELL)
404 char time_string[TIME_STR_LEN], node_str[NODE_STR_LEN];
405 ullong_format_string(CURRENT_TIME,
406 time_string, rtsFalse/*no commas!*/);
408 debugBelch("all threads at [%s]:\n", time_string);
410 debugBelch("all threads:\n");
413 for (i = 0; i < n_capabilities; i++) {
414 cap = &capabilities[i];
415 debugBelch("threads on capability %d:\n", cap->no);
416 for (t = cap->run_queue_hd; t != END_TSO_QUEUE; t = t->_link) {
417 printThreadStatus(t);
421 debugBelch("other threads:\n");
422 for (s = 0; s < total_steps; s++) {
423 for (t = all_steps[s].threads; t != END_TSO_QUEUE; t = next) {
424 if (t->why_blocked != NotBlocked) {
425 printThreadStatus(t);
427 if (t->what_next == ThreadRelocated) {
430 next = t->global_link;
438 printThreadQueue(StgTSO *t)
441 for (; t != END_TSO_QUEUE; t = t->_link) {
442 printThreadStatus(t);
445 debugBelch("%d threads on queue\n", i);