X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Frts%2FInterpreter.c;h=cc18059f22828c17f3d6b5d1062d9835e713a96d;hb=410a99e4d59c22940db2adf59fb912435b71d24b;hp=89a5e5928d2a42b8ebaaece3fcf4881c9deb3363;hpb=9ae23eaef2e0e2631202d9d1590db7ba40c45df2;p=ghc-hetmet.git diff --git a/ghc/rts/Interpreter.c b/ghc/rts/Interpreter.c index 89a5e59..cc18059 100644 --- a/ghc/rts/Interpreter.c +++ b/ghc/rts/Interpreter.c @@ -26,6 +26,11 @@ #include "Disassembler.h" #include "Interpreter.h" +#include /* for memcpy */ +#ifdef HAVE_ERRNO_H +#include +#endif + /* -------------------------------------------------------------------------- * The bytecode interpreter @@ -58,13 +63,13 @@ return (retcode); -static inline StgPtr +STATIC_INLINE StgPtr allocate_UPD (int n_words) { return allocate(stg_max(sizeofW(StgHeader)+MIN_UPD_SIZE, n_words)); } -static inline StgPtr +STATIC_INLINE StgPtr allocate_NONUPD (int n_words) { return allocate(stg_max(sizeofW(StgHeader)+MIN_NONUPD_SIZE, n_words)); @@ -274,7 +279,7 @@ eval_obj: break; case BCO: - ASSERT(BCO_ARITY(obj) > 0); + ASSERT(((StgBCO *)obj)->arity > 0); break; case AP: /* Copied from stg_AP_entry. */ @@ -576,7 +581,7 @@ do_apply: nat arity, i; Sp++; - arity = BCO_ARITY(obj); + arity = ((StgBCO *)obj)->arity; ASSERT(arity > 0); if (arity < n) { // n must be greater than 1, and the only kinds of @@ -672,12 +677,8 @@ run_BCO_return: Sp--; Sp[0] = (W_)&stg_enter_info; RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow); } - - // "Standard" stack check - if (Sp - (INTERP_STACK_CHECK_THRESH+1) < SpLim) { - Sp--; Sp[0] = (W_)&stg_enter_info; - RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow); - } + // 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: @@ -685,11 +686,8 @@ run_BCO_return_unboxed: if (doYouWantToGC()) { RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow); } - - // "Standard" stack check - if (Sp - (INTERP_STACK_CHECK_THRESH+1) < SpLim) { - RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow); - } + // 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: @@ -709,8 +707,8 @@ run_BCO_fun: RETURN_TO_SCHEDULER(ThreadInterpret, HeapOverflow); } - // "Standard" stack check - if (Sp - (INTERP_STACK_CHECK_THRESH+1) < SpLim) { + // Stack check + if (Sp - INTERP_STACK_CHECK_THRESH < SpLim) { Sp -= 2; Sp[1] = (W_)obj; Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really @@ -725,7 +723,7 @@ run_BCO: { register int bciPtr = 1; /* instruction pointer */ register StgBCO* bco = (StgBCO*)obj; - register StgWord16* instrs = (StgWord16*)(BCO_INSTRS(bco)); + 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**) @@ -766,15 +764,19 @@ run_BCO: switch (BCO_NEXT) { - case bci_STKCHECK: - { - // An explicit stack check; we hope these will be rare. + 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; if (Sp - stk_words_reqd < SpLim) { - Sp--; Sp[0] = (W_)obj; + Sp -= 2; + Sp[1] = (W_)obj; + Sp[0] = (W_)&stg_apply_interp_info; RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow); + } else { + goto nextInsn; } - goto nextInsn; } case bci_PUSH_L: { @@ -929,7 +931,7 @@ run_BCO: case bci_ALLOC_AP: { StgAP* ap; - int n_payload = BCO_NEXT - 1; + int n_payload = BCO_NEXT; int request = PAP_sizeW(n_payload); ap = (StgAP*)allocate_UPD(request); Sp[-1] = (W_)ap; @@ -942,7 +944,7 @@ run_BCO: case bci_ALLOC_PAP: { StgPAP* pap; int arity = BCO_NEXT; - int n_payload = BCO_NEXT - 1; + int n_payload = BCO_NEXT; int request = PAP_sizeW(n_payload); pap = (StgPAP*)allocate_NONUPD(request); Sp[-1] = (W_)pap; @@ -956,7 +958,7 @@ run_BCO: case bci_MKAP: { int i; int stkoff = BCO_NEXT; - int n_payload = BCO_NEXT - 1; + int n_payload = BCO_NEXT; StgAP* ap = (StgAP*)Sp[stkoff]; ASSERT((int)ap->n_args == n_payload); ap->fun = (StgClosure*)Sp[0]; @@ -1160,6 +1162,23 @@ run_BCO: int stk_offset = BCO_NEXT; int o_itbl = 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 + + sizeofW(StgRetDyn); + +#ifdef RTS_SUPPORTS_THREADS + // Threaded RTS: + // Arguments on the TSO stack are not good, because garbage + // collection might move the TSO as soon as we call + // suspendThread below. + + W_ arguments[stk_offset]; + + memcpy(arguments, Sp, sizeof(W_) * stk_offset); +#endif + + // Restore the Haskell thread's current value of errno + errno = cap->r.rCurrentTSO->saved_errno; // There are a bunch of non-ptr words on the stack (the // ccall args, the ccall fun address and space for the @@ -1171,23 +1190,43 @@ run_BCO: // CCALL instruction. So we build a RET_DYN stack frame // on the stack frame to describe this chunk of stack. // - Sp -= RET_DYN_SIZE + sizeofW(StgRetDyn); + Sp -= ret_dyn_size; ((StgRetDyn *)Sp)->liveness = ALL_NON_PTRS | N_NONPTRS(stk_offset); ((StgRetDyn *)Sp)->info = (StgInfoTable *)&stg_gc_gen_info; SAVE_STACK_POINTERS; tok = suspendThread(&cap->r,rtsFalse); - // Careful: suspendThread might have shifted the stack +#ifndef RTS_SUPPORTS_THREADS + // Careful: + // suspendThread might have shifted the stack // around (stack squeezing), so we have to grab the real - // Sp out of the TSO to find the ccall args again: - marshall_fn ( (void*)(cap->r.rCurrentTSO->sp + RET_DYN_SIZE - + sizeofW(StgRetDyn)) ); + // Sp out of the TSO to find the ccall args again. + + marshall_fn ( (void*)(cap->r.rCurrentTSO->sp + ret_dyn_size) ); +#else + // Threaded RTS: + // We already made a copy of the arguments above. + + marshall_fn ( arguments ); +#endif // And restart the thread again, popping the RET_DYN frame. - cap = (Capability *)((void *)resumeThread(tok,rtsFalse) - sizeof(StgFunTable)); + cap = (Capability *)((void *)((unsigned char*)resumeThread(tok,rtsFalse) - sizeof(StgFunTable))); LOAD_STACK_POINTERS; - Sp += RET_DYN_SIZE + sizeofW(StgRetDyn); + Sp += ret_dyn_size; + + // Save the Haskell thread's current value of errno + cap->r.rCurrentTSO->saved_errno = errno; + +#ifdef RTS_SUPPORTS_THREADS + // Threaded RTS: + // Copy the "arguments", which might include a return value, + // back to the TSO stack. It would of course be enough to + // just copy the return value, but we don't know the offset. + memcpy(Sp, arguments, sizeof(W_) * stk_offset); +#endif + goto nextInsn; }