Allow CVs to point to HEKs rather than GVs

This will allow named lexical subs to exist independent of GVs.

7 files changed, 53 insertions, 10 deletions

diff --git a/cv.h b/cv.h
index 960ae1d05e..3d44a73968 100644
--- a/cv.h
+++ b/cv.h
@@ -49,7 +49,7 @@ 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)	(0+((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv)
+#define CvGV(sv)	S_CvGV((CV *)(sv))
 #define CvGV_set(cv,gv)	Perl_cvgv_set(aTHX_ cv, gv)
 #define CvFILE(sv)	((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_file
 #ifdef USE_ITHREADS
@@ -103,6 +103,7 @@ See L<perlguts/Autoloading with XSUBs>.
 #define CVf_DYNFILE	0x1000	/* The filename isn't static  */
 #define CVf_AUTOLOAD	0x2000	/* SvPVX contains AUTOLOADed sub name  */
 #define CVf_HASEVAL	0x4000	/* contains string eval  */
+#define CVf_NAMED	0x8000  /* Has a name HEK */
 
 /* This symbol for optimised communication between toke.c and op.c: */
 #define CVf_BUILTIN_ATTRS	(CVf_METHOD|CVf_LVALUE)
@@ -180,9 +181,28 @@ See L<perlguts/Autoloading with XSUBs>.
 #define CvHASEVAL_on(cv)	(CvFLAGS(cv) |= CVf_HASEVAL)
 #define CvHASEVAL_off(cv)	(CvFLAGS(cv) &= ~CVf_HASEVAL)
 
+#define CvNAMED(cv)		(CvFLAGS(cv) & CVf_NAMED)
+#define CvNAMED_on(cv)		(CvFLAGS(cv) |= CVf_NAMED)
+#define CvNAMED_off(cv)		(CvFLAGS(cv) &= ~CVf_NAMED)
+
 /* Flags for newXS_flags  */
 #define XS_DYNAMIC_FILENAME	0x01	/* The filename isn't static  */
 
+PERL_STATIC_INLINE GV *
+S_CvGV(CV *sv)
+{
+    return CvNAMED(sv)
+	? 0
+	: ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
+}
+PERL_STATIC_INLINE HEK *
+CvNAME_HEK(CV *sv)
+{
+    return CvNAMED(sv)
+	? ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_hek
+	: 0;
+}
+
 /*
 =head1 CV reference counts and CvOUTSIDE
 
diff --git a/ext/B/B.xs b/ext/B/B.xs
index 69c4aaed7b..ad839b5a2b 100644
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -1452,7 +1452,11 @@ MODULE = B	PACKAGE = B::IV
 #define PVAV_max_ix	sv_SSize_tp | offsetof(struct xpvav, xav_max)
 
 #define PVCV_stash_ix	sv_SVp | offsetof(struct xpvcv, xcv_stash) 
-#define PVCV_gv_ix	sv_SVp | offsetof(struct xpvcv, xcv_gv)
+#if PERL_VERSION > 17 || (PERL_VERSION == 17 && PERL_SUBVERSION >= 3)
+# define PVCV_gv_ix	sv_SVp | offsetof(struct xpvcv, xcv_gv_u.xcv_gv)
+#else
+# define PVCV_gv_ix	sv_SVp | offsetof(struct xpvcv, xcv_gv)
+#endif
 #define PVCV_file_ix	sv_char_pp | offsetof(struct xpvcv, xcv_file)
 #define PVCV_outside_ix	sv_SVp | offsetof(struct xpvcv, xcv_outside)
 #define PVCV_outside_seq_ix sv_U32p | offsetof(struct xpvcv, xcv_outside_seq)
diff --git a/gv.c b/gv.c
index e64c8f29f6..01ed1f574c 100644
--- a/gv.c
+++ b/gv.c
@@ -207,6 +207,7 @@ void
 Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
 {
     GV * const oldgv = CvGV(cv);
+    HEK *hek;
     PERL_ARGS_ASSERT_CVGV_SET;
 
     if (oldgv == gv)
@@ -221,8 +222,9 @@ Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
 	    sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
 	}
     }
+    else if ((hek = CvNAME_HEK(cv))) unshare_hek(hek);
 
-    SvANY(cv)->xcv_gv = gv;
+    SvANY(cv)->xcv_gv_u.xcv_gv = gv;
     assert(!CvCVGV_RC(cv));
 
     if (!gv)
diff --git a/pad.c b/pad.c
index 711fd21b97..68058be003 100644
--- a/pad.c
+++ b/pad.c
@@ -381,7 +381,8 @@ Perl_cv_undef(pTHX_ CV *cv)
 #endif
     SvPOK_off(MUTABLE_SV(cv));		/* forget prototype */
     sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
-    CvGV_set(cv, NULL);
+    if (CvNAMED(cv)) unshare_hek(CvNAME_HEK(cv));
+    else	     CvGV_set(cv, NULL);
 
     /* This statement and the subsequence if block was pad_undef().  */
     pad_peg("pad_undef");
@@ -1989,7 +1990,9 @@ Perl_cv_clone(pTHX_ CV *proto)
 
     CvFILE(cv)		= CvDYNFILE(proto) ? savepv(CvFILE(proto))
 					   : CvFILE(proto);
-    CvGV_set(cv,CvGV(proto));
+    if (CvNAMED(proto))
+	 SvANY(cv)->xcv_gv_u.xcv_hek = share_hek_hek(CvNAME_HEK(proto));
+    else CvGV_set(cv,CvGV(proto));
     CvSTASH_set(cv, CvSTASH(proto));
     OP_REFCNT_LOCK;
     CvROOT(cv)		= OpREFCNT_inc(CvROOT(proto));
diff --git a/pp.c b/pp.c
index 00b28aee41..a14b62be24 100644
--- a/pp.c
+++ b/pp.c
@@ -935,8 +935,14 @@ PP(pp_undef)
 	{
 	    /* let user-undef'd sub keep its identity */
 	    GV* const gv = CvGV((const CV *)sv);
+	    HEK * const hek = CvNAME_HEK((CV *)sv);
+	    if (hek) share_hek_hek(hek);
 	    cv_undef(MUTABLE_CV(sv));
-	    CvGV_set(MUTABLE_CV(sv), gv);
+	    if (gv) CvGV_set(MUTABLE_CV(sv), gv);
+	    else if (hek) {
+		SvANY((CV *)sv)->xcv_gv_u.xcv_hek = hek;
+		CvNAMED_on(sv);
+	    }
 	}
 	break;
     case SVt_PVGV:
diff --git a/sv.c b/sv.c
index 63523ddf43..2312a36663 100644
--- a/sv.c
+++ b/sv.c
@@ -5906,10 +5906,11 @@ S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
     assert(GvGP(gv));
     assert(!CvANON(cv));
     assert(CvGV(cv) == gv);
+    assert(!CvNAMED(cv));
 
     /* will the CV shortly be freed by gp_free() ? */
     if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
-	SvANY(cv)->xcv_gv = NULL;
+	SvANY(cv)->xcv_gv_u.xcv_gv = NULL;
 	return;
     }
 
@@ -5923,7 +5924,7 @@ S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
 
     CvANON_on(cv);
     CvCVGV_RC_on(cv);
-    SvANY(cv)->xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
+    SvANY(cv)->xcv_gv_u.xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
 }
 
 
