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

Comparing Faster/Faster.pm (file contents):
Revision 1.8 by root, Fri Mar 10 01:51:14 2006 UTC vs.
Revision 1.12 by root, Fri Mar 10 18:39:26 2006 UTC

…		…
31	my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";	31	my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
32	my $LIBS = "$Config{libs}";	32	my $LIBS = "$Config{libs}";
33	my $_o = $Config{_o};	33	my $_o = $Config{_o};
34	my $_so = ".so";	34	my $_so = ".so";
35		35
		36	my $opt_assert = 1;
		37
36	our $source;	38	our $source;
37	our $label_next;
38	our $label_last;
39	our $label_redo;
40		39
41	my @ops;	40	my @ops;
42	my $op;	41	my $op;
43	my $op_name;	42	my $op_name;
		43	my @loop;
44		44
45	my %flag;	45	my %flag;
46		46
		47	# complex flag steting is no longer required, rewrite this ugly code
47	for (split /\n/, <<EOF) {	48	for (split /\n/, <<EOF) {
48	leavesub unsafe	49	leavesub unsafe
49	leavesublv unsafe	50	leavesublv unsafe
50	return unsafe	51	return unsafe
51	flip unsafe	52	flip unsafe
…		…
54	redo unsafe	55	redo unsafe
55	next unsafe	56	next unsafe
56	eval unsafe	57	eval unsafe
57	leaveeval unsafe	58	leaveeval unsafe
58	entertry unsafe	59	entertry unsafe
59	substconst unsafe
60	formline unsafe	60	formline unsafe
61	grepstart unsafe	61	grepstart unsafe
		62	mapstart unsafe
		63	substcont unsafe
		64	entereval unsafe noasync todo
62	require unsafe	65	require unsafe
63	match unsafe noasync todo	66
64	subst unsafe noasync todo
65	entereval unsafe noasync todo
66	mapstart unsafe noasync todo	67	mapstart noasync
67		68	grepstart noasync
68	mapwhile noasync	69	match noasync
69	grepwhile noasync
70		70
		71	last noasync
		72	next noasync
		73	redo noasync
71	seq noasync	74	seq noasync
72	pushmark noasync	75	pushmark noasync extend=0
73	padsv noasync extend=1	76	padsv noasync extend=1
74	padav noasync extend=1	77	padav noasync extend=1
75	padhv noasync extend=1	78	padhv noasync extend=1
76	padany noasync extend=1	79	padany noasync extend=1
77	entersub noasync	80	entersub noasync
…		…
105	leaveloop noasync	108	leaveloop noasync
106	aelem noasync	109	aelem noasync
107	aelemfast noasync	110	aelemfast noasync
108	helem noasync	111	helem noasync
109	pushre noasync	112	pushre noasync
		113	subst noasync
110	const noasync extend=1	114	const noasync extend=1
111	list noasync	115	list noasync
112	join noasync	116	join noasync
113	split noasync	117	split noasync
114	concat noasync	118	concat noasync
115	push noasync	119	push noasync
116	pop noasync	120	pop noasync
117	shift noasync	121	shift noasync
118	unshift noasync	122	unshift noasync
119	require noasync
120	length noasync	123	length noasync
121	substr noasync	124	substr noasync
122	stringify noasync	125	stringify noasync
123	eq noasync	126	eq noasync
124	ne noasync	127	ne noasync
125	gt noasync	128	gt noasync
126	lt noasync	129	lt noasync
127	ge noasync	130	ge noasync
128	le noasync	131	le noasync
129	enteriter noasync	132	enteriter noasync
		133	ord noasync
130		134
131	iter async	135	iter async
132	EOF	136	EOF
133	my (undef, $op, @flags) = split /\s+/;	137	my (undef, $op, @flags) = split /\s+/;
134		138
135	undef $flag{$_}{$op}	139	undef $flag{$_}{$op}
136	for ("known", @flags);	140	for ("known", @flags);
137	}	141	}
138		142
		143	my %callop = (
		144	entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)",
		145	mapstart => "Perl_pp_grepstart (aTHX)",
		146	);
		147
