From: Nicholas Clark <nick@ccl4.org>
Date: Thu, 23 Feb 2006 11:11:12 +0000 (+0000)
Subject: Remove get magic from typeglobs. This means that PVGVs holding
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=180488f8452e93d2afa0f62b189be1cc9ac6ba1a;p=p5sagit%2Fp5-mst-13.2.git

Remove get magic from typeglobs. This means that PVGVs holding
typeglobs never need to use SvPVX. This comes at price - typeglobs
were using magic get for their stringificiation, and to pass SvOK(),
so need to make typeglobs SvOK by default (by sucking SVp_SCREAM into
SVf_OK - it's the only flag left), tweak SvSCREAM() to also check
SVp_POK, and teach sv_2[inpu]v how to convert globs.
However, it should free up SvPVX for the next part of the plan to
pointer indirections, and therefore CPU cache pressure.

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

diff --git a/embed.fnc b/embed.fnc
index 4dbeb36..2021419 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -406,7 +406,6 @@ p	|int	|magic_freeovrld|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_get	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_getarylen|NN SV* sv|NN const MAGIC* mg
 p	|int	|magic_getdefelem|NN SV* sv|NN MAGIC* mg
-p	|int	|magic_getglob	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_getnkeys	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_getpack	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_getpos	|NN SV* sv|NN MAGIC* mg
@@ -734,6 +733,9 @@ p	|void	|sub_crush_depth|NN CV* cv
 Apd	|bool	|sv_2bool	|NN SV* sv
 Apd	|CV*	|sv_2cv		|NULLOK SV* sv|NN HV** st|NN GV** gvp|I32 lref
 Apd	|IO*	|sv_2io		|NN SV* sv
+#ifdef PERL_IN_SV_C
+s	|char*	|glob_2inpuv	|NN GV* gv|NULLOK STRLEN *len|bool want_number
+#endif
 Amb	|IV	|sv_2iv		|NN SV* sv
 Apd	|IV	|sv_2iv_flags	|NN SV* sv|I32 flags
 Apd	|SV*	|sv_2mortal	|NULLOK SV* sv
diff --git a/embed.h b/embed.h
index a47fd20..66f5065 100644
--- a/embed.h
+++ b/embed.h
@@ -404,7 +404,6 @@
 #define magic_get		Perl_magic_get
 #define magic_getarylen		Perl_magic_getarylen
 #define magic_getdefelem	Perl_magic_getdefelem
-#define magic_getglob		Perl_magic_getglob
 #define magic_getnkeys		Perl_magic_getnkeys
 #define magic_getpack		Perl_magic_getpack
 #define magic_getpos		Perl_magic_getpos
@@ -774,6 +773,11 @@
 #define sv_2bool		Perl_sv_2bool
 #define sv_2cv			Perl_sv_2cv
 #define sv_2io			Perl_sv_2io
+#ifdef PERL_IN_SV_C
+#ifdef PERL_CORE
+#define glob_2inpuv		S_glob_2inpuv
+#endif
+#endif
 #define sv_2iv_flags		Perl_sv_2iv_flags
 #define sv_2mortal		Perl_sv_2mortal
 #define sv_2nv			Perl_sv_2nv
@@ -2471,7 +2475,6 @@
 #define magic_get(a,b)		Perl_magic_get(aTHX_ a,b)
 #define magic_getarylen(a,b)	Perl_magic_getarylen(aTHX_ a,b)
 #define magic_getdefelem(a,b)	Perl_magic_getdefelem(aTHX_ a,b)
-#define magic_getglob(a,b)	Perl_magic_getglob(aTHX_ a,b)
 #define magic_getnkeys(a,b)	Perl_magic_getnkeys(aTHX_ a,b)
 #define magic_getpack(a,b)	Perl_magic_getpack(aTHX_ a,b)
 #define magic_getpos(a,b)	Perl_magic_getpos(aTHX_ a,b)
@@ -2836,6 +2839,11 @@
 #define sv_2bool(a)		Perl_sv_2bool(aTHX_ a)
 #define sv_2cv(a,b,c,d)		Perl_sv_2cv(aTHX_ a,b,c,d)
 #define sv_2io(a)		Perl_sv_2io(aTHX_ a)
+#ifdef PERL_IN_SV_C
+#ifdef PERL_CORE
+#define glob_2inpuv(a,b,c)	S_glob_2inpuv(aTHX_ a,b,c)
+#endif
+#endif
 #define sv_2iv_flags(a,b)	Perl_sv_2iv_flags(aTHX_ a,b)
 #define sv_2mortal(a)		Perl_sv_2mortal(aTHX_ a)
 #define sv_2nv(a)		Perl_sv_2nv(aTHX_ a)
diff --git a/ext/Devel/Peek/t/Peek.t b/ext/Devel/Peek/t/Peek.t
index b8ee13a..1be75cc 100644
--- a/ext/Devel/Peek/t/Peek.t
+++ b/ext/Devel/Peek/t/Peek.t
@@ -305,7 +305,7 @@ do_test(17,
 	*a,
 'SV = PVGV\\($ADDR\\) at $ADDR
   REFCNT = 5
-  FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\)
+  FLAGS = \\(SMG,SCREAM,MULTI(?:,IN_PAD)?\\)
   IV = 0
   NV = 0
   PV = 0
diff --git a/gv.c b/gv.c
index d866b66..20c2d47 100644
--- a/gv.c
+++ b/gv.c
@@ -205,6 +205,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
     GvCVGEN(gv) = 0;
     GvEGV(gv) = gv;
     sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, NULL, 0);
