X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/0bd863d8ca9a7ab3337115aefd3f333f3229e50b..acab2422b2372f4b4d6e2542e9b9cf3dc0b83e92:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index b174a05..99ff59a 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -190,7 +190,7 @@ PP(pp_regcomp) PP(pp_substcont) { dSP; - PERL_CONTEXT *cx = &cxstack[cxstack_ix]; + PERL_CONTEXT *cx = CX_CUR(); PMOP * const pm = (PMOP*) cLOGOP->op_other; SV * const dstr = cx->sb_dstr; char *s = cx->sb_s; @@ -285,8 +285,11 @@ PP(pp_substcont) /* PL_tainted must be correctly set for this mg_set */ SvSETMAGIC(TARG); TAINT_NOT; + CX_LEAVE_SCOPE(cx); - POPSUBST(cx); + CX_POPSUBST(cx); + CX_POP(cx); + PERL_ASYNC_CHECK(); RETURNOP(pm->op_next); NOT_REACHED; /* NOTREACHED */ @@ -962,7 +965,7 @@ PP(pp_grepstart) PP(pp_mapwhile) { dSP; - const I32 gimme = GIMME_V; + const U8 gimme = GIMME_V; I32 items = (SP - PL_stack_base) - TOPMARK; /* how many new items */ I32 count; I32 shift; @@ -1263,10 +1266,11 @@ static const char * const context_name[] = { NULL, /* CXt_WHEN never actually needs "block" */ NULL, /* CXt_BLOCK never actually needs "block" */ NULL, /* CXt_GIVEN never actually needs "block" */ - NULL, /* CXt_LOOP_FOR never actually needs "loop" */ NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */ - NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */ NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */ + NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */ + NULL, /* CXt_LOOP_LIST never actually needs "loop" */ + NULL, /* CXt_LOOP_ARY never actually needs "loop" */ "subroutine", "format", "eval", @@ -1294,10 +1298,11 @@ S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags) if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */ return -1; break; + case CXt_LOOP_PLAIN: case CXt_LOOP_LAZYIV: case CXt_LOOP_LAZYSV: - case CXt_LOOP_FOR: - case CXt_LOOP_PLAIN: + case CXt_LOOP_LIST: + case CXt_LOOP_ARY: { STRLEN cx_label_len = 0; U32 cx_label_flags = 0; @@ -1327,14 +1332,14 @@ S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags) -I32 +U8 Perl_dowantarray(pTHX) { - const I32 gimme = block_gimme(); + const U8 gimme = block_gimme(); return (gimme == G_VOID) ? G_SCALAR : gimme; } -I32 +U8 Perl_block_gimme(pTHX) { const I32 cxix = dopoptosub(cxstack_ix); @@ -1361,7 +1366,7 @@ Perl_is_lvalue_sub(pTHX) return 0; } -/* only used by PUSHSUB */ +/* only used by cx_pushsub() */ I32 Perl_was_lvalue_sub(pTHX) { @@ -1441,10 +1446,11 @@ S_dopoptoloop(pTHX_ I32 startingblock) if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */ return -1; break; + case CXt_LOOP_PLAIN: case CXt_LOOP_LAZYIV: case CXt_LOOP_LAZYSV: - case CXt_LOOP_FOR: - case CXt_LOOP_PLAIN: + case CXt_LOOP_LIST: + case CXt_LOOP_ARY: DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i)); return i; } @@ -1452,7 +1458,7 @@ S_dopoptoloop(pTHX_ I32 startingblock) return i; } -/* find the next GIVEN or FOR loop context block */ +/* find the next GIVEN or FOR (with implicit $_) loop context block */ STATIC I32 S_dopoptogivenfor(pTHX_ I32 startingblock) @@ -1467,12 +1473,13 @@ S_dopoptogivenfor(pTHX_ I32 startingblock) DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i)); return i; case CXt_LOOP_PLAIN: - assert(!CxFOREACHDEF(cx)); + assert(!(cx->cx_type & CXp_FOR_DEF)); break; case CXt_LOOP_LAZYIV: case CXt_LOOP_LAZYSV: - case CXt_LOOP_FOR: - if (CxFOREACHDEF(cx)) { + case CXt_LOOP_LIST: + case CXt_LOOP_ARY: + if (cx->cx_type & CXp_FOR_DEF) { DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i)); return i; } @@ -1498,62 +1505,64 @@ S_dopoptowhen(pTHX_ I32 startingblock) return i; } +/* dounwind(): pop all contexts above (but not including) cxix. + * Note that it clears the savestack frame associated with each popped + * context entry, but doesn't free any temps. + * It does a cx_popblock() of the last frame that it pops, and leaves + * cxstack_ix equal to cxix. + */ + void Perl_dounwind(pTHX_ I32 cxix) { - I32 optype; - if (!PL_curstackinfo) /* can happen if die during thread cloning */ return; while (cxstack_ix > cxix) { - PERL_CONTEXT *cx = &cxstack[cxstack_ix]; - DEBUG_CX("UNWIND"); \ + PERL_CONTEXT *cx = CX_CUR(); + + CX_DEBUG(cx, "UNWIND"); /* Note: we don't need to restore the base context info till the end. */ + + CX_LEAVE_SCOPE(cx); + switch (CxTYPE(cx)) { case CXt_SUBST: - CX_LEAVE_SCOPE(cx); - POPSUBST(cx); - continue; /* not break */ + CX_POPSUBST(cx); + break; case CXt_SUB: - CX_LEAVE_SCOPE(cx); - POPSUB(cx); + cx_popsub(cx); break; case CXt_EVAL: - CX_LEAVE_SCOPE(cx); - POPEVAL(cx); - break; - case CXt_BLOCK: - CX_LEAVE_SCOPE(cx); - POPBASICBLK(cx); + cx_popeval(cx); break; + case CXt_LOOP_PLAIN: case CXt_LOOP_LAZYIV: case CXt_LOOP_LAZYSV: - case CXt_LOOP_FOR: - case CXt_LOOP_PLAIN: - CX_LEAVE_SCOPE(cx); - POPLOOP(cx); + case CXt_LOOP_LIST: + case CXt_LOOP_ARY: + cx_poploop(cx); break; case CXt_WHEN: - CX_LEAVE_SCOPE(cx); - POPWHEN(cx); + cx_popwhen(cx); break; case CXt_GIVEN: - CX_LEAVE_SCOPE(cx); - POPGIVEN(cx); + cx_popgiven(cx); break; + case CXt_BLOCK: case CXt_NULL: - /* there isn't a POPNULL ! */ - CX_LEAVE_SCOPE(cx); + /* these two don't have a POPFOO() */ break; case CXt_FORMAT: - CX_LEAVE_SCOPE(cx); - POPFORMAT(cx); + cx_popformat(cx); break; } + if (cxstack_ix == cxix + 1) { + cx_popblock(cx); + } cxstack_ix--; } - PERL_UNUSED_VAR(optype); + } void @@ -1577,6 +1586,34 @@ Perl_qerror(pTHX_ SV *err) ++PL_parser->error_count; } + + +/* undef or delete the $INC{namesv} entry, then croak. + * require0 indicates that the require didn't return a true value */ + +static void +S_undo_inc_then_croak(pTHX_ SV *namesv, SV *err, bool require0) +{ + const char *fmt; + HV *inc_hv = GvHVn(PL_incgv); + I32 klen = SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv); + const char *key = SvPVX_const(namesv); + + if (require0) { + (void)hv_delete(inc_hv, key, klen, G_DISCARD); + fmt = "%"SVf" did not return a true value"; + err = namesv; + } + else { + (void)hv_store(inc_hv, key, klen, &PL_sv_undef, 0); + fmt = "%"SVf"Compilation failed in require"; + err = err ? err : newSVpvs_flags("Unknown error\n", SVs_TEMP); + } + + Perl_croak(aTHX_ fmt, SVfARG(err)); +} + + void Perl_die_unwind(pTHX_ SV *msv) { @@ -1634,63 +1671,44 @@ Perl_die_unwind(pTHX_ SV *msv) } if (cxix >= 0) { - I32 optype; - SV *namesv; + SV *namesv = NULL; PERL_CONTEXT *cx; - SV **newsp; - I32 gimme; -#ifdef DEBUGGING - COP *oldcop; -#endif + SV **oldsp; + U8 gimme; JMPENV *restartjmpenv; OP *restartop; if (cxix < cxstack_ix) dounwind(cxix); - cx = &cxstack[cxstack_ix]; + cx = CX_CUR(); assert(CxTYPE(cx) == CXt_EVAL); - newsp = PL_stack_base + cx->blk_oldsp; - gimme = cx->blk_gimme; + /* return false to the caller of eval */ + oldsp = PL_stack_base + cx->blk_oldsp; + gimme = cx->blk_gimme; if (gimme == G_SCALAR) - *++newsp = &PL_sv_undef; - PL_stack_sp = newsp; - - - if (CxTYPE(cx) != CXt_EVAL) { - STRLEN msglen; - const char* message = SvPVx_const(exceptsv, msglen); - PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11); - PerlIO_write(Perl_error_log, message, msglen); - my_exit(1); - } + *++oldsp = &PL_sv_undef; + PL_stack_sp = oldsp; CX_LEAVE_SCOPE(cx); - POPEVAL(cx); - POPBLOCK(cx); - cxstack_ix--; - namesv = cx->blk_eval.old_namesv; -#ifdef DEBUGGING - oldcop = cx->blk_oldcop; -#endif + cx_popeval(cx); + cx_popblock(cx); restartjmpenv = cx->blk_eval.cur_top_env; restartop = cx->blk_eval.retop; + if (CxOLD_OP_TYPE(cx) == OP_REQUIRE) + namesv = cx->blk_eval.old_namesv; + CX_POP(cx); + + if (namesv) { + /* note that unlike pp_entereval, pp_require isn't + * supposed to trap errors. So now that we've popped the + * EVAL that pp_require pushed, process the error message + * and rethrow the error */ + S_undo_inc_then_croak(aTHX_ namesv, exceptsv, FALSE); + NOT_REACHED; /* NOTREACHED */ + } - if (optype == OP_REQUIRE) { - assert (PL_curcop == oldcop); - (void)hv_store(GvHVn(PL_incgv), - SvPVX_const(namesv), - SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv), - &PL_sv_undef, 0); - /* note that unlike pp_entereval, pp_require isn't - * supposed to trap errors. So now that we've popped the - * EVAL that pp_require pushed, and processed the error - * message, rethrow the error */ - Perl_croak(aTHX_ "%"SVf"Compilation failed in require", - SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n", - SVs_TEMP))); - } if (!(in_eval & EVAL_KEEPERR)) sv_setsv(ERRSV, exceptsv); PL_restartjmpenv = restartjmpenv; @@ -1782,7 +1800,7 @@ PP(pp_caller) dSP; const PERL_CONTEXT *cx; const PERL_CONTEXT *dbcx; - I32 gimme = GIMME_V; + U8 gimme = GIMME_V; const HEK *stash_hek; I32 count = 0; bool has_arg = MAXARG && TOPs; @@ -1803,7 +1821,7 @@ PP(pp_caller) RETURN; } - DEBUG_CX("CALLER"); + CX_DEBUG(cx, "CALLER"); assert(CopSTASH(cx->blk_oldcop)); stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop)) @@ -1852,7 +1870,7 @@ PP(pp_caller) PUSHs(newSVpvs_flags("(eval)", SVs_TEMP)); mPUSHi(0); } - gimme = (I32)cx->blk_gimme; + gimme = cx->blk_gimme; if (gimme == G_VOID) PUSHs(&PL_sv_undef); else @@ -1956,7 +1974,7 @@ PP(pp_dbstate) { PL_curcop = (COP*)PL_op; TAINT_NOT; /* Each statement is presumed innocent */ - PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; + PL_stack_sp = PL_stack_base + CX_CUR()->blk_oldsp; FREETMPS; PERL_ASYNC_CHECK(); @@ -1966,7 +1984,7 @@ PP(pp_dbstate) { dSP; PERL_CONTEXT *cx; - const I32 gimme = G_ARRAY; + const U8 gimme = G_ARRAY; GV * const gv = PL_DBgv; CV * cv = NULL; @@ -1993,20 +2011,19 @@ PP(pp_dbstate) return NORMAL; } else { - U8 hasargs = 0; - PUSHBLOCK(cx, CXt_SUB, SP); - PUSHSUB_DB(cx); - cx->blk_sub.retop = PL_op->op_next; - cx->cx_old_savestack_ix = PL_savestack_ix; + cx = cx_pushblock(CXt_SUB, gimme, SP, PL_savestack_ix); + cx_pushsub(cx, cv, PL_op->op_next, 0); + /* OP_DBSTATE's op_private holds hint bits rather than + * the lvalue-ish flags seen in OP_ENTERSUB. So cancel + * any CxLVAL() flags that have now been mis-calculated */ + cx->blk_u16 = 0; SAVEI32(PL_debug); PL_debug = 0; SAVESTACK_POS(); CvDEPTH(cv)++; - if (CvDEPTH(cv) >= 2) { - PERL_STACK_OVERFLOW_CHECK(); + if (CvDEPTH(cv) >= 2) pad_push(CvPADLIST(cv), CvDEPTH(cv)); - } PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv)); RETURNOP(CvSTART(cv)); } @@ -2015,97 +2032,41 @@ PP(pp_dbstate) return NORMAL; } -/* S_leave_common: Common code that many functions in this file use on - scope exit. - - Process the return args on the stack in the range (mark+1..PL_stack_sp) - based on context, with any final args starting at newsp+1. - 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. -*/ - -STATIC void -S_leave_common(pTHX_ SV **newsp, SV **mark, I32 gimme, - U32 flags, bool lvalue) -{ - dSP; - PERL_ARGS_ASSERT_LEAVE_COMMON; - - TAINT_NOT; - if (gimme == G_SCALAR) { - if (MARK < SP) - *++newsp = (SvFLAGS(*SP) & flags) - ? *SP - : lvalue - ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP)) - : sv_mortalcopy(*SP); - else { - EXTEND(newsp, 1); - *++newsp = &PL_sv_undef; - } - } - else if (gimme == G_ARRAY) { - /* in case LEAVE wipes old return values */ - while (++MARK <= SP) { - if (SvFLAGS(*MARK) & flags) - *++newsp = *MARK; - else { - *++newsp = lvalue - ? sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)) - : sv_mortalcopy(*MARK); - TAINT_NOT; /* Each item is independent */ - } - } - /* When this function was called with MARK == newsp, we reach this - * point with SP == newsp. */ - } - - PL_stack_sp = newsp; -} - PP(pp_enter) { - dSP; - PERL_CONTEXT *cx; - I32 gimme = GIMME_V; - - PUSHBLOCK(cx, CXt_BLOCK, SP); - PUSHBASICBLK(cx); + U8 gimme = GIMME_V; - RETURN; + (void)cx_pushblock(CXt_BLOCK, gimme, PL_stack_sp, PL_savestack_ix); + return NORMAL; } + PP(pp_leave) { PERL_CONTEXT *cx; - SV **newsp; - I32 gimme; + SV **oldsp; + U8 gimme; - cx = &cxstack[cxstack_ix]; + cx = CX_CUR(); assert(CxTYPE(cx) == CXt_BLOCK); if (PL_op->op_flags & OPf_SPECIAL) - cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */ + /* fake block should preserve $1 et al; e.g. /(...)/ while ...; */ + cx->blk_oldpm = PL_curpm; - newsp = PL_stack_base + cx->blk_oldsp; + oldsp = PL_stack_base + cx->blk_oldsp; gimme = cx->blk_gimme; if (gimme == G_VOID) - PL_stack_sp = newsp; + PL_stack_sp = oldsp; else - leave_common(newsp, newsp, gimme, SVs_PADTMP|SVs_TEMP, - PL_op->op_private & OPpLVALUE); + leave_adjust_stacks(oldsp, oldsp, gimme, + PL_op->op_private & OPpLVALUE ? 3 : 1); CX_LEAVE_SCOPE(cx); - POPBASICBLK(cx); - POPBLOCK(cx); - cxstack_ix--; + cx_popblock(cx); + CX_POP(cx); return NORMAL; } @@ -2136,10 +2097,10 @@ PP(pp_enteriter) { dSP; dMARK; PERL_CONTEXT *cx; - const I32 gimme = GIMME_V; + const U8 gimme = GIMME_V; 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; + U8 cxflags = 0; if (PL_op->op_targ) { /* "my" variable */ itervarp = &PAD_SVl(PL_op->op_targ); @@ -2152,68 +2113,63 @@ PP(pp_enteriter) SvPADSTALE_on(itersave); } SvREFCNT_inc_simple_void_NN(itersave); - cxtype |= CXp_FOR_PAD; + cxflags = CXp_FOR_PAD; } else { SV * const sv = POPs; 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; + itersave = GvSV(sv); + SvREFCNT_inc_simple_void(itersave); + cxflags = CXp_FOR_GV; + if (PL_op->op_private & OPpITER_DEF) + cxflags |= CXp_FOR_DEF; } 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; + cxflags = CXp_FOR_LVREF; } } + /* OPpITER_DEF (implicit $_) should only occur with a GV iter var */ + assert((cxflags & CXp_FOR_GV) || !(PL_op->op_private & OPpITER_DEF)); - if (PL_op->op_private & OPpITER_DEF) - cxtype |= CXp_FOR_DEF; + /* Note that this context is initially set as CXt_NULL. Further on + * down it's changed to one of the CXt_LOOP_*. Before it's changed, + * there mustn't be anything in the blk_loop substruct that requires + * freeing or undoing, in case we die in the meantime. And vice-versa. + */ + cx = cx_pushblock(cxflags, gimme, MARK, PL_savestack_ix); + cx_pushloop_for(cx, itervarp, itersave); - PUSHBLOCK(cx, cxtype, SP); - PUSHLOOP_FOR(cx, itervarp, itersave, MARK); if (PL_op->op_flags & OPf_STACKED) { + /* OPf_STACKED implies either a single array: for(@), with a + * single AV on the stack, or a range: for (1..5), with 1 and 5 on + * the stack */ SV *maybe_ary = POPs; if (SvTYPE(maybe_ary) != SVt_PVAV) { + /* range */ dPOPss; SV * const right = maybe_ary; - if (UNLIKELY(cxtype & CXp_FOR_LVREF)) + if (UNLIKELY(cxflags & CXp_FOR_LVREF)) DIE(aTHX_ "Assigned value is not a reference"); SvGETMAGIC(sv); SvGETMAGIC(right); if (RANGE_IS_NUMERIC(sv,right)) { - cx->cx_type &= ~CXTYPEMASK; cx->cx_type |= CXt_LOOP_LAZYIV; - /* Make sure that no-one re-orders cop.h and breaks our - assumptions */ - assert(CxTYPE(cx) == CXt_LOOP_LAZYIV); if (S_outside_integer(aTHX_ sv) || S_outside_integer(aTHX_ right)) DIE(aTHX_ "Range iterator outside integer range"); cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv); cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right); -#ifdef DEBUGGING - /* for correct -Dstv display */ - cx->blk_oldsp = sp - PL_stack_base; -#endif } else { - cx->cx_type &= ~CXTYPEMASK; cx->cx_type |= CXt_LOOP_LAZYSV; - /* Make sure that no-one re-orders cop.h and breaks our - assumptions */ - assert(CxTYPE(cx) == CXt_LOOP_LAZYSV); cx->blk_loop.state_u.lazysv.cur = newSVsv(sv); cx->blk_loop.state_u.lazysv.end = right; - SvREFCNT_inc(right); + SvREFCNT_inc_simple_void_NN(right); (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur); /* This will do the upgrade to SVt_PV, and warn if the value is uninitialised. */ @@ -2227,22 +2183,28 @@ PP(pp_enteriter) } } else /* SvTYPE(maybe_ary) == SVt_PVAV */ { + /* for (@array) {} */ + cx->cx_type |= CXt_LOOP_ARY; cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary); - SvREFCNT_inc(maybe_ary); + SvREFCNT_inc_simple_void_NN(maybe_ary); cx->blk_loop.state_u.ary.ix = (PL_op->op_private & OPpITER_REVERSED) ? AvFILL(cx->blk_loop.state_u.ary.ary) + 1 : -1; } + /* EXTEND(SP, 1) not needed in this branch because we just did POPs */ } else { /* iterating over items on the stack */ - cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */ - if (PL_op->op_private & OPpITER_REVERSED) { - cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1; - } - else { - cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base; - } + cx->cx_type |= CXt_LOOP_LIST; + cx->blk_oldsp = SP - PL_stack_base; + cx->blk_loop.state_u.stack.basesp = MARK - PL_stack_base; + cx->blk_loop.state_u.stack.ix = + (PL_op->op_private & OPpITER_REVERSED) + ? cx->blk_oldsp + 1 + : cx->blk_loop.state_u.stack.basesp; + /* pre-extend stack so pp_iter doesn't have to check every time + * it pushes yes/no */ + EXTEND(SP, 1); } RETURN; @@ -2250,39 +2212,40 @@ PP(pp_enteriter) PP(pp_enterloop) { - dSP; PERL_CONTEXT *cx; - const I32 gimme = GIMME_V; + const U8 gimme = GIMME_V; - PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP); - PUSHLOOP_PLAIN(cx, SP); - - RETURN; + cx = cx_pushblock(CXt_LOOP_PLAIN, gimme, PL_stack_sp, PL_savestack_ix); + cx_pushloop_plain(cx); + return NORMAL; } + PP(pp_leaveloop) { PERL_CONTEXT *cx; - I32 gimme; - SV **newsp; + U8 gimme; + SV **oldsp; SV **mark; - cx = &cxstack[cxstack_ix]; + cx = CX_CUR(); assert(CxTYPE_is_LOOP(cx)); mark = PL_stack_base + cx->blk_oldsp; - newsp = PL_stack_base + cx->blk_loop.resetsp; + oldsp = CxTYPE(cx) == CXt_LOOP_LIST + ? PL_stack_base + cx->blk_loop.state_u.stack.basesp + : mark; gimme = cx->blk_gimme; if (gimme == G_VOID) - PL_stack_sp = newsp; + PL_stack_sp = oldsp; else - leave_common(newsp, MARK, gimme, SVs_PADTMP|SVs_TEMP, - PL_op->op_private & OPpLVALUE); + leave_adjust_stacks(MARK, oldsp, gimme, + PL_op->op_private & OPpLVALUE ? 3 : 1); CX_LEAVE_SCOPE(cx); - POPLOOP(cx); /* Stack values are safe: release loop vars ... */ - POPBLOCK(cx); - cxstack_ix--; + cx_poploop(cx); /* Stack values are safe: release loop vars ... */ + cx_popblock(cx); + CX_POP(cx); return NORMAL; } @@ -2294,19 +2257,18 @@ PP(pp_leaveloop) * * Any changes made to this function may need to be copied to pp_leavesub * and vice-versa. + * + * also tail-called by pp_return */ PP(pp_leavesublv) { - dSP; - SV **newsp; - SV **mark; - I32 gimme; + U8 gimme; PERL_CONTEXT *cx; - bool ref; - const char *what = NULL; + SV **oldsp; + OP *retop; - cx = &cxstack[cxstack_ix]; + cx = CX_CUR(); assert(CxTYPE(cx) == CXt_SUB); if (CxMULTICALL(cx)) { @@ -2316,105 +2278,86 @@ PP(pp_leavesublv) return 0; } - newsp = PL_stack_base + cx->blk_oldsp; gimme = cx->blk_gimme; - TAINT_NOT; + oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */ - mark = newsp + 1; - - ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS); - if (gimme == G_SCALAR) { - if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */ - if (MARK <= SP) { - if ((SvPADTMP(TOPs) || SvREADONLY(TOPs)) && - !SvSMAGICAL(TOPs)) { - what = - SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef" - : "a readonly value" : "a temporary"; - } - else goto copy_sv; - } - else { - /* sub:lvalue{} will take us here. */ - what = "undef"; - } - croak: - CX_LEAVE_SCOPE(cx); - POPSUB(cx); - cxstack_ix--; - PL_curpm = cx->blk_oldpm; - Perl_croak(aTHX_ - "Can't return %s from lvalue subroutine", what - ); - } - if (MARK <= SP) { - copy_sv: - if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { - if (!SvPADTMP(*SP)) { - *MARK = SvREFCNT_inc(*SP); - FREETMPS; - sv_2mortal(*MARK); - } - else { - /* FREETMPS could clobber it */ - SV *sv = SvREFCNT_inc(*SP); - FREETMPS; - *MARK = sv_mortalcopy(sv); - SvREFCNT_dec(sv); - } - } - else - *MARK = - SvPADTMP(*SP) - ? sv_mortalcopy(*SP) - : !SvTEMP(*SP) - ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP)) - : *SP; - } - else { - MEXTEND(MARK, 0); - *MARK = &PL_sv_undef; - } - SP = MARK; + if (gimme == G_VOID) + PL_stack_sp = oldsp; + else { + U8 lval = CxLVAL(cx); + bool is_lval = (lval && !(lval & OPpENTERSUB_INARGS)); + const char *what = NULL; + + if (gimme == G_SCALAR) { + if (is_lval) { + /* check for bad return arg */ + if (oldsp < PL_stack_sp) { + SV *sv = *PL_stack_sp; + if ((SvPADTMP(sv) || SvREADONLY(sv))) { + what = + SvREADONLY(sv) ? (sv == &PL_sv_undef) ? "undef" + : "a readonly value" : "a temporary"; + } + else goto ok; + } + else { + /* sub:lvalue{} will take us here. */ + what = "undef"; + } + croak: + Perl_croak(aTHX_ + "Can't return %s from lvalue subroutine", what); + } - if (CxLVAL(cx) & OPpDEREF) { - SvGETMAGIC(TOPs); - if (!SvOK(TOPs)) { - TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF); - } - } - } - else if (gimme == G_ARRAY) { - assert (!(CxLVAL(cx) & OPpDEREF)); - if (ref || !CxLVAL(cx)) - for (; MARK <= SP; MARK++) - *MARK = - SvFLAGS(*MARK) & SVs_PADTMP - ? sv_mortalcopy(*MARK) - : SvTEMP(*MARK) - ? *MARK - : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)); - else for (; MARK <= SP; MARK++) { - if (*MARK != &PL_sv_undef - && (SvPADTMP(*MARK) || SvREADONLY(*MARK)) - ) { - /* Might be flattened array after $#array = */ - what = SvREADONLY(*MARK) - ? "a readonly value" : "a temporary"; - goto croak; - } - else if (!SvTEMP(*MARK)) - *MARK = sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)); - } + ok: + leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2); + + if (lval & OPpDEREF) { + /* lval_sub()->{...} and similar */ + dSP; + SvGETMAGIC(TOPs); + if (!SvOK(TOPs)) { + TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF); + } + PUTBACK; + } + } + else { + assert(gimme == G_ARRAY); + assert (!(lval & OPpDEREF)); + + if (is_lval) { + /* scan for bad return args */ + SV **p; + for (p = PL_stack_sp; p > oldsp; p--) { + SV *sv = *p; + /* the PL_sv_undef exception is to allow things like + * this to work, where PL_sv_undef acts as 'skip' + * placeholder on the LHS of list assigns: + * sub foo :lvalue { undef } + * ($a, undef, foo(), $b) = 1..4; + */ + if (sv != &PL_sv_undef && (SvPADTMP(sv) || SvREADONLY(sv))) + { + /* Might be flattened array after $#array = */ + what = SvREADONLY(sv) + ? "a readonly value" : "a temporary"; + goto croak; + } + } + } + + leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2); + } } - PUTBACK; CX_LEAVE_SCOPE(cx); - POPSUB(cx); /* Stack values are safe: release CV and @_ ... */ - POPBLOCK(cx); - cxstack_ix--; + cx_popsub(cx); /* Stack values are safe: release CV and @_ ... */ + cx_popblock(cx); + retop = cx->blk_sub.retop; + CX_POP(cx); - return cx->blk_sub.retop; + return retop; } @@ -2457,27 +2400,29 @@ PP(pp_return) } /* There are contexts that need popping. Doing this may free the - * return value(s), so preserve them first, e.g. popping the plain + * 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. + * leaves 1,2,3,4 on the stack. Both these actions will be done by + * leave_adjust_stacks(), along with freeing any temps. Note that + * whoever we tail-call (e.g. pp_leaveeval) will also call + * leave_adjust_stacks(); however, the second call is likely to + * just see a bunch of SvTEMPs with a ref count of 1, and so just + * pass them through, rather than copying them again. So this + * isn't as inefficient as it sounds. */ cx = &cxstack[cxix]; PUTBACK; - leave_common(PL_stack_base + cx->blk_oldsp, MARK, - cx->blk_gimme, SVs_TEMP|SVs_PADTMP, TRUE); + if (cx->blk_gimme != G_VOID) + leave_adjust_stacks(MARK, PL_stack_base + cx->blk_oldsp, + cx->blk_gimme, + CxTYPE(cx) == CXt_SUB && CvLVALUE(cx->blk_sub.cv) + ? 3 : 0); SPAGAIN; dounwind(cxix); + cx = &cxstack[cxix]; /* CX stack may have been realloced */ } else { /* Like in the branch above, we need to handle any extra junk on @@ -2526,16 +2471,18 @@ PP(pp_return) } } +/* find the enclosing loop or labelled loop and dounwind() back to it. */ -static I32 -S_unwind_loop(pTHX_ const char * const opname) +static PERL_CONTEXT * +S_unwind_loop(pTHX) { I32 cxix; if (PL_op->op_flags & OPf_SPECIAL) { cxix = dopoptoloop(cxstack_ix); if (cxix < 0) /* diag_listed_as: Can't "last" outside a loop block */ - Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname); + Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", + OP_NAME(PL_op)); } else { dSP; @@ -2553,7 +2500,7 @@ S_unwind_loop(pTHX_ const char * const opname) if (cxix < 0) /* diag_listed_as: Label not found for "last %s" */ Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"", - opname, + OP_NAME(PL_op), SVfARG(PL_op->op_flags & OPf_STACKED && !SvGMAGICAL(TOPp1s) ? TOPp1s @@ -2563,43 +2510,46 @@ S_unwind_loop(pTHX_ const char * const opname) } if (cxix < cxstack_ix) dounwind(cxix); - return cxix; + return &cxstack[cxix]; } + PP(pp_last) { PERL_CONTEXT *cx; + OP* nextop; - S_unwind_loop(aTHX_ "last"); + cx = S_unwind_loop(aTHX); - cx = &cxstack[cxstack_ix]; - - assert( - CxTYPE(cx) == CXt_LOOP_LAZYIV - || CxTYPE(cx) == CXt_LOOP_LAZYSV - || CxTYPE(cx) == CXt_LOOP_FOR - || CxTYPE(cx) == CXt_LOOP_PLAIN - ); - PL_stack_sp = PL_stack_base + cx->blk_loop.resetsp; + assert(CxTYPE_is_LOOP(cx)); + PL_stack_sp = PL_stack_base + + (CxTYPE(cx) == CXt_LOOP_LIST + ? cx->blk_loop.state_u.stack.basesp + : cx->blk_oldsp + ); TAINT_NOT; /* Stack values are safe: */ CX_LEAVE_SCOPE(cx); - POPLOOP(cx); /* release loop vars ... */ - POPBLOCK(cx); - cxstack_ix--; + cx_poploop(cx); /* release loop vars ... */ + cx_popblock(cx); + nextop = cx->blk_loop.my_op->op_lastop->op_next; + CX_POP(cx); - return cx->blk_loop.my_op->op_lastop->op_next; + return nextop; } PP(pp_next) { PERL_CONTEXT *cx; - S_unwind_loop(aTHX_ "next"); + /* if not a bare 'next' in the main scope, search for it */ + cx = CX_CUR(); + if (!((PL_op->op_flags & OPf_SPECIAL) && CxTYPE_is_LOOP(cx))) + cx = S_unwind_loop(aTHX); - TOPBLOCK(cx); + cx_topblock(cx); PL_curcop = cx->blk_oldcop; PERL_ASYNC_CHECK(); return (cx)->blk_loop.my_op->op_nextop; @@ -2607,20 +2557,20 @@ PP(pp_next) PP(pp_redo) { - const I32 cxix = S_unwind_loop(aTHX_ "redo"); - PERL_CONTEXT *cx; - OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop; + PERL_CONTEXT *cx = S_unwind_loop(aTHX); + OP* redo_op = cx->blk_loop.my_op->op_redoop; if (redo_op->op_type == OP_ENTER) { /* pop one less context to avoid $x being freed in while (my $x..) */ cxstack_ix++; - assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK); + cx = CX_CUR(); + assert(CxTYPE(cx) == CXt_BLOCK); redo_op = redo_op->op_next; } - TOPBLOCK(cx); - CX_LEAVE_SCOPE(cx); FREETMPS; + CX_LEAVE_SCOPE(cx); + cx_topblock(cx); PL_curcop = cx->blk_oldcop; PERL_ASYNC_CHECK(); return redo_op; @@ -2764,7 +2714,8 @@ PP(pp_goto) if (cxix < cxstack_ix) { dounwind(cxix); } - TOPBLOCK(cx); + cx = CX_CUR(); + cx_topblock(cx); SPAGAIN; /* protect @_ during save stack unwind. */ @@ -2774,9 +2725,8 @@ PP(pp_goto) assert(PL_scopestack_ix == cx->blk_oldscopesp); CX_LEAVE_SCOPE(cx); - /* partial unrolled POPSUB(): */ - if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) { + /* this is part of cx_popsub_args() */ AV* av = MUTABLE_AV(PAD_SVl(0)); assert(AvARRAY(MUTABLE_AV( PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[ @@ -2851,7 +2801,7 @@ PP(pp_goto) SP += items; if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) { /* Restore old @_ */ - POP_SAVEARRAY(); + CX_POP_SAVEARRAY(cx); } retop = cx->blk_sub.retop; @@ -2859,10 +2809,10 @@ PP(pp_goto) 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 */ + * this is a cx_popblock(), less all the stuff we already did + * for cx_topblock() earlier */ PL_curcop = cx->blk_oldcop; - cxstack_ix--; + CX_POP(cx); /* Push a mark for the start of arglist */ PUSHMARK(mark); @@ -2876,7 +2826,7 @@ PP(pp_goto) SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ - /* partial unrolled PUSHSUB(): */ + /* partial unrolled cx_pushsub(): */ cx->blk_sub.cv = cv; cx->blk_sub.olddepth = CvDEPTH(cv); @@ -2966,10 +2916,11 @@ PP(pp_goto) break; } /* else fall through */ - case CXt_LOOP_LAZYIV: - case CXt_LOOP_LAZYSV: - case CXt_LOOP_FOR: - case CXt_LOOP_PLAIN: + case CXt_LOOP_PLAIN: + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_LIST: + case CXt_LOOP_ARY: case CXt_GIVEN: case CXt_WHEN: gotoprobe = OpSIBLING(cx->blk_oldcop); @@ -3046,7 +2997,8 @@ PP(pp_goto) if (ix < 0) DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix); dounwind(ix); - TOPBLOCK(cx); + cx = CX_CUR(); + cx_topblock(cx); } /* push wanted frames */ @@ -3169,8 +3121,8 @@ S_docatch(pTHX_ OP *o) switch (ret) { case 0: assert(cxstack_ix >= 0); - assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); - cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env; + assert(CxTYPE(CX_CUR()) == CXt_EVAL); + CX_CUR()->blk_eval.cur_top_env = PL_top_env; redo_body: CALLRUNOPS(aTHX); break; @@ -3274,7 +3226,7 @@ S_try_yyparse(pTHX_ int gramtype) int ret; dJMPENV; - assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); + assert(CxTYPE(CX_CUR()) == CXt_EVAL); JMPENV_PUSH(ret); switch (ret) { case 0: @@ -3307,7 +3259,7 @@ S_try_yyparse(pTHX_ int gramtype) */ STATIC bool -S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) +S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh) { dSP; OP * const saveop = PL_op; @@ -3327,9 +3279,9 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) evalcv = MUTABLE_CV(newSV_type(SVt_PVCV)); CvEVAL_on(evalcv); - assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); - cxstack[cxstack_ix].blk_eval.cv = evalcv; - cxstack[cxstack_ix].blk_gimme = gimme; + assert(CxTYPE(CX_CUR()) == CXt_EVAL); + CX_CUR()->blk_eval.cv = evalcv; + CX_CUR()->blk_gimme = gimme; CvOUTSIDE_SEQ(evalcv) = seq; CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside)); @@ -3426,64 +3378,56 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) /* note that yyparse() may raise an exception, e.g. C, * so honour CATCH_GET and trap it here if necessary */ + + /* compile the code */ yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG); if (yystatus || PL_parser->error_count || !PL_eval_root) { + SV *namesv = NULL; /* initialise to avoid compiler warning */ PERL_CONTEXT *cx; - I32 optype; /* Used by POPEVAL. */ - SV *namesv; - SV *errsv = NULL; - - cx = NULL; - namesv = NULL; - PERL_UNUSED_VAR(optype); + SV *errsv; - /* note that if yystatus == 3, then the EVAL CX block has already - * been popped, and various vars restored */ PL_op = saveop; + /* note that if yystatus == 3, then the require/eval died during + * compilation, so the EVAL CX block has already been popped, and + * various vars restored */ if (yystatus != 3) { if (PL_eval_root) { op_free(PL_eval_root); PL_eval_root = NULL; } SP = PL_stack_base + POPMARK; /* pop original mark */ - cx = &cxstack[cxstack_ix]; + cx = CX_CUR(); CX_LEAVE_SCOPE(cx); - POPEVAL(cx); - POPBLOCK(cx); - cxstack_ix--; - namesv = cx->blk_eval.old_namesv; + cx_popeval(cx); + cx_popblock(cx); + if (in_require) + namesv = cx->blk_eval.old_namesv; + CX_POP(cx); } errsv = ERRSV; if (in_require) { - if (!cx) { - /* If cx is still NULL, it means that we didn't go in the - * POPEVAL branch. */ - cx = &cxstack[cxstack_ix]; - assert(CxTYPE(cx) == CXt_EVAL); - namesv = cx->blk_eval.old_namesv; - } - (void)hv_store(GvHVn(PL_incgv), - SvPVX_const(namesv), - SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv), - &PL_sv_undef, 0); - Perl_croak(aTHX_ "%"SVf"Compilation failed in require", - SVfARG(errsv - ? errsv - : newSVpvs_flags("Unknown error\n", SVs_TEMP))); - } - else { - if (!*(SvPV_nolen_const(errsv))) { - sv_setpvs(errsv, "Compilation error"); - } + if (yystatus == 3) { + cx = CX_CUR(); + assert(CxTYPE(cx) == CXt_EVAL); + namesv = cx->blk_eval.old_namesv; + } + S_undo_inc_then_croak(aTHX_ namesv, errsv, FALSE); + NOT_REACHED; /* NOTREACHED */ } + + if (!*(SvPV_nolen_const(errsv))) + sv_setpvs(errsv, "Compilation error"); + if (gimme != G_ARRAY) PUSHs(&PL_sv_undef); PUTBACK; return FALSE; } - else - LEAVE_with_name("evalcomp"); + + /* Compilation successful. Now clean up */ + + LEAVE_with_name("evalcomp"); CopLINE_set(&PL_compiling, 0); SAVEFREEOP(PL_eval_root); @@ -3509,8 +3453,6 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) PL_eval_start = es; } - /* compiled okay, so do it */ - CvDEPTH(evalcv) = 1; SP = PL_stack_base + POPMARK; /* pop original mark */ PL_op = saveop; /* The caller may need it. */ @@ -3520,6 +3462,7 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) return TRUE; } + STATIC PerlIO * S_check_type_and_open(pTHX_ SV *name) { @@ -3656,7 +3599,7 @@ PP(pp_require) #endif const char *tryname = NULL; SV *namesv = NULL; - const I32 gimme = GIMME_V; + const U8 gimme = GIMME_V; int filter_has_file = 0; PerlIO *tryrsfp = NULL; SV *filter_cache = NULL; @@ -3778,7 +3721,7 @@ PP(pp_require) } } - LOADING_FILE_PROBE(unixname); + PERL_DTRACE_PROBE_FILE_LOADING(unixname); /* prepare to compile file */ @@ -4101,22 +4044,20 @@ PP(pp_require) } /* switch to eval mode */ - PUSHBLOCK(cx, CXt_EVAL, SP); - PUSHEVAL(cx, name); - cx->cx_old_savestack_ix = old_savestack_ix; - cx->blk_eval.retop = PL_op->op_next; + cx = cx_pushblock(CXt_EVAL, gimme, SP, old_savestack_ix); + cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0)); SAVECOPLINE(&PL_compiling); CopLINE_set(&PL_compiling, 0); PUTBACK; - if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL)) + if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL)) op = DOCATCH(PL_eval_start); else op = PL_op->op_next; - LOADED_FILE_PROBE(unixname); + PERL_DTRACE_PROBE_FILE_LOADED(unixname); return op; } @@ -4138,7 +4079,7 @@ PP(pp_entereval) dSP; PERL_CONTEXT *cx; SV *sv; - const I32 gimme = GIMME_V; + const U8 gimme = GIMME_V; const U32 was = PL_breakable_sub_gen; char tbuf[TYPE_DIGITS(long) + 12]; bool saved_delete = FALSE; @@ -4217,10 +4158,8 @@ PP(pp_entereval) * to do the dirty work for us */ runcv = find_runcv(&seq); - PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP); - PUSHEVAL(cx, 0); - cx->cx_old_savestack_ix = old_savestack_ix; - cx->blk_eval.retop = PL_op->op_next; + cx = cx_pushblock((CXt_EVAL|CXp_REAL), gimme, SP, old_savestack_ix); + cx_pusheval(cx, PL_op->op_next, NULL); /* prepare to compile string */ @@ -4239,7 +4178,7 @@ PP(pp_entereval) PUTBACK; - if (doeval(gimme, runcv, seq, saved_hh)) { + if (doeval_compile(gimme, runcv, seq, saved_hh)) { if (was != PL_breakable_sub_gen /* Some subs defined here. */ ? PERLDB_LINE_OR_SAVESRC : PERLDB_SAVESRC_NOSUBS) { @@ -4251,7 +4190,7 @@ PP(pp_entereval) return DOCATCH(PL_eval_start); } else { /* We have already left the scope set up earlier thanks to the LEAVE - in doeval(). */ + in doeval_compile(). */ if (was != PL_breakable_sub_gen /* Some subs defined here. */ ? PERLDB_LINE_OR_SAVESRC : PERLDB_SAVESRC_INVALID) { @@ -4263,70 +4202,71 @@ PP(pp_entereval) } } + +/* also tail-called by pp_return */ + PP(pp_leaveeval) { - dSP; - SV **newsp; - I32 gimme; + SV **oldsp; + U8 gimme; PERL_CONTEXT *cx; OP *retop; - I32 optype; - SV *namesv; + SV *namesv = NULL; CV *evalcv; - /* grab this value before POPEVAL restores old PL_in_eval */ + /* grab this value before cx_popeval restores old PL_in_eval */ bool keep = cBOOL(PL_in_eval & EVAL_KEEPERR); PERL_ASYNC_CHECK(); - cx = &cxstack[cxstack_ix]; + cx = CX_CUR(); assert(CxTYPE(cx) == CXt_EVAL); - newsp = PL_stack_base + cx->blk_oldsp; + + oldsp = PL_stack_base + cx->blk_oldsp; gimme = cx->blk_gimme; - if (gimme != G_VOID) { - PUTBACK; - leave_common(newsp, newsp, gimme, SVs_TEMP, FALSE); - SPAGAIN; - } - /* the POPEVAL does a leavescope, which frees the optree associated + /* did require return a false value? */ + if ( CxOLD_OP_TYPE(cx) == OP_REQUIRE + && !(gimme == G_SCALAR + ? SvTRUE(*PL_stack_sp) + : PL_stack_sp > oldsp) + ) + namesv = cx->blk_eval.old_namesv; + + if (gimme == G_VOID) + PL_stack_sp = oldsp; + else + leave_adjust_stacks(oldsp, oldsp, gimme, 0); + + /* the cx_popeval does a leavescope, which frees the optree associated * with eval, which if it frees the nextstate associated with * PL_curcop, sets PL_curcop to NULL. Which can mess up freeing a * regex when running under 'use re Debug' because it needs PL_curcop * to get the current hints. So restore it early. */ PL_curcop = cx->blk_oldcop; + CX_LEAVE_SCOPE(cx); - POPEVAL(cx); - POPBLOCK(cx); - cxstack_ix--; - namesv = cx->blk_eval.old_namesv; + cx_popeval(cx); + cx_popblock(cx); retop = cx->blk_eval.retop; evalcv = cx->blk_eval.cv; - + CX_POP(cx); #ifdef DEBUGGING assert(CvDEPTH(evalcv) == 1); #endif CvDEPTH(evalcv) = 0; - if (optype == OP_REQUIRE && - !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp)) - { + if (namesv) { /* require returned false */ /* 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); - Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv)); + S_undo_inc_then_croak(aTHX_ namesv, NULL, TRUE); NOT_REACHED; /* NOTREACHED */ - /* die_unwind() did LEAVE, or we won't be here */ - } - else { - if (!keep) - CLEAR_ERRSV(); } - RETURNOP(retop); + if (!keep) + CLEAR_ERRSV(); + + return retop; } /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it @@ -4335,27 +4275,25 @@ void Perl_delete_eval_scope(pTHX) { PERL_CONTEXT *cx; - I32 optype; - cx = &cxstack[cxstack_ix]; + cx = CX_CUR(); CX_LEAVE_SCOPE(cx); - POPEVAL(cx); - POPBLOCK(cx); - cxstack_ix--; - PERL_UNUSED_VAR(optype); + cx_popeval(cx); + cx_popblock(cx); + CX_POP(cx); } /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was also needed by Perl_fold_constants. */ -PERL_CONTEXT * -Perl_create_eval_scope(pTHX_ U32 flags) +void +Perl_create_eval_scope(pTHX_ OP *retop, U32 flags) { PERL_CONTEXT *cx; - const I32 gimme = GIMME_V; + const U8 gimme = GIMME_V; - PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); - PUSHEVAL(cx, 0); - cx->cx_old_savestack_ix = PL_savestack_ix; + cx = cx_pushblock((CXt_EVAL|CXp_TRYBLOCK), gimme, + PL_stack_sp, PL_savestack_ix); + cx_pusheval(cx, retop, NULL); PL_in_eval = EVAL_INEVAL; if (flags & G_KEEPERR) @@ -4365,41 +4303,40 @@ Perl_create_eval_scope(pTHX_ U32 flags) if (flags & G_FAKINGEVAL) { PL_eval_root = PL_op; /* Only needed so that goto works right. */ } - return cx; } PP(pp_entertry) { - PERL_CONTEXT * const cx = create_eval_scope(0); - cx->blk_eval.retop = cLOGOP->op_other->op_next; + create_eval_scope(cLOGOP->op_other->op_next, 0); return DOCATCH(PL_op->op_next); } + +/* also tail-called by pp_return */ + PP(pp_leavetry) { - SV **newsp; - I32 gimme; + SV **oldsp; + U8 gimme; PERL_CONTEXT *cx; - I32 optype; OP *retop; PERL_ASYNC_CHECK(); - cx = &cxstack[cxstack_ix]; + cx = CX_CUR(); assert(CxTYPE(cx) == CXt_EVAL); - newsp = PL_stack_base + cx->blk_oldsp; + oldsp = PL_stack_base + cx->blk_oldsp; gimme = cx->blk_gimme; if (gimme == G_VOID) - PL_stack_sp = newsp; + PL_stack_sp = oldsp; else - leave_common(newsp, newsp, gimme, SVs_PADTMP|SVs_TEMP, FALSE); + leave_adjust_stacks(oldsp, oldsp, gimme, 1); CX_LEAVE_SCOPE(cx); - POPEVAL(cx); - POPBLOCK(cx); - cxstack_ix--; + cx_popeval(cx); + cx_popblock(cx); retop = cx->blk_eval.retop; - PERL_UNUSED_VAR(optype); + CX_POP(cx); CLEAR_ERRSV(); return retop; @@ -4409,15 +4346,15 @@ PP(pp_entergiven) { dSP; PERL_CONTEXT *cx; - const I32 gimme = GIMME_V; + const U8 gimme = GIMME_V; SV *origsv = DEFSV; SV *newsv = 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, origsv); + cx = cx_pushblock(CXt_GIVEN, gimme, SP, PL_savestack_ix); + cx_pushgiven(cx, origsv); RETURN; } @@ -4425,24 +4362,24 @@ PP(pp_entergiven) PP(pp_leavegiven) { PERL_CONTEXT *cx; - I32 gimme; - SV **newsp; + U8 gimme; + SV **oldsp; PERL_UNUSED_CONTEXT; - cx = &cxstack[cxstack_ix]; + cx = CX_CUR(); assert(CxTYPE(cx) == CXt_GIVEN); - newsp = PL_stack_base + cx->blk_oldsp; + oldsp = PL_stack_base + cx->blk_oldsp; gimme = cx->blk_gimme; if (gimme == G_VOID) - PL_stack_sp = newsp; + PL_stack_sp = oldsp; else - leave_common(newsp, newsp, gimme, SVs_PADTMP|SVs_TEMP, FALSE); + leave_adjust_stacks(oldsp, oldsp, gimme, 1); CX_LEAVE_SCOPE(cx); - POPGIVEN(cx); - POPBLOCK(cx); - cxstack_ix--; + cx_popgiven(cx); + cx_popblock(cx); + CX_POP(cx); return NORMAL; } @@ -4985,7 +4922,7 @@ PP(pp_enterwhen) { dSP; PERL_CONTEXT *cx; - const I32 gimme = GIMME_V; + const U8 gimme = GIMME_V; /* This is essentially an optimization: if the match fails, we don't want to push a context and then @@ -4993,11 +4930,11 @@ PP(pp_enterwhen) to the op that follows the leavewhen. RETURNOP calls PUTBACK which restores the stack pointer after the POPs. */ - if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs)) + if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs)) RETURNOP(cLOGOP->op_other->op_next); - PUSHBLOCK(cx, CXt_WHEN, SP); - PUSHWHEN(cx); + cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix); + cx_pushwhen(cx); RETURN; } @@ -5006,10 +4943,10 @@ PP(pp_leavewhen) { I32 cxix; PERL_CONTEXT *cx; - I32 gimme; - SV **newsp; + U8 gimme; + SV **oldsp; - cx = &cxstack[cxstack_ix]; + cx = CX_CUR(); assert(CxTYPE(cx) == CXt_WHEN); gimme = cx->blk_gimme; @@ -5019,11 +4956,12 @@ PP(pp_leavewhen) DIE(aTHX_ "Can't \"%s\" outside a topicalizer", PL_op->op_flags & OPf_SPECIAL ? "default" : "when"); - newsp = PL_stack_base + cx->blk_oldsp; + oldsp = PL_stack_base + cx->blk_oldsp; if (gimme == G_VOID) - PL_stack_sp = newsp; + PL_stack_sp = oldsp; else - leave_common(newsp, newsp, gimme, SVs_PADTMP|SVs_TEMP, FALSE); + leave_adjust_stacks(oldsp, oldsp, gimme, 1); + /* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */ assert(cxix < cxstack_ix); dounwind(cxix); @@ -5033,7 +4971,8 @@ PP(pp_leavewhen) if (CxFOREACH(cx)) { /* emulate pp_next. Note that any stack(s) cleanup will be * done by the pp_unstack which op_nextop should point to */ - TOPBLOCK(cx); + cx = CX_CUR(); + cx_topblock(cx); PL_curcop = cx->blk_oldcop; return cx->blk_loop.my_op->op_nextop; } @@ -5048,6 +4987,7 @@ PP(pp_continue) { I32 cxix; PERL_CONTEXT *cx; + OP *nextop; cxix = dopoptowhen(cxstack_ix); if (cxix < 0) @@ -5056,15 +4996,16 @@ PP(pp_continue) if (cxix < cxstack_ix) dounwind(cxix); - cx = &cxstack[cxstack_ix]; + cx = CX_CUR(); assert(CxTYPE(cx) == CXt_WHEN); PL_stack_sp = PL_stack_base + cx->blk_oldsp; CX_LEAVE_SCOPE(cx); - POPWHEN(cx); - POPBLOCK(cx); - cxstack_ix--; + cx_popwhen(cx); + cx_popblock(cx); + nextop = cx->blk_givwhen.leave_op->op_next; + CX_POP(cx); - return cx->blk_givwhen.leave_op->op_next; + return nextop; } PP(pp_break) @@ -5084,7 +5025,8 @@ PP(pp_break) dounwind(cxix); /* Restore the sp at the time we entered the given block */ - TOPBLOCK(cx); + cx = CX_CUR(); + PL_stack_sp = PL_stack_base + cx->blk_oldsp; return cx->blk_givwhen.leave_op; }