/* ---------------------------------------------------------------------------
- * $Id: Schedule.c,v 1.183 2003/12/16 13:27:32 simonmar Exp $
+ * $Id: Schedule.c,v 1.194 2004/03/13 00:56:45 sof Exp $
*
* (c) The GHC Team, 1998-2003
*
Mutex sched_mutex = INIT_MUTEX_VAR;
Mutex term_mutex = INIT_MUTEX_VAR;
-/*
- * A heavyweight solution to the problem of protecting
- * the thread_id from concurrent update.
- */
-Mutex thread_id_mutex = INIT_MUTEX_VAR;
-
#endif /* RTS_SUPPORTS_THREADS */
#if defined(PAR)
taskStart(void)
{
ACQUIRE_LOCK(&sched_mutex);
+ startingWorkerThread = rtsFalse;
schedule(NULL,NULL);
RELEASE_LOCK(&sched_mutex);
}
Capability *initialCapability )
{
StgTSO *t;
- Capability *cap = initialCapability;
+ Capability *cap;
StgThreadReturnCode ret;
#if defined(GRAN)
rtsEvent *event;
StgTSOWhatNext prev_what_next;
// Pre-condition: sched_mutex is held.
-
+ // We might have a capability, passed in as initialCapability.
+ cap = initialCapability;
+
#if defined(RTS_SUPPORTS_THREADS)
//
// in the threaded case, the capability is either passed in via the
#endif
}
- //
- // Go through the list of main threads and wake up any
- // clients whose computations have finished. ToDo: this
- // should be done more efficiently without a linear scan
- // of the main threads list, somehow...
- //
-#if defined(RTS_SUPPORTS_THREADS)
- {
- StgMainThread *m, **prev;
- prev = &main_threads;
- for (m = main_threads; m != NULL; prev = &m->link, m = m->link) {
- if (m->tso->what_next == ThreadComplete
- || m->tso->what_next == ThreadKilled)
- {
- if (m == mainThread)
- {
- if (m->tso->what_next == ThreadComplete)
- {
- if (m->ret)
- {
- // NOTE: return val is tso->sp[1] (see StgStartup.hc)
- *(m->ret) = (StgClosure *)m->tso->sp[1];
- }
- m->stat = Success;
- }
- else
- {
- if (m->ret)
- {
- *(m->ret) = NULL;
- }
- if (was_interrupted)
- {
- m->stat = Interrupted;
- }
- else
- {
- m->stat = Killed;
- }
- }
- *prev = m->link;
-
-#ifdef DEBUG
- removeThreadLabel((StgWord)m->tso->id);
-#endif
- releaseCapability(cap);
- return;
- }
- else
- {
- // The current OS thread can not handle the fact that
- // the Haskell thread "m" has ended. "m" is bound;
- // the scheduler loop in it's bound OS thread has to
- // return, so let's pass our capability directly to
- // that thread.
- passCapability(&m->bound_thread_cond);
- }
- }
- }
- }
-
-#else /* not threaded */
-
-# if defined(PAR)
- /* in GUM do this only on the Main PE */
- if (IAmMainThread)
-# endif
- /* If our main thread has finished or been killed, return.
- */
- {
- StgMainThread *m = main_threads;
- if (m->tso->what_next == ThreadComplete
- || m->tso->what_next == ThreadKilled) {
-#ifdef DEBUG
- removeThreadLabel((StgWord)m->tso->id);
-#endif
- main_threads = main_threads->link;
- if (m->tso->what_next == ThreadComplete) {
- // We finished successfully, fill in the return value
- // NOTE: return val is tso->sp[1] (see StgStartup.hc)
- if (m->ret) { *(m->ret) = (StgClosure *)m->tso->sp[1]; };
- m->stat = Success;
- return;
- } else {
- if (m->ret) { *(m->ret) = NULL; };
- if (was_interrupted) {
- m->stat = Interrupted;
- } else {
- m->stat = Killed;
- }
- return;
- }
- }
- }
-#endif
-
-
#if defined(RTS_USER_SIGNALS)
// check for signals each time around the scheduler
if (signals_pending()) {
}
#endif
- /* Check whether any waiting threads need to be woken up. If the
- * run queue is empty, and there are no other tasks running, we
- * can wait indefinitely for something to happen.
- */
- if ( !EMPTY_QUEUE(blocked_queue_hd) || !EMPTY_QUEUE(sleeping_queue)
+ //
+ // Check whether any waiting threads need to be woken up. If the
+ // run queue is empty, and there are no other tasks running, we
+ // can wait indefinitely for something to happen.
+ //
+ if ( !EMPTY_QUEUE(blocked_queue_hd) || !EMPTY_QUEUE(sleeping_queue)
#if defined(RTS_SUPPORTS_THREADS)
|| EMPTY_RUN_QUEUE()
#endif
- )
+ )
{
awaitEvent( EMPTY_RUN_QUEUE() );
}
- /* we can be interrupted while waiting for I/O... */
+ // we can be interrupted while waiting for I/O...
if (interrupted) continue;
/*
m = main_threads;
switch (m->tso->why_blocked) {
case BlockedOnBlackHole:
- raiseAsync(m->tso, (StgClosure *)NonTermination_closure);
- break;
case BlockedOnException:
case BlockedOnMVar:
- raiseAsync(m->tso, (StgClosure *)Deadlock_closure);
+ raiseAsync(m->tso, (StgClosure *)NonTermination_closure);
break;
default:
barf("deadlock: main thread blocked in a strange way");
#if defined(RTS_SUPPORTS_THREADS)
if ( EMPTY_RUN_QUEUE() ) {
- continue; // nothing to do
+ continue; // nothing to do
}
#endif
#ifdef THREADED_RTS
{
- StgMainThread *m;
- for(m = main_threads; m; m = m->link)
- {
- if(m->tso == t)
- break;
- }
+ StgMainThread *m = t->main;
if(m)
{
*/
threadPaused(t);
{
- StgMainThread *m;
/* enlarge the stack */
StgTSO *new_t = threadStackOverflow(t);
* main thread stack. It better not be on any other queues...
* (it shouldn't be).
*/
- for (m = main_threads; m != NULL; m = m->link) {
- if (m->tso == t) {
- m->tso = new_t;
- }
+ if (t->main != NULL) {
+ t->main->tso = new_t;
}
threadPaused(new_t);
PUSH_ON_RUN_QUEUE(new_t);
!RtsFlags.ParFlags.ParStats.Suppressed)
DumpEndEvent(CURRENT_PROC, t, rtsFalse /* not mandatory */);
#endif
+
+ //
+ // Check whether the thread that just completed was a main
+ // thread, and if so return with the result.
+ //
+ // There is an assumption here that all thread completion goes
+ // through this point; we need to make sure that if a thread
+ // ends up in the ThreadKilled state, that it stays on the run
+ // queue so it can be dealt with here.
+ //
+ if (
+#if defined(RTS_SUPPORTS_THREADS)
+ mainThread != NULL
+#else
+ mainThread->tso == t
+#endif
+ )
+ {
+ // We are a bound thread: this must be our thread that just
+ // completed.
+ ASSERT(mainThread->tso == t);
+
+ if (t->what_next == ThreadComplete) {
+ if (mainThread->ret) {
+ // NOTE: return val is tso->sp[1] (see StgStartup.hc)
+ *(mainThread->ret) = (StgClosure *)mainThread->tso->sp[1];
+ }
+ mainThread->stat = Success;
+ } else {
+ if (mainThread->ret) {
+ *(mainThread->ret) = NULL;
+ }
+ if (was_interrupted) {
+ mainThread->stat = Interrupted;
+ } else {
+ mainThread->stat = Killed;
+ }
+ }
+#ifdef DEBUG
+ removeThreadLabel((StgWord)mainThread->tso->id);
+#endif
+ if (mainThread->prev == NULL) {
+ main_threads = mainThread->link;
+ } else {
+ mainThread->prev->link = mainThread->link;
+ }
+ if (mainThread->link != NULL) {
+ mainThread->link->prev = NULL;
+ }
+ releaseCapability(cap);
+ return;
+ }
+
+#ifdef RTS_SUPPORTS_THREADS
+ ASSERT(t->main == NULL);
+#else
+ if (t->main != NULL) {
+ // Must be a main thread that is not the topmost one. Leave
+ // it on the run queue until the stack has unwound to the
+ // point where we can deal with this. Leaving it on the run
+ // queue also ensures that the garbage collector knows about
+ // this thread and its return value (it gets dropped from the
+ // all_threads list so there's no other way to find it).
+ APPEND_TO_RUN_QUEUE(t);
+ }
+#endif
break;
-
+
default:
barf("schedule: invalid thread return code %d", (int)ret);
}
isThreadBound(StgTSO* tso USED_IN_THREADED_RTS)
{
#ifdef THREADED_RTS
- StgMainThread *m;
- for(m = main_threads; m; m = m->link)
- {
- if(m->tso == tso)
- return rtsTrue;
- }
+ return (tso->main != NULL);
#endif
return rtsFalse;
}
* Singleton fork(). Do not copy any running threads.
* ------------------------------------------------------------------------- */
+#ifndef mingw32_TARGET_OS
+#define FORKPROCESS_PRIMOP_SUPPORTED
+#endif
+
+#ifdef FORKPROCESS_PRIMOP_SUPPORTED
static void
deleteThreadImmediately(StgTSO *tso);
-
+#endif
StgInt
-forkProcess(HsStablePtr *entry)
+forkProcess(HsStablePtr *entry
+#ifndef FORKPROCESS_PRIMOP_SUPPORTED
+ STG_UNUSED
+#endif
+ )
{
-#ifndef mingw32_TARGET_OS
+#ifdef FORKPROCESS_PRIMOP_SUPPORTED
pid_t pid;
StgTSO* t,*next;
StgMainThread *m;
// wipe the main thread list
while((m = main_threads) != NULL) {
main_threads = m->link;
-#ifdef THREADED_RTS
+# ifdef THREADED_RTS
closeCondition(&m->bound_thread_cond);
-#endif
+# endif
stgFree(m);
}
-#ifdef RTS_SUPPORTS_THREADS
+# ifdef RTS_SUPPORTS_THREADS
resetTaskManagerAfterFork(); // tell startTask() and friends that
startingWorkerThread = rtsFalse; // we have no worker threads any more
resetWorkerWakeupPipeAfterFork();
-#endif
+# endif
rc = rts_evalStableIO(entry, NULL); // run the action
rts_checkSchedStatus("forkProcess",rc);
hs_exit(); // clean up and exit
stg_exit(0);
}
-#else /* mingw32 */
- barf("forkProcess#: primop not implemented for mingw32, sorry!\n");
+#else /* !FORKPROCESS_PRIMOP_SUPPORTED */
+ barf("forkProcess#: primop not supported, sorry!\n");
return -1;
-#endif /* mingw32 */
+#endif
}
/* ---------------------------------------------------------------------------
cap->r.rCurrentTSO->link = suspended_ccalling_threads;
suspended_ccalling_threads = cap->r.rCurrentTSO;
-#if defined(RTS_SUPPORTS_THREADS)
- if(cap->r.rCurrentTSO->blocked_exceptions == NULL)
- {
+ if(cap->r.rCurrentTSO->blocked_exceptions == NULL) {
cap->r.rCurrentTSO->why_blocked = BlockedOnCCall;
cap->r.rCurrentTSO->blocked_exceptions = END_TSO_QUEUE;
- }
- else
- {
+ } else {
cap->r.rCurrentTSO->why_blocked = BlockedOnCCall_NoUnblockExc;
}
-#endif
/* Use the thread ID as the token; it should be unique */
tok = cap->r.rCurrentTSO->id;
}
tso->link = END_TSO_QUEUE;
-#if defined(RTS_SUPPORTS_THREADS)
- if(tso->why_blocked == BlockedOnCCall)
- {
+ if(tso->why_blocked == BlockedOnCCall) {
awakenBlockedQueueNoLock(tso->blocked_exceptions);
tso->blocked_exceptions = NULL;
}
-#endif
/* Reset blocking status */
tso->why_blocked = NotBlocked;
// Always start with the compiled code evaluator
tso->what_next = ThreadRunGHC;
- /* tso->id needs to be unique. For now we use a heavyweight mutex to
- * protect the increment operation on next_thread_id.
- * In future, we could use an atomic increment instead.
- */
- ACQUIRE_LOCK(&thread_id_mutex);
tso->id = next_thread_id++;
- RELEASE_LOCK(&thread_id_mutex);
-
tso->why_blocked = NotBlocked;
tso->blocked_exceptions = NULL;
tso->saved_errno = 0;
+ tso->main = NULL;
tso->stack_size = stack_size;
tso->max_stack_size = round_to_mblocks(RtsFlags.GcFlags.maxStkSize)
scheduleThread_(StgTSO *tso)
{
// Precondition: sched_mutex must be held.
-
- /* Put the new thread on the head of the runnable queue. The caller
- * better push an appropriate closure on this thread's stack
- * beforehand. In the SMP case, the thread may start running as
- * soon as we release the scheduler lock below.
- */
PUSH_ON_RUN_QUEUE(tso);
THREAD_RUNNABLE();
-
-#if 0
- IF_DEBUG(scheduler,printTSO(tso));
-#endif
}
-void scheduleThread(StgTSO* tso)
+void
+scheduleThread(StgTSO* tso)
{
ACQUIRE_LOCK(&sched_mutex);
scheduleThread_(tso);
RELEASE_LOCK(&sched_mutex);
}
+#if defined(RTS_SUPPORTS_THREADS)
+static Condition bound_cond_cache;
+static int bound_cond_cache_full = 0;
+#endif
+
+
SchedulerStatus
scheduleWaitThread(StgTSO* tso, /*[out]*/HaskellObj* ret,
Capability *initialCapability)
m = stgMallocBytes(sizeof(StgMainThread), "waitThread");
m->tso = tso;
+ tso->main = m;
m->ret = ret;
m->stat = NoStatus;
+ m->link = main_threads;
+ m->prev = NULL;
+ if (main_threads != NULL) {
+ main_threads->prev = m;
+ }
+ main_threads = m;
+
#if defined(RTS_SUPPORTS_THREADS)
- initCondition(&m->bound_thread_cond);
+ // Allocating a new condition for each thread is expensive, so we
+ // cache one. This is a pretty feeble hack, but it helps speed up
+ // consecutive call-ins quite a bit.
+ if (bound_cond_cache_full) {
+ m->bound_thread_cond = bound_cond_cache;
+ bound_cond_cache_full = 0;
+ } else {
+ initCondition(&m->bound_thread_cond);
+ }
#endif
/* Put the thread on the main-threads list prior to scheduling the TSO.
*/
IF_DEBUG(scheduler, sched_belch("waiting for thread (%d)", tso->id));
- m->link = main_threads;
- main_threads = m;
-
- scheduleThread_(tso);
+ PUSH_ON_RUN_QUEUE(tso);
+ // NB. Don't call THREAD_RUNNABLE() here, because the thread is
+ // bound and only runnable by *this* OS thread, so waking up other
+ // workers will just slow things down.
return waitThread_(m, initialCapability);
}
* the scheduler. */
initMutex(&sched_mutex);
initMutex(&term_mutex);
- initMutex(&thread_id_mutex);
-
- initCondition(&thread_ready_cond);
#endif
-#if defined(RTS_SUPPORTS_THREADS)
ACQUIRE_LOCK(&sched_mutex);
-#endif
/* A capability holds the state a native thread needs in
* order to execute STG code. At least one capability is
#endif
RELEASE_LOCK(&sched_mutex);
-
}
void
stat = m->stat;
#if defined(RTS_SUPPORTS_THREADS)
- closeCondition(&m->bound_thread_cond);
+ // Free the condition variable, returning it to the cache if possible.
+ if (!bound_cond_cache_full) {
+ bound_cond_cache = m->bound_thread_cond;
+ bound_cond_cache_full = 1;
+ } else {
+ closeCondition(&m->bound_thread_cond);
+ }
#endif
IF_DEBUG(scheduler, sched_belch("main thread (%d) finished", m->tso->id));
// mark the signal handlers (signals should be already blocked)
markSignalHandlers(evac);
#endif
-
- // main threads which have completed need to be retained until they
- // are dealt with in the main scheduler loop. They won't be
- // retained any other way: the GC will drop them from the
- // all_threads list, so we have to be careful to treat them as roots
- // here.
- {
- StgMainThread *m;
- for (m = main_threads; m != NULL; m = m->link) {
- switch (m->tso->what_next) {
- case ThreadComplete:
- case ThreadKilled:
- evac((StgClosure **)&m->tso);
- break;
- default:
- break;
- }
- }
- }
}
/* -----------------------------------------------------------------------------
#else /* !GRAN && !PAR */
-#ifdef RTS_SUPPORTS_THREADS
void
awakenBlockedQueueNoLock(StgTSO *tso)
{
tso = unblockOneLocked(tso);
}
}
-#endif
void
awakenBlockedQueue(StgTSO *tso)
raiseAsync(tso,NULL);
}
+#ifdef FORKPROCESS_PRIMOP_SUPPORTED
static void
deleteThreadImmediately(StgTSO *tso)
{ // for forkProcess only:
if (tso->what_next == ThreadComplete || tso->what_next == ThreadKilled) {
return;
}
-#if defined(RTS_SUPPORTS_THREADS)
- if (tso->why_blocked != BlockedOnCCall
- && tso->why_blocked != BlockedOnCCall_NoUnblockExc)
-#endif
+
+ if (tso->why_blocked != BlockedOnCCall &&
+ tso->why_blocked != BlockedOnCCall_NoUnblockExc) {
unblockThread(tso);
+ }
+
tso->what_next = ThreadKilled;
}
+#endif
void
raiseAsyncWithLock(StgTSO *tso, StgClosure *exception)
tso->block_info.closure, info_type(tso->block_info.closure));
break;
#endif
-#if defined(RTS_SUPPORTS_THREADS)
case BlockedOnCCall:
fprintf(stderr,"is blocked on an external call");
break;
case BlockedOnCCall_NoUnblockExc:
fprintf(stderr,"is blocked on an external call (exceptions were already blocked)");
break;
-#endif
default:
barf("printThreadBlockage: strange tso->why_blocked: %d for TSO %d (%d)",
tso->why_blocked, tso->id, tso);
projects / ghc-hetmet.git / blobdiff