ext/B/t/optree_constants.t

   1 #!perl
   2
   3 BEGIN {
   4     unshift @INC, 't';
   5     require Config;
   6     if (($Config::Config{'extensions'} !~ /\bB\b/) ){
   7         print "1..0 # Skip -- Perl configured without B module\n";
   8         exit 0;
   9     }
  10     if (!$Config::Config{useperlio}) {
  11         print "1..0 # Skip -- need perlio to walk the optree\n";
  12         exit 0;
  13     }
  14 }
  15
  16 use OptreeCheck;        # ALSO DOES @ARGV HANDLING !!!!!!
  17 use Config;
  18
  19 plan tests => 99;
  20
  21 #################################
  22
  23 my sub lleexx {}
  24 sub tsub0 {}
  25 sub tsub1 {} $tsub1 = 1;
  26 sub t::tsub2 {}
  27 sub t::tsub3 {} $tsub3 = 1;
  28 {
  29     package t;
  30     sub tsub4 {}
  31     sub tsub5 {} $tsub5 = 1;
  32 }
  33
  34 use constant {          # see also t/op/gv.t line 358
  35     myaref      => [ 1,2,3 ],
  36     myfl        => 1.414213,
  37     myglob      => \*STDIN,
  38     myhref      => { a  => 1 },
  39     myint       => 42,
  40     myrex       => qr/foo/,
  41     mystr       => 'hithere',
  42     mysub       => \&ok,
  43     myundef     => undef,
  44     myunsub     => \&nosuch,
  45     myanonsub   => sub {},
  46     mylexsub    => \&lleexx,
  47     tsub0       => \&tsub0,
  48     tsub1       => \&tsub1,
  49     tsub2       => \&t::tsub2,
  50     tsub3       => \&t::tsub3,
  51     tsub4       => \&t::tsub4,
  52     tsub5       => \&t::tsub5,
  53 };
  54
  55 sub myyes() { 1==1 }
  56 sub myno () { return 1!=1 }
  57 sub pi () { 3.14159 };
  58
  59 my $want = {    # expected types, how value renders in-line, todos (maybe)
  60     mystr       => [ 'PV', '"'.mystr.'"' ],
  61     myhref      => [ 'IV', '\\\\HASH'],
  62     pi          => [ 'NV', pi ],
  63     myglob      => [ 'IV', '\\\\' ],
  64     mysub       => [ 'IV', '\\\\&main::ok' ],
  65     myunsub     => [ 'IV', '\\\\&main::nosuch' ],
  66     myanonsub   => [ 'IV', '\\\\CODE' ],
  67     mylexsub    => [ 'IV', '\\\\&lleexx' ],
  68     tsub0       => [ 'IV', '\\\\&main::tsub0' ],
  69     tsub1       => [ 'IV', '\\\\&main::tsub1' ],
  70     tsub2       => [ 'IV', '\\\\&t::tsub2' ],
  71     tsub3       => [ 'IV', '\\\\&t::tsub3' ],
  72     tsub4       => [ 'IV', '\\\\&t::tsub4' ],
  73     tsub5       => [ 'IV', '\\\\&t::tsub5' ],
  74     # these are not inlined, at least not per BC::Concise
  75     #myyes      => [ 'IV', ],
  76     #myno       => [ 'IV', ],
  77     myaref      => [ 'IV', '\\\\ARRAY' ],
  78     myfl        => [ 'NV', myfl ],
  79     myint       => [ 'IV', myint ],
  80     myrex       => [ 'IV', '\\\\"\\(?^:Foo\\)"' ],
  81     myundef     => [ 'NULL', ],
  82 };
  83
  84 use constant WEEKDAYS
  85     => qw ( Sunday Monday Tuesday Wednesday Thursday Friday Saturday );
  86
  87
  88 $::{napier} = \2.71828; # counter-example (doesn't get optimized).
  89 eval "sub napier ();";
  90
  91
  92 # should be able to undefine constant::import here ???
  93 INIT {
  94     # eval 'sub constant::import () {}';
  95     # undef *constant::import::{CODE};
  96 };
  97
  98 #################################
  99 pass("RENDER CONSTANT SUBS RETURNING SCALARS");
 100
 101 for $func (sort keys %$want) {
 102     # no strict 'refs'; # why not needed ?
 103     checkOptree ( name      => "$func() as a coderef",
 104                   code      => \&{$func},
 105                   noanchors => 1,
 106                   expect    => <<EOT_EOT, expect_nt => <<EONT_EONT);
 107  is a constant sub, optimized to a $want->{$func}[0]
 108 EOT_EOT
 109  is a constant sub, optimized to a $want->{$func}[0]
 110 EONT_EONT
 111
 112 }
 113
 114 pass("RENDER CALLS TO THOSE CONSTANT SUBS");
 115
 116 for $func (sort keys %$want) {
 117     # print "# doing $func\n";
 118     checkOptree ( name    => "call $func",
 119                   code    => "$func",
 120                   ($want->{$func}[2]) ? ( todo => $want->{$func}[2]) : (),
 121                   bc_opts => '-nobanner',
 122                   expect  => <<EOT_EOT, expect_nt => <<EONT_EONT);
 123 3  <1> leavesub[2 refs] K/REFC,1 ->(end)
 124 -     <\@> lineseq KP ->3
 125 1        <;> dbstate(main 833 (eval 44):1) v ->2
 126 2        <\$> const[$want->{$func}[0] $want->{$func}[1]] s*/FOLD ->3
 127 EOT_EOT
 128 3  <1> leavesub[2 refs] K/REFC,1 ->(end)
 129 -     <\@> lineseq KP ->3
 130 1        <;> dbstate(main 833 (eval 44):1) v ->2
 131 2        <\$> const($want->{$func}[0] $want->{$func}[1]) s*/FOLD ->3
 132 EONT_EONT
 133
 134 }
 135
 136 ##############
 137 pass("MORE TESTS");
 138
 139 checkOptree ( name      => 'myyes() as coderef',
 140               code      => sub () { 1==1 },
 141               noanchors => 1,
 142               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 143  is a constant sub, optimized to a SPECIAL
 144 EOT_EOT
 145  is a constant sub, optimized to a SPECIAL
 146 EONT_EONT
 147
 148
 149 checkOptree ( name      => 'myyes() as coderef',
 150               prog      => 'sub a() { 1==1 }; print a',
 151               noanchors => 1,
 152               strip_open_hints => 1,
 153               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 154 # 6  <@> leave[1 ref] vKP/REFC ->(end)
 155 # 1     <0> enter ->2
 156 # 2     <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
 157 # 5     <@> print vK ->6
 158 # 3        <0> pushmark s ->4
 159 # 4        <$> const[SPECIAL sv_yes] s*/FOLD ->5
 160 EOT_EOT
 161 # 6  <@> leave[1 ref] vKP/REFC ->(end)
 162 # 1     <0> enter ->2
 163 # 2     <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
 164 # 5     <@> print vK ->6
 165 # 3        <0> pushmark s ->4
 166 # 4        <$> const(SPECIAL sv_yes) s*/FOLD ->5
 167 EONT_EONT
 168
 169
 170 # Need to do this as a prog, not code, as only the first constant to use
 171 # PL_sv_no actually gets to use the real thing - every one following is
 172 # copied.
 173 checkOptree ( name      => 'myno() as coderef',
 174               prog      => 'sub a() { 1!=1 }; print a',
 175               noanchors => 1,
 176               strip_open_hints => 1,
 177               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 178 # 6  <@> leave[1 ref] vKP/REFC ->(end)
 179 # 1     <0> enter ->2
 180 # 2     <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
 181 # 5     <@> print vK ->6
 182 # 3        <0> pushmark s ->4
 183 # 4        <$> const[SPECIAL sv_no] s*/FOLD ->5
 184 EOT_EOT
 185 # 6  <@> leave[1 ref] vKP/REFC ->(end)
 186 # 1     <0> enter ->2
 187 # 2     <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
 188 # 5     <@> print vK ->6
 189 # 3        <0> pushmark s ->4
 190 # 4        <$> const(SPECIAL sv_no) s*/FOLD ->5
 191 EONT_EONT
 192
 193
 194 my ($expect, $expect_nt) = (" is a constant sub, optimized to a AV\n") x 2;
 195
 196
 197 checkOptree ( name      => 'constant sub returning list',
 198               code      => \&WEEKDAYS,
 199               noanchors => 1,
 200               expect => $expect, expect_nt => $expect_nt);
 201
 202
 203 sub printem {
 204     printf "myint %d mystr %s myfl %f pi %f\n"
 205         , myint, mystr, myfl, pi;
 206 }
 207
 208 my ($expect, $expect_nt) = (<<'EOT_EOT', <<'EONT_EONT');
 209 # 9  <1> leavesub[1 ref] K/REFC,1 ->(end)
 210 # -     <@> lineseq KP ->9
 211 # 1        <;> nextstate(main 635 optree_constants.t:163) v:>,<,% ->2
 212 # 8        <@> prtf sK ->9
 213 # 2           <0> pushmark sM ->3
 214 # 3           <$> const[PV "myint %d mystr %s myfl %f pi %f\n"] sM/FOLD ->4
 215 # 4           <$> const[IV 42] sM*/FOLD ->5
 216 # 5           <$> const[PV "hithere"] sM*/FOLD ->6
 217 # 6           <$> const[NV 1.414213] sM*/FOLD ->7
 218 # 7           <$> const[NV 3.14159] sM*/FOLD ->8
 219 EOT_EOT
 220 # 9  <1> leavesub[1 ref] K/REFC,1 ->(end)
 221 # -     <@> lineseq KP ->9
 222 # 1        <;> nextstate(main 635 optree_constants.t:163) v:>,<,% ->2
 223 # 8        <@> prtf sK ->9
 224 # 2           <0> pushmark sM ->3
 225 # 3           <$> const(PV "myint %d mystr %s myfl %f pi %f\n") sM/FOLD ->4
 226 # 4           <$> const(IV 42) sM*/FOLD ->5
 227 # 5           <$> const(PV "hithere") sM*/FOLD ->6
 228 # 6           <$> const(NV 1.414213) sM*/FOLD ->7
 229 # 7           <$> const(NV 3.14159) sM*/FOLD ->8
 230 EONT_EONT
 231
 232 s|\\n"[])] sM\K/FOLD|| for $expect, $expect_nt;
 233
 234 checkOptree ( name      => 'call many in a print statement',
 235               code      => \&printem,
 236               strip_open_hints => 1,
 237               expect => $expect, expect_nt => $expect_nt);
 238
 239 # test constant expression folding
 240
 241 checkOptree ( name      => 'arithmetic constant folding in print',
 242               code      => 'print 1+2+3',
 243               strip_open_hints => 1,
 244               expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 245 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 246 # -     <@> lineseq KP ->5
 247 # 1        <;> nextstate(main 937 (eval 53):1) v ->2
 248 # 4        <@> print sK ->5
 249 # 2           <0> pushmark s ->3
 250 # 3           <$> const[IV 6] s/FOLD ->4
 251 EOT_EOT
 252 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 253 # -     <@> lineseq KP ->5
 254 # 1        <;> nextstate(main 937 (eval 53):1) v ->2
 255 # 4        <@> print sK ->5
 256 # 2           <0> pushmark s ->3
 257 # 3           <$> const(IV 6) s/FOLD ->4
 258 EONT_EONT
 259
 260 checkOptree ( name      => 'string constant folding in print',
 261               code      => 'print "foo"."bar"',
 262               strip_open_hints => 1,
 263               expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 264 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 265 # -     <@> lineseq KP ->5
 266 # 1        <;> nextstate(main 942 (eval 55):1) v ->2
 267 # 4        <@> print sK ->5
 268 # 2           <0> pushmark s ->3
 269 # 3           <$> const[PV "foobar"] s/FOLD ->4
 270 EOT_EOT
 271 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 272 # -     <@> lineseq KP ->5
 273 # 1        <;> nextstate(main 942 (eval 55):1) v ->2
 274 # 4        <@> print sK ->5
 275 # 2           <0> pushmark s ->3
 276 # 3           <$> const(PV "foobar") s/FOLD ->4
 277 EONT_EONT
 278
 279 checkOptree ( name      => 'boolean or folding',
 280               code      => 'print "foobar" if 1 or 0',
 281               strip_open_hints => 1,
 282               expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 283 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 284 # -     <@> lineseq KP ->5
 285 # 1        <;> nextstate(main 942 (eval 55):1) v ->2
 286 # 4        <@> print sK/FOLD ->5
 287 # 2           <0> pushmark s ->3
 288 # 3           <$> const[PV "foobar"] s ->4
 289 EOT_EOT
 290 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 291 # -     <@> lineseq KP ->5
 292 # 1        <;> nextstate(main 942 (eval 55):1) v ->2
 293 # 4        <@> print sK/FOLD ->5
 294 # 2           <0> pushmark s ->3
 295 # 3           <$> const(PV "foobar") s ->4
 296 EONT_EONT
 297
 298 checkOptree ( name      => 'lc*,uc*,gt,lt,ge,le,cmp',
 299               code      => sub {
 300                   $s = uc('foo.').ucfirst('bar.').lc('LOW.').lcfirst('LOW');
 301                   print "a-lt-b" if "a" lt "b";
 302                   print "b-gt-a" if "b" gt "a";
 303                   print "a-le-b" if "a" le "b";
 304                   print "b-ge-a" if "b" ge "a";
 305                   print "b-cmp-a" if "b" cmp "a";
 306                   print "a-gt-b" if "a" gt "b"; # should be suppressed
 307               },
 308               strip_open_hints => 1,
 309               expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 310 # r  <1> leavesub[1 ref] K/REFC,1 ->(end)
 311 # -     <@> lineseq KP ->r
 312 # 1        <;> nextstate(main 916 optree_constants.t:307) v:>,<,%,{ ->2
 313 # 4        <2> sassign vKS/2 ->5
 314 # 2           <$> const[PV "FOO.Bar.low.lOW"] s/FOLD ->3
 315 # -           <1> ex-rv2sv sKRM*/1 ->4
 316 # 3              <#> gvsv[*s] s ->4
 317 # 5        <;> nextstate(main 916 optree_constants.t:308) v:>,<,%,{ ->6
 318 # 8        <@> print vK/FOLD ->9
 319 # 6           <0> pushmark s ->7
 320 # 7           <$> const[PV "a-lt-b"] s ->8
 321 # 9        <;> nextstate(main 916 optree_constants.t:309) v:>,<,%,{ ->a
 322 # c        <@> print vK/FOLD ->d
 323 # a           <0> pushmark s ->b
 324 # b           <$> const[PV "b-gt-a"] s ->c
 325 # d        <;> nextstate(main 916 optree_constants.t:310) v:>,<,%,{ ->e
 326 # g        <@> print vK/FOLD ->h
 327 # e           <0> pushmark s ->f
 328 # f           <$> const[PV "a-le-b"] s ->g
 329 # h        <;> nextstate(main 916 optree_constants.t:311) v:>,<,%,{ ->i
 330 # k        <@> print vK/FOLD ->l
 331 # i           <0> pushmark s ->j
 332 # j           <$> const[PV "b-ge-a"] s ->k
 333 # l        <;> nextstate(main 916 optree_constants.t:312) v:>,<,%,{ ->m
 334 # o        <@> print vK/FOLD ->p
 335 # m           <0> pushmark s ->n
 336 # n           <$> const[PV "b-cmp-a"] s ->o
 337 # p        <;> nextstate(main 916 optree_constants.t:313) v:>,<,%,{ ->q
 338 # q        <$> const[SPECIAL sv_no] s/SHORT,FOLD ->r
 339 EOT_EOT
 340 # r  <1> leavesub[1 ref] K/REFC,1 ->(end)
 341 # -     <@> lineseq KP ->r
 342 # 1        <;> nextstate(main 916 optree_constants.t:307) v:>,<,%,{ ->2
 343 # 4        <2> sassign vKS/2 ->5
 344 # 2           <$> const(PV "FOO.Bar.low.lOW") s/FOLD ->3
 345 # -           <1> ex-rv2sv sKRM*/1 ->4
 346 # 3              <$> gvsv(*s) s ->4
 347 # 5        <;> nextstate(main 916 optree_constants.t:308) v:>,<,%,{ ->6
 348 # 8        <@> print vK/FOLD ->9
 349 # 6           <0> pushmark s ->7
 350 # 7           <$> const(PV "a-lt-b") s ->8
 351 # 9        <;> nextstate(main 916 optree_constants.t:309) v:>,<,%,{ ->a
 352 # c        <@> print vK/FOLD ->d
 353 # a           <0> pushmark s ->b
 354 # b           <$> const(PV "b-gt-a") s ->c
 355 # d        <;> nextstate(main 916 optree_constants.t:310) v:>,<,%,{ ->e
 356 # g        <@> print vK/FOLD ->h
 357 # e           <0> pushmark s ->f
 358 # f           <$> const(PV "a-le-b") s ->g
 359 # h        <;> nextstate(main 916 optree_constants.t:311) v:>,<,%,{ ->i
 360 # k        <@> print vK/FOLD ->l
 361 # i           <0> pushmark s ->j
 362 # j           <$> const(PV "b-ge-a") s ->k
 363 # l        <;> nextstate(main 916 optree_constants.t:312) v:>,<,%,{ ->m
 364 # o        <@> print vK/FOLD ->p
 365 # m           <0> pushmark s ->n
 366 # n           <$> const(PV "b-cmp-a") s ->o
 367 # p        <;> nextstate(main 916 optree_constants.t:313) v:>,<,%,{ ->q
 368 # q        <$> const(SPECIAL sv_no) s/SHORT,FOLD ->r
 369 EONT_EONT
 370
 371 checkOptree ( name      => 'mixed constant folding, with explicit braces',
 372               code      => 'print "foo"."bar".(2+3)',
 373               strip_open_hints => 1,
 374               expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 375 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 376 # -     <@> lineseq KP ->5
 377 # 1        <;> nextstate(main 977 (eval 28):1) v ->2
 378 # 4        <@> print sK ->5
 379 # 2           <0> pushmark s ->3
 380 # 3           <$> const[PV "foobar5"] s/FOLD ->4
 381 EOT_EOT
 382 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 383 # -     <@> lineseq KP ->5
 384 # 1        <;> nextstate(main 977 (eval 28):1) v ->2
 385 # 4        <@> print sK ->5
 386 # 2           <0> pushmark s ->3
 387 # 3           <$> const(PV "foobar5") s/FOLD ->4
 388 EONT_EONT
 389
 390 __END__
 391
 392 =head NB
 393
 394 Optimized constant subs are stored as bare scalars in the stash
 395 (package hash), which formerly held only GVs (typeglobs).
 396
 397 But you cant create them manually - you cant assign a scalar to a
 398 stash element, and expect it to work like a constant-sub, even if you
 399 provide a prototype.
 400
 401 This is a feature; alternative is too much action-at-a-distance.  The
 402 following test demonstrates - napier is not seen as a function at all,
 403 much less an optimized one.
 404
 405 =cut
 406
 407 checkOptree ( name      => 'not evertnapier',
 408               code      => \&napier,
 409               noanchors => 1,
 410               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 411  has no START
 412 EOT_EOT
 413  has no START
 414 EONT_EONT
 415
 416