X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=rts%2FInterpreter.c;h=0ca8ddf62378ecfb2ea4b442d5b624a50ffbf43f;hb=dfb079f3b16fb179e083d83280c56aa1ce5821a9;hp=66634459959e4edaa8d4f58d0422aa97e02f7714;hpb=17f848e12faf8cf51aa58918522b6abe1e75dc51;p=ghc-hetmet.git diff --git a/rts/Interpreter.c b/rts/Interpreter.c index 6663445..0ca8ddf 100644 --- a/rts/Interpreter.c +++ b/rts/Interpreter.c @@ -189,7 +189,7 @@ interpretBCO (Capability* cap) // that these entities are non-aliasable. register StgPtr Sp; // local state -- stack pointer register StgPtr SpLim; // local state -- stack lim pointer - register StgClosure* obj; + register StgClosure *tagged_obj = 0, *obj; nat n, m; LOAD_STACK_POINTERS; @@ -224,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; } @@ -241,9 +241,10 @@ interpretBCO (Capability* cap) // Evaluate the object on top of the stack. eval: - obj = (StgClosure*)Sp[0]; Sp++; + tagged_obj = (StgClosure*)Sp[0]; Sp++; eval_obj: + obj = UNTAG_CLOSURE(tagged_obj); INTERP_TICK(it_total_evals); IF_DEBUG(interpreter, @@ -267,7 +268,7 @@ eval_obj: case IND_OLDGEN_PERM: case IND_STATIC: { - obj = ((StgInd*)obj)->indirectee; + tagged_obj = ((StgInd*)obj)->indirectee; goto eval_obj; } @@ -307,7 +308,7 @@ eval_obj: // Stack check if (Sp - (words+sizeofW(StgUpdateFrame)) < SpLim) { Sp -= 2; - Sp[1] = (W_)obj; + Sp[1] = (W_)tagged_obj; Sp[0] = (W_)&stg_enter_info; RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow); } @@ -327,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; } @@ -350,16 +351,17 @@ eval_obj: printObj(obj); ); Sp -= 2; - Sp[1] = (W_)obj; + Sp[1] = (W_)tagged_obj; Sp[0] = (W_)&stg_enter_info; RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding); } } // ------------------------------------------------------------------------ - // We now have an evaluated object (obj). The next thing to + // We now have an evaluated object (tagged_obj). The next thing to // do is return it to the stack frame on top of the stack. do_return: + obj = UNTAG_CLOSURE(tagged_obj); ASSERT(closure_HNF(obj)); IF_DEBUG(interpreter, @@ -420,8 +422,16 @@ do_return: case UPDATE_FRAME: // Returning to an update frame: do the update, pop the update // frame, and continue with the next stack frame. + // + // NB. we must update with the *tagged* pointer. Some tags + // are not optional, and if we omit the tag bits when updating + // then bad things can happen (albeit very rarely). See #1925. + // What happened was an indirection was created with an + // untagged pointer, and this untagged pointer was propagated + // 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, obj); + UPD_IND(((StgUpdateFrame *)Sp)->updatee, tagged_obj); Sp += sizeofW(StgUpdateFrame); goto do_return; @@ -431,6 +441,8 @@ do_return: INTERP_TICK(it_retto_BCO); Sp--; Sp[0] = (W_)obj; + // NB. return the untagged object; the bytecode expects it to + // be untagged. XXX this doesn't seem right. obj = (StgClosure*)Sp[2]; ASSERT(get_itbl(obj)->type == BCO); goto run_BCO_return; @@ -445,7 +457,7 @@ do_return: printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size); ); Sp -= 2; - Sp[1] = (W_)obj; + Sp[1] = (W_)tagged_obj; Sp[0] = (W_)&stg_enter_info; RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding); } @@ -518,6 +530,7 @@ do_return_unboxed: // Application... do_apply: + ASSERT(obj == UNTAG_CLOSURE(tagged_obj)); // we have a function to apply (obj), and n arguments taking up m // words on the stack. The info table (stg_ap_pp_info or whatever) // is on top of the arguments on the stack. @@ -531,7 +544,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; } @@ -556,7 +569,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) { @@ -564,7 +577,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 */ { @@ -581,7 +594,7 @@ do_apply: for (i = 0; i < m; i++) { new_pap->payload[pap->n_args + i] = (StgClosure *)Sp[i]; } - obj = (StgClosure *)new_pap; + tagged_obj = (StgClosure *)new_pap; Sp += m; goto do_return; } @@ -623,7 +636,7 @@ do_apply: for (i = 0; i < m; i++) { pap->payload[i] = (StgClosure *)Sp[i]; } - obj = (StgClosure *)pap; + tagged_obj = (StgClosure *)pap; Sp += m; goto do_return; } @@ -633,7 +646,7 @@ do_apply: default: defer_apply_to_sched: Sp -= 2; - Sp[1] = (W_)obj; + Sp[1] = (W_)tagged_obj; Sp[0] = (W_)&stg_enter_info; RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding); } @@ -846,15 +859,20 @@ 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 -= 8; - Sp[7] = (W_)obj; - Sp[6] = (W_)&stg_apply_interp_info; + Sp -= 9; + Sp[8] = (W_)obj; + Sp[7] = (W_)&stg_apply_interp_info; + Sp[6] = (W_)&stg_noforceIO_info; // see [unreg] below 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 @@ -1048,6 +1066,17 @@ run_BCO: goto nextInsn; } + case bci_ALLOC_AP_NOUPD: { + StgAP* ap; + int n_payload = BCO_NEXT; + ap = (StgAP*)allocate(AP_sizeW(n_payload)); + Sp[-1] = (W_)ap; + ap->n_args = n_payload; + SET_HDR(ap, &stg_AP_NOUPD_info, CCS_SYSTEM/*ToDo*/) + Sp --; + goto nextInsn; + } + case bci_ALLOC_PAP: { StgPAP* pap; int arity = BCO_NEXT; @@ -1247,7 +1276,7 @@ run_BCO: goto eval; case bci_RETURN: - obj = (StgClosure *)Sp[0]; + tagged_obj = (StgClosure *)Sp[0]; Sp++; goto do_return; @@ -1317,9 +1346,14 @@ run_BCO: // on the stack frame to describe this chunk of stack. // Sp -= ret_dyn_size; - ((StgRetDyn *)Sp)->liveness = NO_PTRS | N_NONPTRS(stk_offset); + ((StgRetDyn *)Sp)->liveness = R1_PTR | N_NONPTRS(stk_offset); ((StgRetDyn *)Sp)->info = (StgInfoTable *)&stg_gc_gen_info; + // save obj (pointer to the current BCO), since this + // might move during the call. We use the R1 slot in the + // RET_DYN frame for this, hence R1_PTR above. + ((StgRetDyn *)Sp)->payload[0] = (StgClosure *)obj; + SAVE_STACK_POINTERS; tok = suspendThread(&cap->r); @@ -1340,6 +1374,16 @@ run_BCO: // And restart the thread again, popping the RET_DYN frame. cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - sizeof(StgFunTable))); LOAD_STACK_POINTERS; + + // Re-load the pointer to the BCO from the RET_DYN frame, + // it might have moved during the call. Also reload the + // pointers to the components of the BCO. + obj = ((StgRetDyn *)Sp)->payload[0]; + bco = (StgBCO*)obj; + instrs = (StgWord16*)(bco->instrs->payload); + literals = (StgWord*)(&bco->literals->payload[0]); + ptrs = (StgPtr*)(&bco->ptrs->payload[0]); + Sp += ret_dyn_size; // Save the Haskell thread's current value of errno @@ -1369,7 +1413,7 @@ run_BCO: // Errors default: barf("interpretBCO: unknown or unimplemented opcode %d", - (int)BCO_NEXT); + (int)(bci & 0xFF)); } /* switch on opcode */ }