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

Comparing Faster/Faster.pm (file contents):
Revision 1.12 by root, Fri Mar 10 18:39:26 2006 UTC vs.
Revision 1.23 by root, Fri Mar 10 22:45:18 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
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.
10 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;
18use Config; 41use Config;
19use B (); 42use B ();
20use Digest::MD5 (); 43#use Digest::MD5 ();
21use DynaLoader (); 44use DynaLoader ();
45use File::Temp ();
22 46
23BEGIN { 47BEGIN {
24 our $VERSION = '0.01'; 48 our $VERSION = '0.01';
25 49
26 require XSLoader; 50 require XSLoader;
… …
31my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}"; 55my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
32my $LIBS = "$Config{libs}"; 56my $LIBS = "$Config{libs}";
33my $_o = $Config{_o}; 57my $_o = $Config{_o};
34my $_so = ".so"; 58my $_so = ".so";
35 59
36my $opt_assert = 1; 60# we don't need no steenking PIC on x86
61$COMPILE =~ s/-f(?:PIC|pic)//g
62 if $Config{archname} =~ /^(i[3456]86)-/;
63
64my $opt_assert = $ENV{FASTER_DEBUG};
65my $verbose = $ENV{FASTER_VERBOSE}+0;
37 66
38our $source; 67our $source;
39 68
40my @ops; 69our @ops;
41my $op; 70our $op;
42my $op_name; 71our $op_name;
43my @loop; 72our @op_loop;
73our %op_regcomp;
44 74
45my %flag; 75my %f_unsafe = map +($_ => undef), qw(
76 leavesub leavesublv return
77 goto last redo next
78 eval flip leaveeval entertry
79 formline grepstart mapstart
80 substcont entereval require
81);
46 82
47# complex flag steting is no longer required, rewrite this ugly code
48for (split /\n/, <<EOF) {
49 leavesub unsafe
50 leavesublv unsafe
51 return unsafe
52 flip unsafe
53 goto unsafe
54 last unsafe
55 redo unsafe
56 next unsafe
57 eval unsafe
58 leaveeval unsafe
59 entertry unsafe
60 formline unsafe
61 grepstart unsafe
62 mapstart unsafe
63 substcont unsafe
64 entereval unsafe noasync todo
65 require unsafe
66
67 mapstart noasync
68 grepstart noasync
69 match noasync
70
71 last noasync
72 next noasync
73 redo noasync
74 seq noasync
75 pushmark noasync extend=0 83# pushmark extend=0
76 padsv noasync extend=1 84# padsv extend=1
77 padav noasync extend=1 85# padav extend=1
78 padhv noasync extend=1 86# padhv extend=1
79 padany noasync extend=1 87# padany extend=1
80 entersub noasync 88# const extend=1
81 aassign noasync 89
82 sassign noasync 90my %f_noasync = map +($_ => undef), qw(
83 rv2av noasync 91 mapstart grepstart match entereval
84 rv2cv noasync 92 enteriter entersub leaveloop
85 rv2gv noasync 93
86 rv2hv noasync 94 pushmark nextstate
87 refgen noasync 95
88 nextstate noasync 96 const stub unstack
89 gv noasync 97 last next redo seq
90 gvsv noasync 98 padsv padav padhv padany
91 add noasync 99 aassign sassign orassign
92 subtract noasync 100 rv2av rv2cv rv2gv rv2hv refgen
93 multiply noasync 101 gv gvsv
94 divide noasync 102 add subtract multiply divide
95 complement noasync 103 complement cond_expr and or not
96 cond_expr noasync 104 defined
97 and noasync
98 or noasync
99 not noasync
100 defined noasync
101 method_named noasync 105 method_named
102 preinc noasync 106 preinc postinc predec postdec
103 postinc noasync 107 aelem aelemfast helem delete exists
104 predec noasync 108 pushre subst list join split concat
105 postdec noasync 109 length substr stringify ord
106 stub noasync 110 push pop shift unshift
107 unstack noasync 111 eq ne gt lt ge le
108 leaveloop noasync 112 regcomp regcreset regcmaybe
109 aelem noasync 113);
110 aelemfast noasync
111 helem noasync
112 pushre noasync
113 subst noasync
114 const noasync extend=1
115 list noasync
116 join noasync
117 split noasync
118 concat noasync
119 push noasync
120 pop noasync
121 shift noasync
122 unshift noasync
123 length noasync
124 substr noasync
125 stringify noasync
126 eq noasync
127 ne noasync
128 gt noasync
129 lt noasync
130 ge noasync
131 le noasync
132 enteriter noasync
133 ord noasync
134
135 iter async
136EOF
137 my (undef, $op, @flags) = split /\s+/;
138
139 undef $flag{$_}{$op}
140 for ("known", @flags);
141}
142 114
143my %callop = ( 115my %callop = (
144 entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)", 116 entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)",
145 mapstart => "Perl_pp_grepstart (aTHX)", 117 mapstart => "Perl_pp_grepstart (aTHX)",
146); 118);
… …
157sub out_callop { 129sub out_callop {
158 assert "nextop == (OP *)$$op"; 130 assert "nextop == (OP *)$$op";
159 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n"; 131 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
160} 132}
161 133
134sub out_cond_jump {
135 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
136}
137
162sub out_jump_next { 138sub out_jump_next {
139 out_cond_jump $op_regcomp{$$op}
140 if $op_regcomp{$$op};
141
163 assert "nextop == (OP *)${$op->next}"; 142 assert "nextop == (OP *)${$op->next}";
164 $source .= " goto op_${$op->next};\n"; 143 $source .= " goto op_${$op->next};\n";
165} 144}
166 145
167sub out_next { 146sub out_next {
… …
171} 150}
172 151
173sub out_linear { 152sub out_linear {
174 out_callop; 153 out_callop;
175 out_jump_next; 154 out_jump_next;
176}
177
178sub out_cond_jump {
179 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
180} 155}
181 156
182sub op_entersub { 157sub op_entersub {
183 out_callop; 158 out_callop;
184 $source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n"; 159 $source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n";
… …
199 $source .= " PUSHMARK (PL_stack_sp);\n"; 174 $source .= " PUSHMARK (PL_stack_sp);\n";
200 175
201 out_next; 176 out_next;
202} 177}
203 178
204if (0 && $Config{useithreads} ne "define") { 179if ($Config{useithreads} ne "define") {
205 # disable optimisations on ithreads 180 # disable optimisations on ithreads
206 181
207 *op_const = sub { 182 *op_const = sub {
208 $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n"; 183 $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
209 184
… …
313 out_next; 288 out_next;
314} 289}
315 290
316sub op_padsv { 291sub op_padsv {
317 my $flags = $op->flags; 292 my $flags = $op->flags;
318 my $target = $op->targ; 293 my $targ = $op->targ;
319 294
320 $source .= <<EOF; 295 $source .= <<EOF;
321 { 296 {
322 dSP; 297 dSP;
323 XPUSHs (PAD_SV ((PADOFFSET)$target)); 298 XPUSHs (PAD_SV ((PADOFFSET)$targ));
324 PUTBACK; 299 PUTBACK;
325EOF 300EOF
326 if ($op->flags & B::OPf_MOD) { 301 if ($op->flags & B::OPf_MOD) {
327 if ($op->private & B::OPpLVAL_INTRO) { 302 if ($op->private & B::OPpLVAL_INTRO) {
328 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n"; 303 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$targ));\n";
329 } elsif ($op->private & B::OPpDEREF) { 304 } elsif ($op->private & B::OPpDEREF) {
330 my $deref = $op->private & B::OPpDEREF; 305 my $deref = $op->private & B::OPpDEREF;
331 $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n"; 306 $source .= " Perl_vivify_ref (aTHX_ PAD_SVl ((PADOFFSET)$targ), $deref);\n";
332 } 307 }
333 } 308 }
334 $source .= <<EOF; 309 $source .= <<EOF;
335 } 310 }
336EOF 311EOF
… …
385 out_next; 360 out_next;
386} 361}
387 362
388sub op_grepstart { 363sub op_grepstart {
389 out_callop; 364 out_callop;
365 $op = $op->next;
390 out_cond_jump $op->next->other; 366 out_cond_jump $op->other;
391 out_jump_next; 367 out_jump_next;
392} 368}
393 369
394*op_mapstart = \&op_grepstart; 370*op_mapstart = \&op_grepstart;
395 371
… …
404 my ($idx) = @_; 380 my ($idx) = @_;
405 381
406 out_callop; 382 out_callop;
407 383
408 out_cond_jump $_->[$idx] 384 out_cond_jump $_->[$idx]
409 for reverse @loop; 385 for reverse @op_loop;
410 386
411 $source .= " return nextop;\n"; 387 $source .= " return nextop;\n";
412} 388}
413 389
414sub xop_next { 390sub xop_next {
… …
424} 400}
425 401
426sub cv2c { 402sub cv2c {
427 my ($cv) = @_; 403 my ($cv) = @_;
428 404
429 @loop = (); 405 local @ops;
406 local @op_loop;
407 local %op_regcomp;
430 408
431 my %opsseen; 409 my %opsseen;
432 my @todo = $cv->START; 410 my @todo = $cv->START;
433 411
434 while (my $op = shift @todo) { 412 while (my $op = shift @todo) {
… …
439 my $name = $op->name; 417 my $name = $op->name;
440 my $class = B::class $op; 418 my $class = B::class $op;
441 419
442 if ($class eq "LOGOP") { 420 if ($class eq "LOGOP") {
443 unshift @todo, $op->other; # unshift vs. push saves jumps 421 unshift @todo, $op->other; # unshift vs. push saves jumps
422
423 # regcomp/o patches ops at runtime, lets expect that
424 $op_regcomp{${$op->first}} = $op->next
425 if $name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP;
426
444 } elsif ($class eq "PMOP") { 427 } elsif ($class eq "PMOP") {
445 unshift @todo, $op->pmreplstart if ${$op->pmreplstart}; 428 unshift @todo, $op->pmreplstart if ${$op->pmreplstart};
429
446 } elsif ($class eq "LOOP") { 430 } elsif ($class eq "LOOP") {
447 push @loop, [$op->nextop, $op->lastop->next, $op->redoop->next]; 431 push @op_loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
432 push @todo, $op->nextop, $op->lastop->next, $op->redoop->next;
448 } 433 }
449 } 434 }
450 } 435 }
451 436
452 local $source = <<EOF; 437 local $source = <<EOF;
… …
457 442
458 while (@ops) { 443 while (@ops) {
459 $op = shift @ops; 444 $op = shift @ops;
460 $op_name = $op->name; 445 $op_name = $op->name;
461 446
447 my $class = B::class $op;
448
462 $source .= "op_$$op: /* $op_name */\n"; 449 $source .= "op_$$op: /* $op_name */\n";
463 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d# 450 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
464 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d# 451 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
465 452
466 $source .= " PERL_ASYNC_CHECK ();\n" 453 $source .= " PERL_ASYNC_CHECK ();\n"
467 unless exists $flag{noasync}{$op_name}; 454 unless exists $f_noasync{$op_name};
468 455
469 if (my $can = __PACKAGE__->can ("op_$op_name")) { 456 if (my $can = __PACKAGE__->can ("op_$op_name")) {
470 # handcrafted replacement 457 # handcrafted replacement
471 $can->($op); 458 $can->($op);
472 459
473 } elsif (exists $flag{unsafe}{$op_name}) { 460 } elsif (exists $f_unsafe{$op_name}) {
474 # unsafe, return to interpreter 461 # unsafe, return to interpreter
475 assert "nextop == (OP *)$$op"; 462 assert "nextop == (OP *)$$op";
476 $source .= " return nextop;\n"; 463 $source .= " return nextop;\n";
477 464
478 } elsif ("LOGOP" eq B::class $op) { 465 } elsif ("LOGOP" eq $class) {
479 # logical operation with optionaรถ branch 466 # logical operation with optional branch
480 out_callop; 467 out_callop;
481 out_cond_jump $op->other; 468 out_cond_jump $op->other;
482 out_jump_next; 469 out_jump_next;
483 470
484 } elsif ("PMOP" eq B::class $op) { 471 } elsif ("PMOP" eq $class) {
485 # regex-thingy 472 # regex-thingy
486 out_callop; 473 out_callop;
487 out_cond_jump $op->pmreplroot if ${$op->pmreplroot}; 474 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
488 out_jump_next; 475 out_jump_next;
489 476
490 } else { 477 } else {
491 # normal operator, linear execution 478 # normal operator, linear execution
492 out_linear; 479 out_linear;
… …
503 #warn $source; 490 #warn $source;
504 491
505 $source 492 $source
506} 493}
507 494
495my $uid = "aaaaaaa0";
496
508sub source2ptr { 497sub source2ptr {
509 my ($source) = @_; 498 my (@source) = @_;
510 499
511 my $md5 = Digest::MD5::md5_hex $source; 500 my $stem = "/tmp/Faster-$$-" . $uid++;
512 $source =~ s/%%%FUNC%%%/Faster_$md5/;
513 501
514 my $stem = "/tmp/$md5";
515
516 unless (-e "$stem$_so") {
517 open FILE, ">:raw", "$stem.c"; 502 open FILE, ">:raw", "$stem.c";
518 print FILE <<EOF; 503 print FILE <<EOF;
519#define PERL_NO_GET_CONTEXT 504#define PERL_NO_GET_CONTEXT
520 505
521#include <assert.h> 506#include <assert.h>
522 507
523#include "EXTERN.h" 508#include "EXTERN.h"
524#include "perl.h" 509#include "perl.h"
525#include "XSUB.h" 510#include "XSUB.h"
526 511
527#define RUNOPS_TILL(op) \\ 512#define RUNOPS_TILL(op) \\
528 while (nextop != (op)) \\ 513while (nextop != (op)) \\
529 { \\ 514 { \\
530 PERL_ASYNC_CHECK (); \\ 515 PERL_ASYNC_CHECK (); \\
531 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\ 516 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
532 } 517 }
533 518
534EOF 519EOF
520 for (@source) {
521 my $func = $uid++;
522 $_ =~ s/%%%FUNC%%%/$func/g;
535 print FILE $source; 523 print FILE $_;
536 close FILE; 524 $_ = $func;
537 system "$COMPILE -o $stem$_o $stem.c";
538 system "$LINK -o $stem$_so $stem$_o $LIBS";
539 } 525 }
540 526
541# warn $source; 527 close FILE;
528 system "$COMPILE -o $stem$_o $stem.c";
529 #d#unlink "$stem.c";
530 system "$LINK -o $stem$_so $stem$_o $LIBS";
531 unlink "$stem$_o";
532
542 my $so = DynaLoader::dl_load_file "$stem$_so" 533 my $so = DynaLoader::dl_load_file "$stem$_so"
543 or die "$stem$_so: $!"; 534 or die "$stem$_so: $!";
544 535
545 DynaLoader::dl_find_symbol $so, "Faster_$md5" 536 #unlink "$stem$_so";
546 or die "Faster_$md5: $!" 537
538 map +(DynaLoader::dl_find_symbol $so, $_), @source
547} 539}
540
541my %ignore;
548 542
549sub entersub { 543sub entersub {
550 my ($cv) = @_; 544 my ($cv) = @_;
551 545
552 # always compile the whole stash 546 my $pkg = $cv->STASH->NAME;
553# my @stash = $cv->STASH->ARRAY; 547
554# warn join ":", @stash; 548 return if $ignore{$pkg};
555# exit; 549
550 warn "compiling ", $cv->STASH->NAME, "\n"
551 if $verbose;
556 552
557 eval { 553 eval {
558 my $source = cv2c $cv; 554 my @cv;
555 my @cv_source;
559 556
557 # always compile the whole stash
558 my %stash = $cv->STASH->ARRAY;
559 while (my ($k, $v) = each %stash) {
560 $v->isa (B::GV::)
561 or next;
562
563 my $cv = $v->CV;
564
565 if ($cv->isa (B::CV::)
566 && ${$cv->START}
567 && $cv->START->name ne "null") {
568 push @cv, $cv;
569 push @cv_source, cv2c $cv;
570 }
571 }
572
560 my $ptr = source2ptr $source; 573 my @ptr = source2ptr @cv_source;
561 574
575 for (0 .. $#cv) {
562 patch_cv $cv, $ptr; 576 patch_cv $cv[$_], $ptr[$_];
577 }
563 }; 578 };
564 579
565 warn $@ if $@; 580 if ($@) {
581 $ignore{$pkg}++;
582 warn $@;
583 }
566} 584}
567 585
568hook_entersub; 586hook_entersub;
569 587
5701; 5881;
589
590=back
591
592=head1 ENVIRONMENT VARIABLES
593
594The following environment variables influence the behaviour of Faster:
595
596=over 4
597
598=item FASTER_VERBOSE
599
600Faster will output more informational messages when set to values higher
601than C<0>. Currently, C<1> outputs which packages are being compiled.
602
603=item FASTER_DEBUG
604
605Add debugging code when set to values higher than C<0>. Currently, this
606adds 1-3 C<assert>'s per perl op, to ensure that opcode order and C
607execution order are compatible.
608
609=item FASTER_CACHE
610
611NOT YET IMPLEMENTED
612
613Set a persistent cache directory that caches compiled code
614fragments. Normally, code compiled by Faster will be deleted immediately,
615and every restart will recompile everything. Setting this variable to a
616directory makes Faster cache the generated files for re-use.
617
618This directory will always grow in contents, so you might need to erase it
619from time to time.
571 620
572=back 621=back
573 622
574=head1 BUGS/LIMITATIONS 623=head1 BUGS/LIMITATIONS
575 624
576Perl will check much less often for asynchronous signals in 625Perl will check much less often for asynchronous signals in
577Faster-compiled code. It tries to check on every function call, loop 626Faster-compiled code. It tries to check on every function call, loop
578iteration and every I/O operator, though. 627iteration and every I/O operator, though.
579 628
580The following things will disable Faster. If you manage to enable them at 629The following things will disable Faster. If you manage to enable them at
581runtime, bad things will happen. 630runtime, bad things will happen. Enabling them at startup will be fine,
631though.
582 632
583 enabled tainting 633 enabled tainting
584 enabled debugging 634 enabled debugging
585 635
586This will dramatically reduce Faster's performance: 636Thread-enabled builds of perl will dramatically reduce Faster's
637performance, but you don't care about speed if you enable threads anyway.
587 638
588 threads (but you don't care about speed if you use threads anyway)
589
590These constructs will force the use of the interpreter as soon as they are 639These constructs will force the use of the interpreter for the currently
591being executed, for the rest of the currently executed: 640executed function as soon as they are being encountered during execution.
592 641
593 .., ... (flipflop operators)
594 goto 642 goto
595 next, redo (but not well-behaved last's) 643 next, redo (but not well-behaved last's)
596 eval 644 eval
597 require 645 require
598 any use of formats 646 any use of formats
647 .., ... (flipflop operators)
599 648
600=head1 AUTHOR 649=head1 AUTHOR
601 650
602 Marc Lehmann <schmorp@schmorp.de> 651 Marc Lehmann <schmorp@schmorp.de>
603 http://home.schmorp.de/ 652 http://home.schmorp.de/

Diff Legend

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