ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Faster/Faster.pm
Revision: 1.23
Committed: Fri Mar 10 22:45:18 2006 UTC (18 years, 3 months ago) by root
Branch: MAIN
Changes since 1.22: +6 -4 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.18 F</tmp>, and it will even create those temporary files in an insecure
32     manner, so watch out.
33    
34 root 1.1 =over 4
35    
36     =cut
37    
38     package Faster;
39    
40     use strict;
41 root 1.4 use Config;
42     use B ();
43 root 1.19 #use Digest::MD5 ();
44 root 1.4 use DynaLoader ();
45 root 1.22 use File::Temp ();
46 root 1.1
47     BEGIN {
48     our $VERSION = '0.01';
49    
50     require XSLoader;
51     XSLoader::load __PACKAGE__, $VERSION;
52     }
53    
54 root 1.4 my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}";
55     my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
56     my $LIBS = "$Config{libs}";
57     my $_o = $Config{_o};
58     my $_so = ".so";
59 root 1.1
60 root 1.13 # we don't need no steenking PIC on x86
61     $COMPILE =~ s/-f(?:PIC|pic)//g
62     if $Config{archname} =~ /^(i[3456]86)-/;
63    
64 root 1.21 my $opt_assert = $ENV{FASTER_DEBUG};
65     my $verbose = $ENV{FASTER_VERBOSE}+0;
66 root 1.11
67 root 1.1 our $source;
68    
69 root 1.18 our @ops;
70     our $op;
71     our $op_name;
72     our @op_loop;
73     our %op_regcomp;
74 root 1.8
75 root 1.20 my %f_unsafe = map +($_ => undef), qw(
76     leavesub leavesublv return
77     goto last redo next
78     eval flip leaveeval entertry
79     formline grepstart mapstart
80     substcont entereval require
81     );
82 root 1.2
83 root 1.20 # pushmark extend=0
84     # padsv extend=1
85     # padav extend=1
86     # padhv extend=1
87     # padany extend=1
88     # const extend=1
89    
90     my %f_noasync = map +($_ => undef), qw(
91     mapstart grepstart match entereval
92     enteriter entersub leaveloop
93    
94     pushmark nextstate
95    
96     const stub unstack
97     last next redo seq
98     padsv padav padhv padany
99     aassign sassign orassign
100     rv2av rv2cv rv2gv rv2hv refgen
101     gv gvsv
102     add subtract multiply divide
103     complement cond_expr and or not
104     defined
105     method_named
106     preinc postinc predec postdec
107     aelem aelemfast helem delete exists
108     pushre subst list join split concat
109     length substr stringify ord
110     push pop shift unshift
111     eq ne gt lt ge le
112     regcomp regcreset regcmaybe
113     );
114 root 1.2
115 root 1.11 my %callop = (
116     entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)",
117     mapstart => "Perl_pp_grepstart (aTHX)",
118     );
119    
120 root 1.8 sub callop {
121 root 1.11 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
122     }
123    
124     sub assert {
125     return unless $opt_assert;
126     $source .= " assert ((\"$op_name\", ($_[0])));\n";
127     }
128    
129     sub out_callop {
130     assert "nextop == (OP *)$$op";
131     $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
132 root 1.8 }
133    
134 root 1.18 sub out_cond_jump {
135     $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
136     }
137    
138 root 1.11 sub out_jump_next {
139 root 1.18 out_cond_jump $op_regcomp{$$op}
140     if $op_regcomp{$$op};
141    
142 root 1.11 assert "nextop == (OP *)${$op->next}";
143     $source .= " goto op_${$op->next};\n";
144 root 1.2 }
145    
146 root 1.9 sub out_next {
147     $source .= " nextop = (OP *)${$op->next}L;\n";
148    
149 root 1.11 out_jump_next;
150 root 1.9 }
151    
152 root 1.8 sub out_linear {
153 root 1.11 out_callop;
154     out_jump_next;
155     }
156    
157     sub op_entersub {
158     out_callop;
159     $source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n";
160     out_jump_next;
161 root 1.4 }
162    
163 root 1.11 *op_require = \&op_entersub;
164    
165 root 1.2 sub op_nextstate {
166 root 1.4 $source .= " PL_curcop = (COP *)nextop;\n";
167 root 1.2 $source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
168     $source .= " FREETMPS;\n";
169    
170 root 1.8 out_next;
171 root 1.2 }
172    
173 root 1.3 sub op_pushmark {
174     $source .= " PUSHMARK (PL_stack_sp);\n";
175    
176 root 1.8 out_next;
177 root 1.3 }
178    
179 root 1.13 if ($Config{useithreads} ne "define") {
180 root 1.8 # disable optimisations on ithreads
181    
182     *op_const = sub {
183     $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
184    
185     out_next;
186     };
187    
188     *op_gv = \&op_const;
189    
190     *op_aelemfast = sub {
191     my $targ = $op->targ;
192     my $private = $op->private;
193    
194     $source .= " {\n";
195    
196     if ($op->flags & B::OPf_SPECIAL) {
197     $source .= " AV *av = (AV*)PAD_SV((PADOFFSET)$targ);\n";
198     } else {
199     $source .= " AV *av = GvAV ((GV *)${$op->sv}L);\n";
200     }
201    
202     if ($op->flags & B::OPf_MOD) {
203     $source .= " SV *sv = *av_fetch (av, $private, 1);\n";
204     } else {
205     $source .= " SV **svp = av_fetch (av, $private, 0); SV *sv = svp ? *svp : &PL_sv_undef;\n";
206     }
207    
208     if (!($op->flags & B::OPf_MOD)) {
209     $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
210     }
211    
212     $source .= " dSP;\n";
213     $source .= " XPUSHs (sv);\n";
214     $source .= " PUTBACK;\n";
215     $source .= " }\n";
216    
217     out_next;
218     };
219 root 1.2
220 root 1.8 *op_gvsv = sub {
221     $source .= " {\n";
222     $source .= " dSP;\n";
223     $source .= " EXTEND (SP, 1);\n";
224 root 1.2
225 root 1.8 if ($op->private & B::OPpLVAL_INTRO) {
226     $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
227     } else {
228     $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
229     }
230    
231     $source .= " PUTBACK;\n";
232     $source .= " }\n";
233    
234     out_next;
235     };
236 root 1.2 }
237    
238 root 1.12 # does kill Crossfire/res2pm
239     sub op_stringify {
240     my $targ = $op->targ;
241    
242     $source .= <<EOF;
243     {
244     dSP;
245     SV *targ = PAD_SV ((PADOFFSET)$targ);
246     sv_copypv (TARG, TOPs);
247     SETTARG;
248     PUTBACK;
249     }
250     EOF
251 root 1.3
252 root 1.8 out_next;
253 root 1.3 }
254    
255 root 1.4 sub op_and {
256     $source .= <<EOF;
257     {
258     dSP;
259 root 1.5
260 root 1.4 if (SvTRUE (TOPs))
261     {
262     --SP;
263     PUTBACK;
264     nextop = (OP *)${$op->other}L;
265     goto op_${$op->other};
266     }
267     }
268     EOF
269 root 1.5
270 root 1.8 out_next;
271 root 1.4 }
272    
273 root 1.7 sub op_or {
274     $source .= <<EOF;
275     {
276     dSP;
277    
278     if (!SvTRUE (TOPs))
279     {
280     --SP;
281     PUTBACK;
282     nextop = (OP *)${$op->other}L;
283     goto op_${$op->other};
284     }
285     }
286     EOF
287    
288 root 1.8 out_next;
289 root 1.7 }
290    
291 root 1.4 sub op_padsv {
292     my $flags = $op->flags;
293 root 1.21 my $targ = $op->targ;
294 root 1.4
295     $source .= <<EOF;
296     {
297     dSP;
298 root 1.21 XPUSHs (PAD_SV ((PADOFFSET)$targ));
299 root 1.4 PUTBACK;
300     EOF
301     if ($op->flags & B::OPf_MOD) {
302     if ($op->private & B::OPpLVAL_INTRO) {
303 root 1.21 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$targ));\n";
304 root 1.4 } elsif ($op->private & B::OPpDEREF) {
305     my $deref = $op->private & B::OPpDEREF;
306 root 1.22 $source .= " Perl_vivify_ref (aTHX_ PAD_SVl ((PADOFFSET)$targ), $deref);\n";
307 root 1.4 }
308     }
309     $source .= <<EOF;
310     }
311     EOF
312    
313 root 1.8 out_next;
314 root 1.6 }
315    
316 root 1.3 # pattern const+ (or general push1)
317     # pattern pushmark return(?)
318     # pattern pushmark gv rv2av pushmark padsv+o.รค. aassign
319    
320     # pattern const method_named
321 root 1.12 sub op_method_named {
322 root 1.3 $source .= <<EOF;
323     {
324 root 1.4 static HV *last_stash;
325 root 1.11 static SV *last_cv;
326     static U32 last_sub_generation;
327 root 1.4
328     SV *obj = *(PL_stack_base + TOPMARK + 1);
329 root 1.3
330 root 1.11 if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
331 root 1.3 {
332 root 1.4 dSP;
333     HV *stash = SvSTASH (SvRV (obj));
334 root 1.3
335 root 1.4 /* simple "polymorphic" inline cache */
336 root 1.11 if (stash == last_stash
337     && PL_sub_generation == last_sub_generation)
338 root 1.3 {
339 root 1.11 XPUSHs (last_cv);
340 root 1.4 PUTBACK;
341 root 1.3 }
342     else
343     {
344 root 1.11 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
345 root 1.4
346 root 1.3 SPAGAIN;
347 root 1.11 last_sub_generation = PL_sub_generation;
348     last_stash = stash;
349     last_cv = TOPs;
350 root 1.3 }
351     }
352 root 1.4 else
353     {
354     /* error case usually */
355 root 1.11 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
356 root 1.4 }
357 root 1.3 }
358     EOF
359    
360 root 1.8 out_next;
361 root 1.3 }
362    
363 root 1.11 sub op_grepstart {
364     out_callop;
365 root 1.14 $op = $op->next;
366     out_cond_jump $op->other;
367 root 1.11 out_jump_next;
368     }
369    
370     *op_mapstart = \&op_grepstart;
371    
372     sub op_substcont {
373     out_callop;
374     out_cond_jump $op->other->pmreplstart;
375     assert "nextop == (OP *)${$op->other->next}L";
376     $source .= " goto op_${$op->other->next};\n";
377     }
378    
379     sub out_break_op {
380     my ($idx) = @_;
381    
382     out_callop;
383    
384     out_cond_jump $_->[$idx]
385 root 1.18 for reverse @op_loop;
386 root 1.11
387     $source .= " return nextop;\n";
388     }
389    
390     sub xop_next {
391     out_break_op 0;
392     }
393    
394     sub op_last {
395     out_break_op 1;
396     }
397    
398     sub xop_redo {
399     out_break_op 2;
400     }
401    
402 root 1.4 sub cv2c {
403 root 1.1 my ($cv) = @_;
404    
405 root 1.18 local @ops;
406     local @op_loop;
407     local %op_regcomp;
408 root 1.11
409 root 1.1 my %opsseen;
410     my @todo = $cv->START;
411    
412     while (my $op = shift @todo) {
413     for (; $$op; $op = $op->next) {
414     last if $opsseen{$$op}++;
415     push @ops, $op;
416 root 1.11
417 root 1.1 my $name = $op->name;
418 root 1.11 my $class = B::class $op;
419    
420     if ($class eq "LOGOP") {
421     unshift @todo, $op->other; # unshift vs. push saves jumps
422 root 1.18
423     # regcomp/o patches ops at runtime, lets expect that
424     $op_regcomp{${$op->first}} = $op->next
425     if $name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP;
426    
427 root 1.11 } elsif ($class eq "PMOP") {
428     unshift @todo, $op->pmreplstart if ${$op->pmreplstart};
429 root 1.18
430 root 1.11 } elsif ($class eq "LOOP") {
431 root 1.18 push @op_loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
432     push @todo, $op->nextop, $op->lastop->next, $op->redoop->next;
433 root 1.1 }
434     }
435     }
436    
437 root 1.4 local $source = <<EOF;
438     OP *%%%FUNC%%% (pTHX)
439     {
440     register OP *nextop = (OP *)${$ops[0]}L;
441     EOF
442 root 1.2
443 root 1.8 while (@ops) {
444     $op = shift @ops;
445     $op_name = $op->name;
446 root 1.2
447 root 1.23 my $class = B::class $op;
448    
449 root 1.8 $source .= "op_$$op: /* $op_name */\n";
450     #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
451 root 1.4 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
452    
453 root 1.11 $source .= " PERL_ASYNC_CHECK ();\n"
454 root 1.20 unless exists $f_noasync{$op_name};
455 root 1.2
456 root 1.8 if (my $can = __PACKAGE__->can ("op_$op_name")) {
457 root 1.11 # handcrafted replacement
458 root 1.2 $can->($op);
459 root 1.11
460 root 1.20 } elsif (exists $f_unsafe{$op_name}) {
461 root 1.11 # unsafe, return to interpreter
462     assert "nextop == (OP *)$$op";
463 root 1.9 $source .= " return nextop;\n";
464 root 1.11
465 root 1.23 } elsif ("LOGOP" eq $class) {
466     # logical operation with optional branch
467 root 1.11 out_callop;
468     out_cond_jump $op->other;
469     out_jump_next;
470    
471 root 1.23 } elsif ("PMOP" eq $class) {
472 root 1.11 # regex-thingy
473     out_callop;
474 root 1.23 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
475 root 1.11 out_jump_next;
476    
477 root 1.2 } else {
478 root 1.11 # normal operator, linear execution
479 root 1.8 out_linear;
480 root 1.2 }
481 root 1.1 }
482 root 1.2
483 root 1.11 $op_name = "func exit"; assert (0);
484    
485     $source .= <<EOF;
486     op_0:
487     return 0;
488     }
489     EOF
490 root 1.4 #warn $source;
491 root 1.2
492 root 1.4 $source
493     }
494    
495 root 1.19 my $uid = "aaaaaaa0";
496    
497 root 1.4 sub source2ptr {
498 root 1.19 my (@source) = @_;
499 root 1.4
500 root 1.19 my $stem = "/tmp/Faster-$$-" . $uid++;
501 root 1.4
502 root 1.19 open FILE, ">:raw", "$stem.c";
503     print FILE <<EOF;
504 root 1.11 #define PERL_NO_GET_CONTEXT
505    
506     #include <assert.h>
507    
508     #include "EXTERN.h"
509     #include "perl.h"
510     #include "XSUB.h"
511    
512     #define RUNOPS_TILL(op) \\
513 root 1.19 while (nextop != (op)) \\
514     { \\
515     PERL_ASYNC_CHECK (); \\
516     PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
517     }
518 root 1.11
519     EOF
520 root 1.19 for (@source) {
521     my $func = $uid++;
522     $_ =~ s/%%%FUNC%%%/$func/g;
523     print FILE $_;
524     $_ = $func;
525 root 1.4 }
526    
527 root 1.19 close FILE;
528     system "$COMPILE -o $stem$_o $stem.c";
529     #d#unlink "$stem.c";
530     system "$LINK -o $stem$_so $stem$_o $LIBS";
531     unlink "$stem$_o";
532    
533 root 1.4 my $so = DynaLoader::dl_load_file "$stem$_so"
534     or die "$stem$_so: $!";
535    
536 root 1.19 #unlink "$stem$_so";
537    
538     map +(DynaLoader::dl_find_symbol $so, $_), @source
539 root 1.4 }
540    
541 root 1.19 my %ignore;
542    
543 root 1.4 sub entersub {
544     my ($cv) = @_;
545    
546 root 1.19 my $pkg = $cv->STASH->NAME;
547    
548     return if $ignore{$pkg};
549    
550 root 1.21 warn "compiling ", $cv->STASH->NAME, "\n"
551     if $verbose;
552 root 1.11
553 root 1.4 eval {
554 root 1.19 my @cv;
555     my @cv_source;
556 root 1.4
557 root 1.19 # always compile the whole stash
558     my %stash = $cv->STASH->ARRAY;
559     while (my ($k, $v) = each %stash) {
560     $v->isa (B::GV::)
561     or next;
562    
563     my $cv = $v->CV;
564    
565     if ($cv->isa (B::CV::)
566     && ${$cv->START}
567     && $cv->START->name ne "null") {
568     push @cv, $cv;
569     push @cv_source, cv2c $cv;
570     }
571     }
572    
573     my @ptr = source2ptr @cv_source;
574 root 1.4
575 root 1.19 for (0 .. $#cv) {
576     patch_cv $cv[$_], $ptr[$_];
577     }
578 root 1.4 };
579    
580 root 1.19 if ($@) {
581     $ignore{$pkg}++;
582     warn $@;
583     }
584 root 1.1 }
585    
586     hook_entersub;
587    
588     1;
589    
590     =back
591    
592 root 1.21 =head1 ENVIRONMENT VARIABLES
593    
594     The following environment variables influence the behaviour of Faster:
595    
596     =over 4
597    
598     =item FASTER_VERBOSE
599    
600     Faster will output more informational messages when set to values higher
601     than C<0>. Currently, C<1> outputs which packages are being compiled.
602    
603     =item FASTER_DEBUG
604    
605     Add debugging code when set to values higher than C<0>. Currently, this
606     adds 1-3 C<assert>'s per perl op, to ensure that opcode order and C
607     execution order are compatible.
608    
609     =item FASTER_CACHE
610    
611     NOT YET IMPLEMENTED
612    
613     Set a persistent cache directory that caches compiled code
614     fragments. Normally, code compiled by Faster will be deleted immediately,
615     and every restart will recompile everything. Setting this variable to a
616     directory makes Faster cache the generated files for re-use.
617    
618     This directory will always grow in contents, so you might need to erase it
619     from time to time.
620    
621     =back
622    
623 root 1.11 =head1 BUGS/LIMITATIONS
624    
625     Perl will check much less often for asynchronous signals in
626     Faster-compiled code. It tries to check on every function call, loop
627     iteration and every I/O operator, though.
628    
629     The following things will disable Faster. If you manage to enable them at
630 root 1.19 runtime, bad things will happen. Enabling them at startup will be fine,
631     though.
632 root 1.11
633     enabled tainting
634     enabled debugging
635    
636 root 1.19 Thread-enabled builds of perl will dramatically reduce Faster's
637     performance, but you don't care about speed if you enable threads anyway.
638 root 1.11
639 root 1.19 These constructs will force the use of the interpreter for the currently
640     executed function as soon as they are being encountered during execution.
641 root 1.11
642     goto
643     next, redo (but not well-behaved last's)
644     eval
645     require
646     any use of formats
647 root 1.19 .., ... (flipflop operators)
648 root 1.2
649 root 1.1 =head1 AUTHOR
650    
651     Marc Lehmann <schmorp@schmorp.de>
652     http://home.schmorp.de/
653    
654     =cut
655