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

Comparing Faster/Faster.pm (file contents):
Revision 1.13 by root, Fri Mar 10 18:53:49 2006 UTC vs.
Revision 1.26 by root, Sat Mar 11 18:13:35 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 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.
33
11=over 4 34=over 4
12 35
13=cut 36=cut
14 37
15package Faster; 38package Faster;
39
40no warnings;
16 41
17use strict; 42use strict;
18use Config; 43use Config;
19use B (); 44use B ();
20use Digest::MD5 (); 45#use Digest::MD5 ();
21use DynaLoader (); 46use DynaLoader ();
47use File::Temp ();
22 48
23BEGIN { 49BEGIN {
24 our $VERSION = '0.01'; 50 our $VERSION = '0.01';
25 51
26 require XSLoader; 52 require XSLoader;
… …
35 61
36# we don't need no steenking PIC on x86 62# we don't need no steenking PIC on x86
37$COMPILE =~ s/-f(?:PIC|pic)//g 63$COMPILE =~ s/-f(?:PIC|pic)//g
38 if $Config{archname} =~ /^(i[3456]86)-/; 64 if $Config{archname} =~ /^(i[3456]86)-/;
39 65
40my $opt_assert = 1; 66my $opt_assert = $ENV{FASTER_DEBUG};
67my $verbose = $ENV{FASTER_VERBOSE}+0;
41 68
42our $source; 69our $source;
43 70
44my @ops; 71our @ops;
45my $op; 72our $insn;
73our $op;
46my $op_name; 74our $op_name;
47my @loop; 75our @op_loop;
76our %op_regcomp;
48 77
49my %flag; 78# ops that cause immediate return to the interpreter
79my %f_unsafe = map +($_ => undef), qw(
80 leavesub leavesublv return
81 goto last redo next
82 eval flip leaveeval entertry
83 formline grepstart mapstart
84 substcont entereval require
85);
50 86
51# complex flag steting is no longer required, rewrite this ugly code 87# ops with known stack extend behaviour
52for (split /\n/, <<EOF) { 88# the values given are maximum values
53 leavesub unsafe 89my %extend = (
54 leavesublv unsafe 90 pushmark => 0,
55 return unsafe 91 nextstate => 0, # might reduce the stack
56 flip unsafe 92 unstack => 0,
57 goto unsafe 93 enter => 0,
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 94
71 mapstart noasync 95 stringify => 0,
72 grepstart noasync 96 not => 0,
73 match noasync 97 and => 0,
98 or => 0,
99 gvsv => 0,
100 rv2gv => 0,
101 preinc => 0,
102 predec => 0,
103 postinc => 0,
104 postdec => 0,
105 aelem => 0,
106 helem => 0,
107 qr => 1, #???
108 pushre => 1,
109 gv => 1,
110 aelemfast => 1,
111 aelem => 0,
112 padsv => 1,
113 const => 1,
114 pop => 1,
115 shift => 1,
116 eq => -1,
117 ne => -1,
118 gt => -1,
119 lt => -1,
120 ge => -1,
121 lt => -1,
122 cond_expr => -1,
123 add => -1,
124 subtract => -1,
125 multiply => -1,
126 divide => -1,
127 aassign => 0,
128 sassign => -2,
129 method => 0,
130 method_named => 1,
131);
74 132
75 last noasync 133# ops that do not need an ASYNC_CHECK
76 next noasync 134my %f_noasync = map +($_ => undef), qw(
77 redo noasync 135 mapstart grepstart match entereval
78 seq noasync 136 enteriter entersub leaveloop
79 pushmark noasync extend=0
80 padsv noasync extend=1
81 padav noasync extend=1
82 padhv noasync extend=1
83 padany noasync extend=1
84 entersub noasync
85 aassign noasync
86 sassign noasync
87 rv2av noasync
88 rv2cv noasync
89 rv2gv noasync
90 rv2hv noasync
91 refgen noasync
92 nextstate noasync
93 gv noasync
94 gvsv noasync
95 add noasync
96 subtract noasync
97 multiply noasync
98 divide noasync
99 complement noasync
100 cond_expr noasync
101 and noasync
102 or noasync
103 not noasync
104 defined noasync
105 method_named noasync
106 preinc noasync
107 postinc noasync
108 predec noasync
109 postdec noasync
110 stub noasync
111 unstack noasync
112 leaveloop noasync
113 aelem noasync
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 137
139 iter async 138 pushmark nextstate
140EOF
141 my (undef, $op, @flags) = split /\s+/;
142 139
143 undef $flag{$_}{$op} 140 const stub unstack
144 for ("known", @flags); 141 last next redo seq
145} 142 padsv padav padhv padany
143 aassign sassign orassign
144 rv2av rv2cv rv2gv rv2hv refgen
145 gv gvsv
146 add subtract multiply divide
147 complement cond_expr and or not
148 defined
149 method method_named bless
150 preinc postinc predec postdec
151 aelem aelemfast helem delete exists
152 pushre subst list join split concat
153 length substr stringify ord
154 push pop shift unshift
155 eq ne gt lt ge le
156 regcomp regcreset regcmaybe
157);
146 158
147my %callop = ( 159my %callop = (
148 entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)", 160 entersub => "(PL_op->op_ppaddr) (aTHX)",
149 mapstart => "Perl_pp_grepstart (aTHX)", 161 mapstart => "Perl_pp_grepstart (aTHX)",
150); 162);
151 163
152sub callop { 164sub callop {
153 $callop{$op_name} || "Perl_pp_$op_name (aTHX)" 165 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
… …
161sub out_callop { 173sub out_callop {
162 assert "nextop == (OP *)$$op"; 174 assert "nextop == (OP *)$$op";
163 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n"; 175 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
164} 176}
165 177
178sub out_cond_jump {
179 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
180}
181
166sub out_jump_next { 182sub out_jump_next {
183 out_cond_jump $op_regcomp{$$op}
184 if $op_regcomp{$$op};
185
167 assert "nextop == (OP *)${$op->next}"; 186 assert "nextop == (OP *)${$op->next}";
168 $source .= " goto op_${$op->next};\n"; 187 $source .= " goto op_${$op->next};\n";
169} 188}
170 189
171sub out_next { 190sub out_next {
… …
175} 194}
176 195
177sub out_linear { 196sub out_linear {
178 out_callop; 197 out_callop;
179 out_jump_next; 198 out_jump_next;
180}
181
182sub out_cond_jump {
183 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
184} 199}
185 200
186sub op_entersub { 201sub op_entersub {
187 out_callop; 202 out_callop;
188 $source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n"; 203 $source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n";
… …
207 222
208if ($Config{useithreads} ne "define") { 223if ($Config{useithreads} ne "define") {
209 # disable optimisations on ithreads 224 # disable optimisations on ithreads
210 225
211 *op_const = sub { 226 *op_const = sub {
212 $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n"; 227 $source .= " { dSP; PUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
228
229 $ops[0]{follows_const}++ if @ops;#d#
213 230
214 out_next; 231 out_next;
215 }; 232 };
216 233
217 *op_gv = \&op_const; 234 *op_gv = \&op_const;
… …
237 if (!($op->flags & B::OPf_MOD)) { 254 if (!($op->flags & B::OPf_MOD)) {
238 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n"; 255 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
239 } 256 }
240 257
241 $source .= " dSP;\n"; 258 $source .= " dSP;\n";
242 $source .= " XPUSHs (sv);\n"; 259 $source .= " PUSHs (sv);\n";
243 $source .= " PUTBACK;\n"; 260 $source .= " PUTBACK;\n";
244 $source .= " }\n"; 261 $source .= " }\n";
245 262
246 out_next; 263 out_next;
247 }; 264 };
248 265
249 *op_gvsv = sub { 266 *op_gvsv = sub {
250 $source .= " {\n"; 267 $source .= " {\n";
251 $source .= " dSP;\n"; 268 $source .= " dSP;\n";
252 $source .= " EXTEND (SP, 1);\n";
253 269
254 if ($op->private & B::OPpLVAL_INTRO) { 270 if ($op->private & B::OPpLVAL_INTRO) {
255 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n"; 271 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
256 } else { 272 } else {
257 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n"; 273 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
… …
317 out_next; 333 out_next;
318} 334}
319 335
320sub op_padsv { 336sub op_padsv {
321 my $flags = $op->flags; 337 my $flags = $op->flags;
322 my $target = $op->targ; 338 my $padofs = "(PADOFFSET)" . $op->targ;
323 339
324 $source .= <<EOF; 340 $source .= <<EOF;
325 { 341 {
326 dSP; 342 dSP;
327 XPUSHs (PAD_SV ((PADOFFSET)$target)); 343 SV *sv = PAD_SVl ($padofs);
344EOF
345
346 if (($flags & B::OPf_MOD) && ($op->private & B::OPpLVAL_INTRO)) {
347 $source .= " SAVECLEARSV (PAD_SVl ($padofs));\n";
348 $ops[0]{follows_padsv_lval_intro}++ if @ops;#d#
349 }
350
351 $source .= <<EOF;
352 PUSHs (sv);
328 PUTBACK; 353 PUTBACK;
329EOF 354EOF
330 if ($op->flags & B::OPf_MOD) { 355
331 if ($op->private & B::OPpLVAL_INTRO) { 356 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
332 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n"; 357 $source .= " vivify_ref (sv, " . $op->private . " & OPpDEREF);\n";
333 } elsif ($op->private & B::OPpDEREF) {
334 my $deref = $op->private & B::OPpDEREF;
335 $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
336 }
337 } 358 }
359 $source .= " }\n";
360
361 out_next;
362}
363
364sub op_sassign {
365 $source .= <<EOF;
366 {
367 dSP;
368 dPOPTOPssrl;
369EOF
370 $source .= " SV *temp = left; left = right; right = temp;\n"
371 if $op->private & B::OPpASSIGN_BACKWARDS;
372
373 if ($insn->{follows_padsv_lval_intro} && !($op->private & B::OPpASSIGN_BACKWARDS)) {
374 # simple assignment - the target exists, but is basically undef
375 $source .= " SvSetSV (right, left);\n";
376 } else {
377 $source .= " SvSetMagicSV (right, left);\n";
378 }
379
338 $source .= <<EOF; 380 $source .= <<EOF;
381 SETs (right);
382 PUTBACK;
339 } 383 }
340EOF 384EOF
341 385
342 out_next; 386 out_next;
343} 387}
344 388
345# pattern const+ (or general push1) 389# pattern const+ (or general push1)
346# pattern pushmark return(?)
347# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 390# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
348 391
349# pattern const method_named
350sub op_method_named { 392sub op_method_named {
393 if ($insn->{follows_const}) {
351 $source .= <<EOF; 394 $source .= <<EOF;
395 {
396 dSP;
397 static SV *last_cv;
398 static U32 last_sub_generation;
399
400 /* simple "polymorphic" inline cache */
401 if (PL_sub_generation == last_sub_generation)
402 {
403 PUSHs (last_cv);
404 PUTBACK;
405 }
406 else
407 {
408 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
409
410 SPAGAIN;
411 last_sub_generation = PL_sub_generation;
412 last_cv = TOPs;
413 }
414 }
415EOF
416 } else {
417 $source .= <<EOF;
352 { 418 {
353 static HV *last_stash; 419 static HV *last_stash;
354 static SV *last_cv; 420 static SV *last_cv;
355 static U32 last_sub_generation; 421 static U32 last_sub_generation;
356 422
… …
363 429
364 /* simple "polymorphic" inline cache */ 430 /* simple "polymorphic" inline cache */
365 if (stash == last_stash 431 if (stash == last_stash
366 && PL_sub_generation == last_sub_generation) 432 && PL_sub_generation == last_sub_generation)
367 { 433 {
368 XPUSHs (last_cv); 434 PUSHs (last_cv);
369 PUTBACK; 435 PUTBACK;
370 } 436 }
371 else 437 else
372 { 438 {
373 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 439 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
… …
383 /* error case usually */ 449 /* error case usually */
384 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 450 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
385 } 451 }
386 } 452 }
387EOF 453EOF
454 }
388 455
389 out_next; 456 out_next;
390} 457}
391 458
392sub op_grepstart { 459sub op_grepstart {
393 out_callop; 460 out_callop;
461 $op = $op->next;
394 out_cond_jump $op->next->other; 462 out_cond_jump $op->other;
395 out_jump_next; 463 out_jump_next;
396} 464}
397 465
398*op_mapstart = \&op_grepstart; 466*op_mapstart = \&op_grepstart;
399 467
… …
408 my ($idx) = @_; 476 my ($idx) = @_;
409 477
410 out_callop; 478 out_callop;
411 479
412 out_cond_jump $_->[$idx] 480 out_cond_jump $_->[$idx]
413 for reverse @loop; 481 for reverse @op_loop;
414 482
415 $source .= " return nextop;\n"; 483 $source .= " return nextop;\n";
416} 484}
417 485
418sub xop_next { 486sub xop_next {
… …
428} 496}
429 497
430sub cv2c { 498sub cv2c {
431 my ($cv) = @_; 499 my ($cv) = @_;
432 500
433 @loop = (); 501 local @ops;
502 local @op_loop;
503 local %op_regcomp;
434 504
435 my %opsseen; 505 my %opsseen;
436 my @todo = $cv->START; 506 my @todo = $cv->START;
507 my %op_target;
437 508
438 while (my $op = shift @todo) { 509 while (my $op = shift @todo) {
439 for (; $$op; $op = $op->next) { 510 for (; $$op; $op = $op->next) {
440 last if $opsseen{$$op}++; 511 last if $opsseen{$$op}++;
441 push @ops, $op;
442 512
443 my $name = $op->name; 513 my $name = $op->name;
444 my $class = B::class $op; 514 my $class = B::class $op;
445 515
516 my $insn = { op => $op };
517
518 push @ops, $insn;
519
520 if (exists $extend{$name}) {
521 my $extend = $extend{$name};
522 $extend = $extend->($op) if ref $extend;
523 $insn->{extend} = $extend if defined $extend;
524 }
525
526 push @todo, $op->next;
527
446 if ($class eq "LOGOP") { 528 if ($class eq "LOGOP") {
447 unshift @todo, $op->other; # unshift vs. push saves jumps 529 push @todo, $op->other;
530 $op_target{${$op->other}}++;
531
532 # regcomp/o patches ops at runtime, lets expect that
533 if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
534 $op_target{${$op->first}}++;
535 $op_regcomp{${$op->first}} = $op->next;
536 }
537
448 } elsif ($class eq "PMOP") { 538 } elsif ($class eq "PMOP") {
539 if (${$op->pmreplstart}) {
449 unshift @todo, $op->pmreplstart if ${$op->pmreplstart}; 540 unshift @todo, $op->pmreplstart;
541 $op_target{${$op->pmreplstart}}++;
542 }
543
450 } elsif ($class eq "LOOP") { 544 } elsif ($class eq "LOOP") {
451 push @loop, [$op->nextop, $op->lastop->next, $op->redoop->next]; 545 my @targ = ($op->nextop, $op->lastop->next, $op->redoop->next);
546
547 push @op_loop, \@targ;
548 push @todo, @targ;
549
550 $op_target{$$_}++ for @targ;
551 } elsif ($class eq "COP") {
552 $insn->{bblock}++ if defined $op->label;
452 } 553 }
453 } 554 }
454 } 555 }
556
557 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
455 558
456 local $source = <<EOF; 559 local $source = <<EOF;
457OP *%%%FUNC%%% (pTHX) 560OP *%%%FUNC%%% (pTHX)
458{ 561{
459 register OP *nextop = (OP *)${$ops[0]}L; 562 register OP *nextop = (OP *)${$ops[0]->{op}}L;
460EOF 563EOF
461 564
462 while (@ops) { 565 while (@ops) {
463 $op = shift @ops; 566 $insn = shift @ops;
567
568 $op = $insn->{op};
464 $op_name = $op->name; 569 $op_name = $op->name;
465 570
571 my $class = B::class $op;
572
573 $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
466 $source .= "op_$$op: /* $op_name */\n"; 574 $source .= "op_$$op: /* $op_name */\n";
467 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d# 575 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
468 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d# 576 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
469 577
470 $source .= " PERL_ASYNC_CHECK ();\n" 578 $source .= " PERL_ASYNC_CHECK ();\n"
471 unless exists $flag{noasync}{$op_name}; 579 unless exists $f_noasync{$op_name};
472 580
473 if (my $can = __PACKAGE__->can ("op_$op_name")) { 581 if (my $can = __PACKAGE__->can ("op_$op_name")) {
474 # handcrafted replacement 582 # handcrafted replacement
583
584 if ($insn->{extend} > 0) {
585 # coalesce EXTENDs
586 # TODO: properly take negative preceeding and following EXTENDs into account
587 for my $i (@ops) {
588 last if exists $i->{bblock};
589 last unless exists $i->{extend};
590 my $extend = delete $i->{extend};
591 $insn->{extend} += $extend if $extend > 0;
592 }
593
594 $source .= " { dSP; EXTEND (SP, $insn->{extend}); PUTBACK; }\n"
595 if $insn->{extend} > 0;
596 }
597
475 $can->($op); 598 $can->($op);
476 599
477 } elsif (exists $flag{unsafe}{$op_name}) { 600 } elsif (exists $f_unsafe{$op_name}) {
478 # unsafe, return to interpreter 601 # unsafe, return to interpreter
479 assert "nextop == (OP *)$$op"; 602 assert "nextop == (OP *)$$op";
480 $source .= " return nextop;\n"; 603 $source .= " return nextop;\n";
481 604
482 } elsif ("LOGOP" eq B::class $op) { 605 } elsif ("LOGOP" eq $class) {
483 # logical operation with optionaö branch 606 # logical operation with optional branch
484 out_callop; 607 out_callop;
485 out_cond_jump $op->other; 608 out_cond_jump $op->other;
486 out_jump_next; 609 out_jump_next;
487 610
488 } elsif ("PMOP" eq B::class $op) { 611 } elsif ("PMOP" eq $class) {
489 # regex-thingy 612 # regex-thingy
490 out_callop; 613 out_callop;
491 out_cond_jump $op->pmreplroot if ${$op->pmreplroot}; 614 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
492 out_jump_next; 615 out_jump_next;
493 616
494 } else { 617 } else {
495 # normal operator, linear execution 618 # normal operator, linear execution
496 out_linear; 619 out_linear;
… …
507 #warn $source; 630 #warn $source;
508 631
509 $source 632 $source
510} 633}
511 634
635my $uid = "aaaaaaa0";
636
512sub source2ptr { 637sub source2ptr {
513 my ($source) = @_; 638 my (@source) = @_;
514 639
515 my $md5 = Digest::MD5::md5_hex $source; 640 my $stem = "/tmp/Faster-$$-" . $uid++;
516 $source =~ s/%%%FUNC%%%/Faster_$md5/;
517 641
518 my $stem = "/tmp/$md5";
519
520 unless (-e "$stem$_so") {
521 open FILE, ">:raw", "$stem.c"; 642 open FILE, ">:raw", "$stem.c";
522 print FILE <<EOF; 643 print FILE <<EOF;
523#define PERL_NO_GET_CONTEXT 644#define PERL_NO_GET_CONTEXT
645#define PERL_CORE
524 646
525#include <assert.h> 647#include <assert.h>
526 648
527#include "EXTERN.h" 649#include "EXTERN.h"
528#include "perl.h" 650#include "perl.h"
529#include "XSUB.h" 651#include "XSUB.h"
530 652
531#define RUNOPS_TILL(op) \\ 653#define RUNOPS_TILL(op) \\
532 while (nextop != (op)) \\ 654while (nextop != (op)) \\
533 { \\ 655 { \\
534 PERL_ASYNC_CHECK (); \\ 656 PERL_ASYNC_CHECK (); \\
535 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\ 657 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
536 } 658 }
537 659
538EOF 660EOF
661 for (@source) {
662 my $func = $uid++;
663 $_ =~ s/%%%FUNC%%%/$func/g;
539 print FILE $source; 664 print FILE $_;
540 close FILE; 665 $_ = $func;
541 system "$COMPILE -o $stem$_o $stem.c";
542 system "$LINK -o $stem$_so $stem$_o $LIBS";
543 } 666 }
544 667
545# warn $source; 668 close FILE;
669 system "$COMPILE -o $stem$_o $stem.c";
670 #d#unlink "$stem.c";
671 system "$LINK -o $stem$_so $stem$_o $LIBS";
672 unlink "$stem$_o";
673
546 my $so = DynaLoader::dl_load_file "$stem$_so" 674 my $so = DynaLoader::dl_load_file "$stem$_so"
547 or die "$stem$_so: $!"; 675 or die "$stem$_so: $!";
548 676
549 DynaLoader::dl_find_symbol $so, "Faster_$md5" 677 #unlink "$stem$_so";
550 or die "Faster_$md5: $!" 678
679 map +(DynaLoader::dl_find_symbol $so, $_), @source
551} 680}
681
682my %ignore;
552 683
553sub entersub { 684sub entersub {
554 my ($cv) = @_; 685 my ($cv) = @_;
555 686
556 # always compile the whole stash 687 my $pkg = $cv->STASH->NAME;
557# my @stash = $cv->STASH->ARRAY; 688
558# warn join ":", @stash; 689 return if $ignore{$pkg};
559# exit; 690
691 warn "compiling ", $cv->STASH->NAME, "\n"
692 if $verbose;
560 693
561 eval { 694 eval {
562 my $source = cv2c $cv; 695 my @cv;
696 my @cv_source;
563 697
698 # always compile the whole stash
699 my %stash = $cv->STASH->ARRAY;
700 while (my ($k, $v) = each %stash) {
701 $v->isa (B::GV::)
702 or next;
703
704 my $cv = $v->CV;
705
706 if ($cv->isa (B::CV::)
707 && ${$cv->START}
708 && $cv->START->name ne "null") {
709 push @cv, $cv;
710 push @cv_source, cv2c $cv;
711 }
712 }
713
564 my $ptr = source2ptr $source; 714 my @ptr = source2ptr @cv_source;
565 715
716 for (0 .. $#cv) {
566 patch_cv $cv, $ptr; 717 patch_cv $cv[$_], $ptr[$_];
718 }
567 }; 719 };
568 720
569 warn $@ if $@; 721 if ($@) {
722 $ignore{$pkg}++;
723 warn $@;
724 }
570} 725}
571 726
572hook_entersub; 727hook_entersub;
573 728
5741; 7291;
730
731=back
732
733=head1 ENVIRONMENT VARIABLES
734
735The following environment variables influence the behaviour of Faster:
736
737=over 4
738
739=item FASTER_VERBOSE
740
741Faster will output more informational messages when set to values higher
742than C<0>. Currently, C<1> outputs which packages are being compiled.
743
744=item FASTER_DEBUG
745
746Add debugging code when set to values higher than C<0>. Currently, this
747adds 1-3 C<assert>'s per perl op, to ensure that opcode order and C
748execution order are compatible.
749
750=item FASTER_CACHE
751
752NOT YET IMPLEMENTED
753
754Set a persistent cache directory that caches compiled code
755fragments. Normally, code compiled by Faster will be deleted immediately,
756and every restart will recompile everything. Setting this variable to a
757directory makes Faster cache the generated files for re-use.
758
759This directory will always grow in contents, so you might need to erase it
760from time to time.
575 761
576=back 762=back
577 763
578=head1 BUGS/LIMITATIONS 764=head1 BUGS/LIMITATIONS
579 765
580Perl will check much less often for asynchronous signals in 766Perl will check much less often for asynchronous signals in
581Faster-compiled code. It tries to check on every function call, loop 767Faster-compiled code. It tries to check on every function call, loop
582iteration and every I/O operator, though. 768iteration and every I/O operator, though.
583 769
584The following things will disable Faster. If you manage to enable them at 770The following things will disable Faster. If you manage to enable them at
585runtime, bad things will happen. 771runtime, bad things will happen. Enabling them at startup will be fine,
772though.
586 773
587 enabled tainting 774 enabled tainting
588 enabled debugging 775 enabled debugging
589 776
590This will dramatically reduce Faster's performance: 777Thread-enabled builds of perl will dramatically reduce Faster's
778performance, but you don't care about speed if you enable threads anyway.
591 779
592 threads (but you don't care about speed if you use threads anyway)
593
594These constructs will force the use of the interpreter as soon as they are 780These constructs will force the use of the interpreter for the currently
595being executed, for the rest of the currently executed: 781executed function as soon as they are being encountered during execution.
596 782
597 .., ... (flipflop operators)
598 goto 783 goto
599 next, redo (but not well-behaved last's) 784 next, redo (but not well-behaved last's)
600 eval 785 eval
601 require 786 require
602 any use of formats 787 any use of formats
788 .., ... (flipflop operators)
603 789
604=head1 AUTHOR 790=head1 AUTHOR
605 791
606 Marc Lehmann <schmorp@schmorp.de> 792 Marc Lehmann <schmorp@schmorp.de>
607 http://home.schmorp.de/ 793 http://home.schmorp.de/

Diff Legend

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