ghc/rts/Evaluator.c

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