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_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 = 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);
222 tso->why_blocked = NotBlocked;
224 tso->_link = END_TSO_QUEUE;
226 #if defined(THREADED_RTS)
227 if (tso->cap == cap || (!tsoLocked(tso) &&
229 RtsFlags.ParFlags.wakeupMigrate)) {
230 // We are waking up this thread on the current Capability, which
231 // might involve migrating it from the Capability it was last on.
233 ASSERT(tso->bound->cap == tso->cap);
234 tso->bound->cap = cap;
238 appendToRunQueue(cap,tso);
240 // context-switch soonish so we can migrate the new thread if
241 // necessary. NB. not contextSwitchCapability(cap), which would
242 // force a context switch immediately.
243 cap->context_switch = 1;
245 // we'll try to wake it up on the Capability it was last on.
246 wakeupThreadOnCapability(cap, tso->cap, tso);
249 appendToRunQueue(cap,tso);
251 // context-switch soonish so we can migrate the new thread if
252 // necessary. NB. not contextSwitchCapability(cap), which would
253 // force a context switch immediately.
254 cap->context_switch = 1;
257 traceEventThreadWakeup (cap, tso, tso->cap->no);
262 /* ----------------------------------------------------------------------------
265 wakes up all the threads on the specified queue.
266 ------------------------------------------------------------------------- */
269 awakenBlockedQueue(Capability *cap, StgTSO *tso)
271 while (tso != END_TSO_QUEUE) {
272 tso = unblockOne(cap,tso);
276 /* ---------------------------------------------------------------------------
277 * rtsSupportsBoundThreads(): is the RTS built to support bound threads?
278 * used by Control.Concurrent for error checking.
279 * ------------------------------------------------------------------------- */
282 rtsSupportsBoundThreads(void)
284 #if defined(THREADED_RTS)
287 return HS_BOOL_FALSE;
291 /* ---------------------------------------------------------------------------
292 * isThreadBound(tso): check whether tso is bound to an OS thread.
293 * ------------------------------------------------------------------------- */
296 isThreadBound(StgTSO* tso USED_IF_THREADS)
298 #if defined(THREADED_RTS)
299 return (tso->bound != NULL);
304 /* ----------------------------------------------------------------------------
305 * Debugging: why is a thread blocked
306 * ------------------------------------------------------------------------- */
310 printThreadBlockage(StgTSO *tso)
312 switch (tso->why_blocked) {
314 debugBelch("is blocked on read from fd %d", (int)(tso->block_info.fd));
317 debugBelch("is blocked on write to fd %d", (int)(tso->block_info.fd));
319 #if defined(mingw32_HOST_OS)
320 case BlockedOnDoProc:
321 debugBelch("is blocked on proc (request: %u)", tso->block_info.async_result->reqID);
325 debugBelch("is blocked until %ld", (long)(tso->block_info.target));
328 debugBelch("is blocked on an MVar @ %p", tso->block_info.closure);
330 case BlockedOnException:
331 debugBelch("is blocked on delivering an exception to thread %lu",
332 (unsigned long)tso->block_info.tso->id);
334 case BlockedOnBlackHole:
335 debugBelch("is blocked on a black hole");
338 debugBelch("is not blocked");
341 debugBelch("is blocked on an external call");
343 case BlockedOnCCall_NoUnblockExc:
344 debugBelch("is blocked on an external call (exceptions were already blocked)");
347 debugBelch("is blocked on an STM operation");
350 barf("printThreadBlockage: strange tso->why_blocked: %d for TSO %d (%d)",
351 tso->why_blocked, tso->id, tso);
357 printThreadStatus(StgTSO *t)
359 debugBelch("\tthread %4lu @ %p ", (unsigned long)t->id, (void *)t);
361 void *label = lookupThreadLabel(t->id);
362 if (label) debugBelch("[\"%s\"] ",(char *)label);
364 if (t->what_next == ThreadRelocated) {
365 debugBelch("has been relocated...\n");
367 switch (t->what_next) {
369 debugBelch("has been killed");
372 debugBelch("has completed");
375 printThreadBlockage(t);
378 debugBelch(" (TSO_DIRTY)");
379 } else if (t->flags & TSO_LINK_DIRTY) {
380 debugBelch(" (TSO_LINK_DIRTY)");
387 printAllThreads(void)
394 char time_string[TIME_STR_LEN], node_str[NODE_STR_LEN];
395 ullong_format_string(TIME_ON_PROC(CurrentProc),
396 time_string, rtsFalse/*no commas!*/);
398 debugBelch("all threads at [%s]:\n", time_string);
399 # elif defined(PARALLEL_HASKELL)
400 char time_string[TIME_STR_LEN], node_str[NODE_STR_LEN];
401 ullong_format_string(CURRENT_TIME,
402 time_string, rtsFalse/*no commas!*/);
404 debugBelch("all threads at [%s]:\n", time_string);
406 debugBelch("all threads:\n");
409 for (i = 0; i < n_capabilities; i++) {
410 cap = &capabilities[i];
411 debugBelch("threads on capability %d:\n", cap->no);
412 for (t = cap->run_queue_hd; t != END_TSO_QUEUE; t = t->_link) {
413 printThreadStatus(t);
417 debugBelch("other threads:\n");
418 for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
419 for (t = generations[g].threads; t != END_TSO_QUEUE; t = next) {
420 if (t->why_blocked != NotBlocked) {
421 printThreadStatus(t);
423 if (t->what_next == ThreadRelocated) {
426 next = t->global_link;
434 printThreadQueue(StgTSO *t)
437 for (; t != END_TSO_QUEUE; t = t->_link) {
438 printThreadStatus(t);
441 debugBelch("%d threads on queue\n", i);