For lexical subs, reify CvGV from CvSTASH and CvNAME_HEK

From now on, the presence of a name hek implies a GV.  Any access to
CvGV will cause that implicit GV to be reified.

diff --git a/cv.h b/cv.h
index 21445b5..c060cab 100644 (file)
--- a/cv.h
+++ b/cv.h
@@ -49,8 +49,9 @@ See L<perlguts/Autoloading with XSUBs>.
 #define CvROOT(sv)     ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_root_u.xcv_root
 #define CvXSUB(sv)     ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_root_u.xcv_xsub
 #define CvXSUBANY(sv)  ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_start_u.xcv_xsubany
-#define CvGV(sv)       S_CvGV((const CV *)(sv))
+#define CvGV(sv)       S_CvGV(aTHX_ (CV *)(sv))
 #define CvGV_set(cv,gv)        Perl_cvgv_set(aTHX_ cv, gv)
+#define CvHASGV(cv)    cBOOL(SvANY(cv)->xcv_gv_u.xcv_gv)
 #define CvFILE(sv)     ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_file
 #ifdef USE_ITHREADS
 #  define CvFILE_set_from_cop(sv, cop) \
@@ -193,13 +194,6 @@ See L<perlguts/Autoloading with XSUBs>.
 /* Flags for newXS_flags  */
 #define XS_DYNAMIC_FILENAME    0x01    /* The filename isn't static  */
 
-PERL_STATIC_INLINE GV *
-S_CvGV(const CV *sv)
-{
-    return CvNAMED(sv)
-       ? 0
-       : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
-}
 PERL_STATIC_INLINE HEK *
 CvNAME_HEK(CV *sv)
 {

diff --git a/embed.fnc b/embed.fnc
index 8373e36..74f1ba9 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -535,6 +535,7 @@ Ap  |void   |gv_fullname4   |NN SV* sv|NN const GV* gv|NULLOK const char* prefix|bool
 : Used in scope.c
 pMox   |GP *   |newGP          |NN GV *const gv
 pX     |void   |cvgv_set       |NN CV* cv|NULLOK GV* gv
+poX    |GV *   |cvgv_from_hek  |NN CV* cv
 pX     |void   |cvstash_set    |NN CV* cv|NULLOK HV* stash
 Amd    |void   |gv_init        |NN GV* gv|NULLOK HV* stash \
                                 |NN const char* name|STRLEN len|int multi

diff --git a/ext/B/t/b.t b/ext/B/t/b.t
index 27b4105..8ee6510 100644 (file)
--- a/ext/B/t/b.t
+++ b/ext/B/t/b.t
@@ -404,10 +404,10 @@ SKIP:
         my $cv = B::svref_2object(\&bar);
         ok($cv, "make a B::CV from a lexical sub reference");
         isa_ok($cv, "B::CV");
-        my $gv = $cv->GV;
-        isa_ok($gv, "B::SPECIAL", "GV on a lexical sub");
         my $hek = $cv->NAME_HEK;
         is($hek, "bar", "check the NAME_HEK");
+        my $gv = $cv->GV;
+        isa_ok($gv, "B::GV", "GV on a lexical sub");
     }
     1;
 EOS

diff --git a/gv.c b/gv.c
index 134ed6e..7aa9f1e 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -216,7 +216,7 @@ Perl_newGP(pTHX_ GV *const gv)
 void
 Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
 {
-    GV * const oldgv = CvGV(cv);
+    GV * const oldgv = CvNAMED(cv) ? NULL : SvANY(cv)->xcv_gv_u.xcv_gv;
     HEK *hek;
     PERL_ARGS_ASSERT_CVGV_SET;
 
@@ -252,6 +252,29 @@ Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
     }
 }
 
