[ViewVC] Diff of: cvs/Faster/Faster.pm

Comparing Faster/Faster.pm (file contents):
Revision 1.6 by root, Fri Mar 10 00:11:44 2006 UTC vs.
Revision 1.33 by root, Mon Mar 13 17:10:32 2006 UTC

…		…
4		4
5	=head1 SYNOPSIS	5	=head1 SYNOPSIS
6		6
7	use Faster;	7	use Faster;
8		8
		9	perl -MFaster ...
		10
9	=head1 DESCRIPTION	11	=head1 DESCRIPTION
10		12
		13	This module implements a very simple-minded "JIT" (or actually AIT, ahead
		14	of time compiler). It works by more or less translating every function it
		15	sees into a C program, compiling it and then replacing the function by the
		16	compiled code.
		17
		18	As a result, startup times are immense, as every function might lead to a
		19	full-blown compilation.
		20
		21	The speed improvements are also not great, you can expect 20% or so on
		22	average, for code that runs very often. The reason for this is that data
		23	handling is mostly being done by the same old code, it just gets called
		24	a bit faster. Regexes and string operations won't get faster. Airhtmetic
		25	doresn't become any faster. Just the operands and other stuff is put on
		26	the stack faster, and the opcodes themselves have a bit less overhead.
		27
		28	Faster is in the early stages of development. Due to its design its
		29	relatively safe to use (it will either work or simply slowdown the program
		30	immensely, but rarely cause bugs).
		31
		32	More intelligent algorithms (loop optimisation, type inference) could
		33	improve that easily, but requires a much more elaborate presentation and
		34	optimiser than what is in place. There are no plans to improve Faster in
		35	this way, yet, but it would provide a reasonably good place to start.
		36
		37	Usage is very easy, just C<use Faster> and every function called from then
		38	on will be compiled.
		39
		40	Right now, Faster can leave lots of F<.c> and F<.so> files in your
		41	F<$FASTER_CACHEDIR> (by default F<$HOME/.perl-faster-cache>), and it will
		42	even create those temporary files in an insecure manner, so watch out.
		43
11	=over 4	44	=over 4
12		45
13	=cut	46	=cut
14		47
15	package Faster;	48	package Faster;
		49
		50	no warnings;
16		51
17	use strict;	52	use strict;
18	use Config;	53	use Config;
19	use B ();	54	use B ();
		55	use DynaLoader ();
20	use Digest::MD5 ();	56	use Digest::MD5 ();
21	use DynaLoader ();	57	use Storable ();
		58	use Fcntl ();
22		59
23	BEGIN {	60	BEGIN {
24	our $VERSION = '0.01';	61	our $VERSION = '0.01';
25		62
26	require XSLoader;	63	require XSLoader;
27	XSLoader::load __PACKAGE__, $VERSION;	64	XSLoader::load __PACKAGE__, $VERSION;
28	}	65	}
		66
		67	my $CACHEDIR =
		68	$ENV{FASTER_CACHE}
		69	\|\| (exists $ENV{HOME} && "$ENV{HOME}/.perl-faster-cache")
		70	\|\| do {
		71	require File::Temp;
		72	File::Temp::tempdir (CLEANUP => 1)
		73	};
29		74
30	my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}";	75	my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}";
31	my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";	76	my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
32	my $LIBS = "$Config{libs}";	77	my $LIBS = "$Config{libs}";
33	my $_o = $Config{_o};	78	my $_o = $Config{_o};
34	my $_so = ".so";	79	my $_so = ".so";
35		80
		81	# we don't need no steenking PIC on x86
		82	$COMPILE =~ s/-f(?:PIC\|pic)//g
		83	if $Config{archname} =~ /^(i[3456]86)-/;
		84
		85	my $opt_assert = $ENV{FASTER_DEBUG} > 1;
		86	my $verbose = $ENV{FASTER_VERBOSE}+0;
		87
		88	warn "Faster: CACHEDIR is $CACHEDIR\n" if $verbose > 2;
		89
36	our $source;	90	our $source;
37	our $label_next;
38	our $label_last;
39	our $label_redo;
40		91
41	my %flag;	92	our @ops;
		93	our $insn;
		94	our $op;
		95	our $op_name;
		96	our @op_loop;
		97	our %op_regcomp;
