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

Comparing Faster/Faster.pm (file contents):
Revision 1.3 by root, Thu Mar 9 06:35:33 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;
16		39
		40	no warnings;
		41
17	use strict;	42	use strict;
		43	use Config;
		44	use B ();
		45	#use Digest::MD5 ();
		46	use DynaLoader ();
		47	use File::Temp ();
18		48
19	BEGIN {	49	BEGIN {
20	our $VERSION = '0.01';	50	our $VERSION = '0.01';
21		51
22	require XSLoader;	52	require XSLoader;
23	XSLoader::load __PACKAGE__, $VERSION;	53	XSLoader::load __PACKAGE__, $VERSION;
24	}	54	}
25		55
26	use B ();	56	my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}";
		57	my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
		58	my $LIBS = "$Config{libs}";
		59	my $_o = $Config{_o};
		60	my $_so = ".so";
		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;
27		68
28	our $source;	69	our $source;
29	our $label_next;
30	our $label_last;
31	our $label_redo;
32		70
33	my %flag;	71	our @ops;
		72	our $insn;
		73	our $op;
		74	our $op_name;
		75	our @op_loop;
		76	our %op_regcomp;
34		77
35	for (split /\n/, <<EOF) {	78	# ops that cause immediate return to the interpreter
36	leavesub unsafe	79	my %f_unsafe = map +($_ => undef), qw(
37	leavesublv unsafe	80	leavesub leavesublv return
38	return unsafe	81	goto last redo next
39	flip unsafe	82	eval flip leaveeval entertry
40	goto unsafe	83	formline grepstart mapstart
41	last unsafe	84	substcont entereval require
42	redo unsafe	85	);
43	next unsafe
44	eval unsafe
45	leaveeval unsafe
46	entertry unsafe
47	substconst unsafe
48	formline unsafe
49	grepstart unsafe
50	EOF
51	my (undef, $op, @flags) = split /\s+/;
52		86
53	undef $flag{$_}{$op}	87	# ops with known stack extend behaviour
54	for ("known", @flags);	88	# the values given are maximum values
		89	my %extend = (
		90	pushmark => 0,
		91	nextstate => 0, # might reduce the stack
		92	unstack => 0,
		93	enter => 0,
		94
		95	stringify => 0,
		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_ppaddr [OP_ENTERSUB]) (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";
55	}	188	}
56		189
57	sub out_next {	190	sub out_next {
58	my ($op) = @_;
59
60	$source .= " PL_op = (OP *)${$op->next}L;\n";	191	$source .= " nextop = (OP *)${$op->next}L;\n";
61	$source .= " goto op_${$op->next};\n";	192
		193	out_jump_next;
62	}	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;
63		208
64	sub op_nextstate {	209	sub op_nextstate {
65	my ($op) = @_;
66
67	$source .= " PL_curcop = (COP *)PL_op;\n";	210	$source .= " PL_curcop = (COP *)nextop;\n";
68	$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";
69	$source .= " FREETMPS;\n";	212	$source .= " FREETMPS;\n";
70		213
71	out_next $op;	214	out_next;
72	}	215	}
73		216
74	sub op_pushmark {	217	sub op_pushmark {
75	my ($op) = @_;
76
77	$source .= " PUSHMARK (PL_stack_sp);\n";	218	$source .= " PUSHMARK (PL_stack_sp);\n";
78		219
79	out_next $op;	220	out_next;
80	}	221	}
81		222
82	sub op_const {	223	if ($Config{useithreads} ne "define") {
83	my ($op) = @_;	224	# disable optimisations on ithreads
84		225
		226	*op_const = sub {
85	$source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";	227	$source .= " { dSP; PUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
86		228
87	out_next $op;	229	out_next;
88	}	230	};
89		231
90	*op_gv = \&op_const;	232	*op_gv = \&op_const;
91		233
		234	*op_aelemfast = sub {
		235	my $targ = $op->targ;
		236	my $private = $op->private;
		237
		238	$source .= " {\n";
		239
		240	if ($op->flags & B::OPf_SPECIAL) {
		241	$source .= " AV av = (AV)PAD_SV((PADOFFSET)$targ);\n";
		242	} else {
		243	$source .= " AV av = GvAV ((GV )${$op->sv}L);\n";
		244	}
		245
		246	if ($op->flags & B::OPf_MOD) {
		247	$source .= " SV sv = av_fetch (av, $private, 1);\n";
		248	} else {
		249	$source .= " SV *svp = av_fetch (av, $private, 0); SV sv = svp ? *svp : &PL_sv_undef;\n";
		250	}
		251
		252	if (!($op->flags & B::OPf_MOD)) {
		253	$source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
		254	}
		255
		256	$source .= " dSP;\n";
		257	$source .= " PUSHs (sv);\n";
		258	$source .= " PUTBACK;\n";
		259	$source .= " }\n";
		260
		261	out_next;
		262	};
		263
		264	*op_gvsv = sub {
		265	$source .= " {\n";
		266	$source .= " dSP;\n";
		267
		268	if ($op->private & B::OPpLVAL_INTRO) {
		269	$source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
		270	} else {
		271	$source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
		272	}
		273
		274	$source .= " PUTBACK;\n";
		275	$source .= " }\n";
		276
		277	out_next;
		278	};
		279	}
		280
		281	# does kill Crossfire/res2pm
92	sub op_stringify {	282	sub op_stringify {
93	my ($op) = @_;	283	my $targ = $op->targ;
94		284
95	$source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n";	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
96		294
97	out_next $op;	295	out_next;
		296	}
		297
		298	sub op_and {
		299	$source .= <<EOF;
		300	{
		301	dSP;
		302
		303	if (SvTRUE (TOPs))
		304	{
		305	--SP;
		306	PUTBACK;
		307	nextop = (OP *)${$op->other}L;
		308	goto op_${$op->other};
		309	}
		310	}
		311	EOF
		312
		313	out_next;
		314	}
		315
		316	sub op_or {
		317	$source .= <<EOF;
		318	{
		319	dSP;
		320
		321	if (!SvTRUE (TOPs))
		322	{
		323	--SP;
		324	PUTBACK;
		325	nextop = (OP *)${$op->other}L;
		326	goto op_${$op->other};
		327	}
		328	}
		329	EOF
		330
		331	out_next;
		332	}
		333
		334	sub op_padsv {
		335	my $flags = $op->flags;
		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#
		343
		344	$source .= <<EOF;
		345	{
		346	dSP;
		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);
		357	PUTBACK;
		358	EOF
		359
		360	if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
		361	$source .= " vivify_ref (sv, $flags & OPpDEREF);\n";
		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
		384	$source .= <<EOF;
		385	SETs (right);
		386	PUTBACK;
		387	}
		388	EOF
		389
		390	out_next;
98	}	391	}
99		392
100	# pattern const+ (or general push1)	393	# pattern const+ (or general push1)
101	# pattern pushmark return(?)	394	# pattern pushmark return(?)
102	# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign	395	# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
103		396
104	# pattern const method_named	397	# pattern const method_named
105	sub xop_method_named {	398	sub op_method_named {
106	my ($op) = @_;
107
108	my $ppaddr = ppaddr $op->type;
109
110	$source .= <<EOF;	399	$source .= <<EOF;
111	{	400	{
112	dSP;	401	static HV *last_stash;
		402	static SV *last_cv;
		403	static U32 last_sub_generation;
113		404
114	if (SvROK (TOPm1s) && SvOBJECT (SvRV (TOPm1s)))	405	SV obj = (PL_stack_base + TOPMARK + 1);
		406
		407	if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
115	{	408	{
116	static SV last_stash, SV last_res;	409	dSP;
117	SV *stash = SvSTASH (SvRV (TOPm1s));	410	HV *stash = SvSTASH (SvRV (obj));
118		411
119	// simple polymorphic inline cache	412	/* simple "polymorphic" inline cache */
120	if (stash == last_stash)	413	if (stash == last_stash
		414	&& PL_sub_generation == last_sub_generation)
121	{	415	{
		416	PUSHs (last_cv);
122	dTARGET;	417	PUTBACK;
123	SETTARG (last_res);
124	}	418	}
125	else	419	else
126	{	420	{
127	PUTBACK;	421	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
128	((PPFUNC)${ppaddr}L)(aTHX);\n";	422
129	SPAGAIN;	423	SPAGAIN;
130		424	last_sub_generation = PL_sub_generation;
131	last_stash = stash;	425	last_stash = stash;
132	last_res = TOPs;	426	last_cv = TOPs;
133	}	427	}
134	}	428	}
		429	else
		430	{
		431	/* error case usually */
		432	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
		433	}
135	}	434	}
136	EOF	435	EOF
137		436
138	out_next $op;	437	out_next;
139	}	438	}
140		439
141	sub entersub {	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;
		477	}
		478
		479	sub cv2c {
142	my ($cv) = @_;	480	my ($cv) = @_;
143		481
		482	local @ops;
		483	local @op_loop;
		484	local %op_regcomp;
		485
144	my %opsseen;	486	my %opsseen;
145	my @ops;
146	my @todo = $cv->START;	487	my @todo = $cv->START;
		488	my %op_target;
147		489
148	while (my $op = shift @todo) {	490	while (my $op = shift @todo) {
149	for (; $$op; $op = $op->next) {	491	for (; $$op; $op = $op->next) {
150	last if $opsseen{$$op}++;	492	last if $opsseen{$$op}++;
151	push @ops, $op;	493
152	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
153	if (B::class($op) eq "LOGOP") {	509	if ($class eq "LOGOP") {
154	push @todo, $op->other;	510	push @todo, $op->other;
155	} elsif ($name eq "subst" and ${ $op->pmreplstart }) {	511	$op_target{${$op->other}}++;
156	push @todo, $op->pmreplstart;	512
157	} elsif ($name =~ /^enter(loop\|iter)$/) {	513	# regcomp/o patches ops at runtime, lets expect that
158	# if ($] > 5.009) {	514	if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
159	# $labels{${$op->nextop}} = "NEXT";	515	$op_target{${$op->first}}++;
160	# $labels{${$op->lastop}} = "LAST";	516	$op_regcomp{${$op->first}} = $op->next;
161	# $labels{${$op->redoop}} = "REDO";
162	# } else {
163	# $labels{$op->nextop->seq} = "NEXT";
164	# $labels{$op->lastop->seq} = "LAST";
165	# $labels{$op->redoop->seq} = "REDO";
166	# }	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;
167	}	534	}
168	}	535	}
169	}	536	}
170		537
		538	$_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
		539
171	local $source;	540	local $source = <<EOF;
		541	OP *%%%FUNC%%% (pTHX)
		542	{
		543	register OP nextop = (OP )${$ops[0]->{op}}L;
		544	EOF
172		545
173	$source = "typedef OP (PPFUNC)(pTHX);\n\n";	546	while (@ops) {
174		547	$insn = shift @ops;
175	$source .= "OP *func (pTHX)\n{\n dTHX;\n";
176		548
177	for my $op (@ops) {	549	$op = $insn->{op};
178	my $name = $op->name;	550	$op_name = $op->name;
179	my $ppaddr = ppaddr $op->type;
180		551
		552	my $class = B::class $op;
		553
		554	$source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
181	$source .= "op_$$op: /* $name */\n";	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#
182		558
		559	$source .= " PERL_ASYNC_CHECK ();\n"
		560	unless exists $f_noasync{$op_name};
		561
183	if (my $can = __PACKAGE__->can ("op_$name")) {	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
184	$can->($op);	579	$can->($op);
185	} elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) {	580
186	$source .= " PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n";
187	$source .= " if (PL_op == (OP *)${$op->other}L) goto op_${$op->other};\n";
188	$source .= " goto op_${$op->next};\n";
189	} elsif (exists $flag{unsafe}{$name}) {	581	} elsif (exists $f_unsafe{$op_name}) {
190	$source .= " return ((PPFUNC)${ppaddr}L)(aTHX);\n";	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
191	} else {	598	} else {
192	$source .= " PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n";	599	# normal operator, linear execution
193	$source .= " goto op_${$op->next};\n";	600	out_linear;
194	}	601	}
195	}	602	}
196		603
		604	$op_name = "func exit"; assert (0);
		605
197	$source .= "}\n";	606	$source .= <<EOF;
		607	op_0:
		608	return 0;
		609	}
		610	EOF
		611	#warn $source;
