ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Faster/Faster.pm
Revision: 1.7
Committed: Fri Mar 10 00:13:15 2006 UTC (18 years, 3 months ago) by root
Branch: MAIN
Changes since 1.6: +20 -0 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     our $source;
37     our $label_next;
38     our $label_last;
39     our $label_redo;
40    
41 root 1.2 my %flag;
42    
43     for (split /\n/, <<EOF) {
44     leavesub unsafe
45     leavesublv unsafe
46     return unsafe
47     flip unsafe
48     goto unsafe
49     last unsafe
50     redo unsafe
51     next unsafe
52     eval unsafe
53     leaveeval unsafe
54     entertry unsafe
55     substconst unsafe
56     formline unsafe
57     grepstart unsafe
58 root 1.4 require unsafe
59 root 1.5 match unsafe todo
60     subst unsafe todo
61     entereval unsafe todo
62     mapstart unsafe todo
63 root 1.4
64     pushmark noasync
65     padsv noasync
66     entersub noasync
67     aassign noasync
68     sassign noasync
69     rv2av noasync
70     nextstate noasync
71     gv noasync
72     gvsv noasync
73     add noasync
74     subtract noasync
75     multiply noasync
76     divide noasync
77     complement noasync
78     cond_expr noasync
79     and noasync
80     or noasync
81     not noasync
82     method_named noasync
83     preinc noasync
84     postinc noasync
85     predec noasync
86     postdec noasync
87     stub noasync
88     unstack noasync
89     leaveloop noasync
90     shift noasync
91     aelemA noasync
92     aelemfast noasync
93 root 1.2 EOF
94     my (undef, $op, @flags) = split /\s+/;
95    
96     undef $flag{$_}{$op}
97     for ("known", @flags);
98     }
99    
100     sub out_next {
101     my ($op) = @_;
102    
103 root 1.5 if (${$op->next}) {
104     $source .= " nextop = (OP *)${$op->next}L;\n";
105     $source .= " goto op_${$op->next};\n";
106     } else {
107     $source .= " return 0;\n";
108     }
109 root 1.2 }
110    
111 root 1.4 sub callop {
112     my ($op) = @_;
113    
114     my $name = $op->name;
115    
116     $name eq "entersub"
117     ? "(PL_ppaddr [OP_ENTERSUB]) (aTHX)"
118 root 1.5 : $name eq "mapstart"
119     ? "Perl_pp_grepstart (aTHX)"
120     : "Perl_pp_$name (aTHX)"
121 root 1.4 }
122    
123 root 1.2 sub op_nextstate {
124     my ($op) = @_;
125    
126 root 1.4 $source .= " PL_curcop = (COP *)nextop;\n";
127 root 1.2 $source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
128     $source .= " FREETMPS;\n";
129    
130     out_next $op;
131     }
132    
133 root 1.3 sub op_pushmark {
134     my ($op) = @_;
135    
136     $source .= " PUSHMARK (PL_stack_sp);\n";
137    
138     out_next $op;
139     }
140    
141 root 1.2 sub op_const {
142     my ($op) = @_;
143    
144     $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
145    
146     out_next $op;
147     }
148    
149     *op_gv = \&op_const;
150    
151 root 1.3 sub op_stringify {
152     my ($op) = @_;
153    
154     $source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n";
155    
156     out_next $op;
157     }
158    
159 root 1.4 sub op_and {
160     my ($op) = @_;
161    
162     $source .= <<EOF;
163     {
164     dSP;
165 root 1.5
166 root 1.4 if (SvTRUE (TOPs))
167     {
168     --SP;
169     PUTBACK;
170     nextop = (OP *)${$op->other}L;
171     goto op_${$op->other};
172     }
173     }
174     EOF
175 root 1.5
176     out_next $op;
177 root 1.4 }
178    
179 root 1.7 sub op_or {
180     my ($op) = @_;
181    
182     $source .= <<EOF;
183     {
184     dSP;
185    
186     if (!SvTRUE (TOPs))
187     {
188     --SP;
189     PUTBACK;
190     nextop = (OP *)${$op->other}L;
191     goto op_${$op->other};
192     }
193     }
194     EOF
195    
196     out_next $op;
197     }
198    
199 root 1.4 sub op_padsv {
200     my ($op) = @_;
201    
202     my $flags = $op->flags;
203     my $target = $op->targ;
204    
205     $source .= <<EOF;
206     {
207     dSP;
208     XPUSHs (PAD_SV ((PADOFFSET)$target));
209     PUTBACK;
210     EOF
211     if ($op->flags & B::OPf_MOD) {
212     if ($op->private & B::OPpLVAL_INTRO) {
213     $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n";
214     } elsif ($op->private & B::OPpDEREF) {
215     my $deref = $op->private & B::OPpDEREF;
216     $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
217     }
218     }
219     $source .= <<EOF;
220     }
221     EOF
222    
223     out_next $op;
224     }
225    
226 root 1.6 sub op_aelemfast {
227     my ($op) = @_;
228    
229     my $targ = $op->targ;
230     my $private = $op->private;
231    
232     $source .= " {\n";
233    
234     if ($op->flags & B::OPf_SPECIAL) {
235     $source .= " AV *av = (AV*)PAD_SV((PADOFFSET)$targ);\n";
236     } else {
237     $source .= " AV *av = GvAV ((GV *)${$op->sv}L);\n";
238     }
239    
240     if ($op->flags & B::OPf_MOD) {
241     $source .= " SV *sv = *av_fetch (av, $private, 1);\n";
242     } else {
243     $source .= " SV **svp = av_fetch (av, $private, 0); SV *sv = svp ? *svp : &PL_sv_undef;\n";
244     }
245    
246     if (!($op->flags & B::OPf_MOD)) {
247     $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
248     }
249    
250     $source .= " dSP;\n";
251     $source .= " XPUSHs (sv);\n";
252     $source .= " PUTBACK;\n";
253     $source .= " }\n";
254    
255     out_next $op;
256     }
257    
258 root 1.3 # pattern const+ (or general push1)
259     # pattern pushmark return(?)
260     # pattern pushmark gv rv2av pushmark padsv+o.รค. aassign
261    
262     # pattern const method_named
263 root 1.4 sub op_method_named {
264 root 1.3 my ($op) = @_;
265    
266     $source .= <<EOF;
267     {
268 root 1.4 static HV *last_stash;
269     static SV *last_res;
270    
271     SV *obj = *(PL_stack_base + TOPMARK + 1);
272 root 1.3
273 root 1.4 if (SvROK (obj) && SvOBJECT (SvRV (obj)))
274 root 1.3 {
275 root 1.4 dSP;
276     HV *stash = SvSTASH (SvRV (obj));
277 root 1.3
278 root 1.4 /* simple "polymorphic" inline cache */
279 root 1.3 if (stash == last_stash)
280     {
281 root 1.4 XPUSHs (last_res);
282     PUTBACK;
283 root 1.3 }
284     else
285     {
286 root 1.4 PL_op = nextop;
287     nextop = Perl_pp_method_named (aTHX);
288    
289 root 1.3 SPAGAIN;
290     last_stash = stash;
291     last_res = TOPs;
292     }
293     }
294 root 1.4 else
295     {
296     /* error case usually */
297     PL_op = nextop;
298     nextop = Perl_pp_method_named (aTHX);
299     }
300 root 1.3 }
301     EOF
302    
303     out_next $op;
304     }
305    
306 root 1.4 sub cv2c {
307 root 1.1 my ($cv) = @_;
308    
309     my %opsseen;
310     my @ops;
311     my @todo = $cv->START;
312    
313     while (my $op = shift @todo) {
314     for (; $$op; $op = $op->next) {
315     last if $opsseen{$$op}++;
316     push @ops, $op;
317     my $name = $op->name;
318     if (B::class($op) eq "LOGOP") {
319     push @todo, $op->other;
320     } elsif ($name eq "subst" and ${ $op->pmreplstart }) {
321     push @todo, $op->pmreplstart;
322     } elsif ($name =~ /^enter(loop|iter)$/) {
323     # if ($] > 5.009) {
324     # $labels{${$op->nextop}} = "NEXT";
325     # $labels{${$op->lastop}} = "LAST";
326     # $labels{${$op->redoop}} = "REDO";
327     # } else {
328     # $labels{$op->nextop->seq} = "NEXT";
329     # $labels{$op->lastop->seq} = "LAST";
330     # $labels{$op->redoop->seq} = "REDO";
331     # }
332     }
333     }
334     }
335    
336 root 1.4 local $source = <<EOF;
337     #define PERL_NO_GET_CONTEXT
338    
339     #include <assert.h>
340    
341     #include "EXTERN.h"
342     #include "perl.h"
343     #include "XSUB.h"
344 root 1.2
345 root 1.4 /*typedef OP *(*PPFUNC)(pTHX);*/
346 root 1.2
347 root 1.4 OP *%%%FUNC%%% (pTHX)
348     {
349     register OP *nextop = (OP *)${$ops[0]}L;
350     EOF
351 root 1.2
352     for my $op (@ops) {
353     my $name = $op->name;
354     my $ppaddr = ppaddr $op->type;
355    
356     $source .= "op_$$op: /* $name */\n";
357 root 1.4 #$source .= "fprintf (stderr, \"$$op in op $name\\n\");\n";#d#
358     #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
359    
360     unless (exists $flag{noasync}{$name}) {
361     $source .= " PERL_ASYNC_CHECK ();\n";
362     }
363 root 1.2
364     if (my $can = __PACKAGE__->can ("op_$name")) {
365     $can->($op);
366 root 1.5 } elsif (exists $flag{unsafe}{$name}) {
367     $source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
368     $source .= " PL_op = nextop; return " . (callop $op) . ";\n";
369 root 1.2 } elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) {
370 root 1.4 $source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
371     $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
372     $source .= " if (nextop == (OP *)${$op->other}L) goto op_${$op->other};\n";
373     $source .= " assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#
374 root 1.5 $source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";
375 root 1.2 } else {
376 root 1.4 $source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
377     $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
378     if ($name eq "entersub") {
379     $source .= <<EOF;
380     while (nextop != (OP *)${$op->next})
381     {
382     PERL_ASYNC_CHECK ();
383     PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX);
384     }
385     EOF
386     }
387     $source .= " assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#
388 root 1.5 $source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";
389 root 1.2 }
390 root 1.1 }
391 root 1.2
392     $source .= "}\n";
393 root 1.4 #warn $source;
394 root 1.2
395 root 1.4 $source
396     }
397    
398     sub source2ptr {
399     my ($source) = @_;
400    
401     my $md5 = Digest::MD5::md5_hex $source;
402     $source =~ s/%%%FUNC%%%/Faster_$md5/;
403    
404     my $stem = "/tmp/$md5";
405    
406     unless (-e "$stem$_so") {
407     open FILE, ">:raw", "$stem.c";
408     print FILE $source;
409     close FILE;
410     system "$COMPILE -o $stem$_o $stem.c";
411     system "$LINK -o $stem$_so $stem$_o $LIBS";
412     }
413    
414     # warn $source;
415     my $so = DynaLoader::dl_load_file "$stem$_so"
416     or die "$stem$_so: $!";
417    
418     DynaLoader::dl_find_symbol $so, "Faster_$md5"
419     or die "Faster_$md5: $!"
420     }
421    
422     sub entersub {
423     my ($cv) = @_;
424    
425     eval {
426     my $source = cv2c $cv;
427    
428     my $ptr = source2ptr $source;
429    
430     patch_cv $cv, $ptr;
431     };
432    
433     warn $@ if $@;
434 root 1.1 }
435    
436     hook_entersub;
437    
438     1;
439    
440     =back
441    
442 root 1.2 =head1 LIMITATIONS
443    
444     Tainting and debugging will disable Faster.
445    
446 root 1.1 =head1 AUTHOR
447    
448     Marc Lehmann <schmorp@schmorp.de>
449     http://home.schmorp.de/
450    
451     =cut
452