xref: /openbsd/gnu/usr.bin/perl/ext/B/t/optree_constants.t (revision 4bdff4be) 
1#!perl
2
3BEGIN {
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}
11
12use OptreeCheck;	# ALSO DOES @ARGV HANDLING !!!!!!
13
14plan tests => 99;
15
16#################################
17
18my sub lleexx {}
19sub tsub0 {}
20sub tsub1 {} $tsub1 = 1;
21sub t::tsub2 {}
22sub t::tsub3 {} $tsub3 = 1;
23{
24    package t;
25    sub tsub4 {}
26    sub tsub5 {} $tsub5 = 1;
27}
28
29use constant {		# see also t/op/gv.t line 358
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    myanonsub	=> sub {},
41    mylexsub	=> \&lleexx,
42    tsub0	=> \&tsub0,
43    tsub1	=> \&tsub1,
44    tsub2	=> \&t::tsub2,
45    tsub3	=> \&t::tsub3,
46    tsub4	=> \&t::tsub4,
47    tsub5	=> \&t::tsub5,
48};
49
50sub myyes() { 1==1 }
51sub myno () { return 1!=1 }
52sub pi () { 3.14159 };
53
54my $want = {	# expected types, how value renders in-line, todos (maybe)
55    mystr	=> [ 'PV', '"'.mystr.'"' ],
56    myhref	=> [ 'IV', '\\\\HASH'],
57    pi		=> [ 'NV', pi ],
58    myglob	=> [ 'IV', '\\\\' ],
59    mysub	=> [ 'IV', '\\\\&main::ok' ],
60    myunsub	=> [ 'IV', '\\\\&main::nosuch' ],
61    myanonsub	=> [ 'IV', '\\\\CODE' ],
62    mylexsub	=> [ 'IV', '\\\\&lleexx' ],
63    tsub0	=> [ 'IV', '\\\\&main::tsub0' ],
64    tsub1	=> [ 'IV', '\\\\&main::tsub1' ],
65    tsub2	=> [ 'IV', '\\\\&t::tsub2' ],
66    tsub3	=> [ 'IV', '\\\\&t::tsub3' ],
67    tsub4	=> [ 'IV', '\\\\&t::tsub4' ],
68    tsub5	=> [ 'IV', '\\\\&t::tsub5' ],
69    # these are not inlined, at least not per BC::Concise
70    #myyes	=> [ 'IV', ],
71    #myno	=> [ 'IV', ],
72    myaref	=> [ 'IV', '\\\\ARRAY' ],
73    myfl	=> [ 'NV', myfl ],
74    myint	=> [ 'IV', myint ],
75    myrex	=> [ 'IV', '\\\\"\\(?^:Foo\\)"' ],
76    myundef	=> [ 'NULL', ],
77};
78
79use constant WEEKDAYS
80    => qw ( Sunday Monday Tuesday Wednesday Thursday Friday Saturday );
81
82
83$::{napier} = \2.71828;	# counter-example (doesn't get optimized).
84eval "sub napier ();";
85
86
87# should be able to undefine constant::import here ???
88INIT {
89    # eval 'sub constant::import () {}';
90    # undef *constant::import::{CODE};
91};
92
93#################################
94pass("RENDER CONSTANT SUBS RETURNING SCALARS");
95
96for $func (sort keys %$want) {
97    # no strict 'refs';	# why not needed ?
98    checkOptree ( name      => "$func() as a coderef",
99		  code      => \&{$func},
100		  noanchors => 1,
101		  expect    => <<EOT_EOT, expect_nt => <<EONT_EONT);
102 is a constant sub, optimized to a $want->{$func}[0]
103EOT_EOT
104 is a constant sub, optimized to a $want->{$func}[0]
105EONT_EONT
106
107}
108
109pass("RENDER CALLS TO THOSE CONSTANT SUBS");
110
111for $func (sort keys %$want) {
112    # print "# doing $func\n";
113    checkOptree ( name    => "call $func",
114		  code    => "$func",
115		  ($want->{$func}[2]) ? ( todo => $want->{$func}[2]) : (),
116		  bc_opts => '-nobanner',
117		  expect  => <<EOT_EOT, expect_nt => <<EONT_EONT);
1183  <1> leavesub[2 refs] K/REFC,1 ->(end)
119-     <\@> lineseq KP ->3
1201        <;> dbstate(main 833 (eval 44):1) v ->2
1212        <\$> const[$want->{$func}[0] $want->{$func}[1]] s*/FOLD ->3
122EOT_EOT
1233  <1> leavesub[2 refs] K/REFC,1 ->(end)
124-     <\@> lineseq KP ->3
1251        <;> dbstate(main 833 (eval 44):1) v ->2
1262        <\$> const($want->{$func}[0] $want->{$func}[1]) s*/FOLD ->3
127EONT_EONT
128
129}
130
131##############
132pass("MORE TESTS");
133
134checkOptree ( name	=> 'myyes() as coderef',
135	      code	=> sub () { 1==1 },
136	      noanchors => 1,
137	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
138 is a constant sub, optimized to a SPECIAL
139EOT_EOT
140 is a constant sub, optimized to a SPECIAL
141EONT_EONT
142
143
144checkOptree ( name	=> 'myyes() as coderef',
145	      prog	=> 'sub a() { 1==1 }; print a',
146	      noanchors => 1,
147	      strip_open_hints => 1,
148	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
149# 6  <@> leave[1 ref] vKP/REFC ->(end)
150# 1     <0> enter v ->2
151# 2     <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
152# 5     <@> print vK ->6
153# 3        <0> pushmark s ->4
154# 4        <$> const[SPECIAL sv_yes] s*/FOLD ->5
155EOT_EOT
156# 6  <@> leave[1 ref] vKP/REFC ->(end)
157# 1     <0> enter v ->2
158# 2     <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
159# 5     <@> print vK ->6
160# 3        <0> pushmark s ->4
161# 4        <$> const(SPECIAL sv_yes) s*/FOLD ->5
162EONT_EONT
163
164
165# Need to do this as a prog, not code, as only the first constant to use
166# PL_sv_no actually gets to use the real thing - every one following is
167# copied.
168checkOptree ( name	=> 'myno() as coderef',
169	      prog	=> 'sub a() { 1!=1 }; print a',
170	      noanchors => 1,
171	      strip_open_hints => 1,
172	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
173# 6  <@> leave[1 ref] vKP/REFC ->(end)
174# 1     <0> enter v ->2
175# 2     <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
176# 5     <@> print vK ->6
177# 3        <0> pushmark s ->4
178# 4        <$> const[SPECIAL sv_no] s*/FOLD ->5
179EOT_EOT
180# 6  <@> leave[1 ref] vKP/REFC ->(end)
181# 1     <0> enter v ->2
182# 2     <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
183# 5     <@> print vK ->6
184# 3        <0> pushmark s ->4
185# 4        <$> const(SPECIAL sv_no) s*/FOLD ->5
186EONT_EONT
187
188
189my ($expect, $expect_nt) = (" is a constant sub, optimized to a AV\n") x 2;
190
191
192checkOptree ( name	=> 'constant sub returning list',
193	      code	=> \&WEEKDAYS,
194	      noanchors => 1,
195	      expect => $expect, expect_nt => $expect_nt);
196
197
198sub printem {
199    printf "myint %d mystr %s myfl %f pi %f\n"
200	, myint, mystr, myfl, pi;
201}
202
203my ($expect, $expect_nt) = (<<'EOT_EOT', <<'EONT_EONT');
204# 9  <1> leavesub[1 ref] K/REFC,1 ->(end)
205# -     <@> lineseq KP ->9
206# 1        <;> nextstate(main 635 optree_constants.t:163) v:>,<,% ->2
207# 8        <@> prtf sK ->9
208# 2           <0> pushmark sM ->3
209# 3           <$> const[PV "myint %d mystr %s myfl %f pi %f\n"] sM/FOLD ->4
210# 4           <$> const[IV 42] sM*/FOLD ->5
211# 5           <$> const[PV "hithere"] sM*/FOLD ->6
212# 6           <$> const[NV 1.414213] sM*/FOLD ->7
213# 7           <$> const[NV 3.14159] sM*/FOLD ->8
214EOT_EOT
215# 9  <1> leavesub[1 ref] K/REFC,1 ->(end)
216# -     <@> lineseq KP ->9
217# 1        <;> nextstate(main 635 optree_constants.t:163) v:>,<,% ->2
218# 8        <@> prtf sK ->9
219# 2           <0> pushmark sM ->3
220# 3           <$> const(PV "myint %d mystr %s myfl %f pi %f\n") sM/FOLD ->4
221# 4           <$> const(IV 42) sM*/FOLD ->5
222# 5           <$> const(PV "hithere") sM*/FOLD ->6
223# 6           <$> const(NV 1.414213) sM*/FOLD ->7
224# 7           <$> const(NV 3.14159) sM*/FOLD ->8
225EONT_EONT
226
227s|\\n"[])] sM\K/FOLD|| for $expect, $expect_nt;
228
229checkOptree ( name	=> 'call many in a print statement',
230	      code	=> \&printem,
231	      strip_open_hints => 1,
232	      expect => $expect, expect_nt => $expect_nt);
233
234# test constant expression folding
235
236checkOptree ( name	=> 'arithmetic constant folding in print',
237	      code	=> 'print 1+2+3',
238	      strip_open_hints => 1,
239	      expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
240# 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
241# -     <@> lineseq KP ->5
242# 1        <;> nextstate(main 937 (eval 53):1) v ->2
243# 4        <@> print sK ->5
244# 2           <0> pushmark s ->3
245# 3           <$> const[IV 6] s/FOLD ->4
246EOT_EOT
247# 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
248# -     <@> lineseq KP ->5
249# 1        <;> nextstate(main 937 (eval 53):1) v ->2
250# 4        <@> print sK ->5
251# 2           <0> pushmark s ->3
252# 3           <$> const(IV 6) s/FOLD ->4
253EONT_EONT
254
255checkOptree ( name	=> 'string constant folding in print',
256	      code	=> 'print "foo"."bar"',
257	      strip_open_hints => 1,
258	      expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
259# 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
260# -     <@> lineseq KP ->5
261# 1        <;> nextstate(main 942 (eval 55):1) v ->2
262# 4        <@> print sK ->5
263# 2           <0> pushmark s ->3
264# 3           <$> const[PV "foobar"] s/FOLD ->4
265EOT_EOT
266# 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
267# -     <@> lineseq KP ->5
268# 1        <;> nextstate(main 942 (eval 55):1) v ->2
269# 4        <@> print sK ->5
270# 2           <0> pushmark s ->3
271# 3           <$> const(PV "foobar") s/FOLD ->4
272EONT_EONT
273
274checkOptree ( name	=> 'boolean or folding',
275	      code	=> 'print "foobar" if 1 or 0',
276	      strip_open_hints => 1,
277	      expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
278# 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
279# -     <@> lineseq KP ->5
280# 1        <;> nextstate(main 942 (eval 55):1) v ->2
281# 4        <@> print sK/FOLD ->5
282# 2           <0> pushmark s ->3
283# 3           <$> const[PV "foobar"] s ->4
284EOT_EOT
285# 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
286# -     <@> lineseq KP ->5
287# 1        <;> nextstate(main 942 (eval 55):1) v ->2
288# 4        <@> print sK/FOLD ->5
289# 2           <0> pushmark s ->3
290# 3           <$> const(PV "foobar") s ->4
291EONT_EONT
292
293checkOptree ( name	=> 'lc*,uc*,gt,lt,ge,le,cmp',
294	      code	=> sub {
295		  $s = uc('foo.').ucfirst('bar.').lc('LOW.').lcfirst('LOW');
296		  print "a-lt-b" if "a" lt "b";
297		  print "b-gt-a" if "b" gt "a";
298		  print "a-le-b" if "a" le "b";
299		  print "b-ge-a" if "b" ge "a";
300		  print "b-cmp-a" if "b" cmp "a";
301		  print "a-gt-b" if "a" gt "b";	# should be suppressed
302	      },
303	      strip_open_hints => 1,
304	      expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
305# r  <1> leavesub[1 ref] K/REFC,1 ->(end)
306# -     <@> lineseq KP ->r
307# 1        <;> nextstate(main 916 optree_constants.t:307) v:>,<,%,{ ->2
308# 4        <2> sassign vKS/2 ->5
309# 2           <$> const[PV "FOO.Bar.low.lOW"] s/FOLD ->3
310# -           <1> ex-rv2sv sKRM*/1 ->4
311# 3              <#> gvsv[*s] s ->4
312# 5        <;> nextstate(main 916 optree_constants.t:308) v:>,<,%,{ ->6
313# 8        <@> print vK/FOLD ->9
314# 6           <0> pushmark s ->7
315# 7           <$> const[PV "a-lt-b"] s ->8
316# 9        <;> nextstate(main 916 optree_constants.t:309) v:>,<,%,{ ->a
317# c        <@> print vK/FOLD ->d
318# a           <0> pushmark s ->b
319# b           <$> const[PV "b-gt-a"] s ->c
320# d        <;> nextstate(main 916 optree_constants.t:310) v:>,<,%,{ ->e
321# g        <@> print vK/FOLD ->h
322# e           <0> pushmark s ->f
323# f           <$> const[PV "a-le-b"] s ->g
324# h        <;> nextstate(main 916 optree_constants.t:311) v:>,<,%,{ ->i
325# k        <@> print vK/FOLD ->l
326# i           <0> pushmark s ->j
327# j           <$> const[PV "b-ge-a"] s ->k
328# l        <;> nextstate(main 916 optree_constants.t:312) v:>,<,%,{ ->m
329# o        <@> print vK/FOLD ->p
330# m           <0> pushmark s ->n
331# n           <$> const[PV "b-cmp-a"] s ->o
332# p        <;> nextstate(main 916 optree_constants.t:313) v:>,<,%,{ ->q
333# q        <$> const[SPECIAL sv_no] s/SHORT,FOLD ->r
334EOT_EOT
335# r  <1> leavesub[1 ref] K/REFC,1 ->(end)
336# -     <@> lineseq KP ->r
337# 1        <;> nextstate(main 916 optree_constants.t:307) v:>,<,%,{ ->2
338# 4        <2> sassign vKS/2 ->5
339# 2           <$> const(PV "FOO.Bar.low.lOW") s/FOLD ->3
340# -           <1> ex-rv2sv sKRM*/1 ->4
341# 3              <$> gvsv(*s) s ->4
342# 5        <;> nextstate(main 916 optree_constants.t:308) v:>,<,%,{ ->6
343# 8        <@> print vK/FOLD ->9
344# 6           <0> pushmark s ->7
345# 7           <$> const(PV "a-lt-b") s ->8
346# 9        <;> nextstate(main 916 optree_constants.t:309) v:>,<,%,{ ->a
347# c        <@> print vK/FOLD ->d
348# a           <0> pushmark s ->b
349# b           <$> const(PV "b-gt-a") s ->c
350# d        <;> nextstate(main 916 optree_constants.t:310) v:>,<,%,{ ->e
351# g        <@> print vK/FOLD ->h
352# e           <0> pushmark s ->f
353# f           <$> const(PV "a-le-b") s ->g
354# h        <;> nextstate(main 916 optree_constants.t:311) v:>,<,%,{ ->i
355# k        <@> print vK/FOLD ->l
356# i           <0> pushmark s ->j
357# j           <$> const(PV "b-ge-a") s ->k
358# l        <;> nextstate(main 916 optree_constants.t:312) v:>,<,%,{ ->m
359# o        <@> print vK/FOLD ->p
360# m           <0> pushmark s ->n
361# n           <$> const(PV "b-cmp-a") s ->o
362# p        <;> nextstate(main 916 optree_constants.t:313) v:>,<,%,{ ->q
363# q        <$> const(SPECIAL sv_no) s/SHORT,FOLD ->r
364EONT_EONT
365
366checkOptree ( name	=> 'mixed constant folding, with explicit braces',
367	      code	=> 'print "foo"."bar".(2+3)',
368	      strip_open_hints => 1,
369	      expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
370# 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
371# -     <@> lineseq KP ->5
372# 1        <;> nextstate(main 977 (eval 28):1) v ->2
373# 4        <@> print sK ->5
374# 2           <0> pushmark s ->3
375# 3           <$> const[PV "foobar5"] s/FOLD ->4
376EOT_EOT
377# 5  <1> leavesub[1 ref] K/REFC,1 ->(end)
378# -     <@> lineseq KP ->5
379# 1        <;> nextstate(main 977 (eval 28):1) v ->2
380# 4        <@> print sK ->5
381# 2           <0> pushmark s ->3
382# 3           <$> const(PV "foobar5") s/FOLD ->4
383EONT_EONT
384
385__END__
386
387=head NB
388
389Optimized constant subs are stored as bare scalars in the stash
390(package hash), which formerly held only GVs (typeglobs).
391
392But you cant create them manually - you cant assign a scalar to a
393stash element, and expect it to work like a constant-sub, even if you
394provide a prototype.
395
396This is a feature; alternative is too much action-at-a-distance.  The
397following test demonstrates - napier is not seen as a function at all,
398much less an optimized one.
399
400=cut
401
402checkOptree ( name	=> 'not evertnapier',
403	      code	=> \&napier,
404	      noanchors => 1,
405	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
406 has no START
407EOT_EOT
408 has no START
409EONT_EONT
410
411
412