ghc/rts/Evaluator.c

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