Commit | Line | Data |
---|---|---|
0b2df18f FC |
1 | #!perl |
2 | ||
3 | # Test the various op trees that turn sub () { ... } into a constant, and | |
4 | # some variants that don’t. | |
5 | ||
6 | BEGIN { | |
7 | chdir 't'; | |
8 | require './test.pl'; | |
624c42e2 | 9 | set_up_inc('../lib'); |
0b2df18f | 10 | } |
30fc7a28 | 11 | plan 148; |
0b2df18f | 12 | |
bbd7756c FC |
13 | # @tests is an array of hash refs, each of which can have various keys: |
14 | # | |
15 | # nickname - name of the sub to use in test names | |
16 | # generator - a sub returning a code ref to test | |
a41f70ad | 17 | # finally - sub to run after the tests |
bbd7756c FC |
18 | # |
19 | # Each of the following gives expected test results. If the key is | |
20 | # omitted, the test is skipped: | |
21 | # | |
22 | # retval - the returned code ref’s return value | |
23 | # same_retval - whether the same scalar is returned each time | |
24 | # inlinable - whether the sub is inlinable | |
25 | # deprecated - whether the sub returning a code ref will emit a depreca- | |
26 | # tion warning when called | |
27 | # method - whether the sub has the :method attribute | |
30fc7a28 JK |
28 | # exception - sub now throws an exception (previously threw |
29 | # deprecation warning) | |
30 | ||
31 | my $exception_134138 = 'Constants from lexical variables potentially modified ' | |
32 | . 'elsewhere are no longer permitted'; | |
0b2df18f | 33 | |
bbd7756c FC |
34 | # [perl #63540] Don’t treat sub { if(){.....}; "constant" } as a constant |
35 | sub blonk { ++$blonk_was_called } | |
36 | push @tests, { | |
37 | nickname => 'sub with null+kids (if-block), then constant', | |
38 | generator => sub { | |
39 | # This used to turn into a constant with the value of $x | |
40 | my $x = 7; | |
41 | sub() { if($x){ () = "tralala"; blonk() }; 0 } | |
42 | }, | |
43 | retval => 0, | |
44 | same_retval => 0, | |
45 | inlinable => 0, | |
46 | deprecated => 0, | |
47 | method => 0, | |
48 | finally => sub { ok($blonk_was_called, 'RT #63540'); }, | |
49 | }; | |
0b2df18f FC |
50 | |
51 | # [perl #79908] | |
bbd7756c FC |
52 | push @tests, { |
53 | nickname => 'sub with simple lexical modified elsewhere', | |
54 | generator => sub { my $x = 5; my $ret = sub(){$x}; $x = 7; $ret }, | |
30fc7a28 | 55 | exception => $exception_134138, |
bbd7756c FC |
56 | }; |
57 | ||
58 | push @tests, { | |
cb12c7ef FC |
59 | nickname => 'sub with simple lexical unmodified elsewhere', |
60 | generator => sub { my $x = 5; sub(){$x} }, | |
61 | retval => 5, | |
62 | same_retval => 0, | |
63 | inlinable => 1, | |
64 | deprecated => 0, | |
65 | method => 0, | |
66 | }; | |
67 | ||
68 | push @tests, { | |
69 | nickname => 'return $variable modified elsewhere', | |
70 | generator => sub { my $x=5; my $ret = sub(){return $x}; $x = 7; $ret }, | |
71 | retval => 7, | |
72 | same_retval => 0, | |
73 | inlinable => 0, | |
74 | deprecated => 0, | |
75 | method => 0, | |
76 | }; | |
77 | ||
78 | push @tests, { | |
79 | nickname => 'return $variable unmodified elsewhere', | |
80 | generator => sub { my $x = 5; sub(){return $x} }, | |
81 | retval => 5, | |
82 | same_retval => 0, | |
83 | inlinable => 0, | |
84 | deprecated => 0, | |
85 | method => 0, | |
86 | }; | |
87 | ||
88 | push @tests, { | |
7f08c641 FC |
89 | nickname => 'sub () { 0; $x } with $x modified elsewhere', |
90 | generator => sub { my $x = 5; my $ret = sub(){0;$x}; $x = 8; $ret }, | |
91 | retval => 8, | |
92 | same_retval => 0, | |
93 | inlinable => 0, | |
94 | deprecated => 0, | |
95 | method => 0, | |
96 | }; | |
97 | ||
98 | push @tests, { | |
99 | nickname => 'sub () { 0; $x } with $x unmodified elsewhere', | |
100 | generator => sub { my $x = 5; my $y = $x; sub(){0;$x} }, | |
101 | retval => 5, | |
102 | same_retval => 0, | |
103 | inlinable => 1, | |
104 | deprecated => 0, | |
105 | method => 0, | |
106 | }; | |
107 | ||
3c37c25a FC |
108 | # Explicit return after optimised statement, not at end of sub |
109 | push @tests, { | |
110 | nickname => 'sub () { 0; return $x; ... }', | |
111 | generator => sub { my $x = 5; sub () { 0; return $x; ... } }, | |
112 | retval => 5, | |
113 | same_retval => 0, | |
114 | inlinable => 0, | |
115 | deprecated => 0, | |
116 | method => 0, | |
117 | }; | |
118 | ||
9d391755 FC |
119 | # Explicit return after optimised statement, at end of sub [perl #123092] |
120 | push @tests, { | |
121 | nickname => 'sub () { 0; return $x }', | |
122 | generator => sub { my $x = 5; sub () { 0; return $x } }, | |
123 | retval => 5, | |
124 | same_retval => 0, | |
125 | inlinable => 0, | |
126 | deprecated => 0, | |
127 | method => 0, | |
128 | }; | |
129 | ||
f1603422 FC |
130 | # Multiple closure tests |
131 | push @tests, { | |
132 | nickname => 'simple lexical after another closure and no lvalue', | |
133 | generator => sub { | |
134 | my $x = 5; | |
135 | # This closure prevents inlining, though theoretically it shouldn’t | |
136 | # have to. If you change the behaviour, just change the test. This | |
137 | # fails the refcount check in op.c:op_const_sv, which is necessary for | |
138 | # the sake of \(my $x = 1) (tested below). | |
139 | my $sub1 = sub () { () = $x }; | |
140 | sub () { $x }; | |
141 | }, | |
142 | retval => 5, | |
143 | same_retval => 0, | |
144 | inlinable => 0, | |
145 | deprecated => 0, | |
146 | method => 0, | |
147 | }; | |
148 | push @tests, { | |
149 | nickname => 'simple lexical before another closure and no lvalue', | |
150 | generator => sub { | |
151 | my $x = 5; | |
152 | my $ret = sub () { $x }; | |
153 | # This does not prevent inlining and never has. | |
154 | my $sub1 = sub () { () = $x }; | |
155 | $ret; | |
156 | }, | |
157 | retval => 5, | |
158 | same_retval => 0, | |
159 | inlinable => 1, | |
160 | deprecated => 0, | |
161 | method => 0, | |
162 | }; | |
163 | push @tests, { | |
164 | nickname => 'simple lexical after an lvalue closure', | |
165 | generator => sub { | |
166 | my $x = 5; | |
167 | # This has always prevented inlining | |
168 | my $sub1 = sub () { $x++ }; | |
169 | sub () { $x }; | |
170 | }, | |
171 | retval => 5, | |
172 | same_retval => 0, | |
173 | inlinable => 0, | |
174 | deprecated => 0, | |
175 | method => 0, | |
176 | }; | |
177 | push @tests, { | |
178 | nickname => 'simple lexical before an lvalue closure', | |
179 | generator => sub { | |
180 | my $x = 5; | |
181 | my $ret = sub () { $x }; # <-- simple lexical op tree | |
182 | # Traditionally this has not prevented inlining, though it should. But | |
183 | # since $ret has a simple lexical op tree, we preserve backward-compat- | |
184 | # ibility, but deprecate it. | |
185 | my $sub1 = sub () { $x++ }; | |
186 | $ret; | |
187 | }, | |
30fc7a28 | 188 | exception => $exception_134138, |
f1603422 FC |
189 | }; |
190 | push @tests, { | |
191 | nickname => 'complex lexical op tree before an lvalue closure', | |
192 | generator => sub { | |
193 | my $x = 5; | |
194 | my $ret = sub () { 0; $x }; # <-- more than just a lexical | |
195 | # This used not to prevent inlining, though it should, and now does. | |
196 | my $sub1 = sub () { $x++ }; | |
197 | $ret; | |
198 | }, | |
199 | retval => 5, | |
200 | same_retval => 0, | |
201 | inlinable => 0, | |
202 | deprecated => 0, | |
203 | method => 0, | |
204 | }; | |
205 | push @tests, { | |
206 | nickname => 'complex lexical op tree before a nested lvalue closure', | |
207 | generator => sub { | |
208 | my $x = 5; | |
209 | my $ret = sub () { 0; $x }; # <-- more than just a lexical | |
210 | # This used not to prevent inlining, though it should, and now does. | |
211 | my $sub1 = sub () { sub () { $x++ } }; # nested | |
212 | $ret; | |
213 | }, | |
214 | retval => 5, | |
215 | same_retval => 0, | |
216 | inlinable => 0, | |
217 | deprecated => 0, | |
218 | method => 0, | |
219 | }; | |
220 | ||
4a991780 FC |
221 | use feature 'state', 'lexical_subs'; |
222 | no warnings 'experimental::lexical_subs'; | |
223 | ||
73c13e16 FC |
224 | # Constant constants |
225 | push @tests, { | |
226 | nickname => 'sub with constant', | |
227 | generator => sub { sub () { 8 } }, | |
228 | retval => 8, | |
229 | same_retval => 0, | |
230 | inlinable => 1, | |
231 | deprecated => 0, | |
232 | method => 0, | |
233 | }; | |
234 | push @tests, { | |
235 | nickname => 'sub with constant and return', | |
236 | generator => sub { sub () { return 8 } }, | |
237 | retval => 8, | |
238 | same_retval => 0, | |
239 | inlinable => 0, | |
240 | deprecated => 0, | |
241 | method => 0, | |
242 | }; | |
243 | push @tests, { | |
244 | nickname => 'sub with optimised statement and constant', | |
245 | generator => sub { sub () { 0; 8 } }, | |
246 | retval => 8, | |
247 | same_retval => 0, | |
248 | inlinable => 1, | |
249 | deprecated => 0, | |
250 | method => 0, | |
251 | }; | |
252 | push @tests, { | |
253 | nickname => 'sub with optimised statement, constant and return', | |
254 | generator => sub { sub () { 0; return 8 } }, | |
255 | retval => 8, | |
256 | same_retval => 0, | |
257 | inlinable => 0, | |
258 | deprecated => 0, | |
259 | method => 0, | |
260 | }; | |
261 | push @tests, { | |
262 | nickname => 'my sub with constant', | |
263 | generator => sub { my sub x () { 8 } \&x }, | |
264 | retval => 8, | |
265 | same_retval => 0, | |
266 | inlinable => 1, | |
267 | deprecated => 0, | |
268 | method => 0, | |
269 | }; | |
270 | push @tests, { | |
271 | nickname => 'my sub with constant and return', | |
272 | generator => sub { my sub x () { return 8 } \&x }, | |
273 | retval => 8, | |
274 | same_retval => 0, | |
275 | inlinable => 0, | |
276 | deprecated => 0, | |
277 | method => 0, | |
278 | }; | |
279 | push @tests, { | |
280 | nickname => 'my sub with optimised statement and constant', | |
281 | generator => sub { my sub x () { 0; 8 } \&x }, | |
282 | retval => 8, | |
283 | same_retval => 0, | |
284 | inlinable => 1, | |
285 | deprecated => 0, | |
286 | method => 0, | |
287 | }; | |
288 | push @tests, { | |
289 | nickname => 'my sub with optimised statement, constant and return', | |
290 | generator => sub { my sub x () { 0; return 8 } \&x }, | |
291 | retval => 8, | |
292 | same_retval => 0, | |
293 | inlinable => 0, | |
294 | deprecated => 0, | |
295 | method => 0, | |
296 | }; | |
297 | ||
03414f05 FC |
298 | # String eval |
299 | push @tests, { | |
300 | nickname => 'sub () { $x } with eval in scope', | |
301 | generator => sub { | |
302 | my $outer = 43; | |
303 | my $ret = sub () { $outer }; | |
304 | eval '$outer++'; | |
305 | $ret; | |
306 | }, | |
30fc7a28 | 307 | exception => $exception_134138, |
03414f05 FC |
308 | }; |
309 | push @tests, { | |
310 | nickname => 'sub () { $x } with s///ee in scope', | |
311 | generator => sub { | |
312 | my $outer = 43; | |
313 | my $dummy = '$outer++'; | |
314 | my $ret = sub () { $outer }; | |
315 | $dummy =~ s//$dummy/ee; | |
316 | $ret; | |
317 | }, | |
30fc7a28 | 318 | exception => $exception_134138, |
03414f05 FC |
319 | }; |
320 | push @tests, { | |
321 | nickname => 'sub () { $x } with eval not in scope', | |
322 | generator => sub { | |
323 | my $ret; | |
324 | { | |
325 | my $outer = 43; | |
326 | $ret = sub () { $outer }; | |
327 | } | |
328 | eval ''; | |
329 | $ret; | |
330 | }, | |
331 | retval => 43, | |
332 | same_retval => 0, | |
333 | inlinable => 1, | |
334 | deprecated => 0, | |
335 | method => 0, | |
336 | }; | |
337 | ||
4a991780 FC |
338 | push @tests, { |
339 | nickname => 'sub () { my $x; state sub z { $x } $outer }', | |
340 | generator => sub { | |
341 | my $outer = 43; | |
342 | sub () { my $x; state sub z { $x } $outer } | |
343 | }, | |
344 | retval => 43, | |
345 | same_retval => 0, | |
f1603422 FC |
346 | inlinable => 0, |
347 | deprecated => 0, | |
348 | method => 0, | |
349 | }; | |
350 | ||
351 | push @tests, { | |
352 | nickname => 'closure after \(my $x=1)', | |
353 | generator => sub { | |
354 | $y = \(my $x = 1); | |
355 | my $ret = sub () { $x }; | |
356 | $$y += 7; | |
357 | $ret; | |
358 | }, | |
359 | retval => 8, | |
360 | same_retval => 0, | |
4a991780 FC |
361 | inlinable => 0, |
362 | deprecated => 0, | |
363 | method => 0, | |
364 | }; | |
365 | ||
7f08c641 | 366 | push @tests, { |
bbd7756c FC |
367 | nickname => 'sub:method with simple lexical', |
368 | generator => sub { my $y; sub():method{$y} }, | |
369 | retval => undef, | |
370 | same_retval => 0, | |
371 | inlinable => 1, | |
372 | deprecated => 0, | |
373 | method => 1, | |
374 | }; | |
7a3e5b7e FC |
375 | push @tests, { |
376 | nickname => 'sub:method with constant', | |
377 | generator => sub { sub():method{3} }, | |
378 | retval => 3, | |
379 | same_retval => 0, | |
380 | inlinable => 1, | |
381 | deprecated => 0, | |
382 | method => 1, | |
383 | }; | |
384 | push @tests, { | |
385 | nickname => 'my sub:method with constant', | |
386 | generator => sub { my sub x ():method{3} \&x }, | |
387 | retval => 3, | |
388 | same_retval => 0, | |
389 | inlinable => 1, | |
390 | deprecated => 0, | |
391 | method => 1, | |
392 | }; | |
bbd7756c | 393 | |
e4211fee FC |
394 | push @tests, { |
395 | nickname => 'sub closing over state var', | |
396 | generator => sub { state $x = 3; sub () {$x} }, | |
397 | retval => 3, | |
398 | same_retval => 0, | |
399 | inlinable => 1, | |
400 | deprecated => 0, | |
401 | method => 0, | |
402 | }; | |
403 | push @tests, { | |
404 | nickname => 'sub closing over state var++', | |
405 | generator => sub { state $x++; sub () { $x } }, | |
30fc7a28 | 406 | exception => $exception_134138, |
e4211fee FC |
407 | }; |
408 | ||
bbd7756c FC |
409 | |
410 | use feature 'refaliasing'; | |
411 | no warnings 'experimental::refaliasing'; | |
412 | for \%_ (@tests) { | |
413 | my $nickname = $_{nickname}; | |
30fc7a28 JK |
414 | if (exists $_{exception} and $_{exception}) { |
415 | local $@; | |
416 | eval { my $sub = &{$_{generator}}; }; | |
417 | like($@, qr/$_{exception}/, "$nickname: now throws exception (RT 134138)"); | |
418 | next; | |
419 | } | |
0ac016fc | 420 | my $w; |
bbd7756c FC |
421 | local $SIG{__WARN__} = sub { $w = shift }; |
422 | my $sub = &{$_{generator}}; | |
423 | if (exists $_{deprecated}) { | |
424 | if ($_{deprecated}) { | |
425 | like $w, qr/^Constants from lexical variables potentially (?x: | |
9840d1d6 A |
426 | )modified elsewhere are deprecated\. This will (?x: |
427 | )not be allowed in Perl 5\.32 at /, | |
bbd7756c FC |
428 | "$nickname is deprecated"; |
429 | } | |
430 | else { | |
431 | is $w, undef, "$nickname is not deprecated"; | |
432 | } | |
433 | } | |
434 | if (exists $_{retval}) { | |
435 | is &$sub, $_{retval}, "retval of $nickname"; | |
436 | } | |
437 | if (exists $_{same_retval}) { | |
438 | my $same = $_{same_retval} ? "same" : "different"; | |
439 | &{$_{same_retval} ? \&is : \&isnt}( | |
440 | \scalar &$sub(), \scalar &$sub(), | |
441 | "$nickname gives $same retval each call" | |
442 | ); | |
443 | } | |
444 | if (exists $_{inlinable}) { | |
445 | local *temp_inlinability_test = $sub; | |
446 | $w = undef; | |
447 | use warnings 'redefine'; | |
448 | *temp_inlinability_test = sub (){}; | |
449 | my $S = $_{inlinable} ? "Constant s" : "S"; | |
450 | my $not = " not" x! $_{inlinable}; | |
451 | like $w, qr/^${S}ubroutine .* redefined at /, | |
452 | "$nickname is$not inlinable"; | |
453 | } | |
454 | if (exists $_{method}) { | |
455 | local *time = $sub; | |
456 | $w = undef; | |
457 | use warnings 'ambiguous'; | |
458 | eval "()=time"; | |
459 | if ($_{method}) { | |
460 | is $w, undef, "$nickname has :method attribute"; | |
461 | } | |
462 | else { | |
463 | like $w, qr/^Ambiguous call resolved as CORE::time\(\), (?x: | |
464 | )qualify as such or use & at /, | |
465 | "$nickname has no :method attribute"; | |
466 | } | |
0b2df18f | 467 | } |
0b2df18f | 468 | |
bbd7756c FC |
469 | &{$_{finally} or next} |
470 | } | |
82e85a9c FC |
471 | |
472 | # This used to fail an assertion in leave_scope. For some reason, it did | |
473 | # not fail within the framework above. | |
474 | sub { my $x = "x"; my $sub = sub () { $x }; undef $sub; } ->(); | |
475 | pass("No assertion failure when turning on PADSTALE on lexical shared by" | |
476 | ." erstwhile constant"); | |
477 | ||
6dfba0aa FC |
478 | { |
479 | my $sub = sub { | |
480 | my $x = "x"x2000; sub () {$x}; | |
481 | }->(); | |
482 | $y = &$sub; | |
483 | $z = &$sub; | |
484 | is $z, $y, 'inlinable sub ret vals are not swipable'; | |
485 | } | |
30fc7a28 | 486 |