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.

9 files changed, 50 insertions, 18 deletions

diff --git a/cv.h b/cv.h
index 21445b52f0..c060cabdff 100644
--- 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 8373e36880..74f1ba990b 100644
--- 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 27b41054aa..8ee6510372 100644
--- 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 134ed6ea53..7aa9f1ee68 100644
--- 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 0792694650..ad6edf20df 100644
--- 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 9c0399b311..be9a341e9d 100644
--- 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 333bcc8b48..9e6df2a3a5 100644
--- 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 3d8423df44..642823dc43 100644
--- 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 c219411ed7..200ce875b9 100644
--- 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;