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

Comparing Faster/Faster.pm (file contents):
Revision 1.25 by root, Sat Mar 11 04:58:53 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;
… …
155 eq ne gt lt ge le 167 eq ne gt lt ge le
156 regcomp regcreset regcmaybe 168 regcomp regcreset regcmaybe
157); 169);
158 170
159my %callop = ( 171my %callop = (
160 entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)", 172 entersub => "(PL_op->op_ppaddr) (aTHX)",
161 mapstart => "Perl_pp_grepstart (aTHX)", 173 mapstart => "Perl_pp_grepstart (aTHX)",
162); 174);
163 175
164sub callop { 176sub callop {
165 $callop{$op_name} || "Perl_pp_$op_name (aTHX)" 177 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
… …
223if ($Config{useithreads} ne "define") { 235if ($Config{useithreads} ne "define") {
224 # disable optimisations on ithreads 236 # disable optimisations on ithreads
225 237
226 *op_const = sub { 238 *op_const = sub {
227 $source .= " { dSP; PUSHs ((SV *)${$op->sv}L); PUTBACK; }\n"; 239 $source .= " { dSP; PUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
240
241 $ops[0]{follows_const}++ if @ops;#d#
228 242
229 out_next; 243 out_next;
230 }; 244 };
231 245
232 *op_gv = \&op_const; 246 *op_gv = \&op_const;
… …
333 347
334sub op_padsv { 348sub op_padsv {
335 my $flags = $op->flags; 349 my $flags = $op->flags;
336 my $padofs = "(PADOFFSET)" . $op->targ; 350 my $padofs = "(PADOFFSET)" . $op->targ;
337 351
338 #d#TODO: why does our version break
339 # breaks gce with can't coerce array....
340 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {#d#
341 return out_linear;#d#
342 }#d#
343
344 $source .= <<EOF; 352 $source .= <<EOF;
345 { 353 {
346 dSP; 354 dSP;
347 SV *sv = PAD_SVl ($padofs); 355 SV *sv = PAD_SVl ($padofs);
348EOF 356EOF
349 357
350 if (($flags & B::OPf_MOD) && ($op->private & B::OPpLVAL_INTRO)) { 358 if (($flags & B::OPf_MOD) && ($op->private & B::OPpLVAL_INTRO)) {
351 $source .= " SAVECLEARSV (PAD_SVl ($padofs));\n"; 359 $source .= " SAVECLEARSV (PAD_SVl ($padofs));\n";
352 $ops[0]{pre_padsv_lval_intro}++ if @ops;#d# 360 $ops[0]{follows_padsv_lval_intro}++ if @ops;#d#
353 } 361 }
354 362
355 $source .= <<EOF; 363 $source .= <<EOF;
356 PUSHs (sv); 364 PUSHs (sv);
357 PUTBACK; 365 PUTBACK;
358EOF 366EOF
359 367
360 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) { 368 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
361 $source .= " vivify_ref (sv, $flags & OPpDEREF);\n"; 369 $source .= " if (!SvROK (sv)) vivify_ref (sv, " . $op->private . " & OPpDEREF);\n";
362 } 370 }
363 $source .= " }\n"; 371 $source .= " }\n";
364 372
365 out_next; 373 out_next;
366} 374}
… …
372 dPOPTOPssrl; 380 dPOPTOPssrl;
373EOF 381EOF
374 $source .= " SV *temp = left; left = right; right = temp;\n" 382 $source .= " SV *temp = left; left = right; right = temp;\n"
375 if $op->private & B::OPpASSIGN_BACKWARDS; 383 if $op->private & B::OPpASSIGN_BACKWARDS;
376 384
377 if ($insn->{pre_padsv_lval_intro} && !($op->private & B::OPpASSIGN_BACKWARDS)) { 385 if ($insn->{follows_padsv_lval_intro} && !($op->private & B::OPpASSIGN_BACKWARDS)) {
378 # simple assignment - the target exists, but is basically undef 386 # simple assignment - the target exists, but is basically undef
379 $source .= " SvSetSV (right, left);\n"; 387 $source .= " SvSetSV (right, left);\n";
380 } else { 388 } else {
381 $source .= " SvSetMagicSV (right, left);\n"; 389 $source .= " SvSetMagicSV (right, left);\n";
382 } 390 }
… …
389 397
390 out_next; 398 out_next;
391} 399}
392 400
393# pattern const+ (or general push1) 401# pattern const+ (or general push1)
394# pattern pushmark return(?)
395# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 402# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
396 403
397# pattern const method_named
398sub op_method_named { 404sub op_method_named {
405 if ($insn->{follows_const}) {
399 $source .= <<EOF; 406 $source .= <<EOF;
407 {
408 dSP;
409 static SV *last_cv;
410 static U32 last_sub_generation;
411
412 /* simple "polymorphic" inline cache */
413 if (PL_sub_generation == last_sub_generation)
414 {
415 PUSHs (last_cv);
416 PUTBACK;
417 }
418 else
419 {
420 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
421
422 SPAGAIN;
423 last_sub_generation = PL_sub_generation;
424 last_cv = TOPs;
425 }
426 }
427EOF
428 } else {
429 $source .= <<EOF;
400 { 430 {
401 static HV *last_stash; 431 static HV *last_stash;
402 static SV *last_cv; 432 static SV *last_cv;
403 static U32 last_sub_generation; 433 static U32 last_sub_generation;
404 434
… …
431 /* error case usually */ 461 /* error case usually */
432 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 462 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
433 } 463 }
434 } 464 }
435EOF 465EOF
466 }
436 467
437 out_next; 468 out_next;
438} 469}
439 470
440sub op_grepstart { 471sub op_grepstart {
… …
612 643
613 $source 644 $source
614} 645}
615 646
616my $uid = "aaaaaaa0"; 647my $uid = "aaaaaaa0";
648my %so;
617 649
618sub source2ptr { 650sub func2ptr {
619 my (@source) = @_; 651 my (@func) = @_;
620 652
621 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: $!";
622 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
623 open FILE, ">:raw", "$stem.c"; 675 open my $fh, ">:raw", "$stem.c";
624 print FILE <<EOF; 676 print $fh <<EOF;
625#define PERL_NO_GET_CONTEXT 677#define PERL_NO_GET_CONTEXT
626#define PERL_CORE 678#define PERL_CORE
627 679
628#include <assert.h> 680#include <assert.h>
629 681
630#include "EXTERN.h" 682#include "EXTERN.h"
631#include "perl.h" 683#include "perl.h"
632#include "XSUB.h" 684#include "XSUB.h"
633 685
634#define RUNOPS_TILL(op) \\ 686#define RUNOPS_TILL(op) \\
635while (nextop != (op)) \\ 687 while (nextop != (op)) \\
636 { \\ 688 { \\
637 PERL_ASYNC_CHECK (); \\ 689 PERL_ASYNC_CHECK (); \\
638 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\ 690 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
639 }
640
641EOF
642 for (@source) {
643 my $func = $uid++;
644 $_ =~ s/%%%FUNC%%%/$func/g;
645 print FILE $_;
646 $_ = $func;
647 } 691 }
648 692
649 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;
650 system "$COMPILE -o $stem$_o $stem.c"; 705 system "$COMPILE -o $stem$_o $stem.c";
651 #d#unlink "$stem.c"; 706 unlink "$stem.c";
652 system "$LINK -o $stem$_so $stem$_o $LIBS"; 707 system "$LINK -o $stem$_so $stem$_o $LIBS";
653 unlink "$stem$_o"; 708 unlink "$stem$_o";
709 }
654 710
711 for my $f (@func) {
712 my $stem = $f->{so};
713
655 my $so = DynaLoader::dl_load_file "$stem$_so" 714 my $so = ($so{$stem} ||= DynaLoader::dl_load_file "$stem$_so")
656 or die "$stem$_so: $!"; 715 or die "$stem$_so: $!";
657 716
658 #unlink "$stem$_so"; 717 #unlink "$stem$_so";
659 718
660 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)
661} 728}
662 729
663my %ignore; 730my %ignore;
664 731
665sub entersub { 732sub entersub {
… …
667 734
668 my $pkg = $cv->STASH->NAME; 735 my $pkg = $cv->STASH->NAME;
669 736
670 return if $ignore{$pkg}; 737 return if $ignore{$pkg};
671 738
672 warn "compiling ", $cv->STASH->NAME, "\n" 739 warn "optimising ", $cv->STASH->NAME, "\n"
673 if $verbose; 740 if $verbose;
674 741
675 eval { 742 eval {
676 my @cv; 743 my @func;
677 my @cv_source; 744
745 push @func, {
746 cv => $cv,
747 name => "<>",
748 source => cv2c $cv,
749 };
678 750
679 # always compile the whole stash 751 # always compile the whole stash
680 my %stash = $cv->STASH->ARRAY; 752 my %stash = $cv->STASH->ARRAY;
681 while (my ($k, $v) = each %stash) { 753 while (my ($k, $v) = each %stash) {
682 $v->isa (B::GV::) 754 $v->isa (B::GV::)
… …
685 my $cv = $v->CV; 757 my $cv = $v->CV;
686 758
687 if ($cv->isa (B::CV::) 759 if ($cv->isa (B::CV::)
688 && ${$cv->START} 760 && ${$cv->START}
689 && $cv->START->name ne "null") { 761 && $cv->START->name ne "null") {
762
690 push @cv, $cv; 763 push @func, {
764 cv => $cv,
765 name => $k,
691 push @cv_source, cv2c $cv; 766 source => cv2c $cv,
767 };
692 } 768 }
693 } 769 }
694 770
695 my @ptr = source2ptr @cv_source; 771 func2ptr @func;
696 772
697 for (0 .. $#cv) { 773 for my $f (@func) {
698 patch_cv $cv[$_], $ptr[$_]; 774 patch_cv $f->{cv}, $f->{ptr};
699 } 775 }
700 }; 776 };
701 777
702 if ($@) { 778 if ($@) {
703 $ignore{$pkg}++; 779 $ignore{$pkg}++;
… …
718=over 4 794=over 4
719 795
720=item FASTER_VERBOSE 796=item FASTER_VERBOSE
721 797
722Faster will output more informational messages when set to values higher 798Faster will output more informational messages when set to values higher
723than 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.
724 802
725=item FASTER_DEBUG 803=item FASTER_DEBUG
726 804
727Add 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
728adds 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
729execution order are compatible. 807execution order are compatible.
730 808
731=item FASTER_CACHE 809=item FASTER_CACHE
732 810
733NOT YET IMPLEMENTED
734
735Set a persistent cache directory that caches compiled code 811Set a persistent cache directory that caches compiled code fragments. The
736fragments. Normally, code compiled by Faster will be deleted immediately, 812default is C<$HOME/.perl-faster-cache> if C<HOME> is set and a temporary
737and every restart will recompile everything. Setting this variable to a 813directory otherwise.
738directory makes Faster cache the generated files for re-use.
739 814
740This 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
741from time to time. 816from time to time.
742 817
743=back 818=back
744 819
745=head1 BUGS/LIMITATIONS 820=head1 BUGS/LIMITATIONS

Diff Legend

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