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 s ->3
 215 # 3           <$> const[PV "myint %d mystr %s myfl %f pi %f\n"] s ->4
 216 # 4           <$> const[IV 42] s* ->5
 217 # 5           <$> const[PV "hithere"] s* ->6
 218 # 6           <$> const[NV 1.414213] s* ->7
 219 # 7           <$> const[NV 3.14159] s* ->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 s ->3
 226 # 3           <$> const(PV "myint %d mystr %s myfl %f pi %f\n") s ->4
 227 # 4           <$> const(IV 42) s* ->5
 228 # 5           <$> const(PV "hithere") s* ->6
 229 # 6           <$> const(NV 1.414213) s* ->7
 230 # 7           <$> const(NV 3.14159) s* ->8
 231 EONT_EONT
 232
 233 if($] < 5.009) {
 234     # 5.8.x's use constant has larger types
 235     foreach ($expect, $expect_nt) {
 236         s/IV 42/PV$&/;
 237         s/NV 1.41/PV$&/;
 238     }
 239 }
 240
 241 checkOptree ( name      => 'call many in a print statement',
 242               code      => \&printem,
 243               strip_open_hints => 1,
 244               expect => $expect, expect_nt => $expect_nt);
 245
 246 # test constant expression folding
 247
 248 checkOptree ( name      => 'arithmetic constant folding in print',
 249               code      => 'print 1+2+3',
 250               strip_open_hints => 1,
 251               expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 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 ->4
 258 EOT_EOT
 259 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 260 # -     <@> lineseq KP ->5
 261 # 1        <;> nextstate(main 937 (eval 53):1) v ->2
 262 # 4        <@> print sK ->5
 263 # 2           <0> pushmark s ->3
 264 # 3           <$> const(IV 6) s ->4
 265 EONT_EONT
 266
 267 checkOptree ( name      => 'string constant folding in print',
 268               code      => 'print "foo"."bar"',
 269               strip_open_hints => 1,
 270               expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 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 ->4
 277 EOT_EOT
 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 ->5
 282 # 2           <0> pushmark s ->3
 283 # 3           <$> const(PV "foobar") s ->4
 284 EONT_EONT
 285
 286 checkOptree ( name      => 'boolean or folding',
 287               code      => 'print "foobar" if 1 or 0',
 288               strip_open_hints => 1,
 289               expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 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 ->5
 294 # 2           <0> pushmark s ->3
 295 # 3           <$> const[PV "foobar"] s ->4
 296 EOT_EOT
 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 EONT_EONT
 304
 305 checkOptree ( name      => 'lc*,uc*,gt,lt,ge,le,cmp',
 306               code      => sub {
 307                   $s = uc('foo.').ucfirst('bar.').lc('LOW.').lcfirst('LOW');
 308                   print "a-lt-b" if "a" lt "b";
 309                   print "b-gt-a" if "b" gt "a";
 310                   print "a-le-b" if "a" le "b";
 311                   print "b-ge-a" if "b" ge "a";
 312                   print "b-cmp-a" if "b" cmp "a";
 313                   print "a-gt-b" if "a" gt "b"; # should be suppressed
 314               },
 315               strip_open_hints => 1,
 316               expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 317 # r  <1> leavesub[1 ref] K/REFC,1 ->(end)
 318 # -     <@> lineseq KP ->r
 319 # 1        <;> nextstate(main 916 optree_constants.t:307) v:>,<,%,{ ->2
 320 # 4        <2> sassign vKS/2 ->5
 321 # 2           <$> const[PV "FOO.Bar.low.lOW"] s ->3
 322 # -           <1> ex-rv2sv sKRM*/1 ->4
 323 # 3              <#> gvsv[*s] s ->4
 324 # 5        <;> nextstate(main 916 optree_constants.t:308) v:>,<,%,{ ->6
 325 # 8        <@> print vK ->9
 326 # 6           <0> pushmark s ->7
 327 # 7           <$> const[PV "a-lt-b"] s ->8
 328 # 9        <;> nextstate(main 916 optree_constants.t:309) v:>,<,%,{ ->a
 329 # c        <@> print vK ->d
 330 # a           <0> pushmark s ->b
 331 # b           <$> const[PV "b-gt-a"] s ->c
 332 # d        <;> nextstate(main 916 optree_constants.t:310) v:>,<,%,{ ->e
 333 # g        <@> print vK ->h
 334 # e           <0> pushmark s ->f
 335 # f           <$> const[PV "a-le-b"] s ->g
 336 # h        <;> nextstate(main 916 optree_constants.t:311) v:>,<,%,{ ->i
 337 # k        <@> print vK ->l
 338 # i           <0> pushmark s ->j
 339 # j           <$> const[PV "b-ge-a"] s ->k
 340 # l        <;> nextstate(main 916 optree_constants.t:312) v:>,<,%,{ ->m
 341 # o        <@> print vK ->p
 342 # m           <0> pushmark s ->n
 343 # n           <$> const[PV "b-cmp-a"] s ->o
 344 # p        <;> nextstate(main 916 optree_constants.t:313) v:>,<,%,{ ->q
 345 # q        <$> const[PVNV 0] s/SHORT ->r
 346 EOT_EOT
 347 # r  <1> leavesub[1 ref] K/REFC,1 ->(end)
 348 # -     <@> lineseq KP ->r
 349 # 1        <;> nextstate(main 916 optree_constants.t:307) v:>,<,%,{ ->2
 350 # 4        <2> sassign vKS/2 ->5
 351 # 2           <$> const(PV "FOO.Bar.low.lOW") s ->3
 352 # -           <1> ex-rv2sv sKRM*/1 ->4
 353 # 3              <$> gvsv(*s) s ->4
 354 # 5        <;> nextstate(main 916 optree_constants.t:308) v:>,<,%,{ ->6
 355 # 8        <@> print vK ->9
 356 # 6           <0> pushmark s ->7
 357 # 7           <$> const(PV "a-lt-b") s ->8
 358 # 9        <;> nextstate(main 916 optree_constants.t:309) v:>,<,%,{ ->a
 359 # c        <@> print vK ->d
 360 # a           <0> pushmark s ->b
 361 # b           <$> const(PV "b-gt-a") s ->c
 362 # d        <;> nextstate(main 916 optree_constants.t:310) v:>,<,%,{ ->e
 363 # g        <@> print vK ->h
 364 # e           <0> pushmark s ->f
 365 # f           <$> const(PV "a-le-b") s ->g
 366 # h        <;> nextstate(main 916 optree_constants.t:311) v:>,<,%,{ ->i
 367 # k        <@> print vK ->l
 368 # i           <0> pushmark s ->j
 369 # j           <$> const(PV "b-ge-a") s ->k
 370 # l        <;> nextstate(main 916 optree_constants.t:312) v:>,<,%,{ ->m
 371 # o        <@> print vK ->p
 372 # m           <0> pushmark s ->n
 373 # n           <$> const(PV "b-cmp-a") s ->o
 374 # p        <;> nextstate(main 916 optree_constants.t:313) v:>,<,%,{ ->q
 375 # q        <$> const(SPECIAL sv_no) s/SHORT ->r
 376 EONT_EONT
 377
 378 checkOptree ( name      => 'mixed constant folding, with explicit braces',
 379               code      => 'print "foo"."bar".(2+3)',
 380               strip_open_hints => 1,
 381               expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 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 ->4
 388 EOT_EOT
 389 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 390 # -     <@> lineseq KP ->5
 391 # 1        <;> nextstate(main 977 (eval 28):1) v ->2
 392 # 4        <@> print sK ->5
 393 # 2           <0> pushmark s ->3
 394 # 3           <$> const(PV "foobar5") s ->4
 395 EONT_EONT
 396
 397 __END__
 398
 399 =head NB
 400
 401 Optimized constant subs are stored as bare scalars in the stash
 402 (package hash), which formerly held only GVs (typeglobs).
 403
 404 But you cant create them manually - you cant assign a scalar to a
 405 stash element, and expect it to work like a constant-sub, even if you
 406 provide a prototype.
 407
 408 This is a feature; alternative is too much action-at-a-distance.  The
 409 following test demonstrates - napier is not seen as a function at all,
 410 much less an optimized one.
 411
 412 =cut
 413
 414 checkOptree ( name      => 'not evertnapier',
 415               code      => \&napier,
 416               noanchors => 1,
 417               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 418  has no START
 419 EOT_EOT
 420  has no START
 421 EONT_EONT
 422
 423