From: Nicholas Clark Date: Tue, 20 Dec 2005 20:13:12 +0000 (+0000) Subject: Take care in toke.c not to convert constant subroutine reference X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=62d55b227f6b1e95d65e7faf12ed22fd467e4c0e;p=p5sagit%2Fp5-mst-13.2.git Take care in toke.c not to convert constant subroutine reference proxies into full blown PVGVs with PVCVs, and recognise them and inline their values. Adds a new function gv_const_sv(gv) to return the value of the constant subroutine from a GV, and adds a cv parameter to S_intuit_method. p4raw-id: //depot/perl@26427 --- diff --git a/embed.fnc b/embed.fnc index ccc1500..4d91c30 100644 --- a/embed.fnc +++ b/embed.fnc @@ -150,6 +150,7 @@ Afnp |int |printf_nocontext|NN const char* fmt|... #endif p |void |cv_ckproto |NN const CV* cv|NULLOK const GV* gv|NULLOK const char* p pd |CV* |cv_clone |NN CV* proto +ApdR |SV* |gv_const_sv |NN GV* gv ApdR |SV* |cv_const_sv |NULLOK CV* cv pR |SV* |op_const_sv |NULLOK const OP* o|NULLOK CV* cv Apd |void |cv_undef |NN CV* cv @@ -1356,7 +1357,7 @@ s |void |checkcomma |NN char *s|NN const char *name|NN const char *what s |bool |feature_is_enabled|NN char* name|STRLEN namelen s |void |force_ident |NN const char *s|int kind s |void |incline |NN char *s -s |int |intuit_method |NN char *s|NULLOK GV *gv +s |int |intuit_method |NN char *s|NULLOK GV *gv|NULLOK CV *cv s |int |intuit_more |NN char *s s |I32 |lop |I32 f|int x|NN char *s rs |void |missingterm |NULLOK char *s diff --git a/embed.h b/embed.h index c2242cb..10e6af3 100644 --- a/embed.h +++ b/embed.h @@ -118,6 +118,7 @@ #define cv_ckproto Perl_cv_ckproto #define cv_clone Perl_cv_clone #endif +#define gv_const_sv Perl_gv_const_sv #define cv_const_sv Perl_cv_const_sv #ifdef PERL_CORE #define op_const_sv Perl_op_const_sv @@ -2167,6 +2168,7 @@ #define cv_ckproto(a,b,c) Perl_cv_ckproto(aTHX_ a,b,c) #define cv_clone(a) Perl_cv_clone(aTHX_ a) #endif +#define gv_const_sv(a) Perl_gv_const_sv(aTHX_ a) #define cv_const_sv(a) Perl_cv_const_sv(aTHX_ a) #ifdef PERL_CORE #define op_const_sv(a,b) Perl_op_const_sv(aTHX_ a,b) @@ -3420,7 +3422,7 @@ #define feature_is_enabled(a,b) S_feature_is_enabled(aTHX_ a,b) #define force_ident(a,b) S_force_ident(aTHX_ a,b) #define incline(a) S_incline(aTHX_ a) -#define intuit_method(a,b) S_intuit_method(aTHX_ a,b) +#define intuit_method(a,b,c) S_intuit_method(aTHX_ a,b,c) #define intuit_more(a) S_intuit_more(aTHX_ a) #define lop(a,b,c) S_lop(aTHX_ a,b,c) #define missingterm(a) S_missingterm(aTHX_ a) diff --git a/gv.c b/gv.c index 9e4dcad..418e08c 100644 --- a/gv.c +++ b/gv.c @@ -122,6 +122,25 @@ Perl_gv_fetchfile(pTHX_ const char *name) return gv; } +/* +=for apidoc gv_const_sv + +If C is a typeglob whose subroutine entry is a constant sub eligible for +inlining, or C is a placeholder reference that would be promoted to such +a typeglob, then returns the value returned by the sub. Otherwise, returns +NULL. + +=cut +*/ + +SV * +Perl_gv_const_sv(pTHX_ GV *gv) +{ + if (SvTYPE(gv) == SVt_PVGV) + return cv_const_sv(GvCVu(gv)); + return SvROK(gv) ? SvRV(gv) : NULL; +} + void Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) { diff --git a/proto.h b/proto.h index f1922a3..ff0e856 100644 --- a/proto.h +++ b/proto.h @@ -290,6 +290,10 @@ PERL_CALLCONV void Perl_cv_ckproto(pTHX_ const CV* cv, const GV* gv, const char* PERL_CALLCONV CV* Perl_cv_clone(pTHX_ CV* proto) __attribute__nonnull__(pTHX_1); +PERL_CALLCONV SV* Perl_gv_const_sv(pTHX_ GV* gv) + __attribute__warn_unused_result__ + __attribute__nonnull__(pTHX_1); + PERL_CALLCONV SV* Perl_cv_const_sv(pTHX_ CV* cv) __attribute__warn_unused_result__; @@ -3772,7 +3776,7 @@ STATIC void S_force_ident(pTHX_ const char *s, int kind) STATIC void S_incline(pTHX_ char *s) __attribute__nonnull__(pTHX_1); -STATIC int S_intuit_method(pTHX_ char *s, GV *gv) +STATIC int S_intuit_method(pTHX_ char *s, GV *gv, CV *cv) __attribute__nonnull__(pTHX_1); STATIC int S_intuit_more(pTHX_ char *s) diff --git a/toke.c b/toke.c index 8bdba31..0aba721 100644 --- a/toke.c +++ b/toke.c @@ -2109,7 +2109,7 @@ S_intuit_more(pTHX_ register char *s) */ STATIC int -S_intuit_method(pTHX_ char *start, GV *gv) +S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) { char *s = start + (*start == '$'); char tmpbuf[sizeof PL_tokenbuf]; @@ -2117,16 +2117,17 @@ S_intuit_method(pTHX_ char *start, GV *gv) GV* indirgv; if (gv) { - CV *cv; - if (GvIO(gv)) + if (SvTYPE(gv) == SVt_PVGV && GvIO(gv)) return 0; - if ((cv = GvCVu(gv))) { - const char *proto = SvPVX_const(cv); - if (proto) { - if (*proto == ';') - proto++; - if (*proto == '*') - return 0; + if (cv) { + if (SvPOK(cv)) { + const char *proto = SvPVX_const(cv); + if (proto) { + if (*proto == ';') + proto++; + if (*proto == '*') + return 0; + } } } else gv = 0; @@ -4284,8 +4285,14 @@ Perl_yylex(pTHX) } else { len = 0; - if (!gv) - gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV); + if (!gv) { + /* Mustn't actually add anything to a symbol table. + But also don't want to "initialise" any placeholder + constants that might already be there into full + blown PVGVs with attached PVCV. */ + gv = gv_fetchpv(PL_tokenbuf, GV_NOADD_NOINIT, + SVt_PVCV); + } } /* if we saw a global override before, get the right name */ @@ -4347,7 +4354,8 @@ Perl_yylex(pTHX) /* Two barewords in a row may indicate method call. */ - if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv))) + if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && + (tmp = intuit_method(s, gv, cv))) return REPORT(tmp); /* If not a declared subroutine, it's an indirect object. */ @@ -4385,7 +4393,7 @@ Perl_yylex(pTHX) CLINE; if (cv) { for (d = s + 1; SPACE_OR_TAB(*d); d++) ; - if (*d == ')' && (sv = cv_const_sv(cv))) { + if (*d == ')' && (sv = gv_const_sv(gv))) { s = d + 1; goto its_constant; } @@ -4399,7 +4407,7 @@ Perl_yylex(pTHX) /* If followed by var or block, call it a method (unless sub) */ - if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) { + if ((*s == '$' || *s == '{') && (!gv || !cv)) { PL_last_lop = PL_oldbufptr; PL_last_lop_op = OP_METHOD; PREBLOCK(METHOD); @@ -4409,7 +4417,7 @@ Perl_yylex(pTHX) if (!orig_keyword && (isIDFIRST_lazy_if(s,UTF) || *s == '$') - && (tmp = intuit_method(s,gv))) + && (tmp = intuit_method(s, gv, cv))) return REPORT(tmp); /* Not a method, so call it a subroutine (if defined) */ @@ -4420,7 +4428,7 @@ Perl_yylex(pTHX) "Ambiguous use of -%s resolved as -&%s()", PL_tokenbuf, PL_tokenbuf); /* Check for a constant sub */ - if ((sv = cv_const_sv(cv))) { + if ((sv = gv_const_sv(gv))) { its_constant: SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv); ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv); @@ -4429,6 +4437,14 @@ Perl_yylex(pTHX) } /* Resolve to GV now. */ + if (SvTYPE(gv) != SVt_PVGV) { + gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV); + assert (SvTYPE(gv) == SVt_PVGV); + /* cv must have been some sort of placeholder, so + now needs replacing with a real code reference. */ + cv = GvCV(gv); + } + op_free(yylval.opval); yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv)); yylval.opval->op_private |= OPpENTERSUB_NOPAREN;