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

Diff Legend

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