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

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

Diff Legend

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