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

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

Diff Legend

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