ghc/rts/Evaluator.c

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