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