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