Commit c9b3d15f authored by Simon Marlow's avatar Simon Marlow
Browse files

Improvements to forkProcess()

fixes failures in yesterday's testsuite run
parent fec3bab8
...@@ -2105,7 +2105,7 @@ isThreadBound(StgTSO* tso USED_IF_THREADS) ...@@ -2105,7 +2105,7 @@ isThreadBound(StgTSO* tso USED_IF_THREADS)
#ifdef FORKPROCESS_PRIMOP_SUPPORTED #ifdef FORKPROCESS_PRIMOP_SUPPORTED
static void static void
deleteThreadImmediately(Capability *cap, StgTSO *tso); deleteThread_(Capability *cap, StgTSO *tso);
#endif #endif
StgInt StgInt
forkProcess(HsStablePtr *entry forkProcess(HsStablePtr *entry
...@@ -2142,28 +2142,47 @@ forkProcess(HsStablePtr *entry ...@@ -2142,28 +2142,47 @@ forkProcess(HsStablePtr *entry
} else { // child } else { // child
// delete all threads // Now, all OS threads except the thread that forked are
cap->run_queue_hd = END_TSO_QUEUE; // stopped. We need to stop all Haskell threads, including
cap->run_queue_tl = END_TSO_QUEUE; // those involved in foreign calls. Also we need to delete
// all Tasks, because they correspond to OS threads that are
// now gone.
for (t = all_threads; t != END_TSO_QUEUE; t = next) { for (t = all_threads; t != END_TSO_QUEUE; t = next) {
next = t->link; next = t->global_link;
// don't allow threads to catch the ThreadKilled
// don't allow threads to catch the ThreadKilled exception // exception, but we do want to raiseAsync() because these
deleteThreadImmediately(cap,t); // threads may be evaluating thunks that we need later.
deleteThread_(cap,t);
} }
// wipe the task list // Empty the run queue. It seems tempting to let all the
// killed threads stay on the run queue as zombies to be
// cleaned up later, but some of them correspond to bound
// threads for which the corresponding Task does not exist.
cap->run_queue_hd = END_TSO_QUEUE;
cap->run_queue_tl = END_TSO_QUEUE;
// Any suspended C-calling Tasks are no more, their OS threads
// don't exist now:
cap->suspended_ccalling_tasks = NULL;
// Empty the all_threads list. Otherwise, the garbage
// collector may attempt to resurrect some of these threads.
all_threads = END_TSO_QUEUE;
// Wipe the task list, except the current Task.
ACQUIRE_LOCK(&sched_mutex); ACQUIRE_LOCK(&sched_mutex);
for (task = all_tasks; task != NULL; task=task->all_link) { for (task = all_tasks; task != NULL; task=task->all_link) {
if (task != cap->running_task) discardTask(task); if (task != cap->running_task) {
discardTask(task);
}
} }
RELEASE_LOCK(&sched_mutex); RELEASE_LOCK(&sched_mutex);
cap->suspended_ccalling_tasks = NULL;
#if defined(THREADED_RTS) #if defined(THREADED_RTS)
// wipe our spare workers list. // Wipe our spare workers list, they no longer exist. New
// workers will be created if necessary.
cap->spare_workers = NULL; cap->spare_workers = NULL;
cap->returning_tasks_hd = NULL; cap->returning_tasks_hd = NULL;
cap->returning_tasks_tl = NULL; cap->returning_tasks_tl = NULL;
...@@ -2887,6 +2906,7 @@ GetRoots( evac_fn evac ) ...@@ -2887,6 +2906,7 @@ GetRoots( evac_fn evac )
for (task = cap->suspended_ccalling_tasks; task != NULL; for (task = cap->suspended_ccalling_tasks; task != NULL;
task=task->next) { task=task->next) {
IF_DEBUG(scheduler,sched_belch("evac'ing suspended TSO %d", task->suspended_tso->id));
evac((StgClosure **)&task->suspended_tso); evac((StgClosure **)&task->suspended_tso);
} }
} }
...@@ -3979,20 +3999,17 @@ deleteThread (Capability *cap, StgTSO *tso) ...@@ -3979,20 +3999,17 @@ deleteThread (Capability *cap, StgTSO *tso)
#ifdef FORKPROCESS_PRIMOP_SUPPORTED #ifdef FORKPROCESS_PRIMOP_SUPPORTED
static void static void
deleteThreadImmediately(Capability *cap, StgTSO *tso) deleteThread_(Capability *cap, StgTSO *tso)
{ // for forkProcess only: { // for forkProcess only:
// delete thread without giving it a chance to catch the KillThread exception // like deleteThread(), but we delete threads in foreign calls, too.
if (tso->what_next == ThreadComplete || tso->what_next == ThreadKilled) { if (tso->why_blocked == BlockedOnCCall ||
return; tso->why_blocked == BlockedOnCCall_NoUnblockExc) {
} unblockOne(cap,tso);
tso->what_next = ThreadKilled;
if (tso->why_blocked != BlockedOnCCall && } else {
tso->why_blocked != BlockedOnCCall_NoUnblockExc) { deleteThread(cap,tso);
unblockThread(cap,tso); }
}
tso->what_next = ThreadKilled;
} }
#endif #endif
...@@ -4481,7 +4498,7 @@ sched_belch(char *s, ...) ...@@ -4481,7 +4498,7 @@ sched_belch(char *s, ...)
va_list ap; va_list ap;
va_start(ap,s); va_start(ap,s);
#ifdef THREADED_RTS #ifdef THREADED_RTS
debugBelch("sched (task %p): ", (void *)(unsigned long)(unsigned int)osThreadId()); debugBelch("sched (task %p, pid %d): ", (void *)(unsigned long)(unsigned int)osThreadId(), getpid());
#elif defined(PARALLEL_HASKELL) #elif defined(PARALLEL_HASKELL)
debugBelch("== "); debugBelch("== ");
#else #else
......
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