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

Comparing Faster/Faster.pm (file contents):
Revision 1.12 by root, Fri Mar 10 18:39:26 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;
… …
31my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}"; 57my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
32my $LIBS = "$Config{libs}"; 58my $LIBS = "$Config{libs}";
33my $_o = $Config{_o}; 59my $_o = $Config{_o};
34my $_so = ".so"; 60my $_so = ".so";
35 61
36my $opt_assert = 1; 62# we don't need no steenking PIC on x86
63$COMPILE =~ s/-f(?:PIC|pic)//g
64 if $Config{archname} =~ /^(i[3456]86)-/;
65
66my $opt_assert = $ENV{FASTER_DEBUG};
67my $verbose = $ENV{FASTER_VERBOSE}+0;
37 68
38our $source; 69our $source;
39 70
40my @ops; 71our @ops;
41my $op; 72our $insn;
73our $op;
42my $op_name; 74our $op_name;
43my @loop; 75our @op_loop;
76our %op_regcomp;
44 77
45my %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);
46 86
47# complex flag steting is no longer required, rewrite this ugly code 87# ops with known stack extend behaviour
48for (split /\n/, <<EOF) { 88# the values given are maximum values
49 leavesub unsafe 89my %extend = (
50 leavesublv unsafe 90 pushmark => 0,
51 return unsafe 91 nextstate => 0, # might reduce the stack
52 flip unsafe 92 unstack => 0,
53 goto unsafe 93 enter => 0,
54 last unsafe
55 redo unsafe
56 next unsafe
57 eval unsafe
58 leaveeval unsafe
59 entertry unsafe
60 formline unsafe
61 grepstart unsafe
62 mapstart unsafe
63 substcont unsafe
64 entereval unsafe noasync todo
65 require unsafe
66 94
67 mapstart noasync 95 stringify => 0,
68 grepstart noasync 96 not => 0,
69 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);
70 132
71 last noasync 133# ops that do not need an ASYNC_CHECK
72 next noasync 134my %f_noasync = map +($_ => undef), qw(
73 redo noasync 135 mapstart grepstart match entereval
74 seq noasync 136 enteriter entersub leaveloop
75 pushmark noasync extend=0
76 padsv noasync extend=1
77 padav noasync extend=1
78 padhv noasync extend=1
79 padany noasync extend=1
80 entersub noasync
81 aassign noasync
82 sassign noasync
83 rv2av noasync
84 rv2cv noasync
85 rv2gv noasync
86 rv2hv noasync
87 refgen noasync
88 nextstate noasync
89 gv noasync
90 gvsv noasync
91 add noasync
92 subtract noasync
93 multiply noasync
94 divide noasync
95 complement noasync
96 cond_expr noasync
97 and noasync
98 or noasync
99 not noasync
100 defined noasync
101 method_named noasync
102 preinc noasync
103 postinc noasync
104 predec noasync
105 postdec noasync
106 stub noasync
107 unstack noasync
108 leaveloop noasync
109 aelem noasync
110 aelemfast noasync
111 helem noasync
112 pushre noasync
113 subst noasync
114 const noasync extend=1
115 list noasync
116 join noasync
117 split noasync
118 concat noasync
119 push noasync
120 pop noasync
121 shift noasync
122 unshift noasync
123 length noasync
124 substr noasync
125 stringify noasync
126 eq noasync
127 ne noasync
128 gt noasync
129 lt noasync
130 ge noasync
131 le noasync
132 enteriter noasync
133 ord noasync
134 137
135 iter async 138 pushmark nextstate
136EOF
137 my (undef, $op, @flags) = split /\s+/;
138 139
139 undef $flag{$_}{$op} 140 const stub unstack
140 for ("known", @flags); 141 last next redo seq
141} 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);
142 158
143my %callop = ( 159my %callop = (
144 entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)", 160 entersub => "(PL_op->op_ppaddr) (aTHX)",
145 mapstart => "Perl_pp_grepstart (aTHX)", 161 mapstart => "Perl_pp_grepstart (aTHX)",
146); 162);
147 163
148sub callop { 164sub callop {
149 $callop{$op_name} || "Perl_pp_$op_name (aTHX)" 165 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
… …
157sub out_callop { 173sub out_callop {
158 assert "nextop == (OP *)$$op"; 174 assert "nextop == (OP *)$$op";
159 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n"; 175 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
160} 176}
161 177
178sub out_cond_jump {
179 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
180}
181
162sub out_jump_next { 182sub out_jump_next {
183 out_cond_jump $op_regcomp{$$op}
184 if $op_regcomp{$$op};
185
163 assert "nextop == (OP *)${$op->next}"; 186 assert "nextop == (OP *)${$op->next}";
164 $source .= " goto op_${$op->next};\n"; 187 $source .= " goto op_${$op->next};\n";
165} 188}
166 189
167sub out_next { 190sub out_next {
… …
171} 194}
172 195
173sub out_linear { 196sub out_linear {
174 out_callop; 197 out_callop;
175 out_jump_next; 198 out_jump_next;
176}
177
178sub out_cond_jump {
179 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
180} 199}
181 200
182sub op_entersub { 201sub op_entersub {
183 out_callop; 202 out_callop;
184 $source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n"; 203 $source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n";
… …
199 $source .= " PUSHMARK (PL_stack_sp);\n"; 218 $source .= " PUSHMARK (PL_stack_sp);\n";
200 219
201 out_next; 220 out_next;
202} 221}
203 222
204if (0 && $Config{useithreads} ne "define") { 223if ($Config{useithreads} ne "define") {
205 # disable optimisations on ithreads 224 # disable optimisations on ithreads
206 225
207 *op_const = sub { 226 *op_const = sub {
208 $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#
209 230
210 out_next; 231 out_next;
211 }; 232 };
212 233
213 *op_gv = \&op_const; 234 *op_gv = \&op_const;
… …
233 if (!($op->flags & B::OPf_MOD)) { 254 if (!($op->flags & B::OPf_MOD)) {
234 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n"; 255 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
235 } 256 }
236 257
237 $source .= " dSP;\n"; 258 $source .= " dSP;\n";
238 $source .= " XPUSHs (sv);\n"; 259 $source .= " PUSHs (sv);\n";
239 $source .= " PUTBACK;\n"; 260 $source .= " PUTBACK;\n";
240 $source .= " }\n"; 261 $source .= " }\n";
241 262
242 out_next; 263 out_next;
243 }; 264 };
244 265
245 *op_gvsv = sub { 266 *op_gvsv = sub {
246 $source .= " {\n"; 267 $source .= " {\n";
247 $source .= " dSP;\n"; 268 $source .= " dSP;\n";
248 $source .= " EXTEND (SP, 1);\n";
249 269
250 if ($op->private & B::OPpLVAL_INTRO) { 270 if ($op->private & B::OPpLVAL_INTRO) {
251 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n"; 271 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
252 } else { 272 } else {
253 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n"; 273 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
… …
313 out_next; 333 out_next;
314} 334}
315 335
316sub op_padsv { 336sub op_padsv {
317 my $flags = $op->flags; 337 my $flags = $op->flags;
318 my $target = $op->targ; 338 my $padofs = "(PADOFFSET)" . $op->targ;
319 339
320 $source .= <<EOF; 340 $source .= <<EOF;
321 { 341 {
322 dSP; 342 dSP;
323 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);
324 PUTBACK; 353 PUTBACK;
325EOF 354EOF
326 if ($op->flags & B::OPf_MOD) { 355
327 if ($op->private & B::OPpLVAL_INTRO) { 356 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
328 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n"; 357 $source .= " vivify_ref (sv, " . $op->private . " & OPpDEREF);\n";
329 } elsif ($op->private & B::OPpDEREF) {
330 my $deref = $op->private & B::OPpDEREF;
331 $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
332 }
333 } 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
334 $source .= <<EOF; 380 $source .= <<EOF;
381 SETs (right);
382 PUTBACK;
335 } 383 }
336EOF 384EOF
337 385
338 out_next; 386 out_next;
339} 387}
340 388
341# pattern const+ (or general push1) 389# pattern const+ (or general push1)
342# pattern pushmark return(?)
343# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 390# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
344 391
345# pattern const method_named
346sub op_method_named { 392sub op_method_named {
393 if ($insn->{follows_const}) {
347 $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;
348 { 418 {
349 static HV *last_stash; 419 static HV *last_stash;
350 static SV *last_cv; 420 static SV *last_cv;
351 static U32 last_sub_generation; 421 static U32 last_sub_generation;
352 422
… …
359 429
360 /* simple "polymorphic" inline cache */ 430 /* simple "polymorphic" inline cache */
361 if (stash == last_stash 431 if (stash == last_stash
362 && PL_sub_generation == last_sub_generation) 432 && PL_sub_generation == last_sub_generation)
363 { 433 {
364 XPUSHs (last_cv); 434 PUSHs (last_cv);
365 PUTBACK; 435 PUTBACK;
366 } 436 }
367 else 437 else
368 { 438 {
369 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 439 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
… …
379 /* error case usually */ 449 /* error case usually */
380 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 450 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
381 } 451 }
382 } 452 }
383EOF 453EOF
454 }
384 455
385 out_next; 456 out_next;
386} 457}
387 458
388sub op_grepstart { 459sub op_grepstart {
389 out_callop; 460 out_callop;
461 $op = $op->next;
390 out_cond_jump $op->next->other; 462 out_cond_jump $op->other;
391 out_jump_next; 463 out_jump_next;
392} 464}
393 465
394*op_mapstart = \&op_grepstart; 466*op_mapstart = \&op_grepstart;
395 467
… …
404 my ($idx) = @_; 476 my ($idx) = @_;
405 477
406 out_callop; 478 out_callop;
407 479
408 out_cond_jump $_->[$idx] 480 out_cond_jump $_->[$idx]
409 for reverse @loop; 481 for reverse @op_loop;
410 482
411 $source .= " return nextop;\n"; 483 $source .= " return nextop;\n";
412} 484}
413 485
414sub xop_next { 486sub xop_next {
… …
424} 496}
425 497
426sub cv2c { 498sub cv2c {
427 my ($cv) = @_; 499 my ($cv) = @_;
428 500
429 @loop = (); 501 local @ops;
502 local @op_loop;
503 local %op_regcomp;
430 504
431 my %opsseen; 505 my %opsseen;
432 my @todo = $cv->START; 506 my @todo = $cv->START;
507 my %op_target;
433 508
434 while (my $op = shift @todo) { 509 while (my $op = shift @todo) {
435 for (; $$op; $op = $op->next) { 510 for (; $$op; $op = $op->next) {
436 last if $opsseen{$$op}++; 511 last if $opsseen{$$op}++;
437 push @ops, $op;
438 512
439 my $name = $op->name; 513 my $name = $op->name;
440 my $class = B::class $op; 514 my $class = B::class $op;
441 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
442 if ($class eq "LOGOP") { 528 if ($class eq "LOGOP") {
443 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
444 } elsif ($class eq "PMOP") { 538 } elsif ($class eq "PMOP") {
539 if (${$op->pmreplstart}) {
445 unshift @todo, $op->pmreplstart if ${$op->pmreplstart}; 540 unshift @todo, $op->pmreplstart;
541 $op_target{${$op->pmreplstart}}++;
542 }
543
446 } elsif ($class eq "LOOP") { 544 } elsif ($class eq "LOOP") {
447 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;
448 } 553 }
449 } 554 }
450 } 555 }
556
557 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
451 558
452 local $source = <<EOF; 559 local $source = <<EOF;
453OP *%%%FUNC%%% (pTHX) 560OP *%%%FUNC%%% (pTHX)
454{ 561{
455 register OP *nextop = (OP *)${$ops[0]}L; 562 register OP *nextop = (OP *)${$ops[0]->{op}}L;
456EOF 563EOF
457 564
458 while (@ops) { 565 while (@ops) {
459 $op = shift @ops; 566 $insn = shift @ops;
567
568 $op = $insn->{op};
460 $op_name = $op->name; 569 $op_name = $op->name;
461 570
571 my $class = B::class $op;
572
573 $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
462 $source .= "op_$$op: /* $op_name */\n"; 574 $source .= "op_$$op: /* $op_name */\n";
463 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d# 575 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
464 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d# 576 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
465 577
466 $source .= " PERL_ASYNC_CHECK ();\n" 578 $source .= " PERL_ASYNC_CHECK ();\n"
467 unless exists $flag{noasync}{$op_name}; 579 unless exists $f_noasync{$op_name};
468 580
469 if (my $can = __PACKAGE__->can ("op_$op_name")) { 581 if (my $can = __PACKAGE__->can ("op_$op_name")) {
470 # 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
471 $can->($op); 598 $can->($op);
472 599
473 } elsif (exists $flag{unsafe}{$op_name}) { 600 } elsif (exists $f_unsafe{$op_name}) {
474 # unsafe, return to interpreter 601 # unsafe, return to interpreter
475 assert "nextop == (OP *)$$op"; 602 assert "nextop == (OP *)$$op";
476 $source .= " return nextop;\n"; 603 $source .= " return nextop;\n";
477 604
478 } elsif ("LOGOP" eq B::class $op) { 605 } elsif ("LOGOP" eq $class) {
479 # logical operation with optionaö branch 606 # logical operation with optional branch
480 out_callop; 607 out_callop;
481 out_cond_jump $op->other; 608 out_cond_jump $op->other;
482 out_jump_next; 609 out_jump_next;
483 610
484 } elsif ("PMOP" eq B::class $op) { 611 } elsif ("PMOP" eq $class) {
485 # regex-thingy 612 # regex-thingy
486 out_callop; 613 out_callop;
487 out_cond_jump $op->pmreplroot if ${$op->pmreplroot}; 614 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
488 out_jump_next; 615 out_jump_next;
489 616
490 } else { 617 } else {
491 # normal operator, linear execution 618 # normal operator, linear execution
492 out_linear; 619 out_linear;
… …
503 #warn $source; 630 #warn $source;
504 631
505 $source 632 $source
506} 633}
507 634
635my $uid = "aaaaaaa0";
636
508sub source2ptr { 637sub source2ptr {
509 my ($source) = @_; 638 my (@source) = @_;
510 639
511 my $md5 = Digest::MD5::md5_hex $source; 640 my $stem = "/tmp/Faster-$$-" . $uid++;
512 $source =~ s/%%%FUNC%%%/Faster_$md5/;
513 641
514 my $stem = "/tmp/$md5";
515
516 unless (-e "$stem$_so") {
517 open FILE, ">:raw", "$stem.c"; 642 open FILE, ">:raw", "$stem.c";
518 print FILE <<EOF; 643 print FILE <<EOF;
519#define PERL_NO_GET_CONTEXT 644#define PERL_NO_GET_CONTEXT
645#define PERL_CORE
520 646
521#include <assert.h> 647#include <assert.h>
522 648
523#include "EXTERN.h" 649#include "EXTERN.h"
524#include "perl.h" 650#include "perl.h"
525#include "XSUB.h" 651#include "XSUB.h"
526 652
527#define RUNOPS_TILL(op) \\ 653#define RUNOPS_TILL(op) \\
528 while (nextop != (op)) \\ 654while (nextop != (op)) \\
529 { \\ 655 { \\
530 PERL_ASYNC_CHECK (); \\ 656 PERL_ASYNC_CHECK (); \\
531 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\ 657 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
532 } 658 }
533 659
534EOF 660EOF
661 for (@source) {
662 my $func = $uid++;
663 $_ =~ s/%%%FUNC%%%/$func/g;
535 print FILE $source; 664 print FILE $_;
536 close FILE; 665 $_ = $func;
537 system "$COMPILE -o $stem$_o $stem.c";
538 system "$LINK -o $stem$_so $stem$_o $LIBS";
539 } 666 }
540 667
541# 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
542 my $so = DynaLoader::dl_load_file "$stem$_so" 674 my $so = DynaLoader::dl_load_file "$stem$_so"
543 or die "$stem$_so: $!"; 675 or die "$stem$_so: $!";
544 676
545 DynaLoader::dl_find_symbol $so, "Faster_$md5" 677 #unlink "$stem$_so";
546 or die "Faster_$md5: $!" 678
679 map +(DynaLoader::dl_find_symbol $so, $_), @source
547} 680}
681
682my %ignore;
548 683
549sub entersub { 684sub entersub {
550 my ($cv) = @_; 685 my ($cv) = @_;
551 686
552 # always compile the whole stash 687 my $pkg = $cv->STASH->NAME;
553# my @stash = $cv->STASH->ARRAY; 688
554# warn join ":", @stash; 689 return if $ignore{$pkg};
555# exit; 690
691 warn "compiling ", $cv->STASH->NAME, "\n"
692 if $verbose;
556 693
557 eval { 694 eval {
558 my $source = cv2c $cv; 695 my @cv;
696 my @cv_source;
559 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
560 my $ptr = source2ptr $source; 714 my @ptr = source2ptr @cv_source;
561 715
716 for (0 .. $#cv) {
562 patch_cv $cv, $ptr; 717 patch_cv $cv[$_], $ptr[$_];
718 }
563 }; 719 };
564 720
565 warn $@ if $@; 721 if ($@) {
722 $ignore{$pkg}++;
723 warn $@;
724 }
566} 725}
567 726
568hook_entersub; 727hook_entersub;
569 728
5701; 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.
571 761
572=back 762=back
573 763
574=head1 BUGS/LIMITATIONS 764=head1 BUGS/LIMITATIONS
575 765
576Perl will check much less often for asynchronous signals in 766Perl will check much less often for asynchronous signals in
577Faster-compiled code. It tries to check on every function call, loop 767Faster-compiled code. It tries to check on every function call, loop
578iteration and every I/O operator, though. 768iteration and every I/O operator, though.
579 769
580The 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
581runtime, bad things will happen. 771runtime, bad things will happen. Enabling them at startup will be fine,
772though.
582 773
583 enabled tainting 774 enabled tainting
584 enabled debugging 775 enabled debugging
585 776
586This 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.
587 779
588 threads (but you don't care about speed if you use threads anyway)
589
590These 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
591being executed, for the rest of the currently executed: 781executed function as soon as they are being encountered during execution.
592 782
593 .., ... (flipflop operators)
594 goto 783 goto
595 next, redo (but not well-behaved last's) 784 next, redo (but not well-behaved last's)
596 eval 785 eval
597 require 786 require
598 any use of formats 787 any use of formats
788 .., ... (flipflop operators)
599 789
600=head1 AUTHOR 790=head1 AUTHOR
601 791
602 Marc Lehmann <schmorp@schmorp.de> 792 Marc Lehmann <schmorp@schmorp.de>
603 http://home.schmorp.de/ 793 http://home.schmorp.de/

Diff Legend

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