#include "SchedAPI.h"
#include "RtsUtils.h"
#include "RtsFlags.h"
-#include "BlockAlloc.h"
#include "OSThreads.h"
#include "Storage.h"
#include "StgRun.h"
#include "Trace.h"
#include "RaiseAsync.h"
#include "Threads.h"
+#include "ThrIOManager.h"
#ifdef HAVE_SYS_TYPES_H
#include <sys/types.h>
StgTSO *t );
static rtsBool scheduleDoHeapProfile(rtsBool ready_to_gc);
static Capability *scheduleDoGC(Capability *cap, Task *task,
- rtsBool force_major,
- void (*get_roots)(evac_fn));
+ rtsBool force_major);
static rtsBool checkBlackHoles(Capability *cap);
-static void AllRoots(evac_fn evac);
static StgTSO *threadStackOverflow(Capability *cap, StgTSO *tso);
discardSparksCap(cap);
#endif
/* scheduleDoGC() deletes all the threads */
- cap = scheduleDoGC(cap,task,rtsFalse,GetRoots);
+ cap = scheduleDoGC(cap,task,rtsFalse);
break;
case SCHED_SHUTTING_DOWN:
debugTrace(DEBUG_sched, "SCHED_SHUTTING_DOWN");
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);
// 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
if (scheduleDoHeapProfile(ready_to_gc)) { ready_to_gc = rtsFalse; }
if (ready_to_gc) {
- cap = scheduleDoGC(cap,task,rtsFalse,GetRoots);
+ cap = scheduleDoGC(cap,task,rtsFalse);
}
} /* end of while() */
* Start any pending signal handlers
* ------------------------------------------------------------------------- */
-#if defined(RTS_USER_SIGNALS) && (!defined(THREADED_RTS) || defined(mingw32_HOST_OS))
+#if defined(RTS_USER_SIGNALS) && !defined(THREADED_RTS)
static void
scheduleStartSignalHandlers(Capability *cap)
{
// they are unreachable and will therefore be sent an
// exception. Any threads thus released will be immediately
// runnable.
- cap = scheduleDoGC (cap, task, rtsTrue/*force major GC*/, GetRoots);
+ cap = scheduleDoGC (cap, task, rtsTrue/*force major GC*/);
recent_activity = ACTIVITY_DONE_GC;
if ( !emptyRunQueue(cap) ) return;
-#if defined(RTS_USER_SIGNALS) && (!defined(THREADED_RTS) || defined(mingw32_HOST_OS))
+#if defined(RTS_USER_SIGNALS) && !defined(THREADED_RTS)
/* If we have user-installed signal handlers, then wait
* for signals to arrive rather then bombing out with a
* deadlock.
// 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_thread_finished_event(t);
+
#if defined(GRAN)
endThread(t, CurrentProc); // clean-up the thread
#elif defined(PARALLEL_HASKELL)
scheduleCheckBlackHoles(&MainCapability);
debugTrace(DEBUG_sched, "garbage collecting before heap census");
- GarbageCollect(GetRoots, rtsTrue);
+ GarbageCollect(rtsTrue);
debugTrace(DEBUG_sched, "performing heap census");
heapCensus();
* -------------------------------------------------------------------------- */
static Capability *
-scheduleDoGC (Capability *cap, Task *task USED_IF_THREADS,
- rtsBool force_major, void (*get_roots)(evac_fn))
+scheduleDoGC (Capability *cap, Task *task USED_IF_THREADS, rtsBool force_major)
{
StgTSO *t;
#ifdef THREADED_RTS
#if defined(THREADED_RTS)
debugTrace(DEBUG_sched, "doing GC");
#endif
- GarbageCollect(get_roots, force_major);
+ GarbageCollect(force_major);
#if defined(THREADED_RTS)
// release our stash of capabilities.
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;
- RtsFlags.ConcFlags.ctxtSwitchTicks =
- RtsFlags.ConcFlags.ctxtSwitchTime / TICK_MILLISECS;
-
#if defined(THREADED_RTS)
/* Initialise the mutex and condition variables used by
* the scheduler. */
// If we haven't killed all the threads yet, do it now.
if (sched_state < SCHED_SHUTTING_DOWN) {
sched_state = SCHED_INTERRUPTING;
- scheduleDoGC(NULL,task,rtsFalse,GetRoots);
+ scheduleDoGC(NULL,task,rtsFalse);
}
sched_state = SCHED_SHUTTING_DOWN;
boundTaskExiting(task);
stopTaskManager();
}
+#else
+ freeCapability(&MainCapability);
+#endif
+}
+
+void
+freeScheduler( void )
+{
+ freeTaskManager();
+ if (n_capabilities != 1) {
+ stgFree(capabilities);
+ }
+#if defined(THREADED_RTS)
closeMutex(&sched_mutex);
#endif
}
This is the interface to the garbage collector from Haskell land.
We provide this so that external C code can allocate and garbage
collect when called from Haskell via _ccall_GC.
-
- It might be useful to provide an interface whereby the programmer
- can specify more roots (ToDo).
-
- This needs to be protected by the GC condition variable above. KH.
-------------------------------------------------------------------------- */
-static void (*extra_roots)(evac_fn);
-
static void
-performGC_(rtsBool force_major, void (*get_roots)(evac_fn))
+performGC_(rtsBool force_major)
{
Task *task;
// We must grab a new Task here, because the existing Task may be
ACQUIRE_LOCK(&sched_mutex);
task = newBoundTask();
RELEASE_LOCK(&sched_mutex);
- scheduleDoGC(NULL,task,force_major, get_roots);
+ scheduleDoGC(NULL,task,force_major);
boundTaskExiting(task);
}
void
performGC(void)
{
- performGC_(rtsFalse, GetRoots);
+ performGC_(rtsFalse);
}
void
performMajorGC(void)
{
- performGC_(rtsTrue, GetRoots);
-}
-
-static void
-AllRoots(evac_fn evac)
-{
- GetRoots(evac); // the scheduler's roots
- extra_roots(evac); // the user's roots
-}
-
-void
-performGCWithRoots(void (*get_roots)(evac_fn))
-{
- extra_roots = get_roots;
- performGC_(rtsFalse, AllRoots);
+ performGC_(rtsTrue);
}
/* -----------------------------------------------------------------------------
wakeUpRts(void)
{
#if defined(THREADED_RTS)
-#if !defined(mingw32_HOST_OS)
// This forces the IO Manager thread to wakeup, which will
// in turn ensure that some OS thread wakes up and runs the
// scheduler loop, which will cause a GC and deadlock check.
ioManagerWakeup();
-#else
- // On Windows this might be safe enough, because we aren't
- // in a signal handler. Later we should use the IO Manager,
- // though.
- prodOneCapability();
-#endif
#endif
}
This should either be a CATCH_RETRY_FRAME (if the retry# is within an orElse#)
or should be a ATOMICALLY_FRAME (if the retry# reaches the top level).
- We skip CATCH_STM_FRAMEs because retries are not considered to be exceptions,
- despite the similar implementation.
+ We skip CATCH_STM_FRAMEs (aborting and rolling back the nested tx that they
+ create) because retries are not considered to be exceptions, despite the
+ similar implementation.
We should not expect to see CATCH_FRAME or STOP_FRAME because those should
not be created within memory transactions.
case ATOMICALLY_FRAME:
debugTrace(DEBUG_stm,
- "found ATOMICALLY_FRAME at %p during retrry", p);
+ "found ATOMICALLY_FRAME at %p during retry", p);
tso->sp = p;
return ATOMICALLY_FRAME;
tso->sp = p;
return CATCH_RETRY_FRAME;
- case CATCH_STM_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, "trec=%p outer=%p", trec, outer);
+ stmAbortTransaction(tso -> cap, trec);
+ stmFreeAbortedTRec(tso -> cap, trec);
+ tso -> trec = outer;
+ p = next;
+ continue;
+ }
+
+
default:
ASSERT(info->i.type != CATCH_FRAME);
ASSERT(info->i.type != STOP_FRAME);