/* -----------------------------------------------------------------------------
- * $Id: Schedule.c,v 1.2 1998/12/02 13:28:44 simonm Exp $
+ * $Id: Schedule.c,v 1.26 1999/10/04 16:13:18 simonmar Exp $
+ *
+ * (c) The GHC Team, 1998-1999
*
* Scheduler
*
#include "Printer.h"
#include "Main.h"
#include "Signals.h"
-#include "StablePtr.h"
#include "Profiling.h"
#include "Sanity.h"
#define MIN_STACK_WORDS (RESERVED_STACK_WORDS + sizeofW(StgStopFrame) + 2)
/* -----------------------------------------------------------------------------
+ * Static functions
+ * -------------------------------------------------------------------------- */
+static void unblockThread(StgTSO *tso);
+
+/* -----------------------------------------------------------------------------
+ * Comparing Thread ids.
+ *
+ * This is used from STG land in the implementation of the
+ * instances of Eq/Ord for ThreadIds.
+ * -------------------------------------------------------------------------- */
+
+int cmp_thread(const StgTSO *tso1, const StgTSO *tso2)
+{
+ StgThreadID id1 = tso1->id;
+ StgThreadID id2 = tso2->id;
+
+ if (id1 < id2) return (-1);
+ if (id1 > id2) return 1;
+ return 0;
+}
+
+/* -----------------------------------------------------------------------------
Create a new thread.
The new thread starts with the given stack size. Before the
(and possibly some arguments) pushed on its stack. See
pushClosure() in Schedule.h.
- createGenThread() and createIOThread() (in Schedule.h) are
+ createGenThread() and createIOThread() (in SchedAPI.h) are
convenient packaged versions of this function.
-------------------------------------------------------------------------- */
{
StgTSO *tso;
+ /* catch ridiculously small stack sizes */
+ if (stack_size < MIN_STACK_WORDS + TSO_STRUCT_SIZEW) {
+ stack_size = MIN_STACK_WORDS + TSO_STRUCT_SIZEW;
+ }
+
tso = (StgTSO *)allocate(stack_size);
+ TICK_ALLOC_TSO(stack_size-sizeofW(StgTSO),0);
- initThread(tso, stack_size);
+ initThread(tso, stack_size - TSO_STRUCT_SIZEW);
return tso;
}
void
initThread(StgTSO *tso, nat stack_size)
{
- stack_size -= TSO_STRUCT_SIZEW;
-
- /* catch ridiculously small stack sizes */
- if (stack_size < MIN_STACK_WORDS) {
- stack_size = MIN_STACK_WORDS;
- }
-
SET_INFO(tso,&TSO_info);
tso->whatNext = ThreadEnterGHC;
- tso->state = tso_state_runnable;
tso->id = next_thread_id++;
+ tso->why_blocked = NotBlocked;
tso->splim = (P_)&(tso->stack) + RESERVED_STACK_WORDS;
tso->stack_size = stack_size;
- tso->max_stack_size = RtsFlags.GcFlags.maxStkSize - TSO_STRUCT_SIZEW;
+ tso->max_stack_size = round_to_mblocks(RtsFlags.GcFlags.maxStkSize)
+ - TSO_STRUCT_SIZEW;
tso->sp = (P_)&(tso->stack) + stack_size;
#ifdef PROFILING
/* put a stop frame on the stack */
tso->sp -= sizeofW(StgStopFrame);
- SET_HDR(stgCast(StgClosure*,tso->sp),
- (StgInfoTable *)&stg_stop_thread_info,
- CCS_MAIN);
- tso->su = stgCast(StgUpdateFrame*,tso->sp);
+ SET_HDR((StgClosure*)tso->sp,(StgInfoTable *)&stg_stop_thread_info,CCS_MAIN);
+ tso->su = (StgUpdateFrame*)tso->sp;
- IF_DEBUG(scheduler,belch("Initialised thread %lld, stack size = %lx words\n",
+ IF_DEBUG(scheduler,belch("Initialised thread %ld, stack size = %lx words\n",
tso->id, tso->stack_size));
/* Put the new thread on the head of the runnable queue.
}
/* -----------------------------------------------------------------------------
- Delete a thread - reverting all blackholes to (something
- equivalent to) their former state.
-
- We create an AP_UPD for every UpdateFrame on the stack.
- Entering one of these AP_UPDs pushes everything from the corresponding
- update frame upwards onto the stack. (Actually, it pushes everything
- up to the next update frame plus a pointer to the next AP_UPD
- object. Entering the next AP_UPD object pushes more onto the
- stack until we reach the last AP_UPD object - at which point
- the stack should look exactly as it did when we killed the TSO
- and we can continue execution by entering the closure on top of
- the stack.
- -------------------------------------------------------------------------- */
-
-void deleteThread(StgTSO *tso)
-{
- StgUpdateFrame* su = tso->su;
- StgPtr sp = tso->sp;
-
- /* Thread already dead? */
- if (tso->whatNext == ThreadComplete || tso->whatNext == ThreadKilled) {
- return;
- }
-
- IF_DEBUG(scheduler, belch("Killing thread %lld.", tso->id));
-
- tso->whatNext = ThreadKilled; /* changed to ThreadComplete in schedule() */
- tso->link = END_TSO_QUEUE; /* Just to be on the safe side... */
-
- /* Threads that finish normally leave Su pointing to the word
- * beyond the top of the stack, and Sp pointing to the last word
- * on the stack, which is the return value of the thread.
- */
- if ((P_)tso->su >= tso->stack + tso->stack_size
- || get_itbl(tso->su)->type == STOP_FRAME) {
- return;
- }
-
- IF_DEBUG(scheduler,
- fprintf(stderr, "Freezing TSO stack\n");
- printTSO(tso);
- );
-
- /* The stack freezing code assumes there's a closure pointer on
- * the top of the stack. This isn't always the case with compiled
- * code, so we have to push a dummy closure on the top which just
- * returns to the next return address on the stack.
- */
- if (LOOKS_LIKE_GHC_INFO(*sp)) {
- *(--sp) = (W_)&dummy_ret_closure;
- }
-
- while (1) {
- int words = (stgCast(StgPtr,su) - stgCast(StgPtr,sp)) - 1;
- nat i;
- StgAP_UPD* ap = stgCast(StgAP_UPD*,allocate(AP_sizeW(words)));
-
- /* First build an AP_UPD consisting of the stack chunk above the
- * current update frame, with the top word on the stack as the
- * fun field.
- */
- ASSERT(words >= 0);
-
- /* if (words == 0) { -- optimisation
- ap = stgCast(StgAP_UPD*,*stgCast(StgPtr*,sp)++);
- } else */ {
- ap->n_args = words;
- ap->fun = stgCast(StgClosure*,*stgCast(StgPtr*,sp)++);
- for(i=0; i < (nat)words; ++i) {
- payloadWord(ap,i) = *sp++;
- }
- }
-
- switch (get_itbl(su)->type) {
-
- case UPDATE_FRAME:
- {
- SET_HDR(ap,&AP_UPD_info,su->header.prof.ccs /* ToDo */);
-
- IF_DEBUG(scheduler,
- fprintf(stderr, "Updating ");
- printPtr(stgCast(StgPtr,su->updatee));
- fprintf(stderr, " with ");
- printObj(stgCast(StgClosure*,ap));
- );
-
- /* Replace the updatee with an indirection - happily
- * this will also wake up any threads currently
- * waiting on the result.
- */
- UPD_IND(su->updatee,ap); /* revert the black hole */
- su = su->link;
- sp += sizeofW(StgUpdateFrame) -1;
- sp[0] = stgCast(StgWord,ap); /* push onto stack */
- break;
- }
-
- case CATCH_FRAME:
- {
- StgCatchFrame *cf = (StgCatchFrame *)su;
- StgClosure* o;
-
- /* We want a PAP, not an AP_UPD. Fortunately, the
- * layout's the same.
- */
- SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
-
- /* now build o = FUN(catch,ap,handler) */
- o = stgCast(StgClosure*, allocate(sizeofW(StgClosure)+2));
- SET_HDR(o,&catch_info,su->header.prof.ccs /* ToDo */);
- payloadCPtr(o,0) = stgCast(StgClosure*,ap);
- payloadCPtr(o,1) = cf->handler;
-
- IF_DEBUG(scheduler,
- fprintf(stderr, "Built ");
- printObj(stgCast(StgClosure*,o));
- );
-
- /* pop the old handler and put o on the stack */
- su = cf->link;
- sp += sizeofW(StgCatchFrame) - 1;
- sp[0] = (W_)o;
- break;
- }
-
- case SEQ_FRAME:
- {
- StgSeqFrame *sf = (StgSeqFrame *)su;
- StgClosure* o;
-
- SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
-
- /* now build o = FUN(seq,ap) */
- o = stgCast(StgClosure*, allocate(sizeofW(StgClosure)+1));
- SET_HDR(o,&seq_info,su->header.prof.ccs /* ToDo */);
- payloadCPtr(o,0) = stgCast(StgClosure*,ap);
-
- IF_DEBUG(scheduler,
- fprintf(stderr, "Built ");
- printObj(stgCast(StgClosure*,o));
- );
-
- /* pop the old handler and put o on the stack */
- su = sf->link;
- sp += sizeofW(StgSeqFrame) - 1;
- sp[0] = (W_)o;
- break;
- }
-
- case STOP_FRAME:
- return;
-
- default:
- barf("freezeTSO");
- }
- }
-}
+ * initScheduler()
+ *
+ * Initialise the scheduler. This resets all the queues - if the
+ * queues contained any threads, they'll be garbage collected at the
+ * next pass.
+ * -------------------------------------------------------------------------- */
void initScheduler(void)
{
ccalling_threads = CurrentTSO;
in_ccall_gc = rtsTrue;
IF_DEBUG(scheduler,
- fprintf(stderr, "Re-entry, thread %lld did a _ccall_gc\n",
+ fprintf(stderr, "Re-entry, thread %d did a _ccall_gc\n",
CurrentTSO->id););
} else {
in_ccall_gc = rtsFalse;
/* If we have more threads on the run queue, set up a context
* switch at some point in the future.
*/
- if (run_queue_hd != END_TSO_QUEUE) {
+ if (run_queue_hd != END_TSO_QUEUE || blocked_queue_hd != END_TSO_QUEUE) {
context_switch = 1;
} else {
context_switch = 0;
}
- IF_DEBUG(scheduler, belch("Running thread %lld...\n", t->id));
+ IF_DEBUG(scheduler, belch("Running thread %ld...\n", t->id));
+
+ /* Be friendly to the storage manager: we're about to *run* this
+ * thread, so we better make sure the TSO is mutable.
+ */
+ if (t->mut_link == NULL) {
+ recordMutable((StgMutClosure *)t);
+ }
/* Run the current thread */
switch (t->whatNext) {
LoadThreadState();
/* CHECK_SENSIBLE_REGS(); */
{
- StgClosure* c = stgCast(StgClosure*,*Sp);
+ StgClosure* c = (StgClosure *)Sp[0];
Sp += 1;
ret = enter(c);
}
switch (ret) {
case HeapOverflow:
- IF_DEBUG(scheduler,belch("Thread %lld stopped: HeapOverflow\n", t->id));
+ IF_DEBUG(scheduler,belch("Thread %ld stopped: HeapOverflow\n", t->id));
threadPaused(t);
PUSH_ON_RUN_QUEUE(t);
GarbageCollect(GetRoots);
break;
case StackOverflow:
- IF_DEBUG(scheduler,belch("Thread %lld stopped, StackOverflow\n", t->id));
+ IF_DEBUG(scheduler,belch("Thread %ld stopped, StackOverflow\n", t->id));
{
nat i;
/* enlarge the stack */
/* ToDo: or maybe a timer expired when we were in Hugs?
* or maybe someone hit ctrl-C
*/
- belch("Thread %lld stopped to switch to Hugs\n", t->id);
+ belch("Thread %ld stopped to switch to Hugs\n", t->id);
} else {
- belch("Thread %lld stopped, timer expired\n", t->id);
+ belch("Thread %ld stopped, timer expired\n", t->id);
}
);
threadPaused(t);
* t->link is already set to END_TSO_QUEUE.
*/
ASSERT(t->link == END_TSO_QUEUE);
- if (run_queue_tl != END_TSO_QUEUE) {
+ if (run_queue_tl == END_TSO_QUEUE) {
+ run_queue_hd = run_queue_tl = t;
+ } else {
ASSERT(get_itbl(run_queue_tl)->type == TSO);
if (run_queue_hd == run_queue_tl) {
run_queue_hd->link = t;
run_queue_tl = t;
} else {
run_queue_tl->link = t;
+ run_queue_tl = t;
}
- } else {
- run_queue_hd = run_queue_tl = t;
}
break;
case ThreadBlocked:
- IF_DEBUG(scheduler,belch("Thread %lld stopped, blocking\n", t->id));
+ IF_DEBUG(scheduler,
+ fprintf(stderr, "Thread %d stopped, ", t->id);
+ printThreadBlockage(t);
+ fprintf(stderr, "\n"));
threadPaused(t);
/* assume the thread has put itself on some blocked queue
* somewhere.
break;
case ThreadFinished:
- IF_DEBUG(scheduler,belch("Thread %lld finished\n", t->id));
- deleteThread(t);
+ IF_DEBUG(scheduler,belch("Thread %ld finished\n", t->id));
t->whatNext = ThreadComplete;
break;
}
/* check for signals each time around the scheduler */
+#ifndef __MINGW32__
if (signals_pending()) {
start_signal_handlers();
}
-
+#endif
/* If our main thread has finished or been killed, return.
* If we were re-entered as a result of a _ccall_gc, then
* pop the blocked thread off the ccalling_threads stack back
if (in_ccall_gc) {
CurrentTSO = ccalling_threads;
ccalling_threads = ccalling_threads->link;
+ /* remember to stub the link field of CurrentTSO */
+ CurrentTSO->link = END_TSO_QUEUE;
}
if ((*MainTSO)->whatNext == ThreadComplete) {
/* we finished successfully, fill in the return value */
}
next_thread:
+ /* Checked whether any waiting threads need to be woken up.
+ * If the run queue is empty, we can wait indefinitely for
+ * something to happen.
+ */
+ if (blocked_queue_hd != END_TSO_QUEUE) {
+ awaitEvent(run_queue_hd == END_TSO_QUEUE);
+ }
+
t = run_queue_hd;
if (t != END_TSO_QUEUE) {
run_queue_hd = t->link;
}
}
- if (blocked_queue_hd != END_TSO_QUEUE) {
- return AllBlocked;
- } else {
- return Deadlock;
+ /* If we got to here, then we ran out of threads to run, but the
+ * main thread hasn't finished yet. It must be blocked on an MVar
+ * or a black hole somewhere, so we return deadlock.
+ */
+ return Deadlock;
+}
+
+/* -----------------------------------------------------------------------------
+ Debugging: why is a thread blocked
+ -------------------------------------------------------------------------- */
+
+#ifdef DEBUG
+void printThreadBlockage(StgTSO *tso)
+{
+ switch (tso->why_blocked) {
+ case BlockedOnRead:
+ fprintf(stderr,"blocked on read from fd %d", tso->block_info.fd);
+ break;
+ case BlockedOnWrite:
+ fprintf(stderr,"blocked on write to fd %d", tso->block_info.fd);
+ break;
+ case BlockedOnDelay:
+ fprintf(stderr,"blocked on delay of %d ms", tso->block_info.delay);
+ break;
+ case BlockedOnMVar:
+ fprintf(stderr,"blocked on an MVar");
+ break;
+ case BlockedOnBlackHole:
+ fprintf(stderr,"blocked on a black hole");
+ break;
+ case NotBlocked:
+ fprintf(stderr,"not blocked");
+ break;
}
}
+#endif
/* -----------------------------------------------------------------------------
Where are the roots that we know about?
for (i = 0; i < next_main_thread; i++) {
main_threads[i] = (StgTSO *)MarkRoot((StgClosure *)main_threads[i]);
}
-
- markStablePtrTable();
}
/* -----------------------------------------------------------------------------
StgTSO *dest;
if (tso->stack_size >= tso->max_stack_size) {
- /* ToDo: just kill this thread? */
-#ifdef DEBUG
+#if 0
/* If we're debugging, just print out the top of the stack */
printStackChunk(tso->sp, stg_min(tso->stack+tso->stack_size,
tso->sp+64));
#endif
- stackOverflow(tso->max_stack_size);
+#ifdef INTERPRETER
+ fprintf(stderr, "fatal: stack overflow in Hugs; aborting\n" );
+ exit(1);
+#else
+ /* Send this thread the StackOverflow exception */
+ raiseAsync(tso, (StgClosure *)&stackOverflow_closure);
+#endif
+ return tso;
}
/* Try to double the current stack size. If that takes us over the
new_stack_size = stg_min(tso->stack_size * 2, tso->max_stack_size);
new_tso_size = (nat)BLOCK_ROUND_UP(new_stack_size * sizeof(W_) +
TSO_STRUCT_SIZE)/sizeof(W_);
+ new_tso_size = round_to_mblocks(new_tso_size); /* Be MBLOCK-friendly */
new_stack_size = new_tso_size - TSO_STRUCT_SIZEW;
IF_DEBUG(scheduler, fprintf(stderr,"increasing stack size from %d words to %d.\n", tso->stack_size, new_stack_size));
dest = (StgTSO *)allocate(new_tso_size);
+ TICK_ALLOC_TSO(new_tso_size-sizeofW(StgTSO),0);
/* copy the TSO block and the old stack into the new area */
memcpy(dest,tso,TSO_STRUCT_SIZE);
/* and relocate the update frame list */
relocate_TSO(tso, dest);
- IF_DEBUG(sanity,checkTSO(tso,0)); /* Step 0 because we're not GC'ing. */
+ /* Mark the old one as dead so we don't try to scavenge it during
+ * garbage collection (the TSO will likely be on a mutables list in
+ * some generation, but it'll get collected soon enough). It's
+ * important to set the sp and su values to just beyond the end of
+ * the stack, so we don't attempt to scavenge any part of the dead
+ * TSO's stack.
+ */
+ tso->whatNext = ThreadKilled;
+ tso->sp = (P_)&(tso->stack[tso->stack_size]);
+ tso->su = (StgUpdateFrame *)tso->sp;
+ tso->why_blocked = NotBlocked;
+ dest->mut_link = NULL;
+
+ IF_DEBUG(sanity,checkTSO(tso));
#if 0
IF_DEBUG(scheduler,printTSO(dest));
#endif
}
/* -----------------------------------------------------------------------------
- Wake up a queue that was blocked on some resource (usually a
- computation in progress).
+ Wake up a queue that was blocked on some resource.
-------------------------------------------------------------------------- */
-void awaken_blocked_queue(StgTSO *q)
+StgTSO *unblockOne(StgTSO *tso)
{
- StgTSO *tso;
+ StgTSO *next;
+
+ ASSERT(get_itbl(tso)->type == TSO);
+ ASSERT(tso->why_blocked != NotBlocked);
+ tso->why_blocked = NotBlocked;
+ next = tso->link;
+ tso->link = END_TSO_QUEUE;
+ PUSH_ON_RUN_QUEUE(tso);
+ IF_DEBUG(scheduler,belch("Waking up thread %ld", tso->id));
+ return next;
+}
- while (q != END_TSO_QUEUE) {
- ASSERT(get_itbl(q)->type == TSO);
- tso = q;
- q = tso->link;
- PUSH_ON_RUN_QUEUE(tso);
- IF_DEBUG(scheduler,belch("Waking up thread %lld", tso->id));
+void awakenBlockedQueue(StgTSO *tso)
+{
+ while (tso != END_TSO_QUEUE) {
+ tso = unblockOne(tso);
}
}
- usually called inside a signal handler so it mustn't do anything fancy.
-------------------------------------------------------------------------- */
-void interruptStgRts(void)
+void
+interruptStgRts(void)
{
interrupted = 1;
context_switch = 1;
}
+/* -----------------------------------------------------------------------------
+ Unblock a thread
+
+ This is for use when we raise an exception in another thread, which
+ may be blocked.
+ -------------------------------------------------------------------------- */
+
+static void
+unblockThread(StgTSO *tso)
+{
+ StgTSO *t, **last;
+
+ switch (tso->why_blocked) {
+
+ case NotBlocked:
+ return; /* not blocked */
+
+ case BlockedOnMVar:
+ ASSERT(get_itbl(tso->block_info.closure)->type == MVAR);
+ {
+ StgTSO *last_tso = END_TSO_QUEUE;
+ StgMVar *mvar = (StgMVar *)(tso->block_info.closure);
+
+ last = &mvar->head;
+ for (t = mvar->head; t != END_TSO_QUEUE;
+ last = &t->link, last_tso = t, t = t->link) {
+ if (t == tso) {
+ *last = tso->link;
+ if (mvar->tail == tso) {
+ mvar->tail = last_tso;
+ }
+ goto done;
+ }
+ }
+ barf("unblockThread (MVAR): TSO not found");
+ }
+
+ case BlockedOnBlackHole:
+ ASSERT(get_itbl(tso->block_info.closure)->type == BLACKHOLE_BQ);
+ {
+ StgBlockingQueue *bq = (StgBlockingQueue *)(tso->block_info.closure);
+
+ last = &bq->blocking_queue;
+ for (t = bq->blocking_queue; t != END_TSO_QUEUE;
+ last = &t->link, t = t->link) {
+ if (t == tso) {
+ *last = tso->link;
+ goto done;
+ }
+ }
+ barf("unblockThread (BLACKHOLE): TSO not found");
+ }
+
+ case BlockedOnDelay:
+ case BlockedOnRead:
+ case BlockedOnWrite:
+ {
+ last = &blocked_queue_hd;
+ for (t = blocked_queue_hd; t != END_TSO_QUEUE;
+ last = &t->link, t = t->link) {
+ if (t == tso) {
+ *last = tso->link;
+ if (blocked_queue_tl == t) {
+ blocked_queue_tl = tso->link;
+ }
+ goto done;
+ }
+ }
+ barf("unblockThread (I/O): TSO not found");
+ }
+
+ default:
+ barf("unblockThread");
+ }
+
+ done:
+ tso->link = END_TSO_QUEUE;
+ tso->why_blocked = NotBlocked;
+ tso->block_info.closure = NULL;
+ PUSH_ON_RUN_QUEUE(tso);
+}
+
+/* -----------------------------------------------------------------------------
+ * raiseAsync()
+ *
+ * The following function implements the magic for raising an
+ * asynchronous exception in an existing thread.
+ *
+ * We first remove the thread from any queue on which it might be
+ * blocked. The possible blockages are MVARs and BLACKHOLE_BQs.
+ *
+ * We strip the stack down to the innermost CATCH_FRAME, building
+ * thunks in the heap for all the active computations, so they can
+ * be restarted if necessary. When we reach a CATCH_FRAME, we build
+ * an application of the handler to the exception, and push it on
+ * the top of the stack.
+ *
+ * How exactly do we save all the active computations? We create an
+ * AP_UPD for every UpdateFrame on the stack. Entering one of these
+ * AP_UPDs pushes everything from the corresponding update frame
+ * upwards onto the stack. (Actually, it pushes everything up to the
+ * next update frame plus a pointer to the next AP_UPD object.
+ * Entering the next AP_UPD object pushes more onto the stack until we
+ * reach the last AP_UPD object - at which point the stack should look
+ * exactly as it did when we killed the TSO and we can continue
+ * execution by entering the closure on top of the stack.
+ *
+ * We can also kill a thread entirely - this happens if either (a) the
+ * exception passed to raiseAsync is NULL, or (b) there's no
+ * CATCH_FRAME on the stack. In either case, we strip the entire
+ * stack and replace the thread with a zombie.
+ *
+ * -------------------------------------------------------------------------- */
+
+void
+deleteThread(StgTSO *tso)
+{
+ raiseAsync(tso,NULL);
+}
+
+void
+raiseAsync(StgTSO *tso, StgClosure *exception)
+{
+ StgUpdateFrame* su = tso->su;
+ StgPtr sp = tso->sp;
+
+ /* Thread already dead? */
+ if (tso->whatNext == ThreadComplete || tso->whatNext == ThreadKilled) {
+ return;
+ }
+
+ IF_DEBUG(scheduler, belch("Raising exception in thread %ld.", tso->id));
+
+ /* Remove it from any blocking queues */
+ unblockThread(tso);
+
+ /* The stack freezing code assumes there's a closure pointer on
+ * the top of the stack. This isn't always the case with compiled
+ * code, so we have to push a dummy closure on the top which just
+ * returns to the next return address on the stack.
+ */
+ if ( LOOKS_LIKE_GHC_INFO((void*)*sp) ) {
+ *(--sp) = (W_)&dummy_ret_closure;
+ }
+
+ while (1) {
+ int words = ((P_)su - (P_)sp) - 1;
+ nat i;
+ StgAP_UPD * ap;
+
+ /* If we find a CATCH_FRAME, and we've got an exception to raise,
+ * then build PAP(handler,exception), and leave it on top of
+ * the stack ready to enter.
+ */
+ if (get_itbl(su)->type == CATCH_FRAME && exception != NULL) {
+ StgCatchFrame *cf = (StgCatchFrame *)su;
+ /* we've got an exception to raise, so let's pass it to the
+ * handler in this frame.
+ */
+ ap = (StgAP_UPD *)allocate(sizeofW(StgPAP) + 1);
+ TICK_ALLOC_UPD_PAP(2,0);
+ SET_HDR(ap,&PAP_info,cf->header.prof.ccs);
+
+ ap->n_args = 1;
+ ap->fun = cf->handler;
+ ap->payload[0] = (P_)exception;
+
+ /* sp currently points to the word above the CATCH_FRAME on the
+ * stack. Replace the CATCH_FRAME with a pointer to the new handler
+ * application.
+ */
+ sp += sizeofW(StgCatchFrame);
+ sp[0] = (W_)ap;
+ tso->su = cf->link;
+ tso->sp = sp;
+ tso->whatNext = ThreadEnterGHC;
+ return;
+ }
+
+ /* First build an AP_UPD consisting of the stack chunk above the
+ * current update frame, with the top word on the stack as the
+ * fun field.
+ */
+ ap = (StgAP_UPD *)allocate(AP_sizeW(words));
+
+ ASSERT(words >= 0);
+
+ ap->n_args = words;
+ ap->fun = (StgClosure *)sp[0];
+ sp++;
+ for(i=0; i < (nat)words; ++i) {
+ ap->payload[i] = (P_)*sp++;
+ }
+
+ switch (get_itbl(su)->type) {
+
+ case UPDATE_FRAME:
+ {
+ SET_HDR(ap,&AP_UPD_info,su->header.prof.ccs /* ToDo */);
+ TICK_ALLOC_UP_THK(words+1,0);
+
+ IF_DEBUG(scheduler,
+ fprintf(stderr, "Updating ");
+ printPtr((P_)su->updatee);
+ fprintf(stderr, " with ");
+ printObj((StgClosure *)ap);
+ );
+
+ /* Replace the updatee with an indirection - happily
+ * this will also wake up any threads currently
+ * waiting on the result.
+ */
+ UPD_IND(su->updatee,ap); /* revert the black hole */
+ su = su->link;
+ sp += sizeofW(StgUpdateFrame) -1;
+ sp[0] = (W_)ap; /* push onto stack */
+ break;
+ }
+
+ case CATCH_FRAME:
+ {
+ StgCatchFrame *cf = (StgCatchFrame *)su;
+ StgClosure* o;
+
+ /* We want a PAP, not an AP_UPD. Fortunately, the
+ * layout's the same.
+ */
+ SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
+ TICK_ALLOC_UPD_PAP(words+1,0);
+
+ /* now build o = FUN(catch,ap,handler) */
+ o = (StgClosure *)allocate(sizeofW(StgClosure)+2);
+ TICK_ALLOC_FUN(2,0);
+ SET_HDR(o,&catch_info,su->header.prof.ccs /* ToDo */);
+ o->payload[0] = (StgClosure *)ap;
+ o->payload[1] = cf->handler;
+
+ IF_DEBUG(scheduler,
+ fprintf(stderr, "Built ");
+ printObj((StgClosure *)o);
+ );
+
+ /* pop the old handler and put o on the stack */
+ su = cf->link;
+ sp += sizeofW(StgCatchFrame) - 1;
+ sp[0] = (W_)o;
+ break;
+ }
+
+ case SEQ_FRAME:
+ {
+ StgSeqFrame *sf = (StgSeqFrame *)su;
+ StgClosure* o;
+
+ SET_HDR(ap,&PAP_info,su->header.prof.ccs /* ToDo */);
+ TICK_ALLOC_UPD_PAP(words+1,0);
+
+ /* now build o = FUN(seq,ap) */
+ o = (StgClosure *)allocate(sizeofW(StgClosure)+1);
+ TICK_ALLOC_SE_THK(1,0);
+ SET_HDR(o,&seq_info,su->header.prof.ccs /* ToDo */);
+ payloadCPtr(o,0) = (StgClosure *)ap;
+
+ IF_DEBUG(scheduler,
+ fprintf(stderr, "Built ");
+ printObj((StgClosure *)o);
+ );
+
+ /* pop the old handler and put o on the stack */
+ su = sf->link;
+ sp += sizeofW(StgSeqFrame) - 1;
+ sp[0] = (W_)o;
+ break;
+ }
+
+ case STOP_FRAME:
+ /* We've stripped the entire stack, the thread is now dead. */
+ sp += sizeofW(StgStopFrame) - 1;
+ sp[0] = (W_)exception; /* save the exception */
+ tso->whatNext = ThreadKilled;
+ tso->su = (StgUpdateFrame *)(sp+1);
+ tso->sp = sp;
+ return;
+
+ default:
+ barf("raiseAsync");
+ }
+ }
+ barf("raiseAsync");
+}
projects / ghc-hetmet.git / blobdiff