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     # these have todos, since they render as a bare backslash
  62     myaref      => [ 'RV', '\\\\', ' - should render as \\ARRAY' ],
  63     myglob      => [ 'RV', '\\\\', ' - should render as \\GV' ],
  64     myrex       => [ 'RV', '\\\\', ' - should render as ??' ],
  65     mysub       => [ 'RV', '\\\\', ' - should render as \\CV' ],
  66     myunsub     => [ 'RV', '\\\\', ' - should render as \\CV' ],
  67     # these are not inlined, at least not per BC::Concise
  68     #myyes      => [ 'RV', ],
  69     #myno       => [ 'RV', ],
  70 };
  71
  72 use constant WEEKDAYS
  73     => qw ( Sunday Monday Tuesday Wednesday Thursday Friday Saturday );
  74
  75
  76 $::{napier} = \2.71828; # counter-example (doesn't get optimized).
  77 eval "sub napier ();";
  78
  79
  80 # should be able to undefine constant::import here ???
  81 INIT {
  82     # eval 'sub constant::import () {}';
  83     # undef *constant::import::{CODE};
  84 };
  85
  86 #################################
  87 pass("RENDER CONSTANT SUBS RETURNING SCALARS");
  88
  89 for $func (sort keys %$want) {
  90     # no strict 'refs'; # why not needed ?
  91     checkOptree ( name      => "$func() as a coderef",
  92                   code      => \&{$func},
  93                   noanchors => 1,
  94                   expect    => <<EOT_EOT, expect_nt => <<EONT_EONT);
  95  is a constant sub, optimized to a $want->{$func}[0]
  96 EOT_EOT
  97  is a constant sub, optimized to a $want->{$func}[0]
  98 EONT_EONT
  99
 100 }
 101
 102 pass("RENDER CALLS TO THOSE CONSTANT SUBS");
 103
 104 for $func (sort keys %$want) {
 105     # print "# doing $func\n";
 106     checkOptree ( name    => "call $func",
 107                   code    => "$func",
 108                   ($want->{$func}[2]) ? ( todo => $want->{$func}[2]) : (),
 109                   bc_opts => '-nobanner',
 110                   expect  => <<EOT_EOT, expect_nt => <<EONT_EONT);
 111 3  <1> leavesub[2 refs] K/REFC,1 ->(end)
 112 -     <\@> lineseq KP ->3
 113 1        <;> dbstate(main 1163 OptreeCheck.pm:511]:1) v ->2
 114 2        <\$> const[$want->{$func}[0] $want->{$func}[1]] s ->3
 115 EOT_EOT
 116 3  <1> leavesub[2 refs] K/REFC,1 ->(end)
 117 -     <\@> lineseq KP ->3
 118 1        <;> dbstate(main 1163 OptreeCheck.pm:511]:1) v ->2
 119 2        <\$> const($want->{$func}[0] $want->{$func}[1]) s ->3
 120 EONT_EONT
 121
 122 }
 123
 124 ##############
 125 pass("MORE TESTS");
 126
 127 checkOptree ( name      => 'myyes() as coderef',
 128               code      => sub () { 1==1 },
 129               noanchors => 1,
 130               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 131  is a constant sub, optimized to a SPECIAL
 132 EOT_EOT
 133  is a constant sub, optimized to a SPECIAL
 134 EONT_EONT
 135
 136
 137 checkOptree ( name      => 'myyes() as coderef',
 138               code      => 'sub a() { 1==1 }; print a',
 139               noanchors => 1,
 140               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 141 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 142 # -     <@> lineseq KP ->5
 143 # 1        <;> nextstate(main 810 (eval 47):1) v ->2
 144 # 4        <@> print sK ->5
 145 # 2           <0> pushmark s ->3
 146 # 3           <$> const[SPECIAL sv_yes] s ->4
 147 EOT_EOT
 148 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 149 # -     <@> lineseq KP ->5
 150 # 1        <;> nextstate(main 810 (eval 47):1) v ->2
 151 # 4        <@> print sK ->5
 152 # 2           <0> pushmark s ->3
 153 # 3           <$> const(SPECIAL sv_yes) s ->4
 154 EONT_EONT
 155
 156
 157 checkOptree ( name      => 'myno() as coderef',
 158               code      => 'sub a() { 1!=1 }; print a',
 159               noanchors => 1,
 160               todo      => '- SPECIAL sv_no renders as PVNV 0',
 161               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 162 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 163 # -     <@> lineseq KP ->5
 164 # 1        <;> nextstate(main 810 (eval 47):1) v ->2
 165 # 4        <@> print sK ->5
 166 # 2           <0> pushmark s ->3
 167 # 3           <$> const[PVNV 0] s ->4
 168 EOT_EOT
 169 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 170 # -     <@> lineseq KP ->5
 171 # 1        <;> nextstate(main 810 (eval 47):1) v ->2
 172 # 4        <@> print sK ->5
 173 # 2           <0> pushmark s ->3
 174 # 3           <$> const(PVNV 0) s ->4
 175 EONT_EONT
 176
 177
 178 checkOptree ( name      => 'constant sub returning list',
 179               code      => \&WEEKDAYS,
 180               noanchors => 1,
 181               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 182 # 3  <1> leavesub[2 refs] K/REFC,1 ->(end)
 183 # -     <@> lineseq K ->3
 184 # 1        <;> nextstate(constant 685 constant.pm:121) v:*,& ->2
 185 # 2        <0> padav[@list:FAKE:m:102] ->3
 186 EOT_EOT
 187 # 3  <1> leavesub[2 refs] K/REFC,1 ->(end)
 188 # -     <@> lineseq K ->3
 189 # 1        <;> nextstate(constant 685 constant.pm:121) v:*,& ->2
 190 # 2        <0> padav[@list:FAKE:m:76] ->3
 191 EONT_EONT
 192
 193
 194 sub printem {
 195     printf "myint %d mystr %s myfl %f pi %f\n"
 196         , myint, mystr, myfl, pi;
 197 }
 198
 199 checkOptree ( name      => 'call many in a print statement',
 200               code      => \&printem,
 201               @open_todo,
 202               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 203 # 9  <1> leavesub[1 ref] K/REFC,1 ->(end)
 204 # -     <@> lineseq KP ->9
 205 # 1        <;> nextstate(main 635 optree_constants.t:163) v ->2
 206 # 8        <@> prtf sK ->9
 207 # 2           <0> pushmark s ->3
 208 # 3           <$> const[PV "myint %d mystr %s myfl %f pi %f\n"] s ->4
 209 # 4           <$> const[IV 42] s ->5
 210 # 5           <$> const[PV "hithere"] s ->6
 211 # 6           <$> const[NV 1.414213] s ->7
 212 # 7           <$> const[NV 3.14159] s ->8
 213 EOT_EOT
 214 # 9  <1> leavesub[1 ref] K/REFC,1 ->(end)
 215 # -     <@> lineseq KP ->9
 216 # 1        <;> nextstate(main 635 optree_constants.t:163) v ->2
 217 # 8        <@> prtf sK ->9
 218 # 2           <0> pushmark s ->3
 219 # 3           <$> const(PV "myint %d mystr %s myfl %f pi %f\n") s ->4
 220 # 4           <$> const(IV 42) s ->5
 221 # 5           <$> const(PV "hithere") s ->6
 222 # 6           <$> const(NV 1.414213) s ->7
 223 # 7           <$> const(NV 3.14159) s ->8
 224 EONT_EONT
 225
 226
 227 } #skip
 228
 229 __END__
 230
 231 =head NB
 232
 233 Optimized constant subs are stored as bare scalars in the stash
 234 (package hash), which formerly held only GVs (typeglobs).
 235
 236 But you cant create them manually - you cant assign a scalar to a
 237 stash element, and expect it to work like a constant-sub, even if you
 238 provide a prototype.
 239
 240 This is a feature; alternative is too much action-at-a-distance.  The
 241 following test demonstrates - napier is not seen as a function at all,
 242 much less an optimized one.
 243
 244 =cut
 245
 246 checkOptree ( name      => 'not evertnapier',
 247               code      => \&napier,
 248               noanchors => 1,
 249               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 250  has no START
 251 EOT_EOT
 252  has no START
 253 EONT_EONT
 254
 255