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

Comparing Faster/Faster.pm (file contents):
Revision 1.20 by root, Fri Mar 10 22:32:15 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
38package Faster; 39package Faster;
40
41no warnings;
39 42
40use strict; 43use strict;
41use Config; 44use Config;
42use B (); 45use B ();
43#use Digest::MD5 ();
44use DynaLoader (); 46use DynaLoader ();
47use Digest::MD5 ();
48use Storable ();
49use Fcntl ();
45 50
46BEGIN { 51BEGIN {
47 our $VERSION = '0.01'; 52 our $VERSION = '0.01';
48 53
49 require XSLoader; 54 require XSLoader;
50 XSLoader::load __PACKAGE__, $VERSION; 55 XSLoader::load __PACKAGE__, $VERSION;
51} 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 };
52 65
53my $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}";
54my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}"; 67my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
55my $LIBS = "$Config{libs}"; 68my $LIBS = "$Config{libs}";
56my $_o = $Config{_o}; 69my $_o = $Config{_o};
… …
58 71
59# we don't need no steenking PIC on x86 72# we don't need no steenking PIC on x86
60$COMPILE =~ s/-f(?:PIC|pic)//g 73$COMPILE =~ s/-f(?:PIC|pic)//g
61 if $Config{archname} =~ /^(i[3456]86)-/; 74 if $Config{archname} =~ /^(i[3456]86)-/;
62 75
63my $opt_assert = 0; 76my $opt_assert = $ENV{FASTER_DEBUG};
77my $verbose = $ENV{FASTER_VERBOSE}+0;
78
79warn "Faster: CACHEDIR is $CACHEDIR\n" if $verbose > 2;
64 80
65our $source; 81our $source;
66 82
67our @ops; 83our @ops;
84our $insn;
68our $op; 85our $op;
69our $op_name; 86our $op_name;
70our @op_loop; 87our @op_loop;
71our %op_regcomp; 88our %op_regcomp;
72 89
90# ops that cause immediate return to the interpreter
73my %f_unsafe = map +($_ => undef), qw( 91my %f_unsafe = map +($_ => undef), qw(
74 leavesub leavesublv return 92 leavesub leavesublv return
75 goto last redo next 93 goto last redo next
76 eval flip leaveeval entertry 94 eval flip leaveeval entertry
77 formline grepstart mapstart 95 formline grepstart mapstart
78 substcont entereval require 96 substcont entereval require
79); 97);
80 98
81# pushmark extend=0 99# ops with known stack extend behaviour
82# padsv extend=1 100# the values given are maximum values
83# padav extend=1 101my %extend = (
84# padhv extend=1 102 pushmark => 0,
85# padany extend=1 103 nextstate => 0, # might reduce the stack
86# const extend=1 104 unstack => 0,
105 enter => 0,
87 106
107 stringify => 0,
108 not => 0,
109 and => 0,
110 or => 0,
111 gvsv => 0,
112 rv2gv => 0,
113 preinc => 0,
114 predec => 0,
115 postinc => 0,
116 postdec => 0,
117 aelem => 0,
118 helem => 0,
119 qr => 1, #???
120 pushre => 1,
121 gv => 1,
122 aelemfast => 1,
123 aelem => 0,
124 padsv => 1,
125 const => 1,
126 pop => 1,
127 shift => 1,
128 eq => -1,
129 ne => -1,
130 gt => -1,
131 lt => -1,
132 ge => -1,
133 lt => -1,
134 cond_expr => -1,
135 add => -1,
136 subtract => -1,
137 multiply => -1,
138 divide => -1,
139 aassign => 0,
140 sassign => -2,
141 method => 0,
142 method_named => 1,
143);
144
145# ops that do not need an ASYNC_CHECK
88my %f_noasync = map +($_ => undef), qw( 146my %f_noasync = map +($_ => undef), qw(
89 mapstart grepstart match entereval 147 mapstart grepstart match entereval
90 enteriter entersub leaveloop 148 enteriter entersub leaveloop
91 149
92 pushmark nextstate 150 pushmark nextstate
… …
98 rv2av rv2cv rv2gv rv2hv refgen 156 rv2av rv2cv rv2gv rv2hv refgen
99 gv gvsv 157 gv gvsv
100 add subtract multiply divide 158 add subtract multiply divide
101 complement cond_expr and or not 159 complement cond_expr and or not
102 defined 160 defined
103 method_named 161 method method_named bless
104 preinc postinc predec postdec 162 preinc postinc predec postdec
105 aelem aelemfast helem delete exists 163 aelem aelemfast helem delete exists
106 pushre subst list join split concat 164 pushre subst list join split concat
107 length substr stringify ord 165 length substr stringify ord
108 push pop shift unshift 166 push pop shift unshift
109 eq ne gt lt ge le 167 eq ne gt lt ge le
110 regcomp regcreset regcmaybe 168 regcomp regcreset regcmaybe
111); 169);
112 170
113my %callop = ( 171my %callop = (
114 entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)", 172 entersub => "(PL_op->op_ppaddr) (aTHX)",
115 mapstart => "Perl_pp_grepstart (aTHX)", 173 mapstart => "Perl_pp_grepstart (aTHX)",
116); 174);
117 175
118sub callop { 176sub callop {
119 $callop{$op_name} || "Perl_pp_$op_name (aTHX)" 177 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
… …
176 234
177if ($Config{useithreads} ne "define") { 235if ($Config{useithreads} ne "define") {
178 # disable optimisations on ithreads 236 # disable optimisations on ithreads
179 237
180 *op_const = sub { 238 *op_const = sub {
181 $source .= " { dSP; XPUSHs ((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#
182 242
183 out_next; 243 out_next;
184 }; 244 };
185 245
186 *op_gv = \&op_const; 246 *op_gv = \&op_const;
… …
206 if (!($op->flags & B::OPf_MOD)) { 266 if (!($op->flags & B::OPf_MOD)) {
207 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n"; 267 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
208 } 268 }
209 269
210 $source .= " dSP;\n"; 270 $source .= " dSP;\n";
211 $source .= " XPUSHs (sv);\n"; 271 $source .= " PUSHs (sv);\n";
212 $source .= " PUTBACK;\n"; 272 $source .= " PUTBACK;\n";
213 $source .= " }\n"; 273 $source .= " }\n";
214 274
215 out_next; 275 out_next;
216 }; 276 };
217 277
218 *op_gvsv = sub { 278 *op_gvsv = sub {
219 $source .= " {\n"; 279 $source .= " {\n";
220 $source .= " dSP;\n"; 280 $source .= " dSP;\n";
221 $source .= " EXTEND (SP, 1);\n";
222 281
223 if ($op->private & B::OPpLVAL_INTRO) { 282 if ($op->private & B::OPpLVAL_INTRO) {
224 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n"; 283 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
225 } else { 284 } else {
226 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n"; 285 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
… …
286 out_next; 345 out_next;
287} 346}
288 347
289sub op_padsv { 348sub op_padsv {
290 my $flags = $op->flags; 349 my $flags = $op->flags;
291 my $target = $op->targ; 350 my $padofs = "(PADOFFSET)" . $op->targ;
292 351
293 $source .= <<EOF; 352 $source .= <<EOF;
294 { 353 {
295 dSP; 354 dSP;
296 XPUSHs (PAD_SV ((PADOFFSET)$target)); 355 SV *sv = PAD_SVl ($padofs);
356EOF
357
358 if (($flags & B::OPf_MOD) && ($op->private & B::OPpLVAL_INTRO)) {
359 $source .= " SAVECLEARSV (PAD_SVl ($padofs));\n";
360 $ops[0]{follows_padsv_lval_intro}++ if @ops;#d#
361 }
362
363 $source .= <<EOF;
364 PUSHs (sv);
297 PUTBACK; 365 PUTBACK;
298EOF 366EOF
299 if ($op->flags & B::OPf_MOD) { 367
300 if ($op->private & B::OPpLVAL_INTRO) { 368 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
301 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n"; 369 $source .= " if (!SvROK (sv)) vivify_ref (sv, " . $op->private . " & OPpDEREF);\n";
302 } elsif ($op->private & B::OPpDEREF) {
303 my $deref = $op->private & B::OPpDEREF;
304 $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
305 }
306 } 370 }
371 $source .= " }\n";
372
373 out_next;
374}
375
376sub op_sassign {
377 $source .= <<EOF;
378 {
379 dSP;
380 dPOPTOPssrl;
381EOF
382 $source .= " SV *temp = left; left = right; right = temp;\n"
383 if $op->private & B::OPpASSIGN_BACKWARDS;
384
385 if ($insn->{follows_padsv_lval_intro} && !($op->private & B::OPpASSIGN_BACKWARDS)) {
386 # simple assignment - the target exists, but is basically undef
387 $source .= " SvSetSV (right, left);\n";
388 } else {
389 $source .= " SvSetMagicSV (right, left);\n";
390 }
391
307 $source .= <<EOF; 392 $source .= <<EOF;
393 SETs (right);
394 PUTBACK;
308 } 395 }
309EOF 396EOF
310 397
311 out_next; 398 out_next;
312} 399}
313 400
314# pattern const+ (or general push1) 401# pattern const+ (or general push1)
315# pattern pushmark return(?)
316# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 402# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
317 403
318# pattern const method_named
319sub op_method_named { 404sub op_method_named {
405 if ($insn->{follows_const}) {
320 $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;
321 { 430 {
322 static HV *last_stash; 431 static HV *last_stash;
323 static SV *last_cv; 432 static SV *last_cv;
324 static U32 last_sub_generation; 433 static U32 last_sub_generation;
325 434
… …
332 441
333 /* simple "polymorphic" inline cache */ 442 /* simple "polymorphic" inline cache */
334 if (stash == last_stash 443 if (stash == last_stash
335 && PL_sub_generation == last_sub_generation) 444 && PL_sub_generation == last_sub_generation)
336 { 445 {
337 XPUSHs (last_cv); 446 PUSHs (last_cv);
338 PUTBACK; 447 PUTBACK;
339 } 448 }
340 else 449 else
341 { 450 {
342 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 451 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
… …
352 /* error case usually */ 461 /* error case usually */
353 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 462 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
354 } 463 }
355 } 464 }
356EOF 465EOF
466 }
357 467
358 out_next; 468 out_next;
359} 469}
360 470
361sub op_grepstart { 471sub op_grepstart {
… …
404 local @op_loop; 514 local @op_loop;
405 local %op_regcomp; 515 local %op_regcomp;
406 516
407 my %opsseen; 517 my %opsseen;
408 my @todo = $cv->START; 518 my @todo = $cv->START;
519 my %op_target;
409 520
410 while (my $op = shift @todo) { 521 while (my $op = shift @todo) {
411 for (; $$op; $op = $op->next) { 522 for (; $$op; $op = $op->next) {
412 last if $opsseen{$$op}++; 523 last if $opsseen{$$op}++;
413 push @ops, $op;
414 524
415 my $name = $op->name; 525 my $name = $op->name;
416 my $class = B::class $op; 526 my $class = B::class $op;
417 527
528 my $insn = { op => $op };
529
530 push @ops, $insn;
531
532 if (exists $extend{$name}) {
533 my $extend = $extend{$name};
534 $extend = $extend->($op) if ref $extend;
535 $insn->{extend} = $extend if defined $extend;
536 }
537
538 push @todo, $op->next;
539
418 if ($class eq "LOGOP") { 540 if ($class eq "LOGOP") {
419 unshift @todo, $op->other; # unshift vs. push saves jumps 541 push @todo, $op->other;
542 $op_target{${$op->other}}++;
420 543
421 # regcomp/o patches ops at runtime, lets expect that 544 # regcomp/o patches ops at runtime, lets expect that
545 if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
546 $op_target{${$op->first}}++;
422 $op_regcomp{${$op->first}} = $op->next 547 $op_regcomp{${$op->first}} = $op->next;
423 if $name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP; 548 }
424 549
425 } elsif ($class eq "PMOP") { 550 } elsif ($class eq "PMOP") {
551 if (${$op->pmreplstart}) {
426 unshift @todo, $op->pmreplstart if ${$op->pmreplstart}; 552 unshift @todo, $op->pmreplstart;
553 $op_target{${$op->pmreplstart}}++;
554 }
427 555
428 } elsif ($class eq "LOOP") { 556 } elsif ($class eq "LOOP") {
429 push @op_loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
430 push @todo, $op->nextop, $op->lastop->next, $op->redoop->next; 557 my @targ = ($op->nextop, $op->lastop->next, $op->redoop->next);
558
559 push @op_loop, \@targ;
560 push @todo, @targ;
561
562 $op_target{$$_}++ for @targ;
563 } elsif ($class eq "COP") {
564 $insn->{bblock}++ if defined $op->label;
431 } 565 }
432 } 566 }
433 } 567 }
568
569 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
434 570
435 local $source = <<EOF; 571 local $source = <<EOF;
436OP *%%%FUNC%%% (pTHX) 572OP *%%%FUNC%%% (pTHX)
437{ 573{
438 register OP *nextop = (OP *)${$ops[0]}L; 574 register OP *nextop = (OP *)${$ops[0]->{op}}L;
439EOF 575EOF
440 576
441 while (@ops) { 577 while (@ops) {
442 $op = shift @ops; 578 $insn = shift @ops;
579
580 $op = $insn->{op};
443 $op_name = $op->name; 581 $op_name = $op->name;
444 582
583 my $class = B::class $op;
584
585 $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
445 $source .= "op_$$op: /* $op_name */\n"; 586 $source .= "op_$$op: /* $op_name */\n";
446 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d# 587 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
447 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d# 588 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
448 589
449 $source .= " PERL_ASYNC_CHECK ();\n" 590 $source .= " PERL_ASYNC_CHECK ();\n"
450 unless exists $f_noasync{$op_name}; 591 unless exists $f_noasync{$op_name};
451 592
452 if (my $can = __PACKAGE__->can ("op_$op_name")) { 593 if (my $can = __PACKAGE__->can ("op_$op_name")) {
453 # handcrafted replacement 594 # handcrafted replacement
595
596 if ($insn->{extend} > 0) {
597 # coalesce EXTENDs
598 # TODO: properly take negative preceeding and following EXTENDs into account
599 for my $i (@ops) {
600 last if exists $i->{bblock};
601 last unless exists $i->{extend};
602 my $extend = delete $i->{extend};
603 $insn->{extend} += $extend if $extend > 0;
604 }
605
606 $source .= " { dSP; EXTEND (SP, $insn->{extend}); PUTBACK; }\n"
607 if $insn->{extend} > 0;
608 }
609
454 $can->($op); 610 $can->($op);
455 611
456 } elsif (exists $f_unsafe{$op_name}) { 612 } elsif (exists $f_unsafe{$op_name}) {
457 # unsafe, return to interpreter 613 # unsafe, return to interpreter
458 assert "nextop == (OP *)$$op"; 614 assert "nextop == (OP *)$$op";
459 $source .= " return nextop;\n"; 615 $source .= " return nextop;\n";
460 616
461 } elsif ("LOGOP" eq B::class $op) { 617 } elsif ("LOGOP" eq $class) {
462 # logical operation with optionaö branch 618 # logical operation with optional branch
463 out_callop; 619 out_callop;
464 out_cond_jump $op->other; 620 out_cond_jump $op->other;
465 out_jump_next; 621 out_jump_next;
466 622
467 } elsif ("PMOP" eq B::class $op) { 623 } elsif ("PMOP" eq $class) {
468 # regex-thingy 624 # regex-thingy
469 out_callop; 625 out_callop;
470 out_cond_jump $op->pmreplroot if ${$op->pmreplroot}; 626 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
471 out_jump_next; 627 out_jump_next;
472 628
473 } else { 629 } else {
474 # normal operator, linear execution 630 # normal operator, linear execution
475 out_linear; 631 out_linear;
… …
487 643
488 $source 644 $source
489} 645}
490 646
491my $uid = "aaaaaaa0"; 647my $uid = "aaaaaaa0";
648my %so;
492 649
493sub source2ptr { 650sub func2ptr {
494 my (@source) = @_; 651 my (@func) = @_;
495 652
496 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: $!";
497 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
498 open FILE, ">:raw", "$stem.c"; 675 open my $fh, ">:raw", "$stem.c";
499 print FILE <<EOF; 676 print $fh <<EOF;
500#define PERL_NO_GET_CONTEXT 677#define PERL_NO_GET_CONTEXT
678#define PERL_CORE
501 679
502#include <assert.h> 680#include <assert.h>
503 681
504#include "EXTERN.h" 682#include "EXTERN.h"
505#include "perl.h" 683#include "perl.h"
506#include "XSUB.h" 684#include "XSUB.h"
507 685
508#define RUNOPS_TILL(op) \\ 686#define RUNOPS_TILL(op) \\
509while (nextop != (op)) \\ 687 while (nextop != (op)) \\
510 { \\ 688 { \\
511 PERL_ASYNC_CHECK (); \\ 689 PERL_ASYNC_CHECK (); \\
512 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\ 690 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
513 }
514
515EOF
516 for (@source) {
517 my $func = $uid++;
518 $_ =~ s/%%%FUNC%%%/$func/g;
519 print FILE $_;
520 $_ = $func;
521 } 691 }
522 692
523 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;
524 system "$COMPILE -o $stem$_o $stem.c"; 705 system "$COMPILE -o $stem$_o $stem.c";
525 #d#unlink "$stem.c"; 706 unlink "$stem.c";
526 system "$LINK -o $stem$_so $stem$_o $LIBS"; 707 system "$LINK -o $stem$_so $stem$_o $LIBS";
527 unlink "$stem$_o"; 708 unlink "$stem$_o";
709 }
528 710
711 for my $f (@func) {
712 my $stem = $f->{so};
713
529 my $so = DynaLoader::dl_load_file "$stem$_so" 714 my $so = ($so{$stem} ||= DynaLoader::dl_load_file "$stem$_so")
530 or die "$stem$_so: $!"; 715 or die "$stem$_so: $!";
531 716
532 #unlink "$stem$_so"; 717 #unlink "$stem$_so";
533 718
534 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)
535} 728}
536 729
537my %ignore; 730my %ignore;
538 731
539sub entersub { 732sub entersub {
… …
541 734
542 my $pkg = $cv->STASH->NAME; 735 my $pkg = $cv->STASH->NAME;
543 736
544 return if $ignore{$pkg}; 737 return if $ignore{$pkg};
545 738
546 warn "compiling ", $cv->STASH->NAME;#d# 739 warn "optimising ", $cv->STASH->NAME, "\n"
740 if $verbose;
547 741
548 eval { 742 eval {
549 my @cv; 743 my @func;
550 my @cv_source; 744
745 push @func, {
746 cv => $cv,
747 name => "<>",
748 source => cv2c $cv,
749 };
551 750
552 # always compile the whole stash 751 # always compile the whole stash
553 my %stash = $cv->STASH->ARRAY; 752 my %stash = $cv->STASH->ARRAY;
554 while (my ($k, $v) = each %stash) { 753 while (my ($k, $v) = each %stash) {
555 $v->isa (B::GV::) 754 $v->isa (B::GV::)
… …
558 my $cv = $v->CV; 757 my $cv = $v->CV;
559 758
560 if ($cv->isa (B::CV::) 759 if ($cv->isa (B::CV::)
561 && ${$cv->START} 760 && ${$cv->START}
562 && $cv->START->name ne "null") { 761 && $cv->START->name ne "null") {
762
563 push @cv, $cv; 763 push @func, {
764 cv => $cv,
765 name => $k,
564 push @cv_source, cv2c $cv; 766 source => cv2c $cv,
767 };
565 } 768 }
566 } 769 }
567 770
568 my @ptr = source2ptr @cv_source; 771 func2ptr @func;
569 772
570 for (0 .. $#cv) { 773 for my $f (@func) {
571 patch_cv $cv[$_], $ptr[$_]; 774 patch_cv $f->{cv}, $f->{ptr};
572 } 775 }
573 }; 776 };
574 777
575 if ($@) { 778 if ($@) {
576 $ignore{$pkg}++; 779 $ignore{$pkg}++;
… …
579} 782}
580 783
581hook_entersub; 784hook_entersub;
582 785
5831; 7861;
787
788=back
789
790=head1 ENVIRONMENT VARIABLES
791
792The following environment variables influence the behaviour of Faster:
793
794=over 4
795
796=item FASTER_VERBOSE
797
798Faster will output more informational messages when set to values higher
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.
802
803=item FASTER_DEBUG
804
805Add debugging code when set to values higher than C<0>. Currently, this
806adds 1-3 C<assert>'s per perl op, to ensure that opcode order and C
807execution order are compatible.
808
809=item FASTER_CACHE
810
811Set a persistent cache directory that caches compiled code fragments. The
812default is C<$HOME/.perl-faster-cache> if C<HOME> is set and a temporary
813directory otherwise.
814
815This directory will always grow in size, so you might need to erase it
816from time to time.
584 817
585=back 818=back
586 819
587=head1 BUGS/LIMITATIONS 820=head1 BUGS/LIMITATIONS
588 821

Diff Legend

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