This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add t/perf/, t/perf/opcount.t
authorDavid Mitchell <davem@iabyn.com>
Tue, 21 Oct 2014 12:25:25 +0000 (13:25 +0100)
committerDavid Mitchell <davem@iabyn.com>
Sun, 26 Oct 2014 16:53:50 +0000 (16:53 +0000)
Add a new directory designed to hold performance / optimising tests
and infrastructure, and add the first test file, opcount.t, that
checks that a sub has the right numbers of particular op types

MANIFEST
Makefile.SH
t/TEST
t/harness
t/perf/opcount.t [new file with mode: 0644]

index ce5f1a4..0297736 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -5340,6 +5340,7 @@ t/op/warn.t                       See if warn works
 t/op/while.t                   See if while loops work
 t/op/write.t                   See if write works (formats work)
 t/op/yadayada.t                        See if ... works
 t/op/while.t                   See if while loops work
 t/op/write.t                   See if write works (formats work)
 t/op/yadayada.t                        See if ... works
+t/perf/opcount.t               See if optimised subs have the right op counts
 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/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 3c3efec..7043f3d 100755 (executable)
@@ -1513,7 +1513,9 @@ minitest: $(MINIPERL_EXE)
        @echo "to build lib/Config.pm, or the Unicode data files."
        @echo " "
        - cd t && (rm -f $(PERL_EXE); $(LNS) ../$(MINIPERL_EXE) $(PERL_EXE)) \
        @echo "to build lib/Config.pm, or the Unicode data files."
        @echo " "
        - cd t && (rm -f $(PERL_EXE); $(LNS) ../$(MINIPERL_EXE) $(PERL_EXE)) \
-               && $(RUN_PERL) TEST base/*.t comp/*.t cmd/*.t run/*.t io/*.t re/*.t opbasic/*.t op/*.t uni/*.t </dev/tty
+               && $(RUN_PERL) TEST base/*.t comp/*.t cmd/*.t run/*.t \
+               io/*.t re/*.t opbasic/*.t op/*.t uni/*.t perf/*.t \
+               </dev/tty
 
 # Test via harness
 
 
 # Test via harness
 
diff --git a/t/TEST b/t/TEST
index 5d25af6..42fccab 100755 (executable)
--- a/t/TEST
+++ b/t/TEST
@@ -428,7 +428,7 @@ unless (@ARGV) {
     # then comp, to validate that require works
     # then run, to validate that -M works
     # then we know we can -MTestInit for everything else, making life simpler
     # then comp, to validate that require works
     # then run, to validate that -M works
     # then we know we can -MTestInit for everything else, making life simpler
-    foreach my $dir (qw(base comp run cmd io re opbasic op uni mro)) {
+    foreach my $dir (qw(base comp run cmd io re opbasic op uni mro perf)) {
        _find_tests($dir);
     }
     unless ($::core) {
        _find_tests($dir);
     }
     unless ($::core) {
index cb3d8d7..30f4b1a 100644 (file)
--- a/t/harness
+++ b/t/harness
@@ -134,7 +134,7 @@ if (@ARGV) {
     unless (@tests) {
        my @seq = <base/*.t>;
 
     unless (@tests) {
        my @seq = <base/*.t>;
 
-       my @next = qw(comp run cmd io re opbasic op uni mro lib porting);
+       my @next = qw(comp run cmd io re opbasic op uni mro lib porting perf);
        push @next, 'japh' if $torture;
        push @next, 'win32' if $^O eq 'MSWin32';
        push @next, 'benchmark' if $ENV{PERL_BENCHMARK};
        push @next, 'japh' if $torture;
        push @next, 'win32' if $^O eq 'MSWin32';
        push @next, 'benchmark' if $ENV{PERL_BENCHMARK};
diff --git a/t/perf/opcount.t b/t/perf/opcount.t
new file mode 100644 (file)
index 0000000..8897604
--- /dev/null
@@ -0,0 +1,74 @@
+#!./perl
+#
+# opcount.t
+#
+# Test whether various constructs have the right numbers of particular op
+# types. This is chiefly to test that various optimisations are not
+# inadvertently removed.
+#
+# For example the array access in sub { $a[0] } should get optimised from
+# aelem into aelemfast. So we want to test that there are 1 aelemfast, 0
+# aelem and 1 ex-aelem ops in the optree for that sub.
+
+BEGIN {
+    chdir 't';
+    require './test.pl';
+    skip_all_if_miniperl("No B under miniperl");
+    @INC = '../lib';
+}
+
+plan 3;
+
+use B ();
+
+
+{
+    my %counts;
+
+    # for a given op, increment $count{opname}. Treat null ops
+    # as "ex-foo" where possible
+
+    sub B::OP::test_opcount_callback {
+        my ($op) = @_;
+        my $name = $op->name;
+        if ($name eq 'null') {
+            my $targ = $op->targ;
+            if ($targ) {
+                $name = "ex-" . substr(B::ppname($targ), 3);
+            }
+        }
+        $counts{$name}++;
+    }
+
+    # Given a code ref and a hash ref of expected op counts, check that
+    # for each opname => count pair, whether that op appears that many
+    # times in the op tree for that sub. If $debug is 1, display all the
+    # op counts for the sub.
+
+    sub test_opcount {
+        my ($debug, $desc, $coderef, $expected_counts) = @_;
+
+        %counts = ();
+        B::walkoptree(B::svref_2object($coderef)->ROOT,
+                        'test_opcount_callback');
+
+        if ($debug) {
+            note(sprintf "%3d %s", $counts{$_}, $_) for sort keys %counts;
+        }
+
+        for (sort keys %$expected_counts) {
+            is ($counts{$_}//0, $expected_counts->{$_}, "$desc: $_");
+        }
+    }    
+}
+
+# aelem => aelemfast: a basic test that this test file works
+
+test_opcount(0, "basic aelemfast",
+                sub { $a[0] = 1 }, 
+                {
+                    aelem      => 0,
+                    aelemfast  => 1,
+                    'ex-aelem' => 1,
+                }
+            );