/* flag set by signal handler to precipitate a context switch */
int context_switch = 0;
+/* flag that tracks whether we have done any execution in this time slice. */
+nat recent_activity = ACTIVITY_YES;
+
/* if this flag is set as well, give up execution */
rtsBool interrupted = rtsFalse;
-/* If this flag is set, we are running Haskell code. Used to detect
- * uses of 'foreign import unsafe' that should be 'safe'.
- */
-static rtsBool in_haskell = rtsFalse;
-
/* Next thread ID to allocate.
* Locks required: thread_id_mutex
*/
* ------------------------------------------------------------------------- */
#if defined(RTS_SUPPORTS_THREADS)
-static rtsBool startingWorkerThread = rtsFalse;
+static nat startingWorkerThread = 0;
static void
taskStart(void)
{
ACQUIRE_LOCK(&sched_mutex);
- startingWorkerThread = rtsFalse;
+ startingWorkerThread--;
schedule(NULL,NULL);
taskStop();
RELEASE_LOCK(&sched_mutex);
{
if ( !EMPTY_RUN_QUEUE()
&& !shutting_down_scheduler // not if we're shutting down
- && !startingWorkerThread)
+ && startingWorkerThread==0)
{
// we don't want to start another worker thread
// just because the last one hasn't yet reached the
// "waiting for capability" state
- startingWorkerThread = rtsTrue;
+ startingWorkerThread++;
if (!maybeStartNewWorker(taskStart)) {
- startingWorkerThread = rtsFalse;
+ startingWorkerThread--;
}
}
}
// We now have a capability...
#endif
+
+#if 0 /* extra sanity checking */
+ {
+ StgMainThread *m;
+ for (m = main_threads; m != NULL; m = m->link) {
+ ASSERT(get_itbl(m->tso)->type == TSO);
+ }
+ }
+#endif
// Check whether we have re-entered the RTS from Haskell without
// going via suspendThread()/resumeThread (i.e. a 'safe' foreign
// call).
- if (in_haskell) {
+ if (cap->r.rInHaskell) {
errorBelch("schedule: re-entered unsafely.\n"
" Perhaps a 'foreign import unsafe' should be 'safe'?");
stg_exit(1);
prev_what_next = t->what_next;
errno = t->saved_errno;
- in_haskell = rtsTrue;
+ cap->r.rInHaskell = rtsTrue;
+
+ recent_activity = ACTIVITY_YES;
switch (prev_what_next) {
blackholes_need_checking = rtsTrue;
}
- in_haskell = rtsFalse;
+ cap->r.rInHaskell = rtsFalse;
// The TSO might have moved, eg. if it re-entered the RTS and a GC
// happened. So find the new location:
static void
scheduleDetectDeadlock(void)
{
+
+#if defined(PARALLEL_HASKELL)
+ // ToDo: add deadlock detection in GUM (similar to SMP) -- HWL
+ return;
+#endif
+
/*
* Detect deadlock: when we have no threads to run, there are no
* threads blocked, waiting for I/O, or sleeping, and all the
*/
if ( EMPTY_THREAD_QUEUES() )
{
-#if !defined(PARALLEL_HASKELL) && !defined(RTS_SUPPORTS_THREADS)
+#if defined(RTS_SUPPORTS_THREADS)
+ /*
+ * In the threaded RTS, we only check for deadlock if there
+ * has been no activity in a complete timeslice. This means
+ * we won't eagerly start a full GC just because we don't have
+ * any threads to run currently.
+ */
+ if (recent_activity != ACTIVITY_INACTIVE) return;
+#endif
+
IF_DEBUG(scheduler, sched_belch("deadlocked, forcing major GC..."));
// Garbage collection can release some new threads due to
// exception. Any threads thus released will be immediately
// runnable.
GarbageCollect(GetRoots,rtsTrue);
+ recent_activity = ACTIVITY_DONE_GC;
if ( !EMPTY_RUN_QUEUE() ) return;
-#if defined(RTS_USER_SIGNALS)
+#if defined(RTS_USER_SIGNALS) && !defined(RTS_SUPPORTS_THREADS)
/* If we have user-installed signal handlers, then wait
* for signals to arrive rather then bombing out with a
* deadlock.
}
#endif
+#if !defined(RTS_SUPPORTS_THREADS)
/* Probably a real deadlock. Send the current main thread the
* Deadlock exception (or in the SMP build, send *all* main
* threads the deadlock exception, since none of them can make
StgMainThread *m;
m = main_threads;
switch (m->tso->why_blocked) {
+ case BlockedOnSTM:
case BlockedOnBlackHole:
case BlockedOnException:
case BlockedOnMVar:
barf("deadlock: main thread blocked in a strange way");
}
}
-
-#elif defined(RTS_SUPPORTS_THREADS)
- // ToDo: add deadlock detection in threaded RTS
-#elif defined(PARALLEL_HASKELL)
- // ToDo: add deadlock detection in GUM (similar to SMP) -- HWL
#endif
}
}
debugBelch("--<< thread %ld (%s) stopped: requesting a large block (size %ld)\n",
(long)t->id, whatNext_strs[t->what_next], blocks));
- // don't do this if it would push us over the
- // alloc_blocks_lim limit; we'll GC first.
- if (alloc_blocks + blocks < alloc_blocks_lim) {
+ // don't do this if the nursery is (nearly) full, we'll GC first.
+ if (cap->r.rCurrentNursery->link != NULL ||
+ cap->r.rNursery->n_blocks == 1) { // paranoia to prevent infinite loop
+ // if the nursery has only one block.
- alloc_blocks += blocks;
bd = allocGroup( blocks );
+ cap->r.rNursery->n_blocks += blocks;
// link the new group into the list
bd->link = cap->r.rCurrentNursery;
if (cap->r.rCurrentNursery->u.back != NULL) {
cap->r.rCurrentNursery->u.back->link = bd;
} else {
-#ifdef SMP
- cap->r.rNursery = g0s0->blocks = bd;
-#else
+#if !defined(SMP)
ASSERT(g0s0->blocks == cap->r.rCurrentNursery &&
- g0s0->blocks == cap->r.rNursery);
- cap->r.rNursery = g0s0->blocks = bd;
+ g0s0 == cap->r.rNursery);
#endif
+ cap->r.rNursery->blocks = bd;
}
cap->r.rCurrentNursery->u.back = bd;
{
bdescr *x;
for (x = bd; x < bd + blocks; x++) {
- x->step = g0s0;
+ x->step = cap->r.rNursery;
x->gen_no = 0;
x->flags = 0;
}
}
-#if !defined(SMP)
- // don't forget to update the block count in g0s0.
- g0s0->n_blocks += blocks;
-
// This assert can be a killer if the app is doing lots
// of large block allocations.
- ASSERT(countBlocks(g0s0->blocks) == g0s0->n_blocks);
-#endif
+ IF_DEBUG(sanity, checkNurserySanity(cap->r.rNursery));
// now update the nursery to point to the new block
cap->r.rCurrentNursery = bd;
removeThreadLabel((StgWord)mainThread->tso->id);
#endif
if (mainThread->prev == NULL) {
+ ASSERT(mainThread == main_threads);
main_threads = mainThread->link;
} else {
mainThread->prev->link = mainThread->link;
}
if (mainThread->link != NULL) {
- mainThread->link->prev = NULL;
+ mainThread->link->prev = mainThread->prev;
}
releaseCapability(cap);
return rtsTrue; // tells schedule() to return
{
StgTSO *t;
#ifdef SMP
+ static rtsBool waiting_for_gc;
int n_capabilities = RtsFlags.ParFlags.nNodes - 1;
// subtract one because we're already holding one.
Capability *caps[n_capabilities];
// the other tasks to sleep and stay asleep.
//
+ // Someone else is already trying to GC
+ if (waiting_for_gc) return;
+ waiting_for_gc = rtsTrue;
+
caps[n_capabilities] = cap;
while (n_capabilities > 0) {
IF_DEBUG(scheduler, sched_belch("ready_to_gc, grabbing all the capabilies (%d left)", n_capabilities));
n_capabilities--;
caps[n_capabilities] = cap;
}
+
+ waiting_for_gc = rtsFalse;
#endif
/* Kick any transactions which are invalid back to their
StgBool
rtsSupportsBoundThreads(void)
{
-#ifdef THREADED_RTS
+#if defined(RTS_SUPPORTS_THREADS)
return rtsTrue;
#else
return rtsFalse;
StgBool
isThreadBound(StgTSO* tso USED_IN_THREADED_RTS)
{
-#ifdef THREADED_RTS
+#if defined(RTS_SUPPORTS_THREADS)
return (tso->main != NULL);
#endif
return rtsFalse;
StgTSO* t, *next;
IF_DEBUG(scheduler,sched_belch("deleting all threads"));
for (t = all_threads; t != END_TSO_QUEUE; t = next) {
- next = t->global_link;
- deleteThread(t);
+ if (t->what_next == ThreadRelocated) {
+ next = t->link;
+ } else {
+ next = t->global_link;
+ deleteThread(t);
+ }
}
// The run queue now contains a bunch of ThreadKilled threads. We
tok = cap->r.rCurrentTSO->id;
/* Hand back capability */
+ cap->r.rInHaskell = rtsFalse;
releaseCapability(cap);
#if defined(RTS_SUPPORTS_THREADS)
IF_DEBUG(scheduler, sched_belch("worker (token %d): leaving RTS", tok));
#endif
- in_haskell = rtsFalse;
RELEASE_LOCK(&sched_mutex);
errno = saved_errno;
tso->why_blocked = NotBlocked;
cap->r.rCurrentTSO = tso;
- in_haskell = rtsTrue;
+ cap->r.rInHaskell = rtsTrue;
RELEASE_LOCK(&sched_mutex);
errno = saved_errno;
return &cap->r;
#if defined(SMP)
/* eagerly start some extra workers */
+ startingWorkerThread = RtsFlags.ParFlags.nNodes;
startTasks(RtsFlags.ParFlags.nNodes, taskStart);
#endif
{
interrupted = 1;
context_switch = 1;
+ threadRunnable();
+ /* ToDo: if invoked from a signal handler, this threadRunnable
+ * only works if there's another thread (not this one) waiting to
+ * be woken up.
+ */
}
/* -----------------------------------------------------------------------------
blocked_queue_tl = (StgTSO *)prev;
}
}
+#if defined(mingw32_HOST_OS)
+ /* (Cooperatively) signal that the worker thread should abort
+ * the request.
+ */
+ abandonWorkRequest(tso->block_info.async_result->reqID);
+#endif
goto done;
}
}
blocked_queue_tl = prev;
}
}
+#if defined(mingw32_HOST_OS)
+ /* (Cooperatively) signal that the worker thread should abort
+ * the request.
+ */
+ abandonWorkRequest(tso->block_info.async_result->reqID);
+#endif
goto done;
}
}
#ifdef PROFILING
StgCatchFrame *cf = (StgCatchFrame *)frame;
#endif
- StgClosure *raise;
+ StgThunk *raise;
// we've got an exception to raise, so let's pass it to the
// handler in this frame.
//
- raise = (StgClosure *)allocate(sizeofW(StgClosure)+1);
+ raise = (StgThunk *)allocate(sizeofW(StgThunk)+1);
TICK_ALLOC_SE_THK(1,0);
SET_HDR(raise,&stg_raise_info,cf->header.prof.ccs);
raise->payload[0] = exception;
// fun field.
//
words = frame - sp - 1;
- ap = (StgAP_STACK *)allocate(PAP_sizeW(words));
+ ap = (StgAP_STACK *)allocate(AP_STACK_sizeW(words));
ap->size = words;
ap->fun = (StgClosure *)sp[0];
StgWord
raiseExceptionHelper (StgTSO *tso, StgClosure *exception)
{
- StgClosure *raise_closure = NULL;
+ StgThunk *raise_closure = NULL;
StgPtr p, next;
StgRetInfoTable *info;
//
// Only create raise_closure if we need to.
if (raise_closure == NULL) {
raise_closure =
- (StgClosure *)allocate(sizeofW(StgClosure)+MIN_UPD_SIZE);
+ (StgThunk *)allocate(sizeofW(StgThunk)+MIN_UPD_SIZE);
SET_HDR(raise_closure, &stg_raise_info, CCCS);
raise_closure->payload[0] = exception;
}
- UPD_IND(((StgUpdateFrame *)p)->updatee,raise_closure);
+ UPD_IND(((StgUpdateFrame *)p)->updatee,(StgClosure *)raise_closure);
p = next;
continue;
debugBelch("all threads:\n");
# endif
- for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
+ for (t = all_threads; t != END_TSO_QUEUE; ) {
debugBelch("\tthread %d @ %p ", t->id, (void *)t);
#if defined(DEBUG)
{
if (label) debugBelch("[\"%s\"] ",(char *)label);
}
#endif
- printThreadStatus(t);
- debugBelch("\n");
+ if (t->what_next == ThreadRelocated) {
+ debugBelch("has been relocated...\n");
+ t = t->link;
+ } else {
+ printThreadStatus(t);
+ debugBelch("\n");
+ t = t->global_link;
+ }
}
}
projects / ghc-hetmet.git / blobdiff