ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Faster/Faster.pm
Revision: 1.32
Committed: Mon Mar 13 17:03:36 2006 UTC (18 years, 3 months ago) by root
Branch: MAIN
Changes since 1.31: +12 -8 lines
Log Message:
*** empty log message ***

File Contents

# User Rev Content
1 root 1.1 =head1 NAME
2    
3     Faster - do some things faster
4    
5     =head1 SYNOPSIS
6    
7     use Faster;
8    
9 root 1.18 perl -MFaster ...
10    
11 root 1.1 =head1 DESCRIPTION
12    
13 root 1.32 This module implements a very simple-minded "JIT" (or actually AIT, ahead
14     of time compiler). It works by more or less translating every function it
15     sees into a C program, compiling it and then replacing the function by the
16     compiled code.
17 root 1.18
18     As a result, startup times are immense, as every function might lead to a
19     full-blown compilation.
20    
21     The speed improvements are also not great, you can expect 20% or so on
22 root 1.32 average, for code that runs very often. The reason for this is that data
23     handling is mostly being done by the same old code, it just gets called
24     a bit faster. Regexes and string operations won't get faster. Airhtmetic
25     doresn't become any faster. Just the operands and other stuff is put on
26     the stack faster, and the opcodes themselves have a bit less overhead.
27 root 1.18
28     Faster is in the early stages of development. Due to its design its
29     relatively safe to use (it will either work or simply slowdown the program
30     immensely, but rarely cause bugs).
31    
32     Usage is very easy, just C<use Faster> and every function called from then
33     on will be compiled.
34    
35 root 1.32 Right now, Faster can leave lots of F<*.c> and F<*.so> files in your
36     F<$FASTER_CACHEDIR> (by default F<$HOME/.perl-faster-cache>), and it will
37     even create those temporary files in an insecure manner, so watch out.
38 root 1.18
39 root 1.1 =over 4
40    
41     =cut
42    
43     package Faster;
44    
45 root 1.24 no warnings;
46    
47 root 1.1 use strict;
48 root 1.4 use Config;
49     use B ();
50     use DynaLoader ();
51 root 1.27 use Digest::MD5 ();
52     use Storable ();
53 root 1.29 use Fcntl ();
54 root 1.1
55     BEGIN {
56     our $VERSION = '0.01';
57    
58     require XSLoader;
59     XSLoader::load __PACKAGE__, $VERSION;
60     }
61    
62 root 1.29 my $CACHEDIR =
63     $ENV{FASTER_CACHE}
64     || (exists $ENV{HOME} && "$ENV{HOME}/.perl-faster-cache")
65     || do {
66     require File::Temp;
67     File::Temp::tempdir (CLEANUP => 1)
68     };
69 root 1.27
70 root 1.4 my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}";
71     my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
72     my $LIBS = "$Config{libs}";
73     my $_o = $Config{_o};
74     my $_so = ".so";
75 root 1.1
76 root 1.13 # we don't need no steenking PIC on x86
77     $COMPILE =~ s/-f(?:PIC|pic)//g
78     if $Config{archname} =~ /^(i[3456]86)-/;
79    
80 root 1.30 my $opt_assert = $ENV{FASTER_DEBUG} > 1;
81 root 1.21 my $verbose = $ENV{FASTER_VERBOSE}+0;
82 root 1.11
83 root 1.29 warn "Faster: CACHEDIR is $CACHEDIR\n" if $verbose > 2;
84    
85 root 1.1 our $source;
86    
87 root 1.18 our @ops;
88 root 1.24 our $insn;
89 root 1.18 our $op;
90     our $op_name;
91     our @op_loop;
92     our %op_regcomp;
93 root 1.8
94 root 1.24 # ops that cause immediate return to the interpreter
95 root 1.20 my %f_unsafe = map +($_ => undef), qw(
96     leavesub leavesublv return
97     goto last redo next
98     eval flip leaveeval entertry
99     formline grepstart mapstart
100     substcont entereval require
101     );
102 root 1.2
103 root 1.24 # ops with known stack extend behaviour
104     # the values given are maximum values
105     my %extend = (
106     pushmark => 0,
107     nextstate => 0, # might reduce the stack
108     unstack => 0,
109     enter => 0,
110    
111     stringify => 0,
112     not => 0,
113     and => 0,
114     or => 0,
115     gvsv => 0,
116     rv2gv => 0,
117     preinc => 0,
118     predec => 0,
119     postinc => 0,
120     postdec => 0,
121     aelem => 0,
122     helem => 0,
123     qr => 1, #???
124     pushre => 1,
125     gv => 1,
126     aelemfast => 1,
127     aelem => 0,
128     padsv => 1,
129     const => 1,
130     pop => 1,
131     shift => 1,
132     eq => -1,
133     ne => -1,
134     gt => -1,
135     lt => -1,
136     ge => -1,
137     lt => -1,
138     cond_expr => -1,
139     add => -1,
140     subtract => -1,
141     multiply => -1,
142     divide => -1,
143     aassign => 0,
144     sassign => -2,
145     method => 0,
146     method_named => 1,
147     );
148 root 1.20
149 root 1.24 # ops that do not need an ASYNC_CHECK
150 root 1.20 my %f_noasync = map +($_ => undef), qw(
151     mapstart grepstart match entereval
152     enteriter entersub leaveloop
153    
154 root 1.30 pushmark nextstate caller
155 root 1.20
156     const stub unstack
157 root 1.30 last next redo goto seq
158 root 1.20 padsv padav padhv padany
159     aassign sassign orassign
160     rv2av rv2cv rv2gv rv2hv refgen
161     gv gvsv
162     add subtract multiply divide
163 root 1.31 complement cond_expr and or not
164     bit_and bit_or bit_xor
165 root 1.20 defined
166 root 1.24 method method_named bless
167 root 1.20 preinc postinc predec postdec
168     aelem aelemfast helem delete exists
169 root 1.30 pushre subst list lslice join split concat
170 root 1.20 length substr stringify ord
171     push pop shift unshift
172     eq ne gt lt ge le
173     regcomp regcreset regcmaybe
174     );
175 root 1.2
176 root 1.11 my %callop = (
177 root 1.26 entersub => "(PL_op->op_ppaddr) (aTHX)",
178 root 1.11 mapstart => "Perl_pp_grepstart (aTHX)",
179     );
180    
181 root 1.8 sub callop {
182 root 1.11 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
183     }
184    
185     sub assert {
186     return unless $opt_assert;
187     $source .= " assert ((\"$op_name\", ($_[0])));\n";
188     }
189    
190     sub out_callop {
191     assert "nextop == (OP *)$$op";
192     $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
193 root 1.8 }
194    
195 root 1.18 sub out_cond_jump {
196     $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
197     }
198    
199 root 1.11 sub out_jump_next {
200 root 1.18 out_cond_jump $op_regcomp{$$op}
201     if $op_regcomp{$$op};
202    
203 root 1.11 assert "nextop == (OP *)${$op->next}";
204     $source .= " goto op_${$op->next};\n";
205 root 1.2 }
206    
207 root 1.9 sub out_next {
208     $source .= " nextop = (OP *)${$op->next}L;\n";
209    
210 root 1.11 out_jump_next;
211 root 1.9 }
212    
213 root 1.8 sub out_linear {
214 root 1.11 out_callop;
215     out_jump_next;
216     }
217    
218     sub op_entersub {
219     out_callop;
220     $source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n";
221     out_jump_next;
222 root 1.4 }
223    
224 root 1.11 *op_require = \&op_entersub;
225    
226 root 1.2 sub op_nextstate {
227 root 1.4 $source .= " PL_curcop = (COP *)nextop;\n";
228 root 1.2 $source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
229     $source .= " FREETMPS;\n";
230    
231 root 1.8 out_next;
232 root 1.2 }
233    
234 root 1.3 sub op_pushmark {
235 root 1.30 $source .= " faster_PUSHMARK (PL_stack_sp);\n";
236 root 1.3
237 root 1.8 out_next;
238 root 1.3 }
239    
240 root 1.13 if ($Config{useithreads} ne "define") {
241 root 1.8 # disable optimisations on ithreads
242    
243     *op_const = sub {
244 root 1.24 $source .= " { dSP; PUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
245 root 1.8
246 root 1.26 $ops[0]{follows_const}++ if @ops;#d#
247    
248 root 1.8 out_next;
249     };
250    
251     *op_gv = \&op_const;
252    
253     *op_aelemfast = sub {
254     my $targ = $op->targ;
255     my $private = $op->private;
256    
257     $source .= " {\n";
258    
259     if ($op->flags & B::OPf_SPECIAL) {
260     $source .= " AV *av = (AV*)PAD_SV((PADOFFSET)$targ);\n";
261     } else {
262     $source .= " AV *av = GvAV ((GV *)${$op->sv}L);\n";
263     }
264    
265     if ($op->flags & B::OPf_MOD) {
266     $source .= " SV *sv = *av_fetch (av, $private, 1);\n";
267     } else {
268     $source .= " SV **svp = av_fetch (av, $private, 0); SV *sv = svp ? *svp : &PL_sv_undef;\n";
269     }
270    
271     if (!($op->flags & B::OPf_MOD)) {
272     $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
273     }
274    
275     $source .= " dSP;\n";
276 root 1.24 $source .= " PUSHs (sv);\n";
277 root 1.8 $source .= " PUTBACK;\n";
278     $source .= " }\n";
279    
280     out_next;
281     };
282 root 1.2
283 root 1.8 *op_gvsv = sub {
284     $source .= " {\n";
285     $source .= " dSP;\n";
286 root 1.2
287 root 1.8 if ($op->private & B::OPpLVAL_INTRO) {
288     $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
289     } else {
290     $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
291     }
292    
293     $source .= " PUTBACK;\n";
294     $source .= " }\n";
295    
296     out_next;
297     };
298 root 1.2 }
299    
300 root 1.12 # does kill Crossfire/res2pm
301     sub op_stringify {
302     my $targ = $op->targ;
303    
304     $source .= <<EOF;
305     {
306     dSP;
307     SV *targ = PAD_SV ((PADOFFSET)$targ);
308     sv_copypv (TARG, TOPs);
309     SETTARG;
310     PUTBACK;
311     }
312     EOF
313 root 1.3
314 root 1.8 out_next;
315 root 1.3 }
316    
317 root 1.4 sub op_and {
318     $source .= <<EOF;
319     {
320     dSP;
321 root 1.5
322 root 1.4 if (SvTRUE (TOPs))
323     {
324     --SP;
325     PUTBACK;
326     nextop = (OP *)${$op->other}L;
327     goto op_${$op->other};
328     }
329     }
330     EOF
331 root 1.5
332 root 1.8 out_next;
333 root 1.4 }
334    
335 root 1.7 sub op_or {
336     $source .= <<EOF;
337     {
338     dSP;
339    
340     if (!SvTRUE (TOPs))
341     {
342     --SP;
343     PUTBACK;
344     nextop = (OP *)${$op->other}L;
345     goto op_${$op->other};
346     }
347     }
348     EOF
349    
350 root 1.8 out_next;
351 root 1.7 }
352    
353 root 1.4 sub op_padsv {
354     my $flags = $op->flags;
355 root 1.24 my $padofs = "(PADOFFSET)" . $op->targ;
356    
357 root 1.4 $source .= <<EOF;
358     {
359     dSP;
360 root 1.24 SV *sv = PAD_SVl ($padofs);
361     EOF
362    
363     if (($flags & B::OPf_MOD) && ($op->private & B::OPpLVAL_INTRO)) {
364     $source .= " SAVECLEARSV (PAD_SVl ($padofs));\n";
365 root 1.26 $ops[0]{follows_padsv_lval_intro}++ if @ops;#d#
366 root 1.24 }
367    
368     $source .= <<EOF;
369     PUSHs (sv);
370 root 1.4 PUTBACK;
371     EOF
372 root 1.24
373     if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
374 root 1.27 $source .= " if (!SvROK (sv)) vivify_ref (sv, " . $op->private . " & OPpDEREF);\n";
375 root 1.24 }
376     $source .= " }\n";
377    
378     out_next;
379     }
380    
381     sub op_sassign {
382     $source .= <<EOF;
383     {
384     dSP;
385     dPOPTOPssrl;
386     EOF
387     $source .= " SV *temp = left; left = right; right = temp;\n"
388     if $op->private & B::OPpASSIGN_BACKWARDS;
389    
390 root 1.26 if ($insn->{follows_padsv_lval_intro} && !($op->private & B::OPpASSIGN_BACKWARDS)) {
391 root 1.24 # simple assignment - the target exists, but is basically undef
392     $source .= " SvSetSV (right, left);\n";
393     } else {
394     $source .= " SvSetMagicSV (right, left);\n";
395 root 1.4 }
396 root 1.24
397 root 1.4 $source .= <<EOF;
398 root 1.24 SETs (right);
399     PUTBACK;
400 root 1.4 }
401     EOF
402    
403 root 1.24 out_next;
404 root 1.6 }
405    
406 root 1.3 # pattern const+ (or general push1)
407     # pattern pushmark gv rv2av pushmark padsv+o.รค. aassign
408    
409 root 1.12 sub op_method_named {
410 root 1.26 if ($insn->{follows_const}) {
411     $source .= <<EOF;
412     {
413     dSP;
414     static SV *last_cv;
415     static U32 last_sub_generation;
416    
417     /* simple "polymorphic" inline cache */
418     if (PL_sub_generation == last_sub_generation)
419     {
420     PUSHs (last_cv);
421     PUTBACK;
422     }
423     else
424     {
425     PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
426    
427     SPAGAIN;
428     last_sub_generation = PL_sub_generation;
429     last_cv = TOPs;
430     }
431     }
432     EOF
433     } else {
434     $source .= <<EOF;
435 root 1.3 {
436 root 1.4 static HV *last_stash;
437 root 1.11 static SV *last_cv;
438     static U32 last_sub_generation;
439 root 1.4
440     SV *obj = *(PL_stack_base + TOPMARK + 1);
441 root 1.3
442 root 1.11 if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
443 root 1.3 {
444 root 1.4 dSP;
445     HV *stash = SvSTASH (SvRV (obj));
446 root 1.3
447 root 1.4 /* simple "polymorphic" inline cache */
448 root 1.11 if (stash == last_stash
449     && PL_sub_generation == last_sub_generation)
450 root 1.3 {
451 root 1.24 PUSHs (last_cv);
452 root 1.4 PUTBACK;
453 root 1.3 }
454     else
455     {
456 root 1.11 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
457 root 1.4
458 root 1.3 SPAGAIN;
459 root 1.11 last_sub_generation = PL_sub_generation;
460     last_stash = stash;
461     last_cv = TOPs;
462 root 1.3 }
463     }
464 root 1.4 else
465     {
466     /* error case usually */
467 root 1.11 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
468 root 1.4 }
469 root 1.3 }
470     EOF
471 root 1.26 }
472 root 1.3
473 root 1.8 out_next;
474 root 1.3 }
475    
476 root 1.11 sub op_grepstart {
477     out_callop;
478 root 1.14 $op = $op->next;
479     out_cond_jump $op->other;
480 root 1.11 out_jump_next;
481     }
482    
483     *op_mapstart = \&op_grepstart;
484    
485     sub op_substcont {
486     out_callop;
487     out_cond_jump $op->other->pmreplstart;
488     assert "nextop == (OP *)${$op->other->next}L";
489     $source .= " goto op_${$op->other->next};\n";
490     }
491    
492     sub out_break_op {
493     my ($idx) = @_;
494    
495     out_callop;
496    
497     out_cond_jump $_->[$idx]
498 root 1.18 for reverse @op_loop;
499 root 1.11
500     $source .= " return nextop;\n";
501     }
502    
503     sub xop_next {
504     out_break_op 0;
505     }
506    
507     sub op_last {
508     out_break_op 1;
509     }
510    
511     sub xop_redo {
512     out_break_op 2;
513     }
514    
515 root 1.4 sub cv2c {
516 root 1.1 my ($cv) = @_;
517    
518 root 1.18 local @ops;
519     local @op_loop;
520     local %op_regcomp;
521 root 1.11
522 root 1.1 my %opsseen;
523     my @todo = $cv->START;
524 root 1.24 my %op_target;
525 root 1.30 my $numpushmark;
526 root 1.1
527     while (my $op = shift @todo) {
528     for (; $$op; $op = $op->next) {
529     last if $opsseen{$$op}++;
530 root 1.11
531 root 1.1 my $name = $op->name;
532 root 1.11 my $class = B::class $op;
533    
534 root 1.24 my $insn = { op => $op };
535    
536     push @ops, $insn;
537    
538     if (exists $extend{$name}) {
539     my $extend = $extend{$name};
540     $extend = $extend->($op) if ref $extend;
541     $insn->{extend} = $extend if defined $extend;
542     }
543    
544     push @todo, $op->next;
545    
546 root 1.11 if ($class eq "LOGOP") {
547 root 1.24 push @todo, $op->other;
548     $op_target{${$op->other}}++;
549 root 1.18
550     # regcomp/o patches ops at runtime, lets expect that
551 root 1.24 if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
552     $op_target{${$op->first}}++;
553     $op_regcomp{${$op->first}} = $op->next;
554     }
555 root 1.18
556 root 1.11 } elsif ($class eq "PMOP") {
557 root 1.24 if (${$op->pmreplstart}) {
558     unshift @todo, $op->pmreplstart;
559     $op_target{${$op->pmreplstart}}++;
560     }
561 root 1.18
562 root 1.11 } elsif ($class eq "LOOP") {
563 root 1.24 my @targ = ($op->nextop, $op->lastop->next, $op->redoop->next);
564    
565     push @op_loop, \@targ;
566     push @todo, @targ;
567    
568     $op_target{$$_}++ for @targ;
569 root 1.30
570 root 1.24 } elsif ($class eq "COP") {
571     $insn->{bblock}++ if defined $op->label;
572 root 1.30
573     } else {
574     if ($name eq "pushmark") {
575     $numpushmark++;
576     }
577 root 1.1 }
578     }
579     }
580    
581 root 1.24 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
582    
583 root 1.4 local $source = <<EOF;
584     OP *%%%FUNC%%% (pTHX)
585     {
586 root 1.24 register OP *nextop = (OP *)${$ops[0]->{op}}L;
587 root 1.4 EOF
588 root 1.2
589 root 1.30 $source .= " faster_PUSHMARK_PREALLOC ($numpushmark);\n"
590     if $numpushmark;
591    
592 root 1.8 while (@ops) {
593 root 1.24 $insn = shift @ops;
594    
595     $op = $insn->{op};
596 root 1.8 $op_name = $op->name;
597 root 1.2
598 root 1.23 my $class = B::class $op;
599    
600 root 1.24 $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
601 root 1.8 $source .= "op_$$op: /* $op_name */\n";
602     #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
603 root 1.4 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
604    
605 root 1.11 $source .= " PERL_ASYNC_CHECK ();\n"
606 root 1.20 unless exists $f_noasync{$op_name};
607 root 1.2
608 root 1.8 if (my $can = __PACKAGE__->can ("op_$op_name")) {
609 root 1.11 # handcrafted replacement
610 root 1.24
611     if ($insn->{extend} > 0) {
612     # coalesce EXTENDs
613     # TODO: properly take negative preceeding and following EXTENDs into account
614     for my $i (@ops) {
615     last if exists $i->{bblock};
616     last unless exists $i->{extend};
617     my $extend = delete $i->{extend};
618     $insn->{extend} += $extend if $extend > 0;
619     }
620    
621     $source .= " { dSP; EXTEND (SP, $insn->{extend}); PUTBACK; }\n"
622     if $insn->{extend} > 0;
623     }
624    
625 root 1.2 $can->($op);
626 root 1.11
627 root 1.20 } elsif (exists $f_unsafe{$op_name}) {
628 root 1.11 # unsafe, return to interpreter
629     assert "nextop == (OP *)$$op";
630 root 1.9 $source .= " return nextop;\n";
631 root 1.11
632 root 1.23 } elsif ("LOGOP" eq $class) {
633     # logical operation with optional branch
634 root 1.11 out_callop;
635     out_cond_jump $op->other;
636     out_jump_next;
637    
638 root 1.23 } elsif ("PMOP" eq $class) {
639 root 1.11 # regex-thingy
640     out_callop;
641 root 1.23 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
642 root 1.11 out_jump_next;
643    
644 root 1.2 } else {
645 root 1.11 # normal operator, linear execution
646 root 1.8 out_linear;
647 root 1.2 }
648 root 1.1 }
649 root 1.2
650 root 1.11 $op_name = "func exit"; assert (0);
651    
652     $source .= <<EOF;
653     op_0:
654     return 0;
655     }
656     EOF
657 root 1.4 #warn $source;
658 root 1.2
659 root 1.4 $source
660     }
661    
662 root 1.19 my $uid = "aaaaaaa0";
663 root 1.27 my %so;
664    
665     sub func2ptr {
666     my (@func) = @_;
667 root 1.19
668 root 1.27 #LOCK
669 root 1.29 mkdir $CACHEDIR, 0777;
670     sysopen my $meta_fh, "$CACHEDIR/meta", &Fcntl::O_RDWR | &Fcntl::O_CREAT, 0666
671     or die "$$CACHEDIR/meta: $!";
672     binmode $meta_fh, ":raw:perlio";
673     fcntl_lock fileno $meta_fh
674     or die "$CACHEDIR/meta: $!";
675    
676     my $meta = eval { Storable::fd_retrieve $meta_fh } || { version => 1 };
677 root 1.4
678 root 1.27 for my $f (@func) {
679     $f->{func} = "F" . Digest::MD5::md5_hex ($f->{source});
680     $f->{so} = $meta->{$f->{func}};
681     }
682 root 1.4
683 root 1.27 if (grep !$_->{so}, @func) {
684     my $stem;
685    
686     do {
687     $stem = "$CACHEDIR/$$-" . $uid++;
688     } while -e "$stem$_so";
689    
690     open my $fh, ">:raw", "$stem.c";
691     print $fh <<EOF;
692 root 1.11 #define PERL_NO_GET_CONTEXT
693 root 1.24 #define PERL_CORE
694 root 1.11
695     #include <assert.h>
696    
697     #include "EXTERN.h"
698     #include "perl.h"
699     #include "XSUB.h"
700    
701 root 1.30 #if 1
702     # define faster_PUSHMARK_PREALLOC(count) while (PL_markstack_ptr + (count) >= PL_markstack_max) markstack_grow ()
703     # define faster_PUSHMARK(p) *++PL_markstack_ptr = (p) - PL_stack_base
704     #else
705     # define faster_PUSHMARK_PREALLOC(count) 1
706     # define faster_PUSHMARK(p) PUSHMARK(p)
707     #endif
708    
709 root 1.11 #define RUNOPS_TILL(op) \\
710 root 1.27 while (nextop != (op)) \\
711     { \\
712     PERL_ASYNC_CHECK (); \\
713     PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
714     }
715    
716     EOF
717     for my $f (grep !$_->{so}, @func) {
718     next if $f->{so} = $meta->{$f->{func}}; # some cv's alias others
719    
720     warn "compiling $f->{name} to $stem$_so:$f->{func}\n" if $verbose > 1;
721     my $source = $f->{source};
722     $source =~ s/%%%FUNC%%%/$f->{func}/g;
723     print $fh $source;
724     $meta->{$f->{func}} = $f->{so} = $stem;
725     }
726    
727     close $fh;
728     system "$COMPILE -o $stem$_o $stem.c";
729 root 1.30 unlink "$stem.c" unless $ENV{FASTER_DEBUG} > 0;
730 root 1.27 system "$LINK -o $stem$_so $stem$_o $LIBS";
731     unlink "$stem$_o";
732     }
733 root 1.11
734 root 1.27 for my $f (@func) {
735     my $stem = $f->{so};
736 root 1.4
737 root 1.27 my $so = ($so{$stem} ||= DynaLoader::dl_load_file "$stem$_so")
738     or die "$stem$_so: $!";
739 root 1.19
740 root 1.27 #unlink "$stem$_so";
741 root 1.4
742 root 1.27 $f->{ptr} = DynaLoader::dl_find_symbol $so, $f->{func}
743     or die "$f->{func} not found in $stem$_so: $!";
744     }
745 root 1.19
746 root 1.29 seek $meta_fh, 0, 0 or die "$CACHEDIR/meta: $!";
747     Storable::nstore_fd $meta, $meta_fh;
748     truncate $meta_fh, tell $meta_fh;
749    
750     # UNLOCK (by closing $meta_fh)
751 root 1.4 }
752    
753 root 1.19 my %ignore;
754    
755 root 1.4 sub entersub {
756     my ($cv) = @_;
757    
758 root 1.19 my $pkg = $cv->STASH->NAME;
759    
760     return if $ignore{$pkg};
761    
762 root 1.27 warn "optimising ", $cv->STASH->NAME, "\n"
763 root 1.21 if $verbose;
764 root 1.11
765 root 1.4 eval {
766 root 1.27 my @func;
767 root 1.4
768 root 1.28 push @func, {
769     cv => $cv,
770     name => "<>",
771     source => cv2c $cv,
772     };
773    
774 root 1.19 # always compile the whole stash
775     my %stash = $cv->STASH->ARRAY;
776     while (my ($k, $v) = each %stash) {
777     $v->isa (B::GV::)
778     or next;
779    
780     my $cv = $v->CV;
781    
782     if ($cv->isa (B::CV::)
783     && ${$cv->START}
784     && $cv->START->name ne "null") {
785 root 1.27
786     push @func, {
787     cv => $cv,
788     name => $k,
789     source => cv2c $cv,
790     };
791 root 1.19 }
792     }
793    
794 root 1.27 func2ptr @func;
795 root 1.4
796 root 1.27 for my $f (@func) {
797     patch_cv $f->{cv}, $f->{ptr};
798 root 1.19 }
799 root 1.4 };
800    
801 root 1.19 if ($@) {
802     $ignore{$pkg}++;
803     warn $@;
804     }
805 root 1.1 }
806    
807     hook_entersub;
808    
809     1;
810    
811     =back
812    
813 root 1.21 =head1 ENVIRONMENT VARIABLES
814    
815     The following environment variables influence the behaviour of Faster:
816    
817     =over 4
818    
819     =item FASTER_VERBOSE
820    
821     Faster will output more informational messages when set to values higher
822 root 1.29 than C<0>. Currently, C<1> outputs which packages are being compiled, C<3>
823     outputs the cache directory and C<10> outputs information on which perl
824     function is compiled into which shared object.
825 root 1.21
826     =item FASTER_DEBUG
827    
828     Add debugging code when set to values higher than C<0>. Currently, this
829 root 1.30 adds 1-3 C<assert>'s per perl op (FASTER_DEBUG > 1), to ensure that opcode
830     order and C execution order are compatible.
831 root 1.21
832     =item FASTER_CACHE
833    
834 root 1.29 Set a persistent cache directory that caches compiled code fragments. The
835     default is C<$HOME/.perl-faster-cache> if C<HOME> is set and a temporary
836     directory otherwise.
837 root 1.21
838 root 1.29 This directory will always grow in size, so you might need to erase it
839 root 1.21 from time to time.
840    
841     =back
842    
843 root 1.11 =head1 BUGS/LIMITATIONS
844    
845     Perl will check much less often for asynchronous signals in
846     Faster-compiled code. It tries to check on every function call, loop
847     iteration and every I/O operator, though.
848    
849     The following things will disable Faster. If you manage to enable them at
850 root 1.19 runtime, bad things will happen. Enabling them at startup will be fine,
851     though.
852 root 1.11
853     enabled tainting
854     enabled debugging
855    
856 root 1.19 Thread-enabled builds of perl will dramatically reduce Faster's
857     performance, but you don't care about speed if you enable threads anyway.
858 root 1.11
859 root 1.19 These constructs will force the use of the interpreter for the currently
860     executed function as soon as they are being encountered during execution.
861 root 1.11
862     goto
863     next, redo (but not well-behaved last's)
864     eval
865     require
866     any use of formats
867 root 1.19 .., ... (flipflop operators)
868 root 1.2
869 root 1.1 =head1 AUTHOR
870    
871     Marc Lehmann <schmorp@schmorp.de>
872     http://home.schmorp.de/
873    
874     =cut
875