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