[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.24 by root, Sat Mar 11 04:53:00 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 @ops;	71	our @ops;
42	my $op;	72	our $insn;
		73	our $op;
43	my $op_name;	74	our $op_name;
		75	our @op_loop;
		76	our %op_regcomp;
44		77
45	my %flag;	78	# ops that cause immediate return to the interpreter
		79	my %f_unsafe = map +($_ => undef), qw(
		80	leavesub leavesublv return
		81	goto last redo next
		82	eval flip leaveeval entertry
		83	formline grepstart mapstart
		84	substcont entereval require
		85	);
46		86
47	for (split /\n/, <<EOF) {	87	# ops with known stack extend behaviour
48	leavesub unsafe	88	# the values given are maximum values
49	leavesublv unsafe	89	my %extend = (
50	return unsafe	90	pushmark => 0,
51	flip unsafe	91	nextstate => 0, # might reduce the stack
52	goto unsafe	92	unstack => 0,
53	last unsafe	93	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		94
68	mapwhile noasync	95	stringify => 0,
69	grepwhile noasync	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	);
70		132
71	seq noasync	133	# ops that do not need an ASYNC_CHECK
72	pushmark noasync	134	my %f_noasync = map +($_ => undef), qw(
73	padsv noasync extend=1	135	mapstart grepstart match entereval
74	padav noasync extend=1	136	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		137
131	iter async	138	pushmark nextstate
132	EOF
133	my (undef, $op, @flags) = split /\s+/;
134		139
135	undef $flag{$_}{$op}	140	const stub unstack
136	for ("known", @flags);	141	last next redo seq
137	}	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_ppaddr [OP_ENTERSUB]) (aTHX)",
		161	mapstart => "Perl_pp_grepstart (aTHX)",
		162	);
