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

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

Diff Legend

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