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

Comparing Faster/Faster.pm (file contents):
Revision 1.12 by root, Fri Mar 10 18:39:26 2006 UTC vs.
Revision 1.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};
34my $_so = ".so"; 70my $_so = ".so";
35 71
36my $opt_assert = 1; 72# we don't need no steenking PIC on x86
73$COMPILE =~ s/-f(?:PIC|pic)//g
74 if $Config{archname} =~ /^(i[3456]86)-/;
75
76my $opt_assert = $ENV{FASTER_DEBUG} > 1;
77my $verbose = $ENV{FASTER_VERBOSE}+0;
78
79warn "Faster: CACHEDIR is $CACHEDIR\n" if $verbose > 2;
37 80
38our $source; 81our $source;
39 82
40my @ops; 83our @ops;
41my $op; 84our $insn;
85our $op;
42my $op_name; 86our $op_name;
43my @loop; 87our @op_loop;
88our %op_regcomp;
44 89
45my %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);
46 98
47# complex flag steting is no longer required, rewrite this ugly code 99# ops with known stack extend behaviour
48for (split /\n/, <<EOF) { 100# the values given are maximum values
49 leavesub unsafe 101my %extend = (
50 leavesublv unsafe 102 pushmark => 0,
51 return unsafe 103 nextstate => 0, # might reduce the stack
52 flip unsafe 104 unstack => 0,
53 goto unsafe 105 enter => 0,
54 last unsafe
55 redo unsafe
56 next unsafe
57 eval unsafe
58 leaveeval unsafe
59 entertry unsafe
60 formline unsafe
61 grepstart unsafe
62 mapstart unsafe
63 substcont unsafe
64 entereval unsafe noasync todo
65 require unsafe
66 106
67 mapstart noasync 107 stringify => 0,
68 grepstart noasync 108 not => 0,
69 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);
70 144
71 last noasync 145# ops that do not need an ASYNC_CHECK
72 next noasync 146my %f_noasync = map +($_ => undef), qw(
73 redo noasync 147 mapstart grepstart match entereval
74 seq noasync 148 enteriter entersub leaveloop
75 pushmark noasync extend=0
76 padsv noasync extend=1
77 padav noasync extend=1
78 padhv noasync extend=1
79 padany noasync extend=1
80 entersub noasync
81 aassign noasync
82 sassign noasync
83 rv2av noasync
84 rv2cv noasync
85 rv2gv noasync
86 rv2hv noasync
87 refgen noasync
88 nextstate noasync
89 gv noasync
90 gvsv noasync
91 add noasync
92 subtract noasync
93 multiply noasync
94 divide noasync
95 complement noasync
96 cond_expr noasync
97 and noasync
98 or noasync
99 not noasync
100 defined noasync
101 method_named noasync
102 preinc noasync
103 postinc noasync
104 predec noasync
105 postdec noasync
106 stub noasync
107 unstack noasync
108 leaveloop noasync
109 aelem noasync
110 aelemfast noasync
111 helem noasync
112 pushre noasync
113 subst noasync
114 const noasync extend=1
115 list noasync
116 join noasync
117 split noasync
118 concat noasync
119 push noasync
120 pop noasync
121 shift noasync
122 unshift noasync
123 length noasync
124 substr noasync
125 stringify noasync
126 eq noasync
127 ne noasync
128 gt noasync
129 lt noasync
130 ge noasync
131 le noasync
132 enteriter noasync
133 ord noasync
134 149
135 iter async 150 pushmark nextstate caller
136EOF
137 my (undef, $op, @flags) = split /\s+/;
138 151
139 undef $flag{$_}{$op} 152 const stub unstack
140 for ("known", @flags); 153 last next redo goto seq
141} 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);
142 171
143my %callop = ( 172my %callop = (
144 entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)", 173 entersub => "(PL_op->op_ppaddr) (aTHX)",
145 mapstart => "Perl_pp_grepstart (aTHX)", 174 mapstart => "Perl_pp_grepstart (aTHX)",
146); 175);
147 176
148sub callop { 177sub callop {
149 $callop{$op_name} || "Perl_pp_$op_name (aTHX)" 178 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
… …
157sub out_callop { 186sub out_callop {
158 assert "nextop == (OP *)$$op"; 187 assert "nextop == (OP *)$$op";
159 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n"; 188 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
160} 189}
161 190
191sub out_cond_jump {
192 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
193}
194
162sub out_jump_next { 195sub out_jump_next {
196 out_cond_jump $op_regcomp{$$op}
197 if $op_regcomp{$$op};
198
163 assert "nextop == (OP *)${$op->next}"; 199 assert "nextop == (OP *)${$op->next}";
164 $source .= " goto op_${$op->next};\n"; 200 $source .= " goto op_${$op->next};\n";
165} 201}
166 202
167sub out_next { 203sub out_next {
… …
171} 207}
172 208
173sub out_linear { 209sub out_linear {
174 out_callop; 210 out_callop;
175 out_jump_next; 211 out_jump_next;
176}
177
178sub out_cond_jump {
179 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
180} 212}
181 213
182sub op_entersub { 214sub op_entersub {
183 out_callop; 215 out_callop;
184 $source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n"; 216 $source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n";
… …
194 226
195 out_next; 227 out_next;
196} 228}
197 229
198sub op_pushmark { 230sub op_pushmark {
199 $source .= " PUSHMARK (PL_stack_sp);\n"; 231 $source .= " faster_PUSHMARK (PL_stack_sp);\n";
200 232
201 out_next; 233 out_next;
202} 234}
203 235
204if (0 && $Config{useithreads} ne "define") { 236if ($Config{useithreads} ne "define") {
205 # disable optimisations on ithreads 237 # disable optimisations on ithreads
206 238
207 *op_const = sub { 239 *op_const = sub {
208 $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#
209 243
210 out_next; 244 out_next;
211 }; 245 };
212 246
213 *op_gv = \&op_const; 247 *op_gv = \&op_const;
… …
233 if (!($op->flags & B::OPf_MOD)) { 267 if (!($op->flags & B::OPf_MOD)) {
234 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n"; 268 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
235 } 269 }
236 270
237 $source .= " dSP;\n"; 271 $source .= " dSP;\n";
238 $source .= " XPUSHs (sv);\n"; 272 $source .= " PUSHs (sv);\n";
239 $source .= " PUTBACK;\n"; 273 $source .= " PUTBACK;\n";
240 $source .= " }\n"; 274 $source .= " }\n";
241 275
242 out_next; 276 out_next;
243 }; 277 };
244 278
245 *op_gvsv = sub { 279 *op_gvsv = sub {
246 $source .= " {\n"; 280 $source .= " {\n";
247 $source .= " dSP;\n"; 281 $source .= " dSP;\n";
248 $source .= " EXTEND (SP, 1);\n";
249 282
250 if ($op->private & B::OPpLVAL_INTRO) { 283 if ($op->private & B::OPpLVAL_INTRO) {
251 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n"; 284 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
252 } else { 285 } else {
253 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n"; 286 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
… …
313 out_next; 346 out_next;
314} 347}
315 348
316sub op_padsv { 349sub op_padsv {
317 my $flags = $op->flags; 350 my $flags = $op->flags;
318 my $target = $op->targ; 351 my $padofs = "(PADOFFSET)" . $op->targ;
319 352
320 $source .= <<EOF; 353 $source .= <<EOF;
321 { 354 {
322 dSP; 355 dSP;
323 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);
324 PUTBACK; 366 PUTBACK;
325EOF 367EOF
326 if ($op->flags & B::OPf_MOD) { 368
327 if ($op->private & B::OPpLVAL_INTRO) { 369 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
328 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n"; 370 $source .= " if (!SvROK (sv)) vivify_ref (sv, " . $op->private . " & OPpDEREF);\n";
329 } elsif ($op->private & B::OPpDEREF) {
330 my $deref = $op->private & B::OPpDEREF;
331 $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
332 }
333 } 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
334 $source .= <<EOF; 393 $source .= <<EOF;
394 SETs (right);
395 PUTBACK;
335 } 396 }
336EOF 397EOF
337 398
338 out_next; 399 out_next;
339} 400}
340 401
341# pattern const+ (or general push1) 402# pattern const+ (or general push1)
342# pattern pushmark return(?)
343# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 403# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
344 404
345# pattern const method_named
346sub op_method_named { 405sub op_method_named {
406 if ($insn->{follows_const}) {
347 $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;
348 { 431 {
349 static HV *last_stash; 432 static HV *last_stash;
350 static SV *last_cv; 433 static SV *last_cv;
351 static U32 last_sub_generation; 434 static U32 last_sub_generation;
352 435
… …
359 442
360 /* simple "polymorphic" inline cache */ 443 /* simple "polymorphic" inline cache */
361 if (stash == last_stash 444 if (stash == last_stash
362 && PL_sub_generation == last_sub_generation) 445 && PL_sub_generation == last_sub_generation)
363 { 446 {
364 XPUSHs (last_cv); 447 PUSHs (last_cv);
365 PUTBACK; 448 PUTBACK;
366 } 449 }
367 else 450 else
368 { 451 {
369 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 452 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
… …
379 /* error case usually */ 462 /* error case usually */
380 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 463 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
381 } 464 }
382 } 465 }
383EOF 466EOF
467 }
384 468
385 out_next; 469 out_next;
386} 470}
387 471
388sub op_grepstart { 472sub op_grepstart {
389 out_callop; 473 out_callop;
474 $op = $op->next;
390 out_cond_jump $op->next->other; 475 out_cond_jump $op->other;
391 out_jump_next; 476 out_jump_next;
392} 477}
393 478
394*op_mapstart = \&op_grepstart; 479*op_mapstart = \&op_grepstart;
395 480
… …
404 my ($idx) = @_; 489 my ($idx) = @_;
405 490
406 out_callop; 491 out_callop;
407 492
408 out_cond_jump $_->[$idx] 493 out_cond_jump $_->[$idx]
409 for reverse @loop; 494 for reverse @op_loop;
410 495
411 $source .= " return nextop;\n"; 496 $source .= " return nextop;\n";
412} 497}
413 498
414sub xop_next { 499sub xop_next {
… …
424} 509}
425 510
426sub cv2c { 511sub cv2c {
427 my ($cv) = @_; 512 my ($cv) = @_;
428 513
429 @loop = (); 514 local @ops;
515 local @op_loop;
516 local %op_regcomp;
430 517
431 my %opsseen; 518 my %opsseen;
432 my @todo = $cv->START; 519 my @todo = $cv->START;
520 my %op_target;
521 my $numpushmark;
433 522
434 while (my $op = shift @todo) { 523 while (my $op = shift @todo) {
435 for (; $$op; $op = $op->next) { 524 for (; $$op; $op = $op->next) {
436 last if $opsseen{$$op}++; 525 last if $opsseen{$$op}++;
437 push @ops, $op;
438 526
439 my $name = $op->name; 527 my $name = $op->name;
440 my $class = B::class $op; 528 my $class = B::class $op;
441 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
442 if ($class eq "LOGOP") { 542 if ($class eq "LOGOP") {
443 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
444 } elsif ($class eq "PMOP") { 552 } elsif ($class eq "PMOP") {
553 if (${$op->pmreplstart}) {
445 unshift @todo, $op->pmreplstart if ${$op->pmreplstart}; 554 unshift @todo, $op->pmreplstart;
555 $op_target{${$op->pmreplstart}}++;
556 }
557
446 } elsif ($class eq "LOOP") { 558 } elsif ($class eq "LOOP") {
447 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 }
448 } 573 }
449 } 574 }
450 } 575 }
576
577 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
451 578
452 local $source = <<EOF; 579 local $source = <<EOF;
453OP *%%%FUNC%%% (pTHX) 580OP *%%%FUNC%%% (pTHX)
454{ 581{
455 register OP *nextop = (OP *)${$ops[0]}L; 582 register OP *nextop = (OP *)${$ops[0]->{op}}L;
456EOF 583EOF
584
585 $source .= " faster_PUSHMARK_PREALLOC ($numpushmark);\n"
586 if $numpushmark;
457 587
458 while (@ops) { 588 while (@ops) {
459 $op = shift @ops; 589 $insn = shift @ops;
590
591 $op = $insn->{op};
460 $op_name = $op->name; 592 $op_name = $op->name;
461 593
594 my $class = B::class $op;
595
596 $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
462 $source .= "op_$$op: /* $op_name */\n"; 597 $source .= "op_$$op: /* $op_name */\n";
463 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d# 598 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
464 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d# 599 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
465 600
466 $source .= " PERL_ASYNC_CHECK ();\n" 601 $source .= " PERL_ASYNC_CHECK ();\n"
467 unless exists $flag{noasync}{$op_name}; 602 unless exists $f_noasync{$op_name};
468 603
469 if (my $can = __PACKAGE__->can ("op_$op_name")) { 604 if (my $can = __PACKAGE__->can ("op_$op_name")) {
470 # 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
471 $can->($op); 621 $can->($op);
472 622
473 } elsif (exists $flag{unsafe}{$op_name}) { 623 } elsif (exists $f_unsafe{$op_name}) {
474 # unsafe, return to interpreter 624 # unsafe, return to interpreter
475 assert "nextop == (OP *)$$op"; 625 assert "nextop == (OP *)$$op";
476 $source .= " return nextop;\n"; 626 $source .= " return nextop;\n";
477 627
478 } elsif ("LOGOP" eq B::class $op) { 628 } elsif ("LOGOP" eq $class) {
479 # logical operation with optionaö branch 629 # logical operation with optional branch
480 out_callop; 630 out_callop;
481 out_cond_jump $op->other; 631 out_cond_jump $op->other;
482 out_jump_next; 632 out_jump_next;
483 633
484 } elsif ("PMOP" eq B::class $op) { 634 } elsif ("PMOP" eq $class) {
485 # regex-thingy 635 # regex-thingy
486 out_callop; 636 out_callop;
487 out_cond_jump $op->pmreplroot if ${$op->pmreplroot}; 637 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
488 out_jump_next; 638 out_jump_next;
489 639
490 } else { 640 } else {
491 # normal operator, linear execution 641 # normal operator, linear execution
492 out_linear; 642 out_linear;
… …
503 #warn $source; 653 #warn $source;
504 654
505 $source 655 $source
506} 656}
507 657
658my $uid = "aaaaaaa0";
659my %so;
660
508sub source2ptr { 661sub func2ptr {
509 my ($source) = @_; 662 my (@func) = @_;
510 663
511 my $md5 = Digest::MD5::md5_hex $source; 664 #LOCK
512 $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: $!";
513 671
514 my $stem = "/tmp/$md5"; 672 my $meta = eval { Storable::fd_retrieve $meta_fh } || { version => 1 };
515 673
516 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
517 open FILE, ">:raw", "$stem.c"; 686 open my $fh, ">:raw", "$stem.c";
518 print FILE <<EOF; 687 print $fh <<EOF;
519#define PERL_NO_GET_CONTEXT 688#define PERL_NO_GET_CONTEXT
689#define PERL_CORE
520 690
521#include <assert.h> 691#include <assert.h>
522 692
523#include "EXTERN.h" 693#include "EXTERN.h"
524#include "perl.h" 694#include "perl.h"
525#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
526 704
527#define RUNOPS_TILL(op) \\ 705#define RUNOPS_TILL(op) \\
528 while (nextop != (op)) \\ 706 while (nextop != (op)) \\
529 { \\ 707 { \\
530 PERL_ASYNC_CHECK (); \\ 708 PERL_ASYNC_CHECK (); \\
531 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\ 709 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
532 } 710 }
533 711
534EOF 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;
535 print FILE $source; 719 print $fh $source;
720 $meta->{$f->{func}} = $f->{so} = $stem;
721 }
722
536 close FILE; 723 close $fh;
537 system "$COMPILE -o $stem$_o $stem.c"; 724 system "$COMPILE -o $stem$_o $stem.c";
725 unlink "$stem.c" unless $ENV{FASTER_DEBUG} > 0;
538 system "$LINK -o $stem$_so $stem$_o $LIBS"; 726 system "$LINK -o $stem$_so $stem$_o $LIBS";
727 unlink "$stem$_o";
539 } 728 }
540 729
541# warn $source; 730 for my $f (@func) {
731 my $stem = $f->{so};
732
542 my $so = DynaLoader::dl_load_file "$stem$_so" 733 my $so = ($so{$stem} ||= DynaLoader::dl_load_file "$stem$_so")
543 or die "$stem$_so: $!"; 734 or die "$stem$_so: $!";
544 735
545 DynaLoader::dl_find_symbol $so, "Faster_$md5" 736 #unlink "$stem$_so";
546 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)
547} 747}
748
749my %ignore;
548 750
549sub entersub { 751sub entersub {
550 my ($cv) = @_; 752 my ($cv) = @_;
551 753
552 # always compile the whole stash 754 my $pkg = $cv->STASH->NAME;
553# my @stash = $cv->STASH->ARRAY; 755
554# warn join ":", @stash; 756 return if $ignore{$pkg};
555# exit; 757
758 warn "optimising ", $cv->STASH->NAME, "\n"
759 if $verbose;
556 760
557 eval { 761 eval {
762 my @func;
763
764 push @func, {
765 cv => $cv,
766 name => "<>",
558 my $source = cv2c $cv; 767 source => cv2c $cv,
768 };
559 769
560 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;
561 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) {
562 patch_cv $cv, $ptr; 793 patch_cv $f->{cv}, $f->{ptr};
794 }
563 }; 795 };
564 796
565 warn $@ if $@; 797 if ($@) {
798 $ignore{$pkg}++;
799 warn $@;
800 }
566} 801}
567 802
568hook_entersub; 803hook_entersub;
569 804
5701; 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.
571 836
572=back 837=back
573 838
574=head1 BUGS/LIMITATIONS 839=head1 BUGS/LIMITATIONS
575 840
576Perl will check much less often for asynchronous signals in 841Perl will check much less often for asynchronous signals in
577Faster-compiled code. It tries to check on every function call, loop 842Faster-compiled code. It tries to check on every function call, loop
578iteration and every I/O operator, though. 843iteration and every I/O operator, though.
579 844
580The 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
581runtime, bad things will happen. 846runtime, bad things will happen. Enabling them at startup will be fine,
847though.
582 848
583 enabled tainting 849 enabled tainting
584 enabled debugging 850 enabled debugging
585 851
586This 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.
587 854
588 threads (but you don't care about speed if you use threads anyway)
589
590These constructs will force the use of the interpreter as soon as they are 855These constructs will force the use of the interpreter for the currently
591being executed, for the rest of the currently executed: 856executed function as soon as they are being encountered during execution.
592 857
593 .., ... (flipflop operators)
594 goto 858 goto
595 next, redo (but not well-behaved last's) 859 next, redo (but not well-behaved last's)
596 eval 860 eval
597 require 861 require
598 any use of formats 862 any use of formats
863 .., ... (flipflop operators)
599 864
600=head1 AUTHOR 865=head1 AUTHOR
601 866
602 Marc Lehmann <schmorp@schmorp.de> 867 Marc Lehmann <schmorp@schmorp.de>
603 http://home.schmorp.de/ 868 http://home.schmorp.de/

Diff Legend

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