}
- if (TAINTING_get && TAINT_get) {
+ assert(TAINTING_get || !TAINT_get);
+ if (TAINT_get) {
SvTAINTED_on((SV*)new_re);
RX_TAINT_on(new_re);
}
dSP;
SV *src;
- if (PL_stack_base + *PL_markstack_ptr == SP) {
+ if (PL_stack_base + TOPMARK == SP) {
(void)POPMARK;
if (GIMME_V == G_SCALAR)
mXPUSHi(0);
RETURNOP(PL_op->op_next->op_next);
}
- PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
+ PL_stack_sp = PL_stack_base + TOPMARK + 1;
Perl_pp_pushmark(aTHX); /* push dst */
Perl_pp_pushmark(aTHX); /* push src */
ENTER_with_name("grep"); /* enter outer scope */
SAVETMPS;
- if (PL_op->op_private & OPpGREP_LEX)
- SAVESPTR(PAD_SVl(PL_op->op_targ));
- else
- SAVE_DEFSV;
+ SAVE_DEFSV;
ENTER_with_name("grep_item"); /* enter inner scope */
SAVEVPTR(PL_curpm);
- src = PL_stack_base[*PL_markstack_ptr];
+ src = PL_stack_base[TOPMARK];
if (SvPADTMP(src)) {
- src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
+ src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
PL_tmps_floor++;
}
SvTEMP_off(src);
- if (PL_op->op_private & OPpGREP_LEX)
- PAD_SVl(PL_op->op_targ) = src;
- else
- DEFSV_set(src);
+ DEFSV_set(src);
PUTBACK;
if (PL_op->op_type == OP_MAPSTART)
{
dSP;
const I32 gimme = GIMME_V;
- I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
+ I32 items = (SP - PL_stack_base) - TOPMARK; /* how many new items */
I32 count;
I32 shift;
SV** src;
LEAVE_with_name("grep_item"); /* exit inner scope */
/* All done yet? */
- if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
+ if (PL_markstack_ptr[-1] > TOPMARK) {
(void)POPMARK; /* pop top */
LEAVE_with_name("grep"); /* exit outer scope */
(void)POPMARK; /* pop dst */
SP = PL_stack_base + POPMARK; /* pop original mark */
if (gimme == G_SCALAR) {
- if (PL_op->op_private & OPpGREP_LEX) {
- SV* sv = sv_newmortal();
- sv_setiv(sv, items);
- PUSHs(sv);
- }
- else {
dTARGET;
XPUSHi(items);
- }
}
else if (gimme == G_ARRAY)
SP += items;
src = sv_mortalcopy(src);
}
SvTEMP_off(src);
- if (PL_op->op_private & OPpGREP_LEX)
- PAD_SVl(PL_op->op_targ) = src;
- else
- DEFSV_set(src);
+ DEFSV_set(src);
RETURNOP(cLOGOP->op_other);
}
/* The wraparound of signed integers is undefined
* behavior, but here we aim for count >=1, and
* negative count is just wrong. */
- if (n < 1)
+ if (n < 1
+#if IVSIZE > Size_t_size
+ || n > SSize_t_MAX
+#endif
+ )
overflow = TRUE;
}
if (overflow)
Perl_block_gimme(pTHX)
{
const I32 cxix = dopoptosub(cxstack_ix);
+ U8 gimme;
if (cxix < 0)
return G_VOID;
- switch (cxstack[cxix].blk_gimme) {
- case G_VOID:
- return G_VOID;
- case G_SCALAR:
- return G_SCALAR;
- case G_ARRAY:
- return G_ARRAY;
- default:
- Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
- }
- NOT_REACHED; /* NOTREACHED */
+ gimme = (cxstack[cxix].blk_gimme & G_WANT);
+ if (!gimme)
+ Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme);
+ return gimme;
}
+
I32
Perl_is_lvalue_sub(pTHX)
{
break;
case CXt_EVAL:
POPEVAL(cx);
+ 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;
+ 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);
cx->blk_sub.retop, TRUE);
if (!lcop)
lcop = cx->blk_oldcop;
- mPUSHi((I32)CopLINE(lcop));
+ mPUSHu(CopLINE(lcop));
if (!has_arg)
RETURN;
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
&& CopSTASH_eq(PL_curcop, PL_debstash))
{
- AV * const ary = cx->blk_sub.argarray;
+ /* slot 0 of the pad contains the original @_ */
+ AV * const ary = MUTABLE_AV(AvARRAY(MUTABLE_AV(
+ PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
+ cx->blk_sub.olddepth+1]))[0]);
const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
Perl_init_dbargs(aTHX);
dSP;
PERL_CONTEXT *cx;
const I32 gimme = G_ARRAY;
- U8 hasargs;
GV * const gv = PL_DBgv;
CV * cv = NULL;
/* don't do recursive DB::DB call */
return NORMAL;
- ENTER;
- SAVETMPS;
-
- SAVEI32(PL_debug);
- SAVESTACK_POS();
- PL_debug = 0;
- hasargs = 0;
- SPAGAIN;
-
if (CvISXSUB(cv)) {
+ ENTER;
+ SAVEI32(PL_debug);
+ PL_debug = 0;
+ SAVESTACK_POS();
+ SAVETMPS;
PUSHMARK(SP);
(void)(*CvXSUB(cv))(aTHX_ cv);
FREETMPS;
return NORMAL;
}
else {
+ U8 hasargs = 0;
PUSHBLOCK(cx, CXt_SUB, SP);
PUSHSUB_DB(cx);
cx->blk_sub.retop = PL_op->op_next;
+ cx->cx_u.cx_blk.blku_old_savestack_ix = PL_savestack_ix;
+
+ SAVEI32(PL_debug);
+ PL_debug = 0;
+ SAVESTACK_POS();
CvDEPTH(cv)++;
if (CvDEPTH(cv) >= 2) {
PERL_STACK_OVERFLOW_CHECK();
pad_push(CvPADLIST(cv), CvDEPTH(cv));
}
- SAVECOMPPAD();
PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
RETURNOP(CvSTART(cv));
}
}
/* 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
gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
- SP = leave_common(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP,
- PL_op->op_private & OPpLVALUE);
+ SP = (gimme == G_VOID)
+ ? newsp
+ : leave_common(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP,
+ PL_op->op_private & OPpLVALUE);
PL_curpm = newpm; /* Don't pop $1 et al till now */
LEAVE_with_name("block");
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);
-#ifdef USE_ITHREADS
- itervar = PL_comppad;
-#else
- itervar = &PAD_SVl(PL_op->op_targ);
-#endif
- }
- 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;
- save_aliased_sv(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) {
mark = newsp;
newsp = PL_stack_base + cx->blk_loop.resetsp;
- SP = leave_common(newsp, SP, MARK, gimme, 0,
+ SP = (gimme == G_VOID)
+ ? newsp
+ : leave_common(newsp, SP, MARK, gimme, SVs_PADTMP|SVs_TEMP,
PL_op->op_private & OPpLVALUE);
PUTBACK;
return NORMAL;
}
-/* handle most of the activity of returning from an lvalue sub.
- * Called by pp_leavesublv and pp_return.
- * For pp_leavesublv, base is null; for pp_return, its the base
- * of the args to be returned (i.e. the mark on entry to pp_return)
+
+/* This duplicates most of pp_leavesub, but with additional code to handle
+ * return args in lvalue context. It was forked from pp_leavesub to
+ * avoid slowing down that function any further.
+ *
+ * Any changes made to this function may need to be copied to pp_leavesub
+ * and vice-versa.
*/
-STATIC OP*
-S_return_lvalues(pTHX_ SV **base)
+PP(pp_leavesublv)
{
dSP;
SV **newsp;
bool ref;
const char *what = NULL;
+ if (CxMULTICALL(&cxstack[cxstack_ix])) {
+ /* entry zero of a stack is always PL_sv_undef, which
+ * simplifies converting a '()' return into undef in scalar context */
+ assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
+ return 0;
+ }
+
POPBLOCK(cx,newpm);
cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
TAINT_NOT;
- mark = base ? base : newsp;
+ mark = newsp + 1;
ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
if (gimme == G_SCALAR) {
if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
SV *sv;
- if (MARK < SP) {
- assert(MARK+1 == SP);
+ if (MARK <= SP) {
if ((SvPADTMP(TOPs) || SvREADONLY(TOPs)) &&
!SvSMAGICAL(TOPs)) {
what =
what = "undef";
}
croak:
- LEAVE;
POPSUB(cx,sv);
cxstack_ix--;
PL_curpm = newpm;
"Can't return %s from lvalue subroutine", what
);
}
- if (MARK < SP) {
+ if (MARK <= SP) {
copy_sv:
if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
if (!SvPADTMP(*SP)) {
- *++newsp = SvREFCNT_inc(*SP);
+ *MARK = SvREFCNT_inc(*SP);
FREETMPS;
- sv_2mortal(*newsp);
+ sv_2mortal(*MARK);
}
else {
/* FREETMPS could clobber it */
SV *sv = SvREFCNT_inc(*SP);
FREETMPS;
- *++newsp = sv_mortalcopy(sv);
+ *MARK = sv_mortalcopy(sv);
SvREFCNT_dec(sv);
}
}
else
- *++newsp =
+ *MARK =
SvPADTMP(*SP)
? sv_mortalcopy(*SP)
: !SvTEMP(*SP)
: *SP;
}
else {
- EXTEND(newsp,1);
- *++newsp = &PL_sv_undef;
+ MEXTEND(MARK, 0);
+ *MARK = &PL_sv_undef;
}
+ SP = MARK;
+
if (CxLVAL(cx) & OPpDEREF) {
SvGETMAGIC(TOPs);
if (!SvOK(TOPs)) {
else if (gimme == G_ARRAY) {
assert (!(CxLVAL(cx) & OPpDEREF));
if (ref || !CxLVAL(cx))
- while (++MARK <= SP)
- *++newsp =
+ for (; MARK <= SP; MARK++)
+ *MARK =
SvFLAGS(*MARK) & SVs_PADTMP
? sv_mortalcopy(*MARK)
: SvTEMP(*MARK)
? *MARK
: sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
- else while (++MARK <= SP) {
+ else for (; MARK <= SP; MARK++) {
if (*MARK != &PL_sv_undef
&& (SvPADTMP(*MARK) || SvREADONLY(*MARK))
) {
? "a readonly value" : "a temporary";
goto croak;
}
- else
- *++newsp =
- SvTEMP(*MARK)
- ? *MARK
- : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
+ else if (!SvTEMP(*MARK))
+ *MARK = sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
}
}
- PL_stack_sp = newsp;
+ PUTBACK;
- LEAVE;
POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
cxstack_ix--;
PL_curpm = newpm; /* ... and pop $1 et al */
{
dSP; dMARK;
PERL_CONTEXT *cx;
- bool clear_errsv = FALSE;
- I32 gimme;
- SV **newsp;
- PMOP *newpm;
- I32 optype = 0;
- SV *namesv;
- OP *retop = NULL;
-
const I32 cxix = dopoptosub(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 }}
- */
- assert(cxstack[0].blk_gimme == G_SCALAR);
- return 0;
- }
- else
- DIE(aTHX_ "Can't return outside a subroutine");
- }
- if (cxix < cxstack_ix)
- dounwind(cxix);
+ assert(cxstack_ix >= 0);
+ if (cxix < cxstack_ix) {
+ if (cxix < 0) {
+ 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);
+ if ( (sp != PL_stack_base)
+ && !(SvFLAGS(sv) & (SVs_TEMP|SVs_PADTMP))
+ )
+ *SP = sv_mortalcopy(sv);
+ dounwind(0);
+ }
+ /* caller responsible for popping cxstack[0] */
+ return 0;
+ }
- cx = &cxstack[cxix];
- if (CxMULTICALL(cx)) {
- gimme = cx->blk_gimme;
- if (gimme == G_VOID)
- PL_stack_sp = PL_stack_base;
- else if (gimme == G_SCALAR) {
- PL_stack_base[1] = *PL_stack_sp;
- PL_stack_sp = PL_stack_base + 1;
- }
- return 0;
+ /* 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. 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);
}
-
- if (CxTYPE(cx) == CXt_SUB) {
- if (CvLVALUE(cx->blk_sub.cv))
- return S_return_lvalues(aTHX_ MARK);
- else {
- SV **oldsp = PL_stack_base + cx->blk_oldsp;
- if (oldsp != MARK) {
- /* Handle extra junk on the stack. 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
- * 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.
- */
- 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 {
+ /* 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.
+ */
+ 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;
}
- /* fall through to a normal sub exit */
- return Perl_pp_leavesub(aTHX);
+ else
+ PL_stack_sp = oldsp;
}
}
- POPBLOCK(cx,newpm);
+ /* fall through to a normal exit */
switch (CxTYPE(cx)) {
case CXt_EVAL:
- if (!(PL_in_eval & EVAL_KEEPERR))
- clear_errsv = TRUE;
- POPEVAL(cx);
- namesv = cx->blk_eval.old_namesv;
- retop = cx->blk_eval.retop;
- if (CxTRYBLOCK(cx))
- break;
- if (optype == OP_REQUIRE &&
- (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
- {
- /* Unassume the success we assumed earlier. */
- (void)hv_delete(GvHVn(PL_incgv),
- SvPVX_const(namesv),
- SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
- G_DISCARD);
- DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
- }
- break;
+ return CxTRYBLOCK(cx)
+ ? Perl_pp_leavetry(aTHX)
+ : Perl_pp_leaveeval(aTHX);
+ case CXt_SUB:
+ return CvLVALUE(cx->blk_sub.cv)
+ ? Perl_pp_leavesublv(aTHX)
+ : Perl_pp_leavesub(aTHX);
case CXt_FORMAT:
- retop = cx->blk_sub.retop;
- POPFORMAT(cx);
- break;
+ return Perl_pp_leavewrite(aTHX);
default:
DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
}
-
- TAINT_NOT;
- if (gimme == G_SCALAR)
- *++newsp = (MARK < SP) ? sv_mortalcopy(*SP) : &PL_sv_undef;
- else if (gimme == G_ARRAY) {
- while (++MARK <= SP) {
- *++newsp = sv_mortalcopy(*MARK);
- TAINT_NOT; /* Each item is independent */
- }
- }
- PL_stack_sp = newsp;
-
- LEAVE;
- PL_curpm = newpm; /* ... and pop $1 et al */
-
- if (clear_errsv) {
- CLEAR_ERRSV();
- }
- return retop;
}
-/* This duplicates parts of pp_leavesub, so that it can share code with
- * pp_return */
-PP(pp_leavesublv)
-{
- if (CxMULTICALL(&cxstack[cxstack_ix]))
- return 0;
- return S_return_lvalues(aTHX_ NULL);
-
-
-}
static I32
S_unwind_loop(pTHX_ const char * const opname)
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);
SV * const sv = POPs;
SvGETMAGIC(sv);
- /* This egregious kludge implements goto &subroutine */
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
+ /* This egregious kludge implements goto &subroutine */
I32 cxix;
PERL_CONTEXT *cx;
CV *cv = MUTABLE_CV(SvRV(sv));
AV *arg = GvAV(PL_defgv);
- I32 oldsave;
- retry:
- if (!CvROOT(cv) && !CvXSUB(cv)) {
+ while (!CvROOT(cv) && !CvXSUB(cv)) {
const GV * const gv = CvGV(cv);
if (gv) {
GV *autogv;
SV *tmpstr;
/* autoloaded stub? */
if (cv != GvCV(gv) && (cv = GvCV(gv)))
- goto retry;
+ continue;
autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
GvNAMELEN(gv),
GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
if (autogv && (cv = GvCV(autogv)))
- goto retry;
+ continue;
tmpstr = sv_newmortal();
gv_efullname3(tmpstr, gv, NULL);
DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
DIE(aTHX_ "Goto undefined subroutine");
}
- /* First do some returnish stuff. */
- SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
- FREETMPS;
cxix = dopoptosub(cxstack_ix);
- if (cxix < cxstack_ix) {
- if (cxix < 0) {
- SvREFCNT_dec(cv);
- DIE(aTHX_ "Can't goto subroutine outside a subroutine");
- }
- dounwind(cxix);
+ if (cxix < 0) {
+ DIE(aTHX_ "Can't goto subroutine outside a subroutine");
}
- TOPBLOCK(cx);
- SPAGAIN;
+ cx = &cxstack[cxix];
/* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
if (CxTYPE(cx) == CXt_EVAL) {
- SvREFCNT_dec(cv);
if (CxREALEVAL(cx))
/* diag_listed_as: Can't goto subroutine from an eval-%s */
DIE(aTHX_ "Can't goto subroutine from an eval-string");
DIE(aTHX_ "Can't goto subroutine from an eval-block");
}
else if (CxMULTICALL(cx))
- {
- SvREFCNT_dec(cv);
DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
- }
+
+ /* First do some returnish stuff. */
+
+ SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
+ FREETMPS;
+ if (cxix < cxstack_ix) {
+ dounwind(cxix);
+ }
+ TOPBLOCK(cx);
+ SPAGAIN;
+
+ /* partial unrolled POPSUB(): */
+
+ /* protect @_ during save stack unwind. */
+ if (arg)
+ SvREFCNT_inc_NN(sv_2mortal(MUTABLE_SV(arg)));
+
+ assert(PL_scopestack_ix == cx->blk_oldscopesp);
+ LEAVE_SCOPE(cx->cx_u.cx_blk.blku_old_savestack_ix);
+
if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
- AV* av = cx->blk_sub.argarray;
-
- /* abandon the original @_ if it got reified or if it is
- the same as the current @_ */
- if (AvREAL(av) || av == arg) {
- SvREFCNT_dec(av);
- av = newAV();
- AvREIFY_only(av);
- PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
- }
+ AV* av = MUTABLE_AV(PAD_SVl(0));
+ assert(AvARRAY(MUTABLE_AV(
+ PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
+ CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
+
+ /* we are going to donate the current @_ from the old sub
+ * to the new sub. This first part of the donation puts a
+ * new empty AV in the pad[0] slot of the old sub,
+ * unless pad[0] and @_ differ (e.g. if the old sub did
+ * local *_ = []); in which case clear the old pad[0]
+ * array in the usual way */
+ if (av == arg || AvREAL(av))
+ clear_defarray(av, av == arg);
else CLEAR_ARGARRAY(av);
}
- /* We donate this refcount later to the callee’s pad. */
- SvREFCNT_inc_simple_void(arg);
- if (CxTYPE(cx) == CXt_SUB &&
- !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
- SvREFCNT_dec(cx->blk_sub.cv);
- oldsave = PL_scopestack[PL_scopestack_ix - 1];
- LEAVE_SCOPE(oldsave);
+
+ /* don't restore PL_comppad here. It won't be needed if the
+ * sub we're going to is non-XS, but restoring it early then
+ * croaking (e.g. the "Goto undefined subroutine" below)
+ * means the CX block gets processed again in dounwind,
+ * but this time with the wrong PL_comppad */
/* A destructor called during LEAVE_SCOPE could have undefined
* our precious cv. See bug #99850. */
if (!CvROOT(cv) && !CvXSUB(cv)) {
const GV * const gv = CvGV(cv);
- SvREFCNT_dec(arg);
if (gv) {
SV * const tmpstr = sv_newmortal();
gv_efullname3(tmpstr, gv, NULL);
DIE(aTHX_ "Goto undefined subroutine");
}
+ if (CxTYPE(cx) == CXt_SUB) {
+ CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth;
+ SvREFCNT_dec_NN(cx->blk_sub.cv);
+ }
+
/* Now do some callish stuff. */
- SAVETMPS;
- SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
if (CvISXSUB(cv)) {
SV **newsp;
I32 gimme;
PERL_UNUSED_VAR(newsp);
PERL_UNUSED_VAR(gimme);
+ ENTER;
+ SAVETMPS;
+ SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
+
/* put GvAV(defgv) back onto stack */
if (items) {
EXTEND(SP, items+1); /* @_ could have been extended. */
}
}
SP += items;
- SvREFCNT_dec(arg);
if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
/* Restore old @_ */
- arg = GvAV(PL_defgv);
- GvAV(PL_defgv) = cx->blk_sub.savearray;
- SvREFCNT_dec(arg);
+ POP_SAVEARRAY();
}
retop = cx->blk_sub.retop;
- /* XS subs don't have a CxSUB, so pop it */
- POPBLOCK(cx, PL_curpm);
+ PL_comppad = cx->blk_sub.prevcomppad;
+ PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
+
+ /* XS subs don't have a CXt_SUB, so pop it;
+ * this is a POPBLOCK(), less all the stuff we already did
+ * for TOPBLOCK() earlier */
+ PL_curcop = cx->blk_oldcop;
+ cxstack_ix--;
+
/* Push a mark for the start of arglist */
PUSHMARK(mark);
PUTBACK;
}
else {
PADLIST * const padlist = CvPADLIST(cv);
+
+ SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
+
+ /* partial unrolled PUSHSUB(): */
+
cx->blk_sub.cv = cv;
cx->blk_sub.olddepth = CvDEPTH(cv);
CvDEPTH(cv)++;
- if (CvDEPTH(cv) < 2)
- SvREFCNT_inc_simple_void_NN(cv);
- else {
+ SvREFCNT_inc_simple_void_NN(cv);
+ if (CvDEPTH(cv) > 1) {
if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
sub_crush_depth(cv);
pad_push(padlist, CvDEPTH(cv));
}
PL_curcop = cx->blk_oldcop;
- SAVECOMPPAD();
PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
if (CxHASARGS(cx))
{
- CX_CURPAD_SAVE(cx->blk_sub);
-
- /* cx->blk_sub.argarray has no reference count, so we
- need something to hang on to our argument array so
- that cx->blk_sub.argarray does not end up pointing
- to freed memory as the result of undef *_. So put
- it in the callee’s pad, donating our refer-
- ence count. */
+ /* second half of donating @_ from the old sub to the
+ * new sub: abandon the original pad[0] AV in the
+ * new sub, and replace it with the donated @_.
+ * pad[0] takes ownership of the extra refcount
+ * we gave arg earlier */
if (arg) {
SvREFCNT_dec(PAD_SVl(0));
- PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
+ PAD_SVl(0) = (SV *)arg;
+ SvREFCNT_inc_simple_void_NN(arg);
}
/* GvAV(PL_defgv) might have been modified on scope
- exit, so restore it. */
+ exit, so point it at arg again. */
if (arg != GvAV(PL_defgv)) {
AV * const av = GvAV(PL_defgv);
GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
SvREFCNT_dec(av);
}
}
- else SvREFCNT_dec(arg);
+
if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
Perl_get_db_sub(aTHX_ NULL, cv);
if (PERLDB_GOTO) {
3 is used for a die caught by an inner eval - continue inner loop
-See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
+See F<cop.h>: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
establish a local jmpenv to handle exception traps.
=cut
=for apidoc find_runcv
Locate the CV corresponding to the currently executing sub or eval.
-If db_seqp is non_null, skip CVs that are in the DB package and populate
-*db_seqp with the cop sequence number at the point that the DB:: code was
+If C<db_seqp> is non_null, skip CVs that are in the DB package and populate
+C<*db_seqp> with the cop sequence number at the point that the DB:: code was
entered. (This allows debuggers to eval in the scope of the breakpoint
rather than in the scope of the debugger itself.)
POPBLOCK(cx,PL_curpm);
POPEVAL(cx);
namesv = cx->blk_eval.old_namesv;
- /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
- LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
+ /* POPBLOCK has rendered LEAVE_with_name("evalcomp") unnecessary */
+ LEAVE_SCOPE(cx->cx_u.cx_blk.blku_old_savestack_ix);
+ PL_tmps_floor = cx->cx_u.cx_blk.blku_old_tmpsfloor;
}
errsv = ERRSV;
/* checking here captures a reasonable error message when
* PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
* user gets a confusing message about looking for the .pmc file
- * rather than for the .pm file.
+ * rather than for the .pm file so do the check in S_doopen_pm when
+ * PMC is on instead of here. S_doopen_pm calls this func.
* This check prevents a \0 in @INC causing problems.
*/
+#ifdef PERL_DISABLE_PMC
if (!IS_SAFE_PATHNAME(p, len, "require"))
return NULL;
+#endif
/* on Win32 stat is expensive (it does an open() and close() twice and
a couple other IO calls), the open will fail with a dir on its own with
}
#endif
-#if !defined(PERLIO_IS_STDIO)
retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
-#else
- retio = PerlIO_open(p, PERL_SCRIPT_MODE);
-#endif
#ifdef WIN32
/* EACCES stops the INC search early in pp_require to implement
feature RT #113422 */
if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
SV *const pmcsv = sv_newmortal();
- Stat_t pmcstat;
+ PerlIO * pmcio;
SvSetSV_nosteal(pmcsv,name);
sv_catpvs(pmcsv, "c");
- if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
- return check_type_and_open(pmcsv);
+ pmcio = check_type_and_open(pmcsv);
+ if (pmcio)
+ return pmcio;
}
return check_type_and_open(name);
}
OP *op;
int saved_errno;
bool path_searchable;
+ I32 old_savestack_ix;
sv = POPs;
SvGETMAGIC(sv);
unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
}
- ENTER_with_name("eval");
- SAVETMPS;
+ old_savestack_ix = PL_savestack_ix;
SAVECOPFILE_FREE(&PL_compiling);
CopFILE_set(&PL_compiling, tryname);
lex_start(NULL, tryrsfp, 0);
/* switch to eval mode */
PUSHBLOCK(cx, CXt_EVAL, SP);
PUSHEVAL(cx, name);
+ cx->cx_u.cx_blk.blku_old_savestack_ix = old_savestack_ix;
cx->blk_eval.retop = PL_op->op_next;
SAVECOPLINE(&PL_compiling);
U32 seq, lex_flags = 0;
HV *saved_hh = NULL;
const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
+ I32 old_savestack_ix;
if (PL_op->op_private & OPpEVAL_HAS_HH) {
saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
TAINT_IF(SvTAINTED(sv));
TAINT_PROPER("eval");
- ENTER_with_name("eval");
+ old_savestack_ix = PL_savestack_ix;
+
lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
? LEX_IGNORE_UTF8_HINTS
: bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
)
);
- SAVETMPS;
/* switch to eval mode */
PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
PUSHEVAL(cx, 0);
+ cx->cx_u.cx_blk.blku_old_savestack_ix = old_savestack_ix;
cx->blk_eval.retop = PL_op->op_next;
/* prepare to compile string */
- if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
+ if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
else {
/* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
if (doeval(gimme, runcv, seq, saved_hh)) {
if (was != PL_breakable_sub_gen /* Some subs defined here. */
- ? (PERLDB_LINE || PERLDB_SAVESRC)
+ ? PERLDB_LINE_OR_SAVESRC
: PERLDB_SAVESRC_NOSUBS) {
/* Retain the filegv we created. */
} else if (!saved_delete) {
/* We have already left the scope set up earlier thanks to the LEAVE
in doeval(). */
if (was != PL_breakable_sub_gen /* Some subs defined here. */
- ? (PERLDB_LINE || PERLDB_SAVESRC)
+ ? PERLDB_LINE_OR_SAVESRC
: PERLDB_SAVESRC_INVALID) {
/* Retain the filegv we created. */
} else if (!saved_delete) {
I32 gimme;
PERL_CONTEXT *cx;
OP *retop;
- const U8 save_flags = PL_op -> op_flags;
I32 optype;
SV *namesv;
CV *evalcv;
+ /* grab this value before POPEVAL restores old PL_in_eval */
+ bool keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
PERL_ASYNC_CHECK();
POPBLOCK(cx,newpm);
retop = cx->blk_eval.retop;
evalcv = cx->blk_eval.cv;
- SP = leave_common((gimme == G_VOID) ? SP : newsp, SP, newsp,
- gimme, SVs_TEMP, FALSE);
+ if (gimme != G_VOID)
+ SP = leave_common(newsp, SP, newsp, gimme, SVs_TEMP, FALSE);
PL_curpm = newpm; /* Don't pop $1 et al till now */
#ifdef DEBUGGING
SvPVX_const(namesv),
SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
G_DISCARD);
+ 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_with_name("eval");
- if (!(save_flags & OPf_SPECIAL)) {
+ 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();
- }
}
RETURNOP(retop);
POPBLOCK(cx,newpm);
POPEVAL(cx);
PL_curpm = newpm;
- LEAVE_with_name("eval_scope");
+ 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);
PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
- ENTER_with_name("eval_scope");
- SAVETMPS;
-
PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
PUSHEVAL(cx, 0);
+ cx->cx_u.cx_blk.blku_old_savestack_ix = PL_savestack_ix;
PL_in_eval = EVAL_INEVAL;
if (flags & G_KEEPERR)
I32 gimme;
PERL_CONTEXT *cx;
I32 optype;
+ OP *retop;
PERL_ASYNC_CHECK();
POPBLOCK(cx,newpm);
+ retop = cx->blk_eval.retop;
POPEVAL(cx);
PERL_UNUSED_VAR(optype);
- SP = leave_common(newsp, SP, newsp, gimme,
+ SP = (gimme == G_VOID)
+ ? newsp
+ : leave_common(newsp, SP, newsp, gimme,
SVs_PADTMP|SVs_TEMP, FALSE);
PL_curpm = newpm; /* Don't pop $1 et al till now */
- LEAVE_with_name("eval_scope");
+ LEAVE_SCOPE(cx->cx_u.cx_blk.blku_old_savestack_ix);
+ PL_tmps_floor = cx->cx_u.cx_blk.blku_old_tmpsfloor;
+
CLEAR_ERRSV();
- RETURN;
+ RETURNOP(retop);
}
PP(pp_entergiven)
dSP;
PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
+ SV *origsv = DEFSV;
+ SV *newsv = POPs;
ENTER_with_name("given");
SAVETMPS;
- if (PL_op->op_targ) {
- SAVEPADSVANDMORTALIZE(PL_op->op_targ);
- SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
- PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
- }
- else {
- SAVE_DEFSV;
- DEFSV_set(POPs);
- }
+ assert(!PL_op->op_targ); /* used to be set for lexical $_ */
+ 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 = leave_common(newsp, SP, newsp, gimme,
+ SP = (gimme == G_VOID)
+ ? newsp
+ : leave_common(newsp, SP, newsp, gimme,
SVs_PADTMP|SVs_TEMP, FALSE);
PL_curpm = newpm; /* Don't pop $1 et al till now */
POPBLOCK(cx,newpm);
assert(CxTYPE(cx) == CXt_WHEN);
+ POPWHEN(cx);
- SP = leave_common(newsp, SP, newsp, gimme,
+ SP = (gimme == G_VOID)
+ ? newsp
+ : leave_common(newsp, SP, newsp, gimme,
SVs_PADTMP|SVs_TEMP, FALSE);
PL_curpm = newpm; /* pop $1 et al */
https://perl5.git.perl.org / perl5.git / blobdiff