xref: /openbsd/gnu/usr.bin/perl/t/op/const-optree.t (revision 09467b48) 
1#!perl
2
3# Test the various op trees that turn sub () { ... } into a constant, and
4# some variants that don’t.
5
6BEGIN {
7    chdir 't';
8    require './test.pl';
9    set_up_inc('../lib');
10}
11plan 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
30sub blonk { ++$blonk_was_called }
31push @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]
47push @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
57push @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
67push @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
77push @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
87push @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
97push @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
108push @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]
119push @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
130push @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};
147push @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};
162push @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};
176push @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};
193push @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};
208push @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
224use feature 'state', 'lexical_subs';
225no warnings 'experimental::lexical_subs';
226
227# Constant constants
228push @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};
237push @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};
246push @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};
255push @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};
264push @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};
273push @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};
282push @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};
291push @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
302push @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};
316push @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};
331push @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
349push @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
362push @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
377push @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};
386push @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};
395push @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
405push @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};
414push @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
425use feature 'refaliasing';
426no warnings 'experimental::refaliasing';
427for \%_ (@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.
483sub  { my $x = "x"; my $sub = sub () { $x }; undef $sub; } ->();
484pass("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}
495