ghc/rts/Evaluator.c

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