X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/41f96e1a89a5842483b2a12424693a876f5b57c0..e992140c0e6f8ddfe08a88cc28a1d24149061d74:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index a89688a..74c4f58 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -285,8 +285,11 @@ PP(pp_substcont) /* PL_tainted must be correctly set for this mg_set */ SvSETMAGIC(TARG); TAINT_NOT; - LEAVE_SCOPE(cx->sb_oldsave); + + CX_LEAVE_SCOPE(cx); POPSUBST(cx); + CX_POP(cx); + PERL_ASYNC_CHECK(); RETURNOP(pm->op_next); NOT_REACHED; /* NOTREACHED */ @@ -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", @@ -1291,13 +1295,14 @@ S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags) /* diag_listed_as: Exiting subroutine via %s */ Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", context_name[CxTYPE(cx)], OP_NAME(PL_op)); - if (CxTYPE(cx) == CXt_NULL) + 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; @@ -1438,13 +1443,14 @@ S_dopoptoloop(pTHX_ I32 startingblock) /* diag_listed_as: Exiting subroutine via %s */ Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", context_name[CxTYPE(cx)], OP_NAME(PL_op)); - if ((CxTYPE(cx)) == CXt_NULL) + 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,8 +1458,10 @@ S_dopoptoloop(pTHX_ I32 startingblock) return i; } +/* find the next GIVEN or FOR loop context block */ + STATIC I32 -S_dopoptogiven(pTHX_ I32 startingblock) +S_dopoptogivenfor(pTHX_ I32 startingblock) { I32 i; for (i = startingblock; i >= 0; i--) { @@ -1462,16 +1470,17 @@ S_dopoptogiven(pTHX_ I32 startingblock) default: continue; case CXt_GIVEN: - DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i)); + 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)) { - DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i)); + 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; } } @@ -1499,34 +1508,44 @@ S_dopoptowhen(pTHX_ I32 startingblock) void Perl_dounwind(pTHX_ I32 cxix) { - I32 optype; - if (!PL_curstackinfo) /* can happen if die during thread cloning */ return; while (cxstack_ix > cxix) { - SV *sv; PERL_CONTEXT *cx = &cxstack[cxstack_ix]; 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: POPSUBST(cx); - continue; /* not break */ + break; case CXt_SUB: - POPSUB(cx,sv); - LEAVESUB(sv); + POPSUB(cx); break; case CXt_EVAL: POPEVAL(cx); break; + case CXt_BLOCK: + POPBASICBLK(cx); + 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: POPLOOP(cx); break; + case CXt_WHEN: + POPWHEN(cx); + break; + case CXt_GIVEN: + POPGIVEN(cx); + break; case CXt_NULL: + /* there isn't a POPNULL ! */ break; case CXt_FORMAT: POPFORMAT(cx); @@ -1534,7 +1553,6 @@ Perl_dounwind(pTHX_ I32 cxix) } cxstack_ix--; } - PERL_UNUSED_VAR(optype); } void @@ -1558,6 +1576,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) { @@ -1567,7 +1613,6 @@ Perl_die_unwind(pTHX_ SV *msv) if (in_eval) { I32 cxix; - I32 gimme; /* * Historically, perl used to set ERRSV ($@) early in the die @@ -1616,55 +1661,44 @@ Perl_die_unwind(pTHX_ SV *msv) } if (cxix >= 0) { - I32 optype; - SV *namesv; + SV *namesv = NULL; PERL_CONTEXT *cx; SV **newsp; -#ifdef DEBUGGING - COP *oldcop; -#endif + I32 gimme; JMPENV *restartjmpenv; OP *restartop; if (cxix < cxstack_ix) dounwind(cxix); - POPBLOCK(cx,PL_curpm); - 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); - } - POPEVAL(cx); - namesv = cx->blk_eval.old_namesv; -#ifdef DEBUGGING - oldcop = cx->blk_oldcop; -#endif - restartjmpenv = cx->blk_eval.cur_top_env; - restartop = cx->blk_eval.retop; + cx = &cxstack[cxstack_ix]; + assert(CxTYPE(cx) == CXt_EVAL); + /* return false to the caller of eval */ + newsp = PL_stack_base + cx->blk_oldsp; + gimme = cx->blk_gimme; if (gimme == G_SCALAR) *++newsp = &PL_sv_undef; PL_stack_sp = newsp; - LEAVE; + CX_LEAVE_SCOPE(cx); + POPEVAL(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; @@ -1864,7 +1898,10 @@ PP(pp_caller) 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); @@ -1938,7 +1975,6 @@ PP(pp_dbstate) dSP; PERL_CONTEXT *cx; const I32 gimme = G_ARRAY; - U8 hasargs; GV * const gv = PL_DBgv; CV * cv = NULL; @@ -1952,16 +1988,12 @@ PP(pp_dbstate) /* 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; @@ -1969,9 +2001,15 @@ 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->blk_oldsaveix = PL_savestack_ix; + + SAVEI32(PL_debug); + PL_debug = 0; + SAVESTACK_POS(); CvDEPTH(cv)++; if (CvDEPTH(cv) >= 2) { PERL_STACK_OVERFLOW_CHECK(); @@ -1986,46 +2024,43 @@ PP(pp_dbstate) } /* 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..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 SV ** -S_leave_common(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, +STATIC void +S_leave_common(pTHX_ SV **newsp, SV **mark, I32 gimme, U32 flags, bool lvalue) { - bool padtmp = 0; + dSP; 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)) : sv_mortalcopy(*SP); else { - /* MEXTEND() only updates MARK, so reuse it instead of newsp. */ - MARK = newsp; - MEXTEND(MARK, 1); - *++MARK = &PL_sv_undef; - return MARK; + 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) || (padtmp && SvPADTMP(*MARK))) + if (SvFLAGS(*MARK) & flags) *++newsp = *MARK; else { *++newsp = lvalue @@ -2038,47 +2073,49 @@ S_leave_common(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, * point with SP == newsp. */ } - return newsp; + PL_stack_sp = newsp; } + PP(pp_enter) { dSP; PERL_CONTEXT *cx; I32 gimme = GIMME_V; - ENTER_with_name("block"); - - SAVETMPS; PUSHBLOCK(cx, CXt_BLOCK, SP); + PUSHBASICBLK(cx); RETURN; } PP(pp_leave) { - dSP; PERL_CONTEXT *cx; SV **newsp; - PMOP *newpm; I32 gimme; - if (PL_op->op_flags & OPf_SPECIAL) { - cx = &cxstack[cxstack_ix]; - cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */ - } + cx = &cxstack[cxstack_ix]; + assert(CxTYPE(cx) == CXt_BLOCK); - POPBLOCK(cx,newpm); + if (PL_op->op_flags & OPf_SPECIAL) + cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */ - gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR); + newsp = PL_stack_base + cx->blk_oldsp; + gimme = cx->blk_gimme; - SP = 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 */ + if (gimme == G_VOID) + PL_stack_sp = newsp; + else + leave_common(newsp, newsp, gimme, SVs_PADTMP|SVs_TEMP, + PL_op->op_private & OPpLVALUE); - LEAVE_with_name("block"); + CX_LEAVE_SCOPE(cx); + POPBASICBLK(cx); + POPBLOCK(cx); + CX_POP(cx); - RETURN; + return NORMAL; } static bool @@ -2108,79 +2145,68 @@ PP(pp_enteriter) dSP; dMARK; PERL_CONTEXT *cx; const I32 gimme = GIMME_V; - void *itervar; /* location of the iteration variable */ - U8 cxtype = CXt_LOOP_FOR; - - ENTER_with_name("loop1"); - SAVETMPS; + void *itervarp; /* GV or pad slot of the iteration variable */ + SV *itersave; /* the old var in the iterator var slot */ + U8 cxflags = 0; 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; + SvREFCNT_inc_simple_void_NN(itersave); + cxflags = 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); + cxflags = 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; + cxflags = CXp_FOR_LVREF; + } } if (PL_op->op_private & OPpITER_DEF) - cxtype |= CXp_FOR_DEF; + cxflags |= CXp_FOR_DEF; - ENTER_with_name("loop2"); - - PUSHBLOCK(cx, cxtype, SP); - PUSHLOOP_FOR(cx, itervar, MARK); + PUSHBLOCK(cx, cxflags, MARK); + PUSHLOOP_FOR(cx, itervarp, itersave); if (PL_op->op_flags & OPf_STACKED) { SV *maybe_ary = POPs; if (SvTYPE(maybe_ary) != SVt_PVAV) { 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); @@ -2197,6 +2223,7 @@ PP(pp_enteriter) } } else /* SvTYPE(maybe_ary) == SVt_PVAV */ { + cx->cx_type |= CXt_LOOP_ARY; cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary); SvREFCNT_inc(maybe_ary); cx->blk_loop.state_u.ary.ix = @@ -2204,15 +2231,19 @@ PP(pp_enteriter) 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; @@ -2224,39 +2255,37 @@ PP(pp_enterloop) PERL_CONTEXT *cx; const I32 gimme = GIMME_V; - ENTER_with_name("loop1"); - SAVETMPS; - ENTER_with_name("loop2"); - PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP); - PUSHLOOP_PLAIN(cx, SP); + PUSHLOOP_PLAIN(cx); RETURN; } PP(pp_leaveloop) { - dSP; PERL_CONTEXT *cx; I32 gimme; SV **newsp; - PMOP *newpm; SV **mark; - POPBLOCK(cx,newpm); + cx = &cxstack[cxstack_ix]; assert(CxTYPE_is_LOOP(cx)); - mark = newsp; - newsp = PL_stack_base + cx->blk_loop.resetsp; + mark = PL_stack_base + cx->blk_oldsp; + newsp = CxTYPE(cx) == CXt_LOOP_LIST + ? PL_stack_base + cx->blk_loop.state_u.stack.basesp + : mark; + gimme = cx->blk_gimme; - SP = leave_common(newsp, SP, MARK, gimme, 0, + if (gimme == G_VOID) + PL_stack_sp = newsp; + else + leave_common(newsp, MARK, gimme, SVs_PADTMP|SVs_TEMP, PL_op->op_private & OPpLVALUE); - PUTBACK; + CX_LEAVE_SCOPE(cx); POPLOOP(cx); /* Stack values are safe: release loop vars ... */ - PL_curpm = newpm; /* ... and pop $1 et al */ - - LEAVE_with_name("loop2"); - LEAVE_with_name("loop1"); + POPBLOCK(cx); + CX_POP(cx); return NORMAL; } @@ -2275,22 +2304,24 @@ PP(pp_leavesublv) dSP; SV **newsp; SV **mark; - PMOP *newpm; I32 gimme; PERL_CONTEXT *cx; - SV *sv; bool ref; const char *what = NULL; + OP *retop; - if (CxMULTICALL(&cxstack[cxstack_ix])) { + cx = &cxstack[cxstack_ix]; + assert(CxTYPE(cx) == CXt_SUB); + + if (CxMULTICALL(cx)) { /* 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 */ + newsp = PL_stack_base + cx->blk_oldsp; + gimme = cx->blk_gimme; TAINT_NOT; mark = newsp + 1; @@ -2298,9 +2329,7 @@ PP(pp_leavesublv) 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 == SP); if ((SvPADTMP(TOPs) || SvREADONLY(TOPs)) && !SvSMAGICAL(TOPs)) { what = @@ -2314,11 +2343,6 @@ PP(pp_leavesublv) what = "undef"; } croak: - LEAVE; - POPSUB(cx,sv); - cxstack_ix--; - PL_curpm = newpm; - LEAVESUB(sv); Perl_croak(aTHX_ "Can't return %s from lvalue subroutine", what ); @@ -2385,13 +2409,13 @@ PP(pp_leavesublv) } PUTBACK; - LEAVE; - POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ - cxstack_ix--; - PL_curpm = newpm; /* ... and pop $1 et al */ - LEAVESUB(sv); + CX_LEAVE_SCOPE(cx); + POPSUB(cx); /* Stack values are safe: release CV and @_ ... */ + POPBLOCK(cx); + retop = cx->blk_sub.retop; + CX_POP(cx); - return cx->blk_sub.retop; + return retop; } @@ -2399,55 +2423,92 @@ PP(pp_return) { 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 (!( PL_curstackinfo->si_type == PERLSI_SORT + || ( PL_curstackinfo->si_type == PERLSI_MULTICALL + && (cxstack[0].cx_type & CXp_SUB_RE_FAKE)) + ) + ) + DIE(aTHX_ "Can't return outside a subroutine"); + /* We must be in: + * a sort block, which is a CXt_NULL not a CXt_SUB; + * or a /(?{...})/ block. + * Handle specially. */ + assert(CxTYPE(&cxstack[0]) == CXt_NULL + || ( CxTYPE(&cxstack[0]) == CXt_SUB + && (cxstack[0].cx_type & CXp_SUB_RE_FAKE))); + 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]; + PUTBACK; + leave_common(PL_stack_base + cx->blk_oldsp, MARK, + cx->blk_gimme, SVs_TEMP|SVs_PADTMP, TRUE); + 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 + * 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 */ @@ -2510,50 +2571,38 @@ S_unwind_loop(pTHX_ const char * const opname) PP(pp_last) { PERL_CONTEXT *cx; - I32 gimme; - OP *nextop = NULL; - SV **newsp; - PMOP *newpm; + OP* nextop; S_unwind_loop(aTHX_ "last"); - POPBLOCK(cx,newpm); - cxstack_ix++; /* temporarily protect top context */ - assert( - CxTYPE(cx) == CXt_LOOP_LAZYIV - || CxTYPE(cx) == CXt_LOOP_LAZYSV - || CxTYPE(cx) == CXt_LOOP_FOR - || CxTYPE(cx) == CXt_LOOP_PLAIN - ); - newsp = PL_stack_base + cx->blk_loop.resetsp; - nextop = cx->blk_loop.my_op->op_lastop->op_next; + cx = &cxstack[cxstack_ix]; + + 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; - PL_stack_sp = newsp; - LEAVE; - cxstack_ix--; /* Stack values are safe: */ + CX_LEAVE_SCOPE(cx); POPLOOP(cx); /* release loop vars ... */ - LEAVE; - PL_curpm = newpm; /* ... and pop $1 et al */ + POPBLOCK(cx); + nextop = cx->blk_loop.my_op->op_lastop->op_next; + CX_POP(cx); - PERL_UNUSED_VAR(gimme); return nextop; } PP(pp_next) { PERL_CONTEXT *cx; - const I32 inner = PL_scopestack_ix; S_unwind_loop(aTHX_ "next"); - /* clear off anything above the scope we're re-entering, but - * save the rest until after a possible continue block */ TOPBLOCK(cx); - if (PL_scopestack_ix < inner) - leave_scope(PL_scopestack[PL_scopestack_ix]); PL_curcop = cx->blk_oldcop; PERL_ASYNC_CHECK(); return (cx)->blk_loop.my_op->op_nextop; @@ -2563,7 +2612,6 @@ PP(pp_redo) { const I32 cxix = S_unwind_loop(aTHX_ "redo"); PERL_CONTEXT *cx; - I32 oldsave; OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop; if (redo_op->op_type == OP_ENTER) { @@ -2574,8 +2622,7 @@ PP(pp_redo) } TOPBLOCK(cx); - oldsave = PL_scopestack[PL_scopestack_ix - 1]; - LEAVE_SCOPE(oldsave); + CX_LEAVE_SCOPE(cx); FREETMPS; PL_curcop = cx->blk_oldcop; PERL_ASYNC_CHECK(); @@ -2669,28 +2716,26 @@ PP(pp_goto) 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)); @@ -2698,22 +2743,13 @@ PP(pp_goto) 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"); @@ -2722,41 +2758,53 @@ PP(pp_goto) 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)"); - } - /* partial unrolled POPSUB(): */ + /* 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; + + /* protect @_ during save stack unwind. */ + if (arg) + SvREFCNT_inc_NN(sv_2mortal(MUTABLE_SV(arg))); + + assert(PL_scopestack_ix == cx->blk_oldscopesp); + CX_LEAVE_SCOPE(cx); 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); - } + /* this is POPSUB_ARGS() with minor variations */ + 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); - - assert(PL_scopestack_ix == cx->blk_oldscopesp); - oldsave = PL_scopestack[cx->blk_oldscopesp - 1]; - LEAVE_SCOPE(oldsave); - PL_comppad = cx->blk_sub.prevcomppad; - PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL; + /* 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); @@ -2772,17 +2820,14 @@ PP(pp_goto) } /* Now do some callish stuff. */ - SAVETMPS; - SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ if (CvISXSUB(cv)) { - SV **newsp; - I32 gimme; const SSize_t items = arg ? AvFILL(arg) + 1 : 0; const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0; SV** mark; - 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) { @@ -2806,17 +2851,21 @@ PP(pp_goto) } } 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; + CX_POP(cx); + /* Push a mark for the start of arglist */ PUSHMARK(mark); PUTBACK; @@ -2827,6 +2876,8 @@ PP(pp_goto) else { PADLIST * const padlist = CvPADLIST(cv); + SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ + /* partial unrolled PUSHSUB(): */ cx->blk_sub.cv = cv; @@ -2840,30 +2891,29 @@ PP(pp_goto) pad_push(padlist, CvDEPTH(cv)); } PL_curcop = cx->blk_oldcop; - cx->blk_sub.prevcomppad = PL_comppad; PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); if (CxHASARGS(cx)) { - /* 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) { @@ -2918,10 +2968,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); @@ -2995,14 +3046,10 @@ PP(pp_goto) /* pop unwanted frames */ if (ix < cxstack_ix) { - I32 oldsave; - if (ix < 0) DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix); dounwind(ix); TOPBLOCK(cx); - oldsave = PL_scopestack[PL_scopestack_ix]; - LEAVE_SCOPE(oldsave); } /* push wanted frames */ @@ -3263,7 +3310,7 @@ S_try_yyparse(pTHX_ int gramtype) */ STATIC bool -S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) +S_doeval_compile(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) { dSP; OP * const saveop = PL_op; @@ -3382,65 +3429,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 **newsp; /* Used by POPBLOCK. */ + SV *namesv = NULL; /* initialise to avoid compiler warning */ PERL_CONTEXT *cx; - I32 optype; /* Used by POPEVAL. */ - SV *namesv; - SV *errsv = NULL; + SV *errsv; - cx = NULL; - namesv = NULL; - PERL_UNUSED_VAR(newsp); - PERL_UNUSED_VAR(optype); - - /* 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 */ - POPBLOCK(cx,PL_curpm); + cx = &cxstack[cxstack_ix]; + CX_LEAVE_SCOPE(cx); 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(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 = &cxstack[cxstack_ix]; + 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); @@ -3466,8 +3504,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. */ @@ -3477,6 +3513,7 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) return TRUE; } + STATIC PerlIO * S_check_type_and_open(pTHX_ SV *name) { @@ -3623,6 +3660,7 @@ PP(pp_require) OP *op; int saved_errno; bool path_searchable; + I32 old_savestack_ix; sv = POPs; SvGETMAGIC(sv); @@ -4037,8 +4075,7 @@ PP(pp_require) 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); @@ -4060,6 +4097,7 @@ PP(pp_require) /* switch to eval mode */ PUSHBLOCK(cx, CXt_EVAL, SP); PUSHEVAL(cx, name); + cx->blk_oldsaveix = old_savestack_ix; cx->blk_eval.retop = PL_op->op_next; SAVECOPLINE(&PL_compiling); @@ -4067,7 +4105,7 @@ PP(pp_require) 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; @@ -4104,6 +4142,7 @@ PP(pp_entereval) 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)); @@ -4141,13 +4180,13 @@ PP(pp_entereval) 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 */ @@ -4174,6 +4213,7 @@ PP(pp_entereval) PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP); PUSHEVAL(cx, 0); + cx->blk_oldsaveix = old_savestack_ix; cx->blk_eval.retop = PL_op->op_next; /* prepare to compile string */ @@ -4193,7 +4233,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) { @@ -4205,7 +4245,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) { @@ -4219,53 +4259,66 @@ PP(pp_entereval) PP(pp_leaveeval) { - dSP; SV **newsp; - PMOP *newpm; I32 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 */ bool keep = cBOOL(PL_in_eval & EVAL_KEEPERR); PERL_ASYNC_CHECK(); - POPBLOCK(cx,newpm); + + cx = &cxstack[cxstack_ix]; + assert(CxTYPE(cx) == CXt_EVAL); + + newsp = PL_stack_base + cx->blk_oldsp; + gimme = cx->blk_gimme; + + /* did require return a false value? */ + if ( CxOLD_OP_TYPE(cx) == OP_REQUIRE + && !(gimme == G_SCALAR + ? SvTRUE(*PL_stack_sp) + : PL_stack_sp > newsp) + ) + namesv = cx->blk_eval.old_namesv; + + if (gimme == G_VOID) + PL_stack_sp = newsp; + else + leave_common(newsp, newsp, gimme, SVs_TEMP, FALSE); + + /* the 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); - namesv = cx->blk_eval.old_namesv; + POPBLOCK(cx); retop = cx->blk_eval.retop; evalcv = cx->blk_eval.cv; - - SP = leave_common((gimme == G_VOID) ? SP : newsp, SP, newsp, - gimme, SVs_TEMP, FALSE); - PL_curpm = newpm; /* Don't pop $1 et al till now */ + 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 { - LEAVE_with_name("eval"); - 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 @@ -4273,19 +4326,13 @@ PP(pp_leaveeval) void Perl_delete_eval_scope(pTHX) { - SV **newsp; - PMOP *newpm; - I32 gimme; PERL_CONTEXT *cx; - I32 optype; - POPBLOCK(cx,newpm); + cx = &cxstack[cxstack_ix]; + CX_LEAVE_SCOPE(cx); POPEVAL(cx); - PL_curpm = newpm; - LEAVE_with_name("eval_scope"); - PERL_UNUSED_VAR(newsp); - PERL_UNUSED_VAR(gimme); - PERL_UNUSED_VAR(optype); + POPBLOCK(cx); + CX_POP(cx); } /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was @@ -4296,11 +4343,9 @@ Perl_create_eval_scope(pTHX_ U32 flags) 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->blk_oldsaveix = PL_savestack_ix; PL_in_eval = EVAL_INEVAL; if (flags & G_KEEPERR) @@ -4322,27 +4367,30 @@ PP(pp_entertry) PP(pp_leavetry) { - dSP; SV **newsp; - PMOP *newpm; 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, - SVs_PADTMP|SVs_TEMP, FALSE); - PL_curpm = newpm; /* Don't pop $1 et al till now */ + cx = &cxstack[cxstack_ix]; + assert(CxTYPE(cx) == CXt_EVAL); + newsp = PL_stack_base + cx->blk_oldsp; + gimme = cx->blk_gimme; + + if (gimme == G_VOID) + PL_stack_sp = newsp; + else + leave_common(newsp, newsp, gimme, SVs_PADTMP|SVs_TEMP, FALSE); + CX_LEAVE_SCOPE(cx); + POPEVAL(cx); + POPBLOCK(cx); + retop = cx->blk_eval.retop; + CX_POP(cx); - LEAVE_with_name("eval_scope"); CLEAR_ERRSV(); - RETURNOP(retop); + return retop; } PP(pp_entergiven) @@ -4350,38 +4398,41 @@ PP(pp_entergiven) 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; } PP(pp_leavegiven) { - dSP; PERL_CONTEXT *cx; I32 gimme; SV **newsp; - PMOP *newpm; PERL_UNUSED_CONTEXT; - POPBLOCK(cx,newpm); + cx = &cxstack[cxstack_ix]; assert(CxTYPE(cx) == CXt_GIVEN); + newsp = PL_stack_base + cx->blk_oldsp; + gimme = cx->blk_gimme; + + if (gimme == G_VOID) + PL_stack_sp = newsp; + else + leave_common(newsp, newsp, gimme, SVs_PADTMP|SVs_TEMP, FALSE); - SP = leave_common(newsp, SP, newsp, gimme, - SVs_PADTMP|SVs_TEMP, FALSE); - PL_curpm = newpm; /* Don't pop $1 et al till now */ + CX_LEAVE_SCOPE(cx); + POPGIVEN(cx); + POPBLOCK(cx); + CX_POP(cx); - LEAVE_with_name("given"); - RETURN; + return NORMAL; } /* Helper routines used by pp_smartmatch */ @@ -4933,9 +4984,6 @@ PP(pp_enterwhen) if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs)) RETURNOP(cLOGOP->op_other->op_next); - ENTER_with_name("when"); - SAVETMPS; - PUSHBLOCK(cx, CXt_WHEN, SP); PUSHWHEN(cx); @@ -4944,61 +4992,51 @@ PP(pp_enterwhen) PP(pp_leavewhen) { - dSP; I32 cxix; PERL_CONTEXT *cx; I32 gimme; SV **newsp; - PMOP *newpm; - cxix = dopoptogiven(cxstack_ix); + cx = &cxstack[cxstack_ix]; + assert(CxTYPE(cx) == CXt_WHEN); + gimme = cx->blk_gimme; + + cxix = dopoptogivenfor(cxstack_ix); if (cxix < 0) /* diag_listed_as: Can't "when" outside a topicalizer */ DIE(aTHX_ "Can't \"%s\" outside a topicalizer", PL_op->op_flags & OPf_SPECIAL ? "default" : "when"); - POPBLOCK(cx,newpm); - assert(CxTYPE(cx) == CXt_WHEN); - - SP = leave_common(newsp, SP, newsp, gimme, - SVs_PADTMP|SVs_TEMP, FALSE); - PL_curpm = newpm; /* pop $1 et al */ - - LEAVE_with_name("when"); - - if (cxix < cxstack_ix) - dounwind(cxix); + newsp = PL_stack_base + cx->blk_oldsp; + if (gimme == G_VOID) + PL_stack_sp = newsp; + else + leave_common(newsp, newsp, gimme, SVs_PADTMP|SVs_TEMP, FALSE); + /* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */ + assert(cxix < cxstack_ix); + dounwind(cxix); cx = &cxstack[cxix]; if (CxFOREACH(cx)) { - /* clear off anything above the scope we're re-entering */ - I32 inner = PL_scopestack_ix; - + /* emulate pp_next. Note that any stack(s) cleanup will be + * done by the pp_unstack which op_nextop should point to */ TOPBLOCK(cx); - if (PL_scopestack_ix < inner) - leave_scope(PL_scopestack[PL_scopestack_ix]); PL_curcop = cx->blk_oldcop; - - PERL_ASYNC_CHECK(); return cx->blk_loop.my_op->op_nextop; } else { PERL_ASYNC_CHECK(); - RETURNOP(cx->blk_givwhen.leave_op); + assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN); + return cx->blk_givwhen.leave_op; } } PP(pp_continue) { - dSP; I32 cxix; PERL_CONTEXT *cx; - I32 gimme; - SV **newsp; - PMOP *newpm; - - PERL_UNUSED_VAR(gimme); + OP *nextop; cxix = dopoptowhen(cxstack_ix); if (cxix < 0) @@ -5007,14 +5045,16 @@ PP(pp_continue) if (cxix < cxstack_ix) dounwind(cxix); - POPBLOCK(cx,newpm); + cx = &cxstack[cxstack_ix]; assert(CxTYPE(cx) == CXt_WHEN); + PL_stack_sp = PL_stack_base + cx->blk_oldsp; + CX_LEAVE_SCOPE(cx); + POPWHEN(cx); + POPBLOCK(cx); + nextop = cx->blk_givwhen.leave_op->op_next; + CX_POP(cx); - SP = newsp; - PL_curpm = newpm; /* pop $1 et al */ - - LEAVE_with_name("when"); - RETURNOP(cx->blk_givwhen.leave_op->op_next); + return nextop; } PP(pp_break) @@ -5022,7 +5062,7 @@ PP(pp_break) I32 cxix; PERL_CONTEXT *cx; - cxix = dopoptogiven(cxstack_ix); + cxix = dopoptogivenfor(cxstack_ix); if (cxix < 0) DIE(aTHX_ "Can't \"break\" outside a given block");