ghc/rts/Evaluator.c

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