ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Faster/Faster.pm
Revision: 1.4
Committed: Thu Mar 9 22:32:17 2006 UTC (18 years, 3 months ago) by root
Branch: MAIN
Changes since 1.3: +197 -30 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    
60     pushmark noasync
61     padsv noasync
62     entersub noasync
63     aassign noasync
64     sassign noasync
65     rv2av noasync
66     nextstate noasync
67     gv noasync
68     gvsv noasync
69     add noasync
70     subtract noasync
71     multiply noasync
72     divide noasync
73     complement noasync
74     cond_expr noasync
75     and noasync
76     or noasync
77     not noasync
78     method_named noasync
79     preinc noasync
80     postinc noasync
81     predec noasync
82     postdec noasync
83     stub noasync
84     unstack noasync
85     leaveloop noasync
86     shift noasync
87     aelemA noasync
88     aelemfast noasync
89 root 1.2 EOF
90     my (undef, $op, @flags) = split /\s+/;
91    
92     undef $flag{$_}{$op}
93     for ("known", @flags);
94     }
95    
96     sub out_next {
97     my ($op) = @_;
98    
99 root 1.4 $source .= " nextop = (OP *)${$op->next}L;\n";
100 root 1.2 $source .= " goto op_${$op->next};\n";
101     }
102    
103 root 1.4 sub callop {
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     }
112    
113 root 1.2 sub op_nextstate {
114     my ($op) = @_;
115    
116 root 1.4 $source .= " PL_curcop = (COP *)nextop;\n";
117 root 1.2 $source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
118     $source .= " FREETMPS;\n";
119    
120     out_next $op;
121     }
122    
123 root 1.3 sub op_pushmark {
124     my ($op) = @_;
125    
126     $source .= " PUSHMARK (PL_stack_sp);\n";
127    
128     out_next $op;
129     }
130    
131 root 1.2 sub op_const {
132     my ($op) = @_;
133    
134     $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
135    
136     out_next $op;
137     }
138    
139     *op_gv = \&op_const;
140    
141 root 1.3 sub op_stringify {
142     my ($op) = @_;
143    
144     $source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n";
145    
146     out_next $op;
147     }
148    
149 root 1.4 sub op_and {
150     my ($op) = @_;
151    
152     $source .= <<EOF;
153     {
154     dSP;
155     if (SvTRUE (TOPs))
156     {
157     --SP;
158     PUTBACK;
159     nextop = (OP *)${$op->other}L;
160     goto op_${$op->other};
161     }
162    
163     nextop = (OP *)${$op->next}L;
164     goto op_${$op->next};
165     }
166     EOF
167     }
168    
169     sub op_padsv {
170     my ($op) = @_;
171    
172     my $flags = $op->flags;
173     my $target = $op->targ;
174    
175     $source .= <<EOF;
176     {
177     dSP;
178     XPUSHs (PAD_SV ((PADOFFSET)$target));
179     PUTBACK;
180     EOF
181     if ($op->flags & B::OPf_MOD) {
182     if ($op->private & B::OPpLVAL_INTRO) {
183     $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n";
184     } elsif ($op->private & B::OPpDEREF) {
185     my $deref = $op->private & B::OPpDEREF;
186     $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
187     }
188     }
189     $source .= <<EOF;
190     }
191     EOF
192    
193     out_next $op;
194     }
195    
196 root 1.3 # pattern const+ (or general push1)
197     # pattern pushmark return(?)
198     # pattern pushmark gv rv2av pushmark padsv+o.รค. aassign
199    
200     # pattern const method_named
201 root 1.4 sub op_method_named {
202 root 1.3 my ($op) = @_;
203    
204     $source .= <<EOF;
205     {
206 root 1.4 static HV *last_stash;
207     static SV *last_res;
208    
209     SV *obj = *(PL_stack_base + TOPMARK + 1);
210 root 1.3
211 root 1.4 if (SvROK (obj) && SvOBJECT (SvRV (obj)))
212 root 1.3 {
213 root 1.4 dSP;
214     HV *stash = SvSTASH (SvRV (obj));
215 root 1.3
216 root 1.4 /* simple "polymorphic" inline cache */
217 root 1.3 if (stash == last_stash)
218     {
219 root 1.4 XPUSHs (last_res);
220     PUTBACK;
221 root 1.3 }
222     else
223     {
224 root 1.4 PL_op = nextop;
225     nextop = Perl_pp_method_named (aTHX);
226    
227 root 1.3 SPAGAIN;
228     last_stash = stash;
229     last_res = TOPs;
230     }
231     }
232 root 1.4 else
233     {
234     /* error case usually */
235     PL_op = nextop;
236     nextop = Perl_pp_method_named (aTHX);
237     }
238 root 1.3 }
239     EOF
240    
241     out_next $op;
242     }
243    
244 root 1.4 sub cv2c {
245 root 1.1 my ($cv) = @_;
246    
247     my %opsseen;
248     my @ops;
249     my @todo = $cv->START;
250    
251     while (my $op = shift @todo) {
252     for (; $$op; $op = $op->next) {
253     last if $opsseen{$$op}++;
254     push @ops, $op;
255     my $name = $op->name;
256     if (B::class($op) eq "LOGOP") {
257     push @todo, $op->other;
258     } elsif ($name eq "subst" and ${ $op->pmreplstart }) {
259     push @todo, $op->pmreplstart;
260     } elsif ($name =~ /^enter(loop|iter)$/) {
261     # if ($] > 5.009) {
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     }
271     }
272     }
273    
274 root 1.4 local $source = <<EOF;
275     #define PERL_NO_GET_CONTEXT
276    
277     #include <assert.h>
278    
279     #include "EXTERN.h"
280     #include "perl.h"
281     #include "XSUB.h"
282 root 1.2
283 root 1.4 /*typedef OP *(*PPFUNC)(pTHX);*/
284 root 1.2
285 root 1.4 OP *%%%FUNC%%% (pTHX)
286     {
287     register OP *nextop = (OP *)${$ops[0]}L;
288     EOF
289 root 1.2
290     for my $op (@ops) {
291     my $name = $op->name;
292     my $ppaddr = ppaddr $op->type;
293    
294     $source .= "op_$$op: /* $name */\n";
295 root 1.4 #$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 root 1.2
302     if (my $can = __PACKAGE__->can ("op_$name")) {
303     $can->($op);
304     } elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) {
305 root 1.4 $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 root 1.2 $source .= " goto op_${$op->next};\n";
310     } elsif (exists $flag{unsafe}{$name}) {
311 root 1.4 $source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
312     $source .= " PL_op = nextop; return " . (callop $op) . ";\n";
313 root 1.2 } else {
314 root 1.4 $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;
318     while (nextop != (OP *)${$op->next})
319     {
320     PERL_ASYNC_CHECK ();
321     PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX);
322     }
323     EOF
324     }
325     $source .= " assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#
326 root 1.2 $source .= " goto op_${$op->next};\n";
327     }
328 root 1.1 }
329 root 1.2
330     $source .= "}\n";
331 root 1.4 #warn $source;
332 root 1.2
333 root 1.4 $source
334     }
335    
336     sub 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;
347     close FILE;
348     system "$COMPILE -o $stem$_o $stem.c";
349     system "$LINK -o $stem$_so $stem$_o $LIBS";
350     }
351    
352     # warn $source;
353     my $so = DynaLoader::dl_load_file "$stem$_so"
354     or die "$stem$_so: $!";
355    
356     DynaLoader::dl_find_symbol $so, "Faster_$md5"
357     or die "Faster_$md5: $!"
358     }
359    
360     sub entersub {
361     my ($cv) = @_;
362    
363     eval {
364     my $source = cv2c $cv;
365    
366     my $ptr = source2ptr $source;
367    
368     patch_cv $cv, $ptr;
369     };
370    
371     warn $@ if $@;
372 root 1.1 }
373    
374     hook_entersub;
375    
376     1;
377    
378     =back
379    
380 root 1.2 =head1 LIMITATIONS
381    
382     Tainting and debugging will disable Faster.
383    
384 root 1.1 =head1 AUTHOR
385    
386     Marc Lehmann <schmorp@schmorp.de>
387     http://home.schmorp.de/
388    
389     =cut
390