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

Comparing Faster/Faster.pm (file contents):
Revision 1.26 by root, Sat Mar 11 18:13:35 2006 UTC vs.
Revision 1.35 by root, Sat Feb 21 05:55:52 2009 UTC

… …
8 8
9 perl -MFaster ... 9 perl -MFaster ...
10 10
11=head1 DESCRIPTION 11=head1 DESCRIPTION
12 12
13This module implements a very simple-minded JIT. It works by more or less 13This module implements a very simple-minded "JIT" (or actually AIT, ahead
14translating every function it sees into a C program, compiling it and then 14of time compiler). It works by more or less translating every function it
15replacing the function by the compiled code. 15sees into a C program, compiling it and then replacing the function by the
16compiled code.
16 17
17As a result, startup times are immense, as every function might lead to a 18As a result, startup times are immense, as every function might lead to a
18full-blown compilation. 19full-blown compilation.
19 20
20The speed improvements are also not great, you can expect 20% or so on 21The speed improvements are also not great, you can expect 20% or so on
21average, for code that runs very often. 22average, for code that runs very often. The reason for this is that data
23handling is mostly being done by the same old code, it just gets called
24a bit faster. Regexes and string operations won't get faster. Airhtmetic
25doresn't become any faster. Just the operands and other stuff is put on
26the stack faster, and the opcodes themselves have a bit less overhead.
22 27
23Faster is in the early stages of development. Due to its design its 28Faster 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 29relatively safe to use (it will either work or simply slowdown the program
25immensely, but rarely cause bugs). 30immensely, but rarely cause bugs).
26 31
32More intelligent algorithms (loop optimisation, type inference) could
33improve that easily, but requires a much more elaborate presentation and
34optimiser than what is in place. There are no plans to improve Faster in
35this way, yet, but it would provide a reasonably good place to start.
36
27Usage is very easy, just C<use Faster> and every function called from then 37Usage is very easy, just C<use Faster> and every function called from then
28on will be compiled. 38on will be compiled.
29 39
30Right now, Faster will leave lots of F<*.c>, F<*.o> and F<*.so> files in 40Right now, Faster can leave lots of F<*.c> and F<*.so> files in your
31F</tmp>, and it will even create those temporary files in an insecure 41F<$FASTER_CACHEDIR> (by default F<$HOME/.perl-faster-cache>), and it will
32manner, so watch out. 42even create those temporary files in an insecure manner, so watch out.
33 43
34=over 4 44=over 4
35 45
36=cut 46=cut
37 47
… …
40no warnings; 50no warnings;
41 51
42use strict; 52use strict;
43use Config; 53use Config;
44use B (); 54use B ();
45#use Digest::MD5 ();
46use DynaLoader (); 55use DynaLoader ();
47use File::Temp (); 56use Digest::MD5 ();
57use Storable ();
58use Fcntl ();
48 59
49BEGIN { 60BEGIN {
50 our $VERSION = '0.01'; 61 our $VERSION = '0.01';
51 62
52 require XSLoader; 63 require XSLoader;
53 XSLoader::load __PACKAGE__, $VERSION; 64 XSLoader::load __PACKAGE__, $VERSION;
54} 65}
55 66
67my $CACHEDIR =
68 $ENV{FASTER_CACHE}
69 || (exists $ENV{HOME} && "$ENV{HOME}/.perl-faster-cache")
70 || do {
71 require File::Temp;
72 File::Temp::tempdir (CLEANUP => 1)
73 };
74
56my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}"; 75my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}";
57my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}"; 76my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
58my $LIBS = "$Config{libs}"; 77my $LIBS = "";
59my $_o = $Config{_o}; 78my $_o = $Config{_o};
60my $_so = ".so"; 79my $_so = ".so";
61 80
62# we don't need no steenking PIC on x86 81# we don't need no steenking PIC on x86
63$COMPILE =~ s/-f(?:PIC|pic)//g 82$COMPILE =~ s/-f(?:PIC|pic)//g
64 if $Config{archname} =~ /^(i[3456]86)-/; 83 if $Config{archname} =~ /^(i[3456]86)-/;
65 84
66my $opt_assert = $ENV{FASTER_DEBUG}; 85my $opt_assert = $ENV{FASTER_DEBUG} & 2;
67my $verbose = $ENV{FASTER_VERBOSE}+0; 86my $verbose = $ENV{FASTER_VERBOSE}+0;
87
88warn "Faster: CACHEDIR is $CACHEDIR\n" if $verbose > 2;
68 89
69our $source; 90our $source;
70 91
71our @ops; 92our @ops;
72our $insn; 93our $insn;
73our $op; 94our $op;
74our $op_name; 95our $op_name;
75our @op_loop;
76our %op_regcomp; 96our %op_regcomp;
77 97
78# ops that cause immediate return to the interpreter 98# ops that cause immediate return to the interpreter
79my %f_unsafe = map +($_ => undef), qw( 99my %f_unsafe = map +($_ => undef), qw(
80 leavesub leavesublv return 100 leavesub leavesublv return
… …
133# ops that do not need an ASYNC_CHECK 153# ops that do not need an ASYNC_CHECK
134my %f_noasync = map +($_ => undef), qw( 154my %f_noasync = map +($_ => undef), qw(
135 mapstart grepstart match entereval 155 mapstart grepstart match entereval
136 enteriter entersub leaveloop 156 enteriter entersub leaveloop
137 157
138 pushmark nextstate 158 pushmark nextstate caller
139 159
140 const stub unstack 160 const stub unstack
141 last next redo seq 161 last next redo goto seq
142 padsv padav padhv padany 162 padsv padav padhv padany
143 aassign sassign orassign 163 aassign sassign orassign
144 rv2av rv2cv rv2gv rv2hv refgen 164 rv2av rv2cv rv2gv rv2hv refgen
145 gv gvsv 165 gv gvsv
146 add subtract multiply divide 166 add subtract multiply divide
147 complement cond_expr and or not 167 complement cond_expr and or not
168 bit_and bit_or bit_xor
148 defined 169 defined
149 method method_named bless 170 method method_named bless
150 preinc postinc predec postdec 171 preinc postinc predec postdec
151 aelem aelemfast helem delete exists 172 aelem aelemfast helem delete exists
152 pushre subst list join split concat 173 pushre subst list lslice join split concat
153 length substr stringify ord 174 length substr stringify ord
154 push pop shift unshift 175 push pop shift unshift
155 eq ne gt lt ge le 176 eq ne gt lt ge le
156 regcomp regcreset regcmaybe 177 regcomp regcreset regcmaybe
157); 178);
… …
173sub out_callop { 194sub out_callop {
174 assert "nextop == (OP *)$$op"; 195 assert "nextop == (OP *)$$op";
175 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n"; 196 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
176} 197}
177 198
199sub out_jump {
200 assert "nextop == (OP *)${$_[0]}L";
201 $source .= " goto op_${$_[0]};\n";
202}
203
178sub out_cond_jump { 204sub out_cond_jump {
179 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n"; 205 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
180} 206}
181 207
182sub out_jump_next { 208sub out_jump_next {
… …
213 239
214 out_next; 240 out_next;
215} 241}
216 242
217sub op_pushmark { 243sub op_pushmark {
218 $source .= " PUSHMARK (PL_stack_sp);\n"; 244 $source .= " faster_PUSHMARK (PL_stack_sp);\n";
219 245
220 out_next; 246 out_next;
221} 247}
222 248
223if ($Config{useithreads} ne "define") { 249if ($Config{useithreads} ne "define") {
… …
352 PUSHs (sv); 378 PUSHs (sv);
353 PUTBACK; 379 PUTBACK;
354EOF 380EOF
355 381
356 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) { 382 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
357 $source .= " vivify_ref (sv, " . $op->private . " & OPpDEREF);\n"; 383 $source .= " if (!SvROK (sv)) vivify_ref (sv, " . $op->private . " & OPpDEREF);\n";
358 } 384 }
359 $source .= " }\n"; 385 $source .= " }\n";
360 386
361 out_next; 387 out_next;
362} 388}
… …
473} 499}
474 500
475sub out_break_op { 501sub out_break_op {
476 my ($idx) = @_; 502 my ($idx) = @_;
477 503
504 if ($op->flags & B::OPf_SPECIAL && $insn->{loop}) {
505 # common case: no label, innermost loop only
506 my $next = $insn->{loop}{loop_targ}[$idx];
478 out_callop; 507 out_callop;
479 508 out_jump $next;
480 out_cond_jump $_->[$idx] 509 } elsif (my $loop = $insn->{loop}) {
481 for reverse @op_loop; 510 # less common case: maybe break to some outer loop
482
483 $source .= " return nextop;\n"; 511 $source .= " return nextop;\n";
512 # todo: walk stack up
513 } else {
514 # fuck yourself for writing such hacks
515 $source .= " return nextop;\n";
516 }
484} 517}
485 518
486sub xop_next { 519sub op_next {
487 out_break_op 0; 520 out_break_op 0;
488} 521}
489 522
490sub op_last { 523sub op_last {
491 out_break_op 1; 524 out_break_op 1;
492} 525}
493 526
527# TODO: does not seem to work
494sub xop_redo { 528#sub op_redo {
495 out_break_op 2; 529# out_break_op 2;
496} 530#}
497 531
498sub cv2c { 532sub cv2c {
499 my ($cv) = @_; 533 my ($cv) = @_;
500 534
501 local @ops; 535 local @ops;
502 local @op_loop;
503 local %op_regcomp; 536 local %op_regcomp;
504 537
505 my %opsseen; 538 my $curloop;
506 my @todo = $cv->START; 539 my @todo = $cv->START;
507 my %op_target; 540 my %op_target;
541 my $numpushmark;
542 my $scope;
508 543
544 my %op_seen;
509 while (my $op = shift @todo) { 545 while (my $op = shift @todo) {
546 my $next;
510 for (; $$op; $op = $op->next) { 547 for (; $$op; $op = $next) {
511 last if $opsseen{$$op}++; 548 last if $op_seen{$$op}++;
549
550 $next = $op->next;
512 551
513 my $name = $op->name; 552 my $name = $op->name;
514 my $class = B::class $op; 553 my $class = B::class $op;
515 554
516 my $insn = { op => $op }; 555 my $insn = { op => $op };
556
557 # end of loop reached?
558 $curloop = $curloop->{loop} if $curloop && $$op == ${$curloop->{loop_targ}[1]};
559
560 # remember enclosing loop
561 $insn->{loop} = $curloop if $curloop;
517 562
518 push @ops, $insn; 563 push @ops, $insn;
519 564
520 if (exists $extend{$name}) { 565 if (exists $extend{$name}) {
521 my $extend = $extend{$name}; 566 my $extend = $extend{$name};
522 $extend = $extend->($op) if ref $extend; 567 $extend = $extend->($op) if ref $extend;
523 $insn->{extend} = $extend if defined $extend; 568 $insn->{extend} = $extend if defined $extend;
524 } 569 }
525 570
526 push @todo, $op->next; 571 # TODO: mark scopes similar to loops, make them comparable
527 572 # static cxstack(?)
528 if ($class eq "LOGOP") { 573 if ($class eq "LOGOP") {
529 push @todo, $op->other; 574 push @todo, $op->other;
530 $op_target{${$op->other}}++; 575 $op_target{${$op->other}}++;
531 576
532 # regcomp/o patches ops at runtime, lets expect that 577 # regcomp/o patches ops at runtime, lets expect that
… …
540 unshift @todo, $op->pmreplstart; 585 unshift @todo, $op->pmreplstart;
541 $op_target{${$op->pmreplstart}}++; 586 $op_target{${$op->pmreplstart}}++;
542 } 587 }
543 588
544 } elsif ($class eq "LOOP") { 589 } elsif ($class eq "LOOP") {
545 my @targ = ($op->nextop, $op->lastop->next, $op->redoop->next); 590 my @targ = ($op->nextop, $op->lastop->next, $op->redoop);
546 591
547 push @op_loop, \@targ; 592 unshift @todo, $next, $op->redoop, $op->nextop, $op->lastop;
548 push @todo, @targ; 593 $next = $op->redoop;
549 594
550 $op_target{$$_}++ for @targ; 595 $op_target{$$_}++ for @targ;
596
597 $insn->{loop_targ} = \@targ;
598 $curloop = $insn;
599
551 } elsif ($class eq "COP") { 600 } elsif ($class eq "COP") {
552 $insn->{bblock}++ if defined $op->label; 601 if (defined $op->label) {
602 $insn->{bblock}++;
603 $curloop->{contains_label}{$op->label}++ if $curloop; #TODO: should be within loop
604 }
605
606 } else {
607 if ($name eq "pushmark") {
608 $numpushmark++;
609 }
553 } 610 }
554 } 611 }
555 } 612 }
556 613
557 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops; 614 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
… …
559 local $source = <<EOF; 616 local $source = <<EOF;
560OP *%%%FUNC%%% (pTHX) 617OP *%%%FUNC%%% (pTHX)
561{ 618{
562 register OP *nextop = (OP *)${$ops[0]->{op}}L; 619 register OP *nextop = (OP *)${$ops[0]->{op}}L;
563EOF 620EOF
621
622 $source .= " faster_PUSHMARK_PREALLOC ($numpushmark);\n"
623 if $numpushmark;
564 624
565 while (@ops) { 625 while (@ops) {
566 $insn = shift @ops; 626 $insn = shift @ops;
567 627
568 $op = $insn->{op}; 628 $op = $insn->{op};
… …
631 691
632 $source 692 $source
633} 693}
634 694
635my $uid = "aaaaaaa0"; 695my $uid = "aaaaaaa0";
696my %so;
636 697
637sub source2ptr { 698sub func2ptr {
638 my (@source) = @_; 699 my (@func) = @_;
639 700
640 my $stem = "/tmp/Faster-$$-" . $uid++; 701 #LOCK
702 mkdir $CACHEDIR, 0777;
703 sysopen my $meta_fh, "$CACHEDIR/meta", &Fcntl::O_RDWR | &Fcntl::O_CREAT, 0666
704 or die "$$CACHEDIR/meta: $!";
705 binmode $meta_fh, ":raw:perlio";
706 fcntl_lock fileno $meta_fh
707 or die "$CACHEDIR/meta: $!";
641 708
709 my $meta = eval { Storable::fd_retrieve $meta_fh } || { version => 1 };
710
711 for my $f (@func) {
712 $f->{func} = "F" . Digest::MD5::md5_hex ($f->{source});
713 $f->{so} = $meta->{$f->{func}};
714 }
715
716 if (grep !$_->{so}, @func) {
717 my $stem;
718
719 do {
720 $stem = "$CACHEDIR/$$-" . $uid++;
721 } while -e "$stem$_so";
722
642 open FILE, ">:raw", "$stem.c"; 723 open my $fh, ">:raw", "$stem.c";
643 print FILE <<EOF; 724 print $fh <<EOF;
644#define PERL_NO_GET_CONTEXT 725#define PERL_NO_GET_CONTEXT
645#define PERL_CORE 726#define PERL_CORE
646 727
647#include <assert.h> 728#include <assert.h>
648 729
649#include "EXTERN.h" 730#include "EXTERN.h"
650#include "perl.h" 731#include "perl.h"
651#include "XSUB.h" 732#include "XSUB.h"
652 733
734#if 1
735# define faster_PUSHMARK_PREALLOC(count) while (PL_markstack_ptr + (count) >= PL_markstack_max) markstack_grow ()
736# define faster_PUSHMARK(p) *++PL_markstack_ptr = (p) - PL_stack_base
737#else
738# define faster_PUSHMARK_PREALLOC(count) 1
739# define faster_PUSHMARK(p) PUSHMARK(p)
740#endif
741
653#define RUNOPS_TILL(op) \\ 742#define RUNOPS_TILL(op) \\
654while (nextop != (op)) \\ 743 while (nextop != (op)) \\
655 { \\ 744 { \\
656 PERL_ASYNC_CHECK (); \\ 745 PERL_ASYNC_CHECK (); \\
657 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\ 746 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
658 }
659
660EOF
661 for (@source) {
662 my $func = $uid++;
663 $_ =~ s/%%%FUNC%%%/$func/g;
664 print FILE $_;
665 $_ = $func;
666 } 747 }
667 748
668 close FILE; 749EOF
750 for my $f (grep !$_->{so}, @func) {
751 next if $f->{so} = $meta->{$f->{func}}; # some cv's alias others
752
753 warn "compiling $f->{name} to $stem$_so:$f->{func}\n" if $verbose > 1;
754 my $source = $f->{source};
755 $source =~ s/%%%FUNC%%%/$f->{func}/g;
756 print $fh $source;
757 $meta->{$f->{func}} = $f->{so} = $stem;
758 }
759
760 close $fh;
669 system "$COMPILE -o $stem$_o $stem.c"; 761 system "$COMPILE -o $stem$_o $stem.c";
670 #d#unlink "$stem.c"; 762 unlink "$stem.c" unless $ENV{FASTER_DEBUG} & 1;
671 system "$LINK -o $stem$_so $stem$_o $LIBS"; 763 system "$LINK -o $stem$_so $stem$_o $LIBS";
672 unlink "$stem$_o"; 764 unlink "$stem$_o";
765 }
673 766
767 for my $f (@func) {
768 my $stem = $f->{so};
769
674 my $so = DynaLoader::dl_load_file "$stem$_so" 770 my $so = ($so{$stem} ||= DynaLoader::dl_load_file "$stem$_so")
675 or die "$stem$_so: $!"; 771 or die "$stem$_so: $!";
676 772
677 #unlink "$stem$_so"; 773 #unlink "$stem$_so";
678 774
679 map +(DynaLoader::dl_find_symbol $so, $_), @source 775 $f->{ptr} = DynaLoader::dl_find_symbol $so, $f->{func}
776 or die "$f->{func} not found in $stem$_so: $!";
777 }
778
779 seek $meta_fh, 0, 0 or die "$CACHEDIR/meta: $!";
780 Storable::nstore_fd $meta, $meta_fh;
781 truncate $meta_fh, tell $meta_fh;
782
783 # UNLOCK (by closing $meta_fh)
680} 784}
681 785
682my %ignore; 786my %ignore;
683 787
684sub entersub { 788sub entersub {
… …
686 790
687 my $pkg = $cv->STASH->NAME; 791 my $pkg = $cv->STASH->NAME;
688 792
689 return if $ignore{$pkg}; 793 return if $ignore{$pkg};
690 794
691 warn "compiling ", $cv->STASH->NAME, "\n" 795 warn "optimising ", $cv->STASH->NAME, "\n"
692 if $verbose; 796 if $verbose;
693 797
694 eval { 798 eval {
695 my @cv; 799 my @func;
696 my @cv_source; 800
801 push @func, {
802 cv => $cv,
803 name => "<>",
804 source => cv2c $cv,
805 };
697 806
698 # always compile the whole stash 807 # always compile the whole stash
699 my %stash = $cv->STASH->ARRAY; 808 my %stash = $cv->STASH->ARRAY;
700 while (my ($k, $v) = each %stash) { 809 while (my ($k, $v) = each %stash) {
701 $v->isa (B::GV::) 810 $v->isa (B::GV::)
… …
704 my $cv = $v->CV; 813 my $cv = $v->CV;
705 814
706 if ($cv->isa (B::CV::) 815 if ($cv->isa (B::CV::)
707 && ${$cv->START} 816 && ${$cv->START}
708 && $cv->START->name ne "null") { 817 && $cv->START->name ne "null") {
818
709 push @cv, $cv; 819 push @func, {
820 cv => $cv,
821 name => $k,
710 push @cv_source, cv2c $cv; 822 source => cv2c $cv,
823 };
711 } 824 }
712 } 825 }
713 826
714 my @ptr = source2ptr @cv_source; 827 func2ptr @func;
715 828
716 for (0 .. $#cv) { 829 for my $f (@func) {
717 patch_cv $cv[$_], $ptr[$_]; 830 patch_cv $f->{cv}, $f->{ptr};
718 } 831 }
719 }; 832 };
720 833
721 if ($@) { 834 if ($@) {
722 $ignore{$pkg}++; 835 $ignore{$pkg}++;
… …
737=over 4 850=over 4
738 851
739=item FASTER_VERBOSE 852=item FASTER_VERBOSE
740 853
741Faster will output more informational messages when set to values higher 854Faster will output more informational messages when set to values higher
742than C<0>. Currently, C<1> outputs which packages are being compiled. 855than C<0>. Currently, C<1> outputs which packages are being compiled, C<3>
856outputs the cache directory and C<10> outputs information on which perl
857function is compiled into which shared object.
743 858
744=item FASTER_DEBUG 859=item FASTER_DEBUG
745 860
746Add debugging code when set to values higher than C<0>. Currently, this 861Add debugging code when set to values higher than C<0>. Currently, this
747adds 1-3 C<assert>'s per perl op, to ensure that opcode order and C 862adds 1-3 C<assert>'s per perl op (FASTER_DEBUG > 1), to ensure that opcode
748execution order are compatible. 863order and C execution order are compatible.
749 864
750=item FASTER_CACHE 865=item FASTER_CACHE
751 866
752NOT YET IMPLEMENTED
753
754Set a persistent cache directory that caches compiled code 867Set a persistent cache directory that caches compiled code fragments. The
755fragments. Normally, code compiled by Faster will be deleted immediately, 868default is C<$HOME/.perl-faster-cache> if C<HOME> is set and a temporary
756and every restart will recompile everything. Setting this variable to a 869directory otherwise.
757directory makes Faster cache the generated files for re-use.
758 870
759This directory will always grow in contents, so you might need to erase it 871This directory will always grow in size, so you might need to erase it
760from time to time. 872from time to time.
761 873
762=back 874=back
763 875
764=head1 BUGS/LIMITATIONS 876=head1 BUGS/LIMITATIONS
… …
780These constructs will force the use of the interpreter for the currently 892These constructs will force the use of the interpreter for the currently
781executed function as soon as they are being encountered during execution. 893executed function as soon as they are being encountered during execution.
782 894
783 goto 895 goto
784 next, redo (but not well-behaved last's) 896 next, redo (but not well-behaved last's)
897 labels, if used
785 eval 898 eval
786 require 899 require
787 any use of formats 900 any use of formats
788 .., ... (flipflop operators) 901 .., ... (flipflop operators)
789 902

Diff Legend

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