// 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;
// 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(obj);
+ obj = UNTAG_CLOSURE(tagged_obj);
INTERP_TICK(it_total_evals);
IF_DEBUG(interpreter,
case IND_OLDGEN_PERM:
case IND_STATIC:
{
- obj = ((StgInd*)obj)->indirectee;
+ tagged_obj = ((StgInd*)obj)->indirectee;
goto 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);
}
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,
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;
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;
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);
}
// 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.
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;
}
for (i = 0; i < m; i++) {
pap->payload[i] = (StgClosure *)Sp[i];
}
- obj = (StgClosure *)pap;
+ tagged_obj = (StgClosure *)pap;
Sp += m;
goto do_return;
}
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);
}
// 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
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;
goto eval;
case bci_RETURN:
- obj = (StgClosure *)Sp[0];
+ tagged_obj = (StgClosure *)Sp[0];
Sp++;
goto do_return;
// 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);
// 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
// Errors
default:
barf("interpretBCO: unknown or unimplemented opcode %d",
- (int)BCO_NEXT);
+ (int)(bci & 0xFF));
} /* switch on opcode */
}
projects / ghc-hetmet.git / blobdiff