ghc/rts/Evaluator.c

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