ghc/rts/Evaluator.c

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