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

Comparing Faster/Faster.pm (file contents):
Revision 1.18 by root, Fri Mar 10 19:52:07 2006 UTC vs.
Revision 1.27 by root, Sat Mar 11 23:06:59 2006 UTC

… …
25immensely, but rarely cause bugs). 25immensely, but rarely cause bugs).
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 ltos 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
31F</tmp>, and it will even create those temporary files in an insecure 31F</tmp>, and it will even create those temporary files in an insecure
32manner, so watch out. 32manner, so watch out.
33 33
34=over 4 34=over 4
35 35
36=cut 36=cut
37 37
38package Faster; 38package Faster;
39
40no warnings;
39 41
40use strict; 42use strict;
41use Config; 43use Config;
42use B (); 44use B ();
45#use Digest::MD5 ();
46use DynaLoader ();
43use Digest::MD5 (); 47use Digest::MD5 ();
44use DynaLoader (); 48use Storable ();
45 49
46BEGIN { 50BEGIN {
47 our $VERSION = '0.01'; 51 our $VERSION = '0.01';
48 52
49 require XSLoader; 53 require XSLoader;
50 XSLoader::load __PACKAGE__, $VERSION; 54 XSLoader::load __PACKAGE__, $VERSION;
51} 55}
56
57my $CACHEDIR = $ENV{FASTER_CACHE} || do {
58 require File::Temp;
59 File::Temp::tempdir (CLEANUP => 1)
60};
52 61
53my $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}";
54my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}"; 63my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
55my $LIBS = "$Config{libs}"; 64my $LIBS = "$Config{libs}";
56my $_o = $Config{_o}; 65my $_o = $Config{_o};
… …
58 67
59# we don't need no steenking PIC on x86 68# we don't need no steenking PIC on x86
60$COMPILE =~ s/-f(?:PIC|pic)//g 69$COMPILE =~ s/-f(?:PIC|pic)//g
61 if $Config{archname} =~ /^(i[3456]86)-/; 70 if $Config{archname} =~ /^(i[3456]86)-/;
62 71
63my $opt_assert = 1; 72my $opt_assert = $ENV{FASTER_DEBUG};
73my $verbose = $ENV{FASTER_VERBOSE}+0;
64 74
65our $source; 75our $source;
66 76
67our @ops; 77our @ops;
78our $insn;
68our $op; 79our $op;
69our $op_name; 80our $op_name;
70our @op_loop; 81our @op_loop;
71our %op_regcomp; 82our %op_regcomp;
72 83
73my %flag; 84# ops that cause immediate return to the interpreter
85my %f_unsafe = map +($_ => undef), qw(
86 leavesub leavesublv return
87 goto last redo next
88 eval flip leaveeval entertry
89 formline grepstart mapstart
90 substcont entereval require
91);
74 92
75# complex flag steting is no longer required, rewrite this ugly code 93# ops with known stack extend behaviour
76for (split /\n/, <<EOF) { 94# the values given are maximum values
77 leavesub unsafe 95my %extend = (
78 leavesublv unsafe 96 pushmark => 0,
79 return unsafe 97 nextstate => 0, # might reduce the stack
80 flip unsafe 98 unstack => 0,
81 goto unsafe 99 enter => 0,
82 last unsafe
83 redo unsafe
84 next unsafe
85 eval unsafe
86 leaveeval unsafe
87 entertry unsafe
88 formline unsafe
89 grepstart unsafe
90 mapstart unsafe
91 substcont unsafe
92 entereval unsafe noasync todo
93 require unsafe
94 100
95 mapstart noasync 101 stringify => 0,
96 grepstart noasync 102 not => 0,
97 match noasync 103 and => 0,
104 or => 0,
105 gvsv => 0,
106 rv2gv => 0,
107 preinc => 0,
108 predec => 0,
109 postinc => 0,
110 postdec => 0,
111 aelem => 0,
112 helem => 0,
113 qr => 1, #???
114 pushre => 1,
115 gv => 1,
116 aelemfast => 1,
117 aelem => 0,
118 padsv => 1,
119 const => 1,
120 pop => 1,
121 shift => 1,
122 eq => -1,
123 ne => -1,
124 gt => -1,
125 lt => -1,
126 ge => -1,
127 lt => -1,
128 cond_expr => -1,
129 add => -1,
130 subtract => -1,
131 multiply => -1,
132 divide => -1,
133 aassign => 0,
134 sassign => -2,
135 method => 0,
136 method_named => 1,
137);
98 138
99 last noasync 139# ops that do not need an ASYNC_CHECK
100 next noasync 140my %f_noasync = map +($_ => undef), qw(
101 redo noasync 141 mapstart grepstart match entereval
102 seq noasync 142 enteriter entersub leaveloop
103 pushmark noasync extend=0
104 padsv noasync extend=1
105 padav noasync extend=1
106 padhv noasync extend=1
107 padany noasync extend=1
108 entersub noasync
109 aassign noasync
110 sassign noasync
111 rv2av noasync
112 rv2cv noasync
113 rv2gv noasync
114 rv2hv noasync
115 refgen noasync
116 nextstate noasync
117 gv noasync
118 gvsv noasync
119 add noasync
120 subtract noasync
121 multiply noasync
122 divide noasync
123 complement noasync
124 cond_expr noasync
125 and noasync
126 or noasync
127 not noasync
128 defined noasync
129 method_named noasync
130 preinc noasync
131 postinc noasync
132 predec noasync
133 postdec noasync
134 stub noasync
135 unstack noasync
136 leaveloop noasync
137 aelem noasync
138 aelemfast noasync
139 helem noasync
140 pushre noasync
141 subst noasync
142 const noasync extend=1
143 list noasync
144 join noasync
145 split noasync
146 concat noasync
147 push noasync
148 pop noasync
149 shift noasync
150 unshift noasync
151 length noasync
152 substr noasync
153 stringify noasync
154 eq noasync
155 ne noasync
156 gt noasync
157 lt noasync
158 ge noasync
159 le noasync
160 enteriter noasync
161 ord noasync
162 orassign noasync
163 regcomp noasync
164 regcreset noasync
165 regcmaybe noasync
166 143
167 iter async 144 pushmark nextstate
168EOF
169 my (undef, $op, @flags) = split /\s+/;
170 145
171 undef $flag{$_}{$op} 146 const stub unstack
172 for ("known", @flags); 147 last next redo seq
173} 148 padsv padav padhv padany
149 aassign sassign orassign
150 rv2av rv2cv rv2gv rv2hv refgen
151 gv gvsv
152 add subtract multiply divide
153 complement cond_expr and or not
154 defined
155 method method_named bless
156 preinc postinc predec postdec
157 aelem aelemfast helem delete exists
158 pushre subst list join split concat
159 length substr stringify ord
160 push pop shift unshift
161 eq ne gt lt ge le
162 regcomp regcreset regcmaybe
163);
174 164
175my %callop = ( 165my %callop = (
176 entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)", 166 entersub => "(PL_op->op_ppaddr) (aTHX)",
177 mapstart => "Perl_pp_grepstart (aTHX)", 167 mapstart => "Perl_pp_grepstart (aTHX)",
178); 168);
179 169
180sub callop { 170sub callop {
181 $callop{$op_name} || "Perl_pp_$op_name (aTHX)" 171 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
… …
238 228
239if ($Config{useithreads} ne "define") { 229if ($Config{useithreads} ne "define") {
240 # disable optimisations on ithreads 230 # disable optimisations on ithreads
241 231
242 *op_const = sub { 232 *op_const = sub {
243 $source .= " { dSP; XPUSHs ((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#
244 236
245 out_next; 237 out_next;
246 }; 238 };
247 239
248 *op_gv = \&op_const; 240 *op_gv = \&op_const;
… …
268 if (!($op->flags & B::OPf_MOD)) { 260 if (!($op->flags & B::OPf_MOD)) {
269 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n"; 261 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
270 } 262 }
271 263
272 $source .= " dSP;\n"; 264 $source .= " dSP;\n";
273 $source .= " XPUSHs (sv);\n"; 265 $source .= " PUSHs (sv);\n";
274 $source .= " PUTBACK;\n"; 266 $source .= " PUTBACK;\n";
275 $source .= " }\n"; 267 $source .= " }\n";
276 268
277 out_next; 269 out_next;
278 }; 270 };
279 271
280 *op_gvsv = sub { 272 *op_gvsv = sub {
281 $source .= " {\n"; 273 $source .= " {\n";
282 $source .= " dSP;\n"; 274 $source .= " dSP;\n";
283 $source .= " EXTEND (SP, 1);\n";
284 275
285 if ($op->private & B::OPpLVAL_INTRO) { 276 if ($op->private & B::OPpLVAL_INTRO) {
286 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n"; 277 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
287 } else { 278 } else {
288 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n"; 279 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
… …
348 out_next; 339 out_next;
349} 340}
350 341
351sub op_padsv { 342sub op_padsv {
352 my $flags = $op->flags; 343 my $flags = $op->flags;
353 my $target = $op->targ; 344 my $padofs = "(PADOFFSET)" . $op->targ;
354 345
355 $source .= <<EOF; 346 $source .= <<EOF;
356 { 347 {
357 dSP; 348 dSP;
358 XPUSHs (PAD_SV ((PADOFFSET)$target)); 349 SV *sv = PAD_SVl ($padofs);
350EOF
351
352 if (($flags & B::OPf_MOD) && ($op->private & B::OPpLVAL_INTRO)) {
353 $source .= " SAVECLEARSV (PAD_SVl ($padofs));\n";
354 $ops[0]{follows_padsv_lval_intro}++ if @ops;#d#
355 }
356
357 $source .= <<EOF;
358 PUSHs (sv);
359 PUTBACK; 359 PUTBACK;
360EOF 360EOF
361 if ($op->flags & B::OPf_MOD) { 361
362 if ($op->private & B::OPpLVAL_INTRO) { 362 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
363 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n"; 363 $source .= " if (!SvROK (sv)) vivify_ref (sv, " . $op->private . " & OPpDEREF);\n";
364 } elsif ($op->private & B::OPpDEREF) {
365 my $deref = $op->private & B::OPpDEREF;
366 $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
367 }
368 } 364 }
365 $source .= " }\n";
366
367 out_next;
368}
369
370sub op_sassign {
371 $source .= <<EOF;
372 {
373 dSP;
374 dPOPTOPssrl;
375EOF
376 $source .= " SV *temp = left; left = right; right = temp;\n"
377 if $op->private & B::OPpASSIGN_BACKWARDS;
378
379 if ($insn->{follows_padsv_lval_intro} && !($op->private & B::OPpASSIGN_BACKWARDS)) {
380 # simple assignment - the target exists, but is basically undef
381 $source .= " SvSetSV (right, left);\n";
382 } else {
383 $source .= " SvSetMagicSV (right, left);\n";
384 }
385
369 $source .= <<EOF; 386 $source .= <<EOF;
387 SETs (right);
388 PUTBACK;
370 } 389 }
371EOF 390EOF
372 391
373 out_next; 392 out_next;
374} 393}
375 394
376# pattern const+ (or general push1) 395# pattern const+ (or general push1)
377# pattern pushmark return(?)
378# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 396# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
379 397
380# pattern const method_named
381sub op_method_named { 398sub op_method_named {
399 if ($insn->{follows_const}) {
382 $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;
383 { 424 {
384 static HV *last_stash; 425 static HV *last_stash;
385 static SV *last_cv; 426 static SV *last_cv;
386 static U32 last_sub_generation; 427 static U32 last_sub_generation;
387 428
… …
394 435
395 /* simple "polymorphic" inline cache */ 436 /* simple "polymorphic" inline cache */
396 if (stash == last_stash 437 if (stash == last_stash
397 && PL_sub_generation == last_sub_generation) 438 && PL_sub_generation == last_sub_generation)
398 { 439 {
399 XPUSHs (last_cv); 440 PUSHs (last_cv);
400 PUTBACK; 441 PUTBACK;
401 } 442 }
402 else 443 else
403 { 444 {
404 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 445 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
… …
414 /* error case usually */ 455 /* error case usually */
415 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 456 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
416 } 457 }
417 } 458 }
418EOF 459EOF
460 }
419 461
420 out_next; 462 out_next;
421} 463}
422 464
423sub op_grepstart { 465sub op_grepstart {
… …
466 local @op_loop; 508 local @op_loop;
467 local %op_regcomp; 509 local %op_regcomp;
468 510
469 my %opsseen; 511 my %opsseen;
470 my @todo = $cv->START; 512 my @todo = $cv->START;
513 my %op_target;
471 514
472 while (my $op = shift @todo) { 515 while (my $op = shift @todo) {
473 for (; $$op; $op = $op->next) { 516 for (; $$op; $op = $op->next) {
474 last if $opsseen{$$op}++; 517 last if $opsseen{$$op}++;
475 push @ops, $op;
476 518
477 my $name = $op->name; 519 my $name = $op->name;
478 my $class = B::class $op; 520 my $class = B::class $op;
479 521
522 my $insn = { op => $op };
523
524 push @ops, $insn;
525
526 if (exists $extend{$name}) {
527 my $extend = $extend{$name};
528 $extend = $extend->($op) if ref $extend;
529 $insn->{extend} = $extend if defined $extend;
530 }
531
532 push @todo, $op->next;
533
480 if ($class eq "LOGOP") { 534 if ($class eq "LOGOP") {
481 unshift @todo, $op->other; # unshift vs. push saves jumps 535 push @todo, $op->other;
536 $op_target{${$op->other}}++;
482 537
483 # regcomp/o patches ops at runtime, lets expect that 538 # regcomp/o patches ops at runtime, lets expect that
539 if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
540 $op_target{${$op->first}}++;
484 $op_regcomp{${$op->first}} = $op->next 541 $op_regcomp{${$op->first}} = $op->next;
485 if $name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP; 542 }
486 543
487 } elsif ($class eq "PMOP") { 544 } elsif ($class eq "PMOP") {
545 if (${$op->pmreplstart}) {
488 unshift @todo, $op->pmreplstart if ${$op->pmreplstart}; 546 unshift @todo, $op->pmreplstart;
547 $op_target{${$op->pmreplstart}}++;
548 }
489 549
490 } elsif ($class eq "LOOP") { 550 } elsif ($class eq "LOOP") {
491 push @op_loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
492 push @todo, $op->nextop, $op->lastop->next, $op->redoop->next; 551 my @targ = ($op->nextop, $op->lastop->next, $op->redoop->next);
552
553 push @op_loop, \@targ;
554 push @todo, @targ;
555
556 $op_target{$$_}++ for @targ;
557 } elsif ($class eq "COP") {
558 $insn->{bblock}++ if defined $op->label;
493 } 559 }
494 } 560 }
495 } 561 }
562
563 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
496 564
497 local $source = <<EOF; 565 local $source = <<EOF;
498OP *%%%FUNC%%% (pTHX) 566OP *%%%FUNC%%% (pTHX)
499{ 567{
500 register OP *nextop = (OP *)${$ops[0]}L; 568 register OP *nextop = (OP *)${$ops[0]->{op}}L;
501EOF 569EOF
502 570
503 while (@ops) { 571 while (@ops) {
504 $op = shift @ops; 572 $insn = shift @ops;
573
574 $op = $insn->{op};
505 $op_name = $op->name; 575 $op_name = $op->name;
506 576
577 my $class = B::class $op;
578
579 $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
507 $source .= "op_$$op: /* $op_name */\n"; 580 $source .= "op_$$op: /* $op_name */\n";
508 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d# 581 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
509 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d# 582 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
510 583
511 $source .= " PERL_ASYNC_CHECK ();\n" 584 $source .= " PERL_ASYNC_CHECK ();\n"
512 unless exists $flag{noasync}{$op_name}; 585 unless exists $f_noasync{$op_name};
513 586
514 if (my $can = __PACKAGE__->can ("op_$op_name")) { 587 if (my $can = __PACKAGE__->can ("op_$op_name")) {
515 # handcrafted replacement 588 # handcrafted replacement
589
590 if ($insn->{extend} > 0) {
591 # coalesce EXTENDs
592 # TODO: properly take negative preceeding and following EXTENDs into account
593 for my $i (@ops) {
594 last if exists $i->{bblock};
595 last unless exists $i->{extend};
596 my $extend = delete $i->{extend};
597 $insn->{extend} += $extend if $extend > 0;
598 }
599
600 $source .= " { dSP; EXTEND (SP, $insn->{extend}); PUTBACK; }\n"
601 if $insn->{extend} > 0;
602 }
603
516 $can->($op); 604 $can->($op);
517 605
518 } elsif (exists $flag{unsafe}{$op_name}) { 606 } elsif (exists $f_unsafe{$op_name}) {
519 # unsafe, return to interpreter 607 # unsafe, return to interpreter
520 assert "nextop == (OP *)$$op"; 608 assert "nextop == (OP *)$$op";
521 $source .= " return nextop;\n"; 609 $source .= " return nextop;\n";
522 610
523 } elsif ("LOGOP" eq B::class $op) { 611 } elsif ("LOGOP" eq $class) {
524 # logical operation with optionaö branch 612 # logical operation with optional branch
525 out_callop; 613 out_callop;
526 out_cond_jump $op->other; 614 out_cond_jump $op->other;
527 out_jump_next; 615 out_jump_next;
528 616
529 } elsif ("PMOP" eq B::class $op) { 617 } elsif ("PMOP" eq $class) {
530 # regex-thingy 618 # regex-thingy
531 out_callop; 619 out_callop;
532 out_cond_jump $op->pmreplroot if ${$op->pmreplroot}; 620 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
533 out_jump_next; 621 out_jump_next;
534 622
535 } else { 623 } else {
536 # normal operator, linear execution 624 # normal operator, linear execution
537 out_linear; 625 out_linear;
… …
548 #warn $source; 636 #warn $source;
549 637
550 $source 638 $source
551} 639}
552 640
641my $uid = "aaaaaaa0";
642my %so;
643
553sub source2ptr { 644sub func2ptr {
554 my ($source) = @_; 645 my (@func) = @_;
555 646
556 my $md5 = Digest::MD5::md5_hex $source; 647 #LOCK
557 $source =~ s/%%%FUNC%%%/Faster_$md5/; 648 my $meta = eval { Storable::retrieve "$CACHEDIR/meta" } || { version => 1 };
558 649
559 my $stem = "/tmp/$md5"; 650 for my $f (@func) {
651 $f->{func} = "F" . Digest::MD5::md5_hex ($f->{source});
652 $f->{so} = $meta->{$f->{func}};
653 }
560 654
561 unless (-e "$stem$_so") { 655 if (grep !$_->{so}, @func) {
656 my $stem;
657
658 do {
659 $stem = "$CACHEDIR/$$-" . $uid++;
660 } while -e "$stem$_so";
661
562 open FILE, ">:raw", "$stem.c"; 662 open my $fh, ">:raw", "$stem.c";
563 print FILE <<EOF; 663 print $fh <<EOF;
564#define PERL_NO_GET_CONTEXT 664#define PERL_NO_GET_CONTEXT
665#define PERL_CORE
565 666
566#include <assert.h> 667#include <assert.h>
567 668
568#include "EXTERN.h" 669#include "EXTERN.h"
569#include "perl.h" 670#include "perl.h"
… …
575 PERL_ASYNC_CHECK (); \\ 676 PERL_ASYNC_CHECK (); \\
576 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\ 677 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
577 } 678 }
578 679
579EOF 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;
580 print FILE $source; 687 print $fh $source;
688 $meta->{$f->{func}} = $f->{so} = $stem;
689 }
690
581 close FILE; 691 close $fh;
582 system "$COMPILE -o $stem$_o $stem.c"; 692 system "$COMPILE -o $stem$_o $stem.c";
693 #d#unlink "$stem.c";
583 system "$LINK -o $stem$_so $stem$_o $LIBS"; 694 system "$LINK -o $stem$_so $stem$_o $LIBS";
695 unlink "$stem$_o";
584 } 696 }
585 697
586# warn $source; 698 for my $f (@func) {
699 my $stem = $f->{so};
700
587 my $so = DynaLoader::dl_load_file "$stem$_so" 701 my $so = ($so{$stem} ||= DynaLoader::dl_load_file "$stem$_so")
588 or die "$stem$_so: $!"; 702 or die "$stem$_so: $!";
589 703
590 DynaLoader::dl_find_symbol $so, "Faster_$md5" 704 #unlink "$stem$_so";
591 or die "Faster_$md5: $!" 705
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
592} 712}
713
714my %ignore;
593 715
594sub entersub { 716sub entersub {
595 my ($cv) = @_; 717 my ($cv) = @_;
596 718
597 # always compile the whole stash 719 my $pkg = $cv->STASH->NAME;
598# my @stash = $cv->STASH->ARRAY; 720
599# warn join ":", @stash; 721 return if $ignore{$pkg};
600# exit; 722
723 warn "optimising ", $cv->STASH->NAME, "\n"
724 if $verbose;
601 725
602 eval { 726 eval {
603 my $source = cv2c $cv; 727 my @func;
604 728
605 my $ptr = source2ptr $source; 729 # always compile the whole stash
730 my %stash = $cv->STASH->ARRAY;
731 while (my ($k, $v) = each %stash) {
732 $v->isa (B::GV::)
733 or next;
606 734
735 my $cv = $v->CV;
736
737 if ($cv->isa (B::CV::)
738 && ${$cv->START}
739 && $cv->START->name ne "null") {
740
741 push @func, {
742 cv => $cv,
743 name => $k,
744 source => cv2c $cv,
745 };
746 }
747 }
748
749 func2ptr @func;
750
751 for my $f (@func) {
607 patch_cv $cv, $ptr; 752 patch_cv $f->{cv}, $f->{ptr};
753 }
608 }; 754 };
609 755
610 warn $@ if $@; 756 if ($@) {
757 $ignore{$pkg}++;
758 warn $@;
759 }
611} 760}
612 761
613hook_entersub; 762hook_entersub;
614 763
6151; 7641;
765
766=back
767
768=head1 ENVIRONMENT VARIABLES
769
770The following environment variables influence the behaviour of Faster:
771
772=over 4
773
774=item FASTER_VERBOSE
775
776Faster will output more informational messages when set to values higher
777than C<0>. Currently, C<1> outputs which packages are being compiled.
778
779=item FASTER_DEBUG
780
781Add debugging code when set to values higher than C<0>. Currently, this
782adds 1-3 C<assert>'s per perl op, to ensure that opcode order and C
783execution order are compatible.
784
785=item FASTER_CACHE
786
787NOT YET IMPLEMENTED CORRECTLY, SHARING BEETWEEN INSTANCES IS IMPOSSIBLE
788
789Set a persistent cache directory that caches compiled code
790fragments. Normally, code compiled by Faster will be deleted immediately,
791and every restart will recompile everything. Setting this variable to a
792directory makes Faster cache the generated files for re-use.
793
794This directory will always grow in contents, so you might need to erase it
795from time to time.
616 796
617=back 797=back
618 798
619=head1 BUGS/LIMITATIONS 799=head1 BUGS/LIMITATIONS
620 800
621Perl will check much less often for asynchronous signals in 801Perl will check much less often for asynchronous signals in
622Faster-compiled code. It tries to check on every function call, loop 802Faster-compiled code. It tries to check on every function call, loop
623iteration and every I/O operator, though. 803iteration and every I/O operator, though.
624 804
625The following things will disable Faster. If you manage to enable them at 805The following things will disable Faster. If you manage to enable them at
626runtime, bad things will happen. 806runtime, bad things will happen. Enabling them at startup will be fine,
807though.
627 808
628 enabled tainting 809 enabled tainting
629 enabled debugging 810 enabled debugging
630 811
631This will dramatically reduce Faster's performance: 812Thread-enabled builds of perl will dramatically reduce Faster's
813performance, but you don't care about speed if you enable threads anyway.
632 814
633 threads (but you don't care about speed if you use threads anyway)
634
635These constructs will force the use of the interpreter as soon as they are 815These constructs will force the use of the interpreter for the currently
636being executed, for the rest of the currently executed: 816executed function as soon as they are being encountered during execution.
637 817
638 .., ... (flipflop operators)
639 goto 818 goto
640 next, redo (but not well-behaved last's) 819 next, redo (but not well-behaved last's)
641 eval 820 eval
642 require 821 require
643 any use of formats 822 any use of formats
823 .., ... (flipflop operators)
644 824
645=head1 AUTHOR 825=head1 AUTHOR
646 826
647 Marc Lehmann <schmorp@schmorp.de> 827 Marc Lehmann <schmorp@schmorp.de>
648 http://home.schmorp.de/ 828 http://home.schmorp.de/

Diff Legend

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