[p5sagit/p5-mst-13.2.git] / ext / B / t / optree_constants.t

#!perl

BEGIN {
    if ($ENV{PERL_CORE}) {
	chdir('t') if -d 't';
	@INC = ('.', '../lib', '../ext/B/t');
    } else {
	unshift @INC, 't';
	push @INC, "../../t";
    }
    require Config;
    if (($Config::Config{'extensions'} !~ /\bB\b/) ){
        print "1..0 # Skip -- Perl configured without B module\n";
        exit 0;
    }
    # require 'test.pl'; # now done by OptreeCheck
}

use OptreeCheck;	# ALSO DOES @ARGV HANDLING !!!!!!
use Config;

my $tests = 30;
plan tests => $tests;
SKIP: {
skip "no perlio in this build", $tests unless $Config::Config{useperlio};

#################################

use constant {		# see also t/op/gv.t line 282
    myaref	=> [ 1,2,3 ],
    myfl	=> 1.414213,
    myglob	=> \*STDIN,
    myhref	=> { a	=> 1 },
    myint	=> 42,
    myrex	=> qr/foo/,
    mystr	=> 'hithere',
    mysub	=> \&ok,
    myundef	=> undef,
    myunsub	=> \&nosuch,
};

sub myyes() { 1==1 }
sub myno () { return 1!=1 }
sub pi () { 3.14159 };

my $RV_class = $] >= 5.011 ? 'IV' : 'RV';

my $want = {	# expected types, how value renders in-line, todos (maybe)
    mystr	=> [ 'PV', '"'.mystr.'"' ],
    myhref	=> [ $RV_class, '\\\\HASH'],
    pi		=> [ 'NV', pi ],
    myglob	=> [ $RV_class, '\\\\' ],
    mysub	=> [ $RV_class, '\\\\' ],
    myunsub	=> [ $RV_class, '\\\\' ],
    # these are not inlined, at least not per BC::Concise
    #myyes	=> [ $RV_class, ],
    #myno	=> [ $RV_class, ],
    $] > 5.009 ? (
    myaref	=> [ $RV_class, '\\\\' ],
    myfl	=> [ 'NV', myfl ],
    myint	=> [ 'IV', myint ],
    myrex	=> [ $RV_class, '\\\\' ],
    myundef	=> [ 'NULL', ],
    ) : (
    myaref	=> [ 'PVIV', '' ],
    myfl	=> [ 'PVNV', myfl ],
    myint	=> [ 'PVIV', myint ],
    myrex	=> [ 'PVNV', '' ],
    myundef	=> [ 'PVIV', ],
    )
};

use constant WEEKDAYS
    => qw ( Sunday Monday Tuesday Wednesday Thursday Friday Saturday );


$::{napier} = \2.71828;	# counter-example (doesn't get optimized).
eval "sub napier ();";


# should be able to undefine constant::import here ???
INIT { 
    # eval 'sub constant::import () {}';
    # undef *constant::import::{CODE};
};

#################################
pass("RENDER CONSTANT SUBS RETURNING SCALARS");

for $func (sort keys %$want) {
    # no strict 'refs';	# why not needed ?
    checkOptree ( name      => "$func() as a coderef",
		  code      => \&{$func},
		  noanchors => 1,
		  expect    => <<EOT_EOT, expect_nt => <<EONT_EONT);
 is a constant sub, optimized to a $want->{$func}[0]
EOT_EOT
 is a constant sub, optimized to a $want->{$func}[0]
EONT_EONT

}

pass("RENDER CALLS TO THOSE CONSTANT SUBS");

for $func (sort keys %$want) {
    # print "# doing $func\n";
    checkOptree ( name    => "call $func",
		  code    => "$func",
		  ($want->{$func}[2]) ? ( todo => $want->{$func}[2]) : (),
		  bc_opts => '-nobanner',
		  expect  => <<EOT_EOT, expect_nt => <<EONT_EONT);
3  <1> leavesub[2 refs] K/REFC,1 ->(end)
-     <\@> lineseq KP ->3
1        <;> dbstate(main 833 (eval 44):1) v ->2
2        <\$> const[$want->{$func}[0] $want->{$func}[1]] s ->3
EOT_EOT
3  <1> leavesub[2 refs] K/REFC,1 ->(end)
-     <\@> lineseq KP ->3
1        <;> dbstate(main 833 (eval 44):1) v ->2
2        <\$> const($want->{$func}[0] $want->{$func}[1]) s ->3
EONT_EONT

}

