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