Optimise S_incpush() by avoiding repeatedly copying libdir to subdir.

Specifically, copy it once with newSVsv(), then pass libdir to
S_incpush_if_exists(), and if that creates a new SV, use newSVsv() there to
re-do the copy. Otherwise reset the length of the passed-in SV (which is
subdir), back to the length of libdir, effectively truncating it back to be
equal to libdir. This avoids repeated copying of the same bytes over the same
memory that already holds those bytes.

diff --git a/embed.fnc b/embed.fnc
index c015811..d6c5558 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1493,7 +1493,7 @@ so        |void   |validate_suid  |NN PerlIO *rsfp
 
 s      |void*  |parse_body     |NULLOK char **env|XSINIT_t xsinit
 rs     |void   |run_body       |I32 oldscope
-s      |SV *   |incpush_if_exists|NN AV *const av|NN SV *dir
+s      |SV *   |incpush_if_exists|NN AV *const av|NN SV *dir|NN SV *const stem
 #endif
 
 #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)

diff --git a/embed.h b/embed.h
index f59518e..8e100f2 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -3646,7 +3646,7 @@
 #ifdef PERL_CORE
 #define parse_body(a,b)                S_parse_body(aTHX_ a,b)
 #define run_body(a)            S_run_body(aTHX_ a)
-#define incpush_if_exists(a,b) S_incpush_if_exists(aTHX_ a,b)
+#define incpush_if_exists(a,b,c)       S_incpush_if_exists(aTHX_ a,b,c)
 #endif
 #endif
 #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)

diff --git a/perl.c b/perl.c
index 60f8538..9f7c682 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -4325,7 +4325,7 @@ S_init_perllib(pTHX)
    Generate a new SV if we do this, to save needing to copy the SV we push
    onto @INC  */
 STATIC SV *
-S_incpush_if_exists(pTHX_ AV *const av, SV *dir)
+S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
 {
     dVAR;
     Stat_t tmpstatbuf;
@@ -4335,7 +4335,10 @@ S_incpush_if_exists(pTHX_ AV *const av, SV *dir)
     if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
        S_ISDIR(tmpstatbuf.st_mode)) {
        av_push(av, dir);
-       dir = newSV(0);
+       dir = newSVsv(stem);
+    } else {
+       /* Truncate dir back to stem.  */
+       SvCUR_set(dir, SvCUR(stem));
     }
     return dir;
 }
@@ -4498,7 +4501,7 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
         * archname-specific sub-directories.
         */
        if (using_sub_dirs) {
-           SV *subdir = newSV(0);
+           SV *subdir;
 #ifdef PERL_INC_VERSION_LIST
            /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
            const char * const incverlist[] = { PERL_INC_VERSION_LIST };
@@ -4519,6 +4522,9 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
                              "Failed to unixify @INC element \"%s\"\n",
                              SvPV(libdir,len));
 #endif
+
+           subdir = newSVsv(libdir);
+
            if (add_versioned_sub_dirs) {
 #ifdef MACOS_TRADITIONAL
 #define PERL_ARCH_FMT_PREFIX   ""
@@ -4530,35 +4536,31 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
 #define PERL_ARCH_FMT_PATH     "/" PERL_FS_VERSION
 #endif
                /* .../version/archname if -d .../version/archname */
-               sv_setsv(subdir, libdir);
                sv_catpvs(subdir, PERL_ARCH_FMT_PATH \
                          PERL_ARCH_FMT_PREFIX ARCHNAME PERL_ARCH_FMT_SUFFIX);
-               subdir = S_incpush_if_exists(aTHX_ av, subdir);
+               subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
 
                /* .../version if -d .../version */
-               sv_setsv(subdir, libdir);
                sv_catpvs(subdir, PERL_ARCH_FMT_PATH);
-               subdir = S_incpush_if_exists(aTHX_ av, subdir);
+               subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
            }
 
 #ifdef PERL_INC_VERSION_LIST
            if (addoldvers) {
                for (incver = incverlist; *incver; incver++) {
                    /* .../xxx if -d .../xxx */
-                   Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PREFIX \
-                                  "%s" PERL_ARCH_FMT_SUFFIX,
-                                  SVfARG(libdir), *incver);
-                   subdir = S_incpush_if_exists(aTHX_ av, subdir);
+                   Perl_sv_catpvf(aTHX_ subdir, PERL_ARCH_FMT_PREFIX \
+                                  "%s" PERL_ARCH_FMT_SUFFIX, *incver);
+                   subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
                }
            }
 #endif
 
            if (add_archonly_sub_dirs) {
                /* .../archname if -d .../archname */
-               sv_setsv(subdir, libdir);
                sv_catpvs(subdir,
                          PERL_ARCH_FMT_PREFIX ARCHNAME PERL_ARCH_FMT_SUFFIX);
-               subdir = S_incpush_if_exists(aTHX_ av, subdir);
+               subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
 
            }
 

diff --git a/proto.h b/proto.h
index 428d6eb..7945bde 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -4803,11 +4803,12 @@ STATIC void*    S_parse_body(pTHX_ char **env, XSINIT_t xsinit);
 STATIC void    S_run_body(pTHX_ I32 oldscope)
                        __attribute__noreturn__;
 
-STATIC SV *    S_incpush_if_exists(pTHX_ AV *const av, SV *dir)
+STATIC SV *    S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
                        __attribute__nonnull__(pTHX_1)
-                       __attribute__nonnull__(pTHX_2);
+                       __attribute__nonnull__(pTHX_2)
+                       __attribute__nonnull__(pTHX_3);
 #define PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS     \
-       assert(av); assert(dir)
+       assert(av); assert(dir); assert(stem)
 
 #endif