42		98
43	for (split /\n/, <<EOF) {	99	# ops that cause immediate return to the interpreter
44	leavesub unsafe	100	my %f_unsafe = map +($_ => undef), qw(
45	leavesublv unsafe	101	leavesub leavesublv return
46	return unsafe	102	goto last redo next
47	flip unsafe	103	eval flip leaveeval entertry
48	goto unsafe	104	formline grepstart mapstart
49	last unsafe	105	substcont entereval require
50	redo unsafe	106	);
51	next unsafe
52	eval unsafe
53	leaveeval unsafe
54	entertry unsafe
55	substconst unsafe
56	formline unsafe
57	grepstart unsafe
58	require unsafe
59	match unsafe todo
60	subst unsafe todo
61	entereval unsafe todo
62	mapstart unsafe todo
63		107
64	pushmark noasync	108	# ops with known stack extend behaviour
65	padsv noasync	109	# the values given are maximum values
66	entersub noasync	110	my %extend = (
67	aassign noasync	111	pushmark => 0,
68	sassign noasync	112	nextstate => 0, # might reduce the stack
69	rv2av noasync	113	unstack => 0,
70	nextstate noasync	114	enter => 0,
71	gv noasync
72	gvsv noasync
73	add noasync
74	subtract noasync
75	multiply noasync
76	divide noasync
77	complement noasync
78	cond_expr noasync
79	and noasync
80	or noasync
81	not noasync
82	method_named noasync
83	preinc noasync
84	postinc noasync
85	predec noasync
86	postdec noasync
87	stub noasync
88	unstack noasync
89	leaveloop noasync
90	shift noasync
91	aelemA noasync
92	aelemfast noasync
93	EOF
94	my (undef, $op, @flags) = split /\s+/;
95		115
96	undef $flag{$_}{$op}	116	stringify => 0,
97	for ("known", @flags);	117	not => 0,
		118	and => 0,
		119	or => 0,
		120	gvsv => 0,
		121	rv2gv => 0,
		122	preinc => 0,
		123	predec => 0,
		124	postinc => 0,
		125	postdec => 0,
		126	aelem => 0,
		127	helem => 0,
		128	qr => 1, #???
		129	pushre => 1,
		130	gv => 1,
		131	aelemfast => 1,
		132	aelem => 0,
		133	padsv => 1,
		134	const => 1,
		135	pop => 1,
		136	shift => 1,
		137	eq => -1,
		138	ne => -1,
		139	gt => -1,
		140	lt => -1,
		141	ge => -1,
		142	lt => -1,
		143	cond_expr => -1,
		144	add => -1,
		145	subtract => -1,
		146	multiply => -1,
		147	divide => -1,
		148	aassign => 0,
		149	sassign => -2,
		150	method => 0,
		151	method_named => 1,
		152	);
		153
		154	# ops that do not need an ASYNC_CHECK
		155	my %f_noasync = map +($_ => undef), qw(
		156	mapstart grepstart match entereval
		157	enteriter entersub leaveloop
		158
		159	pushmark nextstate caller
		160
		161	const stub unstack
		162	last next redo goto seq
		163	padsv padav padhv padany
		164	aassign sassign orassign
		165	rv2av rv2cv rv2gv rv2hv refgen
		166	gv gvsv
		167	add subtract multiply divide
		168	complement cond_expr and or not
		169	bit_and bit_or bit_xor
		170	defined
		171	method method_named bless
		172	preinc postinc predec postdec
		173	aelem aelemfast helem delete exists
		174	pushre subst list lslice join split concat
		175	length substr stringify ord
		176	push pop shift unshift
		177	eq ne gt lt ge le
		178	regcomp regcreset regcmaybe
		179	);
		180
		181	my %callop = (
		182	entersub => "(PL_op->op_ppaddr) (aTHX)",
		183	mapstart => "Perl_pp_grepstart (aTHX)",
		184	);
		185
		186	sub callop {
		187	$callop{$op_name} \|\| "Perl_pp_$op_name (aTHX)"
		188	}
		189
		190	sub assert {
		191	return unless $opt_assert;
		192	$source .= " assert ((\"$op_name\", ($_[0])));\n";
		193	}
		194
		195	sub out_callop {
		196	assert "nextop == (OP *)$$op";
		197	$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
		198	}
		199
		200	sub out_cond_jump {
		201	$source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
		202	}
		203
		204	sub out_jump_next {
		205	out_cond_jump $op_regcomp{$$op}
		206	if $op_regcomp{$$op};
		207
		208	assert "nextop == (OP *)${$op->next}";
		209	$source .= " goto op_${$op->next};\n";
98	}	210	}
99		211
100	sub out_next {	212	sub out_next {
101	my ($op) = @_;
102
103	if (${$op->next}) {
104	$source .= " nextop = (OP *)${$op->next}L;\n";	213	$source .= " nextop = (OP *)${$op->next}L;\n";
105	$source .= " goto op_${$op->next};\n";
106	} else {
107	$source .= " return 0;\n";
108	}
109	}
110		214
111	sub callop {	215	out_jump_next;
112	my ($op) = @_;
113
114	my $name = $op->name;
115
116	$name eq "entersub"
117	? "(PL_ppaddr [OP_ENTERSUB]) (aTHX)"
118	: $name eq "mapstart"
119	? "Perl_pp_grepstart (aTHX)"
120	: "Perl_pp_$name (aTHX)"
121	}	216	}
		217
		218	sub out_linear {
		219	out_callop;
		220	out_jump_next;
		221	}
		222
		223	sub op_entersub {
		224	out_callop;
		225	$source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n";
		226	out_jump_next;
		227	}
		228
		229	*op_require = \&op_entersub;
