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