/* ---------------------------------------------------------------------------
- * $Id: Schedule.c,v 1.175 2003/09/26 13:32:14 panne Exp $
+ * $Id: Schedule.c,v 1.179 2003/10/05 20:18:36 panne Exp $
*
* (c) The GHC Team, 1998-2000
*
StgTSO *MainTSO;
*/
-#if defined(PAR) || defined(RTS_SUPPORTS_THREADS)
+#if defined(RTS_SUPPORTS_THREADS)
+static rtsBool startingWorkerThread = rtsFalse;
+
static void taskStart(void);
static void
taskStart(void)
{
- schedule(NULL,NULL);
+ Capability *cap;
+
+ ACQUIRE_LOCK(&sched_mutex);
+ startingWorkerThread = rtsFalse;
+ waitForWorkCapability(&sched_mutex, &cap, NULL);
+ RELEASE_LOCK(&sched_mutex);
+
+ schedule(NULL,cap);
}
-#endif
-#if defined(RTS_SUPPORTS_THREADS)
void
-startSchedulerTask(void)
+startSchedulerTaskIfNecessary(void)
{
- startTask(taskStart);
+ if(run_queue_hd != END_TSO_QUEUE
+ || blocked_queue_hd != END_TSO_QUEUE
+ || sleeping_queue != END_TSO_QUEUE)
+ {
+ if(!startingWorkerThread)
+ { // we don't want to start another worker thread
+ // just because the last one hasn't yet reached the
+ // "waiting for capability" state
+ startingWorkerThread = rtsTrue;
+ startTask(taskStart);
+ }
+ }
}
#endif
// so just exit right away.
prog_belch("interrupted");
releaseCapability(cap);
- startTask(taskStart); // thread-safe-call to shutdownHaskellAndExit
RELEASE_LOCK(&sched_mutex);
shutdownHaskellAndExit(EXIT_SUCCESS);
#else
// no, the current native thread is bound to a different
// Haskell thread, so pass it to any worker thread
PUSH_ON_RUN_QUEUE(t);
- releaseCapability(cap);
+ passCapabilityToWorker(&sched_mutex, cap);
cap = NULL;
continue;
}
* Singleton fork(). Do not copy any running threads.
* ------------------------------------------------------------------------- */
-#ifdef THREADED_RTS
static void
deleteThreadImmediately(StgTSO *tso);
-#endif
StgInt
-forkProcess(StgTSO* tso)
+forkProcess(HsStablePtr *entry)
{
#ifndef mingw32_TARGET_OS
pid_t pid;
StgTSO* t,*next;
+ StgMainThread *m;
+ SchedulerStatus rc;
IF_DEBUG(scheduler,sched_belch("forking!"));
- ACQUIRE_LOCK(&sched_mutex);
+ rts_lock(); // This not only acquires sched_mutex, it also
+ // makes sure that no other threads are running
pid = fork();
+
if (pid) { /* parent */
/* just return the pid */
+ rts_unlock();
+ return pid;
} else { /* child */
-#ifdef THREADED_RTS
- /* wipe all other threads */
+
+
+ // delete all threads
run_queue_hd = run_queue_tl = END_TSO_QUEUE;
- tso->link = END_TSO_QUEUE;
for (t = all_threads; t != END_TSO_QUEUE; t = next) {
next = t->link;
-
- /* Don't kill the current thread.. */
- if (t->id == tso->id) {
- continue;
- }
-
- if (isThreadBound(t)) {
- // If the thread is bound, the OS thread that the thread is bound to
- // no longer exists after the fork() system call.
- // The bound Haskell thread is therefore unable to run at all;
- // we must not give it a chance to survive by catching the
- // ThreadKilled exception. So we kill it "brutally" rather than
- // using deleteThread.
- deleteThreadImmediately(t);
- } else {
- deleteThread(t);
- }
+
+ // don't allow threads to catch the ThreadKilled exception
+ deleteThreadImmediately(t);
}
- if (isThreadBound(tso)) {
- } else {
- // If the current is not bound, then we should make it so.
- // The OS thread left over by fork() is special in that the process
- // will terminate as soon as the thread terminates;
- // we'd expect forkProcess to behave similarily.
- // FIXME - we don't do this.
+ // wipe the main thread list
+ while((m = main_threads) != NULL) {
+ main_threads = m->link;
+#ifdef THREADED_RTS
+ closeCondition(&m->bound_thread_cond);
+#endif
+ stgFree(m);
}
-#else
- StgMainThread *m;
- rtsBool doKill;
- /* wipe all other threads */
- run_queue_hd = run_queue_tl = END_TSO_QUEUE;
- tso->link = END_TSO_QUEUE;
-
- /* When clearing out the threads, we need to ensure
- that a 'main thread' is left behind; if there isn't,
- the Scheduler will shutdown next time it is entered.
-
- ==> we don't kill a thread that's on the main_threads
- list (nor the current thread.)
- [ Attempts at implementing the more ambitious scheme of
- killing the main_threads also, and then adding the
- current thread onto the main_threads list if it wasn't
- there already, failed -- waitThread() (for one) wasn't
- up to it. If it proves to be desirable to also kill
- the main threads, then this scheme will have to be
- revisited (and fully debugged!)
-
- -- sof 7/2002
- ]
- */
- /* DO NOT TOUCH THE QUEUES directly because most of the code around
- us is picky about finding the thread still in its queue when
- handling the deleteThread() */
-
- for (t = all_threads; t != END_TSO_QUEUE; t = next) {
- next = t->link;
-
- /* Don't kill the current thread.. */
- if (t->id == tso->id) continue;
- doKill=rtsTrue;
- /* ..or a main thread */
- for (m = main_threads; m != NULL; m = m->link) {
- if (m->tso->id == t->id) {
- doKill=rtsFalse;
- break;
- }
- }
- if (doKill) {
- deleteThread(t);
- }
- }
+#ifdef RTS_SUPPORTS_THREADS
+ resetTaskManagerAfterFork(); // tell startTask() and friends that
+ startingWorkerThread = rtsFalse; // we have no worker threads any more
+ resetWorkerWakeupPipeAfterFork();
#endif
+
+ rc = rts_evalStableIO(entry, NULL); // run the action
+ rts_checkSchedStatus("forkProcess",rc);
+
+ rts_unlock();
+
+ hs_exit(); // clean up and exit
+ stg_exit(0);
}
- RELEASE_LOCK(&sched_mutex);
- return pid;
#else /* mingw32 */
- barf("forkProcess#: primop not implemented for mingw32, sorry! (%u)\n", tso->id);
- /* pointlessly printing out the TSOs 'id' to avoid CC unused warning. */
+ barf("forkProcess#: primop not implemented for mingw32, sorry!\n");
return -1;
#endif /* mingw32 */
}
waiting to take over.
*/
IF_DEBUG(scheduler, sched_belch("worker thread (%d, osthread %p): leaving RTS", tok, osThreadId()));
- //if (concCall) { // implementing "safe" as opposed to "threadsafe" is more difficult
- startTask(taskStart);
- //}
#endif
/* Other threads _might_ be available for execution; signal this */
m->ret = ret;
m->stat = NoStatus;
#if defined(RTS_SUPPORTS_THREADS)
- initCondition(&m->wakeup);
#if defined(THREADED_RTS)
initCondition(&m->bound_thread_cond);
+#else
+ initCondition(&m->wakeup);
#endif
#endif
m->ret = ret;
m->stat = NoStatus;
#if defined(RTS_SUPPORTS_THREADS)
- initCondition(&m->wakeup);
#if defined(THREADED_RTS)
initCondition(&m->bound_thread_cond);
+#else
+ initCondition(&m->wakeup);
#endif
#endif
stat = m->stat;
#if defined(RTS_SUPPORTS_THREADS)
- closeCondition(&m->wakeup);
#if defined(THREADED_RTS)
closeCondition(&m->bound_thread_cond);
+#else
+ closeCondition(&m->wakeup);
#endif
#endif
{
interrupted = 1;
context_switch = 1;
+#ifdef RTS_SUPPORTS_THREADS
+ wakeBlockedWorkerThread();
+#endif
}
/* -----------------------------------------------------------------------------
raiseAsync(tso,NULL);
}
-#ifdef THREADED_RTS
static void
deleteThreadImmediately(StgTSO *tso)
{ // for forkProcess only:
if (tso->what_next == ThreadComplete || tso->what_next == ThreadKilled) {
return;
}
- unblockThread(tso);
+#if defined(RTS_SUPPORTS_THREADS)
+ if (tso->why_blocked != BlockedOnCCall
+ && tso->why_blocked != BlockedOnCCall_NoUnblockExc)
+#endif
+ unblockThread(tso);
tso->what_next = ThreadKilled;
}
-#endif
void
raiseAsyncWithLock(StgTSO *tso, StgClosure *exception)
projects / ghc-hetmet.git / blobdiff