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.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)" 183}
142 : $op_name eq "mapstart" 184
143 ? "Perl_pp_grepstart (aTHX)" 185sub assert {
144 : "Perl_pp_$op_name (aTHX)" 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
199sub out_jump_next {
200 out_cond_jump $op_regcomp{$$op}
201 if $op_regcomp{$$op};
202
203 assert "nextop == (OP *)${$op->next}";
204 $source .= " goto op_${$op->next};\n";
145} 205}
146 206
147sub out_next { 207sub out_next {
148 if (${$op->next}) {
149 $source .= " nextop = (OP *)${$op->next}L;\n"; 208 $source .= " nextop = (OP *)${$op->next}L;\n";
150 $source .= " assert ((\"$op_name\", nextop == (OP *)${$op->next}));\n"; 209
151 $source .= " goto op_${$op->next};\n"; 210 out_jump_next;
152 } else {
153 $source .= " return 0;\n";
154 }
155} 211}
156 212
157sub out_linear { 213sub out_linear {
158 $source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";#d# 214 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; 215 out_jump_next;
171} 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;
172 225
173sub op_nextstate { 226sub op_nextstate {
174 $source .= " PL_curcop = (COP *)nextop;\n"; 227 $source .= " PL_curcop = (COP *)nextop;\n";
175 $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";
176 $source .= " FREETMPS;\n"; 229 $source .= " FREETMPS;\n";
177 230
178 out_next; 231 out_next;
179} 232}
180 233
181sub op_pushmark { 234sub op_pushmark {
182 $source .= " PUSHMARK (PL_stack_sp);\n"; 235 $source .= " faster_PUSHMARK (PL_stack_sp);\n";
183 236
184 out_next; 237 out_next;
185} 238}
186 239
187if ($Config{useithreads} ne "define") { 240if ($Config{useithreads} ne "define") {
188 # disable optimisations on ithreads 241 # disable optimisations on ithreads
189 242
190 *op_const = sub { 243 *op_const = sub {
191 $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#
192 247
193 out_next; 248 out_next;
194 }; 249 };
195 250
196 *op_gv = \&op_const; 251 *op_gv = \&op_const;
… …
216 if (!($op->flags & B::OPf_MOD)) { 271 if (!($op->flags & B::OPf_MOD)) {
217 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n"; 272 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
218 } 273 }
219 274
220 $source .= " dSP;\n"; 275 $source .= " dSP;\n";
221 $source .= " XPUSHs (sv);\n"; 276 $source .= " PUSHs (sv);\n";
222 $source .= " PUTBACK;\n"; 277 $source .= " PUTBACK;\n";
223 $source .= " }\n"; 278 $source .= " }\n";
224 279
225 out_next; 280 out_next;
226 }; 281 };
227 282
228 *op_gvsv = sub { 283 *op_gvsv = sub {
229 $source .= " {\n"; 284 $source .= " {\n";
230 $source .= " dSP;\n"; 285 $source .= " dSP;\n";
231 $source .= " EXTEND (SP, 1);\n";
232 286
233 if ($op->private & B::OPpLVAL_INTRO) { 287 if ($op->private & B::OPpLVAL_INTRO) {
234 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n"; 288 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
235 } else { 289 } else {
236 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n"; 290 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
… …
241 295
242 out_next; 296 out_next;
243 }; 297 };
244} 298}
245 299
300# does kill Crossfire/res2pm
246sub op_stringify { 301sub op_stringify {
247 $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
248 313
249 out_next; 314 out_next;
250} 315}
251 316
252sub op_and { 317sub op_and {
… …
285 out_next; 350 out_next;
286} 351}
287 352
288sub op_padsv { 353sub op_padsv {
289 my $flags = $op->flags; 354 my $flags = $op->flags;
290 my $target = $op->targ; 355 my $padofs = "(PADOFFSET)" . $op->targ;
291 356
292 $source .= <<EOF; 357 $source .= <<EOF;
293 { 358 {
294 dSP; 359 dSP;
295 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);
296 PUTBACK; 370 PUTBACK;
297EOF 371EOF
298 if ($op->flags & B::OPf_MOD) { 372
299 if ($op->private & B::OPpLVAL_INTRO) { 373 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
300 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n"; 374 $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 } 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
306 $source .= <<EOF; 397 $source .= <<EOF;
398 SETs (right);
399 PUTBACK;
307 } 400 }
308EOF 401EOF
309 402
310 out_next; 403 out_next;
311} 404}
312 405
313# pattern const+ (or general push1) 406# pattern const+ (or general push1)
314# pattern pushmark return(?)
315# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 407# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
316 408
317# pattern const method_named
318sub op_method_named { 409sub op_method_named {
410 if ($insn->{follows_const}) {
319 $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;
320 { 435 {
321 static HV *last_stash; 436 static HV *last_stash;
322 static SV *last_res; 437 static SV *last_cv;
438 static U32 last_sub_generation;
323 439
324 SV *obj = *(PL_stack_base + TOPMARK + 1); 440 SV *obj = *(PL_stack_base + TOPMARK + 1);
325 441
326 if (SvROK (obj) && SvOBJECT (SvRV (obj))) 442 if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
327 { 443 {
328 dSP; 444 dSP;
329 HV *stash = SvSTASH (SvRV (obj)); 445 HV *stash = SvSTASH (SvRV (obj));
330 446
331 /* simple "polymorphic" inline cache */ 447 /* simple "polymorphic" inline cache */
332 if (stash == last_stash) 448 if (stash == last_stash
449 && PL_sub_generation == last_sub_generation)
333 { 450 {
334 XPUSHs (last_res); 451 PUSHs (last_cv);
335 PUTBACK; 452 PUTBACK;
336 } 453 }
337 else 454 else
338 { 455 {
339 PL_op = nextop;
340 nextop = Perl_pp_method_named (aTHX); 456 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
341 457
342 SPAGAIN; 458 SPAGAIN;
459 last_sub_generation = PL_sub_generation;
343 last_stash = stash; 460 last_stash = stash;
344 last_res = TOPs; 461 last_cv = TOPs;
345 } 462 }
346 } 463 }
347 else 464 else
348 { 465 {
349 /* error case usually */ 466 /* error case usually */
350 PL_op = nextop;
351 nextop = Perl_pp_method_named (aTHX); 467 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
352 } 468 }
353 } 469 }
354EOF 470EOF
471 }
355 472
356 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;
357} 513}
358 514
359sub cv2c { 515sub cv2c {
360 my ($cv) = @_; 516 my ($cv) = @_;
361 517
518 local @ops;
519 local @op_loop;
520 local %op_regcomp;
521
362 my %opsseen; 522 my %opsseen;
363 my @todo = $cv->START; 523 my @todo = $cv->START;
524 my %op_target;
525 my $numpushmark;
364 526
365 while (my $op = shift @todo) { 527 while (my $op = shift @todo) {
366 for (; $$op; $op = $op->next) { 528 for (; $$op; $op = $op->next) {
367 last if $opsseen{$$op}++; 529 last if $opsseen{$$op}++;
368 push @ops, $op; 530
369 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
370 if (B::class($op) eq "LOGOP") { 546 if ($class eq "LOGOP") {
371 push @todo, $op->other; 547 push @todo, $op->other;
372 } elsif ($name eq "subst" and ${ $op->pmreplstart }) { 548 $op_target{${$op->other}}++;
373 push @todo, $op->pmreplstart; 549
374 } elsif ($name =~ /^enter(loop|iter)$/) { 550 # regcomp/o patches ops at runtime, lets expect that
375# if ($] > 5.009) { 551 if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
376# $labels{${$op->nextop}} = "NEXT"; 552 $op_target{${$op->first}}++;
377# $labels{${$op->lastop}} = "LAST"; 553 $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# } 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 }
384 } 577 }
385 } 578 }
386 } 579 }
387 580
581 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
582
388 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;
389#define PERL_NO_GET_CONTEXT 692#define PERL_NO_GET_CONTEXT
693#define PERL_CORE
390 694
391//#define NDEBUG 1
392#include <assert.h> 695#include <assert.h>
393 696
394#include "EXTERN.h" 697#include "EXTERN.h"
395#include "perl.h" 698#include "perl.h"
396#include "XSUB.h" 699#include "XSUB.h"
397 700
398OP *%%%FUNC%%% (pTHX) 701#if 1
399{ 702# define faster_PUSHMARK_PREALLOC(count) while (PL_markstack_ptr + (count) >= PL_markstack_max) markstack_grow ()
400 register OP *nextop = (OP *)${$ops[0]}L; 703# define faster_PUSHMARK(p) *++PL_markstack_ptr = (p) - PL_stack_base
401EOF 704#else
705# define faster_PUSHMARK_PREALLOC(count) 1
706# define faster_PUSHMARK(p) PUSHMARK(p)
707#endif
402 708
403 while (@ops) { 709#define RUNOPS_TILL(op) \\
404 $op = shift @ops; 710 while (nextop != (op)) \\
405 $op_name = $op->name; 711 { \\
406 712 PERL_ASYNC_CHECK (); \\
407 $source .= "op_$$op: /* $op_name */\n"; 713 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 } 714 }
430 715
431 $source .= "}\n"; 716EOF
432 #warn $source; 717 for my $f (grep !$_->{so}, @func) {
718 next if $f->{so} = $meta->{$f->{func}}; # some cv's alias others
433 719
434 $source 720 warn "compiling $f->{name} to $stem$_so:$f->{func}\n" if $verbose > 1;
435} 721 my $source = $f->{source};
436 722 $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; 723 print $fh $source;
724 $meta->{$f->{func}} = $f->{so} = $stem;
725 }
726
448 close FILE; 727 close $fh;
449 system "$COMPILE -o $stem$_o $stem.c"; 728 system "$COMPILE -o $stem$_o $stem.c";
729 unlink "$stem.c" unless $ENV{FASTER_DEBUG} > 0;
450 system "$LINK -o $stem$_so $stem$_o $LIBS"; 730 system "$LINK -o $stem$_so $stem$_o $LIBS";
731 unlink "$stem$_o";
451 } 732 }
452 733
453# warn $source; 734 for my $f (@func) {
735 my $stem = $f->{so};
736
454 my $so = DynaLoader::dl_load_file "$stem$_so" 737 my $so = ($so{$stem} ||= DynaLoader::dl_load_file "$stem$_so")
455 or die "$stem$_so: $!"; 738 or die "$stem$_so: $!";
456 739
457 DynaLoader::dl_find_symbol $so, "Faster_$md5" 740 #unlink "$stem$_so";
458 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)
459} 751}
752
753my %ignore;
460 754
461sub entersub { 755sub entersub {
462 my ($cv) = @_; 756 my ($cv) = @_;
463 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
464 eval { 765 eval {
766 my @func;
767
768 push @func, {
769 cv => $cv,
770 name => "<>",
465 my $source = cv2c $cv; 771 source => cv2c $cv,
772 };
466 773
467 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;
468 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) {
469 patch_cv $cv, $ptr; 797 patch_cv $f->{cv}, $f->{ptr};
798 }
470 }; 799 };
471 800
472 warn $@ if $@; 801 if ($@) {
802 $ignore{$pkg}++;
803 warn $@;
804 }
473} 805}
474 806
475hook_entersub; 807hook_entersub;
476 808
4771; 8091;
478 810
479=back 811=back
480 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
481=head1 LIMITATIONS 843=head1 BUGS/LIMITATIONS
482 844
483Tainting 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)
484 868
485=head1 AUTHOR 869=head1 AUTHOR
486 870
487 Marc Lehmann <schmorp@schmorp.de> 871 Marc Lehmann <schmorp@schmorp.de>
488 http://home.schmorp.de/ 872 http://home.schmorp.de/

Diff Legend

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