From 8f417a2d02071611eb5c06ae99eda1e2190e4de2 Mon Sep 17 00:00:00 2001 From: sewardj Date: Wed, 3 Jan 2001 16:44:30 +0000 Subject: [PATCH] [project @ 2001-01-03 16:44:29 by sewardj] Start getting the bytecode interpreter to work. A matching commit to compiler/ghci/ByteCodeGen.lhs follows ... --- ghc/compiler/nativeGen/StixPrim.lhs | 3 ++ ghc/compiler/prelude/primops.txt | 18 ++----- ghc/includes/PrimOps.h | 71 ++-------------------------- ghc/lib/std/PrelGHC.hi-boot | 1 + ghc/rts/Disassembler.c | 35 +++++++++++--- ghc/rts/Interpreter.c | 89 ++++++++++++++++++++++++++--------- ghc/rts/Printer.c | 7 ++- 7 files changed, 111 insertions(+), 113 deletions(-) diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index accb9fe..1a699bc 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -81,6 +81,9 @@ primCode [res] Int2WordOp [arg] primCode [res] Word2IntOp [arg] = simpleCoercion IntRep res arg + +primCode [res] AddrToHValueOp [arg] + = simpleCoercion PtrRep res arg \end{code} \begin{code} diff --git a/ghc/compiler/prelude/primops.txt b/ghc/compiler/prelude/primops.txt index 3550ff6..9bee278 100644 --- a/ghc/compiler/prelude/primops.txt +++ b/ghc/compiler/prelude/primops.txt @@ -1,5 +1,5 @@ ----------------------------------------------------------------------- --- $Id: primops.txt,v 1.12 2000/12/15 17:14:39 sewardj Exp $ +-- $Id: primops.txt,v 1.13 2001/01/03 16:44:29 sewardj Exp $ -- -- Primitive Operations -- @@ -43,21 +43,13 @@ defaults ------------------------------------------------------------------------ ---- Support for the metacircular interpreter --- +--- Support for the bytecode linker --- ------------------------------------------------------------------------ -primop IndexOffClosureOp_Ptr "indexPtrOffClosure#" GenPrimOp - a -> Int# -> (# b #) -primop IndexOffClosureOp_Word "indexWordOffClosure#" GenPrimOp - a -> Int# -> Word# +-- Convert an Addr# to a followable type +primop AddrToHValueOp "addrToHValue#" GenPrimOp + Addr# -> (# a #) -primop SetOffClosureOp_Ptr "setPtrOffClosure#" GenPrimOp - a -> Int# -> b -> (# a #) - with strictness = { \ arity -> StrictnessInfo [wwStrict, wwPrim, wwLazy] False } - -primop SetOffClosureOp_Word "setWordOffClosure#" GenPrimOp - a -> Int# -> Word# -> (# a #) - with strictness = { \ arity -> StrictnessInfo [wwStrict, wwPrim, wwPrim] False } ------------------------------------------------------------------------ --- Addr# --- diff --git a/ghc/includes/PrimOps.h b/ghc/includes/PrimOps.h index 9a1c271..2c5a7dc 100644 --- a/ghc/includes/PrimOps.h +++ b/ghc/includes/PrimOps.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: PrimOps.h,v 1.70 2000/12/12 12:19:57 simonmar Exp $ + * $Id: PrimOps.h,v 1.71 2001/01/03 16:44:29 sewardj Exp $ * * (c) The GHC Team, 1998-2000 * @@ -11,66 +11,11 @@ #define PRIMOPS_H /* ----------------------------------------------------------------------------- - Helpers for the metacircular interpreter. + Helpers for the bytecode linker. -------------------------------------------------------------------------- */ -#ifdef GHCI - -#define CHASE_INDIRECTIONS(lval) \ - do { \ - int again; \ - do { \ - again = 0; \ - if (get_itbl((StgClosure*)lval)->type == IND) \ - { again = 1; lval = ((StgInd*)lval)->indirectee; } \ - else \ - if (get_itbl((StgClosure*)lval)->type == IND_OLDGEN) \ - { again = 1; lval = ((StgIndOldGen*)lval)->indirectee; } \ - } while (again); \ - } while (0) - -#define indexWordOffClosurezh(r,a,i) \ - do { StgClosure* tmp = (StgClosure*)(a); \ - CHASE_INDIRECTIONS(tmp); \ - r = ((P_)tmp)[i]; \ - } while (0) - -#define indexDoubleOffClosurezh(r,a,i) \ - do { StgClosure* tmp = (StgClosure*)(a); \ - CHASE_INDIRECTIONS(tmp); \ - r = PK_DBL(((P_)tmp + i); \ - } while (0) - -#define indexPtrOffClosurezh(r,a,i) \ - do { StgClosure* tmp = (StgClosure*)(a); \ - CHASE_INDIRECTIONS(tmp); \ - r = ((P_ *)tmp)[i]; \ - } while (0) \ - -#define setWordOffClosurezh(r,a,i,b) \ - do { StgClosure* tmp = (StgClosure*)(a); \ - CHASE_INDIRECTIONS(tmp); \ - ((P_)tmp)[i] = b; \ - r = (P_)tmp; \ - } while (0) - -#define setDoubleOffClosurezh(r,a,i,b) \ - do { StgClosure* tmp = (StgClosure*)(a); \ - CHASE_INDIRECTIONS(tmp); \ - ASSIGN_DBL((P_)tmp + i, b); \ - r = (P_)tmp; \ - } while (0) - -#define setPtrOffClosurezh(r,a,i,b) \ - do { StgClosure* tmp = (StgClosure*)(a); \ - CHASE_INDIRECTIONS(tmp); \ - ((P_ *)tmp)[i] = b; \ - r = (P_)tmp; \ - } while (0) +#define addrToHValuezh(r,a) r=(P_)a -#else - -#endif /* ----------------------------------------------------------------------------- Comparison PrimOps. @@ -984,16 +929,7 @@ EXTFUN_RTS(mkForeignObjzh_fast); Constructor tags -------------------------------------------------------------------------- */ -#ifdef GHCI -#define dataToTagzh(r,a) \ - do { StgClosure* tmp = (StgClosure*)(a); \ - CHASE_INDIRECTIONS(tmp); \ - r = (GET_TAG(((StgClosure *)tmp)->header.info)); \ - } while (0) -#else -/* Original version doesn't chase indirections. */ #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info)) -#endif /* tagToEnum# is handled directly by the code generator. */ @@ -1002,7 +938,6 @@ EXTFUN_RTS(mkForeignObjzh_fast); -------------------------------------------------------------------------- */ EXTFUN_RTS(newBCOzh_fast); -#define getBCOPtrszh(r,bco) r=((StgBCO *)bco)->ptrs /* ----------------------------------------------------------------------------- Signal processing. Not really primops, but called directly from diff --git a/ghc/lib/std/PrelGHC.hi-boot b/ghc/lib/std/PrelGHC.hi-boot index 53ffd41..219fc8b 100644 --- a/ghc/lib/std/PrelGHC.hi-boot +++ b/ghc/lib/std/PrelGHC.hi-boot @@ -388,6 +388,7 @@ __export PrelGHC BCOzh unsafeCoercezh + addrToHValuezh ; -- Export PrelErr.error, so that others don't have to import PrelErr diff --git a/ghc/rts/Disassembler.c b/ghc/rts/Disassembler.c index 72715a4..29d40d6 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.16 $ - * $Date: 2000/12/20 14:47:22 $ + * $Revision: 1.17 $ + * $Date: 2001/01/03 16:44:30 $ * ---------------------------------------------------------------------------*/ #ifdef GHCI @@ -58,7 +58,8 @@ int disInstr ( StgBCO *bco, int pc ) instrs[pc+2] ); pc += 3; break; case bci_PUSH_G: - fprintf(stderr, "PUSH_G " ); printPtr( ptrs[instrs[pc]] ); + fprintf(stderr, "PUSH_G " ); printPtr( ptrs[instrs[pc]] ); + fprintf(stderr, "\n" ); pc += 1; break; case bci_PUSH_AS: fprintf(stderr, "PUSH_AS " ); printPtr( ptrs[instrs[pc]] ); @@ -151,17 +152,39 @@ int disInstr ( StgBCO *bco, int pc ) */ void disassemble( StgBCO *bco ) { + nat i, j; StgArrWords* instr_arr = bco->instrs; UShort* instrs = (UShort*)(&instr_arr->payload[0]); - int nbcs = (int)instrs[0]; - int pc = 1; + StgMutArrPtrs* ptrs = bco->ptrs; + nat nbcs = (int)instrs[0]; + nat pc = 1; - fprintf(stderr, "\n\nBCO %p =\n", bco ); + fprintf(stderr, "BCO\n" ); pc = 1; while (pc <= nbcs) { fprintf(stderr, "\t%2d: ", pc ); pc = disInstr ( bco, pc ); } + + fprintf(stderr, "INSTRS:\n " ); + j = 16; + for (i = 0; i < nbcs; i++) { + fprintf(stderr, "%3d ", (int)instrs[i] ); + j--; + if (j == 0) { j = 16; fprintf(stderr, "\n "); }; + } + fprintf(stderr, "\n"); + + fprintf(stderr, "PTRS:\n " ); + j = 8; + for (i = 0; i < ptrs->ptrs; i++) { + fprintf(stderr, "%8p ", ptrs->payload[i] ); + j--; + if (j == 0) { j = 8; fprintf(stderr, "\n "); }; + } + fprintf(stderr, "\n"); + + fprintf(stderr, "\n"); ASSERT(pc == nbcs+1); } diff --git a/ghc/rts/Interpreter.c b/ghc/rts/Interpreter.c index 7ea66ba..7187b60 100644 --- a/ghc/rts/Interpreter.c +++ b/ghc/rts/Interpreter.c @@ -5,8 +5,8 @@ * Copyright (c) 1994-2000. * * $RCSfile: Interpreter.c,v $ - * $Revision: 1.6 $ - * $Date: 2001/01/03 15:30:48 $ + * $Revision: 1.7 $ + * $Date: 2001/01/03 16:44:30 $ * ---------------------------------------------------------------------------*/ #ifdef GHCI @@ -39,6 +39,16 @@ #define BCO_LIT(n) (W_)literals[n] #define BCO_ITBL(n) itbls[n] +#define LOAD_STACK_POINTERS \ + iSp = cap->rCurrentTSO->sp; iSu = cap->rCurrentTSO->su; + +#define SAVE_STACK_POINTERS \ + cap->rCurrentTSO->sp = iSp; cap->rCurrentTSO->su = iSu; + +#define RETURN(retcode) \ + SAVE_STACK_POINTERS; return retcode; + + StgThreadReturnCode interpretBCO ( Capability* cap ) { /* On entry, the closure to interpret is on the top of the @@ -52,30 +62,57 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) register StgPtr iSpLim; /* local state -- stack lim pointer */ register StgClosure* obj; - iSp = cap->rCurrentTSO->sp; - iSu = cap->rCurrentTSO->su; + LOAD_STACK_POINTERS; + iSpLim = cap->rCurrentTSO->stack + RESERVED_STACK_WORDS; + /* Main object-entering loop. Object to be entered is on top of + stack. */ + nextEnter: + + obj = (StgClosure*)StackWord(0); iSp++; + IF_DEBUG(evaluator, fprintf(stderr, "\n---------------------------------------------------------------\n"); - fprintf(stderr,"Entering: "); printObj((StgClosure*)StackWord(0)); + fprintf(stderr,"Entering: "); printObj(obj); 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"); ); - /* Main object-entering loop. Object to be entered is on top of - stack. */ - nextEnter: - - obj = (StgClosure*)StackWord(0); iSp++; - switch ( get_itbl(obj)->type ) { case INVALID_OBJECT: barf("Invalid object %p",(StgPtr)obj); + case AP_UPD: + { nat Words; + nat i; + StgAP_UPD *ap = (StgAP_UPD*)obj; +fprintf(stderr, "home-grown AP_UPD code\n"); + Words = ap->n_args; + + iSp -= sizeofW(StgUpdateFrame); + + { + StgUpdateFrame *__frame; + __frame = (StgUpdateFrame *)iSp; + SET_INFO(__frame, (StgInfoTable *)&stg_upd_frame_info); + __frame->link = iSu; + __frame->updatee = (StgClosure *)(ap); + iSu = __frame; + } + + iSp -= Words; + + /* Reload the stack */ + for (i=0; ipayload[i]; + + iSp--; StackWord(0) = (W_)ap->fun; + goto nextEnter; + } + case BCO: /* ---------------------------------------------------- */ @@ -92,21 +129,24 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) if (doYouWantToGC()) { iSp--; StackWord(0) = (W_)bco; - return HeapOverflow; + RETURN(HeapOverflow); } nextInsn: ASSERT(bciPtr <= instrs[0]); IF_DEBUG(evaluator, - fprintf(stderr,"iSp = %p\tiSu = %p\tpc = %d\t", iSp, iSu, bciPtr); + //fprintf(stderr, "\n-- BEGIN stack\n"); + //printStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu); + //fprintf(stderr, "-- END stack\n\n"); + fprintf(stderr,"iSp = %p iSu = %p pc = %d ", 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)(*(iSp+i))); + fprintf(stderr,"\n"); } - fprintf(stderr,"\n"); ); switch (BCO_NEXT) { @@ -119,19 +159,22 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) if (arg_words_avail >= arg_words_reqd) goto nextInsn; /* Handle arg check failure. Copy the spare args into a PAP frame. */ + fprintf(stderr, "arg check fail %d %d\n", arg_words_reqd, arg_words_avail ); pap = (StgPAP*)allocate(PAP_sizeW(arg_words_avail)); SET_HDR(pap,&stg_PAP_info,CCS_SYSTEM/*ToDo*/); pap->n_args = arg_words_avail; + pap->fun = obj; 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; + RETURN(ThreadEnterGHC); } case bci_PUSH_L: { int o1 = BCO_NEXT; + ASSERT((W_*)iSp+o1 < (W_*)iSu); StackWord(-1) = StackWord(o1); iSp--; goto nextInsn; @@ -187,7 +230,7 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) case bci_SLIDE: { int n = BCO_NEXT; int by = BCO_NEXT; - ASSERT(iSp+n+by <= (W_*)iSu); + ASSERT((W_*)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); @@ -196,9 +239,11 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) goto nextInsn; } case bci_ALLOC: { - int n_payload = BCO_NEXT; - P_ p = allocate(AP_sizeW(n_payload)); - StackWord(-1) = (W_)p; + int n_payload = BCO_NEXT - 1; + StgAP_UPD* ap = (StgAP_UPD*)allocate(AP_sizeW(n_payload)); + StackWord(-1) = (W_)ap; + ap->n_args = n_payload; + SET_HDR(ap, &stg_AP_UPD_info, ??) iSp --; goto nextInsn; } @@ -207,7 +252,7 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) int stkoff = BCO_NEXT; int n_payload = BCO_NEXT - 1; StgAP_UPD* ap = (StgAP_UPD*)StackWord(stkoff); - ap->n_args = n_payload; + ASSERT(ap->n_args == n_payload); ap->fun = (StgClosure*)StackWord(0); for (i = 0; i < n_payload; i++) ap->payload[i] = (StgClosure*)StackWord(i+1); @@ -303,7 +348,7 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) compiled-code return. */ StgInfoTable* magic_itbl = BCO_ITBL(o_itoc_itbl); StackWord(0) = (W_)magic_itbl; - return ThreadRunGHC; + RETURN(ThreadRunGHC); } } @@ -337,7 +382,7 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) printObj(obj); cap->rCurrentTSO->what_next = ThreadEnterGHC; iSp--; StackWord(0) = (W_)obj; - return ThreadYielding; + RETURN(ThreadYielding); } } /* switch on object kind */ diff --git a/ghc/rts/Printer.c b/ghc/rts/Printer.c index 466eba7..4b85b20 100644 --- a/ghc/rts/Printer.c +++ b/ghc/rts/Printer.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Printer.c,v 1.29 2000/12/11 12:40:24 simonmar Exp $ + * $Id: Printer.c,v 1.30 2001/01/03 16:44:30 sewardj Exp $ * * (c) The GHC Team, 1994-2000. * @@ -95,10 +95,9 @@ void printClosure( StgClosure *obj ) switch ( get_itbl(obj)->type ) { case INVALID_OBJECT: barf("Invalid object"); -#ifdef INTERPRETER +#ifdef GHCI case BCO: - fprintf(stderr,"BCO\n"); - disassemble(stgCast(StgBCO*,obj),"\t"); + disassemble( (StgBCO*)obj ); break; #endif -- 1.7.10.4