[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.13 by root, Fri Mar 10 18:53:49 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	out_cond_jump $op->next->other;
		395	out_jump_next;
		396	}
		397
		398	*op_mapstart = \&op_grepstart;
		399
		400	sub op_substcont {
		401	out_callop;
		402	out_cond_jump $op->other->pmreplstart;
		403	assert "nextop == (OP *)${$op->other->next}L";
		404	$source .= " goto op_${$op->other->next};\n";
		405	}
		406
		407	sub out_break_op {
		408	my ($idx) = @_;
		409
		410	out_callop;
		411
		412	out_cond_jump $_->[$idx]
		413	for reverse @loop;
		414
		415	$source .= " return nextop;\n";
		416	}
		417
		418	sub xop_next {
		419	out_break_op 0;
		420	}
		421
		422	sub op_last {
		423	out_break_op 1;
		424	}
		425
		426	sub xop_redo {
		427	out_break_op 2;
362	}	428	}
363		429
364	sub cv2c {	430	sub cv2c {
365	my ($cv) = @_;	431	my ($cv) = @_;
		432
		433	@loop = ();
366		434
367	my %opsseen;	435	my %opsseen;
368	my @todo = $cv->START;	436	my @todo = $cv->START;
369		437
370	while (my $op = shift @todo) {	438	while (my $op = shift @todo) {
371	for (; $$op; $op = $op->next) {	439	for (; $$op; $op = $op->next) {
372	last if $opsseen{$$op}++;	440	last if $opsseen{$$op}++;
373	push @ops, $op;	441	push @ops, $op;
		442
374	my $name = $op->name;	443	my $name = $op->name;
		444	my $class = B::class $op;
		445
375	if (B::class($op) eq "LOGOP") {	446	if ($class eq "LOGOP") {
376	push @todo, $op->other;	447	unshift @todo, $op->other; # unshift vs. push saves jumps
377	} elsif ($name eq "subst" and ${ $op->pmreplstart }) {	448	} elsif ($class eq "PMOP") {
378	push @todo, $op->pmreplstart;	449	unshift @todo, $op->pmreplstart if ${$op->pmreplstart};
379	} elsif ($name =~ /^enter(loop\|iter)$/) {	450	} elsif ($class eq "LOOP") {
380	# if ($] > 5.009) {	451	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	}	452	}
390	}	453	}
391	}	454	}
392		455
393	local $source = <<EOF;	456	local $source = <<EOF;
		457	OP *%%%FUNC%%% (pTHX)
		458	{
		459	register OP nextop = (OP )${$ops[0]}L;
		460	EOF
		461
		462	while (@ops) {
		463	$op = shift @ops;
		464	$op_name = $op->name;
		465
		466	$source .= "op_$$op: /* $op_name */\n";
		467	#$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
		468	#$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
		469
		470	$source .= " PERL_ASYNC_CHECK ();\n"
		471	unless exists $flag{noasync}{$op_name};
		472
		473	if (my $can = __PACKAGE__->can ("op_$op_name")) {
		474	# handcrafted replacement
		475	$can->($op);
		476
		477	} elsif (exists $flag{unsafe}{$op_name}) {
		478	# unsafe, return to interpreter
		479	assert "nextop == (OP *)$$op";
		480	$source .= " return nextop;\n";
		481
		482	} elsif ("LOGOP" eq B::class $op) {
		483	# logical operation with optionaö branch
		484	out_callop;
		485	out_cond_jump $op->other;
		486	out_jump_next;
		487
		488	} elsif ("PMOP" eq B::class $op) {
		489	# regex-thingy
		490	out_callop;
		491	out_cond_jump $op->pmreplroot if ${$op->pmreplroot};
		492	out_jump_next;
		493
		494	} else {
		495	# normal operator, linear execution
		496	out_linear;
		497	}
		498	}
		499
		500	$op_name = "func exit"; assert (0);
		501
		502	$source .= <<EOF;
		503	op_0:
		504	return 0;
		505	}
		506	EOF
		507	#warn $source;
		508
		509	$source
		510	}
		511
		512	sub source2ptr {
		513	my ($source) = @_;
		514
		515	my $md5 = Digest::MD5::md5_hex $source;
		516	$source =~ s/%%%FUNC%%%/Faster_$md5/;
		517
		518	my $stem = "/tmp/$md5";
		519
		520	unless (-e "$stem$_so") {
		521	open FILE, ">:raw", "$stem.c";
		522	print FILE <<EOF;
394	#define PERL_NO_GET_CONTEXT	523	#define PERL_NO_GET_CONTEXT
395		524
396	//#define NDEBUG 1
397	#include <assert.h>	525	#include <assert.h>
398		526
399	#include "EXTERN.h"	527	#include "EXTERN.h"
400	#include "perl.h"	528	#include "perl.h"
401	#include "XSUB.h"	529	#include "XSUB.h"
402		530
403	OP *%%%FUNC%%% (pTHX)	531	#define RUNOPS_TILL(op) \\
404	{	532	while (nextop != (op)) \\
405	register OP nextop = (OP )${$ops[0]}L;	533	{ \\
406	EOF	534	PERL_ASYNC_CHECK (); \\
407		535	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	}	536	}
435		537
436	$source .= "}\n";	538	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;	539	print FILE $source;
453	close FILE;	540	close FILE;
454	system "$COMPILE -o $stem$_o $stem.c";	541	system "$COMPILE -o $stem$_o $stem.c";
455	system "$LINK -o $stem$_so $stem$_o $LIBS";	542	system "$LINK -o $stem$_so $stem$_o $LIBS";
456	}	543	}
…		…
464	}	551	}
465		552
466	sub entersub {	553	sub entersub {
467	my ($cv) = @_;	554	my ($cv) = @_;
468		555
		556	# always compile the whole stash
		557	# my @stash = $cv->STASH->ARRAY;
		558	# warn join ":", @stash;
		559	# exit;
		560
469	eval {	561	eval {
470	my $source = cv2c $cv;	562	my $source = cv2c $cv;
471		563
472	my $ptr = source2ptr $source;	564	my $ptr = source2ptr $source;
473		565
474	patch_cv $cv, $ptr;	566	patch_cv $cv, $ptr;
475	};	567	};
476		568
477	warn $@ if $@;	569	warn $@ if $@;
478	}	570	}
479		571
…		…
481		573
482	1;	574	1;
483		575
484	=back	576	=back
485		577
486	=head1 LIMITATIONS	578	=head1 BUGS/LIMITATIONS
487		579
488	Tainting and debugging will disable Faster.	580	Perl will check much less often for asynchronous signals in
		581	Faster-compiled code. It tries to check on every function call, loop
		582	iteration and every I/O operator, though.
		583
		584	The following things will disable Faster. If you manage to enable them at
		585	runtime, bad things will happen.
		586
		587	enabled tainting
		588	enabled debugging
		589
		590	This will dramatically reduce Faster's performance:
		591
		592	threads (but you don't care about speed if you use threads anyway)
		593
		594	These constructs will force the use of the interpreter as soon as they are
		595	being executed, for the rest of the currently executed:
		596
		597	.., ... (flipflop operators)
		598	goto
		599	next, redo (but not well-behaved last's)
		600	eval
		601	require
		602	any use of formats
489		603
490	=head1 AUTHOR	604	=head1 AUTHOR
491		605
492	Marc Lehmann <schmorp@schmorp.de>	606	Marc Lehmann <schmorp@schmorp.de>
493	http://home.schmorp.de/	607	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.13 by root, Fri Mar 10 18:53:49 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.13 by root, Fri Mar 10 18:53:49 2006 UTC