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