From: Nicholas Clark <nick@ccl4.org>
Date: Wed, 29 Jun 2005 15:58:14 +0000 (+0000)
Subject: First stab at not automatically creating an unused SV for GvSV
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c69033f2a629160559f680da8e4e5a7e3c4c3a0c;p=p5sagit%2Fp5-mst-13.2.git

First stab at not automatically creating an unused SV for GvSV
Enable it with -DPERL_DONT_CREATE_GVSV.
Currently if enabled 22 test scripts have failures, so still some way
to go.

p4raw-id: //depot/perl@25009
---

diff --git a/embed.fnc b/embed.fnc
index 8962aa9..af4f2cc 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1521,6 +1521,10 @@ ApR	|bool	|stashpv_hvname_match|NN const COP *cop|NN const HV *hv
 p	|void	|dump_sv_child	|SV *sv
 #endif
 
+#ifdef PERL_DONT_CREATE_GVSV
+Ap	|GV*	|gv_SVadd	|NN GV* gv
+#endif
+
 END_EXTERN_C
 /*
  * ex: set ts=8 sts=4 sw=4 noet:
diff --git a/embed.h b/embed.h
index c7745b3..e2dab2d 100644
--- a/embed.h
+++ b/embed.h
@@ -1637,6 +1637,9 @@
 #define dump_sv_child		Perl_dump_sv_child
 #endif
 #endif
+#ifdef PERL_DONT_CREATE_GVSV
+#define gv_SVadd		Perl_gv_SVadd
+#endif
 #define ck_anoncode		Perl_ck_anoncode
 #define ck_bitop		Perl_ck_bitop
 #define ck_concat		Perl_ck_concat
@@ -3609,6 +3612,9 @@
 #define dump_sv_child(a)	Perl_dump_sv_child(aTHX_ a)
 #endif
 #endif
+#ifdef PERL_DONT_CREATE_GVSV
+#define gv_SVadd(a)		Perl_gv_SVadd(aTHX_ a)
+#endif
 #define ck_anoncode(a)		Perl_ck_anoncode(aTHX_ a)
 #define ck_bitop(a)		Perl_ck_bitop(aTHX_ a)
 #define ck_concat(a)		Perl_ck_concat(aTHX_ a)
diff --git a/global.sym b/global.sym
index bb974dd..17d16b7 100644
--- a/global.sym
+++ b/global.sym
@@ -691,4 +691,5 @@ Perl_hv_placeholders_set
 Perl_gv_fetchpvn_flags
 Perl_gv_fetchsv
 Perl_stashpv_hvname_match
+Perl_gv_SVadd
 # ex: set ro:
diff --git a/gv.c b/gv.c
index 5fac589..e6993ad 100644
--- a/gv.c
+++ b/gv.c
@@ -37,6 +37,19 @@ Perl stores its global variables.
 static const char S_autoload[] = "AUTOLOAD";
 static const STRLEN S_autolen = sizeof(S_autoload)-1;
 
+
+#ifdef PERL_DONT_CREATE_GVSV
+GV *
+Perl_gv_SVadd(pTHX_ GV *gv)
+{
+    if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
+	Perl_croak(aTHX_ "Bad symbol for scalar");
+    if (!GvSV(gv))
+	GvSV(gv) = NEWSV(72,0);
+    return gv;
+}
+#endif
+
 GV *
 Perl_gv_AVadd(pTHX_ register GV *gv)
 {
@@ -96,7 +109,11 @@ Perl_gv_fetchfile(pTHX_ const char *name)
     gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
     if (!isGV(gv)) {
 	gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
-	sv_setpv(GvSV(gv), name);
+#ifdef PERL_DONT_CREATE_GVSV
+	GvSV(gv) = newSVpvn(name, tmplen - 2);
+#else
+	sv_setpvn(GvSV(gv), name, tmplen - 2);
+#endif
 	if (PERLDB_LINE)
 	    hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, PERL_MAGIC_dbfile);
     }
@@ -124,7 +141,11 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
     }
     Newz(602, gp, 1, GP);
     GvGP(gv) = gp_ref(gp);
+#ifdef PERL_DONT_CREATE_GVSV
+    GvSV(gv) = 0;
+#else
     GvSV(gv) = NEWSV(72,0);
+#endif
     GvLINE(gv) = CopLINE(PL_curcop);
     /* XXX Ideally this cast would be replaced with a change to const char*
        in the struct.  */
@@ -171,6 +192,14 @@ S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
     case SVt_PVHV:
 	(void)GvHVn(gv);
 	break;
