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