122		230
123	sub op_nextstate {	231	sub op_nextstate {
124	my ($op) = @_;
125
126	$source .= " PL_curcop = (COP *)nextop;\n";	232	$source .= " PL_curcop = (COP *)nextop;\n";
127	$source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";	233	$source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
128	$source .= " FREETMPS;\n";	234	$source .= " FREETMPS;\n";
129		235
130	out_next $op;	236	out_next;
131	}	237	}
132		238
133	sub op_pushmark {	239	sub op_pushmark {
134	my ($op) = @_;
135
136	$source .= " PUSHMARK (PL_stack_sp);\n";	240	$source .= " faster_PUSHMARK (PL_stack_sp);\n";
137		241
138	out_next $op;	242	out_next;
139	}	243	}
140		244
141	sub op_const {	245	if ($Config{useithreads} ne "define") {
142	my ($op) = @_;	246	# disable optimisations on ithreads
143		247
		248	*op_const = sub {
144	$source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";	249	$source .= " { dSP; PUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
145		250
		251	$ops[0]{follows_const}++ if @ops;#d#
		252
146	out_next $op;	253	out_next;
147	}	254	};
148		255
149	*op_gv = \&op_const;	256	*op_gv = \&op_const;
150		257
		258	*op_aelemfast = sub {
		259	my $targ = $op->targ;
		260	my $private = $op->private;
		261
		262	$source .= " {\n";
		263
		264	if ($op->flags & B::OPf_SPECIAL) {
		265	$source .= " AV av = (AV)PAD_SV((PADOFFSET)$targ);\n";
		266	} else {
		267	$source .= " AV av = GvAV ((GV )${$op->sv}L);\n";
		268	}
		269
		270	if ($op->flags & B::OPf_MOD) {
		271	$source .= " SV sv = av_fetch (av, $private, 1);\n";
		272	} else {
		273	$source .= " SV *svp = av_fetch (av, $private, 0); SV sv = svp ? *svp : &PL_sv_undef;\n";
		274	}
		275
		276	if (!($op->flags & B::OPf_MOD)) {
		277	$source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
		278	}
		279
		280	$source .= " dSP;\n";
		281	$source .= " PUSHs (sv);\n";
		282	$source .= " PUTBACK;\n";
		283	$source .= " }\n";
		284
		285	out_next;
		286	};
		287
		288	*op_gvsv = sub {
		289	$source .= " {\n";
		290	$source .= " dSP;\n";
		291
		292	if ($op->private & B::OPpLVAL_INTRO) {
		293	$source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
		294	} else {
		295	$source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
		296	}
		297
		298	$source .= " PUTBACK;\n";
		299	$source .= " }\n";
		300
		301	out_next;
		302	};
		303	}
		304
		305	# does kill Crossfire/res2pm
151	sub op_stringify {	306	sub op_stringify {
152	my ($op) = @_;	307	my $targ = $op->targ;
153		308
154	$source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n";	309	$source .= <<EOF;
		310	{
		311	dSP;
		312	SV *targ = PAD_SV ((PADOFFSET)$targ);
		313	sv_copypv (TARG, TOPs);
		314	SETTARG;
		315	PUTBACK;
		316	}
		317	EOF
155		318
156	out_next $op;	319	out_next;
157	}	320	}
158		321
159	sub op_and {	322	sub op_and {
160	my ($op) = @_;
161
162	$source .= <<EOF;	323	$source .= <<EOF;
163	{	324	{
164	dSP;	325	dSP;
165		326
166	if (SvTRUE (TOPs))	327	if (SvTRUE (TOPs))
…		…
171	goto op_${$op->other};	332	goto op_${$op->other};
172	}	333	}
173	}	334	}
174	EOF	335	EOF
175		336
176	out_next $op;	337	out_next;
177	}	338	}
178		339
179	sub op_padsv {	340	sub op_or {
180	my ($op) = @_;
181
182	my $flags = $op->flags;
183	my $target = $op->targ;
184
185	$source .= <<EOF;	341	$source .= <<EOF;
186	{	342	{
187	dSP;	343	dSP;
188	XPUSHs (PAD_SV ((PADOFFSET)$target));	344
189	PUTBACK;	345	if (!SvTRUE (TOPs))
190	EOF
191	if ($op->flags & B::OPf_MOD) {
192	if ($op->private & B::OPpLVAL_INTRO) {
193	$source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n";
194	} elsif ($op->private & B::OPpDEREF) {
195	my $deref = $op->private & B::OPpDEREF;
196	$source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
197	}	346	{
198	}	347	--SP;
199	$source .= <<EOF;	348	PUTBACK;
		349	nextop = (OP *)${$op->other}L;
		350	goto op_${$op->other};
		351	}
200	}	352	}
201	EOF	353	EOF
202		354
203	out_next $op;	355	out_next;
204	}	356	}
205		357
206	sub op_aelemfast {	358	sub op_padsv {
207	my ($op) = @_;
208
209	my $targ = $op->targ;	359	my $flags = $op->flags;
210	my $private = $op->private;	360	my $padofs = "(PADOFFSET)" . $op->targ;
211
212	$source .= " {\n";
213
214	if ($op->flags & B::OPf_SPECIAL) {
215	$source .= " AV av = (AV)PAD_SV((PADOFFSET)$targ);\n";
216	} else {
217	$source .= " AV av = GvAV ((GV )${$op->sv}L);\n";
218	}
219
220	if ($op->flags & B::OPf_MOD) {
221	$source .= " SV sv = av_fetch (av, $private, 1);\n";
222	} else {
223	$source .= " SV *svp = av_fetch (av, $private, 0); SV sv = svp ? *svp : &PL_sv_undef;\n";
224	}
225
226	if (!($op->flags & B::OPf_MOD)) {
227	$source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
228	}
229
230	$source .= " dSP;\n";
231	$source .= " XPUSHs (sv);\n";
232	$source .= " PUTBACK;\n";
233	$source .= " }\n";
234
235	out_next $op;
236	}
237
238	# pattern const+ (or general push1)
239	# pattern pushmark return(?)
240	# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
241
242	# pattern const method_named
243	sub op_method_named {
244	my ($op) = @_;
245		361
246	$source .= <<EOF;	362	$source .= <<EOF;
247	{	363	{
		364	dSP;
		365	SV *sv = PAD_SVl ($padofs);
		366	EOF
		367
		368	if (($flags & B::OPf_MOD) && ($op->private & B::OPpLVAL_INTRO)) {
		369	$source .= " SAVECLEARSV (PAD_SVl ($padofs));\n";
		370	$ops[0]{follows_padsv_lval_intro}++ if @ops;#d#
		371	}
		372
		373	$source .= <<EOF;
		374	PUSHs (sv);
		375	PUTBACK;
		376	EOF
		377
		378	if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
		379	$source .= " if (!SvROK (sv)) vivify_ref (sv, " . $op->private . " & OPpDEREF);\n";
		380	}
		381	$source .= " }\n";
		382
		383	out_next;
		384	}
		385
		386	sub op_sassign {
		387	$source .= <<EOF;
		388	{
		389	dSP;
		390	dPOPTOPssrl;
		391	EOF
		392	$source .= " SV *temp = left; left = right; right = temp;\n"
		393	if $op->private & B::OPpASSIGN_BACKWARDS;
		394
		395	if ($insn->{follows_padsv_lval_intro} && !($op->private & B::OPpASSIGN_BACKWARDS)) {
		396	# simple assignment - the target exists, but is basically undef
		397	$source .= " SvSetSV (right, left);\n";
		398	} else {
		399	$source .= " SvSetMagicSV (right, left);\n";
		400	}
		401
		402	$source .= <<EOF;
		403	SETs (right);
		404	PUTBACK;
		405	}
		406	EOF
		407
		408	out_next;
		409	}
		410
		411	# pattern const+ (or general push1)
		412	# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
		413
		414	sub op_method_named {
		415	if ($insn->{follows_const}) {
		416	$source .= <<EOF;
		417	{
		418	dSP;
		419	static SV *last_cv;
		420	static U32 last_sub_generation;
		421
		422	/* simple "polymorphic" inline cache */
		423	if (PL_sub_generation == last_sub_generation)
		424	{
		425	PUSHs (last_cv);
		426	PUTBACK;
		427	}
		428	else
		429	{
		430	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
		431
		432	SPAGAIN;
		433	last_sub_generation = PL_sub_generation;
		434	last_cv = TOPs;
		435	}
		436	}
		437	EOF
		438	} else {
		439	$source .= <<EOF;
		440	{
248	static HV *last_stash;	441	static HV *last_stash;
249	static SV *last_res;	442	static SV *last_cv;
		443	static U32 last_sub_generation;
250		444
251	SV obj = (PL_stack_base + TOPMARK + 1);	445	SV obj = (PL_stack_base + TOPMARK + 1);
252		446
253	if (SvROK (obj) && SvOBJECT (SvRV (obj)))	447	if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
254	{	448	{
255	dSP;	449	dSP;
256	HV *stash = SvSTASH (SvRV (obj));	450	HV *stash = SvSTASH (SvRV (obj));
257		451
258	/* simple "polymorphic" inline cache */	452	/* simple "polymorphic" inline cache */
259	if (stash == last_stash)	453	if (stash == last_stash
		454	&& PL_sub_generation == last_sub_generation)
260	{	455	{
261	XPUSHs (last_res);	456	PUSHs (last_cv);
262	PUTBACK;	457	PUTBACK;
263	}	458	}
264	else	459	else
265	{	460	{
266	PL_op = nextop;
267	nextop = Perl_pp_method_named (aTHX);	461	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
268		462
269	SPAGAIN;	463	SPAGAIN;
		464	last_sub_generation = PL_sub_generation;
270	last_stash = stash;	465	last_stash = stash;
271	last_res = TOPs;	466	last_cv = TOPs;
272	}	467	}
273	}	468	}
274	else	469	else
275	{	470	{
276	/* error case usually */	471	/* error case usually */
277	PL_op = nextop;
278	nextop = Perl_pp_method_named (aTHX);	472	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
279	}	473	}
280	}	474	}
281	EOF	475	EOF
		476	}
282		477
283	out_next $op;	478	out_next;
		479	}
		480
		481	sub op_grepstart {
		482	out_callop;
		483	$op = $op->next;
		484	out_cond_jump $op->other;
		485	out_jump_next;
		486	}
		487
		488	*op_mapstart = \&op_grepstart;
		489
		490	sub op_substcont {
		491	out_callop;
		492	out_cond_jump $op->other->pmreplstart;
		493	assert "nextop == (OP *)${$op->other->next}L";
		494	$source .= " goto op_${$op->other->next};\n";
		495	}
		496
		497	sub out_break_op {
		498	my ($idx) = @_;
		499
		500	out_callop;
		501
		502	out_cond_jump $_->[$idx]
		503	for reverse @op_loop;
		504
		505	$source .= " return nextop;\n";
		506	}
		507
		508	sub xop_next {
		509	out_break_op 0;
		510	}
		511
		512	sub op_last {
		513	out_break_op 1;
		514	}
		515
		516	sub xop_redo {
		517	out_break_op 2;
284	}	518	}
285		519
286	sub cv2c {	520	sub cv2c {
287	my ($cv) = @_;	521	my ($cv) = @_;
288		522
		523	local @ops;
		524	local @op_loop;
		525	local %op_regcomp;
		526
289	my %opsseen;	527	my %opsseen;
290	my @ops;
291	my @todo = $cv->START;	528	my @todo = $cv->START;
		529	my %op_target;
		530	my $numpushmark;
292		531
293	while (my $op = shift @todo) {	532	while (my $op = shift @todo) {
294	for (; $$op; $op = $op->next) {	533	for (; $$op; $op = $op->next) {
295	last if $opsseen{$$op}++;	534	last if $opsseen{$$op}++;
296	push @ops, $op;	535
297	my $name = $op->name;	536	my $name = $op->name;
		537	my $class = B::class $op;
		538
		539	my $insn = { op => $op };
		540
		541	push @ops, $insn;
		542
		543	if (exists $extend{$name}) {
		544	my $extend = $extend{$name};
		545	$extend = $extend->($op) if ref $extend;
		546	$insn->{extend} = $extend if defined $extend;
		547	}
		548
		549	push @todo, $op->next;
		550
298	if (B::class($op) eq "LOGOP") {	551	if ($class eq "LOGOP") {
299	push @todo, $op->other;	552	push @todo, $op->other;
300	} elsif ($name eq "subst" and ${ $op->pmreplstart }) {	553	$op_target{${$op->other}}++;
301	push @todo, $op->pmreplstart;	554
302	} elsif ($name =~ /^enter(loop\|iter)$/) {	555	# regcomp/o patches ops at runtime, lets expect that
303	# if ($] > 5.009) {	556	if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
304	# $labels{${$op->nextop}} = "NEXT";	557	$op_target{${$op->first}}++;
305	# $labels{${$op->lastop}} = "LAST";	558	$op_regcomp{${$op->first}} = $op->next;
306	# $labels{${$op->redoop}} = "REDO";
307	# } else {
308	# $labels{$op->nextop->seq} = "NEXT";
309	# $labels{$op->lastop->seq} = "LAST";
310	# $labels{$op->redoop->seq} = "REDO";
311	# }	559	}
		560
		561	} elsif ($class eq "PMOP") {
		562	if (${$op->pmreplstart}) {
		563	unshift @todo, $op->pmreplstart;
		564	$op_target{${$op->pmreplstart}}++;
		565	}
		566
		567	} elsif ($class eq "LOOP") {
		568	my @targ = ($op->nextop, $op->lastop->next, $op->redoop->next);
		569
		570	push @op_loop, \@targ;
		571	push @todo, @targ;
		572
		573	$op_target{$$_}++ for @targ;
		574
		575	} elsif ($class eq "COP") {
		576	$insn->{bblock}++ if defined $op->label;
		577
		578	} else {
		579	if ($name eq "pushmark") {
		580	$numpushmark++;
		581	}
312	}	582	}
313	}	583	}
314	}	584	}
315		585
		586	$_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
		587
316	local $source = <<EOF;	588	local $source = <<EOF;
		589	OP *%%%FUNC%%% (pTHX)
		590	{
		591	register OP nextop = (OP )${$ops[0]->{op}}L;
		592	EOF
		593
		594	$source .= " faster_PUSHMARK_PREALLOC ($numpushmark);\n"
		595	if $numpushmark;
		596
		597	while (@ops) {
		598	$insn = shift @ops;
		599
		600	$op = $insn->{op};
		601	$op_name = $op->name;
		602
		603	my $class = B::class $op;
		604
		605	$source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
		606	$source .= "op_$$op: /* $op_name */\n";
		607	#$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
		608	#$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
		609
		610	$source .= " PERL_ASYNC_CHECK ();\n"
		611	unless exists $f_noasync{$op_name};
		612
		613	if (my $can = __PACKAGE__->can ("op_$op_name")) {
		614	# handcrafted replacement
		615
		616	if ($insn->{extend} > 0) {
		617	# coalesce EXTENDs
		618	# TODO: properly take negative preceeding and following EXTENDs into account
		619	for my $i (@ops) {
		620	last if exists $i->{bblock};
		621	last unless exists $i->{extend};
		622	my $extend = delete $i->{extend};
		623	$insn->{extend} += $extend if $extend > 0;
		624	}
		625
		626	$source .= " { dSP; EXTEND (SP, $insn->{extend}); PUTBACK; }\n"
		627	if $insn->{extend} > 0;
		628	}
		629
		630	$can->($op);
		631
		632	} elsif (exists $f_unsafe{$op_name}) {
		633	# unsafe, return to interpreter
		634	assert "nextop == (OP *)$$op";
		635	$source .= " return nextop;\n";
		636
		637	} elsif ("LOGOP" eq $class) {
		638	# logical operation with optional branch
		639	out_callop;
		640	out_cond_jump $op->other;
		641	out_jump_next;
		642
		643	} elsif ("PMOP" eq $class) {
		644	# regex-thingy
		645	out_callop;
		646	out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
		647	out_jump_next;
		648
		649	} else {
		650	# normal operator, linear execution
		651	out_linear;
		652	}
		653	}
		654
		655	$op_name = "func exit"; assert (0);
		656
		657	$source .= <<EOF;
		658	op_0:
		659	return 0;
		660	}
		661	EOF
		662	#warn $source;
		663
		664	$source
		665	}
		666
		667	my $uid = "aaaaaaa0";
		668	my %so;
		669
		670	sub func2ptr {
		671	my (@func) = @_;
		672
		673	#LOCK
		674	mkdir $CACHEDIR, 0777;
		675	sysopen my $meta_fh, "$CACHEDIR/meta", &Fcntl::O_RDWR \| &Fcntl::O_CREAT, 0666
		676	or die "$$CACHEDIR/meta: $!";
		677	binmode $meta_fh, ":raw:perlio";
		678	fcntl_lock fileno $meta_fh
		679	or die "$CACHEDIR/meta: $!";
		680
		681	my $meta = eval { Storable::fd_retrieve $meta_fh } \|\| { version => 1 };
		682
		683	for my $f (@func) {
		684	$f->{func} = "F" . Digest::MD5::md5_hex ($f->{source});
		685	$f->{so} = $meta->{$f->{func}};
		686	}
		687
		688	if (grep !$_->{so}, @func) {
		689	my $stem;
		690
		691	do {
		692	$stem = "$CACHEDIR/$$-" . $uid++;
		693	} while -e "$stem$_so";
		694
		695	open my $fh, ">:raw", "$stem.c";
		696	print $fh <<EOF;
317	#define PERL_NO_GET_CONTEXT	697	#define PERL_NO_GET_CONTEXT
		698	#define PERL_CORE
318		699
319	#include <assert.h>	700	#include <assert.h>
320		701
321	#include "EXTERN.h"	702	#include "EXTERN.h"
322	#include "perl.h"	703	#include "perl.h"
323	#include "XSUB.h"	704	#include "XSUB.h"
324		705
325	/typedef OP (PPFUNC)(pTHX);/	706	#if 1
326		707	# define faster_PUSHMARK_PREALLOC(count) while (PL_markstack_ptr + (count) >= PL_markstack_max) markstack_grow ()
327	OP *%%%FUNC%%% (pTHX)	708	# define faster_PUSHMARK(p) *++PL_markstack_ptr = (p) - PL_stack_base
328	{	709	#else
329	register OP nextop = (OP )${$ops[0]}L;	710	# define faster_PUSHMARK_PREALLOC(count) 1
330	EOF	711	# define faster_PUSHMARK(p) PUSHMARK(p)
		712	#endif
331		713
332	for my $op (@ops) {	714	#define RUNOPS_TILL(op) \\
333	my $name = $op->name;	715	while (nextop != (op)) \\
334	my $ppaddr = ppaddr $op->type;	716	{ \\
335
336	$source .= "op_$$op: /* $name */\n";
337	#$source .= "fprintf (stderr, \"$$op in op $name\\n\");\n";#d#
338	#$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
339
340	unless (exists $flag{noasync}{$name}) {
341	$source .= " PERL_ASYNC_CHECK ();\n";
342	}
343
344	if (my $can = __PACKAGE__->can ("op_$name")) {
345	$can->($op);
346	} elsif (exists $flag{unsafe}{$name}) {
347	$source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
348	$source .= " PL_op = nextop; return " . (callop $op) . ";\n";
349	} elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) {
350	$source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
351	$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
352	$source .= " if (nextop == (OP *)${$op->other}L) goto op_${$op->other};\n";
353	$source .= " assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#
354	$source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";
355	} else {
356	$source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
357	$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
358	if ($name eq "entersub") {
359	$source .= <<EOF;
360	while (nextop != (OP *)${$op->next})
361	{
362	PERL_ASYNC_CHECK ();	717	PERL_ASYNC_CHECK (); \\
363	PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX);	718	PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
364	}
365	EOF
366	}
367	$source .= " assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#
368	$source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";
369	}
370	}	719	}
371		720
372	$source .= "}\n";	721	EOF
373	#warn $source;	722	for my $f (grep !$_->{so}, @func) {
		723	next if $f->{so} = $meta->{$f->{func}}; # some cv's alias others
374		724
375	$source	725	warn "compiling $f->{name} to $stem$_so:$f->{func}\n" if $verbose > 1;
376	}	726	my $source = $f->{source};
377		727	$source =~ s/%%%FUNC%%%/$f->{func}/g;
378	sub source2ptr {
379	my ($source) = @_;
380
381	my $md5 = Digest::MD5::md5_hex $source;
382	$source =~ s/%%%FUNC%%%/Faster_$md5/;
383
384	my $stem = "/tmp/$md5";
385
386	unless (-e "$stem$_so") {
387	open FILE, ">:raw", "$stem.c";
388	print FILE $source;	728	print $fh $source;
		729	$meta->{$f->{func}} = $f->{so} = $stem;
		730	}
		731
389	close FILE;	732	close $fh;
390	system "$COMPILE -o $stem$_o $stem.c";	733	system "$COMPILE -o $stem$_o $stem.c";
		734	unlink "$stem.c" unless $ENV{FASTER_DEBUG} > 0;
391	system "$LINK -o $stem$_so $stem$_o $LIBS";	735	system "$LINK -o $stem$_so $stem$_o $LIBS";
		736	unlink "$stem$_o";
392	}	737	}
393		738
394	# warn $source;	739	for my $f (@func) {
		740	my $stem = $f->{so};
		741
