X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FEvaluator.c;h=566666f16cd4b694da4c19dd712e0bab033c87d8;hb=8d2d17b9bcd6b6dc130ff6a34c177a9971f59435;hp=b72ec980c6575de09cd1880c62aa642c20ca7564;hpb=0600f5d1cf4882ba6292ea5382e695270b1a6ba1;p=ghc-hetmet.git diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c index b72ec98..566666f 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.19 $ - * $Date: 1999/10/19 11:01:26 $ + * $Revision: 1.52 $ + * $Date: 2000/05/10 09:00:20 $ * ---------------------------------------------------------------------------*/ #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,167 +71,10 @@ /* 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 - /* -------------------------------------------------------------------------- * Hugs Hooks - a bit of a hack @@ -255,35 +100,12 @@ void setRtsFlags( int x ) } } -/* -------------------------------------------------------------------------- - * 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 @@ -313,22 +135,20 @@ void defaultsHook (void) /* 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 StgAddr createAdjThunkARCH ( StgStablePtr stableptr, - StgAddr typestr ); +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 @@ -338,24 +158,31 @@ StgPtr CreateByteArrayToHoldInteger ( int ); 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; \ + cap->rCurrentTSO->splim = gSpLim; \ + return retVal; \ } @@ -367,7 +194,7 @@ void SloppifyIntegerEnd ( StgPtr ); 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++)) @@ -429,6 +256,16 @@ void SloppifyIntegerEnd ( StgPtr ); 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 */ \ @@ -452,7 +289,12 @@ void SloppifyIntegerEnd ( StgPtr ); #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. @@ -462,15 +304,22 @@ StgThreadReturnCode enter( StgClosure* obj0 ) register StgPtr xSpLim; /* local state -- stack lim pointer */ register StgClosure* obj; /* object currently under evaluation */ char eCount; /* enter counter, for context switching */ - StgBCO** bco_SAVED; + + + 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->splim; + #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; @@ -484,10 +333,12 @@ StgThreadReturnCode enter( StgClosure* 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++; @@ -497,7 +348,7 @@ StgThreadReturnCode enter( StgClosure* obj0 ) 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; ); @@ -505,12 +356,41 @@ StgThreadReturnCode enter( StgClosure* obj0 ) 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"); + } } } @@ -545,8 +425,6 @@ StgThreadReturnCode enter( StgClosure* obj0 ) register StgBCO* bco = (StgBCO*)obj; StgWord wantToGC; - bco_SAVED = bco; - /* Don't need to SSS ... LLL around doYouWantToGC */ wantToGC = doYouWantToGC(); if (wantToGC) { @@ -554,16 +432,11 @@ StgThreadReturnCode enter( StgClosure* obj0 ) 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; @@ -571,16 +444,12 @@ StgThreadReturnCode enter( StgClosure* obj0 ) 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): @@ -596,6 +465,15 @@ StgThreadReturnCode enter( StgClosure* obj0 ) } 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; @@ -645,8 +523,12 @@ StgThreadReturnCode enter( 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); @@ -693,6 +575,16 @@ StgThreadReturnCode enter( 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; + } Case(i_MKAP): { int x = BCO_INSTR_8; /* ToDo: Word not Int! */ @@ -761,7 +653,7 @@ StgThreadReturnCode enter( 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; @@ -783,7 +675,7 @@ StgThreadReturnCode enter( 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; @@ -836,7 +728,7 @@ StgThreadReturnCode enter( 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; @@ -856,7 +748,7 @@ StgThreadReturnCode enter( StgClosure* obj0 ) || itbl->type == CONSTR_0_2 ); while (--i>=0) { - xPushCPtr(payloadCPtr(o,i)); + xPushCPtr(o->payload[i]); } Continue; } @@ -900,11 +792,17 @@ StgThreadReturnCode enter( 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 "); @@ -961,7 +859,7 @@ StgThreadReturnCode enter( 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 "); @@ -990,11 +888,17 @@ StgThreadReturnCode enter( 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 "); @@ -1027,7 +931,7 @@ StgThreadReturnCode enter( 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, @@ -1060,7 +964,7 @@ StgThreadReturnCode enter( 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 "); @@ -1099,7 +1003,7 @@ StgThreadReturnCode enter( 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 "); @@ -1125,8 +1029,8 @@ StgThreadReturnCode enter( 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; @@ -1154,7 +1058,6 @@ StgThreadReturnCode enter( StgClosure* obj0 ) } Case(i_PRIMOP2): { - /* Remember to save */ int i, trc, pc_saved; void* p; StgBCO* bco_tmp; @@ -1163,7 +1066,8 @@ StgThreadReturnCode enter( StgClosure* obj0 ) 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)); @@ -1172,8 +1076,9 @@ StgThreadReturnCode enter( StgClosure* obj0 ) /* 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; @@ -1254,10 +1159,9 @@ StgThreadReturnCode enter( 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): @@ -1291,22 +1195,19 @@ StgThreadReturnCode enter( 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; 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; } @@ -1321,14 +1222,10 @@ StgThreadReturnCode enter( StgClosure* obj0 ) 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: { @@ -1340,7 +1237,7 @@ StgThreadReturnCode enter( StgClosure* obj0 ) } /* 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)); @@ -1414,10 +1311,13 @@ StgThreadReturnCode enter( StgClosure* obj0 ) 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: @@ -1436,7 +1336,9 @@ StgThreadReturnCode enter( 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, @@ -1455,7 +1357,7 @@ StgThreadReturnCode enter( StgClosure* obj0 ) //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); } @@ -1501,7 +1403,8 @@ StgThreadReturnCode enter( StgClosure* obj0 ) #undef xPushTaggedDouble #undef xTaggedStackDouble #undef xPopTaggedDouble - +#undef xPopUpdateFrame +#undef xPushUpdateFrame /* -------------------------------------------------------------------------- @@ -1509,56 +1412,56 @@ StgThreadReturnCode enter( StgClosure* obj0 ) * ------------------------------------------------------------------------*/ 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; } static inline void PushTaggedRealWorld( void ) { PushTag(REALWORLD_TAG); } inline void PushTaggedInt ( StgInt x ) - { Sp -= sizeofW(StgInt); *Sp = x; PushTag(INT_TAG); } -static inline void PushTaggedWord ( StgWord x ) - { Sp -= sizeofW(StgWord); *Sp = x; PushTag(WORD_TAG); } + { gSp -= sizeofW(StgInt); *gSp = x; PushTag(INT_TAG); } + inline void PushTaggedWord ( StgWord x ) + { gSp -= sizeofW(StgWord); *gSp = x; PushTag(WORD_TAG); } inline void PushTaggedAddr ( StgAddr x ) - { 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); } -static inline void PushTaggedStablePtr ( StgStablePtr x ) - { Sp -= sizeofW(StgStablePtr); *Sp = x; PushTag(STABLE_TAG); } + { gSp -= sizeofW(StgDouble); ASSIGN_DBL(gSp,x); PushTag(DOUBLE_TAG); } + inline void PushTaggedStablePtr ( StgStablePtr x ) + { gSp -= sizeofW(StgStablePtr); *gSp = (W_)x; PushTag(STABLE_TAG); } static inline void PushTaggedBool ( int x ) { PushTaggedInt(x); } @@ -1567,43 +1470,43 @@ static inline void PushTaggedBool ( int 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;} -static inline StgWord PopTaggedWord ( void ) - { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, Sp); - Sp += sizeofW(StgWord); 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*, 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;} -static inline StgStablePtr PopTaggedStablePtr ( void ) - { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, Sp); - Sp += sizeofW(StgStablePtr); return r;} + { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(gSp); + gSp += sizeofW(StgDouble); return r;} + inline StgStablePtr PopTaggedStablePtr ( void ) + { 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); } /* -------------------------------------------------------------------------- @@ -1621,18 +1524,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); } @@ -1644,106 +1541,106 @@ static inline StgPtr grabHpNonUpd( nat 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); - SET_HDR(fp,&catch_frame_info,CCCS); + 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); - SET_HDR(fp,&seq_frame_info,CCCS); - fp->link = Su; - Su = stgCast(StgUpdateFrame*,fp); + gSp -= sizeofW(StgSeqFrame); + fp = stgCast(StgSeqFrame*,gSp); + SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS); + fp->link = gSu; + gSu = stgCast(StgUpdateFrame*,fp); } -static inline void PopSeqFrame( void ) +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: @@ -1764,9 +1661,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 @@ -2100,17 +1997,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; }} @@ -2142,7 +2038,7 @@ void SloppifyIntegerEnd ( StgPtr arr0 ) do_renormalise(b); ASSERT(is_sane(b)); arr->words -= nwunused; - slop = &(arr->payload[arr->words]); + slop = (StgArrWords*)&(arr->payload[arr->words]); SET_HDR(slop,&ARR_WORDS_info,CCCS); slop->words = nwunused - sizeofW(StgArrWords); ASSERT( &(slop->payload[slop->words]) == @@ -2169,7 +2065,6 @@ void SloppifyIntegerEnd ( StgPtr arr0 ) SloppifyIntegerEnd(p); \ PushPtr(p); \ } -#endif @@ -2198,29 +2093,31 @@ void SloppifyIntegerEnd ( StgPtr arr0 ) } -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" ); + /* fprintf(stderr, "myStackCheck\n"); */ + if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) { + fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" ); assert(0); } while (1) { - if (!(su >= CurrentTSO->stack && su <= CurrentTSO->stack + CurrentTSO->stack_size)) { - fprintf ( stderr, "myStackCheck: su out of stack\n" ); + if (!( (P_)gSu >= (P_)cap->rCurrentTSO->stack + && + (P_)gSu <= (P_)(cap->rCurrentTSO->stack + + cap->rCurrentTSO->stack_size))) { + fprintf ( stderr, "myStackCheck: gSu out of stack\n" ); assert(0); } - switch (get_itbl(stgCast(StgClosure*,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; @@ -2241,6 +2138,9 @@ void myStackCheck ( void ) */ static void* enterBCO_primop1 ( int primop1code ) { + if (combined) + barf("enterBCO_primop1 in combined mode"); + switch (primop1code) { case i_pushseqframe: { @@ -2383,8 +2283,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; @@ -2410,7 +2310,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()); @@ -2475,9 +2374,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; @@ -2518,7 +2414,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(); @@ -2538,9 +2433,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; @@ -2586,7 +2479,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(); @@ -2606,9 +2498,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; @@ -2631,11 +2521,24 @@ 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 ) + 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} */ { @@ -2822,7 +2725,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))); @@ -2888,166 +2791,219 @@ static void* enterBCO_primop2 ( int primop2code, { StgStablePtr stableptr = PopTaggedStablePtr(); StgAddr typestr = PopTaggedAddr(); - StgAddr adj_thunk = createAdjThunkARCH(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: + 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: + + 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( @@ -3067,11 +3023,11 @@ off the stack. * 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) @@ -3080,7 +3036,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); @@ -3123,7 +3079,7 @@ nat marshall(char arg_ty, void* arg) } /* 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) @@ -3132,7 +3088,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); @@ -3183,7 +3139,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; @@ -3228,8 +3184,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) */ @@ -3400,161 +3354,4 @@ void B__decodeFloat (B* man, I_* exp, StgFloat flt) } #endif /* FLOATS_AS_DOUBLES */ - -#endif /* STANDALONE_INTEGER */ - - - -/* ----------------------------------------------------------------------------- - * Support for foreign export dynamic. - * ---------------------------------------------------------------------------*/ - -static -int unpackArgsAndCallHaskell_x86 ( StgStablePtr stableptr, - char* tydesc, char* args) -{ - HaskellObj node; - HaskellObj nodeOut; - SchedulerStatus sstat; - - char* resp = tydesc; - char* argp = tydesc; - - /* - fprintf ( stderr, - "unpackArgsAndCallHaskell_x86: args=0x%x tydesc=%s stableptr=0x%x\n", - (unsigned int)args, tydesc, stableptr ); - */ - - node = deRefStablePtr(stableptr); - - if (*argp != ':') argp++; - ASSERT( *argp == ':' ); - argp++; - while (*argp) { - switch (*argp) { - case CHAR_REP: - node = rts_apply ( node, rts_mkChar ( *(char*)args ) ); - /* fprintf(stderr, "char `%c' ", *(char*)args ); */ - args += 4; - break; - case INT_REP: - node = rts_apply ( node, rts_mkInt ( *(int*)args ) ); - /* fprintf(stderr, "int %d ", *(int*)args ); */ - args += 4; - break; - case FLOAT_REP: - node = rts_apply ( node, rts_mkFloat ( *(float*)args ) ); - /* fprintf(stderr, "float %f ", *(float*)args ); */ - args += 4; - break; - case DOUBLE_REP: - node = rts_apply ( node, rts_mkDouble ( *(double*)args ) ); - /* fprintf(stderr, "double %f ", *(double*)args ); */ - args += 8; - break; - case WORD_REP: - case ADDR_REP: - default: - internal( - "unpackArgsAndCallHaskell_x86: unexpected arg type rep"); - } - argp++; - } - fprintf ( stderr, "\n" ); - node = rts_apply ( - asmClosureOfObject(getHugs_AsmObject_for("primRunST")), - node ); - - sstat = rts_eval ( node, &nodeOut ); - if (sstat != Success) - internal ("unpackArgsAndCallHaskell_x86: evalIO failed"); - - switch (*resp) { - case ':': return 0; - case CHAR_REP: return rts_getChar(nodeOut); - case INT_REP: return rts_getInt(nodeOut); - //case FLOAT_REP: return rts_getFloat(nodeOut); - //case DOUBLE_REP: return rts_getDouble(nodeOut); - case WORD_REP: - case ADDR_REP: - default: - internal( - "unpackArgsAndCallHaskell_x86: unexpected res type rep"); - } -} - -static -StgAddr createAdjThunk_x86 ( StgStablePtr stableptr, - StgAddr typestr ) -{ - unsigned char* codeblock; - unsigned char* cp; - unsigned int ts = (unsigned int)typestr; - unsigned int sp = (unsigned int)stableptr; - unsigned int ch = (unsigned int)&unpackArgsAndCallHaskell_x86; - - /* fprintf ( stderr, "createAdjThunk_x86: %s 0x%x\n", (char*)typestr, sp ); */ - codeblock = malloc ( 1 + 0x22 ); - if (!codeblock) { - fprintf ( stderr, - "createAdjThunk_x86 (foreign export dynamic):\n" - "\tfatal: can't alloc mem\n" ); - exit(1); - } - cp = codeblock; - /* Generate the following: - 9 0000 53 pushl %ebx - 10 0001 51 pushl %ecx - 11 0002 56 pushl %esi - 12 0003 57 pushl %edi - 13 0004 55 pushl %ebp - 14 0005 89E0 movl %esp,%eax # sp -> eax - 15 0007 83C018 addl $24,%eax # move eax back over 5 saved regs + retaddr - 16 000a 50 pushl %eax # push arg-block addr - 17 000b 6844332211 pushl $0x11223344 # push addr of type descr string - 18 0010 6877665544 pushl $0x44556677 # push stableptr to closure - 19 0015 E8BBAA9988 call 0x8899aabb # SEE COMMENT BELOW - 20 001a 83C40C addl $12,%esp # pop 3 args - 21 001d 5D popl %ebp - 22 001e 5F popl %edi - 23 001f 5E popl %esi - 24 0020 59 popl %ecx - 25 0021 5B popl %ebx - 26 0022 C3 ret - */ - *cp++ = 0x53; - *cp++ = 0x51; - *cp++ = 0x56; - *cp++ = 0x57; - *cp++ = 0x55; - *cp++ = 0x89; *cp++ = 0xE0; - *cp++ = 0x83; *cp++ = 0xC0; *cp++ = 0x18; - *cp++ = 0x50; - *cp++ = 0x68; *cp++=ts;ts>>=8; *cp++=ts;ts>>=8; *cp++=ts;ts>>=8; *cp++=ts; - *cp++ = 0x68; *cp++=sp;sp>>=8; *cp++=sp;sp>>=8; *cp++=sp;sp>>=8; *cp++=sp; - - /* call address needs to be: displacement relative to next insn */ - ch = ch - ( ((unsigned int)cp) + 5); - *cp++ = 0xE8; *cp++=ch;ch>>=8; *cp++=ch;ch>>=8; *cp++=ch;ch>>=8; *cp++=ch; - - *cp++ = 0x83; *cp++ = 0xC4; *cp++ = 0x0C; - *cp++ = 0x5D; - *cp++ = 0x5F; - *cp++ = 0x5E; - *cp++ = 0x59; - *cp++ = 0x5B; - *cp++ = 0xC3; - - return codeblock; -} - - -static -StgAddr createAdjThunkARCH ( StgStablePtr stableptr, - StgAddr typestr ) -{ - return createAdjThunk_x86 ( stableptr, typestr ); -} - #endif /* INTERPRETER */