+    SvSCREAM_on(gv);
     GvSTASH(gv) = stash;
     if (stash)
 	Perl_sv_add_backref(aTHX_ (SV*)stash, (SV*)gv);
diff --git a/mg.c b/mg.c
index d9e6d76..004f319 100644
--- a/mg.c
+++ b/mg.c
@@ -1837,21 +1837,6 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
 }
 
 int
-Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
-{
-    const U32 wasfake = SvFLAGS(sv) & SVf_FAKE;
-    PERL_UNUSED_ARG(mg);
-
-    /* FAKE globs can get coerced, so need to turn this off temporarily if it
-       is on.  */
-    SvFAKE_off(sv);
-    gv_efullname3(sv,((GV*)sv), "*");
-    SvFLAGS(sv) |= wasfake;
-
-    return 0;
-}
-
-int
 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
 {
     GV* gv;
@@ -1859,6 +1844,12 @@ Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
 
     if (!SvOK(sv))
 	return 0;
+    if (SvFLAGS(sv) & SVp_SCREAM
+	&& (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVGV)) {
+	/* We're actually already a typeglob, so don't need the stuff below.
+	 */
+	return 0;
+    }
     gv =  gv_fetchsv(sv, GV_ADD, SVt_PVGV);
     if (sv == (SV*)gv)
 	return 0;
diff --git a/perl.h b/perl.h
index 75c4932..78469bd 100644
--- a/perl.h
+++ b/perl.h
@@ -4497,7 +4497,7 @@ MGVTBL_SET(
 
 MGVTBL_SET(
     PL_vtbl_glob,
-    MEMBER_TO_FPTR(Perl_magic_getglob),
+    NULL,
     MEMBER_TO_FPTR(Perl_magic_setglob),
     NULL,
     NULL,
diff --git a/proto.h b/proto.h
index 657ca7b..b2d6a93 100644
--- a/proto.h
+++ b/proto.h
@@ -1081,10 +1081,6 @@ PERL_CALLCONV int	Perl_magic_getdefelem(pTHX_ SV* sv, MAGIC* mg)
 			__attribute__nonnull__(pTHX_1)
 			__attribute__nonnull__(pTHX_2);
 
-PERL_CALLCONV int	Perl_magic_getglob(pTHX_ SV* sv, MAGIC* mg)
-			__attribute__nonnull__(pTHX_1)
-			__attribute__nonnull__(pTHX_2);
-
 PERL_CALLCONV int	Perl_magic_getnkeys(pTHX_ SV* sv, MAGIC* mg)
 			__attribute__nonnull__(pTHX_1)
 			__attribute__nonnull__(pTHX_2);
@@ -2033,6 +2029,11 @@ PERL_CALLCONV CV*	Perl_sv_2cv(pTHX_ SV* sv, HV** st, GV** gvp, I32 lref)
 PERL_CALLCONV IO*	Perl_sv_2io(pTHX_ SV* sv)
 			__attribute__nonnull__(pTHX_1);
 
+#ifdef PERL_IN_SV_C
+STATIC char*	S_glob_2inpuv(pTHX_ GV* gv, STRLEN *len, bool want_number)
+			__attribute__nonnull__(pTHX_1);
+
+#endif
 /* PERL_CALLCONV IV	sv_2iv(pTHX_ SV* sv)
 			__attribute__nonnull__(pTHX_1); */
 
diff --git a/sv.c b/sv.c
index ca0c010..b4e69f2 100644
--- a/sv.c
+++ b/sv.c
@@ -1711,6 +1711,31 @@ Perl_looks_like_number(pTHX_ SV *sv)
     return grok_number(sbegin, len, NULL);
 }
 
+STATIC char *
+S_glob_2inpuv(pTHX_ GV *gv, STRLEN *len, bool want_number)
+{
+    const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
+    SV *const buffer = sv_newmortal();
+
+    /* FAKE globs can get coerced, so need to turn this off temporarily if it
+       is on.  */
+    SvFAKE_off(gv);
+    gv_efullname3(buffer, gv, "*");
+    SvFLAGS(gv) |= wasfake;
+
+    if (want_number) {
+	/* We know that all GVs stringify to something that is not-a-number,
+	   so no need to test that.  */
+	if (ckWARN(WARN_NUMERIC))
+	    not_a_number(buffer);
+	/* We just want something true to return, so that S_sv_2iuv_common
+	   can tail call us and return true.  */
+	return (char *) 1;
+    } else {
+	return SvPV(buffer, *len);
+    }
+}
+
 /* Actually, ISO C leaves conversion of UV to IV undefined, but
    until proven guilty, assume that things are not that bad... */
 
@@ -2071,6 +2096,13 @@ S_sv_2iuv_common(pTHX_ SV *sv) {
 	}
     }
     else  {
+	if (((SvFLAGS(sv) & (SVp_POK|SVp_SCREAM)) == SVp_SCREAM)
+	    && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV)) {
+	    return PTR2IV(glob_2inpuv((GV *)sv, NULL, TRUE));
+	}
+	if (SvTYPE(sv) == SVt_PVGV)
+	    sv_dump(sv);
+
 	if (!(SvFLAGS(sv) & SVs_PADTMP)) {
 	    if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
 		report_uninit(sv);
@@ -2418,6 +2450,12 @@ Perl_sv_2nv(pTHX_ register SV *sv)
 #endif /* NV_PRESERVES_UV */
     }
     else  {
+	if (((SvFLAGS(sv) & (SVp_POK|SVp_SCREAM)) == SVp_SCREAM)
+	    && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV)) {
+	    glob_2inpuv((GV *)sv, NULL, TRUE);
+	    return 0.0;
+	}
+
 	if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
 	    report_uninit(sv);
 	assert (SvTYPE(sv) >= SVt_NV);
@@ -2750,6 +2788,11 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
 #endif
     }
     else {
+	if (((SvFLAGS(sv) & (SVp_POK|SVp_SCREAM)) == SVp_SCREAM)
+	    && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV)) {
+	    return glob_2inpuv((GV *)sv, lp, FALSE);
+	}
+
 	if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
 	    report_uninit(sv);
 	if (lp)
