ghc/rts/Evaluator.c

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