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

Comparing Faster/Faster.pm (file contents):
Revision 1.18 by root, Fri Mar 10 19:52:07 2006 UTC vs.
Revision 1.31 by root, Mon Mar 13 16:59:43 2006 UTC

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

Diff Legend

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