ext/B/t/optree_constants.t

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