X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FInterpreter.c;h=f56194c84d84402a6c06bf72c2a9b4f79c1eae4e;hb=1041f9abb1e0c117dab3b1f7e3e1960dfb0efe0d;hp=c7500efd9f1f6daf7eba5ef5aa119667e6a2fde5;hpb=66501562de9d34aed2ef662da6b0c17795e0dab5;p=ghc-hetmet.git diff --git a/ghc/rts/Interpreter.c b/ghc/rts/Interpreter.c index c7500ef..f56194c 100644 --- a/ghc/rts/Interpreter.c +++ b/ghc/rts/Interpreter.c @@ -5,10 +5,11 @@ * Copyright (c) 1994-2000. * * $RCSfile: Interpreter.c,v $ - * $Revision: 1.19 $ - * $Date: 2001/02/13 11:11:06 $ + * $Revision: 1.32 $ + * $Date: 2001/11/14 11:46:12 $ * ---------------------------------------------------------------------------*/ +#include "PosixSource.h" #include "Rts.h" #include "RtsAPI.h" #include "RtsUtils.h" @@ -54,13 +55,18 @@ #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 LOAD_STACK_POINTERS \ + iSp = cap->r.rCurrentTSO->sp; \ + iSu = cap->r.rCurrentTSO->su; \ + /* We don't change this ... */ \ + iSpLim = cap->r.rCurrentTSO->stack + RESERVED_STACK_WORDS; -#define SAVE_STACK_POINTERS \ - cap->rCurrentTSO->sp = iSp; cap->rCurrentTSO->su = iSu; -#define RETURN(retcode) \ +#define SAVE_STACK_POINTERS \ + cap->r.rCurrentTSO->sp = iSp; \ + cap->r.rCurrentTSO->su = iSu; + +#define RETURN(retcode) \ SAVE_STACK_POINTERS; return retcode; @@ -115,7 +121,7 @@ void interp_startup ( void ) void interp_shutdown ( void ) { int i, j, k, o_max, i_max, j_max; - fprintf(stderr, "%d constrs entered -> (%d BCO, %d UPD, %d ???)\n", + fprintf(stderr, "%d constrs entered -> (%d BCO, %d UPD, %d ??? )\n", it_retto_BCO + it_retto_UPDATE + it_retto_other, it_retto_BCO, it_retto_UPDATE, it_retto_other ); fprintf(stderr, "%d total entries, %d unknown entries \n", @@ -169,9 +175,6 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) LOAD_STACK_POINTERS; - /* We don't change this ... */ - iSpLim = cap->rCurrentTSO->stack + RESERVED_STACK_WORDS; - /* Main object-entering loop. Object to be entered is on top of stack. */ nextEnter: @@ -193,10 +196,10 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) // checkSanity(1); // iSp--; StackWord(0) = obj; - // checkStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu); + // checkStack(iSp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu); // iSp++; - printStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu); + printStack(iSp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu); fprintf(stderr, "\n\n"); ); @@ -370,7 +373,7 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) /* Heap check */ if (doYouWantToGC()) { iSp--; StackWord(0) = (W_)bco; - cap->rCurrentTSO->what_next = ThreadEnterInterp; + cap->r.rCurrentTSO->what_next = ThreadEnterInterp; RETURN(HeapOverflow); } @@ -378,7 +381,7 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) if (iSp - (INTERP_STACK_CHECK_THRESH+1) < iSpLim) { iSp--; StackWord(0) = (W_)obj; - cap->rCurrentTSO->what_next = ThreadEnterInterp; + cap->r.rCurrentTSO->what_next = ThreadEnterInterp; RETURN(StackOverflow); } @@ -386,7 +389,7 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) if (context_switch) { iSp--; StackWord(0) = (W_)obj; - cap->rCurrentTSO->what_next = ThreadEnterInterp; + cap->r.rCurrentTSO->what_next = ThreadEnterInterp; RETURN(ThreadYielding); } @@ -401,7 +404,7 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) IF_DEBUG(evaluator, //if (do_print_stack) { //fprintf(stderr, "\n-- BEGIN stack\n"); - //printStack(iSp,cap->rCurrentTSO->stack+cap->rCurrentTSO->stack_size,iSu); + //printStack(iSp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu); //fprintf(stderr, "-- END stack\n\n"); //} do_print_stack = 1; @@ -413,7 +416,7 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) 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); + //if (do_print_stack) checkStack(iSp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu); ); # ifdef INTERP_STATS @@ -433,7 +436,7 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) if (iSp - stk_words_reqd < iSpLim) { iSp--; StackWord(0) = (W_)obj; - cap->rCurrentTSO->what_next = ThreadEnterInterp; + cap->r.rCurrentTSO->what_next = ThreadEnterInterp; RETURN(StackOverflow); } goto nextInsn; @@ -477,7 +480,7 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) fprintf(stderr,"\tBuilt "); printObj((StgClosure*)pap); ); - cap->rCurrentTSO->what_next = ThreadEnterGHC; + cap->r.rCurrentTSO->what_next = ThreadEnterGHC; RETURN(ThreadYielding); } case bci_PUSH_L: { @@ -691,6 +694,30 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) bciPtr = failto; goto nextInsn; } + case bci_TESTLT_F: { + /* The top thing on the stack should be a tagged float. */ + int discr = BCO_NEXT; + int failto = BCO_NEXT; + StgFloat stackFlt, discrFlt; + ASSERT(sizeofW(StgFloat) == StackWord(0)); + stackFlt = PK_FLT( & StackWord(1) ); + discrFlt = PK_FLT( & BCO_LIT(discr) ); + if (stackFlt >= discrFlt) + bciPtr = failto; + goto nextInsn; + } + case bci_TESTEQ_F: { + /* The top thing on the stack should be a tagged float. */ + int discr = BCO_NEXT; + int failto = BCO_NEXT; + StgFloat stackFlt, discrFlt; + ASSERT(sizeofW(StgFloat) == StackWord(0)); + stackFlt = PK_FLT( & StackWord(1) ); + discrFlt = PK_FLT( & BCO_LIT(discr) ); + if (stackFlt != discrFlt) + bciPtr = failto; + goto nextInsn; + } /* Control-flow ish things */ case bci_ENTER: { @@ -706,7 +733,8 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) 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) { + || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_D1_info + || ret_itbl == (StgInfoTable*)&stg_ctoi_ret_V_info) { /* Returning to interpreted code. Interpret the BCO immediately underneath the itbl. */ StgBCO* ret_bco = (StgBCO*)StackWord(tag +1+1); @@ -720,19 +748,48 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) 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; - cap->rCurrentTSO->what_next = ThreadRunGHC; - RETURN(ThreadYielding); + if (magic_itbl != NULL) { + StackWord(0) = (W_)magic_itbl; + cap->r.rCurrentTSO->what_next = ThreadRunGHC; + RETURN(ThreadYielding); + } else { + /* Special case -- returning a VoidRep to + compiled code. T.O.S is the VoidRep tag, + and underneath is the return itbl. Zap the + tag and enter the itbl. */ + ASSERT(StackWord(0) == (W_)NULL); + iSp ++; + cap->r.rCurrentTSO->what_next = ThreadRunGHC; + RETURN(ThreadYielding); + } } } - + case bci_SWIZZLE: { + int stkoff = BCO_NEXT; + signed short n = (signed short)(BCO_NEXT); + StackWord(stkoff) += (W_)n; + goto nextInsn; + } + case bci_CCALL: { + StgInt tok; + int o_itbl = BCO_NEXT; + void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl); + SAVE_STACK_POINTERS; + tok = suspendThread(&cap->r); + marshall_fn ( (void*)(& StackWord(0) ) ); + cap = (Capability *)((void *)resumeThread(tok) - sizeof(StgFunTable)); + LOAD_STACK_POINTERS; + goto nextInsn; + } + case bci_JMP: { + /* BCO_NEXT modifies bciPtr, so be conservative. */ + int nextpc = BCO_NEXT; + bciPtr = nextpc; + goto nextInsn; + } case bci_CASEFAIL: barf("interpretBCO: hit a CASEFAIL"); - /* As yet unimplemented */ - case bci_TESTLT_F: - case bci_TESTEQ_F: - /* Errors */ default: barf("interpretBCO: unknown or unimplemented opcode"); @@ -762,7 +819,7 @@ StgThreadReturnCode interpretBCO ( Capability* cap ) printObj(obj); ); iSp--; StackWord(0) = (W_)obj; - cap->rCurrentTSO->what_next = ThreadEnterGHC; + cap->r.rCurrentTSO->what_next = ThreadEnterGHC; RETURN(ThreadYielding); } } /* switch on object kind */