In perl.git, the branch mauke/overflow has been updated
<https://perl5.git.perl.org/perl.git/commitdiff/82c76ddc179d6cdde6e203f99d72ad1342390c48?hp=bd7061cd2e3b79521294f526a937701c04437e48>
discards bd7061cd2e3b79521294f526a937701c04437e48 (commit)
discards 1ca0866a62e4f9cbfc92fc7502335b593701f0d7 (commit)
discards 90ba6e7724a7a6e4a83d986f278b2dc1c5928c67 (commit)
- Log -----------------------------------------------------------------
commit 82c76ddc179d6cdde6e203f99d72ad1342390c48
Author: Lukas Mai <l....@web.de>
Date: Sun Oct 22 14:40:44 2017 +0200
use __builtin_mul_overflow in pp_multiply
commit 50ec6d9fef3d3a05d30efbb774471fc51618579b
Author: Lukas Mai <l....@web.de>
Date: Sun Oct 22 14:27:34 2017 +0200
use __builtin_sub_overflow in pp_subtract
commit 767bc94bdb6a2fab55855316f9e2a08d0dd59160
Author: Lukas Mai <l....@web.de>
Date: Sun Oct 22 13:43:03 2017 +0200
use __builtin_add_overflow in pp_add
-----------------------------------------------------------------------
Summary of changes:
.metaconf-exclusions.txt | 26 ++++
Configure | 74 +++++-----
MANIFEST | 4 +
Porting/bench.pl | 323 ++++++++++++++++++++++++++++++-------------
configpm | 15 +-
dist/Time-HiRes/t/utime.t | 4 +-
dist/XSLoader/XSLoader_pm.PL | 12 +-
ext/B/B.pm | 4 +-
ext/B/t/b.t | 15 ++
ext/XS-APItest/APItest_BS | 4 +-
ext/XS-APItest/t/bootstrap.t | 2 +-
perl.h | 2 +
pod/perlre.pod | 2 +-
pod/perlvar.pod | 3 +
sv.c | 1 +
t/perf/benchmarks | 54 +++++---
t/perf/benchmarks.t | 24 +++-
t/porting/bench.t | 65 ++++++++-
t/porting/bench/badhash | 15 ++
t/porting/bench/badname | 14 ++
t/porting/bench/oddentry | 10 ++
21 files changed, 492 insertions(+), 181 deletions(-)
create mode 100644 .metaconf-exclusions.txt
create mode 100644 t/porting/bench/badhash
create mode 100644 t/porting/bench/badname
create mode 100644 t/porting/bench/oddentry
diff --git a/.metaconf-exclusions.txt b/.metaconf-exclusions.txt
new file mode 100644
index 0000000000..ce9e3d5658
--- /dev/null
+++ b/.metaconf-exclusions.txt
@@ -0,0 +1,26 @@
+# This file is used when building the Configure script from the metaconfig
+# units. Ordinarily, if any *.c or *.h or *.sh file mentions a symbol that can
+# be provided by a metaconfig unit, the generated Configure will include the
+# relevant probe. But in some cases, that's inappropriate: we have symbols that
+# we no longer need to probe for, but must define in perl.h for backwards
+# compatibilty with XS modules. Also, our C files contain tokens like "index"
+# that are used as the names of Perl builtins, but would be treated by
+# metaconfig as implicit requests for a particular unit that we don't need.
+#
+# Previously, we've used customised "stub" versions of metaconfig units to
+# handle this situation, but that doesn't scale (and, in particular, requires
+# us to maintain those customised units for as long as the relevant symbols are
+# defined by the units in the upstream dist package).
+#
+# A better approach is to list those symbols here (and invoke metaconfig with
+# the "-X .metaconf-exclusions.txt" option when generating Configure); that
+# will prevent the relevant units from being used.
+#
+# See also metaconfig.h, which works in the other direction — it forces units
+# to be included, even before specific code using the relevant symbols has been
+# written.
+
+I_LIMITS
+I_STDARG
+index
+rindex
diff --git a/Configure b/Configure
index 43872c1f3e..0db5887985 100755
--- a/Configure
+++ b/Configure
@@ -19057,52 +19057,52 @@ thread_start(void * arg)
}
int main() {
- char * main_buffer;
- char save_main_buffer[1000];
- pthread_t subthread;
- pthread_attr_t attr;
-
- main_buffer = nl_langinfo_l(CODESET, newlocale(LC_ALL_MASK, "C", 0));
-
- /* If too large for our generous allowance, just assume we don't have
- * it. */
- if (strlen(main_buffer) >= sizeof(save_main_buffer)) {
- exit(1);
- }
+ char * main_buffer;
+ char save_main_buffer[1000];
+ pthread_t subthread;
+ pthread_attr_t attr;
- strcpy(save_main_buffer, main_buffer);
+ main_buffer = nl_langinfo_l(CODESET, newlocale(LC_ALL_MASK, "C", 0));
- if (pthread_attr_init(&attr) != 0) {
- exit(1);
- }
+ /* If too large for our generous allowance, just assume we don't have
+ * it. */
+ if (strlen(main_buffer) >= sizeof(save_main_buffer)) {
+ exit(1);
+ }
- if (pthread_create(&subthread, &attr, thread_start, NULL) != 0) {
- exit(1);
- }
+ strcpy(save_main_buffer, main_buffer);
- if (pthread_join(subthread, NULL) != 0) {
- exit(1);
- }
+ if (pthread_attr_init(&attr) != 0) {
+ exit(1);
+ }
- exit(! (strcmp(main_buffer, save_main_buffer) == 0));
+ if (pthread_create(&subthread, &attr, thread_start, NULL) != 0) {
+ exit(1);
+ }
+
+ if (pthread_join(subthread, NULL) != 0) {
+ exit(1);
+ }
+
+ exit(! (strcmp(main_buffer, save_main_buffer) == 0));
}
EOCP
case "$usethreads" in
define)
- set try
- if eval $compile; then
- echo "Your system has nl_langinfo_l()..." >&4
- if $run ./try; then
- echo "and it is thread-safe (just as I'd hoped)." >&4
- d_thread_safe_nl_langinfo_l="$define"
- echo "$d_thread_safe_nl_langinfo_l" >&4
- else
- echo "but it isn't thread-safe, so we won't use it." >&4
- fi
- else
- echo "your system does not have nl_langinfo_l()" >&4
- fi
- ;;
+ set try
+ if eval $compile; then
+ echo "Your system has nl_langinfo_l()..." >&4
+ if $run ./try; then
+ echo "and it is thread-safe (just as I'd hoped)." >&4
+ d_thread_safe_nl_langinfo_l="$define"
+ echo "$d_thread_safe_nl_langinfo_l" >&4
+ else
+ echo "but it isn't thread-safe, so we won't use it." >&4
+ fi
+ else
+ echo "your system does not have nl_langinfo_l()" >&4
+ fi
+ ;;
*) echo "Since threads aren't selected, we won't bother looking for
nl_langinfo_l()" >&4
esac
if test X"$d_thread_safe_nl_langinfo_l" = X; then
diff --git a/MANIFEST b/MANIFEST
index ffbaa3de1e..b3207030a9 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1,4 +1,5 @@
.dir-locals.el Emacs control file
+.metaconf-exclusions.txt Symbols that should ignored when generating
Configure
.travis.yml continuous integration on github (where enabled)
amigaos4/amigaio.c AmigaOS4 port
amigaos4/amigaio.h AmigaOS4 port
@@ -5805,9 +5806,12 @@ 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
t/porting/bench.t Check Porting/bench.pl runs ok
+t/porting/bench/badhash a test file for t/porting/bench.t
+t/porting/bench/badname a test file for t/porting/bench.t
t/porting/bench/badversion.json a test file for t/porting/bench.t
t/porting/bench/callsub.json a test file for t/porting/bench.t
t/porting/bench/callsub2.json a test file for t/porting/bench.t
+t/porting/bench/oddentry a test file for t/porting/bench.t
t/porting/bench/ret0 a test file for t/porting/bench.t
t/porting/bench/synerr a test file for t/porting/bench.t
t/porting/bench_selftest.t run Porting/bench.pl's selftest facility
diff --git a/Porting/bench.pl b/Porting/bench.pl
index 0bb3fd89ab..6087dca138 100755
--- a/Porting/bench.pl
+++ b/Porting/bench.pl
@@ -99,7 +99,7 @@ I<selftest>, which runs some basic sanity checks and produces
TAP output.
--debug
-Enable verbose debugging output.
+Enable debugging output.
=item *
@@ -109,6 +109,7 @@ Display basic usage information.
=item *
+-v
--verbose
Display progress information.
@@ -188,6 +189,9 @@ but is actually only stripped down to:
5.20.0 5.22.0 5.24.0
+If the final results are plain integers, they are prefixed with "p"
+to avoid looking like column numbers to switches like C<--norm=2>.
+
=item *
@@ -303,7 +307,21 @@ If only one field is selected, the output is in more
compact form.
--norm=I<foo>
Specify which perl column in the output to treat as the 100% norm.
-It may be a column number (0..N-1) or a perl executable name or label.
+It may be:
+
+=over
+
+* a column number (0..N-1),
+
+* a negative column number (-1..-N) which counts from the right (so -1 is
+the right-most column),
+
+* or a perl executable name,
+
+* or a perl executable label.
+
+=back
+
It defaults to the leftmost column.
=item *
@@ -365,7 +383,7 @@ General options:
selftest perform a selftest; produce TAP output
--debug Enable verbose debugging output.
--help Display this help.
- --verbose Display progress information.
+ -v|--verbose Display progress information.
Selection:
@@ -478,7 +496,7 @@ my %OPTS = (
'show' => \$OPTS{show},
'sort=s' => \$OPTS{sort},
'tests=s' => \$OPTS{tests},
- 'verbose' => \$OPTS{verbose},
+ 'v|verbose' => \$OPTS{verbose},
'write|w=s' => \$OPTS{write},
) or die "Use the -h option for usage information.\n";
@@ -598,6 +616,32 @@ sub read_tests_file {
die "Error: can't read '$file': $!\n";
}
+ # validate and process each test
+
+ {
+ my %valid = map { $_ => 1 } qw(desc setup code pre post compile);
+ my @tests = @$ta;
+ if (!@tests || @tests % 2 != 0) {
+ die "Error: '$file' does not contain evenly paired test names and
hashes\n";
+ }
+ while (@tests) {
+ my $name = shift @tests;
+ my $hash = shift @tests;
+
+ unless ($name =~ /^[a-zA-Z]\w*(::\w+)*$/) {
+ die "Error: '$file': invalid test name: '$name'\n";
+ }
+
+ for (sort keys %$hash) {
+ die "Error: '$file': invalid key '$_' for test '$name'\n"
+ unless exists $valid{$_};
+ }
+
+ # make description default to the code
+ $hash->{desc} = $hash->{code} unless exists $hash->{desc};
+ }
+ }
+
my @orig_order;
for (my $i=0; $i < @$ta; $i += 2) {
push @orig_order, $ta->[$i];
@@ -614,18 +658,35 @@ sub read_tests_file {
sub select_a_perl {
my ($perl, $perls, $who) = @_;
- $perls||=[];
- if ($perl =~ /^[0-9]$/) {
+ $perls ||= [];
+ my $n = @$perls;
+
+ if ($perl =~ /^-([0-9]+)$/) {
+ my $p = $1;
+ die "Error: $who value $perl outside range -1..-$n\n"
+ if $p < 1 || $p > $n;
+ return $n - $p;
+ }
+
+ if ($perl =~ /^[0-9]+$/) {
die "Error: $who value $perl outside range 0.." . $#$perls . "\n"
- unless $perl < @$perls;
+ unless $perl < $n;
return $perl;
}
else {
my @perl = grep $perls->[$_][0] eq $perl
|| $perls->[$_][1] eq $perl,
0..$#$perls;
- die "Error: $who: unrecognised perl '$perl'\n"
- unless @perl;
+ unless (@perl) {
+ my $valid = '';
+ for (@$perls) {
+ $valid .= " $_->[1]";
+ $valid .= " $_->[0]" if $_->[0] ne $_->[1];
+ $valid .= "\n";
+ }
+ die "Error: $who: unrecognised perl '$perl'\n"
+ . "Valid perl names are:\n$valid";
+ }
die "Error: $who: ambiguous perl '$perl'\n"
if @perl > 1;
return $perl[0];
@@ -747,6 +808,17 @@ sub process_executables_list {
$post =~ s/^([0-9\.]*).*$/$1/;
$labels[$_][0] .= $post for 0..$#labels;
+ # avoid degenerate empty string for single executable name
+ $labels[0][0] = '0' if @labels == 1 && !length $labels[0][0];
+
+ # if the auto-generated labels are plain integers, prefix
+ # them with 'p' (for perl) to distinguish them from column
+ # indices (otherwise e.g. --norm=2 is ambiguous)
+
+ if ($labels[0][0] =~ /^\d*$/) {
+ $labels[$_][0] = "p$labels[$_][0]" for 0..$#labels;
+ }
+
# now de-duplicate labels
my (%seen, %index);
@@ -774,19 +846,43 @@ sub process_executables_list {
-# Return a string containing perl test code wrapped in a loop
-# that runs $ARGV[0] times
+# Return a string containing a perl program which runs the benchmark code
+# $ARGV[0] times. If $body is true, include the main body (setup) in
+# the loop; otherwise create an empty loop with just pre and post.
+# Note that an empty body is handled with '1;' so that a completely empty
+# loop has a single nextstate rather than a stub op, so more closely
+# matches the active loop; e.g.:
+# {1;} => nextstate; unstack
+# {$x=1;} => nextstate; const; gvsv; sassign; unstack
+# Note also that each statement is prefixed with a label; this avoids
+# adjacent nextstate ops being optimised away.
+#
+# A final 1; statement is added so that the code is always in void
+# context.
+#
+# It the compile flag is set for a test, the body of the loop is wrapped in
+# eval 'sub { .... }' to measure compile time rather than execution time
sub make_perl_prog {
- my ($test, $desc, $setup, $code) = @_;
+ my ($name, $test, $body) = @_;
+ my ($desc, $setup, $code, $pre, $post, $compile) =
+ @$test{qw(desc setup code pre post compile)};
+
+ $setup //= '';
+ $pre = defined $pre ? "_PRE_: $pre; " : "";
+ $post = defined $post ? "_POST_: $post; " : "";
+ $code = $body ? $code : "1";
+ $code = "_CODE_: $code; ";
+ my $full = "$pre$code$post _CXT_: 1; ";
+ $full = "eval q{sub { $full }};" if $compile;
return <<EOF;
# $desc
-package $test;
+package $name;
BEGIN { srand(0) }
$setup;
for my \$__loop__ (1..\$ARGV[0]) {
- $code;
+ $full
}
EOF
}
@@ -1071,14 +1167,9 @@ sub grind_run {
for my $test (grep $tests->{$_}, @$order) {
# Create two test progs: one with an empty loop and one with code.
- # Note that the empty loop is actually '{1;}' rather than '{}';
- # this causes the loop to have a single nextstate rather than a
- # stub op, so more closely matches the active loop; e.g.:
- # {1;} => nextstate; unstack
- # {$x=1;} => nextstate; const; gvsv; sassign; unstack
my @prog = (
- make_perl_prog($test, @{$tests->{$test}}{qw(desc setup)}, '1'),
- make_perl_prog($test, @{$tests->{$test}}{qw(desc setup code)}),
+ make_perl_prog($test, $tests->{$test}, 0),
+ make_perl_prog($test, $tests->{$test}, 1),
);
for my $p (@$perls) {
@@ -1459,6 +1550,27 @@ sub sorted_test_names {
}
+# format one cell data item
+
+sub grind_format_cell {
+ my ($val, $width) = @_;
+ my $s;
+ if (!defined $val) {
+ return sprintf "%*s", $width, '-';
+ }
+ elsif (abs($val) >= 1_000_000) {
+ # avoid displaying very large numbers (which might be the
+ # result of e.g. 1 / 0.000001)
+ return sprintf "%*s", $width, 'Inf';
+ }
+ elsif ($OPTS{raw}) {
+ return sprintf "%*.1f", $width, $val;
+ }
+ else {
+ return sprintf "%*.2f", $width, $val * 100;
+ }
+}
+
# grind_print(): display the tabulated results of all the cachegrinds.
#
# Arguments are of the form:
@@ -1466,6 +1578,7 @@ sub sorted_test_names {
# $averages->{perl_label}{field_name} = M
# $perls = [ [ perl-exe, perl-label ], ... ]
# $tests->{test_name}{desc => ..., ...}
+# $order = [ 'foo::bar1', ... ] # order to display tests
sub grind_print {
my ($results, $averages, $perls, $tests, $order) = @_;
@@ -1475,103 +1588,103 @@ sub grind_print {
my %perl_labels;
$perl_labels{$_->[0]} = $_->[1] for @$perls;
- my $field_label_width = 6;
- # Calculate the width to display for each column.
- my $min_width = $OPTS{raw} ? 8 : 6;
- my @widths = map { length($_) < $min_width ? $min_width : length($_) }
- @perl_labels;
-
# Print standard header.
grind_blurb($perls);
my @test_names = sorted_test_names($results, $order, $perls);
+ my @fields = qw(Ir Dr Dw COND IND
+ COND_m IND_m
+ Ir_m1 Dr_m1 Dw_m1
+ Ir_mm Dr_mm Dw_mm
+ );
+
+ if ($OPTS{fields}) {
+ @fields = grep exists $OPTS{fields}{$_}, @fields;
+ }
+
# If only a single field is to be displayed, use a more compact
# format with only a single line of output per test.
- my $one_field = defined $OPTS{fields} && keys(%{$OPTS{fields}}) == 1;
+ my $one_field = @fields == 1;
- if ($one_field) {
- print "\nResults for field " . (keys(%{$OPTS{fields}}))[0] . ".\n";
+ # The width of column 0: this is either field names, or for
+ # $one_field, test names
- # The first column will now contain test names rather than
- # field names; Calculate the max width.
+ my $width0 = 0;
+ for ($one_field ? @test_names : @fields) {
+ $width0 = length if length > $width0;
+ }
- $field_label_width = 0;
- for (@test_names) {
- $field_label_width = length if length > $field_label_width;
- }
+ # Calculate the widths of the data columns
- # Print the perl executables header.
+ my @widths = map length, @perl_labels;
- print "\n";
- for my $i (0,1) {
- print " " x $field_label_width;
- for (0..$#widths) {
- printf " %*s", $widths[$_],
- $i ? ('-' x$widths[$_]) : $perl_labels[$_];
+ for my $test (@test_names) {
+ my $res = ($test eq 'AVERAGE') ? $averages : $results->{$test};
+ for my $field (@fields) {
+ for my $i (0..$#widths) {
+ my $l = length grind_format_cell(
+ $res->{$perl_labels[$i]}{$field}, 1);
+ $widths[$i] = $l if $l > $widths[$i];
}
- print "\n";
}
}
- # Dump the results for each test.
+ # Print the results for each test
- for my $test_name (@test_names) {
+ for my $test (0..$#test_names) {
+ my $test_name = $test_names[$test];
my $doing_ave = ($test_name eq 'AVERAGE');
- my $res1 = $doing_ave ? $averages : $results->{$test_name};
+ my $res = $doing_ave ? $averages : $results->{$test_name};
- unless ($one_field) {
+ # print per-test header
+
+ if ($one_field) {
+ print "\nResults for field $fields[0]\n\n" if $test == 0;
+ }
+ else {
print "\n$test_name";
print "\n$tests->{$test_name}{desc}" unless $doing_ave;
print "\n\n";
+ }
+
+ # Print the perl executable names header.
- # Print the perl executables header.
+ if (!$one_field || $test == 0) {
for my $i (0,1) {
- print " " x $field_label_width;
+ print " " x $width0;
for (0..$#widths) {
printf " %*s", $widths[$_],
- $i ? ('-' x$widths[$_]) : $perl_labels[$_];
+ $i ? ('-' x$widths[$_]) : $perl_labels[$_];
}
print "\n";
}
}
- for my $field (qw(Ir Dr Dw COND IND
- N
- COND_m IND_m
- N
- Ir_m1 Dr_m1 Dw_m1
- N
- Ir_mm Dr_mm Dw_mm
- ))
- {
- next if $OPTS{fields} and ! exists $OPTS{fields}{$field};
+ my $field_suffix = '';
- if ($field eq 'N') {
- print "\n";
- next;
- }
+ # print a line of data
+ for my $field (@fields) {
if ($one_field) {
- printf "%-*s", $field_label_width, $test_name;
+ printf "%-*s", $width0, $test_name;
}
else {
- printf "%*s", $field_label_width, $field;
+ # If there are enough fields, print a blank line
+ # between groups of fields that have the same suffix
+ if (@fields > 4) {
+ my $s = '';
+ $s = $1 if $field =~ /(_\w+)$/;
+ print "\n" if $s ne $field_suffix;
+ $field_suffix = $s;
+ }
+ printf "%*s", $width0, $field;
}
for my $i (0..$#widths) {
- my $res2 = $res1->{$perl_labels[$i]};
- my $p = $res2->{$field};
- if (!defined $p) {
- printf " %*s", $widths[$i], '-';
- }
- elsif ($OPTS{raw}) {
- printf " %*.1f", $widths[$i], $p;
- }
- else {
- printf " %*.2f", $widths[$i], $p * 100;
- }
+ print " ", grind_format_cell($res->{$perl_labels[$i]}{$field},
+ $widths[$i]);
}
print "\n";
}
@@ -1589,14 +1702,11 @@ sub grind_print {
# $averages->{perl_label}{field_name} = M
# $perls = [ [ perl-exe, perl-label ], ... ]
# $tests->{test_name}{desc => ..., ...}
+# $order = [ 'foo::bar1', ... ] # order to display tests
sub grind_print_compact {
my ($results, $averages, $which_perl, $perls, $tests, $order) = @_;
-
- # the width to display for each column.
- my $width = $OPTS{raw} ? 7 : 6;
-
# Print standard header.
grind_blurb($perls);
@@ -1616,31 +1726,48 @@ sub grind_print_compact {
@fields = grep exists $OPTS{fields}{$_}, @fields;
}
- printf " %*s", $width, $_ for @fields;
+ # calculate the the max width of the test names
+
+ my $name_width = 0;
+ for (@test_names) {
+ $name_width = length if length > $name_width;
+ }
+
+ # Calculate the widths of the data columns
+
+ my @widths = map length, @fields;
+
+ for my $test (@test_names) {
+ my $res = ($test eq 'AVERAGE') ? $averages : $results->{$test};
+ $res = $res->{$perls->[$which_perl][1]};
+ for my $i (0..$#fields) {
+ my $l = length grind_format_cell($res->{$fields[$i]}, 1);
+ $widths[$i] = $l if $l > $widths[$i];
+ }
+ }
+
+ # Print header
+
+ printf " %*s", $widths[$_], $fields[$_] for 0..$#fields;
print "\n";
- printf " %*s", $width, '------' for @fields;
+ printf " %*s", $_, ('-' x $_) for @widths;
print "\n";
+ # Print the results for each test
+
for my $test_name (@test_names) {
my $doing_ave = ($test_name eq 'AVERAGE');
my $res = $doing_ave ? $averages : $results->{$test_name};
$res = $res->{$perls->[$which_perl][1]};
+ my $desc = $doing_ave
+ ? $test_name
+ : sprintf "%-*s %s", $name_width, $test_name,
+ $tests->{$test_name}{desc};
- for my $field (@fields) {
- my $p = $res->{$field};
- if (!defined $p) {
- printf " %*s", $width, '-';
- }
- elsif ($OPTS{raw}) {
- printf " %*.1f", $width, $p;
- }
- else {
- printf " %*.2f", $width, $p * 100;
- }
-
+ for my $i (0..$#fields) {
+ print " ", grind_format_cell($res->{$fields[$i]}, $widths[$i]);
}
-
- print " $test_name\n";
+ print " $desc\n";
}
}
diff --git a/configpm b/configpm
index 09b9e67aab..ebbaaa9b44 100755
--- a/configpm
+++ b/configpm
@@ -212,6 +212,19 @@ my $in_v = 0;
my %Data = ();
my $quote;
+# These variables were set in older versions of Perl, but are no longer needed
+# by the core. However, some CPAN modules may rely on them; in particular, Tk
+# (at least up to version 804.034) fails to build without them. We force them
+# to be emitted to Config_heavy.pl for backcompat with such modules (and we may
+# find that this set needs to be extended in future). See RT#132347.
+my @v_forced = map "$_\n", split /\n+/, <<'EOT';
+i_limits='define'
+i_stdlib='define'
+i_string='define'
+i_time='define'
+prototype='define'
+EOT
+
my %seen_quotes;
{
@@ -567,7 +580,7 @@ $heavy_txt .= join('',
map {
/^([^=]+)/ ? [ $1, $_ ]
: [ $_, $_ ] # shouldnt happen
- } @v_others
+ } @v_others, @v_forced
) . "!END!\n";
# Only need the dynamic byteorder code in Config.pm if 'byteorder' is one of
diff --git a/dist/Time-HiRes/t/utime.t b/dist/Time-HiRes/t/utime.t
index 7821837f8e..c404ec36db 100644
--- a/dist/Time-HiRes/t/utime.t
+++ b/dist/Time-HiRes/t/utime.t
@@ -8,7 +8,7 @@ sub has_subsecond_file_times {
my $dirname = dirname($filename);
require Cwd;
$dirname = &Cwd::getcwd if $dirname eq '.';
- print(STDERR "\n# Testing for subsecond file timestamps (mtime) in
$dirname\n");
+ print("\n# Testing for subsecond file timestamps (mtime) in $dirname\n");
close $fh;
my @mtimes;
for (1..2) {
@@ -22,7 +22,7 @@ sub has_subsecond_file_times {
# print STDERR "mtimes = @mtimes, delta = $delta\n";
unlink $filename;
my $ok = $delta > 0 && $delta < 1;
- printf(STDERR "# Subsecond file timestamps in $dirname: %s\n",
+ printf("# Subsecond file timestamps in $dirname: %s\n",
$ok ? "OK" : "NO");
return $ok;
}
diff --git a/dist/XSLoader/XSLoader_pm.PL b/dist/XSLoader/XSLoader_pm.PL
index 8012e35e32..e09538843d 100644
--- a/dist/XSLoader/XSLoader_pm.PL
+++ b/dist/XSLoader/XSLoader_pm.PL
@@ -11,7 +11,7 @@ print OUT <<'EOT';
package XSLoader;
-$VERSION = "0.27";
+$VERSION = "0.28";
#use strict;
@@ -143,14 +143,8 @@ print OUT <<'EOT';
my $bs = $file;
$bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library
- if (-s $bs) { # only read file if it's not empty
-# print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug;
- eval { local @INC = ('.'); do $bs; };
- warn "$bs: $@\n" if $@;
- goto \&XSLoader::bootstrap_inherit;
- }
-
- goto \&XSLoader::bootstrap_inherit if not -f $file;
+ # This calls DynaLoader::bootstrap, which will load the .bs file if present
+ goto \&XSLoader::bootstrap_inherit if not -f $file or -s $bs;
my $bootname = "boot_$module";
$bootname =~ s/\W/_/g;
diff --git a/ext/B/B.pm b/ext/B/B.pm
index 3365a14f8c..12d8201619 100644
--- a/ext/B/B.pm
+++ b/ext/B/B.pm
@@ -15,7 +15,7 @@ require Exporter;
# walkoptree comes from B.xs
BEGIN {
- $B::VERSION = '1.70';
+ $B::VERSION = '1.71';
@B::EXPORT_OK = ();
# Our BOOT code needs $VERSION set, and will append to @EXPORT_OK.
@@ -261,6 +261,8 @@ sub walksymtable {
no strict 'refs';
$prefix = '' unless defined $prefix;
foreach my $sym ( sort keys %$symref ) {
+ my $dummy = $symref->{$sym}; # Copying the glob and incrementing
+ # the GPs refcnt clears cached methods
$fullname = "*main::".$prefix.$sym;
if ($sym =~ /::$/) {
$sym = $prefix . $sym;
diff --git a/ext/B/t/b.t b/ext/B/t/b.t
index a5d724912b..587c8e665f 100644
--- a/ext/B/t/b.t
+++ b/ext/B/t/b.t
@@ -56,6 +56,21 @@ ok( join('', sort @syms) eq join('', sort keys %Subs), 'all
symbols found' );
# Make sure we only hit them each once.
ok( (!grep $_ != 1, values %Subs), '...and found once' );
+
+# Make sure method caches are not present when walking the sym tab
+@Testing::Method::Caches::Foo::ISA='Testing::Method::Caches::Bar';
+sub Testing::Method::Caches::Bar::foo{}
+Testing::Method::Caches::Foo->foo; # caches the sub in the *foo glob
+
+my $have_cv;
+sub B::GV::method_cache_test { ${shift->CV} and ++$have_cv }
+
+B::walksymtable(\%Testing::Method::Caches::, 'method_cache_test',
+ sub { 1 }, 'Testing::Method::Caches::');
+# $have_cv should only have been incremented for ::Bar::foo
+is $have_cv, 1, 'walksymtable clears cached methods';
+
+
# Tests for MAGIC / MOREMAGIC
ok( B::svref_2object(\$.)->MAGIC->TYPE eq "\0", '$. has \0 magic' );
{
diff --git a/ext/XS-APItest/APItest_BS b/ext/XS-APItest/APItest_BS
index 270dc9c682..d9ec22fb62 100644
--- a/ext/XS-APItest/APItest_BS
+++ b/ext/XS-APItest/APItest_BS
@@ -1,7 +1,7 @@
#
-# test that non-empty .bs files get executed
+# test that non-empty .bs files get executed (but only once)
$bscode = <<'EOF';
-$::bs_file_got_executed = 1;
+$::bs_file_got_executed++;
EOF
diff --git a/ext/XS-APItest/t/bootstrap.t b/ext/XS-APItest/t/bootstrap.t
index 6992b10850..2c6c03466f 100644
--- a/ext/XS-APItest/t/bootstrap.t
+++ b/ext/XS-APItest/t/bootstrap.t
@@ -11,7 +11,7 @@ use strict;
use Test::More;
use XS::APItest;
-is $::bs_file_got_executed, 1, "BS file was executed";
+is $::bs_file_got_executed, 1, "BS file was executed once";
done_testing();
diff --git a/perl.h b/perl.h
index 853fd6f8d3..f433dc7f43 100644
--- a/perl.h
+++ b/perl.h
@@ -565,7 +565,9 @@
#define VOL volatile
#define CAN_PROTOTYPE
#define _(args) args
+#define I_LIMITS
#define I_STDARG
+#define STANDARD_C
#endif
/* By compiling a perl with -DNO_TAINT_SUPPORT or -DSILENT_NO_TAINT_SUPPORT,
diff --git a/pod/perlre.pod b/pod/perlre.pod
index 9cab16e223..b11d862b40 100644
--- a/pod/perlre.pod
+++ b/pod/perlre.pod
@@ -1627,7 +1627,7 @@ constructs (like C<\g{NAME}>) and can be accessed by name
after a successful match via C<%+> or C<%->. See L<perlvar>
for more details on the C<%+> and C<%-> hashes.
-If multiple distinct capture groups have the same name then the
+If multiple distinct capture groups have the same name, then
C<$+{NAME}> will refer to the leftmost defined group in the match.
The forms C<(?'NAME'pattern)> and C<< (?<NAME>pattern) >> are equivalent.
diff --git a/pod/perlvar.pod b/pod/perlvar.pod
index 9ce9430b6b..257fdb6e1a 100644
--- a/pod/perlvar.pod
+++ b/pod/perlvar.pod
@@ -1121,6 +1121,9 @@ For example, C<$+{foo}> is equivalent to C<$1> after the
following match:
The keys of the C<%+> hash list only the names of buffers that have
captured (and that are thus associated to defined values).
+If multiple distinct capture groups have the same name, then
+C<$+{NAME}> will refer to the leftmost defined group in the match.
+
The underlying behaviour of C<%+> is provided by the
L<Tie::Hash::NamedCapture> module.
diff --git a/sv.c b/sv.c
index ac1fb4d823..06168501ee 100644
--- a/sv.c
+++ b/sv.c
@@ -14294,6 +14294,7 @@ S_sv_dup_common(pTHX_ const SV *const sstr,
CLONE_PARAMS *const param)
else
LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
if (isREGEXP(sstr)) goto duprex;
+ /* FALLTHROUGH */
case SVt_PVGV:
/* non-GP case already handled above */
if(isGV_with_GP(sstr)) {
diff --git a/t/perf/benchmarks b/t/perf/benchmarks
index 61909b08a9..423230a914 100644
--- a/t/perf/benchmarks
+++ b/t/perf/benchmarks
@@ -39,15 +39,24 @@
# string:: string handling
#
#
-# Each hash has three fields:
+# Each hash has up to five fields:
+#
+# desc is a description of the test; if not present, it defaults
+# to the same value as the 'code' field
+#
+# setup is an optional string containing setup code that is run once
#
-# desc is a description of the test
-# setup is a string containing setup code
# code is a string containing the code to run in a loop
#
-# So typically a benchmark tool might do something like
+# pre is an optional string containing setup code which is executed
+# just before 'code' for every iteration, but whose execution
+# time is not included in the result
+#
+# post like pre, but executed just after 'code'.
#
-# eval "package $token; $setup; for (1..1000000) { $code }"
+# So typically a benchmark tool might execute variations on something like
+#
+# eval "package $name; $setup; for (1..1000000) { $pre; $code; $post }"
#
# Currently the only tool that uses this file is Porting/bench.pl;
# try C<perl Porting/bench.pl --help> for more info
@@ -57,7 +66,9 @@
# Note: for the cachegrind variant, an entry like
# 'foo::bar' => {
# setup => 'SETUP',
+# pre => 'PRE',
# code => 'CODE',
+# post => 'POST',
# }
# creates two temporary perl sources looking like:
#
@@ -65,12 +76,12 @@
# BEGIN { srand(0) }
# SETUP;
# for my $__loop__ (1..$ARGV[0]) {
-# 1;
+# PRE; 1; POST;
# }
#
-# and as above, but with the '1;' in the loop body replaced with:
+# and as above, but with the loop body replaced with:
#
-# CODE;
+# PRE; CODE; POST;
#
# It then pipes each of the two sources into
#
@@ -79,11 +90,25 @@
# where N is set to 10 and then 20.
#
# It then uses the result of those four cachegrind runs to subtract out
-# the perl startup and loop overheads. So only what's in SETUP and CODE
-# can affect the benchmark, and if the loop happens to leave some state
-# changed (such as storing a value in a hash), then the final benchmark
-# timing is the result of running CODE with the hash entry populated
-# rather than empty.
+# the perl startup and loop overheads (including SETUP, PRE and POST), leaving
+# (in theory only CODE);
+#
+# Note that misleading results may be obtained if each iteration is
+# not identical. For example with
+#
+# code => '$x .= "foo"',
+#
+# the string $x gets longer on each iteration. Similarly, a hash might be
+# empty on the first iteration, but have entries on subsequent iterations.
+#
+# To avoid this, use 'pre' or 'post', e.g.
+#
+# pre => '$x = ""',
+# code => '$x .= "foo"',
+#
+# Finally, the optional 'compile' key causes the code body to be wrapped
+# in eval qw{ sub { ... }}, so that compile time rather than execution
+# time is measured.
[
@@ -1052,12 +1077,10 @@
},
'expr::arith::preinc' => {
- desc => '++$x',
setup => 'my $x = 1;',
code => '++$x',
},
'expr::arith::predec' => {
- desc => '--$x',
setup => 'my $x = 1;',
code => '--$x',
},
@@ -1779,7 +1802,6 @@
'regex::anyof_plus::anchored' => {
- desc => '/^[acgt]+/',
setup => '$_ = "a" x 100;',
code => '/^[acgt]+/',
},
diff --git a/t/perf/benchmarks.t b/t/perf/benchmarks.t
index 873f8db0cf..57dbcf8793 100644
--- a/t/perf/benchmarks.t
+++ b/t/perf/benchmarks.t
@@ -31,22 +31,34 @@ while (@$benchmark_array) {
$benchmarks{$key} = $hash;
}
-plan keys(%benchmarks) * 3;
-
+plan keys(%benchmarks) * 4;
# check the hash of hashes is minimally consistent in format
+my %valid_keys = map { $_=> 1 } qw(desc setup code pre post compile);
+my @required_keys = qw(code);
+
for my $token (sort keys %benchmarks) {
- like($token, qr/^[a-zA-Z](\w|::)+$/a, "legal token: $token");
- my $keys = join('-', sort keys %{$benchmarks{$token}});
- is($keys, 'code-desc-setup', "legal keys: $token");
+ like($token, qr/^[a-zA-Z](\w|::)+$/a, "$token: legal token");
+
+ my @keys = sort keys %{$benchmarks{$token}};
+ my @invalid = grep !exists $valid_keys{$_}, @keys;
+ ok(!@invalid, "$token: only valid keys present")
+ or diag("saw these invalid keys: (@invalid)");
+
+ my @missing = grep !exists $benchmarks{$token}{$_}, @required_keys;
+ ok(!@missing, "$token: all required keys present")
+ or diag("these keys are missing: (@missing)");
}
# check that each bit of code compiles and runs
for my $token (sort keys %benchmarks) {
my $b = $benchmarks{$token};
- my $code = "package $token; $b->{setup}; for (1..1) { $b->{code} } 1;";
+ my $setup = $b->{setup} // '';
+ my $pre = $b->{pre} // '';
+ my $post = $b->{post} // '';
+ my $code = "package $token; $setup; for (1..1) { $pre; $b->{code}; $post;
} 1;";
no warnings;
no strict;
ok(eval $code, "running $token")
diff --git a/t/porting/bench.t b/t/porting/bench.t
index a28a434d10..ee4c1c37ba 100644
--- a/t/porting/bench.t
+++ b/t/porting/bench.t
@@ -81,6 +81,15 @@ my %format_qrs;
. ($l + 1)
. ",}-)"
}ge;
+
+ # convert run of space chars into ' +' or ' *'
+
+ $f =~ s/(\A|\n)(\\ )+/$1 */g;
+ $f =~ s/(\\ )+/ +/g;
+
+ # convert '---' placeholders into a regex
+ $f =~ s/(\\-){2,}/-+/g;
+
$format_qrs{$name} = qr/\A$f\z/;
}
}
@@ -159,14 +168,42 @@ for my $test (
"Error: can't load 't/porting/bench/ret0': code didn't return a true
value\n",
"croak: --benchfile which returns 0"
],
+ [
+ "--benchfile=t/porting/bench/oddentry perl",
+ qr{\AError: 't/porting/bench/oddentry' does not contain evenly paired
test names and hashes\n},
+ "croak: --benchfile with odd number of entries"
+ ],
+ [
+ "--benchfile=t/porting/bench/badname perl",
+ qr{\AError: 't/porting/bench/badname': invalid test name: '1='\n},
+ "croak: --benchfile with invalid test name"
+ ],
+ [
+ "--benchfile=t/porting/bench/badhash perl",
+ qr{\AError: 't/porting/bench/badhash': invalid key 'blah' for test
'foo::bar'\n},
+ "croak: --benchfile with invalid test hash key"
+ ],
[
"--norm=2 ./miniperl ./perl",
"Error: --norm value 2 outside range 0..1\n",
"croak: select-a-perl out of range"
],
+ [
+ "--norm=-0 ./miniperl ./perl",
+ "Error: --norm value -0 outside range -1..-2\n",
+ "croak: select-a-perl out of range"
+ ],
+ [
+ "--norm=-3 ./miniperl ./perl",
+ "Error: --norm value -3 outside range -1..-2\n",
+ "croak: select-a-perl out of range"
+ ],
[
"--sort=Ir:myperl ./miniperl ./perl",
- "Error: --sort: unrecognised perl 'myperl'\n",
+ "Error: --sort: unrecognised perl 'myperl'\n"
+ . "Valid perl names are:\n"
+ . " ./miniperl\n"
+ . " ./perl\n",
"croak: select-a-perl unrecognised"
],
[
@@ -231,7 +268,7 @@ for my $test (
],
[
"--grindargs=Boz --debug --tests=call::sub::empty ./perl=A ./perl=B",
- qr{Error: while executing call::sub::empty/A empty/short
loop:\nunexpected code or cachegrind output:\n},
+ qr{Error: .*?(unexpected code or cachegrind output|gave return
status)}s,
"croak: cachegrind output format "
],
[
@@ -415,6 +452,11 @@ like $out, $format_qrs{percent2}, "basic cachegrind
percent format; 2 perls";
$out = qx($bench_cmd --read=$resultfile2 --norm=0 2>&1);
like $out, $format_qrs{percent2}, "basic cachegrind percent format, norm; 2
perls";
+# ditto with negative norm
+
+$out = qx($bench_cmd --read=$resultfile2 --norm=-2 2>&1);
+like $out, $format_qrs{percent2}, "basic cachegrind percent format, norm -2; 2
perls";
+
# read back the results in relative-percent form with sort
$out = qx($bench_cmd --read=$resultfile2 --sort=Ir:0 2>&1);
@@ -517,7 +559,7 @@ EOF
$cmd =~ s/\n\s+/ /g;
$out = qx($cmd);
$out =~ s{^\./perl}{p0}m;
-$out =~ s{\Q ./perl perl2 0 1}
+$out =~ s{\Q ./perl perl2 p-0 p-1}
{ p0 p1 p2 p3};
like $out, $format_qrs{percent4}, "4 perls with autolabel and args and env";
@@ -528,12 +570,21 @@ done_testing();
# Templates for expected output formats.
#
# Lines starting with '#' are skipped.
+#
# Lines of the form 'FORMAT: foo' start and name a new template
+#
# All other lines are part of the template
+#
# Entries of the form NNNN.NN are converted into a regex of the form
# ( \s* -? \d+\.\d\d | - )
# i.e. it expects number with a fixed number of digits after the point,
# or a '-'.
+#
+# Any runs of space chars (but not tab) are converted into ' +',
+# or ' *' if at the start of a line
+#
+# Entries of the form --- are converted into [-]+
+#
# Lines of the form %%FOO%% are substituted with format 'FOO'
@@ -732,7 +783,7 @@ Results for p1
Ir Dr Dw COND IND COND_m IND_m Ir_m1 Dr_m1 Dw_m1 Ir_mm
Dr_mm Dw_mm
------ ------ ------ ------ ------ ------ ------ ------ ------ ------ ------
------ ------
- NNN.NN NNN.NN NNN.NN NNN.NN NNN.NN NNN.NN NNN.NN NNN.NN NNN.NN NNN.NN NNN.NN
NNN.NN NNN.NN call::sub::empty
+ NNN.NN NNN.NN NNN.NN NNN.NN NNN.NN NNN.NN NNN.NN NNN.NN NNN.NN NNN.NN NNN.NN
NNN.NN NNN.NN call::sub::empty function call with no args or body
# ===================================================================
FORMAT: compact_fields
%%STD_HEADER%%
@@ -746,7 +797,7 @@ Results for p1
Ir Dr
------ ------
- NNN.NN NNN.NN call::sub::empty
+ NNN.NN NNN.NN call::sub::empty function call with no args or body
# ===================================================================
FORMAT: 1field
%%STD_HEADER%%
@@ -756,7 +807,7 @@ p0 at 100.0%.
Higher is better: for example, using half as many instructions gives 200%,
while using twice as many gives 50%.
-Results for field Ir.
+Results for field Ir
p0 p1
------ ------
@@ -800,5 +851,5 @@ Results for p0
Ir Dr Dw COND IND COND_m IND_m Ir_m1 Dr_m1
Dw_m1 Ir_mm Dr_mm Dw_mm
------ ------ ------ ------ ------ ------ ------ ------ ------
------ ------ ------ ------
- NNNNN.N NNNNN.N NNNNN.N NNNNN.N NNNNN.N NNNNN.N NNNNN.N NNNNN.N NNNNN.N
NNNNN.N NNNNN.N NNNNN.N NNNNN.N call::sub::empty
+ NNNNN.N NNNNN.N NNNNN.N NNNNN.N NNNNN.N NNNNN.N NNNNN.N NNNNN.N NNNNN.N
NNNNN.N NNNNN.N NNNNN.N NNNNN.N call::sub::empty function call with no args
or body
# ===================================================================
diff --git a/t/porting/bench/badhash b/t/porting/bench/badhash
new file mode 100644
index 0000000000..38dd473392
--- /dev/null
+++ b/t/porting/bench/badhash
@@ -0,0 +1,15 @@
+#!perl
+# for the use of t/porting/bench.pl.
+#
+# A file to load which has an invalid hash key
+
+
+[
+ 'foo::bar' => {
+ desc => 'my $x = "abc"',
+ setup => '',
+ code => 'my $x = "abc"',
+ blah => 1,
+ },
+];
+
diff --git a/t/porting/bench/badname b/t/porting/bench/badname
new file mode 100644
index 0000000000..f3de2d8ae4
--- /dev/null
+++ b/t/porting/bench/badname
@@ -0,0 +1,14 @@
+#!perl
+# for the use of t/porting/bench.pl.
+#
+# A file to load which has an invalid test name
+
+
+[
+ '1=' => {
+ desc => 'my $x = "abc"',
+ setup => '',
+ code => 'my $x = "abc"',
+ },
+];
+
diff --git a/t/porting/bench/oddentry b/t/porting/bench/oddentry
new file mode 100644
index 0000000000..baca03ae17
--- /dev/null
+++ b/t/porting/bench/oddentry
@@ -0,0 +1,10 @@
+#!perl
+# for the use of t/porting/bench.pl.
+#
+# A file to load which has an odd number of test/hash pairs
+
+
+[
+ 'foo::bar',
+];
+
--
Perl5 Master Repository
