ext/B/t/optree_constants.t

   1 #!perl
   2
   3 BEGIN {
   4     if ($ENV{PERL_CORE}) {
   5         chdir('t') if -d 't';
   6         @INC = ('.', '../lib', '../ext/B/t');
   7     } else {
   8         unshift @INC, 't';
   9         push @INC, "../../t";
  10     }
  11     require Config;
  12     if (($Config::Config{'extensions'} !~ /\bB\b/) ){
  13         print "1..0 # Skip -- Perl configured without B module\n";
  14         exit 0;
  15     }
  16     # require 'test.pl'; # now done by OptreeCheck
  17 }
  18
  19 use OptreeCheck;        # ALSO DOES @ARGV HANDLING !!!!!!
  20 use Config;
  21
  22 my $tests = 30;
  23 plan tests => $tests;
  24 SKIP: {
  25 skip "no perlio in this build", $tests unless $Config::Config{useperlio};
  26
  27 #################################
  28
  29 use constant {          # see also t/op/gv.t line 282
  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 };
  41
  42 sub myyes() { 1==1 }
  43 sub myno () { return 1!=1 }
  44 sub pi () { 3.14159 };
  45
  46 my $want = {    # expected types, how value renders in-line, todos (maybe)
  47     myfl        => [ 'NV', myfl ],
  48     myint       => [ 'IV', myint ],
  49     mystr       => [ 'PV', '"'.mystr.'"' ],
  50     myhref      => [ 'RV', '\\\\HASH'],
  51     myundef     => [ 'NULL', ],
  52     pi          => [ 'NV', pi ],
  53     myaref      => [ 'RV', '\\\\' ],
  54     myglob      => [ 'RV', '\\\\' ],
  55     myrex       => [ 'RV', '\\\\' ],
  56     mysub       => [ 'RV', '\\\\' ],
  57     myunsub     => [ 'RV', '\\\\' ],
  58     # these are not inlined, at least not per BC::Concise
  59     #myyes      => [ 'RV', ],
  60     #myno       => [ 'RV', ],
  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
 106 EOT_EOT
 107 3  <1> leavesub[2 refs] K/REFC,1 ->(end)
 108 -     <\@> lineseq KP ->3
 109 1        <;> dbstate(main 833 (eval 44):1) v ->2
 110 2        <\$> const($want->{$func}[0] $want->{$func}[1]) s ->3
 111 EONT_EONT
 112
 113 }
 114
 115 ##############
 116 pass("MORE TESTS");
 117
 118 checkOptree ( name      => 'myyes() as coderef',
 119               code      => sub () { 1==1 },
 120               noanchors => 1,
 121               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 122  is a constant sub, optimized to a SPECIAL
 123 EOT_EOT
 124  is a constant sub, optimized to a SPECIAL
 125 EONT_EONT
 126
 127
 128 checkOptree ( name      => 'myyes() as coderef',
 129               code      => 'sub a() { 1==1 }; print a',
 130               noanchors => 1,
 131               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 132 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 133 # -     <@> lineseq KP ->5
 134 # 1        <;> nextstate(main 810 (eval 47):1) v ->2
 135 # 4        <@> print sK ->5
 136 # 2           <0> pushmark s ->3
 137 # 3           <$> const[SPECIAL sv_yes] s ->4
 138 EOT_EOT
 139 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 140 # -     <@> lineseq KP ->5
 141 # 1        <;> nextstate(main 810 (eval 47):1) v ->2
 142 # 4        <@> print sK ->5
 143 # 2           <0> pushmark s ->3
 144 # 3           <$> const(SPECIAL sv_yes) s ->4
 145 EONT_EONT
 146
 147
 148 checkOptree ( name      => 'myno() as coderef',
 149               code      => 'sub a() { 1!=1 }; print a',
 150               noanchors => 1,
 151               todo      => '- SPECIAL sv_no renders as PVNV 0',
 152               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 153 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 154 # -     <@> lineseq KP ->5
 155 # 1        <;> nextstate(main 810 (eval 47):1) v ->2
 156 # 4        <@> print sK ->5
 157 # 2           <0> pushmark s ->3
 158 # 3           <$> const[PVNV 0] s ->4
 159 EOT_EOT
 160 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 161 # -     <@> lineseq KP ->5
 162 # 1        <;> nextstate(main 810 (eval 47):1) v ->2
 163 # 4        <@> print sK ->5
 164 # 2           <0> pushmark s ->3
 165 # 3           <$> const(PVNV 0) s ->4
 166 EONT_EONT
 167
 168
 169 checkOptree ( name      => 'constant sub returning list',
 170               code      => \&WEEKDAYS,
 171               noanchors => 1,
 172               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 173 # 3  <1> leavesub[2 refs] K/REFC,1 ->(end)
 174 # -     <@> lineseq K ->3
 175 # 1        <;> nextstate(constant 61 constant.pm:118) v:*,& ->2
 176 # 2        <0> padav[@list:FAKE:m:96] ->3
 177 EOT_EOT
 178 # 3  <1> leavesub[2 refs] K/REFC,1 ->(end)
 179 # -     <@> lineseq K ->3
 180 # 1        <;> nextstate(constant 61 constant.pm:118) v:*,& ->2
 181 # 2        <0> padav[@list:FAKE:m:71] ->3
 182 EONT_EONT
 183
 184
 185 sub printem {
 186     printf "myint %d mystr %s myfl %f pi %f\n"
 187         , myint, mystr, myfl, pi;
 188 }
 189
 190 checkOptree ( name      => 'call many in a print statement',
 191               code      => \&printem,
 192               strip_open_hints => 1,
 193               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 194 # 9  <1> leavesub[1 ref] K/REFC,1 ->(end)
 195 # -     <@> lineseq KP ->9
 196 # 1        <;> nextstate(main 635 optree_constants.t:163) v:>,<,% ->2
 197 # 8        <@> prtf sK ->9
 198 # 2           <0> pushmark s ->3
 199 # 3           <$> const[PV "myint %d mystr %s myfl %f pi %f\n"] s ->4
 200 # 4           <$> const[IV 42] s ->5
 201 # 5           <$> const[PV "hithere"] s ->6
 202 # 6           <$> const[NV 1.414213] s ->7
 203 # 7           <$> const[NV 3.14159] s ->8
 204 EOT_EOT
 205 # 9  <1> leavesub[1 ref] K/REFC,1 ->(end)
 206 # -     <@> lineseq KP ->9
 207 # 1        <;> nextstate(main 635 optree_constants.t:163) v:>,<,% ->2
 208 # 8        <@> prtf sK ->9
 209 # 2           <0> pushmark s ->3
 210 # 3           <$> const(PV "myint %d mystr %s myfl %f pi %f\n") s ->4
 211 # 4           <$> const(IV 42) s ->5
 212 # 5           <$> const(PV "hithere") s ->6
 213 # 6           <$> const(NV 1.414213) s ->7
 214 # 7           <$> const(NV 3.14159) s ->8
 215 EONT_EONT
 216
 217
 218 } #skip
 219
 220 __END__
 221
 222 =head NB
 223
 224 Optimized constant subs are stored as bare scalars in the stash
 225 (package hash), which formerly held only GVs (typeglobs).
 226
 227 But you cant create them manually - you cant assign a scalar to a
 228 stash element, and expect it to work like a constant-sub, even if you
 229 provide a prototype.
 230
 231 This is a feature; alternative is too much action-at-a-distance.  The
 232 following test demonstrates - napier is not seen as a function at all,
 233 much less an optimized one.
 234
 235 =cut
 236
 237 checkOptree ( name      => 'not evertnapier',
 238               code      => \&napier,
 239               noanchors => 1,
 240               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 241  has no START
 242 EOT_EOT
 243  has no START
 244 EONT_EONT
 245
 246