/* -----------------------------------------------------------------------------
- * $Id: Assembler.h,v 1.17 2000/08/29 13:34:21 qrczak Exp $
+ * $Id: Assembler.h,v 1.18 2000/10/09 11:21:41 daan Exp $
*
* (c) The GHC Team 1994-1998.
*
/*------------------------------------------------------------------------
XMlambda primitives.
------------------------------------------------------------------------*/
-typedef AsmInt AsmIndex;
+typedef AsmWord AsmWitness;
+#define WITNESS_REP WORD_REP
-/* Rows */
-extern AsmVar asmAllocRow ( AsmBCO bco, AsmNat /*number of fields*/ n );
+/* insert/remove primitives on rows */
+extern void asmEndPrimRowChainInsert( AsmBCO bco, AsmSp base, AsmWord n /* number of args */ );
+extern void asmEndPrimRowChainBuild ( AsmBCO bco, AsmSp base, AsmWord n /* number of args */ );
+extern void asmEndPrimRowChainRemove( AsmBCO bco, AsmSp base, AsmWord n /* number of args */ );
+extern void asmEndPrimRowChainSelect( AsmBCO bco, AsmSp base, AsmWord n /* number of args */ );
+/* pack/unpack instructions for rows */
+extern AsmVar asmAllocRow ( AsmBCO bco, AsmWord /*number of fields*/ n );
extern AsmSp asmBeginPackRow ( AsmBCO bco );
extern void asmEndPackRow ( AsmBCO bco, AsmVar v, AsmSp start,
- AsmNat /*number of fields*/ n );
+ AsmWord /*number of fields*/ n );
extern void asmBeginUnpackRow( AsmBCO bco );
extern void asmEndUnpackRow ( AsmBCO bco );
-extern AsmPrim primRowRemoveAtN;
-extern AsmPrim primRowIndexAtN;
+extern void asmConstRowTriv ( AsmBCO bco );
+
+/* Inj primitives */
+extern AsmVar asmInjRel( AsmBCO bco, AsmVar var, AsmWitness w );
+extern AsmVar asmInjConst( AsmBCO bco, AsmWitness w );
+
+extern AsmPc asmTestInjRel( AsmBCO bco, AsmVar var, AsmWitness w );
+extern AsmPc asmTestInjConst( AsmBCO, AsmWitness w );
+
+extern void asmWitnessRel( AsmBCO bco, AsmVar var, AsmWitness w );
+extern void asmWitnessConst( AsmBCO bco, AsmWitness w );
-/* Inj */
-extern AsmVar asmInj( AsmBCO bco, AsmVar var );
-extern AsmVar asmInjConst( AsmBCO bco, AsmIndex i );
extern AsmVar asmUnInj( AsmBCO bco );
-extern AsmPc asmTestInj( AsmBCO bco, AsmVar var );
-extern AsmPc asmTestInjConst( AsmBCO, AsmIndex i );
-extern AsmVar asmConstIndex( AsmBCO bco, AsmIndex x );
+
#endif
/* --------------------------------------------------------------------------
CFunDescriptor* mkDescriptor( char* as, char* rs );
+#ifdef XMLAMBDA
+
+typedef enum _CallType
+{ CCall = 'c' /* C calling convention */
+, StdCall = 's' /* Standard calling convention */
+} CallType;
+
+/* The asmEndPrimCall*** functions call external functions.
+ Just start with "asmBeginPrim", push the arguments
+ and end with one of these functions. The argument and
+ result types are given as an argument string containing
+ the character representation of AsmRep's. */
+
+/* asmEndPrimCallDynamic calls a function defined in a dynamic link library.
+ If decorate is true, the funName will be decorated according to its
+ calling convention, for example, with CCall an underscore is prefixed */
+extern void asmEndPrimCallDynamic( AsmBCO bco
+ , AsmSp base
+ , const char* libName
+ , const char* funName
+ , const char* argTypes
+ , const char* resultTypes
+ , CallType callType
+ , int /*bool*/ decorate);
+
+/* asmEndPrimCallIndirect calls the function given by its first
+ argument. (ie. push the address just before calling) */
+extern void asmEndPrimCallIndirect( AsmBCO bco
+ , AsmSp base
+ , const char* argTypes
+ , const char* resultTypes
+ , CallType callType );
+
+
+#endif
+
/*-------------------------------------------------------------------------*/
* Copyright (c) 1994-1998.
*
* $RCSfile: Assembler.c,v $
- * $Revision: 1.32 $
- * $Date: 2000/06/15 13:23:51 $
+ * $Revision: 1.33 $
+ * $Date: 2000/10/09 11:18:46 $
*
* This module provides functions to construct BCOs and other closures
* required by the bytecode compiler.
asmInstr16(bco,arg2);
}
+#ifdef XMLAMBDA
+static void emiti_8_8_16 ( AsmBCO bco, Instr opcode, int arg1, int arg2, int arg3 )
+{
+ asmInstrOp(bco,opcode);
+ asmInstr8(bco,arg1);
+ asmInstr8(bco,arg2);
+ asmInstr16(bco,arg3);
+}
+#endif
/* --------------------------------------------------------------------------
* Wrappers around the above fns
emiti_16(bco,i_CONST_ADDR_big,arg1);
}
+static void emit_i_CONST_WORD ( AsmBCO bco, int arg1 )
+{
+ ASSERT(arg1 >= 0);
+ if (arg1 < 256)
+ emiti_8 (bco,i_CONST_WORD, arg1); else
+ emiti_16(bco,i_CONST_WORD_big,arg1);
+}
+
static void emit_i_CONST_CHAR ( AsmBCO bco, int arg1 )
{
ASSERT(arg1 >= 0);
emiti_16( bco, i_PACK_ROW_big, var );
}
-static void emit_i_PACK_INJ (AsmBCO bco, int var )
+static void emit_i_PACK_INJ_VAR (AsmBCO bco, int var )
{
ASSERT(var >= 0);
if (var < 256)
- emiti_8 ( bco, i_PACK_INJ, var ); else
- emiti_16( bco, i_PACK_INJ_big, var );
+ emiti_8 ( bco, i_PACK_INJ_VAR, var ); else
+ emiti_16( bco, i_PACK_INJ_VAR_big, var );
}
-static void emit_i_TEST_INJ (AsmBCO bco, int var )
+static void emit_i_TEST_INJ_VAR (AsmBCO bco, int var )
{
ASSERT(var >= 0);
if (var < 256)
- emiti_8_16 ( bco, i_TEST_INJ, var, 0 ); else
- emiti_16_16( bco, i_TEST_INJ_big, var, 0 );
+ emiti_8_16 ( bco, i_TEST_INJ_VAR, var, 0 ); else
+ emiti_16_16( bco, i_TEST_INJ_VAR_big, var, 0 );
+}
+
+static void emit_i_ADD_WORD_VAR (AsmBCO bco, int var )
+{
+ ASSERT(var >= 0);
+ if (var < 256)
+ emiti_8( bco, i_ADD_WORD_VAR, var ); else
+ emiti_16( bco, i_ADD_WORD_VAR_big, var );
}
#endif
void asmConstWord( AsmBCO bco, AsmWord x )
{
- emit_i_CONST_INT(bco,bco->n_words);
- asmAddNonPtrWords(bco,AsmWord,(AsmInt)x);
+ emit_i_CONST_WORD(bco,bco->n_words);
+ asmAddNonPtrWords(bco,AsmWord,x);
incSp(bco, repSizeW(WORD_REP));
}
#ifdef XMLAMBDA
/* primitive row operations. */
- , { "primRowInsertAt", "XIa","X", MONAD_Id, i_PRIMOP2, i_rowInsertAt }
- , { "primRowRemoveAt", "XI", "aX", MONAD_Id, i_PRIMOP2, i_rowRemoveAt }
+ , { "primRowInsertAt", "XWa","X", MONAD_Id, i_PRIMOP2, i_rowInsertAt }
+ , { "primRowRemoveAt", "XW", "aX", MONAD_Id, i_PRIMOP2, i_rowRemoveAt }
#endif
/* Ref operations */
/* -----------------------------------------------------------------------
All the XMLambda primitives.
------------------------------------------------------------------------*/
+static void asmConstWordOpt( AsmBCO bco, AsmWord w )
+{
+ if (w < 256)
+ {
+ emiti_8( bco, i_CONST_WORD_8, w );
+ incSp( bco, repSizeW(WORD_REP)); /* push word */
+ }
+ else
+ {
+ asmConstWord( bco, w );
+ }
+}
+
+/* -----------------------------------------------------------------------
+ insert/remove primitives on rows
+------------------------------------------------------------------------*/
+void asmEndPrimRowChainInsert( AsmBCO bco, AsmSp base, AsmWord n /* number of args */ )
+{
+static AsmPrim primRowChainInsert
+ = { "primRowChainInsert", 0, 0, MONAD_Id, i_PRIMOP2, i_rowChainInsert };
+
+ nat size = bco->sp - base;
+ ASSERT(bco->sp >= base);
+ ASSERT(n*3 + 1 == size); /* n witness/value pairs + the row */
+
+ asmConstWordOpt(bco, n);
+ asmEndPrim(bco,&primRowChainInsert,base);
+}
+
+void asmEndPrimRowChainBuild( AsmBCO bco, AsmSp base, AsmWord n /* number of args */ )
+{
+static AsmPrim primRowChainBuild
+ = { "primRowChainBuild", 0, 0, MONAD_Id, i_PRIMOP2, i_rowChainBuild };
+
+ nat size = bco->sp - base;
+ ASSERT(bco->sp >= base);
+ ASSERT(n*3 == size); /* n witness/value pairs */
+
+ asmConstWordOpt(bco, n);
+ asmEndPrim(bco,&primRowChainBuild,base);
+}
+
+void asmEndPrimRowChainRemove( AsmBCO bco, AsmSp base, AsmWord n /* number of args */ )
+{
+static AsmPrim primRowChainRemove
+ = { "primRowChainRemove", 0, 0, MONAD_Id, i_PRIMOP2, i_rowChainRemove };
+
+ nat size = bco->sp - base;
+ ASSERT(bco->sp >= base);
+ ASSERT(n*2 + 1 == size); /* n witnesses + the row */
+
+ asmConstWordOpt(bco, n);
+ asmEndPrim(bco,&primRowChainRemove,base);
+}
+
+void asmEndPrimRowChainSelect( AsmBCO bco, AsmSp base, AsmWord n /* number of args */ )
+{
+static AsmPrim primRowChainSelect
+ = { "primRowChainSelect", 0, 0, MONAD_Id, i_PRIMOP2, i_rowChainSelect };
+
+ nat size = bco->sp - base;
+ ASSERT(bco->sp >= base);
+ ASSERT(n*2 + 1 == size); /* n witnesses + the row */
+
+ asmConstWordOpt(bco, n);
+ asmEndPrim(bco,&primRowChainSelect,base);
+}
/* -----------------------------------------------------------------------
allocation & unpacking of rows
------------------------------------------------------------------------*/
-AsmVar asmAllocRow ( AsmBCO bco, AsmNat n /*number of fields*/ )
+AsmVar asmAllocRow ( AsmBCO bco, AsmWord n /*number of fields*/ )
{
emit_i_ALLOC_ROW(bco,n);
return bco->sp;
}
-void asmEndPackRow( AsmBCO bco, AsmVar v, AsmSp start, AsmNat n /*#fields*/ )
+void asmEndPackRow( AsmBCO bco, AsmVar v, AsmSp start, AsmWord n /*number of fields*/ )
{
nat size = bco->sp - start;
ASSERT(bco->sp >= start);
setSp(bco, start);
}
-void asmBeginUnpackRow( AsmBCO bco )
+void asmBeginUnpackRow( AsmBCO bco __attribute__ ((unused)) )
{
/* dummy to make it look prettier */
}
emiti_(bco,i_UNPACK_ROW);
}
+void asmConstRowTriv( AsmBCO bco )
+{
+ emiti_(bco,i_CONST_ROW_TRIV);
+ incSp(bco,sizeofW(StgPtr));
+}
+
/*------------------------------------------------------------------------
Inj primitives.
- The Inj constructor contains the value and its index: an unboxed int
+ The Inj constructor contains the value and its index: an unboxed word
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 );
+AsmVar asmInjRel( AsmBCO bco, AsmVar var, AsmWitness w )
+{
+ int offset = bco->sp - var;
- decSp(bco, sizeofW(StgPtr)); /* pop argument value */
- incSp(bco, sizeofW(StgPtr)); /* push Inj result */
- return bco->sp;
+ if (w == 0)
+ {
+ emit_i_PACK_INJ_VAR( bco, offset );
+ }
+ else if (w < 256 && offset < 256 && offset >= 0)
+ {
+ emiti_8_8( bco, i_PACK_INJ_REL_8, offset, w );
+ }
+ else
+ {
+ asmWitnessRel( bco, var, w );
+ emiti_( bco, i_PACK_INJ );
+ decSp(bco, repSizeW(WITNESS_REP)); /* pop witness */
+ }
+
+ decSp(bco, sizeofW(StgPtr)); /* pop argument value */
+ incSp(bco, sizeofW(StgPtr)); /* push Inj result */
+ return bco->sp;
}
-AsmVar asmInjConst( AsmBCO bco, AsmIndex x )
-{
- ASSERT( x >= 0 && x <= 255 );
- emiti_8 (bco, i_PACK_INJ_CONST, x );
+AsmVar asmInjConst( AsmBCO bco, AsmWitness w )
+{
+ if (w < 256)
+ {
+ emiti_8 (bco, i_PACK_INJ_CONST_8, w );
+ }
+ else
+ {
+ asmWitnessConst( bco, w );
+ emiti_( bco, i_PACK_INJ );
+ decSp(bco, repSizeW(WITNESS_REP)); /* pop witness */
+ }
- decSp(bco, sizeofW(StgPtr)); /* pop argument value */
- incSp(bco, sizeofW(StgPtr)); /* push Inj result */
- return bco->sp;
+ 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;
+ emiti_(bco,i_UNPACK_INJ);
+ incSp(bco, sizeofW(StgPtr)); /* push the value */
+ return bco->sp;
}
-AsmPc asmTestInj( AsmBCO bco, AsmVar index )
+AsmPc asmTestInjRel( AsmBCO bco, AsmVar var, AsmWitness w )
{
- emit_i_TEST_INJ(bco,bco->sp - index);
- return bco->n_insns;
+ int offset = bco->sp - var;
+
+ if (w == 0)
+ {
+ emit_i_TEST_INJ_VAR(bco,offset );
+ }
+ else if (w < 256 && offset < 256 && offset >= 0)
+ {
+ emiti_8_8_16( bco, i_TEST_INJ_REL_8, offset, w, 0 );
+ }
+ else
+ {
+ asmWitnessRel( bco, var, w );
+ emiti_16( bco, i_TEST_INJ, 0 );
+ decSp(bco, repSizeW(WITNESS_REP)); /* pop witness */
+ }
+ return bco->n_insns;
}
-AsmPc asmTestInjConst( AsmBCO bco, AsmIndex x )
+AsmPc asmTestInjConst( AsmBCO bco, AsmWitness w )
{
- ASSERT( x >= 0 && x <= 255 );
- emiti_8_16 (bco, i_TEST_INJ_CONST, x, 0 );
- return bco->n_insns;
+ if (w < 256)
+ {
+ emiti_8_16( bco, i_TEST_INJ_CONST_8, w, 0 );
+ }
+ else
+ {
+ asmWitnessConst( bco, w );
+ emiti_16( bco, i_TEST_INJ, 0 );
+ decSp(bco, repSizeW(WITNESS_REP)); /* pop witness */
+ }
+ return bco->n_insns;
}
-AsmVar asmConstIndex( AsmBCO bco, AsmIndex x )
+
+void asmWitnessRel( AsmBCO bco, AsmVar var, AsmWitness w )
{
- ASSERT( x >= 0 && x <= 65535 );
- asmConstInt(bco,x);
- return bco->sp;
+ int offset = bco->sp - var;
+
+ if (w == 0)
+ {
+ asmVar( bco, var, WITNESS_REP );
+ }
+ else if (w < 256 && offset < 256 && offset >= 0)
+ {
+ emiti_8_8( bco, i_ADD_WORD_VAR_8, offset, w );
+ incSp( bco, repSizeW(WITNESS_REP)); /* push result */
+ }
+ else
+ {
+ asmWitnessConst( bco, w );
+ emit_i_ADD_WORD_VAR( bco, bco->sp - var );
+ decSp( bco, repSizeW(WITNESS_REP)); /* pop witness w */
+ incSp( bco, repSizeW(WITNESS_REP)); /* push witness result */
+ }
+}
+
+void asmWitnessConst( AsmBCO bco, AsmWitness w )
+{
+ if (w < 256)
+ {
+ emiti_8( bco, i_CONST_WORD_8, w );
+ incSp( bco, repSizeW(WITNESS_REP)); /* push witness */
+ }
+ else
+ {
+ asmConstWord( bco, w );
+ }
}
+
#endif
+
+#ifdef XMLAMBDA
+/* -----------------------------------------------------------------------
+ Calling c functions
+------------------------------------------------------------------------*/
+#include "ForeignCall.h" /* for CallInfo definition */
+#include "Dynamic.h" /* for loadLibrarySymbol & decorateSymbol */
+
+void asmEndPrimCallIndirect(
+ AsmBCO bco
+ , AsmSp base
+ , const char* argTypes
+ , const char* resultTypes
+ , CallType callType )
+{
+static AsmPrim primCCall
+ = { "ccall", 0, 0, MONAD_Id, i_PRIMOP2, i_ccall };
+
+ CallInfo callInfo;
+ StgWord offset = 0;
+ int argCount = argTypes ? strlen(argTypes) : 0;
+ int resultCount = resultTypes ? strlen(resultTypes) : 0;
+
+ if (argCount + resultCount > MAX_CALL_VALUES)
+ barf( "external call: too many arguments and/or results" );
+
+ /* initialize the callInfo structure */
+ callInfo.argCount = argCount;
+ callInfo.resultCount = resultCount;
+ callInfo.callConv = CCall;
+ callInfo.data[0] = '\0';
+ callInfo.data[1] = '\0';
+
+ switch (callType)
+ {
+ case CCall: callInfo.callConv = CCall; break;
+ case StdCall: callInfo.callConv = StdCall; break;
+ default: belch( "external call: unknown calling convention: \"%c\"", callType );
+ }
+
+ if (argCount > 0) strcpy(callInfo.data,argTypes);
+ if (resultCount > 0) strcpy(callInfo.data + argCount + 1, resultTypes);
+
+ /* We push the offset of the CallInfo structure in this BCO's
+ non-ptr area as a Word. In the "i_ccall" primitive
+ this offset is used to retrieve the CallInfo again. */
+ offset = bco->n_words;
+ asmAddNonPtrWords(bco,CallInfo,callInfo);
+ asmConstWord(bco,offset);
+
+ /* emit a ccall */
+ asmEndPrim( bco, &primCCall, base );
+ return;
+}
+
+
+void asmEndPrimCallDynamic(
+ AsmBCO bco
+ , AsmSp base
+ , const char* libName
+ , const char* funName
+ , const char* argTypes
+ , const char* resultTypes
+ , CallType callType
+ , int /*bool*/ decorate )
+{
+ void* funPtr;
+ ASSERT(libName);
+ ASSERT(funName);
+
+ /* load the function pointer */
+ if (decorate)
+ {
+ char funNameBuf[MAX_SYMBOL_NAME];
+ decorateSymbol( funNameBuf, funName, MAX_SYMBOL_NAME
+ , callType, argTypes, resultTypes );
+ funPtr = loadLibrarySymbol( libName, funNameBuf, callType );
+ }
+ else
+ funPtr = loadLibrarySymbol( libName, funName, callType );
+
+ /* push the static function pointer */
+ asmConstAddr( bco, funPtr );
+
+ /* and call it indirectly */
+ asmEndPrimCallIndirect( bco, base, argTypes, resultTypes, callType );
+}
+
+#endif /* XMLAMBDA */
+
+
/*-------------------------------------------------------------------------*/
#endif /* INTERPRETER */
/* -----------------------------------------------------------------------------
- * $Id: Bytecodes.h,v 1.16 2000/06/15 13:23:51 daan Exp $
+ * $Id: Bytecodes.h,v 1.17 2000/10/09 11:20:16 daan Exp $
*
* (c) The GHC Team, 1998-1999
*
Ins(i_ALLOC_PAP), \
Ins(i_ALLOC_CONSTR), \
Ins(i_ALLOC_CONSTR_big), \
- Ins(i_ALLOC_ROW), \
- Ins(i_ALLOC_ROW_big), \
Ins(i_MKAP), \
Ins(i_MKAP_big), \
Ins(i_MKPAP), \
Ins(i_PACK), \
Ins(i_PACK_big), \
- Ins(i_PACK_ROW), \
- Ins(i_PACK_ROW_big), \
- Ins(i_PACK_INJ), \
- Ins(i_PACK_INJ_big), \
- Ins(i_PACK_INJ_CONST), \
Ins(i_SLIDE), \
Ins(i_SLIDE_big), \
Ins(i_TEST), \
- Ins(i_TEST_INJ), \
- Ins(i_TEST_INJ_big), \
- Ins(i_TEST_INJ_CONST), \
Ins(i_UNPACK), \
- Ins(i_UNPACK_ROW), \
- Ins(i_UNPACK_INJ), \
Ins(i_VAR), \
Ins(i_VAR_big), \
Ins(i_CONST), \
Ins(i_RETADDR), \
Ins(i_RETADDR_big), \
Ins(i_VOID), \
+ \
+ Ins(i_ALLOC_ROW), \
+ Ins(i_ALLOC_ROW_big), \
+ Ins(i_PACK_ROW), \
+ Ins(i_PACK_ROW_big), \
+ Ins(i_UNPACK_ROW), \
+ Ins(i_CONST_ROW_TRIV), \
+ \
+ Ins(i_PACK_INJ), \
+ Ins(i_PACK_INJ_VAR), \
+ Ins(i_PACK_INJ_VAR_big), \
+ Ins(i_PACK_INJ_CONST_8), \
+ Ins(i_PACK_INJ_REL_8), \
+ Ins(i_TEST_INJ), \
+ Ins(i_TEST_INJ_VAR), \
+ Ins(i_TEST_INJ_VAR_big), \
+ Ins(i_TEST_INJ_CONST_8), \
+ Ins(i_TEST_INJ_REL_8), \
+ Ins(i_UNPACK_INJ), \
+ Ins(i_CONST_WORD_8), \
+ Ins(i_ADD_WORD_VAR), \
+ Ins(i_ADD_WORD_VAR_big), \
+ Ins(i_ADD_WORD_VAR_8), \
+ \
Ins(i_VAR_INT), \
Ins(i_VAR_INT_big), \
Ins(i_CONST_INT), \
Ins(i_VAR_WORD), \
Ins(i_VAR_WORD_big), \
Ins(i_CONST_WORD), \
+ Ins(i_CONST_WORD_big), \
Ins(i_PACK_WORD), \
Ins(i_UNPACK_WORD), \
Ins(i_VAR_ADDR), \
#ifdef XMLAMBDA
/* row primitives. */
, i_rowInsertAt
+ , i_rowChainInsert
+ , i_rowChainBuild
, i_rowRemoveAt
+ , i_rowChainRemove
+ , i_rowChainSelect
#endif
/* Ref operations */
/* CCall! */
+#ifdef XMLAMBDA
+ , i_ccall
+#endif
, i_ccall_ccall_Id
, i_ccall_ccall_IO
, i_ccall_stdcall_Id
/* If you add a new primop to this table, check you don't
* overflow the 256 limit. That is MAX_Primop2 <= 255.
- * Current value (6/10/2000) = 0x44
+ * Current value (1 oct 2000) = 0x48
*/
, MAX_Primop2 = i_ccall_stdcall_IO
} Primop2;
* Copyright (c) 1994-1998.
*
* $RCSfile: Disassembler.c,v $
- * $Revision: 1.13 $
- * $Date: 2000/06/15 13:23:51 $
+ * $Revision: 1.14 $
+ * $Date: 2000/10/09 11:20:16 $
* ---------------------------------------------------------------------------*/
#include "Rts.h"
fprintf(stderr,"%s %d %d",i,x,pc+y);
return pc;
}
+static InstrPtr disIntIntPC ( StgBCO *bco, InstrPtr pc, char* i )
+{
+ StgInt x,y;
+ StgWord z;
+ x = bcoInstr(bco,pc++);
+ y = bcoInstr(bco,pc++);
+ z = bcoInstr16(bco,pc); pc += 2;
+ fprintf(stderr,"%s %d %d %d",i,x,y,pc+z);
+ return pc;
+}
#endif
static InstrPtr disPC ( StgBCO *bco, InstrPtr pc, char* i )
return disInt(bco,pc,"PACK_ROW");
case i_PACK_ROW_big:
return disInt16(bco,pc,"PACK_ROW_big");
-
- case i_PACK_INJ:
- return disInt(bco,pc,"PACK_INJ");
- case i_PACK_INJ_big:
- return disInt16(bco,pc,"PACK_INJ_big");
- case i_PACK_INJ_CONST:
- return disInt(bco,pc,"PACK_INJ_CONST");
-
case i_UNPACK_ROW:
return disNone(bco,pc,"UNPACK_ROW");
+ case i_CONST_ROW_TRIV:
+ return disNone(bco,pc,"CONST_ROW_TRIV");
+
+ case i_PACK_INJ_VAR:
+ return disInt(bco,pc,"PACK_INJ_VAR");
+ case i_PACK_INJ_VAR_big:
+ return disInt16(bco,pc,"PACK_INJ_VAR_big");
+ case i_PACK_INJ_CONST_8:
+ return disInt(bco,pc,"PACK_INJ_CONST_8");
+ case i_PACK_INJ_REL_8:
+ return disIntInt(bco,pc,"PACK_INJ_REL_8");
+ case i_PACK_INJ:
+ return disNone(bco,pc,"PACK_INJ");
+
case i_UNPACK_INJ:
return disNone(bco,pc,"UNPACK_INJ");
+ case i_TEST_INJ_VAR:
+ return disIntPC(bco,pc,"TEST_INJ_VAR");
+ case i_TEST_INJ_VAR_big:
+ return disInt16PC(bco,pc,"TEST_INJ_VAR_big");
+ case i_TEST_INJ_CONST_8:
+ return disIntPC(bco,pc,"TEST_INJ_CONST_8");
+ case i_TEST_INJ_REL_8:
+ return disIntIntPC(bco,pc,"TEST_INJ_REL_8");
case i_TEST_INJ:
- return disIntPC(bco,pc,"TEST_INJ");
- case i_TEST_INJ_big:
- return disInt16PC(bco,pc,"TEST_INJ_big");
- case i_TEST_INJ_CONST:
- return disIntPC(bco,pc,"TEST_INJ_CONST");
+ return disPC(bco,pc,"TEST_INJ");
+
+ case i_CONST_WORD_8:
+ return disInt(bco,pc,"CONST_WORD_8");
+ case i_ADD_WORD_VAR:
+ return disInt(bco,pc,"ADD_WORD_VAR");
+ case i_ADD_WORD_VAR_big:
+ return disInt16(bco,pc,"ADD_WORD_VAR_big");
+ case i_ADD_WORD_VAR_8:
+ return disIntInt(bco,pc,"ADD_WORD_VAR_8");
#endif
case i_VOID:
return disInt(bco,pc,"VAR_WORD");
case i_CONST_WORD:
return disConstInt(bco,pc,"CONST_WORD");
+ case i_CONST_WORD_big:
+ return disConstInt16(bco,pc,"CONST_WORD_big");
case i_PACK_WORD:
return disNone(bco,pc,"PACK_WORD");
case i_UNPACK_WORD:
switch (op) {
case i_INTERNAL_ERROR2:
return disNone(bco,pc,"INTERNAL_ERROR2");
+#ifdef XMLAMBDA
+ case i_rowInsertAt:
+ return disNone(bco,pc,"ROW_INSERT_1");
+ case i_rowChainInsert:
+ return disNone(bco,pc,"ROW_INSERT");
+ case i_rowChainBuild:
+ return disNone(bco,pc,"ROW_BUILD");
+ case i_rowRemoveAt:
+ return disNone(bco,pc,"ROW_REMOVE_1");
+ case i_rowChainRemove:
+ return disNone(bco,pc,"ROW_REMOVE");
+ case i_rowChainSelect:
+ return disNone(bco,pc,"ROW_SELECT");
+ case i_ccall:
+ return disNone(bco,pc,"ccall");
+#endif
case i_ccall_ccall_Id:
return disNone(bco,pc,"ccall_ccall_Id");
case i_ccall_ccall_IO:
* Copyright (c) 1994-1998.
*
* $RCSfile: Evaluator.c,v $
- * $Revision: 1.57 $
- * $Date: 2000/10/09 10:28:33 $
+ * $Revision: 1.58 $
+ * $Date: 2000/10/09 11:20:16 $
* ---------------------------------------------------------------------------*/
#include "Rts.h"
xPushPtr(p);
Continue;
}
-#ifdef XMLAMBDA
- /* allocate rows, implemented on top of Arrays */
- Case(i_ALLOC_ROW):
- {
- StgMutArrPtrs* p;
- int n = BCO_INSTR_8;
- SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + n)); LLL;
- SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS);
- p->ptrs = n;
- xPushPtr(p);
- Continue;
- }
- Case(i_ALLOC_ROW_big):
- {
- StgMutArrPtrs* p;
- int n = BCO_INSTR_16;
- SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + n)); LLL;
- SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS);
- p->ptrs = n;
- xPushPtr(p);
- Continue;
- }
-#endif
Case(i_MKAP):
{
int x = BCO_INSTR_8; /* ToDo: Word not Int! */
);
Continue;
}
+ Case(i_SLIDE):
+ {
+ int x = BCO_INSTR_8;
+ int y = BCO_INSTR_8;
+ ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
+ /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
+ while(--x >= 0) {
+ xSetStackWord(x+y,xStackWord(x));
+ }
+ xSp += y;
+ Continue;
+ }
+ Case(i_SLIDE_big):
+ {
+ int x, y;
+ x = BCO_INSTR_16;
+ y = BCO_INSTR_16;
+ ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
+ /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
+ while(--x >= 0) {
+ xSetStackWord(x+y,xStackWord(x));
+ }
+ xSp += y;
+ Continue;
+ }
+ Case(i_ENTER):
+ {
+ obj = xPopCPtr();
+ goto enterLoop;
+ }
+ Case(i_RETADDR):
+ {
+ xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
+ xPushPtr(stgCast(StgPtr,&ret_bco_info));
+ Continue;
+ }
+ Case(i_TEST):
+ {
+ int tag = BCO_INSTR_8;
+ StgWord offset = BCO_INSTR_16;
+ if (constrTag( (StgClosure*)xStackPtr(0) ) != tag) {
+ bciPtr += offset;
+ }
+ Continue;
+ }
+ Case(i_UNPACK):
+ {
+ StgClosure* o = stgCast(StgClosure*,xStackPtr(0));
+ const StgInfoTable* itbl = get_itbl(o);
+ int i = itbl->layout.payload.ptrs;
+ ASSERT( itbl->type == CONSTR
+ || itbl->type == CONSTR_STATIC
+ || itbl->type == CONSTR_NOCAF_STATIC
+ || itbl->type == CONSTR_1_0
+ || itbl->type == CONSTR_0_1
+ || itbl->type == CONSTR_2_0
+ || itbl->type == CONSTR_1_1
+ || itbl->type == CONSTR_0_2
+ );
+ while (--i>=0) {
+ xPushCPtr(o->payload[i]);
+ }
+ Continue;
+ }
+ Case(i_VAR_big):
+ {
+ int n = BCO_INSTR_16;
+ StgPtr p = xStackPtr(n);
+ xPushPtr(p);
+ Continue;
+ }
+ Case(i_VAR):
+ {
+ StgPtr p = xStackPtr(BCO_INSTR_8);
+ xPushPtr(p);
+ Continue;
+ }
+ Case(i_CONST):
+ {
+ xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,BCO_INSTR_8)));
+ Continue;
+ }
+ Case(i_CONST_big):
+ {
+ int n = BCO_INSTR_16;
+ xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,n)));
+ Continue;
+ }
#ifdef XMLAMBDA
+ /* allocate rows, implemented on top of (frozen) Arrays */
+ Case(i_ALLOC_ROW):
+ {
+ StgMutArrPtrs* p;
+ StgWord n = BCO_INSTR_8;
+ SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + n)); LLL;
+ SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS);
+ p->ptrs = n;
+ xPushPtr(p);
+ Continue;
+ }
+ Case(i_ALLOC_ROW_big):
+ {
+ StgMutArrPtrs* p;
+ StgWord n = BCO_INSTR_16;
+ SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + n)); LLL;
+ SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS);
+ p->ptrs = n;
+ xPushPtr(p);
+ Continue;
+ }
+
/* pack values into a row. */
Case(i_PACK_ROW):
{
- int offset = BCO_INSTR_8;
+ StgWord offset = BCO_INSTR_8;
StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(offset));
StgWord n = p->ptrs;
- nat i;
+ StgWord i;
for (i=0; i<n; ++i)
{
}
Case(i_PACK_ROW_big):
{
- int offset = BCO_INSTR_16;
+ StgWord offset = BCO_INSTR_16;
StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(offset));
StgWord n = p->ptrs;
- nat i;
+ StgWord i;
for (i=0; i<n; ++i)
{
);
Continue;
}
+
+ /* extract all fields of a row */
+ Case(i_UNPACK_ROW):
+ {
+ StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(0));
+ nat i = p->ptrs;
+ while (i > 0)
+ {
+ i--;
+ xPushCPtr(p->payload[i]);
+ }
+ Continue;
+ }
+
+ /* Trivial row (unit) */
+ Case(i_CONST_ROW_TRIV):
+ {
+ StgMutArrPtrs* p;
+ SSS; p = stgCast(StgMutArrPtrs*,grabHpNonUpd(sizeofW(StgMutArrPtrs) + 0)); LLL;
+ SET_HDR(p,&MUT_ARR_PTRS_FROZEN_info,CCCS);
+ p->ptrs = 0;
+ xPushPtr(p);
+ Continue;
+ }
+
/* pack values into an Inj */
- Case(i_PACK_INJ):
+ Case(i_PACK_INJ_VAR):
{
- const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgInt));
- int offset = BCO_INSTR_8;
+ const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord));
+ StgWord offset = BCO_INSTR_8;
StgClosure* o;
SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
SET_HDR(o,Inj_con_info,??);
- payloadWord(o,sizeofW(StgPtr)) = xTaggedStackInt(offset);
+ payloadWord(o,sizeofW(StgPtr)) = xTaggedStackWord(offset);
payloadPtr(o,0) = xPopPtr();
IF_DEBUG(evaluator,
xPushPtr(stgCast(StgPtr,o));
Continue;
}
- Case(i_PACK_INJ_big):
+ Case(i_PACK_INJ_VAR_big):
{
- const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgInt));
- int offset = BCO_INSTR_16;
+ const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord));
+ StgWord offset = BCO_INSTR_16;
StgClosure* o;
SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
SET_HDR(o,Inj_con_info,??);
- payloadWord(o,sizeofW(StgPtr)) = xTaggedStackInt(offset);
+ payloadWord(o,sizeofW(StgPtr)) = xTaggedStackWord(offset);
payloadPtr(o,0) = xPopPtr();
IF_DEBUG(evaluator,
xPushPtr(stgCast(StgPtr,o));
Continue;
}
- Case(i_PACK_INJ_CONST):
+ Case(i_PACK_INJ_CONST_8):
{
- const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgInt));
- int index = BCO_INSTR_8;
+ const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord));
+ StgWord witness = BCO_INSTR_8;
StgClosure* o;
SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
SET_HDR(o,Inj_con_info,??);
- payloadWord(o,sizeofW(StgPtr)) = index;
+ payloadWord(o,sizeofW(StgPtr)) = witness;
payloadPtr(o,0) = xPopPtr();
IF_DEBUG(evaluator,
xPushPtr(stgCast(StgPtr,o));
Continue;
}
-
-#endif /* XMLAMBDA */
- Case(i_SLIDE):
+ Case(i_PACK_INJ_REL_8):
{
- int x = BCO_INSTR_8;
- int y = BCO_INSTR_8;
- ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
- /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
- while(--x >= 0) {
- xSetStackWord(x+y,xStackWord(x));
- }
- xSp += y;
- Continue;
- }
- Case(i_SLIDE_big):
- {
- int x, y;
- x = BCO_INSTR_16;
- y = BCO_INSTR_16;
- ASSERT(xSp+x+y <= stgCast(StgPtr,xSu));
- /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
- while(--x >= 0) {
- xSetStackWord(x+y,xStackWord(x));
- }
- xSp += y;
- Continue;
- }
- Case(i_ENTER):
- {
- obj = xPopCPtr();
- goto enterLoop;
- }
- Case(i_RETADDR):
- {
- xPushPtr(bcoConstPtr(bco,BCO_INSTR_8));
- xPushPtr(stgCast(StgPtr,&ret_bco_info));
+ const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord));
+ StgWord offset = BCO_INSTR_8;
+ StgWord cwitness = BCO_INSTR_8;
+
+ StgClosure* o;
+ SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
+ SET_HDR(o,Inj_con_info,??);
+
+ payloadWord(o,sizeofW(StgPtr)) = xTaggedStackWord(offset) + cwitness;
+ payloadPtr(o,0) = xPopPtr();
+
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ SSS;
+ printObj(stgCast(StgClosure*,o));
+ LLL;
+ );
+ xPushPtr(stgCast(StgPtr,o));
Continue;
}
- Case(i_TEST):
+ Case(i_PACK_INJ):
{
- int tag = BCO_INSTR_8;
- StgWord offset = BCO_INSTR_16;
- if (constrTag( (StgClosure*)xStackPtr(0) ) != tag) {
- bciPtr += offset;
- }
+ const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgWord));
+
+ StgClosure* o;
+ SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
+ SET_HDR(o,Inj_con_info,??);
+
+ payloadWord(o,sizeofW(StgPtr)) = xPopTaggedWord();
+ payloadPtr(o,0) = xPopPtr();
+
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ SSS;
+ printObj(stgCast(StgClosure*,o));
+ LLL;
+ );
+ xPushPtr(stgCast(StgPtr,o));
Continue;
}
-#ifdef XMLAMBDA
- /* Test Inj indices. */
- Case(i_TEST_INJ):
+
+ /* Test Inj witnesses. */
+ Case(i_TEST_INJ_VAR):
{
- int offset = BCO_INSTR_8;
+ StgWord offset = BCO_INSTR_8;
StgWord jump = BCO_INSTR_16;
- int index = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
- if (index != xTaggedStackInt(offset) )
+ StgWord index = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
+ if (index != xTaggedStackWord(offset) )
{
bciPtr += jump;
}
Continue;
}
- Case(i_TEST_INJ_big):
+ Case(i_TEST_INJ_VAR_big):
{
- int offset = BCO_INSTR_16;
+ StgWord offset = BCO_INSTR_16;
StgWord jump = BCO_INSTR_16;
- int index = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
- if (index != xTaggedStackInt(offset) )
+ StgWord index = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
+ if (index != xTaggedStackWord(offset) )
{
bciPtr += jump;
}
Continue;
}
- Case(i_TEST_INJ_CONST):
+ Case(i_TEST_INJ_CONST_8):
{
- int value = BCO_INSTR_8;
- StgWord jump = BCO_INSTR_16;
+ StgWord cwitness = BCO_INSTR_8;
+ StgWord jump = BCO_INSTR_16;
- int index = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
- if (index != value )
+ StgWord witness = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
+ if (witness != cwitness )
{
bciPtr += jump;
}
Continue;
}
-#endif /* XMLAMBDA */
- Case(i_UNPACK):
+ Case(i_TEST_INJ_REL_8):
{
- StgClosure* o = stgCast(StgClosure*,xStackPtr(0));
- const StgInfoTable* itbl = get_itbl(o);
- int i = itbl->layout.payload.ptrs;
- ASSERT( itbl->type == CONSTR
- || itbl->type == CONSTR_STATIC
- || itbl->type == CONSTR_NOCAF_STATIC
- || itbl->type == CONSTR_1_0
- || itbl->type == CONSTR_0_1
- || itbl->type == CONSTR_2_0
- || itbl->type == CONSTR_1_1
- || itbl->type == CONSTR_0_2
- );
- while (--i>=0) {
- xPushCPtr(o->payload[i]);
+ StgWord offset = BCO_INSTR_8;
+ StgWord cwitness = BCO_INSTR_8;
+ StgWord jump = BCO_INSTR_16;
+
+ StgWord witness = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
+ if (witness != xTaggedStackWord(offset) + cwitness )
+ {
+ bciPtr += jump;
}
- Continue;
+ Continue;
}
-#ifdef XMLAMBDA
- /* extract all fields of a row */
- Case(i_UNPACK_ROW):
+ Case(i_TEST_INJ):
{
- StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(0));
- int i = p->ptrs;
- while (--i >= 0)
+ StgWord jump = BCO_INSTR_16;
+ StgWord cwitness = xPopTaggedWord();
+
+ StgWord witness = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
+ if (witness != cwitness )
{
- xPushCPtr(p->payload[i]);
+ bciPtr += jump;
}
Continue;
- }
+ }
+
/* extract the value of an INJ */
Case(i_UNPACK_INJ):
{
xPushPtr(payloadPtr(con,0));
Continue;
}
-#endif /* XMLAMBA */
- Case(i_VAR_big):
+
+ /* optimized witness (word) operations */
+ Case(i_CONST_WORD_8):
{
- int n = BCO_INSTR_16;
- StgPtr p = xStackPtr(n);
- xPushPtr(p);
+ xPushTaggedWord(BCO_INSTR_8);
Continue;
}
- Case(i_VAR):
+ Case(i_ADD_WORD_VAR):
{
- StgPtr p = xStackPtr(BCO_INSTR_8);
- xPushPtr(p);
+ StgWord offset = BCO_INSTR_8;
+ StgWord witness = xTaggedStackWord(offset);
+ witness += xPopTaggedWord();
+ xPushTaggedWord(witness);
Continue;
}
- Case(i_CONST):
+ Case(i_ADD_WORD_VAR_big):
{
- xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,BCO_INSTR_8)));
+ StgWord offset = BCO_INSTR_16;
+ StgWord witness = xTaggedStackWord(offset);
+ witness += xPopTaggedWord();
+ xPushTaggedWord(witness);
Continue;
- }
- Case(i_CONST_big):
- {
- int n = BCO_INSTR_16;
- xPushPtr(stgCast(StgPtr,bcoConstPtr(bco,n)));
+ }
+ Case(i_ADD_WORD_VAR_8):
+ {
+ StgWord offset = BCO_INSTR_8;
+ StgWord inc = BCO_INSTR_8;
+ StgWord witness = xTaggedStackWord(offset);
+ xPushTaggedWord(witness + inc);
Continue;
}
+#endif /* XMLAMBA */
+
Case(i_VOID):
{
SSS; PushTaggedRealWorld(); LLL;
xPushTaggedWord(bcoConstWord(bco,BCO_INSTR_8));
Continue;
}
+ Case(i_CONST_WORD_big):
+ {
+ StgWord n = BCO_INSTR_16;
+ xPushTaggedWord(bcoConstWord(bco,n));
+ Continue;
+ }
Case(i_PACK_WORD):
{
StgClosure* o;
}
#ifdef XMLAMBDA
/*------------------------------------------------------------------------
- Insert and Remove primitives on Rows
+ Insert and Remove primitives on Rows. This is important stuff for
+ XMlambda, these prims are called *all* the time. That's the reason
+ for all the specialized versions of the basic instructions.
+ note: A Gc might move rows around => allocate first, than pop the arguments.
+------------------------------------------------------------------------*/
+
+/*------------------------------------------------------------------------
+ i_rowInsertAt: insert an element into a row
------------------------------------------------------------------------*/
case i_rowInsertAt:
{
- nat j;
- /* get: row, index and value */
- StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,PopPtr());
- nat i = PopTaggedInt();
- StgClosure* x = PopCPtr();
-
- /* allocate new row */
- StgWord n = row->ptrs;
+ StgWord j;
+ StgWord i;
+ StgWord n;
+ StgClosure* x;
+
+ /* allocate a new row before popping arguments */
+ StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0));
StgMutArrPtrs* newRow
- = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n + 1));
+ = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + row->ptrs + 1));
SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
+
+ /* pop row again and pop index and value */
+ row = stgCast(StgMutArrPtrs*,PopPtr());
+ n = row->ptrs;
newRow->ptrs = n+1;
+ i = PopTaggedWord();
+ x = PopCPtr();
+
ASSERT(i <= n);
/* copy the fields, inserting the new value */
break;
}
- case i_rowRemoveAt:
+/*------------------------------------------------------------------------
+ i_rowChainInsert: behaves like a chain of [i_rowInsertAt] calls. This
+ instruction is vital for XMLambda since we would otherwise allocate
+ a lot of intermediate rows.
+ It assumes that the RTS has no NULL pointers.
+ It behaves 'optimal' if the witnesses are ordered, (lowest on the
+ bottom of the stack).
+------------------------------------------------------------------------*/
+#define ROW_HOLE 0
+ case i_rowChainInsert:
{
- nat j;
- /* get row and index */
- StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,PopPtr());
- nat i = PopTaggedInt(); /* or Word?? */
+ StgWord witness, topWitness;
+ StgClosure* value;
+ StgWord j;
+ StgWord i;
+
+ /* pop the number of arguments (=witness/value pairs) */
+ StgWord n = PopTaggedWord();
+
+ /* allocate a new row before popping boxed arguments */
+ StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0));
+ StgMutArrPtrs* newRow
+ = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n + row->ptrs));
+ SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
+
+ /* pop the row and assign again (it may have moved during gc!) */
+ row = stgCast(StgMutArrPtrs*,PopPtr());
+ newRow->ptrs = n + row->ptrs;
+
+ /* zero the fields */
+ for (i = 0; i < newRow->ptrs; i++)
+ {
+ newRow->payload[i] = ROW_HOLE;
+ }
+
+ /* insert all values */
+ topWitness = 0; /*invariant: 1 + maximal witness */
+ for (i = 0; i < n; i++)
+ {
+ witness = PopTaggedWord();
+ value = PopCPtr();
+ if (witness < topWitness)
+ {
+ /* shoot, unordered witnesses, we have to bump up everything */
+ for (j = topWitness; j > witness; j--)
+ {
+ newRow->payload[j] = newRow->payload[j-1];
+ }
+ topWitness += 1;
+ }
+ else
+ {
+ topWitness = witness+1;
+ }
+
+ ASSERT(topWitness <= n);
+ ASSERT(witness < n);
+ newRow->payload[witness] = value;
+ }
+
+ /* copy the values from the old row into the holes */
+ for (j =0, i = 0; i < row->ptrs; j++,i++)
+ {
+ while (newRow->payload[j] != ROW_HOLE) j++;
+ ASSERT(j < n);
+ newRow->payload[j] = row->payload[i];
+ }
+
+ /* push the result */
+ PushPtr(stgCast(StgPtr,newRow));
+ break;
+ }
+
+/*------------------------------------------------------------------------
+ i_rowChainBuild: exactly as [i_rowChainInsert] but builds a row from scratch.
+------------------------------------------------------------------------*/
+ case i_rowChainBuild:
+ {
+ StgWord witness, topWitness;
+ StgClosure* value;
+ StgWord j;
+ StgWord i;
+
+ /* pop the number of arguments (=witness/value pairs) */
+ StgWord n = PopTaggedWord();
+
+ /* allocate a new row before popping boxed arguments */
+ StgMutArrPtrs* newRow
+ = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n));
+ SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
+ newRow->ptrs = n;
+
+ /* insert all values */
+ topWitness = 0; /*invariant: 1 + maximal witness */
+ for (i = 0; i < n; i++)
+ {
+ witness = PopTaggedWord();
+ value = PopCPtr();
+ if (witness < topWitness)
+ {
+ /* shoot, unordered witnesses, we have to bump up everything */
+ for (j = topWitness; j > witness; j--)
+ {
+ newRow->payload[j] = newRow->payload[j-1];
+ }
+ topWitness += 1;
+ }
+ else
+ {
+ topWitness = witness+1;
+ }
+
+ ASSERT(topWitness <= n);
+ ASSERT(witness < n);
+ newRow->payload[witness] = value;
+ }
- /* allocate new row */
- StgWord n = row->ptrs;
+ /* push the result */
+ PushPtr(stgCast(StgPtr,newRow));
+ break;
+ }
+
+/*------------------------------------------------------------------------
+ i_rowRemoveAt: remove an element from a row
+------------------------------------------------------------------------*/
+ case i_rowRemoveAt:
+ {
+ StgWord j;
+ StgWord i;
+ StgWord n;
+
+ /* allocate new row before popping the arguments */
+ StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0));
StgMutArrPtrs* newRow
- = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n - 1));
+ = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + row->ptrs - 1));
SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
+
+ /* pop row again and pop the index */
+ row = stgCast(StgMutArrPtrs*,PopPtr());
+ n = row->ptrs;
newRow->ptrs = n-1;
-
+
+ i = PopTaggedWord();
+
ASSERT(i < n);
/* copy the fields, except for the removed value. */
PushPtr(stgCast(StgPtr,newRow));
break;
}
+
+/*------------------------------------------------------------------------
+ i_rowChainRemove: behaves like a chain of [i_rowRemoveAt] calls. Again,
+ this is a vital instruction to avoid lots of intermediate rows.
+ It behaves 'optimal' if the witnessses are ordered, lowest on the
+ bottom of the stack.
+ The implementation is quite dirty, blame Daan for this :-)
+ (It overwrites witnesses on the stack with results and marks pointers
+ using their lowest bit.)
+------------------------------------------------------------------------*/
+#define MARK(p) (stgCast(StgClosure*,(stgCast(StgWord,(p)) | 0x01)))
+#define UNMARK(p) (stgCast(StgClosure*,(stgCast(StgWord,(p)) & ~0x01)))
+#define ISMARKED(p) ((stgCast(StgWord,(p)) & 0x01) == 0x01)
+
+ case i_rowChainRemove:
+ {
+ const nat sizeofTaggedWord = sizeofW(StgWord) + sizeofW(StackTag);
+ StgWord i;
+ StgWord j;
+ StgWord minWitness;
+ nat base;
+ StgClosure* value;
+
+
+ /* pop number of arguments (=witnesses) */
+ StgWord n = PopTaggedWord();
+
+ /* allocate new row before popping boxed arguments */
+ StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,stackPtr(0));
+ StgMutArrPtrs* newRow
+ = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + row->ptrs - n));
+ SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
+
+ /* pop row and assign again (gc might have moved it) */
+ row = stgCast(StgMutArrPtrs*,PopPtr());
+ newRow->ptrs = row->ptrs - n;
+ ASSERT( row->ptrs > n );
+
+ /* 'push' all elements that are removed */
+ base = n*sizeofTaggedWord;
+ minWitness = row->ptrs;
+ for (i = 1; i <= n; i++)
+ {
+ StgWord witness;
+
+ witness = taggedStackWord( base - i*sizeofTaggedWord );
+ if (witness >= minWitness)
+ {
+ /* shoot, unordered witnesses, we have to search for the value */
+ nat count;
+
+ count = witness - minWitness;
+ witness = minWitness;
+ while (1)
+ {
+ do{ witness++; } while (ISMARKED(row->payload[witness]));
+ if (count == 0) break;
+ count--;
+ }
+ }
+ else
+ {
+ minWitness = witness;
+ }
+ ASSERT( witness < row->ptrs );
+ ASSERT( !ISMARKED(row->payload[witness]) );
+
+ /* mark the element */
+ value = row->payload[witness];
+ row->payload[witness] = MARK(value);
+
+ /* set the value in the stack (overwriting old witnesses!) */
+ setStackPtr( base - i*sizeofW(StgPtr), stgCast(StgPtr,value) );
+ }
+
+ /* pop the garbage from the stack */
+ gSp = gSp + base - n*sizeofW(StgPtr);
+
+ /* copy all remaining elements and clear the marks */
+ for (j = 0, i = 0; i < newRow->ptrs; j++,i++)
+ {
+ while (ISMARKED(row->payload[j]))
+ {
+ row->payload[j] = UNMARK(row->payload[j]);
+ j++;
+ }
+ newRow->payload[i] = row->payload[j];
+ }
+
+ /* unmark tail */
+ while (j < row->ptrs)
+ {
+ value = row->payload[j];
+ if (ISMARKED(value)) row->payload[j] = UNMARK(value);
+ j++;
+ }
+
+#ifdef DEBUG
+ for (i = 0; i < row->ptrs; i++)
+ {
+ ASSERT(!ISMARKED(row->payload[i]));
+ }
+#endif
+
+ /* and push the result row */
+ PushPtr(stgCast(StgPtr,newRow));
+ break;
+ }
+
+/*------------------------------------------------------------------------
+ i_rowChainSelect: behaves exactly like [i_rowChainRemove] but doesn't return
+ the resulting row, only the removed elements.
+------------------------------------------------------------------------*/
+ case i_rowChainSelect:
+ {
+ const nat sizeofTaggedWord = sizeofW(StgWord) + sizeofW(StackTag);
+ StgWord i;
+ StgWord minWitness;
+ nat base;
+ StgClosure* value;
+
+ /* pop number of arguments (=witnesses) and row*/
+ StgWord n = PopTaggedWord();
+ StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,PopPtr());
+ ASSERT( row->ptrs > n );
+
+ /* 'push' all elements that are removed */
+ base = n*sizeofTaggedWord;
+ minWitness = row->ptrs;
+ for (i = 1; i <= n; i++)
+ {
+ StgWord witness;
+
+ witness = taggedStackWord( base - i*sizeofTaggedWord );
+ if (witness >= minWitness)
+ {
+ /* shoot, unordered witnesses, we have to search for the value */
+ nat count;
+
+ count = witness - minWitness;
+ witness = minWitness;
+ while (1)
+ {
+ do{ witness++; } while (ISMARKED(row->payload[witness]));
+ if (count == 0) break;
+ count--;
+ }
+ }
+ else
+ {
+ minWitness = witness;
+ }
+ ASSERT( witness < row->ptrs );
+ ASSERT( !ISMARKED(row->payload[witness]) );
+
+ /* mark the element */
+ value = row->payload[witness];
+ row->payload[witness] = MARK(value);
+
+ /* set the value in the stack (overwriting old witnesses!) */
+ setStackPtr( base - i*sizeofW(StgPtr), stgCast(StgPtr,value) );
+ }
+
+ /* pop the garbage from the stack */
+ gSp = gSp + base - n*sizeofW(StgPtr);
+
+ /* unmark elements */
+ for( i = 0; i < row->ptrs; i++)
+ {
+ value = row->payload[i];
+ if (ISMARKED(value)) row->payload[i] = UNMARK(value);
+ }
+
+#ifdef DEBUG
+ for (i = 0; i < row->ptrs; i++)
+ {
+ ASSERT(!ISMARKED(row->payload[i]));
+ }
+#endif
+ break;
+ }
+
#endif /* XMLAMBDA */
case i_newRef:
break;
}
#endif /* PROVIDE_CONCURRENT */
+#ifdef XMLAMBDA
+ case i_ccall:
+ {
+ CallInfo callInfo;
+ CFunDescriptor descriptor;
+ void (*funPtr)(void);
+
+ StgWord offset = PopTaggedWord(); /* offset into bco nonptr section */
+ funPtr = PopTaggedAddr();
+
+ ASSERT(funPtr != NULL);
+
+ /* copy the complete callinfo, the bco might move during GC! */
+ callInfo = *stgCast(CallInfo*, (*bco)->payload + (*bco)->n_ptrs + offset);
+
+ /* copy info to a CFunDescriptor. just for compatibility. */
+ descriptor.num_args = callInfo.argCount;
+ descriptor.arg_tys = callInfo.data;
+ descriptor.num_results = callInfo.resultCount;
+ descriptor.result_tys = callInfo.data + callInfo.argCount + 1;
+
+ /* call out */
+ switch (ccall( &descriptor, funPtr, bco, callInfo.callConv, cap ))
+ {
+ case 0: break;
+ case 1: barf( "unhandled type or too many args/results in ccall"); break;
+ case 2: barf("ccall not configured correctly for this platform"); break;
+ default: barf("unknown return code from ccall"); break;
+ }
+
+ break;
+ }
+#endif
case i_ccall_ccall_Id:
case i_ccall_ccall_IO:
/* -----------------------------------------------------------------------------
- * $Id: Evaluator.h,v 1.7 2000/04/25 17:47:43 andy Exp $
+ * $Id: Evaluator.h,v 1.8 2000/10/09 11:21:18 daan Exp $
*
* (c) The GHC Team, 1998-1999
*
extern StgPtr PopPtr ( void );
extern int numEnters;
+
+/*-------------------------------------------------------------------------*/
+#ifdef XMLAMBDA
+
+#define MAX_CALL_VALUES 100
+
+/* Self contained CallInfo structure for the i_ccall instruction */
+typedef struct _CallInfo {
+ unsigned int argCount;
+ unsigned int resultCount;
+ char callConv; /* 's'=stdcall, 'c'=ccall */
+
+/* The strings arg_tys and result_tys reside here.
+ This allows us to put the complete CallInfo in the nonptrwords of a BCO */
+ char data[MAX_CALL_VALUES+2];
+} CallInfo;
+
+#endif
projects / ghc-hetmet.git / commitdiff