ghc/rts/Evaluator.c

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