ghc/rts/Evaluator.c

   1
   2 /* -----------------------------------------------------------------------------
   3  * Bytecode evaluator
   4  *
   5  * Copyright (c) 1994-1998.
   6  *
   7  * $RCSfile: Evaluator.c,v $
   8  * $Revision: 1.36 $
   9  * $Date: 2000/02/29 12:54:51 $
  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("hugsprimUnpackString"));
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            /* A small concession: we need to allow ccalls,
2670               even in combined mode.
2671            */
2672            if (primop2code != i_ccall_ccall_IO &&
2673                primop2code != i_ccall_stdcall_IO)
2674               barf("enterBCO_primop2 in combined mode");
2675         }
2676
2677         switch (primop2code) {
2678         case i_raise:  /* raise#{err} */
2679             {
2680                 StgClosure* err = PopCPtr();
2681                 return (raiseAnError(err));
2682             }
2683
2684         case i_newRef:
2685             {
2686                 StgClosure* init = PopCPtr();
2687                 StgMutVar* mv
2688                     = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
2689                 SET_HDR(mv,&MUT_VAR_info,CCCS);
2690                 mv->var = init;
2691                 PushPtr(stgCast(StgPtr,mv));
2692                 break;
2693             }
2694         case i_readRef:
2695             {
2696                 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2697                 PushCPtr(mv->var);
2698                 break;
2699             }
2700         case i_writeRef:
2701             {
2702                 StgMutVar*  mv    = stgCast(StgMutVar*,PopPtr());
2703                 StgClosure* value = PopCPtr();
2704                 mv->var = value;
2705                 break;
2706             }
2707         case i_newArray:
2708             {
2709                 nat         n    = PopTaggedInt(); /* or Word?? */
2710                 StgClosure* init = PopCPtr();
2711                 StgWord     size = sizeofW(StgMutArrPtrs) + n;
2712                 nat i;
2713                 StgMutArrPtrs* arr
2714                     = stgCast(StgMutArrPtrs*,allocate(size));
2715                 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
2716                 arr->ptrs = n;
2717                 for (i = 0; i < n; ++i) {
2718                     arr->payload[i] = init;
2719                 }
2720                 PushPtr(stgCast(StgPtr,arr));
2721                 break;
2722             }
2723         case i_readArray:
2724         case i_indexArray:
2725             {
2726                 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2727                 nat         i   = PopTaggedInt(); /* or Word?? */
2728                 StgWord     n   = arr->ptrs;
2729                 if (i >= n) {
2730                     return (raiseIndex("{index,read}Array"));
2731                 }
2732                 PushCPtr(arr->payload[i]);
2733                 break;
2734             }
2735         case i_writeArray:
2736             {
2737                 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2738                 nat         i   = PopTaggedInt(); /* or Word? */
2739                 StgClosure* v   = PopCPtr();
2740                 StgWord     n   = arr->ptrs;
2741                 if (i >= n) {
2742                     return (raiseIndex("{index,read}Array"));
2743                 }
2744                 arr->payload[i] = v;
2745                 break;
2746             }
2747         case i_sizeArray:
2748         case i_sizeMutableArray:
2749             {
2750                 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2751                 PushTaggedInt(arr->ptrs);
2752                 break;
2753             }
2754         case i_unsafeFreezeArray:
2755             {
2756                 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2757                 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
2758                 PushPtr(stgCast(StgPtr,arr));
2759                 break;
2760             }
2761         case i_unsafeFreezeByteArray:
2762             {
2763                 /* Delightfully simple :-) */
2764                 break;
2765             }
2766         case i_sameRef:
2767         case i_sameMutableArray:
2768         case i_sameMutableByteArray:
2769             {
2770                 StgPtr x = PopPtr();
2771                 StgPtr y = PopPtr();
2772                 PushTaggedBool(x==y);
2773                 break;
2774             }
2775
2776         case i_newByteArray:
2777             {
2778                 nat     n     = PopTaggedInt(); /* or Word?? */
2779                 StgInt  words = (n+sizeof(W_)-1)/sizeof(W_);
2780                 StgWord size  = sizeofW(StgArrWords) + words;
2781                 StgArrWords* arr  = stgCast(StgArrWords*,allocate(size));
2782                 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2783                 arr->words = words;
2784 #ifdef DEBUG
2785                {nat i;
2786                for (i = 0; i < n; ++i) {
2787                     arr->payload[i] = 0xdeadbeef;
2788                }}
2789 #endif
2790                 PushPtr(stgCast(StgPtr,arr));
2791                 break;
2792             }
2793
2794         /* Most of these generate alignment warnings on Sparcs and similar architectures.
2795          * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
2796          */
2797         case i_indexCharArray:
2798             OP_mI_ty(Char,"indexCharArray",    indexCharArrayzh(r,x,i)); break;
2799         case i_readCharArray:
2800             OP_mI_ty(Char,"readCharArray",     readCharArrayzh(r,x,i));  break;
2801         case i_writeCharArray:
2802             OP_mIty_(Char,"writeCharArray",    writeCharArrayzh(x,i,z)); break;
2803
2804         case i_indexIntArray:
2805             OP_mI_ty(Int,"indexIntArray",      indexIntArrayzh(r,x,i)); break;
2806         case i_readIntArray:
2807             OP_mI_ty(Int,"readIntArray",       readIntArrayzh(r,x,i));  break;
2808         case i_writeIntArray:
2809             OP_mIty_(Int,"writeIntArray",      writeIntArrayzh(x,i,z)); break;
2810
2811         case i_indexAddrArray:
2812             OP_mI_ty(Addr,"indexAddrArray",   indexAddrArrayzh(r,x,i)); break;
2813         case i_readAddrArray:
2814             OP_mI_ty(Addr,"readAddrArray",    readAddrArrayzh(r,x,i));  break;
2815         case i_writeAddrArray:
2816             OP_mIty_(Addr,"writeAddrArray",   writeAddrArrayzh(x,i,z)); break;
2817
2818         case i_indexFloatArray:
2819             OP_mI_ty(Float,"indexFloatArray",  indexFloatArrayzh(r,x,i)); break;
2820         case i_readFloatArray:
2821             OP_mI_ty(Float,"readFloatArray",   readFloatArrayzh(r,x,i));  break;
2822         case i_writeFloatArray:
2823             OP_mIty_(Float,"writeFloatArray",  writeFloatArrayzh(x,i,z)); break;
2824
2825         case i_indexDoubleArray:
2826             OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break;
2827         case i_readDoubleArray:
2828             OP_mI_ty(Double,"readDoubleArray",  readDoubleArrayzh(r,x,i));  break;
2829         case i_writeDoubleArray:
2830             OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break;
2831
2832 #if 0
2833 #ifdef PROVIDE_STABLE
2834         case i_indexStableArray:
2835             OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break;
2836         case i_readStableArray:
2837             OP_mI_ty(StablePtr,"readStableArray",  readStablePtrArrayzh(r,x,i));  break;
2838         case i_writeStableArray:
2839             OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
2840 #endif
2841 #endif
2842
2843
2844
2845 #ifdef PROVIDE_COERCE
2846         case i_unsafeCoerce:
2847             {
2848                 /* Another nullop */
2849                 break;
2850             }
2851 #endif
2852 #ifdef PROVIDE_PTREQUALITY
2853         case i_reallyUnsafePtrEquality:
2854             { /* identical to i_sameRef */
2855                 StgPtr x = PopPtr();
2856                 StgPtr y = PopPtr();
2857                 PushTaggedBool(x==y);
2858                 break;
2859             }
2860 #endif
2861 #ifdef PROVIDE_FOREIGN
2862                 /* ForeignObj# operations */
2863         case i_makeForeignObj:
2864             {
2865                 StgForeignObj *result
2866                     = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
2867                 SET_HDR(result,&FOREIGN_info,CCCS);
2868                 result -> data      = PopTaggedAddr();
2869                 PushPtr(stgCast(StgPtr,result));
2870                 break;
2871             }
2872 #endif /* PROVIDE_FOREIGN */
2873 #ifdef PROVIDE_WEAK
2874         case i_makeWeak:
2875             {
2876                 StgWeak *w
2877                     = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
2878                 SET_HDR(w, &WEAK_info, CCCS);
2879                 w->key        = PopCPtr();
2880                 w->value      = PopCPtr();
2881                 w->finaliser  = PopCPtr();
2882                 w->link       = weak_ptr_list;
2883                 weak_ptr_list = w;
2884                 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
2885                 PushPtr(stgCast(StgPtr,w));
2886                 break;
2887             }
2888         case i_deRefWeak:
2889             {
2890                 StgWeak *w = stgCast(StgWeak*,PopPtr());
2891                 if (w->header.info == &WEAK_info) {
2892                     PushCPtr(w->value); /* last result  */
2893                     PushTaggedInt(1);   /* first result */
2894                 } else {
2895                     PushPtr(stgCast(StgPtr,w));
2896                            /* ToDo: error thunk would be better */
2897                     PushTaggedInt(0);
2898                 }
2899                 break;
2900             }
2901 #endif /* PROVIDE_WEAK */
2902
2903         case i_makeStablePtr:
2904             {
2905                 StgPtr       p  = PopPtr();
2906                 StgStablePtr sp = getStablePtr ( p );
2907                 PushTaggedStablePtr(sp);
2908                 break;
2909             }
2910         case i_deRefStablePtr:
2911             {
2912                 StgPtr p;
2913                 StgStablePtr sp = PopTaggedStablePtr();
2914                 p = deRefStablePtr(sp);
2915                 PushPtr(p);
2916                 break;
2917             }
2918         case i_freeStablePtr:
2919             {
2920                 StgStablePtr sp = PopTaggedStablePtr();
2921                 freeStablePtr(sp);
2922                 break;
2923             }
2924
2925         case i_createAdjThunkARCH:
2926             {
2927                 StgStablePtr stableptr = PopTaggedStablePtr();
2928                 StgAddr      typestr   = PopTaggedAddr();
2929                 StgChar      callconv  = PopTaggedChar();
2930                 StgAddr      adj_thunk = createAdjThunk(stableptr,typestr,callconv);
2931                 PushTaggedAddr(adj_thunk);
2932                 break;
2933             }
2934
2935         case i_getArgc:
2936             {
2937                 StgInt n = prog_argc;
2938                 PushTaggedInt(n);
2939                 break;
2940             }
2941         case i_getArgv:
2942             {
2943                 StgInt  n = PopTaggedInt();
2944                 StgAddr a = (StgAddr)prog_argv[n];
2945                 PushTaggedAddr(a);
2946                 break;
2947             }
2948
2949         case i_newMVar:
2950             {
2951                 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
2952                 SET_INFO(mvar,&EMPTY_MVAR_info);
2953                 mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
2954                 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
2955                 PushPtr(stgCast(StgPtr,mvar));
2956                 break;
2957             }
2958         case i_takeMVar:
2959             {
2960                 StgMVar *mvar = (StgMVar*)PopCPtr();
2961                 if (GET_INFO(mvar) == &EMPTY_MVAR_info) {
2962
2963                     /* The MVar is empty.  Attach ourselves to the TSO's
2964                        blocking queue.
2965                     */
2966                     if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
2967                         mvar->head = cap->rCurrentTSO;
2968                     } else {
2969                         mvar->tail->link = cap->rCurrentTSO;
2970                     }
2971                     cap->rCurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
2972                     cap->rCurrentTSO->why_blocked = BlockedOnMVar;
2973                     cap->rCurrentTSO->block_info.closure = (StgClosure *)mvar;
2974                     mvar->tail = cap->rCurrentTSO;
2975
2976                     /* At this point, the top-of-stack holds the MVar,
2977                        and underneath is the world token ().  So the
2978                        stack is in the same state as when primTakeMVar
2979                        was entered (primTakeMVar is handwritten bytecode).
2980                        Push obj, which is this BCO, and return to the
2981                        scheduler.  When the MVar is filled, the scheduler
2982                        will re-enter primTakeMVar, with the args still on
2983                        the top of the stack.
2984                     */
2985                     PushCPtr((StgClosure*)(*bco));
2986                     *return2 = ThreadBlocked;
2987                     return (void*)(1+(NULL));
2988
2989                 } else {
2990                     PushCPtr(mvar->value);
2991                     mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
2992                     SET_INFO(mvar,&EMPTY_MVAR_info);
2993                 }
2994                 break;
2995             }
2996         case i_putMVar:
2997             {
2998                 StgMVar*    mvar  = stgCast(StgMVar*,PopPtr());
2999                 StgClosure* value = PopCPtr();
3000                 if (GET_INFO(mvar) == &FULL_MVAR_info) {
3001                     return (makeErrorCall("putMVar {full MVar}"));
3002                 } else {
3003                     /* wake up the first thread on the
3004                      * queue, it will continue with the
3005                      * takeMVar operation and mark the
3006                      * MVar empty again.
3007                      */
3008                     mvar->value = value;
3009
3010                     if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
3011                        ASSERT(mvar->head->why_blocked == BlockedOnMVar);
3012                        mvar->head = unblockOne(mvar->head);
3013                        if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
3014                           mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
3015                        }
3016                     }
3017
3018                     /* unlocks the MVar in the SMP case */
3019                     SET_INFO(mvar,&FULL_MVAR_info);
3020
3021                     /* yield for better communication performance */
3022                     context_switch = 1;
3023                 }
3024                 break;
3025             }
3026         case i_sameMVar:
3027             {   /* identical to i_sameRef */
3028                 StgMVar* x = (StgMVar*)PopPtr();
3029                 StgMVar* y = (StgMVar*)PopPtr();
3030                 PushTaggedBool(x==y);
3031                 break;
3032             }
3033         case i_getThreadId:
3034             {
3035                 StgWord tid = cap->rCurrentTSO->id;
3036                 PushTaggedWord(tid);
3037                 break;
3038             }
3039         case i_cmpThreadIds:
3040             {
3041                 StgWord tid1 = PopTaggedWord();
3042                 StgWord tid2 = PopTaggedWord();
3043                 if (tid1 < tid2) PushTaggedInt(-1);
3044                 else if (tid1 > tid2) PushTaggedInt(1);
3045                 else PushTaggedInt(0);
3046                 break;
3047             }
3048         case i_forkIO:
3049             {
3050                 StgClosure* closure;
3051                 StgTSO*     tso;
3052                 StgWord     tid;
3053                 closure = PopCPtr();
3054                 tso     = createGenThread (RtsFlags.GcFlags.initialStkSize,closure);
3055                 tid     = tso->id;
3056                 scheduleThread(tso);
3057                 context_switch = 1;
3058                 PushTaggedWord(tid);
3059                 break;
3060             }
3061
3062 #ifdef PROVIDE_CONCURRENT
3063         case i_killThread:
3064             {
3065                 StgTSO* tso = stgCast(StgTSO*,PopPtr());
3066                 deleteThread(tso);
3067                 if (tso == cap->rCurrentTSO) { /* suicide */
3068                     *return2 = ThreadFinished;
3069                     return (void*)(1+(NULL));
3070                 }
3071                 break;
3072             }
3073
3074 #if 1
3075 #if 0
3076 ToDo: another way out of the problem might be to add an explicit
3077 continuation to primTakeMVar: takeMVar v = primTakeMVar v takeMVar.
3078 The problem with this plan is that now I dont know how much to chop
3079 off the stack.
3080 #endif
3081 #endif
3082         case i_delay:
3083         case i_waitRead:
3084         case i_waitWrite:
3085                 /* As PrimOps.h says: Hmm, I'll think about these later. */
3086                 ASSERT(0);
3087                 break;
3088 #endif /* PROVIDE_CONCURRENT */
3089
3090         case i_ccall_ccall_Id:
3091         case i_ccall_ccall_IO:
3092         case i_ccall_stdcall_Id:
3093         case i_ccall_stdcall_IO:
3094             {
3095                 int r;
3096                 CFunDescriptor* descriptor;
3097                 void (*funPtr)(void);
3098                 char cc;
3099                 descriptor = PopTaggedAddr();
3100                 funPtr     = PopTaggedAddr();
3101                  cc = (primop2code == i_ccall_stdcall_Id ||
3102                            primop2code == i_ccall_stdcall_IO)
3103                           ? 's' : 'c';
3104                 r = ccall(descriptor,funPtr,bco,cc,cap);
3105                 if (r == 0) break;
3106                 if (r == 1)
3107                    return makeErrorCall(
3108                       "unhandled type or too many args/results in ccall");
3109                 if (r == 2)
3110                    barf("ccall not configured correctly for this platform");
3111                 barf("unknown return code from ccall");
3112             }
3113         default:
3114                 barf("Unrecognised primop2");
3115    }
3116    return NULL;
3117 }
3118
3119
3120 /* -----------------------------------------------------------------------------
3121  * ccall support code:
3122  *   marshall moves args from C stack to Haskell stack
3123  *   unmarshall moves args from Haskell stack to C stack
3124  *   argSize calculates how much gSpace you need on the C stack
3125  * ---------------------------------------------------------------------------*/
3126
3127 /* Pop arguments off the C stack and Push them onto the Hugs stack.
3128  * Used when preparing for C calling Haskell or in regSponse to
3129  *  Haskell calling C.
3130  */
3131 nat marshall(char arg_ty, void* arg)
3132 {
3133     switch (arg_ty) {
3134     case INT_REP:
3135             PushTaggedInt(*((int*)arg));
3136             return ARG_SIZE(INT_TAG);
3137 #ifdef TODO_STANDALONE_INTEGER
3138     case INTEGER_REP:
3139             PushTaggedInteger(*((mpz_ptr*)arg));
3140             return ARG_SIZE(INTEGER_TAG);
3141 #endif
3142     case WORD_REP:
3143             PushTaggedWord(*((unsigned int*)arg));
3144             return ARG_SIZE(WORD_TAG);
3145     case CHAR_REP:
3146             PushTaggedChar(*((char*)arg));
3147             return ARG_SIZE(CHAR_TAG);
3148     case FLOAT_REP:
3149             PushTaggedFloat(*((float*)arg));
3150             return ARG_SIZE(FLOAT_TAG);
3151     case DOUBLE_REP:
3152             PushTaggedDouble(*((double*)arg));
3153             return ARG_SIZE(DOUBLE_TAG);
3154     case ADDR_REP:
3155             PushTaggedAddr(*((void**)arg));
3156             return ARG_SIZE(ADDR_TAG);
3157     case STABLE_REP:
3158             PushTaggedStablePtr(*((StgStablePtr*)arg));
3159             return ARG_SIZE(STABLE_TAG);
3160 #ifdef PROVIDE_FOREIGN
3161     case FOREIGN_REP:
3162             /* Not allowed in this direction - you have to
3163              * call makeForeignPtr explicitly
3164              */
3165             barf("marshall: ForeignPtr#\n");
3166             break;
3167 #endif
3168     case BARR_REP:
3169     case MUTBARR_REP:
3170             /* Not allowed in this direction  */
3171             barf("marshall: [Mutable]ByteArray#\n");
3172             break;
3173     default:
3174             barf("marshall: unrecognised arg type %d\n",arg_ty);
3175             break;
3176     }
3177 }
3178
3179 /* Pop arguments off the Hugs stack and Push them onto the C stack.
3180  * Used when preparing for Haskell calling C or in regSponse to
3181  * C calling Haskell.
3182  */
3183 nat unmarshall(char res_ty, void* res)
3184 {
3185     switch (res_ty) {
3186     case INT_REP:
3187             *((int*)res) = PopTaggedInt();
3188             return ARG_SIZE(INT_TAG);
3189 #ifdef TODO_STANDALONE_INTEGER
3190     case INTEGER_REP:
3191             *((mpz_ptr*)res) = PopTaggedInteger();
3192             return ARG_SIZE(INTEGER_TAG);
3193 #endif
3194     case WORD_REP:
3195             *((unsigned int*)res) = PopTaggedWord();
3196             return ARG_SIZE(WORD_TAG);
3197     case CHAR_REP:
3198             *((int*)res) = PopTaggedChar();
3199             return ARG_SIZE(CHAR_TAG);
3200     case FLOAT_REP:
3201             *((float*)res) = PopTaggedFloat();
3202             return ARG_SIZE(FLOAT_TAG);
3203     case DOUBLE_REP:
3204             *((double*)res) = PopTaggedDouble();
3205             return ARG_SIZE(DOUBLE_TAG);
3206     case ADDR_REP:
3207             *((void**)res) = PopTaggedAddr();
3208             return ARG_SIZE(ADDR_TAG);
3209     case STABLE_REP:
3210             *((StgStablePtr*)res) = PopTaggedStablePtr();
3211             return ARG_SIZE(STABLE_TAG);
3212 #ifdef PROVIDE_FOREIGN
3213     case FOREIGN_REP:
3214         {
3215             StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
3216             *((void**)res) = result->data;
3217             return sizeofW(StgPtr);
3218         }
3219 #endif
3220     case BARR_REP:
3221     case MUTBARR_REP:
3222         {
3223             StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3224             *((void**)res) = stgCast(void*,&(arr->payload));
3225             return sizeofW(StgPtr);
3226         }
3227     default:
3228             barf("unmarshall: unrecognised result type %d\n",res_ty);
3229     }
3230 }
3231
3232 nat argSize( const char* ks )
3233 {
3234     nat sz = 0;
3235     for( ; *ks != '\0'; ++ks) {
3236         switch (*ks) {
3237         case INT_REP:
3238                 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
3239                 break;
3240 #ifdef TODO_STANDALONE_INTEGER
3241         case INTEGER_REP:
3242                 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
3243                 break;
3244 #endif
3245         case WORD_REP:
3246                 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
3247                 break;
3248         case CHAR_REP:
3249                 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
3250                 break;
3251         case FLOAT_REP:
3252                 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
3253                 break;
3254         case DOUBLE_REP:
3255                 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
3256                 break;
3257         case ADDR_REP:
3258                 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
3259                 break;
3260         case STABLE_REP:
3261                 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
3262                 break;
3263 #ifdef PROVIDE_FOREIGN
3264         case FOREIGN_REP:
3265 #endif
3266         case BARR_REP:
3267         case MUTBARR_REP:
3268                 sz += sizeof(StgPtr);
3269                 break;
3270         default:
3271                 barf("argSize: unrecognised result type %d\n",*ks);
3272                 break;
3273         }
3274     }
3275     return sz;
3276 }
3277
3278
3279 /* -----------------------------------------------------------------------------
3280  * encode/decode Float/Double code for standalone Hugs
3281  * Code based on the HBC code (lib/fltcode.c) and more recently GHC
3282  * (ghc/rts/StgPrimFloat.c)
3283  * ---------------------------------------------------------------------------*/
3284
3285 #ifdef STANDALONE_INTEGER
3286
3287 #if IEEE_FLOATING_POINT
3288 #define MY_DMINEXP  ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
3289 /* DMINEXP is defined in values.h on Linux (for example) */
3290 #define DHIGHBIT 0x00100000
3291 #define DMSBIT   0x80000000
3292
3293 #define MY_FMINEXP  ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
3294 #define FHIGHBIT 0x00800000
3295 #define FMSBIT   0x80000000
3296 #else
3297 #error The following code doesnt work in a non-IEEE FP environment
3298 #endif
3299
3300 #ifdef WORDS_BIGENDIAN
3301 #define L 1
3302 #define H 0
3303 #else
3304 #define L 0
3305 #define H 1
3306 #endif
3307
3308
3309 StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */
3310 {
3311     StgDouble r;
3312     I_ i;
3313
3314     /* Convert a B to a double; knows a lot about internal rep! */
3315     for(r = 0.0, i = s->used-1; i >= 0; i--)
3316         r = (r * B_BASE_FLT) + s->stuff[i];
3317
3318     /* Now raise to the exponent */
3319     if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3320         r = ldexp(r, e);
3321
3322     /* handle the sign */
3323     if (s->sign < 0) r = -r;
3324
3325     return r;
3326 }
3327
3328
3329
3330 #if ! FLOATS_AS_DOUBLES
3331 StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */
3332 {
3333     StgFloat r;
3334     I_ i;
3335
3336     /* Convert a B to a float; knows a lot about internal rep! */
3337     for(r = 0.0, i = s->used-1; i >= 0; i--)
3338         r = (r * B_BASE_FLT) + s->stuff[i];
3339
3340     /* Now raise to the exponent */
3341     if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3342         r = ldexp(r, e);
3343
3344     /* handle the sign */
3345     if (s->sign < 0) r = -r;
3346
3347     return r;
3348 }
3349 #endif  /* FLOATS_AS_DOUBLES */
3350
3351
3352
3353 /* This only supports IEEE floating point */
3354 void B__decodeDouble (B* man, I_* exp, StgDouble dbl)
3355 {
3356     /* Do some bit fiddling on IEEE */
3357     nat low, high;              /* assuming 32 bit ints */
3358     int sign, iexp;
3359     union { double d; int i[2]; } u;    /* assuming 32 bit ints, 64 bit double */
3360
3361     u.d = dbl;      /* grab chunks of the double */
3362     low = u.i[L];
3363     high = u.i[H];
3364
3365     ASSERT(B_BASE == 256);
3366
3367     /* Assume that the supplied B is the right size */
3368     man->size = 8;
3369
3370     if (low == 0 && (high & ~DMSBIT) == 0) {
3371         man->sign = man->used = 0;
3372         *exp = 0L;
3373     } else {
3374         man->used = 8;
3375         man->sign = 1;
3376         iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
3377         sign = high;
3378
3379         high &= DHIGHBIT-1;
3380         if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
3381             high |= DHIGHBIT;
3382         else {
3383             iexp++;
3384             /* A denorm, normalize the mantissa */
3385             while (! (high & DHIGHBIT)) {
3386                 high <<= 1;
3387                 if (low & DMSBIT)
3388                     high++;
3389                 low <<= 1;
3390                 iexp--;
3391             }
3392         }
3393         *exp = (I_) iexp;
3394
3395         man->stuff[7] = (((W_)high) >> 24) & 0xff;
3396         man->stuff[6] = (((W_)high) >> 16) & 0xff;
3397         man->stuff[5] = (((W_)high) >>  8) & 0xff;
3398         man->stuff[4] = (((W_)high)      ) & 0xff;
3399
3400         man->stuff[3] = (((W_)low) >> 24) & 0xff;
3401         man->stuff[2] = (((W_)low) >> 16) & 0xff;
3402         man->stuff[1] = (((W_)low) >>  8) & 0xff;
3403         man->stuff[0] = (((W_)low)      ) & 0xff;
3404
3405         if (sign < 0) man->sign = -1;
3406     }
3407     do_renormalise(man);
3408 }
3409
3410
3411 #if ! FLOATS_AS_DOUBLES
3412 void B__decodeFloat (B* man, I_* exp, StgFloat flt)
3413 {
3414     /* Do some bit fiddling on IEEE */
3415     int high, sign;                 /* assuming 32 bit ints */
3416     union { float f; int i; } u;    /* assuming 32 bit float and int */
3417
3418     u.f = flt;      /* grab the float */
3419     high = u.i;
3420
3421     ASSERT(B_BASE == 256);
3422
3423     /* Assume that the supplied B is the right size */
3424     man->size = 4;
3425
3426     if ((high & ~FMSBIT) == 0) {
3427         man->sign = man->used = 0;
3428         *exp = 0;
3429     } else {
3430         man->used = 4;
3431         man->sign = 1;
3432         *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
3433         sign = high;
3434
3435         high &= FHIGHBIT-1;
3436         if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
3437             high |= FHIGHBIT;
3438         else {
3439             (*exp)++;
3440             /* A denorm, normalize the mantissa */
3441             while (! (high & FHIGHBIT)) {
3442                 high <<= 1;
3443                 (*exp)--;
3444             }
3445         }
3446         man->stuff[3] = (((W_)high) >> 24) & 0xff;
3447         man->stuff[2] = (((W_)high) >> 16) & 0xff;
3448         man->stuff[1] = (((W_)high) >>  8) & 0xff;
3449         man->stuff[0] = (((W_)high)      ) & 0xff;
3450
3451         if (sign < 0) man->sign = -1;
3452     }
3453     do_renormalise(man);
3454 }
3455
3456 #endif  /* FLOATS_AS_DOUBLES */
3457
3458 #endif /* STANDALONE_INTEGER */
3459
3460 #endif /* INTERPRETER */