2 /* --------------------------------------------------------------------------
5 * Copyright (c) 1994-1998.
7 * $RCSfile: Assembler.c,v $
9 * $Date: 1999/03/09 14:51:19 $
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 "Evaluator.h"
53 #include "StgMiscClosures.h"
56 #define INSIDE_ASSEMBLER_C
57 #include "Assembler.h"
58 #undef INSIDE_ASSEMBLER_C
60 /* --------------------------------------------------------------------------
61 * References between BCOs
63 * These are necessary because there can be circular references between
64 * BCOs so we have to keep track of all the references to each object
65 * and fill in all the references once we're done.
67 * ToDo: generalise to allow references between any objects
68 * ------------------------------------------------------------------------*/
71 AsmObject ref; /* who refers to it */
72 AsmNat i; /* index into some table held by referer */
75 /* --------------------------------------------------------------------------
76 * Queues (of instructions, ptrs, nonptrs)
77 * ------------------------------------------------------------------------*/
79 /* ToDo: while debugging, we use a chunk size of 1 to stress-test the code
80 * this should be fine-tuned using statistics on common sizes
83 #define InstrsChunkSize 40
84 #define PtrsChunkSize 10
85 #define RefsChunkSize 10
86 #define NonPtrsChunkSize 10
90 #include "QueueTemplate.h"
95 #define Type AsmObject
96 #include "QueueTemplate.h"
102 #include "QueueTemplate.h"
106 #define Queue NonPtrs
108 #include "QueueTemplate.h"
112 /* --------------------------------------------------------------------------
113 * AsmObjects are used to build heap objects.
115 * AsmObjects can contain circular references to each other
116 * so we have to keep track of all the references which can't be filled
119 * When we finish building an AsmObject, we allocate an actual heap object and
120 * fill in all the references to the asmObject with pointers to the heap object.
122 * We obtain a limited form of polymorphism through inheritance by putting
123 * the AsmObject first in every structure (as in C++ implementations).
124 * We use the closure type of the allocated object to figure out
125 * where the payload lives in the closure.
126 * ------------------------------------------------------------------------*/
127 /* ToDo: clean up terminology: is Closure right or should it be object or ... */
132 AsmNat num_unresolved; /* number of unfilled references */
133 StgClosure* closure; /* where object was allocated */
137 struct AsmObject_ object; /* must be first in struct */
143 struct AsmObject_ object; /* must be first in struct */
147 struct AsmObject_ object; /* must be first in struct */
149 int /*StgExpr*/ stgexpr;
153 /* abstract machine ("executed" during compilation) */
154 AsmSp sp; /* stack ptr */
156 StgWord hp; /* heap ptr */
160 static void asmResolveRef( AsmObject obj, AsmNat i, AsmClosure reference )
162 ASSERT(obj->closure);
163 switch (get_itbl(obj->closure)->type) {
166 StgBCO* bco = stgCast(StgBCO*,obj->closure);
167 ASSERT(i < bco->n_ptrs && bcoConstPtr(bco,i) == NULL);
168 bcoConstCPtr(bco,i) = reference;
173 StgCAF* caf = stgCast(StgCAF*,obj->closure);
174 ASSERT(i == 0 && caf->body == NULL);
175 caf->body = reference;
180 StgClosure* con = stgCast(StgClosure*,obj->closure);
181 ASSERT(i < get_itbl(con)->layout.payload.nptrs && payloadCPtr(con,i) == NULL);
182 payloadCPtr(con,i) = reference;
187 StgAP_UPD* ap = stgCast(StgAP_UPD*,obj->closure);
188 ASSERT(i < 1+ap->n_args);
190 ASSERT(ap->fun == NULL);
193 ASSERT(payloadCPtr(ap,i-1) == NULL);
194 payloadCPtr(ap,i-1) = reference;
199 barf("asmResolveRef");
201 obj->num_unresolved -= 1;
203 if (obj->num_unresolved == 0) {
204 /* todo: free the queues */
206 /* we don't print until all ptrs are resolved */
207 IF_DEBUG(codegen,printObj(obj->closure);printf("\n\n"));
211 static void asmAddRef( AsmObject referent, AsmObject referer, AsmNat i )
213 if (referent->closure) {
214 asmResolveRef(referer,i,(AsmClosure)referent->closure);
216 insertRefs(&(referent->refs),(AsmRef){referer,i});
220 void asmAddPtr( AsmObject obj, AsmObject arg )
222 ASSERT(obj->closure == 0); /* can't extend an object once it's allocated */
223 insertPtrs( &obj->ptrs, arg );
226 static void asmBeginObject( AsmObject obj )
229 obj->num_unresolved = 0;
230 initRefs(&obj->refs);
231 initPtrs(&obj->ptrs);
234 static void asmEndObject( AsmObject obj, StgClosure* c )
236 obj->num_unresolved = obj->ptrs.len;
238 mapQueue(Ptrs, AsmObject, obj->ptrs, asmAddRef(x,obj,i));
239 mapQueue(Refs, AsmRef, obj->refs, asmResolveRef(x.ref,x.i,c));
241 if (obj->num_unresolved == 0) {
242 /* todo: free the queues */
243 /* we don't print until all ptrs are resolved */
245 if (obj->num_unresolved > 0)
246 fprintf(stderr, "{{%d unresolved}} ", obj->num_unresolved);
248 IF_DEBUG(codegen,printObj(obj->closure));
250 //printf( "unresolved %d\n", obj->num_unresolved);
251 //printObj(obj->closure);
255 int asmObjectHasClosure ( AsmObject obj )
257 return (obj->num_unresolved == 0 && obj->closure);
260 AsmClosure asmClosureOfObject ( AsmObject obj )
262 ASSERT(asmObjectHasClosure(obj));
266 void asmMarkObject ( AsmObject obj )
268 ASSERT(obj->num_unresolved == 0 && obj->closure);
269 obj->closure = MarkRoot(obj->closure);
272 /* --------------------------------------------------------------------------
274 * ------------------------------------------------------------------------*/
276 static StgClosure* asmAlloc( nat size )
278 StgClosure* o = stgCast(StgClosure*,allocate(size));
279 ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
280 /* printf("Allocated %p .. %p\n", o, o+size-1); */
284 static void grabHpUpd( AsmBCO bco, nat size )
286 /* ToDo: sometimes we should test for MIN_UPD_SIZE instead */
287 ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
291 static void grabHpNonUpd( AsmBCO bco, nat size )
293 /* ToDo: sometimes we should test for MIN_UPD_SIZE instead */
294 ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
298 static void resetHp( AsmBCO bco, nat hp )
300 bco->max_hp = stg_max(bco->hp,bco->max_hp);
304 static void resetSp( AsmBCO bco, AsmSp sp )
306 bco->max_sp = stg_max(bco->sp,bco->max_sp);
310 /* --------------------------------------------------------------------------
312 * ------------------------------------------------------------------------*/
314 AsmObject asmMkObject( AsmClosure c )
316 AsmObject obj = malloc(sizeof(struct AsmObject_));
318 barf("Can't allocate AsmObject");
325 AsmCon asmBeginCon( AsmInfo info )
327 AsmCon con = malloc(sizeof(struct AsmCon_));
329 barf("Can't allocate AsmCon");
331 asmBeginObject(&con->object);
336 void asmEndCon( AsmCon con )
338 nat p = con->object.ptrs.len;
339 nat np = stg_max(0,MIN_NONUPD_SIZE-p);
341 StgClosure* c = asmAlloc(CONSTR_sizeW(p,np));
342 StgClosure* o = stgCast(StgClosure*,c);
343 SET_HDR(o,con->info,??);
344 mapQueue(Ptrs, AsmObject, con->object.ptrs, payloadCPtr(o,i) = NULL);
345 { nat i; for( i=0; i<np; ++i ) { payloadWord(o,p+i) = 0xdeadbeef; } }
346 asmEndObject(&con->object,c);
349 AsmCAF asmBeginCAF( void )
351 AsmCAF caf = malloc(sizeof(struct AsmCAF_));
353 barf("Can't allocate AsmCAF");
355 asmBeginObject(&caf->object);
359 void asmEndCAF( AsmCAF caf, AsmBCO body )
361 StgClosure* c = asmAlloc(CAF_sizeW());
362 StgCAF* o = stgCast(StgCAF*,c);
363 SET_HDR(o,&CAF_UNENTERED_info,??);
365 o->value = stgCast(StgClosure*,0xdeadbeef);
366 o->link = stgCast(StgCAF*,0xdeadbeef);
367 asmAddPtr(&caf->object,&body->object);
368 asmEndObject(&caf->object,c);
371 AsmBCO asmBeginBCO( int /*StgExpr*/ e )
373 AsmBCO bco = malloc(sizeof(struct AsmBCO_));
375 barf("Can't allocate AsmBCO");
377 asmBeginObject(&bco->object);
378 initInstrs(&bco->is);
379 initNonPtrs(&bco->nps);
382 bco->max_sp = bco->sp = 0;
383 bco->max_hp = bco->hp = 0;
387 void asmEndBCO( AsmBCO bco )
389 nat p = bco->object.ptrs.len;
390 nat np = bco->nps.len;
392 nat is = bco->is.len + 4; /* 4 for stack and heap checks */
394 nat is = bco->is.len + 2; /* 4 for stack check */
397 StgClosure* c = asmAlloc(BCO_sizeW(p,np,is));
398 StgBCO* o = stgCast(StgBCO*,c);
399 SET_HDR(o,&BCO_info,??);
403 o->stgexpr = bco->stgexpr;
404 mapQueue(Ptrs, AsmObject, bco->object.ptrs, bcoConstCPtr(o,i) = NULL);
405 mapQueue(NonPtrs, StgWord, bco->nps, bcoConstWord(o,i) = x);
408 bco->max_sp = stg_max(bco->sp,bco->max_sp);
409 bco->max_hp = stg_max(bco->hp,bco->max_hp);
410 bcoInstr(o,j++) = i_STK_CHECK;
411 bcoInstr(o,j++) = bco->max_sp;
413 bcoInstr(o,j++) = i_HP_CHECK;
414 bcoInstr(o,j++) = bco->max_hp;
416 mapQueue(Instrs, StgWord8, bco->is, bcoInstr(o,j++) = x);
419 asmEndObject(&bco->object,c);
422 /* --------------------------------------------------------------------------
424 * ------------------------------------------------------------------------*/
426 static void asmInstr8 ( AsmBCO bco, StgWord i )
429 fprintf(stderr, "too big (256)\n");
431 ASSERT(i < 256); /* must be a byte */
432 insertInstrs(&(bco->is),i);
435 static void asmInstr16 ( AsmBCO bco, StgWord i )
438 fprintf(stderr, "too big (65536)\n");
440 ASSERT(i < 65536); /* must be a byte */
441 insertInstrs(&(bco->is),i / 256);
442 insertInstrs(&(bco->is),i % 256);
445 static void asmPtr( AsmBCO bco, AsmObject x )
447 insertPtrs( &bco->object.ptrs, x );
450 static void asmWord( AsmBCO bco, StgWord i )
452 insertNonPtrs( &bco->nps, i );
455 #define asmWords(bco,ty,x) \
457 union { ty a; AsmWord b[sizeofW(ty)]; } p; \
459 if (sizeof(ty) < sizeof(AsmWord)) p.b[0]=0; \
461 for( i = 0; i < sizeofW(ty); i++ ) { \
462 asmWord(bco,p.b[i]); \
466 static StgWord repSizeW( AsmRep rep )
469 case CHAR_REP: return sizeofW(StgWord) + sizeofW(StgChar);
472 case INT_REP: return sizeofW(StgWord) + sizeofW(StgInt);
474 case INT64_REP: return sizeofW(StgWord) + sizeofW(StgInt64);
477 case WORD_REP: return sizeofW(StgWord) + sizeofW(StgWord);
480 case ADDR_REP: return sizeofW(StgWord) + sizeofW(StgAddr);
482 case FLOAT_REP: return sizeofW(StgWord) + sizeofW(StgFloat);
483 case DOUBLE_REP: return sizeofW(StgWord) + sizeofW(StgDouble);
484 #ifdef PROVIDE_STABLE
485 case STABLE_REP: return sizeofW(StgWord) + sizeofW(StgWord);
488 #ifdef PROVIDE_INTEGER
494 #ifdef PROVIDE_FOREIGN
497 case ALPHA_REP: /* a */
498 case BETA_REP: /* b */
499 case GAMMA_REP: /* c */
500 case HANDLER_REP: /* IOError -> IO a */
501 case ERROR_REP: /* IOError */
503 case ARR_REP : /* PrimArray a */
504 case BARR_REP : /* PrimByteArray a */
505 case REF_REP : /* Ref s a */
506 case MUTARR_REP : /* PrimMutableArray s a */
507 case MUTBARR_REP: /* PrimMutableByteArray s a */
509 #ifdef PROVIDE_CONCURRENT
510 case THREADID_REP: /* ThreadId */
511 case MVAR_REP: /* MVar a */
513 case PTR_REP: return sizeofW(StgPtr);
515 case VOID_REP: return sizeofW(StgWord);
516 default: barf("repSizeW %d",rep);
520 /* --------------------------------------------------------------------------
521 * Instruction emission
522 * ------------------------------------------------------------------------*/
524 static void emit_i0 ( AsmBCO bco, Instr opcode )
526 asmInstr8(bco,opcode);
529 static void emit_i1 ( AsmBCO bco, Instr opcode, int arg1 )
531 asmInstr8(bco,opcode);
535 static void emit_i2 ( AsmBCO bco, Instr opcode, int arg1, int arg2 )
537 asmInstr8(bco,opcode);
542 static void emit_i_VAR_INT ( AsmBCO bco, int arg1 )
546 asmInstr8(bco,i_VAR_INT);
549 asmInstr8(bco,i_VAR_INT_big);
550 asmInstr16(bco,arg1);
555 static void emit_i_VAR_ADDR ( AsmBCO bco, int arg1 )
559 asmInstr8(bco,i_VAR_ADDR);
562 asmInstr8(bco,i_VAR_ADDR_big);
563 asmInstr16(bco,arg1);
568 static void emit_i_VAR_CHAR ( AsmBCO bco, int arg1 )
572 asmInstr8(bco,i_VAR_CHAR);
575 asmInstr8(bco,i_VAR_CHAR_big);
576 asmInstr16(bco,arg1);
580 static void emit_i_VAR_FLOAT ( AsmBCO bco, int arg1 )
584 asmInstr8(bco,i_VAR_FLOAT);
587 asmInstr8(bco,i_VAR_FLOAT_big);
588 asmInstr16(bco,arg1);
592 static void emit_i_VAR_DOUBLE ( AsmBCO bco, int arg1 )
596 asmInstr8(bco,i_VAR_DOUBLE);
599 asmInstr8(bco,i_VAR_DOUBLE_big);
600 asmInstr16(bco,arg1);
604 static void emit_i_VAR ( AsmBCO bco, int arg1 )
608 asmInstr8(bco,i_VAR);
611 asmInstr8(bco,i_VAR_big);
612 asmInstr16(bco,arg1);
616 static void emit_i_SLIDE ( AsmBCO bco, int arg1, int arg2 )
620 if (arg1 < 256 && arg2 < 256) {
621 asmInstr8(bco,i_SLIDE);
625 asmInstr8(bco,i_SLIDE_big);
626 asmInstr16(bco,arg1);
627 asmInstr16(bco,arg2);
631 static void emit_i_MKAP ( AsmBCO bco, int arg1, int arg2 )
635 if (arg1 < 256 && arg2 < 256) {
636 asmInstr8(bco,i_MKAP);
640 asmInstr8(bco,i_MKAP_big);
641 asmInstr16(bco,arg1);
642 asmInstr16(bco,arg2);
646 static void emit_i_CONST_INT ( AsmBCO bco, int arg1 )
650 asmInstr8(bco,i_CONST_INT);
653 asmInstr8(bco,i_CONST_INT_big);
654 asmInstr16(bco,arg1);
658 #ifdef PROVIDE_INTEGER
659 static void emit_i_CONST_INTEGER ( AsmBCO bco, int arg1 )
663 asmInstr8(bco,i_CONST_INTEGER);
666 asmInstr8(bco,i_CONST_INTEGER_big);
667 asmInstr16(bco,arg1);
672 static void emit_i_CONST_ADDR ( AsmBCO bco, int arg1 )
676 asmInstr8(bco,i_CONST_ADDR);
679 asmInstr8(bco,i_CONST_ADDR_big);
680 asmInstr16(bco,arg1);
684 static void emit_i_CONST_CHAR ( AsmBCO bco, int arg1 )
688 asmInstr8(bco,i_CONST_CHAR);
691 asmInstr8(bco,i_CONST_CHAR_big);
692 asmInstr16(bco,arg1);
696 static void emit_i_CONST_FLOAT ( AsmBCO bco, int arg1 )
700 asmInstr8(bco,i_CONST_FLOAT);
703 asmInstr8(bco,i_CONST_FLOAT_big);
704 asmInstr16(bco,arg1);
708 static void emit_i_CONST_DOUBLE ( AsmBCO bco, int arg1 )
712 asmInstr8(bco,i_CONST_DOUBLE);
715 asmInstr8(bco,i_CONST_DOUBLE_big);
716 asmInstr16(bco,arg1);
720 static void emit_i_RETADDR ( AsmBCO bco, int arg1 )
724 asmInstr8(bco,i_RETADDR);
727 asmInstr8(bco,i_RETADDR_big);
728 asmInstr16(bco,arg1);
732 static void emit_i_CONST ( AsmBCO bco, int arg1 )
736 asmInstr8(bco,i_CONST);
739 asmInstr8(bco,i_CONST_big);
740 asmInstr16(bco,arg1);
745 /* --------------------------------------------------------------------------
747 * ------------------------------------------------------------------------*/
749 AsmSp asmBeginArgCheck ( AsmBCO bco )
751 ASSERT(bco->sp == 0);
755 void asmEndArgCheck ( AsmBCO bco, AsmSp last_arg )
757 nat args = bco->sp - last_arg;
758 if (args != 0) { /* optimisation */
759 emit_i1(bco,i_ARG_CHECK,args);
760 grabHpNonUpd(bco,PAP_sizeW(args-1));
765 /* --------------------------------------------------------------------------
766 * Creating and using "variables"
767 * ------------------------------------------------------------------------*/
769 AsmVar asmBind ( AsmBCO bco, AsmRep rep )
771 bco->sp += repSizeW(rep);
775 void asmVar ( AsmBCO bco, AsmVar v, AsmRep rep )
779 if (rep == VOID_REP) {
781 bco->sp += repSizeW(rep);
785 offset = bco->sp - v;
789 emit_i_VAR_INT(bco,offset);
793 emit_i_VAR_INT64(bco,offset);
798 emit_i_VAR_WORD(bco,offset);
803 emit_i_VAR_ADDR(bco,offset);
807 emit_i_VAR_CHAR(bco,offset);
810 emit_i_VAR_FLOAT(bco,offset);
813 emit_i_VAR_DOUBLE(bco,offset);
815 #ifdef PROVIDE_STABLE
817 emit_i_VAR_STABLE(bco,offset);
821 #ifdef PROVIDE_INTEGER
827 #ifdef PROVIDE_FOREIGN
830 case ALPHA_REP: /* a */
831 case BETA_REP: /* b */
832 case GAMMA_REP: /* c */
833 case HANDLER_REP: /* IOError -> IO a */
834 case ERROR_REP: /* IOError */
836 case ARR_REP : /* PrimArray a */
837 case BARR_REP : /* PrimByteArray a */
838 case REF_REP : /* Ref s a */
839 case MUTARR_REP : /* PrimMutableArray s a */
840 case MUTBARR_REP: /* PrimMutableByteArray s a */
842 #ifdef PROVIDE_CONCURRENT
843 case THREADID_REP: /* ThreadId */
844 case MVAR_REP: /* MVar a */
847 emit_i_VAR(bco,offset);
850 barf("asmVar %d",rep);
852 bco->sp += repSizeW(rep);
855 /* --------------------------------------------------------------------------
857 * ------------------------------------------------------------------------*/
859 AsmSp asmBeginEnter( AsmBCO bco )
864 void asmEndEnter( AsmBCO bco, AsmSp sp1, AsmSp sp2 )
866 int x = bco->sp - sp1;
868 ASSERT(x >= 0 && y >= 0);
870 emit_i_SLIDE(bco,x,y);
871 bco->sp -= sp1 - sp2;
873 emit_i0(bco,i_ENTER);
876 /* --------------------------------------------------------------------------
877 * Build boxed Ints, Floats, etc
878 * ------------------------------------------------------------------------*/
880 AsmVar asmBox( AsmBCO bco, AsmRep rep )
884 emit_i0(bco,i_PACK_CHAR);
885 grabHpNonUpd(bco,Czh_sizeW);
888 emit_i0(bco,i_PACK_INT);
889 grabHpNonUpd(bco,Izh_sizeW);
893 emit_i0(bco,i_PACK_INT64);
894 grabHpNonUpd(bco,I64zh_sizeW);
899 emit_i0(bco,i_PACK_WORD);
900 grabHpNonUpd(bco,Wzh_sizeW);
905 emit_i0(bco,i_PACK_ADDR);
906 grabHpNonUpd(bco,Azh_sizeW);
910 emit_i0(bco,i_PACK_FLOAT);
911 grabHpNonUpd(bco,Fzh_sizeW);
914 emit_i0(bco,i_PACK_DOUBLE);
915 grabHpNonUpd(bco,Dzh_sizeW);
917 #ifdef PROVIDE_STABLE
919 emit_i0(bco,i_PACK_STABLE);
920 grabHpNonUpd(bco,Stablezh_sizeW);
925 barf("asmBox %d",rep);
927 /* NB: these operations DO pop their arg */
928 bco->sp -= repSizeW(rep); /* pop unboxed arg */
929 bco->sp += sizeofW(StgPtr); /* push box */
933 /* --------------------------------------------------------------------------
934 * Unbox Ints, Floats, etc
935 * ------------------------------------------------------------------------*/
937 AsmVar asmUnbox( AsmBCO bco, AsmRep rep )
941 emit_i0(bco,i_UNPACK_INT);
945 emit_i0(bco,i_UNPACK_INT64);
950 emit_i0(bco,i_UNPACK_WORD);
955 emit_i0(bco,i_UNPACK_ADDR);
959 emit_i0(bco,i_UNPACK_CHAR);
962 emit_i0(bco,i_UNPACK_FLOAT);
965 emit_i0(bco,i_UNPACK_DOUBLE);
967 #ifdef PROVIDE_STABLE
969 emit_i0(bco,i_UNPACK_STABLE);
973 barf("asmUnbox %d",rep);
975 /* NB: these operations DO NOT pop their arg */
976 bco->sp += repSizeW(rep); /* push unboxed arg */
980 /* --------------------------------------------------------------------------
981 * Return unboxed Ints, Floats, etc
982 * ------------------------------------------------------------------------*/
984 void asmReturnUnboxed( AsmBCO bco, AsmRep rep )
988 emit_i0(bco,i_RETURN_CHAR);
991 emit_i0(bco,i_RETURN_INT);
995 emit_i0(bco,i_RETURN_INT64);
1000 emit_i0(bco,i_RETURN_WORD);
1005 emit_i0(bco,i_RETURN_ADDR);
1009 emit_i0(bco,i_RETURN_FLOAT);
1012 emit_i0(bco,i_RETURN_DOUBLE);
1014 #ifdef PROVIDE_STABLE
1016 emit_i0(bco,i_RETURN_STABLE);
1019 #ifdef PROVIDE_INTEGER
1025 #ifdef PROVIDE_FOREIGN
1028 #ifdef PROVIDE_ARRAY
1029 case ARR_REP : /* PrimArray a */
1030 case BARR_REP : /* PrimByteArray a */
1031 case REF_REP : /* Ref s a */
1032 case MUTARR_REP : /* PrimMutableArray s a */
1033 case MUTBARR_REP: /* PrimMutableByteArray s a */
1035 #ifdef PROVIDE_CONCURRENT
1036 case THREADID_REP: /* ThreadId */
1037 case MVAR_REP: /* MVar a */
1039 emit_i0(bco,i_RETURN_GENERIC);
1042 barf("asmReturnUnboxed %d",rep);
1046 /* --------------------------------------------------------------------------
1047 * Push unboxed Ints, Floats, etc
1048 * ------------------------------------------------------------------------*/
1050 void asmConstInt( AsmBCO bco, AsmInt x )
1052 emit_i_CONST_INT(bco,bco->nps.len);
1053 asmWords(bco,AsmInt,x);
1054 bco->sp += repSizeW(INT_REP);
1057 #ifdef PROVIDE_INT64
1058 void asmConstInt64( AsmBCO bco, AsmInt64 x )
1060 emit_i_CONST_INT64(bco,bco->nps.len);
1061 asmWords(bco,AsmInt64,x);
1062 bco->sp += repSizeW(INT64_REP);
1066 #ifdef PROVIDE_INTEGER
1067 void asmConstInteger( AsmBCO bco, AsmString x )
1069 emit_i_CONST_INTEGER(bco,bco->nps.len);
1070 asmWords(bco,AsmString,x);
1071 bco->sp += repSizeW(INTEGER_REP);
1076 void asmConstAddr( AsmBCO bco, AsmAddr x )
1078 emit_i_CONST_ADDR(bco,bco->nps.len);
1079 asmWords(bco,AsmAddr,x);
1080 bco->sp += repSizeW(ADDR_REP);
1085 void asmConstWord( AsmBCO bco, AsmWord x )
1087 emit_i_CONST_INT(bco->nps.len);
1088 asmWords(bco,AsmWord,x);
1089 bco->sp += repSizeW(WORD_REP);
1093 void asmConstChar( AsmBCO bco, AsmChar x )
1095 emit_i_CONST_CHAR(bco,bco->nps.len);
1096 asmWords(bco,AsmChar,x);
1097 bco->sp += repSizeW(CHAR_REP);
1100 void asmConstFloat( AsmBCO bco, AsmFloat x )
1102 emit_i_CONST_FLOAT(bco,bco->nps.len);
1103 asmWords(bco,AsmFloat,x);
1104 bco->sp += repSizeW(FLOAT_REP);
1107 void asmConstDouble( AsmBCO bco, AsmDouble x )
1109 emit_i_CONST_DOUBLE(bco,bco->nps.len);
1110 asmWords(bco,AsmDouble,x);
1111 bco->sp += repSizeW(DOUBLE_REP);
1114 /* --------------------------------------------------------------------------
1115 * Algebraic case helpers
1116 * ------------------------------------------------------------------------*/
1118 /* a mildly bogus pair of functions... */
1119 AsmSp asmBeginCase( AsmBCO bco )
1124 void asmEndCase( AsmBCO bco )
1128 AsmSp asmContinuation( AsmBCO bco, AsmBCO ret_addr )
1130 emit_i_RETADDR(bco,bco->object.ptrs.len);
1131 asmPtr(bco,&(ret_addr->object));
1132 bco->sp += 2 * sizeofW(StgPtr);
1136 AsmBCO asmBeginContinuation ( AsmSp sp, int /*List*/ alts )
1138 AsmBCO bco = asmBeginBCO(alts);
1143 void asmEndContinuation ( AsmBCO bco )
1149 /* --------------------------------------------------------------------------
1151 * ------------------------------------------------------------------------*/
1153 AsmSp asmBeginAlt( AsmBCO bco )
1158 void asmEndAlt( AsmBCO bco, AsmSp sp )
1161 /* This warning is now redundant since we no longer use the hp/max_hp
1162 * information calculated by the assembler
1164 #warning ToDo: adjust hp/max_hp in asmEndAlt
1169 AsmPc asmTest( AsmBCO bco, AsmWord tag )
1171 asmInstr8(bco,i_TEST);
1177 AsmPc asmTestInt( AsmBCO bco, AsmVar v, AsmInt x )
1179 asmVar(bco,v,INT_REP);
1181 asmInstr8(bco,i_TEST_INT);
1183 bco->sp -= 2*repSizeW(INT_REP);
1187 void asmFixBranch( AsmBCO bco, AsmPc from )
1189 int distance = bco->is.len - from;
1190 ASSERT(distance >= 0);
1191 ASSERT(distance < 65536);
1192 setInstrs(&(bco->is),from-2,distance/256);
1193 setInstrs(&(bco->is),from-1,distance%256);
1196 void asmPanic( AsmBCO bco )
1198 emit_i0(bco,i_PANIC); /* "irrefutable" pattern failed - oops! */
1201 /* --------------------------------------------------------------------------
1203 * ------------------------------------------------------------------------*/
1205 AsmSp asmBeginPrim( AsmBCO bco )
1210 void asmEndPrim( AsmBCO bco, const AsmPrim* prim, AsmSp base )
1212 emit_i1(bco,prim->prefix,prim->opcode);
1216 /* Hugs used to let you add arbitrary primops with arbitrary types
1217 * just by editing Prelude.hs or any other file you wanted.
1218 * We deliberately avoided that approach because we wanted more
1219 * control over which primops are provided.
1221 const AsmPrim asmPrimOps[] = {
1223 /* Char# operations */
1224 { "primGtChar", "CC", "B", MONAD_Id, i_PRIMOP1, i_gtChar }
1225 , { "primGeChar", "CC", "B", MONAD_Id, i_PRIMOP1, i_geChar }
1226 , { "primEqChar", "CC", "B", MONAD_Id, i_PRIMOP1, i_eqChar }
1227 , { "primNeChar", "CC", "B", MONAD_Id, i_PRIMOP1, i_neChar }
1228 , { "primLtChar", "CC", "B", MONAD_Id, i_PRIMOP1, i_ltChar }
1229 , { "primLeChar", "CC", "B", MONAD_Id, i_PRIMOP1, i_leChar }
1230 , { "primCharToInt", "C", "I", MONAD_Id, i_PRIMOP1, i_charToInt }
1231 , { "primIntToChar", "I", "C", MONAD_Id, i_PRIMOP1, i_intToChar }
1233 /* Int# operations */
1234 , { "primGtInt", "II", "B", MONAD_Id, i_PRIMOP1, i_gtInt }
1235 , { "primGeInt", "II", "B", MONAD_Id, i_PRIMOP1, i_geInt }
1236 , { "primEqInt", "II", "B", MONAD_Id, i_PRIMOP1, i_eqInt }
1237 , { "primNeInt", "II", "B", MONAD_Id, i_PRIMOP1, i_neInt }
1238 , { "primLtInt", "II", "B", MONAD_Id, i_PRIMOP1, i_ltInt }
1239 , { "primLeInt", "II", "B", MONAD_Id, i_PRIMOP1, i_leInt }
1240 , { "primMinInt", "", "I", MONAD_Id, i_PRIMOP1, i_minInt }
1241 , { "primMaxInt", "", "I", MONAD_Id, i_PRIMOP1, i_maxInt }
1242 , { "primPlusInt", "II", "I", MONAD_Id, i_PRIMOP1, i_plusInt }
1243 , { "primMinusInt", "II", "I", MONAD_Id, i_PRIMOP1, i_minusInt }
1244 , { "primTimesInt", "II", "I", MONAD_Id, i_PRIMOP1, i_timesInt }
1245 , { "primQuotInt", "II", "I", MONAD_Id, i_PRIMOP1, i_quotInt }
1246 , { "primRemInt", "II", "I", MONAD_Id, i_PRIMOP1, i_remInt }
1247 , { "primQuotRemInt", "II", "II", MONAD_Id, i_PRIMOP1, i_quotRemInt }
1248 , { "primNegateInt", "I", "I", MONAD_Id, i_PRIMOP1, i_negateInt }
1250 , { "primAndInt", "II", "I", MONAD_Id, i_PRIMOP1, i_andInt }
1251 , { "primOrInt", "II", "I", MONAD_Id, i_PRIMOP1, i_orInt }
1252 , { "primXorInt", "II", "I", MONAD_Id, i_PRIMOP1, i_xorInt }
1253 , { "primNotInt", "I", "I", MONAD_Id, i_PRIMOP1, i_notInt }
1254 , { "primShiftLInt", "II", "I", MONAD_Id, i_PRIMOP1, i_shiftLInt }
1255 , { "primShiftRAInt", "II", "I", MONAD_Id, i_PRIMOP1, i_shiftRAInt }
1256 , { "primShiftRLInt", "II", "I", MONAD_Id, i_PRIMOP1, i_shiftRLInt }
1258 #ifdef PROVIDE_INT64
1259 /* Int64# operations */
1260 , { "primGtInt64", "zz", "B", MONAD_Id, i_PRIMOP1, i_gtInt64 }
1261 , { "primGeInt64", "zz", "B", MONAD_Id, i_PRIMOP1, i_geInt64 }
1262 , { "primEqInt64", "zz", "B", MONAD_Id, i_PRIMOP1, i_eqInt64 }
1263 , { "primNeInt64", "zz", "B", MONAD_Id, i_PRIMOP1, i_neInt64 }
1264 , { "primLtInt64", "zz", "B", MONAD_Id, i_PRIMOP1, i_ltInt64 }
1265 , { "primLeInt64", "zz", "B", MONAD_Id, i_PRIMOP1, i_leInt64 }
1266 , { "primMinInt64", "", "z", MONAD_Id, i_PRIMOP1, i_minInt64 }
1267 , { "primMaxInt64", "", "z", MONAD_Id, i_PRIMOP1, i_maxInt64 }
1268 , { "primPlusInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_plusInt64 }
1269 , { "primMinusInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_minusInt64 }
1270 , { "primTimesInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_timesInt64 }
1271 , { "primQuotInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_quotInt64 }
1272 , { "primRemInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_remInt64 }
1273 , { "primQuotRemInt64", "zz", "zz", MONAD_Id, i_PRIMOP1, i_quotRemInt64 }
1274 , { "primNegateInt64", "z", "z", MONAD_Id, i_PRIMOP1, i_negateInt64 }
1276 , { "primAndInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_andInt64 }
1277 , { "primOrInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_orInt64 }
1278 , { "primXorInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_xorInt64 }
1279 , { "primNotInt64", "z", "z", MONAD_Id, i_PRIMOP1, i_notInt64 }
1280 , { "primShiftLInt64", "zW", "z", MONAD_Id, i_PRIMOP1, i_shiftLInt64 }
1281 , { "primShiftRAInt64", "zW", "z", MONAD_Id, i_PRIMOP1, i_shiftRAInt64 }
1282 , { "primShiftRLInt64", "zW", "z", MONAD_Id, i_PRIMOP1, i_shiftRLInt64 }
1284 , { "primInt64ToInt", "z", "I", MONAD_Id, i_PRIMOP1, i_int64ToInt }
1285 , { "primIntToInt64", "I", "z", MONAD_Id, i_PRIMOP1, i_intToInt64 }
1287 , { "primInt64ToWord", "z", "W", MONAD_Id, i_PRIMOP1, i_int64ToWord }
1288 , { "primWordToInt64", "W", "z", MONAD_Id, i_PRIMOP1, i_wordToInt64 }
1290 , { "primInt64ToFloat", "z", "F", MONAD_Id, i_PRIMOP1, i_int64ToFloat }
1291 , { "primFloatToInt64", "F", "z", MONAD_Id, i_PRIMOP1, i_floatToInt64 }
1292 , { "primInt64ToDouble", "z", "D", MONAD_Id, i_PRIMOP1, i_int64ToDouble }
1293 , { "primDoubleToInt64", "D", "z", MONAD_Id, i_PRIMOP1, i_doubleToInt64 }
1297 /* Word# operations */
1298 , { "primGtWord", "WW", "B", MONAD_Id, i_PRIMOP1, i_gtWord }
1299 , { "primGeWord", "WW", "B", MONAD_Id, i_PRIMOP1, i_geWord }
1300 , { "primEqWord", "WW", "B", MONAD_Id, i_PRIMOP1, i_eqWord }
1301 , { "primNeWord", "WW", "B", MONAD_Id, i_PRIMOP1, i_neWord }
1302 , { "primLtWord", "WW", "B", MONAD_Id, i_PRIMOP1, i_ltWord }
1303 , { "primLeWord", "WW", "B", MONAD_Id, i_PRIMOP1, i_leWord }
1304 , { "primMinWord", "", "W", MONAD_Id, i_PRIMOP1, i_minWord }
1305 , { "primMaxWord", "", "W", MONAD_Id, i_PRIMOP1, i_maxWord }
1306 , { "primPlusWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_plusWord }
1307 , { "primMinusWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_minusWord }
1308 , { "primTimesWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_timesWord }
1309 , { "primQuotWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_quotWord }
1310 , { "primRemWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_remWord }
1311 , { "primQuotRemWord", "WW", "WW", MONAD_Id, i_PRIMOP1, i_quotRemWord }
1312 , { "primNegateWord", "W", "W", MONAD_Id, i_PRIMOP1, i_negateWord }
1314 , { "primAndWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_andWord }
1315 , { "primOrWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_orWord }
1316 , { "primXorWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_xorWord }
1317 , { "primNotWord", "W", "W", MONAD_Id, i_PRIMOP1, i_notWord }
1318 , { "primShiftLWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_shiftLWord }
1319 , { "primShiftRAWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_shiftRAWord }
1320 , { "primShiftRLWord", "WW", "W", MONAD_Id, i_PRIMOP1, i_shiftRLWord }
1322 , { "primIntToWord", "I", "W", MONAD_Id, i_PRIMOP1, i_intToWord }
1323 , { "primWordToInt", "W", "I", MONAD_Id, i_PRIMOP1, i_wordToInt }
1327 /* Addr# operations */
1328 , { "primGtAddr", "AA", "B", MONAD_Id, i_PRIMOP1, i_gtAddr }
1329 , { "primGeAddr", "AA", "B", MONAD_Id, i_PRIMOP1, i_geAddr }
1330 , { "primEqAddr", "AA", "B", MONAD_Id, i_PRIMOP1, i_eqAddr }
1331 , { "primNeAddr", "AA", "B", MONAD_Id, i_PRIMOP1, i_neAddr }
1332 , { "primLtAddr", "AA", "B", MONAD_Id, i_PRIMOP1, i_ltAddr }
1333 , { "primLeAddr", "AA", "B", MONAD_Id, i_PRIMOP1, i_leAddr }
1334 , { "primIntToAddr", "I", "A", MONAD_Id, i_PRIMOP1, i_intToAddr }
1335 , { "primAddrToInt", "A", "I", MONAD_Id, i_PRIMOP1, i_addrToInt }
1337 , { "primIndexCharOffAddr", "AI", "C", MONAD_Id, i_PRIMOP1, i_indexCharOffAddr }
1338 , { "primIndexIntOffAddr", "AI", "I", MONAD_Id, i_PRIMOP1, i_indexIntOffAddr }
1339 #ifdef PROVIDE_INT64
1340 , { "primIndexInt64OffAddr", "AI", "z", MONAD_Id, i_PRIMOP1, i_indexInt64OffAddr }
1343 , { "primIndexWordOffAddr", "AI", "W", MONAD_Id, i_PRIMOP1, i_indexWordOffAddr }
1345 , { "primIndexAddrOffAddr", "AI", "A", MONAD_Id, i_PRIMOP1, i_indexAddrOffAddr }
1346 , { "primIndexFloatOffAddr", "AI", "F", MONAD_Id, i_PRIMOP1, i_indexFloatOffAddr }
1347 , { "primIndexDoubleOffAddr", "AI", "D", MONAD_Id, i_PRIMOP1, i_indexDoubleOffAddr }
1348 #ifdef PROVIDE_STABLE
1349 , { "primIndexStableOffAddr", "AI", "s", MONAD_Id, i_PRIMOP1, i_indexStableOffAddr }
1352 /* These ops really ought to be in the IO monad */
1353 , { "primReadCharOffAddr", "AI", "C", MONAD_ST, i_PRIMOP1, i_readCharOffAddr }
1354 , { "primReadIntOffAddr", "AI", "I", MONAD_ST, i_PRIMOP1, i_readIntOffAddr }
1355 #ifdef PROVIDE_INT64
1356 , { "primReadInt64OffAddr", "AI", "z", MONAD_ST, i_PRIMOP1, i_readInt64OffAddr }
1359 , { "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 #ifdef PROVIDE_STABLE
1365 , { "primReadStableOffAddr", "AI", "s", MONAD_ST, i_PRIMOP1, i_readStableOffAddr }
1368 /* These ops really ought to be in the IO monad */
1369 , { "primWriteCharOffAddr", "AIC", "", MONAD_ST, i_PRIMOP1, i_writeCharOffAddr }
1370 , { "primWriteIntOffAddr", "AII", "", MONAD_ST, i_PRIMOP1, i_writeIntOffAddr }
1371 #ifdef PROVIDE_INT64
1372 , { "primWriteInt64OffAddr", "AIz", "", MONAD_ST, i_PRIMOP1, i_writeInt64OffAddr }
1375 , { "primWriteWordOffAddr", "AIW", "", MONAD_ST, i_PRIMOP1, i_writeWordOffAddr }
1377 , { "primWriteAddrOffAddr", "AIA", "", MONAD_ST, i_PRIMOP1, i_writeAddrOffAddr }
1378 , { "primWriteFloatOffAddr", "AIF", "", MONAD_ST, i_PRIMOP1, i_writeFloatOffAddr }
1379 , { "primWriteDoubleOffAddr", "AID", "", MONAD_ST, i_PRIMOP1, i_writeDoubleOffAddr }
1380 #ifdef PROVIDE_STABLE
1381 , { "primWriteStableOffAddr", "AIs", "", MONAD_ST, i_PRIMOP1, i_writeStableOffAddr }
1384 #endif /* PROVIDE_ADDR */
1386 #ifdef PROVIDE_INTEGER
1387 /* Integer operations */
1388 , { "primCompareInteger", "ZZ", "I", MONAD_Id, i_PRIMOP1, i_compareInteger }
1389 , { "primNegateInteger", "Z", "Z", MONAD_Id, i_PRIMOP1, i_negateInteger }
1390 , { "primPlusInteger", "ZZ", "Z", MONAD_Id, i_PRIMOP1, i_plusInteger }
1391 , { "primMinusInteger", "ZZ", "Z", MONAD_Id, i_PRIMOP1, i_minusInteger }
1392 , { "primTimesInteger", "ZZ", "Z", MONAD_Id, i_PRIMOP1, i_timesInteger }
1393 , { "primQuotRemInteger", "ZZ", "ZZ", MONAD_Id, i_PRIMOP1, i_quotRemInteger }
1394 , { "primDivModInteger", "ZZ", "ZZ", MONAD_Id, i_PRIMOP1, i_divModInteger }
1395 , { "primIntegerToInt", "Z", "I", MONAD_Id, i_PRIMOP1, i_integerToInt }
1396 , { "primIntToInteger", "I", "Z", MONAD_Id, i_PRIMOP1, i_intToInteger }
1397 #ifdef PROVIDE_INT64
1398 , { "primIntegerToInt64", "Z", "z", MONAD_Id, i_PRIMOP1, i_integerToInt64 }
1399 , { "primInt64ToInteger", "z", "Z", MONAD_Id, i_PRIMOP1, i_int64ToInteger }
1402 , { "primIntegerToWord", "Z", "W", MONAD_Id, i_PRIMOP1, i_integerToWord }
1403 , { "primWordToInteger", "W", "Z", MONAD_Id, i_PRIMOP1, i_wordToInteger }
1405 , { "primIntegerToFloat", "Z", "F", MONAD_Id, i_PRIMOP1, i_integerToFloat }
1406 , { "primFloatToInteger", "F", "Z", MONAD_Id, i_PRIMOP1, i_floatToInteger }
1407 , { "primIntegerToDouble", "Z", "D", MONAD_Id, i_PRIMOP1, i_integerToDouble }
1408 , { "primDoubleToInteger", "D", "Z", MONAD_Id, i_PRIMOP1, i_doubleToInteger }
1411 /* Float# operations */
1412 , { "primGtFloat", "FF", "B", MONAD_Id, i_PRIMOP1, i_gtFloat }
1413 , { "primGeFloat", "FF", "B", MONAD_Id, i_PRIMOP1, i_geFloat }
1414 , { "primEqFloat", "FF", "B", MONAD_Id, i_PRIMOP1, i_eqFloat }
1415 , { "primNeFloat", "FF", "B", MONAD_Id, i_PRIMOP1, i_neFloat }
1416 , { "primLtFloat", "FF", "B", MONAD_Id, i_PRIMOP1, i_ltFloat }
1417 , { "primLeFloat", "FF", "B", MONAD_Id, i_PRIMOP1, i_leFloat }
1418 , { "primMinFloat", "", "F", MONAD_Id, i_PRIMOP1, i_minFloat }
1419 , { "primMaxFloat", "", "F", MONAD_Id, i_PRIMOP1, i_maxFloat }
1420 , { "primRadixFloat", "", "I", MONAD_Id, i_PRIMOP1, i_radixFloat }
1421 , { "primDigitsFloat", "", "I", MONAD_Id, i_PRIMOP1, i_digitsFloat }
1422 , { "primMinExpFloat", "", "I", MONAD_Id, i_PRIMOP1, i_minExpFloat }
1423 , { "primMaxExpFloat", "", "I", MONAD_Id, i_PRIMOP1, i_maxExpFloat }
1424 , { "primPlusFloat", "FF", "F", MONAD_Id, i_PRIMOP1, i_plusFloat }
1425 , { "primMinusFloat", "FF", "F", MONAD_Id, i_PRIMOP1, i_minusFloat }
1426 , { "primTimesFloat", "FF", "F", MONAD_Id, i_PRIMOP1, i_timesFloat }
1427 , { "primDivideFloat", "FF", "F", MONAD_Id, i_PRIMOP1, i_divideFloat }
1428 , { "primNegateFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_negateFloat }
1429 , { "primFloatToInt", "F", "I", MONAD_Id, i_PRIMOP1, i_floatToInt }
1430 , { "primIntToFloat", "I", "F", MONAD_Id, i_PRIMOP1, i_intToFloat }
1431 , { "primExpFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_expFloat }
1432 , { "primLogFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_logFloat }
1433 , { "primSqrtFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_sqrtFloat }
1434 , { "primSinFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_sinFloat }
1435 , { "primCosFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_cosFloat }
1436 , { "primTanFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_tanFloat }
1437 , { "primAsinFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_asinFloat }
1438 , { "primAcosFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_acosFloat }
1439 , { "primAtanFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_atanFloat }
1440 , { "primSinhFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_sinhFloat }
1441 , { "primCoshFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_coshFloat }
1442 , { "primTanhFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_tanhFloat }
1443 , { "primPowerFloat", "FF", "F", MONAD_Id, i_PRIMOP1, i_powerFloat }
1444 #ifdef PROVIDE_INT64
1445 , { "primDecodeFloatz", "F", "zI", MONAD_Id, i_PRIMOP1, i_decodeFloatz }
1446 , { "primEncodeFloatz", "zI", "F", MONAD_Id, i_PRIMOP1, i_encodeFloatz }
1448 #ifdef PROVIDE_INTEGER
1449 , { "primDecodeFloatZ", "F", "ZI", MONAD_Id, i_PRIMOP1, i_decodeFloatZ }
1450 , { "primEncodeFloatZ", "ZI", "F", MONAD_Id, i_PRIMOP1, i_encodeFloatZ }
1452 , { "primIsNaNFloat", "F", "B", MONAD_Id, i_PRIMOP1, i_isNaNFloat }
1453 , { "primIsInfiniteFloat", "F", "B", MONAD_Id, i_PRIMOP1, i_isInfiniteFloat }
1454 , { "primIsDenormalizedFloat", "F", "B", MONAD_Id, i_PRIMOP1, i_isDenormalizedFloat }
1455 , { "primIsNegativeZeroFloat", "F", "B", MONAD_Id, i_PRIMOP1, i_isNegativeZeroFloat }
1456 , { "primIsIEEEFloat", "", "B", MONAD_Id, i_PRIMOP1, i_isIEEEFloat }
1458 /* Double# operations */
1459 , { "primGtDouble", "DD", "B", MONAD_Id, i_PRIMOP1, i_gtDouble }
1460 , { "primGeDouble", "DD", "B", MONAD_Id, i_PRIMOP1, i_geDouble }
1461 , { "primEqDouble", "DD", "B", MONAD_Id, i_PRIMOP1, i_eqDouble }
1462 , { "primNeDouble", "DD", "B", MONAD_Id, i_PRIMOP1, i_neDouble }
1463 , { "primLtDouble", "DD", "B", MONAD_Id, i_PRIMOP1, i_ltDouble }
1464 , { "primLeDouble", "DD", "B", MONAD_Id, i_PRIMOP1, i_leDouble }
1465 , { "primMinDouble", "", "D", MONAD_Id, i_PRIMOP1, i_minDouble }
1466 , { "primMaxDouble", "", "D", MONAD_Id, i_PRIMOP1, i_maxDouble }
1467 , { "primRadixDouble", "", "I", MONAD_Id, i_PRIMOP1, i_radixDouble }
1468 , { "primDigitsDouble", "", "I", MONAD_Id, i_PRIMOP1, i_digitsDouble }
1469 , { "primMinExpDouble", "", "I", MONAD_Id, i_PRIMOP1, i_minExpDouble }
1470 , { "primMaxExpDouble", "", "I", MONAD_Id, i_PRIMOP1, i_maxExpDouble }
1471 , { "primPlusDouble", "DD", "D", MONAD_Id, i_PRIMOP1, i_plusDouble }
1472 , { "primMinusDouble", "DD", "D", MONAD_Id, i_PRIMOP1, i_minusDouble }
1473 , { "primTimesDouble", "DD", "D", MONAD_Id, i_PRIMOP1, i_timesDouble }
1474 , { "primDivideDouble", "DD", "D", MONAD_Id, i_PRIMOP1, i_divideDouble }
1475 , { "primNegateDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_negateDouble }
1476 , { "primDoubleToInt", "D", "I", MONAD_Id, i_PRIMOP1, i_doubleToInt }
1477 , { "primIntToDouble", "I", "D", MONAD_Id, i_PRIMOP1, i_intToDouble }
1478 , { "primDoubleToFloat", "D", "F", MONAD_Id, i_PRIMOP1, i_doubleToFloat }
1479 , { "primFloatToDouble", "F", "D", MONAD_Id, i_PRIMOP1, i_floatToDouble }
1480 , { "primExpDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_expDouble }
1481 , { "primLogDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_logDouble }
1482 , { "primSqrtDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_sqrtDouble }
1483 , { "primSinDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_sinDouble }
1484 , { "primCosDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_cosDouble }
1485 , { "primTanDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_tanDouble }
1486 , { "primAsinDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_asinDouble }
1487 , { "primAcosDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_acosDouble }
1488 , { "primAtanDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_atanDouble }
1489 , { "primSinhDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_sinhDouble }
1490 , { "primCoshDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_coshDouble }
1491 , { "primTanhDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_tanhDouble }
1492 , { "primPowerDouble", "DD", "D", MONAD_Id, i_PRIMOP1, i_powerDouble }
1493 #ifdef PROVIDE_INT64
1494 , { "primDecodeDoublez", "D", "zI", MONAD_Id, i_PRIMOP1, i_decodeDoublez }
1495 , { "primEncodeDoublez", "zI", "D", MONAD_Id, i_PRIMOP1, i_encodeDoublez }
1497 #ifdef PROVIDE_INTEGER
1498 , { "primDecodeDoubleZ", "D", "ZI", MONAD_Id, i_PRIMOP1, i_decodeDoubleZ }
1499 , { "primEncodeDoubleZ", "ZI", "D", MONAD_Id, i_PRIMOP1, i_encodeDoubleZ }
1501 , { "primIsNaNDouble", "D", "B", MONAD_Id, i_PRIMOP1, i_isNaNDouble }
1502 , { "primIsInfiniteDouble", "D", "B", MONAD_Id, i_PRIMOP1, i_isInfiniteDouble }
1503 , { "primIsDenormalizedDouble", "D", "B", MONAD_Id, i_PRIMOP1, i_isDenormalizedDouble }
1504 , { "primIsNegativeZeroDouble", "D", "B", MONAD_Id, i_PRIMOP1, i_isNegativeZeroDouble }
1505 , { "primIsIEEEDouble", "", "B", MONAD_Id, i_PRIMOP1, i_isIEEEDouble }
1508 /* Polymorphic force :: a -> (# #) */
1509 /* , { "primForce", "a", "", MONAD_Id, i_PRIMOP2, i_force } */
1511 /* Error operations - not in IO monad! */
1512 //, { "primRaise", "E", "a", MONAD_Id, i_PRIMOP2, i_raise }
1513 //, { "primCatch'", "aH", "a", MONAD_Id, i_PRIMOP2, i_catch }
1515 #ifdef PROVIDE_ARRAY
1516 /* Ref operations */
1517 , { "primNewRef", "a", "R", MONAD_ST, i_PRIMOP2, i_newRef }
1518 , { "primWriteRef", "Ra", "", MONAD_ST, i_PRIMOP2, i_writeRef }
1519 , { "primReadRef", "R", "a", MONAD_ST, i_PRIMOP2, i_readRef }
1520 , { "primSameRef", "RR", "B", MONAD_Id, i_PRIMOP2, i_sameRef }
1522 /* PrimArray operations */
1523 , { "primSameMutableArray", "MM", "B", MONAD_Id, i_PRIMOP2, i_sameMutableArray }
1524 , { "primUnsafeFreezeArray", "M", "X", MONAD_ST, i_PRIMOP2, i_unsafeFreezeArray }
1525 , { "primNewArray", "Ia", "M", MONAD_ST, i_PRIMOP2, i_newArray }
1526 , { "primWriteArray", "MIa", "", MONAD_ST, i_PRIMOP2, i_writeArray }
1527 , { "primReadArray", "MI", "a", MONAD_ST, i_PRIMOP2, i_readArray }
1528 , { "primIndexArray", "XI", "a", MONAD_Id, i_PRIMOP2, i_indexArray }
1529 , { "primSizeArray", "X", "I", MONAD_Id, i_PRIMOP2, i_sizeArray }
1530 , { "primSizeMutableArray", "M", "I", MONAD_Id, i_PRIMOP2, i_sizeMutableArray }
1532 /* Prim[Mutable]ByteArray operations */
1533 , { "primSameMutableByteArray", "mm", "B", MONAD_Id, i_PRIMOP2, i_sameMutableByteArray }
1534 , { "primUnsafeFreezeByteArray", "m", "x", MONAD_ST, i_PRIMOP2, i_unsafeFreezeByteArray }
1536 , { "primNewByteArray", "I", "m", MONAD_ST, i_PRIMOP2, i_newByteArray }
1538 , { "primWriteCharArray", "mIC", "", MONAD_ST, i_PRIMOP2, i_writeCharArray }
1539 , { "primReadCharArray", "mI", "C", MONAD_ST, i_PRIMOP2, i_readCharArray }
1540 , { "primIndexCharArray", "xI", "C", MONAD_Id, i_PRIMOP2, i_indexCharArray }
1542 , { "primWriteIntArray", "mII", "", MONAD_ST, i_PRIMOP2, i_writeIntArray }
1543 , { "primReadIntArray", "mI", "I", MONAD_ST, i_PRIMOP2, i_readIntArray }
1544 , { "primIndexIntArray", "xI", "I", MONAD_Id, i_PRIMOP2, i_indexIntArray }
1546 #ifdef PROVIDE_INT64
1547 , { "primWriteInt64Array", "mIz", "", MONAD_ST, i_PRIMOP2, i_writeInt64Array }
1548 , { "primReadInt64Array", "mI", "z", MONAD_ST, i_PRIMOP2, i_readInt64Array }
1549 , { "primIndexInt64Array", "xI", "z", MONAD_Id, i_PRIMOP2, i_indexInt64Array }
1552 /* {new,write,read,index}IntegerArray not provided */
1555 , { "primWriteWordArray", "mIW", "", MONAD_ST, i_PRIMOP2, i_writeWordArray }
1556 , { "primReadWordArray", "mI", "W", MONAD_ST, i_PRIMOP2, i_readWordArray }
1557 , { "primIndexWordArray", "xI", "W", MONAD_Id, i_PRIMOP2, i_indexWordArray }
1560 , { "primWriteAddrArray", "mIA", "", MONAD_ST, i_PRIMOP2, i_writeAddrArray }
1561 , { "primReadAddrArray", "mI", "A", MONAD_ST, i_PRIMOP2, i_readAddrArray }
1562 , { "primIndexAddrArray", "xI", "A", MONAD_Id, i_PRIMOP2, i_indexAddrArray }
1564 , { "primWriteFloatArray", "mIF", "", MONAD_ST, i_PRIMOP2, i_writeFloatArray }
1565 , { "primReadFloatArray", "mI", "F", MONAD_ST, i_PRIMOP2, i_readFloatArray }
1566 , { "primIndexFloatArray", "xI", "F", MONAD_Id, i_PRIMOP2, i_indexFloatArray }
1568 , { "primWriteDoubleArray" , "mID", "", MONAD_ST, i_PRIMOP2, i_writeDoubleArray }
1569 , { "primReadDoubleArray", "mI", "D", MONAD_ST, i_PRIMOP2, i_readDoubleArray }
1570 , { "primIndexDoubleArray", "xI", "D", MONAD_Id, i_PRIMOP2, i_indexDoubleArray }
1572 #ifdef PROVIDE_STABLE
1573 , { "primWriteStableArray", "mIs", "", MONAD_ST, i_PRIMOP2, i_writeStableArray }
1574 , { "primReadStableArray", "mI", "s", MONAD_ST, i_PRIMOP2, i_readStableArray }
1575 , { "primIndexStableArray", "xI", "s", MONAD_Id, i_PRIMOP2, i_indexStableArray }
1578 /* {new,write,read,index}ForeignObjArray not provided */
1580 #endif PROVIDE_ARRAY
1582 #ifdef PROVIDE_FOREIGN
1583 /* ForeignObj# operations */
1584 , { "primMakeForeignObj", "A", "f", MONAD_IO, i_PRIMOP2, i_makeForeignObj }
1587 /* WeakPair# operations */
1588 , { "primMakeWeak", "bac", "w", MONAD_IO, i_PRIMOP2, i_makeWeak }
1589 , { "primDeRefWeak", "w", "Ia", MONAD_IO, i_PRIMOP2, i_deRefWeak }
1591 #ifdef PROVIDE_STABLE
1592 /* StablePtr# operations */
1593 , { "primMakeStablePtr", "a", "s", MONAD_IO, i_PRIMOP2, i_makeStablePtr }
1594 , { "primDeRefStablePtr", "s", "a", MONAD_IO, i_PRIMOP2, i_deRefStablePtr }
1595 , { "primFreeStablePtr", "s", "", MONAD_IO, i_PRIMOP2, i_freeStablePtr }
1597 #ifdef PROVIDE_PTREQUALITY
1598 , { "primReallyUnsafePtrEquality", "aa", "B",MONAD_Id, i_PRIMOP2, i_reallyUnsafePtrEquality }
1600 #ifdef PROVIDE_COERCE
1601 , { "primUnsafeCoerce", "a", "b", MONAD_Id, i_PRIMOP2, i_unsafeCoerce }
1603 #ifdef PROVIDE_CONCURRENT
1604 /* Concurrency operations */
1605 , { "primFork", "a", "T", MONAD_IO, i_PRIMOP2, i_fork }
1606 , { "primKillThread", "T", "", MONAD_IO, i_PRIMOP2, i_killThread }
1607 , { "primSameMVar", "rr", "B", MONAD_Id, i_PRIMOP2, i_sameMVar }
1608 , { "primNewMVar", "", "r", MONAD_IO, i_PRIMOP2, i_newMVar }
1609 , { "primTakeMVar", "r", "a", MONAD_IO, i_PRIMOP2, i_takeMVar }
1610 , { "primPutMVar", "ra", "", MONAD_IO, i_PRIMOP2, i_putMVar }
1611 , { "primDelay", "I", "", MONAD_IO, i_PRIMOP2, i_delay }
1612 , { "primWaitRead", "I", "", MONAD_IO, i_PRIMOP2, i_waitRead }
1613 , { "primWaitWrite", "I", "", MONAD_IO, i_PRIMOP2, i_waitWrite }
1616 /* Ccall is polyadic - so it's excluded from this table */
1621 const AsmPrim ccall_Id = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_Id };
1622 const AsmPrim ccall_IO = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_IO };
1625 const AsmPrim* asmFindPrim( char* s )
1628 for (i=0; asmPrimOps[i].name; ++i) {
1629 if (strcmp(s,asmPrimOps[i].name)==0) {
1630 return &asmPrimOps[i];
1636 const AsmPrim* asmFindPrimop( AsmInstr prefix, AsmInstr op )
1639 for (i=0; asmPrimOps[i].name; ++i) {
1640 if (asmPrimOps[i].prefix == prefix && asmPrimOps[i].opcode == op) {
1641 return &asmPrimOps[i];
1647 /* --------------------------------------------------------------------------
1648 * Handwritten primops
1649 * ------------------------------------------------------------------------*/
1651 AsmBCO asm_BCO_catch ( void )
1653 AsmBCO bco = asmBeginBCO(0 /*NIL*/);
1654 emit_i1(bco,i_ARG_CHECK,2);
1655 emit_i1(bco,i_PRIMOP1,i_pushcatchframe);
1656 bco->sp += (1-2)*sizeofW(StgPtr) + sizeofW(StgCatchFrame);
1657 emit_i0(bco,i_ENTER);
1662 AsmBCO asm_BCO_raise ( void )
1664 AsmBCO bco = asmBeginBCO(0 /*NIL*/);
1665 emit_i1(bco,i_ARG_CHECK,1);
1666 emit_i1(bco,i_PRIMOP2,i_raise);
1671 AsmBCO asm_BCO_seq ( void )
1675 cont = asmBeginBCO(0 /*NIL*/);
1676 emit_i1(cont,i_ARG_CHECK,2);
1678 emit_i_SLIDE(cont,1,2);
1679 emit_i0(cont,i_ENTER);
1680 cont->sp += 3*sizeofW(StgPtr);
1683 eval = asmBeginBCO(0 /*NIL*/);
1684 emit_i1(eval,i_ARG_CHECK,2);
1685 emit_i_RETADDR(eval,eval->object.ptrs.len);
1686 asmPtr(eval,&(cont->object));
1688 emit_i_SLIDE(eval,3,1);
1689 emit_i1(eval,i_PRIMOP1,i_pushseqframe);
1690 emit_i0(eval,i_ENTER);
1691 eval->sp += sizeofW(StgSeqFrame) + 4*sizeofW(StgPtr);
1697 /* --------------------------------------------------------------------------
1699 * ------------------------------------------------------------------------*/
1701 AsmVar asmAllocCONSTR ( AsmBCO bco, AsmInfo info )
1703 ASSERT( sizeW_fromITBL(info) >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1704 emit_i1(bco,i_ALLOC_CONSTR,bco->nps.len);
1705 asmWords(bco,AsmInfo,info);
1706 bco->sp += sizeofW(StgClosurePtr);
1707 grabHpNonUpd(bco,sizeW_fromITBL(info));
1711 AsmSp asmBeginPack( AsmBCO bco )
1716 void asmEndPack( AsmBCO bco, AsmVar v, AsmSp start, AsmInfo info )
1718 nat size = bco->sp - start;
1719 assert(bco->sp >= start);
1721 /* only reason to include info is for this assertion */
1722 assert(info->layout.payload.ptrs == size);
1723 emit_i1(bco,i_PACK,bco->sp - v);
1727 void asmBeginUnpack( AsmBCO bco )
1729 /* dummy to make it look prettier */
1732 void asmEndUnpack( AsmBCO bco )
1734 emit_i0(bco,i_UNPACK);
1737 AsmVar asmAllocAP( AsmBCO bco, AsmNat words )
1739 emit_i1(bco,i_ALLOC_AP,words);
1740 bco->sp += sizeofW(StgPtr);
1741 grabHpUpd(bco,AP_sizeW(words));
1745 AsmSp asmBeginMkAP( AsmBCO bco )
1750 void asmEndMkAP( AsmBCO bco, AsmVar v, AsmSp start )
1752 emit_i_MKAP(bco,bco->sp-v,bco->sp-start-1);
1753 /* -1 because fun isn't counted */
1757 AsmVar asmAllocPAP( AsmBCO bco, AsmNat size )
1759 emit_i1(bco,i_ALLOC_PAP,size);
1760 bco->sp += sizeofW(StgPtr);
1764 AsmSp asmBeginMkPAP( AsmBCO bco )
1769 void asmEndMkPAP( AsmBCO bco, AsmVar v, AsmSp start )
1771 emit_i2(bco,i_MKPAP,bco->sp-v,bco->sp-start-1);
1772 /* -1 because fun isn't counted */
1776 AsmVar asmClosure( AsmBCO bco, AsmObject p )
1778 emit_i_CONST(bco,bco->object.ptrs.len);
1780 bco->sp += sizeofW(StgPtr);
1784 /* --------------------------------------------------------------------------
1785 * Building InfoTables
1786 * ------------------------------------------------------------------------*/
1788 AsmInfo asmMkInfo( AsmNat tag, AsmNat ptrs )
1790 StgInfoTable* info = stgMallocBytes( sizeof(StgInfoTable),"asmMkInfo");
1791 /* Note: the evaluator automatically pads objects with the right number
1792 * of non-ptrs to satisfy MIN_NONUPD_SIZE restrictions.
1794 AsmNat nptrs = stg_max(0,MIN_NONUPD_SIZE-ptrs);
1796 /* initialisation code based on INFO_TABLE_CONSTR */
1797 info->layout.payload.ptrs = ptrs;
1798 info->layout.payload.nptrs = nptrs;
1799 info->srt_len = tag;
1800 info->type = CONSTR;
1801 info->flags = FLAGS_CONSTR;
1802 #ifdef USE_MINIINTERPRETER
1803 info->entry = stgCast(StgFunPtr,&Hugs_CONSTR_entry);
1805 #warning asmMkInfo: Need to insert entry code in some cunning way
1807 ASSERT( sizeW_fromITBL(info) >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
1811 /*-------------------------------------------------------------------------*/
1813 #endif /* INTERPRETER */