X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FEvaluator.c;h=d03f683f36cacbda746305e71507b3d948dae75b;hb=0b0cebed71c317fe5e14d9cf3de2bd0948e244e3;hp=4aa5dcf57a057496e732879b8af05b3130760efd;hpb=8ad8c309e8d8e70811415574b43fae6bce396054;p=ghc-hetmet.git diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c index 4aa5dcf..d03f683 100644 --- a/ghc/rts/Evaluator.c +++ b/ghc/rts/Evaluator.c @@ -5,8 +5,8 @@ * Copyright (c) 1994-1998. * * $RCSfile: Evaluator.c,v $ - * $Revision: 1.45 $ - * $Date: 2000/03/20 15:49:56 $ + * $Revision: 1.56 $ + * $Date: 2000/06/23 12:09:00 $ * ---------------------------------------------------------------------------*/ #include "Rts.h" @@ -71,167 +71,9 @@ /* 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; +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 /* -------------------------------------------------------------------------- @@ -418,7 +260,7 @@ void SloppifyIntegerEnd ( StgPtr ); { \ 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; \ @@ -491,10 +333,12 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) enterLoop: + 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++; @@ -530,8 +374,8 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) cap->rCurrentTSO->why_blocked = BlockedOnDelay; ACQUIRE_LOCK(&sched_mutex); -#if defined(HAVE_SETITIMER) - 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 @@ -588,11 +432,6 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) RETURN(HeapOverflow); } -# if CRUDE_PROFILING - cp_enter ( bco ); -# endif - - bciPtr = &(bcoInstr(bco,0)); LoopTopLabel @@ -611,10 +450,6 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) LLL; ); -# if CRUDE_PROFILING - SSS; cp_bill_insns(1); LLL; -# endif - Dispatch Case(i_INTERNAL_ERROR): @@ -688,8 +523,12 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) 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); @@ -746,6 +585,29 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) xPushPtr(p); Continue; } +#ifdef XMLAMBDA + /* allocate rows, implemented on top of Arrays */ + Case(i_ALLOC_ROW): + { + StgMutArrPtrs* p; + int 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; + int 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; + } +#endif Case(i_MKAP): { int x = BCO_INSTR_8; /* ToDo: Word not Int! */ @@ -849,6 +711,112 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) ); Continue; } +#ifdef XMLAMBDA + /* pack values into a row. */ + Case(i_PACK_ROW): + { + int offset = BCO_INSTR_8; + StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(offset)); + StgWord n = p->ptrs; + nat i; + + for (i=0; ipayload[i] = xPopCPtr(); + } + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + SSS; + printObj(stgCast(StgClosure*,p)); + LLL; + ); + Continue; + } + Case(i_PACK_ROW_big): + { + int offset = BCO_INSTR_16; + StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(offset)); + StgWord n = p->ptrs; + nat i; + + for (i=0; ipayload[i] = xPopCPtr(); + } + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + SSS; + printObj(stgCast(StgClosure*,p)); + LLL; + ); + Continue; + } + /* pack values into an Inj */ + Case(i_PACK_INJ): + { + const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgInt)); + int offset = BCO_INSTR_8; + + StgClosure* o; + SSS; o = (StgClosure*)grabHpNonUpd(size); LLL; + SET_HDR(o,Inj_con_info,??); + + payloadWord(o,sizeofW(StgPtr)) = xTaggedStackInt(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_big): + { + const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgInt)); + int offset = BCO_INSTR_16; + + StgClosure* o; + SSS; o = (StgClosure*)grabHpNonUpd(size); LLL; + SET_HDR(o,Inj_con_info,??); + + payloadWord(o,sizeofW(StgPtr)) = xTaggedStackInt(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): + { + const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgInt)); + int index = BCO_INSTR_8; + + StgClosure* o; + SSS; o = (StgClosure*)grabHpNonUpd(size); LLL; + SET_HDR(o,Inj_con_info,??); + + payloadWord(o,sizeofW(StgPtr)) = index; + payloadPtr(o,0) = xPopPtr(); + + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + SSS; + printObj(stgCast(StgClosure*,o)); + LLL; + ); + xPushPtr(stgCast(StgPtr,o)); + Continue; + } + +#endif /* XMLAMBDA */ Case(i_SLIDE): { int x = BCO_INSTR_8; @@ -894,6 +862,45 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) } Continue; } +#ifdef XMLAMBDA + /* Test Inj indices. */ + Case(i_TEST_INJ): + { + int offset = BCO_INSTR_8; + StgWord jump = BCO_INSTR_16; + + int index = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) ); + if (index != xTaggedStackInt(offset) ) + { + bciPtr += jump; + } + Continue; + } + Case(i_TEST_INJ_big): + { + int offset = BCO_INSTR_16; + StgWord jump = BCO_INSTR_16; + + int index = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) ); + if (index != xTaggedStackInt(offset) ) + { + bciPtr += jump; + } + Continue; + } + Case(i_TEST_INJ_CONST): + { + int value = BCO_INSTR_8; + StgWord jump = BCO_INSTR_16; + + int index = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) ); + if (index != value ) + { + bciPtr += jump; + } + Continue; + } +#endif /* XMLAMBDA */ Case(i_UNPACK): { StgClosure* o = stgCast(StgClosure*,xStackPtr(0)); @@ -913,6 +920,29 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) } Continue; } +#ifdef XMLAMBDA + /* extract all fields of a row */ + Case(i_UNPACK_ROW): + { + StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(0)); + int i = p->ptrs; + while (--i >= 0) + { + xPushCPtr(p->payload[i]); + } + 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; + } +#endif /* XMLAMBA */ Case(i_VAR_big): { int n = BCO_INSTR_16; @@ -1191,7 +1221,7 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) StgClosure* o; SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL; SET_HDR(o,StablePtr_con_info,??); - payloadWord(o,0) = xPopTaggedStable(); + payloadWord(o,0) = (W_)xPopTaggedStable(); IF_DEBUG(evaluator, fprintf(stderr,"\tBuilt "); SSS; @@ -1327,6 +1357,20 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) Case(i_VAR_WORD_big): Case(i_RETADDR_big): Case(i_ALLOC_PAP): + + 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): + bciPtr--; printf ( "\n\n" ); disInstr ( bco, PC ); @@ -1356,22 +1400,19 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) 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; newCAF_made_by_Hugs(caf); LLL; + xPushUpdateFrame(bh,0); xSp -= sizeofW(StgUpdateFrame); - caf->link = enteredCAFs; - enteredCAFs = caf; obj = caf->body; goto enterLoop; } @@ -1455,6 +1496,10 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) 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) { @@ -1479,7 +1524,9 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) + cap->rCurrentTSO->stack_size,xSu); LLL; ); + cap->rCurrentTSO->what_next = ThreadComplete; SSS; PopStopFrame(obj); LLL; + xPushPtr((P_)obj); RETURN(ThreadFinished); } case RET_BCO: @@ -1525,7 +1572,7 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) } } barf("Ran off the end of enter - yoiks"); - assert(0); + ASSERT(0); } #undef RETURN @@ -1608,6 +1655,11 @@ static inline StgWord stackWord ( StgStackOffset i ) 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 ) @@ -1623,7 +1675,7 @@ static inline void PushTaggedRealWorld( void ) 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); } + { gSp -= sizeofW(StgStablePtr); *gSp = (W_)x; PushTag(STABLE_TAG); } static inline void PushTaggedBool ( int x ) { PushTaggedInt(x); } @@ -1650,7 +1702,7 @@ static inline void PopTaggedRealWorld ( 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); + { StgStablePtr r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, gSp); gSp += sizeofW(StgStablePtr); return r;} @@ -1686,18 +1738,12 @@ static inline StgStablePtr taggedStackStable ( StgStackOffset 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); } @@ -1788,7 +1834,7 @@ static inline StgClosure* raiseAnError ( StgClosure* exception ) * thunks which are currently under evaluation. */ HaskellObj primRaiseClosure - = asmClosureOfObject(getHugs_AsmObject_for("primRaise")); + = getHugs_BCO_cptr_for("primRaise"); HaskellObj reraiseClosure = rts_apply ( primRaiseClosure, exception ); @@ -1829,9 +1875,9 @@ static StgClosure* makeErrorCall ( const char* msg ) (thinks: probably not so, but anyway ...) */ HaskellObj error - = asmClosureOfObject(getHugs_AsmObject_for("error")); + = getHugs_BCO_cptr_for("error"); HaskellObj unpack - = asmClosureOfObject(getHugs_AsmObject_for("hugsprimUnpackString")); + = getHugs_BCO_cptr_for("hugsprimUnpackString"); HaskellObj thunk = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) ); thunk @@ -2261,12 +2307,14 @@ void SloppifyIntegerEnd ( StgPtr arr0 ) } +__attribute__ ((unused)) 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); + barf("aborting"); + ASSERT(0); } while (1) { if (!( (P_)gSu >= (P_)cap->rCurrentTSO->stack @@ -2274,7 +2322,8 @@ static void myStackCheck ( Capability* cap ) (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: @@ -2289,7 +2338,9 @@ static void myStackCheck ( Capability* cap ) 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: @@ -2450,8 +2501,8 @@ static void* enterBCO_primop1 ( int primop1code ) 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; @@ -2712,6 +2763,71 @@ static void* enterBCO_primop2 ( int primop2code, StgClosure* err = PopCPtr(); return (raiseAnError(err)); } +#ifdef XMLAMBDA +/*------------------------------------------------------------------------ + Insert and Remove primitives on Rows +------------------------------------------------------------------------*/ + case i_rowInsertAt: + { + nat j; + /* get: row, index and value */ + StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,PopPtr()); + nat i = PopTaggedInt(); + StgClosure* x = PopCPtr(); + + /* allocate new row */ + StgWord n = row->ptrs; + StgMutArrPtrs* newRow + = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n + 1)); + SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS); + newRow->ptrs = n+1; + + 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; + } + + case i_rowRemoveAt: + { + nat j; + /* get row and index */ + StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,PopPtr()); + nat i = PopTaggedInt(); /* or Word?? */ + + /* allocate new row */ + StgWord n = row->ptrs; + StgMutArrPtrs* newRow + = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n - 1)); + SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS); + newRow->ptrs = n-1; + + 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; + } +#endif /* XMLAMBDA */ case i_newRef: { @@ -2892,7 +3008,7 @@ static void* enterBCO_primop2 ( int primop2code, #endif #ifdef PROVIDE_FOREIGN /* ForeignObj# operations */ - case i_makeForeignObj: + case i_mkForeignObj: { StgForeignObj *result = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj))); @@ -3101,11 +3217,12 @@ static void* enterBCO_primop2 ( int primop2code, deleteThread(tso); if (tso == cap->rCurrentTSO) { /* suicide */ *return2 = ThreadFinished; - return (void*)(1+(NULL)); + return (void*)(1+(char*)(NULL)); } break; } case i_raiseInThread: + barf("raiseInThread"); ASSERT(0); /* not (yet) supported */ case i_delay: { @@ -3521,5 +3638,4 @@ void B__decodeFloat (B* man, I_* exp, StgFloat flt) } #endif /* FLOATS_AS_DOUBLES */ - #endif /* INTERPRETER */