ghc/rts/Evaluator.c

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