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