ghc/rts/Evaluator.c

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