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               prog      => 'sub a() { 1==1 }; print a',
 130               noanchors => 1,
 131               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 132 # 6  <@> leave[1 ref] vKP/REFC ->(end)
 133 # 1     <0> enter ->2
 134 # 2     <;> nextstate(main 2 -e:1) v:{ ->3
 135 # 5     <@> print vK ->6
 136 # 3        <0> pushmark s ->4
 137 # 4        <$> const[SPECIAL sv_yes] s ->5
 138 EOT_EOT
 139 # 6  <@> leave[1 ref] vKP/REFC ->(end)
 140 # 1     <0> enter ->2
 141 # 2     <;> nextstate(main 2 -e:1) v:{ ->3
 142 # 5     <@> print vK ->6
 143 # 3        <0> pushmark s ->4
 144 # 4        <$> const(SPECIAL sv_yes) s ->5
 145 EONT_EONT
 146
 147
 148 # Need to do this as a prog, not code, as only the first constant to use
 149 # PL_sv_no actually gets to use the real thing - every one following is
 150 # copied.
 151 checkOptree ( name      => 'myno() as coderef',
 152               prog      => 'sub a() { 1!=1 }; print a',
 153               noanchors => 1,
 154               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 155 # 6  <@> leave[1 ref] vKP/REFC ->(end)
 156 # 1     <0> enter ->2
 157 # 2     <;> nextstate(main 2 -e:1) v:{ ->3
 158 # 5     <@> print vK ->6
 159 # 3        <0> pushmark s ->4
 160 # 4        <$> const[SPECIAL sv_no] s ->5
 161 EOT_EOT
 162 # 6  <@> leave[1 ref] vKP/REFC ->(end)
 163 # 1     <0> enter ->2
 164 # 2     <;> nextstate(main 2 -e:1) v:{ ->3
 165 # 5     <@> print vK ->6
 166 # 3        <0> pushmark s ->4
 167 # 4        <$> const(SPECIAL sv_no) s ->5
 168 EONT_EONT
 169
 170
 171 checkOptree ( name      => 'constant sub returning list',
 172               code      => \&WEEKDAYS,
 173               noanchors => 1,
 174               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 175 # 3  <1> leavesub[2 refs] K/REFC,1 ->(end)
 176 # -     <@> lineseq K ->3
 177 # 1        <;> nextstate(constant 61 constant.pm:118) v:*,& ->2
 178 # 2        <0> padav[@list:FAKE:m:96] ->3
 179 EOT_EOT
 180 # 3  <1> leavesub[2 refs] K/REFC,1 ->(end)
 181 # -     <@> lineseq K ->3
 182 # 1        <;> nextstate(constant 61 constant.pm:118) v:*,& ->2
 183 # 2        <0> padav[@list:FAKE:m:71] ->3
 184 EONT_EONT
 185
 186
 187 sub printem {
 188     printf "myint %d mystr %s myfl %f pi %f\n"
 189         , myint, mystr, myfl, pi;
 190 }
 191
 192 checkOptree ( name      => 'call many in a print statement',
 193               code      => \&printem,
 194               strip_open_hints => 1,
 195               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 196 # 9  <1> leavesub[1 ref] K/REFC,1 ->(end)
 197 # -     <@> lineseq KP ->9
 198 # 1        <;> nextstate(main 635 optree_constants.t:163) v:>,<,% ->2
 199 # 8        <@> prtf sK ->9
 200 # 2           <0> pushmark s ->3
 201 # 3           <$> const[PV "myint %d mystr %s myfl %f pi %f\n"] s ->4
 202 # 4           <$> const[IV 42] s ->5
 203 # 5           <$> const[PV "hithere"] s ->6
 204 # 6           <$> const[NV 1.414213] s ->7
 205 # 7           <$> const[NV 3.14159] s ->8
 206 EOT_EOT
 207 # 9  <1> leavesub[1 ref] K/REFC,1 ->(end)
 208 # -     <@> lineseq KP ->9
 209 # 1        <;> nextstate(main 635 optree_constants.t:163) v:>,<,% ->2
 210 # 8        <@> prtf sK ->9
 211 # 2           <0> pushmark s ->3
 212 # 3           <$> const(PV "myint %d mystr %s myfl %f pi %f\n") s ->4
 213 # 4           <$> const(IV 42) s ->5
 214 # 5           <$> const(PV "hithere") s ->6
 215 # 6           <$> const(NV 1.414213) s ->7
 216 # 7           <$> const(NV 3.14159) s ->8
 217 EONT_EONT
 218
 219
 220 } #skip
 221
 222 __END__
 223
 224 =head NB
 225
 226 Optimized constant subs are stored as bare scalars in the stash
 227 (package hash), which formerly held only GVs (typeglobs).
 228
 229 But you cant create them manually - you cant assign a scalar to a
 230 stash element, and expect it to work like a constant-sub, even if you
 231 provide a prototype.
 232
 233 This is a feature; alternative is too much action-at-a-distance.  The
 234 following test demonstrates - napier is not seen as a function at all,
 235 much less an optimized one.
 236
 237 =cut
 238
 239 checkOptree ( name      => 'not evertnapier',
 240               code      => \&napier,
 241               noanchors => 1,
 242               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 243  has no START
 244 EOT_EOT
 245  has no START
 246 EONT_EONT
 247
 248