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

Comparing Faster/Faster.pm (file contents):
Revision 1.19 by root, Fri Mar 10 22:18:39 2006 UTC vs.
Revision 1.24 by root, Sat Mar 11 04:53:00 2006 UTC

… …
34=over 4 34=over 4
35 35
36=cut 36=cut
37 37
38package Faster; 38package Faster;
39
40no warnings;
39 41
40use strict; 42use strict;
41use Config; 43use Config;
42use B (); 44use B ();
43#use Digest::MD5 (); 45#use Digest::MD5 ();
44use DynaLoader (); 46use DynaLoader ();
47use File::Temp ();
45 48
46BEGIN { 49BEGIN {
47 our $VERSION = '0.01'; 50 our $VERSION = '0.01';
48 51
49 require XSLoader; 52 require XSLoader;
… …
58 61
59# we don't need no steenking PIC on x86 62# we don't need no steenking PIC on x86
60$COMPILE =~ s/-f(?:PIC|pic)//g 63$COMPILE =~ s/-f(?:PIC|pic)//g
61 if $Config{archname} =~ /^(i[3456]86)-/; 64 if $Config{archname} =~ /^(i[3456]86)-/;
62 65
63my $opt_assert = 0; 66my $opt_assert = $ENV{FASTER_DEBUG};
67my $verbose = $ENV{FASTER_VERBOSE}+0;
64 68
65our $source; 69our $source;
66 70
67our @ops; 71our @ops;
72our $insn;
68our $op; 73our $op;
69our $op_name; 74our $op_name;
70our @op_loop; 75our @op_loop;
71our %op_regcomp; 76our %op_regcomp;
72 77
73my %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);
74 86
75# complex flag steting is no longer required, rewrite this ugly code 87# ops with known stack extend behaviour
76for (split /\n/, <<EOF) { 88# the values given are maximum values
77 leavesub unsafe 89my %extend = (
78 leavesublv unsafe 90 pushmark => 0,
79 return unsafe 91 nextstate => 0, # might reduce the stack
80 flip unsafe 92 unstack => 0,
81 goto unsafe 93 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 94
95 mapstart noasync 95 stringify => 0,
96 grepstart noasync 96 not => 0,
97 match noasync 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);
98 132
99 last noasync 133# ops that do not need an ASYNC_CHECK
100 next noasync 134my %f_noasync = map +($_ => undef), qw(
101 redo noasync 135 mapstart grepstart match entereval
102 seq noasync 136 enteriter entersub leaveloop
103 pushmark noasync extend=0
104 padsv noasync extend=1
105 padav noasync extend=1
106 padhv noasync extend=1
107 padany noasync extend=1
108 entersub noasync
109 aassign noasync
110 sassign noasync
111 rv2av noasync
112 rv2cv noasync
113 rv2gv noasync
114 rv2hv noasync
115 refgen noasync
116 nextstate noasync
117 gv noasync
118 gvsv noasync
119 add noasync
120 subtract noasync
121 multiply noasync
122 divide noasync
123 complement noasync
124 cond_expr noasync
125 and noasync
126 or noasync
127 not noasync
128 defined noasync
129 method_named noasync
130 preinc noasync
131 postinc noasync
132 predec noasync
133 postdec noasync
134 stub noasync
135 unstack noasync
136 leaveloop noasync
137 aelem noasync
138 aelemfast noasync
139 helem noasync
140 delete noasync
141 exists noasync
142 pushre noasync
143 subst noasync
144 const noasync extend=1
145 list noasync
146 join noasync
147 split noasync
148 concat noasync
149 push noasync
150 pop noasync
151 shift noasync
152 unshift noasync
153 length noasync
154 substr noasync
155 stringify noasync
156 eq noasync
157 ne noasync
158 gt noasync
159 lt noasync
160 ge noasync
161 le noasync
162 enteriter noasync
163 ord noasync
164 orassign noasync
165 regcomp noasync
166 regcreset noasync
167 regcmaybe noasync
168 137
169 iter async 138 pushmark nextstate
170EOF
171 my (undef, $op, @flags) = split /\s+/;
172 139
173 undef $flag{$_}{$op} 140 const stub unstack
174 for ("known", @flags); 141 last next redo seq
175} 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);
176 158
177my %callop = ( 159my %callop = (
178 entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)", 160 entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)",
179 mapstart => "Perl_pp_grepstart (aTHX)", 161 mapstart => "Perl_pp_grepstart (aTHX)",
180); 162);
… …
240 222
241if ($Config{useithreads} ne "define") { 223if ($Config{useithreads} ne "define") {
242 # disable optimisations on ithreads 224 # disable optimisations on ithreads
243 225
244 *op_const = sub { 226 *op_const = sub {
245 $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n"; 227 $source .= " { dSP; PUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
246 228
247 out_next; 229 out_next;
248 }; 230 };
249 231
250 *op_gv = \&op_const; 232 *op_gv = \&op_const;
… …
270 if (!($op->flags & B::OPf_MOD)) { 252 if (!($op->flags & B::OPf_MOD)) {
271 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n"; 253 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
272 } 254 }
273 255
274 $source .= " dSP;\n"; 256 $source .= " dSP;\n";
275 $source .= " XPUSHs (sv);\n"; 257 $source .= " PUSHs (sv);\n";
276 $source .= " PUTBACK;\n"; 258 $source .= " PUTBACK;\n";
277 $source .= " }\n"; 259 $source .= " }\n";
278 260
279 out_next; 261 out_next;
280 }; 262 };
281 263
282 *op_gvsv = sub { 264 *op_gvsv = sub {
283 $source .= " {\n"; 265 $source .= " {\n";
284 $source .= " dSP;\n"; 266 $source .= " dSP;\n";
285 $source .= " EXTEND (SP, 1);\n";
286 267
287 if ($op->private & B::OPpLVAL_INTRO) { 268 if ($op->private & B::OPpLVAL_INTRO) {
288 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n"; 269 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
289 } else { 270 } else {
290 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n"; 271 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
… …
350 out_next; 331 out_next;
351} 332}
352 333
353sub op_padsv { 334sub op_padsv {
354 my $flags = $op->flags; 335 my $flags = $op->flags;
355 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#
356 342
357 $source .= <<EOF; 343 $source .= <<EOF;
358 { 344 {
359 dSP; 345 dSP;
360 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);
361 PUTBACK; 356 PUTBACK;
362EOF 357EOF
363 if ($op->flags & B::OPf_MOD) { 358
364 if ($op->private & B::OPpLVAL_INTRO) { 359 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
365 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n"; 360 $source .= " vivify_ref (sv, $flags & OPpDEREF);\n";
366 } elsif ($op->private & B::OPpDEREF) {
367 my $deref = $op->private & B::OPpDEREF;
368 $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
369 }
370 } 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
371 $source .= <<EOF; 383 $source .= <<EOF;
384 SETs (right);
385 PUTBACK;
372 } 386 }
373EOF 387EOF
374 388
375 out_next; 389 out_next;
376} 390}
377 391
378# pattern const+ (or general push1) 392# pattern const+ (or general push1)
379# pattern pushmark return(?) 393# pattern pushmark return(?)
380# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 394# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
… …
396 410
397 /* simple "polymorphic" inline cache */ 411 /* simple "polymorphic" inline cache */
398 if (stash == last_stash 412 if (stash == last_stash
399 && PL_sub_generation == last_sub_generation) 413 && PL_sub_generation == last_sub_generation)
400 { 414 {
401 XPUSHs (last_cv); 415 PUSHs (last_cv);
402 PUTBACK; 416 PUTBACK;
403 } 417 }
404 else 418 else
405 { 419 {
406 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 420 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
… …
468 local @op_loop; 482 local @op_loop;
469 local %op_regcomp; 483 local %op_regcomp;
470 484
471 my %opsseen; 485 my %opsseen;
472 my @todo = $cv->START; 486 my @todo = $cv->START;
487 my %op_target;
473 488
474 while (my $op = shift @todo) { 489 while (my $op = shift @todo) {
475 for (; $$op; $op = $op->next) { 490 for (; $$op; $op = $op->next) {
476 last if $opsseen{$$op}++; 491 last if $opsseen{$$op}++;
477 push @ops, $op;
478 492
479 my $name = $op->name; 493 my $name = $op->name;
480 my $class = B::class $op; 494 my $class = B::class $op;
481 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
482 if ($class eq "LOGOP") { 508 if ($class eq "LOGOP") {
483 unshift @todo, $op->other; # unshift vs. push saves jumps 509 push @todo, $op->other;
510 $op_target{${$op->other}}++;
484 511
485 # regcomp/o patches ops at runtime, lets expect that 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}}++;
486 $op_regcomp{${$op->first}} = $op->next 515 $op_regcomp{${$op->first}} = $op->next;
487 if $name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP; 516 }
488 517
489 } elsif ($class eq "PMOP") { 518 } elsif ($class eq "PMOP") {
519 if (${$op->pmreplstart}) {
490 unshift @todo, $op->pmreplstart if ${$op->pmreplstart}; 520 unshift @todo, $op->pmreplstart;
521 $op_target{${$op->pmreplstart}}++;
522 }
491 523
492 } elsif ($class eq "LOOP") { 524 } elsif ($class eq "LOOP") {
493 push @op_loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
494 push @todo, $op->nextop, $op->lastop->next, $op->redoop->next; 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;
495 } 533 }
496 } 534 }
497 } 535 }
536
537 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
498 538
499 local $source = <<EOF; 539 local $source = <<EOF;
500OP *%%%FUNC%%% (pTHX) 540OP *%%%FUNC%%% (pTHX)
501{ 541{
502 register OP *nextop = (OP *)${$ops[0]}L; 542 register OP *nextop = (OP *)${$ops[0]->{op}}L;
503EOF 543EOF
504 544
505 while (@ops) { 545 while (@ops) {
506 $op = shift @ops; 546 $insn = shift @ops;
547
548 $op = $insn->{op};
507 $op_name = $op->name; 549 $op_name = $op->name;
508 550
551 my $class = B::class $op;
552
553 $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
509 $source .= "op_$$op: /* $op_name */\n"; 554 $source .= "op_$$op: /* $op_name */\n";
510 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d# 555 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
511 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d# 556 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
512 557
513 $source .= " PERL_ASYNC_CHECK ();\n" 558 $source .= " PERL_ASYNC_CHECK ();\n"
514 unless exists $flag{noasync}{$op_name}; 559 unless exists $f_noasync{$op_name};
515 560
516 if (my $can = __PACKAGE__->can ("op_$op_name")) { 561 if (my $can = __PACKAGE__->can ("op_$op_name")) {
517 # 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
518 $can->($op); 578 $can->($op);
519 579
520 } elsif (exists $flag{unsafe}{$op_name}) { 580 } elsif (exists $f_unsafe{$op_name}) {
521 # unsafe, return to interpreter 581 # unsafe, return to interpreter
522 assert "nextop == (OP *)$$op"; 582 assert "nextop == (OP *)$$op";
523 $source .= " return nextop;\n"; 583 $source .= " return nextop;\n";
524 584
525 } elsif ("LOGOP" eq B::class $op) { 585 } elsif ("LOGOP" eq $class) {
526 # logical operation with optionaö branch 586 # logical operation with optional branch
527 out_callop; 587 out_callop;
528 out_cond_jump $op->other; 588 out_cond_jump $op->other;
529 out_jump_next; 589 out_jump_next;
530 590
531 } elsif ("PMOP" eq B::class $op) { 591 } elsif ("PMOP" eq $class) {
532 # regex-thingy 592 # regex-thingy
533 out_callop; 593 out_callop;
534 out_cond_jump $op->pmreplroot if ${$op->pmreplroot}; 594 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
535 out_jump_next; 595 out_jump_next;
536 596
537 } else { 597 } else {
538 # normal operator, linear execution 598 # normal operator, linear execution
539 out_linear; 599 out_linear;
… …
560 my $stem = "/tmp/Faster-$$-" . $uid++; 620 my $stem = "/tmp/Faster-$$-" . $uid++;
561 621
562 open FILE, ">:raw", "$stem.c"; 622 open FILE, ">:raw", "$stem.c";
563 print FILE <<EOF; 623 print FILE <<EOF;
564#define PERL_NO_GET_CONTEXT 624#define PERL_NO_GET_CONTEXT
625#define PERL_CORE
565 626
566#include <assert.h> 627#include <assert.h>
567 628
568#include "EXTERN.h" 629#include "EXTERN.h"
569#include "perl.h" 630#include "perl.h"
… …
605 666
606 my $pkg = $cv->STASH->NAME; 667 my $pkg = $cv->STASH->NAME;
607 668
608 return if $ignore{$pkg}; 669 return if $ignore{$pkg};
609 670
610 warn "compiling ", $cv->STASH->NAME;#d# 671 warn "compiling ", $cv->STASH->NAME, "\n"
672 if $verbose;
611 673
612 eval { 674 eval {
613 my @cv; 675 my @cv;
614 my @cv_source; 676 my @cv_source;
615 677
… …
646 708
6471; 7091;
648 710
649=back 711=back
650 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.
741
742=back
743
651=head1 BUGS/LIMITATIONS 744=head1 BUGS/LIMITATIONS
652 745
653Perl will check much less often for asynchronous signals in 746Perl will check much less often for asynchronous signals in
654Faster-compiled code. It tries to check on every function call, loop 747Faster-compiled code. It tries to check on every function call, loop
655iteration and every I/O operator, though. 748iteration and every I/O operator, though.

Diff Legend

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