ghc/rts/Assembler.c

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