ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Faster/Faster.pm
(Generate patch)

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

… …
13=cut 13=cut
14 14
15package Faster; 15package Faster;
16 16
17use strict; 17use strict;
18use Config;
19use B ();
20use Digest::MD5 ();
21use DynaLoader ();
18 22
19BEGIN { 23BEGIN {
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
26use B (); 30my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}";
31my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
32my $LIBS = "$Config{libs}";
33my $_o = $Config{_o};
34my $_so = ".so";
27 35
28our $source; 36our $source;
29our $label_next; 37our $label_next;
30our $label_last; 38our $label_last;
31our $label_redo; 39our $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
50EOF 93EOF
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
57sub out_next { 100sub 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
111sub 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
66sub op_nextstate { 123sub 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
133sub op_pushmark {
134 my ($op) = @_;
135
136 $source .= " PUSHMARK (PL_stack_sp);\n";
137
138 out_next $op;
139}
140
76sub op_const { 141sub 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
86sub entersub { 151sub op_stringify {
152 my ($op) = @_;
153
154 $source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n";
155
156 out_next $op;
157}
158
159sub 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 }
174EOF
175
176 out_next $op;
177}
178
179sub op_or {
180 my ($op) = @_;
181
182 $source .= <<EOF;
183 {
184 dSP;
185
186 if (!SvTRUE (TOPs))
187 {
188 --SP;
189 PUTBACK;
190 nextop = (OP *)${$op->other}L;
191 goto op_${$op->other};
192 }
193 }
194EOF
195
196 out_next $op;
197}
198
199sub op_padsv {
200 my ($op) = @_;
201
202 my $flags = $op->flags;
203 my $target = $op->targ;
204
205 $source .= <<EOF;
206 {
207 dSP;
208 XPUSHs (PAD_SV ((PADOFFSET)$target));
209 PUTBACK;
210EOF
211 if ($op->flags & B::OPf_MOD) {
212 if ($op->private & B::OPpLVAL_INTRO) {
213 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n";
214 } elsif ($op->private & B::OPpDEREF) {
215 my $deref = $op->private & B::OPpDEREF;
216 $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
217 }
218 }
219 $source .= <<EOF;
220 }
221EOF
222
223 out_next $op;
224}
225
226sub op_aelemfast {
227 my ($op) = @_;
228
229 my $targ = $op->targ;
230 my $private = $op->private;
231
232 $source .= " {\n";
233
234 if ($op->flags & B::OPf_SPECIAL) {
235 $source .= " AV *av = (AV*)PAD_SV((PADOFFSET)$targ);\n";
236 } else {
237 $source .= " AV *av = GvAV ((GV *)${$op->sv}L);\n";
238 }
239
240 if ($op->flags & B::OPf_MOD) {
241 $source .= " SV *sv = *av_fetch (av, $private, 1);\n";
242 } else {
243 $source .= " SV **svp = av_fetch (av, $private, 0); SV *sv = svp ? *svp : &PL_sv_undef;\n";
244 }
245
246 if (!($op->flags & B::OPf_MOD)) {
247 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
248 }
249
250 $source .= " dSP;\n";
251 $source .= " XPUSHs (sv);\n";
252 $source .= " PUTBACK;\n";
253 $source .= " }\n";
254
255 out_next $op;
256}
257
258# pattern const+ (or general push1)
259# pattern pushmark return(?)
260# pattern pushmark gv rv2av pushmark padsv+o.รค. aassign
261
262# pattern const method_named
263sub op_method_named {
264 my ($op) = @_;
265
266 $source .= <<EOF;
267 {
268 static HV *last_stash;
269 static SV *last_res;
270
271 SV *obj = *(PL_stack_base + TOPMARK + 1);
272
273 if (SvROK (obj) && SvOBJECT (SvRV (obj)))
274 {
275 dSP;
276 HV *stash = SvSTASH (SvRV (obj));
277
278 /* simple "polymorphic" inline cache */
279 if (stash == last_stash)
280 {
281 XPUSHs (last_res);
282 PUTBACK;
283 }
284 else
285 {
286 PL_op = nextop;
287 nextop = Perl_pp_method_named (aTHX);
288
289 SPAGAIN;
290 last_stash = stash;
291 last_res = TOPs;
292 }
293 }
294 else
295 {
296 /* error case usually */
297 PL_op = nextop;
298 nextop = Perl_pp_method_named (aTHX);
299 }
300 }
301EOF
302
303 out_next $op;
304}
305
306sub cv2c {
87 my ($cv) = @_; 307 my ($cv) = @_;
88 308
89 my %opsseen; 309 my %opsseen;
90 my @ops; 310 my @ops;
91 my @todo = $cv->START; 311 my @todo = $cv->START;
… …
111# } 331# }
112 } 332 }
113 } 333 }
114 } 334 }
115 335
116 local $source; 336 local $source = <<EOF;
337#define PERL_NO_GET_CONTEXT
117 338
118 $source = "typedef OP *(*PPFUNC)(pTHX);\n\n"; 339#include <assert.h>
340
341#include "EXTERN.h"
342#include "perl.h"
343#include "XSUB.h"
344
345/*typedef OP *(*PPFUNC)(pTHX);*/
119 346
120 $source .= "OP *func (pTHX)\n{\n"; 347OP *%%%FUNC%%% (pTHX)
348{
349 register OP *nextop = (OP *)${$ops[0]}L;
350EOF
121 351
122 for my $op (@ops) { 352 for my $op (@ops) {
123 my $name = $op->name; 353 my $name = $op->name;
124 my $ppaddr = ppaddr $op->type; 354 my $ppaddr = ppaddr $op->type;
125 355
126 $source .= "op_$$op: /* $name */\n"; 356 $source .= "op_$$op: /* $name */\n";
357 #$source .= "fprintf (stderr, \"$$op in op $name\\n\");\n";#d#
358 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
359
360 unless (exists $flag{noasync}{$name}) {
361 $source .= " PERL_ASYNC_CHECK ();\n";
362 }
127 363
128 if (my $can = __PACKAGE__->can ("op_$name")) { 364 if (my $can = __PACKAGE__->can ("op_$name")) {
129 $can->($op); 365 $can->($op);
366 } elsif (exists $flag{unsafe}{$name}) {
367 $source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
368 $source .= " PL_op = nextop; return " . (callop $op) . ";\n";
130 } elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) { 369 } elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) {
131 $source .= " PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n"; 370 $source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
371 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
132 $source .= " if (PL_op == (OP *)${$op->other}L) goto op_${$op->other};\n"; 372 $source .= " if (nextop == (OP *)${$op->other}L) goto op_${$op->other};\n";
133 $source .= " goto op_${$op->next};\n"; 373 $source .= " assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#
134 } elsif (exists $flag{unsafe}{$name}) { 374 $source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";
135 $source .= " return ((PPFUNC)${ppaddr}L)(aTHX);\n";
136 } else { 375 } else {
137 $source .= " PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n"; 376 $source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
138 $source .= " goto op_${$op->next};\n"; 377 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
378 if ($name eq "entersub") {
379 $source .= <<EOF;
380while (nextop != (OP *)${$op->next})
381 {
382 PERL_ASYNC_CHECK ();
383 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX);
384 }
385EOF
386 }
387 $source .= " assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#
388 $source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";
139 } 389 }
140 } 390 }
141 391
142 $source .= "}\n"; 392 $source .= "}\n";
143
144 print <<EOF;
145#include "EXTERN.h"
146#include "perl.h"
147#include "XSUB.h"
148EOF
149 print $source; 393 #warn $source;
394
395 $source
396}
397
398sub source2ptr {
399 my ($source) = @_;
400
401 my $md5 = Digest::MD5::md5_hex $source;
402 $source =~ s/%%%FUNC%%%/Faster_$md5/;
403
404 my $stem = "/tmp/$md5";
405
406 unless (-e "$stem$_so") {
407 open FILE, ">:raw", "$stem.c";
408 print FILE $source;
409 close FILE;
410 system "$COMPILE -o $stem$_o $stem.c";
411 system "$LINK -o $stem$_so $stem$_o $LIBS";
412 }
413
414# warn $source;
415 my $so = DynaLoader::dl_load_file "$stem$_so"
416 or die "$stem$_so: $!";
417
418 DynaLoader::dl_find_symbol $so, "Faster_$md5"
419 or die "Faster_$md5: $!"
420}
421
422sub entersub {
423 my ($cv) = @_;
424
425 eval {
426 my $source = cv2c $cv;
427
428 my $ptr = source2ptr $source;
429
430 patch_cv $cv, $ptr;
431 };
432
433 warn $@ if $@;
150} 434}
151 435
152hook_entersub; 436hook_entersub;
153 437
1541; 4381;

Diff Legend

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