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