ghc/rts/Evaluator.c

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