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