t/perf/opcount.t

   1 #!./perl
   2 #
   3 # opcount.t
   4 #
   5 # Test whether various constructs have the right numbers of particular op
   6 # types. This is chiefly to test that various optimisations are not
   7 # inadvertently removed.
   8 #
   9 # For example the array access in sub { $a[0] } should get optimised from
  10 # aelem into aelemfast. So we want to test that there are 1 aelemfast, 0
  11 # aelem and 1 ex-aelem ops in the optree for that sub.
  12
  13 BEGIN {
  14     chdir 't';
  15     require './test.pl';
  16     skip_all_if_miniperl("No B under miniperl");
  17     @INC = '../lib';
  18 }
  19
  20 use warnings;
  21 use strict;
  22
  23 plan 2249;
  24
  25 use B ();
  26
  27
  28 {
  29     my %counts;
  30
  31     # for a given op, increment $count{opname}. Treat null ops
  32     # as "ex-foo" where possible
  33
  34     sub B::OP::test_opcount_callback {
  35         my ($op) = @_;
  36         my $name = $op->name;
  37         if ($name eq 'null') {
  38             my $targ = $op->targ;
  39             if ($targ) {
  40                 $name = "ex-" . substr(B::ppname($targ), 3);
  41             }
  42         }
  43         $counts{$name}++;
  44     }
  45
  46     # Given a code ref and a hash ref of expected op counts, check that
  47     # for each opname => count pair, whether that op appears that many
  48     # times in the op tree for that sub. If $debug is 1, display all the
  49     # op counts for the sub.
  50
  51     sub test_opcount {
  52         my ($debug, $desc, $coderef, $expected_counts) = @_;
  53
  54         %counts = ();
  55         B::walkoptree(B::svref_2object($coderef)->ROOT,
  56                         'test_opcount_callback');
  57
  58         if ($debug) {
  59             note(sprintf "%3d %s", $counts{$_}, $_) for sort keys %counts;
  60         }
  61
  62         my @exp;
  63         for (sort keys %$expected_counts) {
  64             my ($c, $e) = ($counts{$_}//0, $expected_counts->{$_});
  65             if ($c != $e) {
  66                 push @exp, "expected $e, got $c: $_";
  67             }
  68         }
  69         ok(!@exp, $desc);
  70         if (@exp) {
  71             diag($_) for @exp;
  72         }
  73     }
  74 }
  75
  76 # aelem => aelemfast: a basic test that this test file works
  77
  78 test_opcount(0, "basic aelemfast",
  79                 sub { our @a; $a[0] = 1 },
  80                 {
  81                     aelem      => 0,
  82                     aelemfast  => 1,
  83                     'ex-aelem' => 1,
  84                 }
  85             );
  86
  87 # Porting/bench.pl tries to create an empty and active loop, with the
  88 # ops executed being exactly the same apart from the additional ops
  89 # in the active loop. Check that this remains true.
  90
  91 {
  92     test_opcount(0, "bench.pl empty loop",
  93                 sub { for my $x (1..$ARGV[0]) { 1; } },
  94                 {
  95                      aelemfast => 1,
  96                      and       => 1,
  97                      const     => 1,
  98                      enteriter => 1,
  99                      iter      => 1,
 100                      leaveloop => 1,
 101                      leavesub  => 1,
 102                      lineseq   => 2,
 103                      nextstate => 2,
 104                      null      => 1,
 105                      pushmark  => 1,
 106                      unstack   => 1,
 107                 }
 108             );
 109
 110     no warnings 'void';
 111     test_opcount(0, "bench.pl active loop",
 112                 sub { for my $x (1..$ARGV[0]) { $x; } },
 113                 {
 114                      aelemfast => 1,
 115                      and       => 1,
 116                      const     => 1,
 117                      enteriter => 1,
 118                      iter      => 1,
 119                      leaveloop => 1,
 120                      leavesub  => 1,
 121                      lineseq   => 2,
 122                      nextstate => 2,
 123                      null      => 1,
 124                      padsv     => 1, # this is the additional active op
 125                      pushmark  => 1,
 126                      unstack   => 1,
 127                 }
 128             );
 129 }
 130
 131 #
 132 # multideref
 133 #
 134 # try many permutations of aggregate lookup expressions
 135
 136 {
 137     package Foo;
 138
 139     my (@agg_lex, %agg_lex, $i_lex, $r_lex);
 140     our (@agg_pkg, %agg_pkg, $i_pkg, $r_pkg);
 141
 142     my $f;
 143     my @bodies = ('[0]', '[128]', '[$i_lex]', '[$i_pkg]',
 144                    '{foo}', '{$i_lex}', '{$i_pkg}',
 145                   );
 146
 147     for my $prefix ('$f->()->', '$agg_lex', '$agg_pkg', '$r_lex->', '$r_pkg->')
 148     {
 149         for my $mod ('', 'local', 'exists', 'delete') {
 150             for my $body0 (@bodies) {
 151                 for my $body1 ('', @bodies) {
 152                     for my $body2 ('', '[2*$i_lex]') {
 153                         my $code = "$mod $prefix$body0$body1$body2";
 154                         my $sub = "sub { $code }";
 155                         my $coderef = eval $sub
 156                             or die "eval '$sub': $@";
 157
 158                         my %c = (aelem         => 0,
 159                                  aelemfast     => 0,
 160                                  aelemfast_lex => 0,
 161                                  exists        => 0,
 162                                  delete        => 0,
 163                                  helem         => 0,
 164                                  multideref    => 0,
 165                         );
 166
 167                         my $top = 'aelem';
 168                         if ($code =~ /^\s*\$agg_...\[0\]$/) {
 169                             # we should expect aelemfast rather than multideref
 170                             $top = $code =~ /lex/ ? 'aelemfast_lex'
 171                                                   : 'aelemfast';
 172                             $c{$top} = 1;
 173                         }
 174                         else {
 175                             $c{multideref} = 1;
 176                         }
 177
 178                         if ($body2 ne '') {
 179                             # trailing index; top aelem/exists/whatever
 180                             # node is kept
 181                             $top = $mod unless $mod eq '' or $mod eq 'local';
 182                             $c{$top} = 1
 183                         }
 184
 185                         ::test_opcount(0, $sub, $coderef, \%c);
 186                     }
 187                 }
 188             }
 189         }
 190     }
 191 }
 192
 193
 194 # multideref: ensure that the prefix expression and trailing index
 195 # expression are optimised (include aelemfast in those expressions)
 196
 197
 198 test_opcount(0, 'multideref expressions',
 199                 sub { ($_[0] // $_)->[0]{2*$_[0]} },
 200                 {
 201                     aelemfast  => 2,
 202                     helem      => 1,
 203                     multideref => 1,
 204                 },
 205             );
 206
 207 # multideref with interesting constant indices
 208
 209
 210 test_opcount(0, 'multideref const index',
 211                 sub { $_->{1}{1.1} },
 212                 {
 213                     helem      => 0,
 214                     multideref => 1,
 215                 },
 216             );
 217
 218 use constant my_undef => undef;
 219 test_opcount(0, 'multideref undef const index',
 220                 sub { $_->{+my_undef} },
 221                 {
 222                     helem      => 1,
 223                     multideref => 0,
 224                 },
 225             );
 226
 227 # multideref when its the first op in a subchain
 228
 229 test_opcount(0, 'multideref op_other etc',
 230                 sub { $_{foo} = $_ ? $_{bar} : $_{baz} },
 231                 {
 232                     helem      => 0,
 233                     multideref => 3,
 234                 },
 235             );
 236
 237 # multideref without hints
 238
 239 {
 240     no strict;
 241     no warnings;
 242
 243     test_opcount(0, 'multideref no hints',
 244                 sub { $_{foo}[0] },
 245                 {
 246                     aelem      => 0,
 247                     helem      => 0,
 248                     multideref => 1,
 249                 },
 250             );
 251 }
 252
 253 # exists shouldn't clash with aelemfast
 254
 255 test_opcount(0, 'multideref exists',
 256                 sub { exists $_[0] },
 257                 {
 258                     aelem      => 0,
 259                     aelemfast  => 0,
 260                     multideref => 1,
 261                 },
 262             );