X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=rts%2FInterpreter.c;h=527ebde0d01211da37a2b8e1a5541dbbffb0d979;hb=decf06a77b1331d3af9304e55164bb0a51c15a7f;hp=62fe50530e2d2cbe6b7197ce94aad02eeefe07d9;hpb=ab0e778ccfde61aed4c22679b24d175fc6cc9bf3;p=ghc-hetmet.git diff --git a/rts/Interpreter.c b/rts/Interpreter.c index 62fe505..527ebde 100644 --- a/rts/Interpreter.c +++ b/rts/Interpreter.c @@ -10,13 +10,13 @@ #include "RtsUtils.h" #include "Closures.h" #include "TSO.h" -#include "Storage.h" #include "Schedule.h" #include "RtsFlags.h" #include "LdvProfile.h" #include "Updates.h" #include "Sanity.h" #include "Liveness.h" +#include "Prelude.h" #include "Bytecodes.h" #include "Printer.h" @@ -42,9 +42,19 @@ /* Sp points to the lowest live word on the stack. */ #define BCO_NEXT instrs[bciPtr++] +#define BCO_NEXT_32 (bciPtr += 2, (((StgWord) instrs[bciPtr-2]) << 16) + ((StgWord) instrs[bciPtr-1])) +#define BCO_NEXT_64 (bciPtr += 4, (((StgWord) instrs[bciPtr-4]) << 48) + (((StgWord) instrs[bciPtr-3]) << 32) + (((StgWord) instrs[bciPtr-2]) << 16) + ((StgWord) instrs[bciPtr-1])) +#if WORD_SIZE_IN_BITS == 32 +#define BCO_NEXT_WORD BCO_NEXT_32 +#elif WORD_SIZE_IN_BITS == 64 +#define BCO_NEXT_WORD BCO_NEXT_64 +#else +#error Cannot cope with WORD_SIZE_IN_BITS being nether 32 nor 64 +#endif +#define BCO_GET_LARGE_ARG ((bci & bci_FLAG_LARGE_ARGS) ? BCO_NEXT_WORD : BCO_NEXT) + #define BCO_PTR(n) (W_)ptrs[n] #define BCO_LIT(n) literals[n] -#define BCO_ITBL(n) itbls[n] #define LOAD_STACK_POINTERS \ Sp = cap->r.rCurrentTSO->sp; \ @@ -74,6 +84,8 @@ allocate_NONUPD (int n_words) return allocate(stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words)); } +int rts_stop_next_breakpoint = 0; +int rts_stop_on_exception = 0; #ifdef INTERP_STATS @@ -94,6 +106,7 @@ int it_ofreq[27]; int it_oofreq[27][27]; int it_lastopc; + #define INTERP_TICK(n) (n)++ void interp_startup ( void ) @@ -166,6 +179,9 @@ static StgWord app_ptrs_itbl[] = { (W_)&stg_ap_pppppp_info, }; +HsStablePtr rts_breakpoint_io_action; // points to the IO action which is executed on a breakpoint + // it is set in main/GHC.hs:runStmt + Capability * interpretBCO (Capability* cap) { @@ -189,8 +205,8 @@ interpretBCO (Capability* cap) // +---------------+ // if (Sp[0] == (W_)&stg_enter_info) { - Sp++; - goto eval; + Sp++; + goto eval; } // ------------------------------------------------------------------------ @@ -208,7 +224,7 @@ interpretBCO (Capability* cap) // +---------------+ // else if (Sp[0] == (W_)&stg_apply_interp_info) { - obj = (StgClosure *)Sp[1]; + obj = UNTAG_CLOSURE((StgClosure *)Sp[1]); Sp += 2; goto run_BCO_fun; } @@ -228,6 +244,7 @@ eval: obj = (StgClosure*)Sp[0]; Sp++; eval_obj: + obj = UNTAG_CLOSURE(obj); INTERP_TICK(it_total_evals); IF_DEBUG(interpreter, @@ -275,8 +292,10 @@ eval_obj: break; case BCO: + { ASSERT(((StgBCO *)obj)->arity > 0); break; + } case AP: /* Copied from stg_AP_entry. */ { @@ -309,7 +328,7 @@ eval_obj: Sp[i] = (W_)ap->payload[i]; } - obj = (StgClosure*)ap->fun; + obj = UNTAG_CLOSURE((StgClosure*)ap->fun); ASSERT(get_itbl(obj)->type == BCO); goto run_BCO_fun; } @@ -513,7 +532,7 @@ do_apply: pap = (StgPAP *)obj; // we only cope with PAPs whose function is a BCO - if (get_itbl(pap->fun)->type != BCO) { + if (get_itbl(UNTAG_CLOSURE(pap->fun))->type != BCO) { goto defer_apply_to_sched; } @@ -538,7 +557,7 @@ do_apply: for (i = 0; i < pap->n_args; i++) { Sp[i] = (W_)pap->payload[i]; } - obj = pap->fun; + obj = UNTAG_CLOSURE(pap->fun); goto run_BCO_fun; } else if (arity == n) { @@ -546,7 +565,7 @@ do_apply: for (i = 0; i < pap->n_args; i++) { Sp[i] = (W_)pap->payload[i]; } - obj = pap->fun; + obj = UNTAG_CLOSURE(pap->fun); goto run_BCO_fun; } else /* arity > n */ { @@ -663,6 +682,7 @@ do_apply: // Sadly we have three different kinds of stack/heap/cswitch check // to do: + run_BCO_return: // Heap check if (doYouWantToGC()) { @@ -671,6 +691,7 @@ run_BCO_return: } // Stack checks aren't necessary at return points, the stack use // is aggregated into the enclosing function entry point. + goto run_BCO; run_BCO_return_unboxed: @@ -680,6 +701,7 @@ run_BCO_return_unboxed: } // Stack checks aren't necessary at return points, the stack use // is aggregated into the enclosing function entry point. + goto run_BCO; run_BCO_fun: @@ -706,6 +728,7 @@ run_BCO_fun: Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow); } + goto run_BCO; // Now, actually interpret the BCO... (no returning to the @@ -714,12 +737,11 @@ run_BCO: INTERP_TICK(it_BCO_entries); { register int bciPtr = 1; /* instruction pointer */ + register StgWord16 bci; register StgBCO* bco = (StgBCO*)obj; register StgWord16* instrs = (StgWord16*)(bco->instrs->payload); register StgWord* literals = (StgWord*)(&bco->literals->payload[0]); register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]); - register StgInfoTable** itbls = (StgInfoTable**) - (&bco->itbls->payload[0]); #ifdef INTERP_STATS it_lastopc = 0; /* no opcode */ @@ -745,6 +767,7 @@ run_BCO: //if (do_print_stack) checkStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu); ); + INTERP_TICK(it_insns); #ifdef INTERP_STATS @@ -754,13 +777,110 @@ run_BCO: it_lastopc = (int)instrs[bciPtr]; #endif - switch (BCO_NEXT) { + bci = BCO_NEXT; + /* We use the high 8 bits for flags, only the highest of which is + * currently allocated */ + ASSERT((bci & 0xFF00) == (bci & 0x8000)); + + switch (bci & 0xFF) { + + /* check for a breakpoint on the beginning of a let binding */ + case bci_BRK_FUN: + { + int arg1_brk_array, arg2_array_index, arg3_freeVars; + StgArrWords *breakPoints; + int returning_from_break; // are we resuming execution from a breakpoint? + // if yes, then don't break this time around + StgClosure *ioAction; // the io action to run at a breakpoint + + StgAP_STACK *new_aps; // a closure to save the top stack frame on the heap + int i; + int size_words; + + arg1_brk_array = BCO_NEXT; // 1st arg of break instruction + arg2_array_index = BCO_NEXT; // 2nd arg of break instruction + arg3_freeVars = BCO_NEXT; // 3rd arg of break instruction + + // check if we are returning from a breakpoint - this info + // is stored in the flags field of the current TSO + returning_from_break = cap->r.rCurrentTSO->flags & TSO_STOPPED_ON_BREAKPOINT; + + // if we are returning from a break then skip this section + // and continue executing + if (!returning_from_break) + { + breakPoints = (StgArrWords *) BCO_PTR(arg1_brk_array); + + // stop the current thread if either the + // "rts_stop_next_breakpoint" flag is true OR if the + // breakpoint flag for this particular expression is + // true + if (rts_stop_next_breakpoint == rtsTrue || + breakPoints->payload[arg2_array_index] == rtsTrue) + { + // make sure we don't automatically stop at the + // next breakpoint + rts_stop_next_breakpoint = rtsFalse; + + // allocate memory for a new AP_STACK, enough to + // store the top stack frame plus an + // stg_apply_interp_info pointer and a pointer to + // the BCO + size_words = BCO_BITMAP_SIZE(obj) + 2; + new_aps = (StgAP_STACK *) allocate (AP_STACK_sizeW(size_words)); + SET_HDR(new_aps,&stg_AP_STACK_info,CCS_SYSTEM); + new_aps->size = size_words; + new_aps->fun = &stg_dummy_ret_closure; + + // fill in the payload of the AP_STACK + new_aps->payload[0] = (StgClosure *)&stg_apply_interp_info; + new_aps->payload[1] = (StgClosure *)obj; + + // copy the contents of the top stack frame into the AP_STACK + for (i = 2; i < size_words; i++) + { + new_aps->payload[i] = (StgClosure *)Sp[i-2]; + } + + // prepare the stack so that we can call the + // rts_breakpoint_io_action and ensure that the stack is + // in a reasonable state for the GC and so that + // execution of this BCO can continue when we resume + ioAction = (StgClosure *) deRefStablePtr (rts_breakpoint_io_action); + Sp -= 8; + Sp[7] = (W_)obj; + Sp[6] = (W_)&stg_apply_interp_info; + Sp[5] = (W_)new_aps; // the AP_STACK + Sp[4] = (W_)BCO_PTR(arg3_freeVars); // the info about local vars of the breakpoint + Sp[3] = (W_)False_closure; // True <=> a breakpoint + Sp[2] = (W_)&stg_ap_pppv_info; + Sp[1] = (W_)ioAction; // apply the IO action to its two arguments above + Sp[0] = (W_)&stg_enter_info; // get ready to run the IO action + + // set the flag in the TSO to say that we are now + // stopping at a breakpoint so that when we resume + // we don't stop on the same breakpoint that we + // already stopped at just now + cap->r.rCurrentTSO->flags |= TSO_STOPPED_ON_BREAKPOINT; + + // stop this thread and return to the scheduler - + // eventually we will come back and the IO action on + // the top of the stack will be executed + RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding); + } + } + // record that this thread is not stopped at a breakpoint anymore + cap->r.rCurrentTSO->flags &= ~TSO_STOPPED_ON_BREAKPOINT; + + // continue normal execution of the byte code instructions + goto nextInsn; + } case bci_STKCHECK: { // Explicit stack check at the beginning of a function // *only* (stack checks in case alternatives are // propagated to the enclosing function). - int stk_words_reqd = BCO_NEXT + 1; + StgWord stk_words_reqd = BCO_GET_LARGE_ARG + 1; if (Sp - stk_words_reqd < SpLim) { Sp -= 2; Sp[1] = (W_)obj; @@ -1002,12 +1122,12 @@ run_BCO: int i; int o_itbl = BCO_NEXT; int n_words = BCO_NEXT; - StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_ITBL(o_itbl)); + StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_LIT(o_itbl)); int request = CONSTR_sizeW( itbl->layout.payload.ptrs, itbl->layout.payload.nptrs ); StgClosure* con = (StgClosure*)allocate_NONUPD(request); ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0); - SET_HDR(con, BCO_ITBL(o_itbl), CCS_SYSTEM/*ToDo*/); + SET_HDR(con, (StgInfoTable*)BCO_LIT(o_itbl), CCS_SYSTEM/*ToDo*/); for (i = 0; i < n_words; i++) { con->payload[i] = (StgClosure*)Sp[i]; } @@ -1243,7 +1363,7 @@ run_BCO: bciPtr = nextpc; goto nextInsn; } - + case bci_CASEFAIL: barf("interpretBCO: hit a CASEFAIL");