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)