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

Diff Legend

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