X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FEvaluator.c;h=566666f16cd4b694da4c19dd712e0bab033c87d8;hb=efcd3f2b7aabe23e30ab482db1ed2eee5075e095;hp=7aef8ef31339ffcfb76171236b09f0e86730ae77;hpb=53f56234adb3e0595483e76a0e6625ecc13ef43a;p=ghc-hetmet.git diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c index 7aef8ef..566666f 100644 --- a/ghc/rts/Evaluator.c +++ b/ghc/rts/Evaluator.c @@ -5,8 +5,8 @@ * Copyright (c) 1994-1998. * * $RCSfile: Evaluator.c,v $ - * $Revision: 1.38 $ - * $Date: 2000/03/13 10:39:11 $ + * $Revision: 1.52 $ + * $Date: 2000/05/10 09:00:20 $ * ---------------------------------------------------------------------------*/ #include "Rts.h" @@ -23,6 +23,8 @@ #include "Assembler.h" /* for CFun stuff */ #include "ForeignCall.h" #include "PrimOps.h" /* for __{encode,decode}{Float,Double} */ +#include "Prelude.h" +#include "Itimer.h" #include "Evaluator.h" #include "sainteger.h" @@ -41,6 +43,9 @@ #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 @@ -66,166 +71,9 @@ /* Make it possible for the evaluator to get hold of bytecode for a given function by name. Useful but a hack. Sigh. */ -extern void* getHugs_AsmObject_for ( char* s ); -extern int /*Bool*/ combined; +extern void* /* StgClosure* */ getHugs_BCO_cptr_for ( char* s ); +extern int /* Bool */ combined; -/* -------------------------------------------------------------------------- - * Crude profiling stuff (mainly to assess effect of optimiser) - * ------------------------------------------------------------------------*/ - -#ifdef CRUDE_PROFILING - -#define M_CPTAB 10000 -#define CP_NIL (-1) - -int cpInUse = -1; -int cpCurr; - -typedef - struct { int /*StgVar*/ who; - int /*StgVar*/ twho; - int enters; - int bytes; - int insns; - } - CPRecord; - -CPRecord cpTab[M_CPTAB]; - -void cp_init ( void ) -{ - int i; - cpCurr = CP_NIL; - cpInUse = 0; - for (i = 0; i < M_CPTAB; i++) - cpTab[i].who = CP_NIL; -} - - -void cp_enter ( StgBCO* b ) -{ - int is_ret_cont; - int h; - int /*StgVar*/ v = b->stgexpr; - if ((void*)v == NULL) return; - - is_ret_cont = 0; - if (v > 500000000) { - is_ret_cont = 1; - v -= 1000000000; - } - - if (v < 0) - h = (-v) % M_CPTAB; else - h = v % M_CPTAB; - - assert (h >= 0 && h < M_CPTAB); - while (cpTab[h].who != v && cpTab[h].who != CP_NIL) { - h++; if (h == M_CPTAB) h = 0; - }; - cpCurr = h; - if (cpTab[cpCurr].who == CP_NIL) { - cpTab[cpCurr].who = v; - if (!is_ret_cont) cpTab[cpCurr].enters = 1; - cpTab[cpCurr].bytes = cpTab[cpCurr].insns = 0; - cpInUse++; - if (cpInUse * 2 > M_CPTAB) { - fprintf(stderr, "\nCRUDE_PROFILING hash table is too full\n" ); - assert(0); - } - } else { - if (!is_ret_cont) cpTab[cpCurr].enters++; - } - - -} - -void cp_bill_words ( int nw ) -{ - if (cpCurr == CP_NIL) return; - cpTab[cpCurr].bytes += sizeof(StgWord)*nw; -} - - -void cp_bill_insns ( int ni ) -{ - if (cpCurr == CP_NIL) return; - cpTab[cpCurr].insns += ni; -} - - -static double percent ( double a, double b ) -{ - return (100.0 * a) / b; -} - - -void cp_show ( void ) -{ - int i, j, max, maxN, totE, totB, totI, cumE, cumB, cumI; - char nm[200]; - - if (cpInUse == -1) return; - - fflush(stdout);fflush(stderr); - printf ( "\n\n" ); - - totE = totB = totI = 0; - for (i = 0; i < M_CPTAB; i++) { - cpTab[i].twho = cpTab[i].who; - if (cpTab[i].who != CP_NIL) { - totE += cpTab[i].enters; - totB += cpTab[i].bytes; - totI += cpTab[i].insns; - } - } - - printf ( "Totals: " - "%6d (%7.3f M) enters, " - "%6d (%7.3f M) insns, " - "%6d (%7.3f M) bytes\n\n", - totE, totE/1000000.0, totI, totI/1000000.0, totB, totB/1000000.0 ); - - cumE = cumB = cumI = 0; - for (j = 0; j < 32; j++) { - - maxN = max = -1; - for (i = 0; i < M_CPTAB; i++) - if (cpTab[i].who != CP_NIL && - cpTab[i].enters > maxN) { - maxN = cpTab[i].enters; - max = i; - } - if (max == -1) break; - - cumE += cpTab[max].enters; - cumB += cpTab[max].bytes; - cumI += cpTab[max].insns; - - strcpy(nm, maybeName(cpTab[max].who)); - if (strcmp(nm, "(unknown)")==0) - sprintf ( nm, "id%d", -cpTab[max].who); - - printf ( "%20s %7d es (%4.1f%%, %4.1f%% c) " - "%7d bs (%4.1f%%, %4.1f%% c) " - "%7d is (%4.1f%%, %4.1f%% c)\n", - nm, - cpTab[max].enters, percent(cpTab[max].enters,totE), percent(cumE,totE), - cpTab[max].bytes, percent(cpTab[max].bytes,totB), percent(cumB,totB), - cpTab[max].insns, percent(cpTab[max].insns,totI), percent(cumI,totI) - ); - - cpTab[max].twho = cpTab[max].who; - cpTab[max].who = CP_NIL; - } - - for (i = 0; i < M_CPTAB; i++) - cpTab[i].who = cpTab[i].twho; - - printf ( "\n" ); -} - -#endif /* -------------------------------------------------------------------------- @@ -253,6 +101,12 @@ void setRtsFlags( int x ) } +typedef struct { + StgTSOBlockReason reason; + unsigned int delay; +} HugsBlock; + + /* -------------------------------------------------------------------------- * Entering-objects and bytecode interpreter part of evaluator * ------------------------------------------------------------------------*/ @@ -282,7 +136,7 @@ void setRtsFlags( int x ) /* 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 ); @@ -451,6 +305,10 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) 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 @@ -475,6 +333,8 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) enterLoop: + numEnters++; + #ifdef DEBUG assert(gSp == tSp); assert(gSu == tSu); @@ -502,8 +362,35 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) #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) || defined(mingw32_TARGET_OS) + 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"); + } } } @@ -545,11 +432,6 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) RETURN(HeapOverflow); } -# if CRUDE_PROFILING - cp_enter ( bco ); -# endif - - bciPtr = &(bcoInstr(bco,0)); LoopTopLabel @@ -568,10 +450,6 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) LLL; ); -# if CRUDE_PROFILING - SSS; cp_bill_insns(1); LLL; -# endif - Dispatch Case(i_INTERNAL_ERROR): @@ -645,8 +523,12 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) xPopUpdateFrame(obj); break; case STOP_FRAME: + barf("STOP frame during pap update"); +#if 0 + cap->rCurrentTSO->what_next = ThreadComplete; SSS; PopStopFrame(obj); LLL; RETURN(ThreadFinished); +#endif case SEQ_FRAME: SSS; PopSeqFrame(); LLL; ASSERT(xSp != (P_)xSu); @@ -771,7 +653,7 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) 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; @@ -793,7 +675,7 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) 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; @@ -866,7 +748,7 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) || itbl->type == CONSTR_0_2 ); while (--i>=0) { - xPushCPtr(payloadCPtr(o,i)); + xPushCPtr(o->payload[i]); } Continue; } @@ -920,7 +802,7 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) { 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 "); @@ -977,7 +859,7 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) { 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 "); @@ -1016,7 +898,7 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) { 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 "); @@ -1049,7 +931,7 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) { 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, @@ -1082,7 +964,7 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) { 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 "); @@ -1121,7 +1003,7 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) { 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 "); @@ -1147,8 +1029,8 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) { StgClosure* o; SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL; - SET_HDR(o,&StablePtr_con_info,??); - payloadWord(o,0) = xPopTaggedStable(); + SET_HDR(o,StablePtr_con_info,??); + payloadWord(o,0) = (W_)xPopTaggedStable(); IF_DEBUG(evaluator, fprintf(stderr,"\tBuilt "); SSS; @@ -1184,7 +1066,8 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) 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)); @@ -1193,8 +1076,9 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) /* 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; @@ -1311,22 +1195,19 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) xPushCPtr(obj); /* code to restart with */ RETURN(StackOverflow); } - /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME - and insert an indirection immediately */ SSS; bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW()); LLL; SET_INFO(bh,&CAF_BLACKHOLE_info); bh->blocking_queue = EndTSOQueue; IF_DEBUG(gccafs, - fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p in evaluator\n",bh,caf)); + fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p" + " in evaluator\n",bh,caf)); SET_INFO(caf,&CAF_ENTERED_info); caf->value = (StgClosure*)bh; - if (caf->mut_link == NULL) { - SSS; recordOldToNewPtrs((StgMutClosure*)caf); LLL; - } + + SSS; newCAF_made_by_Hugs(caf); LLL; + xPushUpdateFrame(bh,0); xSp -= sizeofW(StgUpdateFrame); - caf->link = enteredCAFs; - enteredCAFs = caf; obj = caf->body; goto enterLoop; } @@ -1342,7 +1223,7 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) 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); } @@ -1434,7 +1315,9 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) + cap->rCurrentTSO->stack_size,xSu); LLL; ); + cap->rCurrentTSO->what_next = ThreadComplete; SSS; PopStopFrame(obj); LLL; + xPushPtr((P_)obj); RETURN(ThreadFinished); } case RET_BCO: @@ -1453,7 +1336,7 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) 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: @@ -1474,7 +1357,7 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) //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); } @@ -1578,7 +1461,7 @@ static inline void PushTaggedRealWorld( void ) inline void PushTaggedDouble ( StgDouble x ) { gSp -= sizeofW(StgDouble); ASSIGN_DBL(gSp,x); PushTag(DOUBLE_TAG); } inline void PushTaggedStablePtr ( StgStablePtr x ) - { gSp -= sizeofW(StgStablePtr); *gSp = x; PushTag(STABLE_TAG); } + { gSp -= sizeofW(StgStablePtr); *gSp = (W_)x; PushTag(STABLE_TAG); } static inline void PushTaggedBool ( int x ) { PushTaggedInt(x); } @@ -1605,7 +1488,7 @@ static inline void PopTaggedRealWorld ( void ) { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(gSp); gSp += sizeofW(StgDouble); return r;} inline StgStablePtr PopTaggedStablePtr ( void ) - { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, gSp); + { StgStablePtr r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, gSp); gSp += sizeofW(StgStablePtr); return r;} @@ -1641,18 +1524,12 @@ static inline StgStablePtr taggedStackStable ( StgStackOffset i ) static inline StgPtr grabHpUpd( nat size ) { ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) ); -#ifdef CRUDE_PROFILING - cp_bill_words ( size ); -#endif return allocate(size); } static inline StgPtr grabHpNonUpd( nat size ) { ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) ); -#ifdef CRUDE_PROFILING - cp_bill_words ( size ); -#endif return allocate(size); } @@ -1743,7 +1620,7 @@ static inline StgClosure* raiseAnError ( StgClosure* exception ) * thunks which are currently under evaluation. */ HaskellObj primRaiseClosure - = asmClosureOfObject(getHugs_AsmObject_for("primRaise")); + = getHugs_BCO_cptr_for("primRaise"); HaskellObj reraiseClosure = rts_apply ( primRaiseClosure, exception ); @@ -1784,9 +1661,9 @@ static StgClosure* makeErrorCall ( const char* msg ) (thinks: probably not so, but anyway ...) */ HaskellObj error - = asmClosureOfObject(getHugs_AsmObject_for("error")); + = getHugs_BCO_cptr_for("error"); HaskellObj unpack - = asmClosureOfObject(getHugs_AsmObject_for("hugsprimUnpackString")); + = getHugs_BCO_cptr_for("hugsprimUnpackString"); HaskellObj thunk = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) ); thunk @@ -2216,6 +2093,7 @@ void SloppifyIntegerEnd ( StgPtr arr0 ) } +__attribute__ ((unused)) static void myStackCheck ( Capability* cap ) { /* fprintf(stderr, "myStackCheck\n"); */ @@ -2405,8 +2283,8 @@ static void* enterBCO_primop1 ( int primop1code ) case i_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */ case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */ - case i_intToStable: OP_I_s(x); break; - case i_stableToInt: OP_s_I(x); break; + case i_intToStable: OP_I_s((StgStablePtr)x); break; + case i_stableToInt: OP_s_I((W_)x); break; case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break; case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break; @@ -2643,11 +2521,14 @@ static void* enterBCO_primop1 ( int primop1code ) 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, @@ -2844,7 +2725,7 @@ static void* enterBCO_primop2 ( int primop2code, #endif #ifdef PROVIDE_FOREIGN /* ForeignObj# operations */ - case i_makeForeignObj: + case i_mkForeignObj: { StgForeignObj *result = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj))); @@ -3014,21 +2895,7 @@ static void* enterBCO_primop2 ( int primop2code, 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; @@ -3039,28 +2906,87 @@ static void* enterBCO_primop2 ( int primop2code, 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; - return (void*)(1+(NULL)); + return (void*)(1+(char*)(NULL)); } 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: @@ -3428,5 +3354,4 @@ void B__decodeFloat (B* man, I_* exp, StgFloat flt) } #endif /* FLOATS_AS_DOUBLES */ - #endif /* INTERPRETER */