ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Faster/Faster.pm
(Generate patch)

Comparing Faster/Faster.pm (file contents):
Revision 1.5 by root, Thu Mar 9 22:55:56 2006 UTC vs.
Revision 1.29 by root, Sun Mar 12 21:36:00 2006 UTC

… …
4 4
5=head1 SYNOPSIS 5=head1 SYNOPSIS
6 6
7 use Faster; 7 use Faster;
8 8
9 perl -MFaster ...
10
9=head1 DESCRIPTION 11=head1 DESCRIPTION
10 12
13This module implements a very simple-minded JIT. It works by more or less
14translating every function it sees into a C program, compiling it and then
15replacing the function by the compiled code.
16
17As a result, startup times are immense, as every function might lead to a
18full-blown compilation.
19
20The speed improvements are also not great, you can expect 20% or so on
21average, for code that runs very often.
22
23Faster is in the early stages of development. Due to its design its
24relatively safe to use (it will either work or simply slowdown the program
25immensely, but rarely cause bugs).
26
27Usage is very easy, just C<use Faster> and every function called from then
28on will be compiled.
29
30Right now, Faster will leave lots of F<*.c>, F<*.o> and F<*.so> files in
31your F<$FASTER_CACHEDIR> (by default F<$HOME/.perl-faster-cache>), and it
32will even create those temporary files in an insecure manner, so watch
33out.
34
11=over 4 35=over 4
12 36
13=cut 37=cut
14 38
15package Faster; 39package Faster;
40
41no warnings;
16 42
17use strict; 43use strict;
18use Config; 44use Config;
19use B (); 45use B ();
46use DynaLoader ();
20use Digest::MD5 (); 47use Digest::MD5 ();
21use DynaLoader (); 48use Storable ();
49use Fcntl ();
22 50
23BEGIN { 51BEGIN {
24 our $VERSION = '0.01'; 52 our $VERSION = '0.01';
25 53
26 require XSLoader; 54 require XSLoader;
27 XSLoader::load __PACKAGE__, $VERSION; 55 XSLoader::load __PACKAGE__, $VERSION;
28} 56}
57
58my $CACHEDIR =
59 $ENV{FASTER_CACHE}
60 || (exists $ENV{HOME} && "$ENV{HOME}/.perl-faster-cache")
61 || do {
62 require File::Temp;
63 File::Temp::tempdir (CLEANUP => 1)
64 };
29 65
30my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}"; 66my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}";
31my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}"; 67my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
32my $LIBS = "$Config{libs}"; 68my $LIBS = "$Config{libs}";
33my $_o = $Config{_o}; 69my $_o = $Config{_o};
34my $_so = ".so"; 70my $_so = ".so";
35 71
72# we don't need no steenking PIC on x86
73$COMPILE =~ s/-f(?:PIC|pic)//g
74 if $Config{archname} =~ /^(i[3456]86)-/;
75
76my $opt_assert = $ENV{FASTER_DEBUG};
77my $verbose = $ENV{FASTER_VERBOSE}+0;
78
79warn "Faster: CACHEDIR is $CACHEDIR\n" if $verbose > 2;
80
36our $source; 81our $source;
37our $label_next;
38our $label_last;
39our $label_redo;
40 82
41my %flag; 83our @ops;
84our $insn;
85our $op;
86our $op_name;
87our @op_loop;
88our %op_regcomp;
42 89
43for (split /\n/, <<EOF) { 90# ops that cause immediate return to the interpreter
44 leavesub unsafe 91my %f_unsafe = map +($_ => undef), qw(
45 leavesublv unsafe 92 leavesub leavesublv return
46 return unsafe 93 goto last redo next
47 flip unsafe 94 eval flip leaveeval entertry
48 goto unsafe 95 formline grepstart mapstart
49 last unsafe 96 substcont entereval require
50 redo unsafe 97);
51 next unsafe
52 eval unsafe
53 leaveeval unsafe
54 entertry unsafe
55 substconst unsafe
56 formline unsafe
57 grepstart unsafe
58 require unsafe
59 match unsafe todo
60 subst unsafe todo
61 entereval unsafe todo
62 mapstart unsafe todo
63 98
64 pushmark noasync 99# ops with known stack extend behaviour
65 padsv noasync 100# the values given are maximum values
66 entersub noasync 101my %extend = (
67 aassign noasync 102 pushmark => 0,
68 sassign noasync 103 nextstate => 0, # might reduce the stack
69 rv2av noasync 104 unstack => 0,
70 nextstate noasync 105 enter => 0,
71 gv noasync
72 gvsv noasync
73 add noasync
74 subtract noasync
75 multiply noasync
76 divide noasync
77 complement noasync
78 cond_expr noasync
79 and noasync
80 or noasync
81 not noasync
82 method_named noasync
83 preinc noasync
84 postinc noasync
85 predec noasync
86 postdec noasync
87 stub noasync
88 unstack noasync
89 leaveloop noasync
90 shift noasync
91 aelemA noasync
92 aelemfast noasync
93EOF
94 my (undef, $op, @flags) = split /\s+/;
95 106
96 undef $flag{$_}{$op} 107 stringify => 0,
97 for ("known", @flags); 108 not => 0,
109 and => 0,
110 or => 0,
111 gvsv => 0,
112 rv2gv => 0,
113 preinc => 0,
114 predec => 0,
115 postinc => 0,
116 postdec => 0,
117 aelem => 0,
118 helem => 0,
119 qr => 1, #???
120 pushre => 1,
121 gv => 1,
122 aelemfast => 1,
123 aelem => 0,
124 padsv => 1,
125 const => 1,
126 pop => 1,
127 shift => 1,
128 eq => -1,
129 ne => -1,
130 gt => -1,
131 lt => -1,
132 ge => -1,
133 lt => -1,
134 cond_expr => -1,
135 add => -1,
136 subtract => -1,
137 multiply => -1,
138 divide => -1,
139 aassign => 0,
140 sassign => -2,
141 method => 0,
142 method_named => 1,
143);
144
145# ops that do not need an ASYNC_CHECK
146my %f_noasync = map +($_ => undef), qw(
147 mapstart grepstart match entereval
148 enteriter entersub leaveloop
149
150 pushmark nextstate
151
152 const stub unstack
153 last next redo seq
154 padsv padav padhv padany
155 aassign sassign orassign
156 rv2av rv2cv rv2gv rv2hv refgen
157 gv gvsv
158 add subtract multiply divide
159 complement cond_expr and or not
160 defined
161 method method_named bless
162 preinc postinc predec postdec
163 aelem aelemfast helem delete exists
164 pushre subst list join split concat
165 length substr stringify ord
166 push pop shift unshift
167 eq ne gt lt ge le
168 regcomp regcreset regcmaybe
169);
170
171my %callop = (
172 entersub => "(PL_op->op_ppaddr) (aTHX)",
173 mapstart => "Perl_pp_grepstart (aTHX)",
174);
175
176sub callop {
177 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
178}
179
180sub assert {
181 return unless $opt_assert;
182 $source .= " assert ((\"$op_name\", ($_[0])));\n";
183}
184
185sub out_callop {
186 assert "nextop == (OP *)$$op";
187 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
188}
189
190sub out_cond_jump {
191 $source .= " if (nextop == (OP *)${$_[0]}L) goto op_${$_[0]};\n";
192}
193
194sub out_jump_next {
195 out_cond_jump $op_regcomp{$$op}
196 if $op_regcomp{$$op};
197
198 assert "nextop == (OP *)${$op->next}";
199 $source .= " goto op_${$op->next};\n";
98} 200}
99 201
100sub out_next { 202sub out_next {
101 my ($op) = @_;
102
103 if (${$op->next}) {
104 $source .= " nextop = (OP *)${$op->next}L;\n"; 203 $source .= " nextop = (OP *)${$op->next}L;\n";
105 $source .= " goto op_${$op->next};\n";
106 } else {
107 $source .= " return 0;\n";
108 }
109}
110 204
111sub callop { 205 out_jump_next;
112 my ($op) = @_;
113
114 my $name = $op->name;
115
116 $name eq "entersub"
117 ? "(PL_ppaddr [OP_ENTERSUB]) (aTHX)"
118 : $name eq "mapstart"
119 ? "Perl_pp_grepstart (aTHX)"
120 : "Perl_pp_$name (aTHX)"
121} 206}
207
208sub out_linear {
209 out_callop;
210 out_jump_next;
211}
212
213sub op_entersub {
214 out_callop;
215 $source .= " RUNOPS_TILL ((OP *)${$op->next}L);\n";
216 out_jump_next;
217}
218
219*op_require = \&op_entersub;
122 220
123sub op_nextstate { 221sub op_nextstate {
124 my ($op) = @_;
125
126 $source .= " PL_curcop = (COP *)nextop;\n"; 222 $source .= " PL_curcop = (COP *)nextop;\n";
127 $source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n"; 223 $source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
128 $source .= " FREETMPS;\n"; 224 $source .= " FREETMPS;\n";
129 225
130 out_next $op; 226 out_next;
131} 227}
132 228
133sub op_pushmark { 229sub op_pushmark {
134 my ($op) = @_;
135
136 $source .= " PUSHMARK (PL_stack_sp);\n"; 230 $source .= " PUSHMARK (PL_stack_sp);\n";
137 231
138 out_next $op; 232 out_next;
139} 233}
140 234
141sub op_const { 235if ($Config{useithreads} ne "define") {
142 my ($op) = @_; 236 # disable optimisations on ithreads
143 237
238 *op_const = sub {
144 $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n"; 239 $source .= " { dSP; PUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
145 240
241 $ops[0]{follows_const}++ if @ops;#d#
242
146 out_next $op; 243 out_next;
147} 244 };
148 245
149*op_gv = \&op_const; 246 *op_gv = \&op_const;
150 247
248 *op_aelemfast = sub {
249 my $targ = $op->targ;
250 my $private = $op->private;
251
252 $source .= " {\n";
253
254 if ($op->flags & B::OPf_SPECIAL) {
255 $source .= " AV *av = (AV*)PAD_SV((PADOFFSET)$targ);\n";
256 } else {
257 $source .= " AV *av = GvAV ((GV *)${$op->sv}L);\n";
258 }
259
260 if ($op->flags & B::OPf_MOD) {
261 $source .= " SV *sv = *av_fetch (av, $private, 1);\n";
262 } else {
263 $source .= " SV **svp = av_fetch (av, $private, 0); SV *sv = svp ? *svp : &PL_sv_undef;\n";
264 }
265
266 if (!($op->flags & B::OPf_MOD)) {
267 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
268 }
269
270 $source .= " dSP;\n";
271 $source .= " PUSHs (sv);\n";
272 $source .= " PUTBACK;\n";
273 $source .= " }\n";
274
275 out_next;
276 };
277
278 *op_gvsv = sub {
279 $source .= " {\n";
280 $source .= " dSP;\n";
281
282 if ($op->private & B::OPpLVAL_INTRO) {
283 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
284 } else {
285 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
286 }
287
288 $source .= " PUTBACK;\n";
289 $source .= " }\n";
290
291 out_next;
292 };
293}
294
295# does kill Crossfire/res2pm
151sub op_stringify { 296sub op_stringify {
152 my ($op) = @_; 297 my $targ = $op->targ;
153 298
154 $source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n"; 299 $source .= <<EOF;
300 {
301 dSP;
302 SV *targ = PAD_SV ((PADOFFSET)$targ);
303 sv_copypv (TARG, TOPs);
304 SETTARG;
305 PUTBACK;
306 }
307EOF
155 308
156 out_next $op; 309 out_next;
157} 310}
158 311
159sub op_and { 312sub op_and {
160 my ($op) = @_;
161
162 $source .= <<EOF; 313 $source .= <<EOF;
163 { 314 {
164 dSP; 315 dSP;
165 316
166 if (SvTRUE (TOPs)) 317 if (SvTRUE (TOPs))
… …
171 goto op_${$op->other}; 322 goto op_${$op->other};
172 } 323 }
173 } 324 }
174EOF 325EOF
175 326
176 out_next $op; 327 out_next;
177} 328}
178 329
179sub op_padsv { 330sub op_or {
180 my ($op) = @_;
181
182 my $flags = $op->flags;
183 my $target = $op->targ;
184
185 $source .= <<EOF; 331 $source .= <<EOF;
186 { 332 {
187 dSP; 333 dSP;
188 XPUSHs (PAD_SV ((PADOFFSET)$target)); 334
189 PUTBACK; 335 if (!SvTRUE (TOPs))
190EOF
191 if ($op->flags & B::OPf_MOD) {
192 if ($op->private & B::OPpLVAL_INTRO) {
193 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n";
194 } elsif ($op->private & B::OPpDEREF) {
195 my $deref = $op->private & B::OPpDEREF;
196 $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
197 } 336 {
198 } 337 --SP;
199 $source .= <<EOF; 338 PUTBACK;
339 nextop = (OP *)${$op->other}L;
340 goto op_${$op->other};
341 }
200 } 342 }
201EOF 343EOF
202 344
203 out_next $op; 345 out_next;
204} 346}
205 347
206# pattern const+ (or general push1) 348sub op_padsv {
207# pattern pushmark return(?) 349 my $flags = $op->flags;
208# pattern pushmark gv rv2av pushmark padsv+o.รค. aassign 350 my $padofs = "(PADOFFSET)" . $op->targ;
209
210# pattern const method_named
211sub op_method_named {
212 my ($op) = @_;
213 351
214 $source .= <<EOF; 352 $source .= <<EOF;
215 { 353 {
354 dSP;
355 SV *sv = PAD_SVl ($padofs);
356EOF
357
358 if (($flags & B::OPf_MOD) && ($op->private & B::OPpLVAL_INTRO)) {
359 $source .= " SAVECLEARSV (PAD_SVl ($padofs));\n";
360 $ops[0]{follows_padsv_lval_intro}++ if @ops;#d#
361 }
362
363 $source .= <<EOF;
364 PUSHs (sv);
365 PUTBACK;
366EOF
367
368 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
369 $source .= " if (!SvROK (sv)) vivify_ref (sv, " . $op->private . " & OPpDEREF);\n";
370 }
371 $source .= " }\n";
372
373 out_next;
374}
375
376sub op_sassign {
377 $source .= <<EOF;
378 {
379 dSP;
380 dPOPTOPssrl;
381EOF
382 $source .= " SV *temp = left; left = right; right = temp;\n"
383 if $op->private & B::OPpASSIGN_BACKWARDS;
384
385 if ($insn->{follows_padsv_lval_intro} && !($op->private & B::OPpASSIGN_BACKWARDS)) {
386 # simple assignment - the target exists, but is basically undef
387 $source .= " SvSetSV (right, left);\n";
388 } else {
389 $source .= " SvSetMagicSV (right, left);\n";
390 }
391
392 $source .= <<EOF;
393 SETs (right);
394 PUTBACK;
395 }
396EOF
397
398 out_next;
399}
400
401# pattern const+ (or general push1)
402# pattern pushmark gv rv2av pushmark padsv+o.รค. aassign
403
404sub op_method_named {
405 if ($insn->{follows_const}) {
406 $source .= <<EOF;
407 {
408 dSP;
409 static SV *last_cv;
410 static U32 last_sub_generation;
411
412 /* simple "polymorphic" inline cache */
413 if (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_cv = TOPs;
425 }
426 }
427EOF
428 } else {
429 $source .= <<EOF;
430 {
216 static HV *last_stash; 431 static HV *last_stash;
217 static SV *last_res; 432 static SV *last_cv;
433 static U32 last_sub_generation;
218 434
219 SV *obj = *(PL_stack_base + TOPMARK + 1); 435 SV *obj = *(PL_stack_base + TOPMARK + 1);
220 436
221 if (SvROK (obj) && SvOBJECT (SvRV (obj))) 437 if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
222 { 438 {
223 dSP; 439 dSP;
224 HV *stash = SvSTASH (SvRV (obj)); 440 HV *stash = SvSTASH (SvRV (obj));
225 441
226 /* simple "polymorphic" inline cache */ 442 /* simple "polymorphic" inline cache */
227 if (stash == last_stash) 443 if (stash == last_stash
444 && PL_sub_generation == last_sub_generation)
228 { 445 {
229 XPUSHs (last_res); 446 PUSHs (last_cv);
230 PUTBACK; 447 PUTBACK;
231 } 448 }
232 else 449 else
233 { 450 {
234 PL_op = nextop;
235 nextop = Perl_pp_method_named (aTHX); 451 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
236 452
237 SPAGAIN; 453 SPAGAIN;
454 last_sub_generation = PL_sub_generation;
238 last_stash = stash; 455 last_stash = stash;
239 last_res = TOPs; 456 last_cv = TOPs;
240 } 457 }
241 } 458 }
242 else 459 else
243 { 460 {
244 /* error case usually */ 461 /* error case usually */
245 PL_op = nextop;
246 nextop = Perl_pp_method_named (aTHX); 462 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
247 } 463 }
248 } 464 }
249EOF 465EOF
466 }
250 467
251 out_next $op; 468 out_next;
469}
470
471sub op_grepstart {
472 out_callop;
473 $op = $op->next;
474 out_cond_jump $op->other;
475 out_jump_next;
476}
477
478*op_mapstart = \&op_grepstart;
479
480sub op_substcont {
481 out_callop;
482 out_cond_jump $op->other->pmreplstart;
483 assert "nextop == (OP *)${$op->other->next}L";
484 $source .= " goto op_${$op->other->next};\n";
485}
486
487sub out_break_op {
488 my ($idx) = @_;
489
490 out_callop;
491
492 out_cond_jump $_->[$idx]
493 for reverse @op_loop;
494
495 $source .= " return nextop;\n";
496}
497
498sub xop_next {
499 out_break_op 0;
500}
501
502sub op_last {
503 out_break_op 1;
504}
505
506sub xop_redo {
507 out_break_op 2;
252} 508}
253 509
254sub cv2c { 510sub cv2c {
255 my ($cv) = @_; 511 my ($cv) = @_;
256 512
513 local @ops;
514 local @op_loop;
515 local %op_regcomp;
516
257 my %opsseen; 517 my %opsseen;
258 my @ops;
259 my @todo = $cv->START; 518 my @todo = $cv->START;
519 my %op_target;
260 520
261 while (my $op = shift @todo) { 521 while (my $op = shift @todo) {
262 for (; $$op; $op = $op->next) { 522 for (; $$op; $op = $op->next) {
263 last if $opsseen{$$op}++; 523 last if $opsseen{$$op}++;
264 push @ops, $op; 524
265 my $name = $op->name; 525 my $name = $op->name;
526 my $class = B::class $op;
527
528 my $insn = { op => $op };
529
530 push @ops, $insn;
531
532 if (exists $extend{$name}) {
533 my $extend = $extend{$name};
534 $extend = $extend->($op) if ref $extend;
535 $insn->{extend} = $extend if defined $extend;
536 }
537
538 push @todo, $op->next;
539
266 if (B::class($op) eq "LOGOP") { 540 if ($class eq "LOGOP") {
267 push @todo, $op->other; 541 push @todo, $op->other;
268 } elsif ($name eq "subst" and ${ $op->pmreplstart }) { 542 $op_target{${$op->other}}++;
269 push @todo, $op->pmreplstart; 543
270 } elsif ($name =~ /^enter(loop|iter)$/) { 544 # regcomp/o patches ops at runtime, lets expect that
271# if ($] > 5.009) { 545 if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
272# $labels{${$op->nextop}} = "NEXT"; 546 $op_target{${$op->first}}++;
273# $labels{${$op->lastop}} = "LAST"; 547 $op_regcomp{${$op->first}} = $op->next;
274# $labels{${$op->redoop}} = "REDO";
275# } else {
276# $labels{$op->nextop->seq} = "NEXT";
277# $labels{$op->lastop->seq} = "LAST";
278# $labels{$op->redoop->seq} = "REDO";
279# } 548 }
549
550 } elsif ($class eq "PMOP") {
551 if (${$op->pmreplstart}) {
552 unshift @todo, $op->pmreplstart;
553 $op_target{${$op->pmreplstart}}++;
554 }
555
556 } elsif ($class eq "LOOP") {
557 my @targ = ($op->nextop, $op->lastop->next, $op->redoop->next);
558
559 push @op_loop, \@targ;
560 push @todo, @targ;
561
562 $op_target{$$_}++ for @targ;
563 } elsif ($class eq "COP") {
564 $insn->{bblock}++ if defined $op->label;
280 } 565 }
281 } 566 }
282 } 567 }
283 568
569 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
570
284 local $source = <<EOF; 571 local $source = <<EOF;
572OP *%%%FUNC%%% (pTHX)
573{
574 register OP *nextop = (OP *)${$ops[0]->{op}}L;
575EOF
576
577 while (@ops) {
578 $insn = shift @ops;
579
580 $op = $insn->{op};
581 $op_name = $op->name;
582
583 my $class = B::class $op;
584
585 $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
586 $source .= "op_$$op: /* $op_name */\n";
587 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
588 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
589
590 $source .= " PERL_ASYNC_CHECK ();\n"
591 unless exists $f_noasync{$op_name};
592
593 if (my $can = __PACKAGE__->can ("op_$op_name")) {
594 # handcrafted replacement
595
596 if ($insn->{extend} > 0) {
597 # coalesce EXTENDs
598 # TODO: properly take negative preceeding and following EXTENDs into account
599 for my $i (@ops) {
600 last if exists $i->{bblock};
601 last unless exists $i->{extend};
602 my $extend = delete $i->{extend};
603 $insn->{extend} += $extend if $extend > 0;
604 }
605
606 $source .= " { dSP; EXTEND (SP, $insn->{extend}); PUTBACK; }\n"
607 if $insn->{extend} > 0;
608 }
609
610 $can->($op);
611
612 } elsif (exists $f_unsafe{$op_name}) {
613 # unsafe, return to interpreter
614 assert "nextop == (OP *)$$op";
615 $source .= " return nextop;\n";
616
617 } elsif ("LOGOP" eq $class) {
618 # logical operation with optional branch
619 out_callop;
620 out_cond_jump $op->other;
621 out_jump_next;
622
623 } elsif ("PMOP" eq $class) {
624 # regex-thingy
625 out_callop;
626 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
627 out_jump_next;
628
629 } else {
630 # normal operator, linear execution
631 out_linear;
632 }
633 }
634
635 $op_name = "func exit"; assert (0);
636
637 $source .= <<EOF;
638op_0:
639 return 0;
640}
641EOF
642 #warn $source;
643
644 $source
645}
646
647my $uid = "aaaaaaa0";
648my %so;
649
650sub func2ptr {
651 my (@func) = @_;
652
653 #LOCK
654 mkdir $CACHEDIR, 0777;
655 sysopen my $meta_fh, "$CACHEDIR/meta", &Fcntl::O_RDWR | &Fcntl::O_CREAT, 0666
656 or die "$$CACHEDIR/meta: $!";
657 binmode $meta_fh, ":raw:perlio";
658 fcntl_lock fileno $meta_fh
659 or die "$CACHEDIR/meta: $!";
660
661 my $meta = eval { Storable::fd_retrieve $meta_fh } || { version => 1 };
662
663 for my $f (@func) {
664 $f->{func} = "F" . Digest::MD5::md5_hex ($f->{source});
665 $f->{so} = $meta->{$f->{func}};
666 }
667
668 if (grep !$_->{so}, @func) {
669 my $stem;
670
671 do {
672 $stem = "$CACHEDIR/$$-" . $uid++;
673 } while -e "$stem$_so";
674
675 open my $fh, ">:raw", "$stem.c";
676 print $fh <<EOF;
285#define PERL_NO_GET_CONTEXT 677#define PERL_NO_GET_CONTEXT
678#define PERL_CORE
286 679
287#include <assert.h> 680#include <assert.h>
288 681
289#include "EXTERN.h" 682#include "EXTERN.h"
290#include "perl.h" 683#include "perl.h"
291#include "XSUB.h" 684#include "XSUB.h"
292 685
293/*typedef OP *(*PPFUNC)(pTHX);*/ 686#define RUNOPS_TILL(op) \\
294 687 while (nextop != (op)) \\
295OP *%%%FUNC%%% (pTHX) 688 { \\
296{
297 register OP *nextop = (OP *)${$ops[0]}L;
298EOF
299
300 for my $op (@ops) {
301 my $name = $op->name;
302 my $ppaddr = ppaddr $op->type;
303
304 $source .= "op_$$op: /* $name */\n";
305 #$source .= "fprintf (stderr, \"$$op in op $name\\n\");\n";#d#
306 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
307
308 unless (exists $flag{noasync}{$name}) {
309 $source .= " PERL_ASYNC_CHECK ();\n";
310 }
311
312 if (my $can = __PACKAGE__->can ("op_$name")) {
313 $can->($op);
314 } elsif (exists $flag{unsafe}{$name}) {
315 $source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
316 $source .= " PL_op = nextop; return " . (callop $op) . ";\n";
317 } elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) {
318 $source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
319 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
320 $source .= " if (nextop == (OP *)${$op->other}L) goto op_${$op->other};\n";
321 $source .= " assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#
322 $source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";
323 } else {
324 $source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
325 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
326 if ($name eq "entersub") {
327 $source .= <<EOF;
328while (nextop != (OP *)${$op->next})
329 {
330 PERL_ASYNC_CHECK (); 689 PERL_ASYNC_CHECK (); \\
331 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); 690 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
332 }
333EOF
334 }
335 $source .= " assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#
336 $source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";
337 }
338 } 691 }
339 692
340 $source .= "}\n"; 693EOF
341 #warn $source; 694 for my $f (grep !$_->{so}, @func) {
695 next if $f->{so} = $meta->{$f->{func}}; # some cv's alias others
342 696
343 $source 697 warn "compiling $f->{name} to $stem$_so:$f->{func}\n" if $verbose > 1;
344} 698 my $source = $f->{source};
345 699 $source =~ s/%%%FUNC%%%/$f->{func}/g;
346sub source2ptr {
347 my ($source) = @_;
348
349 my $md5 = Digest::MD5::md5_hex $source;
350 $source =~ s/%%%FUNC%%%/Faster_$md5/;
351
352 my $stem = "/tmp/$md5";
353
354 unless (-e "$stem$_so") {
355 open FILE, ">:raw", "$stem.c";
356 print FILE $source; 700 print $fh $source;
701 $meta->{$f->{func}} = $f->{so} = $stem;
702 }
703
357 close FILE; 704 close $fh;
358 system "$COMPILE -o $stem$_o $stem.c"; 705 system "$COMPILE -o $stem$_o $stem.c";
706 unlink "$stem.c";
359 system "$LINK -o $stem$_so $stem$_o $LIBS"; 707 system "$LINK -o $stem$_so $stem$_o $LIBS";
708 unlink "$stem$_o";
360 } 709 }
361 710
362# warn $source; 711 for my $f (@func) {
712 my $stem = $f->{so};
713
363 my $so = DynaLoader::dl_load_file "$stem$_so" 714 my $so = ($so{$stem} ||= DynaLoader::dl_load_file "$stem$_so")
364 or die "$stem$_so: $!"; 715 or die "$stem$_so: $!";
365 716
366 DynaLoader::dl_find_symbol $so, "Faster_$md5" 717 #unlink "$stem$_so";
367 or die "Faster_$md5: $!" 718
719 $f->{ptr} = DynaLoader::dl_find_symbol $so, $f->{func}
720 or die "$f->{func} not found in $stem$_so: $!";
721 }
722
723 seek $meta_fh, 0, 0 or die "$CACHEDIR/meta: $!";
724 Storable::nstore_fd $meta, $meta_fh;
725 truncate $meta_fh, tell $meta_fh;
726
727 # UNLOCK (by closing $meta_fh)
368} 728}
729
730my %ignore;
369 731
370sub entersub { 732sub entersub {
371 my ($cv) = @_; 733 my ($cv) = @_;
372 734
735 my $pkg = $cv->STASH->NAME;
736
737 return if $ignore{$pkg};
738
739 warn "optimising ", $cv->STASH->NAME, "\n"
740 if $verbose;
741
373 eval { 742 eval {
743 my @func;
744
745 push @func, {
746 cv => $cv,
747 name => "<>",
374 my $source = cv2c $cv; 748 source => cv2c $cv,
749 };
375 750
376 my $ptr = source2ptr $source; 751 # always compile the whole stash
752 my %stash = $cv->STASH->ARRAY;
753 while (my ($k, $v) = each %stash) {
754 $v->isa (B::GV::)
755 or next;
377 756
757 my $cv = $v->CV;
758
759 if ($cv->isa (B::CV::)
760 && ${$cv->START}
761 && $cv->START->name ne "null") {
762
763 push @func, {
764 cv => $cv,
765 name => $k,
766 source => cv2c $cv,
767 };
768 }
769 }
770
771 func2ptr @func;
772
773 for my $f (@func) {
378 patch_cv $cv, $ptr; 774 patch_cv $f->{cv}, $f->{ptr};
775 }
379 }; 776 };
380 777
381 warn $@ if $@; 778 if ($@) {
779 $ignore{$pkg}++;
780 warn $@;
781 }
382} 782}
383 783
384hook_entersub; 784hook_entersub;
385 785
3861; 7861;
387 787
388=back 788=back
389 789
790=head1 ENVIRONMENT VARIABLES
791
792The following environment variables influence the behaviour of Faster:
793
794=over 4
795
796=item FASTER_VERBOSE
797
798Faster will output more informational messages when set to values higher
799than C<0>. Currently, C<1> outputs which packages are being compiled, C<3>
800outputs the cache directory and C<10> outputs information on which perl
801function is compiled into which shared object.
802
803=item FASTER_DEBUG
804
805Add debugging code when set to values higher than C<0>. Currently, this
806adds 1-3 C<assert>'s per perl op, to ensure that opcode order and C
807execution order are compatible.
808
809=item FASTER_CACHE
810
811Set a persistent cache directory that caches compiled code fragments. The
812default is C<$HOME/.perl-faster-cache> if C<HOME> is set and a temporary
813directory otherwise.
814
815This directory will always grow in size, so you might need to erase it
816from time to time.
817
818=back
819
390=head1 LIMITATIONS 820=head1 BUGS/LIMITATIONS
391 821
392Tainting and debugging will disable Faster. 822Perl will check much less often for asynchronous signals in
823Faster-compiled code. It tries to check on every function call, loop
824iteration and every I/O operator, though.
825
826The following things will disable Faster. If you manage to enable them at
827runtime, bad things will happen. Enabling them at startup will be fine,
828though.
829
830 enabled tainting
831 enabled debugging
832
833Thread-enabled builds of perl will dramatically reduce Faster's
834performance, but you don't care about speed if you enable threads anyway.
835
836These constructs will force the use of the interpreter for the currently
837executed function as soon as they are being encountered during execution.
838
839 goto
840 next, redo (but not well-behaved last's)
841 eval
842 require
843 any use of formats
844 .., ... (flipflop operators)
393 845
394=head1 AUTHOR 846=head1 AUTHOR
395 847
396 Marc Lehmann <schmorp@schmorp.de> 848 Marc Lehmann <schmorp@schmorp.de>
397 http://home.schmorp.de/ 849 http://home.schmorp.de/

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines