ghc/rts/Evaluator.c

   1
   2 /* -----------------------------------------------------------------------------
   3  * Bytecode evaluator
   4  *
   5  * Copyright (c) 1994-1998.
   6  *
   7  * $RCSfile: Evaluator.c,v $
   8  * $Revision: 1.51 $
   9  * $Date: 2000/05/09 10:00:36 $
  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) = (W_)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 = (W_)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    { StgStablePtr 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 __attribute__ ((unused))
2270 static void myStackCheck ( Capability* cap )
2271 {
2272    /* fprintf(stderr, "myStackCheck\n"); */
2273    if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) {
2274       fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" );
2275       assert(0);
2276    }
2277    while (1) {
2278       if (!( (P_)gSu >= (P_)cap->rCurrentTSO->stack
2279               &&
2280               (P_)gSu <= (P_)(cap->rCurrentTSO->stack
2281                               + cap->rCurrentTSO->stack_size))) {
2282          fprintf ( stderr, "myStackCheck: gSu out of stack\n" );
2283          assert(0);
2284       }
2285       switch (get_itbl(stgCast(StgClosure*,gSu))->type) {
2286       case CATCH_FRAME:
2287          gSu = (StgUpdateFrame*) ((StgCatchFrame*)(gSu))->link;
2288          break;
2289       case UPDATE_FRAME:
2290          gSu = (StgUpdateFrame*) ((StgUpdateFrame*)(gSu))->link;
2291          break;
2292       case SEQ_FRAME:
2293          gSu = (StgUpdateFrame*) ((StgSeqFrame*)(gSu))->link;
2294          break;
2295       case STOP_FRAME:
2296          goto postloop;
2297       default:
2298          fprintf(stderr, "myStackCheck: invalid activation record\n"); assert(0);
2299       }
2300    }
2301    postloop:
2302 }
2303
2304
2305 /* --------------------------------------------------------------------------
2306  * Primop stuff for bytecode interpreter
2307  * ------------------------------------------------------------------------*/
2308
2309 /* Returns & of the next thing to enter (if throwing an exception),
2310    or NULL in the normal case.
2311 */
2312 static void* enterBCO_primop1 ( int primop1code )
2313 {
2314     if (combined)
2315        barf("enterBCO_primop1 in combined mode");
2316
2317     switch (primop1code) {
2318         case i_pushseqframe:
2319             {
2320                StgClosure* c = PopCPtr();
2321                PushSeqFrame();
2322                PushCPtr(c);
2323                break;
2324             }
2325         case i_pushcatchframe:
2326             {
2327                StgClosure* e = PopCPtr();
2328                StgClosure* h = PopCPtr();
2329                PushCatchFrame(h);
2330                PushCPtr(e);
2331                break;
2332             }
2333
2334         case i_gtChar:          OP_CC_B(x>y);        break;
2335         case i_geChar:          OP_CC_B(x>=y);       break;
2336         case i_eqChar:          OP_CC_B(x==y);       break;
2337         case i_neChar:          OP_CC_B(x!=y);       break;
2338         case i_ltChar:          OP_CC_B(x<y);        break;
2339         case i_leChar:          OP_CC_B(x<=y);       break;
2340         case i_charToInt:       OP_C_I(x);           break;
2341         case i_intToChar:       OP_I_C(x);           break;
2342
2343         case i_gtInt:           OP_II_B(x>y);        break;
2344         case i_geInt:           OP_II_B(x>=y);       break;
2345         case i_eqInt:           OP_II_B(x==y);       break;
2346         case i_neInt:           OP_II_B(x!=y);       break;
2347         case i_ltInt:           OP_II_B(x<y);        break;
2348         case i_leInt:           OP_II_B(x<=y);       break;
2349         case i_minInt:          OP__I(INT_MIN);      break;
2350         case i_maxInt:          OP__I(INT_MAX);      break;
2351         case i_plusInt:         OP_II_I(x+y);        break;
2352         case i_minusInt:        OP_II_I(x-y);        break;
2353         case i_timesInt:        OP_II_I(x*y);        break;
2354         case i_quotInt:
2355             {
2356                 int x = PopTaggedInt();
2357                 int y = PopTaggedInt();
2358                 if (y == 0) {
2359                     return (raiseDiv0("quotInt"));
2360                 }
2361                 /* ToDo: protect against minInt / -1 errors
2362                  * (repeat for all other division primops) */
2363                 PushTaggedInt(x/y);
2364             }
2365             break;
2366         case i_remInt:
2367             {
2368                 int x = PopTaggedInt();
2369                 int y = PopTaggedInt();
2370                 if (y == 0) {
2371                     return (raiseDiv0("remInt"));
2372                 }
2373                 PushTaggedInt(x%y);
2374             }
2375             break;
2376         case i_quotRemInt:
2377             {
2378                 StgInt x = PopTaggedInt();
2379                 StgInt y = PopTaggedInt();
2380                 if (y == 0) {
2381                     return (raiseDiv0("quotRemInt"));
2382                 }
2383                 PushTaggedInt(x%y); /* last result  */
2384                 PushTaggedInt(x/y); /* first result */
2385             }
2386             break;
2387         case i_negateInt:       OP_I_I(-x);          break;
2388
2389         case i_andInt:          OP_II_I(x&y);        break;
2390         case i_orInt:           OP_II_I(x|y);        break;
2391         case i_xorInt:          OP_II_I(x^y);        break;
2392         case i_notInt:          OP_I_I(~x);          break;
2393         case i_shiftLInt:       OP_II_I(x<<y);       break;
2394         case i_shiftRAInt:      OP_II_I(x>>y);       break; /* ToDo */
2395         case i_shiftRLInt:      OP_II_I(x>>y);       break; /* ToDo */
2396
2397         case i_gtWord:          OP_WW_B(x>y);        break;
2398         case i_geWord:          OP_WW_B(x>=y);       break;
2399         case i_eqWord:          OP_WW_B(x==y);       break;
2400         case i_neWord:          OP_WW_B(x!=y);       break;
2401         case i_ltWord:          OP_WW_B(x<y);        break;
2402         case i_leWord:          OP_WW_B(x<=y);       break;
2403         case i_minWord:         OP__W(0);            break;
2404         case i_maxWord:         OP__W(UINT_MAX);     break;
2405         case i_plusWord:        OP_WW_W(x+y);        break;
2406         case i_minusWord:       OP_WW_W(x-y);        break;
2407         case i_timesWord:       OP_WW_W(x*y);        break;
2408         case i_quotWord:
2409             {
2410                 StgWord x = PopTaggedWord();
2411                 StgWord y = PopTaggedWord();
2412                 if (y == 0) {
2413                     return (raiseDiv0("quotWord"));
2414                 }
2415                 PushTaggedWord(x/y);
2416             }
2417             break;
2418         case i_remWord:
2419             {
2420                 StgWord x = PopTaggedWord();
2421                 StgWord y = PopTaggedWord();
2422                 if (y == 0) {
2423                     return (raiseDiv0("remWord"));
2424                 }
2425                 PushTaggedWord(x%y);
2426             }
2427             break;
2428         case i_quotRemWord:
2429             {
2430                 StgWord x = PopTaggedWord();
2431                 StgWord y = PopTaggedWord();
2432                 if (y == 0) {
2433                     return (raiseDiv0("quotRemWord"));
2434                 }
2435                 PushTaggedWord(x%y); /* last result  */
2436                 PushTaggedWord(x/y); /* first result */
2437             }
2438             break;
2439         case i_negateWord:      OP_W_W(-x);         break;
2440         case i_andWord:         OP_WW_W(x&y);        break;
2441         case i_orWord:          OP_WW_W(x|y);        break;
2442         case i_xorWord:         OP_WW_W(x^y);        break;
2443         case i_notWord:         OP_W_W(~x);          break;
2444         case i_shiftLWord:      OP_WW_W(x<<y);       break;
2445         case i_shiftRAWord:     OP_WW_W(x>>y);       break; /* ToDo */
2446         case i_shiftRLWord:     OP_WW_W(x>>y);       break; /* ToDo */
2447         case i_intToWord:       OP_I_W(x);           break;
2448         case i_wordToInt:       OP_W_I(x);           break;
2449
2450         case i_gtAddr:          OP_AA_B(x>y);        break;
2451         case i_geAddr:          OP_AA_B(x>=y);       break;
2452         case i_eqAddr:          OP_AA_B(x==y);       break;
2453         case i_neAddr:          OP_AA_B(x!=y);       break;
2454         case i_ltAddr:          OP_AA_B(x<y);        break;
2455         case i_leAddr:          OP_AA_B(x<=y);       break;
2456         case i_intToAddr:       OP_I_A((StgAddr)x);  break;  /*  ToDo */
2457         case i_addrToInt:       OP_A_I((StgInt)x);   break;  /* ToDo */
2458
2459         case i_intToStable:     OP_I_s((StgStablePtr)x); break;
2460         case i_stableToInt:     OP_s_I((W_)x);           break;
2461
2462         case i_indexCharOffAddr:   OP_AI_C(indexCharOffAddrzh(r,x,y));      break;
2463         case i_readCharOffAddr:    OP_AI_C(indexCharOffAddrzh(r,x,y));      break;
2464         case i_writeCharOffAddr:   OP_AIC_(writeCharOffAddrzh(x,y,z));      break;
2465
2466         case i_indexIntOffAddr:    OP_AI_I(indexIntOffAddrzh(r,x,y));       break;
2467         case i_readIntOffAddr:     OP_AI_I(indexIntOffAddrzh(r,x,y));       break;
2468         case i_writeIntOffAddr:    OP_AII_(writeIntOffAddrzh(x,y,z));       break;
2469
2470         case i_indexAddrOffAddr:   OP_AI_A(indexAddrOffAddrzh(r,x,y));      break;
2471         case i_readAddrOffAddr:    OP_AI_A(indexAddrOffAddrzh(r,x,y));      break;
2472         case i_writeAddrOffAddr:   OP_AIA_(writeAddrOffAddrzh(x,y,z));      break;
2473
2474         case i_indexFloatOffAddr:  OP_AI_F(indexFloatOffAddrzh(r,x,y));     break;
2475         case i_readFloatOffAddr:   OP_AI_F(indexFloatOffAddrzh(r,x,y));     break;
2476         case i_writeFloatOffAddr:  OP_AIF_(writeFloatOffAddrzh(x,y,z));     break;
2477
2478         case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y));    break;
2479         case i_readDoubleOffAddr:  OP_AI_D(indexDoubleOffAddrzh(r,x,y));    break;
2480         case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z));    break;
2481
2482         case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2483         case i_readStableOffAddr:  OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2484         case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
2485
2486         case i_compareInteger:
2487             {
2488                 B* x = IntegerInsideByteArray(PopPtr());
2489                 B* y = IntegerInsideByteArray(PopPtr());
2490                 StgInt r = do_cmp(x,y);
2491                 PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
2492             }
2493             break;
2494         case i_negateInteger:      OP_Z_Z(neg);     break;
2495         case i_plusInteger:        OP_ZZ_Z(add);    break;
2496         case i_minusInteger:       OP_ZZ_Z(sub);    break;
2497         case i_timesInteger:       OP_ZZ_Z(mul);    break;
2498         case i_quotRemInteger:
2499             {
2500                 B* x     = IntegerInsideByteArray(PopPtr());
2501                 B* y     = IntegerInsideByteArray(PopPtr());
2502                 int n    = size_qrm(x,y);
2503                 StgPtr q = CreateByteArrayToHoldInteger(n);
2504                 StgPtr r = CreateByteArrayToHoldInteger(n);
2505                 if (do_getsign(y)==0)
2506                    return (raiseDiv0("quotRemInteger"));
2507                 do_qrm(x,y,n,IntegerInsideByteArray(q),
2508                              IntegerInsideByteArray(r));
2509                 SloppifyIntegerEnd(q);
2510                 SloppifyIntegerEnd(r);
2511                 PushPtr(r);
2512                 PushPtr(q);
2513             }
2514             break;
2515         case i_intToInteger:
2516             {
2517                  int n    = size_fromInt();
2518                  StgPtr p = CreateByteArrayToHoldInteger(n);
2519                  do_fromInt( PopTaggedInt(), n, IntegerInsideByteArray(p));
2520                  PushPtr(p);
2521             }
2522             break;
2523         case i_wordToInteger:
2524             {
2525                  int n    = size_fromWord();
2526                  StgPtr p = CreateByteArrayToHoldInteger(n);
2527                  do_fromWord( PopTaggedWord(), n, IntegerInsideByteArray(p));
2528                  PushPtr(p);
2529             }
2530             break;
2531         case i_integerToInt:       PushTaggedInt(do_toInt(
2532                                       IntegerInsideByteArray(PopPtr())
2533                                    ));
2534                                    break;
2535
2536         case i_integerToWord:      PushTaggedWord(do_toWord(
2537                                       IntegerInsideByteArray(PopPtr())
2538                                    ));
2539                                    break;
2540
2541         case i_integerToFloat:     PushTaggedFloat(do_toFloat(
2542                                       IntegerInsideByteArray(PopPtr())
2543                                    ));
2544                                    break;
2545
2546         case i_integerToDouble:    PushTaggedDouble(do_toDouble(
2547                                       IntegerInsideByteArray(PopPtr())
2548                                    ));
2549                                    break;
2550
2551         case i_gtFloat:         OP_FF_B(x>y);        break;
2552         case i_geFloat:         OP_FF_B(x>=y);       break;
2553         case i_eqFloat:         OP_FF_B(x==y);       break;
2554         case i_neFloat:         OP_FF_B(x!=y);       break;
2555         case i_ltFloat:         OP_FF_B(x<y);        break;
2556         case i_leFloat:         OP_FF_B(x<=y);       break;
2557         case i_minFloat:        OP__F(FLT_MIN);      break;
2558         case i_maxFloat:        OP__F(FLT_MAX);      break;
2559         case i_radixFloat:      OP__I(FLT_RADIX);    break;
2560         case i_digitsFloat:     OP__I(FLT_MANT_DIG); break;
2561         case i_minExpFloat:     OP__I(FLT_MIN_EXP);  break;
2562         case i_maxExpFloat:     OP__I(FLT_MAX_EXP);  break;
2563         case i_plusFloat:       OP_FF_F(x+y);        break;
2564         case i_minusFloat:      OP_FF_F(x-y);        break;
2565         case i_timesFloat:      OP_FF_F(x*y);        break;
2566         case i_divideFloat:
2567             {
2568                 StgFloat x = PopTaggedFloat();
2569                 StgFloat y = PopTaggedFloat();
2570                 PushTaggedFloat(x/y);
2571             }
2572             break;
2573         case i_negateFloat:     OP_F_F(-x);          break;
2574         case i_floatToInt:      OP_F_I(x);           break;
2575         case i_intToFloat:      OP_I_F(x);           break;
2576         case i_expFloat:        OP_F_F(exp(x));      break;
2577         case i_logFloat:        OP_F_F(log(x));      break;
2578         case i_sqrtFloat:       OP_F_F(sqrt(x));     break;
2579         case i_sinFloat:        OP_F_F(sin(x));      break;
2580         case i_cosFloat:        OP_F_F(cos(x));      break;
2581         case i_tanFloat:        OP_F_F(tan(x));      break;
2582         case i_asinFloat:       OP_F_F(asin(x));     break;
2583         case i_acosFloat:       OP_F_F(acos(x));     break;
2584         case i_atanFloat:       OP_F_F(atan(x));     break;
2585         case i_sinhFloat:       OP_F_F(sinh(x));     break;
2586         case i_coshFloat:       OP_F_F(cosh(x));     break;
2587         case i_tanhFloat:       OP_F_F(tanh(x));     break;
2588         case i_powerFloat:      OP_FF_F(pow(x,y));   break;
2589
2590         case i_encodeFloatZ:
2591             {
2592                 StgPtr sig = PopPtr();
2593                 StgInt exp = PopTaggedInt();
2594                 PushTaggedFloat(
2595                    B__encodeFloat(IntegerInsideByteArray(sig), exp)
2596                 );
2597             }
2598             break;
2599         case i_decodeFloatZ:
2600             {
2601                 StgFloat f = PopTaggedFloat();
2602                 StgPtr sig = CreateByteArrayToHoldInteger(size_fltmantissa());
2603                 StgInt exp;
2604                 B__decodeFloat(IntegerInsideByteArray(sig), &exp, f);
2605                 PushTaggedInt(exp);
2606                 PushPtr(sig);
2607             }
2608             break;
2609
2610         case i_isNaNFloat:      OP_F_B(isFloatNaN(x));      break;
2611         case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
2612         case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
2613         case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
2614         case i_gtDouble:        OP_DD_B(x>y);        break;
2615         case i_geDouble:        OP_DD_B(x>=y);       break;
2616         case i_eqDouble:        OP_DD_B(x==y);       break;
2617         case i_neDouble:        OP_DD_B(x!=y);       break;
2618         case i_ltDouble:        OP_DD_B(x<y);        break;
2619         case i_leDouble:        OP_DD_B(x<=y)        break;
2620         case i_minDouble:       OP__D(DBL_MIN);      break;
2621         case i_maxDouble:       OP__D(DBL_MAX);      break;
2622         case i_radixDouble:     OP__I(FLT_RADIX);    break;
2623         case i_digitsDouble:    OP__I(DBL_MANT_DIG); break;
2624         case i_minExpDouble:    OP__I(DBL_MIN_EXP);  break;
2625         case i_maxExpDouble:    OP__I(DBL_MAX_EXP);  break;
2626         case i_plusDouble:      OP_DD_D(x+y);        break;
2627         case i_minusDouble:     OP_DD_D(x-y);        break;
2628         case i_timesDouble:     OP_DD_D(x*y);        break;
2629         case i_divideDouble:
2630             {
2631                 StgDouble x = PopTaggedDouble();
2632                 StgDouble y = PopTaggedDouble();
2633                 PushTaggedDouble(x/y);
2634             }
2635             break;
2636         case i_negateDouble:    OP_D_D(-x);          break;
2637         case i_doubleToInt:     OP_D_I(x);           break;
2638         case i_intToDouble:     OP_I_D(x);           break;
2639         case i_doubleToFloat:   OP_D_F(x);           break;
2640         case i_floatToDouble:   OP_F_F(x);           break;
2641         case i_expDouble:       OP_D_D(exp(x));      break;
2642         case i_logDouble:       OP_D_D(log(x));      break;
2643         case i_sqrtDouble:      OP_D_D(sqrt(x));     break;
2644         case i_sinDouble:       OP_D_D(sin(x));      break;
2645         case i_cosDouble:       OP_D_D(cos(x));      break;
2646         case i_tanDouble:       OP_D_D(tan(x));      break;
2647         case i_asinDouble:      OP_D_D(asin(x));     break;
2648         case i_acosDouble:      OP_D_D(acos(x));     break;
2649         case i_atanDouble:      OP_D_D(atan(x));     break;
2650         case i_sinhDouble:      OP_D_D(sinh(x));     break;
2651         case i_coshDouble:      OP_D_D(cosh(x));     break;
2652         case i_tanhDouble:      OP_D_D(tanh(x));     break;
2653         case i_powerDouble:     OP_DD_D(pow(x,y));   break;
2654
2655         case i_encodeDoubleZ:
2656             {
2657                 StgPtr sig = PopPtr();
2658                 StgInt exp = PopTaggedInt();
2659                 PushTaggedDouble(
2660                    B__encodeDouble(IntegerInsideByteArray(sig), exp)
2661                 );
2662             }
2663             break;
2664         case i_decodeDoubleZ:
2665             {
2666                 StgDouble d = PopTaggedDouble();
2667                 StgPtr sig = CreateByteArrayToHoldInteger(size_dblmantissa());
2668                 StgInt exp;
2669                 B__decodeDouble(IntegerInsideByteArray(sig), &exp, d);
2670                 PushTaggedInt(exp);
2671                 PushPtr(sig);
2672             }
2673             break;
2674
2675         case i_isNaNDouble:      OP_D_B(isDoubleNaN(x));      break;
2676         case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
2677         case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
2678         case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
2679         case i_isIEEEDouble:
2680             {
2681                 PushTaggedBool(rtsTrue);
2682             }
2683             break;
2684         default:
2685                 barf("Unrecognised primop1");
2686         }
2687    return NULL;
2688 }
2689
2690
2691
2692 /* For normal cases, return NULL and leave *return2 unchanged.
2693    To return the address of the next thing to enter,
2694       return the address of it and leave *return2 unchanged.
2695    To return a StgThreadReturnCode to the scheduler,
2696       set *return2 to it and return a non-NULL value.
2697    To cause a context switch, set context_switch (its a global),
2698    and optionally set hugsBlock to your rational.
2699 */
2700 static void* enterBCO_primop2 ( int primop2code,
2701                                 int* /*StgThreadReturnCode* */ return2,
2702                                 StgBCO** bco,
2703                                 Capability* cap,
2704                                 HugsBlock *hugsBlock )
2705 {
2706         if (combined) {
2707            /* A small concession: we need to allow ccalls,
2708               even in combined mode.
2709            */
2710            if (primop2code != i_ccall_ccall_IO &&
2711                primop2code != i_ccall_stdcall_IO)
2712               barf("enterBCO_primop2 in combined mode");
2713         }
2714
2715         switch (primop2code) {
2716         case i_raise:  /* raise#{err} */
2717             {
2718                 StgClosure* err = PopCPtr();
2719                 return (raiseAnError(err));
2720             }
2721
2722         case i_newRef:
2723             {
2724                 StgClosure* init = PopCPtr();
2725                 StgMutVar* mv
2726                     = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
2727                 SET_HDR(mv,&MUT_VAR_info,CCCS);
2728                 mv->var = init;
2729                 PushPtr(stgCast(StgPtr,mv));
2730                 break;
2731             }
2732         case i_readRef:
2733             {
2734                 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2735                 PushCPtr(mv->var);
2736                 break;
2737             }
2738         case i_writeRef:
2739             {
2740                 StgMutVar*  mv    = stgCast(StgMutVar*,PopPtr());
2741                 StgClosure* value = PopCPtr();
2742                 mv->var = value;
2743                 break;
2744             }
2745         case i_newArray:
2746             {
2747                 nat         n    = PopTaggedInt(); /* or Word?? */
2748                 StgClosure* init = PopCPtr();
2749                 StgWord     size = sizeofW(StgMutArrPtrs) + n;
2750                 nat i;
2751                 StgMutArrPtrs* arr
2752                     = stgCast(StgMutArrPtrs*,allocate(size));
2753                 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
2754                 arr->ptrs = n;
2755                 for (i = 0; i < n; ++i) {
2756                     arr->payload[i] = init;
2757                 }
2758                 PushPtr(stgCast(StgPtr,arr));
2759                 break;
2760             }
2761         case i_readArray:
2762         case i_indexArray:
2763             {
2764                 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2765                 nat         i   = PopTaggedInt(); /* or Word?? */
2766                 StgWord     n   = arr->ptrs;
2767                 if (i >= n) {
2768                     return (raiseIndex("{index,read}Array"));
2769                 }
2770                 PushCPtr(arr->payload[i]);
2771                 break;
2772             }
2773         case i_writeArray:
2774             {
2775                 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2776                 nat         i   = PopTaggedInt(); /* or Word? */
2777                 StgClosure* v   = PopCPtr();
2778                 StgWord     n   = arr->ptrs;
2779                 if (i >= n) {
2780                     return (raiseIndex("{index,read}Array"));
2781                 }
2782                 arr->payload[i] = v;
2783                 break;
2784             }
2785         case i_sizeArray:
2786         case i_sizeMutableArray:
2787             {
2788                 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2789                 PushTaggedInt(arr->ptrs);
2790                 break;
2791             }
2792         case i_unsafeFreezeArray:
2793             {
2794                 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2795                 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
2796                 PushPtr(stgCast(StgPtr,arr));
2797                 break;
2798             }
2799         case i_unsafeFreezeByteArray:
2800             {
2801                 /* Delightfully simple :-) */
2802                 break;
2803             }
2804         case i_sameRef:
2805         case i_sameMutableArray:
2806         case i_sameMutableByteArray:
2807             {
2808                 StgPtr x = PopPtr();
2809                 StgPtr y = PopPtr();
2810                 PushTaggedBool(x==y);
2811                 break;
2812             }
2813
2814         case i_newByteArray:
2815             {
2816                 nat     n     = PopTaggedInt(); /* or Word?? */
2817                 StgInt  words = (n+sizeof(W_)-1)/sizeof(W_);
2818                 StgWord size  = sizeofW(StgArrWords) + words;
2819                 StgArrWords* arr  = stgCast(StgArrWords*,allocate(size));
2820                 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2821                 arr->words = words;
2822 #ifdef DEBUG
2823                {nat i;
2824                for (i = 0; i < n; ++i) {
2825                     arr->payload[i] = 0xdeadbeef;
2826                }}
2827 #endif
2828                 PushPtr(stgCast(StgPtr,arr));
2829                 break;
2830             }
2831
2832         /* Most of these generate alignment warnings on Sparcs and similar architectures.
2833          * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
2834          */
2835         case i_indexCharArray:
2836             OP_mI_ty(Char,"indexCharArray",    indexCharArrayzh(r,x,i)); break;
2837         case i_readCharArray:
2838             OP_mI_ty(Char,"readCharArray",     readCharArrayzh(r,x,i));  break;
2839         case i_writeCharArray:
2840             OP_mIty_(Char,"writeCharArray",    writeCharArrayzh(x,i,z)); break;
2841
2842         case i_indexIntArray:
2843             OP_mI_ty(Int,"indexIntArray",      indexIntArrayzh(r,x,i)); break;
2844         case i_readIntArray:
2845             OP_mI_ty(Int,"readIntArray",       readIntArrayzh(r,x,i));  break;
2846         case i_writeIntArray:
2847             OP_mIty_(Int,"writeIntArray",      writeIntArrayzh(x,i,z)); break;
2848
2849         case i_indexAddrArray:
2850             OP_mI_ty(Addr,"indexAddrArray",   indexAddrArrayzh(r,x,i)); break;
2851         case i_readAddrArray:
2852             OP_mI_ty(Addr,"readAddrArray",    readAddrArrayzh(r,x,i));  break;
2853         case i_writeAddrArray:
2854             OP_mIty_(Addr,"writeAddrArray",   writeAddrArrayzh(x,i,z)); break;
2855
2856         case i_indexFloatArray:
2857             OP_mI_ty(Float,"indexFloatArray",  indexFloatArrayzh(r,x,i)); break;
2858         case i_readFloatArray:
2859             OP_mI_ty(Float,"readFloatArray",   readFloatArrayzh(r,x,i));  break;
2860         case i_writeFloatArray:
2861             OP_mIty_(Float,"writeFloatArray",  writeFloatArrayzh(x,i,z)); break;
2862
2863         case i_indexDoubleArray:
2864             OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break;
2865         case i_readDoubleArray:
2866             OP_mI_ty(Double,"readDoubleArray",  readDoubleArrayzh(r,x,i));  break;
2867         case i_writeDoubleArray:
2868             OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break;
2869
2870 #if 0
2871 #ifdef PROVIDE_STABLE
2872         case i_indexStableArray:
2873             OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break;
2874         case i_readStableArray:
2875             OP_mI_ty(StablePtr,"readStableArray",  readStablePtrArrayzh(r,x,i));  break;
2876         case i_writeStableArray:
2877             OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
2878 #endif
2879 #endif
2880
2881
2882
2883 #ifdef PROVIDE_COERCE
2884         case i_unsafeCoerce:
2885             {
2886                 /* Another nullop */
2887                 break;
2888             }
2889 #endif
2890 #ifdef PROVIDE_PTREQUALITY
2891         case i_reallyUnsafePtrEquality:
2892             { /* identical to i_sameRef */
2893                 StgPtr x = PopPtr();
2894                 StgPtr y = PopPtr();
2895                 PushTaggedBool(x==y);
2896                 break;
2897             }
2898 #endif
2899 #ifdef PROVIDE_FOREIGN
2900                 /* ForeignObj# operations */
2901         case i_mkForeignObj:
2902             {
2903                 StgForeignObj *result
2904                     = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
2905                 SET_HDR(result,&FOREIGN_info,CCCS);
2906                 result -> data      = PopTaggedAddr();
2907                 PushPtr(stgCast(StgPtr,result));
2908                 break;
2909             }
2910 #endif /* PROVIDE_FOREIGN */
2911 #ifdef PROVIDE_WEAK
2912         case i_makeWeak:
2913             {
2914                 StgWeak *w
2915                     = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
2916                 SET_HDR(w, &WEAK_info, CCCS);
2917                 w->key        = PopCPtr();
2918                 w->value      = PopCPtr();
2919                 w->finaliser  = PopCPtr();
2920                 w->link       = weak_ptr_list;
2921                 weak_ptr_list = w;
2922                 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
2923                 PushPtr(stgCast(StgPtr,w));
2924                 break;
2925             }
2926         case i_deRefWeak:
2927             {
2928                 StgWeak *w = stgCast(StgWeak*,PopPtr());
2929                 if (w->header.info == &WEAK_info) {
2930                     PushCPtr(w->value); /* last result  */
2931                     PushTaggedInt(1);   /* first result */
2932                 } else {
2933                     PushPtr(stgCast(StgPtr,w));
2934                            /* ToDo: error thunk would be better */
2935                     PushTaggedInt(0);
2936                 }
2937                 break;
2938             }
2939 #endif /* PROVIDE_WEAK */
2940
2941         case i_makeStablePtr:
2942             {
2943                 StgPtr       p  = PopPtr();
2944                 StgStablePtr sp = getStablePtr ( p );
2945                 PushTaggedStablePtr(sp);
2946                 break;
2947             }
2948         case i_deRefStablePtr:
2949             {
2950                 StgPtr p;
2951                 StgStablePtr sp = PopTaggedStablePtr();
2952                 p = deRefStablePtr(sp);
2953                 PushPtr(p);
2954                 break;
2955             }
2956         case i_freeStablePtr:
2957             {
2958                 StgStablePtr sp = PopTaggedStablePtr();
2959                 freeStablePtr(sp);
2960                 break;
2961             }
2962
2963         case i_createAdjThunkARCH:
2964             {
2965                 StgStablePtr stableptr = PopTaggedStablePtr();
2966                 StgAddr      typestr   = PopTaggedAddr();
2967                 StgChar      callconv  = PopTaggedChar();
2968                 StgAddr      adj_thunk = createAdjThunk(stableptr,typestr,callconv);
2969                 PushTaggedAddr(adj_thunk);
2970                 break;
2971             }
2972
2973         case i_getArgc:
2974             {
2975                 StgInt n = prog_argc;
2976                 PushTaggedInt(n);
2977                 break;
2978             }
2979         case i_getArgv:
2980             {
2981                 StgInt  n = PopTaggedInt();
2982                 StgAddr a = (StgAddr)prog_argv[n];
2983                 PushTaggedAddr(a);
2984                 break;
2985             }
2986
2987         case i_newMVar:
2988             {
2989                 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
2990                 SET_INFO(mvar,&EMPTY_MVAR_info);
2991                 mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
2992                 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
2993                 PushPtr(stgCast(StgPtr,mvar));
2994                 break;
2995             }
2996         case i_takeMVar:
2997             {
2998                 StgMVar *mvar = (StgMVar*)PopCPtr();
2999                 if (GET_INFO(mvar) == &EMPTY_MVAR_info) {
3000
3001                     /* The MVar is empty.  Attach ourselves to the TSO's
3002                        blocking queue.
3003                     */
3004                     if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
3005                         mvar->head = cap->rCurrentTSO;
3006                     } else {
3007                         mvar->tail->link = cap->rCurrentTSO;
3008                     }
3009                     cap->rCurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
3010                     cap->rCurrentTSO->why_blocked = BlockedOnMVar;
3011                     cap->rCurrentTSO->block_info.closure = (StgClosure *)mvar;
3012                     mvar->tail = cap->rCurrentTSO;
3013
3014                     /* At this point, the top-of-stack holds the MVar,
3015                        and underneath is the world token ().  So the
3016                        stack is in the same state as when primTakeMVar
3017                        was entered (primTakeMVar is handwritten bytecode).
3018                        Push obj, which is this BCO, and return to the
3019                        scheduler.  When the MVar is filled, the scheduler
3020                        will re-enter primTakeMVar, with the args still on
3021                        the top of the stack.
3022                     */
3023                     PushCPtr((StgClosure*)(*bco));
3024                     *return2 = ThreadBlocked;
3025                     return (void*)(1+(char*)(NULL));
3026
3027                 } else {
3028                     PushCPtr(mvar->value);
3029                     mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
3030                     SET_INFO(mvar,&EMPTY_MVAR_info);
3031                 }
3032                 break;
3033             }
3034         case i_putMVar:
3035             {
3036                 StgMVar*    mvar  = stgCast(StgMVar*,PopPtr());
3037                 StgClosure* value = PopCPtr();
3038                 if (GET_INFO(mvar) == &FULL_MVAR_info) {
3039                     return (makeErrorCall("putMVar {full MVar}"));
3040                 } else {
3041                     /* wake up the first thread on the
3042                      * queue, it will continue with the
3043                      * takeMVar operation and mark the
3044                      * MVar empty again.
3045                      */
3046                     mvar->value = value;
3047
3048                     if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
3049                        ASSERT(mvar->head->why_blocked == BlockedOnMVar);
3050                        mvar->head = unblockOne(mvar->head);
3051                        if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
3052                           mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
3053                        }
3054                     }
3055
3056                     /* unlocks the MVar in the SMP case */
3057                     SET_INFO(mvar,&FULL_MVAR_info);
3058
3059                     /* yield for better communication performance */
3060                     context_switch = 1;
3061                 }
3062                 break;
3063             }
3064         case i_sameMVar:
3065             {   /* identical to i_sameRef */
3066                 StgMVar* x = (StgMVar*)PopPtr();
3067                 StgMVar* y = (StgMVar*)PopPtr();
3068                 PushTaggedBool(x==y);
3069                 break;
3070             }
3071 #ifdef PROVIDE_CONCURRENT
3072         case i_forkIO:
3073             {
3074                 StgClosure* closure;
3075                 StgTSO*     tso;
3076                 StgWord     tid;
3077                 closure = PopCPtr();
3078                 tso     = createGenThread (RtsFlags.GcFlags.initialStkSize,closure);
3079                 tid     = tso->id;
3080                 scheduleThread(tso);
3081                 context_switch = 1;
3082                 /* Later: Change to use tso as the ThreadId */
3083                 PushTaggedWord(tid);
3084                 break;
3085             }
3086
3087         case i_killThread:
3088             {
3089                 StgWord n = PopTaggedWord();
3090                 StgTSO* tso = 0;
3091                 StgTSO *t;
3092
3093                 // Map from ThreadId to Thread Structure */
3094                 for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
3095                   if (n == t->id)
3096                     tso = t;
3097                 }
3098                 if (tso == 0) {
3099                   // Already dead
3100                   break;
3101                 }
3102
3103                 while (tso->what_next == ThreadRelocated) {
3104                   tso = tso->link;
3105                 }
3106
3107                 deleteThread(tso);
3108                 if (tso == cap->rCurrentTSO) { /* suicide */
3109                     *return2 = ThreadFinished;
3110                     return (void*)(1+(char*)(NULL));
3111                 }
3112                 break;
3113             }
3114         case i_raiseInThread:
3115           ASSERT(0); /* not (yet) supported */
3116         case i_delay:
3117           {
3118             StgInt  n = PopTaggedInt();
3119             context_switch = 1;
3120             hugsBlock->reason = BlockedOnDelay;
3121             hugsBlock->delay = n;
3122             break;
3123           }
3124         case i_waitRead:
3125           {
3126             StgInt  n = PopTaggedInt();
3127             context_switch = 1;
3128             hugsBlock->reason = BlockedOnRead;
3129             hugsBlock->delay = n;
3130             break;
3131           }
3132         case i_waitWrite:
3133           {
3134             StgInt  n = PopTaggedInt();
3135             context_switch = 1;
3136             hugsBlock->reason = BlockedOnWrite;
3137             hugsBlock->delay = n;
3138             break;
3139           }
3140         case i_yield:
3141           {
3142             /* The definition of yield include an enter right after
3143              * the primYield, at which time context_switch is tested.
3144              */
3145             context_switch = 1;
3146             break;
3147           }
3148         case i_getThreadId:
3149             {
3150                 StgWord tid = cap->rCurrentTSO->id;
3151                 PushTaggedWord(tid);
3152                 break;
3153             }
3154         case i_cmpThreadIds:
3155             {
3156                 StgWord tid1 = PopTaggedWord();
3157                 StgWord tid2 = PopTaggedWord();
3158                 if (tid1 < tid2) PushTaggedInt(-1);
3159                 else if (tid1 > tid2) PushTaggedInt(1);
3160                 else PushTaggedInt(0);
3161                 break;
3162             }
3163 #endif /* PROVIDE_CONCURRENT */
3164
3165         case i_ccall_ccall_Id:
3166         case i_ccall_ccall_IO:
3167         case i_ccall_stdcall_Id:
3168         case i_ccall_stdcall_IO:
3169             {
3170                 int r;
3171                 CFunDescriptor* descriptor;
3172                 void (*funPtr)(void);
3173                 char cc;
3174                 descriptor = PopTaggedAddr();
3175                 funPtr     = PopTaggedAddr();
3176                  cc = (primop2code == i_ccall_stdcall_Id ||
3177                            primop2code == i_ccall_stdcall_IO)
3178                           ? 's' : 'c';
3179                 r = ccall(descriptor,funPtr,bco,cc,cap);
3180                 if (r == 0) break;
3181                 if (r == 1)
3182                    return makeErrorCall(
3183                       "unhandled type or too many args/results in ccall");
3184                 if (r == 2)
3185                    barf("ccall not configured correctly for this platform");
3186                 barf("unknown return code from ccall");
3187             }
3188         default:
3189                 barf("Unrecognised primop2");
3190    }
3191    return NULL;
3192 }
3193
3194
3195 /* -----------------------------------------------------------------------------
3196  * ccall support code:
3197  *   marshall moves args from C stack to Haskell stack
3198  *   unmarshall moves args from Haskell stack to C stack
3199  *   argSize calculates how much gSpace you need on the C stack
3200  * ---------------------------------------------------------------------------*/
3201
3202 /* Pop arguments off the C stack and Push them onto the Hugs stack.
3203  * Used when preparing for C calling Haskell or in regSponse to
3204  *  Haskell calling C.
3205  */
3206 nat marshall(char arg_ty, void* arg)
3207 {
3208     switch (arg_ty) {
3209     case INT_REP:
3210             PushTaggedInt(*((int*)arg));
3211             return ARG_SIZE(INT_TAG);
3212 #if 0
3213     case INTEGER_REP:
3214             PushTaggedInteger(*((mpz_ptr*)arg));
3215             return ARG_SIZE(INTEGER_TAG);
3216 #endif
3217     case WORD_REP:
3218             PushTaggedWord(*((unsigned int*)arg));
3219             return ARG_SIZE(WORD_TAG);
3220     case CHAR_REP:
3221             PushTaggedChar(*((char*)arg));
3222             return ARG_SIZE(CHAR_TAG);
3223     case FLOAT_REP:
3224             PushTaggedFloat(*((float*)arg));
3225             return ARG_SIZE(FLOAT_TAG);
3226     case DOUBLE_REP:
3227             PushTaggedDouble(*((double*)arg));
3228             return ARG_SIZE(DOUBLE_TAG);
3229     case ADDR_REP:
3230             PushTaggedAddr(*((void**)arg));
3231             return ARG_SIZE(ADDR_TAG);
3232     case STABLE_REP:
3233             PushTaggedStablePtr(*((StgStablePtr*)arg));
3234             return ARG_SIZE(STABLE_TAG);
3235 #ifdef PROVIDE_FOREIGN
3236     case FOREIGN_REP:
3237             /* Not allowed in this direction - you have to
3238              * call makeForeignPtr explicitly
3239              */
3240             barf("marshall: ForeignPtr#\n");
3241             break;
3242 #endif
3243     case BARR_REP:
3244     case MUTBARR_REP:
3245             /* Not allowed in this direction  */
3246             barf("marshall: [Mutable]ByteArray#\n");
3247             break;
3248     default:
3249             barf("marshall: unrecognised arg type %d\n",arg_ty);
3250             break;
3251     }
3252 }
3253
3254 /* Pop arguments off the Hugs stack and Push them onto the C stack.
3255  * Used when preparing for Haskell calling C or in regSponse to
3256  * C calling Haskell.
3257  */
3258 nat unmarshall(char res_ty, void* res)
3259 {
3260     switch (res_ty) {
3261     case INT_REP:
3262             *((int*)res) = PopTaggedInt();
3263             return ARG_SIZE(INT_TAG);
3264 #if 0
3265     case INTEGER_REP:
3266             *((mpz_ptr*)res) = PopTaggedInteger();
3267             return ARG_SIZE(INTEGER_TAG);
3268 #endif
3269     case WORD_REP:
3270             *((unsigned int*)res) = PopTaggedWord();
3271             return ARG_SIZE(WORD_TAG);
3272     case CHAR_REP:
3273             *((int*)res) = PopTaggedChar();
3274             return ARG_SIZE(CHAR_TAG);
3275     case FLOAT_REP:
3276             *((float*)res) = PopTaggedFloat();
3277             return ARG_SIZE(FLOAT_TAG);
3278     case DOUBLE_REP:
3279             *((double*)res) = PopTaggedDouble();
3280             return ARG_SIZE(DOUBLE_TAG);
3281     case ADDR_REP:
3282             *((void**)res) = PopTaggedAddr();
3283             return ARG_SIZE(ADDR_TAG);
3284     case STABLE_REP:
3285             *((StgStablePtr*)res) = PopTaggedStablePtr();
3286             return ARG_SIZE(STABLE_TAG);
3287 #ifdef PROVIDE_FOREIGN
3288     case FOREIGN_REP:
3289         {
3290             StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
3291             *((void**)res) = result->data;
3292             return sizeofW(StgPtr);
3293         }
3294 #endif
3295     case BARR_REP:
3296     case MUTBARR_REP:
3297         {
3298             StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3299             *((void**)res) = stgCast(void*,&(arr->payload));
3300             return sizeofW(StgPtr);
3301         }
3302     default:
3303             barf("unmarshall: unrecognised result type %d\n",res_ty);
3304     }
3305 }
3306
3307 nat argSize( const char* ks )
3308 {
3309     nat sz = 0;
3310     for( ; *ks != '\0'; ++ks) {
3311         switch (*ks) {
3312         case INT_REP:
3313                 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
3314                 break;
3315 #if 0
3316         case INTEGER_REP:
3317                 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
3318                 break;
3319 #endif
3320         case WORD_REP:
3321                 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
3322                 break;
3323         case CHAR_REP:
3324                 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
3325                 break;
3326         case FLOAT_REP:
3327                 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
3328                 break;
3329         case DOUBLE_REP:
3330                 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
3331                 break;
3332         case ADDR_REP:
3333                 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
3334                 break;
3335         case STABLE_REP:
3336                 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
3337                 break;
3338 #ifdef PROVIDE_FOREIGN
3339         case FOREIGN_REP:
3340 #endif
3341         case BARR_REP:
3342         case MUTBARR_REP:
3343                 sz += sizeof(StgPtr);
3344                 break;
3345         default:
3346                 barf("argSize: unrecognised result type %d\n",*ks);
3347                 break;
3348         }
3349     }
3350     return sz;
3351 }
3352
3353
3354 /* -----------------------------------------------------------------------------
3355  * encode/decode Float/Double code for standalone Hugs
3356  * Code based on the HBC code (lib/fltcode.c) and more recently GHC
3357  * (ghc/rts/StgPrimFloat.c)
3358  * ---------------------------------------------------------------------------*/
3359
3360 #if IEEE_FLOATING_POINT
3361 #define MY_DMINEXP  ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
3362 /* DMINEXP is defined in values.h on Linux (for example) */
3363 #define DHIGHBIT 0x00100000
3364 #define DMSBIT   0x80000000
3365
3366 #define MY_FMINEXP  ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
3367 #define FHIGHBIT 0x00800000
3368 #define FMSBIT   0x80000000
3369 #else
3370 #error The following code doesnt work in a non-IEEE FP environment
3371 #endif
3372
3373 #ifdef WORDS_BIGENDIAN
3374 #define L 1
3375 #define H 0
3376 #else
3377 #define L 0
3378 #define H 1
3379 #endif
3380
3381
3382 StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */
3383 {
3384     StgDouble r;
3385     I_ i;
3386
3387     /* Convert a B to a double; knows a lot about internal rep! */
3388     for(r = 0.0, i = s->used-1; i >= 0; i--)
3389         r = (r * B_BASE_FLT) + s->stuff[i];
3390
3391     /* Now raise to the exponent */
3392     if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3393         r = ldexp(r, e);
3394
3395     /* handle the sign */
3396     if (s->sign < 0) r = -r;
3397
3398     return r;
3399 }
3400
3401
3402
3403 #if ! FLOATS_AS_DOUBLES
3404 StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */
3405 {
3406     StgFloat r;
3407     I_ i;
3408
3409     /* Convert a B to a float; knows a lot about internal rep! */
3410     for(r = 0.0, i = s->used-1; i >= 0; i--)
3411         r = (r * B_BASE_FLT) + s->stuff[i];
3412
3413     /* Now raise to the exponent */
3414     if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3415         r = ldexp(r, e);
3416
3417     /* handle the sign */
3418     if (s->sign < 0) r = -r;
3419
3420     return r;
3421 }
3422 #endif  /* FLOATS_AS_DOUBLES */
3423
3424
3425
3426 /* This only supports IEEE floating point */
3427 void B__decodeDouble (B* man, I_* exp, StgDouble dbl)
3428 {
3429     /* Do some bit fiddling on IEEE */
3430     nat low, high;              /* assuming 32 bit ints */
3431     int sign, iexp;
3432     union { double d; int i[2]; } u;    /* assuming 32 bit ints, 64 bit double */
3433
3434     u.d = dbl;      /* grab chunks of the double */
3435     low = u.i[L];
3436     high = u.i[H];
3437
3438     ASSERT(B_BASE == 256);
3439
3440     /* Assume that the supplied B is the right size */
3441     man->size = 8;
3442
3443     if (low == 0 && (high & ~DMSBIT) == 0) {
3444         man->sign = man->used = 0;
3445         *exp = 0L;
3446     } else {
3447         man->used = 8;
3448         man->sign = 1;
3449         iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
3450         sign = high;
3451
3452         high &= DHIGHBIT-1;
3453         if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
3454             high |= DHIGHBIT;
3455         else {
3456             iexp++;
3457             /* A denorm, normalize the mantissa */
3458             while (! (high & DHIGHBIT)) {
3459                 high <<= 1;
3460                 if (low & DMSBIT)
3461                     high++;
3462                 low <<= 1;
3463                 iexp--;
3464             }
3465         }
3466         *exp = (I_) iexp;
3467
3468         man->stuff[7] = (((W_)high) >> 24) & 0xff;
3469         man->stuff[6] = (((W_)high) >> 16) & 0xff;
3470         man->stuff[5] = (((W_)high) >>  8) & 0xff;
3471         man->stuff[4] = (((W_)high)      ) & 0xff;
3472
3473         man->stuff[3] = (((W_)low) >> 24) & 0xff;
3474         man->stuff[2] = (((W_)low) >> 16) & 0xff;
3475         man->stuff[1] = (((W_)low) >>  8) & 0xff;
3476         man->stuff[0] = (((W_)low)      ) & 0xff;
3477
3478         if (sign < 0) man->sign = -1;
3479     }
3480     do_renormalise(man);
3481 }
3482
3483
3484 #if ! FLOATS_AS_DOUBLES
3485 void B__decodeFloat (B* man, I_* exp, StgFloat flt)
3486 {
3487     /* Do some bit fiddling on IEEE */
3488     int high, sign;                 /* assuming 32 bit ints */
3489     union { float f; int i; } u;    /* assuming 32 bit float and int */
3490
3491     u.f = flt;      /* grab the float */
3492     high = u.i;
3493
3494     ASSERT(B_BASE == 256);
3495
3496     /* Assume that the supplied B is the right size */
3497     man->size = 4;
3498
3499     if ((high & ~FMSBIT) == 0) {
3500         man->sign = man->used = 0;
3501         *exp = 0;
3502     } else {
3503         man->used = 4;
3504         man->sign = 1;
3505         *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
3506         sign = high;
3507
3508         high &= FHIGHBIT-1;
3509         if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
3510             high |= FHIGHBIT;
3511         else {
3512             (*exp)++;
3513             /* A denorm, normalize the mantissa */
3514             while (! (high & FHIGHBIT)) {
3515                 high <<= 1;
3516                 (*exp)--;
3517             }
3518         }
3519         man->stuff[3] = (((W_)high) >> 24) & 0xff;
3520         man->stuff[2] = (((W_)high) >> 16) & 0xff;
3521         man->stuff[1] = (((W_)high) >>  8) & 0xff;
3522         man->stuff[0] = (((W_)high)      ) & 0xff;
3523
3524         if (sign < 0) man->sign = -1;
3525     }
3526     do_renormalise(man);
3527 }
3528
3529 #endif  /* FLOATS_AS_DOUBLES */
3530 #endif /* INTERPRETER */