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

Diff Legend

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