/* ---------------------------------------------------------------------------
- * $Id: Schedule.c,v 1.174 2003/09/21 22:20:56 wolfgang Exp $
+ * $Id: Schedule.c,v 1.179 2003/10/05 20:18:36 panne Exp $
*
* (c) The GHC Team, 1998-2000
*
#include <errno.h>
#endif
+#ifdef THREADED_RTS
+#define USED_IN_THREADED_RTS
+#else
+#define USED_IN_THREADED_RTS STG_UNUSED
+#endif
+
+#ifdef RTS_SUPPORTS_THREADS
+#define USED_WHEN_RTS_SUPPORTS_THREADS
+#else
+#define USED_WHEN_RTS_SUPPORTS_THREADS STG_UNUSED
+#endif
+
//@node Variables and Data structures, Prototypes, Includes, Main scheduling code
//@subsection Variables and Data structures
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
------------------------------------------------------------------------ */
//@cindex schedule
static void
-schedule( StgMainThread *mainThread, Capability *initialCapability )
+schedule( StgMainThread *mainThread USED_WHEN_RTS_SUPPORTS_THREADS,
+ Capability *initialCapability )
{
StgTSO *t;
Capability *cap = initialCapability;
// 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;
}
* ------------------------------------------------------------------------- */
StgBool
-isThreadBound(StgTSO* tso)
+isThreadBound(StgTSO* tso USED_IN_THREADED_RTS)
{
#ifdef THREADED_RTS
StgMainThread *m;
deleteThreadImmediately(StgTSO *tso);
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
}
/* -----------------------------------------------------------------------------
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;
}