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/FOLD ->4
 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 # 4           <$> const[IV 42] sM*/FOLD ->5          >=5.017002
 218 # 5           <$> const[PV "hithere"] sM*/FOLD ->6   >=5.017002
 219 # 6           <$> const[NV 1.414213] sM*/FOLD ->7    >=5.017002
 220 # 7           <$> const[NV 3.14159] sM*/FOLD ->8     >=5.017002
 221 EOT_EOT
 222 # 9  <1> leavesub[1 ref] K/REFC,1 ->(end)
 223 # -     <@> lineseq KP ->9
 224 # 1        <;> nextstate(main 635 optree_constants.t:163) v:>,<,% ->2
 225 # 8        <@> prtf sK ->9
 226 # 2           <0> pushmark sM ->3
 227 # 3           <$> const(PV "myint %d mystr %s myfl %f pi %f\n") sM/FOLD ->4
 228 # 4           <$> const(IV 42) sM* ->5          < 5.017002
 229 # 5           <$> const(PV "hithere") sM* ->6   < 5.017002
 230 # 6           <$> const(NV 1.414213) sM* ->7    < 5.017002
 231 # 7           <$> const(NV 3.14159) sM* ->8     < 5.017002
 232 # 4           <$> const(IV 42) sM*/FOLD ->5          >=5.017002
 233 # 5           <$> const(PV "hithere") sM*/FOLD ->6   >=5.017002
 234 # 6           <$> const(NV 1.414213) sM*/FOLD ->7    >=5.017002
 235 # 7           <$> const(NV 3.14159) sM*/FOLD ->8     >=5.017002
 236 EONT_EONT
 237
 238 if($] < 5.015) {
 239     s/M(?=\*? ->)//g for $expect, $expect_nt;
 240 }
 241 if($] < 5.017002 || $] >= 5.019004) {
 242     s|\\n"[])] sM\K/FOLD|| for $expect, $expect_nt;
 243 }
 244
 245 checkOptree ( name      => 'call many in a print statement',
 246               code      => \&printem,
 247               strip_open_hints => 1,
 248               expect => $expect, expect_nt => $expect_nt);
 249
 250 # test constant expression folding
 251
 252 checkOptree ( name      => 'arithmetic constant folding in print',
 253               code      => 'print 1+2+3',
 254               strip_open_hints => 1,
 255               expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 256 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 257 # -     <@> lineseq KP ->5
 258 # 1        <;> nextstate(main 937 (eval 53):1) v ->2
 259 # 4        <@> print sK ->5
 260 # 2           <0> pushmark s ->3
 261 # 3           <$> const[IV 6] s ->4      < 5.017002
 262 # 3           <$> const[IV 6] s/FOLD ->4 >=5.017002
 263 EOT_EOT
 264 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 265 # -     <@> lineseq KP ->5
 266 # 1        <;> nextstate(main 937 (eval 53):1) v ->2
 267 # 4        <@> print sK ->5
 268 # 2           <0> pushmark s ->3
 269 # 3           <$> const(IV 6) s ->4      < 5.017002
 270 # 3           <$> const(IV 6) s/FOLD ->4 >=5.017002
 271 EONT_EONT
 272
 273 checkOptree ( name      => 'string constant folding in print',
 274               code      => 'print "foo"."bar"',
 275               strip_open_hints => 1,
 276               expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 277 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 278 # -     <@> lineseq KP ->5
 279 # 1        <;> nextstate(main 942 (eval 55):1) v ->2
 280 # 4        <@> print sK ->5
 281 # 2           <0> pushmark s ->3
 282 # 3           <$> const[PV "foobar"] s ->4      < 5.017002
 283 # 3           <$> const[PV "foobar"] s/FOLD ->4 >=5.017002
 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 ->5
 289 # 2           <0> pushmark s ->3
 290 # 3           <$> const(PV "foobar") s ->4      < 5.017002
 291 # 3           <$> const(PV "foobar") s/FOLD ->4 >=5.017002
 292 EONT_EONT
 293
 294 checkOptree ( name      => 'boolean or folding',
 295               code      => 'print "foobar" if 1 or 0',
 296               strip_open_hints => 1,
 297               expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 298 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 299 # -     <@> lineseq KP ->5
 300 # 1        <;> nextstate(main 942 (eval 55):1) v ->2
 301 # 4        <@> print sK ->5      < 5.019004
 302 # 4        <@> print sK/FOLD ->5 >=5.019004
 303 # 2           <0> pushmark s ->3
 304 # 3           <$> const[PV "foobar"] s ->4
 305 EOT_EOT
 306 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 307 # -     <@> lineseq KP ->5
 308 # 1        <;> nextstate(main 942 (eval 55):1) v ->2
 309 # 4        <@> print sK ->5      < 5.019004
 310 # 4        <@> print sK/FOLD ->5 >=5.019004
 311 # 2           <0> pushmark s ->3
 312 # 3           <$> const(PV "foobar") s ->4
 313 EONT_EONT
 314
 315 checkOptree ( name      => 'lc*,uc*,gt,lt,ge,le,cmp',
 316               code      => sub {
 317                   $s = uc('foo.').ucfirst('bar.').lc('LOW.').lcfirst('LOW');
 318                   print "a-lt-b" if "a" lt "b";
 319                   print "b-gt-a" if "b" gt "a";
 320                   print "a-le-b" if "a" le "b";
 321                   print "b-ge-a" if "b" ge "a";
 322                   print "b-cmp-a" if "b" cmp "a";
 323                   print "a-gt-b" if "a" gt "b"; # should be suppressed
 324               },
 325               strip_open_hints => 1,
 326               expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 327 # r  <1> leavesub[1 ref] K/REFC,1 ->(end)
 328 # -     <@> lineseq KP ->r
 329 # 1        <;> nextstate(main 916 optree_constants.t:307) v:>,<,%,{ ->2
 330 # 4        <2> sassign vKS/2 ->5
 331 # 2           <$> const[PV "FOO.Bar.low.lOW"] s ->3      < 5.017002
 332 # 2           <$> const[PV "FOO.Bar.low.lOW"] s/FOLD ->3 >=5.017002
 333 # -           <1> ex-rv2sv sKRM*/1 ->4
 334 # 3              <#> gvsv[*s] s ->4
 335 # 5        <;> nextstate(main 916 optree_constants.t:308) v:>,<,%,{ ->6
 336 # 8        <@> print vK ->9      < 5.019004
 337 # 8        <@> print vK/FOLD ->9 >=5.019004
 338 # 6           <0> pushmark s ->7
 339 # 7           <$> const[PV "a-lt-b"] s ->8
 340 # 9        <;> nextstate(main 916 optree_constants.t:309) v:>,<,%,{ ->a
 341 # c        <@> print vK ->d      < 5.019004
 342 # c        <@> print vK/FOLD ->d >=5.019004
 343 # a           <0> pushmark s ->b
 344 # b           <$> const[PV "b-gt-a"] s ->c
 345 # d        <;> nextstate(main 916 optree_constants.t:310) v:>,<,%,{ ->e
 346 # g        <@> print vK ->h      < 5.019004
 347 # g        <@> print vK/FOLD ->h >=5.019004
 348 # e           <0> pushmark s ->f
 349 # f           <$> const[PV "a-le-b"] s ->g
 350 # h        <;> nextstate(main 916 optree_constants.t:311) v:>,<,%,{ ->i
 351 # k        <@> print vK ->l      < 5.019004
 352 # k        <@> print vK/FOLD ->l >=5.019004
 353 # i           <0> pushmark s ->j
 354 # j           <$> const[PV "b-ge-a"] s ->k
 355 # l        <;> nextstate(main 916 optree_constants.t:312) v:>,<,%,{ ->m
 356 # o        <@> print vK ->p      < 5.019004
 357 # o        <@> print vK/FOLD ->p >=5.019004
 358 # m           <0> pushmark s ->n
 359 # n           <$> const[PV "b-cmp-a"] s ->o
 360 # p        <;> nextstate(main 916 optree_constants.t:313) v:>,<,%,{ ->q
 361 # q        <$> const[PVNV 0] s/SHORT ->r      < 5.017002
 362 # q        <$> const[PVNV 0] s/FOLD,SHORT ->r >=5.017002 < 5.019003
 363 # q        <$> const[SPECIAL sv_no] s/SHORT,FOLD ->r >=5.019003
 364 EOT_EOT
 365 # r  <1> leavesub[1 ref] K/REFC,1 ->(end)
 366 # -     <@> lineseq KP ->r
 367 # 1        <;> nextstate(main 916 optree_constants.t:307) v:>,<,%,{ ->2
 368 # 4        <2> sassign vKS/2 ->5
 369 # 2           <$> const(PV "FOO.Bar.low.lOW") s ->3      < 5.017002
 370 # 2           <$> const(PV "FOO.Bar.low.lOW") s/FOLD ->3 >=5.017002
 371 # -           <1> ex-rv2sv sKRM*/1 ->4
 372 # 3              <$> gvsv(*s) s ->4
 373 # 5        <;> nextstate(main 916 optree_constants.t:308) v:>,<,%,{ ->6
 374 # 8        <@> print vK ->9      < 5.019004
 375 # 8        <@> print vK/FOLD ->9 >=5.019004
 376 # 6           <0> pushmark s ->7
 377 # 7           <$> const(PV "a-lt-b") s ->8
 378 # 9        <;> nextstate(main 916 optree_constants.t:309) v:>,<,%,{ ->a
 379 # c        <@> print vK ->d      < 5.019004
 380 # c        <@> print vK/FOLD ->d >=5.019004
 381 # a           <0> pushmark s ->b
 382 # b           <$> const(PV "b-gt-a") s ->c
 383 # d        <;> nextstate(main 916 optree_constants.t:310) v:>,<,%,{ ->e
 384 # g        <@> print vK ->h      < 5.019004
 385 # g        <@> print vK/FOLD ->h >=5.019004
 386 # e           <0> pushmark s ->f
 387 # f           <$> const(PV "a-le-b") s ->g
 388 # h        <;> nextstate(main 916 optree_constants.t:311) v:>,<,%,{ ->i
 389 # k        <@> print vK ->l      < 5.019004
 390 # k        <@> print vK/FOLD ->l >=5.019004
 391 # i           <0> pushmark s ->j
 392 # j           <$> const(PV "b-ge-a") s ->k
 393 # l        <;> nextstate(main 916 optree_constants.t:312) v:>,<,%,{ ->m
 394 # o        <@> print vK ->p      < 5.019004
 395 # o        <@> print vK/FOLD ->p >=5.019004
 396 # m           <0> pushmark s ->n
 397 # n           <$> const(PV "b-cmp-a") s ->o
 398 # p        <;> nextstate(main 916 optree_constants.t:313) v:>,<,%,{ ->q
 399 # q        <$> const(SPECIAL sv_no) s/SHORT ->r      < 5.017002
 400 # q        <$> const(SPECIAL sv_no) s/SHORT,FOLD ->r >=5.017002
 401 EONT_EONT
 402
 403 checkOptree ( name      => 'mixed constant folding, with explicit braces',
 404               code      => 'print "foo"."bar".(2+3)',
 405               strip_open_hints => 1,
 406               expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 407 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 408 # -     <@> lineseq KP ->5
 409 # 1        <;> nextstate(main 977 (eval 28):1) v ->2
 410 # 4        <@> print sK ->5
 411 # 2           <0> pushmark s ->3
 412 # 3           <$> const[PV "foobar5"] s ->4      < 5.017002
 413 # 3           <$> const[PV "foobar5"] s/FOLD ->4 >=5.017002
 414 EOT_EOT
 415 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 416 # -     <@> lineseq KP ->5
 417 # 1        <;> nextstate(main 977 (eval 28):1) v ->2
 418 # 4        <@> print sK ->5
 419 # 2           <0> pushmark s ->3
 420 # 3           <$> const(PV "foobar5") s ->4      < 5.017002
 421 # 3           <$> const(PV "foobar5") s/FOLD ->4 >=5.017002
 422 EONT_EONT
 423
 424 __END__
 425
 426 =head NB
 427
 428 Optimized constant subs are stored as bare scalars in the stash
 429 (package hash), which formerly held only GVs (typeglobs).
 430
 431 But you cant create them manually - you cant assign a scalar to a
 432 stash element, and expect it to work like a constant-sub, even if you
 433 provide a prototype.
 434
 435 This is a feature; alternative is too much action-at-a-distance.  The
 436 following test demonstrates - napier is not seen as a function at all,
 437 much less an optimized one.
 438
 439 =cut
 440
 441 checkOptree ( name      => 'not evertnapier',
 442               code      => \&napier,
 443               noanchors => 1,
 444               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 445  has no START
 446 EOT_EOT
 447  has no START
 448 EONT_EONT
 449
 450