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

Comparing Faster/Faster.pm (file contents):
Revision 1.9 by root, Fri Mar 10 01:55:12 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 @ops;	92	our @ops;
42	my $op;	93	our $insn;
		94	our $op;
43	my $op_name;	95	our $op_name;
		96	our @op_loop;
		97	our %op_regcomp;
44		98
45	my %flag;	99	# ops that cause immediate return to the interpreter
		100	my %f_unsafe = map +($_ => undef), qw(
		101	leavesub leavesublv return
		102	goto last redo next
		103	eval flip leaveeval entertry
		104	formline grepstart mapstart
		105	substcont entereval require
		106	);
46		107
47	for (split /\n/, <<EOF) {	108	# ops with known stack extend behaviour
48	leavesub unsafe	109	# the values given are maximum values
49	leavesublv unsafe	110	my %extend = (
50	return unsafe	111	pushmark => 0,
51	flip unsafe	112	nextstate => 0, # might reduce the stack
52	goto unsafe	113	unstack => 0,
53	last unsafe	114	enter => 0,
54	redo unsafe
55	next unsafe
56	eval unsafe
57	leaveeval unsafe
58	entertry unsafe
59	substconst unsafe
60	formline unsafe
61	grepstart unsafe
62	require unsafe
63	match unsafe noasync todo
64	subst unsafe noasync todo
65	entereval unsafe noasync todo
66	mapstart unsafe noasync todo
67		115
68	mapwhile noasync	116	stringify => 0,
69	grepwhile noasync	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	);
70		153
71	seq noasync	154	# ops that do not need an ASYNC_CHECK
72	pushmark noasync	155	my %f_noasync = map +($_ => undef), qw(
73	padsv noasync extend=1	156	mapstart grepstart match entereval
74	padav noasync extend=1	157	enteriter entersub leaveloop
75	padhv noasync extend=1
76	padany noasync extend=1
77	entersub noasync
78	aassign noasync
79	sassign noasync
80	rv2av noasync
81	rv2cv noasync
82	rv2gv noasync
83	rv2hv noasync
84	refgen noasync
85	nextstate noasync
86	gv noasync
87	gvsv noasync
88	add noasync
89	subtract noasync
90	multiply noasync
91	divide noasync
92	complement noasync
93	cond_expr noasync
94	and noasync
95	or noasync
96	not noasync
97	defined noasync
98	method_named noasync
99	preinc noasync
100	postinc noasync
101	predec noasync
102	postdec noasync
103	stub noasync
104	unstack noasync
105	leaveloop noasync
106	aelem noasync
107	aelemfast noasync
108	helem noasync
109	pushre noasync
110	const noasync extend=1
111	list noasync
112	join noasync
113	split noasync
114	concat noasync
115	push noasync
116	pop noasync
117	shift noasync
118	unshift noasync
119	require noasync
120	length noasync
121	substr noasync
122	stringify noasync
123	eq noasync
124	ne noasync
125	gt noasync
126	lt noasync
127	ge noasync
128	le noasync
129	enteriter noasync
130		158
131	iter async	159	pushmark nextstate caller
132	EOF
133	my (undef, $op, @flags) = split /\s+/;
134		160
135	undef $flag{$_}{$op}	161	const stub unstack
136	for ("known", @flags);	162	last next redo goto seq
137	}	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	);
138		185
139	sub callop {	186	sub callop {
140	$op_name eq "entersub"	187	$callop{$op_name} \|\| "Perl_pp_$op_name (aTHX)"
141	? "(PL_ppaddr [OP_ENTERSUB]) (aTHX)"
142	: $op_name eq "mapstart"
143	? "Perl_pp_grepstart (aTHX)"
144	: "Perl_pp_$op_name (aTHX)"
145	}	188	}
146		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
147	sub out_gotonext {	204	sub out_jump_next {
148	if (${$op->next}) {	205	out_cond_jump $op_regcomp{$$op}
149	$source .= " assert ((\"$op_name\", nextop == (OP *)${$op->next}));\n";	206	if $op_regcomp{$$op};
		207
		208	assert "nextop == (OP *)${$op->next}";
150	$source .= " goto op_${$op->next};\n";	209	$source .= " goto op_${$op->next};\n";
151	} else {
152	$source .= " return 0;\n";
153	}
154	}	210	}
155		211
156	sub out_next {	212	sub out_next {
157	$source .= " nextop = (OP *)${$op->next}L;\n";	213	$source .= " nextop = (OP *)${$op->next}L;\n";
158		214
159	out_gotonext;	215	out_jump_next;
160	}	216	}
161		217
162	sub out_linear {	218	sub out_linear {
163	$source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";#d#	219	out_callop;
164	$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";	220	out_jump_next;
165	if ($op_name eq "entersub") {
166	$source .= <<EOF;
167	while (nextop != (OP *)${$op->next}L)
168	{
169	PERL_ASYNC_CHECK ();
170	PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX);
171	}
172	EOF
173	}
174
175	out_gotonext;
176	}	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;
177		230
178	sub op_nextstate {	231	sub op_nextstate {
179	$source .= " PL_curcop = (COP *)nextop;\n";	232	$source .= " PL_curcop = (COP *)nextop;\n";
180	$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";
181	$source .= " FREETMPS;\n";	234	$source .= " FREETMPS;\n";
182		235
183	out_next;	236	out_next;
184	}	237	}
185		238
186	sub op_pushmark {	239	sub op_pushmark {
187	$source .= " PUSHMARK (PL_stack_sp);\n";	240	$source .= " faster_PUSHMARK (PL_stack_sp);\n";
188		241
189	out_next;	242	out_next;
190	}	243	}
191		244
192	if ($Config{useithreads} ne "define") {	245	if ($Config{useithreads} ne "define") {
193	# disable optimisations on ithreads	246	# disable optimisations on ithreads
194		247
195	*op_const = sub {	248	*op_const = sub {
196	$source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";	249	$source .= " { dSP; PUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
		250
		251	$ops[0]{follows_const}++ if @ops;#d#
197		252
198	out_next;	253	out_next;
199	};	254	};
200		255
201	*op_gv = \&op_const;	256	*op_gv = \&op_const;
…		…
221	if (!($op->flags & B::OPf_MOD)) {	276	if (!($op->flags & B::OPf_MOD)) {
222	$source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";	277	$source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
223	}	278	}
224		279
225	$source .= " dSP;\n";	280	$source .= " dSP;\n";
226	$source .= " XPUSHs (sv);\n";	281	$source .= " PUSHs (sv);\n";
227	$source .= " PUTBACK;\n";	282	$source .= " PUTBACK;\n";
228	$source .= " }\n";	283	$source .= " }\n";
229		284
230	out_next;	285	out_next;
231	};	286	};
232		287
233	*op_gvsv = sub {	288	*op_gvsv = sub {
234	$source .= " {\n";	289	$source .= " {\n";
235	$source .= " dSP;\n";	290	$source .= " dSP;\n";
236	$source .= " EXTEND (SP, 1);\n";
237		291
238	if ($op->private & B::OPpLVAL_INTRO) {	292	if ($op->private & B::OPpLVAL_INTRO) {
239	$source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";	293	$source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
240	} else {	294	} else {
241	$source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";	295	$source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
…		…
246		300
247	out_next;	301	out_next;
248	};	302	};
249	}	303	}
250		304
		305	# does kill Crossfire/res2pm
251	sub op_stringify {	306	sub op_stringify {
252	$source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n";	307	my $targ = $op->targ;
		308
		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
253		318
254	out_next;	319	out_next;
255	}	320	}
256		321
257	sub op_and {	322	sub op_and {
…		…
290	out_next;	355	out_next;
291	}	356	}
292		357
293	sub op_padsv {	358	sub op_padsv {
294	my $flags = $op->flags;	359	my $flags = $op->flags;
295	my $target = $op->targ;	360	my $padofs = "(PADOFFSET)" . $op->targ;
296		361
297	$source .= <<EOF;	362	$source .= <<EOF;
298	{	363	{
299	dSP;	364	dSP;
300	XPUSHs (PAD_SV ((PADOFFSET)$target));	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);
301	PUTBACK;	375	PUTBACK;
302	EOF	376	EOF
303	if ($op->flags & B::OPf_MOD) {	377
304	if ($op->private & B::OPpLVAL_INTRO) {	378	if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
305	$source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n";	379	$source .= " if (!SvROK (sv)) vivify_ref (sv, " . $op->private . " & OPpDEREF);\n";
306	} elsif ($op->private & B::OPpDEREF) {
307	my $deref = $op->private & B::OPpDEREF;
308	$source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
309	}
310	}	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
311	$source .= <<EOF;	402	$source .= <<EOF;
		403	SETs (right);
		404	PUTBACK;
312	}	405	}
313	EOF	406	EOF
314		407
315	out_next;	408	out_next;
316	}	409	}
317		410
318	# pattern const+ (or general push1)	411	# pattern const+ (or general push1)
319	# pattern pushmark return(?)
320	# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign	412	# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
321		413
322	# pattern const method_named
323	sub op_method_named {	414	sub op_method_named {
		415	if ($insn->{follows_const}) {
324	$source .= <<EOF;	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;
325	{	440	{
326	static HV *last_stash;	441	static HV *last_stash;
327	static SV *last_res;	442	static SV *last_cv;
		443	static U32 last_sub_generation;
328		444
329	SV obj = (PL_stack_base + TOPMARK + 1);	445	SV obj = (PL_stack_base + TOPMARK + 1);
330		446
331	if (SvROK (obj) && SvOBJECT (SvRV (obj)))	447	if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
332	{	448	{
333	dSP;	449	dSP;
334	HV *stash = SvSTASH (SvRV (obj));	450	HV *stash = SvSTASH (SvRV (obj));
335		451
336	/* simple "polymorphic" inline cache */	452	/* simple "polymorphic" inline cache */
337	if (stash == last_stash)	453	if (stash == last_stash
		454	&& PL_sub_generation == last_sub_generation)
338	{	455	{
339	XPUSHs (last_res);	456	PUSHs (last_cv);
340	PUTBACK;	457	PUTBACK;
341	}	458	}
342	else	459	else
343	{	460	{
344	PL_op = nextop;
345	nextop = Perl_pp_method_named (aTHX);	461	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
346		462
347	SPAGAIN;	463	SPAGAIN;
		464	last_sub_generation = PL_sub_generation;
348	last_stash = stash;	465	last_stash = stash;
349	last_res = TOPs;	466	last_cv = TOPs;
350	}	467	}
351	}	468	}
352	else	469	else
353	{	470	{
354	/* error case usually */	471	/* error case usually */
355	PL_op = nextop;
356	nextop = Perl_pp_method_named (aTHX);	472	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
357	}	473	}
358	}	474	}
359	EOF	475	EOF
		476	}
360		477
361	out_next;	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;
362	}	518	}
363		519
364	sub cv2c {	520	sub cv2c {
365	my ($cv) = @_;	521	my ($cv) = @_;
366		522
		523	local @ops;
		524	local @op_loop;
		525	local %op_regcomp;
		526
367	my %opsseen;	527	my %opsseen;
368	my @todo = $cv->START;	528	my @todo = $cv->START;
		529	my %op_target;
		530	my $numpushmark;
369		531
370	while (my $op = shift @todo) {	532	while (my $op = shift @todo) {
371	for (; $$op; $op = $op->next) {	533	for (; $$op; $op = $op->next) {
372	last if $opsseen{$$op}++;	534	last if $opsseen{$$op}++;
373	push @ops, $op;	535
374	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
375	if (B::class($op) eq "LOGOP") {	551	if ($class eq "LOGOP") {
376	push @todo, $op->other;	552	push @todo, $op->other;
377	} elsif ($name eq "subst" and ${ $op->pmreplstart }) {	553	$op_target{${$op->other}}++;
378	push @todo, $op->pmreplstart;	554
379	} elsif ($name =~ /^enter(loop\|iter)$/) {	555	# regcomp/o patches ops at runtime, lets expect that
380	# if ($] > 5.009) {	556	if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
381	# $labels{${$op->nextop}} = "NEXT";	557	$op_target{${$op->first}}++;
382	# $labels{${$op->lastop}} = "LAST";	558	$op_regcomp{${$op->first}} = $op->next;
383	# $labels{${$op->redoop}} = "REDO";
384	# } else {
385	# $labels{$op->nextop->seq} = "NEXT";
386	# $labels{$op->lastop->seq} = "LAST";
387	# $labels{$op->redoop->seq} = "REDO";
388	# }	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	}
389	}	582	}
390	}	583	}
391	}	584	}
392		585
		586	$_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
		587
393	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;
394	#define PERL_NO_GET_CONTEXT	697	#define PERL_NO_GET_CONTEXT
		698	#define PERL_CORE
395		699
396	//#define NDEBUG 1
397	#include <assert.h>	700	#include <assert.h>
398		701
399	#include "EXTERN.h"	702	#include "EXTERN.h"
400	#include "perl.h"	703	#include "perl.h"
401	#include "XSUB.h"	704	#include "XSUB.h"
402		705
403	OP *%%%FUNC%%% (pTHX)	706	#if 1
404	{	707	# define faster_PUSHMARK_PREALLOC(count) while (PL_markstack_ptr + (count) >= PL_markstack_max) markstack_grow ()
405	register OP nextop = (OP )${$ops[0]}L;	708	# define faster_PUSHMARK(p) *++PL_markstack_ptr = (p) - PL_stack_base
406	EOF	709	#else
		710	# define faster_PUSHMARK_PREALLOC(count) 1
		711	# define faster_PUSHMARK(p) PUSHMARK(p)
		712	#endif
407		713
408	while (@ops) {	714	#define RUNOPS_TILL(op) \\
409	$op = shift @ops;	715	while (nextop != (op)) \\
410	$op_name = $op->name;	716	{ \\
411		717	PERL_ASYNC_CHECK (); \\
412	$source .= "op_$$op: /* $op_name */\n";	718	PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
413	#$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
414	#$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
415
416	unless (exists $flag{noasync}{$op_name}) {
417	$source .= " PERL_ASYNC_CHECK ();\n";
418	}
419
420	if (my $can = __PACKAGE__->can ("op_$op_name")) {
421	$can->($op);
422	} elsif (exists $flag{unsafe}{$op_name}) {
423	$source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";
424	$source .= " return nextop;\n";
425	} elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$op_name}) {
426	$source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";
427	$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
428	$source .= " if (nextop == (OP *)${$op->other}L) goto op_${$op->other};\n";
429	$source .= " assert ((\"$op_name\", nextop == (OP *)${$op->next}));\n";
430	$source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";
431	} else {
432	out_linear;
433	}
434	}	719	}
435		720
436	$source .= "}\n";	721	EOF
437	#warn $source;	722	for my $f (grep !$_->{so}, @func) {
		723	next if $f->{so} = $meta->{$f->{func}}; # some cv's alias others
438		724
439	$source	725	warn "compiling $f->{name} to $stem$_so:$f->{func}\n" if $verbose > 1;
440	}	726	my $source = $f->{source};
441		727	$source =~ s/%%%FUNC%%%/$f->{func}/g;
442	sub source2ptr {
443	my ($source) = @_;
444
445	my $md5 = Digest::MD5::md5_hex $source;
446	$source =~ s/%%%FUNC%%%/Faster_$md5/;
447
448	my $stem = "/tmp/$md5";
449
450	unless (-e "$stem$_so") {
451	open FILE, ">:raw", "$stem.c";
452	print FILE $source;	728	print $fh $source;
		729	$meta->{$f->{func}} = $f->{so} = $stem;
		730	}
		731
453	close FILE;	732	close $fh;
454	system "$COMPILE -o $stem$_o $stem.c";	733	system "$COMPILE -o $stem$_o $stem.c";
		734	unlink "$stem.c" unless $ENV{FASTER_DEBUG} > 0;
455	system "$LINK -o $stem$_so $stem$_o $LIBS";	735	system "$LINK -o $stem$_so $stem$_o $LIBS";
		736	unlink "$stem$_o";
456	}	737	}
457		738
458	# warn $source;	739	for my $f (@func) {
		740	my $stem = $f->{so};
		741
