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 (file)
--- 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 (file)
--- 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 (file)
--- 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<gv> is a typeglob whose subroutine entry is a constant sub eligible for
+inlining, or C<gv> 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 (file)
--- 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 (file)
--- 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;