X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FInterpreter.c;h=07c89e2a8132931fc3726dbd6538cab8d13556ed;hb=9710d56a8bf53433d16d6d44da3a6e9a35955cce;hp=7ea66ba9dea61d6c1e4a58668f3348c36205004c;hpb=0d7ca63566b893394ddbb3ca72d64e5913ed0b7b;p=ghc-hetmet.git diff --git a/ghc/rts/Interpreter.c b/ghc/rts/Interpreter.c index 7ea66ba..07c89e2 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.13 $ + * $Date: 2001/01/15 16:55:25 $ * ---------------------------------------------------------------------------*/ #ifdef GHCI @@ -39,6 +39,35 @@ #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; + + +static __inline__ StgPtr allocate_UPD ( int n_words ) +{ + //fprintf(stderr, "alloc_UPD %d -> ", n_words ); + if (n_words - sizeofW(StgHeader) < MIN_UPD_SIZE) + n_words = MIN_UPD_SIZE + sizeofW(StgHeader); + //fprintf(stderr, "%d\n", n_words ); + return allocate(n_words); +} + +static __inline__ StgPtr allocate_NONUPD ( int n_words ) +{ + //fprintf(stderr, "alloc_NONUPD %d -> ", n_words ); + if (n_words - sizeofW(StgHeader) < MIN_NONUPD_SIZE) + n_words = MIN_NONUPD_SIZE + sizeofW(StgHeader); + //fprintf(stderr, "%d\n", n_words ); + return allocate(n_words); +} + + StgThreadReturnCode interpretBCO ( Capability* cap ) { /* On entry, the closure to interpret is on the top of the @@ -52,36 +81,74 @@ 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" ); + + // checkSanity(1); + // iSp--; StackWord(0) = obj; + // checkStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu); + // iSp++; + 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); +#if 0 + case AP_UPD: + { nat Words; + nat i; + StgAP_UPD *ap = (StgAP_UPD*)obj; + Words = ap->n_args; + + /* WARNING: do a stack overflow check here ! + This code (copied from stg_AP_UPD_entry) is not correct without it. */ + + 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; + } +#endif + case BCO: /* ---------------------------------------------------- */ /* Start of the bytecode interpreter */ /* ---------------------------------------------------- */ { + int do_print_stack = 1; register int bciPtr = 1; /* instruction pointer */ register StgBCO* bco = (StgBCO*)obj; register UShort* instrs = (UShort*)(&bco->instrs->payload[0]); @@ -92,22 +159,30 @@ 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); - 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"); - ); + //if (do_print_stack) { + //fprintf(stderr, "\n-- BEGIN stack\n"); + //printStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu); + //fprintf(stderr, "-- END stack\n\n"); + //} + do_print_stack = 1; + 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"); + } + //if (do_print_stack) checkStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu); + ); + switch (BCO_NEXT) { @@ -119,21 +194,29 @@ 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. */ - pap = (StgPAP*)allocate(PAP_sizeW(arg_words_avail)); + /* fprintf(stderr, "arg check fail %d %d\n", arg_words_reqd, arg_words_avail ); */ + pap = (StgPAP*)allocate_UPD(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; + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + printObj((StgClosure*)pap); + ); + RETURN(ThreadEnterGHC); } case bci_PUSH_L: { int o1 = BCO_NEXT; + ASSERT((W_*)iSp+o1 < (W_*)iSu); StackWord(-1) = StackWord(o1); iSp--; + do_print_stack = 0; goto nextInsn; } case bci_PUSH_LL: { @@ -163,19 +246,19 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) case bci_PUSH_AS: { int o_bco = BCO_NEXT; int o_itbl = BCO_NEXT; - StackWord(-1) = BCO_LIT(o_itbl); - StackWord(-2) = BCO_PTR(o_bco); + StackWord(-2) = BCO_LIT(o_itbl); + StackWord(-1) = BCO_PTR(o_bco); iSp -= 2; goto nextInsn; } case bci_PUSH_UBX: { + int i; 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++; - } + iSp -= n_words; + for (i = 0; i < n_words; i++) + StackWord(i) = BCO_LIT(o_lits+i); + do_print_stack = 0; goto nextInsn; } case bci_PUSH_TAG: { @@ -187,7 +270,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 +279,13 @@ 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; + StgAP_UPD* ap; + int n_payload = BCO_NEXT - 1; + int request = AP_sizeW(n_payload); + ap = (StgAP_UPD*)allocate_UPD(request); + StackWord(-1) = (W_)ap; + ap->n_args = n_payload; + SET_HDR(ap, &stg_AP_UPD_info, ??) iSp --; goto nextInsn; } @@ -207,11 +294,15 @@ 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((int)ap->n_args == n_payload); ap->fun = (StgClosure*)StackWord(0); for (i = 0; i < n_payload; i++) ap->payload[i] = (StgClosure*)StackWord(i+1); iSp += n_payload+1; + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + printObj((StgClosure*)ap); + ); goto nextInsn; } case bci_UNPACK: { @@ -246,23 +337,31 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) 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, CCS_SYSTEM/*ToDo*/); + StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_ITBL(o_itbl)); + int request = CONSTR_sizeW( itbl->layout.payload.ptrs, + itbl->layout.payload.nptrs ); + StgClosure* con = (StgClosure*)allocate_NONUPD(request); + //fprintf(stderr, "---PACK p %d, np %d\n", + // (int) itbl->layout.payload.ptrs, + // (int) itbl->layout.payload.nptrs ); + ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0); + SET_HDR(con, BCO_ITBL(o_itbl), CCS_SYSTEM/*ToDo*/); for (i = 0; i < n_words; i++) con->payload[i] = (StgClosure*)StackWord(i); iSp += n_words; iSp --; StackWord(0) = (W_)con; + IF_DEBUG(evaluator, + fprintf(stderr,"\tBuilt "); + printObj((StgClosure*)con); + ); goto nextInsn; } case bci_TESTLT_P: { int discr = BCO_NEXT; int failto = BCO_NEXT; StgClosure* con = (StgClosure*)StackWord(0); - if (constrTag(con) < discr) + if (constrTag(con) >= discr) bciPtr = failto; goto nextInsn; } @@ -274,6 +373,50 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) bciPtr = failto; goto nextInsn; } + case bci_TESTLT_I: { + /* The top thing on the stack should be a tagged int. */ + int discr = BCO_NEXT; + int failto = BCO_NEXT; + I_ stackInt = (I_)StackWord(1); + ASSERT(1 == StackWord(0)); + if (stackInt >= (I_)BCO_LIT(discr)) + bciPtr = failto; + goto nextInsn; + } + case bci_TESTEQ_I: { + /* The top thing on the stack should be a tagged int. */ + int discr = BCO_NEXT; + int failto = BCO_NEXT; + I_ stackInt = (I_)StackWord(1); + ASSERT(1 == StackWord(0)); + if (stackInt != (I_)BCO_LIT(discr)) + bciPtr = failto; + goto nextInsn; + } + case bci_TESTLT_D: { + /* The top thing on the stack should be a tagged double. */ + int discr = BCO_NEXT; + int failto = BCO_NEXT; + StgDouble stackDbl, discrDbl; + ASSERT(sizeofW(StgDouble) == StackWord(0)); + stackDbl = PK_DBL( & StackWord(1) ); + discrDbl = PK_DBL( & BCO_LIT(discr) ); + if (stackDbl >= discrDbl) + bciPtr = failto; + goto nextInsn; + } + case bci_TESTEQ_D: { + /* The top thing on the stack should be a tagged double. */ + int discr = BCO_NEXT; + int failto = BCO_NEXT; + StgDouble stackDbl, discrDbl; + ASSERT(sizeofW(StgDouble) == StackWord(0)); + stackDbl = PK_DBL( & StackWord(1) ); + discrDbl = PK_DBL( & BCO_LIT(discr) ); + if (stackDbl != discrDbl) + bciPtr = failto; + goto nextInsn; + } /* Control-flow ish things */ case bci_ENTER: { @@ -284,14 +427,15 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) compiled code. */ int o_itoc_itbl = BCO_NEXT; int tag = StackWord(0); - StgInfoTable* ret_itbl = (StgInfoTable*)StackWord(tag+1 +1); + StgInfoTable* ret_itbl = (StgInfoTable*)StackWord(tag +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 */) { + if (ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1p_info + || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_R1n_info + || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_F1_info + || ret_itbl == (StgInfoTable*)&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); + StgBCO* ret_bco = (StgBCO*)StackWord(tag +1+1); iSp --; StackWord(0) = (W_)ret_bco; goto nextEnter; @@ -303,7 +447,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); } } @@ -311,12 +455,8 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) 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: /* Errors */ default: @@ -333,11 +473,13 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) default: { /* Can't handle this object; yield to sched. */ - fprintf(stderr, "entering unknown closure -- yielding to sched\n"); - printObj(obj); + IF_DEBUG(evaluator, + fprintf(stderr, "entering unknown closure -- yielding to sched\n"); + printObj(obj); + ) cap->rCurrentTSO->what_next = ThreadEnterGHC; iSp--; StackWord(0) = (W_)obj; - return ThreadYielding; + RETURN(ThreadYielding); } } /* switch on object kind */