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