ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Faster/Faster.pm
Revision: 1.6
Committed: Fri Mar 10 00:11:44 2006 UTC (18 years, 3 months ago) by root
Branch: MAIN
Changes since 1.5: +32 -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     sub op_padsv {
180     my ($op) = @_;
181    
182     my $flags = $op->flags;
183     my $target = $op->targ;
184    
185     $source .= <<EOF;
186     {
187     dSP;
188     XPUSHs (PAD_SV ((PADOFFSET)$target));
189     PUTBACK;
190     EOF
191     if ($op->flags & B::OPf_MOD) {
192     if ($op->private & B::OPpLVAL_INTRO) {
193     $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n";
194     } elsif ($op->private & B::OPpDEREF) {
195     my $deref = $op->private & B::OPpDEREF;
196     $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
197     }
198     }
199     $source .= <<EOF;
200     }
201     EOF
202    
203     out_next $op;
204     }
205    
206 root 1.6 sub op_aelemfast {
207     my ($op) = @_;
208    
209     my $targ = $op->targ;
210     my $private = $op->private;
211    
212     $source .= " {\n";
213    
214     if ($op->flags & B::OPf_SPECIAL) {
215     $source .= " AV *av = (AV*)PAD_SV((PADOFFSET)$targ);\n";
216     } else {
217     $source .= " AV *av = GvAV ((GV *)${$op->sv}L);\n";
218     }
219    
220     if ($op->flags & B::OPf_MOD) {
221     $source .= " SV *sv = *av_fetch (av, $private, 1);\n";
222     } else {
223     $source .= " SV **svp = av_fetch (av, $private, 0); SV *sv = svp ? *svp : &PL_sv_undef;\n";
224     }
225    
226     if (!($op->flags & B::OPf_MOD)) {
227     $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
228     }
229    
230     $source .= " dSP;\n";
231     $source .= " XPUSHs (sv);\n";
232     $source .= " PUTBACK;\n";
233     $source .= " }\n";
234    
235     out_next $op;
236     }
237    
238 root 1.3 # pattern const+ (or general push1)
239     # pattern pushmark return(?)
240     # pattern pushmark gv rv2av pushmark padsv+o.รค. aassign
241    
242     # pattern const method_named
243 root 1.4 sub op_method_named {
244 root 1.3 my ($op) = @_;
245    
246     $source .= <<EOF;
247     {
248 root 1.4 static HV *last_stash;
249     static SV *last_res;
250    
251     SV *obj = *(PL_stack_base + TOPMARK + 1);
252 root 1.3
253 root 1.4 if (SvROK (obj) && SvOBJECT (SvRV (obj)))
254 root 1.3 {
255 root 1.4 dSP;
256     HV *stash = SvSTASH (SvRV (obj));
257 root 1.3
258 root 1.4 /* simple "polymorphic" inline cache */
259 root 1.3 if (stash == last_stash)
260     {
261 root 1.4 XPUSHs (last_res);
262     PUTBACK;
263 root 1.3 }
264     else
265     {
266 root 1.4 PL_op = nextop;
267     nextop = Perl_pp_method_named (aTHX);
268    
269 root 1.3 SPAGAIN;
270     last_stash = stash;
271     last_res = TOPs;
272     }
273     }
274 root 1.4 else
275     {
276     /* error case usually */
277     PL_op = nextop;
278     nextop = Perl_pp_method_named (aTHX);
279     }
280 root 1.3 }
281     EOF
282    
283     out_next $op;
284     }
285    
286 root 1.4 sub cv2c {
287 root 1.1 my ($cv) = @_;
288    
289     my %opsseen;
290     my @ops;
291     my @todo = $cv->START;
292    
293     while (my $op = shift @todo) {
294     for (; $$op; $op = $op->next) {
295     last if $opsseen{$$op}++;
296     push @ops, $op;
297     my $name = $op->name;
298     if (B::class($op) eq "LOGOP") {
299     push @todo, $op->other;
300     } elsif ($name eq "subst" and ${ $op->pmreplstart }) {
301     push @todo, $op->pmreplstart;
302     } elsif ($name =~ /^enter(loop|iter)$/) {
303     # if ($] > 5.009) {
304     # $labels{${$op->nextop}} = "NEXT";
305     # $labels{${$op->lastop}} = "LAST";
306     # $labels{${$op->redoop}} = "REDO";
307     # } else {
308     # $labels{$op->nextop->seq} = "NEXT";
309     # $labels{$op->lastop->seq} = "LAST";
310     # $labels{$op->redoop->seq} = "REDO";
311     # }
312     }
313     }
314     }
315    
316 root 1.4 local $source = <<EOF;
317     #define PERL_NO_GET_CONTEXT
318    
319     #include <assert.h>
320    
321     #include "EXTERN.h"
322     #include "perl.h"
323     #include "XSUB.h"
324 root 1.2
325 root 1.4 /*typedef OP *(*PPFUNC)(pTHX);*/
326 root 1.2
327 root 1.4 OP *%%%FUNC%%% (pTHX)
328     {
329     register OP *nextop = (OP *)${$ops[0]}L;
330     EOF
331 root 1.2
332     for my $op (@ops) {
333     my $name = $op->name;
334     my $ppaddr = ppaddr $op->type;
335    
336     $source .= "op_$$op: /* $name */\n";
337 root 1.4 #$source .= "fprintf (stderr, \"$$op in op $name\\n\");\n";#d#
338     #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
339    
340     unless (exists $flag{noasync}{$name}) {
341     $source .= " PERL_ASYNC_CHECK ();\n";
342     }
343 root 1.2
344     if (my $can = __PACKAGE__->can ("op_$name")) {
345     $can->($op);
346 root 1.5 } elsif (exists $flag{unsafe}{$name}) {
347     $source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
348     $source .= " PL_op = nextop; return " . (callop $op) . ";\n";
349 root 1.2 } elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) {
350 root 1.4 $source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
351     $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
352     $source .= " if (nextop == (OP *)${$op->other}L) goto op_${$op->other};\n";
353     $source .= " assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#
354 root 1.5 $source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";
355 root 1.2 } else {
356 root 1.4 $source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
357     $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
358     if ($name eq "entersub") {
359     $source .= <<EOF;
360     while (nextop != (OP *)${$op->next})
361     {
362     PERL_ASYNC_CHECK ();
363     PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX);
364     }
365     EOF
366     }
367     $source .= " assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#
368 root 1.5 $source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";
369 root 1.2 }
370 root 1.1 }
371 root 1.2
372     $source .= "}\n";
373 root 1.4 #warn $source;
374 root 1.2
375 root 1.4 $source
376     }
377    
378     sub source2ptr {
379     my ($source) = @_;
380    
381     my $md5 = Digest::MD5::md5_hex $source;
382     $source =~ s/%%%FUNC%%%/Faster_$md5/;
383    
384     my $stem = "/tmp/$md5";
385    
386     unless (-e "$stem$_so") {
387     open FILE, ">:raw", "$stem.c";
388     print FILE $source;
389     close FILE;
390     system "$COMPILE -o $stem$_o $stem.c";
391     system "$LINK -o $stem$_so $stem$_o $LIBS";
392     }
393    
394     # warn $source;
395     my $so = DynaLoader::dl_load_file "$stem$_so"
396     or die "$stem$_so: $!";
397    
398     DynaLoader::dl_find_symbol $so, "Faster_$md5"
399     or die "Faster_$md5: $!"
400     }
401    
402     sub entersub {
403     my ($cv) = @_;
404    
405     eval {
406     my $source = cv2c $cv;
407    
408     my $ptr = source2ptr $source;
409    
410     patch_cv $cv, $ptr;
411     };
412    
413     warn $@ if $@;
414 root 1.1 }
415    
416     hook_entersub;
417    
418     1;
419    
420     =back
421    
422 root 1.2 =head1 LIMITATIONS
423    
424     Tainting and debugging will disable Faster.
425    
426 root 1.1 =head1 AUTHOR
427    
428     Marc Lehmann <schmorp@schmorp.de>
429     http://home.schmorp.de/
430    
431     =cut
432