Skip to content

GitLab

Commit 3d124552 authored by daan's avatar daan
Browse files

[project @ 2000-06-15 13:23:51 by daan] 

Added new primitives and bytecodes that support
code generation for XMLambda. All additions are
surrounded by #ifdef XMLAMBDA.

Most important additions:
- Rows (n-tuples) which are implemented on top of Frozen Mutarrays
- Inj (variant sums), which is implemented using a new constructor
called Inj which contains both the value and an unboxed int
which represents the index.
parent b619d74d
Hide whitespace changes
Inline Side-by-side
ghc/rts/Assembler.c
View file @ 3d124552
......@@ -5,8 +5,8 @@
* 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.
......@@ -861,6 +861,40 @@ static void emit_i_ALLOC_CONSTR ( AsmBCO bco, int arg1 )
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.
* ------------------------------------------------------------------------*/
......@@ -1414,6 +1448,12 @@ AsmPrim asmPrimOps[] = {
, { "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 }
......@@ -1824,6 +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 */
ghc/rts/Bytecodes.h
View file @ 3d124552
/* -----------------------------------------------------------------------------
* $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
*
......@@ -33,15 +33,27 @@
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), \
......@@ -326,6 +338,12 @@ typedef enum
, i_raise
#ifdef XMLAMBDA
/* row primitives. */
, i_rowInsertAt
, i_rowRemoveAt
#endif
/* Ref operations */
, i_newRef
, i_writeRef
......@@ -444,7 +462,7 @@ typedef enum
/* 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;
......
ghc/rts/Disassembler.c
View file @ 3d124552
......@@ -5,8 +5,8 @@
* 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"
......@@ -81,6 +81,18 @@ static InstrPtr disIntPC ( StgBCO *bco, InstrPtr pc, char* i )
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;
......@@ -267,6 +279,36 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc )
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");
......
ghc/rts/Evaluator.c
View file @ 3d124552
......@@ -5,8 +5,8 @@
* 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"
......@@ -585,6 +585,29 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
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! */
......@@ -688,6 +711,112 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
);
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;
......@@ -733,6 +862,45 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
}
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));
......@@ -752,6 +920,29 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
}
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;
......@@ -1291,6 +1482,10 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
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) {
......@@ -1446,6 +1641,11 @@ static inline StgWord stackWord ( StgStackOffset i )
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 )
......@@ -2549,6 +2749,71 @@ static void* enterBCO_primop2 ( int primop2code,
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:
{
......
ghc/rts/Prelude.c
View file @ 3d124552
/* -----------------------------------------------------------------------------
* $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
*
......@@ -75,6 +75,17 @@ INFO_TABLE_CONSTR(hugs_standalone_Wzh_static_info,Hugs_CONSTR_entry,
0,sizeofW(StgWord),0,CONSTR_NOCAF_STATIC,,EF_,0,0);