+/* Convert CvSTASH + CvNAME_HEK into a GV.  Conceptually, all subs have a
+   GV, but for efficiency that GV may not in fact exist.  This function,
+   called by CvGV, reifies it. */
+
+GV *
+Perl_cvgv_from_hek(pTHX_ CV *cv)
+{
+    GV *gv;
+    PERL_ARGS_ASSERT_CVGV_FROM_HEK;
+    assert(SvTYPE(cv) == SVt_PVCV);
+    if (!CvSTASH(cv)) return NULL;
+    ASSUME(CvNAME_HEK(cv));
+    gv = (GV *)newSV(0);
+    gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)),
+               HEK_LEN(CvNAME_HEK(cv)),
+               SVf_UTF8 * !!HEK_UTF8(CvNAME_HEK(cv)));
+    unshare_hek(CvNAME_HEK(cv));
+    CvNAMED_off(cv);
+    SvANY(cv)->xcv_gv_u.xcv_gv = gv;
+    CvCVGV_RC_on(cv);
+    return gv;
+}
+
 /* Assign CvSTASH(cv) = st, handling weak references. */
 
 void

diff --git a/inline.h b/inline.h
index 0792694..ad6edf2 100644 (file)
--- a/inline.h
+++ b/inline.h
@@ -25,6 +25,14 @@ S_av_top_index(pTHX_ AV *av)
 
 /* ------------------------------- cv.h ------------------------------- */
 
+PERL_STATIC_INLINE GV *
+S_CvGV(pTHX_ CV *sv)
+{
+    return CvNAMED(sv)
+       ? Perl_cvgv_from_hek(aTHX_ sv)
+       : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
+}
+
 PERL_STATIC_INLINE I32 *
 S_CvDEPTHp(const CV * const sv)
 {

diff --git a/op.c b/op.c
index 9c0399b..be9a341 100644 (file)
--- a/op.c
+++ b/op.c
@@ -10172,7 +10172,7 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
     if (SvTYPE((SV*)cv) != SVt_PVCV)
        return NULL;
     if (flags & RV2CVOPCV_RETURN_NAME_GV) {
-       if (!CvANON(cv) || !gv)
+       if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv))
            gv = CvGV(cv);
        return (CV*)gv;
     } else {

diff --git a/pp_hot.c b/pp_hot.c
index 333bcc8..9e6df2a 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2595,15 +2595,15 @@ PP(pp_entersub)
        SV* sub_name;
 
        /* anonymous or undef'd function leaves us no recourse */
-       if (CvANON(cv) || !(gv = CvGV(cv))) {
-           if (CvNAMED(cv))
-               DIE(aTHX_ "Undefined subroutine &%"HEKf" called",
-                          HEKfARG(CvNAME_HEK(cv)));
+       if (CvLEXICAL(cv) && CvHASGV(cv))
+           DIE(aTHX_ "Undefined subroutine &%"SVf" called",
+                      SVfARG(cv_name(cv, NULL)));
+       if (CvANON(cv) || !CvHASGV(cv)) {
            DIE(aTHX_ "Undefined subroutine called");
        }
 
        /* autoloaded stub? */
-       if (cv != GvCV(gv)) {
+       if (cv != GvCV(gv = CvGV(cv))) {
            cv = GvCV(gv);
        }
        /* should call AUTOLOAD now? */

diff --git a/proto.h b/proto.h
index 3d8423d..642823d 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -828,6 +828,11 @@ PERL_CALLCONV void Perl_cv_undef(pTHX_ CV* cv)
 #define PERL_ARGS_ASSERT_CV_UNDEF      \
        assert(cv)
 
+PERL_CALLCONV GV *     Perl_cvgv_from_hek(pTHX_ CV* cv)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CVGV_FROM_HEK \
+       assert(cv)
+
 PERL_CALLCONV void     Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_CVGV_SET      \

diff --git a/universal.c b/universal.c
index c219411..200ce87 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -302,7 +302,8 @@ C<croak()>.  Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
 void
 Perl_croak_xs_usage(const CV *const cv, const char *const params)
 {
-    const GV *const gv = CvGV(cv);
+    /* Avoid CvGV as it requires aTHX.  */
+    const GV *const gv = CvNAMED(cv) ? NULL : cv->sv_any->xcv_gv_u.xcv_gv;
 
     PERL_ARGS_ASSERT_CROAK_XS_USAGE;