ghc/rts/Assembler.c

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