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

Comparing Faster/Faster.pm (file contents):
Revision 1.2 by root, Thu Mar 9 06:03:12 2006 UTC vs.
Revision 1.6 by root, Fri Mar 10 00:11:44 2006 UTC

…		…
13	=cut	13	=cut
14		14
15	package Faster;	15	package Faster;
16		16
17	use strict;	17	use strict;
		18	use Config;
		19	use B ();
		20	use Digest::MD5 ();
		21	use DynaLoader ();
18		22
19	BEGIN {	23	BEGIN {
20	our $VERSION = '0.01';	24	our $VERSION = '0.01';
21		25
22	require XSLoader;	26	require XSLoader;
23	XSLoader::load __PACKAGE__, $VERSION;	27	XSLoader::load __PACKAGE__, $VERSION;
24	}	28	}
25		29
26	use B ();	30	my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}";
		31	my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
		32	my $LIBS = "$Config{libs}";
		33	my $_o = $Config{_o};
		34	my $_so = ".so";
27		35
28	our $source;	36	our $source;
29	our $label_next;	37	our $label_next;
30	our $label_last;	38	our $label_last;
31	our $label_redo;	39	our $label_redo;
…		…
45	leaveeval unsafe	53	leaveeval unsafe
46	entertry unsafe	54	entertry unsafe
47	substconst unsafe	55	substconst unsafe
48	formline unsafe	56	formline unsafe
49	grepstart unsafe	57	grepstart unsafe
		58	require unsafe
		59	match unsafe todo
		60	subst unsafe todo
		61	entereval unsafe todo
		62	mapstart unsafe todo
		63
		64	pushmark noasync
		65	padsv noasync
		66	entersub noasync
		67	aassign noasync
		68	sassign noasync
		69	rv2av noasync
		70	nextstate noasync
		71	gv noasync
		72	gvsv noasync
		73	add noasync
		74	subtract noasync
		75	multiply noasync
		76	divide noasync
		77	complement noasync
		78	cond_expr noasync
		79	and noasync
		80	or noasync
		81	not noasync
		82	method_named noasync
		83	preinc noasync
		84	postinc noasync
		85	predec noasync
		86	postdec noasync
		87	stub noasync
		88	unstack noasync
		89	leaveloop noasync
		90	shift noasync
		91	aelemA noasync
		92	aelemfast noasync
50	EOF	93	EOF
51	my (undef, $op, @flags) = split /\s+/;	94	my (undef, $op, @flags) = split /\s+/;
52		95
53	undef $flag{$_}{$op}	96	undef $flag{$_}{$op}
54	for ("known", @flags);	97	for ("known", @flags);
55	}	98	}
56		99
57	sub out_next {	100	sub out_next {
58	my ($op) = @_;	101	my ($op) = @_;
59		102
60	my $ppaddr = ppaddr $op->type;	103	if (${$op->next}) {
61
62	$source .= " PL_op = (OP *)${$op->next}L;\n";	104	$source .= " nextop = (OP *)${$op->next}L;\n";
63	$source .= " goto op_${$op->next};\n";	105	$source .= " goto op_${$op->next};\n";
		106	} else {
		107	$source .= " return 0;\n";
		108	}
		109	}
		110
		111	sub callop {
		112	my ($op) = @_;
		113
		114	my $name = $op->name;
		115
		116	$name eq "entersub"
		117	? "(PL_ppaddr [OP_ENTERSUB]) (aTHX)"
		118	: $name eq "mapstart"
		119	? "Perl_pp_grepstart (aTHX)"
		120	: "Perl_pp_$name (aTHX)"
64	}	121	}
65		122
66	sub op_nextstate {	123	sub op_nextstate {
67	my ($op) = @_;	124	my ($op) = @_;
68		125
69	$source .= " PL_curcop = (COP *)PL_op;\n";	126	$source .= " PL_curcop = (COP *)nextop;\n";
70	$source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";	127	$source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
71	$source .= " FREETMPS;\n";	128	$source .= " FREETMPS;\n";
72		129
73	out_next $op;	130	out_next $op;
74	}	131	}
75		132
		133	sub op_pushmark {
		134	my ($op) = @_;
		135
		136	$source .= " PUSHMARK (PL_stack_sp);\n";
		137
		138	out_next $op;
		139	}
		140
