perl5.git.perl.org Git - perl5.git/blame_incremental

... / ...

Commit	Line	Data
	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	}
	11
	12	use OptreeCheck; # ALSO DOES @ARGV HANDLING !!!!!!
	13
	14	plan tests => 99;
	15
	16	#################################
	17
	18	my sub lleexx {}
	19	sub tsub0 {}
	20	sub tsub1 {} $tsub1 = 1;
	21	sub t::tsub2 {}
	22	sub t::tsub3 {} $tsub3 = 1;
	23	{
	24	package t;
	25	sub tsub4 {}
	26	sub tsub5 {} $tsub5 = 1;
	27	}
	28
	29	use 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
	50	sub myyes() { 1==1 }
	51	sub myno () { return 1!=1 }
	52	sub pi () { 3.14159 };
	53
	54	my $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
	79	use constant WEEKDAYS
	80	=> qw ( Sunday Monday Tuesday Wednesday Thursday Friday Saturday );
	81
	82
	83	$::{napier} = \2.71828; # counter-example (doesn't get optimized).
	84	eval "sub napier ();";
	85
	86
	87	# should be able to undefine constant::import here ???
	88	INIT {
	89	# eval 'sub constant::import () {}';
	90	# undef *constant::import::{CODE};
	91	};
	92
	93	#################################
	94	pass("RENDER CONSTANT SUBS RETURNING SCALARS");
	95
	96	for $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]
	103	EOT_EOT
	104	is a constant sub, optimized to a $want->{$func}[0]
	105	EONT_EONT
	106
	107	}
	108
	109	pass("RENDER CALLS TO THOSE CONSTANT SUBS");
	110
	111	for $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);
	118	3 <1> leavesub[2 refs] K/REFC,1 ->(end)
	119	- <\@> lineseq KP ->3
	120	1 <;> dbstate(main 833 (eval 44):1) v ->2
	121	2 <\$> const[$want->{$func}[0] $want->{$func}[1]] s*/FOLD ->3
	122	EOT_EOT
	123	3 <1> leavesub[2 refs] K/REFC,1 ->(end)
	124	- <\@> lineseq KP ->3
	125	1 <;> dbstate(main 833 (eval 44):1) v ->2
	126	2 <\$> const($want->{$func}[0] $want->{$func}[1]) s*/FOLD ->3
	127	EONT_EONT
	128
	129	}
	130
	131	##############
	132	pass("MORE TESTS");
	133
	134	checkOptree ( 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
	139	EOT_EOT
	140	is a constant sub, optimized to a SPECIAL
	141	EONT_EONT
	142
	143
	144	checkOptree ( 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
	155	EOT_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
	162	EONT_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.
	168	checkOptree ( 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
	179	EOT_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
	186	EONT_EONT
	187
	188
	189	my ($expect, $expect_nt) = (" is a constant sub, optimized to a AV\n") x 2;
	190
	191
	192	checkOptree ( name => 'constant sub returning list',
	193	code => \&WEEKDAYS,
	194	noanchors => 1,
	195	expect => $expect, expect_nt => $expect_nt);
	196
	197
	198	sub printem {
	199	printf "myint %d mystr %s myfl %f pi %f\n"
	200	, myint, mystr, myfl, pi;
	201	}
	202
	203	my ($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
	214	EOT_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
	225	EONT_EONT
	226
	227	s\|\\n"[])] sM\K/FOLD\|\| for $expect, $expect_nt;
	228
	229	checkOptree ( 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
	236	checkOptree ( 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
	246	EOT_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
	253	EONT_EONT
	254
	255	checkOptree ( 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
	265	EOT_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
	272	EONT_EONT
	273
	274	checkOptree ( 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
	284	EOT_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
	291	EONT_EONT
	292
	293	checkOptree ( 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
	334	EOT_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
	364	EONT_EONT
	365
	366	checkOptree ( 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
	376	EOT_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
	383	EONT_EONT
	384
	385	__END__
	386
	387	=head NB
	388
	389	Optimized constant subs are stored as bare scalars in the stash
	390	(package hash), which formerly held only GVs (typeglobs).
	391
	392	But you cant create them manually - you cant assign a scalar to a
	393	stash element, and expect it to work like a constant-sub, even if you
	394	provide a prototype.
	395
	396	This is a feature; alternative is too much action-at-a-distance. The
	397	following test demonstrates - napier is not seen as a function at all,
	398	much less an optimized one.
	399
	400	=cut
	401
	402	checkOptree ( name => 'not evertnapier',
	403	code => \&napier,
	404	noanchors => 1,
	405	expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
	406	has no START
	407	EOT_EOT
	408	has no START
	409	EONT_EONT
	410
	411