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

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

Diff Legend

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