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.24 by root, Sat Mar 11 04:53:00 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 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {#d#
340 return out_linear;#d#
341 }#d#
342
343 $source .= <<EOF;
344 {
345 dSP;
346 SV *sv = PAD_SVl ($padofs);
347EOF
348
349 if (($flags & B::OPf_MOD) && ($op->private & B::OPpLVAL_INTRO)) {
350 $source .= " SAVECLEARSV (PAD_SVl ($padofs));\n";
351 $ops[0]{pre_padsv_lval_intro}++ if @ops;#d#
352 }
353
354 $source .= <<EOF;
355 PUSHs (sv);
179 PUTBACK; 356 PUTBACK;
180EOF 357EOF
181 if ($op->flags & B::OPf_MOD) { 358
182 if ($op->private & B::OPpLVAL_INTRO) { 359 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
183 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n"; 360 $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 } 361 }
362 $source .= " }\n";
363
364 out_next;
365}
366
367sub op_sassign {
368 $source .= <<EOF;
369 {
370 dSP;
371 dPOPTOPssrl;
372EOF
373 $source .= " SV *temp = left; left = right; right = temp;\n"
374 if $op->private & B::OPpASSIGN_BACKWARDS;
375
376 if ($insn->{pre_padsv_lval_intro} && !($op->private & B::OPpASSIGN_BACKWARDS)) {
377 # simple assignment - the target exists, but is basically undef
378 $source .= " SvSetSV (right, left);\n";
379 } else {
380 $source .= " SvSetMagicSV (right, left);\n";
381 }
382
189 $source .= <<EOF; 383 $source .= <<EOF;
384 SETs (right);
385 PUTBACK;
190 } 386 }
191EOF 387EOF
192 388
193 out_next $op; 389 out_next;
194} 390}
195 391
196# pattern const+ (or general push1) 392# pattern const+ (or general push1)
197# pattern pushmark return(?) 393# pattern pushmark return(?)
198# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 394# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
199 395
200# pattern const method_named 396# pattern const method_named
201sub op_method_named { 397sub op_method_named {
202 my ($op) = @_;
203
204 $source .= <<EOF; 398 $source .= <<EOF;
205 { 399 {
206 static HV *last_stash; 400 static HV *last_stash;
207 static SV *last_res; 401 static SV *last_cv;
402 static U32 last_sub_generation;
208 403
209 SV *obj = *(PL_stack_base + TOPMARK + 1); 404 SV *obj = *(PL_stack_base + TOPMARK + 1);
210 405
211 if (SvROK (obj) && SvOBJECT (SvRV (obj))) 406 if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
212 { 407 {
213 dSP; 408 dSP;
214 HV *stash = SvSTASH (SvRV (obj)); 409 HV *stash = SvSTASH (SvRV (obj));
215 410
216 /* simple "polymorphic" inline cache */ 411 /* simple "polymorphic" inline cache */
217 if (stash == last_stash) 412 if (stash == last_stash
413 && PL_sub_generation == last_sub_generation)
218 { 414 {
219 XPUSHs (last_res); 415 PUSHs (last_cv);
220 PUTBACK; 416 PUTBACK;
221 } 417 }
222 else 418 else
223 { 419 {
224 PL_op = nextop;
225 nextop = Perl_pp_method_named (aTHX); 420 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
226 421
227 SPAGAIN; 422 SPAGAIN;
423 last_sub_generation = PL_sub_generation;
228 last_stash = stash; 424 last_stash = stash;
229 last_res = TOPs; 425 last_cv = TOPs;
230 } 426 }
231 } 427 }
232 else 428 else
233 { 429 {
234 /* error case usually */ 430 /* error case usually */
235 PL_op = nextop;
236 nextop = Perl_pp_method_named (aTHX); 431 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
237 } 432 }
238 } 433 }
239EOF 434EOF
240 435
241 out_next $op; 436 out_next;
437}
438
439sub op_grepstart {
440 out_callop;
441 $op = $op->next;
442 out_cond_jump $op->other;
443 out_jump_next;
444}
445
446*op_mapstart = \&op_grepstart;
447
448sub op_substcont {
449 out_callop;
450 out_cond_jump $op->other->pmreplstart;
451 assert "nextop == (OP *)${$op->other->next}L";
452 $source .= " goto op_${$op->other->next};\n";
453}
454
455sub out_break_op {
456 my ($idx) = @_;
457
458 out_callop;
459
460 out_cond_jump $_->[$idx]
461 for reverse @op_loop;
462
463 $source .= " return nextop;\n";
464}
465
466sub xop_next {
467 out_break_op 0;
468}
469
470sub op_last {
471 out_break_op 1;
472}
473
474sub xop_redo {
475 out_break_op 2;
242} 476}
243 477
244sub cv2c { 478sub cv2c {
245 my ($cv) = @_; 479 my ($cv) = @_;
246 480
481 local @ops;
482 local @op_loop;
483 local %op_regcomp;
484
247 my %opsseen; 485 my %opsseen;
248 my @ops;
249 my @todo = $cv->START; 486 my @todo = $cv->START;
487 my %op_target;
250 488
251 while (my $op = shift @todo) { 489 while (my $op = shift @todo) {
252 for (; $$op; $op = $op->next) { 490 for (; $$op; $op = $op->next) {
253 last if $opsseen{$$op}++; 491 last if $opsseen{$$op}++;
254 push @ops, $op; 492
255 my $name = $op->name; 493 my $name = $op->name;
494 my $class = B::class $op;
495
496 my $insn = { op => $op };
497
498 push @ops, $insn;
499
500 if (exists $extend{$name}) {
501 my $extend = $extend{$name};
502 $extend = $extend->($op) if ref $extend;
503 $insn->{extend} = $extend if defined $extend;
504 }
505
506 push @todo, $op->next;
507
256 if (B::class($op) eq "LOGOP") { 508 if ($class eq "LOGOP") {
257 push @todo, $op->other; 509 push @todo, $op->other;
258 } elsif ($name eq "subst" and ${ $op->pmreplstart }) { 510 $op_target{${$op->other}}++;
259 push @todo, $op->pmreplstart; 511
260 } elsif ($name =~ /^enter(loop|iter)$/) { 512 # regcomp/o patches ops at runtime, lets expect that
261# if ($] > 5.009) { 513 if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
262# $labels{${$op->nextop}} = "NEXT"; 514 $op_target{${$op->first}}++;
263# $labels{${$op->lastop}} = "LAST"; 515 $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# } 516 }
517
518 } elsif ($class eq "PMOP") {
519 if (${$op->pmreplstart}) {
520 unshift @todo, $op->pmreplstart;
521 $op_target{${$op->pmreplstart}}++;
522 }
523
524 } elsif ($class eq "LOOP") {
525 my @targ = ($op->nextop, $op->lastop->next, $op->redoop->next);
526
527 push @op_loop, \@targ;
528 push @todo, @targ;
529
530 $op_target{$$_}++ for @targ;
531 } elsif ($class eq "COP") {
532 $insn->{bblock}++ if defined $op->label;
270 } 533 }
271 } 534 }
272 } 535 }
273 536
537 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
538
274 local $source = <<EOF; 539 local $source = <<EOF;
540OP *%%%FUNC%%% (pTHX)
541{
542 register OP *nextop = (OP *)${$ops[0]->{op}}L;
543EOF
544
545 while (@ops) {
546 $insn = shift @ops;
547
548 $op = $insn->{op};
549 $op_name = $op->name;
550
551 my $class = B::class $op;
552
553 $source .= "\n/* start basic block */\n" if exists $insn->{bblock};#d#
554 $source .= "op_$$op: /* $op_name */\n";
555 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d#
556 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
557
558 $source .= " PERL_ASYNC_CHECK ();\n"
559 unless exists $f_noasync{$op_name};
560
561 if (my $can = __PACKAGE__->can ("op_$op_name")) {
562 # handcrafted replacement
563
564 if ($insn->{extend} > 0) {
565 # coalesce EXTENDs
566 # TODO: properly take negative preceeding and following EXTENDs into account
567 for my $i (@ops) {
568 last if exists $i->{bblock};
569 last unless exists $i->{extend};
570 my $extend = delete $i->{extend};
571 $insn->{extend} += $extend if $extend > 0;
572 }
573
574 $source .= " { dSP; EXTEND (SP, $insn->{extend}); PUTBACK; }\n"
575 if $insn->{extend} > 0;
576 }
577
578 $can->($op);
579
580 } elsif (exists $f_unsafe{$op_name}) {
581 # unsafe, return to interpreter
582 assert "nextop == (OP *)$$op";
583 $source .= " return nextop;\n";
584
585 } elsif ("LOGOP" eq $class) {
586 # logical operation with optional branch
587 out_callop;
588 out_cond_jump $op->other;
589 out_jump_next;
590
591 } elsif ("PMOP" eq $class) {
592 # regex-thingy
593 out_callop;
594 out_cond_jump $op->pmreplroot if $op_name ne "pushre" && ${$op->pmreplroot};
595 out_jump_next;
596
597 } else {
598 # normal operator, linear execution
599 out_linear;
600 }
601 }
602
603 $op_name = "func exit"; assert (0);
604
605 $source .= <<EOF;
606op_0:
607 return 0;
608}
609EOF
610 #warn $source;
611
612 $source
613}
614
615my $uid = "aaaaaaa0";
616
617sub source2ptr {
618 my (@source) = @_;
619
620 my $stem = "/tmp/Faster-$$-" . $uid++;
621
622 open FILE, ">:raw", "$stem.c";
623 print FILE <<EOF;
275#define PERL_NO_GET_CONTEXT 624#define PERL_NO_GET_CONTEXT
625#define PERL_CORE
276 626
277#include <assert.h> 627#include <assert.h>
278 628
279#include "EXTERN.h" 629#include "EXTERN.h"
280#include "perl.h" 630#include "perl.h"
281#include "XSUB.h" 631#include "XSUB.h"
282 632
283/*typedef OP *(*PPFUNC)(pTHX);*/ 633#define RUNOPS_TILL(op) \\
284 634while (nextop != (op)) \\
285OP *%%%FUNC%%% (pTHX) 635 { \\
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 (); 636 PERL_ASYNC_CHECK (); \\
321 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); 637 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
322 } 638 }
639
323EOF 640EOF
324 } 641 for (@source) {
325 $source .= " assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d# 642 my $func = $uid++;
326 $source .= " goto op_${$op->next};\n"; 643 $_ =~ s/%%%FUNC%%%/$func/g;
327 } 644 print FILE $_;
645 $_ = $func;
328 } 646 }
329 647
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; 648 close FILE;
348 system "$COMPILE -o $stem$_o $stem.c"; 649 system "$COMPILE -o $stem$_o $stem.c";
650 #d#unlink "$stem.c";
349 system "$LINK -o $stem$_so $stem$_o $LIBS"; 651 system "$LINK -o $stem$_so $stem$_o $LIBS";
350 } 652 unlink "$stem$_o";
351 653
352# warn $source;
353 my $so = DynaLoader::dl_load_file "$stem$_so" 654 my $so = DynaLoader::dl_load_file "$stem$_so"
354 or die "$stem$_so: $!"; 655 or die "$stem$_so: $!";
355 656
356 DynaLoader::dl_find_symbol $so, "Faster_$md5" 657 #unlink "$stem$_so";
357 or die "Faster_$md5: $!" 658
659 map +(DynaLoader::dl_find_symbol $so, $_), @source
358} 660}
661
662my %ignore;
359 663
360sub entersub { 664sub entersub {
361 my ($cv) = @_; 665 my ($cv) = @_;
362 666
667 my $pkg = $cv->STASH->NAME;
668
669 return if $ignore{$pkg};
670
671 warn "compiling ", $cv->STASH->NAME, "\n"
672 if $verbose;
673
363 eval { 674 eval {
364 my $source = cv2c $cv; 675 my @cv;
676 my @cv_source;
365 677
678 # always compile the whole stash
679 my %stash = $cv->STASH->ARRAY;
680 while (my ($k, $v) = each %stash) {
681 $v->isa (B::GV::)
682 or next;
683
684 my $cv = $v->CV;
685
686 if ($cv->isa (B::CV::)
687 && ${$cv->START}
688 && $cv->START->name ne "null") {
689 push @cv, $cv;
690 push @cv_source, cv2c $cv;
691 }
692 }
693
366 my $ptr = source2ptr $source; 694 my @ptr = source2ptr @cv_source;
367 695
696 for (0 .. $#cv) {
368 patch_cv $cv, $ptr; 697 patch_cv $cv[$_], $ptr[$_];
698 }
369 }; 699 };
370 700
371 warn $@ if $@; 701 if ($@) {
702 $ignore{$pkg}++;
703 warn $@;
704 }
372} 705}
373 706
374hook_entersub; 707hook_entersub;
375 708
3761; 7091;
377 710
378=back 711=back
379 712
713=head1 ENVIRONMENT VARIABLES
714
715The following environment variables influence the behaviour of Faster:
716
717=over 4
718
719=item FASTER_VERBOSE
720
721Faster will output more informational messages when set to values higher
722than C<0>. Currently, C<1> outputs which packages are being compiled.
723
724=item FASTER_DEBUG
725
726Add debugging code when set to values higher than C<0>. Currently, this
727adds 1-3 C<assert>'s per perl op, to ensure that opcode order and C
728execution order are compatible.
729
730=item FASTER_CACHE
731
732NOT YET IMPLEMENTED
733
734Set a persistent cache directory that caches compiled code
735fragments. Normally, code compiled by Faster will be deleted immediately,
736and every restart will recompile everything. Setting this variable to a
737directory makes Faster cache the generated files for re-use.
738
739This directory will always grow in contents, so you might need to erase it
740from time to time.
741
742=back
743
380=head1 LIMITATIONS 744=head1 BUGS/LIMITATIONS
381 745
382Tainting and debugging will disable Faster. 746Perl will check much less often for asynchronous signals in
747Faster-compiled code. It tries to check on every function call, loop
748iteration and every I/O operator, though.
749
750The following things will disable Faster. If you manage to enable them at
751runtime, bad things will happen. Enabling them at startup will be fine,
752though.
753
754 enabled tainting
755 enabled debugging
756
757Thread-enabled builds of perl will dramatically reduce Faster's
758performance, but you don't care about speed if you enable threads anyway.
759
760These constructs will force the use of the interpreter for the currently
761executed function as soon as they are being encountered during execution.
762
763 goto
764 next, redo (but not well-behaved last's)
765 eval
766 require
767 any use of formats
768 .., ... (flipflop operators)
383 769
384=head1 AUTHOR 770=head1 AUTHOR
385 771
386 Marc Lehmann <schmorp@schmorp.de> 772 Marc Lehmann <schmorp@schmorp.de>
387 http://home.schmorp.de/ 773 http://home.schmorp.de/

Diff Legend

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