198		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";
199	print <<EOF;	624	print FILE <<EOF;
		625	#define PERL_NO_GET_CONTEXT
		626	#define PERL_CORE
		627
		628	#include <assert.h>
		629
200	#include "EXTERN.h"	630	#include "EXTERN.h"
201	#include "perl.h"	631	#include "perl.h"
202	#include "XSUB.h"	632	#include "XSUB.h"
		633
		634	#define RUNOPS_TILL(op) \\
		635	while (nextop != (op)) \\
		636	{ \\
		637	PERL_ASYNC_CHECK (); \\
		638	PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
		639	}
		640
203	EOF	641	EOF
204	print $source;	642	for (@source) {
		643	my $func = $uid++;
		644	$_ =~ s/%%%FUNC%%%/$func/g;
		645	print FILE $_;
		646	$_ = $func;
		647	}
		648
		649	close FILE;
		650	system "$COMPILE -o $stem$_o $stem.c";
		651	#d#unlink "$stem.c";
		652	system "$LINK -o $stem$_so $stem$_o $LIBS";
		653	unlink "$stem$_o";
		654
		655	my $so = DynaLoader::dl_load_file "$stem$_so"
		656	or die "$stem$_so: $!";
		657
		658	#unlink "$stem$_so";
		659
		660	map +(DynaLoader::dl_find_symbol $so, $_), @source
		661	}
		662
		663	my %ignore;
		664
		665	sub entersub {
		666	my ($cv) = @_;
		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
		675	eval {
		676	my @cv;
		677	my @cv_source;
		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
		695	my @ptr = source2ptr @cv_source;
		696
		697	for (0 .. $#cv) {
		698	patch_cv $cv[$_], $ptr[$_];
		699	}
		700	};
		701
		702	if ($@) {
		703	$ignore{$pkg}++;
		704	warn $@;
		705	}
205	}	706	}
206		707
207	hook_entersub;	708	hook_entersub;
208		709
209	1;	710	1;
210		711
211	=back	712	=back
212		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
213	=head1 LIMITATIONS	745	=head1 BUGS/LIMITATIONS
214		746
215	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)
216		770
217	=head1 AUTHOR	771	=head1 AUTHOR
218		772
219	Marc Lehmann <schmorp@schmorp.de>	773	Marc Lehmann <schmorp@schmorp.de>
220	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.3 by root, Thu Mar 9 06:35:33 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.3 by root, Thu Mar 9 06:35:33 2006 UTC vs.
Revision 1.25 by root, Sat Mar 11 04:58:53 2006 UTC