76	sub op_const {	141	sub op_const {
77	my ($op) = @_;	142	my ($op) = @_;
78		143
79	$source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";	144	$source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
80		145
81	out_next $op;	146	out_next $op;
82	}	147	}
83		148
84	*op_gv = \&op_const;	149	*op_gv = \&op_const;
85		150
86	sub entersub {	151	sub op_stringify {
		152	my ($op) = @_;
		153
		154	$source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n";
		155
		156	out_next $op;
		157	}
		158
		159	sub op_and {
		160	my ($op) = @_;
		161
		162	$source .= <<EOF;
		163	{
		164	dSP;
		165
		166	if (SvTRUE (TOPs))
		167	{
		168	--SP;
		169	PUTBACK;
		170	nextop = (OP *)${$op->other}L;
		171	goto op_${$op->other};
		172	}
		173	}
		174	EOF
		175
		176	out_next $op;
		177	}
		178
		179	sub op_padsv {
		180	my ($op) = @_;
		181
		182	my $flags = $op->flags;
		183	my $target = $op->targ;
		184
		185	$source .= <<EOF;
		186	{
		187	dSP;
		188	XPUSHs (PAD_SV ((PADOFFSET)$target));
		189	PUTBACK;
		190	EOF
		191	if ($op->flags & B::OPf_MOD) {
		192	if ($op->private & B::OPpLVAL_INTRO) {
		193	$source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n";
		194	} elsif ($op->private & B::OPpDEREF) {
		195	my $deref = $op->private & B::OPpDEREF;
		196	$source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
		197	}
		198	}
		199	$source .= <<EOF;
		200	}
		201	EOF
		202
		203	out_next $op;
		204	}
		205
		206	sub op_aelemfast {
		207	my ($op) = @_;
		208
		209	my $targ = $op->targ;
		210	my $private = $op->private;
		211
		212	$source .= " {\n";
		213
		214	if ($op->flags & B::OPf_SPECIAL) {
		215	$source .= " AV av = (AV)PAD_SV((PADOFFSET)$targ);\n";
		216	} else {
		217	$source .= " AV av = GvAV ((GV )${$op->sv}L);\n";
		218	}
		219
		220	if ($op->flags & B::OPf_MOD) {
		221	$source .= " SV sv = av_fetch (av, $private, 1);\n";
		222	} else {
		223	$source .= " SV *svp = av_fetch (av, $private, 0); SV sv = svp ? *svp : &PL_sv_undef;\n";
		224	}
		225
		226	if (!($op->flags & B::OPf_MOD)) {
		227	$source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
		228	}
		229
		230	$source .= " dSP;\n";
		231	$source .= " XPUSHs (sv);\n";
		232	$source .= " PUTBACK;\n";
		233	$source .= " }\n";
		234
		235	out_next $op;
		236	}
		237
		238	# pattern const+ (or general push1)
		239	# pattern pushmark return(?)
		240	# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
		241
		242	# pattern const method_named
		243	sub op_method_named {
		244	my ($op) = @_;
		245
		246	$source .= <<EOF;
		247	{
		248	static HV *last_stash;
		249	static SV *last_res;
		250
		251	SV obj = (PL_stack_base + TOPMARK + 1);
		252
		253	if (SvROK (obj) && SvOBJECT (SvRV (obj)))
		254	{
		255	dSP;
		256	HV *stash = SvSTASH (SvRV (obj));
		257
		258	/* simple "polymorphic" inline cache */
		259	if (stash == last_stash)
		260	{
		261	XPUSHs (last_res);
		262	PUTBACK;
		263	}
		264	else
		265	{
		266	PL_op = nextop;
		267	nextop = Perl_pp_method_named (aTHX);
		268
		269	SPAGAIN;
		270	last_stash = stash;
		271	last_res = TOPs;
		272	}
		273	}
		274	else
		275	{
		276	/* error case usually */
		277	PL_op = nextop;
		278	nextop = Perl_pp_method_named (aTHX);
		279	}
		280	}
		281	EOF
		282
		283	out_next $op;
		284	}
		285
		286	sub cv2c {
87	my ($cv) = @_;	287	my ($cv) = @_;
88		288
89	my %opsseen;	289	my %opsseen;
90	my @ops;	290	my @ops;
91	my @todo = $cv->START;	291	my @todo = $cv->START;
…		…
111	# }	311	# }
112	}	312	}
113	}	313	}
114	}	314	}
115		315
116	local $source;	316	local $source = <<EOF;
		317	#define PERL_NO_GET_CONTEXT
