In perl.git, the branch maint-5.18 has been updated <http://perl5.git.perl.org/perl.git/commitdiff/a183b355664edd52456e891b72da9d326050e0cd?hp=9de5f9548e6b2b322163ba0386f30c853d6111e2>
- Log ----------------------------------------------------------------- commit a183b355664edd52456e891b72da9d326050e0cd Author: Father Chrysostomos <[email protected]> Date: Sat Jul 27 23:22:43 2013 -0700 perldelta: deep recursion warnings (07b2687d2/#118521) M pod/perldelta.pod commit 9a4c2565b8e795154abadc839aaa3018ff6d9b4f Author: Father Chrysostomos <[email protected]> Date: Sat Jul 13 14:31:31 2013 -0700 perldelta for bdbfc51a7b (undef constant my sub) (cherry picked from commit 07a522a526321341d2a83a852eda7f6fecb333c9) M pod/perldelta.pod commit 804663d121853831babb5327f4afe37af5ba5829 Author: Father Chrysostomos <[email protected]> Date: Sat Jul 13 11:57:02 2013 -0700 perldelta for #118305/88dbe4a (cherry picked from commit 81d3ed5a0fa49c09ac57f7edc0917f345ff6b160) M pod/perldelta.pod commit 107e921d063604cf0b78ee2371b7ab1d03f69b83 Author: Father Chrysostomos <[email protected]> Date: Mon Jun 10 00:50:47 2013 -0700 perldelta for lexsub syntax errors (3a74e0e282c) (cherry picked from commit 3221bc400f3da87f0d721c2bf3501051fac946ea) M pod/perldelta.pod commit a1221657d9ff110a5521d5f4f7dda9c9ed2a36b0 Author: Father Chrysostomos <[email protected]> Date: Mon Jun 10 00:49:26 2013 -0700 perldelta for two lexsub fixes (cherry picked from commit 81748522aff12edb368615e9512781d00a2d5d5b) M pod/perldelta.pod commit 510f162848ed052ce0d7d3556ab6a9076b1ca8ae Author: Father Chrysostomos <[email protected]> Date: Sun Jun 23 12:06:11 2013 -0700 Stop undef &foo from crashing on lex subs (cherry picked from commit bdbfc51a7bc15a2f0a187c1ef09a16838a4c9915) M pp.c M t/op/lexsub.t commit c67a57e45fb9e35ae90420dec38715c471c52a3f Author: Lukas Mai <[email protected]> Date: Tue Jun 18 09:51:32 2013 +0200 don't crash on deep recursion warnings in lexical subs (#118521) (cherry picked from commit 07b2687d22462e599adb759b7c0082fb12b3f33d) M pp_hot.c M t/op/lexsub.t commit 986469e8aa23ceb3584ebcbdfee6076fe85dda8e Author: Father Chrysostomos <[email protected]> Date: Thu Jun 20 14:07:19 2013 -0700 [perl #118305] make dtrace sub-entry probe support lexsubs No tests, because I donât know how to write them. See also <https://rt.perl.org/rt3/Ticket/Display.html?id=118305#txn-1221543>. I have tested this manually, so I know it works and no longer crashes. Hopefully someone else can follow this up with tests. (cherry picked from commit 88dbe4af2506aa2aa6864e188ca115b5423d4f9b) M cop.h commit 06d344cf0950362c8644646c94f29a4ac3a4276e Author: Father Chrysostomos <[email protected]> Date: Sun Jun 2 13:25:24 2013 -0700 Fix crashes after syntax errors in lexical subs Peter Martini fixed this in commit 89e006ae4e39db for our subs. (Thank you, BTW, if you are reading this.) The warning is expected; the assertion failure is not: $ ./miniperl -Ilib -Mfeature=:all -e 'state sub a { is ref } a()' The lexical_subs feature is experimental at -e line 1. Assertion failed: (hek), function Perl_ck_subr, file op.c, line 10558. Abort trap: 6 $ ./miniperl -Ilib -Mfeature=:all -e 'my sub a { is ref } a()' The lexical_subs feature is experimental at -e line 1. Assertion failed: (SvTYPE(_svmagic) >= SVt_PVMG), function S_mg_findext_flags, file mg.c, line 398. Abort trap: 6 $ The prototype CV for a my sub is stored in magic attached to the pad name. The. The code to fetch the prototype CV for a my sub calls mg_find on the pad name. If a syntax error occurs when the sub is be ing compiled, the magic will never be attached, so the pad name (pad names are currently SVs) will not have been upgraded to SVt_PVMG, causing an assertion failure in mg_find, which only accepts SVs thus upgraded. When a pad entry is created, it is automatically filled with an empty SV of the appropriate type. For a subroutine, this is a nameless CV stub. CVs can be named in two ways, via GVs for package subs, or via heks for lexical subs. This stub has neither and is truly nameless. Since a lexical sub is never installed if it contains a syntax error, this stub is visible during subsequent compilation in the same scope. ck_subr wasnât prepared to handle a stub with absolutely no name attached to it, since it is designed for handling sub calls where the sub is known at compile time, so there must be a GV available to it, unless the sub is lexical, and all lexical subs have heks. This commit fixes the assumptions in both places. Exactly what hap- pens and what is returned is not so important, as this only hap- pens after a syntax error, when the op tree is going to be thrown away anyway. (cherry picked from commit 3a74e0e282cd5c2593f9477923d3bcb1f32ece37) M op.c M t/op/lexsub.t commit daa05ff194599b8b008613c12abbe63a1690e427 Author: Father Chrysostomos <[email protected]> Date: Sun Jun 2 00:54:09 2013 -0700 [perl #116735] Honour lexical prototypes when no parens are used As Peter Martini noted in ticket #116735, lexical subs produce dif- ferent op trees for âfoo 1â and âfoo(1)â. foo(1) produces an rv2cv op with a padcv kid. The unparenthetical version produces just a padcv op. And the difference in op trees caused lexical sub calls to honour prototypes only in the presence of parentheses, because rv2cv_op_cv (which searches for the cv in order to check its prototype) was expecting rv2cv+padcv. Not realising there was a discrepancy between the two forms, and noticing that foo() produces *two* newCVREF ops, in commit 279d09bf893 I made newCVREF return just a padcv op for lexical subs. At the time I couldnât figure out why there were two rv2cv ops, and punted on researching it. This is how it works for package subs: When a sub call is compiled, if there are parentheses, an implicit '&' is fed to the parser. The token that follows is a WORD token with a constant op attached to it, containing the name of the subroutine. When the parser sees '&', it calls newCVREF on the const op to create an rv2cv op. For sub calls without parentheses, the token passed to the parser is already an rv2cv op. The resulting op tree is the same either way. For lexical subs, I had the lexer emitting an rv2cv op in both paths, which was why we got the double rv2cv when newCVREF was returning an rv2cv for lexical subs. The real solution is to call newCVREF in the lexer only when there are no parentheses, since in that case the lexer is not going to call newCVREF itself. That avoids a redundant newCVREF call. Hence, we can have newCVREF always return an rv2cv op. The result is that âfoo(1)â and âfoo 1â produce identical op trees for a lexical sub. One more thing needed to change: The lexer was not looking at the lexical prototype CV but simply the stub to be autovivified, so it couldnât see the parameter prototype attached to the CV (the stub doesnât have one). The lexer needs to see the parameter prototype too, in order to deter- mine precedence. The logic for digging through pads to find the CV has been extracted out of rv2cv_op_cv into a separate (non-API!) routine. (cherry picked from commit 9a5e6f3cd84e6eaf40dad034fb9d25cb3361accc) M embed.fnc M embed.h M op.c M proto.h M t/op/lexsub.t M toke.c commit a577946faac23421cbc37de4b630e96637f8263c Author: Father Chrysostomos <[email protected]> Date: Sat Jun 1 18:39:33 2013 -0700 Name lexical constants $ ./perl -Ilib -Mfeature=:all -e 'my sub a(){44} a()' The lexical_subs feature is experimental at -e line 1. Assertion failed: (hek), function Perl_ck_subr, file op.c, line 10558. Abort trap: 6 The experimental warning is expected. The assertion failure is not. When a call checker is invoked, the name of the subroutine is passed to it. op.c:ck_subr gets the name from the CVâs cv (CvGV) or, in the case of lexical subs, from its name hek (CvNAME_HEK). If neither exists, ck_subr cannot cope. Lexical subs never have a GV pointer. Lexical constants were acci- dentally having neither a GV pointer nor a hek. They should have a hek, like other lexical subs. (cherry picked from commit 83a72a15a3e8908c9fea8334e083e9329d425feb) M op.c M t/op/lexsub.t commit bf4a62f42f5451ce7caaba7891dd82801a8a0df4 Author: Father Chrysostomos <[email protected]> Date: Sat Jun 1 06:28:12 2013 -0700 lexsub.t: To-do tests for citing lex subs after errors This currently causes assertion failures on debugging builds. On non-debugging builds (untested), it probably crashes: my sub a { foo ref } # foo must not exist a(); (cherry picked from commit fe54d63b71ffdc66546e8a06b4ea561f58af2fc2) M t/op/lexsub.t ----------------------------------------------------------------------- Summary of changes: cop.h | 8 ++++++-- embed.fnc | 1 + embed.h | 1 + op.c | 51 ++++++++++++++++++++++++++++++--------------------- pod/perldelta.pod | 31 ++++++++++++++++++++++++++++++- pp.c | 7 ++++++- pp_hot.c | 11 +++++++++-- proto.h | 1 + t/op/lexsub.t | 38 +++++++++++++++++++++++++++++++++++++- toke.c | 9 +++++---- 10 files changed, 126 insertions(+), 32 deletions(-) diff --git a/cop.h b/cop.h index 94a1267..122e2d7 100644 --- a/cop.h +++ b/cop.h @@ -581,7 +581,9 @@ struct block_format { * decremented by LEAVESUB, the other by LEAVE. */ #define PUSHSUB_BASE(cx) \ - ENTRY_PROBE(GvENAME(CvGV(cv)), \ + ENTRY_PROBE(CvNAMED(cv) \ + ? HEK_KEY(CvNAME_HEK(cv)) \ + : GvENAME(CvGV(cv)), \ CopFILE((const COP *)CvSTART(cv)), \ CopLINE((const COP *)CvSTART(cv)), \ CopSTASHPV((const COP *)CvSTART(cv))); \ @@ -646,7 +648,9 @@ struct block_format { #define POPSUB(cx,sv) \ STMT_START { \ - RETURN_PROBE(GvENAME(CvGV((const CV*)cx->blk_sub.cv)), \ + RETURN_PROBE(CvNAMED(cx->blk_sub.cv) \ + ? HEK_KEY(CvNAME_HEK(cx->blk_sub.cv)) \ + : GvENAME(CvGV(cx->blk_sub.cv)), \ CopFILE((COP*)CvSTART((const CV*)cx->blk_sub.cv)), \ CopLINE((COP*)CvSTART((const CV*)cx->blk_sub.cv)), \ CopSTASHPV((COP*)CvSTART((const CV*)cx->blk_sub.cv))); \ diff --git a/embed.fnc b/embed.fnc index 480de45..efc1ab4 100644 --- a/embed.fnc +++ b/embed.fnc @@ -427,6 +427,7 @@ p |void |dump_sub_perl |NN const GV* gv|bool justperl Apd |void |fbm_compile |NN SV* sv|U32 flags ApdR |char* |fbm_instr |NN unsigned char* big|NN unsigned char* bigend \ |NN SV* littlestr|U32 flags +p |CV * |find_lexical_cv|PADOFFSET off : Defined in util.c, used only in perl.c p |char* |find_script |NN const char *scriptname|bool dosearch \ |NULLOK const char *const *const search_ext|I32 flags diff --git a/embed.h b/embed.h index 9054358..71456cb 100644 --- a/embed.h +++ b/embed.h @@ -1095,6 +1095,7 @@ #define dump_packsubs_perl(a,b) Perl_dump_packsubs_perl(aTHX_ a,b) #define dump_sub_perl(a,b) Perl_dump_sub_perl(aTHX_ a,b) #define finalize_optree(a) Perl_finalize_optree(aTHX_ a) +#define find_lexical_cv(a) Perl_find_lexical_cv(aTHX_ a) #define find_runcv_where(a,b,c) Perl_find_runcv_where(aTHX_ a,b,c) #define find_rundefsv2(a,b) Perl_find_rundefsv2(aTHX_ a,b) #define find_script(a,b,c,d) Perl_find_script(aTHX_ a,b,c,d) diff --git a/op.c b/op.c index eb8d33e..ff77450 100644 --- a/op.c +++ b/op.c @@ -7151,7 +7151,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) op_free(block); SvREFCNT_dec(compcv); PL_compcv = NULL; - goto clone; + goto setname; } /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to determine whether this sub definition is in the same scope as its @@ -7214,6 +7214,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) cv = compcv; *spot = cv; } + setname: if (!CvNAME_HEK(cv)) { CvNAME_HEK_set(cv, hek @@ -7223,6 +7224,8 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 0) ); } + if (const_sv) goto clone; + CvFILE_set_from_cop(cv, PL_curcop); CvSTASH_set(cv, PL_curstash); @@ -8170,7 +8173,6 @@ Perl_newCVREF(pTHX_ I32 flags, OP *o) dVAR; o->op_type = OP_PADCV; o->op_ppaddr = PL_ppaddr[OP_PADCV]; - return o; } return newUNOP(OP_RV2CV, flags, scalar(o)); } @@ -9891,6 +9893,28 @@ subroutine. =cut */ +/* shared by toke.c:yylex */ +CV * +Perl_find_lexical_cv(pTHX_ PADOFFSET off) +{ + PADNAME *name = PAD_COMPNAME(off); + CV *compcv = PL_compcv; + while (PadnameOUTER(name)) { + assert(PARENT_PAD_INDEX(name)); + compcv = CvOUTSIDE(PL_compcv); + name = PadlistNAMESARRAY(CvPADLIST(compcv)) + [off = PARENT_PAD_INDEX(name)]; + } + assert(!PadnameIsOUR(name)); + if (!PadnameIsSTATE(name) && SvMAGICAL(name)) { + MAGIC * mg = mg_find(name, PERL_MAGIC_proto); + assert(mg); + assert(mg->mg_obj); + return (CV *)mg->mg_obj; + } + return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off]; +} + CV * Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags) { @@ -9925,24 +9949,7 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags) gv = NULL; } break; case OP_PADCV: { - PADNAME *name = PAD_COMPNAME(rvop->op_targ); - CV *compcv = PL_compcv; - PADOFFSET off = rvop->op_targ; - while (PadnameOUTER(name)) { - assert(PARENT_PAD_INDEX(name)); - compcv = CvOUTSIDE(PL_compcv); - name = PadlistNAMESARRAY(CvPADLIST(compcv)) - [off = PARENT_PAD_INDEX(name)]; - } - assert(!PadnameIsOUR(name)); - if (!PadnameIsSTATE(name)) { - MAGIC * mg = mg_find(name, PERL_MAGIC_proto); - assert(mg); - assert(mg->mg_obj); - cv = (CV *)mg->mg_obj; - } - else cv = - (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off]; + cv = find_lexical_cv(rvop->op_targ); gv = NULL; } break; default: { @@ -10539,7 +10546,9 @@ Perl_ck_subr(pTHX_ OP *o) really need is a new call checker API that accepts a GV or string (or GV or CV). */ HEK * const hek = CvNAME_HEK(cv); - assert(hek); + /* After a syntax error in a lexical sub, the cv that + rv2cv_op_cv returns may be a nameless stub. */ + if (!hek) return ck_entersub_args_list(o);; namegv = (GV *)sv_newmortal(); gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek), SVf_UTF8 * !!HEK_UTF8(hek)); diff --git a/pod/perldelta.pod b/pod/perldelta.pod index f7cf937..029dc71 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -1,4 +1,4 @@ -=encoding utf8 +encoding utf8 =head1 NAME @@ -391,6 +391,35 @@ C<\x80..\xff> followed a UTF-8 string, e.g. [perl #118297]. +=item * + +Lexical constants (C<my sub a() { 42 }>) no longer crash when inlined. + +=item * + +Parameter prototypes attached to lexical subroutines are now respected when +compiling sub calls without parentheses. Previously, the prototypes were +honoured only for calls I<with> parentheses. [RT #116735] + +=item * + +Syntax errors in lexical subroutines in combination with calls to the same +subroutines no longer cause crashes at compile time. + +=item * + +The dtrace sub-entry probe now works with lexical subs, instead of +crashing [perl #118305]. + +=item * + +Undefining an inlinable lexical subroutine (C<my sub foo() { 42 } undef +&foo>) would result in a crash if warnings were turned on. + +=item * + +Deep recursion warnings no longer crash lexical subroutines. [RT #118521] + =back =head1 Known Problems diff --git a/pp.c b/pp.c index ed6fd5f..430cf85 100644 --- a/pp.c +++ b/pp.c @@ -969,7 +969,12 @@ PP(pp_undef) "Constant subroutine %"SVf" undefined", SVfARG(CvANON((const CV *)sv) ? newSVpvs_flags("(anonymous)", SVs_TEMP) - : sv_2mortal(newSVhek(GvENAME_HEK(CvGV((const CV *)sv)))))); + : sv_2mortal(newSVhek( + CvNAMED(sv) + ? CvNAME_HEK((CV *)sv) + : GvENAME_HEK(CvGV((const CV *)sv)) + )) + )); /* FALLTHROUGH */ case SVt_PVFM: { diff --git a/pp_hot.c b/pp_hot.c index 157c469..31ce429 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -2901,8 +2901,15 @@ Perl_sub_crush_depth(pTHX_ CV *cv) if (CvANON(cv)) Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine"); else { - SV* const tmpstr = sv_newmortal(); - gv_efullname3(tmpstr, CvGV(cv), NULL); + HEK *const hek = CvNAME_HEK(cv); + SV *tmpstr; + if (hek) { + tmpstr = sv_2mortal(newSVhek(hek)); + } + else { + tmpstr = sv_newmortal(); + gv_efullname3(tmpstr, CvGV(cv), NULL); + } Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"", SVfARG(tmpstr)); } diff --git a/proto.h b/proto.h index c2fe6f3..607eef8 100644 --- a/proto.h +++ b/proto.h @@ -1087,6 +1087,7 @@ PERL_CALLCONV void Perl_finalize_optree(pTHX_ OP* o) #define PERL_ARGS_ASSERT_FINALIZE_OPTREE \ assert(o) +PERL_CALLCONV CV * Perl_find_lexical_cv(pTHX_ PADOFFSET off); PERL_CALLCONV CV* Perl_find_runcv(pTHX_ U32 *db_seqp) __attribute__warn_unused_result__; diff --git a/t/op/lexsub.t b/t/op/lexsub.t index 86c7e26..0141399 100644 --- a/t/op/lexsub.t +++ b/t/op/lexsub.t @@ -8,7 +8,7 @@ BEGIN { *bar::like = *like; } no warnings 'deprecated'; -plan 128; +plan 136; # -------------------- Errors with feature disabled -------------------- # @@ -299,6 +299,9 @@ sub make_anon_with_state_sub{ is ref $_[0], 'ARRAY', 'state sub with proto'; } p(my @a); + p my @b; + state sub q () { 45 } + is q(), 45, 'state constant called with parens'; } { state sub x; @@ -318,6 +321,13 @@ sub make_anon_with_state_sub{ } r(1); } +like runperl( + switches => [ '-Mfeature=:all' ], + prog => 'state sub a { foo ref } a()', + stderr => 1 + ), + qr/syntax error/, + 'referencing a state sub after a syntax error does not crash'; # -------------------- my -------------------- # @@ -587,6 +597,9 @@ not_lexical11(); is ref $_[0], 'ARRAY', 'my sub with proto'; } p(my @a); + p @a; + my sub q () { 46 } + is q(), 46, 'my constant called with parens'; } { my sub x; @@ -607,6 +620,13 @@ not_lexical11(); eval q{ my sub george () { 2 } }; is $w, undef, 'no double free from constant my subs'; } +like runperl( + switches => [ '-Mfeature=:all' ], + prog => 'my sub a { foo ref } a()', + stderr => 1 + ), + qr/syntax error/, + 'referencing a my sub after a syntax error does not crash'; # -------------------- Interactions (and misc tests) -------------------- # @@ -675,3 +695,19 @@ eval 'sub not_lexical7 { my @x }'; } } } + +like runperl( + switches => [ '-Mfeature=:all', '-Mwarnings=FATAL,all', '-M-warnings=experimental::lexical_subs' ], + prog => 'my sub foo; sub foo { foo } foo', + stderr => 1 + ), + qr/Deep recursion on subroutine "foo"/, + 'deep recursion warnings for lexical subs do not crash'; + +like runperl( + switches => [ '-Mfeature=:all', '-Mwarnings=FATAL,all', '-M-warnings=experimental::lexical_subs' ], + prog => 'my sub foo() { 42 } undef &foo', + stderr => 1 + ), + qr/Constant subroutine foo undefined at /, + 'constant undefinition warnings for lexical subs do not crash'; diff --git a/toke.c b/toke.c index f1d09ef..d17a69c 100644 --- a/toke.c +++ b/toke.c @@ -6921,8 +6921,7 @@ Perl_yylex(pTHX) else { rv2cv_op = newOP(OP_PADANY, 0); rv2cv_op->op_targ = off; - rv2cv_op = (OP*)newCVREF(0, rv2cv_op); - cv = (CV *)PAD_SV(off); + cv = find_lexical_cv(off); } lex = TRUE; goto just_a_word; @@ -7251,7 +7250,8 @@ Perl_yylex(pTHX) } op_free(pl_yylval.opval); - pl_yylval.opval = rv2cv_op; + pl_yylval.opval = + off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op; pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN; PL_last_lop = PL_oldbufptr; PL_last_lop_op = OP_ENTERSUB; @@ -7347,7 +7347,8 @@ Perl_yylex(pTHX) gv = gv_fetchpv(PL_tokenbuf, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV); op_free(pl_yylval.opval); - pl_yylval.opval = rv2cv_op; + pl_yylval.opval = + off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op; pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN; PL_last_lop = PL_oldbufptr; PL_last_lop_op = OP_ENTERSUB; -- Perl5 Master Repository
