ghc/rts/Evaluator.c

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