ghc/rts/Assembler.c

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