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