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.27 by root, Sat Mar 11 23:06:59 2006 UTC

… …
42use strict; 42use strict;
43use Config; 43use Config;
44use B (); 44use B ();
45#use Digest::MD5 (); 45#use Digest::MD5 ();
46use DynaLoader (); 46use DynaLoader ();
47use File::Temp (); 47use Digest::MD5 ();
48use Storable ();
48 49
49BEGIN { 50BEGIN {
50 our $VERSION = '0.01'; 51 our $VERSION = '0.01';
51 52
52 require XSLoader; 53 require XSLoader;
53 XSLoader::load __PACKAGE__, $VERSION; 54 XSLoader::load __PACKAGE__, $VERSION;
54} 55}
56
57my $CACHEDIR = $ENV{FASTER_CACHE} || do {
58 require File::Temp;
59 File::Temp::tempdir (CLEANUP => 1)
60};
55 61
56my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}"; 62my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}";
57my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}"; 63my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
58my $LIBS = "$Config{libs}"; 64my $LIBS = "$Config{libs}";
59my $_o = $Config{_o}; 65my $_o = $Config{_o};
… …
155 eq ne gt lt ge le 161 eq ne gt lt ge le
156 regcomp regcreset regcmaybe 162 regcomp regcreset regcmaybe
157); 163);
158 164
159my %callop = ( 165my %callop = (
160 entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)", 166 entersub => "(PL_op->op_ppaddr) (aTHX)",
161 mapstart => "Perl_pp_grepstart (aTHX)", 167 mapstart => "Perl_pp_grepstart (aTHX)",
162); 168);
163 169
164sub callop { 170sub callop {
165 $callop{$op_name} || "Perl_pp_$op_name (aTHX)" 171 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
… …
223if ($Config{useithreads} ne "define") { 229if ($Config{useithreads} ne "define") {
224 # disable optimisations on ithreads 230 # disable optimisations on ithreads
225 231
226 *op_const = sub { 232 *op_const = sub {
227 $source .= " { dSP; PUSHs ((SV *)${$op->sv}L); PUTBACK; }\n"; 233 $source .= " { dSP; PUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
234
235 $ops[0]{follows_const}++ if @ops;#d#
228 236
229 out_next; 237 out_next;
230 }; 238 };
231 239
232 *op_gv = \&op_const; 240 *op_gv = \&op_const;
… …
333 341
334sub op_padsv { 342sub op_padsv {
335 my $flags = $op->flags; 343 my $flags = $op->flags;
336 my $padofs = "(PADOFFSET)" . $op->targ; 344 my $padofs = "(PADOFFSET)" . $op->targ;
337 345
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; 346 $source .= <<EOF;
345 { 347 {
346 dSP; 348 dSP;
347 SV *sv = PAD_SVl ($padofs); 349 SV *sv = PAD_SVl ($padofs);
348EOF 350EOF
349 351
350 if (($flags & B::OPf_MOD) && ($op->private & B::OPpLVAL_INTRO)) { 352 if (($flags & B::OPf_MOD) && ($op->private & B::OPpLVAL_INTRO)) {
351 $source .= " SAVECLEARSV (PAD_SVl ($padofs));\n"; 353 $source .= " SAVECLEARSV (PAD_SVl ($padofs));\n";
352 $ops[0]{pre_padsv_lval_intro}++ if @ops;#d# 354 $ops[0]{follows_padsv_lval_intro}++ if @ops;#d#
353 } 355 }
354 356
355 $source .= <<EOF; 357 $source .= <<EOF;
356 PUSHs (sv); 358 PUSHs (sv);
357 PUTBACK; 359 PUTBACK;
358EOF 360EOF
359 361
360 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) { 362 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
361 $source .= " vivify_ref (sv, $flags & OPpDEREF);\n"; 363 $source .= " if (!SvROK (sv)) vivify_ref (sv, " . $op->private . " & OPpDEREF);\n";
362 } 364 }
363 $source .= " }\n"; 365 $source .= " }\n";
364 366
365 out_next; 367 out_next;
366} 368}
… …
372 dPOPTOPssrl; 374 dPOPTOPssrl;
373EOF 375EOF
374 $source .= " SV *temp = left; left = right; right = temp;\n" 376 $source .= " SV *temp = left; left = right; right = temp;\n"
375 if $op->private & B::OPpASSIGN_BACKWARDS; 377 if $op->private & B::OPpASSIGN_BACKWARDS;
376 378
377 if ($insn->{pre_padsv_lval_intro} && !($op->private & B::OPpASSIGN_BACKWARDS)) { 379 if ($insn->{follows_padsv_lval_intro} && !($op->private & B::OPpASSIGN_BACKWARDS)) {
378 # simple assignment - the target exists, but is basically undef 380 # simple assignment - the target exists, but is basically undef
379 $source .= " SvSetSV (right, left);\n"; 381 $source .= " SvSetSV (right, left);\n";
380 } else { 382 } else {
381 $source .= " SvSetMagicSV (right, left);\n"; 383 $source .= " SvSetMagicSV (right, left);\n";
382 } 384 }
… …
389 391
390 out_next; 392 out_next;
391} 393}
392 394
393# pattern const+ (or general push1) 395# pattern const+ (or general push1)
394# pattern pushmark return(?)
395# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 396# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
396 397
397# pattern const method_named
398sub op_method_named { 398sub op_method_named {
399 if ($insn->{follows_const}) {
399 $source .= <<EOF; 400 $source .= <<EOF;
401 {
402 dSP;
403 static SV *last_cv;
404 static U32 last_sub_generation;
405
406 /* simple "polymorphic" inline cache */
407 if (PL_sub_generation == last_sub_generation)
408 {
409 PUSHs (last_cv);
410 PUTBACK;
411 }
412 else
413 {
414 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
415
416 SPAGAIN;
417 last_sub_generation = PL_sub_generation;
418 last_cv = TOPs;
419 }
420 }
421EOF
422 } else {
423 $source .= <<EOF;
400 { 424 {
401 static HV *last_stash; 425 static HV *last_stash;
402 static SV *last_cv; 426 static SV *last_cv;
403 static U32 last_sub_generation; 427 static U32 last_sub_generation;
404 428
… …
431 /* error case usually */ 455 /* error case usually */
432 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 456 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
433 } 457 }
434 } 458 }
435EOF 459EOF
460 }
436 461
437 out_next; 462 out_next;
438} 463}
439 464
440sub op_grepstart { 465sub op_grepstart {
… …
612 637
613 $source 638 $source
614} 639}
615 640
616my $uid = "aaaaaaa0"; 641my $uid = "aaaaaaa0";
642my %so;
617 643
618sub source2ptr { 644sub func2ptr {
619 my (@source) = @_; 645 my (@func) = @_;
620 646
621 my $stem = "/tmp/Faster-$$-" . $uid++; 647 #LOCK
648 my $meta = eval { Storable::retrieve "$CACHEDIR/meta" } || { version => 1 };
622 649
650 for my $f (@func) {
651 $f->{func} = "F" . Digest::MD5::md5_hex ($f->{source});
652 $f->{so} = $meta->{$f->{func}};
653 }
654
655 if (grep !$_->{so}, @func) {
656 my $stem;
657
658 do {
659 $stem = "$CACHEDIR/$$-" . $uid++;
660 } while -e "$stem$_so";
661
623 open FILE, ">:raw", "$stem.c"; 662 open my $fh, ">:raw", "$stem.c";
624 print FILE <<EOF; 663 print $fh <<EOF;
625#define PERL_NO_GET_CONTEXT 664#define PERL_NO_GET_CONTEXT
626#define PERL_CORE 665#define PERL_CORE
627 666
628#include <assert.h> 667#include <assert.h>
629 668
630#include "EXTERN.h" 669#include "EXTERN.h"
631#include "perl.h" 670#include "perl.h"
632#include "XSUB.h" 671#include "XSUB.h"
633 672
634#define RUNOPS_TILL(op) \\ 673#define RUNOPS_TILL(op) \\
635while (nextop != (op)) \\ 674 while (nextop != (op)) \\
636 { \\ 675 { \\
637 PERL_ASYNC_CHECK (); \\ 676 PERL_ASYNC_CHECK (); \\
638 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\ 677 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 } 678 }
648 679
649 close FILE; 680EOF
681 for my $f (grep !$_->{so}, @func) {
682 next if $f->{so} = $meta->{$f->{func}}; # some cv's alias others
683
684 warn "compiling $f->{name} to $stem$_so:$f->{func}\n" if $verbose > 1;
685 my $source = $f->{source};
686 $source =~ s/%%%FUNC%%%/$f->{func}/g;
687 print $fh $source;
688 $meta->{$f->{func}} = $f->{so} = $stem;
689 }
690
691 close $fh;
650 system "$COMPILE -o $stem$_o $stem.c"; 692 system "$COMPILE -o $stem$_o $stem.c";
651 #d#unlink "$stem.c"; 693 #d#unlink "$stem.c";
652 system "$LINK -o $stem$_so $stem$_o $LIBS"; 694 system "$LINK -o $stem$_so $stem$_o $LIBS";
653 unlink "$stem$_o"; 695 unlink "$stem$_o";
696 }
654 697
698 for my $f (@func) {
699 my $stem = $f->{so};
700
655 my $so = DynaLoader::dl_load_file "$stem$_so" 701 my $so = ($so{$stem} ||= DynaLoader::dl_load_file "$stem$_so")
656 or die "$stem$_so: $!"; 702 or die "$stem$_so: $!";
657 703
658 #unlink "$stem$_so"; 704 #unlink "$stem$_so";
659 705
660 map +(DynaLoader::dl_find_symbol $so, $_), @source 706 $f->{ptr} = DynaLoader::dl_find_symbol $so, $f->{func}
707 or die "$f->{func} not found in $stem$_so: $!";
708 }
709
710 Storable::nstore $meta, "$CACHEDIR/meta";
711 # UNLOCK
661} 712}
662 713
663my %ignore; 714my %ignore;
664 715
665sub entersub { 716sub entersub {
… …
667 718
668 my $pkg = $cv->STASH->NAME; 719 my $pkg = $cv->STASH->NAME;
669 720
670 return if $ignore{$pkg}; 721 return if $ignore{$pkg};
671 722
672 warn "compiling ", $cv->STASH->NAME, "\n" 723 warn "optimising ", $cv->STASH->NAME, "\n"
673 if $verbose; 724 if $verbose;
674 725
675 eval { 726 eval {
676 my @cv; 727 my @func;
677 my @cv_source;
678 728
679 # always compile the whole stash 729 # always compile the whole stash
680 my %stash = $cv->STASH->ARRAY; 730 my %stash = $cv->STASH->ARRAY;
681 while (my ($k, $v) = each %stash) { 731 while (my ($k, $v) = each %stash) {
682 $v->isa (B::GV::) 732 $v->isa (B::GV::)
… …
685 my $cv = $v->CV; 735 my $cv = $v->CV;
686 736
687 if ($cv->isa (B::CV::) 737 if ($cv->isa (B::CV::)
688 && ${$cv->START} 738 && ${$cv->START}
689 && $cv->START->name ne "null") { 739 && $cv->START->name ne "null") {
740
690 push @cv, $cv; 741 push @func, {
742 cv => $cv,
743 name => $k,
691 push @cv_source, cv2c $cv; 744 source => cv2c $cv,
745 };
692 } 746 }
693 } 747 }
694 748
695 my @ptr = source2ptr @cv_source; 749 func2ptr @func;
696 750
697 for (0 .. $#cv) { 751 for my $f (@func) {
698 patch_cv $cv[$_], $ptr[$_]; 752 patch_cv $f->{cv}, $f->{ptr};
699 } 753 }
700 }; 754 };
701 755
702 if ($@) { 756 if ($@) {
703 $ignore{$pkg}++; 757 $ignore{$pkg}++;
… …
728adds 1-3 C<assert>'s per perl op, to ensure that opcode order and C 782adds 1-3 C<assert>'s per perl op, to ensure that opcode order and C
729execution order are compatible. 783execution order are compatible.
730 784
731=item FASTER_CACHE 785=item FASTER_CACHE
732 786
733NOT YET IMPLEMENTED 787NOT YET IMPLEMENTED CORRECTLY, SHARING BEETWEEN INSTANCES IS IMPOSSIBLE
734 788
735Set a persistent cache directory that caches compiled code 789Set a persistent cache directory that caches compiled code
736fragments. Normally, code compiled by Faster will be deleted immediately, 790fragments. Normally, code compiled by Faster will be deleted immediately,
737and every restart will recompile everything. Setting this variable to a 791and every restart will recompile everything. Setting this variable to a
738directory makes Faster cache the generated files for re-use. 792directory makes Faster cache the generated files for re-use.

Diff Legend

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