ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Faster/Faster.pm
(Generate patch)

Comparing Faster/Faster.pm (file contents):
Revision 1.1 by root, Thu Mar 9 04:41:21 2006 UTC vs.
Revision 1.18 by root, Fri Mar 10 19:52:07 2006 UTC

… …
4 4
5=head1 SYNOPSIS 5=head1 SYNOPSIS
6 6
7 use Faster; 7 use Faster;
8 8
9 perl -MFaster ...
10
9=head1 DESCRIPTION 11=head1 DESCRIPTION
10 12
13This module implements a very simple-minded JIT. It works by more or less
14translating every function it sees into a C program, compiling it and then
15replacing the function by the compiled code.
16
17As a result, startup times are immense, as every function might lead to a
18full-blown compilation.
19
20The speed improvements are also not great, you can expect 20% or so on
21average, for code that runs very often.
22
23Faster is in the early stages of development. Due to its design its
24relatively safe to use (it will either work or simply slowdown the program
25immensely, but rarely cause bugs).
26
27Usage is very easy, just C<use Faster> and every function called from then
28on will be compiled.
29
30Right now, Faster will leave ltos of F<*.c>, F<*.o> and F<*.so> files in
31F</tmp>, and it will even create those temporary files in an insecure
32manner, so watch out.
33
11=over 4 34=over 4
12 35
13=cut 36=cut
14 37
15package Faster; 38package Faster;
16 39
17use strict; 40use strict;
41use Config;
42use B ();
43use Digest::MD5 ();
44use DynaLoader ();
18 45
19BEGIN { 46BEGIN {
20 our $VERSION = '0.01'; 47 our $VERSION = '0.01';
21 48
22 require XSLoader; 49 require XSLoader;
23 XSLoader::load __PACKAGE__, $VERSION; 50 XSLoader::load __PACKAGE__, $VERSION;
24} 51}
25 52
26use B (); 53my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}";
54my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
55my $LIBS = "$Config{libs}";
56my $_o = $Config{_o};
57my $_so = ".so";
58
59# we don't need no steenking PIC on x86
60$COMPILE =~ s/-f(?:PIC|pic)//g
61 if $Config{archname} =~ /^(i[3456]86)-/;
62
63my $opt_assert = 1;
27 64
28our $source; 65our $source;
29our $label_next;
30our $label_last;
31our $label_redo;
32 66
67our @ops;
68our $op;
69our $op_name;
70our @op_loop;
71our %op_regcomp;
72
73my %flag;
74
75# complex flag steting is no longer required, rewrite this ugly code
76for (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 mapstart unsafe
91 substcont unsafe
92 entereval unsafe noasync todo
93 require unsafe
94
95 mapstart noasync
96 grepstart noasync
97 match noasync
98
99 last noasync
100 next noasync
101 redo noasync
102 seq noasync
103 pushmark noasync extend=0
104 padsv noasync extend=1
105 padav noasync extend=1
106 padhv noasync extend=1
107 padany noasync extend=1
108 entersub noasync
109 aassign noasync
110 sassign noasync
111 rv2av noasync
112 rv2cv noasync
113 rv2gv noasync
114 rv2hv noasync
115 refgen noasync
116 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 defined noasync
129 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 aelem noasync
138 aelemfast noasync
139 helem noasync
140 pushre noasync
141 subst noasync
142 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 ord noasync
162 orassign noasync
163 regcomp noasync
164 regcreset noasync
165 regcmaybe noasync
166
167 iter async
168EOF
169 my (undef, $op, @flags) = split /\s+/;
170
171 undef $flag{$_}{$op}
172 for ("known", @flags);
173}
174
175my %callop = (
176 entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)",
177 mapstart => "Perl_pp_grepstart (aTHX)",
178);
179
180sub callop {
181 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
182}
183
184sub assert {
185 return unless $opt_assert;
186 $source .= " assert ((\"$op_name\", ($_[0])));\n";
187}
188
189sub out_callop {
190 assert "nextop == (OP *)$$op";
191 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
192}
193
194sub out_cond_jump {
195 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
196}
197
198sub out_jump_next {
199 out_cond_jump $op_regcomp{$$op}
200 if $op_regcomp{$$op};
201
202 assert "nextop == (OP *)${$op->next}";
203 $source .= " goto op_${$op->next};\n";
204}
205
206sub out_next {
207 $source .= " nextop = (OP *)${$op->next}L;\n";
208
209 out_jump_next;
210}
211
212sub out_linear {
213 out_callop;
214 out_jump_next;
215}
216
33sub entersub { 217sub op_entersub {
218 out_callop;
219 $source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n";
220 out_jump_next;
221}
222
223*op_require = \&op_entersub;
224
225sub op_nextstate {
226 $source .= " PL_curcop = (COP *)nextop;\n";
227 $source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
228 $source .= " FREETMPS;\n";
229
230 out_next;
231}
232
233sub op_pushmark {
234 $source .= " PUSHMARK (PL_stack_sp);\n";
235
236 out_next;
237}
238
239if ($Config{useithreads} ne "define") {
240 # 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
280 *op_gvsv = sub {
281 $source .= " {\n";
282 $source .= " dSP;\n";
283 $source .= " EXTEND (SP, 1);\n";
284
285 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}
297
298# does kill Crossfire/res2pm
299sub 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 }
310EOF
311
312 out_next;
313}
314
315sub op_and {
316 $source .= <<EOF;
317 {
318 dSP;
319
320 if (SvTRUE (TOPs))
321 {
322 --SP;
323 PUTBACK;
324 nextop = (OP *)${$op->other}L;
325 goto op_${$op->other};
326 }
327 }
328EOF
329
330 out_next;
331}
332
333sub 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 }
346EOF
347
348 out_next;
349}
350
351sub 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;
360EOF
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 }
371EOF
372
373 out_next;
374}
375
376# pattern const+ (or general push1)
377# pattern pushmark return(?)
378# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
379
380# pattern const method_named
381sub op_method_named {
382 $source .= <<EOF;
383 {
384 static HV *last_stash;
385 static SV *last_cv;
386 static U32 last_sub_generation;
387
388 SV *obj = *(PL_stack_base + TOPMARK + 1);
389
390 if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
391 {
392 dSP;
393 HV *stash = SvSTASH (SvRV (obj));
394
395 /* simple "polymorphic" inline cache */
396 if (stash == last_stash
397 && PL_sub_generation == last_sub_generation)
398 {
399 XPUSHs (last_cv);
400 PUTBACK;
401 }
402 else
403 {
404 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
405
406 SPAGAIN;
407 last_sub_generation = PL_sub_generation;
408 last_stash = stash;
409 last_cv = TOPs;
410 }
411 }
412 else
413 {
414 /* error case usually */
415 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
416 }
417 }
418EOF
419
420 out_next;
421}
422
423sub op_grepstart {
424 out_callop;
425 $op = $op->next;
426 out_cond_jump $op->other;
427 out_jump_next;
428}
429
430*op_mapstart = \&op_grepstart;
431
432sub 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
439sub out_break_op {
440 my ($idx) = @_;
441
442 out_callop;
443
444 out_cond_jump $_->[$idx]
445 for reverse @op_loop;
446
447 $source .= " return nextop;\n";
448}
449
450sub xop_next {
451 out_break_op 0;
452}
453
454sub op_last {
455 out_break_op 1;
456}
457
458sub xop_redo {
459 out_break_op 2;
460}
461
462sub cv2c {
34 my ($cv) = @_; 463 my ($cv) = @_;
35 464
465 local @ops;
466 local @op_loop;
467 local %op_regcomp;
468
36 my %opsseen; 469 my %opsseen;
37 my @ops;
38 my @todo = $cv->START; 470 my @todo = $cv->START;
39 471
40 while (my $op = shift @todo) { 472 while (my $op = shift @todo) {
41 for (; $$op; $op = $op->next) { 473 for (; $$op; $op = $op->next) {
42 last if $opsseen{$$op}++; 474 last if $opsseen{$$op}++;
43 push @ops, $op; 475 push @ops, $op;
476
44 my $name = $op->name; 477 my $name = $op->name;
478 my $class = B::class $op;
479
45 if (B::class($op) eq "LOGOP") { 480 if ($class eq "LOGOP") {
46 push @todo, $op->other; 481 unshift @todo, $op->other; # unshift vs. push saves jumps
47 } elsif ($name eq "subst" and ${ $op->pmreplstart }) { 482
48 push @todo, $op->pmreplstart; 483 # regcomp/o patches ops at runtime, lets expect that
49 } elsif ($name =~ /^enter(loop|iter)$/) { 484 $op_regcomp{${$op->first}} = $op->next
50# if ($] > 5.009) { 485 if $name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP;
51# $labels{${$op->nextop}} = "NEXT"; 486
52# $labels{${$op->lastop}} = "LAST"; 487 } elsif ($class eq "PMOP") {
53# $labels{${$op->redoop}} = "REDO"; 488 unshift @todo, $op->pmreplstart if ${$op->pmreplstart};
54# } else { 489
55# $labels{$op->nextop->seq} = "NEXT"; 490 } elsif ($class eq "LOOP") {
56# $labels{$op->lastop->seq} = "LAST"; 491 push @op_loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
57# $labels{$op->redoop->seq} = "REDO"; 492 push @todo, $op->nextop, $op->lastop->next, $op->redoop->next;
58# }
59 } 493 }
60 } 494 }
61 } 495 }
62 496
497 local $source = <<EOF;
498OP *%%%FUNC%%% (pTHX)
499{
500 register OP *nextop = (OP *)${$ops[0]}L;
501EOF
502
63 for (@ops) { 503 while (@ops) {
64 printf "%s\n", $_->name; 504 $op = shift @ops;
505 $op_name = $op->name;
506
507 $source .= "op_$$op: /* $op_name */\n";
508 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
509 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
510
511 $source .= " PERL_ASYNC_CHECK ();\n"
512 unless exists $flag{noasync}{$op_name};
513
514 if (my $can = __PACKAGE__->can ("op_$op_name")) {
515 # handcrafted replacement
516 $can->($op);
517
518 } elsif (exists $flag{unsafe}{$op_name}) {
519 # unsafe, return to interpreter
520 assert "nextop == (OP *)$$op";
521 $source .= " return nextop;\n";
522
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 } else {
536 # normal operator, linear execution
537 out_linear;
538 }
65 } 539 }
66# walklines(\@lines, 0); 540
541 $op_name = "func exit"; assert (0);
542
543 $source .= <<EOF;
544op_0:
545 return 0;
546}
547EOF
548 #warn $source;
549
550 $source
551}
552
553sub 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 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
579EOF
580 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
594sub entersub {
595 my ($cv) = @_;
596
597 # always compile the whole stash
598# my @stash = $cv->STASH->ARRAY;
599# warn join ":", @stash;
600# exit;
601
602 eval {
603 my $source = cv2c $cv;
604
605 my $ptr = source2ptr $source;
606
607 patch_cv $cv, $ptr;
608 };
609
610 warn $@ if $@;
67} 611}
68 612
69hook_entersub; 613hook_entersub;
70 614
711; 6151;
72 616
73=back 617=back
618
619=head1 BUGS/LIMITATIONS
620
621Perl will check much less often for asynchronous signals in
622Faster-compiled code. It tries to check on every function call, loop
623iteration and every I/O operator, though.
624
625The following things will disable Faster. If you manage to enable them at
626runtime, bad things will happen.
627
628 enabled tainting
629 enabled debugging
630
631This will dramatically reduce Faster's performance:
632
633 threads (but you don't care about speed if you use threads anyway)
634
635These constructs will force the use of the interpreter as soon as they are
636being executed, for the rest of the currently executed:
637
638 .., ... (flipflop operators)
639 goto
640 next, redo (but not well-behaved last's)
641 eval
642 require
643 any use of formats
74 644
75=head1 AUTHOR 645=head1 AUTHOR
76 646
77 Marc Lehmann <schmorp@schmorp.de> 647 Marc Lehmann <schmorp@schmorp.de>
78 http://home.schmorp.de/ 648 http://home.schmorp.de/

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines