[perl5.git] / ext / B / t / optree_constants.t

#!perl

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