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

Comparing Faster/Faster.pm (file contents):
Revision 1.5 by root, Thu Mar 9 22:55:56 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_padsv {	318	sub op_or {
180	my ($op) = @_;
181
182	my $flags = $op->flags;
183	my $target = $op->targ;
184
185	$source .= <<EOF;	319	$source .= <<EOF;
186	{	320	{
187	dSP;	321	dSP;
188	XPUSHs (PAD_SV ((PADOFFSET)$target));	322
189	PUTBACK;	323	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	}	324	{
198	}	325	--SP;
199	$source .= <<EOF;	326	PUTBACK;
		327	nextop = (OP *)${$op->other}L;
		328	goto op_${$op->other};
		329	}
200	}	330	}
201	EOF	331	EOF
202		332
203	out_next $op;	333	out_next;
204	}	334	}
205		335
206	# pattern const+ (or general push1)	336	sub op_padsv {
207	# pattern pushmark return(?)	337	my $flags = $op->flags;
208	# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign	338	my $padofs = "(PADOFFSET)" . $op->targ;
209
210	# pattern const method_named
211	sub op_method_named {
212	my ($op) = @_;
213		339
214	$source .= <<EOF;	340	$source .= <<EOF;
215	{	341	{
		342	dSP;
		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);
		353	PUTBACK;
		354	EOF
		355
		356	if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
		357	$source .= " vivify_ref (sv, " . $op->private . " & OPpDEREF);\n";
		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
		380	$source .= <<EOF;
		381	SETs (right);
		382	PUTBACK;
		383	}
		384	EOF
		385
		386	out_next;
		387	}
		388
		389	# pattern const+ (or general push1)
		390	# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
		391
		392	sub op_method_named {
		393	if ($insn->{follows_const}) {
		394	$source .= <<EOF;
		395	{
		396	dSP;
		397	static SV *last_cv;
		398	static U32 last_sub_generation;
		399
		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);
		409
		410	SPAGAIN;
		411	last_sub_generation = PL_sub_generation;
		412	last_cv = TOPs;
		413	}
		414	}
		415	EOF
		416	} else {
		417	$source .= <<EOF;
		418	{
216	static HV *last_stash;	419	static HV *last_stash;
217	static SV *last_res;	420	static SV *last_cv;
		421	static U32 last_sub_generation;
218		422
219	SV obj = (PL_stack_base + TOPMARK + 1);	423	SV obj = (PL_stack_base + TOPMARK + 1);
220		424
221	if (SvROK (obj) && SvOBJECT (SvRV (obj)))	425	if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
222	{	426	{
223	dSP;	427	dSP;
224	HV *stash = SvSTASH (SvRV (obj));	428	HV *stash = SvSTASH (SvRV (obj));
225		429
226	/* simple "polymorphic" inline cache */	430	/* simple "polymorphic" inline cache */
227	if (stash == last_stash)	431	if (stash == last_stash
		432	&& PL_sub_generation == last_sub_generation)
228	{	433	{
229	XPUSHs (last_res);	434	PUSHs (last_cv);
230	PUTBACK;	435	PUTBACK;
231	}	436	}
232	else	437	else
233	{	438	{
234	PL_op = nextop;
235	nextop = Perl_pp_method_named (aTHX);	439	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
236		440
237	SPAGAIN;	441	SPAGAIN;
		442	last_sub_generation = PL_sub_generation;
238	last_stash = stash;	443	last_stash = stash;
239	last_res = TOPs;	444	last_cv = TOPs;
240	}	445	}
241	}	446	}
242	else	447	else
243	{	448	{
244	/* error case usually */	449	/* error case usually */
245	PL_op = nextop;
246	nextop = Perl_pp_method_named (aTHX);	450	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
247	}	451	}
248	}	452	}
249	EOF	453	EOF
		454	}
