break;
case CXt_EVAL:
POPEVAL(cx);
- LEAVE_SCOPE(cx->blk_eval.old_savestack_ix);
- PL_tmps_floor = cx->blk_eval.old_tmpsfloor;
+ LEAVE_SCOPE(cx->cx_u.cx_blk.blku_old_savestack_ix);
+ PL_tmps_floor = cx->cx_u.cx_blk.blku_old_tmpsfloor;
break;
case CXt_LOOP_LAZYIV:
case CXt_LOOP_LAZYSV:
case CXt_LOOP_PLAIN:
POPLOOP(cx);
break;
+ case CXt_WHEN:
+ POPWHEN(cx);
+ break;
+ case CXt_GIVEN:
+ POPGIVEN(cx);
+ break;
case CXt_NULL:
break;
case CXt_FORMAT:
*++newsp = &PL_sv_undef;
PL_stack_sp = newsp;
- LEAVE_SCOPE(cx->blk_eval.old_savestack_ix);
- PL_tmps_floor = cx->blk_eval.old_tmpsfloor;
+ LEAVE_SCOPE(cx->cx_u.cx_blk.blku_old_savestack_ix);
+ PL_tmps_floor = cx->cx_u.cx_blk.blku_old_tmpsfloor;
if (optype == OP_REQUIRE) {
assert (PL_curcop == oldcop);
PUSHBLOCK(cx, CXt_SUB, SP);
PUSHSUB_DB(cx);
cx->blk_sub.retop = PL_op->op_next;
- cx->blk_sub.old_savestack_ix = PL_savestack_ix;
+ cx->cx_u.cx_blk.blku_old_savestack_ix = PL_savestack_ix;
SAVEI32(PL_debug);
PL_debug = 0;
}
/* S_leave_common: Common code that many functions in this file use on
- scope exit. */
+ scope exit.
-/* SVs on the stack that have any of the flags passed in are left as is.
- Other SVs are protected via the mortals stack if lvalue is true, and
- copied otherwise.
+ Process the return args on the stack in the range (mark+1..sp) based on
+ context, with any final args starting at newsp+1. Returns the new
+ top-of-stack position
+ Args are mortal copied (or mortalied if lvalue) unless its safe to use
+ as-is, based on whether it has the specified flags. Note that most
+ callers specify flags as (SVs_PADTMP|SVs_TEMP), while leaveeval skips
+ SVs_PADTMP since its optree gets immediately freed, freeing its padtmps
+ at the same time.
Also, taintedness is cleared.
*/
S_leave_common(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme,
U32 flags, bool lvalue)
{
- bool padtmp = 0;
PERL_ARGS_ASSERT_LEAVE_COMMON;
TAINT_NOT;
- if (flags & SVs_PADTMP) {
- flags &= ~SVs_PADTMP;
- padtmp = 1;
- }
if (gimme == G_SCALAR) {
if (MARK < SP)
- *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
+ *++newsp = (SvFLAGS(*SP) & flags)
? *SP
: lvalue
? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
else if (gimme == G_ARRAY) {
/* in case LEAVE wipes old return values */
while (++MARK <= SP) {
- if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
+ if (SvFLAGS(*MARK) & flags)
*++newsp = *MARK;
else {
*++newsp = lvalue
dSP; dMARK;
PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
- void *itervar; /* location of the iteration variable */
+ void *itervarp; /* GV or pad slot of the iteration variable */
+ SV *itersave; /* the old var in the iterator var slot */
U8 cxtype = CXt_LOOP_FOR;
ENTER_with_name("loop1");
SAVETMPS;
if (PL_op->op_targ) { /* "my" variable */
+ itervarp = &PAD_SVl(PL_op->op_targ);
+ itersave = *(SV**)itervarp;
+ assert(itersave);
if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
- SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
- SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
- SVs_PADSTALE, SVs_PADSTALE);
+ /* the SV currently in the pad slot is never live during
+ * iteration (the slot is always aliased to one of the items)
+ * so it's always stale */
+ SvPADSTALE_on(itersave);
}
- SAVEPADSVANDMORTALIZE(PL_op->op_targ);
- itervar = &PAD_SVl(PL_op->op_targ);
- }
- else if (LIKELY(isGV(TOPs))) { /* symbol table variable */
- GV * const gv = MUTABLE_GV(POPs);
- SV** svp = &GvSV(gv);
- save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
- *svp = newSV(0);
- itervar = (void *)gv;
+ SvREFCNT_inc_simple_void_NN(itersave);
+ cxtype |= CXp_FOR_PAD;
}
else {
SV * const sv = POPs;
- assert(SvTYPE(sv) == SVt_PVMG);
- assert(SvMAGIC(sv));
- assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
- itervar = (void *)sv;
- cxtype |= CXp_FOR_LVREF;
+ itervarp = (void *)sv;
+ if (LIKELY(isGV(sv))) { /* symbol table variable */
+ SV** svp = &GvSV(sv);
+ itersave = *svp;
+ if (LIKELY(itersave))
+ SvREFCNT_inc_simple_void_NN(itersave);
+ else
+ *svp = newSV(0);
+ cxtype |= CXp_FOR_GV;
+ }
+ else { /* LV ref: for \$foo (...) */
+ assert(SvTYPE(sv) == SVt_PVMG);
+ assert(SvMAGIC(sv));
+ assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
+ itersave = NULL;
+ cxtype |= CXp_FOR_LVREF;
+ }
}
if (PL_op->op_private & OPpITER_DEF)
ENTER_with_name("loop2");
PUSHBLOCK(cx, cxtype, SP);
- PUSHLOOP_FOR(cx, itervar, MARK);
+ PUSHLOOP_FOR(cx, itervarp, itersave, MARK);
if (PL_op->op_flags & OPf_STACKED) {
SV *maybe_ary = POPs;
if (SvTYPE(maybe_ary) != SVt_PVAV) {
SP = (gimme == G_VOID)
? newsp
- : leave_common(newsp, SP, MARK, gimme, 0,
+ : leave_common(newsp, SP, MARK, gimme, SVs_PADTMP|SVs_TEMP,
PL_op->op_private & OPpLVALUE);
PUTBACK;
if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
SV *sv;
if (MARK <= SP) {
- assert(MARK == SP);
if ((SvPADTMP(TOPs) || SvREADONLY(TOPs)) &&
!SvSMAGICAL(TOPs)) {
what =
{
dSP; dMARK;
PERL_CONTEXT *cx;
- SV **oldsp;
const I32 cxix = dopoptosub(cxstack_ix);
assert(cxstack_ix >= 0);
if (cxix < cxstack_ix) {
if (cxix < 0) {
- if (CxMULTICALL(cxstack)) { /* In this case we must be in a
- * sort block, which is a CXt_NULL
- * not a CXt_SUB */
- dounwind(0);
- /* if we were in list context, we would have to splice out
- * any junk before the return args, like we do in the general
- * pp_return case, e.g.
- * sub f { for (junk1, junk2) { return arg1, arg2 }}
- */
+ if (!CxMULTICALL(cxstack))
+ DIE(aTHX_ "Can't return outside a subroutine");
+ /* We must be in a sort block, which is a CXt_NULL not a
+ * CXt_SUB. Handle specially. */
+ if (cxstack_ix > 0) {
+ /* See comment below about context popping. Since we know
+ * we're scalar and not lvalue, we can preserve the return
+ * value in a simpler fashion than there. */
+ SV *sv = *SP;
assert(cxstack[0].blk_gimme == G_SCALAR);
- return 0;
+ if ( (sp != PL_stack_base)
+ && !(SvFLAGS(sv) & (SVs_TEMP|SVs_PADTMP))
+ )
+ *SP = sv_mortalcopy(sv);
+ dounwind(0);
}
- else
- DIE(aTHX_ "Can't return outside a subroutine");
+ /* caller responsible for popping cxstack[0] */
+ return 0;
}
- dounwind(cxix);
- }
-
- cx = &cxstack[cxix];
- oldsp = PL_stack_base + cx->blk_oldsp;
- if (oldsp != MARK) {
- /* Handle extra junk on the stack. For example,
+ /* There are contexts that need popping. Doing this may free the
+ * return value(s), so preserve them first, e.g. popping the plain
+ * loop here would free $x:
+ * sub f { { my $x = 1; return $x } }
+ * We may also need to shift the args down; for example,
* for (1,2) { return 3,4 }
- * leaves 1,2,3,4 on the stack. In list context we
- * have to splice out the 1,2; In scalar context for
+ * leaves 1,2,3,4 on the stack. Both these actions can be done by
+ * leave_common(). By calling it with lvalue=TRUE, we just bump
+ * the ref count and mortalise the args that need it. The "scan
+ * the args and maybe copy them" process will be repeated by
+ * whoever we tail-call (e.g. pp_leaveeval), where any copying etc
+ * will be done. That is to say, in this code path two scans of
+ * the args will be done; the first just shifts and preserves; the
+ * second is the "real" arg processing, based on the type of
+ * return.
+ */
+ cx = &cxstack[cxix];
+ SP = leave_common(PL_stack_base + cx->blk_oldsp, SP, MARK,
+ cx->blk_gimme, SVs_TEMP|SVs_PADTMP, TRUE);
+ PUTBACK;
+ dounwind(cxix);
+ }
+ else {
+ /* Like in the branch above, we need to handle any extra junk on
+ * the stack. But because we're not also popping extra contexts, we
+ * don't have to worry about prematurely freeing args. So we just
+ * need to do the bare minimum to handle junk, and leave the main
+ * arg processing in the function we tail call, e.g. pp_leavesub.
+ * In list context we have to splice out the junk; in scalar
+ * context we can leave as-is (pp_leavesub will later return the
+ * top stack element). But for an empty arg list, e.g.
* for (1,2) { return }
- * we need to set sp = oldsp so that pp_leavesub knows
- * to push &PL_sv_undef onto the stack.
- * Note that in pp_return we only do the extra processing
- * required to handle junk; everything else we leave to
- * pp_leavesub.
+ * we need to set sp = oldsp so that pp_leavesub knows to push
+ * &PL_sv_undef onto the stack.
*/
- SSize_t nargs = SP - MARK;
- if (nargs) {
- if (cx->blk_gimme == G_ARRAY) {
- /* shift return args to base of call stack frame */
- Move(MARK + 1, oldsp + 1, nargs, SV*);
- PL_stack_sp = oldsp + nargs;
+ SV **oldsp;
+ cx = &cxstack[cxix];
+ oldsp = PL_stack_base + cx->blk_oldsp;
+ if (oldsp != MARK) {
+ SSize_t nargs = SP - MARK;
+ if (nargs) {
+ if (cx->blk_gimme == G_ARRAY) {
+ /* shift return args to base of call stack frame */
+ Move(MARK + 1, oldsp + 1, nargs, SV*);
+ PL_stack_sp = oldsp + nargs;
+ }
}
+ else
+ PL_stack_sp = oldsp;
}
- else
- PL_stack_sp = oldsp;
}
/* fall through to a normal exit */
TAINT_NOT;
PL_stack_sp = newsp;
- LEAVE;
+ LEAVE_with_name("loop2");
cxstack_ix--;
/* Stack values are safe: */
POPLOOP(cx); /* release loop vars ... */
- LEAVE;
+ LEAVE_with_name("loop1");
PL_curpm = newpm; /* ... and pop $1 et al */
PERL_UNUSED_VAR(gimme);
SvREFCNT_inc_NN(sv_2mortal(MUTABLE_SV(arg)));
assert(PL_scopestack_ix == cx->blk_oldscopesp);
- LEAVE_SCOPE(cx->blk_sub.old_savestack_ix);
+ LEAVE_SCOPE(cx->cx_u.cx_blk.blku_old_savestack_ix);
if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
AV* av = MUTABLE_AV(PAD_SVl(0));
POPEVAL(cx);
namesv = cx->blk_eval.old_namesv;
/* POPBLOCK has rendered LEAVE_with_name("evalcomp") unnecessary */
- LEAVE_SCOPE(cx->blk_eval.old_savestack_ix);
- PL_tmps_floor = cx->blk_eval.old_tmpsfloor;
+ LEAVE_SCOPE(cx->cx_u.cx_blk.blku_old_savestack_ix);
+ PL_tmps_floor = cx->cx_u.cx_blk.blku_old_tmpsfloor;
}
errsv = ERRSV;
/* switch to eval mode */
PUSHBLOCK(cx, CXt_EVAL, SP);
PUSHEVAL(cx, name);
- cx->blk_eval.old_savestack_ix = old_savestack_ix;
+ cx->cx_u.cx_blk.blku_old_savestack_ix = old_savestack_ix;
cx->blk_eval.retop = PL_op->op_next;
SAVECOPLINE(&PL_compiling);
PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
PUSHEVAL(cx, 0);
- cx->blk_eval.old_savestack_ix = old_savestack_ix;
+ cx->cx_u.cx_blk.blku_old_savestack_ix = old_savestack_ix;
cx->blk_eval.retop = PL_op->op_next;
/* prepare to compile string */
SvPVX_const(namesv),
SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
G_DISCARD);
- LEAVE_SCOPE(cx->blk_eval.old_savestack_ix);
- PL_tmps_floor = cx->blk_eval.old_tmpsfloor;
+ LEAVE_SCOPE(cx->cx_u.cx_blk.blku_old_savestack_ix);
+ PL_tmps_floor = cx->cx_u.cx_blk.blku_old_tmpsfloor;
Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
NOT_REACHED; /* NOTREACHED */
/* die_unwind() did LEAVE, or we won't be here */
}
else {
- LEAVE_SCOPE(cx->blk_eval.old_savestack_ix);
- PL_tmps_floor = cx->blk_eval.old_tmpsfloor;
+ LEAVE_SCOPE(cx->cx_u.cx_blk.blku_old_savestack_ix);
+ PL_tmps_floor = cx->cx_u.cx_blk.blku_old_tmpsfloor;
if (!keep)
CLEAR_ERRSV();
}
POPBLOCK(cx,newpm);
POPEVAL(cx);
PL_curpm = newpm;
- LEAVE_SCOPE(cx->blk_eval.old_savestack_ix);
- PL_tmps_floor = cx->blk_eval.old_tmpsfloor;
+ LEAVE_SCOPE(cx->cx_u.cx_blk.blku_old_savestack_ix);
+ PL_tmps_floor = cx->cx_u.cx_blk.blku_old_tmpsfloor;
PERL_UNUSED_VAR(newsp);
PERL_UNUSED_VAR(gimme);
PERL_UNUSED_VAR(optype);
PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
PUSHEVAL(cx, 0);
- cx->blk_eval.old_savestack_ix = PL_savestack_ix;
+ cx->cx_u.cx_blk.blku_old_savestack_ix = PL_savestack_ix;
PL_in_eval = EVAL_INEVAL;
if (flags & G_KEEPERR)
SVs_PADTMP|SVs_TEMP, FALSE);
PL_curpm = newpm; /* Don't pop $1 et al till now */
- LEAVE_SCOPE(cx->blk_eval.old_savestack_ix);
- PL_tmps_floor = cx->blk_eval.old_tmpsfloor;
+ LEAVE_SCOPE(cx->cx_u.cx_blk.blku_old_savestack_ix);
+ PL_tmps_floor = cx->cx_u.cx_blk.blku_old_tmpsfloor;
CLEAR_ERRSV();
RETURNOP(retop);
dSP;
PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
+ SV *origsv = DEFSV;
+ SV *newsv = POPs;
ENTER_with_name("given");
SAVETMPS;
assert(!PL_op->op_targ); /* used to be set for lexical $_ */
- SAVE_DEFSV;
- DEFSV_set(POPs);
+ GvSV(PL_defgv) = SvREFCNT_inc(newsv);
PUSHBLOCK(cx, CXt_GIVEN, SP);
- PUSHGIVEN(cx);
+ PUSHGIVEN(cx, origsv);
RETURN;
}
PERL_UNUSED_CONTEXT;
POPBLOCK(cx,newpm);
+ POPGIVEN(cx);
assert(CxTYPE(cx) == CXt_GIVEN);
SP = (gimme == G_VOID)
POPBLOCK(cx,newpm);
assert(CxTYPE(cx) == CXt_WHEN);
+ POPWHEN(cx);
SP = (gimme == G_VOID)
? newsp
https://perl5.git.perl.org / perl5.git / blobdiff