+#ifdef PERL_DONT_CREATE_GVSV
+    case SVt_NULL:
+    case SVt_PVCV:
+    case SVt_PVFM:
+	break;
+    default:
+	(void)GvSVn(gv);
+#endif
     }
 }
 
@@ -546,8 +575,12 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
     vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
     ENTER;
 
-    if (!isGV(vargv))
+    if (!isGV(vargv)) {
 	gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
+#ifdef PERL_DONT_CREATE_GVSV
+	GvSV(vargv) = NEWSV(72,0);
+#endif
+    }
     LEAVE;
     varsv = GvSV(vargv);
     sv_setpvn(varsv, packname, packname_len);
@@ -1001,12 +1034,12 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	    goto ro_magicalize;
 
 	case ':':
-	    sv_setpv(GvSV(gv),PL_chopset);
+	    sv_setpv(GvSVn(gv),PL_chopset);
 	    goto magicalize;
 
 	case '?':
 #ifdef COMPLEX_STATUS
-	    SvUPGRADE(GvSV(gv), SVt_PVLV);
+	    SvUPGRADE(GvSVn(gv), SVt_PVLV);
 #endif
 	    goto magicalize;
 
@@ -1018,7 +1051,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	       now (rather than going to magicalize)
 	    */
 
-	    sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
+	    sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
 
 	    if (sv_type == SVt_PVHV)
 		require_errno(gv);
@@ -1038,7 +1071,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 			    "$%c is no longer supported", *name);
 	    break;
 	case '|':
-	    sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
+	    sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
 	    goto magicalize;
 
 	case '+':
@@ -1059,7 +1092,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	case '8':
 	case '9':
 	ro_magicalize:
-	    SvREADONLY_on(GvSV(gv));
+	    SvREADONLY_on(GvSVn(gv));
 	    /* FALL THROUGH */
 	case '[':
 	case '^':
@@ -1087,19 +1120,19 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	case '\024':	/* $^T */
 	case '\027':	/* $^W */
 	magicalize:
-	    sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
+	    sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
 	    break;
 
 	case '\014':	/* $^L */
-	    sv_setpvn(GvSV(gv),"\f",1);
-	    PL_formfeed = GvSV(gv);
+	    sv_setpvn(GvSVn(gv),"\f",1);
+	    PL_formfeed = GvSVn(gv);
 	    break;
 	case ';':
-	    sv_setpvn(GvSV(gv),"\034",1);
+	    sv_setpvn(GvSVn(gv),"\034",1);
 	    break;
 	case ']':
 	{
-	    SV * const sv = GvSV(gv);
+	    SV * const sv = GvSVn(gv);
 	    if (!sv_derived_from(PL_patchlevel, "version"))
 		(void *)upg_version(PL_patchlevel);
 	    GvSV(gv) = vnumify(PL_patchlevel);
@@ -1109,7 +1142,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	break;
 	case '\026':	/* $^V */
 	{
-	    SV * const sv = GvSV(gv);
+	    SV * const sv = GvSVn(gv);
 	    GvSV(gv) = new_version(PL_patchlevel);
 	    SvREADONLY_on(GvSV(gv));
 	    SvREFCNT_dec(sv);
@@ -1379,6 +1412,11 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
 
     if (!gv)
 	lim = DESTROY_amg;		/* Skip overloading entries. */
+#ifdef PERL_DONT_CREATE_GVSV
+    else if (!sv) {
+	/* Equivalent to !SvTRUE and !SvOK  */
+    }
+#endif
     else if (SvTRUE(sv))
 	amt.fallback=AMGfallYES;
     else if (SvOK(sv))
@@ -1414,17 +1452,17 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
 		   knowing *which* methods were declared as overloaded. */
 		/* GvSV contains the name of the method. */
 		GV *ngv = Nullgv;
+		SV *gvsv = GvSV(gv);
 
 		DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
 			"\" for overloaded \"%s\" in package \"%.256s\"\n",
 			     GvSV(gv), cp, hvname) );
