ghc/rts/Evaluator.c

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