This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
47afea4999e450317a81be1b536f8872f5efd831
[perl5.git] / 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, '\\\\"\\(?-xism: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