ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Faster/Faster.pm
Revision: 1.30
Committed: Mon Mar 13 16:59:36 2006 UTC (18 years, 3 months ago) by root
Branch: MAIN
Changes since 1.29: +27 -9 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.30 my $opt_assert = $ENV{FASTER_DEBUG} > 1;
77 root 1.21 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 root 1.30 pushmark nextstate caller
151 root 1.20
152     const stub unstack
153 root 1.30 last next redo goto seq
154 root 1.20 padsv padav padhv padany
155     aassign sassign orassign
156     rv2av rv2cv rv2gv rv2hv refgen
157     gv gvsv
158     add subtract multiply divide
159 root 1.30 complement cond_expr and or not bit_and bit_or bit_xor
160 root 1.20 defined
161 root 1.24 method method_named bless
162 root 1.20 preinc postinc predec postdec
163     aelem aelemfast helem delete exists
164 root 1.30 pushre subst list lslice join split concat
165 root 1.20 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 root 1.30 $source .= " faster_PUSHMARK (PL_stack_sp);\n";
231 root 1.3
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.30 my $numpushmark;
521 root 1.1
522     while (my $op = shift @todo) {
523     for (; $$op; $op = $op->next) {
524     last if $opsseen{$$op}++;
525 root 1.11
526 root 1.1 my $name = $op->name;
527 root 1.11 my $class = B::class $op;
528    
529 root 1.24 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    
541 root 1.11 if ($class eq "LOGOP") {
542 root 1.24 push @todo, $op->other;
543     $op_target{${$op->other}}++;
544 root 1.18
545     # regcomp/o patches ops at runtime, lets expect that
546 root 1.24 if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
547     $op_target{${$op->first}}++;
548     $op_regcomp{${$op->first}} = $op->next;
549     }
550 root 1.18
551 root 1.11 } elsif ($class eq "PMOP") {
552 root 1.24 if (${$op->pmreplstart}) {
553     unshift @todo, $op->pmreplstart;
554     $op_target{${$op->pmreplstart}}++;
555     }
556 root 1.18
557 root 1.11 } elsif ($class eq "LOOP") {
558 root 1.24 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 root 1.30
565 root 1.24 } elsif ($class eq "COP") {
566     $insn->{bblock}++ if defined $op->label;
567 root 1.30
568     } else {
569     if ($name eq "pushmark") {
570     $numpushmark++;
571     }
572 root 1.1 }
573     }
574     }
575    
576 root 1.24 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
577    
578 root 1.4 local $source = <<EOF;
579     OP *%%%FUNC%%% (pTHX)
580     {
581 root 1.24 register OP *nextop = (OP *)${$ops[0]->{op}}L;
582 root 1.4 EOF
583 root 1.2
584 root 1.30 $source .= " faster_PUSHMARK_PREALLOC ($numpushmark);\n"
585     if $numpushmark;
586    
587 root 1.8 while (@ops) {
588 root 1.24 $insn = shift @ops;
589    
590     $op = $insn->{op};
591 root 1.8 $op_name = $op->name;
592 root 1.2
593 root 1.23 my $class = B::class $op;
594    
595 root 1.24 $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
596 root 1.8 $source .= "op_$$op: /* $op_name */\n";
597     #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
598 root 1.4 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
599    
600 root 1.11 $source .= " PERL_ASYNC_CHECK ();\n"
601 root 1.20 unless exists $f_noasync{$op_name};
602 root 1.2
603 root 1.8 if (my $can = __PACKAGE__->can ("op_$op_name")) {
604 root 1.11 # handcrafted replacement
605 root 1.24
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    
620 root 1.2 $can->($op);
621 root 1.11
622 root 1.20 } elsif (exists $f_unsafe{$op_name}) {
623 root 1.11 # unsafe, return to interpreter
624     assert "nextop == (OP *)$$op";
625 root 1.9 $source .= " return nextop;\n";
626 root 1.11
627 root 1.23 } elsif ("LOGOP" eq $class) {
628     # logical operation with optional branch
629 root 1.11 out_callop;
630     out_cond_jump $op->other;
631     out_jump_next;
632    
633 root 1.23 } elsif ("PMOP" eq $class) {
634 root 1.11 # regex-thingy
635     out_callop;
636 root 1.23 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
637 root 1.11 out_jump_next;
638    
639 root 1.2 } else {
640 root 1.11 # normal operator, linear execution
641 root 1.8 out_linear;
642 root 1.2 }
643 root 1.1 }
644 root 1.2
645 root 1.11 $op_name = "func exit"; assert (0);
646    
647     $source .= <<EOF;
648     op_0:
649     return 0;
650     }
651     EOF
652 root 1.4 #warn $source;
653 root 1.2
654 root 1.4 $source
655     }
656    
657 root 1.19 my $uid = "aaaaaaa0";
658 root 1.27 my %so;
659    
660     sub func2ptr {
661     my (@func) = @_;
662 root 1.19
663 root 1.27 #LOCK
664 root 1.29 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: $!";
670    
671     my $meta = eval { Storable::fd_retrieve $meta_fh } || { version => 1 };
672 root 1.4
673 root 1.27 for my $f (@func) {
674     $f->{func} = "F" . Digest::MD5::md5_hex ($f->{source});
675     $f->{so} = $meta->{$f->{func}};
676     }
677 root 1.4
678 root 1.27 if (grep !$_->{so}, @func) {
679     my $stem;
680    
681     do {
682     $stem = "$CACHEDIR/$$-" . $uid++;
683     } while -e "$stem$_so";
684    
685     open my $fh, ">:raw", "$stem.c";
686     print $fh <<EOF;
687 root 1.11 #define PERL_NO_GET_CONTEXT
688 root 1.24 #define PERL_CORE
689 root 1.11
690     #include <assert.h>
691    
692     #include "EXTERN.h"
693     #include "perl.h"
694     #include "XSUB.h"
695    
696 root 1.30 #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    
704 root 1.11 #define RUNOPS_TILL(op) \\
705 root 1.27 while (nextop != (op)) \\
706     { \\
707     PERL_ASYNC_CHECK (); \\
708     PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
709     }
710    
711     EOF
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;
723     system "$COMPILE -o $stem$_o $stem.c";
724 root 1.30 unlink "$stem.c" unless $ENV{FASTER_DEBUG} > 0;
725 root 1.27 system "$LINK -o $stem$_so $stem$_o $LIBS";
726     unlink "$stem$_o";
727     }
728 root 1.11
729 root 1.27 for my $f (@func) {
730     my $stem = $f->{so};
731 root 1.4
732 root 1.27 my $so = ($so{$stem} ||= DynaLoader::dl_load_file "$stem$_so")
733     or die "$stem$_so: $!";
734 root 1.19
735 root 1.27 #unlink "$stem$_so";
736 root 1.4
737 root 1.27 $f->{ptr} = DynaLoader::dl_find_symbol $so, $f->{func}
738     or die "$f->{func} not found in $stem$_so: $!";
739     }
740 root 1.19
741 root 1.29 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)
746 root 1.4 }
747    
748 root 1.19 my %ignore;
749    
750 root 1.4 sub entersub {
751     my ($cv) = @_;
752    
753 root 1.19 my $pkg = $cv->STASH->NAME;
754    
755     return if $ignore{$pkg};
756    
757 root 1.27 warn "optimising ", $cv->STASH->NAME, "\n"
758 root 1.21 if $verbose;
759 root 1.11
760 root 1.4 eval {
761 root 1.27 my @func;
762 root 1.4
763 root 1.28 push @func, {
764     cv => $cv,
765     name => "<>",
766     source => cv2c $cv,
767     };
768    
769 root 1.19 # always compile the whole stash
770     my %stash = $cv->STASH->ARRAY;
771     while (my ($k, $v) = each %stash) {
772     $v->isa (B::GV::)
773     or next;
774    
775     my $cv = $v->CV;
776    
777     if ($cv->isa (B::CV::)
778     && ${$cv->START}
779     && $cv->START->name ne "null") {
780 root 1.27
781     push @func, {
782     cv => $cv,
783     name => $k,
784     source => cv2c $cv,
785     };
786 root 1.19 }
787     }
788    
789 root 1.27 func2ptr @func;
790 root 1.4
791 root 1.27 for my $f (@func) {
792     patch_cv $f->{cv}, $f->{ptr};
793 root 1.19 }
794 root 1.4 };
795    
796 root 1.19 if ($@) {
797     $ignore{$pkg}++;
798     warn $@;
799     }
800 root 1.1 }
801    
802     hook_entersub;
803    
804     1;
805    
806     =back
807    
808 root 1.21 =head1 ENVIRONMENT VARIABLES
809    
810     The following environment variables influence the behaviour of Faster:
811    
812     =over 4
813    
814     =item FASTER_VERBOSE
815    
816     Faster will output more informational messages when set to values higher
817 root 1.29 than C<0>. Currently, C<1> outputs which packages are being compiled, C<3>
818     outputs the cache directory and C<10> outputs information on which perl
819     function is compiled into which shared object.
820 root 1.21
821     =item FASTER_DEBUG
822    
823     Add debugging code when set to values higher than C<0>. Currently, this
824 root 1.30 adds 1-3 C<assert>'s per perl op (FASTER_DEBUG > 1), to ensure that opcode
825     order and C execution order are compatible.
826 root 1.21
827     =item FASTER_CACHE
828    
829 root 1.29 Set a persistent cache directory that caches compiled code fragments. The
830     default is C<$HOME/.perl-faster-cache> if C<HOME> is set and a temporary
831     directory otherwise.
832 root 1.21
833 root 1.29 This directory will always grow in size, so you might need to erase it
834 root 1.21 from time to time.
835    
836     =back
837    
838 root 1.11 =head1 BUGS/LIMITATIONS
839    
840     Perl will check much less often for asynchronous signals in
841     Faster-compiled code. It tries to check on every function call, loop
842     iteration and every I/O operator, though.
843    
844     The following things will disable Faster. If you manage to enable them at
845 root 1.19 runtime, bad things will happen. Enabling them at startup will be fine,
846     though.
847 root 1.11
848     enabled tainting
849     enabled debugging
850    
851 root 1.19 Thread-enabled builds of perl will dramatically reduce Faster's
852     performance, but you don't care about speed if you enable threads anyway.
853 root 1.11
854 root 1.19 These constructs will force the use of the interpreter for the currently
855     executed function as soon as they are being encountered during execution.
856 root 1.11
857     goto
858     next, redo (but not well-behaved last's)
859     eval
860     require
861     any use of formats
862 root 1.19 .., ... (flipflop operators)
863 root 1.2
864 root 1.1 =head1 AUTHOR
865    
866     Marc Lehmann <schmorp@schmorp.de>
867     http://home.schmorp.de/
868    
869     =cut
870