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

Comparing Faster/Faster.pm (file contents):
Revision 1.20 by root, Fri Mar 10 22:32:15 2006 UTC vs.
Revision 1.36 by root, Sat Feb 21 08:27:38 2009 UTC

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

Diff Legend

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