From ed0c285fe3937e5e53572165f9672dc1dc8ca7a4 Mon Sep 17 00:00:00 2001
From: sewardj <unknown>
Date: Mon, 11 Dec 2000 12:55:43 +0000
Subject: [PATCH] [project @ 2000-12-11 12:55:43 by sewardj] Remove the old
 bytecode interpreter and add the new one.

---
 ghc/rts/{Evaluator.c => Interpreter.c} | 1757 +++-----------------------------
 1 file changed, 117 insertions(+), 1640 deletions(-)
 rename ghc/rts/{Evaluator.c => Interpreter.c} (59%)

diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Interpreter.c
similarity index 59%
rename from ghc/rts/Evaluator.c
rename to ghc/rts/Interpreter.c
index 0ae503e..c412f88 100644
--- a/ghc/rts/Evaluator.c
+++ b/ghc/rts/Interpreter.c
@@ -1,17 +1,17 @@
-
+#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"
@@ -1561,6 +1561,7 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
             }
             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 */
@@ -1877,6 +1878,7 @@ static inline void PopUpdateFrame ( StgClosure* obj )
              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
@@ -2458,1648 +2460,123 @@ static void myStackCheck ( Capability* cap )
 
 
 /* --------------------------------------------------------------------------
- * 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 */
-- 
1.7.10.4