From d3f8a934ef964c0f488e9c692275435d8ea2e291 Mon Sep 17 00:00:00 2001 From: =?utf8?q?=C3=86var=20Arnfj=C3=B6r=C3=B0=20Bjarmason?= Date: Wed, 7 May 2014 12:09:40 +0000 Subject: [PATCH] Revert "[perl #79908] Stop sub inlining from breaking closures" This reverts commit 137da2b05b4b7628115049f343163bdaf2c30dbb. See the "How about having a recommended way to add constant subs dynamically?" thread on perl5-porters, specifically while it sucks that we have this bug, it's been documented to work this way since 5.003 in "Constant Functions" in perlsub: If the result after optimization and constant folding is either a constant or a lexically-scoped scalar which has no other references, then it will be used in place of function calls made without C<&> -- http://perldoc.perl.org/perlsub.html#Constant-Functions Since we've had this documented bug for a long time we should introduce this fix in a deprecation cycle rather than silently slowing down code that assumes it's going to be optimized by constant folding. I didn't revert the tests it t/op/sub.t, but turned them into TODO tests instead. Conflicts: t/op/sub.t --- embed.fnc | 2 +- embed.h | 2 +- op.c | 57 ++++++++++++++++++++++++++++++++++++++++++++++++++++++--- pad.c | 19 +++++++++++++++++++ proto.h | 2 +- t/op/sub.t | 12 +++++++++--- 6 files changed, 85 insertions(+), 9 deletions(-) diff --git a/embed.fnc b/embed.fnc index 1545bd2..c78f345 100644 --- a/embed.fnc +++ b/embed.fnc @@ -310,7 +310,7 @@ ApdR |SV* |gv_const_sv |NN GV* gv ApdR |SV* |cv_const_sv |NULLOK const CV *const cv pR |SV* |cv_const_sv_or_av|NULLOK const CV *const cv : Used in pad.c -pR |SV* |op_const_sv |NULLOK const OP* o +pR |SV* |op_const_sv |NULLOK const OP* o|NULLOK CV* cv Apd |void |cv_undef |NN CV* cv p |void |cv_forget_slab |NN CV *cv Ap |void |cx_dump |NN PERL_CONTEXT* cx diff --git a/embed.h b/embed.h index d4b1752..a6e3b9d 100644 --- a/embed.h +++ b/embed.h @@ -1206,7 +1206,7 @@ #define nextargv(a) Perl_nextargv(aTHX_ a) #define oopsAV(a) Perl_oopsAV(aTHX_ a) #define oopsHV(a) Perl_oopsHV(aTHX_ a) -#define op_const_sv(a) Perl_op_const_sv(aTHX_ a) +#define op_const_sv(a,b) Perl_op_const_sv(aTHX_ a,b) #define op_unscope(a) Perl_op_unscope(aTHX_ a) #define package_version(a) Perl_package_version(aTHX_ a) #define pad_block_start(a) Perl_pad_block_start(aTHX_ a) diff --git a/op.c b/op.c index 716c684..796cb03 100644 --- a/op.c +++ b/op.c @@ -7248,10 +7248,28 @@ Perl_cv_const_sv_or_av(pTHX_ const CV * const cv) } /* op_const_sv: examine an optree to determine whether it's in-lineable. + * Can be called in 3 ways: + * + * !cv + * look for a single OP_CONST with attached value: return the value + * + * cv && CvCLONE(cv) && !CvCONST(cv) + * + * examine the clone prototype, and if contains only a single + * OP_CONST referencing a pad const, or a single PADSV referencing + * an outer lexical, return a non-zero value to indicate the CV is + * a candidate for "constizing" at clone time + * + * cv && CvCONST(cv) + * + * We have just cloned an anon prototype that was marked as a const + * candidate. Try to grab the current value, and in the case of + * PADSV, ignore it if it has multiple references. In this case we + * return a newly created *copy* of the value. */ SV * -Perl_op_const_sv(pTHX_ const OP *o) +Perl_op_const_sv(pTHX_ const OP *o, CV *cv) { dVAR; SV *sv = NULL; @@ -7284,6 +7302,27 @@ Perl_op_const_sv(pTHX_ const OP *o) return NULL; if (type == OP_CONST && cSVOPo->op_sv) sv = cSVOPo->op_sv; + else if (cv && type == OP_CONST) { + sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); + if (!sv) + return NULL; + } + 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; + sv = newSVsv(sv); + SvREADONLY_on(sv); + return sv; + } + else { + if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE) + sv = &PL_sv_undef; /* an arbitrary non-null value */ + } + } else { return NULL; } @@ -7455,7 +7494,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) ) const_sv = NULL; else - const_sv = op_const_sv(block); + const_sv = op_const_sv(block, NULL); if (cv) { const bool exists = CvROOT(cv) || CvXSUB(cv); @@ -7628,6 +7667,12 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB); + if (CvCLONE(cv)) { + assert(!CvCONST(cv)); + if (ps && !*ps && op_const_sv(block, cv)) + CvCONST_on(cv); + } + attrs: if (attrs) { /* Need to do a C. */ @@ -7822,7 +7867,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, ) const_sv = NULL; else - const_sv = op_const_sv(block); + const_sv = op_const_sv(block, NULL); if (cv) { const bool exists = CvROOT(cv) || CvXSUB(cv); @@ -7984,6 +8029,12 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB); + if (CvCLONE(cv)) { + assert(!CvCONST(cv)); + if (ps && !*ps && op_const_sv(block, cv)) + CvCONST_on(cv); + } + attrs: if (attrs) { /* Need to do a C. */ diff --git a/pad.c b/pad.c index 419b403..31282d1 100644 --- a/pad.c +++ b/pad.c @@ -2197,6 +2197,25 @@ S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside) cv_dump(cv, "To"); ); + if (CvCONST(cv)) { + /* Constant sub () { $x } closing over $x - see lib/constant.pm: + * The prototype was marked as a candiate for const-ization, + * so try to grab the current const value, and if successful, + * turn into a const sub: + */ + SV* const const_sv = op_const_sv(CvSTART(cv), cv); + if (const_sv) { + SvREFCNT_dec_NN(cv); + /* For this calling case, op_const_sv returns a *copy*, which we + donate to newCONSTSUB. Yes, this is ugly, and should be killed. + Need to fix how lib/constant.pm works to eliminate this. */ + cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv); + } + else { + CvCONST_off(cv); + } + } + return cv; } diff --git a/proto.h b/proto.h index a553202..a6ee09a 100644 --- a/proto.h +++ b/proto.h @@ -3064,7 +3064,7 @@ PERL_CALLCONV void Perl_op_clear(pTHX_ OP* o) #define PERL_ARGS_ASSERT_OP_CLEAR \ assert(o) -PERL_CALLCONV SV* Perl_op_const_sv(pTHX_ const OP* o) +PERL_CALLCONV SV* Perl_op_const_sv(pTHX_ const OP* o, CV* cv) __attribute__warn_unused_result__; PERL_CALLCONV OP* Perl_op_contextualize(pTHX_ OP* o, I32 context) diff --git a/t/op/sub.t b/t/op/sub.t index a086063..7df8f49 100644 --- a/t/op/sub.t +++ b/t/op/sub.t @@ -152,7 +152,10 @@ is eval { my $x = 5; *_79908 = sub (){$x}; $x = 7; - is eval "_79908", 7, 'sub(){$x} does not break closures'; + TODO: { + local $TODO = "Should be fixed with a deprecation cycle, see 'How about having a recommended way to add constant subs dynamically?' on p5p"; + is eval "_79908", 7, 'sub(){$x} does not break closures'; + } isnt eval '\_79908', \$x, 'sub(){$x} returns a copy'; # Test another thing that was broken by $x inlinement @@ -162,8 +165,11 @@ is eval { my $w; local $SIG{__WARN__} = sub { $w .= shift }; eval "()=time"; - is $w, undef, - '*keyword = sub():method{$y} does not cause ambiguity warnings'; + TODO: { + local $TODO = "Should be fixed with a deprecation cycle, see 'How about having a recommended way to add constant subs dynamically?' on p5p"; + is $w, undef, + '*keyword = sub():method{$y} does not cause ambiguity warnings'; + } } # &xsub when @_ has nonexistent elements -- 2.7.4