ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Faster/Faster.pm
Revision: 1.26
Committed: Sat Mar 11 18:13:35 2006 UTC (18 years, 3 months ago) by root
Branch: MAIN
Changes since 1.25: +32 -13 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 perl -MFaster ...
10
11 =head1 DESCRIPTION
12
13 This module implements a very simple-minded JIT. It works by more or less
14 translating every function it sees into a C program, compiling it and then
15 replacing the function by the compiled code.
16
17 As a result, startup times are immense, as every function might lead to a
18 full-blown compilation.
19
20 The speed improvements are also not great, you can expect 20% or so on
21 average, for code that runs very often.
22
23 Faster is in the early stages of development. Due to its design its
24 relatively safe to use (it will either work or simply slowdown the program
25 immensely, but rarely cause bugs).
26
27 Usage is very easy, just C<use Faster> and every function called from then
28 on will be compiled.
29
30 Right now, Faster will leave lots of F<*.c>, F<*.o> and F<*.so> files in
31 F</tmp>, and it will even create those temporary files in an insecure
32 manner, so watch out.
33
34 =over 4
35
36 =cut
37
38 package Faster;
39
40 no warnings;
41
42 use strict;
43 use Config;
44 use B ();
45 #use Digest::MD5 ();
46 use DynaLoader ();
47 use File::Temp ();
48
49 BEGIN {
50 our $VERSION = '0.01';
51
52 require XSLoader;
53 XSLoader::load __PACKAGE__, $VERSION;
54 }
55
56 my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}";
57 my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
58 my $LIBS = "$Config{libs}";
59 my $_o = $Config{_o};
60 my $_so = ".so";
61
62 # we don't need no steenking PIC on x86
63 $COMPILE =~ s/-f(?:PIC|pic)//g
64 if $Config{archname} =~ /^(i[3456]86)-/;
65
66 my $opt_assert = $ENV{FASTER_DEBUG};
67 my $verbose = $ENV{FASTER_VERBOSE}+0;
68
69 our $source;
70
71 our @ops;
72 our $insn;
73 our $op;
74 our $op_name;
75 our @op_loop;
76 our %op_regcomp;
77
78 # ops that cause immediate return to the interpreter
79 my %f_unsafe = map +($_ => undef), qw(
80 leavesub leavesublv return
81 goto last redo next
82 eval flip leaveeval entertry
83 formline grepstart mapstart
84 substcont entereval require
85 );
86
87 # ops with known stack extend behaviour
88 # the values given are maximum values
89 my %extend = (
90 pushmark => 0,
91 nextstate => 0, # might reduce the stack
92 unstack => 0,
93 enter => 0,
94
95 stringify => 0,
96 not => 0,
97 and => 0,
98 or => 0,
99 gvsv => 0,
100 rv2gv => 0,
101 preinc => 0,
102 predec => 0,
103 postinc => 0,
104 postdec => 0,
105 aelem => 0,
106 helem => 0,
107 qr => 1, #???
108 pushre => 1,
109 gv => 1,
110 aelemfast => 1,
111 aelem => 0,
112 padsv => 1,
113 const => 1,
114 pop => 1,
115 shift => 1,
116 eq => -1,
117 ne => -1,
118 gt => -1,
119 lt => -1,
120 ge => -1,
121 lt => -1,
122 cond_expr => -1,
123 add => -1,
124 subtract => -1,
125 multiply => -1,
126 divide => -1,
127 aassign => 0,
128 sassign => -2,
129 method => 0,
130 method_named => 1,
131 );
132
133 # ops that do not need an ASYNC_CHECK
134 my %f_noasync = map +($_ => undef), qw(
135 mapstart grepstart match entereval
136 enteriter entersub leaveloop
137
138 pushmark nextstate
139
140 const stub unstack
141 last next redo seq
142 padsv padav padhv padany
143 aassign sassign orassign
144 rv2av rv2cv rv2gv rv2hv refgen
145 gv gvsv
146 add subtract multiply divide
147 complement cond_expr and or not
148 defined
149 method method_named bless
150 preinc postinc predec postdec
151 aelem aelemfast helem delete exists
152 pushre subst list join split concat
153 length substr stringify ord
154 push pop shift unshift
155 eq ne gt lt ge le
156 regcomp regcreset regcmaybe
157 );
158
159 my %callop = (
160 entersub => "(PL_op->op_ppaddr) (aTHX)",
161 mapstart => "Perl_pp_grepstart (aTHX)",
162 );
163
164 sub callop {
165 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
166 }
167
168 sub assert {
169 return unless $opt_assert;
170 $source .= " assert ((\"$op_name\", ($_[0])));\n";
171 }
172
173 sub out_callop {
174 assert "nextop == (OP *)$$op";
175 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
176 }
177
178 sub out_cond_jump {
179 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
180 }
181
182 sub out_jump_next {
183 out_cond_jump $op_regcomp{$$op}
184 if $op_regcomp{$$op};
185
186 assert "nextop == (OP *)${$op->next}";
187 $source .= " goto op_${$op->next};\n";
188 }
189
190 sub out_next {
191 $source .= " nextop = (OP *)${$op->next}L;\n";
192
193 out_jump_next;
194 }
195
196 sub out_linear {
197 out_callop;
198 out_jump_next;
199 }
200
201 sub op_entersub {
202 out_callop;
203 $source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n";
204 out_jump_next;
205 }
206
207 *op_require = \&op_entersub;
208
209 sub op_nextstate {
210 $source .= " PL_curcop = (COP *)nextop;\n";
211 $source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
212 $source .= " FREETMPS;\n";
213
214 out_next;
215 }
216
217 sub op_pushmark {
218 $source .= " PUSHMARK (PL_stack_sp);\n";
219
220 out_next;
221 }
222
223 if ($Config{useithreads} ne "define") {
224 # disable optimisations on ithreads
225
226 *op_const = sub {
227 $source .= " { dSP; PUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
228
229 $ops[0]{follows_const}++ if @ops;#d#
230
231 out_next;
232 };
233
234 *op_gv = \&op_const;
235
236 *op_aelemfast = sub {
237 my $targ = $op->targ;
238 my $private = $op->private;
239
240 $source .= " {\n";
241
242 if ($op->flags & B::OPf_SPECIAL) {
243 $source .= " AV *av = (AV*)PAD_SV((PADOFFSET)$targ);\n";
244 } else {
245 $source .= " AV *av = GvAV ((GV *)${$op->sv}L);\n";
246 }
247
248 if ($op->flags & B::OPf_MOD) {
249 $source .= " SV *sv = *av_fetch (av, $private, 1);\n";
250 } else {
251 $source .= " SV **svp = av_fetch (av, $private, 0); SV *sv = svp ? *svp : &PL_sv_undef;\n";
252 }
253
254 if (!($op->flags & B::OPf_MOD)) {
255 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
256 }
257
258 $source .= " dSP;\n";
259 $source .= " PUSHs (sv);\n";
260 $source .= " PUTBACK;\n";
261 $source .= " }\n";
262
263 out_next;
264 };
265
266 *op_gvsv = sub {
267 $source .= " {\n";
268 $source .= " dSP;\n";
269
270 if ($op->private & B::OPpLVAL_INTRO) {
271 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
272 } else {
273 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
274 }
275
276 $source .= " PUTBACK;\n";
277 $source .= " }\n";
278
279 out_next;
280 };
281 }
282
283 # does kill Crossfire/res2pm
284 sub op_stringify {
285 my $targ = $op->targ;
286
287 $source .= <<EOF;
288 {
289 dSP;
290 SV *targ = PAD_SV ((PADOFFSET)$targ);
291 sv_copypv (TARG, TOPs);
292 SETTARG;
293 PUTBACK;
294 }
295 EOF
296
297 out_next;
298 }
299
300 sub op_and {
301 $source .= <<EOF;
302 {
303 dSP;
304
305 if (SvTRUE (TOPs))
306 {
307 --SP;
308 PUTBACK;
309 nextop = (OP *)${$op->other}L;
310 goto op_${$op->other};
311 }
312 }
313 EOF
314
315 out_next;
316 }
317
318 sub op_or {
319 $source .= <<EOF;
320 {
321 dSP;
322
323 if (!SvTRUE (TOPs))
324 {
325 --SP;
326 PUTBACK;
327 nextop = (OP *)${$op->other}L;
328 goto op_${$op->other};
329 }
330 }
331 EOF
332
333 out_next;
334 }
335
336 sub op_padsv {
337 my $flags = $op->flags;
338 my $padofs = "(PADOFFSET)" . $op->targ;
339
340 $source .= <<EOF;
341 {
342 dSP;
343 SV *sv = PAD_SVl ($padofs);
344 EOF
345
346 if (($flags & B::OPf_MOD) && ($op->private & B::OPpLVAL_INTRO)) {
347 $source .= " SAVECLEARSV (PAD_SVl ($padofs));\n";
348 $ops[0]{follows_padsv_lval_intro}++ if @ops;#d#
349 }
350
351 $source .= <<EOF;
352 PUSHs (sv);
353 PUTBACK;
354 EOF
355
356 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
357 $source .= " vivify_ref (sv, " . $op->private . " & OPpDEREF);\n";
358 }
359 $source .= " }\n";
360
361 out_next;
362 }
363
364 sub op_sassign {
365 $source .= <<EOF;
366 {
367 dSP;
368 dPOPTOPssrl;
369 EOF
370 $source .= " SV *temp = left; left = right; right = temp;\n"
371 if $op->private & B::OPpASSIGN_BACKWARDS;
372
373 if ($insn->{follows_padsv_lval_intro} && !($op->private & B::OPpASSIGN_BACKWARDS)) {
374 # simple assignment - the target exists, but is basically undef
375 $source .= " SvSetSV (right, left);\n";
376 } else {
377 $source .= " SvSetMagicSV (right, left);\n";
378 }
379
380 $source .= <<EOF;
381 SETs (right);
382 PUTBACK;
383 }
384 EOF
385
386 out_next;
387 }
388
389 # pattern const+ (or general push1)
390 # pattern pushmark gv rv2av pushmark padsv+o.รค. aassign
391
392 sub op_method_named {
393 if ($insn->{follows_const}) {
394 $source .= <<EOF;
395 {
396 dSP;
397 static SV *last_cv;
398 static U32 last_sub_generation;
399
400 /* simple "polymorphic" inline cache */
401 if (PL_sub_generation == last_sub_generation)
402 {
403 PUSHs (last_cv);
404 PUTBACK;
405 }
406 else
407 {
408 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
409
410 SPAGAIN;
411 last_sub_generation = PL_sub_generation;
412 last_cv = TOPs;
413 }
414 }
415 EOF
416 } else {
417 $source .= <<EOF;
418 {
419 static HV *last_stash;
420 static SV *last_cv;
421 static U32 last_sub_generation;
422
423 SV *obj = *(PL_stack_base + TOPMARK + 1);
424
425 if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
426 {
427 dSP;
428 HV *stash = SvSTASH (SvRV (obj));
429
430 /* simple "polymorphic" inline cache */
431 if (stash == last_stash
432 && PL_sub_generation == last_sub_generation)
433 {
434 PUSHs (last_cv);
435 PUTBACK;
436 }
437 else
438 {
439 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
440
441 SPAGAIN;
442 last_sub_generation = PL_sub_generation;
443 last_stash = stash;
444 last_cv = TOPs;
445 }
446 }
447 else
448 {
449 /* error case usually */
450 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
451 }
452 }
453 EOF
454 }
455
456 out_next;
457 }
458
459 sub op_grepstart {
460 out_callop;
461 $op = $op->next;
462 out_cond_jump $op->other;
463 out_jump_next;
464 }
465
466 *op_mapstart = \&op_grepstart;
467
468 sub op_substcont {
469 out_callop;
470 out_cond_jump $op->other->pmreplstart;
471 assert "nextop == (OP *)${$op->other->next}L";
472 $source .= " goto op_${$op->other->next};\n";
473 }
474
475 sub out_break_op {
476 my ($idx) = @_;
477
478 out_callop;
479
480 out_cond_jump $_->[$idx]
481 for reverse @op_loop;
482
483 $source .= " return nextop;\n";
484 }
485
486 sub xop_next {
487 out_break_op 0;
488 }
489
490 sub op_last {
491 out_break_op 1;
492 }
493
494 sub xop_redo {
495 out_break_op 2;
496 }
497
498 sub cv2c {
499 my ($cv) = @_;
500
501 local @ops;
502 local @op_loop;
503 local %op_regcomp;
504
505 my %opsseen;
506 my @todo = $cv->START;
507 my %op_target;
508
509 while (my $op = shift @todo) {
510 for (; $$op; $op = $op->next) {
511 last if $opsseen{$$op}++;
512
513 my $name = $op->name;
514 my $class = B::class $op;
515
516 my $insn = { op => $op };
517
518 push @ops, $insn;
519
520 if (exists $extend{$name}) {
521 my $extend = $extend{$name};
522 $extend = $extend->($op) if ref $extend;
523 $insn->{extend} = $extend if defined $extend;
524 }
525
526 push @todo, $op->next;
527
528 if ($class eq "LOGOP") {
529 push @todo, $op->other;
530 $op_target{${$op->other}}++;
531
532 # regcomp/o patches ops at runtime, lets expect that
533 if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
534 $op_target{${$op->first}}++;
535 $op_regcomp{${$op->first}} = $op->next;
536 }
537
538 } elsif ($class eq "PMOP") {
539 if (${$op->pmreplstart}) {
540 unshift @todo, $op->pmreplstart;
541 $op_target{${$op->pmreplstart}}++;
542 }
543
544 } elsif ($class eq "LOOP") {
545 my @targ = ($op->nextop, $op->lastop->next, $op->redoop->next);
546
547 push @op_loop, \@targ;
548 push @todo, @targ;
549
550 $op_target{$$_}++ for @targ;
551 } elsif ($class eq "COP") {
552 $insn->{bblock}++ if defined $op->label;
553 }
554 }
555 }
556
557 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
558
559 local $source = <<EOF;
560 OP *%%%FUNC%%% (pTHX)
561 {
562 register OP *nextop = (OP *)${$ops[0]->{op}}L;
563 EOF
564
565 while (@ops) {
566 $insn = shift @ops;
567
568 $op = $insn->{op};
569 $op_name = $op->name;
570
571 my $class = B::class $op;
572
573 $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
574 $source .= "op_$$op: /* $op_name */\n";
575 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
576 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
577
578 $source .= " PERL_ASYNC_CHECK ();\n"
579 unless exists $f_noasync{$op_name};
580
581 if (my $can = __PACKAGE__->can ("op_$op_name")) {
582 # handcrafted replacement
583
584 if ($insn->{extend} > 0) {
585 # coalesce EXTENDs
586 # TODO: properly take negative preceeding and following EXTENDs into account
587 for my $i (@ops) {
588 last if exists $i->{bblock};
589 last unless exists $i->{extend};
590 my $extend = delete $i->{extend};
591 $insn->{extend} += $extend if $extend > 0;
592 }
593
594 $source .= " { dSP; EXTEND (SP, $insn->{extend}); PUTBACK; }\n"
595 if $insn->{extend} > 0;
596 }
597
598 $can->($op);
599
600 } elsif (exists $f_unsafe{$op_name}) {
601 # unsafe, return to interpreter
602 assert "nextop == (OP *)$$op";
603 $source .= " return nextop;\n";
604
605 } elsif ("LOGOP" eq $class) {
606 # logical operation with optional branch
607 out_callop;
608 out_cond_jump $op->other;
609 out_jump_next;
610
611 } elsif ("PMOP" eq $class) {
612 # regex-thingy
613 out_callop;
614 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
615 out_jump_next;
616
617 } else {
618 # normal operator, linear execution
619 out_linear;
620 }
621 }
622
623 $op_name = "func exit"; assert (0);
624
625 $source .= <<EOF;
626 op_0:
627 return 0;
628 }
629 EOF
630 #warn $source;
631
632 $source
633 }
634
635 my $uid = "aaaaaaa0";
636
637 sub source2ptr {
638 my (@source) = @_;
639
640 my $stem = "/tmp/Faster-$$-" . $uid++;
641
642 open FILE, ">:raw", "$stem.c";
643 print FILE <<EOF;
644 #define PERL_NO_GET_CONTEXT
645 #define PERL_CORE
646
647 #include <assert.h>
648
649 #include "EXTERN.h"
650 #include "perl.h"
651 #include "XSUB.h"
652
653 #define RUNOPS_TILL(op) \\
654 while (nextop != (op)) \\
655 { \\
656 PERL_ASYNC_CHECK (); \\
657 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
658 }
659
660 EOF
661 for (@source) {
662 my $func = $uid++;
663 $_ =~ s/%%%FUNC%%%/$func/g;
664 print FILE $_;
665 $_ = $func;
666 }
667
668 close FILE;
669 system "$COMPILE -o $stem$_o $stem.c";
670 #d#unlink "$stem.c";
671 system "$LINK -o $stem$_so $stem$_o $LIBS";
672 unlink "$stem$_o";
673
674 my $so = DynaLoader::dl_load_file "$stem$_so"
675 or die "$stem$_so: $!";
676
677 #unlink "$stem$_so";
678
679 map +(DynaLoader::dl_find_symbol $so, $_), @source
680 }
681
682 my %ignore;
683
684 sub entersub {
685 my ($cv) = @_;
686
687 my $pkg = $cv->STASH->NAME;
688
689 return if $ignore{$pkg};
690
691 warn "compiling ", $cv->STASH->NAME, "\n"
692 if $verbose;
693
694 eval {
695 my @cv;
696 my @cv_source;
697
698 # always compile the whole stash
699 my %stash = $cv->STASH->ARRAY;
700 while (my ($k, $v) = each %stash) {
701 $v->isa (B::GV::)
702 or next;
703
704 my $cv = $v->CV;
705
706 if ($cv->isa (B::CV::)
707 && ${$cv->START}
708 && $cv->START->name ne "null") {
709 push @cv, $cv;
710 push @cv_source, cv2c $cv;
711 }
712 }
713
714 my @ptr = source2ptr @cv_source;
715
716 for (0 .. $#cv) {
717 patch_cv $cv[$_], $ptr[$_];
718 }
719 };
720
721 if ($@) {
722 $ignore{$pkg}++;
723 warn $@;
724 }
725 }
726
727 hook_entersub;
728
729 1;
730
731 =back
732
733 =head1 ENVIRONMENT VARIABLES
734
735 The following environment variables influence the behaviour of Faster:
736
737 =over 4
738
739 =item FASTER_VERBOSE
740
741 Faster will output more informational messages when set to values higher
742 than C<0>. Currently, C<1> outputs which packages are being compiled.
743
744 =item FASTER_DEBUG
745
746 Add debugging code when set to values higher than C<0>. Currently, this
747 adds 1-3 C<assert>'s per perl op, to ensure that opcode order and C
748 execution order are compatible.
749
750 =item FASTER_CACHE
751
752 NOT YET IMPLEMENTED
753
754 Set a persistent cache directory that caches compiled code
755 fragments. Normally, code compiled by Faster will be deleted immediately,
756 and every restart will recompile everything. Setting this variable to a
757 directory makes Faster cache the generated files for re-use.
758
759 This directory will always grow in contents, so you might need to erase it
760 from time to time.
761
762 =back
763
764 =head1 BUGS/LIMITATIONS
765
766 Perl will check much less often for asynchronous signals in
767 Faster-compiled code. It tries to check on every function call, loop
768 iteration and every I/O operator, though.
769
770 The following things will disable Faster. If you manage to enable them at
771 runtime, bad things will happen. Enabling them at startup will be fine,
772 though.
773
774 enabled tainting
775 enabled debugging
776
777 Thread-enabled builds of perl will dramatically reduce Faster's
778 performance, but you don't care about speed if you enable threads anyway.
779
780 These constructs will force the use of the interpreter for the currently
781 executed function as soon as they are being encountered during execution.
782
783 goto
784 next, redo (but not well-behaved last's)
785 eval
786 require
787 any use of formats
788 .., ... (flipflop operators)
789
790 =head1 AUTHOR
791
792 Marc Lehmann <schmorp@schmorp.de>
793 http://home.schmorp.de/
794
795 =cut
796