X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=rts%2FInterpreter.c;h=da7ee2196aace39fc16e7335575ded68e69e6ce8;hp=9c494c1f29666b40f24ab4920097f82c554af4d8;hb=83d563cb9ede0ba792836e529b1e2929db926355;hpb=e0939bc459e2fd5420f875ee3065dca14114bf31 diff --git a/rts/Interpreter.c b/rts/Interpreter.c index 9c494c1..da7ee21 100644 --- a/rts/Interpreter.c +++ b/rts/Interpreter.c @@ -11,22 +11,30 @@ // internal headers #include "sm/Storage.h" +#include "sm/Sanity.h" #include "RtsUtils.h" #include "Schedule.h" #include "Updates.h" -#include "Sanity.h" #include "Prelude.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" /* -------------------------------------------------------------------------- @@ -82,7 +90,7 @@ STATIC_INLINE StgPtr allocate_NONUPD (Capability *cap, int n_words) { - return allocateLocal(cap, 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; @@ -262,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; @@ -435,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; @@ -597,7 +605,7 @@ do_apply: else /* arity > n */ { // build a new PAP and return it. StgPAP *new_pap; - new_pap = (StgPAP *)allocateLocal(cap, 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; @@ -642,7 +650,7 @@ do_apply: // build a PAP and return it. StgPAP *pap; nat i; - pap = (StgPAP *)allocateLocal(cap, PAP_sizeW(m)); + pap = (StgPAP *)allocate(cap, PAP_sizeW(m)); SET_HDR(pap, &stg_PAP_info,CCCS); pap->arity = arity - n; pap->fun = obj; @@ -711,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); } @@ -722,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 @@ -740,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 @@ -856,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 *) allocateLocal(cap, 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; @@ -876,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 @@ -1075,7 +1077,7 @@ run_BCO: case bci_ALLOC_AP: { StgAP* ap; int n_payload = BCO_NEXT; - ap = (StgAP*)allocateLocal(cap, 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*/) @@ -1086,7 +1088,7 @@ run_BCO: case bci_ALLOC_AP_NOUPD: { StgAP* ap; int n_payload = BCO_NEXT; - ap = (StgAP*)allocateLocal(cap, 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*/) @@ -1098,7 +1100,7 @@ run_BCO: StgPAP* pap; int arity = BCO_NEXT; int n_payload = BCO_NEXT; - pap = (StgPAP*)allocateLocal(cap, PAP_sizeW(n_payload)); + pap = (StgPAP*)allocate(cap, PAP_sizeW(n_payload)); Sp[-1] = (W_)pap; pap->n_args = n_payload; pap->arity = arity; @@ -1227,6 +1229,27 @@ 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; @@ -1333,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 @@ -1421,7 +1445,7 @@ 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);