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

Comparing Faster/Faster.pm (file contents):
Revision 1.2 by root, Thu Mar 9 06:03:12 2006 UTC vs.
Revision 1.33 by root, Mon Mar 13 17:10:32 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" (or actually AIT, ahead
		14	of time compiler). It works by more or less translating every function it
		15	sees into a C program, compiling it and then replacing the function by the
		16	compiled code.
		17
		18	As a result, startup times are immense, as every function might lead to a
		19	full-blown compilation.
		20
		21	The speed improvements are also not great, you can expect 20% or so on
		22	average, for code that runs very often. The reason for this is that data
		23	handling is mostly being done by the same old code, it just gets called
		24	a bit faster. Regexes and string operations won't get faster. Airhtmetic
		25	doresn't become any faster. Just the operands and other stuff is put on
		26	the stack faster, and the opcodes themselves have a bit less overhead.
		27
		28	Faster is in the early stages of development. Due to its design its
		29	relatively safe to use (it will either work or simply slowdown the program
		30	immensely, but rarely cause bugs).
		31
		32	More intelligent algorithms (loop optimisation, type inference) could
		33	improve that easily, but requires a much more elaborate presentation and
		34	optimiser than what is in place. There are no plans to improve Faster in
		35	this way, yet, but it would provide a reasonably good place to start.
		36
		37	Usage is very easy, just C<use Faster> and every function called from then
		38	on will be compiled.
		39
		40	Right now, Faster can leave lots of F<.c> and F<.so> files in your
		41	F<$FASTER_CACHEDIR> (by default F<$HOME/.perl-faster-cache>), and it will
		42	even create those temporary files in an insecure manner, so watch out.
		43
11	=over 4	44	=over 4
12		45
13	=cut	46	=cut
14		47
15	package Faster;	48	package Faster;
16		49
		50	no warnings;
		51
17	use strict;	52	use strict;
		53	use Config;
		54	use B ();
		55	use DynaLoader ();
		56	use Digest::MD5 ();
		57	use Storable ();
		58	use Fcntl ();
18		59
19	BEGIN {	60	BEGIN {
20	our $VERSION = '0.01';	61	our $VERSION = '0.01';
21		62
22	require XSLoader;	63	require XSLoader;
23	XSLoader::load __PACKAGE__, $VERSION;	64	XSLoader::load __PACKAGE__, $VERSION;
24	}	65	}
25		66
26	use B ();	67	my $CACHEDIR =
		68	$ENV{FASTER_CACHE}
		69	\|\| (exists $ENV{HOME} && "$ENV{HOME}/.perl-faster-cache")
		70	\|\| do {
		71	require File::Temp;
		72	File::Temp::tempdir (CLEANUP => 1)
		73	};
		74
		75	my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}";
		76	my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
		77	my $LIBS = "$Config{libs}";
		78	my $_o = $Config{_o};
		79	my $_so = ".so";
		80
		81	# we don't need no steenking PIC on x86
		82	$COMPILE =~ s/-f(?:PIC\|pic)//g
		83	if $Config{archname} =~ /^(i[3456]86)-/;
		84
		85	my $opt_assert = $ENV{FASTER_DEBUG} > 1;
		86	my $verbose = $ENV{FASTER_VERBOSE}+0;
		87
		88	warn "Faster: CACHEDIR is $CACHEDIR\n" if $verbose > 2;
27		89
28	our $source;	90	our $source;
29	our $label_next;
30	our $label_last;
31	our $label_redo;
32		91
33	my %flag;	92	our @ops;
		93	our $insn;
		94	our $op;
		95	our $op_name;
		96	our @op_loop;
		97	our %op_regcomp;
