X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=rts%2FInterpreter.c;h=da7ee2196aace39fc16e7335575ded68e69e6ce8;hp=1b2d7303edf2d3285910cdf47248ec8a9ddad4b8;hb=83d563cb9ede0ba792836e529b1e2929db926355;hpb=164be7854f6de07bb4bc15f60af727ddb562cde7 diff --git a/rts/Interpreter.c b/rts/Interpreter.c index 1b2d730..da7ee21 100644 --- a/rts/Interpreter.c +++ b/rts/Interpreter.c @@ -7,27 +7,34 @@ #include "PosixSource.h" #include "Rts.h" #include "RtsAPI.h" +#include "rts/Bytecodes.h" + +// internal headers +#include "sm/Storage.h" +#include "sm/Sanity.h" #include "RtsUtils.h" -#include "Closures.h" -#include "TSO.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 "Stable.h" #include "Printer.h" #include "Disassembler.h" #include "Interpreter.h" +#include "ThreadPaused.h" +#include "Threads.h" #include /* for memcpy */ #ifdef HAVE_ERRNO_H #include #endif +// When building the RTS in the non-dyn way on Windows, we don't +// want declspec(__dllimport__) on the front of function prototypes +// from libffi. +#if defined(mingw32_HOST_OS) && !defined(__PIC__) +# define LIBFFI_NOT_DLL +#endif + #include "ffi.h" /* -------------------------------------------------------------------------- @@ -81,9 +88,9 @@ STATIC_INLINE StgPtr -allocate_NONUPD (int n_words) +allocate_NONUPD (Capability *cap, int n_words) { - return allocate(stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words)); + return allocate(cap, stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words)); } int rts_stop_next_breakpoint = 0; @@ -196,6 +203,9 @@ interpretBCO (Capability* cap) LOAD_STACK_POINTERS; + cap->r.rHpLim = (P_)1; // HpLim is the context-switch flag; when it + // goes to zero we must return to the scheduler. + // ------------------------------------------------------------------------ // Case 1: // @@ -260,14 +270,13 @@ eval_obj: debugBelch("\n\n"); ); - IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size)); +// IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size)); + IF_DEBUG(sanity,checkStackFrame(Sp)); switch ( get_itbl(obj)->type ) { case IND: - case IND_OLDGEN: case IND_PERM: - case IND_OLDGEN_PERM: case IND_STATIC: { tagged_obj = ((StgInd*)obj)->indirectee; @@ -433,7 +442,8 @@ do_return: // to a PAP by the GC, violating the invariant that PAPs // always contain a tagged pointer to the function. INTERP_TICK(it_retto_UPDATE); - UPD_IND(((StgUpdateFrame *)Sp)->updatee, tagged_obj); + updateThunk(cap, cap->r.rCurrentTSO, + ((StgUpdateFrame *)Sp)->updatee, tagged_obj); Sp += sizeofW(StgUpdateFrame); goto do_return; @@ -595,7 +605,7 @@ do_apply: else /* arity > n */ { // build a new PAP and return it. StgPAP *new_pap; - new_pap = (StgPAP *)allocate(PAP_sizeW(pap->n_args + m)); + new_pap = (StgPAP *)allocate(cap, PAP_sizeW(pap->n_args + m)); SET_HDR(new_pap,&stg_PAP_info,CCCS); new_pap->arity = pap->arity - n; new_pap->n_args = pap->n_args + m; @@ -640,7 +650,7 @@ do_apply: // build a PAP and return it. StgPAP *pap; nat i; - pap = (StgPAP *)allocate(PAP_sizeW(m)); + pap = (StgPAP *)allocate(cap, PAP_sizeW(m)); SET_HDR(pap, &stg_PAP_info,CCCS); pap->arity = arity - n; pap->fun = obj; @@ -709,7 +719,7 @@ do_apply: run_BCO_return: // Heap check - if (doYouWantToGC()) { + if (doYouWantToGC(cap)) { Sp--; Sp[0] = (W_)&stg_enter_info; RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow); } @@ -720,7 +730,7 @@ run_BCO_return: run_BCO_return_unboxed: // Heap check - if (doYouWantToGC()) { + if (doYouWantToGC(cap)) { RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow); } // Stack checks aren't necessary at return points, the stack use @@ -738,7 +748,7 @@ run_BCO_fun: ); // Heap check - if (doYouWantToGC()) { + if (doYouWantToGC(cap)) { Sp -= 2; Sp[1] = (W_)obj; Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really @@ -760,19 +770,22 @@ run_BCO_fun: run_BCO: INTERP_TICK(it_BCO_entries); { - register int bciPtr = 1; /* instruction pointer */ + register int bciPtr = 0; /* 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]); + int bcoSize; + bcoSize = BCO_NEXT_WORD; + IF_DEBUG(interpreter,debugBelch("bcoSize = %d\n", bcoSize)); #ifdef INTERP_STATS it_lastopc = 0; /* no opcode */ #endif nextInsn: - ASSERT(bciPtr <= instrs[0]); + ASSERT(bciPtr < bcoSize); IF_DEBUG(interpreter, //if (do_print_stack) { //debugBelch("\n-- BEGIN stack\n"); @@ -851,7 +864,7 @@ run_BCO: // 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)); + new_aps = (StgAP_STACK *) allocate(cap, 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; @@ -871,21 +884,15 @@ run_BCO: // 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 -= 9; - Sp[8] = (W_)obj; - Sp[7] = (W_)&stg_apply_interp_info; - Sp[6] = (W_)&stg_noforceIO_info; // see [unreg] below + 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 - // Note [unreg]: in unregisterised mode, the return - // convention for IO is different. The - // stg_noForceIO_info stack frame is necessary to - // account for this difference. - // 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 @@ -1070,7 +1077,7 @@ run_BCO: case bci_ALLOC_AP: { StgAP* ap; int n_payload = BCO_NEXT; - ap = (StgAP*)allocate(AP_sizeW(n_payload)); + ap = (StgAP*)allocate(cap, AP_sizeW(n_payload)); Sp[-1] = (W_)ap; ap->n_args = n_payload; SET_HDR(ap, &stg_AP_info, CCS_SYSTEM/*ToDo*/) @@ -1081,7 +1088,7 @@ run_BCO: case bci_ALLOC_AP_NOUPD: { StgAP* ap; int n_payload = BCO_NEXT; - ap = (StgAP*)allocate(AP_sizeW(n_payload)); + ap = (StgAP*)allocate(cap, AP_sizeW(n_payload)); Sp[-1] = (W_)ap; ap->n_args = n_payload; SET_HDR(ap, &stg_AP_NOUPD_info, CCS_SYSTEM/*ToDo*/) @@ -1093,7 +1100,7 @@ run_BCO: StgPAP* pap; int arity = BCO_NEXT; int n_payload = BCO_NEXT; - pap = (StgPAP*)allocate(PAP_sizeW(n_payload)); + pap = (StgPAP*)allocate(cap, PAP_sizeW(n_payload)); Sp[-1] = (W_)pap; pap->n_args = n_payload; pap->arity = arity; @@ -1165,7 +1172,7 @@ run_BCO: 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); + StgClosure* con = (StgClosure*)allocate_NONUPD(cap,request); ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0); SET_HDR(con, (StgInfoTable*)BCO_LIT(o_itbl), CCS_SYSTEM/*ToDo*/); for (i = 0; i < n_words; i++) { @@ -1183,7 +1190,7 @@ run_BCO: case bci_TESTLT_P: { unsigned int discr = BCO_NEXT; - int failto = BCO_NEXT; + int failto = BCO_GET_LARGE_ARG; StgClosure* con = (StgClosure*)Sp[0]; if (GET_TAG(con) >= discr) { bciPtr = failto; @@ -1193,7 +1200,7 @@ run_BCO: case bci_TESTEQ_P: { unsigned int discr = BCO_NEXT; - int failto = BCO_NEXT; + int failto = BCO_GET_LARGE_ARG; StgClosure* con = (StgClosure*)Sp[0]; if (GET_TAG(con) != discr) { bciPtr = failto; @@ -1204,7 +1211,7 @@ run_BCO: case bci_TESTLT_I: { // There should be an Int at Sp[1], and an info table at Sp[0]. int discr = BCO_NEXT; - int failto = BCO_NEXT; + int failto = BCO_GET_LARGE_ARG; I_ stackInt = (I_)Sp[1]; if (stackInt >= (I_)BCO_LIT(discr)) bciPtr = failto; @@ -1214,7 +1221,7 @@ run_BCO: case bci_TESTEQ_I: { // There should be an Int at Sp[1], and an info table at Sp[0]. int discr = BCO_NEXT; - int failto = BCO_NEXT; + int failto = BCO_GET_LARGE_ARG; I_ stackInt = (I_)Sp[1]; if (stackInt != (I_)BCO_LIT(discr)) { bciPtr = failto; @@ -1222,10 +1229,31 @@ run_BCO: goto nextInsn; } + case bci_TESTLT_W: { + // There should be an Int at Sp[1], and an info table at Sp[0]. + int discr = BCO_NEXT; + int failto = BCO_GET_LARGE_ARG; + W_ stackWord = (W_)Sp[1]; + if (stackWord >= (W_)BCO_LIT(discr)) + bciPtr = failto; + goto nextInsn; + } + + case bci_TESTEQ_W: { + // There should be an Int at Sp[1], and an info table at Sp[0]. + int discr = BCO_NEXT; + int failto = BCO_GET_LARGE_ARG; + W_ stackWord = (W_)Sp[1]; + if (stackWord != (W_)BCO_LIT(discr)) { + bciPtr = failto; + } + goto nextInsn; + } + case bci_TESTLT_D: { // There should be a Double at Sp[1], and an info table at Sp[0]. int discr = BCO_NEXT; - int failto = BCO_NEXT; + int failto = BCO_GET_LARGE_ARG; StgDouble stackDbl, discrDbl; stackDbl = PK_DBL( & Sp[1] ); discrDbl = PK_DBL( & BCO_LIT(discr) ); @@ -1238,7 +1266,7 @@ run_BCO: case bci_TESTEQ_D: { // There should be a Double at Sp[1], and an info table at Sp[0]. int discr = BCO_NEXT; - int failto = BCO_NEXT; + int failto = BCO_GET_LARGE_ARG; StgDouble stackDbl, discrDbl; stackDbl = PK_DBL( & Sp[1] ); discrDbl = PK_DBL( & BCO_LIT(discr) ); @@ -1251,7 +1279,7 @@ run_BCO: case bci_TESTLT_F: { // There should be a Float at Sp[1], and an info table at Sp[0]. int discr = BCO_NEXT; - int failto = BCO_NEXT; + int failto = BCO_GET_LARGE_ARG; StgFloat stackFlt, discrFlt; stackFlt = PK_FLT( & Sp[1] ); discrFlt = PK_FLT( & BCO_LIT(discr) ); @@ -1264,7 +1292,7 @@ run_BCO: case bci_TESTEQ_F: { // There should be a Float at Sp[1], and an info table at Sp[0]. int discr = BCO_NEXT; - int failto = BCO_NEXT; + int failto = BCO_GET_LARGE_ARG; StgFloat stackFlt, discrFlt; stackFlt = PK_FLT( & Sp[1] ); discrFlt = PK_FLT( & BCO_LIT(discr) ); @@ -1281,7 +1309,7 @@ run_BCO: // context switching: sometimes the scheduler can invoke // the interpreter with context_switch == 1, particularly // if the -C0 flag has been given on the cmd line. - if (cap->context_switch) { + if (cap->r.rHpLim == NULL) { Sp--; Sp[0] = (W_)&stg_enter_info; RETURN_TO_SCHEDULER(ThreadInterpret, ThreadYielding); } @@ -1328,6 +1356,7 @@ run_BCO: void *tok; int stk_offset = BCO_NEXT; int o_itbl = BCO_NEXT; + int interruptible = BCO_NEXT; void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl); int ret_dyn_size = RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE @@ -1416,13 +1445,13 @@ run_BCO: ((StgRetDyn *)Sp)->payload[0] = (StgClosure *)obj; SAVE_STACK_POINTERS; - tok = suspendThread(&cap->r); + tok = suspendThread(&cap->r, interruptible ? rtsTrue : rtsFalse); // We already made a copy of the arguments above. ffi_call(cif, fn, ret, argptrs); // And restart the thread again, popping the RET_DYN frame. - cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - FIELD_OFFSET(Capability,r))); + cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - STG_FIELD_OFFSET(Capability,r))); LOAD_STACK_POINTERS; // Re-load the pointer to the BCO from the RET_DYN frame, @@ -1448,7 +1477,7 @@ run_BCO: case bci_JMP: { /* BCO_NEXT modifies bciPtr, so be conservative. */ - int nextpc = BCO_NEXT; + int nextpc = BCO_GET_LARGE_ARG; bciPtr = nextpc; goto nextInsn; }