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

# 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 @ops;
42 my $op;
43 my $op_name;
44
45 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 require unsafe
63 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
71 seq noasync
72 pushmark noasync
73 padsv noasync extend=1
74 padav noasync extend=1
75 padhv noasync extend=1
76 padany noasync extend=1
77 entersub noasync
78 aassign noasync
79 sassign noasync
80 rv2av noasync
81 rv2cv noasync
82 rv2gv noasync
83 rv2hv noasync
84 refgen noasync
85 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 defined noasync
98 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 aelem noasync
107 aelemfast noasync
108 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 EOF
133 my (undef, $op, @flags) = split /\s+/;
134
135 undef $flag{$_}{$op}
136 for ("known", @flags);
137 }
138
139 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 sub out_gotonext {
148 if (${$op->next}) {
149 $source .= " assert ((\"$op_name\", nextop == (OP *)${$op->next}));\n";
150 $source .= " goto op_${$op->next};\n";
151 } else {
152 $source .= " return 0;\n";
153 }
154 }
155
156 sub out_next {
157 $source .= " nextop = (OP *)${$op->next}L;\n";
158
159 out_gotonext;
160 }
161
162 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
175 out_gotonext;
176 }
177
178 sub op_nextstate {
179 $source .= " PL_curcop = (COP *)nextop;\n";
180 $source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
181 $source .= " FREETMPS;\n";
182
183 out_next;
184 }
185
186 sub op_pushmark {
187 $source .= " PUSHMARK (PL_stack_sp);\n";
188
189 out_next;
190 }
191
192 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
233 *op_gvsv = sub {
234 $source .= " {\n";
235 $source .= " dSP;\n";
236 $source .= " EXTEND (SP, 1);\n";
237
238 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 }
250
251 sub op_stringify {
252 $source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n";
253
254 out_next;
255 }
256
257 sub op_and {
258 $source .= <<EOF;
259 {
260 dSP;
261
262 if (SvTRUE (TOPs))
263 {
264 --SP;
265 PUTBACK;
266 nextop = (OP *)${$op->other}L;
267 goto op_${$op->other};
268 }
269 }
270 EOF
271
272 out_next;
273 }
274
275 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 out_next;
291 }
292
293 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 out_next;
316 }
317
318 # 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 sub op_method_named {
324 $source .= <<EOF;
325 {
326 static HV *last_stash;
327 static SV *last_res;
328
329 SV *obj = *(PL_stack_base + TOPMARK + 1);
330
331 if (SvROK (obj) && SvOBJECT (SvRV (obj)))
332 {
333 dSP;
334 HV *stash = SvSTASH (SvRV (obj));
335
336 /* simple "polymorphic" inline cache */
337 if (stash == last_stash)
338 {
339 XPUSHs (last_res);
340 PUTBACK;
341 }
342 else
343 {
344 PL_op = nextop;
345 nextop = Perl_pp_method_named (aTHX);
346
347 SPAGAIN;
348 last_stash = stash;
349 last_res = TOPs;
350 }
351 }
352 else
353 {
354 /* error case usually */
355 PL_op = nextop;
356 nextop = Perl_pp_method_named (aTHX);
357 }
358 }
359 EOF
360
361 out_next;
362 }
363
364 sub cv2c {
365 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 local $source = <<EOF;
394 #define PERL_NO_GET_CONTEXT
395
396 //#define NDEBUG 1
397 #include <assert.h>
398
399 #include "EXTERN.h"
400 #include "perl.h"
401 #include "XSUB.h"
402
403 OP *%%%FUNC%%% (pTHX)
404 {
405 register OP *nextop = (OP *)${$ops[0]}L;
406 EOF
407
408 while (@ops) {
409 $op = shift @ops;
410 $op_name = $op->name;
411
412 $source .= "op_$$op: /* $op_name */\n";
413 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
414 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
415
416 unless (exists $flag{noasync}{$op_name}) {
417 $source .= " PERL_ASYNC_CHECK ();\n";
418 }
419
420 if (my $can = __PACKAGE__->can ("op_$op_name")) {
421 $can->($op);
422 } elsif (exists $flag{unsafe}{$op_name}) {
423 $source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";
424 $source .= " return nextop;\n";
425 } elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$op_name}) {
426 $source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";
427 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
428 $source .= " if (nextop == (OP *)${$op->other}L) goto op_${$op->other};\n";
429 $source .= " assert ((\"$op_name\", nextop == (OP *)${$op->next}));\n";
430 $source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";
431 } else {
432 out_linear;
433 }
434 }
435
436 $source .= "}\n";
437 #warn $source;
438
439 $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 }
479
480 hook_entersub;
481
482 1;
483
484 =back
485
486 =head1 LIMITATIONS
487
488 Tainting and debugging will disable Faster.
489
490 =head1 AUTHOR
491
492 Marc Lehmann <schmorp@schmorp.de>
493 http://home.schmorp.de/
494
495 =cut
496