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

Comparing Faster/Faster.pm (file contents):
Revision 1.21 by root, Fri Mar 10 22:39:11 2006 UTC vs.
Revision 1.25 by root, Sat Mar 11 04:58:53 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;
… …
64my $verbose = $ENV{FASTER_VERBOSE}+0; 67my $verbose = $ENV{FASTER_VERBOSE}+0;
65 68
66our $source; 69our $source;
67 70
68our @ops; 71our @ops;
72our $insn;
69our $op; 73our $op;
70our $op_name; 74our $op_name;
71our @op_loop; 75our @op_loop;
72our %op_regcomp; 76our %op_regcomp;
73 77
78# ops that cause immediate return to the interpreter
74my %f_unsafe = map +($_ => undef), qw( 79my %f_unsafe = map +($_ => undef), qw(
75 leavesub leavesublv return 80 leavesub leavesublv return
76 goto last redo next 81 goto last redo next
77 eval flip leaveeval entertry 82 eval flip leaveeval entertry
78 formline grepstart mapstart 83 formline grepstart mapstart
79 substcont entereval require 84 substcont entereval require
80); 85);
81 86
82# pushmark extend=0 87# ops with known stack extend behaviour
83# padsv extend=1 88# the values given are maximum values
84# padav extend=1 89my %extend = (
85# padhv extend=1 90 pushmark => 0,
86# padany extend=1 91 nextstate => 0, # might reduce the stack
87# const extend=1 92 unstack => 0,
93 enter => 0,
88 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
89my %f_noasync = map +($_ => undef), qw( 134my %f_noasync = map +($_ => undef), qw(
90 mapstart grepstart match entereval 135 mapstart grepstart match entereval
91 enteriter entersub leaveloop 136 enteriter entersub leaveloop
92 137
93 pushmark nextstate 138 pushmark nextstate
… …
99 rv2av rv2cv rv2gv rv2hv refgen 144 rv2av rv2cv rv2gv rv2hv refgen
100 gv gvsv 145 gv gvsv
101 add subtract multiply divide 146 add subtract multiply divide
102 complement cond_expr and or not 147 complement cond_expr and or not
103 defined 148 defined
104 method_named 149 method method_named bless
105 preinc postinc predec postdec 150 preinc postinc predec postdec
106 aelem aelemfast helem delete exists 151 aelem aelemfast helem delete exists
107 pushre subst list join split concat 152 pushre subst list join split concat
108 length substr stringify ord 153 length substr stringify ord
109 push pop shift unshift 154 push pop shift unshift
… …
177 222
178if ($Config{useithreads} ne "define") { 223if ($Config{useithreads} ne "define") {
179 # disable optimisations on ithreads 224 # disable optimisations on ithreads
180 225
181 *op_const = sub { 226 *op_const = sub {
182 $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n"; 227 $source .= " { dSP; PUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
183 228
184 out_next; 229 out_next;
185 }; 230 };
186 231
187 *op_gv = \&op_const; 232 *op_gv = \&op_const;
… …
207 if (!($op->flags & B::OPf_MOD)) { 252 if (!($op->flags & B::OPf_MOD)) {
208 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n"; 253 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
209 } 254 }
210 255
211 $source .= " dSP;\n"; 256 $source .= " dSP;\n";
212 $source .= " XPUSHs (sv);\n"; 257 $source .= " PUSHs (sv);\n";
213 $source .= " PUTBACK;\n"; 258 $source .= " PUTBACK;\n";
214 $source .= " }\n"; 259 $source .= " }\n";
215 260
216 out_next; 261 out_next;
217 }; 262 };
218 263
219 *op_gvsv = sub { 264 *op_gvsv = sub {
220 $source .= " {\n"; 265 $source .= " {\n";
221 $source .= " dSP;\n"; 266 $source .= " dSP;\n";
222 $source .= " EXTEND (SP, 1);\n";
223 267
224 if ($op->private & B::OPpLVAL_INTRO) { 268 if ($op->private & B::OPpLVAL_INTRO) {
225 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n"; 269 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
226 } else { 270 } else {
227 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n"; 271 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
… …
287 out_next; 331 out_next;
288} 332}
289 333
290sub op_padsv { 334sub op_padsv {
291 my $flags = $op->flags; 335 my $flags = $op->flags;
292 my $targ = $op->targ; 336 my $padofs = "(PADOFFSET)" . $op->targ;
337
338 #d#TODO: why does our version break
339 # breaks gce with can't coerce array....
340 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {#d#
341 return out_linear;#d#
342 }#d#
293 343
294 $source .= <<EOF; 344 $source .= <<EOF;
295 { 345 {
296 dSP; 346 dSP;
297 XPUSHs (PAD_SV ((PADOFFSET)$targ)); 347 SV *sv = PAD_SVl ($padofs);
348EOF
349
350 if (($flags & B::OPf_MOD) && ($op->private & B::OPpLVAL_INTRO)) {
351 $source .= " SAVECLEARSV (PAD_SVl ($padofs));\n";
352 $ops[0]{pre_padsv_lval_intro}++ if @ops;#d#
353 }
354
355 $source .= <<EOF;
356 PUSHs (sv);
298 PUTBACK; 357 PUTBACK;
299EOF 358EOF
300 if ($op->flags & B::OPf_MOD) { 359
301 if ($op->private & B::OPpLVAL_INTRO) { 360 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
302 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$targ));\n"; 361 $source .= " vivify_ref (sv, $flags & OPpDEREF);\n";
303 } elsif ($op->private & B::OPpDEREF) {
304 my $deref = $op->private & B::OPpDEREF;
305 $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$targ), $deref);\n";
306 }
307 } 362 }
363 $source .= " }\n";
364
365 out_next;
366}
367
368sub op_sassign {
369 $source .= <<EOF;
370 {
371 dSP;
372 dPOPTOPssrl;
373EOF
374 $source .= " SV *temp = left; left = right; right = temp;\n"
375 if $op->private & B::OPpASSIGN_BACKWARDS;
376
377 if ($insn->{pre_padsv_lval_intro} && !($op->private & B::OPpASSIGN_BACKWARDS)) {
378 # simple assignment - the target exists, but is basically undef
379 $source .= " SvSetSV (right, left);\n";
380 } else {
381 $source .= " SvSetMagicSV (right, left);\n";
382 }
383
308 $source .= <<EOF; 384 $source .= <<EOF;
385 SETs (right);
386 PUTBACK;
309 } 387 }
310EOF 388EOF
311 389
312 out_next; 390 out_next;
313} 391}
314 392
315# pattern const+ (or general push1) 393# pattern const+ (or general push1)
316# pattern pushmark return(?) 394# pattern pushmark return(?)
317# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 395# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
… …
333 411
334 /* simple "polymorphic" inline cache */ 412 /* simple "polymorphic" inline cache */
335 if (stash == last_stash 413 if (stash == last_stash
336 && PL_sub_generation == last_sub_generation) 414 && PL_sub_generation == last_sub_generation)
337 { 415 {
338 XPUSHs (last_cv); 416 PUSHs (last_cv);
339 PUTBACK; 417 PUTBACK;
340 } 418 }
341 else 419 else
342 { 420 {
343 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 421 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
… …
405 local @op_loop; 483 local @op_loop;
406 local %op_regcomp; 484 local %op_regcomp;
407 485
408 my %opsseen; 486 my %opsseen;
409 my @todo = $cv->START; 487 my @todo = $cv->START;
488 my %op_target;
410 489
411 while (my $op = shift @todo) { 490 while (my $op = shift @todo) {
412 for (; $$op; $op = $op->next) { 491 for (; $$op; $op = $op->next) {
413 last if $opsseen{$$op}++; 492 last if $opsseen{$$op}++;
414 push @ops, $op;
415 493
416 my $name = $op->name; 494 my $name = $op->name;
417 my $class = B::class $op; 495 my $class = B::class $op;
418 496
497 my $insn = { op => $op };
498
499 push @ops, $insn;
500
501 if (exists $extend{$name}) {
502 my $extend = $extend{$name};
503 $extend = $extend->($op) if ref $extend;
504 $insn->{extend} = $extend if defined $extend;
505 }
506
507 push @todo, $op->next;
508
419 if ($class eq "LOGOP") { 509 if ($class eq "LOGOP") {
420 unshift @todo, $op->other; # unshift vs. push saves jumps 510 push @todo, $op->other;
511 $op_target{${$op->other}}++;
421 512
422 # regcomp/o patches ops at runtime, lets expect that 513 # regcomp/o patches ops at runtime, lets expect that
514 if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
515 $op_target{${$op->first}}++;
423 $op_regcomp{${$op->first}} = $op->next 516 $op_regcomp{${$op->first}} = $op->next;
424 if $name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP; 517 }
425 518
426 } elsif ($class eq "PMOP") { 519 } elsif ($class eq "PMOP") {
520 if (${$op->pmreplstart}) {
427 unshift @todo, $op->pmreplstart if ${$op->pmreplstart}; 521 unshift @todo, $op->pmreplstart;
522 $op_target{${$op->pmreplstart}}++;
523 }
428 524
429 } elsif ($class eq "LOOP") { 525 } elsif ($class eq "LOOP") {
430 push @op_loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
431 push @todo, $op->nextop, $op->lastop->next, $op->redoop->next; 526 my @targ = ($op->nextop, $op->lastop->next, $op->redoop->next);
527
528 push @op_loop, \@targ;
529 push @todo, @targ;
530
531 $op_target{$$_}++ for @targ;
532 } elsif ($class eq "COP") {
533 $insn->{bblock}++ if defined $op->label;
432 } 534 }
433 } 535 }
434 } 536 }
537
538 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
435 539
436 local $source = <<EOF; 540 local $source = <<EOF;
437OP *%%%FUNC%%% (pTHX) 541OP *%%%FUNC%%% (pTHX)
438{ 542{
439 register OP *nextop = (OP *)${$ops[0]}L; 543 register OP *nextop = (OP *)${$ops[0]->{op}}L;
440EOF 544EOF
441 545
442 while (@ops) { 546 while (@ops) {
443 $op = shift @ops; 547 $insn = shift @ops;
548
549 $op = $insn->{op};
444 $op_name = $op->name; 550 $op_name = $op->name;
445 551
552 my $class = B::class $op;
553
554 $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
446 $source .= "op_$$op: /* $op_name */\n"; 555 $source .= "op_$$op: /* $op_name */\n";
447 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d# 556 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
448 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d# 557 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
449 558
450 $source .= " PERL_ASYNC_CHECK ();\n" 559 $source .= " PERL_ASYNC_CHECK ();\n"
451 unless exists $f_noasync{$op_name}; 560 unless exists $f_noasync{$op_name};
452 561
453 if (my $can = __PACKAGE__->can ("op_$op_name")) { 562 if (my $can = __PACKAGE__->can ("op_$op_name")) {
454 # handcrafted replacement 563 # handcrafted replacement
564
565 if ($insn->{extend} > 0) {
566 # coalesce EXTENDs
567 # TODO: properly take negative preceeding and following EXTENDs into account
568 for my $i (@ops) {
569 last if exists $i->{bblock};
570 last unless exists $i->{extend};
571 my $extend = delete $i->{extend};
572 $insn->{extend} += $extend if $extend > 0;
573 }
574
575 $source .= " { dSP; EXTEND (SP, $insn->{extend}); PUTBACK; }\n"
576 if $insn->{extend} > 0;
577 }
578
455 $can->($op); 579 $can->($op);
456 580
457 } elsif (exists $f_unsafe{$op_name}) { 581 } elsif (exists $f_unsafe{$op_name}) {
458 # unsafe, return to interpreter 582 # unsafe, return to interpreter
459 assert "nextop == (OP *)$$op"; 583 assert "nextop == (OP *)$$op";
460 $source .= " return nextop;\n"; 584 $source .= " return nextop;\n";
461 585
462 } elsif ("LOGOP" eq B::class $op) { 586 } elsif ("LOGOP" eq $class) {
463 # logical operation with optionaö branch 587 # logical operation with optional branch
464 out_callop; 588 out_callop;
465 out_cond_jump $op->other; 589 out_cond_jump $op->other;
466 out_jump_next; 590 out_jump_next;
467 591
468 } elsif ("PMOP" eq B::class $op) { 592 } elsif ("PMOP" eq $class) {
469 # regex-thingy 593 # regex-thingy
470 out_callop; 594 out_callop;
471 out_cond_jump $op->pmreplroot if ${$op->pmreplroot}; 595 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
472 out_jump_next; 596 out_jump_next;
473 597
474 } else { 598 } else {
475 # normal operator, linear execution 599 # normal operator, linear execution
476 out_linear; 600 out_linear;
… …
497 my $stem = "/tmp/Faster-$$-" . $uid++; 621 my $stem = "/tmp/Faster-$$-" . $uid++;
498 622
499 open FILE, ">:raw", "$stem.c"; 623 open FILE, ">:raw", "$stem.c";
500 print FILE <<EOF; 624 print FILE <<EOF;
501#define PERL_NO_GET_CONTEXT 625#define PERL_NO_GET_CONTEXT
626#define PERL_CORE
502 627
503#include <assert.h> 628#include <assert.h>
504 629
505#include "EXTERN.h" 630#include "EXTERN.h"
506#include "perl.h" 631#include "perl.h"

Diff Legend

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