ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Faster/Faster.pm
Revision: 1.23
Committed: Fri Mar 10 22:45:18 2006 UTC (18 years, 2 months ago) by root
Branch: MAIN
Changes since 1.22: +6 -4 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 my $class = B::class $op;
448
449 $source .= "op_$$op: /* $op_name */\n";
450 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
451 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
452
453 $source .= " PERL_ASYNC_CHECK ();\n"
454 unless exists $f_noasync{$op_name};
455
456 if (my $can = __PACKAGE__->can ("op_$op_name")) {
457 # handcrafted replacement
458 $can->($op);
459
460 } elsif (exists $f_unsafe{$op_name}) {
461 # unsafe, return to interpreter
462 assert "nextop == (OP *)$$op";
463 $source .= " return nextop;\n";
464
465 } elsif ("LOGOP" eq $class) {
466 # logical operation with optional branch
467 out_callop;
468 out_cond_jump $op->other;
469 out_jump_next;
470
471 } elsif ("PMOP" eq $class) {
472 # regex-thingy
473 out_callop;
474 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
475 out_jump_next;
476
477 } else {
478 # normal operator, linear execution
479 out_linear;
480 }
481 }
482
483 $op_name = "func exit"; assert (0);
484
485 $source .= <<EOF;
486 op_0:
487 return 0;
488 }
489 EOF
490 #warn $source;
491
492 $source
493 }
494
495 my $uid = "aaaaaaa0";
496
497 sub source2ptr {
498 my (@source) = @_;
499
500 my $stem = "/tmp/Faster-$$-" . $uid++;
501
502 open FILE, ">:raw", "$stem.c";
503 print FILE <<EOF;
504 #define PERL_NO_GET_CONTEXT
505
506 #include <assert.h>
507
508 #include "EXTERN.h"
509 #include "perl.h"
510 #include "XSUB.h"
511
512 #define RUNOPS_TILL(op) \\
513 while (nextop != (op)) \\
514 { \\
515 PERL_ASYNC_CHECK (); \\
516 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
517 }
518
519 EOF
520 for (@source) {
521 my $func = $uid++;
522 $_ =~ s/%%%FUNC%%%/$func/g;
523 print FILE $_;
524 $_ = $func;
525 }
526
527 close FILE;
528 system "$COMPILE -o $stem$_o $stem.c";
529 #d#unlink "$stem.c";
530 system "$LINK -o $stem$_so $stem$_o $LIBS";
531 unlink "$stem$_o";
532
533 my $so = DynaLoader::dl_load_file "$stem$_so"
534 or die "$stem$_so: $!";
535
536 #unlink "$stem$_so";
537
538 map +(DynaLoader::dl_find_symbol $so, $_), @source
539 }
540
541 my %ignore;
542
543 sub entersub {
544 my ($cv) = @_;
545
546 my $pkg = $cv->STASH->NAME;
547
548 return if $ignore{$pkg};
549
550 warn "compiling ", $cv->STASH->NAME, "\n"
551 if $verbose;
552
553 eval {
554 my @cv;
555 my @cv_source;
556
557 # always compile the whole stash
558 my %stash = $cv->STASH->ARRAY;
559 while (my ($k, $v) = each %stash) {
560 $v->isa (B::GV::)
561 or next;
562
563 my $cv = $v->CV;
564
565 if ($cv->isa (B::CV::)
566 && ${$cv->START}
567 && $cv->START->name ne "null") {
568 push @cv, $cv;
569 push @cv_source, cv2c $cv;
570 }
571 }
572
573 my @ptr = source2ptr @cv_source;
574
575 for (0 .. $#cv) {
576 patch_cv $cv[$_], $ptr[$_];
577 }
578 };
579
580 if ($@) {
581 $ignore{$pkg}++;
582 warn $@;
583 }
584 }
585
586 hook_entersub;
587
588 1;
589
590 =back
591
592 =head1 ENVIRONMENT VARIABLES
593
594 The following environment variables influence the behaviour of Faster:
595
596 =over 4
597
598 =item FASTER_VERBOSE
599
600 Faster will output more informational messages when set to values higher
601 than C<0>. Currently, C<1> outputs which packages are being compiled.
602
603 =item FASTER_DEBUG
604
605 Add debugging code when set to values higher than C<0>. Currently, this
606 adds 1-3 C<assert>'s per perl op, to ensure that opcode order and C
607 execution order are compatible.
608
609 =item FASTER_CACHE
610
611 NOT YET IMPLEMENTED
612
613 Set a persistent cache directory that caches compiled code
614 fragments. Normally, code compiled by Faster will be deleted immediately,
615 and every restart will recompile everything. Setting this variable to a
616 directory makes Faster cache the generated files for re-use.
617
618 This directory will always grow in contents, so you might need to erase it
619 from time to time.
620
621 =back
622
623 =head1 BUGS/LIMITATIONS
624
625 Perl will check much less often for asynchronous signals in
626 Faster-compiled code. It tries to check on every function call, loop
627 iteration and every I/O operator, though.
628
629 The following things will disable Faster. If you manage to enable them at
630 runtime, bad things will happen. Enabling them at startup will be fine,
631 though.
632
633 enabled tainting
634 enabled debugging
635
636 Thread-enabled builds of perl will dramatically reduce Faster's
637 performance, but you don't care about speed if you enable threads anyway.
638
639 These constructs will force the use of the interpreter for the currently
640 executed function as soon as they are being encountered during execution.
641
642 goto
643 next, redo (but not well-behaved last's)
644 eval
645 require
646 any use of formats
647 .., ... (flipflop operators)
648
649 =head1 AUTHOR
650
651 Marc Lehmann <schmorp@schmorp.de>
652 http://home.schmorp.de/
653
654 =cut
655