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