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

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

Diff Legend

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