ghc/rts/Evaluator.c

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