This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
t/re/regexp.t: Speed up many regex tests on ASCII platform
authorKarl Williamson <khw@cpan.org>
Thu, 19 Dec 2019 16:59:54 +0000 (09:59 -0700)
committerKarl Williamson <khw@cpan.org>
Thu, 19 Dec 2019 17:11:58 +0000 (10:11 -0700)
This commit:

 commit 0cd59ee9ca0f0af3c0c172ecc27bb3f02da6db08
 Author:     Karl Williamson <khw@cpan.org>
 AuthorDate: Fri Sep 6 10:23:26 2019 -0600
 Commit:     Karl Williamson <khw@cpan.org>
 CommitDate: Mon Nov 11 21:05:13 2019 -0700

     t/re/regexp.t: Only convert to EBCDIC once

     Some tests get added as we go along, and those added tests have already
     been converted to EBCDIC if necessary.  Don't reconvert, which messes
     things up.

caused a huge slowdown in regex tests.  The most noticeable on my
platform was regexp_qr_embed_thr.t which doubled in wall clock time
spent.

It turns out that it was because a function was now always being called,
and that does nothing on ASCII platforms besides return its argument,
which then was copied over the argument.

This new commit causes the function to be a constant { 1; } on ASCII
platforms, so should be completely optimized out, returning the time
spent in that .t to 5.30 levels.

t/re/regexp.t

index 2a3be21..2448439 100644 (file)
@@ -110,27 +110,30 @@ my $test_num = 0;
 # translated again.
 my $first_already_converted_test_num = @tests + 1;
 
-sub convert_from_ascii {
-    my $string = shift;
+sub convert_from_ascii_guts {
+    my $string_ref = shift;
 
-    return $string if ord("A") == 65;
-    return $string if $test_num >= $first_already_converted_test_num;
+    return if $test_num >= $first_already_converted_test_num;
 
-    #my $save = $string;
+    #my $save = $string_ref;
     # Convert \x{...}, \o{...}
-    $string =~ s/ (?<! \\ ) \\x\{ ( .*? ) } / "\\x{" . sprintf("%X", utf8::unicode_to_native(hex $1)) .  "}" /gex;
-    $string =~ s/ (?<! \\ ) \\o\{ ( .*? ) } / "\\o{" . sprintf("%o", utf8::unicode_to_native(oct $1)) .  "}" /gex;
+    $$string_ref =~ s/ (?<! \\ ) \\x\{ ( .*? ) } / "\\x{" . sprintf("%X", utf8::unicode_to_native(hex $1)) .  "}" /gex;
+    $$string_ref =~ s/ (?<! \\ ) \\o\{ ( .*? ) } / "\\o{" . sprintf("%o", utf8::unicode_to_native(oct $1)) .  "}" /gex;
 
     # Convert \xAB
-    $string =~ s/ (?<! \\ ) \\x ( [A-Fa-f0-9]{2} ) / "\\x" . sprintf("%02X", utf8::unicode_to_native(hex $1)) /gex;
+    $$string_ref =~ s/ (?<! \\ ) \\x ( [A-Fa-f0-9]{2} ) / "\\x" . sprintf("%02X", utf8::unicode_to_native(hex $1)) /gex;
 
     # Convert \xA
-    $string =~ s/ (?<! \\ ) \\x ( [A-Fa-f0-9] ) (?! [A-Fa-f0-9] ) / "\\x" . sprintf("%X", utf8::unicode_to_native(hex $1)) /gex;
+    $$string_ref =~ s/ (?<! \\ ) \\x ( [A-Fa-f0-9] ) (?! [A-Fa-f0-9] ) / "\\x" . sprintf("%X", utf8::unicode_to_native(hex $1)) /gex;
 
-    #print STDERR __LINE__, ": $save\n$string\n" if $save ne $string;
-    return $string;
+    #print STDERR __LINE__, ": $save\n$string_ref\n" if $save ne $string_ref;
+    return;
 }
 
+*convert_from_ascii = (ord("A") == 65)
+                      ? sub { 1; }
+                      : convert_from_ascii_guts;
+
 $bang = sprintf "\\%03o", ord "!"; # \41 would not be portable.
 $ffff  = chr(0xff) x 2;
 $nulnul = "\0" x 2;
@@ -159,20 +162,20 @@ foreach (@tests) {
     my $input = join(':',$pat,$subject,$result,$repl,$expect);
 
     # the double '' below keeps simple syntax highlighters from going crazy
-    $pat = "'$pat'" unless $pat =~ /^[:''\/]/; 
+    $pat = "'$pat'" unless $pat =~ /^[:''\/]/;
     $pat =~ s/(\$\{\w+\})/$1/eeg;
     $pat =~ s/\\n/\n/g unless $regex_sets;
-    $pat = convert_from_ascii($pat);
+    convert_from_ascii(\$pat);
 
     my $no_null_pat;
     if ($no_null && $pat =~ /^'(.*)'\z/) {
        $no_null_pat = XS::APItest::string_without_null($1);
     }
 
-    $subject = convert_from_ascii($subject);
+    convert_from_ascii(\$subject);
     $subject = eval qq("$subject"); die $@ if $@;
 
-    $expect = convert_from_ascii($expect);
+    convert_from_ascii(\$expect);
     $expect  = eval qq("$expect"); die $@ if $@;
     $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/;