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

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

Diff Legend

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