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

Comparing Faster/Faster.pm (file contents):
Revision 1.3 by root, Thu Mar 9 06:35:33 2006 UTC vs.
Revision 1.11 by root, Fri Mar 10 18:29:08 2006 UTC

… …
13=cut 13=cut
14 14
15package Faster; 15package Faster;
16 16
17use strict; 17use strict;
18use Config;
19use B ();
20use Digest::MD5 ();
21use DynaLoader ();
18 22
19BEGIN { 23BEGIN {
20 our $VERSION = '0.01'; 24 our $VERSION = '0.01';
21 25
22 require XSLoader; 26 require XSLoader;
23 XSLoader::load __PACKAGE__, $VERSION; 27 XSLoader::load __PACKAGE__, $VERSION;
24} 28}
25 29
26use B (); 30my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}";
31my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
32my $LIBS = "$Config{libs}";
33my $_o = $Config{_o};
34my $_so = ".so";
35
36my $opt_assert = 1;
27 37
28our $source; 38our $source;
29our $label_next; 39
30our $label_last; 40my @ops;
31our $label_redo; 41my $op;
42my $op_name;
43my @loop;
32 44
33my %flag; 45my %flag;
34 46
47# complex flag steting is no longer required, rewrite this ugly code
35for (split /\n/, <<EOF) { 48for (split /\n/, <<EOF) {
36 leavesub unsafe 49 leavesub unsafe
37 leavesublv unsafe 50 leavesublv unsafe
38 return unsafe 51 return unsafe
39 flip unsafe 52 flip unsafe
… …
42 redo unsafe 55 redo unsafe
43 next unsafe 56 next unsafe
44 eval unsafe 57 eval unsafe
45 leaveeval unsafe 58 leaveeval unsafe
46 entertry unsafe 59 entertry unsafe
47 substconst unsafe
48 formline unsafe 60 formline unsafe
49 grepstart unsafe 61 grepstart unsafe
62 mapstart unsafe
63 substcont unsafe
64 entereval unsafe noasync todo
65 require unsafe
66
67 mapstart noasync
68 grepstart noasync
69 match noasync todo#whyisitunsafe? unsafe
70
71 last noasync
72 next noasync
73 redo noasync
74 seq noasync
75 pushmark noasync extend=0
76 padsv noasync extend=1
77 padav noasync extend=1
78 padhv noasync extend=1
79 padany noasync extend=1
80 entersub noasync
81 aassign noasync
82 sassign noasync
83 rv2av noasync
84 rv2cv noasync
85 rv2gv noasync
86 rv2hv noasync
87 refgen noasync
88 nextstate noasync
89 gv noasync
90 gvsv noasync
91 add noasync
92 subtract noasync
93 multiply noasync
94 divide noasync
95 complement noasync
96 cond_expr noasync
97 and noasync
98 or noasync
99 not noasync
100 defined noasync
101 method_named noasync
102 preinc noasync
103 postinc noasync
104 predec noasync
105 postdec noasync
106 stub noasync
107 unstack noasync
108 leaveloop noasync
109 aelem noasync
110 aelemfast noasync
111 helem noasync
112 pushre noasync
113 subst noasync
114 const noasync extend=1
115 list noasync
116 join noasync
117 split noasync
118 concat noasync
119 push noasync
120 pop noasync
121 shift noasync
122 unshift noasync
123 length noasync
124 substr noasync
125 stringify noasync
126 eq noasync
127 ne noasync
128 gt noasync
129 lt noasync
130 ge noasync
131 le noasync
132 enteriter noasync
133 ord noasync
134
135 iter async
50EOF 136EOF
51 my (undef, $op, @flags) = split /\s+/; 137 my (undef, $op, @flags) = split /\s+/;
52 138
53 undef $flag{$_}{$op} 139 undef $flag{$_}{$op}
54 for ("known", @flags); 140 for ("known", @flags);
55} 141}
56 142
143my %callop = (
144 entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)",
145 mapstart => "Perl_pp_grepstart (aTHX)",
146);
147
148sub callop {
149 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
150}
151
152sub assert {
153 return unless $opt_assert;
154 $source .= " assert ((\"$op_name\", ($_[0])));\n";
155}
156
157sub out_callop {
158 assert "nextop == (OP *)$$op";
159 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
160}
161
162sub out_jump_next {
163 assert "nextop == (OP *)${$op->next}";
164 $source .= " goto op_${$op->next};\n";
165}
166
57sub out_next { 167sub out_next {
58 my ($op) = @_;
59
60 $source .= " PL_op = (OP *)${$op->next}L;\n"; 168 $source .= " nextop = (OP *)${$op->next}L;\n";
61 $source .= " goto op_${$op->next};\n"; 169
170 out_jump_next;
62} 171}
172
173sub out_linear {
174 out_callop;
175 out_jump_next;
176}
177
178sub out_cond_jump {
179 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
180}
181
182sub op_entersub {
183 out_callop;
184 $source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n";
185 out_jump_next;
186}
187
188*op_require = \&op_entersub;
63 189
64sub op_nextstate { 190sub op_nextstate {
65 my ($op) = @_;
66
67 $source .= " PL_curcop = (COP *)PL_op;\n"; 191 $source .= " PL_curcop = (COP *)nextop;\n";
68 $source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n"; 192 $source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
69 $source .= " FREETMPS;\n"; 193 $source .= " FREETMPS;\n";
70 194
71 out_next $op; 195 out_next;
72} 196}
73 197
74sub op_pushmark { 198sub op_pushmark {
75 my ($op) = @_;
76
77 $source .= " PUSHMARK (PL_stack_sp);\n"; 199 $source .= " PUSHMARK (PL_stack_sp);\n";
78 200
79 out_next $op; 201 out_next;
80} 202}
81 203
82sub op_const { 204if (0 && $Config{useithreads} ne "define") {
83 my ($op) = @_; 205 # disable optimisations on ithreads
84 206
207 *op_const = sub {
85 $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n"; 208 $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
86 209
87 out_next $op; 210 out_next;
88} 211 };
89 212
90*op_gv = \&op_const; 213 *op_gv = \&op_const;
91 214
215 *op_aelemfast = sub {
216 my $targ = $op->targ;
217 my $private = $op->private;
218
219 $source .= " {\n";
220
221 if ($op->flags & B::OPf_SPECIAL) {
222 $source .= " AV *av = (AV*)PAD_SV((PADOFFSET)$targ);\n";
223 } else {
224 $source .= " AV *av = GvAV ((GV *)${$op->sv}L);\n";
225 }
226
227 if ($op->flags & B::OPf_MOD) {
228 $source .= " SV *sv = *av_fetch (av, $private, 1);\n";
229 } else {
230 $source .= " SV **svp = av_fetch (av, $private, 0); SV *sv = svp ? *svp : &PL_sv_undef;\n";
231 }
232
233 if (!($op->flags & B::OPf_MOD)) {
234 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
235 }
236
237 $source .= " dSP;\n";
238 $source .= " XPUSHs (sv);\n";
239 $source .= " PUTBACK;\n";
240 $source .= " }\n";
241
242 out_next;
243 };
244
245 *op_gvsv = sub {
246 $source .= " {\n";
247 $source .= " dSP;\n";
248 $source .= " EXTEND (SP, 1);\n";
249
250 if ($op->private & B::OPpLVAL_INTRO) {
251 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
252 } else {
253 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
254 }
255
256 $source .= " PUTBACK;\n";
257 $source .= " }\n";
258
259 out_next;
260 };
261}
262
92sub op_stringify { 263sub xop_stringify {
93 my ($op) = @_;
94
95 $source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n"; 264 $source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; PUTBACK; }\n";
96 265
97 out_next $op; 266 out_next;
267}
268
269sub op_and {
270 $source .= <<EOF;
271 {
272 dSP;
273
274 if (SvTRUE (TOPs))
275 {
276 --SP;
277 PUTBACK;
278 nextop = (OP *)${$op->other}L;
279 goto op_${$op->other};
280 }
281 }
282EOF
283
284 out_next;
285}
286
287sub op_or {
288 $source .= <<EOF;
289 {
290 dSP;
291
292 if (!SvTRUE (TOPs))
293 {
294 --SP;
295 PUTBACK;
296 nextop = (OP *)${$op->other}L;
297 goto op_${$op->other};
298 }
299 }
300EOF
301
302 out_next;
303}
304
305sub op_padsv {
306 my $flags = $op->flags;
307 my $target = $op->targ;
308
309 $source .= <<EOF;
310 {
311 dSP;
312 XPUSHs (PAD_SV ((PADOFFSET)$target));
313 PUTBACK;
314EOF
315 if ($op->flags & B::OPf_MOD) {
316 if ($op->private & B::OPpLVAL_INTRO) {
317 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n";
318 } elsif ($op->private & B::OPpDEREF) {
319 my $deref = $op->private & B::OPpDEREF;
320 $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
321 }
322 }
323 $source .= <<EOF;
324 }
325EOF
326
327 out_next;
98} 328}
99 329
100# pattern const+ (or general push1) 330# pattern const+ (or general push1)
101# pattern pushmark return(?) 331# pattern pushmark return(?)
102# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 332# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
103 333
104# pattern const method_named 334# pattern const method_named
105sub xop_method_named { 335sub xop_method_named {
106 my ($op) = @_;
107
108 my $ppaddr = ppaddr $op->type;
109
110 $source .= <<EOF; 336 $source .= <<EOF;
111 { 337 {
112 dSP; 338 static HV *last_stash;
339 static SV *last_cv;
340 static U32 last_sub_generation;
113 341
114 if (SvROK (TOPm1s) && SvOBJECT (SvRV (TOPm1s))) 342 SV *obj = *(PL_stack_base + TOPMARK + 1);
343
344 if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
115 { 345 {
116 static SV *last_stash, SV *last_res; 346 dSP;
117 SV *stash = SvSTASH (SvRV (TOPm1s)); 347 HV *stash = SvSTASH (SvRV (obj));
118 348
119 // simple polymorphic inline cache 349 /* simple "polymorphic" inline cache */
120 if (stash == last_stash) 350 if (stash == last_stash
351 && PL_sub_generation == last_sub_generation)
121 { 352 {
353 XPUSHs (last_cv);
122 dTARGET; 354 PUTBACK;
123 SETTARG (last_res);
124 } 355 }
125 else 356 else
126 { 357 {
127 PUTBACK; 358 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
128 ((PPFUNC)${ppaddr}L)(aTHX);\n"; 359
129 SPAGAIN; 360 SPAGAIN;
130 361 last_sub_generation = PL_sub_generation;
131 last_stash = stash; 362 last_stash = stash;
132 last_res = TOPs; 363 last_cv = TOPs;
133 } 364 }
134 } 365 }
366 else
367 {
368 /* error case usually */
369 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
370 }
135 } 371 }
136EOF 372EOF
137 373
138 out_next $op; 374 out_next;
139} 375}
140 376
141sub entersub { 377sub op_grepstart {
378 out_callop;
379 out_cond_jump $op->next->other;
380 out_jump_next;
381}
382
383*op_mapstart = \&op_grepstart;
384
385sub op_substcont {
386 out_callop;
387 out_cond_jump $op->other->pmreplstart;
388 assert "nextop == (OP *)${$op->other->next}L";
389 $source .= " goto op_${$op->other->next};\n";
390}
391
392sub out_break_op {
393 my ($idx) = @_;
394
395 out_callop;
396
397 out_cond_jump $_->[$idx]
398 for reverse @loop;
399
400 $source .= " return nextop;\n";
401}
402
403sub xop_next {
404 out_break_op 0;
405}
406
407sub op_last {
408 out_break_op 1;
409}
410
411sub xop_redo {
412 out_break_op 2;
413}
414
415sub cv2c {
142 my ($cv) = @_; 416 my ($cv) = @_;
143 417
418 @loop = ();
419
144 my %opsseen; 420 my %opsseen;
145 my @ops;
146 my @todo = $cv->START; 421 my @todo = $cv->START;
147 422
148 while (my $op = shift @todo) { 423 while (my $op = shift @todo) {
149 for (; $$op; $op = $op->next) { 424 for (; $$op; $op = $op->next) {
150 last if $opsseen{$$op}++; 425 last if $opsseen{$$op}++;
151 push @ops, $op; 426 push @ops, $op;
427
152 my $name = $op->name; 428 my $name = $op->name;
429 my $class = B::class $op;
430
153 if (B::class($op) eq "LOGOP") { 431 if ($class eq "LOGOP") {
154 push @todo, $op->other; 432 unshift @todo, $op->other; # unshift vs. push saves jumps
155 } elsif ($name eq "subst" and ${ $op->pmreplstart }) { 433 } elsif ($class eq "PMOP") {
156 push @todo, $op->pmreplstart; 434 unshift @todo, $op->pmreplstart if ${$op->pmreplstart};
157 } elsif ($name =~ /^enter(loop|iter)$/) { 435 } elsif ($class eq "LOOP") {
158# if ($] > 5.009) { 436 push @loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
159# $labels{${$op->nextop}} = "NEXT";
160# $labels{${$op->lastop}} = "LAST";
161# $labels{${$op->redoop}} = "REDO";
162# } else {
163# $labels{$op->nextop->seq} = "NEXT";
164# $labels{$op->lastop->seq} = "LAST";
165# $labels{$op->redoop->seq} = "REDO";
166# }
167 } 437 }
168 } 438 }
169 } 439 }
170 440
171 local $source; 441 local $source = <<EOF;
442OP *%%%FUNC%%% (pTHX)
443{
444 register OP *nextop = (OP *)${$ops[0]}L;
445EOF
172 446
173 $source = "typedef OP *(*PPFUNC)(pTHX);\n\n"; 447 while (@ops) {
174 448 $op = shift @ops;
175 $source .= "OP *func (pTHX)\n{\n dTHX;\n";
176
177 for my $op (@ops) {
178 my $name = $op->name; 449 $op_name = $op->name;
179 my $ppaddr = ppaddr $op->type;
180 450
181 $source .= "op_$$op: /* $name */\n"; 451 $source .= "op_$$op: /* $op_name */\n";
452 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
453 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
182 454
455 $source .= " PERL_ASYNC_CHECK ();\n"
456 unless exists $flag{noasync}{$op_name};
457
183 if (my $can = __PACKAGE__->can ("op_$name")) { 458 if (my $can = __PACKAGE__->can ("op_$op_name")) {
459 # handcrafted replacement
184 $can->($op); 460 $can->($op);
185 } elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) { 461
186 $source .= " PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n";
187 $source .= " if (PL_op == (OP *)${$op->other}L) goto op_${$op->other};\n";
188 $source .= " goto op_${$op->next};\n";
189 } elsif (exists $flag{unsafe}{$name}) { 462 } elsif (exists $flag{unsafe}{$op_name}) {
190 $source .= " return ((PPFUNC)${ppaddr}L)(aTHX);\n"; 463 # unsafe, return to interpreter
464 assert "nextop == (OP *)$$op";
465 $source .= " return nextop;\n";
466
467 } elsif ("LOGOP" eq B::class $op) {
468 # logical operation with optionaö branch
469 out_callop;
470 out_cond_jump $op->other;
471 out_jump_next;
472
473 } elsif ("PMOP" eq B::class $op) {
474 # regex-thingy
475 out_callop;
476 out_cond_jump $op->pmreplroot if ${$op->pmreplroot};
477 out_jump_next;
478
191 } else { 479 } else {
192 $source .= " PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n"; 480 # normal operator, linear execution
193 $source .= " goto op_${$op->next};\n"; 481 out_linear;
194 } 482 }
195 } 483 }
196 484
485 $op_name = "func exit"; assert (0);
486
197 $source .= "}\n"; 487 $source .= <<EOF;
488op_0:
489 return 0;
490}
491EOF
492 #warn $source;
198 493
494 $source
495}
496
497sub source2ptr {
498 my ($source) = @_;
499
500 my $md5 = Digest::MD5::md5_hex $source;
501 $source =~ s/%%%FUNC%%%/Faster_$md5/;
502
503 my $stem = "/tmp/$md5";
504
505 unless (-e "$stem$_so") {
506 open FILE, ">:raw", "$stem.c";
199 print <<EOF; 507 print FILE <<EOF;
508#define PERL_NO_GET_CONTEXT
509
510#include <assert.h>
511
200#include "EXTERN.h" 512#include "EXTERN.h"
201#include "perl.h" 513#include "perl.h"
202#include "XSUB.h" 514#include "XSUB.h"
515
516#define RUNOPS_TILL(op) \\
517 while (nextop != (op)) \\
518 { \\
519 PERL_ASYNC_CHECK (); \\
520 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
521 }
522
203EOF 523EOF
204 print $source; 524 print FILE $source;
525 close FILE;
526 system "$COMPILE -o $stem$_o $stem.c";
527 system "$LINK -o $stem$_so $stem$_o $LIBS";
528 }
529
530# warn $source;
531 my $so = DynaLoader::dl_load_file "$stem$_so"
532 or die "$stem$_so: $!";
533
534 DynaLoader::dl_find_symbol $so, "Faster_$md5"
535 or die "Faster_$md5: $!"
536}
537
538sub entersub {
539 my ($cv) = @_;
540
541 # always compile the whole stash
542# my @stash = $cv->STASH->ARRAY;
543# warn join ":", @stash;
544# exit;
545
546 eval {
547 my $source = cv2c $cv;
548
549 my $ptr = source2ptr $source;
550
551 patch_cv $cv, $ptr;
552 };
553
554 warn $@ if $@;
205} 555}
206 556
207hook_entersub; 557hook_entersub;
208 558
2091; 5591;
210 560
211=back 561=back
212 562
213=head1 LIMITATIONS 563=head1 BUGS/LIMITATIONS
214 564
215Tainting and debugging will disable Faster. 565Perl will check much less often for asynchronous signals in
566Faster-compiled code. It tries to check on every function call, loop
567iteration and every I/O operator, though.
568
569The following things will disable Faster. If you manage to enable them at
570runtime, bad things will happen.
571
572 enabled tainting
573 enabled debugging
574
575This will dramatically reduce Faster's performance:
576
577 threads (but you don't care about speed if you use threads anyway)
578
579These constructs will force the use of the interpreter as soon as they are
580being executed, for the rest of the currently executed:
581
582 .., ... (flipflop operators)
583 goto
584 next, redo (but not well-behaved last's)
585 eval
586 require
587 any use of formats
216 588
217=head1 AUTHOR 589=head1 AUTHOR
218 590
219 Marc Lehmann <schmorp@schmorp.de> 591 Marc Lehmann <schmorp@schmorp.de>
220 http://home.schmorp.de/ 592 http://home.schmorp.de/

Diff Legend

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