395	my $so = DynaLoader::dl_load_file "$stem$_so"	742	my $so = ($so{$stem} \|\|= DynaLoader::dl_load_file "$stem$_so")
396	or die "$stem$_so: $!";	743	or die "$stem$_so: $!";
397		744
398	DynaLoader::dl_find_symbol $so, "Faster_$md5"	745	#unlink "$stem$_so";
399	or die "Faster_$md5: $!"	746
		747	$f->{ptr} = DynaLoader::dl_find_symbol $so, $f->{func}
		748	or die "$f->{func} not found in $stem$_so: $!";
		749	}
		750
		751	seek $meta_fh, 0, 0 or die "$CACHEDIR/meta: $!";
		752	Storable::nstore_fd $meta, $meta_fh;
		753	truncate $meta_fh, tell $meta_fh;
		754
		755	# UNLOCK (by closing $meta_fh)
400	}	756	}
		757
		758	my %ignore;
401		759
402	sub entersub {	760	sub entersub {
403	my ($cv) = @_;	761	my ($cv) = @_;
404		762
		763	my $pkg = $cv->STASH->NAME;
		764
		765	return if $ignore{$pkg};
		766
		767	warn "optimising ", $cv->STASH->NAME, "\n"
		768	if $verbose;
		769
405	eval {	770	eval {
		771	my @func;
		772
		773	push @func, {
		774	cv => $cv,
		775	name => "<>",
406	my $source = cv2c $cv;	776	source => cv2c $cv,
		777	};
407		778
408	my $ptr = source2ptr $source;	779	# always compile the whole stash
		780	my %stash = $cv->STASH->ARRAY;
		781	while (my ($k, $v) = each %stash) {
		782	$v->isa (B::GV::)
		783	or next;
409		784
		785	my $cv = $v->CV;
		786
		787	if ($cv->isa (B::CV::)
		788	&& ${$cv->START}
		789	&& $cv->START->name ne "null") {
		790
		791	push @func, {
		792	cv => $cv,
		793	name => $k,
		794	source => cv2c $cv,
		795	};
		796	}
		797	}
		798
		799	func2ptr @func;
		800
		801	for my $f (@func) {
410	patch_cv $cv, $ptr;	802	patch_cv $f->{cv}, $f->{ptr};
		803	}
411	};	804	};
412		805
413	warn $@ if $@;	806	if ($@) {
		807	$ignore{$pkg}++;
		808	warn $@;
		809	}
414	}	810	}
415		811
416	hook_entersub;	812	hook_entersub;
417		813
418	1;	814	1;
419		815
420	=back	816	=back
421		817
		818	=head1 ENVIRONMENT VARIABLES
		819
		820	The following environment variables influence the behaviour of Faster:
		821
		822	=over 4
		823
		824	=item FASTER_VERBOSE
		825
		826	Faster will output more informational messages when set to values higher
		827	than C<0>. Currently, C<1> outputs which packages are being compiled, C<3>
		828	outputs the cache directory and C<10> outputs information on which perl
		829	function is compiled into which shared object.
		830
		831	=item FASTER_DEBUG
		832
		833	Add debugging code when set to values higher than C<0>. Currently, this
		834	adds 1-3 C<assert>'s per perl op (FASTER_DEBUG > 1), to ensure that opcode
		835	order and C execution order are compatible.
		836
		837	=item FASTER_CACHE
		838
		839	Set a persistent cache directory that caches compiled code fragments. The
		840	default is C<$HOME/.perl-faster-cache> if C<HOME> is set and a temporary
		841	directory otherwise.
		842
		843	This directory will always grow in size, so you might need to erase it
		844	from time to time.
		845
		846	=back
		847
