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

# Content
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 use Config;
19 use B ();
20 use Digest::MD5 ();
21 use DynaLoader ();
22
23 BEGIN {
24 our $VERSION = '0.01';
25
26 require XSLoader;
27 XSLoader::load __PACKAGE__, $VERSION;
28 }
29
30 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
36 our $source;
37 our $label_next;
38 our $label_last;
39 our $label_redo;
40
41 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 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 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 $source .= " nextop = (OP *)${$op->next}L;\n";
100 $source .= " goto op_${$op->next};\n";
101 }
102
103 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 sub op_nextstate {
114 my ($op) = @_;
115
116 $source .= " PL_curcop = (COP *)nextop;\n";
117 $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 sub op_pushmark {
124 my ($op) = @_;
125
126 $source .= " PUSHMARK (PL_stack_sp);\n";
127
128 out_next $op;
129 }
130
131 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 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 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 # 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 sub op_method_named {
202 my ($op) = @_;
203
204 $source .= <<EOF;
205 {
206 static HV *last_stash;
207 static SV *last_res;
208
209 SV *obj = *(PL_stack_base + TOPMARK + 1);
210
211 if (SvROK (obj) && SvOBJECT (SvRV (obj)))
212 {
213 dSP;
214 HV *stash = SvSTASH (SvRV (obj));
215
216 /* simple "polymorphic" inline cache */
217 if (stash == last_stash)
218 {
219 XPUSHs (last_res);
220 PUTBACK;
221 }
222 else
223 {
224 PL_op = nextop;
225 nextop = Perl_pp_method_named (aTHX);
226
227 SPAGAIN;
228 last_stash = stash;
229 last_res = TOPs;
230 }
231 }
232 else
233 {
234 /* error case usually */
235 PL_op = nextop;
236 nextop = Perl_pp_method_named (aTHX);
237 }
238 }
239 EOF
240
241 out_next $op;
242 }
243
244 sub cv2c {
245 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 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
283 /*typedef OP *(*PPFUNC)(pTHX);*/
284
285 OP *%%%FUNC%%% (pTHX)
286 {
287 register OP *nextop = (OP *)${$ops[0]}L;
288 EOF
289
290 for my $op (@ops) {
291 my $name = $op->name;
292 my $ppaddr = ppaddr $op->type;
293
294 $source .= "op_$$op: /* $name */\n";
295 #$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
302 if (my $can = __PACKAGE__->can ("op_$name")) {
303 $can->($op);
304 } elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) {
305 $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 $source .= " goto op_${$op->next};\n";
310 } elsif (exists $flag{unsafe}{$name}) {
311 $source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
312 $source .= " PL_op = nextop; return " . (callop $op) . ";\n";
313 } else {
314 $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 $source .= " goto op_${$op->next};\n";
327 }
328 }
329
330 $source .= "}\n";
331 #warn $source;
332
333 $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 }
373
374 hook_entersub;
375
376 1;
377
378 =back
379
380 =head1 LIMITATIONS
381
382 Tainting and debugging will disable Faster.
383
384 =head1 AUTHOR
385
386 Marc Lehmann <schmorp@schmorp.de>
387 http://home.schmorp.de/
388
389 =cut
390