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