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

Comparing Faster/Faster.pm (file contents):
Revision 1.21 by root, Fri Mar 10 22:39:11 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
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 = $ENV{FASTER_DEBUG}; 76my $opt_assert = $ENV{FASTER_DEBUG} > 1;
64my $verbose = $ENV{FASTER_VERBOSE}+0; 77my $verbose = $ENV{FASTER_VERBOSE}+0;
65 78
79warn "Faster: CACHEDIR is $CACHEDIR\n" if $verbose > 2;
80
66our $source; 81our $source;
67 82
68our @ops; 83our @ops;
84our $insn;
69our $op; 85our $op;
70our $op_name; 86our $op_name;
71our @op_loop; 87our @op_loop;
72our %op_regcomp; 88our %op_regcomp;
73 89
90# ops that cause immediate return to the interpreter
74my %f_unsafe = map +($_ => undef), qw( 91my %f_unsafe = map +($_ => undef), qw(
75 leavesub leavesublv return 92 leavesub leavesublv return
76 goto last redo next 93 goto last redo next
77 eval flip leaveeval entertry 94 eval flip leaveeval entertry
78 formline grepstart mapstart 95 formline grepstart mapstart
79 substcont entereval require 96 substcont entereval require
80); 97);
81 98
82# pushmark extend=0 99# ops with known stack extend behaviour
83# padsv extend=1 100# the values given are maximum values
84# padav extend=1 101my %extend = (
85# padhv extend=1 102 pushmark => 0,
86# padany extend=1 103 nextstate => 0, # might reduce the stack
87# const extend=1 104 unstack => 0,
105 enter => 0,
88 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
89my %f_noasync = map +($_ => undef), qw( 146my %f_noasync = map +($_ => undef), qw(
90 mapstart grepstart match entereval 147 mapstart grepstart match entereval
91 enteriter entersub leaveloop 148 enteriter entersub leaveloop
92 149
93 pushmark nextstate 150 pushmark nextstate caller
94 151
95 const stub unstack 152 const stub unstack
96 last next redo seq 153 last next redo goto seq
97 padsv padav padhv padany 154 padsv padav padhv padany
98 aassign sassign orassign 155 aassign sassign orassign
99 rv2av rv2cv rv2gv rv2hv refgen 156 rv2av rv2cv rv2gv rv2hv refgen
100 gv gvsv 157 gv gvsv
101 add subtract multiply divide 158 add subtract multiply divide
102 complement cond_expr and or not 159 complement cond_expr and or not bit_and bit_or bit_xor
103 defined 160 defined
104 method_named 161 method method_named bless
105 preinc postinc predec postdec 162 preinc postinc predec postdec
106 aelem aelemfast helem delete exists 163 aelem aelemfast helem delete exists
107 pushre subst list join split concat 164 pushre subst list lslice join split concat
108 length substr stringify ord 165 length substr stringify ord
109 push pop shift unshift 166 push pop shift unshift
110 eq ne gt lt ge le 167 eq ne gt lt ge le
111 regcomp regcreset regcmaybe 168 regcomp regcreset regcmaybe
112); 169);
113 170
114my %callop = ( 171my %callop = (
115 entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)", 172 entersub => "(PL_op->op_ppaddr) (aTHX)",
116 mapstart => "Perl_pp_grepstart (aTHX)", 173 mapstart => "Perl_pp_grepstart (aTHX)",
117); 174);
118 175
119sub callop { 176sub callop {
120 $callop{$op_name} || "Perl_pp_$op_name (aTHX)" 177 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
… …
168 225
169 out_next; 226 out_next;
170} 227}
171 228
172sub op_pushmark { 229sub op_pushmark {
173 $source .= " PUSHMARK (PL_stack_sp);\n"; 230 $source .= " faster_PUSHMARK (PL_stack_sp);\n";
174 231
175 out_next; 232 out_next;
176} 233}
177 234
178if ($Config{useithreads} ne "define") { 235if ($Config{useithreads} ne "define") {
179 # disable optimisations on ithreads 236 # disable optimisations on ithreads
180 237
181 *op_const = sub { 238 *op_const = sub {
182 $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#
183 242
184 out_next; 243 out_next;
185 }; 244 };
186 245
187 *op_gv = \&op_const; 246 *op_gv = \&op_const;
… …
207 if (!($op->flags & B::OPf_MOD)) { 266 if (!($op->flags & B::OPf_MOD)) {
208 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n"; 267 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
209 } 268 }
210 269
211 $source .= " dSP;\n"; 270 $source .= " dSP;\n";
212 $source .= " XPUSHs (sv);\n"; 271 $source .= " PUSHs (sv);\n";
213 $source .= " PUTBACK;\n"; 272 $source .= " PUTBACK;\n";
214 $source .= " }\n"; 273 $source .= " }\n";
215 274
216 out_next; 275 out_next;
217 }; 276 };
218 277
219 *op_gvsv = sub { 278 *op_gvsv = sub {
220 $source .= " {\n"; 279 $source .= " {\n";
221 $source .= " dSP;\n"; 280 $source .= " dSP;\n";
222 $source .= " EXTEND (SP, 1);\n";
223 281
224 if ($op->private & B::OPpLVAL_INTRO) { 282 if ($op->private & B::OPpLVAL_INTRO) {
225 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n"; 283 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
226 } else { 284 } else {
227 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n"; 285 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
… …
287 out_next; 345 out_next;
288} 346}
289 347
290sub op_padsv { 348sub op_padsv {
291 my $flags = $op->flags; 349 my $flags = $op->flags;
292 my $targ = $op->targ; 350 my $padofs = "(PADOFFSET)" . $op->targ;
293 351
294 $source .= <<EOF; 352 $source .= <<EOF;
295 { 353 {
296 dSP; 354 dSP;
297 XPUSHs (PAD_SV ((PADOFFSET)$targ)); 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);
298 PUTBACK; 365 PUTBACK;
299EOF 366EOF
300 if ($op->flags & B::OPf_MOD) { 367
301 if ($op->private & B::OPpLVAL_INTRO) { 368 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
302 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$targ));\n"; 369 $source .= " if (!SvROK (sv)) vivify_ref (sv, " . $op->private . " & OPpDEREF);\n";
303 } elsif ($op->private & B::OPpDEREF) {
304 my $deref = $op->private & B::OPpDEREF;
305 $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$targ), $deref);\n";
306 }
307 } 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
308 $source .= <<EOF; 392 $source .= <<EOF;
393 SETs (right);
394 PUTBACK;
309 } 395 }
310EOF 396EOF
311 397
312 out_next; 398 out_next;
313} 399}
314 400
315# pattern const+ (or general push1) 401# pattern const+ (or general push1)
316# pattern pushmark return(?)
317# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 402# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
318 403
319# pattern const method_named
320sub op_method_named { 404sub op_method_named {
405 if ($insn->{follows_const}) {
321 $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;
322 { 430 {
323 static HV *last_stash; 431 static HV *last_stash;
324 static SV *last_cv; 432 static SV *last_cv;
325 static U32 last_sub_generation; 433 static U32 last_sub_generation;
326 434
… …
333 441
334 /* simple "polymorphic" inline cache */ 442 /* simple "polymorphic" inline cache */
335 if (stash == last_stash 443 if (stash == last_stash
336 && PL_sub_generation == last_sub_generation) 444 && PL_sub_generation == last_sub_generation)
337 { 445 {
338 XPUSHs (last_cv); 446 PUSHs (last_cv);
339 PUTBACK; 447 PUTBACK;
340 } 448 }
341 else 449 else
342 { 450 {
343 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 451 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
… …
353 /* error case usually */ 461 /* error case usually */
354 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 462 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
355 } 463 }
356 } 464 }
357EOF 465EOF
466 }
358 467
359 out_next; 468 out_next;
360} 469}
361 470
362sub op_grepstart { 471sub op_grepstart {
… …
405 local @op_loop; 514 local @op_loop;
406 local %op_regcomp; 515 local %op_regcomp;
407 516
408 my %opsseen; 517 my %opsseen;
409 my @todo = $cv->START; 518 my @todo = $cv->START;
519 my %op_target;
520 my $numpushmark;
410 521
411 while (my $op = shift @todo) { 522 while (my $op = shift @todo) {
412 for (; $$op; $op = $op->next) { 523 for (; $$op; $op = $op->next) {
413 last if $opsseen{$$op}++; 524 last if $opsseen{$$op}++;
414 push @ops, $op;
415 525
416 my $name = $op->name; 526 my $name = $op->name;
417 my $class = B::class $op; 527 my $class = B::class $op;
418 528
529 my $insn = { op => $op };
530
531 push @ops, $insn;
532
533 if (exists $extend{$name}) {
534 my $extend = $extend{$name};
535 $extend = $extend->($op) if ref $extend;
536 $insn->{extend} = $extend if defined $extend;
537 }
538
539 push @todo, $op->next;
540
419 if ($class eq "LOGOP") { 541 if ($class eq "LOGOP") {
420 unshift @todo, $op->other; # unshift vs. push saves jumps 542 push @todo, $op->other;
543 $op_target{${$op->other}}++;
421 544
422 # regcomp/o patches ops at runtime, lets expect that 545 # regcomp/o patches ops at runtime, lets expect that
546 if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
547 $op_target{${$op->first}}++;
423 $op_regcomp{${$op->first}} = $op->next 548 $op_regcomp{${$op->first}} = $op->next;
424 if $name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP; 549 }
425 550
426 } elsif ($class eq "PMOP") { 551 } elsif ($class eq "PMOP") {
552 if (${$op->pmreplstart}) {
427 unshift @todo, $op->pmreplstart if ${$op->pmreplstart}; 553 unshift @todo, $op->pmreplstart;
554 $op_target{${$op->pmreplstart}}++;
555 }
428 556
429 } elsif ($class eq "LOOP") { 557 } elsif ($class eq "LOOP") {
430 push @op_loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
431 push @todo, $op->nextop, $op->lastop->next, $op->redoop->next; 558 my @targ = ($op->nextop, $op->lastop->next, $op->redoop->next);
559
560 push @op_loop, \@targ;
561 push @todo, @targ;
562
563 $op_target{$$_}++ for @targ;
564
565 } elsif ($class eq "COP") {
566 $insn->{bblock}++ if defined $op->label;
567
568 } else {
569 if ($name eq "pushmark") {
570 $numpushmark++;
571 }
432 } 572 }
433 } 573 }
434 } 574 }
575
576 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
435 577
436 local $source = <<EOF; 578 local $source = <<EOF;
437OP *%%%FUNC%%% (pTHX) 579OP *%%%FUNC%%% (pTHX)
438{ 580{
439 register OP *nextop = (OP *)${$ops[0]}L; 581 register OP *nextop = (OP *)${$ops[0]->{op}}L;
440EOF 582EOF
583
584 $source .= " faster_PUSHMARK_PREALLOC ($numpushmark);\n"
585 if $numpushmark;
441 586
442 while (@ops) { 587 while (@ops) {
443 $op = shift @ops; 588 $insn = shift @ops;
589
590 $op = $insn->{op};
444 $op_name = $op->name; 591 $op_name = $op->name;
445 592
593 my $class = B::class $op;
594
595 $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
446 $source .= "op_$$op: /* $op_name */\n"; 596 $source .= "op_$$op: /* $op_name */\n";
447 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d# 597 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
448 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d# 598 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
449 599
450 $source .= " PERL_ASYNC_CHECK ();\n" 600 $source .= " PERL_ASYNC_CHECK ();\n"
451 unless exists $f_noasync{$op_name}; 601 unless exists $f_noasync{$op_name};
452 602
453 if (my $can = __PACKAGE__->can ("op_$op_name")) { 603 if (my $can = __PACKAGE__->can ("op_$op_name")) {
454 # handcrafted replacement 604 # handcrafted replacement
605
606 if ($insn->{extend} > 0) {
607 # coalesce EXTENDs
608 # TODO: properly take negative preceeding and following EXTENDs into account
609 for my $i (@ops) {
610 last if exists $i->{bblock};
611 last unless exists $i->{extend};
612 my $extend = delete $i->{extend};
613 $insn->{extend} += $extend if $extend > 0;
614 }
615
616 $source .= " { dSP; EXTEND (SP, $insn->{extend}); PUTBACK; }\n"
617 if $insn->{extend} > 0;
618 }
619
455 $can->($op); 620 $can->($op);
456 621
457 } elsif (exists $f_unsafe{$op_name}) { 622 } elsif (exists $f_unsafe{$op_name}) {
458 # unsafe, return to interpreter 623 # unsafe, return to interpreter
459 assert "nextop == (OP *)$$op"; 624 assert "nextop == (OP *)$$op";
460 $source .= " return nextop;\n"; 625 $source .= " return nextop;\n";
461 626
462 } elsif ("LOGOP" eq B::class $op) { 627 } elsif ("LOGOP" eq $class) {
463 # logical operation with optionaö branch 628 # logical operation with optional branch
464 out_callop; 629 out_callop;
465 out_cond_jump $op->other; 630 out_cond_jump $op->other;
466 out_jump_next; 631 out_jump_next;
467 632
468 } elsif ("PMOP" eq B::class $op) { 633 } elsif ("PMOP" eq $class) {
469 # regex-thingy 634 # regex-thingy
470 out_callop; 635 out_callop;
471 out_cond_jump $op->pmreplroot if ${$op->pmreplroot}; 636 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
472 out_jump_next; 637 out_jump_next;
473 638
474 } else { 639 } else {
475 # normal operator, linear execution 640 # normal operator, linear execution
476 out_linear; 641 out_linear;
… …
488 653
489 $source 654 $source
490} 655}
491 656
492my $uid = "aaaaaaa0"; 657my $uid = "aaaaaaa0";
658my %so;
493 659
494sub source2ptr { 660sub func2ptr {
495 my (@source) = @_; 661 my (@func) = @_;
496 662
497 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: $!";
498 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
499 open FILE, ">:raw", "$stem.c"; 685 open my $fh, ">:raw", "$stem.c";
500 print FILE <<EOF; 686 print $fh <<EOF;
501#define PERL_NO_GET_CONTEXT 687#define PERL_NO_GET_CONTEXT
688#define PERL_CORE
502 689
503#include <assert.h> 690#include <assert.h>
504 691
505#include "EXTERN.h" 692#include "EXTERN.h"
506#include "perl.h" 693#include "perl.h"
507#include "XSUB.h" 694#include "XSUB.h"
508 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
509#define RUNOPS_TILL(op) \\ 704#define RUNOPS_TILL(op) \\
510while (nextop != (op)) \\ 705 while (nextop != (op)) \\
511 { \\ 706 { \\
512 PERL_ASYNC_CHECK (); \\ 707 PERL_ASYNC_CHECK (); \\
513 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\ 708 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
514 }
515
516EOF
517 for (@source) {
518 my $func = $uid++;
519 $_ =~ s/%%%FUNC%%%/$func/g;
520 print FILE $_;
521 $_ = $func;
522 } 709 }
523 710
524 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;
525 system "$COMPILE -o $stem$_o $stem.c"; 723 system "$COMPILE -o $stem$_o $stem.c";
526 #d#unlink "$stem.c"; 724 unlink "$stem.c" unless $ENV{FASTER_DEBUG} > 0;
527 system "$LINK -o $stem$_so $stem$_o $LIBS"; 725 system "$LINK -o $stem$_so $stem$_o $LIBS";
528 unlink "$stem$_o"; 726 unlink "$stem$_o";
727 }
529 728
729 for my $f (@func) {
730 my $stem = $f->{so};
731
530 my $so = DynaLoader::dl_load_file "$stem$_so" 732 my $so = ($so{$stem} ||= DynaLoader::dl_load_file "$stem$_so")
531 or die "$stem$_so: $!"; 733 or die "$stem$_so: $!";
532 734
533 #unlink "$stem$_so"; 735 #unlink "$stem$_so";
534 736
535 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)
536} 746}
537 747
538my %ignore; 748my %ignore;
539 749
540sub entersub { 750sub entersub {
… …
542 752
543 my $pkg = $cv->STASH->NAME; 753 my $pkg = $cv->STASH->NAME;
544 754
545 return if $ignore{$pkg}; 755 return if $ignore{$pkg};
546 756
547 warn "compiling ", $cv->STASH->NAME, "\n" 757 warn "optimising ", $cv->STASH->NAME, "\n"
548 if $verbose; 758 if $verbose;
549 759
550 eval { 760 eval {
551 my @cv; 761 my @func;
552 my @cv_source; 762
763 push @func, {
764 cv => $cv,
765 name => "<>",
766 source => cv2c $cv,
767 };
553 768
554 # always compile the whole stash 769 # always compile the whole stash
555 my %stash = $cv->STASH->ARRAY; 770 my %stash = $cv->STASH->ARRAY;
556 while (my ($k, $v) = each %stash) { 771 while (my ($k, $v) = each %stash) {
557 $v->isa (B::GV::) 772 $v->isa (B::GV::)
… …
560 my $cv = $v->CV; 775 my $cv = $v->CV;
561 776
562 if ($cv->isa (B::CV::) 777 if ($cv->isa (B::CV::)
563 && ${$cv->START} 778 && ${$cv->START}
564 && $cv->START->name ne "null") { 779 && $cv->START->name ne "null") {
780
565 push @cv, $cv; 781 push @func, {
782 cv => $cv,
783 name => $k,
566 push @cv_source, cv2c $cv; 784 source => cv2c $cv,
785 };
567 } 786 }
568 } 787 }
569 788
570 my @ptr = source2ptr @cv_source; 789 func2ptr @func;
571 790
572 for (0 .. $#cv) { 791 for my $f (@func) {
573 patch_cv $cv[$_], $ptr[$_]; 792 patch_cv $f->{cv}, $f->{ptr};
574 } 793 }
575 }; 794 };
576 795
577 if ($@) { 796 if ($@) {
578 $ignore{$pkg}++; 797 $ignore{$pkg}++;
… …
593=over 4 812=over 4
594 813
595=item FASTER_VERBOSE 814=item FASTER_VERBOSE
596 815
597Faster will output more informational messages when set to values higher 816Faster will output more informational messages when set to values higher
598than 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.
599 820
600=item FASTER_DEBUG 821=item FASTER_DEBUG
601 822
602Add 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
603adds 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
604execution order are compatible. 825order and C execution order are compatible.
605 826
606=item FASTER_CACHE 827=item FASTER_CACHE
607 828
608NOT YET IMPLEMENTED
609
610Set a persistent cache directory that caches compiled code 829Set a persistent cache directory that caches compiled code fragments. The
611fragments. Normally, code compiled by Faster will be deleted immediately, 830default is C<$HOME/.perl-faster-cache> if C<HOME> is set and a temporary
612and every restart will recompile everything. Setting this variable to a 831directory otherwise.
613directory makes Faster cache the generated files for re-use.
614 832
615This 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
616from time to time. 834from time to time.
617 835
618=back 836=back
619 837
620=head1 BUGS/LIMITATIONS 838=head1 BUGS/LIMITATIONS

Diff Legend

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