From: daan Date: Mon, 9 Oct 2000 11:21:41 +0000 (+0000) Subject: [project @ 2000-10-09 11:18:46 by daan] X-Git-Tag: Approximately_9120_patches~3665 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=912298070a668c144998361b46c5fcbaac2e27cb;p=ghc-hetmet.git [project @ 2000-10-09 11:18:46 by daan] Lots of changes for Xmlambda. all changes are between #ifdef XMLAMBDA blocks. - new bytecodes for Inj constructors and witnesses - new primops for rows - code for calling foreign functions. This only works with 'dynamic.c' but that is not checked in yet. --- diff --git a/ghc/includes/Assembler.h b/ghc/includes/Assembler.h index bd40d0a..a1e6050 100644 --- a/ghc/includes/Assembler.h +++ b/ghc/includes/Assembler.h @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- - * $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. * @@ -303,28 +303,38 @@ extern void asmEndMkPAP ( AsmBCO bco, AsmVar v, AsmSp start ); /*------------------------------------------------------------------------ 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 /* -------------------------------------------------------------------------- @@ -345,4 +355,40 @@ typedef struct { 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 + /*-------------------------------------------------------------------------*/ diff --git a/ghc/rts/Assembler.c b/ghc/rts/Assembler.c index 6746185..64b2ab4 100644 --- a/ghc/rts/Assembler.c +++ b/ghc/rts/Assembler.c @@ -5,8 +5,8 @@ * 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. @@ -693,6 +693,15 @@ static void emiti_16_16 ( AsmBCO bco, Instr opcode, int arg1, int arg2 ) 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 @@ -813,6 +822,14 @@ static void emit_i_CONST_ADDR ( AsmBCO bco, int arg1 ) 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); @@ -878,20 +895,28 @@ static void emit_i_PACK_ROW (AsmBCO bco, int var ) 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 @@ -1113,8 +1138,8 @@ void asmConstAddr( AsmBCO bco, AsmAddr x ) 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)); } @@ -1450,8 +1475,8 @@ AsmPrim asmPrimOps[] = { #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 */ @@ -1868,11 +1893,78 @@ AsmInfo asmMkInfo( AsmNat tag, AsmNat ptrs ) /* ----------------------------------------------------------------------- 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); @@ -1885,7 +1977,7 @@ AsmSp asmBeginPackRow( AsmBCO bco ) 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); @@ -1896,7 +1988,7 @@ void asmEndPackRow( AsmBCO bco, AsmVar v, AsmSp start, AsmNat n /*#fields*/ ) setSp(bco, start); } -void asmBeginUnpackRow( AsmBCO bco ) +void asmBeginUnpackRow( AsmBCO bco __attribute__ ((unused)) ) { /* dummy to make it look prettier */ } @@ -1906,62 +1998,233 @@ void asmEndUnpackRow( AsmBCO bco ) 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 */ diff --git a/ghc/rts/Bytecodes.h b/ghc/rts/Bytecodes.h index 07e717a..37c8bce4 100644 --- a/ghc/rts/Bytecodes.h +++ b/ghc/rts/Bytecodes.h @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -33,27 +33,15 @@ 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), \ @@ -62,6 +50,30 @@ 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), \ @@ -74,6 +86,7 @@ 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), \ @@ -341,7 +354,11 @@ typedef enum #ifdef XMLAMBDA /* row primitives. */ , i_rowInsertAt + , i_rowChainInsert + , i_rowChainBuild , i_rowRemoveAt + , i_rowChainRemove + , i_rowChainSelect #endif /* Ref operations */ @@ -455,6 +472,9 @@ typedef enum /* CCall! */ +#ifdef XMLAMBDA + , i_ccall +#endif , i_ccall_ccall_Id , i_ccall_ccall_IO , i_ccall_stdcall_Id @@ -462,7 +482,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 (6/10/2000) = 0x44 + * Current value (1 oct 2000) = 0x48 */ , MAX_Primop2 = i_ccall_stdcall_IO } Primop2; diff --git a/ghc/rts/Disassembler.c b/ghc/rts/Disassembler.c index cd8ea43..00a1167 100644 --- a/ghc/rts/Disassembler.c +++ b/ghc/rts/Disassembler.c @@ -5,8 +5,8 @@ * 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" @@ -91,6 +91,16 @@ static InstrPtr disInt16PC ( StgBCO *bco, InstrPtr pc, char* i ) 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 ) @@ -288,25 +298,44 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) 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: @@ -336,6 +365,8 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) 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: @@ -426,6 +457,22 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) 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: diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c index c7e91da..4ee9b0d 100644 --- a/ghc/rts/Evaluator.c +++ b/ghc/rts/Evaluator.c @@ -5,8 +5,8 @@ * 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" @@ -584,29 +584,6 @@ 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! */ @@ -710,14 +687,124 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) ); 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; iptrs; - nat i; + StgWord i; for (i=0; iptrs; + 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, @@ -772,16 +884,16 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) 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, @@ -793,16 +905,16 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) 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, @@ -814,123 +926,112 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) 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): { @@ -941,31 +1042,39 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) 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; @@ -1045,6 +1154,12 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) 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; @@ -2764,23 +2879,36 @@ static void* enterBCO_primop2 ( int primop2code, } #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 */ @@ -2797,20 +2925,150 @@ static void* enterBCO_primop2 ( int primop2code, 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. */ @@ -2826,6 +3084,188 @@ static void* enterBCO_primop2 ( int primop2code, 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: @@ -3271,6 +3711,39 @@ static void* enterBCO_primop2 ( int primop2code, 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: diff --git a/ghc/rts/Evaluator.h b/ghc/rts/Evaluator.h index 6c680e1..8c3e9a9 100644 --- a/ghc/rts/Evaluator.h +++ b/ghc/rts/Evaluator.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -53,3 +53,21 @@ extern void PushPtr ( StgPtr ); 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