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