This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add xor, grep, flip, flop to boolean cxt detection
[perl5.git] / t / perf / optree.t
CommitLineData
987c9691
FC
1#!./perl
2
009e0f19
DM
3# Use B to test that optimisations are not inadvertently removed,
4# by examining particular nodes in the optree.
987c9691 5
7bb1f299
DM
6use warnings;
7use strict;
8
987c9691
FC
9BEGIN {
10 chdir 't';
11 require './test.pl';
12 skip_all_if_miniperl("No B under miniperl");
13 @INC = '../lib';
14}
15
9d692a7f 16plan 711;
987c9691 17
412989c2 18use v5.10; # state
a5f48505
DM
19use B qw(svref_2object
20 OPpASSIGN_COMMON_SCALAR
21 OPpASSIGN_COMMON_RC1
22 OPpASSIGN_COMMON_AGG
7adc03cc
DM
23 OPpTRUEBOOL
24 OPpMAYBE_TRUEBOOL
a5f48505 25 );
2251d43b
FC
26
27
a5f48505
DM
28# Test that OP_AASSIGN gets the appropriate
29# OPpASSIGN_COMMON* flags set.
30#
31# Too few flags set is likely to cause code to misbehave;
32# too many flags set unnecessarily slows things down.
33# See also the tests in t/op/aassign.t
34
35for my $test (
36 # Each anon array contains:
37 # [
38 # expected flags:
39 # a 3 char string, each char showing whether we expect a
40 # particular flag to be set:
41 # '-' indicates any char not set, while
42 # 'S': char 0: OPpASSIGN_COMMON_SCALAR,
43 # 'R': char 1: OPpASSIGN_COMMON_RC1,
44 # 'A' char 2: OPpASSIGN_COMMON_AGG,
45 # code to eval,
46 # description,
47 # ]
48
49 [ "---", '() = (1, $x, my $y, @z, f($p))', 'no LHS' ],
50 [ "---", '(undef, $x, my $y, @z, ($a ? $b : $c)) = ()', 'no RHS' ],
51 [ "---", '(undef, $x, my $y, @z, ($a ? $b : $c)) = (1,2)', 'safe RHS' ],
52 [ "---", 'my @a = (1,2)', 'safe RHS: my array' ],
53 [ "---", 'my %h = (1,2)', 'safe RHS: my hash' ],
54 [ "---", 'my ($a,$b,$c,$d) = 1..6; ($a,$b) = ($c,$d);', 'non-common lex' ],
55 [ "---", '($x,$y) = (1,2)', 'pkg var LHS only' ],
56 [ "---", 'my $p; my ($x,$y) = ($p, $p)', 'my; dup lex var on RHS' ],
57 [ "---", 'my $p; my ($x,$y); ($x,$y) = ($p, $p)', 'dup lex var on RHS' ],
90ce4d05
DM
58 [ "---", 'my ($self) = @_', 'LHS lex scalar only' ],
59 [ "--A", 'my ($self, @rest) = @_', 'LHS lex mixed' ],
a5f48505
DM
60 [ "-R-", 'my ($x,$y) = ($p, $q)', 'pkg var RHS only' ],
61 [ "S--", '($x,$y) = ($p, $q)', 'pkg scalar both sides' ],
62 [ "--A", 'my (@a, @b); @a = @b', 'lex ary both sides' ],
63 [ "-R-", 'my ($x,$y,$z,@a); ($x,$y,$z) = @a ', 'lex vars to lex ary' ],
64 [ "--A", '@a = @b', 'pkg ary both sides' ],
65 [ "--A", 'my (%a,%b); %a = %b', 'lex hash both sides' ],
66 [ "--A", '%a = %b', 'pkg hash both sides' ],
67 [ "--A", 'my $x; @a = ($a[0], $a[$x])', 'common ary' ],
68 [ "--A", 'my ($x,@a); @a = ($a[0], $a[$x])', 'common lex ary' ],
69 [ "S-A", 'my $x; ($a[$x], $a[0]) = ($a[0], $a[$x])', 'common ary elems' ],
70 [ "S-A", 'my ($x,@a); ($a[$x], $a[0]) = ($a[0], $a[$x])',
71 'common lex ary elems' ],
72 [ "--A", 'my $x; my @a = @$x', 'lex ary may have stuff' ],
73 [ "-RA", 'my $x; my ($b, @a) = @$x', 'lex ary may have stuff' ],
74 [ "--A", 'my $x; my %a = @$x', 'lex hash may have stuff' ],
75 [ "-RA", 'my $x; my ($b, %a) = @$x', 'lex hash may have stuff' ],
76 [ "--A", 'my (@a,@b); @a = ($b[0])', 'lex ary and elem' ],
77 [ "S-A", 'my @a; ($a[1],$a[0]) = @a', 'lex ary and elem' ],
78 [ "--A", 'my @x; @y = $x[0]', 'pkg ary from lex elem' ],
808ce557
DM
79 [ "---", '(undef,$x) = f()', 'single scalar on LHS' ],
80 [ "---", '($x,$y) = ($x)', 'single scalar on RHS, no AGG' ],
81 [ "--A", '($x,@b) = ($x)', 'single scalar on RHS' ],
47a8f19b
DM
82 [ "--A", 'my @a; @a = (@a = split())', 'split a/a' ],
83 [ "--A", 'my (@a,@b); @a = (@b = split())', 'split a/b' ],
84 [ "---", 'my @a; @a = (split(), 1)', '(split(),1)' ],
85 [ "---", '@a = (split(//, @a), 1)', 'split(@a)' ],
86 [ "--A", 'my @a; my $ar = @a; @a = (@$ar = split())', 'a/ar split' ],
a5f48505 87) {
7bb1f299 88
a5f48505 89 my ($exp, $code, $desc) = @$test;
7bb1f299
DM
90 my $sub;
91 {
92 # package vars used in code snippets
93 our (@a, %a, @b, %b, $c, $p, $q, $x, $y, @y, @z);
94
95 $sub = eval "sub { $code }"
96 or die
97 "aassign eval('$code') failed: this test needs"
98 . "to be rewritten:\n$@"
99 }
a5f48505
DM
100
101 my $last_expr = svref_2object($sub)->ROOT->first->last;
2251d43b
FC
102 if ($last_expr->name ne 'aassign') {
103 die "Expected aassign but found ", $last_expr->name,
104 "; this test needs to be rewritten"
105 }
a5f48505
DM
106 my $got =
107 (($last_expr->private & OPpASSIGN_COMMON_SCALAR) ? 'S' : '-')
108 . (($last_expr->private & OPpASSIGN_COMMON_RC1) ? 'R' : '-')
109 . (($last_expr->private & OPpASSIGN_COMMON_AGG) ? 'A' : '-');
110 is $got, $exp, "OPpASSIGN_COMMON: $desc: '$code'";
2251d43b
FC
111}
112
113
114# join -> stringify/const
987c9691
FC
115
116for (['CONSTANT', sub { join "foo", $_ }],
117 ['$var' , sub { join $_ , $_ }],
118 ['$myvar' , sub { my $var; join $var, $_ }],
119) {
120 my($sep,$sub) = @$_;
121 my $last_expr = svref_2object($sub)->ROOT->first->last;
122 is $last_expr->name, 'stringify',
123 "join($sep, \$scalar) optimised to stringify";
124}
125
126for (['CONSTANT', sub { join "foo", "bar" }, 0, "bar" ],
127 ['CONSTANT', sub { join "foo", "bar", 3 }, 1, "barfoo3"],
128 ['$var' , sub { join $_ , "bar" }, 0, "bar" ],
129 ['$myvar' , sub { my $var; join $var, "bar" }, 0, "bar" ],
130) {
131 my($sep,$sub,$is_list,$expect) = @$_;
132 my $last_expr = svref_2object($sub)->ROOT->first->last;
133 my $tn = "join($sep, " . ($is_list?'list of constants':'const') . ")";
134 is $last_expr->name, 'const', "$tn optimised to constant";
135 is $sub->(), $expect, "$tn folded correctly";
136}
45742705
FC
137
138
6aa68307
FC
139# list+pushmark in list context elided out of the execution chain
140is svref_2object(sub { () = ($_, ($_, $_)) })
141 ->START # nextstate
142 ->next # pushmark
143 ->next # gvsv
144 ->next # should be gvsv, not pushmark
145 ->name, 'gvsv',
146 "list+pushmark in list context where list's elder sibling is a null";
147
148
f5b5c2a3
FC
149# nextstate multiple times becoming one nextstate
150
151is svref_2object(sub { 0;0;0;0;0;0;time })->START->next->name, 'time',
152 'multiple nextstates become one';
153
154
412989c2
FC
155# pad[ahs]v state declarations in void context
156
157is svref_2object(sub{state($foo,@fit,%far);state $bar;state($a,$b); time})
158 ->START->next->name, 'time',
159 'pad[ahs]v state declarations in void context';
160
161
d964400d
FC
162# pushmark-padsv-padav-padhv in list context --> padrange
163
164{
165 my @ops;
166 my $sub = sub { \my( $f, @f, %f ) };
167 my $op = svref_2object($sub)->START;
168 push(@ops, $op->name), $op = $op->next while $$op;
169 is "@ops", "nextstate padrange refgen leavesub", 'multi-type padrange'
170}
171
172
0298c760
FC
173# rv2[ahs]v in void context
174
175is svref_2object(sub { our($foo,@fit,%far); our $bar; our($a,$b); time })
176 ->START->next->name, 'time',
177 'rv2[ahs]v in void context';
178
179
45742705
FC
180# split to array
181
182for(['@pkgary' , '@_' ],
183 ['@lexary' , 'my @a; @a'],
184 ['my(@array)' , 'my(@a)' ],
185 ['local(@array)', 'local(@_)'],
186 ['@{...}' , '@{\@_}' ],
187){
188 my($tn,$code) = @$_;
189 my $sub = eval "sub { $code = split }";
190 my $split = svref_2object($sub)->ROOT->first->last;
191 is $split->name, 'split', "$tn = split swallows up the assignment";
192}
73f4c4fe
FC
193
194
195# stringify with join kid --> join
196is svref_2object(sub { "@_" })->ROOT->first->last->name, 'join',
197 'qq"@_" optimised from stringify(join(...)) to join(...)';
7adc03cc
DM
198
199
200# Check that certain ops, when in boolean context, have the
201# right private "is boolean" or "maybe boolean" flags set.
202#
203# A maybe flag is set when the context at the end of a chain of and/or/dor
204# ops isn't known till runtime, e.g.
205# sub f { ....; ((%h || $x) || $y)) }
206# If f() is called in void context, then %h can return a boolean value;
207# if in scalar context, %h must return a key count.
208#
209# With (op && other), its ok to treat op as in bool cxt even when the &&
210# is in scalar cxt, as long as whatever op returns as a false boolean value
211# matches what it returns as a false scalar value (IV(0) in the case of
212# rv2hv etc). This is because in (A && B), A is returned only when A is
213# false.
214
215for my $ops (
216 # op code op path flag maybe flag
217 [ 'rv2hv', '%pkg', [], OPpTRUEBOOL, OPpMAYBE_TRUEBOOL ],
218 [ 'rv2hv', 'scalar(%pkg)', [0], OPpTRUEBOOL, OPpMAYBE_TRUEBOOL ],
219 [ 'padhv', '%lex', [], OPpTRUEBOOL, OPpMAYBE_TRUEBOOL ],
220 [ 'padhv', 'scalar(%lex)', [0], OPpTRUEBOOL, OPpMAYBE_TRUEBOOL ],
221) {
222 my ($op_name, $op_code, $post_op_path, $bool_flag, $maybe_flag) = @$ops;
223
224 for my $test (
225 # 1st column: what to expect for each $context (void, scalar, unknown),
226 # 0: expect no flag
227 # 1: expect bool flag
228 # 2: expect maybe bool flag
229 # 9: skip test
b0e8c18f
DM
230 # 2nd column: path though the op subtree to the flagged op:
231 # 0 is first child, 1 is second child etc.
7adc03cc 232 # Will have @$post_op_path from above appended.
b0e8c18f 233 # 3rd column: code to execute: %s holds the code for the op
7adc03cc 234 #
b0e8c18f 235 # [V S U] PATH CODE
7adc03cc
DM
236
237 # INNER PLAIN
238
239 [ [0,0,0], [], '%s' ],
240 [ [1,9,1], [0,0], 'if (%s) {$x}' ],
241 [ [1,9,1], [0,0], 'if (%s) {$x} else {$y}' ],
242 [ [1,9,2], [0,0], 'unless (%s) {$x}' ],
243
244 # INNER NOT
245
246 [ [1,1,1], [0], '!%s' ],
b0e8c18f 247 [ [1,9,1], [0,0,0], 'if (!%s) {$x}' ],
7adc03cc 248 [ [1,9,1], [0,0,0], 'if (!%s) {$x} else {$y}' ],
b0e8c18f 249 [ [1,9,1], [0,0,0], 'unless (!%s) {$x}' ],
7adc03cc
DM
250
251 # INNER COND
252
253 [ [1,1,1], [0,0,], '%s ? $p : $q' ],
254 [ [1,9,1], [0,0,0,0], 'if (%s ? $p : $q) {$x}' ],
255 [ [1,9,1], [0,0,0,0], 'if (%s ? $p : $q) {$x} else {$y}' ],
256 [ [1,9,1], [0,0,0,0], 'unless (%s ? $p : $q) {$x}' ],
257
258
259 # INNER OR LHS
260
261 [ [1,0,2], [0,0], '%s || $x' ],
b0e8c18f 262 [ [1,1,1], [0,0,0], '!(%s || $x)' ],
7adc03cc 263 [ [1,0,2], [0,1,0,0], '$y && (%s || $x)' ],
b0e8c18f
DM
264 [ [1,9,1], [0,0,0,0], 'if (%s || $x) {$x}' ],
265 [ [1,9,1], [0,0,0,0], 'if (%s || $x) {$x} else {$y}' ],
266 [ [1,9,2], [0,0,0,0], 'unless (%s || $x) {$x}' ],
7adc03cc
DM
267
268 # INNER OR RHS
269
b0e8c18f
DM
270 [ [0,0,0], [0,1], '$x || %s' ],
271 [ [1,1,1], [0,0,1], '!($x || %s)' ],
272 [ [0,0,0], [0,1,0,1], '$y && ($x || %s)' ],
273 [ [1,9,1], [0,0,0,1], 'if ($x || %s) {$x}' ],
274 [ [1,9,1], [0,0,0,1], 'if ($x || %s) {$x} else {$y}' ],
275 [ [1,9,2], [0,0,0,1], 'unless ($x || %s) {$x}' ],
7adc03cc
DM
276
277 # INNER DOR LHS
278
279 [ [1,0,2], [0,0], '%s // $x' ],
b0e8c18f 280 [ [1,1,1], [0,0,0], '!(%s // $x)' ],
7adc03cc 281 [ [1,0,2], [0,1,0,0], '$y && (%s // $x)' ],
b0e8c18f
DM
282 [ [1,9,1], [0,0,0,0], 'if (%s // $x) {$x}' ],
283 [ [1,9,2], [0,0,0,0], 'unless (%s // $x) {$x}' ],
284 [ [1,9,1], [0,0,0,0], 'if (%s // $x) {$x}' ],
285 [ [1,9,1], [0,0,0,0], 'if (%s // $x) {$x} else {$y}' ],
7adc03cc 286 [ [1,9,2], [0,0,0,0], 'unless (%s // $x) {$x}' ],
7adc03cc
DM
287
288 # INNER DOR RHS
289
b0e8c18f
DM
290 [ [0,0,0], [0,1], '$x // %s' ],
291 [ [1,1,1], [0,0,1], '!($x // %s)' ],
292 [ [0,0,0], [0,1,0,1], '$y && ($x // %s)' ],
293 [ [1,9,1], [0,0,0,1], 'if ($x // %s) {$x}' ],
294 [ [1,9,1], [0,0,0,1], 'if ($x // %s) {$x} else {$y}' ],
295 [ [1,9,2], [0,0,0,1], 'unless ($x // %s) {$x}' ],
7adc03cc
DM
296
297 # INNER AND LHS
298
299 [ [1,1,1], [0,0], '%s && $x' ],
300 [ [1,1,1], [0,0,0], '!(%s && $x)' ],
301 [ [1,1,1], [0,1,0,0], '$y || (%s && $x)' ],
302 [ [1,9,1], [0,0,0,0], 'if (%s && $x) {$x}' ],
303 [ [1,9,1], [0,0,0,0], 'if (%s && $x) {$x} else {$y}' ],
304 [ [1,9,1], [0,0,0,0], 'unless (%s && $x) {$x}' ],
305
306 # INNER AND RHS
307
b0e8c18f
DM
308 [ [0,0,0], [0,1], '$x && %s' ],
309 [ [1,1,1], [0,0,1], '!($x && %s)' ],
310 [ [0,0,0], [0,1,0,1], '$y || ($x && %s)' ],
311 [ [1,9,1], [0,0,0,1], 'if ($x && %s) {$x}' ],
312 [ [1,9,1], [0,0,0,1], 'if ($x && %s) {$x} else {$y}' ],
313 [ [1,9,2], [0,0,0,1], 'unless ($x && %s) {$x}' ],
7adc03cc 314
9d692a7f
DM
315 # INNER XOR LHS
316
317 # LHS of XOR is currently too hard to detect as
318 # being in boolean context
319
320 # INNER XOR RHS
321
322 [ [1,1,1], [1], '($x xor %s)' ],
323 [ [1,1,1], [0,1], '!($x xor %s)' ],
324 [ [1,1,1], [0,1,1], '$y || ($x xor %s)' ],
325 [ [1,9,1], [0,0,1], 'if ($x xor %s) {$x}' ],
326 [ [1,9,1], [0,0,1], 'if ($x xor %s) {$x} else {$y}' ],
327 [ [1,9,1], [0,0,1], 'unless ($x xor %s) {$x}' ],
328
329 # GREP
330
331 [ [1,1,1], [0,1,0], 'grep %s,1,2' ],
332 [ [1,1,1], [0,1,0,0], 'grep !%s,1,2' ],
333 [ [1,1,1], [0,1,0,0,1],'grep $y || %s,1,2' ],
334
335 # FLIP
336
337 [ [1,1,1], [0,0,0,0], '%s..$x' ],
338 [ [1,1,1], [0,0,0,0,0], '!%s..$x' ],
339 [ [1,1,1], [0,0,0,0,0,1], '($y || %s)..$x' ],
340
341 # FLOP
342
343 [ [1,1,1], [0,0,0,1], '$x..%s' ],
344 [ [1,1,1], [0,0,0,1,0], '$x..!%s' ],
345 [ [1,1,1], [0,0,0,1,0,1], '$x..($y || %s)' ],
346
7adc03cc
DM
347 ) {
348 my ($expects, $op_path, $code_fmt) = @$test;
349
350 for my $context (0,1,2) {
351 # 0: void
352 # 1: scalar
353 # 2: unknown
354 # 9: skip test (principally if() can't be in scalar context)
355
356 next if $expects->[$context] == 9;
357
358 my $base_code = sprintf $code_fmt, $op_code;
359 my $code = $base_code;
360 my @op_path = @$op_path;
361 push @op_path, @$post_op_path;
362
363 # where to find the expression in the top-level lineseq
364 my $seq_offset = -1;
365
366 if ($context == 0) {
367 $seq_offset -= 2;
368 $code .= "; 1";
369 }
370 elsif ($context == 1) {
371 $code = "\$r = ($code)";
372 unshift @op_path, 0;
373 }
374
375
376 my $sub;
377 {
378 our (%pkg);
379 my (%lex, $p, $q, $r, $x, $y);
380
381 no warnings 'void';
382 $sub = eval "sub { $code }"
383 or die
384 "eval'$code' failed: this test needs to be rewritten;\n"
385 . "Errors were:\n$@";
386 }
387
388 # find the expression subtree in the main lineseq of the sub
389 my $expr = svref_2object($sub)->ROOT->first;
390 my @ops;
391 my $next = $expr->first;
392 while ($$next) {
393 push @ops, $next;
394 $next = $next->sibling;
395 }
396 $expr = $ops[$seq_offset];
397
398 # search through the expr subtree looking for the named op -
399 # this assumes that for all the code examples above, the
400 # op is always in the LH branch
401 while (defined (my $p = shift @op_path)) {
402 $expr = $expr->first;
403 $expr = $expr->sibling while $p--;
404 }
405
406 if (!$expr || $expr->name ne $op_name) {
407 die "Can't find $op_name op in optree for '$code'; "
408 . "this test needs to be rewritten"
409 }
410
411 my $exp = $expects->[$context];
412 $exp = $exp == 0 ? 0
413 : $exp == 1 ? $bool_flag
414 : $maybe_flag;
415
416 my $got = ($expr->private & ($bool_flag | $maybe_flag));
417 my $cxt_name = ('void ', 'scalar ', 'unknown')[$context];
418 is $got, $exp, "boolean: $op_name $cxt_name '$base_code'";
419 }
420 }
421}
422