139	sub callop {	148	sub callop {
140	$op_name eq "entersub"	149	$callop{$op_name} \|\| "Perl_pp_$op_name (aTHX)"
141	? "(PL_ppaddr [OP_ENTERSUB]) (aTHX)"	150	}
142	: $op_name eq "mapstart"	151
143	? "Perl_pp_grepstart (aTHX)"	152	sub assert {
144	: "Perl_pp_$op_name (aTHX)"	153	return unless $opt_assert;
		154	$source .= " assert ((\"$op_name\", ($_[0])));\n";
		155	}
		156
		157	sub out_callop {
		158	assert "nextop == (OP *)$$op";
		159	$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
		160	}
		161
		162	sub out_jump_next {
		163	assert "nextop == (OP *)${$op->next}";
		164	$source .= " goto op_${$op->next};\n";
145	}	165	}
146		166
147	sub out_next {	167	sub out_next {
148	if (${$op->next}) {
149	$source .= " nextop = (OP *)${$op->next}L;\n";	168	$source .= " nextop = (OP *)${$op->next}L;\n";
150	$source .= " assert ((\"$op_name\", nextop == (OP *)${$op->next}));\n";	169
151	$source .= " goto op_${$op->next};\n";	170	out_jump_next;
152	} else {
153	$source .= " return 0;\n";
154	}
155	}	171	}
156		172
157	sub out_linear {	173	sub out_linear {
158	$source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";#d#	174	out_callop;
159	$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
160	if ($op_name eq "entersub") {
161	$source .= <<EOF;
162	while (nextop != (OP *)${$op->next}L)
163	{
164	PERL_ASYNC_CHECK ();
165	PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX);
166	}
167	EOF
168	}
169
170	out_next;	175	out_jump_next;
171	}	176	}
		177
		178	sub out_cond_jump {
		179	$source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
		180	}
		181
		182	sub op_entersub {
		183	out_callop;
		184	$source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n";
		185	out_jump_next;
		186	}
		187
		188	*op_require = \&op_entersub;
172		189
173	sub op_nextstate {	190	sub op_nextstate {
174	$source .= " PL_curcop = (COP *)nextop;\n";	191	$source .= " PL_curcop = (COP *)nextop;\n";
175	$source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";	192	$source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
176	$source .= " FREETMPS;\n";	193	$source .= " FREETMPS;\n";
…		…
182	$source .= " PUSHMARK (PL_stack_sp);\n";	199	$source .= " PUSHMARK (PL_stack_sp);\n";
183		200
184	out_next;	201	out_next;
185	}	202	}
186		203
187	if ($Config{useithreads} ne "define") {	204	if (0 && $Config{useithreads} ne "define") {
188	# disable optimisations on ithreads	205	# disable optimisations on ithreads
189		206
190	*op_const = sub {	207	*op_const = sub {
191	$source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";	208	$source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
192		209
…		…
241		258
242	out_next;	259	out_next;
243	};	260	};
244	}	261	}
245		262
		263	# does kill Crossfire/res2pm
