This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix index(...) == -1 type optimisations
[perl5.git] / t / perf / opcount.t
CommitLineData
560a5958
DM
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
fedf30e1
DM
20use warnings;
21use strict;
22
400ffcff 23plan 2309;
560a5958
DM
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
fedf30e1 62 my @exp;
560a5958 63 for (sort keys %$expected_counts) {
fedf30e1
DM
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;
560a5958
DM
72 }
73 }
74}
75
76# aelem => aelemfast: a basic test that this test file works
77
78test_opcount(0, "basic aelemfast",
fedf30e1 79 sub { our @a; $a[0] = 1 },
560a5958
DM
80 {
81 aelem => 0,
82 aelemfast => 1,
83 'ex-aelem' => 1,
84 }
85 );
9e7973fa
DM
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
fedf30e1 110 no warnings 'void';
9e7973fa
DM
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}
fedf30e1
DM
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 );
2e6807b5
AC
263
264test_opcount(0, 'barewords can be constant-folded',
265 sub { no strict 'subs'; FOO . BAR },
266 {
267 concat => 0,
268 });
cf942956
DM
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}
45c198c1
DM
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}
692044df
DM
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}
7e8d786b 353
400ffcff 354# index(...) == -1 and variants optimise away the EQ/NE/etc and CONST
7e8d786b
DM
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) {
400ffcff 364 for my $index ('index($x,$y)', 'rindex($x,$y)') {
25f3319b
DM
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
400ffcff 382 ) {
25f3319b
DM
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 });
7e8d786b
DM
399 }
400 }
401 }
402}