138		163
139	sub callop {	164	sub callop {
140	$op_name eq "entersub"	165	$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	}	166	}
146		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
147	sub out_gotonext {	182	sub out_jump_next {
148	if (${$op->next}) {	183	out_cond_jump $op_regcomp{$$op}
149	$source .= " assert ((\"$op_name\", nextop == (OP *)${$op->next}));\n";	184	if $op_regcomp{$$op};
		185
		186	assert "nextop == (OP *)${$op->next}";
150	$source .= " goto op_${$op->next};\n";	187	$source .= " goto op_${$op->next};\n";
151	} else {
152	$source .= " return 0;\n";
153	}
154	}	188	}
155		189
156	sub out_next {	190	sub out_next {
157	$source .= " nextop = (OP *)${$op->next}L;\n";	191	$source .= " nextop = (OP *)${$op->next}L;\n";
158		192
159	out_gotonext;	193	out_jump_next;
160	}	194	}
161		195
162	sub out_linear {	196	sub out_linear {
163	$source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";#d#	197	out_callop;
164	$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";	198	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	}	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;
177		208
178	sub op_nextstate {	209	sub op_nextstate {
179	$source .= " PL_curcop = (COP *)nextop;\n";	210	$source .= " PL_curcop = (COP *)nextop;\n";
180	$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";
181	$source .= " FREETMPS;\n";	212	$source .= " FREETMPS;\n";
…		…
191		222
192	if ($Config{useithreads} ne "define") {	223	if ($Config{useithreads} ne "define") {
193	# disable optimisations on ithreads	224	# disable optimisations on ithreads
194		225
195	*op_const = sub {	226	*op_const = sub {
196	$source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";	227	$source .= " { dSP; PUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
197		228
198	out_next;	229	out_next;
199	};	230	};
200		231
201	*op_gv = \&op_const;	232	*op_gv = \&op_const;
…		…
221	if (!($op->flags & B::OPf_MOD)) {	252	if (!($op->flags & B::OPf_MOD)) {
222	$source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";	253	$source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
223	}	254	}
224		255
225	$source .= " dSP;\n";	256	$source .= " dSP;\n";
226	$source .= " XPUSHs (sv);\n";	257	$source .= " PUSHs (sv);\n";
227	$source .= " PUTBACK;\n";	258	$source .= " PUTBACK;\n";
228	$source .= " }\n";	259	$source .= " }\n";
229		260
230	out_next;	261	out_next;
231	};	262	};
232		263
233	*op_gvsv = sub {	264	*op_gvsv = sub {
234	$source .= " {\n";	265	$source .= " {\n";
235	$source .= " dSP;\n";	266	$source .= " dSP;\n";
236	$source .= " EXTEND (SP, 1);\n";
237		267
238	if ($op->private & B::OPpLVAL_INTRO) {	268	if ($op->private & B::OPpLVAL_INTRO) {
239	$source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";	269	$source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
240	} else {	270	} else {
241	$source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";	271	$source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
…		…
246		276
247	out_next;	277	out_next;
248	};	278	};
249	}	279	}
250		280
		281	# does kill Crossfire/res2pm
251	sub op_stringify {	282	sub op_stringify {
252	$source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n";	283	my $targ = $op->targ;
		284
		285	$source .= <<EOF;
		286	{
		287	dSP;
		288	SV *targ = PAD_SV ((PADOFFSET)$targ);
		289	sv_copypv (TARG, TOPs);
		290	SETTARG;
		291	PUTBACK;
		292	}
		293	EOF
253		294
254	out_next;	295	out_next;
255	}	296	}
256		297
257	sub op_and {	298	sub op_and {
…		…
290	out_next;	331	out_next;
291	}	332	}
292		333
293	sub op_padsv {	334	sub op_padsv {
294	my $flags = $op->flags;	335	my $flags = $op->flags;
295	my $target = $op->targ;	336	my $padofs = "(PADOFFSET)" . $op->targ;
		337
		338	#d#TODO: why does our version break
		339	if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {#d#
		340	return out_linear;#d#
		341	}#d#
296		342
297	$source .= <<EOF;	343	$source .= <<EOF;
298	{	344	{
299	dSP;	345	dSP;
300	XPUSHs (PAD_SV ((PADOFFSET)$target));	346	SV *sv = PAD_SVl ($padofs);
		347	EOF
		348
		349	if (($flags & B::OPf_MOD) && ($op->private & B::OPpLVAL_INTRO)) {
		350	$source .= " SAVECLEARSV (PAD_SVl ($padofs));\n";
		351	$ops[0]{pre_padsv_lval_intro}++ if @ops;#d#
		352	}
		353
		354	$source .= <<EOF;
		355	PUSHs (sv);
301	PUTBACK;	356	PUTBACK;
302	EOF	357	EOF
303	if ($op->flags & B::OPf_MOD) {	358
304	if ($op->private & B::OPpLVAL_INTRO) {	359	if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
305	$source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n";	360	$source .= " vivify_ref (sv, $flags & 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	}	361	}
		362	$source .= " }\n";
		363
		364	out_next;
		365	}
		366
		367	sub op_sassign {
		368	$source .= <<EOF;
		369	{
		370	dSP;
		371	dPOPTOPssrl;
		372	EOF
		373	$source .= " SV *temp = left; left = right; right = temp;\n"
		374	if $op->private & B::OPpASSIGN_BACKWARDS;
		375
		376	if ($insn->{pre_padsv_lval_intro} && !($op->private & B::OPpASSIGN_BACKWARDS)) {
		377	# simple assignment - the target exists, but is basically undef
		378	$source .= " SvSetSV (right, left);\n";
		379	} else {
		380	$source .= " SvSetMagicSV (right, left);\n";
		381	}
		382
311	$source .= <<EOF;	383	$source .= <<EOF;
		384	SETs (right);
		385	PUTBACK;
312	}	386	}
313	EOF	387	EOF
314		388
315	out_next;	389	out_next;
316	}	390	}
317		391
318	# pattern const+ (or general push1)	392	# pattern const+ (or general push1)
319	# pattern pushmark return(?)	393	# pattern pushmark return(?)
320	# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign	394	# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
…		…
322	# pattern const method_named	396	# pattern const method_named
323	sub op_method_named {	397	sub op_method_named {
324	$source .= <<EOF;	398	$source .= <<EOF;
325	{	399	{
326	static HV *last_stash;	400	static HV *last_stash;
327	static SV *last_res;	401	static SV *last_cv;
		402	static U32 last_sub_generation;
328		403
329	SV obj = (PL_stack_base + TOPMARK + 1);	404	SV obj = (PL_stack_base + TOPMARK + 1);
330		405
331	if (SvROK (obj) && SvOBJECT (SvRV (obj)))	406	if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
332	{	407	{
333	dSP;	408	dSP;
334	HV *stash = SvSTASH (SvRV (obj));	409	HV *stash = SvSTASH (SvRV (obj));
335		410
336	/* simple "polymorphic" inline cache */	411	/* simple "polymorphic" inline cache */
337	if (stash == last_stash)	412	if (stash == last_stash
		413	&& PL_sub_generation == last_sub_generation)
338	{	414	{
339	XPUSHs (last_res);	415	PUSHs (last_cv);
340	PUTBACK;	416	PUTBACK;
341	}	417	}
342	else	418	else
343	{	419	{
344	PL_op = nextop;
345	nextop = Perl_pp_method_named (aTHX);	420	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
346		421
347	SPAGAIN;	422	SPAGAIN;
		423	last_sub_generation = PL_sub_generation;
348	last_stash = stash;	424	last_stash = stash;
349	last_res = TOPs;	425	last_cv = TOPs;
350	}	426	}
351	}	427	}
352	else	428	else
353	{	429	{
354	/* error case usually */	430	/* error case usually */
355	PL_op = nextop;
356	nextop = Perl_pp_method_named (aTHX);	431	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
357	}	432	}
358	}	433	}
359	EOF	434	EOF
360		435
361	out_next;	436	out_next;
		437	}
		438
		439	sub op_grepstart {
		440	out_callop;
		441	$op = $op->next;
		442	out_cond_jump $op->other;
		443	out_jump_next;
		444	}
		445
		446	*op_mapstart = \&op_grepstart;
		447
		448	sub op_substcont {
		449	out_callop;
		450	out_cond_jump $op->other->pmreplstart;
		451	assert "nextop == (OP *)${$op->other->next}L";
		452	$source .= " goto op_${$op->other->next};\n";
		453	}
		454
		455	sub out_break_op {
		456	my ($idx) = @_;
		457
		458	out_callop;
		459
		460	out_cond_jump $_->[$idx]
		461	for reverse @op_loop;
		462
		463	$source .= " return nextop;\n";
		464	}
		465
		466	sub xop_next {
		467	out_break_op 0;
		468	}
		469
		470	sub op_last {
		471	out_break_op 1;
		472	}
		473
		474	sub xop_redo {
		475	out_break_op 2;
362	}	476	}
363		477
364	sub cv2c {	478	sub cv2c {
365	my ($cv) = @_;	479	my ($cv) = @_;
366		480
		481	local @ops;
		482	local @op_loop;
		483	local %op_regcomp;
		484
367	my %opsseen;	485	my %opsseen;
368	my @todo = $cv->START;	486	my @todo = $cv->START;
		487	my %op_target;
369		488
370	while (my $op = shift @todo) {	489	while (my $op = shift @todo) {
371	for (; $$op; $op = $op->next) {	490	for (; $$op; $op = $op->next) {
372	last if $opsseen{$$op}++;	491	last if $opsseen{$$op}++;
373	push @ops, $op;	492
374	my $name = $op->name;	493	my $name = $op->name;
		494	my $class = B::class $op;
		495
		496	my $insn = { op => $op };
		497
		498	push @ops, $insn;
		499
		500	if (exists $extend{$name}) {
		501	my $extend = $extend{$name};
		502	$extend = $extend->($op) if ref $extend;
		503	$insn->{extend} = $extend if defined $extend;
		504	}
		505
		506	push @todo, $op->next;
		507
375	if (B::class($op) eq "LOGOP") {	508	if ($class eq "LOGOP") {
376	push @todo, $op->other;	509	push @todo, $op->other;
377	} elsif ($name eq "subst" and ${ $op->pmreplstart }) {	510	$op_target{${$op->other}}++;
378	push @todo, $op->pmreplstart;	511
379	} elsif ($name =~ /^enter(loop\|iter)$/) {	512	# regcomp/o patches ops at runtime, lets expect that
380	# if ($] > 5.009) {	513	if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
381	# $labels{${$op->nextop}} = "NEXT";	514	$op_target{${$op->first}}++;
382	# $labels{${$op->lastop}} = "LAST";	515	$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	# }	516	}
		517
		518	} elsif ($class eq "PMOP") {
		519	if (${$op->pmreplstart}) {
		520	unshift @todo, $op->pmreplstart;
		521	$op_target{${$op->pmreplstart}}++;
		522	}
		523
		524	} elsif ($class eq "LOOP") {
		525	my @targ = ($op->nextop, $op->lastop->next, $op->redoop->next);
		526
		527	push @op_loop, \@targ;
		528	push @todo, @targ;
		529
		530	$op_target{$$_}++ for @targ;
		531	} elsif ($class eq "COP") {
		532	$insn->{bblock}++ if defined $op->label;
389	}	533	}
390	}	534	}
391	}	535	}
392		536
		537	$_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
		538
393	local $source = <<EOF;	539	local $source = <<EOF;
		540	OP *%%%FUNC%%% (pTHX)
		541	{
		542	register OP nextop = (OP )${$ops[0]->{op}}L;
		543	EOF
		544
		545	while (@ops) {
		546	$insn = shift @ops;
		547
		548	$op = $insn->{op};
		549	$op_name = $op->name;
		550
		551	my $class = B::class $op;
		552
		553	$source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
		554	$source .= "op_$$op: /* $op_name */\n";
		555	#$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
		556	#$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
		557
		558	$source .= " PERL_ASYNC_CHECK ();\n"
		559	unless exists $f_noasync{$op_name};
		560
		561	if (my $can = __PACKAGE__->can ("op_$op_name")) {
		562	# handcrafted replacement
		563
		564	if ($insn->{extend} > 0) {
		565	# coalesce EXTENDs
		566	# TODO: properly take negative preceeding and following EXTENDs into account
		567	for my $i (@ops) {
		568	last if exists $i->{bblock};
		569	last unless exists $i->{extend};
		570	my $extend = delete $i->{extend};
		571	$insn->{extend} += $extend if $extend > 0;
		572	}
		573
		574	$source .= " { dSP; EXTEND (SP, $insn->{extend}); PUTBACK; }\n"
		575	if $insn->{extend} > 0;
		576	}
		577
		578	$can->($op);
		579
		580	} elsif (exists $f_unsafe{$op_name}) {
		581	# unsafe, return to interpreter
		582	assert "nextop == (OP *)$$op";
		583	$source .= " return nextop;\n";
		584
		585	} elsif ("LOGOP" eq $class) {
		586	# logical operation with optional branch
		587	out_callop;
		588	out_cond_jump $op->other;
		589	out_jump_next;
		590
		591	} elsif ("PMOP" eq $class) {
		592	# regex-thingy
		593	out_callop;
		594	out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
		595	out_jump_next;
		596
		597	} else {
		598	# normal operator, linear execution
		599	out_linear;
		600	}
		601	}
		602
		603	$op_name = "func exit"; assert (0);
		604
		605	$source .= <<EOF;
		606	op_0:
		607	return 0;
		608	}
		609	EOF
		610	#warn $source;
		611
		612	$source
		613	}
		614
		615	my $uid = "aaaaaaa0";
		616
		617	sub source2ptr {
		618	my (@source) = @_;
		619
		620	my $stem = "/tmp/Faster-$$-" . $uid++;
		621
		622	open FILE, ">:raw", "$stem.c";
		623	print FILE <<EOF;
394	#define PERL_NO_GET_CONTEXT	624	#define PERL_NO_GET_CONTEXT
		625	#define PERL_CORE
395		626
396	//#define NDEBUG 1
397	#include <assert.h>	627	#include <assert.h>
398		628
399	#include "EXTERN.h"	629	#include "EXTERN.h"
400	#include "perl.h"	630	#include "perl.h"
401	#include "XSUB.h"	631	#include "XSUB.h"
402		632
403	OP *%%%FUNC%%% (pTHX)	633	#define RUNOPS_TILL(op) \\
404	{	634	while (nextop != (op)) \\
405	register OP nextop = (OP )${$ops[0]}L;	635	{ \\
406	EOF	636	PERL_ASYNC_CHECK (); \\
		637	PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
		638	}
407		639
408	while (@ops) {	640	EOF
409	$op = shift @ops;	641	for (@source) {
410	$op_name = $op->name;	642	my $func = $uid++;
411		643	$_ =~ s/%%%FUNC%%%/$func/g;
412	$source .= "op_$$op: /* $op_name */\n";	644	print FILE $_;
413	#$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#	645	$_ = $func;
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	}	646	}
435		647
436	$source .= "}\n";
437	#warn $source;
438
439	$source
440	}
441
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;
453	close FILE;	648	close FILE;
454	system "$COMPILE -o $stem$_o $stem.c";	649	system "$COMPILE -o $stem$_o $stem.c";
		650	#d#unlink "$stem.c";
455	system "$LINK -o $stem$_so $stem$_o $LIBS";	651	system "$LINK -o $stem$_so $stem$_o $LIBS";
456	}	652	unlink "$stem$_o";
457		653
458	# warn $source;
459	my $so = DynaLoader::dl_load_file "$stem$_so"	654	my $so = DynaLoader::dl_load_file "$stem$_so"
460	or die "$stem$_so: $!";	655	or die "$stem$_so: $!";
461		656
462	DynaLoader::dl_find_symbol $so, "Faster_$md5"	657	#unlink "$stem$_so";
463	or die "Faster_$md5: $!"	658
		659	map +(DynaLoader::dl_find_symbol $so, $_), @source
464	}	660	}
		661
		662	my %ignore;
465		663
466	sub entersub {	664	sub entersub {
467	my ($cv) = @_;	665	my ($cv) = @_;
468		666
		667	my $pkg = $cv->STASH->NAME;
		668
		669	return if $ignore{$pkg};
		670
		671	warn "compiling ", $cv->STASH->NAME, "\n"
		672	if $verbose;
		673
469	eval {	674	eval {
470	my $source = cv2c $cv;	675	my @cv;
		676	my @cv_source;
471		677
		678	# always compile the whole stash
		679	my %stash = $cv->STASH->ARRAY;
		680	while (my ($k, $v) = each %stash) {
		681	$v->isa (B::GV::)
		682	or next;
		683
		684	my $cv = $v->CV;
		685
		686	if ($cv->isa (B::CV::)
		687	&& ${$cv->START}
		688	&& $cv->START->name ne "null") {
		689	push @cv, $cv;
		690	push @cv_source, cv2c $cv;
		691	}
		692	}
		693
472	my $ptr = source2ptr $source;	694	my @ptr = source2ptr @cv_source;
473		695
		696	for (0 .. $#cv) {
474	patch_cv $cv, $ptr;	697	patch_cv $cv[$_], $ptr[$_];
		698	}
475	};	699	};
476		700
477	warn $@ if $@;	701	if ($@) {
		702	$ignore{$pkg}++;
		703	warn $@;
		704	}
478	}	705	}
479		706
480	hook_entersub;	707	hook_entersub;
481		708
482	1;	709	1;
483		710
484	=back	711	=back
485		712
		713	=head1 ENVIRONMENT VARIABLES
		714
		715	The following environment variables influence the behaviour of Faster:
		716
		717	=over 4
		718
		719	=item FASTER_VERBOSE
		720
		721	Faster will output more informational messages when set to values higher
		722	than C<0>. Currently, C<1> outputs which packages are being compiled.
		723
		724	=item FASTER_DEBUG
		725
		726	Add debugging code when set to values higher than C<0>. Currently, this
		727	adds 1-3 C<assert>'s per perl op, to ensure that opcode order and C
		728	execution order are compatible.
		729
		730	=item FASTER_CACHE
		731
		732	NOT YET IMPLEMENTED
		733
		734	Set a persistent cache directory that caches compiled code
		735	fragments. Normally, code compiled by Faster will be deleted immediately,
		736	and every restart will recompile everything. Setting this variable to a
		737	directory makes Faster cache the generated files for re-use.
		738
		739	This directory will always grow in contents, so you might need to erase it
		740	from time to time.
		741
		742	=back
		743
486	=head1 LIMITATIONS	744	=head1 BUGS/LIMITATIONS
487		745
488	Tainting and debugging will disable Faster.	746	Perl will check much less often for asynchronous signals in
		747	Faster-compiled code. It tries to check on every function call, loop
		748	iteration and every I/O operator, though.
		749
		750	The following things will disable Faster. If you manage to enable them at
		751	runtime, bad things will happen. Enabling them at startup will be fine,
		752	though.
		753
		754	enabled tainting
		755	enabled debugging
		756
		757	Thread-enabled builds of perl will dramatically reduce Faster's
		758	performance, but you don't care about speed if you enable threads anyway.
		759
		760	These constructs will force the use of the interpreter for the currently
		761	executed function as soon as they are being encountered during execution.
		762
		763	goto
		764	next, redo (but not well-behaved last's)
		765	eval
		766	require
		767	any use of formats
		768	.., ... (flipflop operators)
489		769
490	=head1 AUTHOR	770	=head1 AUTHOR
491		771
492	Marc Lehmann <schmorp@schmorp.de>	772	Marc Lehmann <schmorp@schmorp.de>
493	http://home.schmorp.de/	773	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.24 by root, Sat Mar 11 04:53:00 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.24 by root, Sat Mar 11 04:53:00 2006 UTC