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 my @open_todo;
  28 sub open_todo {
  29     if (((caller 0)[10]||{})->{open}) {
  30         @open_todo = (skip => "\$^OPEN is set");
  31     }
  32 }
  33 open_todo;
  34
  35 #################################
  36
  37 use constant {          # see also t/op/gv.t line 282
  38     myaref      => [ 1,2,3 ],
  39     myfl        => 1.414213,
  40     myglob      => \*STDIN,
  41     myhref      => { a  => 1 },
  42     myint       => 42,
  43     myrex       => qr/foo/,
  44     mystr       => 'hithere',
  45     mysub       => \&ok,
  46     myundef     => undef,
  47     myunsub     => \&nosuch,
  48 };
  49
  50 sub myyes() { 1==1 }
  51 sub myno () { return 1!=1 }
  52 sub pi () { 3.14159 };
  53
  54 my $want = {    # expected types, how value renders in-line, todos (maybe)
  55     myfl        => [ 'NV', myfl ],
  56     myint       => [ 'IV', myint ],
  57     mystr       => [ 'PV', '"'.mystr.'"' ],
  58     myhref      => [ 'RV', '\\\\HASH'],
  59     myundef     => [ 'NULL', ],
  60     pi          => [ 'NV', pi ],
  61     myaref      => [ 'RV', '\\\\' ],
  62     myglob      => [ 'RV', '\\\\' ],
  63     myrex       => [ 'RV', '\\\\' ],
  64     mysub       => [ 'RV', '\\\\' ],
  65     myunsub     => [ 'RV', '\\\\' ],
  66     # these are not inlined, at least not per BC::Concise
  67     #myyes      => [ 'RV', ],
  68     #myno       => [ 'RV', ],
  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 1163 OptreeCheck.pm:511]: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 1163 OptreeCheck.pm:511]: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               code      => 'sub a() { 1==1 }; print a',
 138               noanchors => 1,
 139               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 140 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 141 # -     <@> lineseq KP ->5
 142 # 1        <;> nextstate(main 810 (eval 47):1) v ->2
 143 # 4        <@> print sK ->5
 144 # 2           <0> pushmark s ->3
 145 # 3           <$> const[SPECIAL sv_yes] s ->4
 146 EOT_EOT
 147 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 148 # -     <@> lineseq KP ->5
 149 # 1        <;> nextstate(main 810 (eval 47):1) v ->2
 150 # 4        <@> print sK ->5
 151 # 2           <0> pushmark s ->3
 152 # 3           <$> const(SPECIAL sv_yes) s ->4
 153 EONT_EONT
 154
 155
 156 checkOptree ( name      => 'myno() as coderef',
 157               code      => 'sub a() { 1!=1 }; print a',
 158               noanchors => 1,
 159               todo      => '- SPECIAL sv_no renders as PVNV 0',
 160               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 161 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 162 # -     <@> lineseq KP ->5
 163 # 1        <;> nextstate(main 810 (eval 47):1) v ->2
 164 # 4        <@> print sK ->5
 165 # 2           <0> pushmark s ->3
 166 # 3           <$> const[PVNV 0] s ->4
 167 EOT_EOT
 168 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 169 # -     <@> lineseq KP ->5
 170 # 1        <;> nextstate(main 810 (eval 47):1) v ->2
 171 # 4        <@> print sK ->5
 172 # 2           <0> pushmark s ->3
 173 # 3           <$> const(PVNV 0) s ->4
 174 EONT_EONT
 175
 176
 177 checkOptree ( name      => 'constant sub returning list',
 178               code      => \&WEEKDAYS,
 179               noanchors => 1,
 180               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 181 # 3  <1> leavesub[2 refs] K/REFC,1 ->(end)
 182 # -     <@> lineseq K ->3
 183 # 1        <;> nextstate(constant 61 constant.pm:118) v:*,& ->2
 184 # 2        <0> padav[@list:FAKE:m:96] ->3
 185 EOT_EOT
 186 # 3  <1> leavesub[2 refs] K/REFC,1 ->(end)
 187 # -     <@> lineseq K ->3
 188 # 1        <;> nextstate(constant 61 constant.pm:118) v:*,& ->2
 189 # 2        <0> padav[@list:FAKE:m:71] ->3
 190 EONT_EONT
 191
 192
 193 sub printem {
 194     printf "myint %d mystr %s myfl %f pi %f\n"
 195         , myint, mystr, myfl, pi;
 196 }
 197
 198 checkOptree ( name      => 'call many in a print statement',
 199               code      => \&printem,
 200               @open_todo,
 201               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 202 # 9  <1> leavesub[1 ref] K/REFC,1 ->(end)
 203 # -     <@> lineseq KP ->9
 204 # 1        <;> nextstate(main 635 optree_constants.t:163) v ->2
 205 # 8        <@> prtf sK ->9
 206 # 2           <0> pushmark s ->3
 207 # 3           <$> const[PV "myint %d mystr %s myfl %f pi %f\n"] s ->4
 208 # 4           <$> const[IV 42] s ->5
 209 # 5           <$> const[PV "hithere"] s ->6
 210 # 6           <$> const[NV 1.414213] s ->7
 211 # 7           <$> const[NV 3.14159] s ->8
 212 EOT_EOT
 213 # 9  <1> leavesub[1 ref] K/REFC,1 ->(end)
 214 # -     <@> lineseq KP ->9
 215 # 1        <;> nextstate(main 635 optree_constants.t:163) v ->2
 216 # 8        <@> prtf sK ->9
 217 # 2           <0> pushmark s ->3
 218 # 3           <$> const(PV "myint %d mystr %s myfl %f pi %f\n") s ->4
 219 # 4           <$> const(IV 42) s ->5
 220 # 5           <$> const(PV "hithere") s ->6
 221 # 6           <$> const(NV 1.414213) s ->7
 222 # 7           <$> const(NV 3.14159) s ->8
 223 EONT_EONT
 224
 225
 226 } #skip
 227
 228 __END__
 229
 230 =head NB
 231
 232 Optimized constant subs are stored as bare scalars in the stash
 233 (package hash), which formerly held only GVs (typeglobs).
 234
 235 But you cant create them manually - you cant assign a scalar to a
 236 stash element, and expect it to work like a constant-sub, even if you
 237 provide a prototype.
 238
 239 This is a feature; alternative is too much action-at-a-distance.  The
 240 following test demonstrates - napier is not seen as a function at all,
 241 much less an optimized one.
 242
 243 =cut
 244
 245 checkOptree ( name      => 'not evertnapier',
 246               code      => \&napier,
 247               noanchors => 1,
 248               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 249  has no START
 250 EOT_EOT
 251  has no START
 252 EONT_EONT
 253
 254