/* ---------------------------------------------------------------------------
- * $Id: Schedule.c,v 1.176 2003/10/01 10:49:08 wolfgang Exp $
+ * $Id: Schedule.c,v 1.181 2003/12/05 09:50:39 stolz Exp $
*
* (c) The GHC Team, 1998-2000
*
*prev = m->link;
#ifdef DEBUG
- removeThreadLabel((StgWord)m->tso);
+ removeThreadLabel((StgWord)m->tso->id);
#endif
releaseCapability(cap);
RELEASE_LOCK(&sched_mutex);
if (m->tso->what_next == ThreadComplete
|| m->tso->what_next == ThreadKilled) {
#ifdef DEBUG
- removeThreadLabel((StgWord)m->tso);
+ removeThreadLabel((StgWord)m->tso->id);
#endif
main_threads = main_threads->link;
if (m->tso->what_next == ThreadComplete) {
/* in a GranSim setup the TSO stays on the run queue */
t = CurrentTSO;
/* Take a thread from the run queue. */
- t = POP_RUN_QUEUE(); // take_off_run_queue(t);
+ POP_RUN_QUEUE(t); // take_off_run_queue(t);
IF_DEBUG(gran,
fprintf(stderr, "GRAN: About to run current thread, which is\n");
ASSERT(run_queue_hd != END_TSO_QUEUE);
/* Take a thread from the run queue, if we have work */
- t = POP_RUN_QUEUE(); // take_off_run_queue(END_TSO_QUEUE);
+ POP_RUN_QUEUE(t); // take_off_run_queue(END_TSO_QUEUE);
IF_DEBUG(sanity,checkTSO(t));
/* ToDo: write something to the log-file
/* grab a thread from the run queue */
ASSERT(run_queue_hd != END_TSO_QUEUE);
- t = POP_RUN_QUEUE();
+ POP_RUN_QUEUE(t);
// Sanity check the thread we're about to run. This can be
// expensive if there is lots of thread switching going on...
IF_DEBUG(sanity,checkTSO(t));
* 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 */
}
/* assume that *reg is a pointer to the StgRegTable part
* of a Capability.
*/
- cap = (Capability *)((void *)reg - sizeof(StgFunTable));
+ cap = (Capability *)((void *)((unsigned char*)reg - sizeof(StgFunTable)));
ACQUIRE_LOCK(&sched_mutex);
buf = stgMallocBytes(len * sizeof(char), "Schedule.c:labelThread()");
strncpy(buf,label,len);
/* Update will free the old memory for us */
- updateThreadLabel((StgWord)tso,buf);
+ updateThreadLabel(((StgTSO *)tso)->id,buf);
}
#endif /* DEBUG */
if (tso->stack_size >= tso->max_stack_size) {
IF_DEBUG(gc,
- belch("@@ threadStackOverflow of TSO %d (%p): stack too large (now %ld; max is %ld",
+ belch("@@ threadStackOverflow of TSO %d (%p): stack too large (now %ld; max is %ld)",
tso->id, tso, tso->stack_size, tso->max_stack_size);
/* If we're debugging, just print out the top of the stack */
printStackChunk(tso->sp, stg_min(tso->stack+tso->stack_size,
------------------------------------------------------------------------ */
#if defined(GRAN)
-static inline void
+STATIC_INLINE void
unblockCount ( StgBlockingQueueElement *bqe, StgClosure *node )
{
}
#elif defined(PAR)
-static inline void
+STATIC_INLINE void
unblockCount ( StgBlockingQueueElement *bqe, StgClosure *node )
{
/* write RESUME events to log file and
#endif
#if defined(GRAN) || defined(PAR)
-inline StgBlockingQueueElement *
+INLINE_ME StgBlockingQueueElement *
unblockOne(StgBlockingQueueElement *bqe, StgClosure *node)
{
ACQUIRE_LOCK(&sched_mutex);
return bqe;
}
#else
-inline StgTSO *
+INLINE_ME StgTSO *
unblockOne(StgTSO *tso)
{
ACQUIRE_LOCK(&sched_mutex);
{
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:
unblockThread(tso);
tso->what_next = ThreadKilled;
}
-#endif
void
raiseAsyncWithLock(StgTSO *tso, StgClosure *exception)
for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
fprintf(stderr, "\tthread %d @ %p ", t->id, (void *)t);
- label = lookupThreadLabel((StgWord)t);
+ label = lookupThreadLabel(t->id);
if (label) fprintf(stderr,"[\"%s\"] ",(char *)label);
printThreadStatus(t);
fprintf(stderr,"\n");
projects / ghc-hetmet.git / blobdiff