* Copyright (c) 1994-1998.
*
* $RCSfile: Assembler.c,v $
- * $Revision: 1.8 $
- * $Date: 1999/04/27 10:07:15 $
+ * $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.
#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"
#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 )
+static void setSp( AsmBCO bco, AsmSp sp )
{
- /* ToDo: sometimes we should test for MIN_UPD_SIZE instead */
- ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
- bco->hp += size;
+ bco->max_sp = stg_max(bco->sp,bco->max_sp);
+ bco->sp = sp;
+ bco->max_sp = stg_max(bco->sp,bco->max_sp);
}
-static void resetHp( AsmBCO bco, nat hp )
+static void incSp ( AsmBCO bco, int sp_delta )
{
- bco->max_hp = stg_max(bco->hp,bco->max_hp);
- bco->hp = hp;
+ bco->max_sp = stg_max(bco->sp,bco->max_sp);
+ bco->sp += sp_delta;
+ bco->max_sp = stg_max(bco->sp,bco->max_sp);
}
-static void resetSp( AsmBCO bco, AsmSp sp )
+static void decSp ( AsmBCO bco, int sp_delta )
{
- bco->max_sp = stg_max(bco->sp,bco->max_sp);
- bco->sp = sp;
+ bco->max_sp = stg_max(bco->sp,bco->max_sp);
+ bco->sp -= sp_delta;
+ 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 p = bco->object.ptrs.len;
nat np = bco->nps.len;
- nat is = bco->is.len + 2; /* 2 for stack check */
+ 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);
{
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;
+
+ 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);
}
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; \
case CHAR_REP: return sizeofW(StgWord) + sizeofW(StgChar);
case BOOL_REP:
- case INT_REP: return sizeofW(StgWord) + sizeofW(StgInt);
- 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);
-#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);
case INTEGER_REP:
#ifdef PROVIDE_WEAK
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 */
case ARR_REP : /* PrimArray a */
case REF_REP : /* Ref s a */
case MUTARR_REP : /* PrimMutableArray s a */
case MUTBARR_REP: /* PrimMutableByteArray s a */
-#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);
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);
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);
}
}
AsmVar asmBind ( AsmBCO bco, AsmRep rep )
{
- bco->sp += repSizeW(rep);
+ incSp(bco,repSizeW(rep));
return bco->sp;
}
if (rep == VOID_REP) {
emiti_(bco,i_VOID);
- bco->sp += repSizeW(rep);
+ incSp(bco,repSizeW(rep));
return;
}
case INT_REP:
emit_i_VAR_INT(bco,offset);
break;
+ case THREADID_REP:
case WORD_REP:
emit_i_VAR_WORD(bco,offset);
break;
case DOUBLE_REP:
emit_i_VAR_DOUBLE(bco,offset);
break;
-#ifdef PROVIDE_STABLE
case STABLE_REP:
emit_i_VAR_STABLE(bco,offset);
break;
-#endif
case INTEGER_REP:
#ifdef PROVIDE_WEAK
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 */
case ARR_REP : /* PrimArray a */
case REF_REP : /* Ref s a */
case MUTARR_REP : /* PrimMutableArray s a */
case MUTBARR_REP: /* PrimMutableByteArray s a */
-#ifdef PROVIDE_CONCURRENT
- case THREADID_REP: /* ThreadId */
case MVAR_REP: /* MVar a */
-#endif
case PTR_REP:
emit_i_VAR(bco,offset);
break;
default:
barf("asmVar %d",rep);
}
- bco->sp += repSizeW(rep);
+ incSp(bco,repSizeW(rep));
}
/* --------------------------------------------------------------------------
ASSERT(x >= 0 && y >= 0);
if (y != 0) {
emit_i_SLIDE(bco,x,y);
- bco->sp -= sp1 - sp2;
+ decSp(bco,sp1 - sp2);
}
emiti_(bco,i_ENTER);
+ decSp(bco,sizeofW(StgPtr));
}
/* --------------------------------------------------------------------------
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;
-#ifdef PROVIDE_STABLE
case STABLE_REP:
emiti_(bco,i_PACK_STABLE);
- grabHpNonUpd(bco,Stablezh_sizeW);
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;
}
case INT_REP:
emiti_(bco,i_UNPACK_INT);
break;
+ case THREADID_REP:
case WORD_REP:
emiti_(bco,i_UNPACK_WORD);
break;
case DOUBLE_REP:
emiti_(bco,i_UNPACK_DOUBLE);
break;
-#ifdef PROVIDE_STABLE
case STABLE_REP:
emiti_(bco,i_UNPACK_STABLE);
break;
-#endif
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;
}
{
emit_i_CONST_INT(bco,bco->nps.len);
asmWords(bco,AsmInt,x);
- bco->sp += repSizeW(INT_REP);
+ incSp(bco, repSizeW(INT_REP));
}
void asmConstInteger( AsmBCO bco, AsmString x )
{
emit_i_CONST_INTEGER(bco,bco->nps.len);
asmWords(bco,AsmString,x);
- bco->sp += repSizeW(INTEGER_REP);
+ incSp(bco, repSizeW(INTEGER_REP));
}
void asmConstAddr( AsmBCO bco, AsmAddr x )
{
emit_i_CONST_ADDR(bco,bco->nps.len);
asmWords(bco,AsmAddr,x);
- bco->sp += repSizeW(ADDR_REP);
+ incSp(bco, repSizeW(ADDR_REP));
}
void asmConstWord( AsmBCO bco, AsmWord x )
{
emit_i_CONST_INT(bco,bco->nps.len);
asmWords(bco,AsmWord,(AsmInt)x);
- bco->sp += repSizeW(WORD_REP);
+ incSp(bco, repSizeW(WORD_REP));
}
void asmConstChar( AsmBCO bco, AsmChar x )
{
emit_i_CONST_CHAR(bco,bco->nps.len);
asmWords(bco,AsmChar,x);
- bco->sp += repSizeW(CHAR_REP);
+ incSp(bco, repSizeW(CHAR_REP));
}
void asmConstFloat( AsmBCO bco, AsmFloat x )
{
emit_i_CONST_FLOAT(bco,bco->nps.len);
asmWords(bco,AsmFloat,x);
- bco->sp += repSizeW(FLOAT_REP);
+ incSp(bco, repSizeW(FLOAT_REP));
}
void asmConstDouble( AsmBCO bco, AsmDouble x )
{
emit_i_CONST_DOUBLE(bco,bco->nps.len);
asmWords(bco,AsmDouble,x);
- bco->sp += repSizeW(DOUBLE_REP);
+ incSp(bco, repSizeW(DOUBLE_REP));
}
/* --------------------------------------------------------------------------
{
emit_i_RETADDR(bco,bco->object.ptrs.len);
asmPtr(bco,&(ret_addr->object));
- bco->sp += 2 * sizeofW(StgPtr);
+ incSp(bco, 2 * sizeofW(StgPtr));
return bco->sp;
}
AsmBCO asmBeginContinuation ( AsmSp sp, int /*List*/ alts )
{
AsmBCO bco = asmBeginBCO(alts);
- bco->sp = sp;
+ setSp(bco, sp);
return bco;
}
void asmEndAlt( AsmBCO bco, AsmSp sp )
{
- resetSp(bco,sp);
+ setSp(bco,sp);
}
AsmPc asmTest( AsmBCO bco, AsmWord tag )
asmVar(bco,v,INT_REP);
asmConstInt(bco,x);
emiti_16(bco,i_TEST_INT,0);
- bco->sp -= 2*repSizeW(INT_REP);
+ decSp(bco, 2*repSizeW(INT_REP));
return bco->is.len;
}
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);
- bco->sp = base;
+ setSp(bco, base);
+}
+
+char* asmGetPrimopName ( AsmPrim* p )
+{
+ return p->name;
}
/* Hugs used to let you add arbitrary primops with arbitrary types
* 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 }
, { "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 }
, { "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 }
, { "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
/* Integer operations */
, { "primCompareInteger", "ZZ", "I", MONAD_Id, i_PRIMOP1, i_compareInteger }
, { "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 */
#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
#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 };
+
+#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) {
AsmBCO bco = asmBeginBCO(0 /*NIL*/);
emiti_8(bco,i_ARG_CHECK,2);
emiti_8(bco,i_PRIMOP1,i_pushcatchframe);
- bco->sp += (1-2)*sizeofW(StgPtr) + sizeofW(StgCatchFrame);
+ incSp(bco, (1-2)*sizeofW(StgPtr) + sizeofW(StgCatchFrame));
emiti_(bco,i_ENTER);
+ decSp(bco, sizeofW(StgPtr));
asmEndBCO(bco);
return bco;
}
AsmBCO 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;
}
AsmBCO eval, cont;
cont = asmBeginBCO(0 /*NIL*/);
- emiti_8(cont,i_ARG_CHECK,2);
+ 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);
- cont->sp += 3*sizeofW(StgPtr);
+ incSp(cont, 3*sizeofW(StgPtr));
asmEndBCO(cont);
eval = asmBeginBCO(0 /*NIL*/);
emit_i_SLIDE(eval,3,1);
emiti_8(eval,i_PRIMOP1,i_pushseqframe);
emiti_(eval,i_ENTER);
- eval->sp += sizeofW(StgSeqFrame) + 4*sizeofW(StgPtr);
+ incSp(eval, sizeofW(StgSeqFrame) + 4*sizeofW(StgPtr));
asmEndBCO(eval);
return eval;
}
+AsmBCO asm_BCO_takeMVar ( void )
+{
+ AsmBCO kase, casecont, take;
+
+ 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->object.ptrs.len);
+ asmPtr(casecont,&(take->object));
+ 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->object.ptrs.len);
+ asmPtr(kase,&(casecont->object));
+ emit_i_VAR(kase,2);
+ emiti_(kase,i_ENTER);
+ incSp(kase,20);
+ asmEndBCO(kase);
+
+ return kase;
+}
+
+
/* --------------------------------------------------------------------------
* Heap manipulation
* ------------------------------------------------------------------------*/
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);
- 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->nps.len);
+ asmWords(bco,AsmInfo,info);
+ } else {
+ emit_i_ALLOC_CONSTR(bco,i);
+ }
+
+ incSp(bco, sizeofW(StgClosurePtr));
return bco->sp;
}
/* only reason to include info is for this assertion */
assert(info->layout.payload.ptrs == size);
emit_i_PACK(bco, bco->sp - v);
- bco->sp = start;
+ setSp(bco, start);
}
void asmBeginUnpack( AsmBCO bco )
AsmVar asmAllocAP( AsmBCO bco, AsmNat words )
{
emiti_8(bco,i_ALLOC_AP,words);
- bco->sp += sizeofW(StgPtr);
- grabHpUpd(bco,AP_sizeW(words));
+ incSp(bco, sizeofW(StgPtr));
return bco->sp;
}
{
emit_i_MKAP(bco,bco->sp-v,bco->sp-start-1);
/* -1 because fun isn't counted */
- bco->sp = start;
+ setSp(bco, start);
}
AsmVar asmAllocPAP( AsmBCO bco, AsmNat size )
{
emiti_8(bco,i_ALLOC_PAP,size);
- bco->sp += sizeofW(StgPtr);
+ incSp(bco, sizeofW(StgPtr));
return bco->sp;
}
{
emiti_8_8(bco,i_MKPAP,bco->sp-v,bco->sp-start-1);
/* -1 because fun isn't counted */
- bco->sp = start;
+ setSp(bco, start);
}
AsmVar asmClosure( AsmBCO bco, AsmObject p )
{
emit_i_CONST(bco,bco->object.ptrs.len);
asmPtr(bco,p);
- bco->sp += sizeofW(StgPtr);
+ incSp(bco, sizeofW(StgPtr));
return bco->sp;
}
+AsmVar asmGHCClosure( 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);
+ return bco->sp;
+}
+
+
/* --------------------------------------------------------------------------
* Building InfoTables
* ------------------------------------------------------------------------*/
projects / ghc-hetmet.git / blobdiff