/* ---------------------------------------------------------------------------
- * $Id: Schedule.c,v 1.198 2004/05/27 15:21:37 simonmar Exp $
*
- * (c) The GHC Team, 1998-2003
+ * (c) The GHC Team, 1998-2004
*
* Scheduler
*
#include "SchedAPI.h"
#include "RtsUtils.h"
#include "RtsFlags.h"
+#include "BlockAlloc.h"
#include "Storage.h"
#include "StgRun.h"
-#include "StgStartup.h"
#include "Hooks.h"
#define COMPILING_SCHEDULER
#include "Schedule.h"
#include "Timer.h"
#include "Prelude.h"
#include "ThreadLabels.h"
+#include "LdvProfile.h"
+#include "Updates.h"
#ifdef PROFILING
#include "Proftimer.h"
#include "ProfHeap.h"
#if DEBUG
static char *whatNext_strs[] = {
+ "(unknown)",
"ThreadRunGHC",
"ThreadInterpret",
"ThreadKilled",
# endif
#endif
rtsBool was_interrupted = rtsFalse;
- StgTSOWhatNext prev_what_next;
+ nat prev_what_next;
// Pre-condition: sched_mutex is held.
// We might have a capability, passed in as initialCapability.
|| blocked_queue_hd != END_TSO_QUEUE
|| sleeping_queue != END_TSO_QUEUE)))
context_switch = 1;
- else
- context_switch = 0;
run_thread:
#endif
// did the task ask for a large block?
- if (cap->r.rHpAlloc > BLOCK_SIZE_W) {
+ if (cap->r.rHpAlloc > BLOCK_SIZE) {
// if so, get one and push it on the front of the nursery.
bdescr *bd;
nat blocks;
- blocks = (nat)BLOCK_ROUND_UP(cap->r.rHpAlloc * sizeof(W_)) / BLOCK_SIZE;
+ blocks = (nat)BLOCK_ROUND_UP(cap->r.rHpAlloc) / BLOCK_SIZE;
IF_DEBUG(scheduler,belch("--<< thread %ld (%s) stopped: requesting a large block (size %d)",
t->id, whatNext_strs[t->what_next], blocks));
break;
case ThreadYielding:
+ // Reset the context switch flag. We don't do this just before
+ // running the thread, because that would mean we would lose ticks
+ // during GC, which can lead to unfair scheduling (a thread hogs
+ // the CPU because the tick always arrives during GC). This way
+ // penalises threads that do a lot of allocation, but that seems
+ // better than the alternative.
+ context_switch = 0;
+
#if defined(GRAN)
IF_DEBUG(gran,
DumpGranEvent(GR_DESCHEDULE, t));
* ------------------------------------------------------------------------- */
StgInt
-suspendThread( StgRegTable *reg,
- rtsBool concCall
-#if !defined(DEBUG)
- STG_UNUSED
-#endif
- )
+suspendThread( StgRegTable *reg )
{
nat tok;
Capability *cap;
ACQUIRE_LOCK(&sched_mutex);
IF_DEBUG(scheduler,
- sched_belch("thread %d did a _ccall_gc (is_concurrent: %d)", cap->r.rCurrentTSO->id,concCall));
+ sched_belch("thread %d did a _ccall_gc", cap->r.rCurrentTSO->id));
// XXX this might not be necessary --SDM
cap->r.rCurrentTSO->what_next = ThreadRunGHC;
}
StgRegTable *
-resumeThread( StgInt tok,
- rtsBool concCall STG_UNUSED )
+resumeThread( StgInt tok )
{
StgTSO *tso, **prev;
Capability *cap;
/* put a stop frame on the stack */
tso->sp -= sizeofW(StgStopFrame);
SET_HDR((StgClosure*)tso->sp,(StgInfoTable *)&stg_stop_thread_info,CCS_SYSTEM);
+ tso->link = END_TSO_QUEUE;
+
// ToDo: check this
#if defined(GRAN)
- tso->link = END_TSO_QUEUE;
/* uses more flexible routine in GranSim */
insertThread(tso, CurrentProc);
#else
scheduleThread_(StgTSO *tso)
{
// Precondition: sched_mutex must be held.
- PUSH_ON_RUN_QUEUE(tso);
+ // The thread goes at the *end* of the run-queue, to avoid possible
+ // starvation of any threads already on the queue.
+ APPEND_TO_RUN_QUEUE(tso);
THREAD_RUNNABLE();
}
*/
IF_DEBUG(scheduler, sched_belch("waiting for thread (%d)", tso->id));
- PUSH_ON_RUN_QUEUE(tso);
+ APPEND_TO_RUN_QUEUE(tso);
// NB. Don't call THREAD_RUNNABLE() here, because the thread is
// bound and only runnable by *this* OS thread, so waking up other
// workers will just slow things down.
/* if it's a TSO just push it onto the run_queue */
next = bqe->link;
// ((StgTSO *)bqe)->link = END_TSO_QUEUE; // debugging?
- PUSH_ON_RUN_QUEUE((StgTSO *)bqe);
+ APPEND_TO_RUN_QUEUE((StgTSO *)bqe);
THREAD_RUNNABLE();
unblockCount(bqe, node);
/* reset blocking status after dumping event */
ASSERT(tso->why_blocked != NotBlocked);
tso->why_blocked = NotBlocked;
next = tso->link;
- PUSH_ON_RUN_QUEUE(tso);
+ APPEND_TO_RUN_QUEUE(tso);
THREAD_RUNNABLE();
IF_DEBUG(scheduler,sched_belch("waking up thread %ld", tso->id));
return next;
tso->link = END_TSO_QUEUE;
tso->why_blocked = NotBlocked;
tso->block_info.closure = NULL;
- PUSH_ON_RUN_QUEUE(tso);
+ APPEND_TO_RUN_QUEUE(tso);
}
#endif
//
if (!closure_IND(((StgUpdateFrame *)frame)->updatee)) {
// revert the black hole
- UPD_IND_NOLOCK(((StgUpdateFrame *)frame)->updatee,ap);
+ UPD_IND_NOLOCK(((StgUpdateFrame *)frame)->updatee,
+ (StgClosure *)ap);
}
sp += sizeofW(StgUpdateFrame) - 1;
sp[0] = (W_)ap; // push onto stack
}
/* -----------------------------------------------------------------------------
+ raiseExceptionHelper
+
+ This function is called by the raise# primitve, just so that we can
+ move some of the tricky bits of raising an exception from C-- into
+ C. Who knows, it might be a useful re-useable thing here too.
+ -------------------------------------------------------------------------- */
+
+StgWord
+raiseExceptionHelper (StgTSO *tso, StgClosure *exception)
+{
+ StgClosure *raise_closure = NULL;
+ StgPtr p, next;
+ StgRetInfoTable *info;
+ //
+ // This closure represents the expression 'raise# E' where E
+ // is the exception raise. It is used to overwrite all the
+ // thunks which are currently under evaluataion.
+ //
+
+ //
+ // LDV profiling: stg_raise_info has THUNK as its closure
+ // type. Since a THUNK takes at least MIN_UPD_SIZE words in its
+ // payload, MIN_UPD_SIZE is more approprate than 1. It seems that
+ // 1 does not cause any problem unless profiling is performed.
+ // However, when LDV profiling goes on, we need to linearly scan
+ // small object pool, where raise_closure is stored, so we should
+ // use MIN_UPD_SIZE.
+ //
+ // raise_closure = (StgClosure *)RET_STGCALL1(P_,allocate,
+ // sizeofW(StgClosure)+1);
+ //
+
+ //
+ // Walk up the stack, looking for the catch frame. On the way,
+ // we update any closures pointed to from update frames with the
+ // raise closure that we just built.
+ //
+ p = tso->sp;
+ while(1) {
+ info = get_ret_itbl((StgClosure *)p);
+ next = p + stack_frame_sizeW((StgClosure *)p);
+ switch (info->i.type) {
+
+ case UPDATE_FRAME:
+ // Only create raise_closure if we need to.
+ if (raise_closure == NULL) {
+ raise_closure =
+ (StgClosure *)allocate(sizeofW(StgClosure)+MIN_UPD_SIZE);
+ SET_HDR(raise_closure, &stg_raise_info, CCCS);
+ raise_closure->payload[0] = exception;
+ }
+ UPD_IND(((StgUpdateFrame *)p)->updatee,raise_closure);
+ p = next;
+ continue;
+
+ case CATCH_FRAME:
+ tso->sp = p;
+ return CATCH_FRAME;
+
+ case STOP_FRAME:
+ tso->sp = p;
+ return STOP_FRAME;
+
+ default:
+ p = next;
+ continue;
+ }
+ }
+}
+
+/* -----------------------------------------------------------------------------
resurrectThreads is called after garbage collection on the list of
threads found to be garbage. Each of these threads will be woken
up and sent a signal: BlockedOnDeadMVar if the thread was blocked
projects / ghc-hetmet.git / blobdiff