* Copyright (c) 1994-1998.
*
* $RCSfile: Evaluator.c,v $
- * $Revision: 1.39 $
- * $Date: 2000/03/13 13:00:00 $
+ * $Revision: 1.44 $
+ * $Date: 2000/03/20 09:42:49 $
* ---------------------------------------------------------------------------*/
#include "Rts.h"
#include "ForeignCall.h"
#include "PrimOps.h" /* for __{encode,decode}{Float,Double} */
#include "Prelude.h"
+#include "ITimer.h"
#include "Evaluator.h"
#include "sainteger.h"
#endif
+/* Allegedly useful macro, taken from ClosureMacros.h */
+#define payloadWord( c, i ) (*stgCast(StgWord*, ((c)->payload+(i))))
+#define payloadPtr( c, i ) (*stgCast(StgPtr*, ((c)->payload+(i))))
/* An incredibly useful abbreviation.
* Interestingly, there are some uses of END_TSO_QUEUE_closure that
}
+
void cp_enter ( StgBCO* b )
{
int is_ret_cont;
}
+typedef struct {
+ StgTSOBlockReason reason;
+ unsigned int delay;
+} HugsBlock;
+
+
/* --------------------------------------------------------------------------
* Entering-objects and bytecode interpreter part of evaluator
* ------------------------------------------------------------------------*/
/* Forward decls ... */
static void* enterBCO_primop1 ( int );
static void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */,
- StgBCO**, Capability* );
+ StgBCO**, Capability*, HugsBlock * );
static inline void PopUpdateFrame ( StgClosure* obj );
static inline void PopCatchFrame ( void );
static inline void PopSeqFrame ( void );
register StgClosure* obj; /* object currently under evaluation */
char eCount; /* enter counter, for context switching */
+
+ HugsBlock hugsBlock = { NotBlocked, 0 };
+
+
#ifdef DEBUG
StgPtr tSp; StgUpdateFrame* tSu; StgPtr tSpLim;
#endif
#endif
) {
if (context_switch) {
- xPushCPtr(obj); /* code to restart with */
- RETURN(ThreadYielding);
+ switch(hugsBlock.reason) {
+ case NotBlocked: {
+ xPushCPtr(obj); /* code to restart with */
+ RETURN(ThreadYielding);
+ }
+ case BlockedOnDelay: /* fall through */
+ case BlockedOnRead: /* fall through */
+ case BlockedOnWrite: {
+ ASSERT(cap->rCurrentTSO->why_blocked == NotBlocked);
+ cap->rCurrentTSO->why_blocked = BlockedOnDelay;
+ ACQUIRE_LOCK(&sched_mutex);
+
+#if defined(HAVE_SETITIMER)
+ cap->rCurrentTSO->block_info.delay
+ = hugsBlock.delay + ticks_since_select;
+#else
+ cap->rCurrentTSO->block_info.target
+ = hugsBlock.delay + getourtimeofday();
+#endif
+ APPEND_TO_BLOCKED_QUEUE(cap->rCurrentTSO);
+
+ RELEASE_LOCK(&sched_mutex);
+
+ xPushCPtr(obj); /* code to restart with */
+ RETURN(ThreadBlocked);
+ }
+ default:
+ barf("Unknown context switch reasoning");
+ }
}
}
nat np = info->layout.payload.nptrs;
nat i;
for(i=0; i < p; ++i) {
- payloadCPtr(o,i) = xPopCPtr();
+ o->payload[i] = xPopCPtr();
}
for(i=0; i < np; ++i) {
payloadWord(o,p+i) = 0xdeadbeef;
nat np = info->layout.payload.nptrs;
nat i;
for(i=0; i < p; ++i) {
- payloadCPtr(o,i) = xPopCPtr();
+ o->payload[i] = xPopCPtr();
}
for(i=0; i < np; ++i) {
payloadWord(o,p+i) = 0xdeadbeef;
|| itbl->type == CONSTR_0_2
);
while (--i>=0) {
- xPushCPtr(payloadCPtr(o,i));
+ xPushCPtr(o->payload[i]);
}
Continue;
}
{
StgClosure* o;
SSS; o = (StgClosure*)grabHpNonUpd(Izh_sizeW); LLL;
- SET_HDR(o,&Izh_con_info,??);
+ SET_HDR(o,Izh_con_info,??);
payloadWord(o,0) = xPopTaggedInt();
IF_DEBUG(evaluator,
fprintf(stderr,"\tBuilt ");
{
StgClosure* o;
SSS; o = (StgClosure*)grabHpNonUpd(Wzh_sizeW); LLL;
- SET_HDR(o,&Wzh_con_info,??);
+ SET_HDR(o,Wzh_con_info,??);
payloadWord(o,0) = xPopTaggedWord();
IF_DEBUG(evaluator,
fprintf(stderr,"\tBuilt ");
{
StgClosure* o;
SSS; o = (StgClosure*)grabHpNonUpd(Azh_sizeW); LLL;
- SET_HDR(o,&Azh_con_info,??);
+ SET_HDR(o,Azh_con_info,??);
payloadPtr(o,0) = xPopTaggedAddr();
IF_DEBUG(evaluator,
fprintf(stderr,"\tBuilt ");
{
StgClosure* o;
SSS; o = (StgClosure*)grabHpNonUpd(Czh_sizeW); LLL;
- SET_HDR(o,&Czh_con_info,??);
+ SET_HDR(o,Czh_con_info,??);
payloadWord(o,0) = xPopTaggedChar();
xPushPtr(stgCast(StgPtr,o));
IF_DEBUG(evaluator,
{
StgClosure* o;
SSS; o = (StgClosure*)grabHpNonUpd(Fzh_sizeW); LLL;
- SET_HDR(o,&Fzh_con_info,??);
+ SET_HDR(o,Fzh_con_info,??);
ASSIGN_FLT(&payloadWord(o,0),xPopTaggedFloat());
IF_DEBUG(evaluator,
fprintf(stderr,"\tBuilt ");
{
StgClosure* o;
SSS; o = (StgClosure*)grabHpNonUpd(Dzh_sizeW); LLL;
- SET_HDR(o,&Dzh_con_info,??);
+ SET_HDR(o,Dzh_con_info,??);
ASSIGN_DBL(&payloadWord(o,0),xPopTaggedDouble());
IF_DEBUG(evaluator,
fprintf(stderr,"\tBuilt ");
{
StgClosure* o;
SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL;
- SET_HDR(o,&StablePtr_con_info,??);
+ SET_HDR(o,StablePtr_con_info,??);
payloadWord(o,0) = xPopTaggedStable();
IF_DEBUG(evaluator,
fprintf(stderr,"\tBuilt ");
pc_saved = PC;
bco_tmp = bco;
SSS;
- p = enterBCO_primop2 ( i, &trc, &bco_tmp, cap );
+ p = enterBCO_primop2 ( i, &trc, &bco_tmp, cap,
+ &hugsBlock );
LLL;
bco = bco_tmp;
bciPtr = &(bcoInstr(bco,pc_saved));
/* we want to enter p */
obj = p; goto enterLoop;
} else {
- /* trc is the the StgThreadReturnCode for this thread */
- RETURN((StgThreadReturnCode)trc);
+ /* trc is the the StgThreadReturnCode for
+ * this thread */
+ RETURN((StgThreadReturnCode)trc);
};
}
Continue;
case SE_CAF_BLACKHOLE:
{
/* Let the scheduler figure out what to do :-) */
- cap->rCurrentTSO->whatNext = ThreadEnterGHC;
+ cap->rCurrentTSO->what_next = ThreadEnterGHC;
xPushCPtr(obj);
RETURN(ThreadYielding);
}
case RET_VEC_SMALL:
case RET_BIG:
case RET_VEC_BIG:
- cap->rCurrentTSO->whatNext = ThreadEnterGHC;
+ cap->rCurrentTSO->what_next = ThreadEnterGHC;
xPushCPtr(obj);
RETURN(ThreadYielding);
default:
//fprintf(stderr, "entering unknown closure -- yielding to sched\n");
//printObj(obj);
//LLL;
- cap->rCurrentTSO->whatNext = ThreadEnterGHC;
+ cap->rCurrentTSO->what_next = ThreadEnterGHC;
xPushCPtr(obj); /* code to restart with */
RETURN(ThreadYielding);
}
return the address of it and leave *return2 unchanged.
To return a StgThreadReturnCode to the scheduler,
set *return2 to it and return a non-NULL value.
+ To cause a context switch, set context_switch (its a global),
+ and optionally set hugsBlock to your rational.
*/
static void* enterBCO_primop2 ( int primop2code,
int* /*StgThreadReturnCode* */ return2,
StgBCO** bco,
- Capability* cap )
+ Capability* cap,
+ HugsBlock *hugsBlock )
{
if (combined) {
/* A small concession: we need to allow ccalls,
PushTaggedBool(x==y);
break;
}
- case i_getThreadId:
- {
- StgWord tid = cap->rCurrentTSO->id;
- PushTaggedWord(tid);
- break;
- }
- case i_cmpThreadIds:
- {
- StgWord tid1 = PopTaggedWord();
- StgWord tid2 = PopTaggedWord();
- if (tid1 < tid2) PushTaggedInt(-1);
- else if (tid1 > tid2) PushTaggedInt(1);
- else PushTaggedInt(0);
- break;
- }
+#ifdef PROVIDE_CONCURRENT
case i_forkIO:
{
StgClosure* closure;
tid = tso->id;
scheduleThread(tso);
context_switch = 1;
+ /* Later: Change to use tso as the ThreadId */
PushTaggedWord(tid);
break;
}
-#ifdef PROVIDE_CONCURRENT
case i_killThread:
{
- StgTSO* tso = stgCast(StgTSO*,PopPtr());
+ StgWord n = PopTaggedWord();
+ StgTSO* tso = 0;
+ StgTSO *t;
+
+ // Map from ThreadId to Thread Structure */
+ for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
+ if (n == t->id)
+ tso = t;
+ }
+ if (tso == 0) {
+ // Already dead
+ break;
+ }
+
+ while (tso->what_next == ThreadRelocated) {
+ tso = tso->link;
+ }
+
deleteThread(tso);
if (tso == cap->rCurrentTSO) { /* suicide */
*return2 = ThreadFinished;
}
break;
}
-
+ case i_raiseInThread:
+ ASSERT(0); /* not (yet) supported */
case i_delay:
+ {
+ StgInt n = PopTaggedInt();
+ context_switch = 1;
+ hugsBlock->reason = BlockedOnDelay;
+ hugsBlock->delay = n;
+ break;
+ }
case i_waitRead:
+ {
+ StgInt n = PopTaggedInt();
+ context_switch = 1;
+ hugsBlock->reason = BlockedOnRead;
+ hugsBlock->delay = n;
+ break;
+ }
case i_waitWrite:
- /* As PrimOps.h says: Hmm, I'll think about these later. */
- ASSERT(0);
+ {
+ StgInt n = PopTaggedInt();
+ context_switch = 1;
+ hugsBlock->reason = BlockedOnWrite;
+ hugsBlock->delay = n;
+ break;
+ }
+ case i_yield:
+ {
+ /* The definition of yield include an enter right after
+ * the primYield, at which time context_switch is tested.
+ */
+ context_switch = 1;
+ break;
+ }
+ case i_getThreadId:
+ {
+ StgWord tid = cap->rCurrentTSO->id;
+ PushTaggedWord(tid);
break;
+ }
+ case i_cmpThreadIds:
+ {
+ StgWord tid1 = PopTaggedWord();
+ StgWord tid2 = PopTaggedWord();
+ if (tid1 < tid2) PushTaggedInt(-1);
+ else if (tid1 > tid2) PushTaggedInt(1);
+ else PushTaggedInt(0);
+ break;
+ }
#endif /* PROVIDE_CONCURRENT */
case i_ccall_ccall_Id:
projects / ghc-hetmet.git / blobdiff