ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Faster/Faster.pm
Revision: 1.25
Committed: Sat Mar 11 04:58:53 2006 UTC (18 years, 3 months ago) by root
Branch: MAIN
Changes since 1.24: +1 -0 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_ppaddr [OP_ENTERSUB]) (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 out_next;
230 };
231
232 *op_gv = \&op_const;
233
234 *op_aelemfast = sub {
235 my $targ = $op->targ;
236 my $private = $op->private;
237
238 $source .= " {\n";
239
240 if ($op->flags & B::OPf_SPECIAL) {
241 $source .= " AV *av = (AV*)PAD_SV((PADOFFSET)$targ);\n";
242 } else {
243 $source .= " AV *av = GvAV ((GV *)${$op->sv}L);\n";
244 }
245
246 if ($op->flags & B::OPf_MOD) {
247 $source .= " SV *sv = *av_fetch (av, $private, 1);\n";
248 } else {
249 $source .= " SV **svp = av_fetch (av, $private, 0); SV *sv = svp ? *svp : &PL_sv_undef;\n";
250 }
251
252 if (!($op->flags & B::OPf_MOD)) {
253 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
254 }
255
256 $source .= " dSP;\n";
257 $source .= " PUSHs (sv);\n";
258 $source .= " PUTBACK;\n";
259 $source .= " }\n";
260
261 out_next;
262 };
263
264 *op_gvsv = sub {
265 $source .= " {\n";
266 $source .= " dSP;\n";
267
268 if ($op->private & B::OPpLVAL_INTRO) {
269 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
270 } else {
271 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
272 }
273
274 $source .= " PUTBACK;\n";
275 $source .= " }\n";
276
277 out_next;
278 };
279 }
280
281 # does kill Crossfire/res2pm
282 sub op_stringify {
283 my $targ = $op->targ;
284
285 $source .= <<EOF;
286 {
287 dSP;
288 SV *targ = PAD_SV ((PADOFFSET)$targ);
289 sv_copypv (TARG, TOPs);
290 SETTARG;
291 PUTBACK;
292 }
293 EOF
294
295 out_next;
296 }
297
298 sub op_and {
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 out_next;
314 }
315
316 sub op_or {
317 $source .= <<EOF;
318 {
319 dSP;
320
321 if (!SvTRUE (TOPs))
322 {
323 --SP;
324 PUTBACK;
325 nextop = (OP *)${$op->other}L;
326 goto op_${$op->other};
327 }
328 }
329 EOF
330
331 out_next;
332 }
333
334 sub op_padsv {
335 my $flags = $op->flags;
336 my $padofs = "(PADOFFSET)" . $op->targ;
337
338 #d#TODO: why does our version break
339 # breaks gce with can't coerce array....
340 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {#d#
341 return out_linear;#d#
342 }#d#
343
344 $source .= <<EOF;
345 {
346 dSP;
347 SV *sv = PAD_SVl ($padofs);
348 EOF
349
350 if (($flags & B::OPf_MOD) && ($op->private & B::OPpLVAL_INTRO)) {
351 $source .= " SAVECLEARSV (PAD_SVl ($padofs));\n";
352 $ops[0]{pre_padsv_lval_intro}++ if @ops;#d#
353 }
354
355 $source .= <<EOF;
356 PUSHs (sv);
357 PUTBACK;
358 EOF
359
360 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
361 $source .= " vivify_ref (sv, $flags & OPpDEREF);\n";
362 }
363 $source .= " }\n";
364
365 out_next;
366 }
367
368 sub op_sassign {
369 $source .= <<EOF;
370 {
371 dSP;
372 dPOPTOPssrl;
373 EOF
374 $source .= " SV *temp = left; left = right; right = temp;\n"
375 if $op->private & B::OPpASSIGN_BACKWARDS;
376
377 if ($insn->{pre_padsv_lval_intro} && !($op->private & B::OPpASSIGN_BACKWARDS)) {
378 # simple assignment - the target exists, but is basically undef
379 $source .= " SvSetSV (right, left);\n";
380 } else {
381 $source .= " SvSetMagicSV (right, left);\n";
382 }
383
384 $source .= <<EOF;
385 SETs (right);
386 PUTBACK;
387 }
388 EOF
389
390 out_next;
391 }
392
393 # pattern const+ (or general push1)
394 # pattern pushmark return(?)
395 # pattern pushmark gv rv2av pushmark padsv+o.รค. aassign
396
397 # pattern const method_named
398 sub op_method_named {
399 $source .= <<EOF;
400 {
401 static HV *last_stash;
402 static SV *last_cv;
403 static U32 last_sub_generation;
404
405 SV *obj = *(PL_stack_base + TOPMARK + 1);
406
407 if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
408 {
409 dSP;
410 HV *stash = SvSTASH (SvRV (obj));
411
412 /* simple "polymorphic" inline cache */
413 if (stash == last_stash
414 && PL_sub_generation == last_sub_generation)
415 {
416 PUSHs (last_cv);
417 PUTBACK;
418 }
419 else
420 {
421 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
422
423 SPAGAIN;
424 last_sub_generation = PL_sub_generation;
425 last_stash = stash;
426 last_cv = TOPs;
427 }
428 }
429 else
430 {
431 /* error case usually */
432 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
433 }
434 }
435 EOF
436
437 out_next;
438 }
439
440 sub op_grepstart {
441 out_callop;
442 $op = $op->next;
443 out_cond_jump $op->other;
444 out_jump_next;
445 }
446
447 *op_mapstart = \&op_grepstart;
448
449 sub op_substcont {
450 out_callop;
451 out_cond_jump $op->other->pmreplstart;
452 assert "nextop == (OP *)${$op->other->next}L";
453 $source .= " goto op_${$op->other->next};\n";
454 }
455
456 sub out_break_op {
457 my ($idx) = @_;
458
459 out_callop;
460
461 out_cond_jump $_->[$idx]
462 for reverse @op_loop;
463
464 $source .= " return nextop;\n";
465 }
466
467 sub xop_next {
468 out_break_op 0;
469 }
470
471 sub op_last {
472 out_break_op 1;
473 }
474
475 sub xop_redo {
476 out_break_op 2;
477 }
478
479 sub cv2c {
480 my ($cv) = @_;
481
482 local @ops;
483 local @op_loop;
484 local %op_regcomp;
485
486 my %opsseen;
487 my @todo = $cv->START;
488 my %op_target;
489
490 while (my $op = shift @todo) {
491 for (; $$op; $op = $op->next) {
492 last if $opsseen{$$op}++;
493
494 my $name = $op->name;
495 my $class = B::class $op;
496
497 my $insn = { op => $op };
498
499 push @ops, $insn;
500
501 if (exists $extend{$name}) {
502 my $extend = $extend{$name};
503 $extend = $extend->($op) if ref $extend;
504 $insn->{extend} = $extend if defined $extend;
505 }
506
507 push @todo, $op->next;
508
509 if ($class eq "LOGOP") {
510 push @todo, $op->other;
511 $op_target{${$op->other}}++;
512
513 # regcomp/o patches ops at runtime, lets expect that
514 if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
515 $op_target{${$op->first}}++;
516 $op_regcomp{${$op->first}} = $op->next;
517 }
518
519 } elsif ($class eq "PMOP") {
520 if (${$op->pmreplstart}) {
521 unshift @todo, $op->pmreplstart;
522 $op_target{${$op->pmreplstart}}++;
523 }
524
525 } elsif ($class eq "LOOP") {
526 my @targ = ($op->nextop, $op->lastop->next, $op->redoop->next);
527
528 push @op_loop, \@targ;
529 push @todo, @targ;
530
531 $op_target{$$_}++ for @targ;
532 } elsif ($class eq "COP") {
533 $insn->{bblock}++ if defined $op->label;
534 }
535 }
536 }
537
538 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
539
540 local $source = <<EOF;
541 OP *%%%FUNC%%% (pTHX)
542 {
543 register OP *nextop = (OP *)${$ops[0]->{op}}L;
544 EOF
545
546 while (@ops) {
547 $insn = shift @ops;
548
549 $op = $insn->{op};
550 $op_name = $op->name;
551
552 my $class = B::class $op;
553
554 $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
555 $source .= "op_$$op: /* $op_name */\n";
556 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
557 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
558
559 $source .= " PERL_ASYNC_CHECK ();\n"
560 unless exists $f_noasync{$op_name};
561
562 if (my $can = __PACKAGE__->can ("op_$op_name")) {
563 # handcrafted replacement
564
565 if ($insn->{extend} > 0) {
566 # coalesce EXTENDs
567 # TODO: properly take negative preceeding and following EXTENDs into account
568 for my $i (@ops) {
569 last if exists $i->{bblock};
570 last unless exists $i->{extend};
571 my $extend = delete $i->{extend};
572 $insn->{extend} += $extend if $extend > 0;
573 }
574
575 $source .= " { dSP; EXTEND (SP, $insn->{extend}); PUTBACK; }\n"
576 if $insn->{extend} > 0;
577 }
578
579 $can->($op);
580
581 } elsif (exists $f_unsafe{$op_name}) {
582 # unsafe, return to interpreter
583 assert "nextop == (OP *)$$op";
584 $source .= " return nextop;\n";
585
586 } elsif ("LOGOP" eq $class) {
587 # logical operation with optional branch
588 out_callop;
589 out_cond_jump $op->other;
590 out_jump_next;
591
592 } elsif ("PMOP" eq $class) {
593 # regex-thingy
594 out_callop;
595 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
596 out_jump_next;
597
598 } else {
599 # normal operator, linear execution
600 out_linear;
601 }
602 }
603
604 $op_name = "func exit"; assert (0);
605
606 $source .= <<EOF;
607 op_0:
608 return 0;
609 }
610 EOF
611 #warn $source;
612
613 $source
614 }
615
616 my $uid = "aaaaaaa0";
617
618 sub source2ptr {
619 my (@source) = @_;
620
621 my $stem = "/tmp/Faster-$$-" . $uid++;
622
623 open FILE, ">:raw", "$stem.c";
624 print FILE <<EOF;
625 #define PERL_NO_GET_CONTEXT
626 #define PERL_CORE
627
628 #include <assert.h>
629
630 #include "EXTERN.h"
631 #include "perl.h"
632 #include "XSUB.h"
633
634 #define RUNOPS_TILL(op) \\
635 while (nextop != (op)) \\
636 { \\
637 PERL_ASYNC_CHECK (); \\
638 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
639 }
640
641 EOF
642 for (@source) {
643 my $func = $uid++;
644 $_ =~ s/%%%FUNC%%%/$func/g;
645 print FILE $_;
646 $_ = $func;
647 }
648
649 close FILE;
650 system "$COMPILE -o $stem$_o $stem.c";
651 #d#unlink "$stem.c";
652 system "$LINK -o $stem$_so $stem$_o $LIBS";
653 unlink "$stem$_o";
654
655 my $so = DynaLoader::dl_load_file "$stem$_so"
656 or die "$stem$_so: $!";
657
658 #unlink "$stem$_so";
659
660 map +(DynaLoader::dl_find_symbol $so, $_), @source
661 }
662
663 my %ignore;
664
665 sub entersub {
666 my ($cv) = @_;
667
668 my $pkg = $cv->STASH->NAME;
669
670 return if $ignore{$pkg};
671
672 warn "compiling ", $cv->STASH->NAME, "\n"
673 if $verbose;
674
675 eval {
676 my @cv;
677 my @cv_source;
678
679 # always compile the whole stash
680 my %stash = $cv->STASH->ARRAY;
681 while (my ($k, $v) = each %stash) {
682 $v->isa (B::GV::)
683 or next;
684
685 my $cv = $v->CV;
686
687 if ($cv->isa (B::CV::)
688 && ${$cv->START}
689 && $cv->START->name ne "null") {
690 push @cv, $cv;
691 push @cv_source, cv2c $cv;
692 }
693 }
694
695 my @ptr = source2ptr @cv_source;
696
697 for (0 .. $#cv) {
698 patch_cv $cv[$_], $ptr[$_];
699 }
700 };
701
702 if ($@) {
703 $ignore{$pkg}++;
704 warn $@;
705 }
706 }
707
708 hook_entersub;
709
710 1;
711
712 =back
713
714 =head1 ENVIRONMENT VARIABLES
715
716 The following environment variables influence the behaviour of Faster:
717
718 =over 4
719
720 =item FASTER_VERBOSE
721
722 Faster will output more informational messages when set to values higher
723 than C<0>. Currently, C<1> outputs which packages are being compiled.
724
725 =item FASTER_DEBUG
726
727 Add debugging code when set to values higher than C<0>. Currently, this
728 adds 1-3 C<assert>'s per perl op, to ensure that opcode order and C
729 execution order are compatible.
730
731 =item FASTER_CACHE
732
733 NOT YET IMPLEMENTED
734
735 Set a persistent cache directory that caches compiled code
736 fragments. Normally, code compiled by Faster will be deleted immediately,
737 and every restart will recompile everything. Setting this variable to a
738 directory makes Faster cache the generated files for re-use.
739
740 This directory will always grow in contents, so you might need to erase it
741 from time to time.
742
743 =back
744
745 =head1 BUGS/LIMITATIONS
746
747 Perl will check much less often for asynchronous signals in
748 Faster-compiled code. It tries to check on every function call, loop
749 iteration and every I/O operator, though.
750
751 The following things will disable Faster. If you manage to enable them at
752 runtime, bad things will happen. Enabling them at startup will be fine,
753 though.
754
755 enabled tainting
756 enabled debugging
757
758 Thread-enabled builds of perl will dramatically reduce Faster's
759 performance, but you don't care about speed if you enable threads anyway.
760
761 These constructs will force the use of the interpreter for the currently
762 executed function as soon as they are being encountered during execution.
763
764 goto
765 next, redo (but not well-behaved last's)
766 eval
767 require
768 any use of formats
769 .., ... (flipflop operators)
770
771 =head1 AUTHOR
772
773 Marc Lehmann <schmorp@schmorp.de>
774 http://home.schmorp.de/
775
776 =cut
777