34		98
35	for (split /\n/, <<EOF) {	99	# ops that cause immediate return to the interpreter
36	leavesub unsafe	100	my %f_unsafe = map +($_ => undef), qw(
37	leavesublv unsafe	101	leavesub leavesublv return
38	return unsafe	102	goto last redo next
39	flip unsafe	103	eval flip leaveeval entertry
40	goto unsafe	104	formline grepstart mapstart
41	last unsafe	105	substcont entereval require
42	redo unsafe	106	);
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		107
53	undef $flag{$_}{$op}	108	# ops with known stack extend behaviour
54	for ("known", @flags);	109	# the values given are maximum values
		110	my %extend = (
		111	pushmark => 0,
		112	nextstate => 0, # might reduce the stack
		113	unstack => 0,
		114	enter => 0,
		115
		116	stringify => 0,
		117	not => 0,
		118	and => 0,
		119	or => 0,
		120	gvsv => 0,
		121	rv2gv => 0,
		122	preinc => 0,
		123	predec => 0,
		124	postinc => 0,
		125	postdec => 0,
		126	aelem => 0,
		127	helem => 0,
		128	qr => 1, #???
		129	pushre => 1,
		130	gv => 1,
		131	aelemfast => 1,
		132	aelem => 0,
		133	padsv => 1,
		134	const => 1,
		135	pop => 1,
		136	shift => 1,
		137	eq => -1,
		138	ne => -1,
		139	gt => -1,
		140	lt => -1,
		141	ge => -1,
		142	lt => -1,
		143	cond_expr => -1,
		144	add => -1,
		145	subtract => -1,
		146	multiply => -1,
		147	divide => -1,
		148	aassign => 0,
		149	sassign => -2,
		150	method => 0,
		151	method_named => 1,
		152	);
		153
		154	# ops that do not need an ASYNC_CHECK
		155	my %f_noasync = map +($_ => undef), qw(
		156	mapstart grepstart match entereval
		157	enteriter entersub leaveloop
		158
		159	pushmark nextstate caller
		160
		161	const stub unstack
		162	last next redo goto seq
		163	padsv padav padhv padany
		164	aassign sassign orassign
		165	rv2av rv2cv rv2gv rv2hv refgen
		166	gv gvsv
		167	add subtract multiply divide
		168	complement cond_expr and or not
		169	bit_and bit_or bit_xor
		170	defined
		171	method method_named bless
		172	preinc postinc predec postdec
		173	aelem aelemfast helem delete exists
		174	pushre subst list lslice join split concat
		175	length substr stringify ord
		176	push pop shift unshift
		177	eq ne gt lt ge le
		178	regcomp regcreset regcmaybe
		179	);
		180
		181	my %callop = (
		182	entersub => "(PL_op->op_ppaddr) (aTHX)",
		183	mapstart => "Perl_pp_grepstart (aTHX)",
		184	);
		185
		186	sub callop {
		187	$callop{$op_name} \|\| "Perl_pp_$op_name (aTHX)"
		188	}
		189
		190	sub assert {
		191	return unless $opt_assert;
		192	$source .= " assert ((\"$op_name\", ($_[0])));\n";
		193	}
		194
		195	sub out_callop {
		196	assert "nextop == (OP *)$$op";
		197	$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
		198	}
		199
		200	sub out_cond_jump {
		201	$source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
		202	}
		203
		204	sub out_jump_next {
		205	out_cond_jump $op_regcomp{$$op}
		206	if $op_regcomp{$$op};
		207
		208	assert "nextop == (OP *)${$op->next}";
		209	$source .= " goto op_${$op->next};\n";
55	}	210	}
56		211
57	sub out_next {	212	sub out_next {
58	my ($op) = @_;
59
60	my $ppaddr = ppaddr $op->type;
61
62	$source .= " PL_op = (OP *)${$op->next}L;\n";	213	$source .= " nextop = (OP *)${$op->next}L;\n";
63	$source .= " goto op_${$op->next};\n";	214
		215	out_jump_next;
64	}	216	}
		217
		218	sub out_linear {
		219	out_callop;
		220	out_jump_next;
		221	}
		222
		223	sub op_entersub {
		224	out_callop;
		225	$source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n";
		226	out_jump_next;
		227	}
		228
		229	*op_require = \&op_entersub;
