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.31 by root, Mon Mar 13 16:59:43 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} > 1;
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 caller
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 goto 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 bit_and bit_or bit_xor
161 defined
162 method method_named bless
163 preinc postinc predec postdec
164 aelem aelemfast helem delete exists
165 pushre subst list lslice join split concat
166 length substr stringify ord
167 push pop shift unshift
168 eq ne gt lt ge le
169 regcomp regcreset regcmaybe
170);
146 171
147my %callop = ( 172my %callop = (
148 entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)", 173 entersub => "(PL_op->op_ppaddr) (aTHX)",
149 mapstart => "Perl_pp_grepstart (aTHX)", 174 mapstart => "Perl_pp_grepstart (aTHX)",
150); 175);
151 176
152sub callop { 177sub callop {
153 $callop{$op_name} || "Perl_pp_$op_name (aTHX)" 178 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
… …
161sub out_callop { 186sub out_callop {
162 assert "nextop == (OP *)$$op"; 187 assert "nextop == (OP *)$$op";
163 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n"; 188 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
164} 189}
165 190
191sub out_cond_jump {
192 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
193}
194
166sub out_jump_next { 195sub out_jump_next {
196 out_cond_jump $op_regcomp{$$op}
197 if $op_regcomp{$$op};
198
167 assert "nextop == (OP *)${$op->next}"; 199 assert "nextop == (OP *)${$op->next}";
168 $source .= " goto op_${$op->next};\n"; 200 $source .= " goto op_${$op->next};\n";
169} 201}
170 202
171sub out_next { 203sub out_next {
… …
175} 207}
176 208
177sub out_linear { 209sub out_linear {
178 out_callop; 210 out_callop;
179 out_jump_next; 211 out_jump_next;
180}
181
182sub out_cond_jump {
183 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
184} 212}
185 213
186sub op_entersub { 214sub op_entersub {
187 out_callop; 215 out_callop;
188 $source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n"; 216 $source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n";
… …
198 226
199 out_next; 227 out_next;
200} 228}
201 229
202sub op_pushmark { 230sub op_pushmark {
203 $source .= " PUSHMARK (PL_stack_sp);\n"; 231 $source .= " faster_PUSHMARK (PL_stack_sp);\n";
204 232
205 out_next; 233 out_next;
206} 234}
207 235
208if ($Config{useithreads} ne "define") { 236if ($Config{useithreads} ne "define") {
209 # disable optimisations on ithreads 237 # disable optimisations on ithreads
210 238
211 *op_const = sub { 239 *op_const = sub {
212 $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n"; 240 $source .= " { dSP; PUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
241
242 $ops[0]{follows_const}++ if @ops;#d#
213 243
214 out_next; 244 out_next;
215 }; 245 };
216 246
217 *op_gv = \&op_const; 247 *op_gv = \&op_const;
… …
237 if (!($op->flags & B::OPf_MOD)) { 267 if (!($op->flags & B::OPf_MOD)) {
238 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n"; 268 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
239 } 269 }
240 270
241 $source .= " dSP;\n"; 271 $source .= " dSP;\n";
242 $source .= " XPUSHs (sv);\n"; 272 $source .= " PUSHs (sv);\n";
243 $source .= " PUTBACK;\n"; 273 $source .= " PUTBACK;\n";
244 $source .= " }\n"; 274 $source .= " }\n";
245 275
246 out_next; 276 out_next;
247 }; 277 };
248 278
249 *op_gvsv = sub { 279 *op_gvsv = sub {
250 $source .= " {\n"; 280 $source .= " {\n";
251 $source .= " dSP;\n"; 281 $source .= " dSP;\n";
252 $source .= " EXTEND (SP, 1);\n";
253 282
254 if ($op->private & B::OPpLVAL_INTRO) { 283 if ($op->private & B::OPpLVAL_INTRO) {
255 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n"; 284 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
256 } else { 285 } else {
257 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n"; 286 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
… …
317 out_next; 346 out_next;
318} 347}
319 348
320sub op_padsv { 349sub op_padsv {
321 my $flags = $op->flags; 350 my $flags = $op->flags;
322 my $target = $op->targ; 351 my $padofs = "(PADOFFSET)" . $op->targ;
323 352
324 $source .= <<EOF; 353 $source .= <<EOF;
325 { 354 {
326 dSP; 355 dSP;
327 XPUSHs (PAD_SV ((PADOFFSET)$target)); 356 SV *sv = PAD_SVl ($padofs);
357EOF
358
359 if (($flags & B::OPf_MOD) && ($op->private & B::OPpLVAL_INTRO)) {
360 $source .= " SAVECLEARSV (PAD_SVl ($padofs));\n";
361 $ops[0]{follows_padsv_lval_intro}++ if @ops;#d#
362 }
363
364 $source .= <<EOF;
365 PUSHs (sv);
328 PUTBACK; 366 PUTBACK;
329EOF 367EOF
330 if ($op->flags & B::OPf_MOD) { 368
331 if ($op->private & B::OPpLVAL_INTRO) { 369 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
332 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n"; 370 $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 } 371 }
372 $source .= " }\n";
373
374 out_next;
375}
376
377sub op_sassign {
378 $source .= <<EOF;
379 {
380 dSP;
381 dPOPTOPssrl;
382EOF
383 $source .= " SV *temp = left; left = right; right = temp;\n"
384 if $op->private & B::OPpASSIGN_BACKWARDS;
385
386 if ($insn->{follows_padsv_lval_intro} && !($op->private & B::OPpASSIGN_BACKWARDS)) {
387 # simple assignment - the target exists, but is basically undef
388 $source .= " SvSetSV (right, left);\n";
389 } else {
390 $source .= " SvSetMagicSV (right, left);\n";
391 }
392
338 $source .= <<EOF; 393 $source .= <<EOF;
394 SETs (right);
395 PUTBACK;
339 } 396 }
340EOF 397EOF
341 398
342 out_next; 399 out_next;
343} 400}
344 401
345# pattern const+ (or general push1) 402# pattern const+ (or general push1)
346# pattern pushmark return(?)
347# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 403# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
348 404
349# pattern const method_named
350sub op_method_named { 405sub op_method_named {
406 if ($insn->{follows_const}) {
351 $source .= <<EOF; 407 $source .= <<EOF;
408 {
409 dSP;
410 static SV *last_cv;
411 static U32 last_sub_generation;
412
413 /* simple "polymorphic" inline cache */
414 if (PL_sub_generation == last_sub_generation)
415 {
416 PUSHs (last_cv);
417 PUTBACK;
418 }
419 else
420 {
421 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
422
423 SPAGAIN;
424 last_sub_generation = PL_sub_generation;
425 last_cv = TOPs;
426 }
427 }
428EOF
429 } else {
430 $source .= <<EOF;
352 { 431 {
353 static HV *last_stash; 432 static HV *last_stash;
354 static SV *last_cv; 433 static SV *last_cv;
355 static U32 last_sub_generation; 434 static U32 last_sub_generation;
356 435
… …
363 442
364 /* simple "polymorphic" inline cache */ 443 /* simple "polymorphic" inline cache */
365 if (stash == last_stash 444 if (stash == last_stash
366 && PL_sub_generation == last_sub_generation) 445 && PL_sub_generation == last_sub_generation)
367 { 446 {
368 XPUSHs (last_cv); 447 PUSHs (last_cv);
369 PUTBACK; 448 PUTBACK;
370 } 449 }
371 else 450 else
372 { 451 {
373 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 452 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
… …
383 /* error case usually */ 462 /* error case usually */
384 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 463 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
385 } 464 }
386 } 465 }
387EOF 466EOF
467 }
388 468
389 out_next; 469 out_next;
390} 470}
391 471
392sub op_grepstart { 472sub op_grepstart {
393 out_callop; 473 out_callop;
474 $op = $op->next;
394 out_cond_jump $op->next->other; 475 out_cond_jump $op->other;
395 out_jump_next; 476 out_jump_next;
396} 477}
397 478
398*op_mapstart = \&op_grepstart; 479*op_mapstart = \&op_grepstart;
399 480
… …
408 my ($idx) = @_; 489 my ($idx) = @_;
409 490
410 out_callop; 491 out_callop;
411 492
412 out_cond_jump $_->[$idx] 493 out_cond_jump $_->[$idx]
413 for reverse @loop; 494 for reverse @op_loop;
414 495
415 $source .= " return nextop;\n"; 496 $source .= " return nextop;\n";
416} 497}
417 498
418sub xop_next { 499sub xop_next {
… …
428} 509}
429 510
430sub cv2c { 511sub cv2c {
431 my ($cv) = @_; 512 my ($cv) = @_;
432 513
433 @loop = (); 514 local @ops;
515 local @op_loop;
516 local %op_regcomp;
434 517
435 my %opsseen; 518 my %opsseen;
436 my @todo = $cv->START; 519 my @todo = $cv->START;
520 my %op_target;
521 my $numpushmark;
437 522
438 while (my $op = shift @todo) { 523 while (my $op = shift @todo) {
439 for (; $$op; $op = $op->next) { 524 for (; $$op; $op = $op->next) {
440 last if $opsseen{$$op}++; 525 last if $opsseen{$$op}++;
441 push @ops, $op;
442 526
443 my $name = $op->name; 527 my $name = $op->name;
444 my $class = B::class $op; 528 my $class = B::class $op;
445 529
530 my $insn = { op => $op };
531
532 push @ops, $insn;
533
534 if (exists $extend{$name}) {
535 my $extend = $extend{$name};
536 $extend = $extend->($op) if ref $extend;
537 $insn->{extend} = $extend if defined $extend;
538 }
539
540 push @todo, $op->next;
541
446 if ($class eq "LOGOP") { 542 if ($class eq "LOGOP") {
447 unshift @todo, $op->other; # unshift vs. push saves jumps 543 push @todo, $op->other;
544 $op_target{${$op->other}}++;
545
546 # regcomp/o patches ops at runtime, lets expect that
547 if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
548 $op_target{${$op->first}}++;
549 $op_regcomp{${$op->first}} = $op->next;
550 }
551
448 } elsif ($class eq "PMOP") { 552 } elsif ($class eq "PMOP") {
553 if (${$op->pmreplstart}) {
449 unshift @todo, $op->pmreplstart if ${$op->pmreplstart}; 554 unshift @todo, $op->pmreplstart;
555 $op_target{${$op->pmreplstart}}++;
556 }
557
450 } elsif ($class eq "LOOP") { 558 } elsif ($class eq "LOOP") {
451 push @loop, [$op->nextop, $op->lastop->next, $op->redoop->next]; 559 my @targ = ($op->nextop, $op->lastop->next, $op->redoop->next);
560
561 push @op_loop, \@targ;
562 push @todo, @targ;
563
564 $op_target{$$_}++ for @targ;
565
566 } elsif ($class eq "COP") {
567 $insn->{bblock}++ if defined $op->label;
568
569 } else {
570 if ($name eq "pushmark") {
571 $numpushmark++;
572 }
452 } 573 }
453 } 574 }
454 } 575 }
576
577 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
455 578
456 local $source = <<EOF; 579 local $source = <<EOF;
457OP *%%%FUNC%%% (pTHX) 580OP *%%%FUNC%%% (pTHX)
458{ 581{
459 register OP *nextop = (OP *)${$ops[0]}L; 582 register OP *nextop = (OP *)${$ops[0]->{op}}L;
460EOF 583EOF
584
585 $source .= " faster_PUSHMARK_PREALLOC ($numpushmark);\n"
586 if $numpushmark;
461 587
462 while (@ops) { 588 while (@ops) {
463 $op = shift @ops; 589 $insn = shift @ops;
590
591 $op = $insn->{op};
464 $op_name = $op->name; 592 $op_name = $op->name;
465 593
594 my $class = B::class $op;
595
596 $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
466 $source .= "op_$$op: /* $op_name */\n"; 597 $source .= "op_$$op: /* $op_name */\n";
467 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d# 598 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
468 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d# 599 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
469 600
470 $source .= " PERL_ASYNC_CHECK ();\n" 601 $source .= " PERL_ASYNC_CHECK ();\n"
471 unless exists $flag{noasync}{$op_name}; 602 unless exists $f_noasync{$op_name};
472 603
473 if (my $can = __PACKAGE__->can ("op_$op_name")) { 604 if (my $can = __PACKAGE__->can ("op_$op_name")) {
474 # handcrafted replacement 605 # handcrafted replacement
606
607 if ($insn->{extend} > 0) {
608 # coalesce EXTENDs
609 # TODO: properly take negative preceeding and following EXTENDs into account
610 for my $i (@ops) {
611 last if exists $i->{bblock};
612 last unless exists $i->{extend};
613 my $extend = delete $i->{extend};
614 $insn->{extend} += $extend if $extend > 0;
615 }
616
617 $source .= " { dSP; EXTEND (SP, $insn->{extend}); PUTBACK; }\n"
618 if $insn->{extend} > 0;
619 }
620
475 $can->($op); 621 $can->($op);
476 622
477 } elsif (exists $flag{unsafe}{$op_name}) { 623 } elsif (exists $f_unsafe{$op_name}) {
478 # unsafe, return to interpreter 624 # unsafe, return to interpreter
479 assert "nextop == (OP *)$$op"; 625 assert "nextop == (OP *)$$op";
480 $source .= " return nextop;\n"; 626 $source .= " return nextop;\n";
481 627
482 } elsif ("LOGOP" eq B::class $op) { 628 } elsif ("LOGOP" eq $class) {
483 # logical operation with optionaö branch 629 # logical operation with optional branch
484 out_callop; 630 out_callop;
485 out_cond_jump $op->other; 631 out_cond_jump $op->other;
486 out_jump_next; 632 out_jump_next;
487 633
488 } elsif ("PMOP" eq B::class $op) { 634 } elsif ("PMOP" eq $class) {
489 # regex-thingy 635 # regex-thingy
490 out_callop; 636 out_callop;
491 out_cond_jump $op->pmreplroot if ${$op->pmreplroot}; 637 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
492 out_jump_next; 638 out_jump_next;
493 639
494 } else { 640 } else {
495 # normal operator, linear execution 641 # normal operator, linear execution
496 out_linear; 642 out_linear;
… …
507 #warn $source; 653 #warn $source;
508 654
509 $source 655 $source
510} 656}
511 657
658my $uid = "aaaaaaa0";
659my %so;
660
512sub source2ptr { 661sub func2ptr {
513 my ($source) = @_; 662 my (@func) = @_;
514 663
515 my $md5 = Digest::MD5::md5_hex $source; 664 #LOCK
516 $source =~ s/%%%FUNC%%%/Faster_$md5/; 665 mkdir $CACHEDIR, 0777;
666 sysopen my $meta_fh, "$CACHEDIR/meta", &Fcntl::O_RDWR | &Fcntl::O_CREAT, 0666
667 or die "$$CACHEDIR/meta: $!";
668 binmode $meta_fh, ":raw:perlio";
669 fcntl_lock fileno $meta_fh
670 or die "$CACHEDIR/meta: $!";
517 671
518 my $stem = "/tmp/$md5"; 672 my $meta = eval { Storable::fd_retrieve $meta_fh } || { version => 1 };
519 673
520 unless (-e "$stem$_so") { 674 for my $f (@func) {
675 $f->{func} = "F" . Digest::MD5::md5_hex ($f->{source});
676 $f->{so} = $meta->{$f->{func}};
677 }
678
679 if (grep !$_->{so}, @func) {
680 my $stem;
681
682 do {
683 $stem = "$CACHEDIR/$$-" . $uid++;
684 } while -e "$stem$_so";
685
521 open FILE, ">:raw", "$stem.c"; 686 open my $fh, ">:raw", "$stem.c";
522 print FILE <<EOF; 687 print $fh <<EOF;
523#define PERL_NO_GET_CONTEXT 688#define PERL_NO_GET_CONTEXT
689#define PERL_CORE
524 690
525#include <assert.h> 691#include <assert.h>
526 692
527#include "EXTERN.h" 693#include "EXTERN.h"
528#include "perl.h" 694#include "perl.h"
529#include "XSUB.h" 695#include "XSUB.h"
696
697#if 1
698# define faster_PUSHMARK_PREALLOC(count) while (PL_markstack_ptr + (count) >= PL_markstack_max) markstack_grow ()
699# define faster_PUSHMARK(p) *++PL_markstack_ptr = (p) - PL_stack_base
700#else
701# define faster_PUSHMARK_PREALLOC(count) 1
702# define faster_PUSHMARK(p) PUSHMARK(p)
703#endif
530 704
531#define RUNOPS_TILL(op) \\ 705#define RUNOPS_TILL(op) \\
532 while (nextop != (op)) \\ 706 while (nextop != (op)) \\
533 { \\ 707 { \\
534 PERL_ASYNC_CHECK (); \\ 708 PERL_ASYNC_CHECK (); \\
535 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\ 709 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
536 } 710 }
537 711
538EOF 712EOF
713 for my $f (grep !$_->{so}, @func) {
714 next if $f->{so} = $meta->{$f->{func}}; # some cv's alias others
715
716 warn "compiling $f->{name} to $stem$_so:$f->{func}\n" if $verbose > 1;
717 my $source = $f->{source};
718 $source =~ s/%%%FUNC%%%/$f->{func}/g;
539 print FILE $source; 719 print $fh $source;
720 $meta->{$f->{func}} = $f->{so} = $stem;
721 }
722
540 close FILE; 723 close $fh;
541 system "$COMPILE -o $stem$_o $stem.c"; 724 system "$COMPILE -o $stem$_o $stem.c";
725 unlink "$stem.c" unless $ENV{FASTER_DEBUG} > 0;
542 system "$LINK -o $stem$_so $stem$_o $LIBS"; 726 system "$LINK -o $stem$_so $stem$_o $LIBS";
727 unlink "$stem$_o";
543 } 728 }
544 729
545# warn $source; 730 for my $f (@func) {
731 my $stem = $f->{so};
732
546 my $so = DynaLoader::dl_load_file "$stem$_so" 733 my $so = ($so{$stem} ||= DynaLoader::dl_load_file "$stem$_so")
547 or die "$stem$_so: $!"; 734 or die "$stem$_so: $!";
548 735
549 DynaLoader::dl_find_symbol $so, "Faster_$md5" 736 #unlink "$stem$_so";
550 or die "Faster_$md5: $!" 737
738 $f->{ptr} = DynaLoader::dl_find_symbol $so, $f->{func}
739 or die "$f->{func} not found in $stem$_so: $!";
740 }
741
742 seek $meta_fh, 0, 0 or die "$CACHEDIR/meta: $!";
743 Storable::nstore_fd $meta, $meta_fh;
744 truncate $meta_fh, tell $meta_fh;
745
746 # UNLOCK (by closing $meta_fh)
551} 747}
748
749my %ignore;
552 750
553sub entersub { 751sub entersub {
554 my ($cv) = @_; 752 my ($cv) = @_;
555 753
556 # always compile the whole stash 754 my $pkg = $cv->STASH->NAME;
557# my @stash = $cv->STASH->ARRAY; 755
558# warn join ":", @stash; 756 return if $ignore{$pkg};
559# exit; 757
758 warn "optimising ", $cv->STASH->NAME, "\n"
759 if $verbose;
560 760
561 eval { 761 eval {
762 my @func;
763
764 push @func, {
765 cv => $cv,
766 name => "<>",
562 my $source = cv2c $cv; 767 source => cv2c $cv,
768 };
563 769
564 my $ptr = source2ptr $source; 770 # always compile the whole stash
771 my %stash = $cv->STASH->ARRAY;
772 while (my ($k, $v) = each %stash) {
773 $v->isa (B::GV::)
774 or next;
565 775
776 my $cv = $v->CV;
777
778 if ($cv->isa (B::CV::)
779 && ${$cv->START}
780 && $cv->START->name ne "null") {
781
782 push @func, {
783 cv => $cv,
784 name => $k,
785 source => cv2c $cv,
786 };
787 }
788 }
789
790 func2ptr @func;
791
792 for my $f (@func) {
566 patch_cv $cv, $ptr; 793 patch_cv $f->{cv}, $f->{ptr};
794 }
567 }; 795 };
568 796
569 warn $@ if $@; 797 if ($@) {
798 $ignore{$pkg}++;
799 warn $@;
800 }
570} 801}
571 802
572hook_entersub; 803hook_entersub;
573 804
5741; 8051;
806
807=back
808
809=head1 ENVIRONMENT VARIABLES
810
811The following environment variables influence the behaviour of Faster:
812
813=over 4
814
815=item FASTER_VERBOSE
816
817Faster will output more informational messages when set to values higher
818than C<0>. Currently, C<1> outputs which packages are being compiled, C<3>
819outputs the cache directory and C<10> outputs information on which perl
820function is compiled into which shared object.
821
822=item FASTER_DEBUG
823
824Add debugging code when set to values higher than C<0>. Currently, this
825adds 1-3 C<assert>'s per perl op (FASTER_DEBUG > 1), to ensure that opcode
826order and C execution order are compatible.
827
828=item FASTER_CACHE
829
830Set a persistent cache directory that caches compiled code fragments. The
831default is C<$HOME/.perl-faster-cache> if C<HOME> is set and a temporary
832directory otherwise.
833
834This directory will always grow in size, so you might need to erase it
835from time to time.
575 836
576=back 837=back
577 838
578=head1 BUGS/LIMITATIONS 839=head1 BUGS/LIMITATIONS
579 840
580Perl will check much less often for asynchronous signals in 841Perl will check much less often for asynchronous signals in
581Faster-compiled code. It tries to check on every function call, loop 842Faster-compiled code. It tries to check on every function call, loop
582iteration and every I/O operator, though. 843iteration and every I/O operator, though.
583 844
584The following things will disable Faster. If you manage to enable them at 845The following things will disable Faster. If you manage to enable them at
585runtime, bad things will happen. 846runtime, bad things will happen. Enabling them at startup will be fine,
847though.
586 848
587 enabled tainting 849 enabled tainting
588 enabled debugging 850 enabled debugging
589 851
590This will dramatically reduce Faster's performance: 852Thread-enabled builds of perl will dramatically reduce Faster's
853performance, but you don't care about speed if you enable threads anyway.
591 854
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 855These constructs will force the use of the interpreter for the currently
595being executed, for the rest of the currently executed: 856executed function as soon as they are being encountered during execution.
596 857
597 .., ... (flipflop operators)
598 goto 858 goto
599 next, redo (but not well-behaved last's) 859 next, redo (but not well-behaved last's)
600 eval 860 eval
601 require 861 require
602 any use of formats 862 any use of formats
863 .., ... (flipflop operators)
603 864
604=head1 AUTHOR 865=head1 AUTHOR
605 866
606 Marc Lehmann <schmorp@schmorp.de> 867 Marc Lehmann <schmorp@schmorp.de>
607 http://home.schmorp.de/ 868 http://home.schmorp.de/

Diff Legend

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