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

Comparing Faster/Faster.pm (file contents):
Revision 1.20 by root, Fri Mar 10 22:32:15 2006 UTC vs.
Revision 1.26 by root, Sat Mar 11 18:13:35 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
78# ops that cause immediate return to the interpreter
73my %f_unsafe = map +($_ => undef), qw( 79my %f_unsafe = map +($_ => undef), qw(
74 leavesub leavesublv return 80 leavesub leavesublv return
75 goto last redo next 81 goto last redo next
76 eval flip leaveeval entertry 82 eval flip leaveeval entertry
77 formline grepstart mapstart 83 formline grepstart mapstart
78 substcont entereval require 84 substcont entereval require
79); 85);
80 86
81# pushmark extend=0 87# ops with known stack extend behaviour
82# padsv extend=1 88# the values given are maximum values
83# padav extend=1 89my %extend = (
84# padhv extend=1 90 pushmark => 0,
85# padany extend=1 91 nextstate => 0, # might reduce the stack
86# const extend=1 92 unstack => 0,
93 enter => 0,
87 94
95 stringify => 0,
96 not => 0,
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);
132
133# ops that do not need an ASYNC_CHECK
88my %f_noasync = map +($_ => undef), qw( 134my %f_noasync = map +($_ => undef), qw(
89 mapstart grepstart match entereval 135 mapstart grepstart match entereval
90 enteriter entersub leaveloop 136 enteriter entersub leaveloop
91 137
92 pushmark nextstate 138 pushmark nextstate
… …
98 rv2av rv2cv rv2gv rv2hv refgen 144 rv2av rv2cv rv2gv rv2hv refgen
99 gv gvsv 145 gv gvsv
100 add subtract multiply divide 146 add subtract multiply divide
101 complement cond_expr and or not 147 complement cond_expr and or not
102 defined 148 defined
103 method_named 149 method method_named bless
104 preinc postinc predec postdec 150 preinc postinc predec postdec
105 aelem aelemfast helem delete exists 151 aelem aelemfast helem delete exists
106 pushre subst list join split concat 152 pushre subst list join split concat
107 length substr stringify ord 153 length substr stringify ord
108 push pop shift unshift 154 push pop shift unshift
109 eq ne gt lt ge le 155 eq ne gt lt ge le
110 regcomp regcreset regcmaybe 156 regcomp regcreset regcmaybe
111); 157);
112 158
113my %callop = ( 159my %callop = (
114 entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)", 160 entersub => "(PL_op->op_ppaddr) (aTHX)",
115 mapstart => "Perl_pp_grepstart (aTHX)", 161 mapstart => "Perl_pp_grepstart (aTHX)",
116); 162);
117 163
118sub callop { 164sub callop {
119 $callop{$op_name} || "Perl_pp_$op_name (aTHX)" 165 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
… …
176 222
177if ($Config{useithreads} ne "define") { 223if ($Config{useithreads} ne "define") {
178 # disable optimisations on ithreads 224 # disable optimisations on ithreads
179 225
180 *op_const = sub { 226 *op_const = sub {
181 $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n"; 227 $source .= " { dSP; PUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
228
229 $ops[0]{follows_const}++ if @ops;#d#
182 230
183 out_next; 231 out_next;
184 }; 232 };
185 233
186 *op_gv = \&op_const; 234 *op_gv = \&op_const;
… …
206 if (!($op->flags & B::OPf_MOD)) { 254 if (!($op->flags & B::OPf_MOD)) {
207 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n"; 255 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
208 } 256 }
209 257
210 $source .= " dSP;\n"; 258 $source .= " dSP;\n";
211 $source .= " XPUSHs (sv);\n"; 259 $source .= " PUSHs (sv);\n";
212 $source .= " PUTBACK;\n"; 260 $source .= " PUTBACK;\n";
213 $source .= " }\n"; 261 $source .= " }\n";
214 262
215 out_next; 263 out_next;
216 }; 264 };
217 265
218 *op_gvsv = sub { 266 *op_gvsv = sub {
219 $source .= " {\n"; 267 $source .= " {\n";
220 $source .= " dSP;\n"; 268 $source .= " dSP;\n";
221 $source .= " EXTEND (SP, 1);\n";
222 269
223 if ($op->private & B::OPpLVAL_INTRO) { 270 if ($op->private & B::OPpLVAL_INTRO) {
224 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n"; 271 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
225 } else { 272 } else {
226 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n"; 273 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
… …
286 out_next; 333 out_next;
287} 334}
288 335
289sub op_padsv { 336sub op_padsv {
290 my $flags = $op->flags; 337 my $flags = $op->flags;
291 my $target = $op->targ; 338 my $padofs = "(PADOFFSET)" . $op->targ;
292 339
293 $source .= <<EOF; 340 $source .= <<EOF;
294 { 341 {
295 dSP; 342 dSP;
296 XPUSHs (PAD_SV ((PADOFFSET)$target)); 343 SV *sv = PAD_SVl ($padofs);
344EOF
345
346 if (($flags & B::OPf_MOD) && ($op->private & B::OPpLVAL_INTRO)) {
347 $source .= " SAVECLEARSV (PAD_SVl ($padofs));\n";
348 $ops[0]{follows_padsv_lval_intro}++ if @ops;#d#
349 }
350
351 $source .= <<EOF;
352 PUSHs (sv);
297 PUTBACK; 353 PUTBACK;
298EOF 354EOF
299 if ($op->flags & B::OPf_MOD) { 355
300 if ($op->private & B::OPpLVAL_INTRO) { 356 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
301 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n"; 357 $source .= " vivify_ref (sv, " . $op->private . " & OPpDEREF);\n";
302 } elsif ($op->private & B::OPpDEREF) {
303 my $deref = $op->private & B::OPpDEREF;
304 $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
305 }
306 } 358 }
359 $source .= " }\n";
360
361 out_next;
362}
363
364sub op_sassign {
365 $source .= <<EOF;
366 {
367 dSP;
368 dPOPTOPssrl;
369EOF
370 $source .= " SV *temp = left; left = right; right = temp;\n"
371 if $op->private & B::OPpASSIGN_BACKWARDS;
372
373 if ($insn->{follows_padsv_lval_intro} && !($op->private & B::OPpASSIGN_BACKWARDS)) {
374 # simple assignment - the target exists, but is basically undef
375 $source .= " SvSetSV (right, left);\n";
376 } else {
377 $source .= " SvSetMagicSV (right, left);\n";
378 }
379
307 $source .= <<EOF; 380 $source .= <<EOF;
381 SETs (right);
382 PUTBACK;
308 } 383 }
309EOF 384EOF
310 385
311 out_next; 386 out_next;
312} 387}
313 388
314# pattern const+ (or general push1) 389# pattern const+ (or general push1)
315# pattern pushmark return(?)
316# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 390# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
317 391
318# pattern const method_named
319sub op_method_named { 392sub op_method_named {
393 if ($insn->{follows_const}) {
320 $source .= <<EOF; 394 $source .= <<EOF;
395 {
396 dSP;
397 static SV *last_cv;
398 static U32 last_sub_generation;
399
400 /* simple "polymorphic" inline cache */
401 if (PL_sub_generation == last_sub_generation)
402 {
403 PUSHs (last_cv);
404 PUTBACK;
405 }
406 else
407 {
408 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
409
410 SPAGAIN;
411 last_sub_generation = PL_sub_generation;
412 last_cv = TOPs;
413 }
414 }
415EOF
416 } else {
417 $source .= <<EOF;
321 { 418 {
322 static HV *last_stash; 419 static HV *last_stash;
323 static SV *last_cv; 420 static SV *last_cv;
324 static U32 last_sub_generation; 421 static U32 last_sub_generation;
325 422
… …
332 429
333 /* simple "polymorphic" inline cache */ 430 /* simple "polymorphic" inline cache */
334 if (stash == last_stash 431 if (stash == last_stash
335 && PL_sub_generation == last_sub_generation) 432 && PL_sub_generation == last_sub_generation)
336 { 433 {
337 XPUSHs (last_cv); 434 PUSHs (last_cv);
338 PUTBACK; 435 PUTBACK;
339 } 436 }
340 else 437 else
341 { 438 {
342 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 439 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
… …
352 /* error case usually */ 449 /* error case usually */
353 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 450 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
354 } 451 }
355 } 452 }
356EOF 453EOF
454 }
357 455
358 out_next; 456 out_next;
359} 457}
360 458
361sub op_grepstart { 459sub op_grepstart {
… …
404 local @op_loop; 502 local @op_loop;
405 local %op_regcomp; 503 local %op_regcomp;
406 504
407 my %opsseen; 505 my %opsseen;
408 my @todo = $cv->START; 506 my @todo = $cv->START;
507 my %op_target;
409 508
410 while (my $op = shift @todo) { 509 while (my $op = shift @todo) {
411 for (; $$op; $op = $op->next) { 510 for (; $$op; $op = $op->next) {
412 last if $opsseen{$$op}++; 511 last if $opsseen{$$op}++;
413 push @ops, $op;
414 512
415 my $name = $op->name; 513 my $name = $op->name;
416 my $class = B::class $op; 514 my $class = B::class $op;
417 515
516 my $insn = { op => $op };
517
518 push @ops, $insn;
519
520 if (exists $extend{$name}) {
521 my $extend = $extend{$name};
522 $extend = $extend->($op) if ref $extend;
523 $insn->{extend} = $extend if defined $extend;
524 }
525
526 push @todo, $op->next;
527
418 if ($class eq "LOGOP") { 528 if ($class eq "LOGOP") {
419 unshift @todo, $op->other; # unshift vs. push saves jumps 529 push @todo, $op->other;
530 $op_target{${$op->other}}++;
420 531
421 # regcomp/o patches ops at runtime, lets expect that 532 # regcomp/o patches ops at runtime, lets expect that
533 if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
534 $op_target{${$op->first}}++;
422 $op_regcomp{${$op->first}} = $op->next 535 $op_regcomp{${$op->first}} = $op->next;
423 if $name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP; 536 }
424 537
425 } elsif ($class eq "PMOP") { 538 } elsif ($class eq "PMOP") {
539 if (${$op->pmreplstart}) {
426 unshift @todo, $op->pmreplstart if ${$op->pmreplstart}; 540 unshift @todo, $op->pmreplstart;
541 $op_target{${$op->pmreplstart}}++;
542 }
427 543
428 } elsif ($class eq "LOOP") { 544 } elsif ($class eq "LOOP") {
429 push @op_loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
430 push @todo, $op->nextop, $op->lastop->next, $op->redoop->next; 545 my @targ = ($op->nextop, $op->lastop->next, $op->redoop->next);
546
547 push @op_loop, \@targ;
548 push @todo, @targ;
549
550 $op_target{$$_}++ for @targ;
551 } elsif ($class eq "COP") {
552 $insn->{bblock}++ if defined $op->label;
431 } 553 }
432 } 554 }
433 } 555 }
556
557 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
434 558
435 local $source = <<EOF; 559 local $source = <<EOF;
436OP *%%%FUNC%%% (pTHX) 560OP *%%%FUNC%%% (pTHX)
437{ 561{
438 register OP *nextop = (OP *)${$ops[0]}L; 562 register OP *nextop = (OP *)${$ops[0]->{op}}L;
439EOF 563EOF
440 564
441 while (@ops) { 565 while (@ops) {
442 $op = shift @ops; 566 $insn = shift @ops;
567
568 $op = $insn->{op};
443 $op_name = $op->name; 569 $op_name = $op->name;
444 570
571 my $class = B::class $op;
572
573 $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
445 $source .= "op_$$op: /* $op_name */\n"; 574 $source .= "op_$$op: /* $op_name */\n";
446 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d# 575 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
447 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d# 576 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
448 577
449 $source .= " PERL_ASYNC_CHECK ();\n" 578 $source .= " PERL_ASYNC_CHECK ();\n"
450 unless exists $f_noasync{$op_name}; 579 unless exists $f_noasync{$op_name};
451 580
452 if (my $can = __PACKAGE__->can ("op_$op_name")) { 581 if (my $can = __PACKAGE__->can ("op_$op_name")) {
453 # handcrafted replacement 582 # handcrafted replacement
583
584 if ($insn->{extend} > 0) {
585 # coalesce EXTENDs
586 # TODO: properly take negative preceeding and following EXTENDs into account
587 for my $i (@ops) {
588 last if exists $i->{bblock};
589 last unless exists $i->{extend};
590 my $extend = delete $i->{extend};
591 $insn->{extend} += $extend if $extend > 0;
592 }
593
594 $source .= " { dSP; EXTEND (SP, $insn->{extend}); PUTBACK; }\n"
595 if $insn->{extend} > 0;
596 }
597
454 $can->($op); 598 $can->($op);
455 599
456 } elsif (exists $f_unsafe{$op_name}) { 600 } elsif (exists $f_unsafe{$op_name}) {
457 # unsafe, return to interpreter 601 # unsafe, return to interpreter
458 assert "nextop == (OP *)$$op"; 602 assert "nextop == (OP *)$$op";
459 $source .= " return nextop;\n"; 603 $source .= " return nextop;\n";
460 604
461 } elsif ("LOGOP" eq B::class $op) { 605 } elsif ("LOGOP" eq $class) {
462 # logical operation with optionaö branch 606 # logical operation with optional branch
463 out_callop; 607 out_callop;
464 out_cond_jump $op->other; 608 out_cond_jump $op->other;
465 out_jump_next; 609 out_jump_next;
466 610
467 } elsif ("PMOP" eq B::class $op) { 611 } elsif ("PMOP" eq $class) {
468 # regex-thingy 612 # regex-thingy
469 out_callop; 613 out_callop;
470 out_cond_jump $op->pmreplroot if ${$op->pmreplroot}; 614 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
471 out_jump_next; 615 out_jump_next;
472 616
473 } else { 617 } else {
474 # normal operator, linear execution 618 # normal operator, linear execution
475 out_linear; 619 out_linear;
… …
496 my $stem = "/tmp/Faster-$$-" . $uid++; 640 my $stem = "/tmp/Faster-$$-" . $uid++;
497 641
498 open FILE, ">:raw", "$stem.c"; 642 open FILE, ">:raw", "$stem.c";
499 print FILE <<EOF; 643 print FILE <<EOF;
500#define PERL_NO_GET_CONTEXT 644#define PERL_NO_GET_CONTEXT
645#define PERL_CORE
501 646
502#include <assert.h> 647#include <assert.h>
503 648
504#include "EXTERN.h" 649#include "EXTERN.h"
505#include "perl.h" 650#include "perl.h"
… …
541 686
542 my $pkg = $cv->STASH->NAME; 687 my $pkg = $cv->STASH->NAME;
543 688
544 return if $ignore{$pkg}; 689 return if $ignore{$pkg};
545 690
546 warn "compiling ", $cv->STASH->NAME;#d# 691 warn "compiling ", $cv->STASH->NAME, "\n"
692 if $verbose;
547 693
548 eval { 694 eval {
549 my @cv; 695 my @cv;
550 my @cv_source; 696 my @cv_source;
551 697
… …
582 728
5831; 7291;
584 730
585=back 731=back
586 732
733=head1 ENVIRONMENT VARIABLES
734
735The following environment variables influence the behaviour of Faster:
736
737=over 4
738
739=item FASTER_VERBOSE
740
741Faster will output more informational messages when set to values higher
742than C<0>. Currently, C<1> outputs which packages are being compiled.
743
744=item FASTER_DEBUG
745
746Add debugging code when set to values higher than C<0>. Currently, this
747adds 1-3 C<assert>'s per perl op, to ensure that opcode order and C
748execution order are compatible.
749
750=item FASTER_CACHE
751
752NOT YET IMPLEMENTED
753
754Set a persistent cache directory that caches compiled code
755fragments. Normally, code compiled by Faster will be deleted immediately,
756and every restart will recompile everything. Setting this variable to a
757directory makes Faster cache the generated files for re-use.
758
759This directory will always grow in contents, so you might need to erase it
760from time to time.
761
762=back
763
587=head1 BUGS/LIMITATIONS 764=head1 BUGS/LIMITATIONS
588 765
589Perl will check much less often for asynchronous signals in 766Perl will check much less often for asynchronous signals in
590Faster-compiled code. It tries to check on every function call, loop 767Faster-compiled code. It tries to check on every function call, loop
591iteration and every I/O operator, though. 768iteration and every I/O operator, though.

Diff Legend

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