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 2584;
  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             );
 263
 264 test_opcount(0, 'barewords can be constant-folded',
 265              sub { no strict 'subs'; FOO . BAR },
 266              {
 267                  concat => 0,
 268              });
 269
 270 {
 271     no warnings 'experimental::signatures';
 272     use feature 'signatures';
 273
 274     my @a;
 275     test_opcount(0, 'signature default expressions get optimised',
 276                  sub ($s = $a[0]) {},
 277                  {
 278                      aelem         => 0,
 279                      aelemfast_lex => 1,
 280                  });
 281 }
 282
 283 # in-place sorting
 284
 285 {
 286     local our @global = (3,2,1);
 287     my @lex = qw(a b c);
 288
 289     test_opcount(0, 'in-place sort of global',
 290                  sub { @global = sort @global; 1 },
 291                  {
 292                      rv2av   => 1,
 293                      aassign => 0,
 294                  });
 295
 296     test_opcount(0, 'in-place sort of lexical',
 297                  sub { @lex = sort @lex; 1 },
 298                  {
 299                      padav   => 1,
 300                      aassign => 0,
 301                  });
 302
 303     test_opcount(0, 'in-place reversed sort of global',
 304                  sub { @global = sort { $b <=> $a } @global; 1 },
 305                  {
 306                      rv2av   => 1,
 307                      aassign => 0,
 308                  });
 309
 310
 311     test_opcount(0, 'in-place custom sort of global',
 312                  sub { @global = sort {  $a<$b?1:$a>$b?-1:0 } @global; 1 },
 313                  {
 314                      rv2av   => 1,
 315                      aassign => 0,
 316                  });
 317
 318     sub mysort { $b cmp $a };
 319     test_opcount(0, 'in-place sort with function of lexical',
 320                  sub { @lex = sort mysort @lex; 1 },
 321                  {
 322                      padav   => 1,
 323                      aassign => 0,
 324                  });
 325
 326
 327 }
 328
 329 # in-place assign optimisation for @a = split
 330
 331 {
 332     local our @pkg;
 333     my @lex;
 334
 335     for (['@pkg',       0, ],
 336          ['local @pkg', 0, ],
 337          ['@lex',       0, ],
 338          ['my @a',      0, ],
 339          ['@{[]}',      1, ],
 340     ){
 341         # partial implies that the aassign has been optimised away, but
 342         # not the rv2av
 343         my ($code, $partial) = @$_;
 344         test_opcount(0, "in-place assignment for split: $code",
 345                 eval qq{sub { $code = split }},
 346                 {
 347                     padav   => 0,
 348                     rv2av   => $partial,
 349                     aassign => 0,
 350                 });
 351     }
 352 }
 353
 354 # index(...) == -1 and variants optimise away the EQ/NE/etc and CONST
 355 # and with $lex = (index(...) == -1), the assignment is optimised away
 356 # too
 357
 358 {
 359     local our @pkg;
 360     my @lex;
 361
 362     my ($x, $y, $z);
 363     for my $assign (0, 1) {
 364         for my $index ('index($x,$y)', 'rindex($x,$y)') {
 365             for my $fmt (
 366                     "%s <= -1",
 367                     "%s == -1",
 368                     "%s != -1",
 369                     "%s >  -1",
 370
 371                     "%s <  0",
 372                     "%s >= 0",
 373
 374                     "-1 <  %s",
 375                     "-1 == %s",
 376                     "-1 != %s",
 377                     "-1 >= %s",
 378
 379                     " 0 <= %s",
 380                     " 0 >  %s",
 381
 382             ) {
 383                 my $expr = sprintf $fmt, $index;
 384                 $expr = "\$z = ($expr)" if $assign;
 385
 386                 test_opcount(0, "optimise away compare,const in $expr",
 387                         eval qq{sub { $expr }},
 388                         {
 389                             lt      => 0,
 390                             le      => 0,
 391                             eq      => 0,
 392                             ne      => 0,
 393                             ge      => 0,
 394                             gt      => 0,
 395                             const   => 0,
 396                             sassign => 0,
 397                             padsv   => 2.
 398                         });
 399             }
 400         }
 401     }
 402 }
 403
 404
 405 # a sprintf that can't be optimised shouldn't stop the .= concat being
 406 # optimised
 407
 408 {
 409     my ($i,$j,$s);
 410     test_opcount(0, "sprintf pessimised",
 411         sub { $s .= sprintf "%d%d",$i, $j },
 412         {
 413             const       => 1,
 414             sprintf     => 1,
 415             concat      => 0,
 416             multiconcat => 1,
 417             padsv       => 2,
 418         });
 419 }
 420
 421
 422 # sprintf with constant args should be constant folded
 423
 424 test_opcount(0, "sprintf constant args",
 425         sub { sprintf "%s%s", "abc", "def" },
 426         {
 427             const       => 1,
 428             sprintf     => 0,
 429             multiconcat => 0.
 430         });
 431
 432 #
 433 # concats and assigns that should be optimised into a single multiconcat
 434 # op
 435
 436 {
 437
 438     my %seen; # weed out duplicate combinations
 439
 440     # these are the ones where using multiconcat isn't a gain, so should
 441     # be pessimised
 442     my %pessimise = map { $_ => 1 }
 443                         '$a1.$a2',
 444                         '"$a1$a2"',
 445                         '$pkg .= $a1',
 446                         '$pkg .= "$a1"',
 447                         '$lex  = $a1.$a2',
 448                         '$lex  = "$a1$a2"',
 449                         # these already constant folded
 450                         'sprintf("-")',
 451                         '$pkg  = sprintf("-")',
 452                         '$lex  = sprintf("-")',
 453                         'my $l = sprintf("-")',
 454                     ;
 455
 456     for my $lhs (
 457         '',
 458         '$pkg  = ',
 459         '$pkg .= ',
 460         '$lex  = ',
 461         '$lex .= ',
 462         'my $l = ',
 463     ) {
 464         for my $nargs (0..3) {
 465             for my $type (0..2) {
 466                 # 0: $a . $b
 467                 # 1: "$a$b"
 468                 # 2: sprintf("%s%s", $a, $b)
 469
 470                 for my $const (0..4) {
 471                     # 0: no consts:       "$a1$a2"
 472                     # 1: interior consts: "$a1-$a2"
 473                     # 2: + LH   edge:    "-$a1-$a2"
 474                     # 3: + RH   edge:     "$a1-$a2-"
 475                     # 4: + both edge:    "-$a1-$a2-"
 476
 477                     my @args;
 478                     my @sprintf_args;
 479                     my $c = $type == 0 ? '"-"' : '-';
 480                     push @args, $c if $const == 2 || $const == 4;
 481                     for my $n (1..$nargs) {
 482                         if ($type == 2) {
 483                             # sprintf
 484                             push @sprintf_args, "\$a$n";
 485                             push @args, '%s';
 486                         }
 487                         else {
 488                             push @args, "\$a$n";
 489                         }
 490                         push @args, $c if $const;
 491                     }
 492                     pop @args if  $const == 1 || $const == 2;
 493
 494                     push @args, $c if $nargs == 0 && $const == 1;
 495
 496
 497                     if ($type == 2) {
 498                         # sprintf
 499                         next unless @args;
 500                     }
 501                     else {
 502                         # To ensure that there's at least once concat
 503                         # action, if appending, need at least one RHS arg;
 504                         # else least 2 args:
 505                         #    $x = $a . $b
 506                         #    $x .= $a
 507                         next unless @args >= ($lhs =~ /\./ ? 1 : 2);
 508                     }
 509
 510                     my $rhs;
 511                     if ($type == 0) {
 512                         $rhs = join('.', @args);
 513                     }
 514                     elsif ($type == 1) {
 515                         $rhs = '"' . join('',  @args) . '"'
 516                     }
 517                     else {
 518                         $rhs = 'sprintf("'
 519                                . join('',  @args)
 520                                . '"'
 521                                . join('', map ",$_",  @sprintf_args)
 522                                . ')';
 523                     }
 524
 525                     my $expr = $lhs . $rhs;
 526
 527                     next if exists $seen{$expr};
 528                     $seen{$expr} = 1;
 529
 530                     my ($a1, $a2, $a3);
 531                     my $lex;
 532                     our $pkg;
 533                     my $sub = eval qq{sub { $expr }};
 534                     die "eval(sub { $expr }: $@" if $@;
 535
 536                     my $pm = $pessimise{$expr};
 537                     test_opcount(0, ($pm ? "concat     " : "multiconcat")
 538                                             . ": $expr",
 539                             $sub,
 540                             $pm
 541                             ?   {   multiconcat => 0 }
 542                             :   {
 543                                     multiconcat => 1,
 544                                     padsv       => $nargs,
 545                                     concat      => 0,
 546                                     sprintf     => 0,
 547                                     const       => 0,
 548                                     sassign     => 0,
 549                                     stringify   => 0,
 550                                     gv          => 0, # optimised to gvsv
 551                                 });
 552                 }
 553             }
 554         }
 555     }
 556 }
 557
 558 # $lex = "foo" should *not* get converted into a multiconcat - there's
 559 # no actual concatenation involved, and treating it as a degnerate concat
 560 # would forego any COW copy efficiency
 561
 562 test_opcount(0, '$lex = "foo"', sub { my $x; $x = "foo"; },
 563         {
 564             multiconcat => 0,
 565         });
 566
 567 # for '$lex1 = $lex2 . $lex3', multiconcat is normally slower than
 568 # concat, except in the specific case of '$lex1 = $lex2 . $lex1'
 569
 570 test_opcount(0, '$lex1 = $lex2 . $lex1', sub { my ($x,$y); $x = $y . $x },
 571             {
 572                 multiconcat => 1,
 573                 padsv       => 4, # 2 are from the my()
 574                 concat      => 0,
 575                 sassign     => 0,
 576                 stringify   => 0,
 577             });
 578 test_opcount(0, '$lex1 = "$lex2$lex1"', sub { my ($x,$y); $x = "$y$x" },
 579             {
 580                 multiconcat => 1,
 581                 padsv       => 4, # 2 are from the my()
 582                 concat      => 0,
 583                 sassign     => 0,
 584                 stringify   => 0,
 585             });
 586 test_opcount(0, '$lex1 = $lex1 . $lex1', sub { my $x; $x = $x . $x },
 587             {
 588                 multiconcat => 0,
 589             });
 590
 591 # 'my $x .= ...' doesn't make a lot of sense and so isn't optimised
 592 test_opcount(0, 'my $a .= $b.$c.$d', sub { our ($b,$c,$d); my $a .= $b.$c.$d },
 593             {
 594                 padsv => 1,
 595             });
 596
 597 # prefer rcatline optimisation over multiconcat
 598
 599 test_opcount(0, "rcatline", sub { my ($x,$y); open FOO, "xxx"; $x .= <FOO> },
 600         {
 601             rcatline    => 1,
 602             readline    => 0,
 603             multiconcat => 0,
 604             concat      => 0,
 605         });
 606
 607 # long chains of concats should be converted into chained multiconcats
 608
 609 {
 610     my @a;
 611     for my $i (60..68) { # check each side of 64 threshold
 612         my $c = join '.', map "\$a[$_]", 1..$i;
 613         my $sub = eval qq{sub { $c }} or die $@;
 614         test_opcount(0, "long chain $i", $sub,
 615             {
 616                 multiconcat => $i > 65 ? 2 : 1,
 617                 concat      => $i == 65 ? 1 : 0,
 618                 aelem       => 0,
 619                 aelemfast   => 0,
 620             });
 621     }
 622 }
 623
 624 # with C<$state $s = $a . $b . ....>, the assign is optimised away,
 625 # but the padsv isn't (it's treated like a general LHS expression rather
 626 # than using OPpTARGET_MY).
 627
 628 test_opcount(0, "state works with multiconcat",
 629                 sub { use feature 'state'; our ($a, $b, $c); state $s = $a . $b . $c },
 630                 {
 631                     multiconcat => 1,
 632                     concat      => 0,
 633                     sassign     => 0,
 634                     once        => 1,
 635                     padsv       => 2, # one each for the next/once branches
 636                 });
 637
 638 # multiple concats of constants preceded by at least one non-constant
 639 # shouldn't get constant-folded so that a concat overload method is called
 640 # for each arg. So every second constant string is left as an OP_CONST
 641
 642 test_opcount(0, "multiconcat: 2 adjacent consts",
 643                 sub { my ($a, $b); $a = $b . "c" . "d" },
 644                 {
 645                     const       => 1,
 646                     multiconcat => 1,
 647                     concat      => 0,
 648                     sassign     => 0,
 649                 });
 650 test_opcount(0, "multiconcat: 3 adjacent consts",
 651                 sub { my ($a, $b); $a = $b . "c" . "d" . "e" },
 652                 {
 653                     const       => 1,
 654                     multiconcat => 1,
 655                     concat      => 0,
 656                     sassign     => 0,
 657                 });
 658 test_opcount(0, "multiconcat: 4 adjacent consts",
 659                 sub { my ($a, $b); $a = $b . "c" . "d" . "e" ."f" },
 660                 {
 661                     const       => 2,
 662                     multiconcat => 1,
 663                     concat      => 0,
 664                     sassign     => 0,
 665                 });
 666
 667 # multiconcat shouldn't include the assign if the LHS has 'local'
 668
 669 test_opcount(0, "multiconcat: local assign",
 670                 sub { our $global; local $global = "$global-X" },
 671                 {
 672                     const       => 0,
 673                     gvsv        => 2,
 674                     multiconcat => 1,
 675                     concat      => 0,
 676                     sassign     => 1,
 677                 });
 678
 679 {
 680     use feature 'defer';
 681     no warnings 'experimental::defer';
 682
 683     test_opcount(1, "pushdefer: block is optimized",
 684                     sub { my @a; defer { $a[0] } },
 685                     {
 686                         aelemfast_lex => 1,
 687                         aelem         => 0,
 688                     });
 689 }