ghc/rts/Interpreter.c

   1 #if 0
   2 /* -----------------------------------------------------------------------------
   3  * Bytecode evaluator
   4  *
   5  * Copyright (c) 1994-2000.
   6  *
   7  * $RCSfile: Interpreter.c,v $
   8  * $Revision: 1.1 $
   9  * $Date: 2000/12/11 12:55:43 $
  10  * ---------------------------------------------------------------------------*/
  11
  12 #include "Rts.h"
  13
  14
  15
  16 #include "RtsFlags.h"
  17 #include "RtsUtils.h"
  18 #include "Updates.h"
  19 #include "Storage.h"
  20 #include "SchedAPI.h" /* for createGenThread */
  21 #include "Schedule.h" /* for context_switch  */
  22 #include "Bytecodes.h"
  23 #include "Assembler.h" /* for CFun stuff */
  24 #include "ForeignCall.h"
  25 #include "PrimOps.h"   /* for __{encode,decode}{Float,Double} */
  26 #include "Prelude.h"
  27 #include "Itimer.h"
  28 #include "Evaluator.h"
  29 #include "sainteger.h"
  30
  31 #ifdef DEBUG
  32 #include "Printer.h"
  33 #include "Disassembler.h"
  34 #include "Sanity.h"
  35 #include "StgRun.h"
  36 #endif
  37
  38 #include <math.h>    /* These are for primops */
  39 #include <limits.h>  /* These are for primops */
  40 #include <float.h>   /* These are for primops */
  41 #ifdef HAVE_IEEE754_H
  42 #include <ieee754.h> /* These are for primops */
  43 #endif
  44
  45
  46 /* Allegedly useful macro, taken from ClosureMacros.h */
  47 #define payloadWord( c, i )   (*stgCast(StgWord*,      ((c)->payload+(i))))
  48 #define payloadPtr( c, i )    (*stgCast(StgPtr*,       ((c)->payload+(i))))
  49
  50 /* An incredibly useful abbreviation.
  51  * Interestingly, there are some uses of END_TSO_QUEUE_closure that
  52  * can't use it because they use the closure at type StgClosure* or
  53  * even StgPtr*.  I suspect they should be changed.  -- ADR
  54  */
  55 #define EndTSOQueue stgCast(StgTSO*,(void*)&END_TSO_QUEUE_closure)
  56
  57 /* These macros are rather delicate - read a good ANSI C book carefully
  58  * before meddling.
  59  */
  60 #define mystr(x)      #x
  61 #define mycat(x,y)    x##y
  62 #define mycat2(x,y)   mycat(x,y)
  63 #define mycat3(x,y,z) mycat2(x,mycat2(y,z))
  64
  65 #if defined(__GNUC__) && !defined(DEBUG)
  66 #define USE_GCC_LABELS 1
  67 #else
  68 #define USE_GCC_LABELS 0
  69 #endif
  70
  71 /* Make it possible for the evaluator to get hold of bytecode
  72    for a given function by name.  Useful but a hack.  Sigh.
  73  */
  74 extern void* /* StgClosure* */ getHugs_BCO_cptr_for ( char* s );
  75 extern int   /* Bool */ combined;
  76
  77
  78
  79 /* --------------------------------------------------------------------------
  80  * Hugs Hooks - a bit of a hack
  81  * ------------------------------------------------------------------------*/
  82
  83 void setRtsFlags( int x );
  84 void setRtsFlags( int x )
  85 {
  86     unsigned int w    = 0x12345678;
  87     unsigned char* pw = (unsigned char *)&w;
  88     if (*pw == 0x78) {
  89        /* little endian */
  90        *(int*)(&(RtsFlags.DebugFlags)) = x;
  91     } else {
  92        /* big endian */
  93        unsigned int w1 = x;
  94        unsigned int w2 = 0;
  95        w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
  96        w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
  97        w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
  98        w2 |= (w1 && 0xFF); w2 <<= 8; w1 >>= 8;
  99        *(int*)(&(RtsFlags.DebugFlags)) = (int)w2;
 100     }
 101 }
 102
 103
 104 typedef struct {
 105   StgTSOBlockReason reason;
 106   unsigned int delay;
 107 } HugsBlock;
 108
 109
 110 /* --------------------------------------------------------------------------
 111  * Entering-objects and bytecode interpreter part of evaluator
 112  * ------------------------------------------------------------------------*/
 113
 114 /* The primop (and all other) parts of this evaluator operate upon the
 115    machine state which lives in MainRegTable.  enter is different:
 116    to make its closure- and bytecode-interpreting loops go fast, some of that
 117    state is pulled out into local vars (viz, registers, if we are lucky).
 118    That means that we need to save(load) the local state at every exit(reentry)
 119    into enter.  That is, around every procedure call it makes.  Blargh!
 120    If you modify this code, __be warned__ it will fail in mysterious ways if
 121    you fail to preserve this property.
 122
 123    Currently the pulled-out state is Sp in xSp, Su in xSu and SpLim in xSpLim.
 124    The SSS macros saves the state back in MainRegTable, and LLL loads it from
 125    MainRegTable.  RETURN(v) does SSS and then returns v; all exits should
 126    be via RETURN and not plain return.
 127
 128    Since xSp, xSu and xSpLim are local vars in enter, they are not visible
 129    in procedures called from enter.  To fix this, either (1) turn the
 130    procedures into macros, so they get copied inline, or (2) bracket
 131    the procedure call with SSS and LLL so that the local and global
 132    machine states are synchronised for the duration of the call.
 133 */
 134
 135
 136 /* Forward decls ... */
 137 static        void* enterBCO_primop1 ( int );
 138 static        void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */,
 139                                        StgBCO**, Capability*, HugsBlock * );
 140 static inline void PopUpdateFrame ( StgClosure* obj );
 141 static inline void PopCatchFrame  ( void );
 142 static inline void PopSeqFrame    ( void );
 143 static inline void PopStopFrame( StgClosure* obj );
 144 static inline void PushTaggedRealWorld( void );
 145 /* static inline void PushTaggedInteger  ( mpz_ptr ); */
 146 static inline StgPtr grabHpUpd( nat size );
 147 static inline StgPtr grabHpNonUpd( nat size );
 148 static        StgClosure* raiseAnError   ( StgClosure* exception );
 149
 150 static int  enterCountI = 0;
 151
 152 StgDouble B__encodeDouble (B* s, I_ e);
 153 void      B__decodeDouble (B* man, I_* exp, StgDouble dbl);
 154 StgFloat  B__encodeFloat (B* s, I_ e);
 155 void      B__decodeFloat (B* man, I_* exp, StgFloat flt);
 156 StgPtr    CreateByteArrayToHoldInteger ( int );
 157 B*        IntegerInsideByteArray ( StgPtr );
 158 void      SloppifyIntegerEnd ( StgPtr );
 159
 160
 161
 162
 163 #define gSp     MainRegTable.rSp
 164 #define gSu     MainRegTable.rSu
 165 #define gSpLim  MainRegTable.rSpLim
 166
 167
 168 /* Macros to save/load local state. */
 169 #ifdef DEBUG
 170 #define SSS { tSp=gSp = xSp; tSu=gSu = xSu; tSpLim=gSpLim = xSpLim; }
 171 #define LLL { tSp=xSp = gSp; tSu=xSu = gSu; tSpLim=xSpLim = gSpLim; }
 172 #else
 173 #define SSS { gSp = xSp; gSu = xSu; gSpLim = xSpLim; }
 174 #define LLL { xSp = gSp; xSu = gSu; xSpLim = gSpLim; }
 175 #endif
 176
 177 #define RETURN(vvv) {                                           \
 178            StgThreadReturnCode retVal=(vvv);                    \
 179            SSS;                                                 \
 180            cap->rCurrentTSO->sp    = gSp;                       \
 181            cap->rCurrentTSO->su    = gSu;                       \
 182            return retVal;                                       \
 183         }
 184
 185
 186 /* Macros to operate directly on the pulled-out machine state.
 187    These mirror some of the small procedures used in the primop code
 188    below, except you have to be careful about side effects,
 189    ie xPushPtr(xStackPtr(n)) won't work!  It certainly isn't the
 190    same as PushPtr(StackPtr(n)).  Also note that (1) some of
 191    the macros, in particular xPopTagged*, do not make the tag
 192    sanity checks that their non-x cousins do, and (2) some of
 193    the macros depend critically on the semantics of C comma
 194    expressions to work properly.
 195 */
 196 #define xPushPtr(ppp)           { xSp--; *xSp=(StgWord)(ppp); }
 197 #define xPopPtr()               ((StgPtr)(*xSp++))
 198
 199 #define xPushCPtr(ppp)          { xSp--; *xSp=(StgWord)(ppp); }
 200 #define xPopCPtr()              ((StgClosure*)(*xSp++))
 201
 202 #define xPushWord(ppp)          { xSp--; *xSp=(StgWord)(ppp); }
 203 #define xPopWord()              ((StgWord)(*xSp++))
 204
 205 #define xStackPtr(nnn)          ((StgPtr)(*(xSp+(nnn))))
 206 #define xStackWord(nnn)         ((StgWord)(*(xSp+(nnn))))
 207 #define xSetStackWord(iii,www)  xSp[iii]=(StgWord)(www)
 208
 209 #define xPushTag(ttt)           { xSp--; *xSp=(StgWord)(ttt); }
 210 #define xPopTag(ttt)            { StackTag t = (StackTag)(*xSp++); \
 211                                   ASSERT(t == ttt); }
 212
 213 #define xPushTaggedInt(xxx)     { xSp -= sizeofW(StgInt); \
 214                                   *xSp = (xxx); xPushTag(INT_TAG); }
 215 #define xTaggedStackInt(iii)    ((StgInt)(*(xSp+1+(iii))))
 216 #define xPopTaggedInt()         ((xSp++,xSp+=sizeofW(StgInt), \
 217                                  (StgInt)(*(xSp-sizeofW(StgInt)))))
 218
 219 #define xPushTaggedWord(xxx)    { xSp -= sizeofW(StgWord); \
 220                                   *xSp = (xxx); xPushTag(WORD_TAG); }
 221 #define xTaggedStackWord(iii)   ((StgWord)(*(xSp+1+(iii))))
 222 #define xPopTaggedWord()        ((xSp++,xSp+=sizeofW(StgWord), \
 223                                  (StgWord)(*(xSp-sizeofW(StgWord)))))
 224
 225 #define xPushTaggedAddr(xxx)    { xSp -= sizeofW(StgAddr); \
 226                                   *xSp = (StgWord)(xxx); xPushTag(ADDR_TAG); }
 227 #define xTaggedStackAddr(iii)   ((StgAddr)(*(xSp+1+(iii))))
 228 #define xPopTaggedAddr()        ((xSp++,xSp+=sizeofW(StgAddr), \
 229                                  (StgAddr)(*(xSp-sizeofW(StgAddr)))))
 230
 231 #define xPushTaggedStable(xxx)  { xSp -= sizeofW(StgStablePtr); \
 232                                   *xSp = (StgWord)(xxx); xPushTag(STABLE_TAG); }
 233 #define xTaggedStackStable(iii) ((StgStablePtr)(*(xSp+1+(iii))))
 234 #define xPopTaggedStable()      ((xSp++,xSp+=sizeofW(StgStablePtr), \
 235                                  (StgStablePtr)(*(xSp-sizeofW(StgStablePtr)))))
 236
 237 #define xPushTaggedChar(xxx)    { xSp -= sizeofW(StgChar); \
 238                                   *xSp = (StgWord)(xxx); xPushTag(CHAR_TAG); }
 239 #define xTaggedStackChar(iii)   ((StgChar)(*(xSp+1+(iii))))
 240 #define xPopTaggedChar()        ((xSp++,xSp+=sizeofW(StgChar), \
 241                                  (StgChar)(*(xSp-sizeofW(StgChar)))))
 242
 243 #define xPushTaggedFloat(xxx)   { xSp -= sizeofW(StgFloat); \
 244                                   ASSIGN_FLT(xSp,xxx); xPushTag(FLOAT_TAG); }
 245 #define xTaggedStackFloat(iii)  PK_FLT(xSp+1+(iii))
 246 #define xPopTaggedFloat()       ((xSp++,xSp+=sizeofW(StgFloat), \
 247                                  PK_FLT(xSp-sizeofW(StgFloat))))
 248
 249 #define xPushTaggedDouble(xxx)  { xSp -= sizeofW(StgDouble); \
 250                                   ASSIGN_DBL(xSp,xxx); xPushTag(DOUBLE_TAG); }
 251 #define xTaggedStackDouble(iii) PK_DBL(xSp+1+(iii))
 252 #define xPopTaggedDouble()      ((xSp++,xSp+=sizeofW(StgDouble), \
 253                                  PK_DBL(xSp-sizeofW(StgDouble))))
 254
 255
 256 #define xPushUpdateFrame(target, xSp_offset)                      \
 257 {                                                                 \
 258    StgUpdateFrame *__frame;                                       \
 259    __frame = (StgUpdateFrame *)(xSp + (xSp_offset)) - 1;          \
 260    SET_INFO(__frame, (StgInfoTable *)&upd_frame_info);            \
 261    __frame->link = xSu;                                           \
 262    __frame->updatee = (StgClosure *)(target);                     \
 263    xSu = __frame;                                                 \
 264 }
 265
 266 #define xPopUpdateFrame(ooo)                                      \
 267 {                                                                 \
 268     /* NB: doesn't assume that Sp == Su */                        \
 269     IF_DEBUG(evaluator,                                           \
 270              fprintf(stderr,  "Updating ");                       \
 271              printPtr(stgCast(StgPtr,xSu->updatee));              \
 272              fprintf(stderr,  " with ");                          \
 273              printObj(ooo);                                       \
 274              fprintf(stderr,"xSp = %p\txSu = %p\n\n", xSp, xSu);  \
 275              );                                                   \
 276     UPD_IND(xSu->updatee,ooo);                                    \
 277     xSp = stgCast(StgStackPtr,xSu) + sizeofW(StgUpdateFrame);     \
 278     xSu = xSu->link;                                              \
 279 }
 280
 281
 282
 283 /* Instruction stream macros */
 284 #define BCO_INSTR_8  *bciPtr++
 285 #define BCO_INSTR_16 ((bciPtr += 2,  (*(bciPtr-2) << 8) + *(bciPtr-1)))
 286 #define PC (bciPtr - &(bcoInstr(bco,0)))
 287
 288
 289 /* State on entry to enter():
 290  *    - current thread  is in cap->rCurrentTSO;
 291  *    - allocation area is in cap->rCurrentNursery & cap->rNursery
 292  */
 293
 294 StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
 295 {
 296    /* use of register here is primarily to make it clear to compilers
 297       that these entities are non-aliasable.
 298    */
 299     register StgPtr           xSp;    /* local state -- stack pointer */
 300     register StgUpdateFrame*  xSu;    /* local state -- frame pointer */
 301     register StgPtr           xSpLim; /* local state -- stack lim pointer */
 302     register StgClosure*      obj;    /* object currently under evaluation */
 303              char             eCount; /* enter counter, for context switching */
 304
 305
 306    HugsBlock hugsBlock = { NotBlocked, 0 };
 307
 308
 309 #ifdef DEBUG
 310     StgPtr tSp; StgUpdateFrame* tSu; StgPtr tSpLim;
 311 #endif
 312
 313     gSp    = cap->rCurrentTSO->sp;
 314     gSu    = cap->rCurrentTSO->su;
 315     gSpLim = cap->rCurrentTSO->stack + RESERVED_STACK_WORDS;
 316
 317 #ifdef DEBUG
 318     /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */
 319     tSp = gSp; tSu = gSu; tSpLim = gSpLim;
 320 #endif
 321
 322     obj    = obj0;
 323     eCount = 0;
 324
 325     /* Load the local state from global state, and Party On, Dudes! */
 326     /* From here onwards, we operate with the local state and
 327        save/reload it as necessary.
 328     */
 329     LLL;
 330
 331     enterLoop:
 332
 333     numEnters++;
 334
 335 #ifdef DEBUG
 336     ASSERT(gSp == tSp);
 337     ASSERT(gSu == tSu);
 338     ASSERT(gSpLim == tSpLim);
 339     IF_DEBUG(evaluator,
 340              SSS;
 341              enterCountI++;
 342              ASSERT(xSpLim <= xSp && xSp <= stgCast(StgPtr,xSu));
 343              fprintf(stderr,
 344              "\n---------------------------------------------------------------\n");
 345              fprintf(stderr,"(%d) Entering: ",enterCountI); printObj(obj);
 346              fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
 347              fprintf(stderr, "\n" );
 348              printStack(xSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,xSu);
 349              fprintf(stderr, "\n\n");
 350              LLL;
 351             );
 352 #endif
 353
 354     if (
 355 #ifdef DEBUG
 356              ((++eCount) & 0x0F) == 0
 357 #else
 358              ++eCount == 0
 359 #endif
 360        ) {
 361        if (context_switch) {
 362          switch(hugsBlock.reason) {
 363          case NotBlocked: {
 364            xPushCPtr(obj); /* code to restart with */
 365            RETURN(ThreadYielding);
 366          }
 367          case BlockedOnDelay: /* fall through */
 368          case BlockedOnRead:  /* fall through */
 369          case BlockedOnWrite: {
 370            ASSERT(cap->rCurrentTSO->why_blocked == NotBlocked);
 371            cap->rCurrentTSO->why_blocked = BlockedOnDelay;
 372            ACQUIRE_LOCK(&sched_mutex);
 373
 374 #if defined(HAVE_SETITIMER) /* || defined(mingw32_TARGET_OS) */
 375            cap->rCurrentTSO->block_info.delay
 376              = hugsBlock.delay + ticks_since_select;
 377 #else
 378            cap->rCurrentTSO->block_info.target
 379              = hugsBlock.delay + getourtimeofday();
 380 #endif
 381            APPEND_TO_BLOCKED_QUEUE(cap->rCurrentTSO);
 382
 383            RELEASE_LOCK(&sched_mutex);
 384
 385            xPushCPtr(obj); /* code to restart with */
 386            RETURN(ThreadBlocked);
 387          }
 388          default:
 389            barf("Unknown context switch reasoning");
 390          }
 391        }
 392     }
 393
 394     switch ( get_itbl(obj)->type ) {
 395     case INVALID_OBJECT:
 396             barf("Invalid object %p",obj);
 397
 398     case BCO: bco_entry:
 399
 400             /* ---------------------------------------------------- */
 401             /* Start of the bytecode evaluator                      */
 402             /* ---------------------------------------------------- */
 403         {
 404 #           if USE_GCC_LABELS
 405 #           define Ins(x)          &&l##x
 406             static void *labs[] = { INSTRLIST };
 407 #           undef Ins
 408 #           define LoopTopLabel
 409 #           define Case(x)         l##x
 410 #           define Continue        goto *labs[BCO_INSTR_8]
 411 #           define Dispatch        Continue;
 412 #           define EndDispatch
 413 #           else
 414 #           define LoopTopLabel    insnloop:
 415 #           define Case(x)         case x
 416 #           define Continue        goto insnloop
 417 #           define Dispatch        switch (BCO_INSTR_8) {
 418 #           define EndDispatch     }
 419 #           endif
 420
 421             register StgWord8* bciPtr; /* instruction pointer */
 422             register StgBCO*   bco = (StgBCO*)obj;
 423             StgWord wantToGC;
 424
 425             /* Don't need to SSS ... LLL around doYouWantToGC */
 426             wantToGC = doYouWantToGC();
 427             if (wantToGC) {
 428                 xPushCPtr((StgClosure*)bco); /* code to restart with */
 429                 RETURN(HeapOverflow);
 430             }
 431
 432             bciPtr = &(bcoInstr(bco,0));
 433
 434             LoopTopLabel
 435
 436             ASSERT((StgWord)(PC) < bco->n_instrs);
 437             IF_DEBUG(evaluator,
 438             fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", xSp, xSu, PC);
 439                     SSS;
 440                     disInstr(bco,PC);
 441                     if (0) { int i;
 442                     fprintf(stderr,"\n");
 443                       for (i = 8; i >= 0; i--)
 444                          fprintf(stderr, "%d  %p\n", i, (StgPtr)(*(gSp+i)));
 445                       }
 446                     fprintf(stderr,"\n");
 447                     LLL;
 448                    );
 449
 450             Dispatch
 451
 452             Case(i_INTERNAL_ERROR):
 453                     barf("INTERNAL_ERROR at %p:%d",bco,PC-1);
 454             Case(i_PANIC):
 455                     barf("PANIC at %p:%d",bco,PC-1);
 456             Case(i_STK_CHECK):
 457                 {
 458                     int n = BCO_INSTR_8;
 459                     if (xSp - n < xSpLim) {
 460                         xPushCPtr((StgClosure*)bco); /* code to restart with */
 461                         RETURN(StackOverflow);
 462                     }
 463                     Continue;
 464                 }
 465             Case(i_STK_CHECK_big):
 466                 {
 467                     int n = BCO_INSTR_16;
 468                     if (xSp - n < xSpLim) {
 469                         xPushCPtr((StgClosure*)bco); /* code to restart with */
 470                         RETURN(StackOverflow);
 471                     }
 472                     Continue;
 473                 }
 474             Case(i_ARG_CHECK):
 475                 {
 476                     nat n = BCO_INSTR_8;
 477                     if ((StgPtr*)(xSp + n) > (StgPtr*)xSu) {
 478                         StgWord words = (P_)xSu - xSp;
 479
 480                         /* first build a PAP */
 481                         ASSERT((P_)xSu >= xSp);  /* was (words >= 0) but that's always true */
 482                         if (words == 0) { /* optimisation */
 483                             /* Skip building the PAP and update with an indirection. */
 484                         } else {
 485                             /* Build the PAP. */
 486                             /* In the evaluator, we avoid the need to do
 487                              * a heap check here by including the size of
 488                              * the PAP in the heap check we performed
 489                              * when we entered the BCO.
 490                              */
 491                              StgInt  i;
 492                              StgPAP* pap;
 493                              SSS; pap = (StgPAP*)grabHpNonUpd(PAP_sizeW(words)); LLL;
 494                              SET_HDR(pap,&PAP_info,CC_pap);
 495                              pap->n_args = words;
 496                              pap->fun = obj;
 497                              for (i = 0; i < (I_)words; ++i) {
 498                                  payloadWord(pap,i) = xSp[i];
 499                              }
 500                              xSp += words;
 501                              obj = stgCast(StgClosure*,pap);
 502                         }
 503
 504                         /* now deal with "update frame" */
 505                         /* as an optimisation, we process all on top of stack */
 506                         /* instead of just the top one */
 507                         ASSERT(xSp==(P_)xSu);
 508                         do {
 509                             switch (get_itbl(xSu)->type) {
 510                                 case CATCH_FRAME:
 511                                     /* Hit a catch frame during an arg satisfaction check,
 512                                      * so the thing returning (1) has not thrown an
 513                                      * exception, and (2) is of functional type.  Just
 514                                      * zap the catch frame and carry on down the stack
 515                                      * (looking for more arguments, basically).
 516                                      */
 517                                      SSS; PopCatchFrame(); LLL;
 518                                      break;
 519                                 case UPDATE_FRAME:
 520                                      xPopUpdateFrame(obj);
 521                                      break;
 522                                 case STOP_FRAME:
 523                                      barf("STOP frame during pap update");
 524 #if 0
 525                                      cap->rCurrentTSO->what_next = ThreadComplete;
 526                                      SSS; PopStopFrame(obj); LLL;
 527                                      RETURN(ThreadFinished);
 528 #endif
 529                                 case SEQ_FRAME:
 530                                      SSS; PopSeqFrame(); LLL;
 531                                      ASSERT(xSp != (P_)xSu);
 532                                      /* Hit a SEQ frame during an arg satisfaction check.
 533                                       * So now return to bco_info which is under the
 534                                       * SEQ frame.  The following code is copied from a
 535                                       * case RET_BCO further down.  (The reason why we're
 536                                       * here is that something of functional type has
 537                                       * been seq-d on, and we're now returning to the
 538                                       * algebraic-case-continuation which forced the
 539                                       * evaluation in the first place.)
 540                                       */
 541                                       {
 542                                           StgClosure* ret;
 543                                           (void)xPopPtr();
 544                                           ret = xPopCPtr();
 545                                           xPushPtr((P_)obj);
 546                                           obj = ret;
 547                                           goto enterLoop;
 548                                       }
 549                                       break;
 550                                 default:
 551                                       barf("Invalid update frame during argcheck");
 552                             }
 553                         } while (xSp==(P_)xSu);
 554                         goto enterLoop;
 555                     }
 556                     Continue;
 557                 }
 558             Case(i_ALLOC_AP):
 559                 {
 560                     StgPtr p;
 561                     int words = BCO_INSTR_8;
 562                     SSS; p = grabHpUpd(AP_sizeW(words)); LLL;
 563                     xPushPtr(p);
 564                     Continue;
 565                 }
 566             Case(i_ALLOC_CONSTR):
 567                 {
 568                     StgPtr p;
 569                     StgInfoTable* info = bcoConstAddr(bco,BCO_INSTR_8);
 570                     SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
 571                     SET_HDR((StgClosure*)p,info,??);
 572                     xPushPtr(p);
 573                     Continue;
 574                 }
 575             Case(i_ALLOC_CONSTR_big):
 576                 {
 577                     StgPtr p;
 578                     int x = BCO_INSTR_16;
 579                     StgInfoTable* info = bcoConstAddr(bco,x);
 580                     SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
 581                     SET_HDR((StgClosure*)p,info,??);
 582                     xPushPtr(p);
 583                     Continue;
 584                 }
 585             Case(i_MKAP):
 586                 {
 587                     int x = BCO_INSTR_8;  /* ToDo: Word not Int! */
 588                     int y = BCO_INSTR_8;
 589                     StgAP_UPD* o = stgCast(StgAP_UPD*,xStackPtr(x));
 590                     SET_HDR(o,&AP_UPD_info,??);
 591                     o->n_args = y;
 592                     o->fun    = stgCast(StgClosure*,xPopPtr());
 593                     for(x=0; x < y; ++x) {
 594                         payloadWord(o,x) = xPopWord();
 595                     }
 596                     IF_DEBUG(evaluator,
 597                              fprintf(stderr,"\tBuilt ");
 598                              SSS;
 599                              printObj(stgCast(StgClosure*,o));
 600                              LLL;
 601                     );
 602                     Continue;
 603                 }
 604             Case(i_MKAP_big):
 605                 {
 606                     int x, y;
 607                     StgAP_UPD* o;
 608                     x = BCO_INSTR_16;
 609                     y = BCO_INSTR_16;
 610                     o = stgCast(StgAP_UPD*,xStackPtr(x));
 611                     SET_HDR(o,&AP_UPD_info,??);
 612                     o->n_args = y;
 613                     o->fun    = stgCast(StgClosure*,xPopPtr());
 614                     for(x=0; x < y; ++x) {
 615                         payloadWord(o,x) = xPopWord();
 616                     }
 617                     IF_DEBUG(evaluator,
 618                              fprintf(stderr,"\tBuilt ");
 619                              SSS;
 620                              printObj(stgCast(StgClosure*,o));
 621                              LLL;
 622                     );
 623                     Continue;
 624                 }
 625             Case(i_MKPAP):
 626                 {
 627                     int x = BCO_INSTR_8;
 628                     int y = BCO_INSTR_8;
 629                     StgPAP* o = stgCast(StgPAP*,xStackPtr(x));
 630                     SET_HDR(o,&PAP_info,??);
 631                     o->n_args = y;
 632                     o->fun    = stgCast(StgClosure*,xPopPtr());
 633                     for(x=0; x < y; ++x) {
 634                         payloadWord(o,x) = xPopWord();
 635                     }
 636                     IF_DEBUG(evaluator,
 637                              fprintf(stderr,"\tBuilt ");
 638                              SSS;
 639                              printObj(stgCast(StgClosure*,o));
 640                              LLL;
 641                             );
 642                     Continue;
 643                 }
 644             Case(i_PACK):
 645                 {
 646                     int offset = BCO_INSTR_8;
 647                     StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
 648                     const StgInfoTable* info = get_itbl(o);
 649                     nat p  = info->layout.payload.ptrs;
 650                     nat np = info->layout.payload.nptrs;
 651                     nat i;
 652                     for(i=0; i < p; ++i) {
 653                         o->payload[i] = xPopCPtr();
 654                     }
 655                     for(i=0; i < np; ++i) {
 656                         payloadWord(o,p+i) = 0xdeadbeef;
 657                     }
 658                     IF_DEBUG(evaluator,
 659                              fprintf(stderr,"\tBuilt ");
 660                              SSS;
 661                              printObj(stgCast(StgClosure*,o));
 662                              LLL;
 663                              );
 664                     Continue;
 665                 }
 666             Case(i_PACK_big):
 667                 {
 668                     int offset = BCO_INSTR_16;
 669                     StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
 670                     const StgInfoTable* info = get_itbl(o);
 671                     nat p  = info->layout.payload.ptrs;
 672                     nat np = info->layout.payload.nptrs;
 673                     nat i;
 674                     for(i=0; i < p; ++i) {
 675                         o->payload[i] = xPopCPtr();
 676                     }
 677                     for(i=0; i < np; ++i) {
 678                         payloadWord(o,p+i) = 0xdeadbeef;
 679                     }
 680                     IF_DEBUG(evaluator,
 681                              fprintf(stderr,"\tBuilt ");
 682                              SSS;
 683                              printObj(stgCast(StgClosure*,o));
 684                              LLL;
 685                              );
 686                     Continue;
 687                 }
 688             Case(i_SLIDE):
 689                 {
 690                     int x = BCO_INSTR_8;
 691                     int y = BCO_INSTR_8;
 692                     ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
 693                     /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
 694                     while(--x >= 0) {
 695                         xSetStackWord(x+y,xStackWord(x));
 696                     }
 697                     xSp += y;
 698                     Continue;
 699                 }
 700             Case(i_SLIDE_big):
 701                 {
 702                     int x, y;
 703                     x = BCO_INSTR_16;
 704                     y = BCO_INSTR_16;
 705                     ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
 706                     /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
 707                     while(--x >= 0) {
 708                         xSetStackWord(x+y,xStackWord(x));
 709                     }
 710                     xSp += y;
 711                     Continue;
 712                 }
 713             Case(i_ENTER):
 714                 {
 715                     obj = xPopCPtr();
 716                     goto enterLoop;
 717                 }
 718             Case(i_RETADDR):
 719                 {
 720                     xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
 721                     xPushPtr(stgCast(StgPtr,&ret_bco_info));
 722                     Continue;
 723                 }
 724             Case(i_TEST):
 725                 {
 726                     int  tag       = BCO_INSTR_8;
 727                     StgWord offset = BCO_INSTR_16;
 728                     if (constrTag( (StgClosure*)xStackPtr(0) ) != tag) {
 729                         bciPtr += offset;
 730                     }
 731                     Continue;
 732                 }
 733             Case(i_UNPACK):
 734                 {
 735                     StgClosure* o = stgCast(StgClosure*,xStackPtr(0));
 736                     const StgInfoTable* itbl = get_itbl(o);
 737                     int i = itbl->layout.payload.ptrs;
 738                     ASSERT(  itbl->type == CONSTR
 739                           || itbl->type == CONSTR_STATIC
 740                           || itbl->type == CONSTR_NOCAF_STATIC
 741                           || itbl->type == CONSTR_1_0
 742                           || itbl->type == CONSTR_0_1
 743                           || itbl->type == CONSTR_2_0
 744                           || itbl->type == CONSTR_1_1
 745                           || itbl->type == CONSTR_0_2
 746                           );
 747                     while (--i>=0) {
 748                         xPushCPtr(o->payload[i]);
 749                     }
 750                     Continue;
 751                 }
 752             Case(i_VAR_big):
 753                 {
 754                     int n = BCO_INSTR_16;
 755                     StgPtr p = xStackPtr(n);
 756                     xPushPtr(p);
 757                     Continue;
 758                 }
 759             Case(i_VAR):
 760                 {
 761                     StgPtr p = xStackPtr(BCO_INSTR_8);
 762                     xPushPtr(p);
 763                     Continue;
 764                 }
 765             Case(i_CONST):
 766                 {
 767                     xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,BCO_INSTR_8)));
 768                     Continue;
 769                 }
 770             Case(i_CONST_big):
 771                 {
 772                     int n = BCO_INSTR_16;
 773                     xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,n)));
 774                     Continue;
 775                 }
 776 #ifdef XMLAMBDA
 777             /* allocate rows, implemented on top of (frozen) Arrays */
 778             Case(i_ALLOC_ROW):
 779                 {
 780                     StgMutArrPtrs* p;
 781                     StgWord n = BCO_INSTR_8;
 782                     SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + n)); LLL;
 783                     SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS);
 784                     p->ptrs = n;
 785                     xPushPtr(p);
 786                     Continue;
 787                 }
 788             Case(i_ALLOC_ROW_big):
 789                 {
 790                     StgMutArrPtrs* p;
 791                     StgWord n = BCO_INSTR_16;
 792                     SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + n)); LLL;
 793                     SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS);
 794                     p->ptrs = n;
 795                     xPushPtr(p);
 796                     Continue;
 797                 }
 798
 799             /* pack values into a row. */
 800             Case(i_PACK_ROW):
 801                 {
 802                     StgWord offset   = BCO_INSTR_8;
 803                     StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(offset));
 804                     StgWord        n = p->ptrs;
 805                     StgWord i;
 806
 807                     for (i=0; i<n; ++i)
 808                     {
 809                       p->payload[i] = xPopCPtr();
 810                     }
 811                     IF_DEBUG(evaluator,
 812                              fprintf(stderr,"\tBuilt ");
 813                              SSS;
 814                              printObj(stgCast(StgClosure*,p));
 815                              LLL;
 816                             );
 817                     Continue;
 818                 }
 819             Case(i_PACK_ROW_big):
 820                 {
 821                     StgWord offset   = BCO_INSTR_16;
 822                     StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(offset));
 823                     StgWord        n = p->ptrs;
 824                     StgWord i;
 825
 826                     for (i=0; i<n; ++i)
 827                     {
 828                       p->payload[i] = xPopCPtr();
 829                     }
 830                     IF_DEBUG(evaluator,
 831                              fprintf(stderr,"\tBuilt ");
 832                              SSS;
 833                              printObj(stgCast(StgClosure*,p));
 834                              LLL;
 835                             );
 836                     Continue;
 837                 }
 838
 839             /* extract all fields of a row */
 840             Case(i_UNPACK_ROW):
 841                 {
 842                     StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(0));
 843                     nat i = p->ptrs;
 844                     while (i > 0)
 845                     {
 846                       i--;
 847                       xPushCPtr(p->payload[i]);
 848                     }
 849                     Continue;
 850                 }
 851
 852             /* Trivial row (unit) */
 853             Case(i_CONST_ROW_TRIV):
 854                 {
 855                     StgMutArrPtrs* p;
 856                     SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + 0)); LLL;
 857                     SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS);
 858                     p->ptrs = 0;
 859                     xPushPtr(p);
 860                     Continue;
 861                 }
 862
 863             /* pack values into an Inj */
 864             Case(i_PACK_INJ_VAR):
 865                 {
 866                     const int size  = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord));
 867                     StgWord offset  = BCO_INSTR_8;
 868
 869                     StgClosure* o;
 870                     SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
 871                     SET_HDR(o,Inj_con_info,??);
 872
 873                     payloadWord(o,sizeofW(StgPtr)) = xTaggedStackWord(offset);
 874                     payloadPtr(o,0)                = xPopPtr();
 875
 876                     IF_DEBUG(evaluator,
 877                              fprintf(stderr,"\tBuilt ");
 878                              SSS;
 879                              printObj(stgCast(StgClosure*,o));
 880                              LLL;
 881                              );
 882                     xPushPtr(stgCast(StgPtr,o));
 883                     Continue;
 884                 }
 885             Case(i_PACK_INJ_VAR_big):
 886                 {
 887                     const int size  = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord));
 888                     StgWord offset  = BCO_INSTR_16;
 889
 890                     StgClosure* o;
 891                     SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
 892                     SET_HDR(o,Inj_con_info,??);
 893
 894                     payloadWord(o,sizeofW(StgPtr)) = xTaggedStackWord(offset);
 895                     payloadPtr(o,0)                = xPopPtr();
 896
 897                     IF_DEBUG(evaluator,
 898                              fprintf(stderr,"\tBuilt ");
 899                              SSS;
 900                              printObj(stgCast(StgClosure*,o));
 901                              LLL;
 902                              );
 903                     xPushPtr(stgCast(StgPtr,o));
 904                     Continue;
 905                 }
 906             Case(i_PACK_INJ_CONST_8):
 907                 {
 908                     const int size  = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord));
 909                     StgWord witness = BCO_INSTR_8;
 910
 911                     StgClosure* o;
 912                     SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
 913                     SET_HDR(o,Inj_con_info,??);
 914
 915                     payloadWord(o,sizeofW(StgPtr)) = witness;
 916                     payloadPtr(o,0)                = xPopPtr();
 917
 918                     IF_DEBUG(evaluator,
 919                              fprintf(stderr,"\tBuilt ");
 920                              SSS;
 921                              printObj(stgCast(StgClosure*,o));
 922                              LLL;
 923                              );
 924                     xPushPtr(stgCast(StgPtr,o));
 925                     Continue;
 926                 }
 927             Case(i_PACK_INJ_REL_8):
 928                 {
 929                     const int size   = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord));
 930                     StgWord offset   = BCO_INSTR_8;
 931                     StgWord cwitness = BCO_INSTR_8;
 932
 933                     StgClosure* o;
 934                     SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
 935                     SET_HDR(o,Inj_con_info,??);
 936
 937                     payloadWord(o,sizeofW(StgPtr)) = xTaggedStackWord(offset) + cwitness;
 938                     payloadPtr(o,0)                = xPopPtr();
 939
 940                     IF_DEBUG(evaluator,
 941                              fprintf(stderr,"\tBuilt ");
 942                              SSS;
 943                              printObj(stgCast(StgClosure*,o));
 944                              LLL;
 945                              );
 946                     xPushPtr(stgCast(StgPtr,o));
 947                     Continue;
 948                 }
 949             Case(i_PACK_INJ):
 950                 {
 951                     const int size  = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord));
 952
 953                     StgClosure* o;
 954                     SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
 955                     SET_HDR(o,Inj_con_info,??);
 956
 957                     payloadWord(o,sizeofW(StgPtr)) = xPopTaggedWord();
 958                     payloadPtr(o,0)                = xPopPtr();
 959
 960                     IF_DEBUG(evaluator,
 961                              fprintf(stderr,"\tBuilt ");
 962                              SSS;
 963                              printObj(stgCast(StgClosure*,o));
 964                              LLL;
 965                              );
 966                     xPushPtr(stgCast(StgPtr,o));
 967                     Continue;
 968                 }
 969
 970             /* Test Inj witnesses. */
 971             Case(i_TEST_INJ_VAR):
 972                 {
 973                     StgWord offset = BCO_INSTR_8;
 974                     StgWord jump   = BCO_INSTR_16;
 975
 976                     StgWord index  = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
 977                     if (index != xTaggedStackWord(offset) )
 978                     {
 979                       bciPtr += jump;
 980                     }
 981                     Continue;
 982                 }
 983             Case(i_TEST_INJ_VAR_big):
 984                 {
 985                     StgWord offset = BCO_INSTR_16;
 986                     StgWord jump   = BCO_INSTR_16;
 987
 988                     StgWord index  = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
 989                     if (index != xTaggedStackWord(offset) )
 990                     {
 991                       bciPtr += jump;
 992                     }
 993                     Continue;
 994                 }
 995             Case(i_TEST_INJ_CONST_8):
 996                 {
 997                     StgWord cwitness = BCO_INSTR_8;
 998                     StgWord jump     = BCO_INSTR_16;
 999
1000                     StgWord witness  = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
1001                     if (witness != cwitness )
1002                     {
1003                       bciPtr += jump;
1004                     }
1005                     Continue;
1006                 }
1007             Case(i_TEST_INJ_REL_8):
1008                 {
1009                     StgWord offset    = BCO_INSTR_8;
1010                     StgWord cwitness  = BCO_INSTR_8;
1011                     StgWord jump      = BCO_INSTR_16;
1012
1013                     StgWord witness  = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
1014                     if (witness != xTaggedStackWord(offset) + cwitness )
1015                     {
1016                       bciPtr += jump;
1017                     }
1018                     Continue;
1019                 }
1020             Case(i_TEST_INJ):
1021                 {
1022                     StgWord jump     = BCO_INSTR_16;
1023                     StgWord cwitness = xPopTaggedWord();
1024
1025                     StgWord witness  = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
1026                     if (witness != cwitness )
1027                     {
1028                       bciPtr += jump;
1029                     }
1030                     Continue;
1031                 }
1032
1033             /* extract the value of an INJ */
1034             Case(i_UNPACK_INJ):
1035                 {
1036                     StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1037
1038                     ASSERT(get_itbl(con) == Inj_con_info);
1039
1040                     xPushPtr(payloadPtr(con,0));
1041                     Continue;
1042                 }
1043
1044             /* optimized witness (word) operations */
1045             Case(i_CONST_WORD_8):
1046                 {
1047                     xPushTaggedWord(BCO_INSTR_8);
1048                     Continue;
1049                 }
1050             Case(i_ADD_WORD_VAR):
1051                 {
1052                     StgWord offset  = BCO_INSTR_8;
1053                     StgWord witness = xTaggedStackWord(offset);
1054                     witness += xPopTaggedWord();
1055                     xPushTaggedWord(witness);
1056                     Continue;
1057                 }
1058             Case(i_ADD_WORD_VAR_big):
1059                 {
1060                     StgWord offset  = BCO_INSTR_16;
1061                     StgWord witness = xTaggedStackWord(offset);
1062                     witness += xPopTaggedWord();
1063                     xPushTaggedWord(witness);
1064                     Continue;
1065                 }
1066             Case(i_ADD_WORD_VAR_8):
1067                 {
1068                     StgWord offset  = BCO_INSTR_8;
1069                     StgWord inc     = BCO_INSTR_8;
1070                     StgWord witness = xTaggedStackWord(offset);
1071                     xPushTaggedWord(witness + inc);
1072                     Continue;
1073                 }
1074 #endif /* XMLAMBA */
1075
1076             Case(i_VOID):
1077                 {
1078                     SSS; PushTaggedRealWorld(); LLL;
1079                     Continue;
1080                 }
1081             Case(i_VAR_INT):
1082                 {
1083                     StgInt i = xTaggedStackInt(BCO_INSTR_8);
1084                     xPushTaggedInt(i);
1085                     Continue;
1086                 }
1087             Case(i_CONST_INT):
1088                 {
1089                     xPushTaggedInt(bcoConstInt(bco,BCO_INSTR_8));
1090                     Continue;
1091                 }
1092             Case(i_CONST_INT_big):
1093                 {
1094                     int n = BCO_INSTR_16;
1095                     xPushTaggedInt(bcoConstInt(bco,n));
1096                     Continue;
1097                 }
1098             Case(i_PACK_INT):
1099                 {
1100                     StgClosure* o;
1101                     SSS; o = (StgClosure*)grabHpNonUpd(Izh_sizeW); LLL;
1102                     SET_HDR(o,Izh_con_info,??);
1103                     payloadWord(o,0) = xPopTaggedInt();
1104                     IF_DEBUG(evaluator,
1105                              fprintf(stderr,"\tBuilt ");
1106                              SSS;
1107                              printObj(stgCast(StgClosure*,o));
1108                              LLL;
1109                              );
1110                     xPushPtr(stgCast(StgPtr,o));
1111                     Continue;
1112                 }
1113             Case(i_UNPACK_INT):
1114                 {
1115                     StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1116                     /* ASSERT(isIntLike(con)); */
1117                     xPushTaggedInt(payloadWord(con,0));
1118                     Continue;
1119                 }
1120             Case(i_TEST_INT):
1121                 {
1122                     StgWord offset = BCO_INSTR_16;
1123                     StgInt  x      = xPopTaggedInt();
1124                     StgInt  y      = xPopTaggedInt();
1125                     if (x != y) {
1126                         bciPtr += offset;
1127                     }
1128                     Continue;
1129                 }
1130             Case(i_CONST_INTEGER):
1131                 {
1132                     StgPtr p;
1133                     int n;
1134                     char* s = bcoConstAddr(bco,BCO_INSTR_8);
1135                     SSS;
1136                     n = size_fromStr(s);
1137                     p = CreateByteArrayToHoldInteger(n);
1138                     do_fromStr ( s, n, IntegerInsideByteArray(p));
1139                     SloppifyIntegerEnd(p);
1140                     LLL;
1141                     xPushPtr(p);
1142                     Continue;
1143                 }
1144             Case(i_VAR_WORD):
1145                 {
1146                     StgWord w = xTaggedStackWord(BCO_INSTR_8);
1147                     xPushTaggedWord(w);
1148                     Continue;
1149                 }
1150             Case(i_CONST_WORD):
1151                 {
1152                     xPushTaggedWord(bcoConstWord(bco,BCO_INSTR_8));
1153                     Continue;
1154                 }
1155             Case(i_CONST_WORD_big):
1156                 {
1157                     StgWord n = BCO_INSTR_16;
1158                     xPushTaggedWord(bcoConstWord(bco,n));
1159                     Continue;
1160                 }
1161             Case(i_PACK_WORD):
1162                 {
1163                     StgClosure* o;
1164                     SSS; o = (StgClosure*)grabHpNonUpd(Wzh_sizeW); LLL;
1165                     SET_HDR(o,Wzh_con_info,??);
1166                     payloadWord(o,0) = xPopTaggedWord();
1167                     IF_DEBUG(evaluator,
1168                              fprintf(stderr,"\tBuilt ");
1169                              SSS;
1170                              printObj(stgCast(StgClosure*,o));
1171                              LLL;
1172                             );
1173                     xPushPtr(stgCast(StgPtr,o));
1174                     Continue;
1175                 }
1176             Case(i_UNPACK_WORD):
1177                 {
1178                     StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1179                     /* ASSERT(isWordLike(con)); */
1180                     xPushTaggedWord(payloadWord(con,0));
1181                     Continue;
1182                 }
1183             Case(i_VAR_ADDR):
1184                 {
1185                     StgAddr a = xTaggedStackAddr(BCO_INSTR_8);
1186                     xPushTaggedAddr(a);
1187                     Continue;
1188                 }
1189             Case(i_CONST_ADDR):
1190                 {
1191                     xPushTaggedAddr(bcoConstAddr(bco,BCO_INSTR_8));
1192                     Continue;
1193                 }
1194             Case(i_CONST_ADDR_big):
1195                 {
1196                     int n = BCO_INSTR_16;
1197                     xPushTaggedAddr(bcoConstAddr(bco,n));
1198                     Continue;
1199                 }
1200             Case(i_PACK_ADDR):
1201                 {
1202                     StgClosure* o;
1203                     SSS; o = (StgClosure*)grabHpNonUpd(Azh_sizeW); LLL;
1204                     SET_HDR(o,Azh_con_info,??);
1205                     payloadPtr(o,0) = xPopTaggedAddr();
1206                     IF_DEBUG(evaluator,
1207                              fprintf(stderr,"\tBuilt ");
1208                              SSS;
1209                              printObj(stgCast(StgClosure*,o));
1210                              LLL;
1211                              );
1212                     xPushPtr(stgCast(StgPtr,o));
1213                     Continue;
1214                 }
1215             Case(i_UNPACK_ADDR):
1216                 {
1217                     StgClosure* con = (StgClosure*)xStackPtr(0);
1218                     /* ASSERT(isAddrLike(con)); */
1219                     xPushTaggedAddr(payloadPtr(con,0));
1220                     Continue;
1221                 }
1222             Case(i_VAR_CHAR):
1223                 {
1224                     StgChar c = xTaggedStackChar(BCO_INSTR_8);
1225                     xPushTaggedChar(c);
1226                     Continue;
1227                 }
1228             Case(i_CONST_CHAR):
1229                 {
1230                     xPushTaggedChar(bcoConstChar(bco,BCO_INSTR_8));
1231                     Continue;
1232                 }
1233             Case(i_PACK_CHAR):
1234                 {
1235                     StgClosure* o;
1236                     SSS; o = (StgClosure*)grabHpNonUpd(Czh_sizeW); LLL;
1237                     SET_HDR(o,Czh_con_info,??);
1238                     payloadWord(o,0) = xPopTaggedChar();
1239                     xPushPtr(stgCast(StgPtr,o));
1240                     IF_DEBUG(evaluator,
1241                              fprintf(stderr,"\tBuilt ");
1242                              SSS;
1243                              printObj(stgCast(StgClosure*,o));
1244                              LLL;
1245                              );
1246                     Continue;
1247                 }
1248             Case(i_UNPACK_CHAR):
1249                 {
1250                     StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1251                     /* ASSERT(isCharLike(con)); */
1252                     xPushTaggedChar(payloadWord(con,0));
1253                     Continue;
1254                 }
1255             Case(i_VAR_FLOAT):
1256                 {
1257                     StgFloat f = xTaggedStackFloat(BCO_INSTR_8);
1258                     xPushTaggedFloat(f);
1259                     Continue;
1260                 }
1261             Case(i_CONST_FLOAT):
1262                 {
1263                     xPushTaggedFloat(bcoConstFloat(bco,BCO_INSTR_8));
1264                     Continue;
1265                 }
1266             Case(i_PACK_FLOAT):
1267                 {
1268                     StgClosure* o;
1269                     SSS; o = (StgClosure*)grabHpNonUpd(Fzh_sizeW); LLL;
1270                     SET_HDR(o,Fzh_con_info,??);
1271                     ASSIGN_FLT(&payloadWord(o,0),xPopTaggedFloat());
1272                     IF_DEBUG(evaluator,
1273                              fprintf(stderr,"\tBuilt ");
1274                              SSS;
1275                              printObj(stgCast(StgClosure*,o));
1276                              LLL;
1277                              );
1278                     xPushPtr(stgCast(StgPtr,o));
1279                     Continue;
1280                 }
1281             Case(i_UNPACK_FLOAT):
1282                 {
1283                     StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1284                     /* ASSERT(isFloatLike(con)); */
1285                     xPushTaggedFloat(PK_FLT(&payloadWord(con,0)));
1286                     Continue;
1287                 }
1288             Case(i_VAR_DOUBLE):
1289                 {
1290                     StgDouble d = xTaggedStackDouble(BCO_INSTR_8);
1291                     xPushTaggedDouble(d);
1292                     Continue;
1293                 }
1294             Case(i_CONST_DOUBLE):
1295                 {
1296                     xPushTaggedDouble(bcoConstDouble(bco,BCO_INSTR_8));
1297                     Continue;
1298                 }
1299             Case(i_CONST_DOUBLE_big):
1300                 {
1301                     int n = BCO_INSTR_16;
1302                     xPushTaggedDouble(bcoConstDouble(bco,n));
1303                     Continue;
1304                 }
1305             Case(i_PACK_DOUBLE):
1306                 {
1307                     StgClosure* o;
1308                     SSS; o = (StgClosure*)grabHpNonUpd(Dzh_sizeW); LLL;
1309                     SET_HDR(o,Dzh_con_info,??);
1310                     ASSIGN_DBL(&payloadWord(o,0),xPopTaggedDouble());
1311                     IF_DEBUG(evaluator,
1312                              fprintf(stderr,"\tBuilt ");
1313                              printObj(stgCast(StgClosure*,o));
1314                              );
1315                     xPushPtr(stgCast(StgPtr,o));
1316                     Continue;
1317                 }
1318             Case(i_UNPACK_DOUBLE):
1319                 {
1320                     StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1321                     /* ASSERT(isDoubleLike(con)); */
1322                     xPushTaggedDouble(PK_DBL(&payloadWord(con,0)));
1323                     Continue;
1324                 }
1325             Case(i_VAR_STABLE):
1326                 {
1327                     StgStablePtr s = xTaggedStackStable(BCO_INSTR_8);
1328                     xPushTaggedStable(s);
1329                     Continue;
1330                 }
1331             Case(i_PACK_STABLE):
1332                 {
1333                     StgClosure* o;
1334                     SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL;
1335                     SET_HDR(o,StablePtr_con_info,??);
1336                     payloadWord(o,0) = (W_)xPopTaggedStable();
1337                     IF_DEBUG(evaluator,
1338                              fprintf(stderr,"\tBuilt ");
1339                              SSS;
1340                              printObj(stgCast(StgClosure*,o));
1341                              LLL;
1342                              );
1343                     xPushPtr(stgCast(StgPtr,o));
1344                     Continue;
1345                 }
1346             Case(i_UNPACK_STABLE):
1347                 {
1348                     StgClosure* con = (StgClosure*)xStackPtr(0);
1349                     /* ASSERT(isStableLike(con)); */
1350                     xPushTaggedStable(payloadWord(con,0));
1351                     Continue;
1352                 }
1353             Case(i_PRIMOP1):
1354                 {
1355                     int   i;
1356                     void* p;
1357                     i = BCO_INSTR_8;
1358                     SSS; p = enterBCO_primop1 ( i ); LLL;
1359                     if (p) { obj = p; goto enterLoop; };
1360                     Continue;
1361                 }
1362             Case(i_PRIMOP2):
1363                 {
1364                     int      i, trc, pc_saved;
1365                     void*    p;
1366                     StgBCO*  bco_tmp;
1367                     trc      = 12345678; /* Assume != any StgThreadReturnCode */
1368                     i        = BCO_INSTR_8;
1369                     pc_saved = PC;
1370                     bco_tmp  = bco;
1371                     SSS;
1372                     p        = enterBCO_primop2 ( i, &trc, &bco_tmp, cap,
1373                                                   &hugsBlock );
1374                     LLL;
1375                     bco      = bco_tmp;
1376                     bciPtr   = &(bcoInstr(bco,pc_saved));
1377                     if (p) {
1378                        if (trc == 12345678) {
1379                           /* we want to enter p */
1380                           obj = p; goto enterLoop;
1381                        } else {
1382                           /* trc is the the StgThreadReturnCode for
1383                            * this thread */
1384                          RETURN((StgThreadReturnCode)trc);
1385                        };
1386                     }
1387                     Continue;
1388                 }
1389
1390             /* combined insns, created by peephole opt */
1391             Case(i_SE):
1392                 {
1393                     int x = BCO_INSTR_8;
1394                     int y = BCO_INSTR_8;
1395                     ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
1396                     /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
1397                     if (x == 1) {
1398                        obj = xPopCPtr();
1399                        xSp += y;
1400                        goto enterLoop;
1401                     } else {
1402                        while(--x >= 0) {
1403                            xSetStackWord(x+y,xStackWord(x));
1404                        }
1405                        xSp += y;
1406                        obj = xPopCPtr();
1407                     }
1408                     goto enterLoop;
1409                 }
1410             Case(i_VV):
1411                 {
1412                     StgPtr p;
1413                     p = xStackPtr(BCO_INSTR_8);
1414                     xPushPtr(p);
1415                     p = xStackPtr(BCO_INSTR_8);
1416                     xPushPtr(p);
1417                     Continue;
1418                 }
1419             Case(i_RV):
1420                 {
1421                     StgPtr p;
1422                     xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
1423                     xPushPtr(stgCast(StgPtr,&ret_bco_info));
1424                     p = xStackPtr(BCO_INSTR_8);
1425                     xPushPtr(p);
1426                     Continue;
1427                 }
1428             Case(i_RVE):
1429                 {
1430                     StgPtr retaddr = bcoConstPtr(bco,BCO_INSTR_8);
1431                     StgPtr ptr = xStackPtr(BCO_INSTR_8);
1432
1433                     /* A shortcut.  We're going to push the address of a
1434                        return continuation, and then enter a variable, so
1435                        that when the var is evaluated, we return to the
1436                        continuation.  The shortcut is: if the var is a
1437                        constructor, don't bother to enter it.  Instead,
1438                        push the variable on the stack (since this is what
1439                        the continuation expects) and jump directly to the
1440                        continuation.
1441                      */
1442                     if (get_itbl((StgClosure*)ptr)->type == CONSTR) {
1443                        xPushPtr(ptr);
1444                        obj = (StgClosure*)retaddr;
1445                        IF_DEBUG(evaluator,
1446                                 fprintf(stderr, "object to enter is a constructor -- "
1447                                         "jumping directly to return continuation\n" );
1448                                );
1449                        goto bco_entry;
1450                     }
1451
1452                     /* This is the normal, non-short-cut route */
1453                     xPushPtr(retaddr);
1454                     xPushPtr(stgCast(StgPtr,&ret_bco_info));
1455                     obj = (StgClosure*)ptr;
1456                     goto enterLoop;
1457                 }
1458
1459
1460             Case(i_VAR_DOUBLE_big):
1461             Case(i_CONST_FLOAT_big):
1462             Case(i_VAR_FLOAT_big):
1463             Case(i_CONST_CHAR_big):
1464             Case(i_VAR_CHAR_big):
1465             Case(i_VAR_ADDR_big):
1466             Case(i_VAR_STABLE_big):
1467             Case(i_CONST_INTEGER_big):
1468             Case(i_VAR_INT_big):
1469             Case(i_VAR_WORD_big):
1470             Case(i_RETADDR_big):
1471             Case(i_ALLOC_PAP):
1472 #ifndef XMLAMBDA
1473             Case(i_UNPACK_INJ):
1474             Case(i_UNPACK_ROW):
1475             Case(i_TEST_INJ_CONST):
1476             Case(i_TEST_INJ_big):
1477             Case(i_TEST_INJ):
1478             Case(i_PACK_INJ_CONST):
1479             Case(i_PACK_INJ_big):
1480             Case(i_PACK_INJ):
1481             Case(i_PACK_ROW_big):
1482             Case(i_PACK_ROW):
1483             Case(i_ALLOC_ROW_big):
1484             Case(i_ALLOC_ROW):
1485 #endif
1486                     bciPtr--;
1487                     printf ( "\n\n" );
1488                     disInstr ( bco, PC );
1489                     barf("\nUnrecognised instruction");
1490
1491             EndDispatch
1492
1493             barf("enterBCO: ran off end of loop");
1494             break;
1495         }
1496
1497 #           undef LoopTopLabel
1498 #           undef Case
1499 #           undef Continue
1500 #           undef Dispatch
1501 #           undef EndDispatch
1502
1503             /* ---------------------------------------------------- */
1504             /* End of the bytecode evaluator                        */
1505             /* ---------------------------------------------------- */
1506
1507     case CAF_UNENTERED:
1508         {
1509             StgBlockingQueue* bh;
1510             StgCAF* caf = (StgCAF*)obj;
1511             if (xSp - sizeofW(StgUpdateFrame) < xSpLim) {
1512                 xPushCPtr(obj); /* code to restart with */
1513                 RETURN(StackOverflow);
1514             }
1515             SSS; bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW()); LLL;
1516             SET_INFO(bh,&CAF_BLACKHOLE_info);
1517             bh->blocking_queue = EndTSOQueue;
1518             IF_DEBUG(gccafs,
1519                      fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p"
1520                                     " in evaluator\n",bh,caf));
1521             SET_INFO(caf,&CAF_ENTERED_info);
1522             caf->value = (StgClosure*)bh;
1523
1524             SSS; newCAF_made_by_Hugs(caf); LLL;
1525
1526             xPushUpdateFrame(bh,0);
1527             xSp -= sizeofW(StgUpdateFrame);
1528             obj = caf->body;
1529             goto enterLoop;
1530         }
1531     case CAF_ENTERED:
1532         {
1533             StgCAF* caf = (StgCAF*)obj;
1534             obj = caf->value; /* it's just a fancy indirection */
1535             goto enterLoop;
1536         }
1537     case BLACKHOLE:
1538     case SE_BLACKHOLE:
1539     case CAF_BLACKHOLE:
1540     case SE_CAF_BLACKHOLE:
1541         {
1542             /* Let the scheduler figure out what to do :-) */
1543             cap->rCurrentTSO->what_next = ThreadEnterGHC;
1544             xPushCPtr(obj);
1545             RETURN(ThreadYielding);
1546         }
1547     case AP_UPD:
1548         {
1549             StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
1550             int i = ap->n_args;
1551             if (xSp - (i + sizeofW(StgUpdateFrame)) < xSpLim) {
1552                 xPushCPtr(obj); /* code to restart with */
1553                 RETURN(StackOverflow);
1554             }
1555             /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1556                and insert an indirection immediately  */
1557             xPushUpdateFrame(ap,0);
1558             xSp -= sizeofW(StgUpdateFrame);
1559             while (--i >= 0) {
1560                 xPushWord(payloadWord(ap,i));
1561             }
1562             obj = ap->fun;
1563 #ifdef EAGER_BLACKHOLING
1564 #warn  LAZY_BLACKHOLING is default for StgHugs
1565 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1566             {
1567             /* superfluous - but makes debugging easier */
1568             StgBlackHole* bh = stgCast(StgBlackHole*,ap);
1569             SET_INFO(bh,&BLACKHOLE_info);
1570             bh->blocking_queue = EndTSOQueue;
1571             IF_DEBUG(gccafs,
1572                      fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
1573             /* printObj(bh); */
1574             }
1575 #endif /* EAGER_BLACKHOLING */
1576             goto enterLoop;
1577         }
1578     case PAP:
1579         {
1580             StgPAP* pap = stgCast(StgPAP*,obj);
1581             int i = pap->n_args;  /* ToDo: stack check */
1582             /* ToDo: if PAP is in whnf, we can update any update frames
1583              * on top of stack.
1584              */
1585             while (--i >= 0) {
1586                 xPushWord(payloadWord(pap,i));
1587             }
1588             obj = pap->fun;
1589             goto enterLoop;
1590         }
1591     case IND:
1592         {
1593             obj = stgCast(StgInd*,obj)->indirectee;
1594             goto enterLoop;
1595         }
1596     case IND_OLDGEN:
1597         {
1598             obj = stgCast(StgIndOldGen*,obj)->indirectee;
1599             goto enterLoop;
1600         }
1601     case CONSTR:
1602     case CONSTR_1_0:
1603     case CONSTR_0_1:
1604     case CONSTR_2_0:
1605     case CONSTR_1_1:
1606     case CONSTR_0_2:
1607     case CONSTR_INTLIKE:
1608     case CONSTR_CHARLIKE:
1609     case CONSTR_STATIC:
1610     case CONSTR_NOCAF_STATIC:
1611 #ifdef XMLAMBDA
1612 /* rows are mutarrays and should be treated as constructors. */
1613     case MUT_ARR_PTRS_FROZEN:
1614 #endif
1615         {
1616             while (1) {
1617                 switch (get_itbl(stgCast(StgClosure*,xSp))->type) {
1618                 case CATCH_FRAME:
1619                         SSS; PopCatchFrame(); LLL;
1620                         break;
1621                 case UPDATE_FRAME:
1622                         xPopUpdateFrame(obj);
1623                         break;
1624                 case SEQ_FRAME:
1625                         SSS; PopSeqFrame(); LLL;
1626                         break;
1627                 case STOP_FRAME:
1628                     {
1629                         ASSERT(xSp==(P_)xSu);
1630                         IF_DEBUG(evaluator,
1631                                  SSS;
1632                                  fprintf(stderr, "hit a STOP_FRAME\n");
1633                                  printObj(obj);
1634                                  fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
1635                                  printStack(xSp,cap->rCurrentTSO->stack
1636                                                 + cap->rCurrentTSO->stack_size,xSu);
1637                                  LLL;
1638                                  );
1639                         cap->rCurrentTSO->what_next = ThreadComplete;
1640                         SSS; PopStopFrame(obj); LLL;
1641                         xPushPtr((P_)obj);
1642                         RETURN(ThreadFinished);
1643                     }
1644                 case RET_BCO:
1645                     {
1646                         StgClosure* ret;
1647                         (void)xPopPtr();
1648                         ret = xPopCPtr();
1649                         xPushPtr((P_)obj);
1650                         obj = ret;
1651                         goto bco_entry;
1652                         /* was: goto enterLoop;
1653                            But we know that obj must be a bco now, so jump directly.
1654                         */
1655                     }
1656                 case RET_SMALL:  /* return to GHC */
1657                 case RET_VEC_SMALL:
1658                 case RET_BIG:
1659                 case RET_VEC_BIG:
1660                         cap->rCurrentTSO->what_next = ThreadEnterGHC;
1661                         xPushCPtr(obj);
1662                         RETURN(ThreadYielding);
1663                 default:
1664                         belch("entered CONSTR with invalid continuation on stack");
1665                         IF_DEBUG(evaluator,
1666                                  SSS;
1667                                  printObj(stgCast(StgClosure*,xSp));
1668                                  LLL;
1669                                  );
1670                         barf("bailing out");
1671                 }
1672             }
1673         }
1674     default:
1675         {
1676             //SSS;
1677             //fprintf(stderr, "enterCountI = %d\n", enterCountI);
1678             //fprintf(stderr, "entering unknown closure -- yielding to sched\n");
1679             //printObj(obj);
1680             //LLL;
1681             cap->rCurrentTSO->what_next = ThreadEnterGHC;
1682             xPushCPtr(obj); /* code to restart with */
1683             RETURN(ThreadYielding);
1684         }
1685     }
1686     barf("Ran off the end of enter - yoiks");
1687     ASSERT(0);
1688 }
1689
1690 #undef RETURN
1691 #undef BCO_INSTR_8
1692 #undef BCO_INSTR_16
1693 #undef SSS
1694 #undef LLL
1695 #undef PC
1696 #undef xPushPtr
1697 #undef xPopPtr
1698 #undef xPushCPtr
1699 #undef xPopCPtr
1700 #undef xPopWord
1701 #undef xStackPtr
1702 #undef xStackWord
1703 #undef xSetStackWord
1704 #undef xPushTag
1705 #undef xPopTag
1706 #undef xPushTaggedInt
1707 #undef xPopTaggedInt
1708 #undef xTaggedStackInt
1709 #undef xPushTaggedWord
1710 #undef xPopTaggedWord
1711 #undef xTaggedStackWord
1712 #undef xPushTaggedAddr
1713 #undef xTaggedStackAddr
1714 #undef xPopTaggedAddr
1715 #undef xPushTaggedStable
1716 #undef xTaggedStackStable
1717 #undef xPopTaggedStable
1718 #undef xPushTaggedChar
1719 #undef xTaggedStackChar
1720 #undef xPopTaggedChar
1721 #undef xPushTaggedFloat
1722 #undef xTaggedStackFloat
1723 #undef xPopTaggedFloat
1724 #undef xPushTaggedDouble
1725 #undef xTaggedStackDouble
1726 #undef xPopTaggedDouble
1727 #undef xPopUpdateFrame
1728 #undef xPushUpdateFrame
1729
1730
1731 /* --------------------------------------------------------------------------
1732  * Supporting routines for primops
1733  * ------------------------------------------------------------------------*/
1734
1735 static inline void            PushTag            ( StackTag    t )
1736    { *(--gSp) = t; }
1737        inline void            PushPtr            ( StgPtr      x )
1738    { *(--stgCast(StgPtr*,gSp))  = x; }
1739 static inline void            PushCPtr           ( StgClosure* x )
1740    { *(--stgCast(StgClosure**,gSp)) = x; }
1741 static inline void            PushInt            ( StgInt      x )
1742    { *(--stgCast(StgInt*,gSp))  = x; }
1743 static inline void            PushWord           ( StgWord     x )
1744    { *(--stgCast(StgWord*,gSp)) = x; }
1745
1746
1747 static inline void            checkTag           ( StackTag t1, StackTag t2 )
1748    { ASSERT(t1 == t2);}
1749 static inline void            PopTag             ( StackTag t )
1750    { checkTag(t,*(gSp++));    }
1751        inline StgPtr          PopPtr             ( void )
1752    { return *stgCast(StgPtr*,gSp)++; }
1753 static inline StgClosure*     PopCPtr            ( void )
1754    { return *stgCast(StgClosure**,gSp)++; }
1755 static inline StgInt          PopInt             ( void )
1756    { return *stgCast(StgInt*,gSp)++;  }
1757 static inline StgWord         PopWord            ( void )
1758    { return *stgCast(StgWord*,gSp)++; }
1759
1760 static inline StgPtr          stackPtr           ( StgStackOffset i )
1761    { return *stgCast(StgPtr*, gSp+i); }
1762 static inline StgInt          stackInt           ( StgStackOffset i )
1763    { return *stgCast(StgInt*, gSp+i); }
1764 static inline StgWord         stackWord          ( StgStackOffset i )
1765    { return *stgCast(StgWord*,gSp+i); }
1766
1767 static inline void            setStackWord       ( StgStackOffset i, StgWord w )
1768    { gSp[i] = w; }
1769
1770 #ifdef XMLAMBDA
1771 static inline void            setStackPtr        ( StgStackOffset i, StgPtr p )
1772    { *(stgCast(StgPtr*, gSp+i)) = p; }
1773 #endif
1774
1775 static inline void            PushTaggedRealWorld( void            )
1776    { PushTag(REALWORLD_TAG);  }
1777        inline void            PushTaggedInt      ( StgInt        x )
1778    { gSp -= sizeofW(StgInt);        *gSp = x;          PushTag(INT_TAG);    }
1779        inline void            PushTaggedWord     ( StgWord       x )
1780    { gSp -= sizeofW(StgWord);       *gSp = x;          PushTag(WORD_TAG);   }
1781        inline void            PushTaggedAddr     ( StgAddr       x )
1782    { gSp -= sizeofW(StgAddr);       *gSp = (W_)x;      PushTag(ADDR_TAG);   }
1783        inline void            PushTaggedChar     ( StgChar       x )
1784    { gSp -= sizeofW(StgChar);         *gSp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
1785        inline void            PushTaggedFloat    ( StgFloat      x )
1786    { gSp -= sizeofW(StgFloat);      ASSIGN_FLT(gSp,x); PushTag(FLOAT_TAG);  }
1787        inline void            PushTaggedDouble   ( StgDouble     x )
1788    { gSp -= sizeofW(StgDouble);     ASSIGN_DBL(gSp,x); PushTag(DOUBLE_TAG); }
1789        inline void            PushTaggedStablePtr   ( StgStablePtr  x )
1790    { gSp -= sizeofW(StgStablePtr);  *gSp = (W_)x;      PushTag(STABLE_TAG); }
1791 static inline void            PushTaggedBool     ( int           x )
1792    { PushTaggedInt(x); }
1793
1794
1795
1796 static inline void            PopTaggedRealWorld ( void )
1797    { PopTag(REALWORLD_TAG); }
1798        inline StgInt          PopTaggedInt       ( void )
1799    { StgInt    r; PopTag(INT_TAG);     r = *stgCast(StgInt*,  gSp);
1800      gSp += sizeofW(StgInt);        return r;}
1801        inline StgWord         PopTaggedWord      ( void )
1802    { StgWord   r; PopTag(WORD_TAG);    r = *stgCast(StgWord*, gSp);
1803      gSp += sizeofW(StgWord);       return r;}
1804        inline StgAddr         PopTaggedAddr      ( void )
1805    { StgAddr   r; PopTag(ADDR_TAG);    r = *stgCast(StgAddr*, gSp);
1806      gSp += sizeofW(StgAddr);       return r;}
1807        inline StgChar         PopTaggedChar      ( void )
1808    { StgChar   r; PopTag(CHAR_TAG);    r = stgCast(StgChar, *gSp);
1809      gSp += sizeofW(StgChar);       return r;}
1810        inline StgFloat        PopTaggedFloat     ( void )
1811    { StgFloat  r; PopTag(FLOAT_TAG);   r = PK_FLT(gSp);
1812      gSp += sizeofW(StgFloat);      return r;}
1813        inline StgDouble       PopTaggedDouble    ( void )
1814    { StgDouble r; PopTag(DOUBLE_TAG);  r = PK_DBL(gSp);
1815      gSp += sizeofW(StgDouble);     return r;}
1816        inline StgStablePtr    PopTaggedStablePtr    ( void )
1817    { StgStablePtr r; PopTag(STABLE_TAG);  r = *stgCast(StgStablePtr*, gSp);
1818      gSp += sizeofW(StgStablePtr);  return r;}
1819
1820
1821
1822 static inline StgInt          taggedStackInt     ( StgStackOffset i )
1823    { checkTag(INT_TAG,gSp[i]);     return *stgCast(StgInt*,         gSp+1+i); }
1824 static inline StgWord         taggedStackWord    ( StgStackOffset i )
1825    { checkTag(WORD_TAG,gSp[i]);    return *stgCast(StgWord*,        gSp+1+i); }
1826 static inline StgAddr         taggedStackAddr    ( StgStackOffset i )
1827    { checkTag(ADDR_TAG,gSp[i]);    return *stgCast(StgAddr*,        gSp+1+i); }
1828 static inline StgChar         taggedStackChar    ( StgStackOffset i )
1829    { checkTag(CHAR_TAG,gSp[i]);    return stgCast(StgChar, *(gSp+1+i))   ; }
1830 static inline StgFloat        taggedStackFloat   ( StgStackOffset i )
1831    { checkTag(FLOAT_TAG,gSp[i]);   return PK_FLT(gSp+1+i); }
1832 static inline StgDouble       taggedStackDouble  ( StgStackOffset i )
1833    { checkTag(DOUBLE_TAG,gSp[i]);  return PK_DBL(gSp+1+i); }
1834 static inline StgStablePtr    taggedStackStable  ( StgStackOffset i )
1835    { checkTag(STABLE_TAG,gSp[i]);  return *stgCast(StgStablePtr*,   gSp+1+i); }
1836
1837
1838 /* --------------------------------------------------------------------------
1839  * Heap allocation
1840  *
1841  * Should we allocate from a nursery or use the
1842  * doYouWantToGC/allocate interface?  We'd already implemented a
1843  * nursery-style scheme when the doYouWantToGC/allocate interface
1844  * was implemented.
1845  * One reason to prefer the doYouWantToGC/allocate interface is to
1846  * support operations which allocate an unknown amount in the heap
1847  * (array ops, gmp ops, etc)
1848  * ------------------------------------------------------------------------*/
1849
1850 static inline StgPtr grabHpUpd( nat size )
1851 {
1852     ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
1853     return allocate(size);
1854 }
1855
1856 static inline StgPtr grabHpNonUpd( nat size )
1857 {
1858     ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1859     return allocate(size);
1860 }
1861
1862 /* --------------------------------------------------------------------------
1863  * Manipulate "update frame" list:
1864  * o Update frames           (based on stg_do_update and friends in Updates.hc)
1865  * o Error handling/catching (based on catchzh_fast and friends in Prims.hc)
1866  * o Seq frames              (based on seq_frame_entry in Prims.hc)
1867  * o Stop frames
1868  * ------------------------------------------------------------------------*/
1869
1870 static inline void PopUpdateFrame ( StgClosure* obj )
1871 {
1872     /* NB: doesn't assume that gSp == gSu */
1873     IF_DEBUG(evaluator,
1874              fprintf(stderr,  "Updating ");
1875              printPtr(stgCast(StgPtr,gSu->updatee));
1876              fprintf(stderr,  " with ");
1877              printObj(obj);
1878              fprintf(stderr,"gSp = %p\tgSu = %p\n\n", gSp, gSu);
1879              );
1880 #ifdef EAGER_BLACKHOLING
1881 #warn  LAZY_BLACKHOLING is default for StgHugs
1882 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1883     ASSERT(get_itbl(gSu->updatee)->type == BLACKHOLE
1884            || get_itbl(gSu->updatee)->type == SE_BLACKHOLE
1885            || get_itbl(gSu->updatee)->type == CAF_BLACKHOLE
1886            || get_itbl(gSu->updatee)->type == SE_CAF_BLACKHOLE
1887            );
1888 #endif /* EAGER_BLACKHOLING */
1889     UPD_IND(gSu->updatee,obj);
1890     gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1891     gSu = gSu->link;
1892 }
1893
1894 static inline void PopStopFrame ( StgClosure* obj )
1895 {
1896     /* Move gSu just off the end of the stack, we're about to gSpam the
1897      * STOP_FRAME with the return value.
1898      */
1899     gSu = stgCast(StgUpdateFrame*,gSp+1);
1900     *stgCast(StgClosure**,gSp) = obj;
1901 }
1902
1903 static inline void PushCatchFrame ( StgClosure* handler )
1904 {
1905     StgCatchFrame* fp;
1906     /* ToDo: stack check! */
1907     gSp -= sizeofW(StgCatchFrame);
1908     fp = stgCast(StgCatchFrame*,gSp);
1909     SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS);
1910     fp->handler         = handler;
1911     fp->link            = gSu;
1912     gSu = stgCast(StgUpdateFrame*,fp);
1913 }
1914
1915 static inline void PopCatchFrame ( void )
1916 {
1917     /* NB: doesn't assume that gSp == gSu */
1918     /* fprintf(stderr,"Popping catch frame\n"); */
1919     gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgCatchFrame);
1920     gSu = stgCast(StgCatchFrame*,gSu)->link;
1921 }
1922
1923 static inline void PushSeqFrame ( void )
1924 {
1925     StgSeqFrame* fp;
1926     /* ToDo: stack check! */
1927     gSp -= sizeofW(StgSeqFrame);
1928     fp = stgCast(StgSeqFrame*,gSp);
1929     SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS);
1930     fp->link = gSu;
1931     gSu = stgCast(StgUpdateFrame*,fp);
1932 }
1933
1934 static inline void PopSeqFrame ( void )
1935 {
1936     /* NB: doesn't assume that gSp == gSu */
1937     gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgSeqFrame);
1938     gSu = stgCast(StgSeqFrame*,gSu)->link;
1939 }
1940
1941 static inline StgClosure* raiseAnError ( StgClosure* exception )
1942 {
1943     /* This closure represents the expression 'primRaise E' where E
1944      * is the exception raised (:: Exception).
1945      * It is used to overwrite all the
1946      * thunks which are currently under evaluation.
1947      */
1948     HaskellObj primRaiseClosure
1949        = getHugs_BCO_cptr_for("primRaise");
1950     HaskellObj reraiseClosure
1951        = rts_apply ( primRaiseClosure, exception );
1952
1953     while (1) {
1954         switch (get_itbl(gSu)->type) {
1955         case UPDATE_FRAME:
1956                 UPD_IND(gSu->updatee,reraiseClosure);
1957                 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1958                 gSu = gSu->link;
1959                 break;
1960         case SEQ_FRAME:
1961                 PopSeqFrame();
1962                 break;
1963         case CATCH_FRAME:  /* found it! */
1964             {
1965                 StgCatchFrame* fp = stgCast(StgCatchFrame*,gSu);
1966                 StgClosure *handler = fp->handler;
1967                 gSu = fp->link;
1968                 gSp += sizeofW(StgCatchFrame); /* Pop */
1969                 PushCPtr(exception);
1970                 return handler;
1971             }
1972         case STOP_FRAME:
1973                 barf("raiseError: uncaught exception: STOP_FRAME");
1974         default:
1975                 barf("raiseError: weird activation record");
1976         }
1977     }
1978 }
1979
1980
1981 static StgClosure* makeErrorCall ( const char* msg )
1982 {
1983    /* Note!  the msg string should be allocated in a
1984       place which will not get freed -- preferably
1985       read-only data of the program.  That's because
1986       the thunk we build here may linger indefinitely.
1987       (thinks: probably not so, but anyway ...)
1988    */
1989    HaskellObj error
1990       = getHugs_BCO_cptr_for("error");
1991    HaskellObj unpack
1992       = getHugs_BCO_cptr_for("hugsprimUnpackString");
1993    HaskellObj thunk
1994       = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) );
1995    thunk
1996       = rts_apply ( error, thunk );
1997    return
1998       (StgClosure*) thunk;
1999 }
2000
2001 #define raiseIndex(where) makeErrorCall("Array index out of range in " where)
2002 #define raiseDiv0(where)  makeErrorCall("Division by zero in " where)
2003
2004 /* --------------------------------------------------------------------------
2005  * Evaluator
2006  * ------------------------------------------------------------------------*/
2007
2008 #define OP_CC_B(e)            \
2009 {                             \
2010     unsigned char x = PopTaggedChar(); \
2011     unsigned char y = PopTaggedChar(); \
2012     PushTaggedBool(e);        \
2013 }
2014
2015 #define OP_C_I(e)             \
2016 {                             \
2017     unsigned char x = PopTaggedChar(); \
2018     PushTaggedInt(e);         \
2019 }
2020
2021 #define OP__I(e)             \
2022 {                            \
2023     PushTaggedInt(e);        \
2024 }
2025
2026 #define OP_IW_I(e)           \
2027 {                            \
2028     StgInt  x = PopTaggedInt();  \
2029     StgWord y = PopTaggedWord();  \
2030     PushTaggedInt(e);        \
2031 }
2032
2033 #define OP_II_I(e)           \
2034 {                            \
2035     StgInt x = PopTaggedInt();  \
2036     StgInt y = PopTaggedInt();  \
2037     PushTaggedInt(e);        \
2038 }
2039
2040 #define OP_II_B(e)           \
2041 {                            \
2042     StgInt x = PopTaggedInt();  \
2043     StgInt y = PopTaggedInt();  \
2044     PushTaggedBool(e);       \
2045 }
2046
2047 #define OP__A(e)             \
2048 {                            \
2049     PushTaggedAddr(e);       \
2050 }
2051
2052 #define OP_I_A(e)            \
2053 {                            \
2054     StgInt x = PopTaggedInt();  \
2055     PushTaggedAddr(e);       \
2056 }
2057
2058 #define OP_I_I(e)            \
2059 {                            \
2060     StgInt x = PopTaggedInt();  \
2061     PushTaggedInt(e);        \
2062 }
2063
2064 #define OP__C(e)             \
2065 {                            \
2066     PushTaggedChar(e);       \
2067 }
2068
2069 #define OP_I_C(e)            \
2070 {                            \
2071     StgInt x = PopTaggedInt();  \
2072     PushTaggedChar(e);       \
2073 }
2074
2075 #define OP__W(e)              \
2076 {                             \
2077     PushTaggedWord(e);        \
2078 }
2079
2080 #define OP_I_W(e)            \
2081 {                            \
2082     StgInt x = PopTaggedInt();  \
2083     PushTaggedWord(e);       \
2084 }
2085
2086 #define OP_I_s(e)            \
2087 {                            \
2088     StgInt x = PopTaggedInt();  \
2089     PushTaggedStablePtr(e);  \
2090 }
2091
2092 #define OP__F(e)             \
2093 {                            \
2094     PushTaggedFloat(e);      \
2095 }
2096
2097 #define OP_I_F(e)            \
2098 {                            \
2099     StgInt x = PopTaggedInt();  \
2100     PushTaggedFloat(e);      \
2101 }
2102
2103 #define OP__D(e)             \
2104 {                            \
2105     PushTaggedDouble(e);     \
2106 }
2107
2108 #define OP_I_D(e)            \
2109 {                            \
2110     StgInt x = PopTaggedInt();  \
2111     PushTaggedDouble(e);     \
2112 }
2113
2114 #define OP_WW_B(e)            \
2115 {                             \
2116     StgWord x = PopTaggedWord(); \
2117     StgWord y = PopTaggedWord(); \
2118     PushTaggedBool(e);        \
2119 }
2120
2121 #define OP_WW_W(e)            \
2122 {                             \
2123     StgWord x = PopTaggedWord(); \
2124     StgWord y = PopTaggedWord(); \
2125     PushTaggedWord(e);        \
2126 }
2127
2128 #define OP_W_I(e)             \
2129 {                             \
2130     StgWord x = PopTaggedWord(); \
2131     PushTaggedInt(e);         \
2132 }
2133
2134 #define OP_s_I(e)             \
2135 {                             \
2136     StgStablePtr x = PopTaggedStablePtr(); \
2137     PushTaggedInt(e);         \
2138 }
2139
2140 #define OP_W_W(e)             \
2141 {                             \
2142     StgWord x = PopTaggedWord(); \
2143     PushTaggedWord(e);        \
2144 }
2145
2146 #define OP_AA_B(e)            \
2147 {                             \
2148     StgAddr x = PopTaggedAddr(); \
2149     StgAddr y = PopTaggedAddr(); \
2150     PushTaggedBool(e);        \
2151 }
2152 #define OP_A_I(e)             \
2153 {                             \
2154     StgAddr x = PopTaggedAddr(); \
2155     PushTaggedInt(e);         \
2156 }
2157 #define OP_AI_C(s)            \
2158 {                             \
2159     StgAddr x = PopTaggedAddr(); \
2160     int  y = PopTaggedInt();  \
2161     StgChar r;                \
2162     s;                        \
2163     PushTaggedChar(r);        \
2164 }
2165 #define OP_AI_I(s)            \
2166 {                             \
2167     StgAddr x = PopTaggedAddr(); \
2168     int  y = PopTaggedInt();  \
2169     StgInt r;                 \
2170     s;                        \
2171     PushTaggedInt(r);         \
2172 }
2173 #define OP_AI_A(s)            \
2174 {                             \
2175     StgAddr x = PopTaggedAddr(); \
2176     int  y = PopTaggedInt();  \
2177     StgAddr r;                \
2178     s;                        \
2179     PushTaggedAddr(s);        \
2180 }
2181 #define OP_AI_F(s)            \
2182 {                             \
2183     StgAddr x = PopTaggedAddr(); \
2184     int  y = PopTaggedInt();  \
2185     StgFloat r;               \
2186     s;                        \
2187     PushTaggedFloat(r);       \
2188 }
2189 #define OP_AI_D(s)            \
2190 {                             \
2191     StgAddr x = PopTaggedAddr(); \
2192     int  y = PopTaggedInt();  \
2193     StgDouble r;              \
2194     s;                        \
2195     PushTaggedDouble(r);      \
2196 }
2197 #define OP_AI_s(s)            \
2198 {                             \
2199     StgAddr x = PopTaggedAddr(); \
2200     int  y = PopTaggedInt();  \
2201     StgStablePtr r;           \
2202     s;                        \
2203     PushTaggedStablePtr(r);   \
2204 }
2205 #define OP_AIC_(s)            \
2206 {                             \
2207     StgAddr x = PopTaggedAddr(); \
2208     int     y = PopTaggedInt();  \
2209     StgChar z = PopTaggedChar(); \
2210     s;                        \
2211 }
2212 #define OP_AII_(s)            \
2213 {                             \
2214     StgAddr x = PopTaggedAddr(); \
2215     int     y = PopTaggedInt();  \
2216     StgInt  z = PopTaggedInt(); \
2217     s;                        \
2218 }
2219 #define OP_AIA_(s)            \
2220 {                             \
2221     StgAddr x = PopTaggedAddr(); \
2222     int     y = PopTaggedInt();  \
2223     StgAddr z = PopTaggedAddr(); \
2224     s;                        \
2225 }
2226 #define OP_AIF_(s)            \
2227 {                             \
2228     StgAddr x = PopTaggedAddr(); \
2229     int     y = PopTaggedInt();  \
2230     StgFloat z = PopTaggedFloat(); \
2231     s;                        \
2232 }
2233 #define OP_AID_(s)            \
2234 {                             \
2235     StgAddr x = PopTaggedAddr(); \
2236     int     y = PopTaggedInt();  \
2237     StgDouble z = PopTaggedDouble(); \
2238     s;                        \
2239 }
2240 #define OP_AIs_(s)            \
2241 {                             \
2242     StgAddr x = PopTaggedAddr(); \
2243     int     y = PopTaggedInt();  \
2244     StgStablePtr z = PopTaggedStablePtr(); \
2245     s;                        \
2246 }
2247
2248
2249 #define OP_FF_B(e)              \
2250 {                               \
2251     StgFloat x = PopTaggedFloat(); \
2252     StgFloat y = PopTaggedFloat(); \
2253     PushTaggedBool(e);          \
2254 }
2255
2256 #define OP_FF_F(e)              \
2257 {                               \
2258     StgFloat x = PopTaggedFloat(); \
2259     StgFloat y = PopTaggedFloat(); \
2260     PushTaggedFloat(e);         \
2261 }
2262
2263 #define OP_F_F(e)               \
2264 {                               \
2265     StgFloat x = PopTaggedFloat(); \
2266     PushTaggedFloat(e);         \
2267 }
2268
2269 #define OP_F_B(e)               \
2270 {                               \
2271     StgFloat x = PopTaggedFloat(); \
2272     PushTaggedBool(e);         \
2273 }
2274
2275 #define OP_F_I(e)               \
2276 {                               \
2277     StgFloat x = PopTaggedFloat(); \
2278     PushTaggedInt(e);           \
2279 }
2280
2281 #define OP_F_D(e)               \
2282 {                               \
2283     StgFloat x = PopTaggedFloat(); \
2284     PushTaggedDouble(e);        \
2285 }
2286
2287 #define OP_DD_B(e)                \
2288 {                                 \
2289     StgDouble x = PopTaggedDouble(); \
2290     StgDouble y = PopTaggedDouble(); \
2291     PushTaggedBool(e);            \
2292 }
2293
2294 #define OP_DD_D(e)                \
2295 {                                 \
2296     StgDouble x = PopTaggedDouble(); \
2297     StgDouble y = PopTaggedDouble(); \
2298     PushTaggedDouble(e);          \
2299 }
2300
2301 #define OP_D_B(e)                 \
2302 {                                 \
2303     StgDouble x = PopTaggedDouble(); \
2304     PushTaggedBool(e);          \
2305 }
2306
2307 #define OP_D_D(e)                 \
2308 {                                 \
2309     StgDouble x = PopTaggedDouble(); \
2310     PushTaggedDouble(e);          \
2311 }
2312
2313 #define OP_D_I(e)                 \
2314 {                                 \
2315     StgDouble x = PopTaggedDouble(); \
2316     PushTaggedInt(e);             \
2317 }
2318
2319 #define OP_D_F(e)                 \
2320 {                                 \
2321     StgDouble x = PopTaggedDouble(); \
2322     PushTaggedFloat(e);           \
2323 }
2324
2325
2326 StgPtr CreateByteArrayToHoldInteger ( int nbytes )
2327 {
2328    StgWord words     = (nbytes+sizeof(W_)-1)/sizeof(W_);
2329    StgWord size      = sizeofW(StgArrWords) + words;
2330    StgArrWords* arr  = (StgArrWords*)allocate(size);
2331    SET_HDR(arr,&ARR_WORDS_info,CCCS);
2332    arr->words = words;
2333    ASSERT((W_)nbytes <= arr->words * sizeof(W_));
2334 #ifdef DEBUG
2335    {StgWord i;
2336     for (i = 0; i < words; ++i) {
2337     arr->payload[i] = 0xdeadbeef;
2338    }}
2339    { B* b = (B*) &(arr->payload[0]);
2340      b->used = b->sign = 0;
2341    }
2342 #endif
2343    return (StgPtr)arr;
2344 }
2345
2346 B* IntegerInsideByteArray ( StgPtr arr0 )
2347 {
2348    B* b;
2349    StgArrWords* arr = (StgArrWords*)arr0;
2350    ASSERT(GET_INFO(arr) == &ARR_WORDS_info);
2351    b = (B*) &(arr->payload[0]);
2352    return b;
2353 }
2354
2355 void SloppifyIntegerEnd ( StgPtr arr0 )
2356 {
2357    StgArrWords* arr = (StgArrWords*)arr0;
2358    B* b = (B*) & (arr->payload[0]);
2359    I_ nwunused = arr->words - sizeofW(B) - (b->used+sizeof(W_)-1)/sizeof(W_);
2360    if (nwunused >= ((I_)sizeofW(StgArrWords))) {
2361       StgArrWords* slop;
2362       b->size -= nwunused * sizeof(W_);
2363       if (b->size < b->used) b->size = b->used;
2364       do_renormalise(b);
2365       ASSERT(is_sane(b));
2366       arr->words -= nwunused;
2367       slop = (StgArrWords*)&(arr->payload[arr->words]);
2368       SET_HDR(slop,&ARR_WORDS_info,CCCS);
2369       slop->words = nwunused - sizeofW(StgArrWords);
2370       ASSERT( &(slop->payload[slop->words]) ==
2371               &(arr->payload[arr->words + nwunused]) );
2372    }
2373 }
2374
2375 #define OP_Z_Z(op)                                   \
2376 {                                                    \
2377    B* x     = IntegerInsideByteArray(PopPtr());      \
2378    int n    = mycat2(size_,op)(x);                   \
2379    StgPtr p = CreateByteArrayToHoldInteger(n);       \
2380    mycat2(do_,op)(x,n,IntegerInsideByteArray(p));    \
2381    SloppifyIntegerEnd(p);                            \
2382    PushPtr(p);                                       \
2383 }
2384 #define OP_ZZ_Z(op)                                  \
2385 {                                                    \
2386    B* x     = IntegerInsideByteArray(PopPtr());      \
2387    B* y     = IntegerInsideByteArray(PopPtr());      \
2388    int n    = mycat2(size_,op)(x,y);                 \
2389    StgPtr p = CreateByteArrayToHoldInteger(n);       \
2390    mycat2(do_,op)(x,y,n,IntegerInsideByteArray(p));  \
2391    SloppifyIntegerEnd(p);                            \
2392    PushPtr(p);                                       \
2393 }
2394
2395
2396
2397
2398 #define HEADER_mI(ty,where)          \
2399     StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \
2400     nat i = PopTaggedInt();   \
2401     if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) {        \
2402         return (raiseIndex(where));  \
2403     }
2404 #define OP_mI_ty(ty,where,s)        \
2405 {                                   \
2406     HEADER_mI(mycat2(Stg,ty),where) \
2407     { mycat2(Stg,ty) r;             \
2408       s;                            \
2409       mycat2(PushTagged,ty)(r);     \
2410     }                               \
2411 }
2412 #define OP_mIty_(ty,where,s)        \
2413 {                                   \
2414     HEADER_mI(mycat2(Stg,ty),where) \
2415     {                               \
2416       mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
2417       s;                            \
2418     }                               \
2419 }
2420
2421
2422 __attribute__ ((unused))
2423 static void myStackCheck ( Capability* cap )
2424 {
2425    /* fprintf(stderr, "myStackCheck\n"); */
2426    if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) {
2427       fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" );
2428       barf("aborting");
2429       ASSERT(0);
2430    }
2431    while (1) {
2432       if (!( (P_)gSu >= (P_)cap->rCurrentTSO->stack
2433               &&
2434               (P_)gSu <= (P_)(cap->rCurrentTSO->stack
2435                               + cap->rCurrentTSO->stack_size))) {
2436          fprintf ( stderr, "myStackCheck: gSu out of stack\n" );
2437          barf("aborting");
2438          ASSERT(0);
2439       }
2440       switch (get_itbl(stgCast(StgClosure*,gSu))->type) {
2441       case CATCH_FRAME:
2442          gSu = (StgUpdateFrame*) ((StgCatchFrame*)(gSu))->link;
2443          break;
2444       case UPDATE_FRAME:
2445          gSu = (StgUpdateFrame*) ((StgUpdateFrame*)(gSu))->link;
2446          break;
2447       case SEQ_FRAME:
2448          gSu = (StgUpdateFrame*) ((StgSeqFrame*)(gSu))->link;
2449          break;
2450       case STOP_FRAME:
2451          goto postloop;
2452       default:
2453          fprintf(stderr, "myStackCheck: invalid activation record\n");
2454          barf("aborting");
2455          ASSERT(0);
2456       }
2457    }
2458    postloop:
2459 }
2460
2461
2462 /* --------------------------------------------------------------------------
2463  * The new bytecode interpreter
2464  * ------------------------------------------------------------------------*/
2465
2466 /* Sp points to the lowest live word on the stack. */
2467
2468 #define StackWord(n)  ((W_*)Sp)[n]
2469 #define BCO_NEXT      bco_instrs[bciPtr++]
2470 #define BCO_PTR(n)    bco_ptrs[n]
2471
2472
2473 {
2474       case bci_PUSH_L: {
2475          int o1 = BCO_NEXT;
2476          StackWord(-1) = StackWord(o1);
2477          Sp--;
2478          break;
2479       }
2480       case bci_PUSH_LL: {
2481          int o1 = BCO_NEXT;
2482          int o2 = BCO_NEXT;
2483          StackWord(-1) = StackWord(o1);
2484          StackWord(-2) = StackWord(o2);
2485          Sp -= 2;
2486          break;
2487       }
2488       case bci_PUSH_LLL: {
2489          int o1 = BCO_NEXT;
2490          int o2 = BCO_NEXT;
2491          int o3 = BCO_NEXT;
2492          StackWord(-1) = StackWord(o1);
2493          StackWord(-2) = StackWord(o2);
2494          StackWord(-3) = StackWord(o3);
2495          Sp -= 3;
2496          break;
2497       }
2498       case bci_PUSH_G: {
2499          int o1 = BCO_NEXT;
2500          StackWord(-1) = BCO_PTR(o1);
2501          Sp -= 3;
2502          break;
2503       }
2504       case bci_PUSH_AS: {
2505          int o_bco  = BCO_NEXT;
2506          int o_itbl = BCO_NEXT;
2507          StackWord(-1) = BCO_LITW(o_itbl);
2508          StackWord(-2) = BCO_PTR(o_bco);
2509          Sp -= 2;
2510          break;
2511       }
2512       case bci_PUSH_LIT:{
2513          int o = BCO_NEXT;
2514          StackWord(-1) = BCO_LIT(o);
2515          Sp --;
2516          break;
2517       }
2518       case bci_PUSH_TAG: {
2519          W_ tag = (W_)(BCO_NEXT);
2520          StackWord(-1) = tag;
2521          Sp --;
2522          break;
2523       }
2524       case bci_SLIDE: {
2525          int n  = BCO_NEXT;
2526          int by = BCO_NEXT;
2527          ASSERT(Sp+n+by <= (StgPtr)xSu);
2528          /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */
2529          while(--n >= 0) {
2530             StackWord(n+by) = StackWord(n);
2531          }
2532          Sp += by;
2533          break;
2534       }
2535  case bci_ALLOC: {
2536    int n_payload = BCO_NEXT;
2537    P_ p = allocate(AP_sizeW(n_payload));
2538    StackWord(-1) = p;
2539    Sp --;
2540    break;
2541  }
2542       case bci_MKAP:    {
2543         int off = BCO_NEXT;
2544         int n_payload = BCO_NEXT - 1;
2545         StgAP_UPD* ap = StackWord(off);
2546         ap->n_args = n_payload;
2547         ap->fun = (StgClosure*)StackWord(0);
2548         for (i = 0; i < n_payload; i++)
2549           ap->payload[i] = StackWord(i+1);
2550         }
2551       Sp += n_payload+1;
2552 }
2553 case bci_UNPACK:{
2554   /* Unpack N ptr words from t.o.s constructor */
2555   int n_words = BCO_NEXT;
2556   StgClosure* con = StackWord(0);
2557   Sp -= n_words;
2558   for (i = 0; i < n_words; i++)
2559     StackWord(i) = con->payload[i];
2560 }
2561       case bci_PACK:
2562       case bci_TESTLT_I:
2563       case bci_TESTEQ_I:
2564       case bci_TESTLT_F:
2565       case bci_TESTEQ_F:
2566       case bci_TESTLT_D:
2567       case bci_TESTEQ_D:
2568       case bci_TESTLT_P:
2569       case bci_TESTEQ_P:
2570       case bci_CASEFAIL:
2571
2572       /* Control-flow ish things */
2573       case bci_ARGCHECK:
2574       case bci_ENTER:
2575       case bci_RETURN:
2576
2577       /* Errors */
2578       case bci_LABEL:
2579       default: barf
2580 }
2581
2582 #endif /* 0 */