ghc/rts/Evaluator.c

   1
   2 /* -----------------------------------------------------------------------------
   3  * Bytecode evaluator
   4  *
   5  * Copyright (c) 1994-1998.
   6  *
   7  * $RCSfile: Evaluator.c,v $
   8  * $Revision: 1.58 $
   9  * $Date: 2000/10/09 11:20:16 $
  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 #if ! FLOATS_AS_DOUBLES
 155 StgFloat  B__encodeFloat (B* s, I_ e);
 156 void      B__decodeFloat (B* man, I_* exp, StgFloat flt);
 157 StgPtr    CreateByteArrayToHoldInteger ( int );
 158 B*        IntegerInsideByteArray ( StgPtr );
 159 void      SloppifyIntegerEnd ( StgPtr );
 160 #endif
 161
 162
 163
 164
 165 #define gSp     MainRegTable.rSp
 166 #define gSu     MainRegTable.rSu
 167 #define gSpLim  MainRegTable.rSpLim
 168
 169
 170 /* Macros to save/load local state. */
 171 #ifdef DEBUG
 172 #define SSS { tSp=gSp = xSp; tSu=gSu = xSu; tSpLim=gSpLim = xSpLim; }
 173 #define LLL { tSp=xSp = gSp; tSu=xSu = gSu; tSpLim=xSpLim = gSpLim; }
 174 #else
 175 #define SSS { gSp = xSp; gSu = xSu; gSpLim = xSpLim; }
 176 #define LLL { xSp = gSp; xSu = gSu; xSpLim = gSpLim; }
 177 #endif
 178
 179 #define RETURN(vvv) {                                           \
 180            StgThreadReturnCode retVal=(vvv);                    \
 181            SSS;                                                 \
 182            cap->rCurrentTSO->sp    = gSp;                       \
 183            cap->rCurrentTSO->su    = gSu;                       \
 184            return retVal;                                       \
 185         }
 186
 187
 188 /* Macros to operate directly on the pulled-out machine state.
 189    These mirror some of the small procedures used in the primop code
 190    below, except you have to be careful about side effects,
 191    ie xPushPtr(xStackPtr(n)) won't work!  It certainly isn't the
 192    same as PushPtr(StackPtr(n)).  Also note that (1) some of
 193    the macros, in particular xPopTagged*, do not make the tag
 194    sanity checks that their non-x cousins do, and (2) some of
 195    the macros depend critically on the semantics of C comma
 196    expressions to work properly.
 197 */
 198 #define xPushPtr(ppp)           { xSp--; *xSp=(StgWord)(ppp); }
 199 #define xPopPtr()               ((StgPtr)(*xSp++))
 200
 201 #define xPushCPtr(ppp)          { xSp--; *xSp=(StgWord)(ppp); }
 202 #define xPopCPtr()              ((StgClosure*)(*xSp++))
 203
 204 #define xPushWord(ppp)          { xSp--; *xSp=(StgWord)(ppp); }
 205 #define xPopWord()              ((StgWord)(*xSp++))
 206
 207 #define xStackPtr(nnn)          ((StgPtr)(*(xSp+(nnn))))
 208 #define xStackWord(nnn)         ((StgWord)(*(xSp+(nnn))))
 209 #define xSetStackWord(iii,www)  xSp[iii]=(StgWord)(www)
 210
 211 #define xPushTag(ttt)           { xSp--; *xSp=(StgWord)(ttt); }
 212 #define xPopTag(ttt)            { StackTag t = (StackTag)(*xSp++); \
 213                                   ASSERT(t == ttt); }
 214
 215 #define xPushTaggedInt(xxx)     { xSp -= sizeofW(StgInt); \
 216                                   *xSp = (xxx); xPushTag(INT_TAG); }
 217 #define xTaggedStackInt(iii)    ((StgInt)(*(xSp+1+(iii))))
 218 #define xPopTaggedInt()         ((xSp++,xSp+=sizeofW(StgInt), \
 219                                  (StgInt)(*(xSp-sizeofW(StgInt)))))
 220
 221 #define xPushTaggedWord(xxx)    { xSp -= sizeofW(StgWord); \
 222                                   *xSp = (xxx); xPushTag(WORD_TAG); }
 223 #define xTaggedStackWord(iii)   ((StgWord)(*(xSp+1+(iii))))
 224 #define xPopTaggedWord()        ((xSp++,xSp+=sizeofW(StgWord), \
 225                                  (StgWord)(*(xSp-sizeofW(StgWord)))))
 226
 227 #define xPushTaggedAddr(xxx)    { xSp -= sizeofW(StgAddr); \
 228                                   *xSp = (StgWord)(xxx); xPushTag(ADDR_TAG); }
 229 #define xTaggedStackAddr(iii)   ((StgAddr)(*(xSp+1+(iii))))
 230 #define xPopTaggedAddr()        ((xSp++,xSp+=sizeofW(StgAddr), \
 231                                  (StgAddr)(*(xSp-sizeofW(StgAddr)))))
 232
 233 #define xPushTaggedStable(xxx)  { xSp -= sizeofW(StgStablePtr); \
 234                                   *xSp = (StgWord)(xxx); xPushTag(STABLE_TAG); }
 235 #define xTaggedStackStable(iii) ((StgStablePtr)(*(xSp+1+(iii))))
 236 #define xPopTaggedStable()      ((xSp++,xSp+=sizeofW(StgStablePtr), \
 237                                  (StgStablePtr)(*(xSp-sizeofW(StgStablePtr)))))
 238
 239 #define xPushTaggedChar(xxx)    { xSp -= sizeofW(StgChar); \
 240                                   *xSp = (StgWord)(xxx); xPushTag(CHAR_TAG); }
 241 #define xTaggedStackChar(iii)   ((StgChar)(*(xSp+1+(iii))))
 242 #define xPopTaggedChar()        ((xSp++,xSp+=sizeofW(StgChar), \
 243                                  (StgChar)(*(xSp-sizeofW(StgChar)))))
 244
 245 #define xPushTaggedFloat(xxx)   { xSp -= sizeofW(StgFloat); \
 246                                   ASSIGN_FLT(xSp,xxx); xPushTag(FLOAT_TAG); }
 247 #define xTaggedStackFloat(iii)  PK_FLT(xSp+1+(iii))
 248 #define xPopTaggedFloat()       ((xSp++,xSp+=sizeofW(StgFloat), \
 249                                  PK_FLT(xSp-sizeofW(StgFloat))))
 250
 251 #define xPushTaggedDouble(xxx)  { xSp -= sizeofW(StgDouble); \
 252                                   ASSIGN_DBL(xSp,xxx); xPushTag(DOUBLE_TAG); }
 253 #define xTaggedStackDouble(iii) PK_DBL(xSp+1+(iii))
 254 #define xPopTaggedDouble()      ((xSp++,xSp+=sizeofW(StgDouble), \
 255                                  PK_DBL(xSp-sizeofW(StgDouble))))
 256
 257
 258 #define xPushUpdateFrame(target, xSp_offset)                      \
 259 {                                                                 \
 260    StgUpdateFrame *__frame;                                       \
 261    __frame = (StgUpdateFrame *)(xSp + (xSp_offset)) - 1;          \
 262    SET_INFO(__frame, (StgInfoTable *)&upd_frame_info);            \
 263    __frame->link = xSu;                                           \
 264    __frame->updatee = (StgClosure *)(target);                     \
 265    xSu = __frame;                                                 \
 266 }
 267
 268 #define xPopUpdateFrame(ooo)                                      \
 269 {                                                                 \
 270     /* NB: doesn't assume that Sp == Su */                        \
 271     IF_DEBUG(evaluator,                                           \
 272              fprintf(stderr,  "Updating ");                       \
 273              printPtr(stgCast(StgPtr,xSu->updatee));              \
 274              fprintf(stderr,  " with ");                          \
 275              printObj(ooo);                                       \
 276              fprintf(stderr,"xSp = %p\txSu = %p\n\n", xSp, xSu);  \
 277              );                                                   \
 278     UPD_IND(xSu->updatee,ooo);                                    \
 279     xSp = stgCast(StgStackPtr,xSu) + sizeofW(StgUpdateFrame);     \
 280     xSu = xSu->link;                                              \
 281 }
 282
 283
 284
 285 /* Instruction stream macros */
 286 #define BCO_INSTR_8  *bciPtr++
 287 #define BCO_INSTR_16 ((bciPtr += 2,  (*(bciPtr-2) << 8) + *(bciPtr-1)))
 288 #define PC (bciPtr - &(bcoInstr(bco,0)))
 289
 290
 291 /* State on entry to enter():
 292  *    - current thread  is in cap->rCurrentTSO;
 293  *    - allocation area is in cap->rCurrentNursery & cap->rNursery
 294  */
 295
 296 StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
 297 {
 298    /* use of register here is primarily to make it clear to compilers
 299       that these entities are non-aliasable.
 300    */
 301     register StgPtr           xSp;    /* local state -- stack pointer */
 302     register StgUpdateFrame*  xSu;    /* local state -- frame pointer */
 303     register StgPtr           xSpLim; /* local state -- stack lim pointer */
 304     register StgClosure*      obj;    /* object currently under evaluation */
 305              char             eCount; /* enter counter, for context switching */
 306
 307
 308    HugsBlock hugsBlock = { NotBlocked, 0 };
 309
 310
 311 #ifdef DEBUG
 312     StgPtr tSp; StgUpdateFrame* tSu; StgPtr tSpLim;
 313 #endif
 314
 315     gSp    = cap->rCurrentTSO->sp;
 316     gSu    = cap->rCurrentTSO->su;
 317     gSpLim = cap->rCurrentTSO->stack + RESERVED_STACK_WORDS;
 318
 319 #ifdef DEBUG
 320     /* use the t values to check that Su/Sp/SpLim do not change unexpectedly */
 321     tSp = gSp; tSu = gSu; tSpLim = gSpLim;
 322 #endif
 323
 324     obj    = obj0;
 325     eCount = 0;
 326
 327     /* Load the local state from global state, and Party On, Dudes! */
 328     /* From here onwards, we operate with the local state and
 329        save/reload it as necessary.
 330     */
 331     LLL;
 332
 333     enterLoop:
 334
 335     numEnters++;
 336
 337 #ifdef DEBUG
 338     ASSERT(gSp == tSp);
 339     ASSERT(gSu == tSu);
 340     ASSERT(gSpLim == tSpLim);
 341     IF_DEBUG(evaluator,
 342              SSS;
 343              enterCountI++;
 344              ASSERT(xSpLim <= xSp && xSp <= stgCast(StgPtr,xSu));
 345              fprintf(stderr,
 346              "\n---------------------------------------------------------------\n");
 347              fprintf(stderr,"(%d) Entering: ",enterCountI); printObj(obj);
 348              fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
 349              fprintf(stderr, "\n" );
 350              printStack(xSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,xSu);
 351              fprintf(stderr, "\n\n");
 352              LLL;
 353             );
 354 #endif
 355
 356     if (
 357 #ifdef DEBUG
 358              ((++eCount) & 0x0F) == 0
 359 #else
 360              ++eCount == 0
 361 #endif
 362        ) {
 363        if (context_switch) {
 364          switch(hugsBlock.reason) {
 365          case NotBlocked: {
 366            xPushCPtr(obj); /* code to restart with */
 367            RETURN(ThreadYielding);
 368          }
 369          case BlockedOnDelay: /* fall through */
 370          case BlockedOnRead:  /* fall through */
 371          case BlockedOnWrite: {
 372            ASSERT(cap->rCurrentTSO->why_blocked == NotBlocked);
 373            cap->rCurrentTSO->why_blocked = BlockedOnDelay;
 374            ACQUIRE_LOCK(&sched_mutex);
 375
 376 #if defined(HAVE_SETITIMER) /* || defined(mingw32_TARGET_OS) */
 377            cap->rCurrentTSO->block_info.delay
 378              = hugsBlock.delay + ticks_since_select;
 379 #else
 380            cap->rCurrentTSO->block_info.target
 381              = hugsBlock.delay + getourtimeofday();
 382 #endif
 383            APPEND_TO_BLOCKED_QUEUE(cap->rCurrentTSO);
 384
 385            RELEASE_LOCK(&sched_mutex);
 386
 387            xPushCPtr(obj); /* code to restart with */
 388            RETURN(ThreadBlocked);
 389          }
 390          default:
 391            barf("Unknown context switch reasoning");
 392          }
 393        }
 394     }
 395
 396     switch ( get_itbl(obj)->type ) {
 397     case INVALID_OBJECT:
 398             barf("Invalid object %p",obj);
 399
 400     case BCO: bco_entry:
 401
 402             /* ---------------------------------------------------- */
 403             /* Start of the bytecode evaluator                      */
 404             /* ---------------------------------------------------- */
 405         {
 406 #           if USE_GCC_LABELS
 407 #           define Ins(x)          &&l##x
 408             static void *labs[] = { INSTRLIST };
 409 #           undef Ins
 410 #           define LoopTopLabel
 411 #           define Case(x)         l##x
 412 #           define Continue        goto *labs[BCO_INSTR_8]
 413 #           define Dispatch        Continue;
 414 #           define EndDispatch
 415 #           else
 416 #           define LoopTopLabel    insnloop:
 417 #           define Case(x)         case x
 418 #           define Continue        goto insnloop
 419 #           define Dispatch        switch (BCO_INSTR_8) {
 420 #           define EndDispatch     }
 421 #           endif
 422
 423             register StgWord8* bciPtr; /* instruction pointer */
 424             register StgBCO*   bco = (StgBCO*)obj;
 425             StgWord wantToGC;
 426
 427             /* Don't need to SSS ... LLL around doYouWantToGC */
 428             wantToGC = doYouWantToGC();
 429             if (wantToGC) {
 430                 xPushCPtr((StgClosure*)bco); /* code to restart with */
 431                 RETURN(HeapOverflow);
 432             }
 433
 434             bciPtr = &(bcoInstr(bco,0));
 435
 436             LoopTopLabel
 437
 438             ASSERT((StgWord)(PC) < bco->n_instrs);
 439             IF_DEBUG(evaluator,
 440             fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", xSp, xSu, PC);
 441                     SSS;
 442                     disInstr(bco,PC);
 443                     if (0) { int i;
 444                     fprintf(stderr,"\n");
 445                       for (i = 8; i >= 0; i--)
 446                          fprintf(stderr, "%d  %p\n", i, (StgPtr)(*(gSp+i)));
 447                       }
 448                     fprintf(stderr,"\n");
 449                     LLL;
 450                    );
 451
 452             Dispatch
 453
 454             Case(i_INTERNAL_ERROR):
 455                     barf("INTERNAL_ERROR at %p:%d",bco,PC-1);
 456             Case(i_PANIC):
 457                     barf("PANIC at %p:%d",bco,PC-1);
 458             Case(i_STK_CHECK):
 459                 {
 460                     int n = BCO_INSTR_8;
 461                     if (xSp - n < xSpLim) {
 462                         xPushCPtr((StgClosure*)bco); /* code to restart with */
 463                         RETURN(StackOverflow);
 464                     }
 465                     Continue;
 466                 }
 467             Case(i_STK_CHECK_big):
 468                 {
 469                     int n = BCO_INSTR_16;
 470                     if (xSp - n < xSpLim) {
 471                         xPushCPtr((StgClosure*)bco); /* code to restart with */
 472                         RETURN(StackOverflow);
 473                     }
 474                     Continue;
 475                 }
 476             Case(i_ARG_CHECK):
 477                 {
 478                     nat n = BCO_INSTR_8;
 479                     if ((StgPtr*)(xSp + n) > (StgPtr*)xSu) {
 480                         StgWord words = (P_)xSu - xSp;
 481
 482                         /* first build a PAP */
 483                         ASSERT((P_)xSu >= xSp);  /* was (words >= 0) but that's always true */
 484                         if (words == 0) { /* optimisation */
 485                             /* Skip building the PAP and update with an indirection. */
 486                         } else {
 487                             /* Build the PAP. */
 488                             /* In the evaluator, we avoid the need to do
 489                              * a heap check here by including the size of
 490                              * the PAP in the heap check we performed
 491                              * when we entered the BCO.
 492                              */
 493                              StgInt  i;
 494                              StgPAP* pap;
 495                              SSS; pap = (StgPAP*)grabHpNonUpd(PAP_sizeW(words)); LLL;
 496                              SET_HDR(pap,&PAP_info,CC_pap);
 497                              pap->n_args = words;
 498                              pap->fun = obj;
 499                              for (i = 0; i < (I_)words; ++i) {
 500                                  payloadWord(pap,i) = xSp[i];
 501                              }
 502                              xSp += words;
 503                              obj = stgCast(StgClosure*,pap);
 504                         }
 505
 506                         /* now deal with "update frame" */
 507                         /* as an optimisation, we process all on top of stack */
 508                         /* instead of just the top one */
 509                         ASSERT(xSp==(P_)xSu);
 510                         do {
 511                             switch (get_itbl(xSu)->type) {
 512                                 case CATCH_FRAME:
 513                                     /* Hit a catch frame during an arg satisfaction check,
 514                                      * so the thing returning (1) has not thrown an
 515                                      * exception, and (2) is of functional type.  Just
 516                                      * zap the catch frame and carry on down the stack
 517                                      * (looking for more arguments, basically).
 518                                      */
 519                                      SSS; PopCatchFrame(); LLL;
 520                                      break;
 521                                 case UPDATE_FRAME:
 522                                      xPopUpdateFrame(obj);
 523                                      break;
 524                                 case STOP_FRAME:
 525                                      barf("STOP frame during pap update");
 526 #if 0
 527                                      cap->rCurrentTSO->what_next = ThreadComplete;
 528                                      SSS; PopStopFrame(obj); LLL;
 529                                      RETURN(ThreadFinished);
 530 #endif
 531                                 case SEQ_FRAME:
 532                                      SSS; PopSeqFrame(); LLL;
 533                                      ASSERT(xSp != (P_)xSu);
 534                                      /* Hit a SEQ frame during an arg satisfaction check.
 535                                       * So now return to bco_info which is under the
 536                                       * SEQ frame.  The following code is copied from a
 537                                       * case RET_BCO further down.  (The reason why we're
 538                                       * here is that something of functional type has
 539                                       * been seq-d on, and we're now returning to the
 540                                       * algebraic-case-continuation which forced the
 541                                       * evaluation in the first place.)
 542                                       */
 543                                       {
 544                                           StgClosure* ret;
 545                                           (void)xPopPtr();
 546                                           ret = xPopCPtr();
 547                                           xPushPtr((P_)obj);
 548                                           obj = ret;
 549                                           goto enterLoop;
 550                                       }
 551                                       break;
 552                                 default:
 553                                       barf("Invalid update frame during argcheck");
 554                             }
 555                         } while (xSp==(P_)xSu);
 556                         goto enterLoop;
 557                     }
 558                     Continue;
 559                 }
 560             Case(i_ALLOC_AP):
 561                 {
 562                     StgPtr p;
 563                     int words = BCO_INSTR_8;
 564                     SSS; p = grabHpUpd(AP_sizeW(words)); LLL;
 565                     xPushPtr(p);
 566                     Continue;
 567                 }
 568             Case(i_ALLOC_CONSTR):
 569                 {
 570                     StgPtr p;
 571                     StgInfoTable* info = bcoConstAddr(bco,BCO_INSTR_8);
 572                     SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
 573                     SET_HDR((StgClosure*)p,info,??);
 574                     xPushPtr(p);
 575                     Continue;
 576                 }
 577             Case(i_ALLOC_CONSTR_big):
 578                 {
 579                     StgPtr p;
 580                     int x = BCO_INSTR_16;
 581                     StgInfoTable* info = bcoConstAddr(bco,x);
 582                     SSS; p = grabHpNonUpd(sizeW_fromITBL(info)); LLL;
 583                     SET_HDR((StgClosure*)p,info,??);
 584                     xPushPtr(p);
 585                     Continue;
 586                 }
 587             Case(i_MKAP):
 588                 {
 589                     int x = BCO_INSTR_8;  /* ToDo: Word not Int! */
 590                     int y = BCO_INSTR_8;
 591                     StgAP_UPD* o = stgCast(StgAP_UPD*,xStackPtr(x));
 592                     SET_HDR(o,&AP_UPD_info,??);
 593                     o->n_args = y;
 594                     o->fun    = stgCast(StgClosure*,xPopPtr());
 595                     for(x=0; x < y; ++x) {
 596                         payloadWord(o,x) = xPopWord();
 597                     }
 598                     IF_DEBUG(evaluator,
 599                              fprintf(stderr,"\tBuilt ");
 600                              SSS;
 601                              printObj(stgCast(StgClosure*,o));
 602                              LLL;
 603                     );
 604                     Continue;
 605                 }
 606             Case(i_MKAP_big):
 607                 {
 608                     int x, y;
 609                     StgAP_UPD* o;
 610                     x = BCO_INSTR_16;
 611                     y = BCO_INSTR_16;
 612                     o = stgCast(StgAP_UPD*,xStackPtr(x));
 613                     SET_HDR(o,&AP_UPD_info,??);
 614                     o->n_args = y;
 615                     o->fun    = stgCast(StgClosure*,xPopPtr());
 616                     for(x=0; x < y; ++x) {
 617                         payloadWord(o,x) = xPopWord();
 618                     }
 619                     IF_DEBUG(evaluator,
 620                              fprintf(stderr,"\tBuilt ");
 621                              SSS;
 622                              printObj(stgCast(StgClosure*,o));
 623                              LLL;
 624                     );
 625                     Continue;
 626                 }
 627             Case(i_MKPAP):
 628                 {
 629                     int x = BCO_INSTR_8;
 630                     int y = BCO_INSTR_8;
 631                     StgPAP* o = stgCast(StgPAP*,xStackPtr(x));
 632                     SET_HDR(o,&PAP_info,??);
 633                     o->n_args = y;
 634                     o->fun    = stgCast(StgClosure*,xPopPtr());
 635                     for(x=0; x < y; ++x) {
 636                         payloadWord(o,x) = xPopWord();
 637                     }
 638                     IF_DEBUG(evaluator,
 639                              fprintf(stderr,"\tBuilt ");
 640                              SSS;
 641                              printObj(stgCast(StgClosure*,o));
 642                              LLL;
 643                             );
 644                     Continue;
 645                 }
 646             Case(i_PACK):
 647                 {
 648                     int offset = BCO_INSTR_8;
 649                     StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
 650                     const StgInfoTable* info = get_itbl(o);
 651                     nat p  = info->layout.payload.ptrs;
 652                     nat np = info->layout.payload.nptrs;
 653                     nat i;
 654                     for(i=0; i < p; ++i) {
 655                         o->payload[i] = xPopCPtr();
 656                     }
 657                     for(i=0; i < np; ++i) {
 658                         payloadWord(o,p+i) = 0xdeadbeef;
 659                     }
 660                     IF_DEBUG(evaluator,
 661                              fprintf(stderr,"\tBuilt ");
 662                              SSS;
 663                              printObj(stgCast(StgClosure*,o));
 664                              LLL;
 665                              );
 666                     Continue;
 667                 }
 668             Case(i_PACK_big):
 669                 {
 670                     int offset = BCO_INSTR_16;
 671                     StgClosure* o = stgCast(StgClosure*,xStackPtr(offset));
 672                     const StgInfoTable* info = get_itbl(o);
 673                     nat p  = info->layout.payload.ptrs;
 674                     nat np = info->layout.payload.nptrs;
 675                     nat i;
 676                     for(i=0; i < p; ++i) {
 677                         o->payload[i] = xPopCPtr();
 678                     }
 679                     for(i=0; i < np; ++i) {
 680                         payloadWord(o,p+i) = 0xdeadbeef;
 681                     }
 682                     IF_DEBUG(evaluator,
 683                              fprintf(stderr,"\tBuilt ");
 684                              SSS;
 685                              printObj(stgCast(StgClosure*,o));
 686                              LLL;
 687                              );
 688                     Continue;
 689                 }
 690             Case(i_SLIDE):
 691                 {
 692                     int x = BCO_INSTR_8;
 693                     int y = BCO_INSTR_8;
 694                     ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
 695                     /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
 696                     while(--x >= 0) {
 697                         xSetStackWord(x+y,xStackWord(x));
 698                     }
 699                     xSp += y;
 700                     Continue;
 701                 }
 702             Case(i_SLIDE_big):
 703                 {
 704                     int x, y;
 705                     x = BCO_INSTR_16;
 706                     y = BCO_INSTR_16;
 707                     ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
 708                     /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
 709                     while(--x >= 0) {
 710                         xSetStackWord(x+y,xStackWord(x));
 711                     }
 712                     xSp += y;
 713                     Continue;
 714                 }
 715             Case(i_ENTER):
 716                 {
 717                     obj = xPopCPtr();
 718                     goto enterLoop;
 719                 }
 720             Case(i_RETADDR):
 721                 {
 722                     xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
 723                     xPushPtr(stgCast(StgPtr,&ret_bco_info));
 724                     Continue;
 725                 }
 726             Case(i_TEST):
 727                 {
 728                     int  tag       = BCO_INSTR_8;
 729                     StgWord offset = BCO_INSTR_16;
 730                     if (constrTag( (StgClosure*)xStackPtr(0) ) != tag) {
 731                         bciPtr += offset;
 732                     }
 733                     Continue;
 734                 }
 735             Case(i_UNPACK):
 736                 {
 737                     StgClosure* o = stgCast(StgClosure*,xStackPtr(0));
 738                     const StgInfoTable* itbl = get_itbl(o);
 739                     int i = itbl->layout.payload.ptrs;
 740                     ASSERT(  itbl->type == CONSTR
 741                           || itbl->type == CONSTR_STATIC
 742                           || itbl->type == CONSTR_NOCAF_STATIC
 743                           || itbl->type == CONSTR_1_0
 744                           || itbl->type == CONSTR_0_1
 745                           || itbl->type == CONSTR_2_0
 746                           || itbl->type == CONSTR_1_1
 747                           || itbl->type == CONSTR_0_2
 748                           );
 749                     while (--i>=0) {
 750                         xPushCPtr(o->payload[i]);
 751                     }
 752                     Continue;
 753                 }
 754             Case(i_VAR_big):
 755                 {
 756                     int n = BCO_INSTR_16;
 757                     StgPtr p = xStackPtr(n);
 758                     xPushPtr(p);
 759                     Continue;
 760                 }
 761             Case(i_VAR):
 762                 {
 763                     StgPtr p = xStackPtr(BCO_INSTR_8);
 764                     xPushPtr(p);
 765                     Continue;
 766                 }
 767             Case(i_CONST):
 768                 {
 769                     xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,BCO_INSTR_8)));
 770                     Continue;
 771                 }
 772             Case(i_CONST_big):
 773                 {
 774                     int n = BCO_INSTR_16;
 775                     xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,n)));
 776                     Continue;
 777                 }
 778 #ifdef XMLAMBDA
 779             /* allocate rows, implemented on top of (frozen) Arrays */
 780             Case(i_ALLOC_ROW):
 781                 {
 782                     StgMutArrPtrs* p;
 783                     StgWord n = BCO_INSTR_8;
 784                     SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + n)); LLL;
 785                     SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS);
 786                     p->ptrs = n;
 787                     xPushPtr(p);
 788                     Continue;
 789                 }
 790             Case(i_ALLOC_ROW_big):
 791                 {
 792                     StgMutArrPtrs* p;
 793                     StgWord n = BCO_INSTR_16;
 794                     SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + n)); LLL;
 795                     SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS);
 796                     p->ptrs = n;
 797                     xPushPtr(p);
 798                     Continue;
 799                 }
 800
 801             /* pack values into a row. */
 802             Case(i_PACK_ROW):
 803                 {
 804                     StgWord offset   = BCO_INSTR_8;
 805                     StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(offset));
 806                     StgWord        n = p->ptrs;
 807                     StgWord i;
 808
 809                     for (i=0; i<n; ++i)
 810                     {
 811                       p->payload[i] = xPopCPtr();
 812                     }
 813                     IF_DEBUG(evaluator,
 814                              fprintf(stderr,"\tBuilt ");
 815                              SSS;
 816                              printObj(stgCast(StgClosure*,p));
 817                              LLL;
 818                             );
 819                     Continue;
 820                 }
 821             Case(i_PACK_ROW_big):
 822                 {
 823                     StgWord offset   = BCO_INSTR_16;
 824                     StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(offset));
 825                     StgWord        n = p->ptrs;
 826                     StgWord i;
 827
 828                     for (i=0; i<n; ++i)
 829                     {
 830                       p->payload[i] = xPopCPtr();
 831                     }
 832                     IF_DEBUG(evaluator,
 833                              fprintf(stderr,"\tBuilt ");
 834                              SSS;
 835                              printObj(stgCast(StgClosure*,p));
 836                              LLL;
 837                             );
 838                     Continue;
 839                 }
 840
 841             /* extract all fields of a row */
 842             Case(i_UNPACK_ROW):
 843                 {
 844                     StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(0));
 845                     nat i = p->ptrs;
 846                     while (i > 0)
 847                     {
 848                       i--;
 849                       xPushCPtr(p->payload[i]);
 850                     }
 851                     Continue;
 852                 }
 853
 854             /* Trivial row (unit) */
 855             Case(i_CONST_ROW_TRIV):
 856                 {
 857                     StgMutArrPtrs* p;
 858                     SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + 0)); LLL;
 859                     SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS);
 860                     p->ptrs = 0;
 861                     xPushPtr(p);
 862                     Continue;
 863                 }
 864
 865             /* pack values into an Inj */
 866             Case(i_PACK_INJ_VAR):
 867                 {
 868                     const int size  = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord));
 869                     StgWord offset  = BCO_INSTR_8;
 870
 871                     StgClosure* o;
 872                     SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
 873                     SET_HDR(o,Inj_con_info,??);
 874
 875                     payloadWord(o,sizeofW(StgPtr)) = xTaggedStackWord(offset);
 876                     payloadPtr(o,0)                = xPopPtr();
 877
 878                     IF_DEBUG(evaluator,
 879                              fprintf(stderr,"\tBuilt ");
 880                              SSS;
 881                              printObj(stgCast(StgClosure*,o));
 882                              LLL;
 883                              );
 884                     xPushPtr(stgCast(StgPtr,o));
 885                     Continue;
 886                 }
 887             Case(i_PACK_INJ_VAR_big):
 888                 {
 889                     const int size  = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord));
 890                     StgWord offset  = BCO_INSTR_16;
 891
 892                     StgClosure* o;
 893                     SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
 894                     SET_HDR(o,Inj_con_info,??);
 895
 896                     payloadWord(o,sizeofW(StgPtr)) = xTaggedStackWord(offset);
 897                     payloadPtr(o,0)                = xPopPtr();
 898
 899                     IF_DEBUG(evaluator,
 900                              fprintf(stderr,"\tBuilt ");
 901                              SSS;
 902                              printObj(stgCast(StgClosure*,o));
 903                              LLL;
 904                              );
 905                     xPushPtr(stgCast(StgPtr,o));
 906                     Continue;
 907                 }
 908             Case(i_PACK_INJ_CONST_8):
 909                 {
 910                     const int size  = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord));
 911                     StgWord witness = BCO_INSTR_8;
 912
 913                     StgClosure* o;
 914                     SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
 915                     SET_HDR(o,Inj_con_info,??);
 916
 917                     payloadWord(o,sizeofW(StgPtr)) = witness;
 918                     payloadPtr(o,0)                = xPopPtr();
 919
 920                     IF_DEBUG(evaluator,
 921                              fprintf(stderr,"\tBuilt ");
 922                              SSS;
 923                              printObj(stgCast(StgClosure*,o));
 924                              LLL;
 925                              );
 926                     xPushPtr(stgCast(StgPtr,o));
 927                     Continue;
 928                 }
 929             Case(i_PACK_INJ_REL_8):
 930                 {
 931                     const int size   = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord));
 932                     StgWord offset   = BCO_INSTR_8;
 933                     StgWord cwitness = BCO_INSTR_8;
 934
 935                     StgClosure* o;
 936                     SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
 937                     SET_HDR(o,Inj_con_info,??);
 938
 939                     payloadWord(o,sizeofW(StgPtr)) = xTaggedStackWord(offset) + cwitness;
 940                     payloadPtr(o,0)                = xPopPtr();
 941
 942                     IF_DEBUG(evaluator,
 943                              fprintf(stderr,"\tBuilt ");
 944                              SSS;
 945                              printObj(stgCast(StgClosure*,o));
 946                              LLL;
 947                              );
 948                     xPushPtr(stgCast(StgPtr,o));
 949                     Continue;
 950                 }
 951             Case(i_PACK_INJ):
 952                 {
 953                     const int size  = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord));
 954
 955                     StgClosure* o;
 956                     SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
 957                     SET_HDR(o,Inj_con_info,??);
 958
 959                     payloadWord(o,sizeofW(StgPtr)) = xPopTaggedWord();
 960                     payloadPtr(o,0)                = xPopPtr();
 961
 962                     IF_DEBUG(evaluator,
 963                              fprintf(stderr,"\tBuilt ");
 964                              SSS;
 965                              printObj(stgCast(StgClosure*,o));
 966                              LLL;
 967                              );
 968                     xPushPtr(stgCast(StgPtr,o));
 969                     Continue;
 970                 }
 971
 972             /* Test Inj witnesses. */
 973             Case(i_TEST_INJ_VAR):
 974                 {
 975                     StgWord offset = BCO_INSTR_8;
 976                     StgWord jump   = BCO_INSTR_16;
 977
 978                     StgWord index  = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
 979                     if (index != xTaggedStackWord(offset) )
 980                     {
 981                       bciPtr += jump;
 982                     }
 983                     Continue;
 984                 }
 985             Case(i_TEST_INJ_VAR_big):
 986                 {
 987                     StgWord offset = BCO_INSTR_16;
 988                     StgWord jump   = BCO_INSTR_16;
 989
 990                     StgWord index  = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
 991                     if (index != xTaggedStackWord(offset) )
 992                     {
 993                       bciPtr += jump;
 994                     }
 995                     Continue;
 996                 }
 997             Case(i_TEST_INJ_CONST_8):
 998                 {
 999                     StgWord cwitness = BCO_INSTR_8;
1000                     StgWord jump     = BCO_INSTR_16;
1001
1002                     StgWord witness  = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
1003                     if (witness != cwitness )
1004                     {
1005                       bciPtr += jump;
1006                     }
1007                     Continue;
1008                 }
1009             Case(i_TEST_INJ_REL_8):
1010                 {
1011                     StgWord offset    = BCO_INSTR_8;
1012                     StgWord cwitness  = BCO_INSTR_8;
1013                     StgWord jump      = BCO_INSTR_16;
1014
1015                     StgWord witness  = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
1016                     if (witness != xTaggedStackWord(offset) + cwitness )
1017                     {
1018                       bciPtr += jump;
1019                     }
1020                     Continue;
1021                 }
1022             Case(i_TEST_INJ):
1023                 {
1024                     StgWord jump     = BCO_INSTR_16;
1025                     StgWord cwitness = xPopTaggedWord();
1026
1027                     StgWord witness  = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
1028                     if (witness != cwitness )
1029                     {
1030                       bciPtr += jump;
1031                     }
1032                     Continue;
1033                 }
1034
1035             /* extract the value of an INJ */
1036             Case(i_UNPACK_INJ):
1037                 {
1038                     StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1039
1040                     ASSERT(get_itbl(con) == Inj_con_info);
1041
1042                     xPushPtr(payloadPtr(con,0));
1043                     Continue;
1044                 }
1045
1046             /* optimized witness (word) operations */
1047             Case(i_CONST_WORD_8):
1048                 {
1049                     xPushTaggedWord(BCO_INSTR_8);
1050                     Continue;
1051                 }
1052             Case(i_ADD_WORD_VAR):
1053                 {
1054                     StgWord offset  = BCO_INSTR_8;
1055                     StgWord witness = xTaggedStackWord(offset);
1056                     witness += xPopTaggedWord();
1057                     xPushTaggedWord(witness);
1058                     Continue;
1059                 }
1060             Case(i_ADD_WORD_VAR_big):
1061                 {
1062                     StgWord offset  = BCO_INSTR_16;
1063                     StgWord witness = xTaggedStackWord(offset);
1064                     witness += xPopTaggedWord();
1065                     xPushTaggedWord(witness);
1066                     Continue;
1067                 }
1068             Case(i_ADD_WORD_VAR_8):
1069                 {
1070                     StgWord offset  = BCO_INSTR_8;
1071                     StgWord inc     = BCO_INSTR_8;
1072                     StgWord witness = xTaggedStackWord(offset);
1073                     xPushTaggedWord(witness + inc);
1074                     Continue;
1075                 }
1076 #endif /* XMLAMBA */
1077
1078             Case(i_VOID):
1079                 {
1080                     SSS; PushTaggedRealWorld(); LLL;
1081                     Continue;
1082                 }
1083             Case(i_VAR_INT):
1084                 {
1085                     StgInt i = xTaggedStackInt(BCO_INSTR_8);
1086                     xPushTaggedInt(i);
1087                     Continue;
1088                 }
1089             Case(i_CONST_INT):
1090                 {
1091                     xPushTaggedInt(bcoConstInt(bco,BCO_INSTR_8));
1092                     Continue;
1093                 }
1094             Case(i_CONST_INT_big):
1095                 {
1096                     int n = BCO_INSTR_16;
1097                     xPushTaggedInt(bcoConstInt(bco,n));
1098                     Continue;
1099                 }
1100             Case(i_PACK_INT):
1101                 {
1102                     StgClosure* o;
1103                     SSS; o = (StgClosure*)grabHpNonUpd(Izh_sizeW); LLL;
1104                     SET_HDR(o,Izh_con_info,??);
1105                     payloadWord(o,0) = xPopTaggedInt();
1106                     IF_DEBUG(evaluator,
1107                              fprintf(stderr,"\tBuilt ");
1108                              SSS;
1109                              printObj(stgCast(StgClosure*,o));
1110                              LLL;
1111                              );
1112                     xPushPtr(stgCast(StgPtr,o));
1113                     Continue;
1114                 }
1115             Case(i_UNPACK_INT):
1116                 {
1117                     StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1118                     /* ASSERT(isIntLike(con)); */
1119                     xPushTaggedInt(payloadWord(con,0));
1120                     Continue;
1121                 }
1122             Case(i_TEST_INT):
1123                 {
1124                     StgWord offset = BCO_INSTR_16;
1125                     StgInt  x      = xPopTaggedInt();
1126                     StgInt  y      = xPopTaggedInt();
1127                     if (x != y) {
1128                         bciPtr += offset;
1129                     }
1130                     Continue;
1131                 }
1132             Case(i_CONST_INTEGER):
1133                 {
1134                     StgPtr p;
1135                     int n;
1136                     char* s = bcoConstAddr(bco,BCO_INSTR_8);
1137                     SSS;
1138                     n = size_fromStr(s);
1139                     p = CreateByteArrayToHoldInteger(n);
1140                     do_fromStr ( s, n, IntegerInsideByteArray(p));
1141                     SloppifyIntegerEnd(p);
1142                     LLL;
1143                     xPushPtr(p);
1144                     Continue;
1145                 }
1146             Case(i_VAR_WORD):
1147                 {
1148                     StgWord w = xTaggedStackWord(BCO_INSTR_8);
1149                     xPushTaggedWord(w);
1150                     Continue;
1151                 }
1152             Case(i_CONST_WORD):
1153                 {
1154                     xPushTaggedWord(bcoConstWord(bco,BCO_INSTR_8));
1155                     Continue;
1156                 }
1157             Case(i_CONST_WORD_big):
1158                 {
1159                     StgWord n = BCO_INSTR_16;
1160                     xPushTaggedWord(bcoConstWord(bco,n));
1161                     Continue;
1162                 }
1163             Case(i_PACK_WORD):
1164                 {
1165                     StgClosure* o;
1166                     SSS; o = (StgClosure*)grabHpNonUpd(Wzh_sizeW); LLL;
1167                     SET_HDR(o,Wzh_con_info,??);
1168                     payloadWord(o,0) = xPopTaggedWord();
1169                     IF_DEBUG(evaluator,
1170                              fprintf(stderr,"\tBuilt ");
1171                              SSS;
1172                              printObj(stgCast(StgClosure*,o));
1173                              LLL;
1174                             );
1175                     xPushPtr(stgCast(StgPtr,o));
1176                     Continue;
1177                 }
1178             Case(i_UNPACK_WORD):
1179                 {
1180                     StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1181                     /* ASSERT(isWordLike(con)); */
1182                     xPushTaggedWord(payloadWord(con,0));
1183                     Continue;
1184                 }
1185             Case(i_VAR_ADDR):
1186                 {
1187                     StgAddr a = xTaggedStackAddr(BCO_INSTR_8);
1188                     xPushTaggedAddr(a);
1189                     Continue;
1190                 }
1191             Case(i_CONST_ADDR):
1192                 {
1193                     xPushTaggedAddr(bcoConstAddr(bco,BCO_INSTR_8));
1194                     Continue;
1195                 }
1196             Case(i_CONST_ADDR_big):
1197                 {
1198                     int n = BCO_INSTR_16;
1199                     xPushTaggedAddr(bcoConstAddr(bco,n));
1200                     Continue;
1201                 }
1202             Case(i_PACK_ADDR):
1203                 {
1204                     StgClosure* o;
1205                     SSS; o = (StgClosure*)grabHpNonUpd(Azh_sizeW); LLL;
1206                     SET_HDR(o,Azh_con_info,??);
1207                     payloadPtr(o,0) = xPopTaggedAddr();
1208                     IF_DEBUG(evaluator,
1209                              fprintf(stderr,"\tBuilt ");
1210                              SSS;
1211                              printObj(stgCast(StgClosure*,o));
1212                              LLL;
1213                              );
1214                     xPushPtr(stgCast(StgPtr,o));
1215                     Continue;
1216                 }
1217             Case(i_UNPACK_ADDR):
1218                 {
1219                     StgClosure* con = (StgClosure*)xStackPtr(0);
1220                     /* ASSERT(isAddrLike(con)); */
1221                     xPushTaggedAddr(payloadPtr(con,0));
1222                     Continue;
1223                 }
1224             Case(i_VAR_CHAR):
1225                 {
1226                     StgChar c = xTaggedStackChar(BCO_INSTR_8);
1227                     xPushTaggedChar(c);
1228                     Continue;
1229                 }
1230             Case(i_CONST_CHAR):
1231                 {
1232                     xPushTaggedChar(bcoConstChar(bco,BCO_INSTR_8));
1233                     Continue;
1234                 }
1235             Case(i_PACK_CHAR):
1236                 {
1237                     StgClosure* o;
1238                     SSS; o = (StgClosure*)grabHpNonUpd(Czh_sizeW); LLL;
1239                     SET_HDR(o,Czh_con_info,??);
1240                     payloadWord(o,0) = xPopTaggedChar();
1241                     xPushPtr(stgCast(StgPtr,o));
1242                     IF_DEBUG(evaluator,
1243                              fprintf(stderr,"\tBuilt ");
1244                              SSS;
1245                              printObj(stgCast(StgClosure*,o));
1246                              LLL;
1247                              );
1248                     Continue;
1249                 }
1250             Case(i_UNPACK_CHAR):
1251                 {
1252                     StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1253                     /* ASSERT(isCharLike(con)); */
1254                     xPushTaggedChar(payloadWord(con,0));
1255                     Continue;
1256                 }
1257             Case(i_VAR_FLOAT):
1258                 {
1259                     StgFloat f = xTaggedStackFloat(BCO_INSTR_8);
1260                     xPushTaggedFloat(f);
1261                     Continue;
1262                 }
1263             Case(i_CONST_FLOAT):
1264                 {
1265                     xPushTaggedFloat(bcoConstFloat(bco,BCO_INSTR_8));
1266                     Continue;
1267                 }
1268             Case(i_PACK_FLOAT):
1269                 {
1270                     StgClosure* o;
1271                     SSS; o = (StgClosure*)grabHpNonUpd(Fzh_sizeW); LLL;
1272                     SET_HDR(o,Fzh_con_info,??);
1273                     ASSIGN_FLT(&payloadWord(o,0),xPopTaggedFloat());
1274                     IF_DEBUG(evaluator,
1275                              fprintf(stderr,"\tBuilt ");
1276                              SSS;
1277                              printObj(stgCast(StgClosure*,o));
1278                              LLL;
1279                              );
1280                     xPushPtr(stgCast(StgPtr,o));
1281                     Continue;
1282                 }
1283             Case(i_UNPACK_FLOAT):
1284                 {
1285                     StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1286                     /* ASSERT(isFloatLike(con)); */
1287                     xPushTaggedFloat(PK_FLT(&payloadWord(con,0)));
1288                     Continue;
1289                 }
1290             Case(i_VAR_DOUBLE):
1291                 {
1292                     StgDouble d = xTaggedStackDouble(BCO_INSTR_8);
1293                     xPushTaggedDouble(d);
1294                     Continue;
1295                 }
1296             Case(i_CONST_DOUBLE):
1297                 {
1298                     xPushTaggedDouble(bcoConstDouble(bco,BCO_INSTR_8));
1299                     Continue;
1300                 }
1301             Case(i_CONST_DOUBLE_big):
1302                 {
1303                     int n = BCO_INSTR_16;
1304                     xPushTaggedDouble(bcoConstDouble(bco,n));
1305                     Continue;
1306                 }
1307             Case(i_PACK_DOUBLE):
1308                 {
1309                     StgClosure* o;
1310                     SSS; o = (StgClosure*)grabHpNonUpd(Dzh_sizeW); LLL;
1311                     SET_HDR(o,Dzh_con_info,??);
1312                     ASSIGN_DBL(&payloadWord(o,0),xPopTaggedDouble());
1313                     IF_DEBUG(evaluator,
1314                              fprintf(stderr,"\tBuilt ");
1315                              printObj(stgCast(StgClosure*,o));
1316                              );
1317                     xPushPtr(stgCast(StgPtr,o));
1318                     Continue;
1319                 }
1320             Case(i_UNPACK_DOUBLE):
1321                 {
1322                     StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
1323                     /* ASSERT(isDoubleLike(con)); */
1324                     xPushTaggedDouble(PK_DBL(&payloadWord(con,0)));
1325                     Continue;
1326                 }
1327             Case(i_VAR_STABLE):
1328                 {
1329                     StgStablePtr s = xTaggedStackStable(BCO_INSTR_8);
1330                     xPushTaggedStable(s);
1331                     Continue;
1332                 }
1333             Case(i_PACK_STABLE):
1334                 {
1335                     StgClosure* o;
1336                     SSS; o = (StgClosure*)grabHpNonUpd(Stablezh_sizeW); LLL;
1337                     SET_HDR(o,StablePtr_con_info,??);
1338                     payloadWord(o,0) = (W_)xPopTaggedStable();
1339                     IF_DEBUG(evaluator,
1340                              fprintf(stderr,"\tBuilt ");
1341                              SSS;
1342                              printObj(stgCast(StgClosure*,o));
1343                              LLL;
1344                              );
1345                     xPushPtr(stgCast(StgPtr,o));
1346                     Continue;
1347                 }
1348             Case(i_UNPACK_STABLE):
1349                 {
1350                     StgClosure* con = (StgClosure*)xStackPtr(0);
1351                     /* ASSERT(isStableLike(con)); */
1352                     xPushTaggedStable(payloadWord(con,0));
1353                     Continue;
1354                 }
1355             Case(i_PRIMOP1):
1356                 {
1357                     int   i;
1358                     void* p;
1359                     i = BCO_INSTR_8;
1360                     SSS; p = enterBCO_primop1 ( i ); LLL;
1361                     if (p) { obj = p; goto enterLoop; };
1362                     Continue;
1363                 }
1364             Case(i_PRIMOP2):
1365                 {
1366                     int      i, trc, pc_saved;
1367                     void*    p;
1368                     StgBCO*  bco_tmp;
1369                     trc      = 12345678; /* Assume != any StgThreadReturnCode */
1370                     i        = BCO_INSTR_8;
1371                     pc_saved = PC;
1372                     bco_tmp  = bco;
1373                     SSS;
1374                     p        = enterBCO_primop2 ( i, &trc, &bco_tmp, cap,
1375                                                   &hugsBlock );
1376                     LLL;
1377                     bco      = bco_tmp;
1378                     bciPtr   = &(bcoInstr(bco,pc_saved));
1379                     if (p) {
1380                        if (trc == 12345678) {
1381                           /* we want to enter p */
1382                           obj = p; goto enterLoop;
1383                        } else {
1384                           /* trc is the the StgThreadReturnCode for
1385                            * this thread */
1386                          RETURN((StgThreadReturnCode)trc);
1387                        };
1388                     }
1389                     Continue;
1390                 }
1391
1392             /* combined insns, created by peephole opt */
1393             Case(i_SE):
1394                 {
1395                     int x = BCO_INSTR_8;
1396                     int y = BCO_INSTR_8;
1397                     ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
1398                     /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
1399                     if (x == 1) {
1400                        obj = xPopCPtr();
1401                        xSp += y;
1402                        goto enterLoop;
1403                     } else {
1404                        while(--x >= 0) {
1405                            xSetStackWord(x+y,xStackWord(x));
1406                        }
1407                        xSp += y;
1408                        obj = xPopCPtr();
1409                     }
1410                     goto enterLoop;
1411                 }
1412             Case(i_VV):
1413                 {
1414                     StgPtr p;
1415                     p = xStackPtr(BCO_INSTR_8);
1416                     xPushPtr(p);
1417                     p = xStackPtr(BCO_INSTR_8);
1418                     xPushPtr(p);
1419                     Continue;
1420                 }
1421             Case(i_RV):
1422                 {
1423                     StgPtr p;
1424                     xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
1425                     xPushPtr(stgCast(StgPtr,&ret_bco_info));
1426                     p = xStackPtr(BCO_INSTR_8);
1427                     xPushPtr(p);
1428                     Continue;
1429                 }
1430             Case(i_RVE):
1431                 {
1432                     StgPtr retaddr = bcoConstPtr(bco,BCO_INSTR_8);
1433                     StgPtr ptr = xStackPtr(BCO_INSTR_8);
1434
1435                     /* A shortcut.  We're going to push the address of a
1436                        return continuation, and then enter a variable, so
1437                        that when the var is evaluated, we return to the
1438                        continuation.  The shortcut is: if the var is a
1439                        constructor, don't bother to enter it.  Instead,
1440                        push the variable on the stack (since this is what
1441                        the continuation expects) and jump directly to the
1442                        continuation.
1443                      */
1444                     if (get_itbl((StgClosure*)ptr)->type == CONSTR) {
1445                        xPushPtr(ptr);
1446                        obj = (StgClosure*)retaddr;
1447                        IF_DEBUG(evaluator,
1448                                 fprintf(stderr, "object to enter is a constructor -- "
1449                                         "jumping directly to return continuation\n" );
1450                                );
1451                        goto bco_entry;
1452                     }
1453
1454                     /* This is the normal, non-short-cut route */
1455                     xPushPtr(retaddr);
1456                     xPushPtr(stgCast(StgPtr,&ret_bco_info));
1457                     obj = (StgClosure*)ptr;
1458                     goto enterLoop;
1459                 }
1460
1461
1462             Case(i_VAR_DOUBLE_big):
1463             Case(i_CONST_FLOAT_big):
1464             Case(i_VAR_FLOAT_big):
1465             Case(i_CONST_CHAR_big):
1466             Case(i_VAR_CHAR_big):
1467             Case(i_VAR_ADDR_big):
1468             Case(i_VAR_STABLE_big):
1469             Case(i_CONST_INTEGER_big):
1470             Case(i_VAR_INT_big):
1471             Case(i_VAR_WORD_big):
1472             Case(i_RETADDR_big):
1473             Case(i_ALLOC_PAP):
1474 #ifndef XMLAMBDA
1475             Case(i_UNPACK_INJ):
1476             Case(i_UNPACK_ROW):
1477             Case(i_TEST_INJ_CONST):
1478             Case(i_TEST_INJ_big):
1479             Case(i_TEST_INJ):
1480             Case(i_PACK_INJ_CONST):
1481             Case(i_PACK_INJ_big):
1482             Case(i_PACK_INJ):
1483             Case(i_PACK_ROW_big):
1484             Case(i_PACK_ROW):
1485             Case(i_ALLOC_ROW_big):
1486             Case(i_ALLOC_ROW):
1487 #endif
1488                     bciPtr--;
1489                     printf ( "\n\n" );
1490                     disInstr ( bco, PC );
1491                     barf("\nUnrecognised instruction");
1492
1493             EndDispatch
1494
1495             barf("enterBCO: ran off end of loop");
1496             break;
1497         }
1498
1499 #           undef LoopTopLabel
1500 #           undef Case
1501 #           undef Continue
1502 #           undef Dispatch
1503 #           undef EndDispatch
1504
1505             /* ---------------------------------------------------- */
1506             /* End of the bytecode evaluator                        */
1507             /* ---------------------------------------------------- */
1508
1509     case CAF_UNENTERED:
1510         {
1511             StgBlockingQueue* bh;
1512             StgCAF* caf = (StgCAF*)obj;
1513             if (xSp - sizeofW(StgUpdateFrame) < xSpLim) {
1514                 xPushCPtr(obj); /* code to restart with */
1515                 RETURN(StackOverflow);
1516             }
1517             SSS; bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW()); LLL;
1518             SET_INFO(bh,&CAF_BLACKHOLE_info);
1519             bh->blocking_queue = EndTSOQueue;
1520             IF_DEBUG(gccafs,
1521                      fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p"
1522                                     " in evaluator\n",bh,caf));
1523             SET_INFO(caf,&CAF_ENTERED_info);
1524             caf->value = (StgClosure*)bh;
1525
1526             SSS; newCAF_made_by_Hugs(caf); LLL;
1527
1528             xPushUpdateFrame(bh,0);
1529             xSp -= sizeofW(StgUpdateFrame);
1530             obj = caf->body;
1531             goto enterLoop;
1532         }
1533     case CAF_ENTERED:
1534         {
1535             StgCAF* caf = (StgCAF*)obj;
1536             obj = caf->value; /* it's just a fancy indirection */
1537             goto enterLoop;
1538         }
1539     case BLACKHOLE:
1540     case SE_BLACKHOLE:
1541     case CAF_BLACKHOLE:
1542     case SE_CAF_BLACKHOLE:
1543         {
1544             /* Let the scheduler figure out what to do :-) */
1545             cap->rCurrentTSO->what_next = ThreadEnterGHC;
1546             xPushCPtr(obj);
1547             RETURN(ThreadYielding);
1548         }
1549     case AP_UPD:
1550         {
1551             StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
1552             int i = ap->n_args;
1553             if (xSp - (i + sizeofW(StgUpdateFrame)) < xSpLim) {
1554                 xPushCPtr(obj); /* code to restart with */
1555                 RETURN(StackOverflow);
1556             }
1557             /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1558                and insert an indirection immediately  */
1559             xPushUpdateFrame(ap,0);
1560             xSp -= sizeofW(StgUpdateFrame);
1561             while (--i >= 0) {
1562                 xPushWord(payloadWord(ap,i));
1563             }
1564             obj = ap->fun;
1565 #ifdef EAGER_BLACKHOLING
1566 #warn  LAZY_BLACKHOLING is default for StgHugs
1567 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1568             {
1569             /* superfluous - but makes debugging easier */
1570             StgBlackHole* bh = stgCast(StgBlackHole*,ap);
1571             SET_INFO(bh,&BLACKHOLE_info);
1572             bh->blocking_queue = EndTSOQueue;
1573             IF_DEBUG(gccafs,
1574                      fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
1575             /* printObj(bh); */
1576             }
1577 #endif /* EAGER_BLACKHOLING */
1578             goto enterLoop;
1579         }
1580     case PAP:
1581         {
1582             StgPAP* pap = stgCast(StgPAP*,obj);
1583             int i = pap->n_args;  /* ToDo: stack check */
1584             /* ToDo: if PAP is in whnf, we can update any update frames
1585              * on top of stack.
1586              */
1587             while (--i >= 0) {
1588                 xPushWord(payloadWord(pap,i));
1589             }
1590             obj = pap->fun;
1591             goto enterLoop;
1592         }
1593     case IND:
1594         {
1595             obj = stgCast(StgInd*,obj)->indirectee;
1596             goto enterLoop;
1597         }
1598     case IND_OLDGEN:
1599         {
1600             obj = stgCast(StgIndOldGen*,obj)->indirectee;
1601             goto enterLoop;
1602         }
1603     case CONSTR:
1604     case CONSTR_1_0:
1605     case CONSTR_0_1:
1606     case CONSTR_2_0:
1607     case CONSTR_1_1:
1608     case CONSTR_0_2:
1609     case CONSTR_INTLIKE:
1610     case CONSTR_CHARLIKE:
1611     case CONSTR_STATIC:
1612     case CONSTR_NOCAF_STATIC:
1613 #ifdef XMLAMBDA
1614 /* rows are mutarrays and should be treated as constructors. */
1615     case MUT_ARR_PTRS_FROZEN:
1616 #endif
1617         {
1618             while (1) {
1619                 switch (get_itbl(stgCast(StgClosure*,xSp))->type) {
1620                 case CATCH_FRAME:
1621                         SSS; PopCatchFrame(); LLL;
1622                         break;
1623                 case UPDATE_FRAME:
1624                         xPopUpdateFrame(obj);
1625                         break;
1626                 case SEQ_FRAME:
1627                         SSS; PopSeqFrame(); LLL;
1628                         break;
1629                 case STOP_FRAME:
1630                     {
1631                         ASSERT(xSp==(P_)xSu);
1632                         IF_DEBUG(evaluator,
1633                                  SSS;
1634                                  fprintf(stderr, "hit a STOP_FRAME\n");
1635                                  printObj(obj);
1636                                  fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
1637                                  printStack(xSp,cap->rCurrentTSO->stack
1638                                                 + cap->rCurrentTSO->stack_size,xSu);
1639                                  LLL;
1640                                  );
1641                         cap->rCurrentTSO->what_next = ThreadComplete;
1642                         SSS; PopStopFrame(obj); LLL;
1643                         xPushPtr((P_)obj);
1644                         RETURN(ThreadFinished);
1645                     }
1646                 case RET_BCO:
1647                     {
1648                         StgClosure* ret;
1649                         (void)xPopPtr();
1650                         ret = xPopCPtr();
1651                         xPushPtr((P_)obj);
1652                         obj = ret;
1653                         goto bco_entry;
1654                         /* was: goto enterLoop;
1655                            But we know that obj must be a bco now, so jump directly.
1656                         */
1657                     }
1658                 case RET_SMALL:  /* return to GHC */
1659                 case RET_VEC_SMALL:
1660                 case RET_BIG:
1661                 case RET_VEC_BIG:
1662                         cap->rCurrentTSO->what_next = ThreadEnterGHC;
1663                         xPushCPtr(obj);
1664                         RETURN(ThreadYielding);
1665                 default:
1666                         belch("entered CONSTR with invalid continuation on stack");
1667                         IF_DEBUG(evaluator,
1668                                  SSS;
1669                                  printObj(stgCast(StgClosure*,xSp));
1670                                  LLL;
1671                                  );
1672                         barf("bailing out");
1673                 }
1674             }
1675         }
1676     default:
1677         {
1678             //SSS;
1679             //fprintf(stderr, "enterCountI = %d\n", enterCountI);
1680             //fprintf(stderr, "entering unknown closure -- yielding to sched\n");
1681             //printObj(obj);
1682             //LLL;
1683             cap->rCurrentTSO->what_next = ThreadEnterGHC;
1684             xPushCPtr(obj); /* code to restart with */
1685             RETURN(ThreadYielding);
1686         }
1687     }
1688     barf("Ran off the end of enter - yoiks");
1689     ASSERT(0);
1690 }
1691
1692 #undef RETURN
1693 #undef BCO_INSTR_8
1694 #undef BCO_INSTR_16
1695 #undef SSS
1696 #undef LLL
1697 #undef PC
1698 #undef xPushPtr
1699 #undef xPopPtr
1700 #undef xPushCPtr
1701 #undef xPopCPtr
1702 #undef xPopWord
1703 #undef xStackPtr
1704 #undef xStackWord
1705 #undef xSetStackWord
1706 #undef xPushTag
1707 #undef xPopTag
1708 #undef xPushTaggedInt
1709 #undef xPopTaggedInt
1710 #undef xTaggedStackInt
1711 #undef xPushTaggedWord
1712 #undef xPopTaggedWord
1713 #undef xTaggedStackWord
1714 #undef xPushTaggedAddr
1715 #undef xTaggedStackAddr
1716 #undef xPopTaggedAddr
1717 #undef xPushTaggedStable
1718 #undef xTaggedStackStable
1719 #undef xPopTaggedStable
1720 #undef xPushTaggedChar
1721 #undef xTaggedStackChar
1722 #undef xPopTaggedChar
1723 #undef xPushTaggedFloat
1724 #undef xTaggedStackFloat
1725 #undef xPopTaggedFloat
1726 #undef xPushTaggedDouble
1727 #undef xTaggedStackDouble
1728 #undef xPopTaggedDouble
1729 #undef xPopUpdateFrame
1730 #undef xPushUpdateFrame
1731
1732
1733 /* --------------------------------------------------------------------------
1734  * Supporting routines for primops
1735  * ------------------------------------------------------------------------*/
1736
1737 static inline void            PushTag            ( StackTag    t )
1738    { *(--gSp) = t; }
1739        inline void            PushPtr            ( StgPtr      x )
1740    { *(--stgCast(StgPtr*,gSp))  = x; }
1741 static inline void            PushCPtr           ( StgClosure* x )
1742    { *(--stgCast(StgClosure**,gSp)) = x; }
1743 static inline void            PushInt            ( StgInt      x )
1744    { *(--stgCast(StgInt*,gSp))  = x; }
1745 static inline void            PushWord           ( StgWord     x )
1746    { *(--stgCast(StgWord*,gSp)) = x; }
1747
1748
1749 static inline void            checkTag           ( StackTag t1, StackTag t2 )
1750    { ASSERT(t1 == t2);}
1751 static inline void            PopTag             ( StackTag t )
1752    { checkTag(t,*(gSp++));    }
1753        inline StgPtr          PopPtr             ( void )
1754    { return *stgCast(StgPtr*,gSp)++; }
1755 static inline StgClosure*     PopCPtr            ( void )
1756    { return *stgCast(StgClosure**,gSp)++; }
1757 static inline StgInt          PopInt             ( void )
1758    { return *stgCast(StgInt*,gSp)++;  }
1759 static inline StgWord         PopWord            ( void )
1760    { return *stgCast(StgWord*,gSp)++; }
1761
1762 static inline StgPtr          stackPtr           ( StgStackOffset i )
1763    { return *stgCast(StgPtr*, gSp+i); }
1764 static inline StgInt          stackInt           ( StgStackOffset i )
1765    { return *stgCast(StgInt*, gSp+i); }
1766 static inline StgWord         stackWord          ( StgStackOffset i )
1767    { return *stgCast(StgWord*,gSp+i); }
1768
1769 static inline void            setStackWord       ( StgStackOffset i, StgWord w )
1770    { gSp[i] = w; }
1771
1772 #ifdef XMLAMBDA
1773 static inline void            setStackPtr        ( StgStackOffset i, StgPtr p )
1774    { *(stgCast(StgPtr*, gSp+i)) = p; }
1775 #endif
1776
1777 static inline void            PushTaggedRealWorld( void            )
1778    { PushTag(REALWORLD_TAG);  }
1779        inline void            PushTaggedInt      ( StgInt        x )
1780    { gSp -= sizeofW(StgInt);        *gSp = x;          PushTag(INT_TAG);    }
1781        inline void            PushTaggedWord     ( StgWord       x )
1782    { gSp -= sizeofW(StgWord);       *gSp = x;          PushTag(WORD_TAG);   }
1783        inline void            PushTaggedAddr     ( StgAddr       x )
1784    { gSp -= sizeofW(StgAddr);       *gSp = (W_)x;      PushTag(ADDR_TAG);   }
1785        inline void            PushTaggedChar     ( StgChar       x )
1786    { gSp -= sizeofW(StgChar);         *gSp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
1787        inline void            PushTaggedFloat    ( StgFloat      x )
1788    { gSp -= sizeofW(StgFloat);      ASSIGN_FLT(gSp,x); PushTag(FLOAT_TAG);  }
1789        inline void            PushTaggedDouble   ( StgDouble     x )
1790    { gSp -= sizeofW(StgDouble);     ASSIGN_DBL(gSp,x); PushTag(DOUBLE_TAG); }
1791        inline void            PushTaggedStablePtr   ( StgStablePtr  x )
1792    { gSp -= sizeofW(StgStablePtr);  *gSp = (W_)x;      PushTag(STABLE_TAG); }
1793 static inline void            PushTaggedBool     ( int           x )
1794    { PushTaggedInt(x); }
1795
1796
1797
1798 static inline void            PopTaggedRealWorld ( void )
1799    { PopTag(REALWORLD_TAG); }
1800        inline StgInt          PopTaggedInt       ( void )
1801    { StgInt    r; PopTag(INT_TAG);     r = *stgCast(StgInt*,  gSp);
1802      gSp += sizeofW(StgInt);        return r;}
1803        inline StgWord         PopTaggedWord      ( void )
1804    { StgWord   r; PopTag(WORD_TAG);    r = *stgCast(StgWord*, gSp);
1805      gSp += sizeofW(StgWord);       return r;}
1806        inline StgAddr         PopTaggedAddr      ( void )
1807    { StgAddr   r; PopTag(ADDR_TAG);    r = *stgCast(StgAddr*, gSp);
1808      gSp += sizeofW(StgAddr);       return r;}
1809        inline StgChar         PopTaggedChar      ( void )
1810    { StgChar   r; PopTag(CHAR_TAG);    r = stgCast(StgChar, *gSp);
1811      gSp += sizeofW(StgChar);       return r;}
1812        inline StgFloat        PopTaggedFloat     ( void )
1813    { StgFloat  r; PopTag(FLOAT_TAG);   r = PK_FLT(gSp);
1814      gSp += sizeofW(StgFloat);      return r;}
1815        inline StgDouble       PopTaggedDouble    ( void )
1816    { StgDouble r; PopTag(DOUBLE_TAG);  r = PK_DBL(gSp);
1817      gSp += sizeofW(StgDouble);     return r;}
1818        inline StgStablePtr    PopTaggedStablePtr    ( void )
1819    { StgStablePtr r; PopTag(STABLE_TAG);  r = *stgCast(StgStablePtr*, gSp);
1820      gSp += sizeofW(StgStablePtr);  return r;}
1821
1822
1823
1824 static inline StgInt          taggedStackInt     ( StgStackOffset i )
1825    { checkTag(INT_TAG,gSp[i]);     return *stgCast(StgInt*,         gSp+1+i); }
1826 static inline StgWord         taggedStackWord    ( StgStackOffset i )
1827    { checkTag(WORD_TAG,gSp[i]);    return *stgCast(StgWord*,        gSp+1+i); }
1828 static inline StgAddr         taggedStackAddr    ( StgStackOffset i )
1829    { checkTag(ADDR_TAG,gSp[i]);    return *stgCast(StgAddr*,        gSp+1+i); }
1830 static inline StgChar         taggedStackChar    ( StgStackOffset i )
1831    { checkTag(CHAR_TAG,gSp[i]);    return stgCast(StgChar, *(gSp+1+i))   ; }
1832 static inline StgFloat        taggedStackFloat   ( StgStackOffset i )
1833    { checkTag(FLOAT_TAG,gSp[i]);   return PK_FLT(gSp+1+i); }
1834 static inline StgDouble       taggedStackDouble  ( StgStackOffset i )
1835    { checkTag(DOUBLE_TAG,gSp[i]);  return PK_DBL(gSp+1+i); }
1836 static inline StgStablePtr    taggedStackStable  ( StgStackOffset i )
1837    { checkTag(STABLE_TAG,gSp[i]);  return *stgCast(StgStablePtr*,   gSp+1+i); }
1838
1839
1840 /* --------------------------------------------------------------------------
1841  * Heap allocation
1842  *
1843  * Should we allocate from a nursery or use the
1844  * doYouWantToGC/allocate interface?  We'd already implemented a
1845  * nursery-style scheme when the doYouWantToGC/allocate interface
1846  * was implemented.
1847  * One reason to prefer the doYouWantToGC/allocate interface is to
1848  * support operations which allocate an unknown amount in the heap
1849  * (array ops, gmp ops, etc)
1850  * ------------------------------------------------------------------------*/
1851
1852 static inline StgPtr grabHpUpd( nat size )
1853 {
1854     ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
1855     return allocate(size);
1856 }
1857
1858 static inline StgPtr grabHpNonUpd( nat size )
1859 {
1860     ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1861     return allocate(size);
1862 }
1863
1864 /* --------------------------------------------------------------------------
1865  * Manipulate "update frame" list:
1866  * o Update frames           (based on stg_do_update and friends in Updates.hc)
1867  * o Error handling/catching (based on catchzh_fast and friends in Prims.hc)
1868  * o Seq frames              (based on seq_frame_entry in Prims.hc)
1869  * o Stop frames
1870  * ------------------------------------------------------------------------*/
1871
1872 static inline void PopUpdateFrame ( StgClosure* obj )
1873 {
1874     /* NB: doesn't assume that gSp == gSu */
1875     IF_DEBUG(evaluator,
1876              fprintf(stderr,  "Updating ");
1877              printPtr(stgCast(StgPtr,gSu->updatee));
1878              fprintf(stderr,  " with ");
1879              printObj(obj);
1880              fprintf(stderr,"gSp = %p\tgSu = %p\n\n", gSp, gSu);
1881              );
1882 #ifdef EAGER_BLACKHOLING
1883 #warn  LAZY_BLACKHOLING is default for StgHugs
1884 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1885     ASSERT(get_itbl(gSu->updatee)->type == BLACKHOLE
1886            || get_itbl(gSu->updatee)->type == SE_BLACKHOLE
1887            || get_itbl(gSu->updatee)->type == CAF_BLACKHOLE
1888            || get_itbl(gSu->updatee)->type == SE_CAF_BLACKHOLE
1889            );
1890 #endif /* EAGER_BLACKHOLING */
1891     UPD_IND(gSu->updatee,obj);
1892     gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1893     gSu = gSu->link;
1894 }
1895
1896 static inline void PopStopFrame ( StgClosure* obj )
1897 {
1898     /* Move gSu just off the end of the stack, we're about to gSpam the
1899      * STOP_FRAME with the return value.
1900      */
1901     gSu = stgCast(StgUpdateFrame*,gSp+1);
1902     *stgCast(StgClosure**,gSp) = obj;
1903 }
1904
1905 static inline void PushCatchFrame ( StgClosure* handler )
1906 {
1907     StgCatchFrame* fp;
1908     /* ToDo: stack check! */
1909     gSp -= sizeofW(StgCatchFrame);
1910     fp = stgCast(StgCatchFrame*,gSp);
1911     SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS);
1912     fp->handler         = handler;
1913     fp->link            = gSu;
1914     gSu = stgCast(StgUpdateFrame*,fp);
1915 }
1916
1917 static inline void PopCatchFrame ( void )
1918 {
1919     /* NB: doesn't assume that gSp == gSu */
1920     /* fprintf(stderr,"Popping catch frame\n"); */
1921     gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgCatchFrame);
1922     gSu = stgCast(StgCatchFrame*,gSu)->link;
1923 }
1924
1925 static inline void PushSeqFrame ( void )
1926 {
1927     StgSeqFrame* fp;
1928     /* ToDo: stack check! */
1929     gSp -= sizeofW(StgSeqFrame);
1930     fp = stgCast(StgSeqFrame*,gSp);
1931     SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS);
1932     fp->link = gSu;
1933     gSu = stgCast(StgUpdateFrame*,fp);
1934 }
1935
1936 static inline void PopSeqFrame ( void )
1937 {
1938     /* NB: doesn't assume that gSp == gSu */
1939     gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgSeqFrame);
1940     gSu = stgCast(StgSeqFrame*,gSu)->link;
1941 }
1942
1943 static inline StgClosure* raiseAnError ( StgClosure* exception )
1944 {
1945     /* This closure represents the expression 'primRaise E' where E
1946      * is the exception raised (:: Exception).
1947      * It is used to overwrite all the
1948      * thunks which are currently under evaluation.
1949      */
1950     HaskellObj primRaiseClosure
1951        = getHugs_BCO_cptr_for("primRaise");
1952     HaskellObj reraiseClosure
1953        = rts_apply ( primRaiseClosure, exception );
1954
1955     while (1) {
1956         switch (get_itbl(gSu)->type) {
1957         case UPDATE_FRAME:
1958                 UPD_IND(gSu->updatee,reraiseClosure);
1959                 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1960                 gSu = gSu->link;
1961                 break;
1962         case SEQ_FRAME:
1963                 PopSeqFrame();
1964                 break;
1965         case CATCH_FRAME:  /* found it! */
1966             {
1967                 StgCatchFrame* fp = stgCast(StgCatchFrame*,gSu);
1968                 StgClosure *handler = fp->handler;
1969                 gSu = fp->link;
1970                 gSp += sizeofW(StgCatchFrame); /* Pop */
1971                 PushCPtr(exception);
1972                 return handler;
1973             }
1974         case STOP_FRAME:
1975                 barf("raiseError: uncaught exception: STOP_FRAME");
1976         default:
1977                 barf("raiseError: weird activation record");
1978         }
1979     }
1980 }
1981
1982
1983 static StgClosure* makeErrorCall ( const char* msg )
1984 {
1985    /* Note!  the msg string should be allocated in a
1986       place which will not get freed -- preferably
1987       read-only data of the program.  That's because
1988       the thunk we build here may linger indefinitely.
1989       (thinks: probably not so, but anyway ...)
1990    */
1991    HaskellObj error
1992       = getHugs_BCO_cptr_for("error");
1993    HaskellObj unpack
1994       = getHugs_BCO_cptr_for("hugsprimUnpackString");
1995    HaskellObj thunk
1996       = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) );
1997    thunk
1998       = rts_apply ( error, thunk );
1999    return
2000       (StgClosure*) thunk;
2001 }
2002
2003 #define raiseIndex(where) makeErrorCall("Array index out of range in " where)
2004 #define raiseDiv0(where)  makeErrorCall("Division by zero in " where)
2005
2006 /* --------------------------------------------------------------------------
2007  * Evaluator
2008  * ------------------------------------------------------------------------*/
2009
2010 #define OP_CC_B(e)            \
2011 {                             \
2012     unsigned char x = PopTaggedChar(); \
2013     unsigned char y = PopTaggedChar(); \
2014     PushTaggedBool(e);        \
2015 }
2016
2017 #define OP_C_I(e)             \
2018 {                             \
2019     unsigned char x = PopTaggedChar(); \
2020     PushTaggedInt(e);         \
2021 }
2022
2023 #define OP__I(e)             \
2024 {                            \
2025     PushTaggedInt(e);        \
2026 }
2027
2028 #define OP_IW_I(e)           \
2029 {                            \
2030     StgInt  x = PopTaggedInt();  \
2031     StgWord y = PopTaggedWord();  \
2032     PushTaggedInt(e);        \
2033 }
2034
2035 #define OP_II_I(e)           \
2036 {                            \
2037     StgInt x = PopTaggedInt();  \
2038     StgInt y = PopTaggedInt();  \
2039     PushTaggedInt(e);        \
2040 }
2041
2042 #define OP_II_B(e)           \
2043 {                            \
2044     StgInt x = PopTaggedInt();  \
2045     StgInt y = PopTaggedInt();  \
2046     PushTaggedBool(e);       \
2047 }
2048
2049 #define OP__A(e)             \
2050 {                            \
2051     PushTaggedAddr(e);       \
2052 }
2053
2054 #define OP_I_A(e)            \
2055 {                            \
2056     StgInt x = PopTaggedInt();  \
2057     PushTaggedAddr(e);       \
2058 }
2059
2060 #define OP_I_I(e)            \
2061 {                            \
2062     StgInt x = PopTaggedInt();  \
2063     PushTaggedInt(e);        \
2064 }
2065
2066 #define OP__C(e)             \
2067 {                            \
2068     PushTaggedChar(e);       \
2069 }
2070
2071 #define OP_I_C(e)            \
2072 {                            \
2073     StgInt x = PopTaggedInt();  \
2074     PushTaggedChar(e);       \
2075 }
2076
2077 #define OP__W(e)              \
2078 {                             \
2079     PushTaggedWord(e);        \
2080 }
2081
2082 #define OP_I_W(e)            \
2083 {                            \
2084     StgInt x = PopTaggedInt();  \
2085     PushTaggedWord(e);       \
2086 }
2087
2088 #define OP_I_s(e)            \
2089 {                            \
2090     StgInt x = PopTaggedInt();  \
2091     PushTaggedStablePtr(e);  \
2092 }
2093
2094 #define OP__F(e)             \
2095 {                            \
2096     PushTaggedFloat(e);      \
2097 }
2098
2099 #define OP_I_F(e)            \
2100 {                            \
2101     StgInt x = PopTaggedInt();  \
2102     PushTaggedFloat(e);      \
2103 }
2104
2105 #define OP__D(e)             \
2106 {                            \
2107     PushTaggedDouble(e);     \
2108 }
2109
2110 #define OP_I_D(e)            \
2111 {                            \
2112     StgInt x = PopTaggedInt();  \
2113     PushTaggedDouble(e);     \
2114 }
2115
2116 #define OP_WW_B(e)            \
2117 {                             \
2118     StgWord x = PopTaggedWord(); \
2119     StgWord y = PopTaggedWord(); \
2120     PushTaggedBool(e);        \
2121 }
2122
2123 #define OP_WW_W(e)            \
2124 {                             \
2125     StgWord x = PopTaggedWord(); \
2126     StgWord y = PopTaggedWord(); \
2127     PushTaggedWord(e);        \
2128 }
2129
2130 #define OP_W_I(e)             \
2131 {                             \
2132     StgWord x = PopTaggedWord(); \
2133     PushTaggedInt(e);         \
2134 }
2135
2136 #define OP_s_I(e)             \
2137 {                             \
2138     StgStablePtr x = PopTaggedStablePtr(); \
2139     PushTaggedInt(e);         \
2140 }
2141
2142 #define OP_W_W(e)             \
2143 {                             \
2144     StgWord x = PopTaggedWord(); \
2145     PushTaggedWord(e);        \
2146 }
2147
2148 #define OP_AA_B(e)            \
2149 {                             \
2150     StgAddr x = PopTaggedAddr(); \
2151     StgAddr y = PopTaggedAddr(); \
2152     PushTaggedBool(e);        \
2153 }
2154 #define OP_A_I(e)             \
2155 {                             \
2156     StgAddr x = PopTaggedAddr(); \
2157     PushTaggedInt(e);         \
2158 }
2159 #define OP_AI_C(s)            \
2160 {                             \
2161     StgAddr x = PopTaggedAddr(); \
2162     int  y = PopTaggedInt();  \
2163     StgChar r;                \
2164     s;                        \
2165     PushTaggedChar(r);        \
2166 }
2167 #define OP_AI_I(s)            \
2168 {                             \
2169     StgAddr x = PopTaggedAddr(); \
2170     int  y = PopTaggedInt();  \
2171     StgInt r;                 \
2172     s;                        \
2173     PushTaggedInt(r);         \
2174 }
2175 #define OP_AI_A(s)            \
2176 {                             \
2177     StgAddr x = PopTaggedAddr(); \
2178     int  y = PopTaggedInt();  \
2179     StgAddr r;                \
2180     s;                        \
2181     PushTaggedAddr(s);        \
2182 }
2183 #define OP_AI_F(s)            \
2184 {                             \
2185     StgAddr x = PopTaggedAddr(); \
2186     int  y = PopTaggedInt();  \
2187     StgFloat r;               \
2188     s;                        \
2189     PushTaggedFloat(r);       \
2190 }
2191 #define OP_AI_D(s)            \
2192 {                             \
2193     StgAddr x = PopTaggedAddr(); \
2194     int  y = PopTaggedInt();  \
2195     StgDouble r;              \
2196     s;                        \
2197     PushTaggedDouble(r);      \
2198 }
2199 #define OP_AI_s(s)            \
2200 {                             \
2201     StgAddr x = PopTaggedAddr(); \
2202     int  y = PopTaggedInt();  \
2203     StgStablePtr r;           \
2204     s;                        \
2205     PushTaggedStablePtr(r);   \
2206 }
2207 #define OP_AIC_(s)            \
2208 {                             \
2209     StgAddr x = PopTaggedAddr(); \
2210     int     y = PopTaggedInt();  \
2211     StgChar z = PopTaggedChar(); \
2212     s;                        \
2213 }
2214 #define OP_AII_(s)            \
2215 {                             \
2216     StgAddr x = PopTaggedAddr(); \
2217     int     y = PopTaggedInt();  \
2218     StgInt  z = PopTaggedInt(); \
2219     s;                        \
2220 }
2221 #define OP_AIA_(s)            \
2222 {                             \
2223     StgAddr x = PopTaggedAddr(); \
2224     int     y = PopTaggedInt();  \
2225     StgAddr z = PopTaggedAddr(); \
2226     s;                        \
2227 }
2228 #define OP_AIF_(s)            \
2229 {                             \
2230     StgAddr x = PopTaggedAddr(); \
2231     int     y = PopTaggedInt();  \
2232     StgFloat z = PopTaggedFloat(); \
2233     s;                        \
2234 }
2235 #define OP_AID_(s)            \
2236 {                             \
2237     StgAddr x = PopTaggedAddr(); \
2238     int     y = PopTaggedInt();  \
2239     StgDouble z = PopTaggedDouble(); \
2240     s;                        \
2241 }
2242 #define OP_AIs_(s)            \
2243 {                             \
2244     StgAddr x = PopTaggedAddr(); \
2245     int     y = PopTaggedInt();  \
2246     StgStablePtr z = PopTaggedStablePtr(); \
2247     s;                        \
2248 }
2249
2250
2251 #define OP_FF_B(e)              \
2252 {                               \
2253     StgFloat x = PopTaggedFloat(); \
2254     StgFloat y = PopTaggedFloat(); \
2255     PushTaggedBool(e);          \
2256 }
2257
2258 #define OP_FF_F(e)              \
2259 {                               \
2260     StgFloat x = PopTaggedFloat(); \
2261     StgFloat y = PopTaggedFloat(); \
2262     PushTaggedFloat(e);         \
2263 }
2264
2265 #define OP_F_F(e)               \
2266 {                               \
2267     StgFloat x = PopTaggedFloat(); \
2268     PushTaggedFloat(e);         \
2269 }
2270
2271 #define OP_F_B(e)               \
2272 {                               \
2273     StgFloat x = PopTaggedFloat(); \
2274     PushTaggedBool(e);         \
2275 }
2276
2277 #define OP_F_I(e)               \
2278 {                               \
2279     StgFloat x = PopTaggedFloat(); \
2280     PushTaggedInt(e);           \
2281 }
2282
2283 #define OP_F_D(e)               \
2284 {                               \
2285     StgFloat x = PopTaggedFloat(); \
2286     PushTaggedDouble(e);        \
2287 }
2288
2289 #define OP_DD_B(e)                \
2290 {                                 \
2291     StgDouble x = PopTaggedDouble(); \
2292     StgDouble y = PopTaggedDouble(); \
2293     PushTaggedBool(e);            \
2294 }
2295
2296 #define OP_DD_D(e)                \
2297 {                                 \
2298     StgDouble x = PopTaggedDouble(); \
2299     StgDouble y = PopTaggedDouble(); \
2300     PushTaggedDouble(e);          \
2301 }
2302
2303 #define OP_D_B(e)                 \
2304 {                                 \
2305     StgDouble x = PopTaggedDouble(); \
2306     PushTaggedBool(e);          \
2307 }
2308
2309 #define OP_D_D(e)                 \
2310 {                                 \
2311     StgDouble x = PopTaggedDouble(); \
2312     PushTaggedDouble(e);          \
2313 }
2314
2315 #define OP_D_I(e)                 \
2316 {                                 \
2317     StgDouble x = PopTaggedDouble(); \
2318     PushTaggedInt(e);             \
2319 }
2320
2321 #define OP_D_F(e)                 \
2322 {                                 \
2323     StgDouble x = PopTaggedDouble(); \
2324     PushTaggedFloat(e);           \
2325 }
2326
2327
2328 StgPtr CreateByteArrayToHoldInteger ( int nbytes )
2329 {
2330    StgWord words     = (nbytes+sizeof(W_)-1)/sizeof(W_);
2331    StgWord size      = sizeofW(StgArrWords) + words;
2332    StgArrWords* arr  = (StgArrWords*)allocate(size);
2333    SET_HDR(arr,&ARR_WORDS_info,CCCS);
2334    arr->words = words;
2335    ASSERT((W_)nbytes <= arr->words * sizeof(W_));
2336 #ifdef DEBUG
2337    {StgWord i;
2338     for (i = 0; i < words; ++i) {
2339     arr->payload[i] = 0xdeadbeef;
2340    }}
2341    { B* b = (B*) &(arr->payload[0]);
2342      b->used = b->sign = 0;
2343    }
2344 #endif
2345    return (StgPtr)arr;
2346 }
2347
2348 B* IntegerInsideByteArray ( StgPtr arr0 )
2349 {
2350    B* b;
2351    StgArrWords* arr = (StgArrWords*)arr0;
2352    ASSERT(GET_INFO(arr) == &ARR_WORDS_info);
2353    b = (B*) &(arr->payload[0]);
2354    return b;
2355 }
2356
2357 void SloppifyIntegerEnd ( StgPtr arr0 )
2358 {
2359    StgArrWords* arr = (StgArrWords*)arr0;
2360    B* b = (B*) & (arr->payload[0]);
2361    I_ nwunused = arr->words - sizeofW(B) - (b->used+sizeof(W_)-1)/sizeof(W_);
2362    if (nwunused >= ((I_)sizeofW(StgArrWords))) {
2363       StgArrWords* slop;
2364       b->size -= nwunused * sizeof(W_);
2365       if (b->size < b->used) b->size = b->used;
2366       do_renormalise(b);
2367       ASSERT(is_sane(b));
2368       arr->words -= nwunused;
2369       slop = (StgArrWords*)&(arr->payload[arr->words]);
2370       SET_HDR(slop,&ARR_WORDS_info,CCCS);
2371       slop->words = nwunused - sizeofW(StgArrWords);
2372       ASSERT( &(slop->payload[slop->words]) ==
2373               &(arr->payload[arr->words + nwunused]) );
2374    }
2375 }
2376
2377 #define OP_Z_Z(op)                                   \
2378 {                                                    \
2379    B* x     = IntegerInsideByteArray(PopPtr());      \
2380    int n    = mycat2(size_,op)(x);                   \
2381    StgPtr p = CreateByteArrayToHoldInteger(n);       \
2382    mycat2(do_,op)(x,n,IntegerInsideByteArray(p));    \
2383    SloppifyIntegerEnd(p);                            \
2384    PushPtr(p);                                       \
2385 }
2386 #define OP_ZZ_Z(op)                                  \
2387 {                                                    \
2388    B* x     = IntegerInsideByteArray(PopPtr());      \
2389    B* y     = IntegerInsideByteArray(PopPtr());      \
2390    int n    = mycat2(size_,op)(x,y);                 \
2391    StgPtr p = CreateByteArrayToHoldInteger(n);       \
2392    mycat2(do_,op)(x,y,n,IntegerInsideByteArray(p));  \
2393    SloppifyIntegerEnd(p);                            \
2394    PushPtr(p);                                       \
2395 }
2396
2397
2398
2399
2400 #define HEADER_mI(ty,where)          \
2401     StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \
2402     nat i = PopTaggedInt();   \
2403     if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) {        \
2404         return (raiseIndex(where));  \
2405     }
2406 #define OP_mI_ty(ty,where,s)        \
2407 {                                   \
2408     HEADER_mI(mycat2(Stg,ty),where) \
2409     { mycat2(Stg,ty) r;             \
2410       s;                            \
2411       mycat2(PushTagged,ty)(r);     \
2412     }                               \
2413 }
2414 #define OP_mIty_(ty,where,s)        \
2415 {                                   \
2416     HEADER_mI(mycat2(Stg,ty),where) \
2417     {                               \
2418       mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
2419       s;                            \
2420     }                               \
2421 }
2422
2423
2424 __attribute__ ((unused))
2425 static void myStackCheck ( Capability* cap )
2426 {
2427    /* fprintf(stderr, "myStackCheck\n"); */
2428    if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) {
2429       fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" );
2430       barf("aborting");
2431       ASSERT(0);
2432    }
2433    while (1) {
2434       if (!( (P_)gSu >= (P_)cap->rCurrentTSO->stack
2435               &&
2436               (P_)gSu <= (P_)(cap->rCurrentTSO->stack
2437                               + cap->rCurrentTSO->stack_size))) {
2438          fprintf ( stderr, "myStackCheck: gSu out of stack\n" );
2439          barf("aborting");
2440          ASSERT(0);
2441       }
2442       switch (get_itbl(stgCast(StgClosure*,gSu))->type) {
2443       case CATCH_FRAME:
2444          gSu = (StgUpdateFrame*) ((StgCatchFrame*)(gSu))->link;
2445          break;
2446       case UPDATE_FRAME:
2447          gSu = (StgUpdateFrame*) ((StgUpdateFrame*)(gSu))->link;
2448          break;
2449       case SEQ_FRAME:
2450          gSu = (StgUpdateFrame*) ((StgSeqFrame*)(gSu))->link;
2451          break;
2452       case STOP_FRAME:
2453          goto postloop;
2454       default:
2455          fprintf(stderr, "myStackCheck: invalid activation record\n");
2456          barf("aborting");
2457          ASSERT(0);
2458       }
2459    }
2460    postloop:
2461 }
2462
2463
2464 /* --------------------------------------------------------------------------
2465  * Primop stuff for bytecode interpreter
2466  * ------------------------------------------------------------------------*/
2467
2468 /* Returns & of the next thing to enter (if throwing an exception),
2469    or NULL in the normal case.
2470 */
2471 static void* enterBCO_primop1 ( int primop1code )
2472 {
2473     if (combined)
2474        barf("enterBCO_primop1 in combined mode");
2475
2476     switch (primop1code) {
2477         case i_pushseqframe:
2478             {
2479                StgClosure* c = PopCPtr();
2480                PushSeqFrame();
2481                PushCPtr(c);
2482                break;
2483             }
2484         case i_pushcatchframe:
2485             {
2486                StgClosure* e = PopCPtr();
2487                StgClosure* h = PopCPtr();
2488                PushCatchFrame(h);
2489                PushCPtr(e);
2490                break;
2491             }
2492
2493         case i_gtChar:          OP_CC_B(x>y);        break;
2494         case i_geChar:          OP_CC_B(x>=y);       break;
2495         case i_eqChar:          OP_CC_B(x==y);       break;
2496         case i_neChar:          OP_CC_B(x!=y);       break;
2497         case i_ltChar:          OP_CC_B(x<y);        break;
2498         case i_leChar:          OP_CC_B(x<=y);       break;
2499         case i_charToInt:       OP_C_I(x);           break;
2500         case i_intToChar:       OP_I_C(x);           break;
2501
2502         case i_gtInt:           OP_II_B(x>y);        break;
2503         case i_geInt:           OP_II_B(x>=y);       break;
2504         case i_eqInt:           OP_II_B(x==y);       break;
2505         case i_neInt:           OP_II_B(x!=y);       break;
2506         case i_ltInt:           OP_II_B(x<y);        break;
2507         case i_leInt:           OP_II_B(x<=y);       break;
2508         case i_minInt:          OP__I(INT_MIN);      break;
2509         case i_maxInt:          OP__I(INT_MAX);      break;
2510         case i_plusInt:         OP_II_I(x+y);        break;
2511         case i_minusInt:        OP_II_I(x-y);        break;
2512         case i_timesInt:        OP_II_I(x*y);        break;
2513         case i_quotInt:
2514             {
2515                 int x = PopTaggedInt();
2516                 int y = PopTaggedInt();
2517                 if (y == 0) {
2518                     return (raiseDiv0("quotInt"));
2519                 }
2520                 /* ToDo: protect against minInt / -1 errors
2521                  * (repeat for all other division primops) */
2522                 PushTaggedInt(x/y);
2523             }
2524             break;
2525         case i_remInt:
2526             {
2527                 int x = PopTaggedInt();
2528                 int y = PopTaggedInt();
2529                 if (y == 0) {
2530                     return (raiseDiv0("remInt"));
2531                 }
2532                 PushTaggedInt(x%y);
2533             }
2534             break;
2535         case i_quotRemInt:
2536             {
2537                 StgInt x = PopTaggedInt();
2538                 StgInt y = PopTaggedInt();
2539                 if (y == 0) {
2540                     return (raiseDiv0("quotRemInt"));
2541                 }
2542                 PushTaggedInt(x%y); /* last result  */
2543                 PushTaggedInt(x/y); /* first result */
2544             }
2545             break;
2546         case i_negateInt:       OP_I_I(-x);          break;
2547
2548         case i_andInt:          OP_II_I(x&y);        break;
2549         case i_orInt:           OP_II_I(x|y);        break;
2550         case i_xorInt:          OP_II_I(x^y);        break;
2551         case i_notInt:          OP_I_I(~x);          break;
2552         case i_shiftLInt:       OP_II_I(x<<y);       break;
2553         case i_shiftRAInt:      OP_II_I(x>>y);       break; /* ToDo */
2554         case i_shiftRLInt:      OP_II_I(x>>y);       break; /* ToDo */
2555
2556         case i_gtWord:          OP_WW_B(x>y);        break;
2557         case i_geWord:          OP_WW_B(x>=y);       break;
2558         case i_eqWord:          OP_WW_B(x==y);       break;
2559         case i_neWord:          OP_WW_B(x!=y);       break;
2560         case i_ltWord:          OP_WW_B(x<y);        break;
2561         case i_leWord:          OP_WW_B(x<=y);       break;
2562         case i_minWord:         OP__W(0);            break;
2563         case i_maxWord:         OP__W(UINT_MAX);     break;
2564         case i_plusWord:        OP_WW_W(x+y);        break;
2565         case i_minusWord:       OP_WW_W(x-y);        break;
2566         case i_timesWord:       OP_WW_W(x*y);        break;
2567         case i_quotWord:
2568             {
2569                 StgWord x = PopTaggedWord();
2570                 StgWord y = PopTaggedWord();
2571                 if (y == 0) {
2572                     return (raiseDiv0("quotWord"));
2573                 }
2574                 PushTaggedWord(x/y);
2575             }
2576             break;
2577         case i_remWord:
2578             {
2579                 StgWord x = PopTaggedWord();
2580                 StgWord y = PopTaggedWord();
2581                 if (y == 0) {
2582                     return (raiseDiv0("remWord"));
2583                 }
2584                 PushTaggedWord(x%y);
2585             }
2586             break;
2587         case i_quotRemWord:
2588             {
2589                 StgWord x = PopTaggedWord();
2590                 StgWord y = PopTaggedWord();
2591                 if (y == 0) {
2592                     return (raiseDiv0("quotRemWord"));
2593                 }
2594                 PushTaggedWord(x%y); /* last result  */
2595                 PushTaggedWord(x/y); /* first result */
2596             }
2597             break;
2598         case i_negateWord:      OP_W_W(-x);         break;
2599         case i_andWord:         OP_WW_W(x&y);        break;
2600         case i_orWord:          OP_WW_W(x|y);        break;
2601         case i_xorWord:         OP_WW_W(x^y);        break;
2602         case i_notWord:         OP_W_W(~x);          break;
2603         case i_shiftLWord:      OP_WW_W(x<<y);       break;
2604         case i_shiftRAWord:     OP_WW_W(x>>y);       break; /* ToDo */
2605         case i_shiftRLWord:     OP_WW_W(x>>y);       break; /* ToDo */
2606         case i_intToWord:       OP_I_W(x);           break;
2607         case i_wordToInt:       OP_W_I(x);           break;
2608
2609         case i_gtAddr:          OP_AA_B(x>y);        break;
2610         case i_geAddr:          OP_AA_B(x>=y);       break;
2611         case i_eqAddr:          OP_AA_B(x==y);       break;
2612         case i_neAddr:          OP_AA_B(x!=y);       break;
2613         case i_ltAddr:          OP_AA_B(x<y);        break;
2614         case i_leAddr:          OP_AA_B(x<=y);       break;
2615         case i_intToAddr:       OP_I_A((StgAddr)x);  break;  /*  ToDo */
2616         case i_addrToInt:       OP_A_I((StgInt)x);   break;  /* ToDo */
2617
2618         case i_intToStable:     OP_I_s((StgStablePtr)x); break;
2619         case i_stableToInt:     OP_s_I((W_)x);           break;
2620
2621         case i_indexCharOffAddr:   OP_AI_C(indexCharOffAddrzh(r,x,y));      break;
2622         case i_readCharOffAddr:    OP_AI_C(indexCharOffAddrzh(r,x,y));      break;
2623         case i_writeCharOffAddr:   OP_AIC_(writeCharOffAddrzh(x,y,z));      break;
2624
2625         case i_indexIntOffAddr:    OP_AI_I(indexIntOffAddrzh(r,x,y));       break;
2626         case i_readIntOffAddr:     OP_AI_I(indexIntOffAddrzh(r,x,y));       break;
2627         case i_writeIntOffAddr:    OP_AII_(writeIntOffAddrzh(x,y,z));       break;
2628
2629         case i_indexAddrOffAddr:   OP_AI_A(indexAddrOffAddrzh(r,x,y));      break;
2630         case i_readAddrOffAddr:    OP_AI_A(indexAddrOffAddrzh(r,x,y));      break;
2631         case i_writeAddrOffAddr:   OP_AIA_(writeAddrOffAddrzh(x,y,z));      break;
2632
2633         case i_indexFloatOffAddr:  OP_AI_F(indexFloatOffAddrzh(r,x,y));     break;
2634         case i_readFloatOffAddr:   OP_AI_F(indexFloatOffAddrzh(r,x,y));     break;
2635         case i_writeFloatOffAddr:  OP_AIF_(writeFloatOffAddrzh(x,y,z));     break;
2636
2637         case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y));    break;
2638         case i_readDoubleOffAddr:  OP_AI_D(indexDoubleOffAddrzh(r,x,y));    break;
2639         case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z));    break;
2640
2641         case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2642         case i_readStableOffAddr:  OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2643         case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
2644
2645         case i_compareInteger:
2646             {
2647                 B* x = IntegerInsideByteArray(PopPtr());
2648                 B* y = IntegerInsideByteArray(PopPtr());
2649                 StgInt r = do_cmp(x,y);
2650                 PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
2651             }
2652             break;
2653         case i_negateInteger:      OP_Z_Z(neg);     break;
2654         case i_plusInteger:        OP_ZZ_Z(add);    break;
2655         case i_minusInteger:       OP_ZZ_Z(sub);    break;
2656         case i_timesInteger:       OP_ZZ_Z(mul);    break;
2657         case i_quotRemInteger:
2658             {
2659                 B* x     = IntegerInsideByteArray(PopPtr());
2660                 B* y     = IntegerInsideByteArray(PopPtr());
2661                 int n    = size_qrm(x,y);
2662                 StgPtr q = CreateByteArrayToHoldInteger(n);
2663                 StgPtr r = CreateByteArrayToHoldInteger(n);
2664                 if (do_getsign(y)==0)
2665                    return (raiseDiv0("quotRemInteger"));
2666                 do_qrm(x,y,n,IntegerInsideByteArray(q),
2667                              IntegerInsideByteArray(r));
2668                 SloppifyIntegerEnd(q);
2669                 SloppifyIntegerEnd(r);
2670                 PushPtr(r);
2671                 PushPtr(q);
2672             }
2673             break;
2674         case i_intToInteger:
2675             {
2676                  int n    = size_fromInt();
2677                  StgPtr p = CreateByteArrayToHoldInteger(n);
2678                  do_fromInt( PopTaggedInt(), n, IntegerInsideByteArray(p));
2679                  PushPtr(p);
2680             }
2681             break;
2682         case i_wordToInteger:
2683             {
2684                  int n    = size_fromWord();
2685                  StgPtr p = CreateByteArrayToHoldInteger(n);
2686                  do_fromWord( PopTaggedWord(), n, IntegerInsideByteArray(p));
2687                  PushPtr(p);
2688             }
2689             break;
2690         case i_integerToInt:       PushTaggedInt(do_toInt(
2691                                       IntegerInsideByteArray(PopPtr())
2692                                    ));
2693                                    break;
2694
2695         case i_integerToWord:      PushTaggedWord(do_toWord(
2696                                       IntegerInsideByteArray(PopPtr())
2697                                    ));
2698                                    break;
2699
2700         case i_integerToFloat:     PushTaggedFloat(do_toFloat(
2701                                       IntegerInsideByteArray(PopPtr())
2702                                    ));
2703                                    break;
2704
2705         case i_integerToDouble:    PushTaggedDouble(do_toDouble(
2706                                       IntegerInsideByteArray(PopPtr())
2707                                    ));
2708                                    break;
2709
2710         case i_gtFloat:         OP_FF_B(x>y);        break;
2711         case i_geFloat:         OP_FF_B(x>=y);       break;
2712         case i_eqFloat:         OP_FF_B(x==y);       break;
2713         case i_neFloat:         OP_FF_B(x!=y);       break;
2714         case i_ltFloat:         OP_FF_B(x<y);        break;
2715         case i_leFloat:         OP_FF_B(x<=y);       break;
2716         case i_minFloat:        OP__F(FLT_MIN);      break;
2717         case i_maxFloat:        OP__F(FLT_MAX);      break;
2718         case i_radixFloat:      OP__I(FLT_RADIX);    break;
2719         case i_digitsFloat:     OP__I(FLT_MANT_DIG); break;
2720         case i_minExpFloat:     OP__I(FLT_MIN_EXP);  break;
2721         case i_maxExpFloat:     OP__I(FLT_MAX_EXP);  break;
2722         case i_plusFloat:       OP_FF_F(x+y);        break;
2723         case i_minusFloat:      OP_FF_F(x-y);        break;
2724         case i_timesFloat:      OP_FF_F(x*y);        break;
2725         case i_divideFloat:
2726             {
2727                 StgFloat x = PopTaggedFloat();
2728                 StgFloat y = PopTaggedFloat();
2729                 PushTaggedFloat(x/y);
2730             }
2731             break;
2732         case i_negateFloat:     OP_F_F(-x);          break;
2733         case i_floatToInt:      OP_F_I(x);           break;
2734         case i_intToFloat:      OP_I_F(x);           break;
2735         case i_expFloat:        OP_F_F(exp(x));      break;
2736         case i_logFloat:        OP_F_F(log(x));      break;
2737         case i_sqrtFloat:       OP_F_F(sqrt(x));     break;
2738         case i_sinFloat:        OP_F_F(sin(x));      break;
2739         case i_cosFloat:        OP_F_F(cos(x));      break;
2740         case i_tanFloat:        OP_F_F(tan(x));      break;
2741         case i_asinFloat:       OP_F_F(asin(x));     break;
2742         case i_acosFloat:       OP_F_F(acos(x));     break;
2743         case i_atanFloat:       OP_F_F(atan(x));     break;
2744         case i_sinhFloat:       OP_F_F(sinh(x));     break;
2745         case i_coshFloat:       OP_F_F(cosh(x));     break;
2746         case i_tanhFloat:       OP_F_F(tanh(x));     break;
2747         case i_powerFloat:      OP_FF_F(pow(x,y));   break;
2748
2749         case i_encodeFloatZ:
2750             {
2751                 StgPtr sig = PopPtr();
2752                 StgInt exp = PopTaggedInt();
2753                 PushTaggedFloat(
2754                    B__encodeFloat(IntegerInsideByteArray(sig), exp)
2755                 );
2756             }
2757             break;
2758         case i_decodeFloatZ:
2759             {
2760                 StgFloat f = PopTaggedFloat();
2761                 StgPtr sig = CreateByteArrayToHoldInteger(size_fltmantissa());
2762                 StgInt exp;
2763                 B__decodeFloat(IntegerInsideByteArray(sig), &exp, f);
2764                 PushTaggedInt(exp);
2765                 PushPtr(sig);
2766             }
2767             break;
2768
2769         case i_isNaNFloat:      OP_F_B(isFloatNaN(x));      break;
2770         case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
2771         case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
2772         case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
2773         case i_gtDouble:        OP_DD_B(x>y);        break;
2774         case i_geDouble:        OP_DD_B(x>=y);       break;
2775         case i_eqDouble:        OP_DD_B(x==y);       break;
2776         case i_neDouble:        OP_DD_B(x!=y);       break;
2777         case i_ltDouble:        OP_DD_B(x<y);        break;
2778         case i_leDouble:        OP_DD_B(x<=y)        break;
2779         case i_minDouble:       OP__D(DBL_MIN);      break;
2780         case i_maxDouble:       OP__D(DBL_MAX);      break;
2781         case i_radixDouble:     OP__I(FLT_RADIX);    break;
2782         case i_digitsDouble:    OP__I(DBL_MANT_DIG); break;
2783         case i_minExpDouble:    OP__I(DBL_MIN_EXP);  break;
2784         case i_maxExpDouble:    OP__I(DBL_MAX_EXP);  break;
2785         case i_plusDouble:      OP_DD_D(x+y);        break;
2786         case i_minusDouble:     OP_DD_D(x-y);        break;
2787         case i_timesDouble:     OP_DD_D(x*y);        break;
2788         case i_divideDouble:
2789             {
2790                 StgDouble x = PopTaggedDouble();
2791                 StgDouble y = PopTaggedDouble();
2792                 PushTaggedDouble(x/y);
2793             }
2794             break;
2795         case i_negateDouble:    OP_D_D(-x);          break;
2796         case i_doubleToInt:     OP_D_I(x);           break;
2797         case i_intToDouble:     OP_I_D(x);           break;
2798         case i_doubleToFloat:   OP_D_F(x);           break;
2799         case i_floatToDouble:   OP_F_F(x);           break;
2800         case i_expDouble:       OP_D_D(exp(x));      break;
2801         case i_logDouble:       OP_D_D(log(x));      break;
2802         case i_sqrtDouble:      OP_D_D(sqrt(x));     break;
2803         case i_sinDouble:       OP_D_D(sin(x));      break;
2804         case i_cosDouble:       OP_D_D(cos(x));      break;
2805         case i_tanDouble:       OP_D_D(tan(x));      break;
2806         case i_asinDouble:      OP_D_D(asin(x));     break;
2807         case i_acosDouble:      OP_D_D(acos(x));     break;
2808         case i_atanDouble:      OP_D_D(atan(x));     break;
2809         case i_sinhDouble:      OP_D_D(sinh(x));     break;
2810         case i_coshDouble:      OP_D_D(cosh(x));     break;
2811         case i_tanhDouble:      OP_D_D(tanh(x));     break;
2812         case i_powerDouble:     OP_DD_D(pow(x,y));   break;
2813
2814         case i_encodeDoubleZ:
2815             {
2816                 StgPtr sig = PopPtr();
2817                 StgInt exp = PopTaggedInt();
2818                 PushTaggedDouble(
2819                    B__encodeDouble(IntegerInsideByteArray(sig), exp)
2820                 );
2821             }
2822             break;
2823         case i_decodeDoubleZ:
2824             {
2825                 StgDouble d = PopTaggedDouble();
2826                 StgPtr sig = CreateByteArrayToHoldInteger(size_dblmantissa());
2827                 StgInt exp;
2828                 B__decodeDouble(IntegerInsideByteArray(sig), &exp, d);
2829                 PushTaggedInt(exp);
2830                 PushPtr(sig);
2831             }
2832             break;
2833
2834         case i_isNaNDouble:      OP_D_B(isDoubleNaN(x));      break;
2835         case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
2836         case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
2837         case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
2838         case i_isIEEEDouble:
2839             {
2840                 PushTaggedBool(rtsTrue);
2841             }
2842             break;
2843         default:
2844                 barf("Unrecognised primop1");
2845         }
2846    return NULL;
2847 }
2848
2849
2850
2851 /* For normal cases, return NULL and leave *return2 unchanged.
2852    To return the address of the next thing to enter,
2853       return the address of it and leave *return2 unchanged.
2854    To return a StgThreadReturnCode to the scheduler,
2855       set *return2 to it and return a non-NULL value.
2856    To cause a context switch, set context_switch (its a global),
2857    and optionally set hugsBlock to your rational.
2858 */
2859 static void* enterBCO_primop2 ( int primop2code,
2860                                 int* /*StgThreadReturnCode* */ return2,
2861                                 StgBCO** bco,
2862                                 Capability* cap,
2863                                 HugsBlock *hugsBlock )
2864 {
2865         if (combined) {
2866            /* A small concession: we need to allow ccalls,
2867               even in combined mode.
2868            */
2869            if (primop2code != i_ccall_ccall_IO &&
2870                primop2code != i_ccall_stdcall_IO)
2871               barf("enterBCO_primop2 in combined mode");
2872         }
2873
2874         switch (primop2code) {
2875         case i_raise:  /* raise#{err} */
2876             {
2877                 StgClosure* err = PopCPtr();
2878                 return (raiseAnError(err));
2879             }
2880 #ifdef XMLAMBDA
2881 /*------------------------------------------------------------------------
2882   Insert and Remove primitives on Rows. This is important stuff for
2883   XMlambda, these prims are called *all* the time. That's the reason
2884   for all the specialized versions of the basic instructions.
2885   note: A Gc might move rows around => allocate first, than pop the arguments.
2886 ------------------------------------------------------------------------*/
2887
2888 /*------------------------------------------------------------------------
2889   i_rowInsertAt: insert an element into a row
2890 ------------------------------------------------------------------------*/
2891         case i_rowInsertAt:
2892             {
2893                 StgWord j;
2894                 StgWord i;
2895                 StgWord n;
2896                 StgClosure* x;
2897
2898                 /* allocate a new row before popping arguments */
2899                 StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0));
2900                 StgMutArrPtrs* newRow
2901                     = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + row->ptrs + 1));
2902                 SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
2903
2904                 /* pop row again and pop index and value */
2905                 row = stgCast(StgMutArrPtrs*,PopPtr());
2906                 n   = row->ptrs;
2907                 newRow->ptrs = n+1;
2908
2909                 i   = PopTaggedWord();
2910                 x   = PopCPtr();
2911
2912                 ASSERT(i <= n);
2913
2914                 /* copy the fields, inserting the new value */
2915                 for (j = 0; j < i; j++) {
2916                   newRow->payload[j] = row->payload[j];
2917                 }
2918                 newRow->payload[i] = x;
2919                 for (j = i+1; j <= n; j++)
2920                 {
2921                   newRow->payload[j] = row->payload[j-1];
2922                 }
2923
2924                 PushPtr(stgCast(StgPtr,newRow));
2925                 break;
2926             }
2927
2928 /*------------------------------------------------------------------------
2929   i_rowChainInsert: behaves like a chain of [i_rowInsertAt] calls. This
2930   instruction is vital for XMLambda since we would otherwise allocate
2931   a lot of intermediate rows.
2932   It assumes that the RTS has no NULL pointers.
2933   It behaves 'optimal' if the witnesses are ordered, (lowest on the
2934   bottom of the stack).
2935 ------------------------------------------------------------------------*/
2936 #define ROW_HOLE  0
2937         case i_rowChainInsert:
2938             {
2939                 StgWord witness, topWitness;
2940                 StgClosure* value;
2941                 StgWord j;
2942                 StgWord i;
2943
2944                 /* pop the number of arguments (=witness/value pairs) */
2945                 StgWord n = PopTaggedWord();
2946
2947                 /* allocate a new row before popping boxed arguments */
2948                 StgMutArrPtrs* row  = stgCast(StgMutArrPtrs*,stackPtr(0));
2949                 StgMutArrPtrs* newRow
2950                   = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n + row->ptrs));
2951                 SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
2952
2953                 /* pop the row and assign again (it may have moved during gc!) */
2954                 row = stgCast(StgMutArrPtrs*,PopPtr());
2955                 newRow->ptrs = n + row->ptrs;
2956
2957                 /* zero the fields */
2958                 for (i = 0; i < newRow->ptrs; i++)
2959                 {
2960                   newRow->payload[i] = ROW_HOLE;
2961                 }
2962
2963                 /* insert all values */
2964                 topWitness = 0;         /*invariant: 1 + maximal witness */
2965                 for (i = 0; i < n; i++)
2966                 {
2967                   witness = PopTaggedWord();
2968                   value   = PopCPtr();
2969                   if (witness < topWitness)
2970                   {
2971                     /* shoot, unordered witnesses, we have to bump up everything */
2972                     for (j = topWitness; j > witness; j--)
2973                     {
2974                       newRow->payload[j] = newRow->payload[j-1];
2975                     }
2976                     topWitness += 1;
2977                   }
2978                   else
2979                   {
2980                     topWitness = witness+1;
2981                   }
2982
2983                   ASSERT(topWitness <= n);
2984                   ASSERT(witness < n);
2985                   newRow->payload[witness] = value;
2986                 }
2987
2988                 /* copy the values from the old row into the holes */
2989                 for (j =0, i = 0; i < row->ptrs; j++,i++)
2990                 {
2991                   while (newRow->payload[j] != ROW_HOLE) j++;
2992                   ASSERT(j < n);
2993                   newRow->payload[j] = row->payload[i];
2994                 }
2995
2996                 /* push the result */
2997                 PushPtr(stgCast(StgPtr,newRow));
2998                 break;
2999             }
3000
3001 /*------------------------------------------------------------------------
3002   i_rowChainBuild: exactly as [i_rowChainInsert] but builds a row from scratch.
3003 ------------------------------------------------------------------------*/
3004         case i_rowChainBuild:
3005             {
3006                 StgWord witness, topWitness;
3007                 StgClosure* value;
3008                 StgWord j;
3009                 StgWord i;
3010
3011                 /* pop the number of arguments (=witness/value pairs) */
3012                 StgWord n = PopTaggedWord();
3013
3014                 /* allocate a new row before popping boxed arguments */
3015                 StgMutArrPtrs* newRow
3016                   = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n));
3017                 SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
3018                 newRow->ptrs = n;
3019
3020                 /* insert all values */
3021                 topWitness = 0;         /*invariant: 1 + maximal witness */
3022                 for (i = 0; i < n; i++)
3023                 {
3024                   witness = PopTaggedWord();
3025                   value   = PopCPtr();
3026                   if (witness < topWitness)
3027                   {
3028                     /* shoot, unordered witnesses, we have to bump up everything */
3029                     for (j = topWitness; j > witness; j--)
3030                     {
3031                       newRow->payload[j] = newRow->payload[j-1];
3032                     }
3033                     topWitness += 1;
3034                   }
3035                   else
3036                   {
3037                     topWitness = witness+1;
3038                   }
3039
3040                   ASSERT(topWitness <= n);
3041                   ASSERT(witness < n);
3042                   newRow->payload[witness] = value;
3043                 }
3044
3045                 /* push the result */
3046                 PushPtr(stgCast(StgPtr,newRow));
3047                 break;
3048             }
3049
3050 /*------------------------------------------------------------------------
3051   i_rowRemoveAt: remove an element from a row
3052 ------------------------------------------------------------------------*/
3053         case i_rowRemoveAt:
3054             {
3055                 StgWord j;
3056                 StgWord i;
3057                 StgWord n;
3058
3059                 /* allocate new row before popping the arguments */
3060                 StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0));
3061                 StgMutArrPtrs* newRow
3062                     = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + row->ptrs - 1));
3063                 SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
3064
3065                 /* pop row again and pop the index */
3066                 row = stgCast(StgMutArrPtrs*,PopPtr());
3067                 n            = row->ptrs;
3068                 newRow->ptrs = n-1;
3069
3070                 i   = PopTaggedWord();
3071
3072                 ASSERT(i < n);
3073
3074                 /* copy the fields, except for the removed value. */
3075                 for (j = 0; j < i; j++) {
3076                   newRow->payload[j] = row->payload[j];
3077                 }
3078                 for (j = i+1; j < n; j++)
3079                 {
3080                   newRow->payload[j-1] = row->payload[j];
3081                 }
3082
3083                 PushCPtr(row->payload[i]);
3084                 PushPtr(stgCast(StgPtr,newRow));
3085                 break;
3086             }
3087
3088 /*------------------------------------------------------------------------
3089   i_rowChainRemove: behaves like a chain of [i_rowRemoveAt] calls. Again,
3090   this is a vital instruction to avoid lots of intermediate rows.
3091   It behaves 'optimal' if the witnessses are ordered, lowest on the
3092   bottom of the stack.
3093   The implementation is quite dirty, blame Daan for this :-)
3094   (It overwrites witnesses on the stack with results and marks pointers
3095    using their lowest bit.)
3096 ------------------------------------------------------------------------*/
3097 #define MARK(p)     (stgCast(StgClosure*,(stgCast(StgWord,(p)) | 0x01)))
3098 #define UNMARK(p)   (stgCast(StgClosure*,(stgCast(StgWord,(p)) & ~0x01)))
3099 #define ISMARKED(p) ((stgCast(StgWord,(p)) & 0x01) == 0x01)
3100
3101         case i_rowChainRemove:
3102             {
3103                 const nat sizeofTaggedWord = sizeofW(StgWord) + sizeofW(StackTag);
3104                 StgWord i;
3105                 StgWord j;
3106                 StgWord minWitness;
3107                 nat     base;
3108                 StgClosure* value;
3109
3110
3111                 /* pop number of arguments (=witnesses) */
3112                 StgWord n = PopTaggedWord();
3113
3114                 /* allocate new row before popping boxed arguments */
3115                 StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0));
3116                 StgMutArrPtrs* newRow
3117                     = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + row->ptrs - n));
3118                 SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
3119
3120                 /* pop row and assign again (gc might have moved it) */
3121                 row = stgCast(StgMutArrPtrs*,PopPtr());
3122                 newRow->ptrs = row->ptrs - n;
3123                 ASSERT( row->ptrs > n );
3124
3125                 /* 'push' all elements that are removed */
3126                 base       = n*sizeofTaggedWord;
3127                 minWitness = row->ptrs;
3128                 for (i = 1; i <= n; i++)
3129                 {
3130                   StgWord witness;
3131
3132                   witness = taggedStackWord( base - i*sizeofTaggedWord );
3133                   if (witness >= minWitness)
3134                   {
3135                     /* shoot, unordered witnesses, we have to search for the value */
3136                     nat count;
3137
3138                     count   = witness - minWitness;
3139                     witness = minWitness;
3140                     while (1)
3141                     {
3142                       do{ witness++; } while (ISMARKED(row->payload[witness]));
3143                       if (count == 0) break;
3144                       count--;
3145                     }
3146                   }
3147                   else
3148                   {
3149                     minWitness = witness;
3150                   }
3151                   ASSERT( witness < row->ptrs );
3152                   ASSERT( !ISMARKED(row->payload[witness]) );
3153
3154                   /* mark the element */
3155                   value = row->payload[witness];
3156                   row->payload[witness] = MARK(value);
3157
3158                   /* set the value in the stack (overwriting old witnesses!) */
3159                   setStackPtr( base - i*sizeofW(StgPtr), stgCast(StgPtr,value) );
3160                 }
3161
3162                 /* pop the garbage from the stack */
3163                 gSp = gSp + base - n*sizeofW(StgPtr);
3164
3165                 /* copy all remaining elements and clear the marks */
3166                 for (j = 0, i = 0; i < newRow->ptrs; j++,i++)
3167                 {
3168                   while (ISMARKED(row->payload[j]))
3169                   {
3170                     row->payload[j] = UNMARK(row->payload[j]);
3171                     j++;
3172                   }
3173                   newRow->payload[i] = row->payload[j];
3174                 }
3175
3176                 /* unmark tail */
3177                 while (j < row->ptrs)
3178                 {
3179                   value = row->payload[j];
3180                   if (ISMARKED(value)) row->payload[j] = UNMARK(value);
3181                   j++;
3182                 }
3183
3184 #ifdef DEBUG
3185                 for (i = 0; i < row->ptrs; i++)
3186                 {
3187                   ASSERT(!ISMARKED(row->payload[i]));
3188                 }
3189 #endif
3190
3191                 /* and push the result row */
3192                 PushPtr(stgCast(StgPtr,newRow));
3193                 break;
3194             }
3195
3196 /*------------------------------------------------------------------------
3197   i_rowChainSelect: behaves exactly like [i_rowChainRemove] but doesn't return
3198   the resulting row, only the removed elements.
3199 ------------------------------------------------------------------------*/
3200         case i_rowChainSelect:
3201             {
3202                 const nat sizeofTaggedWord = sizeofW(StgWord) + sizeofW(StackTag);
3203                 StgWord i;
3204                 StgWord minWitness;
3205                 nat     base;
3206                 StgClosure* value;
3207
3208                 /* pop number of arguments (=witnesses) and row*/
3209                 StgWord        n   = PopTaggedWord();
3210                 StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,PopPtr());
3211                 ASSERT( row->ptrs > n );
3212
3213                 /* 'push' all elements that are removed */
3214                 base       = n*sizeofTaggedWord;
3215                 minWitness = row->ptrs;
3216                 for (i = 1; i <= n; i++)
3217                 {
3218                   StgWord witness;
3219
3220                   witness = taggedStackWord( base - i*sizeofTaggedWord );
3221                   if (witness >= minWitness)
3222                   {
3223                     /* shoot, unordered witnesses, we have to search for the value */
3224                     nat count;
3225
3226                     count   = witness - minWitness;
3227                     witness = minWitness;
3228                     while (1)
3229                     {
3230                       do{ witness++; } while (ISMARKED(row->payload[witness]));
3231                       if (count == 0) break;
3232                       count--;
3233                     }
3234                   }
3235                   else
3236                   {
3237                     minWitness = witness;
3238                   }
3239                   ASSERT( witness < row->ptrs );
3240                   ASSERT( !ISMARKED(row->payload[witness]) );
3241
3242                   /* mark the element */
3243                   value = row->payload[witness];
3244                   row->payload[witness] = MARK(value);
3245
3246                   /* set the value in the stack (overwriting old witnesses!) */
3247                   setStackPtr( base - i*sizeofW(StgPtr), stgCast(StgPtr,value) );
3248                 }
3249
3250                 /* pop the garbage from the stack */
3251                 gSp = gSp + base - n*sizeofW(StgPtr);
3252
3253                 /* unmark elements */
3254                 for( i = 0; i < row->ptrs; i++)
3255                 {
3256                   value = row->payload[i];
3257                   if (ISMARKED(value)) row->payload[i] = UNMARK(value);
3258                 }
3259
3260 #ifdef DEBUG
3261                 for (i = 0; i < row->ptrs; i++)
3262                 {
3263                   ASSERT(!ISMARKED(row->payload[i]));
3264                 }
3265 #endif
3266                 break;
3267             }
3268
3269 #endif /* XMLAMBDA */
3270
3271         case i_newRef:
3272             {
3273                 StgClosure* init = PopCPtr();
3274                 StgMutVar* mv
3275                     = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
3276                 SET_HDR(mv,&MUT_VAR_info,CCCS);
3277                 mv->var = init;
3278                 PushPtr(stgCast(StgPtr,mv));
3279                 break;
3280             }
3281         case i_readRef:
3282             {
3283                 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
3284                 PushCPtr(mv->var);
3285                 break;
3286             }
3287         case i_writeRef:
3288             {
3289                 StgMutVar*  mv    = stgCast(StgMutVar*,PopPtr());
3290                 StgClosure* value = PopCPtr();
3291                 mv->var = value;
3292                 break;
3293             }
3294         case i_newArray:
3295             {
3296                 nat         n    = PopTaggedInt(); /* or Word?? */
3297                 StgClosure* init = PopCPtr();
3298                 StgWord     size = sizeofW(StgMutArrPtrs) + n;
3299                 nat i;
3300                 StgMutArrPtrs* arr
3301                     = stgCast(StgMutArrPtrs*,allocate(size));
3302                 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
3303                 arr->ptrs = n;
3304                 for (i = 0; i < n; ++i) {
3305                     arr->payload[i] = init;
3306                 }
3307                 PushPtr(stgCast(StgPtr,arr));
3308                 break;
3309             }
3310         case i_readArray:
3311         case i_indexArray:
3312             {
3313                 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3314                 nat         i   = PopTaggedInt(); /* or Word?? */
3315                 StgWord     n   = arr->ptrs;
3316                 if (i >= n) {
3317                     return (raiseIndex("{index,read}Array"));
3318                 }
3319                 PushCPtr(arr->payload[i]);
3320                 break;
3321             }
3322         case i_writeArray:
3323             {
3324                 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3325                 nat         i   = PopTaggedInt(); /* or Word? */
3326                 StgClosure* v   = PopCPtr();
3327                 StgWord     n   = arr->ptrs;
3328                 if (i >= n) {
3329                     return (raiseIndex("{index,read}Array"));
3330                 }
3331                 arr->payload[i] = v;
3332                 break;
3333             }
3334         case i_sizeArray:
3335         case i_sizeMutableArray:
3336             {
3337                 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3338                 PushTaggedInt(arr->ptrs);
3339                 break;
3340             }
3341         case i_unsafeFreezeArray:
3342             {
3343                 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3344                 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
3345                 PushPtr(stgCast(StgPtr,arr));
3346                 break;
3347             }
3348         case i_unsafeFreezeByteArray:
3349             {
3350                 /* Delightfully simple :-) */
3351                 break;
3352             }
3353         case i_sameRef:
3354         case i_sameMutableArray:
3355         case i_sameMutableByteArray:
3356             {
3357                 StgPtr x = PopPtr();
3358                 StgPtr y = PopPtr();
3359                 PushTaggedBool(x==y);
3360                 break;
3361             }
3362
3363         case i_newByteArray:
3364             {
3365                 nat     n     = PopTaggedInt(); /* or Word?? */
3366                 StgInt  words = (n+sizeof(W_)-1)/sizeof(W_);
3367                 StgWord size  = sizeofW(StgArrWords) + words;
3368                 StgArrWords* arr  = stgCast(StgArrWords*,allocate(size));
3369                 SET_HDR(arr,&ARR_WORDS_info,CCCS);
3370                 arr->words = words;
3371 #ifdef DEBUG
3372                {nat i;
3373                for (i = 0; i < n; ++i) {
3374                     arr->payload[i] = 0xdeadbeef;
3375                }}
3376 #endif
3377                 PushPtr(stgCast(StgPtr,arr));
3378                 break;
3379             }
3380
3381         /* Most of these generate alignment warnings on Sparcs and similar architectures.
3382          * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
3383          */
3384         case i_indexCharArray:
3385             OP_mI_ty(Char,"indexCharArray",    indexCharArrayzh(r,x,i)); break;
3386         case i_readCharArray:
3387             OP_mI_ty(Char,"readCharArray",     readCharArrayzh(r,x,i));  break;
3388         case i_writeCharArray:
3389             OP_mIty_(Char,"writeCharArray",    writeCharArrayzh(x,i,z)); break;
3390
3391         case i_indexIntArray:
3392             OP_mI_ty(Int,"indexIntArray",      indexIntArrayzh(r,x,i)); break;
3393         case i_readIntArray:
3394             OP_mI_ty(Int,"readIntArray",       readIntArrayzh(r,x,i));  break;
3395         case i_writeIntArray:
3396             OP_mIty_(Int,"writeIntArray",      writeIntArrayzh(x,i,z)); break;
3397
3398         case i_indexAddrArray:
3399             OP_mI_ty(Addr,"indexAddrArray",   indexAddrArrayzh(r,x,i)); break;
3400         case i_readAddrArray:
3401             OP_mI_ty(Addr,"readAddrArray",    readAddrArrayzh(r,x,i));  break;
3402         case i_writeAddrArray:
3403             OP_mIty_(Addr,"writeAddrArray",   writeAddrArrayzh(x,i,z)); break;
3404
3405         case i_indexFloatArray:
3406             OP_mI_ty(Float,"indexFloatArray",  indexFloatArrayzh(r,x,i)); break;
3407         case i_readFloatArray:
3408             OP_mI_ty(Float,"readFloatArray",   readFloatArrayzh(r,x,i));  break;
3409         case i_writeFloatArray:
3410             OP_mIty_(Float,"writeFloatArray",  writeFloatArrayzh(x,i,z)); break;
3411
3412         case i_indexDoubleArray:
3413             OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break;
3414         case i_readDoubleArray:
3415             OP_mI_ty(Double,"readDoubleArray",  readDoubleArrayzh(r,x,i));  break;
3416         case i_writeDoubleArray:
3417             OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break;
3418
3419 #if 0
3420 #ifdef PROVIDE_STABLE
3421         case i_indexStableArray:
3422             OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break;
3423         case i_readStableArray:
3424             OP_mI_ty(StablePtr,"readStableArray",  readStablePtrArrayzh(r,x,i));  break;
3425         case i_writeStableArray:
3426             OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
3427 #endif
3428 #endif
3429
3430
3431
3432 #ifdef PROVIDE_COERCE
3433         case i_unsafeCoerce:
3434             {
3435                 /* Another nullop */
3436                 break;
3437             }
3438 #endif
3439 #ifdef PROVIDE_PTREQUALITY
3440         case i_reallyUnsafePtrEquality:
3441             { /* identical to i_sameRef */
3442                 StgPtr x = PopPtr();
3443                 StgPtr y = PopPtr();
3444                 PushTaggedBool(x==y);
3445                 break;
3446             }
3447 #endif
3448 #ifdef PROVIDE_FOREIGN
3449                 /* ForeignObj# operations */
3450         case i_mkForeignObj:
3451             {
3452                 StgForeignObj *result
3453                     = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
3454                 SET_HDR(result,&FOREIGN_info,CCCS);
3455                 result -> data      = PopTaggedAddr();
3456                 PushPtr(stgCast(StgPtr,result));
3457                 break;
3458             }
3459 #endif /* PROVIDE_FOREIGN */
3460 #ifdef PROVIDE_WEAK
3461         case i_makeWeak:
3462             {
3463                 StgWeak *w
3464                     = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
3465                 SET_HDR(w, &WEAK_info, CCCS);
3466                 w->key        = PopCPtr();
3467                 w->value      = PopCPtr();
3468                 w->finaliser  = PopCPtr();
3469                 w->link       = weak_ptr_list;
3470                 weak_ptr_list = w;
3471                 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
3472                 PushPtr(stgCast(StgPtr,w));
3473                 break;
3474             }
3475         case i_deRefWeak:
3476             {
3477                 StgWeak *w = stgCast(StgWeak*,PopPtr());
3478                 if (w->header.info == &WEAK_info) {
3479                     PushCPtr(w->value); /* last result  */
3480                     PushTaggedInt(1);   /* first result */
3481                 } else {
3482                     PushPtr(stgCast(StgPtr,w));
3483                            /* ToDo: error thunk would be better */
3484                     PushTaggedInt(0);
3485                 }
3486                 break;
3487             }
3488 #endif /* PROVIDE_WEAK */
3489
3490         case i_makeStablePtr:
3491             {
3492                 StgPtr       p  = PopPtr();
3493                 StgStablePtr sp = getStablePtr ( p );
3494                 PushTaggedStablePtr(sp);
3495                 break;
3496             }
3497         case i_deRefStablePtr:
3498             {
3499                 StgPtr p;
3500                 StgStablePtr sp = PopTaggedStablePtr();
3501                 p = deRefStablePtr(sp);
3502                 PushPtr(p);
3503                 break;
3504             }
3505         case i_freeStablePtr:
3506             {
3507                 StgStablePtr sp = PopTaggedStablePtr();
3508                 freeStablePtr(sp);
3509                 break;
3510             }
3511
3512         case i_createAdjThunkARCH:
3513             {
3514                 StgStablePtr stableptr = PopTaggedStablePtr();
3515                 StgAddr      typestr   = PopTaggedAddr();
3516                 StgChar      callconv  = PopTaggedChar();
3517                 StgAddr      adj_thunk = createAdjThunk(stableptr,typestr,callconv);
3518                 PushTaggedAddr(adj_thunk);
3519                 break;
3520             }
3521
3522         case i_getArgc:
3523             {
3524                 StgInt n = prog_argc;
3525                 PushTaggedInt(n);
3526                 break;
3527             }
3528         case i_getArgv:
3529             {
3530                 StgInt  n = PopTaggedInt();
3531                 StgAddr a = (StgAddr)prog_argv[n];
3532                 PushTaggedAddr(a);
3533                 break;
3534             }
3535
3536         case i_newMVar:
3537             {
3538                 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
3539                 SET_INFO(mvar,&EMPTY_MVAR_info);
3540                 mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
3541                 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
3542                 PushPtr(stgCast(StgPtr,mvar));
3543                 break;
3544             }
3545         case i_takeMVar:
3546             {
3547                 StgMVar *mvar = (StgMVar*)PopCPtr();
3548                 if (GET_INFO(mvar) == &EMPTY_MVAR_info) {
3549
3550                     /* The MVar is empty.  Attach ourselves to the TSO's
3551                        blocking queue.
3552                     */
3553                     if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
3554                         mvar->head = cap->rCurrentTSO;
3555                     } else {
3556                         mvar->tail->link = cap->rCurrentTSO;
3557                     }
3558                     cap->rCurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
3559                     cap->rCurrentTSO->why_blocked = BlockedOnMVar;
3560                     cap->rCurrentTSO->block_info.closure = (StgClosure *)mvar;
3561                     mvar->tail = cap->rCurrentTSO;
3562
3563                     /* At this point, the top-of-stack holds the MVar,
3564                        and underneath is the world token ().  So the
3565                        stack is in the same state as when primTakeMVar
3566                        was entered (primTakeMVar is handwritten bytecode).
3567                        Push obj, which is this BCO, and return to the
3568                        scheduler.  When the MVar is filled, the scheduler
3569                        will re-enter primTakeMVar, with the args still on
3570                        the top of the stack.
3571                     */
3572                     PushCPtr((StgClosure*)(*bco));
3573                     *return2 = ThreadBlocked;
3574                     return (void*)(1+(char*)(NULL));
3575
3576                 } else {
3577                     PushCPtr(mvar->value);
3578                     mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
3579                     SET_INFO(mvar,&EMPTY_MVAR_info);
3580                 }
3581                 break;
3582             }
3583         case i_putMVar:
3584             {
3585                 StgMVar*    mvar  = stgCast(StgMVar*,PopPtr());
3586                 StgClosure* value = PopCPtr();
3587                 if (GET_INFO(mvar) == &FULL_MVAR_info) {
3588                     return (makeErrorCall("putMVar {full MVar}"));
3589                 } else {
3590                     /* wake up the first thread on the
3591                      * queue, it will continue with the
3592                      * takeMVar operation and mark the
3593                      * MVar empty again.
3594                      */
3595                     mvar->value = value;
3596
3597                     if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
3598                        ASSERT(mvar->head->why_blocked == BlockedOnMVar);
3599                        mvar->head = unblockOne(mvar->head);
3600                        if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
3601                           mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
3602                        }
3603                     }
3604
3605                     /* unlocks the MVar in the SMP case */
3606                     SET_INFO(mvar,&FULL_MVAR_info);
3607
3608                     /* yield for better communication performance */
3609                     context_switch = 1;
3610                 }
3611                 break;
3612             }
3613         case i_sameMVar:
3614             {   /* identical to i_sameRef */
3615                 StgMVar* x = (StgMVar*)PopPtr();
3616                 StgMVar* y = (StgMVar*)PopPtr();
3617                 PushTaggedBool(x==y);
3618                 break;
3619             }
3620 #ifdef PROVIDE_CONCURRENT
3621         case i_forkIO:
3622             {
3623                 StgClosure* closure;
3624                 StgTSO*     tso;
3625                 StgWord     tid;
3626                 closure = PopCPtr();
3627                 tso     = createGenThread (RtsFlags.GcFlags.initialStkSize,closure);
3628                 tid     = tso->id;
3629                 scheduleThread(tso);
3630                 context_switch = 1;
3631                 /* Later: Change to use tso as the ThreadId */
3632                 PushTaggedWord(tid);
3633                 break;
3634             }
3635
3636         case i_killThread:
3637             {
3638                 StgWord n = PopTaggedWord();
3639                 StgTSO* tso = 0;
3640                 StgTSO *t;
3641
3642                 // Map from ThreadId to Thread Structure */
3643                 for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
3644                   if (n == t->id)
3645                     tso = t;
3646                 }
3647                 if (tso == 0) {
3648                   // Already dead
3649                   break;
3650                 }
3651
3652                 while (tso->what_next == ThreadRelocated) {
3653                   tso = tso->link;
3654                 }
3655
3656                 deleteThread(tso);
3657                 if (tso == cap->rCurrentTSO) { /* suicide */
3658                     *return2 = ThreadFinished;
3659                     return (void*)(1+(char*)(NULL));
3660                 }
3661                 break;
3662             }
3663         case i_raiseInThread:
3664           barf("raiseInThread");
3665           ASSERT(0); /* not (yet) supported */
3666         case i_delay:
3667           {
3668             StgInt  n = PopTaggedInt();
3669             context_switch = 1;
3670             hugsBlock->reason = BlockedOnDelay;
3671             hugsBlock->delay = n;
3672             break;
3673           }
3674         case i_waitRead:
3675           {
3676             StgInt  n = PopTaggedInt();
3677             context_switch = 1;
3678             hugsBlock->reason = BlockedOnRead;
3679             hugsBlock->delay = n;
3680             break;
3681           }
3682         case i_waitWrite:
3683           {
3684             StgInt  n = PopTaggedInt();
3685             context_switch = 1;
3686             hugsBlock->reason = BlockedOnWrite;
3687             hugsBlock->delay = n;
3688             break;
3689           }
3690         case i_yield:
3691           {
3692             /* The definition of yield include an enter right after
3693              * the primYield, at which time context_switch is tested.
3694              */
3695             context_switch = 1;
3696             break;
3697           }
3698         case i_getThreadId:
3699             {
3700                 StgWord tid = cap->rCurrentTSO->id;
3701                 PushTaggedWord(tid);
3702                 break;
3703             }
3704         case i_cmpThreadIds:
3705             {
3706                 StgWord tid1 = PopTaggedWord();
3707                 StgWord tid2 = PopTaggedWord();
3708                 if (tid1 < tid2) PushTaggedInt(-1);
3709                 else if (tid1 > tid2) PushTaggedInt(1);
3710                 else PushTaggedInt(0);
3711                 break;
3712             }
3713 #endif /* PROVIDE_CONCURRENT */
3714 #ifdef XMLAMBDA
3715         case i_ccall:
3716             {
3717                 CallInfo        callInfo;
3718                 CFunDescriptor  descriptor;
3719                 void (*funPtr)(void);
3720
3721                 StgWord offset  = PopTaggedWord();  /* offset into bco nonptr section */
3722                 funPtr          = PopTaggedAddr();
3723
3724                 ASSERT(funPtr != NULL);
3725
3726                 /* copy the complete callinfo, the bco might move during GC! */
3727                 callInfo    = *stgCast(CallInfo*, (*bco)->payload + (*bco)->n_ptrs + offset);
3728
3729                 /* copy info to a CFunDescriptor. just for compatibility. */
3730                 descriptor.num_args     = callInfo.argCount;
3731                 descriptor.arg_tys      = callInfo.data;
3732                 descriptor.num_results  = callInfo.resultCount;
3733                 descriptor.result_tys   = callInfo.data + callInfo.argCount + 1;
3734
3735                 /* call out */
3736                 switch (ccall( &descriptor, funPtr, bco, callInfo.callConv, cap ))
3737                 {
3738                 case  0: break;
3739                 case  1: barf( "unhandled type or too many args/results in ccall"); break;
3740                 case  2: barf("ccall not configured correctly for this platform"); break;
3741                 default: barf("unknown return code from ccall"); break;
3742                 }
3743
3744                 break;
3745             }
3746 #endif
3747
3748         case i_ccall_ccall_Id:
3749         case i_ccall_ccall_IO:
3750         case i_ccall_stdcall_Id:
3751         case i_ccall_stdcall_IO:
3752             {
3753                 int r;
3754                 CFunDescriptor* descriptor;
3755                 void (*funPtr)(void);
3756                 char cc;
3757                 descriptor = PopTaggedAddr();
3758                 funPtr     = PopTaggedAddr();
3759                  cc = (primop2code == i_ccall_stdcall_Id ||
3760                            primop2code == i_ccall_stdcall_IO)
3761                           ? 's' : 'c';
3762                 r = ccall(descriptor,funPtr,bco,cc,cap);
3763                 if (r == 0) break;
3764                 if (r == 1)
3765                    return makeErrorCall(
3766                       "unhandled type or too many args/results in ccall");
3767                 if (r == 2)
3768                    barf("ccall not configured correctly for this platform");
3769                 barf("unknown return code from ccall");
3770             }
3771         default:
3772                 barf("Unrecognised primop2");
3773    }
3774    return NULL;
3775 }
3776
3777
3778 /* -----------------------------------------------------------------------------
3779  * ccall support code:
3780  *   marshall moves args from C stack to Haskell stack
3781  *   unmarshall moves args from Haskell stack to C stack
3782  *   argSize calculates how much gSpace you need on the C stack
3783  * ---------------------------------------------------------------------------*/
3784
3785 /* Pop arguments off the C stack and Push them onto the Hugs stack.
3786  * Used when preparing for C calling Haskell or in regSponse to
3787  *  Haskell calling C.
3788  */
3789 nat marshall(char arg_ty, void* arg)
3790 {
3791     switch (arg_ty) {
3792     case INT_REP:
3793             PushTaggedInt(*((int*)arg));
3794             return ARG_SIZE(INT_TAG);
3795 #if 0
3796     case INTEGER_REP:
3797             PushTaggedInteger(*((mpz_ptr*)arg));
3798             return ARG_SIZE(INTEGER_TAG);
3799 #endif
3800     case WORD_REP:
3801             PushTaggedWord(*((unsigned int*)arg));
3802             return ARG_SIZE(WORD_TAG);
3803     case CHAR_REP:
3804             PushTaggedChar(*((char*)arg));
3805             return ARG_SIZE(CHAR_TAG);
3806     case FLOAT_REP:
3807             PushTaggedFloat(*((float*)arg));
3808             return ARG_SIZE(FLOAT_TAG);
3809     case DOUBLE_REP:
3810             PushTaggedDouble(*((double*)arg));
3811             return ARG_SIZE(DOUBLE_TAG);
3812     case ADDR_REP:
3813             PushTaggedAddr(*((void**)arg));
3814             return ARG_SIZE(ADDR_TAG);
3815     case STABLE_REP:
3816             PushTaggedStablePtr(*((StgStablePtr*)arg));
3817             return ARG_SIZE(STABLE_TAG);
3818 #ifdef PROVIDE_FOREIGN
3819     case FOREIGN_REP:
3820             /* Not allowed in this direction - you have to
3821              * call makeForeignPtr explicitly
3822              */
3823             barf("marshall: ForeignPtr#\n");
3824             break;
3825 #endif
3826     case BARR_REP:
3827     case MUTBARR_REP:
3828             /* Not allowed in this direction  */
3829             barf("marshall: [Mutable]ByteArray#\n");
3830             break;
3831     default:
3832             barf("marshall: unrecognised arg type %d\n",arg_ty);
3833             break;
3834     }
3835 }
3836
3837 /* Pop arguments off the Hugs stack and Push them onto the C stack.
3838  * Used when preparing for Haskell calling C or in regSponse to
3839  * C calling Haskell.
3840  */
3841 nat unmarshall(char res_ty, void* res)
3842 {
3843     switch (res_ty) {
3844     case INT_REP:
3845             *((int*)res) = PopTaggedInt();
3846             return ARG_SIZE(INT_TAG);
3847 #if 0
3848     case INTEGER_REP:
3849             *((mpz_ptr*)res) = PopTaggedInteger();
3850             return ARG_SIZE(INTEGER_TAG);
3851 #endif
3852     case WORD_REP:
3853             *((unsigned int*)res) = PopTaggedWord();
3854             return ARG_SIZE(WORD_TAG);
3855     case CHAR_REP:
3856             *((int*)res) = PopTaggedChar();
3857             return ARG_SIZE(CHAR_TAG);
3858     case FLOAT_REP:
3859             *((float*)res) = PopTaggedFloat();
3860             return ARG_SIZE(FLOAT_TAG);
3861     case DOUBLE_REP:
3862             *((double*)res) = PopTaggedDouble();
3863             return ARG_SIZE(DOUBLE_TAG);
3864     case ADDR_REP:
3865             *((void**)res) = PopTaggedAddr();
3866             return ARG_SIZE(ADDR_TAG);
3867     case STABLE_REP:
3868             *((StgStablePtr*)res) = PopTaggedStablePtr();
3869             return ARG_SIZE(STABLE_TAG);
3870 #ifdef PROVIDE_FOREIGN
3871     case FOREIGN_REP:
3872         {
3873             StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
3874             *((void**)res) = result->data;
3875             return sizeofW(StgPtr);
3876         }
3877 #endif
3878     case BARR_REP:
3879     case MUTBARR_REP:
3880         {
3881             StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3882             *((void**)res) = stgCast(void*,&(arr->payload));
3883             return sizeofW(StgPtr);
3884         }
3885     default:
3886             barf("unmarshall: unrecognised result type %d\n",res_ty);
3887     }
3888 }
3889
3890 nat argSize( const char* ks )
3891 {
3892     nat sz = 0;
3893     for( ; *ks != '\0'; ++ks) {
3894         switch (*ks) {
3895         case INT_REP:
3896                 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
3897                 break;
3898 #if 0
3899         case INTEGER_REP:
3900                 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
3901                 break;
3902 #endif
3903         case WORD_REP:
3904                 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
3905                 break;
3906         case CHAR_REP:
3907                 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
3908                 break;
3909         case FLOAT_REP:
3910                 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
3911                 break;
3912         case DOUBLE_REP:
3913                 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
3914                 break;
3915         case ADDR_REP:
3916                 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
3917                 break;
3918         case STABLE_REP:
3919                 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
3920                 break;
3921 #ifdef PROVIDE_FOREIGN
3922         case FOREIGN_REP:
3923 #endif
3924         case BARR_REP:
3925         case MUTBARR_REP:
3926                 sz += sizeof(StgPtr);
3927                 break;
3928         default:
3929                 barf("argSize: unrecognised result type %d\n",*ks);
3930                 break;
3931         }
3932     }
3933     return sz;
3934 }
3935
3936
3937 /* -----------------------------------------------------------------------------
3938  * encode/decode Float/Double code for standalone Hugs
3939  * Code based on the HBC code (lib/fltcode.c) and more recently GHC
3940  * (ghc/rts/StgPrimFloat.c)
3941  * ---------------------------------------------------------------------------*/
3942
3943 #if IEEE_FLOATING_POINT
3944 #define MY_DMINEXP  ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
3945 /* DMINEXP is defined in values.h on Linux (for example) */
3946 #define DHIGHBIT 0x00100000
3947 #define DMSBIT   0x80000000
3948
3949 #define MY_FMINEXP  ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
3950 #define FHIGHBIT 0x00800000
3951 #define FMSBIT   0x80000000
3952 #else
3953 #error The following code doesnt work in a non-IEEE FP environment
3954 #endif
3955
3956 #ifdef WORDS_BIGENDIAN
3957 #define L 1
3958 #define H 0
3959 #else
3960 #define L 0
3961 #define H 1
3962 #endif
3963
3964
3965 StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */
3966 {
3967     StgDouble r;
3968     I_ i;
3969
3970     /* Convert a B to a double; knows a lot about internal rep! */
3971     for(r = 0.0, i = s->used-1; i >= 0; i--)
3972         r = (r * B_BASE_FLT) + s->stuff[i];
3973
3974     /* Now raise to the exponent */
3975     if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3976         r = ldexp(r, e);
3977
3978     /* handle the sign */
3979     if (s->sign < 0) r = -r;
3980
3981     return r;
3982 }
3983
3984
3985
3986 #if ! FLOATS_AS_DOUBLES
3987 StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */
3988 {
3989     StgFloat r;
3990     I_ i;
3991
3992     /* Convert a B to a float; knows a lot about internal rep! */
3993     for(r = 0.0, i = s->used-1; i >= 0; i--)
3994         r = (r * B_BASE_FLT) + s->stuff[i];
3995
3996     /* Now raise to the exponent */
3997     if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3998         r = ldexp(r, e);
3999
4000     /* handle the sign */
4001     if (s->sign < 0) r = -r;
4002
4003     return r;
4004 }
4005 #endif  /* FLOATS_AS_DOUBLES */
4006
4007
4008
4009 /* This only supports IEEE floating point */
4010 void B__decodeDouble (B* man, I_* exp, StgDouble dbl)
4011 {
4012     /* Do some bit fiddling on IEEE */
4013     nat low, high;              /* assuming 32 bit ints */
4014     int sign, iexp;
4015     union { double d; int i[2]; } u;    /* assuming 32 bit ints, 64 bit double */
4016
4017     u.d = dbl;      /* grab chunks of the double */
4018     low = u.i[L];
4019     high = u.i[H];
4020
4021     ASSERT(B_BASE == 256);
4022
4023     /* Assume that the supplied B is the right size */
4024     man->size = 8;
4025
4026     if (low == 0 && (high & ~DMSBIT) == 0) {
4027         man->sign = man->used = 0;
4028         *exp = 0L;
4029     } else {
4030         man->used = 8;
4031         man->sign = 1;
4032         iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
4033         sign = high;
4034
4035         high &= DHIGHBIT-1;
4036         if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
4037             high |= DHIGHBIT;
4038         else {
4039             iexp++;
4040             /* A denorm, normalize the mantissa */
4041             while (! (high & DHIGHBIT)) {
4042                 high <<= 1;
4043                 if (low & DMSBIT)
4044                     high++;
4045                 low <<= 1;
4046                 iexp--;
4047             }
4048         }
4049         *exp = (I_) iexp;
4050
4051         man->stuff[7] = (((W_)high) >> 24) & 0xff;
4052         man->stuff[6] = (((W_)high) >> 16) & 0xff;
4053         man->stuff[5] = (((W_)high) >>  8) & 0xff;
4054         man->stuff[4] = (((W_)high)      ) & 0xff;
4055
4056         man->stuff[3] = (((W_)low) >> 24) & 0xff;
4057         man->stuff[2] = (((W_)low) >> 16) & 0xff;
4058         man->stuff[1] = (((W_)low) >>  8) & 0xff;
4059         man->stuff[0] = (((W_)low)      ) & 0xff;
4060
4061         if (sign < 0) man->sign = -1;
4062     }
4063     do_renormalise(man);
4064 }
4065
4066
4067 #if ! FLOATS_AS_DOUBLES
4068 void B__decodeFloat (B* man, I_* exp, StgFloat flt)
4069 {
4070     /* Do some bit fiddling on IEEE */
4071     int high, sign;                 /* assuming 32 bit ints */
4072     union { float f; int i; } u;    /* assuming 32 bit float and int */
4073
4074     u.f = flt;      /* grab the float */
4075     high = u.i;
4076
4077     ASSERT(B_BASE == 256);
4078
4079     /* Assume that the supplied B is the right size */
4080     man->size = 4;
4081
4082     if ((high & ~FMSBIT) == 0) {
4083         man->sign = man->used = 0;
4084         *exp = 0;
4085     } else {
4086         man->used = 4;
4087         man->sign = 1;
4088         *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
4089         sign = high;
4090
4091         high &= FHIGHBIT-1;
4092         if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
4093             high |= FHIGHBIT;
4094         else {
4095             (*exp)++;
4096             /* A denorm, normalize the mantissa */
4097             while (! (high & FHIGHBIT)) {
4098                 high <<= 1;
4099                 (*exp)--;
4100             }
4101         }
4102         man->stuff[3] = (((W_)high) >> 24) & 0xff;
4103         man->stuff[2] = (((W_)high) >> 16) & 0xff;
4104         man->stuff[1] = (((W_)high) >>  8) & 0xff;
4105         man->stuff[0] = (((W_)high)      ) & 0xff;
4106
4107         if (sign < 0) man->sign = -1;
4108     }
4109     do_renormalise(man);
4110 }
4111
4112 #endif  /* FLOATS_AS_DOUBLES */
4113 #endif /* INTERPRETER */