benchmarks.t: update to handle field changes

[perl5.git] / Porting / bench.pl

diff --git a/Porting/bench.pl b/Porting/bench.pl
index 05cfae5..6087dca 100755 (executable)
--- a/Porting/bench.pl
+++ b/Porting/bench.pl
@@ -616,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];
@@ -820,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
 }
@@ -1117,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) {
@@ -1513,6 +1558,11 @@ sub grind_format_cell {
     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;
     }