ghc/rts/Assembler.c

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