[perl #123202] speed up scalar //g against tainted strings
authorTony Cook <tony@develop-help.com>
Thu, 26 Feb 2015 00:21:16 +0000 (11:21 +1100)
committerTony Cook <tony@develop-help.com>
Thu, 26 Feb 2015 00:21:16 +0000 (11:21 +1100)
MANIFEST
embed.fnc
embed.h
inline.h
mg.h
proto.h
t/perf/taint.t [new file with mode: 0644]

index 69fb9c7..aad1be4 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -5448,6 +5448,7 @@ t/perf/benchmarks.t               test t/perf/benchmarks syntax
 t/perf/opcount.t               See if optimised subs have the right op counts
 t/perf/optree.t                        Test presence of some op optimisations
 t/perf/speed.t                 See if optimisations are keeping things fast
+t/perf/taint.t                 See if optimisations are keeping things fast (taint issues)
 t/perl.supp                    Perl valgrind suppressions
 t/porting/args_assert.t                Check that all PERL_ARGS_ASSERT* macros are used
 t/porting/authors.t            Check that all authors have been acknowledged
index 26d3511..52229fc 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1447,6 +1447,7 @@ Apd       |void   |sv_magic       |NN SV *const sv|NULLOK SV *const obj|const int how \
 Apd    |MAGIC *|sv_magicext    |NN SV *const sv|NULLOK SV *const obj|const int how \
                                |NULLOK const MGVTBL *const vtbl|NULLOK const char *const name \
                                |const I32 namlen
+Ein    |bool   |sv_only_taint_gmagic|NN SV *sv
 : exported for re.pm
 EXp    |MAGIC *|sv_magicext_mglob|NN SV *sv
 ApdbamR        |SV*    |sv_mortalcopy  |NULLOK SV *const oldsv
diff --git a/embed.h b/embed.h
index 77b867c..72edd25 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define reg_temp_copy(a,b)     Perl_reg_temp_copy(aTHX_ a,b)
 #define report_uninit(a)       Perl_report_uninit(aTHX_ a)
 #define sv_magicext_mglob(a)   Perl_sv_magicext_mglob(aTHX_ a)
+#define sv_only_taint_gmagic   S_sv_only_taint_gmagic
 #define validate_proto(a,b,c)  Perl_validate_proto(aTHX_ a,b,c)
 #define vivify_defelem(a)      Perl_vivify_defelem(aTHX_ a)
 #define yylex()                        Perl_yylex(aTHX)
index cde2c54..1124412 100644 (file)
--- a/inline.h
+++ b/inline.h
@@ -377,6 +377,30 @@ get_regex_charset_name(const U32 flags, STRLEN* const lenp)
     return "?";            /* Unknown */
 }
 
+/*
+
+Return false if any get magic is on the SV other than taint magic.
+
+*/
+
+PERL_STATIC_INLINE bool
+S_sv_only_taint_gmagic(SV *sv) {
+    MAGIC *mg = SvMAGIC(sv);
+
+    PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
+
+    while (mg) {
+        if (mg->mg_type != PERL_MAGIC_taint
+            && !(mg->mg_flags & MGf_GSKIP)
+            && mg->mg_virtual->svt_get) {
+            return FALSE;
+        }
+        mg = mg->mg_moremagic;
+    }
+
+    return TRUE;
+}
+
 /*
  * Local variables:
  * c-indentation-style: bsd
diff --git a/mg.h b/mg.h
index 3aa2401..becef4a 100644 (file)
--- a/mg.h
+++ b/mg.h
@@ -65,7 +65,7 @@ struct magic {
 /* assumes get-magic and stringification have already occurred */
 # define MgBYTEPOS_set(mg,sv,pv,off) (                  \
     assert_((mg)->mg_type == PERL_MAGIC_regex_global)    \
-    SvPOK(sv) && !SvGMAGICAL(sv)                          \
+    SvPOK(sv) && (!SvGMAGICAL(sv) || sv_only_taint_gmagic(sv))  \
        ? (mg)->mg_len = (off), (mg)->mg_flags |= MGf_BYTES \
        : ((mg)->mg_len = DO_UTF8(sv)                        \
            ? (SSize_t)utf8_length((U8 *)(pv), (U8 *)(pv)+(off)) \
diff --git a/proto.h b/proto.h
index a8803b0..54115ca 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -4475,6 +4475,11 @@ PERL_CALLCONV NV Perl_sv_nv(pTHX_ SV* sv)
 #define PERL_ARGS_ASSERT_SV_NV \
        assert(sv)
 
+PERL_STATIC_INLINE bool        S_sv_only_taint_gmagic(SV *sv)
+                       __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC  \
+       assert(sv)
+
 PERL_CALLCONV char*    Perl_sv_peek(pTHX_ SV* sv);
 PERL_CALLCONV void     Perl_sv_pos_b2u(pTHX_ SV *const sv, I32 *const offsetp)
                        __attribute__nonnull__(pTHX_2);
diff --git a/t/perf/taint.t b/t/perf/taint.t
new file mode 100644 (file)
index 0000000..386d97e
--- /dev/null
@@ -0,0 +1,42 @@
+#!./perl -T
+#
+# All the tests in this file are ones that run exceptionally slowly
+# (each test taking seconds or even minutes) in the absence of particular
+# optimisations. Thus it is a sort of canary for optimisations being
+# broken.
+#
+# Although it includes a watchdog timeout, this is set to a generous limit
+# to allow for running on slow systems; therefore a broken optimisation
+# might be indicated merely by this test file taking unusually long to
+# run, rather than actually timing out.
+#
+# This is similar to t/perf/speed.t but tests performance regressions specific
+# to taint.
+#
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = ('../lib');
+    require Config; import Config;
+    require './test.pl';
+}
+
+use strict;
+use warnings;
+use Scalar::Util qw(tainted);
+
+$| = 1;
+
+plan tests => 2;
+
+watchdog(60);
+
+{
+    my $in = substr($ENV{PATH}, 0, 0) . ( "ab" x 200_000 );
+    utf8::upgrade($in);
+    ok(tainted($in), "performance issue only when tainted");
+    while ($in =~ /\Ga+b/g) { }
+    pass("\\G on tainted string");
+}
+
+1;