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