[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.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;
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	if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {#d#
		340	return out_linear;#d#
		341	}#d#
		342
		343	$source .= <<EOF;
		344	{
		345	dSP;
		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);
		356	PUTBACK;
		357	EOF
		358
		359	if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
		360	$source .= " vivify_ref (sv, $flags & OPpDEREF);\n";
		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
		383	$source .= <<EOF;
		384	SETs (right);
		385	PUTBACK;
		386	}
		387	EOF
		388
		389	out_next;
98	}	390	}
99		391
100	# pattern const+ (or general push1)	392	# pattern const+ (or general push1)
101	# pattern pushmark return(?)	393	# pattern pushmark return(?)
102	# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign	394	# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
103		395
104	# pattern const method_named	396	# pattern const method_named
105	sub xop_method_named {	397	sub op_method_named {
106	my ($op) = @_;
107
108	my $ppaddr = ppaddr $op->type;
109
110	$source .= <<EOF;	398	$source .= <<EOF;
111	{	399	{
112	dSP;	400	static HV *last_stash;
		401	static SV *last_cv;
		402	static U32 last_sub_generation;
113		403
114	if (SvROK (TOPm1s) && SvOBJECT (SvRV (TOPm1s)))	404	SV obj = (PL_stack_base + TOPMARK + 1);
		405
		406	if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
115	{	407	{
116	static SV last_stash, SV last_res;	408	dSP;
117	SV *stash = SvSTASH (SvRV (TOPm1s));	409	HV *stash = SvSTASH (SvRV (obj));
118		410
119	// simple polymorphic inline cache	411	/* simple "polymorphic" inline cache */
120	if (stash == last_stash)	412	if (stash == last_stash
		413	&& PL_sub_generation == last_sub_generation)
121	{	414	{
		415	PUSHs (last_cv);
122	dTARGET;	416	PUTBACK;
123	SETTARG (last_res);
124	}	417	}
125	else	418	else
126	{	419	{
127	PUTBACK;	420	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
128	((PPFUNC)${ppaddr}L)(aTHX);\n";	421
129	SPAGAIN;	422	SPAGAIN;
130		423	last_sub_generation = PL_sub_generation;
131	last_stash = stash;	424	last_stash = stash;
132	last_res = TOPs;	425	last_cv = TOPs;
133	}	426	}
134	}	427	}
		428	else
		429	{
		430	/* error case usually */
		431	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
		432	}
135	}	433	}
136	EOF	434	EOF
137		435
138	out_next $op;	436	out_next;
139	}	437	}
140		438
141	sub entersub {	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;
		476	}
		477
		478	sub cv2c {
142	my ($cv) = @_;	479	my ($cv) = @_;
143		480
		481	local @ops;
		482	local @op_loop;
		483	local %op_regcomp;
		484
144	my %opsseen;	485	my %opsseen;
145	my @ops;
146	my @todo = $cv->START;	486	my @todo = $cv->START;
		487	my %op_target;
147		488
148	while (my $op = shift @todo) {	489	while (my $op = shift @todo) {
149	for (; $$op; $op = $op->next) {	490	for (; $$op; $op = $op->next) {
150	last if $opsseen{$$op}++;	491	last if $opsseen{$$op}++;
151	push @ops, $op;	492
152	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
153	if (B::class($op) eq "LOGOP") {	508	if ($class eq "LOGOP") {
154	push @todo, $op->other;	509	push @todo, $op->other;
155	} elsif ($name eq "subst" and ${ $op->pmreplstart }) {	510	$op_target{${$op->other}}++;
156	push @todo, $op->pmreplstart;	511
157	} elsif ($name =~ /^enter(loop\|iter)$/) {	512	# regcomp/o patches ops at runtime, lets expect that
158	# if ($] > 5.009) {	513	if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
159	# $labels{${$op->nextop}} = "NEXT";	514	$op_target{${$op->first}}++;
160	# $labels{${$op->lastop}} = "LAST";	515	$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	# }	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;
167	}	533	}
168	}	534	}
169	}	535	}
170		536
		537	$_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
		538
171	local $source;	539	local $source = <<EOF;
		540	OP *%%%FUNC%%% (pTHX)
		541	{
		542	register OP nextop = (OP )${$ops[0]->{op}}L;
		543	EOF
172		544
173	$source = "typedef OP (PPFUNC)(pTHX);\n\n";	545	while (@ops) {
174		546	$insn = shift @ops;
175	$source .= "OP *func (pTHX)\n{\n dTHX;\n";
176		547
177	for my $op (@ops) {	548	$op = $insn->{op};
178	my $name = $op->name;	549	$op_name = $op->name;
179	my $ppaddr = ppaddr $op->type;
180		550
		551	my $class = B::class $op;
		552
		553	$source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
181	$source .= "op_$$op: /* $name */\n";	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#
182		557
		558	$source .= " PERL_ASYNC_CHECK ();\n"
		559	unless exists $f_noasync{$op_name};
		560
183	if (my $can = __PACKAGE__->can ("op_$name")) {	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
184	$can->($op);	578	$can->($op);
185	} elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) {	579
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}) {	580	} elsif (exists $f_unsafe{$op_name}) {
190	$source .= " return ((PPFUNC)${ppaddr}L)(aTHX);\n";	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
191	} else {	597	} else {
192	$source .= " PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n";	598	# normal operator, linear execution
193	$source .= " goto op_${$op->next};\n";	599	out_linear;
194	}	600	}
195	}	601	}
196		602
		603	$op_name = "func exit"; assert (0);
		604
