From: wolfgang Date: Wed, 1 Oct 2003 10:57:44 +0000 (+0000) Subject: [project @ 2003-10-01 10:57:39 by wolfgang] X-Git-Tag: Approx_11550_changesets_converted~398 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=d3581a6a5789da15ab56c11cd02bece49273b41d [project @ 2003-10-01 10:57:39 by wolfgang] New implementation & changed type signature of forkProcess forkProcess now has the following type: forkProcess :: IO () -> IO ProcessID forkProcessAll has been removed as it is unimplementable in the threaded RTS. forkProcess using the old type (IO (Maybe ProcessID)) was impossible to implement correctly in the non-threaded RTS and very hard to implement in the threaded RTS. The new type signature allows a clean and simple implementation. --- diff --git a/ghc/compiler/prelude/primops.txt.pp b/ghc/compiler/prelude/primops.txt.pp index af4a244..4d7d4d9 100644 --- a/ghc/compiler/prelude/primops.txt.pp +++ b/ghc/compiler/prelude/primops.txt.pp @@ -1,5 +1,5 @@ ----------------------------------------------------------------------- --- $Id: primops.txt.pp,v 1.29 2003/09/21 22:20:51 wolfgang Exp $ +-- $Id: primops.txt.pp,v 1.30 2003/10/01 10:57:39 wolfgang Exp $ -- -- Primitive Operations -- @@ -1465,12 +1465,6 @@ primop ForkOp "fork#" GenPrimOp has_side_effects = True out_of_line = True -primop ForkProcessOp "forkProcess#" GenPrimOp - State# RealWorld -> (# State# RealWorld, Int# #) - with - has_side_effects = True - out_of_line = True - primop KillThreadOp "killThread#" GenPrimOp ThreadId# -> a -> State# RealWorld -> State# RealWorld with diff --git a/ghc/includes/PrimOps.h b/ghc/includes/PrimOps.h index 373ef92..daf96da 100644 --- a/ghc/includes/PrimOps.h +++ b/ghc/includes/PrimOps.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: PrimOps.h,v 1.105 2003/09/24 11:06:51 simonmar Exp $ + * $Id: PrimOps.h,v 1.106 2003/10/01 10:57:41 wolfgang Exp $ * * (c) The GHC Team, 1998-2000 * @@ -273,7 +273,6 @@ EXTFUN_RTS(deRefStablePtrzh_fast); -------------------------------------------------------------------------- */ EXTFUN_RTS(forkzh_fast); -EXTFUN_RTS(forkProcesszh_fast); EXTFUN_RTS(yieldzh_fast); EXTFUN_RTS(killThreadzh_fast); EXTFUN_RTS(seqzh_fast); diff --git a/ghc/rts/Linker.c b/ghc/rts/Linker.c index 5e54215..da2f23e 100644 --- a/ghc/rts/Linker.c +++ b/ghc/rts/Linker.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Linker.c,v 1.134 2003/09/26 09:26:12 panne Exp $ + * $Id: Linker.c,v 1.135 2003/10/01 10:57:41 wolfgang Exp $ * * (c) The GHC Team, 2000-2003 * @@ -369,7 +369,7 @@ typedef struct _RtsSymbolVal { SymX(divExactIntegerzh_fast) \ SymX(divModIntegerzh_fast) \ SymX(forkzh_fast) \ - SymX(forkProcesszh_fast) \ + SymX(forkProcess) \ SymX(forkOS_createThread) \ SymX(freeHaskellFunctionPtr) \ SymX(freeStablePtr) \ diff --git a/ghc/rts/PrimOps.hc b/ghc/rts/PrimOps.hc index 9b3f3a4..45fd2cf 100644 --- a/ghc/rts/PrimOps.hc +++ b/ghc/rts/PrimOps.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: PrimOps.hc,v 1.113 2003/09/21 22:20:55 wolfgang Exp $ + * $Id: PrimOps.hc,v 1.114 2003/10/01 10:57:41 wolfgang Exp $ * * (c) The GHC Team, 1998-2002 * @@ -1053,20 +1053,6 @@ FN_(forkzh_fast) FE_ } -FN_(forkProcesszh_fast) -{ - pid_t pid; - - FB_ - /* args: none */ - /* result: Pid */ - - R1.i = RET_STGCALL1(StgInt, forkProcess, CurrentTSO); - - RET_N(R1.i); - FE_ -} - FN_(yieldzh_fast) { FB_ diff --git a/ghc/rts/Schedule.c b/ghc/rts/Schedule.c index 33db7e6..9087a22 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.177 2003/10/01 10:57:42 wolfgang Exp $ * * (c) The GHC Team, 1998-2000 * @@ -1645,108 +1645,62 @@ 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; + resetTaskManagerAfterFork(); // tell startTask() and friends that + startingWorkerThread = rtsFalse; // we have no worker threads any more + resetWorkerWakeupPipeAfterFork(); - /* 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); - } - } -#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 */ } diff --git a/ghc/rts/Schedule.h b/ghc/rts/Schedule.h index ebbe7d1..da4a010 100644 --- a/ghc/rts/Schedule.h +++ b/ghc/rts/Schedule.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Schedule.h,v 1.40 2003/10/01 10:49:09 wolfgang Exp $ + * $Id: Schedule.h,v 1.41 2003/10/01 10:57:43 wolfgang Exp $ * * (c) The GHC Team 1998-1999 * @@ -90,6 +90,14 @@ rtsBool wakeUpSleepingThreads(nat); /* In Select.c */ */ void wakeBlockedWorkerThread(void); /* In Select.c */ +/* resetWorkerWakeupPipeAfterFork() + * + * Notify Select.c that a fork() has occured + * + * Called from STG : NO + * Locks assumed : don't care, but must be called right after fork() + */ +void resetWorkerWakeupPipeAfterFork(void); /* In Select.c */ /* GetRoots(evac_fn f) * @@ -151,7 +159,7 @@ extern nat rts_n_waiting_tasks; StgBool rtsSupportsBoundThreads(void); StgBool isThreadBound(StgTSO *tso); -StgInt forkProcess(StgTSO *tso); +StgInt forkProcess(HsStablePtr *entry); extern SchedulerStatus rts_mainLazyIO(HaskellObj p, /*out*/HaskellObj *ret);