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