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

Diff Legend

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