xref: /openbsd/gnu/usr.bin/perl/t/op/const-optree.t (revision 097a140d) 
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 148;
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#   exception   - sub now throws an exception (previously threw
29#                 deprecation warning)
30
31my $exception_134138 = 'Constants from lexical variables potentially modified '
32    . 'elsewhere are no longer permitted';
33
34# [perl #63540] Don’t treat sub { if(){.....}; "constant" } as a constant
35sub blonk { ++$blonk_was_called }
36push @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};
50
51# [perl #79908]
52push @tests, {
53  nickname    => 'sub with simple lexical modified elsewhere',
54  generator   => sub { my $x = 5; my $ret = sub(){$x}; $x = 7; $ret },
55  exception   => $exception_134138,
56};
57
58push @tests, {
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
68push @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
78push @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
88push @tests, {
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
98push @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
108# Explicit return after optimised statement, not at end of sub
109push @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
119# Explicit return after optimised statement, at end of sub [perl #123092]
120push @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
130# Multiple closure tests
131push @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};
148push @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};
163push @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};
177push @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  },
188  exception   => $exception_134138,
189};
190push @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};
205push @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
221use feature 'state', 'lexical_subs';
222no warnings 'experimental::lexical_subs';
223
224# Constant constants
225push @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};
234push @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};
243push @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};
252push @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};
261push @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};
270push @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};
279push @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};
288push @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
298# String eval
299push @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  },
307  exception   => $exception_134138,
308};
309push @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  },
318  exception   => $exception_134138,
319};
320push @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
338push @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,
346  inlinable   => 0,
347  deprecated  => 0,
348  method      => 0,
349};
350
351push @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,
361  inlinable   => 0,
362  deprecated  => 0,
363  method      => 0,
364};
365
366push @tests, {
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};
375push @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};
384push @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};
393
394push @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};
403push @tests, {
404  nickname    => 'sub closing over state var++',
405  generator   => sub { state $x++; sub () { $x } },
406  exception   => $exception_134138,
407};
408
409
410use feature 'refaliasing';
411no warnings 'experimental::refaliasing';
412for \%_ (@tests) {
413    my $nickname = $_{nickname};
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    }
420    my $w;
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:
426                       )modified elsewhere are deprecated\. This will (?x:
427                       )not be allowed in Perl 5\.32 at /,
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        }
467    }
468
469    &{$_{finally} or next}
470}
471
472# This used to fail an assertion in leave_scope.  For some reason, it did
473# not fail within the framework above.
474sub  { my $x = "x"; my $sub = sub () { $x }; undef $sub; } ->();
475pass("No assertion failure when turning on PADSTALE on lexical shared by"
476    ." erstwhile constant");
477
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}
486
487