In perl.git, the branch sprout/op_const_sv2 has been updated <http://perl5.git.perl.org/perl.git/commitdiff/8e2f715a9b8cc6b2f0ab18569d7b3ffd007fdedd?hp=4da090a33e09da12d1d4874a26345b1db7a58aab>
- Log ----------------------------------------------------------------- commit 8e2f715a9b8cc6b2f0ab18569d7b3ffd007fdedd Author: Father Chrysostomos <[email protected]> Date: Sun Nov 2 21:54:22 2014 -0800 Allow sub():method{CONSTANT} to be inlined This brings non-closure subs into conformity with closures. M op.c M t/op/const-optree.t commit 4886b8729f5e0571310836efb9d578bbf054f864 Author: Father Chrysostomos <[email protected]> Date: Sun Nov 2 21:34:23 2014 -0800 First arg to op_const_sv is never null M embed.fnc M op.c M proto.h commit d60876732c921996bee13af1b825e8fecc100152 Author: Father Chrysostomos <[email protected]> Date: Sun Nov 2 16:50:40 2014 -0800 Remove SvREADONLY_on from op.c:op_const_sv If we turn on the padtmp flag, then this this SV will never be seen in lvalue context, so whether it is read-only is irrelevant. Donât even bother making it so. M op.c commit 2d1df1d3cd70088409397529e1e605105c8adcbb Author: Father Chrysostomos <[email protected]> Date: Sun Nov 2 16:46:57 2014 -0800 op.c:Start the search for const vars at CvSTART When we search an op tree to see whether it could become a constant closure, we search the op execution chain, but we donât necessarily start at the beginning. We start at the outermost op of the first statementâs contents. That means that for sub {$a+$b} we begin the search at the + (add), even though the full execution chain is next- state, gvsv, gvsv, add, leavesub. It was this oddity that led to bug #63540. Originally (before beab0874143b), the search through the op chain started at CvSTART (the start of the execution chain), but was accidentally changed in beab0874143b. (That was also when sub(){return 2} stopped being inlined.) Changing this back to the way it used to be allows use to remove the check to see whether a null op has kids, which was added to handle op trees like b leavesub - lineseq 1 nextstate - null ->9 3 and 2 padsv 8 leave 4 enter 5 nextstate 7 die 6 pushmark 9 nextstate a const which is the result of sub { if($x){ die }; 0 }. If we begin the search at the null op, and if nulls are skipped, we end up missing the entire âifâ block and seeing just null, nextstate, const, leavesub, which looks constant. M op.c commit c836a7af7d4eae65911b289c3345c7ae881c7f82 Author: Father Chrysostomos <[email protected]> Date: Sun Nov 2 16:31:27 2014 -0800 Handle multiple closures in sub(){$x} const-izing Till now, we were checking the reference count of the variable that we have just closed over, to see whether the newly-cloned sub can become a constant. A reference count of 2 would indicate that only the outer pad and the pad of the newly-cloned sub held references. Recent commits also checked whether the variable is used in lvalue context in the outer sub in places other than its declaration. This is insufficient to detect cases like: my $x = 43; my $const_closure = sub () { $x }; my $other_closure = sub {$x++}; Although it does work if the $other_closure comes first (because it holds a refcount by the time the $const_closure is created). Extending the check for lvalue uses to inner subs as well (the changes this commit makes to op_lvalue_flags) fixes that issue. It does not allows cases like my $x = 43; my $other_closure = sub { $x }; my $const_closure = sub () { $x }; to create a constant, because the reference count check still prevents it. I tried removing the reference count check, but it fails for cases like \(my $x = 1), which allows $x to be referenced elsewhere, even though the only lvalue use of it is its declaration. As with the commits leading up to this, we allow a simple sub(){$x} to create constants erroneously where it would have done so before, but with a deprecation warning. The deprecation warning had to be moved, because it could trigger even in those cases where the refcount check fails and we donât create a constant, which is just wrong. This commit does not account for string eval within the scope of the variable. M op.c M t/op/const-optree.t commit 5be1e345f17d7b3c96c75e47c7fdc3ac80a9231b Author: Father Chrysostomos <[email protected]> Date: Sun Nov 2 06:20:09 2014 -0800 const-optree.t: Correct comment M t/op/const-optree.t commit 1d82a40a7906b4042e81980a6d70be3bc5a86ff5 Author: Father Chrysostomos <[email protected]> Date: Sun Nov 2 06:02:18 2014 -0800 Donât inline sub(){ 0; return $x } If return occurs at the end of a sub, it is optimised out of the execution, chain, so we have to look at the op tree structure to detect it. M op.c M t/op/const-optree.t ----------------------------------------------------------------------- Summary of changes: embed.fnc | 2 +- op.c | 56 ++++++++++++++------ proto.h | 5 +- t/op/const-optree.t | 143 +++++++++++++++++++++++++++++++++++++++++++++++++++- 4 files changed, 186 insertions(+), 20 deletions(-) diff --git a/embed.fnc b/embed.fnc index 472977c..0c1ea71 100644 --- a/embed.fnc +++ b/embed.fnc @@ -315,7 +315,7 @@ ApdR |SV* |gv_const_sv |NN GV* gv ApdRn |SV* |cv_const_sv |NULLOK const CV *const cv pRn |SV* |cv_const_sv_or_av|NULLOK const CV *const cv : Used in pad.c -pR |SV* |op_const_sv |NULLOK const OP* o|NULLOK CV* cv \ +pR |SV* |op_const_sv |NN const OP* o|NULLOK CV* cv \ |NULLOK CV *outside Apd |SV * |cv_name |NN CV *cv|NULLOK SV *sv|U32 flags Apd |void |cv_undef |NN CV* cv diff --git a/op.c b/op.c index c83d322..b511c50 100644 --- a/op.c +++ b/op.c @@ -2736,7 +2736,20 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) Perl_croak(aTHX_ "Can't localize lexical variable %"SVf, PAD_COMPNAME_SV(o->op_targ)); if (!(o->op_private & OPpLVAL_INTRO)) - PadnameLVALUE_on(PAD_COMPNAME_SV(o->op_targ)); + { + PADNAME *pn = PAD_COMPNAME_SV(o->op_targ); + CV *cv = PL_compcv; + PadnameLVALUE_on(pn); + while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) { + cv = CvOUTSIDE(cv); + assert(cv); + assert(CvPADLIST(cv)); + pn = + PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)]; + assert(PadnameLEN(pn)); + PadnameLVALUE_on(pn); + } + } break; case OP_PUSHMARK: @@ -7653,8 +7666,7 @@ Perl_op_const_sv(pTHX_ const OP *o, CV *cv, CV *outcv) { SV *sv = NULL; - if (!o) - return NULL; + PERL_ARGS_ASSERT_OP_CONST_SV; if (o->op_type == OP_LINESEQ && cLISTOPo->op_first) o = OP_SIBLING(cLISTOPo->op_first); @@ -7666,7 +7678,7 @@ Perl_op_const_sv(pTHX_ const OP *o, CV *cv, CV *outcv) return sv; if (o->op_next != o) { if (type == OP_NEXTSTATE - || (type == OP_NULL && !(o->op_flags & OPf_KIDS)) + || type == OP_NULL || type == OP_PUSHMARK) continue; if (type == OP_DBSTATE) @@ -7689,6 +7701,11 @@ Perl_op_const_sv(pTHX_ const OP *o, CV *cv, CV *outcv) } else if (cv && type == OP_PADSV) { if (CvCONST(cv)) { /* newly cloned anon */ + sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); + /* the candidate should have 1 ref from this pad and 1 ref + * from the parent */ + if (!sv || SvREFCNT(sv) != 2) + return NULL; if (outcv) { PADNAME * const pn = PadlistNAMESARRAY(CvPADLIST(outcv)) @@ -7702,7 +7719,8 @@ Perl_op_const_sv(pTHX_ const OP *o, CV *cv, CV *outcv) sure behaviour. If this is a âsimple lexical op treeâ, i.e., sub(){$x}, emit a deprecation warning, but continue to exhibit the old behav- - iour of making it a constant regardless. + iour of making it a constant based on the ref- + count of the candidate variable. A simple lexical op tree looks like this: @@ -7725,13 +7743,7 @@ Perl_op_const_sv(pTHX_ const OP *o, CV *cv, CV *outcv) return NULL; } } - sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); - /* the candidate should have 1 ref from this pad and 1 ref - * from the parent */ - if (!sv || SvREFCNT(sv) != 2) - return NULL; sv = newSVsv(sv); - SvREADONLY_on(sv); SvPADTMP_on(sv); return sv; } @@ -7898,7 +7910,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } if (!block || !ps || *ps || attrs - || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS) + || CvLVALUE(compcv) ) const_sv = NULL; else @@ -7947,6 +7959,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvXSUB(cv) = const_sv_xsub; CvCONST_on(cv); CvISXSUB_on(cv); + CvFLAGS(cv) |= CvMETHOD(compcv); op_free(block); SvREFCNT_dec(compcv); PL_compcv = NULL; @@ -8285,7 +8298,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (!block || !ps || *ps || attrs - || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) + || CvLVALUE(PL_compcv) ) const_sv = NULL; else @@ -8355,14 +8368,17 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, CvXSUB(cv) = const_sv_xsub; CvCONST_on(cv); CvISXSUB_on(cv); + CvFLAGS(cv) |= CvMETHOD(PL_compcv); } else { - if (isGV(gv)) { - if (name) GvCV_set(gv, NULL); + if (isGV(gv) || CvMETHOD(PL_compcv)) { + if (name && isGV(gv)) + GvCV_set(gv, NULL); cv = newCONSTSUB_flags( NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0, const_sv ); + CvFLAGS(cv) |= CvMETHOD(PL_compcv); } else { if (!SvROK(gv)) { @@ -8519,7 +8535,15 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (CvCLONE(cv)) { assert(!CvCONST(cv)); - if (ps && !*ps && !attrs && op_const_sv(block, cv, NULL)) + if (ps && !*ps && !attrs + /* Check whether this sub is a potentially inlinable closure. + First check for an explicit return at the end of the sub. + Perl_rpeep will have removed it from the execution chain, + yet we promise that it will prevent inlining. */ + && block->op_type == OP_LINESEQ + && cLISTOPx(block)->op_last->op_type != OP_RETURN + /* Then search the op tree for a single lexical. */ + && op_const_sv(CvSTART(cv), cv, NULL)) CvCONST_on(cv); } diff --git a/proto.h b/proto.h index 0aaea49..4607a76 100644 --- a/proto.h +++ b/proto.h @@ -3185,7 +3185,10 @@ PERL_CALLCONV void Perl_op_clear(pTHX_ OP* o) assert(o) PERL_CALLCONV SV* Perl_op_const_sv(pTHX_ const OP* o, CV* cv, CV *outside) - __attribute__warn_unused_result__; + __attribute__warn_unused_result__ + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_OP_CONST_SV \ + assert(o) PERL_CALLCONV OP* Perl_op_contextualize(pTHX_ OP* o, I32 context) __attribute__nonnull__(pTHX_1); diff --git a/t/op/const-optree.t b/t/op/const-optree.t index de611bb..e22b1c5 100644 --- a/t/op/const-optree.t +++ b/t/op/const-optree.t @@ -8,13 +8,13 @@ BEGIN { require './test.pl'; @INC = '../lib'; } -plan 51; +plan 101; # @tests is an array of hash refs, each of which can have various keys: # # nickname - name of the sub to use in test names # generator - a sub returning a code ref to test -# finally - sub to run after the other tests +# finally - sub to run after the tests # # Each of the following gives expected test results. If the key is # omitted, the test is skipped: @@ -115,6 +115,112 @@ push @tests, { method => 0, }; +# Explicit return after optimised statement, at end of sub [perl #123092] +push @tests, { + nickname => 'sub () { 0; return $x }', + generator => sub { my $x = 5; sub () { 0; return $x } }, + retval => 5, + same_retval => 0, + inlinable => 0, + deprecated => 0, + method => 0, +}; + +# Multiple closure tests +push @tests, { + nickname => 'simple lexical after another closure and no lvalue', + generator => sub { + my $x = 5; + # This closure prevents inlining, though theoretically it shouldnât + # have to. If you change the behaviour, just change the test. This + # fails the refcount check in op.c:op_const_sv, which is necessary for + # the sake of \(my $x = 1) (tested below). + my $sub1 = sub () { () = $x }; + sub () { $x }; + }, + retval => 5, + same_retval => 0, + inlinable => 0, + deprecated => 0, + method => 0, +}; +push @tests, { + nickname => 'simple lexical before another closure and no lvalue', + generator => sub { + my $x = 5; + my $ret = sub () { $x }; + # This does not prevent inlining and never has. + my $sub1 = sub () { () = $x }; + $ret; + }, + retval => 5, + same_retval => 0, + inlinable => 1, + deprecated => 0, + method => 0, +}; +push @tests, { + nickname => 'simple lexical after an lvalue closure', + generator => sub { + my $x = 5; + # This has always prevented inlining + my $sub1 = sub () { $x++ }; + sub () { $x }; + }, + retval => 5, + same_retval => 0, + inlinable => 0, + deprecated => 0, + method => 0, +}; +push @tests, { + nickname => 'simple lexical before an lvalue closure', + generator => sub { + my $x = 5; + my $ret = sub () { $x }; # <-- simple lexical op tree + # Traditionally this has not prevented inlining, though it should. But + # since $ret has a simple lexical op tree, we preserve backward-compat- + # ibility, but deprecate it. + my $sub1 = sub () { $x++ }; + $ret; + }, + retval => 5, + same_retval => 0, + inlinable => 1, + deprecated => 1, + method => 0, +}; +push @tests, { + nickname => 'complex lexical op tree before an lvalue closure', + generator => sub { + my $x = 5; + my $ret = sub () { 0; $x }; # <-- more than just a lexical + # This used not to prevent inlining, though it should, and now does. + my $sub1 = sub () { $x++ }; + $ret; + }, + retval => 5, + same_retval => 0, + inlinable => 0, + deprecated => 0, + method => 0, +}; +push @tests, { + nickname => 'complex lexical op tree before a nested lvalue closure', + generator => sub { + my $x = 5; + my $ret = sub () { 0; $x }; # <-- more than just a lexical + # This used not to prevent inlining, though it should, and now does. + my $sub1 = sub () { sub () { $x++ } }; # nested + $ret; + }, + retval => 5, + same_retval => 0, + inlinable => 0, + deprecated => 0, + method => 0, +}; + use feature 'state', 'lexical_subs'; no warnings 'experimental::lexical_subs'; @@ -132,6 +238,21 @@ push @tests, { }; push @tests, { + nickname => 'closure after \(my $x=1)', + generator => sub { + $y = \(my $x = 1); + my $ret = sub () { $x }; + $$y += 7; + $ret; + }, + retval => 8, + same_retval => 0, + inlinable => 0, + deprecated => 0, + method => 0, +}; + +push @tests, { nickname => 'sub:method with simple lexical', generator => sub { my $y; sub():method{$y} }, retval => undef, @@ -140,6 +261,24 @@ push @tests, { deprecated => 0, method => 1, }; +push @tests, { + nickname => 'sub:method with constant', + generator => sub { sub():method{3} }, + retval => 3, + same_retval => 0, + inlinable => 1, + deprecated => 0, + method => 1, +}; +push @tests, { + nickname => 'my sub:method with constant', + generator => sub { my sub x ():method{3} \&x }, + retval => 3, + same_retval => 0, + inlinable => 1, + deprecated => 0, + method => 1, +}; use feature 'refaliasing'; -- Perl5 Master Repository
