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