65		230
66	sub op_nextstate {	231	sub op_nextstate {
67	my ($op) = @_;
68
69	$source .= " PL_curcop = (COP *)PL_op;\n";	232	$source .= " PL_curcop = (COP *)nextop;\n";
70	$source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";	233	$source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
71	$source .= " FREETMPS;\n";	234	$source .= " FREETMPS;\n";
72		235
73	out_next $op;	236	out_next;
74	}	237	}
75		238
76	sub op_const {	239	sub op_pushmark {
77	my ($op) = @_;	240	$source .= " faster_PUSHMARK (PL_stack_sp);\n";
78		241
		242	out_next;
		243	}
		244
		245	if ($Config{useithreads} ne "define") {
		246	# disable optimisations on ithreads
		247
		248	*op_const = sub {
79	$source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";	249	$source .= " { dSP; PUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
80		250
		251	$ops[0]{follows_const}++ if @ops;#d#
		252
81	out_next $op;	253	out_next;
82	}	254	};
83		255
84	*op_gv = \&op_const;	256	*op_gv = \&op_const;
85		257
86	sub entersub {	258	*op_aelemfast = sub {
		259	my $targ = $op->targ;
		260	my $private = $op->private;
		261
		262	$source .= " {\n";
		263
		264	if ($op->flags & B::OPf_SPECIAL) {
		265	$source .= " AV av = (AV)PAD_SV((PADOFFSET)$targ);\n";
		266	} else {
		267	$source .= " AV av = GvAV ((GV )${$op->sv}L);\n";
		268	}
		269
		270	if ($op->flags & B::OPf_MOD) {
		271	$source .= " SV sv = av_fetch (av, $private, 1);\n";
		272	} else {
		273	$source .= " SV *svp = av_fetch (av, $private, 0); SV sv = svp ? *svp : &PL_sv_undef;\n";
		274	}
		275
		276	if (!($op->flags & B::OPf_MOD)) {
		277	$source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
		278	}
		279
		280	$source .= " dSP;\n";
		281	$source .= " PUSHs (sv);\n";
		282	$source .= " PUTBACK;\n";
		283	$source .= " }\n";
		284
		285	out_next;
		286	};
		287
		288	*op_gvsv = sub {
		289	$source .= " {\n";
		290	$source .= " dSP;\n";
		291
		292	if ($op->private & B::OPpLVAL_INTRO) {
		293	$source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
		294	} else {
		295	$source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
		296	}
		297
		298	$source .= " PUTBACK;\n";
		299	$source .= " }\n";
		300
		301	out_next;
		302	};
		303	}
		304
		305	# does kill Crossfire/res2pm
		306	sub op_stringify {
		307	my $targ = $op->targ;
		308
		309	$source .= <<EOF;
		310	{
		311	dSP;
		312	SV *targ = PAD_SV ((PADOFFSET)$targ);
		313	sv_copypv (TARG, TOPs);
		314	SETTARG;
		315	PUTBACK;
		316	}
		317	EOF
		318
		319	out_next;
		320	}
		321
		322	sub op_and {
		323	$source .= <<EOF;
		324	{
		325	dSP;
		326
		327	if (SvTRUE (TOPs))
		328	{
		329	--SP;
		330	PUTBACK;
		331	nextop = (OP *)${$op->other}L;
		332	goto op_${$op->other};
		333	}
		334	}
		335	EOF
		336
		337	out_next;
		338	}
		339
		340	sub op_or {
		341	$source .= <<EOF;
		342	{
		343	dSP;
		344
		345	if (!SvTRUE (TOPs))
		346	{
		347	--SP;
		348	PUTBACK;
		349	nextop = (OP *)${$op->other}L;
		350	goto op_${$op->other};
		351	}
		352	}
		353	EOF
		354
		355	out_next;
		356	}
		357
		358	sub op_padsv {
		359	my $flags = $op->flags;
		360	my $padofs = "(PADOFFSET)" . $op->targ;
		361
		362	$source .= <<EOF;
		363	{
		364	dSP;
		365	SV *sv = PAD_SVl ($padofs);
		366	EOF
		367
		368	if (($flags & B::OPf_MOD) && ($op->private & B::OPpLVAL_INTRO)) {
		369	$source .= " SAVECLEARSV (PAD_SVl ($padofs));\n";
		370	$ops[0]{follows_padsv_lval_intro}++ if @ops;#d#
		371	}
		372
		373	$source .= <<EOF;
		374	PUSHs (sv);
		375	PUTBACK;
		376	EOF
		377
		378	if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
		379	$source .= " if (!SvROK (sv)) vivify_ref (sv, " . $op->private . " & OPpDEREF);\n";
		380	}
		381	$source .= " }\n";
		382
		383	out_next;
		384	}
		385
		386	sub op_sassign {
		387	$source .= <<EOF;
		388	{
		389	dSP;
		390	dPOPTOPssrl;
		391	EOF
		392	$source .= " SV *temp = left; left = right; right = temp;\n"
		393	if $op->private & B::OPpASSIGN_BACKWARDS;
		394
		395	if ($insn->{follows_padsv_lval_intro} && !($op->private & B::OPpASSIGN_BACKWARDS)) {
		396	# simple assignment - the target exists, but is basically undef
		397	$source .= " SvSetSV (right, left);\n";
		398	} else {
		399	$source .= " SvSetMagicSV (right, left);\n";
		400	}
		401
		402	$source .= <<EOF;
		403	SETs (right);
		404	PUTBACK;
		405	}
		406	EOF
		407
		408	out_next;
		409	}
		410
		411	# pattern const+ (or general push1)
		412	# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
		413
		414	sub op_method_named {
		415	if ($insn->{follows_const}) {
		416	$source .= <<EOF;
		417	{
		418	dSP;
		419	static SV *last_cv;
		420	static U32 last_sub_generation;
		421
		422	/* simple "polymorphic" inline cache */
		423	if (PL_sub_generation == last_sub_generation)
		424	{
		425	PUSHs (last_cv);
		426	PUTBACK;
		427	}
		428	else
		429	{
		430	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
		431
		432	SPAGAIN;
		433	last_sub_generation = PL_sub_generation;
		434	last_cv = TOPs;
		435	}
		436	}
		437	EOF
		438	} else {
		439	$source .= <<EOF;
		440	{
		441	static HV *last_stash;
		442	static SV *last_cv;
		443	static U32 last_sub_generation;
		444
		445	SV obj = (PL_stack_base + TOPMARK + 1);
		446
		447	if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
		448	{
		449	dSP;
		450	HV *stash = SvSTASH (SvRV (obj));
		451
		452	/* simple "polymorphic" inline cache */
		453	if (stash == last_stash
		454	&& PL_sub_generation == last_sub_generation)
		455	{
		456	PUSHs (last_cv);
		457	PUTBACK;
		458	}
		459	else
		460	{
		461	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
		462
		463	SPAGAIN;
		464	last_sub_generation = PL_sub_generation;
		465	last_stash = stash;
		466	last_cv = TOPs;
		467	}
		468	}
		469	else
		470	{
		471	/* error case usually */
		472	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
		473	}
		474	}
		475	EOF
		476	}
		477
		478	out_next;
		479	}
		480
		481	sub op_grepstart {
		482	out_callop;
		483	$op = $op->next;
		484	out_cond_jump $op->other;
		485	out_jump_next;
		486	}
		487
		488	*op_mapstart = \&op_grepstart;
		489
		490	sub op_substcont {
		491	out_callop;
		492	out_cond_jump $op->other->pmreplstart;
		493	assert "nextop == (OP *)${$op->other->next}L";
		494	$source .= " goto op_${$op->other->next};\n";
		495	}
		496
		497	sub out_break_op {
		498	my ($idx) = @_;
		499
		500	out_callop;
		501
		502	out_cond_jump $_->[$idx]
		503	for reverse @op_loop;
		504
		505	$source .= " return nextop;\n";
		506	}
		507
		508	sub xop_next {
		509	out_break_op 0;
		510	}
		511
		512	sub op_last {
		513	out_break_op 1;
		514	}
		515
		516	sub xop_redo {
		517	out_break_op 2;
		518	}
		519
		520	sub cv2c {
87	my ($cv) = @_;	521	my ($cv) = @_;
88		522
		523	local @ops;
		524	local @op_loop;
		525	local %op_regcomp;
		526
89	my %opsseen;	527	my %opsseen;
90	my @ops;
91	my @todo = $cv->START;	528	my @todo = $cv->START;
		529	my %op_target;
		530	my $numpushmark;
92		531
93	while (my $op = shift @todo) {	532	while (my $op = shift @todo) {
94	for (; $$op; $op = $op->next) {	533	for (; $$op; $op = $op->next) {
95	last if $opsseen{$$op}++;	534	last if $opsseen{$$op}++;
96	push @ops, $op;	535
97	my $name = $op->name;	536	my $name = $op->name;
		537	my $class = B::class $op;
		538
		539	my $insn = { op => $op };
		540
		541	push @ops, $insn;
		542
		543	if (exists $extend{$name}) {
		544	my $extend = $extend{$name};
		545	$extend = $extend->($op) if ref $extend;
		546	$insn->{extend} = $extend if defined $extend;
		547	}
		548
		549	push @todo, $op->next;
		550
98	if (B::class($op) eq "LOGOP") {	551	if ($class eq "LOGOP") {
99	push @todo, $op->other;	552	push @todo, $op->other;
100	} elsif ($name eq "subst" and ${ $op->pmreplstart }) {	553	$op_target{${$op->other}}++;
101	push @todo, $op->pmreplstart;	554
102	} elsif ($name =~ /^enter(loop\|iter)$/) {	555	# regcomp/o patches ops at runtime, lets expect that
103	# if ($] > 5.009) {	556	if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
104	# $labels{${$op->nextop}} = "NEXT";	557	$op_target{${$op->first}}++;
105	# $labels{${$op->lastop}} = "LAST";	558	$op_regcomp{${$op->first}} = $op->next;
106	# $labels{${$op->redoop}} = "REDO";
107	# } else {
108	# $labels{$op->nextop->seq} = "NEXT";
109	# $labels{$op->lastop->seq} = "LAST";
110	# $labels{$op->redoop->seq} = "REDO";
111	# }	559	}
		560
		561	} elsif ($class eq "PMOP") {
		562	if (${$op->pmreplstart}) {
		563	unshift @todo, $op->pmreplstart;
		564	$op_target{${$op->pmreplstart}}++;
		565	}
		566
		567	} elsif ($class eq "LOOP") {
		568	my @targ = ($op->nextop, $op->lastop->next, $op->redoop->next);
		569
		570	push @op_loop, \@targ;
		571	push @todo, @targ;
		572
		573	$op_target{$$_}++ for @targ;
		574
		575	} elsif ($class eq "COP") {
		576	$insn->{bblock}++ if defined $op->label;
		577
		578	} else {
		579	if ($name eq "pushmark") {
		580	$numpushmark++;
		581	}
112	}	582	}
113	}	583	}
114	}	584	}
115		585
		586	$_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
		587
116	local $source;	588	local $source = <<EOF;
		589	OP *%%%FUNC%%% (pTHX)
		590	{
		591	register OP nextop = (OP )${$ops[0]->{op}}L;
		592	EOF
117		593
118	$source = "typedef OP (PPFUNC)(pTHX);\n\n";	594	$source .= " faster_PUSHMARK_PREALLOC ($numpushmark);\n"
119		595	if $numpushmark;
120	$source .= "OP *func (pTHX)\n{\n";
121		596
122	for my $op (@ops) {	597	while (@ops) {
		598	$insn = shift @ops;
		599
		600	$op = $insn->{op};
123	my $name = $op->name;	601	$op_name = $op->name;
124	my $ppaddr = ppaddr $op->type;
125		602
		603	my $class = B::class $op;
		604
		605	$source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
126	$source .= "op_$$op: /* $name */\n";	606	$source .= "op_$$op: /* $op_name */\n";
		607	#$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
		608	#$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
127		609
		610	$source .= " PERL_ASYNC_CHECK ();\n"
		611	unless exists $f_noasync{$op_name};
		612
128	if (my $can = __PACKAGE__->can ("op_$name")) {	613	if (my $can = __PACKAGE__->can ("op_$op_name")) {
		614	# handcrafted replacement
		615
		616	if ($insn->{extend} > 0) {
		617	# coalesce EXTENDs
		618	# TODO: properly take negative preceeding and following EXTENDs into account
		619	for my $i (@ops) {
		620	last if exists $i->{bblock};
		621	last unless exists $i->{extend};
		622	my $extend = delete $i->{extend};
		623	$insn->{extend} += $extend if $extend > 0;
		624	}
		625
		626	$source .= " { dSP; EXTEND (SP, $insn->{extend}); PUTBACK; }\n"
		627	if $insn->{extend} > 0;
		628	}
		629
129	$can->($op);	630	$can->($op);
130	} elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) {	631
131	$source .= " PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n";
132	$source .= " if (PL_op == (OP *)${$op->other}L) goto op_${$op->other};\n";
133	$source .= " goto op_${$op->next};\n";
134	} elsif (exists $flag{unsafe}{$name}) {	632	} elsif (exists $f_unsafe{$op_name}) {
135	$source .= " return ((PPFUNC)${ppaddr}L)(aTHX);\n";	633	# unsafe, return to interpreter
		634	assert "nextop == (OP *)$$op";
		635	$source .= " return nextop;\n";
		636
		637	} elsif ("LOGOP" eq $class) {
		638	# logical operation with optional branch
		639	out_callop;
		640	out_cond_jump $op->other;
		641	out_jump_next;
		642
		643	} elsif ("PMOP" eq $class) {
		644	# regex-thingy
		645	out_callop;
		646	out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
		647	out_jump_next;
		648
136	} else {	649	} else {
137	$source .= " PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n";	650	# normal operator, linear execution
138	$source .= " goto op_${$op->next};\n";	651	out_linear;
		652	}
		653	}
		654
		655	$op_name = "func exit"; assert (0);
		656
		657	$source .= <<EOF;
		658	op_0:
		659	return 0;
		660	}
		661	EOF
		662	#warn $source;
		663
		664	$source
		665	}
		666
		667	my $uid = "aaaaaaa0";
		668	my %so;
		669
		670	sub func2ptr {
		671	my (@func) = @_;
		672
		673	#LOCK
		674	mkdir $CACHEDIR, 0777;
		675	sysopen my $meta_fh, "$CACHEDIR/meta", &Fcntl::O_RDWR \| &Fcntl::O_CREAT, 0666
		676	or die "$$CACHEDIR/meta: $!";
		677	binmode $meta_fh, ":raw:perlio";
		678	fcntl_lock fileno $meta_fh
		679	or die "$CACHEDIR/meta: $!";
		680
		681	my $meta = eval { Storable::fd_retrieve $meta_fh } \|\| { version => 1 };
		682
		683	for my $f (@func) {
		684	$f->{func} = "F" . Digest::MD5::md5_hex ($f->{source});
		685	$f->{so} = $meta->{$f->{func}};
		686	}
		687
		688	if (grep !$_->{so}, @func) {
		689	my $stem;
139	}	690
140	}	691	do {
		692	$stem = "$CACHEDIR/$$-" . $uid++;
		693	} while -e "$stem$_so";
141		694
142	$source .= "}\n";	695	open my $fh, ">:raw", "$stem.c";
143
144	print <<EOF;	696	print $fh <<EOF;
		697	#define PERL_NO_GET_CONTEXT
		698	#define PERL_CORE
		699
		700	#include <assert.h>
		701
145	#include "EXTERN.h"	702	#include "EXTERN.h"
146	#include "perl.h"	703	#include "perl.h"
147	#include "XSUB.h"	704	#include "XSUB.h"
		705
		706	#if 1
		707	# define faster_PUSHMARK_PREALLOC(count) while (PL_markstack_ptr + (count) >= PL_markstack_max) markstack_grow ()
		708	# define faster_PUSHMARK(p) *++PL_markstack_ptr = (p) - PL_stack_base
		709	#else
		710	# define faster_PUSHMARK_PREALLOC(count) 1
		711	# define faster_PUSHMARK(p) PUSHMARK(p)
		712	#endif
		713
		714	#define RUNOPS_TILL(op) \\
		715	while (nextop != (op)) \\
		716	{ \\
		717	PERL_ASYNC_CHECK (); \\
		718	PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
		719	}
		720
148	EOF	721	EOF
		722	for my $f (grep !$_->{so}, @func) {
		723	next if $f->{so} = $meta->{$f->{func}}; # some cv's alias others
		724
		725	warn "compiling $f->{name} to $stem$_so:$f->{func}\n" if $verbose > 1;
		726	my $source = $f->{source};
		727	$source =~ s/%%%FUNC%%%/$f->{func}/g;
149	print $source;	728	print $fh $source;
		729	$meta->{$f->{func}} = $f->{so} = $stem;
		730	}
		731
		732	close $fh;
		733	system "$COMPILE -o $stem$_o $stem.c";
		734	unlink "$stem.c" unless $ENV{FASTER_DEBUG} > 0;
		735	system "$LINK -o $stem$_so $stem$_o $LIBS";
		736	unlink "$stem$_o";
		737	}
		738
		739	for my $f (@func) {
		740	my $stem = $f->{so};
		741
		742	my $so = ($so{$stem} \|\|= DynaLoader::dl_load_file "$stem$_so")
		743	or die "$stem$_so: $!";
		744
		745	#unlink "$stem$_so";
		746
		747	$f->{ptr} = DynaLoader::dl_find_symbol $so, $f->{func}
		748	or die "$f->{func} not found in $stem$_so: $!";
		749	}
		750
		751	seek $meta_fh, 0, 0 or die "$CACHEDIR/meta: $!";
		752	Storable::nstore_fd $meta, $meta_fh;
		753	truncate $meta_fh, tell $meta_fh;
		754
		755	# UNLOCK (by closing $meta_fh)
		756	}
		757
		758	my %ignore;
		759
		760	sub entersub {
		761	my ($cv) = @_;
		762
		763	my $pkg = $cv->STASH->NAME;
		764
		765	return if $ignore{$pkg};
		766
		767	warn "optimising ", $cv->STASH->NAME, "\n"
		768	if $verbose;
		769
		770	eval {
		771	my @func;
		772
		773	push @func, {
		774	cv => $cv,
		775	name => "<>",
		776	source => cv2c $cv,
		777	};
		778
		779	# always compile the whole stash
		780	my %stash = $cv->STASH->ARRAY;
		781	while (my ($k, $v) = each %stash) {
		782	$v->isa (B::GV::)
		783	or next;
		784
		785	my $cv = $v->CV;
		786
		787	if ($cv->isa (B::CV::)
		788	&& ${$cv->START}
		789	&& $cv->START->name ne "null") {
		790
		791	push @func, {
		792	cv => $cv,
		793	name => $k,
		794	source => cv2c $cv,
		795	};
		796	}
		797	}
		798
		799	func2ptr @func;
		800
		801	for my $f (@func) {
		802	patch_cv $f->{cv}, $f->{ptr};
		803	}
		804	};
		805
		806	if ($@) {
		807	$ignore{$pkg}++;
		808	warn $@;
		809	}
150	}	810	}
151		811
152	hook_entersub;	812	hook_entersub;
153		813
154	1;	814	1;
155		815
156	=back	816	=back
157		817
		818	=head1 ENVIRONMENT VARIABLES
		819
		820	The following environment variables influence the behaviour of Faster:
		821
		822	=over 4
		823
		824	=item FASTER_VERBOSE
		825
		826	Faster will output more informational messages when set to values higher
		827	than C<0>. Currently, C<1> outputs which packages are being compiled, C<3>
		828	outputs the cache directory and C<10> outputs information on which perl
		829	function is compiled into which shared object.
		830
		831	=item FASTER_DEBUG
		832
		833	Add debugging code when set to values higher than C<0>. Currently, this
		834	adds 1-3 C<assert>'s per perl op (FASTER_DEBUG > 1), to ensure that opcode
		835	order and C execution order are compatible.
		836
		837	=item FASTER_CACHE
		838
		839	Set a persistent cache directory that caches compiled code fragments. The
		840	default is C<$HOME/.perl-faster-cache> if C<HOME> is set and a temporary
		841	directory otherwise.
		842
		843	This directory will always grow in size, so you might need to erase it
		844	from time to time.
		845
		846	=back
		847
