ghc/rts/Evaluator.c

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