X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FEvaluator.c;h=d03f683f36cacbda746305e71507b3d948dae75b;hb=fd23905bf703daa9df3a0d6858d32aa737b0516b;hp=681cb6b0f31b1b6613e222dc7ac347a6156e1abb;hpb=b3c8ae4e104c93354738d3992fcf0e60e9646490;p=ghc-hetmet.git diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c index 681cb6b..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.30 $ - * $Date: 1999/11/29 18:59:42 $ + * $Revision: 1.56 $ + * $Date: 2000/06/23 12:09:00 $ * ---------------------------------------------------------------------------*/ #include "Rts.h" @@ -23,7 +23,10 @@ #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" @@ -39,11 +42,10 @@ #include /* 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 @@ -69,166 +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 ); - - -/* -------------------------------------------------------------------------- - * 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++; - } - +extern void* /* StgClosure* */ getHugs_BCO_cptr_for ( char* s ); +extern int /* Bool */ combined; -} - -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 /* -------------------------------------------------------------------------- @@ -256,6 +101,12 @@ void setRtsFlags( int x ) } +typedef struct { + StgTSOBlockReason reason; + unsigned int delay; +} HugsBlock; + + /* -------------------------------------------------------------------------- * Entering-objects and bytecode interpreter part of evaluator * ------------------------------------------------------------------------*/ @@ -285,7 +136,7 @@ void setRtsFlags( int x ) /* Forward decls ... */ static void* enterBCO_primop1 ( int ); static void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */, - StgBCO**, Capability* ); + StgBCO**, Capability*, HugsBlock * ); static inline void PopUpdateFrame ( StgClosure* obj ); static inline void PopCatchFrame ( void ); static inline void PopSeqFrame ( void ); @@ -298,7 +149,6 @@ 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 @@ -308,7 +158,6 @@ StgPtr CreateByteArrayToHoldInteger ( int ); B* IntegerInsideByteArray ( StgPtr ); void SloppifyIntegerEnd ( StgPtr ); #endif -#endif @@ -411,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; \ @@ -456,6 +305,10 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) register StgClosure* obj; /* object currently under evaluation */ char eCount; /* enter counter, for context switching */ + + HugsBlock hugsBlock = { NotBlocked, 0 }; + + #ifdef DEBUG StgPtr tSp; StgUpdateFrame* tSu; StgPtr tSpLim; #endif @@ -480,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++; @@ -507,8 +362,35 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) #endif ) { 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"); + } } } @@ -550,11 +432,6 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) RETURN(HeapOverflow); } -# if CRUDE_PROFILING - cp_enter ( bco ); -# endif - - bciPtr = &(bcoInstr(bco,0)); LoopTopLabel @@ -573,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): @@ -650,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); @@ -698,6 +575,39 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) 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; + } +#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! */ @@ -766,7 +676,7 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) 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; @@ -788,7 +698,7 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) 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; @@ -801,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; @@ -841,11 +857,50 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) { 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; } +#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)); @@ -861,10 +916,33 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) || itbl->type == CONSTR_0_2 ); while (--i>=0) { - xPushCPtr(payloadCPtr(o,i)); + xPushCPtr(o->payload[i]); + } + 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; @@ -905,11 +983,17 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) 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 "); @@ -966,7 +1050,7 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) { 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 "); @@ -995,11 +1079,17 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) 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 "); @@ -1032,7 +1122,7 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) { 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, @@ -1065,7 +1155,7 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) { 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 "); @@ -1104,7 +1194,7 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) { 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 "); @@ -1130,8 +1220,8 @@ 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(); + SET_HDR(o,StablePtr_con_info,??); + payloadWord(o,0) = (W_)xPopTaggedStable(); IF_DEBUG(evaluator, fprintf(stderr,"\tBuilt "); SSS; @@ -1167,7 +1257,8 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) pc_saved = PC; bco_tmp = bco; SSS; - p = enterBCO_primop2 ( i, &trc, &bco_tmp, cap ); + p = enterBCO_primop2 ( i, &trc, &bco_tmp, cap, + &hugsBlock ); LLL; bco = bco_tmp; bciPtr = &(bcoInstr(bco,pc_saved)); @@ -1176,8 +1267,9 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) /* we want to enter p */ obj = p; goto enterLoop; } else { - /* trc is the the StgThreadReturnCode for this thread */ - RETURN((StgThreadReturnCode)trc); + /* trc is the the StgThreadReturnCode for + * this thread */ + RETURN((StgThreadReturnCode)trc); }; } Continue; @@ -1258,15 +1350,27 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) 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): + + 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 ); @@ -1296,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; } @@ -1327,7 +1428,7 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) case SE_CAF_BLACKHOLE: { /* Let the scheduler figure out what to do :-) */ - cap->rCurrentTSO->whatNext = ThreadEnterGHC; + cap->rCurrentTSO->what_next = ThreadEnterGHC; xPushCPtr(obj); RETURN(ThreadYielding); } @@ -1395,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) { @@ -1419,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: @@ -1438,7 +1545,9 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) 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, @@ -1457,13 +1566,13 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) //fprintf(stderr, "entering unknown closure -- yielding to sched\n"); //printObj(obj); //LLL; - cap->rCurrentTSO->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 @@ -1546,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 ) @@ -1561,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); } @@ -1588,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;} @@ -1624,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); } @@ -1726,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 ); @@ -1767,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("primUnpackString")); + = getHugs_BCO_cptr_for("hugsprimUnpackString"); HaskellObj thunk = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) ); thunk @@ -2103,17 +2211,16 @@ static StgClosure* makeErrorCall ( const char* msg ) } -#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; }} @@ -2172,7 +2279,6 @@ void SloppifyIntegerEnd ( StgPtr arr0 ) SloppifyIntegerEnd(p); \ PushPtr(p); \ } -#endif @@ -2201,34 +2307,40 @@ void SloppifyIntegerEnd ( StgPtr arr0 ) } -void myStackCheck ( Capability* cap ) +__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 (!(gSu >= cap->rCurrentTSO->stack - && gSu <= cap->rCurrentTSO->stack - + cap->rCurrentTSO->stack_size)) { + 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: - gSu = (StgPtr) ((StgCatchFrame*)(gSu))->link; + gSu = (StgUpdateFrame*) ((StgCatchFrame*)(gSu))->link; break; case UPDATE_FRAME: - gSu = (StgPtr) ((StgUpdateFrame*)(gSu))->link; + gSu = (StgUpdateFrame*) ((StgUpdateFrame*)(gSu))->link; break; case SEQ_FRAME: - gSu = (StgPtr) ((StgSeqFrame*)(gSu))->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: @@ -2244,6 +2356,9 @@ void myStackCheck ( Capability* cap ) */ static void* enterBCO_primop1 ( int primop1code ) { + if (combined) + barf("enterBCO_primop1 in combined mode"); + switch (primop1code) { case i_pushseqframe: { @@ -2386,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; @@ -2413,7 +2528,6 @@ static void* enterBCO_primop1 ( int primop1code ) 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()); @@ -2478,9 +2592,6 @@ static void* enterBCO_primop1 ( int primop1code ) 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; @@ -2521,7 +2632,6 @@ static void* enterBCO_primop1 ( int primop1code ) 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(); @@ -2541,9 +2651,7 @@ static void* enterBCO_primop1 ( int primop1code ) 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; @@ -2589,7 +2697,6 @@ static void* enterBCO_primop1 ( int primop1code ) 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(); @@ -2609,9 +2716,7 @@ static void* enterBCO_primop1 ( int primop1code ) 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; @@ -2634,18 +2739,95 @@ static void* enterBCO_primop1 ( int primop1code ) return the address of it and leave *return2 unchanged. To return a StgThreadReturnCode to the scheduler, set *return2 to it and return a non-NULL value. + To cause a context switch, set context_switch (its a global), + and optionally set hugsBlock to your rational. */ static void* enterBCO_primop2 ( int primop2code, int* /*StgThreadReturnCode* */ return2, StgBCO** bco, - Capability* cap ) + 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 +------------------------------------------------------------------------*/ + 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: { @@ -2826,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))); @@ -2950,7 +3132,7 @@ static void* enterBCO_primop2 ( int primop2code, */ PushCPtr((StgClosure*)(*bco)); *return2 = ThreadBlocked; - return (void*)(1+(NULL)); + return (void*)(1+(char*)(NULL)); } else { PushCPtr(mvar->value); @@ -2996,21 +3178,7 @@ static void* enterBCO_primop2 ( int primop2code, PushTaggedBool(x==y); 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; - } +#ifdef PROVIDE_CONCURRENT case i_forkIO: { StgClosure* closure; @@ -3021,36 +3189,88 @@ static void* enterBCO_primop2 ( int primop2code, tid = tso->id; scheduleThread(tso); context_switch = 1; + /* Later: Change to use tso as the ThreadId */ PushTaggedWord(tid); break; } -#ifdef PROVIDE_CONCURRENT case i_killThread: { - StgTSO* tso = stgCast(StgTSO*,PopPtr()); + StgWord n = PopTaggedWord(); + StgTSO* tso = 0; + StgTSO *t; + + // Map from ThreadId to Thread Structure */ + for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) { + if (n == t->id) + tso = t; + } + if (tso == 0) { + // Already dead + break; + } + + while (tso->what_next == ThreadRelocated) { + tso = tso->link; + } + deleteThread(tso); if (tso == cap->rCurrentTSO) { /* suicide */ *return2 = ThreadFinished; - return (void*)(1+(NULL)); + return (void*)(1+(char*)(NULL)); } 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 -#endif + 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_ccall_Id: @@ -3100,7 +3320,7 @@ 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); @@ -3152,7 +3372,7 @@ 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); @@ -3203,7 +3423,7 @@ nat argSize( const char* ks ) 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; @@ -3248,8 +3468,6 @@ nat argSize( const char* ks ) * (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) */ @@ -3420,7 +3638,4 @@ void B__decodeFloat (B* man, I_* exp, StgFloat flt) } #endif /* FLOATS_AS_DOUBLES */ - -#endif /* STANDALONE_INTEGER */ - #endif /* INTERPRETER */