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