* Copyright (c) 1994-1998.
*
* $RCSfile: Evaluator.c,v $
- * $Revision: 1.21 $
- * $Date: 1999/10/22 15:58:22 $
+ * $Revision: 1.58 $
+ * $Date: 2000/10/09 11:20:16 $
* ---------------------------------------------------------------------------*/
#include "Rts.h"
#include "Assembler.h" /* for CFun stuff */
#include "ForeignCall.h"
#include "PrimOps.h" /* for __{encode,decode}{Float,Double} */
+#include "Prelude.h"
+#include "Itimer.h"
#include "Evaluator.h"
+#include "sainteger.h"
#ifdef DEBUG
#include "Printer.h"
#include <ieee754.h> /* These are for primops */
#endif
-#ifdef STANDALONE_INTEGER
-#include "sainteger.h"
-#else
-#error Non-standalone integer not yet supported
-#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
/* 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 );
-
-
-/* --------------------------------------------------------------------------
- * Crude profiling stuff (mainly to assess effect of optimiser)
- * ------------------------------------------------------------------------*/
-
-#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 )
-{
- int i;
- cpCurr = CP_NIL;
- cpInUse = 0;
- for (i = 0; i < M_CPTAB; i++)
- cpTab[i].who = CP_NIL;
-}
-
-
-void cp_enter ( StgBCO* b )
-{
- 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 )
-{
- if (cpCurr == CP_NIL) return;
- cpTab[cpCurr].bytes += sizeof(StgWord)*nw;
-}
-
-
-void cp_bill_insns ( int ni )
-{
- if (cpCurr == CP_NIL) return;
- cpTab[cpCurr].insns += ni;
-}
-
+extern void* /* StgClosure* */ getHugs_BCO_cptr_for ( char* s );
+extern int /* Bool */ combined;
-static double percent ( double a, double b )
-{
- return (100.0 * a) / b;
-}
-
-
-void cp_show ( void )
-{
- 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;
-
- printf ( "\n" );
-}
-
-#endif
/* --------------------------------------------------------------------------
}
}
-/* --------------------------------------------------------------------------
- * RTS Hooks
- *
- * ToDo: figure out why these are being used and crush them!
- * ------------------------------------------------------------------------*/
-#if 0
-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)
-{
- fprintf(stderr,"Out Of Heap\n");
- exit(1);
-}
-void MallocFailHook (unsigned long request_size /* in bytes */, char *msg)
-{
- fprintf(stderr,"Malloc Fail\n");
- exit(1);
-}
-void defaultsHook (void)
-{
- /* do nothing */
-}
-#endif
+
+typedef struct {
+ StgTSOBlockReason reason;
+ unsigned int delay;
+} HugsBlock;
+
/* --------------------------------------------------------------------------
* Entering-objects and bytecode interpreter part of evaluator
/* Forward decls ... */
static void* enterBCO_primop1 ( int );
-static void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */, StgBCO** );
+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 void PushTaggedInteger ( mpz_ptr ); */
static inline StgPtr grabHpUpd( nat size );
static inline StgPtr grabHpNonUpd( nat size );
-static StgClosure* raiseAnError ( StgClosure* errObj );
+static StgClosure* raiseAnError ( StgClosure* exception );
static int enterCountI = 0;
-#ifdef STANDALONE_INTEGER
StgDouble B__encodeDouble (B* s, I_ e);
void B__decodeDouble (B* man, I_* exp, StgDouble dbl);
#if ! FLOATS_AS_DOUBLES
B* IntegerInsideByteArray ( StgPtr );
void SloppifyIntegerEnd ( StgPtr );
#endif
-#endif
+#define gSp MainRegTable.rSp
+#define gSu MainRegTable.rSu
+#define gSpLim MainRegTable.rSpLim
+
+
/* Macros to save/load local state. */
#ifdef DEBUG
-#define SSS { tSp=Sp = xSp; tSu=Su = xSu; tSpLim=SpLim = xSpLim; }
-#define LLL { tSp=xSp = Sp; tSu=xSu = Su; tSpLim=xSpLim = SpLim; }
+#define SSS { tSp=gSp = xSp; tSu=gSu = xSu; tSpLim=gSpLim = xSpLim; }
+#define LLL { tSp=xSp = gSp; tSu=xSu = gSu; tSpLim=xSpLim = gSpLim; }
#else
-#define SSS { Sp = xSp; Su = xSu; SpLim = xSpLim; }
-#define LLL { xSp = Sp; xSu = Su; xSpLim = SpLim; }
+#define SSS { gSp = xSp; gSu = xSu; gSpLim = xSpLim; }
+#define LLL { xSp = gSp; xSu = gSu; xSpLim = gSpLim; }
#endif
-#define RETURN(vvv) { \
- StgThreadReturnCode retVal=(vvv); SSS; \
- /* SaveThreadState() is done by the scheduler. */ \
- return retVal; \
+#define RETURN(vvv) { \
+ StgThreadReturnCode retVal=(vvv); \
+ SSS; \
+ cap->rCurrentTSO->sp = gSp; \
+ cap->rCurrentTSO->su = gSu; \
+ return retVal; \
}
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
+ expressions to work properly.
*/
#define xPushPtr(ppp) { xSp--; *xSp=(StgWord)(ppp); }
#define xPopPtr() ((StgPtr)(*xSp++))
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 */ \
#define PC (bciPtr - &(bcoInstr(bco,0)))
-StgThreadReturnCode enter( StgClosure* obj0 )
+/* State on entry to enter():
+ * - current thread is in cap->rCurrentTSO;
+ * - allocation area is in cap->rCurrentNursery & cap->rNursery
+ */
+
+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 StgClosure* obj; /* object currently under evaluation */
char eCount; /* enter counter, for context switching */
+
+ HugsBlock hugsBlock = { NotBlocked, 0 };
+
+
#ifdef DEBUG
- /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */
StgPtr tSp; StgUpdateFrame* tSu; StgPtr tSpLim;
#endif
- /* LoadThreadState() is done by the scheduler. */
+
+ gSp = cap->rCurrentTSO->sp;
+ gSu = cap->rCurrentTSO->su;
+ gSpLim = cap->rCurrentTSO->stack + RESERVED_STACK_WORDS;
+
#ifdef DEBUG
- tSp = Sp; tSu = Su; tSpLim = SpLim;
+ /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */
+ tSp = gSp; tSu = gSu; tSpLim = gSpLim;
#endif
obj = obj0;
enterLoop:
+ numEnters++;
+
#ifdef DEBUG
- assert(Sp == tSp);
- assert(Su == tSu);
- assert(SpLim == tSpLim);
+ ASSERT(gSp == tSp);
+ ASSERT(gSu == tSu);
+ ASSERT(gSpLim == tSpLim);
IF_DEBUG(evaluator,
SSS;
enterCountI++;
fprintf(stderr,"(%d) Entering: ",enterCountI); printObj(obj);
fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
fprintf(stderr, "\n" );
- printStack(xSp,CurrentTSO->stack+CurrentTSO->stack_size,xSu);
+ printStack(xSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,xSu);
fprintf(stderr, "\n\n");
LLL;
);
if (
#ifdef DEBUG
- 1 ||
+ ((++eCount) & 0x0F) == 0
+#else
+ ++eCount == 0
#endif
- ++eCount == 0) {
+ ) {
if (context_switch) {
- xPushCPtr(obj); /* code to restart with */
- RETURN(ThreadYielding);
+ switch(hugsBlock.reason) {
+ case NotBlocked: {
+ xPushCPtr(obj); /* code to restart with */
+ RETURN(ThreadYielding);
+ }
+ case BlockedOnDelay: /* fall through */
+ case BlockedOnRead: /* fall through */
+ case BlockedOnWrite: {
+ ASSERT(cap->rCurrentTSO->why_blocked == NotBlocked);
+ cap->rCurrentTSO->why_blocked = BlockedOnDelay;
+ ACQUIRE_LOCK(&sched_mutex);
+
+#if defined(HAVE_SETITIMER) /* || defined(mingw32_TARGET_OS) */
+ cap->rCurrentTSO->block_info.delay
+ = hugsBlock.delay + ticks_since_select;
+#else
+ cap->rCurrentTSO->block_info.target
+ = hugsBlock.delay + getourtimeofday();
+#endif
+ APPEND_TO_BLOCKED_QUEUE(cap->rCurrentTSO);
+
+ RELEASE_LOCK(&sched_mutex);
+
+ xPushCPtr(obj); /* code to restart with */
+ RETURN(ThreadBlocked);
+ }
+ default:
+ barf("Unknown context switch reasoning");
+ }
}
}
RETURN(HeapOverflow);
}
-# if CRUDE_PROFILING
- cp_enter ( bco );
-# endif
-
-
bciPtr = &(bcoInstr(bco,0));
LoopTopLabel
- ASSERT(PC < bco->n_instrs);
+ ASSERT((StgWord)(PC) < bco->n_instrs);
IF_DEBUG(evaluator,
fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", xSp, xSu, PC);
SSS;
if (0) { int i;
fprintf(stderr,"\n");
for (i = 8; i >= 0; i--)
- fprintf(stderr, "%d %p\n", i, (StgPtr)(*(Sp+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):
}
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;
xPopUpdateFrame(obj);
break;
case STOP_FRAME:
+ barf("STOP frame during pap update");
+#if 0
+ cap->rCurrentTSO->what_next = ThreadComplete;
SSS; PopStopFrame(obj); LLL;
RETURN(ThreadFinished);
+#endif
case SEQ_FRAME:
SSS; PopSeqFrame(); LLL;
ASSERT(xSp != (P_)xSu);
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! */
nat np = info->layout.payload.nptrs;
nat i;
for(i=0; i < p; ++i) {
- payloadCPtr(o,i) = xPopCPtr();
+ o->payload[i] = xPopCPtr();
}
for(i=0; i < np; ++i) {
payloadWord(o,p+i) = 0xdeadbeef;
nat np = info->layout.payload.nptrs;
nat i;
for(i=0; i < p; ++i) {
- payloadCPtr(o,i) = xPopCPtr();
+ o->payload[i] = xPopCPtr();
}
for(i=0; i < np; ++i) {
payloadWord(o,p+i) = 0xdeadbeef;
{
int tag = BCO_INSTR_8;
StgWord offset = BCO_INSTR_16;
- if (constrTag(stgCast(StgClosure*,xStackPtr(0))) != tag) {
+ if (constrTag( (StgClosure*)xStackPtr(0) ) != tag) {
bciPtr += offset;
}
Continue;
|| itbl->type == CONSTR_0_2
);
while (--i>=0) {
- xPushCPtr(payloadCPtr(o,i));
+ xPushCPtr(o->payload[i]);
}
Continue;
}
xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,n)));
Continue;
}
+#ifdef XMLAMBDA
+ /* allocate rows, implemented on top of (frozen) Arrays */
+ Case(i_ALLOC_ROW):
+ {
+ StgMutArrPtrs* p;
+ StgWord n = BCO_INSTR_8;
+ SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + n)); LLL;
+ SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS);
+ p->ptrs = n;
+ xPushPtr(p);
+ Continue;
+ }
+ Case(i_ALLOC_ROW_big):
+ {
+ StgMutArrPtrs* p;
+ StgWord n = BCO_INSTR_16;
+ SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + n)); LLL;
+ SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS);
+ p->ptrs = n;
+ xPushPtr(p);
+ Continue;
+ }
+
+ /* pack values into a row. */
+ Case(i_PACK_ROW):
+ {
+ StgWord offset = BCO_INSTR_8;
+ StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(offset));
+ StgWord n = p->ptrs;
+ StgWord i;
+
+ for (i=0; i<n; ++i)
+ {
+ p->payload[i] = xPopCPtr();
+ }
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ SSS;
+ printObj(stgCast(StgClosure*,p));
+ LLL;
+ );
+ Continue;
+ }
+ Case(i_PACK_ROW_big):
+ {
+ StgWord offset = BCO_INSTR_16;
+ StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(offset));
+ StgWord n = p->ptrs;
+ StgWord i;
+
+ for (i=0; i<n; ++i)
+ {
+ p->payload[i] = xPopCPtr();
+ }
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ SSS;
+ printObj(stgCast(StgClosure*,p));
+ LLL;
+ );
+ Continue;
+ }
+
+ /* extract all fields of a row */
+ Case(i_UNPACK_ROW):
+ {
+ StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(0));
+ nat i = p->ptrs;
+ while (i > 0)
+ {
+ i--;
+ xPushCPtr(p->payload[i]);
+ }
+ Continue;
+ }
+
+ /* Trivial row (unit) */
+ Case(i_CONST_ROW_TRIV):
+ {
+ StgMutArrPtrs* p;
+ SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + 0)); LLL;
+ SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS);
+ p->ptrs = 0;
+ xPushPtr(p);
+ Continue;
+ }
+
+ /* pack values into an Inj */
+ Case(i_PACK_INJ_VAR):
+ {
+ const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord));
+ StgWord offset = BCO_INSTR_8;
+
+ StgClosure* o;
+ SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
+ SET_HDR(o,Inj_con_info,??);
+
+ payloadWord(o,sizeofW(StgPtr)) = xTaggedStackWord(offset);
+ payloadPtr(o,0) = xPopPtr();
+
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ SSS;
+ printObj(stgCast(StgClosure*,o));
+ LLL;
+ );
+ xPushPtr(stgCast(StgPtr,o));
+ Continue;
+ }
+ Case(i_PACK_INJ_VAR_big):
+ {
+ const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord));
+ StgWord offset = BCO_INSTR_16;
+
+ StgClosure* o;
+ SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
+ SET_HDR(o,Inj_con_info,??);
+
+ payloadWord(o,sizeofW(StgPtr)) = xTaggedStackWord(offset);
+ payloadPtr(o,0) = xPopPtr();
+
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ SSS;
+ printObj(stgCast(StgClosure*,o));
+ LLL;
+ );
+ xPushPtr(stgCast(StgPtr,o));
+ Continue;
+ }
+ Case(i_PACK_INJ_CONST_8):
+ {
+ const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord));
+ StgWord witness = BCO_INSTR_8;
+
+ StgClosure* o;
+ SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
+ SET_HDR(o,Inj_con_info,??);
+
+ payloadWord(o,sizeofW(StgPtr)) = witness;
+ payloadPtr(o,0) = xPopPtr();
+
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ SSS;
+ printObj(stgCast(StgClosure*,o));
+ LLL;
+ );
+ xPushPtr(stgCast(StgPtr,o));
+ Continue;
+ }
+ Case(i_PACK_INJ_REL_8):
+ {
+ const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord));
+ StgWord offset = BCO_INSTR_8;
+ StgWord cwitness = BCO_INSTR_8;
+
+ StgClosure* o;
+ SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
+ SET_HDR(o,Inj_con_info,??);
+
+ payloadWord(o,sizeofW(StgPtr)) = xTaggedStackWord(offset) + cwitness;
+ payloadPtr(o,0) = xPopPtr();
+
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ SSS;
+ printObj(stgCast(StgClosure*,o));
+ LLL;
+ );
+ xPushPtr(stgCast(StgPtr,o));
+ Continue;
+ }
+ Case(i_PACK_INJ):
+ {
+ const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord));
+
+ StgClosure* o;
+ SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
+ SET_HDR(o,Inj_con_info,??);
+
+ payloadWord(o,sizeofW(StgPtr)) = xPopTaggedWord();
+ payloadPtr(o,0) = xPopPtr();
+
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ SSS;
+ printObj(stgCast(StgClosure*,o));
+ LLL;
+ );
+ xPushPtr(stgCast(StgPtr,o));
+ Continue;
+ }
+
+ /* Test Inj witnesses. */
+ Case(i_TEST_INJ_VAR):
+ {
+ StgWord offset = BCO_INSTR_8;
+ StgWord jump = BCO_INSTR_16;
+
+ StgWord index = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
+ if (index != xTaggedStackWord(offset) )
+ {
+ bciPtr += jump;
+ }
+ Continue;
+ }
+ Case(i_TEST_INJ_VAR_big):
+ {
+ StgWord offset = BCO_INSTR_16;
+ StgWord jump = BCO_INSTR_16;
+
+ StgWord index = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
+ if (index != xTaggedStackWord(offset) )
+ {
+ bciPtr += jump;
+ }
+ Continue;
+ }
+ Case(i_TEST_INJ_CONST_8):
+ {
+ StgWord cwitness = BCO_INSTR_8;
+ StgWord jump = BCO_INSTR_16;
+
+ StgWord witness = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
+ if (witness != cwitness )
+ {
+ bciPtr += jump;
+ }
+ Continue;
+ }
+ Case(i_TEST_INJ_REL_8):
+ {
+ StgWord offset = BCO_INSTR_8;
+ StgWord cwitness = BCO_INSTR_8;
+ StgWord jump = BCO_INSTR_16;
+
+ StgWord witness = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
+ if (witness != xTaggedStackWord(offset) + cwitness )
+ {
+ bciPtr += jump;
+ }
+ Continue;
+ }
+ Case(i_TEST_INJ):
+ {
+ StgWord jump = BCO_INSTR_16;
+ StgWord cwitness = xPopTaggedWord();
+
+ StgWord witness = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
+ if (witness != cwitness )
+ {
+ bciPtr += jump;
+ }
+ Continue;
+ }
+
+ /* extract the value of an INJ */
+ Case(i_UNPACK_INJ):
+ {
+ StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
+
+ ASSERT(get_itbl(con) == Inj_con_info);
+
+ xPushPtr(payloadPtr(con,0));
+ Continue;
+ }
+
+ /* optimized witness (word) operations */
+ Case(i_CONST_WORD_8):
+ {
+ xPushTaggedWord(BCO_INSTR_8);
+ Continue;
+ }
+ Case(i_ADD_WORD_VAR):
+ {
+ StgWord offset = BCO_INSTR_8;
+ StgWord witness = xTaggedStackWord(offset);
+ witness += xPopTaggedWord();
+ xPushTaggedWord(witness);
+ Continue;
+ }
+ Case(i_ADD_WORD_VAR_big):
+ {
+ StgWord offset = BCO_INSTR_16;
+ StgWord witness = xTaggedStackWord(offset);
+ witness += xPopTaggedWord();
+ xPushTaggedWord(witness);
+ Continue;
+ }
+ Case(i_ADD_WORD_VAR_8):
+ {
+ StgWord offset = BCO_INSTR_8;
+ StgWord inc = BCO_INSTR_8;
+ StgWord witness = xTaggedStackWord(offset);
+ xPushTaggedWord(witness + inc);
+ Continue;
+ }
+#endif /* XMLAMBA */
+
Case(i_VOID):
{
SSS; PushTaggedRealWorld(); LLL;
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,??);
+ SET_HDR(o,Izh_con_info,??);
payloadWord(o,0) = xPopTaggedInt();
IF_DEBUG(evaluator,
fprintf(stderr,"\tBuilt ");
xPushTaggedWord(bcoConstWord(bco,BCO_INSTR_8));
Continue;
}
+ Case(i_CONST_WORD_big):
+ {
+ StgWord n = BCO_INSTR_16;
+ xPushTaggedWord(bcoConstWord(bco,n));
+ Continue;
+ }
Case(i_PACK_WORD):
{
StgClosure* o;
SSS; o = (StgClosure*)grabHpNonUpd(Wzh_sizeW); LLL;
- SET_HDR(o,&Wzh_con_info,??);
+ SET_HDR(o,Wzh_con_info,??);
payloadWord(o,0) = xPopTaggedWord();
IF_DEBUG(evaluator,
fprintf(stderr,"\tBuilt ");
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,??);
+ SET_HDR(o,Azh_con_info,??);
payloadPtr(o,0) = xPopTaggedAddr();
IF_DEBUG(evaluator,
fprintf(stderr,"\tBuilt ");
{
StgClosure* o;
SSS; o = (StgClosure*)grabHpNonUpd(Czh_sizeW); LLL;
- SET_HDR(o,&Czh_con_info,??);
+ SET_HDR(o,Czh_con_info,??);
payloadWord(o,0) = xPopTaggedChar();
xPushPtr(stgCast(StgPtr,o));
IF_DEBUG(evaluator,
{
StgClosure* o;
SSS; o = (StgClosure*)grabHpNonUpd(Fzh_sizeW); LLL;
- SET_HDR(o,&Fzh_con_info,??);
+ SET_HDR(o,Fzh_con_info,??);
ASSIGN_FLT(&payloadWord(o,0),xPopTaggedFloat());
IF_DEBUG(evaluator,
fprintf(stderr,"\tBuilt ");
{
StgClosure* o;
SSS; o = (StgClosure*)grabHpNonUpd(Dzh_sizeW); LLL;
- SET_HDR(o,&Dzh_con_info,??);
+ SET_HDR(o,Dzh_con_info,??);
ASSIGN_DBL(&payloadWord(o,0),xPopTaggedDouble());
IF_DEBUG(evaluator,
fprintf(stderr,"\tBuilt ");
{
StgClosure* o;
SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL;
- SET_HDR(o,&StablePtr_con_info,??);
- payloadWord(o,0) = xPopTaggedStable();
+ SET_HDR(o,StablePtr_con_info,??);
+ payloadWord(o,0) = (W_)xPopTaggedStable();
IF_DEBUG(evaluator,
fprintf(stderr,"\tBuilt ");
SSS;
}
Case(i_PRIMOP2):
{
- /* Remember to save */
int i, trc, pc_saved;
void* p;
StgBCO* bco_tmp;
pc_saved = PC;
bco_tmp = bco;
SSS;
- p = enterBCO_primop2 ( i, &trc, &bco_tmp );
+ p = enterBCO_primop2 ( i, &trc, &bco_tmp, cap,
+ &hugsBlock );
LLL;
bco = bco_tmp;
bciPtr = &(bcoInstr(bco,pc_saved));
/* we want to enter p */
obj = p; goto enterLoop;
} else {
- /* p is the the StgThreadReturnCode for this thread */
- RETURN((StgThreadReturnCode)p);
+ /* trc is the the StgThreadReturnCode for
+ * this thread */
+ RETURN((StgThreadReturnCode)trc);
};
}
Continue;
Case(i_VAR_FLOAT_big):
Case(i_CONST_CHAR_big):
Case(i_VAR_CHAR_big):
- Case(i_CONST_ADDR_big):
Case(i_VAR_ADDR_big):
+ Case(i_VAR_STABLE_big):
Case(i_CONST_INTEGER_big):
- Case(i_CONST_INT_big):
Case(i_VAR_INT_big):
Case(i_VAR_WORD_big):
Case(i_RETADDR_big):
Case(i_ALLOC_PAP):
+#ifndef XMLAMBDA
+ Case(i_UNPACK_INJ):
+ Case(i_UNPACK_ROW):
+ Case(i_TEST_INJ_CONST):
+ Case(i_TEST_INJ_big):
+ Case(i_TEST_INJ):
+ Case(i_PACK_INJ_CONST):
+ Case(i_PACK_INJ_big):
+ Case(i_PACK_INJ):
+ Case(i_PACK_ROW_big):
+ Case(i_PACK_ROW):
+ Case(i_ALLOC_ROW_big):
+ Case(i_ALLOC_ROW):
+#endif
bciPtr--;
printf ( "\n\n" );
disInstr ( bco, PC );
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));
+ 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;
- }
- SSS; PUSH_UPD_FRAME(bh,0); LLL;
+
+ SSS; newCAF_made_by_Hugs(caf); LLL;
+
+ xPushUpdateFrame(bh,0);
xSp -= sizeofW(StgUpdateFrame);
- caf->link = enteredCAFs;
- enteredCAFs = caf;
obj = caf->body;
goto enterLoop;
}
case CAF_BLACKHOLE:
case SE_CAF_BLACKHOLE:
{
- /*was StgBlackHole* */
- StgBlockingQueue* bh = (StgBlockingQueue*)obj;
- /* Put ourselves on the blocking queue for this black hole and block */
- CurrentTSO->link = bh->blocking_queue;
- bh->blocking_queue = CurrentTSO;
- xPushCPtr(obj); /* code to restart with */
- barf("enter: CAF_BLACKHOLE unexpected!");
- RETURN(ThreadBlocked);
+ /* Let the scheduler figure out what to do :-) */
+ cap->rCurrentTSO->what_next = ThreadEnterGHC;
+ xPushCPtr(obj);
+ RETURN(ThreadYielding);
}
case AP_UPD:
{
}
/* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
and insert an indirection immediately */
- SSS; PUSH_UPD_FRAME(ap,0); LLL;
+ xPushUpdateFrame(ap,0);
xSp -= sizeofW(StgUpdateFrame);
while (--i >= 0) {
xPushWord(payloadWord(ap,i));
case CONSTR_CHARLIKE:
case CONSTR_STATIC:
case CONSTR_NOCAF_STATIC:
+#ifdef XMLAMBDA
+/* rows are mutarrays and should be treated as constructors. */
+ case MUT_ARR_PTRS_FROZEN:
+#endif
{
while (1) {
switch (get_itbl(stgCast(StgClosure*,xSp))->type) {
fprintf(stderr, "hit a STOP_FRAME\n");
printObj(obj);
fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
- printStack(xSp,CurrentTSO->stack+CurrentTSO->stack_size,xSu);
+ printStack(xSp,cap->rCurrentTSO->stack
+ + cap->rCurrentTSO->stack_size,xSu);
LLL;
);
+ cap->rCurrentTSO->what_next = ThreadComplete;
SSS; PopStopFrame(obj); LLL;
+ xPushPtr((P_)obj);
RETURN(ThreadFinished);
}
case RET_BCO:
case RET_VEC_SMALL:
case RET_BIG:
case RET_VEC_BIG:
- // barf("todo: RET_[VEC_]{BIG,SMALL}");
+ cap->rCurrentTSO->what_next = ThreadEnterGHC;
+ xPushCPtr(obj);
+ RETURN(ThreadYielding);
default:
belch("entered CONSTR with invalid continuation on stack");
IF_DEBUG(evaluator,
//fprintf(stderr, "entering unknown closure -- yielding to sched\n");
//printObj(obj);
//LLL;
- CurrentTSO->whatNext = ThreadEnterGHC;
+ cap->rCurrentTSO->what_next = ThreadEnterGHC;
xPushCPtr(obj); /* code to restart with */
RETURN(ThreadYielding);
}
}
barf("Ran off the end of enter - yoiks");
- assert(0);
+ ASSERT(0);
}
#undef RETURN
#undef xPushTaggedDouble
#undef xTaggedStackDouble
#undef xPopTaggedDouble
-
+#undef xPopUpdateFrame
+#undef xPushUpdateFrame
/* --------------------------------------------------------------------------
* ------------------------------------------------------------------------*/
static inline void PushTag ( StackTag t )
- { *(--Sp) = t; }
+ { *(--gSp) = t; }
inline void PushPtr ( StgPtr x )
- { *(--stgCast(StgPtr*,Sp)) = x; }
+ { *(--stgCast(StgPtr*,gSp)) = x; }
static inline void PushCPtr ( StgClosure* x )
- { *(--stgCast(StgClosure**,Sp)) = x; }
+ { *(--stgCast(StgClosure**,gSp)) = x; }
static inline void PushInt ( StgInt x )
- { *(--stgCast(StgInt*,Sp)) = x; }
+ { *(--stgCast(StgInt*,gSp)) = x; }
static inline void PushWord ( StgWord x )
- { *(--stgCast(StgWord*,Sp)) = x; }
+ { *(--stgCast(StgWord*,gSp)) = x; }
static inline void checkTag ( StackTag t1, StackTag t2 )
{ ASSERT(t1 == t2);}
static inline void PopTag ( StackTag t )
- { checkTag(t,*(Sp++)); }
+ { checkTag(t,*(gSp++)); }
inline StgPtr PopPtr ( void )
- { return *stgCast(StgPtr*,Sp)++; }
+ { return *stgCast(StgPtr*,gSp)++; }
static inline StgClosure* PopCPtr ( void )
- { return *stgCast(StgClosure**,Sp)++; }
+ { return *stgCast(StgClosure**,gSp)++; }
static inline StgInt PopInt ( void )
- { return *stgCast(StgInt*,Sp)++; }
+ { return *stgCast(StgInt*,gSp)++; }
static inline StgWord PopWord ( void )
- { return *stgCast(StgWord*,Sp)++; }
+ { return *stgCast(StgWord*,gSp)++; }
static inline StgPtr stackPtr ( StgStackOffset i )
- { return *stgCast(StgPtr*, Sp+i); }
+ { return *stgCast(StgPtr*, gSp+i); }
static inline StgInt stackInt ( StgStackOffset i )
- { return *stgCast(StgInt*, Sp+i); }
+ { return *stgCast(StgInt*, gSp+i); }
static inline StgWord stackWord ( StgStackOffset i )
- { return *stgCast(StgWord*,Sp+i); }
+ { return *stgCast(StgWord*,gSp+i); }
static inline void setStackWord ( StgStackOffset i, StgWord w )
- { Sp[i] = w; }
+ { gSp[i] = w; }
+
+#ifdef XMLAMBDA
+static inline void setStackPtr ( StgStackOffset i, StgPtr p )
+ { *(stgCast(StgPtr*, gSp+i)) = p; }
+#endif
static inline void PushTaggedRealWorld( void )
{ PushTag(REALWORLD_TAG); }
inline void PushTaggedInt ( StgInt x )
- { Sp -= sizeofW(StgInt); *Sp = x; PushTag(INT_TAG); }
+ { gSp -= sizeofW(StgInt); *gSp = x; PushTag(INT_TAG); }
inline void PushTaggedWord ( StgWord x )
- { Sp -= sizeofW(StgWord); *Sp = x; PushTag(WORD_TAG); }
+ { gSp -= sizeofW(StgWord); *gSp = x; PushTag(WORD_TAG); }
inline void PushTaggedAddr ( StgAddr x )
- { Sp -= sizeofW(StgAddr); *Sp = (W_)x; PushTag(ADDR_TAG); }
+ { gSp -= sizeofW(StgAddr); *gSp = (W_)x; PushTag(ADDR_TAG); }
inline void PushTaggedChar ( StgChar x )
- { Sp -= sizeofW(StgChar); *Sp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
+ { gSp -= sizeofW(StgChar); *gSp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
inline void PushTaggedFloat ( StgFloat x )
- { Sp -= sizeofW(StgFloat); ASSIGN_FLT(Sp,x); PushTag(FLOAT_TAG); }
+ { gSp -= sizeofW(StgFloat); ASSIGN_FLT(gSp,x); PushTag(FLOAT_TAG); }
inline void PushTaggedDouble ( StgDouble x )
- { Sp -= sizeofW(StgDouble); ASSIGN_DBL(Sp,x); PushTag(DOUBLE_TAG); }
+ { gSp -= sizeofW(StgDouble); ASSIGN_DBL(gSp,x); PushTag(DOUBLE_TAG); }
inline void PushTaggedStablePtr ( StgStablePtr x )
- { Sp -= sizeofW(StgStablePtr); *Sp = x; PushTag(STABLE_TAG); }
+ { gSp -= sizeofW(StgStablePtr); *gSp = (W_)x; PushTag(STABLE_TAG); }
static inline void PushTaggedBool ( int x )
{ PushTaggedInt(x); }
static inline void PopTaggedRealWorld ( void )
{ PopTag(REALWORLD_TAG); }
inline StgInt PopTaggedInt ( void )
- { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, Sp);
- Sp += sizeofW(StgInt); return r;}
+ { 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*, Sp);
- Sp += sizeofW(StgWord); return r;}
+ { 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*, Sp);
- Sp += sizeofW(StgAddr); return r;}
+ { 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, *Sp);
- Sp += sizeofW(StgChar); return r;}
+ { 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(Sp);
- Sp += sizeofW(StgFloat); return r;}
+ { 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(Sp);
- Sp += sizeofW(StgDouble); return r;}
+ { 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*, Sp);
- Sp += sizeofW(StgStablePtr); return r;}
+ { StgStablePtr r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, gSp);
+ gSp += sizeofW(StgStablePtr); return r;}
static inline StgInt taggedStackInt ( StgStackOffset i )
- { checkTag(INT_TAG,Sp[i]); return *stgCast(StgInt*, Sp+1+i); }
+ { checkTag(INT_TAG,gSp[i]); return *stgCast(StgInt*, gSp+1+i); }
static inline StgWord taggedStackWord ( StgStackOffset i )
- { checkTag(WORD_TAG,Sp[i]); return *stgCast(StgWord*, Sp+1+i); }
+ { checkTag(WORD_TAG,gSp[i]); return *stgCast(StgWord*, gSp+1+i); }
static inline StgAddr taggedStackAddr ( StgStackOffset i )
- { checkTag(ADDR_TAG,Sp[i]); return *stgCast(StgAddr*, Sp+1+i); }
+ { checkTag(ADDR_TAG,gSp[i]); return *stgCast(StgAddr*, gSp+1+i); }
static inline StgChar taggedStackChar ( StgStackOffset i )
- { checkTag(CHAR_TAG,Sp[i]); return stgCast(StgChar, *(Sp+1+i)) ; }
+ { checkTag(CHAR_TAG,gSp[i]); return stgCast(StgChar, *(gSp+1+i)) ; }
static inline StgFloat taggedStackFloat ( StgStackOffset i )
- { checkTag(FLOAT_TAG,Sp[i]); return PK_FLT(Sp+1+i); }
+ { checkTag(FLOAT_TAG,gSp[i]); return PK_FLT(gSp+1+i); }
static inline StgDouble taggedStackDouble ( StgStackOffset i )
- { checkTag(DOUBLE_TAG,Sp[i]); return PK_DBL(Sp+1+i); }
+ { checkTag(DOUBLE_TAG,gSp[i]); return PK_DBL(gSp+1+i); }
static inline StgStablePtr taggedStackStable ( StgStackOffset i )
- { checkTag(STABLE_TAG,Sp[i]); return *stgCast(StgStablePtr*, Sp+1+i); }
+ { checkTag(STABLE_TAG,gSp[i]); return *stgCast(StgStablePtr*, gSp+1+i); }
/* --------------------------------------------------------------------------
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);
}
* o Stop frames
* ------------------------------------------------------------------------*/
-static inline void PopUpdateFrame( StgClosure* obj )
+static inline void PopUpdateFrame ( StgClosure* obj )
{
- /* NB: doesn't assume that Sp == Su */
+ /* NB: doesn't assume that gSp == gSu */
IF_DEBUG(evaluator,
fprintf(stderr, "Updating ");
- printPtr(stgCast(StgPtr,Su->updatee));
+ printPtr(stgCast(StgPtr,gSu->updatee));
fprintf(stderr, " with ");
printObj(obj);
- fprintf(stderr,"Sp = %p\tSu = %p\n\n", Sp, Su);
+ 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(Su->updatee)->type == BLACKHOLE
- || get_itbl(Su->updatee)->type == SE_BLACKHOLE
- || get_itbl(Su->updatee)->type == CAF_BLACKHOLE
- || get_itbl(Su->updatee)->type == SE_CAF_BLACKHOLE
+ 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(Su->updatee,obj);
- Sp = stgCast(StgStackPtr,Su) + sizeofW(StgUpdateFrame);
- Su = Su->link;
+ UPD_IND(gSu->updatee,obj);
+ gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
+ gSu = gSu->link;
}
-static inline void PopStopFrame( StgClosure* obj )
+static inline void PopStopFrame ( StgClosure* obj )
{
- /* Move Su just off the end of the stack, we're about to spam the
+ /* Move gSu just off the end of the stack, we're about to gSpam the
* STOP_FRAME with the return value.
*/
- Su = stgCast(StgUpdateFrame*,Sp+1);
- *stgCast(StgClosure**,Sp) = obj;
+ gSu = stgCast(StgUpdateFrame*,gSp+1);
+ *stgCast(StgClosure**,gSp) = obj;
}
-static inline void PushCatchFrame( StgClosure* handler )
+static inline void PushCatchFrame ( StgClosure* handler )
{
StgCatchFrame* fp;
/* ToDo: stack check! */
- Sp -= sizeofW(StgCatchFrame);
- fp = stgCast(StgCatchFrame*,Sp);
+ gSp -= sizeofW(StgCatchFrame);
+ fp = stgCast(StgCatchFrame*,gSp);
SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS);
fp->handler = handler;
- fp->link = Su;
- Su = stgCast(StgUpdateFrame*,fp);
+ fp->link = gSu;
+ gSu = stgCast(StgUpdateFrame*,fp);
}
-static inline void PopCatchFrame( void )
+static inline void PopCatchFrame ( void )
{
- /* NB: doesn't assume that Sp == Su */
+ /* NB: doesn't assume that gSp == gSu */
/* fprintf(stderr,"Popping catch frame\n"); */
- Sp = stgCast(StgStackPtr,Su) + sizeofW(StgCatchFrame);
- Su = stgCast(StgCatchFrame*,Su)->link;
+ gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgCatchFrame);
+ gSu = stgCast(StgCatchFrame*,gSu)->link;
}
-static inline void PushSeqFrame( void )
+static inline void PushSeqFrame ( void )
{
StgSeqFrame* fp;
/* ToDo: stack check! */
- Sp -= sizeofW(StgSeqFrame);
- fp = stgCast(StgSeqFrame*,Sp);
+ gSp -= sizeofW(StgSeqFrame);
+ fp = stgCast(StgSeqFrame*,gSp);
SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS);
- fp->link = Su;
- Su = stgCast(StgUpdateFrame*,fp);
+ fp->link = gSu;
+ gSu = stgCast(StgUpdateFrame*,fp);
}
-static inline void PopSeqFrame( void )
+static inline void PopSeqFrame ( void )
{
- /* NB: doesn't assume that Sp == Su */
- Sp = stgCast(StgStackPtr,Su) + sizeofW(StgSeqFrame);
- Su = stgCast(StgSeqFrame*,Su)->link;
+ /* NB: doesn't assume that gSp == gSu */
+ gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgSeqFrame);
+ gSu = stgCast(StgSeqFrame*,gSu)->link;
}
-static inline StgClosure* raiseAnError( StgClosure* errObj )
+static inline StgClosure* raiseAnError ( StgClosure* exception )
{
- StgClosure *raise_closure;
-
- /* This closure represents the expression 'raise# E' where E
- * is the exception raised. It is used to overwrite all the
- * thunks which are currently under evaluataion.
+ /* 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.
*/
- raise_closure = (StgClosure *)allocate(sizeofW(StgClosure)+1);
- raise_closure->header.info = &raise_info;
- raise_closure->payload[0] = R1.cl;
-
+ HaskellObj primRaiseClosure
+ = getHugs_BCO_cptr_for("primRaise");
+ HaskellObj reraiseClosure
+ = rts_apply ( primRaiseClosure, exception );
+
while (1) {
- switch (get_itbl(Su)->type) {
+ switch (get_itbl(gSu)->type) {
case UPDATE_FRAME:
- UPD_IND(Su->updatee,raise_closure);
- Sp = stgCast(StgStackPtr,Su) + sizeofW(StgUpdateFrame);
- Su = Su->link;
+ 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*,Su);
+ StgCatchFrame* fp = stgCast(StgCatchFrame*,gSu);
StgClosure *handler = fp->handler;
- Su = fp->link;
- Sp += sizeofW(StgCatchFrame); /* Pop */
- PushCPtr(errObj);
+ gSu = fp->link;
+ gSp += sizeofW(StgCatchFrame); /* Pop */
+ PushCPtr(exception);
return handler;
}
case STOP_FRAME:
(thinks: probably not so, but anyway ...)
*/
HaskellObj error
- = asmClosureOfObject(getHugs_AsmObject_for("error"));
+ = getHugs_BCO_cptr_for("error");
HaskellObj unpack
- = asmClosureOfObject(getHugs_AsmObject_for("primUnpackString"));
+ = getHugs_BCO_cptr_for("hugsprimUnpackString");
HaskellObj thunk
= rts_apply ( unpack, rts_mkAddr ( (void*)msg ) );
thunk
}
-#ifdef STANDALONE_INTEGER
StgPtr CreateByteArrayToHoldInteger ( int nbytes )
{
- StgInt words = (nbytes+sizeof(W_)-1)/sizeof(W_);
+ 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(nbytes <= arr->words * sizeof(W_));
+ ASSERT((W_)nbytes <= arr->words * sizeof(W_));
#ifdef DEBUG
- {nat i;
+ {StgWord i;
for (i = 0; i < words; ++i) {
arr->payload[i] = 0xdeadbeef;
}}
SloppifyIntegerEnd(p); \
PushPtr(p); \
}
-#endif
}
-void myStackCheck ( void )
+__attribute__ ((unused))
+static void myStackCheck ( Capability* cap )
{
- //StgPtr sp = (StgPtr)Sp;
- StgPtr su = (StgPtr)Su;
- //fprintf(stderr, "myStackCheck\n");
- if (!(SpLim <= Sp && Sp <= stgCast(StgPtr,Su))) {
- fprintf(stderr, "myStackCheck: invalid initial Sp/Su \n" );
- assert(0);
+ /* fprintf(stderr, "myStackCheck\n"); */
+ if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) {
+ fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" );
+ barf("aborting");
+ ASSERT(0);
}
while (1) {
- if (!(su >= CurrentTSO->stack && su <= CurrentTSO->stack + CurrentTSO->stack_size)) {
- fprintf ( stderr, "myStackCheck: su out of stack\n" );
- assert(0);
+ if (!( (P_)gSu >= (P_)cap->rCurrentTSO->stack
+ &&
+ (P_)gSu <= (P_)(cap->rCurrentTSO->stack
+ + cap->rCurrentTSO->stack_size))) {
+ fprintf ( stderr, "myStackCheck: gSu out of stack\n" );
+ barf("aborting");
+ ASSERT(0);
}
- switch (get_itbl(stgCast(StgClosure*,su))->type) {
+ switch (get_itbl(stgCast(StgClosure*,gSu))->type) {
case CATCH_FRAME:
- su = (StgPtr) ((StgCatchFrame*)(su))->link;
+ gSu = (StgUpdateFrame*) ((StgCatchFrame*)(gSu))->link;
break;
case UPDATE_FRAME:
- su = (StgPtr) ((StgUpdateFrame*)(su))->link;
+ gSu = (StgUpdateFrame*) ((StgUpdateFrame*)(gSu))->link;
break;
case SEQ_FRAME:
- su = (StgPtr) ((StgSeqFrame*)(su))->link;
+ gSu = (StgUpdateFrame*) ((StgSeqFrame*)(gSu))->link;
break;
case STOP_FRAME:
goto postloop;
default:
- fprintf(stderr, "myStackCheck: invalid activation record\n"); assert(0);
+ fprintf(stderr, "myStackCheck: invalid activation record\n");
+ barf("aborting");
+ ASSERT(0);
}
}
postloop:
*/
static void* enterBCO_primop1 ( int primop1code )
{
+ if (combined)
+ barf("enterBCO_primop1 in combined mode");
+
switch (primop1code) {
case i_pushseqframe:
{
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_intToStable: OP_I_s((StgStablePtr)x); break;
+ case i_stableToInt: OP_s_I((W_)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_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
-#ifdef STANDALONE_INTEGER
case i_compareInteger:
{
B* x = IntegerInsideByteArray(PopPtr());
IntegerInsideByteArray(PopPtr())
));
break;
-#else
-#error Non-standalone integer not yet implemented
-#endif /* STANDALONE_INTEGER */
case i_gtFloat: OP_FF_B(x>y); break;
case i_geFloat: OP_FF_B(x>=y); break;
case i_tanhFloat: OP_F_F(tanh(x)); break;
case i_powerFloat: OP_FF_F(pow(x,y)); break;
-#ifdef STANDALONE_INTEGER
case i_encodeFloatZ:
{
StgPtr sig = PopPtr();
PushPtr(sig);
}
break;
-#else
-#error encode/decodeFloatZ not yet implemented for GHC ints
-#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_tanhDouble: OP_D_D(tanh(x)); break;
case i_powerDouble: OP_DD_D(pow(x,y)); break;
-#ifdef STANDALONE_INTEGER
case i_encodeDoubleZ:
{
StgPtr sig = PopPtr();
PushPtr(sig);
}
break;
-#else
-#error encode/decodeDoubleZ not yet implemented for GHC ints
-#endif
+
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;
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 )
+ 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));
}
+#ifdef XMLAMBDA
+/*------------------------------------------------------------------------
+ Insert and Remove primitives on Rows. This is important stuff for
+ XMlambda, these prims are called *all* the time. That's the reason
+ for all the specialized versions of the basic instructions.
+ note: A Gc might move rows around => allocate first, than pop the arguments.
+------------------------------------------------------------------------*/
+
+/*------------------------------------------------------------------------
+ i_rowInsertAt: insert an element into a row
+------------------------------------------------------------------------*/
+ case i_rowInsertAt:
+ {
+ StgWord j;
+ StgWord i;
+ StgWord n;
+ StgClosure* x;
+
+ /* allocate a new row before popping arguments */
+ StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0));
+ StgMutArrPtrs* newRow
+ = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + row->ptrs + 1));
+ SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
+
+ /* pop row again and pop index and value */
+ row = stgCast(StgMutArrPtrs*,PopPtr());
+ n = row->ptrs;
+ newRow->ptrs = n+1;
+
+ i = PopTaggedWord();
+ x = PopCPtr();
+
+ ASSERT(i <= n);
+
+ /* copy the fields, inserting the new value */
+ for (j = 0; j < i; j++) {
+ newRow->payload[j] = row->payload[j];
+ }
+ newRow->payload[i] = x;
+ for (j = i+1; j <= n; j++)
+ {
+ newRow->payload[j] = row->payload[j-1];
+ }
+
+ PushPtr(stgCast(StgPtr,newRow));
+ break;
+ }
+
+/*------------------------------------------------------------------------
+ i_rowChainInsert: behaves like a chain of [i_rowInsertAt] calls. This
+ instruction is vital for XMLambda since we would otherwise allocate
+ a lot of intermediate rows.
+ It assumes that the RTS has no NULL pointers.
+ It behaves 'optimal' if the witnesses are ordered, (lowest on the
+ bottom of the stack).
+------------------------------------------------------------------------*/
+#define ROW_HOLE 0
+ case i_rowChainInsert:
+ {
+ StgWord witness, topWitness;
+ StgClosure* value;
+ StgWord j;
+ StgWord i;
+
+ /* pop the number of arguments (=witness/value pairs) */
+ StgWord n = PopTaggedWord();
+
+ /* allocate a new row before popping boxed arguments */
+ StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0));
+ StgMutArrPtrs* newRow
+ = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n + row->ptrs));
+ SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
+
+ /* pop the row and assign again (it may have moved during gc!) */
+ row = stgCast(StgMutArrPtrs*,PopPtr());
+ newRow->ptrs = n + row->ptrs;
+
+ /* zero the fields */
+ for (i = 0; i < newRow->ptrs; i++)
+ {
+ newRow->payload[i] = ROW_HOLE;
+ }
+
+ /* insert all values */
+ topWitness = 0; /*invariant: 1 + maximal witness */
+ for (i = 0; i < n; i++)
+ {
+ witness = PopTaggedWord();
+ value = PopCPtr();
+ if (witness < topWitness)
+ {
+ /* shoot, unordered witnesses, we have to bump up everything */
+ for (j = topWitness; j > witness; j--)
+ {
+ newRow->payload[j] = newRow->payload[j-1];
+ }
+ topWitness += 1;
+ }
+ else
+ {
+ topWitness = witness+1;
+ }
+
+ ASSERT(topWitness <= n);
+ ASSERT(witness < n);
+ newRow->payload[witness] = value;
+ }
+
+ /* copy the values from the old row into the holes */
+ for (j =0, i = 0; i < row->ptrs; j++,i++)
+ {
+ while (newRow->payload[j] != ROW_HOLE) j++;
+ ASSERT(j < n);
+ newRow->payload[j] = row->payload[i];
+ }
+
+ /* push the result */
+ PushPtr(stgCast(StgPtr,newRow));
+ break;
+ }
+
+/*------------------------------------------------------------------------
+ i_rowChainBuild: exactly as [i_rowChainInsert] but builds a row from scratch.
+------------------------------------------------------------------------*/
+ case i_rowChainBuild:
+ {
+ StgWord witness, topWitness;
+ StgClosure* value;
+ StgWord j;
+ StgWord i;
+
+ /* pop the number of arguments (=witness/value pairs) */
+ StgWord n = PopTaggedWord();
+
+ /* allocate a new row before popping boxed arguments */
+ StgMutArrPtrs* newRow
+ = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n));
+ SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
+ newRow->ptrs = n;
+
+ /* insert all values */
+ topWitness = 0; /*invariant: 1 + maximal witness */
+ for (i = 0; i < n; i++)
+ {
+ witness = PopTaggedWord();
+ value = PopCPtr();
+ if (witness < topWitness)
+ {
+ /* shoot, unordered witnesses, we have to bump up everything */
+ for (j = topWitness; j > witness; j--)
+ {
+ newRow->payload[j] = newRow->payload[j-1];
+ }
+ topWitness += 1;
+ }
+ else
+ {
+ topWitness = witness+1;
+ }
+
+ ASSERT(topWitness <= n);
+ ASSERT(witness < n);
+ newRow->payload[witness] = value;
+ }
+
+ /* push the result */
+ PushPtr(stgCast(StgPtr,newRow));
+ break;
+ }
+
+/*------------------------------------------------------------------------
+ i_rowRemoveAt: remove an element from a row
+------------------------------------------------------------------------*/
+ case i_rowRemoveAt:
+ {
+ StgWord j;
+ StgWord i;
+ StgWord n;
+
+ /* allocate new row before popping the arguments */
+ StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0));
+ StgMutArrPtrs* newRow
+ = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + row->ptrs - 1));
+ SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
+
+ /* pop row again and pop the index */
+ row = stgCast(StgMutArrPtrs*,PopPtr());
+ n = row->ptrs;
+ newRow->ptrs = n-1;
+
+ i = PopTaggedWord();
+
+ ASSERT(i < n);
+
+ /* copy the fields, except for the removed value. */
+ for (j = 0; j < i; j++) {
+ newRow->payload[j] = row->payload[j];
+ }
+ for (j = i+1; j < n; j++)
+ {
+ newRow->payload[j-1] = row->payload[j];
+ }
+
+ PushCPtr(row->payload[i]);
+ PushPtr(stgCast(StgPtr,newRow));
+ break;
+ }
+
+/*------------------------------------------------------------------------
+ i_rowChainRemove: behaves like a chain of [i_rowRemoveAt] calls. Again,
+ this is a vital instruction to avoid lots of intermediate rows.
+ It behaves 'optimal' if the witnessses are ordered, lowest on the
+ bottom of the stack.
+ The implementation is quite dirty, blame Daan for this :-)
+ (It overwrites witnesses on the stack with results and marks pointers
+ using their lowest bit.)
+------------------------------------------------------------------------*/
+#define MARK(p) (stgCast(StgClosure*,(stgCast(StgWord,(p)) | 0x01)))
+#define UNMARK(p) (stgCast(StgClosure*,(stgCast(StgWord,(p)) & ~0x01)))
+#define ISMARKED(p) ((stgCast(StgWord,(p)) & 0x01) == 0x01)
+
+ case i_rowChainRemove:
+ {
+ const nat sizeofTaggedWord = sizeofW(StgWord) + sizeofW(StackTag);
+ StgWord i;
+ StgWord j;
+ StgWord minWitness;
+ nat base;
+ StgClosure* value;
+
+
+ /* pop number of arguments (=witnesses) */
+ StgWord n = PopTaggedWord();
+
+ /* allocate new row before popping boxed arguments */
+ StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0));
+ StgMutArrPtrs* newRow
+ = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + row->ptrs - n));
+ SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
+
+ /* pop row and assign again (gc might have moved it) */
+ row = stgCast(StgMutArrPtrs*,PopPtr());
+ newRow->ptrs = row->ptrs - n;
+ ASSERT( row->ptrs > n );
+
+ /* 'push' all elements that are removed */
+ base = n*sizeofTaggedWord;
+ minWitness = row->ptrs;
+ for (i = 1; i <= n; i++)
+ {
+ StgWord witness;
+
+ witness = taggedStackWord( base - i*sizeofTaggedWord );
+ if (witness >= minWitness)
+ {
+ /* shoot, unordered witnesses, we have to search for the value */
+ nat count;
+
+ count = witness - minWitness;
+ witness = minWitness;
+ while (1)
+ {
+ do{ witness++; } while (ISMARKED(row->payload[witness]));
+ if (count == 0) break;
+ count--;
+ }
+ }
+ else
+ {
+ minWitness = witness;
+ }
+ ASSERT( witness < row->ptrs );
+ ASSERT( !ISMARKED(row->payload[witness]) );
+
+ /* mark the element */
+ value = row->payload[witness];
+ row->payload[witness] = MARK(value);
+
+ /* set the value in the stack (overwriting old witnesses!) */
+ setStackPtr( base - i*sizeofW(StgPtr), stgCast(StgPtr,value) );
+ }
+
+ /* pop the garbage from the stack */
+ gSp = gSp + base - n*sizeofW(StgPtr);
+
+ /* copy all remaining elements and clear the marks */
+ for (j = 0, i = 0; i < newRow->ptrs; j++,i++)
+ {
+ while (ISMARKED(row->payload[j]))
+ {
+ row->payload[j] = UNMARK(row->payload[j]);
+ j++;
+ }
+ newRow->payload[i] = row->payload[j];
+ }
+
+ /* unmark tail */
+ while (j < row->ptrs)
+ {
+ value = row->payload[j];
+ if (ISMARKED(value)) row->payload[j] = UNMARK(value);
+ j++;
+ }
+
+#ifdef DEBUG
+ for (i = 0; i < row->ptrs; i++)
+ {
+ ASSERT(!ISMARKED(row->payload[i]));
+ }
+#endif
+
+ /* and push the result row */
+ PushPtr(stgCast(StgPtr,newRow));
+ break;
+ }
+
+/*------------------------------------------------------------------------
+ i_rowChainSelect: behaves exactly like [i_rowChainRemove] but doesn't return
+ the resulting row, only the removed elements.
+------------------------------------------------------------------------*/
+ case i_rowChainSelect:
+ {
+ const nat sizeofTaggedWord = sizeofW(StgWord) + sizeofW(StackTag);
+ StgWord i;
+ StgWord minWitness;
+ nat base;
+ StgClosure* value;
+
+ /* pop number of arguments (=witnesses) and row*/
+ StgWord n = PopTaggedWord();
+ StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,PopPtr());
+ ASSERT( row->ptrs > n );
+
+ /* 'push' all elements that are removed */
+ base = n*sizeofTaggedWord;
+ minWitness = row->ptrs;
+ for (i = 1; i <= n; i++)
+ {
+ StgWord witness;
+
+ witness = taggedStackWord( base - i*sizeofTaggedWord );
+ if (witness >= minWitness)
+ {
+ /* shoot, unordered witnesses, we have to search for the value */
+ nat count;
+
+ count = witness - minWitness;
+ witness = minWitness;
+ while (1)
+ {
+ do{ witness++; } while (ISMARKED(row->payload[witness]));
+ if (count == 0) break;
+ count--;
+ }
+ }
+ else
+ {
+ minWitness = witness;
+ }
+ ASSERT( witness < row->ptrs );
+ ASSERT( !ISMARKED(row->payload[witness]) );
+
+ /* mark the element */
+ value = row->payload[witness];
+ row->payload[witness] = MARK(value);
+
+ /* set the value in the stack (overwriting old witnesses!) */
+ setStackPtr( base - i*sizeofW(StgPtr), stgCast(StgPtr,value) );
+ }
+
+ /* pop the garbage from the stack */
+ gSp = gSp + base - n*sizeofW(StgPtr);
+
+ /* unmark elements */
+ for( i = 0; i < row->ptrs; i++)
+ {
+ value = row->payload[i];
+ if (ISMARKED(value)) row->payload[i] = UNMARK(value);
+ }
+
+#ifdef DEBUG
+ for (i = 0; i < row->ptrs; i++)
+ {
+ ASSERT(!ISMARKED(row->payload[i]));
+ }
+#endif
+ break;
+ }
+
+#endif /* XMLAMBDA */
case i_newRef:
{
#endif
#ifdef PROVIDE_FOREIGN
/* ForeignObj# operations */
- case i_makeForeignObj:
+ case i_mkForeignObj:
{
StgForeignObj *result
= stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
{
StgStablePtr stableptr = PopTaggedStablePtr();
StgAddr typestr = PopTaggedAddr();
- StgAddr adj_thunk = createAdjThunk(stableptr,typestr);
+ StgChar callconv = PopTaggedChar();
+ StgAddr adj_thunk = createAdjThunk(stableptr,typestr,callconv);
PushTaggedAddr(adj_thunk);
break;
}
-#ifdef PROVIDE_CONCURRENT
- case i_fork:
+ case i_getArgc:
{
- 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;
+ StgInt n = prog_argc;
+ PushTaggedInt(n);
break;
}
- case i_killThread:
+ case i_getArgv:
{
- StgTSO* tso = stgCast(StgTSO*,PopPtr());
- deleteThread(tso);
- if (tso == CurrentTSO) { /* suicide */
- *return2 = ThreadFinished;
- return (void*)(1+(NULL));
- }
- break;
- }
- case i_sameMVar:
- { /* identical to i_sameRef */
- StgPtr x = PopPtr();
- StgPtr y = PopPtr();
- PushTaggedBool(x==y);
+ 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 = EndTSOQueue;
- /* ToDo: this is a little strange */
+ mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
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;
+ 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 = CurrentTSO;
+ mvar->tail->link = cap->rCurrentTSO;
}
- 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!
- */
-
- PopPtr();
- PopPtr();
- PushCPtr(obj);
+ 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+(NULL));
+ return (void*)(1+(char*)(NULL));
} else {
PushCPtr(mvar->value);
+ mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
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) {
- return (raisePrim("putMVar {full MVar}"));
+ 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.
*/
- 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;
- }
+
+ 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;
}
- /* yield for better communication performance */
+ break;
+ }
+ case i_sameMVar:
+ { /* identical to i_sameRef */
+ StgMVar* x = (StgMVar*)PopPtr();
+ StgMVar* y = (StgMVar*)PopPtr();
+ PushTaggedBool(x==y);
+ break;
+ }
+#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;
}
+
+ case i_killThread:
+ {
+ 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+(char*)(NULL));
+ }
+ break;
+ }
+ case i_raiseInThread:
+ barf("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:
- /* As PrimOps.h says: Hmm, I'll think about these later. */
- ASSERT(0);
+ {
+ 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.
+ */
+ context_switch = 1;
+ break;
+ }
+ case i_getThreadId:
+ {
+ StgWord tid = cap->rCurrentTSO->id;
+ PushTaggedWord(tid);
+ break;
+ }
+ case i_cmpThreadIds:
+ {
+ StgWord tid1 = PopTaggedWord();
+ StgWord tid2 = PopTaggedWord();
+ if (tid1 < tid2) PushTaggedInt(-1);
+ else if (tid1 > tid2) PushTaggedInt(1);
+ else PushTaggedInt(0);
break;
+ }
#endif /* PROVIDE_CONCURRENT */
- case i_ccall_Id:
- case i_ccall_IO:
+#ifdef XMLAMBDA
+ case i_ccall:
+ {
+ CallInfo callInfo;
+ CFunDescriptor descriptor;
+ void (*funPtr)(void);
+
+ StgWord offset = PopTaggedWord(); /* offset into bco nonptr section */
+ funPtr = PopTaggedAddr();
+
+ ASSERT(funPtr != NULL);
+
+ /* copy the complete callinfo, the bco might move during GC! */
+ callInfo = *stgCast(CallInfo*, (*bco)->payload + (*bco)->n_ptrs + offset);
+
+ /* copy info to a CFunDescriptor. just for compatibility. */
+ descriptor.num_args = callInfo.argCount;
+ descriptor.arg_tys = callInfo.data;
+ descriptor.num_results = callInfo.resultCount;
+ descriptor.result_tys = callInfo.data + callInfo.argCount + 1;
+
+ /* call out */
+ switch (ccall( &descriptor, funPtr, bco, callInfo.callConv, cap ))
+ {
+ case 0: break;
+ case 1: barf( "unhandled type or too many args/results in ccall"); break;
+ case 2: barf("ccall not configured correctly for this platform"); break;
+ default: barf("unknown return code from ccall"); break;
+ }
+
+ break;
+ }
+#endif
+
+ case i_ccall_ccall_Id:
+ case i_ccall_ccall_IO:
+ case i_ccall_stdcall_Id:
+ case i_ccall_stdcall_IO:
{
int r;
- CFunDescriptor* descriptor = PopTaggedAddr();
- void (*funPtr)(void) = PopTaggedAddr();
- r = ccall(descriptor,funPtr,bco);
+ 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(
* 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 TODO_STANDALONE_INTEGER
+#if 0
case INTEGER_REP:
PushTaggedInteger(*((mpz_ptr*)arg));
return ARG_SIZE(INTEGER_TAG);
}
/* 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 TODO_STANDALONE_INTEGER
+#if 0
case INTEGER_REP:
*((mpz_ptr*)res) = PopTaggedInteger();
return ARG_SIZE(INTEGER_TAG);
case INT_REP:
sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
break;
-#ifdef TODO_STANDALONE_INTEGER
+#if 0
case INTEGER_REP:
sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
break;
* (ghc/rts/StgPrimFloat.c)
* ---------------------------------------------------------------------------*/
-#ifdef STANDALONE_INTEGER
-
#if IEEE_FLOATING_POINT
#define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
/* DMINEXP is defined in values.h on Linux (for example) */
}
#endif /* FLOATS_AS_DOUBLES */
-
-#endif /* STANDALONE_INTEGER */
-
#endif /* INTERPRETER */
projects / ghc-hetmet.git / blobdiff