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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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)