ghc/rts/Evaluator.c

   1
   2 /* -----------------------------------------------------------------------------
   3  * Bytecode evaluator
   4  *
   5  * Copyright (c) 1994-2000.
   6  *
   7  * $RCSfile: Evaluator.c,v $
   8  * $Revision: 1.60 $
   9  * $Date: 2000/11/20 11:15:41 $
  10  * ---------------------------------------------------------------------------*/
  11
  12 #include "Rts.h"
  13
  14 #ifdef INTERPRETER
  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 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1565             {
1566             /* superfluous - but makes debugging easier */
1567             StgBlackHole* bh = stgCast(StgBlackHole*,ap);
1568             SET_INFO(bh,&BLACKHOLE_info);
1569             bh->blocking_queue = EndTSOQueue;
1570             IF_DEBUG(gccafs,
1571                      fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
1572             /* printObj(bh); */
1573             }
1574 #endif /* EAGER_BLACKHOLING */
1575             goto enterLoop;
1576         }
1577     case PAP:
1578         {
1579             StgPAP* pap = stgCast(StgPAP*,obj);
1580             int i = pap->n_args;  /* ToDo: stack check */
1581             /* ToDo: if PAP is in whnf, we can update any update frames
1582              * on top of stack.
1583              */
1584             while (--i >= 0) {
1585                 xPushWord(payloadWord(pap,i));
1586             }
1587             obj = pap->fun;
1588             goto enterLoop;
1589         }
1590     case IND:
1591         {
1592             obj = stgCast(StgInd*,obj)->indirectee;
1593             goto enterLoop;
1594         }
1595     case IND_OLDGEN:
1596         {
1597             obj = stgCast(StgIndOldGen*,obj)->indirectee;
1598             goto enterLoop;
1599         }
1600     case CONSTR:
1601     case CONSTR_1_0:
1602     case CONSTR_0_1:
1603     case CONSTR_2_0:
1604     case CONSTR_1_1:
1605     case CONSTR_0_2:
1606     case CONSTR_INTLIKE:
1607     case CONSTR_CHARLIKE:
1608     case CONSTR_STATIC:
1609     case CONSTR_NOCAF_STATIC:
1610 #ifdef XMLAMBDA
1611 /* rows are mutarrays and should be treated as constructors. */
1612     case MUT_ARR_PTRS_FROZEN:
1613 #endif
1614         {
1615             while (1) {
1616                 switch (get_itbl(stgCast(StgClosure*,xSp))->type) {
1617                 case CATCH_FRAME:
1618                         SSS; PopCatchFrame(); LLL;
1619                         break;
1620                 case UPDATE_FRAME:
1621                         xPopUpdateFrame(obj);
1622                         break;
1623                 case SEQ_FRAME:
1624                         SSS; PopSeqFrame(); LLL;
1625                         break;
1626                 case STOP_FRAME:
1627                     {
1628                         ASSERT(xSp==(P_)xSu);
1629                         IF_DEBUG(evaluator,
1630                                  SSS;
1631                                  fprintf(stderr, "hit a STOP_FRAME\n");
1632                                  printObj(obj);
1633                                  fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
1634                                  printStack(xSp,cap->rCurrentTSO->stack
1635                                                 + cap->rCurrentTSO->stack_size,xSu);
1636                                  LLL;
1637                                  );
1638                         cap->rCurrentTSO->what_next = ThreadComplete;
1639                         SSS; PopStopFrame(obj); LLL;
1640                         xPushPtr((P_)obj);
1641                         RETURN(ThreadFinished);
1642                     }
1643                 case RET_BCO:
1644                     {
1645                         StgClosure* ret;
1646                         (void)xPopPtr();
1647                         ret = xPopCPtr();
1648                         xPushPtr((P_)obj);
1649                         obj = ret;
1650                         goto bco_entry;
1651                         /* was: goto enterLoop;
1652                            But we know that obj must be a bco now, so jump directly.
1653                         */
1654                     }
1655                 case RET_SMALL:  /* return to GHC */
1656                 case RET_VEC_SMALL:
1657                 case RET_BIG:
1658                 case RET_VEC_BIG:
1659                         cap->rCurrentTSO->what_next = ThreadEnterGHC;
1660                         xPushCPtr(obj);
1661                         RETURN(ThreadYielding);
1662                 default:
1663                         belch("entered CONSTR with invalid continuation on stack");
1664                         IF_DEBUG(evaluator,
1665                                  SSS;
1666                                  printObj(stgCast(StgClosure*,xSp));
1667                                  LLL;
1668                                  );
1669                         barf("bailing out");
1670                 }
1671             }
1672         }
1673     default:
1674         {
1675             //SSS;
1676             //fprintf(stderr, "enterCountI = %d\n", enterCountI);
1677             //fprintf(stderr, "entering unknown closure -- yielding to sched\n");
1678             //printObj(obj);
1679             //LLL;
1680             cap->rCurrentTSO->what_next = ThreadEnterGHC;
1681             xPushCPtr(obj); /* code to restart with */
1682             RETURN(ThreadYielding);
1683         }
1684     }
1685     barf("Ran off the end of enter - yoiks");
1686     ASSERT(0);
1687 }
1688
1689 #undef RETURN
1690 #undef BCO_INSTR_8
1691 #undef BCO_INSTR_16
1692 #undef SSS
1693 #undef LLL
1694 #undef PC
1695 #undef xPushPtr
1696 #undef xPopPtr
1697 #undef xPushCPtr
1698 #undef xPopCPtr
1699 #undef xPopWord
1700 #undef xStackPtr
1701 #undef xStackWord
1702 #undef xSetStackWord
1703 #undef xPushTag
1704 #undef xPopTag
1705 #undef xPushTaggedInt
1706 #undef xPopTaggedInt
1707 #undef xTaggedStackInt
1708 #undef xPushTaggedWord
1709 #undef xPopTaggedWord
1710 #undef xTaggedStackWord
1711 #undef xPushTaggedAddr
1712 #undef xTaggedStackAddr
1713 #undef xPopTaggedAddr
1714 #undef xPushTaggedStable
1715 #undef xTaggedStackStable
1716 #undef xPopTaggedStable
1717 #undef xPushTaggedChar
1718 #undef xTaggedStackChar
1719 #undef xPopTaggedChar
1720 #undef xPushTaggedFloat
1721 #undef xTaggedStackFloat
1722 #undef xPopTaggedFloat
1723 #undef xPushTaggedDouble
1724 #undef xTaggedStackDouble
1725 #undef xPopTaggedDouble
1726 #undef xPopUpdateFrame
1727 #undef xPushUpdateFrame
1728
1729
1730 /* --------------------------------------------------------------------------
1731  * Supporting routines for primops
1732  * ------------------------------------------------------------------------*/
1733
1734 static inline void            PushTag            ( StackTag    t )
1735    { *(--gSp) = t; }
1736        inline void            PushPtr            ( StgPtr      x )
1737    { *(--stgCast(StgPtr*,gSp))  = x; }
1738 static inline void            PushCPtr           ( StgClosure* x )
1739    { *(--stgCast(StgClosure**,gSp)) = x; }
1740 static inline void            PushInt            ( StgInt      x )
1741    { *(--stgCast(StgInt*,gSp))  = x; }
1742 static inline void            PushWord           ( StgWord     x )
1743    { *(--stgCast(StgWord*,gSp)) = x; }
1744
1745
1746 static inline void            checkTag           ( StackTag t1, StackTag t2 )
1747    { ASSERT(t1 == t2);}
1748 static inline void            PopTag             ( StackTag t )
1749    { checkTag(t,*(gSp++));    }
1750        inline StgPtr          PopPtr             ( void )
1751    { return *stgCast(StgPtr*,gSp)++; }
1752 static inline StgClosure*     PopCPtr            ( void )
1753    { return *stgCast(StgClosure**,gSp)++; }
1754 static inline StgInt          PopInt             ( void )
1755    { return *stgCast(StgInt*,gSp)++;  }
1756 static inline StgWord         PopWord            ( void )
1757    { return *stgCast(StgWord*,gSp)++; }
1758
1759 static inline StgPtr          stackPtr           ( StgStackOffset i )
1760    { return *stgCast(StgPtr*, gSp+i); }
1761 static inline StgInt          stackInt           ( StgStackOffset i )
1762    { return *stgCast(StgInt*, gSp+i); }
1763 static inline StgWord         stackWord          ( StgStackOffset i )
1764    { return *stgCast(StgWord*,gSp+i); }
1765
1766 static inline void            setStackWord       ( StgStackOffset i, StgWord w )
1767    { gSp[i] = w; }
1768
1769 #ifdef XMLAMBDA
1770 static inline void            setStackPtr        ( StgStackOffset i, StgPtr p )
1771    { *(stgCast(StgPtr*, gSp+i)) = p; }
1772 #endif
1773
1774 static inline void            PushTaggedRealWorld( void            )
1775    { PushTag(REALWORLD_TAG);  }
1776        inline void            PushTaggedInt      ( StgInt        x )
1777    { gSp -= sizeofW(StgInt);        *gSp = x;          PushTag(INT_TAG);    }
1778        inline void            PushTaggedWord     ( StgWord       x )
1779    { gSp -= sizeofW(StgWord);       *gSp = x;          PushTag(WORD_TAG);   }
1780        inline void            PushTaggedAddr     ( StgAddr       x )
1781    { gSp -= sizeofW(StgAddr);       *gSp = (W_)x;      PushTag(ADDR_TAG);   }
1782        inline void            PushTaggedChar     ( StgChar       x )
1783    { gSp -= sizeofW(StgChar);         *gSp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
1784        inline void            PushTaggedFloat    ( StgFloat      x )
1785    { gSp -= sizeofW(StgFloat);      ASSIGN_FLT(gSp,x); PushTag(FLOAT_TAG);  }
1786        inline void            PushTaggedDouble   ( StgDouble     x )
1787    { gSp -= sizeofW(StgDouble);     ASSIGN_DBL(gSp,x); PushTag(DOUBLE_TAG); }
1788        inline void            PushTaggedStablePtr   ( StgStablePtr  x )
1789    { gSp -= sizeofW(StgStablePtr);  *gSp = (W_)x;      PushTag(STABLE_TAG); }
1790 static inline void            PushTaggedBool     ( int           x )
1791    { PushTaggedInt(x); }
1792
1793
1794
1795 static inline void            PopTaggedRealWorld ( void )
1796    { PopTag(REALWORLD_TAG); }
1797        inline StgInt          PopTaggedInt       ( void )
1798    { StgInt    r; PopTag(INT_TAG);     r = *stgCast(StgInt*,  gSp);
1799      gSp += sizeofW(StgInt);        return r;}
1800        inline StgWord         PopTaggedWord      ( void )
1801    { StgWord   r; PopTag(WORD_TAG);    r = *stgCast(StgWord*, gSp);
1802      gSp += sizeofW(StgWord);       return r;}
1803        inline StgAddr         PopTaggedAddr      ( void )
1804    { StgAddr   r; PopTag(ADDR_TAG);    r = *stgCast(StgAddr*, gSp);
1805      gSp += sizeofW(StgAddr);       return r;}
1806        inline StgChar         PopTaggedChar      ( void )
1807    { StgChar   r; PopTag(CHAR_TAG);    r = stgCast(StgChar, *gSp);
1808      gSp += sizeofW(StgChar);       return r;}
1809        inline StgFloat        PopTaggedFloat     ( void )
1810    { StgFloat  r; PopTag(FLOAT_TAG);   r = PK_FLT(gSp);
1811      gSp += sizeofW(StgFloat);      return r;}
1812        inline StgDouble       PopTaggedDouble    ( void )
1813    { StgDouble r; PopTag(DOUBLE_TAG);  r = PK_DBL(gSp);
1814      gSp += sizeofW(StgDouble);     return r;}
1815        inline StgStablePtr    PopTaggedStablePtr    ( void )
1816    { StgStablePtr r; PopTag(STABLE_TAG);  r = *stgCast(StgStablePtr*, gSp);
1817      gSp += sizeofW(StgStablePtr);  return r;}
1818
1819
1820
1821 static inline StgInt          taggedStackInt     ( StgStackOffset i )
1822    { checkTag(INT_TAG,gSp[i]);     return *stgCast(StgInt*,         gSp+1+i); }
1823 static inline StgWord         taggedStackWord    ( StgStackOffset i )
1824    { checkTag(WORD_TAG,gSp[i]);    return *stgCast(StgWord*,        gSp+1+i); }
1825 static inline StgAddr         taggedStackAddr    ( StgStackOffset i )
1826    { checkTag(ADDR_TAG,gSp[i]);    return *stgCast(StgAddr*,        gSp+1+i); }
1827 static inline StgChar         taggedStackChar    ( StgStackOffset i )
1828    { checkTag(CHAR_TAG,gSp[i]);    return stgCast(StgChar, *(gSp+1+i))   ; }
1829 static inline StgFloat        taggedStackFloat   ( StgStackOffset i )
1830    { checkTag(FLOAT_TAG,gSp[i]);   return PK_FLT(gSp+1+i); }
1831 static inline StgDouble       taggedStackDouble  ( StgStackOffset i )
1832    { checkTag(DOUBLE_TAG,gSp[i]);  return PK_DBL(gSp+1+i); }
1833 static inline StgStablePtr    taggedStackStable  ( StgStackOffset i )
1834    { checkTag(STABLE_TAG,gSp[i]);  return *stgCast(StgStablePtr*,   gSp+1+i); }
1835
1836
1837 /* --------------------------------------------------------------------------
1838  * Heap allocation
1839  *
1840  * Should we allocate from a nursery or use the
1841  * doYouWantToGC/allocate interface?  We'd already implemented a
1842  * nursery-style scheme when the doYouWantToGC/allocate interface
1843  * was implemented.
1844  * One reason to prefer the doYouWantToGC/allocate interface is to
1845  * support operations which allocate an unknown amount in the heap
1846  * (array ops, gmp ops, etc)
1847  * ------------------------------------------------------------------------*/
1848
1849 static inline StgPtr grabHpUpd( nat size )
1850 {
1851     ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
1852     return allocate(size);
1853 }
1854
1855 static inline StgPtr grabHpNonUpd( nat size )
1856 {
1857     ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1858     return allocate(size);
1859 }
1860
1861 /* --------------------------------------------------------------------------
1862  * Manipulate "update frame" list:
1863  * o Update frames           (based on stg_do_update and friends in Updates.hc)
1864  * o Error handling/catching (based on catchzh_fast and friends in Prims.hc)
1865  * o Seq frames              (based on seq_frame_entry in Prims.hc)
1866  * o Stop frames
1867  * ------------------------------------------------------------------------*/
1868
1869 static inline void PopUpdateFrame ( StgClosure* obj )
1870 {
1871     /* NB: doesn't assume that gSp == gSu */
1872     IF_DEBUG(evaluator,
1873              fprintf(stderr,  "Updating ");
1874              printPtr(stgCast(StgPtr,gSu->updatee));
1875              fprintf(stderr,  " with ");
1876              printObj(obj);
1877              fprintf(stderr,"gSp = %p\tgSu = %p\n\n", gSp, gSu);
1878              );
1879 #ifdef EAGER_BLACKHOLING
1880 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1881     ASSERT(get_itbl(gSu->updatee)->type == BLACKHOLE
1882            || get_itbl(gSu->updatee)->type == SE_BLACKHOLE
1883            || get_itbl(gSu->updatee)->type == CAF_BLACKHOLE
1884            || get_itbl(gSu->updatee)->type == SE_CAF_BLACKHOLE
1885            );
1886 #endif /* EAGER_BLACKHOLING */
1887     UPD_IND(gSu->updatee,obj);
1888     gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1889     gSu = gSu->link;
1890 }
1891
1892 static inline void PopStopFrame ( StgClosure* obj )
1893 {
1894     /* Move gSu just off the end of the stack, we're about to gSpam the
1895      * STOP_FRAME with the return value.
1896      */
1897     gSu = stgCast(StgUpdateFrame*,gSp+1);
1898     *stgCast(StgClosure**,gSp) = obj;
1899 }
1900
1901 static inline void PushCatchFrame ( StgClosure* handler )
1902 {
1903     StgCatchFrame* fp;
1904     /* ToDo: stack check! */
1905     gSp -= sizeofW(StgCatchFrame);
1906     fp = stgCast(StgCatchFrame*,gSp);
1907     SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS);
1908     fp->handler         = handler;
1909     fp->link            = gSu;
1910     gSu = stgCast(StgUpdateFrame*,fp);
1911 }
1912
1913 static inline void PopCatchFrame ( void )
1914 {
1915     /* NB: doesn't assume that gSp == gSu */
1916     /* fprintf(stderr,"Popping catch frame\n"); */
1917     gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgCatchFrame);
1918     gSu = stgCast(StgCatchFrame*,gSu)->link;
1919 }
1920
1921 static inline void PushSeqFrame ( void )
1922 {
1923     StgSeqFrame* fp;
1924     /* ToDo: stack check! */
1925     gSp -= sizeofW(StgSeqFrame);
1926     fp = stgCast(StgSeqFrame*,gSp);
1927     SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS);
1928     fp->link = gSu;
1929     gSu = stgCast(StgUpdateFrame*,fp);
1930 }
1931
1932 static inline void PopSeqFrame ( void )
1933 {
1934     /* NB: doesn't assume that gSp == gSu */
1935     gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgSeqFrame);
1936     gSu = stgCast(StgSeqFrame*,gSu)->link;
1937 }
1938
1939 static inline StgClosure* raiseAnError ( StgClosure* exception )
1940 {
1941     /* This closure represents the expression 'primRaise E' where E
1942      * is the exception raised (:: Exception).
1943      * It is used to overwrite all the
1944      * thunks which are currently under evaluation.
1945      */
1946     HaskellObj primRaiseClosure
1947        = getHugs_BCO_cptr_for("primRaise");
1948     HaskellObj reraiseClosure
1949        = rts_apply ( primRaiseClosure, exception );
1950
1951     while (1) {
1952         switch (get_itbl(gSu)->type) {
1953         case UPDATE_FRAME:
1954                 UPD_IND(gSu->updatee,reraiseClosure);
1955                 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1956                 gSu = gSu->link;
1957                 break;
1958         case SEQ_FRAME:
1959                 PopSeqFrame();
1960                 break;
1961         case CATCH_FRAME:  /* found it! */
1962             {
1963                 StgCatchFrame* fp = stgCast(StgCatchFrame*,gSu);
1964                 StgClosure *handler = fp->handler;
1965                 gSu = fp->link;
1966                 gSp += sizeofW(StgCatchFrame); /* Pop */
1967                 PushCPtr(exception);
1968                 return handler;
1969             }
1970         case STOP_FRAME:
1971                 barf("raiseError: uncaught exception: STOP_FRAME");
1972         default:
1973                 barf("raiseError: weird activation record");
1974         }
1975     }
1976 }
1977
1978
1979 static StgClosure* makeErrorCall ( const char* msg )
1980 {
1981    /* Note!  the msg string should be allocated in a
1982       place which will not get freed -- preferably
1983       read-only data of the program.  That's because
1984       the thunk we build here may linger indefinitely.
1985       (thinks: probably not so, but anyway ...)
1986    */
1987    HaskellObj error
1988       = getHugs_BCO_cptr_for("error");
1989    HaskellObj unpack
1990       = getHugs_BCO_cptr_for("hugsprimUnpackString");
1991    HaskellObj thunk
1992       = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) );
1993    thunk
1994       = rts_apply ( error, thunk );
1995    return
1996       (StgClosure*) thunk;
1997 }
1998
1999 #define raiseIndex(where) makeErrorCall("Array index out of range in " where)
2000 #define raiseDiv0(where)  makeErrorCall("Division by zero in " where)
2001
2002 /* --------------------------------------------------------------------------
2003  * Evaluator
2004  * ------------------------------------------------------------------------*/
2005
2006 #define OP_CC_B(e)            \
2007 {                             \
2008     unsigned char x = PopTaggedChar(); \
2009     unsigned char y = PopTaggedChar(); \
2010     PushTaggedBool(e);        \
2011 }
2012
2013 #define OP_C_I(e)             \
2014 {                             \
2015     unsigned char x = PopTaggedChar(); \
2016     PushTaggedInt(e);         \
2017 }
2018
2019 #define OP__I(e)             \
2020 {                            \
2021     PushTaggedInt(e);        \
2022 }
2023
2024 #define OP_IW_I(e)           \
2025 {                            \
2026     StgInt  x = PopTaggedInt();  \
2027     StgWord y = PopTaggedWord();  \
2028     PushTaggedInt(e);        \
2029 }
2030
2031 #define OP_II_I(e)           \
2032 {                            \
2033     StgInt x = PopTaggedInt();  \
2034     StgInt y = PopTaggedInt();  \
2035     PushTaggedInt(e);        \
2036 }
2037
2038 #define OP_II_B(e)           \
2039 {                            \
2040     StgInt x = PopTaggedInt();  \
2041     StgInt y = PopTaggedInt();  \
2042     PushTaggedBool(e);       \
2043 }
2044
2045 #define OP__A(e)             \
2046 {                            \
2047     PushTaggedAddr(e);       \
2048 }
2049
2050 #define OP_I_A(e)            \
2051 {                            \
2052     StgInt x = PopTaggedInt();  \
2053     PushTaggedAddr(e);       \
2054 }
2055
2056 #define OP_I_I(e)            \
2057 {                            \
2058     StgInt x = PopTaggedInt();  \
2059     PushTaggedInt(e);        \
2060 }
2061
2062 #define OP__C(e)             \
2063 {                            \
2064     PushTaggedChar(e);       \
2065 }
2066
2067 #define OP_I_C(e)            \
2068 {                            \
2069     StgInt x = PopTaggedInt();  \
2070     PushTaggedChar(e);       \
2071 }
2072
2073 #define OP__W(e)              \
2074 {                             \
2075     PushTaggedWord(e);        \
2076 }
2077
2078 #define OP_I_W(e)            \
2079 {                            \
2080     StgInt x = PopTaggedInt();  \
2081     PushTaggedWord(e);       \
2082 }
2083
2084 #define OP_I_s(e)            \
2085 {                            \
2086     StgInt x = PopTaggedInt();  \
2087     PushTaggedStablePtr(e);  \
2088 }
2089
2090 #define OP__F(e)             \
2091 {                            \
2092     PushTaggedFloat(e);      \
2093 }
2094
2095 #define OP_I_F(e)            \
2096 {                            \
2097     StgInt x = PopTaggedInt();  \
2098     PushTaggedFloat(e);      \
2099 }
2100
2101 #define OP__D(e)             \
2102 {                            \
2103     PushTaggedDouble(e);     \
2104 }
2105
2106 #define OP_I_D(e)            \
2107 {                            \
2108     StgInt x = PopTaggedInt();  \
2109     PushTaggedDouble(e);     \
2110 }
2111
2112 #define OP_WW_B(e)            \
2113 {                             \
2114     StgWord x = PopTaggedWord(); \
2115     StgWord y = PopTaggedWord(); \
2116     PushTaggedBool(e);        \
2117 }
2118
2119 #define OP_WW_W(e)            \
2120 {                             \
2121     StgWord x = PopTaggedWord(); \
2122     StgWord y = PopTaggedWord(); \
2123     PushTaggedWord(e);        \
2124 }
2125
2126 #define OP_W_I(e)             \
2127 {                             \
2128     StgWord x = PopTaggedWord(); \
2129     PushTaggedInt(e);         \
2130 }
2131
2132 #define OP_s_I(e)             \
2133 {                             \
2134     StgStablePtr x = PopTaggedStablePtr(); \
2135     PushTaggedInt(e);         \
2136 }
2137
2138 #define OP_W_W(e)             \
2139 {                             \
2140     StgWord x = PopTaggedWord(); \
2141     PushTaggedWord(e);        \
2142 }
2143
2144 #define OP_AA_B(e)            \
2145 {                             \
2146     StgAddr x = PopTaggedAddr(); \
2147     StgAddr y = PopTaggedAddr(); \
2148     PushTaggedBool(e);        \
2149 }
2150 #define OP_A_I(e)             \
2151 {                             \
2152     StgAddr x = PopTaggedAddr(); \
2153     PushTaggedInt(e);         \
2154 }
2155 #define OP_AI_C(s)            \
2156 {                             \
2157     StgAddr x = PopTaggedAddr(); \
2158     int  y = PopTaggedInt();  \
2159     StgChar r;                \
2160     s;                        \
2161     PushTaggedChar(r);        \
2162 }
2163 #define OP_AI_I(s)            \
2164 {                             \
2165     StgAddr x = PopTaggedAddr(); \
2166     int  y = PopTaggedInt();  \
2167     StgInt r;                 \
2168     s;                        \
2169     PushTaggedInt(r);         \
2170 }
2171 #define OP_AI_A(s)            \
2172 {                             \
2173     StgAddr x = PopTaggedAddr(); \
2174     int  y = PopTaggedInt();  \
2175     StgAddr r;                \
2176     s;                        \
2177     PushTaggedAddr(s);        \
2178 }
2179 #define OP_AI_F(s)            \
2180 {                             \
2181     StgAddr x = PopTaggedAddr(); \
2182     int  y = PopTaggedInt();  \
2183     StgFloat r;               \
2184     s;                        \
2185     PushTaggedFloat(r);       \
2186 }
2187 #define OP_AI_D(s)            \
2188 {                             \
2189     StgAddr x = PopTaggedAddr(); \
2190     int  y = PopTaggedInt();  \
2191     StgDouble r;              \
2192     s;                        \
2193     PushTaggedDouble(r);      \
2194 }
2195 #define OP_AI_s(s)            \
2196 {                             \
2197     StgAddr x = PopTaggedAddr(); \
2198     int  y = PopTaggedInt();  \
2199     StgStablePtr r;           \
2200     s;                        \
2201     PushTaggedStablePtr(r);   \
2202 }
2203 #define OP_AIC_(s)            \
2204 {                             \
2205     StgAddr x = PopTaggedAddr(); \
2206     int     y = PopTaggedInt();  \
2207     StgChar z = PopTaggedChar(); \
2208     s;                        \
2209 }
2210 #define OP_AII_(s)            \
2211 {                             \
2212     StgAddr x = PopTaggedAddr(); \
2213     int     y = PopTaggedInt();  \
2214     StgInt  z = PopTaggedInt(); \
2215     s;                        \
2216 }
2217 #define OP_AIA_(s)            \
2218 {                             \
2219     StgAddr x = PopTaggedAddr(); \
2220     int     y = PopTaggedInt();  \
2221     StgAddr z = PopTaggedAddr(); \
2222     s;                        \
2223 }
2224 #define OP_AIF_(s)            \
2225 {                             \
2226     StgAddr x = PopTaggedAddr(); \
2227     int     y = PopTaggedInt();  \
2228     StgFloat z = PopTaggedFloat(); \
2229     s;                        \
2230 }
2231 #define OP_AID_(s)            \
2232 {                             \
2233     StgAddr x = PopTaggedAddr(); \
2234     int     y = PopTaggedInt();  \
2235     StgDouble z = PopTaggedDouble(); \
2236     s;                        \
2237 }
2238 #define OP_AIs_(s)            \
2239 {                             \
2240     StgAddr x = PopTaggedAddr(); \
2241     int     y = PopTaggedInt();  \
2242     StgStablePtr z = PopTaggedStablePtr(); \
2243     s;                        \
2244 }
2245
2246
2247 #define OP_FF_B(e)              \
2248 {                               \
2249     StgFloat x = PopTaggedFloat(); \
2250     StgFloat y = PopTaggedFloat(); \
2251     PushTaggedBool(e);          \
2252 }
2253
2254 #define OP_FF_F(e)              \
2255 {                               \
2256     StgFloat x = PopTaggedFloat(); \
2257     StgFloat y = PopTaggedFloat(); \
2258     PushTaggedFloat(e);         \
2259 }
2260
2261 #define OP_F_F(e)               \
2262 {                               \
2263     StgFloat x = PopTaggedFloat(); \
2264     PushTaggedFloat(e);         \
2265 }
2266
2267 #define OP_F_B(e)               \
2268 {                               \
2269     StgFloat x = PopTaggedFloat(); \
2270     PushTaggedBool(e);         \
2271 }
2272
2273 #define OP_F_I(e)               \
2274 {                               \
2275     StgFloat x = PopTaggedFloat(); \
2276     PushTaggedInt(e);           \
2277 }
2278
2279 #define OP_F_D(e)               \
2280 {                               \
2281     StgFloat x = PopTaggedFloat(); \
2282     PushTaggedDouble(e);        \
2283 }
2284
2285 #define OP_DD_B(e)                \
2286 {                                 \
2287     StgDouble x = PopTaggedDouble(); \
2288     StgDouble y = PopTaggedDouble(); \
2289     PushTaggedBool(e);            \
2290 }
2291
2292 #define OP_DD_D(e)                \
2293 {                                 \
2294     StgDouble x = PopTaggedDouble(); \
2295     StgDouble y = PopTaggedDouble(); \
2296     PushTaggedDouble(e);          \
2297 }
2298
2299 #define OP_D_B(e)                 \
2300 {                                 \
2301     StgDouble x = PopTaggedDouble(); \
2302     PushTaggedBool(e);          \
2303 }
2304
2305 #define OP_D_D(e)                 \
2306 {                                 \
2307     StgDouble x = PopTaggedDouble(); \
2308     PushTaggedDouble(e);          \
2309 }
2310
2311 #define OP_D_I(e)                 \
2312 {                                 \
2313     StgDouble x = PopTaggedDouble(); \
2314     PushTaggedInt(e);             \
2315 }
2316
2317 #define OP_D_F(e)                 \
2318 {                                 \
2319     StgDouble x = PopTaggedDouble(); \
2320     PushTaggedFloat(e);           \
2321 }
2322
2323
2324 StgPtr CreateByteArrayToHoldInteger ( int nbytes )
2325 {
2326    StgWord words     = (nbytes+sizeof(W_)-1)/sizeof(W_);
2327    StgWord size      = sizeofW(StgArrWords) + words;
2328    StgArrWords* arr  = (StgArrWords*)allocate(size);
2329    SET_HDR(arr,&ARR_WORDS_info,CCCS);
2330    arr->words = words;
2331    ASSERT((W_)nbytes <= arr->words * sizeof(W_));
2332 #ifdef DEBUG
2333    {StgWord i;
2334     for (i = 0; i < words; ++i) {
2335     arr->payload[i] = 0xdeadbeef;
2336    }}
2337    { B* b = (B*) &(arr->payload[0]);
2338      b->used = b->sign = 0;
2339    }
2340 #endif
2341    return (StgPtr)arr;
2342 }
2343
2344 B* IntegerInsideByteArray ( StgPtr arr0 )
2345 {
2346    B* b;
2347    StgArrWords* arr = (StgArrWords*)arr0;
2348    ASSERT(GET_INFO(arr) == &ARR_WORDS_info);
2349    b = (B*) &(arr->payload[0]);
2350    return b;
2351 }
2352
2353 void SloppifyIntegerEnd ( StgPtr arr0 )
2354 {
2355    StgArrWords* arr = (StgArrWords*)arr0;
2356    B* b = (B*) & (arr->payload[0]);
2357    I_ nwunused = arr->words - sizeofW(B) - (b->used+sizeof(W_)-1)/sizeof(W_);
2358    if (nwunused >= ((I_)sizeofW(StgArrWords))) {
2359       StgArrWords* slop;
2360       b->size -= nwunused * sizeof(W_);
2361       if (b->size < b->used) b->size = b->used;
2362       do_renormalise(b);
2363       ASSERT(is_sane(b));
2364       arr->words -= nwunused;
2365       slop = (StgArrWords*)&(arr->payload[arr->words]);
2366       SET_HDR(slop,&ARR_WORDS_info,CCCS);
2367       slop->words = nwunused - sizeofW(StgArrWords);
2368       ASSERT( &(slop->payload[slop->words]) ==
2369               &(arr->payload[arr->words + nwunused]) );
2370    }
2371 }
2372
2373 #define OP_Z_Z(op)                                   \
2374 {                                                    \
2375    B* x     = IntegerInsideByteArray(PopPtr());      \
2376    int n    = mycat2(size_,op)(x);                   \
2377    StgPtr p = CreateByteArrayToHoldInteger(n);       \
2378    mycat2(do_,op)(x,n,IntegerInsideByteArray(p));    \
2379    SloppifyIntegerEnd(p);                            \
2380    PushPtr(p);                                       \
2381 }
2382 #define OP_ZZ_Z(op)                                  \
2383 {                                                    \
2384    B* x     = IntegerInsideByteArray(PopPtr());      \
2385    B* y     = IntegerInsideByteArray(PopPtr());      \
2386    int n    = mycat2(size_,op)(x,y);                 \
2387    StgPtr p = CreateByteArrayToHoldInteger(n);       \
2388    mycat2(do_,op)(x,y,n,IntegerInsideByteArray(p));  \
2389    SloppifyIntegerEnd(p);                            \
2390    PushPtr(p);                                       \
2391 }
2392
2393
2394
2395
2396 #define HEADER_mI(ty,where)          \
2397     StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \
2398     nat i = PopTaggedInt();   \
2399     if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) {        \
2400         return (raiseIndex(where));  \
2401     }
2402 #define OP_mI_ty(ty,where,s)        \
2403 {                                   \
2404     HEADER_mI(mycat2(Stg,ty),where) \
2405     { mycat2(Stg,ty) r;             \
2406       s;                            \
2407       mycat2(PushTagged,ty)(r);     \
2408     }                               \
2409 }
2410 #define OP_mIty_(ty,where,s)        \
2411 {                                   \
2412     HEADER_mI(mycat2(Stg,ty),where) \
2413     {                               \
2414       mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
2415       s;                            \
2416     }                               \
2417 }
2418
2419
2420 __attribute__ ((unused))
2421 static void myStackCheck ( Capability* cap )
2422 {
2423    /* fprintf(stderr, "myStackCheck\n"); */
2424    if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) {
2425       fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" );
2426       barf("aborting");
2427       ASSERT(0);
2428    }
2429    while (1) {
2430       if (!( (P_)gSu >= (P_)cap->rCurrentTSO->stack
2431               &&
2432               (P_)gSu <= (P_)(cap->rCurrentTSO->stack
2433                               + cap->rCurrentTSO->stack_size))) {
2434          fprintf ( stderr, "myStackCheck: gSu out of stack\n" );
2435          barf("aborting");
2436          ASSERT(0);
2437       }
2438       switch (get_itbl(stgCast(StgClosure*,gSu))->type) {
2439       case CATCH_FRAME:
2440          gSu = (StgUpdateFrame*) ((StgCatchFrame*)(gSu))->link;
2441          break;
2442       case UPDATE_FRAME:
2443          gSu = (StgUpdateFrame*) ((StgUpdateFrame*)(gSu))->link;
2444          break;
2445       case SEQ_FRAME:
2446          gSu = (StgUpdateFrame*) ((StgSeqFrame*)(gSu))->link;
2447          break;
2448       case STOP_FRAME:
2449          goto postloop;
2450       default:
2451          fprintf(stderr, "myStackCheck: invalid activation record\n");
2452          barf("aborting");
2453          ASSERT(0);
2454       }
2455    }
2456    postloop:
2457 }
2458
2459
2460 /* --------------------------------------------------------------------------
2461  * Primop stuff for bytecode interpreter
2462  * ------------------------------------------------------------------------*/
2463
2464 /* Returns & of the next thing to enter (if throwing an exception),
2465    or NULL in the normal case.
2466 */
2467 static void* enterBCO_primop1 ( int primop1code )
2468 {
2469     if (combined)
2470        barf("enterBCO_primop1 in combined mode");
2471
2472     switch (primop1code) {
2473         case i_pushseqframe:
2474             {
2475                StgClosure* c = PopCPtr();
2476                PushSeqFrame();
2477                PushCPtr(c);
2478                break;
2479             }
2480         case i_pushcatchframe:
2481             {
2482                StgClosure* e = PopCPtr();
2483                StgClosure* h = PopCPtr();
2484                PushCatchFrame(h);
2485                PushCPtr(e);
2486                break;
2487             }
2488
2489         case i_gtChar:          OP_CC_B(x>y);        break;
2490         case i_geChar:          OP_CC_B(x>=y);       break;
2491         case i_eqChar:          OP_CC_B(x==y);       break;
2492         case i_neChar:          OP_CC_B(x!=y);       break;
2493         case i_ltChar:          OP_CC_B(x<y);        break;
2494         case i_leChar:          OP_CC_B(x<=y);       break;
2495         case i_charToInt:       OP_C_I(x);           break;
2496         case i_intToChar:       OP_I_C(x);           break;
2497
2498         case i_gtInt:           OP_II_B(x>y);        break;
2499         case i_geInt:           OP_II_B(x>=y);       break;
2500         case i_eqInt:           OP_II_B(x==y);       break;
2501         case i_neInt:           OP_II_B(x!=y);       break;
2502         case i_ltInt:           OP_II_B(x<y);        break;
2503         case i_leInt:           OP_II_B(x<=y);       break;
2504         case i_minInt:          OP__I(INT_MIN);      break;
2505         case i_maxInt:          OP__I(INT_MAX);      break;
2506         case i_plusInt:         OP_II_I(x+y);        break;
2507         case i_minusInt:        OP_II_I(x-y);        break;
2508         case i_timesInt:        OP_II_I(x*y);        break;
2509         case i_quotInt:
2510             {
2511                 int x = PopTaggedInt();
2512                 int y = PopTaggedInt();
2513                 if (y == 0) {
2514                     return (raiseDiv0("quotInt"));
2515                 }
2516                 /* ToDo: protect against minInt / -1 errors
2517                  * (repeat for all other division primops) */
2518                 PushTaggedInt(x/y);
2519             }
2520             break;
2521         case i_remInt:
2522             {
2523                 int x = PopTaggedInt();
2524                 int y = PopTaggedInt();
2525                 if (y == 0) {
2526                     return (raiseDiv0("remInt"));
2527                 }
2528                 PushTaggedInt(x%y);
2529             }
2530             break;
2531         case i_quotRemInt:
2532             {
2533                 StgInt x = PopTaggedInt();
2534                 StgInt y = PopTaggedInt();
2535                 if (y == 0) {
2536                     return (raiseDiv0("quotRemInt"));
2537                 }
2538                 PushTaggedInt(x%y); /* last result  */
2539                 PushTaggedInt(x/y); /* first result */
2540             }
2541             break;
2542         case i_negateInt:       OP_I_I(-x);          break;
2543
2544         case i_andInt:          OP_II_I(x&y);        break;
2545         case i_orInt:           OP_II_I(x|y);        break;
2546         case i_xorInt:          OP_II_I(x^y);        break;
2547         case i_notInt:          OP_I_I(~x);          break;
2548         case i_shiftLInt:       OP_II_I(x<<y);       break;
2549         case i_shiftRAInt:      OP_II_I(x>>y);       break; /* ToDo */
2550         case i_shiftRLInt:      OP_II_I(x>>y);       break; /* ToDo */
2551
2552         case i_gtWord:          OP_WW_B(x>y);        break;
2553         case i_geWord:          OP_WW_B(x>=y);       break;
2554         case i_eqWord:          OP_WW_B(x==y);       break;
2555         case i_neWord:          OP_WW_B(x!=y);       break;
2556         case i_ltWord:          OP_WW_B(x<y);        break;
2557         case i_leWord:          OP_WW_B(x<=y);       break;
2558         case i_minWord:         OP__W(0);            break;
2559         case i_maxWord:         OP__W(UINT_MAX);     break;
2560         case i_plusWord:        OP_WW_W(x+y);        break;
2561         case i_minusWord:       OP_WW_W(x-y);        break;
2562         case i_timesWord:       OP_WW_W(x*y);        break;
2563         case i_quotWord:
2564             {
2565                 StgWord x = PopTaggedWord();
2566                 StgWord y = PopTaggedWord();
2567                 if (y == 0) {
2568                     return (raiseDiv0("quotWord"));
2569                 }
2570                 PushTaggedWord(x/y);
2571             }
2572             break;
2573         case i_remWord:
2574             {
2575                 StgWord x = PopTaggedWord();
2576                 StgWord y = PopTaggedWord();
2577                 if (y == 0) {
2578                     return (raiseDiv0("remWord"));
2579                 }
2580                 PushTaggedWord(x%y);
2581             }
2582             break;
2583         case i_quotRemWord:
2584             {
2585                 StgWord x = PopTaggedWord();
2586                 StgWord y = PopTaggedWord();
2587                 if (y == 0) {
2588                     return (raiseDiv0("quotRemWord"));
2589                 }
2590                 PushTaggedWord(x%y); /* last result  */
2591                 PushTaggedWord(x/y); /* first result */
2592             }
2593             break;
2594         case i_negateWord:      OP_W_W(-x);         break;
2595         case i_andWord:         OP_WW_W(x&y);        break;
2596         case i_orWord:          OP_WW_W(x|y);        break;
2597         case i_xorWord:         OP_WW_W(x^y);        break;
2598         case i_notWord:         OP_W_W(~x);          break;
2599         case i_shiftLWord:      OP_WW_W(x<<y);       break;
2600         case i_shiftRAWord:     OP_WW_W(x>>y);       break; /* ToDo */
2601         case i_shiftRLWord:     OP_WW_W(x>>y);       break; /* ToDo */
2602         case i_intToWord:       OP_I_W(x);           break;
2603         case i_wordToInt:       OP_W_I(x);           break;
2604
2605         case i_gtAddr:          OP_AA_B(x>y);        break;
2606         case i_geAddr:          OP_AA_B(x>=y);       break;
2607         case i_eqAddr:          OP_AA_B(x==y);       break;
2608         case i_neAddr:          OP_AA_B(x!=y);       break;
2609         case i_ltAddr:          OP_AA_B(x<y);        break;
2610         case i_leAddr:          OP_AA_B(x<=y);       break;
2611         case i_intToAddr:       OP_I_A((StgAddr)x);  break;  /*  ToDo */
2612         case i_addrToInt:       OP_A_I((StgInt)x);   break;  /* ToDo */
2613
2614         case i_intToStable:     OP_I_s((StgStablePtr)x); break;
2615         case i_stableToInt:     OP_s_I((W_)x);           break;
2616
2617         case i_indexCharOffAddr:   OP_AI_C(indexCharOffAddrzh(r,x,y));      break;
2618         case i_readCharOffAddr:    OP_AI_C(indexCharOffAddrzh(r,x,y));      break;
2619         case i_writeCharOffAddr:   OP_AIC_(writeCharOffAddrzh(x,y,z));      break;
2620
2621         case i_indexIntOffAddr:    OP_AI_I(indexIntOffAddrzh(r,x,y));       break;
2622         case i_readIntOffAddr:     OP_AI_I(indexIntOffAddrzh(r,x,y));       break;
2623         case i_writeIntOffAddr:    OP_AII_(writeIntOffAddrzh(x,y,z));       break;
2624
2625         case i_indexAddrOffAddr:   OP_AI_A(indexAddrOffAddrzh(r,x,y));      break;
2626         case i_readAddrOffAddr:    OP_AI_A(indexAddrOffAddrzh(r,x,y));      break;
2627         case i_writeAddrOffAddr:   OP_AIA_(writeAddrOffAddrzh(x,y,z));      break;
2628
2629         case i_indexFloatOffAddr:  OP_AI_F(indexFloatOffAddrzh(r,x,y));     break;
2630         case i_readFloatOffAddr:   OP_AI_F(indexFloatOffAddrzh(r,x,y));     break;
2631         case i_writeFloatOffAddr:  OP_AIF_(writeFloatOffAddrzh(x,y,z));     break;
2632
2633         case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y));    break;
2634         case i_readDoubleOffAddr:  OP_AI_D(indexDoubleOffAddrzh(r,x,y));    break;
2635         case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z));    break;
2636
2637         case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2638         case i_readStableOffAddr:  OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2639         case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
2640
2641         case i_compareInteger:
2642             {
2643                 B* x = IntegerInsideByteArray(PopPtr());
2644                 B* y = IntegerInsideByteArray(PopPtr());
2645                 StgInt r = do_cmp(x,y);
2646                 PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
2647             }
2648             break;
2649         case i_negateInteger:      OP_Z_Z(neg);     break;
2650         case i_plusInteger:        OP_ZZ_Z(add);    break;
2651         case i_minusInteger:       OP_ZZ_Z(sub);    break;
2652         case i_timesInteger:       OP_ZZ_Z(mul);    break;
2653         case i_quotRemInteger:
2654             {
2655                 B* x     = IntegerInsideByteArray(PopPtr());
2656                 B* y     = IntegerInsideByteArray(PopPtr());
2657                 int n    = size_qrm(x,y);
2658                 StgPtr q = CreateByteArrayToHoldInteger(n);
2659                 StgPtr r = CreateByteArrayToHoldInteger(n);
2660                 if (do_getsign(y)==0)
2661                    return (raiseDiv0("quotRemInteger"));
2662                 do_qrm(x,y,n,IntegerInsideByteArray(q),
2663                              IntegerInsideByteArray(r));
2664                 SloppifyIntegerEnd(q);
2665                 SloppifyIntegerEnd(r);
2666                 PushPtr(r);
2667                 PushPtr(q);
2668             }
2669             break;
2670         case i_intToInteger:
2671             {
2672                  int n    = size_fromInt();
2673                  StgPtr p = CreateByteArrayToHoldInteger(n);
2674                  do_fromInt( PopTaggedInt(), n, IntegerInsideByteArray(p));
2675                  PushPtr(p);
2676             }
2677             break;
2678         case i_wordToInteger:
2679             {
2680                  int n    = size_fromWord();
2681                  StgPtr p = CreateByteArrayToHoldInteger(n);
2682                  do_fromWord( PopTaggedWord(), n, IntegerInsideByteArray(p));
2683                  PushPtr(p);
2684             }
2685             break;
2686         case i_integerToInt:       PushTaggedInt(do_toInt(
2687                                       IntegerInsideByteArray(PopPtr())
2688                                    ));
2689                                    break;
2690
2691         case i_integerToWord:      PushTaggedWord(do_toWord(
2692                                       IntegerInsideByteArray(PopPtr())
2693                                    ));
2694                                    break;
2695
2696         case i_integerToFloat:     PushTaggedFloat(do_toFloat(
2697                                       IntegerInsideByteArray(PopPtr())
2698                                    ));
2699                                    break;
2700
2701         case i_integerToDouble:    PushTaggedDouble(do_toDouble(
2702                                       IntegerInsideByteArray(PopPtr())
2703                                    ));
2704                                    break;
2705
2706         case i_gtFloat:         OP_FF_B(x>y);        break;
2707         case i_geFloat:         OP_FF_B(x>=y);       break;
2708         case i_eqFloat:         OP_FF_B(x==y);       break;
2709         case i_neFloat:         OP_FF_B(x!=y);       break;
2710         case i_ltFloat:         OP_FF_B(x<y);        break;
2711         case i_leFloat:         OP_FF_B(x<=y);       break;
2712         case i_minFloat:        OP__F(FLT_MIN);      break;
2713         case i_maxFloat:        OP__F(FLT_MAX);      break;
2714         case i_radixFloat:      OP__I(FLT_RADIX);    break;
2715         case i_digitsFloat:     OP__I(FLT_MANT_DIG); break;
2716         case i_minExpFloat:     OP__I(FLT_MIN_EXP);  break;
2717         case i_maxExpFloat:     OP__I(FLT_MAX_EXP);  break;
2718         case i_plusFloat:       OP_FF_F(x+y);        break;
2719         case i_minusFloat:      OP_FF_F(x-y);        break;
2720         case i_timesFloat:      OP_FF_F(x*y);        break;
2721         case i_divideFloat:
2722             {
2723                 StgFloat x = PopTaggedFloat();
2724                 StgFloat y = PopTaggedFloat();
2725                 PushTaggedFloat(x/y);
2726             }
2727             break;
2728         case i_negateFloat:     OP_F_F(-x);          break;
2729         case i_floatToInt:      OP_F_I(x);           break;
2730         case i_intToFloat:      OP_I_F(x);           break;
2731         case i_expFloat:        OP_F_F(exp(x));      break;
2732         case i_logFloat:        OP_F_F(log(x));      break;
2733         case i_sqrtFloat:       OP_F_F(sqrt(x));     break;
2734         case i_sinFloat:        OP_F_F(sin(x));      break;
2735         case i_cosFloat:        OP_F_F(cos(x));      break;
2736         case i_tanFloat:        OP_F_F(tan(x));      break;
2737         case i_asinFloat:       OP_F_F(asin(x));     break;
2738         case i_acosFloat:       OP_F_F(acos(x));     break;
2739         case i_atanFloat:       OP_F_F(atan(x));     break;
2740         case i_sinhFloat:       OP_F_F(sinh(x));     break;
2741         case i_coshFloat:       OP_F_F(cosh(x));     break;
2742         case i_tanhFloat:       OP_F_F(tanh(x));     break;
2743         case i_powerFloat:      OP_FF_F(pow(x,y));   break;
2744
2745         case i_encodeFloatZ:
2746             {
2747                 StgPtr sig = PopPtr();
2748                 StgInt exp = PopTaggedInt();
2749                 PushTaggedFloat(
2750                    B__encodeFloat(IntegerInsideByteArray(sig), exp)
2751                 );
2752             }
2753             break;
2754         case i_decodeFloatZ:
2755             {
2756                 StgFloat f = PopTaggedFloat();
2757                 StgPtr sig = CreateByteArrayToHoldInteger(size_fltmantissa());
2758                 StgInt exp;
2759                 B__decodeFloat(IntegerInsideByteArray(sig), &exp, f);
2760                 PushTaggedInt(exp);
2761                 PushPtr(sig);
2762             }
2763             break;
2764
2765         case i_isNaNFloat:      OP_F_B(isFloatNaN(x));      break;
2766         case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
2767         case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
2768         case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
2769         case i_gtDouble:        OP_DD_B(x>y);        break;
2770         case i_geDouble:        OP_DD_B(x>=y);       break;
2771         case i_eqDouble:        OP_DD_B(x==y);       break;
2772         case i_neDouble:        OP_DD_B(x!=y);       break;
2773         case i_ltDouble:        OP_DD_B(x<y);        break;
2774         case i_leDouble:        OP_DD_B(x<=y)        break;
2775         case i_minDouble:       OP__D(DBL_MIN);      break;
2776         case i_maxDouble:       OP__D(DBL_MAX);      break;
2777         case i_radixDouble:     OP__I(FLT_RADIX);    break;
2778         case i_digitsDouble:    OP__I(DBL_MANT_DIG); break;
2779         case i_minExpDouble:    OP__I(DBL_MIN_EXP);  break;
2780         case i_maxExpDouble:    OP__I(DBL_MAX_EXP);  break;
2781         case i_plusDouble:      OP_DD_D(x+y);        break;
2782         case i_minusDouble:     OP_DD_D(x-y);        break;
2783         case i_timesDouble:     OP_DD_D(x*y);        break;
2784         case i_divideDouble:
2785             {
2786                 StgDouble x = PopTaggedDouble();
2787                 StgDouble y = PopTaggedDouble();
2788                 PushTaggedDouble(x/y);
2789             }
2790             break;
2791         case i_negateDouble:    OP_D_D(-x);          break;
2792         case i_doubleToInt:     OP_D_I(x);           break;
2793         case i_intToDouble:     OP_I_D(x);           break;
2794         case i_doubleToFloat:   OP_D_F(x);           break;
2795         case i_floatToDouble:   OP_F_F(x);           break;
2796         case i_expDouble:       OP_D_D(exp(x));      break;
2797         case i_logDouble:       OP_D_D(log(x));      break;
2798         case i_sqrtDouble:      OP_D_D(sqrt(x));     break;
2799         case i_sinDouble:       OP_D_D(sin(x));      break;
2800         case i_cosDouble:       OP_D_D(cos(x));      break;
2801         case i_tanDouble:       OP_D_D(tan(x));      break;
2802         case i_asinDouble:      OP_D_D(asin(x));     break;
2803         case i_acosDouble:      OP_D_D(acos(x));     break;
2804         case i_atanDouble:      OP_D_D(atan(x));     break;
2805         case i_sinhDouble:      OP_D_D(sinh(x));     break;
2806         case i_coshDouble:      OP_D_D(cosh(x));     break;
2807         case i_tanhDouble:      OP_D_D(tanh(x));     break;
2808         case i_powerDouble:     OP_DD_D(pow(x,y));   break;
2809
2810         case i_encodeDoubleZ:
2811             {
2812                 StgPtr sig = PopPtr();
2813                 StgInt exp = PopTaggedInt();
2814                 PushTaggedDouble(
2815                    B__encodeDouble(IntegerInsideByteArray(sig), exp)
2816                 );
2817             }
2818             break;
2819         case i_decodeDoubleZ:
2820             {
2821                 StgDouble d = PopTaggedDouble();
2822                 StgPtr sig = CreateByteArrayToHoldInteger(size_dblmantissa());
2823                 StgInt exp;
2824                 B__decodeDouble(IntegerInsideByteArray(sig), &exp, d);
2825                 PushTaggedInt(exp);
2826                 PushPtr(sig);
2827             }
2828             break;
2829
2830         case i_isNaNDouble:      OP_D_B(isDoubleNaN(x));      break;
2831         case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
2832         case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
2833         case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
2834         case i_isIEEEDouble:
2835             {
2836                 PushTaggedBool(rtsTrue);
2837             }
2838             break;
2839         default:
2840                 barf("Unrecognised primop1");
2841         }
2842    return NULL;
2843 }
2844
2845
2846
2847 /* For normal cases, return NULL and leave *return2 unchanged.
2848    To return the address of the next thing to enter,
2849       return the address of it and leave *return2 unchanged.
2850    To return a StgThreadReturnCode to the scheduler,
2851       set *return2 to it and return a non-NULL value.
2852    To cause a context switch, set context_switch (its a global),
2853    and optionally set hugsBlock to your rational.
2854 */
2855 static void* enterBCO_primop2 ( int primop2code,
2856                                 int* /*StgThreadReturnCode* */ return2,
2857                                 StgBCO** bco,
2858                                 Capability* cap,
2859                                 HugsBlock *hugsBlock )
2860 {
2861         if (combined) {
2862            /* A small concession: we need to allow ccalls,
2863               even in combined mode.
2864            */
2865            if (primop2code != i_ccall_ccall_IO &&
2866                primop2code != i_ccall_stdcall_IO)
2867               barf("enterBCO_primop2 in combined mode");
2868         }
2869
2870         switch (primop2code) {
2871         case i_raise:  /* raise#{err} */
2872             {
2873                 StgClosure* err = PopCPtr();
2874                 return (raiseAnError(err));
2875             }
2876 #ifdef XMLAMBDA
2877 /*------------------------------------------------------------------------
2878   Insert and Remove primitives on Rows. This is important stuff for
2879   XMlambda, these prims are called *all* the time. That's the reason
2880   for all the specialized versions of the basic instructions.
2881   note: A Gc might move rows around => allocate first, than pop the arguments.
2882 ------------------------------------------------------------------------*/
2883
2884 /*------------------------------------------------------------------------
2885   i_rowInsertAt: insert an element into a row
2886 ------------------------------------------------------------------------*/
2887         case i_rowInsertAt:
2888             {
2889                 StgWord j;
2890                 StgWord i;
2891                 StgWord n;
2892                 StgClosure* x;
2893
2894                 /* allocate a new row before popping arguments */
2895                 StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0));
2896                 StgMutArrPtrs* newRow
2897                     = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + row->ptrs + 1));
2898                 SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
2899
2900                 /* pop row again and pop index and value */
2901                 row = stgCast(StgMutArrPtrs*,PopPtr());
2902                 n   = row->ptrs;
2903                 newRow->ptrs = n+1;
2904
2905                 i   = PopTaggedWord();
2906                 x   = PopCPtr();
2907
2908                 ASSERT(i <= n);
2909
2910                 /* copy the fields, inserting the new value */
2911                 for (j = 0; j < i; j++) {
2912                   newRow->payload[j] = row->payload[j];
2913                 }
2914                 newRow->payload[i] = x;
2915                 for (j = i+1; j <= n; j++)
2916                 {
2917                   newRow->payload[j] = row->payload[j-1];
2918                 }
2919
2920                 PushPtr(stgCast(StgPtr,newRow));
2921                 break;
2922             }
2923
2924 /*------------------------------------------------------------------------
2925   i_rowChainInsert: behaves like a chain of [i_rowInsertAt] calls. This
2926   instruction is vital for XMLambda since we would otherwise allocate
2927   a lot of intermediate rows.
2928   It assumes that the RTS has no NULL pointers.
2929   It behaves 'optimal' if the witnesses are ordered, (lowest on the
2930   bottom of the stack).
2931 ------------------------------------------------------------------------*/
2932 #define ROW_HOLE  0
2933         case i_rowChainInsert:
2934             {
2935                 StgWord witness, topWitness;
2936                 StgClosure* value;
2937                 StgWord j;
2938                 StgWord i;
2939
2940                 /* pop the number of arguments (=witness/value pairs) */
2941                 StgWord n = PopTaggedWord();
2942
2943                 /* allocate a new row before popping boxed arguments */
2944                 StgMutArrPtrs* row  = stgCast(StgMutArrPtrs*,stackPtr(0));
2945                 StgMutArrPtrs* newRow
2946                   = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n + row->ptrs));
2947                 SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
2948
2949                 /* pop the row and assign again (it may have moved during gc!) */
2950                 row = stgCast(StgMutArrPtrs*,PopPtr());
2951                 newRow->ptrs = n + row->ptrs;
2952
2953                 /* zero the fields */
2954                 for (i = 0; i < newRow->ptrs; i++)
2955                 {
2956                   newRow->payload[i] = ROW_HOLE;
2957                 }
2958
2959                 /* insert all values */
2960                 topWitness = 0;         /*invariant: 1 + maximal witness */
2961                 for (i = 0; i < n; i++)
2962                 {
2963                   witness = PopTaggedWord();
2964                   value   = PopCPtr();
2965                   if (witness < topWitness)
2966                   {
2967                     /* shoot, unordered witnesses, we have to bump up everything */
2968                     for (j = topWitness; j > witness; j--)
2969                     {
2970                       newRow->payload[j] = newRow->payload[j-1];
2971                     }
2972                     topWitness += 1;
2973                   }
2974                   else
2975                   {
2976                     topWitness = witness+1;
2977                   }
2978
2979                   ASSERT(topWitness <= n);
2980                   ASSERT(witness < n);
2981                   newRow->payload[witness] = value;
2982                 }
2983
2984                 /* copy the values from the old row into the holes */
2985                 for (j =0, i = 0; i < row->ptrs; j++,i++)
2986                 {
2987                   while (newRow->payload[j] != ROW_HOLE) j++;
2988                   ASSERT(j < n);
2989                   newRow->payload[j] = row->payload[i];
2990                 }
2991
2992                 /* push the result */
2993                 PushPtr(stgCast(StgPtr,newRow));
2994                 break;
2995             }
2996
2997 /*------------------------------------------------------------------------
2998   i_rowChainBuild: exactly as [i_rowChainInsert] but builds a row from scratch.
2999 ------------------------------------------------------------------------*/
3000         case i_rowChainBuild:
3001             {
3002                 StgWord witness, topWitness;
3003                 StgClosure* value;
3004                 StgWord j;
3005                 StgWord i;
3006
3007                 /* pop the number of arguments (=witness/value pairs) */
3008                 StgWord n = PopTaggedWord();
3009
3010                 /* allocate a new row before popping boxed arguments */
3011                 StgMutArrPtrs* newRow
3012                   = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n));
3013                 SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
3014                 newRow->ptrs = n;
3015
3016                 /* insert all values */
3017                 topWitness = 0;         /*invariant: 1 + maximal witness */
3018                 for (i = 0; i < n; i++)
3019                 {
3020                   witness = PopTaggedWord();
3021                   value   = PopCPtr();
3022                   if (witness < topWitness)
3023                   {
3024                     /* shoot, unordered witnesses, we have to bump up everything */
3025                     for (j = topWitness; j > witness; j--)
3026                     {
3027                       newRow->payload[j] = newRow->payload[j-1];
3028                     }
3029                     topWitness += 1;
3030                   }
3031                   else
3032                   {
3033                     topWitness = witness+1;
3034                   }
3035
3036                   ASSERT(topWitness <= n);
3037                   ASSERT(witness < n);
3038                   newRow->payload[witness] = value;
3039                 }
3040
3041                 /* push the result */
3042                 PushPtr(stgCast(StgPtr,newRow));
3043                 break;
3044             }
3045
3046 /*------------------------------------------------------------------------
3047   i_rowRemoveAt: remove an element from a row
3048 ------------------------------------------------------------------------*/
3049         case i_rowRemoveAt:
3050             {
3051                 StgWord j;
3052                 StgWord i;
3053                 StgWord n;
3054
3055                 /* allocate new row before popping the arguments */
3056                 StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0));
3057                 StgMutArrPtrs* newRow
3058                     = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + row->ptrs - 1));
3059                 SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
3060
3061                 /* pop row again and pop the index */
3062                 row = stgCast(StgMutArrPtrs*,PopPtr());
3063                 n            = row->ptrs;
3064                 newRow->ptrs = n-1;
3065
3066                 i   = PopTaggedWord();
3067
3068                 ASSERT(i < n);
3069
3070                 /* copy the fields, except for the removed value. */
3071                 for (j = 0; j < i; j++) {
3072                   newRow->payload[j] = row->payload[j];
3073                 }
3074                 for (j = i+1; j < n; j++)
3075                 {
3076                   newRow->payload[j-1] = row->payload[j];
3077                 }
3078
3079                 PushCPtr(row->payload[i]);
3080                 PushPtr(stgCast(StgPtr,newRow));
3081                 break;
3082             }
3083
3084 /*------------------------------------------------------------------------
3085   i_rowChainRemove: behaves like a chain of [i_rowRemoveAt] calls. Again,
3086   this is a vital instruction to avoid lots of intermediate rows.
3087   It behaves 'optimal' if the witnessses are ordered, lowest on the
3088   bottom of the stack.
3089   The implementation is quite dirty, blame Daan for this :-)
3090   (It overwrites witnesses on the stack with results and marks pointers
3091    using their lowest bit.)
3092 ------------------------------------------------------------------------*/
3093 #define MARK(p)     (stgCast(StgClosure*,(stgCast(StgWord,(p)) | 0x01)))
3094 #define UNMARK(p)   (stgCast(StgClosure*,(stgCast(StgWord,(p)) & ~0x01)))
3095 #define ISMARKED(p) ((stgCast(StgWord,(p)) & 0x01) == 0x01)
3096
3097         case i_rowChainRemove:
3098             {
3099                 const nat sizeofTaggedWord = sizeofW(StgWord) + sizeofW(StackTag);
3100                 StgWord i;
3101                 StgWord j;
3102                 StgWord minWitness;
3103                 nat     base;
3104                 StgClosure* value;
3105
3106
3107                 /* pop number of arguments (=witnesses) */
3108                 StgWord n = PopTaggedWord();
3109
3110                 /* allocate new row before popping boxed arguments */
3111                 StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0));
3112                 StgMutArrPtrs* newRow
3113                     = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + row->ptrs - n));
3114                 SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
3115
3116                 /* pop row and assign again (gc might have moved it) */
3117                 row = stgCast(StgMutArrPtrs*,PopPtr());
3118                 newRow->ptrs = row->ptrs - n;
3119                 ASSERT( row->ptrs > n );
3120
3121                 /* 'push' all elements that are removed */
3122                 base       = n*sizeofTaggedWord;
3123                 minWitness = row->ptrs;
3124                 for (i = 1; i <= n; i++)
3125                 {
3126                   StgWord witness;
3127
3128                   witness = taggedStackWord( base - i*sizeofTaggedWord );
3129                   if (witness >= minWitness)
3130                   {
3131                     /* shoot, unordered witnesses, we have to search for the value */
3132                     nat count;
3133
3134                     count   = witness - minWitness;
3135                     witness = minWitness;
3136                     while (1)
3137                     {
3138                       do{ witness++; } while (ISMARKED(row->payload[witness]));
3139                       if (count == 0) break;
3140                       count--;
3141                     }
3142                   }
3143                   else
3144                   {
3145                     minWitness = witness;
3146                   }
3147                   ASSERT( witness < row->ptrs );
3148                   ASSERT( !ISMARKED(row->payload[witness]) );
3149
3150                   /* mark the element */
3151                   value = row->payload[witness];
3152                   row->payload[witness] = MARK(value);
3153
3154                   /* set the value in the stack (overwriting old witnesses!) */
3155                   setStackPtr( base - i*sizeofW(StgPtr), stgCast(StgPtr,value) );
3156                 }
3157
3158                 /* pop the garbage from the stack */
3159                 gSp = gSp + base - n*sizeofW(StgPtr);
3160
3161                 /* copy all remaining elements and clear the marks */
3162                 for (j = 0, i = 0; i < newRow->ptrs; j++,i++)
3163                 {
3164                   while (ISMARKED(row->payload[j]))
3165                   {
3166                     row->payload[j] = UNMARK(row->payload[j]);
3167                     j++;
3168                   }
3169                   newRow->payload[i] = row->payload[j];
3170                 }
3171
3172                 /* unmark tail */
3173                 while (j < row->ptrs)
3174                 {
3175                   value = row->payload[j];
3176                   if (ISMARKED(value)) row->payload[j] = UNMARK(value);
3177                   j++;
3178                 }
3179
3180 #ifdef DEBUG
3181                 for (i = 0; i < row->ptrs; i++)
3182                 {
3183                   ASSERT(!ISMARKED(row->payload[i]));
3184                 }
3185 #endif
3186
3187                 /* and push the result row */
3188                 PushPtr(stgCast(StgPtr,newRow));
3189                 break;
3190             }
3191
3192 /*------------------------------------------------------------------------
3193   i_rowChainSelect: behaves exactly like [i_rowChainRemove] but doesn't return
3194   the resulting row, only the removed elements.
3195 ------------------------------------------------------------------------*/
3196         case i_rowChainSelect:
3197             {
3198                 const nat sizeofTaggedWord = sizeofW(StgWord) + sizeofW(StackTag);
3199                 StgWord i;
3200                 StgWord minWitness;
3201                 nat     base;
3202                 StgClosure* value;
3203
3204                 /* pop number of arguments (=witnesses) and row*/
3205                 StgWord        n   = PopTaggedWord();
3206                 StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,PopPtr());
3207                 ASSERT( row->ptrs > n );
3208
3209                 /* 'push' all elements that are removed */
3210                 base       = n*sizeofTaggedWord;
3211                 minWitness = row->ptrs;
3212                 for (i = 1; i <= n; i++)
3213                 {
3214                   StgWord witness;
3215
3216                   witness = taggedStackWord( base - i*sizeofTaggedWord );
3217                   if (witness >= minWitness)
3218                   {
3219                     /* shoot, unordered witnesses, we have to search for the value */
3220                     nat count;
3221
3222                     count   = witness - minWitness;
3223                     witness = minWitness;
3224                     while (1)
3225                     {
3226                       do{ witness++; } while (ISMARKED(row->payload[witness]));
3227                       if (count == 0) break;
3228                       count--;
3229                     }
3230                   }
3231                   else
3232                   {
3233                     minWitness = witness;
3234                   }
3235                   ASSERT( witness < row->ptrs );
3236                   ASSERT( !ISMARKED(row->payload[witness]) );
3237
3238                   /* mark the element */
3239                   value = row->payload[witness];
3240                   row->payload[witness] = MARK(value);
3241
3242                   /* set the value in the stack (overwriting old witnesses!) */
3243                   setStackPtr( base - i*sizeofW(StgPtr), stgCast(StgPtr,value) );
3244                 }
3245
3246                 /* pop the garbage from the stack */
3247                 gSp = gSp + base - n*sizeofW(StgPtr);
3248
3249                 /* unmark elements */
3250                 for( i = 0; i < row->ptrs; i++)
3251                 {
3252                   value = row->payload[i];
3253                   if (ISMARKED(value)) row->payload[i] = UNMARK(value);
3254                 }
3255
3256 #ifdef DEBUG
3257                 for (i = 0; i < row->ptrs; i++)
3258                 {
3259                   ASSERT(!ISMARKED(row->payload[i]));
3260                 }
3261 #endif
3262                 break;
3263             }
3264
3265 #endif /* XMLAMBDA */
3266
3267         case i_newRef:
3268             {
3269                 StgClosure* init = PopCPtr();
3270                 StgMutVar* mv
3271                     = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
3272                 SET_HDR(mv,&MUT_VAR_info,CCCS);
3273                 mv->var = init;
3274                 PushPtr(stgCast(StgPtr,mv));
3275                 break;
3276             }
3277         case i_readRef:
3278             {
3279                 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
3280                 PushCPtr(mv->var);
3281                 break;
3282             }
3283         case i_writeRef:
3284             {
3285                 StgMutVar*  mv    = stgCast(StgMutVar*,PopPtr());
3286                 StgClosure* value = PopCPtr();
3287                 mv->var = value;
3288                 break;
3289             }
3290         case i_newArray:
3291             {
3292                 nat         n    = PopTaggedInt(); /* or Word?? */
3293                 StgClosure* init = PopCPtr();
3294                 StgWord     size = sizeofW(StgMutArrPtrs) + n;
3295                 nat i;
3296                 StgMutArrPtrs* arr
3297                     = stgCast(StgMutArrPtrs*,allocate(size));
3298                 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
3299                 arr->ptrs = n;
3300                 for (i = 0; i < n; ++i) {
3301                     arr->payload[i] = init;
3302                 }
3303                 PushPtr(stgCast(StgPtr,arr));
3304                 break;
3305             }
3306         case i_readArray:
3307         case i_indexArray:
3308             {
3309                 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3310                 nat         i   = PopTaggedInt(); /* or Word?? */
3311                 StgWord     n   = arr->ptrs;
3312                 if (i >= n) {
3313                     return (raiseIndex("{index,read}Array"));
3314                 }
3315                 PushCPtr(arr->payload[i]);
3316                 break;
3317             }
3318         case i_writeArray:
3319             {
3320                 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3321                 nat         i   = PopTaggedInt(); /* or Word? */
3322                 StgClosure* v   = PopCPtr();
3323                 StgWord     n   = arr->ptrs;
3324                 if (i >= n) {
3325                     return (raiseIndex("{index,read}Array"));
3326                 }
3327                 arr->payload[i] = v;
3328                 break;
3329             }
3330         case i_sizeArray:
3331         case i_sizeMutableArray:
3332             {
3333                 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3334                 PushTaggedInt(arr->ptrs);
3335                 break;
3336             }
3337         case i_unsafeFreezeArray:
3338             {
3339                 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3340                 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
3341                 PushPtr(stgCast(StgPtr,arr));
3342                 break;
3343             }
3344         case i_unsafeFreezeByteArray:
3345             {
3346                 /* Delightfully simple :-) */
3347                 break;
3348             }
3349         case i_sameRef:
3350         case i_sameMutableArray:
3351         case i_sameMutableByteArray:
3352             {
3353                 StgPtr x = PopPtr();
3354                 StgPtr y = PopPtr();
3355                 PushTaggedBool(x==y);
3356                 break;
3357             }
3358
3359         case i_newByteArray:
3360             {
3361                 nat     n     = PopTaggedInt(); /* or Word?? */
3362                 StgInt  words = (n+sizeof(W_)-1)/sizeof(W_);
3363                 StgWord size  = sizeofW(StgArrWords) + words;
3364                 StgArrWords* arr  = stgCast(StgArrWords*,allocate(size));
3365                 SET_HDR(arr,&ARR_WORDS_info,CCCS);
3366                 arr->words = words;
3367 #ifdef DEBUG
3368                {nat i;
3369                for (i = 0; i < n; ++i) {
3370                     arr->payload[i] = 0xdeadbeef;
3371                }}
3372 #endif
3373                 PushPtr(stgCast(StgPtr,arr));
3374                 break;
3375             }
3376
3377         /* Most of these generate alignment warnings on Sparcs and similar architectures.
3378          * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
3379          */
3380         case i_indexCharArray:
3381             OP_mI_ty(Char,"indexCharArray",    indexCharArrayzh(r,x,i)); break;
3382         case i_readCharArray:
3383             OP_mI_ty(Char,"readCharArray",     readCharArrayzh(r,x,i));  break;
3384         case i_writeCharArray:
3385             OP_mIty_(Char,"writeCharArray",    writeCharArrayzh(x,i,z)); break;
3386
3387         case i_indexIntArray:
3388             OP_mI_ty(Int,"indexIntArray",      indexIntArrayzh(r,x,i)); break;
3389         case i_readIntArray:
3390             OP_mI_ty(Int,"readIntArray",       readIntArrayzh(r,x,i));  break;
3391         case i_writeIntArray:
3392             OP_mIty_(Int,"writeIntArray",      writeIntArrayzh(x,i,z)); break;
3393
3394         case i_indexAddrArray:
3395             OP_mI_ty(Addr,"indexAddrArray",   indexAddrArrayzh(r,x,i)); break;
3396         case i_readAddrArray:
3397             OP_mI_ty(Addr,"readAddrArray",    readAddrArrayzh(r,x,i));  break;
3398         case i_writeAddrArray:
3399             OP_mIty_(Addr,"writeAddrArray",   writeAddrArrayzh(x,i,z)); break;
3400
3401         case i_indexFloatArray:
3402             OP_mI_ty(Float,"indexFloatArray",  indexFloatArrayzh(r,x,i)); break;
3403         case i_readFloatArray:
3404             OP_mI_ty(Float,"readFloatArray",   readFloatArrayzh(r,x,i));  break;
3405         case i_writeFloatArray:
3406             OP_mIty_(Float,"writeFloatArray",  writeFloatArrayzh(x,i,z)); break;
3407
3408         case i_indexDoubleArray:
3409             OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break;
3410         case i_readDoubleArray:
3411             OP_mI_ty(Double,"readDoubleArray",  readDoubleArrayzh(r,x,i));  break;
3412         case i_writeDoubleArray:
3413             OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break;
3414
3415 #if 0
3416 #ifdef PROVIDE_STABLE
3417         case i_indexStableArray:
3418             OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break;
3419         case i_readStableArray:
3420             OP_mI_ty(StablePtr,"readStableArray",  readStablePtrArrayzh(r,x,i));  break;
3421         case i_writeStableArray:
3422             OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
3423 #endif
3424 #endif
3425
3426
3427
3428 #ifdef PROVIDE_COERCE
3429         case i_unsafeCoerce:
3430             {
3431                 /* Another nullop */
3432                 break;
3433             }
3434 #endif
3435 #ifdef PROVIDE_PTREQUALITY
3436         case i_reallyUnsafePtrEquality:
3437             { /* identical to i_sameRef */
3438                 StgPtr x = PopPtr();
3439                 StgPtr y = PopPtr();
3440                 PushTaggedBool(x==y);
3441                 break;
3442             }
3443 #endif
3444 #ifdef PROVIDE_FOREIGN
3445                 /* ForeignObj# operations */
3446         case i_mkForeignObj:
3447             {
3448                 StgForeignObj *result
3449                     = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
3450                 SET_HDR(result,&FOREIGN_info,CCCS);
3451                 result -> data      = PopTaggedAddr();
3452                 PushPtr(stgCast(StgPtr,result));
3453                 break;
3454             }
3455 #endif /* PROVIDE_FOREIGN */
3456 #ifdef PROVIDE_WEAK
3457         case i_makeWeak:
3458             {
3459                 StgWeak *w
3460                     = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
3461                 SET_HDR(w, &WEAK_info, CCCS);
3462                 w->key        = PopCPtr();
3463                 w->value      = PopCPtr();
3464                 w->finaliser  = PopCPtr();
3465                 w->link       = weak_ptr_list;
3466                 weak_ptr_list = w;
3467                 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
3468                 PushPtr(stgCast(StgPtr,w));
3469                 break;
3470             }
3471         case i_deRefWeak:
3472             {
3473                 StgWeak *w = stgCast(StgWeak*,PopPtr());
3474                 if (w->header.info == &WEAK_info) {
3475                     PushCPtr(w->value); /* last result  */
3476                     PushTaggedInt(1);   /* first result */
3477                 } else {
3478                     PushPtr(stgCast(StgPtr,w));
3479                            /* ToDo: error thunk would be better */
3480                     PushTaggedInt(0);
3481                 }
3482                 break;
3483             }
3484 #endif /* PROVIDE_WEAK */
3485
3486         case i_makeStablePtr:
3487             {
3488                 StgPtr       p  = PopPtr();
3489                 StgStablePtr sp = getStablePtr ( p );
3490                 PushTaggedStablePtr(sp);
3491                 break;
3492             }
3493         case i_deRefStablePtr:
3494             {
3495                 StgPtr p;
3496                 StgStablePtr sp = PopTaggedStablePtr();
3497                 p = deRefStablePtr(sp);
3498                 PushPtr(p);
3499                 break;
3500             }
3501         case i_freeStablePtr:
3502             {
3503                 StgStablePtr sp = PopTaggedStablePtr();
3504                 freeStablePtr(sp);
3505                 break;
3506             }
3507
3508         case i_createAdjThunkARCH:
3509             {
3510                 StgStablePtr stableptr = PopTaggedStablePtr();
3511                 StgAddr      typestr   = PopTaggedAddr();
3512                 StgChar      callconv  = PopTaggedChar();
3513                 StgAddr      adj_thunk = createAdjThunk(stableptr,typestr,callconv);
3514                 PushTaggedAddr(adj_thunk);
3515                 break;
3516             }
3517
3518         case i_getArgc:
3519             {
3520                 StgInt n = prog_argc;
3521                 PushTaggedInt(n);
3522                 break;
3523             }
3524         case i_getArgv:
3525             {
3526                 StgInt  n = PopTaggedInt();
3527                 StgAddr a = (StgAddr)prog_argv[n];
3528                 PushTaggedAddr(a);
3529                 break;
3530             }
3531
3532         case i_newMVar:
3533             {
3534                 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
3535                 SET_INFO(mvar,&EMPTY_MVAR_info);
3536                 mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
3537                 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
3538                 PushPtr(stgCast(StgPtr,mvar));
3539                 break;
3540             }
3541         case i_takeMVar:
3542             {
3543                 StgMVar *mvar = (StgMVar*)PopCPtr();
3544                 if (GET_INFO(mvar) == &EMPTY_MVAR_info) {
3545
3546                     /* The MVar is empty.  Attach ourselves to the TSO's
3547                        blocking queue.
3548                     */
3549                     if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
3550                         mvar->head = cap->rCurrentTSO;
3551                     } else {
3552                         mvar->tail->link = cap->rCurrentTSO;
3553                     }
3554                     cap->rCurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
3555                     cap->rCurrentTSO->why_blocked = BlockedOnMVar;
3556                     cap->rCurrentTSO->block_info.closure = (StgClosure *)mvar;
3557                     mvar->tail = cap->rCurrentTSO;
3558
3559                     /* At this point, the top-of-stack holds the MVar,
3560                        and underneath is the world token ().  So the
3561                        stack is in the same state as when primTakeMVar
3562                        was entered (primTakeMVar is handwritten bytecode).
3563                        Push obj, which is this BCO, and return to the
3564                        scheduler.  When the MVar is filled, the scheduler
3565                        will re-enter primTakeMVar, with the args still on
3566                        the top of the stack.
3567                     */
3568                     PushCPtr((StgClosure*)(*bco));
3569                     *return2 = ThreadBlocked;
3570                     return (void*)(1+(char*)(NULL));
3571
3572                 } else {
3573                     PushCPtr(mvar->value);
3574                     mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
3575                     SET_INFO(mvar,&EMPTY_MVAR_info);
3576                 }
3577                 break;
3578             }
3579         case i_putMVar:
3580             {
3581                 StgMVar*    mvar  = stgCast(StgMVar*,PopPtr());
3582                 StgClosure* value = PopCPtr();
3583                 if (GET_INFO(mvar) == &FULL_MVAR_info) {
3584                     return (makeErrorCall("putMVar {full MVar}"));
3585                 } else {
3586                     /* wake up the first thread on the
3587                      * queue, it will continue with the
3588                      * takeMVar operation and mark the
3589                      * MVar empty again.
3590                      */
3591                     mvar->value = value;
3592
3593                     if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
3594                        ASSERT(mvar->head->why_blocked == BlockedOnMVar);
3595                        mvar->head = unblockOne(mvar->head);
3596                        if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
3597                           mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
3598                        }
3599                     }
3600
3601                     /* unlocks the MVar in the SMP case */
3602                     SET_INFO(mvar,&FULL_MVAR_info);
3603
3604                     /* yield for better communication performance */
3605                     context_switch = 1;
3606                 }
3607                 break;
3608             }
3609         case i_sameMVar:
3610             {   /* identical to i_sameRef */
3611                 StgMVar* x = (StgMVar*)PopPtr();
3612                 StgMVar* y = (StgMVar*)PopPtr();
3613                 PushTaggedBool(x==y);
3614                 break;
3615             }
3616 #ifdef PROVIDE_CONCURRENT
3617         case i_forkIO:
3618             {
3619                 StgClosure* closure;
3620                 StgTSO*     tso;
3621                 StgWord     tid;
3622                 closure = PopCPtr();
3623                 tso     = createGenThread (RtsFlags.GcFlags.initialStkSize,closure);
3624                 tid     = tso->id;
3625                 scheduleThread(tso);
3626                 context_switch = 1;
3627                 /* Later: Change to use tso as the ThreadId */
3628                 PushTaggedWord(tid);
3629                 break;
3630             }
3631
3632         case i_killThread:
3633             {
3634                 StgWord n = PopTaggedWord();
3635                 StgTSO* tso = 0;
3636                 StgTSO *t;
3637
3638                 // Map from ThreadId to Thread Structure */
3639                 for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
3640                   if (n == t->id)
3641                     tso = t;
3642                 }
3643                 if (tso == 0) {
3644                   // Already dead
3645                   break;
3646                 }
3647
3648                 while (tso->what_next == ThreadRelocated) {
3649                   tso = tso->link;
3650                 }
3651
3652                 deleteThread(tso);
3653                 if (tso == cap->rCurrentTSO) { /* suicide */
3654                     *return2 = ThreadFinished;
3655                     return (void*)(1+(char*)(NULL));
3656                 }
3657                 break;
3658             }
3659         case i_raiseInThread:
3660           barf("raiseInThread");
3661           ASSERT(0); /* not (yet) supported */
3662         case i_delay:
3663           {
3664             StgInt  n = PopTaggedInt();
3665             context_switch = 1;
3666             hugsBlock->reason = BlockedOnDelay;
3667             hugsBlock->delay = n;
3668             break;
3669           }
3670         case i_waitRead:
3671           {
3672             StgInt  n = PopTaggedInt();
3673             context_switch = 1;
3674             hugsBlock->reason = BlockedOnRead;
3675             hugsBlock->delay = n;
3676             break;
3677           }
3678         case i_waitWrite:
3679           {
3680             StgInt  n = PopTaggedInt();
3681             context_switch = 1;
3682             hugsBlock->reason = BlockedOnWrite;
3683             hugsBlock->delay = n;
3684             break;
3685           }
3686         case i_yield:
3687           {
3688             /* The definition of yield include an enter right after
3689              * the primYield, at which time context_switch is tested.
3690              */
3691             context_switch = 1;
3692             break;
3693           }
3694         case i_getThreadId:
3695             {
3696                 StgWord tid = cap->rCurrentTSO->id;
3697                 PushTaggedWord(tid);
3698                 break;
3699             }
3700         case i_cmpThreadIds:
3701             {
3702                 StgWord tid1 = PopTaggedWord();
3703                 StgWord tid2 = PopTaggedWord();
3704                 if (tid1 < tid2) PushTaggedInt(-1);
3705                 else if (tid1 > tid2) PushTaggedInt(1);
3706                 else PushTaggedInt(0);
3707                 break;
3708             }
3709 #endif /* PROVIDE_CONCURRENT */
3710 #ifdef XMLAMBDA
3711         case i_ccall:
3712             {
3713                 CallInfo        callInfo;
3714                 CFunDescriptor  descriptor;
3715                 void (*funPtr)(void);
3716
3717                 StgWord offset  = PopTaggedWord();  /* offset into bco nonptr section */
3718                 funPtr          = PopTaggedAddr();
3719
3720                 ASSERT(funPtr != NULL);
3721
3722                 /* copy the complete callinfo, the bco might move during GC! */
3723                 callInfo    = *stgCast(CallInfo*, (*bco)->payload + (*bco)->n_ptrs + offset);
3724
3725                 /* copy info to a CFunDescriptor. just for compatibility. */
3726                 descriptor.num_args     = callInfo.argCount;
3727                 descriptor.arg_tys      = callInfo.data;
3728                 descriptor.num_results  = callInfo.resultCount;
3729                 descriptor.result_tys   = callInfo.data + callInfo.argCount + 1;
3730
3731                 /* call out */
3732                 switch (ccall( &descriptor, funPtr, bco, callInfo.callConv, cap ))
3733                 {
3734                 case  0: break;
3735                 case  1: barf( "unhandled type or too many args/results in ccall"); break;
3736                 case  2: barf("ccall not configured correctly for this platform"); break;
3737                 default: barf("unknown return code from ccall"); break;
3738                 }
3739
3740                 break;
3741             }
3742 #endif
3743
3744         case i_ccall_ccall_Id:
3745         case i_ccall_ccall_IO:
3746         case i_ccall_stdcall_Id:
3747         case i_ccall_stdcall_IO:
3748             {
3749                 int r;
3750                 CFunDescriptor* descriptor;
3751                 void (*funPtr)(void);
3752                 char cc;
3753                 descriptor = PopTaggedAddr();
3754                 funPtr     = PopTaggedAddr();
3755                  cc = (primop2code == i_ccall_stdcall_Id ||
3756                            primop2code == i_ccall_stdcall_IO)
3757                           ? 's' : 'c';
3758                 r = ccall(descriptor,funPtr,bco,cc,cap);
3759                 if (r == 0) break;
3760                 if (r == 1)
3761                    return makeErrorCall(
3762                       "unhandled type or too many args/results in ccall");
3763                 if (r == 2)
3764                    barf("ccall not configured correctly for this platform");
3765                 barf("unknown return code from ccall");
3766             }
3767         default:
3768                 barf("Unrecognised primop2");
3769    }
3770    return NULL;
3771 }
3772
3773
3774 /* -----------------------------------------------------------------------------
3775  * ccall support code:
3776  *   marshall moves args from C stack to Haskell stack
3777  *   unmarshall moves args from Haskell stack to C stack
3778  *   argSize calculates how much gSpace you need on the C stack
3779  * ---------------------------------------------------------------------------*/
3780
3781 /* Pop arguments off the C stack and Push them onto the Hugs stack.
3782  * Used when preparing for C calling Haskell or in regSponse to
3783  *  Haskell calling C.
3784  */
3785 nat marshall(char arg_ty, void* arg)
3786 {
3787     switch (arg_ty) {
3788     case INT_REP:
3789             PushTaggedInt(*((int*)arg));
3790             return ARG_SIZE(INT_TAG);
3791 #if 0
3792     case INTEGER_REP:
3793             PushTaggedInteger(*((mpz_ptr*)arg));
3794             return ARG_SIZE(INTEGER_TAG);
3795 #endif
3796     case WORD_REP:
3797             PushTaggedWord(*((unsigned int*)arg));
3798             return ARG_SIZE(WORD_TAG);
3799     case CHAR_REP:
3800             PushTaggedChar(*((char*)arg));
3801             return ARG_SIZE(CHAR_TAG);
3802     case FLOAT_REP:
3803             PushTaggedFloat(*((float*)arg));
3804             return ARG_SIZE(FLOAT_TAG);
3805     case DOUBLE_REP:
3806             PushTaggedDouble(*((double*)arg));
3807             return ARG_SIZE(DOUBLE_TAG);
3808     case ADDR_REP:
3809             PushTaggedAddr(*((void**)arg));
3810             return ARG_SIZE(ADDR_TAG);
3811     case STABLE_REP:
3812             PushTaggedStablePtr(*((StgStablePtr*)arg));
3813             return ARG_SIZE(STABLE_TAG);
3814 #ifdef PROVIDE_FOREIGN
3815     case FOREIGN_REP:
3816             /* Not allowed in this direction - you have to
3817              * call makeForeignPtr explicitly
3818              */
3819             barf("marshall: ForeignPtr#\n");
3820             break;
3821 #endif
3822     case BARR_REP:
3823     case MUTBARR_REP:
3824             /* Not allowed in this direction  */
3825             barf("marshall: [Mutable]ByteArray#\n");
3826             break;
3827     default:
3828             barf("marshall: unrecognised arg type %d\n",arg_ty);
3829             break;
3830     }
3831 }
3832
3833 /* Pop arguments off the Hugs stack and Push them onto the C stack.
3834  * Used when preparing for Haskell calling C or in regSponse to
3835  * C calling Haskell.
3836  */
3837 nat unmarshall(char res_ty, void* res)
3838 {
3839     switch (res_ty) {
3840     case INT_REP:
3841             *((int*)res) = PopTaggedInt();
3842             return ARG_SIZE(INT_TAG);
3843 #if 0
3844     case INTEGER_REP:
3845             *((mpz_ptr*)res) = PopTaggedInteger();
3846             return ARG_SIZE(INTEGER_TAG);
3847 #endif
3848     case WORD_REP:
3849             *((unsigned int*)res) = PopTaggedWord();
3850             return ARG_SIZE(WORD_TAG);
3851     case CHAR_REP:
3852             *((int*)res) = PopTaggedChar();
3853             return ARG_SIZE(CHAR_TAG);
3854     case FLOAT_REP:
3855             *((float*)res) = PopTaggedFloat();
3856             return ARG_SIZE(FLOAT_TAG);
3857     case DOUBLE_REP:
3858             *((double*)res) = PopTaggedDouble();
3859             return ARG_SIZE(DOUBLE_TAG);
3860     case ADDR_REP:
3861             *((void**)res) = PopTaggedAddr();
3862             return ARG_SIZE(ADDR_TAG);
3863     case STABLE_REP:
3864             *((StgStablePtr*)res) = PopTaggedStablePtr();
3865             return ARG_SIZE(STABLE_TAG);
3866 #ifdef PROVIDE_FOREIGN
3867     case FOREIGN_REP:
3868         {
3869             StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
3870             *((void**)res) = result->data;
3871             return sizeofW(StgPtr);
3872         }
3873 #endif
3874     case BARR_REP:
3875     case MUTBARR_REP:
3876         {
3877             StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3878             *((void**)res) = stgCast(void*,&(arr->payload));
3879             return sizeofW(StgPtr);
3880         }
3881     default:
3882             barf("unmarshall: unrecognised result type %d\n",res_ty);
3883     }
3884 }
3885
3886 nat argSize( const char* ks )
3887 {
3888     nat sz = 0;
3889     for( ; *ks != '\0'; ++ks) {
3890         switch (*ks) {
3891         case INT_REP:
3892                 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
3893                 break;
3894 #if 0
3895         case INTEGER_REP:
3896                 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
3897                 break;
3898 #endif
3899         case WORD_REP:
3900                 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
3901                 break;
3902         case CHAR_REP:
3903                 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
3904                 break;
3905         case FLOAT_REP:
3906                 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
3907                 break;
3908         case DOUBLE_REP:
3909                 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
3910                 break;
3911         case ADDR_REP:
3912                 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
3913                 break;
3914         case STABLE_REP:
3915                 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
3916                 break;
3917 #ifdef PROVIDE_FOREIGN
3918         case FOREIGN_REP:
3919 #endif
3920         case BARR_REP:
3921         case MUTBARR_REP:
3922                 sz += sizeof(StgPtr);
3923                 break;
3924         default:
3925                 barf("argSize: unrecognised result type %d\n",*ks);
3926                 break;
3927         }
3928     }
3929     return sz;
3930 }
3931
3932
3933 /* -----------------------------------------------------------------------------
3934  * encode/decode Float/Double code for standalone Hugs
3935  * Code based on the HBC code (lib/fltcode.c) and more recently GHC
3936  * (ghc/rts/StgPrimFloat.c)
3937  * ---------------------------------------------------------------------------*/
3938
3939 #if IEEE_FLOATING_POINT
3940 #define MY_DMINEXP  ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
3941 /* DMINEXP is defined in values.h on Linux (for example) */
3942 #define DHIGHBIT 0x00100000
3943 #define DMSBIT   0x80000000
3944
3945 #define MY_FMINEXP  ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
3946 #define FHIGHBIT 0x00800000
3947 #define FMSBIT   0x80000000
3948 #else
3949 #error The following code doesnt work in a non-IEEE FP environment
3950 #endif
3951
3952 #ifdef WORDS_BIGENDIAN
3953 #define L 1
3954 #define H 0
3955 #else
3956 #define L 0
3957 #define H 1
3958 #endif
3959
3960
3961 StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */
3962 {
3963     StgDouble r;
3964     I_ i;
3965
3966     /* Convert a B to a double; knows a lot about internal rep! */
3967     for(r = 0.0, i = s->used-1; i >= 0; i--)
3968         r = (r * B_BASE_FLT) + s->stuff[i];
3969
3970     /* Now raise to the exponent */
3971     if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3972         r = ldexp(r, e);
3973
3974     /* handle the sign */
3975     if (s->sign < 0) r = -r;
3976
3977     return r;
3978 }
3979
3980
3981
3982 StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */
3983 {
3984     StgFloat r;
3985     I_ i;
3986
3987     /* Convert a B to a float; knows a lot about internal rep! */
3988     for(r = 0.0, i = s->used-1; i >= 0; i--)
3989         r = (r * B_BASE_FLT) + s->stuff[i];
3990
3991     /* Now raise to the exponent */
3992     if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3993         r = ldexp(r, e);
3994
3995     /* handle the sign */
3996     if (s->sign < 0) r = -r;
3997
3998     return r;
3999 }
4000
4001
4002
4003 /* This only supports IEEE floating point */
4004 void B__decodeDouble (B* man, I_* exp, StgDouble dbl)
4005 {
4006     /* Do some bit fiddling on IEEE */
4007     nat low, high;              /* assuming 32 bit ints */
4008     int sign, iexp;
4009     union { double d; int i[2]; } u;    /* assuming 32 bit ints, 64 bit double */
4010
4011     u.d = dbl;      /* grab chunks of the double */
4012     low = u.i[L];
4013     high = u.i[H];
4014
4015     ASSERT(B_BASE == 256);
4016
4017     /* Assume that the supplied B is the right size */
4018     man->size = 8;
4019
4020     if (low == 0 && (high & ~DMSBIT) == 0) {
4021         man->sign = man->used = 0;
4022         *exp = 0L;
4023     } else {
4024         man->used = 8;
4025         man->sign = 1;
4026         iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
4027         sign = high;
4028
4029         high &= DHIGHBIT-1;
4030         if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
4031             high |= DHIGHBIT;
4032         else {
4033             iexp++;
4034             /* A denorm, normalize the mantissa */
4035             while (! (high & DHIGHBIT)) {
4036                 high <<= 1;
4037                 if (low & DMSBIT)
4038                     high++;
4039                 low <<= 1;
4040                 iexp--;
4041             }
4042         }
4043         *exp = (I_) iexp;
4044
4045         man->stuff[7] = (((W_)high) >> 24) & 0xff;
4046         man->stuff[6] = (((W_)high) >> 16) & 0xff;
4047         man->stuff[5] = (((W_)high) >>  8) & 0xff;
4048         man->stuff[4] = (((W_)high)      ) & 0xff;
4049
4050         man->stuff[3] = (((W_)low) >> 24) & 0xff;
4051         man->stuff[2] = (((W_)low) >> 16) & 0xff;
4052         man->stuff[1] = (((W_)low) >>  8) & 0xff;
4053         man->stuff[0] = (((W_)low)      ) & 0xff;
4054
4055         if (sign < 0) man->sign = -1;
4056     }
4057     do_renormalise(man);
4058 }
4059
4060
4061 void B__decodeFloat (B* man, I_* exp, StgFloat flt)
4062 {
4063     /* Do some bit fiddling on IEEE */
4064     int high, sign;                 /* assuming 32 bit ints */
4065     union { float f; int i; } u;    /* assuming 32 bit float and int */
4066
4067     u.f = flt;      /* grab the float */
4068     high = u.i;
4069
4070     ASSERT(B_BASE == 256);
4071
4072     /* Assume that the supplied B is the right size */
4073     man->size = 4;
4074
4075     if ((high & ~FMSBIT) == 0) {
4076         man->sign = man->used = 0;
4077         *exp = 0;
4078     } else {
4079         man->used = 4;
4080         man->sign = 1;
4081         *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
4082         sign = high;
4083
4084         high &= FHIGHBIT-1;
4085         if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
4086             high |= FHIGHBIT;
4087         else {
4088             (*exp)++;
4089             /* A denorm, normalize the mantissa */
4090             while (! (high & FHIGHBIT)) {
4091                 high <<= 1;
4092                 (*exp)--;
4093             }
4094         }
4095         man->stuff[3] = (((W_)high) >> 24) & 0xff;
4096         man->stuff[2] = (((W_)high) >> 16) & 0xff;
4097         man->stuff[1] = (((W_)high) >>  8) & 0xff;
4098         man->stuff[0] = (((W_)high)      ) & 0xff;
4099
4100         if (sign < 0) man->sign = -1;
4101     }
4102     do_renormalise(man);
4103 }
4104
4105 #endif /* INTERPRETER */