197	$source .= "}\n";	605	$source .= <<EOF;
		606	op_0:
		607	return 0;
		608	}
		609	EOF
		610	#warn $source;
198		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";
199	print <<EOF;	623	print FILE <<EOF;
		624	#define PERL_NO_GET_CONTEXT
		625	#define PERL_CORE
		626
		627	#include <assert.h>
		628
200	#include "EXTERN.h"	629	#include "EXTERN.h"
201	#include "perl.h"	630	#include "perl.h"
202	#include "XSUB.h"	631	#include "XSUB.h"
		632
		633	#define RUNOPS_TILL(op) \\
		634	while (nextop != (op)) \\
		635	{ \\
		636	PERL_ASYNC_CHECK (); \\
		637	PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
		638	}
		639
203	EOF	640	EOF
204	print $source;	641	for (@source) {
		642	my $func = $uid++;
		643	$_ =~ s/%%%FUNC%%%/$func/g;
		644	print FILE $_;
		645	$_ = $func;
		646	}
		647
		648	close FILE;
		649	system "$COMPILE -o $stem$_o $stem.c";
		650	#d#unlink "$stem.c";
		651	system "$LINK -o $stem$_so $stem$_o $LIBS";
		652	unlink "$stem$_o";
		653
		654	my $so = DynaLoader::dl_load_file "$stem$_so"
		655	or die "$stem$_so: $!";
		656
		657	#unlink "$stem$_so";
		658
		659	map +(DynaLoader::dl_find_symbol $so, $_), @source
		660	}
		661
		662	my %ignore;
		663
		664	sub entersub {
		665	my ($cv) = @_;
		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
		674	eval {
		675	my @cv;
		676	my @cv_source;
		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
		694	my @ptr = source2ptr @cv_source;
		695
		696	for (0 .. $#cv) {
		697	patch_cv $cv[$_], $ptr[$_];
		698	}
		699	};
		700
		701	if ($@) {
		702	$ignore{$pkg}++;
		703	warn $@;
		704	}
205	}	705	}
206		706
207	hook_entersub;	707	hook_entersub;
208		708
209	1;	709	1;
210		710
211	=back	711	=back
212		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
213	=head1 LIMITATIONS	744	=head1 BUGS/LIMITATIONS
214		745
215	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)
216		769
217	=head1 AUTHOR	770	=head1 AUTHOR
218		771
219	Marc Lehmann <schmorp@schmorp.de>	772	Marc Lehmann <schmorp@schmorp.de>
220	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.3 by root, Thu Mar 9 06:35:33 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.3 by root, Thu Mar 9 06:35:33 2006 UTC vs.
Revision 1.24 by root, Sat Mar 11 04:53:00 2006 UTC