ghc/rts/Evaluator.c

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