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