ghc/rts/Evaluator.c

   1
   2 /* -----------------------------------------------------------------------------
   3  * Bytecode evaluator
   4  *
   5  * Copyright (c) 1994-1998.
   6  *
   7  * $RCSfile: Evaluator.c,v $
   8  * $Revision: 1.10 $
   9  * $Date: 1999/03/01 14:47:03 $
  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
1050 /* This is written as one giant function in the hope that gcc will do
1051  * a better job of register allocation.
1052  */
1053 StgThreadReturnCode enter( StgClosure* obj )
1054 {
1055     /* We use a char so that we'll do a context_switch check every 256
1056      * iterations.
1057      */
1058     char enterCount = 0;
1059     int  enterCountI = 0;
1060 enterLoop:
1061     /* ASSERT(StorageMgrInfo.hp_start <= Hp && Hp < HpLim && HpLim == StorageMgrInfo.hplim); */
1062     ASSERT(SpLim <= Sp && Sp <= stgCast(StgPtr,Su));
1063 #if DEBUG
1064     IF_DEBUG(evaluator,
1065              fprintf(stderr,
1066              "\n---------------------------------------------------------------\n");
1067              fprintf(stderr,"(%d) Entering: ",enterCountI++); printObj(obj);
1068              fprintf(stderr,"Sp = %p\tSu = %p\n", Sp, Su);
1069              fprintf(stderr, "\n" );
1070              printStack(Sp,CurrentTSO->stack+CurrentTSO->stack_size,Su);
1071              fprintf(stderr, "\n\n");
1072             );
1073 #endif
1074 #if 0
1075     IF_DEBUG(sanity,
1076              {
1077                  /*belch("Starting sanity check");
1078                   *SaveThreadState();
1079                   *checkTSO(CurrentTSO, heap_step);
1080                   * This check fails if we've done any updates because we
1081                   * whack into holes in the heap.
1082                   *checkHeap(?,?);
1083                   *belch("Ending sanity check");
1084                   */
1085              }
1086              );
1087 #endif
1088 #if 0
1089     IF_DEBUG(evaluator,
1090              fprintf(stderr,"Continue?\n");
1091              getchar()
1092              );
1093 #endif
1094     if (++enterCount == 0 && context_switch) {
1095         PushCPtr(obj); /* code to restart with */
1096         return ThreadYielding;
1097     }
1098     switch ( get_itbl(obj)->type ) {
1099     case INVALID_OBJECT:
1100             barf("Invalid object %p",obj);
1101     case BCO:
1102         {
1103             StgBCO* bco = stgCast(StgBCO*,obj);
1104             InstrPtr pc = 0;
1105 #if 1  /* We don't use an explicit HP_CHECK anymore */
1106             if (doYouWantToGC()) {
1107                 PushCPtr(obj); /* code to restart with */
1108                 return HeapOverflow;
1109             }
1110 #endif
1111             while (1) {
1112                 ASSERT(pc < bco->n_instrs);
1113                 if (0 /*enterCountI > 2*/ ) {
1114                 fprintf(stderr, "\n\n-----------------\n" );
1115                 printStack(Sp,CurrentTSO->stack+CurrentTSO->stack_size,Su);
1116                 fprintf(stderr, "\n");
1117                 }
1118                 IF_DEBUG(evaluator,
1119                          fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", Sp, Su, pc);
1120                          disInstr(bco,pc);
1121                          /*fprintf(stderr,"\t"); printStackObj(Sp); */
1122                          fprintf(stderr,"\n");
1123                          );
1124                 switch (bcoInstr(bco,pc++)) {
1125                 case i_INTERNAL_ERROR:
1126                         barf("INTERNAL_ERROR at %p:%d",bco,pc-1);
1127                 case i_PANIC:
1128                         barf("PANIC at %p:%d",bco,pc-1);
1129 #if 0
1130                 case i_HP_CHECK:
1131                     {
1132                         int n = bcoInstr(bco,pc++);
1133                         /* ToDo: we could allocate the whole thing now and
1134                          * slice it up ourselves
1135                          */
1136                         if (doYouWantToGC()) {
1137                             PushCPtr(obj); /* code to restart with */
1138                             return HeapOverflow;
1139                         }
1140                         break;
1141                     }
1142 #endif
1143                 case i_STK_CHECK:
1144                     {
1145                         int n = bcoInstr(bco,pc++);
1146                         if (Sp - n < SpLim) {
1147                             PushCPtr(obj); /* code to restart with */
1148                             return StackOverflow;
1149                         }
1150                         break;
1151                     }
1152                 case i_ARG_CHECK:
1153                     {
1154                         /* ToDo: make sure that hp check allows for possible PAP */
1155                         nat n = bcoInstr(bco,pc++);
1156                         if (stgCast(StgPtr,Sp + n) > stgCast(StgPtr,Su)) {
1157                             StgWord words = (P_)Su - Sp;
1158
1159                             /* first build a PAP */
1160                             ASSERT((P_)Su >= Sp);  /* was (words >= 0) but that's always true */
1161                             if (words == 0) { /* optimisation */
1162                                 /* Skip building the PAP and update with an indirection. */
1163                             } else { /* Build the PAP. */
1164                                 /* In the evaluator, we avoid the need to do
1165                                  * a heap check here by including the size of
1166                                  * the PAP in the heap check we performed
1167                                  * when we entered the BCO.
1168                                  */
1169                                 StgInt  i;
1170                                 StgPAP* pap = stgCast(StgPAP*,grabHpNonUpd(PAP_sizeW(words)));
1171                                 SET_HDR(pap,&PAP_info,CC_pap);
1172                                 pap->n_args = words;
1173                                 pap->fun = obj;
1174                                 for(i = 0; i < (I_)words; ++i) {
1175                                     payloadWord(pap,i) = Sp[i];
1176                                 }
1177                                 Sp += words;
1178                                 obj = stgCast(StgClosure*,pap);
1179                             }
1180
1181                             /* now deal with "update frame" */
1182                             /* as an optimisation, we process all on top of stack */
1183                             /* instead of just the top one */
1184                             ASSERT(Sp==(P_)Su);
1185                             do {
1186                                 switch (get_itbl(Su)->type) {
1187                                 case CATCH_FRAME:
1188                                         PopCatchFrame();
1189                                         ASSERT(Sp != (P_)Su);
1190                                         /* We hit a CATCH frame during an arg satisfaction
1191                                          * check.  So now return to bco_info which is under
1192                                          * the CATCH frame.  The following code is copied
1193                                          * from a case RET_BCO further down.
1194                                          * (The reason why we're here is that something of
1195                                          * functional type has been evaluated as a possibly
1196                                          * exception-throwing computation, but has not thrown
1197                                          * any exception, and is now returning to the
1198                                          * algebraic-case-continuation which forced the
1199                                          * evaluation in the first place.)
1200                                          */
1201                                         {
1202                                            StgClosure* ret;
1203                                            PopPtr();
1204                                            ret = PopCPtr();
1205                                            PushPtr((P_)obj);
1206                                            obj = ret;
1207                                            goto enterLoop;
1208                                         }
1209                                         break;
1210
1211                                         break;
1212                                 case UPDATE_FRAME:
1213                                         PopUpdateFrame(obj);
1214                                         break;
1215                                 case STOP_FRAME:
1216                                         PopStopFrame(obj);
1217                                         return ThreadFinished;
1218                                 case SEQ_FRAME:
1219                                         PopSeqFrame();
1220                                         ASSERT(Sp != (P_)Su);
1221                                         /* We hit a SEQ frame during an arg satisfaction check.
1222                                          * So now return to bco_info which is under the
1223                                          * SEQ frame.  The following code is copied from a
1224                                          * case RET_BCO further down.  (The reason why we're
1225                                          * here is that something of functional type has
1226                                          * been seq-d on, and we're now returning to the
1227                                          * algebraic-case-continuation which forced the
1228                                          * evaluation in the first place.)
1229                                          */
1230                                         {
1231                                            StgClosure* ret;
1232                                            PopPtr();
1233                                            ret = PopCPtr();
1234                                            PushPtr((P_)obj);
1235                                            obj = ret;
1236                                            goto enterLoop;
1237                                         }
1238                                         break;
1239                                 default:
1240                                         barf("Invalid update frame during argcheck");
1241                                 }
1242                             } while (Sp==(P_)Su);
1243                             goto enterLoop;
1244                         }
1245                         break;
1246                     }
1247                 case i_ALLOC_AP:
1248                     {
1249                         int words = bcoInstr(bco,pc++);
1250                         PushPtr(grabHpUpd(AP_sizeW(words)));
1251                         break;
1252                     }
1253                 case i_ALLOC_CONSTR:
1254                     {
1255                         StgInfoTable* info = bcoConstAddr(bco,bcoInstr(bco,pc++));
1256                         StgClosure* c = stgCast(StgClosure*,grabHpNonUpd(sizeW_fromITBL(info)));
1257                         SET_HDR(c,info,??);
1258                         PushPtr(stgCast(StgPtr,c));
1259                         break;
1260                     }
1261                 case i_MKAP:
1262                     {
1263                         int x = bcoInstr(bco,pc++);  /* ToDo: Word not Int! */
1264                         int y = bcoInstr(bco,pc++);
1265                         StgAP_UPD* o = stgCast(StgAP_UPD*,stackPtr(x));
1266                         SET_HDR(o,&AP_UPD_info,??);
1267                         o->n_args = y;
1268                         o->fun    = stgCast(StgClosure*,PopPtr());
1269                         for(x=0; x < y; ++x) {
1270                             payloadWord(o,x) = PopWord();
1271                         }
1272                         IF_DEBUG(evaluator,
1273                                  fprintf(stderr,"\tBuilt ");
1274                                  printObj(stgCast(StgClosure*,o));
1275                         );
1276                         break;
1277                     }
1278                 case i_MKPAP:
1279                     {
1280                         int x = bcoInstr(bco,pc++);
1281                         int y = bcoInstr(bco,pc++);
1282                         StgPAP* o = stgCast(StgPAP*,stackPtr(x));
1283                         SET_HDR(o,&PAP_info,??);
1284                         o->n_args = y;
1285                         o->fun    = stgCast(StgClosure*,PopPtr());
1286                         for(x=0; x < y; ++x) {
1287                             payloadWord(o,x) = PopWord();
1288                         }
1289                         IF_DEBUG(evaluator,
1290                                  fprintf(stderr,"\tBuilt ");
1291                                  printObj(stgCast(StgClosure*,o));
1292                                  );
1293                         break;
1294                     }
1295                 case i_PACK:
1296                     {
1297                         int offset = bcoInstr(bco,pc++);
1298                         StgClosure* o = stgCast(StgClosure*,stackPtr(offset));
1299                         const StgInfoTable* info = get_itbl(o);
1300                         nat p  = info->layout.payload.ptrs;
1301                         nat np = info->layout.payload.nptrs;
1302                         nat i;
1303                         for(i=0; i < p; ++i) {
1304                             payloadCPtr(o,i) = PopCPtr();
1305                         }
1306                         for(i=0; i < np; ++i) {
1307                             payloadWord(o,p+i) = 0xdeadbeef;
1308                         }
1309                         IF_DEBUG(evaluator,
1310                                  fprintf(stderr,"\tBuilt ");
1311                                  printObj(stgCast(StgClosure*,o));
1312                                  );
1313                         break;
1314                     }
1315                 case i_SLIDE:
1316                     {
1317                         int x = bcoInstr(bco,pc++);
1318                         int y = bcoInstr(bco,pc++);
1319                         ASSERT(Sp+x+y <= stgCast(StgPtr,Su));
1320                         /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
1321                         while(--x >= 0) {
1322                             setStackWord(x+y,stackWord(x));
1323                         }
1324                         Sp += y;
1325                         break;
1326                     }
1327                 case i_ENTER:
1328                     {
1329                         obj = PopCPtr();
1330                         goto enterLoop;
1331                     }
1332                 case i_RETADDR:
1333                     {
1334                         PushPtr(bcoConstPtr(bco,bcoInstr(bco,pc++)));
1335                         PushPtr(stgCast(StgPtr,&ret_bco_info));
1336                         break;
1337                     }
1338                 case i_TEST:
1339                     {
1340                         int  tag       = bcoInstr(bco,pc++);
1341                         StgWord offset = bcoInstr(bco,pc++);
1342                         if (constrTag(stgCast(StgClosure*,stackPtr(0))) != tag) {
1343                             pc += offset;
1344                         }
1345                         break;
1346                     }
1347                 case i_UNPACK:
1348                     {
1349                         StgClosure* o = stgCast(StgClosure*,stackPtr(0));
1350                         const StgInfoTable* itbl = get_itbl(o);
1351                         int i = itbl->layout.payload.ptrs;
1352                         ASSERT(  itbl->type == CONSTR
1353                               || itbl->type == CONSTR_STATIC
1354                               || itbl->type == CONSTR_NOCAF_STATIC
1355                               );
1356                         while (--i>=0) {
1357                             PushCPtr(payloadCPtr(o,i));
1358                         }
1359                         break;
1360                     }
1361                 case i_VAR:
1362                     {
1363                         PushPtr(stackPtr(bcoInstr(bco,pc++)));
1364                         break;
1365                     }
1366                 case i_CONST:
1367                     {
1368                         PushPtr(stgCast(StgPtr,bcoConstPtr(bco,bcoInstr(bco,pc++))));
1369                         break;
1370                     }
1371                 case i_CONST2:
1372                     {
1373                         StgWord o1 = bcoInstr(bco,pc++);
1374                         StgWord o2 = bcoInstr(bco,pc++);
1375                         StgWord o  = o1*256 + o2;
1376                         PushPtr(stgCast(StgPtr,bcoConstPtr(bco,o)));
1377                         break;
1378                     }
1379                 case i_VOID:
1380                     {
1381                         PushTaggedRealWorld();
1382                         break;
1383                     }
1384                 case i_VAR_INT:
1385                     {
1386                         PushTaggedInt(taggedStackInt(bcoInstr(bco,pc++)));
1387                         break;
1388                     }
1389                 case i_CONST_INT:
1390                     {
1391                         PushTaggedInt(bcoConstInt(bco,bcoInstr(bco,pc++)));
1392                         break;
1393                     }
1394                 case i_RETURN_INT:
1395                     {
1396                         ASSERT(0);
1397                         break;
1398                     }
1399                 case i_PACK_INT:
1400                     {
1401                         StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Izh_sizeW));
1402                         SET_HDR(o,&Izh_con_info,??);
1403                         payloadWord(o,0) = PopTaggedInt();
1404                         IF_DEBUG(evaluator,
1405                                  fprintf(stderr,"\tBuilt ");
1406                                  printObj(stgCast(StgClosure*,o));
1407                                  );
1408                         PushPtr(stgCast(StgPtr,o));
1409                         break;
1410                     }
1411                 case i_UNPACK_INT:
1412                     {
1413                         StgClosure* con = stgCast(StgClosure*,stackPtr(0));
1414                         /* ASSERT(isIntLike(con)); */
1415                         PushTaggedInt(payloadWord(con,0));
1416                         break;
1417                     }
1418                 case i_TEST_INT:
1419                     {
1420                         StgWord offset = bcoInstr(bco,pc++);
1421                         StgInt  x      = PopTaggedInt();
1422                         StgInt  y      = PopTaggedInt();
1423                         if (x != y) {
1424                             pc += offset;
1425                         }
1426                         break;
1427                     }
1428 #ifdef PROVIDE_INT64
1429                 case i_VAR_INT64:
1430                     {
1431                         PushTaggedInt64(taggedStackInt64(bcoInstr(bco,pc++)));
1432                         break;
1433                     }
1434                 case i_CONST_INT64:
1435                     {
1436                         PushTaggedInt64(bcoConstInt64(bco,bcoInstr(bco,pc++)));
1437                         break;
1438                     }
1439                 case i_RETURN_INT64:
1440                     {
1441                         ASSERT(0); /* ToDo(); */
1442                         break;
1443                     }
1444                 case i_PACK_INT64:
1445                     {
1446                         StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(I64zh_sizeW));
1447                         SET_HDR(o,&I64zh_con_info,??);
1448                         ASSIGN_Int64(&payloadWord(o,0),PopTaggedInt64());
1449                         IF_DEBUG(evaluator,
1450                                  fprintf(stderr,"\tBuilt ");
1451                                  printObj(stgCast(StgClosure*,o));
1452                                  );
1453                         PushPtr(stgCast(StgPtr,o));
1454                         break;
1455                     }
1456                 case i_UNPACK_INT64:
1457                     {
1458                         StgClosure* con = stgCast(StgClosure*,stackPtr(0));
1459                         /*ASSERT(isInt64Like(con)); */
1460                         PushTaggedInt64(PK_Int64(&payloadWord(con,0)));
1461                         break;
1462                     }
1463 #endif
1464 #ifdef PROVIDE_INTEGER
1465                 case i_CONST_INTEGER:
1466                     {
1467                         char* s = bcoConstAddr(bco,bcoInstr(bco,pc++));
1468                         mpz_ptr r = mpz_alloc();
1469                         if (s[0] == '0' && s[1] == 'x') {
1470                             mpz_set_str(r,s+2,16);
1471                         } else {
1472                             mpz_set_str(r,s,10);
1473                         }
1474                         PushTaggedInteger(r);
1475                         break;
1476                     }
1477 #endif
1478
1479 #ifdef PROVIDE_WORD
1480                 case i_VAR_WORD:
1481                     {
1482                         PushTaggedWord(taggedStackWord(bcoInstr(bco,pc++)));
1483                         break;
1484                     }
1485                 case i_CONST_WORD:
1486                     {
1487                         PushTaggedWord(bcoConstWord(bco,bcoInstr(bco,pc++)));
1488                         break;
1489                     }
1490                 case i_RETURN_WORD:
1491                     {
1492                         ASSERT(0);
1493                         break;
1494                     }
1495                 case i_PACK_WORD:
1496                     {
1497                         StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Wzh_sizeW));
1498
1499                         SET_HDR(o,&Wzh_con_info,??);
1500                         payloadWord(o,0) = PopTaggedWord();
1501                         IF_DEBUG(evaluator,
1502                                  fprintf(stderr,"\tBuilt ");
1503                                  printObj(stgCast(StgClosure*,o));
1504                                  );
1505                         PushPtr(stgCast(StgPtr,o));
1506                         break;
1507                     }
1508                 case i_UNPACK_WORD:
1509                     {
1510                         StgClosure* con = stgCast(StgClosure*,stackPtr(0));
1511                         /* ASSERT(isWordLike(con)); */
1512                         PushTaggedWord(payloadWord(con,0));
1513                         break;
1514                     }
1515 #endif
1516 #ifdef PROVIDE_ADDR
1517                 case i_VAR_ADDR:
1518                     {
1519                         PushTaggedAddr(taggedStackAddr(bcoInstr(bco,pc++)));
1520                         break;
1521                     }
1522                 case i_CONST_ADDR:
1523                     {
1524                         PushTaggedAddr(bcoConstAddr(bco,bcoInstr(bco,pc++)));
1525                         break;
1526                     }
1527                 case i_RETURN_ADDR:
1528                     {
1529                         ASSERT(0);
1530                         break;
1531                     }
1532                 case i_PACK_ADDR:
1533                     {
1534                         StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Azh_sizeW));
1535                         SET_HDR(o,&Azh_con_info,??);
1536                         payloadPtr(o,0) = PopTaggedAddr();
1537                         IF_DEBUG(evaluator,
1538                                  fprintf(stderr,"\tBuilt ");
1539                                  printObj(stgCast(StgClosure*,o));
1540                                  );
1541                         PushPtr(stgCast(StgPtr,o));
1542                         break;
1543                     }
1544                 case i_UNPACK_ADDR:
1545                     {
1546                         StgClosure* con = stgCast(StgClosure*,stackPtr(0));
1547                         /* ASSERT(isAddrLike(con)); */
1548                         PushTaggedAddr(payloadPtr(con,0));
1549                         break;
1550                     }
1551 #endif
1552                 case i_VAR_CHAR:
1553                     {
1554                         PushTaggedChar(taggedStackChar(bcoInstr(bco,pc++)));
1555                         break;
1556                     }
1557                 case i_CONST_CHAR:
1558                     {
1559                         PushTaggedChar(bcoConstChar(bco,bcoInstr(bco,pc++)));
1560                         break;
1561                     }
1562                 case i_RETURN_CHAR:
1563                     {
1564                         ASSERT(0);
1565                         break;
1566                     }
1567                 case i_PACK_CHAR:
1568                     {
1569                         StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Czh_sizeW));
1570                         SET_HDR(o,&Czh_con_info,??);
1571                         payloadWord(o,0) = PopTaggedChar();
1572                         PushPtr(stgCast(StgPtr,o));
1573                         IF_DEBUG(evaluator,
1574                                  fprintf(stderr,"\tBuilt ");
1575                                  printObj(stgCast(StgClosure*,o));
1576                                  );
1577                         break;
1578                     }
1579                 case i_UNPACK_CHAR:
1580                     {
1581                         StgClosure* con = stgCast(StgClosure*,stackPtr(0));
1582                         /* ASSERT(isCharLike(con)); */
1583                         PushTaggedChar(payloadWord(con,0));
1584                         break;
1585                     }
1586                 case i_VAR_FLOAT:
1587                     {
1588                         PushTaggedFloat(taggedStackFloat(bcoInstr(bco,pc++)));
1589                         break;
1590                     }
1591                 case i_CONST_FLOAT:
1592                     {
1593                         PushTaggedFloat(bcoConstFloat(bco,bcoInstr(bco,pc++)));
1594                         break;
1595                     }
1596                 case i_RETURN_FLOAT:
1597                     {
1598                         ASSERT(0);
1599                         break;
1600                     }
1601                 case i_PACK_FLOAT:
1602                     {
1603                         StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Fzh_sizeW));
1604                         SET_HDR(o,&Fzh_con_info,??);
1605                         ASSIGN_FLT(&payloadWord(o,0),PopTaggedFloat());
1606                         IF_DEBUG(evaluator,
1607                                  fprintf(stderr,"\tBuilt ");
1608                                  printObj(stgCast(StgClosure*,o));
1609                                  );
1610                         PushPtr(stgCast(StgPtr,o));
1611                         break;
1612                     }
1613                 case i_UNPACK_FLOAT:
1614                     {
1615                         StgClosure* con = stgCast(StgClosure*,stackPtr(0));
1616                         /* ASSERT(isFloatLike(con)); */
1617                         PushTaggedFloat(PK_FLT(&payloadWord(con,0)));
1618                         break;
1619                     }
1620                 case i_VAR_DOUBLE:
1621                     {
1622                         PushTaggedDouble(taggedStackDouble(bcoInstr(bco,pc++)));
1623                         break;
1624                     }
1625                 case i_CONST_DOUBLE:
1626                     {
1627                         PushTaggedDouble(bcoConstDouble(bco,bcoInstr(bco,pc++)));
1628                         break;
1629                     }
1630                 case i_RETURN_DOUBLE:
1631                     {
1632                         ASSERT(0);
1633                         break;
1634                     }
1635                 case i_PACK_DOUBLE:
1636                     {
1637                         StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Dzh_sizeW));
1638                         SET_HDR(o,&Dzh_con_info,??);
1639                         ASSIGN_DBL(&payloadWord(o,0),PopTaggedDouble());
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_DOUBLE:
1648                     {
1649                         StgClosure* con = stgCast(StgClosure*,stackPtr(0));
1650                         /* ASSERT(isDoubleLike(con)); */
1651                         PushTaggedDouble(PK_DBL(&payloadWord(con,0)));
1652                         break;
1653                     }
1654 #ifdef PROVIDE_STABLE
1655                 case i_VAR_STABLE:
1656                     {
1657                         PushTaggedStablePtr(taggedStackStable(bcoInstr(bco,pc++)));
1658                         break;
1659                     }
1660                 case i_RETURN_STABLE:
1661                     {
1662                         ASSERT(0);
1663                         break;
1664                     }
1665                 case i_PACK_STABLE:
1666                     {
1667                         StgClosure* o = stgCast(StgClosure*,grabHpNonUpd(Stablezh_sizeW));
1668                         SET_HDR(o,&StablePtr_con_info,??);
1669                         payloadWord(o,0) = PopTaggedStablePtr();
1670                         IF_DEBUG(evaluator,
1671                                  fprintf(stderr,"\tBuilt ");
1672                                  printObj(stgCast(StgClosure*,o));
1673                                  );
1674                         PushPtr(stgCast(StgPtr,o));
1675                         break;
1676                     }
1677                 case i_UNPACK_STABLE:
1678                     {
1679                         StgClosure* con = stgCast(StgClosure*,stackPtr(0));
1680                         /* ASSERT(isStableLike(con)); */
1681                         PushTaggedStablePtr(payloadWord(con,0));
1682                         break;
1683                     }
1684 #endif
1685                 case i_PRIMOP1:
1686                     {
1687                         switch (bcoInstr(bco,pc++)) {
1688                         case i_INTERNAL_ERROR1:
1689                                 barf("INTERNAL_ERROR1 at %p:%d",bco,pc-1);
1690
1691                         case i_pushseqframe:
1692                             {
1693                                StgClosure* c = PopCPtr();
1694                                PushSeqFrame();
1695                                PushCPtr(c);
1696                                break;
1697                             }
1698                         case i_pushcatchframe:
1699                             {
1700                                StgClosure* e = PopCPtr();
1701                                StgClosure* h = PopCPtr();
1702                                PushCatchFrame(h);
1703                                PushCPtr(e);
1704                                break;
1705                             }
1706
1707                         case i_gtChar:          OP_CC_B(x>y);        break;
1708                         case i_geChar:          OP_CC_B(x>=y);       break;
1709                         case i_eqChar:          OP_CC_B(x==y);       break;
1710                         case i_neChar:          OP_CC_B(x!=y);       break;
1711                         case i_ltChar:          OP_CC_B(x<y);        break;
1712                         case i_leChar:          OP_CC_B(x<=y);       break;
1713                         case i_charToInt:       OP_C_I(x);           break;
1714                         case i_intToChar:       OP_I_C(x);           break;
1715
1716                         case i_gtInt:           OP_II_B(x>y);        break;
1717                         case i_geInt:           OP_II_B(x>=y);       break;
1718                         case i_eqInt:           OP_II_B(x==y);       break;
1719                         case i_neInt:           OP_II_B(x!=y);       break;
1720                         case i_ltInt:           OP_II_B(x<y);        break;
1721                         case i_leInt:           OP_II_B(x<=y);       break;
1722                         case i_minInt:          OP__I(INT_MIN);      break;
1723                         case i_maxInt:          OP__I(INT_MAX);      break;
1724                         case i_plusInt:         OP_II_I(x+y);        break;
1725                         case i_minusInt:        OP_II_I(x-y);        break;
1726                         case i_timesInt:        OP_II_I(x*y);        break;
1727                         case i_quotInt:
1728                             {
1729                                 int x = PopTaggedInt();
1730                                 int y = PopTaggedInt();
1731                                 if (y == 0) {
1732                                     obj = raiseDiv0("quotInt");
1733                                     goto enterLoop;
1734                                 }
1735                                 /* ToDo: protect against minInt / -1 errors
1736                                  * (repeat for all other division primops)
1737                                  */
1738                                 PushTaggedInt(x/y);
1739                             }
1740                             break;
1741                         case i_remInt:
1742                             {
1743                                 int x = PopTaggedInt();
1744                                 int y = PopTaggedInt();
1745                                 if (y == 0) {
1746                                     obj = raiseDiv0("remInt");
1747                                     goto enterLoop;
1748                                 }
1749                                 PushTaggedInt(x%y);
1750                             }
1751                             break;
1752                         case i_quotRemInt:
1753                             {
1754                                 StgInt x = PopTaggedInt();
1755                                 StgInt y = PopTaggedInt();
1756                                 if (y == 0) {
1757                                     obj = raiseDiv0("quotRemInt");
1758                                     goto enterLoop;
1759                                 }
1760                                 PushTaggedInt(x%y); /* last result  */
1761                                 PushTaggedInt(x/y); /* first result */
1762                             }
1763                             break;
1764                         case i_negateInt:       OP_I_I(-x);          break;
1765
1766                         case i_andInt:          OP_II_I(x&y);        break;
1767                         case i_orInt:           OP_II_I(x|y);        break;
1768                         case i_xorInt:          OP_II_I(x^y);        break;
1769                         case i_notInt:          OP_I_I(~x);          break;
1770                         case i_shiftLInt:       OP_II_I(x<<y);       break;
1771                         case i_shiftRAInt:      OP_II_I(x>>y);       break; /* ToDo */
1772                         case i_shiftRLInt:      OP_II_I(x>>y);       break; /* ToDo */
1773
1774 #ifdef PROVIDE_INT64
1775                         case i_gtInt64:         OP_zz_B(x>y);        break;
1776                         case i_geInt64:         OP_zz_B(x>=y);       break;
1777                         case i_eqInt64:         OP_zz_B(x==y);       break;
1778                         case i_neInt64:         OP_zz_B(x!=y);       break;
1779                         case i_ltInt64:         OP_zz_B(x<y);        break;
1780                         case i_leInt64:         OP_zz_B(x<=y);       break;
1781                         case i_minInt64:        OP__z(0x800000000000LL); break;
1782                         case i_maxInt64:        OP__z(0x7fffffffffffLL); break;
1783                         case i_plusInt64:       OP_zz_z(x+y);        break;
1784                         case i_minusInt64:      OP_zz_z(x-y);        break;
1785                         case i_timesInt64:      OP_zz_z(x*y);        break;
1786                         case i_quotInt64:
1787                             {
1788                                 StgInt64 x = PopTaggedInt64();
1789                                 StgInt64 y = PopTaggedInt64();
1790                                 if (y == 0) {
1791                                     obj = raiseDiv0("quotInt64");
1792                                     goto enterLoop;
1793                                 }
1794                                 /* ToDo: protect against minInt64 / -1 errors
1795                                  * (repeat for all other division primops)
1796                                  */
1797                                 PushTaggedInt64(x/y);
1798                             }
1799                             break;
1800                         case i_remInt64:
1801                             {
1802                                 StgInt64 x = PopTaggedInt64();
1803                                 StgInt64 y = PopTaggedInt64();
1804                                 if (y == 0) {
1805                                     obj = raiseDiv0("remInt64");
1806                                     goto enterLoop;
1807                                 }
1808                                 PushTaggedInt64(x%y);
1809                             }
1810                             break;
1811                         case i_quotRemInt64:
1812                             {
1813                                 StgInt64 x = PopTaggedInt64();
1814                                 StgInt64 y = PopTaggedInt64();
1815                                 if (y == 0) {
1816                                     obj = raiseDiv0("quotRemInt64");
1817                                     goto enterLoop;
1818                                 }
1819                                 PushTaggedInt64(x%y); /* last result  */
1820                                 PushTaggedInt64(x/y); /* first result */
1821                             }
1822                             break;
1823                         case i_negateInt64:     OP_z_z(-x);          break;
1824
1825                         case i_andInt64:        OP_zz_z(x&y);        break;
1826                         case i_orInt64:         OP_zz_z(x|y);        break;
1827                         case i_xorInt64:        OP_zz_z(x^y);        break;
1828                         case i_notInt64:        OP_z_z(~x);          break;
1829                         case i_shiftLInt64:     OP_zW_z(x<<y);       break;
1830                         case i_shiftRAInt64:    OP_zW_z(x>>y);       break; /* ToDo */
1831                         case i_shiftRLInt64:    OP_zW_z(x>>y);       break; /* ToDo */
1832
1833                         case i_int64ToInt:      OP_z_I(x);           break;
1834                         case i_intToInt64:      OP_I_z(x);           break;
1835 #ifdef PROVIDE_WORD
1836                         case i_int64ToWord:     OP_z_W(x);           break;
1837                         case i_wordToInt64:     OP_W_z(x);           break;
1838 #endif
1839                         case i_int64ToFloat:    OP_z_F(x);           break;
1840                         case i_floatToInt64:    OP_F_z(x);           break;
1841                         case i_int64ToDouble:   OP_z_D(x);           break;
1842                         case i_doubleToInt64:   OP_D_z(x);           break;
1843 #endif
1844 #ifdef PROVIDE_WORD
1845                         case i_gtWord:          OP_WW_B(x>y);        break;
1846                         case i_geWord:          OP_WW_B(x>=y);       break;
1847                         case i_eqWord:          OP_WW_B(x==y);       break;
1848                         case i_neWord:          OP_WW_B(x!=y);       break;
1849                         case i_ltWord:          OP_WW_B(x<y);        break;
1850                         case i_leWord:          OP_WW_B(x<=y);       break;
1851                         case i_minWord:         OP__W(0);            break;
1852                         case i_maxWord:         OP__W(UINT_MAX);     break;
1853                         case i_plusWord:        OP_WW_W(x+y);        break;
1854                         case i_minusWord:       OP_WW_W(x-y);        break;
1855                         case i_timesWord:       OP_WW_W(x*y);        break;
1856                         case i_quotWord:
1857                             {
1858                                 StgWord x = PopTaggedWord();
1859                                 StgWord y = PopTaggedWord();
1860                                 if (y == 0) {
1861                                     obj = raiseDiv0("quotWord");
1862                                     goto enterLoop;
1863                                 }
1864                                 PushTaggedWord(x/y);
1865                             }
1866                             break;
1867                         case i_remWord:
1868                             {
1869                                 StgWord x = PopTaggedWord();
1870                                 StgWord y = PopTaggedWord();
1871                                 if (y == 0) {
1872                                     obj = raiseDiv0("remWord");
1873                                     goto enterLoop;
1874                                 }
1875                                 PushTaggedWord(x%y);
1876                             }
1877                             break;
1878                         case i_quotRemWord:
1879                             {
1880                                 StgWord x = PopTaggedWord();
1881                                 StgWord y = PopTaggedWord();
1882                                 if (y == 0) {
1883                                     obj = raiseDiv0("quotRemWord");
1884                                     goto enterLoop;
1885                                 }
1886                                 PushTaggedWord(x%y); /* last result  */
1887                                 PushTaggedWord(x/y); /* first result */
1888                             }
1889                             break;
1890                         case i_negateWord:      OP_W_W(-x);         break;
1891                         case i_andWord:         OP_WW_W(x&y);        break;
1892                         case i_orWord:          OP_WW_W(x|y);        break;
1893                         case i_xorWord:         OP_WW_W(x^y);        break;
1894                         case i_notWord:         OP_W_W(~x);          break;
1895                         case i_shiftLWord:      OP_WW_W(x<<y);       break;
1896                         case i_shiftRAWord:     OP_WW_W(x>>y);       break; /* ToDo */
1897                         case i_shiftRLWord:     OP_WW_W(x>>y);       break; /* ToDo */
1898                         case i_intToWord:       OP_I_W(x);           break;
1899                         case i_wordToInt:       OP_W_I(x);           break;
1900 #endif
1901 #ifdef PROVIDE_ADDR
1902                         case i_gtAddr:          OP_AA_B(x>y);        break;
1903                         case i_geAddr:          OP_AA_B(x>=y);       break;
1904                         case i_eqAddr:          OP_AA_B(x==y);       break;
1905                         case i_neAddr:          OP_AA_B(x!=y);       break;
1906                         case i_ltAddr:          OP_AA_B(x<y);        break;
1907                         case i_leAddr:          OP_AA_B(x<=y);       break;
1908                         case i_intToAddr:       OP_I_A((StgAddr)x);  break;  /*  ToDo */
1909                         case i_addrToInt:       OP_A_I((StgInt)x);   break;  /* ToDo */
1910
1911                         case i_indexCharOffAddr:   OP_AI_C(indexCharOffAddrzh(r,x,y));      break;
1912                         case i_readCharOffAddr:    OP_AI_C(indexCharOffAddrzh(r,x,y));      break;
1913                         case i_writeCharOffAddr:   OP_AIC_(writeCharOffAddrzh(x,y,z));      break;
1914
1915                         case i_indexIntOffAddr:    OP_AI_I(indexIntOffAddrzh(r,x,y));       break;
1916                         case i_readIntOffAddr:     OP_AI_I(indexIntOffAddrzh(r,x,y));       break;
1917                         case i_writeIntOffAddr:    OP_AII_(writeIntOffAddrzh(x,y,z));       break;
1918 #ifdef PROVIDE_INT64
1919                         case i_indexInt64OffAddr:  OP_AI_z(indexInt64OffAddrzh(r,x,y));     break;
1920                         case i_readInt64OffAddr:   OP_AI_z(indexInt64OffAddrzh(r,x,y));     break;
1921                         case i_writeInt64OffAddr:  OP_AIz_(writeInt64OffAddrzh(x,y,z));     break;
1922 #endif
1923
1924                         case i_indexAddrOffAddr:   OP_AI_A(indexAddrOffAddrzh(r,x,y));      break;
1925                         case i_readAddrOffAddr:    OP_AI_A(indexAddrOffAddrzh(r,x,y));      break;
1926                         case i_writeAddrOffAddr:   OP_AIA_(writeAddrOffAddrzh(x,y,z));      break;
1927
1928                         case i_indexFloatOffAddr:  OP_AI_F(indexFloatOffAddrzh(r,x,y));     break;
1929                         case i_readFloatOffAddr:   OP_AI_F(indexFloatOffAddrzh(r,x,y));     break;
1930                         case i_writeFloatOffAddr:  OP_AIF_(writeFloatOffAddrzh(x,y,z));     break;
1931
1932                         case i_indexDoubleOffAddr: OP_AI_D(indexDoubleOffAddrzh(r,x,y));    break;
1933                         case i_readDoubleOffAddr:  OP_AI_D(indexDoubleOffAddrzh(r,x,y));    break;
1934                         case i_writeDoubleOffAddr: OP_AID_(writeDoubleOffAddrzh(x,y,z));    break;
1935
1936 #ifdef PROVIDE_STABLE
1937                         case i_indexStableOffAddr: OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
1938                         case i_readStableOffAddr:  OP_AI_s(indexStablePtrOffAddrzh(r,x,y)); break;
1939                         case i_writeStableOffAddr: OP_AIs_(writeStablePtrOffAddrzh(x,y,z)); break;
1940 #endif
1941
1942 #endif /* PROVIDE_ADDR */
1943
1944 #ifdef PROVIDE_INTEGER
1945                         case i_compareInteger:
1946                             {
1947                                 mpz_ptr x = PopTaggedInteger();
1948                                 mpz_ptr y = PopTaggedInteger();
1949                                 StgInt r = mpz_cmp(x,y);
1950                                 PushTaggedInt(r<0 ? -1 : (r>0 ? 1 : 0));
1951                             }
1952                             break;
1953                         case i_negateInteger:      OP_Z_Z(mpz_neg(r,x));       break;
1954                         case i_plusInteger:        OP_ZZ_Z(mpz_add(r,x,y));    break;
1955                         case i_minusInteger:       OP_ZZ_Z(mpz_sub(r,x,y));    break;
1956                         case i_timesInteger:       OP_ZZ_Z(mpz_mul(r,x,y));    break;
1957                         case i_quotRemInteger:
1958                             {
1959                                 mpz_ptr x = PopTaggedInteger();
1960                                 mpz_ptr y = PopTaggedInteger();
1961                                 mpz_ptr q = mpz_alloc();
1962                                 mpz_ptr r = mpz_alloc();
1963                                 if (mpz_sgn(y) == 0) {
1964                                     obj = raiseDiv0("quotRemInteger");
1965                                     goto enterLoop;
1966                                 }
1967                                 mpz_tdiv_qr(q,r,x,y);
1968                                 PushTaggedInteger(r); /* last result  */
1969                                 PushTaggedInteger(q); /* first result */
1970                             }
1971                             break;
1972                         case i_divModInteger:
1973                             {
1974                                 mpz_ptr x = PopTaggedInteger();
1975                                 mpz_ptr y = PopTaggedInteger();
1976                                 mpz_ptr q = mpz_alloc();
1977                                 mpz_ptr r = mpz_alloc();
1978                                 if (mpz_sgn(y) == 0) {
1979                                     obj = raiseDiv0("divModInteger");
1980                                     goto enterLoop;
1981                                 }
1982                                 mpz_fdiv_qr(q,r,x,y);
1983                                 PushTaggedInteger(r); /* last result  */
1984                                 PushTaggedInteger(q); /* first result */
1985                             }
1986                             break;
1987                         case i_integerToInt:       OP_Z_I(mpz_get_si(x));   break;
1988                         case i_intToInteger:       OP_I_Z(mpz_set_si(r,x)); break;
1989 #ifdef PROVIDE_INT64
1990                         case i_integerToInt64:     OP_Z_z(mpz_get_si(x));   break;
1991                         case i_int64ToInteger:     OP_z_Z(mpz_set_si(r,x)); break;
1992 #endif
1993 #ifdef PROVIDE_WORD
1994                         /* NB Use of mpz_get_si is quite deliberate since otherwise
1995                          * -255 is converted to 255.
1996                          */
1997                         case i_integerToWord:      OP_Z_W(mpz_get_si(x));   break;
1998                         case i_wordToInteger:      OP_W_Z(mpz_set_ui(r,x)); break;
1999 #endif
2000                         case i_integerToFloat:     OP_Z_F(mpz_get_d(x));    break;
2001                         case i_floatToInteger:     OP_F_Z(mpz_set_d(r,x));  break;
2002                         case i_integerToDouble:    OP_Z_D(mpz_get_d(x));    break;
2003                         case i_doubleToInteger:    OP_D_Z(mpz_set_d(r,x));  break;
2004 #endif /* PROVIDE_INTEGER */
2005
2006                         case i_gtFloat:         OP_FF_B(x>y);        break;
2007                         case i_geFloat:         OP_FF_B(x>=y);       break;
2008                         case i_eqFloat:         OP_FF_B(x==y);       break;
2009                         case i_neFloat:         OP_FF_B(x!=y);       break;
2010                         case i_ltFloat:         OP_FF_B(x<y);        break;
2011                         case i_leFloat:         OP_FF_B(x<=y);       break;
2012                         case i_minFloat:        OP__F(FLT_MIN);      break;
2013                         case i_maxFloat:        OP__F(FLT_MAX);      break;
2014                         case i_radixFloat:      OP__I(FLT_RADIX);    break;
2015                         case i_digitsFloat:     OP__I(FLT_MANT_DIG); break;
2016                         case i_minExpFloat:     OP__I(FLT_MIN_EXP);  break;
2017                         case i_maxExpFloat:     OP__I(FLT_MAX_EXP);  break;
2018                         case i_plusFloat:       OP_FF_F(x+y);        break;
2019                         case i_minusFloat:      OP_FF_F(x-y);        break;
2020                         case i_timesFloat:      OP_FF_F(x*y);        break;
2021                         case i_divideFloat:
2022                             {
2023                                 StgFloat x = PopTaggedFloat();
2024                                 StgFloat y = PopTaggedFloat();
2025 #if 0
2026                                 if (y == 0) {
2027                                     obj = raiseDiv0("divideFloat");
2028                                     goto enterLoop;
2029                                 }
2030 #endif
2031                                 PushTaggedFloat(x/y);
2032                             }
2033                             break;
2034                         case i_negateFloat:     OP_F_F(-x);          break;
2035                         case i_floatToInt:      OP_F_I(x);           break;
2036                         case i_intToFloat:      OP_I_F(x);           break;
2037                         case i_expFloat:        OP_F_F(exp(x));      break;
2038                         case i_logFloat:        OP_F_F(log(x));      break;
2039                         case i_sqrtFloat:       OP_F_F(sqrt(x));     break;
2040                         case i_sinFloat:        OP_F_F(sin(x));      break;
2041                         case i_cosFloat:        OP_F_F(cos(x));      break;
2042                         case i_tanFloat:        OP_F_F(tan(x));      break;
2043                         case i_asinFloat:       OP_F_F(asin(x));     break;
2044                         case i_acosFloat:       OP_F_F(acos(x));     break;
2045                         case i_atanFloat:       OP_F_F(atan(x));     break;
2046                         case i_sinhFloat:       OP_F_F(sinh(x));     break;
2047                         case i_coshFloat:       OP_F_F(cosh(x));     break;
2048                         case i_tanhFloat:       OP_F_F(tanh(x));     break;
2049                         case i_powerFloat:      OP_FF_F(pow(x,y));   break;
2050
2051 #ifdef PROVIDE_INT64
2052                                 /* Based on old Hugs code */
2053                                 /* ToDo: use ~/fptools/ghc/runtime/prims/PrimArith.lc */
2054                         case i_encodeFloatz:     OP_zI_F(ldexp(x,y)); break;
2055                         case i_decodeFloatz:
2056                             {
2057                                 /* ToDo: this code is known to give very approximate results
2058                                  * (even when StgInt64 overflow doesn't occur)
2059                                  */
2060                                 double f0 = PopTaggedFloat();
2061                                 int    n;
2062                                 double f1 = frexp((double)(f0),&n); /* 0.5   <= f1 < 1                   */
2063                                 double f2 = ldexp(f1,FLT_MANT_DIG); /* 2^m-1 <= f2 < 2^m, m=FLT_MANT_DIG */
2064                                 PushTaggedInt(n-FLT_MANT_DIG);
2065                                 PushTaggedInt64((StgInt64)f2);
2066 #if 1 /* paranoia */
2067                                 if (ldexp((StgInt64)f2,n-FLT_MANT_DIG) != f0) {
2068                                     fprintf(stderr,"*** primDecodeFloat mismatch: %.10f != %.10f\n",
2069                                             ldexp((StgInt64)f2,n-FLT_MANT_DIG),f0);
2070                                 }
2071 #endif
2072                             }
2073                             break;
2074 #endif /* PROVIDE_INT64 */
2075 #ifdef PROVIDE_INTEGER
2076                         case i_encodeFloatZ: OP_ZI_F(__encodeFloat(x,y)); break;
2077                         case i_decodeFloatZ: OP_F_ZI(__decodeFloat(r1,&r2,x)); break;
2078 #endif
2079                         case i_isNaNFloat:      OP_F_B(isFloatNaN(x));      break;
2080                         case i_isInfiniteFloat: OP_F_B(isFloatInfinite(x)); break;
2081                         case i_isNegativeZeroFloat: OP_F_B(isFloatNegativeZero(x)); break;
2082                         case i_isDenormalizedFloat: OP_F_B(isFloatDenormalized(x)); break;
2083                         case i_gtDouble:        OP_DD_B(x>y);        break;
2084                         case i_geDouble:        OP_DD_B(x>=y);       break;
2085                         case i_eqDouble:        OP_DD_B(x==y);       break;
2086                         case i_neDouble:        OP_DD_B(x!=y);       break;
2087                         case i_ltDouble:        OP_DD_B(x<y);        break;
2088                         case i_leDouble:        OP_DD_B(x<=y)        break;
2089                         case i_minDouble:       OP__D(DBL_MIN);      break;
2090                         case i_maxDouble:       OP__D(DBL_MAX);      break;
2091                         case i_radixDouble:     OP__I(FLT_RADIX);    break;
2092                         case i_digitsDouble:    OP__I(DBL_MANT_DIG); break;
2093                         case i_minExpDouble:    OP__I(DBL_MIN_EXP);  break;
2094                         case i_maxExpDouble:    OP__I(DBL_MAX_EXP);  break;
2095                         case i_plusDouble:      OP_DD_D(x+y);        break;
2096                         case i_minusDouble:     OP_DD_D(x-y);        break;
2097                         case i_timesDouble:     OP_DD_D(x*y);        break;
2098                         case i_divideDouble:
2099                             {
2100                                 StgDouble x = PopTaggedDouble();
2101                                 StgDouble y = PopTaggedDouble();
2102 #if 0
2103                                 if (y == 0) {
2104                                     obj = raiseDiv0("divideDouble");
2105                                     goto enterLoop;
2106                                 }
2107 #endif
2108                                 PushTaggedDouble(x/y);
2109                             }
2110                             break;
2111                         case i_negateDouble:    OP_D_D(-x);          break;
2112                         case i_doubleToInt:     OP_D_I(x);           break;
2113                         case i_intToDouble:     OP_I_D(x);           break;
2114                         case i_doubleToFloat:   OP_D_F(x);           break;
2115                         case i_floatToDouble:   OP_F_F(x);           break;
2116                         case i_expDouble:       OP_D_D(exp(x));      break;
2117                         case i_logDouble:       OP_D_D(log(x));      break;
2118                         case i_sqrtDouble:      OP_D_D(sqrt(x));     break;
2119                         case i_sinDouble:       OP_D_D(sin(x));      break;
2120                         case i_cosDouble:       OP_D_D(cos(x));      break;
2121                         case i_tanDouble:       OP_D_D(tan(x));      break;
2122                         case i_asinDouble:      OP_D_D(asin(x));     break;
2123                         case i_acosDouble:      OP_D_D(acos(x));     break;
2124                         case i_atanDouble:      OP_D_D(atan(x));     break;
2125                         case i_sinhDouble:      OP_D_D(sinh(x));     break;
2126                         case i_coshDouble:      OP_D_D(cosh(x));     break;
2127                         case i_tanhDouble:      OP_D_D(tanh(x));     break;
2128                         case i_powerDouble:     OP_DD_D(pow(x,y));   break;
2129 #ifdef PROVIDE_INT64
2130                         case i_encodeDoublez:    OP_zI_D(ldexp(x,y)); break;
2131                         case i_decodeDoublez:
2132                             {
2133                                 /* ToDo: this code is known to give very approximate results
2134                                  * (even when StgInt64 overflow doesn't occur)
2135                                  */
2136                                 double f0 = PopTaggedDouble();
2137                                 int    n;
2138                                 double f1 = frexp((double)(f0),&n); /* 0.5   <= f1 < 1                   */
2139                                 double f2 = ldexp(f1,FLT_MANT_DIG); /* 2^m-1 <= f2 < 2^m, m=FLT_MANT_DIG */
2140                                 PushTaggedInt(n-FLT_MANT_DIG);
2141                                 PushTaggedInt64((StgInt64)f2);
2142 #if 1 /* paranoia */
2143                                 if (ldexp((StgInt64)f2,n-FLT_MANT_DIG) != f0) {
2144                                     fprintf(stderr,"*** primDecodeDouble mismatch: %.10f != %.10f\n",
2145                                             ldexp((StgInt64)f2,n-FLT_MANT_DIG),f0);
2146                                 }
2147 #endif
2148                             }
2149                             break;
2150 #endif /* PROVIDE_INT64 */
2151 #ifdef PROVIDE_INTEGER
2152                         case i_encodeDoubleZ: OP_ZI_D(__encodeDouble(x,y)); break;
2153                         case i_decodeDoubleZ: OP_D_ZI(__decodeDouble(r1,&r2,x)); break;
2154 #endif /* PROVIDE_INTEGER */
2155                         case i_isNaNDouble:      OP_D_B(isDoubleNaN(x));      break;
2156                         case i_isInfiniteDouble: OP_D_B(isDoubleInfinite(x)); break;
2157                         case i_isNegativeZeroDouble: OP_D_B(isDoubleNegativeZero(x)); break;
2158                         case i_isDenormalizedDouble: OP_D_B(isDoubleDenormalized(x)); break;
2159                         case i_isIEEEDouble:
2160                             {
2161                                 PushTaggedBool(rtsTrue);
2162                             }
2163                             break;
2164                         default:
2165                                 barf("Unrecognised primop1");
2166                         }
2167                         break;
2168                     }
2169                 case i_PRIMOP2:
2170                     {
2171                         switch (bcoInstr(bco,pc++)) {
2172                         case i_INTERNAL_ERROR2:
2173                                 barf("INTERNAL_ERROR2 at %p:%d",bco,pc-1);
2174
2175                         case i_raise:  /* raise#{err} */
2176                             {
2177                                 StgClosure* err = PopCPtr();
2178                                 obj = raiseAnError(err);
2179                                 goto enterLoop;
2180                             }
2181 #ifdef PROVIDE_ARRAY
2182                         case i_newRef:
2183                             {
2184                                 StgClosure* init = PopCPtr();
2185                                 StgMutVar* mv
2186                                     = stgCast(StgMutVar*,allocate(sizeofW(StgMutVar)));
2187                                 SET_HDR(mv,&MUT_VAR_info,CCCS);
2188                                 mv->var = init;
2189                                 PushPtr(stgCast(StgPtr,mv));
2190                                 break;
2191                             }
2192                         case i_readRef:
2193                             {
2194                                 StgMutVar* mv = stgCast(StgMutVar*,PopPtr());
2195                                 PushCPtr(mv->var);
2196                                 break;
2197                             }
2198                         case i_writeRef:
2199                             {
2200                                 StgMutVar*  mv    = stgCast(StgMutVar*,PopPtr());
2201                                 StgClosure* value = PopCPtr();
2202                                 mv->var = value;
2203                                 break;
2204                             }
2205                         case i_newArray:
2206                             {
2207                                 nat         n    = PopTaggedInt(); /* or Word?? */
2208                                 StgClosure* init = PopCPtr();
2209                                 StgWord     size = sizeofW(StgMutArrPtrs) + n;
2210                                 nat i;
2211                                 StgMutArrPtrs* arr
2212                                     = stgCast(StgMutArrPtrs*,allocate(size));
2213                                 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
2214                                 arr->ptrs = n;
2215                                 for (i = 0; i < n; ++i) {
2216                                     arr->payload[i] = init;
2217                                 }
2218                                 PushPtr(stgCast(StgPtr,arr));
2219                                 break;
2220                             }
2221                         case i_readArray:
2222                         case i_indexArray:
2223                             {
2224                                 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2225                                 nat         i   = PopTaggedInt(); /* or Word?? */
2226                                 StgWord     n   = arr->ptrs;
2227                                 if (i >= n) {
2228                                     obj = raiseIndex("{index,read}Array");
2229                                     goto enterLoop;
2230                                 }
2231                                 PushCPtr(arr->payload[i]);
2232                                 break;
2233                             }
2234                         case i_writeArray:
2235                             {
2236                                 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2237                                 nat         i   = PopTaggedInt(); /* or Word? */
2238                                 StgClosure* v   = PopCPtr();
2239                                 StgWord     n   = arr->ptrs;
2240                                 if (i >= n) {
2241                                     obj = raiseIndex("{index,read}Array");
2242                                     goto enterLoop;
2243                                 }
2244                                 arr->payload[i] = v;
2245                                 break;
2246                             }
2247                         case i_sizeArray:
2248                         case i_sizeMutableArray:
2249                             {
2250                                 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2251                                 PushTaggedInt(arr->ptrs);
2252                                 break;
2253                             }
2254                         case i_unsafeFreezeArray:
2255                             {
2256                                 StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2257                                 SET_INFO(arr,&MUT_ARR_PTRS_FROZEN_info);
2258                                 PushPtr(stgCast(StgPtr,arr));
2259                                 break;
2260                             }
2261                         case i_unsafeFreezeByteArray:
2262                             {
2263                                 /* Delightfully simple :-) */
2264                                 break;
2265                             }
2266                         case i_sameRef:
2267                         case i_sameMutableArray:
2268                         case i_sameMutableByteArray:
2269                             {
2270                                 StgPtr x = PopPtr();
2271                                 StgPtr y = PopPtr();
2272                                 PushTaggedBool(x==y);
2273                                 break;
2274                             }
2275
2276                         case i_newByteArray:
2277                             {
2278                                 nat     n     = PopTaggedInt(); /* or Word?? */
2279                                 StgInt  words = (n+sizeof(W_)-1)/sizeof(W_);
2280                                 StgWord size  = sizeofW(StgArrWords) + words;
2281                                 nat i;
2282                                 StgArrWords* arr  = stgCast(StgArrWords*,allocate(size));
2283                                 SET_HDR(arr,&ARR_WORDS_info,CCCS);
2284                                 arr->words = words;
2285 #ifdef DEBUG
2286                                 for (i = 0; i < n; ++i) {
2287                                     arr->payload[i] = 0xdeadbeef;
2288                                 }
2289 #endif
2290                                 PushPtr(stgCast(StgPtr,arr));
2291                                 break;
2292                             }
2293
2294                         /* Most of these generate alignment warnings on Sparcs and similar architectures.
2295                          * These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
2296                          */
2297                         case i_indexCharArray:   OP_mI_ty(Char,"indexCharArray",    indexCharArrayzh(r,x,i)); break;
2298                         case i_readCharArray:    OP_mI_ty(Char,"readCharArray",     readCharArrayzh(r,x,i));  break;
2299                         case i_writeCharArray:   OP_mIty_(Char,"writeCharArray",    writeCharArrayzh(x,i,z)); break;
2300
2301                         case i_indexIntArray:    OP_mI_ty(Int,"indexIntArray",      indexIntArrayzh(r,x,i)); break;
2302                         case i_readIntArray:     OP_mI_ty(Int,"readIntArray",       readIntArrayzh(r,x,i));  break;
2303                         case i_writeIntArray:    OP_mIty_(Int,"writeIntArray",      writeIntArrayzh(x,i,z)); break;
2304 #ifdef PROVIDE_INT64
2305                         case i_indexInt64Array:  OP_mI_ty(Int64,"indexInt64Array",  indexInt64Arrayzh(r,x,i)); break;
2306                         case i_readInt64Array:   OP_mI_ty(Int64,"readInt64Array",   readInt64Arrayzh(r,x,i));  break;
2307                         case i_writeInt64Array:  OP_mIty_(Int64,"writeInt64Array",  writeInt64Arrayzh(x,i,z)); break;
2308 #endif
2309 #ifdef PROVIDE_ADDR
2310                         case i_indexAddrArray:   OP_mI_ty(Addr,"indexAddrArray",   indexAddrArrayzh(r,x,i)); break;
2311                         case i_readAddrArray:    OP_mI_ty(Addr,"readAddrArray",    readAddrArrayzh(r,x,i));  break;
2312                         case i_writeAddrArray:   OP_mIty_(Addr,"writeAddrArray",   writeAddrArrayzh(x,i,z)); break;
2313 #endif
2314                         case i_indexFloatArray:  OP_mI_ty(Float,"indexFloatArray",  indexFloatArrayzh(r,x,i)); break;
2315                         case i_readFloatArray:   OP_mI_ty(Float,"readFloatArray",   readFloatArrayzh(r,x,i));  break;
2316                         case i_writeFloatArray:  OP_mIty_(Float,"writeFloatArray",  writeFloatArrayzh(x,i,z)); break;
2317
2318                         case i_indexDoubleArray: OP_mI_ty(Double,"indexDoubleArray", indexDoubleArrayzh(r,x,i)); break;
2319                         case i_readDoubleArray:  OP_mI_ty(Double,"readDoubleArray",  readDoubleArrayzh(r,x,i));  break;
2320                         case i_writeDoubleArray: OP_mIty_(Double,"writeDoubleArray", writeDoubleArrayzh(x,i,z)); break;
2321
2322 #ifdef PROVIDE_STABLE
2323                         case i_indexStableArray: OP_mI_ty(StablePtr,"indexStableArray", indexStablePtrArrayzh(r,x,i)); break;
2324                         case i_readStableArray:  OP_mI_ty(StablePtr,"readStableArray",  readStablePtrArrayzh(r,x,i));  break;
2325                         case i_writeStableArray: OP_mIty_(StablePtr,"writeStableArray", writeStablePtrArrayzh(x,i,z)); break;
2326 #endif
2327
2328 #endif /* PROVIDE_ARRAY */
2329 #ifdef PROVIDE_COERCE
2330                         case i_unsafeCoerce:
2331                             {
2332                                 /* Another nullop */
2333                                 break;
2334                             }
2335 #endif
2336 #ifdef PROVIDE_PTREQUALITY
2337                         case i_reallyUnsafePtrEquality:
2338                             { /* identical to i_sameRef */
2339                                 StgPtr x = PopPtr();
2340                                 StgPtr y = PopPtr();
2341                                 PushTaggedBool(x==y);
2342                                 break;
2343                             }
2344 #endif
2345 #ifdef PROVIDE_FOREIGN
2346                                 /* ForeignObj# operations */
2347                         case i_makeForeignObj:
2348                             {
2349                                 StgForeignObj *result
2350                                     = stgCast(StgForeignObj*,allocate(sizeofW(StgForeignObj)));
2351                                 SET_HDR(result,&FOREIGN_info,CCCS);
2352                                 result -> data      = PopTaggedAddr();
2353                                 PushPtr(stgCast(StgPtr,result));
2354                                 break;
2355                             }
2356 #endif /* PROVIDE_FOREIGN */
2357 #ifdef PROVIDE_WEAK
2358                         case i_makeWeak:
2359                             {
2360                                 StgWeak *w
2361                                     = stgCast(StgWeak*,allocate(sizeofW(StgWeak)));
2362                                 SET_HDR(w, &WEAK_info, CCCS);
2363                                 w->key        = PopCPtr();
2364                                 w->value      = PopCPtr();
2365                                 w->finaliser  = PopCPtr();
2366                                 w->link       = weak_ptr_list;
2367                                 weak_ptr_list = w;
2368                                 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
2369                                 PushPtr(stgCast(StgPtr,w));
2370                                 break;
2371                             }
2372                         case i_deRefWeak:
2373                             {
2374                                 StgWeak *w = stgCast(StgWeak*,PopPtr());
2375                                 if (w->header.info == &WEAK_info) {
2376                                     PushCPtr(w->value); /* last result  */
2377                                     PushTaggedInt(1);   /* first result */
2378                                 } else {
2379                                     PushPtr(stgCast(StgPtr,w)); /* ToDo: error thunk would be better */
2380                                     PushTaggedInt(0);
2381                                 }
2382                                 break;
2383                             }
2384 #endif /* PROVIDE_WEAK */
2385 #ifdef PROVIDE_STABLE
2386                                 /* StablePtr# operations */
2387                         case i_makeStablePtr:
2388                         case i_deRefStablePtr:
2389                         case i_freeStablePtr:
2390                            { fprintf(stderr,"Evaluator.c:stablePtrOp unimp\n" );
2391                            exit(1); };
2392
2393 #if 0
2394                         ToDo: reinstate
2395                         case i_makeStablePtr:
2396                             {
2397                                 StgStablePtr stable_ptr;
2398                                 if (stable_ptr_free == NULL) {
2399                                     enlargeStablePtrTable();
2400                                 }
2401
2402                                 stable_ptr = stable_ptr_free - stable_ptr_table;
2403                                 stable_ptr_free  = (P_*)*stable_ptr_free;
2404                                 stable_ptr_table[stable_ptr] = PopPtr();
2405
2406                                 PushTaggedStablePtr(stable_ptr);
2407                                 break;
2408                             }
2409                         case i_deRefStablePtr:
2410                             {
2411                                 StgStablePtr stable_ptr = PopTaggedStablePtr();
2412                                 PushPtr(stable_ptr_table[stable_ptr]);
2413                                 break;
2414                             }
2415
2416                         case i_freeStablePtr:
2417                             {
2418                                 StgStablePtr stable_ptr = PopTaggedStablePtr();
2419                                 stable_ptr_table[stable_ptr] = (P_)stable_ptr_free;
2420                                 stable_ptr_free = stable_ptr_table + stable_ptr;
2421                                 break;
2422                             }
2423 #endif /* 0 */
2424
2425
2426 #endif /* PROVIDE_STABLE */
2427 #ifdef PROVIDE_CONCURRENT
2428                         case i_fork:
2429                             {
2430                                 StgClosure* c = PopCPtr();
2431                                 StgTSO* t = createGenThread(RtsFlags.GcFlags.initialStkSize,c);
2432                                 PushPtr(stgCast(StgPtr,t));
2433
2434                                 /* switch at the earliest opportunity */
2435                                 context_switch = 1;
2436                                 /* but don't automatically switch to GHC - or you'll waste your
2437                                  * time slice switching back.
2438                                  *
2439                                  * Actually, there's more to it than that: the default
2440                                  * (ThreadEnterGHC) causes the thread to crash - don't
2441                                  * understand why. - ADR
2442                                  */
2443                                 t->whatNext = ThreadEnterHugs;
2444                                 break;
2445                             }
2446                         case i_killThread:
2447                             {
2448                                 StgTSO* tso = stgCast(StgTSO*,PopPtr());
2449                                 deleteThread(tso);
2450                                 if (tso == CurrentTSO) { /* suicide */
2451                                     return ThreadFinished;
2452                                 }
2453                                 break;
2454                             }
2455                         case i_sameMVar:
2456                             { /* identical to i_sameRef */
2457                                 StgPtr x = PopPtr();
2458                                 StgPtr y = PopPtr();
2459                                 PushTaggedBool(x==y);
2460                                 break;
2461                             }
2462                         case i_newMVar:
2463                             {
2464                                 StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
2465                                 SET_INFO(mvar,&EMPTY_MVAR_info);
2466                                 mvar->head = mvar->tail = EndTSOQueue;
2467                                 /* ToDo: this is a little strange */
2468                                 mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
2469                                 PushPtr(stgCast(StgPtr,mvar));
2470                                 break;
2471                             }
2472 #if 1
2473 #if 0
2474 ToDo: another way out of the problem might be to add an explicit
2475 continuation to primTakeMVar: takeMVar v = primTakeMVar v takeMVar.
2476 The problem with this plan is that now I dont know how much to chop
2477 off the stack.
2478 #endif
2479                         case i_takeMVar:
2480                             {
2481                                 StgMVar *mvar = stgCast(StgMVar*,PopPtr());
2482                                 /* If the MVar is empty, put ourselves
2483                                  * on its blocking queue, and wait
2484                                  * until we're woken up.
2485                                  */
2486                                 if (GET_INFO(mvar) != &FULL_MVAR_info) {
2487                                     if (mvar->head == EndTSOQueue) {
2488                                         mvar->head = CurrentTSO;
2489                                     } else {
2490                                         mvar->tail->link = CurrentTSO;
2491                                     }
2492                                     CurrentTSO->link = EndTSOQueue;
2493                                     mvar->tail = CurrentTSO;
2494
2495                                     /* Hack, hack, hack.
2496                                      * When we block, we push a restart closure
2497                                      * on the stack - but which closure?
2498                                      * We happen to know that the BCO we're
2499                                      * executing looks like this:
2500                                      *
2501                                      *   0:      STK_CHECK 4
2502                                      *   2:      HP_CHECK 3
2503                                      *   4:      TEST 0 29
2504                                      *   7:      UNPACK
2505                                      *   8:      VAR 3
2506                                      *   10:     VAR 1
2507                                      *   12:     primTakeMVar
2508                                      *   14:     ALLOC_CONSTR 0x8213a80
2509                                      *   16:     VAR 2
2510                                      *   18:     VAR 2
2511                                      *   20:     PACK 2
2512                                      *   22:     VAR 0
2513                                      *   24:     SLIDE 1 7
2514                                      *   27:     ENTER
2515                                      *   28:     PANIC
2516                                      *   29:     PANIC
2517                                      *
2518                                      * so we rearrange the stack to look the
2519                                      * way it did when we entered this BCO
2520                                      * and push ths BCO.
2521                                      * What a disgusting hack!
2522                                      */
2523
2524                                     PopPtr();
2525                                     PopPtr();
2526                                     PushCPtr(obj);
2527                                     return ThreadBlocked;
2528
2529                                 } else {
2530                                     PushCPtr(mvar->value);
2531                                     SET_INFO(mvar,&EMPTY_MVAR_info);
2532                                     /* ToDo: this is a little strange */
2533                                     mvar->value = (StgClosure*)&END_TSO_QUEUE_closure;
2534                                 }
2535                                 break;
2536                             }
2537 #endif
2538                         case i_putMVar:
2539                             {
2540                                 StgMVar*    mvar  = stgCast(StgMVar*,PopPtr());
2541                                 StgClosure* value = PopCPtr();
2542                                 if (GET_INFO(mvar) == &FULL_MVAR_info) {
2543                                     obj = raisePrim("putMVar {full MVar}");
2544                                     goto enterLoop;
2545                                 } else {
2546                                     /* wake up the first thread on the
2547                                      * queue, it will continue with the
2548                                      * takeMVar operation and mark the
2549                                      * MVar empty again.
2550                                      */
2551                                     StgTSO* tso = mvar->head;
2552                                     SET_INFO(mvar,&FULL_MVAR_info);
2553                                     mvar->value = value;
2554                                     if (tso != EndTSOQueue) {
2555                                         PUSH_ON_RUN_QUEUE(tso);
2556                                         mvar->head = tso->link;
2557                                         tso->link = EndTSOQueue;
2558                                         if (mvar->head == EndTSOQueue) {
2559                                             mvar->tail = EndTSOQueue;
2560                                         }
2561                                     }
2562                                 }
2563                                 /* yield for better communication performance */
2564                                 context_switch = 1;
2565                                 break;
2566                             }
2567                         case i_delay:
2568                         case i_waitRead:
2569                         case i_waitWrite:
2570                                 /* As PrimOps.h says: Hmm, I'll think about these later. */
2571                                 ASSERT(0);
2572                                 break;
2573 #endif /* PROVIDE_CONCURRENT */
2574                         case i_ccall_Id:
2575                         case i_ccall_IO:
2576                             {
2577                                 CFunDescriptor* descriptor = PopTaggedAddr();
2578                                 StgAddr funPtr = PopTaggedAddr();
2579                                 ccall(descriptor,funPtr);
2580                                 break;
2581                             }
2582                         default:
2583                                 barf("Unrecognised primop2");
2584                         }
2585                         break;
2586                     }
2587                 default:
2588                         barf("Unrecognised instruction");
2589                 }
2590             }
2591             barf("Ran off the end of bco - yoiks");
2592             break;
2593         }
2594     case CAF_UNENTERED:
2595         {
2596             StgCAF* caf = stgCast(StgCAF*,obj);
2597             if (Sp - sizeofW(StgUpdateFrame) < SpLim) {
2598                 PushCPtr(obj); /* code to restart with */
2599                 return StackOverflow;
2600             }
2601             /* ToDo: look for Sp==Su && stackInt(0) == UPD_FRAME and insert an indirection immediately */
2602             {
2603                 /*was StgBlackHole* */
2604                 StgBlockingQueue* bh
2605                     = stgCast(StgBlockingQueue*,grabHpUpd(BLACKHOLE_sizeW()));
2606                 SET_INFO(bh,&CAF_BLACKHOLE_info);
2607                 bh->blocking_queue = EndTSOQueue;
2608                 IF_DEBUG(gccafs,fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p in evaluator\n",bh,caf));
2609                 SET_INFO(caf,&CAF_ENTERED_info);
2610                 caf->value = stgCast(StgClosure*,bh);
2611                 PUSH_UPD_FRAME(bh,0);
2612                 Sp -= sizeofW(StgUpdateFrame);
2613             }
2614             caf->link = enteredCAFs;
2615             enteredCAFs = caf;
2616             obj = caf->body;
2617             goto enterLoop;
2618         }
2619     case CAF_ENTERED:
2620         {
2621             StgCAF* caf = stgCast(StgCAF*,obj);
2622             obj = caf->value; /* it's just a fancy indirection */
2623             goto enterLoop;
2624         }
2625     case BLACKHOLE:
2626     case CAF_BLACKHOLE:
2627         {
2628             /*was StgBlackHole* */
2629             StgBlockingQueue* bh = stgCast(StgBlockingQueue*,obj);
2630             /* Put ourselves on the blocking queue for this black hole and block */
2631             CurrentTSO->link = bh->blocking_queue;
2632             bh->blocking_queue = CurrentTSO;
2633             PushCPtr(obj); /* code to restart with */
2634             return ThreadBlocked;
2635         }
2636     case AP_UPD:
2637         {
2638             StgAP_UPD* ap = stgCast(StgAP_UPD*,obj);
2639             int i = ap->n_args;
2640             if (Sp - (i + sizeofW(StgUpdateFrame)) < SpLim) {
2641                 PushCPtr(obj); /* code to restart with */
2642                 return StackOverflow;
2643             }
2644             /* ToDo: look for Sp==Su && stackInt(0) == UPD_FRAME and insert an indirection immediately  */
2645             PUSH_UPD_FRAME(ap,0);
2646             Sp -= sizeofW(StgUpdateFrame);
2647             while (--i >= 0) {
2648                 PushWord(payloadWord(ap,i));
2649             }
2650             obj = ap->fun;
2651 #ifndef LAZY_BLACKHOLING
2652             {
2653                 /* superfluous - but makes debugging easier */
2654                 StgBlackHole* bh = stgCast(StgBlackHole*,ap);
2655                 SET_INFO(bh,&BLACKHOLE_info);
2656                 bh->blocking_queue = EndTSOQueue;
2657                 IF_DEBUG(gccafs,fprintf(stderr,"Eagerly blackholed AP_UPD %p in evaluator\n",bh));
2658                 /*printObj(bh); */
2659             }
2660 #endif /* LAZY_BLACKHOLING */
2661             goto enterLoop;
2662         }
2663     case PAP:
2664         {
2665             StgPAP* pap = stgCast(StgPAP*,obj);
2666             int i = pap->n_args;  /* ToDo: stack check */
2667             /* ToDo: if PAP is in whnf, we can update any update frames
2668              * on top of stack.
2669              */
2670             while (--i >= 0) {
2671                 PushWord(payloadWord(pap,i));
2672             }
2673             obj = pap->fun;
2674             goto enterLoop;
2675         }
2676     case IND:
2677         {
2678             obj = stgCast(StgInd*,obj)->indirectee;
2679             goto enterLoop;
2680         }
2681     case CONSTR:
2682     case CONSTR_INTLIKE:
2683     case CONSTR_CHARLIKE:
2684     case CONSTR_STATIC:
2685     case CONSTR_NOCAF_STATIC:
2686         {
2687             while (1) {
2688                 switch (get_itbl(stgCast(StgClosure*,Sp))->type) {
2689                 case CATCH_FRAME:
2690                         PopCatchFrame();
2691                         break;
2692                 case UPDATE_FRAME:
2693                         PopUpdateFrame(obj);
2694                         break;
2695                 case SEQ_FRAME:
2696                         PopSeqFrame();
2697                         break;
2698                 case STOP_FRAME:
2699                     {
2700                         ASSERT(Sp==(P_)Su);
2701                         IF_DEBUG(evaluator,
2702                                  printObj(obj);
2703                                  /*fprintf(stderr,"Sp = %p\tSu = %p\n", Sp, Su);*/
2704                                  /*printStack(Sp,CurrentTSO->stack+CurrentTSO->stack_size,Su);*/
2705                                  );
2706                         PopStopFrame(obj);
2707                         return ThreadFinished;
2708                     }
2709                 case RET_BCO:
2710                     {
2711                         StgClosure* ret;
2712                         PopPtr();
2713                         ret = PopCPtr();
2714                         PushPtr((P_)obj);
2715                         obj = ret;
2716                         goto enterLoop;
2717                     }
2718                 case RET_SMALL:  /* return to GHC */
2719                 case RET_VEC_SMALL:
2720                 case RET_BIG:
2721                 case RET_VEC_BIG:
2722                         barf("todo: RET_[VEC_]{BIG,SMALL}");
2723                 default:
2724                         belch("entered CONSTR with invalid continuation on stack");
2725                         IF_DEBUG(evaluator,
2726                                  printObj(stgCast(StgClosure*,Sp))
2727                                  );
2728                         barf("bailing out");
2729                 }
2730             }
2731         }
2732     default:
2733         {
2734             CurrentTSO->whatNext = ThreadEnterGHC;
2735             PushCPtr(obj); /* code to restart with */
2736             return ThreadYielding;
2737         }
2738     }
2739     barf("Ran off the end of enter - yoiks");
2740 }
2741
2742 /* -----------------------------------------------------------------------------
2743  * ccall support code:
2744  *   marshall moves args from C stack to Haskell stack
2745  *   unmarshall moves args from Haskell stack to C stack
2746  *   argSize calculates how much space you need on the C stack
2747  * ---------------------------------------------------------------------------*/
2748
2749 /* Pop arguments off the C stack and Push them onto the Hugs stack.
2750  * Used when preparing for C calling Haskell or in response to
2751  *  Haskell calling C.
2752  */
2753 nat marshall(char arg_ty, void* arg)
2754 {
2755     switch (arg_ty) {
2756     case INT_REP:
2757             PushTaggedInt(*((int*)arg));
2758             return ARG_SIZE(INT_TAG);
2759 #ifdef PROVIDE_INT64
2760     case INT64_REP:
2761             PushTaggedInt64(*((StgInt64*)arg));
2762             return ARG_SIZE(INT64_TAG);
2763 #endif
2764 #ifdef TODO_PROVIDE_INTEGER
2765     case INTEGER_REP:
2766             PushTaggedInteger(*((mpz_ptr*)arg));
2767             return ARG_SIZE(INTEGER_TAG);
2768 #endif
2769 #ifdef PROVIDE_WORD
2770     case WORD_REP:
2771             PushTaggedWord(*((unsigned int*)arg));
2772             return ARG_SIZE(WORD_TAG);
2773 #endif
2774     case CHAR_REP:
2775             PushTaggedChar(*((char*)arg));
2776             return ARG_SIZE(CHAR_TAG);
2777     case FLOAT_REP:
2778             PushTaggedFloat(*((float*)arg));
2779             return ARG_SIZE(FLOAT_TAG);
2780     case DOUBLE_REP:
2781             PushTaggedDouble(*((double*)arg));
2782             return ARG_SIZE(DOUBLE_TAG);
2783 #ifdef PROVIDE_ADDR
2784     case ADDR_REP:
2785             PushTaggedAddr(*((void**)arg));
2786             return ARG_SIZE(ADDR_TAG);
2787 #endif
2788 #ifdef PROVIDE_STABLE
2789     case STABLE_REP:
2790             PushTaggedStablePtr(*((StgStablePtr*)arg));
2791             return ARG_SIZE(STABLE_TAG);
2792 #endif
2793     case FOREIGN_REP:
2794             /* Not allowed in this direction - you have to
2795              * call makeForeignPtr explicitly
2796              */
2797             barf("marshall: ForeignPtr#\n");
2798             break;
2799 #ifdef PROVIDE_ARRAY
2800     case BARR_REP:
2801     case MUTBARR_REP:
2802 #endif
2803             /* Not allowed in this direction  */
2804             barf("marshall: [Mutable]ByteArray#\n");
2805             break;
2806     default:
2807             barf("marshall: unrecognised arg type %d\n",arg_ty);
2808             break;
2809     }
2810 }
2811
2812 /* Pop arguments off the Hugs stack and Push them onto the C stack.
2813  * Used when preparing for Haskell calling C or in response to
2814  * C calling Haskell.
2815  */
2816 nat unmarshall(char res_ty, void* res)
2817 {
2818     switch (res_ty) {
2819     case INT_REP:
2820             *((int*)res) = PopTaggedInt();
2821             return ARG_SIZE(INT_TAG);
2822 #ifdef PROVIDE_INT64
2823     case INT64_REP:
2824             *((StgInt64*)res) = PopTaggedInt64();
2825             return ARG_SIZE(INT64_TAG);
2826 #endif
2827 #ifdef TODO_PROVIDE_INTEGER
2828     case INTEGER_REP:
2829             *((mpz_ptr*)res) = PopTaggedInteger();
2830             return ARG_SIZE(INTEGER_TAG);
2831 #endif
2832 #ifdef PROVIDE_WORD
2833     case WORD_REP:
2834             *((unsigned int*)res) = PopTaggedWord();
2835             return ARG_SIZE(WORD_TAG);
2836 #endif
2837     case CHAR_REP:
2838             *((int*)res) = PopTaggedChar();
2839             return ARG_SIZE(CHAR_TAG);
2840     case FLOAT_REP:
2841             *((float*)res) = PopTaggedFloat();
2842             return ARG_SIZE(FLOAT_TAG);
2843     case DOUBLE_REP:
2844             *((double*)res) = PopTaggedDouble();
2845             return ARG_SIZE(DOUBLE_TAG);
2846 #ifdef PROVIDE_ADDR
2847     case ADDR_REP:
2848             *((void**)res) = PopTaggedAddr();
2849             return ARG_SIZE(ADDR_TAG);
2850 #endif
2851 #ifdef PROVIDE_STABLE
2852     case STABLE_REP:
2853             *((StgStablePtr*)res) = PopTaggedStablePtr();
2854             return ARG_SIZE(STABLE_TAG);
2855 #endif
2856     case FOREIGN_REP:
2857         {
2858             StgForeignObj *result = stgCast(StgForeignObj*,PopPtr());
2859             *((void**)res) = result->data;
2860             return sizeofW(StgPtr);
2861         }
2862 #ifdef PROVIDE_ARRAY
2863     case BARR_REP:
2864     case MUTBARR_REP:
2865 #endif
2866         {
2867             StgMutArrPtrs* arr = stgCast(StgMutArrPtrs*,PopPtr());
2868             *((void**)res) = stgCast(void*,&(arr->payload));
2869             return sizeofW(StgPtr);
2870         }
2871     default:
2872             barf("unmarshall: unrecognised result type %d\n",res_ty);
2873     }
2874 }
2875
2876 nat argSize( const char* ks )
2877 {
2878     nat sz = 0;
2879     for( ; *ks != '\0'; ++ks) {
2880         switch (*ks) {
2881         case INT_REP:
2882                 sz += sizeof(StgWord) * ARG_SIZE(INT_TAG);
2883                 break;
2884 #ifdef PROVIDE_INT64
2885         case INT64_REP:
2886                 sz += sizeof(StgWord) * ARG_SIZE(INT64_TAG);
2887                 break;
2888 #endif
2889 #ifdef TODO_PROVIDE_INTEGER
2890         case INTEGER_REP:
2891                 sz += sizeof(StgWord) * ARG_SIZE(INTEGER_TAG);
2892                 break;
2893 #endif
2894 #ifdef PROVIDE_WORD
2895         case WORD_REP:
2896                 sz += sizeof(StgWord) * ARG_SIZE(WORD_TAG);
2897                 break;
2898 #endif
2899         case CHAR_REP:
2900                 sz += sizeof(StgWord) * ARG_SIZE(CHAR_TAG);
2901                 break;
2902         case FLOAT_REP:
2903                 sz += sizeof(StgWord) * ARG_SIZE(FLOAT_TAG);
2904                 break;
2905         case DOUBLE_REP:
2906                 sz += sizeof(StgWord) * ARG_SIZE(DOUBLE_TAG);
2907                 break;
2908 #ifdef PROVIDE_ADDR
2909         case ADDR_REP:
2910                 sz += sizeof(StgWord) * ARG_SIZE(ADDR_TAG);
2911                 break;
2912 #endif
2913 #ifdef PROVIDE_STABLE
2914         case STABLE_REP:
2915                 sz += sizeof(StgWord) * ARG_SIZE(STABLE_TAG);
2916                 break;
2917 #endif
2918 #ifdef PROVIDE_FOREIGN
2919         case FOREIGN_REP:
2920 #endif
2921 #ifdef PROVIDE_ARRAY
2922         case BARR_REP:
2923         case MUTBARR_REP:
2924 #endif
2925                 sz += sizeof(StgPtr);
2926                 break;
2927         default:
2928                 barf("argSize: unrecognised result type %d\n",*ks);
2929                 break;
2930         }
2931     }
2932     return sz;
2933 }
2934
2935 #endif /* INTERPRETER */