250		455
251	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;
252	}	496	}
253		497
254	sub cv2c {	498	sub cv2c {
255	my ($cv) = @_;	499	my ($cv) = @_;
256		500
		501	local @ops;
		502	local @op_loop;
		503	local %op_regcomp;
		504
257	my %opsseen;	505	my %opsseen;
258	my @ops;
259	my @todo = $cv->START;	506	my @todo = $cv->START;
		507	my %op_target;
260		508
261	while (my $op = shift @todo) {	509	while (my $op = shift @todo) {
262	for (; $$op; $op = $op->next) {	510	for (; $$op; $op = $op->next) {
263	last if $opsseen{$$op}++;	511	last if $opsseen{$$op}++;
264	push @ops, $op;	512
265	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
266	if (B::class($op) eq "LOGOP") {	528	if ($class eq "LOGOP") {
267	push @todo, $op->other;	529	push @todo, $op->other;
268	} elsif ($name eq "subst" and ${ $op->pmreplstart }) {	530	$op_target{${$op->other}}++;
269	push @todo, $op->pmreplstart;	531
270	} elsif ($name =~ /^enter(loop\|iter)$/) {	532	# regcomp/o patches ops at runtime, lets expect that
271	# if ($] > 5.009) {	533	if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
272	# $labels{${$op->nextop}} = "NEXT";	534	$op_target{${$op->first}}++;
273	# $labels{${$op->lastop}} = "LAST";	535	$op_regcomp{${$op->first}} = $op->next;
274	# $labels{${$op->redoop}} = "REDO";
275	# } else {
276	# $labels{$op->nextop->seq} = "NEXT";
277	# $labels{$op->lastop->seq} = "LAST";
278	# $labels{$op->redoop->seq} = "REDO";
279	# }	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;
280	}	553	}
281	}	554	}
282	}	555	}
283		556
		557	$_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
		558
284	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;
285	#define PERL_NO_GET_CONTEXT	644	#define PERL_NO_GET_CONTEXT
		645	#define PERL_CORE
286		646
287	#include <assert.h>	647	#include <assert.h>
288		648
289	#include "EXTERN.h"	649	#include "EXTERN.h"
290	#include "perl.h"	650	#include "perl.h"
291	#include "XSUB.h"	651	#include "XSUB.h"
292		652
293	/typedef OP (PPFUNC)(pTHX);/	653	#define RUNOPS_TILL(op) \\
294		654	while (nextop != (op)) \\
295	OP *%%%FUNC%%% (pTHX)	655	{ \\
296	{
297	register OP nextop = (OP )${$ops[0]}L;
298	EOF
299
300	for my $op (@ops) {
301	my $name = $op->name;
302	my $ppaddr = ppaddr $op->type;
303
304	$source .= "op_$$op: /* $name */\n";
305	#$source .= "fprintf (stderr, \"$$op in op $name\\n\");\n";#d#
306	#$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
307
308	unless (exists $flag{noasync}{$name}) {
309	$source .= " PERL_ASYNC_CHECK ();\n";
310	}
311
312	if (my $can = __PACKAGE__->can ("op_$name")) {
313	$can->($op);
314	} elsif (exists $flag{unsafe}{$name}) {
315	$source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
316	$source .= " PL_op = nextop; return " . (callop $op) . ";\n";
317	} elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) {
318	$source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
319	$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
320	$source .= " if (nextop == (OP *)${$op->other}L) goto op_${$op->other};\n";
321	$source .= " assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#
322	$source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";
323	} else {
324	$source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
325	$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
326	if ($name eq "entersub") {
327	$source .= <<EOF;
328	while (nextop != (OP *)${$op->next})
329	{
330	PERL_ASYNC_CHECK ();	656	PERL_ASYNC_CHECK (); \\
331	PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX);	657	PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
332	}	658	}
		659
333	EOF	660	EOF
334	}	661	for (@source) {
335	$source .= " assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#	662	my $func = $uid++;
336	$source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";	663	$_ =~ s/%%%FUNC%%%/$func/g;
337	}	664	print FILE $_;
		665	$_ = $func;
338	}	666	}
339		667
340	$source .= "}\n";
341	#warn $source;
342
343	$source
344	}
345
346	sub source2ptr {
347	my ($source) = @_;
348
349	my $md5 = Digest::MD5::md5_hex $source;
350	$source =~ s/%%%FUNC%%%/Faster_$md5/;
351
352	my $stem = "/tmp/$md5";
353
354	unless (-e "$stem$_so") {
355	open FILE, ">:raw", "$stem.c";
356	print FILE $source;
357	close FILE;	668	close FILE;
358	system "$COMPILE -o $stem$_o $stem.c";	669	system "$COMPILE -o $stem$_o $stem.c";
		670	#d#unlink "$stem.c";
359	system "$LINK -o $stem$_so $stem$_o $LIBS";	671	system "$LINK -o $stem$_so $stem$_o $LIBS";
360	}	672	unlink "$stem$_o";
361		673
362	# warn $source;
363	my $so = DynaLoader::dl_load_file "$stem$_so"	674	my $so = DynaLoader::dl_load_file "$stem$_so"
364	or die "$stem$_so: $!";	675	or die "$stem$_so: $!";
365		676
366	DynaLoader::dl_find_symbol $so, "Faster_$md5"	677	#unlink "$stem$_so";
367	or die "Faster_$md5: $!"	678
		679	map +(DynaLoader::dl_find_symbol $so, $_), @source
368	}	680	}
		681
		682	my %ignore;
369		683
370	sub entersub {	684	sub entersub {
371	my ($cv) = @_;	685	my ($cv) = @_;
372		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
373	eval {	694	eval {
374	my $source = cv2c $cv;	695	my @cv;
		696	my @cv_source;
375		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
376	my $ptr = source2ptr $source;	714	my @ptr = source2ptr @cv_source;
377		715
		716	for (0 .. $#cv) {
378	patch_cv $cv, $ptr;	717	patch_cv $cv[$_], $ptr[$_];
		718	}
379	};	719	};
380		720
381	warn $@ if $@;	721	if ($@) {
		722	$ignore{$pkg}++;
		723	warn $@;
		724	}
382	}	725	}
383		726
384	hook_entersub;	727	hook_entersub;
385		728
386	1;	729	1;
387		730
388	=back	731	=back
389		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
390	=head1 LIMITATIONS	764	=head1 BUGS/LIMITATIONS
391		765
392	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)
393		789
394	=head1 AUTHOR	790	=head1 AUTHOR
395		791
396	Marc Lehmann <schmorp@schmorp.de>	792	Marc Lehmann <schmorp@schmorp.de>
397	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.5 by root, Thu Mar 9 22:55:56 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.5 by root, Thu Mar 9 22:55:56 2006 UTC vs.
Revision 1.26 by root, Sat Mar 11 18:13:35 2006 UTC