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