* --------------------------------------------------------------------------*/
#include "PosixSource.h"
+#define KEEP_LOCKCLOSURE
#include "Rts.h"
#include "SchedAPI.h"
#include "RtsUtils.h"
#include "ThreadLabels.h"
#include "LdvProfile.h"
#include "Updates.h"
-#ifdef PROFILING
#include "Proftimer.h"
#include "ProfHeap.h"
-#endif
#if defined(GRAN) || defined(PARALLEL_HASKELL)
# include "GranSimRts.h"
# include "GranSim.h"
static void scheduleHandleThreadBlocked( StgTSO *t );
static rtsBool scheduleHandleThreadFinished( Capability *cap, Task *task,
StgTSO *t );
-static rtsBool scheduleDoHeapProfile(rtsBool ready_to_gc);
+static rtsBool scheduleNeedHeapProfile(rtsBool ready_to_gc);
static Capability *scheduleDoGC(Capability *cap, Task *task,
rtsBool force_major);
debugTrace(DEBUG_sched, "-->> running thread %ld %s ...",
(long)t->id, whatNext_strs[t->what_next]);
-#if defined(PROFILING)
startHeapProfTimer();
-#endif
// Check for exceptions blocked on this thread
maybePerformBlockedException (cap, t);
prev_what_next = t->what_next;
errno = t->saved_errno;
+#if mingw32_HOST_OS
+ SetLastError(t->saved_winerror);
+#endif
+
cap->in_haskell = rtsTrue;
dirtyTSO(t);
- recent_activity = ACTIVITY_YES;
+#if defined(THREADED_RTS)
+ if (recent_activity == ACTIVITY_DONE_GC) {
+ // ACTIVITY_DONE_GC means we turned off the timer signal to
+ // conserve power (see #1623). Re-enable it here.
+ nat prev;
+ prev = xchg(&recent_activity, ACTIVITY_YES);
+ if (prev == ACTIVITY_DONE_GC) {
+ startTimer();
+ }
+ } else {
+ recent_activity = ACTIVITY_YES;
+ }
+#endif
switch (prev_what_next) {
// XXX: possibly bogus for SMP because this thread might already
// be running again, see code below.
t->saved_errno = errno;
+#if mingw32_HOST_OS
+ // Similarly for Windows error code
+ t->saved_winerror = GetLastError();
+#endif
#if defined(THREADED_RTS)
// If ret is ThreadBlocked, and this Task is bound to the TSO that
// ----------------------------------------------------------------------
// Costs for the scheduler are assigned to CCS_SYSTEM
-#if defined(PROFILING)
stopHeapProfTimer();
+#if defined(PROFILING)
CCCS = CCS_SYSTEM;
#endif
barf("schedule: invalid thread return code %d", (int)ret);
}
- if (scheduleDoHeapProfile(ready_to_gc)) { ready_to_gc = rtsFalse; }
- if (ready_to_gc) {
+ if (ready_to_gc || scheduleNeedHeapProfile(ready_to_gc)) {
cap = scheduleDoGC(cap,task,rtsFalse);
}
} /* end of while() */
static void
scheduleStartSignalHandlers(Capability *cap)
{
- if (signals_pending()) { // safe outside the lock
+ if (RtsFlags.MiscFlags.install_signal_handlers && signals_pending()) {
+ // safe outside the lock
startSignalHandlers(cap);
}
}
cap = scheduleDoGC (cap, task, rtsTrue/*force major GC*/);
recent_activity = ACTIVITY_DONE_GC;
+ // disable timer signals (see #1623)
+ stopTimer();
if ( !emptyRunQueue(cap) ) return;
* for signals to arrive rather then bombing out with a
* deadlock.
*/
- if ( anyUserHandlers() ) {
+ if ( RtsFlags.MiscFlags.install_signal_handlers && anyUserHandlers() ) {
debugTrace(DEBUG_sched,
"still deadlocked, waiting for signals...");
// has tidied up its stack and placed itself on whatever queue
// it needs to be on.
-#if !defined(THREADED_RTS)
- ASSERT(t->why_blocked != NotBlocked);
- // This might not be true under THREADED_RTS: we don't have
- // exclusive access to this TSO, so someone might have
- // woken it up by now. This actually happens: try
- // conc023 +RTS -N2.
-#endif
+ // ASSERT(t->why_blocked != NotBlocked);
+ // Not true: for example,
+ // - in THREADED_RTS, the thread may already have been woken
+ // up by another Capability. This actually happens: try
+ // conc023 +RTS -N2.
+ // - the thread may have woken itself up already, because
+ // threadPaused() might have raised a blocked throwTo
+ // exception, see maybePerformBlockedException().
#ifdef DEBUG
if (traceClass(DEBUG_sched)) {
debugTrace(DEBUG_sched, "--++ thread %lu (%s) finished",
(unsigned long)t->id, whatNext_strs[t->what_next]);
- /* Inform the Hpc that a thread has finished */
- hs_hpc_event("Thread Finished",t);
-
#if defined(GRAN)
endThread(t, CurrentProc); // clean-up the thread
#elif defined(PARALLEL_HASKELL)
}
/* -----------------------------------------------------------------------------
- * Perform a heap census, if PROFILING
+ * Perform a heap census
* -------------------------------------------------------------------------- */
static rtsBool
-scheduleDoHeapProfile( rtsBool ready_to_gc STG_UNUSED )
+scheduleNeedHeapProfile( rtsBool ready_to_gc STG_UNUSED )
{
-#if defined(PROFILING)
// When we have +RTS -i0 and we're heap profiling, do a census at
// every GC. This lets us get repeatable runs for debugging.
if (performHeapProfile ||
(RtsFlags.ProfFlags.profileInterval==0 &&
RtsFlags.ProfFlags.doHeapProfile && ready_to_gc)) {
-
- // checking black holes is necessary before GC, otherwise
- // there may be threads that are unreachable except by the
- // blackhole queue, which the GC will consider to be
- // deadlocked.
- scheduleCheckBlackHoles(&MainCapability);
-
- debugTrace(DEBUG_sched, "garbage collecting before heap census");
- GarbageCollect(rtsTrue);
-
- debugTrace(DEBUG_sched, "performing heap census");
- heapCensus();
-
- performHeapProfile = rtsFalse;
- return rtsTrue; // true <=> we already GC'd
+ return rtsTrue;
+ } else {
+ return rtsFalse;
}
-#endif
- return rtsFalse;
}
/* -----------------------------------------------------------------------------
scheduleDoGC (Capability *cap, Task *task USED_IF_THREADS, rtsBool force_major)
{
StgTSO *t;
+ rtsBool heap_census;
#ifdef THREADED_RTS
static volatile StgWord waiting_for_gc;
rtsBool was_waiting;
deleteAllThreads(&capabilities[0]);
sched_state = SCHED_SHUTTING_DOWN;
}
+
+ heap_census = scheduleNeedHeapProfile(rtsTrue);
/* everybody back, start the GC.
* Could do it in this thread, or signal a condition var
#if defined(THREADED_RTS)
debugTrace(DEBUG_sched, "doing GC");
#endif
- GarbageCollect(force_major);
+ GarbageCollect(force_major || heap_census);
+ if (heap_census) {
+ debugTrace(DEBUG_sched, "performing heap census");
+ heapCensus();
+ performHeapProfile = rtsFalse;
+ }
+
#if defined(THREADED_RTS)
// release our stash of capabilities.
for (i = 0; i < n_capabilities; i++) {
* Singleton fork(). Do not copy any running threads.
* ------------------------------------------------------------------------- */
-StgInt
+pid_t
forkProcess(HsStablePtr *entry
#ifndef FORKPROCESS_PRIMOP_SUPPORTED
STG_UNUSED
cap->returning_tasks_tl = NULL;
#endif
+ // On Unix, all timers are reset in the child, so we need to start
+ // the timer again.
+ initTimer();
+ startTimer();
+
cap = rts_evalStableIO(cap, entry, NULL); // run the action
rts_checkSchedStatus("forkProcess",cap);
suspendThread (StgRegTable *reg)
{
Capability *cap;
- int saved_errno = errno;
+ int saved_errno;
StgTSO *tso;
Task *task;
+#if mingw32_HOST_OS
+ StgWord32 saved_winerror;
+#endif
+
+ saved_errno = errno;
+#if mingw32_HOST_OS
+ saved_winerror = GetLastError();
+#endif
/* assume that *reg is a pointer to the StgRegTable part of a Capability.
*/
#endif
errno = saved_errno;
+#if mingw32_HOST_OS
+ SetLastError(saved_winerror);
+#endif
return task;
}
{
StgTSO *tso;
Capability *cap;
- int saved_errno = errno;
Task *task = task_;
+ int saved_errno;
+#if mingw32_HOST_OS
+ StgWord32 saved_winerror;
+#endif
+
+ saved_errno = errno;
+#if mingw32_HOST_OS
+ saved_winerror = GetLastError();
+#endif
cap = task->cap;
// Wait for permission to re-enter the RTS with the result.
cap->r.rCurrentTSO = tso;
cap->in_haskell = rtsTrue;
errno = saved_errno;
+#if mingw32_HOST_OS
+ SetLastError(saved_winerror);
+#endif
/* We might have GC'd, mark the TSO dirty again */
dirtyTSO(tso);
context_switch = 0;
sched_state = SCHED_RUNNING;
+ recent_activity = ACTIVITY_YES;
#if defined(THREADED_RTS)
/* Initialise the mutex and condition variables used by
}
void
-exitScheduler( void )
+exitScheduler(
+ rtsBool wait_foreign
+#if !defined(THREADED_RTS)
+ __attribute__((unused))
+#endif
+)
+ /* see Capability.c, shutdownCapability() */
{
Task *task = NULL;
nat i;
for (i = 0; i < n_capabilities; i++) {
- shutdownCapability(&capabilities[i], task);
+ shutdownCapability(&capabilities[i], task, wait_foreign);
}
boundTaskExiting(task);
stopTaskManager();
#if defined(RTS_USER_SIGNALS)
// mark the signal handlers (signals should be already blocked)
- markSignalHandlers(evac);
+ if (RtsFlags.MiscFlags.install_signal_handlers) {
+ markSignalHandlers(evac);
+ }
#endif
}
// while we are moving the TSO:
lockClosure((StgClosure *)tso);
- if (tso->stack_size >= tso->max_stack_size) {
+ if (tso->stack_size >= tso->max_stack_size && !(tso->flags & TSO_BLOCKEX)) {
+ // NB. never raise a StackOverflow exception if the thread is
+ // inside Control.Exceptino.block. It is impractical to protect
+ // against stack overflow exceptions, since virtually anything
+ // can raise one (even 'catch'), so this is the only sensible
+ // thing to do here. See bug #767.
debugTrace(DEBUG_gc,
"threadStackOverflow of TSO %ld (%p): stack too large (now %ld; max is %ld)",
return CATCH_RETRY_FRAME;
case CATCH_STM_FRAME: {
- debugTrace(DEBUG_stm,
- "found CATCH_STM_FRAME at %p during retry", p);
StgTRecHeader *trec = tso -> trec;
StgTRecHeader *outer = stmGetEnclosingTRec(trec);
+ debugTrace(DEBUG_stm,
+ "found CATCH_STM_FRAME at %p during retry", p);
debugTrace(DEBUG_stm, "trec=%p outer=%p", trec, outer);
stmAbortTransaction(tso -> cap, trec);
stmFreeAbortedTRec(tso -> cap, trec);
projects / ghc-hetmet.git / blobdiff