Don’t create pads for sub stubs

Two code paths, sv_2cv (for \&name) and get_cvn_flags (for
&{"name"}()) were using start_subparse and newATTRSUB to create a
subroutine stub, which is what usually happens for Perl subs (with
op trees).

This resulted in subs with unused pads attached to them, because
start_subparse sets up the pad, which must be accessible dur-
ing parsing.

One code path, gv_init, which (among other things) reifies a GV after
a sub declaration (like ‘sub foo;’, which for efficiency doesn’t
create a CV), created the subroutine stub itself, without using
start_subparse/newATTRSUB.

This commit takes the code from gv_init, makes it more generic so it
can apply to the other two cases, puts it in a new function called
newSTUB, and makes all three locations call it.

Now stub creation should be faster and use less memory.

Additionally, this commit causes sv_2cv and get_cvn_flags to bypass
bug #107370 (glob stringification not round-tripping properly).  They
used to stringify the GV and pass the string to newATTRSUB (wrapped in
an op, of all things) for it to look up the GV again.  While bug
been fixed, as it was a side effect of sv_2cv triggering bug #107370.

diff --git a/embed.fnc b/embed.fnc
index f7444e9..196cf1f 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1623,6 +1623,7 @@ Apr       |OP *   |newMYSUB       |I32 floor|NULLOK OP *o|NULLOK OP *proto \
 #else
 Apr    |void   |newMYSUB       |I32 floor|NULLOK OP *o|NULLOK OP *proto|NULLOK OP *attrs|NULLOK OP *block
 #endif
+p      |CV*    |newSTUB        |NN GV *gv|bool fake
 : Used in perly.y
 p      |OP *   |my_attrs       |NN OP *o|NULLOK OP *attrs
 #if defined(USE_ITHREADS)

diff --git a/embed.h b/embed.h
index 2f819d7..2a4585c 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1158,6 +1158,7 @@
 #define my_swabn               Perl_my_swabn
 #define my_unexec()            Perl_my_unexec(aTHX)
 #define newATTRSUB_flags(a,b,c,d,e,f)  Perl_newATTRSUB_flags(aTHX_ a,b,c,d,e,f)
+#define newSTUB(a,b)           Perl_newSTUB(aTHX_ a,b)
 #define newXS_len_flags(a,b,c,d,e,f,g) Perl_newXS_len_flags(aTHX_ a,b,c,d,e,f,g)
 #define nextargv(a)            Perl_nextargv(aTHX_ a)
 #define oopsAV(a)              Perl_oopsAV(aTHX_ a)

diff --git a/gv.c b/gv.c
index 6c1e73e..c217bed 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -368,7 +368,7 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag
     gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
     if (flags & GV_ADDMULTI || doproto)        /* doproto means it */
        GvMULTI_on(gv);                 /* _was_ mentioned */
-    if (doproto) {                     /* Replicate part of newSUB here. */
+    if (doproto) {
        CV *cv;
        if (has_constant) {
            /* newCONSTSUB takes ownership of the reference from us.  */
@@ -382,17 +382,10 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag
               from a reference to CV.  */
            if (exported_constant)
                GvIMPORTED_CV_on(gv);
+           CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */
        } else {
-           ENTER;
-           (void) start_subparse(0,0); /* Create empty CV in compcv. */
-           cv = PL_compcv;
-           GvCV_set(gv,cv);
-           LEAVE;
+           cv = newSTUB(gv,1);
        }
-
-       CvGV_set(cv, gv);
-       CvFILE_set_from_cop(cv, PL_curcop);
-       CvSTASH_set(cv, PL_curstash);
        if (proto) {
            sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
                            SV_HAS_TRAILING_NUL);

diff --git a/op.c b/op.c
index 01b871d..0b28b9a 100644 (file)
--- a/op.c
+++ b/op.c
@@ -7300,6 +7300,23 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
     return cv;
 }
 
+CV *
+Perl_newSTUB(pTHX_ GV *gv, bool fake)
+{
+    register CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
+    PERL_ARGS_ASSERT_NEWSTUB;
+    assert(!GvCVu(gv));
+    GvCV_set(gv, cv);
+    GvCVGEN(gv) = 0;
+    if (!fake && HvENAME_HEK(GvSTASH(gv)))
+       mro_method_changed_in(GvSTASH(gv));
+    CvGV_set(cv, gv);
+    CvFILE_set_from_cop(cv, PL_curcop);
+    CvSTASH_set(cv, PL_curstash);
+    GvMULTI_on(gv);
+    return cv;
+}
+
 /*
 =for apidoc U||newXS
 

diff --git a/perl.c b/perl.c
index a5ed4a2..ae4390e 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -2527,10 +2527,7 @@ Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
      * It has the same effect as "sub name;", i.e. just a forward
      * declaration! */
     if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
-       SV *const sv = newSVpvn_flags(name, len, flags & SVf_UTF8);
-       return newSUB(start_subparse(FALSE, 0),
-                     newSVOP(OP_CONST, 0, sv),
-                     NULL, NULL);
+       return newSTUB(gv,0);
     }
     if (gv)
        return GvCVu(gv);

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index e547ceb..7d85af4 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -4821,10 +4821,6 @@ was not a reference to an unblessed hash or array.
 (F) Your machine doesn't implement the umask function and you tried to
 use it to restrict permissions for yourself (EXPR & 0700).
 
-=item Unable to create sub named "%s"
-
-(F) You attempted to create or access a subroutine with an illegal name.
-
 =item Unbalanced context: %d more PUSHes than POPs
 
 (W internal) The exit code detected an internal inconsistency in how

diff --git a/proto.h b/proto.h
index bd23296..e1e116c 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -2714,6 +2714,11 @@ PERL_CALLCONV OP*        Perl_newSTATEOP(pTHX_ I32 flags, char* label, OP* o)
                        __attribute__malloc__
                        __attribute__warn_unused_result__;
 
+PERL_CALLCONV CV*      Perl_newSTUB(pTHX_ GV *gv, bool fake)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NEWSTUB       \
+       assert(gv)
+
 /* PERL_CALLCONV CV*   Perl_newSUB(pTHX_ I32 floor, OP* o, OP* proto, OP* block); */
 PERL_CALLCONV SV*      Perl_newSV(pTHX_ const STRLEN len)
                        __attribute__malloc__

diff --git a/sv.c b/sv.c
index ec80a16..b96f7c1 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -9021,20 +9021,10 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
        }
        *st = GvESTASH(gv);
        if (lref & ~GV_ADDMG && !GvCVu(gv)) {
-           SV *tmpsv;
-           ENTER;
-           tmpsv = newSV(0);
-           gv_efullname3(tmpsv, gv, NULL);
            /* XXX this is probably not what they think they're getting.
             * It has the same effect as "sub name;", i.e. just a forward
             * declaration! */
-           newSUB(start_subparse(FALSE, 0),
-                  newSVOP(OP_CONST, 0, tmpsv),
-                  NULL, NULL);
-           LEAVE;
-           if (!GvCVu(gv))
-               Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
-                          SVfARG(SvOK(sv) ? sv : &PL_sv_no));
+           newSTUB(gv,0);
        }
        return GvCVu(gv);
     }