ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Faster/Faster.pm
Revision: 1.36
Committed: Sat Feb 21 08:27:38 2009 UTC (15 years, 3 months ago) by root
Branch: MAIN
CVS Tags: rel-0_1, HEAD
Changes since 1.35: +1 -1 lines
Log Message:
rel-0_1

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