ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Faster/Faster.pm
Revision: 1.12
Committed: Fri Mar 10 18:39:26 2006 UTC (18 years, 3 months ago) by root
Branch: MAIN
Changes since 1.11: +15 -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 root 1.11 my $opt_assert = 1;
37    
38 root 1.1 our $source;
39    
40 root 1.8 my @ops;
41     my $op;
42     my $op_name;
43 root 1.11 my @loop;
44 root 1.8
45 root 1.2 my %flag;
46    
47 root 1.11 # complex flag steting is no longer required, rewrite this ugly code
48 root 1.2 for (split /\n/, <<EOF) {
49     leavesub unsafe
50     leavesublv unsafe
51     return unsafe
52     flip unsafe
53     goto unsafe
54     last unsafe
55     redo unsafe
56     next unsafe
57     eval unsafe
58     leaveeval unsafe
59     entertry unsafe
60     formline unsafe
61     grepstart unsafe
62 root 1.11 mapstart unsafe
63     substcont unsafe
64     entereval unsafe noasync todo
65 root 1.4 require unsafe
66    
67 root 1.11 mapstart noasync
68     grepstart noasync
69 root 1.12 match noasync
70 root 1.11
71     last noasync
72     next noasync
73     redo noasync
74 root 1.8 seq noasync
75 root 1.11 pushmark noasync extend=0
76 root 1.8 padsv noasync extend=1
77     padav noasync extend=1
78     padhv noasync extend=1
79     padany noasync extend=1
80 root 1.4 entersub noasync
81     aassign noasync
82     sassign noasync
83     rv2av noasync
84 root 1.8 rv2cv noasync
85     rv2gv noasync
86     rv2hv noasync
87     refgen noasync
88 root 1.4 nextstate noasync
89     gv noasync
90     gvsv noasync
91     add noasync
92     subtract noasync
93     multiply noasync
94     divide noasync
95     complement noasync
96     cond_expr noasync
97     and noasync
98     or noasync
99     not noasync
100 root 1.8 defined noasync
101 root 1.4 method_named noasync
102     preinc noasync
103     postinc noasync
104     predec noasync
105     postdec noasync
106     stub noasync
107     unstack noasync
108     leaveloop noasync
109 root 1.8 aelem noasync
110 root 1.4 aelemfast noasync
111 root 1.8 helem noasync
112     pushre noasync
113 root 1.11 subst noasync
114 root 1.8 const noasync extend=1
115     list noasync
116     join noasync
117     split noasync
118     concat noasync
119     push noasync
120     pop noasync
121     shift noasync
122     unshift noasync
123     length noasync
124     substr noasync
125     stringify noasync
126     eq noasync
127     ne noasync
128     gt noasync
129     lt noasync
130     ge noasync
131     le noasync
132     enteriter noasync
133 root 1.11 ord noasync
134 root 1.8
135     iter async
136 root 1.2 EOF
137     my (undef, $op, @flags) = split /\s+/;
138    
139     undef $flag{$_}{$op}
140     for ("known", @flags);
141     }
142    
143 root 1.11 my %callop = (
144     entersub => "(PL_ppaddr [OP_ENTERSUB]) (aTHX)",
145     mapstart => "Perl_pp_grepstart (aTHX)",
146     );
147    
148 root 1.8 sub callop {
149 root 1.11 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
150     }
151    
152     sub assert {
153     return unless $opt_assert;
154     $source .= " assert ((\"$op_name\", ($_[0])));\n";
155     }
156    
157     sub out_callop {
158     assert "nextop == (OP *)$$op";
159     $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
160 root 1.8 }
161    
162 root 1.11 sub out_jump_next {
163     assert "nextop == (OP *)${$op->next}";
164     $source .= " goto op_${$op->next};\n";
165 root 1.2 }
166    
167 root 1.9 sub out_next {
168     $source .= " nextop = (OP *)${$op->next}L;\n";
169    
170 root 1.11 out_jump_next;
171 root 1.9 }
172    
173 root 1.8 sub out_linear {
174 root 1.11 out_callop;
175     out_jump_next;
176     }
177    
178     sub out_cond_jump {
179     $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
180     }
181 root 1.4
182 root 1.11 sub op_entersub {
183     out_callop;
184     $source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n";
185     out_jump_next;
186 root 1.4 }
187    
188 root 1.11 *op_require = \&op_entersub;
189    
190 root 1.2 sub op_nextstate {
191 root 1.4 $source .= " PL_curcop = (COP *)nextop;\n";
192 root 1.2 $source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
193     $source .= " FREETMPS;\n";
194    
195 root 1.8 out_next;
196 root 1.2 }
197    
198 root 1.3 sub op_pushmark {
199     $source .= " PUSHMARK (PL_stack_sp);\n";
200    
201 root 1.8 out_next;
202 root 1.3 }
203    
204 root 1.11 if (0 && $Config{useithreads} ne "define") {
205 root 1.8 # disable optimisations on ithreads
206    
207     *op_const = sub {
208     $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
209    
210     out_next;
211     };
212    
213     *op_gv = \&op_const;
214    
215     *op_aelemfast = sub {
216     my $targ = $op->targ;
217     my $private = $op->private;
218    
219     $source .= " {\n";
220    
221     if ($op->flags & B::OPf_SPECIAL) {
222     $source .= " AV *av = (AV*)PAD_SV((PADOFFSET)$targ);\n";
223     } else {
224     $source .= " AV *av = GvAV ((GV *)${$op->sv}L);\n";
225     }
226    
227     if ($op->flags & B::OPf_MOD) {
228     $source .= " SV *sv = *av_fetch (av, $private, 1);\n";
229     } else {
230     $source .= " SV **svp = av_fetch (av, $private, 0); SV *sv = svp ? *svp : &PL_sv_undef;\n";
231     }
232    
233     if (!($op->flags & B::OPf_MOD)) {
234     $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
235     }
236    
237     $source .= " dSP;\n";
238     $source .= " XPUSHs (sv);\n";
239     $source .= " PUTBACK;\n";
240     $source .= " }\n";
241    
242     out_next;
243     };
244 root 1.2
245 root 1.8 *op_gvsv = sub {
246     $source .= " {\n";
247     $source .= " dSP;\n";
248     $source .= " EXTEND (SP, 1);\n";
249 root 1.2
250 root 1.8 if ($op->private & B::OPpLVAL_INTRO) {
251     $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
252     } else {
253     $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
254     }
255    
256     $source .= " PUTBACK;\n";
257     $source .= " }\n";
258    
259     out_next;
260     };
261 root 1.2 }
262    
263 root 1.12 # does kill Crossfire/res2pm
264     sub op_stringify {
265     my $targ = $op->targ;
266    
267     $source .= <<EOF;
268     {
269     dSP;
270     SV *targ = PAD_SV ((PADOFFSET)$targ);
271     sv_copypv (TARG, TOPs);
272     SETTARG;
273     PUTBACK;
274     }
275     EOF
276 root 1.3
277 root 1.8 out_next;
278 root 1.3 }
279    
280 root 1.4 sub op_and {
281     $source .= <<EOF;
282     {
283     dSP;
284 root 1.5
285 root 1.4 if (SvTRUE (TOPs))
286     {
287     --SP;
288     PUTBACK;
289     nextop = (OP *)${$op->other}L;
290     goto op_${$op->other};
291     }
292     }
293     EOF
294 root 1.5
295 root 1.8 out_next;
296 root 1.4 }
297    
298 root 1.7 sub op_or {
299     $source .= <<EOF;
300     {
301     dSP;
302    
303     if (!SvTRUE (TOPs))
304     {
305     --SP;
306     PUTBACK;
307     nextop = (OP *)${$op->other}L;
308     goto op_${$op->other};
309     }
310     }
311     EOF
312    
313 root 1.8 out_next;
314 root 1.7 }
315    
316 root 1.4 sub op_padsv {
317     my $flags = $op->flags;
318     my $target = $op->targ;
319    
320     $source .= <<EOF;
321     {
322     dSP;
323     XPUSHs (PAD_SV ((PADOFFSET)$target));
324     PUTBACK;
325     EOF
326     if ($op->flags & B::OPf_MOD) {
327     if ($op->private & B::OPpLVAL_INTRO) {
328     $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n";
329     } elsif ($op->private & B::OPpDEREF) {
330     my $deref = $op->private & B::OPpDEREF;
331     $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
332     }
333     }
334     $source .= <<EOF;
335     }
336     EOF
337    
338 root 1.8 out_next;
339 root 1.6 }
340    
341 root 1.3 # pattern const+ (or general push1)
342     # pattern pushmark return(?)
343     # pattern pushmark gv rv2av pushmark padsv+o.√§. aassign
344    
345     # pattern const method_named
346 root 1.12 sub op_method_named {
347 root 1.3 $source .= <<EOF;
348     {
349 root 1.4 static HV *last_stash;
350 root 1.11 static SV *last_cv;
351     static U32 last_sub_generation;
352 root 1.4
353     SV *obj = *(PL_stack_base + TOPMARK + 1);
354 root 1.3
355 root 1.11 if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
356 root 1.3 {
357 root 1.4 dSP;
358     HV *stash = SvSTASH (SvRV (obj));
359 root 1.3
360 root 1.4 /* simple "polymorphic" inline cache */
361 root 1.11 if (stash == last_stash
362     && PL_sub_generation == last_sub_generation)
363 root 1.3 {
364 root 1.11 XPUSHs (last_cv);
365 root 1.4 PUTBACK;
366 root 1.3 }
367     else
368     {
369 root 1.11 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
370 root 1.4
371 root 1.3 SPAGAIN;
372 root 1.11 last_sub_generation = PL_sub_generation;
373     last_stash = stash;
374     last_cv = TOPs;
375 root 1.3 }
376     }
377 root 1.4 else
378     {
379     /* error case usually */
380 root 1.11 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
381 root 1.4 }
382 root 1.3 }
383     EOF
384    
385 root 1.8 out_next;
386 root 1.3 }
387    
388 root 1.11 sub op_grepstart {
389     out_callop;
390     out_cond_jump $op->next->other;
391     out_jump_next;
392     }
393    
394     *op_mapstart = \&op_grepstart;
395    
396     sub op_substcont {
397     out_callop;
398     out_cond_jump $op->other->pmreplstart;
399     assert "nextop == (OP *)${$op->other->next}L";
400     $source .= " goto op_${$op->other->next};\n";
401     }
402    
403     sub out_break_op {
404     my ($idx) = @_;
405    
406     out_callop;
407    
408     out_cond_jump $_->[$idx]
409     for reverse @loop;
410    
411     $source .= " return nextop;\n";
412     }
413    
414     sub xop_next {
415     out_break_op 0;
416     }
417    
418     sub op_last {
419     out_break_op 1;
420     }
421    
422     sub xop_redo {
423     out_break_op 2;
424     }
425    
426 root 1.4 sub cv2c {
427 root 1.1 my ($cv) = @_;
428    
429 root 1.11 @loop = ();
430    
431 root 1.1 my %opsseen;
432     my @todo = $cv->START;
433    
434     while (my $op = shift @todo) {
435     for (; $$op; $op = $op->next) {
436     last if $opsseen{$$op}++;
437     push @ops, $op;
438 root 1.11
439 root 1.1 my $name = $op->name;
440 root 1.11 my $class = B::class $op;
441    
442     if ($class eq "LOGOP") {
443     unshift @todo, $op->other; # unshift vs. push saves jumps
444     } elsif ($class eq "PMOP") {
445     unshift @todo, $op->pmreplstart if ${$op->pmreplstart};
446     } elsif ($class eq "LOOP") {
447     push @loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
448 root 1.1 }
449     }
450     }
451    
452 root 1.4 local $source = <<EOF;
453     OP *%%%FUNC%%% (pTHX)
454     {
455     register OP *nextop = (OP *)${$ops[0]}L;
456     EOF
457 root 1.2
458 root 1.8 while (@ops) {
459     $op = shift @ops;
460     $op_name = $op->name;
461 root 1.2
462 root 1.8 $source .= "op_$$op: /* $op_name */\n";
463     #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
464 root 1.4 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
465    
466 root 1.11 $source .= " PERL_ASYNC_CHECK ();\n"
467     unless exists $flag{noasync}{$op_name};
468 root 1.2
469 root 1.8 if (my $can = __PACKAGE__->can ("op_$op_name")) {
470 root 1.11 # handcrafted replacement
471 root 1.2 $can->($op);
472 root 1.11
473 root 1.8 } elsif (exists $flag{unsafe}{$op_name}) {
474 root 1.11 # unsafe, return to interpreter
475     assert "nextop == (OP *)$$op";
476 root 1.9 $source .= " return nextop;\n";
477 root 1.11
478     } elsif ("LOGOP" eq B::class $op) {
479     # logical operation with optiona√∂ branch
480     out_callop;
481     out_cond_jump $op->other;
482     out_jump_next;
483    
484     } elsif ("PMOP" eq B::class $op) {
485     # regex-thingy
486     out_callop;
487     out_cond_jump $op->pmreplroot if ${$op->pmreplroot};
488     out_jump_next;
489    
490 root 1.2 } else {
491 root 1.11 # normal operator, linear execution
492 root 1.8 out_linear;
493 root 1.2 }
494 root 1.1 }
495 root 1.2
496 root 1.11 $op_name = "func exit"; assert (0);
497    
498     $source .= <<EOF;
499     op_0:
500     return 0;
501     }
502     EOF
503 root 1.4 #warn $source;
504 root 1.2
505 root 1.4 $source
506     }
507    
508     sub source2ptr {
509     my ($source) = @_;
510    
511     my $md5 = Digest::MD5::md5_hex $source;
512     $source =~ s/%%%FUNC%%%/Faster_$md5/;
513    
514     my $stem = "/tmp/$md5";
515    
516     unless (-e "$stem$_so") {
517     open FILE, ">:raw", "$stem.c";
518 root 1.11 print FILE <<EOF;
519     #define PERL_NO_GET_CONTEXT
520    
521     #include <assert.h>
522    
523     #include "EXTERN.h"
524     #include "perl.h"
525     #include "XSUB.h"
526    
527     #define RUNOPS_TILL(op) \\
528     while (nextop != (op)) \\
529     { \\
530     PERL_ASYNC_CHECK (); \\
531     PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
532     }
533    
534     EOF
535 root 1.4 print FILE $source;
536     close FILE;
537     system "$COMPILE -o $stem$_o $stem.c";
538     system "$LINK -o $stem$_so $stem$_o $LIBS";
539     }
540    
541     # warn $source;
542     my $so = DynaLoader::dl_load_file "$stem$_so"
543     or die "$stem$_so: $!";
544    
545     DynaLoader::dl_find_symbol $so, "Faster_$md5"
546     or die "Faster_$md5: $!"
547     }
548    
549     sub entersub {
550     my ($cv) = @_;
551    
552 root 1.11 # always compile the whole stash
553     # my @stash = $cv->STASH->ARRAY;
554     # warn join ":", @stash;
555     # exit;
556    
557 root 1.4 eval {
558     my $source = cv2c $cv;
559    
560 root 1.11 my $ptr = source2ptr $source;
561 root 1.4
562 root 1.11 patch_cv $cv, $ptr;
563 root 1.4 };
564    
565     warn $@ if $@;
566 root 1.1 }
567    
568     hook_entersub;
569    
570     1;
571    
572     =back
573    
574 root 1.11 =head1 BUGS/LIMITATIONS
575    
576     Perl will check much less often for asynchronous signals in
577     Faster-compiled code. It tries to check on every function call, loop
578     iteration and every I/O operator, though.
579    
580     The following things will disable Faster. If you manage to enable them at
581     runtime, bad things will happen.
582    
583     enabled tainting
584     enabled debugging
585    
586     This will dramatically reduce Faster's performance:
587    
588     threads (but you don't care about speed if you use threads anyway)
589    
590     These constructs will force the use of the interpreter as soon as they are
591     being executed, for the rest of the currently executed:
592 root 1.2
593 root 1.11 .., ... (flipflop operators)
594     goto
595     next, redo (but not well-behaved last's)
596     eval
597     require
598     any use of formats
599 root 1.2
600 root 1.1 =head1 AUTHOR
601    
602     Marc Lehmann <schmorp@schmorp.de>
603     http://home.schmorp.de/
604    
605     =cut
606