ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Faster/Faster.pm
Revision: 1.34
Committed: Wed Mar 15 02:32:27 2006 UTC (18 years, 3 months ago) by root
Branch: MAIN
Changes since 1.33: +48 -21 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 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     $source .= " return nextop;\n";
515     }
516 root 1.11 }
517    
518 root 1.34 sub op_next {
519 root 1.11 out_break_op 0;
520     }
521    
522     sub op_last {
523     out_break_op 1;
524     }
525    
526     sub xop_redo {
527     out_break_op 2;
528     }
529    
530 root 1.4 sub cv2c {
531 root 1.1 my ($cv) = @_;
532    
533 root 1.18 local @ops;
534     local %op_regcomp;
535 root 1.11
536 root 1.34 my $curloop;
537 root 1.1 my @todo = $cv->START;
538 root 1.24 my %op_target;
539 root 1.30 my $numpushmark;
540 root 1.34 my $scope;
541 root 1.1
542 root 1.34 my %op_seen;
543 root 1.1 while (my $op = shift @todo) {
544 root 1.34 my $next;
545     for (; $$op; $op = $next) {
546     last if $op_seen{$$op}++;
547    
548     $next = $op->next;
549 root 1.11
550 root 1.1 my $name = $op->name;
551 root 1.11 my $class = B::class $op;
552    
553 root 1.24 my $insn = { op => $op };
554    
555 root 1.34 # end of loop reached?
556     $curloop = $curloop->{loop} if $curloop && $$op == ${$curloop->{loop_targ}[1]};
557    
558     # remember enclosing loop
559     $insn->{loop} = $curloop if $curloop;
560    
561 root 1.24 push @ops, $insn;
562    
563     if (exists $extend{$name}) {
564     my $extend = $extend{$name};
565     $extend = $extend->($op) if ref $extend;
566     $insn->{extend} = $extend if defined $extend;
567     }
568    
569 root 1.34 # TODO: mark scopes similar to loops, make them comparable
570     # static cxstack(?)
571 root 1.11 if ($class eq "LOGOP") {
572 root 1.24 push @todo, $op->other;
573     $op_target{${$op->other}}++;
574 root 1.18
575     # regcomp/o patches ops at runtime, lets expect that
576 root 1.24 if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
577     $op_target{${$op->first}}++;
578     $op_regcomp{${$op->first}} = $op->next;
579     }
580 root 1.18
581 root 1.11 } elsif ($class eq "PMOP") {
582 root 1.24 if (${$op->pmreplstart}) {
583     unshift @todo, $op->pmreplstart;
584     $op_target{${$op->pmreplstart}}++;
585     }
586 root 1.18
587 root 1.11 } elsif ($class eq "LOOP") {
588 root 1.34 my @targ = ($op->nextop, $op->lastop->next, $op->redoop);
589 root 1.24
590 root 1.34 unshift @todo, $next, $op->redoop, $op->nextop, $op->lastop;
591     $next = $op->redoop;
592 root 1.24
593     $op_target{$$_}++ for @targ;
594 root 1.30
595 root 1.34 $insn->{loop_targ} = \@targ;
596     $curloop = $insn;
597    
598 root 1.24 } elsif ($class eq "COP") {
599 root 1.34 if (defined $op->label) {
600     $insn->{bblock}++;
601     $curloop->{contains_label}{$op->label}++ if $curloop; #TODO: should be within loop
602     }
603 root 1.30
604     } else {
605     if ($name eq "pushmark") {
606     $numpushmark++;
607     }
608 root 1.1 }
609     }
610     }
611    
612 root 1.24 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
613    
614 root 1.4 local $source = <<EOF;
615     OP *%%%FUNC%%% (pTHX)
616     {
617 root 1.24 register OP *nextop = (OP *)${$ops[0]->{op}}L;
618 root 1.4 EOF
619 root 1.2
620 root 1.30 $source .= " faster_PUSHMARK_PREALLOC ($numpushmark);\n"
621     if $numpushmark;
622    
623 root 1.8 while (@ops) {
624 root 1.24 $insn = shift @ops;
625    
626     $op = $insn->{op};
627 root 1.8 $op_name = $op->name;
628 root 1.2
629 root 1.23 my $class = B::class $op;
630    
631 root 1.24 $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
632 root 1.8 $source .= "op_$$op: /* $op_name */\n";
633     #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
634 root 1.4 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
635    
636 root 1.11 $source .= " PERL_ASYNC_CHECK ();\n"
637 root 1.20 unless exists $f_noasync{$op_name};
638 root 1.2
639 root 1.8 if (my $can = __PACKAGE__->can ("op_$op_name")) {
640 root 1.11 # handcrafted replacement
641 root 1.24
642     if ($insn->{extend} > 0) {
643     # coalesce EXTENDs
644     # TODO: properly take negative preceeding and following EXTENDs into account
645     for my $i (@ops) {
646     last if exists $i->{bblock};
647     last unless exists $i->{extend};
648     my $extend = delete $i->{extend};
649     $insn->{extend} += $extend if $extend > 0;
650     }
651    
652     $source .= " { dSP; EXTEND (SP, $insn->{extend}); PUTBACK; }\n"
653     if $insn->{extend} > 0;
654     }
655    
656 root 1.2 $can->($op);
657 root 1.11
658 root 1.20 } elsif (exists $f_unsafe{$op_name}) {
659 root 1.11 # unsafe, return to interpreter
660     assert "nextop == (OP *)$$op";
661 root 1.9 $source .= " return nextop;\n";
662 root 1.11
663 root 1.23 } elsif ("LOGOP" eq $class) {
664     # logical operation with optional branch
665 root 1.11 out_callop;
666     out_cond_jump $op->other;
667     out_jump_next;
668    
669 root 1.23 } elsif ("PMOP" eq $class) {
670 root 1.11 # regex-thingy
671     out_callop;
672 root 1.23 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
673 root 1.11 out_jump_next;
674    
675 root 1.2 } else {
676 root 1.11 # normal operator, linear execution
677 root 1.8 out_linear;
678 root 1.2 }
679 root 1.1 }
680 root 1.2
681 root 1.11 $op_name = "func exit"; assert (0);
682    
683     $source .= <<EOF;
684     op_0:
685     return 0;
686     }
687     EOF
688 root 1.4 #warn $source;
689 root 1.2
690 root 1.4 $source
691     }
692    
693 root 1.19 my $uid = "aaaaaaa0";
694 root 1.27 my %so;
695    
696     sub func2ptr {
697     my (@func) = @_;
698 root 1.19
699 root 1.27 #LOCK
700 root 1.29 mkdir $CACHEDIR, 0777;
701     sysopen my $meta_fh, "$CACHEDIR/meta", &Fcntl::O_RDWR | &Fcntl::O_CREAT, 0666
702     or die "$$CACHEDIR/meta: $!";
703     binmode $meta_fh, ":raw:perlio";
704     fcntl_lock fileno $meta_fh
705     or die "$CACHEDIR/meta: $!";
706    
707     my $meta = eval { Storable::fd_retrieve $meta_fh } || { version => 1 };
708 root 1.4
709 root 1.27 for my $f (@func) {
710     $f->{func} = "F" . Digest::MD5::md5_hex ($f->{source});
711     $f->{so} = $meta->{$f->{func}};
712     }
713 root 1.4
714 root 1.27 if (grep !$_->{so}, @func) {
715     my $stem;
716    
717     do {
718     $stem = "$CACHEDIR/$$-" . $uid++;
719     } while -e "$stem$_so";
720    
721     open my $fh, ">:raw", "$stem.c";
722     print $fh <<EOF;
723 root 1.11 #define PERL_NO_GET_CONTEXT
724 root 1.24 #define PERL_CORE
725 root 1.11
726     #include <assert.h>
727    
728     #include "EXTERN.h"
729     #include "perl.h"
730     #include "XSUB.h"
731    
732 root 1.30 #if 1
733     # define faster_PUSHMARK_PREALLOC(count) while (PL_markstack_ptr + (count) >= PL_markstack_max) markstack_grow ()
734     # define faster_PUSHMARK(p) *++PL_markstack_ptr = (p) - PL_stack_base
735     #else
736     # define faster_PUSHMARK_PREALLOC(count) 1
737     # define faster_PUSHMARK(p) PUSHMARK(p)
738     #endif
739    
740 root 1.11 #define RUNOPS_TILL(op) \\
741 root 1.27 while (nextop != (op)) \\
742     { \\
743     PERL_ASYNC_CHECK (); \\
744     PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
745     }
746    
747     EOF
748     for my $f (grep !$_->{so}, @func) {
749     next if $f->{so} = $meta->{$f->{func}}; # some cv's alias others
750    
751     warn "compiling $f->{name} to $stem$_so:$f->{func}\n" if $verbose > 1;
752     my $source = $f->{source};
753     $source =~ s/%%%FUNC%%%/$f->{func}/g;
754     print $fh $source;
755     $meta->{$f->{func}} = $f->{so} = $stem;
756     }
757    
758     close $fh;
759     system "$COMPILE -o $stem$_o $stem.c";
760 root 1.34 unlink "$stem.c" unless $ENV{FASTER_DEBUG} & 1;
761 root 1.27 system "$LINK -o $stem$_so $stem$_o $LIBS";
762     unlink "$stem$_o";
763     }
764 root 1.11
765 root 1.27 for my $f (@func) {
766     my $stem = $f->{so};
767 root 1.4
768 root 1.27 my $so = ($so{$stem} ||= DynaLoader::dl_load_file "$stem$_so")
769     or die "$stem$_so: $!";
770 root 1.19
771 root 1.27 #unlink "$stem$_so";
772 root 1.4
773 root 1.27 $f->{ptr} = DynaLoader::dl_find_symbol $so, $f->{func}
774     or die "$f->{func} not found in $stem$_so: $!";
775     }
776 root 1.19
777 root 1.29 seek $meta_fh, 0, 0 or die "$CACHEDIR/meta: $!";
778     Storable::nstore_fd $meta, $meta_fh;
779     truncate $meta_fh, tell $meta_fh;
780    
781     # UNLOCK (by closing $meta_fh)
782 root 1.4 }
783    
784 root 1.19 my %ignore;
785    
786 root 1.4 sub entersub {
787     my ($cv) = @_;
788    
789 root 1.19 my $pkg = $cv->STASH->NAME;
790    
791     return if $ignore{$pkg};
792    
793 root 1.27 warn "optimising ", $cv->STASH->NAME, "\n"
794 root 1.21 if $verbose;
795 root 1.11
796 root 1.4 eval {
797 root 1.27 my @func;
798 root 1.4
799 root 1.28 push @func, {
800     cv => $cv,
801     name => "<>",
802     source => cv2c $cv,
803     };
804    
805 root 1.19 # always compile the whole stash
806     my %stash = $cv->STASH->ARRAY;
807     while (my ($k, $v) = each %stash) {
808     $v->isa (B::GV::)
809     or next;
810    
811     my $cv = $v->CV;
812    
813     if ($cv->isa (B::CV::)
814     && ${$cv->START}
815     && $cv->START->name ne "null") {
816 root 1.27
817     push @func, {
818     cv => $cv,
819     name => $k,
820     source => cv2c $cv,
821     };
822 root 1.19 }
823     }
824    
825 root 1.27 func2ptr @func;
826 root 1.4
827 root 1.27 for my $f (@func) {
828     patch_cv $f->{cv}, $f->{ptr};
829 root 1.19 }
830 root 1.4 };
831    
832 root 1.19 if ($@) {
833     $ignore{$pkg}++;
834     warn $@;
835     }
836 root 1.1 }
837    
838     hook_entersub;
839    
840     1;
841    
842     =back
843    
844 root 1.21 =head1 ENVIRONMENT VARIABLES
845    
846     The following environment variables influence the behaviour of Faster:
847    
848     =over 4
849    
850     =item FASTER_VERBOSE
851    
852     Faster will output more informational messages when set to values higher
853 root 1.29 than C<0>. Currently, C<1> outputs which packages are being compiled, C<3>
854     outputs the cache directory and C<10> outputs information on which perl
855     function is compiled into which shared object.
856 root 1.21
857     =item FASTER_DEBUG
858    
859     Add debugging code when set to values higher than C<0>. Currently, this
860 root 1.30 adds 1-3 C<assert>'s per perl op (FASTER_DEBUG > 1), to ensure that opcode
861     order and C execution order are compatible.
862 root 1.21
863     =item FASTER_CACHE
864    
865 root 1.29 Set a persistent cache directory that caches compiled code fragments. The
866     default is C<$HOME/.perl-faster-cache> if C<HOME> is set and a temporary
867     directory otherwise.
868 root 1.21
869 root 1.29 This directory will always grow in size, so you might need to erase it
870 root 1.21 from time to time.
871    
872     =back
873    
874 root 1.11 =head1 BUGS/LIMITATIONS
875    
876     Perl will check much less often for asynchronous signals in
877     Faster-compiled code. It tries to check on every function call, loop
878     iteration and every I/O operator, though.
879    
880     The following things will disable Faster. If you manage to enable them at
881 root 1.19 runtime, bad things will happen. Enabling them at startup will be fine,
882     though.
883 root 1.11
884     enabled tainting
885     enabled debugging
886    
887 root 1.19 Thread-enabled builds of perl will dramatically reduce Faster's
888     performance, but you don't care about speed if you enable threads anyway.
889 root 1.11
890 root 1.19 These constructs will force the use of the interpreter for the currently
891     executed function as soon as they are being encountered during execution.
892 root 1.11
893     goto
894     next, redo (but not well-behaved last's)
895 root 1.34 labels, if used
896 root 1.11 eval
897     require
898     any use of formats
899 root 1.19 .., ... (flipflop operators)
900 root 1.2
901 root 1.1 =head1 AUTHOR
902    
903     Marc Lehmann <schmorp@schmorp.de>
904     http://home.schmorp.de/
905    
906     =cut
907