ghc/rts/Evaluator.c

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