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

Comparing Faster/Faster.pm (file contents):
Revision 1.10 by root, Fri Mar 10 02:03:50 2006 UTC vs.
Revision 1.35 by root, Sat Feb 21 05:55:52 2009 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)"
142 : $op_name eq "mapstart"
143 ? "Perl_pp_grepstart (aTHX)"
144 : "Perl_pp_$op_name (aTHX)"
145} 187}
146 188
189sub assert {
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
147sub out_gotonext { 208sub out_jump_next {
148 if (${$op->next}) { 209 out_cond_jump $op_regcomp{$$op}
149 $source .= " assert ((\"$op_name\", nextop == (OP *)${$op->next}));\n"; 210 if $op_regcomp{$$op};
211
212 assert "nextop == (OP *)${$op->next}";
150 $source .= " goto op_${$op->next};\n"; 213 $source .= " goto op_${$op->next};\n";
151 } else {
152 $source .= " return 0;\n";
153 }
154} 214}
155 215
156sub out_next { 216sub out_next {
157 $source .= " nextop = (OP *)${$op->next}L;\n"; 217 $source .= " nextop = (OP *)${$op->next}L;\n";
158 218
159 out_gotonext; 219 out_jump_next;
160} 220}
161 221
162sub out_linear { 222sub out_linear {
163 $source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";#d# 223 out_callop;
164 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n"; 224 out_jump_next;
165 if ($op_name eq "entersub") {
166 $source .= <<EOF;
167 while (nextop != (OP *)${$op->next}L)
168 {
169 PERL_ASYNC_CHECK ();
170 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX);
171 }
172EOF
173 }
174
175 out_gotonext;
176} 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;
177 234
178sub op_nextstate { 235sub op_nextstate {
179 $source .= " PL_curcop = (COP *)nextop;\n"; 236 $source .= " PL_curcop = (COP *)nextop;\n";
180 $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";
181 $source .= " FREETMPS;\n"; 238 $source .= " FREETMPS;\n";
182 239
183 out_next; 240 out_next;
184} 241}
185 242
186sub op_pushmark { 243sub op_pushmark {
187 $source .= " PUSHMARK (PL_stack_sp);\n"; 244 $source .= " faster_PUSHMARK (PL_stack_sp);\n";
188 245
189 out_next; 246 out_next;
190} 247}
191 248
192if ($Config{useithreads} ne "define") { 249if ($Config{useithreads} ne "define") {
193 # disable optimisations on ithreads 250 # disable optimisations on ithreads
194 251
195 *op_const = sub { 252 *op_const = sub {
196 $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#
197 256
198 out_next; 257 out_next;
199 }; 258 };
200 259
201 *op_gv = \&op_const; 260 *op_gv = \&op_const;
… …
221 if (!($op->flags & B::OPf_MOD)) { 280 if (!($op->flags & B::OPf_MOD)) {
222 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n"; 281 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
223 } 282 }
224 283
225 $source .= " dSP;\n"; 284 $source .= " dSP;\n";
226 $source .= " XPUSHs (sv);\n"; 285 $source .= " PUSHs (sv);\n";
227 $source .= " PUTBACK;\n"; 286 $source .= " PUTBACK;\n";
228 $source .= " }\n"; 287 $source .= " }\n";
229 288
230 out_next; 289 out_next;
231 }; 290 };
232 291
233 *op_gvsv = sub { 292 *op_gvsv = sub {
234 $source .= " {\n"; 293 $source .= " {\n";
235 $source .= " dSP;\n"; 294 $source .= " dSP;\n";
236 $source .= " EXTEND (SP, 1);\n";
237 295
238 if ($op->private & B::OPpLVAL_INTRO) { 296 if ($op->private & B::OPpLVAL_INTRO) {
239 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n"; 297 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
240 } else { 298 } else {
241 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n"; 299 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
… …
246 304
247 out_next; 305 out_next;
248 }; 306 };
249} 307}
250 308
309# does kill Crossfire/res2pm
251sub op_stringify { 310sub op_stringify {
252 $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
253 322
254 out_next; 323 out_next;
255} 324}
256 325
257sub op_and { 326sub op_and {
… …
290 out_next; 359 out_next;
291} 360}
292 361
293sub op_padsv { 362sub op_padsv {
294 my $flags = $op->flags; 363 my $flags = $op->flags;
295 my $target = $op->targ; 364 my $padofs = "(PADOFFSET)" . $op->targ;
296 365
297 $source .= <<EOF; 366 $source .= <<EOF;
298 { 367 {
299 dSP; 368 dSP;
300 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);
301 PUTBACK; 379 PUTBACK;
302EOF 380EOF
303 if ($op->flags & B::OPf_MOD) { 381
304 if ($op->private & B::OPpLVAL_INTRO) { 382 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
305 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n"; 383 $source .= " if (!SvROK (sv)) vivify_ref (sv, " . $op->private . " & OPpDEREF);\n";
306 } elsif ($op->private & B::OPpDEREF) {
307 my $deref = $op->private & B::OPpDEREF;
308 $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
309 }
310 } 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
311 $source .= <<EOF; 406 $source .= <<EOF;
407 SETs (right);
408 PUTBACK;
312 } 409 }
313EOF 410EOF
314 411
315 out_next; 412 out_next;
316} 413}
317 414
318# pattern const+ (or general push1) 415# pattern const+ (or general push1)
319# pattern pushmark return(?)
320# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 416# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
321 417
322# pattern const method_named
323sub op_method_named { 418sub op_method_named {
419 if ($insn->{follows_const}) {
324 $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;
325 { 444 {
326 static HV *last_stash; 445 static HV *last_stash;
327 static SV *last_res; 446 static SV *last_cv;
447 static U32 last_sub_generation;
328 448
329 SV *obj = *(PL_stack_base + TOPMARK + 1); 449 SV *obj = *(PL_stack_base + TOPMARK + 1);
330 450
331 printf ("todo: PL_subgeneration or somesuch\\n");
332 if (SvROK (obj) && SvOBJECT (SvRV (obj))) 451 if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
333 { 452 {
334 dSP; 453 dSP;
335 HV *stash = SvSTASH (SvRV (obj)); 454 HV *stash = SvSTASH (SvRV (obj));
336 455
337 /* simple "polymorphic" inline cache */ 456 /* simple "polymorphic" inline cache */
338 if (stash == last_stash) 457 if (stash == last_stash
458 && PL_sub_generation == last_sub_generation)
339 { 459 {
340 XPUSHs (last_res); 460 PUSHs (last_cv);
341 PUTBACK; 461 PUTBACK;
342 } 462 }
343 else 463 else
344 { 464 {
345 PL_op = nextop;
346 nextop = Perl_pp_method_named (aTHX); 465 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
347 466
348 SPAGAIN; 467 SPAGAIN;
468 last_sub_generation = PL_sub_generation;
349 last_stash = stash; 469 last_stash = stash;
350 last_res = TOPs; 470 last_cv = TOPs;
351 } 471 }
352 } 472 }
353 else 473 else
354 { 474 {
355 /* error case usually */ 475 /* error case usually */
356 PL_op = nextop;
357 nextop = Perl_pp_method_named (aTHX); 476 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
358 } 477 }
359 } 478 }
360EOF 479EOF
480 }
361 481
362 out_next; 482 out_next;
363} 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 # fuck yourself for writing such hacks
515 $source .= " return nextop;\n";
516 }
517}
518
519sub op_next {
520 out_break_op 0;
521}
522
523sub op_last {
524 out_break_op 1;
525}
526
527# TODO: does not seem to work
528#sub op_redo {
529# out_break_op 2;
530#}
364 531
365sub cv2c { 532sub cv2c {
366 my ($cv) = @_; 533 my ($cv) = @_;
367 534
368 my %opsseen; 535 local @ops;
536 local %op_regcomp;
537
538 my $curloop;
369 my @todo = $cv->START; 539 my @todo = $cv->START;
540 my %op_target;
541 my $numpushmark;
542 my $scope;
370 543
544 my %op_seen;
371 while (my $op = shift @todo) { 545 while (my $op = shift @todo) {
546 my $next;
372 for (; $$op; $op = $op->next) { 547 for (; $$op; $op = $next) {
373 last if $opsseen{$$op}++; 548 last if $op_seen{$$op}++;
374 push @ops, $op; 549
550 $next = $op->next;
551
375 my $name = $op->name; 552 my $name = $op->name;
553 my $class = B::class $op;
554
555 my $insn = { op => $op };
556
557 # end of loop reached?
558 $curloop = $curloop->{loop} if $curloop && $$op == ${$curloop->{loop_targ}[1]};
559
560 # remember enclosing loop
561 $insn->{loop} = $curloop if $curloop;
562
563 push @ops, $insn;
564
565 if (exists $extend{$name}) {
566 my $extend = $extend{$name};
567 $extend = $extend->($op) if ref $extend;
568 $insn->{extend} = $extend if defined $extend;
569 }
570
571 # TODO: mark scopes similar to loops, make them comparable
572 # static cxstack(?)
376 if (B::class($op) eq "LOGOP") { 573 if ($class eq "LOGOP") {
377 push @todo, $op->other; 574 push @todo, $op->other;
378 } elsif ($name eq "subst" and ${ $op->pmreplstart }) { 575 $op_target{${$op->other}}++;
379 push @todo, $op->pmreplstart; 576
380 } elsif ($name =~ /^enter(loop|iter)$/) { 577 # regcomp/o patches ops at runtime, lets expect that
381# if ($] > 5.009) { 578 if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
382# $labels{${$op->nextop}} = "NEXT"; 579 $op_target{${$op->first}}++;
383# $labels{${$op->lastop}} = "LAST"; 580 $op_regcomp{${$op->first}} = $op->next;
384# $labels{${$op->redoop}} = "REDO";
385# } else {
386# $labels{$op->nextop->seq} = "NEXT";
387# $labels{$op->lastop->seq} = "LAST";
388# $labels{$op->redoop->seq} = "REDO";
389# } 581 }
582
583 } elsif ($class eq "PMOP") {
584 if (${$op->pmreplstart}) {
585 unshift @todo, $op->pmreplstart;
586 $op_target{${$op->pmreplstart}}++;
587 }
588
589 } elsif ($class eq "LOOP") {
590 my @targ = ($op->nextop, $op->lastop->next, $op->redoop);
591
592 unshift @todo, $next, $op->redoop, $op->nextop, $op->lastop;
593 $next = $op->redoop;
594
595 $op_target{$$_}++ for @targ;
596
597 $insn->{loop_targ} = \@targ;
598 $curloop = $insn;
599
600 } elsif ($class eq "COP") {
601 if (defined $op->label) {
602 $insn->{bblock}++;
603 $curloop->{contains_label}{$op->label}++ if $curloop; #TODO: should be within loop
604 }
605
606 } else {
607 if ($name eq "pushmark") {
608 $numpushmark++;
609 }
390 } 610 }
391 } 611 }
392 } 612 }
393 613
614 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
615
394 local $source = <<EOF; 616 local $source = <<EOF;
617OP *%%%FUNC%%% (pTHX)
618{
619 register OP *nextop = (OP *)${$ops[0]->{op}}L;
620EOF
621
622 $source .= " faster_PUSHMARK_PREALLOC ($numpushmark);\n"
623 if $numpushmark;
624
625 while (@ops) {
626 $insn = shift @ops;
627
628 $op = $insn->{op};
629 $op_name = $op->name;
630
631 my $class = B::class $op;
632
633 $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
634 $source .= "op_$$op: /* $op_name */\n";
635 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
636 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
637
638 $source .= " PERL_ASYNC_CHECK ();\n"
639 unless exists $f_noasync{$op_name};
640
641 if (my $can = __PACKAGE__->can ("op_$op_name")) {
642 # handcrafted replacement
643
644 if ($insn->{extend} > 0) {
645 # coalesce EXTENDs
646 # TODO: properly take negative preceeding and following EXTENDs into account
647 for my $i (@ops) {
648 last if exists $i->{bblock};
649 last unless exists $i->{extend};
650 my $extend = delete $i->{extend};
651 $insn->{extend} += $extend if $extend > 0;
652 }
653
654 $source .= " { dSP; EXTEND (SP, $insn->{extend}); PUTBACK; }\n"
655 if $insn->{extend} > 0;
656 }
657
658 $can->($op);
659
660 } elsif (exists $f_unsafe{$op_name}) {
661 # unsafe, return to interpreter
662 assert "nextop == (OP *)$$op";
663 $source .= " return nextop;\n";
664
665 } elsif ("LOGOP" eq $class) {
666 # logical operation with optional branch
667 out_callop;
668 out_cond_jump $op->other;
669 out_jump_next;
670
671 } elsif ("PMOP" eq $class) {
672 # regex-thingy
673 out_callop;
674 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
675 out_jump_next;
676
677 } else {
678 # normal operator, linear execution
679 out_linear;
680 }
681 }
682
683 $op_name = "func exit"; assert (0);
684
685 $source .= <<EOF;
686op_0:
687 return 0;
688}
689EOF
690 #warn $source;
691
692 $source
693}
694
695my $uid = "aaaaaaa0";
696my %so;
697
698sub func2ptr {
699 my (@func) = @_;
700
701 #LOCK
702 mkdir $CACHEDIR, 0777;
703 sysopen my $meta_fh, "$CACHEDIR/meta", &Fcntl::O_RDWR | &Fcntl::O_CREAT, 0666
704 or die "$$CACHEDIR/meta: $!";
705 binmode $meta_fh, ":raw:perlio";
706 fcntl_lock fileno $meta_fh
707 or die "$CACHEDIR/meta: $!";
708
709 my $meta = eval { Storable::fd_retrieve $meta_fh } || { version => 1 };
710
711 for my $f (@func) {
712 $f->{func} = "F" . Digest::MD5::md5_hex ($f->{source});
713 $f->{so} = $meta->{$f->{func}};
714 }
715
716 if (grep !$_->{so}, @func) {
717 my $stem;
718
719 do {
720 $stem = "$CACHEDIR/$$-" . $uid++;
721 } while -e "$stem$_so";
722
723 open my $fh, ">:raw", "$stem.c";
724 print $fh <<EOF;
395#define PERL_NO_GET_CONTEXT 725#define PERL_NO_GET_CONTEXT
726#define PERL_CORE
396 727
397//#define NDEBUG 1
398#include <assert.h> 728#include <assert.h>
399 729
400#include "EXTERN.h" 730#include "EXTERN.h"
401#include "perl.h" 731#include "perl.h"
402#include "XSUB.h" 732#include "XSUB.h"
403 733
404OP *%%%FUNC%%% (pTHX) 734#if 1
405{ 735# define faster_PUSHMARK_PREALLOC(count) while (PL_markstack_ptr + (count) >= PL_markstack_max) markstack_grow ()
406 register OP *nextop = (OP *)${$ops[0]}L; 736# define faster_PUSHMARK(p) *++PL_markstack_ptr = (p) - PL_stack_base
407EOF 737#else
738# define faster_PUSHMARK_PREALLOC(count) 1
739# define faster_PUSHMARK(p) PUSHMARK(p)
740#endif
408 741
409 while (@ops) { 742#define RUNOPS_TILL(op) \\
410 $op = shift @ops; 743 while (nextop != (op)) \\
411 $op_name = $op->name; 744 { \\
412 745 PERL_ASYNC_CHECK (); \\
413 $source .= "op_$$op: /* $op_name */\n"; 746 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
414 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
415 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
416
417 unless (exists $flag{noasync}{$op_name}) {
418 $source .= " PERL_ASYNC_CHECK ();\n";
419 }
420
421 if (my $can = __PACKAGE__->can ("op_$op_name")) {
422 $can->($op);
423 } elsif (exists $flag{unsafe}{$op_name}) {
424 $source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";
425 $source .= " return nextop;\n";
426 } elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$op_name}) {
427 $source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";
428 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
429 $source .= " if (nextop == (OP *)${$op->other}L) goto op_${$op->other};\n";
430 $source .= " assert ((\"$op_name\", nextop == (OP *)${$op->next}));\n";
431 $source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";
432 } else {
433 out_linear;
434 }
435 } 747 }
436 748
437 $source .= "}\n"; 749EOF
438 #warn $source; 750 for my $f (grep !$_->{so}, @func) {
751 next if $f->{so} = $meta->{$f->{func}}; # some cv's alias others
439 752
440 $source 753 warn "compiling $f->{name} to $stem$_so:$f->{func}\n" if $verbose > 1;
441} 754 my $source = $f->{source};
442 755 $source =~ s/%%%FUNC%%%/$f->{func}/g;
443sub source2ptr {
444 my ($source) = @_;
445
446 my $md5 = Digest::MD5::md5_hex $source;
447 $source =~ s/%%%FUNC%%%/Faster_$md5/;
448
449 my $stem = "/tmp/$md5";
450
451 unless (-e "$stem$_so") {
452 open FILE, ">:raw", "$stem.c";
453 print FILE $source; 756 print $fh $source;
757 $meta->{$f->{func}} = $f->{so} = $stem;
758 }
759
454 close FILE; 760 close $fh;
455 system "$COMPILE -o $stem$_o $stem.c"; 761 system "$COMPILE -o $stem$_o $stem.c";
762 unlink "$stem.c" unless $ENV{FASTER_DEBUG} & 1;
456 system "$LINK -o $stem$_so $stem$_o $LIBS"; 763 system "$LINK -o $stem$_so $stem$_o $LIBS";
764 unlink "$stem$_o";
457 } 765 }
458 766
459# warn $source; 767 for my $f (@func) {
768 my $stem = $f->{so};
769
460 my $so = DynaLoader::dl_load_file "$stem$_so" 770 my $so = ($so{$stem} ||= DynaLoader::dl_load_file "$stem$_so")
461 or die "$stem$_so: $!"; 771 or die "$stem$_so: $!";
462 772
463 DynaLoader::dl_find_symbol $so, "Faster_$md5" 773 #unlink "$stem$_so";
464 or die "Faster_$md5: $!" 774
775 $f->{ptr} = DynaLoader::dl_find_symbol $so, $f->{func}
776 or die "$f->{func} not found in $stem$_so: $!";
777 }
778
779 seek $meta_fh, 0, 0 or die "$CACHEDIR/meta: $!";
780 Storable::nstore_fd $meta, $meta_fh;
781 truncate $meta_fh, tell $meta_fh;
782
783 # UNLOCK (by closing $meta_fh)
465} 784}
785
786my %ignore;
466 787
467sub entersub { 788sub entersub {
468 my ($cv) = @_; 789 my ($cv) = @_;
469 790
791 my $pkg = $cv->STASH->NAME;
792
793 return if $ignore{$pkg};
794
795 warn "optimising ", $cv->STASH->NAME, "\n"
796 if $verbose;
797
470 eval { 798 eval {
799 my @func;
800
801 push @func, {
802 cv => $cv,
803 name => "<>",
471 my $source = cv2c $cv; 804 source => cv2c $cv,
805 };
472 806
473 my $ptr = source2ptr $source; 807 # always compile the whole stash
808 my %stash = $cv->STASH->ARRAY;
809 while (my ($k, $v) = each %stash) {
810 $v->isa (B::GV::)
811 or next;
474 812
813 my $cv = $v->CV;
814
815 if ($cv->isa (B::CV::)
816 && ${$cv->START}
817 && $cv->START->name ne "null") {
818
819 push @func, {
820 cv => $cv,
821 name => $k,
822 source => cv2c $cv,
823 };
824 }
825 }
826
827 func2ptr @func;
828
829 for my $f (@func) {
475 patch_cv $cv, $ptr; 830 patch_cv $f->{cv}, $f->{ptr};
831 }
476 }; 832 };
477 833
478 warn $@ if $@; 834 if ($@) {
835 $ignore{$pkg}++;
836 warn $@;
837 }
479} 838}
480 839
481hook_entersub; 840hook_entersub;
482 841
4831; 8421;
484 843
485=back 844=back
486 845
846=head1 ENVIRONMENT VARIABLES
847
848The following environment variables influence the behaviour of Faster:
849
850=over 4
851
852=item FASTER_VERBOSE
853
854Faster will output more informational messages when set to values higher
855than C<0>. Currently, C<1> outputs which packages are being compiled, C<3>
856outputs the cache directory and C<10> outputs information on which perl
857function is compiled into which shared object.
858
859=item FASTER_DEBUG
860
861Add debugging code when set to values higher than C<0>. Currently, this
862adds 1-3 C<assert>'s per perl op (FASTER_DEBUG > 1), to ensure that opcode
863order and C execution order are compatible.
864
865=item FASTER_CACHE
866
867Set a persistent cache directory that caches compiled code fragments. The
868default is C<$HOME/.perl-faster-cache> if C<HOME> is set and a temporary
869directory otherwise.
870
871This directory will always grow in size, so you might need to erase it
872from time to time.
873
874=back
875
487=head1 LIMITATIONS 876=head1 BUGS/LIMITATIONS
488 877
489Tainting and debugging will disable Faster. 878Perl will check much less often for asynchronous signals in
879Faster-compiled code. It tries to check on every function call, loop
880iteration and every I/O operator, though.
881
882The following things will disable Faster. If you manage to enable them at
883runtime, bad things will happen. Enabling them at startup will be fine,
884though.
885
886 enabled tainting
887 enabled debugging
888
889Thread-enabled builds of perl will dramatically reduce Faster's
890performance, but you don't care about speed if you enable threads anyway.
891
892These constructs will force the use of the interpreter for the currently
893executed function as soon as they are being encountered during execution.
894
895 goto
896 next, redo (but not well-behaved last's)
897 labels, if used
898 eval
899 require
900 any use of formats
901 .., ... (flipflop operators)
490 902
491=head1 AUTHOR 903=head1 AUTHOR
492 904
493 Marc Lehmann <schmorp@schmorp.de> 905 Marc Lehmann <schmorp@schmorp.de>
494 http://home.schmorp.de/ 906 http://home.schmorp.de/

Diff Legend

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