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

Diff Legend

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