This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
peephole optimise op_other branch in OP_ARGDEFELEM
[perl5.git] / 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 2251;
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 }