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.10 by root, Fri Mar 10 02:03:50 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;
40
41my @ops;
42my $op;
43my $op_name;
32 44
33my %flag; 45my %flag;
34 46
35for (split /\n/, <<EOF) { 47for (split /\n/, <<EOF) {
36 leavesub unsafe 48 leavesub unsafe
… …
45 leaveeval unsafe 57 leaveeval unsafe
46 entertry unsafe 58 entertry unsafe
47 substconst unsafe 59 substconst unsafe
48 formline unsafe 60 formline unsafe
49 grepstart unsafe 61 grepstart unsafe
62 require unsafe
63 match unsafe noasync todo
64 subst unsafe noasync todo
65 entereval unsafe noasync todo
66 mapstart unsafe noasync todo
67
68 mapwhile noasync
69 grepwhile noasync
70
71 seq noasync
72 pushmark noasync
73 padsv noasync extend=1
74 padav noasync extend=1
75 padhv noasync extend=1
76 padany noasync extend=1
77 entersub noasync
78 aassign noasync
79 sassign noasync
80 rv2av noasync
81 rv2cv noasync
82 rv2gv noasync
83 rv2hv noasync
84 refgen noasync
85 nextstate noasync
86 gv noasync
87 gvsv noasync
88 add noasync
89 subtract noasync
90 multiply noasync
91 divide noasync
92 complement noasync
93 cond_expr noasync
94 and noasync
95 or noasync
96 not noasync
97 defined noasync
98 method_named noasync
99 preinc noasync
100 postinc noasync
101 predec noasync
102 postdec noasync
103 stub noasync
104 unstack noasync
105 leaveloop noasync
106 aelem noasync
107 aelemfast noasync
108 helem noasync
109 pushre noasync
110 const noasync extend=1
111 list noasync
112 join noasync
113 split noasync
114 concat noasync
115 push noasync
116 pop noasync
117 shift noasync
118 unshift noasync
119 require noasync
120 length noasync
121 substr noasync
122 stringify noasync
123 eq noasync
124 ne noasync
125 gt noasync
126 lt noasync
127 ge noasync
128 le noasync
129 enteriter noasync
130
131 iter async
50EOF 132EOF
51 my (undef, $op, @flags) = split /\s+/; 133 my (undef, $op, @flags) = split /\s+/;
52 134
53 undef $flag{$_}{$op} 135 undef $flag{$_}{$op}
54 for ("known", @flags); 136 for ("known", @flags);
55} 137}
56 138
139sub callop {
140 $op_name eq "entersub"
141 ? "(PL_ppaddr [OP_ENTERSUB]) (aTHX)"
142 : $op_name eq "mapstart"
143 ? "Perl_pp_grepstart (aTHX)"
144 : "Perl_pp_$op_name (aTHX)"
145}
146
147sub out_gotonext {
148 if (${$op->next}) {
149 $source .= " assert ((\"$op_name\", nextop == (OP *)${$op->next}));\n";
150 $source .= " goto op_${$op->next};\n";
151 } else {
152 $source .= " return 0;\n";
153 }
154}
155
57sub out_next { 156sub out_next {
58 my ($op) = @_;
59
60 my $ppaddr = ppaddr $op->type;
61
62 $source .= " PL_op = (OP *)${$op->next}L;\n"; 157 $source .= " nextop = (OP *)${$op->next}L;\n";
63 $source .= " goto op_${$op->next};\n"; 158
159 out_gotonext;
160}
161
162sub out_linear {
163 $source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";#d#
164 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
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 }
172EOF
173 }
174
175 out_gotonext;
64} 176}
65 177
66sub op_nextstate { 178sub op_nextstate {
67 my ($op) = @_;
68
69 $source .= " PL_curcop = (COP *)PL_op;\n"; 179 $source .= " PL_curcop = (COP *)nextop;\n";
70 $source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n"; 180 $source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
71 $source .= " FREETMPS;\n"; 181 $source .= " FREETMPS;\n";
72 182
73 out_next $op; 183 out_next;
74} 184}
75 185
76sub op_const { 186sub op_pushmark {
77 my ($op) = @_; 187 $source .= " PUSHMARK (PL_stack_sp);\n";
78 188
189 out_next;
190}
191
192if ($Config{useithreads} ne "define") {
193 # disable optimisations on ithreads
194
195 *op_const = sub {
79 $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n"; 196 $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
80 197
81 out_next $op; 198 out_next;
82} 199 };
83 200
84*op_gv = \&op_const; 201 *op_gv = \&op_const;
85 202
86sub entersub { 203 *op_aelemfast = sub {
204 my $targ = $op->targ;
205 my $private = $op->private;
206
207 $source .= " {\n";
208
209 if ($op->flags & B::OPf_SPECIAL) {
210 $source .= " AV *av = (AV*)PAD_SV((PADOFFSET)$targ);\n";
211 } else {
212 $source .= " AV *av = GvAV ((GV *)${$op->sv}L);\n";
213 }
214
215 if ($op->flags & B::OPf_MOD) {
216 $source .= " SV *sv = *av_fetch (av, $private, 1);\n";
217 } else {
218 $source .= " SV **svp = av_fetch (av, $private, 0); SV *sv = svp ? *svp : &PL_sv_undef;\n";
219 }
220
221 if (!($op->flags & B::OPf_MOD)) {
222 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
223 }
224
225 $source .= " dSP;\n";
226 $source .= " XPUSHs (sv);\n";
227 $source .= " PUTBACK;\n";
228 $source .= " }\n";
229
230 out_next;
231 };
232
233 *op_gvsv = sub {
234 $source .= " {\n";
235 $source .= " dSP;\n";
236 $source .= " EXTEND (SP, 1);\n";
237
238 if ($op->private & B::OPpLVAL_INTRO) {
239 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
240 } else {
241 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
242 }
243
244 $source .= " PUTBACK;\n";
245 $source .= " }\n";
246
247 out_next;
248 };
249}
250
251sub op_stringify {
252 $source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n";
253
254 out_next;
255}
256
257sub op_and {
258 $source .= <<EOF;
259 {
260 dSP;
261
262 if (SvTRUE (TOPs))
263 {
264 --SP;
265 PUTBACK;
266 nextop = (OP *)${$op->other}L;
267 goto op_${$op->other};
268 }
269 }
270EOF
271
272 out_next;
273}
274
275sub op_or {
276 $source .= <<EOF;
277 {
278 dSP;
279
280 if (!SvTRUE (TOPs))
281 {
282 --SP;
283 PUTBACK;
284 nextop = (OP *)${$op->other}L;
285 goto op_${$op->other};
286 }
287 }
288EOF
289
290 out_next;
291}
292
293sub op_padsv {
294 my $flags = $op->flags;
295 my $target = $op->targ;
296
297 $source .= <<EOF;
298 {
299 dSP;
300 XPUSHs (PAD_SV ((PADOFFSET)$target));
301 PUTBACK;
302EOF
303 if ($op->flags & B::OPf_MOD) {
304 if ($op->private & B::OPpLVAL_INTRO) {
305 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n";
306 } elsif ($op->private & B::OPpDEREF) {
307 my $deref = $op->private & B::OPpDEREF;
308 $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
309 }
310 }
311 $source .= <<EOF;
312 }
313EOF
314
315 out_next;
316}
317
318# pattern const+ (or general push1)
319# pattern pushmark return(?)
320# pattern pushmark gv rv2av pushmark padsv+o.รค. aassign
321
322# pattern const method_named
323sub op_method_named {
324 $source .= <<EOF;
325 {
326 static HV *last_stash;
327 static SV *last_res;
328
329 SV *obj = *(PL_stack_base + TOPMARK + 1);
330
331 printf ("todo: PL_subgeneration or somesuch\\n");
332 if (SvROK (obj) && SvOBJECT (SvRV (obj)))
333 {
334 dSP;
335 HV *stash = SvSTASH (SvRV (obj));
336
337 /* simple "polymorphic" inline cache */
338 if (stash == last_stash)
339 {
340 XPUSHs (last_res);
341 PUTBACK;
342 }
343 else
344 {
345 PL_op = nextop;
346 nextop = Perl_pp_method_named (aTHX);
347
348 SPAGAIN;
349 last_stash = stash;
350 last_res = TOPs;
351 }
352 }
353 else
354 {
355 /* error case usually */
356 PL_op = nextop;
357 nextop = Perl_pp_method_named (aTHX);
358 }
359 }
360EOF
361
362 out_next;
363}
364
365sub cv2c {
87 my ($cv) = @_; 366 my ($cv) = @_;
88 367
89 my %opsseen; 368 my %opsseen;
90 my @ops;
91 my @todo = $cv->START; 369 my @todo = $cv->START;
92 370
93 while (my $op = shift @todo) { 371 while (my $op = shift @todo) {
94 for (; $$op; $op = $op->next) { 372 for (; $$op; $op = $op->next) {
95 last if $opsseen{$$op}++; 373 last if $opsseen{$$op}++;
… …
111# } 389# }
112 } 390 }
113 } 391 }
114 } 392 }
115 393
116 local $source; 394 local $source = <<EOF;
395#define PERL_NO_GET_CONTEXT
117 396
118 $source = "typedef OP *(*PPFUNC)(pTHX);\n\n"; 397//#define NDEBUG 1
119 398#include <assert.h>
120 $source .= "OP *func (pTHX)\n{\n";
121 399
122 for my $op (@ops) {
123 my $name = $op->name;
124 my $ppaddr = ppaddr $op->type;
125
126 $source .= "op_$$op: /* $name */\n";
127
128 if (my $can = __PACKAGE__->can ("op_$name")) {
129 $can->($op);
130 } elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) {
131 $source .= " PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n";
132 $source .= " if (PL_op == (OP *)${$op->other}L) goto op_${$op->other};\n";
133 $source .= " goto op_${$op->next};\n";
134 } elsif (exists $flag{unsafe}{$name}) {
135 $source .= " return ((PPFUNC)${ppaddr}L)(aTHX);\n";
136 } else {
137 $source .= " PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n";
138 $source .= " goto op_${$op->next};\n";
139 }
140 }
141
142 $source .= "}\n";
143
144 print <<EOF;
145#include "EXTERN.h" 400#include "EXTERN.h"
146#include "perl.h" 401#include "perl.h"
147#include "XSUB.h" 402#include "XSUB.h"
403
404OP *%%%FUNC%%% (pTHX)
405{
406 register OP *nextop = (OP *)${$ops[0]}L;
148EOF 407EOF
408
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 }
436
437 $source .= "}\n";
149 print $source; 438 #warn $source;
439
440 $source
441}
442
443sub 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;
454 close FILE;
455 system "$COMPILE -o $stem$_o $stem.c";
456 system "$LINK -o $stem$_so $stem$_o $LIBS";
457 }
458
459# warn $source;
460 my $so = DynaLoader::dl_load_file "$stem$_so"
461 or die "$stem$_so: $!";
462
463 DynaLoader::dl_find_symbol $so, "Faster_$md5"
464 or die "Faster_$md5: $!"
465}
466
467sub entersub {
468 my ($cv) = @_;
469
470 eval {
471 my $source = cv2c $cv;
472
473 my $ptr = source2ptr $source;
474
475 patch_cv $cv, $ptr;
476 };
477
478 warn $@ if $@;
150} 479}
151 480
152hook_entersub; 481hook_entersub;
153 482
1541; 4831;

Diff Legend

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