ghc/rts/Evaluator.c

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