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.29 by root, Sun Mar 12 21:36:00 2006 UTC

… …
26 26
27Usage is very easy, just C<use Faster> and every function called from then 27Usage is very easy, just C<use Faster> and every function called from then
28on will be compiled. 28on will be compiled.
29 29
30Right now, Faster will leave lots of F<*.c>, F<*.o> and F<*.so> files in 30Right now, Faster will leave lots of F<*.c>, F<*.o> and F<*.so> files in
31your F<$FASTER_CACHEDIR> (by default F<$HOME/.perl-faster-cache>), and it
31F</tmp>, and it will even create those temporary files in an insecure 32will even create those temporary files in an insecure manner, so watch
32manner, so watch out. 33out.
33 34
34=over 4 35=over 4
35 36
36=cut 37=cut
37 38
… …
40no warnings; 41no warnings;
41 42
42use strict; 43use strict;
43use Config; 44use Config;
44use B (); 45use B ();
45#use Digest::MD5 ();
46use DynaLoader (); 46use DynaLoader ();
47use File::Temp (); 47use Digest::MD5 ();
48use Storable ();
49use Fcntl ();
48 50
49BEGIN { 51BEGIN {
50 our $VERSION = '0.01'; 52 our $VERSION = '0.01';
51 53
52 require XSLoader; 54 require XSLoader;
53 XSLoader::load __PACKAGE__, $VERSION; 55 XSLoader::load __PACKAGE__, $VERSION;
54} 56}
57
58my $CACHEDIR =
59 $ENV{FASTER_CACHE}
60 || (exists $ENV{HOME} && "$ENV{HOME}/.perl-faster-cache")
61 || do {
62 require File::Temp;
63 File::Temp::tempdir (CLEANUP => 1)
64 };
55 65
56my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}"; 66my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}";
57my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}"; 67my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
58my $LIBS = "$Config{libs}"; 68my $LIBS = "$Config{libs}";
59my $_o = $Config{_o}; 69my $_o = $Config{_o};
… …
63$COMPILE =~ s/-f(?:PIC|pic)//g 73$COMPILE =~ s/-f(?:PIC|pic)//g
64 if $Config{archname} =~ /^(i[3456]86)-/; 74 if $Config{archname} =~ /^(i[3456]86)-/;
65 75
66my $opt_assert = $ENV{FASTER_DEBUG}; 76my $opt_assert = $ENV{FASTER_DEBUG};
67my $verbose = $ENV{FASTER_VERBOSE}+0; 77my $verbose = $ENV{FASTER_VERBOSE}+0;
78
79warn "Faster: CACHEDIR is $CACHEDIR\n" if $verbose > 2;
68 80
69our $source; 81our $source;
70 82
71our @ops; 83our @ops;
72our $insn; 84our $insn;
… …
352 PUSHs (sv); 364 PUSHs (sv);
353 PUTBACK; 365 PUTBACK;
354EOF 366EOF
355 367
356 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) { 368 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
357 $source .= " vivify_ref (sv, " . $op->private . " & OPpDEREF);\n"; 369 $source .= " if (!SvROK (sv)) vivify_ref (sv, " . $op->private . " & OPpDEREF);\n";
358 } 370 }
359 $source .= " }\n"; 371 $source .= " }\n";
360 372
361 out_next; 373 out_next;
362} 374}
… …
631 643
632 $source 644 $source
633} 645}
634 646
635my $uid = "aaaaaaa0"; 647my $uid = "aaaaaaa0";
648my %so;
636 649
637sub source2ptr { 650sub func2ptr {
638 my (@source) = @_; 651 my (@func) = @_;
639 652
640 my $stem = "/tmp/Faster-$$-" . $uid++; 653 #LOCK
654 mkdir $CACHEDIR, 0777;
655 sysopen my $meta_fh, "$CACHEDIR/meta", &Fcntl::O_RDWR | &Fcntl::O_CREAT, 0666
656 or die "$$CACHEDIR/meta: $!";
657 binmode $meta_fh, ":raw:perlio";
658 fcntl_lock fileno $meta_fh
659 or die "$CACHEDIR/meta: $!";
641 660
661 my $meta = eval { Storable::fd_retrieve $meta_fh } || { version => 1 };
662
663 for my $f (@func) {
664 $f->{func} = "F" . Digest::MD5::md5_hex ($f->{source});
665 $f->{so} = $meta->{$f->{func}};
666 }
667
668 if (grep !$_->{so}, @func) {
669 my $stem;
670
671 do {
672 $stem = "$CACHEDIR/$$-" . $uid++;
673 } while -e "$stem$_so";
674
642 open FILE, ">:raw", "$stem.c"; 675 open my $fh, ">:raw", "$stem.c";
643 print FILE <<EOF; 676 print $fh <<EOF;
644#define PERL_NO_GET_CONTEXT 677#define PERL_NO_GET_CONTEXT
645#define PERL_CORE 678#define PERL_CORE
646 679
647#include <assert.h> 680#include <assert.h>
648 681
649#include "EXTERN.h" 682#include "EXTERN.h"
650#include "perl.h" 683#include "perl.h"
651#include "XSUB.h" 684#include "XSUB.h"
652 685
653#define RUNOPS_TILL(op) \\ 686#define RUNOPS_TILL(op) \\
654while (nextop != (op)) \\ 687 while (nextop != (op)) \\
655 { \\ 688 { \\
656 PERL_ASYNC_CHECK (); \\ 689 PERL_ASYNC_CHECK (); \\
657 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\ 690 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 } 691 }
667 692
668 close FILE; 693EOF
694 for my $f (grep !$_->{so}, @func) {
695 next if $f->{so} = $meta->{$f->{func}}; # some cv's alias others
696
697 warn "compiling $f->{name} to $stem$_so:$f->{func}\n" if $verbose > 1;
698 my $source = $f->{source};
699 $source =~ s/%%%FUNC%%%/$f->{func}/g;
700 print $fh $source;
701 $meta->{$f->{func}} = $f->{so} = $stem;
702 }
703
704 close $fh;
669 system "$COMPILE -o $stem$_o $stem.c"; 705 system "$COMPILE -o $stem$_o $stem.c";
670 #d#unlink "$stem.c"; 706 unlink "$stem.c";
671 system "$LINK -o $stem$_so $stem$_o $LIBS"; 707 system "$LINK -o $stem$_so $stem$_o $LIBS";
672 unlink "$stem$_o"; 708 unlink "$stem$_o";
709 }
673 710
711 for my $f (@func) {
712 my $stem = $f->{so};
713
674 my $so = DynaLoader::dl_load_file "$stem$_so" 714 my $so = ($so{$stem} ||= DynaLoader::dl_load_file "$stem$_so")
675 or die "$stem$_so: $!"; 715 or die "$stem$_so: $!";
676 716
677 #unlink "$stem$_so"; 717 #unlink "$stem$_so";
678 718
679 map +(DynaLoader::dl_find_symbol $so, $_), @source 719 $f->{ptr} = DynaLoader::dl_find_symbol $so, $f->{func}
720 or die "$f->{func} not found in $stem$_so: $!";
721 }
722
723 seek $meta_fh, 0, 0 or die "$CACHEDIR/meta: $!";
724 Storable::nstore_fd $meta, $meta_fh;
725 truncate $meta_fh, tell $meta_fh;
726
727 # UNLOCK (by closing $meta_fh)
680} 728}
681 729
682my %ignore; 730my %ignore;
683 731
684sub entersub { 732sub entersub {
… …
686 734
687 my $pkg = $cv->STASH->NAME; 735 my $pkg = $cv->STASH->NAME;
688 736
689 return if $ignore{$pkg}; 737 return if $ignore{$pkg};
690 738
691 warn "compiling ", $cv->STASH->NAME, "\n" 739 warn "optimising ", $cv->STASH->NAME, "\n"
692 if $verbose; 740 if $verbose;
693 741
694 eval { 742 eval {
695 my @cv; 743 my @func;
696 my @cv_source; 744
745 push @func, {
746 cv => $cv,
747 name => "<>",
748 source => cv2c $cv,
749 };
697 750
698 # always compile the whole stash 751 # always compile the whole stash
699 my %stash = $cv->STASH->ARRAY; 752 my %stash = $cv->STASH->ARRAY;
700 while (my ($k, $v) = each %stash) { 753 while (my ($k, $v) = each %stash) {
701 $v->isa (B::GV::) 754 $v->isa (B::GV::)
… …
704 my $cv = $v->CV; 757 my $cv = $v->CV;
705 758
706 if ($cv->isa (B::CV::) 759 if ($cv->isa (B::CV::)
707 && ${$cv->START} 760 && ${$cv->START}
708 && $cv->START->name ne "null") { 761 && $cv->START->name ne "null") {
762
709 push @cv, $cv; 763 push @func, {
764 cv => $cv,
765 name => $k,
710 push @cv_source, cv2c $cv; 766 source => cv2c $cv,
767 };
711 } 768 }
712 } 769 }
713 770
714 my @ptr = source2ptr @cv_source; 771 func2ptr @func;
715 772
716 for (0 .. $#cv) { 773 for my $f (@func) {
717 patch_cv $cv[$_], $ptr[$_]; 774 patch_cv $f->{cv}, $f->{ptr};
718 } 775 }
719 }; 776 };
720 777
721 if ($@) { 778 if ($@) {
722 $ignore{$pkg}++; 779 $ignore{$pkg}++;
… …
737=over 4 794=over 4
738 795
739=item FASTER_VERBOSE 796=item FASTER_VERBOSE
740 797
741Faster will output more informational messages when set to values higher 798Faster will output more informational messages when set to values higher
742than C<0>. Currently, C<1> outputs which packages are being compiled. 799than C<0>. Currently, C<1> outputs which packages are being compiled, C<3>
800outputs the cache directory and C<10> outputs information on which perl
801function is compiled into which shared object.
743 802
744=item FASTER_DEBUG 803=item FASTER_DEBUG
745 804
746Add debugging code when set to values higher than C<0>. Currently, this 805Add 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 806adds 1-3 C<assert>'s per perl op, to ensure that opcode order and C
748execution order are compatible. 807execution order are compatible.
749 808
750=item FASTER_CACHE 809=item FASTER_CACHE
751 810
752NOT YET IMPLEMENTED
753
754Set a persistent cache directory that caches compiled code 811Set a persistent cache directory that caches compiled code fragments. The
755fragments. Normally, code compiled by Faster will be deleted immediately, 812default 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 813directory otherwise.
757directory makes Faster cache the generated files for re-use.
758 814
759This directory will always grow in contents, so you might need to erase it 815This directory will always grow in size, so you might need to erase it
760from time to time. 816from time to time.
761 817
762=back 818=back
763 819
764=head1 BUGS/LIMITATIONS 820=head1 BUGS/LIMITATIONS

Diff Legend

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