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
1 #!./perl
2
3 # Use B to test that optimisations are not inadvertently removed,
4 # by examining particular nodes in the optree.
5
6 use warnings;
7 use strict;
8
9 BEGIN {
10     chdir 't';
11     require './test.pl';
12     skip_all_if_miniperl("No B under miniperl");
13     @INC = '../lib';
14 }
15
16 plan 711;
17
18 use v5.10; # state
19 use B qw(svref_2object
20          OPpASSIGN_COMMON_SCALAR
21          OPpASSIGN_COMMON_RC1
22          OPpASSIGN_COMMON_AGG
23          OPpTRUEBOOL
24          OPpMAYBE_TRUEBOOL
25       );
26
27
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
35 for 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' ],
58     [ "---", 'my ($self) = @_', 'LHS lex scalar only' ],
59     [ "--A", 'my ($self, @rest) = @_', 'LHS lex mixed' ],
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' ],
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' ],
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'  ],
87 ) {
88
89     my ($exp, $code, $desc) = @$test;
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     }
100
101     my $last_expr = svref_2object($sub)->ROOT->first->last;
102     if ($last_expr->name ne 'aassign') {
103         die "Expected aassign but found ", $last_expr->name,
104             "; this test needs to be rewritten" 
105     }
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'";
111 }    
112
113
114 # join -> stringify/const
115
116 for (['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
126 for (['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 }
137
138
139 # list+pushmark in list context elided out of the execution chain
140 is 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
149 # nextstate multiple times becoming one nextstate
150
151 is svref_2object(sub { 0;0;0;0;0;0;time })->START->next->name, 'time',
152   'multiple nextstates become one';
153
154
155 # pad[ahs]v state declarations in void context 
156
157 is 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
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
173 # rv2[ahs]v in void context
174
175 is 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
180 # split to array
181
182 for(['@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 }
193
194
195 # stringify with join kid --> join
196 is svref_2object(sub { "@_" })->ROOT->first->last->name, 'join',
197   'qq"@_" optimised from stringify(join(...)) to join(...)';
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
215 for 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
230         #  2nd column: path though the op subtree to the flagged op:
231         #                0 is first child, 1 is second child etc.
232         #                Will have @$post_op_path from above appended.
233         #  3rd column: code to execute: %s holds the code for the op
234         #
235         # [V S U]  PATH        CODE
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'                              ],
247         [ [1,9,1], [0,0,0],   'if (!%s) {$x}'                    ],
248         [ [1,9,1], [0,0,0],   'if (!%s) {$x} else {$y}'          ],
249         [ [1,9,1], [0,0,0],   'unless (!%s) {$x}'                ],
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'                         ],
262         [ [1,1,1], [0,0,0],   '!(%s || $x)'                      ],
263         [ [1,0,2], [0,1,0,0], '$y && (%s || $x)'                 ],
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}'           ],
267
268         # INNER OR RHS
269
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}'           ],
276
277         # INNER DOR LHS
278
279         [ [1,0,2], [0,0],     '%s // $x'                         ],
280         [ [1,1,1], [0,0,0],   '!(%s // $x)'                      ],
281         [ [1,0,2], [0,1,0,0], '$y && (%s // $x)'                 ],
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}'     ],
286         [ [1,9,2], [0,0,0,0], 'unless (%s // $x) {$x}'           ],
287
288         # INNER DOR RHS
289
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}'           ],
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
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}'           ],
314
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
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