Commit | Line | Data |
---|---|---|
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 | ||
13 | BEGIN { | |
14 | chdir 't'; | |
15 | require './test.pl'; | |
16 | skip_all_if_miniperl("No B under miniperl"); | |
17 | @INC = '../lib'; | |
18 | } | |
19 | ||
fedf30e1 DM |
20 | use warnings; |
21 | use strict; | |
22 | ||
23 | plan 2249; | |
560a5958 DM |
24 | |
25 | use 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 | ||
78 | test_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 | ||
198 | test_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 | ||
210 | test_opcount(0, 'multideref const index', | |
211 | sub { $_->{1}{1.1} }, | |
212 | { | |
213 | helem => 0, | |
214 | multideref => 1, | |
215 | }, | |
216 | ); | |
217 | ||
218 | use constant my_undef => undef; | |
219 | test_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 | ||
229 | test_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 | ||
255 | test_opcount(0, 'multideref exists', | |
256 | sub { exists $_[0] }, | |
257 | { | |
258 | aelem => 0, | |
259 | aelemfast => 0, | |
260 | multideref => 1, | |
261 | }, | |
262 | ); |