Commit | Line | Data |
---|---|---|
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 FC |
5 | |
6 | BEGIN { | |
7 | chdir 't'; | |
8 | require './test.pl'; | |
9 | skip_all_if_miniperl("No B under miniperl"); | |
10 | @INC = '../lib'; | |
11 | } | |
12 | ||
808ce557 | 13 | plan 54; |
987c9691 | 14 | |
412989c2 | 15 | use v5.10; # state |
a5f48505 DM |
16 | use B qw(svref_2object |
17 | OPpASSIGN_COMMON_SCALAR | |
18 | OPpASSIGN_COMMON_RC1 | |
19 | OPpASSIGN_COMMON_AGG | |
20 | ); | |
2251d43b FC |
21 | |
22 | ||
a5f48505 DM |
23 | # Test that OP_AASSIGN gets the appropriate |
24 | # OPpASSIGN_COMMON* flags set. | |
25 | # | |
26 | # Too few flags set is likely to cause code to misbehave; | |
27 | # too many flags set unnecessarily slows things down. | |
28 | # See also the tests in t/op/aassign.t | |
29 | ||
30 | for my $test ( | |
31 | # Each anon array contains: | |
32 | # [ | |
33 | # expected flags: | |
34 | # a 3 char string, each char showing whether we expect a | |
35 | # particular flag to be set: | |
36 | # '-' indicates any char not set, while | |
37 | # 'S': char 0: OPpASSIGN_COMMON_SCALAR, | |
38 | # 'R': char 1: OPpASSIGN_COMMON_RC1, | |
39 | # 'A' char 2: OPpASSIGN_COMMON_AGG, | |
40 | # code to eval, | |
41 | # description, | |
42 | # ] | |
43 | ||
44 | [ "---", '() = (1, $x, my $y, @z, f($p))', 'no LHS' ], | |
45 | [ "---", '(undef, $x, my $y, @z, ($a ? $b : $c)) = ()', 'no RHS' ], | |
46 | [ "---", '(undef, $x, my $y, @z, ($a ? $b : $c)) = (1,2)', 'safe RHS' ], | |
47 | [ "---", 'my @a = (1,2)', 'safe RHS: my array' ], | |
48 | [ "---", 'my %h = (1,2)', 'safe RHS: my hash' ], | |
49 | [ "---", 'my ($a,$b,$c,$d) = 1..6; ($a,$b) = ($c,$d);', 'non-common lex' ], | |
50 | [ "---", '($x,$y) = (1,2)', 'pkg var LHS only' ], | |
51 | [ "---", 'my $p; my ($x,$y) = ($p, $p)', 'my; dup lex var on RHS' ], | |
52 | [ "---", 'my $p; my ($x,$y); ($x,$y) = ($p, $p)', 'dup lex var on RHS' ], | |
90ce4d05 DM |
53 | [ "---", 'my ($self) = @_', 'LHS lex scalar only' ], |
54 | [ "--A", 'my ($self, @rest) = @_', 'LHS lex mixed' ], | |
a5f48505 DM |
55 | [ "-R-", 'my ($x,$y) = ($p, $q)', 'pkg var RHS only' ], |
56 | [ "S--", '($x,$y) = ($p, $q)', 'pkg scalar both sides' ], | |
57 | [ "--A", 'my (@a, @b); @a = @b', 'lex ary both sides' ], | |
58 | [ "-R-", 'my ($x,$y,$z,@a); ($x,$y,$z) = @a ', 'lex vars to lex ary' ], | |
59 | [ "--A", '@a = @b', 'pkg ary both sides' ], | |
60 | [ "--A", 'my (%a,%b); %a = %b', 'lex hash both sides' ], | |
61 | [ "--A", '%a = %b', 'pkg hash both sides' ], | |
62 | [ "--A", 'my $x; @a = ($a[0], $a[$x])', 'common ary' ], | |
63 | [ "--A", 'my ($x,@a); @a = ($a[0], $a[$x])', 'common lex ary' ], | |
64 | [ "S-A", 'my $x; ($a[$x], $a[0]) = ($a[0], $a[$x])', 'common ary elems' ], | |
65 | [ "S-A", 'my ($x,@a); ($a[$x], $a[0]) = ($a[0], $a[$x])', | |
66 | 'common lex ary elems' ], | |
67 | [ "--A", 'my $x; my @a = @$x', 'lex ary may have stuff' ], | |
68 | [ "-RA", 'my $x; my ($b, @a) = @$x', 'lex ary may have stuff' ], | |
69 | [ "--A", 'my $x; my %a = @$x', 'lex hash may have stuff' ], | |
70 | [ "-RA", 'my $x; my ($b, %a) = @$x', 'lex hash may have stuff' ], | |
71 | [ "--A", 'my (@a,@b); @a = ($b[0])', 'lex ary and elem' ], | |
72 | [ "S-A", 'my @a; ($a[1],$a[0]) = @a', 'lex ary and elem' ], | |
73 | [ "--A", 'my @x; @y = $x[0]', 'pkg ary from lex elem' ], | |
808ce557 DM |
74 | [ "---", '(undef,$x) = f()', 'single scalar on LHS' ], |
75 | [ "---", '($x,$y) = ($x)', 'single scalar on RHS, no AGG' ], | |
76 | [ "--A", '($x,@b) = ($x)', 'single scalar on RHS' ], | |
a5f48505 DM |
77 | ) { |
78 | my ($exp, $code, $desc) = @$test; | |
79 | my $sub = eval "sub { $code }" | |
80 | or die | |
81 | "aassign eval('$code') failed: this test needs to be rewritten:\n" | |
82 | . $@; | |
83 | ||
84 | my $last_expr = svref_2object($sub)->ROOT->first->last; | |
2251d43b FC |
85 | if ($last_expr->name ne 'aassign') { |
86 | die "Expected aassign but found ", $last_expr->name, | |
87 | "; this test needs to be rewritten" | |
88 | } | |
a5f48505 DM |
89 | my $got = |
90 | (($last_expr->private & OPpASSIGN_COMMON_SCALAR) ? 'S' : '-') | |
91 | . (($last_expr->private & OPpASSIGN_COMMON_RC1) ? 'R' : '-') | |
92 | . (($last_expr->private & OPpASSIGN_COMMON_AGG) ? 'A' : '-'); | |
93 | is $got, $exp, "OPpASSIGN_COMMON: $desc: '$code'"; | |
2251d43b FC |
94 | } |
95 | ||
96 | ||
97 | # join -> stringify/const | |
987c9691 FC |
98 | |
99 | for (['CONSTANT', sub { join "foo", $_ }], | |
100 | ['$var' , sub { join $_ , $_ }], | |
101 | ['$myvar' , sub { my $var; join $var, $_ }], | |
102 | ) { | |
103 | my($sep,$sub) = @$_; | |
104 | my $last_expr = svref_2object($sub)->ROOT->first->last; | |
105 | is $last_expr->name, 'stringify', | |
106 | "join($sep, \$scalar) optimised to stringify"; | |
107 | } | |
108 | ||
109 | for (['CONSTANT', sub { join "foo", "bar" }, 0, "bar" ], | |
110 | ['CONSTANT', sub { join "foo", "bar", 3 }, 1, "barfoo3"], | |
111 | ['$var' , sub { join $_ , "bar" }, 0, "bar" ], | |
112 | ['$myvar' , sub { my $var; join $var, "bar" }, 0, "bar" ], | |
113 | ) { | |
114 | my($sep,$sub,$is_list,$expect) = @$_; | |
115 | my $last_expr = svref_2object($sub)->ROOT->first->last; | |
116 | my $tn = "join($sep, " . ($is_list?'list of constants':'const') . ")"; | |
117 | is $last_expr->name, 'const', "$tn optimised to constant"; | |
118 | is $sub->(), $expect, "$tn folded correctly"; | |
119 | } | |
45742705 FC |
120 | |
121 | ||
6aa68307 FC |
122 | # list+pushmark in list context elided out of the execution chain |
123 | is svref_2object(sub { () = ($_, ($_, $_)) }) | |
124 | ->START # nextstate | |
125 | ->next # pushmark | |
126 | ->next # gvsv | |
127 | ->next # should be gvsv, not pushmark | |
128 | ->name, 'gvsv', | |
129 | "list+pushmark in list context where list's elder sibling is a null"; | |
130 | ||
131 | ||
f5b5c2a3 FC |
132 | # nextstate multiple times becoming one nextstate |
133 | ||
134 | is svref_2object(sub { 0;0;0;0;0;0;time })->START->next->name, 'time', | |
135 | 'multiple nextstates become one'; | |
136 | ||
137 | ||
412989c2 FC |
138 | # pad[ahs]v state declarations in void context |
139 | ||
140 | is svref_2object(sub{state($foo,@fit,%far);state $bar;state($a,$b); time}) | |
141 | ->START->next->name, 'time', | |
142 | 'pad[ahs]v state declarations in void context'; | |
143 | ||
144 | ||
d964400d FC |
145 | # pushmark-padsv-padav-padhv in list context --> padrange |
146 | ||
147 | { | |
148 | my @ops; | |
149 | my $sub = sub { \my( $f, @f, %f ) }; | |
150 | my $op = svref_2object($sub)->START; | |
151 | push(@ops, $op->name), $op = $op->next while $$op; | |
152 | is "@ops", "nextstate padrange refgen leavesub", 'multi-type padrange' | |
153 | } | |
154 | ||
155 | ||
0298c760 FC |
156 | # rv2[ahs]v in void context |
157 | ||
158 | is svref_2object(sub { our($foo,@fit,%far); our $bar; our($a,$b); time }) | |
159 | ->START->next->name, 'time', | |
160 | 'rv2[ahs]v in void context'; | |
161 | ||
162 | ||
45742705 FC |
163 | # split to array |
164 | ||
165 | for(['@pkgary' , '@_' ], | |
166 | ['@lexary' , 'my @a; @a'], | |
167 | ['my(@array)' , 'my(@a)' ], | |
168 | ['local(@array)', 'local(@_)'], | |
169 | ['@{...}' , '@{\@_}' ], | |
170 | ){ | |
171 | my($tn,$code) = @$_; | |
172 | my $sub = eval "sub { $code = split }"; | |
173 | my $split = svref_2object($sub)->ROOT->first->last; | |
174 | is $split->name, 'split', "$tn = split swallows up the assignment"; | |
175 | } | |
73f4c4fe FC |
176 | |
177 | ||
178 | # stringify with join kid --> join | |
179 | is svref_2object(sub { "@_" })->ROOT->first->last->name, 'join', | |
180 | 'qq"@_" optimised from stringify(join(...)) to join(...)'; |