1#!perl 2 3BEGIN { 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 19use OptreeCheck; # ALSO DOES @ARGV HANDLING !!!!!! 20use Config; 21 22my $tests = 30; 23plan tests => $tests; 24SKIP: { 25skip "no perlio in this build", $tests unless $Config::Config{useperlio}; 26 27################################# 28 29use 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 42sub myyes() { 1==1 } 43sub myno () { return 1!=1 } 44sub pi () { 3.14159 }; 45 46my $want = { # expected types, how value renders in-line, todos (maybe) 47 mystr => [ 'PV', '"'.mystr.'"' ], 48 myhref => [ 'RV', '\\\\HASH'], 49 pi => [ 'NV', pi ], 50 myglob => [ 'RV', '\\\\' ], 51 mysub => [ 'RV', '\\\\' ], 52 myunsub => [ 'RV', '\\\\' ], 53 # these are not inlined, at least not per BC::Concise 54 #myyes => [ 'RV', ], 55 #myno => [ 'RV', ], 56 $] > 5.009 ? ( 57 myaref => [ 'RV', '\\\\' ], 58 myfl => [ 'NV', myfl ], 59 myint => [ 'IV', myint ], 60 myrex => [ 'RV', '\\\\' ], 61 myundef => [ 'NULL', ], 62 ) : ( 63 myaref => [ 'PVIV', '' ], 64 myfl => [ 'PVNV', myfl ], 65 myint => [ 'PVIV', myint ], 66 myrex => [ 'PVNV', '' ], 67 myundef => [ 'PVIV', ], 68 ) 69}; 70 71use constant WEEKDAYS 72 => qw ( Sunday Monday Tuesday Wednesday Thursday Friday Saturday ); 73 74 75$::{napier} = \2.71828; # counter-example (doesn't get optimized). 76eval "sub napier ();"; 77 78 79# should be able to undefine constant::import here ??? 80INIT { 81 # eval 'sub constant::import () {}'; 82 # undef *constant::import::{CODE}; 83}; 84 85################################# 86pass("RENDER CONSTANT SUBS RETURNING SCALARS"); 87 88for $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] 95EOT_EOT 96 is a constant sub, optimized to a $want->{$func}[0] 97EONT_EONT 98 99} 100 101pass("RENDER CALLS TO THOSE CONSTANT SUBS"); 102 103for $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); 1103 <1> leavesub[2 refs] K/REFC,1 ->(end) 111- <\@> lineseq KP ->3 1121 <;> dbstate(main 833 (eval 44):1) v ->2 1132 <\$> const[$want->{$func}[0] $want->{$func}[1]] s ->3 114EOT_EOT 1153 <1> leavesub[2 refs] K/REFC,1 ->(end) 116- <\@> lineseq KP ->3 1171 <;> dbstate(main 833 (eval 44):1) v ->2 1182 <\$> const($want->{$func}[0] $want->{$func}[1]) s ->3 119EONT_EONT 120 121} 122 123############## 124pass("MORE TESTS"); 125 126checkOptree ( 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 131EOT_EOT 132 is a constant sub, optimized to a SPECIAL 133EONT_EONT 134 135 136checkOptree ( 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 147EOT_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 154EONT_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. 160checkOptree ( 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 171EOT_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 178EONT_EONT 179 180 181my ($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 186EOT_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 191EONT_EONT 192 193if($] < 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 198checkOptree ( name => 'constant sub returning list', 199 code => \&WEEKDAYS, 200 noanchors => 1, 201 expect => $expect, expect_nt => $expect_nt); 202 203 204sub printem { 205 printf "myint %d mystr %s myfl %f pi %f\n" 206 , myint, mystr, myfl, pi; 207} 208 209my ($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 220EOT_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 231EONT_EONT 232 233if($] < 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 241checkOptree ( 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 252Optimized constant subs are stored as bare scalars in the stash 253(package hash), which formerly held only GVs (typeglobs). 254 255But you cant create them manually - you cant assign a scalar to a 256stash element, and expect it to work like a constant-sub, even if you 257provide a prototype. 258 259This is a feature; alternative is too much action-at-a-distance. The 260following test demonstrates - napier is not seen as a function at all, 261much less an optimized one. 262 263=cut 264 265checkOptree ( name => 'not evertnapier', 266 code => \&napier, 267 noanchors => 1, 268 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 269 has no START 270EOT_EOT 271 has no START 272EONT_EONT 273 274 275