ghc/rts/Evaluator.c

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