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

Comparing Faster/Faster.pm (file contents):
Revision 1.17 by root, Fri Mar 10 18:58:35 2006 UTC vs.
Revision 1.23 by root, Fri Mar 10 22:45:18 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
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 lots 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.
10 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;
18use Config; 41use Config;
19use B (); 42use B ();
20use Digest::MD5 (); 43#use Digest::MD5 ();
21use DynaLoader (); 44use DynaLoader ();
45use File::Temp ();
22 46
23BEGIN { 47BEGIN {
24 our $VERSION = '0.01'; 48 our $VERSION = '0.01';
25 49
26 require XSLoader; 50 require XSLoader;
… …
35 59
36# we don't need no steenking PIC on x86 60# we don't need no steenking PIC on x86
37$COMPILE =~ s/-f(?:PIC|pic)//g 61$COMPILE =~ s/-f(?:PIC|pic)//g
38 if $Config{archname} =~ /^(i[3456]86)-/; 62 if $Config{archname} =~ /^(i[3456]86)-/;
39 63
40my $opt_assert = 0; 64my $opt_assert = $ENV{FASTER_DEBUG};
65my $verbose = $ENV{FASTER_VERBOSE}+0;
41 66
42our $source; 67our $source;
43 68
44my @ops; 69our @ops;
45my $op; 70our $op;
46my $op_name; 71our $op_name;
47my @loop; 72our @op_loop;
73our %op_regcomp;
48 74
49my %flag; 75my %f_unsafe = map +($_ => undef), qw(
76 leavesub leavesublv return
77 goto last redo next
78 eval flip leaveeval entertry
79 formline grepstart mapstart
80 substcont entereval require
81);
50 82
51# complex flag steting is no longer required, rewrite this ugly code
52for (split /\n/, <<EOF) {
53 leavesub unsafe
54 leavesublv unsafe
55 return unsafe
56 flip unsafe
57 goto unsafe
58 last unsafe
59 redo unsafe
60 next unsafe
61 eval unsafe
62 leaveeval unsafe
63 entertry unsafe
64 formline unsafe
65 grepstart unsafe
66 mapstart unsafe
67 substcont unsafe
68 entereval unsafe noasync todo
69 require unsafe
70
71 mapstart noasync
72 grepstart noasync
73 match noasync
74
75 last noasync
76 next noasync
77 redo noasync
78 seq noasync
79 pushmark noasync extend=0 83# pushmark extend=0
80 padsv noasync extend=1 84# padsv extend=1
81 padav noasync extend=1 85# padav extend=1
82 padhv noasync extend=1 86# padhv extend=1
83 padany noasync extend=1 87# padany extend=1
84 entersub noasync 88# const extend=1
85 aassign noasync 89
86 sassign noasync 90my %f_noasync = map +($_ => undef), qw(
87 rv2av noasync 91 mapstart grepstart match entereval
88 rv2cv noasync 92 enteriter entersub leaveloop
89 rv2gv noasync 93
90 rv2hv noasync 94 pushmark nextstate
91 refgen noasync 95
92 nextstate noasync 96 const stub unstack
93 gv noasync 97 last next redo seq
94 gvsv noasync 98 padsv padav padhv padany
95 add noasync 99 aassign sassign orassign
96 subtract noasync 100 rv2av rv2cv rv2gv rv2hv refgen
97 multiply noasync 101 gv gvsv
98 divide noasync 102 add subtract multiply divide
99 complement noasync 103 complement cond_expr and or not
100 cond_expr noasync 104 defined
101 and noasync
102 or noasync
103 not noasync
104 defined noasync
105 method_named noasync 105 method_named
106 preinc noasync 106 preinc postinc predec postdec
107 postinc noasync 107 aelem aelemfast helem delete exists
108 predec noasync 108 pushre subst list join split concat
109 postdec noasync 109 length substr stringify ord
110 stub noasync 110 push pop shift unshift
111 unstack noasync 111 eq ne gt lt ge le
112 leaveloop noasync 112 regcomp regcreset regcmaybe
113 aelem noasync 113);
114 aelemfast noasync
115 helem noasync
116 pushre noasync
117 subst noasync
118 const noasync extend=1
119 list noasync
120 join noasync
121 split noasync
122 concat noasync
123 push noasync
124 pop noasync
125 shift noasync
126 unshift noasync
127 length noasync
128 substr noasync
129 stringify noasync
130 eq noasync
131 ne noasync
132 gt noasync
133 lt noasync
134 ge noasync
135 le noasync
136 enteriter noasync
137 ord noasync
138
139 iter async
140EOF
141 my (undef, $op, @flags) = split /\s+/;
142
143 undef $flag{$_}{$op}
144 for ("known", @flags);
145}
146 114
147my %callop = ( 115my %callop = (
148 entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)", 116 entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)",
149 mapstart => "Perl_pp_grepstart (aTHX)", 117 mapstart => "Perl_pp_grepstart (aTHX)",
150); 118);
… …
161sub out_callop { 129sub out_callop {
162 assert "nextop == (OP *)$$op"; 130 assert "nextop == (OP *)$$op";
163 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n"; 131 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
164} 132}
165 133
134sub out_cond_jump {
135 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
136}
137
166sub out_jump_next { 138sub out_jump_next {
139 out_cond_jump $op_regcomp{$$op}
140 if $op_regcomp{$$op};
141
167 assert "nextop == (OP *)${$op->next}"; 142 assert "nextop == (OP *)${$op->next}";
168 $source .= " goto op_${$op->next};\n"; 143 $source .= " goto op_${$op->next};\n";
169} 144}
170 145
171sub out_next { 146sub out_next {
… …
175} 150}
176 151
177sub out_linear { 152sub out_linear {
178 out_callop; 153 out_callop;
179 out_jump_next; 154 out_jump_next;
180}
181
182sub out_cond_jump {
183 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
184} 155}
185 156
186sub op_entersub { 157sub op_entersub {
187 out_callop; 158 out_callop;
188 $source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n"; 159 $source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n";
… …
317 out_next; 288 out_next;
318} 289}
319 290
320sub op_padsv { 291sub op_padsv {
321 my $flags = $op->flags; 292 my $flags = $op->flags;
322 my $target = $op->targ; 293 my $targ = $op->targ;
323 294
324 $source .= <<EOF; 295 $source .= <<EOF;
325 { 296 {
326 dSP; 297 dSP;
327 XPUSHs (PAD_SV ((PADOFFSET)$target)); 298 XPUSHs (PAD_SV ((PADOFFSET)$targ));
328 PUTBACK; 299 PUTBACK;
329EOF 300EOF
330 if ($op->flags & B::OPf_MOD) { 301 if ($op->flags & B::OPf_MOD) {
331 if ($op->private & B::OPpLVAL_INTRO) { 302 if ($op->private & B::OPpLVAL_INTRO) {
332 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n"; 303 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$targ));\n";
333 } elsif ($op->private & B::OPpDEREF) { 304 } elsif ($op->private & B::OPpDEREF) {
334 my $deref = $op->private & B::OPpDEREF; 305 my $deref = $op->private & B::OPpDEREF;
335 $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n"; 306 $source .= " Perl_vivify_ref (aTHX_ PAD_SVl ((PADOFFSET)$targ), $deref);\n";
336 } 307 }
337 } 308 }
338 $source .= <<EOF; 309 $source .= <<EOF;
339 } 310 }
340EOF 311EOF
… …
409 my ($idx) = @_; 380 my ($idx) = @_;
410 381
411 out_callop; 382 out_callop;
412 383
413 out_cond_jump $_->[$idx] 384 out_cond_jump $_->[$idx]
414 for reverse @loop; 385 for reverse @op_loop;
415 386
416 $source .= " return nextop;\n"; 387 $source .= " return nextop;\n";
417} 388}
418 389
419sub xop_next { 390sub xop_next {
… …
429} 400}
430 401
431sub cv2c { 402sub cv2c {
432 my ($cv) = @_; 403 my ($cv) = @_;
433 404
434 @loop = (); 405 local @ops;
406 local @op_loop;
407 local %op_regcomp;
435 408
436 my %opsseen; 409 my %opsseen;
437 my @todo = $cv->START; 410 my @todo = $cv->START;
438 411
439 while (my $op = shift @todo) { 412 while (my $op = shift @todo) {
… …
444 my $name = $op->name; 417 my $name = $op->name;
445 my $class = B::class $op; 418 my $class = B::class $op;
446 419
447 if ($class eq "LOGOP") { 420 if ($class eq "LOGOP") {
448 unshift @todo, $op->other; # unshift vs. push saves jumps 421 unshift @todo, $op->other; # unshift vs. push saves jumps
422
423 # regcomp/o patches ops at runtime, lets expect that
424 $op_regcomp{${$op->first}} = $op->next
425 if $name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP;
426
449 } elsif ($class eq "PMOP") { 427 } elsif ($class eq "PMOP") {
450 unshift @todo, $op->pmreplstart if ${$op->pmreplstart}; 428 unshift @todo, $op->pmreplstart if ${$op->pmreplstart};
429
451 } elsif ($class eq "LOOP") { 430 } elsif ($class eq "LOOP") {
452 push @loop, [$op->nextop, $op->lastop->next, $op->redoop->next]; 431 push @op_loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
432 push @todo, $op->nextop, $op->lastop->next, $op->redoop->next;
453 } 433 }
454 } 434 }
455 } 435 }
456 436
457 local $source = <<EOF; 437 local $source = <<EOF;
… …
462 442
463 while (@ops) { 443 while (@ops) {
464 $op = shift @ops; 444 $op = shift @ops;
465 $op_name = $op->name; 445 $op_name = $op->name;
466 446
447 my $class = B::class $op;
448
467 $source .= "op_$$op: /* $op_name */\n"; 449 $source .= "op_$$op: /* $op_name */\n";
468 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d# 450 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
469 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d# 451 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
470 452
471 $source .= " PERL_ASYNC_CHECK ();\n" 453 $source .= " PERL_ASYNC_CHECK ();\n"
472 unless exists $flag{noasync}{$op_name}; 454 unless exists $f_noasync{$op_name};
473 455
474 if (my $can = __PACKAGE__->can ("op_$op_name")) { 456 if (my $can = __PACKAGE__->can ("op_$op_name")) {
475 # handcrafted replacement 457 # handcrafted replacement
476 $can->($op); 458 $can->($op);
477 459
478 } elsif (exists $flag{unsafe}{$op_name}) { 460 } elsif (exists $f_unsafe{$op_name}) {
479 # unsafe, return to interpreter 461 # unsafe, return to interpreter
480 assert "nextop == (OP *)$$op"; 462 assert "nextop == (OP *)$$op";
481 $source .= " return nextop;\n"; 463 $source .= " return nextop;\n";
482 464
483 } elsif ("LOGOP" eq B::class $op) { 465 } elsif ("LOGOP" eq $class) {
484 # logical operation with optionaรถ branch 466 # logical operation with optional branch
485 out_callop; 467 out_callop;
486 out_cond_jump $op->other; 468 out_cond_jump $op->other;
487 out_jump_next; 469 out_jump_next;
488 470
489 } elsif ("PMOP" eq B::class $op) { 471 } elsif ("PMOP" eq $class) {
490 # regex-thingy 472 # regex-thingy
491 out_callop; 473 out_callop;
492 out_cond_jump $op->pmreplroot if ${$op->pmreplroot}; 474 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
493 out_jump_next; 475 out_jump_next;
494 476
495 } else { 477 } else {
496 # normal operator, linear execution 478 # normal operator, linear execution
497 out_linear; 479 out_linear;
… …
508 #warn $source; 490 #warn $source;
509 491
510 $source 492 $source
511} 493}
512 494
495my $uid = "aaaaaaa0";
496
513sub source2ptr { 497sub source2ptr {
514 my ($source) = @_; 498 my (@source) = @_;
515 499
516 my $md5 = Digest::MD5::md5_hex $source; 500 my $stem = "/tmp/Faster-$$-" . $uid++;
517 $source =~ s/%%%FUNC%%%/Faster_$md5/;
518 501
519 my $stem = "/tmp/$md5";
520
521 unless (-e "$stem$_so") {
522 open FILE, ">:raw", "$stem.c"; 502 open FILE, ">:raw", "$stem.c";
523 print FILE <<EOF; 503 print FILE <<EOF;
524#define PERL_NO_GET_CONTEXT 504#define PERL_NO_GET_CONTEXT
525 505
526#include <assert.h> 506#include <assert.h>
527 507
528#include "EXTERN.h" 508#include "EXTERN.h"
529#include "perl.h" 509#include "perl.h"
530#include "XSUB.h" 510#include "XSUB.h"
531 511
532#define RUNOPS_TILL(op) \\ 512#define RUNOPS_TILL(op) \\
533 while (nextop != (op)) \\ 513while (nextop != (op)) \\
534 { \\ 514 { \\
535 PERL_ASYNC_CHECK (); \\ 515 PERL_ASYNC_CHECK (); \\
536 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\ 516 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
537 } 517 }
538 518
539EOF 519EOF
520 for (@source) {
521 my $func = $uid++;
522 $_ =~ s/%%%FUNC%%%/$func/g;
540 print FILE $source; 523 print FILE $_;
541 close FILE; 524 $_ = $func;
542 system "$COMPILE -o $stem$_o $stem.c";
543 system "$LINK -o $stem$_so $stem$_o $LIBS";
544 } 525 }
545 526
546# warn $source; 527 close FILE;
528 system "$COMPILE -o $stem$_o $stem.c";
529 #d#unlink "$stem.c";
530 system "$LINK -o $stem$_so $stem$_o $LIBS";
531 unlink "$stem$_o";
532
547 my $so = DynaLoader::dl_load_file "$stem$_so" 533 my $so = DynaLoader::dl_load_file "$stem$_so"
548 or die "$stem$_so: $!"; 534 or die "$stem$_so: $!";
549 535
550 DynaLoader::dl_find_symbol $so, "Faster_$md5" 536 #unlink "$stem$_so";
551 or die "Faster_$md5: $!" 537
538 map +(DynaLoader::dl_find_symbol $so, $_), @source
552} 539}
540
541my %ignore;
553 542
554sub entersub { 543sub entersub {
555 my ($cv) = @_; 544 my ($cv) = @_;
556 545
557 # always compile the whole stash 546 my $pkg = $cv->STASH->NAME;
558# my @stash = $cv->STASH->ARRAY; 547
559# warn join ":", @stash; 548 return if $ignore{$pkg};
560# exit; 549
550 warn "compiling ", $cv->STASH->NAME, "\n"
551 if $verbose;
561 552
562 eval { 553 eval {
563 my $source = cv2c $cv; 554 my @cv;
555 my @cv_source;
564 556
557 # always compile the whole stash
558 my %stash = $cv->STASH->ARRAY;
559 while (my ($k, $v) = each %stash) {
560 $v->isa (B::GV::)
561 or next;
562
563 my $cv = $v->CV;
564
565 if ($cv->isa (B::CV::)
566 && ${$cv->START}
567 && $cv->START->name ne "null") {
568 push @cv, $cv;
569 push @cv_source, cv2c $cv;
570 }
571 }
572
565 my $ptr = source2ptr $source; 573 my @ptr = source2ptr @cv_source;
566 574
575 for (0 .. $#cv) {
567 patch_cv $cv, $ptr; 576 patch_cv $cv[$_], $ptr[$_];
577 }
568 }; 578 };
569 579
570 warn $@ if $@; 580 if ($@) {
581 $ignore{$pkg}++;
582 warn $@;
583 }
571} 584}
572 585
573hook_entersub; 586hook_entersub;
574 587
5751; 5881;
589
590=back
591
592=head1 ENVIRONMENT VARIABLES
593
594The following environment variables influence the behaviour of Faster:
595
596=over 4
597
598=item FASTER_VERBOSE
599
600Faster will output more informational messages when set to values higher
601than C<0>. Currently, C<1> outputs which packages are being compiled.
602
603=item FASTER_DEBUG
604
605Add debugging code when set to values higher than C<0>. Currently, this
606adds 1-3 C<assert>'s per perl op, to ensure that opcode order and C
607execution order are compatible.
608
609=item FASTER_CACHE
610
611NOT YET IMPLEMENTED
612
613Set a persistent cache directory that caches compiled code
614fragments. Normally, code compiled by Faster will be deleted immediately,
615and every restart will recompile everything. Setting this variable to a
616directory makes Faster cache the generated files for re-use.
617
618This directory will always grow in contents, so you might need to erase it
619from time to time.
576 620
577=back 621=back
578 622
579=head1 BUGS/LIMITATIONS 623=head1 BUGS/LIMITATIONS
580 624
581Perl will check much less often for asynchronous signals in 625Perl will check much less often for asynchronous signals in
582Faster-compiled code. It tries to check on every function call, loop 626Faster-compiled code. It tries to check on every function call, loop
583iteration and every I/O operator, though. 627iteration and every I/O operator, though.
584 628
585The following things will disable Faster. If you manage to enable them at 629The following things will disable Faster. If you manage to enable them at
586runtime, bad things will happen. 630runtime, bad things will happen. Enabling them at startup will be fine,
631though.
587 632
588 enabled tainting 633 enabled tainting
589 enabled debugging 634 enabled debugging
590 635
591This will dramatically reduce Faster's performance: 636Thread-enabled builds of perl will dramatically reduce Faster's
637performance, but you don't care about speed if you enable threads anyway.
592 638
593 threads (but you don't care about speed if you use threads anyway)
594
595These constructs will force the use of the interpreter as soon as they are 639These constructs will force the use of the interpreter for the currently
596being executed, for the rest of the currently executed: 640executed function as soon as they are being encountered during execution.
597 641
598 .., ... (flipflop operators)
599 goto 642 goto
600 next, redo (but not well-behaved last's) 643 next, redo (but not well-behaved last's)
601 eval 644 eval
602 require 645 require
603 any use of formats 646 any use of formats
647 .., ... (flipflop operators)
604 648
605=head1 AUTHOR 649=head1 AUTHOR
606 650
607 Marc Lehmann <schmorp@schmorp.de> 651 Marc Lehmann <schmorp@schmorp.de>
608 http://home.schmorp.de/ 652 http://home.schmorp.de/

Diff Legend

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