X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FInterpreter.c;h=f007c4abd9212c05dfbc409c6d5ca982418dc65c;hb=7c82b4a858411e7363f46d29bbd297e7880ef625;hp=cd7ab131edcc918e05a9e2ca4aeedde27c2b8297;hpb=423d477bfecd490de1449c59325c8776f91d7aac;p=ghc-hetmet.git diff --git a/ghc/rts/Interpreter.c b/ghc/rts/Interpreter.c index cd7ab13..f007c4a 100644 --- a/ghc/rts/Interpreter.c +++ b/ghc/rts/Interpreter.c @@ -13,6 +13,7 @@ #include "Schedule.h" #include "RtsFlags.h" #include "Storage.h" +#include "LdvProfile.h" #include "Updates.h" #include "Sanity.h" #include "Liveness.h" @@ -42,7 +43,7 @@ #define BCO_NEXT instrs[bciPtr++] #define BCO_PTR(n) (W_)ptrs[n] -#define BCO_LIT(n) (W_)literals[n] +#define BCO_LIT(n) literals[n] #define BCO_ITBL(n) itbls[n] #define LOAD_STACK_POINTERS \ @@ -54,9 +55,17 @@ cap->r.rCurrentTSO->sp = Sp #define RETURN_TO_SCHEDULER(todo,retcode) \ - SAVE_STACK_POINTERS; \ - cap->r.rCurrentTSO->what_next = (todo); \ - return (retcode); + SAVE_STACK_POINTERS; \ + cap->r.rCurrentTSO->what_next = (todo); \ + threadPaused(cap->r.rCurrentTSO); \ + cap->r.rRet = (retcode); \ + return cap; + +#define RETURN_TO_SCHEDULER_NO_PAUSE(todo,retcode) \ + SAVE_STACK_POINTERS; \ + cap->r.rCurrentTSO->what_next = (todo); \ + cap->r.rRet = (retcode); \ + return cap; STATIC_INLINE StgPtr @@ -111,22 +120,22 @@ 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", + debugBelch("%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", + debugBelch("%d total entries, %d unknown entries \n", it_total_entries, it_total_unknown_entries); for (i = 0; i < N_CLOSURE_TYPES; i++) { if (it_unknown_entries[i] == 0) continue; - fprintf(stderr, " type %2d: unknown entries (%4.1f%%) == %d\n", + debugBelch(" type %2d: unknown entries (%4.1f%%) == %d\n", i, 100.0 * ((double)it_unknown_entries[i]) / ((double)it_total_unknown_entries), it_unknown_entries[i]); } - fprintf(stderr, "%d insns, %d slides, %d BCO_entries\n", + debugBelch("%d insns, %d slides, %d BCO_entries\n", it_insns, it_slides, it_BCO_entries); for (i = 0; i < 27; i++) - fprintf(stderr, "opcode %2d got %d\n", i, it_ofreq[i] ); + debugBelch("opcode %2d got %d\n", i, it_ofreq[i] ); for (k = 1; k < 20; k++) { o_max = 0; @@ -140,7 +149,7 @@ void interp_shutdown ( void ) } } - fprintf ( stderr, "%d: count (%4.1f%%) %6d is %d then %d\n", + debugBelch("%d: count (%4.1f%%) %6d is %d then %d\n", k, ((double)o_max) * 100.0 / ((double)it_insns), o_max, i_max, j_max ); it_oofreq[i_max][j_max] = 0; @@ -163,7 +172,7 @@ static StgWord app_ptrs_itbl[] = { (W_)&stg_ap_pppppp_info, }; -StgThreadReturnCode +Capability * interpretBCO (Capability* cap) { // Use of register here is primarily to make it clear to compilers @@ -228,14 +237,14 @@ eval_obj: INTERP_TICK(it_total_evals); IF_DEBUG(interpreter, - fprintf(stderr, + debugBelch( "\n---------------------------------------------------------------\n"); - fprintf(stderr,"Evaluating: "); printObj(obj); - fprintf(stderr,"Sp = %p\n", Sp); - fprintf(stderr, "\n" ); + debugBelch("Evaluating: "); printObj(obj); + debugBelch("Sp = %p\n", Sp); + debugBelch("\n" ); printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size); - fprintf(stderr, "\n\n"); + debugBelch("\n\n"); ); IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size)); @@ -327,13 +336,13 @@ eval_obj: { // Can't handle this object; yield to scheduler IF_DEBUG(interpreter, - fprintf(stderr, "evaluating unknown closure -- yielding to sched\n"); + debugBelch("evaluating unknown closure -- yielding to sched\n"); printObj(obj); ); Sp -= 2; Sp[1] = (W_)obj; Sp[0] = (W_)&stg_enter_info; - RETURN_TO_SCHEDULER(ThreadRunGHC, ThreadYielding); + RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding); } } @@ -344,13 +353,13 @@ do_return: ASSERT(closure_HNF(obj)); IF_DEBUG(interpreter, - fprintf(stderr, + debugBelch( "\n---------------------------------------------------------------\n"); - fprintf(stderr,"Returning: "); printObj(obj); - fprintf(stderr,"Sp = %p\n", Sp); - fprintf(stderr, "\n" ); + debugBelch("Returning: "); printObj(obj); + debugBelch("Sp = %p\n", Sp); + debugBelch("\n" ); printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size); - fprintf(stderr, "\n\n"); + debugBelch("\n\n"); ); IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size)); @@ -422,13 +431,13 @@ do_return: // Can't handle this return address; yield to scheduler INTERP_TICK(it_retto_other); IF_DEBUG(interpreter, - fprintf(stderr, "returning to unknown frame -- yielding to sched\n"); + debugBelch("returning to unknown frame -- yielding to sched\n"); printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size); ); Sp -= 2; Sp[1] = (W_)obj; Sp[0] = (W_)&stg_enter_info; - RETURN_TO_SCHEDULER(ThreadRunGHC, ThreadYielding); + RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding); } } @@ -485,10 +494,10 @@ do_return_unboxed: // Can't handle this return address; yield to scheduler INTERP_TICK(it_retto_other); IF_DEBUG(interpreter, - fprintf(stderr, "returning to unknown frame -- yielding to sched\n"); + debugBelch("returning to unknown frame -- yielding to sched\n"); printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size); ); - RETURN_TO_SCHEDULER(ThreadRunGHC, ThreadYielding); + RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding); } } } @@ -507,7 +516,7 @@ do_apply: case PAP: { StgPAP *pap; - nat arity, i; + nat i, arity; pap = (StgPAP *)obj; @@ -527,7 +536,8 @@ do_apply: // Shuffle the args for this function down, and put // the appropriate info table in the gap. for (i = 0; i < arity; i++) { - Sp[i-1] = Sp[i]; + Sp[(int)i-1] = Sp[i]; + // ^^^^^ careful, i-1 might be negative, but i in unsigned } Sp[arity-1] = app_ptrs_itbl[n-arity-1]; Sp--; @@ -583,7 +593,8 @@ do_apply: // Shuffle the args for this function down, and put // the appropriate info table in the gap. for (i = 0; i < arity; i++) { - Sp[i-1] = Sp[i]; + Sp[(int)i-1] = Sp[i]; + // ^^^^^ careful, i-1 might be negative, but i in unsigned } Sp[arity-1] = app_ptrs_itbl[n-arity-1]; Sp--; @@ -617,7 +628,7 @@ do_apply: Sp -= 2; Sp[1] = (W_)obj; Sp[0] = (W_)&stg_enter_info; - RETURN_TO_SCHEDULER(ThreadRunGHC, ThreadYielding); + RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding); } // ------------------------------------------------------------------------ @@ -729,18 +740,18 @@ run_BCO: ASSERT(bciPtr <= instrs[0]); IF_DEBUG(interpreter, //if (do_print_stack) { - //fprintf(stderr, "\n-- BEGIN stack\n"); + //debugBelch("\n-- BEGIN stack\n"); //printStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu); - //fprintf(stderr, "-- END stack\n\n"); + //debugBelch("-- END stack\n\n"); //} - fprintf(stderr,"Sp = %p pc = %d ", Sp, bciPtr); + debugBelch("Sp = %p pc = %d ", Sp, bciPtr); disInstr(bco,bciPtr); if (0) { int i; - fprintf(stderr,"\n"); + debugBelch("\n"); for (i = 8; i >= 0; i--) { - fprintf(stderr, "%d %p\n", i, (StgPtr)(*(Sp+i))); + debugBelch("%d %p\n", i, (StgPtr)(*(Sp+i))); } - fprintf(stderr,"\n"); + debugBelch("\n"); } //if (do_print_stack) checkStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu); ); @@ -901,7 +912,7 @@ run_BCO: int n_words = BCO_NEXT; Sp -= n_words; for (i = 0; i < n_words; i++) { - Sp[i] = BCO_LIT(o_lits+i); + Sp[i] = (W_)BCO_LIT(o_lits+i); } goto nextInsn; } @@ -962,7 +973,7 @@ run_BCO: ap->payload[i] = (StgClosure*)Sp[i+1]; Sp += n_payload+1; IF_DEBUG(interpreter, - fprintf(stderr,"\tBuilt "); + debugBelch("\tBuilt "); printObj((StgClosure*)ap); ); goto nextInsn; @@ -997,14 +1008,14 @@ run_BCO: Sp --; Sp[0] = (W_)con; IF_DEBUG(interpreter, - fprintf(stderr,"\tBuilt "); + debugBelch("\tBuilt "); printObj((StgClosure*)con); ); goto nextInsn; } case bci_TESTLT_P: { - int discr = BCO_NEXT; + unsigned int discr = BCO_NEXT; int failto = BCO_NEXT; StgClosure* con = (StgClosure*)Sp[0]; if (GET_TAG(con) >= discr) { @@ -1014,7 +1025,7 @@ run_BCO: } case bci_TESTEQ_P: { - int discr = BCO_NEXT; + unsigned int discr = BCO_NEXT; int failto = BCO_NEXT; StgClosure* con = (StgClosure*)Sp[0]; if (GET_TAG(con) != discr) { @@ -1147,7 +1158,7 @@ run_BCO: } case bci_CCALL: { - StgInt tok; + void *tok; int stk_offset = BCO_NEXT; int o_itbl = BCO_NEXT; void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl); @@ -1155,7 +1166,7 @@ run_BCO: RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE + sizeofW(StgRetDyn); -#ifdef RTS_SUPPORTS_THREADS +#ifdef THREADED_RTS // Threaded RTS: // Arguments on the TSO stack are not good, because garbage // collection might move the TSO as soon as we call @@ -1186,7 +1197,7 @@ run_BCO: SAVE_STACK_POINTERS; tok = suspendThread(&cap->r); -#ifndef RTS_SUPPORTS_THREADS +#ifndef THREADED_RTS // Careful: // suspendThread might have shifted the stack // around (stack squeezing), so we have to grab the real @@ -1208,7 +1219,7 @@ run_BCO: // Save the Haskell thread's current value of errno cap->r.rCurrentTSO->saved_errno = errno; -#ifdef RTS_SUPPORTS_THREADS +#ifdef THREADED_RTS // Threaded RTS: // Copy the "arguments", which might include a return value, // back to the TSO stack. It would of course be enough to