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

Comparing Faster/Faster.pm (file contents):
Revision 1.2 by root, Thu Mar 9 06:03:12 2006 UTC vs.
Revision 1.12 by root, Fri Mar 10 18:39:26 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
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 my $ppaddr = ppaddr $op->type;
61
62 $source .= " PL_op = (OP *)${$op->next}L;\n"; 168 $source .= " nextop = (OP *)${$op->next}L;\n";
63 $source .= " goto op_${$op->next};\n"; 169
170 out_jump_next;
64} 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;
65 189
66sub op_nextstate { 190sub op_nextstate {
67 my ($op) = @_;
68
69 $source .= " PL_curcop = (COP *)PL_op;\n"; 191 $source .= " PL_curcop = (COP *)nextop;\n";
70 $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";
71 $source .= " FREETMPS;\n"; 193 $source .= " FREETMPS;\n";
72 194
73 out_next $op; 195 out_next;
74} 196}
75 197
76sub op_const { 198sub op_pushmark {
77 my ($op) = @_; 199 $source .= " PUSHMARK (PL_stack_sp);\n";
78 200
201 out_next;
202}
203
204if (0 && $Config{useithreads} ne "define") {
205 # disable optimisations on ithreads
206
207 *op_const = sub {
79 $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n"; 208 $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
80 209
81 out_next $op; 210 out_next;
82} 211 };
83 212
84*op_gv = \&op_const; 213 *op_gv = \&op_const;
85 214
86sub entersub { 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
263# does kill Crossfire/res2pm
264sub op_stringify {
265 my $targ = $op->targ;
266
267 $source .= <<EOF;
268 {
269 dSP;
270 SV *targ = PAD_SV ((PADOFFSET)$targ);
271 sv_copypv (TARG, TOPs);
272 SETTARG;
273 PUTBACK;
274 }
275EOF
276
277 out_next;
278}
279
280sub op_and {
281 $source .= <<EOF;
282 {
283 dSP;
284
285 if (SvTRUE (TOPs))
286 {
287 --SP;
288 PUTBACK;
289 nextop = (OP *)${$op->other}L;
290 goto op_${$op->other};
291 }
292 }
293EOF
294
295 out_next;
296}
297
298sub op_or {
299 $source .= <<EOF;
300 {
301 dSP;
302
303 if (!SvTRUE (TOPs))
304 {
305 --SP;
306 PUTBACK;
307 nextop = (OP *)${$op->other}L;
308 goto op_${$op->other};
309 }
310 }
311EOF
312
313 out_next;
314}
315
316sub op_padsv {
317 my $flags = $op->flags;
318 my $target = $op->targ;
319
320 $source .= <<EOF;
321 {
322 dSP;
323 XPUSHs (PAD_SV ((PADOFFSET)$target));
324 PUTBACK;
325EOF
326 if ($op->flags & B::OPf_MOD) {
327 if ($op->private & B::OPpLVAL_INTRO) {
328 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n";
329 } elsif ($op->private & B::OPpDEREF) {
330 my $deref = $op->private & B::OPpDEREF;
331 $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
332 }
333 }
334 $source .= <<EOF;
335 }
336EOF
337
338 out_next;
339}
340
341# pattern const+ (or general push1)
342# pattern pushmark return(?)
343# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
344
345# pattern const method_named
346sub op_method_named {
347 $source .= <<EOF;
348 {
349 static HV *last_stash;
350 static SV *last_cv;
351 static U32 last_sub_generation;
352
353 SV *obj = *(PL_stack_base + TOPMARK + 1);
354
355 if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
356 {
357 dSP;
358 HV *stash = SvSTASH (SvRV (obj));
359
360 /* simple "polymorphic" inline cache */
361 if (stash == last_stash
362 && PL_sub_generation == last_sub_generation)
363 {
364 XPUSHs (last_cv);
365 PUTBACK;
366 }
367 else
368 {
369 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
370
371 SPAGAIN;
372 last_sub_generation = PL_sub_generation;
373 last_stash = stash;
374 last_cv = TOPs;
375 }
376 }
377 else
378 {
379 /* error case usually */
380 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
381 }
382 }
383EOF
384
385 out_next;
386}
387
388sub op_grepstart {
389 out_callop;
390 out_cond_jump $op->next->other;
391 out_jump_next;
392}
393
394*op_mapstart = \&op_grepstart;
395
396sub op_substcont {
397 out_callop;
398 out_cond_jump $op->other->pmreplstart;
399 assert "nextop == (OP *)${$op->other->next}L";
400 $source .= " goto op_${$op->other->next};\n";
401}
402
403sub out_break_op {
404 my ($idx) = @_;
405
406 out_callop;
407
408 out_cond_jump $_->[$idx]
409 for reverse @loop;
410
411 $source .= " return nextop;\n";
412}
413
414sub xop_next {
415 out_break_op 0;
416}
417
418sub op_last {
419 out_break_op 1;
420}
421
422sub xop_redo {
423 out_break_op 2;
424}
425
426sub cv2c {
87 my ($cv) = @_; 427 my ($cv) = @_;
88 428
429 @loop = ();
430
89 my %opsseen; 431 my %opsseen;
90 my @ops;
91 my @todo = $cv->START; 432 my @todo = $cv->START;
92 433
93 while (my $op = shift @todo) { 434 while (my $op = shift @todo) {
94 for (; $$op; $op = $op->next) { 435 for (; $$op; $op = $op->next) {
95 last if $opsseen{$$op}++; 436 last if $opsseen{$$op}++;
96 push @ops, $op; 437 push @ops, $op;
438
97 my $name = $op->name; 439 my $name = $op->name;
440 my $class = B::class $op;
441
98 if (B::class($op) eq "LOGOP") { 442 if ($class eq "LOGOP") {
99 push @todo, $op->other; 443 unshift @todo, $op->other; # unshift vs. push saves jumps
100 } elsif ($name eq "subst" and ${ $op->pmreplstart }) { 444 } elsif ($class eq "PMOP") {
101 push @todo, $op->pmreplstart; 445 unshift @todo, $op->pmreplstart if ${$op->pmreplstart};
102 } elsif ($name =~ /^enter(loop|iter)$/) { 446 } elsif ($class eq "LOOP") {
103# if ($] > 5.009) { 447 push @loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
104# $labels{${$op->nextop}} = "NEXT";
105# $labels{${$op->lastop}} = "LAST";
106# $labels{${$op->redoop}} = "REDO";
107# } else {
108# $labels{$op->nextop->seq} = "NEXT";
109# $labels{$op->lastop->seq} = "LAST";
110# $labels{$op->redoop->seq} = "REDO";
111# }
112 } 448 }
113 } 449 }
114 } 450 }
115 451
116 local $source; 452 local $source = <<EOF;
453OP *%%%FUNC%%% (pTHX)
454{
455 register OP *nextop = (OP *)${$ops[0]}L;
456EOF
117 457
118 $source = "typedef OP *(*PPFUNC)(pTHX);\n\n"; 458 while (@ops) {
119 459 $op = shift @ops;
120 $source .= "OP *func (pTHX)\n{\n";
121
122 for my $op (@ops) {
123 my $name = $op->name; 460 $op_name = $op->name;
124 my $ppaddr = ppaddr $op->type;
125 461
126 $source .= "op_$$op: /* $name */\n"; 462 $source .= "op_$$op: /* $op_name */\n";
463 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
464 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
127 465
466 $source .= " PERL_ASYNC_CHECK ();\n"
467 unless exists $flag{noasync}{$op_name};
468
128 if (my $can = __PACKAGE__->can ("op_$name")) { 469 if (my $can = __PACKAGE__->can ("op_$op_name")) {
470 # handcrafted replacement
129 $can->($op); 471 $can->($op);
130 } elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) { 472
131 $source .= " PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n";
132 $source .= " if (PL_op == (OP *)${$op->other}L) goto op_${$op->other};\n";
133 $source .= " goto op_${$op->next};\n";
134 } elsif (exists $flag{unsafe}{$name}) { 473 } elsif (exists $flag{unsafe}{$op_name}) {
135 $source .= " return ((PPFUNC)${ppaddr}L)(aTHX);\n"; 474 # unsafe, return to interpreter
475 assert "nextop == (OP *)$$op";
476 $source .= " return nextop;\n";
477
478 } elsif ("LOGOP" eq B::class $op) {
479 # logical operation with optionaö branch
480 out_callop;
481 out_cond_jump $op->other;
482 out_jump_next;
483
484 } elsif ("PMOP" eq B::class $op) {
485 # regex-thingy
486 out_callop;
487 out_cond_jump $op->pmreplroot if ${$op->pmreplroot};
488 out_jump_next;
489
136 } else { 490 } else {
137 $source .= " PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n"; 491 # normal operator, linear execution
138 $source .= " goto op_${$op->next};\n"; 492 out_linear;
139 } 493 }
140 } 494 }
141 495
496 $op_name = "func exit"; assert (0);
497
142 $source .= "}\n"; 498 $source .= <<EOF;
499op_0:
500 return 0;
501}
502EOF
503 #warn $source;
143 504
505 $source
506}
507
508sub source2ptr {
509 my ($source) = @_;
510
511 my $md5 = Digest::MD5::md5_hex $source;
512 $source =~ s/%%%FUNC%%%/Faster_$md5/;
513
514 my $stem = "/tmp/$md5";
515
516 unless (-e "$stem$_so") {
517 open FILE, ">:raw", "$stem.c";
144 print <<EOF; 518 print FILE <<EOF;
519#define PERL_NO_GET_CONTEXT
520
521#include <assert.h>
522
145#include "EXTERN.h" 523#include "EXTERN.h"
146#include "perl.h" 524#include "perl.h"
147#include "XSUB.h" 525#include "XSUB.h"
526
527#define RUNOPS_TILL(op) \\
528 while (nextop != (op)) \\
529 { \\
530 PERL_ASYNC_CHECK (); \\
531 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
532 }
533
148EOF 534EOF
149 print $source; 535 print FILE $source;
536 close FILE;
537 system "$COMPILE -o $stem$_o $stem.c";
538 system "$LINK -o $stem$_so $stem$_o $LIBS";
539 }
540
541# warn $source;
542 my $so = DynaLoader::dl_load_file "$stem$_so"
543 or die "$stem$_so: $!";
544
545 DynaLoader::dl_find_symbol $so, "Faster_$md5"
546 or die "Faster_$md5: $!"
547}
548
549sub entersub {
550 my ($cv) = @_;
551
552 # always compile the whole stash
553# my @stash = $cv->STASH->ARRAY;
554# warn join ":", @stash;
555# exit;
556
557 eval {
558 my $source = cv2c $cv;
559
560 my $ptr = source2ptr $source;
561
562 patch_cv $cv, $ptr;
563 };
564
565 warn $@ if $@;
150} 566}
151 567
152hook_entersub; 568hook_entersub;
153 569
1541; 5701;
155 571
156=back 572=back
157 573
158=head1 LIMITATIONS 574=head1 BUGS/LIMITATIONS
159 575
160Tainting and debugging will disable Faster. 576Perl will check much less often for asynchronous signals in
577Faster-compiled code. It tries to check on every function call, loop
578iteration and every I/O operator, though.
579
580The following things will disable Faster. If you manage to enable them at
581runtime, bad things will happen.
582
583 enabled tainting
584 enabled debugging
585
586This will dramatically reduce Faster's performance:
587
588 threads (but you don't care about speed if you use threads anyway)
589
590These constructs will force the use of the interpreter as soon as they are
591being executed, for the rest of the currently executed:
592
593 .., ... (flipflop operators)
594 goto
595 next, redo (but not well-behaved last's)
596 eval
597 require
598 any use of formats
161 599
162=head1 AUTHOR 600=head1 AUTHOR
163 601
164 Marc Lehmann <schmorp@schmorp.de> 602 Marc Lehmann <schmorp@schmorp.de>
165 http://home.schmorp.de/ 603 http://home.schmorp.de/

Diff Legend

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