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

Comparing Faster/Faster.pm (file contents):
Revision 1.3 by root, Thu Mar 9 06:35:33 2006 UTC vs.
Revision 1.17 by root, Fri Mar 10 18:58:35 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 = 0;
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 $source .= " PL_op = (OP *)${$op->next}L;\n"; 172 $source .= " nextop = (OP *)${$op->next}L;\n";
61 $source .= " goto op_${$op->next};\n"; 173
174 out_jump_next;
62} 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;
63 193
64sub op_nextstate { 194sub op_nextstate {
65 my ($op) = @_;
66
67 $source .= " PL_curcop = (COP *)PL_op;\n"; 195 $source .= " PL_curcop = (COP *)nextop;\n";
68 $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";
69 $source .= " FREETMPS;\n"; 197 $source .= " FREETMPS;\n";
70 198
71 out_next $op; 199 out_next;
72} 200}
73 201
74sub op_pushmark { 202sub op_pushmark {
75 my ($op) = @_;
76
77 $source .= " PUSHMARK (PL_stack_sp);\n"; 203 $source .= " PUSHMARK (PL_stack_sp);\n";
78 204
79 out_next $op; 205 out_next;
80} 206}
81 207
82sub op_const { 208if ($Config{useithreads} ne "define") {
83 my ($op) = @_; 209 # disable optimisations on ithreads
84 210
211 *op_const = sub {
85 $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n"; 212 $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
86 213
87 out_next $op; 214 out_next;
88} 215 };
89 216
90*op_gv = \&op_const; 217 *op_gv = \&op_const;
91 218
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
92sub op_stringify { 268sub op_stringify {
93 my ($op) = @_; 269 my $targ = $op->targ;
94 270
95 $source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n"; 271 $source .= <<EOF;
272 {
273 dSP;
274 SV *targ = PAD_SV ((PADOFFSET)$targ);
275 sv_copypv (TARG, TOPs);
276 SETTARG;
277 PUTBACK;
278 }
279EOF
96 280
97 out_next $op; 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;
98} 343}
99 344
100# pattern const+ (or general push1) 345# pattern const+ (or general push1)
101# pattern pushmark return(?) 346# pattern pushmark return(?)
102# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 347# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
103 348
104# pattern const method_named 349# pattern const method_named
105sub xop_method_named { 350sub op_method_named {
106 my ($op) = @_;
107
108 my $ppaddr = ppaddr $op->type;
109
110 $source .= <<EOF; 351 $source .= <<EOF;
111 { 352 {
112 dSP; 353 static HV *last_stash;
354 static SV *last_cv;
355 static U32 last_sub_generation;
113 356
114 if (SvROK (TOPm1s) && SvOBJECT (SvRV (TOPm1s))) 357 SV *obj = *(PL_stack_base + TOPMARK + 1);
358
359 if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
115 { 360 {
116 static SV *last_stash, SV *last_res; 361 dSP;
117 SV *stash = SvSTASH (SvRV (TOPm1s)); 362 HV *stash = SvSTASH (SvRV (obj));
118 363
119 // simple polymorphic inline cache 364 /* simple "polymorphic" inline cache */
120 if (stash == last_stash) 365 if (stash == last_stash
366 && PL_sub_generation == last_sub_generation)
121 { 367 {
368 XPUSHs (last_cv);
122 dTARGET; 369 PUTBACK;
123 SETTARG (last_res);
124 } 370 }
125 else 371 else
126 { 372 {
127 PUTBACK; 373 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
128 ((PPFUNC)${ppaddr}L)(aTHX);\n"; 374
129 SPAGAIN; 375 SPAGAIN;
130 376 last_sub_generation = PL_sub_generation;
131 last_stash = stash; 377 last_stash = stash;
132 last_res = TOPs; 378 last_cv = TOPs;
133 } 379 }
134 } 380 }
381 else
382 {
383 /* error case usually */
384 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
385 }
135 } 386 }
136EOF 387EOF
137 388
138 out_next $op; 389 out_next;
139} 390}
140 391
141sub entersub { 392sub op_grepstart {
393 out_callop;
394 $op = $op->next;
395 out_cond_jump $op->other;
396 out_jump_next;
397}
398
399*op_mapstart = \&op_grepstart;
400
401sub op_substcont {
402 out_callop;
403 out_cond_jump $op->other->pmreplstart;
404 assert "nextop == (OP *)${$op->other->next}L";
405 $source .= " goto op_${$op->other->next};\n";
406}
407
408sub out_break_op {
409 my ($idx) = @_;
410
411 out_callop;
412
413 out_cond_jump $_->[$idx]
414 for reverse @loop;
415
416 $source .= " return nextop;\n";
417}
418
419sub xop_next {
420 out_break_op 0;
421}
422
423sub op_last {
424 out_break_op 1;
425}
426
427sub xop_redo {
428 out_break_op 2;
429}
430
431sub cv2c {
142 my ($cv) = @_; 432 my ($cv) = @_;
143 433
434 @loop = ();
435
144 my %opsseen; 436 my %opsseen;
145 my @ops;
146 my @todo = $cv->START; 437 my @todo = $cv->START;
147 438
148 while (my $op = shift @todo) { 439 while (my $op = shift @todo) {
149 for (; $$op; $op = $op->next) { 440 for (; $$op; $op = $op->next) {
150 last if $opsseen{$$op}++; 441 last if $opsseen{$$op}++;
151 push @ops, $op; 442 push @ops, $op;
443
152 my $name = $op->name; 444 my $name = $op->name;
445 my $class = B::class $op;
446
153 if (B::class($op) eq "LOGOP") { 447 if ($class eq "LOGOP") {
154 push @todo, $op->other; 448 unshift @todo, $op->other; # unshift vs. push saves jumps
155 } elsif ($name eq "subst" and ${ $op->pmreplstart }) { 449 } elsif ($class eq "PMOP") {
156 push @todo, $op->pmreplstart; 450 unshift @todo, $op->pmreplstart if ${$op->pmreplstart};
157 } elsif ($name =~ /^enter(loop|iter)$/) { 451 } elsif ($class eq "LOOP") {
158# if ($] > 5.009) { 452 push @loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
159# $labels{${$op->nextop}} = "NEXT";
160# $labels{${$op->lastop}} = "LAST";
161# $labels{${$op->redoop}} = "REDO";
162# } else {
163# $labels{$op->nextop->seq} = "NEXT";
164# $labels{$op->lastop->seq} = "LAST";
165# $labels{$op->redoop->seq} = "REDO";
166# }
167 } 453 }
168 } 454 }
169 } 455 }
170 456
171 local $source; 457 local $source = <<EOF;
458OP *%%%FUNC%%% (pTHX)
459{
460 register OP *nextop = (OP *)${$ops[0]}L;
461EOF
172 462
173 $source = "typedef OP *(*PPFUNC)(pTHX);\n\n"; 463 while (@ops) {
174 464 $op = shift @ops;
175 $source .= "OP *func (pTHX)\n{\n dTHX;\n";
176
177 for my $op (@ops) {
178 my $name = $op->name; 465 $op_name = $op->name;
179 my $ppaddr = ppaddr $op->type;
180 466
181 $source .= "op_$$op: /* $name */\n"; 467 $source .= "op_$$op: /* $op_name */\n";
468 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
469 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
182 470
471 $source .= " PERL_ASYNC_CHECK ();\n"
472 unless exists $flag{noasync}{$op_name};
473
183 if (my $can = __PACKAGE__->can ("op_$name")) { 474 if (my $can = __PACKAGE__->can ("op_$op_name")) {
475 # handcrafted replacement
184 $can->($op); 476 $can->($op);
185 } elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) { 477
186 $source .= " PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n";
187 $source .= " if (PL_op == (OP *)${$op->other}L) goto op_${$op->other};\n";
188 $source .= " goto op_${$op->next};\n";
189 } elsif (exists $flag{unsafe}{$name}) { 478 } elsif (exists $flag{unsafe}{$op_name}) {
190 $source .= " return ((PPFUNC)${ppaddr}L)(aTHX);\n"; 479 # unsafe, return to interpreter
480 assert "nextop == (OP *)$$op";
481 $source .= " return nextop;\n";
482
483 } elsif ("LOGOP" eq B::class $op) {
484 # logical operation with optionaö branch
485 out_callop;
486 out_cond_jump $op->other;
487 out_jump_next;
488
489 } elsif ("PMOP" eq B::class $op) {
490 # regex-thingy
491 out_callop;
492 out_cond_jump $op->pmreplroot if ${$op->pmreplroot};
493 out_jump_next;
494
191 } else { 495 } else {
192 $source .= " PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n"; 496 # normal operator, linear execution
193 $source .= " goto op_${$op->next};\n"; 497 out_linear;
194 } 498 }
195 } 499 }
196 500
501 $op_name = "func exit"; assert (0);
502
197 $source .= "}\n"; 503 $source .= <<EOF;
504op_0:
505 return 0;
506}
507EOF
508 #warn $source;
198 509
510 $source
511}
512
513sub source2ptr {
514 my ($source) = @_;
515
516 my $md5 = Digest::MD5::md5_hex $source;
517 $source =~ s/%%%FUNC%%%/Faster_$md5/;
518
519 my $stem = "/tmp/$md5";
520
521 unless (-e "$stem$_so") {
522 open FILE, ">:raw", "$stem.c";
199 print <<EOF; 523 print FILE <<EOF;
524#define PERL_NO_GET_CONTEXT
525
526#include <assert.h>
527
200#include "EXTERN.h" 528#include "EXTERN.h"
201#include "perl.h" 529#include "perl.h"
202#include "XSUB.h" 530#include "XSUB.h"
531
532#define RUNOPS_TILL(op) \\
533 while (nextop != (op)) \\
534 { \\
535 PERL_ASYNC_CHECK (); \\
536 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
537 }
538
203EOF 539EOF
204 print $source; 540 print FILE $source;
541 close FILE;
542 system "$COMPILE -o $stem$_o $stem.c";
543 system "$LINK -o $stem$_so $stem$_o $LIBS";
544 }
545
546# warn $source;
547 my $so = DynaLoader::dl_load_file "$stem$_so"
548 or die "$stem$_so: $!";
549
550 DynaLoader::dl_find_symbol $so, "Faster_$md5"
551 or die "Faster_$md5: $!"
552}
553
554sub entersub {
555 my ($cv) = @_;
556
557 # always compile the whole stash
558# my @stash = $cv->STASH->ARRAY;
559# warn join ":", @stash;
560# exit;
561
562 eval {
563 my $source = cv2c $cv;
564
565 my $ptr = source2ptr $source;
566
567 patch_cv $cv, $ptr;
568 };
569
570 warn $@ if $@;
205} 571}
206 572
207hook_entersub; 573hook_entersub;
208 574
2091; 5751;
210 576
211=back 577=back
212 578
213=head1 LIMITATIONS 579=head1 BUGS/LIMITATIONS
214 580
215Tainting and debugging will disable Faster. 581Perl will check much less often for asynchronous signals in
582Faster-compiled code. It tries to check on every function call, loop
583iteration and every I/O operator, though.
584
585The following things will disable Faster. If you manage to enable them at
586runtime, bad things will happen.
587
588 enabled tainting
589 enabled debugging
590
591This will dramatically reduce Faster's performance:
592
593 threads (but you don't care about speed if you use threads anyway)
594
595These constructs will force the use of the interpreter as soon as they are
596being executed, for the rest of the currently executed:
597
598 .., ... (flipflop operators)
599 goto
600 next, redo (but not well-behaved last's)
601 eval
602 require
603 any use of formats
216 604
217=head1 AUTHOR 605=head1 AUTHOR
218 606
219 Marc Lehmann <schmorp@schmorp.de> 607 Marc Lehmann <schmorp@schmorp.de>
220 http://home.schmorp.de/ 608 http://home.schmorp.de/

Diff Legend

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