* Copyright (c) 1994-1998.
*
* $RCSfile: Assembler.c,v $
- * $Revision: 1.16 $
- * $Date: 1999/11/18 12:10:24 $
+ * $Revision: 1.26 $
+ * $Date: 2000/04/14 15:18:06 $
*
* This module provides functions to construct BCOs and other closures
* required by the bytecode compiler.
#define Queue Instrs
#define Type StgWord8
+#define MAKE_findIn 0
#include "QueueTemplate.h"
+#undef MAKE_findIn
#undef Type
#undef Queue
#define Queue Ptrs
#define Type AsmObject
+#define MAKE_findIn 0
#include "QueueTemplate.h"
+#undef MAKE_findIn
#undef Type
#undef Queue
#define Queue Refs
#define Type AsmRef
+#define MAKE_findIn 0
#include "QueueTemplate.h"
+#undef MAKE_findIn
#undef Type
#undef Queue
#define Queue NonPtrs
#define Type StgWord
+#define MAKE_findIn 1
#include "QueueTemplate.h"
+#undef MAKE_findIn
#undef Type
#undef Queue
/* abstract machine ("executed" during compilation) */
AsmSp sp; /* stack ptr */
AsmSp max_sp;
- StgWord hp; /* heap ptr */
- StgWord max_hp;
Instr lastOpc;
};
case CONSTR:
{
StgClosure* con = stgCast(StgClosure*,obj->closure);
- ASSERT(i < get_itbl(con)->layout.payload.nptrs && payloadCPtr(con,i) == NULL);
- payloadCPtr(con,i) = reference;
+ ASSERT(i < get_itbl(con)->layout.payload.nptrs && con->payload[i] == NULL);
+ con->payload[i] = reference;
break;
}
case AP_UPD:
ASSERT(ap->fun == NULL);
ap->fun = reference;
} else {
- ASSERT(payloadCPtr(ap,i-1) == NULL);
- payloadCPtr(ap,i-1) = reference;
+ ASSERT(ap->payload[i-1] == NULL);
+ ap->payload[i-1] = (StgPtr)reference;
}
break;
}
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);
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; } }
+ mapQueue(Ptrs, AsmObject, con->object.ptrs, o->payload[i] = NULL);
+ { nat i; for( i=0; i<np; ++i ) { o->payload[p+i] = (StgClosure *)0xdeadbeef; }}
asmEndObject(&con->object,c);
}
bco->stgexpr = e;
bco->max_sp = bco->sp = 0;
- bco->max_hp = bco->hp = 0;
bco->lastOpc = i_INTERNAL_ERROR;
return bco;
}
{
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) {
insertNonPtrs( &bco->nps, i );
}
+static int asmFindInNonPtrs ( AsmBCO bco, StgWord i )
+{
+ return findInNonPtrs ( &bco->nps, i );
+}
+
#define asmWords(bco,ty,x) \
{ \
union { ty a; AsmWord b[sizeofW(ty)]; } p; \
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);
+}
+
/* --------------------------------------------------------------------------
* 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:
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 }
#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) {
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->nps.len);
+ asmWords(bco,AsmInfo,info);
+ } else {
+ emit_i_ALLOC_CONSTR(bco,i);
+ }
+
incSp(bco, sizeofW(StgClosurePtr));
- grabHpNonUpd(bco,sizeW_fromITBL(info));
return bco->sp;
}
{
emiti_8(bco,i_ALLOC_AP,words);
incSp(bco, sizeofW(StgPtr));
- grabHpUpd(bco,AP_sizeW(words));
return bco->sp;
}
projects / ghc-hetmet.git / blobdiff