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

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

Diff Legend

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

Comparing Faster/Faster.pm (file contents): Revision 1.7 by root, Fri Mar 10 00:13:15 2006 UTC vs. Revision 1.26 by root, Sat Mar 11 18:13:35 2006 UTC

Diff Legend

Comparing Faster/Faster.pm (file contents):
Revision 1.7 by root, Fri Mar 10 00:13:15 2006 UTC vs.
Revision 1.26 by root, Sat Mar 11 18:13:35 2006 UTC