459	my $so = DynaLoader::dl_load_file "$stem$_so"	742	my $so = ($so{$stem} \|\|= DynaLoader::dl_load_file "$stem$_so")
460	or die "$stem$_so: $!";	743	or die "$stem$_so: $!";
461		744
462	DynaLoader::dl_find_symbol $so, "Faster_$md5"	745	#unlink "$stem$_so";
463	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)
464	}	756	}
		757
		758	my %ignore;
465		759
466	sub entersub {	760	sub entersub {
467	my ($cv) = @_;	761	my ($cv) = @_;
468		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
469	eval {	770	eval {
		771	my @func;
		772
		773	push @func, {
		774	cv => $cv,
		775	name => "<>",
470	my $source = cv2c $cv;	776	source => cv2c $cv,
		777	};
471		778
472	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;
473		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) {
474	patch_cv $cv, $ptr;	802	patch_cv $f->{cv}, $f->{ptr};
		803	}
475	};	804	};
476		805
477	warn $@ if $@;	806	if ($@) {
		807	$ignore{$pkg}++;
		808	warn $@;
		809	}
478	}	810	}
479		811
480	hook_entersub;	812	hook_entersub;
481		813
482	1;	814	1;
483		815
484	=back	816	=back
485		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
486	=head1 LIMITATIONS	848	=head1 BUGS/LIMITATIONS
487		849
488	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)
489		873
490	=head1 AUTHOR	874	=head1 AUTHOR
491		875
492	Marc Lehmann <schmorp@schmorp.de>	876	Marc Lehmann <schmorp@schmorp.de>
493	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.9 by root, Fri Mar 10 01:55:12 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.9 by root, Fri Mar 10 01:55:12 2006 UTC vs.
Revision 1.33 by root, Mon Mar 13 17:10:32 2006 UTC