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.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 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 {
… …
483 local %op_regcomp; 515 local %op_regcomp;
484 516
485 my %opsseen; 517 my %opsseen;
486 my @todo = $cv->START; 518 my @todo = $cv->START;
487 my %op_target; 519 my %op_target;
520 my $numpushmark;
488 521
489 while (my $op = shift @todo) { 522 while (my $op = shift @todo) {
490 for (; $$op; $op = $op->next) { 523 for (; $$op; $op = $op->next) {
491 last if $opsseen{$$op}++; 524 last if $opsseen{$$op}++;
492 525
… …
526 559
527 push @op_loop, \@targ; 560 push @op_loop, \@targ;
528 push @todo, @targ; 561 push @todo, @targ;
529 562
530 $op_target{$$_}++ for @targ; 563 $op_target{$$_}++ for @targ;
564
531 } elsif ($class eq "COP") { 565 } elsif ($class eq "COP") {
532 $insn->{bblock}++ if defined $op->label; 566 $insn->{bblock}++ if defined $op->label;
567
568 } else {
569 if ($name eq "pushmark") {
570 $numpushmark++;
571 }
533 } 572 }
534 } 573 }
535 } 574 }
536 575
537 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops; 576 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
… …
539 local $source = <<EOF; 578 local $source = <<EOF;
540OP *%%%FUNC%%% (pTHX) 579OP *%%%FUNC%%% (pTHX)
541{ 580{
542 register OP *nextop = (OP *)${$ops[0]->{op}}L; 581 register OP *nextop = (OP *)${$ops[0]->{op}}L;
543EOF 582EOF
583
584 $source .= " faster_PUSHMARK_PREALLOC ($numpushmark);\n"
585 if $numpushmark;
544 586
545 while (@ops) { 587 while (@ops) {
546 $insn = shift @ops; 588 $insn = shift @ops;
547 589
548 $op = $insn->{op}; 590 $op = $insn->{op};
… …
611 653
612 $source 654 $source
613} 655}
614 656
615my $uid = "aaaaaaa0"; 657my $uid = "aaaaaaa0";
658my %so;
616 659
617sub source2ptr { 660sub func2ptr {
618 my (@source) = @_; 661 my (@func) = @_;
619 662
620 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: $!";
621 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
622 open FILE, ">:raw", "$stem.c"; 685 open my $fh, ">:raw", "$stem.c";
623 print FILE <<EOF; 686 print $fh <<EOF;
624#define PERL_NO_GET_CONTEXT 687#define PERL_NO_GET_CONTEXT
625#define PERL_CORE 688#define PERL_CORE
626 689
627#include <assert.h> 690#include <assert.h>
628 691
629#include "EXTERN.h" 692#include "EXTERN.h"
630#include "perl.h" 693#include "perl.h"
631#include "XSUB.h" 694#include "XSUB.h"
632 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
633#define RUNOPS_TILL(op) \\ 704#define RUNOPS_TILL(op) \\
634while (nextop != (op)) \\ 705 while (nextop != (op)) \\
635 { \\ 706 { \\
636 PERL_ASYNC_CHECK (); \\ 707 PERL_ASYNC_CHECK (); \\
637 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\ 708 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 } 709 }
647 710
648 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;
649 system "$COMPILE -o $stem$_o $stem.c"; 723 system "$COMPILE -o $stem$_o $stem.c";
650 #d#unlink "$stem.c"; 724 unlink "$stem.c" unless $ENV{FASTER_DEBUG} > 0;
651 system "$LINK -o $stem$_so $stem$_o $LIBS"; 725 system "$LINK -o $stem$_so $stem$_o $LIBS";
652 unlink "$stem$_o"; 726 unlink "$stem$_o";
727 }
653 728
729 for my $f (@func) {
730 my $stem = $f->{so};
731
654 my $so = DynaLoader::dl_load_file "$stem$_so" 732 my $so = ($so{$stem} ||= DynaLoader::dl_load_file "$stem$_so")
655 or die "$stem$_so: $!"; 733 or die "$stem$_so: $!";
656 734
657 #unlink "$stem$_so"; 735 #unlink "$stem$_so";
658 736
659 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)
660} 746}
661 747
662my %ignore; 748my %ignore;
663 749
664sub entersub { 750sub entersub {
… …
666 752
667 my $pkg = $cv->STASH->NAME; 753 my $pkg = $cv->STASH->NAME;
668 754
669 return if $ignore{$pkg}; 755 return if $ignore{$pkg};
670 756
671 warn "compiling ", $cv->STASH->NAME, "\n" 757 warn "optimising ", $cv->STASH->NAME, "\n"
672 if $verbose; 758 if $verbose;
673 759
674 eval { 760 eval {
675 my @cv; 761 my @func;
676 my @cv_source; 762
763 push @func, {
764 cv => $cv,
765 name => "<>",
766 source => cv2c $cv,
767 };
677 768
678 # always compile the whole stash 769 # always compile the whole stash
679 my %stash = $cv->STASH->ARRAY; 770 my %stash = $cv->STASH->ARRAY;
680 while (my ($k, $v) = each %stash) { 771 while (my ($k, $v) = each %stash) {
681 $v->isa (B::GV::) 772 $v->isa (B::GV::)
… …
684 my $cv = $v->CV; 775 my $cv = $v->CV;
685 776
686 if ($cv->isa (B::CV::) 777 if ($cv->isa (B::CV::)
687 && ${$cv->START} 778 && ${$cv->START}
688 && $cv->START->name ne "null") { 779 && $cv->START->name ne "null") {
780
689 push @cv, $cv; 781 push @func, {
782 cv => $cv,
783 name => $k,
690 push @cv_source, cv2c $cv; 784 source => cv2c $cv,
785 };
691 } 786 }
692 } 787 }
693 788
694 my @ptr = source2ptr @cv_source; 789 func2ptr @func;
695 790
696 for (0 .. $#cv) { 791 for my $f (@func) {
697 patch_cv $cv[$_], $ptr[$_]; 792 patch_cv $f->{cv}, $f->{ptr};
698 } 793 }
699 }; 794 };
700 795
701 if ($@) { 796 if ($@) {
702 $ignore{$pkg}++; 797 $ignore{$pkg}++;
… …
717=over 4 812=over 4
718 813
719=item FASTER_VERBOSE 814=item FASTER_VERBOSE
720 815
721Faster will output more informational messages when set to values higher 816Faster will output more informational messages when set to values higher
722than 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.
723 820
724=item FASTER_DEBUG 821=item FASTER_DEBUG
725 822
726Add 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
727adds 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
728execution order are compatible. 825order and C execution order are compatible.
729 826
730=item FASTER_CACHE 827=item FASTER_CACHE
731 828
732NOT YET IMPLEMENTED
733
734Set a persistent cache directory that caches compiled code 829Set a persistent cache directory that caches compiled code fragments. The
735fragments. Normally, code compiled by Faster will be deleted immediately, 830default 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 831directory otherwise.
737directory makes Faster cache the generated files for re-use.
738 832
739This 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
740from time to time. 834from time to time.
741 835
742=back 836=back
743 837
744=head1 BUGS/LIMITATIONS 838=head1 BUGS/LIMITATIONS

Diff Legend

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