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

Comparing Faster/Faster.pm (file contents):
Revision 1.16 by root, Fri Mar 10 18:58:31 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 {
… …
409 my ($idx) = @_; 489 my ($idx) = @_;
410 490
411 out_callop; 491 out_callop;
412 492
413 out_cond_jump $_->[$idx] 493 out_cond_jump $_->[$idx]
414 for reverse @loop; 494 for reverse @op_loop;
415 495
416 $source .= " return nextop;\n"; 496 $source .= " return nextop;\n";
417} 497}
418 498
419sub xop_next { 499sub xop_next {
… …
429} 509}
430 510
431sub cv2c { 511sub cv2c {
432 my ($cv) = @_; 512 my ($cv) = @_;
433 513
434 @loop = (); 514 local @ops;
515 local @op_loop;
516 local %op_regcomp;
435 517
436 my %opsseen; 518 my %opsseen;
437 my @todo = $cv->START; 519 my @todo = $cv->START;
520 my %op_target;
521 my $numpushmark;
438 522
439 while (my $op = shift @todo) { 523 while (my $op = shift @todo) {
440 for (; $$op; $op = $op->next) { 524 for (; $$op; $op = $op->next) {
441 last if $opsseen{$$op}++; 525 last if $opsseen{$$op}++;
442 push @ops, $op;
443 526
444 my $name = $op->name; 527 my $name = $op->name;
445 my $class = B::class $op; 528 my $class = B::class $op;
446 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
447 if ($class eq "LOGOP") { 542 if ($class eq "LOGOP") {
448 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
449 } elsif ($class eq "PMOP") { 552 } elsif ($class eq "PMOP") {
553 if (${$op->pmreplstart}) {
450 unshift @todo, $op->pmreplstart if ${$op->pmreplstart}; 554 unshift @todo, $op->pmreplstart;
555 $op_target{${$op->pmreplstart}}++;
556 }
557
451 } elsif ($class eq "LOOP") { 558 } elsif ($class eq "LOOP") {
452 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 }
453 } 573 }
454 } 574 }
455 } 575 }
576
577 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
456 578
457 local $source = <<EOF; 579 local $source = <<EOF;
458OP *%%%FUNC%%% (pTHX) 580OP *%%%FUNC%%% (pTHX)
459{ 581{
460 register OP *nextop = (OP *)${$ops[0]}L; 582 register OP *nextop = (OP *)${$ops[0]->{op}}L;
461EOF 583EOF
584
585 $source .= " faster_PUSHMARK_PREALLOC ($numpushmark);\n"
586 if $numpushmark;
462 587
463 while (@ops) { 588 while (@ops) {
464 $op = shift @ops; 589 $insn = shift @ops;
590
591 $op = $insn->{op};
465 $op_name = $op->name; 592 $op_name = $op->name;
466 593
594 my $class = B::class $op;
595
596 $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
467 $source .= "op_$$op: /* $op_name */\n"; 597 $source .= "op_$$op: /* $op_name */\n";
468 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d# 598 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
469 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d# 599 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
470 600
471 $source .= " PERL_ASYNC_CHECK ();\n" 601 $source .= " PERL_ASYNC_CHECK ();\n"
472 unless exists $flag{noasync}{$op_name}; 602 unless exists $f_noasync{$op_name};
473 603
474 if (my $can = __PACKAGE__->can ("op_$op_name")) { 604 if (my $can = __PACKAGE__->can ("op_$op_name")) {
475 # 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
476 $can->($op); 621 $can->($op);
477 622
478 } elsif (exists $flag{unsafe}{$op_name}) { 623 } elsif (exists $f_unsafe{$op_name}) {
479 # unsafe, return to interpreter 624 # unsafe, return to interpreter
480 assert "nextop == (OP *)$$op"; 625 assert "nextop == (OP *)$$op";
481 $source .= " return nextop;\n"; 626 $source .= " return nextop;\n";
482 627
483 } elsif ("LOGOP" eq B::class $op) { 628 } elsif ("LOGOP" eq $class) {
484 # logical operation with optionaö branch 629 # logical operation with optional branch
485 out_callop; 630 out_callop;
486 out_cond_jump $op->other; 631 out_cond_jump $op->other;
487 out_jump_next; 632 out_jump_next;
488 633
489 } elsif ("PMOP" eq B::class $op) { 634 } elsif ("PMOP" eq $class) {
490 # regex-thingy 635 # regex-thingy
491 out_callop; 636 out_callop;
492 out_cond_jump $op->pmreplroot if ${$op->pmreplroot}; 637 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
493 out_jump_next; 638 out_jump_next;
494 639
495 } else { 640 } else {
496 # normal operator, linear execution 641 # normal operator, linear execution
497 out_linear; 642 out_linear;
… …
508 #warn $source; 653 #warn $source;
509 654
510 $source 655 $source
511} 656}
512 657
658my $uid = "aaaaaaa0";
659my %so;
660
513sub source2ptr { 661sub func2ptr {
514 my ($source) = @_; 662 my (@func) = @_;
515 663
516 my $md5 = Digest::MD5::md5_hex $source; 664 #LOCK
517 $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: $!";
518 671
519 my $stem = "/tmp/$md5"; 672 my $meta = eval { Storable::fd_retrieve $meta_fh } || { version => 1 };
520 673
521 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
522 open FILE, ">:raw", "$stem.c"; 686 open my $fh, ">:raw", "$stem.c";
523 print FILE <<EOF; 687 print $fh <<EOF;
524#define PERL_NO_GET_CONTEXT 688#define PERL_NO_GET_CONTEXT
689#define PERL_CORE
525 690
526#include <assert.h> 691#include <assert.h>
527 692
528#include "EXTERN.h" 693#include "EXTERN.h"
529#include "perl.h" 694#include "perl.h"
530#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
531 704
532#define RUNOPS_TILL(op) \\ 705#define RUNOPS_TILL(op) \\
533 while (nextop != (op)) \\ 706 while (nextop != (op)) \\
534 { \\ 707 { \\
535 PERL_ASYNC_CHECK (); \\ 708 PERL_ASYNC_CHECK (); \\
536 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\ 709 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
537 } 710 }
538 711
539EOF 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;
540 print FILE $source; 719 print $fh $source;
720 $meta->{$f->{func}} = $f->{so} = $stem;
721 }
722
541 close FILE; 723 close $fh;
542 system "$COMPILE -o $stem$_o $stem.c"; 724 system "$COMPILE -o $stem$_o $stem.c";
725 unlink "$stem.c" unless $ENV{FASTER_DEBUG} > 0;
543 system "$LINK -o $stem$_so $stem$_o $LIBS"; 726 system "$LINK -o $stem$_so $stem$_o $LIBS";
727 unlink "$stem$_o";
544 } 728 }
545 729
546# warn $source; 730 for my $f (@func) {
731 my $stem = $f->{so};
732
547 my $so = DynaLoader::dl_load_file "$stem$_so" 733 my $so = ($so{$stem} ||= DynaLoader::dl_load_file "$stem$_so")
548 or die "$stem$_so: $!"; 734 or die "$stem$_so: $!";
549 735
550 DynaLoader::dl_find_symbol $so, "Faster_$md5" 736 #unlink "$stem$_so";
551 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)
552} 747}
748
749my %ignore;
553 750
554sub entersub { 751sub entersub {
555 my ($cv) = @_; 752 my ($cv) = @_;
556 753
557 # always compile the whole stash 754 my $pkg = $cv->STASH->NAME;
558# my @stash = $cv->STASH->ARRAY; 755
559# warn join ":", @stash; 756 return if $ignore{$pkg};
560# exit; 757
758 warn "optimising ", $cv->STASH->NAME, "\n"
759 if $verbose;
561 760
562 eval { 761 eval {
762 my @func;
763
764 push @func, {
765 cv => $cv,
766 name => "<>",
563 my $source = cv2c $cv; 767 source => cv2c $cv,
768 };
564 769
565 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;
566 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) {
567 patch_cv $cv, $ptr; 793 patch_cv $f->{cv}, $f->{ptr};
794 }
568 }; 795 };
569 796
570 warn $@ if $@; 797 if ($@) {
798 $ignore{$pkg}++;
799 warn $@;
800 }
571} 801}
572 802
573hook_entersub; 803hook_entersub;
574 804
5751; 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.
576 836
577=back 837=back
578 838
579=head1 BUGS/LIMITATIONS 839=head1 BUGS/LIMITATIONS
580 840
581Perl will check much less often for asynchronous signals in 841Perl will check much less often for asynchronous signals in
582Faster-compiled code. It tries to check on every function call, loop 842Faster-compiled code. It tries to check on every function call, loop
583iteration and every I/O operator, though. 843iteration and every I/O operator, though.
584 844
585The 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
586runtime, bad things will happen. 846runtime, bad things will happen. Enabling them at startup will be fine,
847though.
587 848
588 enabled tainting 849 enabled tainting
589 enabled debugging 850 enabled debugging
590 851
591This 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.
592 854
593 threads (but you don't care about speed if you use threads anyway)
594
595These 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
596being executed, for the rest of the currently executed: 856executed function as soon as they are being encountered during execution.
597 857
598 .., ... (flipflop operators)
599 goto 858 goto
600 next, redo (but not well-behaved last's) 859 next, redo (but not well-behaved last's)
601 eval 860 eval
602 require 861 require
603 any use of formats 862 any use of formats
863 .., ... (flipflop operators)
604 864
605=head1 AUTHOR 865=head1 AUTHOR
606 866
607 Marc Lehmann <schmorp@schmorp.de> 867 Marc Lehmann <schmorp@schmorp.de>
608 http://home.schmorp.de/ 868 http://home.schmorp.de/

Diff Legend

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