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