-		if (!SvPOK(GvSV(gv))
-		    || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(GvSV(gv)),
+		if (!gvsv || !SvPOK(gvsv)
+		    || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
 						       FALSE)))
 		{
 		    /* Can be an import stub (created by "can"). */
-		    SV *gvsv = GvSV(gv);
-		    const char * const name = SvPOK(gvsv) ?  SvPVX_const(gvsv) : "???";
+		    const char * const name = (gvsv && SvPOK(gvsv)) ?  SvPVX_const(gvsv) : "???";
 		    Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
 				"in package \"%.256s\"",
 			       (GvCVGEN(gv) ? "Stub found while resolving"
diff --git a/gv.h b/gv.h
index c020510..d59307a 100644
--- a/gv.h
+++ b/gv.h
@@ -42,6 +42,14 @@ Return the SV from the GV.
 */
 
 #define GvSV(gv)	(GvGP(gv)->gp_sv)
+#ifdef PERL_DONT_CREATE_GVSV
+#define GvSVn(gv)	(GvGP(gv)->gp_sv ? \
+			 GvGP(gv)->gp_sv : \
+			 GvGP(gv_SVadd(gv))->gp_sv)
+#else
+#define GvSVn(gv)	GvSV(gv)
+#endif
+
 #define GvREFCNT(gv)	(GvGP(gv)->gp_refcnt)
 #define GvIO(gv)	((gv) && SvTYPE((SV*)gv) == SVt_PVGV && GvGP(gv) ? GvIOp(gv) : 0)
 #define GvIOp(gv)	(GvGP(gv)->gp_io)
diff --git a/makedef.pl b/makedef.pl
index 9753100..bc47833 100644
--- a/makedef.pl
+++ b/makedef.pl
@@ -789,6 +789,11 @@ unless ($define{'DEBUG_LEAKING_SCALARS_FORK_DUMP'}) {
 		    PL_dumper_fd
 		    )];
 }
+unless ($define{'PERL_DONT_CREATE_GVSV'}) {
+    skip_symbols [qw(
+		     Perl_gv_SVadd
+		    )];
+}
 
 unless ($define{'d_mmap'}) {
     skip_symbols [qw(
diff --git a/perl.c b/perl.c
index 5c3f416..cb82691 100644
--- a/perl.c
+++ b/perl.c
@@ -1371,9 +1371,9 @@ S_set_caret_X(pTHX) {
 	S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
 #else
 #ifdef OS2
-	sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
+	sv_setpv(GvSVn(tmpgv), os2_execname(aTHX));
 #else
-	sv_setpv(GvSV(tmpgv),PL_origargv[0]);
+	sv_setpv(GvSVn(tmpgv),PL_origargv[0]);
 #endif
 #endif
     }
@@ -3381,6 +3381,9 @@ S_init_main_stash(pTHX)
     PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
     GvMULTI_on(PL_replgv);
     (void)Perl_form(aTHX_ "%240s","");	/* Preallocate temp - for immediate signals. */
+#ifdef PERL_DONT_CREATE_GVSV
+    gv_SVadd(PL_errgv);
+#endif
     sv_grow(ERRSV, 240);	/* Preallocate - for immediate signals. */
     sv_setpvn(ERRSV, "", 0);
     PL_curstash = PL_defstash;
diff --git a/pp_hot.c b/pp_hot.c
index 1fba457..9cf214a 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -58,7 +58,7 @@ PP(pp_gvsv)
     if (PL_op->op_private & OPpLVAL_INTRO)
 	PUSHs(save_scalar(cGVOP_gv));
     else
-	PUSHs(GvSV(cGVOP_gv));
+	PUSHs(GvSVn(cGVOP_gv));
     RETURN;
 }
 
@@ -1473,7 +1473,7 @@ Perl_do_readline(pTHX)
 		    if (av_len(GvAVn(PL_last_in_gv)) < 0) {
 			IoFLAGS(io) &= ~IOf_START;
 			do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
-			sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
+			sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
 			SvSETMAGIC(GvSV(PL_last_in_gv));
 			fp = IoIFP(io);
 			goto have_fp;
diff --git a/proto.h b/proto.h
index 42cf557..a75cb74 100644
--- a/proto.h
+++ b/proto.h
@@ -2991,6 +2991,12 @@ PERL_CALLCONV bool	Perl_stashpv_hvname_match(pTHX_ const COP *cop, const HV *hv)
 PERL_CALLCONV void	Perl_dump_sv_child(pTHX_ SV *sv);
 #endif
 
+#ifdef PERL_DONT_CREATE_GVSV
+PERL_CALLCONV GV*	Perl_gv_SVadd(pTHX_ GV* gv)
+			__attribute__nonnull__(pTHX_1);
+
+#endif
+
 END_EXTERN_C
 /*
  * ex: set ts=8 sts=4 sw=4 noet:
diff --git a/sv.c b/sv.c
index 03a2589..3d12232 100644
--- a/sv.c
+++ b/sv.c
@@ -441,7 +441,11 @@ static void
 do_clean_named_objs(pTHX_ SV *sv)
 {
     if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
-	if ( SvOBJECT(GvSV(sv)) ||
+	if ((
+#ifdef PERL_DONT_CREATE_GVSV
+	     GvSV(sv) &&
+#endif
+	     SvOBJECT(GvSV(sv))) ||
 	     (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
 	     (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
 	     (GvIO(sv) && SvOBJECT(GvIO(sv))) ||