[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.25 by root, Sat Mar 11 04:58:53 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	# breaks gce with can't coerce array....
		340	if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {#d#
		341	return out_linear;#d#
		342	}#d#
296		343
297	$source .= <<EOF;	344	$source .= <<EOF;
298	{	345	{
299	dSP;	346	dSP;
300	XPUSHs (PAD_SV ((PADOFFSET)$target));	347	SV *sv = PAD_SVl ($padofs);
		348	EOF
		349
		350	if (($flags & B::OPf_MOD) && ($op->private & B::OPpLVAL_INTRO)) {
		351	$source .= " SAVECLEARSV (PAD_SVl ($padofs));\n";
		352	$ops[0]{pre_padsv_lval_intro}++ if @ops;#d#
		353	}
		354
		355	$source .= <<EOF;
		356	PUSHs (sv);
301	PUTBACK;	357	PUTBACK;
302	EOF	358	EOF
303	if ($op->flags & B::OPf_MOD) {	359
304	if ($op->private & B::OPpLVAL_INTRO) {	360	if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
305	$source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n";	361	$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	}	362	}
		363	$source .= " }\n";
		364
		365	out_next;
		366	}
		367
		368	sub op_sassign {
		369	$source .= <<EOF;
		370	{
		371	dSP;
		372	dPOPTOPssrl;
		373	EOF
		374	$source .= " SV *temp = left; left = right; right = temp;\n"
		375	if $op->private & B::OPpASSIGN_BACKWARDS;
		376
		377	if ($insn->{pre_padsv_lval_intro} && !($op->private & B::OPpASSIGN_BACKWARDS)) {
		378	# simple assignment - the target exists, but is basically undef
		379	$source .= " SvSetSV (right, left);\n";
		380	} else {
		381	$source .= " SvSetMagicSV (right, left);\n";
		382	}
		383
311	$source .= <<EOF;	384	$source .= <<EOF;
		385	SETs (right);
		386	PUTBACK;
312	}	387	}
313	EOF	388	EOF
314		389
315	out_next;	390	out_next;
316	}	391	}
317		392
318	# pattern const+ (or general push1)	393	# pattern const+ (or general push1)
319	# pattern pushmark return(?)	394	# pattern pushmark return(?)
320	# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign	395	# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
…		…
322	# pattern const method_named	397	# pattern const method_named
323	sub op_method_named {	398	sub op_method_named {
324	$source .= <<EOF;	399	$source .= <<EOF;
325	{	400	{
326	static HV *last_stash;	401	static HV *last_stash;
327	static SV *last_res;	402	static SV *last_cv;
		403	static U32 last_sub_generation;
328		404
329	SV obj = (PL_stack_base + TOPMARK + 1);	405	SV obj = (PL_stack_base + TOPMARK + 1);
330		406
331	if (SvROK (obj) && SvOBJECT (SvRV (obj)))	407	if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
332	{	408	{
333	dSP;	409	dSP;
334	HV *stash = SvSTASH (SvRV (obj));	410	HV *stash = SvSTASH (SvRV (obj));
335		411
336	/* simple "polymorphic" inline cache */	412	/* simple "polymorphic" inline cache */
337	if (stash == last_stash)	413	if (stash == last_stash
		414	&& PL_sub_generation == last_sub_generation)
338	{	415	{
339	XPUSHs (last_res);	416	PUSHs (last_cv);
340	PUTBACK;	417	PUTBACK;
341	}	418	}
342	else	419	else
343	{	420	{
344	PL_op = nextop;
345	nextop = Perl_pp_method_named (aTHX);	421	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
346		422
347	SPAGAIN;	423	SPAGAIN;
		424	last_sub_generation = PL_sub_generation;
348	last_stash = stash;	425	last_stash = stash;
349	last_res = TOPs;	426	last_cv = TOPs;
350	}	427	}
351	}	428	}
352	else	429	else
353	{	430	{
354	/* error case usually */	431	/* error case usually */
355	PL_op = nextop;
356	nextop = Perl_pp_method_named (aTHX);	432	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
357	}	433	}
358	}	434	}
359	EOF	435	EOF
360		436
361	out_next;	437	out_next;
		438	}
		439
		440	sub op_grepstart {
		441	out_callop;
		442	$op = $op->next;
		443	out_cond_jump $op->other;
		444	out_jump_next;
		445	}
		446
		447	*op_mapstart = \&op_grepstart;
		448
		449	sub op_substcont {
		450	out_callop;
		451	out_cond_jump $op->other->pmreplstart;
		452	assert "nextop == (OP *)${$op->other->next}L";
		453	$source .= " goto op_${$op->other->next};\n";
		454	}
		455
		456	sub out_break_op {
		457	my ($idx) = @_;
		458
		459	out_callop;
		460
		461	out_cond_jump $_->[$idx]
		462	for reverse @op_loop;
		463
		464	$source .= " return nextop;\n";
		465	}
		466
		467	sub xop_next {
		468	out_break_op 0;
		469	}
		470
		471	sub op_last {
		472	out_break_op 1;
		473	}
		474
		475	sub xop_redo {
		476	out_break_op 2;
362	}	477	}
363		478
364	sub cv2c {	479	sub cv2c {
365	my ($cv) = @_;	480	my ($cv) = @_;
366		481
		482	local @ops;
		483	local @op_loop;
		484	local %op_regcomp;
		485
367	my %opsseen;	486	my %opsseen;
368	my @todo = $cv->START;	487	my @todo = $cv->START;
		488	my %op_target;
369		489
370	while (my $op = shift @todo) {	490	while (my $op = shift @todo) {
371	for (; $$op; $op = $op->next) {	491	for (; $$op; $op = $op->next) {
372	last if $opsseen{$$op}++;	492	last if $opsseen{$$op}++;
373	push @ops, $op;	493
374	my $name = $op->name;	494	my $name = $op->name;
		495	my $class = B::class $op;
		496
		497	my $insn = { op => $op };
		498
		499	push @ops, $insn;
		500
		501	if (exists $extend{$name}) {
		502	my $extend = $extend{$name};
		503	$extend = $extend->($op) if ref $extend;
		504	$insn->{extend} = $extend if defined $extend;
		505	}
		506
		507	push @todo, $op->next;
		508
375	if (B::class($op) eq "LOGOP") {	509	if ($class eq "LOGOP") {
376	push @todo, $op->other;	510	push @todo, $op->other;
377	} elsif ($name eq "subst" and ${ $op->pmreplstart }) {	511	$op_target{${$op->other}}++;
378	push @todo, $op->pmreplstart;	512
379	} elsif ($name =~ /^enter(loop\|iter)$/) {	513	# regcomp/o patches ops at runtime, lets expect that
380	# if ($] > 5.009) {	514	if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
381	# $labels{${$op->nextop}} = "NEXT";	515	$op_target{${$op->first}}++;
382	# $labels{${$op->lastop}} = "LAST";	516	$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	# }	517	}
		518
		519	} elsif ($class eq "PMOP") {
		520	if (${$op->pmreplstart}) {
		521	unshift @todo, $op->pmreplstart;
		522	$op_target{${$op->pmreplstart}}++;
		523	}
		524
		525	} elsif ($class eq "LOOP") {
		526	my @targ = ($op->nextop, $op->lastop->next, $op->redoop->next);
		527
		528	push @op_loop, \@targ;
		529	push @todo, @targ;
		530
		531	$op_target{$$_}++ for @targ;
		532	} elsif ($class eq "COP") {
		533	$insn->{bblock}++ if defined $op->label;
389	}	534	}
390	}	535	}
391	}	536	}
392		537
		538	$_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
		539
393	local $source = <<EOF;	540	local $source = <<EOF;
		541	OP *%%%FUNC%%% (pTHX)
		542	{
		543	register OP nextop = (OP )${$ops[0]->{op}}L;
		544	EOF
		545
		546	while (@ops) {
		547	$insn = shift @ops;
		548
		549	$op = $insn->{op};
		550	$op_name = $op->name;
		551
		552	my $class = B::class $op;
		553
		554	$source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
		555	$source .= "op_$$op: /* $op_name */\n";
		556	#$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
		557	#$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
		558
		559	$source .= " PERL_ASYNC_CHECK ();\n"
		560	unless exists $f_noasync{$op_name};
		561
		562	if (my $can = __PACKAGE__->can ("op_$op_name")) {
		563	# handcrafted replacement
		564
		565	if ($insn->{extend} > 0) {
		566	# coalesce EXTENDs
		567	# TODO: properly take negative preceeding and following EXTENDs into account
		568	for my $i (@ops) {
		569	last if exists $i->{bblock};
		570	last unless exists $i->{extend};
		571	my $extend = delete $i->{extend};
		572	$insn->{extend} += $extend if $extend > 0;
		573	}
		574
		575	$source .= " { dSP; EXTEND (SP, $insn->{extend}); PUTBACK; }\n"
		576	if $insn->{extend} > 0;
		577	}
		578
		579	$can->($op);
		580
		581	} elsif (exists $f_unsafe{$op_name}) {
		582	# unsafe, return to interpreter
		583	assert "nextop == (OP *)$$op";
		584	$source .= " return nextop;\n";
		585
		586	} elsif ("LOGOP" eq $class) {
		587	# logical operation with optional branch
		588	out_callop;
		589	out_cond_jump $op->other;
		590	out_jump_next;
		591
		592	} elsif ("PMOP" eq $class) {
		593	# regex-thingy
		594	out_callop;
		595	out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
		596	out_jump_next;
		597
		598	} else {
		599	# normal operator, linear execution
		600	out_linear;
		601	}
		602	}
		603
		604	$op_name = "func exit"; assert (0);
		605
		606	$source .= <<EOF;
		607	op_0:
		608	return 0;
		609	}
		610	EOF
		611	#warn $source;
		612
		613	$source
		614	}
		615
		616	my $uid = "aaaaaaa0";
		617
		618	sub source2ptr {
		619	my (@source) = @_;
		620
		621	my $stem = "/tmp/Faster-$$-" . $uid++;
		622
		623	open FILE, ">:raw", "$stem.c";
		624	print FILE <<EOF;
394	#define PERL_NO_GET_CONTEXT	625	#define PERL_NO_GET_CONTEXT
		626	#define PERL_CORE
395		627
396	//#define NDEBUG 1
397	#include <assert.h>	628	#include <assert.h>
398		629
399	#include "EXTERN.h"	630	#include "EXTERN.h"
400	#include "perl.h"	631	#include "perl.h"
401	#include "XSUB.h"	632	#include "XSUB.h"
402		633
403	OP *%%%FUNC%%% (pTHX)	634	#define RUNOPS_TILL(op) \\
404	{	635	while (nextop != (op)) \\
405	register OP nextop = (OP )${$ops[0]}L;	636	{ \\
406	EOF	637	PERL_ASYNC_CHECK (); \\
		638	PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
		639	}
407		640
408	while (@ops) {	641	EOF
409	$op = shift @ops;	642	for (@source) {
410	$op_name = $op->name;	643	my $func = $uid++;
411		644	$_ =~ s/%%%FUNC%%%/$func/g;
412	$source .= "op_$$op: /* $op_name */\n";	645	print FILE $_;
413	#$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#	646	$_ = $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	}	647	}
435		648
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;	649	close FILE;
454	system "$COMPILE -o $stem$_o $stem.c";	650	system "$COMPILE -o $stem$_o $stem.c";
		651	#d#unlink "$stem.c";
455	system "$LINK -o $stem$_so $stem$_o $LIBS";	652	system "$LINK -o $stem$_so $stem$_o $LIBS";
456	}	653	unlink "$stem$_o";
457		654
458	# warn $source;
459	my $so = DynaLoader::dl_load_file "$stem$_so"	655	my $so = DynaLoader::dl_load_file "$stem$_so"
460	or die "$stem$_so: $!";	656	or die "$stem$_so: $!";
461		657
462	DynaLoader::dl_find_symbol $so, "Faster_$md5"	658	#unlink "$stem$_so";
463	or die "Faster_$md5: $!"	659
		660	map +(DynaLoader::dl_find_symbol $so, $_), @source
464	}	661	}
		662
		663	my %ignore;
465		664
466	sub entersub {	665	sub entersub {
467	my ($cv) = @_;	666	my ($cv) = @_;
468		667
		668	my $pkg = $cv->STASH->NAME;
		669
		670	return if $ignore{$pkg};
		671
		672	warn "compiling ", $cv->STASH->NAME, "\n"
		673	if $verbose;
		674
469	eval {	675	eval {
470	my $source = cv2c $cv;	676	my @cv;
		677	my @cv_source;
471		678
		679	# always compile the whole stash
		680	my %stash = $cv->STASH->ARRAY;
		681	while (my ($k, $v) = each %stash) {
		682	$v->isa (B::GV::)
		683	or next;
		684
		685	my $cv = $v->CV;
		686
		687	if ($cv->isa (B::CV::)
		688	&& ${$cv->START}
		689	&& $cv->START->name ne "null") {
		690	push @cv, $cv;
		691	push @cv_source, cv2c $cv;
		692	}
		693	}
		694
472	my $ptr = source2ptr $source;	695	my @ptr = source2ptr @cv_source;
473		696
		697	for (0 .. $#cv) {
474	patch_cv $cv, $ptr;	698	patch_cv $cv[$_], $ptr[$_];
		699	}
475	};	700	};
476		701
477	warn $@ if $@;	702	if ($@) {
		703	$ignore{$pkg}++;
		704	warn $@;
		705	}
478	}	706	}
479		707
480	hook_entersub;	708	hook_entersub;
481		709
482	1;	710	1;
483		711
484	=back	712	=back
485		713
		714	=head1 ENVIRONMENT VARIABLES
		715
		716	The following environment variables influence the behaviour of Faster:
		717
		718	=over 4
		719
		720	=item FASTER_VERBOSE
		721
		722	Faster will output more informational messages when set to values higher
		723	than C<0>. Currently, C<1> outputs which packages are being compiled.
		724
		725	=item FASTER_DEBUG
		726
		727	Add debugging code when set to values higher than C<0>. Currently, this
		728	adds 1-3 C<assert>'s per perl op, to ensure that opcode order and C
		729	execution order are compatible.
		730
		731	=item FASTER_CACHE
		732
		733	NOT YET IMPLEMENTED
		734
		735	Set a persistent cache directory that caches compiled code
		736	fragments. Normally, code compiled by Faster will be deleted immediately,
		737	and every restart will recompile everything. Setting this variable to a
		738	directory makes Faster cache the generated files for re-use.
		739
		740	This directory will always grow in contents, so you might need to erase it
		741	from time to time.
		742
		743	=back
		744
486	=head1 LIMITATIONS	745	=head1 BUGS/LIMITATIONS
487		746
488	Tainting and debugging will disable Faster.	747	Perl will check much less often for asynchronous signals in
		748	Faster-compiled code. It tries to check on every function call, loop
		749	iteration and every I/O operator, though.
		750
		751	The following things will disable Faster. If you manage to enable them at
		752	runtime, bad things will happen. Enabling them at startup will be fine,
		753	though.
		754
		755	enabled tainting
		756	enabled debugging
		757
		758	Thread-enabled builds of perl will dramatically reduce Faster's
		759	performance, but you don't care about speed if you enable threads anyway.
		760
		761	These constructs will force the use of the interpreter for the currently
		762	executed function as soon as they are being encountered during execution.
		763
		764	goto
		765	next, redo (but not well-behaved last's)
		766	eval
		767	require
		768	any use of formats
		769	.., ... (flipflop operators)
489		770
490	=head1 AUTHOR	771	=head1 AUTHOR
491		772
492	Marc Lehmann <schmorp@schmorp.de>	773	Marc Lehmann <schmorp@schmorp.de>
493	http://home.schmorp.de/	774	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.25 by root, Sat Mar 11 04:58:53 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.25 by root, Sat Mar 11 04:58:53 2006 UTC