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

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

Diff Legend

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