@@ -2880,8 +2923,13 @@ Perl_sv_2bool(pTHX_ register SV *sv)
 	else {
 	    if (SvNOKp(sv))
 		return SvNVX(sv) != 0.0;
-	    else
-		return FALSE;
+	    else {
+		if ((SvFLAGS(sv) & SVp_SCREAM)
+		    && (SvTYPE(sv) == (SVt_PVGV) || SvTYPE(sv) == (SVt_PVLV)))
+		    return TRUE;
+		else
+		    return FALSE;
+	    }
 	}
     }
 }
@@ -3138,6 +3186,7 @@ S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype)
 #endif
 
     (void)SvOK_off(dstr);
+    SvSCREAM_on(dstr);
     GvINTRO_off(dstr);		/* one-shot flag */
     gp_free((GV*)dstr);
     GvGP(dstr) = gp_ref(GvGP(sstr));
@@ -3605,6 +3654,18 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
 	    if (ckWARN(WARN_MISC))
 		Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
 	}
+	else if ((stype == SVt_PVGV || stype == SVt_PVLV)
+		 && (sflags & SVp_SCREAM)) {
+	    /* This stringification rule for globs is spread in 3 places.
+	       This feels bad. FIXME.  */
+	    const U32 wasfake = sflags & SVf_FAKE;
+
+	    /* FAKE globs can get coerced, so need to turn this off
+	       temporarily if it is on.  */
+	    SvFAKE_off(sstr);
+	    gv_efullname3(dstr, (GV *)sstr, "*");
+	    SvFLAGS(sstr) |= wasfake;
+	}
 	else
 	    (void)SvOK_off(dstr);
     }