##############
pass("MORE TESTS");

checkOptree ( name	=> 'myyes() as coderef',
	      code	=> sub () { 1==1 },
	      noanchors => 1,
	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 is a constant sub, optimized to a SPECIAL
EOT_EOT
 is a constant sub, optimized to a SPECIAL
EONT_EONT


checkOptree ( name	=> 'myyes() as coderef',
	      prog	=> 'sub a() { 1==1 }; print a',
	      noanchors => 1,
	      strip_open_hints => 1,
	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 6  <@> leave[1 ref] vKP/REFC ->(end)
# 1     <0> enter ->2
# 2     <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
# 5     <@> print vK ->6
# 3        <0> pushmark s ->4
# 4        <$> const[SPECIAL sv_yes] s ->5
EOT_EOT
# 6  <@> leave[1 ref] vKP/REFC ->(end)
# 1     <0> enter ->2
# 2     <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
# 5     <@> print vK ->6
# 3        <0> pushmark s ->4
# 4        <$> const(SPECIAL sv_yes) s ->5
EONT_EONT


# Need to do this as a prog, not code, as only the first constant to use
# PL_sv_no actually gets to use the real thing - every one following is
# copied.
checkOptree ( name	=> 'myno() as coderef',
	      prog	=> 'sub a() { 1!=1 }; print a',
	      noanchors => 1,
	      strip_open_hints => 1,
	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 6  <@> leave[1 ref] vKP/REFC ->(end)
# 1     <0> enter ->2
# 2     <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
# 5     <@> print vK ->6
# 3        <0> pushmark s ->4
# 4        <$> const[SPECIAL sv_no] s ->5
EOT_EOT
# 6  <@> leave[1 ref] vKP/REFC ->(end)
# 1     <0> enter ->2
# 2     <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
# 5     <@> print vK ->6
# 3        <0> pushmark s ->4
# 4        <$> const(SPECIAL sv_no) s ->5
EONT_EONT


my ($expect, $expect_nt) = (<<'EOT_EOT', <<'EONT_EONT');
# 3  <1> leavesub[2 refs] K/REFC,1 ->(end)
# -     <@> lineseq K ->3
# 1        <;> nextstate(constant 61 constant.pm:118) v:*,& ->2
# 2        <0> padav[@list:FAKE:m:96] ->3
EOT_EOT
# 3  <1> leavesub[2 refs] K/REFC,1 ->(end)
# -     <@> lineseq K ->3
# 1        <;> nextstate(constant 61 constant.pm:118) v:*,& ->2
# 2        <0> padav[@list:FAKE:m:71] ->3
EONT_EONT

if($] < 5.009) {
    # 5.8.x doesn't add the m flag to padav
    s/FAKE:m:\d+/FAKE/ foreach ($expect, $expect_nt);
}

checkOptree ( name	=> 'constant sub returning list',
	      code	=> \&WEEKDAYS,
	      noanchors => 1,
	      expect => $expect, expect_nt => $expect_nt);


sub printem {
    printf "myint %d mystr %s myfl %f pi %f\n"
	, myint, mystr, myfl, pi;
}

my ($expect, $expect_nt) = (<<'EOT_EOT', <<'EONT_EONT');
# 9  <1> leavesub[1 ref] K/REFC,1 ->(end)
# -     <@> lineseq KP ->9
# 1        <;> nextstate(main 635 optree_constants.t:163) v:>,<,% ->2
# 8        <@> prtf sK ->9
# 2           <0> pushmark s ->3
# 3           <$> const[PV "myint %d mystr %s myfl %f pi %f\n"] s ->4
# 4           <$> const[IV 42] s ->5
# 5           <$> const[PV "hithere"] s ->6
# 6           <$> const[NV 1.414213] s ->7
# 7           <$> const[NV 3.14159] s ->8
EOT_EOT
# 9  <1> leavesub[1 ref] K/REFC,1 ->(end)
# -     <@> lineseq KP ->9
# 1        <;> nextstate(main 635 optree_constants.t:163) v:>,<,% ->2
# 8        <@> prtf sK ->9
# 2           <0> pushmark s ->3
# 3           <$> const(PV "myint %d mystr %s myfl %f pi %f\n") s ->4
# 4           <$> const(IV 42) s ->5
# 5           <$> const(PV "hithere") s ->6
# 6           <$> const(NV 1.414213) s ->7
# 7           <$> const(NV 3.14159) s ->8
EONT_EONT

if($] < 5.009) {
    # 5.8.x's use constant has larger types
    foreach ($expect, $expect_nt) {
	s/IV 42/PV$&/;
	s/NV 1.41/PV$&/;
    }
}

checkOptree ( name	=> 'call many in a print statement',
	      code	=> \&printem,
	      strip_open_hints => 1,
	      expect => $expect, expect_nt => $expect_nt);

} #skip

