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

Comparing Faster/Faster.pm (file contents):
Revision 1.4 by root, Thu Mar 9 22:32:17 2006 UTC vs.
Revision 1.12 by root, Fri Mar 10 18:39:26 2006 UTC

… …
31my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}"; 31my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
32my $LIBS = "$Config{libs}"; 32my $LIBS = "$Config{libs}";
33my $_o = $Config{_o}; 33my $_o = $Config{_o};
34my $_so = ".so"; 34my $_so = ".so";
35 35
36my $opt_assert = 1;
37
36our $source; 38our $source;
37our $label_next; 39
38our $label_last; 40my @ops;
39our $label_redo; 41my $op;
42my $op_name;
43my @loop;
40 44
41my %flag; 45my %flag;
42 46
47# complex flag steting is no longer required, rewrite this ugly code
43for (split /\n/, <<EOF) { 48for (split /\n/, <<EOF) {
44 leavesub unsafe 49 leavesub unsafe
45 leavesublv unsafe 50 leavesublv unsafe
46 return unsafe 51 return unsafe
47 flip unsafe 52 flip unsafe
… …
50 redo unsafe 55 redo unsafe
51 next unsafe 56 next unsafe
52 eval unsafe 57 eval unsafe
53 leaveeval unsafe 58 leaveeval unsafe
54 entertry unsafe 59 entertry unsafe
55 substconst unsafe
56 formline unsafe 60 formline unsafe
57 grepstart unsafe 61 grepstart unsafe
62 mapstart unsafe
63 substcont unsafe
64 entereval unsafe noasync todo
58 require unsafe 65 require unsafe
59 66
67 mapstart noasync
60 pushmark noasync 68 grepstart noasync
69 match noasync
70
61 padsv noasync 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
62 entersub noasync 80 entersub noasync
63 aassign noasync 81 aassign noasync
64 sassign noasync 82 sassign noasync
65 rv2av noasync 83 rv2av noasync
84 rv2cv noasync
85 rv2gv noasync
86 rv2hv noasync
87 refgen noasync
66 nextstate noasync 88 nextstate noasync
67 gv noasync 89 gv noasync
68 gvsv noasync 90 gvsv noasync
69 add noasync 91 add noasync
70 subtract noasync 92 subtract noasync
… …
73 complement noasync 95 complement noasync
74 cond_expr noasync 96 cond_expr noasync
75 and noasync 97 and noasync
76 or noasync 98 or noasync
77 not noasync 99 not noasync
100 defined noasync
78 method_named noasync 101 method_named noasync
79 preinc noasync 102 preinc noasync
80 postinc noasync 103 postinc noasync
81 predec noasync 104 predec noasync
82 postdec noasync 105 postdec noasync
83 stub noasync 106 stub noasync
84 unstack noasync 107 unstack noasync
85 leaveloop noasync 108 leaveloop noasync
86 shift noasync
87 aelemA noasync 109 aelem noasync
88 aelemfast 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
89EOF 136EOF
90 my (undef, $op, @flags) = split /\s+/; 137 my (undef, $op, @flags) = split /\s+/;
91 138
92 undef $flag{$_}{$op} 139 undef $flag{$_}{$op}
93 for ("known", @flags); 140 for ("known", @flags);
94} 141}
95 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
96sub out_next { 167sub out_next {
97 my ($op) = @_;
98
99 $source .= " nextop = (OP *)${$op->next}L;\n"; 168 $source .= " nextop = (OP *)${$op->next}L;\n";
100 $source .= " goto op_${$op->next};\n";
101}
102 169
103sub callop { 170 out_jump_next;
104 my ($op) = @_;
105
106 my $name = $op->name;
107
108 $name eq "entersub"
109 ? "(PL_ppaddr [OP_ENTERSUB]) (aTHX)"
110 : "Perl_pp_$name (aTHX)"
111} 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;
112 189
113sub op_nextstate { 190sub op_nextstate {
114 my ($op) = @_;
115
116 $source .= " PL_curcop = (COP *)nextop;\n"; 191 $source .= " PL_curcop = (COP *)nextop;\n";
117 $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";
118 $source .= " FREETMPS;\n"; 193 $source .= " FREETMPS;\n";
119 194
120 out_next $op; 195 out_next;
121} 196}
122 197
123sub op_pushmark { 198sub op_pushmark {
124 my ($op) = @_;
125
126 $source .= " PUSHMARK (PL_stack_sp);\n"; 199 $source .= " PUSHMARK (PL_stack_sp);\n";
127 200
128 out_next $op; 201 out_next;
129} 202}
130 203
131sub op_const { 204if (0 && $Config{useithreads} ne "define") {
132 my ($op) = @_; 205 # disable optimisations on ithreads
133 206
207 *op_const = sub {
134 $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n"; 208 $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
135 209
136 out_next $op; 210 out_next;
137} 211 };
138 212
139*op_gv = \&op_const; 213 *op_gv = \&op_const;
140 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
263# does kill Crossfire/res2pm
141sub op_stringify { 264sub op_stringify {
142 my ($op) = @_; 265 my $targ = $op->targ;
143
144 $source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n";
145
146 out_next $op;
147}
148
149sub op_and {
150 my ($op) = @_;
151 266
152 $source .= <<EOF; 267 $source .= <<EOF;
153 { 268 {
154 dSP; 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
155 if (SvTRUE (TOPs)) 285 if (SvTRUE (TOPs))
156 { 286 {
157 --SP; 287 --SP;
158 PUTBACK; 288 PUTBACK;
159 nextop = (OP *)${$op->other}L; 289 nextop = (OP *)${$op->other}L;
160 goto op_${$op->other}; 290 goto op_${$op->other};
161 } 291 }
162
163 nextop = (OP *)${$op->next}L;
164 goto op_${$op->next};
165 } 292 }
166EOF 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;
167} 314}
168 315
169sub op_padsv { 316sub op_padsv {
170 my ($op) = @_;
171
172 my $flags = $op->flags; 317 my $flags = $op->flags;
173 my $target = $op->targ; 318 my $target = $op->targ;
174 319
175 $source .= <<EOF; 320 $source .= <<EOF;
176 { 321 {
… …
188 } 333 }
189 $source .= <<EOF; 334 $source .= <<EOF;
190 } 335 }
191EOF 336EOF
192 337
193 out_next $op; 338 out_next;
194} 339}
195 340
196# pattern const+ (or general push1) 341# pattern const+ (or general push1)
197# pattern pushmark return(?) 342# pattern pushmark return(?)
198# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 343# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
199 344
200# pattern const method_named 345# pattern const method_named
201sub op_method_named { 346sub op_method_named {
202 my ($op) = @_;
203
204 $source .= <<EOF; 347 $source .= <<EOF;
205 { 348 {
206 static HV *last_stash; 349 static HV *last_stash;
207 static SV *last_res; 350 static SV *last_cv;
351 static U32 last_sub_generation;
208 352
209 SV *obj = *(PL_stack_base + TOPMARK + 1); 353 SV *obj = *(PL_stack_base + TOPMARK + 1);
210 354
211 if (SvROK (obj) && SvOBJECT (SvRV (obj))) 355 if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
212 { 356 {
213 dSP; 357 dSP;
214 HV *stash = SvSTASH (SvRV (obj)); 358 HV *stash = SvSTASH (SvRV (obj));
215 359
216 /* simple "polymorphic" inline cache */ 360 /* simple "polymorphic" inline cache */
217 if (stash == last_stash) 361 if (stash == last_stash
362 && PL_sub_generation == last_sub_generation)
218 { 363 {
219 XPUSHs (last_res); 364 XPUSHs (last_cv);
220 PUTBACK; 365 PUTBACK;
221 } 366 }
222 else 367 else
223 { 368 {
224 PL_op = nextop;
225 nextop = Perl_pp_method_named (aTHX); 369 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
226 370
227 SPAGAIN; 371 SPAGAIN;
372 last_sub_generation = PL_sub_generation;
228 last_stash = stash; 373 last_stash = stash;
229 last_res = TOPs; 374 last_cv = TOPs;
230 } 375 }
231 } 376 }
232 else 377 else
233 { 378 {
234 /* error case usually */ 379 /* error case usually */
235 PL_op = nextop;
236 nextop = Perl_pp_method_named (aTHX); 380 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
237 } 381 }
238 } 382 }
239EOF 383EOF
240 384
241 out_next $op; 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;
242} 424}
243 425
244sub cv2c { 426sub cv2c {
245 my ($cv) = @_; 427 my ($cv) = @_;
246 428
429 @loop = ();
430
247 my %opsseen; 431 my %opsseen;
248 my @ops;
249 my @todo = $cv->START; 432 my @todo = $cv->START;
250 433
251 while (my $op = shift @todo) { 434 while (my $op = shift @todo) {
252 for (; $$op; $op = $op->next) { 435 for (; $$op; $op = $op->next) {
253 last if $opsseen{$$op}++; 436 last if $opsseen{$$op}++;
254 push @ops, $op; 437 push @ops, $op;
438
255 my $name = $op->name; 439 my $name = $op->name;
440 my $class = B::class $op;
441
256 if (B::class($op) eq "LOGOP") { 442 if ($class eq "LOGOP") {
257 push @todo, $op->other; 443 unshift @todo, $op->other; # unshift vs. push saves jumps
258 } elsif ($name eq "subst" and ${ $op->pmreplstart }) { 444 } elsif ($class eq "PMOP") {
259 push @todo, $op->pmreplstart; 445 unshift @todo, $op->pmreplstart if ${$op->pmreplstart};
260 } elsif ($name =~ /^enter(loop|iter)$/) { 446 } elsif ($class eq "LOOP") {
261# if ($] > 5.009) { 447 push @loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
262# $labels{${$op->nextop}} = "NEXT";
263# $labels{${$op->lastop}} = "LAST";
264# $labels{${$op->redoop}} = "REDO";
265# } else {
266# $labels{$op->nextop->seq} = "NEXT";
267# $labels{$op->lastop->seq} = "LAST";
268# $labels{$op->redoop->seq} = "REDO";
269# }
270 } 448 }
271 } 449 }
272 } 450 }
273 451
274 local $source = <<EOF; 452 local $source = <<EOF;
453OP *%%%FUNC%%% (pTHX)
454{
455 register OP *nextop = (OP *)${$ops[0]}L;
456EOF
457
458 while (@ops) {
459 $op = shift @ops;
460 $op_name = $op->name;
461
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#
465
466 $source .= " PERL_ASYNC_CHECK ();\n"
467 unless exists $flag{noasync}{$op_name};
468
469 if (my $can = __PACKAGE__->can ("op_$op_name")) {
470 # handcrafted replacement
471 $can->($op);
472
473 } elsif (exists $flag{unsafe}{$op_name}) {
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
490 } else {
491 # normal operator, linear execution
492 out_linear;
493 }
494 }
495
496 $op_name = "func exit"; assert (0);
497
498 $source .= <<EOF;
499op_0:
500 return 0;
501}
502EOF
503 #warn $source;
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";
518 print FILE <<EOF;
275#define PERL_NO_GET_CONTEXT 519#define PERL_NO_GET_CONTEXT
276 520
277#include <assert.h> 521#include <assert.h>
278 522
279#include "EXTERN.h" 523#include "EXTERN.h"
280#include "perl.h" 524#include "perl.h"
281#include "XSUB.h" 525#include "XSUB.h"
282 526
283/*typedef OP *(*PPFUNC)(pTHX);*/ 527#define RUNOPS_TILL(op) \\
284 528 while (nextop != (op)) \\
285OP *%%%FUNC%%% (pTHX) 529 { \\
286{
287 register OP *nextop = (OP *)${$ops[0]}L;
288EOF
289
290 for my $op (@ops) {
291 my $name = $op->name;
292 my $ppaddr = ppaddr $op->type;
293
294 $source .= "op_$$op: /* $name */\n";
295 #$source .= "fprintf (stderr, \"$$op in op $name\\n\");\n";#d#
296 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
297
298 unless (exists $flag{noasync}{$name}) {
299 $source .= " PERL_ASYNC_CHECK ();\n";
300 }
301
302 if (my $can = __PACKAGE__->can ("op_$name")) {
303 $can->($op);
304 } elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) {
305 $source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
306 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
307 $source .= " if (nextop == (OP *)${$op->other}L) goto op_${$op->other};\n";
308 $source .= " assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#
309 $source .= " goto op_${$op->next};\n";
310 } elsif (exists $flag{unsafe}{$name}) {
311 $source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
312 $source .= " PL_op = nextop; return " . (callop $op) . ";\n";
313 } else {
314 $source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
315 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
316 if ($name eq "entersub") {
317 $source .= <<EOF;
318while (nextop != (OP *)${$op->next})
319 {
320 PERL_ASYNC_CHECK (); 530 PERL_ASYNC_CHECK (); \\
321 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); 531 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
322 }
323EOF
324 }
325 $source .= " assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#
326 $source .= " goto op_${$op->next};\n";
327 }
328 } 532 }
329 533
330 $source .= "}\n"; 534EOF
331 #warn $source;
332
333 $source
334}
335
336sub source2ptr {
337 my ($source) = @_;
338
339 my $md5 = Digest::MD5::md5_hex $source;
340 $source =~ s/%%%FUNC%%%/Faster_$md5/;
341
342 my $stem = "/tmp/$md5";
343
344 unless (-e "$stem$_so") {
345 open FILE, ">:raw", "$stem.c";
346 print FILE $source; 535 print FILE $source;
347 close FILE; 536 close FILE;
348 system "$COMPILE -o $stem$_o $stem.c"; 537 system "$COMPILE -o $stem$_o $stem.c";
349 system "$LINK -o $stem$_so $stem$_o $LIBS"; 538 system "$LINK -o $stem$_so $stem$_o $LIBS";
350 } 539 }
… …
358} 547}
359 548
360sub entersub { 549sub entersub {
361 my ($cv) = @_; 550 my ($cv) = @_;
362 551
552 # always compile the whole stash
553# my @stash = $cv->STASH->ARRAY;
554# warn join ":", @stash;
555# exit;
556
363 eval { 557 eval {
364 my $source = cv2c $cv; 558 my $source = cv2c $cv;
365 559
366 my $ptr = source2ptr $source; 560 my $ptr = source2ptr $source;
367 561
368 patch_cv $cv, $ptr; 562 patch_cv $cv, $ptr;
369 }; 563 };
370 564
371 warn $@ if $@; 565 warn $@ if $@;
372} 566}
373 567
… …
375 569
3761; 5701;
377 571
378=back 572=back
379 573
380=head1 LIMITATIONS 574=head1 BUGS/LIMITATIONS
381 575
382Tainting 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
383 599
384=head1 AUTHOR 600=head1 AUTHOR
385 601
386 Marc Lehmann <schmorp@schmorp.de> 602 Marc Lehmann <schmorp@schmorp.de>
387 http://home.schmorp.de/ 603 http://home.schmorp.de/

Diff Legend

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