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