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     # these have todos, since they render as a bare backslash
  54     myaref      => [ 'RV', '\\\\', ' - should render as \\ARRAY' ],
  55     myglob      => [ 'RV', '\\\\', ' - should render as \\GV' ],
  56     myrex       => [ 'RV', '\\\\', ' - should render as ??' ],
  57     mysub       => [ 'RV', '\\\\', ' - should render as \\CV' ],
  58     myunsub     => [ 'RV', '\\\\', ' - should render as \\CV' ],
  59     # these are not inlined, at least not per BC::Concise
  60     #myyes      => [ 'RV', ],
  61     #myno       => [ 'RV', ],
  62 };
  63
  64 use constant WEEKDAYS
  65     => qw ( Sunday Monday Tuesday Wednesday Thursday Friday Saturday );
  66
  67
  68 $::{napier} = \2.71828; # counter-example (doesn't get optimized).
  69 eval "sub napier ();";
  70
  71
  72 # should be able to undefine constant::import here ???
  73 INIT {
  74     # eval 'sub constant::import () {}';
  75     # undef *constant::import::{CODE};
  76 };
  77
  78 #################################
  79 pass("RENDER CONSTANT SUBS RETURNING SCALARS");
  80
  81 for $func (sort keys %$want) {
  82     # no strict 'refs'; # why not needed ?
  83     checkOptree ( name      => "$func() as a coderef",
  84                   code      => \&{$func},
  85                   noanchors => 1,
  86                   expect    => <<EOT_EOT, expect_nt => <<EONT_EONT);
  87  is a constant sub, optimized to a $want->{$func}[0]
  88 EOT_EOT
  89  is a constant sub, optimized to a $want->{$func}[0]
  90 EONT_EONT
  91
  92 }
  93
  94 pass("RENDER CALLS TO THOSE CONSTANT SUBS");
  95
  96 for $func (sort keys %$want) {
  97     # print "# doing $func\n";
  98     checkOptree ( name    => "call $func",
  99                   code    => "$func",
 100                   ($want->{$func}[2]) ? ( todo => $want->{$func}[2]) : (),
 101                   bc_opts => '-nobanner',
 102                   expect  => <<EOT_EOT, expect_nt => <<EONT_EONT);
 103 3  <1> leavesub[2 refs] K/REFC,1 ->(end)
 104 -     <\@> lineseq KP ->3
 105 1        <;> dbstate(main 1163 OptreeCheck.pm:511]:1) v ->2
 106 2        <\$> const[$want->{$func}[0] $want->{$func}[1]] s ->3
 107 EOT_EOT
 108 3  <1> leavesub[2 refs] K/REFC,1 ->(end)
 109 -     <\@> lineseq KP ->3
 110 1        <;> dbstate(main 1163 OptreeCheck.pm:511]:1) v ->2
 111 2        <\$> const($want->{$func}[0] $want->{$func}[1]) s ->3
 112 EONT_EONT
 113
 114 }
 115
 116 ##############
 117 pass("MORE TESTS");
 118
 119 checkOptree ( name      => 'myyes() as coderef',
 120               code      => sub () { 1==1 },
 121               noanchors => 1,
 122               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 123  is a constant sub, optimized to a SPECIAL
 124 EOT_EOT
 125  is a constant sub, optimized to a SPECIAL
 126 EONT_EONT
 127
 128
 129 checkOptree ( name      => 'myyes() as coderef',
 130               code      => 'sub a() { 1==1 }; print a',
 131               noanchors => 1,
 132               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 133 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 134 # -     <@> lineseq KP ->5
 135 # 1        <;> nextstate(main 810 (eval 47):1) v ->2
 136 # 4        <@> print sK ->5
 137 # 2           <0> pushmark s ->3
 138 # 3           <$> const[SPECIAL sv_yes] s ->4
 139 EOT_EOT
 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 EONT_EONT
 147
 148
 149 checkOptree ( name      => 'myno() as coderef',
 150               code      => 'sub a() { 1!=1 }; print a',
 151               noanchors => 1,
 152               todo      => '- SPECIAL sv_no renders as PVNV 0',
 153               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 154 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
 155 # -     <@> lineseq KP ->5
 156 # 1        <;> nextstate(main 810 (eval 47):1) v ->2
 157 # 4        <@> print sK ->5
 158 # 2           <0> pushmark s ->3
 159 # 3           <$> const[PVNV 0] s ->4
 160 EOT_EOT
 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 EONT_EONT
 168
 169
 170 checkOptree ( name      => 'constant sub returning list',
 171               code      => \&WEEKDAYS,
 172               noanchors => 1,
 173               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 174 # 3  <1> leavesub[2 refs] K/REFC,1 ->(end)
 175 # -     <@> lineseq K ->3
 176 # 1        <;> nextstate(constant 685 constant.pm:121) v ->2
 177 # 2        <0> padav[@list:FAKE:m:102] ->3
 178 EOT_EOT
 179 # 3  <1> leavesub[2 refs] K/REFC,1 ->(end)
 180 # -     <@> lineseq K ->3
 181 # 1        <;> nextstate(constant 685 constant.pm:121) v ->2
 182 # 2        <0> padav[@list:FAKE:m:76] ->3
 183 EONT_EONT
 184
 185
 186 sub printem {
 187     printf "myint %d mystr %s myfl %f pi %f\n"
 188         , myint, mystr, myfl, pi;
 189 }
 190
 191 checkOptree ( name      => 'call many in a print statement',
 192               code      => \&printem,
 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