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

Comparing Faster/Faster.pm (file contents):
Revision 1.23 by root, Fri Mar 10 22:45:18 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 ();
… …
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 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {#d#
340 return out_linear;#d#
341 }#d#
294 342
295 $source .= <<EOF; 343 $source .= <<EOF;
296 { 344 {
297 dSP; 345 dSP;
298 XPUSHs (PAD_SV ((PADOFFSET)$targ)); 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);
299 PUTBACK; 356 PUTBACK;
300EOF 357EOF
301 if ($op->flags & B::OPf_MOD) { 358
302 if ($op->private & B::OPpLVAL_INTRO) { 359 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
303 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$targ));\n"; 360 $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 } 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
309 $source .= <<EOF; 383 $source .= <<EOF;
384 SETs (right);
385 PUTBACK;
310 } 386 }
311EOF 387EOF
312 388
313 out_next; 389 out_next;
314} 390}
315 391
316# pattern const+ (or general push1) 392# pattern const+ (or general push1)
317# pattern pushmark return(?) 393# pattern pushmark return(?)
318# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 394# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
… …
334 410
335 /* simple "polymorphic" inline cache */ 411 /* simple "polymorphic" inline cache */
336 if (stash == last_stash 412 if (stash == last_stash
337 && PL_sub_generation == last_sub_generation) 413 && PL_sub_generation == last_sub_generation)
338 { 414 {
339 XPUSHs (last_cv); 415 PUSHs (last_cv);
340 PUTBACK; 416 PUTBACK;
341 } 417 }
342 else 418 else
343 { 419 {
344 PL_op = nextop; nextop = Perl_pp_method_named (aTHX); 420 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
… …
406 local @op_loop; 482 local @op_loop;
407 local %op_regcomp; 483 local %op_regcomp;
408 484
409 my %opsseen; 485 my %opsseen;
410 my @todo = $cv->START; 486 my @todo = $cv->START;
487 my %op_target;
411 488
412 while (my $op = shift @todo) { 489 while (my $op = shift @todo) {
413 for (; $$op; $op = $op->next) { 490 for (; $$op; $op = $op->next) {
414 last if $opsseen{$$op}++; 491 last if $opsseen{$$op}++;
415 push @ops, $op;
416 492
417 my $name = $op->name; 493 my $name = $op->name;
418 my $class = B::class $op; 494 my $class = B::class $op;
419 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
420 if ($class eq "LOGOP") { 508 if ($class eq "LOGOP") {
421 unshift @todo, $op->other; # unshift vs. push saves jumps 509 push @todo, $op->other;
510 $op_target{${$op->other}}++;
422 511
423 # 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}}++;
424 $op_regcomp{${$op->first}} = $op->next 515 $op_regcomp{${$op->first}} = $op->next;
425 if $name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP; 516 }
426 517
427 } elsif ($class eq "PMOP") { 518 } elsif ($class eq "PMOP") {
519 if (${$op->pmreplstart}) {
428 unshift @todo, $op->pmreplstart if ${$op->pmreplstart}; 520 unshift @todo, $op->pmreplstart;
521 $op_target{${$op->pmreplstart}}++;
522 }
429 523
430 } elsif ($class eq "LOOP") { 524 } 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; 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;
433 } 533 }
434 } 534 }
435 } 535 }
536
537 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
436 538
437 local $source = <<EOF; 539 local $source = <<EOF;
438OP *%%%FUNC%%% (pTHX) 540OP *%%%FUNC%%% (pTHX)
439{ 541{
440 register OP *nextop = (OP *)${$ops[0]}L; 542 register OP *nextop = (OP *)${$ops[0]->{op}}L;
441EOF 543EOF
442 544
443 while (@ops) { 545 while (@ops) {
444 $op = shift @ops; 546 $insn = shift @ops;
547
548 $op = $insn->{op};
445 $op_name = $op->name; 549 $op_name = $op->name;
446 550
447 my $class = B::class $op; 551 my $class = B::class $op;
448 552
553 $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
449 $source .= "op_$$op: /* $op_name */\n"; 554 $source .= "op_$$op: /* $op_name */\n";
450 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d# 555 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
451 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d# 556 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
452 557
453 $source .= " PERL_ASYNC_CHECK ();\n" 558 $source .= " PERL_ASYNC_CHECK ();\n"
454 unless exists $f_noasync{$op_name}; 559 unless exists $f_noasync{$op_name};
455 560
456 if (my $can = __PACKAGE__->can ("op_$op_name")) { 561 if (my $can = __PACKAGE__->can ("op_$op_name")) {
457 # 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
458 $can->($op); 578 $can->($op);
459 579
460 } elsif (exists $f_unsafe{$op_name}) { 580 } elsif (exists $f_unsafe{$op_name}) {
461 # unsafe, return to interpreter 581 # unsafe, return to interpreter
462 assert "nextop == (OP *)$$op"; 582 assert "nextop == (OP *)$$op";
… …
500 my $stem = "/tmp/Faster-$$-" . $uid++; 620 my $stem = "/tmp/Faster-$$-" . $uid++;
501 621
502 open FILE, ">:raw", "$stem.c"; 622 open FILE, ">:raw", "$stem.c";
503 print FILE <<EOF; 623 print FILE <<EOF;
504#define PERL_NO_GET_CONTEXT 624#define PERL_NO_GET_CONTEXT
625#define PERL_CORE
505 626
506#include <assert.h> 627#include <assert.h>
507 628
508#include "EXTERN.h" 629#include "EXTERN.h"
509#include "perl.h" 630#include "perl.h"

Diff Legend

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