* Copyright (c) 1994-1998.
*
* $RCSfile: Evaluator.c,v $
- * $Revision: 1.7 $
- * $Date: 1999/02/05 15:25:05 $
+ * $Revision: 1.44 $
+ * $Date: 2000/03/20 09:42:49 $
* ---------------------------------------------------------------------------*/
#include "Rts.h"
#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 "Prelude.h"
+#include "ITimer.h"
#include "Evaluator.h"
+#include "sainteger.h"
#ifdef DEBUG
#include "Printer.h"
#include "Disassembler.h"
-
#include "Sanity.h"
#include "StgRun.h"
#endif
#ifdef HAVE_IEEE754_H
#include <ieee754.h> /* These are for primops */
#endif
-#ifdef PROVIDE_INTEGER
-#include "gmp.h" /* These are for primops */
-#endif
+
+
+/* Allegedly useful macro, taken from ClosureMacros.h */
+#define payloadWord( c, i ) (*stgCast(StgWord*, ((c)->payload+(i))))
+#define payloadPtr( c, i ) (*stgCast(StgPtr*, ((c)->payload+(i))))
/* An incredibly useful abbreviation.
* Interestingly, there are some uses of END_TSO_QUEUE_closure that
#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
-void setRtsFlags( int x );
-void setRtsFlags( int x )
-{
- *(int*)(&(RtsFlags.DebugFlags)) = x;
-}
+/* 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 );
+extern int /*Bool*/ combined;
/* --------------------------------------------------------------------------
- * 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)
-{
- fprintf(stderr,"Stack Overflow\n");
- exit(1);
-}
-void OutOfHeapHook (unsigned long request_size, unsigned long heap_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,"Out Of Heap\n");
- exit(1);
+ int i;
+ cpCurr = CP_NIL;
+ cpInUse = 0;
+ for (i = 0; i < M_CPTAB; i++)
+ cpTab[i].who = CP_NIL;
}
-void MallocFailHook (unsigned long request_size /* in bytes */, char *msg)
+
+
+
+void cp_enter ( StgBCO* b )
{
- fprintf(stderr,"Malloc Fail\n");
- exit(1);
-}
-void defaultsHook (void)
+ 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 cp_bill_words ( int nw )
{
- /* do nothing */
+ if (cpCurr == CP_NIL) return;
+ cpTab[cpCurr].bytes += sizeof(StgWord)*nw;
}
-/* --------------------------------------------------------------------------
- * 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 )
+void cp_bill_insns ( int ni )
{
- mpz_ptr r = stgCast(mpz_ptr,stgMallocBytes( sizeof(mpz_t),"mpz_alloc"));
- mpz_init(r);
- return r;
+ if (cpCurr == CP_NIL) return;
+ cpTab[cpCurr].insns += ni;
}
-static /*inline*/ void mpz_free ( mpz_ptr a )
+
+static double percent ( double a, double b )
{
- mpz_clear(a);
- free(a);
+ return (100.0 * a) / b;
}
-#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 ) { *(--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 );
-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 )
+void cp_show ( void )
{
- 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
+ int i, j, max, maxN, totE, totB, totI, cumE, cumB, cumI;
+ char nm[200];
+
+ if (cpInUse == -1) return;
+
+ fflush(stdout);fflush(stderr);
+ printf ( "\n\n" );
+
+ 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)
+ );
+
+ cpTab[max].twho = cpTab[max].who;
+ cpTab[max].who = CP_NIL;
+ }
+
+ for (i = 0; i < M_CPTAB; i++)
+ cpTab[i].who = cpTab[i].twho;
- PushPtr(stgCast(StgPtr,result));
+ printf ( "\n" );
}
+
#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 = 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
-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); }
/* --------------------------------------------------------------------------
- * 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);
-}
+
+typedef struct {
+ StgTSOBlockReason reason;
+ unsigned int delay;
+} HugsBlock;
+
/* --------------------------------------------------------------------------
- * 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
* ------------------------------------------------------------------------*/
-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 );
+/* 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.
-static /*inline*/ StgClosure* raiseAnError ( StgClosure* errObj );
+ 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.
-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,"\nSp = %p\tSu = %p\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;
-}
+ 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.
+*/
-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*); /* ToDo: this can't be right */
- fp = stgCast(StgCatchFrame*,Sp);
- SET_HDR(fp,&catch_frame_info,CCCS);
- fp->handler = handler;
- fp->link = Su;
- Su = stgCast(StgUpdateFrame*,fp);
-}
+/* Forward decls ... */
+static void* enterBCO_primop1 ( int );
+static void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */,
+ StgBCO**, Capability*, HugsBlock * );
+static inline void PopUpdateFrame ( StgClosure* obj );
+static inline void PopCatchFrame ( void );
+static inline void PopSeqFrame ( void );
+static inline void PopStopFrame( StgClosure* obj );
+static inline void PushTaggedRealWorld( void );
+/* static inline void PushTaggedInteger ( mpz_ptr ); */
+static inline StgPtr grabHpUpd( nat size );
+static inline StgPtr grabHpNonUpd( nat size );
+static StgClosure* raiseAnError ( StgClosure* exception );
-static /*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;
-}
+static int enterCountI = 0;
-static /*inline*/ void PushSeqFrame( void )
-{
- StgSeqFrame* fp;
- /* ToDo: stack check! */
- Sp -= sizeofW(StgSeqFrame*); /* ToDo: this can't be right */
- fp = stgCast(StgSeqFrame*,Sp);
- SET_HDR(fp,&seq_frame_info,CCCS);
- fp->link = Su;
- Su = stgCast(StgUpdateFrame*,fp);
-}
+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
-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 raise. 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;
- 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: STOP_FRAME");
- default:
- barf("raiseError: weird activation record");
- }
- }
-}
+#define gSp MainRegTable.rSp
+#define gSu MainRegTable.rSu
+#define gSpLim MainRegTable.rSpLim
-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;
-#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)
-
-/* --------------------------------------------------------------------------
- * Evaluator
- * ------------------------------------------------------------------------*/
-#define OP_CC_B(e) \
-{ \
- unsigned char x = PopTaggedChar(); \
- unsigned char y = PopTaggedChar(); \
- PushTaggedBool(e); \
-}
+#define RETURN(vvv) { \
+ StgThreadReturnCode retVal=(vvv); \
+ SSS; \
+ cap->rCurrentTSO->sp = gSp; \
+ cap->rCurrentTSO->su = gSu; \
+ cap->rCurrentTSO->splim = gSpLim; \
+ return retVal; \
+ }
-#define OP_C_I(e) \
-{ \
- unsigned char x = PopTaggedChar(); \
- PushTaggedInt(e); \
-}
-#define OP__I(e) \
-{ \
- PushTaggedInt(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_IW_I(e) \
-{ \
- StgInt x = PopTaggedInt(); \
- StgWord y = PopTaggedWord(); \
- 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_II_I(e) \
-{ \
- StgInt x = PopTaggedInt(); \
- StgInt y = PopTaggedInt(); \
- PushTaggedInt(e); \
-}
-#define OP_II_B(e) \
-{ \
- StgInt x = PopTaggedInt(); \
- StgInt y = PopTaggedInt(); \
- PushTaggedBool(e); \
-}
+ HugsBlock hugsBlock = { NotBlocked, 0 };
-#define OP__A(e) \
-{ \
- PushTaggedAddr(e); \
-}
-#define OP_I_A(e) \
-{ \
- StgInt x = PopTaggedInt(); \
- PushTaggedAddr(e); \
-}
+#ifdef DEBUG
+ StgPtr tSp; StgUpdateFrame* tSu; StgPtr tSpLim;
+#endif
-#define OP_I_I(e) \
-{ \
- StgInt x = PopTaggedInt(); \
- PushTaggedInt(e); \
-}
+ gSp = cap->rCurrentTSO->sp;
+ gSu = cap->rCurrentTSO->su;
+ gSpLim = cap->rCurrentTSO->splim;
-#define OP__C(e) \
-{ \
- PushTaggedChar(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_I_C(e) \
-{ \
- StgInt x = PopTaggedInt(); \
- PushTaggedChar(e); \
-}
+ obj = obj0;
+ eCount = 0;
-#define OP__W(e) \
-{ \
- PushTaggedWord(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_W(e) \
-{ \
- StgInt x = PopTaggedInt(); \
- PushTaggedWord(e); \
-}
+ enterLoop:
-#define OP__F(e) \
-{ \
- PushTaggedFloat(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
+
+ if (
+#ifdef DEBUG
+ ((++eCount) & 0x0F) == 0
+#else
+ ++eCount == 0
+#endif
+ ) {
+ if (context_switch) {
+ switch(hugsBlock.reason) {
+ case NotBlocked: {
+ xPushCPtr(obj); /* code to restart with */
+ RETURN(ThreadYielding);
+ }
+ case BlockedOnDelay: /* fall through */
+ case BlockedOnRead: /* fall through */
+ case BlockedOnWrite: {
+ ASSERT(cap->rCurrentTSO->why_blocked == NotBlocked);
+ cap->rCurrentTSO->why_blocked = BlockedOnDelay;
+ ACQUIRE_LOCK(&sched_mutex);
+
+#if defined(HAVE_SETITIMER)
+ cap->rCurrentTSO->block_info.delay
+ = hugsBlock.delay + ticks_since_select;
+#else
+ cap->rCurrentTSO->block_info.target
+ = hugsBlock.delay + getourtimeofday();
+#endif
+ APPEND_TO_BLOCKED_QUEUE(cap->rCurrentTSO);
+
+ RELEASE_LOCK(&sched_mutex);
+
+ xPushCPtr(obj); /* code to restart with */
+ RETURN(ThreadBlocked);
+ }
+ default:
+ barf("Unknown context switch reasoning");
+ }
+ }
+ }
-#define OP_I_F(e) \
-{ \
- StgInt x = PopTaggedInt(); \
- PushTaggedFloat(e); \
-}
+ switch ( get_itbl(obj)->type ) {
+ case INVALID_OBJECT:
+ barf("Invalid object %p",obj);
-#define OP__D(e) \
-{ \
- PushTaggedDouble(e); \
-}
+ case BCO: bco_entry:
-#define OP_I_D(e) \
-{ \
- StgInt x = PopTaggedInt(); \
- PushTaggedDouble(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);
+ }
-#ifdef PROVIDE_WORD
-#define OP_WW_B(e) \
-{ \
- StgWord x = PopTaggedWord(); \
+# 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_ALLOC_CONSTR_big):
+ {
+ StgPtr p;
+ int x = BCO_INSTR_16;
+ StgInfoTable* info = bcoConstAddr(bco,x);
+ SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
+ SET_HDR((StgClosure*)p,info,??);
+ xPushPtr(p);
+ Continue;
+ }
+ Case(i_MKAP):
+ {
+ int x = BCO_INSTR_8; /* ToDo: Word not Int! */
+ int y = BCO_INSTR_8;
+ StgAP_UPD* o = stgCast(StgAP_UPD*,xStackPtr(x));
+ SET_HDR(o,&AP_UPD_info,??);
+ o->n_args = y;
+ o->fun = stgCast(StgClosure*,xPopPtr());
+ for(x=0; x < y; ++x) {
+ payloadWord(o,x) = xPopWord();
+ }
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ SSS;
+ printObj(stgCast(StgClosure*,o));
+ LLL;
+ );
+ Continue;
+ }
+ Case(i_MKAP_big):
+ {
+ int x, y;
+ StgAP_UPD* o;
+ x = BCO_INSTR_16;
+ y = BCO_INSTR_16;
+ o = stgCast(StgAP_UPD*,xStackPtr(x));
+ SET_HDR(o,&AP_UPD_info,??);
+ o->n_args = y;
+ o->fun = stgCast(StgClosure*,xPopPtr());
+ for(x=0; x < y; ++x) {
+ payloadWord(o,x) = xPopWord();
+ }
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ SSS;
+ printObj(stgCast(StgClosure*,o));
+ LLL;
+ );
+ Continue;
+ }
+ Case(i_MKPAP):
+ {
+ int x = BCO_INSTR_8;
+ int y = BCO_INSTR_8;
+ StgPAP* o = stgCast(StgPAP*,xStackPtr(x));
+ SET_HDR(o,&PAP_info,??);
+ o->n_args = y;
+ o->fun = stgCast(StgClosure*,xPopPtr());
+ for(x=0; x < y; ++x) {
+ payloadWord(o,x) = xPopWord();
+ }
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ SSS;
+ printObj(stgCast(StgClosure*,o));
+ LLL;
+ );
+ Continue;
+ }
+ Case(i_PACK):
+ {
+ int offset = BCO_INSTR_8;
+ StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
+ const StgInfoTable* info = get_itbl(o);
+ nat p = info->layout.payload.ptrs;
+ nat np = info->layout.payload.nptrs;
+ nat i;
+ for(i=0; i < p; ++i) {
+ o->payload[i] = xPopCPtr();
+ }
+ for(i=0; i < np; ++i) {
+ payloadWord(o,p+i) = 0xdeadbeef;
+ }
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ SSS;
+ printObj(stgCast(StgClosure*,o));
+ LLL;
+ );
+ Continue;
+ }
+ Case(i_PACK_big):
+ {
+ int offset = BCO_INSTR_16;
+ StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
+ const StgInfoTable* info = get_itbl(o);
+ nat p = info->layout.payload.ptrs;
+ nat np = info->layout.payload.nptrs;
+ nat i;
+ for(i=0; i < p; ++i) {
+ o->payload[i] = xPopCPtr();
+ }
+ for(i=0; i < np; ++i) {
+ payloadWord(o,p+i) = 0xdeadbeef;
+ }
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ SSS;
+ printObj(stgCast(StgClosure*,o));
+ LLL;
+ );
+ Continue;
+ }
+ Case(i_SLIDE):
+ {
+ int x = BCO_INSTR_8;
+ int y = BCO_INSTR_8;
+ ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
+ /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
+ while(--x >= 0) {
+ xSetStackWord(x+y,xStackWord(x));
+ }
+ xSp += y;
+ Continue;
+ }
+ Case(i_SLIDE_big):
+ {
+ int x, y;
+ x = BCO_INSTR_16;
+ y = BCO_INSTR_16;
+ ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
+ /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
+ while(--x >= 0) {
+ xSetStackWord(x+y,xStackWord(x));
+ }
+ xSp += y;
+ Continue;
+ }
+ Case(i_ENTER):
+ {
+ obj = xPopCPtr();
+ goto enterLoop;
+ }
+ Case(i_RETADDR):
+ {
+ xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
+ xPushPtr(stgCast(StgPtr,&ret_bco_info));
+ Continue;
+ }
+ Case(i_TEST):
+ {
+ int tag = BCO_INSTR_8;
+ StgWord offset = BCO_INSTR_16;
+ if (constrTag( (StgClosure*)xStackPtr(0) ) != tag) {
+ bciPtr += offset;
+ }
+ Continue;
+ }
+ Case(i_UNPACK):
+ {
+ StgClosure* o = stgCast(StgClosure*,xStackPtr(0));
+ const StgInfoTable* itbl = get_itbl(o);
+ int i = itbl->layout.payload.ptrs;
+ ASSERT( itbl->type == CONSTR
+ || itbl->type == CONSTR_STATIC
+ || itbl->type == CONSTR_NOCAF_STATIC
+ || itbl->type == CONSTR_1_0
+ || itbl->type == CONSTR_0_1
+ || itbl->type == CONSTR_2_0
+ || itbl->type == CONSTR_1_1
+ || itbl->type == CONSTR_0_2
+ );
+ while (--i>=0) {
+ xPushCPtr(o->payload[i]);
+ }
+ Continue;
+ }
+ Case(i_VAR_big):
+ {
+ int n = BCO_INSTR_16;
+ StgPtr p = xStackPtr(n);
+ xPushPtr(p);
+ Continue;
+ }
+ Case(i_VAR):
+ {
+ StgPtr p = xStackPtr(BCO_INSTR_8);
+ xPushPtr(p);
+ Continue;
+ }
+ Case(i_CONST):
+ {
+ xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,BCO_INSTR_8)));
+ Continue;
+ }
+ Case(i_CONST_big):
+ {
+ int n = BCO_INSTR_16;
+ xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,n)));
+ Continue;
+ }
+ Case(i_VOID):
+ {
+ SSS; PushTaggedRealWorld(); LLL;
+ Continue;
+ }
+ Case(i_VAR_INT):
+ {
+ StgInt i = xTaggedStackInt(BCO_INSTR_8);
+ xPushTaggedInt(i);
+ Continue;
+ }
+ Case(i_CONST_INT):
+ {
+ xPushTaggedInt(bcoConstInt(bco,BCO_INSTR_8));
+ Continue;
+ }
+ Case(i_CONST_INT_big):
+ {
+ int n = BCO_INSTR_16;
+ xPushTaggedInt(bcoConstInt(bco,n));
+ Continue;
+ }
+ Case(i_PACK_INT):
+ {
+ StgClosure* o;
+ SSS; o = (StgClosure*)grabHpNonUpd(Izh_sizeW); LLL;
+ SET_HDR(o,Izh_con_info,??);
+ payloadWord(o,0) = xPopTaggedInt();
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ SSS;
+ printObj(stgCast(StgClosure*,o));
+ LLL;
+ );
+ xPushPtr(stgCast(StgPtr,o));
+ Continue;
+ }
+ Case(i_UNPACK_INT):
+ {
+ StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
+ /* ASSERT(isIntLike(con)); */
+ xPushTaggedInt(payloadWord(con,0));
+ Continue;
+ }
+ Case(i_TEST_INT):
+ {
+ StgWord offset = BCO_INSTR_16;
+ StgInt x = xPopTaggedInt();
+ StgInt y = xPopTaggedInt();
+ if (x != y) {
+ bciPtr += offset;
+ }
+ Continue;
+ }
+ Case(i_CONST_INTEGER):
+ {
+ StgPtr p;
+ int n;
+ char* s = bcoConstAddr(bco,BCO_INSTR_8);
+ SSS;
+ n = size_fromStr(s);
+ p = CreateByteArrayToHoldInteger(n);
+ do_fromStr ( s, n, IntegerInsideByteArray(p));
+ SloppifyIntegerEnd(p);
+ LLL;
+ xPushPtr(p);
+ Continue;
+ }
+ Case(i_VAR_WORD):
+ {
+ StgWord w = xTaggedStackWord(BCO_INSTR_8);
+ xPushTaggedWord(w);
+ Continue;
+ }
+ Case(i_CONST_WORD):
+ {
+ xPushTaggedWord(bcoConstWord(bco,BCO_INSTR_8));
+ Continue;
+ }
+ Case(i_PACK_WORD):
+ {
+ StgClosure* o;
+ SSS; o = (StgClosure*)grabHpNonUpd(Wzh_sizeW); LLL;
+ SET_HDR(o,Wzh_con_info,??);
+ payloadWord(o,0) = xPopTaggedWord();
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ SSS;
+ printObj(stgCast(StgClosure*,o));
+ LLL;
+ );
+ xPushPtr(stgCast(StgPtr,o));
+ Continue;
+ }
+ Case(i_UNPACK_WORD):
+ {
+ StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
+ /* ASSERT(isWordLike(con)); */
+ xPushTaggedWord(payloadWord(con,0));
+ Continue;
+ }
+ Case(i_VAR_ADDR):
+ {
+ StgAddr a = xTaggedStackAddr(BCO_INSTR_8);
+ xPushTaggedAddr(a);
+ Continue;
+ }
+ Case(i_CONST_ADDR):
+ {
+ xPushTaggedAddr(bcoConstAddr(bco,BCO_INSTR_8));
+ Continue;
+ }
+ Case(i_CONST_ADDR_big):
+ {
+ int n = BCO_INSTR_16;
+ xPushTaggedAddr(bcoConstAddr(bco,n));
+ Continue;
+ }
+ Case(i_PACK_ADDR):
+ {
+ StgClosure* o;
+ SSS; o = (StgClosure*)grabHpNonUpd(Azh_sizeW); LLL;
+ SET_HDR(o,Azh_con_info,??);
+ payloadPtr(o,0) = xPopTaggedAddr();
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ SSS;
+ printObj(stgCast(StgClosure*,o));
+ LLL;
+ );
+ xPushPtr(stgCast(StgPtr,o));
+ Continue;
+ }
+ Case(i_UNPACK_ADDR):
+ {
+ StgClosure* con = (StgClosure*)xStackPtr(0);
+ /* ASSERT(isAddrLike(con)); */
+ xPushTaggedAddr(payloadPtr(con,0));
+ Continue;
+ }
+ Case(i_VAR_CHAR):
+ {
+ StgChar c = xTaggedStackChar(BCO_INSTR_8);
+ xPushTaggedChar(c);
+ Continue;
+ }
+ Case(i_CONST_CHAR):
+ {
+ xPushTaggedChar(bcoConstChar(bco,BCO_INSTR_8));
+ Continue;
+ }
+ Case(i_PACK_CHAR):
+ {
+ StgClosure* o;
+ SSS; o = (StgClosure*)grabHpNonUpd(Czh_sizeW); LLL;
+ SET_HDR(o,Czh_con_info,??);
+ payloadWord(o,0) = xPopTaggedChar();
+ xPushPtr(stgCast(StgPtr,o));
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ SSS;
+ printObj(stgCast(StgClosure*,o));
+ LLL;
+ );
+ Continue;
+ }
+ Case(i_UNPACK_CHAR):
+ {
+ StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
+ /* ASSERT(isCharLike(con)); */
+ xPushTaggedChar(payloadWord(con,0));
+ Continue;
+ }
+ Case(i_VAR_FLOAT):
+ {
+ StgFloat f = xTaggedStackFloat(BCO_INSTR_8);
+ xPushTaggedFloat(f);
+ Continue;
+ }
+ Case(i_CONST_FLOAT):
+ {
+ xPushTaggedFloat(bcoConstFloat(bco,BCO_INSTR_8));
+ Continue;
+ }
+ Case(i_PACK_FLOAT):
+ {
+ StgClosure* o;
+ SSS; o = (StgClosure*)grabHpNonUpd(Fzh_sizeW); LLL;
+ SET_HDR(o,Fzh_con_info,??);
+ ASSIGN_FLT(&payloadWord(o,0),xPopTaggedFloat());
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ SSS;
+ printObj(stgCast(StgClosure*,o));
+ LLL;
+ );
+ xPushPtr(stgCast(StgPtr,o));
+ Continue;
+ }
+ Case(i_UNPACK_FLOAT):
+ {
+ StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
+ /* ASSERT(isFloatLike(con)); */
+ xPushTaggedFloat(PK_FLT(&payloadWord(con,0)));
+ Continue;
+ }
+ Case(i_VAR_DOUBLE):
+ {
+ StgDouble d = xTaggedStackDouble(BCO_INSTR_8);
+ xPushTaggedDouble(d);
+ Continue;
+ }
+ Case(i_CONST_DOUBLE):
+ {
+ xPushTaggedDouble(bcoConstDouble(bco,BCO_INSTR_8));
+ Continue;
+ }
+ Case(i_CONST_DOUBLE_big):
+ {
+ int n = BCO_INSTR_16;
+ xPushTaggedDouble(bcoConstDouble(bco,n));
+ Continue;
+ }
+ Case(i_PACK_DOUBLE):
+ {
+ StgClosure* o;
+ SSS; o = (StgClosure*)grabHpNonUpd(Dzh_sizeW); LLL;
+ SET_HDR(o,Dzh_con_info,??);
+ ASSIGN_DBL(&payloadWord(o,0),xPopTaggedDouble());
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ printObj(stgCast(StgClosure*,o));
+ );
+ xPushPtr(stgCast(StgPtr,o));
+ Continue;
+ }
+ Case(i_UNPACK_DOUBLE):
+ {
+ StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
+ /* ASSERT(isDoubleLike(con)); */
+ xPushTaggedDouble(PK_DBL(&payloadWord(con,0)));
+ Continue;
+ }
+ Case(i_VAR_STABLE):
+ {
+ StgStablePtr s = xTaggedStackStable(BCO_INSTR_8);
+ xPushTaggedStable(s);
+ Continue;
+ }
+ Case(i_PACK_STABLE):
+ {
+ StgClosure* o;
+ SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL;
+ SET_HDR(o,StablePtr_con_info,??);
+ payloadWord(o,0) = xPopTaggedStable();
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ SSS;
+ printObj(stgCast(StgClosure*,o));
+ LLL;
+ );
+ xPushPtr(stgCast(StgPtr,o));
+ Continue;
+ }
+ Case(i_UNPACK_STABLE):
+ {
+ StgClosure* con = (StgClosure*)xStackPtr(0);
+ /* ASSERT(isStableLike(con)); */
+ xPushTaggedStable(payloadWord(con,0));
+ Continue;
+ }
+ Case(i_PRIMOP1):
+ {
+ int i;
+ void* p;
+ i = BCO_INSTR_8;
+ SSS; p = enterBCO_primop1 ( i ); LLL;
+ if (p) { obj = p; goto enterLoop; };
+ Continue;
+ }
+ Case(i_PRIMOP2):
+ {
+ int i, trc, pc_saved;
+ void* p;
+ StgBCO* bco_tmp;
+ trc = 12345678; /* Assume != any StgThreadReturnCode */
+ i = BCO_INSTR_8;
+ pc_saved = PC;
+ bco_tmp = bco;
+ SSS;
+ p = enterBCO_primop2 ( i, &trc, &bco_tmp, cap,
+ &hugsBlock );
+ LLL;
+ bco = bco_tmp;
+ bciPtr = &(bcoInstr(bco,pc_saved));
+ if (p) {
+ if (trc == 12345678) {
+ /* we want to enter p */
+ obj = p; goto enterLoop;
+ } else {
+ /* trc is the the StgThreadReturnCode for
+ * this thread */
+ RETURN((StgThreadReturnCode)trc);
+ };
+ }
+ Continue;
+ }
+
+ /* combined insns, created by peephole opt */
+ Case(i_SE):
+ {
+ int x = BCO_INSTR_8;
+ int y = BCO_INSTR_8;
+ ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
+ /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
+ if (x == 1) {
+ obj = xPopCPtr();
+ xSp += y;
+ goto enterLoop;
+ } else {
+ while(--x >= 0) {
+ xSetStackWord(x+y,xStackWord(x));
+ }
+ xSp += y;
+ obj = xPopCPtr();
+ }
+ goto enterLoop;
+ }
+ Case(i_VV):
+ {
+ StgPtr p;
+ p = xStackPtr(BCO_INSTR_8);
+ xPushPtr(p);
+ p = xStackPtr(BCO_INSTR_8);
+ xPushPtr(p);
+ Continue;
+ }
+ Case(i_RV):
+ {
+ StgPtr p;
+ xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
+ xPushPtr(stgCast(StgPtr,&ret_bco_info));
+ p = xStackPtr(BCO_INSTR_8);
+ xPushPtr(p);
+ Continue;
+ }
+ Case(i_RVE):
+ {
+ StgPtr retaddr = bcoConstPtr(bco,BCO_INSTR_8);
+ StgPtr ptr = xStackPtr(BCO_INSTR_8);
+
+ /* A shortcut. We're going to push the address of a
+ return continuation, and then enter a variable, so
+ that when the var is evaluated, we return to the
+ continuation. The shortcut is: if the var is a
+ constructor, don't bother to enter it. Instead,
+ push the variable on the stack (since this is what
+ the continuation expects) and jump directly to the
+ continuation.
+ */
+ if (get_itbl((StgClosure*)ptr)->type == CONSTR) {
+ xPushPtr(ptr);
+ obj = (StgClosure*)retaddr;
+ IF_DEBUG(evaluator,
+ fprintf(stderr, "object to enter is a constructor -- "
+ "jumping directly to return continuation\n" );
+ );
+ goto bco_entry;
+ }
+
+ /* This is the normal, non-short-cut route */
+ xPushPtr(retaddr);
+ xPushPtr(stgCast(StgPtr,&ret_bco_info));
+ obj = (StgClosure*)ptr;
+ goto enterLoop;
+ }
+
+
+ Case(i_VAR_DOUBLE_big):
+ Case(i_CONST_FLOAT_big):
+ Case(i_VAR_FLOAT_big):
+ Case(i_CONST_CHAR_big):
+ Case(i_VAR_CHAR_big):
+ Case(i_VAR_ADDR_big):
+ Case(i_VAR_STABLE_big):
+ Case(i_CONST_INTEGER_big):
+ Case(i_VAR_INT_big):
+ Case(i_VAR_WORD_big):
+ Case(i_RETADDR_big):
+ Case(i_ALLOC_PAP):
+ bciPtr--;
+ printf ( "\n\n" );
+ disInstr ( bco, PC );
+ barf("\nUnrecognised instruction");
+
+ EndDispatch
+
+ barf("enterBCO: ran off end of loop");
+ break;
+ }
+
+# undef LoopTopLabel
+# undef Case
+# undef Continue
+# undef Dispatch
+# undef EndDispatch
+
+ /* ---------------------------------------------------- */
+ /* End of the bytecode evaluator */
+ /* ---------------------------------------------------- */
+
+ case CAF_UNENTERED:
+ {
+ StgBlockingQueue* bh;
+ StgCAF* caf = (StgCAF*)obj;
+ if (xSp - sizeofW(StgUpdateFrame) < xSpLim) {
+ xPushCPtr(obj); /* code to restart with */
+ RETURN(StackOverflow);
+ }
+ /* 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:
+ {
+ /* Let the scheduler figure out what to do :-) */
+ cap->rCurrentTSO->what_next = ThreadEnterGHC;
+ xPushCPtr(obj);
+ RETURN(ThreadYielding);
+ }
+ case AP_UPD:
+ {
+ StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
+ int i = ap->n_args;
+ if (xSp - (i + sizeofW(StgUpdateFrame)) < xSpLim) {
+ xPushCPtr(obj); /* code to restart with */
+ RETURN(StackOverflow);
+ }
+ /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
+ and insert an indirection immediately */
+ xPushUpdateFrame(ap,0);
+ xSp -= sizeofW(StgUpdateFrame);
+ while (--i >= 0) {
+ xPushWord(payloadWord(ap,i));
+ }
+ obj = ap->fun;
+#ifdef EAGER_BLACKHOLING
+#warn LAZY_BLACKHOLING is default for StgHugs
+#error Dont know if EAGER_BLACKHOLING works in StgHugs
+ {
+ /* superfluous - but makes debugging easier */
+ StgBlackHole* bh = stgCast(StgBlackHole*,ap);
+ SET_INFO(bh,&BLACKHOLE_info);
+ bh->blocking_queue = EndTSOQueue;
+ IF_DEBUG(gccafs,
+ fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
+ /* printObj(bh); */
+ }
+#endif /* EAGER_BLACKHOLING */
+ goto enterLoop;
+ }
+ case PAP:
+ {
+ StgPAP* pap = stgCast(StgPAP*,obj);
+ int i = pap->n_args; /* ToDo: stack check */
+ /* ToDo: if PAP is in whnf, we can update any update frames
+ * on top of stack.
+ */
+ while (--i >= 0) {
+ xPushWord(payloadWord(pap,i));
+ }
+ obj = pap->fun;
+ goto enterLoop;
+ }
+ case IND:
+ {
+ obj = stgCast(StgInd*,obj)->indirectee;
+ goto enterLoop;
+ }
+ case IND_OLDGEN:
+ {
+ obj = stgCast(StgIndOldGen*,obj)->indirectee;
+ goto enterLoop;
+ }
+ case CONSTR:
+ case CONSTR_1_0:
+ case CONSTR_0_1:
+ case CONSTR_2_0:
+ case CONSTR_1_1:
+ case CONSTR_0_2:
+ case CONSTR_INTLIKE:
+ case CONSTR_CHARLIKE:
+ case CONSTR_STATIC:
+ case CONSTR_NOCAF_STATIC:
+ {
+ 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:
+ cap->rCurrentTSO->what_next = ThreadEnterGHC;
+ xPushCPtr(obj);
+ RETURN(ThreadYielding);
+ default:
+ belch("entered CONSTR with invalid continuation on stack");
+ IF_DEBUG(evaluator,
+ SSS;
+ printObj(stgCast(StgClosure*,xSp));
+ LLL;
+ );
+ barf("bailing out");
+ }
+ }
+ }
+ default:
+ {
+ //SSS;
+ //fprintf(stderr, "enterCountI = %d\n", enterCountI);
+ //fprintf(stderr, "entering unknown closure -- yielding to sched\n");
+ //printObj(obj);
+ //LLL;
+ cap->rCurrentTSO->what_next = ThreadEnterGHC;
+ xPushCPtr(obj); /* code to restart with */
+ RETURN(ThreadYielding);
+ }
+ }
+ barf("Ran off the end of enter - yoiks");
+ assert(0);
+}
+
+#undef RETURN
+#undef BCO_INSTR_8
+#undef BCO_INSTR_16
+#undef SSS
+#undef LLL
+#undef PC
+#undef xPushPtr
+#undef xPopPtr
+#undef xPushCPtr
+#undef xPopCPtr
+#undef xPopWord
+#undef xStackPtr
+#undef xStackWord
+#undef xSetStackWord
+#undef xPushTag
+#undef xPopTag
+#undef xPushTaggedInt
+#undef xPopTaggedInt
+#undef xTaggedStackInt
+#undef xPushTaggedWord
+#undef xPopTaggedWord
+#undef xTaggedStackWord
+#undef xPushTaggedAddr
+#undef xTaggedStackAddr
+#undef xPopTaggedAddr
+#undef xPushTaggedStable
+#undef xTaggedStackStable
+#undef xPopTaggedStable
+#undef xPushTaggedChar
+#undef xTaggedStackChar
+#undef xPopTaggedChar
+#undef xPushTaggedFloat
+#undef xTaggedStackFloat
+#undef xPopTaggedFloat
+#undef xPushTaggedDouble
+#undef xTaggedStackDouble
+#undef xPopTaggedDouble
+#undef xPopUpdateFrame
+#undef xPushUpdateFrame
+
+
+/* --------------------------------------------------------------------------
+ * Supporting routines for primops
+ * ------------------------------------------------------------------------*/
+
+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* exception )
+{
+ /* This closure represents the expression 'primRaise E' where E
+ * is the exception raised (:: Exception).
+ * It is used to overwrite all the
+ * thunks which are currently under evaluation.
+ */
+ HaskellObj primRaiseClosure
+ = asmClosureOfObject(getHugs_AsmObject_for("primRaise"));
+ HaskellObj reraiseClosure
+ = rts_apply ( primRaiseClosure, exception );
+
+ while (1) {
+ switch (get_itbl(gSu)->type) {
+ case UPDATE_FRAME:
+ UPD_IND(gSu->updatee,reraiseClosure);
+ gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
+ gSu = gSu->link;
+ break;
+ case SEQ_FRAME:
+ PopSeqFrame();
+ break;
+ case CATCH_FRAME: /* found it! */
+ {
+ StgCatchFrame* fp = stgCast(StgCatchFrame*,gSu);
+ StgClosure *handler = fp->handler;
+ gSu = fp->link;
+ gSp += sizeofW(StgCatchFrame); /* Pop */
+ PushCPtr(exception);
+ return handler;
+ }
+ case STOP_FRAME:
+ barf("raiseError: uncaught exception: STOP_FRAME");
+ default:
+ barf("raiseError: weird activation record");
+ }
+ }
+}
+
+
+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("hugsprimUnpackString"));
+ HaskellObj thunk
+ = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) );
+ thunk
+ = rts_apply ( error, thunk );
+ return
+ (StgClosure*) thunk;
+}
+
+#define raiseIndex(where) makeErrorCall("Array index out of range in " where)
+#define raiseDiv0(where) makeErrorCall("Division by zero in " where)
+
+/* --------------------------------------------------------------------------
+ * Evaluator
+ * ------------------------------------------------------------------------*/
+
+#define OP_CC_B(e) \
+{ \
+ unsigned char x = PopTaggedChar(); \
+ unsigned char y = PopTaggedChar(); \
+ PushTaggedBool(e); \
+}
+
+#define OP_C_I(e) \
+{ \
+ unsigned char x = PopTaggedChar(); \
+ PushTaggedInt(e); \
+}
+
+#define OP__I(e) \
+{ \
+ PushTaggedInt(e); \
+}
+
+#define OP_IW_I(e) \
+{ \
+ StgInt x = PopTaggedInt(); \
+ StgWord y = PopTaggedWord(); \
+ PushTaggedInt(e); \
+}
+
+#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); \
}
PushTaggedInt(e); \
}
+#define OP_s_I(e) \
+{ \
+ StgStablePtr x = PopTaggedStablePtr(); \
+ PushTaggedInt(e); \
+}
+
#define OP_W_W(e) \
{ \
StgWord x = PopTaggedWord(); \
PushTaggedWord(e); \
}
-#endif
-#ifdef PROVIDE_ADDR
#define OP_AA_B(e) \
{ \
StgAddr x = PopTaggedAddr(); \
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(); \
int y = PopTaggedInt(); \
StgStablePtr r; \
s; \
- PushTaggedStablePtr(r); \
+ PushTaggedStablePtr(r); \
}
#define OP_AIC_(s) \
{ \
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(); \
s; \
}
-#endif /* PROVIDE_ADDR */
#define OP_FF_B(e) \
{ \
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); \
-}
+
+StgPtr CreateByteArrayToHoldInteger ( int nbytes )
+{
+ StgWord words = (nbytes+sizeof(W_)-1)/sizeof(W_);
+ StgWord size = sizeofW(StgArrWords) + words;
+ StgArrWords* arr = (StgArrWords*)allocate(size);
+ SET_HDR(arr,&ARR_WORDS_info,CCCS);
+ arr->words = words;
+ ASSERT((W_)nbytes <= arr->words * sizeof(W_));
+#ifdef DEBUG
+ {StgWord i;
+ for (i = 0; i < words; ++i) {
+ arr->payload[i] = 0xdeadbeef;
+ }}
+ { B* b = (B*) &(arr->payload[0]);
+ b->used = b->sign = 0;
+ }
#endif
-#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); \
+ return (StgPtr)arr;
}
-#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); \
+B* IntegerInsideByteArray ( StgPtr arr0 )
+{
+ B* b;
+ StgArrWords* arr = (StgArrWords*)arr0;
+ ASSERT(GET_INFO(arr) == &ARR_WORDS_info);
+ b = (B*) &(arr->payload[0]);
+ return b;
}
-#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); \
+
+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
-#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; \
+ return (raiseIndex(where)); \
}
#define OP_mI_ty(ty,where,s) \
{ \
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 */
-
-
-/* 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;
-enterLoop:
- /* ASSERT(StorageMgrInfo.hp_start <= Hp && Hp < HpLim && HpLim == StorageMgrInfo.hplim); */
- ASSERT(SpLim <= Sp && Sp <= stgCast(StgPtr,Su));
-#if 0
- IF_DEBUG(evaluator,
- fprintf(stderr,"Sp = %p\tSu = %p\n", Sp, Su);
- 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()
- );
-#endif
- if (++enterCount == 0 && context_switch) {
- PushCPtr(obj); /* code to restart with */
- 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 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,
- 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);
-#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++);
- 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();
- break;
- case UPDATE_FRAME:
- PopUpdateFrame(obj);
- break;
- case STOP_FRAME:
- PopStopFrame(obj);
- return ThreadFinished;
- case SEQ_FRAME:
- PopSeqFrame();
- 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_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_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 = bcoInstr(bco,pc++);
- 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:
- {
- PushPtr(stackPtr(bcoInstr(bco,pc++)));
- break;
- }
- case i_CONST:
- {
- PushPtr(stgCast(StgPtr,bcoConstPtr(bco,bcoInstr(bco,pc++))));
- break;
- }
- case i_CONST2:
- {
- StgWord o1 = bcoInstr(bco,pc++);
- StgWord o2 = bcoInstr(bco,pc++);
- StgWord o = o1*256 + o2;
- PushPtr(stgCast(StgPtr,bcoConstPtr(bco,o)));
- 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 = bcoInstr(bco,pc++);
- StgInt x = PopTaggedInt();
- StgInt y = PopTaggedInt();
- 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
+}
+#define OP_mIty_(ty,where,s) \
+{ \
+ HEADER_mI(mycat2(Stg,ty),where) \
+ { \
+ mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
+ s; \
+ } \
+}
-#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_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(x<y); break;
- case i_leChar: OP_CC_B(x<=y); break;
- case i_charToInt: OP_C_I(x); break;
- case i_intToChar: OP_I_C(x); break;
-
- case i_gtInt: OP_II_B(x>y); 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;
- case i_leInt: OP_II_B(x<=y); break;
- case i_minInt: OP__I(INT_MIN); break;
- case i_maxInt: OP__I(INT_MAX); break;
- case i_plusInt: OP_II_I(x+y); break;
- case i_minusInt: OP_II_I(x-y); break;
- case i_timesInt: OP_II_I(x*y); break;
- case i_quotInt:
- {
- int x = PopTaggedInt();
- int y = PopTaggedInt();
- if (y == 0) {
- obj = raiseDiv0("quotInt");
- goto enterLoop;
- }
- /* ToDo: protect against minInt / -1 errors
- * (repeat for all other division primops)
- */
- PushTaggedInt(x/y);
- }
- break;
- case i_remInt:
- {
- int x = PopTaggedInt();
- int y = PopTaggedInt();
- if (y == 0) {
- obj = raiseDiv0("remInt");
- goto enterLoop;
- }
- PushTaggedInt(x%y);
- }
- break;
- case i_quotRemInt:
- {
- StgInt x = PopTaggedInt();
- StgInt y = PopTaggedInt();
- if (y == 0) {
- obj = raiseDiv0("quotRemInt");
- goto enterLoop;
- }
- PushTaggedInt(x%y); /* last result */
- PushTaggedInt(x/y); /* first result */
- }
- break;
- case i_negateInt: OP_I_I(-x); break;
-
- case i_andInt: OP_II_I(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 */
-
-#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;
- case i_leInt64: OP_zz_B(x<=y); break;
- case i_minInt64: OP__z(0x800000000000LL); break;
- case i_maxInt64: OP__z(0x7fffffffffffLL); break;
- case i_plusInt64: OP_zz_z(x+y); break;
- case i_minusInt64: OP_zz_z(x-y); break;
- case i_timesInt64: OP_zz_z(x*y); break;
- case i_quotInt64:
- {
- StgInt64 x = PopTaggedInt64();
- StgInt64 y = PopTaggedInt64();
- if (y == 0) {
- obj = raiseDiv0("quotInt64");
- goto enterLoop;
- }
- /* ToDo: protect against minInt64 / -1 errors
- * (repeat for all other division primops)
- */
- PushTaggedInt64(x/y);
- }
- break;
- case i_remInt64:
- {
- StgInt64 x = PopTaggedInt64();
- StgInt64 y = PopTaggedInt64();
- if (y == 0) {
- obj = raiseDiv0("remInt64");
- goto enterLoop;
- }
- PushTaggedInt64(x%y);
- }
- break;
- case i_quotRemInt64:
- {
- StgInt64 x = PopTaggedInt64();
- StgInt64 y = PopTaggedInt64();
- if (y == 0) {
- obj = raiseDiv0("quotRemInt64");
- goto enterLoop;
- }
- PushTaggedInt64(x%y); /* last result */
- PushTaggedInt64(x/y); /* first result */
- }
- break;
- case i_negateInt64: OP_z_z(-x); break;
-
- case i_andInt64: OP_zz_z(x&y); break;
- case i_orInt64: OP_zz_z(x|y); break;
- case i_xorInt64: OP_zz_z(x^y); break;
- case i_notInt64: OP_z_z(~x); break;
- case i_shiftLInt64: OP_zW_z(x<<y); break;
- case i_shiftRAInt64: OP_zW_z(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;
-#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;
- case i_leWord: OP_WW_B(x<=y); break;
- case i_minWord: OP__W(0); break;
- case i_maxWord: OP__W(UINT_MAX); break;
- case i_plusWord: OP_WW_W(x+y); break;
- case i_minusWord: OP_WW_W(x-y); break;
- case i_timesWord: OP_WW_W(x*y); break;
- case i_quotWord:
- {
- StgWord x = PopTaggedWord();
- StgWord y = PopTaggedWord();
- if (y == 0) {
- obj = raiseDiv0("quotWord");
- goto enterLoop;
- }
- PushTaggedWord(x/y);
- }
- break;
- case i_remWord:
- {
- StgWord x = PopTaggedWord();
- StgWord y = PopTaggedWord();
- if (y == 0) {
- obj = raiseDiv0("remWord");
- goto enterLoop;
- }
- PushTaggedWord(x%y);
- }
- break;
- case i_quotRemWord:
- {
- StgWord x = PopTaggedWord();
- StgWord y = PopTaggedWord();
- if (y == 0) {
- obj = raiseDiv0("quotRemWord");
- goto enterLoop;
- }
- PushTaggedWord(x%y); /* last result */
- PushTaggedWord(x/y); /* first result */
- }
- break;
- case i_negateWord: OP_W_W(-x); break;
- case i_andWord: OP_WW_W(x&y); break;
- case i_orWord: OP_WW_W(x|y); break;
- case i_xorWord: OP_WW_W(x^y); break;
- case i_notWord: OP_W_W(~x); break;
- case i_shiftLWord: OP_WW_W(x<<y); break;
- case i_shiftRAWord: OP_WW_W(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;
-#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<y); break;
- case i_leAddr: OP_AA_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;
+static 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 (!( (P_)gSu >= (P_)cap->rCurrentTSO->stack
+ &&
+ (P_)gSu <= (P_)(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 = (StgUpdateFrame*) ((StgCatchFrame*)(gSu))->link;
+ break;
+ case UPDATE_FRAME:
+ gSu = (StgUpdateFrame*) ((StgUpdateFrame*)(gSu))->link;
+ break;
+ case SEQ_FRAME:
+ gSu = (StgUpdateFrame*) ((StgSeqFrame*)(gSu))->link;
+ break;
+ case STOP_FRAME:
+ goto postloop;
+ default:
+ fprintf(stderr, "myStackCheck: invalid activation record\n"); 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 )
+{
+ if (combined)
+ barf("enterBCO_primop1 in combined mode");
+
+ 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(x<y); break;
+ case i_leChar: OP_CC_B(x<=y); break;
+ case i_charToInt: OP_C_I(x); break;
+ case i_intToChar: OP_I_C(x); break;
+
+ case i_gtInt: OP_II_B(x>y); 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;
+ case i_leInt: OP_II_B(x<=y); break;
+ case i_minInt: OP__I(INT_MIN); break;
+ case i_maxInt: OP__I(INT_MAX); break;
+ case i_plusInt: OP_II_I(x+y); break;
+ case i_minusInt: OP_II_I(x-y); break;
+ case i_timesInt: OP_II_I(x*y); break;
+ case i_quotInt:
+ {
+ int x = PopTaggedInt();
+ int y = PopTaggedInt();
+ if (y == 0) {
+ return (raiseDiv0("quotInt"));
+ }
+ /* ToDo: protect against minInt / -1 errors
+ * (repeat for all other division primops) */
+ PushTaggedInt(x/y);
+ }
+ break;
+ case i_remInt:
+ {
+ int x = PopTaggedInt();
+ int y = PopTaggedInt();
+ if (y == 0) {
+ return (raiseDiv0("remInt"));
+ }
+ PushTaggedInt(x%y);
+ }
+ break;
+ case i_quotRemInt:
+ {
+ StgInt x = PopTaggedInt();
+ StgInt y = PopTaggedInt();
+ if (y == 0) {
+ return (raiseDiv0("quotRemInt"));
+ }
+ PushTaggedInt(x%y); /* last result */
+ PushTaggedInt(x/y); /* first result */
+ }
+ break;
+ case i_negateInt: OP_I_I(-x); break;
+
+ case i_andInt: OP_II_I(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_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 */
+
+ 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;
+ case i_leWord: OP_WW_B(x<=y); break;
+ case i_minWord: OP__W(0); break;
+ case i_maxWord: OP__W(UINT_MAX); break;
+ case i_plusWord: OP_WW_W(x+y); break;
+ case i_minusWord: OP_WW_W(x-y); break;
+ case i_timesWord: OP_WW_W(x*y); break;
+ case i_quotWord:
+ {
+ StgWord x = PopTaggedWord();
+ StgWord y = PopTaggedWord();
+ if (y == 0) {
+ return (raiseDiv0("quotWord"));
+ }
+ PushTaggedWord(x/y);
+ }
+ break;
+ case i_remWord:
+ {
+ StgWord x = PopTaggedWord();
+ StgWord y = PopTaggedWord();
+ if (y == 0) {
+ return (raiseDiv0("remWord"));
+ }
+ PushTaggedWord(x%y);
+ }
+ break;
+ case i_quotRemWord:
+ {
+ StgWord x = PopTaggedWord();
+ StgWord y = PopTaggedWord();
+ if (y == 0) {
+ return (raiseDiv0("quotRemWord"));
+ }
+ PushTaggedWord(x%y); /* last result */
+ PushTaggedWord(x/y); /* first result */
+ }
+ break;
+ case i_negateWord: OP_W_W(-x); break;
+ case i_andWord: OP_WW_W(x&y); break;
+ case i_orWord: OP_WW_W(x|y); break;
+ case i_xorWord: OP_WW_W(x^y); break;
+ case i_notWord: OP_W_W(~x); break;
+ case i_shiftLWord: OP_WW_W(x<<y); break;
+ case i_shiftRAWord: OP_WW_W(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(x<y); break;
+ case i_leAddr: OP_AA_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_intToStable: OP_I_s(x); break;
+ case i_stableToInt: OP_s_I(x); 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;
-#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;
-#endif
+ 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_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;
-#endif
+ 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 /* PROVIDE_ADDR */
+ case i_compareInteger:
+ {
+ B* x = IntegerInsideByteArray(PopPtr());
+ B* y = IntegerInsideByteArray(PopPtr());
+ StgInt r = do_cmp(x,y);
+ PushTaggedInt(r<0 ? -1 : (r>0 ? 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;
+
+ 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<y); break;
+ case i_leFloat: OP_FF_B(x<=y); break;
+ case i_minFloat: OP__F(FLT_MIN); break;
+ case i_maxFloat: OP__F(FLT_MAX); break;
+ case i_radixFloat: OP__I(FLT_RADIX); break;
+ case i_digitsFloat: OP__I(FLT_MANT_DIG); break;
+ case i_minExpFloat: OP__I(FLT_MIN_EXP); break;
+ case i_maxExpFloat: OP__I(FLT_MAX_EXP); break;
+ case i_plusFloat: OP_FF_F(x+y); break;
+ case i_minusFloat: OP_FF_F(x-y); break;
+ case i_timesFloat: OP_FF_F(x*y); break;
+ case i_divideFloat:
+ {
+ StgFloat x = PopTaggedFloat();
+ StgFloat y = PopTaggedFloat();
+ PushTaggedFloat(x/y);
+ }
+ break;
+ case i_negateFloat: OP_F_F(-x); break;
+ case i_floatToInt: OP_F_I(x); break;
+ case i_intToFloat: OP_I_F(x); break;
+ case i_expFloat: OP_F_F(exp(x)); break;
+ case i_logFloat: OP_F_F(log(x)); break;
+ case i_sqrtFloat: OP_F_F(sqrt(x)); break;
+ case i_sinFloat: OP_F_F(sin(x)); break;
+ case i_cosFloat: OP_F_F(cos(x)); break;
+ case i_tanFloat: OP_F_F(tan(x)); break;
+ case i_asinFloat: OP_F_F(asin(x)); break;
+ case i_acosFloat: OP_F_F(acos(x)); break;
+ case i_atanFloat: OP_F_F(atan(x)); break;
+ case i_sinhFloat: OP_F_F(sinh(x)); break;
+ case i_coshFloat: OP_F_F(cosh(x)); break;
+ case i_tanhFloat: OP_F_F(tanh(x)); break;
+ case i_powerFloat: OP_FF_F(pow(x,y)); break;
+
+ case i_encodeFloatZ:
+ {
+ StgPtr sig = PopPtr();
+ StgInt exp = PopTaggedInt();
+ PushTaggedFloat(
+ B__encodeFloat(IntegerInsideByteArray(sig), exp)
+ );
+ }
+ break;
+ case i_decodeFloatZ:
+ {
+ StgFloat f = PopTaggedFloat();
+ StgPtr sig = CreateByteArrayToHoldInteger(size_fltmantissa());
+ StgInt exp;
+ B__decodeFloat(IntegerInsideByteArray(sig), &exp, f);
+ PushTaggedInt(exp);
+ PushPtr(sig);
+ }
+ break;
-#ifdef PROVIDE_INTEGER
- case i_compareInteger:
- {
- mpz_ptr x = PopTaggedInteger();
- mpz_ptr y = PopTaggedInteger();
- StgInt r = mpz_cmp(x,y);
- PushTaggedInt(r<0 ? -1 : (r>0 ? 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<y); break;
- case i_leFloat: OP_FF_B(x<=y); break;
- case i_minFloat: OP__F(FLT_MIN); break;
- case i_maxFloat: OP__F(FLT_MAX); break;
- case i_radixFloat: OP__I(FLT_RADIX); break;
- case i_digitsFloat: OP__I(FLT_MANT_DIG); break;
- case i_minExpFloat: OP__I(FLT_MIN_EXP); break;
- case i_maxExpFloat: OP__I(FLT_MAX_EXP); break;
- case i_plusFloat: OP_FF_F(x+y); break;
- case i_minusFloat: OP_FF_F(x-y); break;
- case i_timesFloat: OP_FF_F(x*y); break;
- case i_divideFloat:
- {
- StgFloat x = PopTaggedFloat();
- StgFloat y = PopTaggedFloat();
-#if 0
- if (y == 0) {
- obj = raiseDiv0("divideFloat");
- goto enterLoop;
- }
-#endif
- PushTaggedFloat(x/y);
- }
- break;
- case i_negateFloat: OP_F_F(-x); break;
- case i_floatToInt: OP_F_I(x); break;
- case i_intToFloat: OP_I_F(x); break;
- case i_expFloat: OP_F_F(exp(x)); break;
- case i_logFloat: OP_F_F(log(x)); break;
- case i_sqrtFloat: OP_F_F(sqrt(x)); break;
- case i_sinFloat: OP_F_F(sin(x)); break;
- case i_cosFloat: OP_F_F(cos(x)); break;
- case i_tanFloat: OP_F_F(tan(x)); break;
- case i_asinFloat: OP_F_F(asin(x)); break;
- case i_acosFloat: OP_F_F(acos(x)); break;
- case i_atanFloat: OP_F_F(atan(x)); break;
- case i_sinhFloat: OP_F_F(sinh(x)); break;
- case i_coshFloat: OP_F_F(cosh(x)); break;
- case i_tanhFloat: OP_F_F(tanh(x)); break;
- case i_powerFloat: OP_FF_F(pow(x,y)); break;
-
-#ifdef PROVIDE_INT64
- /* Based on old Hugs code */
- /* ToDo: use ~/fptools/ghc/runtime/prims/PrimArith.lc */
- case i_encodeFloatz: OP_zI_F(ldexp(x,y)); break;
- case i_decodeFloatz:
- {
- /* ToDo: this code is known to give very approximate results
- * (even when StgInt64 overflow doesn't occur)
- */
- double f0 = PopTaggedFloat();
- int n;
- double f1 = frexp((double)(f0),&n); /* 0.5 <= f1 < 1 */
- double f2 = ldexp(f1,FLT_MANT_DIG); /* 2^m-1 <= f2 < 2^m, m=FLT_MANT_DIG */
- PushTaggedInt(n-FLT_MANT_DIG);
- PushTaggedInt64((StgInt64)f2);
-#if 1 /* paranoia */
- if (ldexp((StgInt64)f2,n-FLT_MANT_DIG) != f0) {
- fprintf(stderr,"*** primDecodeFloat mismatch: %.10f != %.10f\n",
- ldexp((StgInt64)f2,n-FLT_MANT_DIG),f0);
- }
-#endif
- }
- break;
-#endif /* PROVIDE_INT64 */
-#ifdef PROVIDE_INTEGER
- case i_encodeFloatZ: OP_ZI_F(__encodeFloat(x,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<y); break;
- case i_leDouble: OP_DD_B(x<=y) break;
- case i_minDouble: OP__D(DBL_MIN); break;
- case i_maxDouble: OP__D(DBL_MAX); break;
- case i_radixDouble: OP__I(FLT_RADIX); break;
- case i_digitsDouble: OP__I(DBL_MANT_DIG); break;
- case i_minExpDouble: OP__I(DBL_MIN_EXP); break;
- case i_maxExpDouble: OP__I(DBL_MAX_EXP); break;
- case i_plusDouble: OP_DD_D(x+y); break;
- case i_minusDouble: OP_DD_D(x-y); break;
- case i_timesDouble: OP_DD_D(x*y); break;
- case i_divideDouble:
- {
- StgDouble x = PopTaggedDouble();
- StgDouble y = PopTaggedDouble();
-#if 0
- if (y == 0) {
- obj = raiseDiv0("divideDouble");
- goto enterLoop;
- }
-#endif
- PushTaggedDouble(x/y);
- }
- break;
- case i_negateDouble: OP_D_D(-x); break;
- case i_doubleToInt: OP_D_I(x); break;
- case i_intToDouble: OP_I_D(x); break;
- case i_doubleToFloat: OP_D_F(x); break;
- case i_floatToDouble: OP_F_F(x); break;
- case i_expDouble: OP_D_D(exp(x)); break;
- case i_logDouble: OP_D_D(log(x)); break;
- case i_sqrtDouble: OP_D_D(sqrt(x)); break;
- case i_sinDouble: OP_D_D(sin(x)); break;
- case i_cosDouble: OP_D_D(cos(x)); break;
- case i_tanDouble: OP_D_D(tan(x)); break;
- case i_asinDouble: OP_D_D(asin(x)); break;
- case i_acosDouble: OP_D_D(acos(x)); break;
- case i_atanDouble: OP_D_D(atan(x)); break;
- case i_sinhDouble: OP_D_D(sinh(x)); break;
- case i_coshDouble: OP_D_D(cosh(x)); break;
- case i_tanhDouble: OP_D_D(tanh(x)); break;
- case i_powerDouble: OP_DD_D(pow(x,y)); break;
-#ifdef PROVIDE_INT64
- case i_encodeDoublez: OP_zI_D(ldexp(x,y)); break;
- case i_decodeDoublez:
- {
- /* ToDo: this code is known to give very approximate results
- * (even when StgInt64 overflow doesn't occur)
- */
- double f0 = PopTaggedDouble();
- int n;
- double f1 = frexp((double)(f0),&n); /* 0.5 <= f1 < 1 */
- double f2 = ldexp(f1,FLT_MANT_DIG); /* 2^m-1 <= f2 < 2^m, m=FLT_MANT_DIG */
- PushTaggedInt(n-FLT_MANT_DIG);
- PushTaggedInt64((StgInt64)f2);
-#if 1 /* paranoia */
- if (ldexp((StgInt64)f2,n-FLT_MANT_DIG) != f0) {
- fprintf(stderr,"*** primDecodeDouble mismatch: %.10f != %.10f\n",
- ldexp((StgInt64)f2,n-FLT_MANT_DIG),f0);
- }
-#endif
- }
- break;
-#endif /* PROVIDE_INT64 */
-#ifdef PROVIDE_INTEGER
- case i_encodeDoubleZ: OP_ZI_D(__encodeDouble(x,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_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:
- {
- 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_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<y); break;
+ case i_leDouble: OP_DD_B(x<=y) break;
+ case i_minDouble: OP__D(DBL_MIN); break;
+ case i_maxDouble: OP__D(DBL_MAX); break;
+ case i_radixDouble: OP__I(FLT_RADIX); break;
+ case i_digitsDouble: OP__I(DBL_MANT_DIG); break;
+ case i_minExpDouble: OP__I(DBL_MIN_EXP); break;
+ case i_maxExpDouble: OP__I(DBL_MAX_EXP); break;
+ case i_plusDouble: OP_DD_D(x+y); break;
+ case i_minusDouble: OP_DD_D(x-y); break;
+ case i_timesDouble: OP_DD_D(x*y); break;
+ case i_divideDouble:
+ {
+ StgDouble x = PopTaggedDouble();
+ StgDouble y = PopTaggedDouble();
+ PushTaggedDouble(x/y);
+ }
+ break;
+ case i_negateDouble: OP_D_D(-x); break;
+ case i_doubleToInt: OP_D_I(x); break;
+ case i_intToDouble: OP_I_D(x); break;
+ case i_doubleToFloat: OP_D_F(x); break;
+ case i_floatToDouble: OP_F_F(x); break;
+ case i_expDouble: OP_D_D(exp(x)); break;
+ case i_logDouble: OP_D_D(log(x)); break;
+ case i_sqrtDouble: OP_D_D(sqrt(x)); break;
+ case i_sinDouble: OP_D_D(sin(x)); break;
+ case i_cosDouble: OP_D_D(cos(x)); break;
+ case i_tanDouble: OP_D_D(tan(x)); break;
+ case i_asinDouble: OP_D_D(asin(x)); break;
+ case i_acosDouble: OP_D_D(acos(x)); break;
+ case i_atanDouble: OP_D_D(atan(x)); break;
+ case i_sinhDouble: OP_D_D(sinh(x)); break;
+ case i_coshDouble: OP_D_D(cosh(x)); break;
+ case i_tanhDouble: OP_D_D(tanh(x)); break;
+ case i_powerDouble: OP_DD_D(pow(x,y)); break;
+
+ case i_encodeDoubleZ:
+ {
+ StgPtr sig = PopPtr();
+ StgInt exp = PopTaggedInt();
+ PushTaggedDouble(
+ B__encodeDouble(IntegerInsideByteArray(sig), exp)
+ );
+ }
+ break;
+ case i_decodeDoubleZ:
+ {
+ StgDouble d = PopTaggedDouble();
+ StgPtr sig = CreateByteArrayToHoldInteger(size_dblmantissa());
+ StgInt exp;
+ B__decodeDouble(IntegerInsideByteArray(sig), &exp, d);
+ PushTaggedInt(exp);
+ PushPtr(sig);
+ }
+ break;
+
+ 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");
+ }
+ return NULL;
+}
+
+
+
+/* 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.
+ To cause a context switch, set context_switch (its a global),
+ and optionally set hugsBlock to your rational.
+*/
+static void* enterBCO_primop2 ( int primop2code,
+ int* /*StgThreadReturnCode* */ return2,
+ StgBCO** bco,
+ Capability* cap,
+ HugsBlock *hugsBlock )
+{
+ if (combined) {
+ /* A small concession: we need to allow ccalls,
+ even in combined mode.
+ */
+ if (primop2code != i_ccall_ccall_IO &&
+ primop2code != i_ccall_stdcall_IO)
+ barf("enterBCO_primop2 in combined mode");
+ }
+
+ 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;
- nat i;
- StgArrWords* arr = stgCast(StgArrWords*,allocate(size));
- SET_HDR(arr,&ARR_WORDS_info,CCCS);
- arr->words = words;
+ 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;
+
+ 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;
- /* 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;
+#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 */
-#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;
- }
-#if 1
-#if 0
-ToDo: another way out of the problem might be to add an explicit
-continuation to primTakeMVar: takeMVar v = primTakeMVar v takeMVar.
-The problem with this plan is that now I dont know how much to chop
-off the stack.
-#endif
- case i_takeMVar:
- {
- StgMVar *mvar = stgCast(StgMVar*,PopPtr());
- /* If the MVar is empty, put ourselves
- * on its blocking queue, and wait
- * until we're woken up.
- */
- if (GET_INFO(mvar) != &FULL_MVAR_info) {
- if (mvar->head == EndTSOQueue) {
- mvar->head = CurrentTSO;
- } 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
- * and push ths BCO.
- * What a disgusting hack!
- */
+ 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;
+ }
- 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;
- }
-#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");
- }
- 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;
+ }
+
+ case i_newMVar:
+ {
+ StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
+ SET_INFO(mvar,&EMPTY_MVAR_info);
+ mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
+ mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
+ PushPtr(stgCast(StgPtr,mvar));
+ break;
+ }
+ case i_takeMVar:
+ {
+ StgMVar *mvar = (StgMVar*)PopCPtr();
+ if (GET_INFO(mvar) == &EMPTY_MVAR_info) {
+
+ /* The MVar is empty. Attach ourselves to the TSO's
+ blocking queue.
+ */
+ if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
+ mvar->head = cap->rCurrentTSO;
+ } else {
+ mvar->tail->link = cap->rCurrentTSO;
}
- default:
- barf("Unrecognised instruction");
+ cap->rCurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
+ cap->rCurrentTSO->why_blocked = BlockedOnMVar;
+ cap->rCurrentTSO->block_info.closure = (StgClosure *)mvar;
+ mvar->tail = cap->rCurrentTSO;
+
+ /* At this point, the top-of-stack holds the MVar,
+ and underneath is the world token (). So the
+ stack is in the same state as when primTakeMVar
+ was entered (primTakeMVar is handwritten bytecode).
+ Push obj, which is this BCO, and return to the
+ scheduler. When the MVar is filled, the scheduler
+ will re-enter primTakeMVar, with the args still on
+ the top of the stack.
+ */
+ PushCPtr((StgClosure*)(*bco));
+ *return2 = ThreadBlocked;
+ return (void*)(1+(char*)(NULL));
+
+ } else {
+ PushCPtr(mvar->value);
+ mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
+ SET_INFO(mvar,&EMPTY_MVAR_info);
}
+ break;
}
- barf("Ran off the end of bco - yoiks");
- break;
- }
- case CAF_UNENTERED:
- {
- StgCAF* caf = stgCast(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 */
+ case i_putMVar:
{
- /*was StgBlackHole* */
- StgBlockingQueue* bh
- = stgCast(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 = stgCast(StgClosure*,bh);
- PUSH_UPD_FRAME(bh,0);
- Sp -= sizeofW(StgUpdateFrame);
+ StgMVar* mvar = stgCast(StgMVar*,PopPtr());
+ StgClosure* value = PopCPtr();
+ if (GET_INFO(mvar) == &FULL_MVAR_info) {
+ return (makeErrorCall("putMVar {full MVar}"));
+ } else {
+ /* wake up the first thread on the
+ * queue, it will continue with the
+ * takeMVar operation and mark the
+ * MVar empty again.
+ */
+ mvar->value = value;
+
+ if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
+ ASSERT(mvar->head->why_blocked == BlockedOnMVar);
+ mvar->head = unblockOne(mvar->head);
+ if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
+ mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
+ }
+ }
+
+ /* unlocks the MVar in the SMP case */
+ SET_INFO(mvar,&FULL_MVAR_info);
+
+ /* yield for better communication performance */
+ context_switch = 1;
+ }
+ break;
}
- caf->link = enteredCAFs;
- enteredCAFs = caf;
- obj = caf->body;
- goto enterLoop;
- }
- case CAF_ENTERED:
- {
- StgCAF* caf = stgCast(StgCAF*,obj);
- obj = caf->value; /* it's just a fancy indirection */
- goto enterLoop;
- }
- case BLACKHOLE:
- case CAF_BLACKHOLE:
- {
- /*was StgBlackHole* */
- StgBlockingQueue* bh = stgCast(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 */
- 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;
+ case i_sameMVar:
+ { /* identical to i_sameRef */
+ StgMVar* x = (StgMVar*)PopPtr();
+ StgMVar* y = (StgMVar*)PopPtr();
+ PushTaggedBool(x==y);
+ break;
}
- /* 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));
+#ifdef PROVIDE_CONCURRENT
+ case i_forkIO:
+ {
+ StgClosure* closure;
+ StgTSO* tso;
+ StgWord tid;
+ closure = PopCPtr();
+ tso = createGenThread (RtsFlags.GcFlags.initialStkSize,closure);
+ tid = tso->id;
+ scheduleThread(tso);
+ context_switch = 1;
+ /* Later: Change to use tso as the ThreadId */
+ PushTaggedWord(tid);
+ break;
}
- obj = ap->fun;
-#ifndef LAZY_BLACKHOLING
+
+ case i_killThread:
{
- /* 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); */
+ StgWord n = PopTaggedWord();
+ StgTSO* tso = 0;
+ StgTSO *t;
+
+ // Map from ThreadId to Thread Structure */
+ for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
+ if (n == t->id)
+ tso = t;
+ }
+ if (tso == 0) {
+ // Already dead
+ break;
+ }
+
+ while (tso->what_next == ThreadRelocated) {
+ tso = tso->link;
+ }
+
+ deleteThread(tso);
+ if (tso == cap->rCurrentTSO) { /* suicide */
+ *return2 = ThreadFinished;
+ return (void*)(1+(NULL));
+ }
+ break;
}
-#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.
+ case i_raiseInThread:
+ ASSERT(0); /* not (yet) supported */
+ case i_delay:
+ {
+ StgInt n = PopTaggedInt();
+ context_switch = 1;
+ hugsBlock->reason = BlockedOnDelay;
+ hugsBlock->delay = n;
+ break;
+ }
+ case i_waitRead:
+ {
+ StgInt n = PopTaggedInt();
+ context_switch = 1;
+ hugsBlock->reason = BlockedOnRead;
+ hugsBlock->delay = n;
+ break;
+ }
+ case i_waitWrite:
+ {
+ StgInt n = PopTaggedInt();
+ context_switch = 1;
+ hugsBlock->reason = BlockedOnWrite;
+ hugsBlock->delay = n;
+ break;
+ }
+ case i_yield:
+ {
+ /* The definition of yield include an enter right after
+ * the primYield, at which time context_switch is tested.
*/
- while (--i >= 0) {
- PushWord(payloadWord(pap,i));
+ context_switch = 1;
+ break;
+ }
+ case i_getThreadId:
+ {
+ StgWord tid = cap->rCurrentTSO->id;
+ PushTaggedWord(tid);
+ break;
}
- obj = pap->fun;
- goto enterLoop;
- }
- case IND:
- {
- obj = stgCast(StgInd*,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");
- }
+ case i_cmpThreadIds:
+ {
+ StgWord tid1 = PopTaggedWord();
+ StgWord tid2 = PopTaggedWord();
+ if (tid1 < tid2) PushTaggedInt(-1);
+ else if (tid1 > tid2) PushTaggedInt(1);
+ else PushTaggedInt(0);
+ break;
}
- }
- default:
- {
- CurrentTSO->whatNext = ThreadEnterGHC;
- PushCPtr(obj); /* code to restart with */
- return ThreadYielding;
- }
- }
- barf("Ran off the end of enter - yoiks");
+#endif /* PROVIDE_CONCURRENT */
+
+ case i_ccall_ccall_Id:
+ case i_ccall_ccall_IO:
+ case i_ccall_stdcall_Id:
+ case i_ccall_stdcall_IO:
+ {
+ int r;
+ CFunDescriptor* descriptor;
+ void (*funPtr)(void);
+ char cc;
+ descriptor = PopTaggedAddr();
+ funPtr = PopTaggedAddr();
+ cc = (primop2code == i_ccall_stdcall_Id ||
+ primop2code == i_ccall_stdcall_IO)
+ ? 's' : 'c';
+ r = ccall(descriptor,funPtr,bco,cc,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:
+ 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)
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
+#if 0
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);
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
case STABLE_REP:
PushTaggedStablePtr(*((StgStablePtr*)arg));
return ARG_SIZE(STABLE_TAG);
+#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;
}
/* 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)
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
+#if 0
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);
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
case STABLE_REP:
*((StgStablePtr*)res) = PopTaggedStablePtr();
return ARG_SIZE(STABLE_TAG);
+#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));
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
+#if 0
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;
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:
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)
+ * ---------------------------------------------------------------------------*/
+
+#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 /* INTERPRETER */
projects / ghc-hetmet.git / blobdiff