-
+#if 0
/* -----------------------------------------------------------------------------
* Bytecode evaluator
*
* Copyright (c) 1994-2000.
*
- * $RCSfile: Evaluator.c,v $
- * $Revision: 1.60 $
- * $Date: 2000/11/20 11:15:41 $
+ * $RCSfile: Interpreter.c,v $
+ * $Revision: 1.1 $
+ * $Date: 2000/12/11 12:55:43 $
* ---------------------------------------------------------------------------*/
#include "Rts.h"
-#ifdef INTERPRETER
+
#include "RtsFlags.h"
#include "RtsUtils.h"
}
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 */
fprintf(stderr,"gSp = %p\tgSu = %p\n\n", gSp, gSu);
);
#ifdef EAGER_BLACKHOLING
+#warn LAZY_BLACKHOLING is default for StgHugs
#error Dont know if EAGER_BLACKHOLING works in StgHugs
ASSERT(get_itbl(gSu->updatee)->type == BLACKHOLE
|| get_itbl(gSu->updatee)->type == SE_BLACKHOLE
/* --------------------------------------------------------------------------
- * Primop stuff for bytecode interpreter
+ * The new bytecode interpreter
* ------------------------------------------------------------------------*/
-/* Returns & of the next thing to enter (if throwing an exception),
- or NULL in the normal case.
-*/
-static void* enterBCO_primop1 ( int primop1code )
-{
- if (combined)
- barf("enterBCO_primop1 in combined mode");
-
- switch (primop1code) {
- case i_pushseqframe:
- {
- StgClosure* c = PopCPtr();
- PushSeqFrame();
- PushCPtr(c);
- break;
- }
- case i_pushcatchframe:
- {
- StgClosure* e = PopCPtr();
- StgClosure* h = PopCPtr();
- PushCatchFrame(h);
- PushCPtr(e);
- break;
- }
-
- case i_gtChar: OP_CC_B(x>y); break;
- case i_geChar: OP_CC_B(x>=y); break;
- case i_eqChar: OP_CC_B(x==y); break;
- case i_neChar: OP_CC_B(x!=y); break;
- case i_ltChar: OP_CC_B(x<y); break;
- case i_leChar: OP_CC_B(x<=y); break;
- case i_charToInt: OP_C_I(x); break;
- case i_intToChar: OP_I_C(x); break;
-
- case i_gtInt: OP_II_B(x>y); break;
- case i_geInt: OP_II_B(x>=y); break;
- case i_eqInt: OP_II_B(x==y); break;
- case i_neInt: OP_II_B(x!=y); break;
- case i_ltInt: OP_II_B(x<y); break;
- case i_leInt: OP_II_B(x<=y); break;
- case i_minInt: OP__I(INT_MIN); break;
- case i_maxInt: OP__I(INT_MAX); break;
- case i_plusInt: OP_II_I(x+y); break;
- case i_minusInt: OP_II_I(x-y); break;
- case i_timesInt: OP_II_I(x*y); break;
- case i_quotInt:
- {
- int x = PopTaggedInt();
- int y = PopTaggedInt();
- if (y == 0) {
- return (raiseDiv0("quotInt"));
- }
- /* ToDo: protect against minInt / -1 errors
- * (repeat for all other division primops) */
- PushTaggedInt(x/y);
- }
- break;
- case i_remInt:
- {
- int x = PopTaggedInt();
- int y = PopTaggedInt();
- if (y == 0) {
- return (raiseDiv0("remInt"));
- }
- PushTaggedInt(x%y);
- }
- break;
- case i_quotRemInt:
- {
- StgInt x = PopTaggedInt();
- StgInt y = PopTaggedInt();
- if (y == 0) {
- return (raiseDiv0("quotRemInt"));
- }
- PushTaggedInt(x%y); /* last result */
- PushTaggedInt(x/y); /* first result */
- }
- break;
- case i_negateInt: OP_I_I(-x); break;
-
- case i_andInt: OP_II_I(x&y); break;
- case i_orInt: OP_II_I(x|y); break;
- case i_xorInt: OP_II_I(x^y); break;
- case i_notInt: OP_I_I(~x); break;
- case i_shiftLInt: OP_II_I(x<<y); break;
- case i_shiftRAInt: OP_II_I(x>>y); break; /* ToDo */
- case i_shiftRLInt: OP_II_I(x>>y); break; /* ToDo */
-
- case i_gtWord: OP_WW_B(x>y); break;
- case i_geWord: OP_WW_B(x>=y); break;
- case i_eqWord: OP_WW_B(x==y); break;
- case i_neWord: OP_WW_B(x!=y); break;
- case i_ltWord: OP_WW_B(x<y); break;
- case i_leWord: OP_WW_B(x<=y); break;
- case i_minWord: OP__W(0); break;
- case i_maxWord: OP__W(UINT_MAX); break;
- case i_plusWord: OP_WW_W(x+y); break;
- case i_minusWord: OP_WW_W(x-y); break;
- case i_timesWord: OP_WW_W(x*y); break;
- case i_quotWord:
- {
- StgWord x = PopTaggedWord();
- StgWord y = PopTaggedWord();
- if (y == 0) {
- return (raiseDiv0("quotWord"));
- }
- PushTaggedWord(x/y);
- }
- break;
- case i_remWord:
- {
- StgWord x = PopTaggedWord();
- StgWord y = PopTaggedWord();
- if (y == 0) {
- return (raiseDiv0("remWord"));
- }
- PushTaggedWord(x%y);
- }
- break;
- case i_quotRemWord:
- {
- StgWord x = PopTaggedWord();
- StgWord y = PopTaggedWord();
- if (y == 0) {
- return (raiseDiv0("quotRemWord"));
- }
- PushTaggedWord(x%y); /* last result */
- PushTaggedWord(x/y); /* first result */
- }
- break;
- case i_negateWord: OP_W_W(-x); break;
- case i_andWord: OP_WW_W(x&y); break;
- case i_orWord: OP_WW_W(x|y); break;
- case i_xorWord: OP_WW_W(x^y); break;
- case i_notWord: OP_W_W(~x); break;
- case i_shiftLWord: OP_WW_W(x<<y); break;
- case i_shiftRAWord: OP_WW_W(x>>y); break; /* ToDo */
- case i_shiftRLWord: OP_WW_W(x>>y); break; /* ToDo */
- case i_intToWord: OP_I_W(x); break;
- case i_wordToInt: OP_W_I(x); break;
-
- case i_gtAddr: OP_AA_B(x>y); break;
- case i_geAddr: OP_AA_B(x>=y); break;
- case i_eqAddr: OP_AA_B(x==y); break;
- case i_neAddr: OP_AA_B(x!=y); break;
- case i_ltAddr: OP_AA_B(x<y); break;
- case i_leAddr: OP_AA_B(x<=y); break;
- 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((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;
- case i_writeCharOffAddr: OP_AIC_(writeCharOffAddrzh(x,y,z)); break;
-
- case i_indexIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
- case i_readIntOffAddr: OP_AI_I(indexIntOffAddrzh(r,x,y)); break;
- case i_writeIntOffAddr: OP_AII_(writeIntOffAddrzh(x,y,z)); break;
-
- case i_indexAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
- case i_readAddrOffAddr: OP_AI_A(indexAddrOffAddrzh(r,x,y)); break;
- case i_writeAddrOffAddr: OP_AIA_(writeAddrOffAddrzh(x,y,z)); break;
-
- case i_indexFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
- case i_readFloatOffAddr: OP_AI_F(indexFloatOffAddrzh(r,x,y)); break;
- case i_writeFloatOffAddr: OP_AIF_(writeFloatOffAddrzh(x,y,z)); break;
-
- case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
- case i_readDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y)); break;
- case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z)); break;
-
- 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;
-
- case i_compareInteger:
- {
- B* x = IntegerInsideByteArray(PopPtr());
- B* y = IntegerInsideByteArray(PopPtr());
- StgInt r = do_cmp(x,y);
- PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
- }
- break;
- case i_negateInteger: OP_Z_Z(neg); break;
- case i_plusInteger: OP_ZZ_Z(add); break;
- case i_minusInteger: OP_ZZ_Z(sub); break;
- case i_timesInteger: OP_ZZ_Z(mul); break;
- case i_quotRemInteger:
- {
- B* x = IntegerInsideByteArray(PopPtr());
- B* y = IntegerInsideByteArray(PopPtr());
- int n = size_qrm(x,y);
- StgPtr q = CreateByteArrayToHoldInteger(n);
- StgPtr r = CreateByteArrayToHoldInteger(n);
- if (do_getsign(y)==0)
- return (raiseDiv0("quotRemInteger"));
- do_qrm(x,y,n,IntegerInsideByteArray(q),
- IntegerInsideByteArray(r));
- SloppifyIntegerEnd(q);
- SloppifyIntegerEnd(r);
- PushPtr(r);
- PushPtr(q);
- }
- break;
- case i_intToInteger:
- {
- int n = size_fromInt();
- StgPtr p = CreateByteArrayToHoldInteger(n);
- do_fromInt( PopTaggedInt(), n, IntegerInsideByteArray(p));
- PushPtr(p);
- }
- break;
- case i_wordToInteger:
- {
- int n = size_fromWord();
- StgPtr p = CreateByteArrayToHoldInteger(n);
- do_fromWord( PopTaggedWord(), n, IntegerInsideByteArray(p));
- PushPtr(p);
- }
- break;
- case i_integerToInt: PushTaggedInt(do_toInt(
- IntegerInsideByteArray(PopPtr())
- ));
- break;
-
- case i_integerToWord: PushTaggedWord(do_toWord(
- IntegerInsideByteArray(PopPtr())
- ));
- break;
-
- case i_integerToFloat: PushTaggedFloat(do_toFloat(
- IntegerInsideByteArray(PopPtr())
- ));
- break;
-
- case i_integerToDouble: PushTaggedDouble(do_toDouble(
- IntegerInsideByteArray(PopPtr())
- ));
- break;
-
- case i_gtFloat: OP_FF_B(x>y); break;
- case i_geFloat: OP_FF_B(x>=y); break;
- case i_eqFloat: OP_FF_B(x==y); break;
- case i_neFloat: OP_FF_B(x!=y); break;
- case i_ltFloat: OP_FF_B(x<y); break;
- case i_leFloat: OP_FF_B(x<=y); break;
- case i_minFloat: OP__F(FLT_MIN); break;
- case i_maxFloat: OP__F(FLT_MAX); break;
- case i_radixFloat: OP__I(FLT_RADIX); break;
- case i_digitsFloat: OP__I(FLT_MANT_DIG); break;
- case i_minExpFloat: OP__I(FLT_MIN_EXP); break;
- case i_maxExpFloat: OP__I(FLT_MAX_EXP); break;
- case i_plusFloat: OP_FF_F(x+y); break;
- case i_minusFloat: OP_FF_F(x-y); break;
- case i_timesFloat: OP_FF_F(x*y); break;
- case i_divideFloat:
- {
- StgFloat x = PopTaggedFloat();
- StgFloat y = PopTaggedFloat();
- PushTaggedFloat(x/y);
- }
- break;
- case i_negateFloat: OP_F_F(-x); break;
- case i_floatToInt: OP_F_I(x); break;
- case i_intToFloat: OP_I_F(x); break;
- case i_expFloat: OP_F_F(exp(x)); break;
- case i_logFloat: OP_F_F(log(x)); break;
- case i_sqrtFloat: OP_F_F(sqrt(x)); break;
- case i_sinFloat: OP_F_F(sin(x)); break;
- case i_cosFloat: OP_F_F(cos(x)); break;
- case i_tanFloat: OP_F_F(tan(x)); break;
- case i_asinFloat: OP_F_F(asin(x)); break;
- case i_acosFloat: OP_F_F(acos(x)); break;
- case i_atanFloat: OP_F_F(atan(x)); break;
- case i_sinhFloat: OP_F_F(sinh(x)); break;
- case i_coshFloat: OP_F_F(cosh(x)); break;
- case i_tanhFloat: OP_F_F(tanh(x)); break;
- case i_powerFloat: OP_FF_F(pow(x,y)); break;
-
- case i_encodeFloatZ:
- {
- StgPtr sig = PopPtr();
- StgInt exp = PopTaggedInt();
- PushTaggedFloat(
- B__encodeFloat(IntegerInsideByteArray(sig), exp)
- );
- }
- break;
- case i_decodeFloatZ:
- {
- StgFloat f = PopTaggedFloat();
- StgPtr sig = CreateByteArrayToHoldInteger(size_fltmantissa());
- StgInt exp;
- B__decodeFloat(IntegerInsideByteArray(sig), &exp, f);
- PushTaggedInt(exp);
- PushPtr(sig);
- }
- break;
-
- 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_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
- case i_gtDouble: OP_DD_B(x>y); break;
- case i_geDouble: OP_DD_B(x>=y); break;
- case i_eqDouble: OP_DD_B(x==y); break;
- case i_neDouble: OP_DD_B(x!=y); break;
- case i_ltDouble: OP_DD_B(x<y); break;
- case i_leDouble: OP_DD_B(x<=y) break;
- case i_minDouble: OP__D(DBL_MIN); break;
- case i_maxDouble: OP__D(DBL_MAX); break;
- case i_radixDouble: OP__I(FLT_RADIX); break;
- case i_digitsDouble: OP__I(DBL_MANT_DIG); break;
- case i_minExpDouble: OP__I(DBL_MIN_EXP); break;
- case i_maxExpDouble: OP__I(DBL_MAX_EXP); break;
- case i_plusDouble: OP_DD_D(x+y); break;
- case i_minusDouble: OP_DD_D(x-y); break;
- case i_timesDouble: OP_DD_D(x*y); break;
- case i_divideDouble:
- {
- StgDouble x = PopTaggedDouble();
- StgDouble y = PopTaggedDouble();
- PushTaggedDouble(x/y);
- }
- break;
- case i_negateDouble: OP_D_D(-x); break;
- case i_doubleToInt: OP_D_I(x); break;
- case i_intToDouble: OP_I_D(x); break;
- case i_doubleToFloat: OP_D_F(x); break;
- case i_floatToDouble: OP_F_F(x); break;
- case i_expDouble: OP_D_D(exp(x)); break;
- case i_logDouble: OP_D_D(log(x)); break;
- case i_sqrtDouble: OP_D_D(sqrt(x)); break;
- case i_sinDouble: OP_D_D(sin(x)); break;
- case i_cosDouble: OP_D_D(cos(x)); break;
- case i_tanDouble: OP_D_D(tan(x)); break;
- case i_asinDouble: OP_D_D(asin(x)); break;
- case i_acosDouble: OP_D_D(acos(x)); break;
- case i_atanDouble: OP_D_D(atan(x)); break;
- case i_sinhDouble: OP_D_D(sinh(x)); break;
- case i_coshDouble: OP_D_D(cosh(x)); break;
- case i_tanhDouble: OP_D_D(tanh(x)); break;
- case i_powerDouble: OP_DD_D(pow(x,y)); break;
-
- case i_encodeDoubleZ:
- {
- StgPtr sig = PopPtr();
- StgInt exp = PopTaggedInt();
- PushTaggedDouble(
- B__encodeDouble(IntegerInsideByteArray(sig), exp)
- );
- }
- break;
- case i_decodeDoubleZ:
- {
- StgDouble d = PopTaggedDouble();
- StgPtr sig = CreateByteArrayToHoldInteger(size_dblmantissa());
- StgInt exp;
- B__decodeDouble(IntegerInsideByteArray(sig), &exp, d);
- PushTaggedInt(exp);
- PushPtr(sig);
- }
- break;
-
- 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;
- case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
- case i_isIEEEDouble:
- {
- PushTaggedBool(rtsTrue);
- }
- break;
- default:
- barf("Unrecognised primop1");
- }
- return NULL;
-}
-
-
-
-/* For normal cases, return NULL and leave *return2 unchanged.
- To return the address of the next thing to enter,
- 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,
- HugsBlock *hugsBlock )
-{
- if (combined) {
- /* A small concession: we need to allow ccalls,
- even in combined mode.
- */
- if (primop2code != i_ccall_ccall_IO &&
- primop2code != i_ccall_stdcall_IO)
- barf("enterBCO_primop2 in combined mode");
- }
-
- switch (primop2code) {
- case i_raise: /* raise#{err} */
- {
- StgClosure* err = PopCPtr();
- return (raiseAnError(err));
- }
-#ifdef XMLAMBDA
-/*------------------------------------------------------------------------
- Insert and Remove primitives on Rows. 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:
- {
- StgClosure* init = PopCPtr();
- StgMutVar* mv
- = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
- SET_HDR(mv,&MUT_VAR_info,CCCS);
- mv->var = init;
- PushPtr(stgCast(StgPtr,mv));
- break;
- }
- case i_readRef:
- {
- StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
- PushCPtr(mv->var);
- break;
- }
- case i_writeRef:
- {
- StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
- StgClosure* value = PopCPtr();
- mv->var = value;
- break;
- }
- case i_newArray:
- {
- nat n = PopTaggedInt(); /* or Word?? */
- StgClosure* init = PopCPtr();
- StgWord size = sizeofW(StgMutArrPtrs) + n;
- nat i;
- StgMutArrPtrs* arr
- = stgCast(StgMutArrPtrs*,allocate(size));
- SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
- arr->ptrs = n;
- for (i = 0; i < n; ++i) {
- arr->payload[i] = init;
- }
- PushPtr(stgCast(StgPtr,arr));
- break;
- }
- case i_readArray:
- case i_indexArray:
- {
- StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
- nat i = PopTaggedInt(); /* or Word?? */
- StgWord n = arr->ptrs;
- if (i >= n) {
- return (raiseIndex("{index,read}Array"));
- }
- PushCPtr(arr->payload[i]);
- break;
- }
- case i_writeArray:
- {
- StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
- nat i = PopTaggedInt(); /* or Word? */
- StgClosure* v = PopCPtr();
- StgWord n = arr->ptrs;
- if (i >= n) {
- return (raiseIndex("{index,read}Array"));
- }
- arr->payload[i] = v;
- break;
- }
- case i_sizeArray:
- case i_sizeMutableArray:
- {
- StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
- PushTaggedInt(arr->ptrs);
- break;
- }
- case i_unsafeFreezeArray:
- {
- StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
- SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
- PushPtr(stgCast(StgPtr,arr));
- break;
- }
- case i_unsafeFreezeByteArray:
- {
- /* Delightfully simple :-) */
- break;
- }
- case i_sameRef:
- case i_sameMutableArray:
- case i_sameMutableByteArray:
- {
- StgPtr x = PopPtr();
- StgPtr y = PopPtr();
- PushTaggedBool(x==y);
- break;
- }
-
- case i_newByteArray:
- {
- nat n = PopTaggedInt(); /* or Word?? */
- StgInt words = (n+sizeof(W_)-1)/sizeof(W_);
- StgWord size = sizeofW(StgArrWords) + words;
- StgArrWords* arr = stgCast(StgArrWords*,allocate(size));
- SET_HDR(arr,&ARR_WORDS_info,CCCS);
- arr->words = words;
-#ifdef DEBUG
- {nat i;
- for (i = 0; i < n; ++i) {
- arr->payload[i] = 0xdeadbeef;
- }}
-#endif
- PushPtr(stgCast(StgPtr,arr));
- break;
- }
-
- /* 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:
- OP_mI_ty(Char,"indexCharArray", indexCharArrayzh(r,x,i)); break;
- case i_readCharArray:
- OP_mI_ty(Char,"readCharArray", readCharArrayzh(r,x,i)); break;
- case i_writeCharArray:
- OP_mIty_(Char,"writeCharArray", writeCharArrayzh(x,i,z)); break;
-
- case i_indexIntArray:
- OP_mI_ty(Int,"indexIntArray", indexIntArrayzh(r,x,i)); break;
- case i_readIntArray:
- OP_mI_ty(Int,"readIntArray", readIntArrayzh(r,x,i)); break;
- case i_writeIntArray:
- OP_mIty_(Int,"writeIntArray", writeIntArrayzh(x,i,z)); break;
-
- case i_indexAddrArray:
- OP_mI_ty(Addr,"indexAddrArray", indexAddrArrayzh(r,x,i)); break;
- case i_readAddrArray:
- OP_mI_ty(Addr,"readAddrArray", readAddrArrayzh(r,x,i)); break;
- case i_writeAddrArray:
- OP_mIty_(Addr,"writeAddrArray", writeAddrArrayzh(x,i,z)); break;
-
- case i_indexFloatArray:
- OP_mI_ty(Float,"indexFloatArray", indexFloatArrayzh(r,x,i)); break;
- case i_readFloatArray:
- OP_mI_ty(Float,"readFloatArray", readFloatArrayzh(r,x,i)); break;
- case i_writeFloatArray:
- OP_mIty_(Float,"writeFloatArray", writeFloatArrayzh(x,i,z)); break;
-
- case i_indexDoubleArray:
- OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break;
- case i_readDoubleArray:
- OP_mI_ty(Double,"readDoubleArray", readDoubleArrayzh(r,x,i)); break;
- 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;
- case i_readStableArray:
- OP_mI_ty(StablePtr,"readStableArray", readStablePtrArrayzh(r,x,i)); break;
- case i_writeStableArray:
- OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
-#endif
-#endif
-
-
+/* Sp points to the lowest live word on the stack. */
-#ifdef PROVIDE_COERCE
- case i_unsafeCoerce:
- {
- /* Another nullop */
- break;
- }
-#endif
-#ifdef PROVIDE_PTREQUALITY
- case i_reallyUnsafePtrEquality:
- { /* identical to i_sameRef */
- StgPtr x = PopPtr();
- StgPtr y = PopPtr();
- PushTaggedBool(x==y);
- break;
- }
-#endif
-#ifdef PROVIDE_FOREIGN
- /* ForeignObj# operations */
- case i_mkForeignObj:
- {
- StgForeignObj *result
- = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
- SET_HDR(result,&FOREIGN_info,CCCS);
- result -> data = PopTaggedAddr();
- PushPtr(stgCast(StgPtr,result));
- break;
- }
-#endif /* PROVIDE_FOREIGN */
-#ifdef PROVIDE_WEAK
- case i_makeWeak:
- {
- StgWeak *w
- = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
- SET_HDR(w, &WEAK_info, CCCS);
- w->key = PopCPtr();
- w->value = PopCPtr();
- w->finaliser = PopCPtr();
- w->link = weak_ptr_list;
- weak_ptr_list = w;
- IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
- PushPtr(stgCast(StgPtr,w));
- break;
- }
- case i_deRefWeak:
- {
- StgWeak *w = stgCast(StgWeak*,PopPtr());
- if (w->header.info == &WEAK_info) {
- PushCPtr(w->value); /* last result */
- PushTaggedInt(1); /* first result */
- } else {
- PushPtr(stgCast(StgPtr,w));
- /* ToDo: error thunk would be better */
- PushTaggedInt(0);
- }
- break;
- }
-#endif /* PROVIDE_WEAK */
-
- case i_makeStablePtr:
- {
- StgPtr p = PopPtr();
- StgStablePtr sp = getStablePtr ( p );
- PushTaggedStablePtr(sp);
- break;
- }
- case i_deRefStablePtr:
- {
- StgPtr p;
- StgStablePtr sp = PopTaggedStablePtr();
- p = deRefStablePtr(sp);
- PushPtr(p);
- break;
- }
- case i_freeStablePtr:
- {
- StgStablePtr sp = PopTaggedStablePtr();
- freeStablePtr(sp);
- break;
- }
-
- case i_createAdjThunkARCH:
- {
- StgStablePtr stableptr = PopTaggedStablePtr();
- StgAddr typestr = PopTaggedAddr();
- StgChar callconv = PopTaggedChar();
- StgAddr adj_thunk = createAdjThunk(stableptr,typestr,callconv);
- PushTaggedAddr(adj_thunk);
- break;
- }
-
- case i_getArgc:
- {
- StgInt n = prog_argc;
- PushTaggedInt(n);
- break;
- }
- 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 = (StgTSO *)&END_TSO_QUEUE_closure;
- mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
- PushPtr(stgCast(StgPtr,mvar));
- break;
- }
- case i_takeMVar:
- {
- 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 = (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+(char*)(NULL));
-
- } else {
- PushCPtr(mvar->value);
- mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
- SET_INFO(mvar,&EMPTY_MVAR_info);
- }
- break;
- }
- case i_putMVar:
- {
- StgMVar* mvar = stgCast(StgMVar*,PopPtr());
- StgClosure* value = PopCPtr();
- if (GET_INFO(mvar) == &FULL_MVAR_info) {
- 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.
- */
- mvar->value = value;
-
- 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;
- }
- break;
- }
- case i_sameMVar:
- { /* identical to i_sameRef */
- StgMVar* x = (StgMVar*)PopPtr();
- StgMVar* y = (StgMVar*)PopPtr();
- PushTaggedBool(x==y);
- break;
- }
-#ifdef PROVIDE_CONCURRENT
- case i_forkIO:
- {
- StgClosure* closure;
- StgTSO* tso;
- StgWord tid;
- closure = PopCPtr();
- tso = createGenThread (RtsFlags.GcFlags.initialStkSize,closure);
- tid = tso->id;
- scheduleThread(tso);
- context_switch = 1;
- /* Later: Change to use tso as the ThreadId */
- PushTaggedWord(tid);
- break;
- }
-
- case i_killThread:
- {
- StgWord n = PopTaggedWord();
- StgTSO* tso = 0;
- StgTSO *t;
-
- // Map from ThreadId to Thread Structure */
- for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
- if (n == t->id)
- tso = t;
- }
- if (tso == 0) {
- // Already dead
- break;
- }
-
- while (tso->what_next == ThreadRelocated) {
- tso = tso->link;
- }
-
- deleteThread(tso);
- if (tso == cap->rCurrentTSO) { /* suicide */
- *return2 = ThreadFinished;
- return (void*)(1+(char*)(NULL));
- }
- break;
- }
- case i_raiseInThread:
- 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:
- {
- 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:
- 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");
- }
- return NULL;
-}
-
-
-/* -----------------------------------------------------------------------------
- * 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 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 regSponse to
- * Haskell calling C.
- */
-nat marshall(char arg_ty, void* arg)
-{
- switch (arg_ty) {
- case INT_REP:
- PushTaggedInt(*((int*)arg));
- return ARG_SIZE(INT_TAG);
-#if 0
- case INTEGER_REP:
- PushTaggedInteger(*((mpz_ptr*)arg));
- return ARG_SIZE(INTEGER_TAG);
-#endif
- case WORD_REP:
- PushTaggedWord(*((unsigned int*)arg));
- return ARG_SIZE(WORD_TAG);
- case CHAR_REP:
- PushTaggedChar(*((char*)arg));
- return ARG_SIZE(CHAR_TAG);
- case FLOAT_REP:
- PushTaggedFloat(*((float*)arg));
- return ARG_SIZE(FLOAT_TAG);
- case DOUBLE_REP:
- PushTaggedDouble(*((double*)arg));
- return ARG_SIZE(DOUBLE_TAG);
- case ADDR_REP:
- PushTaggedAddr(*((void**)arg));
- return ARG_SIZE(ADDR_TAG);
- case STABLE_REP:
- PushTaggedStablePtr(*((StgStablePtr*)arg));
- return ARG_SIZE(STABLE_TAG);
-#ifdef PROVIDE_FOREIGN
- case FOREIGN_REP:
- /* Not allowed in this direction - you have to
- * call makeForeignPtr explicitly
- */
- barf("marshall: ForeignPtr#\n");
- break;
-#endif
- case BARR_REP:
- case MUTBARR_REP:
- /* Not allowed in this direction */
- barf("marshall: [Mutable]ByteArray#\n");
- break;
- default:
- barf("marshall: unrecognised arg type %d\n",arg_ty);
- break;
- }
-}
-
-/* Pop arguments off the Hugs stack and Push them onto the C stack.
- * Used when preparing for Haskell calling C or in regSponse to
- * C calling Haskell.
- */
-nat unmarshall(char res_ty, void* res)
-{
- switch (res_ty) {
- case INT_REP:
- *((int*)res) = PopTaggedInt();
- return ARG_SIZE(INT_TAG);
-#if 0
- case INTEGER_REP:
- *((mpz_ptr*)res) = PopTaggedInteger();
- return ARG_SIZE(INTEGER_TAG);
-#endif
- case WORD_REP:
- *((unsigned int*)res) = PopTaggedWord();
- return ARG_SIZE(WORD_TAG);
- case CHAR_REP:
- *((int*)res) = PopTaggedChar();
- return ARG_SIZE(CHAR_TAG);
- case FLOAT_REP:
- *((float*)res) = PopTaggedFloat();
- return ARG_SIZE(FLOAT_TAG);
- case DOUBLE_REP:
- *((double*)res) = PopTaggedDouble();
- return ARG_SIZE(DOUBLE_TAG);
- case ADDR_REP:
- *((void**)res) = PopTaggedAddr();
- return ARG_SIZE(ADDR_TAG);
- case STABLE_REP:
- *((StgStablePtr*)res) = PopTaggedStablePtr();
- return ARG_SIZE(STABLE_TAG);
-#ifdef PROVIDE_FOREIGN
- case FOREIGN_REP:
- {
- StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
- *((void**)res) = result->data;
- return sizeofW(StgPtr);
- }
-#endif
- case BARR_REP:
- case MUTBARR_REP:
- {
- StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
- *((void**)res) = stgCast(void*,&(arr->payload));
- return sizeofW(StgPtr);
- }
- default:
- barf("unmarshall: unrecognised result type %d\n",res_ty);
- }
-}
-
-nat argSize( const char* ks )
-{
- nat sz = 0;
- for( ; *ks != '\0'; ++ks) {
- switch (*ks) {
- case INT_REP:
- sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
- break;
-#if 0
- case INTEGER_REP:
- sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
- break;
-#endif
- case WORD_REP:
- sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
- break;
- case CHAR_REP:
- sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
- break;
- case FLOAT_REP:
- sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
- break;
- case DOUBLE_REP:
- sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
- break;
- case ADDR_REP:
- sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
- break;
- case STABLE_REP:
- sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
- break;
-#ifdef PROVIDE_FOREIGN
- case FOREIGN_REP:
-#endif
- case BARR_REP:
- case MUTBARR_REP:
- sz += sizeof(StgPtr);
- break;
- default:
- barf("argSize: unrecognised result type %d\n",*ks);
- break;
- }
- }
- return sz;
-}
-
-
-/* -----------------------------------------------------------------------------
- * encode/decode Float/Double code for standalone Hugs
- * Code based on the HBC code (lib/fltcode.c) and more recently GHC
- * (ghc/rts/StgPrimFloat.c)
- * ---------------------------------------------------------------------------*/
+#define StackWord(n) ((W_*)Sp)[n]
+#define BCO_NEXT bco_instrs[bciPtr++]
+#define BCO_PTR(n) bco_ptrs[n]
-#if IEEE_FLOATING_POINT
-#define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
-/* DMINEXP is defined in values.h on Linux (for example) */
-#define DHIGHBIT 0x00100000
-#define DMSBIT 0x80000000
-#define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
-#define FHIGHBIT 0x00800000
-#define FMSBIT 0x80000000
-#else
-#error The following code doesnt work in a non-IEEE FP environment
-#endif
-
-#ifdef WORDS_BIGENDIAN
-#define L 1
-#define H 0
-#else
-#define L 0
-#define H 1
-#endif
-
-
-StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */
{
- StgDouble r;
- I_ i;
-
- /* Convert a B to a double; knows a lot about internal rep! */
- for(r = 0.0, i = s->used-1; i >= 0; i--)
- r = (r * B_BASE_FLT) + s->stuff[i];
-
- /* Now raise to the exponent */
- if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
- r = ldexp(r, e);
-
- /* handle the sign */
- if (s->sign < 0) r = -r;
-
- return r;
-}
-
-
-
-StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */
-{
- StgFloat r;
- I_ i;
-
- /* Convert a B to a float; knows a lot about internal rep! */
- for(r = 0.0, i = s->used-1; i >= 0; i--)
- r = (r * B_BASE_FLT) + s->stuff[i];
-
- /* Now raise to the exponent */
- if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
- r = ldexp(r, e);
-
- /* handle the sign */
- if (s->sign < 0) r = -r;
-
- return r;
-}
-
-
-
-/* This only supports IEEE floating point */
-void B__decodeDouble (B* man, I_* exp, StgDouble dbl)
-{
- /* Do some bit fiddling on IEEE */
- nat low, high; /* assuming 32 bit ints */
- int sign, iexp;
- union { double d; int i[2]; } u; /* assuming 32 bit ints, 64 bit double */
-
- u.d = dbl; /* grab chunks of the double */
- low = u.i[L];
- high = u.i[H];
-
- ASSERT(B_BASE == 256);
-
- /* Assume that the supplied B is the right size */
- man->size = 8;
-
- if (low == 0 && (high & ~DMSBIT) == 0) {
- man->sign = man->used = 0;
- *exp = 0L;
- } else {
- man->used = 8;
- man->sign = 1;
- iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
- sign = high;
-
- high &= DHIGHBIT-1;
- if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
- high |= DHIGHBIT;
- else {
- iexp++;
- /* A denorm, normalize the mantissa */
- while (! (high & DHIGHBIT)) {
- high <<= 1;
- if (low & DMSBIT)
- high++;
- low <<= 1;
- iexp--;
- }
- }
- *exp = (I_) iexp;
-
- man->stuff[7] = (((W_)high) >> 24) & 0xff;
- man->stuff[6] = (((W_)high) >> 16) & 0xff;
- man->stuff[5] = (((W_)high) >> 8) & 0xff;
- man->stuff[4] = (((W_)high) ) & 0xff;
-
- man->stuff[3] = (((W_)low) >> 24) & 0xff;
- man->stuff[2] = (((W_)low) >> 16) & 0xff;
- man->stuff[1] = (((W_)low) >> 8) & 0xff;
- man->stuff[0] = (((W_)low) ) & 0xff;
-
- if (sign < 0) man->sign = -1;
- }
- do_renormalise(man);
-}
-
-
-void B__decodeFloat (B* man, I_* exp, StgFloat flt)
-{
- /* Do some bit fiddling on IEEE */
- int high, sign; /* assuming 32 bit ints */
- union { float f; int i; } u; /* assuming 32 bit float and int */
-
- u.f = flt; /* grab the float */
- high = u.i;
-
- ASSERT(B_BASE == 256);
-
- /* Assume that the supplied B is the right size */
- man->size = 4;
-
- if ((high & ~FMSBIT) == 0) {
- man->sign = man->used = 0;
- *exp = 0;
- } else {
- man->used = 4;
- man->sign = 1;
- *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
- sign = high;
-
- high &= FHIGHBIT-1;
- if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
- high |= FHIGHBIT;
- else {
- (*exp)++;
- /* A denorm, normalize the mantissa */
- while (! (high & FHIGHBIT)) {
- high <<= 1;
- (*exp)--;
- }
+ case bci_PUSH_L: {
+ int o1 = BCO_NEXT;
+ StackWord(-1) = StackWord(o1);
+ Sp--;
+ break;
+ }
+ case bci_PUSH_LL: {
+ int o1 = BCO_NEXT;
+ int o2 = BCO_NEXT;
+ StackWord(-1) = StackWord(o1);
+ StackWord(-2) = StackWord(o2);
+ Sp -= 2;
+ break;
+ }
+ case bci_PUSH_LLL: {
+ int o1 = BCO_NEXT;
+ int o2 = BCO_NEXT;
+ int o3 = BCO_NEXT;
+ StackWord(-1) = StackWord(o1);
+ StackWord(-2) = StackWord(o2);
+ StackWord(-3) = StackWord(o3);
+ Sp -= 3;
+ break;
+ }
+ case bci_PUSH_G: {
+ int o1 = BCO_NEXT;
+ StackWord(-1) = BCO_PTR(o1);
+ Sp -= 3;
+ break;
+ }
+ case bci_PUSH_AS: {
+ int o_bco = BCO_NEXT;
+ int o_itbl = BCO_NEXT;
+ StackWord(-1) = BCO_LITW(o_itbl);
+ StackWord(-2) = BCO_PTR(o_bco);
+ Sp -= 2;
+ break;
+ }
+ case bci_PUSH_LIT:{
+ int o = BCO_NEXT;
+ StackWord(-1) = BCO_LIT(o);
+ Sp --;
+ break;
+ }
+ case bci_PUSH_TAG: {
+ W_ tag = (W_)(BCO_NEXT);
+ StackWord(-1) = tag;
+ Sp --;
+ break;
+ }
+ case bci_SLIDE: {
+ int n = BCO_NEXT;
+ int by = BCO_NEXT;
+ ASSERT(Sp+n+by <= (StgPtr)xSu);
+ /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
+ while(--n >= 0) {
+ StackWord(n+by) = StackWord(n);
+ }
+ Sp += by;
+ break;
+ }
+ case bci_ALLOC: {
+ int n_payload = BCO_NEXT;
+ P_ p = allocate(AP_sizeW(n_payload));
+ StackWord(-1) = p;
+ Sp --;
+ break;
+ }
+ case bci_MKAP: {
+ int off = BCO_NEXT;
+ int n_payload = BCO_NEXT - 1;
+ StgAP_UPD* ap = StackWord(off);
+ ap->n_args = n_payload;
+ ap->fun = (StgClosure*)StackWord(0);
+ for (i = 0; i < n_payload; i++)
+ ap->payload[i] = StackWord(i+1);
}
- man->stuff[3] = (((W_)high) >> 24) & 0xff;
- man->stuff[2] = (((W_)high) >> 16) & 0xff;
- man->stuff[1] = (((W_)high) >> 8) & 0xff;
- man->stuff[0] = (((W_)high) ) & 0xff;
+ Sp += n_payload+1;
+}
+case bci_UNPACK:{
+ /* Unpack N ptr words from t.o.s constructor */
+ int n_words = BCO_NEXT;
+ StgClosure* con = StackWord(0);
+ Sp -= n_words;
+ for (i = 0; i < n_words; i++)
+ StackWord(i) = con->payload[i];
+}
+ case bci_PACK:
+ case bci_TESTLT_I:
+ case bci_TESTEQ_I:
+ case bci_TESTLT_F:
+ case bci_TESTEQ_F:
+ case bci_TESTLT_D:
+ case bci_TESTEQ_D:
+ case bci_TESTLT_P:
+ case bci_TESTEQ_P:
+ case bci_CASEFAIL:
+
+ /* Control-flow ish things */
+ case bci_ARGCHECK:
+ case bci_ENTER:
+ case bci_RETURN:
- if (sign < 0) man->sign = -1;
- }
- do_renormalise(man);
+ /* Errors */
+ case bci_LABEL:
+ default: barf
}
-#endif /* INTERPRETER */
+#endif /* 0 */
projects / ghc-hetmet.git / commitdiff