Commit 456eca73 authored by simonm's avatar simonm

[project @ 1999-03-16 13:20:07 by simonm]

Improvements to the threading model.

   - asynchronous exceptions supported.

	- killThread# can now raise an exception in the specified
	  thread.  It's new type is

		killThread# :: ThreadId# -> Exception -> IO ()

	  High-level versions:

		killThread :: ThreadId -> IO ()
		raiseInThread :: ThreadId -> Exception -> IO ()

	  (killThread raises a 'ThreadKilled' exception in the
	   specified thread).

	  If the thread has no exception handler, it is killed
	  as before.  Otherwise, the exception is passed to
	  the innermost CATCH_FRAME and the thread is woken up
	  if it was blocked.  The current computation is
	  suspended, instead of being replaced by the exception
	  (as is the case with throw).

	  Sending an exception to the current thread works too.

   - new primitive: myThreadId# :: IO ThreadId# and corresponding
     high-level version myThreadId :: IO ThreadId.

   - new primitive: yield# :: IO (), and yield :: IO ().

   - the TSO now contains a pointer to the resource currently blocked
     on (MVAR or BLACKHOLE_BQ).

  - Add a giant comment to TSO.h about what the various link fields
    are supposed to do, and invariants etc.
parent 8306cc58
......@@ -274,6 +274,8 @@ about using it this way?? ADR)
-- concurrency
| ForkOp
| KillThreadOp
| YieldOp
| MyThreadIdOp
| DelayOp
| WaitReadOp
| WaitWriteOp
......@@ -525,23 +527,25 @@ tagOf_PrimOp SeqOp = ILIT(220)
tagOf_PrimOp ParOp = ILIT(221)
tagOf_PrimOp ForkOp = ILIT(222)
tagOf_PrimOp KillThreadOp = ILIT(223)
tagOf_PrimOp DelayOp = ILIT(224)
tagOf_PrimOp WaitReadOp = ILIT(225)
tagOf_PrimOp WaitWriteOp = ILIT(226)
tagOf_PrimOp ParGlobalOp = ILIT(227)
tagOf_PrimOp ParLocalOp = ILIT(228)
tagOf_PrimOp ParAtOp = ILIT(229)
tagOf_PrimOp ParAtAbsOp = ILIT(230)
tagOf_PrimOp ParAtRelOp = ILIT(231)
tagOf_PrimOp ParAtForNowOp = ILIT(232)
tagOf_PrimOp CopyableOp = ILIT(233)
tagOf_PrimOp NoFollowOp = ILIT(234)
tagOf_PrimOp NewMutVarOp = ILIT(235)
tagOf_PrimOp ReadMutVarOp = ILIT(236)
tagOf_PrimOp WriteMutVarOp = ILIT(237)
tagOf_PrimOp SameMutVarOp = ILIT(238)
tagOf_PrimOp CatchOp = ILIT(239)
tagOf_PrimOp RaiseOp = ILIT(240)
tagOf_PrimOp YieldOp = ILIT(224)
tagOf_PrimOp MyThreadIdOp = ILIT(225)
tagOf_PrimOp DelayOp = ILIT(226)
tagOf_PrimOp WaitReadOp = ILIT(227)
tagOf_PrimOp WaitWriteOp = ILIT(228)
tagOf_PrimOp ParGlobalOp = ILIT(229)
tagOf_PrimOp ParLocalOp = ILIT(230)
tagOf_PrimOp ParAtOp = ILIT(231)
tagOf_PrimOp ParAtAbsOp = ILIT(232)
tagOf_PrimOp ParAtRelOp = ILIT(233)
tagOf_PrimOp ParAtForNowOp = ILIT(234)
tagOf_PrimOp CopyableOp = ILIT(235)
tagOf_PrimOp NoFollowOp = ILIT(236)
tagOf_PrimOp NewMutVarOp = ILIT(237)
tagOf_PrimOp ReadMutVarOp = ILIT(238)
tagOf_PrimOp WriteMutVarOp = ILIT(239)
tagOf_PrimOp SameMutVarOp = ILIT(240)
tagOf_PrimOp CatchOp = ILIT(241)
tagOf_PrimOp RaiseOp = ILIT(242)
tagOf_PrimOp op = pprPanic# "tagOf_PrimOp: pattern-match" (ppr op)
--panic# "tagOf_PrimOp: pattern-match"
......@@ -802,6 +806,8 @@ allThePrimOps
ParOp,
ForkOp,
KillThreadOp,
YieldOp,
MyThreadIdOp,
DelayOp,
WaitReadOp,
WaitWriteOp
......@@ -1530,9 +1536,21 @@ primOpInfo ForkOp
-- killThread# :: ThreadId# -> State# RealWorld -> State# RealWorld
primOpInfo KillThreadOp
= mkGenPrimOp SLIT("killThread#") []
[threadIdPrimTy, realWorldStatePrimTy]
= mkGenPrimOp SLIT("killThread#") [alphaTyVar]
[threadIdPrimTy, alphaTy, realWorldStatePrimTy]
realWorldStatePrimTy
-- yield# :: State# RealWorld -> State# RealWorld
primOpInfo YieldOp
= mkGenPrimOp SLIT("yield#") []
[realWorldStatePrimTy]
realWorldStatePrimTy
-- myThreadId# :: State# RealWorld -> (# State# RealWorld, ThreadId# #)
primOpInfo MyThreadIdOp
= mkGenPrimOp SLIT("myThreadId#") []
[realWorldStatePrimTy]
(unboxedPair [realWorldStatePrimTy, threadIdPrimTy])
\end{code}
************************************************************************
......@@ -1860,6 +1878,7 @@ primOpOutOfLine op
NewMVarOp -> True
ForkOp -> True
KillThreadOp -> True
YieldOp -> True
CCallOp _ _ may_gc@True _ -> True -- _ccall_GC_
-- the next one doesn't perform any heap checks,
-- but it is of such an esoteric nature that
......@@ -1934,6 +1953,7 @@ primOpHasSideEffects WaitWriteOp = True
primOpHasSideEffects ParOp = True
primOpHasSideEffects ForkOp = True
primOpHasSideEffects KillThreadOp = True
primOpHasSideEffects YieldOp = True
primOpHasSideEffects SeqOp = True
primOpHasSideEffects MakeForeignObjOp = True
......
/* -----------------------------------------------------------------------------
* $Id: PrimOps.h,v 1.23 1999/03/05 10:21:29 sof Exp $
* $Id: PrimOps.h,v 1.24 1999/03/16 13:20:09 simonm Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -702,9 +702,12 @@ EF_(makeStableNamezh_fast);
-------------------------------------------------------------------------- */
EF_(forkzh_fast);
EF_(yieldzh_fast);
EF_(killThreadzh_fast);
EF_(seqzh_fast);
#define myThreadIdzh(t) (t = CurrentTSO)
/* Hmm, I'll think about these later. */
/* -----------------------------------------------------------------------------
Pointer equality
......
/* -----------------------------------------------------------------------------
* $Id: TSO.h,v 1.5 1999/03/02 19:44:22 sof Exp $
* $Id: TSO.h,v 1.6 1999/03/16 13:20:10 simonm Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -81,9 +81,8 @@ typedef struct StgTSO_ {
struct StgTSO_* link;
StgMutClosure * mut_link; /* TSO's are mutable of course! */
StgTSOWhatNext whatNext;
StgTSOState state; /* necessary? */
StgClosure * blocked_on;
StgThreadID id;
/* Exception Handlers */
StgTSOTickyInfo ticky;
StgTSOProfInfo prof;
StgTSOParInfo par;
......@@ -101,6 +100,44 @@ typedef struct StgTSO_ {
extern DLL_IMPORT_RTS StgTSO *CurrentTSO;
/* -----------------------------------------------------------------------------
Invariants:
An active thread has the following properties:
tso->stack < tso->sp < tso->stack+tso->stack_size
tso->stack_size <= tso->max_stack_size
tso->splim == tso->stack + RESERVED_STACK_WORDS;
RESERVED_STACK_WORDS is large enough for any heap-check or
stack-check failure.
The size of the TSO struct plus the stack is either
(a) smaller than a block, or
(b) a multiple of BLOCK_SIZE
tso->link
== END_TSO_QUEUE , iff the thread is currently running.
== (StgTSO *) , otherwise, and it is linked onto either:
- the runnable_queue tso->blocked_on == END_TSO_QUEUE
- the blocked_queue tso->blocked_on == END_TSO_QUEUE
- a BLACKHOLE_BQ, tso->blocked_on == the BLACKHOLE_BQ
- an MVAR, tso->blocked_on == the MVAR
A zombie thread has the following properties:
tso->whatNext == ThreadComplete or ThreadKilled
tso->link == (could be on some queue somewhere)
tso->su == tso->stack + tso->stack_size
tso->sp == tso->stack + tso->stack_size - 1 (i.e. top stack word)
tso->sp[0] == return value of thread, if whatNext == ThreadComplete,
exception , if whatNext == ThreadKilled
(tso->sp is left pointing at the top word on the stack so that
the return value or exception will be retained by a GC).
---------------------------------------------------------------------------- */
/* Workaround for a bug/quirk in gcc on certain architectures.
* symptom is that (&tso->stack - &tso->header) /= sizeof(StgTSO)
......
% -----------------------------------------------------------------------------
% $Id: Exception.lhs,v 1.5 1999/01/19 09:57:12 sof Exp $
% $Id: Exception.lhs,v 1.6 1999/03/16 13:20:11 simonm Exp $
%
% (c) The GRAP/AQUA Project, Glasgow University, 1998
%
......@@ -36,6 +36,7 @@ module Exception (
-- Throwing exceptions
throw, -- :: Exception -> a
raiseInThread, -- :: ThreadId -> Exception -> a
-- Dynamic exceptions
......@@ -58,6 +59,7 @@ import Prelude hiding (catch)
import Prelude hiding (catch)
import PrelGHC (catch#)
import PrelException hiding (catch)
import PrelConc ( raiseInThread )
#endif
import Dynamic
......
......@@ -9,27 +9,31 @@ Basic concurrency stuff
\begin{code}
{-# OPTIONS -fno-implicit-prelude #-}
module PrelConc (
-- Thread Ids
ThreadId,
-- Forking and suchlike
forkIO,
killThread,
par, fork, seq,
module PrelConc
-- Thread Ids
( ThreadId -- abstract
-- Forking and suchlike
, forkIO -- :: IO () -> IO ThreadId
, myThreadId -- :: IO ThreadId
, killThread -- :: ThreadId -> IO ()
, raiseInThread -- :: ThreadId -> Exception -> IO ()
, par -- :: a -> b -> b
, fork -- :: a -> b -> b
, seq -- :: a -> b -> b
{-threadDelay, threadWaitRead, threadWaitWrite,-}
-- MVars
MVar
, newMVar
, newEmptyMVar
, takeMVar
, putMVar
, readMVar
, swapMVar
-- use with care (see comment.)
, isEmptyMVar
-- MVars
, MVar -- abstract
, newMVar -- :: a -> IO (MVar a)
, newEmptyMVar -- :: IO (MVar a)
, takeMVar -- :: MVar a -> IO a
, putMVar -- :: MVar a -> a -> IO ()
, readMVar -- :: MVar a -> IO a
, swapMVar -- :: MVar a -> a -> IO a
, isEmptyMVar -- :: MVar a -> IO Bool
) where
import PrelBase
......@@ -37,6 +41,7 @@ import PrelErr ( parError, seqError )
import PrelST ( liftST )
import PrelIOBase ( IO(..), MVar(..), unsafePerformIO )
import PrelBase ( Int(..) )
import PrelException ( Exception(..), AsyncException(..) )
infixr 0 `par`, `fork`
\end{code}
......@@ -49,8 +54,8 @@ infixr 0 `par`, `fork`
\begin{code}
data ThreadId = ThreadId ThreadId#
-- ToDo: data ThreadId = ThreadId (WeakPair ThreadId# ())
-- But since ThreadId# is unlifted, the WeakPair type must use open
-- ToDo: data ThreadId = ThreadId (Weak ThreadId#)
-- But since ThreadId# is unlifted, the Weak type must use open
-- type variables.
forkIO :: IO () -> IO ThreadId
......@@ -59,7 +64,15 @@ forkIO action = IO $ \ s ->
killThread :: ThreadId -> IO ()
killThread (ThreadId id) = IO $ \ s ->
case (killThread# id s) of s1 -> (# s1, () #)
case (killThread# id (AsyncException ThreadKilled) s) of s1 -> (# s1, () #)
raiseInThread :: ThreadId -> Exception -> IO ()
raiseInThread (ThreadId id) ex = IO $ \ s ->
case (killThread# id ex s) of s1 -> (# s1, () #)
myThreadId :: IO ThreadId
myThreadId = IO $ \s ->
case (myThreadId# s) of (# s1, id #) -> (# s1, ThreadId id #)
-- "seq" is defined a bit wierdly (see below)
--
......
......@@ -25,7 +25,9 @@ __export PrelGHC
-- Concurrency primitives
ThreadIdzh
myThreadIdzh
forkzh
yieldzh
killThreadzh
delayzh
waitReadzh
......
/* -----------------------------------------------------------------------------
* $Id: GC.c,v 1.52 1999/03/15 16:53:11 simonm Exp $
* $Id: GC.c,v 1.53 1999/03/16 13:20:13 simonm Exp $
*
* (c) The GHC Team 1998-1999
*
......@@ -1803,6 +1803,9 @@ scavenge(step *step)
evac_gen = 0;
/* chase the link field for any TSOs on the same queue */
(StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
if (tso->blocked_on) {
tso->blocked_on = evacuate(tso->blocked_on);
}
/* scavenge this thread's stack */
scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
evac_gen = saved_evac_gen;
......@@ -2143,19 +2146,14 @@ scavenge_mutable_list(generation *gen)
}
case TSO:
/* follow ptrs and remove this from the mutable list */
{
StgTSO *tso = (StgTSO *)p;
/* Don't bother scavenging if this thread is dead
*/
if (!(tso->whatNext == ThreadComplete ||
tso->whatNext == ThreadKilled)) {
/* Don't need to chase the link field for any TSOs on the
* same queue. Just scavenge this thread's stack
*/
scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
(StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
if (tso->blocked_on) {
tso->blocked_on = evacuate(tso->blocked_on);
}
scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
/* Don't take this TSO off the mutable list - it might still
* point to some younger objects (because we set evac_gen to 0
......@@ -2527,6 +2525,9 @@ scavenge_large(step *step)
tso = (StgTSO *)p;
/* chase the link field for any TSOs on the same queue */
(StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
if (tso->blocked_on) {
tso->blocked_on = evacuate(tso->blocked_on);
}
/* scavenge this thread's stack */
scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
continue;
......
......@@ -35,6 +35,7 @@ EXTFUN(stg_gen_chk_ret);
EXTFUN(stg_gen_chk);
EXTFUN(stg_gen_hp);
EXTFUN(stg_gen_yield);
EXTFUN(stg_yield_noregs);
EXTFUN(stg_yield_to_Hugs);
EXTFUN(stg_gen_block);
EXTFUN(stg_block_1);
/* -----------------------------------------------------------------------------
* $Id: HeapStackCheck.hc,v 1.3 1999/02/05 16:02:43 simonm Exp $
* $Id: HeapStackCheck.hc,v 1.4 1999/03/16 13:20:15 simonm Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -806,6 +806,13 @@ FN_(stg_gen_yield)
FE_
}
FN_(stg_yield_noregs)
{
FB_
YIELD_GENERIC
FE_
}
FN_(stg_yield_to_Hugs)
{
FB_
......
/* -----------------------------------------------------------------------------
* $Id: PrimOps.hc,v 1.21 1999/03/05 10:21:27 sof Exp $
* $Id: PrimOps.hc,v 1.22 1999/03/16 13:20:15 simonm Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -19,6 +19,8 @@
#include "Storage.h"
#include "BlockAlloc.h" /* tmp */
#include "StablePriv.h"
#include "HeapStackCheck.h"
#include "StgRun.h"
/* ** temporary **
......@@ -397,7 +399,7 @@ FN_(int2Integerzh_fast)
TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
p = stgCast(StgArrWords*,Hp)-1;
p = (StgArrWords *)Hp - 1;
SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, 1);
/* mpz_set_si is inlined here, makes things simpler */
......@@ -434,7 +436,7 @@ FN_(word2Integerzh_fast)
TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
p = stgCast(StgArrWords*,Hp)-1;
p = (StgArrWords *)Hp - 1;
SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, 1);
if (val != 0) {
......@@ -507,7 +509,7 @@ FN_(int64ToIntegerzh_fast)
TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
p = stgCast(StgArrWords*,(Hp-words_needed+1))-1;
p = (StgArrWords *)(Hp-words_needed+1) - 1;
SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, words_needed);
if ( val < 0LL ) {
......@@ -558,7 +560,7 @@ FN_(word64ToIntegerzh_fast)
TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
p = stgCast(StgArrWords*,(Hp-words_needed+1))-1;
p = (StgArrWords *)(Hp-words_needed+1) - 1;
SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, words_needed);
hi = (W_)((LW_)val / 0x100000000ULL);
......@@ -686,7 +688,7 @@ FN_(decodeFloatzh_fast)
/* Be prepared to tell Lennart-coded __decodeFloat */
/* where mantissa._mp_d can be put (it does not care about the rest) */
p = stgCast(StgArrWords*,Hp)-1;
p = (StgArrWords *)Hp - 1;
SET_ARR_HDR(p,&ARR_WORDS_info,CCCS,1)
mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
......@@ -719,7 +721,7 @@ FN_(decodeDoublezh_fast)
/* Be prepared to tell Lennart-coded __decodeDouble */
/* where mantissa.d can be put (it does not care about the rest) */
p = stgCast(StgArrWords*,Hp-ARR_SIZE+1);
p = (StgArrWords *)(Hp-ARR_SIZE+1);
SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, DOUBLE_MANTISSA_SIZE);
mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
......@@ -741,7 +743,7 @@ FN_(forkzh_fast)
FB_
/* args: R1 = closure to spark */
if (closure_SHOULD_SPARK(stgCast(StgClosure*,R1.p))) {
if (closure_SHOULD_SPARK(R1.cl)) {
MAYBE_GC(R1_PTR, forkzh_fast);
......@@ -757,21 +759,44 @@ FN_(forkzh_fast)
FE_
}
FN_(yieldzh_fast)
{
FB_
JMP_(stg_yield_noregs)
FE_
}
FN_(killThreadzh_fast)
{
FB_
/* args: R1.p = TSO to kill */
/* args: R1.p = TSO to kill, R2.p = Exception */
/* The thread is dead, but the TSO sticks around for a while. That's why
* we don't have to explicitly remove it from any queues it might be on.
*/
STGCALL1(deleteThread, (StgTSO *)R1.p);
/* We might have killed ourselves. In which case, better return to the
* scheduler...
/* We might have killed ourselves. In which case, better be *very*
* careful. If the exception killed us, then return to the scheduler.
* If the exception went to a catch frame, we'll just continue from
* the handler.
*/
if ((StgTSO *)R1.p == CurrentTSO) {
JMP_(stg_stop_thread_entry); /* leave semi-gracefully */
if (R1.t == CurrentTSO) {
SaveThreadState(); /* inline! */
STGCALL2(raiseAsync, R1.t, R2.cl);
if (CurrentTSO->whatNext == ThreadKilled) {
R1.w = ThreadYielding;
JMP_(StgReturn);
}
LoadThreadState();
if (CurrentTSO->whatNext == ThreadEnterGHC) {
R1.w = Sp[0];
Sp++;
JMP_(GET_ENTRY(R1.cl));
} else {
barf("killThreadzh_fast");
}
} else {
STGCALL2(raiseAsync, R1.t, R2.cl);
}
JMP_(ENTRY_CODE(Sp[0]));
......
/* -----------------------------------------------------------------------------
* $Id: Schedule.c,v 1.15 1999/03/08 16:41:42 sof Exp $
* $Id: Schedule.c,v 1.16 1999/03/16 13:20:16 simonm Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -70,6 +70,11 @@ StgTSO *MainTSO;
#define MIN_STACK_WORDS (RESERVED_STACK_WORDS + sizeofW(StgStopFrame) + 2)
/* -----------------------------------------------------------------------------
* Static functions
* -------------------------------------------------------------------------- */
static void unblockThread(StgTSO *tso);
/* -----------------------------------------------------------------------------
Create a new thread.
......@@ -104,8 +109,8 @@ initThread(StgTSO *tso, nat stack_size)
{
SET_INFO(tso,&TSO_info);
tso->whatNext = ThreadEnterGHC;
tso->state = tso_state_runnable;
tso->id = next_thread_id++;
tso->blocked_on = NULL;
tso->splim = (P_)&(tso->stack) + RESERVED_STACK_WORDS;
tso->stack_size = stack_size;
......@@ -139,166 +144,12 @@ initThread(StgTSO *tso, nat stack_size)
}
/* -----------------------------------------------------------------------------
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 %ld.", 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((void*)*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)));
TICK_ALLOC_THK(words+1,0);
/* 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));
TICK_ALLOC_THK(2,0);
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 */);