In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/ed38223246c041b4e9ce5687cadf6f6b903050ca?hp=e11fa374c86b187ae1e8382680d49e2e44abf1bb>
- Log ----------------------------------------------------------------- commit ed38223246c041b4e9ce5687cadf6f6b903050ca Author: Tony Cook <[email protected]> Date: Thu Feb 26 11:21:16 2015 +1100 [perl #123202] speed up scalar //g against tainted strings ----------------------------------------------------------------------- Summary of changes: MANIFEST | 1 + embed.fnc | 1 + embed.h | 1 + inline.h | 24 ++++++++++++++++++++++++ mg.h | 2 +- proto.h | 5 +++++ t/perf/{speed.t => taint.t} | 39 +++++++++++++++------------------------ 7 files changed, 48 insertions(+), 25 deletions(-) copy t/perf/{speed.t => taint.t} (62%) diff --git a/MANIFEST b/MANIFEST index 69fb9c7..aad1be4 100644 --- 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 diff --git a/embed.fnc b/embed.fnc index 26d3511..52229fc 100644 --- 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 --- a/embed.h +++ b/embed.h @@ -914,6 +914,7 @@ #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) diff --git a/inline.h b/inline.h index cde2c54..1124412 100644 --- a/inline.h +++ b/inline.h @@ -378,6 +378,30 @@ get_regex_charset_name(const U32 flags, STRLEN* const lenp) } /* + +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 * c-basic-offset: 4 diff --git a/mg.h b/mg.h index 3aa2401..becef4a 100644 --- 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 --- 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/speed.t b/t/perf/taint.t similarity index 62% copy from t/perf/speed.t copy to t/perf/taint.t index 43d09bb..386d97e 100644 --- a/t/perf/speed.t +++ b/t/perf/taint.t @@ -1,4 +1,4 @@ -#!./perl +#!./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 @@ -10,15 +10,9 @@ # might be indicated merely by this test file taking unusually long to # run, rather than actually timing out. # - -use strict; -use warnings; -use 5.010; - -sub run_tests; - -$| = 1; - +# This is similar to t/perf/speed.t but tests performance regressions specific +# to taint. +# BEGIN { chdir 't' if -d 't'; @@ -27,25 +21,22 @@ BEGIN { require './test.pl'; } -plan tests => 1; - -use warnings; use strict; +use warnings; +use Scalar::Util qw(tainted); -watchdog(60); +$| = 1; -SKIP: { - # RT #121975 COW speedup lost after e8c6a474 +plan tests => 2; - # without COW, this test takes minutes; with COW, its less than a - # second - # - skip "PERL_NO_COW", 1 if $Config{ccflags} =~ /PERL_NO_COW/; +watchdog(60); - my ($x, $y); - $x = "x" x 1_000_000; - $y = $x for 1..1_000_000; - pass("COW 1Mb strings"); +{ + 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; -- Perl5 Master Repository
