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

# User Rev Content
1 root 1.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 root 1.4 use Config;
19     use B ();
20     use Digest::MD5 ();
21     use DynaLoader ();
22 root 1.1
23     BEGIN {
24     our $VERSION = '0.01';
25    
26     require XSLoader;
27     XSLoader::load __PACKAGE__, $VERSION;
28     }
29    
30 root 1.4 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 root 1.1
36 root 1.11 my $opt_assert = 1;
37    
38 root 1.1 our $source;
39    
40 root 1.8 my @ops;
41     my $op;
42     my $op_name;
43 root 1.11 my @loop;
44 root 1.8
45 root 1.2 my %flag;
46    
47 root 1.11 # complex flag steting is no longer required, rewrite this ugly code
48 root 1.2 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 root 1.11 mapstart unsafe
63     substcont unsafe
64     entereval unsafe noasync todo
65 root 1.4 require unsafe
66    
67 root 1.11 mapstart noasync
68     grepstart noasync
69     match noasync todo#whyisitunsafe? unsafe
70    
71     last noasync
72     next noasync
73     redo noasync
74 root 1.8 seq noasync
75 root 1.11 pushmark noasync extend=0
76 root 1.8 padsv noasync extend=1
77     padav noasync extend=1
78     padhv noasync extend=1
79     padany noasync extend=1
80 root 1.4 entersub noasync
81     aassign noasync
82     sassign noasync
83     rv2av noasync
84 root 1.8 rv2cv noasync
85     rv2gv noasync
86     rv2hv noasync
87     refgen noasync
88 root 1.4 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 root 1.8 defined noasync
101 root 1.4 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 root 1.8 aelem noasync
110 root 1.4 aelemfast noasync
111 root 1.8 helem noasync
112     pushre noasync
113 root 1.11 subst noasync
114 root 1.8 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 root 1.11 ord noasync
134 root 1.8
135     iter async
136 root 1.2 EOF
137     my (undef, $op, @flags) = split /\s+/;
138    
139     undef $flag{$_}{$op}
140     for ("known", @flags);
141     }
142    
143 root 1.11 my %callop = (
144     entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)",
145     mapstart => "Perl_pp_grepstart (aTHX)",
146     );
147    
148 root 1.8 sub callop {
149 root 1.11 $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 root 1.8 }
161    
162 root 1.11 sub out_jump_next {
163     assert "nextop == (OP *)${$op->next}";
164     $source .= " goto op_${$op->next};\n";
165 root 1.2 }
166    
167 root 1.9 sub out_next {
168     $source .= " nextop = (OP *)${$op->next}L;\n";
169    
170 root 1.11 out_jump_next;
171 root 1.9 }
172    
173 root 1.8 sub out_linear {
174 root 1.11 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 root 1.4
182 root 1.11 sub op_entersub {
183     out_callop;
184     $source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n";
185     out_jump_next;
186 root 1.4 }
187    
188 root 1.11 *op_require = \&op_entersub;
189    
190 root 1.2 sub op_nextstate {
191 root 1.4 $source .= " PL_curcop = (COP *)nextop;\n";
192 root 1.2 $source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
193     $source .= " FREETMPS;\n";
194    
195 root 1.8 out_next;
196 root 1.2 }
197    
198 root 1.3 sub op_pushmark {
199     $source .= " PUSHMARK (PL_stack_sp);\n";
200    
201 root 1.8 out_next;
202 root 1.3 }
203    
204 root 1.11 if (0 && $Config{useithreads} ne "define") {
205 root 1.8 # 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 root 1.2
245 root 1.8 *op_gvsv = sub {
246     $source .= " {\n";
247     $source .= " dSP;\n";
248     $source .= " EXTEND (SP, 1);\n";
249 root 1.2
250 root 1.8 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 root 1.2 }
262    
263 root 1.11 sub xop_stringify {
264     $source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; PUTBACK; }\n";
265 root 1.3
266 root 1.8 out_next;
267 root 1.3 }
268    
269 root 1.4 sub op_and {
270     $source .= <<EOF;
271     {
272     dSP;
273 root 1.5
274 root 1.4 if (SvTRUE (TOPs))
275     {
276     --SP;
277     PUTBACK;
278     nextop = (OP *)${$op->other}L;
279     goto op_${$op->other};
280     }
281     }
282     EOF
283 root 1.5
284 root 1.8 out_next;
285 root 1.4 }
286    
287 root 1.7 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 root 1.8 out_next;
303 root 1.7 }
304    
305 root 1.4 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 root 1.8 out_next;
328 root 1.6 }
329    
330 root 1.3 # 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 root 1.11 sub xop_method_named {
336 root 1.3 $source .= <<EOF;
337     {
338 root 1.4 static HV *last_stash;
339 root 1.11 static SV *last_cv;
340     static U32 last_sub_generation;
341 root 1.4
342     SV *obj = *(PL_stack_base + TOPMARK + 1);
343 root 1.3
344 root 1.11 if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
345 root 1.3 {
346 root 1.4 dSP;
347     HV *stash = SvSTASH (SvRV (obj));
348 root 1.3
349 root 1.4 /* simple "polymorphic" inline cache */
350 root 1.11 if (stash == last_stash
351     && PL_sub_generation == last_sub_generation)
352 root 1.3 {
353 root 1.11 XPUSHs (last_cv);
354 root 1.4 PUTBACK;
355 root 1.3 }
356     else
357     {
358 root 1.11 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
359 root 1.4
360 root 1.3 SPAGAIN;
361 root 1.11 last_sub_generation = PL_sub_generation;
362     last_stash = stash;
363     last_cv = TOPs;
364 root 1.3 }
365     }
366 root 1.4 else
367     {
368     /* error case usually */
369 root 1.11 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
370 root 1.4 }
371 root 1.3 }
372     EOF
373    
374 root 1.8 out_next;
375 root 1.3 }
376    
377 root 1.11 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 root 1.4 sub cv2c {
416 root 1.1 my ($cv) = @_;
417    
418 root 1.11 @loop = ();
419    
420 root 1.1 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 root 1.11
428 root 1.1 my $name = $op->name;
429 root 1.11 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 root 1.1 }
438     }
439     }
440    
441 root 1.4 local $source = <<EOF;
442     OP *%%%FUNC%%% (pTHX)
443     {
444     register OP *nextop = (OP *)${$ops[0]}L;
445     EOF
446 root 1.2
447 root 1.8 while (@ops) {
448     $op = shift @ops;
449     $op_name = $op->name;
450 root 1.2
451 root 1.8 $source .= "op_$$op: /* $op_name */\n";
452     #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
453 root 1.4 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
454    
455 root 1.11 $source .= " PERL_ASYNC_CHECK ();\n"
456     unless exists $flag{noasync}{$op_name};
457 root 1.2
458 root 1.8 if (my $can = __PACKAGE__->can ("op_$op_name")) {
459 root 1.11 # handcrafted replacement
460 root 1.2 $can->($op);
461 root 1.11
462 root 1.8 } elsif (exists $flag{unsafe}{$op_name}) {
463 root 1.11 # unsafe, return to interpreter
464     assert "nextop == (OP *)$$op";
465 root 1.9 $source .= " return nextop;\n";
466 root 1.11
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 root 1.2 } else {
480 root 1.11 # normal operator, linear execution
481 root 1.8 out_linear;
482 root 1.2 }
483 root 1.1 }
484 root 1.2
485 root 1.11 $op_name = "func exit"; assert (0);
486    
487     $source .= <<EOF;
488     op_0:
489     return 0;
490     }
491     EOF
492 root 1.4 #warn $source;
493 root 1.2
494 root 1.4 $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 root 1.11 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 root 1.4 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 root 1.11 # always compile the whole stash
542     # my @stash = $cv->STASH->ARRAY;
543     # warn join ":", @stash;
544     # exit;
545    
546 root 1.4 eval {
547     my $source = cv2c $cv;
548    
549 root 1.11 my $ptr = source2ptr $source;
550 root 1.4
551 root 1.11 patch_cv $cv, $ptr;
552 root 1.4 };
553    
554     warn $@ if $@;
555 root 1.1 }
556    
557     hook_entersub;
558    
559     1;
560    
561     =back
562    
563 root 1.11 =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 root 1.2
582 root 1.11 .., ... (flipflop operators)
583     goto
584     next, redo (but not well-behaved last's)
585     eval
586     require
587     any use of formats
588 root 1.2
589 root 1.1 =head1 AUTHOR
590    
591     Marc Lehmann <schmorp@schmorp.de>
592     http://home.schmorp.de/
593    
594     =cut
595