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

Diff Legend

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