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

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

Diff Legend

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