ghc/rts/Evaluator.c

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