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

Diff Legend

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