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