X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FSchedule.c;h=0f600b65e8e43c77d9fbef986511a6dcc76e0801;hb=41ef96e51c2b3d16a80dc773306a987dbe0225b0;hp=33db7e685fc32811ca4309fb9aa2ad4c6c47a33b;hpb=324e96d2ebfcb113cd97c43ef043d591ef87de71;p=ghc-hetmet.git diff --git a/ghc/rts/Schedule.c b/ghc/rts/Schedule.c index 33db7e6..0f600b6 100644 --- a/ghc/rts/Schedule.c +++ b/ghc/rts/Schedule.c @@ -1,5 +1,5 @@ /* --------------------------------------------------------------------------- - * $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 * @@ -542,7 +542,7 @@ schedule( StgMainThread *mainThread USED_WHEN_RTS_SUPPORTS_THREADS, *prev = m->link; #ifdef DEBUG - removeThreadLabel((StgWord)m->tso); + removeThreadLabel((StgWord)m->tso->id); #endif releaseCapability(cap); RELEASE_LOCK(&sched_mutex); @@ -577,7 +577,7 @@ schedule( StgMainThread *mainThread USED_WHEN_RTS_SUPPORTS_THREADS, 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) { @@ -960,7 +960,7 @@ schedule( StgMainThread *mainThread USED_WHEN_RTS_SUPPORTS_THREADS, /* 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"); @@ -1067,7 +1067,7 @@ schedule( StgMainThread *mainThread USED_WHEN_RTS_SUPPORTS_THREADS, 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 @@ -1113,7 +1113,7 @@ schedule( StgMainThread *mainThread USED_WHEN_RTS_SUPPORTS_THREADS, /* 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)); @@ -1639,114 +1639,68 @@ isThreadBound(StgTSO* tso USED_IN_THREADED_RTS) * 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 */ } @@ -1810,7 +1764,7 @@ suspendThread( StgRegTable *reg, /* 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); @@ -1956,7 +1910,7 @@ labelThread(StgPtr tso, char *label) 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 */ @@ -2805,7 +2759,7 @@ threadStackOverflow(StgTSO *tso) 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, @@ -2877,12 +2831,12 @@ threadStackOverflow(StgTSO *tso) ------------------------------------------------------------------------ */ #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 @@ -3018,7 +2972,7 @@ unblockOneLocked(StgTSO *tso) #endif #if defined(GRAN) || defined(PAR) -inline StgBlockingQueueElement * +INLINE_ME StgBlockingQueueElement * unblockOne(StgBlockingQueueElement *bqe, StgClosure *node) { ACQUIRE_LOCK(&sched_mutex); @@ -3027,7 +2981,7 @@ unblockOne(StgBlockingQueueElement *bqe, StgClosure *node) return bqe; } #else -inline StgTSO * +INLINE_ME StgTSO * unblockOne(StgTSO *tso) { ACQUIRE_LOCK(&sched_mutex); @@ -3187,6 +3141,9 @@ interruptStgRts(void) { interrupted = 1; context_switch = 1; +#ifdef RTS_SUPPORTS_THREADS + wakeBlockedWorkerThread(); +#endif } /* ----------------------------------------------------------------------------- @@ -3506,7 +3463,6 @@ deleteThread(StgTSO *tso) raiseAsync(tso,NULL); } -#ifdef THREADED_RTS static void deleteThreadImmediately(StgTSO *tso) { // for forkProcess only: @@ -3522,7 +3478,6 @@ deleteThreadImmediately(StgTSO *tso) unblockThread(tso); tso->what_next = ThreadKilled; } -#endif void raiseAsyncWithLock(StgTSO *tso, StgClosure *exception) @@ -3911,7 +3866,7 @@ printAllThreads(void) 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");