ghc/rts/Evaluator.c

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