X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FEvaluator.c;h=03a154813b75f482f8f8e3638de7ffb56b229228;hb=34a98f40dea6d31ced5213b7810dc39b4989c395;hp=0624184eaa3eb2be15982da703a8cf98cbeaa967;hpb=d37986fe8eef5554e6dbd6dbe83db0cce9f62280;p=ghc-hetmet.git diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c index 0624184..03a1548 100644 --- a/ghc/rts/Evaluator.c +++ b/ghc/rts/Evaluator.c @@ -2,11 +2,11 @@ /* ----------------------------------------------------------------------------- * Bytecode evaluator * - * Copyright (c) 1994-1998. + * Copyright (c) 1994-2000. * * $RCSfile: Evaluator.c,v $ - * $Revision: 1.41 $ - * $Date: 2000/03/17 13:30:23 $ + * $Revision: 1.59 $ + * $Date: 2000/11/07 13:30:41 $ * ---------------------------------------------------------------------------*/ #include "Rts.h" @@ -24,6 +24,7 @@ #include "ForeignCall.h" #include "PrimOps.h" /* for __{encode,decode}{Float,Double} */ #include "Prelude.h" +#include "Itimer.h" #include "Evaluator.h" #include "sainteger.h" @@ -42,6 +43,9 @@ #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 @@ -67,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 ); -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 /* -------------------------------------------------------------------------- @@ -254,6 +101,12 @@ void setRtsFlags( int x ) } +typedef struct { + StgTSOBlockReason reason; + unsigned int delay; +} HugsBlock; + + /* -------------------------------------------------------------------------- * Entering-objects and bytecode interpreter part of evaluator * ------------------------------------------------------------------------*/ @@ -283,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,13 +151,11 @@ static int enterCountI = 0; StgDouble B__encodeDouble (B* s, I_ e); void B__decodeDouble (B* man, I_* exp, StgDouble dbl); -#if ! FLOATS_AS_DOUBLES StgFloat B__encodeFloat (B* s, I_ e); void B__decodeFloat (B* man, I_* exp, StgFloat flt); StgPtr CreateByteArrayToHoldInteger ( int ); B* IntegerInsideByteArray ( StgPtr ); void SloppifyIntegerEnd ( StgPtr ); -#endif @@ -328,7 +179,6 @@ void SloppifyIntegerEnd ( StgPtr ); SSS; \ cap->rCurrentTSO->sp = gSp; \ cap->rCurrentTSO->su = gSu; \ - cap->rCurrentTSO->splim = gSpLim; \ return retVal; \ } @@ -407,7 +257,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; \ @@ -452,13 +302,17 @@ 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 gSp = cap->rCurrentTSO->sp; gSu = cap->rCurrentTSO->su; - gSpLim = cap->rCurrentTSO->splim; + gSpLim = cap->rCurrentTSO->stack + RESERVED_STACK_WORDS; #ifdef DEBUG /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */ @@ -476,10 +330,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++; @@ -503,8 +359,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"); + } } } @@ -546,11 +429,6 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) RETURN(HeapOverflow); } -# if CRUDE_PROFILING - cp_enter ( bco ); -# endif - - bciPtr = &(bcoInstr(bco,0)); LoopTopLabel @@ -569,10 +447,6 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) LLL; ); -# if CRUDE_PROFILING - SSS; cp_bill_insns(1); LLL; -# endif - Dispatch Case(i_INTERNAL_ERROR): @@ -646,8 +520,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); @@ -772,7 +650,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; @@ -794,7 +672,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; @@ -867,7 +745,7 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) || itbl->type == CONSTR_0_2 ); while (--i>=0) { - xPushCPtr(payloadCPtr(o,i)); + xPushCPtr(o->payload[i]); } Continue; } @@ -895,6 +773,306 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,n))); Continue; } +#ifdef XMLAMBDA + /* allocate rows, implemented on top of (frozen) Arrays */ + Case(i_ALLOC_ROW): + { + StgMutArrPtrs* p; + StgWord n = BCO_INSTR_8; + SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + n)); LLL; + SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS); + p->ptrs = n; + xPushPtr(p); + Continue; + } + Case(i_ALLOC_ROW_big): + { + StgMutArrPtrs* p; + StgWord n = BCO_INSTR_16; + SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + n)); LLL; + SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS); + p->ptrs = n; + xPushPtr(p); + Continue; + } + + /* pack values into a row. */ + Case(i_PACK_ROW): + { + StgWord offset = BCO_INSTR_8; + StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(offset)); + StgWord n = p->ptrs; + StgWord i; + + for (i=0; ipayload[i] = xPopCPtr(); + } + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + SSS; + printObj(stgCast(StgClosure*,p)); + LLL; + ); + Continue; + } + Case(i_PACK_ROW_big): + { + StgWord offset = BCO_INSTR_16; + StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(offset)); + StgWord n = p->ptrs; + StgWord i; + + for (i=0; ipayload[i] = xPopCPtr(); + } + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + SSS; + printObj(stgCast(StgClosure*,p)); + LLL; + ); + Continue; + } + + /* extract all fields of a row */ + Case(i_UNPACK_ROW): + { + StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(0)); + nat i = p->ptrs; + while (i > 0) + { + i--; + xPushCPtr(p->payload[i]); + } + Continue; + } + + /* Trivial row (unit) */ + Case(i_CONST_ROW_TRIV): + { + StgMutArrPtrs* p; + SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + 0)); LLL; + SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS); + p->ptrs = 0; + xPushPtr(p); + Continue; + } + + /* pack values into an Inj */ + Case(i_PACK_INJ_VAR): + { + const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord)); + StgWord offset = BCO_INSTR_8; + + StgClosure* o; + SSS; o = (StgClosure*)grabHpNonUpd(size); LLL; + SET_HDR(o,Inj_con_info,??); + + payloadWord(o,sizeofW(StgPtr)) = xTaggedStackWord(offset); + payloadPtr(o,0) = xPopPtr(); + + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + SSS; + printObj(stgCast(StgClosure*,o)); + LLL; + ); + xPushPtr(stgCast(StgPtr,o)); + Continue; + } + Case(i_PACK_INJ_VAR_big): + { + const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord)); + StgWord offset = BCO_INSTR_16; + + StgClosure* o; + SSS; o = (StgClosure*)grabHpNonUpd(size); LLL; + SET_HDR(o,Inj_con_info,??); + + payloadWord(o,sizeofW(StgPtr)) = xTaggedStackWord(offset); + payloadPtr(o,0) = xPopPtr(); + + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + SSS; + printObj(stgCast(StgClosure*,o)); + LLL; + ); + xPushPtr(stgCast(StgPtr,o)); + Continue; + } + Case(i_PACK_INJ_CONST_8): + { + const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord)); + StgWord witness = BCO_INSTR_8; + + StgClosure* o; + SSS; o = (StgClosure*)grabHpNonUpd(size); LLL; + SET_HDR(o,Inj_con_info,??); + + payloadWord(o,sizeofW(StgPtr)) = witness; + payloadPtr(o,0) = xPopPtr(); + + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + SSS; + printObj(stgCast(StgClosure*,o)); + LLL; + ); + xPushPtr(stgCast(StgPtr,o)); + Continue; + } + Case(i_PACK_INJ_REL_8): + { + const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord)); + StgWord offset = BCO_INSTR_8; + StgWord cwitness = BCO_INSTR_8; + + StgClosure* o; + SSS; o = (StgClosure*)grabHpNonUpd(size); LLL; + SET_HDR(o,Inj_con_info,??); + + payloadWord(o,sizeofW(StgPtr)) = xTaggedStackWord(offset) + cwitness; + payloadPtr(o,0) = xPopPtr(); + + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + SSS; + printObj(stgCast(StgClosure*,o)); + LLL; + ); + xPushPtr(stgCast(StgPtr,o)); + Continue; + } + Case(i_PACK_INJ): + { + const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord)); + + StgClosure* o; + SSS; o = (StgClosure*)grabHpNonUpd(size); LLL; + SET_HDR(o,Inj_con_info,??); + + payloadWord(o,sizeofW(StgPtr)) = xPopTaggedWord(); + payloadPtr(o,0) = xPopPtr(); + + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + SSS; + printObj(stgCast(StgClosure*,o)); + LLL; + ); + xPushPtr(stgCast(StgPtr,o)); + Continue; + } + + /* Test Inj witnesses. */ + Case(i_TEST_INJ_VAR): + { + StgWord offset = BCO_INSTR_8; + StgWord jump = BCO_INSTR_16; + + StgWord index = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) ); + if (index != xTaggedStackWord(offset) ) + { + bciPtr += jump; + } + Continue; + } + Case(i_TEST_INJ_VAR_big): + { + StgWord offset = BCO_INSTR_16; + StgWord jump = BCO_INSTR_16; + + StgWord index = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) ); + if (index != xTaggedStackWord(offset) ) + { + bciPtr += jump; + } + Continue; + } + Case(i_TEST_INJ_CONST_8): + { + StgWord cwitness = BCO_INSTR_8; + StgWord jump = BCO_INSTR_16; + + StgWord witness = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) ); + if (witness != cwitness ) + { + bciPtr += jump; + } + Continue; + } + Case(i_TEST_INJ_REL_8): + { + StgWord offset = BCO_INSTR_8; + StgWord cwitness = BCO_INSTR_8; + StgWord jump = BCO_INSTR_16; + + StgWord witness = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) ); + if (witness != xTaggedStackWord(offset) + cwitness ) + { + bciPtr += jump; + } + Continue; + } + Case(i_TEST_INJ): + { + StgWord jump = BCO_INSTR_16; + StgWord cwitness = xPopTaggedWord(); + + StgWord witness = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) ); + if (witness != cwitness ) + { + bciPtr += jump; + } + Continue; + } + + /* extract the value of an INJ */ + Case(i_UNPACK_INJ): + { + StgClosure* con = stgCast(StgClosure*,xStackPtr(0)); + + ASSERT(get_itbl(con) == Inj_con_info); + + xPushPtr(payloadPtr(con,0)); + Continue; + } + + /* optimized witness (word) operations */ + Case(i_CONST_WORD_8): + { + xPushTaggedWord(BCO_INSTR_8); + Continue; + } + Case(i_ADD_WORD_VAR): + { + StgWord offset = BCO_INSTR_8; + StgWord witness = xTaggedStackWord(offset); + witness += xPopTaggedWord(); + xPushTaggedWord(witness); + Continue; + } + Case(i_ADD_WORD_VAR_big): + { + StgWord offset = BCO_INSTR_16; + StgWord witness = xTaggedStackWord(offset); + witness += xPopTaggedWord(); + xPushTaggedWord(witness); + Continue; + } + Case(i_ADD_WORD_VAR_8): + { + StgWord offset = BCO_INSTR_8; + StgWord inc = BCO_INSTR_8; + StgWord witness = xTaggedStackWord(offset); + xPushTaggedWord(witness + inc); + Continue; + } +#endif /* XMLAMBA */ + Case(i_VOID): { SSS; PushTaggedRealWorld(); LLL; @@ -974,6 +1152,12 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) xPushTaggedWord(bcoConstWord(bco,BCO_INSTR_8)); Continue; } + Case(i_CONST_WORD_big): + { + StgWord n = BCO_INSTR_16; + xPushTaggedWord(bcoConstWord(bco,n)); + Continue; + } Case(i_PACK_WORD): { StgClosure* o; @@ -1149,7 +1333,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; @@ -1185,7 +1369,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)); @@ -1194,8 +1379,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; @@ -1283,6 +1469,20 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) Case(i_VAR_WORD_big): Case(i_RETADDR_big): Case(i_ALLOC_PAP): +#ifndef XMLAMBDA + Case(i_UNPACK_INJ): + Case(i_UNPACK_ROW): + Case(i_TEST_INJ_CONST): + Case(i_TEST_INJ_big): + Case(i_TEST_INJ): + Case(i_PACK_INJ_CONST): + Case(i_PACK_INJ_big): + Case(i_PACK_INJ): + Case(i_PACK_ROW_big): + Case(i_PACK_ROW): + Case(i_ALLOC_ROW_big): + Case(i_ALLOC_ROW): +#endif bciPtr--; printf ( "\n\n" ); disInstr ( bco, PC ); @@ -1312,22 +1512,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; } @@ -1411,6 +1608,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) { @@ -1435,7 +1636,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: @@ -1481,7 +1684,7 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) } } barf("Ran off the end of enter - yoiks"); - assert(0); + ASSERT(0); } #undef RETURN @@ -1564,6 +1767,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 ) @@ -1579,7 +1787,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); } @@ -1606,7 +1814,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;} @@ -1642,18 +1850,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); } @@ -1744,7 +1946,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 ); @@ -1785,9 +1987,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 @@ -2217,12 +2419,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 @@ -2230,7 +2434,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: @@ -2245,7 +2450,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: @@ -2406,8 +2613,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; @@ -2644,11 +2851,14 @@ 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, @@ -2665,6 +2875,396 @@ static void* enterBCO_primop2 ( int primop2code, StgClosure* err = PopCPtr(); return (raiseAnError(err)); } +#ifdef XMLAMBDA +/*------------------------------------------------------------------------ + Insert and Remove primitives on Rows. This is important stuff for + XMlambda, these prims are called *all* the time. That's the reason + for all the specialized versions of the basic instructions. + note: A Gc might move rows around => allocate first, than pop the arguments. +------------------------------------------------------------------------*/ + +/*------------------------------------------------------------------------ + i_rowInsertAt: insert an element into a row +------------------------------------------------------------------------*/ + case i_rowInsertAt: + { + StgWord j; + StgWord i; + StgWord n; + StgClosure* x; + + /* allocate a new row before popping arguments */ + StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0)); + StgMutArrPtrs* newRow + = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + row->ptrs + 1)); + SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS); + + /* pop row again and pop index and value */ + row = stgCast(StgMutArrPtrs*,PopPtr()); + n = row->ptrs; + newRow->ptrs = n+1; + + i = PopTaggedWord(); + x = PopCPtr(); + + ASSERT(i <= n); + + /* copy the fields, inserting the new value */ + for (j = 0; j < i; j++) { + newRow->payload[j] = row->payload[j]; + } + newRow->payload[i] = x; + for (j = i+1; j <= n; j++) + { + newRow->payload[j] = row->payload[j-1]; + } + + PushPtr(stgCast(StgPtr,newRow)); + break; + } + +/*------------------------------------------------------------------------ + i_rowChainInsert: behaves like a chain of [i_rowInsertAt] calls. This + instruction is vital for XMLambda since we would otherwise allocate + a lot of intermediate rows. + It assumes that the RTS has no NULL pointers. + It behaves 'optimal' if the witnesses are ordered, (lowest on the + bottom of the stack). +------------------------------------------------------------------------*/ +#define ROW_HOLE 0 + case i_rowChainInsert: + { + StgWord witness, topWitness; + StgClosure* value; + StgWord j; + StgWord i; + + /* pop the number of arguments (=witness/value pairs) */ + StgWord n = PopTaggedWord(); + + /* allocate a new row before popping boxed arguments */ + StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0)); + StgMutArrPtrs* newRow + = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n + row->ptrs)); + SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS); + + /* pop the row and assign again (it may have moved during gc!) */ + row = stgCast(StgMutArrPtrs*,PopPtr()); + newRow->ptrs = n + row->ptrs; + + /* zero the fields */ + for (i = 0; i < newRow->ptrs; i++) + { + newRow->payload[i] = ROW_HOLE; + } + + /* insert all values */ + topWitness = 0; /*invariant: 1 + maximal witness */ + for (i = 0; i < n; i++) + { + witness = PopTaggedWord(); + value = PopCPtr(); + if (witness < topWitness) + { + /* shoot, unordered witnesses, we have to bump up everything */ + for (j = topWitness; j > witness; j--) + { + newRow->payload[j] = newRow->payload[j-1]; + } + topWitness += 1; + } + else + { + topWitness = witness+1; + } + + ASSERT(topWitness <= n); + ASSERT(witness < n); + newRow->payload[witness] = value; + } + + /* copy the values from the old row into the holes */ + for (j =0, i = 0; i < row->ptrs; j++,i++) + { + while (newRow->payload[j] != ROW_HOLE) j++; + ASSERT(j < n); + newRow->payload[j] = row->payload[i]; + } + + /* push the result */ + PushPtr(stgCast(StgPtr,newRow)); + break; + } + +/*------------------------------------------------------------------------ + i_rowChainBuild: exactly as [i_rowChainInsert] but builds a row from scratch. +------------------------------------------------------------------------*/ + case i_rowChainBuild: + { + StgWord witness, topWitness; + StgClosure* value; + StgWord j; + StgWord i; + + /* pop the number of arguments (=witness/value pairs) */ + StgWord n = PopTaggedWord(); + + /* allocate a new row before popping boxed arguments */ + StgMutArrPtrs* newRow + = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n)); + SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS); + newRow->ptrs = n; + + /* insert all values */ + topWitness = 0; /*invariant: 1 + maximal witness */ + for (i = 0; i < n; i++) + { + witness = PopTaggedWord(); + value = PopCPtr(); + if (witness < topWitness) + { + /* shoot, unordered witnesses, we have to bump up everything */ + for (j = topWitness; j > witness; j--) + { + newRow->payload[j] = newRow->payload[j-1]; + } + topWitness += 1; + } + else + { + topWitness = witness+1; + } + + ASSERT(topWitness <= n); + ASSERT(witness < n); + newRow->payload[witness] = value; + } + + /* push the result */ + PushPtr(stgCast(StgPtr,newRow)); + break; + } + +/*------------------------------------------------------------------------ + i_rowRemoveAt: remove an element from a row +------------------------------------------------------------------------*/ + case i_rowRemoveAt: + { + StgWord j; + StgWord i; + StgWord n; + + /* allocate new row before popping the arguments */ + StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0)); + StgMutArrPtrs* newRow + = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + row->ptrs - 1)); + SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS); + + /* pop row again and pop the index */ + row = stgCast(StgMutArrPtrs*,PopPtr()); + n = row->ptrs; + newRow->ptrs = n-1; + + i = PopTaggedWord(); + + ASSERT(i < n); + + /* copy the fields, except for the removed value. */ + for (j = 0; j < i; j++) { + newRow->payload[j] = row->payload[j]; + } + for (j = i+1; j < n; j++) + { + newRow->payload[j-1] = row->payload[j]; + } + + PushCPtr(row->payload[i]); + PushPtr(stgCast(StgPtr,newRow)); + break; + } + +/*------------------------------------------------------------------------ + i_rowChainRemove: behaves like a chain of [i_rowRemoveAt] calls. Again, + this is a vital instruction to avoid lots of intermediate rows. + It behaves 'optimal' if the witnessses are ordered, lowest on the + bottom of the stack. + The implementation is quite dirty, blame Daan for this :-) + (It overwrites witnesses on the stack with results and marks pointers + using their lowest bit.) +------------------------------------------------------------------------*/ +#define MARK(p) (stgCast(StgClosure*,(stgCast(StgWord,(p)) | 0x01))) +#define UNMARK(p) (stgCast(StgClosure*,(stgCast(StgWord,(p)) & ~0x01))) +#define ISMARKED(p) ((stgCast(StgWord,(p)) & 0x01) == 0x01) + + case i_rowChainRemove: + { + const nat sizeofTaggedWord = sizeofW(StgWord) + sizeofW(StackTag); + StgWord i; + StgWord j; + StgWord minWitness; + nat base; + StgClosure* value; + + + /* pop number of arguments (=witnesses) */ + StgWord n = PopTaggedWord(); + + /* allocate new row before popping boxed arguments */ + StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0)); + StgMutArrPtrs* newRow + = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + row->ptrs - n)); + SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS); + + /* pop row and assign again (gc might have moved it) */ + row = stgCast(StgMutArrPtrs*,PopPtr()); + newRow->ptrs = row->ptrs - n; + ASSERT( row->ptrs > n ); + + /* 'push' all elements that are removed */ + base = n*sizeofTaggedWord; + minWitness = row->ptrs; + for (i = 1; i <= n; i++) + { + StgWord witness; + + witness = taggedStackWord( base - i*sizeofTaggedWord ); + if (witness >= minWitness) + { + /* shoot, unordered witnesses, we have to search for the value */ + nat count; + + count = witness - minWitness; + witness = minWitness; + while (1) + { + do{ witness++; } while (ISMARKED(row->payload[witness])); + if (count == 0) break; + count--; + } + } + else + { + minWitness = witness; + } + ASSERT( witness < row->ptrs ); + ASSERT( !ISMARKED(row->payload[witness]) ); + + /* mark the element */ + value = row->payload[witness]; + row->payload[witness] = MARK(value); + + /* set the value in the stack (overwriting old witnesses!) */ + setStackPtr( base - i*sizeofW(StgPtr), stgCast(StgPtr,value) ); + } + + /* pop the garbage from the stack */ + gSp = gSp + base - n*sizeofW(StgPtr); + + /* copy all remaining elements and clear the marks */ + for (j = 0, i = 0; i < newRow->ptrs; j++,i++) + { + while (ISMARKED(row->payload[j])) + { + row->payload[j] = UNMARK(row->payload[j]); + j++; + } + newRow->payload[i] = row->payload[j]; + } + + /* unmark tail */ + while (j < row->ptrs) + { + value = row->payload[j]; + if (ISMARKED(value)) row->payload[j] = UNMARK(value); + j++; + } + +#ifdef DEBUG + for (i = 0; i < row->ptrs; i++) + { + ASSERT(!ISMARKED(row->payload[i])); + } +#endif + + /* and push the result row */ + PushPtr(stgCast(StgPtr,newRow)); + break; + } + +/*------------------------------------------------------------------------ + i_rowChainSelect: behaves exactly like [i_rowChainRemove] but doesn't return + the resulting row, only the removed elements. +------------------------------------------------------------------------*/ + case i_rowChainSelect: + { + const nat sizeofTaggedWord = sizeofW(StgWord) + sizeofW(StackTag); + StgWord i; + StgWord minWitness; + nat base; + StgClosure* value; + + /* pop number of arguments (=witnesses) and row*/ + StgWord n = PopTaggedWord(); + StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,PopPtr()); + ASSERT( row->ptrs > n ); + + /* 'push' all elements that are removed */ + base = n*sizeofTaggedWord; + minWitness = row->ptrs; + for (i = 1; i <= n; i++) + { + StgWord witness; + + witness = taggedStackWord( base - i*sizeofTaggedWord ); + if (witness >= minWitness) + { + /* shoot, unordered witnesses, we have to search for the value */ + nat count; + + count = witness - minWitness; + witness = minWitness; + while (1) + { + do{ witness++; } while (ISMARKED(row->payload[witness])); + if (count == 0) break; + count--; + } + } + else + { + minWitness = witness; + } + ASSERT( witness < row->ptrs ); + ASSERT( !ISMARKED(row->payload[witness]) ); + + /* mark the element */ + value = row->payload[witness]; + row->payload[witness] = MARK(value); + + /* set the value in the stack (overwriting old witnesses!) */ + setStackPtr( base - i*sizeofW(StgPtr), stgCast(StgPtr,value) ); + } + + /* pop the garbage from the stack */ + gSp = gSp + base - n*sizeofW(StgPtr); + + /* unmark elements */ + for( i = 0; i < row->ptrs; i++) + { + value = row->payload[i]; + if (ISMARKED(value)) row->payload[i] = UNMARK(value); + } + +#ifdef DEBUG + for (i = 0; i < row->ptrs; i++) + { + ASSERT(!ISMARKED(row->payload[i])); + } +#endif + break; + } + +#endif /* XMLAMBDA */ case i_newRef: { @@ -2845,7 +3445,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))); @@ -3015,21 +3615,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; @@ -3040,29 +3626,122 @@ 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; } - + 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 */ +#ifdef XMLAMBDA + case i_ccall: + { + CallInfo callInfo; + CFunDescriptor descriptor; + void (*funPtr)(void); + + StgWord offset = PopTaggedWord(); /* offset into bco nonptr section */ + funPtr = PopTaggedAddr(); + + ASSERT(funPtr != NULL); + + /* copy the complete callinfo, the bco might move during GC! */ + callInfo = *stgCast(CallInfo*, (*bco)->payload + (*bco)->n_ptrs + offset); + + /* copy info to a CFunDescriptor. just for compatibility. */ + descriptor.num_args = callInfo.argCount; + descriptor.arg_tys = callInfo.data; + descriptor.num_results = callInfo.resultCount; + descriptor.result_tys = callInfo.data + callInfo.argCount + 1; + + /* call out */ + switch (ccall( &descriptor, funPtr, bco, callInfo.callConv, cap )) + { + case 0: break; + case 1: barf( "unhandled type or too many args/results in ccall"); break; + case 2: barf("ccall not configured correctly for this platform"); break; + default: barf("unknown return code from ccall"); break; + } + + break; + } +#endif case i_ccall_ccall_Id: case i_ccall_ccall_IO: @@ -3302,7 +3981,6 @@ StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */ -#if ! FLOATS_AS_DOUBLES StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */ { StgFloat r; @@ -3321,7 +3999,6 @@ StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */ return r; } -#endif /* FLOATS_AS_DOUBLES */ @@ -3383,7 +4060,6 @@ void B__decodeDouble (B* man, I_* exp, StgDouble dbl) } -#if ! FLOATS_AS_DOUBLES void B__decodeFloat (B* man, I_* exp, StgFloat flt) { /* Do some bit fiddling on IEEE */ @@ -3428,6 +4104,4 @@ void B__decodeFloat (B* man, I_* exp, StgFloat flt) do_renormalise(man); } -#endif /* FLOATS_AS_DOUBLES */ - #endif /* INTERPRETER */