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

Diff Legend

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