Time-HiRes 1.9760 - bump Module::CoreList & co
[perl.git] / t / op / const-optree.t
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';
9     set_up_inc('../lib');
10 }
11 plan 168;
12
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
17 #   finally     - sub to run after the tests
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
28
29 # [perl #63540] Don’t treat sub { if(){.....}; "constant" } as a constant
30 sub blonk { ++$blonk_was_called }
31 push @tests, {
32   nickname    => 'sub with null+kids (if-block), then constant',
33   generator   => sub {
34     # This used to turn into a constant with the value of $x
35     my $x = 7;
36     sub() { if($x){ () = "tralala"; blonk() }; 0 }
37   },
38   retval      => 0,
39   same_retval => 0,
40   inlinable   => 0,
41   deprecated  => 0,
42   method      => 0,
43   finally     => sub { ok($blonk_was_called, 'RT #63540'); },
44 };
45
46 # [perl #79908]
47 push @tests, {
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
51   same_retval => 0,
52   inlinable   => 1,
53   deprecated  => 1,
54   method      => 0,
55 };
56
57 push @tests, {
58   nickname    => 'sub with simple lexical unmodified elsewhere',
59   generator   => sub { my $x = 5; sub(){$x} },
60   retval      => 5,
61   same_retval => 0,
62   inlinable   => 1,
63   deprecated  => 0,
64   method      => 0,
65 };
66
67 push @tests, {
68   nickname    => 'return $variable modified elsewhere',
69   generator   => sub { my $x=5; my $ret = sub(){return $x}; $x = 7; $ret },
70   retval      => 7,
71   same_retval => 0,
72   inlinable   => 0,
73   deprecated  => 0,
74   method      => 0,
75 };
76
77 push @tests, {
78   nickname    => 'return $variable unmodified elsewhere',
79   generator   => sub { my $x = 5; sub(){return $x} },
80   retval      => 5,
81   same_retval => 0,
82   inlinable   => 0,
83   deprecated  => 0,
84   method      => 0,
85 };
86
87 push @tests, {
88   nickname    => 'sub () { 0; $x } with $x modified elsewhere',
89   generator   => sub { my $x = 5; my $ret = sub(){0;$x}; $x = 8; $ret },
90   retval      => 8,
91   same_retval => 0,
92   inlinable   => 0,
93   deprecated  => 0,
94   method      => 0,
95 };
96
97 push @tests, {
98   nickname    => 'sub () { 0; $x } with $x unmodified elsewhere',
99   generator   => sub { my $x = 5; my $y = $x; sub(){0;$x} },
100   retval      => 5,
101   same_retval => 0,
102   inlinable   => 1,
103   deprecated  => 0,
104   method      => 0,
105 };
106
107 # Explicit return after optimised statement, not at end of sub
108 push @tests, {
109   nickname    => 'sub () { 0; return $x; ... }',
110   generator   => sub { my $x = 5; sub () { 0; return $x; ... } },
111   retval      => 5,
112   same_retval => 0,
113   inlinable   => 0,
114   deprecated  => 0,
115   method      => 0,
116 };
117
118 # Explicit return after optimised statement, at end of sub [perl #123092]
119 push @tests, {
120   nickname    => 'sub () { 0; return $x }',
121   generator   => sub { my $x = 5; sub () { 0; return $x } },
122   retval      => 5,
123   same_retval => 0,
124   inlinable   => 0,
125   deprecated  => 0,
126   method      => 0,
127 };
128
129 # Multiple closure tests
130 push @tests, {
131   nickname    => 'simple lexical after another closure and no lvalue',
132   generator   => sub {
133     my $x = 5;
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 };
139     sub () { $x };
140   },
141   retval      => 5,
142   same_retval => 0,
143   inlinable   => 0,
144   deprecated  => 0,
145   method      => 0,
146 };
147 push @tests, {
148   nickname    => 'simple lexical before another closure and no lvalue',
149   generator   => sub {
150     my $x = 5;
151     my $ret = sub () { $x };
152     # This does not prevent inlining and never has.
153     my $sub1 = sub () { () = $x };
154     $ret;
155   },
156   retval      => 5,
157   same_retval => 0,
158   inlinable   => 1,
159   deprecated  => 0,
160   method      => 0,
161 };
162 push @tests, {
163   nickname    => 'simple lexical after an lvalue closure',
164   generator   => sub {
165     my $x = 5;
166     # This has always prevented inlining
167     my $sub1 = sub () { $x++ };
168     sub () { $x };
169   },
170   retval      => 5,
171   same_retval => 0,
172   inlinable   => 0,
173   deprecated  => 0,
174   method      => 0,
175 };
176 push @tests, {
177   nickname    => 'simple lexical before an lvalue closure',
178   generator   => sub {
179     my $x = 5;
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++ };
185     $ret;
186   },
187   retval      => 5,
188   same_retval => 0,
189   inlinable   => 1,
190   deprecated  => 1,
191   method      => 0,
192 };
193 push @tests, {
194   nickname    => 'complex lexical op tree before an lvalue closure',
195   generator   => sub {
196     my $x = 5;
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++ };
200     $ret;
201   },
202   retval      => 5,
203   same_retval => 0,
204   inlinable   => 0,
205   deprecated  => 0,
206   method      => 0,
207 };
208 push @tests, {
209   nickname    => 'complex lexical op tree before a nested lvalue closure',
210   generator   => sub {
211     my $x = 5;
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
215     $ret;
216   },
217   retval      => 5,
218   same_retval => 0,
219   inlinable   => 0,
220   deprecated  => 0,
221   method      => 0,
222 };
223
224 use feature 'state', 'lexical_subs';
225 no warnings 'experimental::lexical_subs';
226
227 # Constant constants
228 push @tests, {
229   nickname    => 'sub with constant',
230   generator   => sub { sub () { 8 } },
231   retval      => 8,
232   same_retval => 0,
233   inlinable   => 1,
234   deprecated  => 0,
235   method      => 0,
236 };
237 push @tests, {
238   nickname    => 'sub with constant and return',
239   generator   => sub { sub () { return 8 } },
240   retval      => 8,
241   same_retval => 0,
242   inlinable   => 0,
243   deprecated  => 0,
244   method      => 0,
245 };
246 push @tests, {
247   nickname    => 'sub with optimised statement and constant',
248   generator   => sub { sub () { 0; 8 } },
249   retval      => 8,
250   same_retval => 0,
251   inlinable   => 1,
252   deprecated  => 0,
253   method      => 0,
254 };
255 push @tests, {
256   nickname    => 'sub with optimised statement, constant and return',
257   generator   => sub { sub () { 0; return 8 } },
258   retval      => 8,
259   same_retval => 0,
260   inlinable   => 0,
261   deprecated  => 0,
262   method      => 0,
263 };
264 push @tests, {
265   nickname    => 'my sub with constant',
266   generator   => sub { my sub x () { 8 } \&x },
267   retval      => 8,
268   same_retval => 0,
269   inlinable   => 1,
270   deprecated  => 0,
271   method      => 0,
272 };
273 push @tests, {
274   nickname    => 'my sub with constant and return',
275   generator   => sub { my sub x () { return 8 } \&x },
276   retval      => 8,
277   same_retval => 0,
278   inlinable   => 0,
279   deprecated  => 0,
280   method      => 0,
281 };
282 push @tests, {
283   nickname    => 'my sub with optimised statement and constant',
284   generator   => sub { my sub x () { 0; 8 } \&x },
285   retval      => 8,
286   same_retval => 0,
287   inlinable   => 1,
288   deprecated  => 0,
289   method      => 0,
290 };
291 push @tests, {
292   nickname    => 'my sub with optimised statement, constant and return',
293   generator   => sub { my sub x () { 0; return 8 } \&x },
294   retval      => 8,
295   same_retval => 0,
296   inlinable   => 0,
297   deprecated  => 0,
298   method      => 0,
299 };
300
301 # String eval
302 push @tests, {
303   nickname    => 'sub () { $x } with eval in scope',
304   generator   => sub {
305     my $outer = 43;
306     my $ret = sub () { $outer };
307     eval '$outer++';
308     $ret;
309   },
310   retval      => 43,
311   same_retval => 0,
312   inlinable   => 1,
313   deprecated  => 1,
314   method      => 0,
315 };
316 push @tests, {
317   nickname    => 'sub () { $x } with s///ee in scope',
318   generator   => sub {
319     my $outer = 43;
320     my $dummy = '$outer++';
321     my $ret = sub () { $outer };
322     $dummy =~ s//$dummy/ee;
323     $ret;
324   },
325   retval      => 43,
326   same_retval => 0,
327   inlinable   => 1,
328   deprecated  => 1,
329   method      => 0,
330 };
331 push @tests, {
332   nickname    => 'sub () { $x } with eval not in scope',
333   generator   => sub {
334     my $ret;
335     {
336       my $outer = 43;
337       $ret = sub () { $outer };
338     }
339     eval '';
340     $ret;
341   },
342   retval      => 43,
343   same_retval => 0,
344   inlinable   => 1,
345   deprecated  => 0,
346   method      => 0,
347 };
348
349 push @tests, {
350   nickname    => 'sub () { my $x; state sub z { $x } $outer }',
351   generator   => sub {
352     my $outer = 43;
353     sub () { my $x; state sub z { $x } $outer }
354   },
355   retval      => 43,
356   same_retval => 0,
357   inlinable   => 0,
358   deprecated  => 0,
359   method      => 0,
360 };
361
362 push @tests, {
363   nickname    => 'closure after \(my $x=1)',
364   generator   => sub {
365     $y = \(my $x = 1);
366     my $ret = sub () { $x };
367     $$y += 7;
368     $ret;
369   },
370   retval      => 8,
371   same_retval => 0,
372   inlinable   => 0,
373   deprecated  => 0,
374   method      => 0,
375 };
376
377 push @tests, {
378   nickname    => 'sub:method with simple lexical',
379   generator   => sub { my $y; sub():method{$y} },
380   retval      => undef,
381   same_retval => 0,
382   inlinable   => 1,
383   deprecated  => 0,
384   method      => 1,
385 };
386 push @tests, {
387   nickname    => 'sub:method with constant',
388   generator   => sub { sub():method{3} },
389   retval      => 3,
390   same_retval => 0,
391   inlinable   => 1,
392   deprecated  => 0,
393   method      => 1,
394 };
395 push @tests, {
396   nickname    => 'my sub:method with constant',
397   generator   => sub { my sub x ():method{3} \&x },
398   retval      => 3,
399   same_retval => 0,
400   inlinable   => 1,
401   deprecated  => 0,
402   method      => 1,
403 };
404
405 push @tests, {
406   nickname    => 'sub closing over state var',
407   generator   => sub { state $x = 3; sub () {$x} },
408   retval      => 3,
409   same_retval => 0,
410   inlinable   => 1,
411   deprecated  => 0,
412   method      => 0,
413 };
414 push @tests, {
415   nickname    => 'sub closing over state var++',
416   generator   => sub { state $x++; sub () { $x } },
417   retval      => 1,
418   same_retval => 0,
419   inlinable   => 1,
420   deprecated  => 1,
421   method      => 0,
422 };
423
424
425 use feature 'refaliasing';
426 no warnings 'experimental::refaliasing';
427 for \%_ (@tests) {
428     my $nickname = $_{nickname};
429     my $w;
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";
438         }
439         else {
440             is $w, undef, "$nickname is not deprecated";
441         }
442     }
443     if (exists $_{retval}) {
444         is &$sub, $_{retval}, "retval of $nickname";
445     }
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"
451         );
452     }
453     if (exists $_{inlinable}) {
454         local *temp_inlinability_test = $sub;
455         $w = undef;
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";
462     }
463     if (exists $_{method}) {
464         local *time = $sub;
465         $w = undef;
466         use warnings 'ambiguous';
467         eval "()=time";
468         if ($_{method}) {
469             is $w, undef, "$nickname has :method attribute";
470         }
471         else {
472             like $w, qr/^Ambiguous call resolved as CORE::time\(\), (?x:
473                         )qualify as such or use & at /,
474                 "$nickname has no :method attribute";
475         }
476     }
477
478     &{$_{finally} or next}
479 }
480
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");
486
487 {
488     my $sub = sub {
489         my $x = "x"x2000; sub () {$x};
490     }->();
491     $y = &$sub;
492     $z = &$sub;
493     is $z, $y, 'inlinable sub ret vals are not swipable';
494 }