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