422	=head1 LIMITATIONS	848	=head1 BUGS/LIMITATIONS
423		849
424	Tainting and debugging will disable Faster.	850	Perl will check much less often for asynchronous signals in
		851	Faster-compiled code. It tries to check on every function call, loop
		852	iteration and every I/O operator, though.
		853
		854	The following things will disable Faster. If you manage to enable them at
		855	runtime, bad things will happen. Enabling them at startup will be fine,
		856	though.
		857
		858	enabled tainting
		859	enabled debugging
		860
		861	Thread-enabled builds of perl will dramatically reduce Faster's
		862	performance, but you don't care about speed if you enable threads anyway.
		863
		864	These constructs will force the use of the interpreter for the currently
		865	executed function as soon as they are being encountered during execution.
		866
		867	goto
		868	next, redo (but not well-behaved last's)
		869	eval
		870	require
		871	any use of formats
		872	.., ... (flipflop operators)
425		873
426	=head1 AUTHOR	874	=head1 AUTHOR
427		875
428	Marc Lehmann <schmorp@schmorp.de>	876	Marc Lehmann <schmorp@schmorp.de>
429	http://home.schmorp.de/	877	http://home.schmorp.de/

Diff Legend

-–
+Removed lines
-+
+Added lines
-<
+Changed lines
->
+Changed lines

Comparing Faster/Faster.pm (file contents): Revision 1.6 by root, Fri Mar 10 00:11:44 2006 UTC vs. Revision 1.33 by root, Mon Mar 13 17:10:32 2006 UTC

Diff Legend

Comparing Faster/Faster.pm (file contents):
Revision 1.6 by root, Fri Mar 10 00:11:44 2006 UTC vs.
Revision 1.33 by root, Mon Mar 13 17:10:32 2006 UTC