ghc/rts/Assembler.c

   1
   2 /* --------------------------------------------------------------------------
   3  * Bytecode assembler
   4  *
   5  * Copyright (c) 1994-1998.
   6  *
   7  * $RCSfile: Assembler.c,v $
   8  * $Revision: 1.20 $
   9  * $Date: 1999/12/07 11:15:00 $
  10  *
  11  * This module provides functions to construct BCOs and other closures
  12  * required by the bytecode compiler.
  13  *
  14  * It is supposed to shield the compiler from platform dependent information
  15  * such as:
  16  *
  17  * o sizeof(StgFloat)
  18  * o sizeof(I#)
  19  *
  20  * and from details of how the abstract machine is implemented such as:
  21  *
  22  * o what does a BCO look like?
  23  * o how many bytes does the "Push InfoTable" instruction require?
  24  *
  25  * Details of design:
  26  * o (To handle letrecs) We allocate Aps, Paps and Cons using number of
  27  *   heap allocated args to determine size.
  28  *   We can't handle unboxed args :-(
  29  * o All stack offsets are relative to position of Sp at start of
  30  *   function or thunk (not BCO - consider continuations)
  31  * o Active thunks must be roots during GC - how to achieve this?
  32  * o Each BCO contains its own stack and heap check
  33  *   We don't try to exploit the Hp check optimisation - easier to make
  34  *   each thunk stand on its own.
  35  * o asBind returns a "varid" (which is, in fact, a stack offset)
  36  *   asVar acts on a "varid" - combining it with the current stack size to
  37  *   determine actual position
  38  * o Assembler.h uses totally neutral types: strings, floats, ints, etc
  39  *   to minimise conflicts with other parts of the system.
  40  * Simulated Stack
  41  * ------------------------------------------------------------------------*/
  42
  43 #include "Rts.h"
  44
  45 #ifdef INTERPRETER
  46
  47 #include "RtsFlags.h"
  48 #include "RtsUtils.h"
  49 #include "Bytecodes.h"
  50 #include "Printer.h"
  51 #include "Disassembler.h"
  52 #include "StgMiscClosures.h"
  53 #include "Storage.h"
  54 #include "Schedule.h"
  55 #include "Evaluator.h"
  56
  57 #define INSIDE_ASSEMBLER_C
  58 #include "Assembler.h"
  59 #undef INSIDE_ASSEMBLER_C
  60
  61 /* --------------------------------------------------------------------------
  62  * References between BCOs
  63  *
  64  * These are necessary because there can be circular references between
  65  * BCOs so we have to keep track of all the references to each object
  66  * and fill in all the references once we're done.
  67  *
  68  * ToDo: generalise to allow references between any objects
  69  * ------------------------------------------------------------------------*/
  70
  71 typedef struct {
  72     AsmObject ref;  /* who refers to it                       */
  73     AsmNat i;       /* index into some table held by referer  */
  74 } AsmRef;
  75
  76 /* --------------------------------------------------------------------------
  77  * Queues (of instructions, ptrs, nonptrs)
  78  * ------------------------------------------------------------------------*/
  79
  80 #define Queue Instrs
  81 #define Type  StgWord8
  82 #define MAKE_findIn 0
  83 #include "QueueTemplate.h"
  84 #undef MAKE_findIn
  85 #undef Type
  86 #undef Queue
  87
  88 #define Queue Ptrs
  89 #define Type  AsmObject
  90 #define MAKE_findIn 0
  91 #include "QueueTemplate.h"
  92 #undef MAKE_findIn
  93 #undef Type
  94 #undef Queue
  95
  96 #define Queue Refs
  97 #define Type  AsmRef
  98 #define MAKE_findIn 0
  99 #include "QueueTemplate.h"
 100 #undef MAKE_findIn
 101 #undef Type
 102 #undef Queue
 103
 104 #define Queue NonPtrs
 105 #define Type  StgWord
 106 #define MAKE_findIn 1
 107 #include "QueueTemplate.h"
 108 #undef MAKE_findIn
 109 #undef Type
 110 #undef Queue
 111
 112 /* --------------------------------------------------------------------------
 113  * AsmObjects are used to build heap objects.
 114  *
 115  * AsmObjects can contain circular references to each other
 116  * so we have to keep track of all the references which can't be filled
 117  * in yet.
 118  *
 119  * When we finish building an AsmObject, we allocate an actual heap object and
 120  * fill in all the references to the asmObject with pointers to the heap object.
 121  *
 122  * We obtain a limited form of polymorphism through inheritance by putting
 123  * the AsmObject first in every structure (as in C++ implementations).
 124  * We use the closure type of the allocated object to figure out
 125  * where the payload lives in the closure.
 126  * ------------------------------------------------------------------------*/
 127 /* ToDo: clean up terminology: is Closure right or should it be object or ... */
 128
 129 struct AsmObject_ {
 130     Refs           refs;
 131     Ptrs           ptrs;
 132     AsmNat         num_unresolved; /* number of unfilled references */
 133     StgClosure*    closure;        /* where object was allocated    */
 134 };
 135
 136 struct AsmCon_ {
 137     struct AsmObject_ object;  /* must be first in struct */
 138
 139     AsmInfo info;
 140 };
 141
 142 struct AsmCAF_ {
 143     struct AsmObject_ object;  /* must be first in struct */
 144 };
 145
 146 struct AsmBCO_ {
 147     struct AsmObject_ object;  /* must be first in struct */
 148
 149     Instrs   is;
 150     NonPtrs  nps;
 151
 152     int /*StgExpr*/  stgexpr;
 153
 154     /* abstract machine ("executed" during compilation) */
 155     AsmSp    sp;          /* stack ptr */
 156     AsmSp    max_sp;
 157     StgWord  hp;          /* heap ptr  */
 158     StgWord  max_hp;
 159     Instr    lastOpc;
 160 };
 161
 162 static void asmResolveRef( AsmObject obj, AsmNat i, AsmClosure reference )
 163 {
 164     ASSERT(obj->closure);
 165     switch (get_itbl(obj->closure)->type) {
 166     case BCO:
 167         {
 168             StgBCO* bco = stgCast(StgBCO*,obj->closure);
 169             ASSERT(i < bco->n_ptrs && bcoConstPtr(bco,i) == NULL);
 170             bcoConstCPtr(bco,i) = reference;
 171             break;
 172         }
 173     case CAF_UNENTERED:
 174         {
 175             StgCAF* caf = stgCast(StgCAF*,obj->closure);
 176             ASSERT(i == 0 && caf->body == NULL);
 177             caf->body = reference;
 178             break;
 179         }
 180     case CONSTR:
 181         {
 182             StgClosure* con = stgCast(StgClosure*,obj->closure);
 183             ASSERT(i < get_itbl(con)->layout.payload.nptrs && payloadCPtr(con,i) == NULL);
 184             payloadCPtr(con,i) = reference;
 185             break;
 186         }
 187     case AP_UPD:
 188         {
 189             StgAP_UPD* ap = stgCast(StgAP_UPD*,obj->closure);
 190             ASSERT(i < 1+ap->n_args);
 191             if (i==0) {
 192                 ASSERT(ap->fun == NULL);
 193                 ap->fun = reference;
 194             } else {
 195                 ASSERT(payloadCPtr(ap,i-1) == NULL);
 196                 payloadCPtr(ap,i-1) = reference;
 197             }
 198             break;
 199         }
 200     default:
 201             barf("asmResolveRef");
 202     }
 203     obj->num_unresolved -= 1;
 204 }
 205
 206 static void asmAddRef( AsmObject referent, AsmObject referer, AsmNat i )
 207 {
 208     if (referent->closure) {
 209         asmResolveRef(referer,i,(AsmClosure)referent->closure);
 210     } else {
 211         insertRefs(&(referent->refs),(AsmRef){referer,i});
 212     }
 213 }
 214
 215 void asmAddPtr( AsmObject obj, AsmObject arg )
 216 {
 217     ASSERT(obj->closure == 0); /* can't extend an object once it's allocated */
 218     insertPtrs( &obj->ptrs, arg );
 219 }
 220
 221 static void asmBeginObject( AsmObject obj )
 222 {
 223     obj->closure = NULL;
 224     obj->num_unresolved = 0;
 225     initRefs(&obj->refs);
 226     initPtrs(&obj->ptrs);
 227 }
 228
 229 static void asmEndObject( AsmObject obj, StgClosure* c )
 230 {
 231     obj->num_unresolved = obj->ptrs.len;
 232     obj->closure = c;
 233     mapQueue(Ptrs,    AsmObject, obj->ptrs, asmAddRef(x,obj,i));
 234     mapQueue(Refs,    AsmRef,    obj->refs, asmResolveRef(x.ref,x.i,c));
 235
 236     if (obj->num_unresolved == 0) {
 237         freePtrs(&obj->ptrs);
 238         freeRefs(&obj->refs);
 239         /* we don't print until all ptrs are resolved */
 240         IF_DEBUG(codegen,printObj(obj->closure));
 241     }
 242 }
 243
 244 int asmObjectHasClosure ( AsmObject obj )
 245 {
 246     return (obj->num_unresolved == 0 && obj->closure);
 247 }
 248
 249 AsmClosure asmClosureOfObject ( AsmObject obj )
 250 {
 251     ASSERT(asmObjectHasClosure(obj));
 252     return obj->closure;
 253 }
 254
 255 void asmMarkObject ( AsmObject obj )
 256 {
 257     ASSERT(obj->num_unresolved == 0 && obj->closure);
 258     obj->closure = MarkRoot(obj->closure);
 259 }
 260
 261 /* --------------------------------------------------------------------------
 262  * Heap allocation
 263  * ------------------------------------------------------------------------*/
 264
 265 static StgClosure* asmAlloc( nat size )
 266 {
 267     StgClosure* o = stgCast(StgClosure*,allocate(size));
 268     ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
 269     /* printf("Allocated %p .. %p\n", o, o+size-1); */
 270     return o;
 271 }
 272
 273 static void grabHpUpd( AsmBCO bco, nat size )
 274 {
 275     /* ToDo: sometimes we should test for MIN_UPD_SIZE instead */
 276     ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
 277     bco->hp += size;
 278 }
 279
 280 static void grabHpNonUpd( AsmBCO bco, nat size )
 281 {
 282     /* ToDo: sometimes we should test for MIN_UPD_SIZE instead */
 283     ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
 284     bco->hp += size;
 285 }
 286
 287 static void resetHp( AsmBCO bco, nat hp )
 288 {
 289     bco->max_hp = stg_max(bco->hp,bco->max_hp);
 290     bco->hp     = hp;
 291 }
 292
 293 static void setSp( AsmBCO bco, AsmSp sp )
 294 {
 295     bco->max_sp = stg_max(bco->sp,bco->max_sp);
 296     bco->sp     = sp;
 297     bco->max_sp = stg_max(bco->sp,bco->max_sp);
 298 }
 299
 300 static void incSp ( AsmBCO bco, int sp_delta )
 301 {
 302     bco->max_sp  = stg_max(bco->sp,bco->max_sp);
 303     bco->sp     += sp_delta;
 304     bco->max_sp  = stg_max(bco->sp,bco->max_sp);
 305 }
 306
 307 static void decSp ( AsmBCO bco, int sp_delta )
 308 {
 309     bco->max_sp  = stg_max(bco->sp,bco->max_sp);
 310     bco->sp     -= sp_delta;
 311     bco->max_sp  = stg_max(bco->sp,bco->max_sp);
 312 }
 313
 314 /* --------------------------------------------------------------------------
 315  *
 316  * ------------------------------------------------------------------------*/
 317
 318 AsmObject asmMkObject( AsmClosure c )
 319 {
 320     AsmObject obj = malloc(sizeof(struct AsmObject_));
 321     if (obj == NULL) {
 322         barf("Can't allocate AsmObject");
 323     }
 324     asmBeginObject(obj);
 325     asmEndObject(obj,c);
 326     return obj;
 327 }
 328
 329 AsmCon asmBeginCon( AsmInfo info )
 330 {
 331     AsmCon con = malloc(sizeof(struct AsmCon_));
 332     if (con == NULL) {
 333         barf("Can't allocate AsmCon");
 334     }
 335     asmBeginObject(&con->object);
 336     con->info = info;
 337     return con;
 338 }
 339
 340 void asmEndCon( AsmCon con )
 341 {
 342     nat p  = con->object.ptrs.len;
 343     nat np = stg_max(0,MIN_NONUPD_SIZE-p);
 344
 345     StgClosure* c = asmAlloc(CONSTR_sizeW(p,np));
 346     StgClosure* o = stgCast(StgClosure*,c);
 347     SET_HDR(o,con->info,??);
 348     mapQueue(Ptrs,    AsmObject, con->object.ptrs, payloadCPtr(o,i) = NULL);
 349     { nat i; for( i=0; i<np; ++i ) { payloadWord(o,p+i) = 0xdeadbeef; } }
 350     asmEndObject(&con->object,c);
 351 }
 352
 353 AsmCAF asmBeginCAF( void )
 354 {
 355     AsmCAF caf = malloc(sizeof(struct AsmCAF_));
 356     if (caf == NULL) {
 357         barf("Can't allocate AsmCAF");
 358     }
 359     asmBeginObject(&caf->object);
 360     return caf;
 361 }
 362
 363 void asmEndCAF( AsmCAF caf, AsmBCO body )
 364 {
 365     StgClosure* c = asmAlloc(CAF_sizeW());
 366     StgCAF*     o = stgCast(StgCAF*,c);
 367     SET_HDR(o,&CAF_UNENTERED_info,??);
 368     o->body  = NULL;
 369     o->value = stgCast(StgClosure*,0xdeadbeef);
 370     o->link  = stgCast(StgCAF*,0xdeadbeef);
 371     o->mut_link = NULL;
 372     asmAddPtr(&caf->object,&body->object);
 373     asmEndObject(&caf->object,c);
 374 }
 375
 376 AsmBCO asmBeginBCO( int /*StgExpr*/ e )
 377 {
 378     AsmBCO bco = malloc(sizeof(struct AsmBCO_));
 379     if (bco == NULL) {
 380         barf("Can't allocate AsmBCO");
 381     }
 382     asmBeginObject(&bco->object);
 383     initInstrs(&bco->is);
 384     initNonPtrs(&bco->nps);
 385
 386     bco->stgexpr = e;
 387     bco->max_sp = bco->sp = 0;
 388     bco->max_hp = bco->hp = 0;
 389     bco->lastOpc = i_INTERNAL_ERROR;
 390     return bco;
 391 }
 392
 393 void asmEndBCO( AsmBCO bco )
 394 {
 395     nat p  = bco->object.ptrs.len;
 396     nat np = bco->nps.len;
 397     nat is = bco->is.len + (bco->max_sp <= 255 ? 2 : 3);  /* 2 or 3 for stack check */
 398
 399     StgClosure* c = asmAlloc(BCO_sizeW(p,np,is));
 400     StgBCO*     o = stgCast(StgBCO*,c);
 401     SET_HDR(o,&BCO_info,??);
 402     o->n_ptrs   = p;
 403     o->n_words  = np;
 404     o->n_instrs = is;
 405     o->stgexpr  = bco->stgexpr;
 406     mapQueue(Ptrs,    AsmObject, bco->object.ptrs, bcoConstCPtr(o,i) = NULL);
 407     mapQueue(NonPtrs, StgWord,   bco->nps,  bcoConstWord(o,i) = x);
 408     {
 409         nat j = 0;
 410         bco->max_sp = stg_max(bco->sp,bco->max_sp);
 411         bco->max_hp = stg_max(bco->hp,bco->max_hp);
 412
 413         ASSERT(bco->max_sp <= 65535);
 414         if (bco->max_sp <= 255) {
 415            bcoInstr(o,j++) = i_STK_CHECK;
 416            bcoInstr(o,j++) = bco->max_sp;
 417         } else {
 418            bcoInstr(o,j++) = i_STK_CHECK_big;
 419            bcoInstr(o,j++) = bco->max_sp / 256;
 420            bcoInstr(o,j++) = bco->max_sp % 256;
 421         }
 422
 423         mapQueue(Instrs,  StgWord8,   bco->is,   bcoInstr(o,j++) = x);
 424         ASSERT(j == is);
 425     }
 426     freeInstrs(&bco->is);
 427     freeNonPtrs(&bco->nps);
 428     asmEndObject(&bco->object,c);
 429 }
 430
 431 /* --------------------------------------------------------------------------
 432  *
 433  * ------------------------------------------------------------------------*/
 434
 435 static void asmInstrOp ( AsmBCO bco, StgWord i )
 436 {
 437     ASSERT(i <= BIGGEST_OPCODE); /* must be a valid opcode */
 438     bco->lastOpc = i;
 439     insertInstrs(&(bco->is),i);
 440 }
 441
 442 static void asmInstr8 ( AsmBCO bco, StgWord i )
 443 {
 444   if (i >= 256) {
 445     ASSERT(i < 256); /* must be a byte */
 446   }
 447     insertInstrs(&(bco->is),i);
 448 }
 449
 450 static void asmInstr16 ( AsmBCO bco, StgWord i )
 451 {
 452     ASSERT(i < 65536); /* must be a short */
 453     insertInstrs(&(bco->is),i / 256);
 454     insertInstrs(&(bco->is),i % 256);
 455 }
 456
 457 static Instr asmInstrBack ( AsmBCO bco, StgWord n )
 458 {
 459    return bco->is.elems[bco->is.len - n];
 460 }
 461
 462 static void asmInstrRecede ( AsmBCO bco, StgWord n )
 463 {
 464    if (bco->is.len < n) barf("asmInstrRecede");
 465    bco->is.len -= n;
 466 }
 467
 468 static void asmPtr( AsmBCO bco, AsmObject x )
 469 {
 470     insertPtrs( &bco->object.ptrs, x );
 471 }
 472
 473 static void asmWord( AsmBCO bco, StgWord i )
 474 {
 475     insertNonPtrs( &bco->nps, i );
 476 }
 477
 478 static int asmFindInNonPtrs ( AsmBCO bco, StgWord i )
 479 {
 480    return findInNonPtrs ( &bco->nps, i );
 481 }
 482
 483 #define asmWords(bco,ty,x)                               \
 484     {                                                    \
 485         union { ty a; AsmWord b[sizeofW(ty)]; } p;       \
 486         nat i;                                           \
 487         if (sizeof(ty) < sizeof(AsmWord)) p.b[0]=0;      \
 488         p.a = x;                                         \
 489         for( i = 0; i < sizeofW(ty); i++ ) {             \
 490             asmWord(bco,p.b[i]);                         \
 491         }                                                \
 492     }
 493
 494 static StgWord repSizeW( AsmRep rep )
 495 {
 496     switch (rep) {
 497     case CHAR_REP:    return sizeofW(StgWord) + sizeofW(StgChar);
 498
 499     case BOOL_REP:
 500     case INT_REP:      return sizeofW(StgWord) + sizeofW(StgInt);
 501     case THREADID_REP:
 502     case WORD_REP:     return sizeofW(StgWord) + sizeofW(StgWord);
 503     case ADDR_REP:     return sizeofW(StgWord) + sizeofW(StgAddr);
 504     case FLOAT_REP:    return sizeofW(StgWord) + sizeofW(StgFloat);
 505     case DOUBLE_REP:   return sizeofW(StgWord) + sizeofW(StgDouble);
 506     case STABLE_REP:   return sizeofW(StgWord) + sizeofW(StgWord);
 507
 508     case INTEGER_REP:
 509 #ifdef PROVIDE_WEAK
 510     case WEAK_REP:
 511 #endif
 512 #ifdef PROVIDE_FOREIGN
 513     case FOREIGN_REP:
 514 #endif
 515     case ALPHA_REP:    /* a                        */
 516     case BETA_REP:     /* b                        */
 517     case GAMMA_REP:    /* c                        */
 518     case DELTA_REP:    /* d                        */
 519     case HANDLER_REP:  /* IOError -> IO a          */
 520     case ERROR_REP:    /* IOError                  */
 521     case ARR_REP    :  /* PrimArray              a */
 522     case BARR_REP   :  /* PrimByteArray          a */
 523     case REF_REP    :  /* Ref                  s a */
 524     case MUTARR_REP :  /* PrimMutableArray     s a */
 525     case MUTBARR_REP:  /* PrimMutableByteArray s a */
 526     case MVAR_REP:     /* MVar a                   */
 527     case PTR_REP:     return sizeofW(StgPtr);
 528
 529     case VOID_REP:    return sizeofW(StgWord);
 530     default:          barf("repSizeW %d",rep);
 531     }
 532 }
 533
 534
 535 int asmRepSizeW ( AsmRep rep )
 536 {
 537    return repSizeW ( rep );
 538 }
 539
 540
 541 /* --------------------------------------------------------------------------
 542  * Instruction emission.  All instructions should be routed through here
 543  * so that the peephole optimiser gets to see what's happening.
 544  * ------------------------------------------------------------------------*/
 545
 546 static void emiti_ ( AsmBCO bco, Instr opcode )
 547 {
 548    StgInt x, y;
 549    if (bco->lastOpc == i_SLIDE && opcode == i_ENTER) {
 550       /* SLIDE x y ; ENTER   ===>  SE x y */
 551       x = asmInstrBack(bco,2);
 552       y = asmInstrBack(bco,1);
 553       asmInstrRecede(bco,3);
 554       asmInstrOp(bco,i_SE); asmInstr8(bco,x); asmInstr8(bco,y);
 555    }
 556    else
 557    if (bco->lastOpc == i_RV && opcode == i_ENTER) {
 558       /* RV x y ; ENTER ===> RVE x (y-2)
 559          Because RETADDR pushes 2 words on the stack, y must be at least 2. */
 560       x = asmInstrBack(bco,2);
 561       y = asmInstrBack(bco,1);
 562       if (y < 2) barf("emiti_: RVE: impossible y value");
 563       asmInstrRecede(bco,3);
 564       asmInstrOp(bco, i_RVE); asmInstr8(bco,x); asmInstr8(bco,y-2);
 565    }
 566    else {
 567       asmInstrOp(bco,opcode);
 568    }
 569 }
 570
 571 static void emiti_8 ( AsmBCO bco, Instr opcode, int arg1 )
 572 {
 573    StgInt x;
 574    if (bco->lastOpc == i_VAR && opcode == i_VAR) {
 575       /* VAR x ; VAR y ===>  VV x y */
 576       x = asmInstrBack(bco,1);
 577       asmInstrRecede(bco,2);
 578       asmInstrOp(bco,i_VV); asmInstr8(bco,x); asmInstr8(bco,arg1);
 579    }
 580    else
 581    if (bco->lastOpc == i_RETADDR && opcode == i_VAR) {
 582       /* RETADDR x ; VAR y ===> RV x y */
 583       x = asmInstrBack(bco,1);
 584       asmInstrRecede(bco,2);
 585       asmInstrOp(bco, i_RV); asmInstr8(bco,x); asmInstr8(bco,arg1);
 586    }
 587    else {
 588       asmInstrOp(bco,opcode);
 589       asmInstr8(bco,arg1);
 590    }
 591 }
 592
 593 static void emiti_16 ( AsmBCO bco, Instr opcode, int arg1 )
 594 {
 595    asmInstrOp(bco,opcode);
 596    asmInstr16(bco,arg1);
 597 }
 598
 599 static void emiti_8_8 ( AsmBCO bco, Instr opcode, int arg1, int arg2 )
 600 {
 601    asmInstrOp(bco,opcode);
 602    asmInstr8(bco,arg1);
 603    asmInstr8(bco,arg2);
 604 }
 605
 606 static void emiti_8_16 ( AsmBCO bco, Instr opcode, int arg1, int arg2 )
 607 {
 608    asmInstrOp(bco,opcode);
 609    asmInstr8(bco,arg1);
 610    asmInstr16(bco,arg2);
 611 }
 612
 613 static void emiti_16_16 ( AsmBCO bco, Instr opcode, int arg1, int arg2 )
 614 {
 615    asmInstrOp(bco,opcode);
 616    asmInstr16(bco,arg1);
 617    asmInstr16(bco,arg2);
 618 }
 619
 620
 621 /* --------------------------------------------------------------------------
 622  * Wrappers around the above fns
 623  * ------------------------------------------------------------------------*/
 624
 625 static void emit_i_VAR_INT ( AsmBCO bco, int arg1 )
 626 {
 627    ASSERT(arg1 >= 0);
 628    if (arg1 < 256)
 629       emiti_8 (bco,i_VAR_INT,    arg1); else
 630       emiti_16(bco,i_VAR_INT_big,arg1);
 631 }
 632
 633 static void emit_i_VAR_WORD ( AsmBCO bco, int arg1 )
 634 {
 635    ASSERT(arg1 >= 0);
 636    if (arg1 < 256)
 637       emiti_8 (bco,i_VAR_WORD,    arg1); else
 638       emiti_16(bco,i_VAR_WORD_big,arg1);
 639 }
 640
 641 static void emit_i_VAR_ADDR ( AsmBCO bco, int arg1 )
 642 {
 643    ASSERT(arg1 >= 0);
 644    if (arg1 < 256)
 645       emiti_8 (bco,i_VAR_ADDR,    arg1); else
 646       emiti_16(bco,i_VAR_ADDR_big,arg1);
 647 }
 648
 649 static void emit_i_VAR_CHAR ( AsmBCO bco, int arg1 )
 650 {
 651    ASSERT(arg1 >= 0);
 652    if (arg1 < 256)
 653       emiti_8 (bco,i_VAR_CHAR,    arg1); else
 654       emiti_16(bco,i_VAR_CHAR_big,arg1);
 655 }
 656
 657 static void emit_i_VAR_FLOAT ( AsmBCO bco, int arg1 )
 658 {
 659    ASSERT(arg1 >= 0);
 660    if (arg1 < 256)
 661       emiti_8 (bco,i_VAR_FLOAT,    arg1); else
 662       emiti_16(bco,i_VAR_FLOAT_big,arg1);
 663 }
 664
 665 static void emit_i_VAR_DOUBLE ( AsmBCO bco, int arg1 )
 666 {
 667    ASSERT(arg1 >= 0);
 668    if (arg1 < 256)
 669       emiti_8 (bco,i_VAR_DOUBLE,    arg1); else
 670       emiti_16(bco,i_VAR_DOUBLE_big,arg1);
 671 }
 672
 673 static void emit_i_VAR_STABLE ( AsmBCO bco, int arg1 )
 674 {
 675    ASSERT(arg1 >= 0);
 676    if (arg1 < 256)
 677       emiti_8 (bco,i_VAR_STABLE,    arg1); else
 678       emiti_16(bco,i_VAR_STABLE_big,arg1);
 679 }
 680
 681 static void emit_i_VAR ( AsmBCO bco, int arg1 )
 682 {
 683    ASSERT(arg1 >= 0);
 684    if (arg1 < 256)
 685       emiti_8 (bco,i_VAR,    arg1); else
 686       emiti_16(bco,i_VAR_big,arg1);
 687 }
 688
 689 static void emit_i_PACK ( AsmBCO bco, int arg1 )
 690 {
 691    ASSERT(arg1 >= 0);
 692    if (arg1 < 256)
 693       emiti_8 (bco,i_PACK,    arg1); else
 694       emiti_16(bco,i_PACK_big,arg1);
 695 }
 696
 697 static void emit_i_SLIDE ( AsmBCO bco, int arg1, int arg2 )
 698 {
 699    ASSERT(arg1 >= 0);
 700    ASSERT(arg2 >= 0);
 701    if (arg1 < 256 && arg2 < 256)
 702       emiti_8_8  (bco,i_SLIDE,    arg1,arg2); else
 703       emiti_16_16(bco,i_SLIDE_big,arg1,arg2);
 704 }
 705
 706 static void emit_i_MKAP ( AsmBCO bco, int arg1, int arg2 )
 707 {
 708    ASSERT(arg1 >= 0);
 709    ASSERT(arg2 >= 0);
 710    if (arg1 < 256 && arg2 < 256)
 711       emiti_8_8  (bco,i_MKAP,    arg1,arg2); else
 712       emiti_16_16(bco,i_MKAP_big,arg1,arg2);
 713 }
 714
 715
 716 static void emit_i_CONST_INT ( AsmBCO bco, int arg1 )
 717 {
 718    ASSERT(arg1 >= 0);
 719    if (arg1 < 256)
 720       emiti_8 (bco,i_CONST_INT,    arg1); else
 721       emiti_16(bco,i_CONST_INT_big,arg1);
 722 }
 723
 724 static void emit_i_CONST_INTEGER ( AsmBCO bco, int arg1 )
 725 {
 726    ASSERT(arg1 >= 0);
 727    if (arg1 < 256)
 728       emiti_8 (bco,i_CONST_INTEGER,    arg1); else
 729       emiti_16(bco,i_CONST_INTEGER_big,arg1);
 730 }
 731
 732 static void emit_i_CONST_ADDR ( AsmBCO bco, int arg1 )
 733 {
 734    ASSERT(arg1 >= 0);
 735    if (arg1 < 256)
 736       emiti_8 (bco,i_CONST_ADDR,    arg1); else
 737       emiti_16(bco,i_CONST_ADDR_big,arg1);
 738 }
 739
 740 static void emit_i_CONST_CHAR ( AsmBCO bco, int arg1 )
 741 {
 742    ASSERT(arg1 >= 0);
 743    if (arg1 < 256)
 744       emiti_8 (bco,i_CONST_CHAR,    arg1); else
 745       emiti_16(bco,i_CONST_CHAR_big,arg1);
 746 }
 747
 748 static void emit_i_CONST_FLOAT ( AsmBCO bco, int arg1 )
 749 {
 750    ASSERT(arg1 >= 0);
 751    if (arg1 < 256)
 752       emiti_8 (bco,i_CONST_FLOAT,    arg1); else
 753       emiti_16(bco,i_CONST_FLOAT_big,arg1);
 754 }
 755
 756 static void emit_i_CONST_DOUBLE ( AsmBCO bco, int arg1 )
 757 {
 758    ASSERT(arg1 >= 0);
 759    if (arg1 < 256)
 760       emiti_8 (bco,i_CONST_DOUBLE,    arg1); else
 761       emiti_16(bco,i_CONST_DOUBLE_big,arg1);
 762 }
 763
 764 static void emit_i_CONST ( AsmBCO bco, int arg1 )
 765 {
 766    ASSERT(arg1 >= 0);
 767    if (arg1 < 256)
 768       emiti_8 (bco,i_CONST,    arg1); else
 769       emiti_16(bco,i_CONST_big,arg1);
 770 }
 771
 772 static void emit_i_RETADDR ( AsmBCO bco, int arg1 )
 773 {
 774    ASSERT(arg1 >= 0);
 775    if (arg1 < 256)
 776       emiti_8 (bco,i_RETADDR,    arg1); else
 777       emiti_16(bco,i_RETADDR_big,arg1);
 778 }
 779
 780
 781 /* --------------------------------------------------------------------------
 782  * Arg checks.
 783  * ------------------------------------------------------------------------*/
 784
 785 AsmSp  asmBeginArgCheck ( AsmBCO bco )
 786 {
 787     ASSERT(bco->sp == 0);
 788     return bco->sp;
 789 }
 790
 791 void   asmEndArgCheck   ( AsmBCO bco, AsmSp last_arg )
 792 {
 793     nat args = bco->sp - last_arg;
 794     if (args != 0) { /* optimisation */
 795         emiti_8(bco,i_ARG_CHECK,args);
 796         grabHpNonUpd(bco,PAP_sizeW(args-1));
 797         resetHp(bco,0);
 798     }
 799 }
 800
 801 /* --------------------------------------------------------------------------
 802  * Creating and using "variables"
 803  * ------------------------------------------------------------------------*/
 804
 805 AsmVar asmBind          ( AsmBCO bco, AsmRep rep )
 806 {
 807     incSp(bco,repSizeW(rep));
 808     return bco->sp;
 809 }
 810
 811 void   asmVar           ( AsmBCO bco, AsmVar v, AsmRep rep )
 812 {
 813     int offset;
 814
 815     if (rep == VOID_REP) {
 816         emiti_(bco,i_VOID);
 817         incSp(bco,repSizeW(rep));
 818         return;
 819     }
 820
 821     offset = bco->sp - v;
 822     switch (rep) {
 823     case BOOL_REP:
 824     case INT_REP:
 825             emit_i_VAR_INT(bco,offset);
 826             break;
 827     case THREADID_REP:
 828     case WORD_REP:
 829             emit_i_VAR_WORD(bco,offset);
 830             break;
 831     case ADDR_REP:
 832             emit_i_VAR_ADDR(bco,offset);
 833             break;
 834     case CHAR_REP:
 835             emit_i_VAR_CHAR(bco,offset);
 836             break;
 837     case FLOAT_REP:
 838             emit_i_VAR_FLOAT(bco,offset);
 839             break;
 840     case DOUBLE_REP:
 841             emit_i_VAR_DOUBLE(bco,offset);
 842             break;
 843     case STABLE_REP:
 844             emit_i_VAR_STABLE(bco,offset);
 845             break;
 846
 847     case INTEGER_REP:
 848 #ifdef PROVIDE_WEAK
 849     case WEAK_REP:
 850 #endif
 851 #ifdef PROVIDE_FOREIGN
 852     case FOREIGN_REP:
 853 #endif
 854     case ALPHA_REP:    /* a                        */
 855     case BETA_REP:     /* b                        */
 856     case GAMMA_REP:    /* c                        */
 857     case DELTA_REP:    /* d                        */
 858     case HANDLER_REP:  /* IOError -> IO a          */
 859     case ERROR_REP:    /* IOError                  */
 860     case ARR_REP    :  /* PrimArray              a */
 861     case BARR_REP   :  /* PrimByteArray          a */
 862     case REF_REP    :  /* Ref                  s a */
 863     case MUTARR_REP :  /* PrimMutableArray     s a */
 864     case MUTBARR_REP:  /* PrimMutableByteArray s a */
 865     case MVAR_REP:     /* MVar a                   */
 866     case PTR_REP:
 867             emit_i_VAR(bco,offset);
 868             break;
 869     default:
 870             barf("asmVar %d",rep);
 871     }
 872     incSp(bco,repSizeW(rep));
 873 }
 874
 875 /* --------------------------------------------------------------------------
 876  * Tail calls
 877  * ------------------------------------------------------------------------*/
 878
 879 AsmSp asmBeginEnter( AsmBCO bco )
 880 {
 881     return bco->sp;
 882 }
 883
 884 void asmEndEnter( AsmBCO bco, AsmSp sp1, AsmSp sp2 )
 885 {
 886     int x = bco->sp - sp1;
 887     int y = sp1 - sp2;
 888     ASSERT(x >= 0 && y >= 0);
 889     if (y != 0) {
 890         emit_i_SLIDE(bco,x,y);
 891         decSp(bco,sp1 - sp2);
 892     }
 893     emiti_(bco,i_ENTER);
 894     decSp(bco,sizeofW(StgPtr));
 895 }
 896
 897 /* --------------------------------------------------------------------------
 898  * Build boxed Ints, Floats, etc
 899  * ------------------------------------------------------------------------*/
 900
 901 AsmVar asmBox( AsmBCO bco, AsmRep rep )
 902 {
 903     switch (rep) {
 904     case CHAR_REP:
 905             emiti_(bco,i_PACK_CHAR);
 906             grabHpNonUpd(bco,Czh_sizeW);
 907             break;
 908     case INT_REP:
 909             emiti_(bco,i_PACK_INT);
 910             grabHpNonUpd(bco,Izh_sizeW);
 911             break;
 912     case THREADID_REP:
 913     case WORD_REP:
 914             emiti_(bco,i_PACK_WORD);
 915             grabHpNonUpd(bco,Wzh_sizeW);
 916             break;
 917     case ADDR_REP:
 918             emiti_(bco,i_PACK_ADDR);
 919             grabHpNonUpd(bco,Azh_sizeW);
 920             break;
 921     case FLOAT_REP:
 922             emiti_(bco,i_PACK_FLOAT);
 923             grabHpNonUpd(bco,Fzh_sizeW);
 924             break;
 925     case DOUBLE_REP:
 926             emiti_(bco,i_PACK_DOUBLE);
 927             grabHpNonUpd(bco,Dzh_sizeW);
 928             break;
 929     case STABLE_REP:
 930             emiti_(bco,i_PACK_STABLE);
 931             grabHpNonUpd(bco,Stablezh_sizeW);
 932             break;
 933
 934     default:
 935             barf("asmBox %d",rep);
 936     }
 937     /* NB: these operations DO pop their arg       */
 938     decSp(bco, repSizeW(rep));   /* pop unboxed arg */
 939     incSp(bco, sizeofW(StgPtr)); /* push box        */
 940     return bco->sp;
 941 }
 942
 943 /* --------------------------------------------------------------------------
 944  * Unbox Ints, Floats, etc
 945  * ------------------------------------------------------------------------*/
 946
 947 AsmVar asmUnbox( AsmBCO bco, AsmRep rep )
 948 {
 949     switch (rep) {
 950     case INT_REP:
 951             emiti_(bco,i_UNPACK_INT);
 952             break;
 953     case THREADID_REP:
 954     case WORD_REP:
 955             emiti_(bco,i_UNPACK_WORD);
 956             break;
 957     case ADDR_REP:
 958             emiti_(bco,i_UNPACK_ADDR);
 959             break;
 960     case CHAR_REP:
 961             emiti_(bco,i_UNPACK_CHAR);
 962             break;
 963     case FLOAT_REP:
 964             emiti_(bco,i_UNPACK_FLOAT);
 965             break;
 966     case DOUBLE_REP:
 967             emiti_(bco,i_UNPACK_DOUBLE);
 968             break;
 969     case STABLE_REP:
 970             emiti_(bco,i_UNPACK_STABLE);
 971             break;
 972     default:
 973             barf("asmUnbox %d",rep);
 974     }
 975     /* NB: these operations DO NOT pop their arg  */
 976     incSp(bco, repSizeW(rep)); /* push unboxed arg */
 977     return bco->sp;
 978 }
 979
 980
 981 /* --------------------------------------------------------------------------
 982  * Push unboxed Ints, Floats, etc
 983  * ------------------------------------------------------------------------*/
 984
 985 void asmConstInt( AsmBCO bco, AsmInt x )
 986 {
 987     emit_i_CONST_INT(bco,bco->nps.len);
 988     asmWords(bco,AsmInt,x);
 989     incSp(bco, repSizeW(INT_REP));
 990 }
 991
 992 void asmConstInteger( AsmBCO bco, AsmString x )
 993 {
 994     emit_i_CONST_INTEGER(bco,bco->nps.len);
 995     asmWords(bco,AsmString,x);
 996     incSp(bco, repSizeW(INTEGER_REP));
 997 }
 998
 999 void asmConstAddr( AsmBCO bco, AsmAddr x )
