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

Comparing Faster/Faster.pm (file contents):
Revision 1.1 by root, Thu Mar 9 04:41:21 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;
32 40
33sub entersub { 41my @ops;
42my $op;
43my $op_name;
44
45my %flag;
46
47for (split /\n/, <<EOF) {
48 leavesub unsafe
49 leavesublv unsafe
50 return unsafe
51 flip unsafe
52 goto unsafe
53 last unsafe
54 redo unsafe
55 next unsafe
56 eval unsafe
57 leaveeval unsafe
58 entertry unsafe
59 substconst unsafe
60 formline 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
132EOF
133 my (undef, $op, @flags) = split /\s+/;
134
135 undef $flag{$_}{$op}
136 for ("known", @flags);
137}
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
156sub out_next {
157 $source .= " nextop = (OP *)${$op->next}L;\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;
176}
177
178sub op_nextstate {
179 $source .= " PL_curcop = (COP *)nextop;\n";
180 $source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
181 $source .= " FREETMPS;\n";
182
183 out_next;
184}
185
186sub op_pushmark {
187 $source .= " PUSHMARK (PL_stack_sp);\n";
188
189 out_next;
190}
191
192if ($Config{useithreads} ne "define") {
193 # disable optimisations on ithreads
194
195 *op_const = sub {
196 $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
197
198 out_next;
199 };
200
201 *op_gv = \&op_const;
202
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 {
34 my ($cv) = @_; 366 my ($cv) = @_;
35 367
36 my %opsseen; 368 my %opsseen;
37 my @ops;
38 my @todo = $cv->START; 369 my @todo = $cv->START;
39 370
40 while (my $op = shift @todo) { 371 while (my $op = shift @todo) {
41 for (; $$op; $op = $op->next) { 372 for (; $$op; $op = $op->next) {
42 last if $opsseen{$$op}++; 373 last if $opsseen{$$op}++;
… …
58# } 389# }
59 } 390 }
60 } 391 }
61 } 392 }
62 393
394 local $source = <<EOF;
395#define PERL_NO_GET_CONTEXT
396
397//#define NDEBUG 1
398#include <assert.h>
399
400#include "EXTERN.h"
401#include "perl.h"
402#include "XSUB.h"
403
404OP *%%%FUNC%%% (pTHX)
405{
406 register OP *nextop = (OP *)${$ops[0]}L;
407EOF
408
63 for (@ops) { 409 while (@ops) {
64 printf "%s\n", $_->name; 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";
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;
65 } 476 };
66# walklines(\@lines, 0); 477
478 warn $@ if $@;
67} 479}
68 480
69hook_entersub; 481hook_entersub;
70 482
711; 4831;
72 484
73=back 485=back
486
487=head1 LIMITATIONS
488
489Tainting and debugging will disable Faster.
74 490
75=head1 AUTHOR 491=head1 AUTHOR
76 492
77 Marc Lehmann <schmorp@schmorp.de> 493 Marc Lehmann <schmorp@schmorp.de>
78 http://home.schmorp.de/ 494 http://home.schmorp.de/

Diff Legend

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