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

Diff Legend

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