ghc/rts/Evaluator.c

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