3 # Test the various op trees that turn sub () { ... } into a constant, and
4 # some variants that don’t.
13 # @tests is an array of hash refs, each of which can have various keys:
15 # nickname - name of the sub to use in test names
16 # generator - a sub returning a code ref to test
17 # finally - sub to run after the tests
19 # Each of the following gives expected test results. If the key is
20 # omitted, the test is skipped:
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
29 # [perl #63540] Don’t treat sub { if(){.....}; "constant" } as a constant
30 sub blonk { ++$blonk_was_called }
32 nickname => 'sub with null+kids (if-block), then constant',
34 # This used to turn into a constant with the value of $x
36 sub() { if($x){ () = "tralala"; blonk() }; 0 }
43 finally => sub { ok($blonk_was_called, 'RT #63540'); },
48 nickname => 'sub with simple lexical modified elsewhere',
49 generator => sub { my $x = 5; my $ret = sub(){$x}; $x = 7; $ret },
50 retval => 5, # change to 7 when the deprecation cycle is over
58 nickname => 'sub with simple lexical unmodified elsewhere',
59 generator => sub { my $x = 5; sub(){$x} },
68 nickname => 'return $variable modified elsewhere',
69 generator => sub { my $x=5; my $ret = sub(){return $x}; $x = 7; $ret },
78 nickname => 'return $variable unmodified elsewhere',
79 generator => sub { my $x = 5; sub(){return $x} },
88 nickname => 'sub () { 0; $x } with $x modified elsewhere',
89 generator => sub { my $x = 5; my $ret = sub(){0;$x}; $x = 8; $ret },
98 nickname => 'sub () { 0; $x } with $x unmodified elsewhere',
99 generator => sub { my $x = 5; my $y = $x; sub(){0;$x} },
107 # Explicit return after optimised statement, not at end of sub
109 nickname => 'sub () { 0; return $x; ... }',
110 generator => sub { my $x = 5; sub () { 0; return $x; ... } },
118 # Explicit return after optimised statement, at end of sub [perl #123092]
120 nickname => 'sub () { 0; return $x }',
121 generator => sub { my $x = 5; sub () { 0; return $x } },
129 # Multiple closure tests
131 nickname => 'simple lexical after another closure and no lvalue',
134 # This closure prevents inlining, though theoretically it shouldn’t
135 # have to. If you change the behaviour, just change the test. This
136 # fails the refcount check in op.c:op_const_sv, which is necessary for
137 # the sake of \(my $x = 1) (tested below).
138 my $sub1 = sub () { () = $x };
148 nickname => 'simple lexical before another closure and no lvalue',
151 my $ret = sub () { $x };
152 # This does not prevent inlining and never has.
153 my $sub1 = sub () { () = $x };
163 nickname => 'simple lexical after an lvalue closure',
166 # This has always prevented inlining
167 my $sub1 = sub () { $x++ };
177 nickname => 'simple lexical before an lvalue closure',
180 my $ret = sub () { $x }; # <-- simple lexical op tree
181 # Traditionally this has not prevented inlining, though it should. But
182 # since $ret has a simple lexical op tree, we preserve backward-compat-
183 # ibility, but deprecate it.
184 my $sub1 = sub () { $x++ };
194 nickname => 'complex lexical op tree before an lvalue closure',
197 my $ret = sub () { 0; $x }; # <-- more than just a lexical
198 # This used not to prevent inlining, though it should, and now does.
199 my $sub1 = sub () { $x++ };
209 nickname => 'complex lexical op tree before a nested lvalue closure',
212 my $ret = sub () { 0; $x }; # <-- more than just a lexical
213 # This used not to prevent inlining, though it should, and now does.
214 my $sub1 = sub () { sub () { $x++ } }; # nested
224 use feature 'state', 'lexical_subs';
225 no warnings 'experimental::lexical_subs';
229 nickname => 'sub with constant',
230 generator => sub { sub () { 8 } },
238 nickname => 'sub with constant and return',
239 generator => sub { sub () { return 8 } },
247 nickname => 'sub with optimised statement and constant',
248 generator => sub { sub () { 0; 8 } },
256 nickname => 'sub with optimised statement, constant and return',
257 generator => sub { sub () { 0; return 8 } },
265 nickname => 'my sub with constant',
266 generator => sub { my sub x () { 8 } \&x },
274 nickname => 'my sub with constant and return',
275 generator => sub { my sub x () { return 8 } \&x },
283 nickname => 'my sub with optimised statement and constant',
284 generator => sub { my sub x () { 0; 8 } \&x },
292 nickname => 'my sub with optimised statement, constant and return',
293 generator => sub { my sub x () { 0; return 8 } \&x },
303 nickname => 'sub () { $x } with eval in scope',
306 my $ret = sub () { $outer };
317 nickname => 'sub () { $x } with s///ee in scope',
320 my $dummy = '$outer++';
321 my $ret = sub () { $outer };
322 $dummy =~ s//$dummy/ee;
332 nickname => 'sub () { $x } with eval not in scope',
337 $ret = sub () { $outer };
350 nickname => 'sub () { my $x; state sub z { $x } $outer }',
353 sub () { my $x; state sub z { $x } $outer }
363 nickname => 'closure after \(my $x=1)',
366 my $ret = sub () { $x };
378 nickname => 'sub:method with simple lexical',
379 generator => sub { my $y; sub():method{$y} },
387 nickname => 'sub:method with constant',
388 generator => sub { sub():method{3} },
396 nickname => 'my sub:method with constant',
397 generator => sub { my sub x ():method{3} \&x },
406 nickname => 'sub closing over state var',
407 generator => sub { state $x = 3; sub () {$x} },
415 nickname => 'sub closing over state var++',
416 generator => sub { state $x++; sub () { $x } },
425 use feature 'refaliasing';
426 no warnings 'experimental::refaliasing';
428 my $nickname = $_{nickname};
430 local $SIG{__WARN__} = sub { $w = shift };
431 my $sub = &{$_{generator}};
432 if (exists $_{deprecated}) {
433 if ($_{deprecated}) {
434 like $w, qr/^Constants from lexical variables potentially (?x:
435 )modified elsewhere are deprecated\. This will (?x:
436 )not be allowed in Perl 5\.32 at /,
437 "$nickname is deprecated";
440 is $w, undef, "$nickname is not deprecated";
443 if (exists $_{retval}) {
444 is &$sub, $_{retval}, "retval of $nickname";
446 if (exists $_{same_retval}) {
447 my $same = $_{same_retval} ? "same" : "different";
448 &{$_{same_retval} ? \&is : \&isnt}(
449 \scalar &$sub(), \scalar &$sub(),
450 "$nickname gives $same retval each call"
453 if (exists $_{inlinable}) {
454 local *temp_inlinability_test = $sub;
456 use warnings 'redefine';
457 *temp_inlinability_test = sub (){};
458 my $S = $_{inlinable} ? "Constant s" : "S";
459 my $not = " not" x! $_{inlinable};
460 like $w, qr/^${S}ubroutine .* redefined at /,
461 "$nickname is$not inlinable";
463 if (exists $_{method}) {
466 use warnings 'ambiguous';
469 is $w, undef, "$nickname has :method attribute";
472 like $w, qr/^Ambiguous call resolved as CORE::time\(\), (?x:
473 )qualify as such or use & at /,
474 "$nickname has no :method attribute";
478 &{$_{finally} or next}
481 # This used to fail an assertion in leave_scope. For some reason, it did
482 # not fail within the framework above.
483 sub { my $x = "x"; my $sub = sub () { $x }; undef $sub; } ->();
484 pass("No assertion failure when turning on PADSTALE on lexical shared by"
485 ." erstwhile constant");
489 my $x = "x"x2000; sub () {$x};
493 is $z, $y, 'inlinable sub ret vals are not swipable';