X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FEvaluator.c;h=b7906f7589ec34158b9d3ca5a3106508029c0de8;hb=a0b380bb30e37ab75eb42ff3f7e9a9bc60291496;hp=66f4a897f7952d86fedcdc3a203acdb9ad3646e6;hpb=eb407ca1d21a43ff86ad731868f71e994afafe78;p=ghc-hetmet.git diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c index 66f4a89..b7906f7 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.16 $ - * $Date: 1999/05/11 16:47:50 $ + * $Revision: 1.46 $ + * $Date: 2000/04/03 15:24:21 $ * ---------------------------------------------------------------------------*/ #include "Rts.h" @@ -19,18 +19,18 @@ #include "Storage.h" #include "SchedAPI.h" /* for createGenThread */ #include "Schedule.h" /* for context_switch */ - #include "Bytecodes.h" #include "Assembler.h" /* for CFun stuff */ #include "ForeignCall.h" -#include "StablePriv.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" #include "Disassembler.h" - #include "Sanity.h" #include "StgRun.h" #endif @@ -42,12 +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 @@ -70,6 +68,12 @@ #define USE_GCC_LABELS 0 #endif +/* 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; + /* -------------------------------------------------------------------------- * Crude profiling stuff (mainly to assess effect of optimiser) * ------------------------------------------------------------------------*/ @@ -103,6 +107,7 @@ void cp_init ( void ) } + void cp_enter ( StgBCO* b ) { int is_ret_cont; @@ -233,43 +238,31 @@ void cp_show ( void ) * Hugs Hooks - a bit of a hack * ------------------------------------------------------------------------*/ -/* A total hack -- this code has an endian dependancy and only works - on little-endian archs. -*/ void setRtsFlags( int x ); void setRtsFlags( int x ) { - *(int*)(&(RtsFlags.DebugFlags)) = x; + unsigned int w = 0x12345678; + unsigned char* pw = (unsigned char *)&w; + if (*pw == 0x78) { + /* little endian */ + *(int*)(&(RtsFlags.DebugFlags)) = x; + } else { + /* big endian */ + unsigned int w1 = x; + unsigned int w2 = 0; + w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8; + w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8; + w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8; + w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8; + *(int*)(&(RtsFlags.DebugFlags)) = (int)w2; + } } -/* -------------------------------------------------------------------------- - * RTS Hooks - * - * ToDo: figure out why these are being used and crush them! - * ------------------------------------------------------------------------*/ -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 */ -} +typedef struct { + StgTSOBlockReason reason; + unsigned int delay; +} HugsBlock; /* -------------------------------------------------------------------------- @@ -300,20 +293,20 @@ void defaultsHook (void) /* Forward decls ... */ static void* enterBCO_primop1 ( int ); -static void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */ ); +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 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 @@ -323,21 +316,32 @@ 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; return retVal; } +#define RETURN(vvv) { \ + StgThreadReturnCode retVal=(vvv); \ + SSS; \ + cap->rCurrentTSO->sp = gSp; \ + cap->rCurrentTSO->su = gSu; \ + cap->rCurrentTSO->splim = gSpLim; \ + return retVal; \ + } /* Macros to operate directly on the pulled-out machine state. @@ -348,7 +352,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++)) @@ -385,6 +389,12 @@ void SloppifyIntegerEnd ( StgPtr ); #define xPopTaggedAddr() ((xSp++,xSp+=sizeofW(StgAddr), \ (StgAddr)(*(xSp-sizeofW(StgAddr))))) +#define xPushTaggedStable(xxx) { xSp -= sizeofW(StgStablePtr); \ + *xSp = (StgWord)(xxx); xPushTag(STABLE_TAG); } +#define xTaggedStackStable(iii) ((StgStablePtr)(*(xSp+1+(iii)))) +#define xPopTaggedStable() ((xSp++,xSp+=sizeofW(StgStablePtr), \ + (StgStablePtr)(*(xSp-sizeofW(StgStablePtr))))) + #define xPushTaggedChar(xxx) { xSp -= sizeofW(StgChar); \ *xSp = (StgWord)(xxx); xPushTag(CHAR_TAG); } #define xTaggedStackChar(iii) ((StgChar)(*(xSp+1+(iii)))) @@ -404,6 +414,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 */ \ @@ -427,7 +447,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. @@ -438,9 +463,21 @@ StgThreadReturnCode enter( 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; + #ifdef DEBUG /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */ - StgPtr tSp = Sp; StgUpdateFrame* tSu = Su; StgPtr tSpLim = SpLim; + tSp = gSp; tSu = gSu; tSpLim = gSpLim; #endif obj = obj0; @@ -455,9 +492,9 @@ StgThreadReturnCode enter( StgClosure* obj0 ) enterLoop: #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++; @@ -467,16 +504,49 @@ 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; ); #endif - if (++eCount == 0) { + if ( +#ifdef DEBUG + ((++eCount) & 0x0F) == 0 +#else + ++eCount == 0 +#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"); + } } } @@ -527,15 +597,15 @@ StgThreadReturnCode enter( StgClosure* obj0 ) 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; disInstr(bco,PC); - { int i; + 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; @@ -560,6 +630,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; @@ -657,6 +736,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! */ @@ -725,7 +814,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; @@ -747,7 +836,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; @@ -800,7 +889,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; @@ -813,9 +902,14 @@ StgThreadReturnCode enter( StgClosure* obj0 ) ASSERT( itbl->type == CONSTR || itbl->type == CONSTR_STATIC || itbl->type == CONSTR_NOCAF_STATIC + || itbl->type == CONSTR_1_0 + || itbl->type == CONSTR_0_1 + || itbl->type == CONSTR_2_0 + || itbl->type == CONSTR_1_1 + || itbl->type == CONSTR_0_2 ); while (--i>=0) { - xPushCPtr(payloadCPtr(o,i)); + xPushCPtr(o->payload[i]); } Continue; } @@ -859,11 +953,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 "); @@ -920,7 +1020,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 "); @@ -949,11 +1049,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 "); @@ -966,7 +1072,7 @@ StgThreadReturnCode enter( StgClosure* obj0 ) } Case(i_UNPACK_ADDR): { - StgClosure* con = stgCast(StgClosure*,xStackPtr(0)); + StgClosure* con = (StgClosure*)xStackPtr(0); /* ASSERT(isAddrLike(con)); */ xPushTaggedAddr(payloadPtr(con,0)); Continue; @@ -986,7 +1092,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, @@ -1019,7 +1125,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 "); @@ -1058,7 +1164,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 "); @@ -1076,38 +1182,30 @@ StgThreadReturnCode enter( StgClosure* obj0 ) } Case(i_VAR_STABLE): { - fprintf(stderr, "unimp: i_VAR_STABLE\n" ); exit(0); - /*fix side effects here ...*/ - /* - xPushTaggedStablePtr(xTaggedStackStable(BCO_INSTR_8)); - */ + StgStablePtr s = xTaggedStackStable(BCO_INSTR_8); + xPushTaggedStable(s); Continue; } Case(i_PACK_STABLE): { - //StgClosure* o; - fprintf(stderr, "unimp: i_PACK_STABLE\n" ); exit(0); - /* + StgClosure* o; SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL; - SET_HDR(o,&StablePtr_con_info,??); - payloadWord(o,0) = xPopTaggedStablePtr(); + SET_HDR(o,StablePtr_con_info,??); + payloadWord(o,0) = xPopTaggedStable(); IF_DEBUG(evaluator, fprintf(stderr,"\tBuilt "); + SSS; printObj(stgCast(StgClosure*,o)); + LLL; ); xPushPtr(stgCast(StgPtr,o)); - */ Continue; } Case(i_UNPACK_STABLE): { - //StgClosure* con; - fprintf(stderr, "unimp: i_UNPACK_STABLE\n" ); exit(0); - /* - con = stgCast(StgClosure*,xStackPtr(0)); - ASSERT(isStableLike(con)); - xPushTaggedStablePtr(payloadWord(con,0)); - */ + StgClosure* con = (StgClosure*)xStackPtr(0); + /* ASSERT(isStableLike(con)); */ + xPushTaggedStable(payloadWord(con,0)); Continue; } Case(i_PRIMOP1): @@ -1121,18 +1219,27 @@ StgThreadReturnCode enter( StgClosure* obj0 ) } Case(i_PRIMOP2): { - int i, trc; - void* p; - trc = 12345678; /* Hope that no StgThreadReturnCode has this value */ - i = BCO_INSTR_8; - SSS; p = enterBCO_primop2 ( i, &trc ); LLL; + int i, trc, pc_saved; + void* p; + StgBCO* bco_tmp; + trc = 12345678; /* Assume != any StgThreadReturnCode */ + i = BCO_INSTR_8; + pc_saved = PC; + bco_tmp = bco; + SSS; + p = enterBCO_primop2 ( i, &trc, &bco_tmp, cap, + &hugsBlock ); + LLL; + bco = bco_tmp; + bciPtr = &(bcoInstr(bco,pc_saved)); if (p) { if (trc == 12345678) { /* 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; @@ -1213,10 +1320,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): @@ -1262,7 +1368,7 @@ StgThreadReturnCode enter( StgClosure* obj0 ) if (caf->mut_link == NULL) { SSS; recordOldToNewPtrs((StgMutClosure*)caf); LLL; } - SSS; PUSH_UPD_FRAME(bh,0); LLL; + xPushUpdateFrame(bh,0); xSp -= sizeofW(StgUpdateFrame); caf->link = enteredCAFs; enteredCAFs = caf; @@ -1280,14 +1386,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: { @@ -1299,20 +1401,23 @@ 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)); } obj = ap->fun; #ifdef EAGER_BLACKHOLING +#warn LAZY_BLACKHOLING is default for StgHugs +#error Dont know if EAGER_BLACKHOLING works in StgHugs { - /* superfluous - but makes debugging easier */ - StgBlackHole* bh = stgCast(StgBlackHole*,ap); - SET_INFO(bh,&BLACKHOLE_info); - bh->blocking_queue = EndTSOQueue; - IF_DEBUG(gccafs,fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh)); - /*printObj(bh); */ + /* superfluous - but makes debugging easier */ + StgBlackHole* bh = stgCast(StgBlackHole*,ap); + SET_INFO(bh,&BLACKHOLE_info); + bh->blocking_queue = EndTSOQueue; + IF_DEBUG(gccafs, + fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh)); + /* printObj(bh); */ } #endif /* EAGER_BLACKHOLING */ goto enterLoop; @@ -1341,6 +1446,11 @@ StgThreadReturnCode enter( StgClosure* obj0 ) goto enterLoop; } case CONSTR: + case CONSTR_1_0: + case CONSTR_0_1: + case CONSTR_2_0: + case CONSTR_1_1: + case CONSTR_0_2: case CONSTR_INTLIKE: case CONSTR_CHARLIKE: case CONSTR_STATIC: @@ -1362,9 +1472,11 @@ StgThreadReturnCode enter( StgClosure* obj0 ) ASSERT(xSp==(P_)xSu); IF_DEBUG(evaluator, SSS; + 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);*/ + fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu); + printStack(xSp,cap->rCurrentTSO->stack + + cap->rCurrentTSO->stack_size,xSu); LLL; ); SSS; PopStopFrame(obj); LLL; @@ -1386,7 +1498,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, @@ -1400,16 +1514,12 @@ StgThreadReturnCode enter( StgClosure* obj0 ) } default: { - SSS; - fprintf(stderr, "enterCountI = %d\n", enterCountI); - fprintf(stderr, "panic: enter: entered unknown closure\n"); - printObj(obj); - fprintf(stderr, "what it points at is\n"); - printObj( ((StgEvacuated*)obj) ->evacuee); - LLL; - exit(1); - /* formerly ... */ - CurrentTSO->whatNext = ThreadEnterGHC; + //SSS; + //fprintf(stderr, "enterCountI = %d\n", enterCountI); + //fprintf(stderr, "entering unknown closure -- yielding to sched\n"); + //printObj(obj); + //LLL; + cap->rCurrentTSO->what_next = ThreadEnterGHC; xPushCPtr(obj); /* code to restart with */ RETURN(ThreadYielding); } @@ -1443,6 +1553,9 @@ StgThreadReturnCode enter( StgClosure* obj0 ) #undef xPushTaggedAddr #undef xTaggedStackAddr #undef xPopTaggedAddr +#undef xPushTaggedStable +#undef xTaggedStackStable +#undef xPopTaggedStable #undef xPushTaggedChar #undef xTaggedStackChar #undef xPopTaggedChar @@ -1452,7 +1565,8 @@ StgThreadReturnCode enter( StgClosure* obj0 ) #undef xPushTaggedDouble #undef xTaggedStackDouble #undef xPopTaggedDouble - +#undef xPopUpdateFrame +#undef xPushUpdateFrame /* -------------------------------------------------------------------------- @@ -1460,56 +1574,56 @@ StgThreadReturnCode enter( StgClosure* obj0 ) * ------------------------------------------------------------------------*/ static inline void PushTag ( StackTag t ) - { *(--Sp) = t; } -static inline void PushPtr ( StgPtr x ) - { *(--stgCast(StgPtr*,Sp)) = x; } + { *(--gSp) = t; } + inline void PushPtr ( StgPtr 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++)); } -static inline StgPtr PopPtr ( void ) - { return *stgCast(StgPtr*,Sp)++; } + { checkTag(t,*(gSp++)); } + inline StgPtr PopPtr ( void ) + { 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); } -static inline void PushTaggedAddr ( StgAddr x ) - { Sp -= sizeofW(StgAddr); *Sp = (W_)x; PushTag(ADDR_TAG); } -static inline void PushTaggedChar ( StgChar x ) - { Sp -= sizeofW(StgChar); *Sp = stgCast(StgWord,x); PushTag(CHAR_TAG); } -static inline void PushTaggedFloat ( StgFloat x ) - { Sp -= sizeofW(StgFloat); ASSIGN_FLT(Sp,x); PushTag(FLOAT_TAG); } -static 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(StgInt); *gSp = x; PushTag(INT_TAG); } + inline void PushTaggedWord ( StgWord x ) + { gSp -= sizeofW(StgWord); *gSp = x; PushTag(WORD_TAG); } + inline void PushTaggedAddr ( StgAddr x ) + { gSp -= sizeofW(StgAddr); *gSp = (W_)x; PushTag(ADDR_TAG); } + inline void PushTaggedChar ( StgChar x ) + { gSp -= sizeofW(StgChar); *gSp = stgCast(StgWord,x); PushTag(CHAR_TAG); } + inline void PushTaggedFloat ( StgFloat x ) + { gSp -= sizeofW(StgFloat); ASSIGN_FLT(gSp,x); PushTag(FLOAT_TAG); } + 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); } static inline void PushTaggedBool ( int x ) { PushTaggedInt(x); } @@ -1518,43 +1632,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;} -static inline StgAddr PopTaggedAddr ( void ) - { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, Sp); - Sp += sizeofW(StgAddr); return r;} -static inline StgChar PopTaggedChar ( void ) - { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *Sp); - Sp += sizeofW(StgChar); return r;} -static inline StgFloat PopTaggedFloat ( void ) - { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(Sp); - Sp += sizeofW(StgFloat); return r;} -static 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;} + { 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*, gSp); + gSp += sizeofW(StgAddr); return r;} + inline StgChar PopTaggedChar ( void ) + { 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(gSp); + gSp += sizeofW(StgFloat); return r;} + inline StgDouble PopTaggedDouble ( 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); + 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); } /* -------------------------------------------------------------------------- @@ -1595,104 +1709,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 - 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 +#warn LAZY_BLACKHOLING is default for StgHugs +#error Dont know if EAGER_BLACKHOLING works in StgHugs + 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 + = asmClosureOfObject(getHugs_AsmObject_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: @@ -1703,32 +1819,29 @@ static inline StgClosure* raiseAnError( StgClosure* errObj ) } } -static StgClosure* raisePrim(char* msg) + +static StgClosure* makeErrorCall ( const char* msg ) { - /* ToDo: figure out some way to turn the msg into a Haskell Exception - * Hack: we don't know how to build an Exception but we do know how - * to build a (recursive!) error object. - * The result isn't pretty but it's (slightly) better than nothing. - */ - nat size = sizeof(StgClosure) + 1; - StgClosure* errObj = stgCast(StgClosure*,grabHpNonUpd(size)); - SET_INFO(errObj,&raise_info); - errObj->payload[0] = errObj; -fprintf(stderr, "\n\n\nRAISE PRIM %s\n", msg); -#if 0 - belch(msg); -#else - /* At the moment, I prefer to put it on stdout to make things as - * close to Hugs' old behaviour as possible. - */ - fprintf(stdout, "Program error: %s", msg); - fflush(stdout); -#endif - return raiseAnError(stgCast(StgClosure*,errObj)); + /* Note! the msg string should be allocated in a + place which will not get freed -- preferably + read-only data of the program. That's because + the thunk we build here may linger indefinitely. + (thinks: probably not so, but anyway ...) + */ + HaskellObj error + = asmClosureOfObject(getHugs_AsmObject_for("error")); + HaskellObj unpack + = asmClosureOfObject(getHugs_AsmObject_for("hugsprimUnpackString")); + HaskellObj thunk + = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) ); + thunk + = rts_apply ( error, thunk ); + return + (StgClosure*) thunk; } -#define raiseIndex(where) raisePrim("Array index out of range in " where) -#define raiseDiv0(where) raisePrim("Division by 0 in " where) +#define raiseIndex(where) makeErrorCall("Array index out of range in " where) +#define raiseDiv0(where) makeErrorCall("Division by zero in " where) /* -------------------------------------------------------------------------- * Evaluator @@ -1812,6 +1925,12 @@ fprintf(stderr, "\n\n\nRAISE PRIM %s\n", msg); PushTaggedWord(e); \ } +#define OP_I_s(e) \ +{ \ + StgInt x = PopTaggedInt(); \ + PushTaggedStablePtr(e); \ +} + #define OP__F(e) \ { \ PushTaggedFloat(e); \ @@ -1854,6 +1973,12 @@ fprintf(stderr, "\n\n\nRAISE PRIM %s\n", msg); PushTaggedInt(e); \ } +#define OP_s_I(e) \ +{ \ + StgStablePtr x = PopTaggedStablePtr(); \ + PushTaggedInt(e); \ +} + #define OP_W_W(e) \ { \ StgWord x = PopTaggedWord(); \ @@ -1917,7 +2042,7 @@ fprintf(stderr, "\n\n\nRAISE PRIM %s\n", msg); int y = PopTaggedInt(); \ StgStablePtr r; \ s; \ - PushTaggedStablePtr(r); \ + PushTaggedStablePtr(r); \ } #define OP_AIC_(s) \ { \ @@ -2040,17 +2165,16 @@ fprintf(stderr, "\n\n\nRAISE PRIM %s\n", 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; }} @@ -2082,7 +2206,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]) == @@ -2109,7 +2233,6 @@ void SloppifyIntegerEnd ( StgPtr arr0 ) SloppifyIntegerEnd(p); \ PushPtr(p); \ } -#endif @@ -2138,29 +2261,30 @@ void SloppifyIntegerEnd ( StgPtr arr0 ) } -void myStackCheck ( void ) +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; @@ -2181,6 +2305,9 @@ void myStackCheck ( void ) */ static void* enterBCO_primop1 ( int primop1code ) { + if (combined) + barf("enterBCO_primop1 in combined mode"); + switch (primop1code) { case i_pushseqframe: { @@ -2226,8 +2353,7 @@ static void* enterBCO_primop1 ( int primop1code ) return (raiseDiv0("quotInt")); } /* ToDo: protect against minInt / -1 errors - * (repeat for all other division primops) - */ + * (repeat for all other division primops) */ PushTaggedInt(x/y); } break; @@ -2324,6 +2450,9 @@ 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_indexCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break; case i_readCharOffAddr: OP_AI_C(indexCharOffAddrzh(r,x,y)); break; case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrzh(x,y,z)); break; @@ -2344,13 +2473,10 @@ static void* enterBCO_primop1 ( int primop1code ) case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break; case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z)); break; -#ifdef PROVIDE_STABLE case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break; case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break; case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break; -#endif -#ifdef STANDALONE_INTEGER case i_compareInteger: { B* x = IntegerInsideByteArray(PopPtr()); @@ -2415,9 +2541,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; @@ -2438,11 +2561,6 @@ static void* enterBCO_primop1 ( int primop1code ) { StgFloat x = PopTaggedFloat(); StgFloat y = PopTaggedFloat(); -#if 0 - if (y == 0) { - return (raiseDiv0("divideFloat")); - } -#endif PushTaggedFloat(x/y); } break; @@ -2463,7 +2581,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(); @@ -2483,9 +2600,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; @@ -2509,11 +2624,6 @@ static void* enterBCO_primop1 ( int primop1code ) { StgDouble x = PopTaggedDouble(); StgDouble y = PopTaggedDouble(); -#if 0 - if (y == 0) { - return (raiseDiv0("divideDouble")); - } -#endif PushTaggedDouble(x/y); } break; @@ -2536,7 +2646,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(); @@ -2556,9 +2665,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; @@ -2581,10 +2688,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 ) + int* /*StgThreadReturnCode* */ return2, + 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} */ { @@ -2703,8 +2824,8 @@ static void* enterBCO_primop2 ( int primop2code, } /* Most of these generate alignment warnings on Sparcs and similar architectures. - * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS. - */ + * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS. + */ case i_indexCharArray: OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break; case i_readCharArray: @@ -2740,6 +2861,7 @@ static void* enterBCO_primop2 ( int primop2code, case i_writeDoubleArray: OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break; +#if 0 #ifdef PROVIDE_STABLE case i_indexStableArray: OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break; @@ -2748,7 +2870,7 @@ static void* enterBCO_primop2 ( int primop2code, case i_writeStableArray: OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break; #endif - +#endif @@ -2802,210 +2924,261 @@ static void* enterBCO_primop2 ( int primop2code, PushCPtr(w->value); /* last result */ PushTaggedInt(1); /* first result */ } else { - PushPtr(stgCast(StgPtr,w)); /* ToDo: error thunk would be better */ + PushPtr(stgCast(StgPtr,w)); + /* ToDo: error thunk would be better */ PushTaggedInt(0); } break; } #endif /* PROVIDE_WEAK */ -#ifdef PROVIDE_STABLE - /* StablePtr# operations */ - case i_makeStablePtr: - case i_deRefStablePtr: - case i_freeStablePtr: - { fprintf(stderr,"Evaluator.c:stablePtrOp unimp\n" ); - exit(1); }; -#if 0 - ToDo: reinstate case i_makeStablePtr: { - StgStablePtr stable_ptr; - if (stable_ptr_free == NULL) { - enlargeStablePtrTable(); - } - - stable_ptr = stable_ptr_free - stable_ptr_table; - stable_ptr_free = (P_*)*stable_ptr_free; - stable_ptr_table[stable_ptr] = PopPtr(); - - PushTaggedStablePtr(stable_ptr); + StgPtr p = PopPtr(); + StgStablePtr sp = getStablePtr ( p ); + PushTaggedStablePtr(sp); break; } case i_deRefStablePtr: { - StgStablePtr stable_ptr = PopTaggedStablePtr(); - PushPtr(stable_ptr_table[stable_ptr]); + StgPtr p; + StgStablePtr sp = PopTaggedStablePtr(); + p = deRefStablePtr(sp); + PushPtr(p); break; } - case i_freeStablePtr: { - StgStablePtr stable_ptr = PopTaggedStablePtr(); - stable_ptr_table[stable_ptr] = (P_)stable_ptr_free; - stable_ptr_free = stable_ptr_table + stable_ptr; + StgStablePtr sp = PopTaggedStablePtr(); + freeStablePtr(sp); break; } -#endif /* 0 */ - -#endif /* PROVIDE_STABLE */ -#ifdef PROVIDE_CONCURRENT - case i_fork: + case i_createAdjThunkARCH: { - 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; + StgStablePtr stableptr = PopTaggedStablePtr(); + StgAddr typestr = PopTaggedAddr(); + StgChar callconv = PopTaggedChar(); + StgAddr adj_thunk = createAdjThunk(stableptr,typestr,callconv); + PushTaggedAddr(adj_thunk); break; - } - case i_killThread: + } + + case i_getArgc: { - StgTSO* tso = stgCast(StgTSO*,PopPtr()); - deleteThread(tso); - if (tso == CurrentTSO) { /* suicide */ - *return2 = ThreadFinished; - return (void*)(1+(NULL)); - } + StgInt n = prog_argc; + PushTaggedInt(n); break; } - case i_sameMVar: - { /* identical to i_sameRef */ - StgPtr x = PopPtr(); - StgPtr y = PopPtr(); - PushTaggedBool(x==y); + case i_getArgv: + { + 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+(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; -#endif /* PROVIDE_CONCURRENT */ - case i_ccall_Id: - case i_ccall_IO: + } + case i_cmpThreadIds: { - CFunDescriptor* descriptor = PopTaggedAddr(); - StgAddr funPtr = PopTaggedAddr(); - ccall(descriptor,funPtr); + StgWord tid1 = PopTaggedWord(); + StgWord tid2 = PopTaggedWord(); + if (tid1 < tid2) PushTaggedInt(-1); + else if (tid1 > tid2) PushTaggedInt(1); + else PushTaggedInt(0); break; } +#endif /* PROVIDE_CONCURRENT */ + + case i_ccall_ccall_Id: + case i_ccall_ccall_IO: + case i_ccall_stdcall_Id: + case i_ccall_stdcall_IO: + { + int r; + 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( + "unhandled type or too many args/results in ccall"); + if (r == 2) + barf("ccall not configured correctly for this platform"); + barf("unknown return code from ccall"); + } default: barf("Unrecognised primop2"); } @@ -3017,11 +3190,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) @@ -3030,7 +3203,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); @@ -3050,11 +3223,9 @@ nat marshall(char arg_ty, void* arg) case ADDR_REP: PushTaggedAddr(*((void**)arg)); return ARG_SIZE(ADDR_TAG); -#ifdef PROVIDE_STABLE case STABLE_REP: PushTaggedStablePtr(*((StgStablePtr*)arg)); return ARG_SIZE(STABLE_TAG); -#endif #ifdef PROVIDE_FOREIGN case FOREIGN_REP: /* Not allowed in this direction - you have to @@ -3075,7 +3246,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) @@ -3084,7 +3255,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); @@ -3104,11 +3275,9 @@ nat unmarshall(char res_ty, void* res) case ADDR_REP: *((void**)res) = PopTaggedAddr(); return ARG_SIZE(ADDR_TAG); -#ifdef PROVIDE_STABLE case STABLE_REP: *((StgStablePtr*)res) = PopTaggedStablePtr(); return ARG_SIZE(STABLE_TAG); -#endif #ifdef PROVIDE_FOREIGN case FOREIGN_REP: { @@ -3137,7 +3306,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; @@ -3157,11 +3326,9 @@ nat argSize( const char* ks ) case ADDR_REP: sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG); break; -#ifdef PROVIDE_STABLE case STABLE_REP: sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG); break; -#endif #ifdef PROVIDE_FOREIGN case FOREIGN_REP: #endif @@ -3184,8 +3351,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) */ @@ -3357,8 +3522,4 @@ void B__decodeFloat (B* man, I_* exp, StgFloat flt) #endif /* FLOATS_AS_DOUBLES */ -#endif /* STANDALONE_INTEGER */ - - - #endif /* INTERPRETER */