ghc/rts/Evaluator.c

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