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.13 by root, Fri Mar 10 18:53:49 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";
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
40my $opt_assert = 1;
27 41
28our $source; 42our $source;
29our $label_next; 43
30our $label_last; 44my @ops;
31our $label_redo; 45my $op;
46my $op_name;
47my @loop;
32 48
33my %flag; 49my %flag;
34 50
51# complex flag steting is no longer required, rewrite this ugly code
35for (split /\n/, <<EOF) { 52for (split /\n/, <<EOF) {
36 leavesub unsafe 53 leavesub unsafe
37 leavesublv unsafe 54 leavesublv unsafe
38 return unsafe 55 return unsafe
39 flip unsafe 56 flip unsafe
… …
42 redo unsafe 59 redo unsafe
43 next unsafe 60 next unsafe
44 eval unsafe 61 eval unsafe
45 leaveeval unsafe 62 leaveeval unsafe
46 entertry unsafe 63 entertry unsafe
47 substconst unsafe
48 formline unsafe 64 formline unsafe
49 grepstart unsafe 65 grepstart unsafe
66 mapstart unsafe
67 substcont unsafe
68 entereval unsafe noasync todo
69 require unsafe
70
71 mapstart noasync
72 grepstart noasync
73 match noasync
74
75 last noasync
76 next noasync
77 redo noasync
78 seq noasync
79 pushmark noasync extend=0
80 padsv noasync extend=1
81 padav noasync extend=1
82 padhv noasync extend=1
83 padany noasync extend=1
84 entersub noasync
85 aassign noasync
86 sassign noasync
87 rv2av noasync
88 rv2cv noasync
89 rv2gv noasync
90 rv2hv noasync
91 refgen noasync
92 nextstate noasync
93 gv noasync
94 gvsv noasync
95 add noasync
96 subtract noasync
97 multiply noasync
98 divide noasync
99 complement noasync
100 cond_expr noasync
101 and noasync
102 or noasync
103 not noasync
104 defined noasync
105 method_named noasync
106 preinc noasync
107 postinc noasync
108 predec noasync
109 postdec noasync
110 stub noasync
111 unstack noasync
112 leaveloop noasync
113 aelem noasync
114 aelemfast noasync
115 helem noasync
116 pushre noasync
117 subst noasync
118 const noasync extend=1
119 list noasync
120 join noasync
121 split noasync
122 concat noasync
123 push noasync
124 pop noasync
125 shift noasync
126 unshift noasync
127 length noasync
128 substr noasync
129 stringify noasync
130 eq noasync
131 ne noasync
132 gt noasync
133 lt noasync
134 ge noasync
135 le noasync
136 enteriter noasync
137 ord noasync
138
139 iter async
50EOF 140EOF
51 my (undef, $op, @flags) = split /\s+/; 141 my (undef, $op, @flags) = split /\s+/;
52 142
53 undef $flag{$_}{$op} 143 undef $flag{$_}{$op}
54 for ("known", @flags); 144 for ("known", @flags);
55} 145}
56 146
147my %callop = (
148 entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)",
149 mapstart => "Perl_pp_grepstart (aTHX)",
150);
151
152sub callop {
153 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
154}
155
156sub assert {
157 return unless $opt_assert;
158 $source .= " assert ((\"$op_name\", ($_[0])));\n";
159}
160
161sub out_callop {
162 assert "nextop == (OP *)$$op";
163 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
164}
165
166sub out_jump_next {
167 assert "nextop == (OP *)${$op->next}";
168 $source .= " goto op_${$op->next};\n";
169}
170
57sub out_next { 171sub out_next {
58 my ($op) = @_;
59
60 my $ppaddr = ppaddr $op->type;
61
62 $source .= " PL_op = (OP *)${$op->next}L;\n"; 172 $source .= " nextop = (OP *)${$op->next}L;\n";
63 $source .= " goto op_${$op->next};\n"; 173
174 out_jump_next;
64} 175}
176
177sub out_linear {
178 out_callop;
179 out_jump_next;
180}
181
182sub out_cond_jump {
183 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
184}
185
186sub 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;
65 193
66sub op_nextstate { 194sub op_nextstate {
67 my ($op) = @_;
68
69 $source .= " PL_curcop = (COP *)PL_op;\n"; 195 $source .= " PL_curcop = (COP *)nextop;\n";
70 $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";
71 $source .= " FREETMPS;\n"; 197 $source .= " FREETMPS;\n";
72 198
73 out_next $op; 199 out_next;
74} 200}
75 201
76sub op_const { 202sub op_pushmark {
77 my ($op) = @_; 203 $source .= " PUSHMARK (PL_stack_sp);\n";
78 204
205 out_next;
206}
207
208if ($Config{useithreads} ne "define") {
209 # disable optimisations on ithreads
210
211 *op_const = sub {
79 $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n"; 212 $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
80 213
81 out_next $op; 214 out_next;
82} 215 };
83 216
84*op_gv = \&op_const; 217 *op_gv = \&op_const;
85 218
86sub entersub { 219 *op_aelemfast = sub {
220 my $targ = $op->targ;
221 my $private = $op->private;
222
223 $source .= " {\n";
224
225 if ($op->flags & B::OPf_SPECIAL) {
226 $source .= " AV *av = (AV*)PAD_SV((PADOFFSET)$targ);\n";
227 } else {
228 $source .= " AV *av = GvAV ((GV *)${$op->sv}L);\n";
229 }
230
231 if ($op->flags & B::OPf_MOD) {
232 $source .= " SV *sv = *av_fetch (av, $private, 1);\n";
233 } else {
234 $source .= " SV **svp = av_fetch (av, $private, 0); SV *sv = svp ? *svp : &PL_sv_undef;\n";
235 }
236
237 if (!($op->flags & B::OPf_MOD)) {
238 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
239 }
240
241 $source .= " dSP;\n";
242 $source .= " XPUSHs (sv);\n";
243 $source .= " PUTBACK;\n";
244 $source .= " }\n";
245
246 out_next;
247 };
248
249 *op_gvsv = sub {
250 $source .= " {\n";
251 $source .= " dSP;\n";
252 $source .= " EXTEND (SP, 1);\n";
253
254 if ($op->private & B::OPpLVAL_INTRO) {
255 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
256 } else {
257 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
258 }
259
260 $source .= " PUTBACK;\n";
261 $source .= " }\n";
262
263 out_next;
264 };
265}
266
267# does kill Crossfire/res2pm
268sub op_stringify {
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 }
279EOF
280
281 out_next;
282}
283
284sub op_and {
285 $source .= <<EOF;
286 {
287 dSP;
288
289 if (SvTRUE (TOPs))
290 {
291 --SP;
292 PUTBACK;
293 nextop = (OP *)${$op->other}L;
294 goto op_${$op->other};
295 }
296 }
297EOF
298
299 out_next;
300}
301
302sub op_or {
303 $source .= <<EOF;
304 {
305 dSP;
306
307 if (!SvTRUE (TOPs))
308 {
309 --SP;
310 PUTBACK;
311 nextop = (OP *)${$op->other}L;
312 goto op_${$op->other};
313 }
314 }
315EOF
316
317 out_next;
318}
319
320sub op_padsv {
321 my $flags = $op->flags;
322 my $target = $op->targ;
323
324 $source .= <<EOF;
325 {
326 dSP;
327 XPUSHs (PAD_SV ((PADOFFSET)$target));
328 PUTBACK;
329EOF
330 if ($op->flags & B::OPf_MOD) {
331 if ($op->private & B::OPpLVAL_INTRO) {
332 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n";
333 } elsif ($op->private & B::OPpDEREF) {
334 my $deref = $op->private & B::OPpDEREF;
335 $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
336 }
337 }
338 $source .= <<EOF;
339 }
340EOF
341
342 out_next;
343}
344
345# pattern const+ (or general push1)
346# pattern pushmark return(?)
347# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
348
349# pattern const method_named
350sub op_method_named {
351 $source .= <<EOF;
352 {
353 static HV *last_stash;
354 static SV *last_cv;
355 static U32 last_sub_generation;
356
357 SV *obj = *(PL_stack_base + TOPMARK + 1);
358
359 if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
360 {
361 dSP;
362 HV *stash = SvSTASH (SvRV (obj));
363
364 /* simple "polymorphic" inline cache */
365 if (stash == last_stash
366 && PL_sub_generation == last_sub_generation)
367 {
368 XPUSHs (last_cv);
369 PUTBACK;
370 }
371 else
372 {
373 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
374
375 SPAGAIN;
376 last_sub_generation = PL_sub_generation;
377 last_stash = stash;
378 last_cv = TOPs;
379 }
380 }
381 else
382 {
383 /* error case usually */
384 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
385 }
386 }
387EOF
388
389 out_next;
390}
391
392sub op_grepstart {
393 out_callop;
394 out_cond_jump $op->next->other;
395 out_jump_next;
396}
397
398*op_mapstart = \&op_grepstart;
399
400sub 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
407sub 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
418sub xop_next {
419 out_break_op 0;
420}
421
422sub op_last {
423 out_break_op 1;
424}
425
426sub xop_redo {
427 out_break_op 2;
428}
429
430sub cv2c {
87 my ($cv) = @_; 431 my ($cv) = @_;
88 432
433 @loop = ();
434
89 my %opsseen; 435 my %opsseen;
90 my @ops;
91 my @todo = $cv->START; 436 my @todo = $cv->START;
92 437
93 while (my $op = shift @todo) { 438 while (my $op = shift @todo) {
94 for (; $$op; $op = $op->next) { 439 for (; $$op; $op = $op->next) {
95 last if $opsseen{$$op}++; 440 last if $opsseen{$$op}++;
96 push @ops, $op; 441 push @ops, $op;
442
97 my $name = $op->name; 443 my $name = $op->name;
444 my $class = B::class $op;
445
98 if (B::class($op) eq "LOGOP") { 446 if ($class eq "LOGOP") {
99 push @todo, $op->other; 447 unshift @todo, $op->other; # unshift vs. push saves jumps
100 } elsif ($name eq "subst" and ${ $op->pmreplstart }) { 448 } elsif ($class eq "PMOP") {
101 push @todo, $op->pmreplstart; 449 unshift @todo, $op->pmreplstart if ${$op->pmreplstart};
102 } elsif ($name =~ /^enter(loop|iter)$/) { 450 } elsif ($class eq "LOOP") {
103# if ($] > 5.009) { 451 push @loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
104# $labels{${$op->nextop}} = "NEXT";
105# $labels{${$op->lastop}} = "LAST";
106# $labels{${$op->redoop}} = "REDO";
107# } else {
108# $labels{$op->nextop->seq} = "NEXT";
109# $labels{$op->lastop->seq} = "LAST";
110# $labels{$op->redoop->seq} = "REDO";
111# }
112 } 452 }
113 } 453 }
114 } 454 }
115 455
116 local $source; 456 local $source = <<EOF;
457OP *%%%FUNC%%% (pTHX)
458{
459 register OP *nextop = (OP *)${$ops[0]}L;
460EOF
117 461
118 $source = "typedef OP *(*PPFUNC)(pTHX);\n\n"; 462 while (@ops) {
119 463 $op = shift @ops;
120 $source .= "OP *func (pTHX)\n{\n";
121
122 for my $op (@ops) {
123 my $name = $op->name; 464 $op_name = $op->name;
124 my $ppaddr = ppaddr $op->type;
125 465
126 $source .= "op_$$op: /* $name */\n"; 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#
127 469
470 $source .= " PERL_ASYNC_CHECK ();\n"
471 unless exists $flag{noasync}{$op_name};
472
128 if (my $can = __PACKAGE__->can ("op_$name")) { 473 if (my $can = __PACKAGE__->can ("op_$op_name")) {
474 # handcrafted replacement
129 $can->($op); 475 $can->($op);
130 } elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) { 476
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}) { 477 } elsif (exists $flag{unsafe}{$op_name}) {
135 $source .= " return ((PPFUNC)${ppaddr}L)(aTHX);\n"; 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
136 } else { 494 } else {
137 $source .= " PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n"; 495 # normal operator, linear execution
138 $source .= " goto op_${$op->next};\n"; 496 out_linear;
139 } 497 }
140 } 498 }
141 499
500 $op_name = "func exit"; assert (0);
501
142 $source .= "}\n"; 502 $source .= <<EOF;
503op_0:
504 return 0;
505}
506EOF
507 #warn $source;
143 508
509 $source
510}
511
512sub 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";
144 print <<EOF; 522 print FILE <<EOF;
523#define PERL_NO_GET_CONTEXT
524
525#include <assert.h>
526
145#include "EXTERN.h" 527#include "EXTERN.h"
146#include "perl.h" 528#include "perl.h"
147#include "XSUB.h" 529#include "XSUB.h"
530
531#define RUNOPS_TILL(op) \\
532 while (nextop != (op)) \\
533 { \\
534 PERL_ASYNC_CHECK (); \\
535 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
536 }
537
148EOF 538EOF
149 print $source; 539 print FILE $source;
540 close FILE;
541 system "$COMPILE -o $stem$_o $stem.c";
542 system "$LINK -o $stem$_so $stem$_o $LIBS";
543 }
544
545# warn $source;
546 my $so = DynaLoader::dl_load_file "$stem$_so"
547 or die "$stem$_so: $!";
548
549 DynaLoader::dl_find_symbol $so, "Faster_$md5"
550 or die "Faster_$md5: $!"
551}
552
553sub entersub {
554 my ($cv) = @_;
555
556 # always compile the whole stash
557# my @stash = $cv->STASH->ARRAY;
558# warn join ":", @stash;
559# exit;
560
561 eval {
562 my $source = cv2c $cv;
563
564 my $ptr = source2ptr $source;
565
566 patch_cv $cv, $ptr;
567 };
568
569 warn $@ if $@;
150} 570}
151 571
152hook_entersub; 572hook_entersub;
153 573
1541; 5741;
155 575
156=back 576=back
157 577
158=head1 LIMITATIONS 578=head1 BUGS/LIMITATIONS
159 579
160Tainting and debugging will disable Faster. 580Perl will check much less often for asynchronous signals in
581Faster-compiled code. It tries to check on every function call, loop
582iteration and every I/O operator, though.
583
584The following things will disable Faster. If you manage to enable them at
585runtime, bad things will happen.
586
587 enabled tainting
588 enabled debugging
589
590This will dramatically reduce Faster's performance:
591
592 threads (but you don't care about speed if you use threads anyway)
593
594These constructs will force the use of the interpreter as soon as they are
595being 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
161 603
162=head1 AUTHOR 604=head1 AUTHOR
163 605
164 Marc Lehmann <schmorp@schmorp.de> 606 Marc Lehmann <schmorp@schmorp.de>
165 http://home.schmorp.de/ 607 http://home.schmorp.de/

Diff Legend

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