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

Comparing Faster/Faster.pm (file contents):
Revision 1.19 by root, Fri Mar 10 22:18:39 2006 UTC vs.
Revision 1.35 by root, Sat Feb 21 05:55:52 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.01';
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
73my %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);
74 106
75# complex flag steting is no longer required, rewrite this ugly code 107# ops with known stack extend behaviour
76for (split /\n/, <<EOF) { 108# the values given are maximum values
77 leavesub unsafe 109my %extend = (
78 leavesublv unsafe 110 pushmark => 0,
79 return unsafe 111 nextstate => 0, # might reduce the stack
80 flip unsafe 112 unstack => 0,
81 goto unsafe 113 enter => 0,
82 last unsafe
83 redo unsafe
84 next unsafe
85 eval unsafe
86 leaveeval unsafe
87 entertry unsafe
88 formline unsafe
89 grepstart unsafe
90 mapstart unsafe
91 substcont unsafe
92 entereval unsafe noasync todo
93 require unsafe
94 114
95 mapstart noasync 115 stringify => 0,
96 grepstart noasync 116 not => 0,
97 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);
98 152
99 last noasync 153# ops that do not need an ASYNC_CHECK
100 next noasync 154my %f_noasync = map +($_ => undef), qw(
101 redo noasync 155 mapstart grepstart match entereval
102 seq noasync 156 enteriter entersub leaveloop
103 pushmark noasync extend=0
104 padsv noasync extend=1
105 padav noasync extend=1
106 padhv noasync extend=1
107 padany noasync extend=1
108 entersub noasync
109 aassign noasync
110 sassign noasync
111 rv2av noasync
112 rv2cv noasync
113 rv2gv noasync
114 rv2hv noasync
115 refgen noasync
116 nextstate noasync
117 gv noasync
118 gvsv noasync
119 add noasync
120 subtract noasync
121 multiply noasync
122 divide noasync
123 complement noasync
124 cond_expr noasync
125 and noasync
126 or noasync
127 not noasync
128 defined noasync
129 method_named noasync
130 preinc noasync
131 postinc noasync
132 predec noasync
133 postdec noasync
134 stub noasync
135 unstack noasync
136 leaveloop noasync
137 aelem noasync
138 aelemfast noasync
139 helem noasync
140 delete noasync
141 exists noasync
142 pushre noasync
143 subst noasync
144 const noasync extend=1
145 list noasync
146 join noasync
147 split noasync
148 concat noasync
149 push noasync
150 pop noasync
151 shift noasync
152 unshift noasync
153 length noasync
154 substr noasync
155 stringify noasync
156 eq noasync
157 ne noasync
158 gt noasync
159 lt noasync
160 ge noasync
161 le noasync
162 enteriter noasync
163 ord noasync
164 orassign noasync
165 regcomp noasync
166 regcreset noasync
167 regcmaybe noasync
168 157
169 iter async 158 pushmark nextstate caller
170EOF
171 my (undef, $op, @flags) = split /\s+/;
172 159
173 undef $flag{$_}{$op} 160 const stub unstack
174 for ("known", @flags); 161 last next redo goto seq
175} 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);
176 179
177my %callop = ( 180my %callop = (
178 entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)", 181 entersub => "(PL_op->op_ppaddr) (aTHX)",
179 mapstart => "Perl_pp_grepstart (aTHX)", 182 mapstart => "Perl_pp_grepstart (aTHX)",
180); 183);
181 184
182sub callop { 185sub callop {
183 $callop{$op_name} || "Perl_pp_$op_name (aTHX)" 186 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
… …
189} 192}
190 193
191sub out_callop { 194sub out_callop {
192 assert "nextop == (OP *)$$op"; 195 assert "nextop == (OP *)$$op";
193 $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";
194} 202}
195 203
196sub out_cond_jump { 204sub out_cond_jump {
197 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n"; 205 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
198} 206}
… …
231 239
232 out_next; 240 out_next;
233} 241}
234 242
235sub op_pushmark { 243sub op_pushmark {
236 $source .= " PUSHMARK (PL_stack_sp);\n"; 244 $source .= " faster_PUSHMARK (PL_stack_sp);\n";
237 245
238 out_next; 246 out_next;
239} 247}
240 248
241if ($Config{useithreads} ne "define") { 249if ($Config{useithreads} ne "define") {
242 # disable optimisations on ithreads 250 # disable optimisations on ithreads
243 251
244 *op_const = sub { 252 *op_const = sub {
245 $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#
246 256
247 out_next; 257 out_next;
248 }; 258 };
249 259
250 *op_gv = \&op_const; 260 *op_gv = \&op_const;
… …
270 if (!($op->flags & B::OPf_MOD)) { 280 if (!($op->flags & B::OPf_MOD)) {
271 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n"; 281 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
272 } 282 }
273 283
274 $source .= " dSP;\n"; 284 $source .= " dSP;\n";
275 $source .= " XPUSHs (sv);\n"; 285 $source .= " PUSHs (sv);\n";
276 $source .= " PUTBACK;\n"; 286 $source .= " PUTBACK;\n";
277 $source .= " }\n"; 287 $source .= " }\n";
278 288
279 out_next; 289 out_next;
280 }; 290 };
281 291
282 *op_gvsv = sub { 292 *op_gvsv = sub {
283 $source .= " {\n"; 293 $source .= " {\n";
284 $source .= " dSP;\n"; 294 $source .= " dSP;\n";
285 $source .= " EXTEND (SP, 1);\n";
286 295
287 if ($op->private & B::OPpLVAL_INTRO) { 296 if ($op->private & B::OPpLVAL_INTRO) {
288 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n"; 297 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
289 } else { 298 } else {
290 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n"; 299 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
… …
350 out_next; 359 out_next;
351} 360}
352 361
353sub op_padsv { 362sub op_padsv {
354 my $flags = $op->flags; 363 my $flags = $op->flags;
355 my $target = $op->targ; 364 my $padofs = "(PADOFFSET)" . $op->targ;
356 365
357 $source .= <<EOF; 366 $source .= <<EOF;
358 { 367 {
359 dSP; 368 dSP;
360 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);
361 PUTBACK; 379 PUTBACK;
362EOF 380EOF
363 if ($op->flags & B::OPf_MOD) { 381
364 if ($op->private & B::OPpLVAL_INTRO) { 382 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
365 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n"; 383 $source .= " if (!SvROK (sv)) vivify_ref (sv, " . $op->private . " & OPpDEREF);\n";
366 } elsif ($op->private & B::OPpDEREF) {
367 my $deref = $op->private & B::OPpDEREF;
368 $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
369 }
370 } 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
371 $source .= <<EOF; 406 $source .= <<EOF;
407 SETs (right);
408 PUTBACK;
372 } 409 }
373EOF 410EOF
374 411
375 out_next; 412 out_next;
376} 413}
377 414
378# pattern const+ (or general push1) 415# pattern const+ (or general push1)
379# pattern pushmark return(?)
380# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 416# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
381 417
382# pattern const method_named
383sub op_method_named { 418sub op_method_named {
419 if ($insn->{follows_const}) {
384 $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;
385 { 444 {
386 static HV *last_stash; 445 static HV *last_stash;
387 static SV *last_cv; 446 static SV *last_cv;
388 static U32 last_sub_generation; 447 static U32 last_sub_generation;
389 448
… …
396 455
397 /* simple "polymorphic" inline cache */ 456 /* simple "polymorphic" inline cache */
398 if (stash == last_stash 457 if (stash == last_stash
399 && PL_sub_generation == last_sub_generation) 458 && PL_sub_generation == last_sub_generation)
400 { 459 {
401 XPUSHs (last_cv); 460 PUSHs (last_cv);
402 PUTBACK; 461 PUTBACK;
403 } 462 }
404 else 463 else
405 { 464 {
406 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 465 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
… …
416 /* error case usually */ 475 /* error case usually */
417 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 476 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
418 } 477 }
419 } 478 }
420EOF 479EOF
480 }
421 481
422 out_next; 482 out_next;
423} 483}
424 484
425sub op_grepstart { 485sub op_grepstart {
… …
439} 499}
440 500
441sub out_break_op { 501sub out_break_op {
442 my ($idx) = @_; 502 my ($idx) = @_;
443 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];
444 out_callop; 507 out_callop;
445 508 out_jump $next;
446 out_cond_jump $_->[$idx] 509 } elsif (my $loop = $insn->{loop}) {
447 for reverse @op_loop; 510 # less common case: maybe break to some outer loop
448
449 $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 }
450} 517}
451 518
452sub xop_next { 519sub op_next {
453 out_break_op 0; 520 out_break_op 0;
454} 521}
455 522
456sub op_last { 523sub op_last {
457 out_break_op 1; 524 out_break_op 1;
458} 525}
459 526
527# TODO: does not seem to work
460sub xop_redo { 528#sub op_redo {
461 out_break_op 2; 529# out_break_op 2;
462} 530#}
463 531
464sub cv2c { 532sub cv2c {
465 my ($cv) = @_; 533 my ($cv) = @_;
466 534
467 local @ops; 535 local @ops;
468 local @op_loop;
469 local %op_regcomp; 536 local %op_regcomp;
470 537
471 my %opsseen; 538 my $curloop;
472 my @todo = $cv->START; 539 my @todo = $cv->START;
540 my %op_target;
541 my $numpushmark;
542 my $scope;
473 543
544 my %op_seen;
474 while (my $op = shift @todo) { 545 while (my $op = shift @todo) {
546 my $next;
475 for (; $$op; $op = $op->next) { 547 for (; $$op; $op = $next) {
476 last if $opsseen{$$op}++; 548 last if $op_seen{$$op}++;
477 push @ops, $op; 549
550 $next = $op->next;
478 551
479 my $name = $op->name; 552 my $name = $op->name;
480 my $class = B::class $op; 553 my $class = B::class $op;
481 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(?)
482 if ($class eq "LOGOP") { 573 if ($class eq "LOGOP") {
483 unshift @todo, $op->other; # unshift vs. push saves jumps 574 push @todo, $op->other;
575 $op_target{${$op->other}}++;
484 576
485 # 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}}++;
486 $op_regcomp{${$op->first}} = $op->next 580 $op_regcomp{${$op->first}} = $op->next;
487 if $name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP; 581 }
488 582
489 } elsif ($class eq "PMOP") { 583 } elsif ($class eq "PMOP") {
584 if (${$op->pmreplstart}) {
490 unshift @todo, $op->pmreplstart if ${$op->pmreplstart}; 585 unshift @todo, $op->pmreplstart;
586 $op_target{${$op->pmreplstart}}++;
587 }
491 588
492 } elsif ($class eq "LOOP") { 589 } elsif ($class eq "LOOP") {
493 push @op_loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
494 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 }
495 } 610 }
496 } 611 }
497 } 612 }
613
614 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
498 615
499 local $source = <<EOF; 616 local $source = <<EOF;
500OP *%%%FUNC%%% (pTHX) 617OP *%%%FUNC%%% (pTHX)
501{ 618{
502 register OP *nextop = (OP *)${$ops[0]}L; 619 register OP *nextop = (OP *)${$ops[0]->{op}}L;
503EOF 620EOF
621
622 $source .= " faster_PUSHMARK_PREALLOC ($numpushmark);\n"
623 if $numpushmark;
504 624
505 while (@ops) { 625 while (@ops) {
506 $op = shift @ops; 626 $insn = shift @ops;
627
628 $op = $insn->{op};
507 $op_name = $op->name; 629 $op_name = $op->name;
508 630
631 my $class = B::class $op;
632
633 $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
509 $source .= "op_$$op: /* $op_name */\n"; 634 $source .= "op_$$op: /* $op_name */\n";
510 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d# 635 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
511 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d# 636 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
512 637
513 $source .= " PERL_ASYNC_CHECK ();\n" 638 $source .= " PERL_ASYNC_CHECK ();\n"
514 unless exists $flag{noasync}{$op_name}; 639 unless exists $f_noasync{$op_name};
515 640
516 if (my $can = __PACKAGE__->can ("op_$op_name")) { 641 if (my $can = __PACKAGE__->can ("op_$op_name")) {
517 # 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
518 $can->($op); 658 $can->($op);
519 659
520 } elsif (exists $flag{unsafe}{$op_name}) { 660 } elsif (exists $f_unsafe{$op_name}) {
521 # unsafe, return to interpreter 661 # unsafe, return to interpreter
522 assert "nextop == (OP *)$$op"; 662 assert "nextop == (OP *)$$op";
523 $source .= " return nextop;\n"; 663 $source .= " return nextop;\n";
524 664
525 } elsif ("LOGOP" eq B::class $op) { 665 } elsif ("LOGOP" eq $class) {
526 # logical operation with optionaö branch 666 # logical operation with optional branch
527 out_callop; 667 out_callop;
528 out_cond_jump $op->other; 668 out_cond_jump $op->other;
529 out_jump_next; 669 out_jump_next;
530 670
531 } elsif ("PMOP" eq B::class $op) { 671 } elsif ("PMOP" eq $class) {
532 # regex-thingy 672 # regex-thingy
533 out_callop; 673 out_callop;
534 out_cond_jump $op->pmreplroot if ${$op->pmreplroot}; 674 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
535 out_jump_next; 675 out_jump_next;
536 676
537 } else { 677 } else {
538 # normal operator, linear execution 678 # normal operator, linear execution
539 out_linear; 679 out_linear;
… …
551 691
552 $source 692 $source
553} 693}
554 694
555my $uid = "aaaaaaa0"; 695my $uid = "aaaaaaa0";
696my %so;
556 697
557sub source2ptr { 698sub func2ptr {
558 my (@source) = @_; 699 my (@func) = @_;
559 700
560 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: $!";
561 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
562 open FILE, ">:raw", "$stem.c"; 723 open my $fh, ">:raw", "$stem.c";
563 print FILE <<EOF; 724 print $fh <<EOF;
564#define PERL_NO_GET_CONTEXT 725#define PERL_NO_GET_CONTEXT
726#define PERL_CORE
565 727
566#include <assert.h> 728#include <assert.h>
567 729
568#include "EXTERN.h" 730#include "EXTERN.h"
569#include "perl.h" 731#include "perl.h"
570#include "XSUB.h" 732#include "XSUB.h"
571 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
572#define RUNOPS_TILL(op) \\ 742#define RUNOPS_TILL(op) \\
573while (nextop != (op)) \\ 743 while (nextop != (op)) \\
574 { \\ 744 { \\
575 PERL_ASYNC_CHECK (); \\ 745 PERL_ASYNC_CHECK (); \\
576 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\ 746 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
577 }
578
579EOF
580 for (@source) {
581 my $func = $uid++;
582 $_ =~ s/%%%FUNC%%%/$func/g;
583 print FILE $_;
584 $_ = $func;
585 } 747 }
586 748
587 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;
588 system "$COMPILE -o $stem$_o $stem.c"; 761 system "$COMPILE -o $stem$_o $stem.c";
589 #d#unlink "$stem.c"; 762 unlink "$stem.c" unless $ENV{FASTER_DEBUG} & 1;
590 system "$LINK -o $stem$_so $stem$_o $LIBS"; 763 system "$LINK -o $stem$_so $stem$_o $LIBS";
591 unlink "$stem$_o"; 764 unlink "$stem$_o";
765 }
592 766
767 for my $f (@func) {
768 my $stem = $f->{so};
769
593 my $so = DynaLoader::dl_load_file "$stem$_so" 770 my $so = ($so{$stem} ||= DynaLoader::dl_load_file "$stem$_so")
594 or die "$stem$_so: $!"; 771 or die "$stem$_so: $!";
595 772
596 #unlink "$stem$_so"; 773 #unlink "$stem$_so";
597 774
598 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)
599} 784}
600 785
601my %ignore; 786my %ignore;
602 787
603sub entersub { 788sub entersub {
… …
605 790
606 my $pkg = $cv->STASH->NAME; 791 my $pkg = $cv->STASH->NAME;
607 792
608 return if $ignore{$pkg}; 793 return if $ignore{$pkg};
609 794
610 warn "compiling ", $cv->STASH->NAME;#d# 795 warn "optimising ", $cv->STASH->NAME, "\n"
796 if $verbose;
611 797
612 eval { 798 eval {
613 my @cv; 799 my @func;
614 my @cv_source; 800
801 push @func, {
802 cv => $cv,
803 name => "<>",
804 source => cv2c $cv,
805 };
615 806
616 # always compile the whole stash 807 # always compile the whole stash
617 my %stash = $cv->STASH->ARRAY; 808 my %stash = $cv->STASH->ARRAY;
618 while (my ($k, $v) = each %stash) { 809 while (my ($k, $v) = each %stash) {
619 $v->isa (B::GV::) 810 $v->isa (B::GV::)
… …
622 my $cv = $v->CV; 813 my $cv = $v->CV;
623 814
624 if ($cv->isa (B::CV::) 815 if ($cv->isa (B::CV::)
625 && ${$cv->START} 816 && ${$cv->START}
626 && $cv->START->name ne "null") { 817 && $cv->START->name ne "null") {
818
627 push @cv, $cv; 819 push @func, {
820 cv => $cv,
821 name => $k,
628 push @cv_source, cv2c $cv; 822 source => cv2c $cv,
823 };
629 } 824 }
630 } 825 }
631 826
632 my @ptr = source2ptr @cv_source; 827 func2ptr @func;
633 828
634 for (0 .. $#cv) { 829 for my $f (@func) {
635 patch_cv $cv[$_], $ptr[$_]; 830 patch_cv $f->{cv}, $f->{ptr};
636 } 831 }
637 }; 832 };
638 833
639 if ($@) { 834 if ($@) {
640 $ignore{$pkg}++; 835 $ignore{$pkg}++;
… …
646 841
6471; 8421;
648 843
649=back 844=back
650 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
651=head1 BUGS/LIMITATIONS 876=head1 BUGS/LIMITATIONS
652 877
653Perl will check much less often for asynchronous signals in 878Perl will check much less often for asynchronous signals in
654Faster-compiled code. It tries to check on every function call, loop 879Faster-compiled code. It tries to check on every function call, loop
655iteration and every I/O operator, though. 880iteration and every I/O operator, though.
… …
667These constructs will force the use of the interpreter for the currently 892These constructs will force the use of the interpreter for the currently
668executed function as soon as they are being encountered during execution. 893executed function as soon as they are being encountered during execution.
669 894
670 goto 895 goto
671 next, redo (but not well-behaved last's) 896 next, redo (but not well-behaved last's)
897 labels, if used
672 eval 898 eval
673 require 899 require
674 any use of formats 900 any use of formats
675 .., ... (flipflop operators) 901 .., ... (flipflop operators)
676 902

Diff Legend

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