diff options
| -rw-r--r-- | embed.fnc | 2 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | op.c | 57 | ||||
| -rw-r--r-- | pad.c | 19 | ||||
| -rw-r--r-- | proto.h | 2 | ||||
| -rw-r--r-- | t/op/sub.t | 12 |
6 files changed, 85 insertions, 9 deletions
@@ -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 @@ -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) @@ -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<use attributes $stash_of_cv,\&cv,@attrs>. */ @@ -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<use attributes $stash_of_cv,\&cv,@attrs>. */ @@ -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; } @@ -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 a0860636d8..7df8f49aab 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 |