ghc/rts/Evaluator.c

   1
   2 /* -----------------------------------------------------------------------------
   3  * Bytecode evaluator
   4  *
   5  * Copyright (c) 1994-1998.
   6  *
   7  * $RCSfile: Evaluator.c,v $
   8  * $Revision: 1.55 $
   9  * $Date: 2000/06/15 13:23:51 $
  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                     bciPtr--;
1361                     printf ( "\n\n" );
1362                     disInstr ( bco, PC );
1363                     barf("\nUnrecognised instruction");
1364
1365             EndDispatch
1366
1367             barf("enterBCO: ran off end of loop");
1368             break;
1369         }
1370
1371 #           undef LoopTopLabel
1372 #           undef Case
1373 #           undef Continue
1374 #           undef Dispatch
1375 #           undef EndDispatch
1376
1377             /* ---------------------------------------------------- */
1378             /* End of the bytecode evaluator                        */
1379             /* ---------------------------------------------------- */
1380
1381     case CAF_UNENTERED:
1382         {
1383             StgBlockingQueue* bh;
1384             StgCAF* caf = (StgCAF*)obj;
1385             if (xSp - sizeofW(StgUpdateFrame) < xSpLim) {
1386                 xPushCPtr(obj); /* code to restart with */
1387                 RETURN(StackOverflow);
1388             }
1389             SSS; bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW()); LLL;
1390             SET_INFO(bh,&CAF_BLACKHOLE_info);
1391             bh->blocking_queue = EndTSOQueue;
1392             IF_DEBUG(gccafs,
1393                      fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p"
1394                                     " in evaluator\n",bh,caf));
1395             SET_INFO(caf,&CAF_ENTERED_info);
1396             caf->value = (StgClosure*)bh;
1397
1398             SSS; newCAF_made_by_Hugs(caf); LLL;
1399
1400             xPushUpdateFrame(bh,0);
1401             xSp -= sizeofW(StgUpdateFrame);
1402             obj = caf->body;
1403             goto enterLoop;
1404         }
1405     case CAF_ENTERED:
1406         {
1407             StgCAF* caf = (StgCAF*)obj;
1408             obj = caf->value; /* it's just a fancy indirection */
1409             goto enterLoop;
1410         }
1411     case BLACKHOLE:
1412     case SE_BLACKHOLE:
1413     case CAF_BLACKHOLE:
1414     case SE_CAF_BLACKHOLE:
1415         {
1416             /* Let the scheduler figure out what to do :-) */
1417             cap->rCurrentTSO->what_next = ThreadEnterGHC;
1418             xPushCPtr(obj);
1419             RETURN(ThreadYielding);
1420         }
1421     case AP_UPD:
1422         {
1423             StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
1424             int i = ap->n_args;
1425             if (xSp - (i + sizeofW(StgUpdateFrame)) < xSpLim) {
1426                 xPushCPtr(obj); /* code to restart with */
1427                 RETURN(StackOverflow);
1428             }
1429             /* ToDo: look for xSp==xSu && stackInt(0) == UPD_FRAME
1430                and insert an indirection immediately  */
1431             xPushUpdateFrame(ap,0);
1432             xSp -= sizeofW(StgUpdateFrame);
1433             while (--i >= 0) {
1434                 xPushWord(payloadWord(ap,i));
1435             }
1436             obj = ap->fun;
1437 #ifdef EAGER_BLACKHOLING
1438 #warn  LAZY_BLACKHOLING is default for StgHugs
1439 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1440             {
1441             /* superfluous - but makes debugging easier */
1442             StgBlackHole* bh = stgCast(StgBlackHole*,ap);
1443             SET_INFO(bh,&BLACKHOLE_info);
1444             bh->blocking_queue = EndTSOQueue;
1445             IF_DEBUG(gccafs,
1446                      fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
1447             /* printObj(bh); */
1448             }
1449 #endif /* EAGER_BLACKHOLING */
1450             goto enterLoop;
1451         }
1452     case PAP:
1453         {
1454             StgPAP* pap = stgCast(StgPAP*,obj);
1455             int i = pap->n_args;  /* ToDo: stack check */
1456             /* ToDo: if PAP is in whnf, we can update any update frames
1457              * on top of stack.
1458              */
1459             while (--i >= 0) {
1460                 xPushWord(payloadWord(pap,i));
1461             }
1462             obj = pap->fun;
1463             goto enterLoop;
1464         }
1465     case IND:
1466         {
1467             obj = stgCast(StgInd*,obj)->indirectee;
1468             goto enterLoop;
1469         }
1470     case IND_OLDGEN:
1471         {
1472             obj = stgCast(StgIndOldGen*,obj)->indirectee;
1473             goto enterLoop;
1474         }
1475     case CONSTR:
1476     case CONSTR_1_0:
1477     case CONSTR_0_1:
1478     case CONSTR_2_0:
1479     case CONSTR_1_1:
1480     case CONSTR_0_2:
1481     case CONSTR_INTLIKE:
1482     case CONSTR_CHARLIKE:
1483     case CONSTR_STATIC:
1484     case CONSTR_NOCAF_STATIC:
1485 #ifdef XMLAMBDA
1486 /* rows are mutarrays and should be treated as constructors. */
1487     case MUT_ARR_PTRS_FROZEN:
1488 #endif
1489         {
1490             while (1) {
1491                 switch (get_itbl(stgCast(StgClosure*,xSp))->type) {
1492                 case CATCH_FRAME:
1493                         SSS; PopCatchFrame(); LLL;
1494                         break;
1495                 case UPDATE_FRAME:
1496                         xPopUpdateFrame(obj);
1497                         break;
1498                 case SEQ_FRAME:
1499                         SSS; PopSeqFrame(); LLL;
1500                         break;
1501                 case STOP_FRAME:
1502                     {
1503                         ASSERT(xSp==(P_)xSu);
1504                         IF_DEBUG(evaluator,
1505                                  SSS;
1506                                  fprintf(stderr, "hit a STOP_FRAME\n");
1507                                  printObj(obj);
1508                                  fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu);
1509                                  printStack(xSp,cap->rCurrentTSO->stack
1510                                                 + cap->rCurrentTSO->stack_size,xSu);
1511                                  LLL;
1512                                  );
1513                         cap->rCurrentTSO->what_next = ThreadComplete;
1514                         SSS; PopStopFrame(obj); LLL;
1515                         xPushPtr((P_)obj);
1516                         RETURN(ThreadFinished);
1517                     }
1518                 case RET_BCO:
1519                     {
1520                         StgClosure* ret;
1521                         (void)xPopPtr();
1522                         ret = xPopCPtr();
1523                         xPushPtr((P_)obj);
1524                         obj = ret;
1525                         goto bco_entry;
1526                         /* was: goto enterLoop;
1527                            But we know that obj must be a bco now, so jump directly.
1528                         */
1529                     }
1530                 case RET_SMALL:  /* return to GHC */
1531                 case RET_VEC_SMALL:
1532                 case RET_BIG:
1533                 case RET_VEC_BIG:
1534                         cap->rCurrentTSO->what_next = ThreadEnterGHC;
1535                         xPushCPtr(obj);
1536                         RETURN(ThreadYielding);
1537                 default:
1538                         belch("entered CONSTR with invalid continuation on stack");
1539                         IF_DEBUG(evaluator,
1540                                  SSS;
1541                                  printObj(stgCast(StgClosure*,xSp));
1542                                  LLL;
1543                                  );
1544                         barf("bailing out");
1545                 }
1546             }
1547         }
1548     default:
1549         {
1550             //SSS;
1551             //fprintf(stderr, "enterCountI = %d\n", enterCountI);
1552             //fprintf(stderr, "entering unknown closure -- yielding to sched\n");
1553             //printObj(obj);
1554             //LLL;
1555             cap->rCurrentTSO->what_next = ThreadEnterGHC;
1556             xPushCPtr(obj); /* code to restart with */
1557             RETURN(ThreadYielding);
1558         }
1559     }
1560     barf("Ran off the end of enter - yoiks");
1561     ASSERT(0);
1562 }
1563
1564 #undef RETURN
1565 #undef BCO_INSTR_8
1566 #undef BCO_INSTR_16
1567 #undef SSS
1568 #undef LLL
1569 #undef PC
1570 #undef xPushPtr
1571 #undef xPopPtr
1572 #undef xPushCPtr
1573 #undef xPopCPtr
1574 #undef xPopWord
1575 #undef xStackPtr
1576 #undef xStackWord
1577 #undef xSetStackWord
1578 #undef xPushTag
1579 #undef xPopTag
1580 #undef xPushTaggedInt
1581 #undef xPopTaggedInt
1582 #undef xTaggedStackInt
1583 #undef xPushTaggedWord
1584 #undef xPopTaggedWord
1585 #undef xTaggedStackWord
1586 #undef xPushTaggedAddr
1587 #undef xTaggedStackAddr
1588 #undef xPopTaggedAddr
1589 #undef xPushTaggedStable
1590 #undef xTaggedStackStable
1591 #undef xPopTaggedStable
1592 #undef xPushTaggedChar
1593 #undef xTaggedStackChar
1594 #undef xPopTaggedChar
1595 #undef xPushTaggedFloat
1596 #undef xTaggedStackFloat
1597 #undef xPopTaggedFloat
1598 #undef xPushTaggedDouble
1599 #undef xTaggedStackDouble
1600 #undef xPopTaggedDouble
1601 #undef xPopUpdateFrame
1602 #undef xPushUpdateFrame
1603
1604
1605 /* --------------------------------------------------------------------------
1606  * Supporting routines for primops
1607  * ------------------------------------------------------------------------*/
1608
1609 static inline void            PushTag            ( StackTag    t )
1610    { *(--gSp) = t; }
1611        inline void            PushPtr            ( StgPtr      x )
1612    { *(--stgCast(StgPtr*,gSp))  = x; }
1613 static inline void            PushCPtr           ( StgClosure* x )
1614    { *(--stgCast(StgClosure**,gSp)) = x; }
1615 static inline void            PushInt            ( StgInt      x )
1616    { *(--stgCast(StgInt*,gSp))  = x; }
1617 static inline void            PushWord           ( StgWord     x )
1618    { *(--stgCast(StgWord*,gSp)) = x; }
1619
1620
1621 static inline void            checkTag           ( StackTag t1, StackTag t2 )
1622    { ASSERT(t1 == t2);}
1623 static inline void            PopTag             ( StackTag t )
1624    { checkTag(t,*(gSp++));    }
1625        inline StgPtr          PopPtr             ( void )
1626    { return *stgCast(StgPtr*,gSp)++; }
1627 static inline StgClosure*     PopCPtr            ( void )
1628    { return *stgCast(StgClosure**,gSp)++; }
1629 static inline StgInt          PopInt             ( void )
1630    { return *stgCast(StgInt*,gSp)++;  }
1631 static inline StgWord         PopWord            ( void )
1632    { return *stgCast(StgWord*,gSp)++; }
1633
1634 static inline StgPtr          stackPtr           ( StgStackOffset i )
1635    { return *stgCast(StgPtr*, gSp+i); }
1636 static inline StgInt          stackInt           ( StgStackOffset i )
1637    { return *stgCast(StgInt*, gSp+i); }
1638 static inline StgWord         stackWord          ( StgStackOffset i )
1639    { return *stgCast(StgWord*,gSp+i); }
1640
1641 static inline void            setStackWord       ( StgStackOffset i, StgWord w )
1642    { gSp[i] = w; }
1643
1644 #ifdef XMLAMBDA
1645 static inline void            setStackPtr        ( StgStackOffset i, StgPtr p )
1646    { *(stgCast(StgPtr*, gSp+i)) = p; }
1647 #endif
1648
1649 static inline void            PushTaggedRealWorld( void            )
1650    { PushTag(REALWORLD_TAG);  }
1651        inline void            PushTaggedInt      ( StgInt        x )
1652    { gSp -= sizeofW(StgInt);        *gSp = x;          PushTag(INT_TAG);    }
1653        inline void            PushTaggedWord     ( StgWord       x )
1654    { gSp -= sizeofW(StgWord);       *gSp = x;          PushTag(WORD_TAG);   }
1655        inline void            PushTaggedAddr     ( StgAddr       x )
1656    { gSp -= sizeofW(StgAddr);       *gSp = (W_)x;      PushTag(ADDR_TAG);   }
1657        inline void            PushTaggedChar     ( StgChar       x )
1658    { gSp -= sizeofW(StgChar);         *gSp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
1659        inline void            PushTaggedFloat    ( StgFloat      x )
1660    { gSp -= sizeofW(StgFloat);      ASSIGN_FLT(gSp,x); PushTag(FLOAT_TAG);  }
1661        inline void            PushTaggedDouble   ( StgDouble     x )
1662    { gSp -= sizeofW(StgDouble);     ASSIGN_DBL(gSp,x); PushTag(DOUBLE_TAG); }
1663        inline void            PushTaggedStablePtr   ( StgStablePtr  x )
1664    { gSp -= sizeofW(StgStablePtr);  *gSp = (W_)x;      PushTag(STABLE_TAG); }
1665 static inline void            PushTaggedBool     ( int           x )
1666    { PushTaggedInt(x); }
1667
1668
1669
1670 static inline void            PopTaggedRealWorld ( void )
1671    { PopTag(REALWORLD_TAG); }
1672        inline StgInt          PopTaggedInt       ( void )
1673    { StgInt    r; PopTag(INT_TAG);     r = *stgCast(StgInt*,  gSp);
1674      gSp += sizeofW(StgInt);        return r;}
1675        inline StgWord         PopTaggedWord      ( void )
1676    { StgWord   r; PopTag(WORD_TAG);    r = *stgCast(StgWord*, gSp);
1677      gSp += sizeofW(StgWord);       return r;}
1678        inline StgAddr         PopTaggedAddr      ( void )
1679    { StgAddr   r; PopTag(ADDR_TAG);    r = *stgCast(StgAddr*, gSp);
1680      gSp += sizeofW(StgAddr);       return r;}
1681        inline StgChar         PopTaggedChar      ( void )
1682    { StgChar   r; PopTag(CHAR_TAG);    r = stgCast(StgChar, *gSp);
1683      gSp += sizeofW(StgChar);       return r;}
1684        inline StgFloat        PopTaggedFloat     ( void )
1685    { StgFloat  r; PopTag(FLOAT_TAG);   r = PK_FLT(gSp);
1686      gSp += sizeofW(StgFloat);      return r;}
1687        inline StgDouble       PopTaggedDouble    ( void )
1688    { StgDouble r; PopTag(DOUBLE_TAG);  r = PK_DBL(gSp);
1689      gSp += sizeofW(StgDouble);     return r;}
1690        inline StgStablePtr    PopTaggedStablePtr    ( void )
1691    { StgStablePtr r; PopTag(STABLE_TAG);  r = *stgCast(StgStablePtr*, gSp);
1692      gSp += sizeofW(StgStablePtr);  return r;}
1693
1694
1695
1696 static inline StgInt          taggedStackInt     ( StgStackOffset i )
1697    { checkTag(INT_TAG,gSp[i]);     return *stgCast(StgInt*,         gSp+1+i); }
1698 static inline StgWord         taggedStackWord    ( StgStackOffset i )
1699    { checkTag(WORD_TAG,gSp[i]);    return *stgCast(StgWord*,        gSp+1+i); }
1700 static inline StgAddr         taggedStackAddr    ( StgStackOffset i )
1701    { checkTag(ADDR_TAG,gSp[i]);    return *stgCast(StgAddr*,        gSp+1+i); }
1702 static inline StgChar         taggedStackChar    ( StgStackOffset i )
1703    { checkTag(CHAR_TAG,gSp[i]);    return stgCast(StgChar, *(gSp+1+i))   ; }
1704 static inline StgFloat        taggedStackFloat   ( StgStackOffset i )
1705    { checkTag(FLOAT_TAG,gSp[i]);   return PK_FLT(gSp+1+i); }
1706 static inline StgDouble       taggedStackDouble  ( StgStackOffset i )
1707    { checkTag(DOUBLE_TAG,gSp[i]);  return PK_DBL(gSp+1+i); }
1708 static inline StgStablePtr    taggedStackStable  ( StgStackOffset i )
1709    { checkTag(STABLE_TAG,gSp[i]);  return *stgCast(StgStablePtr*,   gSp+1+i); }
1710
1711
1712 /* --------------------------------------------------------------------------
1713  * Heap allocation
1714  *
1715  * Should we allocate from a nursery or use the
1716  * doYouWantToGC/allocate interface?  We'd already implemented a
1717  * nursery-style scheme when the doYouWantToGC/allocate interface
1718  * was implemented.
1719  * One reason to prefer the doYouWantToGC/allocate interface is to
1720  * support operations which allocate an unknown amount in the heap
1721  * (array ops, gmp ops, etc)
1722  * ------------------------------------------------------------------------*/
1723
1724 static inline StgPtr grabHpUpd( nat size )
1725 {
1726     ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
1727     return allocate(size);
1728 }
1729
1730 static inline StgPtr grabHpNonUpd( nat size )
1731 {
1732     ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1733     return allocate(size);
1734 }
1735
1736 /* --------------------------------------------------------------------------
1737  * Manipulate "update frame" list:
1738  * o Update frames           (based on stg_do_update and friends in Updates.hc)
1739  * o Error handling/catching (based on catchzh_fast and friends in Prims.hc)
1740  * o Seq frames              (based on seq_frame_entry in Prims.hc)
1741  * o Stop frames
1742  * ------------------------------------------------------------------------*/
1743
1744 static inline void PopUpdateFrame ( StgClosure* obj )
1745 {
1746     /* NB: doesn't assume that gSp == gSu */
1747     IF_DEBUG(evaluator,
1748              fprintf(stderr,  "Updating ");
1749              printPtr(stgCast(StgPtr,gSu->updatee));
1750              fprintf(stderr,  " with ");
1751              printObj(obj);
1752              fprintf(stderr,"gSp = %p\tgSu = %p\n\n", gSp, gSu);
1753              );
1754 #ifdef EAGER_BLACKHOLING
1755 #warn  LAZY_BLACKHOLING is default for StgHugs
1756 #error Dont know if EAGER_BLACKHOLING works in StgHugs
1757     ASSERT(get_itbl(gSu->updatee)->type == BLACKHOLE
1758            || get_itbl(gSu->updatee)->type == SE_BLACKHOLE
1759            || get_itbl(gSu->updatee)->type == CAF_BLACKHOLE
1760            || get_itbl(gSu->updatee)->type == SE_CAF_BLACKHOLE
1761            );
1762 #endif /* EAGER_BLACKHOLING */
1763     UPD_IND(gSu->updatee,obj);
1764     gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1765     gSu = gSu->link;
1766 }
1767
1768 static inline void PopStopFrame ( StgClosure* obj )
1769 {
1770     /* Move gSu just off the end of the stack, we're about to gSpam the
1771      * STOP_FRAME with the return value.
1772      */
1773     gSu = stgCast(StgUpdateFrame*,gSp+1);
1774     *stgCast(StgClosure**,gSp) = obj;
1775 }
1776
1777 static inline void PushCatchFrame ( StgClosure* handler )
1778 {
1779     StgCatchFrame* fp;
1780     /* ToDo: stack check! */
1781     gSp -= sizeofW(StgCatchFrame);
1782     fp = stgCast(StgCatchFrame*,gSp);
1783     SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS);
1784     fp->handler         = handler;
1785     fp->link            = gSu;
1786     gSu = stgCast(StgUpdateFrame*,fp);
1787 }
1788
1789 static inline void PopCatchFrame ( void )
1790 {
1791     /* NB: doesn't assume that gSp == gSu */
1792     /* fprintf(stderr,"Popping catch frame\n"); */
1793     gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgCatchFrame);
1794     gSu = stgCast(StgCatchFrame*,gSu)->link;
1795 }
1796
1797 static inline void PushSeqFrame ( void )
1798 {
1799     StgSeqFrame* fp;
1800     /* ToDo: stack check! */
1801     gSp -= sizeofW(StgSeqFrame);
1802     fp = stgCast(StgSeqFrame*,gSp);
1803     SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS);
1804     fp->link = gSu;
1805     gSu = stgCast(StgUpdateFrame*,fp);
1806 }
1807
1808 static inline void PopSeqFrame ( void )
1809 {
1810     /* NB: doesn't assume that gSp == gSu */
1811     gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgSeqFrame);
1812     gSu = stgCast(StgSeqFrame*,gSu)->link;
1813 }
1814
1815 static inline StgClosure* raiseAnError ( StgClosure* exception )
1816 {
1817     /* This closure represents the expression 'primRaise E' where E
1818      * is the exception raised (:: Exception).
1819      * It is used to overwrite all the
1820      * thunks which are currently under evaluation.
1821      */
1822     HaskellObj primRaiseClosure
1823        = getHugs_BCO_cptr_for("primRaise");
1824     HaskellObj reraiseClosure
1825        = rts_apply ( primRaiseClosure, exception );
1826
1827     while (1) {
1828         switch (get_itbl(gSu)->type) {
1829         case UPDATE_FRAME:
1830                 UPD_IND(gSu->updatee,reraiseClosure);
1831                 gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame);
1832                 gSu = gSu->link;
1833                 break;
1834         case SEQ_FRAME:
1835                 PopSeqFrame();
1836                 break;
1837         case CATCH_FRAME:  /* found it! */
1838             {
1839                 StgCatchFrame* fp = stgCast(StgCatchFrame*,gSu);
1840                 StgClosure *handler = fp->handler;
1841                 gSu = fp->link;
1842                 gSp += sizeofW(StgCatchFrame); /* Pop */
1843                 PushCPtr(exception);
1844                 return handler;
1845             }
1846         case STOP_FRAME:
1847                 barf("raiseError: uncaught exception: STOP_FRAME");
1848         default:
1849                 barf("raiseError: weird activation record");
1850         }
1851     }
1852 }
1853
1854
1855 static StgClosure* makeErrorCall ( const char* msg )
1856 {
1857    /* Note!  the msg string should be allocated in a
1858       place which will not get freed -- preferably
1859       read-only data of the program.  That's because
1860       the thunk we build here may linger indefinitely.
1861       (thinks: probably not so, but anyway ...)
1862    */
1863    HaskellObj error
1864       = getHugs_BCO_cptr_for("error");
1865    HaskellObj unpack
1866       = getHugs_BCO_cptr_for("hugsprimUnpackString");
1867    HaskellObj thunk
1868       = rts_apply ( unpack, rts_mkAddr ( (void*)msg ) );
1869    thunk
1870       = rts_apply ( error, thunk );
1871    return
1872       (StgClosure*) thunk;
1873 }
1874
1875 #define raiseIndex(where) makeErrorCall("Array index out of range in " where)
1876 #define raiseDiv0(where)  makeErrorCall("Division by zero in " where)
1877
1878 /* --------------------------------------------------------------------------
1879  * Evaluator
1880  * ------------------------------------------------------------------------*/
1881
1882 #define OP_CC_B(e)            \
1883 {                             \
1884     unsigned char x = PopTaggedChar(); \
1885     unsigned char y = PopTaggedChar(); \
1886     PushTaggedBool(e);        \
1887 }
1888
1889 #define OP_C_I(e)             \
1890 {                             \
1891     unsigned char x = PopTaggedChar(); \
1892     PushTaggedInt(e);         \
1893 }
1894
1895 #define OP__I(e)             \
1896 {                            \
1897     PushTaggedInt(e);        \
1898 }
1899
1900 #define OP_IW_I(e)           \
1901 {                            \
1902     StgInt  x = PopTaggedInt();  \
1903     StgWord y = PopTaggedWord();  \
1904     PushTaggedInt(e);        \
1905 }
1906
1907 #define OP_II_I(e)           \
1908 {                            \
1909     StgInt x = PopTaggedInt();  \
1910     StgInt y = PopTaggedInt();  \
1911     PushTaggedInt(e);        \
1912 }
1913
1914 #define OP_II_B(e)           \
1915 {                            \
1916     StgInt x = PopTaggedInt();  \
1917     StgInt y = PopTaggedInt();  \
1918     PushTaggedBool(e);       \
1919 }
1920
1921 #define OP__A(e)             \
1922 {                            \
1923     PushTaggedAddr(e);       \
1924 }
1925
1926 #define OP_I_A(e)            \
1927 {                            \
1928     StgInt x = PopTaggedInt();  \
1929     PushTaggedAddr(e);       \
1930 }
1931
1932 #define OP_I_I(e)            \
1933 {                            \
1934     StgInt x = PopTaggedInt();  \
1935     PushTaggedInt(e);        \
1936 }
1937
1938 #define OP__C(e)             \
1939 {                            \
1940     PushTaggedChar(e);       \
1941 }
1942
1943 #define OP_I_C(e)            \
1944 {                            \
1945     StgInt x = PopTaggedInt();  \
1946     PushTaggedChar(e);       \
1947 }
1948
1949 #define OP__W(e)              \
1950 {                             \
1951     PushTaggedWord(e);        \
1952 }
1953
1954 #define OP_I_W(e)            \
1955 {                            \
1956     StgInt x = PopTaggedInt();  \
1957     PushTaggedWord(e);       \
1958 }
1959
1960 #define OP_I_s(e)            \
1961 {                            \
1962     StgInt x = PopTaggedInt();  \
1963     PushTaggedStablePtr(e);  \
1964 }
1965
1966 #define OP__F(e)             \
1967 {                            \
1968     PushTaggedFloat(e);      \
1969 }
1970
1971 #define OP_I_F(e)            \
1972 {                            \
1973     StgInt x = PopTaggedInt();  \
1974     PushTaggedFloat(e);      \
1975 }
1976
1977 #define OP__D(e)             \
1978 {                            \
1979     PushTaggedDouble(e);     \
1980 }
1981
1982 #define OP_I_D(e)            \
1983 {                            \
1984     StgInt x = PopTaggedInt();  \
1985     PushTaggedDouble(e);     \
1986 }
1987
1988 #define OP_WW_B(e)            \
1989 {                             \
1990     StgWord x = PopTaggedWord(); \
1991     StgWord y = PopTaggedWord(); \
1992     PushTaggedBool(e);        \
1993 }
1994
1995 #define OP_WW_W(e)            \
1996 {                             \
1997     StgWord x = PopTaggedWord(); \
1998     StgWord y = PopTaggedWord(); \
1999     PushTaggedWord(e);        \
2000 }
2001
2002 #define OP_W_I(e)             \
2003 {                             \
2004     StgWord x = PopTaggedWord(); \
2005     PushTaggedInt(e);         \
2006 }
2007
2008 #define OP_s_I(e)             \
2009 {                             \
2010     StgStablePtr x = PopTaggedStablePtr(); \
2011     PushTaggedInt(e);         \
2012 }
2013
2014 #define OP_W_W(e)             \
2015 {                             \
2016     StgWord x = PopTaggedWord(); \
2017     PushTaggedWord(e);        \
2018 }
2019
2020 #define OP_AA_B(e)            \
2021 {                             \
2022     StgAddr x = PopTaggedAddr(); \
2023     StgAddr y = PopTaggedAddr(); \
2024     PushTaggedBool(e);        \
2025 }
2026 #define OP_A_I(e)             \
2027 {                             \
2028     StgAddr x = PopTaggedAddr(); \
2029     PushTaggedInt(e);         \
2030 }
2031 #define OP_AI_C(s)            \
2032 {                             \
2033     StgAddr x = PopTaggedAddr(); \
2034     int  y = PopTaggedInt();  \
2035     StgChar r;                \
2036     s;                        \
2037     PushTaggedChar(r);        \
2038 }
2039 #define OP_AI_I(s)            \
2040 {                             \
2041     StgAddr x = PopTaggedAddr(); \
2042     int  y = PopTaggedInt();  \
2043     StgInt r;                 \
2044     s;                        \
2045     PushTaggedInt(r);         \
2046 }
2047 #define OP_AI_A(s)            \
2048 {                             \
2049     StgAddr x = PopTaggedAddr(); \
2050     int  y = PopTaggedInt();  \
2051     StgAddr r;                \
2052     s;                        \
2053     PushTaggedAddr(s);        \
2054 }
2055 #define OP_AI_F(s)            \
2056 {                             \
2057     StgAddr x = PopTaggedAddr(); \
2058     int  y = PopTaggedInt();  \
2059     StgFloat r;               \
2060     s;                        \
2061     PushTaggedFloat(r);       \
2062 }
2063 #define OP_AI_D(s)            \
2064 {                             \
2065     StgAddr x = PopTaggedAddr(); \
2066     int  y = PopTaggedInt();  \
2067     StgDouble r;              \
2068     s;                        \
2069     PushTaggedDouble(r);      \
2070 }
2071 #define OP_AI_s(s)            \
2072 {                             \
2073     StgAddr x = PopTaggedAddr(); \
2074     int  y = PopTaggedInt();  \
2075     StgStablePtr r;           \
2076     s;                        \
2077     PushTaggedStablePtr(r);   \
2078 }
2079 #define OP_AIC_(s)            \
2080 {                             \
2081     StgAddr x = PopTaggedAddr(); \
2082     int     y = PopTaggedInt();  \
2083     StgChar z = PopTaggedChar(); \
2084     s;                        \
2085 }
2086 #define OP_AII_(s)            \
2087 {                             \
2088     StgAddr x = PopTaggedAddr(); \
2089     int     y = PopTaggedInt();  \
2090     StgInt  z = PopTaggedInt(); \
2091     s;                        \
2092 }
2093 #define OP_AIA_(s)            \
2094 {                             \
2095     StgAddr x = PopTaggedAddr(); \
2096     int     y = PopTaggedInt();  \
2097     StgAddr z = PopTaggedAddr(); \
2098     s;                        \
2099 }
2100 #define OP_AIF_(s)            \
2101 {                             \
2102     StgAddr x = PopTaggedAddr(); \
2103     int     y = PopTaggedInt();  \
2104     StgFloat z = PopTaggedFloat(); \
2105     s;                        \
2106 }
2107 #define OP_AID_(s)            \
2108 {                             \
2109     StgAddr x = PopTaggedAddr(); \
2110     int     y = PopTaggedInt();  \
2111     StgDouble z = PopTaggedDouble(); \
2112     s;                        \
2113 }
2114 #define OP_AIs_(s)            \
2115 {                             \
2116     StgAddr x = PopTaggedAddr(); \
2117     int     y = PopTaggedInt();  \
2118     StgStablePtr z = PopTaggedStablePtr(); \
2119     s;                        \
2120 }
2121
2122
2123 #define OP_FF_B(e)              \
2124 {                               \
2125     StgFloat x = PopTaggedFloat(); \
2126     StgFloat y = PopTaggedFloat(); \
2127     PushTaggedBool(e);          \
2128 }
2129
2130 #define OP_FF_F(e)              \
2131 {                               \
2132     StgFloat x = PopTaggedFloat(); \
2133     StgFloat y = PopTaggedFloat(); \
2134     PushTaggedFloat(e);         \
2135 }
2136
2137 #define OP_F_F(e)               \
2138 {                               \
2139     StgFloat x = PopTaggedFloat(); \
2140     PushTaggedFloat(e);         \
2141 }
2142
2143 #define OP_F_B(e)               \
2144 {                               \
2145     StgFloat x = PopTaggedFloat(); \
2146     PushTaggedBool(e);         \
2147 }
2148
2149 #define OP_F_I(e)               \
2150 {                               \
2151     StgFloat x = PopTaggedFloat(); \
2152     PushTaggedInt(e);           \
2153 }
2154
2155 #define OP_F_D(e)               \
2156 {                               \
2157     StgFloat x = PopTaggedFloat(); \
2158     PushTaggedDouble(e);        \
2159 }
2160
2161 #define OP_DD_B(e)                \
2162 {                                 \
2163     StgDouble x = PopTaggedDouble(); \
2164     StgDouble y = PopTaggedDouble(); \
2165     PushTaggedBool(e);            \
2166 }
2167
2168 #define OP_DD_D(e)                \
2169 {                                 \
2170     StgDouble x = PopTaggedDouble(); \
2171     StgDouble y = PopTaggedDouble(); \
2172     PushTaggedDouble(e);          \
2173 }
2174
2175 #define OP_D_B(e)                 \
2176 {                                 \
2177     StgDouble x = PopTaggedDouble(); \
2178     PushTaggedBool(e);          \
2179 }
2180
2181 #define OP_D_D(e)                 \
2182 {                                 \
2183     StgDouble x = PopTaggedDouble(); \
2184     PushTaggedDouble(e);          \
2185 }
2186
2187 #define OP_D_I(e)                 \
2188 {                                 \
2189     StgDouble x = PopTaggedDouble(); \
2190     PushTaggedInt(e);             \
2191 }
2192
2193 #define OP_D_F(e)                 \
2194 {                                 \
2195     StgDouble x = PopTaggedDouble(); \
2196     PushTaggedFloat(e);           \
2197 }
2198
2199
2200 StgPtr CreateByteArrayToHoldInteger ( int nbytes )
2201 {
2202    StgWord words     = (nbytes+sizeof(W_)-1)/sizeof(W_);
2203    StgWord size      = sizeofW(StgArrWords) + words;
2204    StgArrWords* arr  = (StgArrWords*)allocate(size);
2205    SET_HDR(arr,&ARR_WORDS_info,CCCS);
2206    arr->words = words;
2207    ASSERT((W_)nbytes <= arr->words * sizeof(W_));
2208 #ifdef DEBUG
2209    {StgWord i;
2210     for (i = 0; i < words; ++i) {
2211     arr->payload[i] = 0xdeadbeef;
2212    }}
2213    { B* b = (B*) &(arr->payload[0]);
2214      b->used = b->sign = 0;
2215    }
2216 #endif
2217    return (StgPtr)arr;
2218 }
2219
2220 B* IntegerInsideByteArray ( StgPtr arr0 )
2221 {
2222    B* b;
2223    StgArrWords* arr = (StgArrWords*)arr0;
2224    ASSERT(GET_INFO(arr) == &ARR_WORDS_info);
2225    b = (B*) &(arr->payload[0]);
2226    return b;
2227 }
2228
2229 void SloppifyIntegerEnd ( StgPtr arr0 )
2230 {
2231    StgArrWords* arr = (StgArrWords*)arr0;
2232    B* b = (B*) & (arr->payload[0]);
2233    I_ nwunused = arr->words - sizeofW(B) - (b->used+sizeof(W_)-1)/sizeof(W_);
2234    if (nwunused >= ((I_)sizeofW(StgArrWords))) {
2235       StgArrWords* slop;
2236       b->size -= nwunused * sizeof(W_);
2237       if (b->size < b->used) b->size = b->used;
2238       do_renormalise(b);
2239       ASSERT(is_sane(b));
2240       arr->words -= nwunused;
2241       slop = (StgArrWords*)&(arr->payload[arr->words]);
2242       SET_HDR(slop,&ARR_WORDS_info,CCCS);
2243       slop->words = nwunused - sizeofW(StgArrWords);
2244       ASSERT( &(slop->payload[slop->words]) ==
2245               &(arr->payload[arr->words + nwunused]) );
2246    }
2247 }
2248
2249 #define OP_Z_Z(op)                                   \
2250 {                                                    \
2251    B* x     = IntegerInsideByteArray(PopPtr());      \
2252    int n    = mycat2(size_,op)(x);                   \
2253    StgPtr p = CreateByteArrayToHoldInteger(n);       \
2254    mycat2(do_,op)(x,n,IntegerInsideByteArray(p));    \
2255    SloppifyIntegerEnd(p);                            \
2256    PushPtr(p);                                       \
2257 }
2258 #define OP_ZZ_Z(op)                                  \
2259 {                                                    \
2260    B* x     = IntegerInsideByteArray(PopPtr());      \
2261    B* y     = IntegerInsideByteArray(PopPtr());      \
2262    int n    = mycat2(size_,op)(x,y);                 \
2263    StgPtr p = CreateByteArrayToHoldInteger(n);       \
2264    mycat2(do_,op)(x,y,n,IntegerInsideByteArray(p));  \
2265    SloppifyIntegerEnd(p);                            \
2266    PushPtr(p);                                       \
2267 }
2268
2269
2270
2271
2272 #define HEADER_mI(ty,where)          \
2273     StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \
2274     nat i = PopTaggedInt();   \
2275     if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) {        \
2276         return (raiseIndex(where));  \
2277     }
2278 #define OP_mI_ty(ty,where,s)        \
2279 {                                   \
2280     HEADER_mI(mycat2(Stg,ty),where) \
2281     { mycat2(Stg,ty) r;             \
2282       s;                            \
2283       mycat2(PushTagged,ty)(r);     \
2284     }                               \
2285 }
2286 #define OP_mIty_(ty,where,s)        \
2287 {                                   \
2288     HEADER_mI(mycat2(Stg,ty),where) \
2289     {                               \
2290       mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
2291       s;                            \
2292     }                               \
2293 }
2294
2295
2296 __attribute__ ((unused))
2297 static void myStackCheck ( Capability* cap )
2298 {
2299    /* fprintf(stderr, "myStackCheck\n"); */
2300    if (!(gSpLim <= gSp && gSp <= stgCast(StgPtr,gSu))) {
2301       fprintf(stderr, "myStackCheck: invalid initial gSp/gSu \n" );
2302       barf("aborting");
2303       ASSERT(0);
2304    }
2305    while (1) {
2306       if (!( (P_)gSu >= (P_)cap->rCurrentTSO->stack
2307               &&
2308               (P_)gSu <= (P_)(cap->rCurrentTSO->stack
2309                               + cap->rCurrentTSO->stack_size))) {
2310          fprintf ( stderr, "myStackCheck: gSu out of stack\n" );
2311          barf("aborting");
2312          ASSERT(0);
2313       }
2314       switch (get_itbl(stgCast(StgClosure*,gSu))->type) {
2315       case CATCH_FRAME:
2316          gSu = (StgUpdateFrame*) ((StgCatchFrame*)(gSu))->link;
2317          break;
2318       case UPDATE_FRAME:
2319          gSu = (StgUpdateFrame*) ((StgUpdateFrame*)(gSu))->link;
2320          break;
2321       case SEQ_FRAME:
2322          gSu = (StgUpdateFrame*) ((StgSeqFrame*)(gSu))->link;
2323          break;
2324       case STOP_FRAME:
2325          goto postloop;
2326       default:
2327          fprintf(stderr, "myStackCheck: invalid activation record\n");
2328          barf("aborting");
2329          ASSERT(0);
2330       }
2331    }
2332    postloop:
2333 }
2334
2335
2336 /* --------------------------------------------------------------------------
2337  * Primop stuff for bytecode interpreter
2338  * ------------------------------------------------------------------------*/
2339
2340 /* Returns & of the next thing to enter (if throwing an exception),
2341    or NULL in the normal case.
2342 */
2343 static void* enterBCO_primop1 ( int primop1code )
2344 {
2345     if (combined)
2346        barf("enterBCO_primop1 in combined mode");
2347
2348     switch (primop1code) {
2349         case i_pushseqframe:
2350             {
2351                StgClosure* c = PopCPtr();
2352                PushSeqFrame();
2353                PushCPtr(c);
2354                break;
2355             }
2356         case i_pushcatchframe:
2357             {
2358                StgClosure* e = PopCPtr();
2359                StgClosure* h = PopCPtr();
2360                PushCatchFrame(h);
2361                PushCPtr(e);
2362                break;
2363             }
2364
2365         case i_gtChar:          OP_CC_B(x>y);        break;
2366         case i_geChar:          OP_CC_B(x>=y);       break;
2367         case i_eqChar:          OP_CC_B(x==y);       break;
2368         case i_neChar:          OP_CC_B(x!=y);       break;
2369         case i_ltChar:          OP_CC_B(x<y);        break;
2370         case i_leChar:          OP_CC_B(x<=y);       break;
2371         case i_charToInt:       OP_C_I(x);           break;
2372         case i_intToChar:       OP_I_C(x);           break;
2373
2374         case i_gtInt:           OP_II_B(x>y);        break;
2375         case i_geInt:           OP_II_B(x>=y);       break;
2376         case i_eqInt:           OP_II_B(x==y);       break;
2377         case i_neInt:           OP_II_B(x!=y);       break;
2378         case i_ltInt:           OP_II_B(x<y);        break;
2379         case i_leInt:           OP_II_B(x<=y);       break;
2380         case i_minInt:          OP__I(INT_MIN);      break;
2381         case i_maxInt:          OP__I(INT_MAX);      break;
2382         case i_plusInt:         OP_II_I(x+y);        break;
2383         case i_minusInt:        OP_II_I(x-y);        break;
2384         case i_timesInt:        OP_II_I(x*y);        break;
2385         case i_quotInt:
2386             {
2387                 int x = PopTaggedInt();
2388                 int y = PopTaggedInt();
2389                 if (y == 0) {
2390                     return (raiseDiv0("quotInt"));
2391                 }
2392                 /* ToDo: protect against minInt / -1 errors
2393                  * (repeat for all other division primops) */
2394                 PushTaggedInt(x/y);
2395             }
2396             break;
2397         case i_remInt:
2398             {
2399                 int x = PopTaggedInt();
2400                 int y = PopTaggedInt();
2401                 if (y == 0) {
2402                     return (raiseDiv0("remInt"));
2403                 }
2404                 PushTaggedInt(x%y);
2405             }
2406             break;
2407         case i_quotRemInt:
2408             {
2409                 StgInt x = PopTaggedInt();
2410                 StgInt y = PopTaggedInt();
2411                 if (y == 0) {
2412                     return (raiseDiv0("quotRemInt"));
2413                 }
2414                 PushTaggedInt(x%y); /* last result  */
2415                 PushTaggedInt(x/y); /* first result */
2416             }
2417             break;
2418         case i_negateInt:       OP_I_I(-x);          break;
2419
2420         case i_andInt:          OP_II_I(x&y);        break;
2421         case i_orInt:           OP_II_I(x|y);        break;
2422         case i_xorInt:          OP_II_I(x^y);        break;
2423         case i_notInt:          OP_I_I(~x);          break;
2424         case i_shiftLInt:       OP_II_I(x<<y);       break;
2425         case i_shiftRAInt:      OP_II_I(x>>y);       break; /* ToDo */
2426         case i_shiftRLInt:      OP_II_I(x>>y);       break; /* ToDo */
2427
2428         case i_gtWord:          OP_WW_B(x>y);        break;
2429         case i_geWord:          OP_WW_B(x>=y);       break;
2430         case i_eqWord:          OP_WW_B(x==y);       break;
2431         case i_neWord:          OP_WW_B(x!=y);       break;
2432         case i_ltWord:          OP_WW_B(x<y);        break;
2433         case i_leWord:          OP_WW_B(x<=y);       break;
2434         case i_minWord:         OP__W(0);            break;
2435         case i_maxWord:         OP__W(UINT_MAX);     break;
2436         case i_plusWord:        OP_WW_W(x+y);        break;
2437         case i_minusWord:       OP_WW_W(x-y);        break;
2438         case i_timesWord:       OP_WW_W(x*y);        break;
2439         case i_quotWord:
2440             {
2441                 StgWord x = PopTaggedWord();
2442                 StgWord y = PopTaggedWord();
2443                 if (y == 0) {
2444                     return (raiseDiv0("quotWord"));
2445                 }
2446                 PushTaggedWord(x/y);
2447             }
2448             break;
2449         case i_remWord:
2450             {
2451                 StgWord x = PopTaggedWord();
2452                 StgWord y = PopTaggedWord();
2453                 if (y == 0) {
2454                     return (raiseDiv0("remWord"));
2455                 }
2456                 PushTaggedWord(x%y);
2457             }
2458             break;
2459         case i_quotRemWord:
2460             {
2461                 StgWord x = PopTaggedWord();
2462                 StgWord y = PopTaggedWord();
2463                 if (y == 0) {
2464                     return (raiseDiv0("quotRemWord"));
2465                 }
2466                 PushTaggedWord(x%y); /* last result  */
2467                 PushTaggedWord(x/y); /* first result */
2468             }
2469             break;
2470         case i_negateWord:      OP_W_W(-x);         break;
2471         case i_andWord:         OP_WW_W(x&y);        break;
2472         case i_orWord:          OP_WW_W(x|y);        break;
2473         case i_xorWord:         OP_WW_W(x^y);        break;
2474         case i_notWord:         OP_W_W(~x);          break;
2475         case i_shiftLWord:      OP_WW_W(x<<y);       break;
2476         case i_shiftRAWord:     OP_WW_W(x>>y);       break; /* ToDo */
2477         case i_shiftRLWord:     OP_WW_W(x>>y);       break; /* ToDo */
2478         case i_intToWord:       OP_I_W(x);           break;
2479         case i_wordToInt:       OP_W_I(x);           break;
2480
2481         case i_gtAddr:          OP_AA_B(x>y);        break;
2482         case i_geAddr:          OP_AA_B(x>=y);       break;
2483         case i_eqAddr:          OP_AA_B(x==y);       break;
2484         case i_neAddr:          OP_AA_B(x!=y);       break;
2485         case i_ltAddr:          OP_AA_B(x<y);        break;
2486         case i_leAddr:          OP_AA_B(x<=y);       break;
2487         case i_intToAddr:       OP_I_A((StgAddr)x);  break;  /*  ToDo */
2488         case i_addrToInt:       OP_A_I((StgInt)x);   break;  /* ToDo */
2489
2490         case i_intToStable:     OP_I_s((StgStablePtr)x); break;
2491         case i_stableToInt:     OP_s_I((W_)x);           break;
2492
2493         case i_indexCharOffAddr:   OP_AI_C(indexCharOffAddrzh(r,x,y));      break;
2494         case i_readCharOffAddr:    OP_AI_C(indexCharOffAddrzh(r,x,y));      break;
2495         case i_writeCharOffAddr:   OP_AIC_(writeCharOffAddrzh(x,y,z));      break;
2496
2497         case i_indexIntOffAddr:    OP_AI_I(indexIntOffAddrzh(r,x,y));       break;
2498         case i_readIntOffAddr:     OP_AI_I(indexIntOffAddrzh(r,x,y));       break;
2499         case i_writeIntOffAddr:    OP_AII_(writeIntOffAddrzh(x,y,z));       break;
2500
2501         case i_indexAddrOffAddr:   OP_AI_A(indexAddrOffAddrzh(r,x,y));      break;
2502         case i_readAddrOffAddr:    OP_AI_A(indexAddrOffAddrzh(r,x,y));      break;
2503         case i_writeAddrOffAddr:   OP_AIA_(writeAddrOffAddrzh(x,y,z));      break;
2504
2505         case i_indexFloatOffAddr:  OP_AI_F(indexFloatOffAddrzh(r,x,y));     break;
2506         case i_readFloatOffAddr:   OP_AI_F(indexFloatOffAddrzh(r,x,y));     break;
2507         case i_writeFloatOffAddr:  OP_AIF_(writeFloatOffAddrzh(x,y,z));     break;
2508
2509         case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y));    break;
2510         case i_readDoubleOffAddr:  OP_AI_D(indexDoubleOffAddrzh(r,x,y));    break;
2511         case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z));    break;
2512
2513         case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2514         case i_readStableOffAddr:  OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
2515         case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
2516
2517         case i_compareInteger:
2518             {
2519                 B* x = IntegerInsideByteArray(PopPtr());
2520                 B* y = IntegerInsideByteArray(PopPtr());
2521                 StgInt r = do_cmp(x,y);
2522                 PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
2523             }
2524             break;
2525         case i_negateInteger:      OP_Z_Z(neg);     break;
2526         case i_plusInteger:        OP_ZZ_Z(add);    break;
2527         case i_minusInteger:       OP_ZZ_Z(sub);    break;
2528         case i_timesInteger:       OP_ZZ_Z(mul);    break;
2529         case i_quotRemInteger:
2530             {
2531                 B* x     = IntegerInsideByteArray(PopPtr());
2532                 B* y     = IntegerInsideByteArray(PopPtr());
2533                 int n    = size_qrm(x,y);
2534                 StgPtr q = CreateByteArrayToHoldInteger(n);
2535                 StgPtr r = CreateByteArrayToHoldInteger(n);
2536                 if (do_getsign(y)==0)
2537                    return (raiseDiv0("quotRemInteger"));
2538                 do_qrm(x,y,n,IntegerInsideByteArray(q),
2539                              IntegerInsideByteArray(r));
2540                 SloppifyIntegerEnd(q);
2541                 SloppifyIntegerEnd(r);
2542                 PushPtr(r);
2543                 PushPtr(q);
2544             }
2545             break;
2546         case i_intToInteger:
2547             {
2548                  int n    = size_fromInt();
2549                  StgPtr p = CreateByteArrayToHoldInteger(n);
2550                  do_fromInt( PopTaggedInt(), n, IntegerInsideByteArray(p));
2551                  PushPtr(p);
2552             }
2553             break;
2554         case i_wordToInteger:
2555             {
2556                  int n    = size_fromWord();
2557                  StgPtr p = CreateByteArrayToHoldInteger(n);
2558                  do_fromWord( PopTaggedWord(), n, IntegerInsideByteArray(p));
2559                  PushPtr(p);
2560             }
2561             break;
2562         case i_integerToInt:       PushTaggedInt(do_toInt(
2563                                       IntegerInsideByteArray(PopPtr())
2564                                    ));
2565                                    break;
2566
2567         case i_integerToWord:      PushTaggedWord(do_toWord(
2568                                       IntegerInsideByteArray(PopPtr())
2569                                    ));
2570                                    break;
2571
2572         case i_integerToFloat:     PushTaggedFloat(do_toFloat(
2573                                       IntegerInsideByteArray(PopPtr())
2574                                    ));
2575                                    break;
2576
2577         case i_integerToDouble:    PushTaggedDouble(do_toDouble(
2578                                       IntegerInsideByteArray(PopPtr())
2579                                    ));
2580                                    break;
2581
2582         case i_gtFloat:         OP_FF_B(x>y);        break;
2583         case i_geFloat:         OP_FF_B(x>=y);       break;
2584         case i_eqFloat:         OP_FF_B(x==y);       break;
2585         case i_neFloat:         OP_FF_B(x!=y);       break;
2586         case i_ltFloat:         OP_FF_B(x<y);        break;
2587         case i_leFloat:         OP_FF_B(x<=y);       break;
2588         case i_minFloat:        OP__F(FLT_MIN);      break;
2589         case i_maxFloat:        OP__F(FLT_MAX);      break;
2590         case i_radixFloat:      OP__I(FLT_RADIX);    break;
2591         case i_digitsFloat:     OP__I(FLT_MANT_DIG); break;
2592         case i_minExpFloat:     OP__I(FLT_MIN_EXP);  break;
2593         case i_maxExpFloat:     OP__I(FLT_MAX_EXP);  break;
2594         case i_plusFloat:       OP_FF_F(x+y);        break;
2595         case i_minusFloat:      OP_FF_F(x-y);        break;
2596         case i_timesFloat:      OP_FF_F(x*y);        break;
2597         case i_divideFloat:
2598             {
2599                 StgFloat x = PopTaggedFloat();
2600                 StgFloat y = PopTaggedFloat();
2601                 PushTaggedFloat(x/y);
2602             }
2603             break;
2604         case i_negateFloat:     OP_F_F(-x);          break;
2605         case i_floatToInt:      OP_F_I(x);           break;
2606         case i_intToFloat:      OP_I_F(x);           break;
2607         case i_expFloat:        OP_F_F(exp(x));      break;
2608         case i_logFloat:        OP_F_F(log(x));      break;
2609         case i_sqrtFloat:       OP_F_F(sqrt(x));     break;
2610         case i_sinFloat:        OP_F_F(sin(x));      break;
2611         case i_cosFloat:        OP_F_F(cos(x));      break;
2612         case i_tanFloat:        OP_F_F(tan(x));      break;
2613         case i_asinFloat:       OP_F_F(asin(x));     break;
2614         case i_acosFloat:       OP_F_F(acos(x));     break;
2615         case i_atanFloat:       OP_F_F(atan(x));     break;
2616         case i_sinhFloat:       OP_F_F(sinh(x));     break;
2617         case i_coshFloat:       OP_F_F(cosh(x));     break;
2618         case i_tanhFloat:       OP_F_F(tanh(x));     break;
2619         case i_powerFloat:      OP_FF_F(pow(x,y));   break;
2620
2621         case i_encodeFloatZ:
2622             {
2623                 StgPtr sig = PopPtr();
2624                 StgInt exp = PopTaggedInt();
2625                 PushTaggedFloat(
2626                    B__encodeFloat(IntegerInsideByteArray(sig), exp)
2627                 );
2628             }
2629             break;
2630         case i_decodeFloatZ:
2631             {
2632                 StgFloat f = PopTaggedFloat();
2633                 StgPtr sig = CreateByteArrayToHoldInteger(size_fltmantissa());
2634                 StgInt exp;
2635                 B__decodeFloat(IntegerInsideByteArray(sig), &exp, f);
2636                 PushTaggedInt(exp);
2637                 PushPtr(sig);
2638             }
2639             break;
2640
2641         case i_isNaNFloat:      OP_F_B(isFloatNaN(x));      break;
2642         case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
2643         case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
2644         case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
2645         case i_gtDouble:        OP_DD_B(x>y);        break;
2646         case i_geDouble:        OP_DD_B(x>=y);       break;
2647         case i_eqDouble:        OP_DD_B(x==y);       break;
2648         case i_neDouble:        OP_DD_B(x!=y);       break;
2649         case i_ltDouble:        OP_DD_B(x<y);        break;
2650         case i_leDouble:        OP_DD_B(x<=y)        break;
2651         case i_minDouble:       OP__D(DBL_MIN);      break;
2652         case i_maxDouble:       OP__D(DBL_MAX);      break;
2653         case i_radixDouble:     OP__I(FLT_RADIX);    break;
2654         case i_digitsDouble:    OP__I(DBL_MANT_DIG); break;
2655         case i_minExpDouble:    OP__I(DBL_MIN_EXP);  break;
2656         case i_maxExpDouble:    OP__I(DBL_MAX_EXP);  break;
2657         case i_plusDouble:      OP_DD_D(x+y);        break;
2658         case i_minusDouble:     OP_DD_D(x-y);        break;
2659         case i_timesDouble:     OP_DD_D(x*y);        break;
2660         case i_divideDouble:
2661             {
2662                 StgDouble x = PopTaggedDouble();
2663                 StgDouble y = PopTaggedDouble();
2664                 PushTaggedDouble(x/y);
2665             }
2666             break;
2667         case i_negateDouble:    OP_D_D(-x);          break;
2668         case i_doubleToInt:     OP_D_I(x);           break;
2669         case i_intToDouble:     OP_I_D(x);           break;
2670         case i_doubleToFloat:   OP_D_F(x);           break;
2671         case i_floatToDouble:   OP_F_F(x);           break;
2672         case i_expDouble:       OP_D_D(exp(x));      break;
2673         case i_logDouble:       OP_D_D(log(x));      break;
2674         case i_sqrtDouble:      OP_D_D(sqrt(x));     break;
2675         case i_sinDouble:       OP_D_D(sin(x));      break;
2676         case i_cosDouble:       OP_D_D(cos(x));      break;
2677         case i_tanDouble:       OP_D_D(tan(x));      break;
2678         case i_asinDouble:      OP_D_D(asin(x));     break;
2679         case i_acosDouble:      OP_D_D(acos(x));     break;
2680         case i_atanDouble:      OP_D_D(atan(x));     break;
2681         case i_sinhDouble:      OP_D_D(sinh(x));     break;
2682         case i_coshDouble:      OP_D_D(cosh(x));     break;
2683         case i_tanhDouble:      OP_D_D(tanh(x));     break;
2684         case i_powerDouble:     OP_DD_D(pow(x,y));   break;
2685
2686         case i_encodeDoubleZ:
2687             {
2688                 StgPtr sig = PopPtr();
2689                 StgInt exp = PopTaggedInt();
2690                 PushTaggedDouble(
2691                    B__encodeDouble(IntegerInsideByteArray(sig), exp)
2692                 );
2693             }
2694             break;
2695         case i_decodeDoubleZ:
2696             {
2697                 StgDouble d = PopTaggedDouble();
2698                 StgPtr sig = CreateByteArrayToHoldInteger(size_dblmantissa());
2699                 StgInt exp;
2700                 B__decodeDouble(IntegerInsideByteArray(sig), &exp, d);
2701                 PushTaggedInt(exp);
2702                 PushPtr(sig);
2703             }
2704             break;
2705
2706         case i_isNaNDouble:      OP_D_B(isDoubleNaN(x));      break;
2707         case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
2708         case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
2709         case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
2710         case i_isIEEEDouble:
2711             {
2712                 PushTaggedBool(rtsTrue);
2713             }
2714             break;
2715         default:
2716                 barf("Unrecognised primop1");
2717         }
2718    return NULL;
2719 }
2720
2721
2722
2723 /* For normal cases, return NULL and leave *return2 unchanged.
2724    To return the address of the next thing to enter,
2725       return the address of it and leave *return2 unchanged.
2726    To return a StgThreadReturnCode to the scheduler,
2727       set *return2 to it and return a non-NULL value.
2728    To cause a context switch, set context_switch (its a global),
2729    and optionally set hugsBlock to your rational.
2730 */
2731 static void* enterBCO_primop2 ( int primop2code,
2732                                 int* /*StgThreadReturnCode* */ return2,
2733                                 StgBCO** bco,
2734                                 Capability* cap,
2735                                 HugsBlock *hugsBlock )
2736 {
2737         if (combined) {
2738            /* A small concession: we need to allow ccalls,
2739               even in combined mode.
2740            */
2741            if (primop2code != i_ccall_ccall_IO &&
2742                primop2code != i_ccall_stdcall_IO)
2743               barf("enterBCO_primop2 in combined mode");
2744         }
2745
2746         switch (primop2code) {
2747         case i_raise:  /* raise#{err} */
2748             {
2749                 StgClosure* err = PopCPtr();
2750                 return (raiseAnError(err));
2751             }
2752 #ifdef XMLAMBDA
2753 /*------------------------------------------------------------------------
2754   Insert and Remove primitives on Rows
2755 ------------------------------------------------------------------------*/
2756         case i_rowInsertAt:
2757             {
2758                 nat j;
2759                 /* get: row, index and value */
2760                 StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,PopPtr());
2761                 nat         i   = PopTaggedInt();
2762                 StgClosure* x   = PopCPtr();
2763
2764                 /* allocate new row */
2765                 StgWord     n    = row->ptrs;
2766                 StgMutArrPtrs* newRow
2767                     = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n + 1));
2768                 SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
2769                 newRow->ptrs = n+1;
2770
2771                 ASSERT(i <= n);
2772
2773                 /* copy the fields, inserting the new value */
2774                 for (j = 0; j < i; j++) {
2775                   newRow->payload[j] = row->payload[j];
2776                 }
2777                 newRow->payload[i] = x;
2778                 for (j = i+1; j <= n; j++)
2779                 {
2780                   newRow->payload[j] = row->payload[j-1];
2781                 }
2782
2783                 PushPtr(stgCast(StgPtr,newRow));
2784                 break;
2785             }
2786
2787         case i_rowRemoveAt:
2788             {
2789                 nat j;
2790                 /* get row and index */
2791                 StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,PopPtr());
2792                 nat         i   = PopTaggedInt(); /* or Word?? */
2793
2794                 /* allocate new row */
2795                 StgWord     n    = row->ptrs;
2796                 StgMutArrPtrs* newRow
2797                     = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n - 1));
2798                 SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
2799                 newRow->ptrs = n-1;
2800
2801                 ASSERT(i < n);
2802
2803                 /* copy the fields, except for the removed value. */
2804                 for (j = 0; j < i; j++) {
2805                   newRow->payload[j] = row->payload[j];
2806                 }
2807                 for (j = i+1; j < n; j++)
2808                 {
2809                   newRow->payload[j-1] = row->payload[j];
2810                 }
2811
2812                 PushCPtr(row->payload[i]);
2813                 PushPtr(stgCast(StgPtr,newRow));
2814                 break;
2815             }
2816 #endif /* XMLAMBDA */
2817
2818         case i_newRef:
2819             {
2820                 StgClosure* init = PopCPtr();
2821                 StgMutVar* mv
2822                     = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
2823                 SET_HDR(mv,&MUT_VAR_info,CCCS);
2824                 mv->var = init;
2825                 PushPtr(stgCast(StgPtr,mv));
2826                 break;
2827             }
2828         case i_readRef:
2829             {
2830                 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2831                 PushCPtr(mv->var);
2832                 break;
2833             }
2834         case i_writeRef:
2835             {
2836                 StgMutVar*  mv    = stgCast(StgMutVar*,PopPtr());
2837                 StgClosure* value = PopCPtr();
2838                 mv->var = value;
2839                 break;
2840             }
2841         case i_newArray:
2842             {
2843                 nat         n    = PopTaggedInt(); /* or Word?? */
2844                 StgClosure* init = PopCPtr();
2845                 StgWord     size = sizeofW(StgMutArrPtrs) + n;
2846                 nat i;
2847                 StgMutArrPtrs* arr
2848                     = stgCast(StgMutArrPtrs*,allocate(size));
2849                 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
2850                 arr->ptrs = n;
2851                 for (i = 0; i < n; ++i) {
2852                     arr->payload[i] = init;
2853                 }
2854                 PushPtr(stgCast(StgPtr,arr));
2855                 break;
2856             }
2857         case i_readArray:
2858         case i_indexArray:
2859             {
2860                 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2861                 nat         i   = PopTaggedInt(); /* or Word?? */
2862                 StgWord     n   = arr->ptrs;
2863                 if (i >= n) {
2864                     return (raiseIndex("{index,read}Array"));
2865                 }
2866                 PushCPtr(arr->payload[i]);
2867                 break;
2868             }
2869         case i_writeArray:
2870             {
2871                 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2872                 nat         i   = PopTaggedInt(); /* or Word? */
2873                 StgClosure* v   = PopCPtr();
2874                 StgWord     n   = arr->ptrs;
2875                 if (i >= n) {
2876                     return (raiseIndex("{index,read}Array"));
2877                 }
2878                 arr->payload[i] = v;
2879                 break;
2880             }
2881         case i_sizeArray:
2882         case i_sizeMutableArray:
2883             {
2884                 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2885                 PushTaggedInt(arr->ptrs);
2886                 break;
2887             }
2888         case i_unsafeFreezeArray:
2889             {
2890                 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2891                 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
2892                 PushPtr(stgCast(StgPtr,arr));
2893                 break;
2894             }
2895         case i_unsafeFreezeByteArray:
2896             {
2897                 /* Delightfully simple :-) */
2898                 break;
2899             }
2900         case i_sameRef:
2901         case i_sameMutableArray:
2902         case i_sameMutableByteArray:
2903             {
2904                 StgPtr x = PopPtr();
2905                 StgPtr y = PopPtr();
2906                 PushTaggedBool(x==y);
2907                 break;
2908             }
2909
2910         case i_newByteArray:
2911             {
2912                 nat     n     = PopTaggedInt(); /* or Word?? */
2913                 StgInt  words = (n+sizeof(W_)-1)/sizeof(W_);
2914                 StgWord size  = sizeofW(StgArrWords) + words;
2915                 StgArrWords* arr  = stgCast(StgArrWords*,allocate(size));
2916                 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2917                 arr->words = words;
2918 #ifdef DEBUG
2919                {nat i;
2920                for (i = 0; i < n; ++i) {
2921                     arr->payload[i] = 0xdeadbeef;
2922                }}
2923 #endif
2924                 PushPtr(stgCast(StgPtr,arr));
2925                 break;
2926             }
2927
2928         /* Most of these generate alignment warnings on Sparcs and similar architectures.
2929          * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
2930          */
2931         case i_indexCharArray:
2932             OP_mI_ty(Char,"indexCharArray",    indexCharArrayzh(r,x,i)); break;
2933         case i_readCharArray:
2934             OP_mI_ty(Char,"readCharArray",     readCharArrayzh(r,x,i));  break;
2935         case i_writeCharArray:
2936             OP_mIty_(Char,"writeCharArray",    writeCharArrayzh(x,i,z)); break;
2937
2938         case i_indexIntArray:
2939             OP_mI_ty(Int,"indexIntArray",      indexIntArrayzh(r,x,i)); break;
2940         case i_readIntArray:
2941             OP_mI_ty(Int,"readIntArray",       readIntArrayzh(r,x,i));  break;
2942         case i_writeIntArray:
2943             OP_mIty_(Int,"writeIntArray",      writeIntArrayzh(x,i,z)); break;
2944
2945         case i_indexAddrArray:
2946             OP_mI_ty(Addr,"indexAddrArray",   indexAddrArrayzh(r,x,i)); break;
2947         case i_readAddrArray:
2948             OP_mI_ty(Addr,"readAddrArray",    readAddrArrayzh(r,x,i));  break;
2949         case i_writeAddrArray:
2950             OP_mIty_(Addr,"writeAddrArray",   writeAddrArrayzh(x,i,z)); break;
2951
2952         case i_indexFloatArray:
2953             OP_mI_ty(Float,"indexFloatArray",  indexFloatArrayzh(r,x,i)); break;
2954         case i_readFloatArray:
2955             OP_mI_ty(Float,"readFloatArray",   readFloatArrayzh(r,x,i));  break;
2956         case i_writeFloatArray:
2957             OP_mIty_(Float,"writeFloatArray",  writeFloatArrayzh(x,i,z)); break;
2958
2959         case i_indexDoubleArray:
2960             OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break;
2961         case i_readDoubleArray:
2962             OP_mI_ty(Double,"readDoubleArray",  readDoubleArrayzh(r,x,i));  break;
2963         case i_writeDoubleArray:
2964             OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break;
2965
2966 #if 0
2967 #ifdef PROVIDE_STABLE
2968         case i_indexStableArray:
2969             OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break;
2970         case i_readStableArray:
2971             OP_mI_ty(StablePtr,"readStableArray",  readStablePtrArrayzh(r,x,i));  break;
2972         case i_writeStableArray:
2973             OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
2974 #endif
2975 #endif
2976
2977
2978
2979 #ifdef PROVIDE_COERCE
2980         case i_unsafeCoerce:
2981             {
2982                 /* Another nullop */
2983                 break;
2984             }
2985 #endif
2986 #ifdef PROVIDE_PTREQUALITY
2987         case i_reallyUnsafePtrEquality:
2988             { /* identical to i_sameRef */
2989                 StgPtr x = PopPtr();
2990                 StgPtr y = PopPtr();
2991                 PushTaggedBool(x==y);
2992                 break;
2993             }
2994 #endif
2995 #ifdef PROVIDE_FOREIGN
2996                 /* ForeignObj# operations */
2997         case i_mkForeignObj:
2998             {
2999                 StgForeignObj *result
3000                     = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
3001                 SET_HDR(result,&FOREIGN_info,CCCS);
3002                 result -> data      = PopTaggedAddr();
3003                 PushPtr(stgCast(StgPtr,result));
3004                 break;
3005             }
3006 #endif /* PROVIDE_FOREIGN */
3007 #ifdef PROVIDE_WEAK
3008         case i_makeWeak:
3009             {
3010                 StgWeak *w
3011                     = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
3012                 SET_HDR(w, &WEAK_info, CCCS);
3013                 w->key        = PopCPtr();
3014                 w->value      = PopCPtr();
3015                 w->finaliser  = PopCPtr();
3016                 w->link       = weak_ptr_list;
3017                 weak_ptr_list = w;
3018                 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
3019                 PushPtr(stgCast(StgPtr,w));
3020                 break;
3021             }
3022         case i_deRefWeak:
3023             {
3024                 StgWeak *w = stgCast(StgWeak*,PopPtr());
3025                 if (w->header.info == &WEAK_info) {
3026                     PushCPtr(w->value); /* last result  */
3027                     PushTaggedInt(1);   /* first result */
3028                 } else {
3029                     PushPtr(stgCast(StgPtr,w));
3030                            /* ToDo: error thunk would be better */
3031                     PushTaggedInt(0);
3032                 }
3033                 break;
3034             }
3035 #endif /* PROVIDE_WEAK */
3036
3037         case i_makeStablePtr:
3038             {
3039                 StgPtr       p  = PopPtr();
3040                 StgStablePtr sp = getStablePtr ( p );
3041                 PushTaggedStablePtr(sp);
3042                 break;
3043             }
3044         case i_deRefStablePtr:
3045             {
3046                 StgPtr p;
3047                 StgStablePtr sp = PopTaggedStablePtr();
3048                 p = deRefStablePtr(sp);
3049                 PushPtr(p);
3050                 break;
3051             }
3052         case i_freeStablePtr:
3053             {
3054                 StgStablePtr sp = PopTaggedStablePtr();
3055                 freeStablePtr(sp);
3056                 break;
3057             }
3058
3059         case i_createAdjThunkARCH:
3060             {
3061                 StgStablePtr stableptr = PopTaggedStablePtr();
3062                 StgAddr      typestr   = PopTaggedAddr();
3063                 StgChar      callconv  = PopTaggedChar();
3064                 StgAddr      adj_thunk = createAdjThunk(stableptr,typestr,callconv);
3065                 PushTaggedAddr(adj_thunk);
3066                 break;
3067             }
3068
3069         case i_getArgc:
3070             {
3071                 StgInt n = prog_argc;
3072                 PushTaggedInt(n);
3073                 break;
3074             }
3075         case i_getArgv:
3076             {
3077                 StgInt  n = PopTaggedInt();
3078                 StgAddr a = (StgAddr)prog_argv[n];
3079                 PushTaggedAddr(a);
3080                 break;
3081             }
3082
3083         case i_newMVar:
3084             {
3085                 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
3086                 SET_INFO(mvar,&EMPTY_MVAR_info);
3087                 mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
3088                 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
3089                 PushPtr(stgCast(StgPtr,mvar));
3090                 break;
3091             }
3092         case i_takeMVar:
3093             {
3094                 StgMVar *mvar = (StgMVar*)PopCPtr();
3095                 if (GET_INFO(mvar) == &EMPTY_MVAR_info) {
3096
3097                     /* The MVar is empty.  Attach ourselves to the TSO's
3098                        blocking queue.
3099                     */
3100                     if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
3101                         mvar->head = cap->rCurrentTSO;
3102                     } else {
3103                         mvar->tail->link = cap->rCurrentTSO;
3104                     }
3105                     cap->rCurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
3106                     cap->rCurrentTSO->why_blocked = BlockedOnMVar;
3107                     cap->rCurrentTSO->block_info.closure = (StgClosure *)mvar;
3108                     mvar->tail = cap->rCurrentTSO;
3109
3110                     /* At this point, the top-of-stack holds the MVar,
3111                        and underneath is the world token ().  So the
3112                        stack is in the same state as when primTakeMVar
3113                        was entered (primTakeMVar is handwritten bytecode).
3114                        Push obj, which is this BCO, and return to the
3115                        scheduler.  When the MVar is filled, the scheduler
3116                        will re-enter primTakeMVar, with the args still on
3117                        the top of the stack.
3118                     */
3119                     PushCPtr((StgClosure*)(*bco));
3120                     *return2 = ThreadBlocked;
3121                     return (void*)(1+(char*)(NULL));
3122
3123                 } else {
3124                     PushCPtr(mvar->value);
3125                     mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
3126                     SET_INFO(mvar,&EMPTY_MVAR_info);
3127                 }
3128                 break;
3129             }
3130         case i_putMVar:
3131             {
3132                 StgMVar*    mvar  = stgCast(StgMVar*,PopPtr());
3133                 StgClosure* value = PopCPtr();
3134                 if (GET_INFO(mvar) == &FULL_MVAR_info) {
3135                     return (makeErrorCall("putMVar {full MVar}"));
3136                 } else {
3137                     /* wake up the first thread on the
3138                      * queue, it will continue with the
3139                      * takeMVar operation and mark the
3140                      * MVar empty again.
3141                      */
3142                     mvar->value = value;
3143
3144                     if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
3145                        ASSERT(mvar->head->why_blocked == BlockedOnMVar);
3146                        mvar->head = unblockOne(mvar->head);
3147                        if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
3148                           mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
3149                        }
3150                     }
3151
3152                     /* unlocks the MVar in the SMP case */
3153                     SET_INFO(mvar,&FULL_MVAR_info);
3154
3155                     /* yield for better communication performance */
3156                     context_switch = 1;
3157                 }
3158                 break;
3159             }
3160         case i_sameMVar:
3161             {   /* identical to i_sameRef */
3162                 StgMVar* x = (StgMVar*)PopPtr();
3163                 StgMVar* y = (StgMVar*)PopPtr();
3164                 PushTaggedBool(x==y);
3165                 break;
3166             }
3167 #ifdef PROVIDE_CONCURRENT
3168         case i_forkIO:
3169             {
3170                 StgClosure* closure;
3171                 StgTSO*     tso;
3172                 StgWord     tid;
3173                 closure = PopCPtr();
3174                 tso     = createGenThread (RtsFlags.GcFlags.initialStkSize,closure);
3175                 tid     = tso->id;
3176                 scheduleThread(tso);
3177                 context_switch = 1;
3178                 /* Later: Change to use tso as the ThreadId */
3179                 PushTaggedWord(tid);
3180                 break;
3181             }
3182
3183         case i_killThread:
3184             {
3185                 StgWord n = PopTaggedWord();
3186                 StgTSO* tso = 0;
3187                 StgTSO *t;
3188
3189                 // Map from ThreadId to Thread Structure */
3190                 for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
3191                   if (n == t->id)
3192                     tso = t;
3193                 }
3194                 if (tso == 0) {
3195                   // Already dead
3196                   break;
3197                 }
3198
3199                 while (tso->what_next == ThreadRelocated) {
3200                   tso = tso->link;
3201                 }
3202
3203                 deleteThread(tso);
3204                 if (tso == cap->rCurrentTSO) { /* suicide */
3205                     *return2 = ThreadFinished;
3206                     return (void*)(1+(char*)(NULL));
3207                 }
3208                 break;
3209             }
3210         case i_raiseInThread:
3211           barf("raiseInThread");
3212           ASSERT(0); /* not (yet) supported */
3213         case i_delay:
3214           {
3215             StgInt  n = PopTaggedInt();
3216             context_switch = 1;
3217             hugsBlock->reason = BlockedOnDelay;
3218             hugsBlock->delay = n;
3219             break;
3220           }
3221         case i_waitRead:
3222           {
3223             StgInt  n = PopTaggedInt();
3224             context_switch = 1;
3225             hugsBlock->reason = BlockedOnRead;
3226             hugsBlock->delay = n;
3227             break;
3228           }
3229         case i_waitWrite:
3230           {
3231             StgInt  n = PopTaggedInt();
3232             context_switch = 1;
3233             hugsBlock->reason = BlockedOnWrite;
3234             hugsBlock->delay = n;
3235             break;
3236           }
3237         case i_yield:
3238           {
3239             /* The definition of yield include an enter right after
3240              * the primYield, at which time context_switch is tested.
3241              */
3242             context_switch = 1;
3243             break;
3244           }
3245         case i_getThreadId:
3246             {
3247                 StgWord tid = cap->rCurrentTSO->id;
3248                 PushTaggedWord(tid);
3249                 break;
3250             }
3251         case i_cmpThreadIds:
3252             {
3253                 StgWord tid1 = PopTaggedWord();
3254                 StgWord tid2 = PopTaggedWord();
3255                 if (tid1 < tid2) PushTaggedInt(-1);
3256                 else if (tid1 > tid2) PushTaggedInt(1);
3257                 else PushTaggedInt(0);
3258                 break;
3259             }
3260 #endif /* PROVIDE_CONCURRENT */
3261
3262         case i_ccall_ccall_Id:
3263         case i_ccall_ccall_IO:
3264         case i_ccall_stdcall_Id:
3265         case i_ccall_stdcall_IO:
3266             {
3267                 int r;
3268                 CFunDescriptor* descriptor;
3269                 void (*funPtr)(void);
3270                 char cc;
3271                 descriptor = PopTaggedAddr();
3272                 funPtr     = PopTaggedAddr();
3273                  cc = (primop2code == i_ccall_stdcall_Id ||
3274                            primop2code == i_ccall_stdcall_IO)
3275                           ? 's' : 'c';
3276                 r = ccall(descriptor,funPtr,bco,cc,cap);
3277                 if (r == 0) break;
3278                 if (r == 1)
3279                    return makeErrorCall(
3280                       "unhandled type or too many args/results in ccall");
3281                 if (r == 2)
3282                    barf("ccall not configured correctly for this platform");
3283                 barf("unknown return code from ccall");
3284             }
3285         default:
3286                 barf("Unrecognised primop2");
3287    }
3288    return NULL;
3289 }
3290
3291
3292 /* -----------------------------------------------------------------------------
3293  * ccall support code:
3294  *   marshall moves args from C stack to Haskell stack
3295  *   unmarshall moves args from Haskell stack to C stack
3296  *   argSize calculates how much gSpace you need on the C stack
3297  * ---------------------------------------------------------------------------*/
3298
3299 /* Pop arguments off the C stack and Push them onto the Hugs stack.
3300  * Used when preparing for C calling Haskell or in regSponse to
3301  *  Haskell calling C.
3302  */
3303 nat marshall(char arg_ty, void* arg)
3304 {
3305     switch (arg_ty) {
3306     case INT_REP:
3307             PushTaggedInt(*((int*)arg));
3308             return ARG_SIZE(INT_TAG);
3309 #if 0
3310     case INTEGER_REP:
3311             PushTaggedInteger(*((mpz_ptr*)arg));
3312             return ARG_SIZE(INTEGER_TAG);
3313 #endif
3314     case WORD_REP:
3315             PushTaggedWord(*((unsigned int*)arg));
3316             return ARG_SIZE(WORD_TAG);
3317     case CHAR_REP:
3318             PushTaggedChar(*((char*)arg));
3319             return ARG_SIZE(CHAR_TAG);
3320     case FLOAT_REP:
3321             PushTaggedFloat(*((float*)arg));
3322             return ARG_SIZE(FLOAT_TAG);
3323     case DOUBLE_REP:
3324             PushTaggedDouble(*((double*)arg));
3325             return ARG_SIZE(DOUBLE_TAG);
3326     case ADDR_REP:
3327             PushTaggedAddr(*((void**)arg));
3328             return ARG_SIZE(ADDR_TAG);
3329     case STABLE_REP:
3330             PushTaggedStablePtr(*((StgStablePtr*)arg));
3331             return ARG_SIZE(STABLE_TAG);
3332 #ifdef PROVIDE_FOREIGN
3333     case FOREIGN_REP:
3334             /* Not allowed in this direction - you have to
3335              * call makeForeignPtr explicitly
3336              */
3337             barf("marshall: ForeignPtr#\n");
3338             break;
3339 #endif
3340     case BARR_REP:
3341     case MUTBARR_REP:
3342             /* Not allowed in this direction  */
3343             barf("marshall: [Mutable]ByteArray#\n");
3344             break;
3345     default:
3346             barf("marshall: unrecognised arg type %d\n",arg_ty);
3347             break;
3348     }
3349 }
3350
3351 /* Pop arguments off the Hugs stack and Push them onto the C stack.
3352  * Used when preparing for Haskell calling C or in regSponse to
3353  * C calling Haskell.
3354  */
3355 nat unmarshall(char res_ty, void* res)
3356 {
3357     switch (res_ty) {
3358     case INT_REP:
3359             *((int*)res) = PopTaggedInt();
3360             return ARG_SIZE(INT_TAG);
3361 #if 0
3362     case INTEGER_REP:
3363             *((mpz_ptr*)res) = PopTaggedInteger();
3364             return ARG_SIZE(INTEGER_TAG);
3365 #endif
3366     case WORD_REP:
3367             *((unsigned int*)res) = PopTaggedWord();
3368             return ARG_SIZE(WORD_TAG);
3369     case CHAR_REP:
3370             *((int*)res) = PopTaggedChar();
3371             return ARG_SIZE(CHAR_TAG);
3372     case FLOAT_REP:
3373             *((float*)res) = PopTaggedFloat();
3374             return ARG_SIZE(FLOAT_TAG);
3375     case DOUBLE_REP:
3376             *((double*)res) = PopTaggedDouble();
3377             return ARG_SIZE(DOUBLE_TAG);
3378     case ADDR_REP:
3379             *((void**)res) = PopTaggedAddr();
3380             return ARG_SIZE(ADDR_TAG);
3381     case STABLE_REP:
3382             *((StgStablePtr*)res) = PopTaggedStablePtr();
3383             return ARG_SIZE(STABLE_TAG);
3384 #ifdef PROVIDE_FOREIGN
3385     case FOREIGN_REP:
3386         {
3387             StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
3388             *((void**)res) = result->data;
3389             return sizeofW(StgPtr);
3390         }
3391 #endif
3392     case BARR_REP:
3393     case MUTBARR_REP:
3394         {
3395             StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
3396             *((void**)res) = stgCast(void*,&(arr->payload));
3397             return sizeofW(StgPtr);
3398         }
3399     default:
3400             barf("unmarshall: unrecognised result type %d\n",res_ty);
3401     }
3402 }
3403
3404 nat argSize( const char* ks )
3405 {
3406     nat sz = 0;
3407     for( ; *ks != '\0'; ++ks) {
3408         switch (*ks) {
3409         case INT_REP:
3410                 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
3411                 break;
3412 #if 0
3413         case INTEGER_REP:
3414                 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
3415                 break;
3416 #endif
3417         case WORD_REP:
3418                 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
3419                 break;
3420         case CHAR_REP:
3421                 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
3422                 break;
3423         case FLOAT_REP:
3424                 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
3425                 break;
3426         case DOUBLE_REP:
3427                 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
3428                 break;
3429         case ADDR_REP:
3430                 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
3431                 break;
3432         case STABLE_REP:
3433                 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
3434                 break;
3435 #ifdef PROVIDE_FOREIGN
3436         case FOREIGN_REP:
3437 #endif
3438         case BARR_REP:
3439         case MUTBARR_REP:
3440                 sz += sizeof(StgPtr);
3441                 break;
3442         default:
3443                 barf("argSize: unrecognised result type %d\n",*ks);
3444                 break;
3445         }
3446     }
3447     return sz;
3448 }
3449
3450
3451 /* -----------------------------------------------------------------------------
3452  * encode/decode Float/Double code for standalone Hugs
3453  * Code based on the HBC code (lib/fltcode.c) and more recently GHC
3454  * (ghc/rts/StgPrimFloat.c)
3455  * ---------------------------------------------------------------------------*/
3456
3457 #if IEEE_FLOATING_POINT
3458 #define MY_DMINEXP  ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
3459 /* DMINEXP is defined in values.h on Linux (for example) */
3460 #define DHIGHBIT 0x00100000
3461 #define DMSBIT   0x80000000
3462
3463 #define MY_FMINEXP  ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
3464 #define FHIGHBIT 0x00800000
3465 #define FMSBIT   0x80000000
3466 #else
3467 #error The following code doesnt work in a non-IEEE FP environment
3468 #endif
3469
3470 #ifdef WORDS_BIGENDIAN
3471 #define L 1
3472 #define H 0
3473 #else
3474 #define L 0
3475 #define H 1
3476 #endif
3477
3478
3479 StgDouble B__encodeDouble (B* s, I_ e) /* result = s * 2^e */
3480 {
3481     StgDouble r;
3482     I_ i;
3483
3484     /* Convert a B to a double; knows a lot about internal rep! */
3485     for(r = 0.0, i = s->used-1; i >= 0; i--)
3486         r = (r * B_BASE_FLT) + s->stuff[i];
3487
3488     /* Now raise to the exponent */
3489     if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3490         r = ldexp(r, e);
3491
3492     /* handle the sign */
3493     if (s->sign < 0) r = -r;
3494
3495     return r;
3496 }
3497
3498
3499
3500 #if ! FLOATS_AS_DOUBLES
3501 StgFloat B__encodeFloat (B* s, I_ e) /* result = s * 2^e */
3502 {
3503     StgFloat r;
3504     I_ i;
3505
3506     /* Convert a B to a float; knows a lot about internal rep! */
3507     for(r = 0.0, i = s->used-1; i >= 0; i--)
3508         r = (r * B_BASE_FLT) + s->stuff[i];
3509
3510     /* Now raise to the exponent */
3511     if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
3512         r = ldexp(r, e);
3513
3514     /* handle the sign */
3515     if (s->sign < 0) r = -r;
3516
3517     return r;
3518 }
3519 #endif  /* FLOATS_AS_DOUBLES */
3520
3521
3522
3523 /* This only supports IEEE floating point */
3524 void B__decodeDouble (B* man, I_* exp, StgDouble dbl)
3525 {
3526     /* Do some bit fiddling on IEEE */
3527     nat low, high;              /* assuming 32 bit ints */
3528     int sign, iexp;
3529     union { double d; int i[2]; } u;    /* assuming 32 bit ints, 64 bit double */
3530
3531     u.d = dbl;      /* grab chunks of the double */
3532     low = u.i[L];
3533     high = u.i[H];
3534
3535     ASSERT(B_BASE == 256);
3536
3537     /* Assume that the supplied B is the right size */
3538     man->size = 8;
3539
3540     if (low == 0 && (high & ~DMSBIT) == 0) {
3541         man->sign = man->used = 0;
3542         *exp = 0L;
3543     } else {
3544         man->used = 8;
3545         man->sign = 1;
3546         iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
3547         sign = high;
3548
3549         high &= DHIGHBIT-1;
3550         if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
3551             high |= DHIGHBIT;
3552         else {
3553             iexp++;
3554             /* A denorm, normalize the mantissa */
3555             while (! (high & DHIGHBIT)) {
3556                 high <<= 1;
3557                 if (low & DMSBIT)
3558                     high++;
3559                 low <<= 1;
3560                 iexp--;
3561             }
3562         }
3563         *exp = (I_) iexp;
3564
3565         man->stuff[7] = (((W_)high) >> 24) & 0xff;
3566         man->stuff[6] = (((W_)high) >> 16) & 0xff;
3567         man->stuff[5] = (((W_)high) >>  8) & 0xff;
3568         man->stuff[4] = (((W_)high)      ) & 0xff;
3569
3570         man->stuff[3] = (((W_)low) >> 24) & 0xff;
3571         man->stuff[2] = (((W_)low) >> 16) & 0xff;
3572         man->stuff[1] = (((W_)low) >>  8) & 0xff;
3573         man->stuff[0] = (((W_)low)      ) & 0xff;
3574
3575         if (sign < 0) man->sign = -1;
3576     }
3577     do_renormalise(man);
3578 }
3579
3580
3581 #if ! FLOATS_AS_DOUBLES
3582 void B__decodeFloat (B* man, I_* exp, StgFloat flt)
3583 {
3584     /* Do some bit fiddling on IEEE */
3585     int high, sign;                 /* assuming 32 bit ints */
3586     union { float f; int i; } u;    /* assuming 32 bit float and int */
3587
3588     u.f = flt;      /* grab the float */
3589     high = u.i;
3590
3591     ASSERT(B_BASE == 256);
3592
3593     /* Assume that the supplied B is the right size */
3594     man->size = 4;
3595
3596     if ((high & ~FMSBIT) == 0) {
3597         man->sign = man->used = 0;
3598         *exp = 0;
3599     } else {
3600         man->used = 4;
3601         man->sign = 1;
3602         *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
3603         sign = high;
3604
3605         high &= FHIGHBIT-1;
3606         if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
3607             high |= FHIGHBIT;
3608         else {
3609             (*exp)++;
3610             /* A denorm, normalize the mantissa */
3611             while (! (high & FHIGHBIT)) {
3612                 high <<= 1;
3613                 (*exp)--;
3614             }
3615         }
3616         man->stuff[3] = (((W_)high) >> 24) & 0xff;
3617         man->stuff[2] = (((W_)high) >> 16) & 0xff;
3618         man->stuff[1] = (((W_)high) >>  8) & 0xff;
3619         man->stuff[0] = (((W_)high)      ) & 0xff;
3620
3621         if (sign < 0) man->sign = -1;
3622     }
3623     do_renormalise(man);
3624 }
3625
3626 #endif  /* FLOATS_AS_DOUBLES */
3627 #endif /* INTERPRETER */