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

Comparing Faster/Faster.pm (file contents):
Revision 1.13 by root, Fri Mar 10 18:53:49 2006 UTC vs.
Revision 1.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};
… …
35 75
36# we don't need no steenking PIC on x86 76# we don't need no steenking PIC on x86
37$COMPILE =~ s/-f(?:PIC|pic)//g 77$COMPILE =~ s/-f(?:PIC|pic)//g
38 if $Config{archname} =~ /^(i[3456]86)-/; 78 if $Config{archname} =~ /^(i[3456]86)-/;
39 79
40my $opt_assert = 1; 80my $opt_assert = $ENV{FASTER_DEBUG} > 1;
81my $verbose = $ENV{FASTER_VERBOSE}+0;
82
83warn "Faster: CACHEDIR is $CACHEDIR\n" if $verbose > 2;
41 84
42our $source; 85our $source;
43 86
44my @ops; 87our @ops;
45my $op; 88our $insn;
89our $op;
46my $op_name; 90our $op_name;
47my @loop; 91our @op_loop;
92our %op_regcomp;
48 93
49my %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);
50 102
51# complex flag steting is no longer required, rewrite this ugly code 103# ops with known stack extend behaviour
52for (split /\n/, <<EOF) { 104# the values given are maximum values
53 leavesub unsafe 105my %extend = (
54 leavesublv unsafe 106 pushmark => 0,
55 return unsafe 107 nextstate => 0, # might reduce the stack
56 flip unsafe 108 unstack => 0,
57 goto unsafe 109 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 110
71 mapstart noasync 111 stringify => 0,
72 grepstart noasync 112 not => 0,
73 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);
74 148
75 last noasync 149# ops that do not need an ASYNC_CHECK
76 next noasync 150my %f_noasync = map +($_ => undef), qw(
77 redo noasync 151 mapstart grepstart match entereval
78 seq noasync 152 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 153
139 iter async 154 pushmark nextstate caller
140EOF
141 my (undef, $op, @flags) = split /\s+/;
142 155
143 undef $flag{$_}{$op} 156 const stub unstack
144 for ("known", @flags); 157 last next redo goto seq
145} 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);
146 175
147my %callop = ( 176my %callop = (
148 entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)", 177 entersub => "(PL_op->op_ppaddr) (aTHX)",
149 mapstart => "Perl_pp_grepstart (aTHX)", 178 mapstart => "Perl_pp_grepstart (aTHX)",
150); 179);
151 180
152sub callop { 181sub callop {
153 $callop{$op_name} || "Perl_pp_$op_name (aTHX)" 182 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
… …
161sub out_callop { 190sub out_callop {
162 assert "nextop == (OP *)$$op"; 191 assert "nextop == (OP *)$$op";
163 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n"; 192 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
164} 193}
165 194
195sub out_cond_jump {
196 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
197}
198
166sub out_jump_next { 199sub out_jump_next {
200 out_cond_jump $op_regcomp{$$op}
201 if $op_regcomp{$$op};
202
167 assert "nextop == (OP *)${$op->next}"; 203 assert "nextop == (OP *)${$op->next}";
168 $source .= " goto op_${$op->next};\n"; 204 $source .= " goto op_${$op->next};\n";
169} 205}
170 206
171sub out_next { 207sub out_next {
… …
175} 211}
176 212
177sub out_linear { 213sub out_linear {
178 out_callop; 214 out_callop;
179 out_jump_next; 215 out_jump_next;
180}
181
182sub out_cond_jump {
183 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
184} 216}
185 217
186sub op_entersub { 218sub op_entersub {
187 out_callop; 219 out_callop;
188 $source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n"; 220 $source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n";
… …
198 230
199 out_next; 231 out_next;
200} 232}
201 233
202sub op_pushmark { 234sub op_pushmark {
203 $source .= " PUSHMARK (PL_stack_sp);\n"; 235 $source .= " faster_PUSHMARK (PL_stack_sp);\n";
204 236
205 out_next; 237 out_next;
206} 238}
207 239
208if ($Config{useithreads} ne "define") { 240if ($Config{useithreads} ne "define") {
209 # disable optimisations on ithreads 241 # disable optimisations on ithreads
210 242
211 *op_const = sub { 243 *op_const = sub {
212 $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#
213 247
214 out_next; 248 out_next;
215 }; 249 };
216 250
217 *op_gv = \&op_const; 251 *op_gv = \&op_const;
… …
237 if (!($op->flags & B::OPf_MOD)) { 271 if (!($op->flags & B::OPf_MOD)) {
238 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n"; 272 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
239 } 273 }
240 274
241 $source .= " dSP;\n"; 275 $source .= " dSP;\n";
242 $source .= " XPUSHs (sv);\n"; 276 $source .= " PUSHs (sv);\n";
243 $source .= " PUTBACK;\n"; 277 $source .= " PUTBACK;\n";
244 $source .= " }\n"; 278 $source .= " }\n";
245 279
246 out_next; 280 out_next;
247 }; 281 };
248 282
249 *op_gvsv = sub { 283 *op_gvsv = sub {
250 $source .= " {\n"; 284 $source .= " {\n";
251 $source .= " dSP;\n"; 285 $source .= " dSP;\n";
252 $source .= " EXTEND (SP, 1);\n";
253 286
254 if ($op->private & B::OPpLVAL_INTRO) { 287 if ($op->private & B::OPpLVAL_INTRO) {
255 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n"; 288 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
256 } else { 289 } else {
257 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n"; 290 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
… …
317 out_next; 350 out_next;
318} 351}
319 352
320sub op_padsv { 353sub op_padsv {
321 my $flags = $op->flags; 354 my $flags = $op->flags;
322 my $target = $op->targ; 355 my $padofs = "(PADOFFSET)" . $op->targ;
323 356
324 $source .= <<EOF; 357 $source .= <<EOF;
325 { 358 {
326 dSP; 359 dSP;
327 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);
328 PUTBACK; 370 PUTBACK;
329EOF 371EOF
330 if ($op->flags & B::OPf_MOD) { 372
331 if ($op->private & B::OPpLVAL_INTRO) { 373 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
332 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n"; 374 $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 } 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
338 $source .= <<EOF; 397 $source .= <<EOF;
398 SETs (right);
399 PUTBACK;
339 } 400 }
340EOF 401EOF
341 402
342 out_next; 403 out_next;
343} 404}
344 405
345# pattern const+ (or general push1) 406# pattern const+ (or general push1)
346# pattern pushmark return(?)
347# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 407# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
348 408
349# pattern const method_named
350sub op_method_named { 409sub op_method_named {
410 if ($insn->{follows_const}) {
351 $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;
352 { 435 {
353 static HV *last_stash; 436 static HV *last_stash;
354 static SV *last_cv; 437 static SV *last_cv;
355 static U32 last_sub_generation; 438 static U32 last_sub_generation;
356 439
… …
363 446
364 /* simple "polymorphic" inline cache */ 447 /* simple "polymorphic" inline cache */
365 if (stash == last_stash 448 if (stash == last_stash
366 && PL_sub_generation == last_sub_generation) 449 && PL_sub_generation == last_sub_generation)
367 { 450 {
368 XPUSHs (last_cv); 451 PUSHs (last_cv);
369 PUTBACK; 452 PUTBACK;
370 } 453 }
371 else 454 else
372 { 455 {
373 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 456 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
… …
383 /* error case usually */ 466 /* error case usually */
384 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 467 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
385 } 468 }
386 } 469 }
387EOF 470EOF
471 }
388 472
389 out_next; 473 out_next;
390} 474}
391 475
392sub op_grepstart { 476sub op_grepstart {
393 out_callop; 477 out_callop;
478 $op = $op->next;
394 out_cond_jump $op->next->other; 479 out_cond_jump $op->other;
395 out_jump_next; 480 out_jump_next;
396} 481}
397 482
398*op_mapstart = \&op_grepstart; 483*op_mapstart = \&op_grepstart;
399 484
… …
408 my ($idx) = @_; 493 my ($idx) = @_;
409 494
410 out_callop; 495 out_callop;
411 496
412 out_cond_jump $_->[$idx] 497 out_cond_jump $_->[$idx]
413 for reverse @loop; 498 for reverse @op_loop;
414 499
415 $source .= " return nextop;\n"; 500 $source .= " return nextop;\n";
416} 501}
417 502
418sub xop_next { 503sub xop_next {
… …
428} 513}
429 514
430sub cv2c { 515sub cv2c {
431 my ($cv) = @_; 516 my ($cv) = @_;
432 517
433 @loop = (); 518 local @ops;
519 local @op_loop;
520 local %op_regcomp;
434 521
435 my %opsseen; 522 my %opsseen;
436 my @todo = $cv->START; 523 my @todo = $cv->START;
524 my %op_target;
525 my $numpushmark;
437 526
438 while (my $op = shift @todo) { 527 while (my $op = shift @todo) {
439 for (; $$op; $op = $op->next) { 528 for (; $$op; $op = $op->next) {
440 last if $opsseen{$$op}++; 529 last if $opsseen{$$op}++;
441 push @ops, $op;
442 530
443 my $name = $op->name; 531 my $name = $op->name;
444 my $class = B::class $op; 532 my $class = B::class $op;
445 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
446 if ($class eq "LOGOP") { 546 if ($class eq "LOGOP") {
447 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
448 } elsif ($class eq "PMOP") { 556 } elsif ($class eq "PMOP") {
557 if (${$op->pmreplstart}) {
449 unshift @todo, $op->pmreplstart if ${$op->pmreplstart}; 558 unshift @todo, $op->pmreplstart;
559 $op_target{${$op->pmreplstart}}++;
560 }
561
450 } elsif ($class eq "LOOP") { 562 } elsif ($class eq "LOOP") {
451 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 }
452 } 577 }
453 } 578 }
454 } 579 }
580
581 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
455 582
456 local $source = <<EOF; 583 local $source = <<EOF;
457OP *%%%FUNC%%% (pTHX) 584OP *%%%FUNC%%% (pTHX)
458{ 585{
459 register OP *nextop = (OP *)${$ops[0]}L; 586 register OP *nextop = (OP *)${$ops[0]->{op}}L;
460EOF 587EOF
588
589 $source .= " faster_PUSHMARK_PREALLOC ($numpushmark);\n"
590 if $numpushmark;
461 591
462 while (@ops) { 592 while (@ops) {
463 $op = shift @ops; 593 $insn = shift @ops;
594
595 $op = $insn->{op};
464 $op_name = $op->name; 596 $op_name = $op->name;
465 597
598 my $class = B::class $op;
599
600 $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
466 $source .= "op_$$op: /* $op_name */\n"; 601 $source .= "op_$$op: /* $op_name */\n";
467 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d# 602 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
468 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d# 603 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
469 604
470 $source .= " PERL_ASYNC_CHECK ();\n" 605 $source .= " PERL_ASYNC_CHECK ();\n"
471 unless exists $flag{noasync}{$op_name}; 606 unless exists $f_noasync{$op_name};
472 607
473 if (my $can = __PACKAGE__->can ("op_$op_name")) { 608 if (my $can = __PACKAGE__->can ("op_$op_name")) {
474 # 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
475 $can->($op); 625 $can->($op);
476 626
477 } elsif (exists $flag{unsafe}{$op_name}) { 627 } elsif (exists $f_unsafe{$op_name}) {
478 # unsafe, return to interpreter 628 # unsafe, return to interpreter
479 assert "nextop == (OP *)$$op"; 629 assert "nextop == (OP *)$$op";
480 $source .= " return nextop;\n"; 630 $source .= " return nextop;\n";
481 631
482 } elsif ("LOGOP" eq B::class $op) { 632 } elsif ("LOGOP" eq $class) {
483 # logical operation with optionaö branch 633 # logical operation with optional branch
484 out_callop; 634 out_callop;
485 out_cond_jump $op->other; 635 out_cond_jump $op->other;
486 out_jump_next; 636 out_jump_next;
487 637
488 } elsif ("PMOP" eq B::class $op) { 638 } elsif ("PMOP" eq $class) {
489 # regex-thingy 639 # regex-thingy
490 out_callop; 640 out_callop;
491 out_cond_jump $op->pmreplroot if ${$op->pmreplroot}; 641 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
492 out_jump_next; 642 out_jump_next;
493 643
494 } else { 644 } else {
495 # normal operator, linear execution 645 # normal operator, linear execution
496 out_linear; 646 out_linear;
… …
507 #warn $source; 657 #warn $source;
508 658
509 $source 659 $source
510} 660}
511 661
662my $uid = "aaaaaaa0";
663my %so;
664
512sub source2ptr { 665sub func2ptr {
513 my ($source) = @_; 666 my (@func) = @_;
514 667
515 my $md5 = Digest::MD5::md5_hex $source; 668 #LOCK
516 $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: $!";
517 675
518 my $stem = "/tmp/$md5"; 676 my $meta = eval { Storable::fd_retrieve $meta_fh } || { version => 1 };
519 677
520 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
521 open FILE, ">:raw", "$stem.c"; 690 open my $fh, ">:raw", "$stem.c";
522 print FILE <<EOF; 691 print $fh <<EOF;
523#define PERL_NO_GET_CONTEXT 692#define PERL_NO_GET_CONTEXT
693#define PERL_CORE
524 694
525#include <assert.h> 695#include <assert.h>
526 696
527#include "EXTERN.h" 697#include "EXTERN.h"
528#include "perl.h" 698#include "perl.h"
529#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
530 708
531#define RUNOPS_TILL(op) \\ 709#define RUNOPS_TILL(op) \\
532 while (nextop != (op)) \\ 710 while (nextop != (op)) \\
533 { \\ 711 { \\
534 PERL_ASYNC_CHECK (); \\ 712 PERL_ASYNC_CHECK (); \\
535 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\ 713 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
536 } 714 }
537 715
538EOF 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;
539 print FILE $source; 723 print $fh $source;
724 $meta->{$f->{func}} = $f->{so} = $stem;
725 }
726
540 close FILE; 727 close $fh;
541 system "$COMPILE -o $stem$_o $stem.c"; 728 system "$COMPILE -o $stem$_o $stem.c";
729 unlink "$stem.c" unless $ENV{FASTER_DEBUG} > 0;
542 system "$LINK -o $stem$_so $stem$_o $LIBS"; 730 system "$LINK -o $stem$_so $stem$_o $LIBS";
731 unlink "$stem$_o";
543 } 732 }
544 733
545# warn $source; 734 for my $f (@func) {
735 my $stem = $f->{so};
736
546 my $so = DynaLoader::dl_load_file "$stem$_so" 737 my $so = ($so{$stem} ||= DynaLoader::dl_load_file "$stem$_so")
547 or die "$stem$_so: $!"; 738 or die "$stem$_so: $!";
548 739
549 DynaLoader::dl_find_symbol $so, "Faster_$md5" 740 #unlink "$stem$_so";
550 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)
551} 751}
752
753my %ignore;
552 754
553sub entersub { 755sub entersub {
554 my ($cv) = @_; 756 my ($cv) = @_;
555 757
556 # always compile the whole stash 758 my $pkg = $cv->STASH->NAME;
557# my @stash = $cv->STASH->ARRAY; 759
558# warn join ":", @stash; 760 return if $ignore{$pkg};
559# exit; 761
762 warn "optimising ", $cv->STASH->NAME, "\n"
763 if $verbose;
560 764
561 eval { 765 eval {
766 my @func;
767
768 push @func, {
769 cv => $cv,
770 name => "<>",
562 my $source = cv2c $cv; 771 source => cv2c $cv,
772 };
563 773
564 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;
565 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) {
566 patch_cv $cv, $ptr; 797 patch_cv $f->{cv}, $f->{ptr};
798 }
567 }; 799 };
568 800
569 warn $@ if $@; 801 if ($@) {
802 $ignore{$pkg}++;
803 warn $@;
804 }
570} 805}
571 806
572hook_entersub; 807hook_entersub;
573 808
5741; 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.
575 840
576=back 841=back
577 842
578=head1 BUGS/LIMITATIONS 843=head1 BUGS/LIMITATIONS
579 844
580Perl will check much less often for asynchronous signals in 845Perl will check much less often for asynchronous signals in
581Faster-compiled code. It tries to check on every function call, loop 846Faster-compiled code. It tries to check on every function call, loop
582iteration and every I/O operator, though. 847iteration and every I/O operator, though.
583 848
584The 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
585runtime, bad things will happen. 850runtime, bad things will happen. Enabling them at startup will be fine,
851though.
586 852
587 enabled tainting 853 enabled tainting
588 enabled debugging 854 enabled debugging
589 855
590This 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.
591 858
592 threads (but you don't care about speed if you use threads anyway)
593
594These constructs will force the use of the interpreter as soon as they are 859These constructs will force the use of the interpreter for the currently
595being executed, for the rest of the currently executed: 860executed function as soon as they are being encountered during execution.
596 861
597 .., ... (flipflop operators)
598 goto 862 goto
599 next, redo (but not well-behaved last's) 863 next, redo (but not well-behaved last's)
600 eval 864 eval
601 require 865 require
602 any use of formats 866 any use of formats
867 .., ... (flipflop operators)
603 868
604=head1 AUTHOR 869=head1 AUTHOR
605 870
606 Marc Lehmann <schmorp@schmorp.de> 871 Marc Lehmann <schmorp@schmorp.de>
607 http://home.schmorp.de/ 872 http://home.schmorp.de/

Diff Legend

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