X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FEvaluator.c;h=87e561682e60265f190dcc4e36232fe69d275e62;hb=bd2fb1c5eacc886737afd72cc889386e00ed5d23;hp=5a6b0bccb63aeffcb866e2e2df494119d63c920b;hpb=9da01c710daee2cd5038afb8fad761cdaf343033;p=ghc-hetmet.git diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c index 5a6b0bc..87e5616 100644 --- a/ghc/rts/Evaluator.c +++ b/ghc/rts/Evaluator.c @@ -5,8 +5,8 @@ * Copyright (c) 1994-1998. * * $RCSfile: Evaluator.c,v $ - * $Revision: 1.11 $ - * $Date: 1999/03/09 14:51:21 $ + * $Revision: 1.25 $ + * $Date: 1999/11/08 15:30:33 $ * ---------------------------------------------------------------------------*/ #include "Rts.h" @@ -19,18 +19,15 @@ #include "Storage.h" #include "SchedAPI.h" /* for createGenThread */ #include "Schedule.h" /* for context_switch */ - #include "Bytecodes.h" #include "Assembler.h" /* for CFun stuff */ #include "ForeignCall.h" -#include "StablePriv.h" #include "PrimOps.h" /* for __{encode,decode}{Float,Double} */ #include "Evaluator.h" #ifdef DEBUG #include "Printer.h" #include "Disassembler.h" - #include "Sanity.h" #include "StgRun.h" #endif @@ -41,8 +38,11 @@ #ifdef HAVE_IEEE754_H #include /* These are for primops */ #endif -#ifdef PROVIDE_INTEGER -#include "gmp.h" /* These are for primops */ + +#ifdef STANDALONE_INTEGER +#include "sainteger.h" +#else +#error Non-standalone integer not yet supported #endif /* An incredibly useful abbreviation. @@ -60,552 +60,1871 @@ #define mycat2(x,y) mycat(x,y) #define mycat3(x,y,z) mycat2(x,mycat2(y,z)) -/* -------------------------------------------------------------------------- - * Hugs Hooks - a bit of a hack - * ------------------------------------------------------------------------*/ +#if defined(__GNUC__) && !defined(DEBUG) +#define USE_GCC_LABELS 1 +#else +#define USE_GCC_LABELS 0 +#endif + +/* Make it possible for the evaluator to get hold of bytecode + for a given function by name. Useful but a hack. Sigh. + */ +extern void* getHugs_AsmObject_for ( char* s ); -void setRtsFlags( int x ); -void setRtsFlags( int x ) -{ - *(int*)(&(RtsFlags.DebugFlags)) = x; -} /* -------------------------------------------------------------------------- - * RTS Hooks - * - * ToDo: figure out why these are being used and crush them! + * Crude profiling stuff (mainly to assess effect of optimiser) * ------------------------------------------------------------------------*/ -void OnExitHook (void) -{ -} -void StackOverflowHook (unsigned long stack_size) +#ifdef CRUDE_PROFILING + +#define M_CPTAB 10000 +#define CP_NIL (-1) + +int cpInUse = -1; +int cpCurr; + +typedef + struct { int /*StgVar*/ who; + int /*StgVar*/ twho; + int enters; + int bytes; + int insns; + } + CPRecord; + +CPRecord cpTab[M_CPTAB]; + +void cp_init ( void ) { - fprintf(stderr,"Stack Overflow\n"); - exit(1); + int i; + cpCurr = CP_NIL; + cpInUse = 0; + for (i = 0; i < M_CPTAB; i++) + cpTab[i].who = CP_NIL; } -void OutOfHeapHook (unsigned long request_size, unsigned long heap_size) + + +void cp_enter ( StgBCO* b ) { - fprintf(stderr,"Out Of Heap\n"); - exit(1); + int is_ret_cont; + int h; + int /*StgVar*/ v = b->stgexpr; + if ((void*)v == NULL) return; + + is_ret_cont = 0; + if (v > 500000000) { + is_ret_cont = 1; + v -= 1000000000; + } + + if (v < 0) + h = (-v) % M_CPTAB; else + h = v % M_CPTAB; + + assert (h >= 0 && h < M_CPTAB); + while (cpTab[h].who != v && cpTab[h].who != CP_NIL) { + h++; if (h == M_CPTAB) h = 0; + }; + cpCurr = h; + if (cpTab[cpCurr].who == CP_NIL) { + cpTab[cpCurr].who = v; + if (!is_ret_cont) cpTab[cpCurr].enters = 1; + cpTab[cpCurr].bytes = cpTab[cpCurr].insns = 0; + cpInUse++; + if (cpInUse * 2 > M_CPTAB) { + fprintf(stderr, "\nCRUDE_PROFILING hash table is too full\n" ); + assert(0); + } + } else { + if (!is_ret_cont) cpTab[cpCurr].enters++; + } + + } -void MallocFailHook (unsigned long request_size /* in bytes */, char *msg) + +void cp_bill_words ( int nw ) { - fprintf(stderr,"Malloc Fail\n"); - exit(1); + if (cpCurr == CP_NIL) return; + cpTab[cpCurr].bytes += sizeof(StgWord)*nw; } -void defaultsHook (void) + + +void cp_bill_insns ( int ni ) { - /* do nothing */ + if (cpCurr == CP_NIL) return; + cpTab[cpCurr].insns += ni; } -/* -------------------------------------------------------------------------- - * MPZ helpers - * ------------------------------------------------------------------------*/ - -#ifdef PROVIDE_INTEGER -static inline mpz_ptr mpz_alloc ( void ); -//static inline void mpz_free ( mpz_ptr ); -static inline mpz_ptr mpz_alloc ( void ) +static double percent ( double a, double b ) { - mpz_ptr r = stgCast(mpz_ptr,stgMallocBytes( sizeof(mpz_t),"mpz_alloc")); - mpz_init(r); - return r; + return (100.0 * a) / b; } -#if 0 /* apparently unused */ -static inline void mpz_free ( mpz_ptr a ) + +void cp_show ( void ) { - mpz_clear(a); - free(a); -} -#endif -#endif + int i, j, max, maxN, totE, totB, totI, cumE, cumB, cumI; + char nm[200]; -/* -------------------------------------------------------------------------- - * - * ------------------------------------------------------------------------*/ + if (cpInUse == -1) return; -/*static*/ inline void PushTag ( StackTag t ); -/*static*/ inline void PushPtr ( StgPtr x ); -/*static*/ inline void PushCPtr ( StgClosure* x ); -/*static*/ inline void PushInt ( StgInt x ); -/*static*/ inline void PushWord ( StgWord x ); - -/*static*/ inline void PushTag ( StackTag t ) { *(--Sp) = t; } -/*static*/ inline void PushPtr ( StgPtr x ) { *(--stgCast(StgPtr*,Sp)) = x; } -/*static*/ inline void PushCPtr ( StgClosure* x ) { *(--stgCast(StgClosure**,Sp)) = x; } -/*static*/ inline void PushInt ( StgInt x ) { *(--stgCast(StgInt*,Sp)) = x; } -/*static*/ inline void PushWord ( StgWord x ) { *(--stgCast(StgWord*,Sp)) = x; } - -/*static*/ inline void checkTag ( StackTag t1, StackTag t2 ); -/*static*/ inline void PopTag ( StackTag t ); -/*static*/ inline StgPtr PopPtr ( void ); -/*static*/ inline StgClosure* PopCPtr ( void ); -/*static*/ inline StgInt PopInt ( void ); -/*static*/ inline StgWord PopWord ( void ); - -/*static*/ inline void checkTag ( StackTag t1, StackTag t2 ) { ASSERT(t1 == t2);} -/*static*/ inline void PopTag ( StackTag t ) { checkTag(t,*(Sp++)); } -/*static*/ inline StgPtr PopPtr ( void ) { return *stgCast(StgPtr*,Sp)++; } -/*static*/ inline StgClosure* PopCPtr ( void ) { return *stgCast(StgClosure**,Sp)++; } -/*static*/ inline StgInt PopInt ( void ) { return *stgCast(StgInt*,Sp)++; } -/*static*/ inline StgWord PopWord ( void ) { return *stgCast(StgWord*,Sp)++; } - -/*static*/ inline StgPtr stackPtr ( StgStackOffset i ); -/*static*/ inline StgInt stackInt ( StgStackOffset i ); -/*static*/ inline StgWord stackWord ( StgStackOffset i ); - -/*static*/ inline StgPtr stackPtr ( StgStackOffset i ) { return *stgCast(StgPtr*, Sp+i); } -/*static*/ inline StgInt stackInt ( StgStackOffset i ) { return *stgCast(StgInt*, Sp+i); } -/*static*/ inline StgWord stackWord ( StgStackOffset i ) { return *stgCast(StgWord*,Sp+i); } - -/*static*/ inline void setStackWord ( StgStackOffset i, StgWord w ); + fflush(stdout);fflush(stderr); + printf ( "\n\n" ); -/*static*/ inline void setStackWord ( StgStackOffset i, StgWord w ) { Sp[i] = w; } - -/*static*/ inline void PushTaggedRealWorld( void ); -/*static*/ inline void PushTaggedInt ( StgInt x ); -#ifdef PROVIDE_INT64 -/*static*/ inline void PushTaggedInt64 ( StgInt64 x ); -#endif -#ifdef PROVIDE_INTEGER -/*static*/ inline void PushTaggedInteger ( mpz_ptr x ); -#endif -#ifdef PROVIDE_WORD -/*static*/ inline void PushTaggedWord ( StgWord x ); -#endif -#ifdef PROVIDE_ADDR -/*static*/ inline void PushTaggedAddr ( StgAddr x ); -#endif -/*static*/ inline void PushTaggedChar ( StgChar x ); -/*static*/ inline void PushTaggedFloat ( StgFloat x ); -/*static*/ inline void PushTaggedDouble ( StgDouble x ); -/*static*/ inline void PushTaggedStablePtr ( StgStablePtr x ); -/*static*/ inline void PushTaggedBool ( int x ); - -/*static*/ inline void PushTaggedRealWorld( void ) { PushTag(REALWORLD_TAG); } -/*static*/ inline void PushTaggedInt ( StgInt x ) { Sp -= sizeofW(StgInt); *Sp = x; PushTag(INT_TAG); } -#ifdef PROVIDE_INT64 -/*static*/ inline void PushTaggedInt64 ( StgInt64 x ) { Sp -= sizeofW(StgInt64); ASSIGN_Int64(Sp,x); PushTag(INT64_TAG); } -#endif -#ifdef PROVIDE_INTEGER -/*static*/ inline void PushTaggedInteger ( mpz_ptr x ) -{ - StgForeignObj *result; - //StgWeak *w; - - result = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj))); - SET_HDR(result,&FOREIGN_info,CCCS); - result -> data = x; - -#if 0 /* For now we don't deallocate Integer's at all */ - w = stgCast(StgWeak*,allocate(sizeofW(StgWeak))); - SET_HDR(w, &WEAK_info, CCCS); - w->key = stgCast(StgClosure*,result); - w->value = stgCast(StgClosure*,result); /* or any other closure you have handy */ - w->finaliser = funPtrToIO(mpz_free); - w->link = weak_ptr_list; - weak_ptr_list = w; - IF_DEBUG(weak, fprintf(stderr,"New weak pointer watching Foreign MPZ at %p\n",w)); -#endif + totE = totB = totI = 0; + for (i = 0; i < M_CPTAB; i++) { + cpTab[i].twho = cpTab[i].who; + if (cpTab[i].who != CP_NIL) { + totE += cpTab[i].enters; + totB += cpTab[i].bytes; + totI += cpTab[i].insns; + } + } + + printf ( "Totals: " + "%6d (%7.3f M) enters, " + "%6d (%7.3f M) insns, " + "%6d (%7.3f M) bytes\n\n", + totE, totE/1000000.0, totI, totI/1000000.0, totB, totB/1000000.0 ); + + cumE = cumB = cumI = 0; + for (j = 0; j < 32; j++) { + + maxN = max = -1; + for (i = 0; i < M_CPTAB; i++) + if (cpTab[i].who != CP_NIL && + cpTab[i].enters > maxN) { + maxN = cpTab[i].enters; + max = i; + } + if (max == -1) break; + + cumE += cpTab[max].enters; + cumB += cpTab[max].bytes; + cumI += cpTab[max].insns; + + strcpy(nm, maybeName(cpTab[max].who)); + if (strcmp(nm, "(unknown)")==0) + sprintf ( nm, "id%d", -cpTab[max].who); + + printf ( "%20s %7d es (%4.1f%%, %4.1f%% c) " + "%7d bs (%4.1f%%, %4.1f%% c) " + "%7d is (%4.1f%%, %4.1f%% c)\n", + nm, + cpTab[max].enters, percent(cpTab[max].enters,totE), percent(cumE,totE), + cpTab[max].bytes, percent(cpTab[max].bytes,totB), percent(cumB,totB), + cpTab[max].insns, percent(cpTab[max].insns,totI), percent(cumI,totI) + ); - PushPtr(stgCast(StgPtr,result)); -} -#endif -#ifdef PROVIDE_WORD -/*static*/ inline void PushTaggedWord ( StgWord x ) { Sp -= sizeofW(StgWord); *Sp = x; PushTag(WORD_TAG); } -#endif -#ifdef PROVIDE_ADDR -/*static*/ inline void PushTaggedAddr ( StgAddr x ) { Sp -= sizeofW(StgAddr); *Sp = (W_)x; PushTag(ADDR_TAG); } -#endif -/*static*/ inline void PushTaggedChar ( StgChar x ) -{ Sp -= sizeofW(StgChar); *Sp = stgCast(StgWord,x); PushTag(CHAR_TAG); } - -/*static*/ inline void PushTaggedFloat ( StgFloat x ) { Sp -= sizeofW(StgFloat); ASSIGN_FLT(Sp,x); PushTag(FLOAT_TAG); } -/*static*/ inline void PushTaggedDouble ( StgDouble x ) { Sp -= sizeofW(StgDouble); ASSIGN_DBL(Sp,x); PushTag(DOUBLE_TAG); } -/*static*/ inline void PushTaggedStablePtr ( StgStablePtr x ) { Sp -= sizeofW(StgStablePtr); *Sp = x; PushTag(STABLE_TAG); } -/*static*/ inline void PushTaggedBool ( int x ) { PushTaggedInt(x); } - -/*static*/ inline void PopTaggedRealWorld ( void ); -/*static*/ inline StgInt PopTaggedInt ( void ); -#ifdef PROVIDE_INT64 -/*static*/ inline StgInt64 PopTaggedInt64 ( void ); -#endif -#ifdef PROVIDE_INTEGER -/*static*/ inline mpz_ptr PopTaggedInteger ( void ); -#endif -#ifdef PROVIDE_WORD -/*static*/ inline StgWord PopTaggedWord ( void ); -#endif -#ifdef PROVIDE_ADDR -/*static*/ inline StgAddr PopTaggedAddr ( void ); -#endif -/*static*/ inline StgChar PopTaggedChar ( void ); -/*static*/ inline StgFloat PopTaggedFloat ( void ); -/*static*/ inline StgDouble PopTaggedDouble ( void ); -/*static*/ inline StgStablePtr PopTaggedStablePtr ( void ); - -/*static*/ inline void PopTaggedRealWorld ( void ) { PopTag(REALWORLD_TAG); } -/*static*/ inline StgInt PopTaggedInt ( void ) { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, Sp); Sp += sizeofW(StgInt); return r;} -#ifdef PROVIDE_INT64 -/*static*/ inline StgInt64 PopTaggedInt64 ( void ) { StgInt64 r; PopTag(INT64_TAG); r = PK_Int64(Sp); Sp += sizeofW(StgInt64); return r;} -#endif -#ifdef PROVIDE_INTEGER -/*static*/ inline mpz_ptr PopTaggedInteger ( void ) { StgForeignObj *r = *stgCast(StgForeignObj**,Sp); Sp += sizeofW(StgPtr); return stgCast(mpz_ptr,r->data);} -#endif -#ifdef PROVIDE_WORD -/*static*/ inline StgWord PopTaggedWord ( void ) { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, Sp); Sp += sizeofW(StgWord); return r;} -#endif -#ifdef PROVIDE_ADDR -/*static*/ inline StgAddr PopTaggedAddr ( void ) { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, Sp); Sp += sizeofW(StgAddr); return r;} -#endif -/*static*/ inline StgChar PopTaggedChar ( void ) { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *Sp); Sp += sizeofW(StgChar); return r;} -/*static*/ inline StgFloat PopTaggedFloat ( void ) { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(Sp); Sp += sizeofW(StgFloat); return r;} -/*static*/ inline StgDouble PopTaggedDouble ( void ) { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(Sp); Sp += sizeofW(StgDouble); return r;} -/*static*/ inline StgStablePtr PopTaggedStablePtr ( void ) { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, Sp); Sp += sizeofW(StgStablePtr); return r;} - -/*static*/ inline StgInt taggedStackInt ( StgStackOffset i ); -#ifdef PROVIDE_INT64 -/*static*/ inline StgInt64 taggedStackInt64 ( StgStackOffset i ); -#endif -#ifdef PROVIDE_WORD -/*static*/ inline StgWord taggedStackWord ( StgStackOffset i ); -#endif -#ifdef PROVIDE_ADDR -/*static*/ inline StgAddr taggedStackAddr ( StgStackOffset i ); -#endif -/*static*/ inline StgChar taggedStackChar ( StgStackOffset i ); -/*static*/ inline StgFloat taggedStackFloat ( StgStackOffset i ); -/*static*/ inline StgDouble taggedStackDouble ( StgStackOffset i ); -/*static*/ inline StgStablePtr taggedStackStable ( StgStackOffset i ); - -/*static*/ inline StgInt taggedStackInt ( StgStackOffset i ) { checkTag(INT_TAG,Sp[i]); return *stgCast(StgInt*, Sp+1+i); } -#ifdef PROVIDE_INT64 -/*static*/ inline StgInt64 taggedStackInt64 ( StgStackOffset i ) { checkTag(INT64_TAG,Sp[i]); return PK_Int64(Sp+1+i); } -#endif -#ifdef PROVIDE_WORD -/*static*/ inline StgWord taggedStackWord ( StgStackOffset i ) { checkTag(WORD_TAG,Sp[i]); return *stgCast(StgWord*, Sp+1+i); } -#endif -#ifdef PROVIDE_ADDR -/*static*/ inline StgAddr taggedStackAddr ( StgStackOffset i ) { checkTag(ADDR_TAG,Sp[i]); return *stgCast(StgAddr*, Sp+1+i); } -#endif + cpTab[max].twho = cpTab[max].who; + cpTab[max].who = CP_NIL; + } -/*static*/ inline StgChar taggedStackChar ( StgStackOffset i ) { checkTag(CHAR_TAG,Sp[i]); return stgCast(StgChar, *(Sp+1+i)) ; } + for (i = 0; i < M_CPTAB; i++) + cpTab[i].who = cpTab[i].twho; + printf ( "\n" ); +} -/*static*/ inline StgFloat taggedStackFloat ( StgStackOffset i ) { checkTag(FLOAT_TAG,Sp[i]); return PK_FLT(Sp+1+i); } -/*static*/ inline StgDouble taggedStackDouble ( StgStackOffset i ) { checkTag(DOUBLE_TAG,Sp[i]); return PK_DBL(Sp+1+i); } -/*static*/ inline StgStablePtr taggedStackStable ( StgStackOffset i ) { checkTag(STABLE_TAG,Sp[i]); return *stgCast(StgStablePtr*, Sp+1+i); } +#endif /* -------------------------------------------------------------------------- - * 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) + * Hugs Hooks - a bit of a hack * ------------------------------------------------------------------------*/ -static inline StgPtr grabHpUpd( nat size ) +void setRtsFlags( int x ); +void setRtsFlags( int x ) { - ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) ); - return allocate(size); + 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; + } } -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 + * Entering-objects and bytecode interpreter part of evaluator * ------------------------------------------------------------------------*/ +/* 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* ); static inline void PopUpdateFrame ( StgClosure* obj ); -static inline void PushCatchFrame ( StgClosure* catcher ); static inline void PopCatchFrame ( void ); -static inline void PushSeqFrame ( 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* errObj ); -static inline StgClosure* raiseAnError ( StgClosure* errObj ); - -static inline void PopUpdateFrame( StgClosure* obj ) -{ - /* NB: doesn't assume that Sp == Su */ - IF_DEBUG(evaluator, - fprintf(stderr, "Updating "); - printPtr(stgCast(StgPtr,Su->updatee)); - fprintf(stderr, " with "); - printObj(obj); - fprintf(stderr,"Sp = %p\tSu = %p\n\n", Sp, Su); - ); -#ifndef LAZY_BLACKHOLING - ASSERT(get_itbl(Su->updatee)->type == BLACKHOLE - || get_itbl(Su->updatee)->type == CAF_BLACKHOLE - ); -#endif /* LAZY_BLACKHOLING */ - UPD_IND(Su->updatee,obj); - Sp = stgCast(StgStackPtr,Su) + sizeofW(StgUpdateFrame); - Su = Su->link; -} - -static inline void PopStopFrame( StgClosure* obj ) -{ - /* Move Su just off the end of the stack, we're about to spam the - * STOP_FRAME with the return value. - */ - Su = stgCast(StgUpdateFrame*,Sp+1); - *stgCast(StgClosure**,Sp) = obj; -} - -static inline void PushCatchFrame( StgClosure* handler ) -{ - StgCatchFrame* fp; - /* ToDo: stack check! */ - Sp -= sizeofW(StgCatchFrame); - fp = stgCast(StgCatchFrame*,Sp); - SET_HDR(fp,&catch_frame_info,CCCS); - fp->handler = handler; - fp->link = Su; - Su = stgCast(StgUpdateFrame*,fp); -} +static int enterCountI = 0; -static inline void PopCatchFrame( void ) -{ - /* NB: doesn't assume that Sp == Su */ - /* fprintf(stderr,"Popping catch frame\n"); */ - Sp = stgCast(StgStackPtr,Su) + sizeofW(StgCatchFrame); - Su = stgCast(StgCatchFrame*,Su)->link; -} +#ifdef STANDALONE_INTEGER +StgDouble B__encodeDouble (B* s, I_ e); +void B__decodeDouble (B* man, I_* exp, StgDouble dbl); +#if ! FLOATS_AS_DOUBLES +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 ); +#endif +#endif -static inline void PushSeqFrame( void ) -{ - StgSeqFrame* fp; - /* ToDo: stack check! */ - Sp -= sizeofW(StgSeqFrame); - fp = stgCast(StgSeqFrame*,Sp); - SET_HDR(fp,&seq_frame_info,CCCS); - fp->link = Su; - Su = stgCast(StgUpdateFrame*,fp); -} -static inline void PopSeqFrame( void ) -{ - /* NB: doesn't assume that Sp == Su */ - Sp = stgCast(StgStackPtr,Su) + sizeofW(StgSeqFrame); - Su = stgCast(StgSeqFrame*,Su)->link; -} -static inline StgClosure* raiseAnError( StgClosure* errObj ) -{ - StgClosure *raise_closure; - /* This closure represents the expression 'raise# E' where E - * is the exception raised. It is used to overwrite all the - * thunks which are currently under evaluataion. - */ - raise_closure = (StgClosure *)allocate(sizeofW(StgClosure)+1); - raise_closure->header.info = &raise_info; - raise_closure->payload[0] = R1.cl; +#define gSp MainRegTable.rSp +#define gSu MainRegTable.rSu +#define gSpLim MainRegTable.rSpLim - while (1) { - switch (get_itbl(Su)->type) { - case UPDATE_FRAME: - UPD_IND(Su->updatee,raise_closure); - Sp = stgCast(StgStackPtr,Su) + sizeofW(StgUpdateFrame); - Su = Su->link; - break; - case SEQ_FRAME: - PopSeqFrame(); - break; - case CATCH_FRAME: /* found it! */ - { - StgCatchFrame* fp = stgCast(StgCatchFrame*,Su); - StgClosure *handler = fp->handler; - Su = fp->link; - Sp += sizeofW(StgCatchFrame); /* Pop */ - PushCPtr(errObj); - return handler; - } - case STOP_FRAME: - barf("raiseError: uncaught exception: STOP_FRAME"); - default: - barf("raiseError: weird activation record"); - } - } -} -static StgClosure* raisePrim(char* msg) -{ - /* ToDo: figure out some way to turn the msg into a Haskell Exception - * Hack: we don't know how to build an Exception but we do know how - * to build a (recursive!) error object. - * The result isn't pretty but it's (slightly) better than nothing. - */ - nat size = sizeof(StgClosure) + 1; - StgClosure* errObj = stgCast(StgClosure*,grabHpNonUpd(size)); - SET_INFO(errObj,&raise_info); - errObj->payload[0] = errObj; -fprintf(stderr, "\n\n\nRAISE PRIM %s\n", msg); -#if 0 - belch(msg); +/* 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 - /* At the moment, I prefer to put it on stdout to make things as - * close to Hugs' old behaviour as possible. - */ - fprintf(stdout, "Program error: %s", msg); - fflush(stdout); +#define SSS { gSp = xSp; gSu = xSu; gSpLim = xSpLim; } +#define LLL { xSp = gSp; xSu = gSu; xSpLim = gSpLim; } #endif - return raiseAnError(stgCast(StgClosure*,errObj)); -} -#define raiseIndex(where) raisePrim("Array index out of range in " where) -#define raiseDiv0(where) raisePrim("Division by 0 in " where) +#define RETURN(vvv) { \ + StgThreadReturnCode retVal=(vvv); \ + SSS; \ + cap->rCurrentTSO->sp = gSp; \ + cap->rCurrentTSO->su = gSu; \ + cap->rCurrentTSO->splim = gSpLim; \ + return retVal; \ + } -/* -------------------------------------------------------------------------- - * Evaluator - * ------------------------------------------------------------------------*/ -#define OP_CC_B(e) \ -{ \ - unsigned char x = PopTaggedChar(); \ - unsigned char y = PopTaggedChar(); \ - PushTaggedBool(e); \ -} +/* Macros to operate directly on the pulled-out machine state. + These mirror some of the small procedures used in the primop code + below, except you have to be careful about side effects, + ie xPushPtr(xStackPtr(n)) won't work! It certainly isn't the + same as PushPtr(StackPtr(n)). Also note that (1) some of + the macros, in particular xPopTagged*, do not make the tag + sanity checks that their non-x cousins do, and (2) some of + the macros depend critically on the semantics of C comma + expressions to work properly. +*/ +#define xPushPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); } +#define xPopPtr() ((StgPtr)(*xSp++)) + +#define xPushCPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); } +#define xPopCPtr() ((StgClosure*)(*xSp++)) + +#define xPushWord(ppp) { xSp--; *xSp=(StgWord)(ppp); } +#define xPopWord() ((StgWord)(*xSp++)) + +#define xStackPtr(nnn) ((StgPtr)(*(xSp+(nnn)))) +#define xStackWord(nnn) ((StgWord)(*(xSp+(nnn)))) +#define xSetStackWord(iii,www) xSp[iii]=(StgWord)(www) + +#define xPushTag(ttt) { xSp--; *xSp=(StgWord)(ttt); } +#define xPopTag(ttt) { StackTag t = (StackTag)(*xSp++); \ + ASSERT(t == ttt); } + +#define xPushTaggedInt(xxx) { xSp -= sizeofW(StgInt); \ + *xSp = (xxx); xPushTag(INT_TAG); } +#define xTaggedStackInt(iii) ((StgInt)(*(xSp+1+(iii)))) +#define xPopTaggedInt() ((xSp++,xSp+=sizeofW(StgInt), \ + (StgInt)(*(xSp-sizeofW(StgInt))))) + +#define xPushTaggedWord(xxx) { xSp -= sizeofW(StgWord); \ + *xSp = (xxx); xPushTag(WORD_TAG); } +#define xTaggedStackWord(iii) ((StgWord)(*(xSp+1+(iii)))) +#define xPopTaggedWord() ((xSp++,xSp+=sizeofW(StgWord), \ + (StgWord)(*(xSp-sizeofW(StgWord))))) + +#define xPushTaggedAddr(xxx) { xSp -= sizeofW(StgAddr); \ + *xSp = (StgWord)(xxx); xPushTag(ADDR_TAG); } +#define xTaggedStackAddr(iii) ((StgAddr)(*(xSp+1+(iii)))) +#define xPopTaggedAddr() ((xSp++,xSp+=sizeofW(StgAddr), \ + (StgAddr)(*(xSp-sizeofW(StgAddr))))) + +#define xPushTaggedStable(xxx) { xSp -= sizeofW(StgStablePtr); \ + *xSp = (StgWord)(xxx); xPushTag(STABLE_TAG); } +#define xTaggedStackStable(iii) ((StgStablePtr)(*(xSp+1+(iii)))) +#define xPopTaggedStable() ((xSp++,xSp+=sizeofW(StgStablePtr), \ + (StgStablePtr)(*(xSp-sizeofW(StgStablePtr))))) + +#define xPushTaggedChar(xxx) { xSp -= sizeofW(StgChar); \ + *xSp = (StgWord)(xxx); xPushTag(CHAR_TAG); } +#define xTaggedStackChar(iii) ((StgChar)(*(xSp+1+(iii)))) +#define xPopTaggedChar() ((xSp++,xSp+=sizeofW(StgChar), \ + (StgChar)(*(xSp-sizeofW(StgChar))))) + +#define xPushTaggedFloat(xxx) { xSp -= sizeofW(StgFloat); \ + ASSIGN_FLT(xSp,xxx); xPushTag(FLOAT_TAG); } +#define xTaggedStackFloat(iii) PK_FLT(xSp+1+(iii)) +#define xPopTaggedFloat() ((xSp++,xSp+=sizeofW(StgFloat), \ + PK_FLT(xSp-sizeofW(StgFloat)))) + +#define xPushTaggedDouble(xxx) { xSp -= sizeofW(StgDouble); \ + ASSIGN_DBL(xSp,xxx); xPushTag(DOUBLE_TAG); } +#define xTaggedStackDouble(iii) PK_DBL(xSp+1+(iii)) +#define xPopTaggedDouble() ((xSp++,xSp+=sizeofW(StgDouble), \ + PK_DBL(xSp-sizeofW(StgDouble)))) + + +#define xPushUpdateFrame(target, xSp_offset) \ +{ \ + StgUpdateFrame *__frame; \ + __frame = (StgUpdateFrame *)(xSp + (xSp_offset)) - 1; \ + SET_INFO(__frame, (StgInfoTable *)&Upd_frame_info); \ + __frame->link = xSu; \ + __frame->updatee = (StgClosure *)(target); \ + xSu = __frame; \ +} + +#define xPopUpdateFrame(ooo) \ +{ \ + /* NB: doesn't assume that Sp == Su */ \ + IF_DEBUG(evaluator, \ + fprintf(stderr, "Updating "); \ + printPtr(stgCast(StgPtr,xSu->updatee)); \ + fprintf(stderr, " with "); \ + printObj(ooo); \ + fprintf(stderr,"xSp = %p\txSu = %p\n\n", xSp, xSu); \ + ); \ + UPD_IND(xSu->updatee,ooo); \ + xSp = stgCast(StgStackPtr,xSu) + sizeofW(StgUpdateFrame); \ + xSu = xSu->link; \ +} + + + +/* Instruction stream macros */ +#define BCO_INSTR_8 *bciPtr++ +#define BCO_INSTR_16 ((bciPtr += 2, (*(bciPtr-2) << 8) + *(bciPtr-1))) +#define PC (bciPtr - &(bcoInstr(bco,0))) + + +/* State on entry to enter(): + * - current thread is in cap->rCurrentTSO; + * - allocation area is in cap->rCurrentNursery & cap->rNursery + */ -#define OP_C_I(e) \ -{ \ - unsigned char x = PopTaggedChar(); \ - PushTaggedInt(e); \ -} +StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) +{ + /* use of register here is primarily to make it clear to compilers + that these entities are non-aliasable. + */ + register StgPtr xSp; /* local state -- stack pointer */ + register StgUpdateFrame* xSu; /* local state -- frame pointer */ + register StgPtr xSpLim; /* local state -- stack lim pointer */ + register StgClosure* obj; /* object currently under evaluation */ + char eCount; /* enter counter, for context switching */ -#define OP__I(e) \ -{ \ - PushTaggedInt(e); \ -} +#ifdef DEBUG + StgPtr tSp; StgUpdateFrame* tSu; StgPtr tSpLim; +#endif -#define OP_IW_I(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - StgWord y = PopTaggedWord(); \ - PushTaggedInt(e); \ -} + gSp = cap->rCurrentTSO->sp; + gSu = cap->rCurrentTSO->su; + gSpLim = cap->rCurrentTSO->splim; -#define OP_II_I(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - StgInt y = PopTaggedInt(); \ - PushTaggedInt(e); \ -} +#ifdef DEBUG + /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */ + tSp = gSp; tSu = gSu; tSpLim = gSpLim; +#endif -#define OP_II_B(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - StgInt y = PopTaggedInt(); \ - PushTaggedBool(e); \ -} + obj = obj0; + eCount = 0; -#define OP__A(e) \ -{ \ - PushTaggedAddr(e); \ -} + /* 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; -#define OP_I_A(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - PushTaggedAddr(e); \ -} + enterLoop: -#define OP_I_I(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - PushTaggedInt(e); \ -} +#ifdef DEBUG + assert(gSp == tSp); + assert(gSu == tSu); + assert(gSpLim == tSpLim); + IF_DEBUG(evaluator, + SSS; + enterCountI++; + ASSERT(xSpLim <= xSp && xSp <= stgCast(StgPtr,xSu)); + fprintf(stderr, + "\n---------------------------------------------------------------\n"); + fprintf(stderr,"(%d) Entering: ",enterCountI); printObj(obj); + fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu); + fprintf(stderr, "\n" ); + printStack(xSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,xSu); + fprintf(stderr, "\n\n"); + LLL; + ); +#endif -#define OP__C(e) \ -{ \ - PushTaggedChar(e); \ -} + if ( +#ifdef DEBUG + 1 || +#endif + ++eCount == 0) { + if (context_switch) { + xPushCPtr(obj); /* code to restart with */ + RETURN(ThreadYielding); + } + } -#define OP_I_C(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - PushTaggedChar(e); \ -} + switch ( get_itbl(obj)->type ) { + case INVALID_OBJECT: + barf("Invalid object %p",obj); -#define OP__W(e) \ -{ \ - PushTaggedWord(e); \ -} + case BCO: bco_entry: -#define OP_I_W(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - PushTaggedWord(e); \ -} + /* ---------------------------------------------------- */ + /* 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); + } -#define OP__F(e) \ -{ \ - PushTaggedFloat(e); \ -} +# if CRUDE_PROFILING + cp_enter ( bco ); +# endif + + + 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; + ); + +# if CRUDE_PROFILING + SSS; cp_bill_insns(1); LLL; +# endif + + 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: + SSS; PopStopFrame(obj); LLL; + RETURN(ThreadFinished); + 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_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) { + payloadCPtr(o,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) { + payloadCPtr(o,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(stgCast(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(payloadCPtr(o,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; + } + 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_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_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_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) = 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): + { + /* Remember to save */ + 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 ); + LLL; + bco = bco_tmp; + bciPtr = &(bcoInstr(bco,pc_saved)); + if (p) { + if (trc == 12345678) { + /* we want to enter p */ + obj = p; goto enterLoop; + } else { + /* p is the the StgThreadReturnCode for this thread */ + RETURN((StgThreadReturnCode)p); + }; + } + 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; + } -#define OP_I_F(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - PushTaggedFloat(e); \ -} -#define OP__D(e) \ -{ \ - PushTaggedDouble(e); \ -} + 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_CONST_ADDR_big): + Case(i_VAR_ADDR_big): + Case(i_CONST_INTEGER_big): + Case(i_CONST_INT_big): + Case(i_VAR_INT_big): + Case(i_VAR_WORD_big): + Case(i_RETADDR_big): + Case(i_ALLOC_PAP): + bciPtr--; + printf ( "\n\n" ); + disInstr ( bco, PC ); + barf("\nUnrecognised instruction"); + + EndDispatch + + barf("enterBCO: ran off end of loop"); + break; + } -#define OP_I_D(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - PushTaggedDouble(e); \ -} +# undef LoopTopLabel +# undef Case +# undef Continue +# undef Dispatch +# undef EndDispatch -#ifdef PROVIDE_WORD -#define OP_WW_B(e) \ -{ \ - StgWord x = PopTaggedWord(); \ - StgWord y = PopTaggedWord(); \ - PushTaggedBool(e); \ -} + /* ---------------------------------------------------- */ + /* End of the bytecode evaluator */ + /* ---------------------------------------------------- */ -#define OP_WW_W(e) \ -{ \ - StgWord x = PopTaggedWord(); \ - StgWord y = PopTaggedWord(); \ - PushTaggedWord(e); \ + case CAF_UNENTERED: + { + StgBlockingQueue* bh; + StgCAF* caf = (StgCAF*)obj; + if (xSp - 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 */ + 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; + if (caf->mut_link == NULL) { + SSS; recordOldToNewPtrs((StgMutClosure*)caf); LLL; + } + xPushUpdateFrame(bh,0); + xSp -= sizeofW(StgUpdateFrame); + caf->link = enteredCAFs; + enteredCAFs = caf; + 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: + { + /*was StgBlackHole* */ + StgBlockingQueue* bh = (StgBlockingQueue*)obj; + /* Put ourselves on the blocking queue for this black hole and block */ + cap->rCurrentTSO->link = bh->blocking_queue; + bh->blocking_queue = cap->rCurrentTSO; + xPushCPtr(obj); /* code to restart with */ + barf("enter: CAF_BLACKHOLE unexpected!"); + RETURN(ThreadBlocked); + } + case AP_UPD: + { + StgAP_UPD* ap = stgCast(StgAP_UPD*,obj); + int i = ap->n_args; + if (xSp - (i + sizeofW(StgUpdateFrame)) < xSpLim) { + xPushCPtr(obj); /* code to restart with */ + RETURN(StackOverflow); + } + /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME + and insert an indirection immediately */ + xPushUpdateFrame(ap,0); + xSp -= sizeofW(StgUpdateFrame); + while (--i >= 0) { + xPushWord(payloadWord(ap,i)); + } + obj = ap->fun; +#ifdef EAGER_BLACKHOLING +#warn LAZY_BLACKHOLING is default for StgHugs +#error Dont know if EAGER_BLACKHOLING works in StgHugs + { + /* superfluous - but makes debugging easier */ + StgBlackHole* bh = stgCast(StgBlackHole*,ap); + SET_INFO(bh,&BLACKHOLE_info); + bh->blocking_queue = EndTSOQueue; + IF_DEBUG(gccafs, + fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh)); + /* printObj(bh); */ + } +#endif /* EAGER_BLACKHOLING */ + goto enterLoop; + } + case PAP: + { + StgPAP* pap = stgCast(StgPAP*,obj); + int i = pap->n_args; /* ToDo: stack check */ + /* ToDo: if PAP is in whnf, we can update any update frames + * on top of stack. + */ + while (--i >= 0) { + xPushWord(payloadWord(pap,i)); + } + obj = pap->fun; + goto enterLoop; + } + case IND: + { + obj = stgCast(StgInd*,obj)->indirectee; + goto enterLoop; + } + case IND_OLDGEN: + { + obj = stgCast(StgIndOldGen*,obj)->indirectee; + goto enterLoop; + } + case CONSTR: + case CONSTR_1_0: + case CONSTR_0_1: + case CONSTR_2_0: + case CONSTR_1_1: + case CONSTR_0_2: + case CONSTR_INTLIKE: + case CONSTR_CHARLIKE: + case CONSTR_STATIC: + case CONSTR_NOCAF_STATIC: + { + 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; + ); + SSS; PopStopFrame(obj); LLL; + 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: + // barf("todo: RET_[VEC_]{BIG,SMALL}"); + 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->whatNext = ThreadEnterGHC; + xPushCPtr(obj); /* code to restart with */ + RETURN(ThreadYielding); + } + } + barf("Ran off the end of enter - yoiks"); + assert(0); } -#define OP_W_I(e) \ -{ \ - StgWord x = PopTaggedWord(); \ - PushTaggedInt(e); \ -} +#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 -#define OP_W_W(e) \ -{ \ - StgWord x = PopTaggedWord(); \ - PushTaggedWord(e); \ + +/* -------------------------------------------------------------------------- + * Supporting routines for primops + * ------------------------------------------------------------------------*/ + +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; } + +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 = 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 ) + { StgInt 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) ); +#ifdef CRUDE_PROFILING + cp_bill_words ( size ); +#endif + return allocate(size); } + +static inline StgPtr grabHpNonUpd( nat size ) +{ + ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) ); +#ifdef CRUDE_PROFILING + cp_bill_words ( size ); #endif + return allocate(size); +} + +/* -------------------------------------------------------------------------- + * Manipulate "update frame" list: + * o Update frames (based on stg_do_update and friends in Updates.hc) + * o Error handling/catching (based on catchzh_fast and friends in Prims.hc) + * o Seq frames (based on seq_frame_entry in Prims.hc) + * o Stop frames + * ------------------------------------------------------------------------*/ + +static inline void PopUpdateFrame ( StgClosure* obj ) +{ + /* NB: doesn't assume that gSp == gSu */ + IF_DEBUG(evaluator, + fprintf(stderr, "Updating "); + printPtr(stgCast(StgPtr,gSu->updatee)); + fprintf(stderr, " with "); + printObj(obj); + fprintf(stderr,"gSp = %p\tgSu = %p\n\n", gSp, gSu); + ); +#ifdef EAGER_BLACKHOLING +#warn LAZY_BLACKHOLING is default for StgHugs +#error Dont know if EAGER_BLACKHOLING works in StgHugs + ASSERT(get_itbl(gSu->updatee)->type == BLACKHOLE + || get_itbl(gSu->updatee)->type == SE_BLACKHOLE + || get_itbl(gSu->updatee)->type == CAF_BLACKHOLE + || get_itbl(gSu->updatee)->type == SE_CAF_BLACKHOLE + ); +#endif /* EAGER_BLACKHOLING */ + UPD_IND(gSu->updatee,obj); + gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame); + gSu = gSu->link; +} + +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; +} + +static inline void PushCatchFrame ( StgClosure* handler ) +{ + StgCatchFrame* fp; + /* ToDo: stack check! */ + gSp -= sizeofW(StgCatchFrame); + fp = stgCast(StgCatchFrame*,gSp); + SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS); + fp->handler = handler; + fp->link = gSu; + gSu = stgCast(StgUpdateFrame*,fp); +} + +static inline void PopCatchFrame ( void ) +{ + /* NB: doesn't assume that gSp == gSu */ + /* fprintf(stderr,"Popping catch frame\n"); */ + gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgCatchFrame); + gSu = stgCast(StgCatchFrame*,gSu)->link; +} + +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); +} + +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* errObj ) +{ + StgClosure *raise_closure; + + /* This closure represents the expression 'raise# E' where E + * is the exception raised. It is used to overwrite all the + * thunks which are currently under evaluation. + */ + raise_closure = (StgClosure *)allocate(sizeofW(StgClosure)+1); + raise_closure->header.info = &raise_info; + raise_closure->payload[0] = 0xdeadbeef; /*R1.cl;*/ + + while (1) { + switch (get_itbl(gSu)->type) { + case UPDATE_FRAME: + UPD_IND(gSu->updatee,raise_closure); + 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(errObj); + return handler; + } + case STOP_FRAME: + barf("raiseError: uncaught exception: STOP_FRAME"); + default: + barf("raiseError: weird activation record"); + } + } +} + + +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 + = asmClosureOfObject(getHugs_AsmObject_for("error")); + HaskellObj unpack + = asmClosureOfObject(getHugs_AsmObject_for("primUnpackString")); + HaskellObj thunk + = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) ); + thunk + = rts_apply ( error, thunk ); + return + (StgClosure*) thunk; +} + +#define raiseIndex(where) makeErrorCall("Array index out of range in " where) +#define raiseDiv0(where) makeErrorCall("Division by zero in " where) + +/* -------------------------------------------------------------------------- + * Evaluator + * ------------------------------------------------------------------------*/ + +#define OP_CC_B(e) \ +{ \ + unsigned char x = PopTaggedChar(); \ + unsigned char y = PopTaggedChar(); \ + PushTaggedBool(e); \ +} + +#define OP_C_I(e) \ +{ \ + unsigned char x = PopTaggedChar(); \ + PushTaggedInt(e); \ +} + +#define OP__I(e) \ +{ \ + PushTaggedInt(e); \ +} + +#define OP_IW_I(e) \ +{ \ + StgInt x = PopTaggedInt(); \ + StgWord y = PopTaggedWord(); \ + PushTaggedInt(e); \ +} + +#define OP_II_I(e) \ +{ \ + StgInt x = PopTaggedInt(); \ + StgInt y = PopTaggedInt(); \ + PushTaggedInt(e); \ +} + +#define OP_II_B(e) \ +{ \ + StgInt x = PopTaggedInt(); \ + StgInt y = PopTaggedInt(); \ + PushTaggedBool(e); \ +} + +#define OP__A(e) \ +{ \ + PushTaggedAddr(e); \ +} + +#define OP_I_A(e) \ +{ \ + StgInt x = PopTaggedInt(); \ + PushTaggedAddr(e); \ +} + +#define OP_I_I(e) \ +{ \ + StgInt x = PopTaggedInt(); \ + PushTaggedInt(e); \ +} + +#define OP__C(e) \ +{ \ + PushTaggedChar(e); \ +} + +#define OP_I_C(e) \ +{ \ + StgInt x = PopTaggedInt(); \ + PushTaggedChar(e); \ +} + +#define OP__W(e) \ +{ \ + PushTaggedWord(e); \ +} + +#define OP_I_W(e) \ +{ \ + StgInt x = PopTaggedInt(); \ + PushTaggedWord(e); \ +} + +#define OP_I_s(e) \ +{ \ + StgInt x = PopTaggedInt(); \ + PushTaggedStablePtr(e); \ +} + +#define OP__F(e) \ +{ \ + PushTaggedFloat(e); \ +} + +#define OP_I_F(e) \ +{ \ + StgInt x = PopTaggedInt(); \ + PushTaggedFloat(e); \ +} + +#define OP__D(e) \ +{ \ + PushTaggedDouble(e); \ +} + +#define OP_I_D(e) \ +{ \ + StgInt x = PopTaggedInt(); \ + PushTaggedDouble(e); \ +} + +#define OP_WW_B(e) \ +{ \ + StgWord x = PopTaggedWord(); \ + StgWord y = PopTaggedWord(); \ + PushTaggedBool(e); \ +} + +#define OP_WW_W(e) \ +{ \ + StgWord x = PopTaggedWord(); \ + StgWord y = PopTaggedWord(); \ + PushTaggedWord(e); \ +} + +#define OP_W_I(e) \ +{ \ + StgWord x = PopTaggedWord(); \ + PushTaggedInt(e); \ +} + +#define OP_s_I(e) \ +{ \ + StgStablePtr x = PopTaggedStablePtr(); \ + PushTaggedInt(e); \ +} + +#define OP_W_W(e) \ +{ \ + StgWord x = PopTaggedWord(); \ + PushTaggedWord(e); \ +} -#ifdef PROVIDE_ADDR #define OP_AA_B(e) \ { \ StgAddr x = PopTaggedAddr(); \ @@ -633,14 +1952,6 @@ fprintf(stderr, "\n\n\nRAISE PRIM %s\n", msg); s; \ PushTaggedInt(r); \ } -#define OP_AI_z(s) \ -{ \ - StgAddr x = PopTaggedAddr(); \ - int y = PopTaggedInt(); \ - StgInt64 r; \ - s; \ - PushTaggedInt64(r); \ -} #define OP_AI_A(s) \ { \ StgAddr x = PopTaggedAddr(); \ @@ -671,7 +1982,7 @@ fprintf(stderr, "\n\n\nRAISE PRIM %s\n", msg); int y = PopTaggedInt(); \ StgStablePtr r; \ s; \ - PushTaggedStablePtr(r); \ + PushTaggedStablePtr(r); \ } #define OP_AIC_(s) \ { \ @@ -687,13 +1998,6 @@ fprintf(stderr, "\n\n\nRAISE PRIM %s\n", msg); StgInt z = PopTaggedInt(); \ s; \ } -#define OP_AIz_(s) \ -{ \ - StgAddr x = PopTaggedAddr(); \ - int y = PopTaggedInt(); \ - StgInt64 z = PopTaggedInt64(); \ - s; \ -} #define OP_AIA_(s) \ { \ StgAddr x = PopTaggedAddr(); \ @@ -723,7 +2027,6 @@ fprintf(stderr, "\n\n\nRAISE PRIM %s\n", msg); s; \ } -#endif /* PROVIDE_ADDR */ #define OP_FF_B(e) \ { \ @@ -767,1746 +2070,896 @@ fprintf(stderr, "\n\n\nRAISE PRIM %s\n", msg); { \ StgDouble x = PopTaggedDouble(); \ StgDouble y = PopTaggedDouble(); \ - PushTaggedBool(e); \ -} - -#define OP_DD_D(e) \ -{ \ - StgDouble x = PopTaggedDouble(); \ - StgDouble y = PopTaggedDouble(); \ - PushTaggedDouble(e); \ -} - -#define OP_D_B(e) \ -{ \ - StgDouble x = PopTaggedDouble(); \ - PushTaggedBool(e); \ -} - -#define OP_D_D(e) \ -{ \ - StgDouble x = PopTaggedDouble(); \ - PushTaggedDouble(e); \ -} - -#define OP_D_I(e) \ -{ \ - StgDouble x = PopTaggedDouble(); \ - PushTaggedInt(e); \ -} - -#define OP_D_F(e) \ -{ \ - StgDouble x = PopTaggedDouble(); \ - PushTaggedFloat(e); \ -} - -#ifdef PROVIDE_INT64 -#define OP_zI_F(e) \ -{ \ - StgInt64 x = PopTaggedInt64(); \ - int y = PopTaggedInt(); \ - PushTaggedFloat(e); \ -} -#define OP_zI_D(e) \ -{ \ - StgInt64 x = PopTaggedInt64(); \ - int y = PopTaggedInt(); \ - PushTaggedDouble(e); \ -} -#define OP_zz_I(e) \ -{ \ - StgInt64 x = PopTaggedInt64(); \ - StgInt64 y = PopTaggedInt64(); \ - PushTaggedInt(e); \ -} -#define OP_z_z(e) \ -{ \ - StgInt64 x = PopTaggedInt64(); \ - PushTaggedInt64(e); \ -} -#define OP_zz_z(e) \ -{ \ - StgInt64 x = PopTaggedInt64(); \ - StgInt64 y = PopTaggedInt64(); \ - PushTaggedInt64(e); \ -} -#define OP_zW_z(e) \ -{ \ - StgInt64 x = PopTaggedInt64(); \ - StgWord y = PopTaggedWord(); \ - PushTaggedInt64(e); \ -} -#define OP_zz_zZ(e1,e2) \ -{ \ - StgInt64 x = PopTaggedInt64(); \ - StgInt64 y = PopTaggedInt64(); \ - PushTaggedInt64(e1); \ - PushTaggedInt64(e2); \ -} -#define OP_zz_B(e) \ -{ \ - StgInt64 x = PopTaggedInt64(); \ - StgInt64 y = PopTaggedInt64(); \ - PushTaggedBool(e); \ -} -#define OP__z(e) \ -{ \ - PushTaggedInt64(e); \ -} -#define OP_z_I(e) \ -{ \ - StgInt64 x = PopTaggedInt64(); \ - PushTaggedInt(e); \ -} -#define OP_I_z(e) \ -{ \ - StgInt x = PopTaggedInt(); \ - PushTaggedInt64(e); \ -} -#ifdef PROVIDE_WORD -#define OP_z_W(e) \ -{ \ - StgInt64 x = PopTaggedInt64(); \ - PushTaggedWord(e); \ -} -#define OP_W_z(e) \ -{ \ - StgWord x = PopTaggedWord(); \ - PushTaggedInt64(e); \ -} -#endif -#define OP_z_F(e) \ -{ \ - StgInt64 x = PopTaggedInt64(); \ - printf("%lld = %f\n",x,(float)(e)); \ - PushTaggedFloat(e); \ -} -#define OP_F_z(e) \ -{ \ - StgFloat x = PopTaggedFloat(); \ - PushTaggedInt64(e); \ -} -#define OP_z_D(e) \ -{ \ - StgInt64 x = PopTaggedInt64(); \ - PushTaggedDouble(e); \ -} -#define OP_D_z(e) \ -{ \ - StgDouble x = PopTaggedDouble(); \ - PushTaggedInt64(e); \ -} -#endif - -#ifdef PROVIDE_INTEGER - -#define OP_ZI_F(e) \ -{ \ - mpz_ptr x = PopTaggedInteger(); \ - int y = PopTaggedInt(); \ - PushTaggedFloat(e); \ -} -#define OP_F_ZI(s) \ -{ \ - StgFloat x = PopTaggedFloat(); \ - mpz_ptr r1 = mpz_alloc(); \ - StgInt r2; \ - s; \ - PushTaggedInt(r2); \ - PushTaggedInteger(r1); \ -} -#define OP_ZI_D(e) \ -{ \ - mpz_ptr x = PopTaggedInteger(); \ - int y = PopTaggedInt(); \ - PushTaggedDouble(e); \ -} -#define OP_D_ZI(s) \ -{ \ - StgDouble x = PopTaggedDouble(); \ - mpz_ptr r1 = mpz_alloc(); \ - StgInt r2; \ - s; \ - PushTaggedInt(r2); \ - PushTaggedInteger(r1); \ -} -#define OP_Z_Z(s) \ -{ \ - mpz_ptr x = PopTaggedInteger(); \ - mpz_ptr r = mpz_alloc(); \ - s; \ - PushTaggedInteger(r); \ -} -#define OP_ZZ_Z(s) \ -{ \ - mpz_ptr x = PopTaggedInteger(); \ - mpz_ptr y = PopTaggedInteger(); \ - mpz_ptr r = mpz_alloc(); \ - s; \ - PushTaggedInteger(r); \ -} -#define OP_ZZ_B(e) \ -{ \ - mpz_ptr x = PopTaggedInteger(); \ - mpz_ptr y = PopTaggedInteger(); \ - PushTaggedBool(e); \ -} -#define OP_Z_I(e) \ -{ \ - mpz_ptr x = PopTaggedInteger(); \ - PushTaggedInt(e); \ -} -#define OP_I_Z(s) \ -{ \ - StgInt x = PopTaggedInt(); \ - mpz_ptr r = mpz_alloc(); \ - s; \ - PushTaggedInteger(r); \ -} -#ifdef PROVIDE_INT64 -#define OP_Z_z(e) \ -{ \ - mpz_ptr x = PopTaggedInteger(); \ - PushTaggedInt64(e); \ -} -#define OP_z_Z(s) \ -{ \ - StgInt64 x = PopTaggedInt64(); \ - mpz_ptr r = mpz_alloc(); \ - s; \ - PushTaggedInteger(r); \ -} -#endif -#ifdef PROVIDE_WORD -#define OP_Z_W(e) \ -{ \ - mpz_ptr x = PopTaggedInteger(); \ - PushTaggedWord(e); \ -} -#define OP_W_Z(s) \ -{ \ - StgWord x = PopTaggedWord(); \ - mpz_ptr r = mpz_alloc(); \ - s; \ - PushTaggedInteger(r); \ -} -#endif -#define OP_Z_F(e) \ -{ \ - mpz_ptr x = PopTaggedInteger(); \ - PushTaggedFloat(e); \ -} -#define OP_F_Z(s) \ -{ \ - StgFloat x = PopTaggedFloat(); \ - mpz_ptr r = mpz_alloc(); \ - s; \ - PushTaggedInteger(r); \ -} -#define OP_Z_D(e) \ -{ \ - mpz_ptr x = PopTaggedInteger(); \ - PushTaggedDouble(e); \ -} -#define OP_D_Z(s) \ -{ \ - StgDouble x = PopTaggedDouble(); \ - mpz_ptr r = mpz_alloc(); \ - s; \ - PushTaggedInteger(r); \ -} - -#endif /* ifdef PROVIDE_INTEGER */ - -#ifdef PROVIDE_ARRAY -#define HEADER_mI(ty,where) \ - StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \ - nat i = PopTaggedInt(); \ - if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) { \ - obj = raiseIndex(where); \ - goto enterLoop; \ - } -#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; \ - } \ -} - -#endif /* PROVIDE_ARRAY */ - -static int enterCountI = 0; - -void myStackCheck ( void ) -{ - StgPtr sp = Sp; - StgPtr su = Su; - //fprintf(stderr, "myStackCheck\n"); - if (!(SpLim <= Sp && Sp <= stgCast(StgPtr,Su))) { - fprintf(stderr, "myStackCheck: invalid initial Sp/Su \n" ); - assert(0); - } - while (1) { - if (!(su >= CurrentTSO->stack && su <= CurrentTSO->stack + CurrentTSO->stack_size)) { - fprintf ( stderr, "myStackCheck: su out of stack\n" ); - assert(0); - } - switch (get_itbl(stgCast(StgClosure*,su))->type) { - case CATCH_FRAME: - su = ((StgCatchFrame*)(su))->link; - break; - case UPDATE_FRAME: - su = ((StgUpdateFrame*)(su))->link; - break; - case SEQ_FRAME: - su = ((StgSeqFrame*)(su))->link; - break; - case STOP_FRAME: - goto postloop; - default: - fprintf(stderr, "myStackCheck: invalid activation record\n"); assert(0); - } - } - postloop: -} - - -/* This is written as one giant function in the hope that gcc will do - * a better job of register allocation. - */ -StgThreadReturnCode enter( StgClosure* obj ) -{ - /* We use a char so that we'll do a context_switch check every 256 - * iterations. - */ - char enterCount = 0; - //fprintf ( stderr, "enter: Sp=%p Su=%p\n", Sp, Su); -enterLoop: - enterCountI++;// fprintf(stderr, "%d\n", enterCountI); - ASSERT(SpLim <= Sp && Sp <= stgCast(StgPtr,Su)); - -#if DEBUG - IF_DEBUG(evaluator, - fprintf(stderr, - "\n---------------------------------------------------------------\n"); - fprintf(stderr,"(%d) Entering: ",enterCountI); printObj(obj); - fprintf(stderr,"Sp = %p\tSu = %p\n", Sp, Su); - fprintf(stderr, "\n" ); - printStack(Sp,CurrentTSO->stack+CurrentTSO->stack_size,Su); - fprintf(stderr, "\n\n"); - ); -#endif - - if (++enterCount == 0 && context_switch) { - PushCPtr(obj); /* code to restart with */ - assert(0); - return ThreadYielding; - } - switch ( get_itbl(obj)->type ) { - case INVALID_OBJECT: - barf("Invalid object %p",obj); - case BCO: - { - StgBCO* bco = stgCast(StgBCO*,obj); - InstrPtr pc = 0; - - if (doYouWantToGC()) { - PushCPtr(obj); /* code to restart with */ - return HeapOverflow; - } - - while (1) { - ASSERT(pc < bco->n_instrs); - IF_DEBUG(evaluator, - fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", Sp, Su, pc); - disInstr(bco,pc); - /*fprintf(stderr,"\t"); printStackObj(Sp); */ - fprintf(stderr,"\n"); - ); - switch (bcoInstr(bco,pc++)) { - 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 = bcoInstr(bco,pc++); - if (Sp - n < SpLim) { - PushCPtr(obj); /* code to restart with */ - return StackOverflow; - } - break; - } - case i_ARG_CHECK: - { - /* ToDo: make sure that hp check allows for possible PAP */ - nat n = bcoInstr(bco,pc++); - if (stgCast(StgPtr,Sp + n) > stgCast(StgPtr,Su)) { - StgWord words = (P_)Su - Sp; - - /* first build a PAP */ - ASSERT((P_)Su >= Sp); /* 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 = stgCast(StgPAP*,grabHpNonUpd(PAP_sizeW(words))); - SET_HDR(pap,&PAP_info,CC_pap); - pap->n_args = words; - pap->fun = obj; - for(i = 0; i < (I_)words; ++i) { - payloadWord(pap,i) = Sp[i]; - } - Sp += 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(Sp==(P_)Su); - do { - switch (get_itbl(Su)->type) { - case CATCH_FRAME: - PopCatchFrame(); - ASSERT(Sp != (P_)Su); - /* We hit a CATCH frame during an arg satisfaction - * check. So now return to bco_info which is under - * the CATCH 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 evaluated as a possibly - * exception-throwing computation, but has not thrown - * any exception, and is now returning to the - * algebraic-case-continuation which forced the - * evaluation in the first place.) - */ - { - StgClosure* ret; - PopPtr(); - ret = PopCPtr(); - PushPtr((P_)obj); - obj = ret; - goto enterLoop; - } - break; - - break; - case UPDATE_FRAME: - PopUpdateFrame(obj); - break; - case STOP_FRAME: - PopStopFrame(obj); - return ThreadFinished; - case SEQ_FRAME: - PopSeqFrame(); - ASSERT(Sp != (P_)Su); - /* We 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; - PopPtr(); - ret = PopCPtr(); - PushPtr((P_)obj); - obj = ret; - goto enterLoop; - } - break; - default: - barf("Invalid update frame during argcheck"); - } - } while (Sp==(P_)Su); - goto enterLoop; - } - break; - } - case i_ALLOC_AP: - { - int words = bcoInstr(bco,pc++); - PushPtr(grabHpUpd(AP_sizeW(words))); - break; - } - case i_ALLOC_CONSTR: - { - StgInfoTable* info = bcoConstAddr(bco,bcoInstr(bco,pc++)); - StgClosure* c = stgCast(StgClosure*,grabHpNonUpd(sizeW_fromITBL(info))); - SET_HDR(c,info,??); - PushPtr(stgCast(StgPtr,c)); - break; - } - case i_MKAP: - { - int x = bcoInstr(bco,pc++); /* ToDo: Word not Int! */ - int y = bcoInstr(bco,pc++); - StgAP_UPD* o = stgCast(StgAP_UPD*,stackPtr(x)); - SET_HDR(o,&AP_UPD_info,??); - o->n_args = y; - o->fun = stgCast(StgClosure*,PopPtr()); - for(x=0; x < y; ++x) { - payloadWord(o,x) = PopWord(); - } - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - printObj(stgCast(StgClosure*,o)); - ); - break; - } - case i_MKAP_big: - { - int x, y; - StgAP_UPD* o; - x = bcoInstr16(bco,pc); pc += 2; /* ToDo: Word not Int! */ - y = bcoInstr16(bco,pc); pc += 2; - o = stgCast(StgAP_UPD*,stackPtr(x)); - SET_HDR(o,&AP_UPD_info,??); - o->n_args = y; - o->fun = stgCast(StgClosure*,PopPtr()); - for(x=0; x < y; ++x) { - payloadWord(o,x) = PopWord(); - } - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - printObj(stgCast(StgClosure*,o)); - ); - break; - } - case i_MKPAP: - { - int x = bcoInstr(bco,pc++); - int y = bcoInstr(bco,pc++); - StgPAP* o = stgCast(StgPAP*,stackPtr(x)); - SET_HDR(o,&PAP_info,??); - o->n_args = y; - o->fun = stgCast(StgClosure*,PopPtr()); - for(x=0; x < y; ++x) { - payloadWord(o,x) = PopWord(); - } - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - printObj(stgCast(StgClosure*,o)); - ); - break; - } - case i_PACK: - { - int offset = bcoInstr(bco,pc++); - StgClosure* o = stgCast(StgClosure*,stackPtr(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) { - payloadCPtr(o,i) = PopCPtr(); - } - for(i=0; i < np; ++i) { - payloadWord(o,p+i) = 0xdeadbeef; - } - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - printObj(stgCast(StgClosure*,o)); - ); - break; - } - case i_SLIDE: - { - int x = bcoInstr(bco,pc++); - int y = bcoInstr(bco,pc++); - ASSERT(Sp+x+y <= stgCast(StgPtr,Su)); - /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */ - while(--x >= 0) { - setStackWord(x+y,stackWord(x)); - } - Sp += y; - break; - } - case i_SLIDE_big: - { - int x, y; - x = bcoInstr16(bco,pc); pc += 2; - y = bcoInstr16(bco,pc); pc += 2; - ASSERT(Sp+x+y <= stgCast(StgPtr,Su)); - /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */ - while(--x >= 0) { - setStackWord(x+y,stackWord(x)); - } - Sp += y; - break; - } - case i_ENTER: - { - obj = PopCPtr(); - goto enterLoop; - } - case i_RETADDR: - { - PushPtr(bcoConstPtr(bco,bcoInstr(bco,pc++))); - PushPtr(stgCast(StgPtr,&ret_bco_info)); - break; - } - case i_TEST: - { - int tag = bcoInstr(bco,pc++); - StgWord offset = bcoInstr16(bco,pc); pc += 2; - if (constrTag(stgCast(StgClosure*,stackPtr(0))) != tag) { - pc += offset; - } - break; - } - case i_UNPACK: - { - StgClosure* o = stgCast(StgClosure*,stackPtr(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 - ); - while (--i>=0) { - PushCPtr(payloadCPtr(o,i)); - } - break; - } - case i_VAR_big: - { - PushPtr(stackPtr(bcoInstr16(bco,pc))); pc+=2; - break; - } - case i_VAR: - { - PushPtr(stackPtr(bcoInstr(bco,pc++))); - break; - } - case i_CONST: - { - PushPtr(stgCast(StgPtr,bcoConstPtr(bco,bcoInstr(bco,pc++)))); - break; - } - case i_CONST_big: - { - PushPtr(stgCast(StgPtr,bcoConstPtr(bco,bcoInstr16(bco,pc)))); pc += 2; - break; - } - case i_VOID: - { - PushTaggedRealWorld(); - break; - } - case i_VAR_INT: - { - PushTaggedInt(taggedStackInt(bcoInstr(bco,pc++))); - break; - } - case i_CONST_INT: - { - PushTaggedInt(bcoConstInt(bco,bcoInstr(bco,pc++))); - break; - } - case i_RETURN_INT: - { - ASSERT(0); - break; - } - case i_PACK_INT: - { - StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Izh_sizeW)); - SET_HDR(o,&Izh_con_info,??); - payloadWord(o,0) = PopTaggedInt(); - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - printObj(stgCast(StgClosure*,o)); - ); - PushPtr(stgCast(StgPtr,o)); - break; - } - case i_UNPACK_INT: - { - StgClosure* con = stgCast(StgClosure*,stackPtr(0)); - /* ASSERT(isIntLike(con)); */ - PushTaggedInt(payloadWord(con,0)); - break; - } - case i_TEST_INT: - { - StgWord offset = bcoInstr16(bco,pc); - StgInt x = PopTaggedInt(); - StgInt y = PopTaggedInt(); - pc += 2; - if (x != y) { - pc += offset; - } - break; - } -#ifdef PROVIDE_INT64 - case i_VAR_INT64: - { - PushTaggedInt64(taggedStackInt64(bcoInstr(bco,pc++))); - break; - } - case i_CONST_INT64: - { - PushTaggedInt64(bcoConstInt64(bco,bcoInstr(bco,pc++))); - break; - } - case i_RETURN_INT64: - { - ASSERT(0); /* ToDo(); */ - break; - } - case i_PACK_INT64: - { - StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(I64zh_sizeW)); - SET_HDR(o,&I64zh_con_info,??); - ASSIGN_Int64(&payloadWord(o,0),PopTaggedInt64()); - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - printObj(stgCast(StgClosure*,o)); - ); - PushPtr(stgCast(StgPtr,o)); - break; - } - case i_UNPACK_INT64: - { - StgClosure* con = stgCast(StgClosure*,stackPtr(0)); - /*ASSERT(isInt64Like(con)); */ - PushTaggedInt64(PK_Int64(&payloadWord(con,0))); - break; - } -#endif -#ifdef PROVIDE_INTEGER - case i_CONST_INTEGER: - { - char* s = bcoConstAddr(bco,bcoInstr(bco,pc++)); - mpz_ptr r = mpz_alloc(); - if (s[0] == '0' && s[1] == 'x') { - mpz_set_str(r,s+2,16); - } else { - mpz_set_str(r,s,10); - } - PushTaggedInteger(r); - break; - } -#endif - -#ifdef PROVIDE_WORD - case i_VAR_WORD: - { - PushTaggedWord(taggedStackWord(bcoInstr(bco,pc++))); - break; - } - case i_CONST_WORD: - { - PushTaggedWord(bcoConstWord(bco,bcoInstr(bco,pc++))); - break; - } - case i_RETURN_WORD: - { - ASSERT(0); - break; - } - case i_PACK_WORD: - { - StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Wzh_sizeW)); - - SET_HDR(o,&Wzh_con_info,??); - payloadWord(o,0) = PopTaggedWord(); - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - printObj(stgCast(StgClosure*,o)); - ); - PushPtr(stgCast(StgPtr,o)); - break; - } - case i_UNPACK_WORD: - { - StgClosure* con = stgCast(StgClosure*,stackPtr(0)); - /* ASSERT(isWordLike(con)); */ - PushTaggedWord(payloadWord(con,0)); - break; - } -#endif -#ifdef PROVIDE_ADDR - case i_VAR_ADDR: - { - PushTaggedAddr(taggedStackAddr(bcoInstr(bco,pc++))); - break; - } - case i_CONST_ADDR: - { - PushTaggedAddr(bcoConstAddr(bco,bcoInstr(bco,pc++))); - break; - } - case i_RETURN_ADDR: - { - ASSERT(0); - break; - } - case i_PACK_ADDR: - { - StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Azh_sizeW)); - SET_HDR(o,&Azh_con_info,??); - payloadPtr(o,0) = PopTaggedAddr(); - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - printObj(stgCast(StgClosure*,o)); - ); - PushPtr(stgCast(StgPtr,o)); - break; - } - case i_UNPACK_ADDR: - { - StgClosure* con = stgCast(StgClosure*,stackPtr(0)); - /* ASSERT(isAddrLike(con)); */ - PushTaggedAddr(payloadPtr(con,0)); - break; - } -#endif - case i_VAR_CHAR: - { - PushTaggedChar(taggedStackChar(bcoInstr(bco,pc++))); - break; - } - case i_CONST_CHAR: - { - PushTaggedChar(bcoConstChar(bco,bcoInstr(bco,pc++))); - break; - } - case i_RETURN_CHAR: - { - ASSERT(0); - break; - } - case i_PACK_CHAR: - { - StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Czh_sizeW)); - SET_HDR(o,&Czh_con_info,??); - payloadWord(o,0) = PopTaggedChar(); - PushPtr(stgCast(StgPtr,o)); - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - printObj(stgCast(StgClosure*,o)); - ); - break; - } - case i_UNPACK_CHAR: - { - StgClosure* con = stgCast(StgClosure*,stackPtr(0)); - /* ASSERT(isCharLike(con)); */ - PushTaggedChar(payloadWord(con,0)); - break; - } - case i_VAR_FLOAT: - { - PushTaggedFloat(taggedStackFloat(bcoInstr(bco,pc++))); - break; - } - case i_CONST_FLOAT: - { - PushTaggedFloat(bcoConstFloat(bco,bcoInstr(bco,pc++))); - break; - } - case i_RETURN_FLOAT: - { - ASSERT(0); - break; - } - case i_PACK_FLOAT: - { - StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Fzh_sizeW)); - SET_HDR(o,&Fzh_con_info,??); - ASSIGN_FLT(&payloadWord(o,0),PopTaggedFloat()); - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - printObj(stgCast(StgClosure*,o)); - ); - PushPtr(stgCast(StgPtr,o)); - break; - } - case i_UNPACK_FLOAT: - { - StgClosure* con = stgCast(StgClosure*,stackPtr(0)); - /* ASSERT(isFloatLike(con)); */ - PushTaggedFloat(PK_FLT(&payloadWord(con,0))); - break; - } - case i_VAR_DOUBLE: - { - PushTaggedDouble(taggedStackDouble(bcoInstr(bco,pc++))); - break; - } - case i_CONST_DOUBLE: - { - PushTaggedDouble(bcoConstDouble(bco,bcoInstr(bco,pc++))); - break; - } - case i_RETURN_DOUBLE: - { - ASSERT(0); - break; - } - case i_PACK_DOUBLE: - { - StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Dzh_sizeW)); - SET_HDR(o,&Dzh_con_info,??); - ASSIGN_DBL(&payloadWord(o,0),PopTaggedDouble()); - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - printObj(stgCast(StgClosure*,o)); - ); - PushPtr(stgCast(StgPtr,o)); - break; - } - case i_UNPACK_DOUBLE: - { - StgClosure* con = stgCast(StgClosure*,stackPtr(0)); - /* ASSERT(isDoubleLike(con)); */ - PushTaggedDouble(PK_DBL(&payloadWord(con,0))); - break; - } -#ifdef PROVIDE_STABLE - case i_VAR_STABLE: - { - PushTaggedStablePtr(taggedStackStable(bcoInstr(bco,pc++))); - break; - } - case i_RETURN_STABLE: - { - ASSERT(0); - break; - } - case i_PACK_STABLE: - { - StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Stablezh_sizeW)); - SET_HDR(o,&StablePtr_con_info,??); - payloadWord(o,0) = PopTaggedStablePtr(); - IF_DEBUG(evaluator, - fprintf(stderr,"\tBuilt "); - printObj(stgCast(StgClosure*,o)); - ); - PushPtr(stgCast(StgPtr,o)); - break; - } - case i_UNPACK_STABLE: - { - StgClosure* con = stgCast(StgClosure*,stackPtr(0)); - /* ASSERT(isStableLike(con)); */ - PushTaggedStablePtr(payloadWord(con,0)); - break; - } -#endif - case i_PRIMOP1: - { - switch (bcoInstr(bco,pc++)) { - case i_INTERNAL_ERROR1: - barf("INTERNAL_ERROR1 at %p:%d",bco,pc-1); - - case i_pushseqframe: - { - StgClosure* c = PopCPtr(); - PushSeqFrame(); - PushCPtr(c); - break; - } - case i_pushcatchframe: - { - StgClosure* e = PopCPtr(); - StgClosure* h = PopCPtr(); - PushCatchFrame(h); - PushCPtr(e); - break; - } + PushTaggedBool(e); \ +} - case i_gtChar: OP_CC_B(x>y); break; - case i_geChar: OP_CC_B(x>=y); break; - case i_eqChar: OP_CC_B(x==y); break; - case i_neChar: OP_CC_B(x!=y); break; - case i_ltChar: OP_CC_B(xy); break; - case i_geInt: OP_II_B(x>=y); break; - case i_eqInt: OP_II_B(x==y); break; - case i_neInt: OP_II_B(x!=y); break; - case i_ltInt: OP_II_B(x>y); break; /* ToDo */ - case i_shiftRLInt: OP_II_I(x>>y); break; /* ToDo */ - -#ifdef PROVIDE_INT64 - case i_gtInt64: OP_zz_B(x>y); break; - case i_geInt64: OP_zz_B(x>=y); break; - case i_eqInt64: OP_zz_B(x==y); break; - case i_neInt64: OP_zz_B(x!=y); break; - case i_ltInt64: OP_zz_B(x>y); break; /* ToDo */ - case i_shiftRLInt64: OP_zW_z(x>>y); break; /* ToDo */ - - case i_int64ToInt: OP_z_I(x); break; - case i_intToInt64: OP_I_z(x); break; -#ifdef PROVIDE_WORD - case i_int64ToWord: OP_z_W(x); break; - case i_wordToInt64: OP_W_z(x); break; -#endif - case i_int64ToFloat: OP_z_F(x); break; - case i_floatToInt64: OP_F_z(x); break; - case i_int64ToDouble: OP_z_D(x); break; - case i_doubleToInt64: OP_D_z(x); break; +#define OP_DD_D(e) \ +{ \ + StgDouble x = PopTaggedDouble(); \ + StgDouble y = PopTaggedDouble(); \ + PushTaggedDouble(e); \ +} + +#define OP_D_B(e) \ +{ \ + StgDouble x = PopTaggedDouble(); \ + PushTaggedBool(e); \ +} + +#define OP_D_D(e) \ +{ \ + StgDouble x = PopTaggedDouble(); \ + PushTaggedDouble(e); \ +} + +#define OP_D_I(e) \ +{ \ + StgDouble x = PopTaggedDouble(); \ + PushTaggedInt(e); \ +} + +#define OP_D_F(e) \ +{ \ + StgDouble x = PopTaggedDouble(); \ + PushTaggedFloat(e); \ +} + + +#ifdef STANDALONE_INTEGER +StgPtr CreateByteArrayToHoldInteger ( int nbytes ) +{ + StgInt 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(nbytes <= arr->words * sizeof(W_)); +#ifdef DEBUG + {nat i; + for (i = 0; i < words; ++i) { + arr->payload[i] = 0xdeadbeef; + }} + { B* b = (B*) &(arr->payload[0]); + b->used = b->sign = 0; + } #endif -#ifdef PROVIDE_WORD - case i_gtWord: OP_WW_B(x>y); break; - case i_geWord: OP_WW_B(x>=y); break; - case i_eqWord: OP_WW_B(x==y); break; - case i_neWord: OP_WW_B(x!=y); break; - case i_ltWord: OP_WW_B(x>y); break; /* ToDo */ - case i_shiftRLWord: OP_WW_W(x>>y); break; /* ToDo */ - case i_intToWord: OP_I_W(x); break; - case i_wordToInt: OP_W_I(x); break; + 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); \ +} #endif -#ifdef PROVIDE_ADDR - case i_gtAddr: OP_AA_B(x>y); break; - case i_geAddr: OP_AA_B(x>=y); break; - case i_eqAddr: OP_AA_B(x==y); break; - case i_neAddr: OP_AA_B(x!=y); break; - case i_ltAddr: OP_AA_B(x 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; \ + } \ +} + + +void myStackCheck ( Capability* cap ) +{ + /* fprintf(stderr, "myStackCheck\n"); */ + if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) { + fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" ); + assert(0); + } + while (1) { + if (!(gSu >= cap->rCurrentTSO->stack + && gSu <= cap->rCurrentTSO->stack + + cap->rCurrentTSO->stack_size)) { + fprintf ( stderr, "myStackCheck: gSu out of stack\n" ); + assert(0); + } + switch (get_itbl(stgCast(StgClosure*,gSu))->type) { + case CATCH_FRAME: + gSu = (StgPtr) ((StgCatchFrame*)(gSu))->link; + break; + case UPDATE_FRAME: + gSu = (StgPtr) ((StgUpdateFrame*)(gSu))->link; + break; + case SEQ_FRAME: + gSu = (StgPtr) ((StgSeqFrame*)(gSu))->link; + break; + case STOP_FRAME: + goto postloop; + default: + fprintf(stderr, "myStackCheck: invalid activation record\n"); assert(0); + } + } + postloop: +} + + +/* -------------------------------------------------------------------------- + * Primop stuff for bytecode interpreter + * ------------------------------------------------------------------------*/ + +/* Returns & of the next thing to enter (if throwing an exception), + or NULL in the normal case. +*/ +static void* enterBCO_primop1 ( int primop1code ) +{ + switch (primop1code) { + case i_pushseqframe: + { + StgClosure* c = PopCPtr(); + PushSeqFrame(); + PushCPtr(c); + break; + } + case i_pushcatchframe: + { + StgClosure* e = PopCPtr(); + StgClosure* h = PopCPtr(); + PushCatchFrame(h); + PushCPtr(e); + break; + } + + case i_gtChar: OP_CC_B(x>y); break; + case i_geChar: OP_CC_B(x>=y); break; + case i_eqChar: OP_CC_B(x==y); break; + case i_neChar: OP_CC_B(x!=y); break; + case i_ltChar: OP_CC_B(xy); break; + case i_geInt: OP_II_B(x>=y); break; + case i_eqInt: OP_II_B(x==y); break; + case i_neInt: OP_II_B(x!=y); break; + case i_ltInt: OP_II_B(x>y); break; /* ToDo */ + case i_shiftRLInt: OP_II_I(x>>y); break; /* ToDo */ + + case i_gtWord: OP_WW_B(x>y); break; + case i_geWord: OP_WW_B(x>=y); break; + case i_eqWord: OP_WW_B(x==y); break; + case i_neWord: OP_WW_B(x!=y); break; + case i_ltWord: OP_WW_B(x>y); break; /* ToDo */ + case i_shiftRLWord: OP_WW_W(x>>y); break; /* ToDo */ + case i_intToWord: OP_I_W(x); break; + case i_wordToInt: OP_W_I(x); break; + + case i_gtAddr: OP_AA_B(x>y); break; + case i_geAddr: OP_AA_B(x>=y); break; + case i_eqAddr: OP_AA_B(x==y); break; + case i_neAddr: OP_AA_B(x!=y); break; + case i_ltAddr: OP_AA_B(x0 ? 1 : 0)); + } + break; + case i_negateInteger: OP_Z_Z(neg); break; + case i_plusInteger: OP_ZZ_Z(add); break; + case i_minusInteger: OP_ZZ_Z(sub); break; + case i_timesInteger: OP_ZZ_Z(mul); break; + case i_quotRemInteger: + { + B* x = IntegerInsideByteArray(PopPtr()); + B* y = IntegerInsideByteArray(PopPtr()); + int n = size_qrm(x,y); + StgPtr q = CreateByteArrayToHoldInteger(n); + StgPtr r = CreateByteArrayToHoldInteger(n); + if (do_getsign(y)==0) + return (raiseDiv0("quotRemInteger")); + do_qrm(x,y,n,IntegerInsideByteArray(q), + IntegerInsideByteArray(r)); + SloppifyIntegerEnd(q); + SloppifyIntegerEnd(r); + PushPtr(r); + PushPtr(q); + } + break; + case i_intToInteger: + { + int n = size_fromInt(); + StgPtr p = CreateByteArrayToHoldInteger(n); + do_fromInt( PopTaggedInt(), n, IntegerInsideByteArray(p)); + PushPtr(p); + } + break; + case i_wordToInteger: + { + int n = size_fromWord(); + StgPtr p = CreateByteArrayToHoldInteger(n); + do_fromWord( PopTaggedWord(), n, IntegerInsideByteArray(p)); + PushPtr(p); + } + break; + case i_integerToInt: PushTaggedInt(do_toInt( + IntegerInsideByteArray(PopPtr()) + )); + break; + + case i_integerToWord: PushTaggedWord(do_toWord( + IntegerInsideByteArray(PopPtr()) + )); + break; + + case i_integerToFloat: PushTaggedFloat(do_toFloat( + IntegerInsideByteArray(PopPtr()) + )); + break; + + case i_integerToDouble: PushTaggedDouble(do_toDouble( + IntegerInsideByteArray(PopPtr()) + )); + break; +#else +#error Non-standalone integer not yet implemented +#endif /* STANDALONE_INTEGER */ + + case i_gtFloat: OP_FF_B(x>y); break; + case i_geFloat: OP_FF_B(x>=y); break; + case i_eqFloat: OP_FF_B(x==y); break; + case i_neFloat: OP_FF_B(x!=y); break; + case i_ltFloat: OP_FF_B(xy); break; + case i_geDouble: OP_DD_B(x>=y); break; + case i_eqDouble: OP_DD_B(x==y); break; + case i_neDouble: OP_DD_B(x!=y); break; + case i_ltDouble: OP_DD_B(x0 ? 1 : 0)); - } - break; - case i_negateInteger: OP_Z_Z(mpz_neg(r,x)); break; - case i_plusInteger: OP_ZZ_Z(mpz_add(r,x,y)); break; - case i_minusInteger: OP_ZZ_Z(mpz_sub(r,x,y)); break; - case i_timesInteger: OP_ZZ_Z(mpz_mul(r,x,y)); break; - case i_quotRemInteger: - { - mpz_ptr x = PopTaggedInteger(); - mpz_ptr y = PopTaggedInteger(); - mpz_ptr q = mpz_alloc(); - mpz_ptr r = mpz_alloc(); - if (mpz_sgn(y) == 0) { - obj = raiseDiv0("quotRemInteger"); - goto enterLoop; - } - mpz_tdiv_qr(q,r,x,y); - PushTaggedInteger(r); /* last result */ - PushTaggedInteger(q); /* first result */ - } - break; - case i_divModInteger: - { - mpz_ptr x = PopTaggedInteger(); - mpz_ptr y = PopTaggedInteger(); - mpz_ptr q = mpz_alloc(); - mpz_ptr r = mpz_alloc(); - if (mpz_sgn(y) == 0) { - obj = raiseDiv0("divModInteger"); - goto enterLoop; - } - mpz_fdiv_qr(q,r,x,y); - PushTaggedInteger(r); /* last result */ - PushTaggedInteger(q); /* first result */ - } - break; - case i_integerToInt: OP_Z_I(mpz_get_si(x)); break; - case i_intToInteger: OP_I_Z(mpz_set_si(r,x)); break; -#ifdef PROVIDE_INT64 - case i_integerToInt64: OP_Z_z(mpz_get_si(x)); break; - case i_int64ToInteger: OP_z_Z(mpz_set_si(r,x)); break; -#endif -#ifdef PROVIDE_WORD - /* NB Use of mpz_get_si is quite deliberate since otherwise - * -255 is converted to 255. - */ - case i_integerToWord: OP_Z_W(mpz_get_si(x)); break; - case i_wordToInteger: OP_W_Z(mpz_set_ui(r,x)); break; -#endif - case i_integerToFloat: OP_Z_F(mpz_get_d(x)); break; - case i_floatToInteger: OP_F_Z(mpz_set_d(r,x)); break; - case i_integerToDouble: OP_Z_D(mpz_get_d(x)); break; - case i_doubleToInteger: OP_D_Z(mpz_set_d(r,x)); break; -#endif /* PROVIDE_INTEGER */ - - case i_gtFloat: OP_FF_B(x>y); break; - case i_geFloat: OP_FF_B(x>=y); break; - case i_eqFloat: OP_FF_B(x==y); break; - case i_neFloat: OP_FF_B(x!=y); break; - case i_ltFloat: OP_FF_B(x_mp_size, - stgCast(StgByteArray,x->_mp_d), - y)); break; - case i_decodeFloatZ: OP_F_ZI(__decodeFloat(r1,&r2,x)); break; -#endif - case i_isNaNFloat: OP_F_B(isFloatNaN(x)); break; - case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break; - case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break; - case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break; - case i_gtDouble: OP_DD_B(x>y); break; - case i_geDouble: OP_DD_B(x>=y); break; - case i_eqDouble: OP_DD_B(x==y); break; - case i_neDouble: OP_DD_B(x!=y); break; - case i_ltDouble: OP_DD_B(x_mp_size, - stgCast(StgByteArray,x->_mp_d), - y)); break; - case i_decodeDoubleZ: OP_D_ZI(__decodeDouble(r1,&r2,x)); break; -#endif /* PROVIDE_INTEGER */ - case i_isNaNDouble: OP_D_B(isDoubleNaN(x)); break; - case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break; - case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break; - case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break; - case i_isIEEEDouble: - { - PushTaggedBool(rtsTrue); - } - break; - default: - barf("Unrecognised primop1"); - } - break; - } - case i_PRIMOP2: - { - switch (bcoInstr(bco,pc++)) { - case i_INTERNAL_ERROR2: - barf("INTERNAL_ERROR2 at %p:%d",bco,pc-1); - - case i_raise: /* raise#{err} */ - { - StgClosure* err = PopCPtr(); - obj = raiseAnError(err); - goto enterLoop; - } -#ifdef PROVIDE_ARRAY - case i_newRef: - { - StgClosure* init = PopCPtr(); - StgMutVar* mv - = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar))); - SET_HDR(mv,&MUT_VAR_info,CCCS); - mv->var = init; - PushPtr(stgCast(StgPtr,mv)); - break; - } - case i_readRef: - { - StgMutVar* mv = stgCast(StgMutVar*,PopPtr()); - PushCPtr(mv->var); - break; - } - case i_writeRef: - { - StgMutVar* mv = stgCast(StgMutVar*,PopPtr()); - StgClosure* value = PopCPtr(); - mv->var = value; - break; - } - case i_newArray: - { - nat n = PopTaggedInt(); /* or Word?? */ - StgClosure* init = PopCPtr(); - StgWord size = sizeofW(StgMutArrPtrs) + n; - nat i; - StgMutArrPtrs* arr - = stgCast(StgMutArrPtrs*,allocate(size)); - SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS); - arr->ptrs = n; - for (i = 0; i < n; ++i) { - arr->payload[i] = init; - } - PushPtr(stgCast(StgPtr,arr)); - break; - } - case i_readArray: - case i_indexArray: - { - StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr()); - nat i = PopTaggedInt(); /* or Word?? */ - StgWord n = arr->ptrs; - if (i >= n) { - obj = raiseIndex("{index,read}Array"); - goto enterLoop; - } - PushCPtr(arr->payload[i]); - break; - } - case i_writeArray: - { - StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr()); - nat i = PopTaggedInt(); /* or Word? */ - StgClosure* v = PopCPtr(); - StgWord n = arr->ptrs; - if (i >= n) { - obj = raiseIndex("{index,read}Array"); - goto enterLoop; - } - arr->payload[i] = v; - break; - } - case i_sizeArray: - case i_sizeMutableArray: - { - StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr()); - PushTaggedInt(arr->ptrs); - break; - } - case i_unsafeFreezeArray: - { - StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr()); - SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info); - PushPtr(stgCast(StgPtr,arr)); - break; - } - case i_unsafeFreezeByteArray: - { - /* Delightfully simple :-) */ - break; - } - case i_sameRef: - case i_sameMutableArray: - case i_sameMutableByteArray: - { - StgPtr x = PopPtr(); - StgPtr y = PopPtr(); - PushTaggedBool(x==y); - break; - } - case i_newByteArray: - { - nat n = PopTaggedInt(); /* or Word?? */ - StgInt words = (n+sizeof(W_)-1)/sizeof(W_); - StgWord size = sizeofW(StgArrWords) + words; - nat i; - StgArrWords* arr = stgCast(StgArrWords*,allocate(size)); - SET_HDR(arr,&ARR_WORDS_info,CCCS); - arr->words = words; +/* For normal cases, return NULL and leave *return2 unchanged. + To return the address of the next thing to enter, + return the address of it and leave *return2 unchanged. + To return a StgThreadReturnCode to the scheduler, + set *return2 to it and return a non-NULL value. +*/ +static void* enterBCO_primop2 ( int primop2code, + int* /*StgThreadReturnCode* */ return2, + StgBCO** bco, + Capability* cap ) +{ + switch (primop2code) { + case i_raise: /* raise#{err} */ + { + StgClosure* err = PopCPtr(); + return (raiseAnError(err)); + } + + case i_newRef: + { + StgClosure* init = PopCPtr(); + StgMutVar* mv + = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar))); + SET_HDR(mv,&MUT_VAR_info,CCCS); + mv->var = init; + PushPtr(stgCast(StgPtr,mv)); + break; + } + case i_readRef: + { + StgMutVar* mv = stgCast(StgMutVar*,PopPtr()); + PushCPtr(mv->var); + break; + } + case i_writeRef: + { + StgMutVar* mv = stgCast(StgMutVar*,PopPtr()); + StgClosure* value = PopCPtr(); + mv->var = value; + break; + } + case i_newArray: + { + nat n = PopTaggedInt(); /* or Word?? */ + StgClosure* init = PopCPtr(); + StgWord size = sizeofW(StgMutArrPtrs) + n; + nat i; + StgMutArrPtrs* arr + = stgCast(StgMutArrPtrs*,allocate(size)); + SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS); + arr->ptrs = n; + for (i = 0; i < n; ++i) { + arr->payload[i] = init; + } + PushPtr(stgCast(StgPtr,arr)); + break; + } + case i_readArray: + case i_indexArray: + { + StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr()); + nat i = PopTaggedInt(); /* or Word?? */ + StgWord n = arr->ptrs; + if (i >= n) { + return (raiseIndex("{index,read}Array")); + } + PushCPtr(arr->payload[i]); + break; + } + case i_writeArray: + { + StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr()); + nat i = PopTaggedInt(); /* or Word? */ + StgClosure* v = PopCPtr(); + StgWord n = arr->ptrs; + if (i >= n) { + return (raiseIndex("{index,read}Array")); + } + arr->payload[i] = v; + break; + } + case i_sizeArray: + case i_sizeMutableArray: + { + StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr()); + PushTaggedInt(arr->ptrs); + break; + } + case i_unsafeFreezeArray: + { + StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr()); + SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info); + PushPtr(stgCast(StgPtr,arr)); + break; + } + case i_unsafeFreezeByteArray: + { + /* Delightfully simple :-) */ + break; + } + case i_sameRef: + case i_sameMutableArray: + case i_sameMutableByteArray: + { + StgPtr x = PopPtr(); + StgPtr y = PopPtr(); + PushTaggedBool(x==y); + break; + } + + case i_newByteArray: + { + nat n = PopTaggedInt(); /* or Word?? */ + StgInt words = (n+sizeof(W_)-1)/sizeof(W_); + StgWord size = sizeofW(StgArrWords) + words; + StgArrWords* arr = stgCast(StgArrWords*,allocate(size)); + SET_HDR(arr,&ARR_WORDS_info,CCCS); + arr->words = words; #ifdef DEBUG - for (i = 0; i < n; ++i) { - arr->payload[i] = 0xdeadbeef; - } + {nat i; + for (i = 0; i < n; ++i) { + arr->payload[i] = 0xdeadbeef; + }} #endif - PushPtr(stgCast(StgPtr,arr)); - break; - } + PushPtr(stgCast(StgPtr,arr)); + break; + } - /* Most of these generate alignment warnings on Sparcs and similar architectures. - * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS. - */ - case i_indexCharArray: OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break; - case i_readCharArray: OP_mI_ty(Char,"readCharArray", readCharArrayzh(r,x,i)); break; - case i_writeCharArray: OP_mIty_(Char,"writeCharArray", writeCharArrayzh(x,i,z)); break; - - case i_indexIntArray: OP_mI_ty(Int,"indexIntArray", indexIntArrayzh(r,x,i)); break; - case i_readIntArray: OP_mI_ty(Int,"readIntArray", readIntArrayzh(r,x,i)); break; - case i_writeIntArray: OP_mIty_(Int,"writeIntArray", writeIntArrayzh(x,i,z)); break; -#ifdef PROVIDE_INT64 - case i_indexInt64Array: OP_mI_ty(Int64,"indexInt64Array", indexInt64Arrayzh(r,x,i)); break; - case i_readInt64Array: OP_mI_ty(Int64,"readInt64Array", readInt64Arrayzh(r,x,i)); break; - case i_writeInt64Array: OP_mIty_(Int64,"writeInt64Array", writeInt64Arrayzh(x,i,z)); break; + /* Most of these generate alignment warnings on gSparcs and similar architectures. + * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS. + */ + case i_indexCharArray: + OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break; + case i_readCharArray: + OP_mI_ty(Char,"readCharArray", readCharArrayzh(r,x,i)); break; + case i_writeCharArray: + OP_mIty_(Char,"writeCharArray", writeCharArrayzh(x,i,z)); break; + + case i_indexIntArray: + OP_mI_ty(Int,"indexIntArray", indexIntArrayzh(r,x,i)); break; + case i_readIntArray: + OP_mI_ty(Int,"readIntArray", readIntArrayzh(r,x,i)); break; + case i_writeIntArray: + OP_mIty_(Int,"writeIntArray", writeIntArrayzh(x,i,z)); break; + + case i_indexAddrArray: + OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayzh(r,x,i)); break; + case i_readAddrArray: + OP_mI_ty(Addr,"readAddrArray", readAddrArrayzh(r,x,i)); break; + case i_writeAddrArray: + OP_mIty_(Addr,"writeAddrArray", writeAddrArrayzh(x,i,z)); break; + + case i_indexFloatArray: + OP_mI_ty(Float,"indexFloatArray", indexFloatArrayzh(r,x,i)); break; + case i_readFloatArray: + OP_mI_ty(Float,"readFloatArray", readFloatArrayzh(r,x,i)); break; + case i_writeFloatArray: + OP_mIty_(Float,"writeFloatArray", writeFloatArrayzh(x,i,z)); break; + + case i_indexDoubleArray: + OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break; + case i_readDoubleArray: + OP_mI_ty(Double,"readDoubleArray", readDoubleArrayzh(r,x,i)); break; + case i_writeDoubleArray: + OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break; + +#if 0 +#ifdef PROVIDE_STABLE + case i_indexStableArray: + OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break; + case i_readStableArray: + OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayzh(r,x,i)); break; + case i_writeStableArray: + OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break; #endif -#ifdef PROVIDE_ADDR - case i_indexAddrArray: OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayzh(r,x,i)); break; - case i_readAddrArray: OP_mI_ty(Addr,"readAddrArray", readAddrArrayzh(r,x,i)); break; - case i_writeAddrArray: OP_mIty_(Addr,"writeAddrArray", writeAddrArrayzh(x,i,z)); break; #endif - case i_indexFloatArray: OP_mI_ty(Float,"indexFloatArray", indexFloatArrayzh(r,x,i)); break; - case i_readFloatArray: OP_mI_ty(Float,"readFloatArray", readFloatArrayzh(r,x,i)); break; - case i_writeFloatArray: OP_mIty_(Float,"writeFloatArray", writeFloatArrayzh(x,i,z)); break; - case i_indexDoubleArray: OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break; - case i_readDoubleArray: OP_mI_ty(Double,"readDoubleArray", readDoubleArrayzh(r,x,i)); break; - case i_writeDoubleArray: OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break; -#ifdef PROVIDE_STABLE - case i_indexStableArray: OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break; - case i_readStableArray: OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayzh(r,x,i)); break; - case i_writeStableArray: OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break; -#endif -#endif /* PROVIDE_ARRAY */ #ifdef PROVIDE_COERCE - case i_unsafeCoerce: - { - /* Another nullop */ - break; - } + case i_unsafeCoerce: + { + /* Another nullop */ + break; + } #endif #ifdef PROVIDE_PTREQUALITY - case i_reallyUnsafePtrEquality: - { /* identical to i_sameRef */ - StgPtr x = PopPtr(); - StgPtr y = PopPtr(); - PushTaggedBool(x==y); - break; - } + case i_reallyUnsafePtrEquality: + { /* identical to i_sameRef */ + StgPtr x = PopPtr(); + StgPtr y = PopPtr(); + PushTaggedBool(x==y); + break; + } #endif #ifdef PROVIDE_FOREIGN - /* ForeignObj# operations */ - case i_makeForeignObj: - { - StgForeignObj *result - = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj))); - SET_HDR(result,&FOREIGN_info,CCCS); - result -> data = PopTaggedAddr(); - PushPtr(stgCast(StgPtr,result)); - break; - } + /* ForeignObj# operations */ + case i_makeForeignObj: + { + StgForeignObj *result + = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj))); + SET_HDR(result,&FOREIGN_info,CCCS); + result -> data = PopTaggedAddr(); + PushPtr(stgCast(StgPtr,result)); + break; + } #endif /* PROVIDE_FOREIGN */ #ifdef PROVIDE_WEAK - case i_makeWeak: - { - StgWeak *w - = stgCast(StgWeak*,allocate(sizeofW(StgWeak))); - SET_HDR(w, &WEAK_info, CCCS); - w->key = PopCPtr(); - w->value = PopCPtr(); - w->finaliser = PopCPtr(); - w->link = weak_ptr_list; - weak_ptr_list = w; - IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w)); - PushPtr(stgCast(StgPtr,w)); - break; - } - case i_deRefWeak: - { - StgWeak *w = stgCast(StgWeak*,PopPtr()); - if (w->header.info == &WEAK_info) { - PushCPtr(w->value); /* last result */ - PushTaggedInt(1); /* first result */ - } else { - PushPtr(stgCast(StgPtr,w)); /* ToDo: error thunk would be better */ - PushTaggedInt(0); - } - break; - } + case i_makeWeak: + { + StgWeak *w + = stgCast(StgWeak*,allocate(sizeofW(StgWeak))); + SET_HDR(w, &WEAK_info, CCCS); + w->key = PopCPtr(); + w->value = PopCPtr(); + w->finaliser = PopCPtr(); + w->link = weak_ptr_list; + weak_ptr_list = w; + IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w)); + PushPtr(stgCast(StgPtr,w)); + break; + } + case i_deRefWeak: + { + StgWeak *w = stgCast(StgWeak*,PopPtr()); + if (w->header.info == &WEAK_info) { + PushCPtr(w->value); /* last result */ + PushTaggedInt(1); /* first result */ + } else { + PushPtr(stgCast(StgPtr,w)); + /* ToDo: error thunk would be better */ + PushTaggedInt(0); + } + break; + } #endif /* PROVIDE_WEAK */ -#ifdef PROVIDE_STABLE - /* StablePtr# operations */ - case i_makeStablePtr: - case i_deRefStablePtr: - case i_freeStablePtr: - { fprintf(stderr,"Evaluator.c:stablePtrOp unimp\n" ); - exit(1); }; -#if 0 - ToDo: reinstate - case i_makeStablePtr: - { - StgStablePtr stable_ptr; - if (stable_ptr_free == NULL) { - enlargeStablePtrTable(); - } - - stable_ptr = stable_ptr_free - stable_ptr_table; - stable_ptr_free = (P_*)*stable_ptr_free; - stable_ptr_table[stable_ptr] = PopPtr(); - - PushTaggedStablePtr(stable_ptr); - break; - } - case i_deRefStablePtr: - { - StgStablePtr stable_ptr = PopTaggedStablePtr(); - PushPtr(stable_ptr_table[stable_ptr]); - break; - } - - case i_freeStablePtr: - { - StgStablePtr stable_ptr = PopTaggedStablePtr(); - stable_ptr_table[stable_ptr] = (P_)stable_ptr_free; - stable_ptr_free = stable_ptr_table + stable_ptr; - break; - } -#endif /* 0 */ - - -#endif /* PROVIDE_STABLE */ + case i_makeStablePtr: + { + StgPtr p = PopPtr(); + StgStablePtr sp = getStablePtr ( p ); + PushTaggedStablePtr(sp); + break; + } + case i_deRefStablePtr: + { + StgPtr p; + StgStablePtr sp = PopTaggedStablePtr(); + p = deRefStablePtr(sp); + PushPtr(p); + break; + } + case i_freeStablePtr: + { + StgStablePtr sp = PopTaggedStablePtr(); + freeStablePtr(sp); + break; + } + + case i_createAdjThunkARCH: + { + StgStablePtr stableptr = PopTaggedStablePtr(); + StgAddr typestr = PopTaggedAddr(); + StgChar callconv = PopTaggedChar(); + StgAddr adj_thunk = createAdjThunk(stableptr,typestr,callconv); + PushTaggedAddr(adj_thunk); + break; + } + + case i_getArgc: + { + StgInt n = prog_argc; + PushTaggedInt(n); + break; + } + case i_getArgv: + { + StgInt n = PopTaggedInt(); + StgAddr a = (StgAddr)prog_argv[n]; + PushTaggedAddr(a); + break; + } + #ifdef PROVIDE_CONCURRENT - case i_fork: - { - StgClosure* c = PopCPtr(); - StgTSO* t = createGenThread(RtsFlags.GcFlags.initialStkSize,c); - PushPtr(stgCast(StgPtr,t)); - - /* switch at the earliest opportunity */ - context_switch = 1; - /* but don't automatically switch to GHC - or you'll waste your - * time slice switching back. - * - * Actually, there's more to it than that: the default - * (ThreadEnterGHC) causes the thread to crash - don't - * understand why. - ADR - */ - t->whatNext = ThreadEnterHugs; - break; - } - case i_killThread: - { - StgTSO* tso = stgCast(StgTSO*,PopPtr()); - deleteThread(tso); - if (tso == CurrentTSO) { /* suicide */ - return ThreadFinished; - } - break; - } - case i_sameMVar: - { /* identical to i_sameRef */ - StgPtr x = PopPtr(); - StgPtr y = PopPtr(); - PushTaggedBool(x==y); - break; - } - case i_newMVar: - { - StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar))); - SET_INFO(mvar,&EMPTY_MVAR_info); - mvar->head = mvar->tail = EndTSOQueue; - /* ToDo: this is a little strange */ - mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure); - PushPtr(stgCast(StgPtr,mvar)); - break; - } + case i_fork: + { + StgClosure* c = PopCPtr(); + StgTSO* t = createGenThread(RtsFlags.GcFlags.initialStkSize,c); + PushPtr(stgCast(StgPtr,t)); + + /* switch at the earliest opportunity */ + context_switch = 1; + /* but don't automatically switch to GHC - or you'll waste your + * time slice switching back. + * + * Actually, there's more to it than that: the default + * (ThreadEnterGHC) causes the thread to crash - don't + * understand why. - ADR + */ + t->whatNext = ThreadEnterHugs; + break; + } + case i_killThread: + { + StgTSO* tso = stgCast(StgTSO*,PopPtr()); + deleteThread(tso); + if (tso == cap->rCurrentTSO) { /* suicide */ + *return2 = ThreadFinished; + return (void*)(1+(NULL)); + } + break; + } + case i_sameMVar: + { /* identical to i_sameRef */ + StgPtr x = PopPtr(); + StgPtr y = PopPtr(); + PushTaggedBool(x==y); + break; + } + case i_newMVar: + { + StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar))); + SET_INFO(mvar,&EMPTY_MVAR_info); + mvar->head = mvar->tail = EndTSOQueue; + /* ToDo: this is a little strange */ + mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure); + PushPtr(stgCast(StgPtr,mvar)); + break; + } #if 1 #if 0 ToDo: another way out of the problem might be to add an explicit @@ -2514,295 +2967,137 @@ continuation to primTakeMVar: takeMVar v = primTakeMVar v takeMVar. The problem with this plan is that now I dont know how much to chop off the stack. #endif - case i_takeMVar: - { - StgMVar *mvar = stgCast(StgMVar*,PopPtr()); - /* If the MVar is empty, put ourselves - * on its blocking queue, and wait - * until we're woken up. - */ - if (GET_INFO(mvar) != &FULL_MVAR_info) { - if (mvar->head == EndTSOQueue) { - mvar->head = CurrentTSO; - } else { - mvar->tail->link = CurrentTSO; - } - CurrentTSO->link = EndTSOQueue; - mvar->tail = CurrentTSO; - - /* Hack, hack, hack. - * When we block, we push a restart closure - * on the stack - but which closure? - * We happen to know that the BCO we're - * executing looks like this: - * - * 0: STK_CHECK 4 - * 2: HP_CHECK 3 - * 4: TEST 0 29 - * 7: UNPACK - * 8: VAR 3 - * 10: VAR 1 - * 12: primTakeMVar - * 14: ALLOC_CONSTR 0x8213a80 - * 16: VAR 2 - * 18: VAR 2 - * 20: PACK 2 - * 22: VAR 0 - * 24: SLIDE 1 7 - * 27: ENTER - * 28: PANIC - * 29: PANIC - * - * so we rearrange the stack to look the - * way it did when we entered this BCO + case i_takeMVar: + { + StgMVar *mvar = stgCast(StgMVar*,PopPtr()); + /* If the MVar is empty, put ourselves + * on its blocking queue, and wait + * until we're woken up. + */ + if (GET_INFO(mvar) != &FULL_MVAR_info) { + if (mvar->head == EndTSOQueue) { + mvar->head = cap->rCurrentTSO; + } else { + mvar->tail->link = cap->rCurrentTSO; + } + cap->rCurrentTSO->link = EndTSOQueue; + mvar->tail = cap->rCurrentTSO; + + /* Hack, hack, hack. + * When we block, we push a restart closure + * on the stack - but which closure? + * We happen to know that the BCO we're + * executing looks like this: + * + * 0: STK_CHECK 4 + * 2: HP_CHECK 3 + * 4: TEST 0 29 + * 7: UNPACK + * 8: VAR 3 + * 10: VAR 1 + * 12: primTakeMVar + * 14: ALLOC_CONSTR 0x8213a80 + * 16: VAR 2 + * 18: VAR 2 + * 20: PACK 2 + * 22: VAR 0 + * 24: SLIDE 1 7 + * 27: ENTER + * 28: PANIC + * 29: PANIC + * + * so we rearrange the stack to look the + * way it did when we entered this BCO * and push ths BCO. - * What a disgusting hack! - */ - - PopPtr(); - PopPtr(); - PushCPtr(obj); - return ThreadBlocked; - - } else { - PushCPtr(mvar->value); - SET_INFO(mvar,&EMPTY_MVAR_info); - /* ToDo: this is a little strange */ - mvar->value = (StgClosure*)&END_TSO_QUEUE_closure; - } - break; - } + * What a disgusting hack! + */ + + PopPtr(); + PopPtr(); + PushCPtr(obj); + *return2 = ThreadBlocked; + return (void*)(1+(NULL)); + + } else { + PushCPtr(mvar->value); + SET_INFO(mvar,&EMPTY_MVAR_info); + /* ToDo: this is a little strange */ + mvar->value = (StgClosure*)&END_TSO_QUEUE_closure; + } + break; + } #endif - case i_putMVar: - { - StgMVar* mvar = stgCast(StgMVar*,PopPtr()); - StgClosure* value = PopCPtr(); - if (GET_INFO(mvar) == &FULL_MVAR_info) { - obj = raisePrim("putMVar {full MVar}"); - goto enterLoop; - } else { - /* wake up the first thread on the - * queue, it will continue with the - * takeMVar operation and mark the - * MVar empty again. - */ - StgTSO* tso = mvar->head; - SET_INFO(mvar,&FULL_MVAR_info); - mvar->value = value; - if (tso != EndTSOQueue) { - PUSH_ON_RUN_QUEUE(tso); - mvar->head = tso->link; - tso->link = EndTSOQueue; - if (mvar->head == EndTSOQueue) { - mvar->tail = EndTSOQueue; - } - } - } - /* yield for better communication performance */ - context_switch = 1; - break; - } - case i_delay: - case i_waitRead: - case i_waitWrite: - /* As PrimOps.h says: Hmm, I'll think about these later. */ - ASSERT(0); - break; -#endif /* PROVIDE_CONCURRENT */ - case i_ccall_Id: - case i_ccall_IO: - { - CFunDescriptor* descriptor = PopTaggedAddr(); - StgAddr funPtr = PopTaggedAddr(); - ccall(descriptor,funPtr); - break; - } - default: - barf("Unrecognised primop2"); + case i_putMVar: + { + StgMVar* mvar = stgCast(StgMVar*,PopPtr()); + StgClosure* value = PopCPtr(); + if (GET_INFO(mvar) == &FULL_MVAR_info) { + return (raisePrim("putMVar {full MVar}")); + } else { + /* wake up the first thread on the + * queue, it will continue with the + * takeMVar operation and mark the + * MVar empty again. + */ + StgTSO* tso = mvar->head; + SET_INFO(mvar,&FULL_MVAR_info); + mvar->value = value; + if (tso != EndTSOQueue) { + PUSH_ON_RUN_QUEUE(tso); + mvar->head = tso->link; + tso->link = EndTSOQueue; + if (mvar->head == EndTSOQueue) { + mvar->tail = EndTSOQueue; } - break; } - default: - pc--; - printf ( "\n\n" ); - disInstr ( bco, pc ); - barf("\nUnrecognised instruction"); } + /* yield for better communication performance */ + context_switch = 1; + break; } - barf("Ran off the end of bco - yoiks"); - break; - } - case CAF_UNENTERED: - { - StgBlockingQueue* bh; - StgCAF* caf = (StgCAF*)obj; - if (Sp - sizeofW(StgUpdateFrame) < SpLim) { - PushCPtr(obj); /* code to restart with */ - return StackOverflow; - } - /* ToDo: look for Sp==Su && stackInt(0) == UPD_FRAME - and insert an indirection immediately */ - bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW()); - 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; - recordOldToNewPtrs(caf); - PUSH_UPD_FRAME(bh,0); - Sp -= sizeofW(StgUpdateFrame); - caf->link = enteredCAFs; - enteredCAFs = caf; - 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 CAF_BLACKHOLE: - { - /*was StgBlackHole* */ - StgBlockingQueue* bh = (StgBlockingQueue*)obj; - /* Put ourselves on the blocking queue for this black hole and block */ - CurrentTSO->link = bh->blocking_queue; - bh->blocking_queue = CurrentTSO; - PushCPtr(obj); /* code to restart with */ - assert(0); - return ThreadBlocked; - } - case AP_UPD: - { - StgAP_UPD* ap = stgCast(StgAP_UPD*,obj); - int i = ap->n_args; - if (Sp - (i + sizeofW(StgUpdateFrame)) < SpLim) { - PushCPtr(obj); /* code to restart with */ - return StackOverflow; - } - /* ToDo: look for Sp==Su && stackInt(0) == UPD_FRAME - and insert an indirection immediately */ - PUSH_UPD_FRAME(ap,0); - Sp -= sizeofW(StgUpdateFrame); - while (--i >= 0) { - PushWord(payloadWord(ap,i)); - } - obj = ap->fun; -#ifndef LAZY_BLACKHOLING + case i_delay: + case i_waitRead: + case i_waitWrite: + /* As PrimOps.h says: Hmm, I'll think about these later. */ + ASSERT(0); + break; +#endif /* PROVIDE_CONCURRENT */ + case i_ccall_ccall_Id: + case i_ccall_ccall_IO: + case i_ccall_stdcall_Id: + case i_ccall_stdcall_IO: { - /* 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 /* LAZY_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) { - PushWord(payloadWord(pap,i)); - } - obj = pap->fun; - goto enterLoop; - } - case IND: - { - obj = stgCast(StgInd*,obj)->indirectee; - goto enterLoop; - } - case IND_OLDGEN: - { - obj = stgCast(StgIndOldGen*,obj)->indirectee; - goto enterLoop; - } - case CONSTR: - case CONSTR_INTLIKE: - case CONSTR_CHARLIKE: - case CONSTR_STATIC: - case CONSTR_NOCAF_STATIC: - { - while (1) { - switch (get_itbl(stgCast(StgClosure*,Sp))->type) { - case CATCH_FRAME: - PopCatchFrame(); - break; - case UPDATE_FRAME: - PopUpdateFrame(obj); - break; - case SEQ_FRAME: - PopSeqFrame(); - break; - case STOP_FRAME: - { - ASSERT(Sp==(P_)Su); - IF_DEBUG(evaluator, - printObj(obj); - /*fprintf(stderr,"Sp = %p\tSu = %p\n", Sp, Su);*/ - /*printStack(Sp,CurrentTSO->stack+CurrentTSO->stack_size,Su);*/ - ); - PopStopFrame(obj); - return ThreadFinished; - } - case RET_BCO: - { - StgClosure* ret; - PopPtr(); - ret = PopCPtr(); - PushPtr((P_)obj); - obj = ret; - goto enterLoop; - } - case RET_SMALL: /* return to GHC */ - case RET_VEC_SMALL: - case RET_BIG: - case RET_VEC_BIG: - barf("todo: RET_[VEC_]{BIG,SMALL}"); - default: - belch("entered CONSTR with invalid continuation on stack"); - IF_DEBUG(evaluator, - printObj(stgCast(StgClosure*,Sp)) - ); - barf("bailing out"); - } + int r; + CFunDescriptor* descriptor = PopTaggedAddr(); + void (*funPtr)(void) = PopTaggedAddr(); + char cc = (primop2code == i_ccall_stdcall_Id || + primop2code == i_ccall_stdcall_IO) + ? 's' : 'c'; + r = ccall(descriptor,funPtr,bco,cc,cap); + if (r == 0) break; + if (r == 1) + return makeErrorCall( + "unhandled type or too many args/results in ccall"); + if (r == 2) + barf("ccall not configured correctly for this platform"); + barf("unknown return code from ccall"); } - } - default: - { -fprintf(stderr, "enterCountI = %d\n", enterCountI); -fprintf(stderr, "panic: enter: entered unknown closure\n"); -printObj(obj); -fprintf(stderr, "what it points at is\n"); -printObj( ((StgEvacuated*)obj) ->evacuee); -exit(1); - CurrentTSO->whatNext = ThreadEnterGHC; - PushCPtr(obj); /* code to restart with */ - return ThreadYielding; - } - } - barf("Ran off the end of enter - yoiks"); - assert(0); + default: + barf("Unrecognised primop2"); + } + return NULL; } + /* ----------------------------------------------------------------------------- * ccall support code: * marshall moves args from C stack to Haskell stack * unmarshall moves args from Haskell stack to C stack - * argSize calculates how much space you need on the C stack + * argSize calculates how much gSpace you need on the C stack * ---------------------------------------------------------------------------*/ /* Pop arguments off the C stack and Push them onto the Hugs stack. - * Used when preparing for C calling Haskell or in response to + * Used when preparing for C calling Haskell or in regSponse to * Haskell calling C. */ nat marshall(char arg_ty, void* arg) @@ -2811,21 +3106,14 @@ nat marshall(char arg_ty, void* arg) case INT_REP: PushTaggedInt(*((int*)arg)); return ARG_SIZE(INT_TAG); -#ifdef PROVIDE_INT64 - case INT64_REP: - PushTaggedInt64(*((StgInt64*)arg)); - return ARG_SIZE(INT64_TAG); -#endif -#ifdef TODO_PROVIDE_INTEGER +#ifdef TODO_STANDALONE_INTEGER case INTEGER_REP: PushTaggedInteger(*((mpz_ptr*)arg)); return ARG_SIZE(INTEGER_TAG); #endif -#ifdef PROVIDE_WORD case WORD_REP: PushTaggedWord(*((unsigned int*)arg)); return ARG_SIZE(WORD_TAG); -#endif case CHAR_REP: PushTaggedChar(*((char*)arg)); return ARG_SIZE(CHAR_TAG); @@ -2835,26 +3123,22 @@ nat marshall(char arg_ty, void* arg) case DOUBLE_REP: PushTaggedDouble(*((double*)arg)); return ARG_SIZE(DOUBLE_TAG); -#ifdef PROVIDE_ADDR case ADDR_REP: PushTaggedAddr(*((void**)arg)); return ARG_SIZE(ADDR_TAG); -#endif -#ifdef PROVIDE_STABLE case STABLE_REP: PushTaggedStablePtr(*((StgStablePtr*)arg)); return ARG_SIZE(STABLE_TAG); -#endif +#ifdef PROVIDE_FOREIGN case FOREIGN_REP: /* Not allowed in this direction - you have to * call makeForeignPtr explicitly */ barf("marshall: ForeignPtr#\n"); break; -#ifdef PROVIDE_ARRAY +#endif case BARR_REP: case MUTBARR_REP: -#endif /* Not allowed in this direction */ barf("marshall: [Mutable]ByteArray#\n"); break; @@ -2865,7 +3149,7 @@ nat marshall(char arg_ty, void* arg) } /* Pop arguments off the Hugs stack and Push them onto the C stack. - * Used when preparing for Haskell calling C or in response to + * Used when preparing for Haskell calling C or in regSponse to * C calling Haskell. */ nat unmarshall(char res_ty, void* res) @@ -2874,21 +3158,14 @@ nat unmarshall(char res_ty, void* res) case INT_REP: *((int*)res) = PopTaggedInt(); return ARG_SIZE(INT_TAG); -#ifdef PROVIDE_INT64 - case INT64_REP: - *((StgInt64*)res) = PopTaggedInt64(); - return ARG_SIZE(INT64_TAG); -#endif -#ifdef TODO_PROVIDE_INTEGER +#ifdef TODO_STANDALONE_INTEGER case INTEGER_REP: *((mpz_ptr*)res) = PopTaggedInteger(); return ARG_SIZE(INTEGER_TAG); #endif -#ifdef PROVIDE_WORD case WORD_REP: *((unsigned int*)res) = PopTaggedWord(); return ARG_SIZE(WORD_TAG); -#endif case CHAR_REP: *((int*)res) = PopTaggedChar(); return ARG_SIZE(CHAR_TAG); @@ -2898,26 +3175,22 @@ nat unmarshall(char res_ty, void* res) case DOUBLE_REP: *((double*)res) = PopTaggedDouble(); return ARG_SIZE(DOUBLE_TAG); -#ifdef PROVIDE_ADDR case ADDR_REP: *((void**)res) = PopTaggedAddr(); return ARG_SIZE(ADDR_TAG); -#endif -#ifdef PROVIDE_STABLE case STABLE_REP: *((StgStablePtr*)res) = PopTaggedStablePtr(); return ARG_SIZE(STABLE_TAG); -#endif +#ifdef PROVIDE_FOREIGN case FOREIGN_REP: { StgForeignObj *result = stgCast(StgForeignObj*,PopPtr()); *((void**)res) = result->data; return sizeofW(StgPtr); } -#ifdef PROVIDE_ARRAY +#endif case BARR_REP: case MUTBARR_REP: -#endif { StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr()); *((void**)res) = stgCast(void*,&(arr->payload)); @@ -2936,21 +3209,14 @@ nat argSize( const char* ks ) case INT_REP: sz += sizeof(StgWord) * ARG_SIZE(INT_TAG); break; -#ifdef PROVIDE_INT64 - case INT64_REP: - sz += sizeof(StgWord) * ARG_SIZE(INT64_TAG); - break; -#endif -#ifdef TODO_PROVIDE_INTEGER +#ifdef TODO_STANDALONE_INTEGER case INTEGER_REP: sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG); break; #endif -#ifdef PROVIDE_WORD case WORD_REP: sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG); break; -#endif case CHAR_REP: sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG); break; @@ -2960,23 +3226,17 @@ nat argSize( const char* ks ) case DOUBLE_REP: sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG); break; -#ifdef PROVIDE_ADDR case ADDR_REP: sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG); break; -#endif -#ifdef PROVIDE_STABLE case STABLE_REP: sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG); break; -#endif #ifdef PROVIDE_FOREIGN case FOREIGN_REP: #endif -#ifdef PROVIDE_ARRAY case BARR_REP: case MUTBARR_REP: -#endif sz += sizeof(StgPtr); break; default: @@ -2987,4 +3247,186 @@ nat argSize( const char* ks ) return sz; } + +/* ----------------------------------------------------------------------------- + * encode/decode Float/Double code for standalone Hugs + * Code based on the HBC code (lib/fltcode.c) and more recently GHC + * (ghc/rts/StgPrimFloat.c) + * ---------------------------------------------------------------------------*/ + +#ifdef STANDALONE_INTEGER + +#if IEEE_FLOATING_POINT +#define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1) +/* DMINEXP is defined in values.h on Linux (for example) */ +#define DHIGHBIT 0x00100000 +#define DMSBIT 0x80000000 + +#define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1) +#define FHIGHBIT 0x00800000 +#define FMSBIT 0x80000000 +#else +#error The following code doesnt work in a non-IEEE FP environment +#endif + +#ifdef WORDS_BIGENDIAN +#define L 1 +#define H 0 +#else +#define L 0 +#define H 1 +#endif + + +StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */ +{ + StgDouble r; + I_ i; + + /* Convert a B to a double; knows a lot about internal rep! */ + for(r = 0.0, i = s->used-1; i >= 0; i--) + r = (r * B_BASE_FLT) + s->stuff[i]; + + /* Now raise to the exponent */ + if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */ + r = ldexp(r, e); + + /* handle the sign */ + if (s->sign < 0) r = -r; + + return r; +} + + + +#if ! FLOATS_AS_DOUBLES +StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */ +{ + StgFloat r; + I_ i; + + /* Convert a B to a float; knows a lot about internal rep! */ + for(r = 0.0, i = s->used-1; i >= 0; i--) + r = (r * B_BASE_FLT) + s->stuff[i]; + + /* Now raise to the exponent */ + if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */ + r = ldexp(r, e); + + /* handle the sign */ + if (s->sign < 0) r = -r; + + return r; +} +#endif /* FLOATS_AS_DOUBLES */ + + + +/* This only supports IEEE floating point */ +void B__decodeDouble (B* man, I_* exp, StgDouble dbl) +{ + /* Do some bit fiddling on IEEE */ + nat low, high; /* assuming 32 bit ints */ + int sign, iexp; + union { double d; int i[2]; } u; /* assuming 32 bit ints, 64 bit double */ + + u.d = dbl; /* grab chunks of the double */ + low = u.i[L]; + high = u.i[H]; + + ASSERT(B_BASE == 256); + + /* Assume that the supplied B is the right size */ + man->size = 8; + + if (low == 0 && (high & ~DMSBIT) == 0) { + man->sign = man->used = 0; + *exp = 0L; + } else { + man->used = 8; + man->sign = 1; + iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP; + sign = high; + + high &= DHIGHBIT-1; + if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */ + high |= DHIGHBIT; + else { + iexp++; + /* A denorm, normalize the mantissa */ + while (! (high & DHIGHBIT)) { + high <<= 1; + if (low & DMSBIT) + high++; + low <<= 1; + iexp--; + } + } + *exp = (I_) iexp; + + man->stuff[7] = (((W_)high) >> 24) & 0xff; + man->stuff[6] = (((W_)high) >> 16) & 0xff; + man->stuff[5] = (((W_)high) >> 8) & 0xff; + man->stuff[4] = (((W_)high) ) & 0xff; + + man->stuff[3] = (((W_)low) >> 24) & 0xff; + man->stuff[2] = (((W_)low) >> 16) & 0xff; + man->stuff[1] = (((W_)low) >> 8) & 0xff; + man->stuff[0] = (((W_)low) ) & 0xff; + + if (sign < 0) man->sign = -1; + } + do_renormalise(man); +} + + +#if ! FLOATS_AS_DOUBLES +void B__decodeFloat (B* man, I_* exp, StgFloat flt) +{ + /* Do some bit fiddling on IEEE */ + int high, sign; /* assuming 32 bit ints */ + union { float f; int i; } u; /* assuming 32 bit float and int */ + + u.f = flt; /* grab the float */ + high = u.i; + + ASSERT(B_BASE == 256); + + /* Assume that the supplied B is the right size */ + man->size = 4; + + if ((high & ~FMSBIT) == 0) { + man->sign = man->used = 0; + *exp = 0; + } else { + man->used = 4; + man->sign = 1; + *exp = ((high >> 23) & 0xff) + MY_FMINEXP; + sign = high; + + high &= FHIGHBIT-1; + if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */ + high |= FHIGHBIT; + else { + (*exp)++; + /* A denorm, normalize the mantissa */ + while (! (high & FHIGHBIT)) { + high <<= 1; + (*exp)--; + } + } + man->stuff[3] = (((W_)high) >> 24) & 0xff; + man->stuff[2] = (((W_)high) >> 16) & 0xff; + man->stuff[1] = (((W_)high) >> 8) & 0xff; + man->stuff[0] = (((W_)high) ) & 0xff; + + if (sign < 0) man->sign = -1; + } + do_renormalise(man); +} + +#endif /* FLOATS_AS_DOUBLES */ + +#endif /* STANDALONE_INTEGER */ + #endif /* INTERPRETER */