ghc/rts/Evaluator.c

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