From 799da9d7a389d2e825fba9c63b2f6876513385c7 Mon Sep 17 00:00:00 2001 From: David Mitchell Date: Wed, 16 Dec 2015 12:30:01 +0000 Subject: make pp_leavesublv use S_leavesub_adjust_stacks() Currently S_leavesub_adjust_stacks() is just used by pp_leavesub. Rename it to Perl_leave_adjust_stacks(), extend its functionality slightly, then make pp_leavesublv() use it too. This means that lvalue sub exit gains the benefit of FREETMPS being done, and (where mortal copying needs doing) the optimised copying code. It also means there is now one less version of the "process args on scope exit" code. pp_leavesublv() still does a scan of its return args looking for things to croak() on, but leaves everything else to leave_adjust_stacks(). leave_adjust_stacks() is intended shortly to be used in place of S_leave_common() too, thus unifying all args-on-scope-exit code. The changes to leave_adjust_stacks() in this commit (apart from the renaming and doc changes) are: * a new arg to indicate what condition to use to decide whether to pass or copy the arg; * a new branch to mortalise and ref count bump an arg --- pp_ctl.c | 161 +++++++++++++++++++++++++++------------------------------------ 1 file changed, 68 insertions(+), 93 deletions(-) (limited to 'pp_ctl.c') diff --git a/pp_ctl.c b/pp_ctl.c index cde30a40fc..ff1fb42313 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -2308,13 +2308,9 @@ PP(pp_leaveloop) PP(pp_leavesublv) { - dSP; - SV **newsp; - SV **mark; I32 gimme; PERL_CONTEXT *cx; - bool ref; - const char *what = NULL; + SV **oldsp; OP *retop; cx = CX_CUR(); @@ -2327,99 +2323,78 @@ 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; + 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); + } - 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))) { - 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: - 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; + ok: + leave_adjust_stacks(oldsp, gimme, is_lval ? 3 : 2); - 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++) { - /* 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 (*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)); - } + 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, gimme, is_lval ? 3 : 2); + } } - PUTBACK; CX_LEAVE_SCOPE(cx); POPSUB(cx); /* Stack values are safe: release CV and @_ ... */ -- cgit v1.2.1