@@ -12159,9 +12160,13 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
 		}
 		assert(!CvSLABBED(dstr));
 		if (CvDYNFILE(dstr)) CvFILE(dstr) = SAVEPV(CvFILE(dstr));
+		if (CvNAMED(dstr))
+		    SvANY((CV *)dstr)->xcv_gv_u.xcv_hek =
+			share_hek_hek(CvNAME_HEK((CV *)sstr));
 		/* don't dup if copying back - CvGV isn't refcounted, so the
 		 * duped GV may never be freed. A bit of a hack! DAPM */
-		SvANY(MUTABLE_CV(dstr))->xcv_gv =
+		else
+		  SvANY(MUTABLE_CV(dstr))->xcv_gv_u.xcv_gv =
 		    CvCVGV_RC(dstr)
 		    ? gv_dup_inc(CvGV(sstr), param)
 		    : (param->flags & CLONEf_JOIN_IN)
diff --git a/sv.h b/sv.h
index ebbc27a1ce..18d30152a3 100644
--- a/sv.h
+++ b/sv.h
@@ -459,7 +459,10 @@ typedef U16 cv_flags_t;
 	OP *	xcv_root;							\
 	void	(*xcv_xsub) (pTHX_ CV*);					\
     }		xcv_root_u;							\
-    GV *	xcv_gv;								\
+    union {								\
+	GV *	xcv_gv;							\
+	HEK *	xcv_hek;						\
+    }		xcv_gv_u;						\
     char *	xcv_file;							\
     PADLIST *	xcv_padlist;							\
     CV *	xcv_outside;							\