ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Faster/Faster.pm
Revision: 1.13
Committed: Fri Mar 10 18:53:49 2006 UTC (18 years, 3 months ago) by root
Branch: MAIN
Changes since 1.12: +5 -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.11 my $opt_assert = 1;
41    
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     out_cond_jump $op->next->other;
395     out_jump_next;
396     }
397    
398     *op_mapstart = \&op_grepstart;
399    
400     sub op_substcont {
401     out_callop;
402     out_cond_jump $op->other->pmreplstart;
403     assert "nextop == (OP *)${$op->other->next}L";
404     $source .= " goto op_${$op->other->next};\n";
405     }
406    
407     sub out_break_op {
408     my ($idx) = @_;
409    
410     out_callop;
411    
412     out_cond_jump $_->[$idx]
413     for reverse @loop;
414    
415     $source .= " return nextop;\n";
416     }
417    
418     sub xop_next {
419     out_break_op 0;
420     }
421    
422     sub op_last {
423     out_break_op 1;
424     }
425    
426     sub xop_redo {
427     out_break_op 2;
428     }
429    
430 root 1.4 sub cv2c {
431 root 1.1 my ($cv) = @_;
432    
433 root 1.11 @loop = ();
434    
435 root 1.1 my %opsseen;
436     my @todo = $cv->START;
437    
438     while (my $op = shift @todo) {
439     for (; $$op; $op = $op->next) {
440     last if $opsseen{$$op}++;
441     push @ops, $op;
442 root 1.11
443 root 1.1 my $name = $op->name;
444 root 1.11 my $class = B::class $op;
445    
446     if ($class eq "LOGOP") {
447     unshift @todo, $op->other; # unshift vs. push saves jumps
448     } elsif ($class eq "PMOP") {
449     unshift @todo, $op->pmreplstart if ${$op->pmreplstart};
450     } elsif ($class eq "LOOP") {
451     push @loop, [$op->nextop, $op->lastop->next, $op->redoop->next];
452 root 1.1 }
453     }
454     }
455    
456 root 1.4 local $source = <<EOF;
457     OP *%%%FUNC%%% (pTHX)
458     {
459     register OP *nextop = (OP *)${$ops[0]}L;
460     EOF
461 root 1.2
462 root 1.8 while (@ops) {
463     $op = shift @ops;
464     $op_name = $op->name;
465 root 1.2
466 root 1.8 $source .= "op_$$op: /* $op_name */\n";
467     #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
468 root 1.4 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
469    
470 root 1.11 $source .= " PERL_ASYNC_CHECK ();\n"
471     unless exists $flag{noasync}{$op_name};
472 root 1.2
473 root 1.8 if (my $can = __PACKAGE__->can ("op_$op_name")) {
474 root 1.11 # handcrafted replacement
475 root 1.2 $can->($op);
476 root 1.11
477 root 1.8 } elsif (exists $flag{unsafe}{$op_name}) {
478 root 1.11 # unsafe, return to interpreter
479     assert "nextop == (OP *)$$op";
480 root 1.9 $source .= " return nextop;\n";
481 root 1.11
482     } elsif ("LOGOP" eq B::class $op) {
483     # logical operation with optiona√∂ branch
484     out_callop;
485     out_cond_jump $op->other;
486     out_jump_next;
487    
488     } elsif ("PMOP" eq B::class $op) {
489     # regex-thingy
490     out_callop;
491     out_cond_jump $op->pmreplroot if ${$op->pmreplroot};
492     out_jump_next;
493    
494 root 1.2 } else {
495 root 1.11 # normal operator, linear execution
496 root 1.8 out_linear;
497 root 1.2 }
498 root 1.1 }
499 root 1.2
500 root 1.11 $op_name = "func exit"; assert (0);
501    
502     $source .= <<EOF;
503     op_0:
504     return 0;
505     }
506     EOF
507 root 1.4 #warn $source;
508 root 1.2
509 root 1.4 $source
510     }
511    
512     sub source2ptr {
513     my ($source) = @_;
514    
515     my $md5 = Digest::MD5::md5_hex $source;
516     $source =~ s/%%%FUNC%%%/Faster_$md5/;
517    
518     my $stem = "/tmp/$md5";
519    
520     unless (-e "$stem$_so") {
521     open FILE, ">:raw", "$stem.c";
522 root 1.11 print FILE <<EOF;
523     #define PERL_NO_GET_CONTEXT
524    
525     #include <assert.h>
526    
527     #include "EXTERN.h"
528     #include "perl.h"
529     #include "XSUB.h"
530    
531     #define RUNOPS_TILL(op) \\
532     while (nextop != (op)) \\
533     { \\
534     PERL_ASYNC_CHECK (); \\
535     PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
536     }
537    
538     EOF
539 root 1.4 print FILE $source;
540     close FILE;
541     system "$COMPILE -o $stem$_o $stem.c";
542     system "$LINK -o $stem$_so $stem$_o $LIBS";
543     }
544    
545     # warn $source;
546     my $so = DynaLoader::dl_load_file "$stem$_so"
547     or die "$stem$_so: $!";
548    
549     DynaLoader::dl_find_symbol $so, "Faster_$md5"
550     or die "Faster_$md5: $!"
551     }
552    
553     sub entersub {
554     my ($cv) = @_;
555    
556 root 1.11 # always compile the whole stash
557     # my @stash = $cv->STASH->ARRAY;
558     # warn join ":", @stash;
559     # exit;
560    
561 root 1.4 eval {
562     my $source = cv2c $cv;
563    
564 root 1.11 my $ptr = source2ptr $source;
565 root 1.4
566 root 1.11 patch_cv $cv, $ptr;
567 root 1.4 };
568    
569     warn $@ if $@;
570 root 1.1 }
571    
572     hook_entersub;
573    
574     1;
575    
576     =back
577    
578 root 1.11 =head1 BUGS/LIMITATIONS
579    
580     Perl will check much less often for asynchronous signals in
581     Faster-compiled code. It tries to check on every function call, loop
582     iteration and every I/O operator, though.
583    
584     The following things will disable Faster. If you manage to enable them at
585     runtime, bad things will happen.
586    
587     enabled tainting
588     enabled debugging
589    
590     This will dramatically reduce Faster's performance:
591    
592     threads (but you don't care about speed if you use threads anyway)
593    
594     These constructs will force the use of the interpreter as soon as they are
595     being executed, for the rest of the currently executed:
596 root 1.2
597 root 1.11 .., ... (flipflop operators)
598     goto
599     next, redo (but not well-behaved last's)
600     eval
601     require
602     any use of formats
603 root 1.2
604 root 1.1 =head1 AUTHOR
605    
606     Marc Lehmann <schmorp@schmorp.de>
607     http://home.schmorp.de/
608    
609     =cut
610