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 }