X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FInterpreter.c;h=95ddc48c2e144367b4dcb6a6a9c2f1346b0ef287;hb=6942766ac64f71b57c85a4069900b383495e2bdb;hp=c412f88d2e4920918a04a38d21fe32e6738afa93;hpb=ed0c285fe3937e5e53572165f9672dc1dc8ca7a4;p=ghc-hetmet.git diff --git a/ghc/rts/Interpreter.c b/ghc/rts/Interpreter.c index c412f88..95ddc48 100644 --- a/ghc/rts/Interpreter.c +++ b/ghc/rts/Interpreter.c @@ -1,2582 +1,833 @@ -#if 0 + /* ----------------------------------------------------------------------------- * Bytecode evaluator * * Copyright (c) 1994-2000. * * $RCSfile: Interpreter.c,v $ - * $Revision: 1.1 $ - * $Date: 2000/12/11 12:55:43 $ + * $Revision: 1.34 $ + * $Date: 2002/02/15 22:15:08 $ * ---------------------------------------------------------------------------*/ +#if !defined(SMP) +#include "PosixSource.h" +#else +/* Hack and slash.. */ +#include "Stg.h" +#endif #include "Rts.h" - - - -#include "RtsFlags.h" +#include "RtsAPI.h" #include "RtsUtils.h" -#include "Updates.h" +#include "Closures.h" +#include "TSO.h" +#include "Schedule.h" +#include "RtsFlags.h" #include "Storage.h" -#include "SchedAPI.h" /* for createGenThread */ -#include "Schedule.h" /* for context_switch */ +#include "Updates.h" + #include "Bytecodes.h" -#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" - -#ifdef DEBUG #include "Printer.h" #include "Disassembler.h" -#include "Sanity.h" -#include "StgRun.h" -#endif - -#include /* These are for primops */ -#include /* These are for primops */ -#include /* These are for primops */ -#ifdef HAVE_IEEE754_H -#include /* These are for primops */ -#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 - * can't use it because they use the closure at type StgClosure* or - * even StgPtr*. I suspect they should be changed. -- ADR - */ -#define EndTSOQueue stgCast(StgTSO*,(void*)&END_TSO_QUEUE_closure) - -/* These macros are rather delicate - read a good ANSI C book carefully - * before meddling. - */ -#define mystr(x) #x -#define mycat(x,y) x##y -#define mycat2(x,y) mycat(x,y) -#define mycat3(x,y,z) mycat2(x,mycat2(y,z)) - -#if defined(__GNUC__) && !defined(DEBUG) -#define USE_GCC_LABELS 1 -#else -#define USE_GCC_LABELS 0 -#endif - -/* Make it possible for the evaluator to get hold of bytecode - for a given function by name. Useful but a hack. Sigh. - */ -extern void* /* StgClosure* */ getHugs_BCO_cptr_for ( char* s ); -extern int /* Bool */ combined; - - - -/* -------------------------------------------------------------------------- - * Hugs Hooks - a bit of a hack - * ------------------------------------------------------------------------*/ - -void setRtsFlags( int x ); -void setRtsFlags( int x ) -{ - unsigned int w = 0x12345678; - unsigned char* pw = (unsigned char *)&w; - if (*pw == 0x78) { - /* little endian */ - *(int*)(&(RtsFlags.DebugFlags)) = x; - } else { - /* big endian */ - unsigned int w1 = x; - unsigned int w2 = 0; - w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8; - w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8; - w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8; - w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8; - *(int*)(&(RtsFlags.DebugFlags)) = (int)w2; - } -} - - -typedef struct { - StgTSOBlockReason reason; - unsigned int delay; -} HugsBlock; +#include "Interpreter.h" /* -------------------------------------------------------------------------- - * Entering-objects and bytecode interpreter part of evaluator + * The new bytecode interpreter * ------------------------------------------------------------------------*/ -/* The primop (and all other) parts of this evaluator operate upon the - machine state which lives in MainRegTable. enter is different: - to make its closure- and bytecode-interpreting loops go fast, some of that - state is pulled out into local vars (viz, registers, if we are lucky). - That means that we need to save(load) the local state at every exit(reentry) - into enter. That is, around every procedure call it makes. Blargh! - If you modify this code, __be warned__ it will fail in mysterious ways if - you fail to preserve this property. - - Currently the pulled-out state is Sp in xSp, Su in xSu and SpLim in xSpLim. - The SSS macros saves the state back in MainRegTable, and LLL loads it from - MainRegTable. RETURN(v) does SSS and then returns v; all exits should - be via RETURN and not plain return. - - Since xSp, xSu and xSpLim are local vars in enter, they are not visible - in procedures called from enter. To fix this, either (1) turn the - procedures into macros, so they get copied inline, or (2) bracket - the procedure call with SSS and LLL so that the local and global - machine states are synchronised for the duration of the call. -*/ - - -/* Forward decls ... */ -static void* enterBCO_primop1 ( int ); -static void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */, - StgBCO**, Capability*, HugsBlock * ); -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 StgPtr grabHpUpd( nat size ); -static inline StgPtr grabHpNonUpd( nat size ); -static StgClosure* raiseAnError ( StgClosure* exception ); - -static int enterCountI = 0; - -StgDouble B__encodeDouble (B* s, I_ e); -void B__decodeDouble (B* man, I_* exp, StgDouble dbl); -StgFloat B__encodeFloat (B* s, I_ e); -void B__decodeFloat (B* man, I_* exp, StgFloat flt); -StgPtr CreateByteArrayToHoldInteger ( int ); -B* IntegerInsideByteArray ( StgPtr ); -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=gSp = xSp; tSu=gSu = xSu; tSpLim=gSpLim = xSpLim; } -#define LLL { tSp=xSp = gSp; tSu=xSu = gSu; tSpLim=xSpLim = gSpLim; } -#else -#define SSS { gSp = xSp; gSu = xSu; gSpLim = xSpLim; } -#define LLL { xSp = gSp; xSu = gSu; xSpLim = gSpLim; } -#endif - -#define RETURN(vvv) { \ - StgThreadReturnCode retVal=(vvv); \ - SSS; \ - cap->rCurrentTSO->sp = gSp; \ - cap->rCurrentTSO->su = gSu; \ - return retVal; \ - } - - -/* Macros to operate directly on the pulled-out machine state. - These mirror some of the small procedures used in the primop code - below, except you have to be careful about side effects, - ie xPushPtr(xStackPtr(n)) won't work! It certainly isn't the - same as PushPtr(StackPtr(n)). Also note that (1) some of - 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. -*/ -#define xPushPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); } -#define xPopPtr() ((StgPtr)(*xSp++)) - -#define xPushCPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); } -#define xPopCPtr() ((StgClosure*)(*xSp++)) - -#define xPushWord(ppp) { xSp--; *xSp=(StgWord)(ppp); } -#define xPopWord() ((StgWord)(*xSp++)) - -#define xStackPtr(nnn) ((StgPtr)(*(xSp+(nnn)))) -#define xStackWord(nnn) ((StgWord)(*(xSp+(nnn)))) -#define xSetStackWord(iii,www) xSp[iii]=(StgWord)(www) - -#define xPushTag(ttt) { xSp--; *xSp=(StgWord)(ttt); } -#define xPopTag(ttt) { StackTag t = (StackTag)(*xSp++); \ - ASSERT(t == ttt); } - -#define xPushTaggedInt(xxx) { xSp -= sizeofW(StgInt); \ - *xSp = (xxx); xPushTag(INT_TAG); } -#define xTaggedStackInt(iii) ((StgInt)(*(xSp+1+(iii)))) -#define xPopTaggedInt() ((xSp++,xSp+=sizeofW(StgInt), \ - (StgInt)(*(xSp-sizeofW(StgInt))))) - -#define xPushTaggedWord(xxx) { xSp -= sizeofW(StgWord); \ - *xSp = (xxx); xPushTag(WORD_TAG); } -#define xTaggedStackWord(iii) ((StgWord)(*(xSp+1+(iii)))) -#define xPopTaggedWord() ((xSp++,xSp+=sizeofW(StgWord), \ - (StgWord)(*(xSp-sizeofW(StgWord))))) - -#define xPushTaggedAddr(xxx) { xSp -= sizeofW(StgAddr); \ - *xSp = (StgWord)(xxx); xPushTag(ADDR_TAG); } -#define xTaggedStackAddr(iii) ((StgAddr)(*(xSp+1+(iii)))) -#define xPopTaggedAddr() ((xSp++,xSp+=sizeofW(StgAddr), \ - (StgAddr)(*(xSp-sizeofW(StgAddr))))) - -#define xPushTaggedStable(xxx) { xSp -= sizeofW(StgStablePtr); \ - *xSp = (StgWord)(xxx); xPushTag(STABLE_TAG); } -#define xTaggedStackStable(iii) ((StgStablePtr)(*(xSp+1+(iii)))) -#define xPopTaggedStable() ((xSp++,xSp+=sizeofW(StgStablePtr), \ - (StgStablePtr)(*(xSp-sizeofW(StgStablePtr))))) - -#define xPushTaggedChar(xxx) { xSp -= sizeofW(StgChar); \ - *xSp = (StgWord)(xxx); xPushTag(CHAR_TAG); } -#define xTaggedStackChar(iii) ((StgChar)(*(xSp+1+(iii)))) -#define xPopTaggedChar() ((xSp++,xSp+=sizeofW(StgChar), \ - (StgChar)(*(xSp-sizeofW(StgChar))))) - -#define xPushTaggedFloat(xxx) { xSp -= sizeofW(StgFloat); \ - ASSIGN_FLT(xSp,xxx); xPushTag(FLOAT_TAG); } -#define xTaggedStackFloat(iii) PK_FLT(xSp+1+(iii)) -#define xPopTaggedFloat() ((xSp++,xSp+=sizeofW(StgFloat), \ - PK_FLT(xSp-sizeofW(StgFloat)))) - -#define xPushTaggedDouble(xxx) { xSp -= sizeofW(StgDouble); \ - ASSIGN_DBL(xSp,xxx); xPushTag(DOUBLE_TAG); } -#define xTaggedStackDouble(iii) PK_DBL(xSp+1+(iii)) -#define xPopTaggedDouble() ((xSp++,xSp+=sizeofW(StgDouble), \ - 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 */ \ - IF_DEBUG(evaluator, \ - fprintf(stderr, "Updating "); \ - printPtr(stgCast(StgPtr,xSu->updatee)); \ - fprintf(stderr, " with "); \ - printObj(ooo); \ - fprintf(stderr,"xSp = %p\txSu = %p\n\n", xSp, xSu); \ - ); \ - UPD_IND(xSu->updatee,ooo); \ - xSp = stgCast(StgStackPtr,xSu) + sizeofW(StgUpdateFrame); \ - xSu = xSu->link; \ -} - - - -/* Instruction stream macros */ -#define BCO_INSTR_8 *bciPtr++ -#define BCO_INSTR_16 ((bciPtr += 2, (*(bciPtr-2) << 8) + *(bciPtr-1))) -#define PC (bciPtr - &(bcoInstr(bco,0))) +/* The interpreter can be compiled so it just interprets BCOs and + hands literally everything else to the scheduler. This gives a + "reference interpreter" which is correct but slow -- useful for + debugging. By default, we handle certain closures specially so as + to dramatically cut down on the number of deferrals to the + scheduler. Ie normally you don't want REFERENCE_INTERPRETER to be + defined. */ +/* #define REFERENCE_INTERPRETER */ -/* State on entry to enter(): - * - current thread is in cap->rCurrentTSO; - * - allocation area is in cap->rCurrentNursery & cap->rNursery - */ +/* Gather stats about entry, opcode, opcode-pair frequencies. For + tuning the interpreter. */ -StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) -{ - /* use of register here is primarily to make it clear to compilers - that these entities are non-aliasable. - */ - register StgPtr xSp; /* local state -- stack pointer */ - register StgUpdateFrame* xSu; /* local state -- frame pointer */ - register StgPtr xSpLim; /* local state -- stack lim pointer */ - 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 - - gSp = cap->rCurrentTSO->sp; - gSu = cap->rCurrentTSO->su; - gSpLim = cap->rCurrentTSO->stack + RESERVED_STACK_WORDS; - -#ifdef DEBUG - /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */ - tSp = gSp; tSu = gSu; tSpLim = gSpLim; -#endif +/* #define INTERP_STATS */ - obj = obj0; - eCount = 0; - /* Load the local state from global state, and Party On, Dudes! */ - /* From here onwards, we operate with the local state and - save/reload it as necessary. - */ - LLL; - enterLoop: +/* iSp points to the lowest live word on the stack. */ - numEnters++; - -#ifdef DEBUG - ASSERT(gSp == tSp); - ASSERT(gSu == tSu); - ASSERT(gSpLim == tSpLim); - IF_DEBUG(evaluator, - SSS; - enterCountI++; - ASSERT(xSpLim <= xSp && xSp <= stgCast(StgPtr,xSu)); - fprintf(stderr, - "\n---------------------------------------------------------------\n"); - fprintf(stderr,"(%d) Entering: ",enterCountI); printObj(obj); - fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu); - fprintf(stderr, "\n" ); - printStack(xSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,xSu); - fprintf(stderr, "\n\n"); - LLL; - ); -#endif - - if ( -#ifdef DEBUG - ((++eCount) & 0x0F) == 0 -#else - ++eCount == 0 -#endif - ) { - if (context_switch) { - 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"); - } - } - } +#define StackWord(n) iSp[n] +#define BCO_NEXT instrs[bciPtr++] +#define BCO_PTR(n) (W_)ptrs[n] +#define BCO_LIT(n) (W_)literals[n] +#define BCO_ITBL(n) itbls[n] - switch ( get_itbl(obj)->type ) { - case INVALID_OBJECT: - barf("Invalid object %p",obj); - - case BCO: bco_entry: - - /* ---------------------------------------------------- */ - /* Start of the bytecode evaluator */ - /* ---------------------------------------------------- */ - { -# if USE_GCC_LABELS -# define Ins(x) &&l##x - static void *labs[] = { INSTRLIST }; -# undef Ins -# define LoopTopLabel -# define Case(x) l##x -# define Continue goto *labs[BCO_INSTR_8] -# define Dispatch Continue; -# define EndDispatch -# else -# define LoopTopLabel insnloop: -# define Case(x) case x -# define Continue goto insnloop -# define Dispatch switch (BCO_INSTR_8) { -# define EndDispatch } -# endif - - register StgWord8* bciPtr; /* instruction pointer */ - register StgBCO* bco = (StgBCO*)obj; - StgWord wantToGC; - - /* Don't need to SSS ... LLL around doYouWantToGC */ - wantToGC = doYouWantToGC(); - if (wantToGC) { - xPushCPtr((StgClosure*)bco); /* code to restart with */ - RETURN(HeapOverflow); - } - - bciPtr = &(bcoInstr(bco,0)); - - LoopTopLabel - - ASSERT((StgWord)(PC) < bco->n_instrs); - IF_DEBUG(evaluator, - fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", xSp, xSu, PC); - SSS; - disInstr(bco,PC); - if (0) { int i; - fprintf(stderr,"\n"); - for (i = 8; i >= 0; i--) - fprintf(stderr, "%d %p\n", i, (StgPtr)(*(gSp+i))); - } - fprintf(stderr,"\n"); - LLL; - ); - - Dispatch - - Case(i_INTERNAL_ERROR): - barf("INTERNAL_ERROR at %p:%d",bco,PC-1); - Case(i_PANIC): - barf("PANIC at %p:%d",bco,PC-1); - Case(i_STK_CHECK): - { - int n = BCO_INSTR_8; - if (xSp - n < xSpLim) { - xPushCPtr((StgClosure*)bco); /* code to restart with */ - RETURN(StackOverflow); - } - Continue; - } - Case(i_STK_CHECK_big): - { - int n = BCO_INSTR_16; - if (xSp - n < xSpLim) { - xPushCPtr((StgClosure*)bco); /* code to restart with */ - RETURN(StackOverflow); - } - Continue; - } - Case(i_ARG_CHECK): - { - nat n = BCO_INSTR_8; - if ((StgPtr*)(xSp + n) > (StgPtr*)xSu) { - StgWord words = (P_)xSu - xSp; - - /* first build a PAP */ - ASSERT((P_)xSu >= xSp); /* was (words >= 0) but that's always true */ - if (words == 0) { /* optimisation */ - /* Skip building the PAP and update with an indirection. */ - } else { - /* Build the PAP. */ - /* In the evaluator, we avoid the need to do - * a heap check here by including the size of - * the PAP in the heap check we performed - * when we entered the BCO. - */ - StgInt i; - StgPAP* pap; - SSS; pap = (StgPAP*)grabHpNonUpd(PAP_sizeW(words)); LLL; - SET_HDR(pap,&PAP_info,CC_pap); - pap->n_args = words; - pap->fun = obj; - for (i = 0; i < (I_)words; ++i) { - payloadWord(pap,i) = xSp[i]; - } - xSp += words; - obj = stgCast(StgClosure*,pap); - } - - /* now deal with "update frame" */ - /* as an optimisation, we process all on top of stack */ - /* instead of just the top one */ - ASSERT(xSp==(P_)xSu); - do { - switch (get_itbl(xSu)->type) { - case CATCH_FRAME: - /* Hit a catch frame during an arg satisfaction check, - * so the thing returning (1) has not thrown an - * exception, and (2) is of functional type. Just - * zap the catch frame and carry on down the stack - * (looking for more arguments, basically). - */ - SSS; PopCatchFrame(); LLL; - break; - case UPDATE_FRAME: - 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); - /* Hit a SEQ frame during an arg satisfaction check. - * So now return to bco_info which is under the - * SEQ frame. The following code is copied from a - * case RET_BCO further down. (The reason why we're - * here is that something of functional type has - * been seq-d on, and we're now returning to the - * algebraic-case-continuation which forced the - * evaluation in the first place.) - */ - { - StgClosure* ret; - (void)xPopPtr(); - ret = xPopCPtr(); - xPushPtr((P_)obj); - obj = ret; - goto enterLoop; - } - break; - default: - barf("Invalid update frame during argcheck"); - } - } while (xSp==(P_)xSu); - goto enterLoop; - } - Continue; - } - Case(i_ALLOC_AP): - { - StgPtr p; - int words = BCO_INSTR_8; - SSS; p = grabHpUpd(AP_sizeW(words)); LLL; - xPushPtr(p); - Continue; - } - Case(i_ALLOC_CONSTR): - { - StgPtr p; - StgInfoTable* info = bcoConstAddr(bco,BCO_INSTR_8); - SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL; - SET_HDR((StgClosure*)p,info,??); - 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! */ - int y = BCO_INSTR_8; - StgAP_UPD* o = stgCast(StgAP_UPD*,xStackPtr(x)); - SET_HDR(o,&AP_UPD_info,??); - o->n_args = y; - o->fun = stgCast(StgClosure*,xPopPtr()); - for(x=0; x < y; ++x) { - payloadWord(o,x) = xPopWord(); - } - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - SSS; - printObj(stgCast(StgClosure*,o)); - LLL; - ); - Continue; - } - Case(i_MKAP_big): - { - int x, y; - StgAP_UPD* o; - x = BCO_INSTR_16; - y = BCO_INSTR_16; - o = stgCast(StgAP_UPD*,xStackPtr(x)); - SET_HDR(o,&AP_UPD_info,??); - o->n_args = y; - o->fun = stgCast(StgClosure*,xPopPtr()); - for(x=0; x < y; ++x) { - payloadWord(o,x) = xPopWord(); - } - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - SSS; - printObj(stgCast(StgClosure*,o)); - LLL; - ); - Continue; - } - Case(i_MKPAP): - { - int x = BCO_INSTR_8; - int y = BCO_INSTR_8; - StgPAP* o = stgCast(StgPAP*,xStackPtr(x)); - SET_HDR(o,&PAP_info,??); - o->n_args = y; - o->fun = stgCast(StgClosure*,xPopPtr()); - for(x=0; x < y; ++x) { - payloadWord(o,x) = xPopWord(); - } - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - SSS; - printObj(stgCast(StgClosure*,o)); - LLL; - ); - Continue; - } - Case(i_PACK): - { - int offset = BCO_INSTR_8; - StgClosure* o = stgCast(StgClosure*,xStackPtr(offset)); - const StgInfoTable* info = get_itbl(o); - nat p = info->layout.payload.ptrs; - nat np = info->layout.payload.nptrs; - nat i; - for(i=0; i < p; ++i) { - o->payload[i] = xPopCPtr(); - } - for(i=0; i < np; ++i) { - payloadWord(o,p+i) = 0xdeadbeef; - } - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - SSS; - printObj(stgCast(StgClosure*,o)); - LLL; - ); - Continue; - } - Case(i_PACK_big): - { - int offset = BCO_INSTR_16; - StgClosure* o = stgCast(StgClosure*,xStackPtr(offset)); - const StgInfoTable* info = get_itbl(o); - nat p = info->layout.payload.ptrs; - nat np = info->layout.payload.nptrs; - nat i; - for(i=0; i < p; ++i) { - o->payload[i] = xPopCPtr(); - } - for(i=0; i < np; ++i) { - payloadWord(o,p+i) = 0xdeadbeef; - } - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - SSS; - printObj(stgCast(StgClosure*,o)); - LLL; - ); - Continue; - } - Case(i_SLIDE): - { - int x = BCO_INSTR_8; - int y = BCO_INSTR_8; - ASSERT(xSp+x+y <= stgCast(StgPtr,xSu)); - /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */ - while(--x >= 0) { - xSetStackWord(x+y,xStackWord(x)); - } - xSp += y; - Continue; - } - Case(i_SLIDE_big): - { - int x, y; - x = BCO_INSTR_16; - y = BCO_INSTR_16; - ASSERT(xSp+x+y <= stgCast(StgPtr,xSu)); - /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */ - while(--x >= 0) { - xSetStackWord(x+y,xStackWord(x)); - } - xSp += y; - Continue; - } - Case(i_ENTER): - { - obj = xPopCPtr(); - goto enterLoop; - } - Case(i_RETADDR): - { - xPushPtr(bcoConstPtr(bco,BCO_INSTR_8)); - xPushPtr(stgCast(StgPtr,&ret_bco_info)); - Continue; - } - Case(i_TEST): - { - int tag = BCO_INSTR_8; - StgWord offset = BCO_INSTR_16; - if (constrTag( (StgClosure*)xStackPtr(0) ) != tag) { - bciPtr += offset; - } - Continue; - } - Case(i_UNPACK): - { - StgClosure* o = stgCast(StgClosure*,xStackPtr(0)); - const StgInfoTable* itbl = get_itbl(o); - int i = itbl->layout.payload.ptrs; - ASSERT( itbl->type == CONSTR - || itbl->type == CONSTR_STATIC - || itbl->type == CONSTR_NOCAF_STATIC - || itbl->type == CONSTR_1_0 - || itbl->type == CONSTR_0_1 - || itbl->type == CONSTR_2_0 - || itbl->type == CONSTR_1_1 - || itbl->type == CONSTR_0_2 - ); - while (--i>=0) { - xPushCPtr(o->payload[i]); - } - Continue; - } - Case(i_VAR_big): - { - int n = BCO_INSTR_16; - StgPtr p = xStackPtr(n); - xPushPtr(p); - Continue; - } - Case(i_VAR): - { - StgPtr p = xStackPtr(BCO_INSTR_8); - xPushPtr(p); - Continue; - } - Case(i_CONST): - { - xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,BCO_INSTR_8))); - Continue; - } - Case(i_CONST_big): - { - int n = BCO_INSTR_16; - xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,n))); - Continue; - } -#ifdef XMLAMBDA - /* allocate rows, implemented on top of (frozen) Arrays */ - Case(i_ALLOC_ROW): - { - StgMutArrPtrs* p; - StgWord n = BCO_INSTR_8; - SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + n)); LLL; - SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS); - p->ptrs = n; - xPushPtr(p); - Continue; - } - Case(i_ALLOC_ROW_big): - { - StgMutArrPtrs* p; - StgWord n = BCO_INSTR_16; - SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + n)); LLL; - SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS); - p->ptrs = n; - xPushPtr(p); - Continue; - } - - /* pack values into a row. */ - Case(i_PACK_ROW): - { - StgWord offset = BCO_INSTR_8; - StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(offset)); - StgWord n = p->ptrs; - StgWord i; - - for (i=0; ipayload[i] = xPopCPtr(); - } - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - SSS; - printObj(stgCast(StgClosure*,p)); - LLL; - ); - Continue; - } - Case(i_PACK_ROW_big): - { - StgWord offset = BCO_INSTR_16; - StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(offset)); - StgWord n = p->ptrs; - StgWord i; - - for (i=0; ipayload[i] = xPopCPtr(); - } - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - SSS; - printObj(stgCast(StgClosure*,p)); - LLL; - ); - Continue; - } - - /* extract all fields of a row */ - Case(i_UNPACK_ROW): - { - StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(0)); - nat i = p->ptrs; - while (i > 0) - { - i--; - xPushCPtr(p->payload[i]); - } - Continue; - } - - /* Trivial row (unit) */ - Case(i_CONST_ROW_TRIV): - { - StgMutArrPtrs* p; - SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + 0)); LLL; - SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS); - p->ptrs = 0; - xPushPtr(p); - Continue; - } - - /* pack values into an Inj */ - Case(i_PACK_INJ_VAR): - { - const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord)); - StgWord offset = BCO_INSTR_8; - - StgClosure* o; - SSS; o = (StgClosure*)grabHpNonUpd(size); LLL; - SET_HDR(o,Inj_con_info,??); - - payloadWord(o,sizeofW(StgPtr)) = xTaggedStackWord(offset); - payloadPtr(o,0) = xPopPtr(); - - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - SSS; - printObj(stgCast(StgClosure*,o)); - LLL; - ); - xPushPtr(stgCast(StgPtr,o)); - Continue; - } - Case(i_PACK_INJ_VAR_big): - { - const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord)); - StgWord offset = BCO_INSTR_16; - - StgClosure* o; - SSS; o = (StgClosure*)grabHpNonUpd(size); LLL; - SET_HDR(o,Inj_con_info,??); - - payloadWord(o,sizeofW(StgPtr)) = xTaggedStackWord(offset); - payloadPtr(o,0) = xPopPtr(); - - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - SSS; - printObj(stgCast(StgClosure*,o)); - LLL; - ); - xPushPtr(stgCast(StgPtr,o)); - Continue; - } - Case(i_PACK_INJ_CONST_8): - { - const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord)); - StgWord witness = BCO_INSTR_8; - - StgClosure* o; - SSS; o = (StgClosure*)grabHpNonUpd(size); LLL; - SET_HDR(o,Inj_con_info,??); - - payloadWord(o,sizeofW(StgPtr)) = witness; - payloadPtr(o,0) = xPopPtr(); - - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - SSS; - printObj(stgCast(StgClosure*,o)); - LLL; - ); - xPushPtr(stgCast(StgPtr,o)); - Continue; - } - Case(i_PACK_INJ_REL_8): - { - const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord)); - StgWord offset = BCO_INSTR_8; - StgWord cwitness = BCO_INSTR_8; - - StgClosure* o; - SSS; o = (StgClosure*)grabHpNonUpd(size); LLL; - SET_HDR(o,Inj_con_info,??); - - payloadWord(o,sizeofW(StgPtr)) = xTaggedStackWord(offset) + cwitness; - payloadPtr(o,0) = xPopPtr(); - - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - SSS; - printObj(stgCast(StgClosure*,o)); - LLL; - ); - xPushPtr(stgCast(StgPtr,o)); - Continue; - } - Case(i_PACK_INJ): - { - const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord)); - - StgClosure* o; - SSS; o = (StgClosure*)grabHpNonUpd(size); LLL; - SET_HDR(o,Inj_con_info,??); - - payloadWord(o,sizeofW(StgPtr)) = xPopTaggedWord(); - payloadPtr(o,0) = xPopPtr(); - - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - SSS; - printObj(stgCast(StgClosure*,o)); - LLL; - ); - xPushPtr(stgCast(StgPtr,o)); - Continue; - } - - /* Test Inj witnesses. */ - Case(i_TEST_INJ_VAR): - { - StgWord offset = BCO_INSTR_8; - StgWord jump = BCO_INSTR_16; - - StgWord index = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) ); - if (index != xTaggedStackWord(offset) ) - { - bciPtr += jump; - } - Continue; - } - Case(i_TEST_INJ_VAR_big): - { - StgWord offset = BCO_INSTR_16; - StgWord jump = BCO_INSTR_16; - - StgWord index = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) ); - if (index != xTaggedStackWord(offset) ) - { - bciPtr += jump; - } - Continue; - } - Case(i_TEST_INJ_CONST_8): - { - StgWord cwitness = BCO_INSTR_8; - StgWord jump = BCO_INSTR_16; - - StgWord witness = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) ); - if (witness != cwitness ) - { - bciPtr += jump; - } - Continue; - } - Case(i_TEST_INJ_REL_8): - { - StgWord offset = BCO_INSTR_8; - StgWord cwitness = BCO_INSTR_8; - StgWord jump = BCO_INSTR_16; - - StgWord witness = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) ); - if (witness != xTaggedStackWord(offset) + cwitness ) - { - bciPtr += jump; - } - Continue; - } - Case(i_TEST_INJ): - { - StgWord jump = BCO_INSTR_16; - StgWord cwitness = xPopTaggedWord(); - - StgWord witness = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) ); - if (witness != cwitness ) - { - bciPtr += jump; - } - Continue; - } - - /* extract the value of an INJ */ - Case(i_UNPACK_INJ): - { - StgClosure* con = stgCast(StgClosure*,xStackPtr(0)); - - ASSERT(get_itbl(con) == Inj_con_info); - - xPushPtr(payloadPtr(con,0)); - Continue; - } - - /* optimized witness (word) operations */ - Case(i_CONST_WORD_8): - { - xPushTaggedWord(BCO_INSTR_8); - Continue; - } - Case(i_ADD_WORD_VAR): - { - StgWord offset = BCO_INSTR_8; - StgWord witness = xTaggedStackWord(offset); - witness += xPopTaggedWord(); - xPushTaggedWord(witness); - Continue; - } - Case(i_ADD_WORD_VAR_big): - { - StgWord offset = BCO_INSTR_16; - StgWord witness = xTaggedStackWord(offset); - witness += xPopTaggedWord(); - xPushTaggedWord(witness); - Continue; - } - Case(i_ADD_WORD_VAR_8): - { - StgWord offset = BCO_INSTR_8; - StgWord inc = BCO_INSTR_8; - StgWord witness = xTaggedStackWord(offset); - xPushTaggedWord(witness + inc); - Continue; - } -#endif /* XMLAMBA */ - - Case(i_VOID): - { - SSS; PushTaggedRealWorld(); LLL; - Continue; - } - Case(i_VAR_INT): - { - StgInt i = xTaggedStackInt(BCO_INSTR_8); - xPushTaggedInt(i); - Continue; - } - Case(i_CONST_INT): - { - xPushTaggedInt(bcoConstInt(bco,BCO_INSTR_8)); - Continue; - } - Case(i_CONST_INT_big): - { - int n = BCO_INSTR_16; - xPushTaggedInt(bcoConstInt(bco,n)); - Continue; - } - Case(i_PACK_INT): - { - StgClosure* o; - SSS; o = (StgClosure*)grabHpNonUpd(Izh_sizeW); LLL; - SET_HDR(o,Izh_con_info,??); - payloadWord(o,0) = xPopTaggedInt(); - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - SSS; - printObj(stgCast(StgClosure*,o)); - LLL; - ); - xPushPtr(stgCast(StgPtr,o)); - Continue; - } - Case(i_UNPACK_INT): - { - StgClosure* con = stgCast(StgClosure*,xStackPtr(0)); - /* ASSERT(isIntLike(con)); */ - xPushTaggedInt(payloadWord(con,0)); - Continue; - } - Case(i_TEST_INT): - { - StgWord offset = BCO_INSTR_16; - StgInt x = xPopTaggedInt(); - StgInt y = xPopTaggedInt(); - if (x != y) { - bciPtr += offset; - } - Continue; - } - Case(i_CONST_INTEGER): - { - StgPtr p; - int n; - char* s = bcoConstAddr(bco,BCO_INSTR_8); - SSS; - n = size_fromStr(s); - p = CreateByteArrayToHoldInteger(n); - do_fromStr ( s, n, IntegerInsideByteArray(p)); - SloppifyIntegerEnd(p); - LLL; - xPushPtr(p); - Continue; - } - Case(i_VAR_WORD): - { - StgWord w = xTaggedStackWord(BCO_INSTR_8); - xPushTaggedWord(w); - Continue; - } - Case(i_CONST_WORD): - { - xPushTaggedWord(bcoConstWord(bco,BCO_INSTR_8)); - Continue; - } - Case(i_CONST_WORD_big): - { - StgWord n = BCO_INSTR_16; - xPushTaggedWord(bcoConstWord(bco,n)); - Continue; - } - Case(i_PACK_WORD): - { - StgClosure* o; - SSS; o = (StgClosure*)grabHpNonUpd(Wzh_sizeW); LLL; - SET_HDR(o,Wzh_con_info,??); - payloadWord(o,0) = xPopTaggedWord(); - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - SSS; - printObj(stgCast(StgClosure*,o)); - LLL; - ); - xPushPtr(stgCast(StgPtr,o)); - Continue; - } - Case(i_UNPACK_WORD): - { - StgClosure* con = stgCast(StgClosure*,xStackPtr(0)); - /* ASSERT(isWordLike(con)); */ - xPushTaggedWord(payloadWord(con,0)); - Continue; - } - Case(i_VAR_ADDR): - { - StgAddr a = xTaggedStackAddr(BCO_INSTR_8); - xPushTaggedAddr(a); - Continue; - } - Case(i_CONST_ADDR): - { - xPushTaggedAddr(bcoConstAddr(bco,BCO_INSTR_8)); - Continue; - } - Case(i_CONST_ADDR_big): - { - int n = BCO_INSTR_16; - xPushTaggedAddr(bcoConstAddr(bco,n)); - Continue; - } - Case(i_PACK_ADDR): - { - StgClosure* o; - SSS; o = (StgClosure*)grabHpNonUpd(Azh_sizeW); LLL; - SET_HDR(o,Azh_con_info,??); - payloadPtr(o,0) = xPopTaggedAddr(); - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - SSS; - printObj(stgCast(StgClosure*,o)); - LLL; - ); - xPushPtr(stgCast(StgPtr,o)); - Continue; - } - Case(i_UNPACK_ADDR): - { - StgClosure* con = (StgClosure*)xStackPtr(0); - /* ASSERT(isAddrLike(con)); */ - xPushTaggedAddr(payloadPtr(con,0)); - Continue; - } - Case(i_VAR_CHAR): - { - StgChar c = xTaggedStackChar(BCO_INSTR_8); - xPushTaggedChar(c); - Continue; - } - Case(i_CONST_CHAR): - { - xPushTaggedChar(bcoConstChar(bco,BCO_INSTR_8)); - Continue; - } - Case(i_PACK_CHAR): - { - StgClosure* o; - SSS; o = (StgClosure*)grabHpNonUpd(Czh_sizeW); LLL; - SET_HDR(o,Czh_con_info,??); - payloadWord(o,0) = xPopTaggedChar(); - xPushPtr(stgCast(StgPtr,o)); - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - SSS; - printObj(stgCast(StgClosure*,o)); - LLL; - ); - Continue; - } - Case(i_UNPACK_CHAR): - { - StgClosure* con = stgCast(StgClosure*,xStackPtr(0)); - /* ASSERT(isCharLike(con)); */ - xPushTaggedChar(payloadWord(con,0)); - Continue; - } - Case(i_VAR_FLOAT): - { - StgFloat f = xTaggedStackFloat(BCO_INSTR_8); - xPushTaggedFloat(f); - Continue; - } - Case(i_CONST_FLOAT): - { - xPushTaggedFloat(bcoConstFloat(bco,BCO_INSTR_8)); - Continue; - } - Case(i_PACK_FLOAT): - { - StgClosure* o; - SSS; o = (StgClosure*)grabHpNonUpd(Fzh_sizeW); LLL; - SET_HDR(o,Fzh_con_info,??); - ASSIGN_FLT(&payloadWord(o,0),xPopTaggedFloat()); - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - SSS; - printObj(stgCast(StgClosure*,o)); - LLL; - ); - xPushPtr(stgCast(StgPtr,o)); - Continue; - } - Case(i_UNPACK_FLOAT): - { - StgClosure* con = stgCast(StgClosure*,xStackPtr(0)); - /* ASSERT(isFloatLike(con)); */ - xPushTaggedFloat(PK_FLT(&payloadWord(con,0))); - Continue; - } - Case(i_VAR_DOUBLE): - { - StgDouble d = xTaggedStackDouble(BCO_INSTR_8); - xPushTaggedDouble(d); - Continue; - } - Case(i_CONST_DOUBLE): - { - xPushTaggedDouble(bcoConstDouble(bco,BCO_INSTR_8)); - Continue; - } - Case(i_CONST_DOUBLE_big): - { - int n = BCO_INSTR_16; - xPushTaggedDouble(bcoConstDouble(bco,n)); - Continue; - } - Case(i_PACK_DOUBLE): - { - StgClosure* o; - SSS; o = (StgClosure*)grabHpNonUpd(Dzh_sizeW); LLL; - SET_HDR(o,Dzh_con_info,??); - ASSIGN_DBL(&payloadWord(o,0),xPopTaggedDouble()); - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - printObj(stgCast(StgClosure*,o)); - ); - xPushPtr(stgCast(StgPtr,o)); - Continue; - } - Case(i_UNPACK_DOUBLE): - { - StgClosure* con = stgCast(StgClosure*,xStackPtr(0)); - /* ASSERT(isDoubleLike(con)); */ - xPushTaggedDouble(PK_DBL(&payloadWord(con,0))); - Continue; - } - Case(i_VAR_STABLE): - { - StgStablePtr s = xTaggedStackStable(BCO_INSTR_8); - xPushTaggedStable(s); - Continue; - } - Case(i_PACK_STABLE): - { - StgClosure* o; - SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL; - SET_HDR(o,StablePtr_con_info,??); - payloadWord(o,0) = (W_)xPopTaggedStable(); - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - SSS; - printObj(stgCast(StgClosure*,o)); - LLL; - ); - xPushPtr(stgCast(StgPtr,o)); - Continue; - } - Case(i_UNPACK_STABLE): - { - StgClosure* con = (StgClosure*)xStackPtr(0); - /* ASSERT(isStableLike(con)); */ - xPushTaggedStable(payloadWord(con,0)); - Continue; - } - Case(i_PRIMOP1): - { - int i; - void* p; - i = BCO_INSTR_8; - SSS; p = enterBCO_primop1 ( i ); LLL; - if (p) { obj = p; goto enterLoop; }; - Continue; - } - Case(i_PRIMOP2): - { - int i, trc, pc_saved; - void* p; - StgBCO* bco_tmp; - trc = 12345678; /* Assume != any StgThreadReturnCode */ - i = BCO_INSTR_8; - pc_saved = PC; - bco_tmp = bco; - SSS; - p = enterBCO_primop2 ( i, &trc, &bco_tmp, cap, - &hugsBlock ); - LLL; - bco = bco_tmp; - bciPtr = &(bcoInstr(bco,pc_saved)); - if (p) { - if (trc == 12345678) { - /* we want to enter p */ - obj = p; goto enterLoop; - } else { - /* trc is the the StgThreadReturnCode for - * this thread */ - RETURN((StgThreadReturnCode)trc); - }; - } - Continue; - } - - /* combined insns, created by peephole opt */ - Case(i_SE): - { - int x = BCO_INSTR_8; - int y = BCO_INSTR_8; - ASSERT(xSp+x+y <= stgCast(StgPtr,xSu)); - /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */ - if (x == 1) { - obj = xPopCPtr(); - xSp += y; - goto enterLoop; - } else { - while(--x >= 0) { - xSetStackWord(x+y,xStackWord(x)); - } - xSp += y; - obj = xPopCPtr(); - } - goto enterLoop; - } - Case(i_VV): - { - StgPtr p; - p = xStackPtr(BCO_INSTR_8); - xPushPtr(p); - p = xStackPtr(BCO_INSTR_8); - xPushPtr(p); - Continue; - } - Case(i_RV): - { - StgPtr p; - xPushPtr(bcoConstPtr(bco,BCO_INSTR_8)); - xPushPtr(stgCast(StgPtr,&ret_bco_info)); - p = xStackPtr(BCO_INSTR_8); - xPushPtr(p); - Continue; - } - Case(i_RVE): - { - StgPtr retaddr = bcoConstPtr(bco,BCO_INSTR_8); - StgPtr ptr = xStackPtr(BCO_INSTR_8); - - /* A shortcut. We're going to push the address of a - return continuation, and then enter a variable, so - that when the var is evaluated, we return to the - continuation. The shortcut is: if the var is a - constructor, don't bother to enter it. Instead, - push the variable on the stack (since this is what - the continuation expects) and jump directly to the - continuation. - */ - if (get_itbl((StgClosure*)ptr)->type == CONSTR) { - xPushPtr(ptr); - obj = (StgClosure*)retaddr; - IF_DEBUG(evaluator, - fprintf(stderr, "object to enter is a constructor -- " - "jumping directly to return continuation\n" ); - ); - goto bco_entry; - } - - /* This is the normal, non-short-cut route */ - xPushPtr(retaddr); - xPushPtr(stgCast(StgPtr,&ret_bco_info)); - obj = (StgClosure*)ptr; - goto enterLoop; - } - - - Case(i_VAR_DOUBLE_big): - Case(i_CONST_FLOAT_big): - Case(i_VAR_FLOAT_big): - Case(i_CONST_CHAR_big): - Case(i_VAR_CHAR_big): - Case(i_VAR_ADDR_big): - Case(i_VAR_STABLE_big): - Case(i_CONST_INTEGER_big): - Case(i_VAR_INT_big): - Case(i_VAR_WORD_big): - Case(i_RETADDR_big): - Case(i_ALLOC_PAP): -#ifndef XMLAMBDA - Case(i_UNPACK_INJ): - Case(i_UNPACK_ROW): - Case(i_TEST_INJ_CONST): - Case(i_TEST_INJ_big): - Case(i_TEST_INJ): - Case(i_PACK_INJ_CONST): - Case(i_PACK_INJ_big): - Case(i_PACK_INJ): - Case(i_PACK_ROW_big): - Case(i_PACK_ROW): - Case(i_ALLOC_ROW_big): - Case(i_ALLOC_ROW): -#endif - bciPtr--; - printf ( "\n\n" ); - disInstr ( bco, PC ); - barf("\nUnrecognised instruction"); - - EndDispatch - - barf("enterBCO: ran off end of loop"); - break; - } - -# undef LoopTopLabel -# undef Case -# undef Continue -# undef Dispatch -# undef EndDispatch - - /* ---------------------------------------------------- */ - /* End of the bytecode evaluator */ - /* ---------------------------------------------------- */ - - case CAF_UNENTERED: - { - StgBlockingQueue* bh; - StgCAF* caf = (StgCAF*)obj; - if (xSp - sizeofW(StgUpdateFrame) < xSpLim) { - xPushCPtr(obj); /* code to restart with */ - RETURN(StackOverflow); - } - 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)); - SET_INFO(caf,&CAF_ENTERED_info); - caf->value = (StgClosure*)bh; - - SSS; newCAF_made_by_Hugs(caf); LLL; - - xPushUpdateFrame(bh,0); - xSp -= sizeofW(StgUpdateFrame); - obj = caf->body; - goto enterLoop; - } - case CAF_ENTERED: - { - StgCAF* caf = (StgCAF*)obj; - obj = caf->value; /* it's just a fancy indirection */ - goto enterLoop; - } - case BLACKHOLE: - case SE_BLACKHOLE: - case CAF_BLACKHOLE: - case SE_CAF_BLACKHOLE: - { - /* Let the scheduler figure out what to do :-) */ - cap->rCurrentTSO->what_next = ThreadEnterGHC; - xPushCPtr(obj); - RETURN(ThreadYielding); - } - case AP_UPD: - { - StgAP_UPD* ap = stgCast(StgAP_UPD*,obj); - int i = ap->n_args; - if (xSp - (i + sizeofW(StgUpdateFrame)) < xSpLim) { - xPushCPtr(obj); /* code to restart with */ - RETURN(StackOverflow); - } - /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME - and insert an indirection immediately */ - xPushUpdateFrame(ap,0); - xSp -= sizeofW(StgUpdateFrame); - while (--i >= 0) { - xPushWord(payloadWord(ap,i)); - } - obj = ap->fun; -#ifdef EAGER_BLACKHOLING -#warn LAZY_BLACKHOLING is default for StgHugs -#error Dont know if EAGER_BLACKHOLING works in StgHugs - { - /* superfluous - but makes debugging easier */ - StgBlackHole* bh = stgCast(StgBlackHole*,ap); - SET_INFO(bh,&BLACKHOLE_info); - bh->blocking_queue = EndTSOQueue; - IF_DEBUG(gccafs, - fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh)); - /* printObj(bh); */ - } -#endif /* EAGER_BLACKHOLING */ - goto enterLoop; - } - case PAP: - { - StgPAP* pap = stgCast(StgPAP*,obj); - int i = pap->n_args; /* ToDo: stack check */ - /* ToDo: if PAP is in whnf, we can update any update frames - * on top of stack. - */ - while (--i >= 0) { - xPushWord(payloadWord(pap,i)); - } - obj = pap->fun; - goto enterLoop; - } - case IND: - { - obj = stgCast(StgInd*,obj)->indirectee; - goto enterLoop; - } - case IND_OLDGEN: - { - obj = stgCast(StgIndOldGen*,obj)->indirectee; - goto enterLoop; - } - case CONSTR: - case CONSTR_1_0: - case CONSTR_0_1: - case CONSTR_2_0: - case CONSTR_1_1: - case CONSTR_0_2: - case CONSTR_INTLIKE: - case CONSTR_CHARLIKE: - case CONSTR_STATIC: - case CONSTR_NOCAF_STATIC: -#ifdef XMLAMBDA -/* rows are mutarrays and should be treated as constructors. */ - case MUT_ARR_PTRS_FROZEN: -#endif - { - while (1) { - switch (get_itbl(stgCast(StgClosure*,xSp))->type) { - case CATCH_FRAME: - SSS; PopCatchFrame(); LLL; - break; - case UPDATE_FRAME: - xPopUpdateFrame(obj); - break; - case SEQ_FRAME: - SSS; PopSeqFrame(); LLL; - break; - case STOP_FRAME: - { - ASSERT(xSp==(P_)xSu); - IF_DEBUG(evaluator, - SSS; - fprintf(stderr, "hit a STOP_FRAME\n"); - printObj(obj); - fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu); - printStack(xSp,cap->rCurrentTSO->stack - + cap->rCurrentTSO->stack_size,xSu); - LLL; - ); - cap->rCurrentTSO->what_next = ThreadComplete; - SSS; PopStopFrame(obj); LLL; - xPushPtr((P_)obj); - RETURN(ThreadFinished); - } - case RET_BCO: - { - StgClosure* ret; - (void)xPopPtr(); - ret = xPopCPtr(); - xPushPtr((P_)obj); - obj = ret; - goto bco_entry; - /* was: goto enterLoop; - But we know that obj must be a bco now, so jump directly. - */ - } - case RET_SMALL: /* return to GHC */ - case RET_VEC_SMALL: - case RET_BIG: - case RET_VEC_BIG: - cap->rCurrentTSO->what_next = ThreadEnterGHC; - xPushCPtr(obj); - RETURN(ThreadYielding); - default: - belch("entered CONSTR with invalid continuation on stack"); - IF_DEBUG(evaluator, - SSS; - printObj(stgCast(StgClosure*,xSp)); - LLL; - ); - barf("bailing out"); - } - } - } - default: - { - //SSS; - //fprintf(stderr, "enterCountI = %d\n", enterCountI); - //fprintf(stderr, "entering unknown closure -- yielding to sched\n"); - //printObj(obj); - //LLL; - cap->rCurrentTSO->what_next = ThreadEnterGHC; - xPushCPtr(obj); /* code to restart with */ - RETURN(ThreadYielding); - } - } - barf("Ran off the end of enter - yoiks"); - ASSERT(0); -} - -#undef RETURN -#undef BCO_INSTR_8 -#undef BCO_INSTR_16 -#undef SSS -#undef LLL -#undef PC -#undef xPushPtr -#undef xPopPtr -#undef xPushCPtr -#undef xPopCPtr -#undef xPopWord -#undef xStackPtr -#undef xStackWord -#undef xSetStackWord -#undef xPushTag -#undef xPopTag -#undef xPushTaggedInt -#undef xPopTaggedInt -#undef xTaggedStackInt -#undef xPushTaggedWord -#undef xPopTaggedWord -#undef xTaggedStackWord -#undef xPushTaggedAddr -#undef xTaggedStackAddr -#undef xPopTaggedAddr -#undef xPushTaggedStable -#undef xTaggedStackStable -#undef xPopTaggedStable -#undef xPushTaggedChar -#undef xTaggedStackChar -#undef xPopTaggedChar -#undef xPushTaggedFloat -#undef xTaggedStackFloat -#undef xPopTaggedFloat -#undef xPushTaggedDouble -#undef xTaggedStackDouble -#undef xPopTaggedDouble -#undef xPopUpdateFrame -#undef xPushUpdateFrame - - -/* -------------------------------------------------------------------------- - * Supporting routines for primops - * ------------------------------------------------------------------------*/ +#define LOAD_STACK_POINTERS \ + iSp = cap->r.rCurrentTSO->sp; \ + iSu = cap->r.rCurrentTSO->su; \ + /* We don't change this ... */ \ + iSpLim = cap->r.rCurrentTSO->stack + RESERVED_STACK_WORDS; -static inline void PushTag ( StackTag t ) - { *(--gSp) = t; } - inline void PushPtr ( StgPtr x ) - { *(--stgCast(StgPtr*,gSp)) = x; } -static inline void PushCPtr ( StgClosure* x ) - { *(--stgCast(StgClosure**,gSp)) = x; } -static inline void PushInt ( StgInt x ) - { *(--stgCast(StgInt*,gSp)) = x; } -static inline void PushWord ( StgWord x ) - { *(--stgCast(StgWord*,gSp)) = x; } - - -static inline void checkTag ( StackTag t1, StackTag t2 ) - { ASSERT(t1 == t2);} -static inline void PopTag ( StackTag t ) - { checkTag(t,*(gSp++)); } - inline StgPtr PopPtr ( void ) - { return *stgCast(StgPtr*,gSp)++; } -static inline StgClosure* PopCPtr ( void ) - { return *stgCast(StgClosure**,gSp)++; } -static inline StgInt PopInt ( void ) - { return *stgCast(StgInt*,gSp)++; } -static inline StgWord PopWord ( void ) - { return *stgCast(StgWord*,gSp)++; } - -static inline StgPtr stackPtr ( StgStackOffset i ) - { return *stgCast(StgPtr*, gSp+i); } -static inline StgInt stackInt ( StgStackOffset i ) - { return *stgCast(StgInt*, gSp+i); } -static inline StgWord stackWord ( StgStackOffset i ) - { return *stgCast(StgWord*,gSp+i); } - -static inline void setStackWord ( StgStackOffset i, StgWord w ) - { gSp[i] = w; } - -#ifdef XMLAMBDA -static inline void setStackPtr ( StgStackOffset i, StgPtr p ) - { *(stgCast(StgPtr*, gSp+i)) = p; } -#endif -static inline void PushTaggedRealWorld( void ) - { PushTag(REALWORLD_TAG); } - inline void PushTaggedInt ( StgInt x ) - { gSp -= sizeofW(StgInt); *gSp = x; PushTag(INT_TAG); } - inline void PushTaggedWord ( StgWord x ) - { gSp -= sizeofW(StgWord); *gSp = x; PushTag(WORD_TAG); } - inline void PushTaggedAddr ( StgAddr x ) - { gSp -= sizeofW(StgAddr); *gSp = (W_)x; PushTag(ADDR_TAG); } - inline void PushTaggedChar ( StgChar x ) - { gSp -= sizeofW(StgChar); *gSp = stgCast(StgWord,x); PushTag(CHAR_TAG); } - inline void PushTaggedFloat ( StgFloat x ) - { gSp -= sizeofW(StgFloat); ASSIGN_FLT(gSp,x); PushTag(FLOAT_TAG); } - inline void PushTaggedDouble ( StgDouble x ) - { gSp -= sizeofW(StgDouble); ASSIGN_DBL(gSp,x); PushTag(DOUBLE_TAG); } - inline void PushTaggedStablePtr ( StgStablePtr x ) - { gSp -= sizeofW(StgStablePtr); *gSp = (W_)x; PushTag(STABLE_TAG); } -static inline void PushTaggedBool ( int x ) - { PushTaggedInt(x); } - - - -static inline void PopTaggedRealWorld ( void ) - { PopTag(REALWORLD_TAG); } - inline StgInt PopTaggedInt ( void ) - { 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*, gSp); - gSp += sizeofW(StgWord); return r;} - inline StgAddr PopTaggedAddr ( void ) - { 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, *gSp); - gSp += sizeofW(StgChar); return r;} - inline StgFloat PopTaggedFloat ( void ) - { 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(gSp); - gSp += sizeofW(StgDouble); return r;} - inline StgStablePtr PopTaggedStablePtr ( void ) - { StgStablePtr r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, gSp); - gSp += sizeofW(StgStablePtr); return r;} - - - -static inline StgInt taggedStackInt ( StgStackOffset i ) - { checkTag(INT_TAG,gSp[i]); return *stgCast(StgInt*, gSp+1+i); } -static inline StgWord taggedStackWord ( StgStackOffset i ) - { checkTag(WORD_TAG,gSp[i]); return *stgCast(StgWord*, gSp+1+i); } -static inline StgAddr taggedStackAddr ( StgStackOffset i ) - { checkTag(ADDR_TAG,gSp[i]); return *stgCast(StgAddr*, gSp+1+i); } -static inline StgChar taggedStackChar ( StgStackOffset i ) - { checkTag(CHAR_TAG,gSp[i]); return stgCast(StgChar, *(gSp+1+i)) ; } -static inline StgFloat taggedStackFloat ( StgStackOffset i ) - { checkTag(FLOAT_TAG,gSp[i]); return PK_FLT(gSp+1+i); } -static inline StgDouble taggedStackDouble ( StgStackOffset i ) - { checkTag(DOUBLE_TAG,gSp[i]); return PK_DBL(gSp+1+i); } -static inline StgStablePtr taggedStackStable ( StgStackOffset i ) - { checkTag(STABLE_TAG,gSp[i]); return *stgCast(StgStablePtr*, gSp+1+i); } +#define SAVE_STACK_POINTERS \ + cap->r.rCurrentTSO->sp = iSp; \ + cap->r.rCurrentTSO->su = iSu; +#define RETURN(retcode) \ + SAVE_STACK_POINTERS; return retcode; -/* -------------------------------------------------------------------------- - * Heap allocation - * - * Should we allocate from a nursery or use the - * doYouWantToGC/allocate interface? We'd already implemented a - * nursery-style scheme when the doYouWantToGC/allocate interface - * was implemented. - * One reason to prefer the doYouWantToGC/allocate interface is to - * support operations which allocate an unknown amount in the heap - * (array ops, gmp ops, etc) - * ------------------------------------------------------------------------*/ -static inline StgPtr grabHpUpd( nat size ) +static __inline__ StgPtr allocate_UPD ( int n_words ) { - ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) ); - return allocate(size); + if (n_words - sizeofW(StgHeader) < MIN_UPD_SIZE) + n_words = MIN_UPD_SIZE + sizeofW(StgHeader); + return allocate(n_words); } -static inline StgPtr grabHpNonUpd( nat size ) +static __inline__ StgPtr allocate_NONUPD ( int n_words ) { - ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) ); - return allocate(size); + if (n_words - sizeofW(StgHeader) < MIN_NONUPD_SIZE) + n_words = MIN_NONUPD_SIZE + sizeofW(StgHeader); + return allocate(n_words); } -/* -------------------------------------------------------------------------- - * Manipulate "update frame" list: - * o Update frames (based on stg_do_update and friends in Updates.hc) - * o Error handling/catching (based on catchzh_fast and friends in Prims.hc) - * o Seq frames (based on seq_frame_entry in Prims.hc) - * o Stop frames - * ------------------------------------------------------------------------*/ -static inline void PopUpdateFrame ( StgClosure* obj ) -{ - /* NB: doesn't assume that gSp == gSu */ - IF_DEBUG(evaluator, - fprintf(stderr, "Updating "); - printPtr(stgCast(StgPtr,gSu->updatee)); - fprintf(stderr, " with "); - printObj(obj); - 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(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(gSu->updatee,obj); - gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame); - gSu = gSu->link; -} +#ifdef INTERP_STATS +/* Hacky stats, for tuning the interpreter ... */ +int it_unknown_entries[N_CLOSURE_TYPES]; +int it_total_unknown_entries; +int it_total_entries; -static inline void PopStopFrame ( StgClosure* obj ) -{ - /* Move gSu just off the end of the stack, we're about to gSpam the - * STOP_FRAME with the return value. - */ - gSu = stgCast(StgUpdateFrame*,gSp+1); - *stgCast(StgClosure**,gSp) = obj; -} +int it_retto_BCO; +int it_retto_UPDATE; +int it_retto_other; -static inline void PushCatchFrame ( StgClosure* handler ) -{ - StgCatchFrame* fp; - /* ToDo: stack check! */ - gSp -= sizeofW(StgCatchFrame); - fp = stgCast(StgCatchFrame*,gSp); - SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS); - fp->handler = handler; - fp->link = gSu; - gSu = stgCast(StgUpdateFrame*,fp); -} - -static inline void PopCatchFrame ( void ) -{ - /* NB: doesn't assume that gSp == gSu */ - /* fprintf(stderr,"Popping catch frame\n"); */ - gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgCatchFrame); - gSu = stgCast(StgCatchFrame*,gSu)->link; -} +int it_slides; +int it_insns; +int it_BCO_entries; -static inline void PushSeqFrame ( void ) -{ - StgSeqFrame* fp; - /* ToDo: stack check! */ - gSp -= sizeofW(StgSeqFrame); - fp = stgCast(StgSeqFrame*,gSp); - SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS); - fp->link = gSu; - gSu = stgCast(StgUpdateFrame*,fp); -} +int it_ofreq[27]; +int it_oofreq[27][27]; +int it_lastopc; -static inline void PopSeqFrame ( void ) +void interp_startup ( void ) { - /* NB: doesn't assume that gSp == gSu */ - gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgSeqFrame); - gSu = stgCast(StgSeqFrame*,gSu)->link; -} - -static inline StgClosure* raiseAnError ( StgClosure* exception ) + int i, j; + it_retto_BCO = it_retto_UPDATE = it_retto_other = 0; + it_total_entries = it_total_unknown_entries = 0; + for (i = 0; i < N_CLOSURE_TYPES; i++) + it_unknown_entries[i] = 0; + it_slides = it_insns = it_BCO_entries = 0; + for (i = 0; i < 27; i++) it_ofreq[i] = 0; + for (i = 0; i < 27; i++) + for (j = 0; j < 27; j++) + it_oofreq[i][j] = 0; + it_lastopc = 0; +} + +void interp_shutdown ( void ) { - /* 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. - */ - HaskellObj primRaiseClosure - = getHugs_BCO_cptr_for("primRaise"); - HaskellObj reraiseClosure - = rts_apply ( primRaiseClosure, exception ); - - while (1) { - switch (get_itbl(gSu)->type) { - case UPDATE_FRAME: - 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*,gSu); - StgClosure *handler = fp->handler; - gSu = fp->link; - gSp += sizeofW(StgCatchFrame); /* Pop */ - PushCPtr(exception); - return handler; + int i, j, k, o_max, i_max, j_max; + fprintf(stderr, "%d constrs entered -> (%d BCO, %d UPD, %d ??? )\n", + it_retto_BCO + it_retto_UPDATE + it_retto_other, + it_retto_BCO, it_retto_UPDATE, it_retto_other ); + fprintf(stderr, "%d total entries, %d unknown entries \n", + it_total_entries, it_total_unknown_entries); + for (i = 0; i < N_CLOSURE_TYPES; i++) { + if (it_unknown_entries[i] == 0) continue; + fprintf(stderr, " type %2d: unknown entries (%4.1f%%) == %d\n", + i, 100.0 * ((double)it_unknown_entries[i]) / + ((double)it_total_unknown_entries), + it_unknown_entries[i]); + } + fprintf(stderr, "%d insns, %d slides, %d BCO_entries\n", + it_insns, it_slides, it_BCO_entries); + for (i = 0; i < 27; i++) + fprintf(stderr, "opcode %2d got %d\n", i, it_ofreq[i] ); + + for (k = 1; k < 20; k++) { + o_max = 0; + i_max = j_max = 0; + for (i = 0; i < 27; i++) { + for (j = 0; j < 27; j++) { + if (it_oofreq[i][j] > o_max) { + o_max = it_oofreq[i][j]; + i_max = i; j_max = j; } - case STOP_FRAME: - barf("raiseError: uncaught exception: STOP_FRAME"); - default: - barf("raiseError: weird activation record"); - } - } + } + } + + fprintf ( stderr, "%d: count (%4.1f%%) %6d is %d then %d\n", + k, ((double)o_max) * 100.0 / ((double)it_insns), o_max, + i_max, j_max ); + it_oofreq[i_max][j_max] = 0; + + } } +#endif -static StgClosure* makeErrorCall ( const char* msg ) +StgThreadReturnCode interpretBCO ( Capability* cap ) { - /* Note! the msg string should be allocated in a - place which will not get freed -- preferably - read-only data of the program. That's because - the thunk we build here may linger indefinitely. - (thinks: probably not so, but anyway ...) + /* On entry, the closure to interpret is on the top of the + stack. */ + + /* Use of register here is primarily to make it clear to compilers + that these entities are non-aliasable. */ - HaskellObj error - = getHugs_BCO_cptr_for("error"); - HaskellObj unpack - = getHugs_BCO_cptr_for("hugsprimUnpackString"); - HaskellObj thunk - = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) ); - thunk - = rts_apply ( error, thunk ); - return - (StgClosure*) thunk; -} - -#define raiseIndex(where) makeErrorCall("Array index out of range in " where) -#define raiseDiv0(where) makeErrorCall("Division by zero in " where) - -/* -------------------------------------------------------------------------- - * Evaluator - * ------------------------------------------------------------------------*/ - -#define OP_CC_B(e) \ -{ \ - unsigned char x = PopTaggedChar(); \ - unsigned char y = PopTaggedChar(); \ - PushTaggedBool(e); \ -} - -#define OP_C_I(e) \ -{ \ - unsigned char x = PopTaggedChar(); \ - PushTaggedInt(e); \ -} - -#define OP__I(e) \ -{ \ - PushTaggedInt(e); \ -} - -#define OP_IW_I(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - StgWord y = PopTaggedWord(); \ - PushTaggedInt(e); \ -} + register W_* iSp; /* local state -- stack pointer */ + register StgUpdateFrame* iSu; /* local state -- frame pointer */ + register StgPtr iSpLim; /* local state -- stack lim pointer */ + register StgClosure* obj; -#define OP_II_I(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - StgInt y = PopTaggedInt(); \ - PushTaggedInt(e); \ -} - -#define OP_II_B(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - StgInt y = PopTaggedInt(); \ - PushTaggedBool(e); \ -} - -#define OP__A(e) \ -{ \ - PushTaggedAddr(e); \ -} - -#define OP_I_A(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - PushTaggedAddr(e); \ -} - -#define OP_I_I(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - PushTaggedInt(e); \ -} - -#define OP__C(e) \ -{ \ - PushTaggedChar(e); \ -} - -#define OP_I_C(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - PushTaggedChar(e); \ -} - -#define OP__W(e) \ -{ \ - PushTaggedWord(e); \ -} - -#define OP_I_W(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - PushTaggedWord(e); \ -} - -#define OP_I_s(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - PushTaggedStablePtr(e); \ -} - -#define OP__F(e) \ -{ \ - PushTaggedFloat(e); \ -} + LOAD_STACK_POINTERS; -#define OP_I_F(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - PushTaggedFloat(e); \ -} - -#define OP__D(e) \ -{ \ - PushTaggedDouble(e); \ -} + /* Main object-entering loop. Object to be entered is on top of + stack. */ + nextEnter: -#define OP_I_D(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - PushTaggedDouble(e); \ -} + obj = (StgClosure*)StackWord(0); iSp++; -#define OP_WW_B(e) \ -{ \ - StgWord x = PopTaggedWord(); \ - StgWord y = PopTaggedWord(); \ - PushTaggedBool(e); \ -} + nextEnter_obj: -#define OP_WW_W(e) \ -{ \ - StgWord x = PopTaggedWord(); \ - StgWord y = PopTaggedWord(); \ - PushTaggedWord(e); \ -} +# ifdef INTERP_STATS + it_total_entries++; +# endif -#define OP_W_I(e) \ -{ \ - StgWord x = PopTaggedWord(); \ - PushTaggedInt(e); \ -} - -#define OP_s_I(e) \ -{ \ - StgStablePtr x = PopTaggedStablePtr(); \ - PushTaggedInt(e); \ -} - -#define OP_W_W(e) \ -{ \ - StgWord x = PopTaggedWord(); \ - PushTaggedWord(e); \ -} - -#define OP_AA_B(e) \ -{ \ - StgAddr x = PopTaggedAddr(); \ - StgAddr y = PopTaggedAddr(); \ - PushTaggedBool(e); \ -} -#define OP_A_I(e) \ -{ \ - StgAddr x = PopTaggedAddr(); \ - PushTaggedInt(e); \ -} -#define OP_AI_C(s) \ -{ \ - StgAddr x = PopTaggedAddr(); \ - int y = PopTaggedInt(); \ - StgChar r; \ - s; \ - PushTaggedChar(r); \ -} -#define OP_AI_I(s) \ -{ \ - StgAddr x = PopTaggedAddr(); \ - int y = PopTaggedInt(); \ - StgInt r; \ - s; \ - PushTaggedInt(r); \ -} -#define OP_AI_A(s) \ -{ \ - StgAddr x = PopTaggedAddr(); \ - int y = PopTaggedInt(); \ - StgAddr r; \ - s; \ - PushTaggedAddr(s); \ -} -#define OP_AI_F(s) \ -{ \ - StgAddr x = PopTaggedAddr(); \ - int y = PopTaggedInt(); \ - StgFloat r; \ - s; \ - PushTaggedFloat(r); \ -} -#define OP_AI_D(s) \ -{ \ - StgAddr x = PopTaggedAddr(); \ - int y = PopTaggedInt(); \ - StgDouble r; \ - s; \ - PushTaggedDouble(r); \ -} -#define OP_AI_s(s) \ -{ \ - StgAddr x = PopTaggedAddr(); \ - int y = PopTaggedInt(); \ - StgStablePtr r; \ - s; \ - PushTaggedStablePtr(r); \ -} -#define OP_AIC_(s) \ -{ \ - StgAddr x = PopTaggedAddr(); \ - int y = PopTaggedInt(); \ - StgChar z = PopTaggedChar(); \ - s; \ -} -#define OP_AII_(s) \ -{ \ - StgAddr x = PopTaggedAddr(); \ - int y = PopTaggedInt(); \ - StgInt z = PopTaggedInt(); \ - s; \ -} -#define OP_AIA_(s) \ -{ \ - StgAddr x = PopTaggedAddr(); \ - int y = PopTaggedInt(); \ - StgAddr z = PopTaggedAddr(); \ - s; \ -} -#define OP_AIF_(s) \ -{ \ - StgAddr x = PopTaggedAddr(); \ - int y = PopTaggedInt(); \ - StgFloat z = PopTaggedFloat(); \ - s; \ -} -#define OP_AID_(s) \ -{ \ - StgAddr x = PopTaggedAddr(); \ - int y = PopTaggedInt(); \ - StgDouble z = PopTaggedDouble(); \ - s; \ -} -#define OP_AIs_(s) \ -{ \ - StgAddr x = PopTaggedAddr(); \ - int y = PopTaggedInt(); \ - StgStablePtr z = PopTaggedStablePtr(); \ - s; \ -} - - -#define OP_FF_B(e) \ -{ \ - StgFloat x = PopTaggedFloat(); \ - StgFloat y = PopTaggedFloat(); \ - PushTaggedBool(e); \ -} - -#define OP_FF_F(e) \ -{ \ - StgFloat x = PopTaggedFloat(); \ - StgFloat y = PopTaggedFloat(); \ - PushTaggedFloat(e); \ -} - -#define OP_F_F(e) \ -{ \ - StgFloat x = PopTaggedFloat(); \ - PushTaggedFloat(e); \ -} - -#define OP_F_B(e) \ -{ \ - StgFloat x = PopTaggedFloat(); \ - PushTaggedBool(e); \ -} - -#define OP_F_I(e) \ -{ \ - StgFloat x = PopTaggedFloat(); \ - PushTaggedInt(e); \ -} - -#define OP_F_D(e) \ -{ \ - StgFloat x = PopTaggedFloat(); \ - PushTaggedDouble(e); \ -} - -#define OP_DD_B(e) \ -{ \ - StgDouble x = PopTaggedDouble(); \ - StgDouble y = PopTaggedDouble(); \ - PushTaggedBool(e); \ -} - -#define OP_DD_D(e) \ -{ \ - StgDouble x = PopTaggedDouble(); \ - StgDouble y = PopTaggedDouble(); \ - PushTaggedDouble(e); \ -} - -#define OP_D_B(e) \ -{ \ - StgDouble x = PopTaggedDouble(); \ - PushTaggedBool(e); \ -} - -#define OP_D_D(e) \ -{ \ - StgDouble x = PopTaggedDouble(); \ - PushTaggedDouble(e); \ -} - -#define OP_D_I(e) \ -{ \ - StgDouble x = PopTaggedDouble(); \ - PushTaggedInt(e); \ -} - -#define OP_D_F(e) \ -{ \ - StgDouble x = PopTaggedDouble(); \ - PushTaggedFloat(e); \ -} - - -StgPtr CreateByteArrayToHoldInteger ( int nbytes ) -{ - StgWord words = (nbytes+sizeof(W_)-1)/sizeof(W_); - StgWord size = sizeofW(StgArrWords) + words; - StgArrWords* arr = (StgArrWords*)allocate(size); - SET_HDR(arr,&ARR_WORDS_info,CCCS); - arr->words = words; - ASSERT((W_)nbytes <= arr->words * sizeof(W_)); -#ifdef DEBUG - {StgWord i; - for (i = 0; i < words; ++i) { - arr->payload[i] = 0xdeadbeef; - }} - { B* b = (B*) &(arr->payload[0]); - b->used = b->sign = 0; - } -#endif - return (StgPtr)arr; -} - -B* IntegerInsideByteArray ( StgPtr arr0 ) -{ - B* b; - StgArrWords* arr = (StgArrWords*)arr0; - ASSERT(GET_INFO(arr) == &ARR_WORDS_info); - b = (B*) &(arr->payload[0]); - return b; -} + IF_DEBUG(evaluator, + fprintf(stderr, + "\n---------------------------------------------------------------\n"); + fprintf(stderr,"Entering: "); printObj(obj); + fprintf(stderr,"iSp = %p\tiSu = %p\n", iSp, iSu); + fprintf(stderr, "\n" ); -void SloppifyIntegerEnd ( StgPtr arr0 ) -{ - StgArrWords* arr = (StgArrWords*)arr0; - B* b = (B*) & (arr->payload[0]); - I_ nwunused = arr->words - sizeofW(B) - (b->used+sizeof(W_)-1)/sizeof(W_); - if (nwunused >= ((I_)sizeofW(StgArrWords))) { - StgArrWords* slop; - b->size -= nwunused * sizeof(W_); - if (b->size < b->used) b->size = b->used; - do_renormalise(b); - ASSERT(is_sane(b)); - arr->words -= nwunused; - slop = (StgArrWords*)&(arr->payload[arr->words]); - SET_HDR(slop,&ARR_WORDS_info,CCCS); - slop->words = nwunused - sizeofW(StgArrWords); - ASSERT( &(slop->payload[slop->words]) == - &(arr->payload[arr->words + nwunused]) ); - } -} + // checkSanity(1); + // iSp--; StackWord(0) = obj; + // checkStack(iSp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu); + // iSp++; -#define OP_Z_Z(op) \ -{ \ - B* x = IntegerInsideByteArray(PopPtr()); \ - int n = mycat2(size_,op)(x); \ - StgPtr p = CreateByteArrayToHoldInteger(n); \ - mycat2(do_,op)(x,n,IntegerInsideByteArray(p)); \ - SloppifyIntegerEnd(p); \ - PushPtr(p); \ -} -#define OP_ZZ_Z(op) \ -{ \ - B* x = IntegerInsideByteArray(PopPtr()); \ - B* y = IntegerInsideByteArray(PopPtr()); \ - int n = mycat2(size_,op)(x,y); \ - StgPtr p = CreateByteArrayToHoldInteger(n); \ - mycat2(do_,op)(x,y,n,IntegerInsideByteArray(p)); \ - SloppifyIntegerEnd(p); \ - PushPtr(p); \ -} + printStack(iSp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu); + fprintf(stderr, "\n\n"); + ); + switch ( get_itbl(obj)->type ) { -#define HEADER_mI(ty,where) \ - StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \ - nat i = PopTaggedInt(); \ - if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) { \ - return (raiseIndex(where)); \ - } -#define OP_mI_ty(ty,where,s) \ -{ \ - HEADER_mI(mycat2(Stg,ty),where) \ - { mycat2(Stg,ty) r; \ - s; \ - mycat2(PushTagged,ty)(r); \ - } \ -} -#define OP_mIty_(ty,where,s) \ -{ \ - HEADER_mI(mycat2(Stg,ty),where) \ - { \ - mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \ - s; \ - } \ -} + case INVALID_OBJECT: + barf("Invalid object %p",(StgPtr)obj); +# ifndef REFERENCE_INTERPRETER -__attribute__ ((unused)) -static void myStackCheck ( Capability* cap ) -{ - /* fprintf(stderr, "myStackCheck\n"); */ - if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) { - fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" ); - barf("aborting"); - ASSERT(0); - } - while (1) { - if (!( (P_)gSu >= (P_)cap->rCurrentTSO->stack - && - (P_)gSu <= (P_)(cap->rCurrentTSO->stack - + cap->rCurrentTSO->stack_size))) { - fprintf ( stderr, "myStackCheck: gSu out of stack\n" ); - barf("aborting"); - ASSERT(0); - } - switch (get_itbl(stgCast(StgClosure*,gSu))->type) { - case CATCH_FRAME: - gSu = (StgUpdateFrame*) ((StgCatchFrame*)(gSu))->link; - break; - case UPDATE_FRAME: - gSu = (StgUpdateFrame*) ((StgUpdateFrame*)(gSu))->link; - break; - case SEQ_FRAME: - gSu = (StgUpdateFrame*) ((StgSeqFrame*)(gSu))->link; - break; - case STOP_FRAME: - goto postloop; - default: - fprintf(stderr, "myStackCheck: invalid activation record\n"); - barf("aborting"); - ASSERT(0); - } - } - postloop: -} + case IND: + case IND_OLDGEN: + case IND_PERM: + case IND_OLDGEN_PERM: + case IND_STATIC: + { + obj = ((StgInd*)obj)->indirectee; + goto nextEnter_obj; + } + case CONSTR: + case CONSTR_1_0: + case CONSTR_0_1: + case CONSTR_2_0: + case CONSTR_1_1: + case CONSTR_0_2: + case CONSTR_INTLIKE: + case CONSTR_CHARLIKE: + case CONSTR_STATIC: + case CONSTR_NOCAF_STATIC: + nextEnter_obj_CONSTR: + { + StgInfoTable* ret_itbl = (StgInfoTable*)StackWord(0); + if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1p_info) { +# ifdef INTERP_STATS + it_retto_BCO++; +# endif + /* Returning this constr to a BCO. Push the constr on + the stack and enter the return continuation BCO, which + is immediately underneath ret_itbl. */ + StackWord(-1) = (W_)obj; + obj = (StgClosure*)StackWord(1); + iSp --; + if (get_itbl(obj)->type == BCO) + goto nextEnter_obj_BCO; /* fast-track common case */ + else + goto nextEnter_obj; /* a safe fallback */ + } else + if (ret_itbl == (StgInfoTable*)&stg_upd_frame_info) { +# ifdef INTERP_STATS + it_retto_UPDATE++; +# endif + /* Returning this constr to an update frame. Do the + update and re-enter the constr. */ + ASSERT((W_*)iSu == iSp); + UPD_IND(iSu->updatee, obj); + iSu = iSu->link; + iSp += sizeofW(StgUpdateFrame); + goto nextEnter_obj_CONSTR; + } +# ifdef INTERP_STATS + else it_retto_other++; +# endif + goto defer_to_sched; + } -/* -------------------------------------------------------------------------- - * The new bytecode interpreter - * ------------------------------------------------------------------------*/ + case AP_UPD: + /* Copied from stg_AP_UPD_entry. */ + { + nat i, words; + StgAP_UPD *ap = (StgAP_UPD*)obj; + words = ap->n_args; + + /* Stack check. If a stack overflow might occur, don't enter + the closure; let the scheduler handle it instead. */ + if (iSp - (words+sizeofW(StgUpdateFrame)) < iSpLim) + goto defer_to_sched; + + /* Ok; we're safe. Party on. Push an update frame. */ + iSp -= sizeofW(StgUpdateFrame); + { + StgUpdateFrame *__frame; + __frame = (StgUpdateFrame *)iSp; + SET_INFO(__frame, (StgInfoTable *)&stg_upd_frame_info); + __frame->link = iSu; + __frame->updatee = (StgClosure *)(ap); + iSu = __frame; + } + + /* Reload the stack */ + iSp -= words; + for (i=0; i < words; i++) StackWord(i) = (W_)ap->payload[i]; + + obj = (StgClosure*)ap->fun; + goto nextEnter_obj; + } -/* Sp points to the lowest live word on the stack. */ + case PAP: + /* Copied from stg_PAP_entry. */ + { + nat words, i; + StgPAP* pap = (StgPAP *)obj; + + /* + * remove any update frames on the top of the stack, by just + * performing the update here. + */ + while ((W_)iSu - (W_)iSp == 0) { + + switch (get_itbl(iSu)->type) { + + case UPDATE_FRAME: + /* We're sitting on top of an update frame, so let's + do the business. */ + UPD_IND(iSu->updatee, pap); + iSu = iSu->link; + iSp += sizeofW(StgUpdateFrame); + continue; + + case SEQ_FRAME: + /* Too complicated ... adopt the Usual Solution. */ + /* fprintf(stderr, "!!! SEQ frame in PAP update\n"); */ + goto defer_to_sched; + + case CATCH_FRAME: + /* can't happen, see stg_update_PAP */ + barf("interpretBCO: PAP_entry: CATCH_FRAME"); + + default: + barf("interpretBCO: PAP_entry: strange activation record"); + } + } + + words = pap->n_args; + + /* Stack check. If a stack overflow might occur, don't enter + the closure; let the scheduler handle it instead. */ + if (iSp - words < iSpLim) + goto defer_to_sched; + + /* Ok; safe. */ + iSp -= words; + for (i=0; i < words; i++) StackWord(i) = (W_)pap->payload[i]; + + obj = (StgClosure*)pap->fun; + goto nextEnter_obj; + } -#define StackWord(n) ((W_*)Sp)[n] -#define BCO_NEXT bco_instrs[bciPtr++] -#define BCO_PTR(n) bco_ptrs[n] +# endif /* ndef REFERENCE_INTERPRETER */ + + case BCO: + /* ---------------------------------------------------- */ + /* Start of the bytecode interpreter */ + /* ---------------------------------------------------- */ + nextEnter_obj_BCO: +# ifdef INTERP_STATS + it_BCO_entries++; +# endif + { + int do_print_stack = 1; + register int bciPtr = 1; /* instruction pointer */ + register StgBCO* bco = (StgBCO*)obj; + register UShort* instrs = (UShort*)(&bco->instrs->payload[0]); + register StgWord* literals = (StgWord*)(&bco->literals->payload[0]); + register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]); + register StgInfoTable** itbls = (StgInfoTable**) + (&bco->itbls->payload[0]); + + /* Heap check */ + if (doYouWantToGC()) { + iSp--; StackWord(0) = (W_)bco; + cap->r.rCurrentTSO->what_next = ThreadEnterInterp; + RETURN(HeapOverflow); + } + + /* "Standard" stack check */ + if (iSp - (INTERP_STACK_CHECK_THRESH+1) < iSpLim) { + iSp--; + StackWord(0) = (W_)obj; + cap->r.rCurrentTSO->what_next = ThreadEnterInterp; + RETURN(StackOverflow); + } + + /* Context-switch check */ + if (context_switch) { + iSp--; + StackWord(0) = (W_)obj; + cap->r.rCurrentTSO->what_next = ThreadEnterInterp; + RETURN(ThreadYielding); + } + + +# ifdef INTERP_STATS + it_lastopc = 0; /* no opcode */ +# endif + + nextInsn: + + ASSERT(bciPtr <= instrs[0]); + IF_DEBUG(evaluator, + //if (do_print_stack) { + //fprintf(stderr, "\n-- BEGIN stack\n"); + //printStack(iSp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu); + //fprintf(stderr, "-- END stack\n\n"); + //} + do_print_stack = 1; + fprintf(stderr,"iSp = %p iSu = %p pc = %d ", iSp, iSu, bciPtr); + disInstr(bco,bciPtr); + if (0) { int i; + fprintf(stderr,"\n"); + for (i = 8; i >= 0; i--) + fprintf(stderr, "%d %p\n", i, (StgPtr)(*(iSp+i))); + fprintf(stderr,"\n"); + } + //if (do_print_stack) checkStack(iSp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu); + ); + +# ifdef INTERP_STATS + it_insns++; + ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < 27 ); + it_ofreq[ (int)instrs[bciPtr] ] ++; + it_oofreq[ it_lastopc ][ (int)instrs[bciPtr] ] ++; + it_lastopc = (int)instrs[bciPtr]; +# endif + + switch (BCO_NEXT) { + + case bci_STKCHECK: { + /* An explicit stack check; we hope these will be + rare. */ + int stk_words_reqd = BCO_NEXT + 1; + if (iSp - stk_words_reqd < iSpLim) { + iSp--; + StackWord(0) = (W_)obj; + cap->r.rCurrentTSO->what_next = ThreadEnterInterp; + RETURN(StackOverflow); + } + goto nextInsn; + } + case bci_ARGCHECK: { + int i; + StgPAP* pap; + int arg_words_reqd = BCO_NEXT; + int arg_words_avail = ((W_*)iSu) - ((W_*)iSp); + if (arg_words_avail >= arg_words_reqd) goto nextInsn; + +# ifndef REFERENCE_INTERPRETER + + /* Optimisation: if there are no args avail and the + t-o-s is an update frame, do the update, and + re-enter the object. */ + if (arg_words_avail == 0 + && get_itbl(iSu)->type == UPDATE_FRAME) { + UPD_IND(iSu->updatee, obj); + iSu = iSu->link; + iSp += sizeofW(StgUpdateFrame); + goto nextEnter_obj_BCO; + } + +# endif /* ndef REFERENCE_INTERPRETER */ + + /* Handle arg check failure. General case: copy the + spare args into a PAP frame. */ + pap = (StgPAP*)allocate_UPD(PAP_sizeW(arg_words_avail)); + SET_HDR(pap,&stg_PAP_info,CCS_SYSTEM/*ToDo*/); + pap->n_args = arg_words_avail; + pap->fun = obj; + for (i = 0; i < arg_words_avail; i++) + pap->payload[i] = (StgClosure*)StackWord(i); + + /* Push on the stack and defer to the scheduler. */ + iSp = (StgPtr)iSu; + iSp --; + StackWord(0) = (W_)pap; + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + printObj((StgClosure*)pap); + ); + cap->r.rCurrentTSO->what_next = ThreadEnterGHC; + RETURN(ThreadYielding); + } + case bci_PUSH_L: { + int o1 = BCO_NEXT; + ASSERT((W_*)iSp+o1 < (W_*)iSu); + StackWord(-1) = StackWord(o1); + iSp--; + do_print_stack = 0; + goto nextInsn; + } + case bci_PUSH_LL: { + int o1 = BCO_NEXT; + int o2 = BCO_NEXT; + ASSERT((W_*)iSp+o1 < (W_*)iSu); + ASSERT((W_*)iSp+o2 < (W_*)iSu); + StackWord(-1) = StackWord(o1); + StackWord(-2) = StackWord(o2); + iSp -= 2; + goto nextInsn; + } + case bci_PUSH_LLL: { + int o1 = BCO_NEXT; + int o2 = BCO_NEXT; + int o3 = BCO_NEXT; + ASSERT((W_*)iSp+o1 < (W_*)iSu); + ASSERT((W_*)iSp+o2 < (W_*)iSu); + ASSERT((W_*)iSp+o3 < (W_*)iSu); + StackWord(-1) = StackWord(o1); + StackWord(-2) = StackWord(o2); + StackWord(-3) = StackWord(o3); + iSp -= 3; + goto nextInsn; + } + case bci_PUSH_G: { + int o1 = BCO_NEXT; + StackWord(-1) = BCO_PTR(o1); + iSp -= 1; + goto nextInsn; + } + case bci_PUSH_AS: { + int o_bco = BCO_NEXT; + int o_itbl = BCO_NEXT; + StackWord(-2) = BCO_LIT(o_itbl); + StackWord(-1) = BCO_PTR(o_bco); + iSp -= 2; + goto nextInsn; + } + case bci_PUSH_UBX: { + int i; + int o_lits = BCO_NEXT; + int n_words = BCO_NEXT; + iSp -= n_words; + for (i = 0; i < n_words; i++) + StackWord(i) = BCO_LIT(o_lits+i); + do_print_stack = 0; + goto nextInsn; + } + case bci_PUSH_TAG: { + W_ tag = (W_)(BCO_NEXT); + StackWord(-1) = tag; + iSp --; + goto nextInsn; + } + case bci_SLIDE: { + int n = BCO_NEXT; + int by = BCO_NEXT; + ASSERT((W_*)iSp+n+by <= (W_*)iSu); + /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */ + while(--n >= 0) { + StackWord(n+by) = StackWord(n); + } + iSp += by; +# ifdef INTERP_STATS + it_slides++; +# endif + goto nextInsn; + } + case bci_ALLOC: { + StgAP_UPD* ap; + int n_payload = BCO_NEXT - 1; + int request = AP_sizeW(n_payload); + ap = (StgAP_UPD*)allocate_UPD(request); + StackWord(-1) = (W_)ap; + ap->n_args = n_payload; + SET_HDR(ap, &stg_AP_UPD_info, CCS_SYSTEM/*ToDo*/) + iSp --; + goto nextInsn; + } + case bci_MKAP: { + int i; + int stkoff = BCO_NEXT; + int n_payload = BCO_NEXT - 1; + StgAP_UPD* ap = (StgAP_UPD*)StackWord(stkoff); + ASSERT((int)ap->n_args == n_payload); + ap->fun = (StgClosure*)StackWord(0); + for (i = 0; i < n_payload; i++) + ap->payload[i] = (StgClosure*)StackWord(i+1); + iSp += n_payload+1; + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + printObj((StgClosure*)ap); + ); + goto nextInsn; + } + case bci_UNPACK: { + /* Unpack N ptr words from t.o.s constructor */ + /* The common case ! */ + int i; + int n_words = BCO_NEXT; + StgClosure* con = (StgClosure*)StackWord(0); + iSp -= n_words; + for (i = 0; i < n_words; i++) + StackWord(i) = (W_)con->payload[i]; + goto nextInsn; + } + case bci_UPK_TAG: { + /* Unpack N (non-ptr) words from offset M in the + constructor K words down the stack, and then push + N as a tag, on top of it. Slow but general; we + hope it will be the rare case. */ + int i; + int n_words = BCO_NEXT; + int con_off = BCO_NEXT; + int stk_off = BCO_NEXT; + StgClosure* con = (StgClosure*)StackWord(stk_off); + iSp -= n_words; + for (i = 0; i < n_words; i++) + StackWord(i) = (W_)con->payload[con_off + i]; + iSp --; + StackWord(0) = n_words; + goto nextInsn; + } + case bci_PACK: { + int i; + int o_itbl = BCO_NEXT; + int n_words = BCO_NEXT; + StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_ITBL(o_itbl)); + int request = CONSTR_sizeW( itbl->layout.payload.ptrs, + itbl->layout.payload.nptrs ); + StgClosure* con = (StgClosure*)allocate_NONUPD(request); + ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0); + SET_HDR(con, BCO_ITBL(o_itbl), CCS_SYSTEM/*ToDo*/); + for (i = 0; i < n_words; i++) + con->payload[i] = (StgClosure*)StackWord(i); + iSp += n_words; + iSp --; + StackWord(0) = (W_)con; + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + printObj((StgClosure*)con); + ); + goto nextInsn; + } + case bci_TESTLT_P: { + int discr = BCO_NEXT; + int failto = BCO_NEXT; + StgClosure* con = (StgClosure*)StackWord(0); + if (constrTag(con) >= discr) + bciPtr = failto; + goto nextInsn; + } + case bci_TESTEQ_P: { + int discr = BCO_NEXT; + int failto = BCO_NEXT; + StgClosure* con = (StgClosure*)StackWord(0); + if (constrTag(con) != discr) + bciPtr = failto; + goto nextInsn; + } + case bci_TESTLT_I: { + /* The top thing on the stack should be a tagged int. */ + int discr = BCO_NEXT; + int failto = BCO_NEXT; + I_ stackInt = (I_)StackWord(1); + ASSERT(1 == StackWord(0)); + if (stackInt >= (I_)BCO_LIT(discr)) + bciPtr = failto; + goto nextInsn; + } + case bci_TESTEQ_I: { + /* The top thing on the stack should be a tagged int. */ + int discr = BCO_NEXT; + int failto = BCO_NEXT; + I_ stackInt = (I_)StackWord(1); + ASSERT(1 == StackWord(0)); + if (stackInt != (I_)BCO_LIT(discr)) + bciPtr = failto; + goto nextInsn; + } + case bci_TESTLT_D: { + /* The top thing on the stack should be a tagged double. */ + int discr = BCO_NEXT; + int failto = BCO_NEXT; + StgDouble stackDbl, discrDbl; + ASSERT(sizeofW(StgDouble) == StackWord(0)); + stackDbl = PK_DBL( & StackWord(1) ); + discrDbl = PK_DBL( & BCO_LIT(discr) ); + if (stackDbl >= discrDbl) + bciPtr = failto; + goto nextInsn; + } + case bci_TESTEQ_D: { + /* The top thing on the stack should be a tagged double. */ + int discr = BCO_NEXT; + int failto = BCO_NEXT; + StgDouble stackDbl, discrDbl; + ASSERT(sizeofW(StgDouble) == StackWord(0)); + stackDbl = PK_DBL( & StackWord(1) ); + discrDbl = PK_DBL( & BCO_LIT(discr) ); + if (stackDbl != discrDbl) + bciPtr = failto; + goto nextInsn; + } + case bci_TESTLT_F: { + /* The top thing on the stack should be a tagged float. */ + int discr = BCO_NEXT; + int failto = BCO_NEXT; + StgFloat stackFlt, discrFlt; + ASSERT(sizeofW(StgFloat) == StackWord(0)); + stackFlt = PK_FLT( & StackWord(1) ); + discrFlt = PK_FLT( & BCO_LIT(discr) ); + if (stackFlt >= discrFlt) + bciPtr = failto; + goto nextInsn; + } + case bci_TESTEQ_F: { + /* The top thing on the stack should be a tagged float. */ + int discr = BCO_NEXT; + int failto = BCO_NEXT; + StgFloat stackFlt, discrFlt; + ASSERT(sizeofW(StgFloat) == StackWord(0)); + stackFlt = PK_FLT( & StackWord(1) ); + discrFlt = PK_FLT( & BCO_LIT(discr) ); + if (stackFlt != discrFlt) + bciPtr = failto; + goto nextInsn; + } + + /* Control-flow ish things */ + case bci_ENTER: { + goto nextEnter; + } + case bci_RETURN: { + /* Figure out whether returning to interpreted or + compiled code. */ + int o_itoc_itbl = BCO_NEXT; + int tag = StackWord(0); + StgInfoTable* ret_itbl = (StgInfoTable*)StackWord(tag +1); + ASSERT(tag <= 2); /* say ... */ + if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1p_info + || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1n_info + || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_F1_info + || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_D1_info + || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_V_info) { + /* Returning to interpreted code. Interpret the BCO + immediately underneath the itbl. */ + StgBCO* ret_bco = (StgBCO*)StackWord(tag +1+1); + iSp --; + StackWord(0) = (W_)ret_bco; + goto nextEnter; + } else { + /* Returning (unboxed value) to compiled code. + Replace tag with a suitable itbl and ask the + scheduler to run it. The itbl code will copy + the TOS value into R1/F1/D1 and do a standard + compiled-code return. */ + StgInfoTable* magic_itbl = BCO_ITBL(o_itoc_itbl); + if (magic_itbl != NULL) { + StackWord(0) = (W_)magic_itbl; + cap->r.rCurrentTSO->what_next = ThreadRunGHC; + RETURN(ThreadYielding); + } else { + /* Special case -- returning a VoidRep to + compiled code. T.O.S is the VoidRep tag, + and underneath is the return itbl. Zap the + tag and enter the itbl. */ + ASSERT(StackWord(0) == (W_)NULL); + iSp ++; + cap->r.rCurrentTSO->what_next = ThreadRunGHC; + RETURN(ThreadYielding); + } + } + } + case bci_SWIZZLE: { + int stkoff = BCO_NEXT; + signed short n = (signed short)(BCO_NEXT); + StackWord(stkoff) += (W_)n; + goto nextInsn; + } + case bci_CCALL: { + StgInt tok; + int o_itbl = BCO_NEXT; + void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl); + SAVE_STACK_POINTERS; + tok = suspendThread(&cap->r,rtsFalse); + marshall_fn ( (void*)(& StackWord(0) ) ); + cap = (Capability *)((void *)resumeThread(tok,rtsFalse) - sizeof(StgFunTable)); + LOAD_STACK_POINTERS; + goto nextInsn; + } + case bci_JMP: { + /* BCO_NEXT modifies bciPtr, so be conservative. */ + int nextpc = BCO_NEXT; + bciPtr = nextpc; + goto nextInsn; + } + case bci_CASEFAIL: + barf("interpretBCO: hit a CASEFAIL"); + + /* Errors */ + default: + barf("interpretBCO: unknown or unimplemented opcode"); + + } /* switch on opcode */ + + barf("interpretBCO: fell off end of insn loop"); + } + /* ---------------------------------------------------- */ + /* End of the bytecode interpreter */ + /* ---------------------------------------------------- */ + + defer_to_sched: + default: { +# ifdef INTERP_STATS + { int j = get_itbl(obj)->type; + ASSERT(j >= 0 && j < N_CLOSURE_TYPES); + it_unknown_entries[j]++; + it_total_unknown_entries++; + } +# endif + + /* Can't handle this object; yield to sched. */ + IF_DEBUG(evaluator, + fprintf(stderr, "entering unknown closure -- yielding to sched\n"); + printObj(obj); + ); + iSp--; StackWord(0) = (W_)obj; + cap->r.rCurrentTSO->what_next = ThreadEnterGHC; + RETURN(ThreadYielding); + } + } /* switch on object kind */ -{ - case bci_PUSH_L: { - int o1 = BCO_NEXT; - StackWord(-1) = StackWord(o1); - Sp--; - break; - } - case bci_PUSH_LL: { - int o1 = BCO_NEXT; - int o2 = BCO_NEXT; - StackWord(-1) = StackWord(o1); - StackWord(-2) = StackWord(o2); - Sp -= 2; - break; - } - case bci_PUSH_LLL: { - int o1 = BCO_NEXT; - int o2 = BCO_NEXT; - int o3 = BCO_NEXT; - StackWord(-1) = StackWord(o1); - StackWord(-2) = StackWord(o2); - StackWord(-3) = StackWord(o3); - Sp -= 3; - break; - } - case bci_PUSH_G: { - int o1 = BCO_NEXT; - StackWord(-1) = BCO_PTR(o1); - Sp -= 3; - break; - } - case bci_PUSH_AS: { - int o_bco = BCO_NEXT; - int o_itbl = BCO_NEXT; - StackWord(-1) = BCO_LITW(o_itbl); - StackWord(-2) = BCO_PTR(o_bco); - Sp -= 2; - break; - } - case bci_PUSH_LIT:{ - int o = BCO_NEXT; - StackWord(-1) = BCO_LIT(o); - Sp --; - break; - } - case bci_PUSH_TAG: { - W_ tag = (W_)(BCO_NEXT); - StackWord(-1) = tag; - Sp --; - break; - } - case bci_SLIDE: { - int n = BCO_NEXT; - int by = BCO_NEXT; - ASSERT(Sp+n+by <= (StgPtr)xSu); - /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */ - while(--n >= 0) { - StackWord(n+by) = StackWord(n); - } - Sp += by; - break; - } - case bci_ALLOC: { - int n_payload = BCO_NEXT; - P_ p = allocate(AP_sizeW(n_payload)); - StackWord(-1) = p; - Sp --; - break; - } - case bci_MKAP: { - int off = BCO_NEXT; - int n_payload = BCO_NEXT - 1; - StgAP_UPD* ap = StackWord(off); - ap->n_args = n_payload; - ap->fun = (StgClosure*)StackWord(0); - for (i = 0; i < n_payload; i++) - ap->payload[i] = StackWord(i+1); - } - Sp += n_payload+1; -} -case bci_UNPACK:{ - /* Unpack N ptr words from t.o.s constructor */ - int n_words = BCO_NEXT; - StgClosure* con = StackWord(0); - Sp -= n_words; - for (i = 0; i < n_words; i++) - StackWord(i) = con->payload[i]; + barf("fallen off end of object-type switch in interpretBCO()"); } - case bci_PACK: - case bci_TESTLT_I: - case bci_TESTEQ_I: - case bci_TESTLT_F: - case bci_TESTEQ_F: - case bci_TESTLT_D: - case bci_TESTEQ_D: - case bci_TESTLT_P: - case bci_TESTEQ_P: - case bci_CASEFAIL: - - /* Control-flow ish things */ - case bci_ARGCHECK: - case bci_ENTER: - case bci_RETURN: - - /* Errors */ - case bci_LABEL: - default: barf -} - -#endif /* 0 */