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

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

Diff Legend

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