ghc/rts/Evaluator.c

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