ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Faster/Faster.pm
Revision: 1.9
Committed: Fri Mar 10 01:55:12 2006 UTC (18 years, 3 months ago) by root
Branch: MAIN
Changes since 1.8: +9 -4 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.9 sub out_gotonext {
148 root 1.5 if (${$op->next}) {
149 root 1.8 $source .= " assert ((\"$op_name\", nextop == (OP *)${$op->next}));\n";
150 root 1.5 $source .= " goto op_${$op->next};\n";
151     } else {
152     $source .= " return 0;\n";
153     }
154 root 1.2 }
155    
156 root 1.9 sub out_next {
157     $source .= " nextop = (OP *)${$op->next}L;\n";
158    
159     out_gotonext;
160     }
161    
162 root 1.8 sub out_linear {
163     $source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";#d#
164     $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
165     if ($op_name eq "entersub") {
166     $source .= <<EOF;
167     while (nextop != (OP *)${$op->next}L)
168     {
169     PERL_ASYNC_CHECK ();
170     PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX);
171     }
172     EOF
173     }
174 root 1.4
175 root 1.9 out_gotonext;
176 root 1.4 }
177    
178 root 1.2 sub op_nextstate {
179 root 1.4 $source .= " PL_curcop = (COP *)nextop;\n";
180 root 1.2 $source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
181     $source .= " FREETMPS;\n";
182    
183 root 1.8 out_next;
184 root 1.2 }
185    
186 root 1.3 sub op_pushmark {
187     $source .= " PUSHMARK (PL_stack_sp);\n";
188    
189 root 1.8 out_next;
190 root 1.3 }
191    
192 root 1.8 if ($Config{useithreads} ne "define") {
193     # disable optimisations on ithreads
194    
195     *op_const = sub {
196     $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
197    
198     out_next;
199     };
200    
201     *op_gv = \&op_const;
202    
203     *op_aelemfast = sub {
204     my $targ = $op->targ;
205     my $private = $op->private;
206    
207     $source .= " {\n";
208    
209     if ($op->flags & B::OPf_SPECIAL) {
210     $source .= " AV *av = (AV*)PAD_SV((PADOFFSET)$targ);\n";
211     } else {
212     $source .= " AV *av = GvAV ((GV *)${$op->sv}L);\n";
213     }
214    
215     if ($op->flags & B::OPf_MOD) {
216     $source .= " SV *sv = *av_fetch (av, $private, 1);\n";
217     } else {
218     $source .= " SV **svp = av_fetch (av, $private, 0); SV *sv = svp ? *svp : &PL_sv_undef;\n";
219     }
220    
221     if (!($op->flags & B::OPf_MOD)) {
222     $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
223     }
224    
225     $source .= " dSP;\n";
226     $source .= " XPUSHs (sv);\n";
227     $source .= " PUTBACK;\n";
228     $source .= " }\n";
229    
230     out_next;
231     };
232 root 1.2
233 root 1.8 *op_gvsv = sub {
234     $source .= " {\n";
235     $source .= " dSP;\n";
236     $source .= " EXTEND (SP, 1);\n";
237 root 1.2
238 root 1.8 if ($op->private & B::OPpLVAL_INTRO) {
239     $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
240     } else {
241     $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
242     }
243    
244     $source .= " PUTBACK;\n";
245     $source .= " }\n";
246    
247     out_next;
248     };
249 root 1.2 }
250    
251 root 1.3 sub op_stringify {
252     $source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n";
253    
254 root 1.8 out_next;
255 root 1.3 }
256    
257 root 1.4 sub op_and {
258     $source .= <<EOF;
259     {
260     dSP;
261 root 1.5
262 root 1.4 if (SvTRUE (TOPs))
263     {
264     --SP;
265     PUTBACK;
266     nextop = (OP *)${$op->other}L;
267     goto op_${$op->other};
268     }
269     }
270     EOF
271 root 1.5
272 root 1.8 out_next;
273 root 1.4 }
274    
275 root 1.7 sub op_or {
276     $source .= <<EOF;
277     {
278     dSP;
279    
280     if (!SvTRUE (TOPs))
281     {
282     --SP;
283     PUTBACK;
284     nextop = (OP *)${$op->other}L;
285     goto op_${$op->other};
286     }
287     }
288     EOF
289    
290 root 1.8 out_next;
291 root 1.7 }
292    
293 root 1.4 sub op_padsv {
294     my $flags = $op->flags;
295     my $target = $op->targ;
296    
297     $source .= <<EOF;
298     {
299     dSP;
300     XPUSHs (PAD_SV ((PADOFFSET)$target));
301     PUTBACK;
302     EOF
303     if ($op->flags & B::OPf_MOD) {
304     if ($op->private & B::OPpLVAL_INTRO) {
305     $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n";
306     } elsif ($op->private & B::OPpDEREF) {
307     my $deref = $op->private & B::OPpDEREF;
308     $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
309     }
310     }
311     $source .= <<EOF;
312     }
313     EOF
314    
315 root 1.8 out_next;
316 root 1.6 }
317    
318 root 1.3 # pattern const+ (or general push1)
319     # pattern pushmark return(?)
320     # pattern pushmark gv rv2av pushmark padsv+o.รค. aassign
321    
322     # pattern const method_named
323 root 1.4 sub op_method_named {
324 root 1.3 $source .= <<EOF;
325     {
326 root 1.4 static HV *last_stash;
327     static SV *last_res;
328    
329     SV *obj = *(PL_stack_base + TOPMARK + 1);
330 root 1.3
331 root 1.4 if (SvROK (obj) && SvOBJECT (SvRV (obj)))
332 root 1.3 {
333 root 1.4 dSP;
334     HV *stash = SvSTASH (SvRV (obj));
335 root 1.3
336 root 1.4 /* simple "polymorphic" inline cache */
337 root 1.3 if (stash == last_stash)
338     {
339 root 1.4 XPUSHs (last_res);
340     PUTBACK;
341 root 1.3 }
342     else
343     {
344 root 1.4 PL_op = nextop;
345     nextop = Perl_pp_method_named (aTHX);
346    
347 root 1.3 SPAGAIN;
348     last_stash = stash;
349     last_res = TOPs;
350     }
351     }
352 root 1.4 else
353     {
354     /* error case usually */
355     PL_op = nextop;
356     nextop = Perl_pp_method_named (aTHX);
357     }
358 root 1.3 }
359     EOF
360    
361 root 1.8 out_next;
362 root 1.3 }
363    
364 root 1.4 sub cv2c {
365 root 1.1 my ($cv) = @_;
366    
367     my %opsseen;
368     my @todo = $cv->START;
369    
370     while (my $op = shift @todo) {
371     for (; $$op; $op = $op->next) {
372     last if $opsseen{$$op}++;
373     push @ops, $op;
374     my $name = $op->name;
375     if (B::class($op) eq "LOGOP") {
376     push @todo, $op->other;
377     } elsif ($name eq "subst" and ${ $op->pmreplstart }) {
378     push @todo, $op->pmreplstart;
379     } elsif ($name =~ /^enter(loop|iter)$/) {
380     # if ($] > 5.009) {
381     # $labels{${$op->nextop}} = "NEXT";
382     # $labels{${$op->lastop}} = "LAST";
383     # $labels{${$op->redoop}} = "REDO";
384     # } else {
385     # $labels{$op->nextop->seq} = "NEXT";
386     # $labels{$op->lastop->seq} = "LAST";
387     # $labels{$op->redoop->seq} = "REDO";
388     # }
389     }
390     }
391     }
392    
393 root 1.4 local $source = <<EOF;
394     #define PERL_NO_GET_CONTEXT
395    
396 root 1.8 //#define NDEBUG 1
397 root 1.4 #include <assert.h>
398    
399     #include "EXTERN.h"
400     #include "perl.h"
401     #include "XSUB.h"
402 root 1.2
403 root 1.4 OP *%%%FUNC%%% (pTHX)
404     {
405     register OP *nextop = (OP *)${$ops[0]}L;
406     EOF
407 root 1.2
408 root 1.8 while (@ops) {
409     $op = shift @ops;
410     $op_name = $op->name;
411 root 1.2
412 root 1.8 $source .= "op_$$op: /* $op_name */\n";
413     #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
414 root 1.4 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
415    
416 root 1.8 unless (exists $flag{noasync}{$op_name}) {
417 root 1.4 $source .= " PERL_ASYNC_CHECK ();\n";
418     }
419 root 1.2
420 root 1.8 if (my $can = __PACKAGE__->can ("op_$op_name")) {
421 root 1.2 $can->($op);
422 root 1.8 } elsif (exists $flag{unsafe}{$op_name}) {
423     $source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";
424 root 1.9 $source .= " return nextop;\n";
425 root 1.8 } elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$op_name}) {
426     $source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";
427 root 1.4 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
428     $source .= " if (nextop == (OP *)${$op->other}L) goto op_${$op->other};\n";
429 root 1.8 $source .= " assert ((\"$op_name\", nextop == (OP *)${$op->next}));\n";
430 root 1.5 $source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";
431 root 1.2 } else {
432 root 1.8 out_linear;
433 root 1.2 }
434 root 1.1 }
435 root 1.2
436     $source .= "}\n";
437 root 1.4 #warn $source;
438 root 1.2
439 root 1.4 $source
440     }
441    
442     sub source2ptr {
443     my ($source) = @_;
444    
445     my $md5 = Digest::MD5::md5_hex $source;
446     $source =~ s/%%%FUNC%%%/Faster_$md5/;
447    
448     my $stem = "/tmp/$md5";
449    
450     unless (-e "$stem$_so") {
451     open FILE, ">:raw", "$stem.c";
452     print FILE $source;
453     close FILE;
454     system "$COMPILE -o $stem$_o $stem.c";
455     system "$LINK -o $stem$_so $stem$_o $LIBS";
456     }
457    
458     # warn $source;
459     my $so = DynaLoader::dl_load_file "$stem$_so"
460     or die "$stem$_so: $!";
461    
462     DynaLoader::dl_find_symbol $so, "Faster_$md5"
463     or die "Faster_$md5: $!"
464     }
465    
466     sub entersub {
467     my ($cv) = @_;
468    
469     eval {
470     my $source = cv2c $cv;
471    
472     my $ptr = source2ptr $source;
473    
474     patch_cv $cv, $ptr;
475     };
476    
477     warn $@ if $@;
478 root 1.1 }
479    
480     hook_entersub;
481    
482     1;
483    
484     =back
485    
486 root 1.2 =head1 LIMITATIONS
487    
488     Tainting and debugging will disable Faster.
489    
490 root 1.1 =head1 AUTHOR
491    
492     Marc Lehmann <schmorp@schmorp.de>
493     http://home.schmorp.de/
494    
495     =cut
496