ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Faster/Faster.pm
Revision: 1.11
Committed: Fri Mar 10 18:29:08 2006 UTC (18 years, 3 months ago) by root
Branch: MAIN
Changes since 1.10: +189 -91 lines
Log Message:
*** empty log message ***

File Contents

# Content
1 =head1 NAME
2
3 Faster - do some things faster
4
5 =head1 SYNOPSIS
6
7 use Faster;
8
9 =head1 DESCRIPTION
10
11 =over 4
12
13 =cut
14
15 package Faster;
16
17 use strict;
18 use Config;
19 use B ();
20 use Digest::MD5 ();
21 use DynaLoader ();
22
23 BEGIN {
24 our $VERSION = '0.01';
25
26 require XSLoader;
27 XSLoader::load __PACKAGE__, $VERSION;
28 }
29
30 my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}";
31 my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
32 my $LIBS = "$Config{libs}";
33 my $_o = $Config{_o};
34 my $_so = ".so";
35
36 my $opt_assert = 1;
37
38 our $source;
39
40 my @ops;
41 my $op;
42 my $op_name;
43 my @loop;
44
45 my %flag;
46
47 # complex flag steting is no longer required, rewrite this ugly code
48 for (split /\n/, <<EOF) {
49 leavesub unsafe
50 leavesublv unsafe
51 return unsafe
52 flip unsafe
53 goto unsafe
54 last unsafe
55 redo unsafe
56 next unsafe
57 eval unsafe
58 leaveeval unsafe
59 entertry unsafe
60 formline 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
136 EOF
137 my (undef, $op, @flags) = split /\s+/;
138
139 undef $flag{$_}{$op}
140 for ("known", @flags);
141 }
142
143 my %callop = (
144 entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)",
145 mapstart => "Perl_pp_grepstart (aTHX)",
146 );
147
148 sub callop {
149 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
150 }
151
152 sub assert {
153 return unless $opt_assert;
154 $source .= " assert ((\"$op_name\", ($_[0])));\n";
155 }
156
157 sub out_callop {
158 assert "nextop == (OP *)$$op";
159 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
160 }
161
162 sub out_jump_next {
163 assert "nextop == (OP *)${$op->next}";
164 $source .= " goto op_${$op->next};\n";
165 }
166
167 sub out_next {
168 $source .= " nextop = (OP *)${$op->next}L;\n";
169
170 out_jump_next;
171 }
172
173 sub out_linear {
174 out_callop;
175 out_jump_next;
176 }
177
178 sub out_cond_jump {
179 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
180 }
181
182 sub 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;
189
190 sub op_nextstate {
191 $source .= " PL_curcop = (COP *)nextop;\n";
192 $source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
193 $source .= " FREETMPS;\n";
194
195 out_next;
196 }
197
198 sub op_pushmark {
199 $source .= " PUSHMARK (PL_stack_sp);\n";
200
201 out_next;
202 }
203
204 if (0 && $Config{useithreads} ne "define") {
205 # disable optimisations on ithreads
206
207 *op_const = sub {
208 $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
209
210 out_next;
211 };
212
213 *op_gv = \&op_const;
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 sub xop_stringify {
264 $source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; PUTBACK; }\n";
265
266 out_next;
267 }
268
269 sub 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 }
282 EOF
283
284 out_next;
285 }
286
287 sub 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 }
300 EOF
301
302 out_next;
303 }
304
305 sub 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;
314 EOF
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 }
325 EOF
326
327 out_next;
328 }
329
330 # pattern const+ (or general push1)
331 # pattern pushmark return(?)
332 # pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
333
334 # pattern const method_named
335 sub xop_method_named {
336 $source .= <<EOF;
337 {
338 static HV *last_stash;
339 static SV *last_cv;
340 static U32 last_sub_generation;
341
342 SV *obj = *(PL_stack_base + TOPMARK + 1);
343
344 if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
345 {
346 dSP;
347 HV *stash = SvSTASH (SvRV (obj));
348
349 /* simple "polymorphic" inline cache */
350 if (stash == last_stash
351 && PL_sub_generation == last_sub_generation)
352 {
353 XPUSHs (last_cv);
354 PUTBACK;
355 }
356 else
357 {
358 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
359
360 SPAGAIN;
361 last_sub_generation = PL_sub_generation;
362 last_stash = stash;
363 last_cv = TOPs;
364 }
365 }
366 else
367 {
368 /* error case usually */
369 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
370 }
371 }
372 EOF
373
374 out_next;
375 }
376
377 sub op_grepstart {
378 out_callop;
379 out_cond_jump $op->next->other;
380 out_jump_next;
381 }
382
383 *op_mapstart = \&op_grepstart;
384
385 sub 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
392 sub 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
403 sub xop_next {
404 out_break_op 0;
405 }
406
407 sub op_last {
408 out_break_op 1;
409 }
410
411 sub xop_redo {
412 out_break_op 2;
413 }
414
415 sub cv2c {
416 my ($cv) = @_;
417
418 @loop = ();
419
420 my %opsseen;
421 my @todo = $cv->START;
422
423 while (my $op = shift @todo) {
424 for (; $$op; $op = $op->next) {
425 last if $opsseen{$$op}++;
426 push @ops, $op;
427
428 my $name = $op->name;
429 my $class = B::class $op;
430
431 if ($class eq "LOGOP") {
432 unshift @todo, $op->other; # unshift vs. push saves jumps
433 } elsif ($class eq "PMOP") {
434 unshift @todo, $op->pmreplstart if ${$op->pmreplstart};
435 } elsif ($class eq "LOOP") {
436 push @loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
437 }
438 }
439 }
440
441 local $source = <<EOF;
442 OP *%%%FUNC%%% (pTHX)
443 {
444 register OP *nextop = (OP *)${$ops[0]}L;
445 EOF
446
447 while (@ops) {
448 $op = shift @ops;
449 $op_name = $op->name;
450
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#
454
455 $source .= " PERL_ASYNC_CHECK ();\n"
456 unless exists $flag{noasync}{$op_name};
457
458 if (my $can = __PACKAGE__->can ("op_$op_name")) {
459 # handcrafted replacement
460 $can->($op);
461
462 } elsif (exists $flag{unsafe}{$op_name}) {
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
479 } else {
480 # normal operator, linear execution
481 out_linear;
482 }
483 }
484
485 $op_name = "func exit"; assert (0);
486
487 $source .= <<EOF;
488 op_0:
489 return 0;
490 }
491 EOF
492 #warn $source;
493
494 $source
495 }
496
497 sub 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";
507 print FILE <<EOF;
508 #define PERL_NO_GET_CONTEXT
509
510 #include <assert.h>
511
512 #include "EXTERN.h"
513 #include "perl.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
523 EOF
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
538 sub 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 $@;
555 }
556
557 hook_entersub;
558
559 1;
560
561 =back
562
563 =head1 BUGS/LIMITATIONS
564
565 Perl will check much less often for asynchronous signals in
566 Faster-compiled code. It tries to check on every function call, loop
567 iteration and every I/O operator, though.
568
569 The following things will disable Faster. If you manage to enable them at
570 runtime, bad things will happen.
571
572 enabled tainting
573 enabled debugging
574
575 This will dramatically reduce Faster's performance:
576
577 threads (but you don't care about speed if you use threads anyway)
578
579 These constructs will force the use of the interpreter as soon as they are
580 being 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
588
589 =head1 AUTHOR
590
591 Marc Lehmann <schmorp@schmorp.de>
592 http://home.schmorp.de/
593
594 =cut
595