diff options
| -rw-r--r-- | ghc/includes/StgMiscClosures.h | 8 | ||||
| -rw-r--r-- | ghc/rts/Disassembler.c | 618 | ||||
| -rw-r--r-- | ghc/rts/Disassembler.h | 4 | ||||
| -rw-r--r-- | ghc/rts/Interpreter.c | 271 |
4 files changed, 275 insertions, 626 deletions
diff --git a/ghc/includes/StgMiscClosures.h b/ghc/includes/StgMiscClosures.h index 02478901a4..0915b245be 100644 --- a/ghc/includes/StgMiscClosures.h +++ b/ghc/includes/StgMiscClosures.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: StgMiscClosures.h,v 1.29 2000/12/19 16:48:58 sewardj Exp $ + * $Id: StgMiscClosures.h,v 1.30 2000/12/20 14:47:22 sewardj Exp $ * * (c) The GHC Team, 1998-1999 * @@ -70,6 +70,12 @@ STGFUN(stg_interp_constr8_entry); extern DLL_IMPORT_RTS const vec_info_8 stg_ctoi_ret_R1_info; extern DLL_IMPORT_RTS const vec_info_8 stg_ctoi_ret_F1_info; extern DLL_IMPORT_RTS const vec_info_8 stg_ctoi_ret_D1_info; + +/* Used by the interpreter to return an unboxed value on the stack to + compiled code. */ +extern DLL_IMPORT_RTS const StgInfoTable stg_gc_unbx_r1_info; +extern DLL_IMPORT_RTS const StgInfoTable stg_gc_f1_info; +extern DLL_IMPORT_RTS const StgInfoTable stg_gc_d1_info; #endif #if defined(PAR) || defined(GRAN) diff --git a/ghc/rts/Disassembler.c b/ghc/rts/Disassembler.c index e03ea7e673..72715a4bfe 100644 --- a/ghc/rts/Disassembler.c +++ b/ghc/rts/Disassembler.c @@ -5,19 +5,20 @@ * Copyright (c) 1994-1998. * * $RCSfile: Disassembler.c,v $ - * $Revision: 1.15 $ - * $Date: 2000/12/19 16:48:35 $ + * $Revision: 1.16 $ + * $Date: 2000/12/20 14:47:22 $ * ---------------------------------------------------------------------------*/ -#if 0 +#ifdef GHCI #include "Rts.h" - -#ifdef INTERPRETER - +#include "RtsAPI.h" #include "RtsUtils.h" +#include "Closures.h" +#include "TSO.h" +#include "Schedule.h" + #include "Bytecodes.h" -#include "Assembler.h" #include "Printer.h" #include "Disassembler.h" #include "Interpreter.h" @@ -26,565 +27,142 @@ * Disassembler * ------------------------------------------------------------------------*/ -static int disInstr ( StgBCO *bco, int pc ) +int disInstr ( StgBCO *bco, int pc ) { - StgArrWords* instr_arr = bco->instrs; - UShort* instrs = (UShort*)(&instr_arr->payload[0]); + int i; + + StgArrWords* instr_arr = bco->instrs; + UShort* instrs = (UShort*)(&instr_arr->payload[0]); + + StgArrWords* literal_arr = bco->literals; + StgWord* literals = (StgWord*)(&literal_arr->payload[0]); + + StgMutArrPtrs* ptrs_arr = bco->ptrs; + StgPtr* ptrs = (StgPtr*)(&ptrs_arr->payload[0]); + + StgArrWords* itbls_arr = bco->itbls; + StgInfoTable** itbls = (StgInfoTable**)(&itbls_arr->payload[0]); switch (instrs[pc++]) { - case i_ARGCHECK: + case bci_ARGCHECK: fprintf(stderr, "ARGCHECK %d\n", instrs[pc] ); pc += 1; break; - case i_PUSH_L: + case bci_PUSH_L: fprintf(stderr, "PUSH_L %d\n", instrs[pc] ); pc += 1; break; - case i_PUSH_LL: + case bci_PUSH_LL: fprintf(stderr, "PUSH_LL %d %d\n", instrs[pc], instrs[pc+1] ); pc += 2; break; - case i_PUSH_LLL: + case bci_PUSH_LLL: fprintf(stderr, "PUSH_LLL %d %d %d\n", instrs[pc], instrs[pc+1], instrs[pc+2] ); pc += 3; break; - case i_PUSH_G: + case bci_PUSH_G: fprintf(stderr, "PUSH_G " ); printPtr( ptrs[instrs[pc]] ); pc += 1; break; - case i_PUSH_AS: + case bci_PUSH_AS: fprintf(stderr, "PUSH_AS " ); printPtr( ptrs[instrs[pc]] ); fprintf(stderr, " 0x%x", literals[instrs[pc+1]] ); pc += 2; break; - case i_PUSH_UBX: + case bci_PUSH_UBX: fprintf(stderr, "PUSH_UBX "); for (i = 0; i < instrs[pc+1]; i++) fprintf(stderr, "0x%x ", literals[i + instrs[pc]] ); fprintf(stderr, "\n"); pc += 2; break; - case i_PUSH_TAG: + case bci_PUSH_TAG: fprintf(stderr, "PUSH_TAG %d\n", instrs[pc] ); pc += 1; break; - case i_SLIDE: + case bci_SLIDE: fprintf(stderr, "SLIDE %d down by %d\n", instrs[pc], instrs[pc+1] ); pc += 2; break; - case i_ALLOC: + case bci_ALLOC: fprintf(stderr, "ALLOC %d words\n", instrs[pc] ); pc += 1; break; - case i_MKAP: + case bci_MKAP: fprintf(stderr, "MKAP %d words, %d stkoff\n", instrs[pc+1], instrs[pc] ); pc += 2; break; - case i_UNPACK: + case bci_UNPACK: fprintf(stderr, "UNPACK %d\n", instrs[pc] ); pc += 1; break; - case i_UPK_TAG: + case bci_UPK_TAG: fprintf(stderr, "UPK_TAG %d words, %d conoff, %d stkoff\n", instrs[pc], instrs[pc+1], instrs[pc+2] ); pc += 3; break; - case i_PACK: + case bci_PACK: fprintf(stderr, "PACK %d words with itbl ", instrs[pc+1] ); - printPtr( itbls[instrs[pc]] ); + printPtr( (StgPtr)itbls[instrs[pc]] ); pc += 2; break; - - case i_TESTLT_I: - -pc = disLitN ( bco, pc ); break; - case i_TESTEQ_I: pc = disLitNInt ( bco, pc ); - } -} - - -static InstrPtr disNone ( StgBCO *bco, InstrPtr pc, char* i ); -static InstrPtr disInt ( StgBCO *bco, InstrPtr pc, char* i ); -static InstrPtr disIntInt ( StgBCO *bco, InstrPtr pc, char* i ); -static InstrPtr disInfo ( StgBCO *bco, InstrPtr pc, char* i ); -static InstrPtr disConstPtr ( StgBCO *bco, InstrPtr pc, char* i ); -static InstrPtr disConstInt ( StgBCO *bco, InstrPtr pc, char* i ); -static InstrPtr disConstChar ( StgBCO *bco, InstrPtr pc, char* i ); -static InstrPtr disConstFloat ( StgBCO *bco, InstrPtr pc, char* i ); - -static InstrPtr disNone ( StgBCO *bco, InstrPtr pc, char* i ) -{ - fprintf(stderr,"%s",i); - return pc; -} - -static InstrPtr disInt ( StgBCO *bco, InstrPtr pc, char* i ) -{ - StgInt x = bcoInstr(bco,pc++); - ASSERT(pc <= bco->n_instrs); - fprintf(stderr,"%s %d",i,x); - return pc; -} - -static InstrPtr disInt16 ( StgBCO *bco, InstrPtr pc, char* i ) -{ - StgInt x = bcoInstr16(bco,pc); pc+=2; - ASSERT(pc <= bco->n_instrs); - fprintf(stderr,"%s %d",i,x); - return pc; -} - -static InstrPtr disIntInt ( StgBCO *bco, InstrPtr pc, char* i ) -{ - StgInt x = bcoInstr(bco,pc++); - StgInt y = bcoInstr(bco,pc++); - fprintf(stderr,"%s %d %d",i,x,y); - return pc; -} - -static InstrPtr disIntInt16 ( StgBCO *bco, InstrPtr pc, char* i ) -{ - StgInt x, y; - x = bcoInstr16(bco,pc); pc += 2; - y = bcoInstr16(bco,pc); pc += 2; - fprintf(stderr,"%s %d %d",i,x,y); - return pc; -} -static InstrPtr disIntPC ( StgBCO *bco, InstrPtr pc, char* i ) -{ - StgInt x; - StgWord y; - x = bcoInstr(bco,pc++); - y = bcoInstr16(bco,pc); pc += 2; - fprintf(stderr,"%s %d %d",i,x,pc+y); - 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; -} -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 ) -{ - StgWord y = bcoInstr16(bco,pc); pc += 2; - fprintf(stderr,"%s %d",i,pc+y); - return pc; -} - -static InstrPtr disInfo ( StgBCO *bco, InstrPtr pc, char* i ) -{ - StgInfoTable* info = bcoConstInfoPtr(bco,bcoInstr(bco,pc++)); - /* ToDo: print contents of infotable */ - fprintf(stderr,"%s ",i); - printPtr(stgCast(StgPtr,info)); - return pc; -} - -static InstrPtr disInfo16 ( StgBCO *bco, InstrPtr pc, char* i ) -{ - StgWord x = bcoInstr16(bco,pc); - StgInfoTable* info = bcoConstInfoPtr(bco,x); - pc+=2; - /* ToDo: print contents of infotable */ - fprintf(stderr,"%s ",i); - printPtr(stgCast(StgPtr,info)); - return pc; -} - -static InstrPtr disConstPtr ( StgBCO *bco, InstrPtr pc, char* i ) -{ - StgInt o = bcoInstr(bco,pc++); - StgPtr x = bcoConstPtr(bco,o); - fprintf(stderr,"%s [%d]=",i,o); - printPtr(x); /* bad way to print it... */ - return pc; -} - -static InstrPtr disConstPtr16 ( StgBCO *bco, InstrPtr pc, char* i ) -{ - StgInt o; - StgPtr x; - o = bcoInstr16(bco,pc); pc += 2; - x = bcoConstPtr(bco,o); - fprintf(stderr,"%s [%d]=",i,o); - printPtr(x); /* bad way to print it... */ - return pc; -} - -static InstrPtr disConstInt ( StgBCO *bco, InstrPtr pc, char* i ) -{ - StgInt x = bcoConstInt(bco,bcoInstr(bco,pc++)); - fprintf(stderr,"%s %d (0x%x)",i,x,x); - return pc; -} - -static InstrPtr disConstInt16 ( StgBCO *bco, InstrPtr pc, char* i ) -{ - StgInt x = bcoConstInt(bco,bcoInstr16(bco,pc)); pc += 2; - fprintf(stderr,"%s %d (0x%x)",i,x,x); - return pc; -} - -static InstrPtr disConstAddr ( StgBCO *bco, InstrPtr pc, char* i ) -{ - StgAddr x = bcoConstAddr(bco,bcoInstr(bco,pc++)); - fprintf(stderr,"%s ",i); - printPtr(x); - return pc; -} - -static InstrPtr disConstAddr16 ( StgBCO *bco, InstrPtr pc, char* i ) -{ - StgAddr x = bcoConstAddr(bco,bcoInstr16(bco,pc)); pc += 2; - fprintf(stderr,"%s ",i); - printPtr(x); - return pc; -} - -static InstrPtr disConstChar ( StgBCO *bco, InstrPtr pc, char* i ) -{ - StgChar x = bcoConstChar(bco,bcoInstr(bco,pc++)); - if (isprint((int)x)) - fprintf(stderr,"%s '%c'",i,x); else - fprintf(stderr,"%s 0x%x",i,(int)x); - return pc; -} - -static InstrPtr disConstChar16 ( StgBCO *bco, InstrPtr pc, char* i ) -{ - StgChar x = bcoConstChar(bco,bcoInstr16(bco,pc)); pc += 2; - if (isprint((int)x)) - fprintf(stderr,"%s '%c'",i,x); else - fprintf(stderr,"%s 0x%x",i,(int)x); - return pc; -} + case bci_TESTLT_I: + fprintf(stderr, "TESTLT_I %d, fail to %d\n", literals[instrs[pc]], + instrs[pc+1]); + pc += 2; break; + case bci_TESTEQ_I: + fprintf(stderr, "TESTEQ_I %d, fail to %d\n", literals[instrs[pc]], + instrs[pc+1]); + pc += 2; break; -static InstrPtr disConstFloat ( StgBCO *bco, InstrPtr pc, char* i ) -{ - StgFloat x = bcoConstFloat(bco,bcoInstr(bco,pc++)); - fprintf(stderr,"%s %f",i,x); - return pc; -} + case bci_TESTLT_F: + fprintf(stderr, "TESTLT_F %d, fail to %d\n", literals[instrs[pc]], + instrs[pc+1]); + pc += 2; break; + case bci_TESTEQ_F: + fprintf(stderr, "TESTEQ_F %d, fail to %d\n", literals[instrs[pc]], + instrs[pc+1]); + pc += 2; break; -static InstrPtr disConstFloat16 ( StgBCO *bco, InstrPtr pc, char* i ) -{ - StgFloat x = bcoConstFloat(bco,bcoInstr16(bco,pc)); pc += 2; - fprintf(stderr,"%s %f",i,x); - return pc; -} + case bci_TESTLT_D: + fprintf(stderr, "TESTLT_D %d, fail to %d\n", literals[instrs[pc]], + instrs[pc+1]); + pc += 2; break; + case bci_TESTEQ_D: + fprintf(stderr, "TESTEQ_D %d, fail to %d\n", literals[instrs[pc]], + instrs[pc+1]); + pc += 2; break; -static InstrPtr disConstDouble ( StgBCO *bco, InstrPtr pc, char* i ) -{ - StgDouble x = bcoConstDouble(bco,bcoInstr(bco,pc++)); - fprintf(stderr,"%s %f",i,x); - return pc; + case bci_TESTLT_P: + fprintf(stderr, "TESTLT_P %d, fail to %d\n", instrs[pc], + instrs[pc+1]); + pc += 2; break; + case bci_TESTEQ_P: + fprintf(stderr, "TESTEQ_P %d, fail to %d\n", instrs[pc], + instrs[pc+1]); + pc += 2; break; + case bci_RETURN: + fprintf(stderr, "RETURN " ); printPtr( (StgPtr)itbls[instrs[pc]] ); + fprintf(stderr, "\n"); + pc += 1; break; + case bci_ENTER: + fprintf(stderr, "ENTER\n"); + break; + default: + barf("disInstr: unknown opcode"); + } + return pc; } -static InstrPtr disConstDouble16 ( StgBCO *bco, InstrPtr pc, char* i ) -{ - StgDouble x = bcoConstDouble(bco,bcoInstr16(bco,pc)); pc += 2; - fprintf(stderr,"%s %f",i,x); - return pc; -} -InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) +/* Something of a kludge .. how do we know where the end of the insn + array is, since it isn't recorded anywhere? Answer: the first + short is the number of bytecodes which follow it. + See ByteCodeGen.linkBCO.insns_arr for construction ... +*/ +void disassemble( StgBCO *bco ) { - Instr in; - ASSERT(pc < bco->n_instrs); - in = bcoInstr(bco,pc++); - switch (in) { - case i_INTERNAL_ERROR: - return disNone(bco,pc,"INTERNAL_ERROR"); - case i_PANIC: - return disNone(bco,pc,"PANIC"); - case i_STK_CHECK: - return disInt(bco,pc,"STK_CHECK"); - case i_STK_CHECK_big: - return disInt16(bco,pc,"STK_CHECK_big"); - case i_ARG_CHECK: - return disInt(bco,pc,"ARG_CHECK"); - case i_ALLOC_AP: - return disInt(bco,pc,"ALLOC_AP"); - case i_ALLOC_PAP: - return disInt(bco,pc,"ALLOC_PAP"); - case i_ALLOC_CONSTR: - return disInfo(bco,pc,"ALLOC_CONSTR"); - case i_ALLOC_CONSTR_big: - return disInfo16(bco,pc,"ALLOC_CONSTR_big"); - case i_MKAP: - return disIntInt(bco,pc,"MKAP"); - case i_MKAP_big: - return disIntInt16(bco,pc,"MKAP_big"); - case i_MKPAP: - return disIntInt(bco,pc,"MKPAP"); - case i_PACK: - return disInt(bco,pc,"PACK"); - case i_SLIDE: - return disIntInt(bco,pc,"SLIDE"); - case i_RV: - return disIntInt(bco,pc,"R_V"); - case i_RVE: - return disIntInt(bco,pc,"R_V_E"); - case i_VV: - return disIntInt(bco,pc,"V_V"); - case i_SE: - return disIntInt(bco,pc,"S_E"); - case i_SLIDE_big: - return disIntInt16(bco,pc,"SLIDE_big"); - case i_ENTER: - return disNone(bco,pc,"ENTER"); - case i_RETADDR: - return disConstPtr(bco,pc,"RETADDR"); - case i_RETADDR_big: - return disConstPtr16(bco,pc,"RETADDR_big"); - case i_TEST: - return disIntPC(bco,pc,"TEST"); - case i_UNPACK: - return disNone(bco,pc,"UNPACK"); - case i_VAR: - return disInt(bco,pc,"VAR"); - case i_VAR_big: - return disInt16(bco,pc,"VAR_big"); - case i_CONST: - return disConstPtr(bco,pc,"CONST"); - 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_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 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 disNone(bco,pc,"VOID"); + StgArrWords* instr_arr = bco->instrs; + UShort* instrs = (UShort*)(&instr_arr->payload[0]); + int nbcs = (int)instrs[0]; + int pc = 1; - case i_VAR_INT: - return disInt(bco,pc,"VAR_INT"); - case i_VAR_INT_big: - return disInt16(bco,pc,"VAR_INT_big"); - case i_CONST_INT: - return disConstInt(bco,pc,"CONST_INT"); - case i_CONST_INT_big: - return disConstInt16(bco,pc,"CONST_INT_big"); - case i_PACK_INT: - return disNone(bco,pc,"PACK_INT"); - case i_UNPACK_INT: - return disNone(bco,pc,"UNPACK_INT"); - case i_TEST_INT: - return disPC(bco,pc,"TEST_INT"); - - case i_CONST_INTEGER: - return disConstAddr(bco,pc,"CONST_INTEGER"); - case i_CONST_INTEGER_big: - return disConstAddr16(bco,pc,"CONST_INTEGER_big"); - - case i_VAR_WORD: - 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: - return disNone(bco,pc,"UNPACK_WORD"); - - case i_VAR_ADDR: - return disInt(bco,pc,"VAR_ADDR"); - case i_VAR_ADDR_big: - return disInt16(bco,pc,"VAR_ADDR_big"); - case i_CONST_ADDR: - return disConstAddr(bco,pc,"CONST_ADDR"); - case i_CONST_ADDR_big: - return disConstAddr16(bco,pc,"CONST_ADDR_big"); - case i_PACK_ADDR: - return disNone(bco,pc,"PACK_ADDR"); - case i_UNPACK_ADDR: - return disNone(bco,pc,"UNPACK_ADDR"); - - case i_VAR_CHAR: - return disInt(bco,pc,"VAR_CHAR"); - case i_VAR_CHAR_big: - return disInt16(bco,pc,"VAR_CHAR_big"); - case i_CONST_CHAR: - return disConstChar(bco,pc,"CONST_CHAR"); - case i_CONST_CHAR_big: - return disConstChar16(bco,pc,"CONST_CHAR_big"); - case i_PACK_CHAR: - return disNone(bco,pc,"PACK_CHAR"); - case i_UNPACK_CHAR: - return disNone(bco,pc,"UNPACK_CHAR"); - - case i_VAR_FLOAT: - return disInt(bco,pc,"VAR_FLOAT"); - case i_VAR_FLOAT_big: - return disInt16(bco,pc,"VAR_FLOAT_big"); - case i_CONST_FLOAT: - return disConstFloat(bco,pc,"CONST_FLOAT"); - case i_CONST_FLOAT_big: - return disConstFloat16(bco,pc,"CONST_FLOAT_big"); - case i_PACK_FLOAT: - return disNone(bco,pc,"PACK_FLOAT"); - case i_UNPACK_FLOAT: - return disNone(bco,pc,"UNPACK_FLOAT"); - - case i_VAR_DOUBLE: - return disInt(bco,pc,"VAR_DOUBLE"); - case i_VAR_DOUBLE_big: - return disInt16(bco,pc,"VAR_DOUBLE_big"); - case i_CONST_DOUBLE: - return disConstDouble(bco,pc,"CONST_DOUBLE"); - case i_CONST_DOUBLE_big: - return disConstDouble16(bco,pc,"CONST_DOUBLE_big"); - case i_PACK_DOUBLE: - return disNone(bco,pc,"PACK_DOUBLE"); - case i_UNPACK_DOUBLE: - return disNone(bco,pc,"UNPACK_DOUBLE"); - - case i_VAR_STABLE: - return disInt(bco,pc,"VAR_STABLE"); - case i_PACK_STABLE: - return disNone(bco,pc,"PACK_STABLE"); - case i_UNPACK_STABLE: - return disNone(bco,pc,"UNPACK_STABLE"); - - case i_PRIMOP1: - { - Primop1 op = bcoInstr(bco,pc++); - switch (op) { - case i_INTERNAL_ERROR1: - return disNone(bco,pc,"INTERNAL_ERROR1"); - case i_pushseqframe: - return disNone(bco,pc,"i_pushseqframe"); - case i_pushcatchframe: - return disNone(bco,pc,"i_pushcatchframe"); - default: - { - const AsmPrim* p = asmFindPrimop(i_PRIMOP1,op); - if (p) { - return disNone(bco,pc,p->name); - } - barf("Unrecognised primop1 %d\n",op); - } - } - } - case i_PRIMOP2: - { - Primop2 op = bcoInstr(bco,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: - return disNone(bco,pc,"ccall_ccall_IO"); - case i_ccall_stdcall_Id: - return disNone(bco,pc,"ccall_stdcall_Id"); - case i_ccall_stdcall_IO: - return disNone(bco,pc,"ccall_stdcall_IO"); - case i_raise: - return disNone(bco,pc,"primRaise"); - case i_takeMVar: - return disNone(bco,pc,"primTakeMVar"); - default: - { - const AsmPrim* p = asmFindPrimop(i_PRIMOP2,op); - if (p) { - return disNone(bco,pc,p->name); - } - barf("Unrecognised primop2 %d\n",op); - } - } - } - default: - barf("Unrecognised instruction %d\n",in); - } -} - -void disassemble( StgBCO *bco, char* prefix ) -{ - int pc = 0; - int pcLim = bco->n_instrs; - ASSERT( get_itbl(bco)->type == BCO); - while (pc < pcLim) { - fprintf(stderr,"%s%d:\t",prefix,pc); - pc = disInstr(bco,pc); - fprintf(stderr,"\n"); - } - if (bco->stgexpr) { - ppStgExpr(bco->stgexpr); - fprintf(stderr, "\n"); - } - else - fprintf(stderr, "\t(no associated tree)\n" ); + fprintf(stderr, "\n\nBCO %p =\n", bco ); + pc = 1; + while (pc <= nbcs) { + fprintf(stderr, "\t%2d: ", pc ); + pc = disInstr ( bco, pc ); + } + ASSERT(pc == nbcs+1); } -#endif /* INTERPRETER */ -#endif 0
\ No newline at end of file +#endif /* GHCI */ diff --git a/ghc/rts/Disassembler.h b/ghc/rts/Disassembler.h index 3751dff7c9..e792dab062 100644 --- a/ghc/rts/Disassembler.h +++ b/ghc/rts/Disassembler.h @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- - * $Id: Disassembler.h,v 1.5 2000/12/19 16:48:35 sewardj Exp $ + * $Id: Disassembler.h,v 1.6 2000/12/20 14:47:22 sewardj Exp $ * * (c) The GHC Team, 1998-2000 * @@ -11,6 +11,6 @@ #ifdef GHCI extern int disInstr ( StgBCO *bco, int pc ); -extern void disassemble( StgBCO *bco, char* prefix ); +extern void disassemble( StgBCO *bco ); #endif diff --git a/ghc/rts/Interpreter.c b/ghc/rts/Interpreter.c index 8fa1c46f43..d0dd0e3445 100644 --- a/ghc/rts/Interpreter.c +++ b/ghc/rts/Interpreter.c @@ -1,69 +1,43 @@ - -#if 0 /* ----------------------------------------------------------------------------- * Bytecode evaluator * * Copyright (c) 1994-2000. * * $RCSfile: Interpreter.c,v $ - * $Revision: 1.4 $ - * $Date: 2000/12/19 16:48:35 $ + * $Revision: 1.5 $ + * $Date: 2000/12/20 14:47:22 $ * ---------------------------------------------------------------------------*/ -#include "Rts.h" - +#ifdef GHCI - -#include "RtsFlags.h" +#include "Rts.h" +#include "RtsAPI.h" #include "RtsUtils.h" -#include "Updates.h" +#include "Closures.h" +#include "TSO.h" +#include "Schedule.h" +#include "RtsFlags.h" #include "Storage.h" -#include "SchedAPI.h" /* for createGenThread */ -#include "Schedule.h" /* for context_switch */ -#include "Bytecodes.h" -#include "ForeignCall.h" -#include "PrimOps.h" /* for __{encode,decode}{Float,Double} */ -#include "Prelude.h" -#include "Itimer.h" -#include "Evaluator.h" -#include "sainteger.h" +#include "Updates.h" -#ifdef DEBUG +#include "Bytecodes.h" #include "Printer.h" #include "Disassembler.h" -#include "Sanity.h" -#include "StgRun.h" -#endif - -#include <math.h> /* These are for primops */ -#include <limits.h> /* These are for primops */ -#include <float.h> /* These are for primops */ -#ifdef HAVE_IEEE754_H -#include <ieee754.h> /* These are for primops */ -#endif +#include "Interpreter.h" -#endif /* 0 */ -#include <stdio.h> - -int /*StgThreadReturnCode*/ interpretBCO ( void* /* Capability* */ cap ) -{ - fprintf(stderr, "Greetings, earthlings. I am not yet implemented. Bye!\n"); - exit(1); -} - -#if 0 /* -------------------------------------------------------------------------- * The new bytecode interpreter * ------------------------------------------------------------------------*/ /* Sp points to the lowest live word on the stack. */ -#define StackWord(n) ((W_*)iSp)[n] -#define BCO_NEXT bco_instrs[bciPtr++] -#define BCO_PTR(n) bco_ptrs[n] - +#define StackWord(n) iSp[n] +#define BCO_NEXT instrs[bciPtr++] +#define BCO_PTR(n) (W_)ptrs[n] +#define BCO_LIT(n) (W_)literals[n] +#define BCO_ITBL(n) itbls[n] StgThreadReturnCode interpretBCO ( Capability* cap ) { @@ -73,7 +47,7 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) /* Use of register here is primarily to make it clear to compilers that these entities are non-aliasable. */ - register StgPtr iSp; /* local state -- stack pointer */ + register W_* iSp; /* local state -- stack pointer */ register StgUpdateFrame* iSu; /* local state -- frame pointer */ register StgPtr iSpLim; /* local state -- stack lim pointer */ register StgClosure* obj; @@ -83,11 +57,10 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) iSpLim = cap->rCurrentTSO->stack + RESERVED_STACK_WORDS; IF_DEBUG(evaluator, - enterCountI++; fprintf(stderr, "\n---------------------------------------------------------------\n"); - fprintf(stderr,"Entering: ",); printObj(obj); - fprintf(stderr,"xSp = %p\txSu = %p\n", xSp, xSu); + fprintf(stderr,"Entering: "); printObj((StgClosure*)StackWord(0)); + fprintf(stderr,"iSp = %p\tiSu = %p\n", iSp, iSu); fprintf(stderr, "\n" ); printStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu); fprintf(stderr, "\n\n"); @@ -97,45 +70,70 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) stack. */ nextEnter: - obj = StackWord(0); iSp++; + obj = (StgClosure*)StackWord(0); iSp++; switch ( get_itbl(obj)->type ) { case INVALID_OBJECT: - barf("Invalid object %p",obj); + barf("Invalid object %p",(StgPtr)obj); - case BCO: bco_entry: + case BCO: /* ---------------------------------------------------- */ /* Start of the bytecode interpreter */ /* ---------------------------------------------------- */ { - register StgWord8* bciPtr; /* instruction pointer */ - register StgBCO* bco = (StgBCO*)obj; + register int bciPtr = 1; /* instruction pointer */ + register StgBCO* bco = (StgBCO*)obj; + register UShort* instrs = (UShort*)(&bco->instrs->payload[0]); + register StgWord* literals = (StgWord*)(&bco->literals->payload[0]); + register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]); + register StgInfoTable** itbls = (StgInfoTable**) + (&bco->itbls->payload[0]); + if (doYouWantToGC()) { - iSp--; StackWord(0) = bco; + iSp--; StackWord(0) = (W_)bco; return HeapOverflow; } nextInsn: - ASSERT((StgWord)(PC) < bco->n_instrs); + ASSERT(bciPtr <= instrs[0]); IF_DEBUG(evaluator, - fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", xSp, xSu, PC); - disInstr(bco,PC); + fprintf(stderr,"iSp = %p\tiSu = %p\tpc = %d\t", iSp, iSu, bciPtr); + disInstr(bco,bciPtr); if (0) { int i; fprintf(stderr,"\n"); for (i = 8; i >= 0; i--) - fprintf(stderr, "%d %p\n", i, (StgPtr)(*(gSp+i))); + fprintf(stderr, "%d %p\n", i, (StgPtr)(*(iSp+i))); } fprintf(stderr,"\n"); ); switch (BCO_NEXT) { + case bci_ARGCHECK: { + int i; + StgPAP* pap; + int arg_words_reqd = BCO_NEXT; + int arg_words_avail = ((W_*)iSu) - ((W_*)iSp); + if (arg_words_avail >= arg_words_reqd) goto nextInsn; + /* Handle arg check failure. Copy the spare args + into a PAP frame. */ + pap = (StgPAP*)allocate(PAP_sizeW(arg_words_avail)); + SET_HDR(pap,&stg_PAP_info,CC_pap); + pap->n_args = arg_words_avail; + for (i = 0; i < arg_words_avail; i++) + pap->payload[i] = (StgClosure*)StackWord(i); + /* Push on the stack and defer to the scheduler. */ + iSp = (StgPtr)iSu; + iSp --; + StackWord(0) = (W_)pap; + return ThreadEnterGHC; + } case bci_PUSH_L: { int o1 = BCO_NEXT; StackWord(-1) = StackWord(o1); - Sp--; + iSp--; goto nextInsn; } case bci_PUSH_LL: { @@ -143,7 +141,7 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) int o2 = BCO_NEXT; StackWord(-1) = StackWord(o1); StackWord(-2) = StackWord(o2); - Sp -= 2; + iSp -= 2; goto nextInsn; } case bci_PUSH_LLL: { @@ -153,13 +151,13 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) StackWord(-1) = StackWord(o1); StackWord(-2) = StackWord(o2); StackWord(-3) = StackWord(o3); - Sp -= 3; + iSp -= 3; goto nextInsn; } case bci_PUSH_G: { int o1 = BCO_NEXT; StackWord(-1) = BCO_PTR(o1); - Sp -= 3; + iSp -= 1; goto nextInsn; } case bci_PUSH_AS: { @@ -167,98 +165,166 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) int o_itbl = BCO_NEXT; StackWord(-1) = BCO_LIT(o_itbl); StackWord(-2) = BCO_PTR(o_bco); - Sp -= 2; + iSp -= 2; + goto nextInsn; + } + case bci_PUSH_UBX: { + int o_lits = BCO_NEXT; + int n_words = BCO_NEXT; + for (; n_words > 0; n_words--) { + iSp --; + StackWord(0) = BCO_LIT(o_lits); + o_lits++; + } goto nextInsn; } case bci_PUSH_TAG: { W_ tag = (W_)(BCO_NEXT); StackWord(-1) = tag; - Sp --; - goto nextInsn; - } - case bci_PUSH_LIT:{ - int o = BCO_NEXT; - StackWord(-1) = BCO_LIT(o); - Sp --; + iSp --; goto nextInsn; } case bci_SLIDE: { int n = BCO_NEXT; int by = BCO_NEXT; - ASSERT(Sp+n+by <= (StgPtr)xSu); + ASSERT(iSp+n+by <= (W_*)iSu); /* a_1, .. a_n, b_1, .. b_by, s => a_1, .. a_n, s */ while(--n >= 0) { StackWord(n+by) = StackWord(n); } - Sp += by; + iSp += by; goto nextInsn; } case bci_ALLOC: { int n_payload = BCO_NEXT; P_ p = allocate(AP_sizeW(n_payload)); - StackWord(-1) = p; - Sp --; + StackWord(-1) = (W_)p; + iSp --; goto nextInsn; } - case bci_MKAP: { - int off = BCO_NEXT; + case bci_MKAP: { + int i; + int stkoff = BCO_NEXT; int n_payload = BCO_NEXT - 1; - StgAP_UPD* ap = StackWord(off); + StgAP_UPD* ap = (StgAP_UPD*)StackWord(stkoff); ap->n_args = n_payload; ap->fun = (StgClosure*)StackWord(0); for (i = 0; i < n_payload; i++) - ap->payload[i] = StackWord(i+1); - Sp += n_payload+1; + ap->payload[i] = (StgClosure*)StackWord(i+1); + iSp += n_payload+1; goto nextInsn; } case bci_UNPACK: { /* Unpack N ptr words from t.o.s constructor */ /* The common case ! */ + int i; int n_words = BCO_NEXT; - StgClosure* con = StackWord(0); - Sp -= n_words; + StgClosure* con = (StgClosure*)StackWord(0); + iSp -= n_words; for (i = 0; i < n_words; i++) - StackWord(i) = con->payload[i]; + StackWord(i) = (W_)con->payload[i]; goto nextInsn; } - case bci_UNPACK_BX: { + case bci_UPK_TAG: { /* Unpack N (non-ptr) words from offset M in the constructor K words down the stack, and then push N as a tag, on top of it. Slow but general; we hope it will be the rare case. */ + int i; int n_words = BCO_NEXT; int con_off = BCO_NEXT; int stk_off = BCO_NEXT; - StgClosure* con = StackWord(stk_off); - Sp -= n_words; + StgClosure* con = (StgClosure*)StackWord(stk_off); + iSp -= n_words; for (i = 0; i < n_words; i++) - StackWord(i) = con->payload[con_off + i]; - Sp --; + StackWord(i) = (W_)con->payload[con_off + i]; + iSp --; StackWord(0) = n_words; goto nextInsn; } - case bci_PACK: + case bci_PACK: { + int i; + int o_itbl = BCO_NEXT; + int n_words = BCO_NEXT; + StgInfoTable* itbl = BCO_ITBL(o_itbl); + /* A bit of a kludge since n_words = n_p + n_np */ + int request = CONSTR_sizeW( n_words, 0 ); + StgClosure* con = (StgClosure*)allocate(request); + SET_HDR(con, itbl, ??); + for (i = 0; i < n_words; i++) + con->payload[i] = (StgClosure*)StackWord(i); + iSp += n_words; + iSp --; + StackWord(0) = (W_)con; + goto nextInsn; + } + case bci_TESTLT_P: { + int discr = BCO_NEXT; + int failto = BCO_NEXT; + StgClosure* con = (StgClosure*)StackWord(0); + if (constrTag(con) < discr) + bciPtr = failto; + goto nextInsn; + } + case bci_TESTEQ_P: { + int discr = BCO_NEXT; + int failto = BCO_NEXT; + StgClosure* con = (StgClosure*)StackWord(0); + if (constrTag(con) != discr) + bciPtr = failto; + goto nextInsn; + } + + /* Control-flow ish things */ + case bci_ENTER: { + goto nextEnter; + } + case bci_RETURN: { + /* Figure out whether returning to interpreted or + compiled code. */ + int o_itoc_itbl = BCO_NEXT; + int tag = StackWord(0); + StgInfoTable* ret_itbl = (StgInfoTable*)StackWord(tag+1 +1); + ASSERT(tag <= 2); /* say ... */ + if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1_info + /* || ret_itbl == stg_ctoi_ret_F1_info + || ret_itbl == stg_ctoi_ret_D1_info */) { + /* Returning to interpreted code. Interpret the BCO + immediately underneath the itbl. */ + StgBCO* ret_bco = (StgBCO*)StackWord(tag+1 +1+1); + iSp --; + StackWord(0) = (W_)ret_bco; + goto nextEnter; + } else { + /* Returning (unboxed value) to compiled code. + Replace tag with a suitable itbl and ask the + scheduler to run it. The itbl code will copy + the TOS value into R1/F1/D1 and do a standard + compiled-code return. */ + StgInfoTable* magic_itbl = BCO_ITBL(o_itoc_itbl); + StackWord(0) = (W_)magic_itbl; + return ThreadRunGHC; + } + } + + case bci_CASEFAIL: + barf("interpretBCO: hit a CASEFAIL"); + + /* As yet unimplemented */ case bci_TESTLT_I: case bci_TESTEQ_I: case bci_TESTLT_F: case bci_TESTEQ_F: case bci_TESTLT_D: case bci_TESTEQ_D: - case bci_TESTLT_P: - case bci_TESTEQ_P: - case bci_CASEFAIL: - - /* Control-flow ish things */ - case bci_ARGCHECK: - case bci_ENTER: - case bci_RETURN: - + /* Errors */ - case bci_LABEL: - default: barf + default: + barf("interpretBCO: unknown or unimplemented opcode"); } /* switch on opcode */ - goto nextEnter; + + barf("interpretBCO: fell off end of insn loop"); } /* ---------------------------------------------------- */ @@ -270,13 +336,12 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) fprintf(stderr, "entering unknown closure -- yielding to sched\n"); printObj(obj); cap->rCurrentTSO->what_next = ThreadEnterGHC; - iSp--; StackWord(0) = obj; + iSp--; StackWord(0) = (W_)obj; return ThreadYielding; } } /* switch on object kind */ - barf("fallen off end of switch in enter()"); + barf("fallen off end of object-type switch in interpretBCO()"); } - -#endif /* 0 */ +#endif /* GHCI */ |