* Copyright (c) 1994-1998.
*
* $RCSfile: Assembler.c,v $
- * $Revision: 1.18 $
- * $Date: 1999/11/19 15:42:12 $
+ * $Revision: 1.33 $
+ * $Date: 2000/10/09 11:18:46 $
*
* This module provides functions to construct BCOs and other closures
* required by the bytecode compiler.
#include "Assembler.h"
#undef INSIDE_ASSEMBLER_C
-/* --------------------------------------------------------------------------
- * References between BCOs
- *
- * These are necessary because there can be circular references between
- * BCOs so we have to keep track of all the references to each object
- * and fill in all the references once we're done.
- *
- * ToDo: generalise to allow references between any objects
- * ------------------------------------------------------------------------*/
-
-typedef struct {
- AsmObject ref; /* who refers to it */
- AsmNat i; /* index into some table held by referer */
-} AsmRef;
+static StgClosure* asmAlloc ( nat size );
+extern void* getNameOrTupleClosureCPtr ( int /*Cell*/ c );
-/* --------------------------------------------------------------------------
- * Queues (of instructions, ptrs, nonptrs)
- * ------------------------------------------------------------------------*/
-#define Queue Instrs
-#define Type StgWord8
-#include "QueueTemplate.h"
-#undef Type
-#undef Queue
-
-#define Queue Ptrs
-#define Type AsmObject
-#include "QueueTemplate.h"
-#undef Type
-#undef Queue
-
-#define Queue Refs
-#define Type AsmRef
-#include "QueueTemplate.h"
-#undef Type
-#undef Queue
-
-#define Queue NonPtrs
-#define Type StgWord
-#include "QueueTemplate.h"
-#undef Type
-#undef Queue
+/* Defined in this file ... */
+AsmObject asmNewObject ( void );
+void asmAddEntity ( AsmObject, Asm_Kind, StgWord );
+int asmCalcHeapSizeW ( AsmObject );
+StgClosure* asmDerefEntity ( Asm_Entity );
/* --------------------------------------------------------------------------
- * AsmObjects are used to build heap objects.
- *
- * AsmObjects can contain circular references to each other
- * so we have to keep track of all the references which can't be filled
- * in yet.
- *
- * When we finish building an AsmObject, we allocate an actual heap object and
- * fill in all the references to the asmObject with pointers to the heap object.
- *
- * We obtain a limited form of polymorphism through inheritance by putting
- * the AsmObject first in every structure (as in C++ implementations).
- * We use the closure type of the allocated object to figure out
- * where the payload lives in the closure.
+ * Initialising and managing objects and entities
* ------------------------------------------------------------------------*/
-/* ToDo: clean up terminology: is Closure right or should it be object or ... */
-struct AsmObject_ {
- Refs refs;
- Ptrs ptrs;
- AsmNat num_unresolved; /* number of unfilled references */
- StgClosure* closure; /* where object was allocated */
-};
-
-struct AsmCon_ {
- struct AsmObject_ object; /* must be first in struct */
-
- AsmInfo info;
-};
-
-struct AsmCAF_ {
- struct AsmObject_ object; /* must be first in struct */
-};
-
-struct AsmBCO_ {
- struct AsmObject_ object; /* must be first in struct */
+static struct AsmObject_* objects;
+
+#define INITIALISE_TABLE(Type,table,size,used) \
+ size = used = 0; \
+ table = NULL;
+
+#define ENSURE_SPACE_IN_TABLE(Type,table,size,used) \
+ if (used == size) { \
+ Type* new; \
+ size = (size ? 2*size : 1); \
+ new = malloc ( size * sizeof(Type)); \
+ if (!new) \
+ barf("bytecode assembler: can't expand table of type " \
+ #Type); \
+ memcpy ( new, table, used * sizeof(Type) ); \
+ if (table) free(table); \
+ table = new; \
+ }
- Instrs is;
- NonPtrs nps;
+void asmInitialise ( void )
+{
+ objects = NULL;
+}
+
+
+AsmObject asmNewObject ( void )
+{
+ AsmObject obj = malloc(sizeof(struct AsmObject_));
+ if (!obj)
+ barf("bytecode assembler: can't malloc in asmNewObject");
+ obj->next = objects;
+ objects = obj;
+ obj->n_refs = obj->n_words = obj->n_insns = 0;
+ obj->closure = NULL;
+ obj->stgexpr = 0; /*NIL*/
+ obj->magic = 0x31415927;
+ INITIALISE_TABLE(AsmEntity,obj->entities,
+ obj->sizeEntities,
+ obj->usedEntities);
+ return obj;
+}
+
+
+void asmAddEntity ( AsmObject obj,
+ Asm_Kind kind,
+ StgWord val )
+{
+ ENSURE_SPACE_IN_TABLE(
+ Asm_Entity,obj->entities,
+ obj->sizeEntities,obj->usedEntities);
+ obj->entities[obj->usedEntities].kind = kind;
+ obj->entities[obj->usedEntities].val = val;
+ obj->usedEntities++;
+ switch (kind) {
+ case Asm_RefNoOp: case Asm_RefObject: case Asm_RefHugs:
+ obj->n_refs++; break;
+ case Asm_NonPtrWord:
+ obj->n_words++; break;
+ case Asm_Insn8:
+ obj->n_insns++; break;
+ default:
+ barf("asmAddEntity");
+ }
+}
- int /*StgExpr*/ stgexpr;
+/* Support for the peephole optimiser. Find the instruction
+ byte n back, carefully stepping over any non Asm_Insn8 entities
+ on the way.
+*/
+static Instr asmInstrBack ( AsmBCO bco, StgInt n )
+{
+ StgInt ue = bco->usedEntities;
+ while (1) {
+ if (ue < 0 || n <= 0) barf("asmInstrBack");
+ ue--;
+ if (bco->entities[ue].kind != Asm_Insn8) continue;
+ n--;
+ if (n == 0) return bco->entities[ue].val;
+ }
+}
- /* abstract machine ("executed" during compilation) */
- AsmSp sp; /* stack ptr */
- AsmSp max_sp;
- StgWord hp; /* heap ptr */
- StgWord max_hp;
- Instr lastOpc;
-};
-static void asmResolveRef( AsmObject obj, AsmNat i, AsmClosure reference )
+/* Throw away n Asm_Insn8 bytes, and slide backwards any Asm_Insn8 entities
+ as necessary.
+*/
+static void asmInstrRecede ( AsmBCO bco, StgInt n )
{
- ASSERT(obj->closure);
- switch (get_itbl(obj->closure)->type) {
- case BCO:
- {
- StgBCO* bco = stgCast(StgBCO*,obj->closure);
- ASSERT(i < bco->n_ptrs && bcoConstPtr(bco,i) == NULL);
- bcoConstCPtr(bco,i) = reference;
- break;
- }
- case CAF_UNENTERED:
- {
- StgCAF* caf = stgCast(StgCAF*,obj->closure);
- ASSERT(i == 0 && caf->body == NULL);
- caf->body = reference;
- break;
- }
- case CONSTR:
- {
- StgClosure* con = stgCast(StgClosure*,obj->closure);
- ASSERT(i < get_itbl(con)->layout.payload.nptrs && payloadCPtr(con,i) == NULL);
- payloadCPtr(con,i) = reference;
- break;
- }
- case AP_UPD:
- {
- StgAP_UPD* ap = stgCast(StgAP_UPD*,obj->closure);
- ASSERT(i < 1+ap->n_args);
- if (i==0) {
- ASSERT(ap->fun == NULL);
- ap->fun = reference;
- } else {
- ASSERT(payloadCPtr(ap,i-1) == NULL);
- payloadCPtr(ap,i-1) = reference;
- }
- break;
- }
- default:
- barf("asmResolveRef");
- }
- obj->num_unresolved -= 1;
+ StgInt ue = bco->usedEntities;
+ StgInt wr;
+ while (1) {
+ if (ue < 0 || n <= 0) barf("asmInstrRecede");
+ ue--;
+ if (bco->entities[ue].kind != Asm_Insn8) continue;
+ n--;
+ bco->n_insns--;
+ if (n == 0) break;
+ }
+ /* Now ue is the place where we would recede usedEntities to,
+ except that there may be stuff to slide downwards.
+ */
+ wr = ue;
+ for (; ue < bco->usedEntities; ue++) {
+ if (bco->entities[ue].kind != Asm_Insn8) {
+ bco->entities[wr] = bco->entities[ue];
+ wr++;
+ }
+ }
+ bco->usedEntities = wr;
}
-static void asmAddRef( AsmObject referent, AsmObject referer, AsmNat i )
+
+static int asmFindInNonPtrs ( AsmBCO bco, StgWord w )
{
- if (referent->closure) {
- asmResolveRef(referer,i,(AsmClosure)referent->closure);
- } else {
- insertRefs(&(referent->refs),(AsmRef){referer,i});
- }
+ int i, j = 0;
+ for (i = 0; i < bco->usedEntities; i++) {
+ if (bco->entities[i].kind == Asm_NonPtrWord) {
+ if (bco->entities[i].val == w) return j;
+ j++;
+ }
+ }
+ return -1;
}
-void asmAddPtr( AsmObject obj, AsmObject arg )
+static void setInstrs ( AsmBCO bco, int instr_no, StgWord new_instr_byte )
{
- ASSERT(obj->closure == 0); /* can't extend an object once it's allocated */
- insertPtrs( &obj->ptrs, arg );
+ int i, j = 0;
+ for (i = 0; i < bco->usedEntities; i++) {
+ if (bco->entities[i].kind == Asm_Insn8) {
+ if (j == instr_no) {
+ bco->entities[i].val = new_instr_byte;
+ return;
+ }
+ j++;
+ }
+ }
+ barf("setInstrs");
}
-static void asmBeginObject( AsmObject obj )
+void* asmGetClosureOfObject ( AsmObject obj )
{
- obj->closure = NULL;
- obj->num_unresolved = 0;
- initRefs(&obj->refs);
- initPtrs(&obj->ptrs);
+ return obj->closure;
}
-static void asmEndObject( AsmObject obj, StgClosure* c )
-{
- obj->num_unresolved = obj->ptrs.len;
- obj->closure = c;
- mapQueue(Ptrs, AsmObject, obj->ptrs, asmAddRef(x,obj,i));
- mapQueue(Refs, AsmRef, obj->refs, asmResolveRef(x.ref,x.i,c));
- if (obj->num_unresolved == 0) {
- freePtrs(&obj->ptrs);
- freeRefs(&obj->refs);
- /* we don't print until all ptrs are resolved */
- IF_DEBUG(codegen,printObj(obj->closure));
- }
-}
+/* --------------------------------------------------------------------------
+ * Top level assembler/BCO linker functions
+ * ------------------------------------------------------------------------*/
-int asmObjectHasClosure ( AsmObject obj )
-{
- return (obj->num_unresolved == 0 && obj->closure);
+int asmCalcHeapSizeW ( AsmObject obj )
+{
+ int p, np, is, ws;
+ switch (obj->kind) {
+ case Asm_BCO:
+ p = obj->n_refs;
+ np = obj->n_words;
+ is = obj->n_insns + (obj->max_sp <= 255 ? 2 : 3);
+ ws = BCO_sizeW ( p, np, is );
+ break;
+ case Asm_CAF:
+ ws = CAF_sizeW();
+ break;
+ case Asm_Con:
+ p = obj->n_refs;
+ np = obj->n_words;
+ ws = CONSTR_sizeW ( p, np );
+ break;
+ default:
+ barf("asmCalcHeapSizeW");
+ }
+ if (ws - sizeofW(StgHeader) < MIN_NONUPD_SIZE)
+ ws = sizeofW(StgHeader) + MIN_NONUPD_SIZE;
+ return ws;
}
-AsmClosure asmClosureOfObject ( AsmObject obj )
+
+void asmAllocateHeapSpace ( void )
{
- ASSERT(asmObjectHasClosure(obj));
- return obj->closure;
+ AsmObject obj;
+ for (obj = objects; obj; obj = obj->next) {
+ StgClosure* c = asmAlloc ( asmCalcHeapSizeW ( obj ) );
+ obj->closure = c;
+ }
}
-void asmMarkObject ( AsmObject obj )
+void asmShutdown ( void )
{
- ASSERT(obj->num_unresolved == 0 && obj->closure);
- obj->closure = MarkRoot(obj->closure);
+ AsmObject obj;
+ AsmObject next = NULL;
+ for (obj = objects; obj; obj = next) {
+ next = obj->next;
+ obj->magic = 0x27180828;
+ if ( /*paranoia*/ obj->entities)
+ free(obj->entities);
+ free(obj);
+ }
+ objects = NULL;
+}
+
+StgClosure* asmDerefEntity ( Asm_Entity entity )
+{
+ switch (entity.kind) {
+ case Asm_RefNoOp:
+ return (StgClosure*)entity.val;
+ case Asm_RefObject:
+ ASSERT(entity.val);
+ ASSERT( ((AsmObject)(entity.val))->magic == 0x31415927 );
+ return ((AsmObject)(entity.val))->closure;
+ case Asm_RefHugs:
+ return getNameOrTupleClosureCPtr(entity.val);
+ default:
+ barf("asmDerefEntity");
+ }
+ return NULL; /*notreached*/
+}
+
+
+void asmCopyAndLink ( void )
+{
+ int j, k;
+ AsmObject obj;
+
+ for (obj = objects; obj; obj = obj->next) {
+ StgClosure** p = (StgClosure**)(obj->closure);
+ ASSERT(p);
+
+ switch (obj->kind) {
+
+ case Asm_BCO: {
+ AsmBCO abco = (AsmBCO)obj;
+ StgBCO* bco = (StgBCO*)p;
+ SET_HDR(bco,&BCO_info,??);
+ bco->n_ptrs = abco->n_refs;
+ bco->n_words = abco->n_words;
+ bco->n_instrs = abco->n_insns + (obj->max_sp <= 255 ? 2 : 3);
+ bco->stgexpr = abco->stgexpr;
+ //ppStgExpr(bco->stgexpr);
+ /* First copy in the ptrs. */
+ k = 0;
+ for (j = 0; j < obj->usedEntities; j++) {
+ switch (obj->entities[j].kind) {
+ case Asm_RefNoOp:
+ case Asm_RefObject:
+ case Asm_RefHugs:
+ bcoConstCPtr(bco,k++)
+ = (StgClosure*)asmDerefEntity(obj->entities[j]); break;
+ default:
+ break;
+ }
+ }
+
+ /* Now the non-ptrs. */
+ k = 0;
+ for (j = 0; j < obj->usedEntities; j++) {
+ switch (obj->entities[j].kind) {
+ case Asm_NonPtrWord:
+ bcoConstWord(bco,k++) = obj->entities[j].val; break;
+ default:
+ break;
+ }
+ }
+
+ /* Finally the insns, adding a stack check at the start. */
+ k = 0;
+ abco->max_sp = stg_max(abco->sp,abco->max_sp);
+
+ ASSERT(abco->max_sp <= 65535);
+ if (abco->max_sp <= 255) {
+ bcoInstr(bco,k++) = i_STK_CHECK;
+ bcoInstr(bco,k++) = abco->max_sp;
+ } else {
+ bcoInstr(bco,k++) = i_STK_CHECK_big;
+ bcoInstr(bco,k++) = abco->max_sp / 256;
+ bcoInstr(bco,k++) = abco->max_sp % 256;
+ }
+ for (j = 0; j < obj->usedEntities; j++) {
+ switch (obj->entities[j].kind) {
+ case Asm_Insn8:
+ bcoInstr(bco,k++) = obj->entities[j].val; break;
+ case Asm_RefNoOp:
+ case Asm_RefObject:
+ case Asm_RefHugs:
+ case Asm_NonPtrWord:
+ break;
+ default:
+ barf("asmCopyAndLink: strange stuff in AsmBCO");
+ }
+ }
+
+ ASSERT((unsigned int)k == bco->n_instrs);
+ break;
+ }
+
+ case Asm_CAF: {
+ StgCAF* caf = (StgCAF*)p;
+ SET_HDR(caf,&CAF_UNENTERED_info,??);
+ caf->link = NULL;
+ caf->mut_link = NULL;
+ caf->value = (StgClosure*)0xdeadbeef;
+ ASSERT(obj->usedEntities == 1);
+ switch (obj->entities[0].kind) {
+ case Asm_RefNoOp:
+ case Asm_RefObject:
+ case Asm_RefHugs:
+ caf->body = (StgClosure*)asmDerefEntity(obj->entities[0]);
+ break;
+ default:
+ barf("asmCopyAndLink: strange stuff in AsmCAF");
+ }
+ p += CAF_sizeW();
+ break;
+ }
+
+ case Asm_Con: {
+ SET_HDR((StgClosure*)p,obj->itbl,??);
+ p++;
+ /* First put in the pointers, then the non-pointers. */
+ for (j = 0; j < obj->usedEntities; j++) {
+ switch (obj->entities[j].kind) {
+ case Asm_RefNoOp:
+ case Asm_RefObject:
+ case Asm_RefHugs:
+ *p++ = asmDerefEntity(obj->entities[j]); break;
+ default:
+ break;
+ }
+ }
+ for (j = 0; j < obj->usedEntities; j++) {
+ switch (obj->entities[j].kind) {
+ case Asm_NonPtrWord:
+ *p++ = (StgClosure*)(obj->entities[j].val); break;
+ default:
+ barf("asmCopyAndLink: strange stuff in AsmCon");
+ }
+ }
+ break;
+ }
+
+ default:
+ barf("asmCopyAndLink");
+ }
+ }
}
+
/* --------------------------------------------------------------------------
- * Heap allocation
+ * Keeping track of the simulated stack pointer
* ------------------------------------------------------------------------*/
static StgClosure* asmAlloc( nat size )
return o;
}
-static void grabHpUpd( AsmBCO bco, nat size )
-{
- /* ToDo: sometimes we should test for MIN_UPD_SIZE instead */
- ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
- bco->hp += size;
-}
-
-static void grabHpNonUpd( AsmBCO bco, nat size )
-{
- /* ToDo: sometimes we should test for MIN_UPD_SIZE instead */
- ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
- bco->hp += size;
-}
-
-static void resetHp( AsmBCO bco, nat hp )
-{
- bco->max_hp = stg_max(bco->hp,bco->max_hp);
- bco->hp = hp;
-}
-
static void setSp( AsmBCO bco, AsmSp sp )
{
bco->max_sp = stg_max(bco->sp,bco->max_sp);
*
* ------------------------------------------------------------------------*/
-AsmObject asmMkObject( AsmClosure c )
-{
- AsmObject obj = malloc(sizeof(struct AsmObject_));
- if (obj == NULL) {
- barf("Can't allocate AsmObject");
- }
- asmBeginObject(obj);
- asmEndObject(obj,c);
- return obj;
-}
-
AsmCon asmBeginCon( AsmInfo info )
{
- AsmCon con = malloc(sizeof(struct AsmCon_));
- if (con == NULL) {
- barf("Can't allocate AsmCon");
- }
- asmBeginObject(&con->object);
- con->info = info;
- return con;
+ AsmCon con = asmNewObject();
+ con->kind = Asm_Con;
+ con->itbl = info;
+ return con;
}
-void asmEndCon( AsmCon con )
+void asmEndCon( AsmCon con __attribute__ ((unused)) )
{
- nat p = con->object.ptrs.len;
- nat np = stg_max(0,MIN_NONUPD_SIZE-p);
-
- StgClosure* c = asmAlloc(CONSTR_sizeW(p,np));
- StgClosure* o = stgCast(StgClosure*,c);
- SET_HDR(o,con->info,??);
- mapQueue(Ptrs, AsmObject, con->object.ptrs, payloadCPtr(o,i) = NULL);
- { nat i; for( i=0; i<np; ++i ) { payloadWord(o,p+i) = 0xdeadbeef; } }
- asmEndObject(&con->object,c);
}
AsmCAF asmBeginCAF( void )
{
- AsmCAF caf = malloc(sizeof(struct AsmCAF_));
- if (caf == NULL) {
- barf("Can't allocate AsmCAF");
- }
- asmBeginObject(&caf->object);
- return caf;
+ AsmCAF caf = asmNewObject();
+ caf->kind = Asm_CAF;
+ return caf;
}
-void asmEndCAF( AsmCAF caf, AsmBCO body )
+void asmEndCAF( AsmCAF caf __attribute__ ((unused)) )
{
- StgClosure* c = asmAlloc(CAF_sizeW());
- StgCAF* o = stgCast(StgCAF*,c);
- SET_HDR(o,&CAF_UNENTERED_info,??);
- o->body = NULL;
- o->value = stgCast(StgClosure*,0xdeadbeef);
- o->link = stgCast(StgCAF*,0xdeadbeef);
- o->mut_link = NULL;
- asmAddPtr(&caf->object,&body->object);
- asmEndObject(&caf->object,c);
}
AsmBCO asmBeginBCO( int /*StgExpr*/ e )
{
- AsmBCO bco = malloc(sizeof(struct AsmBCO_));
- if (bco == NULL) {
- barf("Can't allocate AsmBCO");
- }
- asmBeginObject(&bco->object);
- initInstrs(&bco->is);
- initNonPtrs(&bco->nps);
-
- bco->stgexpr = e;
- bco->max_sp = bco->sp = 0;
- bco->max_hp = bco->hp = 0;
- bco->lastOpc = i_INTERNAL_ERROR;
- return bco;
+ AsmBCO bco = asmNewObject();
+ bco->kind = Asm_BCO;
+ bco->stgexpr = e;
+ //ppStgExpr(bco->stgexpr);
+ bco->sp = 0;
+ bco->max_sp = 0;
+ bco->lastOpc = i_INTERNAL_ERROR;
+ return bco;
}
-void asmEndBCO( AsmBCO bco )
-{
- nat p = bco->object.ptrs.len;
- nat np = bco->nps.len;
- nat is = bco->is.len + (bco->max_sp <= 255 ? 2 : 3); /* 2 or 3 for stack check */
-
- StgClosure* c = asmAlloc(BCO_sizeW(p,np,is));
- StgBCO* o = stgCast(StgBCO*,c);
- SET_HDR(o,&BCO_info,??);
- o->n_ptrs = p;
- o->n_words = np;
- o->n_instrs = is;
- o->stgexpr = bco->stgexpr;
- mapQueue(Ptrs, AsmObject, bco->object.ptrs, bcoConstCPtr(o,i) = NULL);
- mapQueue(NonPtrs, StgWord, bco->nps, bcoConstWord(o,i) = x);
- {
- nat j = 0;
- bco->max_sp = stg_max(bco->sp,bco->max_sp);
- bco->max_hp = stg_max(bco->hp,bco->max_hp);
-
- ASSERT(bco->max_sp <= 65535);
- if (bco->max_sp <= 255) {
- bcoInstr(o,j++) = i_STK_CHECK;
- bcoInstr(o,j++) = bco->max_sp;
- } else {
- bcoInstr(o,j++) = i_STK_CHECK_big;
- bcoInstr(o,j++) = bco->max_sp / 256;
- bcoInstr(o,j++) = bco->max_sp % 256;
- }
-
- mapQueue(Instrs, StgWord8, bco->is, bcoInstr(o,j++) = x);
- ASSERT(j == is);
- }
- freeInstrs(&bco->is);
- freeNonPtrs(&bco->nps);
- asmEndObject(&bco->object,c);
+void asmEndBCO( AsmBCO bco __attribute__ ((unused)) )
+{
}
/* --------------------------------------------------------------------------
*
* ------------------------------------------------------------------------*/
-static void asmInstrOp ( AsmBCO bco, StgWord i )
+static void asmAddInstr ( AsmBCO bco, StgWord i )
{
- ASSERT(i <= BIGGEST_OPCODE); /* must be a valid opcode */
- bco->lastOpc = i;
- insertInstrs(&(bco->is),i);
+ asmAddEntity ( bco, Asm_Insn8, i );
}
-static void asmInstr8 ( AsmBCO bco, StgWord i )
+static void asmAddNonPtrWord ( AsmObject obj, StgWord i )
{
- if (i >= 256) {
- ASSERT(i < 256); /* must be a byte */
- }
- insertInstrs(&(bco->is),i);
+ asmAddEntity ( obj, Asm_NonPtrWord, i );
}
-static void asmInstr16 ( AsmBCO bco, StgWord i )
+void asmAddRefHugs ( AsmObject obj,int /*Name*/ n )
{
- ASSERT(i < 65536); /* must be a short */
- insertInstrs(&(bco->is),i / 256);
- insertInstrs(&(bco->is),i % 256);
+ asmAddEntity ( obj, Asm_RefHugs, n );
}
-static Instr asmInstrBack ( AsmBCO bco, StgWord n )
+void asmAddRefObject ( AsmObject obj, AsmObject p )
{
- return bco->is.elems[bco->is.len - n];
+ ASSERT(p->magic == 0x31415927);
+ asmAddEntity ( obj, Asm_RefObject, (StgWord)p );
}
-static void asmInstrRecede ( AsmBCO bco, StgWord n )
+void asmAddRefNoOp ( AsmObject obj, StgPtr p )
{
- if (bco->is.len < n) barf("asmInstrRecede");
- bco->is.len -= n;
+ asmAddEntity ( obj, Asm_RefNoOp, (StgWord)p );
}
-static void asmPtr( AsmBCO bco, AsmObject x )
+
+
+static void asmInstrOp ( AsmBCO bco, StgWord i )
{
- insertPtrs( &bco->object.ptrs, x );
+ ASSERT(i <= BIGGEST_OPCODE); /* must be a valid opcode */
+ bco->lastOpc = i;
+ asmAddInstr(bco,i);
}
-static void asmWord( AsmBCO bco, StgWord i )
+static void asmInstr8 ( AsmBCO bco, StgWord i )
{
- insertNonPtrs( &bco->nps, i );
+ if (i >= 256) {
+ ASSERT(i < 256); /* must be a byte */
+ }
+ asmAddInstr(bco,i);
+}
+
+static void asmInstr16 ( AsmBCO bco, StgWord i )
+{
+ ASSERT(i < 65536); /* must be a short */
+ asmAddInstr(bco,i / 256);
+ asmAddInstr(bco,i % 256);
}
-#define asmWords(bco,ty,x) \
+
+#define asmAddNonPtrWords(bco,ty,x) \
{ \
union { ty a; AsmWord b[sizeofW(ty)]; } p; \
nat i; \
if (sizeof(ty) < sizeof(AsmWord)) p.b[0]=0; \
p.a = x; \
for( i = 0; i < sizeofW(ty); i++ ) { \
- asmWord(bco,p.b[i]); \
+ asmAddNonPtrWord(bco,p.b[i]); \
} \
}
case FOREIGN_REP:
#endif
case ALPHA_REP: /* a */
- case BETA_REP: /* b */
- case GAMMA_REP: /* c */
+ case BETA_REP: /* b */
+ case GAMMA_REP: /* c */
case DELTA_REP: /* d */
case HANDLER_REP: /* IOError -> IO a */
case ERROR_REP: /* IOError */
static void emiti_ ( AsmBCO bco, Instr opcode )
{
+#if 1
StgInt x, y;
if (bco->lastOpc == i_SLIDE && opcode == i_ENTER) {
/* SLIDE x y ; ENTER ===> SE x y */
else {
asmInstrOp(bco,opcode);
}
+#else
+ asmInstrOp(bco,opcode);
+#endif
}
static void emiti_8 ( AsmBCO bco, Instr opcode, int arg1 )
{
+#if 1
StgInt x;
if (bco->lastOpc == i_VAR && opcode == i_VAR) {
/* VAR x ; VAR y ===> VV x y */
asmInstrOp(bco,opcode);
asmInstr8(bco,arg1);
}
+#else
+ asmInstrOp(bco,opcode);
+ asmInstr8(bco,arg1);
+#endif
}
static void emiti_16 ( AsmBCO bco, Instr opcode, int arg1 )
asmInstr16(bco,arg2);
}
+#ifdef XMLAMBDA
+static void emiti_8_8_16 ( AsmBCO bco, Instr opcode, int arg1, int arg2, int arg3 )
+{
+ asmInstrOp(bco,opcode);
+ asmInstr8(bco,arg1);
+ asmInstr8(bco,arg2);
+ asmInstr16(bco,arg3);
+}
+#endif
/* --------------------------------------------------------------------------
* Wrappers around the above fns
emiti_16(bco,i_CONST_ADDR_big,arg1);
}
+static void emit_i_CONST_WORD ( AsmBCO bco, int arg1 )
+{
+ ASSERT(arg1 >= 0);
+ if (arg1 < 256)
+ emiti_8 (bco,i_CONST_WORD, arg1); else
+ emiti_16(bco,i_CONST_WORD_big,arg1);
+}
+
static void emit_i_CONST_CHAR ( AsmBCO bco, int arg1 )
{
ASSERT(arg1 >= 0);
emiti_16(bco,i_RETADDR_big,arg1);
}
+static void emit_i_ALLOC_CONSTR ( AsmBCO bco, int arg1 )
+{
+ ASSERT(arg1 >= 0);
+ if (arg1 < 256)
+ emiti_8 (bco,i_ALLOC_CONSTR, arg1); else
+ emiti_16(bco,i_ALLOC_CONSTR_big,arg1);
+}
+
+#ifdef XMLAMBDA
+static void emit_i_ALLOC_ROW( AsmBCO bco, int n )
+{
+ ASSERT(n >= 0);
+ if (n < 256)
+ emiti_8 ( bco, i_ALLOC_ROW, n ); else
+ emiti_16( bco, i_ALLOC_ROW_big, n );
+}
+
+static void emit_i_PACK_ROW (AsmBCO bco, int var )
+{
+ ASSERT(var >= 0);
+ if (var < 256)
+ emiti_8 ( bco, i_PACK_ROW, var ); else
+ emiti_16( bco, i_PACK_ROW_big, var );
+}
+
+static void emit_i_PACK_INJ_VAR (AsmBCO bco, int var )
+{
+ ASSERT(var >= 0);
+ if (var < 256)
+ emiti_8 ( bco, i_PACK_INJ_VAR, var ); else
+ emiti_16( bco, i_PACK_INJ_VAR_big, var );
+}
+
+static void emit_i_TEST_INJ_VAR (AsmBCO bco, int var )
+{
+ ASSERT(var >= 0);
+ if (var < 256)
+ emiti_8_16 ( bco, i_TEST_INJ_VAR, var, 0 ); else
+ emiti_16_16( bco, i_TEST_INJ_VAR_big, var, 0 );
+}
+
+static void emit_i_ADD_WORD_VAR (AsmBCO bco, int var )
+{
+ ASSERT(var >= 0);
+ if (var < 256)
+ emiti_8( bco, i_ADD_WORD_VAR, var ); else
+ emiti_16( bco, i_ADD_WORD_VAR_big, var );
+}
+#endif
/* --------------------------------------------------------------------------
* Arg checks.
nat args = bco->sp - last_arg;
if (args != 0) { /* optimisation */
emiti_8(bco,i_ARG_CHECK,args);
- grabHpNonUpd(bco,PAP_sizeW(args-1));
- resetHp(bco,0);
}
}
switch (rep) {
case CHAR_REP:
emiti_(bco,i_PACK_CHAR);
- grabHpNonUpd(bco,Czh_sizeW);
break;
case INT_REP:
emiti_(bco,i_PACK_INT);
- grabHpNonUpd(bco,Izh_sizeW);
break;
case THREADID_REP:
case WORD_REP:
emiti_(bco,i_PACK_WORD);
- grabHpNonUpd(bco,Wzh_sizeW);
break;
case ADDR_REP:
emiti_(bco,i_PACK_ADDR);
- grabHpNonUpd(bco,Azh_sizeW);
break;
case FLOAT_REP:
emiti_(bco,i_PACK_FLOAT);
- grabHpNonUpd(bco,Fzh_sizeW);
break;
case DOUBLE_REP:
emiti_(bco,i_PACK_DOUBLE);
- grabHpNonUpd(bco,Dzh_sizeW);
break;
case STABLE_REP:
emiti_(bco,i_PACK_STABLE);
- grabHpNonUpd(bco,Stablezh_sizeW);
break;
default:
void asmConstInt( AsmBCO bco, AsmInt x )
{
- emit_i_CONST_INT(bco,bco->nps.len);
- asmWords(bco,AsmInt,x);
+ emit_i_CONST_INT(bco,bco->n_words);
+ asmAddNonPtrWords(bco,AsmInt,x);
incSp(bco, repSizeW(INT_REP));
}
void asmConstInteger( AsmBCO bco, AsmString x )
{
- emit_i_CONST_INTEGER(bco,bco->nps.len);
- asmWords(bco,AsmString,x);
+ emit_i_CONST_INTEGER(bco,bco->n_words);
+ asmAddNonPtrWords(bco,AsmString,x);
incSp(bco, repSizeW(INTEGER_REP));
}
void asmConstAddr( AsmBCO bco, AsmAddr x )
{
- emit_i_CONST_ADDR(bco,bco->nps.len);
- asmWords(bco,AsmAddr,x);
+ emit_i_CONST_ADDR(bco,bco->n_words);
+ asmAddNonPtrWords(bco,AsmAddr,x);
incSp(bco, repSizeW(ADDR_REP));
}
void asmConstWord( AsmBCO bco, AsmWord x )
{
- emit_i_CONST_INT(bco,bco->nps.len);
- asmWords(bco,AsmWord,(AsmInt)x);
+ emit_i_CONST_WORD(bco,bco->n_words);
+ asmAddNonPtrWords(bco,AsmWord,x);
incSp(bco, repSizeW(WORD_REP));
}
void asmConstChar( AsmBCO bco, AsmChar x )
{
- emit_i_CONST_CHAR(bco,bco->nps.len);
- asmWords(bco,AsmChar,x);
+ emit_i_CONST_CHAR(bco,bco->n_words);
+ asmAddNonPtrWords(bco,AsmChar,x);
incSp(bco, repSizeW(CHAR_REP));
}
void asmConstFloat( AsmBCO bco, AsmFloat x )
{
- emit_i_CONST_FLOAT(bco,bco->nps.len);
- asmWords(bco,AsmFloat,x);
+ emit_i_CONST_FLOAT(bco,bco->n_words);
+ asmAddNonPtrWords(bco,AsmFloat,x);
incSp(bco, repSizeW(FLOAT_REP));
}
void asmConstDouble( AsmBCO bco, AsmDouble x )
{
- emit_i_CONST_DOUBLE(bco,bco->nps.len);
- asmWords(bco,AsmDouble,x);
+ emit_i_CONST_DOUBLE(bco,bco->n_words);
+ asmAddNonPtrWords(bco,AsmDouble,x);
incSp(bco, repSizeW(DOUBLE_REP));
}
return bco->sp;
}
-void asmEndCase( AsmBCO bco )
+void asmEndCase( AsmBCO bco __attribute__ ((unused)) )
{
}
AsmSp asmContinuation( AsmBCO bco, AsmBCO ret_addr )
{
- emit_i_RETADDR(bco,bco->object.ptrs.len);
- asmPtr(bco,&(ret_addr->object));
+ emit_i_RETADDR(bco,bco->n_refs);
+ asmAddRefObject(bco,ret_addr);
incSp(bco, 2 * sizeofW(StgPtr));
return bco->sp;
}
AsmPc asmTest( AsmBCO bco, AsmWord tag )
{
emiti_8_16(bco,i_TEST,tag,0);
- return bco->is.len;
+ return bco->n_insns;
}
-AsmPc asmTestInt( AsmBCO bco, AsmVar v, AsmInt x )
+AsmPc asmTestInt ( AsmBCO bco, AsmVar v, AsmInt x )
{
asmVar(bco,v,INT_REP);
asmConstInt(bco,x);
emiti_16(bco,i_TEST_INT,0);
decSp(bco, 2*repSizeW(INT_REP));
- return bco->is.len;
+ return bco->n_insns;
}
-void asmFixBranch( AsmBCO bco, AsmPc from )
+void asmFixBranch ( AsmBCO bco, AsmPc from )
{
- int distance = bco->is.len - from;
+ int distance = bco->n_insns - from;
ASSERT(distance >= 0);
ASSERT(distance < 65536);
- setInstrs(&(bco->is),from-2,distance/256);
- setInstrs(&(bco->is),from-1,distance%256);
+ setInstrs(bco,from-2,distance/256);
+ setInstrs(bco,from-1,distance%256);
}
void asmPanic( AsmBCO bco )
return bco->sp;
}
-void asmEndPrim( AsmBCO bco, const AsmPrim* prim, AsmSp base )
+void asmEndPrim( AsmBCO bco, const AsmPrim* prim, AsmSp base )
{
emiti_8(bco,prim->prefix,prim->opcode);
setSp(bco, base);
}
+char* asmGetPrimopName ( AsmPrim* p )
+{
+ return p->name;
+}
+
/* Hugs used to let you add arbitrary primops with arbitrary types
* just by editing Prelude.hs or any other file you wanted.
* We deliberately avoided that approach because we wanted more
* control over which primops are provided.
*/
-const AsmPrim asmPrimOps[] = {
+AsmPrim asmPrimOps[] = {
/* Char# operations */
{ "primGtChar", "CC", "B", MONAD_Id, i_PRIMOP1, i_gtChar }
, { "primIsNegativeZeroDouble", "D", "B", MONAD_Id, i_PRIMOP1, i_isNegativeZeroDouble }
, { "primIsIEEEDouble", "", "B", MONAD_Id, i_PRIMOP1, i_isIEEEDouble }
+#ifdef XMLAMBDA
+ /* primitive row operations. */
+ , { "primRowInsertAt", "XWa","X", MONAD_Id, i_PRIMOP2, i_rowInsertAt }
+ , { "primRowRemoveAt", "XW", "aX", MONAD_Id, i_PRIMOP2, i_rowRemoveAt }
+#endif
+
/* Ref operations */
, { "primNewRef", "a", "R", MONAD_ST, i_PRIMOP2, i_newRef }
, { "primWriteRef", "Ra", "", MONAD_ST, i_PRIMOP2, i_writeRef }
#ifdef PROVIDE_FOREIGN
/* ForeignObj# operations */
- , { "primMakeForeignObj", "A", "f", MONAD_IO, i_PRIMOP2, i_makeForeignObj }
+ , { "primMkForeignObj", "A", "f", MONAD_IO, i_PRIMOP2, i_mkForeignObj }
#endif
#ifdef PROVIDE_WEAK
/* WeakPair# operations */
#endif
#ifdef PROVIDE_CONCURRENT
/* Concurrency operations */
- , { "primFork", "a", "T", MONAD_IO, i_PRIMOP2, i_fork }
+ , { "primForkIO", "a", "T", MONAD_IO, i_PRIMOP2, i_forkIO }
, { "primKillThread", "T", "", MONAD_IO, i_PRIMOP2, i_killThread }
- , { "primDelay", "I", "", MONAD_IO, i_PRIMOP2, i_delay }
+ , { "primRaiseInThread", "TE", "", MONAD_IO, i_PRIMOP2, i_raiseInThread }
+
, { "primWaitRead", "I", "", MONAD_IO, i_PRIMOP2, i_waitRead }
, { "primWaitWrite", "I", "", MONAD_IO, i_PRIMOP2, i_waitWrite }
+ , { "primYield", "", "", MONAD_IO, i_PRIMOP2, i_yield } , { "primDelay", "I", "", MONAD_IO, i_PRIMOP2, i_delay }
+ , { "primGetThreadId", "", "T", MONAD_IO, i_PRIMOP2, i_getThreadId }
+ , { "primCmpThreadIds", "TT", "I", MONAD_Id, i_PRIMOP2, i_cmpThreadIds }
#endif
- , { "primNewEmptyMVar", "", "r", MONAD_IO, i_PRIMOP2, i_newMVar }
+ , { "primNewEmptyMVar", "", "r", MONAD_IO, i_PRIMOP2, i_newMVar }
/* primTakeMVar is handwritten bytecode */
, { "primPutMVar", "ra", "", MONAD_IO, i_PRIMOP2, i_putMVar }
, { "primSameMVar", "rr", "B", MONAD_Id, i_PRIMOP2, i_sameMVar }
- , { "primGetThreadId", "", "T", MONAD_IO, i_PRIMOP2, i_getThreadId }
- , { "primCmpThreadIds", "TT", "I", MONAD_Id, i_PRIMOP2, i_cmpThreadIds }
- , { "primForkIO", "a", "T", MONAD_IO, i_PRIMOP2, i_forkIO }
+
/* Ccall is polyadic - so it's excluded from this table */
, { 0,0,0,0,0,0 }
};
-const AsmPrim ccall_ccall_Id
+AsmPrim ccall_ccall_Id
= { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_ccall_Id };
-const AsmPrim ccall_ccall_IO
+AsmPrim ccall_ccall_IO
= { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_ccall_IO };
-const AsmPrim ccall_stdcall_Id
+AsmPrim ccall_stdcall_Id
= { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_stdcall_Id };
-const AsmPrim ccall_stdcall_IO
+AsmPrim ccall_stdcall_IO
= { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_stdcall_IO };
+#ifdef DEBUG
+void checkBytecodeCount( void );
+void checkBytecodeCount( void )
+{
+ if (MAX_Primop1 >= 255) {
+ printf("Too many Primop1 bytecodes (%d)\n",MAX_Primop1);
+ }
+ if (MAX_Primop2 >= 255) {
+ printf("Too many Primop2 bytecodes (%d)\n",MAX_Primop2);
+ }
+}
+#endif
-const AsmPrim* asmFindPrim( char* s )
+AsmPrim* asmFindPrim( char* s )
{
int i;
for (i=0; asmPrimOps[i].name; ++i) {
return 0;
}
-const AsmPrim* asmFindPrimop( AsmInstr prefix, AsmInstr op )
+AsmPrim* asmFindPrimop( AsmInstr prefix, AsmInstr op )
{
nat i;
for (i=0; asmPrimOps[i].name; ++i) {
* Handwritten primops
* ------------------------------------------------------------------------*/
-AsmBCO asm_BCO_catch ( void )
+void* /* StgBCO* */ asm_BCO_catch ( void )
{
- AsmBCO bco = asmBeginBCO(0 /*NIL*/);
+ AsmBCO bco;
+ StgBCO* closure;
+ asmInitialise();
+
+ bco = asmBeginBCO(0 /*NIL*/);
emiti_8(bco,i_ARG_CHECK,2);
emiti_8(bco,i_PRIMOP1,i_pushcatchframe);
incSp(bco, (1-2)*sizeofW(StgPtr) + sizeofW(StgCatchFrame));
emiti_(bco,i_ENTER);
decSp(bco, sizeofW(StgPtr));
asmEndBCO(bco);
- return bco;
+
+ asmAllocateHeapSpace();
+ asmCopyAndLink();
+ closure = (StgBCO*)(bco->closure);
+ asmShutdown();
+ return closure;
}
-AsmBCO asm_BCO_raise ( void )
+void* /* StgBCO* */ asm_BCO_raise ( void )
{
- AsmBCO bco = asmBeginBCO(0 /*NIL*/);
+ AsmBCO bco;
+ StgBCO* closure;
+ asmInitialise();
+
+ bco = asmBeginBCO(0 /*NIL*/);
emiti_8(bco,i_ARG_CHECK,1);
emiti_8(bco,i_PRIMOP2,i_raise);
decSp(bco,sizeofW(StgPtr));
asmEndBCO(bco);
- return bco;
+
+ asmAllocateHeapSpace();
+ asmCopyAndLink();
+ closure = (StgBCO*)(bco->closure);
+ asmShutdown();
+ return closure;
}
-AsmBCO asm_BCO_seq ( void )
+void* /* StgBCO* */ asm_BCO_seq ( void )
{
AsmBCO eval, cont;
+ StgBCO* closure;
+ asmInitialise();
cont = asmBeginBCO(0 /*NIL*/);
emiti_8(cont,i_ARG_CHECK,2); /* should never fail */
eval = asmBeginBCO(0 /*NIL*/);
emiti_8(eval,i_ARG_CHECK,2);
- emit_i_RETADDR(eval,eval->object.ptrs.len);
- asmPtr(eval,&(cont->object));
+ emit_i_RETADDR(eval,eval->n_refs);
+ asmAddRefObject(eval,cont);
emit_i_VAR(eval,2);
emit_i_SLIDE(eval,3,1);
emiti_8(eval,i_PRIMOP1,i_pushseqframe);
incSp(eval, sizeofW(StgSeqFrame) + 4*sizeofW(StgPtr));
asmEndBCO(eval);
- return eval;
+ asmAllocateHeapSpace();
+ asmCopyAndLink();
+ closure = (StgBCO*)(eval->closure);
+ asmShutdown();
+ return closure;
}
-AsmBCO asm_BCO_takeMVar ( void )
+void* /* StgBCO* */ asm_BCO_takeMVar ( void )
{
AsmBCO kase, casecont, take;
+ StgBCO* closure;
+ asmInitialise();
take = asmBeginBCO(0 /*NIL*/);
emit_i_VAR(take,0);
emit_i_VAR(casecont,4);
emit_i_VAR(casecont,4);
emit_i_VAR(casecont,2);
- emit_i_CONST(casecont,casecont->object.ptrs.len);
- asmPtr(casecont,&(take->object));
+ emit_i_CONST(casecont,casecont->n_refs);
+ asmAddRefObject(casecont,take);
emit_i_SLIDE(casecont,4,5);
emiti_(casecont,i_ENTER);
incSp(casecont,20);
kase = asmBeginBCO(0 /*NIL*/);
emiti_8(kase,i_ARG_CHECK,3);
- emit_i_RETADDR(kase,kase->object.ptrs.len);
- asmPtr(kase,&(casecont->object));
+ emit_i_RETADDR(kase,kase->n_refs);
+ asmAddRefObject(kase,casecont);
emit_i_VAR(kase,2);
emiti_(kase,i_ENTER);
incSp(kase,20);
asmEndBCO(kase);
- return kase;
+ asmAllocateHeapSpace();
+ asmCopyAndLink();
+ closure = (StgBCO*)(kase->closure);
+ asmShutdown();
+ return closure;
}
AsmVar asmAllocCONSTR ( AsmBCO bco, AsmInfo info )
{
+ int i;
ASSERT( sizeW_fromITBL(info) >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
- emiti_8(bco,i_ALLOC_CONSTR,bco->nps.len);
- asmWords(bco,AsmInfo,info);
+
+ /* Look in this bco's collection of nonpointers (literals)
+ to see if the itbl pointer is already there. If so, re-use it. */
+ i = asmFindInNonPtrs ( bco, (StgWord)info );
+
+ if (i == -1) {
+ emit_i_ALLOC_CONSTR(bco,bco->n_words);
+ asmAddNonPtrWords(bco,AsmInfo,info);
+ } else {
+ emit_i_ALLOC_CONSTR(bco,i);
+ }
+
incSp(bco, sizeofW(StgClosurePtr));
- grabHpNonUpd(bco,sizeW_fromITBL(info));
return bco->sp;
}
void asmEndPack( AsmBCO bco, AsmVar v, AsmSp start, AsmInfo info )
{
nat size = bco->sp - start;
- assert(bco->sp >= start);
- assert(start >= v);
+ ASSERT(bco->sp >= start);
+ ASSERT(start >= v);
/* only reason to include info is for this assertion */
- assert(info->layout.payload.ptrs == size);
+ ASSERT(info->layout.payload.ptrs == size);
emit_i_PACK(bco, bco->sp - v);
setSp(bco, start);
}
-void asmBeginUnpack( AsmBCO bco )
+void asmBeginUnpack( AsmBCO bco __attribute__ ((unused)) )
{
/* dummy to make it look prettier */
}
{
emiti_8(bco,i_ALLOC_AP,words);
incSp(bco, sizeofW(StgPtr));
- grabHpUpd(bco,AP_sizeW(words));
return bco->sp;
}
setSp(bco, start);
}
-AsmVar asmClosure( AsmBCO bco, AsmObject p )
+AsmVar asmPushRefHugs ( AsmBCO bco, int /*Name*/ n )
{
- emit_i_CONST(bco,bco->object.ptrs.len);
- asmPtr(bco,p);
+ emit_i_CONST(bco,bco->n_refs);
+ asmAddRefHugs(bco,n);
incSp(bco, sizeofW(StgPtr));
return bco->sp;
}
-AsmVar asmGHCClosure( AsmBCO bco, AsmObject p )
+AsmVar asmPushRefObject ( AsmBCO bco, AsmObject p )
{
- // A complete hack. Pushes the address as a tagged int
- // and then uses SLIDE to get rid of the tag. Appalling.
- asmConstInt(bco, (AsmInt)p);
- emit_i_SLIDE(bco,0,1); decSp(bco,1);
+ emit_i_CONST(bco,bco->n_refs);
+ asmAddRefObject(bco,p);
+ incSp(bco, sizeofW(StgPtr));
+ return bco->sp;
+}
+
+AsmVar asmPushRefNoOp ( AsmBCO bco, StgPtr p )
+{
+ emit_i_CONST(bco,bco->n_refs);
+ asmAddRefNoOp(bco,p);
+ incSp(bco, sizeofW(StgPtr));
return bco->sp;
}
return info;
}
+#ifdef XMLAMBDA
+/* -----------------------------------------------------------------------
+ All the XMLambda primitives.
+------------------------------------------------------------------------*/
+static void asmConstWordOpt( AsmBCO bco, AsmWord w )
+{
+ if (w < 256)
+ {
+ emiti_8( bco, i_CONST_WORD_8, w );
+ incSp( bco, repSizeW(WORD_REP)); /* push word */
+ }
+ else
+ {
+ asmConstWord( bco, w );
+ }
+}
+
+/* -----------------------------------------------------------------------
+ insert/remove primitives on rows
+------------------------------------------------------------------------*/
+void asmEndPrimRowChainInsert( AsmBCO bco, AsmSp base, AsmWord n /* number of args */ )
+{
+static AsmPrim primRowChainInsert
+ = { "primRowChainInsert", 0, 0, MONAD_Id, i_PRIMOP2, i_rowChainInsert };
+
+ nat size = bco->sp - base;
+ ASSERT(bco->sp >= base);
+ ASSERT(n*3 + 1 == size); /* n witness/value pairs + the row */
+
+ asmConstWordOpt(bco, n);
+ asmEndPrim(bco,&primRowChainInsert,base);
+}
+
+void asmEndPrimRowChainBuild( AsmBCO bco, AsmSp base, AsmWord n /* number of args */ )
+{
+static AsmPrim primRowChainBuild
+ = { "primRowChainBuild", 0, 0, MONAD_Id, i_PRIMOP2, i_rowChainBuild };
+
+ nat size = bco->sp - base;
+ ASSERT(bco->sp >= base);
+ ASSERT(n*3 == size); /* n witness/value pairs */
+
+ asmConstWordOpt(bco, n);
+ asmEndPrim(bco,&primRowChainBuild,base);
+}
+
+void asmEndPrimRowChainRemove( AsmBCO bco, AsmSp base, AsmWord n /* number of args */ )
+{
+static AsmPrim primRowChainRemove
+ = { "primRowChainRemove", 0, 0, MONAD_Id, i_PRIMOP2, i_rowChainRemove };
+
+ nat size = bco->sp - base;
+ ASSERT(bco->sp >= base);
+ ASSERT(n*2 + 1 == size); /* n witnesses + the row */
+
+ asmConstWordOpt(bco, n);
+ asmEndPrim(bco,&primRowChainRemove,base);
+}
+
+void asmEndPrimRowChainSelect( AsmBCO bco, AsmSp base, AsmWord n /* number of args */ )
+{
+static AsmPrim primRowChainSelect
+ = { "primRowChainSelect", 0, 0, MONAD_Id, i_PRIMOP2, i_rowChainSelect };
+
+ nat size = bco->sp - base;
+ ASSERT(bco->sp >= base);
+ ASSERT(n*2 + 1 == size); /* n witnesses + the row */
+
+ asmConstWordOpt(bco, n);
+ asmEndPrim(bco,&primRowChainSelect,base);
+}
+
+/* -----------------------------------------------------------------------
+ allocation & unpacking of rows
+------------------------------------------------------------------------*/
+AsmVar asmAllocRow ( AsmBCO bco, AsmWord n /*number of fields*/ )
+{
+ emit_i_ALLOC_ROW(bco,n);
+
+ incSp(bco, sizeofW(StgClosurePtr));
+ return bco->sp;
+}
+
+AsmSp asmBeginPackRow( AsmBCO bco )
+{
+ return bco->sp;
+}
+
+void asmEndPackRow( AsmBCO bco, AsmVar v, AsmSp start, AsmWord n /*number of fields*/ )
+{
+ nat size = bco->sp - start;
+ ASSERT(bco->sp >= start);
+ ASSERT(start >= v);
+ /* only reason to include n is for this assertion */
+ ASSERT(n == size);
+ emit_i_PACK_ROW(bco,bco->sp - v);
+ setSp(bco, start);
+}
+
+void asmBeginUnpackRow( AsmBCO bco __attribute__ ((unused)) )
+{
+ /* dummy to make it look prettier */
+}
+
+void asmEndUnpackRow( AsmBCO bco )
+{
+ emiti_(bco,i_UNPACK_ROW);
+}
+
+void asmConstRowTriv( AsmBCO bco )
+{
+ emiti_(bco,i_CONST_ROW_TRIV);
+ incSp(bco,sizeofW(StgPtr));
+}
+
+/*------------------------------------------------------------------------
+ Inj primitives.
+ The Inj constructor contains the value and its index: an unboxed word
+ data Inj = forall a. Inj a Int#
+------------------------------------------------------------------------*/
+AsmVar asmInjRel( AsmBCO bco, AsmVar var, AsmWitness w )
+{
+ int offset = bco->sp - var;
+
+ if (w == 0)
+ {
+ emit_i_PACK_INJ_VAR( bco, offset );
+ }
+ else if (w < 256 && offset < 256 && offset >= 0)
+ {
+ emiti_8_8( bco, i_PACK_INJ_REL_8, offset, w );
+ }
+ else
+ {
+ asmWitnessRel( bco, var, w );
+ emiti_( bco, i_PACK_INJ );
+ decSp(bco, repSizeW(WITNESS_REP)); /* pop witness */
+ }
+
+ decSp(bco, sizeofW(StgPtr)); /* pop argument value */
+ incSp(bco, sizeofW(StgPtr)); /* push Inj result */
+ return bco->sp;
+}
+
+AsmVar asmInjConst( AsmBCO bco, AsmWitness w )
+{
+ if (w < 256)
+ {
+ emiti_8 (bco, i_PACK_INJ_CONST_8, w );
+ }
+ else
+ {
+ asmWitnessConst( bco, w );
+ emiti_( bco, i_PACK_INJ );
+ decSp(bco, repSizeW(WITNESS_REP)); /* pop witness */
+ }
+
+ decSp(bco, sizeofW(StgPtr)); /* pop argument value */
+ incSp(bco, sizeofW(StgPtr)); /* push Inj result */
+ return bco->sp;
+}
+
+/* UNPACK_INJ only returns the value; the index should be
+ tested using the TEST_INJ instructions. */
+AsmVar asmUnInj( AsmBCO bco )
+{
+ emiti_(bco,i_UNPACK_INJ);
+ incSp(bco, sizeofW(StgPtr)); /* push the value */
+ return bco->sp;
+}
+
+AsmPc asmTestInjRel( AsmBCO bco, AsmVar var, AsmWitness w )
+{
+ int offset = bco->sp - var;
+
+ if (w == 0)
+ {
+ emit_i_TEST_INJ_VAR(bco,offset );
+ }
+ else if (w < 256 && offset < 256 && offset >= 0)
+ {
+ emiti_8_8_16( bco, i_TEST_INJ_REL_8, offset, w, 0 );
+ }
+ else
+ {
+ asmWitnessRel( bco, var, w );
+ emiti_16( bco, i_TEST_INJ, 0 );
+ decSp(bco, repSizeW(WITNESS_REP)); /* pop witness */
+ }
+ return bco->n_insns;
+}
+
+AsmPc asmTestInjConst( AsmBCO bco, AsmWitness w )
+{
+ if (w < 256)
+ {
+ emiti_8_16( bco, i_TEST_INJ_CONST_8, w, 0 );
+ }
+ else
+ {
+ asmWitnessConst( bco, w );
+ emiti_16( bco, i_TEST_INJ, 0 );
+ decSp(bco, repSizeW(WITNESS_REP)); /* pop witness */
+ }
+ return bco->n_insns;
+}
+
+
+void asmWitnessRel( AsmBCO bco, AsmVar var, AsmWitness w )
+{
+ int offset = bco->sp - var;
+
+ if (w == 0)
+ {
+ asmVar( bco, var, WITNESS_REP );
+ }
+ else if (w < 256 && offset < 256 && offset >= 0)
+ {
+ emiti_8_8( bco, i_ADD_WORD_VAR_8, offset, w );
+ incSp( bco, repSizeW(WITNESS_REP)); /* push result */
+ }
+ else
+ {
+ asmWitnessConst( bco, w );
+ emit_i_ADD_WORD_VAR( bco, bco->sp - var );
+ decSp( bco, repSizeW(WITNESS_REP)); /* pop witness w */
+ incSp( bco, repSizeW(WITNESS_REP)); /* push witness result */
+ }
+}
+
+void asmWitnessConst( AsmBCO bco, AsmWitness w )
+{
+ if (w < 256)
+ {
+ emiti_8( bco, i_CONST_WORD_8, w );
+ incSp( bco, repSizeW(WITNESS_REP)); /* push witness */
+ }
+ else
+ {
+ asmConstWord( bco, w );
+ }
+}
+
+#endif
+
+
+#ifdef XMLAMBDA
+/* -----------------------------------------------------------------------
+ Calling c functions
+------------------------------------------------------------------------*/
+#include "ForeignCall.h" /* for CallInfo definition */
+#include "Dynamic.h" /* for loadLibrarySymbol & decorateSymbol */
+
+void asmEndPrimCallIndirect(
+ AsmBCO bco
+ , AsmSp base
+ , const char* argTypes
+ , const char* resultTypes
+ , CallType callType )
+{
+static AsmPrim primCCall
+ = { "ccall", 0, 0, MONAD_Id, i_PRIMOP2, i_ccall };
+
+ CallInfo callInfo;
+ StgWord offset = 0;
+ int argCount = argTypes ? strlen(argTypes) : 0;
+ int resultCount = resultTypes ? strlen(resultTypes) : 0;
+
+ if (argCount + resultCount > MAX_CALL_VALUES)
+ barf( "external call: too many arguments and/or results" );
+
+ /* initialize the callInfo structure */
+ callInfo.argCount = argCount;
+ callInfo.resultCount = resultCount;
+ callInfo.callConv = CCall;
+ callInfo.data[0] = '\0';
+ callInfo.data[1] = '\0';
+
+ switch (callType)
+ {
+ case CCall: callInfo.callConv = CCall; break;
+ case StdCall: callInfo.callConv = StdCall; break;
+ default: belch( "external call: unknown calling convention: \"%c\"", callType );
+ }
+
+ if (argCount > 0) strcpy(callInfo.data,argTypes);
+ if (resultCount > 0) strcpy(callInfo.data + argCount + 1, resultTypes);
+
+ /* We push the offset of the CallInfo structure in this BCO's
+ non-ptr area as a Word. In the "i_ccall" primitive
+ this offset is used to retrieve the CallInfo again. */
+ offset = bco->n_words;
+ asmAddNonPtrWords(bco,CallInfo,callInfo);
+ asmConstWord(bco,offset);
+
+ /* emit a ccall */
+ asmEndPrim( bco, &primCCall, base );
+ return;
+}
+
+
+void asmEndPrimCallDynamic(
+ AsmBCO bco
+ , AsmSp base
+ , const char* libName
+ , const char* funName
+ , const char* argTypes
+ , const char* resultTypes
+ , CallType callType
+ , int /*bool*/ decorate )
+{
+ void* funPtr;
+ ASSERT(libName);
+ ASSERT(funName);
+
+ /* load the function pointer */
+ if (decorate)
+ {
+ char funNameBuf[MAX_SYMBOL_NAME];
+ decorateSymbol( funNameBuf, funName, MAX_SYMBOL_NAME
+ , callType, argTypes, resultTypes );
+ funPtr = loadLibrarySymbol( libName, funNameBuf, callType );
+ }
+ else
+ funPtr = loadLibrarySymbol( libName, funName, callType );
+
+ /* push the static function pointer */
+ asmConstAddr( bco, funPtr );
+
+ /* and call it indirectly */
+ asmEndPrimCallIndirect( bco, base, argTypes, resultTypes, callType );
+}
+
+#endif /* XMLAMBDA */
+
+
/*-------------------------------------------------------------------------*/
#endif /* INTERPRETER */
-