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

Comparing Faster/Faster.pm (file contents):
Revision 1.22 by root, Fri Mar 10 22:41:47 2006 UTC vs.
Revision 1.34 by root, Wed Mar 15 02:32:27 2006 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 ();
45use File::Temp (); 56use Digest::MD5 ();
57use Storable ();
58use Fcntl ();
46 59
47BEGIN { 60BEGIN {
48 our $VERSION = '0.01'; 61 our $VERSION = '0.01';
49 62
50 require XSLoader; 63 require XSLoader;
51 XSLoader::load __PACKAGE__, $VERSION; 64 XSLoader::load __PACKAGE__, $VERSION;
52} 65}
53 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
54my $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}";
55my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}"; 76my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
56my $LIBS = "$Config{libs}"; 77my $LIBS = "";
57my $_o = $Config{_o}; 78my $_o = $Config{_o};
58my $_so = ".so"; 79my $_so = ".so";
59 80
60# we don't need no steenking PIC on x86 81# we don't need no steenking PIC on x86
61$COMPILE =~ s/-f(?:PIC|pic)//g 82$COMPILE =~ s/-f(?:PIC|pic)//g
62 if $Config{archname} =~ /^(i[3456]86)-/; 83 if $Config{archname} =~ /^(i[3456]86)-/;
63 84
64my $opt_assert = $ENV{FASTER_DEBUG}; 85my $opt_assert = $ENV{FASTER_DEBUG} & 2;
65my $verbose = $ENV{FASTER_VERBOSE}+0; 86my $verbose = $ENV{FASTER_VERBOSE}+0;
66 87
88warn "Faster: CACHEDIR is $CACHEDIR\n" if $verbose > 2;
89
67our $source; 90our $source;
68 91
69our @ops; 92our @ops;
93our $insn;
70our $op; 94our $op;
71our $op_name; 95our $op_name;
72our @op_loop;
73our %op_regcomp; 96our %op_regcomp;
74 97
98# ops that cause immediate return to the interpreter
75my %f_unsafe = map +($_ => undef), qw( 99my %f_unsafe = map +($_ => undef), qw(
76 leavesub leavesublv return 100 leavesub leavesublv return
77 goto last redo next 101 goto last redo next
78 eval flip leaveeval entertry 102 eval flip leaveeval entertry
79 formline grepstart mapstart 103 formline grepstart mapstart
80 substcont entereval require 104 substcont entereval require
81); 105);
82 106
83# pushmark extend=0 107# ops with known stack extend behaviour
84# padsv extend=1 108# the values given are maximum values
85# padav extend=1 109my %extend = (
86# padhv extend=1 110 pushmark => 0,
87# padany extend=1 111 nextstate => 0, # might reduce the stack
88# const extend=1 112 unstack => 0,
113 enter => 0,
89 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
90my %f_noasync = map +($_ => undef), qw( 154my %f_noasync = map +($_ => undef), qw(
91 mapstart grepstart match entereval 155 mapstart grepstart match entereval
92 enteriter entersub leaveloop 156 enteriter entersub leaveloop
93 157
94 pushmark nextstate 158 pushmark nextstate caller
95 159
96 const stub unstack 160 const stub unstack
97 last next redo seq 161 last next redo goto seq
98 padsv padav padhv padany 162 padsv padav padhv padany
99 aassign sassign orassign 163 aassign sassign orassign
100 rv2av rv2cv rv2gv rv2hv refgen 164 rv2av rv2cv rv2gv rv2hv refgen
101 gv gvsv 165 gv gvsv
102 add subtract multiply divide 166 add subtract multiply divide
103 complement cond_expr and or not 167 complement cond_expr and or not
168 bit_and bit_or bit_xor
104 defined 169 defined
105 method_named 170 method method_named bless
106 preinc postinc predec postdec 171 preinc postinc predec postdec
107 aelem aelemfast helem delete exists 172 aelem aelemfast helem delete exists
108 pushre subst list join split concat 173 pushre subst list lslice join split concat
109 length substr stringify ord 174 length substr stringify ord
110 push pop shift unshift 175 push pop shift unshift
111 eq ne gt lt ge le 176 eq ne gt lt ge le
112 regcomp regcreset regcmaybe 177 regcomp regcreset regcmaybe
113); 178);
114 179
115my %callop = ( 180my %callop = (
116 entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)", 181 entersub => "(PL_op->op_ppaddr) (aTHX)",
117 mapstart => "Perl_pp_grepstart (aTHX)", 182 mapstart => "Perl_pp_grepstart (aTHX)",
118); 183);
119 184
120sub callop { 185sub callop {
121 $callop{$op_name} || "Perl_pp_$op_name (aTHX)" 186 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
… …
127} 192}
128 193
129sub out_callop { 194sub out_callop {
130 assert "nextop == (OP *)$$op"; 195 assert "nextop == (OP *)$$op";
131 $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";
132} 202}
133 203
134sub out_cond_jump { 204sub out_cond_jump {
135 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n"; 205 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
136} 206}
… …
169 239
170 out_next; 240 out_next;
171} 241}
172 242
173sub op_pushmark { 243sub op_pushmark {
174 $source .= " PUSHMARK (PL_stack_sp);\n"; 244 $source .= " faster_PUSHMARK (PL_stack_sp);\n";
175 245
176 out_next; 246 out_next;
177} 247}
178 248
179if ($Config{useithreads} ne "define") { 249if ($Config{useithreads} ne "define") {
180 # disable optimisations on ithreads 250 # disable optimisations on ithreads
181 251
182 *op_const = sub { 252 *op_const = sub {
183 $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#
184 256
185 out_next; 257 out_next;
186 }; 258 };
187 259
188 *op_gv = \&op_const; 260 *op_gv = \&op_const;
… …
208 if (!($op->flags & B::OPf_MOD)) { 280 if (!($op->flags & B::OPf_MOD)) {
209 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n"; 281 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
210 } 282 }
211 283
212 $source .= " dSP;\n"; 284 $source .= " dSP;\n";
213 $source .= " XPUSHs (sv);\n"; 285 $source .= " PUSHs (sv);\n";
214 $source .= " PUTBACK;\n"; 286 $source .= " PUTBACK;\n";
215 $source .= " }\n"; 287 $source .= " }\n";
216 288
217 out_next; 289 out_next;
218 }; 290 };
219 291
220 *op_gvsv = sub { 292 *op_gvsv = sub {
221 $source .= " {\n"; 293 $source .= " {\n";
222 $source .= " dSP;\n"; 294 $source .= " dSP;\n";
223 $source .= " EXTEND (SP, 1);\n";
224 295
225 if ($op->private & B::OPpLVAL_INTRO) { 296 if ($op->private & B::OPpLVAL_INTRO) {
226 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n"; 297 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
227 } else { 298 } else {
228 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n"; 299 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
… …
288 out_next; 359 out_next;
289} 360}
290 361
291sub op_padsv { 362sub op_padsv {
292 my $flags = $op->flags; 363 my $flags = $op->flags;
293 my $targ = $op->targ; 364 my $padofs = "(PADOFFSET)" . $op->targ;
294 365
295 $source .= <<EOF; 366 $source .= <<EOF;
296 { 367 {
297 dSP; 368 dSP;
298 XPUSHs (PAD_SV ((PADOFFSET)$targ)); 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);
299 PUTBACK; 379 PUTBACK;
300EOF 380EOF
301 if ($op->flags & B::OPf_MOD) { 381
302 if ($op->private & B::OPpLVAL_INTRO) { 382 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
303 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$targ));\n"; 383 $source .= " if (!SvROK (sv)) vivify_ref (sv, " . $op->private . " & OPpDEREF);\n";
304 } elsif ($op->private & B::OPpDEREF) {
305 my $deref = $op->private & B::OPpDEREF;
306 $source .= " Perl_vivify_ref (aTHX_ PAD_SVl ((PADOFFSET)$targ), $deref);\n";
307 }
308 } 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
309 $source .= <<EOF; 406 $source .= <<EOF;
407 SETs (right);
408 PUTBACK;
310 } 409 }
311EOF 410EOF
312 411
313 out_next; 412 out_next;
314} 413}
315 414
316# pattern const+ (or general push1) 415# pattern const+ (or general push1)
317# pattern pushmark return(?)
318# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 416# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
319 417
320# pattern const method_named
321sub op_method_named { 418sub op_method_named {
419 if ($insn->{follows_const}) {
322 $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;
323 { 444 {
324 static HV *last_stash; 445 static HV *last_stash;
325 static SV *last_cv; 446 static SV *last_cv;
326 static U32 last_sub_generation; 447 static U32 last_sub_generation;
327 448
… …
334 455
335 /* simple "polymorphic" inline cache */ 456 /* simple "polymorphic" inline cache */
336 if (stash == last_stash 457 if (stash == last_stash
337 && PL_sub_generation == last_sub_generation) 458 && PL_sub_generation == last_sub_generation)
338 { 459 {
339 XPUSHs (last_cv); 460 PUSHs (last_cv);
340 PUTBACK; 461 PUTBACK;
341 } 462 }
342 else 463 else
343 { 464 {
344 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 465 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
… …
354 /* error case usually */ 475 /* error case usually */
355 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 476 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
356 } 477 }
357 } 478 }
358EOF 479EOF
480 }
359 481
360 out_next; 482 out_next;
361} 483}
362 484
363sub op_grepstart { 485sub op_grepstart {
… …
377} 499}
378 500
379sub out_break_op { 501sub out_break_op {
380 my ($idx) = @_; 502 my ($idx) = @_;
381 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];
382 out_callop; 507 out_callop;
383 508 out_jump $next;
384 out_cond_jump $_->[$idx] 509 } elsif (my $loop = $insn->{loop}) {
385 for reverse @op_loop; 510 # less common case: maybe break to some outer loop
386
387 $source .= " return nextop;\n"; 511 $source .= " return nextop;\n";
512 # todo: walk stack up
513 } else {
514 $source .= " return nextop;\n";
515 }
388} 516}
389 517
390sub xop_next { 518sub op_next {
391 out_break_op 0; 519 out_break_op 0;
392} 520}
393 521
394sub op_last { 522sub op_last {
395 out_break_op 1; 523 out_break_op 1;
… …
401 529
402sub cv2c { 530sub cv2c {
403 my ($cv) = @_; 531 my ($cv) = @_;
404 532
405 local @ops; 533 local @ops;
406 local @op_loop;
407 local %op_regcomp; 534 local %op_regcomp;
408 535
409 my %opsseen; 536 my $curloop;
410 my @todo = $cv->START; 537 my @todo = $cv->START;
538 my %op_target;
539 my $numpushmark;
540 my $scope;
411 541
542 my %op_seen;
412 while (my $op = shift @todo) { 543 while (my $op = shift @todo) {
544 my $next;
413 for (; $$op; $op = $op->next) { 545 for (; $$op; $op = $next) {
414 last if $opsseen{$$op}++; 546 last if $op_seen{$$op}++;
415 push @ops, $op; 547
548 $next = $op->next;
416 549
417 my $name = $op->name; 550 my $name = $op->name;
418 my $class = B::class $op; 551 my $class = B::class $op;
419 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(?)
420 if ($class eq "LOGOP") { 571 if ($class eq "LOGOP") {
421 unshift @todo, $op->other; # unshift vs. push saves jumps 572 push @todo, $op->other;
573 $op_target{${$op->other}}++;
422 574
423 # regcomp/o patches ops at runtime, lets expect that 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}}++;
424 $op_regcomp{${$op->first}} = $op->next 578 $op_regcomp{${$op->first}} = $op->next;
425 if $name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP; 579 }
426 580
427 } elsif ($class eq "PMOP") { 581 } elsif ($class eq "PMOP") {
582 if (${$op->pmreplstart}) {
428 unshift @todo, $op->pmreplstart if ${$op->pmreplstart}; 583 unshift @todo, $op->pmreplstart;
584 $op_target{${$op->pmreplstart}}++;
585 }
429 586
430 } elsif ($class eq "LOOP") { 587 } elsif ($class eq "LOOP") {
431 push @op_loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
432 push @todo, $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 }
433 } 608 }
434 } 609 }
435 } 610 }
611
612 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
436 613
437 local $source = <<EOF; 614 local $source = <<EOF;
438OP *%%%FUNC%%% (pTHX) 615OP *%%%FUNC%%% (pTHX)
439{ 616{
440 register OP *nextop = (OP *)${$ops[0]}L; 617 register OP *nextop = (OP *)${$ops[0]->{op}}L;
441EOF 618EOF
619
620 $source .= " faster_PUSHMARK_PREALLOC ($numpushmark);\n"
621 if $numpushmark;
442 622
443 while (@ops) { 623 while (@ops) {
444 $op = shift @ops; 624 $insn = shift @ops;
625
626 $op = $insn->{op};
445 $op_name = $op->name; 627 $op_name = $op->name;
446 628
629 my $class = B::class $op;
630
631 $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
447 $source .= "op_$$op: /* $op_name */\n"; 632 $source .= "op_$$op: /* $op_name */\n";
448 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d# 633 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
449 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d# 634 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
450 635
451 $source .= " PERL_ASYNC_CHECK ();\n" 636 $source .= " PERL_ASYNC_CHECK ();\n"
452 unless exists $f_noasync{$op_name}; 637 unless exists $f_noasync{$op_name};
453 638
454 if (my $can = __PACKAGE__->can ("op_$op_name")) { 639 if (my $can = __PACKAGE__->can ("op_$op_name")) {
455 # 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
456 $can->($op); 656 $can->($op);
457 657
458 } elsif (exists $f_unsafe{$op_name}) { 658 } elsif (exists $f_unsafe{$op_name}) {
459 # unsafe, return to interpreter 659 # unsafe, return to interpreter
460 assert "nextop == (OP *)$$op"; 660 assert "nextop == (OP *)$$op";
461 $source .= " return nextop;\n"; 661 $source .= " return nextop;\n";
462 662
463 } elsif ("LOGOP" eq B::class $op) { 663 } elsif ("LOGOP" eq $class) {
464 # logical operation with optionaö branch 664 # logical operation with optional branch
465 out_callop; 665 out_callop;
466 out_cond_jump $op->other; 666 out_cond_jump $op->other;
467 out_jump_next; 667 out_jump_next;
468 668
469 } elsif ("PMOP" eq B::class $op) { 669 } elsif ("PMOP" eq $class) {
470 # regex-thingy 670 # regex-thingy
471 out_callop; 671 out_callop;
472 out_cond_jump $op->pmreplroot if ${$op->pmreplroot}; 672 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
473 out_jump_next; 673 out_jump_next;
474 674
475 } else { 675 } else {
476 # normal operator, linear execution 676 # normal operator, linear execution
477 out_linear; 677 out_linear;
… …
489 689
490 $source 690 $source
491} 691}
492 692
493my $uid = "aaaaaaa0"; 693my $uid = "aaaaaaa0";
694my %so;
494 695
495sub source2ptr { 696sub func2ptr {
496 my (@source) = @_; 697 my (@func) = @_;
497 698
498 my $stem = "/tmp/Faster-$$-" . $uid++; 699 #LOCK
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: $!";
499 706
707 my $meta = eval { Storable::fd_retrieve $meta_fh } || { version => 1 };
708
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
500 open FILE, ">:raw", "$stem.c"; 721 open my $fh, ">:raw", "$stem.c";
501 print FILE <<EOF; 722 print $fh <<EOF;
502#define PERL_NO_GET_CONTEXT 723#define PERL_NO_GET_CONTEXT
724#define PERL_CORE
503 725
504#include <assert.h> 726#include <assert.h>
505 727
506#include "EXTERN.h" 728#include "EXTERN.h"
507#include "perl.h" 729#include "perl.h"
508#include "XSUB.h" 730#include "XSUB.h"
509 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
739
510#define RUNOPS_TILL(op) \\ 740#define RUNOPS_TILL(op) \\
511while (nextop != (op)) \\ 741 while (nextop != (op)) \\
512 { \\ 742 { \\
513 PERL_ASYNC_CHECK (); \\ 743 PERL_ASYNC_CHECK (); \\
514 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\ 744 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
515 }
516
517EOF
518 for (@source) {
519 my $func = $uid++;
520 $_ =~ s/%%%FUNC%%%/$func/g;
521 print FILE $_;
522 $_ = $func;
523 } 745 }
524 746
525 close FILE; 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;
754 print $fh $source;
755 $meta->{$f->{func}} = $f->{so} = $stem;
756 }
757
758 close $fh;
526 system "$COMPILE -o $stem$_o $stem.c"; 759 system "$COMPILE -o $stem$_o $stem.c";
527 #d#unlink "$stem.c"; 760 unlink "$stem.c" unless $ENV{FASTER_DEBUG} & 1;
528 system "$LINK -o $stem$_so $stem$_o $LIBS"; 761 system "$LINK -o $stem$_so $stem$_o $LIBS";
529 unlink "$stem$_o"; 762 unlink "$stem$_o";
763 }
530 764
765 for my $f (@func) {
766 my $stem = $f->{so};
767
531 my $so = DynaLoader::dl_load_file "$stem$_so" 768 my $so = ($so{$stem} ||= DynaLoader::dl_load_file "$stem$_so")
532 or die "$stem$_so: $!"; 769 or die "$stem$_so: $!";
533 770
534 #unlink "$stem$_so"; 771 #unlink "$stem$_so";
535 772
536 map +(DynaLoader::dl_find_symbol $so, $_), @source 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)
537} 782}
538 783
539my %ignore; 784my %ignore;
540 785
541sub entersub { 786sub entersub {
… …
543 788
544 my $pkg = $cv->STASH->NAME; 789 my $pkg = $cv->STASH->NAME;
545 790
546 return if $ignore{$pkg}; 791 return if $ignore{$pkg};
547 792
548 warn "compiling ", $cv->STASH->NAME, "\n" 793 warn "optimising ", $cv->STASH->NAME, "\n"
549 if $verbose; 794 if $verbose;
550 795
551 eval { 796 eval {
552 my @cv; 797 my @func;
553 my @cv_source; 798
799 push @func, {
800 cv => $cv,
801 name => "<>",
802 source => cv2c $cv,
803 };
554 804
555 # always compile the whole stash 805 # always compile the whole stash
556 my %stash = $cv->STASH->ARRAY; 806 my %stash = $cv->STASH->ARRAY;
557 while (my ($k, $v) = each %stash) { 807 while (my ($k, $v) = each %stash) {
558 $v->isa (B::GV::) 808 $v->isa (B::GV::)
… …
561 my $cv = $v->CV; 811 my $cv = $v->CV;
562 812
563 if ($cv->isa (B::CV::) 813 if ($cv->isa (B::CV::)
564 && ${$cv->START} 814 && ${$cv->START}
565 && $cv->START->name ne "null") { 815 && $cv->START->name ne "null") {
816
566 push @cv, $cv; 817 push @func, {
818 cv => $cv,
819 name => $k,
567 push @cv_source, cv2c $cv; 820 source => cv2c $cv,
821 };
568 } 822 }
569 } 823 }
570 824
571 my @ptr = source2ptr @cv_source; 825 func2ptr @func;
572 826
573 for (0 .. $#cv) { 827 for my $f (@func) {
574 patch_cv $cv[$_], $ptr[$_]; 828 patch_cv $f->{cv}, $f->{ptr};
575 } 829 }
576 }; 830 };
577 831
578 if ($@) { 832 if ($@) {
579 $ignore{$pkg}++; 833 $ignore{$pkg}++;
… …
594=over 4 848=over 4
595 849
596=item FASTER_VERBOSE 850=item FASTER_VERBOSE
597 851
598Faster will output more informational messages when set to values higher 852Faster will output more informational messages when set to values higher
599than C<0>. Currently, C<1> outputs which packages are being compiled. 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.
600 856
601=item FASTER_DEBUG 857=item FASTER_DEBUG
602 858
603Add debugging code when set to values higher than C<0>. Currently, this 859Add debugging code when set to values higher than C<0>. Currently, this
604adds 1-3 C<assert>'s per perl op, to ensure that opcode order and C 860adds 1-3 C<assert>'s per perl op (FASTER_DEBUG > 1), to ensure that opcode
605execution order are compatible. 861order and C execution order are compatible.
606 862
607=item FASTER_CACHE 863=item FASTER_CACHE
608 864
609NOT YET IMPLEMENTED
610
611Set a persistent cache directory that caches compiled code 865Set a persistent cache directory that caches compiled code fragments. The
612fragments. Normally, code compiled by Faster will be deleted immediately, 866default is C<$HOME/.perl-faster-cache> if C<HOME> is set and a temporary
613and every restart will recompile everything. Setting this variable to a 867directory otherwise.
614directory makes Faster cache the generated files for re-use.
615 868
616This directory will always grow in contents, so you might need to erase it 869This directory will always grow in size, so you might need to erase it
617from time to time. 870from time to time.
618 871
619=back 872=back
620 873
621=head1 BUGS/LIMITATIONS 874=head1 BUGS/LIMITATIONS
… …
637These constructs will force the use of the interpreter for the currently 890These constructs will force the use of the interpreter for the currently
638executed function as soon as they are being encountered during execution. 891executed function as soon as they are being encountered during execution.
639 892
640 goto 893 goto
641 next, redo (but not well-behaved last's) 894 next, redo (but not well-behaved last's)
895 labels, if used
642 eval 896 eval
643 require 897 require
644 any use of formats 898 any use of formats
645 .., ... (flipflop operators) 899 .., ... (flipflop operators)
646 900

Diff Legend

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