ghc/rts/Evaluator.c

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