ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Faster/Faster.pm
Revision: 1.31
Committed: Mon Mar 13 16:59:43 2006 UTC (18 years, 3 months ago) by root
Branch: MAIN
Changes since 1.30: +2 -1 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.31 complement cond_expr and or not
160     bit_and bit_or bit_xor
161 root 1.20 defined
162 root 1.24 method method_named bless
163 root 1.20 preinc postinc predec postdec
164     aelem aelemfast helem delete exists
165 root 1.30 pushre subst list lslice join split concat
166 root 1.20 length substr stringify ord
167     push pop shift unshift
168     eq ne gt lt ge le
169     regcomp regcreset regcmaybe
170     );
171 root 1.2
172 root 1.11 my %callop = (
173 root 1.26 entersub => "(PL_op->op_ppaddr) (aTHX)",
174 root 1.11 mapstart => "Perl_pp_grepstart (aTHX)",
175     );
176    
177 root 1.8 sub callop {
178 root 1.11 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
179     }
180    
181     sub assert {
182     return unless $opt_assert;
183     $source .= " assert ((\"$op_name\", ($_[0])));\n";
184     }
185    
186     sub out_callop {
187     assert "nextop == (OP *)$$op";
188     $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
189 root 1.8 }
190    
191 root 1.18 sub out_cond_jump {
192     $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
193     }
194    
195 root 1.11 sub out_jump_next {
196 root 1.18 out_cond_jump $op_regcomp{$$op}
197     if $op_regcomp{$$op};
198    
199 root 1.11 assert "nextop == (OP *)${$op->next}";
200     $source .= " goto op_${$op->next};\n";
201 root 1.2 }
202    
203 root 1.9 sub out_next {
204     $source .= " nextop = (OP *)${$op->next}L;\n";
205    
206 root 1.11 out_jump_next;
207 root 1.9 }
208    
209 root 1.8 sub out_linear {
210 root 1.11 out_callop;
211     out_jump_next;
212     }
213    
214     sub op_entersub {
215     out_callop;
216     $source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n";
217     out_jump_next;
218 root 1.4 }
219    
220 root 1.11 *op_require = \&op_entersub;
221    
222 root 1.2 sub op_nextstate {
223 root 1.4 $source .= " PL_curcop = (COP *)nextop;\n";
224 root 1.2 $source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
225     $source .= " FREETMPS;\n";
226    
227 root 1.8 out_next;
228 root 1.2 }
229    
230 root 1.3 sub op_pushmark {
231 root 1.30 $source .= " faster_PUSHMARK (PL_stack_sp);\n";
232 root 1.3
233 root 1.8 out_next;
234 root 1.3 }
235    
236 root 1.13 if ($Config{useithreads} ne "define") {
237 root 1.8 # disable optimisations on ithreads
238    
239     *op_const = sub {
240 root 1.24 $source .= " { dSP; PUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
241 root 1.8
242 root 1.26 $ops[0]{follows_const}++ if @ops;#d#
243    
244 root 1.8 out_next;
245     };
246    
247     *op_gv = \&op_const;
248    
249     *op_aelemfast = sub {
250     my $targ = $op->targ;
251     my $private = $op->private;
252    
253     $source .= " {\n";
254    
255     if ($op->flags & B::OPf_SPECIAL) {
256     $source .= " AV *av = (AV*)PAD_SV((PADOFFSET)$targ);\n";
257     } else {
258     $source .= " AV *av = GvAV ((GV *)${$op->sv}L);\n";
259     }
260    
261     if ($op->flags & B::OPf_MOD) {
262     $source .= " SV *sv = *av_fetch (av, $private, 1);\n";
263     } else {
264     $source .= " SV **svp = av_fetch (av, $private, 0); SV *sv = svp ? *svp : &PL_sv_undef;\n";
265     }
266    
267     if (!($op->flags & B::OPf_MOD)) {
268     $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
269     }
270    
271     $source .= " dSP;\n";
272 root 1.24 $source .= " PUSHs (sv);\n";
273 root 1.8 $source .= " PUTBACK;\n";
274     $source .= " }\n";
275    
276     out_next;
277     };
278 root 1.2
279 root 1.8 *op_gvsv = sub {
280     $source .= " {\n";
281     $source .= " dSP;\n";
282 root 1.2
283 root 1.8 if ($op->private & B::OPpLVAL_INTRO) {
284     $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
285     } else {
286     $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
287     }
288    
289     $source .= " PUTBACK;\n";
290     $source .= " }\n";
291    
292     out_next;
293     };
294 root 1.2 }
295    
296 root 1.12 # does kill Crossfire/res2pm
297     sub op_stringify {
298     my $targ = $op->targ;
299    
300     $source .= <<EOF;
301     {
302     dSP;
303     SV *targ = PAD_SV ((PADOFFSET)$targ);
304     sv_copypv (TARG, TOPs);
305     SETTARG;
306     PUTBACK;
307     }
308     EOF
309 root 1.3
310 root 1.8 out_next;
311 root 1.3 }
312    
313 root 1.4 sub op_and {
314     $source .= <<EOF;
315     {
316     dSP;
317 root 1.5
318 root 1.4 if (SvTRUE (TOPs))
319     {
320     --SP;
321     PUTBACK;
322     nextop = (OP *)${$op->other}L;
323     goto op_${$op->other};
324     }
325     }
326     EOF
327 root 1.5
328 root 1.8 out_next;
329 root 1.4 }
330    
331 root 1.7 sub op_or {
332     $source .= <<EOF;
333     {
334     dSP;
335    
336     if (!SvTRUE (TOPs))
337     {
338     --SP;
339     PUTBACK;
340     nextop = (OP *)${$op->other}L;
341     goto op_${$op->other};
342     }
343     }
344     EOF
345    
346 root 1.8 out_next;
347 root 1.7 }
348    
349 root 1.4 sub op_padsv {
350     my $flags = $op->flags;
351 root 1.24 my $padofs = "(PADOFFSET)" . $op->targ;
352    
353 root 1.4 $source .= <<EOF;
354     {
355     dSP;
356 root 1.24 SV *sv = PAD_SVl ($padofs);
357     EOF
358    
359     if (($flags & B::OPf_MOD) && ($op->private & B::OPpLVAL_INTRO)) {
360     $source .= " SAVECLEARSV (PAD_SVl ($padofs));\n";
361 root 1.26 $ops[0]{follows_padsv_lval_intro}++ if @ops;#d#
362 root 1.24 }
363    
364     $source .= <<EOF;
365     PUSHs (sv);
366 root 1.4 PUTBACK;
367     EOF
368 root 1.24
369     if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
370 root 1.27 $source .= " if (!SvROK (sv)) vivify_ref (sv, " . $op->private . " & OPpDEREF);\n";
371 root 1.24 }
372     $source .= " }\n";
373    
374     out_next;
375     }
376    
377     sub op_sassign {
378     $source .= <<EOF;
379     {
380     dSP;
381     dPOPTOPssrl;
382     EOF
383     $source .= " SV *temp = left; left = right; right = temp;\n"
384     if $op->private & B::OPpASSIGN_BACKWARDS;
385    
386 root 1.26 if ($insn->{follows_padsv_lval_intro} && !($op->private & B::OPpASSIGN_BACKWARDS)) {
387 root 1.24 # simple assignment - the target exists, but is basically undef
388     $source .= " SvSetSV (right, left);\n";
389     } else {
390     $source .= " SvSetMagicSV (right, left);\n";
391 root 1.4 }
392 root 1.24
393 root 1.4 $source .= <<EOF;
394 root 1.24 SETs (right);
395     PUTBACK;
396 root 1.4 }
397     EOF
398    
399 root 1.24 out_next;
400 root 1.6 }
401    
402 root 1.3 # pattern const+ (or general push1)
403     # pattern pushmark gv rv2av pushmark padsv+o.รค. aassign
404    
405 root 1.12 sub op_method_named {
406 root 1.26 if ($insn->{follows_const}) {
407     $source .= <<EOF;
408     {
409     dSP;
410     static SV *last_cv;
411     static U32 last_sub_generation;
412    
413     /* simple "polymorphic" inline cache */
414     if (PL_sub_generation == last_sub_generation)
415     {
416     PUSHs (last_cv);
417     PUTBACK;
418     }
419     else
420     {
421     PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
422    
423     SPAGAIN;
424     last_sub_generation = PL_sub_generation;
425     last_cv = TOPs;
426     }
427     }
428     EOF
429     } else {
430     $source .= <<EOF;
431 root 1.3 {
432 root 1.4 static HV *last_stash;
433 root 1.11 static SV *last_cv;
434     static U32 last_sub_generation;
435 root 1.4
436     SV *obj = *(PL_stack_base + TOPMARK + 1);
437 root 1.3
438 root 1.11 if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
439 root 1.3 {
440 root 1.4 dSP;
441     HV *stash = SvSTASH (SvRV (obj));
442 root 1.3
443 root 1.4 /* simple "polymorphic" inline cache */
444 root 1.11 if (stash == last_stash
445     && PL_sub_generation == last_sub_generation)
446 root 1.3 {
447 root 1.24 PUSHs (last_cv);
448 root 1.4 PUTBACK;
449 root 1.3 }
450     else
451     {
452 root 1.11 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
453 root 1.4
454 root 1.3 SPAGAIN;
455 root 1.11 last_sub_generation = PL_sub_generation;
456     last_stash = stash;
457     last_cv = TOPs;
458 root 1.3 }
459     }
460 root 1.4 else
461     {
462     /* error case usually */
463 root 1.11 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
464 root 1.4 }
465 root 1.3 }
466     EOF
467 root 1.26 }
468 root 1.3
469 root 1.8 out_next;
470 root 1.3 }
471    
472 root 1.11 sub op_grepstart {
473     out_callop;
474 root 1.14 $op = $op->next;
475     out_cond_jump $op->other;
476 root 1.11 out_jump_next;
477     }
478    
479     *op_mapstart = \&op_grepstart;
480    
481     sub op_substcont {
482     out_callop;
483     out_cond_jump $op->other->pmreplstart;
484     assert "nextop == (OP *)${$op->other->next}L";
485     $source .= " goto op_${$op->other->next};\n";
486     }
487    
488     sub out_break_op {
489     my ($idx) = @_;
490    
491     out_callop;
492    
493     out_cond_jump $_->[$idx]
494 root 1.18 for reverse @op_loop;
495 root 1.11
496     $source .= " return nextop;\n";
497     }
498    
499     sub xop_next {
500     out_break_op 0;
501     }
502    
503     sub op_last {
504     out_break_op 1;
505     }
506    
507     sub xop_redo {
508     out_break_op 2;
509     }
510    
511 root 1.4 sub cv2c {
512 root 1.1 my ($cv) = @_;
513    
514 root 1.18 local @ops;
515     local @op_loop;
516     local %op_regcomp;
517 root 1.11
518 root 1.1 my %opsseen;
519     my @todo = $cv->START;
520 root 1.24 my %op_target;
521 root 1.30 my $numpushmark;
522 root 1.1
523     while (my $op = shift @todo) {
524     for (; $$op; $op = $op->next) {
525     last if $opsseen{$$op}++;
526 root 1.11
527 root 1.1 my $name = $op->name;
528 root 1.11 my $class = B::class $op;
529    
530 root 1.24 my $insn = { op => $op };
531    
532     push @ops, $insn;
533    
534     if (exists $extend{$name}) {
535     my $extend = $extend{$name};
536     $extend = $extend->($op) if ref $extend;
537     $insn->{extend} = $extend if defined $extend;
538     }
539    
540     push @todo, $op->next;
541    
542 root 1.11 if ($class eq "LOGOP") {
543 root 1.24 push @todo, $op->other;
544     $op_target{${$op->other}}++;
545 root 1.18
546     # regcomp/o patches ops at runtime, lets expect that
547 root 1.24 if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
548     $op_target{${$op->first}}++;
549     $op_regcomp{${$op->first}} = $op->next;
550     }
551 root 1.18
552 root 1.11 } elsif ($class eq "PMOP") {
553 root 1.24 if (${$op->pmreplstart}) {
554     unshift @todo, $op->pmreplstart;
555     $op_target{${$op->pmreplstart}}++;
556     }
557 root 1.18
558 root 1.11 } elsif ($class eq "LOOP") {
559 root 1.24 my @targ = ($op->nextop, $op->lastop->next, $op->redoop->next);
560    
561     push @op_loop, \@targ;
562     push @todo, @targ;
563    
564     $op_target{$$_}++ for @targ;
565 root 1.30
566 root 1.24 } elsif ($class eq "COP") {
567     $insn->{bblock}++ if defined $op->label;
568 root 1.30
569     } else {
570     if ($name eq "pushmark") {
571     $numpushmark++;
572     }
573 root 1.1 }
574     }
575     }
576    
577 root 1.24 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
578    
579 root 1.4 local $source = <<EOF;
580     OP *%%%FUNC%%% (pTHX)
581     {
582 root 1.24 register OP *nextop = (OP *)${$ops[0]->{op}}L;
583 root 1.4 EOF
584 root 1.2
585 root 1.30 $source .= " faster_PUSHMARK_PREALLOC ($numpushmark);\n"
586     if $numpushmark;
587    
588 root 1.8 while (@ops) {
589 root 1.24 $insn = shift @ops;
590    
591     $op = $insn->{op};
592 root 1.8 $op_name = $op->name;
593 root 1.2
594 root 1.23 my $class = B::class $op;
595    
596 root 1.24 $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
597 root 1.8 $source .= "op_$$op: /* $op_name */\n";
598     #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
599 root 1.4 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
600    
601 root 1.11 $source .= " PERL_ASYNC_CHECK ();\n"
602 root 1.20 unless exists $f_noasync{$op_name};
603 root 1.2
604 root 1.8 if (my $can = __PACKAGE__->can ("op_$op_name")) {
605 root 1.11 # handcrafted replacement
606 root 1.24
607     if ($insn->{extend} > 0) {
608     # coalesce EXTENDs
609     # TODO: properly take negative preceeding and following EXTENDs into account
610     for my $i (@ops) {
611     last if exists $i->{bblock};
612     last unless exists $i->{extend};
613     my $extend = delete $i->{extend};
614     $insn->{extend} += $extend if $extend > 0;
615     }
616    
617     $source .= " { dSP; EXTEND (SP, $insn->{extend}); PUTBACK; }\n"
618     if $insn->{extend} > 0;
619     }
620    
621 root 1.2 $can->($op);
622 root 1.11
623 root 1.20 } elsif (exists $f_unsafe{$op_name}) {
624 root 1.11 # unsafe, return to interpreter
625     assert "nextop == (OP *)$$op";
626 root 1.9 $source .= " return nextop;\n";
627 root 1.11
628 root 1.23 } elsif ("LOGOP" eq $class) {
629     # logical operation with optional branch
630 root 1.11 out_callop;
631     out_cond_jump $op->other;
632     out_jump_next;
633    
634 root 1.23 } elsif ("PMOP" eq $class) {
635 root 1.11 # regex-thingy
636     out_callop;
637 root 1.23 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
638 root 1.11 out_jump_next;
639    
640 root 1.2 } else {
641 root 1.11 # normal operator, linear execution
642 root 1.8 out_linear;
643 root 1.2 }
644 root 1.1 }
645 root 1.2
646 root 1.11 $op_name = "func exit"; assert (0);
647    
648     $source .= <<EOF;
649     op_0:
650     return 0;
651     }
652     EOF
653 root 1.4 #warn $source;
654 root 1.2
655 root 1.4 $source
656     }
657    
658 root 1.19 my $uid = "aaaaaaa0";
659 root 1.27 my %so;
660    
661     sub func2ptr {
662     my (@func) = @_;
663 root 1.19
664 root 1.27 #LOCK
665 root 1.29 mkdir $CACHEDIR, 0777;
666     sysopen my $meta_fh, "$CACHEDIR/meta", &Fcntl::O_RDWR | &Fcntl::O_CREAT, 0666
667     or die "$$CACHEDIR/meta: $!";
668     binmode $meta_fh, ":raw:perlio";
669     fcntl_lock fileno $meta_fh
670     or die "$CACHEDIR/meta: $!";
671    
672     my $meta = eval { Storable::fd_retrieve $meta_fh } || { version => 1 };
673 root 1.4
674 root 1.27 for my $f (@func) {
675     $f->{func} = "F" . Digest::MD5::md5_hex ($f->{source});
676     $f->{so} = $meta->{$f->{func}};
677     }
678 root 1.4
679 root 1.27 if (grep !$_->{so}, @func) {
680     my $stem;
681    
682     do {
683     $stem = "$CACHEDIR/$$-" . $uid++;
684     } while -e "$stem$_so";
685    
686     open my $fh, ">:raw", "$stem.c";
687     print $fh <<EOF;
688 root 1.11 #define PERL_NO_GET_CONTEXT
689 root 1.24 #define PERL_CORE
690 root 1.11
691     #include <assert.h>
692    
693     #include "EXTERN.h"
694     #include "perl.h"
695     #include "XSUB.h"
696    
697 root 1.30 #if 1
698     # define faster_PUSHMARK_PREALLOC(count) while (PL_markstack_ptr + (count) >= PL_markstack_max) markstack_grow ()
699     # define faster_PUSHMARK(p) *++PL_markstack_ptr = (p) - PL_stack_base
700     #else
701     # define faster_PUSHMARK_PREALLOC(count) 1
702     # define faster_PUSHMARK(p) PUSHMARK(p)
703     #endif
704    
705 root 1.11 #define RUNOPS_TILL(op) \\
706 root 1.27 while (nextop != (op)) \\
707     { \\
708     PERL_ASYNC_CHECK (); \\
709     PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
710     }
711    
712     EOF
713     for my $f (grep !$_->{so}, @func) {
714     next if $f->{so} = $meta->{$f->{func}}; # some cv's alias others
715    
716     warn "compiling $f->{name} to $stem$_so:$f->{func}\n" if $verbose > 1;
717     my $source = $f->{source};
718     $source =~ s/%%%FUNC%%%/$f->{func}/g;
719     print $fh $source;
720     $meta->{$f->{func}} = $f->{so} = $stem;
721     }
722    
723     close $fh;
724     system "$COMPILE -o $stem$_o $stem.c";
725 root 1.30 unlink "$stem.c" unless $ENV{FASTER_DEBUG} > 0;
726 root 1.27 system "$LINK -o $stem$_so $stem$_o $LIBS";
727     unlink "$stem$_o";
728     }
729 root 1.11
730 root 1.27 for my $f (@func) {
731     my $stem = $f->{so};
732 root 1.4
733 root 1.27 my $so = ($so{$stem} ||= DynaLoader::dl_load_file "$stem$_so")
734     or die "$stem$_so: $!";
735 root 1.19
736 root 1.27 #unlink "$stem$_so";
737 root 1.4
738 root 1.27 $f->{ptr} = DynaLoader::dl_find_symbol $so, $f->{func}
739     or die "$f->{func} not found in $stem$_so: $!";
740     }
741 root 1.19
742 root 1.29 seek $meta_fh, 0, 0 or die "$CACHEDIR/meta: $!";
743     Storable::nstore_fd $meta, $meta_fh;
744     truncate $meta_fh, tell $meta_fh;
745    
746     # UNLOCK (by closing $meta_fh)
747 root 1.4 }
748    
749 root 1.19 my %ignore;
750    
751 root 1.4 sub entersub {
752     my ($cv) = @_;
753    
754 root 1.19 my $pkg = $cv->STASH->NAME;
755    
756     return if $ignore{$pkg};
757    
758 root 1.27 warn "optimising ", $cv->STASH->NAME, "\n"
759 root 1.21 if $verbose;
760 root 1.11
761 root 1.4 eval {
762 root 1.27 my @func;
763 root 1.4
764 root 1.28 push @func, {
765     cv => $cv,
766     name => "<>",
767     source => cv2c $cv,
768     };
769    
770 root 1.19 # always compile the whole stash
771     my %stash = $cv->STASH->ARRAY;
772     while (my ($k, $v) = each %stash) {
773     $v->isa (B::GV::)
774     or next;
775    
776     my $cv = $v->CV;
777    
778     if ($cv->isa (B::CV::)
779     && ${$cv->START}
780     && $cv->START->name ne "null") {
781 root 1.27
782     push @func, {
783     cv => $cv,
784     name => $k,
785     source => cv2c $cv,
786     };
787 root 1.19 }
788     }
789    
790 root 1.27 func2ptr @func;
791 root 1.4
792 root 1.27 for my $f (@func) {
793     patch_cv $f->{cv}, $f->{ptr};
794 root 1.19 }
795 root 1.4 };
796    
797 root 1.19 if ($@) {
798     $ignore{$pkg}++;
799     warn $@;
800     }
801 root 1.1 }
802    
803     hook_entersub;
804    
805     1;
806    
807     =back
808    
809 root 1.21 =head1 ENVIRONMENT VARIABLES
810    
811     The following environment variables influence the behaviour of Faster:
812    
813     =over 4
814    
815     =item FASTER_VERBOSE
816    
817     Faster will output more informational messages when set to values higher
818 root 1.29 than C<0>. Currently, C<1> outputs which packages are being compiled, C<3>
819     outputs the cache directory and C<10> outputs information on which perl
820     function is compiled into which shared object.
821 root 1.21
822     =item FASTER_DEBUG
823    
824     Add debugging code when set to values higher than C<0>. Currently, this
825 root 1.30 adds 1-3 C<assert>'s per perl op (FASTER_DEBUG > 1), to ensure that opcode
826     order and C execution order are compatible.
827 root 1.21
828     =item FASTER_CACHE
829    
830 root 1.29 Set a persistent cache directory that caches compiled code fragments. The
831     default is C<$HOME/.perl-faster-cache> if C<HOME> is set and a temporary
832     directory otherwise.
833 root 1.21
834 root 1.29 This directory will always grow in size, so you might need to erase it
835 root 1.21 from time to time.
836    
837     =back
838    
839 root 1.11 =head1 BUGS/LIMITATIONS
840    
841     Perl will check much less often for asynchronous signals in
842     Faster-compiled code. It tries to check on every function call, loop
843     iteration and every I/O operator, though.
844    
845     The following things will disable Faster. If you manage to enable them at
846 root 1.19 runtime, bad things will happen. Enabling them at startup will be fine,
847     though.
848 root 1.11
849     enabled tainting
850     enabled debugging
851    
852 root 1.19 Thread-enabled builds of perl will dramatically reduce Faster's
853     performance, but you don't care about speed if you enable threads anyway.
854 root 1.11
855 root 1.19 These constructs will force the use of the interpreter for the currently
856     executed function as soon as they are being encountered during execution.
857 root 1.11
858     goto
859     next, redo (but not well-behaved last's)
860     eval
861     require
862     any use of formats
863 root 1.19 .., ... (flipflop operators)
864 root 1.2
865 root 1.1 =head1 AUTHOR
866    
867     Marc Lehmann <schmorp@schmorp.de>
868     http://home.schmorp.de/
869    
870     =cut
871