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

Comparing Faster/Faster.pm (file contents):
Revision 1.23 by root, Fri Mar 10 22:45:18 2006 UTC vs.
Revision 1.33 by root, Mon Mar 13 17:10:32 2006 UTC

… …
8 8
9 perl -MFaster ... 9 perl -MFaster ...
10 10
11=head1 DESCRIPTION 11=head1 DESCRIPTION
12 12
13This module implements a very simple-minded JIT. It works by more or less 13This module implements a very simple-minded "JIT" (or actually AIT, ahead
14translating every function it sees into a C program, compiling it and then 14of time compiler). It works by more or less translating every function it
15replacing the function by the compiled code. 15sees into a C program, compiling it and then replacing the function by the
16compiled code.
16 17
17As a result, startup times are immense, as every function might lead to a 18As a result, startup times are immense, as every function might lead to a
18full-blown compilation. 19full-blown compilation.
19 20
20The speed improvements are also not great, you can expect 20% or so on 21The speed improvements are also not great, you can expect 20% or so on
21average, for code that runs very often. 22average, for code that runs very often. The reason for this is that data
23handling is mostly being done by the same old code, it just gets called
24a bit faster. Regexes and string operations won't get faster. Airhtmetic
25doresn't become any faster. Just the operands and other stuff is put on
26the stack faster, and the opcodes themselves have a bit less overhead.
22 27
23Faster is in the early stages of development. Due to its design its 28Faster is in the early stages of development. Due to its design its
24relatively safe to use (it will either work or simply slowdown the program 29relatively safe to use (it will either work or simply slowdown the program
25immensely, but rarely cause bugs). 30immensely, but rarely cause bugs).
26 31
32More intelligent algorithms (loop optimisation, type inference) could
33improve that easily, but requires a much more elaborate presentation and
34optimiser than what is in place. There are no plans to improve Faster in
35this way, yet, but it would provide a reasonably good place to start.
36
27Usage is very easy, just C<use Faster> and every function called from then 37Usage is very easy, just C<use Faster> and every function called from then
28on will be compiled. 38on will be compiled.
29 39
30Right now, Faster will leave lots of F<*.c>, F<*.o> and F<*.so> files in 40Right now, Faster can leave lots of F<*.c> and F<*.so> files in your
31F</tmp>, and it will even create those temporary files in an insecure 41F<$FASTER_CACHEDIR> (by default F<$HOME/.perl-faster-cache>), and it will
32manner, so watch out. 42even create those temporary files in an insecure manner, so watch out.
33 43
34=over 4 44=over 4
35 45
36=cut 46=cut
37 47
38package Faster; 48package Faster;
49
50no warnings;
39 51
40use strict; 52use strict;
41use Config; 53use Config;
42use B (); 54use B ();
43#use Digest::MD5 ();
44use DynaLoader (); 55use DynaLoader ();
45use File::Temp (); 56use Digest::MD5 ();
57use Storable ();
58use Fcntl ();
46 59
47BEGIN { 60BEGIN {
48 our $VERSION = '0.01'; 61 our $VERSION = '0.01';
49 62
50 require XSLoader; 63 require XSLoader;
51 XSLoader::load __PACKAGE__, $VERSION; 64 XSLoader::load __PACKAGE__, $VERSION;
52} 65}
66
67my $CACHEDIR =
68 $ENV{FASTER_CACHE}
69 || (exists $ENV{HOME} && "$ENV{HOME}/.perl-faster-cache")
70 || do {
71 require File::Temp;
72 File::Temp::tempdir (CLEANUP => 1)
73 };
53 74
54my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}"; 75my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}";
55my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}"; 76my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
56my $LIBS = "$Config{libs}"; 77my $LIBS = "$Config{libs}";
57my $_o = $Config{_o}; 78my $_o = $Config{_o};
… …
59 80
60# we don't need no steenking PIC on x86 81# we don't need no steenking PIC on x86
61$COMPILE =~ s/-f(?:PIC|pic)//g 82$COMPILE =~ s/-f(?:PIC|pic)//g
62 if $Config{archname} =~ /^(i[3456]86)-/; 83 if $Config{archname} =~ /^(i[3456]86)-/;
63 84
64my $opt_assert = $ENV{FASTER_DEBUG}; 85my $opt_assert = $ENV{FASTER_DEBUG} > 1;
65my $verbose = $ENV{FASTER_VERBOSE}+0; 86my $verbose = $ENV{FASTER_VERBOSE}+0;
66 87
88warn "Faster: CACHEDIR is $CACHEDIR\n" if $verbose > 2;
89
67our $source; 90our $source;
68 91
69our @ops; 92our @ops;
93our $insn;
70our $op; 94our $op;
71our $op_name; 95our $op_name;
72our @op_loop; 96our @op_loop;
73our %op_regcomp; 97our %op_regcomp;
74 98
99# ops that cause immediate return to the interpreter
75my %f_unsafe = map +($_ => undef), qw( 100my %f_unsafe = map +($_ => undef), qw(
76 leavesub leavesublv return 101 leavesub leavesublv return
77 goto last redo next 102 goto last redo next
78 eval flip leaveeval entertry 103 eval flip leaveeval entertry
79 formline grepstart mapstart 104 formline grepstart mapstart
80 substcont entereval require 105 substcont entereval require
81); 106);
82 107
83# pushmark extend=0 108# ops with known stack extend behaviour
84# padsv extend=1 109# the values given are maximum values
85# padav extend=1 110my %extend = (
86# padhv extend=1 111 pushmark => 0,
87# padany extend=1 112 nextstate => 0, # might reduce the stack
88# const extend=1 113 unstack => 0,
114 enter => 0,
89 115
116 stringify => 0,
117 not => 0,
118 and => 0,
119 or => 0,
120 gvsv => 0,
121 rv2gv => 0,
122 preinc => 0,
123 predec => 0,
124 postinc => 0,
125 postdec => 0,
126 aelem => 0,
127 helem => 0,
128 qr => 1, #???
129 pushre => 1,
130 gv => 1,
131 aelemfast => 1,
132 aelem => 0,
133 padsv => 1,
134 const => 1,
135 pop => 1,
136 shift => 1,
137 eq => -1,
138 ne => -1,
139 gt => -1,
140 lt => -1,
141 ge => -1,
142 lt => -1,
143 cond_expr => -1,
144 add => -1,
145 subtract => -1,
146 multiply => -1,
147 divide => -1,
148 aassign => 0,
149 sassign => -2,
150 method => 0,
151 method_named => 1,
152);
153
154# ops that do not need an ASYNC_CHECK
90my %f_noasync = map +($_ => undef), qw( 155my %f_noasync = map +($_ => undef), qw(
91 mapstart grepstart match entereval 156 mapstart grepstart match entereval
92 enteriter entersub leaveloop 157 enteriter entersub leaveloop
93 158
94 pushmark nextstate 159 pushmark nextstate caller
95 160
96 const stub unstack 161 const stub unstack
97 last next redo seq 162 last next redo goto seq
98 padsv padav padhv padany 163 padsv padav padhv padany
99 aassign sassign orassign 164 aassign sassign orassign
100 rv2av rv2cv rv2gv rv2hv refgen 165 rv2av rv2cv rv2gv rv2hv refgen
101 gv gvsv 166 gv gvsv
102 add subtract multiply divide 167 add subtract multiply divide
103 complement cond_expr and or not 168 complement cond_expr and or not
169 bit_and bit_or bit_xor
104 defined 170 defined
105 method_named 171 method method_named bless
106 preinc postinc predec postdec 172 preinc postinc predec postdec
107 aelem aelemfast helem delete exists 173 aelem aelemfast helem delete exists
108 pushre subst list join split concat 174 pushre subst list lslice join split concat
109 length substr stringify ord 175 length substr stringify ord
110 push pop shift unshift 176 push pop shift unshift
111 eq ne gt lt ge le 177 eq ne gt lt ge le
112 regcomp regcreset regcmaybe 178 regcomp regcreset regcmaybe
113); 179);
114 180
115my %callop = ( 181my %callop = (
116 entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)", 182 entersub => "(PL_op->op_ppaddr) (aTHX)",
117 mapstart => "Perl_pp_grepstart (aTHX)", 183 mapstart => "Perl_pp_grepstart (aTHX)",
118); 184);
119 185
120sub callop { 186sub callop {
121 $callop{$op_name} || "Perl_pp_$op_name (aTHX)" 187 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
… …
169 235
170 out_next; 236 out_next;
171} 237}
172 238
173sub op_pushmark { 239sub op_pushmark {
174 $source .= " PUSHMARK (PL_stack_sp);\n"; 240 $source .= " faster_PUSHMARK (PL_stack_sp);\n";
175 241
176 out_next; 242 out_next;
177} 243}
178 244
179if ($Config{useithreads} ne "define") { 245if ($Config{useithreads} ne "define") {
180 # disable optimisations on ithreads 246 # disable optimisations on ithreads
181 247
182 *op_const = sub { 248 *op_const = sub {
183 $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n"; 249 $source .= " { dSP; PUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
250
251 $ops[0]{follows_const}++ if @ops;#d#
184 252
185 out_next; 253 out_next;
186 }; 254 };
187 255
188 *op_gv = \&op_const; 256 *op_gv = \&op_const;
… …
208 if (!($op->flags & B::OPf_MOD)) { 276 if (!($op->flags & B::OPf_MOD)) {
209 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n"; 277 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
210 } 278 }
211 279
212 $source .= " dSP;\n"; 280 $source .= " dSP;\n";
213 $source .= " XPUSHs (sv);\n"; 281 $source .= " PUSHs (sv);\n";
214 $source .= " PUTBACK;\n"; 282 $source .= " PUTBACK;\n";
215 $source .= " }\n"; 283 $source .= " }\n";
216 284
217 out_next; 285 out_next;
218 }; 286 };
219 287
220 *op_gvsv = sub { 288 *op_gvsv = sub {
221 $source .= " {\n"; 289 $source .= " {\n";
222 $source .= " dSP;\n"; 290 $source .= " dSP;\n";
223 $source .= " EXTEND (SP, 1);\n";
224 291
225 if ($op->private & B::OPpLVAL_INTRO) { 292 if ($op->private & B::OPpLVAL_INTRO) {
226 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n"; 293 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
227 } else { 294 } else {
228 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n"; 295 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
… …
288 out_next; 355 out_next;
289} 356}
290 357
291sub op_padsv { 358sub op_padsv {
292 my $flags = $op->flags; 359 my $flags = $op->flags;
293 my $targ = $op->targ; 360 my $padofs = "(PADOFFSET)" . $op->targ;
294 361
295 $source .= <<EOF; 362 $source .= <<EOF;
296 { 363 {
297 dSP; 364 dSP;
298 XPUSHs (PAD_SV ((PADOFFSET)$targ)); 365 SV *sv = PAD_SVl ($padofs);
366EOF
367
368 if (($flags & B::OPf_MOD) && ($op->private & B::OPpLVAL_INTRO)) {
369 $source .= " SAVECLEARSV (PAD_SVl ($padofs));\n";
370 $ops[0]{follows_padsv_lval_intro}++ if @ops;#d#
371 }
372
373 $source .= <<EOF;
374 PUSHs (sv);
299 PUTBACK; 375 PUTBACK;
300EOF 376EOF
301 if ($op->flags & B::OPf_MOD) { 377
302 if ($op->private & B::OPpLVAL_INTRO) { 378 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
303 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$targ));\n"; 379 $source .= " if (!SvROK (sv)) vivify_ref (sv, " . $op->private . " & OPpDEREF);\n";
304 } elsif ($op->private & B::OPpDEREF) {
305 my $deref = $op->private & B::OPpDEREF;
306 $source .= " Perl_vivify_ref (aTHX_ PAD_SVl ((PADOFFSET)$targ), $deref);\n";
307 }
308 } 380 }
381 $source .= " }\n";
382
383 out_next;
384}
385
386sub op_sassign {
387 $source .= <<EOF;
388 {
389 dSP;
390 dPOPTOPssrl;
391EOF
392 $source .= " SV *temp = left; left = right; right = temp;\n"
393 if $op->private & B::OPpASSIGN_BACKWARDS;
394
395 if ($insn->{follows_padsv_lval_intro} && !($op->private & B::OPpASSIGN_BACKWARDS)) {
396 # simple assignment - the target exists, but is basically undef
397 $source .= " SvSetSV (right, left);\n";
398 } else {
399 $source .= " SvSetMagicSV (right, left);\n";
400 }
401
309 $source .= <<EOF; 402 $source .= <<EOF;
403 SETs (right);
404 PUTBACK;
310 } 405 }
311EOF 406EOF
312 407
313 out_next; 408 out_next;
314} 409}
315 410
316# pattern const+ (or general push1) 411# pattern const+ (or general push1)
317# pattern pushmark return(?)
318# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 412# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
319 413
320# pattern const method_named
321sub op_method_named { 414sub op_method_named {
415 if ($insn->{follows_const}) {
322 $source .= <<EOF; 416 $source .= <<EOF;
417 {
418 dSP;
419 static SV *last_cv;
420 static U32 last_sub_generation;
421
422 /* simple "polymorphic" inline cache */
423 if (PL_sub_generation == last_sub_generation)
424 {
425 PUSHs (last_cv);
426 PUTBACK;
427 }
428 else
429 {
430 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
431
432 SPAGAIN;
433 last_sub_generation = PL_sub_generation;
434 last_cv = TOPs;
435 }
436 }
437EOF
438 } else {
439 $source .= <<EOF;
323 { 440 {
324 static HV *last_stash; 441 static HV *last_stash;
325 static SV *last_cv; 442 static SV *last_cv;
326 static U32 last_sub_generation; 443 static U32 last_sub_generation;
327 444
… …
334 451
335 /* simple "polymorphic" inline cache */ 452 /* simple "polymorphic" inline cache */
336 if (stash == last_stash 453 if (stash == last_stash
337 && PL_sub_generation == last_sub_generation) 454 && PL_sub_generation == last_sub_generation)
338 { 455 {
339 XPUSHs (last_cv); 456 PUSHs (last_cv);
340 PUTBACK; 457 PUTBACK;
341 } 458 }
342 else 459 else
343 { 460 {
344 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 461 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
… …
354 /* error case usually */ 471 /* error case usually */
355 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 472 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
356 } 473 }
357 } 474 }
358EOF 475EOF
476 }
359 477
360 out_next; 478 out_next;
361} 479}
362 480
363sub op_grepstart { 481sub op_grepstart {
… …
406 local @op_loop; 524 local @op_loop;
407 local %op_regcomp; 525 local %op_regcomp;
408 526
409 my %opsseen; 527 my %opsseen;
410 my @todo = $cv->START; 528 my @todo = $cv->START;
529 my %op_target;
530 my $numpushmark;
411 531
412 while (my $op = shift @todo) { 532 while (my $op = shift @todo) {
413 for (; $$op; $op = $op->next) { 533 for (; $$op; $op = $op->next) {
414 last if $opsseen{$$op}++; 534 last if $opsseen{$$op}++;
415 push @ops, $op;
416 535
417 my $name = $op->name; 536 my $name = $op->name;
418 my $class = B::class $op; 537 my $class = B::class $op;
419 538
539 my $insn = { op => $op };
540
541 push @ops, $insn;
542
543 if (exists $extend{$name}) {
544 my $extend = $extend{$name};
545 $extend = $extend->($op) if ref $extend;
546 $insn->{extend} = $extend if defined $extend;
547 }
548
549 push @todo, $op->next;
550
420 if ($class eq "LOGOP") { 551 if ($class eq "LOGOP") {
421 unshift @todo, $op->other; # unshift vs. push saves jumps 552 push @todo, $op->other;
553 $op_target{${$op->other}}++;
422 554
423 # regcomp/o patches ops at runtime, lets expect that 555 # regcomp/o patches ops at runtime, lets expect that
556 if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
557 $op_target{${$op->first}}++;
424 $op_regcomp{${$op->first}} = $op->next 558 $op_regcomp{${$op->first}} = $op->next;
425 if $name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP; 559 }
426 560
427 } elsif ($class eq "PMOP") { 561 } elsif ($class eq "PMOP") {
562 if (${$op->pmreplstart}) {
428 unshift @todo, $op->pmreplstart if ${$op->pmreplstart}; 563 unshift @todo, $op->pmreplstart;
564 $op_target{${$op->pmreplstart}}++;
565 }
429 566
430 } elsif ($class eq "LOOP") { 567 } elsif ($class eq "LOOP") {
431 push @op_loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
432 push @todo, $op->nextop, $op->lastop->next, $op->redoop->next; 568 my @targ = ($op->nextop, $op->lastop->next, $op->redoop->next);
569
570 push @op_loop, \@targ;
571 push @todo, @targ;
572
573 $op_target{$$_}++ for @targ;
574
575 } elsif ($class eq "COP") {
576 $insn->{bblock}++ if defined $op->label;
577
578 } else {
579 if ($name eq "pushmark") {
580 $numpushmark++;
581 }
433 } 582 }
434 } 583 }
435 } 584 }
585
586 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
436 587
437 local $source = <<EOF; 588 local $source = <<EOF;
438OP *%%%FUNC%%% (pTHX) 589OP *%%%FUNC%%% (pTHX)
439{ 590{
440 register OP *nextop = (OP *)${$ops[0]}L; 591 register OP *nextop = (OP *)${$ops[0]->{op}}L;
441EOF 592EOF
593
594 $source .= " faster_PUSHMARK_PREALLOC ($numpushmark);\n"
595 if $numpushmark;
442 596
443 while (@ops) { 597 while (@ops) {
444 $op = shift @ops; 598 $insn = shift @ops;
599
600 $op = $insn->{op};
445 $op_name = $op->name; 601 $op_name = $op->name;
446 602
447 my $class = B::class $op; 603 my $class = B::class $op;
448 604
605 $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
449 $source .= "op_$$op: /* $op_name */\n"; 606 $source .= "op_$$op: /* $op_name */\n";
450 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d# 607 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
451 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d# 608 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
452 609
453 $source .= " PERL_ASYNC_CHECK ();\n" 610 $source .= " PERL_ASYNC_CHECK ();\n"
454 unless exists $f_noasync{$op_name}; 611 unless exists $f_noasync{$op_name};
455 612
456 if (my $can = __PACKAGE__->can ("op_$op_name")) { 613 if (my $can = __PACKAGE__->can ("op_$op_name")) {
457 # handcrafted replacement 614 # handcrafted replacement
615
616 if ($insn->{extend} > 0) {
617 # coalesce EXTENDs
618 # TODO: properly take negative preceeding and following EXTENDs into account
619 for my $i (@ops) {
620 last if exists $i->{bblock};
621 last unless exists $i->{extend};
622 my $extend = delete $i->{extend};
623 $insn->{extend} += $extend if $extend > 0;
624 }
625
626 $source .= " { dSP; EXTEND (SP, $insn->{extend}); PUTBACK; }\n"
627 if $insn->{extend} > 0;
628 }
629
458 $can->($op); 630 $can->($op);
459 631
460 } elsif (exists $f_unsafe{$op_name}) { 632 } elsif (exists $f_unsafe{$op_name}) {
461 # unsafe, return to interpreter 633 # unsafe, return to interpreter
462 assert "nextop == (OP *)$$op"; 634 assert "nextop == (OP *)$$op";
… …
491 663
492 $source 664 $source
493} 665}
494 666
495my $uid = "aaaaaaa0"; 667my $uid = "aaaaaaa0";
668my %so;
496 669
497sub source2ptr { 670sub func2ptr {
498 my (@source) = @_; 671 my (@func) = @_;
499 672
500 my $stem = "/tmp/Faster-$$-" . $uid++; 673 #LOCK
674 mkdir $CACHEDIR, 0777;
675 sysopen my $meta_fh, "$CACHEDIR/meta", &Fcntl::O_RDWR | &Fcntl::O_CREAT, 0666
676 or die "$$CACHEDIR/meta: $!";
677 binmode $meta_fh, ":raw:perlio";
678 fcntl_lock fileno $meta_fh
679 or die "$CACHEDIR/meta: $!";
501 680
681 my $meta = eval { Storable::fd_retrieve $meta_fh } || { version => 1 };
682
683 for my $f (@func) {
684 $f->{func} = "F" . Digest::MD5::md5_hex ($f->{source});
685 $f->{so} = $meta->{$f->{func}};
686 }
687
688 if (grep !$_->{so}, @func) {
689 my $stem;
690
691 do {
692 $stem = "$CACHEDIR/$$-" . $uid++;
693 } while -e "$stem$_so";
694
502 open FILE, ">:raw", "$stem.c"; 695 open my $fh, ">:raw", "$stem.c";
503 print FILE <<EOF; 696 print $fh <<EOF;
504#define PERL_NO_GET_CONTEXT 697#define PERL_NO_GET_CONTEXT
698#define PERL_CORE
505 699
506#include <assert.h> 700#include <assert.h>
507 701
508#include "EXTERN.h" 702#include "EXTERN.h"
509#include "perl.h" 703#include "perl.h"
510#include "XSUB.h" 704#include "XSUB.h"
511 705
706#if 1
707# define faster_PUSHMARK_PREALLOC(count) while (PL_markstack_ptr + (count) >= PL_markstack_max) markstack_grow ()
708# define faster_PUSHMARK(p) *++PL_markstack_ptr = (p) - PL_stack_base
709#else
710# define faster_PUSHMARK_PREALLOC(count) 1
711# define faster_PUSHMARK(p) PUSHMARK(p)
712#endif
713
512#define RUNOPS_TILL(op) \\ 714#define RUNOPS_TILL(op) \\
513while (nextop != (op)) \\ 715 while (nextop != (op)) \\
514 { \\ 716 { \\
515 PERL_ASYNC_CHECK (); \\ 717 PERL_ASYNC_CHECK (); \\
516 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\ 718 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
517 }
518
519EOF
520 for (@source) {
521 my $func = $uid++;
522 $_ =~ s/%%%FUNC%%%/$func/g;
523 print FILE $_;
524 $_ = $func;
525 } 719 }
526 720
527 close FILE; 721EOF
722 for my $f (grep !$_->{so}, @func) {
723 next if $f->{so} = $meta->{$f->{func}}; # some cv's alias others
724
725 warn "compiling $f->{name} to $stem$_so:$f->{func}\n" if $verbose > 1;
726 my $source = $f->{source};
727 $source =~ s/%%%FUNC%%%/$f->{func}/g;
728 print $fh $source;
729 $meta->{$f->{func}} = $f->{so} = $stem;
730 }
731
732 close $fh;
528 system "$COMPILE -o $stem$_o $stem.c"; 733 system "$COMPILE -o $stem$_o $stem.c";
529 #d#unlink "$stem.c"; 734 unlink "$stem.c" unless $ENV{FASTER_DEBUG} > 0;
530 system "$LINK -o $stem$_so $stem$_o $LIBS"; 735 system "$LINK -o $stem$_so $stem$_o $LIBS";
531 unlink "$stem$_o"; 736 unlink "$stem$_o";
737 }
532 738
739 for my $f (@func) {
740 my $stem = $f->{so};
741
533 my $so = DynaLoader::dl_load_file "$stem$_so" 742 my $so = ($so{$stem} ||= DynaLoader::dl_load_file "$stem$_so")
534 or die "$stem$_so: $!"; 743 or die "$stem$_so: $!";
535 744
536 #unlink "$stem$_so"; 745 #unlink "$stem$_so";
537 746
538 map +(DynaLoader::dl_find_symbol $so, $_), @source 747 $f->{ptr} = DynaLoader::dl_find_symbol $so, $f->{func}
748 or die "$f->{func} not found in $stem$_so: $!";
749 }
750
751 seek $meta_fh, 0, 0 or die "$CACHEDIR/meta: $!";
752 Storable::nstore_fd $meta, $meta_fh;
753 truncate $meta_fh, tell $meta_fh;
754
755 # UNLOCK (by closing $meta_fh)
539} 756}
540 757
541my %ignore; 758my %ignore;
542 759
543sub entersub { 760sub entersub {
… …
545 762
546 my $pkg = $cv->STASH->NAME; 763 my $pkg = $cv->STASH->NAME;
547 764
548 return if $ignore{$pkg}; 765 return if $ignore{$pkg};
549 766
550 warn "compiling ", $cv->STASH->NAME, "\n" 767 warn "optimising ", $cv->STASH->NAME, "\n"
551 if $verbose; 768 if $verbose;
552 769
553 eval { 770 eval {
554 my @cv; 771 my @func;
555 my @cv_source; 772
773 push @func, {
774 cv => $cv,
775 name => "<>",
776 source => cv2c $cv,
777 };
556 778
557 # always compile the whole stash 779 # always compile the whole stash
558 my %stash = $cv->STASH->ARRAY; 780 my %stash = $cv->STASH->ARRAY;
559 while (my ($k, $v) = each %stash) { 781 while (my ($k, $v) = each %stash) {
560 $v->isa (B::GV::) 782 $v->isa (B::GV::)
… …
563 my $cv = $v->CV; 785 my $cv = $v->CV;
564 786
565 if ($cv->isa (B::CV::) 787 if ($cv->isa (B::CV::)
566 && ${$cv->START} 788 && ${$cv->START}
567 && $cv->START->name ne "null") { 789 && $cv->START->name ne "null") {
790
568 push @cv, $cv; 791 push @func, {
792 cv => $cv,
793 name => $k,
569 push @cv_source, cv2c $cv; 794 source => cv2c $cv,
795 };
570 } 796 }
571 } 797 }
572 798
573 my @ptr = source2ptr @cv_source; 799 func2ptr @func;
574 800
575 for (0 .. $#cv) { 801 for my $f (@func) {
576 patch_cv $cv[$_], $ptr[$_]; 802 patch_cv $f->{cv}, $f->{ptr};
577 } 803 }
578 }; 804 };
579 805
580 if ($@) { 806 if ($@) {
581 $ignore{$pkg}++; 807 $ignore{$pkg}++;
… …
596=over 4 822=over 4
597 823
598=item FASTER_VERBOSE 824=item FASTER_VERBOSE
599 825
600Faster will output more informational messages when set to values higher 826Faster will output more informational messages when set to values higher
601than C<0>. Currently, C<1> outputs which packages are being compiled. 827than C<0>. Currently, C<1> outputs which packages are being compiled, C<3>
828outputs the cache directory and C<10> outputs information on which perl
829function is compiled into which shared object.
602 830
603=item FASTER_DEBUG 831=item FASTER_DEBUG
604 832
605Add debugging code when set to values higher than C<0>. Currently, this 833Add debugging code when set to values higher than C<0>. Currently, this
606adds 1-3 C<assert>'s per perl op, to ensure that opcode order and C 834adds 1-3 C<assert>'s per perl op (FASTER_DEBUG > 1), to ensure that opcode
607execution order are compatible. 835order and C execution order are compatible.
608 836
609=item FASTER_CACHE 837=item FASTER_CACHE
610 838
611NOT YET IMPLEMENTED
612
613Set a persistent cache directory that caches compiled code 839Set a persistent cache directory that caches compiled code fragments. The
614fragments. Normally, code compiled by Faster will be deleted immediately, 840default is C<$HOME/.perl-faster-cache> if C<HOME> is set and a temporary
615and every restart will recompile everything. Setting this variable to a 841directory otherwise.
616directory makes Faster cache the generated files for re-use.
617 842
618This directory will always grow in contents, so you might need to erase it 843This directory will always grow in size, so you might need to erase it
619from time to time. 844from time to time.
620 845
621=back 846=back
622 847
623=head1 BUGS/LIMITATIONS 848=head1 BUGS/LIMITATIONS

Diff Legend

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