@@ -7592,9 +7653,12 @@ S_sv_unglob(pTHX_ SV *sv)
 {
     dVAR;
     void *xpvmg;
+    SV *temp = sv_newmortal();
 
     assert(SvTYPE(sv) == SVt_PVGV);
     SvFAKE_off(sv);
+    gv_efullname3(temp, (GV *) sv, "*");
+
     if (GvGP(sv))
 	gp_free((GV*)sv);
     if (GvSTASH(sv)) {
@@ -7602,6 +7666,7 @@ S_sv_unglob(pTHX_ SV *sv)
 	GvSTASH(sv) = NULL;
     }
     sv_unmagic(sv, PERL_MAGIC_glob);
+    SvSCREAM_off(sv);
     Safefree(GvNAME(sv));
     GvMULTI_off(sv);
 
@@ -7613,6 +7678,10 @@ S_sv_unglob(pTHX_ SV *sv)
 
     SvFLAGS(sv) &= ~SVTYPEMASK;
     SvFLAGS(sv) |= SVt_PVMG;
+
+    /* Intentionally not calling any local SET magic, as this isn't so much a
+       set operation as merely an internal storage change.  */
+    sv_setsv_flags(sv, temp, 0);
 }
 
 /*
diff --git a/sv.h b/sv.h
index c15a658..4f97214 100644
--- a/sv.h
+++ b/sv.h
@@ -252,7 +252,7 @@ perform the upgrade if necessary.  See C<svtype>.
 #define SVf_THINKFIRST	(SVf_READONLY|SVf_ROK|SVf_FAKE)
 
 #define SVf_OK		(SVf_IOK|SVf_NOK|SVf_POK|SVf_ROK| \
-			 SVp_IOK|SVp_NOK|SVp_POK)
+			 SVp_IOK|SVp_NOK|SVp_POK|SVp_SCREAM)
 
 #define PRIVSHIFT 4	/* (SVp_?OK >> PRIVSHIFT) == SVf_?OK */
 
@@ -897,7 +897,7 @@ in gv.h: */
 #define SvREADONLY_on(sv)	(SvFLAGS(sv) |= SVf_READONLY)
 #define SvREADONLY_off(sv)	(SvFLAGS(sv) &= ~SVf_READONLY)
 
-#define SvSCREAM(sv)		(SvFLAGS(sv) & SVp_SCREAM)
+#define SvSCREAM(sv) ((SvFLAGS(sv) & (SVp_SCREAM|SVp_POK)) == (SVp_SCREAM|SVp_POK))
 #define SvSCREAM_on(sv)		(SvFLAGS(sv) |= SVp_SCREAM)
 #define SvSCREAM_off(sv)	(SvFLAGS(sv) &= ~SVp_SCREAM)