246	sub op_stringify {	264	sub op_stringify {
247	$source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n";	265	my $targ = $op->targ;
		266
		267	$source .= <<EOF;
		268	{
		269	dSP;
		270	SV *targ = PAD_SV ((PADOFFSET)$targ);
		271	sv_copypv (TARG, TOPs);
		272	SETTARG;
		273	PUTBACK;
		274	}
		275	EOF
248		276
249	out_next;	277	out_next;
250	}	278	}
251		279
252	sub op_and {	280	sub op_and {
…		…
317	# pattern const method_named	345	# pattern const method_named
318	sub op_method_named {	346	sub op_method_named {
319	$source .= <<EOF;	347	$source .= <<EOF;
320	{	348	{
321	static HV *last_stash;	349	static HV *last_stash;
322	static SV *last_res;	350	static SV *last_cv;
		351	static U32 last_sub_generation;
323		352
324	SV obj = (PL_stack_base + TOPMARK + 1);	353	SV obj = (PL_stack_base + TOPMARK + 1);
325		354
326	if (SvROK (obj) && SvOBJECT (SvRV (obj)))	355	if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
327	{	356	{
328	dSP;	357	dSP;
329	HV *stash = SvSTASH (SvRV (obj));	358	HV *stash = SvSTASH (SvRV (obj));
330		359
331	/* simple "polymorphic" inline cache */	360	/* simple "polymorphic" inline cache */
332	if (stash == last_stash)	361	if (stash == last_stash
		362	&& PL_sub_generation == last_sub_generation)
333	{	363	{
334	XPUSHs (last_res);	364	XPUSHs (last_cv);
335	PUTBACK;	365	PUTBACK;
336	}	366	}
337	else	367	else
338	{	368	{
339	PL_op = nextop;
340	nextop = Perl_pp_method_named (aTHX);	369	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
341		370
342	SPAGAIN;	371	SPAGAIN;
		372	last_sub_generation = PL_sub_generation;
343	last_stash = stash;	373	last_stash = stash;
344	last_res = TOPs;	374	last_cv = TOPs;
345	}	375	}
346	}	376	}
347	else	377	else
348	{	378	{
349	/* error case usually */	379	/* error case usually */
350	PL_op = nextop;
351	nextop = Perl_pp_method_named (aTHX);	380	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
352	}	381	}
353	}	382	}
354	EOF	383	EOF
355		384
356	out_next;	385	out_next;
		386	}
		387
		388	sub op_grepstart {
		389	out_callop;
		390	out_cond_jump $op->next->other;
		391	out_jump_next;
		392	}
		393
		394	*op_mapstart = \&op_grepstart;
		395
		396	sub op_substcont {
		397	out_callop;
		398	out_cond_jump $op->other->pmreplstart;
		399	assert "nextop == (OP *)${$op->other->next}L";
		400	$source .= " goto op_${$op->other->next};\n";
		401	}
		402
		403	sub out_break_op {
		404	my ($idx) = @_;
		405
		406	out_callop;
		407
		408	out_cond_jump $_->[$idx]
		409	for reverse @loop;
		410
		411	$source .= " return nextop;\n";
		412	}
		413
		414	sub xop_next {
		415	out_break_op 0;
		416	}
		417
		418	sub op_last {
		419	out_break_op 1;
		420	}
		421
		422	sub xop_redo {
		423	out_break_op 2;
357	}	424	}
358		425
359	sub cv2c {	426	sub cv2c {
360	my ($cv) = @_;	427	my ($cv) = @_;
		428
		429	@loop = ();
361		430
362	my %opsseen;	431	my %opsseen;
363	my @todo = $cv->START;	432	my @todo = $cv->START;
364		433
365	while (my $op = shift @todo) {	434	while (my $op = shift @todo) {
366	for (; $$op; $op = $op->next) {	435	for (; $$op; $op = $op->next) {
367	last if $opsseen{$$op}++;	436	last if $opsseen{$$op}++;
368	push @ops, $op;	437	push @ops, $op;
		438
369	my $name = $op->name;	439	my $name = $op->name;
		440	my $class = B::class $op;
		441
370	if (B::class($op) eq "LOGOP") {	442	if ($class eq "LOGOP") {
371	push @todo, $op->other;	443	unshift @todo, $op->other; # unshift vs. push saves jumps
372	} elsif ($name eq "subst" and ${ $op->pmreplstart }) {	444	} elsif ($class eq "PMOP") {
373	push @todo, $op->pmreplstart;	445	unshift @todo, $op->pmreplstart if ${$op->pmreplstart};
374	} elsif ($name =~ /^enter(loop\|iter)$/) {	446	} elsif ($class eq "LOOP") {
375	# if ($] > 5.009) {	447	push @loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
376	# $labels{${$op->nextop}} = "NEXT";
377	# $labels{${$op->lastop}} = "LAST";
378	# $labels{${$op->redoop}} = "REDO";
379	# } else {
380	# $labels{$op->nextop->seq} = "NEXT";
381	# $labels{$op->lastop->seq} = "LAST";
382	# $labels{$op->redoop->seq} = "REDO";
383	# }
384	}	448	}
385	}	449	}
386	}	450	}
387		451
388	local $source = <<EOF;	452	local $source = <<EOF;
		453	OP *%%%FUNC%%% (pTHX)
		454	{
		455	register OP nextop = (OP )${$ops[0]}L;
		456	EOF
		457
		458	while (@ops) {
		459	$op = shift @ops;
		460	$op_name = $op->name;
		461
		462	$source .= "op_$$op: /* $op_name */\n";
		463	#$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
		464	#$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
		465
		466	$source .= " PERL_ASYNC_CHECK ();\n"
		467	unless exists $flag{noasync}{$op_name};
		468
		469	if (my $can = __PACKAGE__->can ("op_$op_name")) {
		470	# handcrafted replacement
		471	$can->($op);
		472
		473	} elsif (exists $flag{unsafe}{$op_name}) {
		474	# unsafe, return to interpreter
		475	assert "nextop == (OP *)$$op";
		476	$source .= " return nextop;\n";
		477
		478	} elsif ("LOGOP" eq B::class $op) {
		479	# logical operation with optionaö branch
		480	out_callop;
		481	out_cond_jump $op->other;
		482	out_jump_next;
		483
		484	} elsif ("PMOP" eq B::class $op) {
		485	# regex-thingy
		486	out_callop;
		487	out_cond_jump $op->pmreplroot if ${$op->pmreplroot};
		488	out_jump_next;
		489
		490	} else {
		491	# normal operator, linear execution
		492	out_linear;
		493	}
		494	}
		495
		496	$op_name = "func exit"; assert (0);
		497
		498	$source .= <<EOF;
		499	op_0:
		500	return 0;
		501	}
		502	EOF
		503	#warn $source;
		504
		505	$source
		506	}
		507
		508	sub source2ptr {
		509	my ($source) = @_;
		510
		511	my $md5 = Digest::MD5::md5_hex $source;
		512	$source =~ s/%%%FUNC%%%/Faster_$md5/;
		513
		514	my $stem = "/tmp/$md5";
		515
		516	unless (-e "$stem$_so") {
		517	open FILE, ">:raw", "$stem.c";
		518	print FILE <<EOF;
389	#define PERL_NO_GET_CONTEXT	519	#define PERL_NO_GET_CONTEXT
390		520
391	//#define NDEBUG 1
392	#include <assert.h>	521	#include <assert.h>
393		522
394	#include "EXTERN.h"	523	#include "EXTERN.h"
395	#include "perl.h"	524	#include "perl.h"
396	#include "XSUB.h"	525	#include "XSUB.h"
397		526
398	OP *%%%FUNC%%% (pTHX)	527	#define RUNOPS_TILL(op) \\
399	{	528	while (nextop != (op)) \\
400	register OP nextop = (OP )${$ops[0]}L;	529	{ \\
401	EOF	530	PERL_ASYNC_CHECK (); \\
402		531	PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
403	while (@ops) {
404	$op = shift @ops;
405	$op_name = $op->name;
406
407	$source .= "op_$$op: /* $op_name */\n";
408	#$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
409	#$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
410
411	unless (exists $flag{noasync}{$op_name}) {
412	$source .= " PERL_ASYNC_CHECK ();\n";
413	}
414
415	if (my $can = __PACKAGE__->can ("op_$op_name")) {
416	$can->($op);
417	} elsif (exists $flag{unsafe}{$op_name}) {
418	$source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";
419	$source .= " PL_op = nextop; return " . (callop $op) . ";\n";
420	} elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$op_name}) {
421	$source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";
422	$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
423	$source .= " if (nextop == (OP *)${$op->other}L) goto op_${$op->other};\n";
424	$source .= " assert ((\"$op_name\", nextop == (OP *)${$op->next}));\n";
425	$source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";
426	} else {
427	out_linear;
428	}
429	}	532	}
430		533
431	$source .= "}\n";	534	EOF
432	#warn $source;
433
434	$source
435	}
436
437	sub source2ptr {
438	my ($source) = @_;
439
440	my $md5 = Digest::MD5::md5_hex $source;
441	$source =~ s/%%%FUNC%%%/Faster_$md5/;
442
443	my $stem = "/tmp/$md5";
444
445	unless (-e "$stem$_so") {
446	open FILE, ">:raw", "$stem.c";
447	print FILE $source;	535	print FILE $source;
448	close FILE;	536	close FILE;
449	system "$COMPILE -o $stem$_o $stem.c";	537	system "$COMPILE -o $stem$_o $stem.c";
450	system "$LINK -o $stem$_so $stem$_o $LIBS";	538	system "$LINK -o $stem$_so $stem$_o $LIBS";
451	}	539	}
…		…
459	}	547	}
460		548
461	sub entersub {	549	sub entersub {
462	my ($cv) = @_;	550	my ($cv) = @_;
463		551
		552	# always compile the whole stash
		553	# my @stash = $cv->STASH->ARRAY;
		554	# warn join ":", @stash;
		555	# exit;
		556
464	eval {	557	eval {
465	my $source = cv2c $cv;	558	my $source = cv2c $cv;
466		559
467	my $ptr = source2ptr $source;	560	my $ptr = source2ptr $source;
468		561
469	patch_cv $cv, $ptr;	562	patch_cv $cv, $ptr;
470	};	563	};
471		564
472	warn $@ if $@;	565	warn $@ if $@;
473	}	566	}
474		567
…		…
476		569
477	1;	570	1;
478		571
479	=back	572	=back
480		573
481	=head1 LIMITATIONS	574	=head1 BUGS/LIMITATIONS
482		575
483	Tainting and debugging will disable Faster.	576	Perl will check much less often for asynchronous signals in
		577	Faster-compiled code. It tries to check on every function call, loop
		578	iteration and every I/O operator, though.
		579
		580	The following things will disable Faster. If you manage to enable them at
		581	runtime, bad things will happen.
		582
		583	enabled tainting
		584	enabled debugging
		585
		586	This will dramatically reduce Faster's performance:
		587
		588	threads (but you don't care about speed if you use threads anyway)
		589
		590	These constructs will force the use of the interpreter as soon as they are
		591	being executed, for the rest of the currently executed:
		592
		593	.., ... (flipflop operators)
		594	goto
		595	next, redo (but not well-behaved last's)
		596	eval
		597	require
		598	any use of formats
484		599
485	=head1 AUTHOR	600	=head1 AUTHOR
486		601
487	Marc Lehmann <schmorp@schmorp.de>	602	Marc Lehmann <schmorp@schmorp.de>
488	http://home.schmorp.de/	603	http://home.schmorp.de/

Diff Legend

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

Comparing Faster/Faster.pm (file contents): Revision 1.8 by root, Fri Mar 10 01:51:14 2006 UTC vs. Revision 1.12 by root, Fri Mar 10 18:39:26 2006 UTC

Diff Legend

Comparing Faster/Faster.pm (file contents):
Revision 1.8 by root, Fri Mar 10 01:51:14 2006 UTC vs.
Revision 1.12 by root, Fri Mar 10 18:39:26 2006 UTC