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

Comparing Faster/Faster.pm (file contents):
Revision 1.7 by root, Fri Mar 10 00:13:15 2006 UTC vs.
Revision 1.25 by root, Sat Mar 11 04:58:53 2006 UTC

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

Diff Legend

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