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.30 by root, Mon Mar 13 16:59:36 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};
… …
61 71
62# we don't need no steenking PIC on x86 72# we don't need no steenking PIC on x86
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} > 1;
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;
… …
133# ops that do not need an ASYNC_CHECK 145# ops that do not need an ASYNC_CHECK
134my %f_noasync = map +($_ => undef), qw( 146my %f_noasync = map +($_ => undef), qw(
135 mapstart grepstart match entereval 147 mapstart grepstart match entereval
136 enteriter entersub leaveloop 148 enteriter entersub leaveloop
137 149
138 pushmark nextstate 150 pushmark nextstate caller
139 151
140 const stub unstack 152 const stub unstack
141 last next redo seq 153 last next redo goto seq
142 padsv padav padhv padany 154 padsv padav padhv padany
143 aassign sassign orassign 155 aassign sassign orassign
144 rv2av rv2cv rv2gv rv2hv refgen 156 rv2av rv2cv rv2gv rv2hv refgen
145 gv gvsv 157 gv gvsv
146 add subtract multiply divide 158 add subtract multiply divide
147 complement cond_expr and or not 159 complement cond_expr and or not bit_and bit_or bit_xor
148 defined 160 defined
149 method method_named bless 161 method method_named bless
150 preinc postinc predec postdec 162 preinc postinc predec postdec
151 aelem aelemfast helem delete exists 163 aelem aelemfast helem delete exists
152 pushre subst list join split concat 164 pushre subst list lslice join split concat
153 length substr stringify ord 165 length substr stringify ord
154 push pop shift unshift 166 push pop shift unshift
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)"
… …
213 225
214 out_next; 226 out_next;
215} 227}
216 228
217sub op_pushmark { 229sub op_pushmark {
218 $source .= " PUSHMARK (PL_stack_sp);\n"; 230 $source .= " faster_PUSHMARK (PL_stack_sp);\n";
219 231
220 out_next; 232 out_next;
221} 233}
222 234
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 {
… …
484 local %op_regcomp; 515 local %op_regcomp;
485 516
486 my %opsseen; 517 my %opsseen;
487 my @todo = $cv->START; 518 my @todo = $cv->START;
488 my %op_target; 519 my %op_target;
520 my $numpushmark;
489 521
490 while (my $op = shift @todo) { 522 while (my $op = shift @todo) {
491 for (; $$op; $op = $op->next) { 523 for (; $$op; $op = $op->next) {
492 last if $opsseen{$$op}++; 524 last if $opsseen{$$op}++;
493 525
… …
527 559
528 push @op_loop, \@targ; 560 push @op_loop, \@targ;
529 push @todo, @targ; 561 push @todo, @targ;
530 562
531 $op_target{$$_}++ for @targ; 563 $op_target{$$_}++ for @targ;
564
532 } elsif ($class eq "COP") { 565 } elsif ($class eq "COP") {
533 $insn->{bblock}++ if defined $op->label; 566 $insn->{bblock}++ if defined $op->label;
567
568 } else {
569 if ($name eq "pushmark") {
570 $numpushmark++;
571 }
534 } 572 }
535 } 573 }
536 } 574 }
537 575
538 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops; 576 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
… …
540 local $source = <<EOF; 578 local $source = <<EOF;
541OP *%%%FUNC%%% (pTHX) 579OP *%%%FUNC%%% (pTHX)
542{ 580{
543 register OP *nextop = (OP *)${$ops[0]->{op}}L; 581 register OP *nextop = (OP *)${$ops[0]->{op}}L;
544EOF 582EOF
583
584 $source .= " faster_PUSHMARK_PREALLOC ($numpushmark);\n"
585 if $numpushmark;
545 586
546 while (@ops) { 587 while (@ops) {
547 $insn = shift @ops; 588 $insn = shift @ops;
548 589
549 $op = $insn->{op}; 590 $op = $insn->{op};
… …
612 653
613 $source 654 $source
614} 655}
615 656
616my $uid = "aaaaaaa0"; 657my $uid = "aaaaaaa0";
658my %so;
617 659
618sub source2ptr { 660sub func2ptr {
619 my (@source) = @_; 661 my (@func) = @_;
620 662
621 my $stem = "/tmp/Faster-$$-" . $uid++; 663 #LOCK
664 mkdir $CACHEDIR, 0777;
665 sysopen my $meta_fh, "$CACHEDIR/meta", &Fcntl::O_RDWR | &Fcntl::O_CREAT, 0666
666 or die "$$CACHEDIR/meta: $!";
667 binmode $meta_fh, ":raw:perlio";
668 fcntl_lock fileno $meta_fh
669 or die "$CACHEDIR/meta: $!";
622 670
671 my $meta = eval { Storable::fd_retrieve $meta_fh } || { version => 1 };
672
673 for my $f (@func) {
674 $f->{func} = "F" . Digest::MD5::md5_hex ($f->{source});
675 $f->{so} = $meta->{$f->{func}};
676 }
677
678 if (grep !$_->{so}, @func) {
679 my $stem;
680
681 do {
682 $stem = "$CACHEDIR/$$-" . $uid++;
683 } while -e "$stem$_so";
684
623 open FILE, ">:raw", "$stem.c"; 685 open my $fh, ">:raw", "$stem.c";
624 print FILE <<EOF; 686 print $fh <<EOF;
625#define PERL_NO_GET_CONTEXT 687#define PERL_NO_GET_CONTEXT
626#define PERL_CORE 688#define PERL_CORE
627 689
628#include <assert.h> 690#include <assert.h>
629 691
630#include "EXTERN.h" 692#include "EXTERN.h"
631#include "perl.h" 693#include "perl.h"
632#include "XSUB.h" 694#include "XSUB.h"
633 695
696#if 1
697# define faster_PUSHMARK_PREALLOC(count) while (PL_markstack_ptr + (count) >= PL_markstack_max) markstack_grow ()
698# define faster_PUSHMARK(p) *++PL_markstack_ptr = (p) - PL_stack_base
699#else
700# define faster_PUSHMARK_PREALLOC(count) 1
701# define faster_PUSHMARK(p) PUSHMARK(p)
702#endif
703
634#define RUNOPS_TILL(op) \\ 704#define RUNOPS_TILL(op) \\
635while (nextop != (op)) \\ 705 while (nextop != (op)) \\
636 { \\ 706 { \\
637 PERL_ASYNC_CHECK (); \\ 707 PERL_ASYNC_CHECK (); \\
638 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\ 708 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 } 709 }
648 710
649 close FILE; 711EOF
712 for my $f (grep !$_->{so}, @func) {
713 next if $f->{so} = $meta->{$f->{func}}; # some cv's alias others
714
715 warn "compiling $f->{name} to $stem$_so:$f->{func}\n" if $verbose > 1;
716 my $source = $f->{source};
717 $source =~ s/%%%FUNC%%%/$f->{func}/g;
718 print $fh $source;
719 $meta->{$f->{func}} = $f->{so} = $stem;
720 }
721
722 close $fh;
650 system "$COMPILE -o $stem$_o $stem.c"; 723 system "$COMPILE -o $stem$_o $stem.c";
651 #d#unlink "$stem.c"; 724 unlink "$stem.c" unless $ENV{FASTER_DEBUG} > 0;
652 system "$LINK -o $stem$_so $stem$_o $LIBS"; 725 system "$LINK -o $stem$_so $stem$_o $LIBS";
653 unlink "$stem$_o"; 726 unlink "$stem$_o";
727 }
654 728
729 for my $f (@func) {
730 my $stem = $f->{so};
731
655 my $so = DynaLoader::dl_load_file "$stem$_so" 732 my $so = ($so{$stem} ||= DynaLoader::dl_load_file "$stem$_so")
656 or die "$stem$_so: $!"; 733 or die "$stem$_so: $!";
657 734
658 #unlink "$stem$_so"; 735 #unlink "$stem$_so";
659 736
660 map +(DynaLoader::dl_find_symbol $so, $_), @source 737 $f->{ptr} = DynaLoader::dl_find_symbol $so, $f->{func}
738 or die "$f->{func} not found in $stem$_so: $!";
739 }
740
741 seek $meta_fh, 0, 0 or die "$CACHEDIR/meta: $!";
742 Storable::nstore_fd $meta, $meta_fh;
743 truncate $meta_fh, tell $meta_fh;
744
745 # UNLOCK (by closing $meta_fh)
661} 746}
662 747
663my %ignore; 748my %ignore;
664 749
665sub entersub { 750sub entersub {
… …
667 752
668 my $pkg = $cv->STASH->NAME; 753 my $pkg = $cv->STASH->NAME;
669 754
670 return if $ignore{$pkg}; 755 return if $ignore{$pkg};
671 756
672 warn "compiling ", $cv->STASH->NAME, "\n" 757 warn "optimising ", $cv->STASH->NAME, "\n"
673 if $verbose; 758 if $verbose;
674 759
675 eval { 760 eval {
676 my @cv; 761 my @func;
677 my @cv_source; 762
763 push @func, {
764 cv => $cv,
765 name => "<>",
766 source => cv2c $cv,
767 };
678 768
679 # always compile the whole stash 769 # always compile the whole stash
680 my %stash = $cv->STASH->ARRAY; 770 my %stash = $cv->STASH->ARRAY;
681 while (my ($k, $v) = each %stash) { 771 while (my ($k, $v) = each %stash) {
682 $v->isa (B::GV::) 772 $v->isa (B::GV::)
… …
685 my $cv = $v->CV; 775 my $cv = $v->CV;
686 776
687 if ($cv->isa (B::CV::) 777 if ($cv->isa (B::CV::)
688 && ${$cv->START} 778 && ${$cv->START}
689 && $cv->START->name ne "null") { 779 && $cv->START->name ne "null") {
780
690 push @cv, $cv; 781 push @func, {
782 cv => $cv,
783 name => $k,
691 push @cv_source, cv2c $cv; 784 source => cv2c $cv,
785 };
692 } 786 }
693 } 787 }
694 788
695 my @ptr = source2ptr @cv_source; 789 func2ptr @func;
696 790
697 for (0 .. $#cv) { 791 for my $f (@func) {
698 patch_cv $cv[$_], $ptr[$_]; 792 patch_cv $f->{cv}, $f->{ptr};
699 } 793 }
700 }; 794 };
701 795
702 if ($@) { 796 if ($@) {
703 $ignore{$pkg}++; 797 $ignore{$pkg}++;
… …
718=over 4 812=over 4
719 813
720=item FASTER_VERBOSE 814=item FASTER_VERBOSE
721 815
722Faster will output more informational messages when set to values higher 816Faster will output more informational messages when set to values higher
723than C<0>. Currently, C<1> outputs which packages are being compiled. 817than C<0>. Currently, C<1> outputs which packages are being compiled, C<3>
818outputs the cache directory and C<10> outputs information on which perl
819function is compiled into which shared object.
724 820
725=item FASTER_DEBUG 821=item FASTER_DEBUG
726 822
727Add debugging code when set to values higher than C<0>. Currently, this 823Add 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 824adds 1-3 C<assert>'s per perl op (FASTER_DEBUG > 1), to ensure that opcode
729execution order are compatible. 825order and C execution order are compatible.
730 826
731=item FASTER_CACHE 827=item FASTER_CACHE
732 828
733NOT YET IMPLEMENTED
734
735Set a persistent cache directory that caches compiled code 829Set a persistent cache directory that caches compiled code fragments. The
736fragments. Normally, code compiled by Faster will be deleted immediately, 830default 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 831directory otherwise.
738directory makes Faster cache the generated files for re-use.
739 832
740This directory will always grow in contents, so you might need to erase it 833This directory will always grow in size, so you might need to erase it
741from time to time. 834from time to time.
742 835
743=back 836=back
744 837
745=head1 BUGS/LIMITATIONS 838=head1 BUGS/LIMITATIONS

Diff Legend

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