X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FInterpreter.c;h=56e9bb67cea7c43ec25d9bc8c4ffe8c6c27123b9;hb=5c67b7e313b2455ca65d5aa5970d86889145e97e;hp=c412f88d2e4920918a04a38d21fe32e6738afa93;hpb=ed0c285fe3937e5e53572165f9672dc1dc8ca7a4;p=ghc-hetmet.git diff --git a/ghc/rts/Interpreter.c b/ghc/rts/Interpreter.c index c412f88..56e9bb6 100644 --- a/ghc/rts/Interpreter.c +++ b/ghc/rts/Interpreter.c @@ -1,1603 +1,260 @@ -#if 0 /* ----------------------------------------------------------------------------- - * Bytecode evaluator + * Bytecode interpreter * - * Copyright (c) 1994-2000. - * - * $RCSfile: Interpreter.c,v $ - * $Revision: 1.1 $ - * $Date: 2000/12/11 12:55:43 $ + * Copyright (c) The GHC Team, 1994-2002. * ---------------------------------------------------------------------------*/ +#include "PosixSource.h" #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 "LdvProfile.h" +#include "Updates.h" +#include "Sanity.h" +#include "Liveness.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 "Interpreter.h" -#include /* These are for primops */ -#include /* These are for primops */ -#include /* These are for primops */ -#ifdef HAVE_IEEE754_H -#include /* These are for primops */ +#include /* for memcpy */ +#ifdef HAVE_ERRNO_H +#include #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 +/* -------------------------------------------------------------------------- + * The bytecode interpreter + * ------------------------------------------------------------------------*/ -/* 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; +/* Gather stats about entry, opcode, opcode-pair frequencies. For + tuning the interpreter. */ +/* #define INTERP_STATS */ -/* -------------------------------------------------------------------------- - * Hugs Hooks - a bit of a hack - * ------------------------------------------------------------------------*/ +/* Sp points to the lowest live word on the stack. */ -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; - } -} +#define BCO_NEXT instrs[bciPtr++] +#define BCO_PTR(n) (W_)ptrs[n] +#define BCO_LIT(n) literals[n] +#define BCO_ITBL(n) itbls[n] +#define LOAD_STACK_POINTERS \ + Sp = cap->r.rCurrentTSO->sp; \ + /* We don't change this ... */ \ + SpLim = cap->r.rCurrentTSO->stack + RESERVED_STACK_WORDS; -typedef struct { - StgTSOBlockReason reason; - unsigned int delay; -} HugsBlock; +#define SAVE_STACK_POINTERS \ + cap->r.rCurrentTSO->sp = Sp +#define RETURN_TO_SCHEDULER(todo,retcode) \ + SAVE_STACK_POINTERS; \ + cap->r.rCurrentTSO->what_next = (todo); \ + threadPaused(cap,cap->r.rCurrentTSO); \ + cap->r.rRet = (retcode); \ + return cap; -/* -------------------------------------------------------------------------- - * Entering-objects and bytecode interpreter part of evaluator - * ------------------------------------------------------------------------*/ +#define RETURN_TO_SCHEDULER_NO_PAUSE(todo,retcode) \ + SAVE_STACK_POINTERS; \ + cap->r.rCurrentTSO->what_next = (todo); \ + cap->r.rRet = (retcode); \ + return cap; -/* 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; \ +STATIC_INLINE StgPtr +allocate_NONUPD (int n_words) +{ + return allocate(stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words)); } -#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; \ -} +#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; +int it_retto_BCO; +int it_retto_UPDATE; +int it_retto_other; -/* 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))) +int it_slides; +int it_insns; +int it_BCO_entries; +int it_ofreq[27]; +int it_oofreq[27][27]; +int it_lastopc; -/* State on entry to enter(): - * - current thread is in cap->rCurrentTSO; - * - allocation area is in cap->rCurrentNursery & cap->rNursery - */ +#define INTERP_TICK(n) (n)++ -StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) +void interp_startup ( void ) { - /* 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 */ + 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 ) +{ + int i, j, k, o_max, i_max, j_max; + debugBelch("%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 ); + debugBelch("%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; + debugBelch(" 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]); + } + debugBelch("%d insns, %d slides, %d BCO_entries\n", + it_insns, it_slides, it_BCO_entries); + for (i = 0; i < 27; i++) + debugBelch("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; + } + } + } + + debugBelch("%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; + } +} - HugsBlock hugsBlock = { NotBlocked, 0 }; +#else // !INTERP_STATS +#define INTERP_TICK(n) /* nothing */ -#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 +static StgWord app_ptrs_itbl[] = { + (W_)&stg_ap_p_info, + (W_)&stg_ap_pp_info, + (W_)&stg_ap_ppp_info, + (W_)&stg_ap_pppp_info, + (W_)&stg_ap_ppppp_info, + (W_)&stg_ap_pppppp_info, +}; + +Capability * +interpretBCO (Capability* cap) +{ + // Use of register here is primarily to make it clear to compilers + // that these entities are non-aliasable. + register StgPtr Sp; // local state -- stack pointer + register StgPtr SpLim; // local state -- stack lim pointer + register StgClosure* obj; + nat n, m; + + LOAD_STACK_POINTERS; + + // ------------------------------------------------------------------------ + // Case 1: + // + // We have a closure to evaluate. Stack looks like: + // + // | XXXX_info | + // +---------------+ + // Sp | -------------------> closure + // +---------------+ + // + if (Sp[0] == (W_)&stg_enter_info) { + Sp++; + goto eval; + } - obj = obj0; - eCount = 0; + // ------------------------------------------------------------------------ + // Case 2: + // + // We have a BCO application to perform. Stack looks like: + // + // | .... | + // +---------------+ + // | arg1 | + // +---------------+ + // | BCO | + // +---------------+ + // Sp | RET_BCO | + // +---------------+ + // + else if (Sp[0] == (W_)&stg_apply_interp_info) { + obj = (StgClosure *)Sp[1]; + Sp += 2; + goto run_BCO_fun; + } - /* 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; + // ------------------------------------------------------------------------ + // Case 3: + // + // We have an unboxed value to return. See comment before + // do_return_unboxed, below. + // + else { + goto do_return_unboxed; + } - enterLoop: + // Evaluate the object on top of the stack. +eval: + obj = (StgClosure*)Sp[0]; Sp++; - numEnters++; +eval_obj: + INTERP_TICK(it_total_evals); -#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, + IF_DEBUG(interpreter, + debugBelch( "\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; + debugBelch("Evaluating: "); printObj(obj); + debugBelch("Sp = %p\n", Sp); + debugBelch("\n" ); + + printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size); + debugBelch("\n\n"); ); -#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"); - } - } - } + IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size)); 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 IND_PERM: + case IND_OLDGEN_PERM: + case IND_STATIC: + { + obj = ((StgInd*)obj)->indirectee; + goto eval_obj; + } + case CONSTR: case CONSTR_1_0: case CONSTR_0_1: @@ -1608,975 +265,997 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) 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 - + case FUN: + case FUN_1_0: + case FUN_0_1: + case FUN_2_0: + case FUN_1_1: + case FUN_0_2: + case FUN_STATIC: + case PAP: + // already in WHNF + break; + + case BCO: + ASSERT(((StgBCO *)obj)->arity > 0); + break; + + case AP: /* Copied from stg_AP_entry. */ + { + nat i, words; + StgAP *ap; + + ap = (StgAP*)obj; + words = ap->n_args; + + // Stack check + if (Sp - (words+sizeofW(StgUpdateFrame)) < SpLim) { + Sp -= 2; + Sp[1] = (W_)obj; + Sp[0] = (W_)&stg_enter_info; + RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow); + } + + /* Ok; we're safe. Party on. Push an update frame. */ + Sp -= sizeofW(StgUpdateFrame); + { + StgUpdateFrame *__frame; + __frame = (StgUpdateFrame *)Sp; + SET_INFO(__frame, (StgInfoTable *)&stg_upd_frame_info); + __frame->updatee = (StgClosure *)(ap); + } + + /* Reload the stack */ + Sp -= words; + for (i=0; i < words; i++) { + Sp[i] = (W_)ap->payload[i]; + } -/* -------------------------------------------------------------------------- - * Supporting routines for primops - * ------------------------------------------------------------------------*/ + obj = (StgClosure*)ap->fun; + ASSERT(get_itbl(obj)->type == BCO); + goto run_BCO_fun; + } -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; } + default: +#ifdef INTERP_STATS + { + int j; + + 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 scheduler + IF_DEBUG(interpreter, + debugBelch("evaluating unknown closure -- yielding to sched\n"); + printObj(obj); + ); + Sp -= 2; + Sp[1] = (W_)obj; + Sp[0] = (W_)&stg_enter_info; + RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding); + } + } -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); } - - -/* -------------------------------------------------------------------------- - * 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 ) -{ - ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) ); - return allocate(size); -} - -static inline StgPtr grabHpNonUpd( nat size ) -{ - ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) ); - return allocate(size); -} - -/* -------------------------------------------------------------------------- - * 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 - * ------------------------------------------------------------------------*/ + // ------------------------------------------------------------------------ + // We now have an evaluated object (obj). The next thing to + // do is return it to the stack frame on top of the stack. +do_return: + ASSERT(closure_HNF(obj)); -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; -} - -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; -} + IF_DEBUG(interpreter, + debugBelch( + "\n---------------------------------------------------------------\n"); + debugBelch("Returning: "); printObj(obj); + debugBelch("Sp = %p\n", Sp); + debugBelch("\n" ); + printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size); + debugBelch("\n\n"); + ); -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); -} + IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size)); -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; -} + switch (get_itbl((StgClosure *)Sp)->type) { -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); -} + case RET_SMALL: { + const StgInfoTable *info; -static inline void PopSeqFrame ( 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 ) -{ - /* 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; - } - case STOP_FRAME: - barf("raiseError: uncaught exception: STOP_FRAME"); - default: - barf("raiseError: weird activation record"); - } + // NOTE: not using get_itbl(). + info = ((StgClosure *)Sp)->header.info; + if (info == (StgInfoTable *)&stg_ap_v_info) { + n = 1; m = 0; goto do_apply; + } + if (info == (StgInfoTable *)&stg_ap_f_info) { + n = 1; m = 1; goto do_apply; + } + if (info == (StgInfoTable *)&stg_ap_d_info) { + n = 1; m = sizeofW(StgDouble); goto do_apply; + } + if (info == (StgInfoTable *)&stg_ap_l_info) { + n = 1; m = sizeofW(StgInt64); goto do_apply; + } + if (info == (StgInfoTable *)&stg_ap_n_info) { + n = 1; m = 1; goto do_apply; + } + if (info == (StgInfoTable *)&stg_ap_p_info) { + n = 1; m = 1; goto do_apply; + } + if (info == (StgInfoTable *)&stg_ap_pp_info) { + n = 2; m = 2; goto do_apply; + } + if (info == (StgInfoTable *)&stg_ap_ppp_info) { + n = 3; m = 3; goto do_apply; + } + if (info == (StgInfoTable *)&stg_ap_pppp_info) { + n = 4; m = 4; goto do_apply; + } + if (info == (StgInfoTable *)&stg_ap_ppppp_info) { + n = 5; m = 5; goto do_apply; + } + if (info == (StgInfoTable *)&stg_ap_pppppp_info) { + n = 6; m = 6; goto do_apply; + } + goto do_return_unrecognised; } -} + case UPDATE_FRAME: + // Returning to an update frame: do the update, pop the update + // frame, and continue with the next stack frame. + INTERP_TICK(it_retto_UPDATE); + UPD_IND(((StgUpdateFrame *)Sp)->updatee, obj); + Sp += sizeofW(StgUpdateFrame); + goto do_return; + + case RET_BCO: + // Returning to an interpreted continuation: put the object on + // the stack, and start executing the BCO. + INTERP_TICK(it_retto_BCO); + Sp--; + Sp[0] = (W_)obj; + obj = (StgClosure*)Sp[2]; + ASSERT(get_itbl(obj)->type == BCO); + goto run_BCO_return; -static StgClosure* makeErrorCall ( const char* msg ) -{ - /* 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 ...) - */ - 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; -} + default: + do_return_unrecognised: + { + // Can't handle this return address; yield to scheduler + INTERP_TICK(it_retto_other); + IF_DEBUG(interpreter, + debugBelch("returning to unknown frame -- yielding to sched\n"); + printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size); + ); + Sp -= 2; + Sp[1] = (W_)obj; + Sp[0] = (W_)&stg_enter_info; + RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding); + } + } -#define raiseIndex(where) makeErrorCall("Array index out of range in " where) -#define raiseDiv0(where) makeErrorCall("Division by zero in " where) + // ------------------------------------------------------------------------- + // Returning an unboxed value. The stack looks like this: + // + // | .... | + // +---------------+ + // | fv2 | + // +---------------+ + // | fv1 | + // +---------------+ + // | BCO | + // +---------------+ + // | stg_ctoi_ret_ | + // +---------------+ + // | retval | + // +---------------+ + // | XXXX_info | + // +---------------+ + // + // where XXXX_info is one of the stg_gc_unbx_r1_info family. + // + // We're only interested in the case when the real return address + // is a BCO; otherwise we'll return to the scheduler. + +do_return_unboxed: + { + int offset; + + ASSERT( Sp[0] == (W_)&stg_gc_unbx_r1_info + || Sp[0] == (W_)&stg_gc_unpt_r1_info + || Sp[0] == (W_)&stg_gc_f1_info + || Sp[0] == (W_)&stg_gc_d1_info + || Sp[0] == (W_)&stg_gc_l1_info + || Sp[0] == (W_)&stg_gc_void_info // VoidRep + ); + + // get the offset of the stg_ctoi_ret_XXX itbl + offset = stack_frame_sizeW((StgClosure *)Sp); + + switch (get_itbl((StgClosure *)Sp+offset)->type) { + + case RET_BCO: + // Returning to an interpreted continuation: put the object on + // the stack, and start executing the BCO. + INTERP_TICK(it_retto_BCO); + obj = (StgClosure*)Sp[offset+1]; + ASSERT(get_itbl(obj)->type == BCO); + goto run_BCO_return_unboxed; + + default: + { + // Can't handle this return address; yield to scheduler + INTERP_TICK(it_retto_other); + IF_DEBUG(interpreter, + debugBelch("returning to unknown frame -- yielding to sched\n"); + printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size); + ); + RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding); + } + } + } + // not reached. -/* -------------------------------------------------------------------------- - * Evaluator - * ------------------------------------------------------------------------*/ -#define OP_CC_B(e) \ -{ \ - unsigned char x = PopTaggedChar(); \ - unsigned char y = PopTaggedChar(); \ - PushTaggedBool(e); \ -} + // ------------------------------------------------------------------------- + // Application... -#define OP_C_I(e) \ -{ \ - unsigned char x = PopTaggedChar(); \ - PushTaggedInt(e); \ -} +do_apply: + // we have a function to apply (obj), and n arguments taking up m + // words on the stack. The info table (stg_ap_pp_info or whatever) + // is on top of the arguments on the stack. + { + switch (get_itbl(obj)->type) { -#define OP__I(e) \ -{ \ - PushTaggedInt(e); \ -} + case PAP: { + StgPAP *pap; + nat i, arity; -#define OP_IW_I(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - StgWord y = PopTaggedWord(); \ - PushTaggedInt(e); \ -} + pap = (StgPAP *)obj; -#define OP_II_I(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - StgInt y = PopTaggedInt(); \ - PushTaggedInt(e); \ -} + // we only cope with PAPs whose function is a BCO + if (get_itbl(pap->fun)->type != BCO) { + goto defer_apply_to_sched; + } -#define OP_II_B(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - StgInt y = PopTaggedInt(); \ - PushTaggedBool(e); \ -} + Sp++; + arity = pap->arity; + ASSERT(arity > 0); + if (arity < n) { + // n must be greater than 1, and the only kinds of + // application we support with more than one argument + // are all pointers... + // + // Shuffle the args for this function down, and put + // the appropriate info table in the gap. + for (i = 0; i < arity; i++) { + Sp[(int)i-1] = Sp[i]; + // ^^^^^ careful, i-1 might be negative, but i in unsigned + } + Sp[arity-1] = app_ptrs_itbl[n-arity-1]; + Sp--; + // unpack the PAP's arguments onto the stack + Sp -= pap->n_args; + for (i = 0; i < pap->n_args; i++) { + Sp[i] = (W_)pap->payload[i]; + } + obj = pap->fun; + goto run_BCO_fun; + } + else if (arity == n) { + Sp -= pap->n_args; + for (i = 0; i < pap->n_args; i++) { + Sp[i] = (W_)pap->payload[i]; + } + obj = pap->fun; + goto run_BCO_fun; + } + else /* arity > n */ { + // build a new PAP and return it. + StgPAP *new_pap; + new_pap = (StgPAP *)allocate(PAP_sizeW(pap->n_args + m)); + SET_HDR(new_pap,&stg_PAP_info,CCCS); + new_pap->arity = pap->arity - n; + new_pap->n_args = pap->n_args + m; + new_pap->fun = pap->fun; + for (i = 0; i < pap->n_args; i++) { + new_pap->payload[i] = pap->payload[i]; + } + for (i = 0; i < m; i++) { + new_pap->payload[pap->n_args + i] = (StgClosure *)Sp[i]; + } + obj = (StgClosure *)new_pap; + Sp += m; + goto do_return; + } + } + + case BCO: { + nat arity, i; + + Sp++; + arity = ((StgBCO *)obj)->arity; + ASSERT(arity > 0); + if (arity < n) { + // n must be greater than 1, and the only kinds of + // application we support with more than one argument + // are all pointers... + // + // Shuffle the args for this function down, and put + // the appropriate info table in the gap. + for (i = 0; i < arity; i++) { + Sp[(int)i-1] = Sp[i]; + // ^^^^^ careful, i-1 might be negative, but i in unsigned + } + Sp[arity-1] = app_ptrs_itbl[n-arity-1]; + Sp--; + goto run_BCO_fun; + } + else if (arity == n) { + goto run_BCO_fun; + } + else /* arity > n */ { + // build a PAP and return it. + StgPAP *pap; + nat i; + pap = (StgPAP *)allocate(PAP_sizeW(m)); + SET_HDR(pap, &stg_PAP_info,CCCS); + pap->arity = arity - n; + pap->fun = obj; + pap->n_args = m; + for (i = 0; i < m; i++) { + pap->payload[i] = (StgClosure *)Sp[i]; + } + obj = (StgClosure *)pap; + Sp += m; + goto do_return; + } + } -#define OP__A(e) \ -{ \ - PushTaggedAddr(e); \ -} + // No point in us applying machine-code functions + default: + defer_apply_to_sched: + Sp -= 2; + Sp[1] = (W_)obj; + Sp[0] = (W_)&stg_enter_info; + RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding); + } -#define OP_I_A(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - PushTaggedAddr(e); \ -} + // ------------------------------------------------------------------------ + // Ok, we now have a bco (obj), and its arguments are all on the + // stack. We can start executing the byte codes. + // + // The stack is in one of two states. First, if this BCO is a + // function: + // + // | .... | + // +---------------+ + // | arg2 | + // +---------------+ + // | arg1 | + // +---------------+ + // + // Second, if this BCO is a continuation: + // + // | .... | + // +---------------+ + // | fv2 | + // +---------------+ + // | fv1 | + // +---------------+ + // | BCO | + // +---------------+ + // | stg_ctoi_ret_ | + // +---------------+ + // | retval | + // +---------------+ + // + // where retval is the value being returned to this continuation. + // In the event of a stack check, heap check, or context switch, + // we need to leave the stack in a sane state so the garbage + // collector can find all the pointers. + // + // (1) BCO is a function: the BCO's bitmap describes the + // pointerhood of the arguments. + // + // (2) BCO is a continuation: BCO's bitmap describes the + // pointerhood of the free variables. + // + // Sadly we have three different kinds of stack/heap/cswitch check + // to do: + +run_BCO_return: + // Heap check + if (doYouWantToGC()) { + Sp--; Sp[0] = (W_)&stg_enter_info; + RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow); + } + // Stack checks aren't necessary at return points, the stack use + // is aggregated into the enclosing function entry point. + goto run_BCO; + +run_BCO_return_unboxed: + // Heap check + if (doYouWantToGC()) { + RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow); + } + // Stack checks aren't necessary at return points, the stack use + // is aggregated into the enclosing function entry point. + goto run_BCO; + +run_BCO_fun: + IF_DEBUG(sanity, + Sp -= 2; + Sp[1] = (W_)obj; + Sp[0] = (W_)&stg_apply_interp_info; + checkStackChunk(Sp,SpLim); + Sp += 2; + ); + + // Heap check + if (doYouWantToGC()) { + Sp -= 2; + Sp[1] = (W_)obj; + Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really + RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow); + } + + // Stack check + if (Sp - INTERP_STACK_CHECK_THRESH < SpLim) { + Sp -= 2; + Sp[1] = (W_)obj; + Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really + RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow); + } + goto run_BCO; + + // Now, actually interpret the BCO... (no returning to the + // scheduler again until the stack is in an orderly state). +run_BCO: + INTERP_TICK(it_BCO_entries); + { + register int bciPtr = 1; /* instruction pointer */ + register StgBCO* bco = (StgBCO*)obj; + register StgWord16* instrs = (StgWord16*)(bco->instrs->payload); + register StgWord* literals = (StgWord*)(&bco->literals->payload[0]); + register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]); + register StgInfoTable** itbls = (StgInfoTable**) + (&bco->itbls->payload[0]); + +#ifdef INTERP_STATS + it_lastopc = 0; /* no opcode */ +#endif -#define OP_I_I(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - PushTaggedInt(e); \ -} + nextInsn: + ASSERT(bciPtr <= instrs[0]); + IF_DEBUG(interpreter, + //if (do_print_stack) { + //debugBelch("\n-- BEGIN stack\n"); + //printStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu); + //debugBelch("-- END stack\n\n"); + //} + debugBelch("Sp = %p pc = %d ", Sp, bciPtr); + disInstr(bco,bciPtr); + if (0) { int i; + debugBelch("\n"); + for (i = 8; i >= 0; i--) { + debugBelch("%d %p\n", i, (StgPtr)(*(Sp+i))); + } + debugBelch("\n"); + } + //if (do_print_stack) checkStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu); + ); + + INTERP_TICK(it_insns); + +#ifdef INTERP_STATS + 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 -#define OP__C(e) \ -{ \ - PushTaggedChar(e); \ -} + switch (BCO_NEXT) { + + case bci_STKCHECK: { + // Explicit stack check at the beginning of a function + // *only* (stack checks in case alternatives are + // propagated to the enclosing function). + int stk_words_reqd = BCO_NEXT + 1; + if (Sp - stk_words_reqd < SpLim) { + Sp -= 2; + Sp[1] = (W_)obj; + Sp[0] = (W_)&stg_apply_interp_info; + RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow); + } else { + goto nextInsn; + } + } -#define OP_I_C(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - PushTaggedChar(e); \ -} + case bci_PUSH_L: { + int o1 = BCO_NEXT; + Sp[-1] = Sp[o1]; + Sp--; + goto nextInsn; + } -#define OP__W(e) \ -{ \ - PushTaggedWord(e); \ -} + case bci_PUSH_LL: { + int o1 = BCO_NEXT; + int o2 = BCO_NEXT; + Sp[-1] = Sp[o1]; + Sp[-2] = Sp[o2]; + Sp -= 2; + goto nextInsn; + } -#define OP_I_W(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - PushTaggedWord(e); \ -} + case bci_PUSH_LLL: { + int o1 = BCO_NEXT; + int o2 = BCO_NEXT; + int o3 = BCO_NEXT; + Sp[-1] = Sp[o1]; + Sp[-2] = Sp[o2]; + Sp[-3] = Sp[o3]; + Sp -= 3; + goto nextInsn; + } -#define OP_I_s(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - PushTaggedStablePtr(e); \ -} + case bci_PUSH_G: { + int o1 = BCO_NEXT; + Sp[-1] = BCO_PTR(o1); + Sp -= 1; + goto nextInsn; + } -#define OP__F(e) \ -{ \ - PushTaggedFloat(e); \ -} + case bci_PUSH_ALTS: { + int o_bco = BCO_NEXT; + Sp[-2] = (W_)&stg_ctoi_R1p_info; + Sp[-1] = BCO_PTR(o_bco); + Sp -= 2; + goto nextInsn; + } -#define OP_I_F(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - PushTaggedFloat(e); \ -} + case bci_PUSH_ALTS_P: { + int o_bco = BCO_NEXT; + Sp[-2] = (W_)&stg_ctoi_R1unpt_info; + Sp[-1] = BCO_PTR(o_bco); + Sp -= 2; + goto nextInsn; + } -#define OP__D(e) \ -{ \ - PushTaggedDouble(e); \ -} + case bci_PUSH_ALTS_N: { + int o_bco = BCO_NEXT; + Sp[-2] = (W_)&stg_ctoi_R1n_info; + Sp[-1] = BCO_PTR(o_bco); + Sp -= 2; + goto nextInsn; + } -#define OP_I_D(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - PushTaggedDouble(e); \ -} + case bci_PUSH_ALTS_F: { + int o_bco = BCO_NEXT; + Sp[-2] = (W_)&stg_ctoi_F1_info; + Sp[-1] = BCO_PTR(o_bco); + Sp -= 2; + goto nextInsn; + } -#define OP_WW_B(e) \ -{ \ - StgWord x = PopTaggedWord(); \ - StgWord y = PopTaggedWord(); \ - PushTaggedBool(e); \ -} + case bci_PUSH_ALTS_D: { + int o_bco = BCO_NEXT; + Sp[-2] = (W_)&stg_ctoi_D1_info; + Sp[-1] = BCO_PTR(o_bco); + Sp -= 2; + goto nextInsn; + } -#define OP_WW_W(e) \ -{ \ - StgWord x = PopTaggedWord(); \ - StgWord y = PopTaggedWord(); \ - PushTaggedWord(e); \ -} + case bci_PUSH_ALTS_L: { + int o_bco = BCO_NEXT; + Sp[-2] = (W_)&stg_ctoi_L1_info; + Sp[-1] = BCO_PTR(o_bco); + Sp -= 2; + goto nextInsn; + } -#define OP_W_I(e) \ -{ \ - StgWord x = PopTaggedWord(); \ - PushTaggedInt(e); \ -} + case bci_PUSH_ALTS_V: { + int o_bco = BCO_NEXT; + Sp[-2] = (W_)&stg_ctoi_V_info; + Sp[-1] = BCO_PTR(o_bco); + Sp -= 2; + goto nextInsn; + } -#define OP_s_I(e) \ -{ \ - StgStablePtr x = PopTaggedStablePtr(); \ - PushTaggedInt(e); \ -} + case bci_PUSH_APPLY_N: + Sp--; Sp[0] = (W_)&stg_ap_n_info; + goto nextInsn; + case bci_PUSH_APPLY_V: + Sp--; Sp[0] = (W_)&stg_ap_v_info; + goto nextInsn; + case bci_PUSH_APPLY_F: + Sp--; Sp[0] = (W_)&stg_ap_f_info; + goto nextInsn; + case bci_PUSH_APPLY_D: + Sp--; Sp[0] = (W_)&stg_ap_d_info; + goto nextInsn; + case bci_PUSH_APPLY_L: + Sp--; Sp[0] = (W_)&stg_ap_l_info; + goto nextInsn; + case bci_PUSH_APPLY_P: + Sp--; Sp[0] = (W_)&stg_ap_p_info; + goto nextInsn; + case bci_PUSH_APPLY_PP: + Sp--; Sp[0] = (W_)&stg_ap_pp_info; + goto nextInsn; + case bci_PUSH_APPLY_PPP: + Sp--; Sp[0] = (W_)&stg_ap_ppp_info; + goto nextInsn; + case bci_PUSH_APPLY_PPPP: + Sp--; Sp[0] = (W_)&stg_ap_pppp_info; + goto nextInsn; + case bci_PUSH_APPLY_PPPPP: + Sp--; Sp[0] = (W_)&stg_ap_ppppp_info; + goto nextInsn; + case bci_PUSH_APPLY_PPPPPP: + Sp--; Sp[0] = (W_)&stg_ap_pppppp_info; + goto nextInsn; + + case bci_PUSH_UBX: { + int i; + int o_lits = BCO_NEXT; + int n_words = BCO_NEXT; + Sp -= n_words; + for (i = 0; i < n_words; i++) { + Sp[i] = (W_)BCO_LIT(o_lits+i); + } + goto nextInsn; + } -#define OP_W_W(e) \ -{ \ - StgWord x = PopTaggedWord(); \ - PushTaggedWord(e); \ -} + case bci_SLIDE: { + int n = BCO_NEXT; + int by = BCO_NEXT; + /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */ + while(--n >= 0) { + Sp[n+by] = Sp[n]; + } + Sp += by; + INTERP_TICK(it_slides); + goto nextInsn; + } -#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; \ -} + case bci_ALLOC_AP: { + StgAP* ap; + int n_payload = BCO_NEXT; + ap = (StgAP*)allocate(AP_sizeW(n_payload)); + Sp[-1] = (W_)ap; + ap->n_args = n_payload; + SET_HDR(ap, &stg_AP_info, CCS_SYSTEM/*ToDo*/) + Sp --; + goto nextInsn; + } + case bci_ALLOC_PAP: { + StgPAP* pap; + int arity = BCO_NEXT; + int n_payload = BCO_NEXT; + pap = (StgPAP*)allocate(PAP_sizeW(n_payload)); + Sp[-1] = (W_)pap; + pap->n_args = n_payload; + pap->arity = arity; + SET_HDR(pap, &stg_PAP_info, CCS_SYSTEM/*ToDo*/) + Sp --; + goto nextInsn; + } -#define OP_FF_B(e) \ -{ \ - StgFloat x = PopTaggedFloat(); \ - StgFloat y = PopTaggedFloat(); \ - PushTaggedBool(e); \ -} + case bci_MKAP: { + int i; + int stkoff = BCO_NEXT; + int n_payload = BCO_NEXT; + StgAP* ap = (StgAP*)Sp[stkoff]; + ASSERT((int)ap->n_args == n_payload); + ap->fun = (StgClosure*)Sp[0]; + + // The function should be a BCO, and its bitmap should + // cover the payload of the AP correctly. + ASSERT(get_itbl(ap->fun)->type == BCO + && BCO_BITMAP_SIZE(ap->fun) == ap->n_args); + + for (i = 0; i < n_payload; i++) + ap->payload[i] = (StgClosure*)Sp[i+1]; + Sp += n_payload+1; + IF_DEBUG(interpreter, + debugBelch("\tBuilt "); + printObj((StgClosure*)ap); + ); + goto nextInsn; + } -#define OP_FF_F(e) \ -{ \ - StgFloat x = PopTaggedFloat(); \ - StgFloat y = PopTaggedFloat(); \ - PushTaggedFloat(e); \ -} + case bci_MKPAP: { + int i; + int stkoff = BCO_NEXT; + int n_payload = BCO_NEXT; + StgPAP* pap = (StgPAP*)Sp[stkoff]; + ASSERT((int)pap->n_args == n_payload); + pap->fun = (StgClosure*)Sp[0]; + + // The function should be a BCO + ASSERT(get_itbl(pap->fun)->type == BCO); + + for (i = 0; i < n_payload; i++) + pap->payload[i] = (StgClosure*)Sp[i+1]; + Sp += n_payload+1; + IF_DEBUG(interpreter, + debugBelch("\tBuilt "); + printObj((StgClosure*)pap); + ); + goto nextInsn; + } -#define OP_F_F(e) \ -{ \ - StgFloat x = PopTaggedFloat(); \ - PushTaggedFloat(e); \ -} + case bci_UNPACK: { + /* Unpack N ptr words from t.o.s constructor */ + int i; + int n_words = BCO_NEXT; + StgClosure* con = (StgClosure*)Sp[0]; + Sp -= n_words; + for (i = 0; i < n_words; i++) { + Sp[i] = (W_)con->payload[i]; + } + goto nextInsn; + } -#define OP_F_B(e) \ -{ \ - StgFloat x = PopTaggedFloat(); \ - PushTaggedBool(e); \ -} + 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*)Sp[i]; + } + Sp += n_words; + Sp --; + Sp[0] = (W_)con; + IF_DEBUG(interpreter, + debugBelch("\tBuilt "); + printObj((StgClosure*)con); + ); + goto nextInsn; + } -#define OP_F_I(e) \ -{ \ - StgFloat x = PopTaggedFloat(); \ - PushTaggedInt(e); \ -} + case bci_TESTLT_P: { + unsigned int discr = BCO_NEXT; + int failto = BCO_NEXT; + StgClosure* con = (StgClosure*)Sp[0]; + if (GET_TAG(con) >= discr) { + bciPtr = failto; + } + goto nextInsn; + } -#define OP_F_D(e) \ -{ \ - StgFloat x = PopTaggedFloat(); \ - PushTaggedDouble(e); \ -} + case bci_TESTEQ_P: { + unsigned int discr = BCO_NEXT; + int failto = BCO_NEXT; + StgClosure* con = (StgClosure*)Sp[0]; + if (GET_TAG(con) != discr) { + bciPtr = failto; + } + goto nextInsn; + } -#define OP_DD_B(e) \ -{ \ - StgDouble x = PopTaggedDouble(); \ - StgDouble y = PopTaggedDouble(); \ - PushTaggedBool(e); \ -} + case bci_TESTLT_I: { + // There should be an Int at Sp[1], and an info table at Sp[0]. + int discr = BCO_NEXT; + int failto = BCO_NEXT; + I_ stackInt = (I_)Sp[1]; + if (stackInt >= (I_)BCO_LIT(discr)) + bciPtr = failto; + goto nextInsn; + } -#define OP_DD_D(e) \ -{ \ - StgDouble x = PopTaggedDouble(); \ - StgDouble y = PopTaggedDouble(); \ - PushTaggedDouble(e); \ -} + case bci_TESTEQ_I: { + // There should be an Int at Sp[1], and an info table at Sp[0]. + int discr = BCO_NEXT; + int failto = BCO_NEXT; + I_ stackInt = (I_)Sp[1]; + if (stackInt != (I_)BCO_LIT(discr)) { + bciPtr = failto; + } + goto nextInsn; + } -#define OP_D_B(e) \ -{ \ - StgDouble x = PopTaggedDouble(); \ - PushTaggedBool(e); \ -} + case bci_TESTLT_D: { + // There should be a Double at Sp[1], and an info table at Sp[0]. + int discr = BCO_NEXT; + int failto = BCO_NEXT; + StgDouble stackDbl, discrDbl; + stackDbl = PK_DBL( & Sp[1] ); + discrDbl = PK_DBL( & BCO_LIT(discr) ); + if (stackDbl >= discrDbl) { + bciPtr = failto; + } + goto nextInsn; + } -#define OP_D_D(e) \ -{ \ - StgDouble x = PopTaggedDouble(); \ - PushTaggedDouble(e); \ -} + case bci_TESTEQ_D: { + // There should be a Double at Sp[1], and an info table at Sp[0]. + int discr = BCO_NEXT; + int failto = BCO_NEXT; + StgDouble stackDbl, discrDbl; + stackDbl = PK_DBL( & Sp[1] ); + discrDbl = PK_DBL( & BCO_LIT(discr) ); + if (stackDbl != discrDbl) { + bciPtr = failto; + } + goto nextInsn; + } -#define OP_D_I(e) \ -{ \ - StgDouble x = PopTaggedDouble(); \ - PushTaggedInt(e); \ -} + case bci_TESTLT_F: { + // There should be a Float at Sp[1], and an info table at Sp[0]. + int discr = BCO_NEXT; + int failto = BCO_NEXT; + StgFloat stackFlt, discrFlt; + stackFlt = PK_FLT( & Sp[1] ); + discrFlt = PK_FLT( & BCO_LIT(discr) ); + if (stackFlt >= discrFlt) { + bciPtr = failto; + } + goto nextInsn; + } -#define OP_D_F(e) \ -{ \ - StgDouble x = PopTaggedDouble(); \ - PushTaggedFloat(e); \ -} + case bci_TESTEQ_F: { + // There should be a Float at Sp[1], and an info table at Sp[0]. + int discr = BCO_NEXT; + int failto = BCO_NEXT; + StgFloat stackFlt, discrFlt; + stackFlt = PK_FLT( & Sp[1] ); + discrFlt = PK_FLT( & BCO_LIT(discr) ); + if (stackFlt != discrFlt) { + bciPtr = failto; + } + goto nextInsn; + } + // Control-flow ish things + case bci_ENTER: + // Context-switch check. We put it here to ensure that + // the interpreter has done at least *some* work before + // context switching: sometimes the scheduler can invoke + // the interpreter with context_switch == 1, particularly + // if the -C0 flag has been given on the cmd line. + if (context_switch) { + Sp--; Sp[0] = (W_)&stg_enter_info; + RETURN_TO_SCHEDULER(ThreadInterpret, ThreadYielding); + } + goto eval; + + case bci_RETURN: + obj = (StgClosure *)Sp[0]; + Sp++; + goto do_return; + + case bci_RETURN_P: + Sp--; + Sp[0] = (W_)&stg_gc_unpt_r1_info; + goto do_return_unboxed; + case bci_RETURN_N: + Sp--; + Sp[0] = (W_)&stg_gc_unbx_r1_info; + goto do_return_unboxed; + case bci_RETURN_F: + Sp--; + Sp[0] = (W_)&stg_gc_f1_info; + goto do_return_unboxed; + case bci_RETURN_D: + Sp--; + Sp[0] = (W_)&stg_gc_d1_info; + goto do_return_unboxed; + case bci_RETURN_L: + Sp--; + Sp[0] = (W_)&stg_gc_l1_info; + goto do_return_unboxed; + case bci_RETURN_V: + Sp--; + Sp[0] = (W_)&stg_gc_void_info; + goto do_return_unboxed; + + case bci_SWIZZLE: { + int stkoff = BCO_NEXT; + signed short n = (signed short)(BCO_NEXT); + Sp[stkoff] += (W_)n; + goto nextInsn; + } -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; - } + case bci_CCALL: { + void *tok; + int stk_offset = BCO_NEXT; + int o_itbl = BCO_NEXT; + void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl); + int ret_dyn_size = + RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE + + sizeofW(StgRetDyn); + +#ifdef THREADED_RTS + // Threaded RTS: + // Arguments on the TSO stack are not good, because garbage + // collection might move the TSO as soon as we call + // suspendThread below. + + W_ arguments[stk_offset]; + + memcpy(arguments, Sp, sizeof(W_) * stk_offset); #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; -} - -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]) ); - } -} - -#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); \ -} - - - - -#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; \ - } \ -} + // Restore the Haskell thread's current value of errno + errno = cap->r.rCurrentTSO->saved_errno; + + // There are a bunch of non-ptr words on the stack (the + // ccall args, the ccall fun address and space for the + // result), which we need to cover with an info table + // since we might GC during this call. + // + // We know how many (non-ptr) words there are before the + // next valid stack frame: it is the stk_offset arg to the + // CCALL instruction. So we build a RET_DYN stack frame + // on the stack frame to describe this chunk of stack. + // + Sp -= ret_dyn_size; + ((StgRetDyn *)Sp)->liveness = NO_PTRS | N_NONPTRS(stk_offset); + ((StgRetDyn *)Sp)->info = (StgInfoTable *)&stg_gc_gen_info; + + SAVE_STACK_POINTERS; + tok = suspendThread(&cap->r); + +#ifndef THREADED_RTS + // Careful: + // suspendThread might have shifted the stack + // around (stack squeezing), so we have to grab the real + // Sp out of the TSO to find the ccall args again. + + marshall_fn ( (void*)(cap->r.rCurrentTSO->sp + ret_dyn_size) ); +#else + // Threaded RTS: + // We already made a copy of the arguments above. -__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: -} + marshall_fn ( arguments ); +#endif + // And restart the thread again, popping the RET_DYN frame. + cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - sizeof(StgFunTable))); + LOAD_STACK_POINTERS; + Sp += ret_dyn_size; + + // Save the Haskell thread's current value of errno + cap->r.rCurrentTSO->saved_errno = errno; + +#ifdef THREADED_RTS + // Threaded RTS: + // Copy the "arguments", which might include a return value, + // back to the TSO stack. It would of course be enough to + // just copy the return value, but we don't know the offset. + memcpy(Sp, arguments, sizeof(W_) * stk_offset); +#endif -/* -------------------------------------------------------------------------- - * The new bytecode interpreter - * ------------------------------------------------------------------------*/ + goto nextInsn; + } -/* Sp points to the lowest live word on the stack. */ + case bci_JMP: { + /* BCO_NEXT modifies bciPtr, so be conservative. */ + int nextpc = BCO_NEXT; + bciPtr = nextpc; + goto nextInsn; + } -#define StackWord(n) ((W_*)Sp)[n] -#define BCO_NEXT bco_instrs[bciPtr++] -#define BCO_PTR(n) bco_ptrs[n] + case bci_CASEFAIL: + barf("interpretBCO: hit a CASEFAIL"); + + // Errors + default: + barf("interpretBCO: unknown or unimplemented opcode"); + } /* switch on opcode */ + } + } -{ - 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("interpretBCO: fell off end of the interpreter"); } - 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 */