__END__

=head NB

Optimized constant subs are stored as bare scalars in the stash
(package hash), which formerly held only GVs (typeglobs).

But you cant create them manually - you cant assign a scalar to a
stash element, and expect it to work like a constant-sub, even if you
provide a prototype.

This is a feature; alternative is too much action-at-a-distance.  The
following test demonstrates - napier is not seen as a function at all,
much less an optimized one.

=cut

checkOptree ( name	=> 'not evertnapier',
	      code	=> \&napier,
	      noanchors => 1,
	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 has no START
EOT_EOT
 has no START
EONT_EONT
Commit	Line	Data
d51cf0c9	1	#!perl
	2
	3	BEGIN {
	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
	19	use OptreeCheck; # ALSO DOES @ARGV HANDLING !!!!!!
	20	use Config;
	21
f9f861ec	22	my $tests = 30;
d51cf0c9	23	plan tests => $tests;
	24	SKIP: {
	25	skip "no perlio in this build", $tests unless $Config::Config{useperlio};
	26
	27	#################################
	28
	29	use constant { # see also t/op/gv.t line 282
f9f861ec	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
	42	sub myyes() { 1==1 }
	43	sub myno () { return 1!=1 }
	44	sub pi () { 3.14159 };
	45
4df7f6af	46	my $RV_class = $] >= 5.011 ? 'IV' : 'RV';
4df7f6af	47
f9f861ec	48	my $want = { # expected types, how value renders in-line, todos (maybe)
f9f861ec	49	mystr => [ 'PV', '"'.mystr.'"' ],
4df7f6af	50	myhref => [ $RV_class, '\\\\HASH'],
f9f861ec	51	pi => [ 'NV', pi ],
4df7f6af	52	myglob => [ $RV_class, '\\\\' ],
	53	mysub => [ $RV_class, '\\\\' ],
	54	myunsub => [ $RV_class, '\\\\' ],
f9f861ec	55	# these are not inlined, at least not per BC::Concise
4df7f6af	56	#myyes => [ $RV_class, ],
4df7f6af	57	#myno => [ $RV_class, ],
e412117e	58	$] > 5.009 ? (
4df7f6af	59	myaref => [ $RV_class, '\\\\' ],
e412117e	60	myfl => [ 'NV', myfl ],
e412117e	61	myint => [ 'IV', myint ],
4df7f6af	62	myrex => [ $RV_class, '\\\\' ],
e412117e	63	myundef => [ 'NULL', ],
	64	) : (
	65	myaref => [ 'PVIV', '' ],
	66	myfl => [ 'PVNV', myfl ],
	67	myint => [ 'PVIV', myint ],
	68	myrex => [ 'PVNV', '' ],
	69	myundef => [ 'PVIV', ],
	70	)
d51cf0c9	71	};
	72
	73	use constant WEEKDAYS
	74	=> qw ( Sunday Monday Tuesday Wednesday Thursday Friday Saturday );
	75
	76
d51cf0c9	77	$::{napier} = \2.71828; # counter-example (doesn't get optimized).
	78	eval "sub napier ();";
	79
	80
	81	# should be able to undefine constant::import here ???
	82	INIT {
	83	# eval 'sub constant::import () {}';
	84	# undef *constant::import::{CODE};
	85	};
	86
	87	#################################
f9f861ec	88	pass("RENDER CONSTANT SUBS RETURNING SCALARS");
2018a5c3	89
f9f861ec	90	for $func (sort keys %$want) {
	91	# no strict 'refs'; # why not needed ?
	92	checkOptree ( name => "$func() as a coderef",
	93	code => \&{$func},
	94	noanchors => 1,
	95	expect => <<EOT_EOT, expect_nt => <<EONT_EONT);
	96	is a constant sub, optimized to a $want->{$func}[0]
2018a5c3	97	EOT_EOT
f9f861ec	98	is a constant sub, optimized to a $want->{$func}[0]
d51cf0c9	99	EONT_EONT
d51cf0c9	100
f9f861ec	101	}
d51cf0c9	102
f9f861ec	103	pass("RENDER CALLS TO THOSE CONSTANT SUBS");
d51cf0c9	104
f9f861ec	105	for $func (sort keys %$want) {
	106	# print "# doing $func\n";
	107	checkOptree ( name => "call $func",
	108	code => "$func",
	109	($want->{$func}[2]) ? ( todo => $want->{$func}[2]) : (),
	110	bc_opts => '-nobanner',
	111	expect => <<EOT_EOT, expect_nt => <<EONT_EONT);
d51cf0c9	112	3 <1> leavesub[2 refs] K/REFC,1 ->(end)
f9f861ec	113	- <\@> lineseq KP ->3
be2b1c74	114	1 <;> dbstate(main 833 (eval 44):1) v ->2
f9f861ec	115	2 <\$> const[$want->{$func}[0] $want->{$func}[1]] s ->3
d51cf0c9	116	EOT_EOT
d51cf0c9	117	3 <1> leavesub[2 refs] K/REFC,1 ->(end)
f9f861ec	118	- <\@> lineseq KP ->3
be2b1c74	119	1 <;> dbstate(main 833 (eval 44):1) v ->2
f9f861ec	120	2 <\$> const($want->{$func}[0] $want->{$func}[1]) s ->3
d51cf0c9	121	EONT_EONT
d51cf0c9	122
f9f861ec	123	}
d51cf0c9	124
f9f861ec	125	##############
f9f861ec	126	pass("MORE TESTS");
d51cf0c9	127
f9f861ec	128	checkOptree ( name => 'myyes() as coderef',
f9f861ec	129	code => sub () { 1==1 },
2018a5c3	130	noanchors => 1,
2018a5c3	131	expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
f9f861ec	132	is a constant sub, optimized to a SPECIAL
2018a5c3	133	EOT_EOT
f9f861ec	134	is a constant sub, optimized to a SPECIAL
2018a5c3	135	EONT_EONT
	136
	137
f9f861ec	138	checkOptree ( name => 'myyes() as coderef',
36932700	139	prog => 'sub a() { 1==1 }; print a',
2018a5c3	140	noanchors => 1,
e412117e	141	strip_open_hints => 1,
2018a5c3	142	expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
36932700	143	# 6 <@> leave[1 ref] vKP/REFC ->(end)
36932700	144	# 1 <0> enter ->2
e412117e	145	# 2 <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
36932700	146	# 5 <@> print vK ->6
	147	# 3 <0> pushmark s ->4
	148	# 4 <$> const[SPECIAL sv_yes] s ->5
2018a5c3	149	EOT_EOT
36932700	150	# 6 <@> leave[1 ref] vKP/REFC ->(end)
36932700	151	# 1 <0> enter ->2
e412117e	152	# 2 <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
36932700	153	# 5 <@> print vK ->6
	154	# 3 <0> pushmark s ->4
	155	# 4 <$> const(SPECIAL sv_yes) s ->5
2018a5c3	156	EONT_EONT
2018a5c3	157
d51cf0c9	158
36932700	159	# Need to do this as a prog, not code, as only the first constant to use
	160	# PL_sv_no actually gets to use the real thing - every one following is
	161	# copied.
f9f861ec	162	checkOptree ( name => 'myno() as coderef',
36932700	163	prog => 'sub a() { 1!=1 }; print a',
d51cf0c9	164	noanchors => 1,
e412117e	165	strip_open_hints => 1,
d51cf0c9	166	expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
36932700	167	# 6 <@> leave[1 ref] vKP/REFC ->(end)
36932700	168	# 1 <0> enter ->2
e412117e	169	# 2 <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
36932700	170	# 5 <@> print vK ->6
	171	# 3 <0> pushmark s ->4
	172	# 4 <$> const[SPECIAL sv_no] s ->5
d51cf0c9	173	EOT_EOT
36932700	174	# 6 <@> leave[1 ref] vKP/REFC ->(end)
36932700	175	# 1 <0> enter ->2
e412117e	176	# 2 <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
36932700	177	# 5 <@> print vK ->6
	178	# 3 <0> pushmark s ->4
	179	# 4 <$> const(SPECIAL sv_no) s ->5
d51cf0c9	180	EONT_EONT
	181
	182
e412117e	183	my ($expect, $expect_nt) = (<<'EOT_EOT', <<'EONT_EONT');
d51cf0c9	184	# 3 <1> leavesub[2 refs] K/REFC,1 ->(end)
d51cf0c9	185	# - <@> lineseq K ->3
dbeafbd1	186	# 1 <;> nextstate(constant 61 constant.pm:118) v:*,& ->2
dbeafbd1	187	# 2 <0> padav[@list:FAKE:m:96] ->3
d51cf0c9	188	EOT_EOT
	189	# 3 <1> leavesub[2 refs] K/REFC,1 ->(end)
	190	# - <@> lineseq K ->3
dbeafbd1	191	# 1 <;> nextstate(constant 61 constant.pm:118) v:*,& ->2
dbeafbd1	192	# 2 <0> padav[@list:FAKE:m:71] ->3
d51cf0c9	193	EONT_EONT
d51cf0c9	194
e412117e	195	if($] < 5.009) {
	196	# 5.8.x doesn't add the m flag to padav
	197	s/FAKE:m:\d+/FAKE/ foreach ($expect, $expect_nt);
	198	}
	199
	200	checkOptree ( name => 'constant sub returning list',
	201	code => \&WEEKDAYS,
	202	noanchors => 1,
	203	expect => $expect, expect_nt => $expect_nt);
	204
d51cf0c9	205
	206	sub printem {
	207	printf "myint %d mystr %s myfl %f pi %f\n"
	208	, myint, mystr, myfl, pi;
	209	}
	210
e412117e	211	my ($expect, $expect_nt) = (<<'EOT_EOT', <<'EONT_EONT');
d51cf0c9	212	# 9 <1> leavesub[1 ref] K/REFC,1 ->(end)
d51cf0c9	213	# - <@> lineseq KP ->9
be2b1c74	214	# 1 <;> nextstate(main 635 optree_constants.t:163) v:>,<,% ->2
d51cf0c9	215	# 8 <@> prtf sK ->9
	216	# 2 <0> pushmark s ->3
	217	# 3 <$> const[PV "myint %d mystr %s myfl %f pi %f\n"] s ->4
	218	# 4 <$> const[IV 42] s ->5
	219	# 5 <$> const[PV "hithere"] s ->6
f9f861ec	220	# 6 <$> const[NV 1.414213] s ->7
d51cf0c9	221	# 7 <$> const[NV 3.14159] s ->8
	222	EOT_EOT
	223	# 9 <1> leavesub[1 ref] K/REFC,1 ->(end)
	224	# - <@> lineseq KP ->9
be2b1c74	225	# 1 <;> nextstate(main 635 optree_constants.t:163) v:>,<,% ->2
d51cf0c9	226	# 8 <@> prtf sK ->9
	227	# 2 <0> pushmark s ->3
	228	# 3 <$> const(PV "myint %d mystr %s myfl %f pi %f\n") s ->4
	229	# 4 <$> const(IV 42) s ->5
	230	# 5 <$> const(PV "hithere") s ->6
f9f861ec	231	# 6 <$> const(NV 1.414213) s ->7
d51cf0c9	232	# 7 <$> const(NV 3.14159) s ->8
	233	EONT_EONT
	234
e412117e	235	if($] < 5.009) {
	236	# 5.8.x's use constant has larger types
	237	foreach ($expect, $expect_nt) {
	238	s/IV 42/PV$&/;
	239	s/NV 1.41/PV$&/;
	240	}
	241	}
	242
	243	checkOptree ( name => 'call many in a print statement',
	244	code => \&printem,
	245	strip_open_hints => 1,
	246	expect => $expect, expect_nt => $expect_nt);
d51cf0c9	247
	248	} #skip
	249
	250	__END__
	251
	252	=head NB
	253
	254	Optimized constant subs are stored as bare scalars in the stash
	255	(package hash), which formerly held only GVs (typeglobs).
	256
	257	But you cant create them manually - you cant assign a scalar to a
	258	stash element, and expect it to work like a constant-sub, even if you
	259	provide a prototype.
	260
	261	This is a feature; alternative is too much action-at-a-distance. The
	262	following test demonstrates - napier is not seen as a function at all,
	263	much less an optimized one.
	264
	265	=cut
	266
	267	checkOptree ( name => 'not evertnapier',
	268	code => \&napier,
	269	noanchors => 1,
	270	expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
	271	has no START
	272	EOT_EOT
	273	has no START
	274	EONT_EONT
	275
	276