Make assignment over glob copies much faster

sv_force_normal is passed the SV_COW_DROP_PV flag if the scalar is
about to be written over.  That flag is not currently used.  We can
speed up assignment over fake GVs a lot by taking advantage of the flag.

Before and after:

$ time ./perl -e '$x = *foo, undef $x for 1..2000000'

real	0m4.264s
user	0m4.248s
sys	0m0.007s
$ time ./perl -e '$x = *foo, undef $x for 1..2000000'

real	0m1.820s
user	0m1.812s
sys	0m0.005s

diff --git a/embed.fnc b/embed.fnc
index 559f8cb..3f93d6d 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1994,7 +1994,7 @@ pR        |SV *   |varname        |NULLOK const GV *const gv|const char gvtype \
 pX     |void   |sv_del_backref |NN SV *const tsv|NN SV *const sv
 #if defined(PERL_IN_SV_C)
 nsR    |char * |uiv_2buf       |NN char *const buf|const IV iv|UV uv|const int is_uv|NN char **const peob
-s      |void   |sv_unglob      |NN SV *const sv
+s      |void   |sv_unglob      |NN SV *const sv|U32 flags
 s      |void   |not_a_number   |NN SV *const sv
 s      |I32    |visit          |NN SVFUNC_t f|const U32 flags|const U32 mask
 #  ifdef DEBUGGING

diff --git a/embed.h b/embed.h
index 42f4da4..b741b1c 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1511,7 +1511,7 @@
 #define sv_pos_u2b_cached(a,b,c,d,e,f,g)       S_sv_pos_u2b_cached(aTHX_ a,b,c,d,e,f,g)
 #define sv_pos_u2b_forwards    S_sv_pos_u2b_forwards
 #define sv_pos_u2b_midway      S_sv_pos_u2b_midway
-#define sv_unglob(a)           S_sv_unglob(aTHX_ a)
+#define sv_unglob(a,b)         S_sv_unglob(aTHX_ a,b)
 #define uiv_2buf               S_uiv_2buf
 #define utf8_mg_len_cache_update(a,b,c)        S_utf8_mg_len_cache_update(aTHX_ a,b,c)
 #define utf8_mg_pos_cache_update(a,b,c,d,e)    S_utf8_mg_pos_cache_update(aTHX_ a,b,c,d,e)

diff --git a/proto.h b/proto.h
index 0906acf..3d8f993 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -6732,7 +6732,7 @@ STATIC STRLEN     S_sv_pos_u2b_midway(const U8 *const start, const U8 *send, STRLEN
 #define PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY     \
        assert(start); assert(send)
 
-STATIC void    S_sv_unglob(pTHX_ SV *const sv)
+STATIC void    S_sv_unglob(pTHX_ SV *const sv, U32 flags)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_SV_UNGLOB     \
        assert(sv)

diff --git a/sv.c b/sv.c
index 31bda3b..44a8ba6 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -4806,7 +4806,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
     if (SvROK(sv))
        sv_unref_flags(sv, flags);
     else if (SvFAKE(sv) && isGV_with_GP(sv))
-       sv_unglob(sv);
+       sv_unglob(sv, flags);
     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
        /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
           to sv_unglob. We only need it here, so inline it.  */
@@ -9464,7 +9464,7 @@ Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
  */
 
 STATIC void
-S_sv_unglob(pTHX_ SV *const sv)
+S_sv_unglob(pTHX_ SV *const sv, U32 flags)
 {
     dVAR;
     void *xpvmg;
@@ -9475,7 +9475,8 @@ S_sv_unglob(pTHX_ SV *const sv)
 
     assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV);
     SvFAKE_off(sv);
-    gv_efullname3(temp, MUTABLE_GV(sv), "*");
+    if (!(flags & SV_COW_DROP_PV))
+       gv_efullname3(temp, MUTABLE_GV(sv), "*");
 
     if (GvGP(sv)) {
         if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
@@ -9506,7 +9507,8 @@ S_sv_unglob(pTHX_ SV *const sv)
 
     /* 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);
+    if (flags & SV_COW_DROP_PV) SvOK_off(sv);
+    else sv_setsv_flags(sv, temp, 0);
 }
 
 /*