ghc/rts/Evaluator.c

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