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 23use B (); 24 25 26{ 27 my %counts; 28 29 # for a given op, increment $count{opname}. Treat null ops 30 # as "ex-foo" where possible 31 32 sub B::OP::test_opcount_callback { 33 my ($op) = @_; 34 my $name = $op->name; 35 if ($name eq 'null') { 36 my $targ = $op->targ; 37 if ($targ) { 38 $name = "ex-" . substr(B::ppname($targ), 3); 39 } 40 } 41 $counts{$name}++; 42 } 43 44 # Given a code ref and a hash ref of expected op counts, check that 45 # for each opname => count pair, whether that op appears that many 46 # times in the op tree for that sub. If $debug is 1, display all the 47 # op counts for the sub. 48 49 sub test_opcount { 50 my ($debug, $desc, $coderef, $expected_counts) = @_; 51 52 %counts = (); 53 B::walkoptree(B::svref_2object($coderef)->ROOT, 54 'test_opcount_callback'); 55 56 if ($debug) { 57 note(sprintf "%3d %s", $counts{$_}, $_) for sort keys %counts; 58 } 59 60 my @exp; 61 for (sort keys %$expected_counts) { 62 my ($c, $e) = ($counts{$_}//0, $expected_counts->{$_}); 63 if ($c != $e) { 64 push @exp, "expected $e, got $c: $_"; 65 } 66 } 67 ok(!@exp, $desc); 68 if (@exp) { 69 diag($_) for @exp; 70 } 71 } 72} 73 74# aelem => aelemfast: a basic test that this test file works 75 76test_opcount(0, "basic aelemfast", 77 sub { our @a; $a[0] = 1 }, 78 { 79 aelem => 0, 80 aelemfast => 1, 81 'ex-aelem' => 1, 82 } 83 ); 84 85# Porting/bench.pl tries to create an empty and active loop, with the 86# ops executed being exactly the same apart from the additional ops 87# in the active loop. Check that this remains true. 88 89{ 90 test_opcount(0, "bench.pl empty loop", 91 sub { for my $x (1..$ARGV[0]) { 1; } }, 92 { 93 aelemfast => 1, 94 and => 1, 95 const => 1, 96 enteriter => 1, 97 iter => 1, 98 leaveloop => 1, 99 leavesub => 1, 100 lineseq => 2, 101 nextstate => 2, 102 null => 1, 103 pushmark => 1, 104 unstack => 1, 105 } 106 ); 107 108 no warnings 'void'; 109 test_opcount(0, "bench.pl active loop", 110 sub { for my $x (1..$ARGV[0]) { $x; } }, 111 { 112 aelemfast => 1, 113 and => 1, 114 const => 1, 115 enteriter => 1, 116 iter => 1, 117 leaveloop => 1, 118 leavesub => 1, 119 lineseq => 2, 120 nextstate => 2, 121 null => 1, 122 padsv => 1, # this is the additional active op 123 pushmark => 1, 124 unstack => 1, 125 } 126 ); 127} 128 129# 130# multideref 131# 132# try many permutations of aggregate lookup expressions 133 134{ 135 package Foo; 136 137 my (@agg_lex, %agg_lex, $i_lex, $r_lex); 138 our (@agg_pkg, %agg_pkg, $i_pkg, $r_pkg); 139 140 my $f; 141 my @bodies = ('[0]', '[128]', '[$i_lex]', '[$i_pkg]', 142 '{foo}', '{$i_lex}', '{$i_pkg}', 143 ); 144 145 for my $prefix ('$f->()->', '$agg_lex', '$agg_pkg', '$r_lex->', '$r_pkg->') 146 { 147 for my $mod ('', 'local', 'exists', 'delete') { 148 for my $body0 (@bodies) { 149 for my $body1 ('', @bodies) { 150 for my $body2 ('', '[2*$i_lex]') { 151 my $code = "$mod $prefix$body0$body1$body2"; 152 my $sub = "sub { $code }"; 153 my $coderef = eval $sub 154 or die "eval '$sub': $@"; 155 156 my %c = (aelem => 0, 157 aelemfast => 0, 158 aelemfast_lex => 0, 159 exists => 0, 160 delete => 0, 161 helem => 0, 162 multideref => 0, 163 ); 164 165 my $top = 'aelem'; 166 if ($code =~ /^\s*\$agg_...\[0\]$/) { 167 # we should expect aelemfast rather than multideref 168 $top = $code =~ /lex/ ? 'aelemfast_lex' 169 : 'aelemfast'; 170 $c{$top} = 1; 171 } 172 else { 173 $c{multideref} = 1; 174 } 175 176 if ($body2 ne '') { 177 # trailing index; top aelem/exists/whatever 178 # node is kept 179 $top = $mod unless $mod eq '' or $mod eq 'local'; 180 $c{$top} = 1 181 } 182 183 ::test_opcount(0, $sub, $coderef, \%c); 184 } 185 } 186 } 187 } 188 } 189} 190 191 192# multideref: ensure that the prefix expression and trailing index 193# expression are optimised (include aelemfast in those expressions) 194 195 196test_opcount(0, 'multideref expressions', 197 sub { ($_[0] // $_)->[0]{2*$_[0]} }, 198 { 199 aelemfast => 2, 200 helem => 1, 201 multideref => 1, 202 }, 203 ); 204 205# multideref with interesting constant indices 206 207 208test_opcount(0, 'multideref const index', 209 sub { $_->{1}{1.1} }, 210 { 211 helem => 0, 212 multideref => 1, 213 }, 214 ); 215 216use constant my_undef => undef; 217test_opcount(0, 'multideref undef const index', 218 sub { $_->{+my_undef} }, 219 { 220 helem => 1, 221 multideref => 0, 222 }, 223 ); 224 225# multideref when its the first op in a subchain 226 227test_opcount(0, 'multideref op_other etc', 228 sub { $_{foo} = $_ ? $_{bar} : $_{baz} }, 229 { 230 helem => 0, 231 multideref => 3, 232 }, 233 ); 234 235# multideref without hints 236 237{ 238 no strict; 239 no warnings; 240 241 test_opcount(0, 'multideref no hints', 242 sub { $_{foo}[0] }, 243 { 244 aelem => 0, 245 helem => 0, 246 multideref => 1, 247 }, 248 ); 249} 250 251# exists shouldn't clash with aelemfast 252 253test_opcount(0, 'multideref exists', 254 sub { exists $_[0] }, 255 { 256 aelem => 0, 257 aelemfast => 0, 258 multideref => 1, 259 }, 260 ); 261 262test_opcount(0, 'barewords can be constant-folded', 263 sub { no strict 'subs'; FOO . BAR }, 264 { 265 concat => 0, 266 }); 267 268{ 269 use feature 'signatures'; 270 271 my @a; 272 test_opcount(0, 'signature default expressions get optimised', 273 sub ($s = $a[0]) {}, 274 { 275 aelem => 0, 276 aelemfast_lex => 1, 277 }); 278} 279 280# in-place sorting 281 282{ 283 local our @global = (3,2,1); 284 my @lex = qw(a b c); 285 286 test_opcount(0, 'in-place sort of global', 287 sub { @global = sort @global; 1 }, 288 { 289 rv2av => 1, 290 aassign => 0, 291 }); 292 293 test_opcount(0, 'in-place sort of lexical', 294 sub { @lex = sort @lex; 1 }, 295 { 296 padav => 1, 297 aassign => 0, 298 }); 299 300 test_opcount(0, 'in-place reversed sort of global', 301 sub { @global = sort { $b <=> $a } @global; 1 }, 302 { 303 rv2av => 1, 304 aassign => 0, 305 }); 306 307 308 test_opcount(0, 'in-place custom sort of global', 309 sub { @global = sort { $a<$b?1:$a>$b?-1:0 } @global; 1 }, 310 { 311 rv2av => 1, 312 aassign => 0, 313 }); 314 315 sub mysort { $b cmp $a }; 316 test_opcount(0, 'in-place sort with function of lexical', 317 sub { @lex = sort mysort @lex; 1 }, 318 { 319 padav => 1, 320 aassign => 0, 321 }); 322 323 324} 325 326# in-place assign optimisation for @a = split 327 328{ 329 local our @pkg; 330 my @lex; 331 332 for (['@pkg', 0, ], 333 ['local @pkg', 0, ], 334 ['@lex', 0, ], 335 ['my @a', 0, ], 336 ['@{[]}', 1, ], 337 ){ 338 # partial implies that the aassign has been optimised away, but 339 # not the rv2av 340 my ($code, $partial) = @$_; 341 test_opcount(0, "in-place assignment for split: $code", 342 eval qq{sub { $code = split }}, 343 { 344 padav => 0, 345 rv2av => $partial, 346 aassign => 0, 347 }); 348 } 349} 350 351# index(...) == -1 and variants optimise away the EQ/NE/etc and CONST 352# and with $lex = (index(...) == -1), the assignment is optimised away 353# too 354 355{ 356 local our @pkg; 357 my @lex; 358 359 my ($x, $y, $z); 360 for my $assign (0, 1) { 361 for my $index ('index($x,$y)', 'rindex($x,$y)') { 362 for my $fmt ( 363 "%s <= -1", 364 "%s == -1", 365 "%s != -1", 366 "%s > -1", 367 368 "%s < 0", 369 "%s >= 0", 370 371 "-1 < %s", 372 "-1 == %s", 373 "-1 != %s", 374 "-1 >= %s", 375 376 " 0 <= %s", 377 " 0 > %s", 378 379 ) { 380 my $expr = sprintf $fmt, $index; 381 $expr = "\$z = ($expr)" if $assign; 382 383 test_opcount(0, "optimise away compare,const in $expr", 384 eval qq{sub { $expr }}, 385 { 386 lt => 0, 387 le => 0, 388 eq => 0, 389 ne => 0, 390 ge => 0, 391 gt => 0, 392 const => 0, 393 sassign => 0, 394 padsv => 2. 395 }); 396 } 397 } 398 } 399} 400 401 402# a sprintf that can't be optimised shouldn't stop the .= concat being 403# optimised 404 405{ 406 my ($i,$j,$s); 407 test_opcount(0, "sprintf pessimised", 408 sub { $s .= sprintf "%d%d",$i, $j }, 409 { 410 const => 1, 411 sprintf => 1, 412 concat => 0, 413 multiconcat => 1, 414 padsv => 2, 415 }); 416} 417 418 419# sprintf with constant args should be constant folded 420 421test_opcount(0, "sprintf constant args", 422 sub { sprintf "%s%s", "abc", "def" }, 423 { 424 const => 1, 425 sprintf => 0, 426 multiconcat => 0. 427 }); 428 429# 430# concats and assigns that should be optimised into a single multiconcat 431# op 432 433{ 434 435 my %seen; # weed out duplicate combinations 436 437 # these are the ones where using multiconcat isn't a gain, so should 438 # be pessimised 439 my %pessimise = map { $_ => 1 } 440 '$a1.$a2', 441 '"$a1$a2"', 442 '$pkg .= $a1', 443 '$pkg .= "$a1"', 444 '$lex = $a1.$a2', 445 '$lex = "$a1$a2"', 446 # these already constant folded 447 'sprintf("-")', 448 '$pkg = sprintf("-")', 449 '$lex = sprintf("-")', 450 'my $l = sprintf("-")', 451 ; 452 453 for my $lhs ( 454 '', 455 '$pkg = ', 456 '$pkg .= ', 457 '$lex = ', 458 '$lex .= ', 459 'my $l = ', 460 ) { 461 for my $nargs (0..3) { 462 for my $type (0..2) { 463 # 0: $a . $b 464 # 1: "$a$b" 465 # 2: sprintf("%s%s", $a, $b) 466 467 for my $const (0..4) { 468 # 0: no consts: "$a1$a2" 469 # 1: interior consts: "$a1-$a2" 470 # 2: + LH edge: "-$a1-$a2" 471 # 3: + RH edge: "$a1-$a2-" 472 # 4: + both edge: "-$a1-$a2-" 473 474 my @args; 475 my @sprintf_args; 476 my $c = $type == 0 ? '"-"' : '-'; 477 push @args, $c if $const == 2 || $const == 4; 478 for my $n (1..$nargs) { 479 if ($type == 2) { 480 # sprintf 481 push @sprintf_args, "\$a$n"; 482 push @args, '%s'; 483 } 484 else { 485 push @args, "\$a$n"; 486 } 487 push @args, $c if $const; 488 } 489 pop @args if $const == 1 || $const == 2; 490 491 push @args, $c if $nargs == 0 && $const == 1; 492 493 494 if ($type == 2) { 495 # sprintf 496 next unless @args; 497 } 498 else { 499 # To ensure that there's at least once concat 500 # action, if appending, need at least one RHS arg; 501 # else least 2 args: 502 # $x = $a . $b 503 # $x .= $a 504 next unless @args >= ($lhs =~ /\./ ? 1 : 2); 505 } 506 507 my $rhs; 508 if ($type == 0) { 509 $rhs = join('.', @args); 510 } 511 elsif ($type == 1) { 512 $rhs = '"' . join('', @args) . '"' 513 } 514 else { 515 $rhs = 'sprintf("' 516 . join('', @args) 517 . '"' 518 . join('', map ",$_", @sprintf_args) 519 . ')'; 520 } 521 522 my $expr = $lhs . $rhs; 523 524 next if exists $seen{$expr}; 525 $seen{$expr} = 1; 526 527 my ($a1, $a2, $a3); 528 my $lex; 529 our $pkg; 530 my $sub = eval qq{sub { $expr }}; 531 die "eval(sub { $expr }: $@" if $@; 532 533 my $pm = $pessimise{$expr}; 534 test_opcount(0, ($pm ? "concat " : "multiconcat") 535 . ": $expr", 536 $sub, 537 $pm 538 ? { multiconcat => 0 } 539 : { 540 multiconcat => 1, 541 padsv => $nargs, 542 concat => 0, 543 sprintf => 0, 544 const => 0, 545 sassign => 0, 546 stringify => 0, 547 gv => 0, # optimised to gvsv 548 }); 549 } 550 } 551 } 552 } 553} 554 555# $lex = "foo" should *not* get converted into a multiconcat - there's 556# no actual concatenation involved, and treating it as a degnerate concat 557# would forego any COW copy efficiency 558 559test_opcount(0, '$lex = "foo"', sub { my $x; $x = "foo"; }, 560 { 561 multiconcat => 0, 562 }); 563 564# for '$lex1 = $lex2 . $lex3', multiconcat is normally slower than 565# concat, except in the specific case of '$lex1 = $lex2 . $lex1' 566 567test_opcount(0, '$lex1 = $lex2 . $lex1', sub { my ($x,$y); $x = $y . $x }, 568 { 569 multiconcat => 1, 570 padsv => 4, # 2 are from the my() 571 concat => 0, 572 sassign => 0, 573 stringify => 0, 574 }); 575test_opcount(0, '$lex1 = "$lex2$lex1"', sub { my ($x,$y); $x = "$y$x" }, 576 { 577 multiconcat => 1, 578 padsv => 4, # 2 are from the my() 579 concat => 0, 580 sassign => 0, 581 stringify => 0, 582 }); 583test_opcount(0, '$lex1 = $lex1 . $lex1', sub { my $x; $x = $x . $x }, 584 { 585 multiconcat => 0, 586 }); 587 588# 'my $x .= ...' doesn't make a lot of sense and so isn't optimised 589test_opcount(0, 'my $a .= $b.$c.$d', sub { our ($b,$c,$d); my $a .= $b.$c.$d }, 590 { 591 padsv => 1, 592 }); 593 594# prefer rcatline optimisation over multiconcat 595 596test_opcount(0, "rcatline", sub { my ($x,$y); open FOO, "xxx"; $x .= <FOO> }, 597 { 598 rcatline => 1, 599 readline => 0, 600 multiconcat => 0, 601 concat => 0, 602 }); 603 604# long chains of concats should be converted into chained multiconcats 605 606{ 607 my @a; 608 for my $i (60..68) { # check each side of 64 threshold 609 my $c = join '.', map "\$a[$_]", 1..$i; 610 my $sub = eval qq{sub { $c }} or die $@; 611 test_opcount(0, "long chain $i", $sub, 612 { 613 multiconcat => $i > 65 ? 2 : 1, 614 concat => $i == 65 ? 1 : 0, 615 aelem => 0, 616 aelemfast => 0, 617 }); 618 } 619} 620 621# with C<$state $s = $a . $b . ....>, the assign is optimised away, 622# but the padsv isn't (it's treated like a general LHS expression rather 623# than using OPpTARGET_MY). 624 625test_opcount(0, "state works with multiconcat", 626 sub { use feature 'state'; our ($a, $b, $c); state $s = $a . $b . $c }, 627 { 628 multiconcat => 1, 629 concat => 0, 630 sassign => 0, 631 once => 1, 632 padsv => 2, # one each for the next/once branches 633 }); 634 635# multiple concats of constants preceded by at least one non-constant 636# shouldn't get constant-folded so that a concat overload method is called 637# for each arg. So every second constant string is left as an OP_CONST 638 639test_opcount(0, "multiconcat: 2 adjacent consts", 640 sub { my ($a, $b); $a = $b . "c" . "d" }, 641 { 642 const => 1, 643 multiconcat => 1, 644 concat => 0, 645 sassign => 0, 646 }); 647test_opcount(0, "multiconcat: 3 adjacent consts", 648 sub { my ($a, $b); $a = $b . "c" . "d" . "e" }, 649 { 650 const => 1, 651 multiconcat => 1, 652 concat => 0, 653 sassign => 0, 654 }); 655test_opcount(0, "multiconcat: 4 adjacent consts", 656 sub { my ($a, $b); $a = $b . "c" . "d" . "e" ."f" }, 657 { 658 const => 2, 659 multiconcat => 1, 660 concat => 0, 661 sassign => 0, 662 }); 663 664# multiconcat shouldn't include the assign if the LHS has 'local' 665 666test_opcount(0, "multiconcat: local assign", 667 sub { our $global; local $global = "$global-X" }, 668 { 669 const => 0, 670 gvsv => 2, 671 multiconcat => 1, 672 concat => 0, 673 sassign => 1, 674 }); 675 676{ 677 use feature 'try'; 678 679 test_opcount(0, "try/catch: catch block is optimized", 680 sub { my @a; try {} catch($e) { $a[0] } }, 681 { 682 aelemfast_lex => 1, 683 aelem => 0, 684 }); 685} 686 687{ 688 use feature 'defer'; 689 no warnings 'experimental::defer'; 690 691 test_opcount(0, "pushdefer: block is optimized", 692 sub { my @a; defer { $a[0] } }, 693 { 694 aelemfast_lex => 1, 695 aelem => 0, 696 }); 697} 698 699# builtin:: function calls should be replaced with efficient op implementations 700no warnings 'experimental::builtin'; 701 702test_opcount(0, "builtin::true/false are replaced with constants", 703 sub { my $x = builtin::true(); my $y = builtin::false() }, 704 { 705 entersub => 0, 706 const => 2, 707 }); 708 709test_opcount(0, "builtin::is_bool is replaced with direct opcode", 710 sub { my $x; my $y; $y = builtin::is_bool($x); }, 711 { 712 entersub => 0, 713 is_bool => 1, 714 padsv => 3, 715 padsv_store => 1, 716 }); 717 718test_opcount(0, "builtin::is_bool gets constant-folded", 719 sub { builtin::is_bool(123); }, 720 { 721 entersub => 0, 722 is_bool => 0, 723 const => 1, 724 }); 725 726test_opcount(0, "builtin::weaken is replaced with direct opcode", 727 sub { my $x = []; builtin::weaken($x); }, 728 { 729 entersub => 0, 730 weaken => 1, 731 }); 732 733test_opcount(0, "builtin::unweaken is replaced with direct opcode", 734 sub { my $x = []; builtin::unweaken($x); }, 735 { 736 entersub => 0, 737 unweaken => 1, 738 }); 739 740test_opcount(0, "builtin::is_weak is replaced with direct opcode", 741 sub { builtin::is_weak([]); }, 742 { 743 entersub => 0, 744 is_weak => 1, 745 }); 746 747test_opcount(0, "builtin::blessed is replaced with direct opcode", 748 sub { builtin::blessed([]); }, 749 { 750 entersub => 0, 751 blessed => 1, 752 }); 753 754test_opcount(0, "builtin::refaddr is replaced with direct opcode", 755 sub { builtin::refaddr([]); }, 756 { 757 entersub => 0, 758 refaddr => 1, 759 }); 760 761test_opcount(0, "builtin::reftype is replaced with direct opcode", 762 sub { builtin::reftype([]); }, 763 { 764 entersub => 0, 765 reftype => 1, 766 }); 767 768my $one_point_five = 1.5; # Prevent const-folding. 769test_opcount(0, "builtin::ceil is replaced with direct opcode", 770 sub { builtin::ceil($one_point_five); }, 771 { 772 entersub => 0, 773 ceil => 1, 774 }); 775 776test_opcount(0, "builtin::floor is replaced with direct opcode", 777 sub { builtin::floor($one_point_five); }, 778 { 779 entersub => 0, 780 floor => 1, 781 }); 782 783test_opcount(0, "builtin::is_tainted is replaced with direct opcode", 784 sub { builtin::is_tainted($0); }, 785 { 786 entersub => 0, 787 is_tainted => 1, 788 }); 789 790# sassign + padsv combinations are replaced by padsv_store 791test_opcount(0, "sassign + padsv replaced by padsv_store", 792 sub { my $y; my $z = $y = 3; }, 793 { 794 padsv => 1, 795 padsv_store => 2, 796 }); 797 798# OPpTARGET_MY optimizations on undef 799test_opcount(0, "undef + padsv (undef my \$x) is reduced to undef", 800 sub { undef my $x }, 801 { 802 undef => 1, 803 padsv => 0, 804 padsv_store => 0, 805 sassign => 0, 806 }); 807test_opcount(0, "undef + padsv + sassign (my \$x = undef) is reduced to undef", 808 sub { my $x = undef }, 809 { 810 undef => 1, 811 padsv => 0, 812 padsv_store => 0, 813 sassign => 0, 814 }); 815test_opcount(0, "undef + padsv (undef \$x) is reduced to undef", 816 sub { my $x; undef $x }, 817 { 818 undef => 1, 819 padsv => 1, 820 padsv_store => 0, 821 sassign => 0, 822 }); 823test_opcount(0, "undef + padsv + sassign (\$x = undef) is reduced to undef", 824 sub { my $x; $x = undef }, 825 { 826 undef => 1, 827 padsv => 1, 828 padsv_store => 0, 829 sassign => 0, 830 }); 831# Additional test cases requested by demerphq 832test_opcount(0, 'my $y= 1; my @x= ($y= undef);', 833 sub { my $y= 1; my @x= ($y= undef); }, 834 { 835 undef => 1, 836 aassign => 1, 837 padav => 1, 838 padsv => 0, 839 padsv_store => 1, 840 sassign => 0, 841 }); 842 843test_opcount(0, 'my $x= 1; sub f{} f($x=undef);', 844 sub { my $x= 1; sub f{} f($x=undef); }, 845 { 846 undef => 1, 847 gv => 1, 848 padsv => 0, 849 padsv_store => 1, 850 sassign => 0, 851 }); 852 853test_opcount(0, 'my ($x,$p)=(1,2); sub g{} g(($x=undef),$p);', 854 sub { my ($x,$p)=(1,2); sub g{} g(($x=undef),$p); }, 855 { 856 undef => 1, 857 aassign => 1, 858 gv => 1, 859 padrange => 1, 860 padsv => 3, 861 padsv_store => 0, 862 sassign => 0, 863 }); 864 865test_opcount(0, 'my $h= {}; my @k= keys %{($h=undef)||{}};', 866 sub { my $h= {}; my @k= keys %{($h=undef)||{}}; }, 867 { 868 undef => 1, 869 aassign => 1, 870 emptyavhv => 2, 871 padav => 1, 872 padsv => 0, 873 padsv_store => 0, 874 sassign => 0, 875 }); 876 877test_opcount(0, 'my $y= 1; my @x= \($y= undef);', 878 sub { my $y= 1; my @x= \($y= undef); }, 879 { 880 undef => 1, 881 aassign => 1, 882 padav => 1, 883 padsv => 0, 884 padsv_store => 1, 885 sassign => 0, 886 srefgen => 1, 887 }); 888 889# aelemfast_lex + sassign are replaced by a combined OP 890test_opcount(0, "simple aelemfast_lex + sassign replacement", 891 sub { my @x; $x[0] = "foo"; 1 }, 892 { 893 aelemfast_lex => 0, 894 aelemfastlex_store => 1, 895 padav => 1, 896 sassign => 0, 897 }); 898 899# aelemfast_lex + sassign are not replaced by a combined OP 900# when key <0 (not handled, to keep the pp_ function simple 901test_opcount(0, "aelemfast_lex + sassign replacement with neg key", 902 sub { my @x = (1,2); $x[-1] = 7; 1 }, 903 { 904 aelemfast_lex => 0, 905 aelemfastlex_store => 1, 906 padav => 1, 907 sassign => 0, 908 }); 909 910# aelemfast_lex + sassign optimization does not disrupt multideref 911test_opcount(0, "no aelemfast_lex + sassign replacement with multideref", 912 sub { my @x = ([1,2]); $x[0][1] = 1; }, 913 { 914 aelemfast_lex => 0, 915 aelemfastlex_store => 0, 916 multideref => 1, 917 padav => 1, 918 sassign => 1, 919 }); 920 921# emptyavhv optimizations 922 923test_opcount(0, "Empty anonlist", 924 sub { [] }, 925 { 926 anonlist => 0, 927 emptyavhv => 1, 928 sassign => 0, 929 }); 930test_opcount(0, "Empty anonlist with global assignment", 931 sub { our $x; $x = [] }, 932 { 933 anonlist => 0, 934 emptyavhv => 1, 935 gvsv => 1, 936 pushmark => 0, 937 sassign => 1, 938 }); 939test_opcount(0, "Empty anonlist and lexical assignment", 940 sub { my $x; $x = [] }, 941 { 942 anonlist => 0, 943 emptyavhv => 1, 944 padsv => 1, 945 pushmark => 0, 946 sassign => 0, 947 }); 948test_opcount(0, "Empty anonlist and direct lexical assignment", 949 sub { my $x = [] }, 950 { 951 anonlist => 0, 952 emptyavhv => 1, 953 padsv => 0, 954 pushmark => 0, 955 sassign => 0, 956 }); 957test_opcount(0, "Empty anonlist ref and direct lexical assignment", 958 sub { my $x = \[] }, 959 { 960 anonlist => 0, 961 emptyavhv => 1, 962 padsv => 0, 963 padsv_store => 1, 964 pushmark => 0, 965 sassign => 0, 966 srefgen => 1, 967 }); 968test_opcount(0, "Empty anonhash", 969 sub { {} }, 970 { 971 anonhash => 0, 972 emptyavhv => 1, 973 sassign => 0, 974 }); 975test_opcount(0, "Empty anonhash with global assignment", 976 sub { our $x; $x = {} }, 977 { 978 anonhash => 0, 979 emptyavhv => 1, 980 gvsv => 1, 981 pushmark => 0, 982 sassign => 1, 983 }); 984test_opcount(0, "Empty anonhash and lexical assignment", 985 sub { my $x; $x = {} }, 986 { 987 anonhash => 0, 988 emptyavhv => 1, 989 padsv => 1, 990 pushmark => 0, 991 sassign => 0, 992 }); 993test_opcount(0, "Empty anonhash and direct lexical assignment", 994 sub { my $x = {} }, 995 { 996 anonhash => 0, 997 emptyavhv => 1, 998 padsv => 0, 999 pushmark => 0, 1000 sassign => 0, 1001 }); 1002test_opcount(0, "Empty anonhash ref and direct lexical assignment", 1003 sub { my $x = \{} }, 1004 { 1005 anonhash => 0, 1006 emptyavhv => 1, 1007 padsv => 0, 1008 padsv_store => 1, 1009 pushmark => 0, 1010 sassign => 0, 1011 srefgen => 1, 1012 }); 1013 1014done_testing(); 1015