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

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

Diff Legend

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