[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.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	printf ("todo: PL_subgeneration or somesuch\\n");
332	if (SvROK (obj) && SvOBJECT (SvRV (obj)))	359	if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
333	{	360	{
334	dSP;	361	dSP;
335	HV *stash = SvSTASH (SvRV (obj));	362	HV *stash = SvSTASH (SvRV (obj));
336		363
337	/* simple "polymorphic" inline cache */	364	/* simple "polymorphic" inline cache */
338	if (stash == last_stash)	365	if (stash == last_stash
		366	&& PL_sub_generation == last_sub_generation)
339	{	367	{
340	XPUSHs (last_res);	368	XPUSHs (last_cv);
341	PUTBACK;	369	PUTBACK;
342	}	370	}
343	else	371	else
344	{	372	{
345	PL_op = nextop;
346	nextop = Perl_pp_method_named (aTHX);	373	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
347		374
348	SPAGAIN;	375	SPAGAIN;
		376	last_sub_generation = PL_sub_generation;
349	last_stash = stash;	377	last_stash = stash;
350	last_res = TOPs;	378	last_cv = TOPs;
351	}	379	}
352	}	380	}
353	else	381	else
354	{	382	{
355	/* error case usually */	383	/* error case usually */
356	PL_op = nextop;
357	nextop = Perl_pp_method_named (aTHX);	384	PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
358	}	385	}
359	}	386	}
360	EOF	387	EOF
361		388
362	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;
363	}	428	}
364		429
365	sub cv2c {	430	sub cv2c {
366	my ($cv) = @_;	431	my ($cv) = @_;
		432
		433	@loop = ();
367		434
368	my %opsseen;	435	my %opsseen;
369	my @todo = $cv->START;	436	my @todo = $cv->START;
370		437
371	while (my $op = shift @todo) {	438	while (my $op = shift @todo) {
372	for (; $$op; $op = $op->next) {	439	for (; $$op; $op = $op->next) {
373	last if $opsseen{$$op}++;	440	last if $opsseen{$$op}++;
374	push @ops, $op;	441	push @ops, $op;
		442
375	my $name = $op->name;	443	my $name = $op->name;
		444	my $class = B::class $op;
		445
376	if (B::class($op) eq "LOGOP") {	446	if ($class eq "LOGOP") {
377	push @todo, $op->other;	447	unshift @todo, $op->other; # unshift vs. push saves jumps
378	} elsif ($name eq "subst" and ${ $op->pmreplstart }) {	448	} elsif ($class eq "PMOP") {
379	push @todo, $op->pmreplstart;	449	unshift @todo, $op->pmreplstart if ${$op->pmreplstart};
380	} elsif ($name =~ /^enter(loop\|iter)$/) {	450	} elsif ($class eq "LOOP") {
381	# if ($] > 5.009) {	451	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	}	452	}
391	}	453	}
392	}	454	}
393		455
394	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;
395	#define PERL_NO_GET_CONTEXT	523	#define PERL_NO_GET_CONTEXT
396		524
397	//#define NDEBUG 1
398	#include <assert.h>	525	#include <assert.h>
399		526
400	#include "EXTERN.h"	527	#include "EXTERN.h"
401	#include "perl.h"	528	#include "perl.h"
402	#include "XSUB.h"	529	#include "XSUB.h"
403		530
404	OP *%%%FUNC%%% (pTHX)	531	#define RUNOPS_TILL(op) \\
405	{	532	while (nextop != (op)) \\
406	register OP nextop = (OP )${$ops[0]}L;	533	{ \\
407	EOF	534	PERL_ASYNC_CHECK (); \\
408		535	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	}	536	}
436		537
437	$source .= "}\n";	538	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;	539	print FILE $source;
454	close FILE;	540	close FILE;
455	system "$COMPILE -o $stem$_o $stem.c";	541	system "$COMPILE -o $stem$_o $stem.c";
456	system "$LINK -o $stem$_so $stem$_o $LIBS";	542	system "$LINK -o $stem$_so $stem$_o $LIBS";
457	}	543	}
…		…
465	}	551	}
466		552
467	sub entersub {	553	sub entersub {
468	my ($cv) = @_;	554	my ($cv) = @_;
469		555
		556	# always compile the whole stash
		557	# my @stash = $cv->STASH->ARRAY;
		558	# warn join ":", @stash;
		559	# exit;
		560
470	eval {	561	eval {
471	my $source = cv2c $cv;	562	my $source = cv2c $cv;
472		563
473	my $ptr = source2ptr $source;	564	my $ptr = source2ptr $source;
474		565
475	patch_cv $cv, $ptr;	566	patch_cv $cv, $ptr;
476	};	567	};
477		568
478	warn $@ if $@;	569	warn $@ if $@;
479	}	570	}
480		571
…		…
482		573
483	1;	574	1;
484		575
485	=back	576	=back
486		577
487	=head1 LIMITATIONS	578	=head1 BUGS/LIMITATIONS
488		579
489	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
490		603
491	=head1 AUTHOR	604	=head1 AUTHOR
492		605
493	Marc Lehmann <schmorp@schmorp.de>	606	Marc Lehmann <schmorp@schmorp.de>
494	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.10 by root, Fri Mar 10 02:03:50 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.10 by root, Fri Mar 10 02:03:50 2006 UTC vs.
Revision 1.13 by root, Fri Mar 10 18:53:49 2006 UTC