117		318
118	$source = "typedef OP (PPFUNC)(pTHX);\n\n";	319	#include <assert.h>
		320
		321	#include "EXTERN.h"
		322	#include "perl.h"
		323	#include "XSUB.h"
		324
		325	/typedef OP (PPFUNC)(pTHX);/
119		326
120	$source .= "OP *func (pTHX)\n{\n";	327	OP *%%%FUNC%%% (pTHX)
		328	{
		329	register OP nextop = (OP )${$ops[0]}L;
		330	EOF
121		331
122	for my $op (@ops) {	332	for my $op (@ops) {
123	my $name = $op->name;	333	my $name = $op->name;
124	my $ppaddr = ppaddr $op->type;	334	my $ppaddr = ppaddr $op->type;
125		335
126	$source .= "op_$$op: /* $name */\n";	336	$source .= "op_$$op: /* $name */\n";
		337	#$source .= "fprintf (stderr, \"$$op in op $name\\n\");\n";#d#
		338	#$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
		339
		340	unless (exists $flag{noasync}{$name}) {
		341	$source .= " PERL_ASYNC_CHECK ();\n";
		342	}
127		343
128	if (my $can = __PACKAGE__->can ("op_$name")) {	344	if (my $can = __PACKAGE__->can ("op_$name")) {
129	$can->($op);	345	$can->($op);
		346	} elsif (exists $flag{unsafe}{$name}) {
		347	$source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
		348	$source .= " PL_op = nextop; return " . (callop $op) . ";\n";
130	} elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) {	349	} elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) {
131	$source .= " PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n";	350	$source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
		351	$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
132	$source .= " if (PL_op == (OP *)${$op->other}L) goto op_${$op->other};\n";	352	$source .= " if (nextop == (OP *)${$op->other}L) goto op_${$op->other};\n";
133	$source .= " goto op_${$op->next};\n";	353	$source .= " assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#
134	} elsif (exists $flag{unsafe}{$name}) {	354	$source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";
135	$source .= " return ((PPFUNC)${ppaddr}L)(aTHX);\n";
136	} else {	355	} else {
137	$source .= " PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n";	356	$source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
138	$source .= " goto op_${$op->next};\n";	357	$source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
		358	if ($name eq "entersub") {
		359	$source .= <<EOF;
		360	while (nextop != (OP *)${$op->next})
		361	{
		362	PERL_ASYNC_CHECK ();
		363	PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX);
		364	}
		365	EOF
		366	}
		367	$source .= " assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#
		368	$source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";
139	}	369	}
140	}	370	}
141		371
142	$source .= "}\n";	372	$source .= "}\n";
143
144	print <<EOF;
145	#include "EXTERN.h"
146	#include "perl.h"
147	#include "XSUB.h"
148	EOF
149	print $source;	373	#warn $source;
		374
		375	$source
		376	}
		377
		378	sub source2ptr {
		379	my ($source) = @_;
		380
		381	my $md5 = Digest::MD5::md5_hex $source;
		382	$source =~ s/%%%FUNC%%%/Faster_$md5/;
		383
		384	my $stem = "/tmp/$md5";
		385
		386	unless (-e "$stem$_so") {
		387	open FILE, ">:raw", "$stem.c";
		388	print FILE $source;
		389	close FILE;
		390	system "$COMPILE -o $stem$_o $stem.c";
		391	system "$LINK -o $stem$_so $stem$_o $LIBS";
		392	}
		393
		394	# warn $source;
		395	my $so = DynaLoader::dl_load_file "$stem$_so"
		396	or die "$stem$_so: $!";
		397
		398	DynaLoader::dl_find_symbol $so, "Faster_$md5"
		399	or die "Faster_$md5: $!"
		400	}
		401
		402	sub entersub {
		403	my ($cv) = @_;
		404
		405	eval {
		406	my $source = cv2c $cv;
		407
		408	my $ptr = source2ptr $source;
		409
		410	patch_cv $cv, $ptr;
		411	};
		412
		413	warn $@ if $@;
150	}	414	}
151		415
152	hook_entersub;	416	hook_entersub;
153		417
154	1;	418	1;

Diff Legend

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

Comparing Faster/Faster.pm (file contents): Revision 1.2 by root, Thu Mar 9 06:03:12 2006 UTC vs. Revision 1.6 by root, Fri Mar 10 00:11:44 2006 UTC

Diff Legend

Comparing Faster/Faster.pm (file contents):
Revision 1.2 by root, Thu Mar 9 06:03:12 2006 UTC vs.
Revision 1.6 by root, Fri Mar 10 00:11:44 2006 UTC