2 /* --------------------------------------------------------------------------
5 * Copyright (c) 1994-1998.
7 * $RCSfile: Assembler.c,v $
9 * $Date: 2000/10/09 11:18:46 $
11 * This module provides functions to construct BCOs and other closures
12 * required by the bytecode compiler.
14 * It is supposed to shield the compiler from platform dependent information
20 * and from details of how the abstract machine is implemented such as:
22 * o what does a BCO look like?
23 * o how many bytes does the "Push InfoTable" instruction require?
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.
41 * ------------------------------------------------------------------------*/
49 #include "Bytecodes.h"
51 #include "Disassembler.h"
52 #include "StgMiscClosures.h"
55 #include "Evaluator.h"
57 #define INSIDE_ASSEMBLER_C
58 #include "Assembler.h"
59 #undef INSIDE_ASSEMBLER_C
61 static StgClosure* asmAlloc ( nat size );
62 extern void* getNameOrTupleClosureCPtr ( int /*Cell*/ c );
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 );
71 /* --------------------------------------------------------------------------
72 * Initialising and managing objects and entities
73 * ------------------------------------------------------------------------*/
75 static struct AsmObject_* objects;
77 #define INITIALISE_TABLE(Type,table,size,used) \
81 #define ENSURE_SPACE_IN_TABLE(Type,table,size,used) \
84 size = (size ? 2*size : 1); \
85 new = malloc ( size * sizeof(Type)); \
87 barf("bytecode assembler: can't expand table of type " \
89 memcpy ( new, table, used * sizeof(Type) ); \
90 if (table) free(table); \
94 void asmInitialise ( void )
100 AsmObject asmNewObject ( void )
102 AsmObject obj = malloc(sizeof(struct AsmObject_));
104 barf("bytecode assembler: can't malloc in asmNewObject");
107 obj->n_refs = obj->n_words = obj->n_insns = 0;
109 obj->stgexpr = 0; /*NIL*/
110 obj->magic = 0x31415927;
111 INITIALISE_TABLE(AsmEntity,obj->entities,
118 void asmAddEntity ( AsmObject obj,
122 ENSURE_SPACE_IN_TABLE(
123 Asm_Entity,obj->entities,
124 obj->sizeEntities,obj->usedEntities);
125 obj->entities[obj->usedEntities].kind = kind;
126 obj->entities[obj->usedEntities].val = val;
129 case Asm_RefNoOp: case Asm_RefObject: case Asm_RefHugs:
130 obj->n_refs++; break;
132 obj->n_words++; break;
134 obj->n_insns++; break;
136 barf("asmAddEntity");
140 /* Support for the peephole optimiser. Find the instruction
141 byte n back, carefully stepping over any non Asm_Insn8 entities
144 static Instr asmInstrBack ( AsmBCO bco, StgInt n )
146 StgInt ue = bco->usedEntities;
148 if (ue < 0 || n <= 0) barf("asmInstrBack");
150 if (bco->entities[ue].kind != Asm_Insn8) continue;
152 if (n == 0) return bco->entities[ue].val;
157 /* Throw away n Asm_Insn8 bytes, and slide backwards any Asm_Insn8 entities
160 static void asmInstrRecede ( AsmBCO bco, StgInt n )
162 StgInt ue = bco->usedEntities;
165 if (ue < 0 || n <= 0) barf("asmInstrRecede");
167 if (bco->entities[ue].kind != Asm_Insn8) continue;
172 /* Now ue is the place where we would recede usedEntities to,
173 except that there may be stuff to slide downwards.
176 for (; ue < bco->usedEntities; ue++) {
177 if (bco->entities[ue].kind != Asm_Insn8) {
178 bco->entities[wr] = bco->entities[ue];
182 bco->usedEntities = wr;
186 static int asmFindInNonPtrs ( AsmBCO bco, StgWord w )
189 for (i = 0; i < bco->usedEntities; i++) {
190 if (bco->entities[i].kind == Asm_NonPtrWord) {
191 if (bco->entities[i].val == w) return j;
198 static void setInstrs ( AsmBCO bco, int instr_no, StgWord new_instr_byte )
201 for (i = 0; i < bco->usedEntities; i++) {
202 if (bco->entities[i].kind == Asm_Insn8) {
204 bco->entities[i].val = new_instr_byte;
213 void* asmGetClosureOfObject ( AsmObject obj )
219 /* --------------------------------------------------------------------------
220 * Top level assembler/BCO linker functions
221 * ------------------------------------------------------------------------*/
223 int asmCalcHeapSizeW ( AsmObject obj )
230 is = obj->n_insns + (obj->max_sp <= 255 ? 2 : 3);
231 ws = BCO_sizeW ( p, np, is );
239 ws = CONSTR_sizeW ( p, np );
242 barf("asmCalcHeapSizeW");
244 if (ws - sizeofW(StgHeader) < MIN_NONUPD_SIZE)
245 ws = sizeofW(StgHeader) + MIN_NONUPD_SIZE;
250 void asmAllocateHeapSpace ( void )
253 for (obj = objects; obj; obj = obj->next) {
254 StgClosure* c = asmAlloc ( asmCalcHeapSizeW ( obj ) );
259 void asmShutdown ( void )
262 AsmObject next = NULL;
263 for (obj = objects; obj; obj = next) {
265 obj->magic = 0x27180828;
266 if ( /*paranoia*/ obj->entities)
273 StgClosure* asmDerefEntity ( Asm_Entity entity )
275 switch (entity.kind) {
277 return (StgClosure*)entity.val;
280 ASSERT( ((AsmObject)(entity.val))->magic == 0x31415927 );
281 return ((AsmObject)(entity.val))->closure;
283 return getNameOrTupleClosureCPtr(entity.val);
285 barf("asmDerefEntity");
287 return NULL; /*notreached*/
291 void asmCopyAndLink ( void )
296 for (obj = objects; obj; obj = obj->next) {
297 StgClosure** p = (StgClosure**)(obj->closure);
303 AsmBCO abco = (AsmBCO)obj;
304 StgBCO* bco = (StgBCO*)p;
305 SET_HDR(bco,&BCO_info,??);
306 bco->n_ptrs = abco->n_refs;
307 bco->n_words = abco->n_words;
308 bco->n_instrs = abco->n_insns + (obj->max_sp <= 255 ? 2 : 3);
309 bco->stgexpr = abco->stgexpr;
310 //ppStgExpr(bco->stgexpr);
311 /* First copy in the ptrs. */
313 for (j = 0; j < obj->usedEntities; j++) {
314 switch (obj->entities[j].kind) {
318 bcoConstCPtr(bco,k++)
319 = (StgClosure*)asmDerefEntity(obj->entities[j]); break;
325 /* Now the non-ptrs. */
327 for (j = 0; j < obj->usedEntities; j++) {
328 switch (obj->entities[j].kind) {
330 bcoConstWord(bco,k++) = obj->entities[j].val; break;
336 /* Finally the insns, adding a stack check at the start. */
338 abco->max_sp = stg_max(abco->sp,abco->max_sp);
340 ASSERT(abco->max_sp <= 65535);
341 if (abco->max_sp <= 255) {
342 bcoInstr(bco,k++) = i_STK_CHECK;
343 bcoInstr(bco,k++) = abco->max_sp;
345 bcoInstr(bco,k++) = i_STK_CHECK_big;
346 bcoInstr(bco,k++) = abco->max_sp / 256;
347 bcoInstr(bco,k++) = abco->max_sp % 256;
349 for (j = 0; j < obj->usedEntities; j++) {
350 switch (obj->entities[j].kind) {
352 bcoInstr(bco,k++) = obj->entities[j].val; break;
359 barf("asmCopyAndLink: strange stuff in AsmBCO");
363 ASSERT((unsigned int)k == bco->n_instrs);
368 StgCAF* caf = (StgCAF*)p;
369 SET_HDR(caf,&CAF_UNENTERED_info,??);
371 caf->mut_link = NULL;
372 caf->value = (StgClosure*)0xdeadbeef;
373 ASSERT(obj->usedEntities == 1);
374 switch (obj->entities[0].kind) {
378 caf->body = (StgClosure*)asmDerefEntity(obj->entities[0]);
381 barf("asmCopyAndLink: strange stuff in AsmCAF");
388 SET_HDR((StgClosure*)p,obj->itbl,??);
390 /* First put in the pointers, then the non-pointers. */
391 for (j = 0; j < obj->usedEntities; j++) {
392 switch (obj->entities[j].kind) {
396 *p++ = asmDerefEntity(obj->entities[j]); break;
401 for (j = 0; j < obj->usedEntities; j++) {
402 switch (obj->entities[j].kind) {
404 *p++ = (StgClosure*)(obj->entities[j].val); break;
406 barf("asmCopyAndLink: strange stuff in AsmCon");
413 barf("asmCopyAndLink");
419 /* --------------------------------------------------------------------------
420 * Keeping track of the simulated stack pointer
421 * ------------------------------------------------------------------------*/
423 static StgClosure* asmAlloc( nat size )
425 StgClosure* o = stgCast(StgClosure*,allocate(size));
426 ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
427 /* printf("Allocated %p .. %p\n", o, o+size-1); */
431 static void setSp( AsmBCO bco, AsmSp sp )
433 bco->max_sp = stg_max(bco->sp,bco->max_sp);
435 bco->max_sp = stg_max(bco->sp,bco->max_sp);
438 static void incSp ( AsmBCO bco, int sp_delta )
440 bco->max_sp = stg_max(bco->sp,bco->max_sp);
442 bco->max_sp = stg_max(bco->sp,bco->max_sp);
445 static void decSp ( AsmBCO bco, int sp_delta )
447 bco->max_sp = stg_max(bco->sp,bco->max_sp);
449 bco->max_sp = stg_max(bco->sp,bco->max_sp);
452 /* --------------------------------------------------------------------------
454 * ------------------------------------------------------------------------*/
456 AsmCon asmBeginCon( AsmInfo info )
458 AsmCon con = asmNewObject();
464 void asmEndCon( AsmCon con __attribute__ ((unused)) )
468 AsmCAF asmBeginCAF( void )
470 AsmCAF caf = asmNewObject();
475 void asmEndCAF( AsmCAF caf __attribute__ ((unused)) )
479 AsmBCO asmBeginBCO( int /*StgExpr*/ e )
481 AsmBCO bco = asmNewObject();
484 //ppStgExpr(bco->stgexpr);
487 bco->lastOpc = i_INTERNAL_ERROR;
491 void asmEndBCO( AsmBCO bco __attribute__ ((unused)) )
495 /* --------------------------------------------------------------------------
497 * ------------------------------------------------------------------------*/
499 static void asmAddInstr ( AsmBCO bco, StgWord i )
501 asmAddEntity ( bco, Asm_Insn8, i );
504 static void asmAddNonPtrWord ( AsmObject obj, StgWord i )
506 asmAddEntity ( obj, Asm_NonPtrWord, i );
509 void asmAddRefHugs ( AsmObject obj,int /*Name*/ n )
511 asmAddEntity ( obj, Asm_RefHugs, n );
514 void asmAddRefObject ( AsmObject obj, AsmObject p )
516 ASSERT(p->magic == 0x31415927);
517 asmAddEntity ( obj, Asm_RefObject, (StgWord)p );
520 void asmAddRefNoOp ( AsmObject obj, StgPtr p )
522 asmAddEntity ( obj, Asm_RefNoOp, (StgWord)p );
527 static void asmInstrOp ( AsmBCO bco, StgWord i )
529 ASSERT(i <= BIGGEST_OPCODE); /* must be a valid opcode */
534 static void asmInstr8 ( AsmBCO bco, StgWord i )
537 ASSERT(i < 256); /* must be a byte */
542 static void asmInstr16 ( AsmBCO bco, StgWord i )
544 ASSERT(i < 65536); /* must be a short */
545 asmAddInstr(bco,i / 256);
546 asmAddInstr(bco,i % 256);
550 #define asmAddNonPtrWords(bco,ty,x) \
552 union { ty a; AsmWord b[sizeofW(ty)]; } p; \
554 if (sizeof(ty) < sizeof(AsmWord)) p.b[0]=0; \
556 for( i = 0; i < sizeofW(ty); i++ ) { \
557 asmAddNonPtrWord(bco,p.b[i]); \
561 static StgWord repSizeW( AsmRep rep )
564 case CHAR_REP: return sizeofW(StgWord) + sizeofW(StgChar);
567 case INT_REP: return sizeofW(StgWord) + sizeofW(StgInt);
569 case WORD_REP: return sizeofW(StgWord) + sizeofW(StgWord);
570 case ADDR_REP: return sizeofW(StgWord) + sizeofW(StgAddr);
571 case FLOAT_REP: return sizeofW(StgWord) + sizeofW(StgFloat);
572 case DOUBLE_REP: return sizeofW(StgWord) + sizeofW(StgDouble);
573 case STABLE_REP: return sizeofW(StgWord) + sizeofW(StgWord);
579 #ifdef PROVIDE_FOREIGN
582 case ALPHA_REP: /* a */
583 case BETA_REP: /* b */
584 case GAMMA_REP: /* c */
585 case DELTA_REP: /* d */
586 case HANDLER_REP: /* IOError -> IO a */
587 case ERROR_REP: /* IOError */
588 case ARR_REP : /* PrimArray a */
589 case BARR_REP : /* PrimByteArray a */
590 case REF_REP : /* Ref s a */
591 case MUTARR_REP : /* PrimMutableArray s a */
592 case MUTBARR_REP: /* PrimMutableByteArray s a */
593 case MVAR_REP: /* MVar a */
594 case PTR_REP: return sizeofW(StgPtr);
596 case VOID_REP: return sizeofW(StgWord);
597 default: barf("repSizeW %d",rep);
602 int asmRepSizeW ( AsmRep rep )
604 return repSizeW ( rep );
608 /* --------------------------------------------------------------------------
609 * Instruction emission. All instructions should be routed through here
610 * so that the peephole optimiser gets to see what's happening.
611 * ------------------------------------------------------------------------*/
613 static void emiti_ ( AsmBCO bco, Instr opcode )
617 if (bco->lastOpc == i_SLIDE && opcode == i_ENTER) {
618 /* SLIDE x y ; ENTER ===> SE x y */
619 x = asmInstrBack(bco,2);
620 y = asmInstrBack(bco,1);
621 asmInstrRecede(bco,3);
622 asmInstrOp(bco,i_SE); asmInstr8(bco,x); asmInstr8(bco,y);
625 if (bco->lastOpc == i_RV && opcode == i_ENTER) {
626 /* RV x y ; ENTER ===> RVE x (y-2)
627 Because RETADDR pushes 2 words on the stack, y must be at least 2. */
628 x = asmInstrBack(bco,2);
629 y = asmInstrBack(bco,1);
630 if (y < 2) barf("emiti_: RVE: impossible y value");
631 asmInstrRecede(bco,3);
632 asmInstrOp(bco, i_RVE); asmInstr8(bco,x); asmInstr8(bco,y-2);
635 asmInstrOp(bco,opcode);
638 asmInstrOp(bco,opcode);
642 static void emiti_8 ( AsmBCO bco, Instr opcode, int arg1 )
646 if (bco->lastOpc == i_VAR && opcode == i_VAR) {
647 /* VAR x ; VAR y ===> VV x y */
648 x = asmInstrBack(bco,1);
649 asmInstrRecede(bco,2);
650 asmInstrOp(bco,i_VV); asmInstr8(bco,x); asmInstr8(bco,arg1);
653 if (bco->lastOpc == i_RETADDR && opcode == i_VAR) {
654 /* RETADDR x ; VAR y ===> RV x y */
655 x = asmInstrBack(bco,1);
656 asmInstrRecede(bco,2);
657 asmInstrOp(bco, i_RV); asmInstr8(bco,x); asmInstr8(bco,arg1);
660 asmInstrOp(bco,opcode);
664 asmInstrOp(bco,opcode);
669 static void emiti_16 ( AsmBCO bco, Instr opcode, int arg1 )
671 asmInstrOp(bco,opcode);
672 asmInstr16(bco,arg1);
675 static void emiti_8_8 ( AsmBCO bco, Instr opcode, int arg1, int arg2 )
677 asmInstrOp(bco,opcode);
682 static void emiti_8_16 ( AsmBCO bco, Instr opcode, int arg1, int arg2 )
684 asmInstrOp(bco,opcode);
686 asmInstr16(bco,arg2);
689 static void emiti_16_16 ( AsmBCO bco, Instr opcode, int arg1, int arg2 )
691 asmInstrOp(bco,opcode);
692 asmInstr16(bco,arg1);
693 asmInstr16(bco,arg2);
697 static void emiti_8_8_16 ( AsmBCO bco, Instr opcode, int arg1, int arg2, int arg3 )
699 asmInstrOp(bco,opcode);
702 asmInstr16(bco,arg3);
706 /* --------------------------------------------------------------------------
707 * Wrappers around the above fns
708 * ------------------------------------------------------------------------*/
710 static void emit_i_VAR_INT ( AsmBCO bco, int arg1 )
714 emiti_8 (bco,i_VAR_INT, arg1); else
715 emiti_16(bco,i_VAR_INT_big,arg1);
718 static void emit_i_VAR_WORD ( AsmBCO bco, int arg1 )
722 emiti_8 (bco,i_VAR_WORD, arg1); else
723 emiti_16(bco,i_VAR_WORD_big,arg1);
726 static void emit_i_VAR_ADDR ( AsmBCO bco, int arg1 )
730 emiti_8 (bco,i_VAR_ADDR, arg1); else
731 emiti_16(bco,i_VAR_ADDR_big,arg1);
734 static void emit_i_VAR_CHAR ( AsmBCO bco, int arg1 )
738 emiti_8 (bco,i_VAR_CHAR, arg1); else
739 emiti_16(bco,i_VAR_CHAR_big,arg1);
742 static void emit_i_VAR_FLOAT ( AsmBCO bco, int arg1 )
746 emiti_8 (bco,i_VAR_FLOAT, arg1); else
747 emiti_16(bco,i_VAR_FLOAT_big,arg1);
750 static void emit_i_VAR_DOUBLE ( AsmBCO bco, int arg1 )
754 emiti_8 (bco,i_VAR_DOUBLE, arg1); else
755 emiti_16(bco,i_VAR_DOUBLE_big,arg1);
758 static void emit_i_VAR_STABLE ( AsmBCO bco, int arg1 )
762 emiti_8 (bco,i_VAR_STABLE, arg1); else
763 emiti_16(bco,i_VAR_STABLE_big,arg1);
766 static void emit_i_VAR ( AsmBCO bco, int arg1 )
770 emiti_8 (bco,i_VAR, arg1); else
771 emiti_16(bco,i_VAR_big,arg1);
774 static void emit_i_PACK ( AsmBCO bco, int arg1 )
778 emiti_8 (bco,i_PACK, arg1); else
779 emiti_16(bco,i_PACK_big,arg1);
782 static void emit_i_SLIDE ( AsmBCO bco, int arg1, int arg2 )
786 if (arg1 < 256 && arg2 < 256)
787 emiti_8_8 (bco,i_SLIDE, arg1,arg2); else
788 emiti_16_16(bco,i_SLIDE_big,arg1,arg2);
791 static void emit_i_MKAP ( AsmBCO bco, int arg1, int arg2 )
795 if (arg1 < 256 && arg2 < 256)
796 emiti_8_8 (bco,i_MKAP, arg1,arg2); else
797 emiti_16_16(bco,i_MKAP_big,arg1,arg2);
801 static void emit_i_CONST_INT ( AsmBCO bco, int arg1 )
805 emiti_8 (bco,i_CONST_INT, arg1); else
806 emiti_16(bco,i_CONST_INT_big,arg1);
809 static void emit_i_CONST_INTEGER ( AsmBCO bco, int arg1 )
813 emiti_8 (bco,i_CONST_INTEGER, arg1); else
814 emiti_16(bco,i_CONST_INTEGER_big,arg1);
817 static void emit_i_CONST_ADDR ( AsmBCO bco, int arg1 )
821 emiti_8 (bco,i_CONST_ADDR, arg1); else
822 emiti_16(bco,i_CONST_ADDR_big,arg1);
825 static void emit_i_CONST_WORD ( AsmBCO bco, int arg1 )
829 emiti_8 (bco,i_CONST_WORD, arg1); else
830 emiti_16(bco,i_CONST_WORD_big,arg1);
833 static void emit_i_CONST_CHAR ( AsmBCO bco, int arg1 )
837 emiti_8 (bco,i_CONST_CHAR, arg1); else
838 emiti_16(bco,i_CONST_CHAR_big,arg1);
841 static void emit_i_CONST_FLOAT ( AsmBCO bco, int arg1 )
845 emiti_8 (bco,i_CONST_FLOAT, arg1); else
846 emiti_16(bco,i_CONST_FLOAT_big,arg1);
849 static void emit_i_CONST_DOUBLE ( AsmBCO bco, int arg1 )
853 emiti_8 (bco,i_CONST_DOUBLE, arg1); else
854 emiti_16(bco,i_CONST_DOUBLE_big,arg1);
857 static void emit_i_CONST ( AsmBCO bco, int arg1 )
861 emiti_8 (bco,i_CONST, arg1); else
862 emiti_16(bco,i_CONST_big,arg1);
865 static void emit_i_RETADDR ( AsmBCO bco, int arg1 )
869 emiti_8 (bco,i_RETADDR, arg1); else
870 emiti_16(bco,i_RETADDR_big,arg1);
873 static void emit_i_ALLOC_CONSTR ( AsmBCO bco, int arg1 )
877 emiti_8 (bco,i_ALLOC_CONSTR, arg1); else
878 emiti_16(bco,i_ALLOC_CONSTR_big,arg1);
882 static void emit_i_ALLOC_ROW( AsmBCO bco, int n )
886 emiti_8 ( bco, i_ALLOC_ROW, n ); else
887 emiti_16( bco, i_ALLOC_ROW_big, n );
890 static void emit_i_PACK_ROW (AsmBCO bco, int var )
894 emiti_8 ( bco, i_PACK_ROW, var ); else
895 emiti_16( bco, i_PACK_ROW_big, var );
898 static void emit_i_PACK_INJ_VAR (AsmBCO bco, int var )
902 emiti_8 ( bco, i_PACK_INJ_VAR, var ); else
903 emiti_16( bco, i_PACK_INJ_VAR_big, var );
906 static void emit_i_TEST_INJ_VAR (AsmBCO bco, int var )
910 emiti_8_16 ( bco, i_TEST_INJ_VAR, var, 0 ); else
911 emiti_16_16( bco, i_TEST_INJ_VAR_big, var, 0 );
914 static void emit_i_ADD_WORD_VAR (AsmBCO bco, int var )
918 emiti_8( bco, i_ADD_WORD_VAR, var ); else
919 emiti_16( bco, i_ADD_WORD_VAR_big, var );
923 /* --------------------------------------------------------------------------
925 * ------------------------------------------------------------------------*/
927 AsmSp asmBeginArgCheck ( AsmBCO bco )
929 ASSERT(bco->sp == 0);
933 void asmEndArgCheck ( AsmBCO bco, AsmSp last_arg )
935 nat args = bco->sp - last_arg;
936 if (args != 0) { /* optimisation */
937 emiti_8(bco,i_ARG_CHECK,args);
941 /* --------------------------------------------------------------------------
942 * Creating and using "variables"
943 * ------------------------------------------------------------------------*/
945 AsmVar asmBind ( AsmBCO bco, AsmRep rep )
947 incSp(bco,repSizeW(rep));
951 void asmVar ( AsmBCO bco, AsmVar v, AsmRep rep )
955 if (rep == VOID_REP) {
957 incSp(bco,repSizeW(rep));
961 offset = bco->sp - v;
965 emit_i_VAR_INT(bco,offset);
969 emit_i_VAR_WORD(bco,offset);
972 emit_i_VAR_ADDR(bco,offset);
975 emit_i_VAR_CHAR(bco,offset);
978 emit_i_VAR_FLOAT(bco,offset);
981 emit_i_VAR_DOUBLE(bco,offset);
984 emit_i_VAR_STABLE(bco,offset);
991 #ifdef PROVIDE_FOREIGN
994 case ALPHA_REP: /* a */
995 case BETA_REP: /* b */
996 case GAMMA_REP: /* c */
997 case DELTA_REP: /* d */
998 case HANDLER_REP: /* IOError -> IO a */
999 case ERROR_REP: /* IOError */
1000 case ARR_REP : /* PrimArray a */
1001 case BARR_REP : /* PrimByteArray a */
1002 case REF_REP : /* Ref s a */
1003 case MUTARR_REP : /* PrimMutableArray s a */
1004 case MUTBARR_REP: /* PrimMutableByteArray s a */
1005 case MVAR_REP: /* MVar a */
1007 emit_i_VAR(bco,offset);
1010 barf("asmVar %d",rep);
1012 incSp(bco,repSizeW(rep));
1015 /* --------------------------------------------------------------------------
1017 * ------------------------------------------------------------------------*/
1019 AsmSp asmBeginEnter( AsmBCO bco )
1024 void asmEndEnter( AsmBCO bco, AsmSp sp1, AsmSp sp2 )
1026 int x = bco->sp - sp1;
1028 ASSERT(x >= 0 && y >= 0);
1030 emit_i_SLIDE(bco,x,y);
1031 decSp(bco,sp1 - sp2);
1033 emiti_(bco,i_ENTER);
1034 decSp(bco,sizeofW(StgPtr));
1037 /* --------------------------------------------------------------------------
1038 * Build boxed Ints, Floats, etc
1039 * ------------------------------------------------------------------------*/
1041 AsmVar asmBox( AsmBCO bco, AsmRep rep )
1045 emiti_(bco,i_PACK_CHAR);
1048 emiti_(bco,i_PACK_INT);
1052 emiti_(bco,i_PACK_WORD);
1055 emiti_(bco,i_PACK_ADDR);
1058 emiti_(bco,i_PACK_FLOAT);
1061 emiti_(bco,i_PACK_DOUBLE);
1064 emiti_(bco,i_PACK_STABLE);
1068 barf("asmBox %d",rep);
1070 /* NB: these operations DO pop their arg */
1071 decSp(bco, repSizeW(rep)); /* pop unboxed arg */
1072 incSp(bco, sizeofW(StgPtr)); /* push box */
1076 /* --------------------------------------------------------------------------
1077 * Unbox Ints, Floats, etc
1078 * ------------------------------------------------------------------------*/
1080 AsmVar asmUnbox( AsmBCO bco, AsmRep rep )
1084 emiti_(bco,i_UNPACK_INT);
1088 emiti_(bco,i_UNPACK_WORD);
1091 emiti_(bco,i_UNPACK_ADDR);
1094 emiti_(bco,i_UNPACK_CHAR);
1097 emiti_(bco,i_UNPACK_FLOAT);
1100 emiti_(bco,i_UNPACK_DOUBLE);
1103 emiti_(bco,i_UNPACK_STABLE);
1106 barf("asmUnbox %d",rep);
1108 /* NB: these operations DO NOT pop their arg */
1109 incSp(bco, repSizeW(rep)); /* push unboxed arg */
1114 /* --------------------------------------------------------------------------
1115 * Push unboxed Ints, Floats, etc
1116 * ------------------------------------------------------------------------*/
1118 void asmConstInt( AsmBCO bco, AsmInt x )
1120 emit_i_CONST_INT(bco,bco->n_words);
1121 asmAddNonPtrWords(bco,AsmInt,x);
1122 incSp(bco, repSizeW(INT_REP));
1125 void asmConstInteger( AsmBCO bco, AsmString x )
1127 emit_i_CONST_INTEGER(bco,bco->n_words);
1128 asmAddNonPtrWords(bco,AsmString,x);
1129 incSp(bco, repSizeW(INTEGER_REP));
1132 void asmConstAddr( AsmBCO bco, AsmAddr x )
1134 emit_i_CONST_ADDR(bco,bco->n_words);
1135 asmAddNonPtrWords(bco,AsmAddr,x);
1136 incSp(bco, repSizeW(ADDR_REP));
1139 void asmConstWord( AsmBCO bco, AsmWord x )
1141 emit_i_CONST_WORD(bco,bco->n_words);
1142 asmAddNonPtrWords(bco,AsmWord,x);
1143 incSp(bco, repSizeW(WORD_REP));
1146 void asmConstChar( AsmBCO bco, AsmChar x )
1148 emit_i_CONST_CHAR(bco,bco->n_words);
1149 asmAddNonPtrWords(bco,AsmChar,x);
1150 incSp(bco, repSizeW(CHAR_REP));
1153 void asmConstFloat( AsmBCO bco, AsmFloat x )
1155 emit_i_CONST_FLOAT(bco,bco->n_words);
1156 asmAddNonPtrWords(bco,AsmFloat,x);
1157 incSp(bco, repSizeW(FLOAT_REP));
1160 void asmConstDouble( AsmBCO bco, AsmDouble x )
1162 emit_i_CONST_DOUBLE(bco,bco->n_words);
1163 asmAddNonPtrWords(bco,AsmDouble,x);
1164 incSp(bco, repSizeW(DOUBLE_REP));
1167 /* --------------------------------------------------------------------------
1168 * Algebraic case helpers
1169 * ------------------------------------------------------------------------*/
1171 /* a mildly bogus pair of functions... */
1172 AsmSp asmBeginCase( AsmBCO bco )
1177 void asmEndCase( AsmBCO bco __attribute__ ((unused)) )
1181 AsmSp asmContinuation( AsmBCO bco, AsmBCO ret_addr )
1183 emit_i_RETADDR(bco,bco->n_refs);
1184 asmAddRefObject(bco,ret_addr);
1185 incSp(bco, 2 * sizeofW(StgPtr));
1189 AsmBCO asmBeginContinuation ( AsmSp sp, int /*List*/ alts )
1191 AsmBCO bco = asmBeginBCO(alts);
1196 void asmEndContinuation ( AsmBCO bco )
1202 /* --------------------------------------------------------------------------
1204 * ------------------------------------------------------------------------*/
1206 AsmSp asmBeginAlt( AsmBCO bco )
1211 void asmEndAlt( AsmBCO bco, AsmSp sp )
1216 AsmPc asmTest( AsmBCO bco, AsmWord tag )
1218 emiti_8_16(bco,i_TEST,tag,0);
1219 return bco->n_insns;
1222 AsmPc asmTestInt ( AsmBCO bco, AsmVar v, AsmInt x )
1224 asmVar(bco,v,INT_REP);
1226 emiti_16(bco,i_TEST_INT,0);
1227 decSp(bco, 2*repSizeW(INT_REP));
1228 return bco->n_insns;
1231 void asmFixBranch ( AsmBCO bco, AsmPc from )
1233 int distance = bco->n_insns - from;
1234 ASSERT(distance >= 0);
1235 ASSERT(distance < 65536);
1236 setInstrs(bco,from-2,distance/256);
1237 setInstrs(bco,from-1,distance%256);
1240 void asmPanic( AsmBCO bco )
1242 emiti_(bco,i_PANIC); /* "irrefutable" pattern failed - oops! */
1245 /* --------------------------------------------------------------------------
1247 * ------------------------------------------------------------------------*/
1249 AsmSp asmBeginPrim( AsmBCO bco )
1254 void asmEndPrim( AsmBCO bco, const AsmPrim* prim, AsmSp base )
1256 emiti_8(bco,prim->prefix,prim->opcode);
1260 char* asmGetPrimopName ( AsmPrim* p )
1265 /* Hugs used to let you add arbitrary primops with arbitrary types
1266 * just by editing Prelude.hs or any other file you wanted.
1267 * We deliberately avoided that approach because we wanted more
1268 * control over which primops are provided.
1270 AsmPrim asmPrimOps[] = {
1272 /* Char# operations */
1273 { "primGtChar", "CC", "B", MONAD_Id, i_PRIMOP1, i_gtChar }
1274 , { "primGeChar", "CC", "B", MONAD_Id, i_PRIMOP1, i_geChar }
1275 , { "primEqChar", "CC", "B", MONAD_Id, i_PRIMOP1, i_eqChar }
1276 , { "primNeChar", "CC", "B", MONAD_Id, i_PRIMOP1, i_neChar }
1277 , { "primLtChar", "CC", "B", MONAD_Id, i_PRIMOP1, i_ltChar }
1278 , { "primLeChar", "CC", "B", MONAD_Id, i_PRIMOP1, i_leChar }
1279 , { "primCharToInt", "C", "I", MONAD_Id, i_PRIMOP1, i_charToInt }
1280 , { "primIntToChar", "I", "C", MONAD_Id, i_PRIMOP1, i_intToChar }
1282 /* Int# operations */
1283 , { "primGtInt", "II", "B", MONAD_Id, i_PRIMOP1, i_gtInt }
1284 , { "primGeInt", "II", "B", MONAD_Id, i_PRIMOP1, i_geInt }
1285 , { "primEqInt", "II", "B", MONAD_Id, i_PRIMOP1, i_eqInt }
1286 , { "primNeInt", "II", "B", MONAD_Id, i_PRIMOP1, i_neInt }
1287 , { "primLtInt", "II", "B", MONAD_Id, i_PRIMOP1, i_ltInt }
1288 , { "primLeInt", "II", "B", MONAD_Id, i_PRIMOP1, i_leInt }
1289 , { "primMinInt", "", "I", MONAD_Id, i_PRIMOP1, i_minInt }
1290 , { "primMaxInt", "", "I", MONAD_Id, i_PRIMOP1, i_maxInt }
1291 , { "primPlusInt", "II", "I", MONAD_Id, i_PRIMOP1, i_plusInt }
1292 , { "primMinusInt", "II", "I", MONAD_Id, i_PRIMOP1, i_minusInt }
1293 , { "primTimesInt", "II", "I", MONAD_Id, i_PRIMOP1, i_timesInt }
1294 , { "primQuotInt", "II", "I", MONAD_Id, i_PRIMOP1, i_quotInt }
1295 , { "primRemInt", "II", "I", MONAD_Id, i_PRIMOP1, i_remInt }
1296 , { "primQuotRemInt", "II", "II", MONAD_Id, i_PRIMOP1, i_quotRemInt }
1297 , { "primNegateInt", "I", "I", MONAD_Id, i_PRIMOP1, i_negateInt }
1299 , { "primAndInt", "II", "I", MONAD_Id, i_PRIMOP1, i_andInt }
1300 , { "primOrInt", "II", "I", MONAD_Id, i_PRIMOP1, i_orInt }
1301 , { "primXorInt", "II", "I", MONAD_Id, i_PRIMOP1, i_xorInt }
1302 , { "primNotInt", "I", "I", MONAD_Id, i_PRIMOP1, i_notInt }
1303 , { "primShiftLInt", "II", "I", MONAD_Id, i_PRIMOP1, i_shiftLInt }
1304 , { "primShiftRAInt", "II", "I", MONAD_Id, i_PRIMOP1, i_shiftRAInt }
1305 , { "primShiftRLInt", "II", "I", MONAD_Id, i_PRIMOP1, i_shiftRLInt }
1307 /* Word# operations */
1308 , { "primGtWord", "WW", "B", MONAD_Id, i_PRIMOP1, i_gtWord }
1309 , { "primGeWord", "WW", "B", MONAD_Id, i_PRIMOP1, i_geWord }
1310 , { "primEqWord", "WW", "B", MONAD_Id, i_PRIMOP1, i_eqWord }
1311 , { "primNeWord", "WW", "B", MONAD_Id, i_PRIMOP1, i_neWord }
1312 , { "primLtWord", "WW", "B", MONAD_Id, i_PRIMOP1, i_ltWord }
1313 , { "primLeWord", "WW", "B", MONAD_Id, i_PRIMOP1, i_leWord }
1314 , { "primMinWord", "", "W", MONAD_Id, i_PRIMOP1, i_minWord }
1315 , { "primMaxWord", "", "W", MONAD_Id, i_PRIMOP1, i_maxWord }
1316 , { "primPlusWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_plusWord }
1317 , { "primMinusWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_minusWord }
1318 , { "primTimesWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_timesWord }
1319 , { "primQuotWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_quotWord }
1320 , { "primRemWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_remWord }
1321 , { "primQuotRemWord", "WW", "WW", MONAD_Id, i_PRIMOP1, i_quotRemWord }
1322 , { "primNegateWord", "W", "W", MONAD_Id, i_PRIMOP1, i_negateWord }
1324 , { "primAndWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_andWord }
1325 , { "primOrWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_orWord }
1326 , { "primXorWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_xorWord }
1327 , { "primNotWord", "W", "W", MONAD_Id, i_PRIMOP1, i_notWord }
1328 , { "primShiftLWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_shiftLWord }
1329 , { "primShiftRAWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_shiftRAWord }
1330 , { "primShiftRLWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_shiftRLWord }
1332 , { "primIntToWord", "I", "W", MONAD_Id, i_PRIMOP1, i_intToWord }
1333 , { "primWordToInt", "W", "I", MONAD_Id, i_PRIMOP1, i_wordToInt }
1335 /* Addr# operations */
1336 , { "primGtAddr", "AA", "B", MONAD_Id, i_PRIMOP1, i_gtAddr }
1337 , { "primGeAddr", "AA", "B", MONAD_Id, i_PRIMOP1, i_geAddr }
1338 , { "primEqAddr", "AA", "B", MONAD_Id, i_PRIMOP1, i_eqAddr }
1339 , { "primNeAddr", "AA", "B", MONAD_Id, i_PRIMOP1, i_neAddr }
1340 , { "primLtAddr", "AA", "B", MONAD_Id, i_PRIMOP1, i_ltAddr }
1341 , { "primLeAddr", "AA", "B", MONAD_Id, i_PRIMOP1, i_leAddr }
1342 , { "primIntToAddr", "I", "A", MONAD_Id, i_PRIMOP1, i_intToAddr }
1343 , { "primAddrToInt", "A", "I", MONAD_Id, i_PRIMOP1, i_addrToInt }
1345 , { "primIndexCharOffAddr", "AI", "C", MONAD_Id, i_PRIMOP1, i_indexCharOffAddr }
1346 , { "primIndexIntOffAddr", "AI", "I", MONAD_Id, i_PRIMOP1, i_indexIntOffAddr }
1347 , { "primIndexWordOffAddr", "AI", "W", MONAD_Id, i_PRIMOP1, i_indexWordOffAddr }
1348 , { "primIndexAddrOffAddr", "AI", "A", MONAD_Id, i_PRIMOP1, i_indexAddrOffAddr }
1349 , { "primIndexFloatOffAddr", "AI", "F", MONAD_Id, i_PRIMOP1, i_indexFloatOffAddr }
1350 , { "primIndexDoubleOffAddr", "AI", "D", MONAD_Id, i_PRIMOP1, i_indexDoubleOffAddr }
1351 , { "primIndexStableOffAddr", "AI", "s", MONAD_Id, i_PRIMOP1, i_indexStableOffAddr }
1353 /* Stable# operations */
1354 , { "primIntToStablePtr", "I", "s", MONAD_Id, i_PRIMOP1, i_intToStable }
1355 , { "primStablePtrToInt", "s", "I", MONAD_Id, i_PRIMOP1, i_stableToInt }
1357 /* These ops really ought to be in the IO monad */
1358 , { "primReadCharOffAddr", "AI", "C", MONAD_ST, i_PRIMOP1, i_readCharOffAddr }
1359 , { "primReadIntOffAddr", "AI", "I", MONAD_ST, i_PRIMOP1, i_readIntOffAddr }
1360 , { "primReadWordOffAddr", "AI", "W", MONAD_ST, i_PRIMOP1, i_readWordOffAddr }
1361 , { "primReadAddrOffAddr", "AI", "A", MONAD_ST, i_PRIMOP1, i_readAddrOffAddr }
1362 , { "primReadFloatOffAddr", "AI", "F", MONAD_ST, i_PRIMOP1, i_readFloatOffAddr }
1363 , { "primReadDoubleOffAddr", "AI", "D", MONAD_ST, i_PRIMOP1, i_readDoubleOffAddr }
1364 , { "primReadStableOffAddr", "AI", "s", MONAD_ST, i_PRIMOP1, i_readStableOffAddr }
1366 /* These ops really ought to be in the IO monad */
1367 , { "primWriteCharOffAddr", "AIC", "", MONAD_ST, i_PRIMOP1, i_writeCharOffAddr }
1368 , { "primWriteIntOffAddr", "AII", "", MONAD_ST, i_PRIMOP1, i_writeIntOffAddr }
1369 , { "primWriteWordOffAddr", "AIW", "", MONAD_ST, i_PRIMOP1, i_writeWordOffAddr }
1370 , { "primWriteAddrOffAddr", "AIA", "", MONAD_ST, i_PRIMOP1, i_writeAddrOffAddr }
1371 , { "primWriteFloatOffAddr", "AIF", "", MONAD_ST, i_PRIMOP1, i_writeFloatOffAddr }
1372 , { "primWriteDoubleOffAddr", "AID", "", MONAD_ST, i_PRIMOP1, i_writeDoubleOffAddr }
1373 , { "primWriteStableOffAddr", "AIs", "", MONAD_ST, i_PRIMOP1, i_writeStableOffAddr }
1375 /* Integer operations */
1376 , { "primCompareInteger", "ZZ", "I", MONAD_Id, i_PRIMOP1, i_compareInteger }
1377 , { "primNegateInteger", "Z", "Z", MONAD_Id, i_PRIMOP1, i_negateInteger }
1378 , { "primPlusInteger", "ZZ", "Z", MONAD_Id, i_PRIMOP1, i_plusInteger }
1379 , { "primMinusInteger", "ZZ", "Z", MONAD_Id, i_PRIMOP1, i_minusInteger }
1380 , { "primTimesInteger", "ZZ", "Z", MONAD_Id, i_PRIMOP1, i_timesInteger }
1381 , { "primQuotRemInteger", "ZZ", "ZZ", MONAD_Id, i_PRIMOP1, i_quotRemInteger }
1382 , { "primDivModInteger", "ZZ", "ZZ", MONAD_Id, i_PRIMOP1, i_divModInteger }
1383 , { "primIntegerToInt", "Z", "I", MONAD_Id, i_PRIMOP1, i_integerToInt }
1384 , { "primIntToInteger", "I", "Z", MONAD_Id, i_PRIMOP1, i_intToInteger }
1385 , { "primIntegerToWord", "Z", "W", MONAD_Id, i_PRIMOP1, i_integerToWord }
1386 , { "primWordToInteger", "W", "Z", MONAD_Id, i_PRIMOP1, i_wordToInteger }
1387 , { "primIntegerToFloat", "Z", "F", MONAD_Id, i_PRIMOP1, i_integerToFloat }
1388 , { "primFloatToInteger", "F", "Z", MONAD_Id, i_PRIMOP1, i_floatToInteger }
1389 , { "primIntegerToDouble", "Z", "D", MONAD_Id, i_PRIMOP1, i_integerToDouble }
1390 , { "primDoubleToInteger", "D", "Z", MONAD_Id, i_PRIMOP1, i_doubleToInteger }
1392 /* Float# operations */
1393 , { "primGtFloat", "FF", "B", MONAD_Id, i_PRIMOP1, i_gtFloat }
1394 , { "primGeFloat", "FF", "B", MONAD_Id, i_PRIMOP1, i_geFloat }
1395 , { "primEqFloat", "FF", "B", MONAD_Id, i_PRIMOP1, i_eqFloat }
1396 , { "primNeFloat", "FF", "B", MONAD_Id, i_PRIMOP1, i_neFloat }
1397 , { "primLtFloat", "FF", "B", MONAD_Id, i_PRIMOP1, i_ltFloat }
1398 , { "primLeFloat", "FF", "B", MONAD_Id, i_PRIMOP1, i_leFloat }
1399 , { "primMinFloat", "", "F", MONAD_Id, i_PRIMOP1, i_minFloat }
1400 , { "primMaxFloat", "", "F", MONAD_Id, i_PRIMOP1, i_maxFloat }
1401 , { "primRadixFloat", "", "I", MONAD_Id, i_PRIMOP1, i_radixFloat }
1402 , { "primDigitsFloat", "", "I", MONAD_Id, i_PRIMOP1, i_digitsFloat }
1403 , { "primMinExpFloat", "", "I", MONAD_Id, i_PRIMOP1, i_minExpFloat }
1404 , { "primMaxExpFloat", "", "I", MONAD_Id, i_PRIMOP1, i_maxExpFloat }
1405 , { "primPlusFloat", "FF", "F", MONAD_Id, i_PRIMOP1, i_plusFloat }
1406 , { "primMinusFloat", "FF", "F", MONAD_Id, i_PRIMOP1, i_minusFloat }
1407 , { "primTimesFloat", "FF", "F", MONAD_Id, i_PRIMOP1, i_timesFloat }
1408 , { "primDivideFloat", "FF", "F", MONAD_Id, i_PRIMOP1, i_divideFloat }
1409 , { "primNegateFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_negateFloat }
1410 , { "primFloatToInt", "F", "I", MONAD_Id, i_PRIMOP1, i_floatToInt }
1411 , { "primIntToFloat", "I", "F", MONAD_Id, i_PRIMOP1, i_intToFloat }
1412 , { "primExpFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_expFloat }
1413 , { "primLogFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_logFloat }
1414 , { "primSqrtFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_sqrtFloat }
1415 , { "primSinFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_sinFloat }
1416 , { "primCosFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_cosFloat }
1417 , { "primTanFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_tanFloat }
1418 , { "primAsinFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_asinFloat }
1419 , { "primAcosFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_acosFloat }
1420 , { "primAtanFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_atanFloat }
1421 , { "primSinhFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_sinhFloat }
1422 , { "primCoshFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_coshFloat }
1423 , { "primTanhFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_tanhFloat }
1424 , { "primPowerFloat", "FF", "F", MONAD_Id, i_PRIMOP1, i_powerFloat }
1425 , { "primDecodeFloatZ", "F", "ZI", MONAD_Id, i_PRIMOP1, i_decodeFloatZ }
1426 , { "primEncodeFloatZ", "ZI", "F", MONAD_Id, i_PRIMOP1, i_encodeFloatZ }
1427 , { "primIsNaNFloat", "F", "B", MONAD_Id, i_PRIMOP1, i_isNaNFloat }
1428 , { "primIsInfiniteFloat", "F", "B", MONAD_Id, i_PRIMOP1, i_isInfiniteFloat }
1429 , { "primIsDenormalizedFloat", "F", "B", MONAD_Id, i_PRIMOP1, i_isDenormalizedFloat }
1430 , { "primIsNegativeZeroFloat", "F", "B", MONAD_Id, i_PRIMOP1, i_isNegativeZeroFloat }
1431 , { "primIsIEEEFloat", "", "B", MONAD_Id, i_PRIMOP1, i_isIEEEFloat }
1433 /* Double# operations */
1434 , { "primGtDouble", "DD", "B", MONAD_Id, i_PRIMOP1, i_gtDouble }
1435 , { "primGeDouble", "DD", "B", MONAD_Id, i_PRIMOP1, i_geDouble }
1436 , { "primEqDouble", "DD", "B", MONAD_Id, i_PRIMOP1, i_eqDouble }
1437 , { "primNeDouble", "DD", "B", MONAD_Id, i_PRIMOP1, i_neDouble }
1438 , { "primLtDouble", "DD", "B", MONAD_Id, i_PRIMOP1, i_ltDouble }
1439 , { "primLeDouble", "DD", "B", MONAD_Id, i_PRIMOP1, i_leDouble }
1440 , { "primMinDouble", "", "D", MONAD_Id, i_PRIMOP1, i_minDouble }
1441 , { "primMaxDouble", "", "D", MONAD_Id, i_PRIMOP1, i_maxDouble }
1442 , { "primRadixDouble", "", "I", MONAD_Id, i_PRIMOP1, i_radixDouble }
1443 , { "primDigitsDouble", "", "I", MONAD_Id, i_PRIMOP1, i_digitsDouble }
1444 , { "primMinExpDouble", "", "I", MONAD_Id, i_PRIMOP1, i_minExpDouble }
1445 , { "primMaxExpDouble", "", "I", MONAD_Id, i_PRIMOP1, i_maxExpDouble }
1446 , { "primPlusDouble", "DD", "D", MONAD_Id, i_PRIMOP1, i_plusDouble }
1447 , { "primMinusDouble", "DD", "D", MONAD_Id, i_PRIMOP1, i_minusDouble }
1448 , { "primTimesDouble", "DD", "D", MONAD_Id, i_PRIMOP1, i_timesDouble }
1449 , { "primDivideDouble", "DD", "D", MONAD_Id, i_PRIMOP1, i_divideDouble }
1450 , { "primNegateDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_negateDouble }
1451 , { "primDoubleToInt", "D", "I", MONAD_Id, i_PRIMOP1, i_doubleToInt }
1452 , { "primIntToDouble", "I", "D", MONAD_Id, i_PRIMOP1, i_intToDouble }
1453 , { "primDoubleToFloat", "D", "F", MONAD_Id, i_PRIMOP1, i_doubleToFloat }
1454 , { "primFloatToDouble", "F", "D", MONAD_Id, i_PRIMOP1, i_floatToDouble }
1455 , { "primExpDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_expDouble }
1456 , { "primLogDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_logDouble }
1457 , { "primSqrtDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_sqrtDouble }
1458 , { "primSinDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_sinDouble }
1459 , { "primCosDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_cosDouble }
1460 , { "primTanDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_tanDouble }
1461 , { "primAsinDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_asinDouble }
1462 , { "primAcosDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_acosDouble }
1463 , { "primAtanDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_atanDouble }
1464 , { "primSinhDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_sinhDouble }
1465 , { "primCoshDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_coshDouble }
1466 , { "primTanhDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_tanhDouble }
1467 , { "primPowerDouble", "DD", "D", MONAD_Id, i_PRIMOP1, i_powerDouble }
1468 , { "primDecodeDoubleZ", "D", "ZI", MONAD_Id, i_PRIMOP1, i_decodeDoubleZ }
1469 , { "primEncodeDoubleZ", "ZI", "D", MONAD_Id, i_PRIMOP1, i_encodeDoubleZ }
1470 , { "primIsNaNDouble", "D", "B", MONAD_Id, i_PRIMOP1, i_isNaNDouble }
1471 , { "primIsInfiniteDouble", "D", "B", MONAD_Id, i_PRIMOP1, i_isInfiniteDouble }
1472 , { "primIsDenormalizedDouble", "D", "B", MONAD_Id, i_PRIMOP1, i_isDenormalizedDouble }
1473 , { "primIsNegativeZeroDouble", "D", "B", MONAD_Id, i_PRIMOP1, i_isNegativeZeroDouble }
1474 , { "primIsIEEEDouble", "", "B", MONAD_Id, i_PRIMOP1, i_isIEEEDouble }
1477 /* primitive row operations. */
1478 , { "primRowInsertAt", "XWa","X", MONAD_Id, i_PRIMOP2, i_rowInsertAt }
1479 , { "primRowRemoveAt", "XW", "aX", MONAD_Id, i_PRIMOP2, i_rowRemoveAt }
1482 /* Ref operations */
1483 , { "primNewRef", "a", "R", MONAD_ST, i_PRIMOP2, i_newRef }
1484 , { "primWriteRef", "Ra", "", MONAD_ST, i_PRIMOP2, i_writeRef }
1485 , { "primReadRef", "R", "a", MONAD_ST, i_PRIMOP2, i_readRef }
1486 , { "primSameRef", "RR", "B", MONAD_Id, i_PRIMOP2, i_sameRef }
1488 /* PrimArray operations */
1489 , { "primSameMutableArray", "MM", "B", MONAD_Id, i_PRIMOP2, i_sameMutableArray }
1490 , { "primUnsafeFreezeArray", "M", "X", MONAD_ST, i_PRIMOP2, i_unsafeFreezeArray }
1491 , { "primNewArray", "Ia", "M", MONAD_ST, i_PRIMOP2, i_newArray }
1492 , { "primWriteArray", "MIa", "", MONAD_ST, i_PRIMOP2, i_writeArray }
1493 , { "primReadArray", "MI", "a", MONAD_ST, i_PRIMOP2, i_readArray }
1494 , { "primIndexArray", "XI", "a", MONAD_Id, i_PRIMOP2, i_indexArray }
1495 , { "primSizeArray", "X", "I", MONAD_Id, i_PRIMOP2, i_sizeArray }
1496 , { "primSizeMutableArray", "M", "I", MONAD_Id, i_PRIMOP2, i_sizeMutableArray }
1498 /* Prim[Mutable]ByteArray operations */
1499 , { "primSameMutableByteArray", "mm", "B", MONAD_Id, i_PRIMOP2, i_sameMutableByteArray }
1500 , { "primUnsafeFreezeByteArray", "m", "x", MONAD_ST, i_PRIMOP2, i_unsafeFreezeByteArray }
1502 , { "primNewByteArray", "I", "m", MONAD_ST, i_PRIMOP2, i_newByteArray }
1504 , { "primWriteCharArray", "mIC", "", MONAD_ST, i_PRIMOP2, i_writeCharArray }
1505 , { "primReadCharArray", "mI", "C", MONAD_ST, i_PRIMOP2, i_readCharArray }
1506 , { "primIndexCharArray", "xI", "C", MONAD_Id, i_PRIMOP2, i_indexCharArray }
1508 , { "primWriteIntArray", "mII", "", MONAD_ST, i_PRIMOP2, i_writeIntArray }
1509 , { "primReadIntArray", "mI", "I", MONAD_ST, i_PRIMOP2, i_readIntArray }
1510 , { "primIndexIntArray", "xI", "I", MONAD_Id, i_PRIMOP2, i_indexIntArray }
1512 /* {new,write,read,index}IntegerArray not provided */
1514 , { "primWriteWordArray", "mIW", "", MONAD_ST, i_PRIMOP2, i_writeWordArray }
1515 , { "primReadWordArray", "mI", "W", MONAD_ST, i_PRIMOP2, i_readWordArray }
1516 , { "primIndexWordArray", "xI", "W", MONAD_Id, i_PRIMOP2, i_indexWordArray }
1517 , { "primWriteAddrArray", "mIA", "", MONAD_ST, i_PRIMOP2, i_writeAddrArray }
1518 , { "primReadAddrArray", "mI", "A", MONAD_ST, i_PRIMOP2, i_readAddrArray }
1519 , { "primIndexAddrArray", "xI", "A", MONAD_Id, i_PRIMOP2, i_indexAddrArray }
1520 , { "primWriteFloatArray", "mIF", "", MONAD_ST, i_PRIMOP2, i_writeFloatArray }
1521 , { "primReadFloatArray", "mI", "F", MONAD_ST, i_PRIMOP2, i_readFloatArray }
1522 , { "primIndexFloatArray", "xI", "F", MONAD_Id, i_PRIMOP2, i_indexFloatArray }
1523 , { "primWriteDoubleArray" , "mID", "", MONAD_ST, i_PRIMOP2, i_writeDoubleArray }
1524 , { "primReadDoubleArray", "mI", "D", MONAD_ST, i_PRIMOP2, i_readDoubleArray }
1525 , { "primIndexDoubleArray", "xI", "D", MONAD_Id, i_PRIMOP2, i_indexDoubleArray }
1528 #ifdef PROVIDE_STABLE
1529 , { "primWriteStableArray", "mIs", "", MONAD_ST, i_PRIMOP2, i_writeStableArray }
1530 , { "primReadStableArray", "mI", "s", MONAD_ST, i_PRIMOP2, i_readStableArray }
1531 , { "primIndexStableArray", "xI", "s", MONAD_Id, i_PRIMOP2, i_indexStableArray }
1534 /* {new,write,read,index}ForeignObjArray not provided */
1537 #ifdef PROVIDE_FOREIGN
1538 /* ForeignObj# operations */
1539 , { "primMkForeignObj", "A", "f", MONAD_IO, i_PRIMOP2, i_mkForeignObj }
1542 /* WeakPair# operations */
1543 , { "primMakeWeak", "bac", "w", MONAD_IO, i_PRIMOP2, i_makeWeak }
1544 , { "primDeRefWeak", "w", "Ia", MONAD_IO, i_PRIMOP2, i_deRefWeak }
1546 /* StablePtr# operations */
1547 , { "primMakeStablePtr", "a", "s", MONAD_IO, i_PRIMOP2, i_makeStablePtr }
1548 , { "primDeRefStablePtr", "s", "a", MONAD_IO, i_PRIMOP2, i_deRefStablePtr }
1549 , { "primFreeStablePtr", "s", "", MONAD_IO, i_PRIMOP2, i_freeStablePtr }
1551 /* foreign export dynamic support */
1552 , { "primCreateAdjThunkARCH", "sAC","A", MONAD_IO, i_PRIMOP2, i_createAdjThunkARCH }
1554 /* misc handy hacks */
1555 , { "primGetArgc", "", "I", MONAD_IO, i_PRIMOP2, i_getArgc }
1556 , { "primGetArgv", "I", "A", MONAD_IO, i_PRIMOP2, i_getArgv }
1558 #ifdef PROVIDE_PTREQUALITY
1559 , { "primReallyUnsafePtrEquality", "aa", "B",MONAD_Id, i_PRIMOP2, i_reallyUnsafePtrEquality }
1561 #ifdef PROVIDE_COERCE
1562 , { "primUnsafeCoerce", "a", "b", MONAD_Id, i_PRIMOP2, i_unsafeCoerce }
1564 #ifdef PROVIDE_CONCURRENT
1565 /* Concurrency operations */
1566 , { "primForkIO", "a", "T", MONAD_IO, i_PRIMOP2, i_forkIO }
1567 , { "primKillThread", "T", "", MONAD_IO, i_PRIMOP2, i_killThread }
1568 , { "primRaiseInThread", "TE", "", MONAD_IO, i_PRIMOP2, i_raiseInThread }
1570 , { "primWaitRead", "I", "", MONAD_IO, i_PRIMOP2, i_waitRead }
1571 , { "primWaitWrite", "I", "", MONAD_IO, i_PRIMOP2, i_waitWrite }
1572 , { "primYield", "", "", MONAD_IO, i_PRIMOP2, i_yield } , { "primDelay", "I", "", MONAD_IO, i_PRIMOP2, i_delay }
1573 , { "primGetThreadId", "", "T", MONAD_IO, i_PRIMOP2, i_getThreadId }
1574 , { "primCmpThreadIds", "TT", "I", MONAD_Id, i_PRIMOP2, i_cmpThreadIds }
1576 , { "primNewEmptyMVar", "", "r", MONAD_IO, i_PRIMOP2, i_newMVar }
1577 /* primTakeMVar is handwritten bytecode */
1578 , { "primPutMVar", "ra", "", MONAD_IO, i_PRIMOP2, i_putMVar }
1579 , { "primSameMVar", "rr", "B", MONAD_Id, i_PRIMOP2, i_sameMVar }
1582 /* Ccall is polyadic - so it's excluded from this table */
1587 AsmPrim ccall_ccall_Id
1588 = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_ccall_Id };
1589 AsmPrim ccall_ccall_IO
1590 = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_ccall_IO };
1591 AsmPrim ccall_stdcall_Id
1592 = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_stdcall_Id };
1593 AsmPrim ccall_stdcall_IO
1594 = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_stdcall_IO };
1597 void checkBytecodeCount( void );
1598 void checkBytecodeCount( void )
1600 if (MAX_Primop1 >= 255) {
1601 printf("Too many Primop1 bytecodes (%d)\n",MAX_Primop1);
1603 if (MAX_Primop2 >= 255) {
1604 printf("Too many Primop2 bytecodes (%d)\n",MAX_Primop2);
1609 AsmPrim* asmFindPrim( char* s )
1612 for (i=0; asmPrimOps[i].name; ++i) {
1613 if (strcmp(s,asmPrimOps[i].name)==0) {
1614 return &asmPrimOps[i];
1620 AsmPrim* asmFindPrimop( AsmInstr prefix, AsmInstr op )
1623 for (i=0; asmPrimOps[i].name; ++i) {
1624 if (asmPrimOps[i].prefix == prefix && asmPrimOps[i].opcode == op) {
1625 return &asmPrimOps[i];
1631 /* --------------------------------------------------------------------------
1632 * Handwritten primops
1633 * ------------------------------------------------------------------------*/
1635 void* /* StgBCO* */ asm_BCO_catch ( void )
1641 bco = asmBeginBCO(0 /*NIL*/);
1642 emiti_8(bco,i_ARG_CHECK,2);
1643 emiti_8(bco,i_PRIMOP1,i_pushcatchframe);
1644 incSp(bco, (1-2)*sizeofW(StgPtr) + sizeofW(StgCatchFrame));
1645 emiti_(bco,i_ENTER);
1646 decSp(bco, sizeofW(StgPtr));
1649 asmAllocateHeapSpace();
1651 closure = (StgBCO*)(bco->closure);
1656 void* /* StgBCO* */ asm_BCO_raise ( void )
1662 bco = asmBeginBCO(0 /*NIL*/);
1663 emiti_8(bco,i_ARG_CHECK,1);
1664 emiti_8(bco,i_PRIMOP2,i_raise);
1665 decSp(bco,sizeofW(StgPtr));
1668 asmAllocateHeapSpace();
1670 closure = (StgBCO*)(bco->closure);
1675 void* /* StgBCO* */ asm_BCO_seq ( void )
1681 cont = asmBeginBCO(0 /*NIL*/);
1682 emiti_8(cont,i_ARG_CHECK,2); /* should never fail */
1684 emit_i_SLIDE(cont,1,2);
1685 emiti_(cont,i_ENTER);
1686 incSp(cont, 3*sizeofW(StgPtr));
1689 eval = asmBeginBCO(0 /*NIL*/);
1690 emiti_8(eval,i_ARG_CHECK,2);
1691 emit_i_RETADDR(eval,eval->n_refs);
1692 asmAddRefObject(eval,cont);
1694 emit_i_SLIDE(eval,3,1);
1695 emiti_8(eval,i_PRIMOP1,i_pushseqframe);
1696 emiti_(eval,i_ENTER);
1697 incSp(eval, sizeofW(StgSeqFrame) + 4*sizeofW(StgPtr));
1700 asmAllocateHeapSpace();
1702 closure = (StgBCO*)(eval->closure);
1707 void* /* StgBCO* */ asm_BCO_takeMVar ( void )
1709 AsmBCO kase, casecont, take;
1713 take = asmBeginBCO(0 /*NIL*/);
1715 emiti_8(take,i_PRIMOP2,i_takeMVar);
1719 emit_i_SLIDE(take,3,4);
1720 emiti_(take,i_ENTER);
1724 casecont = asmBeginBCO(0 /*NIL*/);
1725 emiti_(casecont,i_UNPACK);
1726 emit_i_VAR(casecont,4);
1727 emit_i_VAR(casecont,4);
1728 emit_i_VAR(casecont,2);
1729 emit_i_CONST(casecont,casecont->n_refs);
1730 asmAddRefObject(casecont,take);
1731 emit_i_SLIDE(casecont,4,5);
1732 emiti_(casecont,i_ENTER);
1734 asmEndBCO(casecont);
1736 kase = asmBeginBCO(0 /*NIL*/);
1737 emiti_8(kase,i_ARG_CHECK,3);
1738 emit_i_RETADDR(kase,kase->n_refs);
1739 asmAddRefObject(kase,casecont);
1741 emiti_(kase,i_ENTER);
1745 asmAllocateHeapSpace();
1747 closure = (StgBCO*)(kase->closure);
1753 /* --------------------------------------------------------------------------
1755 * ------------------------------------------------------------------------*/
1757 AsmVar asmAllocCONSTR ( AsmBCO bco, AsmInfo info )
1760 ASSERT( sizeW_fromITBL(info) >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1762 /* Look in this bco's collection of nonpointers (literals)
1763 to see if the itbl pointer is already there. If so, re-use it. */
1764 i = asmFindInNonPtrs ( bco, (StgWord)info );
1767 emit_i_ALLOC_CONSTR(bco,bco->n_words);
1768 asmAddNonPtrWords(bco,AsmInfo,info);
1770 emit_i_ALLOC_CONSTR(bco,i);
1773 incSp(bco, sizeofW(StgClosurePtr));
1777 AsmSp asmBeginPack( AsmBCO bco )
1782 void asmEndPack( AsmBCO bco, AsmVar v, AsmSp start, AsmInfo info )
1784 nat size = bco->sp - start;
1785 ASSERT(bco->sp >= start);
1787 /* only reason to include info is for this assertion */
1788 ASSERT(info->layout.payload.ptrs == size);
1789 emit_i_PACK(bco, bco->sp - v);
1793 void asmBeginUnpack( AsmBCO bco __attribute__ ((unused)) )
1795 /* dummy to make it look prettier */
1798 void asmEndUnpack( AsmBCO bco )
1800 emiti_(bco,i_UNPACK);
1803 AsmVar asmAllocAP( AsmBCO bco, AsmNat words )
1805 emiti_8(bco,i_ALLOC_AP,words);
1806 incSp(bco, sizeofW(StgPtr));
1810 AsmSp asmBeginMkAP( AsmBCO bco )
1815 void asmEndMkAP( AsmBCO bco, AsmVar v, AsmSp start )
1817 emit_i_MKAP(bco,bco->sp-v,bco->sp-start-1);
1818 /* -1 because fun isn't counted */
1822 AsmVar asmAllocPAP( AsmBCO bco, AsmNat size )
1824 emiti_8(bco,i_ALLOC_PAP,size);
1825 incSp(bco, sizeofW(StgPtr));
1829 AsmSp asmBeginMkPAP( AsmBCO bco )
1834 void asmEndMkPAP( AsmBCO bco, AsmVar v, AsmSp start )
1836 emiti_8_8(bco,i_MKPAP,bco->sp-v,bco->sp-start-1);
1837 /* -1 because fun isn't counted */
1841 AsmVar asmPushRefHugs ( AsmBCO bco, int /*Name*/ n )
1843 emit_i_CONST(bco,bco->n_refs);
1844 asmAddRefHugs(bco,n);
1845 incSp(bco, sizeofW(StgPtr));
1849 AsmVar asmPushRefObject ( AsmBCO bco, AsmObject p )
1851 emit_i_CONST(bco,bco->n_refs);
1852 asmAddRefObject(bco,p);
1853 incSp(bco, sizeofW(StgPtr));
1857 AsmVar asmPushRefNoOp ( AsmBCO bco, StgPtr p )
1859 emit_i_CONST(bco,bco->n_refs);
1860 asmAddRefNoOp(bco,p);
1861 incSp(bco, sizeofW(StgPtr));
1866 /* --------------------------------------------------------------------------
1867 * Building InfoTables
1868 * ------------------------------------------------------------------------*/
1870 AsmInfo asmMkInfo( AsmNat tag, AsmNat ptrs )
1872 StgInfoTable* info = stgMallocBytes( sizeof(StgInfoTable),"asmMkInfo");
1873 /* Note: the evaluator automatically pads objects with the right number
1874 * of non-ptrs to satisfy MIN_NONUPD_SIZE restrictions.
1876 AsmNat nptrs = stg_max(0,MIN_NONUPD_SIZE-ptrs);
1878 /* initialisation code based on INFO_TABLE_CONSTR */
1879 info->layout.payload.ptrs = ptrs;
1880 info->layout.payload.nptrs = nptrs;
1881 info->srt_len = tag;
1882 info->type = CONSTR;
1883 #ifdef USE_MINIINTERPRETER
1884 info->entry = stgCast(StgFunPtr,&Hugs_CONSTR_entry);
1886 #warning asmMkInfo: Need to insert entry code in some cunning way
1888 ASSERT( sizeW_fromITBL(info) >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1893 /* -----------------------------------------------------------------------
1894 All the XMLambda primitives.
1895 ------------------------------------------------------------------------*/
1896 static void asmConstWordOpt( AsmBCO bco, AsmWord w )
1900 emiti_8( bco, i_CONST_WORD_8, w );
1901 incSp( bco, repSizeW(WORD_REP)); /* push word */
1905 asmConstWord( bco, w );
1909 /* -----------------------------------------------------------------------
1910 insert/remove primitives on rows
1911 ------------------------------------------------------------------------*/
1912 void asmEndPrimRowChainInsert( AsmBCO bco, AsmSp base, AsmWord n /* number of args */ )
1914 static AsmPrim primRowChainInsert
1915 = { "primRowChainInsert", 0, 0, MONAD_Id, i_PRIMOP2, i_rowChainInsert };
1917 nat size = bco->sp - base;
1918 ASSERT(bco->sp >= base);
1919 ASSERT(n*3 + 1 == size); /* n witness/value pairs + the row */
1921 asmConstWordOpt(bco, n);
1922 asmEndPrim(bco,&primRowChainInsert,base);
1925 void asmEndPrimRowChainBuild( AsmBCO bco, AsmSp base, AsmWord n /* number of args */ )
1927 static AsmPrim primRowChainBuild
1928 = { "primRowChainBuild", 0, 0, MONAD_Id, i_PRIMOP2, i_rowChainBuild };
1930 nat size = bco->sp - base;
1931 ASSERT(bco->sp >= base);
1932 ASSERT(n*3 == size); /* n witness/value pairs */
1934 asmConstWordOpt(bco, n);
1935 asmEndPrim(bco,&primRowChainBuild,base);
1938 void asmEndPrimRowChainRemove( AsmBCO bco, AsmSp base, AsmWord n /* number of args */ )
1940 static AsmPrim primRowChainRemove
1941 = { "primRowChainRemove", 0, 0, MONAD_Id, i_PRIMOP2, i_rowChainRemove };
1943 nat size = bco->sp - base;
1944 ASSERT(bco->sp >= base);
1945 ASSERT(n*2 + 1 == size); /* n witnesses + the row */
1947 asmConstWordOpt(bco, n);
1948 asmEndPrim(bco,&primRowChainRemove,base);
1951 void asmEndPrimRowChainSelect( AsmBCO bco, AsmSp base, AsmWord n /* number of args */ )
1953 static AsmPrim primRowChainSelect
1954 = { "primRowChainSelect", 0, 0, MONAD_Id, i_PRIMOP2, i_rowChainSelect };
1956 nat size = bco->sp - base;
1957 ASSERT(bco->sp >= base);
1958 ASSERT(n*2 + 1 == size); /* n witnesses + the row */
1960 asmConstWordOpt(bco, n);
1961 asmEndPrim(bco,&primRowChainSelect,base);
1964 /* -----------------------------------------------------------------------
1965 allocation & unpacking of rows
1966 ------------------------------------------------------------------------*/
1967 AsmVar asmAllocRow ( AsmBCO bco, AsmWord n /*number of fields*/ )
1969 emit_i_ALLOC_ROW(bco,n);
1971 incSp(bco, sizeofW(StgClosurePtr));
1975 AsmSp asmBeginPackRow( AsmBCO bco )
1980 void asmEndPackRow( AsmBCO bco, AsmVar v, AsmSp start, AsmWord n /*number of fields*/ )
1982 nat size = bco->sp - start;
1983 ASSERT(bco->sp >= start);
1985 /* only reason to include n is for this assertion */
1987 emit_i_PACK_ROW(bco,bco->sp - v);
1991 void asmBeginUnpackRow( AsmBCO bco __attribute__ ((unused)) )
1993 /* dummy to make it look prettier */
1996 void asmEndUnpackRow( AsmBCO bco )
1998 emiti_(bco,i_UNPACK_ROW);
2001 void asmConstRowTriv( AsmBCO bco )
2003 emiti_(bco,i_CONST_ROW_TRIV);
2004 incSp(bco,sizeofW(StgPtr));
2007 /*------------------------------------------------------------------------
2009 The Inj constructor contains the value and its index: an unboxed word
2010 data Inj = forall a. Inj a Int#
2011 ------------------------------------------------------------------------*/
2012 AsmVar asmInjRel( AsmBCO bco, AsmVar var, AsmWitness w )
2014 int offset = bco->sp - var;
2018 emit_i_PACK_INJ_VAR( bco, offset );
2020 else if (w < 256 && offset < 256 && offset >= 0)
2022 emiti_8_8( bco, i_PACK_INJ_REL_8, offset, w );
2026 asmWitnessRel( bco, var, w );
2027 emiti_( bco, i_PACK_INJ );
2028 decSp(bco, repSizeW(WITNESS_REP)); /* pop witness */
2031 decSp(bco, sizeofW(StgPtr)); /* pop argument value */
2032 incSp(bco, sizeofW(StgPtr)); /* push Inj result */
2036 AsmVar asmInjConst( AsmBCO bco, AsmWitness w )
2040 emiti_8 (bco, i_PACK_INJ_CONST_8, w );
2044 asmWitnessConst( bco, w );
2045 emiti_( bco, i_PACK_INJ );
2046 decSp(bco, repSizeW(WITNESS_REP)); /* pop witness */
2049 decSp(bco, sizeofW(StgPtr)); /* pop argument value */
2050 incSp(bco, sizeofW(StgPtr)); /* push Inj result */
2054 /* UNPACK_INJ only returns the value; the index should be
2055 tested using the TEST_INJ instructions. */
2056 AsmVar asmUnInj( AsmBCO bco )
2058 emiti_(bco,i_UNPACK_INJ);
2059 incSp(bco, sizeofW(StgPtr)); /* push the value */
2063 AsmPc asmTestInjRel( AsmBCO bco, AsmVar var, AsmWitness w )
2065 int offset = bco->sp - var;
2069 emit_i_TEST_INJ_VAR(bco,offset );
2071 else if (w < 256 && offset < 256 && offset >= 0)
2073 emiti_8_8_16( bco, i_TEST_INJ_REL_8, offset, w, 0 );
2077 asmWitnessRel( bco, var, w );
2078 emiti_16( bco, i_TEST_INJ, 0 );
2079 decSp(bco, repSizeW(WITNESS_REP)); /* pop witness */
2081 return bco->n_insns;
2084 AsmPc asmTestInjConst( AsmBCO bco, AsmWitness w )
2088 emiti_8_16( bco, i_TEST_INJ_CONST_8, w, 0 );
2092 asmWitnessConst( bco, w );
2093 emiti_16( bco, i_TEST_INJ, 0 );
2094 decSp(bco, repSizeW(WITNESS_REP)); /* pop witness */
2096 return bco->n_insns;
2100 void asmWitnessRel( AsmBCO bco, AsmVar var, AsmWitness w )
2102 int offset = bco->sp - var;
2106 asmVar( bco, var, WITNESS_REP );
2108 else if (w < 256 && offset < 256 && offset >= 0)
2110 emiti_8_8( bco, i_ADD_WORD_VAR_8, offset, w );
2111 incSp( bco, repSizeW(WITNESS_REP)); /* push result */
2115 asmWitnessConst( bco, w );
2116 emit_i_ADD_WORD_VAR( bco, bco->sp - var );
2117 decSp( bco, repSizeW(WITNESS_REP)); /* pop witness w */
2118 incSp( bco, repSizeW(WITNESS_REP)); /* push witness result */
2122 void asmWitnessConst( AsmBCO bco, AsmWitness w )
2126 emiti_8( bco, i_CONST_WORD_8, w );
2127 incSp( bco, repSizeW(WITNESS_REP)); /* push witness */
2131 asmConstWord( bco, w );
2139 /* -----------------------------------------------------------------------
2141 ------------------------------------------------------------------------*/
2142 #include "ForeignCall.h" /* for CallInfo definition */
2143 #include "Dynamic.h" /* for loadLibrarySymbol & decorateSymbol */
2145 void asmEndPrimCallIndirect(
2148 , const char* argTypes
2149 , const char* resultTypes
2150 , CallType callType )
2152 static AsmPrim primCCall
2153 = { "ccall", 0, 0, MONAD_Id, i_PRIMOP2, i_ccall };
2157 int argCount = argTypes ? strlen(argTypes) : 0;
2158 int resultCount = resultTypes ? strlen(resultTypes) : 0;
2160 if (argCount + resultCount > MAX_CALL_VALUES)
2161 barf( "external call: too many arguments and/or results" );
2163 /* initialize the callInfo structure */
2164 callInfo.argCount = argCount;
2165 callInfo.resultCount = resultCount;
2166 callInfo.callConv = CCall;
2167 callInfo.data[0] = '\0';
2168 callInfo.data[1] = '\0';
2172 case CCall: callInfo.callConv = CCall; break;
2173 case StdCall: callInfo.callConv = StdCall; break;
2174 default: belch( "external call: unknown calling convention: \"%c\"", callType );
2177 if (argCount > 0) strcpy(callInfo.data,argTypes);
2178 if (resultCount > 0) strcpy(callInfo.data + argCount + 1, resultTypes);
2180 /* We push the offset of the CallInfo structure in this BCO's
2181 non-ptr area as a Word. In the "i_ccall" primitive
2182 this offset is used to retrieve the CallInfo again. */
2183 offset = bco->n_words;
2184 asmAddNonPtrWords(bco,CallInfo,callInfo);
2185 asmConstWord(bco,offset);
2188 asmEndPrim( bco, &primCCall, base );
2193 void asmEndPrimCallDynamic(
2196 , const char* libName
2197 , const char* funName
2198 , const char* argTypes
2199 , const char* resultTypes
2201 , int /*bool*/ decorate )
2207 /* load the function pointer */
2210 char funNameBuf[MAX_SYMBOL_NAME];
2211 decorateSymbol( funNameBuf, funName, MAX_SYMBOL_NAME
2212 , callType, argTypes, resultTypes );
2213 funPtr = loadLibrarySymbol( libName, funNameBuf, callType );
2216 funPtr = loadLibrarySymbol( libName, funName, callType );
2218 /* push the static function pointer */
2219 asmConstAddr( bco, funPtr );
2221 /* and call it indirectly */
2222 asmEndPrimCallIndirect( bco, base, argTypes, resultTypes, callType );
2225 #endif /* XMLAMBDA */
2228 /*-------------------------------------------------------------------------*/
2230 #endif /* INTERPRETER */