This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Record folded constants in the op tree
[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     if (!$Config::Config{useperlio}) {
11         print "1..0 # Skip -- need perlio to walk the optree\n";
12         exit 0;
13     }
14 }
15
16 use OptreeCheck;        # ALSO DOES @ARGV HANDLING !!!!!!
17 use Config;
18
19 plan tests => 67;
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*/FOLD ->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*/FOLD ->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*/FOLD ->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*/FOLD ->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*/FOLD ->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*/FOLD ->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:*,&,x*,x&,x$ ->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:*,&,x*,x&,x$ ->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 sM ->3
215 # 3           <$> const[PV "myint %d mystr %s myfl %f pi %f\n"] sM/FOLD ->4
216 # 4           <$> const[IV 42] sM*/FOLD ->5
217 # 5           <$> const[PV "hithere"] sM*/FOLD ->6
218 # 6           <$> const[NV 1.414213] sM*/FOLD ->7
219 # 7           <$> const[NV 3.14159] sM*/FOLD ->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 sM ->3
226 # 3           <$> const(PV "myint %d mystr %s myfl %f pi %f\n") sM/FOLD ->4
227 # 4           <$> const(IV 42) sM*/FOLD ->5
228 # 5           <$> const(PV "hithere") sM*/FOLD ->6
229 # 6           <$> const(NV 1.414213) sM*/FOLD ->7
230 # 7           <$> const(NV 3.14159) sM*/FOLD ->8
231 EONT_EONT
232
233 if($] < 5.015) {
234     s/M(?=\*? ->)//g for $expect, $expect_nt;
235 }
236 if($] < 5.009) {
237     # 5.8.x's use constant has larger types
238     foreach ($expect, $expect_nt) {
239         s/IV 42/PV$&/;
240         s/NV 1.41/PV$&/;
241     }
242 }
243
244 checkOptree ( name      => 'call many in a print statement',
245               code      => \&printem,
246               strip_open_hints => 1,
247               expect => $expect, expect_nt => $expect_nt);
248
249 # test constant expression folding
250
251 checkOptree ( name      => 'arithmetic constant folding in print',
252               code      => 'print 1+2+3',
253               strip_open_hints => 1,
254               expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
255 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
256 # -     <@> lineseq KP ->5
257 # 1        <;> nextstate(main 937 (eval 53):1) v ->2
258 # 4        <@> print sK ->5
259 # 2           <0> pushmark s ->3
260 # 3           <$> const[IV 6] s/FOLD ->4
261 EOT_EOT
262 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
263 # -     <@> lineseq KP ->5
264 # 1        <;> nextstate(main 937 (eval 53):1) v ->2
265 # 4        <@> print sK ->5
266 # 2           <0> pushmark s ->3
267 # 3           <$> const(IV 6) s/FOLD ->4
268 EONT_EONT
269
270 checkOptree ( name      => 'string constant folding in print',
271               code      => 'print "foo"."bar"',
272               strip_open_hints => 1,
273               expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
274 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
275 # -     <@> lineseq KP ->5
276 # 1        <;> nextstate(main 942 (eval 55):1) v ->2
277 # 4        <@> print sK ->5
278 # 2           <0> pushmark s ->3
279 # 3           <$> const[PV "foobar"] s/FOLD ->4
280 EOT_EOT
281 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
282 # -     <@> lineseq KP ->5
283 # 1        <;> nextstate(main 942 (eval 55):1) v ->2
284 # 4        <@> print sK ->5
285 # 2           <0> pushmark s ->3
286 # 3           <$> const(PV "foobar") s/FOLD ->4
287 EONT_EONT
288
289 checkOptree ( name      => 'boolean or folding',
290               code      => 'print "foobar" if 1 or 0',
291               strip_open_hints => 1,
292               expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
293 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
294 # -     <@> lineseq KP ->5
295 # 1        <;> nextstate(main 942 (eval 55):1) v ->2
296 # 4        <@> print sK ->5
297 # 2           <0> pushmark s ->3
298 # 3           <$> const[PV "foobar"] s ->4
299 EOT_EOT
300 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
301 # -     <@> lineseq KP ->5
302 # 1        <;> nextstate(main 942 (eval 55):1) v ->2
303 # 4        <@> print sK ->5
304 # 2           <0> pushmark s ->3
305 # 3           <$> const(PV "foobar") s ->4
306 EONT_EONT
307
308 checkOptree ( name      => 'lc*,uc*,gt,lt,ge,le,cmp',
309               code      => sub {
310                   $s = uc('foo.').ucfirst('bar.').lc('LOW.').lcfirst('LOW');
311                   print "a-lt-b" if "a" lt "b";
312                   print "b-gt-a" if "b" gt "a";
313                   print "a-le-b" if "a" le "b";
314                   print "b-ge-a" if "b" ge "a";
315                   print "b-cmp-a" if "b" cmp "a";
316                   print "a-gt-b" if "a" gt "b"; # should be suppressed
317               },
318               strip_open_hints => 1,
319               expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
320 # r  <1> leavesub[1 ref] K/REFC,1 ->(end)
321 # -     <@> lineseq KP ->r
322 # 1        <;> nextstate(main 916 optree_constants.t:307) v:>,<,%,{ ->2
323 # 4        <2> sassign vKS/2 ->5
324 # 2           <$> const[PV "FOO.Bar.low.lOW"] s/FOLD ->3
325 # -           <1> ex-rv2sv sKRM*/1 ->4
326 # 3              <#> gvsv[*s] s ->4
327 # 5        <;> nextstate(main 916 optree_constants.t:308) v:>,<,%,{ ->6
328 # 8        <@> print vK ->9
329 # 6           <0> pushmark s ->7
330 # 7           <$> const[PV "a-lt-b"] s ->8
331 # 9        <;> nextstate(main 916 optree_constants.t:309) v:>,<,%,{ ->a
332 # c        <@> print vK ->d
333 # a           <0> pushmark s ->b
334 # b           <$> const[PV "b-gt-a"] s ->c
335 # d        <;> nextstate(main 916 optree_constants.t:310) v:>,<,%,{ ->e
336 # g        <@> print vK ->h
337 # e           <0> pushmark s ->f
338 # f           <$> const[PV "a-le-b"] s ->g
339 # h        <;> nextstate(main 916 optree_constants.t:311) v:>,<,%,{ ->i
340 # k        <@> print vK ->l
341 # i           <0> pushmark s ->j
342 # j           <$> const[PV "b-ge-a"] s ->k
343 # l        <;> nextstate(main 916 optree_constants.t:312) v:>,<,%,{ ->m
344 # o        <@> print vK ->p
345 # m           <0> pushmark s ->n
346 # n           <$> const[PV "b-cmp-a"] s ->o
347 # p        <;> nextstate(main 916 optree_constants.t:313) v:>,<,%,{ ->q
348 # q        <$> const[PVNV 0] s/FOLD,SHORT ->r
349 EOT_EOT
350 # r  <1> leavesub[1 ref] K/REFC,1 ->(end)
351 # -     <@> lineseq KP ->r
352 # 1        <;> nextstate(main 916 optree_constants.t:307) v:>,<,%,{ ->2
353 # 4        <2> sassign vKS/2 ->5
354 # 2           <$> const(PV "FOO.Bar.low.lOW") s/FOLD ->3
355 # -           <1> ex-rv2sv sKRM*/1 ->4
356 # 3              <$> gvsv(*s) s ->4
357 # 5        <;> nextstate(main 916 optree_constants.t:308) v:>,<,%,{ ->6
358 # 8        <@> print vK ->9
359 # 6           <0> pushmark s ->7
360 # 7           <$> const(PV "a-lt-b") s ->8
361 # 9        <;> nextstate(main 916 optree_constants.t:309) v:>,<,%,{ ->a
362 # c        <@> print vK ->d
363 # a           <0> pushmark s ->b
364 # b           <$> const(PV "b-gt-a") s ->c
365 # d        <;> nextstate(main 916 optree_constants.t:310) v:>,<,%,{ ->e
366 # g        <@> print vK ->h
367 # e           <0> pushmark s ->f
368 # f           <$> const(PV "a-le-b") s ->g
369 # h        <;> nextstate(main 916 optree_constants.t:311) v:>,<,%,{ ->i
370 # k        <@> print vK ->l
371 # i           <0> pushmark s ->j
372 # j           <$> const(PV "b-ge-a") s ->k
373 # l        <;> nextstate(main 916 optree_constants.t:312) v:>,<,%,{ ->m
374 # o        <@> print vK ->p
375 # m           <0> pushmark s ->n
376 # n           <$> const(PV "b-cmp-a") s ->o
377 # p        <;> nextstate(main 916 optree_constants.t:313) v:>,<,%,{ ->q
378 # q        <$> const(SPECIAL sv_no) s/FOLD,SHORT ->r
379 EONT_EONT
380
381 checkOptree ( name      => 'mixed constant folding, with explicit braces',
382               code      => 'print "foo"."bar".(2+3)',
383               strip_open_hints => 1,
384               expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
385 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
386 # -     <@> lineseq KP ->5
387 # 1        <;> nextstate(main 977 (eval 28):1) v ->2
388 # 4        <@> print sK ->5
389 # 2           <0> pushmark s ->3
390 # 3           <$> const[PV "foobar5"] s/FOLD ->4
391 EOT_EOT
392 # 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
393 # -     <@> lineseq KP ->5
394 # 1        <;> nextstate(main 977 (eval 28):1) v ->2
395 # 4        <@> print sK ->5
396 # 2           <0> pushmark s ->3
397 # 3           <$> const(PV "foobar5") s/FOLD ->4
398 EONT_EONT
399
400 __END__
401
402 =head NB
403
404 Optimized constant subs are stored as bare scalars in the stash
405 (package hash), which formerly held only GVs (typeglobs).
406
407 But you cant create them manually - you cant assign a scalar to a
408 stash element, and expect it to work like a constant-sub, even if you
409 provide a prototype.
410
411 This is a feature; alternative is too much action-at-a-distance.  The
412 following test demonstrates - napier is not seen as a function at all,
413 much less an optimized one.
414
415 =cut
416
417 checkOptree ( name      => 'not evertnapier',
418               code      => \&napier,
419               noanchors => 1,
420               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
421  has no START
422 EOT_EOT
423  has no START
424 EONT_EONT
425
426