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

Diff Legend

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