/* -----------------------------------------------------------------------------
* Bytecode evaluator
*
- * Copyright (c) 1994-1998.
+ * Copyright (c) 1994-2000.
*
* $RCSfile: Evaluator.c,v $
- * $Revision: 1.51 $
- * $Date: 2000/05/09 10:00:36 $
+ * $Revision: 1.59 $
+ * $Date: 2000/11/07 13:30:41 $
* ---------------------------------------------------------------------------*/
#include "Rts.h"
extern void* /* StgClosure* */ getHugs_BCO_cptr_for ( char* s );
extern int /* Bool */ combined;
-/* --------------------------------------------------------------------------
- * 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;
-}
-
-
-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
/* --------------------------------------------------------------------------
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
SSS; \
cap->rCurrentTSO->sp = gSp; \
cap->rCurrentTSO->su = gSu; \
- cap->rCurrentTSO->splim = gSpLim; \
return retVal; \
}
{ \
StgUpdateFrame *__frame; \
__frame = (StgUpdateFrame *)(xSp + (xSp_offset)) - 1; \
- SET_INFO(__frame, (StgInfoTable *)&Upd_frame_info); \
+ SET_INFO(__frame, (StgInfoTable *)&upd_frame_info); \
__frame->link = xSu; \
__frame->updatee = (StgClosure *)(target); \
xSu = __frame; \
gSp = cap->rCurrentTSO->sp;
gSu = cap->rCurrentTSO->su;
- gSpLim = cap->rCurrentTSO->splim;
+ gSpLim = cap->rCurrentTSO->stack + RESERVED_STACK_WORDS;
#ifdef DEBUG
/* use the t values to check that Su/Sp/SpLim do not change unexpectedly */
numEnters++;
#ifdef DEBUG
- assert(gSp == tSp);
- assert(gSu == tSu);
- assert(gSpLim == tSpLim);
+ ASSERT(gSp == tSp);
+ ASSERT(gSu == tSu);
+ ASSERT(gSpLim == tSpLim);
IF_DEBUG(evaluator,
SSS;
enterCountI++;
cap->rCurrentTSO->why_blocked = BlockedOnDelay;
ACQUIRE_LOCK(&sched_mutex);
-#if defined(HAVE_SETITIMER) || defined(mingw32_TARGET_OS)
- cap->rCurrentTSO->block_info.delay
+#if defined(HAVE_SETITIMER) /* || defined(mingw32_TARGET_OS) */
+ cap->rCurrentTSO->block_info.delay
= hugsBlock.delay + ticks_since_select;
#else
cap->rCurrentTSO->block_info.target
RETURN(HeapOverflow);
}
-# if CRUDE_PROFILING
- cp_enter ( bco );
-# endif
-
-
bciPtr = &(bcoInstr(bco,0));
LoopTopLabel
LLL;
);
-# if CRUDE_PROFILING
- SSS; cp_bill_insns(1); LLL;
-# endif
-
Dispatch
Case(i_INTERNAL_ERROR):
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;
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;
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 );
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) {
}
}
barf("Ran off the end of enter - yoiks");
- assert(0);
+ ASSERT(0);
}
#undef RETURN
static inline void setStackWord ( StgStackOffset i, StgWord w )
{ gSp[i] = w; }
+#ifdef XMLAMBDA
+static inline void setStackPtr ( StgStackOffset i, StgPtr p )
+ { *(stgCast(StgPtr*, gSp+i)) = p; }
+#endif
+
static inline void PushTaggedRealWorld( void )
{ PushTag(REALWORLD_TAG); }
inline void PushTaggedInt ( StgInt x )
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);
}
/* fprintf(stderr, "myStackCheck\n"); */
if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) {
fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" );
- assert(0);
+ barf("aborting");
+ ASSERT(0);
}
while (1) {
if (!( (P_)gSu >= (P_)cap->rCurrentTSO->stack
(P_)gSu <= (P_)(cap->rCurrentTSO->stack
+ cap->rCurrentTSO->stack_size))) {
fprintf ( stderr, "myStackCheck: gSu out of stack\n" );
- assert(0);
+ barf("aborting");
+ ASSERT(0);
}
switch (get_itbl(stgCast(StgClosure*,gSu))->type) {
case CATCH_FRAME:
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:
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:
{
break;
}
case i_raiseInThread:
+ barf("raiseInThread");
ASSERT(0); /* not (yet) supported */
case i_delay:
{
break;
}
#endif /* PROVIDE_CONCURRENT */
+#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:
-#if ! FLOATS_AS_DOUBLES
StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */
{
StgFloat r;
return r;
}
-#endif /* FLOATS_AS_DOUBLES */
}
-#if ! FLOATS_AS_DOUBLES
void B__decodeFloat (B* man, I_* exp, StgFloat flt)
{
/* Do some bit fiddling on IEEE */
do_renormalise(man);
}
-#endif /* FLOATS_AS_DOUBLES */
#endif /* INTERPRETER */
projects / ghc-hetmet.git / blobdiff