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