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

Comparing Faster/Faster.pm (file contents):
Revision 1.19 by root, Fri Mar 10 22:18:39 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
73my %flag; 90# ops that cause immediate return to the interpreter
91my %f_unsafe = map +($_ => undef), qw(
92 leavesub leavesublv return
93 goto last redo next
94 eval flip leaveeval entertry
95 formline grepstart mapstart
96 substcont entereval require
97);
74 98
75# complex flag steting is no longer required, rewrite this ugly code 99# ops with known stack extend behaviour
76for (split /\n/, <<EOF) { 100# the values given are maximum values
77 leavesub unsafe 101my %extend = (
78 leavesublv unsafe 102 pushmark => 0,
79 return unsafe 103 nextstate => 0, # might reduce the stack
80 flip unsafe 104 unstack => 0,
81 goto unsafe 105 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 106
95 mapstart noasync 107 stringify => 0,
96 grepstart noasync 108 not => 0,
97 match noasync 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);
98 144
99 last noasync 145# ops that do not need an ASYNC_CHECK
100 next noasync 146my %f_noasync = map +($_ => undef), qw(
101 redo noasync 147 mapstart grepstart match entereval
102 seq noasync 148 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 delete noasync
141 exists noasync
142 pushre noasync
143 subst noasync
144 const noasync extend=1
145 list noasync
146 join noasync
147 split noasync
148 concat noasync
149 push noasync
150 pop noasync
151 shift noasync
152 unshift noasync
153 length noasync
154 substr noasync
155 stringify noasync
156 eq noasync
157 ne noasync
158 gt noasync
159 lt noasync
160 ge noasync
161 le noasync
162 enteriter noasync
163 ord noasync
164 orassign noasync
165 regcomp noasync
166 regcreset noasync
167 regcmaybe noasync
168 149
169 iter async 150 pushmark nextstate
170EOF
171 my (undef, $op, @flags) = split /\s+/;
172 151
173 undef $flag{$_}{$op} 152 const stub unstack
174 for ("known", @flags); 153 last next redo seq
175} 154 padsv padav padhv padany
155 aassign sassign orassign
156 rv2av rv2cv rv2gv rv2hv refgen
157 gv gvsv
158 add subtract multiply divide
159 complement cond_expr and or not
160 defined
161 method method_named bless
162 preinc postinc predec postdec
163 aelem aelemfast helem delete exists
164 pushre subst list join split concat
165 length substr stringify ord
166 push pop shift unshift
167 eq ne gt lt ge le
168 regcomp regcreset regcmaybe
169);
176 170
177my %callop = ( 171my %callop = (
178 entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)", 172 entersub => "(PL_op->op_ppaddr) (aTHX)",
179 mapstart => "Perl_pp_grepstart (aTHX)", 173 mapstart => "Perl_pp_grepstart (aTHX)",
180); 174);
181 175
182sub callop { 176sub callop {
183 $callop{$op_name} || "Perl_pp_$op_name (aTHX)" 177 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
… …
240 234
241if ($Config{useithreads} ne "define") { 235if ($Config{useithreads} ne "define") {
242 # disable optimisations on ithreads 236 # disable optimisations on ithreads
243 237
244 *op_const = sub { 238 *op_const = sub {
245 $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#
246 242
247 out_next; 243 out_next;
248 }; 244 };
249 245
250 *op_gv = \&op_const; 246 *op_gv = \&op_const;
… …
270 if (!($op->flags & B::OPf_MOD)) { 266 if (!($op->flags & B::OPf_MOD)) {
271 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n"; 267 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
272 } 268 }
273 269
274 $source .= " dSP;\n"; 270 $source .= " dSP;\n";
275 $source .= " XPUSHs (sv);\n"; 271 $source .= " PUSHs (sv);\n";
276 $source .= " PUTBACK;\n"; 272 $source .= " PUTBACK;\n";
277 $source .= " }\n"; 273 $source .= " }\n";
278 274
279 out_next; 275 out_next;
280 }; 276 };
281 277
282 *op_gvsv = sub { 278 *op_gvsv = sub {
283 $source .= " {\n"; 279 $source .= " {\n";
284 $source .= " dSP;\n"; 280 $source .= " dSP;\n";
285 $source .= " EXTEND (SP, 1);\n";
286 281
287 if ($op->private & B::OPpLVAL_INTRO) { 282 if ($op->private & B::OPpLVAL_INTRO) {
288 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n"; 283 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
289 } else { 284 } else {
290 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n"; 285 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
… …
350 out_next; 345 out_next;
351} 346}
352 347
353sub op_padsv { 348sub op_padsv {
354 my $flags = $op->flags; 349 my $flags = $op->flags;
355 my $target = $op->targ; 350 my $padofs = "(PADOFFSET)" . $op->targ;
356 351
357 $source .= <<EOF; 352 $source .= <<EOF;
358 { 353 {
359 dSP; 354 dSP;
360 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);
361 PUTBACK; 365 PUTBACK;
362EOF 366EOF
363 if ($op->flags & B::OPf_MOD) { 367
364 if ($op->private & B::OPpLVAL_INTRO) { 368 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
365 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n"; 369 $source .= " if (!SvROK (sv)) vivify_ref (sv, " . $op->private . " & OPpDEREF);\n";
366 } elsif ($op->private & B::OPpDEREF) {
367 my $deref = $op->private & B::OPpDEREF;
368 $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
369 }
370 } 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
371 $source .= <<EOF; 392 $source .= <<EOF;
393 SETs (right);
394 PUTBACK;
372 } 395 }
373EOF 396EOF
374 397
375 out_next; 398 out_next;
376} 399}
377 400
378# pattern const+ (or general push1) 401# pattern const+ (or general push1)
379# pattern pushmark return(?)
380# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 402# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
381 403
382# pattern const method_named
383sub op_method_named { 404sub op_method_named {
405 if ($insn->{follows_const}) {
384 $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;
385 { 430 {
386 static HV *last_stash; 431 static HV *last_stash;
387 static SV *last_cv; 432 static SV *last_cv;
388 static U32 last_sub_generation; 433 static U32 last_sub_generation;
389 434
… …
396 441
397 /* simple "polymorphic" inline cache */ 442 /* simple "polymorphic" inline cache */
398 if (stash == last_stash 443 if (stash == last_stash
399 && PL_sub_generation == last_sub_generation) 444 && PL_sub_generation == last_sub_generation)
400 { 445 {
401 XPUSHs (last_cv); 446 PUSHs (last_cv);
402 PUTBACK; 447 PUTBACK;
403 } 448 }
404 else 449 else
405 { 450 {
406 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 451 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
… …
416 /* error case usually */ 461 /* error case usually */
417 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 462 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
418 } 463 }
419 } 464 }
420EOF 465EOF
466 }
421 467
422 out_next; 468 out_next;
423} 469}
424 470
425sub op_grepstart { 471sub op_grepstart {
… …
468 local @op_loop; 514 local @op_loop;
469 local %op_regcomp; 515 local %op_regcomp;
470 516
471 my %opsseen; 517 my %opsseen;
472 my @todo = $cv->START; 518 my @todo = $cv->START;
519 my %op_target;
473 520
474 while (my $op = shift @todo) { 521 while (my $op = shift @todo) {
475 for (; $$op; $op = $op->next) { 522 for (; $$op; $op = $op->next) {
476 last if $opsseen{$$op}++; 523 last if $opsseen{$$op}++;
477 push @ops, $op;
478 524
479 my $name = $op->name; 525 my $name = $op->name;
480 my $class = B::class $op; 526 my $class = B::class $op;
481 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
482 if ($class eq "LOGOP") { 540 if ($class eq "LOGOP") {
483 unshift @todo, $op->other; # unshift vs. push saves jumps 541 push @todo, $op->other;
542 $op_target{${$op->other}}++;
484 543
485 # 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}}++;
486 $op_regcomp{${$op->first}} = $op->next 547 $op_regcomp{${$op->first}} = $op->next;
487 if $name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP; 548 }
488 549
489 } elsif ($class eq "PMOP") { 550 } elsif ($class eq "PMOP") {
551 if (${$op->pmreplstart}) {
490 unshift @todo, $op->pmreplstart if ${$op->pmreplstart}; 552 unshift @todo, $op->pmreplstart;
553 $op_target{${$op->pmreplstart}}++;
554 }
491 555
492 } elsif ($class eq "LOOP") { 556 } elsif ($class eq "LOOP") {
493 push @op_loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
494 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;
495 } 565 }
496 } 566 }
497 } 567 }
568
569 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
498 570
499 local $source = <<EOF; 571 local $source = <<EOF;
500OP *%%%FUNC%%% (pTHX) 572OP *%%%FUNC%%% (pTHX)
501{ 573{
502 register OP *nextop = (OP *)${$ops[0]}L; 574 register OP *nextop = (OP *)${$ops[0]->{op}}L;
503EOF 575EOF
504 576
505 while (@ops) { 577 while (@ops) {
506 $op = shift @ops; 578 $insn = shift @ops;
579
580 $op = $insn->{op};
507 $op_name = $op->name; 581 $op_name = $op->name;
508 582
583 my $class = B::class $op;
584
585 $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
509 $source .= "op_$$op: /* $op_name */\n"; 586 $source .= "op_$$op: /* $op_name */\n";
510 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d# 587 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
511 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d# 588 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
512 589
513 $source .= " PERL_ASYNC_CHECK ();\n" 590 $source .= " PERL_ASYNC_CHECK ();\n"
514 unless exists $flag{noasync}{$op_name}; 591 unless exists $f_noasync{$op_name};
515 592
516 if (my $can = __PACKAGE__->can ("op_$op_name")) { 593 if (my $can = __PACKAGE__->can ("op_$op_name")) {
517 # 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
518 $can->($op); 610 $can->($op);
519 611
520 } elsif (exists $flag{unsafe}{$op_name}) { 612 } elsif (exists $f_unsafe{$op_name}) {
521 # unsafe, return to interpreter 613 # unsafe, return to interpreter
522 assert "nextop == (OP *)$$op"; 614 assert "nextop == (OP *)$$op";
523 $source .= " return nextop;\n"; 615 $source .= " return nextop;\n";
524 616
525 } elsif ("LOGOP" eq B::class $op) { 617 } elsif ("LOGOP" eq $class) {
526 # logical operation with optionaö branch 618 # logical operation with optional branch
527 out_callop; 619 out_callop;
528 out_cond_jump $op->other; 620 out_cond_jump $op->other;
529 out_jump_next; 621 out_jump_next;
530 622
531 } elsif ("PMOP" eq B::class $op) { 623 } elsif ("PMOP" eq $class) {
532 # regex-thingy 624 # regex-thingy
533 out_callop; 625 out_callop;
534 out_cond_jump $op->pmreplroot if ${$op->pmreplroot}; 626 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
535 out_jump_next; 627 out_jump_next;
536 628
537 } else { 629 } else {
538 # normal operator, linear execution 630 # normal operator, linear execution
539 out_linear; 631 out_linear;
… …
551 643
552 $source 644 $source
553} 645}
554 646
555my $uid = "aaaaaaa0"; 647my $uid = "aaaaaaa0";
648my %so;
556 649
557sub source2ptr { 650sub func2ptr {
558 my (@source) = @_; 651 my (@func) = @_;
559 652
560 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: $!";
561 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
562 open FILE, ">:raw", "$stem.c"; 675 open my $fh, ">:raw", "$stem.c";
563 print FILE <<EOF; 676 print $fh <<EOF;
564#define PERL_NO_GET_CONTEXT 677#define PERL_NO_GET_CONTEXT
678#define PERL_CORE
565 679
566#include <assert.h> 680#include <assert.h>
567 681
568#include "EXTERN.h" 682#include "EXTERN.h"
569#include "perl.h" 683#include "perl.h"
570#include "XSUB.h" 684#include "XSUB.h"
571 685
572#define RUNOPS_TILL(op) \\ 686#define RUNOPS_TILL(op) \\
573while (nextop != (op)) \\ 687 while (nextop != (op)) \\
574 { \\ 688 { \\
575 PERL_ASYNC_CHECK (); \\ 689 PERL_ASYNC_CHECK (); \\
576 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\ 690 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
577 }
578
579EOF
580 for (@source) {
581 my $func = $uid++;
582 $_ =~ s/%%%FUNC%%%/$func/g;
583 print FILE $_;
584 $_ = $func;
585 } 691 }
586 692
587 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;
588 system "$COMPILE -o $stem$_o $stem.c"; 705 system "$COMPILE -o $stem$_o $stem.c";
589 #d#unlink "$stem.c"; 706 unlink "$stem.c";
590 system "$LINK -o $stem$_so $stem$_o $LIBS"; 707 system "$LINK -o $stem$_so $stem$_o $LIBS";
591 unlink "$stem$_o"; 708 unlink "$stem$_o";
709 }
592 710
711 for my $f (@func) {
712 my $stem = $f->{so};
713
593 my $so = DynaLoader::dl_load_file "$stem$_so" 714 my $so = ($so{$stem} ||= DynaLoader::dl_load_file "$stem$_so")
594 or die "$stem$_so: $!"; 715 or die "$stem$_so: $!";
595 716
596 #unlink "$stem$_so"; 717 #unlink "$stem$_so";
597 718
598 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)
599} 728}
600 729
601my %ignore; 730my %ignore;
602 731
603sub entersub { 732sub entersub {
… …
605 734
606 my $pkg = $cv->STASH->NAME; 735 my $pkg = $cv->STASH->NAME;
607 736
608 return if $ignore{$pkg}; 737 return if $ignore{$pkg};
609 738
610 warn "compiling ", $cv->STASH->NAME;#d# 739 warn "optimising ", $cv->STASH->NAME, "\n"
740 if $verbose;
611 741
612 eval { 742 eval {
613 my @cv; 743 my @func;
614 my @cv_source; 744
745 push @func, {
746 cv => $cv,
747 name => "<>",
748 source => cv2c $cv,
749 };
615 750
616 # always compile the whole stash 751 # always compile the whole stash
617 my %stash = $cv->STASH->ARRAY; 752 my %stash = $cv->STASH->ARRAY;
618 while (my ($k, $v) = each %stash) { 753 while (my ($k, $v) = each %stash) {
619 $v->isa (B::GV::) 754 $v->isa (B::GV::)
… …
622 my $cv = $v->CV; 757 my $cv = $v->CV;
623 758
624 if ($cv->isa (B::CV::) 759 if ($cv->isa (B::CV::)
625 && ${$cv->START} 760 && ${$cv->START}
626 && $cv->START->name ne "null") { 761 && $cv->START->name ne "null") {
762
627 push @cv, $cv; 763 push @func, {
764 cv => $cv,
765 name => $k,
628 push @cv_source, cv2c $cv; 766 source => cv2c $cv,
767 };
629 } 768 }
630 } 769 }
631 770
632 my @ptr = source2ptr @cv_source; 771 func2ptr @func;
633 772
634 for (0 .. $#cv) { 773 for my $f (@func) {
635 patch_cv $cv[$_], $ptr[$_]; 774 patch_cv $f->{cv}, $f->{ptr};
636 } 775 }
637 }; 776 };
638 777
639 if ($@) { 778 if ($@) {
640 $ignore{$pkg}++; 779 $ignore{$pkg}++;
… …
643} 782}
644 783
645hook_entersub; 784hook_entersub;
646 785
6471; 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.
648 817
649=back 818=back
650 819
651=head1 BUGS/LIMITATIONS 820=head1 BUGS/LIMITATIONS
652 821

Diff Legend

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