X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FSchedule.c;h=1b57352410751f30d9614daa335b014f40939394;hb=8a8eee36f8bdcefbe05d04f62d481f1d612bde6b;hp=756d4765198a2f70a55f6027ab351da17f0ddf2b;hpb=f477a85c5ba20c12e6f229e5b870fddc7e8bacfd;p=ghc-hetmet.git diff --git a/ghc/rts/Schedule.c b/ghc/rts/Schedule.c index 756d476..1b57352 100644 --- a/ghc/rts/Schedule.c +++ b/ghc/rts/Schedule.c @@ -1,5 +1,5 @@ /* --------------------------------------------------------------------------- - * $Id: Schedule.c,v 1.147 2002/07/10 09:28:56 simonmar Exp $ + * $Id: Schedule.c,v 1.158 2002/12/10 13:38:40 wolfgang Exp $ * * (c) The GHC Team, 1998-2000 * @@ -84,6 +84,7 @@ #include "StgRun.h" #include "StgStartup.h" #include "Hooks.h" +#define COMPILING_SCHEDULER #include "Schedule.h" #include "StgMiscClosures.h" #include "Storage.h" @@ -122,6 +123,8 @@ #include #endif +#include +#include #include //@node Variables and Data structures, Prototypes, Includes, Main scheduling code @@ -130,7 +133,7 @@ /* Main thread queue. * Locks required: sched_mutex. */ -StgMainThread *main_threads; +StgMainThread *main_threads = NULL; /* Thread queues. * Locks required: sched_mutex. @@ -157,16 +160,18 @@ StgTSO *ccalling_threadss[MAX_PROC]; #else /* !GRAN */ -StgTSO *run_queue_hd, *run_queue_tl; -StgTSO *blocked_queue_hd, *blocked_queue_tl; -StgTSO *sleeping_queue; /* perhaps replace with a hash table? */ +StgTSO *run_queue_hd = NULL; +StgTSO *run_queue_tl = NULL; +StgTSO *blocked_queue_hd = NULL; +StgTSO *blocked_queue_tl = NULL; +StgTSO *sleeping_queue = NULL; /* perhaps replace with a hash table? */ #endif /* Linked list of all threads. * Used for detecting garbage collected threads. */ -StgTSO *all_threads; +StgTSO *all_threads = NULL; /* When a thread performs a safe C call (_ccall_GC, using old * terminology), it gets put on the suspended_ccalling_threads @@ -183,17 +188,17 @@ static StgTSO *threadStackOverflow(StgTSO *tso); /* flag set by signal handler to precipitate a context switch */ //@cindex context_switch -nat context_switch; +nat context_switch = 0; /* if this flag is set as well, give up execution */ //@cindex interrupted -rtsBool interrupted; +rtsBool interrupted = rtsFalse; /* Next thread ID to allocate. * Locks required: thread_id_mutex */ //@cindex next_thread_id -StgThreadID next_thread_id = 1; +static StgThreadID next_thread_id = 1; /* * Pointers to the state of the current thread. @@ -224,7 +229,7 @@ StgTSO *CurrentTSO; */ StgTSO dummy_tso; -rtsBool ready_to_gc; +static rtsBool ready_to_gc; /* * Set to TRUE when entering a shutdown state (via shutdownHaskellAndExit()) -- @@ -272,21 +277,13 @@ rtsBool emitSchedule = rtsTrue; #endif #if DEBUG -char *whatNext_strs[] = { +static char *whatNext_strs[] = { "ThreadEnterGHC", "ThreadRunGHC", "ThreadEnterInterp", "ThreadKilled", "ThreadComplete" }; - -char *threadReturnCode_strs[] = { - "HeapOverflow", /* might also be StackOverflow */ - "StackOverflow", - "ThreadYielding", - "ThreadBlocked", - "ThreadFinished" -}; #endif #if defined(PAR) @@ -452,7 +449,7 @@ schedule( void ) m->stat = Success; broadcastCondition(&m->wakeup); #ifdef DEBUG - removeThreadLabel(m->tso); + removeThreadLabel((StgWord)m->tso); #endif break; case ThreadKilled: @@ -465,7 +462,7 @@ schedule( void ) } broadcastCondition(&m->wakeup); #ifdef DEBUG - removeThreadLabel(m->tso); + removeThreadLabel((StgWord)m->tso); #endif break; default: @@ -1441,6 +1438,8 @@ StgInt forkProcess(StgTSO* tso) { #ifndef mingw32_TARGET_OS pid_t pid; StgTSO* t,*next; + StgMainThread *m; + rtsBool doKill; IF_DEBUG(scheduler,sched_belch("forking!")); @@ -1451,16 +1450,45 @@ StgInt forkProcess(StgTSO* tso) { } else { /* child */ /* wipe all other threads */ - run_queue_hd = tso; + run_queue_hd = run_queue_tl = tso; 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 threat still in its queue when + 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; - if (t->id != tso->id) { + + /* 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); } } @@ -1629,10 +1657,11 @@ static void unblockThread(StgTSO *tso); * instances of Eq/Ord for ThreadIds. * ------------------------------------------------------------------------ */ -int cmp_thread(const StgTSO *tso1, const StgTSO *tso2) +int +cmp_thread(StgPtr tso1, StgPtr tso2) { - StgThreadID id1 = tso1->id; - StgThreadID id2 = tso2->id; + StgThreadID id1 = ((StgTSO *)tso1)->id; + StgThreadID id2 = ((StgTSO *)tso2)->id; if (id1 < id2) return (-1); if (id1 > id2) return 1; @@ -1644,13 +1673,15 @@ int cmp_thread(const StgTSO *tso1, const StgTSO *tso2) * * This is used in the implementation of Show for ThreadIds. * ------------------------------------------------------------------------ */ -int rts_getThreadId(const StgTSO *tso) +int +rts_getThreadId(StgPtr tso) { - return tso->id; + return ((StgTSO *)tso)->id; } #ifdef DEBUG -void labelThread(StgTSO *tso, char *label) +void +labelThread(StgPtr tso, char *label) { int len; void *buf; @@ -1939,7 +1970,7 @@ scheduleThread_(StgTSO *tso #endif ) { - ACQUIRE_LOCK(&sched_mutex); + // 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 @@ -1960,12 +1991,13 @@ scheduleThread_(StgTSO *tso #if 0 IF_DEBUG(scheduler,printTSO(tso)); #endif - RELEASE_LOCK(&sched_mutex); } void scheduleThread(StgTSO* tso) { + ACQUIRE_LOCK(&sched_mutex); scheduleThread_(tso, rtsFalse); + RELEASE_LOCK(&sched_mutex); } SchedulerStatus @@ -1996,14 +2028,9 @@ scheduleWaitThread(StgTSO* tso, /*[out]*/HaskellObj* ret) m->link = main_threads; main_threads = m; - /* Inefficient (scheduleThread_() acquires it again right away), - * but obviously correct. - */ - RELEASE_LOCK(&sched_mutex); - scheduleThread_(tso, rtsTrue); #if defined(THREADED_RTS) - return waitThread_(m, rtsTrue); + return waitThread_(m, rtsTrue); // waitThread_ releases sched_mutex #else return waitThread_(m); #endif @@ -2205,11 +2232,10 @@ waitThread(StgTSO *tso, /*out*/StgClosure **ret) IF_DEBUG(scheduler, sched_belch("== scheduler: waiting for thread (%d)\n", tso->id)); m->link = main_threads; main_threads = m; - RELEASE_LOCK(&sched_mutex); IF_DEBUG(scheduler, sched_belch("== scheduler: waiting for thread (%d)\n", tso->id)); #if defined(THREADED_RTS) - return waitThread_(m, rtsFalse); + return waitThread_(m, rtsFalse); // waitThread_ releases sched_mutex #else return waitThread_(m); #endif @@ -2225,6 +2251,7 @@ waitThread_(StgMainThread* m { SchedulerStatus stat; + // Precondition: sched_mutex must be held. IF_DEBUG(scheduler, sched_belch("== scheduler: new main thread (%d)\n", m->tso->id)); #if defined(RTS_SUPPORTS_THREADS) @@ -2235,12 +2262,12 @@ waitThread_(StgMainThread* m * gets to enter the RTS directly without going via another * task/thread. */ + RELEASE_LOCK(&sched_mutex); schedule(); ASSERT(m->stat != NoStatus); } else # endif { - ACQUIRE_LOCK(&sched_mutex); do { waitCondition(&m->wakeup, &sched_mutex); } while (m->stat == NoStatus); @@ -2251,6 +2278,7 @@ waitThread_(StgMainThread* m procStatus[MainProc] = Busy; // status of main PE CurrentProc = MainProc; // PE to run it on + RELEASE_LOCK(&sched_mutex); schedule(); #else RELEASE_LOCK(&sched_mutex); @@ -2273,6 +2301,7 @@ waitThread_(StgMainThread* m #endif RELEASE_LOCK(&sched_mutex); + // Postcondition: sched_mutex must not be held return stat; } @@ -2444,6 +2473,30 @@ GetRoots(evac_fn evac) #if defined(PAR) || defined(GRAN) markSparkQueue(evac); #endif + +#ifndef mingw32_TARGET_OS + // 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; + } + } + } } /* ----------------------------------------------------------------------------- @@ -2459,7 +2512,7 @@ GetRoots(evac_fn evac) This needs to be protected by the GC condition variable above. KH. -------------------------------------------------------------------------- */ -void (*extra_roots)(evac_fn); +static void (*extra_roots)(evac_fn); void performGC(void) @@ -3230,7 +3283,6 @@ raiseAsync(StgTSO *tso, StgClosure *exception) /* Remove it from any blocking queues */ unblockThread(tso); - IF_DEBUG(scheduler, sched_belch("raising exception in thread %ld.", tso->id)); /* The stack freezing code assumes there's a closure pointer on * the top of the stack. This isn't always the case with compiled * code, so we have to push a dummy closure on the top which just @@ -3245,6 +3297,8 @@ raiseAsync(StgTSO *tso, StgClosure *exception) nat i; StgAP_UPD * ap; + ASSERT((P_)su > (P_)sp); + /* If we find a CATCH_FRAME, and we've got an exception to raise, * then build the THUNK raise(exception), and leave it on * top of the CATCH_FRAME ready to enter. @@ -3292,8 +3346,6 @@ raiseAsync(StgTSO *tso, StgClosure *exception) */ ap = (StgAP_UPD *)allocate(AP_sizeW(words)); - ASSERT(words >= 0); - ap->n_args = words; ap->fun = (StgClosure *)sp[0]; sp++; @@ -3516,11 +3568,12 @@ detectBlackHoles( void ) //@subsection Debugging Routines /* ----------------------------------------------------------------------------- - Debugging: why is a thread blocked + * Debugging: why is a thread blocked + * [Also provides useful information when debugging threaded programs + * at the Haskell source code level, so enable outside of DEBUG. --sof 7/02] -------------------------------------------------------------------------- */ -#ifdef DEBUG - +static void printThreadBlockage(StgTSO *tso) { @@ -3568,6 +3621,7 @@ printThreadBlockage(StgTSO *tso) } } +static void printThreadStatus(StgTSO *tso) { @@ -3594,15 +3648,15 @@ printAllThreads(void) ullong_format_string(TIME_ON_PROC(CurrentProc), time_string, rtsFalse/*no commas!*/); - sched_belch("all threads at [%s]:", time_string); + fprintf(stderr, "all threads at [%s]:\n", time_string); # elif defined(PAR) char time_string[TIME_STR_LEN], node_str[NODE_STR_LEN]; ullong_format_string(CURRENT_TIME, time_string, rtsFalse/*no commas!*/); - sched_belch("all threads at [%s]:", time_string); + fprintf(stderr,"all threads at [%s]:\n", time_string); # else - sched_belch("all threads:"); + fprintf(stderr,"all threads:\n"); # endif for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) { @@ -3614,6 +3668,8 @@ printAllThreads(void) } } +#ifdef DEBUG + /* Print a whole blocking queue attached to node (debugging only). */