-/* -*- mode: hugs-c; -*- */
+
/* -----------------------------------------------------------------------------
* Bytecode evaluator
*
* Copyright (c) 1994-1998.
*
* $RCSfile: Evaluator.c,v $
- * $Revision: 1.4 $
- * $Date: 1999/01/26 11:12:41 $
+ * $Revision: 1.11 $
+ * $Date: 1999/03/09 14:51:21 $
* ---------------------------------------------------------------------------*/
#include "Rts.h"
#ifdef PROVIDE_INTEGER
static inline mpz_ptr mpz_alloc ( void );
-static inline void mpz_free ( mpz_ptr );
+//static inline void mpz_free ( mpz_ptr );
static inline mpz_ptr mpz_alloc ( void )
{
return r;
}
+#if 0 /* apparently unused */
static inline void mpz_free ( mpz_ptr a )
{
mpz_clear(a);
free(a);
}
#endif
+#endif
/* --------------------------------------------------------------------------
*
* ------------------------------------------------------------------------*/
-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 );
+/*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 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 );
+/*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 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 );
+/*static*/ inline void setStackWord ( StgStackOffset i, StgWord w );
-static inline void setStackWord ( StgStackOffset i, StgWord w ) { Sp[i] = w; }
+/*static*/ inline void setStackWord ( StgStackOffset i, StgWord w ) { Sp[i] = w; }
-static inline void PushTaggedRealWorld( void );
-static inline void PushTaggedInt ( StgInt x );
+/*static*/ inline void PushTaggedRealWorld( void );
+/*static*/ inline void PushTaggedInt ( StgInt x );
#ifdef PROVIDE_INT64
-static inline void PushTaggedInt64 ( StgInt64 x );
+/*static*/ inline void PushTaggedInt64 ( StgInt64 x );
#endif
#ifdef PROVIDE_INTEGER
-static inline void PushTaggedInteger ( mpz_ptr x );
+/*static*/ inline void PushTaggedInteger ( mpz_ptr x );
#endif
#ifdef PROVIDE_WORD
-static inline void PushTaggedWord ( StgWord x );
+/*static*/ inline void PushTaggedWord ( StgWord x );
#endif
#ifdef PROVIDE_ADDR
-static inline void PushTaggedAddr ( StgAddr x );
+/*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 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); }
+/*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); }
+/*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 )
+/*static*/ inline void PushTaggedInteger ( mpz_ptr x )
{
StgForeignObj *result;
- StgWeak *w;
+ //StgWeak *w;
result = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
SET_HDR(result,&FOREIGN_info,CCCS);
}
#endif
#ifdef PROVIDE_WORD
-static inline void PushTaggedWord ( StgWord x ) { Sp -= sizeofW(StgWord); *Sp = x; PushTag(WORD_TAG); }
+/*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); }
+/*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 = 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 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 );
+/*static*/ inline void PopTaggedRealWorld ( void );
+/*static*/ inline StgInt PopTaggedInt ( void );
#ifdef PROVIDE_INT64
-static inline StgInt64 PopTaggedInt64 ( void );
+/*static*/ inline StgInt64 PopTaggedInt64 ( void );
#endif
#ifdef PROVIDE_INTEGER
-static inline mpz_ptr PopTaggedInteger ( void );
+/*static*/ inline mpz_ptr PopTaggedInteger ( void );
#endif
#ifdef PROVIDE_WORD
-static inline StgWord PopTaggedWord ( void );
+/*static*/ inline StgWord PopTaggedWord ( void );
#endif
#ifdef PROVIDE_ADDR
-static inline StgAddr PopTaggedAddr ( void );
+/*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 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;}
+/*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;}
+/*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);}
+/*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;}
+/*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;}
+/*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 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 );
+/*static*/ inline StgInt taggedStackInt ( StgStackOffset i );
#ifdef PROVIDE_INT64
-static inline StgInt64 taggedStackInt64 ( StgStackOffset i );
+/*static*/ inline StgInt64 taggedStackInt64 ( StgStackOffset i );
#endif
#ifdef PROVIDE_WORD
-static inline StgWord taggedStackWord ( StgStackOffset i );
+/*static*/ inline StgWord taggedStackWord ( StgStackOffset i );
#endif
#ifdef PROVIDE_ADDR
-static inline StgAddr taggedStackAddr ( StgStackOffset i );
+/*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 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); }
+/*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); }
+/*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); }
+/*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); }
+/*static*/ inline StgAddr taggedStackAddr ( StgStackOffset i ) { checkTag(ADDR_TAG,Sp[i]); return *stgCast(StgAddr*, Sp+1+i); }
#endif
-static inline StgChar taggedStackChar ( StgStackOffset i ) { checkTag(CHAR_TAG,Sp[i]); return *stgCast(StgChar*, Sp+1+i); }
-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); }
+
+/*static*/ inline StgChar taggedStackChar ( StgStackOffset i ) { checkTag(CHAR_TAG,Sp[i]); return stgCast(StgChar, *(Sp+1+i)) ; }
+
+
+/*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); }
/* --------------------------------------------------------------------------
/* --------------------------------------------------------------------------
* 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 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
* ------------------------------------------------------------------------*/
printPtr(stgCast(StgPtr,Su->updatee));
fprintf(stderr, " with ");
printObj(obj);
- fprintf(stderr,"\nSp = %p\tSu = %p\n", Sp, Su);
+ fprintf(stderr,"Sp = %p\tSu = %p\n\n", Sp, Su);
);
#ifndef LAZY_BLACKHOLING
ASSERT(get_itbl(Su->updatee)->type == BLACKHOLE
{
StgCatchFrame* fp;
/* ToDo: stack check! */
- Sp -= sizeofW(StgCatchFrame*); /* ToDo: this can't be right */
+ Sp -= sizeofW(StgCatchFrame);
fp = stgCast(StgCatchFrame*,Sp);
SET_HDR(fp,&catch_frame_info,CCCS);
fp->handler = handler;
{
StgSeqFrame* fp;
/* ToDo: stack check! */
- Sp -= sizeofW(StgSeqFrame*); /* ToDo: this can't be right */
+ Sp -= sizeofW(StgSeqFrame);
fp = stgCast(StgSeqFrame*,Sp);
SET_HDR(fp,&seq_frame_info,CCCS);
fp->link = Su;
StgClosure *raise_closure;
/* This closure represents the expression 'raise# E' where E
- * is the exception raise. It is used to overwrite all the
+ * is the exception raised. It is used to overwrite all the
* thunks which are currently under evaluataion.
*/
raise_closure = (StgClosure *)allocate(sizeofW(StgClosure)+1);
Sp += sizeofW(StgCatchFrame); /* Pop */
PushCPtr(errObj);
return handler;
- }
+ }
case STOP_FRAME:
- barf("raiseError: STOP_FRAME");
+ barf("raiseError: uncaught exception: STOP_FRAME");
default:
barf("raiseError: weird activation record");
}
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);
#else
#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.
* iterations.
*/
char enterCount = 0;
+ //fprintf ( stderr, "enter: Sp=%p Su=%p\n", Sp, Su);
enterLoop:
- /* ASSERT(StorageMgrInfo.hp_start <= Hp && Hp < HpLim && HpLim == StorageMgrInfo.hplim); */
+ enterCountI++;// fprintf(stderr, "%d\n", enterCountI);
ASSERT(SpLim <= Sp && Sp <= stgCast(StgPtr,Su));
-#if 0
- IF_DEBUG(evaluator,
+
+#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,"Entering: "); printObj(obj);
- );
-#endif
-#if 0
- IF_DEBUG(sanity,
- {
- /*belch("Starting sanity check");
- *SaveThreadState();
- *checkTSO(CurrentTSO, heap_step);
- * This check fails if we've done any updates because we
- * whack into holes in the heap.
- *checkHeap(?,?);
- *belch("Ending sanity check");
- */
- }
- );
-#endif
-#if 0
- IF_DEBUG(evaluator,
- fprintf(stderr,"Continue?\n");
- getchar()
- );
+ 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 ) {
{
StgBCO* bco = stgCast(StgBCO*,obj);
InstrPtr pc = 0;
-#if 1 /* We don't use an explicit HP_CHECK anymore */
+
if (doYouWantToGC()) {
PushCPtr(obj); /* code to restart with */
return HeapOverflow;
}
-#endif
+
while (1) {
ASSERT(pc < bco->n_instrs);
IF_DEBUG(evaluator,
barf("INTERNAL_ERROR at %p:%d",bco,pc-1);
case i_PANIC:
barf("PANIC at %p:%d",bco,pc-1);
-#if 0
- case i_HP_CHECK:
- {
- int n = bcoInstr(bco,pc++);
- /* ToDo: we could allocate the whole thing now and
- * slice it up ourselves
- */
- if (doYouWantToGC()) {
- PushCPtr(obj); /* code to restart with */
- return HeapOverflow;
- }
- break;
- }
-#endif
case i_STK_CHECK:
{
int n = bcoInstr(bco,pc++);
}
/* now deal with "update frame" */
- /* as an optimisation, we process all on top of stack instead of just the top one */
+ /* 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);
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");
);
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++);
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();
case i_TEST:
{
int tag = bcoInstr(bco,pc++);
- StgWord offset = bcoInstr(bco,pc++);
+ StgWord offset = bcoInstr16(bco,pc); pc += 2;
if (constrTag(stgCast(StgClosure*,stackPtr(0))) != tag) {
pc += offset;
}
}
break;
}
+ case i_VAR_big:
+ {
+ PushPtr(stackPtr(bcoInstr16(bco,pc))); pc+=2;
+ break;
+ }
case i_VAR:
{
PushPtr(stackPtr(bcoInstr(bco,pc++)));
PushPtr(stgCast(StgPtr,bcoConstPtr(bco,bcoInstr(bco,pc++))));
break;
}
- case i_CONST2:
+ case i_CONST_big:
{
- StgWord o1 = bcoInstr(bco,pc++);
- StgWord o2 = bcoInstr(bco,pc++);
- StgWord o = o1*256 + o2;
- PushPtr(stgCast(StgPtr,bcoConstPtr(bco,o)));
+ PushPtr(stgCast(StgPtr,bcoConstPtr(bco,bcoInstr16(bco,pc)))); pc += 2;
break;
}
case i_VOID:
}
case i_PACK_INT:
{
- StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(IZh_sizeW));
- SET_HDR(o,&IZh_con_info,??);
+ StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Izh_sizeW));
+ SET_HDR(o,&Izh_con_info,??);
payloadWord(o,0) = PopTaggedInt();
IF_DEBUG(evaluator,
fprintf(stderr,"\tBuilt ");
}
case i_TEST_INT:
{
- StgWord offset = bcoInstr(bco,pc++);
+ StgWord offset = bcoInstr16(bco,pc);
StgInt x = PopTaggedInt();
StgInt y = PopTaggedInt();
+ pc += 2;
if (x != y) {
pc += offset;
}
}
case i_PACK_INT64:
{
- StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(I64Zh_sizeW));
- SET_HDR(o,&I64Zh_con_info,??);
+ 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 ");
}
case i_PACK_WORD:
{
- StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(WZh_sizeW));
+ StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Wzh_sizeW));
- SET_HDR(o,&WZh_con_info,??);
+ SET_HDR(o,&Wzh_con_info,??);
payloadWord(o,0) = PopTaggedWord();
IF_DEBUG(evaluator,
fprintf(stderr,"\tBuilt ");
}
case i_PACK_ADDR:
{
- StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(AZh_sizeW));
- SET_HDR(o,&AZh_con_info,??);
+ StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Azh_sizeW));
+ SET_HDR(o,&Azh_con_info,??);
payloadPtr(o,0) = PopTaggedAddr();
IF_DEBUG(evaluator,
fprintf(stderr,"\tBuilt ");
}
case i_PACK_CHAR:
{
- StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(CZh_sizeW));
- SET_HDR(o,&CZh_con_info,??);
+ StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Czh_sizeW));
+ SET_HDR(o,&Czh_con_info,??);
payloadWord(o,0) = PopTaggedChar();
PushPtr(stgCast(StgPtr,o));
IF_DEBUG(evaluator,
}
case i_PACK_FLOAT:
{
- StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(FZh_sizeW));
- SET_HDR(o,&FZh_con_info,??);
+ 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 ");
}
case i_PACK_DOUBLE:
{
- StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(DZh_sizeW));
- SET_HDR(o,&DZh_con_info,??);
+ 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 ");
}
case i_PACK_STABLE:
{
- StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(StableZh_sizeW));
+ StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Stablezh_sizeW));
SET_HDR(o,&StablePtr_con_info,??);
payloadWord(o,0) = PopTaggedStablePtr();
IF_DEBUG(evaluator,
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;
+ }
+
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_orInt: OP_II_I(x|y); break;
case i_xorInt: OP_II_I(x^y); break;
case i_notInt: OP_I_I(~x); break;
- case i_shiftLInt: OP_IW_I(x<<y); break;
- case i_shiftRAInt: OP_IW_I(x>>y); break; /* ToDo */
- case i_shiftRLInt: OP_IW_I(x>>y); break; /* ToDo */
+ case i_shiftLInt: OP_II_I(x<<y); break;
+ case i_shiftRAInt: OP_II_I(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_intToAddr: OP_I_A((StgAddr)x); break; /* ToDo */
case i_addrToInt: OP_A_I((StgInt)x); break; /* ToDo */
- case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrZh(r,x,y)); break;
- case i_readCharOffAddr: OP_AI_C(indexCharOffAddrZh(r,x,y)); break;
- case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrZh(x,y,z)); break;
+ case i_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
+ case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break;
+ case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrzh(x,y,z)); break;
- case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrZh(r,x,y)); break;
- case i_readIntOffAddr: OP_AI_I(indexIntOffAddrZh(r,x,y)); break;
- case i_writeIntOffAddr: OP_AII_(writeIntOffAddrZh(x,y,z)); break;
+ case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
+ case i_readIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
+ case i_writeIntOffAddr: OP_AII_(writeIntOffAddrzh(x,y,z)); break;
#ifdef PROVIDE_INT64
- case i_indexInt64OffAddr: OP_AI_z(indexInt64OffAddrZh(r,x,y)); break;
- case i_readInt64OffAddr: OP_AI_z(indexInt64OffAddrZh(r,x,y)); break;
- case i_writeInt64OffAddr: OP_AIz_(writeInt64OffAddrZh(x,y,z)); break;
+ case i_indexInt64OffAddr: OP_AI_z(indexInt64OffAddrzh(r,x,y)); break;
+ case i_readInt64OffAddr: OP_AI_z(indexInt64OffAddrzh(r,x,y)); break;
+ case i_writeInt64OffAddr: OP_AIz_(writeInt64OffAddrzh(x,y,z)); break;
#endif
- case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrZh(r,x,y)); break;
- case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrZh(r,x,y)); break;
- case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrZh(x,y,z)); break;
+ case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
+ case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
+ case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrzh(x,y,z)); break;
- case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrZh(r,x,y)); break;
- case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrZh(r,x,y)); break;
- case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrZh(x,y,z)); break;
+ case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
+ case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
+ case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrzh(x,y,z)); break;
- case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrZh(r,x,y)); break;
- case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrZh(r,x,y)); break;
- case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrZh(x,y,z)); break;
+ case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
+ case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
+ case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z)); break;
#ifdef PROVIDE_STABLE
- case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrZh(r,x,y)); break;
- case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrZh(r,x,y)); break;
- case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrZh(x,y,z)); break;
+ case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
+ case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
+ case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
#endif
#endif /* PROVIDE_ADDR */
break;
#endif /* PROVIDE_INT64 */
#ifdef PROVIDE_INTEGER
- case i_encodeFloatZ: OP_ZI_F(__encodeFloat(x,y)); break;
+ case i_encodeFloatZ: OP_ZI_F(__encodeFloat(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;
break;
#endif /* PROVIDE_INT64 */
#ifdef PROVIDE_INTEGER
- case i_encodeDoubleZ: OP_ZI_D(__encodeDouble(x,y)); break;
+ case i_encodeDoubleZ: OP_ZI_D(__encodeDouble(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;
switch (bcoInstr(bco,pc++)) {
case i_INTERNAL_ERROR2:
barf("INTERNAL_ERROR2 at %p:%d",bco,pc-1);
- case i_catch: /* catch#{e,h} */
- {
- StgClosure* h;
- obj = PopCPtr();
- h = PopCPtr();
-
- /* catch suffers the same problem as takeMVar:
- * it tries to do control flow even if it isn't
- * the last instruction in the BCO.
- * This can leave a mess on the stack if the
- * last instructions are anything important
- * like SLIDE. Our vile hack depends on the
- * fact that with the current code generator,
- * we know exactly that i_catch is followed
- * by code that drops 2 variables off the
- * stack.
- * What a vile hack!
- */
- Sp += 2;
- PushCatchFrame(h);
- goto enterLoop;
- }
case i_raise: /* raise#{err} */
{
StgClosure* err = PopCPtr();
obj = raiseAnError(err);
goto enterLoop;
}
- case i_force: /* force#{x} (evaluate x, primreturn nothing) */
- {
- StgClosure* x;
- obj = PopCPtr();
-
- /* force suffers the same problem as takeMVar:
- * it tries to do control flow even if it isn't
- * the last instruction in the BCO.
- * This can leave a mess on the stack if the
- * last instructions are anything important
- * like SLIDE. Our vile hack depends on the
- * fact that with the current code generator,
- * we know exactly that i_force is followed
- * by code that drops 1 variable off the stack.
- * What a vile hack!
- */
- Sp += 1;
-
- PushSeqFrame();
- goto enterLoop;
- }
#ifdef PROVIDE_ARRAY
case i_newRef:
{
{
nat n = PopTaggedInt(); /* or Word?? */
StgClosure* init = PopCPtr();
- StgWord size = sizeofW(StgArrPtrs) + n;
+ StgWord size = sizeofW(StgMutArrPtrs) + n;
nat i;
- StgArrPtrs* arr
- = stgCast(StgArrPtrs*,allocate(size));
+ StgMutArrPtrs* arr
+ = stgCast(StgMutArrPtrs*,allocate(size));
SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
arr->ptrs = n;
for (i = 0; i < n; ++i) {
case i_readArray:
case i_indexArray:
{
- StgArrPtrs* arr = stgCast(StgArrPtrs*,PopPtr());
+ StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
nat i = PopTaggedInt(); /* or Word?? */
StgWord n = arr->ptrs;
if (i >= n) {
}
case i_writeArray:
{
- StgArrPtrs* arr = stgCast(StgArrPtrs*,PopPtr());
+ StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
nat i = PopTaggedInt(); /* or Word? */
StgClosure* v = PopCPtr();
StgWord n = arr->ptrs;
case i_sizeArray:
case i_sizeMutableArray:
{
- StgArrPtrs* arr = stgCast(StgArrPtrs*,PopPtr());
+ StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
PushTaggedInt(arr->ptrs);
break;
}
case i_unsafeFreezeArray:
{
- StgArrPtrs* arr = stgCast(StgArrPtrs*,PopPtr());
+ StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
PushPtr(stgCast(StgPtr,arr));
break;
StgWord size = sizeofW(StgArrWords) + words;
nat i;
StgArrWords* arr = stgCast(StgArrWords*,allocate(size));
- SET_HDR(arr,&MUT_ARR_WORDS_info,CCCS);
+ SET_HDR(arr,&ARR_WORDS_info,CCCS);
arr->words = words;
#ifdef DEBUG
for (i = 0; i < n; ++i) {
/* 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_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_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;
+ 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;
#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;
+ 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_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;
+ 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;
+ 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 */
#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;
stable_ptr_free = stable_ptr_table + stable_ptr;
break;
}
+#endif /* 0 */
+
+
#endif /* PROVIDE_STABLE */
#ifdef PROVIDE_CONCURRENT
case i_fork:
break;
}
default:
- barf("Unrecognised instruction");
+ pc--;
+ printf ( "\n\n" );
+ disInstr ( bco, pc );
+ barf("\nUnrecognised instruction");
}
}
barf("Ran off the end of bco - yoiks");
}
case CAF_UNENTERED:
{
- StgCAF* caf = stgCast(StgCAF*,obj);
+ 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 */
- {
- StgBlackHole* bh = stgCast(StgBlackHole*,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 = stgCast(StgClosure*,bh);
- PUSH_UPD_FRAME(bh,0);
- Sp -= sizeofW(StgUpdateFrame);
- }
+ /* 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;
}
case CAF_ENTERED:
{
- StgCAF* caf = stgCast(StgCAF*,obj);
+ StgCAF* caf = (StgCAF*)obj;
obj = caf->value; /* it's just a fancy indirection */
goto enterLoop;
}
case BLACKHOLE:
case CAF_BLACKHOLE:
{
- StgBlackHole* bh = stgCast(StgBlackHole*,obj);
+ /*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:
PushCPtr(obj); /* code to restart with */
return StackOverflow;
}
- /* ToDo: look for Sp==Su && stackInt(0) == UPD_FRAME and insert an indirection immediately */
+ /* 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) {
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:
}
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);
}
/* -----------------------------------------------------------------------------
PushTaggedAddr(*((void**)arg));
return ARG_SIZE(ADDR_TAG);
#endif
+#ifdef PROVIDE_STABLE
case STABLE_REP:
PushTaggedStablePtr(*((StgStablePtr*)arg));
return ARG_SIZE(STABLE_TAG);
+#endif
case FOREIGN_REP:
/* Not allowed in this direction - you have to
* call makeForeignPtr explicitly
*((void**)res) = PopTaggedAddr();
return ARG_SIZE(ADDR_TAG);
#endif
+#ifdef PROVIDE_STABLE
case STABLE_REP:
*((StgStablePtr*)res) = PopTaggedStablePtr();
return ARG_SIZE(STABLE_TAG);
+#endif
case FOREIGN_REP:
{
StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
case MUTBARR_REP:
#endif
{
- StgArrPtrs* arr = stgCast(StgArrPtrs*,PopPtr());
+ StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
*((void**)res) = stgCast(void*,&(arr->payload));
return sizeofW(StgPtr);
}
projects / ghc-hetmet.git / blobdiff