ghc/rts/Assembler.c

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