X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/f5319de94d4a51ecd2324744e9fdac7c11804ca5..b405d38bc792991fe2bdb47a1503569aba7d5db5:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index 518b755..8478918 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; - LEAVE_SCOPE(cx->sb_oldsave); - POPSUBST(cx); + + CX_LEAVE_SCOPE(cx); + 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 (with implicit $_) 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; } } @@ -1496,55 +1505,66 @@ 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) { - SV *sv; - 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: - POPSUBST(cx); - continue; /* not break */ + CX_POPSUBST(cx); + break; case CXt_SUB: - POPSUB(cx,sv); - LEAVESUB(sv); + CX_POPSUB(cx); break; case CXt_EVAL: - POPEVAL(cx); - /* FALLTHROUGH */ + CX_POPEVAL(cx); + break; case CXt_BLOCK: - LEAVE_SCOPE(cx->cx_u.cx_blk.blku_old_savestack_ix); - PL_tmps_floor = cx->cx_u.cx_blk.blku_old_tmpsfloor; + CX_POPBASICBLK(cx); break; + case CXt_LOOP_PLAIN: case CXt_LOOP_LAZYIV: case CXt_LOOP_LAZYSV: - case CXt_LOOP_FOR: - case CXt_LOOP_PLAIN: - POPLOOP(cx); + case CXt_LOOP_LIST: + case CXt_LOOP_ARY: + CX_POPLOOP(cx); break; case CXt_WHEN: - POPWHEN(cx); + CX_POPWHEN(cx); break; case CXt_GIVEN: - POPGIVEN(cx); + CX_POPGIVEN(cx); break; case CXt_NULL: + /* there isn't a CX_POPNULL ! */ break; case CXt_FORMAT: - POPFORMAT(cx); + CX_POPFORMAT(cx); break; } + if (cxstack_ix == cxix + 1) { + CX_POPBLOCK(cx); + } cxstack_ix--; } - PERL_UNUSED_VAR(optype); + } void @@ -1568,6 +1588,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) { @@ -1577,7 +1625,6 @@ Perl_die_unwind(pTHX_ SV *msv) if (in_eval) { I32 cxix; - I32 gimme; /* * Historically, perl used to set ERRSV ($@) early in the die @@ -1626,56 +1673,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 + SV **oldsp; + 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 + cx = CX_CUR(); + assert(CxTYPE(cx) == CXt_EVAL); + + /* return false to the caller of eval */ + oldsp = PL_stack_base + cx->blk_oldsp; + gimme = cx->blk_gimme; + if (gimme == G_SCALAR) + *++oldsp = &PL_sv_undef; + PL_stack_sp = oldsp; + + CX_LEAVE_SCOPE(cx); + 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 (gimme == G_SCALAR) - *++newsp = &PL_sv_undef; - PL_stack_sp = newsp; - - 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); - (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; @@ -1788,7 +1823,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)) @@ -1941,7 +1976,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(); @@ -1982,7 +2017,7 @@ PP(pp_dbstate) 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; + cx->blk_oldsaveix = PL_savestack_ix; SAVEI32(PL_debug); PL_debug = 0; @@ -2000,61 +2035,6 @@ 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..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. -*/ - -STATIC SV ** -S_leave_common(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, - U32 flags, bool lvalue) -{ - 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 { - /* MEXTEND() only updates MARK, so reuse it instead of newsp. */ - MARK = newsp; - MEXTEND(MARK, 1); - *++MARK = &PL_sv_undef; - return MARK; - } - } - 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. */ - } - - return newsp; -} PP(pp_enter) { @@ -2063,41 +2043,38 @@ PP(pp_enter) I32 gimme = GIMME_V; PUSHBLOCK(cx, CXt_BLOCK, SP); - cx->cx_u.cx_blk.blku_old_savestack_ix = PL_savestack_ix; - cx->cx_u.cx_blk.blku_old_tmpsfloor = PL_tmps_floor; - PL_tmps_floor = PL_tmps_ix; + PUSHBASICBLK(cx); RETURN; } PP(pp_leave) { - dSP; PERL_CONTEXT *cx; - SV **newsp; - PMOP *newpm; + SV **oldsp; 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 */ - } - - POPBLOCK(cx,newpm); + cx = CX_CUR(); + assert(CxTYPE(cx) == CXt_BLOCK); - gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR); + if (PL_op->op_flags & OPf_SPECIAL) + cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */ - SP = (gimme == G_VOID) - ? newsp - : leave_common(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP, - PL_op->op_private & OPpLVALUE); + oldsp = PL_stack_base + cx->blk_oldsp; + gimme = cx->blk_gimme; - LEAVE_SCOPE(cx->cx_u.cx_blk.blku_old_savestack_ix); - PL_tmps_floor = cx->cx_u.cx_blk.blku_old_tmpsfloor; + if (gimme == G_VOID) + PL_stack_sp = oldsp; + else + leave_adjust_stacks(oldsp, oldsp, gimme, + PL_op->op_private & OPpLVALUE ? 3 : 1); - PL_curpm = newpm; /* Don't pop $1 et al till now */ + CX_LEAVE_SCOPE(cx); + CX_POPBASICBLK(cx); + CX_POPBLOCK(cx); + CX_POP(cx); - RETURN; + return NORMAL; } static bool @@ -2129,7 +2106,7 @@ PP(pp_enteriter) const I32 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); @@ -2142,68 +2119,58 @@ 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; + PUSHBLOCK(cx, cxflags, MARK); + 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. */ @@ -2217,22 +2184,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; @@ -2245,33 +2218,36 @@ PP(pp_enterloop) const I32 gimme = GIMME_V; 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 **oldsp; SV **mark; - POPBLOCK(cx,newpm); + cx = CX_CUR(); assert(CxTYPE_is_LOOP(cx)); - mark = newsp; - newsp = PL_stack_base + cx->blk_loop.resetsp; + mark = PL_stack_base + cx->blk_oldsp; + oldsp = CxTYPE(cx) == CXt_LOOP_LIST + ? PL_stack_base + cx->blk_loop.state_u.stack.basesp + : mark; + gimme = cx->blk_gimme; - SP = (gimme == G_VOID) - ? newsp - : leave_common(newsp, SP, MARK, gimme, SVs_PADTMP|SVs_TEMP, - PL_op->op_private & OPpLVALUE); - PUTBACK; + if (gimme == G_VOID) + PL_stack_sp = oldsp; + else + leave_adjust_stacks(MARK, oldsp, gimme, + PL_op->op_private & OPpLVALUE ? 3 : 1); - POPLOOP(cx); /* Stack values are safe: release loop vars ... */ - PL_curpm = newpm; /* ... and pop $1 et al */ + CX_LEAVE_SCOPE(cx); + CX_POPLOOP(cx); /* Stack values are safe: release loop vars ... */ + CX_POPBLOCK(cx); + CX_POP(cx); return NORMAL; } @@ -2287,123 +2263,101 @@ PP(pp_leaveloop) PP(pp_leavesublv) { - dSP; - SV **newsp; - SV **mark; - PMOP *newpm; I32 gimme; PERL_CONTEXT *cx; - SV *sv; - bool ref; - const char *what = NULL; + SV **oldsp; + OP *retop; + + cx = CX_CUR(); + assert(CxTYPE(cx) == CXt_SUB); - if (CxMULTICALL(&cxstack[cxstack_ix])) { + 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 */ - TAINT_NOT; + gimme = cx->blk_gimme; + 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. */ - SV *sv; - 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: - POPSUB(cx,sv); - cxstack_ix--; - PL_curpm = newpm; - LEAVESUB(sv); - 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; - 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); + 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; } @@ -2416,10 +2370,19 @@ PP(pp_return) assert(cxstack_ix >= 0); if (cxix < cxstack_ix) { if (cxix < 0) { - if (!CxMULTICALL(cxstack)) + 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. Handle specially. */ + /* 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 @@ -2443,20 +2406,25 @@ PP(pp_return) * 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. + * leave_adjust_stacks(). By calling it with and lvalue "pass + * all" action, we just bump the ref count and mortalise the args + * that need it, do a FREETMPS. 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; + 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 @@ -2505,16 +2473,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; @@ -2532,7 +2502,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 @@ -2542,39 +2512,33 @@ 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; - I32 gimme; - OP *nextop = NULL; - SV **newsp; - PMOP *newpm; - - 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; + OP* nextop; + + cx = S_unwind_loop(aTHX); + + 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; - cxstack_ix--; /* Stack values are safe: */ - POPLOOP(cx); /* release loop vars ... */ - PL_curpm = newpm; /* ... and pop $1 et al */ + CX_LEAVE_SCOPE(cx); + CX_POPLOOP(cx); /* release loop vars ... */ + CX_POPBLOCK(cx); + nextop = cx->blk_loop.my_op->op_lastop->op_next; + CX_POP(cx); - PERL_UNUSED_VAR(gimme); return nextop; } @@ -2582,9 +2546,12 @@ 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; @@ -2592,20 +2559,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); - LEAVE_SCOPE(cx->cx_u.cx_blk.blku_old_savestack_ix); FREETMPS; + CX_LEAVE_SCOPE(cx); + CX_TOPBLOCK(cx); PL_curcop = cx->blk_oldcop; PERL_ASYNC_CHECK(); return redo_op; @@ -2749,19 +2716,19 @@ PP(pp_goto) if (cxix < cxstack_ix) { dounwind(cxix); } - TOPBLOCK(cx); + cx = CX_CUR(); + CX_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); + CX_LEAVE_SCOPE(cx); 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))[ @@ -2804,15 +2771,10 @@ PP(pp_goto) /* Now do some callish stuff. */ 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 */ @@ -2841,7 +2803,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; @@ -2849,10 +2811,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); @@ -2956,10 +2918,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); @@ -3036,7 +2999,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 */ @@ -3159,8 +3123,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; @@ -3264,7 +3228,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: @@ -3297,7 +3261,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; @@ -3317,9 +3281,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)); @@ -3416,66 +3380,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; - - cx = NULL; - namesv = NULL; - PERL_UNUSED_VAR(newsp); - 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 */ - POPBLOCK(cx,PL_curpm); - POPEVAL(cx); - namesv = cx->blk_eval.old_namesv; - /* 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; + cx = CX_CUR(); + CX_LEAVE_SCOPE(cx); + 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); @@ -3501,8 +3455,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. */ @@ -3512,6 +3464,7 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) return TRUE; } + STATIC PerlIO * S_check_type_and_open(pTHX_ SV *name) { @@ -4095,7 +4048,7 @@ PP(pp_require) /* 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_oldsaveix = old_savestack_ix; cx->blk_eval.retop = PL_op->op_next; SAVECOPLINE(&PL_compiling); @@ -4103,7 +4056,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; @@ -4211,7 +4164,7 @@ PP(pp_entereval) PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP); PUSHEVAL(cx, 0); - cx->cx_u.cx_blk.blku_old_savestack_ix = old_savestack_ix; + cx->blk_oldsaveix = old_savestack_ix; cx->blk_eval.retop = PL_op->op_next; /* prepare to compile string */ @@ -4231,7 +4184,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) { @@ -4243,7 +4196,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) { @@ -4257,56 +4210,66 @@ PP(pp_entereval) PP(pp_leaveeval) { - dSP; - SV **newsp; - PMOP *newpm; + SV **oldsp; 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 */ + /* grab this value before CX_POPEVAL restores old PL_in_eval */ bool keep = cBOOL(PL_in_eval & EVAL_KEEPERR); PERL_ASYNC_CHECK(); - POPBLOCK(cx,newpm); - if (gimme != G_VOID) - SP = leave_common(newsp, SP, newsp, gimme, SVs_TEMP, FALSE); - POPEVAL(cx); - namesv = cx->blk_eval.old_namesv; + + cx = CX_CUR(); + assert(CxTYPE(cx) == CXt_EVAL); + + oldsp = 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 > 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); + CX_POPEVAL(cx); + CX_POPBLOCK(cx); retop = cx->blk_eval.retop; evalcv = cx->blk_eval.cv; - - 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); - 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)); + S_undo_inc_then_croak(aTHX_ namesv, NULL, TRUE); NOT_REACHED; /* NOTREACHED */ - /* die_unwind() did LEAVE, or we won't be here */ - } - else { - 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); + if (!keep) + CLEAR_ERRSV(); + + return retop; } /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it @@ -4314,20 +4277,13 @@ PP(pp_leaveeval) void Perl_delete_eval_scope(pTHX) { - SV **newsp; - PMOP *newpm; - I32 gimme; PERL_CONTEXT *cx; - I32 optype; - POPBLOCK(cx,newpm); - POPEVAL(cx); - PL_curpm = newpm; - 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); + cx = CX_CUR(); + CX_LEAVE_SCOPE(cx); + CX_POPEVAL(cx); + CX_POPBLOCK(cx); + CX_POP(cx); } /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was @@ -4340,7 +4296,7 @@ Perl_create_eval_scope(pTHX_ U32 flags) PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); PUSHEVAL(cx, 0); - cx->cx_u.cx_blk.blku_old_savestack_ix = PL_savestack_ix; + cx->blk_oldsaveix = PL_savestack_ix; PL_in_eval = EVAL_INEVAL; if (flags & G_KEEPERR) @@ -4362,31 +4318,30 @@ PP(pp_entertry) PP(pp_leavetry) { - dSP; - SV **newsp; - PMOP *newpm; + SV **oldsp; I32 gimme; PERL_CONTEXT *cx; - I32 optype; OP *retop; PERL_ASYNC_CHECK(); - POPBLOCK(cx,newpm); - retop = cx->blk_eval.retop; - SP = (gimme == G_VOID) - ? newsp - : leave_common(newsp, SP, newsp, gimme, - SVs_PADTMP|SVs_TEMP, FALSE); - POPEVAL(cx); - PERL_UNUSED_VAR(optype); - PL_curpm = newpm; /* Don't pop $1 et al till now */ + cx = CX_CUR(); + assert(CxTYPE(cx) == CXt_EVAL); + oldsp = PL_stack_base + cx->blk_oldsp; + gimme = cx->blk_gimme; - LEAVE_SCOPE(cx->cx_u.cx_blk.blku_old_savestack_ix); - PL_tmps_floor = cx->cx_u.cx_blk.blku_old_tmpsfloor; + if (gimme == G_VOID) + PL_stack_sp = oldsp; + else + leave_adjust_stacks(oldsp, oldsp, gimme, 1); + CX_LEAVE_SCOPE(cx); + CX_POPEVAL(cx); + CX_POPBLOCK(cx); + retop = cx->blk_eval.retop; + CX_POP(cx); CLEAR_ERRSV(); - RETURNOP(retop); + return retop; } PP(pp_entergiven) @@ -4408,24 +4363,27 @@ PP(pp_entergiven) PP(pp_leavegiven) { - dSP; PERL_CONTEXT *cx; I32 gimme; - SV **newsp; - PMOP *newpm; + SV **oldsp; PERL_UNUSED_CONTEXT; - POPBLOCK(cx,newpm); - SP = (gimme == G_VOID) - ? newsp - : leave_common(newsp, SP, newsp, gimme, - SVs_PADTMP|SVs_TEMP, FALSE); - POPGIVEN(cx); + cx = CX_CUR(); assert(CxTYPE(cx) == CXt_GIVEN); + oldsp = PL_stack_base + cx->blk_oldsp; + gimme = cx->blk_gimme; + + if (gimme == G_VOID) + PL_stack_sp = oldsp; + else + leave_adjust_stacks(oldsp, oldsp, gimme, 1); - PL_curpm = newpm; /* Don't pop $1 et al till now */ + CX_LEAVE_SCOPE(cx); + CX_POPGIVEN(cx); + CX_POPBLOCK(cx); + CX_POP(cx); - RETURN; + return NORMAL; } /* Helper routines used by pp_smartmatch */ @@ -4985,62 +4943,53 @@ PP(pp_enterwhen) PP(pp_leavewhen) { - dSP; I32 cxix; PERL_CONTEXT *cx; I32 gimme; - SV **newsp; - PMOP *newpm; + SV **oldsp; + + cx = CX_CUR(); + assert(CxTYPE(cx) == CXt_WHEN); + gimme = cx->blk_gimme; - cxix = dopoptogiven(cxstack_ix); + 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 = (gimme == G_VOID) - ? newsp - : leave_common(newsp, SP, newsp, gimme, - SVs_PADTMP|SVs_TEMP, FALSE); - POPWHEN(cx); - - PL_curpm = newpm; /* pop $1 et al */ + oldsp = PL_stack_base + cx->blk_oldsp; + if (gimme == G_VOID) + PL_stack_sp = oldsp; + else + leave_adjust_stacks(oldsp, oldsp, gimme, 1); - if (cxix < cxstack_ix) - dounwind(cxix); + /* 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; - - TOPBLOCK(cx); - if (PL_scopestack_ix < inner) - leave_scope(PL_scopestack[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 */ + cx = CX_CUR(); + CX_TOPBLOCK(cx); 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) @@ -5049,14 +4998,16 @@ PP(pp_continue) if (cxix < cxstack_ix) dounwind(cxix); - POPBLOCK(cx,newpm); + cx = CX_CUR(); assert(CxTYPE(cx) == CXt_WHEN); - POPWHEN(cx); - - SP = newsp; - PL_curpm = newpm; /* pop $1 et al */ + PL_stack_sp = PL_stack_base + cx->blk_oldsp; + CX_LEAVE_SCOPE(cx); + CX_POPWHEN(cx); + CX_POPBLOCK(cx); + nextop = cx->blk_givwhen.leave_op->op_next; + CX_POP(cx); - RETURNOP(cx->blk_givwhen.leave_op->op_next); + return nextop; } PP(pp_break) @@ -5064,7 +5015,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"); @@ -5076,7 +5027,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; }