* Copyright (c) 1994-1998.
*
* $RCSfile: Evaluator.c,v $
- * $Revision: 1.26 $
- * $Date: 1999/11/12 17:50:04 $
+ * $Revision: 1.38 $
+ * $Date: 2000/03/13 10:39:11 $
* ---------------------------------------------------------------------------*/
#include "Rts.h"
#include "ForeignCall.h"
#include "PrimOps.h" /* for __{encode,decode}{Float,Double} */
#include "Evaluator.h"
+#include "sainteger.h"
#ifdef DEBUG
#include "Printer.h"
#include <ieee754.h> /* These are for primops */
#endif
-#ifdef STANDALONE_INTEGER
-#include "sainteger.h"
-#else
-#error Non-standalone integer not yet supported
-#endif
+
/* An incredibly useful abbreviation.
* Interestingly, there are some uses of END_TSO_QUEUE_closure that
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)
/* 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
B* IntegerInsideByteArray ( StgPtr );
void SloppifyIntegerEnd ( StgPtr );
#endif
-#endif
if (
#ifdef DEBUG
- 1 ||
+ ((++eCount) & 0x0F) == 0
+#else
+ ++eCount == 0
#endif
- ++eCount == 0) {
+ ) {
if (context_switch) {
xPushCPtr(obj); /* code to restart with */
RETURN(ThreadYielding);
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! */
{
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;
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;
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;
}
Case(i_PRIMOP2):
{
- /* Remember to save */
int i, trc, pc_saved;
void* p;
StgBCO* bco_tmp;
/* 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;
Case(i_VAR_FLOAT_big):
Case(i_CONST_CHAR_big):
Case(i_VAR_CHAR_big):
- Case(i_CONST_ADDR_big):
Case(i_VAR_ADDR_big):
Case(i_VAR_STABLE_big):
Case(i_CONST_INTEGER_big):
- Case(i_CONST_INT_big):
Case(i_VAR_INT_big):
Case(i_VAR_WORD_big):
Case(i_RETADDR_big):
case CAF_BLACKHOLE:
case SE_CAF_BLACKHOLE:
{
- /*was StgBlackHole* */
- StgBlockingQueue* bh = (StgBlockingQueue*)obj;
- /* Put ourselves on the blocking queue for this black hole and block */
- cap->rCurrentTSO->link = bh->blocking_queue;
- bh->blocking_queue = cap->rCurrentTSO;
- xPushCPtr(obj); /* code to restart with */
- barf("enter: CAF_BLACKHOLE unexpected!");
- RETURN(ThreadBlocked);
+ /* Let the scheduler figure out what to do :-) */
+ cap->rCurrentTSO->whatNext = ThreadEnterGHC;
+ xPushCPtr(obj);
+ RETURN(ThreadYielding);
}
case AP_UPD:
{
case RET_VEC_SMALL:
case RET_BIG:
case RET_VEC_BIG:
- // barf("todo: RET_[VEC_]{BIG,SMALL}");
+ cap->rCurrentTSO->whatNext = ThreadEnterGHC;
+ xPushCPtr(obj);
+ RETURN(ThreadYielding);
default:
belch("entered CONSTR with invalid continuation on stack");
IF_DEBUG(evaluator,
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
+ /* 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] = 0xdeadbeef; /*R1.cl;*/
-
+ HaskellObj primRaiseClosure
+ = asmClosureOfObject(getHugs_AsmObject_for("primRaise"));
+ HaskellObj reraiseClosure
+ = rts_apply ( primRaiseClosure, exception );
+
while (1) {
switch (get_itbl(gSu)->type) {
case UPDATE_FRAME:
- UPD_IND(gSu->updatee,raise_closure);
+ UPD_IND(gSu->updatee,reraiseClosure);
gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
gSu = gSu->link;
break;
StgClosure *handler = fp->handler;
gSu = fp->link;
gSp += sizeofW(StgCatchFrame); /* Pop */
- PushCPtr(errObj);
+ PushCPtr(exception);
return handler;
}
case STOP_FRAME:
HaskellObj error
= asmClosureOfObject(getHugs_AsmObject_for("error"));
HaskellObj unpack
- = asmClosureOfObject(getHugs_AsmObject_for("primUnpackString"));
+ = asmClosureOfObject(getHugs_AsmObject_for("hugsprimUnpackString"));
HaskellObj thunk
= rts_apply ( unpack, rts_mkAddr ( (void*)msg ) );
thunk
}
-#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;
}}
SloppifyIntegerEnd(p); \
PushPtr(p); \
}
-#endif
}
-void myStackCheck ( Capability* cap )
+static void myStackCheck ( Capability* cap )
{
/* fprintf(stderr, "myStackCheck\n"); */
if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) {
assert(0);
}
while (1) {
- if (!(gSu >= cap->rCurrentTSO->stack
- && gSu <= cap->rCurrentTSO->stack
- + cap->rCurrentTSO->stack_size)) {
+ if (!( (P_)gSu >= (P_)cap->rCurrentTSO->stack
+ &&
+ (P_)gSu <= (P_)(cap->rCurrentTSO->stack
+ + cap->rCurrentTSO->stack_size))) {
fprintf ( stderr, "myStackCheck: gSu out of stack\n" );
assert(0);
}
switch (get_itbl(stgCast(StgClosure*,gSu))->type) {
case CATCH_FRAME:
- gSu = (StgPtr) ((StgCatchFrame*)(gSu))->link;
+ gSu = (StgUpdateFrame*) ((StgCatchFrame*)(gSu))->link;
break;
case UPDATE_FRAME:
- gSu = (StgPtr) ((StgUpdateFrame*)(gSu))->link;
+ gSu = (StgUpdateFrame*) ((StgUpdateFrame*)(gSu))->link;
break;
case SEQ_FRAME:
- gSu = (StgPtr) ((StgSeqFrame*)(gSu))->link;
+ gSu = (StgUpdateFrame*) ((StgSeqFrame*)(gSu))->link;
break;
case STOP_FRAME:
goto postloop;
*/
static void* enterBCO_primop1 ( int primop1code )
{
+ if (combined)
+ barf("enterBCO_primop1 in combined mode");
+
switch (primop1code) {
case i_pushseqframe:
{
case i_readStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
-#ifdef STANDALONE_INTEGER
case i_compareInteger:
{
B* x = IntegerInsideByteArray(PopPtr());
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;
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();
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;
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();
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;
StgBCO** bco,
Capability* cap )
{
+ 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} */
{
break;
}
- /* Most of these generate alignment warnings on gSparcs and similar architectures.
+ /* 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.
*/
case i_indexCharArray:
break;
}
-#ifdef PROVIDE_CONCURRENT
- case i_fork:
- {
- 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;
- break;
- }
- case i_killThread:
- {
- StgTSO* tso = stgCast(StgTSO*,PopPtr());
- deleteThread(tso);
- if (tso == cap->rCurrentTSO) { /* suicide */
- *return2 = ThreadFinished;
- return (void*)(1+(NULL));
- }
- break;
- }
- case i_sameMVar:
- { /* identical to i_sameRef */
- StgPtr x = PopPtr();
- StgPtr y = PopPtr();
- PushTaggedBool(x==y);
- 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) {
+ 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 = cap->rCurrentTSO;
}
- cap->rCurrentTSO->link = EndTSOQueue;
+ cap->rCurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
+ cap->rCurrentTSO->why_blocked = BlockedOnMVar;
+ cap->rCurrentTSO->block_info.closure = (StgClosure *)mvar;
mvar->tail = cap->rCurrentTSO;
- /* 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);
+ /* 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;
+ }
+ 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;
+ }
+ 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;
+ PushTaggedWord(tid);
+ break;
+ }
+
+#ifdef PROVIDE_CONCURRENT
+ case i_killThread:
+ {
+ StgTSO* tso = stgCast(StgTSO*,PopPtr());
+ deleteThread(tso);
+ if (tso == cap->rCurrentTSO) { /* suicide */
+ *return2 = ThreadFinished;
+ return (void*)(1+(NULL));
+ }
break;
}
+
case i_delay:
case i_waitRead:
case i_waitWrite:
ASSERT(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 = PopTaggedAddr();
- void (*funPtr)(void) = PopTaggedAddr();
- char cc = (primop2code == i_ccall_stdcall_Id ||
+ 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);
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);
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);
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;
* (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) */
#endif /* FLOATS_AS_DOUBLES */
-#endif /* STANDALONE_INTEGER */
-
#endif /* INTERPRETER */
projects / ghc-hetmet.git / blobdiff