ghc/rts/Evaluator.c

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