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.19 by root, Fri Mar 10 22:18:39 2006 UTC

… …
4 4
5=head1 SYNOPSIS 5=head1 SYNOPSIS
6 6
7 use Faster; 7 use Faster;
8 8
9 perl -MFaster ...
10
9=head1 DESCRIPTION 11=head1 DESCRIPTION
10 12
13This module implements a very simple-minded JIT. It works by more or less
14translating every function it sees into a C program, compiling it and then
15replacing the function by the compiled code.
16
17As a result, startup times are immense, as every function might lead to a
18full-blown compilation.
19
20The speed improvements are also not great, you can expect 20% or so on
21average, for code that runs very often.
22
23Faster is in the early stages of development. Due to its design its
24relatively safe to use (it will either work or simply slowdown the program
25immensely, but rarely cause bugs).
26
27Usage is very easy, just C<use Faster> and every function called from then
28on will be compiled.
29
30Right now, Faster will leave lots of F<*.c>, F<*.o> and F<*.so> files in
31F</tmp>, and it will even create those temporary files in an insecure
32manner, so watch out.
33
11=over 4 34=over 4
12 35
13=cut 36=cut
14 37
15package Faster; 38package Faster;
16 39
17use strict; 40use strict;
41use Config;
42use B ();
43#use Digest::MD5 ();
44use DynaLoader ();
18 45
19BEGIN { 46BEGIN {
20 our $VERSION = '0.01'; 47 our $VERSION = '0.01';
21 48
22 require XSLoader; 49 require XSLoader;
23 XSLoader::load __PACKAGE__, $VERSION; 50 XSLoader::load __PACKAGE__, $VERSION;
24} 51}
25 52
26use B (); 53my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}";
54my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
55my $LIBS = "$Config{libs}";
56my $_o = $Config{_o};
57my $_so = ".so";
58
59# we don't need no steenking PIC on x86
60$COMPILE =~ s/-f(?:PIC|pic)//g
61 if $Config{archname} =~ /^(i[3456]86)-/;
62
63my $opt_assert = 0;
27 64
28our $source; 65our $source;
29our $label_next; 66
30our $label_last; 67our @ops;
31our $label_redo; 68our $op;
69our $op_name;
70our @op_loop;
71our %op_regcomp;
32 72
33my %flag; 73my %flag;
34 74
75# complex flag steting is no longer required, rewrite this ugly code
35for (split /\n/, <<EOF) { 76for (split /\n/, <<EOF) {
36 leavesub unsafe 77 leavesub unsafe
37 leavesublv unsafe 78 leavesublv unsafe
38 return unsafe 79 return unsafe
39 flip unsafe 80 flip unsafe
… …
42 redo unsafe 83 redo unsafe
43 next unsafe 84 next unsafe
44 eval unsafe 85 eval unsafe
45 leaveeval unsafe 86 leaveeval unsafe
46 entertry unsafe 87 entertry unsafe
47 substconst unsafe
48 formline unsafe 88 formline unsafe
49 grepstart unsafe 89 grepstart unsafe
90 mapstart unsafe
91 substcont unsafe
92 entereval unsafe noasync todo
93 require unsafe
94
95 mapstart noasync
96 grepstart noasync
97 match noasync
98
99 last noasync
100 next noasync
101 redo noasync
102 seq noasync
103 pushmark noasync extend=0
104 padsv noasync extend=1
105 padav noasync extend=1
106 padhv noasync extend=1
107 padany noasync extend=1
108 entersub noasync
109 aassign noasync
110 sassign noasync
111 rv2av noasync
112 rv2cv noasync
113 rv2gv noasync
114 rv2hv noasync
115 refgen noasync
116 nextstate noasync
117 gv noasync
118 gvsv noasync
119 add noasync
120 subtract noasync
121 multiply noasync
122 divide noasync
123 complement noasync
124 cond_expr noasync
125 and noasync
126 or noasync
127 not noasync
128 defined noasync
129 method_named noasync
130 preinc noasync
131 postinc noasync
132 predec noasync
133 postdec noasync
134 stub noasync
135 unstack noasync
136 leaveloop noasync
137 aelem noasync
138 aelemfast noasync
139 helem noasync
140 delete noasync
141 exists noasync
142 pushre noasync
143 subst noasync
144 const noasync extend=1
145 list noasync
146 join noasync
147 split noasync
148 concat noasync
149 push noasync
150 pop noasync
151 shift noasync
152 unshift noasync
153 length noasync
154 substr noasync
155 stringify noasync
156 eq noasync
157 ne noasync
158 gt noasync
159 lt noasync
160 ge noasync
161 le noasync
162 enteriter noasync
163 ord noasync
164 orassign noasync
165 regcomp noasync
166 regcreset noasync
167 regcmaybe noasync
168
169 iter async
50EOF 170EOF
51 my (undef, $op, @flags) = split /\s+/; 171 my (undef, $op, @flags) = split /\s+/;
52 172
53 undef $flag{$_}{$op} 173 undef $flag{$_}{$op}
54 for ("known", @flags); 174 for ("known", @flags);
55} 175}
56 176
177my %callop = (
178 entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)",
179 mapstart => "Perl_pp_grepstart (aTHX)",
180);
181
182sub callop {
183 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
184}
185
186sub assert {
187 return unless $opt_assert;
188 $source .= " assert ((\"$op_name\", ($_[0])));\n";
189}
190
191sub out_callop {
192 assert "nextop == (OP *)$$op";
193 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
194}
195
196sub out_cond_jump {
197 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
198}
199
200sub out_jump_next {
201 out_cond_jump $op_regcomp{$$op}
202 if $op_regcomp{$$op};
203
204 assert "nextop == (OP *)${$op->next}";
205 $source .= " goto op_${$op->next};\n";
206}
207
57sub out_next { 208sub out_next {
58 my ($op) = @_;
59
60 $source .= " PL_op = (OP *)${$op->next}L;\n"; 209 $source .= " nextop = (OP *)${$op->next}L;\n";
61 $source .= " goto op_${$op->next};\n"; 210
211 out_jump_next;
62} 212}
213
214sub out_linear {
215 out_callop;
216 out_jump_next;
217}
218
219sub op_entersub {
220 out_callop;
221 $source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n";
222 out_jump_next;
223}
224
225*op_require = \&op_entersub;
63 226
64sub op_nextstate { 227sub op_nextstate {
65 my ($op) = @_;
66
67 $source .= " PL_curcop = (COP *)PL_op;\n"; 228 $source .= " PL_curcop = (COP *)nextop;\n";
68 $source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n"; 229 $source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
69 $source .= " FREETMPS;\n"; 230 $source .= " FREETMPS;\n";
70 231
71 out_next $op; 232 out_next;
72} 233}
73 234
74sub op_pushmark { 235sub op_pushmark {
75 my ($op) = @_;
76
77 $source .= " PUSHMARK (PL_stack_sp);\n"; 236 $source .= " PUSHMARK (PL_stack_sp);\n";
78 237
79 out_next $op; 238 out_next;
80} 239}
81 240
82sub op_const { 241if ($Config{useithreads} ne "define") {
83 my ($op) = @_; 242 # disable optimisations on ithreads
84 243
244 *op_const = sub {
85 $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n"; 245 $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
86 246
87 out_next $op; 247 out_next;
88} 248 };
89 249
90*op_gv = \&op_const; 250 *op_gv = \&op_const;
91 251
252 *op_aelemfast = sub {
253 my $targ = $op->targ;
254 my $private = $op->private;
255
256 $source .= " {\n";
257
258 if ($op->flags & B::OPf_SPECIAL) {
259 $source .= " AV *av = (AV*)PAD_SV((PADOFFSET)$targ);\n";
260 } else {
261 $source .= " AV *av = GvAV ((GV *)${$op->sv}L);\n";
262 }
263
264 if ($op->flags & B::OPf_MOD) {
265 $source .= " SV *sv = *av_fetch (av, $private, 1);\n";
266 } else {
267 $source .= " SV **svp = av_fetch (av, $private, 0); SV *sv = svp ? *svp : &PL_sv_undef;\n";
268 }
269
270 if (!($op->flags & B::OPf_MOD)) {
271 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
272 }
273
274 $source .= " dSP;\n";
275 $source .= " XPUSHs (sv);\n";
276 $source .= " PUTBACK;\n";
277 $source .= " }\n";
278
279 out_next;
280 };
281
282 *op_gvsv = sub {
283 $source .= " {\n";
284 $source .= " dSP;\n";
285 $source .= " EXTEND (SP, 1);\n";
286
287 if ($op->private & B::OPpLVAL_INTRO) {
288 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
289 } else {
290 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
291 }
292
293 $source .= " PUTBACK;\n";
294 $source .= " }\n";
295
296 out_next;
297 };
298}
299
300# does kill Crossfire/res2pm
92sub op_stringify { 301sub op_stringify {
93 my ($op) = @_; 302 my $targ = $op->targ;
94 303
95 $source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n"; 304 $source .= <<EOF;
305 {
306 dSP;
307 SV *targ = PAD_SV ((PADOFFSET)$targ);
308 sv_copypv (TARG, TOPs);
309 SETTARG;
310 PUTBACK;
311 }
312EOF
96 313
97 out_next $op; 314 out_next;
315}
316
317sub op_and {
318 $source .= <<EOF;
319 {
320 dSP;
321
322 if (SvTRUE (TOPs))
323 {
324 --SP;
325 PUTBACK;
326 nextop = (OP *)${$op->other}L;
327 goto op_${$op->other};
328 }
329 }
330EOF
331
332 out_next;
333}
334
335sub op_or {
336 $source .= <<EOF;
337 {
338 dSP;
339
340 if (!SvTRUE (TOPs))
341 {
342 --SP;
343 PUTBACK;
344 nextop = (OP *)${$op->other}L;
345 goto op_${$op->other};
346 }
347 }
348EOF
349
350 out_next;
351}
352
353sub op_padsv {
354 my $flags = $op->flags;
355 my $target = $op->targ;
356
357 $source .= <<EOF;
358 {
359 dSP;
360 XPUSHs (PAD_SV ((PADOFFSET)$target));
361 PUTBACK;
362EOF
363 if ($op->flags & B::OPf_MOD) {
364 if ($op->private & B::OPpLVAL_INTRO) {
365 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n";
366 } elsif ($op->private & B::OPpDEREF) {
367 my $deref = $op->private & B::OPpDEREF;
368 $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
369 }
370 }
371 $source .= <<EOF;
372 }
373EOF
374
375 out_next;
98} 376}
99 377
100# pattern const+ (or general push1) 378# pattern const+ (or general push1)
101# pattern pushmark return(?) 379# pattern pushmark return(?)
102# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 380# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
103 381
104# pattern const method_named 382# pattern const method_named
105sub xop_method_named { 383sub op_method_named {
106 my ($op) = @_;
107
108 my $ppaddr = ppaddr $op->type;
109
110 $source .= <<EOF; 384 $source .= <<EOF;
111 { 385 {
112 dSP; 386 static HV *last_stash;
387 static SV *last_cv;
388 static U32 last_sub_generation;
113 389
114 if (SvROK (TOPm1s) && SvOBJECT (SvRV (TOPm1s))) 390 SV *obj = *(PL_stack_base + TOPMARK + 1);
391
392 if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
115 { 393 {
116 static SV *last_stash, SV *last_res; 394 dSP;
117 SV *stash = SvSTASH (SvRV (TOPm1s)); 395 HV *stash = SvSTASH (SvRV (obj));
118 396
119 // simple polymorphic inline cache 397 /* simple "polymorphic" inline cache */
120 if (stash == last_stash) 398 if (stash == last_stash
399 && PL_sub_generation == last_sub_generation)
121 { 400 {
401 XPUSHs (last_cv);
122 dTARGET; 402 PUTBACK;
123 SETTARG (last_res);
124 } 403 }
125 else 404 else
126 { 405 {
127 PUTBACK; 406 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
128 ((PPFUNC)${ppaddr}L)(aTHX);\n"; 407
129 SPAGAIN; 408 SPAGAIN;
130 409 last_sub_generation = PL_sub_generation;
131 last_stash = stash; 410 last_stash = stash;
132 last_res = TOPs; 411 last_cv = TOPs;
133 } 412 }
134 } 413 }
414 else
415 {
416 /* error case usually */
417 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
418 }
135 } 419 }
136EOF 420EOF
137 421
138 out_next $op; 422 out_next;
139} 423}
140 424
141sub entersub { 425sub op_grepstart {
426 out_callop;
427 $op = $op->next;
428 out_cond_jump $op->other;
429 out_jump_next;
430}
431
432*op_mapstart = \&op_grepstart;
433
434sub op_substcont {
435 out_callop;
436 out_cond_jump $op->other->pmreplstart;
437 assert "nextop == (OP *)${$op->other->next}L";
438 $source .= " goto op_${$op->other->next};\n";
439}
440
441sub out_break_op {
442 my ($idx) = @_;
443
444 out_callop;
445
446 out_cond_jump $_->[$idx]
447 for reverse @op_loop;
448
449 $source .= " return nextop;\n";
450}
451
452sub xop_next {
453 out_break_op 0;
454}
455
456sub op_last {
457 out_break_op 1;
458}
459
460sub xop_redo {
461 out_break_op 2;
462}
463
464sub cv2c {
142 my ($cv) = @_; 465 my ($cv) = @_;
143 466
467 local @ops;
468 local @op_loop;
469 local %op_regcomp;
470
144 my %opsseen; 471 my %opsseen;
145 my @ops;
146 my @todo = $cv->START; 472 my @todo = $cv->START;
147 473
148 while (my $op = shift @todo) { 474 while (my $op = shift @todo) {
149 for (; $$op; $op = $op->next) { 475 for (; $$op; $op = $op->next) {
150 last if $opsseen{$$op}++; 476 last if $opsseen{$$op}++;
151 push @ops, $op; 477 push @ops, $op;
478
152 my $name = $op->name; 479 my $name = $op->name;
480 my $class = B::class $op;
481
153 if (B::class($op) eq "LOGOP") { 482 if ($class eq "LOGOP") {
154 push @todo, $op->other; 483 unshift @todo, $op->other; # unshift vs. push saves jumps
155 } elsif ($name eq "subst" and ${ $op->pmreplstart }) { 484
156 push @todo, $op->pmreplstart; 485 # regcomp/o patches ops at runtime, lets expect that
157 } elsif ($name =~ /^enter(loop|iter)$/) { 486 $op_regcomp{${$op->first}} = $op->next
158# if ($] > 5.009) { 487 if $name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP;
159# $labels{${$op->nextop}} = "NEXT"; 488
160# $labels{${$op->lastop}} = "LAST"; 489 } elsif ($class eq "PMOP") {
161# $labels{${$op->redoop}} = "REDO"; 490 unshift @todo, $op->pmreplstart if ${$op->pmreplstart};
162# } else { 491
163# $labels{$op->nextop->seq} = "NEXT"; 492 } elsif ($class eq "LOOP") {
164# $labels{$op->lastop->seq} = "LAST"; 493 push @op_loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
165# $labels{$op->redoop->seq} = "REDO"; 494 push @todo, $op->nextop, $op->lastop->next, $op->redoop->next;
166# }
167 } 495 }
168 } 496 }
169 } 497 }
170 498
171 local $source; 499 local $source = <<EOF;
500OP *%%%FUNC%%% (pTHX)
501{
502 register OP *nextop = (OP *)${$ops[0]}L;
503EOF
172 504
173 $source = "typedef OP *(*PPFUNC)(pTHX);\n\n"; 505 while (@ops) {
174 506 $op = shift @ops;
175 $source .= "OP *func (pTHX)\n{\n dTHX;\n";
176
177 for my $op (@ops) {
178 my $name = $op->name; 507 $op_name = $op->name;
179 my $ppaddr = ppaddr $op->type;
180 508
181 $source .= "op_$$op: /* $name */\n"; 509 $source .= "op_$$op: /* $op_name */\n";
510 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
511 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
182 512
513 $source .= " PERL_ASYNC_CHECK ();\n"
514 unless exists $flag{noasync}{$op_name};
515
183 if (my $can = __PACKAGE__->can ("op_$name")) { 516 if (my $can = __PACKAGE__->can ("op_$op_name")) {
517 # handcrafted replacement
184 $can->($op); 518 $can->($op);
185 } elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) { 519
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}) { 520 } elsif (exists $flag{unsafe}{$op_name}) {
190 $source .= " return ((PPFUNC)${ppaddr}L)(aTHX);\n"; 521 # unsafe, return to interpreter
522 assert "nextop == (OP *)$$op";
523 $source .= " return nextop;\n";
524
525 } elsif ("LOGOP" eq B::class $op) {
526 # logical operation with optionaö branch
527 out_callop;
528 out_cond_jump $op->other;
529 out_jump_next;
530
531 } elsif ("PMOP" eq B::class $op) {
532 # regex-thingy
533 out_callop;
534 out_cond_jump $op->pmreplroot if ${$op->pmreplroot};
535 out_jump_next;
536
191 } else { 537 } else {
192 $source .= " PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n"; 538 # normal operator, linear execution
193 $source .= " goto op_${$op->next};\n"; 539 out_linear;
194 } 540 }
195 } 541 }
196 542
543 $op_name = "func exit"; assert (0);
544
197 $source .= "}\n"; 545 $source .= <<EOF;
546op_0:
547 return 0;
548}
549EOF
550 #warn $source;
198 551
552 $source
553}
554
555my $uid = "aaaaaaa0";
556
557sub source2ptr {
558 my (@source) = @_;
559
560 my $stem = "/tmp/Faster-$$-" . $uid++;
561
562 open FILE, ">:raw", "$stem.c";
199 print <<EOF; 563 print FILE <<EOF;
564#define PERL_NO_GET_CONTEXT
565
566#include <assert.h>
567
200#include "EXTERN.h" 568#include "EXTERN.h"
201#include "perl.h" 569#include "perl.h"
202#include "XSUB.h" 570#include "XSUB.h"
571
572#define RUNOPS_TILL(op) \\
573while (nextop != (op)) \\
574 { \\
575 PERL_ASYNC_CHECK (); \\
576 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
577 }
578
203EOF 579EOF
204 print $source; 580 for (@source) {
581 my $func = $uid++;
582 $_ =~ s/%%%FUNC%%%/$func/g;
583 print FILE $_;
584 $_ = $func;
585 }
586
587 close FILE;
588 system "$COMPILE -o $stem$_o $stem.c";
589 #d#unlink "$stem.c";
590 system "$LINK -o $stem$_so $stem$_o $LIBS";
591 unlink "$stem$_o";
592
593 my $so = DynaLoader::dl_load_file "$stem$_so"
594 or die "$stem$_so: $!";
595
596 #unlink "$stem$_so";
597
598 map +(DynaLoader::dl_find_symbol $so, $_), @source
599}
600
601my %ignore;
602
603sub entersub {
604 my ($cv) = @_;
605
606 my $pkg = $cv->STASH->NAME;
607
608 return if $ignore{$pkg};
609
610 warn "compiling ", $cv->STASH->NAME;#d#
611
612 eval {
613 my @cv;
614 my @cv_source;
615
616 # always compile the whole stash
617 my %stash = $cv->STASH->ARRAY;
618 while (my ($k, $v) = each %stash) {
619 $v->isa (B::GV::)
620 or next;
621
622 my $cv = $v->CV;
623
624 if ($cv->isa (B::CV::)
625 && ${$cv->START}
626 && $cv->START->name ne "null") {
627 push @cv, $cv;
628 push @cv_source, cv2c $cv;
629 }
630 }
631
632 my @ptr = source2ptr @cv_source;
633
634 for (0 .. $#cv) {
635 patch_cv $cv[$_], $ptr[$_];
636 }
637 };
638
639 if ($@) {
640 $ignore{$pkg}++;
641 warn $@;
642 }
205} 643}
206 644
207hook_entersub; 645hook_entersub;
208 646
2091; 6471;
210 648
211=back 649=back
212 650
213=head1 LIMITATIONS 651=head1 BUGS/LIMITATIONS
214 652
215Tainting and debugging will disable Faster. 653Perl will check much less often for asynchronous signals in
654Faster-compiled code. It tries to check on every function call, loop
655iteration and every I/O operator, though.
656
657The following things will disable Faster. If you manage to enable them at
658runtime, bad things will happen. Enabling them at startup will be fine,
659though.
660
661 enabled tainting
662 enabled debugging
663
664Thread-enabled builds of perl will dramatically reduce Faster's
665performance, but you don't care about speed if you enable threads anyway.
666
667These constructs will force the use of the interpreter for the currently
668executed function as soon as they are being encountered during execution.
669
670 goto
671 next, redo (but not well-behaved last's)
672 eval
673 require
674 any use of formats
675 .., ... (flipflop operators)
216 676
217=head1 AUTHOR 677=head1 AUTHOR
218 678
219 Marc Lehmann <schmorp@schmorp.de> 679 Marc Lehmann <schmorp@schmorp.de>
220 http://home.schmorp.de/ 680 http://home.schmorp.de/

Diff Legend

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