Skip to content

GitLab

Commit d3581a6a authored by wolfgang's avatar wolfgang
Browse files

[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.
parent 324e96d2
Hide whitespace changes
Inline Side-by-side
ghc/compiler/prelude/primops.txt.pp
View file @ d3581a6a
-----------------------------------------------------------------------
-- $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
......
ghc/includes/PrimOps.h
View file @ d3581a6a
/* -----------------------------------------------------------------------------
* $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);
......
ghc/rts/Linker.c
View file @ d3581a6a
/* -----------------------------------------------------------------------------
* $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) \
......
ghc/rts/PrimOps.hc
View file @ d3581a6a
/* -----------------------------------------------------------------------------
* $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_
......
ghc/rts/Schedule.c
View file @ d3581a6a
/* ---------------------------------------------------------------------------
* $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 */
}
......
ghc/rts/Schedule.h
View file @ d3581a6a
/* -----------------------------------------------------------------------------
* $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);
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment