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

Comparing Faster/Faster.pm (file contents):
Revision 1.10 by root, Fri Mar 10 02:03:50 2006 UTC vs.
Revision 1.11 by root, Fri Mar 10 18:29:08 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	mapwhile noasync
69	grepwhile noasync	68	grepstart noasync
		69	match noasync todo#whyisitunsafe? unsafe
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
251	sub op_stringify {	263	sub xop_stringify {
252	$source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n";	264	$source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; PUTBACK; }\n";
253		265
254	out_next;	266	out_next;
255	}	267	}
256		268
257	sub op_and {	269	sub op_and {
…		…
318	# pattern const+ (or general push1)	330	# pattern const+ (or general push1)
319	# pattern pushmark return(?)	331	# pattern pushmark return(?)
320	# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign	332	# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
321		333
322	# pattern const method_named	334	# pattern const method_named
323	sub op_method_named {	335	sub xop_method_named {
324	$source .= <<EOF;	336	$source .= <<EOF;
325	{	337	{
326	static HV *last_stash;	338	static HV *last_stash;
327	static SV *last_res;	339	static SV *last_cv;
		340	static U32 last_sub_generation;
328		341
329	SV obj = (PL_stack_base + TOPMARK + 1);	342	SV obj = (PL_stack_base + TOPMARK + 1);
330		343
331	printf ("todo: PL_subgeneration or somesuch\\n");
332	if (SvROK (obj) && SvOBJECT (SvRV (obj)))	344	if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
333	{	345	{
334	dSP;	346	dSP;
335	HV *stash = SvSTASH (SvRV (obj));	347	HV *stash = SvSTASH (SvRV (obj));
336		348
337	/* simple "polymorphic" inline cache */	349	/* simple "polymorphic" inline cache */
338	if (stash == last_stash)	350	if (stash == last_stash
		351	&& PL_sub_generation == last_sub_generation)
339	{	352	{
340	XPUSHs (last_res);	353	XPUSHs (last_cv);
341	PUTBACK;	354	PUTBACK;
342	}	355	}
343	else	356	else
344	{	357	{
345	PL_op = nextop;
346	nextop = Perl_pp_method_named (aTHX);	358	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
347		359
348	SPAGAIN;	360	SPAGAIN;
		361	last_sub_generation = PL_sub_generation;
349	last_stash = stash;	362	last_stash = stash;
350	last_res = TOPs;	363	last_cv = TOPs;
351	}	364	}
352	}	365	}
353	else	366	else
354	{	367	{
355	/* error case usually */	368	/* error case usually */
356	PL_op = nextop;
357	nextop = Perl_pp_method_named (aTHX);	369	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
358	}	370	}
359	}	371	}
360	EOF	372	EOF
361		373
362	out_next;	374	out_next;
		375	}
		376
		377	sub op_grepstart {
		378	out_callop;
		379	out_cond_jump $op->next->other;
		380	out_jump_next;
		381	}
		382
		383	*op_mapstart = \&op_grepstart;
		384
		385	sub op_substcont {
		386	out_callop;
		387	out_cond_jump $op->other->pmreplstart;
		388	assert "nextop == (OP *)${$op->other->next}L";
		389	$source .= " goto op_${$op->other->next};\n";
		390	}
		391
		392	sub out_break_op {
		393	my ($idx) = @_;
		394
		395	out_callop;
		396
		397	out_cond_jump $_->[$idx]
		398	for reverse @loop;
		399
		400	$source .= " return nextop;\n";
		401	}
		402
		403	sub xop_next {
		404	out_break_op 0;
		405	}
		406
		407	sub op_last {
		408	out_break_op 1;
		409	}
		410
		411	sub xop_redo {
		412	out_break_op 2;
363	}	413	}
364		414
365	sub cv2c {	415	sub cv2c {
366	my ($cv) = @_;	416	my ($cv) = @_;
		417
		418	@loop = ();
367		419
368	my %opsseen;	420	my %opsseen;
369	my @todo = $cv->START;	421	my @todo = $cv->START;
370		422
371	while (my $op = shift @todo) {	423	while (my $op = shift @todo) {
372	for (; $$op; $op = $op->next) {	424	for (; $$op; $op = $op->next) {
373	last if $opsseen{$$op}++;	425	last if $opsseen{$$op}++;
374	push @ops, $op;	426	push @ops, $op;
		427
375	my $name = $op->name;	428	my $name = $op->name;
		429	my $class = B::class $op;
		430
376	if (B::class($op) eq "LOGOP") {	431	if ($class eq "LOGOP") {
377	push @todo, $op->other;	432	unshift @todo, $op->other; # unshift vs. push saves jumps
378	} elsif ($name eq "subst" and ${ $op->pmreplstart }) {	433	} elsif ($class eq "PMOP") {
379	push @todo, $op->pmreplstart;	434	unshift @todo, $op->pmreplstart if ${$op->pmreplstart};
380	} elsif ($name =~ /^enter(loop\|iter)$/) {	435	} elsif ($class eq "LOOP") {
381	# if ($] > 5.009) {	436	push @loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
382	# $labels{${$op->nextop}} = "NEXT";
383	# $labels{${$op->lastop}} = "LAST";
384	# $labels{${$op->redoop}} = "REDO";
385	# } else {
386	# $labels{$op->nextop->seq} = "NEXT";
387	# $labels{$op->lastop->seq} = "LAST";
388	# $labels{$op->redoop->seq} = "REDO";
389	# }
390	}	437	}
391	}	438	}
392	}	439	}
393		440
394	local $source = <<EOF;	441	local $source = <<EOF;
		442	OP *%%%FUNC%%% (pTHX)
		443	{
		444	register OP nextop = (OP )${$ops[0]}L;
		445	EOF
		446
		447	while (@ops) {
		448	$op = shift @ops;
		449	$op_name = $op->name;
		450
		451	$source .= "op_$$op: /* $op_name */\n";
		452	#$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
		453	#$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
		454
		455	$source .= " PERL_ASYNC_CHECK ();\n"
		456	unless exists $flag{noasync}{$op_name};
		457
		458	if (my $can = __PACKAGE__->can ("op_$op_name")) {
		459	# handcrafted replacement
		460	$can->($op);
		461
		462	} elsif (exists $flag{unsafe}{$op_name}) {
		463	# unsafe, return to interpreter
		464	assert "nextop == (OP *)$$op";
		465	$source .= " return nextop;\n";
		466
		467	} elsif ("LOGOP" eq B::class $op) {
		468	# logical operation with optionaö branch
		469	out_callop;
		470	out_cond_jump $op->other;
		471	out_jump_next;
		472
		473	} elsif ("PMOP" eq B::class $op) {
		474	# regex-thingy
		475	out_callop;
		476	out_cond_jump $op->pmreplroot if ${$op->pmreplroot};
		477	out_jump_next;
		478
		479	} else {
		480	# normal operator, linear execution
		481	out_linear;
		482	}
		483	}
		484
		485	$op_name = "func exit"; assert (0);
		486
		487	$source .= <<EOF;
		488	op_0:
		489	return 0;
		490	}
		491	EOF
		492	#warn $source;
		493
		494	$source
		495	}
		496
		497	sub source2ptr {
		498	my ($source) = @_;
		499
		500	my $md5 = Digest::MD5::md5_hex $source;
		501	$source =~ s/%%%FUNC%%%/Faster_$md5/;
		502
		503	my $stem = "/tmp/$md5";
		504
		505	unless (-e "$stem$_so") {
		506	open FILE, ">:raw", "$stem.c";
		507	print FILE <<EOF;
395	#define PERL_NO_GET_CONTEXT	508	#define PERL_NO_GET_CONTEXT
396		509
397	//#define NDEBUG 1
398	#include <assert.h>	510	#include <assert.h>
399		511
400	#include "EXTERN.h"	512	#include "EXTERN.h"
401	#include "perl.h"	513	#include "perl.h"
402	#include "XSUB.h"	514	#include "XSUB.h"
403		515
404	OP *%%%FUNC%%% (pTHX)	516	#define RUNOPS_TILL(op) \\
405	{	517	while (nextop != (op)) \\
406	register OP nextop = (OP )${$ops[0]}L;	518	{ \\
407	EOF	519	PERL_ASYNC_CHECK (); \\
408		520	PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
409	while (@ops) {
410	$op = shift @ops;
411	$op_name = $op->name;
412
413	$source .= "op_$$op: /* $op_name */\n";
414	#$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
415	#$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
416
417	unless (exists $flag{noasync}{$op_name}) {
418	$source .= " PERL_ASYNC_CHECK ();\n";
419	}
420
421	if (my $can = __PACKAGE__->can ("op_$op_name")) {
422	$can->($op);
423	} elsif (exists $flag{unsafe}{$op_name}) {
424	$source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";
425	$source .= " return nextop;\n";
426	} elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$op_name}) {
427	$source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";
428	$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
429	$source .= " if (nextop == (OP *)${$op->other}L) goto op_${$op->other};\n";
430	$source .= " assert ((\"$op_name\", nextop == (OP *)${$op->next}));\n";
431	$source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";
432	} else {
433	out_linear;
434	}
435	}	521	}
436		522
437	$source .= "}\n";	523	EOF
438	#warn $source;
439
440	$source
441	}
442
443	sub source2ptr {
444	my ($source) = @_;
445
446	my $md5 = Digest::MD5::md5_hex $source;
447	$source =~ s/%%%FUNC%%%/Faster_$md5/;
448
449	my $stem = "/tmp/$md5";
450
451	unless (-e "$stem$_so") {
452	open FILE, ">:raw", "$stem.c";
453	print FILE $source;	524	print FILE $source;
454	close FILE;	525	close FILE;
455	system "$COMPILE -o $stem$_o $stem.c";	526	system "$COMPILE -o $stem$_o $stem.c";
456	system "$LINK -o $stem$_so $stem$_o $LIBS";	527	system "$LINK -o $stem$_so $stem$_o $LIBS";
457	}	528	}
…		…
465	}	536	}
466		537
467	sub entersub {	538	sub entersub {
468	my ($cv) = @_;	539	my ($cv) = @_;
469		540
		541	# always compile the whole stash
		542	# my @stash = $cv->STASH->ARRAY;
		543	# warn join ":", @stash;
		544	# exit;
		545
470	eval {	546	eval {
471	my $source = cv2c $cv;	547	my $source = cv2c $cv;
472		548
473	my $ptr = source2ptr $source;	549	my $ptr = source2ptr $source;
474		550
475	patch_cv $cv, $ptr;	551	patch_cv $cv, $ptr;
476	};	552	};
477		553
478	warn $@ if $@;	554	warn $@ if $@;
479	}	555	}
480		556
…		…
482		558
483	1;	559	1;
484		560
485	=back	561	=back
486		562
487	=head1 LIMITATIONS	563	=head1 BUGS/LIMITATIONS
488		564
489	Tainting and debugging will disable Faster.	565	Perl will check much less often for asynchronous signals in
		566	Faster-compiled code. It tries to check on every function call, loop
		567	iteration and every I/O operator, though.
		568
		569	The following things will disable Faster. If you manage to enable them at
		570	runtime, bad things will happen.
		571
		572	enabled tainting
		573	enabled debugging
		574
		575	This will dramatically reduce Faster's performance:
		576
		577	threads (but you don't care about speed if you use threads anyway)
		578
		579	These constructs will force the use of the interpreter as soon as they are
		580	being executed, for the rest of the currently executed:
		581
		582	.., ... (flipflop operators)
		583	goto
		584	next, redo (but not well-behaved last's)
		585	eval
		586	require
		587	any use of formats
490		588
491	=head1 AUTHOR	589	=head1 AUTHOR
492		590
493	Marc Lehmann <schmorp@schmorp.de>	591	Marc Lehmann <schmorp@schmorp.de>
494	http://home.schmorp.de/	592	http://home.schmorp.de/

Diff Legend

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

Comparing Faster/Faster.pm (file contents): Revision 1.10 by root, Fri Mar 10 02:03:50 2006 UTC vs. Revision 1.11 by root, Fri Mar 10 18:29:08 2006 UTC

Diff Legend

Comparing Faster/Faster.pm (file contents):
Revision 1.10 by root, Fri Mar 10 02:03:50 2006 UTC vs.
Revision 1.11 by root, Fri Mar 10 18:29:08 2006 UTC