ghc/rts/Evaluator.c

   1 /* -*- mode: hugs-c; -*- */
   2 /* -----------------------------------------------------------------------------
   3  * Bytecode evaluator
   4  *
   5  * Copyright (c) 1994-1998.
   6  *
   7  * $RCSfile: Evaluator.c,v $
   8  * $Revision: 1.2 $
   9  * $Date: 1998/12/02 13:28:17 $
  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
  23 #include "Bytecodes.h"
  24 #include "Assembler.h" /* for CFun stuff */
  25 #include "ForeignCall.h"
  26 #include "StablePtr.h"
  27 #include "PrimOps.h"   /* for __{encode,decode}{Float,Double} */
  28 #include "Evaluator.h"
  29
  30 #ifdef DEBUG
  31 #include "Printer.h"
  32 #include "Disassembler.h"
  33
  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 #ifdef PROVIDE_INTEGER
  45 #include "gmp.h"     /* These are for primops */
  46 #endif
  47
  48 /* An incredibly useful abbreviation.
  49  * Interestingly, there are some uses of END_TSO_QUEUE_closure that
  50  * can't use it because they use the closure at type StgClosure* or
  51  * even StgPtr*.  I suspect they should be changed.  -- ADR
  52  */
  53 #define EndTSOQueue stgCast(StgTSO*,(void*)&END_TSO_QUEUE_closure)
  54
  55 /* These macros are rather delicate - read a good ANSI C book carefully
  56  * before meddling.
  57  */
  58 #define mystr(x)      #x
  59 #define mycat(x,y)    x##y
  60 #define mycat2(x,y)   mycat(x,y)
  61 #define mycat3(x,y,z) mycat2(x,mycat2(y,z))
  62
  63 /* --------------------------------------------------------------------------
  64  * Hugs Hooks - a bit of a hack
  65  * ------------------------------------------------------------------------*/
  66
  67 void setRtsFlags( int x );
  68 void setRtsFlags( int x )
  69 {
  70     *(int*)(&(RtsFlags.DebugFlags)) = x;
  71 }
  72
  73 /* --------------------------------------------------------------------------
  74  * RTS Hooks
  75  *
  76  * ToDo: figure out why these are being used and crush them!
  77  * ------------------------------------------------------------------------*/
  78
  79 void OnExitHook (void)
  80 {
  81 }
  82 void StackOverflowHook (unsigned long stack_size)
  83 {
  84     fprintf(stderr,"Stack Overflow\n");
  85     exit(1);
  86 }
  87 void OutOfHeapHook (unsigned long request_size, unsigned long heap_size)
  88 {
  89     fprintf(stderr,"Out Of Heap\n");
  90     exit(1);
  91 }
  92 void MallocFailHook (unsigned long request_size /* in bytes */, char *msg)
  93 {
  94     fprintf(stderr,"Malloc Fail\n");
  95     exit(1);
  96 }
  97 void defaultsHook (void)
  98 {
  99     /* do nothing */
 100 }
 101
 102 /* --------------------------------------------------------------------------
 103  * MPZ helpers
 104  * ------------------------------------------------------------------------*/
 105
 106 #ifdef PROVIDE_INTEGER
 107 static inline mpz_ptr mpz_alloc ( void );
 108 static inline void    mpz_free  ( mpz_ptr );
 109
 110 static inline mpz_ptr mpz_alloc ( void )
 111 {
 112     mpz_ptr r = stgCast(mpz_ptr,stgMallocBytes( sizeof(mpz_t),"mpz_alloc"));
 113     mpz_init(r);
 114     return r;
 115 }
 116
 117 static inline void    mpz_free  ( mpz_ptr a )
 118 {
 119     mpz_clear(a);
 120     free(a);
 121 }
 122 #endif
 123
 124 /* --------------------------------------------------------------------------
 125  *
 126  * ------------------------------------------------------------------------*/
 127
 128 static inline void            PushTag            ( StackTag    t );
 129 static inline void            PushPtr            ( StgPtr      x );
 130 static inline void            PushCPtr           ( StgClosure* x );
 131 static inline void            PushInt            ( StgInt      x );
 132 static inline void            PushWord           ( StgWord     x );
 133
 134 static inline void            PushTag            ( StackTag    t ) { *(--Sp) = t; }
 135 static inline void            PushPtr            ( StgPtr      x ) { *(--stgCast(StgPtr*,Sp))  = x; }
 136 static inline void            PushCPtr           ( StgClosure* x ) { *(--stgCast(StgClosure**,Sp)) = x; }
 137 static inline void            PushInt            ( StgInt      x ) { *(--stgCast(StgInt*,Sp))  = x; }
 138 static inline void            PushWord           ( StgWord     x ) { *(--stgCast(StgWord*,Sp)) = x; }
 139
 140 static inline void            checkTag           ( StackTag t1, StackTag t2 );
 141 static inline void            PopTag             ( StackTag t );
 142 static inline StgPtr          PopPtr             ( void );
 143 static inline StgClosure*     PopCPtr            ( void );
 144 static inline StgInt          PopInt             ( void );
 145 static inline StgWord         PopWord            ( void );
 146
 147 static inline void            checkTag           ( StackTag t1, StackTag t2 ) { ASSERT(t1 == t2);}
 148 static inline void            PopTag             ( StackTag t ) { checkTag(t,*(Sp++));    }
 149 static inline StgPtr          PopPtr             ( void )       { return *stgCast(StgPtr*,Sp)++; }
 150 static inline StgClosure*     PopCPtr            ( void )       { return *stgCast(StgClosure**,Sp)++; }
 151 static inline StgInt          PopInt             ( void )       { return *stgCast(StgInt*,Sp)++;  }
 152 static inline StgWord         PopWord            ( void )       { return *stgCast(StgWord*,Sp)++; }
 153
 154 static inline StgPtr          stackPtr           ( StgStackOffset i );
 155 static inline StgInt          stackInt           ( StgStackOffset i );
 156 static inline StgWord         stackWord          ( StgStackOffset i );
 157
 158 static inline StgPtr          stackPtr           ( StgStackOffset i ) { return *stgCast(StgPtr*, Sp+i); }
 159 static inline StgInt          stackInt           ( StgStackOffset i ) { return *stgCast(StgInt*, Sp+i); }
 160 static inline StgWord         stackWord          ( StgStackOffset i ) { return *stgCast(StgWord*,Sp+i); }
 161
 162 static inline void            setStackWord       ( StgStackOffset i, StgWord w );
 163
 164 static inline void            setStackWord       ( StgStackOffset i, StgWord w ) { Sp[i] = w; }
 165
 166 static inline void            PushTaggedRealWorld( void         );
 167 static inline void            PushTaggedInt      ( StgInt     x );
 168 #ifdef PROVIDE_INT64
 169 static inline void            PushTaggedInt64    ( StgInt64   x );
 170 #endif
 171 #ifdef PROVIDE_INTEGER
 172 static inline void            PushTaggedInteger  ( mpz_ptr    x );
 173 #endif
 174 #ifdef PROVIDE_WORD
 175 static inline void            PushTaggedWord     ( StgWord    x );
 176 #endif
 177 #ifdef PROVIDE_ADDR
 178 static inline void            PushTaggedAddr     ( StgAddr    x );
 179 #endif
 180 static inline void            PushTaggedChar     ( StgChar    x );
 181 static inline void            PushTaggedFloat    ( StgFloat   x );
 182 static inline void            PushTaggedDouble   ( StgDouble  x );
 183 static inline void            PushTaggedStablePtr   ( StgStablePtr x );
 184 static inline void            PushTaggedBool     ( int        x );
 185
 186 static inline void            PushTaggedRealWorld( void            ) { PushTag(REALWORLD_TAG);  }
 187 static inline void            PushTaggedInt      ( StgInt        x ) { Sp -= sizeofW(StgInt);        *Sp = x;          PushTag(INT_TAG);    }
 188 #ifdef PROVIDE_INT64
 189 static inline void            PushTaggedInt64    ( StgInt64      x ) { Sp -= sizeofW(StgInt64);      ASSIGN_Int64(Sp,x); PushTag(INT64_TAG); }
 190 #endif
 191 #ifdef PROVIDE_INTEGER
 192 static inline void            PushTaggedInteger  ( mpz_ptr    x )
 193 {
 194     StgForeignObj *result;
 195     StgWeak *w;
 196
 197     result = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
 198     SET_HDR(result,&FOREIGN_info,CCCS);
 199     result -> data      = x;
 200
 201 #if 0 /* For now we don't deallocate Integer's at all */
 202     w = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
 203     SET_HDR(w, &WEAK_info, CCCS);
 204     w->key        = stgCast(StgClosure*,result);
 205     w->value      = stgCast(StgClosure*,result); /* or any other closure you have handy */
 206     w->finaliser  = funPtrToIO(mpz_free);
 207     w->link       = weak_ptr_list;
 208     weak_ptr_list = w;
 209     IF_DEBUG(weak, fprintf(stderr,"New weak pointer watching Foreign MPZ at %p\n",w));
 210 #endif
 211
 212     PushPtr(stgCast(StgPtr,result));
 213 }
 214 #endif
 215 #ifdef PROVIDE_WORD
 216 static inline void            PushTaggedWord     ( StgWord       x ) { Sp -= sizeofW(StgWord);       *Sp = x;          PushTag(WORD_TAG);   }
 217 #endif
 218 #ifdef PROVIDE_ADDR
 219 static inline void            PushTaggedAddr     ( StgAddr       x ) { Sp -= sizeofW(StgAddr);       *Sp = (W_)x;      PushTag(ADDR_TAG);   }
 220 #endif
 221 static inline void            PushTaggedChar     ( StgChar       x ) { Sp -= sizeofW(StgChar);       *Sp = x;          PushTag(CHAR_TAG);   }
 222 static inline void            PushTaggedFloat    ( StgFloat      x ) { Sp -= sizeofW(StgFloat);      ASSIGN_FLT(Sp,x); PushTag(FLOAT_TAG);  }
 223 static inline void            PushTaggedDouble   ( StgDouble     x ) { Sp -= sizeofW(StgDouble);     ASSIGN_DBL(Sp,x); PushTag(DOUBLE_TAG); }
 224 static inline void            PushTaggedStablePtr   ( StgStablePtr  x ) { Sp -= sizeofW(StgStablePtr);  *Sp = x;          PushTag(STABLE_TAG); }
 225 static inline void            PushTaggedBool     ( int           x ) { PushTaggedInt(x); }
 226
 227 static inline void            PopTaggedRealWorld ( void );
 228 static inline StgInt          PopTaggedInt       ( void );
 229 #ifdef PROVIDE_INT64
 230 static inline StgInt64        PopTaggedInt64     ( void );
 231 #endif
 232 #ifdef PROVIDE_INTEGER
 233 static inline mpz_ptr         PopTaggedInteger   ( void );
 234 #endif
 235 #ifdef PROVIDE_WORD
 236 static inline StgWord         PopTaggedWord      ( void );
 237 #endif
 238 #ifdef PROVIDE_ADDR
 239 static inline StgAddr         PopTaggedAddr      ( void );
 240 #endif
 241 static inline StgChar         PopTaggedChar      ( void );
 242 static inline StgFloat        PopTaggedFloat     ( void );
 243 static inline StgDouble       PopTaggedDouble    ( void );
 244 static inline StgStablePtr    PopTaggedStablePtr    ( void );
 245
 246 static inline void            PopTaggedRealWorld ( void ) { PopTag(REALWORLD_TAG); }
 247 static inline StgInt          PopTaggedInt       ( void ) { StgInt    r; PopTag(INT_TAG);     r = *stgCast(StgInt*,  Sp);      Sp += sizeofW(StgInt);        return r;}
 248 #ifdef PROVIDE_INT64
 249 static inline StgInt64        PopTaggedInt64     ( void ) { StgInt64  r; PopTag(INT64_TAG);   r = PK_Int64(Sp);                Sp += sizeofW(StgInt64);      return r;}
 250 #endif
 251 #ifdef PROVIDE_INTEGER
 252 static inline mpz_ptr         PopTaggedInteger   ( void ) { StgForeignObj *r = *stgCast(StgForeignObj**,Sp); Sp += sizeofW(StgPtr); return stgCast(mpz_ptr,r->data);}
 253 #endif
 254 #ifdef PROVIDE_WORD
 255 static inline StgWord         PopTaggedWord      ( void ) { StgWord   r; PopTag(WORD_TAG);    r = *stgCast(StgWord*, Sp);      Sp += sizeofW(StgWord);       return r;}
 256 #endif
 257 #ifdef PROVIDE_ADDR
 258 static inline StgAddr         PopTaggedAddr      ( void ) { StgAddr   r; PopTag(ADDR_TAG);    r = *stgCast(StgAddr*, Sp);      Sp += sizeofW(StgAddr);       return r;}
 259 #endif
 260 static inline StgChar         PopTaggedChar      ( void ) { StgChar   r; PopTag(CHAR_TAG);    r = *stgCast(StgChar*, Sp);      Sp += sizeofW(StgChar);       return r;}
 261 static inline StgFloat        PopTaggedFloat     ( void ) { StgFloat  r; PopTag(FLOAT_TAG);   r = PK_FLT(Sp);                  Sp += sizeofW(StgFloat);      return r;}
 262 static inline StgDouble       PopTaggedDouble    ( void ) { StgDouble r; PopTag(DOUBLE_TAG);  r = PK_DBL(Sp);                  Sp += sizeofW(StgDouble);     return r;}
 263 static inline StgStablePtr    PopTaggedStablePtr    ( void ) { StgInt    r; PopTag(STABLE_TAG);  r = *stgCast(StgStablePtr*, Sp); Sp += sizeofW(StgStablePtr);  return r;}
 264
 265 static inline StgInt          taggedStackInt     ( StgStackOffset i );
 266 #ifdef PROVIDE_INT64
 267 static inline StgInt64        taggedStackInt64   ( StgStackOffset i );
 268 #endif
 269 #ifdef PROVIDE_WORD
 270 static inline StgWord         taggedStackWord    ( StgStackOffset i );
 271 #endif
 272 #ifdef PROVIDE_ADDR
 273 static inline StgAddr         taggedStackAddr    ( StgStackOffset i );
 274 #endif
 275 static inline StgChar         taggedStackChar    ( StgStackOffset i );
 276 static inline StgFloat        taggedStackFloat   ( StgStackOffset i );
 277 static inline StgDouble       taggedStackDouble  ( StgStackOffset i );
 278 static inline StgStablePtr    taggedStackStable  ( StgStackOffset i );
 279
 280 static inline StgInt          taggedStackInt     ( StgStackOffset i ) { checkTag(INT_TAG,Sp[i]);     return *stgCast(StgInt*,         Sp+1+i); }
 281 #ifdef PROVIDE_INT64
 282 static inline StgInt64        taggedStackInt64   ( StgStackOffset i ) { checkTag(INT64_TAG,Sp[i]);   return PK_Int64(Sp+1+i); }
 283 #endif
 284 #ifdef PROVIDE_WORD
 285 static inline StgWord         taggedStackWord    ( StgStackOffset i ) { checkTag(WORD_TAG,Sp[i]);    return *stgCast(StgWord*,        Sp+1+i); }
 286 #endif
 287 #ifdef PROVIDE_ADDR
 288 static inline StgAddr         taggedStackAddr    ( StgStackOffset i ) { checkTag(ADDR_TAG,Sp[i]);    return *stgCast(StgAddr*,        Sp+1+i); }
 289 #endif
 290 static inline StgChar         taggedStackChar    ( StgStackOffset i ) { checkTag(CHAR_TAG,Sp[i]);    return *stgCast(StgChar*,        Sp+1+i); }
 291 static inline StgFloat        taggedStackFloat   ( StgStackOffset i ) { checkTag(FLOAT_TAG,Sp[i]);   return PK_FLT(Sp+1+i); }
 292 static inline StgDouble       taggedStackDouble  ( StgStackOffset i ) { checkTag(DOUBLE_TAG,Sp[i]);  return PK_DBL(Sp+1+i); }
 293 static inline StgStablePtr    taggedStackStable  ( StgStackOffset i ) { checkTag(STABLE_TAG,Sp[i]);  return *stgCast(StgStablePtr*,   Sp+1+i); }
 294
 295
 296 /* --------------------------------------------------------------------------
 297  * Heap allocation
 298  *
 299  * Should we allocate from a nursery or use the
 300  * doYouWantToGC/allocate interface?  We'd already implemented a
 301  * nursery-style scheme when the doYouWantToGC/allocate interface
 302  * was implemented.
 303  * One reason to prefer the doYouWantToGC/allocate interface is to
 304  * support operations which allocate an unknown amount in the heap
 305  * (array ops, gmp ops, etc)
 306  * ------------------------------------------------------------------------*/
 307
 308 static inline StgPtr grabHpUpd( nat size )
 309 {
 310     ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
 311     return allocate(size);
 312 }
 313
 314 static inline StgPtr grabHpNonUpd( nat size )
 315 {
 316     ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
 317     return allocate(size);
 318 }
 319
 320 /* --------------------------------------------------------------------------
 321  * Manipulate "update frame" list:
 322  * o Update frames           (based on stg_do_update and friends in Updates.hc)
 323  * o Error handling/catching (based on catchZh_fast and friends in Prims.hc)
 324  * o Seq frames              (based on seq_frame_entry in Prims.hc)
 325  * o Stop frames
 326  * ------------------------------------------------------------------------*/
 327
 328 static inline void PopUpdateFrame ( StgClosure* obj );
 329 static inline void PushCatchFrame ( StgClosure* catcher );
 330 static inline void PopCatchFrame  ( void );
 331 static inline void PushSeqFrame   ( void );
 332 static inline void PopSeqFrame    ( void );
 333
 334 static inline StgClosure* raiseAnError   ( StgClosure* errObj );
 335
 336 static inline void PopUpdateFrame( StgClosure* obj )
 337 {
 338     /* NB: doesn't assume that Sp == Su */
 339     IF_DEBUG(evaluator,
 340              fprintf(stderr,  "Updating ");
 341              printPtr(stgCast(StgPtr,Su->updatee));
 342              fprintf(stderr,  " with ");
 343              printObj(obj);
 344              fprintf(stderr,"\nSp = %p\tSu = %p\n", Sp, Su);
 345              );
 346 #ifndef LAZY_BLACKHOLING
 347     ASSERT(get_itbl(Su->updatee)->type == BLACKHOLE
 348            || get_itbl(Su->updatee)->type == CAF_BLACKHOLE
 349            );
 350 #endif /* LAZY_BLACKHOLING */
 351     UPD_IND(Su->updatee,obj);
 352     Sp = stgCast(StgStackPtr,Su) + sizeofW(StgUpdateFrame);
 353     Su = Su->link;
 354 }
 355
 356 static inline void PopStopFrame( StgClosure* obj )
 357 {
 358     /* Move Su just off the end of the stack, we're about to spam the
 359      * STOP_FRAME with the return value.
 360      */
 361     Su = stgCast(StgUpdateFrame*,Sp+1);
 362     *stgCast(StgClosure**,Sp) = obj;
 363 }
 364
 365 static inline void PushCatchFrame( StgClosure* handler )
 366 {
 367     StgCatchFrame* fp;
 368     /* ToDo: stack check! */
 369     Sp -= sizeofW(StgCatchFrame*);  /* ToDo: this can't be right */
 370     fp = stgCast(StgCatchFrame*,Sp);
 371     SET_HDR(fp,&catch_frame_info,CCCS);
 372     fp->handler         = handler;
 373     fp->link            = Su;
 374     Su = stgCast(StgUpdateFrame*,fp);
 375 }
 376
 377 static inline void PopCatchFrame( void )
 378 {
 379     /* NB: doesn't assume that Sp == Su */
 380     /* fprintf(stderr,"Popping catch frame\n"); */
 381     Sp = stgCast(StgStackPtr,Su) + sizeofW(StgCatchFrame);
 382     Su = stgCast(StgCatchFrame*,Su)->link;
 383 }
 384
 385 static inline void PushSeqFrame( void )
 386 {
 387     StgSeqFrame* fp;
 388     /* ToDo: stack check! */
 389     Sp -= sizeofW(StgSeqFrame*);  /* ToDo: this can't be right */
 390     fp = stgCast(StgSeqFrame*,Sp);
 391     SET_HDR(fp,&seq_frame_info,CCCS);
 392     fp->link = Su;
 393     Su = stgCast(StgUpdateFrame*,fp);
 394 }
 395
 396 static inline void PopSeqFrame( void )
 397 {
 398     /* NB: doesn't assume that Sp == Su */
 399     Sp = stgCast(StgStackPtr,Su) + sizeofW(StgSeqFrame);
 400     Su = stgCast(StgSeqFrame*,Su)->link;
 401 }
 402
 403 static inline StgClosure* raiseAnError( StgClosure* errObj )
 404 {
 405     while (1) {
 406         switch (get_itbl(Su)->type) {
 407         case UPDATE_FRAME:
 408                 UPD_INPLACE1(Su->updatee,&raise_info,errObj);
 409                 Sp = stgCast(StgStackPtr,Su) + sizeofW(StgUpdateFrame);
 410                 Su = Su->link;
 411                 break;
 412         case SEQ_FRAME:
 413                 PopSeqFrame();
 414                 break;
 415         case CATCH_FRAME:  /* found it! */
 416             {
 417                 StgCatchFrame* fp = stgCast(StgCatchFrame*,Su);
 418                 StgClosure *handler = fp->handler;
 419                 Su = fp->link;
 420                 Sp += sizeofW(StgCatchFrame); /* Pop */
 421                 PushCPtr(errObj);
 422                 return handler;
 423             }
 424         case STOP_FRAME:
 425                 barf("raiseError: STOP_FRAME");
 426         default:
 427                 barf("raiseError: weird activation record");
 428         }
 429     }
 430 }
 431
 432 static StgClosure* raisePrim(char* msg)
 433 {
 434     /* ToDo: figure out some way to turn the msg into a Haskell Exception
 435      * Hack: we don't know how to build an Exception but we do know how
 436      * to build a (recursive!) error object.
 437      * The result isn't pretty but it's (slightly) better than nothing.
 438      */
 439     nat size = sizeof(StgClosure) + 1;
 440     StgClosure* errObj = stgCast(StgClosure*,grabHpNonUpd(size));
 441     SET_INFO(errObj,&raise_info);
 442     errObj->payload[0] = errObj;
 443
 444 #if 0
 445     belch(msg);
 446 #else
 447     /* At the moment, I prefer to put it on stdout to make things as
 448      * close to Hugs' old behaviour as possible.
 449      */
 450     fprintf(stdout, "Program error: %s", msg);
 451     fflush(stdout);
 452 #endif
 453     return raiseAnError(stgCast(StgClosure*,errObj));
 454 }
 455
 456 #define raiseIndex(where) raisePrim("Array index out of range in " where)
 457 #define raiseDiv0(where)  raisePrim("Division by 0 in " where)
 458
 459 /* --------------------------------------------------------------------------
 460  * Evaluator
 461  * ------------------------------------------------------------------------*/
 462
 463 #define OP_CC_B(e)            \
 464 {                             \
 465     unsigned char x = PopTaggedChar(); \
 466     unsigned char y = PopTaggedChar(); \
 467     PushTaggedBool(e);        \
 468 }
 469
 470 #define OP_C_I(e)             \
 471 {                             \
 472     unsigned char x = PopTaggedChar(); \
 473     PushTaggedInt(e);         \
 474 }
 475
 476 #define OP__I(e)             \
 477 {                            \
 478     PushTaggedInt(e);        \
 479 }
 480
 481 #define OP_IW_I(e)           \
 482 {                            \
 483     StgInt  x = PopTaggedInt();  \
 484     StgWord y = PopTaggedWord();  \
 485     PushTaggedInt(e);        \
 486 }
 487
 488 #define OP_II_I(e)           \
 489 {                            \
 490     StgInt x = PopTaggedInt();  \
 491     StgInt y = PopTaggedInt();  \
 492     PushTaggedInt(e);        \
 493 }
 494
 495 #define OP_II_B(e)           \
 496 {                            \
 497     StgInt x = PopTaggedInt();  \
 498     StgInt y = PopTaggedInt();  \
 499     PushTaggedBool(e);       \
 500 }
 501
 502 #define OP__A(e)             \
 503 {                            \
 504     PushTaggedAddr(e);       \
 505 }
 506
 507 #define OP_I_A(e)            \
 508 {                            \
 509     StgInt x = PopTaggedInt();  \
 510     PushTaggedAddr(e);       \
 511 }
 512
 513 #define OP_I_I(e)            \
 514 {                            \
 515     StgInt x = PopTaggedInt();  \
 516     PushTaggedInt(e);        \
 517 }
 518
 519 #define OP__C(e)             \
 520 {                            \
 521     PushTaggedChar(e);       \
 522 }
 523
 524 #define OP_I_C(e)            \
 525 {                            \
 526     StgInt x = PopTaggedInt();  \
 527     PushTaggedChar(e);       \
 528 }
 529
 530 #define OP__W(e)              \
 531 {                             \
 532     PushTaggedWord(e);        \
 533 }
 534
 535 #define OP_I_W(e)            \
 536 {                            \
 537     StgInt x = PopTaggedInt();  \
 538     PushTaggedWord(e);       \
 539 }
 540
 541 #define OP__F(e)             \
 542 {                            \
 543     PushTaggedFloat(e);      \
 544 }
 545
 546 #define OP_I_F(e)            \
 547 {                            \
 548     StgInt x = PopTaggedInt();  \
 549     PushTaggedFloat(e);      \
 550 }
 551
 552 #define OP__D(e)             \
 553 {                            \
 554     PushTaggedDouble(e);     \
 555 }
 556
 557 #define OP_I_D(e)            \
 558 {                            \
 559     StgInt x = PopTaggedInt();  \
 560     PushTaggedDouble(e);     \
 561 }
 562
 563 #ifdef PROVIDE_WORD
 564 #define OP_WW_B(e)            \
 565 {                             \
 566     StgWord x = PopTaggedWord(); \
 567     StgWord y = PopTaggedWord(); \
 568     PushTaggedBool(e);        \
 569 }
 570
 571 #define OP_WW_W(e)            \
 572 {                             \
 573     StgWord x = PopTaggedWord(); \
 574     StgWord y = PopTaggedWord(); \
 575     PushTaggedWord(e);        \
 576 }
 577
 578 #define OP_W_I(e)             \
 579 {                             \
 580     StgWord x = PopTaggedWord(); \
 581     PushTaggedInt(e);         \
 582 }
 583
 584 #define OP_W_W(e)             \
 585 {                             \
 586     StgWord x = PopTaggedWord(); \
 587     PushTaggedWord(e);        \
 588 }
 589 #endif
 590
 591 #ifdef PROVIDE_ADDR
 592 #define OP_AA_B(e)            \
 593 {                             \
 594     StgAddr x = PopTaggedAddr(); \
 595     StgAddr y = PopTaggedAddr(); \
 596     PushTaggedBool(e);        \
 597 }
 598 #define OP_A_I(e)             \
 599 {                             \
 600     StgAddr x = PopTaggedAddr(); \
 601     PushTaggedInt(e);         \
 602 }
 603 #define OP_AI_C(s)            \
 604 {                             \
 605     StgAddr x = PopTaggedAddr(); \
 606     int  y = PopTaggedInt();  \
 607     StgChar r;                \
 608     s;                        \
 609     PushTaggedChar(r);        \
 610 }
 611 #define OP_AI_I(s)            \
 612 {                             \
 613     StgAddr x = PopTaggedAddr(); \
 614     int  y = PopTaggedInt();  \
 615     StgInt r;                 \
 616     s;                        \
 617     PushTaggedInt(r);         \
 618 }
 619 #define OP_AI_z(s)            \
 620 {                             \
 621     StgAddr x = PopTaggedAddr(); \
 622     int  y = PopTaggedInt();  \
 623     StgInt64 r;               \
 624     s;                        \
 625     PushTaggedInt64(r);       \
 626 }
 627 #define OP_AI_A(s)            \
 628 {                             \
 629     StgAddr x = PopTaggedAddr(); \
 630     int  y = PopTaggedInt();  \
 631     StgAddr r;                \
 632     s;                        \
 633     PushTaggedAddr(s);        \
 634 }
 635 #define OP_AI_F(s)            \
 636 {                             \
 637     StgAddr x = PopTaggedAddr(); \
 638     int  y = PopTaggedInt();  \
 639     StgFloat r;               \
 640     s;                        \
 641     PushTaggedFloat(r);       \
 642 }
 643 #define OP_AI_D(s)            \
 644 {                             \
 645     StgAddr x = PopTaggedAddr(); \
 646     int  y = PopTaggedInt();  \
 647     StgDouble r;              \
 648     s;                        \
 649     PushTaggedDouble(r);      \
 650 }
 651 #define OP_AI_s(s)            \
 652 {                             \
 653     StgAddr x = PopTaggedAddr(); \
 654     int  y = PopTaggedInt();  \
 655     StgStablePtr r;           \
 656     s;                        \
 657     PushTaggedStablePtr(r);      \
 658 }
 659 #define OP_AIC_(s)            \
 660 {                             \
 661     StgAddr x = PopTaggedAddr(); \
 662     int     y = PopTaggedInt();  \
 663     StgChar z = PopTaggedChar(); \
 664     s;                        \
 665 }
 666 #define OP_AII_(s)            \
 667 {                             \
 668     StgAddr x = PopTaggedAddr(); \
 669     int     y = PopTaggedInt();  \
 670     StgInt  z = PopTaggedInt(); \
 671     s;                        \
 672 }
 673 #define OP_AIz_(s)            \
 674 {                             \
 675     StgAddr x = PopTaggedAddr(); \
 676     int     y = PopTaggedInt();  \
 677     StgInt64 z = PopTaggedInt64(); \
 678     s;                        \
 679 }
 680 #define OP_AIA_(s)            \
 681 {                             \
 682     StgAddr x = PopTaggedAddr(); \
 683     int     y = PopTaggedInt();  \
 684     StgAddr z = PopTaggedAddr(); \
 685     s;                        \
 686 }
 687 #define OP_AIF_(s)            \
 688 {                             \
 689     StgAddr x = PopTaggedAddr(); \
 690     int     y = PopTaggedInt();  \
 691     StgFloat z = PopTaggedFloat(); \
 692     s;                        \
 693 }
 694 #define OP_AID_(s)            \
 695 {                             \
 696     StgAddr x = PopTaggedAddr(); \
 697     int     y = PopTaggedInt();  \
 698     StgDouble z = PopTaggedDouble(); \
 699     s;                        \
 700 }
 701 #define OP_AIs_(s)            \
 702 {                             \
 703     StgAddr x = PopTaggedAddr(); \
 704     int     y = PopTaggedInt();  \
 705     StgStablePtr z = PopTaggedStablePtr(); \
 706     s;                        \
 707 }
 708
 709 #endif /* PROVIDE_ADDR */
 710
 711 #define OP_FF_B(e)              \
 712 {                               \
 713     StgFloat x = PopTaggedFloat(); \
 714     StgFloat y = PopTaggedFloat(); \
 715     PushTaggedBool(e);          \
 716 }
 717
 718 #define OP_FF_F(e)              \
 719 {                               \
 720     StgFloat x = PopTaggedFloat(); \
 721     StgFloat y = PopTaggedFloat(); \
 722     PushTaggedFloat(e);         \
 723 }
 724
 725 #define OP_F_F(e)               \
 726 {                               \
 727     StgFloat x = PopTaggedFloat(); \
 728     PushTaggedFloat(e);         \
 729 }
 730
 731 #define OP_F_B(e)               \
 732 {                               \
 733     StgFloat x = PopTaggedFloat(); \
 734     PushTaggedBool(e);         \
 735 }
 736
 737 #define OP_F_I(e)               \
 738 {                               \
 739     StgFloat x = PopTaggedFloat(); \
 740     PushTaggedInt(e);           \
 741 }
 742
 743 #define OP_F_D(e)               \
 744 {                               \
 745     StgFloat x = PopTaggedFloat(); \
 746     PushTaggedDouble(e);        \
 747 }
 748
 749 #define OP_DD_B(e)                \
 750 {                                 \
 751     StgDouble x = PopTaggedDouble(); \
 752     StgDouble y = PopTaggedDouble(); \
 753     PushTaggedBool(e);            \
 754 }
 755
 756 #define OP_DD_D(e)                \
 757 {                                 \
 758     StgDouble x = PopTaggedDouble(); \
 759     StgDouble y = PopTaggedDouble(); \
 760     PushTaggedDouble(e);          \
 761 }
 762
 763 #define OP_D_B(e)                 \
 764 {                                 \
 765     StgDouble x = PopTaggedDouble(); \
 766     PushTaggedBool(e);          \
 767 }
 768
 769 #define OP_D_D(e)                 \
 770 {                                 \
 771     StgDouble x = PopTaggedDouble(); \
 772     PushTaggedDouble(e);          \
 773 }
 774
 775 #define OP_D_I(e)                 \
 776 {                                 \
 777     StgDouble x = PopTaggedDouble(); \
 778     PushTaggedInt(e);             \
 779 }
 780
 781 #define OP_D_F(e)                 \
 782 {                                 \
 783     StgDouble x = PopTaggedDouble(); \
 784     PushTaggedFloat(e);           \
 785 }
 786
 787 #ifdef PROVIDE_INT64
 788 #define OP_zI_F(e)                     \
 789 {                                      \
 790     StgInt64 x = PopTaggedInt64(); \
 791     int        y = PopTaggedInt();     \
 792     PushTaggedFloat(e);                \
 793 }
 794 #define OP_zI_D(e)                     \
 795 {                                      \
 796     StgInt64 x = PopTaggedInt64(); \
 797     int        y = PopTaggedInt();     \
 798     PushTaggedDouble(e);               \
 799 }
 800 #define OP_zz_I(e)                     \
 801 {                                      \
 802     StgInt64 x = PopTaggedInt64(); \
 803     StgInt64 y = PopTaggedInt64(); \
 804     PushTaggedInt(e);                  \
 805 }
 806 #define OP_z_z(e)                      \
 807 {                                      \
 808     StgInt64 x = PopTaggedInt64(); \
 809     PushTaggedInt64(e);              \
 810 }
 811 #define OP_zz_z(e)                     \
 812 {                                      \
 813     StgInt64 x = PopTaggedInt64(); \
 814     StgInt64 y = PopTaggedInt64(); \
 815     PushTaggedInt64(e);              \
 816 }
 817 #define OP_zW_z(e)                     \
 818 {                                      \
 819     StgInt64 x = PopTaggedInt64(); \
 820     StgWord  y = PopTaggedWord(); \
 821     PushTaggedInt64(e);              \
 822 }
 823 #define OP_zz_zZ(e1,e2)                \
 824 {                                      \
 825     StgInt64 x = PopTaggedInt64(); \
 826     StgInt64 y = PopTaggedInt64(); \
 827     PushTaggedInt64(e1);             \
 828     PushTaggedInt64(e2);             \
 829 }
 830 #define OP_zz_B(e)           \
 831 {                            \
 832     StgInt64 x = PopTaggedInt64();  \
 833     StgInt64 y = PopTaggedInt64();  \
 834     PushTaggedBool(e);       \
 835 }
 836 #define OP__z(e)             \
 837 {                            \
 838     PushTaggedInt64(e);        \
 839 }
 840 #define OP_z_I(e)                      \
 841 {                                      \
 842     StgInt64 x = PopTaggedInt64(); \
 843     PushTaggedInt(e);                  \
 844 }
 845 #define OP_I_z(e)                      \
 846 {                                      \
 847     StgInt x = PopTaggedInt();            \
 848     PushTaggedInt64(e);              \
 849 }
 850 #ifdef PROVIDE_WORD
 851 #define OP_z_W(e)                      \
 852 {                                      \
 853     StgInt64 x = PopTaggedInt64(); \
 854     PushTaggedWord(e);                 \
 855 }
 856 #define OP_W_z(e)                      \
 857 {                                      \
 858     StgWord x = PopTaggedWord();          \
 859     PushTaggedInt64(e);              \
 860 }
 861 #endif
 862 #define OP_z_F(e)                      \
 863 {                                      \
 864     StgInt64 x = PopTaggedInt64(); \
 865     printf("%lld = %f\n",x,(float)(e)); \
 866     PushTaggedFloat(e);                \
 867 }
 868 #define OP_F_z(e)                      \
 869 {                                      \
 870     StgFloat x = PopTaggedFloat();        \
 871     PushTaggedInt64(e);              \
 872 }
 873 #define OP_z_D(e)                      \
 874 {                                      \
 875     StgInt64 x = PopTaggedInt64(); \
 876     PushTaggedDouble(e);               \
 877 }
 878 #define OP_D_z(e)                      \
 879 {                                      \
 880     StgDouble x = PopTaggedDouble();      \
 881     PushTaggedInt64(e);              \
 882 }
 883 #endif
 884
 885 #ifdef PROVIDE_INTEGER
 886
 887 #define OP_ZI_F(e)                     \
 888 {                                      \
 889     mpz_ptr x = PopTaggedInteger();    \
 890     int   y = PopTaggedInt();          \
 891     PushTaggedFloat(e);                \
 892 }
 893 #define OP_F_ZI(s)                     \
 894 {                                      \
 895     StgFloat x = PopTaggedFloat();     \
 896     mpz_ptr r1 = mpz_alloc();          \
 897     StgInt r2;                         \
 898     s;                                 \
 899     PushTaggedInt(r2);                 \
 900     PushTaggedInteger(r1);             \
 901 }
 902 #define OP_ZI_D(e)                     \
 903 {                                      \
 904     mpz_ptr x = PopTaggedInteger();    \
 905     int   y = PopTaggedInt();          \
 906     PushTaggedDouble(e);               \
 907 }
 908 #define OP_D_ZI(s)                     \
 909 {                                      \
 910     StgDouble x = PopTaggedDouble();   \
 911     mpz_ptr r1 = mpz_alloc();          \
 912     StgInt r2;                         \
 913     s;                                 \
 914     PushTaggedInt(r2);                 \
 915     PushTaggedInteger(r1);             \
 916 }
 917 #define OP_Z_Z(s)                      \
 918 {                                      \
 919     mpz_ptr x = PopTaggedInteger();      \
 920     mpz_ptr r = mpz_alloc();           \
 921     s;                                 \
 922     PushTaggedInteger(r);              \
 923 }
 924 #define OP_ZZ_Z(s)                     \
 925 {                                      \
 926     mpz_ptr x = PopTaggedInteger();    \
 927     mpz_ptr y = PopTaggedInteger();    \
 928     mpz_ptr r = mpz_alloc();           \
 929     s;                                 \
 930     PushTaggedInteger(r);              \
 931 }
 932 #define OP_ZZ_B(e)           \
 933 {                            \
 934     mpz_ptr x = PopTaggedInteger();  \
 935     mpz_ptr y = PopTaggedInteger();  \
 936     PushTaggedBool(e);       \
 937 }
 938 #define OP_Z_I(e)                      \
 939 {                                      \
 940     mpz_ptr x = PopTaggedInteger();      \
 941     PushTaggedInt(e);                  \
 942 }
 943 #define OP_I_Z(s)                      \
 944 {                                      \
 945     StgInt x = PopTaggedInt();         \
 946     mpz_ptr r = mpz_alloc();           \
 947     s;                                 \
 948     PushTaggedInteger(r);              \
 949 }
 950 #ifdef PROVIDE_INT64
 951 #define OP_Z_z(e)                      \
 952 {                                      \
 953     mpz_ptr x = PopTaggedInteger(); \
 954     PushTaggedInt64(e);                  \
 955 }
 956 #define OP_z_Z(s)                      \
 957 {                                      \
 958     StgInt64 x = PopTaggedInt64();     \
 959     mpz_ptr r = mpz_alloc();           \
 960     s;                                 \
 961     PushTaggedInteger(r);              \
 962 }
 963 #endif
 964 #ifdef PROVIDE_WORD
 965 #define OP_Z_W(e)                      \
 966 {                                      \
 967     mpz_ptr x = PopTaggedInteger(); \
 968     PushTaggedWord(e);                 \
 969 }
 970 #define OP_W_Z(s)                      \
 971 {                                      \
 972     StgWord x = PopTaggedWord();       \
 973     mpz_ptr r = mpz_alloc();           \
 974     s;                                 \
 975     PushTaggedInteger(r);              \
 976 }
 977 #endif
 978 #define OP_Z_F(e)                      \
 979 {                                      \
 980     mpz_ptr x = PopTaggedInteger(); \
 981     PushTaggedFloat(e);                \
 982 }
 983 #define OP_F_Z(s)                      \
 984 {                                      \
 985     StgFloat x = PopTaggedFloat();        \
 986     mpz_ptr r = mpz_alloc();           \
 987     s;                                 \
 988     PushTaggedInteger(r);              \
 989 }
 990 #define OP_Z_D(e)                      \
 991 {                                      \
 992     mpz_ptr x = PopTaggedInteger(); \
 993     PushTaggedDouble(e);               \
 994 }
 995 #define OP_D_Z(s)                      \
 996 {                                      \
 997     StgDouble x = PopTaggedDouble();      \
 998     mpz_ptr r = mpz_alloc();           \
 999     s;                                 \
1000     PushTaggedInteger(r);              \
1001 }
1002
1003 #endif /* ifdef PROVIDE_INTEGER */
1004
1005 #ifdef PROVIDE_ARRAY
1006 #define HEADER_mI(ty,where)          \
1007     StgArrWords* x = stgCast(StgArrWords*,PopPtr()); \
1008     nat i = PopTaggedInt();   \
1009     if (i * sizeof(ty) + (sizeof(ty)) > sizeof(StgWord) * x->words) {        \
1010         obj = raiseIndex(where);  \
1011         goto enterLoop;           \
1012     }
1013 #define OP_mI_ty(ty,where,s)        \
1014 {                                   \
1015     HEADER_mI(mycat2(Stg,ty),where) \
1016     { mycat2(Stg,ty) r;             \
1017       s;                            \
1018       mycat2(PushTagged,ty)(r);     \
1019     }                               \
1020 }
1021 #define OP_mIty_(ty,where,s)        \
1022 {                                   \
1023     HEADER_mI(mycat2(Stg,ty),where) \
1024     {                               \
1025       mycat2(Stg,ty) z = mycat2(PopTagged,ty)(); \
1026       s;                            \
1027     }                               \
1028 }
1029
1030 #endif /* PROVIDE_ARRAY */
1031
1032
1033 /* This is written as one giant function in the hope that gcc will do
1034  * a better job of register allocation.
1035  */
1036 StgThreadReturnCode enter( StgClosure* obj )
1037 {
1038     /* We use a char so that we'll do a context_switch check every 256
1039      * iterations.
1040      */
1041     char enterCount = 0;
1042 enterLoop:
1043     /* ASSERT(StorageMgrInfo.hp_start <= Hp && Hp < HpLim && HpLim == StorageMgrInfo.hplim); */
1044     ASSERT(SpLim <= Sp && Sp <= stgCast(StgPtr,Su));
1045 #if 0
1046     IF_DEBUG(evaluator,
1047              fprintf(stderr,"Sp = %p\tSu = %p\n", Sp, Su);
1048              printStack(Sp,CurrentTSO->stack+CurrentTSO->stack_size,Su);
1049              fprintf(stderr,"Entering: "); printObj(obj);
1050     );
1051 #endif
1052 #if 0
1053     IF_DEBUG(sanity,
1054              {
1055                  /*belch("Starting sanity check");
1056                   *SaveThreadState();
1057                   *checkTSO(CurrentTSO, heap_step);
1058                   * This check fails if we've done any updates because we
1059                   * whack into holes in the heap.
1060                   *checkHeap(?,?);
1061                   *belch("Ending sanity check");
1062                   */
1063              }
1064              );
1065 #endif
1066 #if 0
1067     IF_DEBUG(evaluator,
1068              fprintf(stderr,"Continue?\n");
1069              getchar()
1070              );
1071 #endif
1072     if (++enterCount == 0 && context_switch) {
1073         PushCPtr(obj); /* code to restart with */
1074         return ThreadYielding;
1075     }
1076     switch ( get_itbl(obj)->type ) {
1077     case INVALID_OBJECT:
1078             barf("Invalid object %p",obj);
1079     case BCO:
1080         {
1081             StgBCO* bco = stgCast(StgBCO*,obj);
1082             InstrPtr pc = 0;
1083 #if 1  /* We don't use an explicit HP_CHECK anymore */
1084             if (doYouWantToGC()) {
1085                 PushCPtr(obj); /* code to restart with */
1086                 return HeapOverflow;
1087             }
1088 #endif
1089             while (1) {
1090                 ASSERT(pc < bco->n_instrs);
1091                 IF_DEBUG(evaluator,
1092                          fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", Sp, Su, pc);
1093                          disInstr(bco,pc);
1094                          /*fprintf(stderr,"\t"); printStackObj(Sp); */
1095                          fprintf(stderr,"\n");
1096                          );
1097                 switch (bcoInstr(bco,pc++)) {
1098                 case i_INTERNAL_ERROR:
1099                         barf("INTERNAL_ERROR at %p:%d",bco,pc-1);
1100                 case i_PANIC:
1101                         barf("PANIC at %p:%d",bco,pc-1);
1102 #if 0
1103                 case i_HP_CHECK:
1104                     {
1105                         int n = bcoInstr(bco,pc++);
1106                         /* ToDo: we could allocate the whole thing now and
1107                          * slice it up ourselves
1108                          */
1109                         if (doYouWantToGC()) {
1110                             PushCPtr(obj); /* code to restart with */
1111                             return HeapOverflow;
1112                         }
1113                         break;
1114                     }
1115 #endif
1116                 case i_STK_CHECK:
1117                     {
1118                         int n = bcoInstr(bco,pc++);
1119                         if (Sp - n < SpLim) {
1120                             PushCPtr(obj); /* code to restart with */
1121                             return StackOverflow;
1122                         }
1123                         break;
1124                     }
1125                 case i_ARG_CHECK:
1126                     {
1127                         /* ToDo: make sure that hp check allows for possible PAP */
1128                         nat n = bcoInstr(bco,pc++);
1129                         if (stgCast(StgPtr,Sp + n) > stgCast(StgPtr,Su)) {
1130                             StgWord words = (P_)Su - Sp;
1131
1132                             /* first build a PAP */
1133                             ASSERT((P_)Su >= Sp);  /* was (words >= 0) but that's always true */
1134                             if (words == 0) { /* optimisation */
1135                                 /* Skip building the PAP and update with an indirection. */
1136                             } else { /* Build the PAP. */
1137                                 /* In the evaluator, we avoid the need to do
1138                                  * a heap check here by including the size of
1139                                  * the PAP in the heap check we performed
1140                                  * when we entered the BCO.
1141                                  */
1142                                 StgInt  i;
1143                                 StgPAP* pap = stgCast(StgPAP*,grabHpNonUpd(PAP_sizeW(words)));
1144                                 SET_HDR(pap,&PAP_info,CC_pap);
1145                                 pap->n_args = words;
1146                                 pap->fun = obj;
1147                                 for(i = 0; i < (I_)words; ++i) {
1148                                     payloadWord(pap,i) = Sp[i];
1149                                 }
1150                                 Sp += words;
1151                                 obj = stgCast(StgClosure*,pap);
1152                             }
1153
1154                             /* now deal with "update frame" */
1155                             /* as an optimisation, we process all on top of stack instead of just the top one */
1156                             ASSERT(Sp==(P_)Su);
1157                             do {
1158                                 switch (get_itbl(Su)->type) {
1159                                 case CATCH_FRAME:
1160                                         PopCatchFrame();
1161                                         break;
1162                                 case UPDATE_FRAME:
1163                                         PopUpdateFrame(obj);
1164                                         break;
1165                                 case STOP_FRAME:
1166                                         PopStopFrame(obj);
1167                                         return ThreadFinished;
1168                                 case SEQ_FRAME:
1169                                         PopSeqFrame();
1170                                         break;
1171                                 default:
1172                                         barf("Invalid update frame during argcheck");
1173                                 }
1174                             } while (Sp==(P_)Su);
1175                             goto enterLoop;
1176                         }
1177                         break;
1178                     }
1179                 case i_ALLOC_AP:
1180                     {
1181                         int words = bcoInstr(bco,pc++);
1182                         PushPtr(grabHpUpd(AP_sizeW(words)));
1183                         break;
1184                     }
1185                 case i_ALLOC_CONSTR:
1186                     {
1187                         StgInfoTable* info = bcoConstAddr(bco,bcoInstr(bco,pc++));
1188                         StgClosure* c = stgCast(StgClosure*,grabHpNonUpd(sizeW_fromITBL(info)));
1189                         SET_HDR(c,info,??);
1190                         PushPtr(stgCast(StgPtr,c));
1191                         break;
1192                     }
1193                 case i_MKAP:
1194                     {
1195                         int x = bcoInstr(bco,pc++);  /* ToDo: Word not Int! */
1196                         int y = bcoInstr(bco,pc++);
1197                         StgAP_UPD* o = stgCast(StgAP_UPD*,stackPtr(x));
1198                         SET_HDR(o,&AP_UPD_info,??);
1199                         o->n_args = y;
1200                         o->fun    = stgCast(StgClosure*,PopPtr());
1201                         for(x=0; x < y; ++x) {
1202                             payloadWord(o,x) = PopWord();
1203                         }
1204                         IF_DEBUG(evaluator,
1205                                  fprintf(stderr,"\tBuilt ");
1206                                  printObj(stgCast(StgClosure*,o));
1207                         );
1208                         break;
1209                     }
1210                 case i_MKPAP:
1211                     {
1212                         int x = bcoInstr(bco,pc++);
1213                         int y = bcoInstr(bco,pc++);
1214                         StgPAP* o = stgCast(StgPAP*,stackPtr(x));
1215                         SET_HDR(o,&PAP_info,??);
1216                         o->n_args = y;
1217                         o->fun    = stgCast(StgClosure*,PopPtr());
1218                         for(x=0; x < y; ++x) {
1219                             payloadWord(o,x) = PopWord();
1220                         }
1221                         IF_DEBUG(evaluator,
1222                                  fprintf(stderr,"\tBuilt ");
1223                                  printObj(stgCast(StgClosure*,o));
1224                                  );
1225                         break;
1226                     }
1227                 case i_PACK:
1228                     {
1229                         int offset = bcoInstr(bco,pc++);
1230                         StgClosure* o = stgCast(StgClosure*,stackPtr(offset));
1231                         const StgInfoTable* info = get_itbl(o);
1232                         nat p  = info->layout.payload.ptrs;
1233                         nat np = info->layout.payload.nptrs;
1234                         nat i;
1235                         for(i=0; i < p; ++i) {
1236                             payloadCPtr(o,i) = PopCPtr();
1237                         }
1238                         for(i=0; i < np; ++i) {
1239                             payloadWord(o,p+i) = 0xdeadbeef;
1240                         }
1241                         IF_DEBUG(evaluator,
1242                                  fprintf(stderr,"\tBuilt ");
1243                                  printObj(stgCast(StgClosure*,o));
1244                                  );
1245                         break;
1246                     }
1247                 case i_SLIDE:
1248                     {
1249                         int x = bcoInstr(bco,pc++);
1250                         int y = bcoInstr(bco,pc++);
1251                         ASSERT(Sp+x+y <= stgCast(StgPtr,Su));
1252                         /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
1253                         while(--x >= 0) {
1254                             setStackWord(x+y,stackWord(x));
1255                         }
1256                         Sp += y;
1257                         break;
1258                     }
1259                 case i_ENTER:
1260                     {
1261                         obj = PopCPtr();
1262                         goto enterLoop;
1263                     }
1264                 case i_RETADDR:
1265                     {
1266                         PushPtr(bcoConstPtr(bco,bcoInstr(bco,pc++)));
1267                         PushPtr(stgCast(StgPtr,&ret_bco_info));
1268                         break;
1269                     }
1270                 case i_TEST:
1271                     {
1272                         int  tag       = bcoInstr(bco,pc++);
1273                         StgWord offset = bcoInstr(bco,pc++);
1274                         if (constrTag(stgCast(StgClosure*,stackPtr(0))) != tag) {
1275                             pc += offset;
1276                         }
1277                         break;
1278                     }
1279                 case i_UNPACK:
1280                     {
1281                         StgClosure* o = stgCast(StgClosure*,stackPtr(0));
1282                         const StgInfoTable* itbl = get_itbl(o);
1283                         int i = itbl->layout.payload.ptrs;
1284                         ASSERT(  itbl->type == CONSTR
1285                               || itbl->type == CONSTR_STATIC
1286                               || itbl->type == CONSTR_NOCAF_STATIC
1287                               );
1288                         while (--i>=0) {
1289                             PushCPtr(payloadCPtr(o,i));
1290                         }
1291                         break;
1292                     }
1293                 case i_VAR:
1294                     {
1295                         PushPtr(stackPtr(bcoInstr(bco,pc++)));
1296                         break;
1297                     }
1298                 case i_CONST:
1299                     {
1300                         PushPtr(stgCast(StgPtr,bcoConstPtr(bco,bcoInstr(bco,pc++))));
1301                         break;
1302                     }
1303                 case i_CONST2:
1304                     {
1305                         StgWord o1 = bcoInstr(bco,pc++);
1306                         StgWord o2 = bcoInstr(bco,pc++);
1307                         StgWord o  = o1*256 + o2;
1308                         PushPtr(stgCast(StgPtr,bcoConstPtr(bco,o)));
1309                         break;
1310                     }
1311                 case i_VOID:
1312                     {
1313                         PushTaggedRealWorld();
1314                         break;
1315                     }
1316                 case i_VAR_INT:
1317                     {
1318                         PushTaggedInt(taggedStackInt(bcoInstr(bco,pc++)));
1319                         break;
1320                     }
1321                 case i_CONST_INT:
1322                     {
1323                         PushTaggedInt(bcoConstInt(bco,bcoInstr(bco,pc++)));
1324                         break;
1325                     }
1326                 case i_RETURN_INT:
1327                     {
1328                         ASSERT(0);
1329                         break;
1330                     }
1331                 case i_PACK_INT:
1332                     {
1333                         StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(IZh_sizeW));
1334                         SET_HDR(o,&IZh_con_info,??);
1335                         payloadWord(o,0) = PopTaggedInt();
1336                         IF_DEBUG(evaluator,
1337                                  fprintf(stderr,"\tBuilt ");
1338                                  printObj(stgCast(StgClosure*,o));
1339                                  );
1340                         PushPtr(stgCast(StgPtr,o));
1341                         break;
1342                     }
1343                 case i_UNPACK_INT:
1344                     {
1345                         StgClosure* con = stgCast(StgClosure*,stackPtr(0));
1346                         /* ASSERT(isIntLike(con)); */
1347                         PushTaggedInt(payloadWord(con,0));
1348                         break;
1349                     }
1350                 case i_TEST_INT:
1351                     {
1352                         StgWord offset = bcoInstr(bco,pc++);
1353                         StgInt  x      = PopTaggedInt();
1354                         StgInt  y      = PopTaggedInt();
1355                         if (x != y) {
1356                             pc += offset;
1357                         }
1358                         break;
1359                     }
1360 #ifdef PROVIDE_INT64
1361                 case i_VAR_INT64:
1362                     {
1363                         PushTaggedInt64(taggedStackInt64(bcoInstr(bco,pc++)));
1364                         break;
1365                     }
1366                 case i_CONST_INT64:
1367                     {
1368                         PushTaggedInt64(bcoConstInt64(bco,bcoInstr(bco,pc++)));
1369                         break;
1370                     }
1371                 case i_RETURN_INT64:
1372                     {
1373                         ASSERT(0); /* ToDo(); */
1374                         break;
1375                     }
1376                 case i_PACK_INT64:
1377                     {
1378                         StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(I64Zh_sizeW));
1379                         SET_HDR(o,&I64Zh_con_info,??);
1380                         ASSIGN_Int64(&payloadWord(o,0),PopTaggedInt64());
1381                         IF_DEBUG(evaluator,
1382                                  fprintf(stderr,"\tBuilt ");
1383                                  printObj(stgCast(StgClosure*,o));
1384                                  );
1385                         PushPtr(stgCast(StgPtr,o));
1386                         break;
1387                     }
1388                 case i_UNPACK_INT64:
1389                     {
1390                         StgClosure* con = stgCast(StgClosure*,stackPtr(0));
1391                         /*ASSERT(isInt64Like(con)); */
1392                         PushTaggedInt64(PK_Int64(&payloadWord(con,0)));
1393                         break;
1394                     }
1395 #endif
1396 #ifdef PROVIDE_INTEGER
1397                 case i_CONST_INTEGER:
1398                     {
1399                         char* s = bcoConstAddr(bco,bcoInstr(bco,pc++));
1400                         mpz_ptr r = mpz_alloc();
1401                         if (s[0] == '0' && s[1] == 'x') {
1402                             mpz_set_str(r,s+2,16);
1403                         } else {
1404                             mpz_set_str(r,s,10);
1405                         }
1406                         PushTaggedInteger(r);
1407                         break;
1408                     }
1409 #endif
1410
1411 #ifdef PROVIDE_WORD
1412                 case i_VAR_WORD:
1413                     {
1414                         PushTaggedWord(taggedStackWord(bcoInstr(bco,pc++)));
1415                         break;
1416                     }
1417                 case i_CONST_WORD:
1418                     {
1419                         PushTaggedWord(bcoConstWord(bco,bcoInstr(bco,pc++)));
1420                         break;
1421                     }
1422                 case i_RETURN_WORD:
1423                     {
1424                         ASSERT(0);
1425                         break;
1426                     }
1427                 case i_PACK_WORD:
1428                     {
1429                         StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(WZh_sizeW));
1430
1431                         SET_HDR(o,&WZh_con_info,??);
1432                         payloadWord(o,0) = PopTaggedWord();
1433                         IF_DEBUG(evaluator,
1434                                  fprintf(stderr,"\tBuilt ");
1435                                  printObj(stgCast(StgClosure*,o));
1436                                  );
1437                         PushPtr(stgCast(StgPtr,o));
1438                         break;
1439                     }
1440                 case i_UNPACK_WORD:
1441                     {
1442                         StgClosure* con = stgCast(StgClosure*,stackPtr(0));
1443                         /* ASSERT(isWordLike(con)); */
1444                         PushTaggedWord(payloadWord(con,0));
1445                         break;
1446                     }
1447 #endif
1448 #ifdef PROVIDE_ADDR
1449                 case i_VAR_ADDR:
1450                     {
1451                         PushTaggedAddr(taggedStackAddr(bcoInstr(bco,pc++)));
1452                         break;
1453                     }
1454                 case i_CONST_ADDR:
1455                     {
1456                         PushTaggedAddr(bcoConstAddr(bco,bcoInstr(bco,pc++)));
1457                         break;
1458                     }
1459                 case i_RETURN_ADDR:
1460                     {
1461                         ASSERT(0);
1462                         break;
1463                     }
1464                 case i_PACK_ADDR:
1465                     {
1466                         StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(AZh_sizeW));
1467                         SET_HDR(o,&AZh_con_info,??);
1468                         payloadPtr(o,0) = PopTaggedAddr();
1469                         IF_DEBUG(evaluator,
1470                                  fprintf(stderr,"\tBuilt ");
1471                                  printObj(stgCast(StgClosure*,o));
1472                                  );
1473                         PushPtr(stgCast(StgPtr,o));
1474                         break;
1475                     }
1476                 case i_UNPACK_ADDR:
1477                     {
1478                         StgClosure* con = stgCast(StgClosure*,stackPtr(0));
1479                         /* ASSERT(isAddrLike(con)); */
1480                         PushTaggedAddr(payloadPtr(con,0));
1481                         break;
1482                     }
1483 #endif
1484                 case i_VAR_CHAR:
1485                     {
1486                         PushTaggedChar(taggedStackChar(bcoInstr(bco,pc++)));
1487                         break;
1488                     }
1489                 case i_CONST_CHAR:
1490                     {
1491                         PushTaggedChar(bcoConstChar(bco,bcoInstr(bco,pc++)));
1492                         break;
1493                     }
1494                 case i_RETURN_CHAR:
1495                     {
1496                         ASSERT(0);
1497                         break;
1498                     }
1499                 case i_PACK_CHAR:
1500                     {
1501                         StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(CZh_sizeW));
1502                         SET_HDR(o,&CZh_con_info,??);
1503                         payloadWord(o,0) = PopTaggedChar();
1504                         PushPtr(stgCast(StgPtr,o));
1505                         IF_DEBUG(evaluator,
1506                                  fprintf(stderr,"\tBuilt ");
1507                                  printObj(stgCast(StgClosure*,o));
1508                                  );
1509                         break;
1510                     }
1511                 case i_UNPACK_CHAR:
1512                     {
1513                         StgClosure* con = stgCast(StgClosure*,stackPtr(0));
1514                         /* ASSERT(isCharLike(con)); */
1515                         PushTaggedChar(payloadWord(con,0));
1516                         break;
1517                     }
1518                 case i_VAR_FLOAT:
1519                     {
1520                         PushTaggedFloat(taggedStackFloat(bcoInstr(bco,pc++)));
1521                         break;
1522                     }
1523                 case i_CONST_FLOAT:
1524                     {
1525                         PushTaggedFloat(bcoConstFloat(bco,bcoInstr(bco,pc++)));
1526                         break;
1527                     }
1528                 case i_RETURN_FLOAT:
1529                     {
1530                         ASSERT(0);
1531                         break;
1532                     }
1533                 case i_PACK_FLOAT:
1534                     {
1535                         StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(FZh_sizeW));
1536                         SET_HDR(o,&FZh_con_info,??);
1537                         ASSIGN_FLT(&payloadWord(o,0),PopTaggedFloat());
1538                         IF_DEBUG(evaluator,
1539                                  fprintf(stderr,"\tBuilt ");
1540                                  printObj(stgCast(StgClosure*,o));
1541                                  );
1542                         PushPtr(stgCast(StgPtr,o));
1543                         break;
1544                     }
1545                 case i_UNPACK_FLOAT:
1546                     {
1547                         StgClosure* con = stgCast(StgClosure*,stackPtr(0));
1548                         /* ASSERT(isFloatLike(con)); */
1549                         PushTaggedFloat(PK_FLT(&payloadWord(con,0)));
1550                         break;
1551                     }
1552                 case i_VAR_DOUBLE:
1553                     {
1554                         PushTaggedDouble(taggedStackDouble(bcoInstr(bco,pc++)));
1555                         break;
1556                     }
1557                 case i_CONST_DOUBLE:
1558                     {
1559                         PushTaggedDouble(bcoConstDouble(bco,bcoInstr(bco,pc++)));
1560                         break;
1561                     }
1562                 case i_RETURN_DOUBLE:
1563                     {
1564                         ASSERT(0);
1565                         break;
1566                     }
1567                 case i_PACK_DOUBLE:
1568                     {
1569                         StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(DZh_sizeW));
1570                         SET_HDR(o,&DZh_con_info,??);
1571                         ASSIGN_DBL(&payloadWord(o,0),PopTaggedDouble());
1572                         IF_DEBUG(evaluator,
1573                                  fprintf(stderr,"\tBuilt ");
1574                                  printObj(stgCast(StgClosure*,o));
1575                                  );
1576                         PushPtr(stgCast(StgPtr,o));
1577                         break;
1578                     }
1579                 case i_UNPACK_DOUBLE:
1580                     {
1581                         StgClosure* con = stgCast(StgClosure*,stackPtr(0));
1582                         /* ASSERT(isDoubleLike(con)); */
1583                         PushTaggedDouble(PK_DBL(&payloadWord(con,0)));
1584                         break;
1585                     }
1586 #ifdef PROVIDE_STABLE
1587                 case i_VAR_STABLE:
1588                     {
1589                         PushTaggedStablePtr(taggedStackStable(bcoInstr(bco,pc++)));
1590                         break;
1591                     }
1592                 case i_RETURN_STABLE:
1593                     {
1594                         ASSERT(0);
1595                         break;
1596                     }
1597                 case i_PACK_STABLE:
1598                     {
1599                         StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(StableZh_sizeW));
1600                         SET_HDR(o,&StablePtr_con_info,??);
1601                         payloadWord(o,0) = PopTaggedStablePtr();
1602                         IF_DEBUG(evaluator,
1603                                  fprintf(stderr,"\tBuilt ");
1604                                  printObj(stgCast(StgClosure*,o));
1605                                  );
1606                         PushPtr(stgCast(StgPtr,o));
1607                         break;
1608                     }
1609                 case i_UNPACK_STABLE:
1610                     {
1611                         StgClosure* con = stgCast(StgClosure*,stackPtr(0));
1612                         /* ASSERT(isStableLike(con)); */
1613                         PushTaggedStablePtr(payloadWord(con,0));
1614                         break;
1615                     }
1616 #endif
1617                 case i_PRIMOP1:
1618                     {
1619                         switch (bcoInstr(bco,pc++)) {
1620                         case i_INTERNAL_ERROR1:
1621                                 barf("INTERNAL_ERROR1 at %p:%d",bco,pc-1);
1622
1623                         case i_gtChar:          OP_CC_B(x>y);        break;
1624                         case i_geChar:          OP_CC_B(x>=y);       break;
1625                         case i_eqChar:          OP_CC_B(x==y);       break;
1626                         case i_neChar:          OP_CC_B(x!=y);       break;
1627                         case i_ltChar:          OP_CC_B(x<y);        break;
1628                         case i_leChar:          OP_CC_B(x<=y);       break;
1629                         case i_charToInt:       OP_C_I(x);           break;
1630                         case i_intToChar:       OP_I_C(x);           break;
1631
1632                         case i_gtInt:           OP_II_B(x>y);        break;
1633                         case i_geInt:           OP_II_B(x>=y);       break;
1634                         case i_eqInt:           OP_II_B(x==y);       break;
1635                         case i_neInt:           OP_II_B(x!=y);       break;
1636                         case i_ltInt:           OP_II_B(x<y);        break;
1637                         case i_leInt:           OP_II_B(x<=y);       break;
1638                         case i_minInt:          OP__I(INT_MIN);      break;
1639                         case i_maxInt:          OP__I(INT_MAX);      break;
1640                         case i_plusInt:         OP_II_I(x+y);        break;
1641                         case i_minusInt:        OP_II_I(x-y);        break;
1642                         case i_timesInt:        OP_II_I(x*y);        break;
1643                         case i_quotInt:
1644                             {
1645                                 int x = PopTaggedInt();
1646                                 int y = PopTaggedInt();
1647                                 if (y == 0) {
1648                                     obj = raiseDiv0("quotInt");
1649                                     goto enterLoop;
1650                                 }
1651                                 /* ToDo: protect against minInt / -1 errors
1652                                  * (repeat for all other division primops)
1653                                  */
1654                                 PushTaggedInt(x/y);
1655                             }
1656                             break;
1657                         case i_remInt:
1658                             {
1659                                 int x = PopTaggedInt();
1660                                 int y = PopTaggedInt();
1661                                 if (y == 0) {
1662                                     obj = raiseDiv0("remInt");
1663                                     goto enterLoop;
1664                                 }
1665                                 PushTaggedInt(x%y);
1666                             }
1667                             break;
1668                         case i_quotRemInt:
1669                             {
1670                                 StgInt x = PopTaggedInt();
1671                                 StgInt y = PopTaggedInt();
1672                                 if (y == 0) {
1673                                     obj = raiseDiv0("quotRemInt");
1674                                     goto enterLoop;
1675                                 }
1676                                 PushTaggedInt(x%y); /* last result  */
1677                                 PushTaggedInt(x/y); /* first result */
1678                             }
1679                             break;
1680                         case i_negateInt:       OP_I_I(-x);          break;
1681
1682                         case i_andInt:          OP_II_I(x&y);        break;
1683                         case i_orInt:           OP_II_I(x|y);        break;
1684                         case i_xorInt:          OP_II_I(x^y);        break;
1685                         case i_notInt:          OP_I_I(~x);          break;
1686                         case i_shiftLInt:       OP_IW_I(x<<y);       break;
1687                         case i_shiftRAInt:      OP_IW_I(x>>y);       break; /* ToDo */
1688                         case i_shiftRLInt:      OP_IW_I(x>>y);       break; /* ToDo */
1689
1690 #ifdef PROVIDE_INT64
1691                         case i_gtInt64:         OP_zz_B(x>y);        break;
1692                         case i_geInt64:         OP_zz_B(x>=y);       break;
1693                         case i_eqInt64:         OP_zz_B(x==y);       break;
1694                         case i_neInt64:         OP_zz_B(x!=y);       break;
1695                         case i_ltInt64:         OP_zz_B(x<y);        break;
1696                         case i_leInt64:         OP_zz_B(x<=y);       break;
1697                         case i_minInt64:        OP__z(0x800000000000LL); break;
1698                         case i_maxInt64:        OP__z(0x7fffffffffffLL); break;
1699                         case i_plusInt64:       OP_zz_z(x+y);        break;
1700                         case i_minusInt64:      OP_zz_z(x-y);        break;
1701                         case i_timesInt64:      OP_zz_z(x*y);        break;
1702                         case i_quotInt64:
1703                             {
1704                                 StgInt64 x = PopTaggedInt64();
1705                                 StgInt64 y = PopTaggedInt64();
1706                                 if (y == 0) {
1707                                     obj = raiseDiv0("quotInt64");
1708                                     goto enterLoop;
1709                                 }
1710                                 /* ToDo: protect against minInt64 / -1 errors
1711                                  * (repeat for all other division primops)
1712                                  */
1713                                 PushTaggedInt64(x/y);
1714                             }
1715                             break;
1716                         case i_remInt64:
1717                             {
1718                                 StgInt64 x = PopTaggedInt64();
1719                                 StgInt64 y = PopTaggedInt64();
1720                                 if (y == 0) {
1721                                     obj = raiseDiv0("remInt64");
1722                                     goto enterLoop;
1723                                 }
1724                                 PushTaggedInt64(x%y);
1725                             }
1726                             break;
1727                         case i_quotRemInt64:
1728                             {
1729                                 StgInt64 x = PopTaggedInt64();
1730                                 StgInt64 y = PopTaggedInt64();
1731                                 if (y == 0) {
1732                                     obj = raiseDiv0("quotRemInt64");
1733                                     goto enterLoop;
1734                                 }
1735                                 PushTaggedInt64(x%y); /* last result  */
1736                                 PushTaggedInt64(x/y); /* first result */
1737                             }
1738                             break;
1739                         case i_negateInt64:     OP_z_z(-x);          break;
1740
1741                         case i_andInt64:        OP_zz_z(x&y);        break;
1742                         case i_orInt64:         OP_zz_z(x|y);        break;
1743                         case i_xorInt64:        OP_zz_z(x^y);        break;
1744                         case i_notInt64:        OP_z_z(~x);          break;
1745                         case i_shiftLInt64:     OP_zW_z(x<<y);       break;
1746                         case i_shiftRAInt64:    OP_zW_z(x>>y);       break; /* ToDo */
1747                         case i_shiftRLInt64:    OP_zW_z(x>>y);       break; /* ToDo */
1748
1749                         case i_int64ToInt:      OP_z_I(x);           break;
1750                         case i_intToInt64:      OP_I_z(x);           break;
1751 #ifdef PROVIDE_WORD
1752                         case i_int64ToWord:     OP_z_W(x);           break;
1753                         case i_wordToInt64:     OP_W_z(x);           break;
1754 #endif
1755                         case i_int64ToFloat:    OP_z_F(x);           break;
1756                         case i_floatToInt64:    OP_F_z(x);           break;
1757                         case i_int64ToDouble:   OP_z_D(x);           break;
1758                         case i_doubleToInt64:   OP_D_z(x);           break;
1759 #endif
1760 #ifdef PROVIDE_WORD
1761                         case i_gtWord:          OP_WW_B(x>y);        break;
1762                         case i_geWord:          OP_WW_B(x>=y);       break;
1763                         case i_eqWord:          OP_WW_B(x==y);       break;
1764                         case i_neWord:          OP_WW_B(x!=y);       break;
1765                         case i_ltWord:          OP_WW_B(x<y);        break;
1766                         case i_leWord:          OP_WW_B(x<=y);       break;
1767                         case i_minWord:         OP__W(0);            break;
1768                         case i_maxWord:         OP__W(UINT_MAX);     break;
1769                         case i_plusWord:        OP_WW_W(x+y);        break;
1770                         case i_minusWord:       OP_WW_W(x-y);        break;
1771                         case i_timesWord:       OP_WW_W(x*y);        break;
1772                         case i_quotWord:
1773                             {
1774                                 StgWord x = PopTaggedWord();
1775                                 StgWord y = PopTaggedWord();
1776                                 if (y == 0) {
1777                                     obj = raiseDiv0("quotWord");
1778                                     goto enterLoop;
1779                                 }
1780                                 PushTaggedWord(x/y);
1781                             }
1782                             break;
1783                         case i_remWord:
1784                             {
1785                                 StgWord x = PopTaggedWord();
1786                                 StgWord y = PopTaggedWord();
1787                                 if (y == 0) {
1788                                     obj = raiseDiv0("remWord");
1789                                     goto enterLoop;
1790                                 }
1791                                 PushTaggedWord(x%y);
1792                             }
1793                             break;
1794                         case i_quotRemWord:
1795                             {
1796                                 StgWord x = PopTaggedWord();
1797                                 StgWord y = PopTaggedWord();
1798                                 if (y == 0) {
1799                                     obj = raiseDiv0("quotRemWord");
1800                                     goto enterLoop;
1801                                 }
1802                                 PushTaggedWord(x%y); /* last result  */
1803                                 PushTaggedWord(x/y); /* first result */
1804                             }
1805                             break;
1806                         case i_negateWord:      OP_W_W(-x);         break;
1807                         case i_andWord:         OP_WW_W(x&y);        break;
1808                         case i_orWord:          OP_WW_W(x|y);        break;
1809                         case i_xorWord:         OP_WW_W(x^y);        break;
1810                         case i_notWord:         OP_W_W(~x);          break;
1811                         case i_shiftLWord:      OP_WW_W(x<<y);       break;
1812                         case i_shiftRAWord:     OP_WW_W(x>>y);       break; /* ToDo */
1813                         case i_shiftRLWord:     OP_WW_W(x>>y);       break; /* ToDo */
1814                         case i_intToWord:       OP_I_W(x);           break;
1815                         case i_wordToInt:       OP_W_I(x);           break;
1816 #endif
1817 #ifdef PROVIDE_ADDR
1818                         case i_gtAddr:          OP_AA_B(x>y);        break;
1819                         case i_geAddr:          OP_AA_B(x>=y);       break;
1820                         case i_eqAddr:          OP_AA_B(x==y);       break;
1821                         case i_neAddr:          OP_AA_B(x!=y);       break;
1822                         case i_ltAddr:          OP_AA_B(x<y);        break;
1823                         case i_leAddr:          OP_AA_B(x<=y);       break;
1824                         case i_intToAddr:       OP_I_A((StgAddr)x);  break;  /*  ToDo */
1825                         case i_addrToInt:       OP_A_I((StgInt)x);   break;  /* ToDo */
1826
1827                         case i_indexCharOffAddr:   OP_AI_C(indexCharOffAddrZh(r,x,y));      break;
1828                         case i_readCharOffAddr:    OP_AI_C(indexCharOffAddrZh(r,x,y));      break;
1829                         case i_writeCharOffAddr:   OP_AIC_(writeCharOffAddrZh(x,y,z));      break;
1830
1831                         case i_indexIntOffAddr:    OP_AI_I(indexIntOffAddrZh(r,x,y));       break;
1832                         case i_readIntOffAddr:     OP_AI_I(indexIntOffAddrZh(r,x,y));       break;
1833                         case i_writeIntOffAddr:    OP_AII_(writeIntOffAddrZh(x,y,z));       break;
1834 #ifdef PROVIDE_INT64
1835                         case i_indexInt64OffAddr:  OP_AI_z(indexInt64OffAddrZh(r,x,y));     break;
1836                         case i_readInt64OffAddr:   OP_AI_z(indexInt64OffAddrZh(r,x,y));     break;
1837                         case i_writeInt64OffAddr:  OP_AIz_(writeInt64OffAddrZh(x,y,z));     break;
1838 #endif
1839
1840                         case i_indexAddrOffAddr:   OP_AI_A(indexAddrOffAddrZh(r,x,y));      break;
1841                         case i_readAddrOffAddr:    OP_AI_A(indexAddrOffAddrZh(r,x,y));      break;
1842                         case i_writeAddrOffAddr:   OP_AIA_(writeAddrOffAddrZh(x,y,z));      break;
1843
1844                         case i_indexFloatOffAddr:  OP_AI_F(indexFloatOffAddrZh(r,x,y));     break;
1845                         case i_readFloatOffAddr:   OP_AI_F(indexFloatOffAddrZh(r,x,y));     break;
1846                         case i_writeFloatOffAddr:  OP_AIF_(writeFloatOffAddrZh(x,y,z));     break;
1847
1848                         case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrZh(r,x,y));    break;
1849                         case i_readDoubleOffAddr:  OP_AI_D(indexDoubleOffAddrZh(r,x,y));    break;
1850                         case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrZh(x,y,z));    break;
1851
1852 #ifdef PROVIDE_STABLE
1853                         case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrZh(r,x,y)); break;
1854                         case i_readStableOffAddr:  OP_AI_s(indexStablePtrOffAddrZh(r,x,y)); break;
1855                         case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrZh(x,y,z)); break;
1856 #endif
1857
1858 #endif /* PROVIDE_ADDR */
1859
1860 #ifdef PROVIDE_INTEGER
1861                         case i_compareInteger:
1862                             {
1863                                 mpz_ptr x = PopTaggedInteger();
1864                                 mpz_ptr y = PopTaggedInteger();
1865                                 StgInt r = mpz_cmp(x,y);
1866                                 PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
1867                             }
1868                             break;
1869                         case i_negateInteger:      OP_Z_Z(mpz_neg(r,x));       break;
1870                         case i_plusInteger:        OP_ZZ_Z(mpz_add(r,x,y));    break;
1871                         case i_minusInteger:       OP_ZZ_Z(mpz_sub(r,x,y));    break;
1872                         case i_timesInteger:       OP_ZZ_Z(mpz_mul(r,x,y));    break;
1873                         case i_quotRemInteger:
1874                             {
1875                                 mpz_ptr x = PopTaggedInteger();
1876                                 mpz_ptr y = PopTaggedInteger();
1877                                 mpz_ptr q = mpz_alloc();
1878                                 mpz_ptr r = mpz_alloc();
1879                                 if (mpz_sgn(y) == 0) {
1880                                     obj = raiseDiv0("quotRemInteger");
1881                                     goto enterLoop;
1882                                 }
1883                                 mpz_tdiv_qr(q,r,x,y);
1884                                 PushTaggedInteger(r); /* last result  */
1885                                 PushTaggedInteger(q); /* first result */
1886                             }
1887                             break;
1888                         case i_divModInteger:
1889                             {
1890                                 mpz_ptr x = PopTaggedInteger();
1891                                 mpz_ptr y = PopTaggedInteger();
1892                                 mpz_ptr q = mpz_alloc();
1893                                 mpz_ptr r = mpz_alloc();
1894                                 if (mpz_sgn(y) == 0) {
1895                                     obj = raiseDiv0("divModInteger");
1896                                     goto enterLoop;
1897                                 }
1898                                 mpz_fdiv_qr(q,r,x,y);
1899                                 PushTaggedInteger(r); /* last result  */
1900                                 PushTaggedInteger(q); /* first result */
1901                             }
1902                             break;
1903                         case i_integerToInt:       OP_Z_I(mpz_get_si(x));   break;
1904                         case i_intToInteger:       OP_I_Z(mpz_set_si(r,x)); break;
1905 #ifdef PROVIDE_INT64
1906                         case i_integerToInt64:     OP_Z_z(mpz_get_si(x));   break;
1907                         case i_int64ToInteger:     OP_z_Z(mpz_set_si(r,x)); break;
1908 #endif
1909 #ifdef PROVIDE_WORD
1910                         /* NB Use of mpz_get_si is quite deliberate since otherwise
1911                          * -255 is converted to 255.
1912                          */
1913                         case i_integerToWord:      OP_Z_W(mpz_get_si(x));   break;
1914                         case i_wordToInteger:      OP_W_Z(mpz_set_ui(r,x)); break;
1915 #endif
1916                         case i_integerToFloat:     OP_Z_F(mpz_get_d(x));    break;
1917                         case i_floatToInteger:     OP_F_Z(mpz_set_d(r,x));  break;
1918                         case i_integerToDouble:    OP_Z_D(mpz_get_d(x));    break;
1919                         case i_doubleToInteger:    OP_D_Z(mpz_set_d(r,x));  break;
1920 #endif /* PROVIDE_INTEGER */
1921
1922                         case i_gtFloat:         OP_FF_B(x>y);        break;
1923                         case i_geFloat:         OP_FF_B(x>=y);       break;
1924                         case i_eqFloat:         OP_FF_B(x==y);       break;
1925                         case i_neFloat:         OP_FF_B(x!=y);       break;
1926                         case i_ltFloat:         OP_FF_B(x<y);        break;
1927                         case i_leFloat:         OP_FF_B(x<=y);       break;
1928                         case i_minFloat:        OP__F(FLT_MIN);      break;
1929                         case i_maxFloat:        OP__F(FLT_MAX);      break;
1930                         case i_radixFloat:      OP__I(FLT_RADIX);    break;
1931                         case i_digitsFloat:     OP__I(FLT_MANT_DIG); break;
1932                         case i_minExpFloat:     OP__I(FLT_MIN_EXP);  break;
1933                         case i_maxExpFloat:     OP__I(FLT_MAX_EXP);  break;
1934                         case i_plusFloat:       OP_FF_F(x+y);        break;
1935                         case i_minusFloat:      OP_FF_F(x-y);        break;
1936                         case i_timesFloat:      OP_FF_F(x*y);        break;
1937                         case i_divideFloat:
1938                             {
1939                                 StgFloat x = PopTaggedFloat();
1940                                 StgFloat y = PopTaggedFloat();
1941 #if 0
1942                                 if (y == 0) {
1943                                     obj = raiseDiv0("divideFloat");
1944                                     goto enterLoop;
1945                                 }
1946 #endif
1947                                 PushTaggedFloat(x/y);
1948                             }
1949                             break;
1950                         case i_negateFloat:     OP_F_F(-x);          break;
1951                         case i_floatToInt:      OP_F_I(x);           break;
1952                         case i_intToFloat:      OP_I_F(x);           break;
1953                         case i_expFloat:        OP_F_F(exp(x));      break;
1954                         case i_logFloat:        OP_F_F(log(x));      break;
1955                         case i_sqrtFloat:       OP_F_F(sqrt(x));     break;
1956                         case i_sinFloat:        OP_F_F(sin(x));      break;
1957                         case i_cosFloat:        OP_F_F(cos(x));      break;
1958                         case i_tanFloat:        OP_F_F(tan(x));      break;
1959                         case i_asinFloat:       OP_F_F(asin(x));     break;
1960                         case i_acosFloat:       OP_F_F(acos(x));     break;
1961                         case i_atanFloat:       OP_F_F(atan(x));     break;
1962                         case i_sinhFloat:       OP_F_F(sinh(x));     break;
1963                         case i_coshFloat:       OP_F_F(cosh(x));     break;
1964                         case i_tanhFloat:       OP_F_F(tanh(x));     break;
1965                         case i_powerFloat:      OP_FF_F(pow(x,y));   break;
1966
1967 #ifdef PROVIDE_INT64
1968                                 /* Based on old Hugs code */
1969                                 /* ToDo: use ~/fptools/ghc/runtime/prims/PrimArith.lc */
1970                         case i_encodeFloatz:     OP_zI_F(ldexp(x,y)); break;
1971                         case i_decodeFloatz:
1972                             {
1973                                 /* ToDo: this code is known to give very approximate results
1974                                  * (even when StgInt64 overflow doesn't occur)
1975                                  */
1976                                 double f0 = PopTaggedFloat();
1977                                 int    n;
1978                                 double f1 = frexp((double)(f0),&n); /* 0.5   <= f1 < 1                   */
1979                                 double f2 = ldexp(f1,FLT_MANT_DIG); /* 2^m-1 <= f2 < 2^m, m=FLT_MANT_DIG */
1980                                 PushTaggedInt(n-FLT_MANT_DIG);
1981                                 PushTaggedInt64((StgInt64)f2);
1982 #if 1 /* paranoia */
1983                                 if (ldexp((StgInt64)f2,n-FLT_MANT_DIG) != f0) {
1984                                     fprintf(stderr,"*** primDecodeFloat mismatch: %.10f != %.10f\n",
1985                                             ldexp((StgInt64)f2,n-FLT_MANT_DIG),f0);
1986                                 }
1987 #endif
1988                             }
1989                             break;
1990 #endif /* PROVIDE_INT64 */
1991 #ifdef PROVIDE_INTEGER
1992                         case i_encodeFloatZ: OP_ZI_F(__encodeFloat(x,y)); break;
1993                         case i_decodeFloatZ: OP_F_ZI(__decodeFloat(r1,&r2,x)); break;
1994 #endif
1995                         case i_isNaNFloat:      OP_F_B(isFloatNaN(x));      break;
1996                         case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
1997                         case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
1998                         case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
1999                         case i_gtDouble:        OP_DD_B(x>y);        break;
2000                         case i_geDouble:        OP_DD_B(x>=y);       break;
2001                         case i_eqDouble:        OP_DD_B(x==y);       break;
2002                         case i_neDouble:        OP_DD_B(x!=y);       break;
2003                         case i_ltDouble:        OP_DD_B(x<y);        break;
2004                         case i_leDouble:        OP_DD_B(x<=y)        break;
2005                         case i_minDouble:       OP__D(DBL_MIN);      break;
2006                         case i_maxDouble:       OP__D(DBL_MAX);      break;
2007                         case i_radixDouble:     OP__I(FLT_RADIX);    break;
2008                         case i_digitsDouble:    OP__I(DBL_MANT_DIG); break;
2009                         case i_minExpDouble:    OP__I(DBL_MIN_EXP);  break;
2010                         case i_maxExpDouble:    OP__I(DBL_MAX_EXP);  break;
2011                         case i_plusDouble:      OP_DD_D(x+y);        break;
2012                         case i_minusDouble:     OP_DD_D(x-y);        break;
2013                         case i_timesDouble:     OP_DD_D(x*y);        break;
2014                         case i_divideDouble:
2015                             {
2016                                 StgDouble x = PopTaggedDouble();
2017                                 StgDouble y = PopTaggedDouble();
2018 #if 0
2019                                 if (y == 0) {
2020                                     obj = raiseDiv0("divideDouble");
2021                                     goto enterLoop;
2022                                 }
2023 #endif
2024                                 PushTaggedDouble(x/y);
2025                             }
2026                             break;
2027                         case i_negateDouble:    OP_D_D(-x);          break;
2028                         case i_doubleToInt:     OP_D_I(x);           break;
2029                         case i_intToDouble:     OP_I_D(x);           break;
2030                         case i_doubleToFloat:   OP_D_F(x);           break;
2031                         case i_floatToDouble:   OP_F_F(x);           break;
2032                         case i_expDouble:       OP_D_D(exp(x));      break;
2033                         case i_logDouble:       OP_D_D(log(x));      break;
2034                         case i_sqrtDouble:      OP_D_D(sqrt(x));     break;
2035                         case i_sinDouble:       OP_D_D(sin(x));      break;
2036                         case i_cosDouble:       OP_D_D(cos(x));      break;
2037                         case i_tanDouble:       OP_D_D(tan(x));      break;
2038                         case i_asinDouble:      OP_D_D(asin(x));     break;
2039                         case i_acosDouble:      OP_D_D(acos(x));     break;
2040                         case i_atanDouble:      OP_D_D(atan(x));     break;
2041                         case i_sinhDouble:      OP_D_D(sinh(x));     break;
2042                         case i_coshDouble:      OP_D_D(cosh(x));     break;
2043                         case i_tanhDouble:      OP_D_D(tanh(x));     break;
2044                         case i_powerDouble:     OP_DD_D(pow(x,y));   break;
2045 #ifdef PROVIDE_INT64
2046                         case i_encodeDoublez:    OP_zI_D(ldexp(x,y)); break;
2047                         case i_decodeDoublez:
2048                             {
2049                                 /* ToDo: this code is known to give very approximate results
2050                                  * (even when StgInt64 overflow doesn't occur)
2051                                  */
2052                                 double f0 = PopTaggedDouble();
2053                                 int    n;
2054                                 double f1 = frexp((double)(f0),&n); /* 0.5   <= f1 < 1                   */
2055                                 double f2 = ldexp(f1,FLT_MANT_DIG); /* 2^m-1 <= f2 < 2^m, m=FLT_MANT_DIG */
2056                                 PushTaggedInt(n-FLT_MANT_DIG);
2057                                 PushTaggedInt64((StgInt64)f2);
2058 #if 1 /* paranoia */
2059                                 if (ldexp((StgInt64)f2,n-FLT_MANT_DIG) != f0) {
2060                                     fprintf(stderr,"*** primDecodeDouble mismatch: %.10f != %.10f\n",
2061                                             ldexp((StgInt64)f2,n-FLT_MANT_DIG),f0);
2062                                 }
2063 #endif
2064                             }
2065                             break;
2066 #endif /* PROVIDE_INT64 */
2067 #ifdef PROVIDE_INTEGER
2068                         case i_encodeDoubleZ: OP_ZI_D(__encodeDouble(x,y)); break;
2069                         case i_decodeDoubleZ: OP_D_ZI(__decodeDouble(r1,&r2,x)); break;
2070 #endif /* PROVIDE_INTEGER */
2071                         case i_isNaNDouble:      OP_D_B(isDoubleNaN(x));      break;
2072                         case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
2073                         case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
2074                         case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
2075                         case i_isIEEEDouble:
2076                             {
2077                                 PushTaggedBool(rtsTrue);
2078                             }
2079                             break;
2080                         default:
2081                                 barf("Unrecognised primop1");
2082                         }
2083                         break;
2084                     }
2085                 case i_PRIMOP2:
2086                     {
2087                         switch (bcoInstr(bco,pc++)) {
2088                         case i_INTERNAL_ERROR2:
2089                                 barf("INTERNAL_ERROR2 at %p:%d",bco,pc-1);
2090                         case i_catch:  /* catch#{e,h} */
2091                             {
2092                                 StgClosure* h;
2093                                 obj = PopCPtr();
2094                                 h   = PopCPtr();
2095
2096                                 /* catch suffers the same problem as takeMVar:
2097                                  * it tries to do control flow even if it isn't
2098                                  * the last instruction in the BCO.
2099                                  * This can leave a mess on the stack if the
2100                                  * last instructions are anything important
2101                                  * like SLIDE.  Our vile hack depends on the
2102                                  * fact that with the current code generator,
2103                                  * we know exactly that i_catch is followed
2104                                  * by code that drops 2 variables off the
2105                                  * stack.
2106                                  * What a vile hack!
2107                                  */
2108                                 Sp += 2;
2109
2110                                 PushCatchFrame(h);
2111                                 goto enterLoop;
2112                             }
2113                         case i_raise:  /* raise#{err} */
2114                             {
2115                                 StgClosure* err = PopCPtr();
2116                                 obj = raiseAnError(err);
2117                                 goto enterLoop;
2118                             }
2119                         case i_force:    /* force#{x} (evaluate x, primreturn nothing) */
2120                             {
2121                                 StgClosure* x;
2122                                 obj = PopCPtr();
2123
2124                                 /* force suffers the same problem as takeMVar:
2125                                  * it tries to do control flow even if it isn't
2126                                  * the last instruction in the BCO.
2127                                  * This can leave a mess on the stack if the
2128                                  * last instructions are anything important
2129                                  * like SLIDE.  Our vile hack depends on the
2130                                  * fact that with the current code generator,
2131                                  * we know exactly that i_force is followed
2132                                  * by code that drops 1 variable off the stack.
2133                                  * What a vile hack!
2134                                  */
2135                                 Sp += 1;
2136
2137                                 PushSeqFrame();
2138                                 goto enterLoop;
2139                             }
2140 #ifdef PROVIDE_ARRAY
2141                         case i_newRef:
2142                             {
2143                                 StgClosure* init = PopCPtr();
2144                                 StgMutVar* mv
2145                                     = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
2146                                 SET_HDR(mv,&MUT_VAR_info,CCCS);
2147                                 mv->var = init;
2148                                 PushPtr(stgCast(StgPtr,mv));
2149                                 break;
2150                             }
2151                         case i_readRef:
2152                             {
2153                                 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2154                                 PushCPtr(mv->var);
2155                                 break;
2156                             }
2157                         case i_writeRef:
2158                             {
2159                                 StgMutVar*  mv    = stgCast(StgMutVar*,PopPtr());
2160                                 StgClosure* value = PopCPtr();
2161                                 mv->var = value;
2162                                 break;
2163                             }
2164                         case i_newArray:
2165                             {
2166                                 nat         n    = PopTaggedInt(); /* or Word?? */
2167                                 StgClosure* init = PopCPtr();
2168                                 StgWord     size = sizeofW(StgArrPtrs) + n;
2169                                 nat i;
2170                                 StgArrPtrs* arr
2171                                     = stgCast(StgArrPtrs*,allocate(size));
2172                                 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
2173                                 arr->ptrs = n;
2174                                 for (i = 0; i < n; ++i) {
2175                                     arr->payload[i] = init;
2176                                 }
2177                                 PushPtr(stgCast(StgPtr,arr));
2178                                 break;
2179                             }
2180                         case i_readArray:
2181                         case i_indexArray:
2182                             {
2183                                 StgArrPtrs* arr = stgCast(StgArrPtrs*,PopPtr());
2184                                 nat         i   = PopTaggedInt(); /* or Word?? */
2185                                 StgWord     n   = arr->ptrs;
2186                                 if (i >= n) {
2187                                     obj = raiseIndex("{index,read}Array");
2188                                     goto enterLoop;
2189                                 }
2190                                 PushCPtr(arr->payload[i]);
2191                                 break;
2192                             }
2193                         case i_writeArray:
2194                             {
2195                                 StgArrPtrs* arr = stgCast(StgArrPtrs*,PopPtr());
2196                                 nat         i   = PopTaggedInt(); /* or Word? */
2197                                 StgClosure* v   = PopCPtr();
2198                                 StgWord     n   = arr->ptrs;
2199                                 if (i >= n) {
2200                                     obj = raiseIndex("{index,read}Array");
2201                                     goto enterLoop;
2202                                 }
2203                                 arr->payload[i] = v;
2204                                 break;
2205                             }
2206                         case i_sizeArray:
2207                         case i_sizeMutableArray:
2208                             {
2209                                 StgArrPtrs* arr = stgCast(StgArrPtrs*,PopPtr());
2210                                 PushTaggedInt(arr->ptrs);
2211                                 break;
2212                             }
2213                         case i_unsafeFreezeArray:
2214                             {
2215                                 StgArrPtrs* arr = stgCast(StgArrPtrs*,PopPtr());
2216                                 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
2217                                 PushPtr(stgCast(StgPtr,arr));
2218                                 break;
2219                             }
2220                         case i_unsafeFreezeByteArray:
2221                             {
2222                                 /* Delightfully simple :-) */
2223                                 break;
2224                             }
2225                         case i_sameRef:
2226                         case i_sameMutableArray:
2227                         case i_sameMutableByteArray:
2228                             {
2229                                 StgPtr x = PopPtr();
2230                                 StgPtr y = PopPtr();
2231                                 PushTaggedBool(x==y);
2232                                 break;
2233                             }
2234
2235                         case i_newByteArray:
2236                             {
2237                                 nat     n     = PopTaggedInt(); /* or Word?? */
2238                                 StgInt  words = (n+sizeof(W_)-1)/sizeof(W_);
2239                                 StgWord size  = sizeofW(StgArrWords) + words;
2240                                 nat i;
2241                                 StgArrWords* arr  = stgCast(StgArrWords*,allocate(size));
2242                                 SET_HDR(arr,&MUT_ARR_WORDS_info,CCCS);
2243                                 arr->words = words;
2244 #ifdef DEBUG
2245                                 for (i = 0; i < n; ++i) {
2246                                     arr->payload[i] = 0xdeadbeef;
2247                                 }
2248 #endif
2249                                 PushPtr(stgCast(StgPtr,arr));
2250                                 break;
2251                             }
2252
2253                         /* Most of these generate alignment warnings on Sparcs and similar architectures.
2254                          * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
2255                          */
2256                         case i_indexCharArray:   OP_mI_ty(Char,"indexCharArray",    indexCharArrayZh(r,x,i)); break;
2257                         case i_readCharArray:    OP_mI_ty(Char,"readCharArray",     readCharArrayZh(r,x,i));  break;
2258                         case i_writeCharArray:   OP_mIty_(Char,"writeCharArray",    writeCharArrayZh(x,i,z)); break;
2259
2260                         case i_indexIntArray:    OP_mI_ty(Int,"indexIntArray",      indexIntArrayZh(r,x,i)); break;
2261                         case i_readIntArray:     OP_mI_ty(Int,"readIntArray",       readIntArrayZh(r,x,i));  break;
2262                         case i_writeIntArray:    OP_mIty_(Int,"writeIntArray",      writeIntArrayZh(x,i,z)); break;
2263 #ifdef PROVIDE_INT64
2264                         case i_indexInt64Array:  OP_mI_ty(Int64,"indexInt64Array",  indexInt64ArrayZh(r,x,i)); break;
2265                         case i_readInt64Array:   OP_mI_ty(Int64,"readInt64Array",   readInt64ArrayZh(r,x,i));  break;
2266                         case i_writeInt64Array:  OP_mIty_(Int64,"writeInt64Array",  writeInt64ArrayZh(x,i,z)); break;
2267 #endif
2268 #ifdef PROVIDE_ADDR
2269                         case i_indexAddrArray:   OP_mI_ty(Addr,"indexAddrArray",   indexAddrArrayZh(r,x,i)); break;
2270                         case i_readAddrArray:    OP_mI_ty(Addr,"readAddrArray",    readAddrArrayZh(r,x,i));  break;
2271                         case i_writeAddrArray:   OP_mIty_(Addr,"writeAddrArray",   writeAddrArrayZh(x,i,z)); break;
2272 #endif
2273                         case i_indexFloatArray:  OP_mI_ty(Float,"indexFloatArray",  indexFloatArrayZh(r,x,i)); break;
2274                         case i_readFloatArray:   OP_mI_ty(Float,"readFloatArray",   readFloatArrayZh(r,x,i));  break;
2275                         case i_writeFloatArray:  OP_mIty_(Float,"writeFloatArray",  writeFloatArrayZh(x,i,z)); break;
2276
2277                         case i_indexDoubleArray: OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayZh(r,x,i)); break;
2278                         case i_readDoubleArray:  OP_mI_ty(Double,"readDoubleArray",  readDoubleArrayZh(r,x,i));  break;
2279                         case i_writeDoubleArray: OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayZh(x,i,z)); break;
2280
2281 #ifdef PROVIDE_STABLE
2282                         case i_indexStableArray: OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayZh(r,x,i)); break;
2283                         case i_readStableArray:  OP_mI_ty(StablePtr,"readStableArray",  readStablePtrArrayZh(r,x,i));  break;
2284                         case i_writeStableArray: OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayZh(x,i,z)); break;
2285 #endif
2286
2287 #endif /* PROVIDE_ARRAY */
2288 #ifdef PROVIDE_COERCE
2289                         case i_unsafeCoerce:
2290                             {
2291                                 /* Another nullop */
2292                                 break;
2293                             }
2294 #endif
2295 #ifdef PROVIDE_PTREQUALITY
2296                         case i_reallyUnsafePtrEquality:
2297                             { /* identical to i_sameRef */
2298                                 StgPtr x = PopPtr();
2299                                 StgPtr y = PopPtr();
2300                                 PushTaggedBool(x==y);
2301                                 break;
2302                             }
2303 #endif
2304 #ifdef PROVIDE_FOREIGN
2305                                 /* ForeignObj# operations */
2306                         case i_makeForeignObj:
2307                             {
2308                                 StgForeignObj *result
2309                                     = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
2310                                 SET_HDR(result,&FOREIGN_info,CCCS);
2311                                 result -> data      = PopTaggedAddr();
2312                                 PushPtr(stgCast(StgPtr,result));
2313                                 break;
2314                             }
2315 #endif /* PROVIDE_FOREIGN */
2316 #ifdef PROVIDE_WEAK
2317                         case i_makeWeak:
2318                             {
2319                                 StgWeak *w
2320                                     = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
2321                                 SET_HDR(w, &WEAK_info, CCCS);
2322                                 w->key        = PopCPtr();
2323                                 w->value      = PopCPtr();
2324                                 w->finaliser  = PopCPtr();
2325                                 w->link       = weak_ptr_list;
2326                                 weak_ptr_list = w;
2327                                 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
2328                                 PushPtr(stgCast(StgPtr,w));
2329                                 break;
2330                             }
2331                         case i_deRefWeak:
2332                             {
2333                                 StgWeak *w = stgCast(StgWeak*,PopPtr());
2334                                 if (w->header.info == &WEAK_info) {
2335                                     PushCPtr(w->value); /* last result  */
2336                                     PushTaggedInt(1);   /* first result */
2337                                 } else {
2338                                     PushPtr(stgCast(StgPtr,w)); /* ToDo: error thunk would be better */
2339                                     PushTaggedInt(0);
2340                                 }
2341                                 break;
2342                             }
2343 #endif /* PROVIDE_WEAK */
2344 #ifdef PROVIDE_STABLE
2345                                 /* StablePtr# operations */
2346                         case i_makeStablePtr:
2347                             {
2348                                 StgStablePtr stable_ptr;
2349                                 if (stable_ptr_free == NULL) {
2350                                     enlargeStablePtrTable();
2351                                 }
2352
2353                                 stable_ptr = stable_ptr_free - stable_ptr_table;
2354                                 stable_ptr_free  = (P_*)*stable_ptr_free;
2355                                 stable_ptr_table[stable_ptr] = PopPtr();
2356
2357                                 PushTaggedStablePtr(stable_ptr);
2358                                 break;
2359                             }
2360                         case i_deRefStablePtr:
2361                             {
2362                                 StgStablePtr stable_ptr = PopTaggedStablePtr();
2363                                 PushPtr(stable_ptr_table[stable_ptr]);
2364                                 break;
2365                             }
2366
2367                         case i_freeStablePtr:
2368                             {
2369                                 StgStablePtr stable_ptr = PopTaggedStablePtr();
2370                                 stable_ptr_table[stable_ptr] = (P_)stable_ptr_free;
2371                                 stable_ptr_free = stable_ptr_table + stable_ptr;
2372                                 break;
2373                             }
2374 #endif /* PROVIDE_STABLE */
2375 #ifdef PROVIDE_CONCURRENT
2376                         case i_fork:
2377                             {
2378                                 StgClosure* c = PopCPtr();
2379                                 StgTSO* t = createGenThread(RtsFlags.GcFlags.initialStkSize,c);
2380                                 PushPtr(stgCast(StgPtr,t));
2381
2382                                 /* switch at the earliest opportunity */
2383                                 context_switch = 1;
2384                                 /* but don't automatically switch to GHC - or you'll waste your
2385                                  * time slice switching back.
2386                                  *
2387                                  * Actually, there's more to it than that: the default
2388                                  * (ThreadEnterGHC) causes the thread to crash - don't
2389                                  * understand why. - ADR
2390                                  */
2391                                 t->whatNext = ThreadEnterHugs;
2392                                 break;
2393                             }
2394                         case i_killThread:
2395                             {
2396                                 StgTSO* tso = stgCast(StgTSO*,PopPtr());
2397                                 deleteThread(tso);
2398                                 if (tso == CurrentTSO) { /* suicide */
2399                                     return ThreadFinished;
2400                                 }
2401                                 break;
2402                             }
2403                         case i_sameMVar:
2404                             { /* identical to i_sameRef */
2405                                 StgPtr x = PopPtr();
2406                                 StgPtr y = PopPtr();
2407                                 PushTaggedBool(x==y);
2408                                 break;
2409                             }
2410                         case i_newMVar:
2411                             {
2412                                 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
2413                                 SET_INFO(mvar,&EMPTY_MVAR_info);
2414                                 mvar->head = mvar->tail = EndTSOQueue;
2415                                 /* ToDo: this is a little strange */
2416                                 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
2417                                 PushPtr(stgCast(StgPtr,mvar));
2418                                 break;
2419                             }
2420 #if 1
2421 #if 0
2422 ToDo: another way out of the problem might be to add an explicit
2423 continuation to primTakeMVar: takeMVar v = primTakeMVar v takeMVar.
2424 The problem with this plan is that now I dont know how much to chop
2425 off the stack.
2426 #endif
2427                         case i_takeMVar:
2428                             {
2429                                 StgMVar *mvar = stgCast(StgMVar*,PopPtr());
2430                                 /* If the MVar is empty, put ourselves
2431                                  * on its blocking queue, and wait
2432                                  * until we're woken up.
2433                                  */
2434                                 if (GET_INFO(mvar) != &FULL_MVAR_info) {
2435                                     if (mvar->head == EndTSOQueue) {
2436                                         mvar->head = CurrentTSO;
2437                                     } else {
2438                                         mvar->tail->link = CurrentTSO;
2439                                     }
2440                                     CurrentTSO->link = EndTSOQueue;
2441                                     mvar->tail = CurrentTSO;
2442
2443                                     /* Hack, hack, hack.
2444                                      * When we block, we push a restart closure
2445                                      * on the stack - but which closure?
2446                                      * We happen to know that the BCO we're
2447                                      * executing looks like this:
2448                                      *
2449                                      *   0:      STK_CHECK 4
2450                                      *   2:      HP_CHECK 3
2451                                      *   4:      TEST 0 29
2452                                      *   7:      UNPACK
2453                                      *   8:      VAR 3
2454                                      *   10:     VAR 1
2455                                      *   12:     primTakeMVar
2456                                      *   14:     ALLOC_CONSTR 0x8213a80
2457                                      *   16:     VAR 2
2458                                      *   18:     VAR 2
2459                                      *   20:     PACK 2
2460                                      *   22:     VAR 0
2461                                      *   24:     SLIDE 1 7
2462                                      *   27:     ENTER
2463                                      *   28:     PANIC
2464                                      *   29:     PANIC
2465                                      *
2466                                      * so we rearrange the stack to look the
2467                                      * way it did when we entered this BCO
2468                                      * and push ths BCO.
2469                                      * What a disgusting hack!
2470                                      */
2471
2472                                     PopPtr();
2473                                     PopPtr();
2474                                     PushCPtr(obj);
2475                                     return ThreadBlocked;
2476
2477                                 } else {
2478                                     PushCPtr(mvar->value);
2479                                     SET_INFO(mvar,&EMPTY_MVAR_info);
2480                                     /* ToDo: this is a little strange */
2481                                     mvar->value = (StgClosure*)&END_TSO_QUEUE_closure;
2482                                 }
2483                                 break;
2484                             }
2485 #endif
2486                         case i_putMVar:
2487                             {
2488                                 StgMVar*    mvar  = stgCast(StgMVar*,PopPtr());
2489                                 StgClosure* value = PopCPtr();
2490                                 if (GET_INFO(mvar) == &FULL_MVAR_info) {
2491                                     obj = raisePrim("putMVar {full MVar}");
2492                                     goto enterLoop;
2493                                 } else {
2494                                     /* wake up the first thread on the
2495                                      * queue, it will continue with the
2496                                      * takeMVar operation and mark the
2497                                      * MVar empty again.
2498                                      */
2499                                     StgTSO* tso = mvar->head;
2500                                     SET_INFO(mvar,&FULL_MVAR_info);
2501                                     mvar->value = value;
2502                                     if (tso != EndTSOQueue) {
2503                                         PUSH_ON_RUN_QUEUE(tso);
2504                                         mvar->head = tso->link;
2505                                         tso->link = EndTSOQueue;
2506                                         if (mvar->head == EndTSOQueue) {
2507                                             mvar->tail = EndTSOQueue;
2508                                         }
2509                                     }
2510                                 }
2511                                 /* yield for better communication performance */
2512                                 context_switch = 1;
2513                                 break;
2514                             }
2515                         case i_delay:
2516                         case i_waitRead:
2517                         case i_waitWrite:
2518                                 /* As PrimOps.h says: Hmm, I'll think about these later. */
2519                                 ASSERT(0);
2520                                 break;
2521 #endif /* PROVIDE_CONCURRENT */
2522                         case i_ccall_Id:
2523                         case i_ccall_IO:
2524                             {
2525                                 CFunDescriptor* descriptor = PopTaggedAddr();
2526                                 StgAddr funPtr = PopTaggedAddr();
2527                                 ccall(descriptor,funPtr);
2528                                 break;
2529                             }
2530                         default:
2531                                 barf("Unrecognised primop2");
2532                         }
2533                         break;
2534                     }
2535                 default:
2536                         barf("Unrecognised instruction");
2537                 }
2538             }
2539             barf("Ran off the end of bco - yoiks");
2540             break;
2541         }
2542     case CAF_UNENTERED:
2543         {
2544             StgCAF* caf = stgCast(StgCAF*,obj);
2545             if (Sp - sizeofW(StgUpdateFrame) < SpLim) {
2546                 PushCPtr(obj); /* code to restart with */
2547                 return StackOverflow;
2548             }
2549             /* ToDo: look for Sp==Su && stackInt(0) == UPD_FRAME and insert an indirection immediately */
2550             {
2551                 StgBlackHole* bh = stgCast(StgBlackHole*,grabHpUpd(BLACKHOLE_sizeW()));
2552                 SET_INFO(bh,&CAF_BLACKHOLE_info);
2553                 bh->blocking_queue = EndTSOQueue;
2554                 IF_DEBUG(gccafs,fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p in evaluator\n",bh,caf));
2555                 SET_INFO(caf,&CAF_ENTERED_info);
2556                 caf->value = stgCast(StgClosure*,bh);
2557                 PUSH_UPD_FRAME(bh,0);
2558                 Sp -= sizeofW(StgUpdateFrame);
2559             }
2560             caf->link = enteredCAFs;
2561             enteredCAFs = caf;
2562             obj = caf->body;
2563             goto enterLoop;
2564         }
2565     case CAF_ENTERED:
2566         {
2567             StgCAF* caf = stgCast(StgCAF*,obj);
2568             obj = caf->value; /* it's just a fancy indirection */
2569             goto enterLoop;
2570         }
2571     case BLACKHOLE:
2572     case CAF_BLACKHOLE:
2573         {
2574             StgBlackHole* bh = stgCast(StgBlackHole*,obj);
2575             /* Put ourselves on the blocking queue for this black hole and block */
2576             CurrentTSO->link = bh->blocking_queue;
2577             bh->blocking_queue = CurrentTSO;
2578             PushCPtr(obj); /* code to restart with */
2579             return ThreadBlocked;
2580         }
2581     case AP_UPD:
2582         {
2583             StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
2584             int i = ap->n_args;
2585             if (Sp - (i + sizeofW(StgUpdateFrame)) < SpLim) {
2586                 PushCPtr(obj); /* code to restart with */
2587                 return StackOverflow;
2588             }
2589             /* ToDo: look for Sp==Su && stackInt(0) == UPD_FRAME and insert an indirection immediately  */
2590             PUSH_UPD_FRAME(ap,0);
2591             Sp -= sizeofW(StgUpdateFrame);
2592             while (--i >= 0) {
2593                 PushWord(payloadWord(ap,i));
2594             }
2595             obj = ap->fun;
2596 #ifndef LAZY_BLACKHOLING
2597             {
2598                 /* superfluous - but makes debugging easier */
2599                 StgBlackHole* bh = stgCast(StgBlackHole*,ap);
2600                 SET_INFO(bh,&BLACKHOLE_info);
2601                 bh->blocking_queue = EndTSOQueue;
2602                 IF_DEBUG(gccafs,fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
2603                 /*printObj(bh); */
2604             }
2605 #endif /* LAZY_BLACKHOLING */
2606             goto enterLoop;
2607         }
2608     case PAP:
2609         {
2610             StgPAP* pap = stgCast(StgPAP*,obj);
2611             int i = pap->n_args;  /* ToDo: stack check */
2612             /* ToDo: if PAP is in whnf, we can update any update frames
2613              * on top of stack.
2614              */
2615             while (--i >= 0) {
2616                 PushWord(payloadWord(pap,i));
2617             }
2618             obj = pap->fun;
2619             goto enterLoop;
2620         }
2621     case IND:
2622         {
2623             obj = stgCast(StgInd*,obj)->indirectee;
2624             goto enterLoop;
2625         }
2626     case CONSTR:
2627     case CONSTR_INTLIKE:
2628     case CONSTR_CHARLIKE:
2629     case CONSTR_STATIC:
2630     case CONSTR_NOCAF_STATIC:
2631         {
2632             while (1) {
2633                 switch (get_itbl(stgCast(StgClosure*,Sp))->type) {
2634                 case CATCH_FRAME:
2635                         PopCatchFrame();
2636                         break;
2637                 case UPDATE_FRAME:
2638                         PopUpdateFrame(obj);
2639                         break;
2640                 case SEQ_FRAME:
2641                         PopSeqFrame();
2642                         break;
2643                 case STOP_FRAME:
2644                     {
2645                         ASSERT(Sp==(P_)Su);
2646                         IF_DEBUG(evaluator,
2647                                  printObj(obj);
2648                                  /*fprintf(stderr,"Sp = %p\tSu = %p\n", Sp, Su);*/
2649                                  /*printStack(Sp,CurrentTSO->stack+CurrentTSO->stack_size,Su);*/
2650                                  );
2651                         PopStopFrame(obj);
2652                         return ThreadFinished;
2653                     }
2654                 case RET_BCO:
2655                     {
2656                         StgClosure* ret;
2657                         PopPtr();
2658                         ret = PopCPtr();
2659                         PushPtr((P_)obj);
2660                         obj = ret;
2661                         goto enterLoop;
2662                     }
2663                 case RET_SMALL:  /* return to GHC */
2664                 case RET_VEC_SMALL:
2665                 case RET_BIG:
2666                 case RET_VEC_BIG:
2667                         barf("todo: RET_[VEC_]{BIG,SMALL}");
2668                 default:
2669                         belch("entered CONSTR with invalid continuation on stack");
2670                         IF_DEBUG(evaluator,
2671                                  printObj(stgCast(StgClosure*,Sp))
2672                                  );
2673                         barf("bailing out");
2674                 }
2675             }
2676         }
2677     default:
2678         {
2679             CurrentTSO->whatNext = ThreadEnterGHC;
2680             PushCPtr(obj); /* code to restart with */
2681             return ThreadYielding;
2682         }
2683     }
2684     barf("Ran off the end of enter - yoiks");
2685 }
2686
2687 /* -----------------------------------------------------------------------------
2688  * ccall support code:
2689  *   marshall moves args from C stack to Haskell stack
2690  *   unmarshall moves args from Haskell stack to C stack
2691  *   argSize calculates how much space you need on the C stack
2692  * ---------------------------------------------------------------------------*/
2693
2694 /* Pop arguments off the C stack and Push them onto the Hugs stack.
2695  * Used when preparing for C calling Haskell or in response to
2696  *  Haskell calling C.
2697  */
2698 nat marshall(char arg_ty, void* arg)
2699 {
2700     switch (arg_ty) {
2701     case INT_REP:
2702             PushTaggedInt(*((int*)arg));
2703             return ARG_SIZE(INT_TAG);
2704 #ifdef PROVIDE_INT64
2705     case INT64_REP:
2706             PushTaggedInt64(*((StgInt64*)arg));
2707             return ARG_SIZE(INT64_TAG);
2708 #endif
2709 #ifdef TODO_PROVIDE_INTEGER
2710     case INTEGER_REP:
2711             PushTaggedInteger(*((mpz_ptr*)arg));
2712             return ARG_SIZE(INTEGER_TAG);
2713 #endif
2714 #ifdef PROVIDE_WORD
2715     case WORD_REP:
2716             PushTaggedWord(*((unsigned int*)arg));
2717             return ARG_SIZE(WORD_TAG);
2718 #endif
2719     case CHAR_REP:
2720             PushTaggedChar(*((char*)arg));
2721             return ARG_SIZE(CHAR_TAG);
2722     case FLOAT_REP:
2723             PushTaggedFloat(*((float*)arg));
2724             return ARG_SIZE(FLOAT_TAG);
2725     case DOUBLE_REP:
2726             PushTaggedDouble(*((double*)arg));
2727             return ARG_SIZE(DOUBLE_TAG);
2728 #ifdef PROVIDE_ADDR
2729     case ADDR_REP:
2730             PushTaggedAddr(*((void**)arg));
2731             return ARG_SIZE(ADDR_TAG);
2732 #endif
2733     case STABLE_REP:
2734             PushTaggedStablePtr(*((StgStablePtr*)arg));
2735             return ARG_SIZE(STABLE_TAG);
2736     case FOREIGN_REP:
2737             /* Not allowed in this direction - you have to
2738              * call makeForeignPtr explicitly
2739              */
2740             barf("marshall: ForeignPtr#\n");
2741             break;
2742 #ifdef PROVIDE_ARRAY
2743     case BARR_REP:
2744     case MUTBARR_REP:
2745 #endif
2746             /* Not allowed in this direction  */
2747             barf("marshall: [Mutable]ByteArray#\n");
2748             break;
2749     default:
2750             barf("marshall: unrecognised arg type %d\n",arg_ty);
2751             break;
2752     }
2753 }
2754
2755 /* Pop arguments off the Hugs stack and Push them onto the C stack.
2756  * Used when preparing for Haskell calling C or in response to
2757  * C calling Haskell.
2758  */
2759 nat unmarshall(char res_ty, void* res)
2760 {
2761     switch (res_ty) {
2762     case INT_REP:
2763             *((int*)res) = PopTaggedInt();
2764             return ARG_SIZE(INT_TAG);
2765 #ifdef PROVIDE_INT64
2766     case INT64_REP:
2767             *((StgInt64*)res) = PopTaggedInt64();
2768             return ARG_SIZE(INT64_TAG);
2769 #endif
2770 #ifdef TODO_PROVIDE_INTEGER
2771     case INTEGER_REP:
2772             *((mpz_ptr*)res) = PopTaggedInteger();
2773             return ARG_SIZE(INTEGER_TAG);
2774 #endif
2775 #ifdef PROVIDE_WORD
2776     case WORD_REP:
2777             *((unsigned int*)res) = PopTaggedWord();
2778             return ARG_SIZE(WORD_TAG);
2779 #endif
2780     case CHAR_REP:
2781             *((int*)res) = PopTaggedChar();
2782             return ARG_SIZE(CHAR_TAG);
2783     case FLOAT_REP:
2784             *((float*)res) = PopTaggedFloat();
2785             return ARG_SIZE(FLOAT_TAG);
2786     case DOUBLE_REP:
2787             *((double*)res) = PopTaggedDouble();
2788             return ARG_SIZE(DOUBLE_TAG);
2789 #ifdef PROVIDE_ADDR
2790     case ADDR_REP:
2791             *((void**)res) = PopTaggedAddr();
2792             return ARG_SIZE(ADDR_TAG);
2793 #endif
2794     case STABLE_REP:
2795             *((StgStablePtr*)res) = PopTaggedStablePtr();
2796             return ARG_SIZE(STABLE_TAG);
2797     case FOREIGN_REP:
2798         {
2799             StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
2800             *((void**)res) = result->data;
2801             return sizeofW(StgPtr);
2802         }
2803 #ifdef PROVIDE_ARRAY
2804     case BARR_REP:
2805     case MUTBARR_REP:
2806 #endif
2807         {
2808             StgArrPtrs* arr = stgCast(StgArrPtrs*,PopPtr());
2809             *((void**)res) = stgCast(void*,&(arr->payload));
2810             return sizeofW(StgPtr);
2811         }
2812     default:
2813             barf("unmarshall: unrecognised result type %d\n",res_ty);
2814     }
2815 }
2816
2817 nat argSize( const char* ks )
2818 {
2819     nat sz = 0;
2820     for( ; *ks != '\0'; ++ks) {
2821         switch (*ks) {
2822         case INT_REP:
2823                 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
2824                 break;
2825 #ifdef PROVIDE_INT64
2826         case INT64_REP:
2827                 sz += sizeof(StgWord) * ARG_SIZE(INT64_TAG);
2828                 break;
2829 #endif
2830 #ifdef TODO_PROVIDE_INTEGER
2831         case INTEGER_REP:
2832                 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
2833                 break;
2834 #endif
2835 #ifdef PROVIDE_WORD
2836         case WORD_REP:
2837                 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
2838                 break;
2839 #endif
2840         case CHAR_REP:
2841                 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
2842                 break;
2843         case FLOAT_REP:
2844                 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
2845                 break;
2846         case DOUBLE_REP:
2847                 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
2848                 break;
2849 #ifdef PROVIDE_ADDR
2850         case ADDR_REP:
2851                 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
2852                 break;
2853 #endif
2854 #ifdef PROVIDE_STABLE
2855         case STABLE_REP:
2856                 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
2857                 break;
2858 #endif
2859 #ifdef PROVIDE_FOREIGN
2860         case FOREIGN_REP:
2861 #endif
2862 #ifdef PROVIDE_ARRAY
2863         case BARR_REP:
2864         case MUTBARR_REP:
2865 #endif
2866                 sz += sizeof(StgPtr);
2867                 break;
2868         default:
2869                 barf("argSize: unrecognised result type %d\n",*ks);
2870                 break;
2871         }
2872     }
2873     return sz;
2874 }
2875
2876 #endif /* INTERPRETER */