X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FEvaluator.c;h=6001b8597241e9088d6574c549d5aec64c18ff7b;hb=7c1668b46ada13fbb5a8de2276b2878ed1c6e210;hp=e8cc683ed3e999ca02e7e4d269c0fb393e212140;hpb=081601b1b535a1b520b7ad2a6de02ba6d9145172;p=ghc-hetmet.git diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c index e8cc683..6001b85 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.24 $ - * $Date: 1999/11/01 18:19:41 $ + * $Revision: 1.33 $ + * $Date: 2000/02/15 13:16:20 $ * ---------------------------------------------------------------------------*/ #include "Rts.h" @@ -70,7 +70,7 @@ for a given function by name. Useful but a hack. Sigh. */ extern void* getHugs_AsmObject_for ( char* s ); - +extern int /*Bool*/ combined; /* -------------------------------------------------------------------------- * Crude profiling stuff (mainly to assess effect of optimiser) @@ -255,35 +255,6 @@ void setRtsFlags( int x ) } } -/* -------------------------------------------------------------------------- - * RTS Hooks - * - * ToDo: figure out why these are being used and crush them! - * ------------------------------------------------------------------------*/ -#if 0 -void OnExitHook (void) -{ -} -void StackOverflowHook (unsigned long stack_size) -{ - fprintf(stderr,"Stack Overflow\n"); - exit(1); -} -void OutOfHeapHook (unsigned long request_size, unsigned long heap_size) -{ - fprintf(stderr,"Out Of Heap\n"); - exit(1); -} -void MallocFailHook (unsigned long request_size /* in bytes */, char *msg) -{ - fprintf(stderr,"Malloc Fail\n"); - exit(1); -} -void defaultsHook (void) -{ - /* do nothing */ -} -#endif /* -------------------------------------------------------------------------- * Entering-objects and bytecode interpreter part of evaluator @@ -313,16 +284,17 @@ void defaultsHook (void) /* Forward decls ... */ static void* enterBCO_primop1 ( int ); -static void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */, StgBCO** ); +static void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */, + StgBCO**, Capability* ); static inline void PopUpdateFrame ( StgClosure* obj ); static inline void PopCatchFrame ( void ); static inline void PopSeqFrame ( void ); static inline void PopStopFrame( StgClosure* obj ); static inline void PushTaggedRealWorld( void ); -static inline void PushTaggedInteger ( mpz_ptr ); +/* static inline void PushTaggedInteger ( mpz_ptr ); */ static inline StgPtr grabHpUpd( nat size ); static inline StgPtr grabHpNonUpd( nat size ); -static StgClosure* raiseAnError ( StgClosure* errObj ); +static StgClosure* raiseAnError ( StgClosure* exception ); static int enterCountI = 0; @@ -341,19 +313,27 @@ void SloppifyIntegerEnd ( StgPtr ); +#define gSp MainRegTable.rSp +#define gSu MainRegTable.rSu +#define gSpLim MainRegTable.rSpLim + + /* Macros to save/load local state. */ #ifdef DEBUG -#define SSS { tSp=Sp = xSp; tSu=Su = xSu; tSpLim=SpLim = xSpLim; } -#define LLL { tSp=xSp = Sp; tSu=xSu = Su; tSpLim=xSpLim = SpLim; } +#define SSS { tSp=gSp = xSp; tSu=gSu = xSu; tSpLim=gSpLim = xSpLim; } +#define LLL { tSp=xSp = gSp; tSu=xSu = gSu; tSpLim=xSpLim = gSpLim; } #else -#define SSS { Sp = xSp; Su = xSu; SpLim = xSpLim; } -#define LLL { xSp = Sp; xSu = Su; xSpLim = SpLim; } +#define SSS { gSp = xSp; gSu = xSu; gSpLim = xSpLim; } +#define LLL { xSp = gSp; xSu = gSu; xSpLim = gSpLim; } #endif -#define RETURN(vvv) { \ - StgThreadReturnCode retVal=(vvv); SSS; \ - /* SaveThreadState() is done by the scheduler. */ \ - return retVal; \ +#define RETURN(vvv) { \ + StgThreadReturnCode retVal=(vvv); \ + SSS; \ + cap->rCurrentTSO->sp = gSp; \ + cap->rCurrentTSO->su = gSu; \ + cap->rCurrentTSO->splim = gSpLim; \ + return retVal; \ } @@ -365,7 +345,7 @@ void SloppifyIntegerEnd ( StgPtr ); the macros, in particular xPopTagged*, do not make the tag sanity checks that their non-x cousins do, and (2) some of the macros depend critically on the semantics of C comma - expressions to work properly + expressions to work properly. */ #define xPushPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); } #define xPopPtr() ((StgPtr)(*xSp++)) @@ -427,6 +407,16 @@ void SloppifyIntegerEnd ( StgPtr ); PK_DBL(xSp-sizeofW(StgDouble)))) +#define xPushUpdateFrame(target, xSp_offset) \ +{ \ + StgUpdateFrame *__frame; \ + __frame = (StgUpdateFrame *)(xSp + (xSp_offset)) - 1; \ + SET_INFO(__frame, (StgInfoTable *)&Upd_frame_info); \ + __frame->link = xSu; \ + __frame->updatee = (StgClosure *)(target); \ + xSu = __frame; \ +} + #define xPopUpdateFrame(ooo) \ { \ /* NB: doesn't assume that Sp == Su */ \ @@ -450,7 +440,12 @@ void SloppifyIntegerEnd ( StgPtr ); #define PC (bciPtr - &(bcoInstr(bco,0))) -StgThreadReturnCode enter( StgClosure* obj0 ) +/* State on entry to enter(): + * - current thread is in cap->rCurrentTSO; + * - allocation area is in cap->rCurrentNursery & cap->rNursery + */ + +StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) { /* use of register here is primarily to make it clear to compilers that these entities are non-aliasable. @@ -462,12 +457,16 @@ StgThreadReturnCode enter( StgClosure* obj0 ) char eCount; /* enter counter, for context switching */ #ifdef DEBUG - /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */ StgPtr tSp; StgUpdateFrame* tSu; StgPtr tSpLim; #endif - /* LoadThreadState() is done by the scheduler. */ + + gSp = cap->rCurrentTSO->sp; + gSu = cap->rCurrentTSO->su; + gSpLim = cap->rCurrentTSO->splim; + #ifdef DEBUG - tSp = Sp; tSu = Su; tSpLim = SpLim; + /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */ + tSp = gSp; tSu = gSu; tSpLim = gSpLim; #endif obj = obj0; @@ -482,9 +481,9 @@ StgThreadReturnCode enter( StgClosure* obj0 ) enterLoop: #ifdef DEBUG - assert(Sp == tSp); - assert(Su == tSu); - assert(SpLim == tSpLim); + assert(gSp == tSp); + assert(gSu == tSu); + assert(gSpLim == tSpLim); IF_DEBUG(evaluator, SSS; enterCountI++; @@ -494,7 +493,7 @@ StgThreadReturnCode enter( StgClosure* obj0 ) fprintf(stderr,"(%d) Entering: ",enterCountI); printObj(obj); fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu); fprintf(stderr, "\n" ); - printStack(xSp,CurrentTSO->stack+CurrentTSO->stack_size,xSu); + printStack(xSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,xSu); fprintf(stderr, "\n\n"); LLL; ); @@ -502,9 +501,11 @@ StgThreadReturnCode enter( StgClosure* obj0 ) if ( #ifdef DEBUG - 1 || + ((++eCount) & 0x0F) == 0 +#else + ++eCount == 0 #endif - ++eCount == 0) { + ) { if (context_switch) { xPushCPtr(obj); /* code to restart with */ RETURN(ThreadYielding); @@ -558,7 +559,7 @@ StgThreadReturnCode enter( StgClosure* obj0 ) LoopTopLabel - ASSERT(PC < bco->n_instrs); + ASSERT((StgWord)(PC) < bco->n_instrs); IF_DEBUG(evaluator, fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", xSp, xSu, PC); SSS; @@ -566,7 +567,7 @@ StgThreadReturnCode enter( StgClosure* obj0 ) if (0) { int i; fprintf(stderr,"\n"); for (i = 8; i >= 0; i--) - fprintf(stderr, "%d %p\n", i, (StgPtr)(*(Sp+i))); + fprintf(stderr, "%d %p\n", i, (StgPtr)(*(gSp+i))); } fprintf(stderr,"\n"); LLL; @@ -697,6 +698,16 @@ StgThreadReturnCode enter( StgClosure* obj0 ) xPushPtr(p); Continue; } + Case(i_ALLOC_CONSTR_big): + { + StgPtr p; + int x = BCO_INSTR_16; + StgInfoTable* info = bcoConstAddr(bco,x); + SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL; + SET_HDR((StgClosure*)p,info,??); + xPushPtr(p); + Continue; + } Case(i_MKAP): { int x = BCO_INSTR_8; /* ToDo: Word not Int! */ @@ -840,7 +851,7 @@ StgThreadReturnCode enter( StgClosure* obj0 ) { int tag = BCO_INSTR_8; StgWord offset = BCO_INSTR_16; - if (constrTag(stgCast(StgClosure*,xStackPtr(0))) != tag) { + if (constrTag( (StgClosure*)xStackPtr(0) ) != tag) { bciPtr += offset; } Continue; @@ -1158,7 +1169,6 @@ StgThreadReturnCode enter( StgClosure* obj0 ) } Case(i_PRIMOP2): { - /* Remember to save */ int i, trc, pc_saved; void* p; StgBCO* bco_tmp; @@ -1167,7 +1177,7 @@ StgThreadReturnCode enter( StgClosure* obj0 ) pc_saved = PC; bco_tmp = bco; SSS; - p = enterBCO_primop2 ( i, &trc, &bco_tmp ); + p = enterBCO_primop2 ( i, &trc, &bco_tmp, cap ); LLL; bco = bco_tmp; bciPtr = &(bcoInstr(bco,pc_saved)); @@ -1176,8 +1186,8 @@ StgThreadReturnCode enter( StgClosure* obj0 ) /* we want to enter p */ obj = p; goto enterLoop; } else { - /* p is the the StgThreadReturnCode for this thread */ - RETURN((StgThreadReturnCode)p); + /* trc is the the StgThreadReturnCode for this thread */ + RETURN((StgThreadReturnCode)trc); }; } Continue; @@ -1260,6 +1270,7 @@ StgThreadReturnCode enter( StgClosure* obj0 ) Case(i_VAR_CHAR_big): Case(i_CONST_ADDR_big): Case(i_VAR_ADDR_big): + Case(i_VAR_STABLE_big): Case(i_CONST_INTEGER_big): Case(i_CONST_INT_big): Case(i_VAR_INT_big): @@ -1307,7 +1318,7 @@ StgThreadReturnCode enter( StgClosure* obj0 ) if (caf->mut_link == NULL) { SSS; recordOldToNewPtrs((StgMutClosure*)caf); LLL; } - SSS; PUSH_UPD_FRAME(bh,0); LLL; + xPushUpdateFrame(bh,0); xSp -= sizeofW(StgUpdateFrame); caf->link = enteredCAFs; enteredCAFs = caf; @@ -1325,14 +1336,10 @@ StgThreadReturnCode enter( StgClosure* obj0 ) case CAF_BLACKHOLE: case SE_CAF_BLACKHOLE: { - /*was StgBlackHole* */ - StgBlockingQueue* bh = (StgBlockingQueue*)obj; - /* Put ourselves on the blocking queue for this black hole and block */ - CurrentTSO->link = bh->blocking_queue; - bh->blocking_queue = CurrentTSO; - xPushCPtr(obj); /* code to restart with */ - barf("enter: CAF_BLACKHOLE unexpected!"); - RETURN(ThreadBlocked); + /* Let the scheduler figure out what to do :-) */ + cap->rCurrentTSO->whatNext = ThreadEnterGHC; + xPushCPtr(obj); + RETURN(ThreadYielding); } case AP_UPD: { @@ -1344,7 +1351,7 @@ StgThreadReturnCode enter( StgClosure* obj0 ) } /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME and insert an indirection immediately */ - SSS; PUSH_UPD_FRAME(ap,0); LLL; + xPushUpdateFrame(ap,0); xSp -= sizeofW(StgUpdateFrame); while (--i >= 0) { xPushWord(payloadWord(ap,i)); @@ -1418,7 +1425,8 @@ StgThreadReturnCode enter( StgClosure* obj0 ) fprintf(stderr, "hit a STOP_FRAME\n"); printObj(obj); fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu); - printStack(xSp,CurrentTSO->stack+CurrentTSO->stack_size,xSu); + printStack(xSp,cap->rCurrentTSO->stack + + cap->rCurrentTSO->stack_size,xSu); LLL; ); SSS; PopStopFrame(obj); LLL; @@ -1440,7 +1448,9 @@ StgThreadReturnCode enter( StgClosure* obj0 ) case RET_VEC_SMALL: case RET_BIG: case RET_VEC_BIG: - // barf("todo: RET_[VEC_]{BIG,SMALL}"); + cap->rCurrentTSO->whatNext = ThreadEnterGHC; + xPushCPtr(obj); + RETURN(ThreadYielding); default: belch("entered CONSTR with invalid continuation on stack"); IF_DEBUG(evaluator, @@ -1459,7 +1469,7 @@ StgThreadReturnCode enter( StgClosure* obj0 ) //fprintf(stderr, "entering unknown closure -- yielding to sched\n"); //printObj(obj); //LLL; - CurrentTSO->whatNext = ThreadEnterGHC; + cap->rCurrentTSO->whatNext = ThreadEnterGHC; xPushCPtr(obj); /* code to restart with */ RETURN(ThreadYielding); } @@ -1505,7 +1515,8 @@ StgThreadReturnCode enter( StgClosure* obj0 ) #undef xPushTaggedDouble #undef xTaggedStackDouble #undef xPopTaggedDouble - +#undef xPopUpdateFrame +#undef xPushUpdateFrame /* -------------------------------------------------------------------------- @@ -1513,56 +1524,56 @@ StgThreadReturnCode enter( StgClosure* obj0 ) * ------------------------------------------------------------------------*/ static inline void PushTag ( StackTag t ) - { *(--Sp) = t; } + { *(--gSp) = t; } inline void PushPtr ( StgPtr x ) - { *(--stgCast(StgPtr*,Sp)) = x; } + { *(--stgCast(StgPtr*,gSp)) = x; } static inline void PushCPtr ( StgClosure* x ) - { *(--stgCast(StgClosure**,Sp)) = x; } + { *(--stgCast(StgClosure**,gSp)) = x; } static inline void PushInt ( StgInt x ) - { *(--stgCast(StgInt*,Sp)) = x; } + { *(--stgCast(StgInt*,gSp)) = x; } static inline void PushWord ( StgWord x ) - { *(--stgCast(StgWord*,Sp)) = x; } + { *(--stgCast(StgWord*,gSp)) = x; } static inline void checkTag ( StackTag t1, StackTag t2 ) { ASSERT(t1 == t2);} static inline void PopTag ( StackTag t ) - { checkTag(t,*(Sp++)); } + { checkTag(t,*(gSp++)); } inline StgPtr PopPtr ( void ) - { return *stgCast(StgPtr*,Sp)++; } + { return *stgCast(StgPtr*,gSp)++; } static inline StgClosure* PopCPtr ( void ) - { return *stgCast(StgClosure**,Sp)++; } + { return *stgCast(StgClosure**,gSp)++; } static inline StgInt PopInt ( void ) - { return *stgCast(StgInt*,Sp)++; } + { return *stgCast(StgInt*,gSp)++; } static inline StgWord PopWord ( void ) - { return *stgCast(StgWord*,Sp)++; } + { return *stgCast(StgWord*,gSp)++; } static inline StgPtr stackPtr ( StgStackOffset i ) - { return *stgCast(StgPtr*, Sp+i); } + { return *stgCast(StgPtr*, gSp+i); } static inline StgInt stackInt ( StgStackOffset i ) - { return *stgCast(StgInt*, Sp+i); } + { return *stgCast(StgInt*, gSp+i); } static inline StgWord stackWord ( StgStackOffset i ) - { return *stgCast(StgWord*,Sp+i); } + { return *stgCast(StgWord*,gSp+i); } static inline void setStackWord ( StgStackOffset i, StgWord w ) - { Sp[i] = w; } + { gSp[i] = w; } static inline void PushTaggedRealWorld( void ) { PushTag(REALWORLD_TAG); } inline void PushTaggedInt ( StgInt x ) - { Sp -= sizeofW(StgInt); *Sp = x; PushTag(INT_TAG); } + { gSp -= sizeofW(StgInt); *gSp = x; PushTag(INT_TAG); } inline void PushTaggedWord ( StgWord x ) - { Sp -= sizeofW(StgWord); *Sp = x; PushTag(WORD_TAG); } + { gSp -= sizeofW(StgWord); *gSp = x; PushTag(WORD_TAG); } inline void PushTaggedAddr ( StgAddr x ) - { Sp -= sizeofW(StgAddr); *Sp = (W_)x; PushTag(ADDR_TAG); } + { gSp -= sizeofW(StgAddr); *gSp = (W_)x; PushTag(ADDR_TAG); } inline void PushTaggedChar ( StgChar x ) - { Sp -= sizeofW(StgChar); *Sp = stgCast(StgWord,x); PushTag(CHAR_TAG); } + { gSp -= sizeofW(StgChar); *gSp = stgCast(StgWord,x); PushTag(CHAR_TAG); } inline void PushTaggedFloat ( StgFloat x ) - { Sp -= sizeofW(StgFloat); ASSIGN_FLT(Sp,x); PushTag(FLOAT_TAG); } + { gSp -= sizeofW(StgFloat); ASSIGN_FLT(gSp,x); PushTag(FLOAT_TAG); } inline void PushTaggedDouble ( StgDouble x ) - { Sp -= sizeofW(StgDouble); ASSIGN_DBL(Sp,x); PushTag(DOUBLE_TAG); } + { gSp -= sizeofW(StgDouble); ASSIGN_DBL(gSp,x); PushTag(DOUBLE_TAG); } inline void PushTaggedStablePtr ( StgStablePtr x ) - { Sp -= sizeofW(StgStablePtr); *Sp = x; PushTag(STABLE_TAG); } + { gSp -= sizeofW(StgStablePtr); *gSp = x; PushTag(STABLE_TAG); } static inline void PushTaggedBool ( int x ) { PushTaggedInt(x); } @@ -1571,43 +1582,43 @@ static inline void PushTaggedBool ( int x ) static inline void PopTaggedRealWorld ( void ) { PopTag(REALWORLD_TAG); } inline StgInt PopTaggedInt ( void ) - { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, Sp); - Sp += sizeofW(StgInt); return r;} + { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, gSp); + gSp += sizeofW(StgInt); return r;} inline StgWord PopTaggedWord ( void ) - { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, Sp); - Sp += sizeofW(StgWord); return r;} + { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, gSp); + gSp += sizeofW(StgWord); return r;} inline StgAddr PopTaggedAddr ( void ) - { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, Sp); - Sp += sizeofW(StgAddr); return r;} + { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, gSp); + gSp += sizeofW(StgAddr); return r;} inline StgChar PopTaggedChar ( void ) - { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *Sp); - Sp += sizeofW(StgChar); return r;} + { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *gSp); + gSp += sizeofW(StgChar); return r;} inline StgFloat PopTaggedFloat ( void ) - { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(Sp); - Sp += sizeofW(StgFloat); return r;} + { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(gSp); + gSp += sizeofW(StgFloat); return r;} inline StgDouble PopTaggedDouble ( void ) - { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(Sp); - Sp += sizeofW(StgDouble); return r;} + { 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*, Sp); - Sp += sizeofW(StgStablePtr); return r;} + { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, gSp); + gSp += sizeofW(StgStablePtr); return r;} static inline StgInt taggedStackInt ( StgStackOffset i ) - { checkTag(INT_TAG,Sp[i]); return *stgCast(StgInt*, Sp+1+i); } + { checkTag(INT_TAG,gSp[i]); return *stgCast(StgInt*, gSp+1+i); } static inline StgWord taggedStackWord ( StgStackOffset i ) - { checkTag(WORD_TAG,Sp[i]); return *stgCast(StgWord*, Sp+1+i); } + { checkTag(WORD_TAG,gSp[i]); return *stgCast(StgWord*, gSp+1+i); } static inline StgAddr taggedStackAddr ( StgStackOffset i ) - { checkTag(ADDR_TAG,Sp[i]); return *stgCast(StgAddr*, Sp+1+i); } + { checkTag(ADDR_TAG,gSp[i]); return *stgCast(StgAddr*, gSp+1+i); } static inline StgChar taggedStackChar ( StgStackOffset i ) - { checkTag(CHAR_TAG,Sp[i]); return stgCast(StgChar, *(Sp+1+i)) ; } + { checkTag(CHAR_TAG,gSp[i]); return stgCast(StgChar, *(gSp+1+i)) ; } static inline StgFloat taggedStackFloat ( StgStackOffset i ) - { checkTag(FLOAT_TAG,Sp[i]); return PK_FLT(Sp+1+i); } + { checkTag(FLOAT_TAG,gSp[i]); return PK_FLT(gSp+1+i); } static inline StgDouble taggedStackDouble ( StgStackOffset i ) - { checkTag(DOUBLE_TAG,Sp[i]); return PK_DBL(Sp+1+i); } + { checkTag(DOUBLE_TAG,gSp[i]); return PK_DBL(gSp+1+i); } static inline StgStablePtr taggedStackStable ( StgStackOffset i ) - { checkTag(STABLE_TAG,Sp[i]); return *stgCast(StgStablePtr*, Sp+1+i); } + { checkTag(STABLE_TAG,gSp[i]); return *stgCast(StgStablePtr*, gSp+1+i); } /* -------------------------------------------------------------------------- @@ -1648,106 +1659,106 @@ static inline StgPtr grabHpNonUpd( nat size ) * o Stop frames * ------------------------------------------------------------------------*/ -static inline void PopUpdateFrame( StgClosure* obj ) +static inline void PopUpdateFrame ( StgClosure* obj ) { - /* NB: doesn't assume that Sp == Su */ + /* NB: doesn't assume that gSp == gSu */ IF_DEBUG(evaluator, fprintf(stderr, "Updating "); - printPtr(stgCast(StgPtr,Su->updatee)); + printPtr(stgCast(StgPtr,gSu->updatee)); fprintf(stderr, " with "); printObj(obj); - fprintf(stderr,"Sp = %p\tSu = %p\n\n", Sp, Su); + fprintf(stderr,"gSp = %p\tgSu = %p\n\n", gSp, gSu); ); #ifdef EAGER_BLACKHOLING #warn LAZY_BLACKHOLING is default for StgHugs #error Dont know if EAGER_BLACKHOLING works in StgHugs - ASSERT(get_itbl(Su->updatee)->type == BLACKHOLE - || get_itbl(Su->updatee)->type == SE_BLACKHOLE - || get_itbl(Su->updatee)->type == CAF_BLACKHOLE - || get_itbl(Su->updatee)->type == SE_CAF_BLACKHOLE + ASSERT(get_itbl(gSu->updatee)->type == BLACKHOLE + || get_itbl(gSu->updatee)->type == SE_BLACKHOLE + || get_itbl(gSu->updatee)->type == CAF_BLACKHOLE + || get_itbl(gSu->updatee)->type == SE_CAF_BLACKHOLE ); #endif /* EAGER_BLACKHOLING */ - UPD_IND(Su->updatee,obj); - Sp = stgCast(StgStackPtr,Su) + sizeofW(StgUpdateFrame); - Su = Su->link; + UPD_IND(gSu->updatee,obj); + gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame); + gSu = gSu->link; } -static inline void PopStopFrame( StgClosure* obj ) +static inline void PopStopFrame ( StgClosure* obj ) { - /* Move Su just off the end of the stack, we're about to spam the + /* Move gSu just off the end of the stack, we're about to gSpam the * STOP_FRAME with the return value. */ - Su = stgCast(StgUpdateFrame*,Sp+1); - *stgCast(StgClosure**,Sp) = obj; + gSu = stgCast(StgUpdateFrame*,gSp+1); + *stgCast(StgClosure**,gSp) = obj; } -static inline void PushCatchFrame( StgClosure* handler ) +static inline void PushCatchFrame ( StgClosure* handler ) { StgCatchFrame* fp; /* ToDo: stack check! */ - Sp -= sizeofW(StgCatchFrame); - fp = stgCast(StgCatchFrame*,Sp); + gSp -= sizeofW(StgCatchFrame); + fp = stgCast(StgCatchFrame*,gSp); SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS); fp->handler = handler; - fp->link = Su; - Su = stgCast(StgUpdateFrame*,fp); + fp->link = gSu; + gSu = stgCast(StgUpdateFrame*,fp); } -static inline void PopCatchFrame( void ) +static inline void PopCatchFrame ( void ) { - /* NB: doesn't assume that Sp == Su */ + /* NB: doesn't assume that gSp == gSu */ /* fprintf(stderr,"Popping catch frame\n"); */ - Sp = stgCast(StgStackPtr,Su) + sizeofW(StgCatchFrame); - Su = stgCast(StgCatchFrame*,Su)->link; + gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgCatchFrame); + gSu = stgCast(StgCatchFrame*,gSu)->link; } -static inline void PushSeqFrame( void ) +static inline void PushSeqFrame ( void ) { StgSeqFrame* fp; /* ToDo: stack check! */ - Sp -= sizeofW(StgSeqFrame); - fp = stgCast(StgSeqFrame*,Sp); + gSp -= sizeofW(StgSeqFrame); + fp = stgCast(StgSeqFrame*,gSp); SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS); - fp->link = Su; - Su = stgCast(StgUpdateFrame*,fp); + fp->link = gSu; + gSu = stgCast(StgUpdateFrame*,fp); } -static inline void PopSeqFrame( void ) +static inline void PopSeqFrame ( void ) { - /* NB: doesn't assume that Sp == Su */ - Sp = stgCast(StgStackPtr,Su) + sizeofW(StgSeqFrame); - Su = stgCast(StgSeqFrame*,Su)->link; + /* NB: doesn't assume that gSp == gSu */ + gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgSeqFrame); + gSu = stgCast(StgSeqFrame*,gSu)->link; } -static inline StgClosure* raiseAnError( StgClosure* errObj ) +static inline StgClosure* raiseAnError ( StgClosure* exception ) { - StgClosure *raise_closure; - - /* This closure represents the expression 'raise# E' where E - * is the exception raised. It is used to overwrite all the - * thunks which are currently under evaluataion. + /* This closure represents the expression 'primRaise E' where E + * is the exception raised (:: Exception). + * It is used to overwrite all the + * thunks which are currently under evaluation. */ - raise_closure = (StgClosure *)allocate(sizeofW(StgClosure)+1); - raise_closure->header.info = &raise_info; - raise_closure->payload[0] = R1.cl; - + HaskellObj primRaiseClosure + = asmClosureOfObject(getHugs_AsmObject_for("primRaise")); + HaskellObj reraiseClosure + = rts_apply ( primRaiseClosure, exception ); + while (1) { - switch (get_itbl(Su)->type) { + switch (get_itbl(gSu)->type) { case UPDATE_FRAME: - UPD_IND(Su->updatee,raise_closure); - Sp = stgCast(StgStackPtr,Su) + sizeofW(StgUpdateFrame); - Su = Su->link; + UPD_IND(gSu->updatee,reraiseClosure); + gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame); + gSu = gSu->link; break; case SEQ_FRAME: PopSeqFrame(); break; case CATCH_FRAME: /* found it! */ { - StgCatchFrame* fp = stgCast(StgCatchFrame*,Su); + StgCatchFrame* fp = stgCast(StgCatchFrame*,gSu); StgClosure *handler = fp->handler; - Su = fp->link; - Sp += sizeofW(StgCatchFrame); /* Pop */ - PushCPtr(errObj); + gSu = fp->link; + gSp += sizeofW(StgCatchFrame); /* Pop */ + PushCPtr(exception); return handler; } case STOP_FRAME: @@ -2202,29 +2213,29 @@ void SloppifyIntegerEnd ( StgPtr arr0 ) } -void myStackCheck ( void ) +void myStackCheck ( Capability* cap ) { - //StgPtr sp = (StgPtr)Sp; - StgPtr su = (StgPtr)Su; - //fprintf(stderr, "myStackCheck\n"); - if (!(SpLim <= Sp && Sp <= stgCast(StgPtr,Su))) { - fprintf(stderr, "myStackCheck: invalid initial Sp/Su \n" ); + /* fprintf(stderr, "myStackCheck\n"); */ + if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) { + fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" ); assert(0); } while (1) { - if (!(su >= CurrentTSO->stack && su <= CurrentTSO->stack + CurrentTSO->stack_size)) { - fprintf ( stderr, "myStackCheck: su out of stack\n" ); + if (!(gSu >= cap->rCurrentTSO->stack + && gSu <= cap->rCurrentTSO->stack + + cap->rCurrentTSO->stack_size)) { + fprintf ( stderr, "myStackCheck: gSu out of stack\n" ); assert(0); } - switch (get_itbl(stgCast(StgClosure*,su))->type) { + switch (get_itbl(stgCast(StgClosure*,gSu))->type) { case CATCH_FRAME: - su = (StgPtr) ((StgCatchFrame*)(su))->link; + gSu = (StgPtr) ((StgCatchFrame*)(gSu))->link; break; case UPDATE_FRAME: - su = (StgPtr) ((StgUpdateFrame*)(su))->link; + gSu = (StgPtr) ((StgUpdateFrame*)(gSu))->link; break; case SEQ_FRAME: - su = (StgPtr) ((StgSeqFrame*)(su))->link; + gSu = (StgPtr) ((StgSeqFrame*)(gSu))->link; break; case STOP_FRAME: goto postloop; @@ -2245,6 +2256,9 @@ void myStackCheck ( void ) */ static void* enterBCO_primop1 ( int primop1code ) { + if (combined) + barf("enterBCO_primop1 in combined mode"); + switch (primop1code) { case i_pushseqframe: { @@ -2638,8 +2652,12 @@ static void* enterBCO_primop1 ( int primop1code ) */ static void* enterBCO_primop2 ( int primop2code, int* /*StgThreadReturnCode* */ return2, - StgBCO** bco ) + StgBCO** bco, + Capability* cap ) { + if (combined) + barf("enterBCO_primop1 in combined mode"); + switch (primop2code) { case i_raise: /* raise#{err} */ { @@ -2912,147 +2930,139 @@ static void* enterBCO_primop2 ( int primop2code, break; } -#ifdef PROVIDE_CONCURRENT - case i_fork: - { - StgClosure* c = PopCPtr(); - StgTSO* t = createGenThread(RtsFlags.GcFlags.initialStkSize,c); - PushPtr(stgCast(StgPtr,t)); - - /* switch at the earliest opportunity */ - context_switch = 1; - /* but don't automatically switch to GHC - or you'll waste your - * time slice switching back. - * - * Actually, there's more to it than that: the default - * (ThreadEnterGHC) causes the thread to crash - don't - * understand why. - ADR - */ - t->whatNext = ThreadEnterHugs; - break; - } - case i_killThread: - { - StgTSO* tso = stgCast(StgTSO*,PopPtr()); - deleteThread(tso); - if (tso == CurrentTSO) { /* suicide */ - *return2 = ThreadFinished; - return (void*)(1+(NULL)); - } - break; - } - case i_sameMVar: - { /* identical to i_sameRef */ - StgPtr x = PopPtr(); - StgPtr y = PopPtr(); - PushTaggedBool(x==y); - break; - } case i_newMVar: { StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar))); SET_INFO(mvar,&EMPTY_MVAR_info); - mvar->head = mvar->tail = EndTSOQueue; - /* ToDo: this is a little strange */ + mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure; mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure); PushPtr(stgCast(StgPtr,mvar)); break; } -#if 1 -#if 0 -ToDo: another way out of the problem might be to add an explicit -continuation to primTakeMVar: takeMVar v = primTakeMVar v takeMVar. -The problem with this plan is that now I dont know how much to chop -off the stack. -#endif case i_takeMVar: { - StgMVar *mvar = stgCast(StgMVar*,PopPtr()); - /* If the MVar is empty, put ourselves - * on its blocking queue, and wait - * until we're woken up. - */ - if (GET_INFO(mvar) != &FULL_MVAR_info) { - if (mvar->head == EndTSOQueue) { - mvar->head = CurrentTSO; + StgMVar *mvar = (StgMVar*)PopCPtr(); + if (GET_INFO(mvar) == &EMPTY_MVAR_info) { + + /* The MVar is empty. Attach ourselves to the TSO's + blocking queue. + */ + if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) { + mvar->head = cap->rCurrentTSO; } else { - mvar->tail->link = CurrentTSO; + mvar->tail->link = cap->rCurrentTSO; } - CurrentTSO->link = EndTSOQueue; - mvar->tail = CurrentTSO; - - /* Hack, hack, hack. - * When we block, we push a restart closure - * on the stack - but which closure? - * We happen to know that the BCO we're - * executing looks like this: - * - * 0: STK_CHECK 4 - * 2: HP_CHECK 3 - * 4: TEST 0 29 - * 7: UNPACK - * 8: VAR 3 - * 10: VAR 1 - * 12: primTakeMVar - * 14: ALLOC_CONSTR 0x8213a80 - * 16: VAR 2 - * 18: VAR 2 - * 20: PACK 2 - * 22: VAR 0 - * 24: SLIDE 1 7 - * 27: ENTER - * 28: PANIC - * 29: PANIC - * - * so we rearrange the stack to look the - * way it did when we entered this BCO - * and push ths BCO. - * What a disgusting hack! - */ - - PopPtr(); - PopPtr(); - PushCPtr(obj); + cap->rCurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure; + cap->rCurrentTSO->why_blocked = BlockedOnMVar; + cap->rCurrentTSO->block_info.closure = (StgClosure *)mvar; + mvar->tail = cap->rCurrentTSO; + + /* At this point, the top-of-stack holds the MVar, + and underneath is the world token (). So the + stack is in the same state as when primTakeMVar + was entered (primTakeMVar is handwritten bytecode). + Push obj, which is this BCO, and return to the + scheduler. When the MVar is filled, the scheduler + will re-enter primTakeMVar, with the args still on + the top of the stack. + */ + PushCPtr((StgClosure*)(*bco)); *return2 = ThreadBlocked; return (void*)(1+(NULL)); } else { PushCPtr(mvar->value); + mvar->value = (StgClosure *)&END_TSO_QUEUE_closure; SET_INFO(mvar,&EMPTY_MVAR_info); - /* ToDo: this is a little strange */ - mvar->value = (StgClosure*)&END_TSO_QUEUE_closure; } break; } -#endif case i_putMVar: { StgMVar* mvar = stgCast(StgMVar*,PopPtr()); StgClosure* value = PopCPtr(); if (GET_INFO(mvar) == &FULL_MVAR_info) { - return (raisePrim("putMVar {full MVar}")); + return (makeErrorCall("putMVar {full MVar}")); } else { /* wake up the first thread on the * queue, it will continue with the * takeMVar operation and mark the * MVar empty again. */ - StgTSO* tso = mvar->head; - SET_INFO(mvar,&FULL_MVAR_info); mvar->value = value; - if (tso != EndTSOQueue) { - PUSH_ON_RUN_QUEUE(tso); - mvar->head = tso->link; - tso->link = EndTSOQueue; - if (mvar->head == EndTSOQueue) { - mvar->tail = EndTSOQueue; - } + + if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) { + ASSERT(mvar->head->why_blocked == BlockedOnMVar); + mvar->head = unblockOne(mvar->head); + if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) { + mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure; + } } + + /* unlocks the MVar in the SMP case */ + SET_INFO(mvar,&FULL_MVAR_info); + + /* yield for better communication performance */ + context_switch = 1; } - /* yield for better communication performance */ + break; + } + case i_sameMVar: + { /* identical to i_sameRef */ + StgMVar* x = (StgMVar*)PopPtr(); + StgMVar* y = (StgMVar*)PopPtr(); + 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; + } + case i_forkIO: + { + StgClosure* closure; + StgTSO* tso; + StgWord tid; + closure = PopCPtr(); + tso = createGenThread (RtsFlags.GcFlags.initialStkSize,closure); + tid = tso->id; + scheduleThread(tso); context_switch = 1; + PushTaggedWord(tid); + break; + } + +#ifdef PROVIDE_CONCURRENT + case i_killThread: + { + StgTSO* tso = stgCast(StgTSO*,PopPtr()); + deleteThread(tso); + if (tso == cap->rCurrentTSO) { /* suicide */ + *return2 = ThreadFinished; + return (void*)(1+(NULL)); + } break; } + +#if 1 +#if 0 +ToDo: another way out of the problem might be to add an explicit +continuation to primTakeMVar: takeMVar v = primTakeMVar v takeMVar. +The problem with this plan is that now I dont know how much to chop +off the stack. +#endif +#endif case i_delay: case i_waitRead: case i_waitWrite: @@ -3060,18 +3070,22 @@ off the stack. ASSERT(0); break; #endif /* PROVIDE_CONCURRENT */ + case i_ccall_ccall_Id: case i_ccall_ccall_IO: case i_ccall_stdcall_Id: case i_ccall_stdcall_IO: { int r; - CFunDescriptor* descriptor = PopTaggedAddr(); - void (*funPtr)(void) = PopTaggedAddr(); - char cc = (primop2code == i_ccall_stdcall_Id || + CFunDescriptor* descriptor; + void (*funPtr)(void); + char cc; + descriptor = PopTaggedAddr(); + funPtr = PopTaggedAddr(); + cc = (primop2code == i_ccall_stdcall_Id || primop2code == i_ccall_stdcall_IO) ? 's' : 'c'; - r = ccall(descriptor,funPtr,bco,cc); + r = ccall(descriptor,funPtr,bco,cc,cap); if (r == 0) break; if (r == 1) return makeErrorCall( @@ -3091,11 +3105,11 @@ off the stack. * ccall support code: * marshall moves args from C stack to Haskell stack * unmarshall moves args from Haskell stack to C stack - * argSize calculates how much space you need on the C stack + * argSize calculates how much gSpace you need on the C stack * ---------------------------------------------------------------------------*/ /* Pop arguments off the C stack and Push them onto the Hugs stack. - * Used when preparing for C calling Haskell or in response to + * Used when preparing for C calling Haskell or in regSponse to * Haskell calling C. */ nat marshall(char arg_ty, void* arg) @@ -3147,7 +3161,7 @@ nat marshall(char arg_ty, void* arg) } /* Pop arguments off the Hugs stack and Push them onto the C stack. - * Used when preparing for Haskell calling C or in response to + * Used when preparing for Haskell calling C or in regSponse to * C calling Haskell. */ nat unmarshall(char res_ty, void* res)