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

Comparing Faster/Faster.pm (file contents):
Revision 1.9 by root, Fri Mar 10 01:55:12 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)"
142	: $op_name eq "mapstart"
143	? "Perl_pp_grepstart (aTHX)"
144	: "Perl_pp_$op_name (aTHX)"
145	}	150	}
146		151
		152	sub assert {
		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
147	sub out_gotonext {	162	sub out_jump_next {
148	if (${$op->next}) {	163	assert "nextop == (OP *)${$op->next}";
149	$source .= " assert ((\"$op_name\", nextop == (OP *)${$op->next}));\n";
150	$source .= " goto op_${$op->next};\n";	164	$source .= " goto op_${$op->next};\n";
151	} else {
152	$source .= " return 0;\n";
153	}
154	}	165	}
155		166
156	sub out_next {	167	sub out_next {
157	$source .= " nextop = (OP *)${$op->next}L;\n";	168	$source .= " nextop = (OP *)${$op->next}L;\n";
158		169
159	out_gotonext;	170	out_jump_next;
160	}	171	}
161		172
162	sub out_linear {	173	sub out_linear {
163	$source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";#d#	174	out_callop;
164	$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";	175	out_jump_next;
165	if ($op_name eq "entersub") {
166	$source .= <<EOF;
167	while (nextop != (OP *)${$op->next}L)
168	{
169	PERL_ASYNC_CHECK ();
170	PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX);
171	}
172	EOF
173	}
174
175	out_gotonext;
176	}	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;
177		189
178	sub op_nextstate {	190	sub op_nextstate {
179	$source .= " PL_curcop = (COP *)nextop;\n";	191	$source .= " PL_curcop = (COP *)nextop;\n";
180	$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";
181	$source .= " FREETMPS;\n";	193	$source .= " FREETMPS;\n";
…		…
187	$source .= " PUSHMARK (PL_stack_sp);\n";	199	$source .= " PUSHMARK (PL_stack_sp);\n";
188		200
189	out_next;	201	out_next;
190	}	202	}
191		203
192	if ($Config{useithreads} ne "define") {	204	if (0 && $Config{useithreads} ne "define") {
193	# disable optimisations on ithreads	205	# disable optimisations on ithreads
194		206
195	*op_const = sub {	207	*op_const = sub {
196	$source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";	208	$source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
197		209
…		…
246		258
247	out_next;	259	out_next;
248	};	260	};
249	}	261	}
250		262
		263	# does kill Crossfire/res2pm
251	sub op_stringify {	264	sub op_stringify {
252	$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
253		276
254	out_next;	277	out_next;
255	}	278	}
256		279
257	sub op_and {	280	sub op_and {
…		…
322	# pattern const method_named	345	# pattern const method_named
323	sub op_method_named {	346	sub op_method_named {
324	$source .= <<EOF;	347	$source .= <<EOF;
325	{	348	{
326	static HV *last_stash;	349	static HV *last_stash;
327	static SV *last_res;	350	static SV *last_cv;
		351	static U32 last_sub_generation;
328		352
329	SV obj = (PL_stack_base + TOPMARK + 1);	353	SV obj = (PL_stack_base + TOPMARK + 1);
330		354
331	if (SvROK (obj) && SvOBJECT (SvRV (obj)))	355	if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
332	{	356	{
333	dSP;	357	dSP;
334	HV *stash = SvSTASH (SvRV (obj));	358	HV *stash = SvSTASH (SvRV (obj));
335		359
336	/* simple "polymorphic" inline cache */	360	/* simple "polymorphic" inline cache */
337	if (stash == last_stash)	361	if (stash == last_stash
		362	&& PL_sub_generation == last_sub_generation)
338	{	363	{
339	XPUSHs (last_res);	364	XPUSHs (last_cv);
340	PUTBACK;	365	PUTBACK;
341	}	366	}
342	else	367	else
343	{	368	{
344	PL_op = nextop;
345	nextop = Perl_pp_method_named (aTHX);	369	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
346		370
347	SPAGAIN;	371	SPAGAIN;
		372	last_sub_generation = PL_sub_generation;
348	last_stash = stash;	373	last_stash = stash;
349	last_res = TOPs;	374	last_cv = TOPs;
350	}	375	}
351	}	376	}
352	else	377	else
353	{	378	{
354	/* error case usually */	379	/* error case usually */
355	PL_op = nextop;
356	nextop = Perl_pp_method_named (aTHX);	380	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
357	}	381	}
358	}	382	}
359	EOF	383	EOF
360		384
361	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;
362	}	424	}
363		425
364	sub cv2c {	426	sub cv2c {
365	my ($cv) = @_;	427	my ($cv) = @_;
		428
		429	@loop = ();
366		430
367	my %opsseen;	431	my %opsseen;
368	my @todo = $cv->START;	432	my @todo = $cv->START;
369		433
370	while (my $op = shift @todo) {	434	while (my $op = shift @todo) {
371	for (; $$op; $op = $op->next) {	435	for (; $$op; $op = $op->next) {
372	last if $opsseen{$$op}++;	436	last if $opsseen{$$op}++;
373	push @ops, $op;	437	push @ops, $op;
		438
374	my $name = $op->name;	439	my $name = $op->name;
		440	my $class = B::class $op;
		441
375	if (B::class($op) eq "LOGOP") {	442	if ($class eq "LOGOP") {
376	push @todo, $op->other;	443	unshift @todo, $op->other; # unshift vs. push saves jumps
377	} elsif ($name eq "subst" and ${ $op->pmreplstart }) {	444	} elsif ($class eq "PMOP") {
378	push @todo, $op->pmreplstart;	445	unshift @todo, $op->pmreplstart if ${$op->pmreplstart};
379	} elsif ($name =~ /^enter(loop\|iter)$/) {	446	} elsif ($class eq "LOOP") {
380	# if ($] > 5.009) {	447	push @loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
381	# $labels{${$op->nextop}} = "NEXT";
382	# $labels{${$op->lastop}} = "LAST";
383	# $labels{${$op->redoop}} = "REDO";
384	# } else {
385	# $labels{$op->nextop->seq} = "NEXT";
386	# $labels{$op->lastop->seq} = "LAST";
387	# $labels{$op->redoop->seq} = "REDO";
388	# }
389	}	448	}
390	}	449	}
391	}	450	}
392		451
393	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;
394	#define PERL_NO_GET_CONTEXT	519	#define PERL_NO_GET_CONTEXT
395		520
396	//#define NDEBUG 1
397	#include <assert.h>	521	#include <assert.h>
398		522
399	#include "EXTERN.h"	523	#include "EXTERN.h"
400	#include "perl.h"	524	#include "perl.h"
401	#include "XSUB.h"	525	#include "XSUB.h"
402		526
403	OP *%%%FUNC%%% (pTHX)	527	#define RUNOPS_TILL(op) \\
404	{	528	while (nextop != (op)) \\
405	register OP nextop = (OP )${$ops[0]}L;	529	{ \\
406	EOF	530	PERL_ASYNC_CHECK (); \\
407		531	PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
408	while (@ops) {
409	$op = shift @ops;
410	$op_name = $op->name;
411
412	$source .= "op_$$op: /* $op_name */\n";
413	#$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
414	#$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
415
416	unless (exists $flag{noasync}{$op_name}) {
417	$source .= " PERL_ASYNC_CHECK ();\n";
418	}
419
420	if (my $can = __PACKAGE__->can ("op_$op_name")) {
421	$can->($op);
422	} elsif (exists $flag{unsafe}{$op_name}) {
423	$source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";
424	$source .= " return nextop;\n";
425	} elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$op_name}) {
426	$source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";
427	$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
428	$source .= " if (nextop == (OP *)${$op->other}L) goto op_${$op->other};\n";
429	$source .= " assert ((\"$op_name\", nextop == (OP *)${$op->next}));\n";
430	$source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";
431	} else {
432	out_linear;
433	}
434	}	532	}
435		533
436	$source .= "}\n";	534	EOF
437	#warn $source;
438
439	$source
440	}
441
442	sub source2ptr {
443	my ($source) = @_;
444
445	my $md5 = Digest::MD5::md5_hex $source;
446	$source =~ s/%%%FUNC%%%/Faster_$md5/;
447
448	my $stem = "/tmp/$md5";
449
450	unless (-e "$stem$_so") {
451	open FILE, ">:raw", "$stem.c";
452	print FILE $source;	535	print FILE $source;
453	close FILE;	536	close FILE;
454	system "$COMPILE -o $stem$_o $stem.c";	537	system "$COMPILE -o $stem$_o $stem.c";
455	system "$LINK -o $stem$_so $stem$_o $LIBS";	538	system "$LINK -o $stem$_so $stem$_o $LIBS";
456	}	539	}
…		…
464	}	547	}
465		548
466	sub entersub {	549	sub entersub {
467	my ($cv) = @_;	550	my ($cv) = @_;
468		551
		552	# always compile the whole stash
		553	# my @stash = $cv->STASH->ARRAY;
		554	# warn join ":", @stash;
		555	# exit;
		556
469	eval {	557	eval {
470	my $source = cv2c $cv;	558	my $source = cv2c $cv;
471		559
472	my $ptr = source2ptr $source;	560	my $ptr = source2ptr $source;
473		561
474	patch_cv $cv, $ptr;	562	patch_cv $cv, $ptr;
475	};	563	};
476		564
477	warn $@ if $@;	565	warn $@ if $@;
478	}	566	}
479		567
…		…
481		569
482	1;	570	1;
483		571
484	=back	572	=back
485		573
486	=head1 LIMITATIONS	574	=head1 BUGS/LIMITATIONS
487		575
488	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
489		599
490	=head1 AUTHOR	600	=head1 AUTHOR
491		601
492	Marc Lehmann <schmorp@schmorp.de>	602	Marc Lehmann <schmorp@schmorp.de>
493	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.9 by root, Fri Mar 10 01:55:12 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.9 by root, Fri Mar 10 01:55:12 2006 UTC vs.
Revision 1.12 by root, Fri Mar 10 18:39:26 2006 UTC