X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=rts%2FInterpreter.c;h=9a38a7ed189e0bb4579d9fbdd8479119b6539995;hb=41bfdf710742595e6043d9b851e8dab30ffe6d2f;hp=d047876d21d2c12fc198686fe384a688b183ce4c;hpb=a2a67cd520b9841114d69a87a423dabcb3b4368e;p=ghc-hetmet.git diff --git a/rts/Interpreter.c b/rts/Interpreter.c index d047876..9a38a7e 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" /* -------------------------------------------------------------------------- @@ -80,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; @@ -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 *)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; @@ -642,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; @@ -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 *) 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; @@ -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*)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*/) @@ -1086,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*/) @@ -1098,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; @@ -1170,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++) { @@ -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;