X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FAssembler.c;h=674618597a328ba7175be94b3be02d04227a6087;hb=3d124552f679101c2f6dd98101b10dbcf9ba0898;hp=e755fdd72f8064f4c04dee2e52cc2789fee4c5ea;hpb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;p=ghc-hetmet.git diff --git a/ghc/rts/Assembler.c b/ghc/rts/Assembler.c index e755fdd..6746185 100644 --- a/ghc/rts/Assembler.c +++ b/ghc/rts/Assembler.c @@ -1,12 +1,12 @@ -/* -*- mode: hugs-c; -*- */ + /* -------------------------------------------------------------------------- * Bytecode assembler * * Copyright (c) 1994-1998. * * $RCSfile: Assembler.c,v $ - * $Revision: 1.2 $ - * $Date: 1998/12/02 13:28:09 $ + * $Revision: 1.32 $ + * $Date: 2000/06/15 13:23:51 $ * * This module provides functions to construct BCOs and other closures * required by the bytecode compiler. @@ -49,392 +49,512 @@ #include "Bytecodes.h" #include "Printer.h" #include "Disassembler.h" -#include "Evaluator.h" #include "StgMiscClosures.h" #include "Storage.h" +#include "Schedule.h" +#include "Evaluator.h" #define INSIDE_ASSEMBLER_C #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 - * ------------------------------------------------------------------------*/ +static StgClosure* asmAlloc ( nat size ); +extern void* getNameOrTupleClosureCPtr ( int /*Cell*/ c ); -typedef struct { - AsmObject ref; /* who refers to it */ - AsmNat i; /* index into some table held by referer */ -} AsmRef; + +/* Defined in this file ... */ +AsmObject asmNewObject ( void ); +void asmAddEntity ( AsmObject, Asm_Kind, StgWord ); +int asmCalcHeapSizeW ( AsmObject ); +StgClosure* asmDerefEntity ( Asm_Entity ); /* -------------------------------------------------------------------------- - * Queues (of instructions, ptrs, nonptrs) + * Initialising and managing objects and entities * ------------------------------------------------------------------------*/ -/* ToDo: while debugging, we use a chunk size of 1 to stress-test the code - * this should be fine-tuned using statistics on common sizes - */ +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; \ + } + +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"); + } +} + +/* 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; + } +} + + +/* Throw away n Asm_Insn8 bytes, and slide backwards any Asm_Insn8 entities + as necessary. +*/ +static void asmInstrRecede ( AsmBCO bco, StgInt n ) +{ + 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 int asmFindInNonPtrs ( AsmBCO bco, StgWord w ) +{ + 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; +} + +static void setInstrs ( AsmBCO bco, int instr_no, StgWord new_instr_byte ) +{ + 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"); +} + +void* asmGetClosureOfObject ( AsmObject obj ) +{ + return obj->closure; +} -#define InstrsChunkSize 40 -#define PtrsChunkSize 10 -#define RefsChunkSize 10 -#define NonPtrsChunkSize 10 - -#define Queue Instrs -#define Type StgNat8 -#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 /* -------------------------------------------------------------------------- - * 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. + * Top level assembler/BCO linker functions * ------------------------------------------------------------------------*/ -/* 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 */ +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; +} + + +void asmAllocateHeapSpace ( void ) +{ + AsmObject obj; + for (obj = objects; obj; obj = obj->next) { + StgClosure* c = asmAlloc ( asmCalcHeapSizeW ( obj ) ); + obj->closure = c; + } +} + +void asmShutdown ( void ) +{ + 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; + } + } - AsmInfo info; -}; - -struct AsmCAF_ { - struct AsmObject_ object; /* must be first in struct */ -}; + /* 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; + } + } -struct AsmBCO_ { - struct AsmObject_ object; /* must be first in struct */ - - Instrs is; - NonPtrs nps; - - /* abstract machine ("executed" during compilation) */ - AsmSp sp; /* stack ptr */ - AsmSp max_sp; - StgWord hp; /* heap ptr */ - StgWord max_hp; -}; + /* Finally the insns, adding a stack check at the start. */ + k = 0; + abco->max_sp = stg_max(abco->sp,abco->max_sp); -static void asmResolveRef( AsmObject obj, AsmNat i, AsmClosure reference ) -{ - 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; + 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 CONSTR: - { - StgClosure* con = stgCast(StgClosure*,obj->closure); - ASSERT(i < get_itbl(con)->layout.payload.nptrs && payloadCPtr(con,i) == NULL); - payloadCPtr(con,i) = reference; + } + + 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 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; + } + + 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("asmResolveRef"); - } - obj->num_unresolved -= 1; - - if (obj->num_unresolved == 0) { - /* todo: free the queues */ - - /* we don't print until all ptrs are resolved */ - IF_DEBUG(codegen,printObj(obj->closure)); - } -} + } -static void asmAddRef( AsmObject referent, AsmObject referer, AsmNat i ) -{ - if (referent->closure) { - asmResolveRef(referer,i,(AsmClosure)referent->closure); - } else { - insertRefs(&(referent->refs),(AsmRef){referer,i}); - } + default: + barf("asmCopyAndLink"); + } + } } -void asmAddPtr( AsmObject obj, AsmObject arg ) -{ - ASSERT(obj->closure == 0); /* can't extend an object once it's allocated */ - insertPtrs( &obj->ptrs, arg ); -} -static void asmBeginObject( AsmObject obj ) -{ - obj->closure = NULL; - obj->num_unresolved = 0; - initRefs(&obj->refs); - initPtrs(&obj->ptrs); -} +/* -------------------------------------------------------------------------- + * Keeping track of the simulated stack pointer + * ------------------------------------------------------------------------*/ -static void asmEndObject( AsmObject obj, StgClosure* c ) +static StgClosure* asmAlloc( nat size ) { - 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) { - /* todo: free the queues */ - /* we don't print until all ptrs are resolved */ - IF_DEBUG(codegen,printObj(obj->closure)); - } + StgClosure* o = stgCast(StgClosure*,allocate(size)); + ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) ); + /* printf("Allocated %p .. %p\n", o, o+size-1); */ + return o; } -int asmObjectHasClosure ( AsmObject obj ) +static void setSp( AsmBCO bco, AsmSp sp ) { - return (obj->num_unresolved == 0 && obj->closure); + bco->max_sp = stg_max(bco->sp,bco->max_sp); + bco->sp = sp; + bco->max_sp = stg_max(bco->sp,bco->max_sp); } -AsmClosure asmClosureOfObject ( AsmObject obj ) +static void incSp ( AsmBCO bco, int sp_delta ) { - ASSERT(asmObjectHasClosure(obj)); - return obj->closure; + bco->max_sp = stg_max(bco->sp,bco->max_sp); + bco->sp += sp_delta; + bco->max_sp = stg_max(bco->sp,bco->max_sp); } -void asmMarkObject ( AsmObject obj ) +static void decSp ( AsmBCO bco, int sp_delta ) { - ASSERT(obj->num_unresolved == 0 && obj->closure); - obj->closure = MarkRoot(obj->closure); + bco->max_sp = stg_max(bco->sp,bco->max_sp); + bco->sp -= sp_delta; + bco->max_sp = stg_max(bco->sp,bco->max_sp); } /* -------------------------------------------------------------------------- - * Heap allocation + * * ------------------------------------------------------------------------*/ -static StgClosure* asmAlloc( nat size ) +AsmCon asmBeginCon( AsmInfo info ) { - StgClosure* o = stgCast(StgClosure*,allocate(size)); - ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) ); - /* printf("Allocated %p .. %p\n", o, o+size-1); */ - return o; + AsmCon con = asmNewObject(); + con->kind = Asm_Con; + con->itbl = info; + return con; } -static void grabHpUpd( AsmBCO bco, nat size ) +void asmEndCon( AsmCon con __attribute__ ((unused)) ) { - /* 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 ) +AsmCAF asmBeginCAF( void ) { - /* ToDo: sometimes we should test for MIN_UPD_SIZE instead */ - ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) ); - bco->hp += size; + AsmCAF caf = asmNewObject(); + caf->kind = Asm_CAF; + return caf; } -static void resetHp( AsmBCO bco, nat hp ) +void asmEndCAF( AsmCAF caf __attribute__ ((unused)) ) { - bco->max_hp = stg_max(bco->hp,bco->max_hp); - bco->hp = hp; } -static void resetSp( AsmBCO bco, AsmSp sp ) +AsmBCO asmBeginBCO( int /*StgExpr*/ e ) +{ + 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 __attribute__ ((unused)) ) { - bco->max_sp = stg_max(bco->sp,bco->max_sp); - bco->sp = sp; } /* -------------------------------------------------------------------------- * * ------------------------------------------------------------------------*/ -AsmObject asmMkObject( AsmClosure c ) +static void asmAddInstr ( AsmBCO bco, StgWord i ) { - AsmObject obj = malloc(sizeof(struct AsmObject_)); - if (obj == NULL) { - barf("Can't allocate AsmObject"); - } - asmBeginObject(obj); - asmEndObject(obj,c); - return obj; + asmAddEntity ( bco, Asm_Insn8, i ); } -AsmCon asmBeginCon( AsmInfo info ) +static void asmAddNonPtrWord ( AsmObject obj, StgWord i ) { - AsmCon con = malloc(sizeof(struct AsmCon_)); - if (con == NULL) { - barf("Can't allocate AsmCon"); - } - asmBeginObject(&con->object); - con->info = info; - return con; + asmAddEntity ( obj, Asm_NonPtrWord, i ); } -void asmEndCon( AsmCon con ) +void asmAddRefHugs ( AsmObject obj,int /*Name*/ n ) { - 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; iobject,c); + asmAddEntity ( obj, Asm_RefHugs, n ); } -AsmCAF asmBeginCAF( void ) +void asmAddRefObject ( AsmObject obj, AsmObject p ) { - AsmCAF caf = malloc(sizeof(struct AsmCAF_)); - if (caf == NULL) { - barf("Can't allocate AsmCAF"); - } - asmBeginObject(&caf->object); - return caf; + ASSERT(p->magic == 0x31415927); + asmAddEntity ( obj, Asm_RefObject, (StgWord)p ); } -void asmEndCAF( AsmCAF caf, AsmBCO body ) +void asmAddRefNoOp ( AsmObject obj, StgPtr p ) { - 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); - asmAddPtr(&caf->object,&body->object); - asmEndObject(&caf->object,c); + asmAddEntity ( obj, Asm_RefNoOp, (StgWord)p ); } -AsmBCO asmBeginBCO( void ) -{ - AsmBCO bco = malloc(sizeof(struct AsmBCO_)); - if (bco == NULL) { - barf("Can't allocate AsmBCO"); - } - asmBeginObject(&bco->object); - initInstrs(&bco->is); - initNonPtrs(&bco->nps); - bco->max_sp = bco->sp = 0; - bco->max_hp = bco->hp = 0; - return bco; -} -void asmEndBCO( AsmBCO bco ) +static void asmInstrOp ( AsmBCO bco, StgWord i ) { - nat p = bco->object.ptrs.len; - nat np = bco->nps.len; -#if 0 - nat is = bco->is.len + 4; /* 4 for stack and heap checks */ -#else - nat is = bco->is.len + 2; /* 4 for stack check */ -#endif - - 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; - 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); - bcoInstr(o,j++) = i_STK_CHECK; - bcoInstr(o,j++) = bco->max_sp; -#if 0 - bcoInstr(o,j++) = i_HP_CHECK; - bcoInstr(o,j++) = bco->max_hp; -#endif - mapQueue(Instrs, StgNat8, bco->is, bcoInstr(o,j++) = x); - ASSERT(j == is); - } - asmEndObject(&bco->object,c); + ASSERT(i <= BIGGEST_OPCODE); /* must be a valid opcode */ + bco->lastOpc = i; + asmAddInstr(bco,i); } -/* -------------------------------------------------------------------------- - * - * ------------------------------------------------------------------------*/ - -static void asmInstr( AsmBCO bco, StgWord i ) +static void asmInstr8 ( AsmBCO bco, StgWord i ) { + if (i >= 256) { ASSERT(i < 256); /* must be a byte */ - insertInstrs(&(bco->is),i); + } + asmAddInstr(bco,i); } -static void asmPtr( AsmBCO bco, AsmObject x ) +static void asmInstr16 ( AsmBCO bco, StgWord i ) { - insertPtrs( &bco->object.ptrs, x ); + ASSERT(i < 65536); /* must be a short */ + asmAddInstr(bco,i / 256); + asmAddInstr(bco,i % 256); } -static void asmWord( AsmBCO bco, StgWord i ) -{ - insertNonPtrs( &bco->nps, i ); -} -#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]); \ } \ } @@ -444,25 +564,15 @@ static StgWord repSizeW( AsmRep rep ) case CHAR_REP: return sizeofW(StgWord) + sizeofW(StgChar); case BOOL_REP: - case INT_REP: return sizeofW(StgWord) + sizeofW(StgInt); -#ifdef PROVIDE_INT64 - case INT64_REP: return sizeofW(StgWord) + sizeofW(StgInt64); -#endif -#ifdef PROVIDE_WORD - case WORD_REP: return sizeofW(StgWord) + sizeofW(StgWord); -#endif -#ifdef PROVIDE_ADDR - case ADDR_REP: return sizeofW(StgWord) + sizeofW(StgAddr); -#endif - case FLOAT_REP: return sizeofW(StgWord) + sizeofW(StgFloat); - case DOUBLE_REP: return sizeofW(StgWord) + sizeofW(StgDouble); -#ifdef PROVIDE_STABLE - case STABLE_REP: return sizeofW(StgWord) + sizeofW(StgWord); -#endif + case INT_REP: return sizeofW(StgWord) + sizeofW(StgInt); + case THREADID_REP: + case WORD_REP: return sizeofW(StgWord) + sizeofW(StgWord); + case ADDR_REP: return sizeofW(StgWord) + sizeofW(StgAddr); + case FLOAT_REP: return sizeofW(StgWord) + sizeofW(StgFloat); + case DOUBLE_REP: return sizeofW(StgWord) + sizeofW(StgDouble); + case STABLE_REP: return sizeofW(StgWord) + sizeofW(StgWord); -#ifdef PROVIDE_INTEGER case INTEGER_REP: -#endif #ifdef PROVIDE_WEAK case WEAK_REP: #endif @@ -470,21 +580,17 @@ static StgWord repSizeW( AsmRep rep ) 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 */ -#ifdef PROVIDE_ARRAY case ARR_REP : /* PrimArray a */ case BARR_REP : /* PrimByteArray a */ case REF_REP : /* Ref s a */ case MUTARR_REP : /* PrimMutableArray s a */ case MUTBARR_REP: /* PrimMutableByteArray s a */ -#endif -#ifdef PROVIDE_CONCURRENT - case THREADID_REP: /* ThreadId */ case MVAR_REP: /* MVar a */ -#endif case PTR_REP: return sizeofW(StgPtr); case VOID_REP: return sizeofW(StgWord); @@ -492,6 +598,303 @@ static StgWord repSizeW( AsmRep rep ) } } + +int asmRepSizeW ( AsmRep rep ) +{ + return repSizeW ( rep ); +} + + +/* -------------------------------------------------------------------------- + * Instruction emission. All instructions should be routed through here + * so that the peephole optimiser gets to see what's happening. + * ------------------------------------------------------------------------*/ + +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 */ + x = asmInstrBack(bco,2); + y = asmInstrBack(bco,1); + asmInstrRecede(bco,3); + asmInstrOp(bco,i_SE); asmInstr8(bco,x); asmInstr8(bco,y); + } + else + if (bco->lastOpc == i_RV && opcode == i_ENTER) { + /* RV x y ; ENTER ===> RVE x (y-2) + Because RETADDR pushes 2 words on the stack, y must be at least 2. */ + x = asmInstrBack(bco,2); + y = asmInstrBack(bco,1); + if (y < 2) barf("emiti_: RVE: impossible y value"); + asmInstrRecede(bco,3); + asmInstrOp(bco, i_RVE); asmInstr8(bco,x); asmInstr8(bco,y-2); + } + 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 */ + x = asmInstrBack(bco,1); + asmInstrRecede(bco,2); + asmInstrOp(bco,i_VV); asmInstr8(bco,x); asmInstr8(bco,arg1); + } + else + if (bco->lastOpc == i_RETADDR && opcode == i_VAR) { + /* RETADDR x ; VAR y ===> RV x y */ + x = asmInstrBack(bco,1); + asmInstrRecede(bco,2); + asmInstrOp(bco, i_RV); asmInstr8(bco,x); asmInstr8(bco,arg1); + } + else { + asmInstrOp(bco,opcode); + asmInstr8(bco,arg1); + } +#else + asmInstrOp(bco,opcode); + asmInstr8(bco,arg1); +#endif +} + +static void emiti_16 ( AsmBCO bco, Instr opcode, int arg1 ) +{ + asmInstrOp(bco,opcode); + asmInstr16(bco,arg1); +} + +static void emiti_8_8 ( AsmBCO bco, Instr opcode, int arg1, int arg2 ) +{ + asmInstrOp(bco,opcode); + asmInstr8(bco,arg1); + asmInstr8(bco,arg2); +} + +static void emiti_8_16 ( AsmBCO bco, Instr opcode, int arg1, int arg2 ) +{ + asmInstrOp(bco,opcode); + asmInstr8(bco,arg1); + asmInstr16(bco,arg2); +} + +static void emiti_16_16 ( AsmBCO bco, Instr opcode, int arg1, int arg2 ) +{ + asmInstrOp(bco,opcode); + asmInstr16(bco,arg1); + asmInstr16(bco,arg2); +} + + +/* -------------------------------------------------------------------------- + * Wrappers around the above fns + * ------------------------------------------------------------------------*/ + +static void emit_i_VAR_INT ( AsmBCO bco, int arg1 ) +{ + ASSERT(arg1 >= 0); + if (arg1 < 256) + emiti_8 (bco,i_VAR_INT, arg1); else + emiti_16(bco,i_VAR_INT_big,arg1); +} + +static void emit_i_VAR_WORD ( AsmBCO bco, int arg1 ) +{ + ASSERT(arg1 >= 0); + if (arg1 < 256) + emiti_8 (bco,i_VAR_WORD, arg1); else + emiti_16(bco,i_VAR_WORD_big,arg1); +} + +static void emit_i_VAR_ADDR ( AsmBCO bco, int arg1 ) +{ + ASSERT(arg1 >= 0); + if (arg1 < 256) + emiti_8 (bco,i_VAR_ADDR, arg1); else + emiti_16(bco,i_VAR_ADDR_big,arg1); +} + +static void emit_i_VAR_CHAR ( AsmBCO bco, int arg1 ) +{ + ASSERT(arg1 >= 0); + if (arg1 < 256) + emiti_8 (bco,i_VAR_CHAR, arg1); else + emiti_16(bco,i_VAR_CHAR_big,arg1); +} + +static void emit_i_VAR_FLOAT ( AsmBCO bco, int arg1 ) +{ + ASSERT(arg1 >= 0); + if (arg1 < 256) + emiti_8 (bco,i_VAR_FLOAT, arg1); else + emiti_16(bco,i_VAR_FLOAT_big,arg1); +} + +static void emit_i_VAR_DOUBLE ( AsmBCO bco, int arg1 ) +{ + ASSERT(arg1 >= 0); + if (arg1 < 256) + emiti_8 (bco,i_VAR_DOUBLE, arg1); else + emiti_16(bco,i_VAR_DOUBLE_big,arg1); +} + +static void emit_i_VAR_STABLE ( AsmBCO bco, int arg1 ) +{ + ASSERT(arg1 >= 0); + if (arg1 < 256) + emiti_8 (bco,i_VAR_STABLE, arg1); else + emiti_16(bco,i_VAR_STABLE_big,arg1); +} + +static void emit_i_VAR ( AsmBCO bco, int arg1 ) +{ + ASSERT(arg1 >= 0); + if (arg1 < 256) + emiti_8 (bco,i_VAR, arg1); else + emiti_16(bco,i_VAR_big,arg1); +} + +static void emit_i_PACK ( AsmBCO bco, int arg1 ) +{ + ASSERT(arg1 >= 0); + if (arg1 < 256) + emiti_8 (bco,i_PACK, arg1); else + emiti_16(bco,i_PACK_big,arg1); +} + +static void emit_i_SLIDE ( AsmBCO bco, int arg1, int arg2 ) +{ + ASSERT(arg1 >= 0); + ASSERT(arg2 >= 0); + if (arg1 < 256 && arg2 < 256) + emiti_8_8 (bco,i_SLIDE, arg1,arg2); else + emiti_16_16(bco,i_SLIDE_big,arg1,arg2); +} + +static void emit_i_MKAP ( AsmBCO bco, int arg1, int arg2 ) +{ + ASSERT(arg1 >= 0); + ASSERT(arg2 >= 0); + if (arg1 < 256 && arg2 < 256) + emiti_8_8 (bco,i_MKAP, arg1,arg2); else + emiti_16_16(bco,i_MKAP_big,arg1,arg2); +} + + +static void emit_i_CONST_INT ( AsmBCO bco, int arg1 ) +{ + ASSERT(arg1 >= 0); + if (arg1 < 256) + emiti_8 (bco,i_CONST_INT, arg1); else + emiti_16(bco,i_CONST_INT_big,arg1); +} + +static void emit_i_CONST_INTEGER ( AsmBCO bco, int arg1 ) +{ + ASSERT(arg1 >= 0); + if (arg1 < 256) + emiti_8 (bco,i_CONST_INTEGER, arg1); else + emiti_16(bco,i_CONST_INTEGER_big,arg1); +} + +static void emit_i_CONST_ADDR ( AsmBCO bco, int arg1 ) +{ + ASSERT(arg1 >= 0); + if (arg1 < 256) + emiti_8 (bco,i_CONST_ADDR, arg1); else + emiti_16(bco,i_CONST_ADDR_big,arg1); +} + +static void emit_i_CONST_CHAR ( AsmBCO bco, int arg1 ) +{ + ASSERT(arg1 >= 0); + if (arg1 < 256) + emiti_8 (bco,i_CONST_CHAR, arg1); else + emiti_16(bco,i_CONST_CHAR_big,arg1); +} + +static void emit_i_CONST_FLOAT ( AsmBCO bco, int arg1 ) +{ + ASSERT(arg1 >= 0); + if (arg1 < 256) + emiti_8 (bco,i_CONST_FLOAT, arg1); else + emiti_16(bco,i_CONST_FLOAT_big,arg1); +} + +static void emit_i_CONST_DOUBLE ( AsmBCO bco, int arg1 ) +{ + ASSERT(arg1 >= 0); + if (arg1 < 256) + emiti_8 (bco,i_CONST_DOUBLE, arg1); else + emiti_16(bco,i_CONST_DOUBLE_big,arg1); +} + +static void emit_i_CONST ( AsmBCO bco, int arg1 ) +{ + ASSERT(arg1 >= 0); + if (arg1 < 256) + emiti_8 (bco,i_CONST, arg1); else + emiti_16(bco,i_CONST_big,arg1); +} + +static void emit_i_RETADDR ( AsmBCO bco, int arg1 ) +{ + ASSERT(arg1 >= 0); + if (arg1 < 256) + emiti_8 (bco,i_RETADDR, arg1); else + 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 (AsmBCO bco, int var ) +{ + ASSERT(var >= 0); + if (var < 256) + emiti_8 ( bco, i_PACK_INJ, var ); else + emiti_16( bco, i_PACK_INJ_big, var ); +} + +static void emit_i_TEST_INJ (AsmBCO bco, int var ) +{ + ASSERT(var >= 0); + if (var < 256) + emiti_8_16 ( bco, i_TEST_INJ, var, 0 ); else + emiti_16_16( bco, i_TEST_INJ_big, var, 0 ); +} +#endif + /* -------------------------------------------------------------------------- * Arg checks. * ------------------------------------------------------------------------*/ @@ -506,10 +909,7 @@ void asmEndArgCheck ( AsmBCO bco, AsmSp last_arg ) { nat args = bco->sp - last_arg; if (args != 0) { /* optimisation */ - asmInstr(bco,i_ARG_CHECK); - asmInstr(bco,args); - grabHpNonUpd(bco,PAP_sizeW(args-1)); - resetHp(bco,0); + emiti_8(bco,i_ARG_CHECK,args); } } @@ -519,50 +919,47 @@ void asmEndArgCheck ( AsmBCO bco, AsmSp last_arg ) AsmVar asmBind ( AsmBCO bco, AsmRep rep ) { - bco->sp += repSizeW(rep); + incSp(bco,repSizeW(rep)); return bco->sp; } void asmVar ( AsmBCO bco, AsmVar v, AsmRep rep ) { + int offset; + + if (rep == VOID_REP) { + emiti_(bco,i_VOID); + incSp(bco,repSizeW(rep)); + return; + } + + offset = bco->sp - v; switch (rep) { case BOOL_REP: case INT_REP: - asmInstr(bco,i_VAR_INT); + emit_i_VAR_INT(bco,offset); break; -#ifdef PROVIDE_INT64 - case INT64_REP: - asmInstr(bco,i_VAR_INT64); - break; -#endif -#ifdef PROVIDE_WORD + case THREADID_REP: case WORD_REP: - asmInstr(bco,i_VAR_WORD); + emit_i_VAR_WORD(bco,offset); break; -#endif -#ifdef PROVIDE_ADDR case ADDR_REP: - asmInstr(bco,i_VAR_ADDR); + emit_i_VAR_ADDR(bco,offset); break; -#endif case CHAR_REP: - asmInstr(bco,i_VAR_CHAR); + emit_i_VAR_CHAR(bco,offset); break; case FLOAT_REP: - asmInstr(bco,i_VAR_FLOAT); + emit_i_VAR_FLOAT(bco,offset); break; case DOUBLE_REP: - asmInstr(bco,i_VAR_DOUBLE); + emit_i_VAR_DOUBLE(bco,offset); break; -#ifdef PROVIDE_STABLE case STABLE_REP: - asmInstr(bco,i_VAR_STABLE); + emit_i_VAR_STABLE(bco,offset); break; -#endif -#ifdef PROVIDE_INTEGER case INTEGER_REP: -#endif #ifdef PROVIDE_WEAK case WEAK_REP: #endif @@ -572,32 +969,22 @@ void asmVar ( AsmBCO bco, AsmVar v, AsmRep rep ) case ALPHA_REP: /* a */ case BETA_REP: /* b */ case GAMMA_REP: /* c */ + case DELTA_REP: /* d */ case HANDLER_REP: /* IOError -> IO a */ case ERROR_REP: /* IOError */ -#ifdef PROVIDE_ARRAY case ARR_REP : /* PrimArray a */ case BARR_REP : /* PrimByteArray a */ case REF_REP : /* Ref s a */ case MUTARR_REP : /* PrimMutableArray s a */ case MUTBARR_REP: /* PrimMutableByteArray s a */ -#endif -#ifdef PROVIDE_CONCURRENT - case THREADID_REP: /* ThreadId */ case MVAR_REP: /* MVar a */ -#endif case PTR_REP: - asmInstr(bco,i_VAR); + emit_i_VAR(bco,offset); break; - - case VOID_REP: - asmInstr(bco,i_VOID); - bco->sp += repSizeW(rep); - return; /* NB we don't break! */ default: barf("asmVar %d",rep); } - asmInstr(bco,bco->sp - v); - bco->sp += repSizeW(rep); + incSp(bco,repSizeW(rep)); } /* -------------------------------------------------------------------------- @@ -615,12 +1002,11 @@ void asmEndEnter( AsmBCO bco, AsmSp sp1, AsmSp sp2 ) int y = sp1 - sp2; ASSERT(x >= 0 && y >= 0); if (y != 0) { - asmInstr(bco,i_SLIDE); - asmInstr(bco,x); - asmInstr(bco,y); - bco->sp -= sp1 - sp2; + emit_i_SLIDE(bco,x,y); + decSp(bco,sp1 - sp2); } - asmInstr(bco,i_ENTER); + emiti_(bco,i_ENTER); + decSp(bco,sizeofW(StgPtr)); } /* -------------------------------------------------------------------------- @@ -631,52 +1017,34 @@ AsmVar asmBox( AsmBCO bco, AsmRep rep ) { switch (rep) { case CHAR_REP: - asmInstr(bco,i_PACK_CHAR); - grabHpNonUpd(bco,CZh_sizeW); + emiti_(bco,i_PACK_CHAR); break; case INT_REP: - asmInstr(bco,i_PACK_INT); - grabHpNonUpd(bco,IZh_sizeW); - break; -#ifdef PROVIDE_INT64 - case INT64_REP: - asmInstr(bco,i_PACK_INT64); - grabHpNonUpd(bco,I64Zh_sizeW); + emiti_(bco,i_PACK_INT); break; -#endif -#ifdef PROVIDE_WORD + case THREADID_REP: case WORD_REP: - asmInstr(bco,i_PACK_WORD); - grabHpNonUpd(bco,WZh_sizeW); + emiti_(bco,i_PACK_WORD); break; -#endif -#ifdef PROVIDE_ADDR case ADDR_REP: - asmInstr(bco,i_PACK_ADDR); - grabHpNonUpd(bco,AZh_sizeW); + emiti_(bco,i_PACK_ADDR); break; -#endif case FLOAT_REP: - asmInstr(bco,i_PACK_FLOAT); - grabHpNonUpd(bco,FZh_sizeW); + emiti_(bco,i_PACK_FLOAT); break; case DOUBLE_REP: - asmInstr(bco,i_PACK_DOUBLE); - grabHpNonUpd(bco,DZh_sizeW); + emiti_(bco,i_PACK_DOUBLE); break; -#ifdef PROVIDE_STABLE case STABLE_REP: - asmInstr(bco,i_PACK_STABLE); - grabHpNonUpd(bco,StableZh_sizeW); + emiti_(bco,i_PACK_STABLE); break; -#endif default: barf("asmBox %d",rep); } /* NB: these operations DO pop their arg */ - bco->sp -= repSizeW(rep); /* pop unboxed arg */ - bco->sp += sizeofW(StgPtr); /* push box */ + decSp(bco, repSizeW(rep)); /* pop unboxed arg */ + incSp(bco, sizeofW(StgPtr)); /* push box */ return bco->sp; } @@ -688,109 +1056,35 @@ AsmVar asmUnbox( AsmBCO bco, AsmRep rep ) { switch (rep) { case INT_REP: - asmInstr(bco,i_UNPACK_INT); - break; -#ifdef PROVIDE_INT64 - case INT64_REP: - asmInstr(bco,i_UNPACK_INT64); + emiti_(bco,i_UNPACK_INT); break; -#endif -#ifdef PROVIDE_WORD + case THREADID_REP: case WORD_REP: - asmInstr(bco,i_UNPACK_WORD); + emiti_(bco,i_UNPACK_WORD); break; -#endif -#ifdef PROVIDE_ADDR case ADDR_REP: - asmInstr(bco,i_UNPACK_ADDR); + emiti_(bco,i_UNPACK_ADDR); break; -#endif case CHAR_REP: - asmInstr(bco,i_UNPACK_CHAR); + emiti_(bco,i_UNPACK_CHAR); break; case FLOAT_REP: - asmInstr(bco,i_UNPACK_FLOAT); + emiti_(bco,i_UNPACK_FLOAT); break; case DOUBLE_REP: - asmInstr(bco,i_UNPACK_DOUBLE); + emiti_(bco,i_UNPACK_DOUBLE); break; case STABLE_REP: - asmInstr(bco,i_UNPACK_STABLE); + emiti_(bco,i_UNPACK_STABLE); break; - default: barf("asmUnbox %d",rep); } /* NB: these operations DO NOT pop their arg */ - bco->sp += repSizeW(rep); /* push unboxed arg */ + incSp(bco, repSizeW(rep)); /* push unboxed arg */ return bco->sp; } -/* -------------------------------------------------------------------------- - * Return unboxed Ints, Floats, etc - * ------------------------------------------------------------------------*/ - -void asmReturnUnboxed( AsmBCO bco, AsmRep rep ) -{ - switch (rep) { - case CHAR_REP: - asmInstr(bco,i_RETURN_CHAR); - break; - case INT_REP: - asmInstr(bco,i_RETURN_INT); - break; -#ifdef PROVIDE_INT64 - case INT64_REP: - asmInstr(bco,i_RETURN_INT64); - break; -#endif -#ifdef PROVIDE_WORD - case WORD_REP: - asmInstr(bco,i_RETURN_WORD); - break; -#endif -#ifdef PROVIDE_ADDR - case ADDR_REP: - asmInstr(bco,i_RETURN_ADDR); - break; -#endif - case FLOAT_REP: - asmInstr(bco,i_RETURN_FLOAT); - break; - case DOUBLE_REP: - asmInstr(bco,i_RETURN_DOUBLE); - break; -#ifdef PROVIDE_STABLE - case STABLE_REP: - asmInstr(bco,i_RETURN_STABLE); - break; -#endif -#ifdef PROVIDE_INTEGER - case INTEGER_REP: -#endif -#ifdef PROVIDE_WEAK - case WEAK_REP: -#endif -#ifdef PROVIDE_FOREIGN - case FOREIGN_REP: -#endif -#ifdef PROVIDE_ARRAY - case ARR_REP : /* PrimArray a */ - case BARR_REP : /* PrimByteArray a */ - case REF_REP : /* Ref s a */ - case MUTARR_REP : /* PrimMutableArray s a */ - case MUTBARR_REP: /* PrimMutableByteArray s a */ -#endif -#ifdef PROVIDE_CONCURRENT - case THREADID_REP: /* ThreadId */ - case MVAR_REP: /* MVar a */ -#endif - asmInstr(bco,i_RETURN_GENERIC); - break; - default: - barf("asmReturnUnboxed %d",rep); - } -} /* -------------------------------------------------------------------------- * Push unboxed Ints, Floats, etc @@ -798,78 +1092,55 @@ void asmReturnUnboxed( AsmBCO bco, AsmRep rep ) void asmConstInt( AsmBCO bco, AsmInt x ) { - asmInstr(bco,i_CONST_INT); - asmInstr(bco,bco->nps.len); - asmWords(bco,AsmInt,x); - bco->sp += repSizeW(INT_REP); + emit_i_CONST_INT(bco,bco->n_words); + asmAddNonPtrWords(bco,AsmInt,x); + incSp(bco, repSizeW(INT_REP)); } -#ifdef PROVIDE_INT64 -void asmConstInt64( AsmBCO bco, AsmInt64 x ) -{ - asmInstr(bco,i_CONST_INT64); - asmInstr(bco,bco->nps.len); - asmWords(bco,AsmInt64,x); - bco->sp += repSizeW(INT64_REP); -} -#endif - -#ifdef PROVIDE_INTEGER void asmConstInteger( AsmBCO bco, AsmString x ) { - asmInstr(bco,i_CONST_INTEGER); - asmInstr(bco,bco->nps.len); - asmWords(bco,AsmString,x); - bco->sp += repSizeW(INTEGER_REP); + emit_i_CONST_INTEGER(bco,bco->n_words); + asmAddNonPtrWords(bco,AsmString,x); + incSp(bco, repSizeW(INTEGER_REP)); } -#endif -#ifdef PROVIDE_ADDR void asmConstAddr( AsmBCO bco, AsmAddr x ) { - asmInstr(bco,i_CONST_ADDR); - asmInstr(bco,bco->nps.len); - asmWords(bco,AsmAddr,x); - bco->sp += repSizeW(ADDR_REP); + emit_i_CONST_ADDR(bco,bco->n_words); + asmAddNonPtrWords(bco,AsmAddr,x); + incSp(bco, repSizeW(ADDR_REP)); } -#endif -#ifdef PROVIDE_WORD void asmConstWord( AsmBCO bco, AsmWord x ) { - asmInstr(bco,i_CONST_INT); - asmInstr(bco,bco->nps.len); - asmWords(bco,AsmWord,x); - bco->sp += repSizeW(WORD_REP); + emit_i_CONST_INT(bco,bco->n_words); + asmAddNonPtrWords(bco,AsmWord,(AsmInt)x); + incSp(bco, repSizeW(WORD_REP)); } -#endif void asmConstChar( AsmBCO bco, AsmChar x ) { - asmInstr(bco,i_CONST_CHAR); - asmInstr(bco,bco->nps.len); - asmWords(bco,AsmChar,x); - bco->sp += repSizeW(CHAR_REP); + emit_i_CONST_CHAR(bco,bco->n_words); + asmAddNonPtrWords(bco,AsmChar,x); + incSp(bco, repSizeW(CHAR_REP)); } void asmConstFloat( AsmBCO bco, AsmFloat x ) { - asmInstr(bco,i_CONST_FLOAT); - asmInstr(bco,bco->nps.len); - asmWords(bco,AsmFloat,x); - bco->sp += repSizeW(FLOAT_REP); + emit_i_CONST_FLOAT(bco,bco->n_words); + asmAddNonPtrWords(bco,AsmFloat,x); + incSp(bco, repSizeW(FLOAT_REP)); } void asmConstDouble( AsmBCO bco, AsmDouble x ) { - asmInstr(bco,i_CONST_DOUBLE); - asmInstr(bco,bco->nps.len); - asmWords(bco,AsmDouble,x); - bco->sp += repSizeW(DOUBLE_REP); + emit_i_CONST_DOUBLE(bco,bco->n_words); + asmAddNonPtrWords(bco,AsmDouble,x); + incSp(bco, repSizeW(DOUBLE_REP)); } /* -------------------------------------------------------------------------- - * + * Algebraic case helpers * ------------------------------------------------------------------------*/ /* a mildly bogus pair of functions... */ @@ -878,23 +1149,22 @@ AsmSp asmBeginCase( AsmBCO bco ) return bco->sp; } -void asmEndCase( AsmBCO bco ) +void asmEndCase( AsmBCO bco __attribute__ ((unused)) ) { } AsmSp asmContinuation( AsmBCO bco, AsmBCO ret_addr ) { - asmInstr(bco,i_RETADDR); - asmInstr(bco,bco->object.ptrs.len); - asmPtr(bco,&(ret_addr->object)); - bco->sp += 2 * sizeofW(StgPtr); + emit_i_RETADDR(bco,bco->n_refs); + asmAddRefObject(bco,ret_addr); + incSp(bco, 2 * sizeofW(StgPtr)); return bco->sp; } -AsmBCO asmBeginContinuation ( AsmSp sp ) +AsmBCO asmBeginContinuation ( AsmSp sp, int /*List*/ alts ) { - AsmBCO bco = asmBeginBCO(); - bco->sp = sp; + AsmBCO bco = asmBeginBCO(alts); + setSp(bco, sp); return bco; } @@ -903,6 +1173,7 @@ void asmEndContinuation ( AsmBCO bco ) asmEndBCO(bco); } + /* -------------------------------------------------------------------------- * Branches * ------------------------------------------------------------------------*/ @@ -914,43 +1185,36 @@ AsmSp asmBeginAlt( AsmBCO bco ) void asmEndAlt( AsmBCO bco, AsmSp sp ) { -#if 0 - /* This warning is now redundant since we no longer use the hp/max_hp - * information calculated by the assembler - */ -#warning ToDo: adjust hp/max_hp in asmEndAlt -#endif - resetSp(bco,sp); + setSp(bco,sp); } AsmPc asmTest( AsmBCO bco, AsmWord tag ) { - asmInstr(bco,i_TEST); - asmInstr(bco,tag); - asmInstr(bco,0); - return bco->is.len; + emiti_8_16(bco,i_TEST,tag,0); + 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); - asmInstr(bco,i_TEST_INT); - asmInstr(bco,0); - bco->sp -= 2*repSizeW(INT_REP); - return bco->is.len; + emiti_16(bco,i_TEST_INT,0); + decSp(bco, 2*repSizeW(INT_REP)); + 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); - setInstrs(&(bco->is),from-1,distance); + ASSERT(distance < 65536); + setInstrs(bco,from-2,distance/256); + setInstrs(bco,from-1,distance%256); } void asmPanic( AsmBCO bco ) { - asmInstr(bco,i_PANIC); /* "irrefutable" pattern failed - oops! */ + emiti_(bco,i_PANIC); /* "irrefutable" pattern failed - oops! */ } /* -------------------------------------------------------------------------- @@ -962,11 +1226,15 @@ AsmSp asmBeginPrim( 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 ) { - asmInstr(bco,prim->prefix); - asmInstr(bco,prim->opcode); - bco->sp = base; + return p->name; } /* Hugs used to let you add arbitrary primops with arbitrary types @@ -974,7 +1242,7 @@ void asmEndPrim( AsmBCO bco, const AsmPrim* prim, AsmSp base ) * 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 } @@ -1007,49 +1275,10 @@ const AsmPrim asmPrimOps[] = { , { "primOrInt", "II", "I", MONAD_Id, i_PRIMOP1, i_orInt } , { "primXorInt", "II", "I", MONAD_Id, i_PRIMOP1, i_xorInt } , { "primNotInt", "I", "I", MONAD_Id, i_PRIMOP1, i_notInt } - , { "primShiftLInt", "IW", "I", MONAD_Id, i_PRIMOP1, i_shiftLInt } - , { "primShiftRAInt", "IW", "I", MONAD_Id, i_PRIMOP1, i_shiftRAInt } - , { "primShiftRLInt", "IW", "I", MONAD_Id, i_PRIMOP1, i_shiftRLInt } - -#ifdef PROVIDE_INT64 - /* Int64# operations */ - , { "primGtInt64", "zz", "B", MONAD_Id, i_PRIMOP1, i_gtInt64 } - , { "primGeInt64", "zz", "B", MONAD_Id, i_PRIMOP1, i_geInt64 } - , { "primEqInt64", "zz", "B", MONAD_Id, i_PRIMOP1, i_eqInt64 } - , { "primNeInt64", "zz", "B", MONAD_Id, i_PRIMOP1, i_neInt64 } - , { "primLtInt64", "zz", "B", MONAD_Id, i_PRIMOP1, i_ltInt64 } - , { "primLeInt64", "zz", "B", MONAD_Id, i_PRIMOP1, i_leInt64 } - , { "primMinInt64", "", "z", MONAD_Id, i_PRIMOP1, i_minInt64 } - , { "primMaxInt64", "", "z", MONAD_Id, i_PRIMOP1, i_maxInt64 } - , { "primPlusInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_plusInt64 } - , { "primMinusInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_minusInt64 } - , { "primTimesInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_timesInt64 } - , { "primQuotInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_quotInt64 } - , { "primRemInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_remInt64 } - , { "primQuotRemInt64", "zz", "zz", MONAD_Id, i_PRIMOP1, i_quotRemInt64 } - , { "primNegateInt64", "z", "z", MONAD_Id, i_PRIMOP1, i_negateInt64 } - - , { "primAndInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_andInt64 } - , { "primOrInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_orInt64 } - , { "primXorInt64", "zz", "z", MONAD_Id, i_PRIMOP1, i_xorInt64 } - , { "primNotInt64", "z", "z", MONAD_Id, i_PRIMOP1, i_notInt64 } - , { "primShiftLInt64", "zW", "z", MONAD_Id, i_PRIMOP1, i_shiftLInt64 } - , { "primShiftRAInt64", "zW", "z", MONAD_Id, i_PRIMOP1, i_shiftRAInt64 } - , { "primShiftRLInt64", "zW", "z", MONAD_Id, i_PRIMOP1, i_shiftRLInt64 } - - , { "primInt64ToInt", "z", "I", MONAD_Id, i_PRIMOP1, i_int64ToInt } - , { "primIntToInt64", "I", "z", MONAD_Id, i_PRIMOP1, i_intToInt64 } -#ifdef PROVIDE_WORD - , { "primInt64ToWord", "z", "W", MONAD_Id, i_PRIMOP1, i_int64ToWord } - , { "primWordToInt64", "W", "z", MONAD_Id, i_PRIMOP1, i_wordToInt64 } -#endif - , { "primInt64ToFloat", "z", "F", MONAD_Id, i_PRIMOP1, i_int64ToFloat } - , { "primFloatToInt64", "F", "z", MONAD_Id, i_PRIMOP1, i_floatToInt64 } - , { "primInt64ToDouble", "z", "D", MONAD_Id, i_PRIMOP1, i_int64ToDouble } - , { "primDoubleToInt64", "D", "z", MONAD_Id, i_PRIMOP1, i_doubleToInt64 } -#endif + , { "primShiftLInt", "II", "I", MONAD_Id, i_PRIMOP1, i_shiftLInt } + , { "primShiftRAInt", "II", "I", MONAD_Id, i_PRIMOP1, i_shiftRAInt } + , { "primShiftRLInt", "II", "I", MONAD_Id, i_PRIMOP1, i_shiftRLInt } -#ifdef PROVIDE_WORD /* Word# operations */ , { "primGtWord", "WW", "B", MONAD_Id, i_PRIMOP1, i_gtWord } , { "primGeWord", "WW", "B", MONAD_Id, i_PRIMOP1, i_geWord } @@ -1077,9 +1306,7 @@ const AsmPrim asmPrimOps[] = { , { "primIntToWord", "I", "W", MONAD_Id, i_PRIMOP1, i_intToWord } , { "primWordToInt", "W", "I", MONAD_Id, i_PRIMOP1, i_wordToInt } -#endif -#ifdef PROVIDE_ADDR /* Addr# operations */ , { "primGtAddr", "AA", "B", MONAD_Id, i_PRIMOP1, i_gtAddr } , { "primGeAddr", "AA", "B", MONAD_Id, i_PRIMOP1, i_geAddr } @@ -1092,48 +1319,34 @@ const AsmPrim asmPrimOps[] = { , { "primIndexCharOffAddr", "AI", "C", MONAD_Id, i_PRIMOP1, i_indexCharOffAddr } , { "primIndexIntOffAddr", "AI", "I", MONAD_Id, i_PRIMOP1, i_indexIntOffAddr } -#ifdef PROVIDE_INT64 - , { "primIndexInt64OffAddr", "AI", "z", MONAD_Id, i_PRIMOP1, i_indexInt64OffAddr } -#endif , { "primIndexWordOffAddr", "AI", "W", MONAD_Id, i_PRIMOP1, i_indexWordOffAddr } , { "primIndexAddrOffAddr", "AI", "A", MONAD_Id, i_PRIMOP1, i_indexAddrOffAddr } , { "primIndexFloatOffAddr", "AI", "F", MONAD_Id, i_PRIMOP1, i_indexFloatOffAddr } , { "primIndexDoubleOffAddr", "AI", "D", MONAD_Id, i_PRIMOP1, i_indexDoubleOffAddr } -#ifdef PROVIDE_STABLE , { "primIndexStableOffAddr", "AI", "s", MONAD_Id, i_PRIMOP1, i_indexStableOffAddr } -#endif + + /* Stable# operations */ + , { "primIntToStablePtr", "I", "s", MONAD_Id, i_PRIMOP1, i_intToStable } + , { "primStablePtrToInt", "s", "I", MONAD_Id, i_PRIMOP1, i_stableToInt } /* These ops really ought to be in the IO monad */ , { "primReadCharOffAddr", "AI", "C", MONAD_ST, i_PRIMOP1, i_readCharOffAddr } , { "primReadIntOffAddr", "AI", "I", MONAD_ST, i_PRIMOP1, i_readIntOffAddr } -#ifdef PROVIDE_INT64 - , { "primReadInt64OffAddr", "AI", "z", MONAD_ST, i_PRIMOP1, i_readInt64OffAddr } -#endif , { "primReadWordOffAddr", "AI", "W", MONAD_ST, i_PRIMOP1, i_readWordOffAddr } , { "primReadAddrOffAddr", "AI", "A", MONAD_ST, i_PRIMOP1, i_readAddrOffAddr } , { "primReadFloatOffAddr", "AI", "F", MONAD_ST, i_PRIMOP1, i_readFloatOffAddr } , { "primReadDoubleOffAddr", "AI", "D", MONAD_ST, i_PRIMOP1, i_readDoubleOffAddr } -#ifdef PROVIDE_STABLE , { "primReadStableOffAddr", "AI", "s", MONAD_ST, i_PRIMOP1, i_readStableOffAddr } -#endif /* These ops really ought to be in the IO monad */ , { "primWriteCharOffAddr", "AIC", "", MONAD_ST, i_PRIMOP1, i_writeCharOffAddr } , { "primWriteIntOffAddr", "AII", "", MONAD_ST, i_PRIMOP1, i_writeIntOffAddr } -#ifdef PROVIDE_INT64 - , { "primWriteInt64OffAddr", "AIz", "", MONAD_ST, i_PRIMOP1, i_writeInt64OffAddr } -#endif , { "primWriteWordOffAddr", "AIW", "", MONAD_ST, i_PRIMOP1, i_writeWordOffAddr } , { "primWriteAddrOffAddr", "AIA", "", MONAD_ST, i_PRIMOP1, i_writeAddrOffAddr } , { "primWriteFloatOffAddr", "AIF", "", MONAD_ST, i_PRIMOP1, i_writeFloatOffAddr } , { "primWriteDoubleOffAddr", "AID", "", MONAD_ST, i_PRIMOP1, i_writeDoubleOffAddr } -#ifdef PROVIDE_STABLE , { "primWriteStableOffAddr", "AIs", "", MONAD_ST, i_PRIMOP1, i_writeStableOffAddr } -#endif - -#endif /* PROVIDE_ADDR */ -#ifdef PROVIDE_INTEGER /* Integer operations */ , { "primCompareInteger", "ZZ", "I", MONAD_Id, i_PRIMOP1, i_compareInteger } , { "primNegateInteger", "Z", "Z", MONAD_Id, i_PRIMOP1, i_negateInteger } @@ -1144,17 +1357,12 @@ const AsmPrim asmPrimOps[] = { , { "primDivModInteger", "ZZ", "ZZ", MONAD_Id, i_PRIMOP1, i_divModInteger } , { "primIntegerToInt", "Z", "I", MONAD_Id, i_PRIMOP1, i_integerToInt } , { "primIntToInteger", "I", "Z", MONAD_Id, i_PRIMOP1, i_intToInteger } - , { "primIntegerToInt64", "Z", "z", MONAD_Id, i_PRIMOP1, i_integerToInt64 } - , { "primInt64ToInteger", "z", "Z", MONAD_Id, i_PRIMOP1, i_int64ToInteger } -#ifdef PROVIDE_WORD , { "primIntegerToWord", "Z", "W", MONAD_Id, i_PRIMOP1, i_integerToWord } , { "primWordToInteger", "W", "Z", MONAD_Id, i_PRIMOP1, i_wordToInteger } -#endif , { "primIntegerToFloat", "Z", "F", MONAD_Id, i_PRIMOP1, i_integerToFloat } , { "primFloatToInteger", "F", "Z", MONAD_Id, i_PRIMOP1, i_floatToInteger } , { "primIntegerToDouble", "Z", "D", MONAD_Id, i_PRIMOP1, i_integerToDouble } , { "primDoubleToInteger", "D", "Z", MONAD_Id, i_PRIMOP1, i_doubleToInteger } -#endif /* Float# operations */ , { "primGtFloat", "FF", "B", MONAD_Id, i_PRIMOP1, i_gtFloat } @@ -1189,14 +1397,8 @@ const AsmPrim asmPrimOps[] = { , { "primCoshFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_coshFloat } , { "primTanhFloat", "F", "F", MONAD_Id, i_PRIMOP1, i_tanhFloat } , { "primPowerFloat", "FF", "F", MONAD_Id, i_PRIMOP1, i_powerFloat } -#ifdef PROVIDE_INT64 - , { "primDecodeFloatz", "F", "zI", MONAD_Id, i_PRIMOP1, i_decodeFloatz } - , { "primEncodeFloatz", "zI", "F", MONAD_Id, i_PRIMOP1, i_encodeFloatz } -#endif -#ifdef PROVIDE_INTEGER , { "primDecodeFloatZ", "F", "ZI", MONAD_Id, i_PRIMOP1, i_decodeFloatZ } , { "primEncodeFloatZ", "ZI", "F", MONAD_Id, i_PRIMOP1, i_encodeFloatZ } -#endif , { "primIsNaNFloat", "F", "B", MONAD_Id, i_PRIMOP1, i_isNaNFloat } , { "primIsInfiniteFloat", "F", "B", MONAD_Id, i_PRIMOP1, i_isInfiniteFloat } , { "primIsDenormalizedFloat", "F", "B", MONAD_Id, i_PRIMOP1, i_isDenormalizedFloat } @@ -1238,29 +1440,20 @@ const AsmPrim asmPrimOps[] = { , { "primCoshDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_coshDouble } , { "primTanhDouble", "D", "D", MONAD_Id, i_PRIMOP1, i_tanhDouble } , { "primPowerDouble", "DD", "D", MONAD_Id, i_PRIMOP1, i_powerDouble } -#ifdef PROVIDE_INT64 - , { "primDecodeDoublez", "D", "zI", MONAD_Id, i_PRIMOP1, i_decodeDoublez } - , { "primEncodeDoublez", "zI", "D", MONAD_Id, i_PRIMOP1, i_encodeDoublez } -#endif -#ifdef PROVIDE_INTEGER , { "primDecodeDoubleZ", "D", "ZI", MONAD_Id, i_PRIMOP1, i_decodeDoubleZ } , { "primEncodeDoubleZ", "ZI", "D", MONAD_Id, i_PRIMOP1, i_encodeDoubleZ } -#endif , { "primIsNaNDouble", "D", "B", MONAD_Id, i_PRIMOP1, i_isNaNDouble } , { "primIsInfiniteDouble", "D", "B", MONAD_Id, i_PRIMOP1, i_isInfiniteDouble } , { "primIsDenormalizedDouble", "D", "B", MONAD_Id, i_PRIMOP1, i_isDenormalizedDouble } , { "primIsNegativeZeroDouble", "D", "B", MONAD_Id, i_PRIMOP1, i_isNegativeZeroDouble } , { "primIsIEEEDouble", "", "B", MONAD_Id, i_PRIMOP1, i_isIEEEDouble } +#ifdef XMLAMBDA + /* primitive row operations. */ + , { "primRowInsertAt", "XIa","X", MONAD_Id, i_PRIMOP2, i_rowInsertAt } + , { "primRowRemoveAt", "XI", "aX", MONAD_Id, i_PRIMOP2, i_rowRemoveAt } +#endif - /* Polymorphic force :: a -> (# #) */ - , { "primForce", "a", "", MONAD_Id, i_PRIMOP2, i_force } - - /* Error operations - not in IO monad! */ - , { "primRaise", "E", "a", MONAD_Id, i_PRIMOP2, i_raise } - , { "primCatch'", "aH", "a", MONAD_Id, i_PRIMOP2, i_catch } - -#ifdef PROVIDE_ARRAY /* Ref operations */ , { "primNewRef", "a", "R", MONAD_ST, i_PRIMOP2, i_newRef } , { "primWriteRef", "Ra", "", MONAD_ST, i_PRIMOP2, i_writeRef } @@ -1291,57 +1484,52 @@ const AsmPrim asmPrimOps[] = { , { "primReadIntArray", "mI", "I", MONAD_ST, i_PRIMOP2, i_readIntArray } , { "primIndexIntArray", "xI", "I", MONAD_Id, i_PRIMOP2, i_indexIntArray } -#ifdef PROVIDE_INT64 - , { "primWriteInt64Array", "mIz", "", MONAD_ST, i_PRIMOP2, i_writeInt64Array } - , { "primReadInt64Array", "mI", "z", MONAD_ST, i_PRIMOP2, i_readInt64Array } - , { "primIndexInt64Array", "xI", "z", MONAD_Id, i_PRIMOP2, i_indexInt64Array } -#endif - /* {new,write,read,index}IntegerArray not provided */ -#ifdef PROVIDE_WORD , { "primWriteWordArray", "mIW", "", MONAD_ST, i_PRIMOP2, i_writeWordArray } , { "primReadWordArray", "mI", "W", MONAD_ST, i_PRIMOP2, i_readWordArray } , { "primIndexWordArray", "xI", "W", MONAD_Id, i_PRIMOP2, i_indexWordArray } -#endif -#ifdef PROVIDE_ADDR , { "primWriteAddrArray", "mIA", "", MONAD_ST, i_PRIMOP2, i_writeAddrArray } , { "primReadAddrArray", "mI", "A", MONAD_ST, i_PRIMOP2, i_readAddrArray } , { "primIndexAddrArray", "xI", "A", MONAD_Id, i_PRIMOP2, i_indexAddrArray } -#endif , { "primWriteFloatArray", "mIF", "", MONAD_ST, i_PRIMOP2, i_writeFloatArray } , { "primReadFloatArray", "mI", "F", MONAD_ST, i_PRIMOP2, i_readFloatArray } , { "primIndexFloatArray", "xI", "F", MONAD_Id, i_PRIMOP2, i_indexFloatArray } - , { "primWriteDoubleArray" , "mID", "", MONAD_ST, i_PRIMOP2, i_writeDoubleArray } , { "primReadDoubleArray", "mI", "D", MONAD_ST, i_PRIMOP2, i_readDoubleArray } , { "primIndexDoubleArray", "xI", "D", MONAD_Id, i_PRIMOP2, i_indexDoubleArray } -#ifdef PROVIDE_STABLE +#if 0 +#ifdef PROVIDE_STABLE , { "primWriteStableArray", "mIs", "", MONAD_ST, i_PRIMOP2, i_writeStableArray } , { "primReadStableArray", "mI", "s", MONAD_ST, i_PRIMOP2, i_readStableArray } , { "primIndexStableArray", "xI", "s", MONAD_Id, i_PRIMOP2, i_indexStableArray } #endif - +#endif /* {new,write,read,index}ForeignObjArray not provided */ -#endif PROVIDE_ARRAY #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 */ , { "primMakeWeak", "bac", "w", MONAD_IO, i_PRIMOP2, i_makeWeak } , { "primDeRefWeak", "w", "Ia", MONAD_IO, i_PRIMOP2, i_deRefWeak } #endif -#ifdef PROVIDE_STABLE /* StablePtr# operations */ , { "primMakeStablePtr", "a", "s", MONAD_IO, i_PRIMOP2, i_makeStablePtr } , { "primDeRefStablePtr", "s", "a", MONAD_IO, i_PRIMOP2, i_deRefStablePtr } , { "primFreeStablePtr", "s", "", MONAD_IO, i_PRIMOP2, i_freeStablePtr } -#endif + + /* foreign export dynamic support */ + , { "primCreateAdjThunkARCH", "sAC","A", MONAD_IO, i_PRIMOP2, i_createAdjThunkARCH } + + /* misc handy hacks */ + , { "primGetArgc", "", "I", MONAD_IO, i_PRIMOP2, i_getArgc } + , { "primGetArgv", "I", "A", MONAD_IO, i_PRIMOP2, i_getArgv } + #ifdef PROVIDE_PTREQUALITY , { "primReallyUnsafePtrEquality", "aa", "B",MONAD_Id, i_PRIMOP2, i_reallyUnsafePtrEquality } #endif @@ -1350,26 +1538,50 @@ const AsmPrim asmPrimOps[] = { #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 } - , { "primSameMVar", "rr", "B", MONAD_Id, i_PRIMOP2, i_sameMVar } - , { "primNewMVar", "", "r", MONAD_IO, i_PRIMOP2, i_newMVar } - , { "primTakeMVar", "r", "a", MONAD_IO, i_PRIMOP2, i_takeMVar } - , { "primPutMVar", "ra", "", MONAD_IO, i_PRIMOP2, i_putMVar } - , { "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 } + /* primTakeMVar is handwritten bytecode */ + , { "primPutMVar", "ra", "", MONAD_IO, i_PRIMOP2, i_putMVar } + , { "primSameMVar", "rr", "B", MONAD_Id, i_PRIMOP2, i_sameMVar } + /* Ccall is polyadic - so it's excluded from this table */ - , { 0,0,0,0 } + , { 0,0,0,0,0,0 } }; -const AsmPrim ccall_Id = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_Id }; -const AsmPrim ccall_IO = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_IO }; +AsmPrim ccall_ccall_Id + = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_ccall_Id }; +AsmPrim ccall_ccall_IO + = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_ccall_IO }; +AsmPrim ccall_stdcall_Id + = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_stdcall_Id }; +AsmPrim ccall_stdcall_IO + = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_stdcall_IO }; -const AsmPrim* asmFindPrim( char* s ) +#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 + +AsmPrim* asmFindPrim( char* s ) { int i; for (i=0; asmPrimOps[i].name; ++i) { @@ -1380,7 +1592,7 @@ const AsmPrim* asmFindPrim( char* s ) return 0; } -const AsmPrim* asmFindPrimop( AsmInstr prefix, AsmInstr op ) +AsmPrim* asmFindPrimop( AsmInstr prefix, AsmInstr op ) { nat i; for (i=0; asmPrimOps[i].name; ++i) { @@ -1392,17 +1604,148 @@ const AsmPrim* asmFindPrimop( AsmInstr prefix, AsmInstr op ) } /* -------------------------------------------------------------------------- + * Handwritten primops + * ------------------------------------------------------------------------*/ + +void* /* StgBCO* */ asm_BCO_catch ( void ) +{ + 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); + + asmAllocateHeapSpace(); + asmCopyAndLink(); + closure = (StgBCO*)(bco->closure); + asmShutdown(); + return closure; +} + +void* /* StgBCO* */ asm_BCO_raise ( void ) +{ + 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); + + asmAllocateHeapSpace(); + asmCopyAndLink(); + closure = (StgBCO*)(bco->closure); + asmShutdown(); + return closure; +} + +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 */ + emit_i_VAR(cont,1); + emit_i_SLIDE(cont,1,2); + emiti_(cont,i_ENTER); + incSp(cont, 3*sizeofW(StgPtr)); + asmEndBCO(cont); + + eval = asmBeginBCO(0 /*NIL*/); + emiti_8(eval,i_ARG_CHECK,2); + 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); + emiti_(eval,i_ENTER); + incSp(eval, sizeofW(StgSeqFrame) + 4*sizeofW(StgPtr)); + asmEndBCO(eval); + + asmAllocateHeapSpace(); + asmCopyAndLink(); + closure = (StgBCO*)(eval->closure); + asmShutdown(); + return closure; +} + +void* /* StgBCO* */ asm_BCO_takeMVar ( void ) +{ + AsmBCO kase, casecont, take; + StgBCO* closure; + asmInitialise(); + + take = asmBeginBCO(0 /*NIL*/); + emit_i_VAR(take,0); + emiti_8(take,i_PRIMOP2,i_takeMVar); + emit_i_VAR(take,3); + emit_i_VAR(take,1); + emit_i_VAR(take,4); + emit_i_SLIDE(take,3,4); + emiti_(take,i_ENTER); + incSp(take,20); + asmEndBCO(take); + + casecont = asmBeginBCO(0 /*NIL*/); + emiti_(casecont,i_UNPACK); + emit_i_VAR(casecont,4); + emit_i_VAR(casecont,4); + emit_i_VAR(casecont,2); + emit_i_CONST(casecont,casecont->n_refs); + asmAddRefObject(casecont,take); + emit_i_SLIDE(casecont,4,5); + emiti_(casecont,i_ENTER); + incSp(casecont,20); + asmEndBCO(casecont); + + kase = asmBeginBCO(0 /*NIL*/); + emiti_8(kase,i_ARG_CHECK,3); + emit_i_RETADDR(kase,kase->n_refs); + asmAddRefObject(kase,casecont); + emit_i_VAR(kase,2); + emiti_(kase,i_ENTER); + incSp(kase,20); + asmEndBCO(kase); + + asmAllocateHeapSpace(); + asmCopyAndLink(); + closure = (StgBCO*)(kase->closure); + asmShutdown(); + return closure; +} + + +/* -------------------------------------------------------------------------- * Heap manipulation * ------------------------------------------------------------------------*/ AsmVar asmAllocCONSTR ( AsmBCO bco, AsmInfo info ) { + int i; ASSERT( sizeW_fromITBL(info) >= MIN_NONUPD_SIZE + sizeofW(StgHeader) ); - asmInstr(bco,i_ALLOC_CONSTR); - asmInstr(bco,bco->nps.len); - asmWords(bco,AsmInfo,info); - bco->sp += sizeofW(StgClosurePtr); - grabHpNonUpd(bco,sizeW_fromITBL(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)); return bco->sp; } @@ -1418,27 +1761,24 @@ void asmEndPack( AsmBCO bco, AsmVar v, AsmSp start, AsmInfo info ) ASSERT(start >= v); /* only reason to include info is for this assertion */ ASSERT(info->layout.payload.ptrs == size); - asmInstr(bco,i_PACK); - asmInstr(bco,bco->sp - v); - bco->sp = start; + 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 */ } void asmEndUnpack( AsmBCO bco ) { - asmInstr(bco,i_UNPACK); + emiti_(bco,i_UNPACK); } AsmVar asmAllocAP( AsmBCO bco, AsmNat words ) { - asmInstr(bco,i_ALLOC_AP); - asmInstr(bco,words); - bco->sp += sizeofW(StgPtr); - grabHpUpd(bco,AP_sizeW(words)); + emiti_8(bco,i_ALLOC_AP,words); + incSp(bco, sizeofW(StgPtr)); return bco->sp; } @@ -1449,17 +1789,15 @@ AsmSp asmBeginMkAP( AsmBCO bco ) void asmEndMkAP( AsmBCO bco, AsmVar v, AsmSp start ) { - asmInstr(bco,i_MKAP); - asmInstr(bco,bco->sp-v); - asmInstr(bco,bco->sp-start-1); /* -1 because fun isn't counted */ - bco->sp = start; + emit_i_MKAP(bco,bco->sp-v,bco->sp-start-1); + /* -1 because fun isn't counted */ + setSp(bco, start); } AsmVar asmAllocPAP( AsmBCO bco, AsmNat size ) { - asmInstr(bco,i_ALLOC_PAP); - asmInstr(bco,size); - bco->sp += sizeofW(StgPtr); + emiti_8(bco,i_ALLOC_PAP,size); + incSp(bco, sizeofW(StgPtr)); return bco->sp; } @@ -1470,29 +1808,36 @@ AsmSp asmBeginMkPAP( AsmBCO bco ) void asmEndMkPAP( AsmBCO bco, AsmVar v, AsmSp start ) { - asmInstr(bco,i_MKPAP); - asmInstr(bco,bco->sp-v); - asmInstr(bco,bco->sp-start-1); /* -1 because fun isn't counted */ - bco->sp = start; + emiti_8_8(bco,i_MKPAP,bco->sp-v,bco->sp-start-1); + /* -1 because fun isn't counted */ + setSp(bco, start); } -AsmVar asmClosure( AsmBCO bco, AsmObject p ) +AsmVar asmPushRefHugs ( AsmBCO bco, int /*Name*/ n ) { - StgWord o = bco->object.ptrs.len; - if (o < 256) { - asmInstr(bco,i_CONST); - asmInstr(bco,o); - asmPtr(bco,p); - } else { - asmInstr(bco,i_CONST2); - asmInstr(bco,o / 256); - asmInstr(bco,o % 256); - asmPtr(bco,p); - } - bco->sp += sizeofW(StgPtr); + emit_i_CONST(bco,bco->n_refs); + asmAddRefHugs(bco,n); + incSp(bco, sizeofW(StgPtr)); + return bco->sp; +} + +AsmVar asmPushRefObject ( AsmBCO bco, AsmObject p ) +{ + 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; } + /* -------------------------------------------------------------------------- * Building InfoTables * ------------------------------------------------------------------------*/ @@ -1510,7 +1855,6 @@ AsmInfo asmMkInfo( AsmNat tag, AsmNat ptrs ) info->layout.payload.nptrs = nptrs; info->srt_len = tag; info->type = CONSTR; - info->flags = FLAGS_CONSTR; #ifdef USE_MINIINTERPRETER info->entry = stgCast(StgFunPtr,&Hugs_CONSTR_entry); #else @@ -1520,7 +1864,104 @@ AsmInfo asmMkInfo( AsmNat tag, AsmNat ptrs ) return info; } +#ifdef XMLAMBDA +/* ----------------------------------------------------------------------- + All the XMLambda primitives. +------------------------------------------------------------------------*/ + +/* ----------------------------------------------------------------------- + allocation & unpacking of rows +------------------------------------------------------------------------*/ +AsmVar asmAllocRow ( AsmBCO bco, AsmNat 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, AsmNat n /*#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 ) +{ + /* dummy to make it look prettier */ +} + +void asmEndUnpackRow( AsmBCO bco ) +{ + emiti_(bco,i_UNPACK_ROW); +} + +/*------------------------------------------------------------------------ + Inj primitives. + The Inj constructor contains the value and its index: an unboxed int + data Inj = forall a. Inj a Int# + There is no "big" form for the INJ_CONST instructions. The index + is therefore still limited to 256 values. +------------------------------------------------------------------------*/ +AsmVar asmInj( AsmBCO bco, AsmVar index ) +{ + emit_i_PACK_INJ( bco, bco->sp - index ); + + decSp(bco, sizeofW(StgPtr)); /* pop argument value */ + incSp(bco, sizeofW(StgPtr)); /* push Inj result */ + return bco->sp; +} + +AsmVar asmInjConst( AsmBCO bco, AsmIndex x ) +{ + ASSERT( x >= 0 && x <= 255 ); + emiti_8 (bco, i_PACK_INJ_CONST, x ); + + 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 asmTestInj( AsmBCO bco, AsmVar index ) +{ + emit_i_TEST_INJ(bco,bco->sp - index); + return bco->n_insns; +} + +AsmPc asmTestInjConst( AsmBCO bco, AsmIndex x ) +{ + ASSERT( x >= 0 && x <= 255 ); + emiti_8_16 (bco, i_TEST_INJ_CONST, x, 0 ); + return bco->n_insns; +} + +AsmVar asmConstIndex( AsmBCO bco, AsmIndex x ) +{ + ASSERT( x >= 0 && x <= 65535 ); + asmConstInt(bco,x); + return bco->sp; +} +#endif + /*-------------------------------------------------------------------------*/ #endif /* INTERPRETER */ -