1000 {
1001     emit_i_CONST_ADDR(bco,bco->nps.len);
1002     asmWords(bco,AsmAddr,x);
1003     incSp(bco, repSizeW(ADDR_REP));
1004 }
1005
1006 void asmConstWord( AsmBCO bco, AsmWord x )
1007 {
1008     emit_i_CONST_INT(bco,bco->nps.len);
1009     asmWords(bco,AsmWord,(AsmInt)x);
1010     incSp(bco, repSizeW(WORD_REP));
1011 }
1012
1013 void asmConstChar( AsmBCO bco, AsmChar x )
1014 {
1015     emit_i_CONST_CHAR(bco,bco->nps.len);
1016     asmWords(bco,AsmChar,x);
1017     incSp(bco, repSizeW(CHAR_REP));
1018 }
1019
1020 void asmConstFloat( AsmBCO bco, AsmFloat x )
1021 {
1022     emit_i_CONST_FLOAT(bco,bco->nps.len);
1023     asmWords(bco,AsmFloat,x);
1024     incSp(bco, repSizeW(FLOAT_REP));
1025 }
1026
1027 void asmConstDouble( AsmBCO bco, AsmDouble x )
1028 {
1029     emit_i_CONST_DOUBLE(bco,bco->nps.len);
1030     asmWords(bco,AsmDouble,x);
1031     incSp(bco, repSizeW(DOUBLE_REP));
1032 }
1033
1034 /* --------------------------------------------------------------------------
1035  * Algebraic case helpers
1036  * ------------------------------------------------------------------------*/
1037
1038 /* a mildly bogus pair of functions... */
1039 AsmSp asmBeginCase( AsmBCO bco )
1040 {
1041     return bco->sp;
1042 }
1043
1044 void asmEndCase( AsmBCO bco )
1045 {
1046 }
1047
1048 AsmSp asmContinuation( AsmBCO bco, AsmBCO ret_addr )
1049 {
1050     emit_i_RETADDR(bco,bco->object.ptrs.len);
1051     asmPtr(bco,&(ret_addr->object));
1052     incSp(bco, 2 * sizeofW(StgPtr));
1053     return bco->sp;
1054 }
1055
1056 AsmBCO asmBeginContinuation ( AsmSp sp, int /*List*/ alts )
1057 {
1058     AsmBCO bco = asmBeginBCO(alts);
1059     setSp(bco, sp);
1060     return bco;
1061 }
1062
1063 void asmEndContinuation ( AsmBCO bco )
1064 {
1065     asmEndBCO(bco);
1066 }
1067
1068
1069 /* --------------------------------------------------------------------------
1070  * Branches
1071  * ------------------------------------------------------------------------*/
1072
1073 AsmSp asmBeginAlt( AsmBCO bco )
1074 {
1075     return bco->sp;
1076 }
1077
1078 void asmEndAlt( AsmBCO bco, AsmSp  sp )
1079 {
1080     setSp(bco,sp);
1081 }
1082
1083 AsmPc asmTest( AsmBCO bco, AsmWord tag )
1084 {
1085     emiti_8_16(bco,i_TEST,tag,0);
1086     return bco->is.len;
1087 }
1088
1089 AsmPc asmTestInt( AsmBCO bco, AsmVar v, AsmInt x )
1090 {
1091     asmVar(bco,v,INT_REP);
1092     asmConstInt(bco,x);
1093     emiti_16(bco,i_TEST_INT,0);
1094     decSp(bco, 2*repSizeW(INT_REP));
1095     return bco->is.len;
1096 }
1097
1098 void asmFixBranch( AsmBCO bco, AsmPc from )
1099 {
1100     int distance = bco->is.len - from;
1101     ASSERT(distance >= 0);
1102     ASSERT(distance < 65536);
1103     setInstrs(&(bco->is),from-2,distance/256);
1104     setInstrs(&(bco->is),from-1,distance%256);
1105 }
1106
1107 void asmPanic( AsmBCO bco )
1108 {
1109     emiti_(bco,i_PANIC); /* "irrefutable" pattern failed - oops! */
1110 }
1111
1112 /* --------------------------------------------------------------------------
1113  * Primops
1114  * ------------------------------------------------------------------------*/
1115
1116 AsmSp asmBeginPrim( AsmBCO bco )
1117 {
1118     return bco->sp;
1119 }
1120
1121 void asmEndPrim( AsmBCO bco, const AsmPrim* prim, AsmSp base )
1122 {
1123     emiti_8(bco,prim->prefix,prim->opcode);
1124     setSp(bco, base);
1125 }
1126
1127 char* asmGetPrimopName ( AsmPrim* p )
1128 {
1129    return p->name;
1130 }
1131
1132 /* Hugs used to let you add arbitrary primops with arbitrary types
1133  * just by editing Prelude.hs or any other file you wanted.
1134  * We deliberately avoided that approach because we wanted more
1135  * control over which primops are provided.
1136  */
1137 AsmPrim asmPrimOps[] = {
1138
1139     /* Char# operations */
1140       { "primGtChar",                "CC", "B",  MONAD_Id, i_PRIMOP1, i_gtChar }
1141     , { "primGeChar",                "CC", "B",  MONAD_Id, i_PRIMOP1, i_geChar }
1142     , { "primEqChar",                "CC", "B",  MONAD_Id, i_PRIMOP1, i_eqChar }
1143     , { "primNeChar",                "CC", "B",  MONAD_Id, i_PRIMOP1, i_neChar }
1144     , { "primLtChar",                "CC", "B",  MONAD_Id, i_PRIMOP1, i_ltChar }
1145     , { "primLeChar",                "CC", "B",  MONAD_Id, i_PRIMOP1, i_leChar }
1146     , { "primCharToInt",             "C",  "I",  MONAD_Id, i_PRIMOP1, i_charToInt }
1147     , { "primIntToChar",             "I",  "C",  MONAD_Id, i_PRIMOP1, i_intToChar }
1148
1149     /* Int# operations */
1150     , { "primGtInt",                 "II", "B",  MONAD_Id, i_PRIMOP1, i_gtInt }
1151     , { "primGeInt",                 "II", "B",  MONAD_Id, i_PRIMOP1, i_geInt }
1152     , { "primEqInt",                 "II", "B",  MONAD_Id, i_PRIMOP1, i_eqInt }
1153     , { "primNeInt",                 "II", "B",  MONAD_Id, i_PRIMOP1, i_neInt }
1154     , { "primLtInt",                 "II", "B",  MONAD_Id, i_PRIMOP1, i_ltInt }
1155     , { "primLeInt",                 "II", "B",  MONAD_Id, i_PRIMOP1, i_leInt }
1156     , { "primMinInt",                "",   "I",  MONAD_Id, i_PRIMOP1, i_minInt }
1157     , { "primMaxInt",                "",   "I",  MONAD_Id, i_PRIMOP1, i_maxInt }
1158     , { "primPlusInt",               "II", "I",  MONAD_Id, i_PRIMOP1, i_plusInt }
1159     , { "primMinusInt",              "II", "I",  MONAD_Id, i_PRIMOP1, i_minusInt }
1160     , { "primTimesInt",              "II", "I",  MONAD_Id, i_PRIMOP1, i_timesInt }
1161     , { "primQuotInt",               "II", "I",  MONAD_Id, i_PRIMOP1, i_quotInt }
1162     , { "primRemInt",                "II", "I",  MONAD_Id, i_PRIMOP1, i_remInt }
1163     , { "primQuotRemInt",            "II", "II", MONAD_Id, i_PRIMOP1, i_quotRemInt }
1164     , { "primNegateInt",             "I",  "I",  MONAD_Id, i_PRIMOP1, i_negateInt }
1165
1166     , { "primAndInt",                "II", "I",  MONAD_Id, i_PRIMOP1, i_andInt }
1167     , { "primOrInt",                 "II", "I",  MONAD_Id, i_PRIMOP1, i_orInt }
1168     , { "primXorInt",                "II", "I",  MONAD_Id, i_PRIMOP1, i_xorInt }
1169     , { "primNotInt",                "I",  "I",  MONAD_Id, i_PRIMOP1, i_notInt }
1170     , { "primShiftLInt",             "II", "I",  MONAD_Id, i_PRIMOP1, i_shiftLInt }
1171     , { "primShiftRAInt",            "II", "I",  MONAD_Id, i_PRIMOP1, i_shiftRAInt }
1172     , { "primShiftRLInt",            "II", "I",  MONAD_Id, i_PRIMOP1, i_shiftRLInt }
1173
1174     /* Word# operations */
1175     , { "primGtWord",                "WW", "B",  MONAD_Id, i_PRIMOP1, i_gtWord }
1176     , { "primGeWord",                "WW", "B",  MONAD_Id, i_PRIMOP1, i_geWord }
1177     , { "primEqWord",                "WW", "B",  MONAD_Id, i_PRIMOP1, i_eqWord }
1178     , { "primNeWord",                "WW", "B",  MONAD_Id, i_PRIMOP1, i_neWord }
1179     , { "primLtWord",                "WW", "B",  MONAD_Id, i_PRIMOP1, i_ltWord }
1180     , { "primLeWord",                "WW", "B",  MONAD_Id, i_PRIMOP1, i_leWord }
1181     , { "primMinWord",               "",   "W",  MONAD_Id, i_PRIMOP1, i_minWord }
1182     , { "primMaxWord",               "",   "W",  MONAD_Id, i_PRIMOP1, i_maxWord }
1183     , { "primPlusWord",              "WW", "W",  MONAD_Id, i_PRIMOP1, i_plusWord }
1184     , { "primMinusWord",             "WW", "W",  MONAD_Id, i_PRIMOP1, i_minusWord }
1185     , { "primTimesWord",             "WW", "W",  MONAD_Id, i_PRIMOP1, i_timesWord }
1186     , { "primQuotWord",              "WW", "W",  MONAD_Id, i_PRIMOP1, i_quotWord }
1187     , { "primRemWord",               "WW", "W",  MONAD_Id, i_PRIMOP1, i_remWord }
1188     , { "primQuotRemWord",           "WW", "WW", MONAD_Id, i_PRIMOP1, i_quotRemWord }
1189     , { "primNegateWord",            "W",  "W",  MONAD_Id, i_PRIMOP1, i_negateWord }
1190
1191     , { "primAndWord",               "WW", "W",  MONAD_Id, i_PRIMOP1, i_andWord }
1192     , { "primOrWord",                "WW", "W",  MONAD_Id, i_PRIMOP1, i_orWord }
1193     , { "primXorWord",               "WW", "W",  MONAD_Id, i_PRIMOP1, i_xorWord }
1194     , { "primNotWord",               "W",  "W",  MONAD_Id, i_PRIMOP1, i_notWord }
1195     , { "primShiftLWord",            "WW", "W",  MONAD_Id, i_PRIMOP1, i_shiftLWord }
1196     , { "primShiftRAWord",           "WW", "W",  MONAD_Id, i_PRIMOP1, i_shiftRAWord }
1197     , { "primShiftRLWord",           "WW", "W",  MONAD_Id, i_PRIMOP1, i_shiftRLWord }
1198
1199     , { "primIntToWord",             "I",  "W",  MONAD_Id, i_PRIMOP1, i_intToWord }
1200     , { "primWordToInt",             "W",  "I",  MONAD_Id, i_PRIMOP1, i_wordToInt }
1201
1202     /* Addr# operations */
1203     , { "primGtAddr",                "AA", "B",  MONAD_Id, i_PRIMOP1, i_gtAddr }
1204     , { "primGeAddr",                "AA", "B",  MONAD_Id, i_PRIMOP1, i_geAddr }
1205     , { "primEqAddr",                "AA", "B",  MONAD_Id, i_PRIMOP1, i_eqAddr }
1206     , { "primNeAddr",                "AA", "B",  MONAD_Id, i_PRIMOP1, i_neAddr }
1207     , { "primLtAddr",                "AA", "B",  MONAD_Id, i_PRIMOP1, i_ltAddr }
1208     , { "primLeAddr",                "AA", "B",  MONAD_Id, i_PRIMOP1, i_leAddr }
1209     , { "primIntToAddr",             "I",  "A",  MONAD_Id, i_PRIMOP1, i_intToAddr }
1210     , { "primAddrToInt",             "A",  "I",  MONAD_Id, i_PRIMOP1, i_addrToInt }
1211
1212     , { "primIndexCharOffAddr",      "AI", "C",  MONAD_Id, i_PRIMOP1, i_indexCharOffAddr }
1213     , { "primIndexIntOffAddr",       "AI", "I",  MONAD_Id, i_PRIMOP1, i_indexIntOffAddr }
1214     , { "primIndexWordOffAddr",      "AI", "W",  MONAD_Id, i_PRIMOP1, i_indexWordOffAddr }
1215     , { "primIndexAddrOffAddr",      "AI", "A",  MONAD_Id, i_PRIMOP1, i_indexAddrOffAddr }
1216     , { "primIndexFloatOffAddr",     "AI", "F",  MONAD_Id, i_PRIMOP1, i_indexFloatOffAddr }
1217     , { "primIndexDoubleOffAddr",    "AI", "D",  MONAD_Id, i_PRIMOP1, i_indexDoubleOffAddr }
1218     , { "primIndexStableOffAddr",    "AI", "s",  MONAD_Id, i_PRIMOP1, i_indexStableOffAddr }
1219
1220     /* Stable# operations */
1221     , { "primIntToStablePtr",        "I",  "s",  MONAD_Id, i_PRIMOP1, i_intToStable }
1222     , { "primStablePtrToInt",        "s",  "I",  MONAD_Id, i_PRIMOP1, i_stableToInt }
1223
1224     /* These ops really ought to be in the IO monad */
1225     , { "primReadCharOffAddr",       "AI", "C",  MONAD_ST, i_PRIMOP1, i_readCharOffAddr }
1226     , { "primReadIntOffAddr",        "AI", "I",  MONAD_ST, i_PRIMOP1, i_readIntOffAddr }
1227     , { "primReadWordOffAddr",       "AI", "W",  MONAD_ST, i_PRIMOP1, i_readWordOffAddr }
1228     , { "primReadAddrOffAddr",       "AI", "A",  MONAD_ST, i_PRIMOP1, i_readAddrOffAddr }
1229     , { "primReadFloatOffAddr",      "AI", "F",  MONAD_ST, i_PRIMOP1, i_readFloatOffAddr }
1230     , { "primReadDoubleOffAddr",     "AI", "D",  MONAD_ST, i_PRIMOP1, i_readDoubleOffAddr }
1231     , { "primReadStableOffAddr",     "AI", "s",  MONAD_ST, i_PRIMOP1, i_readStableOffAddr }
1232
1233     /* These ops really ought to be in the IO monad */
1234     , { "primWriteCharOffAddr",      "AIC", "",  MONAD_ST, i_PRIMOP1, i_writeCharOffAddr }
1235     , { "primWriteIntOffAddr",       "AII", "",  MONAD_ST, i_PRIMOP1, i_writeIntOffAddr }
1236     , { "primWriteWordOffAddr",      "AIW", "",  MONAD_ST, i_PRIMOP1, i_writeWordOffAddr }
1237     , { "primWriteAddrOffAddr",      "AIA", "",  MONAD_ST, i_PRIMOP1, i_writeAddrOffAddr }
1238     , { "primWriteFloatOffAddr",     "AIF", "",  MONAD_ST, i_PRIMOP1, i_writeFloatOffAddr }
1239     , { "primWriteDoubleOffAddr",    "AID", "",  MONAD_ST, i_PRIMOP1, i_writeDoubleOffAddr }
1240     , { "primWriteStableOffAddr",    "AIs", "",  MONAD_ST, i_PRIMOP1, i_writeStableOffAddr }
1241
1242     /* Integer operations */
1243     , { "primCompareInteger",        "ZZ", "I",  MONAD_Id, i_PRIMOP1, i_compareInteger }
1244     , { "primNegateInteger",         "Z",  "Z",  MONAD_Id, i_PRIMOP1, i_negateInteger }
1245     , { "primPlusInteger",           "ZZ", "Z",  MONAD_Id, i_PRIMOP1, i_plusInteger }
1246     , { "primMinusInteger",          "ZZ", "Z",  MONAD_Id, i_PRIMOP1, i_minusInteger }
1247     , { "primTimesInteger",          "ZZ", "Z",  MONAD_Id, i_PRIMOP1, i_timesInteger }
1248     , { "primQuotRemInteger",        "ZZ", "ZZ", MONAD_Id, i_PRIMOP1, i_quotRemInteger }
1249     , { "primDivModInteger",         "ZZ", "ZZ", MONAD_Id, i_PRIMOP1, i_divModInteger }
1250     , { "primIntegerToInt",          "Z",  "I",  MONAD_Id, i_PRIMOP1, i_integerToInt }
1251     , { "primIntToInteger",          "I",  "Z",  MONAD_Id, i_PRIMOP1, i_intToInteger }
1252     , { "primIntegerToWord",         "Z",  "W",  MONAD_Id, i_PRIMOP1, i_integerToWord }
1253     , { "primWordToInteger",         "W",  "Z",  MONAD_Id, i_PRIMOP1, i_wordToInteger }
1254     , { "primIntegerToFloat",        "Z",  "F",  MONAD_Id, i_PRIMOP1, i_integerToFloat }
1255     , { "primFloatToInteger",        "F",  "Z",  MONAD_Id, i_PRIMOP1, i_floatToInteger }
1256     , { "primIntegerToDouble",       "Z",  "D",  MONAD_Id, i_PRIMOP1, i_integerToDouble }
1257     , { "primDoubleToInteger",       "D",  "Z",  MONAD_Id, i_PRIMOP1, i_doubleToInteger }
1258
1259     /* Float# operations */
1260     , { "primGtFloat",               "FF", "B",  MONAD_Id, i_PRIMOP1, i_gtFloat }
1261     , { "primGeFloat",               "FF", "B",  MONAD_Id, i_PRIMOP1, i_geFloat }
1262     , { "primEqFloat",               "FF", "B",  MONAD_Id, i_PRIMOP1, i_eqFloat }
1263     , { "primNeFloat",               "FF", "B",  MONAD_Id, i_PRIMOP1, i_neFloat }
1264     , { "primLtFloat",               "FF", "B",  MONAD_Id, i_PRIMOP1, i_ltFloat }
1265     , { "primLeFloat",               "FF", "B",  MONAD_Id, i_PRIMOP1, i_leFloat }
1266     , { "primMinFloat",              "",   "F",  MONAD_Id, i_PRIMOP1, i_minFloat }
1267     , { "primMaxFloat",              "",   "F",  MONAD_Id, i_PRIMOP1, i_maxFloat }
1268     , { "primRadixFloat",            "",   "I",  MONAD_Id, i_PRIMOP1, i_radixFloat }
1269     , { "primDigitsFloat",           "",   "I",  MONAD_Id, i_PRIMOP1, i_digitsFloat }
1270     , { "primMinExpFloat",           "",   "I",  MONAD_Id, i_PRIMOP1, i_minExpFloat }
1271     , { "primMaxExpFloat",           "",   "I",  MONAD_Id, i_PRIMOP1, i_maxExpFloat }
1272     , { "primPlusFloat",             "FF", "F",  MONAD_Id, i_PRIMOP1, i_plusFloat }
1273     , { "primMinusFloat",            "FF", "F",  MONAD_Id, i_PRIMOP1, i_minusFloat }
1274     , { "primTimesFloat",            "FF", "F",  MONAD_Id, i_PRIMOP1, i_timesFloat }
1275     , { "primDivideFloat",           "FF", "F",  MONAD_Id, i_PRIMOP1, i_divideFloat }
1276     , { "primNegateFloat",           "F",  "F",  MONAD_Id, i_PRIMOP1, i_negateFloat }
1277     , { "primFloatToInt",            "F",  "I",  MONAD_Id, i_PRIMOP1, i_floatToInt }
1278     , { "primIntToFloat",            "I",  "F",  MONAD_Id, i_PRIMOP1, i_intToFloat }
1279     , { "primExpFloat",              "F",  "F",  MONAD_Id, i_PRIMOP1, i_expFloat }
1280     , { "primLogFloat",              "F",  "F",  MONAD_Id, i_PRIMOP1, i_logFloat }
1281     , { "primSqrtFloat",             "F",  "F",  MONAD_Id, i_PRIMOP1, i_sqrtFloat }
1282     , { "primSinFloat",              "F",  "F",  MONAD_Id, i_PRIMOP1, i_sinFloat }
1283     , { "primCosFloat",              "F",  "F",  MONAD_Id, i_PRIMOP1, i_cosFloat }
1284     , { "primTanFloat",              "F",  "F",  MONAD_Id, i_PRIMOP1, i_tanFloat }
1285     , { "primAsinFloat",             "F",  "F",  MONAD_Id, i_PRIMOP1, i_asinFloat }
1286     , { "primAcosFloat",             "F",  "F",  MONAD_Id, i_PRIMOP1, i_acosFloat }
1287     , { "primAtanFloat",             "F",  "F",  MONAD_Id, i_PRIMOP1, i_atanFloat }
1288     , { "primSinhFloat",             "F",  "F",  MONAD_Id, i_PRIMOP1, i_sinhFloat }
1289     , { "primCoshFloat",             "F",  "F",  MONAD_Id, i_PRIMOP1, i_coshFloat }
1290     , { "primTanhFloat",             "F",  "F",  MONAD_Id, i_PRIMOP1, i_tanhFloat }
1291     , { "primPowerFloat",            "FF", "F",  MONAD_Id, i_PRIMOP1, i_powerFloat }
1292     , { "primDecodeFloatZ",          "F",  "ZI", MONAD_Id, i_PRIMOP1, i_decodeFloatZ }
1293     , { "primEncodeFloatZ",          "ZI", "F",  MONAD_Id, i_PRIMOP1, i_encodeFloatZ }
1294     , { "primIsNaNFloat",            "F",  "B",  MONAD_Id, i_PRIMOP1, i_isNaNFloat }
1295     , { "primIsInfiniteFloat",       "F",  "B",  MONAD_Id, i_PRIMOP1, i_isInfiniteFloat }
1296     , { "primIsDenormalizedFloat",   "F",  "B",  MONAD_Id, i_PRIMOP1, i_isDenormalizedFloat }
1297     , { "primIsNegativeZeroFloat",   "F",  "B",  MONAD_Id, i_PRIMOP1, i_isNegativeZeroFloat }
1298     , { "primIsIEEEFloat",           "",   "B",  MONAD_Id, i_PRIMOP1, i_isIEEEFloat }
1299
1300     /* Double# operations */
1301     , { "primGtDouble",              "DD", "B",  MONAD_Id, i_PRIMOP1, i_gtDouble }
1302     , { "primGeDouble",              "DD", "B",  MONAD_Id, i_PRIMOP1, i_geDouble }
1303     , { "primEqDouble",              "DD", "B",  MONAD_Id, i_PRIMOP1, i_eqDouble }
1304     , { "primNeDouble",              "DD", "B",  MONAD_Id, i_PRIMOP1, i_neDouble }
1305     , { "primLtDouble",              "DD", "B",  MONAD_Id, i_PRIMOP1, i_ltDouble }
1306     , { "primLeDouble",              "DD", "B",  MONAD_Id, i_PRIMOP1, i_leDouble }
1307     , { "primMinDouble",             "",   "D",  MONAD_Id, i_PRIMOP1, i_minDouble }
1308     , { "primMaxDouble",             "",   "D",  MONAD_Id, i_PRIMOP1, i_maxDouble }
1309     , { "primRadixDouble",           "",   "I",  MONAD_Id, i_PRIMOP1, i_radixDouble }
1310     , { "primDigitsDouble",          "",   "I",  MONAD_Id, i_PRIMOP1, i_digitsDouble }
1311     , { "primMinExpDouble",          "",   "I",  MONAD_Id, i_PRIMOP1, i_minExpDouble }
1312     , { "primMaxExpDouble",          "",   "I",  MONAD_Id, i_PRIMOP1, i_maxExpDouble }
1313     , { "primPlusDouble",            "DD", "D",  MONAD_Id, i_PRIMOP1, i_plusDouble }
1314     , { "primMinusDouble",           "DD", "D",  MONAD_Id, i_PRIMOP1, i_minusDouble }
1315     , { "primTimesDouble",           "DD", "D",  MONAD_Id, i_PRIMOP1, i_timesDouble }
1316     , { "primDivideDouble",          "DD", "D",  MONAD_Id, i_PRIMOP1, i_divideDouble }
1317     , { "primNegateDouble",          "D",  "D",  MONAD_Id, i_PRIMOP1, i_negateDouble }
1318     , { "primDoubleToInt",           "D",  "I",  MONAD_Id, i_PRIMOP1, i_doubleToInt }
1319     , { "primIntToDouble",           "I",  "D",  MONAD_Id, i_PRIMOP1, i_intToDouble }
1320     , { "primDoubleToFloat",         "D",  "F",  MONAD_Id, i_PRIMOP1, i_doubleToFloat }
1321     , { "primFloatToDouble",         "F",  "D",  MONAD_Id, i_PRIMOP1, i_floatToDouble }
1322     , { "primExpDouble",             "D",  "D",  MONAD_Id, i_PRIMOP1, i_expDouble }
1323     , { "primLogDouble",             "D",  "D",  MONAD_Id, i_PRIMOP1, i_logDouble }
1324     , { "primSqrtDouble",            "D",  "D",  MONAD_Id, i_PRIMOP1, i_sqrtDouble }
1325     , { "primSinDouble",             "D",  "D",  MONAD_Id, i_PRIMOP1, i_sinDouble }
1326     , { "primCosDouble",             "D",  "D",  MONAD_Id, i_PRIMOP1, i_cosDouble }
1327     , { "primTanDouble",             "D",  "D",  MONAD_Id, i_PRIMOP1, i_tanDouble }
1328     , { "primAsinDouble",            "D",  "D",  MONAD_Id, i_PRIMOP1, i_asinDouble }
1329     , { "primAcosDouble",            "D",  "D",  MONAD_Id, i_PRIMOP1, i_acosDouble }
1330     , { "primAtanDouble",            "D",  "D",  MONAD_Id, i_PRIMOP1, i_atanDouble }
1331     , { "primSinhDouble",            "D",  "D",  MONAD_Id, i_PRIMOP1, i_sinhDouble }
1332     , { "primCoshDouble",            "D",  "D",  MONAD_Id, i_PRIMOP1, i_coshDouble }
1333     , { "primTanhDouble",            "D",  "D",  MONAD_Id, i_PRIMOP1, i_tanhDouble }
1334     , { "primPowerDouble",           "DD", "D",  MONAD_Id, i_PRIMOP1, i_powerDouble }
1335     , { "primDecodeDoubleZ",         "D",  "ZI", MONAD_Id, i_PRIMOP1, i_decodeDoubleZ }
1336     , { "primEncodeDoubleZ",         "ZI",  "D", MONAD_Id, i_PRIMOP1, i_encodeDoubleZ }
1337     , { "primIsNaNDouble",           "D",  "B",  MONAD_Id, i_PRIMOP1, i_isNaNDouble }
1338     , { "primIsInfiniteDouble",      "D",  "B",  MONAD_Id, i_PRIMOP1, i_isInfiniteDouble }
1339     , { "primIsDenormalizedDouble",  "D",  "B",  MONAD_Id, i_PRIMOP1, i_isDenormalizedDouble }
1340     , { "primIsNegativeZeroDouble",  "D",  "B",  MONAD_Id, i_PRIMOP1, i_isNegativeZeroDouble }
1341     , { "primIsIEEEDouble",          "",   "B",  MONAD_Id, i_PRIMOP1, i_isIEEEDouble }
1342
1343     /* Ref operations */
1344     , { "primNewRef",                "a",  "R",  MONAD_ST, i_PRIMOP2, i_newRef }
1345     , { "primWriteRef",              "Ra", "",   MONAD_ST, i_PRIMOP2, i_writeRef }
1346     , { "primReadRef",               "R",  "a",  MONAD_ST, i_PRIMOP2, i_readRef }
1347     , { "primSameRef",               "RR", "B",  MONAD_Id, i_PRIMOP2, i_sameRef }
1348
1349     /* PrimArray operations */
1350     , { "primSameMutableArray",      "MM",  "B", MONAD_Id, i_PRIMOP2, i_sameMutableArray }
1351     , { "primUnsafeFreezeArray",     "M",   "X", MONAD_ST, i_PRIMOP2, i_unsafeFreezeArray }
1352     , { "primNewArray",              "Ia",  "M", MONAD_ST, i_PRIMOP2, i_newArray }
1353     , { "primWriteArray",            "MIa", "",  MONAD_ST, i_PRIMOP2, i_writeArray }
1354     , { "primReadArray",             "MI",  "a", MONAD_ST, i_PRIMOP2, i_readArray }
1355     , { "primIndexArray",            "XI",  "a", MONAD_Id, i_PRIMOP2, i_indexArray }
1356     , { "primSizeArray",             "X",   "I", MONAD_Id, i_PRIMOP2, i_sizeArray }
1357     , { "primSizeMutableArray",      "M",   "I", MONAD_Id, i_PRIMOP2, i_sizeMutableArray }
1358
1359     /* Prim[Mutable]ByteArray operations */
1360     , { "primSameMutableByteArray",  "mm", "B", MONAD_Id, i_PRIMOP2, i_sameMutableByteArray }
1361     , { "primUnsafeFreezeByteArray", "m",  "x", MONAD_ST, i_PRIMOP2, i_unsafeFreezeByteArray }
1362
1363     , { "primNewByteArray",          "I",  "m", MONAD_ST, i_PRIMOP2, i_newByteArray }
1364
1365     , { "primWriteCharArray",        "mIC", "", MONAD_ST, i_PRIMOP2, i_writeCharArray }
1366     , { "primReadCharArray",         "mI", "C", MONAD_ST, i_PRIMOP2, i_readCharArray }
1367     , { "primIndexCharArray",        "xI", "C", MONAD_Id, i_PRIMOP2, i_indexCharArray }
1368
1369     , { "primWriteIntArray",         "mII", "",  MONAD_ST, i_PRIMOP2, i_writeIntArray }
1370     , { "primReadIntArray",          "mI",  "I", MONAD_ST, i_PRIMOP2, i_readIntArray }
1371     , { "primIndexIntArray",         "xI",  "I", MONAD_Id, i_PRIMOP2, i_indexIntArray }
1372
1373     /* {new,write,read,index}IntegerArray not provided */
1374
1375     , { "primWriteWordArray",        "mIW", "",  MONAD_ST, i_PRIMOP2, i_writeWordArray }
1376     , { "primReadWordArray",         "mI",  "W", MONAD_ST, i_PRIMOP2, i_readWordArray }
1377     , { "primIndexWordArray",        "xI",  "W", MONAD_Id, i_PRIMOP2, i_indexWordArray }
1378     , { "primWriteAddrArray",        "mIA", "",  MONAD_ST, i_PRIMOP2, i_writeAddrArray }
1379     , { "primReadAddrArray",         "mI",  "A", MONAD_ST, i_PRIMOP2, i_readAddrArray }
1380     , { "primIndexAddrArray",        "xI",  "A", MONAD_Id, i_PRIMOP2, i_indexAddrArray }
1381     , { "primWriteFloatArray",       "mIF", "",  MONAD_ST, i_PRIMOP2, i_writeFloatArray }
1382     , { "primReadFloatArray",        "mI",  "F", MONAD_ST, i_PRIMOP2, i_readFloatArray }
1383     , { "primIndexFloatArray",       "xI",  "F", MONAD_Id, i_PRIMOP2, i_indexFloatArray }
1384     , { "primWriteDoubleArray" ,     "mID", "",  MONAD_ST, i_PRIMOP2, i_writeDoubleArray }
1385     , { "primReadDoubleArray",       "mI",  "D", MONAD_ST, i_PRIMOP2, i_readDoubleArray }
1386     , { "primIndexDoubleArray",      "xI",  "D", MONAD_Id, i_PRIMOP2, i_indexDoubleArray }
1387
1388 #if 0
1389 #ifdef PROVIDE_STABLE
1390     , { "primWriteStableArray",      "mIs", "",  MONAD_ST, i_PRIMOP2, i_writeStableArray }
1391     , { "primReadStableArray",       "mI",  "s", MONAD_ST, i_PRIMOP2, i_readStableArray }
1392     , { "primIndexStableArray",      "xI",  "s", MONAD_Id, i_PRIMOP2, i_indexStableArray }
1393 #endif
1394 #endif
1395     /* {new,write,read,index}ForeignObjArray not provided */
1396
1397
1398 #ifdef PROVIDE_FOREIGN
1399     /* ForeignObj# operations */
1400     , { "primMakeForeignObj",        "A",  "f",  MONAD_IO, i_PRIMOP2, i_makeForeignObj }
1401 #endif
1402 #ifdef PROVIDE_WEAK
1403     /* WeakPair# operations */
1404     , { "primMakeWeak",              "bac", "w",  MONAD_IO, i_PRIMOP2, i_makeWeak }
1405     , { "primDeRefWeak",             "w",   "Ia", MONAD_IO, i_PRIMOP2, i_deRefWeak }
1406 #endif
1407     /* StablePtr# operations */
1408     , { "primMakeStablePtr",         "a", "s",   MONAD_IO, i_PRIMOP2, i_makeStablePtr }
1409     , { "primDeRefStablePtr",        "s", "a",   MONAD_IO, i_PRIMOP2, i_deRefStablePtr }
1410     , { "primFreeStablePtr",         "s", "",    MONAD_IO, i_PRIMOP2, i_freeStablePtr }
1411
1412     /* foreign export dynamic support */
1413     , { "primCreateAdjThunkARCH",    "sAC","A",  MONAD_IO, i_PRIMOP2, i_createAdjThunkARCH }
1414
1415     /* misc handy hacks */
1416     , { "primGetArgc",               "",   "I",  MONAD_IO, i_PRIMOP2, i_getArgc }
1417     , { "primGetArgv",               "I",  "A",  MONAD_IO, i_PRIMOP2, i_getArgv }
1418
1419 #ifdef PROVIDE_PTREQUALITY
1420     , { "primReallyUnsafePtrEquality", "aa", "B",MONAD_Id, i_PRIMOP2, i_reallyUnsafePtrEquality }
1421 #endif
1422 #ifdef PROVIDE_COERCE
1423     , { "primUnsafeCoerce",          "a", "b",   MONAD_Id, i_PRIMOP2, i_unsafeCoerce }
1424 #endif
1425 #ifdef PROVIDE_CONCURRENT
1426     /* Concurrency operations */
1427     , { "primFork",                  "a", "T",   MONAD_IO, i_PRIMOP2, i_fork }
1428     , { "primKillThread",            "T", "",    MONAD_IO, i_PRIMOP2, i_killThread }
1429     , { "primDelay",                 "I", "",    MONAD_IO, i_PRIMOP2, i_delay }
1430     , { "primWaitRead",              "I", "",    MONAD_IO, i_PRIMOP2, i_waitRead }
1431     , { "primWaitWrite",             "I", "",    MONAD_IO, i_PRIMOP2, i_waitWrite }
1432 #endif
1433     , { "primNewEmptyMVar",         "",  "r",   MONAD_IO, i_PRIMOP2, i_newMVar }
1434       /* primTakeMVar is handwritten bytecode */
1435     , { "primPutMVar",               "ra", "",   MONAD_IO, i_PRIMOP2, i_putMVar }
1436     , { "primSameMVar",              "rr", "B",  MONAD_Id, i_PRIMOP2, i_sameMVar }
1437     , { "primGetThreadId",           "",   "T",  MONAD_IO, i_PRIMOP2, i_getThreadId }
1438     , { "primCmpThreadIds",          "TT", "I",  MONAD_Id, i_PRIMOP2, i_cmpThreadIds }
1439     , { "primForkIO",                 "a", "T",  MONAD_IO, i_PRIMOP2, i_forkIO }
1440
1441     /* Ccall is polyadic - so it's excluded from this table */
1442
1443     , { 0,0,0,0,0,0 }
1444 };
1445
1446 AsmPrim ccall_ccall_Id
1447    = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_ccall_Id };
1448 AsmPrim ccall_ccall_IO
1449    = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_ccall_IO };
1450 AsmPrim ccall_stdcall_Id
1451    = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_stdcall_Id };
1452 AsmPrim ccall_stdcall_IO
1453    = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_stdcall_IO };
1454
1455
1456 AsmPrim* asmFindPrim( char* s )
1457 {
1458     int i;
1459     for (i=0; asmPrimOps[i].name; ++i) {
1460         if (strcmp(s,asmPrimOps[i].name)==0) {
1461             return &asmPrimOps[i];
1462         }
1463     }
1464     return 0;
1465 }
1466
1467 AsmPrim* asmFindPrimop( AsmInstr prefix, AsmInstr op )
1468 {
1469     nat i;
1470     for (i=0; asmPrimOps[i].name; ++i) {
1471         if (asmPrimOps[i].prefix == prefix && asmPrimOps[i].opcode == op) {
1472             return &asmPrimOps[i];
1473         }
1474     }
1475     return 0;
1476 }
1477
1478 /* --------------------------------------------------------------------------
1479  * Handwritten primops
1480  * ------------------------------------------------------------------------*/
1481
1482 AsmBCO asm_BCO_catch ( void )
1483 {
1484    AsmBCO bco = asmBeginBCO(0 /*NIL*/);
1485    emiti_8(bco,i_ARG_CHECK,2);
1486    emiti_8(bco,i_PRIMOP1,i_pushcatchframe);
1487    incSp(bco, (1-2)*sizeofW(StgPtr) + sizeofW(StgCatchFrame));
1488    emiti_(bco,i_ENTER);
1489    decSp(bco, sizeofW(StgPtr));
1490    asmEndBCO(bco);
1491    return bco;
1492 }
1493
1494 AsmBCO asm_BCO_raise ( void )
1495 {
1496    AsmBCO bco = asmBeginBCO(0 /*NIL*/);
1497    emiti_8(bco,i_ARG_CHECK,1);
1498    emiti_8(bco,i_PRIMOP2,i_raise);
1499    decSp(bco,sizeofW(StgPtr));
1500    asmEndBCO(bco);
1501    return bco;
1502 }
1503
1504 AsmBCO asm_BCO_seq ( void )
1505 {
1506    AsmBCO eval, cont;
1507
1508    cont = asmBeginBCO(0 /*NIL*/);
1509    emiti_8(cont,i_ARG_CHECK,2);   /* should never fail */
1510    emit_i_VAR(cont,1);
1511    emit_i_SLIDE(cont,1,2);
1512    emiti_(cont,i_ENTER);
1513    incSp(cont, 3*sizeofW(StgPtr));
1514    asmEndBCO(cont);
1515
1516    eval = asmBeginBCO(0 /*NIL*/);
1517    emiti_8(eval,i_ARG_CHECK,2);
1518    emit_i_RETADDR(eval,eval->object.ptrs.len);
1519    asmPtr(eval,&(cont->object));
1520    emit_i_VAR(eval,2);
1521    emit_i_SLIDE(eval,3,1);
1522    emiti_8(eval,i_PRIMOP1,i_pushseqframe);
1523    emiti_(eval,i_ENTER);
1524    incSp(eval, sizeofW(StgSeqFrame) + 4*sizeofW(StgPtr));
1525    asmEndBCO(eval);
1526
1527    return eval;
1528 }
1529
1530 AsmBCO asm_BCO_takeMVar ( void )
1531 {
1532    AsmBCO kase, casecont, take;
1533
1534    take = asmBeginBCO(0 /*NIL*/);
1535    emit_i_VAR(take,0);
1536    emiti_8(take,i_PRIMOP2,i_takeMVar);
1537    emit_i_VAR(take,3);
1538    emit_i_VAR(take,1);
1539    emit_i_VAR(take,4);
1540    emit_i_SLIDE(take,3,4);
1541    emiti_(take,i_ENTER);
1542    incSp(take,20);
1543    asmEndBCO(take);
1544
1545    casecont = asmBeginBCO(0 /*NIL*/);
1546    emiti_(casecont,i_UNPACK);
1547    emit_i_VAR(casecont,4);
1548    emit_i_VAR(casecont,4);
1549    emit_i_VAR(casecont,2);
1550    emit_i_CONST(casecont,casecont->object.ptrs.len);
1551    asmPtr(casecont,&(take->object));
1552    emit_i_SLIDE(casecont,4,5);
1553    emiti_(casecont,i_ENTER);
1554    incSp(casecont,20);
1555    asmEndBCO(casecont);
1556
1557    kase = asmBeginBCO(0 /*NIL*/);
1558    emiti_8(kase,i_ARG_CHECK,3);
1559    emit_i_RETADDR(kase,kase->object.ptrs.len);
1560    asmPtr(kase,&(casecont->object));
1561    emit_i_VAR(kase,2);
1562    emiti_(kase,i_ENTER);
1563    incSp(kase,20);
1564    asmEndBCO(kase);
1565
1566    return kase;
1567 }
1568
1569
1570 /* --------------------------------------------------------------------------
1571  * Heap manipulation
1572  * ------------------------------------------------------------------------*/
1573
1574 AsmVar asmAllocCONSTR   ( AsmBCO bco, AsmInfo info )
1575 {
1576     int i;
1577     ASSERT( sizeW_fromITBL(info) >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1578
1579     /* Look in this bco's collection of nonpointers (literals)
1580        to see if the itbl pointer is already there.  If so, re-use it. */
1581     i = asmFindInNonPtrs ( bco, (StgWord)info );
1582
1583     if (i == -1) {
1584        emiti_8(bco,i_ALLOC_CONSTR,bco->nps.len);
1585        asmWords(bco,AsmInfo,info);
1586     } else {
1587        emiti_8(bco,i_ALLOC_CONSTR,i);
1588     }
1589
1590     incSp(bco, sizeofW(StgClosurePtr));
1591     grabHpNonUpd(bco,sizeW_fromITBL(info));
1592     return bco->sp;
1593 }
1594
1595 AsmSp asmBeginPack( AsmBCO bco )
1596 {
1597     return bco->sp;
1598 }
1599
1600 void asmEndPack( AsmBCO bco, AsmVar v, AsmSp start, AsmInfo info )
1601 {
1602     nat size = bco->sp - start;
1603     assert(bco->sp >= start);
1604     assert(start >= v);
1605     /* only reason to include info is for this assertion */
1606     assert(info->layout.payload.ptrs == size);
1607     emit_i_PACK(bco, bco->sp - v);
1608     setSp(bco, start);
1609 }
1610
1611 void asmBeginUnpack( AsmBCO bco )
1612 {
1613     /* dummy to make it look prettier */
1614 }
1615
1616 void asmEndUnpack( AsmBCO bco )
1617 {
1618     emiti_(bco,i_UNPACK);
1619 }
1620
1621 AsmVar asmAllocAP( AsmBCO bco, AsmNat words )
1622 {
1623     emiti_8(bco,i_ALLOC_AP,words);
1624     incSp(bco, sizeofW(StgPtr));
1625     grabHpUpd(bco,AP_sizeW(words));
1626     return bco->sp;
1627 }
1628
1629 AsmSp asmBeginMkAP( AsmBCO bco )
1630 {
1631     return bco->sp;
1632 }
1633
1634 void asmEndMkAP( AsmBCO bco, AsmVar v, AsmSp start )
1635 {
1636     emit_i_MKAP(bco,bco->sp-v,bco->sp-start-1);
1637             /* -1 because fun isn't counted */
1638     setSp(bco, start);
1639 }
1640
1641 AsmVar asmAllocPAP( AsmBCO bco, AsmNat size )
1642 {
1643     emiti_8(bco,i_ALLOC_PAP,size);
1644     incSp(bco, sizeofW(StgPtr));
1645     return bco->sp;
1646 }
1647
1648 AsmSp asmBeginMkPAP( AsmBCO bco )
1649 {
1650     return bco->sp;
1651 }
1652
1653 void asmEndMkPAP( AsmBCO bco, AsmVar v, AsmSp start )
1654 {
1655     emiti_8_8(bco,i_MKPAP,bco->sp-v,bco->sp-start-1);
1656             /* -1 because fun isn't counted */
1657     setSp(bco, start);
1658 }
1659
1660 AsmVar asmClosure( AsmBCO bco, AsmObject p )
1661 {
1662     emit_i_CONST(bco,bco->object.ptrs.len);
1663     asmPtr(bco,p);
1664     incSp(bco, sizeofW(StgPtr));
1665     return bco->sp;
1666 }
1667
1668 AsmVar asmGHCClosure( AsmBCO bco, AsmObject p )
1669 {
1670     // A complete hack.  Pushes the address as a tagged int
1671     // and then uses SLIDE to get rid of the tag.  Appalling.
1672     asmConstInt(bco, (AsmInt)p);
1673     emit_i_SLIDE(bco,0,1); decSp(bco,1);
1674     return bco->sp;
1675 }
1676
1677
1678 /* --------------------------------------------------------------------------
1679  * Building InfoTables
1680  * ------------------------------------------------------------------------*/
1681
1682 AsmInfo asmMkInfo( AsmNat tag, AsmNat ptrs )
1683 {
1684     StgInfoTable* info = stgMallocBytes( sizeof(StgInfoTable),"asmMkInfo");
1685     /* Note: the evaluator automatically pads objects with the right number
1686      * of non-ptrs to satisfy MIN_NONUPD_SIZE restrictions.
1687      */
1688     AsmNat nptrs = stg_max(0,MIN_NONUPD_SIZE-ptrs);
1689
1690     /* initialisation code based on INFO_TABLE_CONSTR */
1691     info->layout.payload.ptrs  = ptrs;
1692     info->layout.payload.nptrs = nptrs;
1693     info->srt_len = tag;
1694     info->type    = CONSTR;
1695 #ifdef USE_MINIINTERPRETER
1696     info->entry   = stgCast(StgFunPtr,&Hugs_CONSTR_entry);
1697 #else
1698 #warning asmMkInfo: Need to insert entry code in some cunning way
1699 #endif
1700     ASSERT( sizeW_fromITBL(info) >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1701     return info;
1702 }
1703
1704 /*-------------------------------------------------------------------------*/
1705
1706 #endif /* INTERPRETER */
1707