ghc/rts/Evaluator.c

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