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 13BEGIN { 14 chdir 't'; 15 require './test.pl'; 16 skip_all_if_miniperl("No B under miniperl"); 17 @INC = '../lib'; 18} 19 20use warnings; 21use strict; 22 23plan 2582; 24 25use 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 78test_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 198test_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 210test_opcount(0, 'multideref const index', 211 sub { $_->{1}{1.1} }, 212 { 213 helem => 0, 214 multideref => 1, 215 }, 216 ); 217 218use constant my_undef => undef; 219test_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 229test_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 255test_opcount(0, 'multideref exists', 256 sub { exists $_[0] }, 257 { 258 aelem => 0, 259 aelemfast => 0, 260 multideref => 1, 261 }, 262 ); 263 264test_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 424test_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 562test_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 570test_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 }); 578test_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 }); 586test_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 592test_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 599test_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 628test_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 642test_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 }); 650test_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 }); 658test_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