158	=head1 LIMITATIONS	848	=head1 BUGS/LIMITATIONS
159		849
160	Tainting and debugging will disable Faster.	850	Perl will check much less often for asynchronous signals in
		851	Faster-compiled code. It tries to check on every function call, loop
		852	iteration and every I/O operator, though.
		853
		854	The following things will disable Faster. If you manage to enable them at
		855	runtime, bad things will happen. Enabling them at startup will be fine,
		856	though.
		857
		858	enabled tainting
		859	enabled debugging
		860
		861	Thread-enabled builds of perl will dramatically reduce Faster's
		862	performance, but you don't care about speed if you enable threads anyway.
		863
		864	These constructs will force the use of the interpreter for the currently
		865	executed function as soon as they are being encountered during execution.
		866
		867	goto
		868	next, redo (but not well-behaved last's)
		869	eval
		870	require
		871	any use of formats
		872	.., ... (flipflop operators)
161		873
162	=head1 AUTHOR	874	=head1 AUTHOR
163		875
164	Marc Lehmann <schmorp@schmorp.de>	876	Marc Lehmann <schmorp@schmorp.de>
165	http://home.schmorp.de/	877	http://home.schmorp.de/

Diff Legend

-–
+Removed lines
-+
+Added lines
-<
+Changed lines
->
+Changed lines

Comparing Faster/Faster.pm (file contents): Revision 1.2 by root, Thu Mar 9 06:03:12 2006 UTC vs. Revision 1.33 by root, Mon Mar 13 17:10:32 2006 UTC

Diff Legend

Comparing Faster/Faster.pm (file contents):
Revision 1.2 by root, Thu Mar 9 06:03:12 2006 UTC vs.
Revision 1.33 by root, Mon Mar 13 17:10:32 2006 UTC