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