* Copyright (c) 1994-1998.
*
* $RCSfile: Assembler.c,v $
- * $Revision: 1.31 $
- * $Date: 2000/05/26 10:14:34 $
+ * $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.
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.
* ------------------------------------------------------------------------*/
, { "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
+
/* Ref operations */
, { "primNewRef", "a", "R", MONAD_ST, i_PRIMOP2, i_newRef }
, { "primWriteRef", "Ra", "", MONAD_ST, i_PRIMOP2, i_writeRef }
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 */
/* -----------------------------------------------------------------------------
- * $Id: Bytecodes.h,v 1.15 2000/04/11 20:44:19 panne Exp $
+ * $Id: Bytecodes.h,v 1.16 2000/06/15 13:23:51 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), \
, i_raise
+#ifdef XMLAMBDA
+ /* row primitives. */
+ , i_rowInsertAt
+ , i_rowRemoveAt
+#endif
+
/* Ref operations */
, i_newRef
, i_writeRef
/* If you add a new primop to this table, check you don't
* overflow the 256 limit. That is MAX_Primop2 <= 255.
- * Current value (30/10/98) = 0x42
+ * Current value (6/10/2000) = 0x44
*/
, MAX_Primop2 = i_ccall_stdcall_IO
} Primop2;
* Copyright (c) 1994-1998.
*
* $RCSfile: Disassembler.c,v $
- * $Revision: 1.12 $
- * $Date: 1999/12/07 11:49:11 $
+ * $Revision: 1.13 $
+ * $Date: 2000/06/15 13:23:51 $
* ---------------------------------------------------------------------------*/
#include "Rts.h"
return pc;
}
+#ifdef XMLAMBDA
+static InstrPtr disInt16PC ( StgBCO *bco, InstrPtr pc, char* i )
+{
+ StgInt x;
+ StgWord y;
+ x = bcoInstr(bco,pc); pc += 2;
+ y = bcoInstr16(bco,pc); pc += 2;
+ fprintf(stderr,"%s %d %d",i,x,pc+y);
+ return pc;
+}
+#endif
+
static InstrPtr disPC ( StgBCO *bco, InstrPtr pc, char* i )
{
StgWord y = bcoInstr16(bco,pc); pc += 2;
case i_CONST_big:
return disConstPtr16(bco,pc,"CONST_big");
+#ifdef XMLAMBDA
+ case i_ALLOC_ROW:
+ return disInt(bco,pc,"ALLOC_ROW");
+ case i_ALLOC_ROW_big:
+ return disInt16(bco,pc,"ALLOC_ROW_big");
+ case i_PACK_ROW:
+ 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_UNPACK_INJ:
+ return disNone(bco,pc,"UNPACK_INJ");
+
+ 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");
+#endif
+
case i_VOID:
return disNone(bco,pc,"VOID");
* Copyright (c) 1994-1998.
*
* $RCSfile: Evaluator.c,v $
- * $Revision: 1.54 $
- * $Date: 2000/05/26 10:14:34 $
+ * $Revision: 1.55 $
+ * $Date: 2000/06/15 13:23:51 $
* ---------------------------------------------------------------------------*/
#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;
}
+#ifdef XMLAMBDA
+ /* pack values into a row. */
+ Case(i_PACK_ROW):
+ {
+ int offset = BCO_INSTR_8;
+ StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(offset));
+ StgWord n = p->ptrs;
+ nat i;
+
+ for (i=0; i<n; ++i)
+ {
+ p->payload[i] = xPopCPtr();
+ }
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ SSS;
+ printObj(stgCast(StgClosure*,p));
+ LLL;
+ );
+ Continue;
+ }
+ Case(i_PACK_ROW_big):
+ {
+ int offset = BCO_INSTR_16;
+ StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(offset));
+ StgWord n = p->ptrs;
+ nat i;
+
+ for (i=0; i<n; ++i)
+ {
+ p->payload[i] = xPopCPtr();
+ }
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ SSS;
+ printObj(stgCast(StgClosure*,p));
+ LLL;
+ );
+ Continue;
+ }
+ /* pack values into an Inj */
+ Case(i_PACK_INJ):
+ {
+ const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgInt));
+ int offset = BCO_INSTR_8;
+
+ StgClosure* o;
+ SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
+ SET_HDR(o,Inj_con_info,??);
+
+ payloadWord(o,sizeofW(StgPtr)) = xTaggedStackInt(offset);
+ payloadPtr(o,0) = xPopPtr();
+
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ SSS;
+ printObj(stgCast(StgClosure*,o));
+ LLL;
+ );
+ xPushPtr(stgCast(StgPtr,o));
+ Continue;
+ }
+ Case(i_PACK_INJ_big):
+ {
+ const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgInt));
+ int offset = BCO_INSTR_16;
+
+ StgClosure* o;
+ SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
+ SET_HDR(o,Inj_con_info,??);
+
+ payloadWord(o,sizeofW(StgPtr)) = xTaggedStackInt(offset);
+ payloadPtr(o,0) = xPopPtr();
+
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ SSS;
+ printObj(stgCast(StgClosure*,o));
+ LLL;
+ );
+ xPushPtr(stgCast(StgPtr,o));
+ Continue;
+ }
+ Case(i_PACK_INJ_CONST):
+ {
+ const int size = CONSTR_sizeW(sizeofW(StgPtr),sizeofW(StgInt));
+ int index = BCO_INSTR_8;
+
+ StgClosure* o;
+ SSS; o = (StgClosure*)grabHpNonUpd(size); LLL;
+ SET_HDR(o,Inj_con_info,??);
+
+ payloadWord(o,sizeofW(StgPtr)) = index;
+ payloadPtr(o,0) = xPopPtr();
+
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ SSS;
+ printObj(stgCast(StgClosure*,o));
+ LLL;
+ );
+ xPushPtr(stgCast(StgPtr,o));
+ Continue;
+ }
+
+#endif /* XMLAMBDA */
Case(i_SLIDE):
{
int x = BCO_INSTR_8;
}
Continue;
}
+#ifdef XMLAMBDA
+ /* Test Inj indices. */
+ Case(i_TEST_INJ):
+ {
+ int offset = BCO_INSTR_8;
+ StgWord jump = BCO_INSTR_16;
+
+ int index = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
+ if (index != xTaggedStackInt(offset) )
+ {
+ bciPtr += jump;
+ }
+ Continue;
+ }
+ Case(i_TEST_INJ_big):
+ {
+ int offset = BCO_INSTR_16;
+ StgWord jump = BCO_INSTR_16;
+
+ int index = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
+ if (index != xTaggedStackInt(offset) )
+ {
+ bciPtr += jump;
+ }
+ Continue;
+ }
+ Case(i_TEST_INJ_CONST):
+ {
+ int value = BCO_INSTR_8;
+ StgWord jump = BCO_INSTR_16;
+
+ int index = payloadWord( (StgClosure*)xStackPtr(0), sizeofW(StgPtr) );
+ if (index != value )
+ {
+ bciPtr += jump;
+ }
+ Continue;
+ }
+#endif /* XMLAMBDA */
Case(i_UNPACK):
{
StgClosure* o = stgCast(StgClosure*,xStackPtr(0));
}
Continue;
}
+#ifdef XMLAMBDA
+ /* extract all fields of a row */
+ Case(i_UNPACK_ROW):
+ {
+ StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,xStackPtr(0));
+ int i = p->ptrs;
+ while (--i >= 0)
+ {
+ xPushCPtr(p->payload[i]);
+ }
+ Continue;
+ }
+ /* extract the value of an INJ */
+ Case(i_UNPACK_INJ):
+ {
+ StgClosure* con = stgCast(StgClosure*,xStackPtr(0));
+
+ ASSERT(get_itbl(con) == Inj_con_info);
+
+ xPushPtr(payloadPtr(con,0));
+ Continue;
+ }
+#endif /* XMLAMBA */
Case(i_VAR_big):
{
int n = BCO_INSTR_16;
case CONSTR_CHARLIKE:
case CONSTR_STATIC:
case CONSTR_NOCAF_STATIC:
+#ifdef XMLAMBDA
+/* rows are mutarrays and should be treated as constructors. */
+ case MUT_ARR_PTRS_FROZEN:
+#endif
{
while (1) {
switch (get_itbl(stgCast(StgClosure*,xSp))->type) {
static inline void setStackWord ( StgStackOffset i, StgWord w )
{ gSp[i] = w; }
+#ifdef XMLAMBDA
+static inline void setStackPtr ( StgStackOffset i, StgPtr p )
+ { *(stgCast(StgPtr*, gSp+i)) = p; }
+#endif
+
static inline void PushTaggedRealWorld( void )
{ PushTag(REALWORLD_TAG); }
inline void PushTaggedInt ( StgInt x )
StgClosure* err = PopCPtr();
return (raiseAnError(err));
}
+#ifdef XMLAMBDA
+/*------------------------------------------------------------------------
+ Insert and Remove primitives on Rows
+------------------------------------------------------------------------*/
+ 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;
+ StgMutArrPtrs* newRow
+ = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n + 1));
+ SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
+ newRow->ptrs = n+1;
+
+ ASSERT(i <= n);
+
+ /* copy the fields, inserting the new value */
+ for (j = 0; j < i; j++) {
+ newRow->payload[j] = row->payload[j];
+ }
+ newRow->payload[i] = x;
+ for (j = i+1; j <= n; j++)
+ {
+ newRow->payload[j] = row->payload[j-1];
+ }
+
+ PushPtr(stgCast(StgPtr,newRow));
+ break;
+ }
+
+ case i_rowRemoveAt:
+ {
+ nat j;
+ /* get row and index */
+ StgMutArrPtrs* row = stgCast(StgMutArrPtrs*,PopPtr());
+ nat i = PopTaggedInt(); /* or Word?? */
+
+ /* allocate new row */
+ StgWord n = row->ptrs;
+ StgMutArrPtrs* newRow
+ = stgCast(StgMutArrPtrs*,allocate(sizeofW(StgMutArrPtrs) + n - 1));
+ SET_HDR(newRow,&MUT_ARR_PTRS_FROZEN_info,CCCS);
+ newRow->ptrs = n-1;
+
+ ASSERT(i < n);
+
+ /* copy the fields, except for the removed value. */
+ for (j = 0; j < i; j++) {
+ newRow->payload[j] = row->payload[j];
+ }
+ for (j = i+1; j < n; j++)
+ {
+ newRow->payload[j-1] = row->payload[j];
+ }
+
+ PushCPtr(row->payload[i]);
+ PushPtr(stgCast(StgPtr,newRow));
+ break;
+ }
+#endif /* XMLAMBDA */
case i_newRef:
{
/* -----------------------------------------------------------------------------
- * $Id: Prelude.c,v 1.7 2000/05/22 13:09:29 simonmar Exp $
+ * $Id: Prelude.c,v 1.8 2000/06/15 13:23:52 daan Exp $
*
* (c) The GHC Team, 1998-2000
*
0,sizeofW(StgWord),0,CONSTR_NOCAF_STATIC,,EF_,0,0);
INFO_TABLE_CONSTR(hugs_standalone_StablePtr_static_info,Hugs_CONSTR_entry,
0,sizeofW(StgStablePtr),0,CONSTR_NOCAF_STATIC,,EF_,0,0);
+
+#ifdef XMLAMBDA
+/* The Inj constructor: data Inj = forall a. Inj a Int#
+ Since this one is not present in Haskell compiled stuff, we bind it statically.
+*/
+INFO_TABLE_CONSTR(xmlambda_Inj_con_info,Hugs_CONSTR_entry,
+ sizeofW(StgPtr),sizeofW(StgInt),0,CONSTR,,EF_,0,0);
+
+const StgInfoTable* ind_Inj_con_info = &xmlambda_Inj_con_info;
+#endif /* XMLAMBDA */
+
#endif
/* -----------------------------------------------------------------------------
- * $Id: Prelude.h,v 1.10 2000/05/23 15:31:48 sewardj Exp $
+ * $Id: Prelude.h,v 1.11 2000/06/15 13:23:52 daan Exp $
*
* (c) The GHC Team, 1998-2000
*
#define StablePtr_static_info ind_StablePtr_static_info
#define StablePtr_con_info ind_StablePtr_con_info
+#ifdef XMLAMBDA
+/* The Inj constructor. Not present in combined mode or compiled code. */
+
+extern const StgInfoTable *ind_Inj_con_info;
+#define Inj_con_info ind_Inj_con_info
+
+#endif
+
#endif
void fixupRTStoPreludeRefs( void*(*)(char*) );
/* -----------------------------------------------------------------------------
- * $Id: Printer.c,v 1.26 2000/04/17 14:31:19 sewardj Exp $
+ * $Id: Printer.c,v 1.27 2000/06/15 13:23:52 daan Exp $
*
* (c) The GHC Team, 1994-2000.
*
break;
}
+#ifdef XMLAMBDA
+/* rows are mutarrays in xmlambda, maybe we should make a new type: ROW */
+ case MUT_ARR_PTRS_FROZEN:
+ {
+ StgWord i;
+ StgMutArrPtrs* p = stgCast(StgMutArrPtrs*,obj);
+
+ fprintf(stderr,"Row<%i>(",p->ptrs);
+ for (i = 0; i < p->ptrs; ++i) {
+ if (i > 0) fprintf(stderr,", ");
+ printPtr((StgPtr)(p->payload[i]));
+ }
+ fprintf(stderr,")\n");
+ break;
+ }
+#endif
+
case FUN:
case FUN_1_0: case FUN_0_1:
case FUN_1_1: case FUN_0_2: case FUN_2_0:
projects / ghc-hetmet.git / commitdiff