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

Comparing Faster/Faster.pm (file contents):
Revision 1.10 by root, Fri Mar 10 02:03:50 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 @ops; 71our @ops;
42my $op; 72our $insn;
73our $op;
43my $op_name; 74our $op_name;
75our @op_loop;
76our %op_regcomp;
44 77
45my %flag; 78# ops that cause immediate return to the interpreter
79my %f_unsafe = map +($_ => undef), qw(
80 leavesub leavesublv return
81 goto last redo next
82 eval flip leaveeval entertry
83 formline grepstart mapstart
84 substcont entereval require
85);
46 86
47for (split /\n/, <<EOF) { 87# ops with known stack extend behaviour
48 leavesub unsafe 88# the values given are maximum values
49 leavesublv unsafe 89my %extend = (
50 return unsafe 90 pushmark => 0,
51 flip unsafe 91 nextstate => 0, # might reduce the stack
52 goto unsafe 92 unstack => 0,
53 last unsafe 93 enter => 0,
54 redo unsafe
55 next unsafe
56 eval unsafe
57 leaveeval unsafe
58 entertry unsafe
59 substconst unsafe
60 formline unsafe
61 grepstart unsafe
62 require unsafe
63 match unsafe noasync todo
64 subst unsafe noasync todo
65 entereval unsafe noasync todo
66 mapstart unsafe noasync todo
67 94
68 mapwhile noasync 95 stringify => 0,
69 grepwhile noasync 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);
70 132
71 seq noasync 133# ops that do not need an ASYNC_CHECK
72 pushmark noasync 134my %f_noasync = map +($_ => undef), qw(
73 padsv noasync extend=1 135 mapstart grepstart match entereval
74 padav noasync extend=1 136 enteriter entersub leaveloop
75 padhv noasync extend=1
76 padany noasync extend=1
77 entersub noasync
78 aassign noasync
79 sassign noasync
80 rv2av noasync
81 rv2cv noasync
82 rv2gv noasync
83 rv2hv noasync
84 refgen noasync
85 nextstate noasync
86 gv noasync
87 gvsv noasync
88 add noasync
89 subtract noasync
90 multiply noasync
91 divide noasync
92 complement noasync
93 cond_expr noasync
94 and noasync
95 or noasync
96 not noasync
97 defined noasync
98 method_named noasync
99 preinc noasync
100 postinc noasync
101 predec noasync
102 postdec noasync
103 stub noasync
104 unstack noasync
105 leaveloop noasync
106 aelem noasync
107 aelemfast noasync
108 helem noasync
109 pushre noasync
110 const noasync extend=1
111 list noasync
112 join noasync
113 split noasync
114 concat noasync
115 push noasync
116 pop noasync
117 shift noasync
118 unshift noasync
119 require noasync
120 length noasync
121 substr noasync
122 stringify noasync
123 eq noasync
124 ne noasync
125 gt noasync
126 lt noasync
127 ge noasync
128 le noasync
129 enteriter noasync
130 137
131 iter async 138 pushmark nextstate
132EOF
133 my (undef, $op, @flags) = split /\s+/;
134 139
135 undef $flag{$_}{$op} 140 const stub unstack
136 for ("known", @flags); 141 last next redo seq
137} 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);
138 163
139sub callop { 164sub callop {
140 $op_name eq "entersub" 165 $callop{$op_name} || "Perl_pp_$op_name (aTHX)"
141 ? "(PL_ppaddr [OP_ENTERSUB]) (aTHX)"
142 : $op_name eq "mapstart"
143 ? "Perl_pp_grepstart (aTHX)"
144 : "Perl_pp_$op_name (aTHX)"
145} 166}
146 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
147sub out_gotonext { 182sub out_jump_next {
148 if (${$op->next}) { 183 out_cond_jump $op_regcomp{$$op}
149 $source .= " assert ((\"$op_name\", nextop == (OP *)${$op->next}));\n"; 184 if $op_regcomp{$$op};
185
186 assert "nextop == (OP *)${$op->next}";
150 $source .= " goto op_${$op->next};\n"; 187 $source .= " goto op_${$op->next};\n";
151 } else {
152 $source .= " return 0;\n";
153 }
154} 188}
155 189
156sub out_next { 190sub out_next {
157 $source .= " nextop = (OP *)${$op->next}L;\n"; 191 $source .= " nextop = (OP *)${$op->next}L;\n";
158 192
159 out_gotonext; 193 out_jump_next;
160} 194}
161 195
162sub out_linear { 196sub out_linear {
163 $source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";#d# 197 out_callop;
164 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n"; 198 out_jump_next;
165 if ($op_name eq "entersub") {
166 $source .= <<EOF;
167 while (nextop != (OP *)${$op->next}L)
168 {
169 PERL_ASYNC_CHECK ();
170 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX);
171 }
172EOF
173 }
174
175 out_gotonext;
176} 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;
177 208
178sub op_nextstate { 209sub op_nextstate {
179 $source .= " PL_curcop = (COP *)nextop;\n"; 210 $source .= " PL_curcop = (COP *)nextop;\n";
180 $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";
181 $source .= " FREETMPS;\n"; 212 $source .= " FREETMPS;\n";
… …
191 222
192if ($Config{useithreads} ne "define") { 223if ($Config{useithreads} ne "define") {
193 # disable optimisations on ithreads 224 # disable optimisations on ithreads
194 225
195 *op_const = sub { 226 *op_const = sub {
196 $source .= " { dSP; XPUSHs ((SV *)${$op->sv}L); PUTBACK; }\n"; 227 $source .= " { dSP; PUSHs ((SV *)${$op->sv}L); PUTBACK; }\n";
228
229 $ops[0]{follows_const}++ if @ops;#d#
197 230
198 out_next; 231 out_next;
199 }; 232 };
200 233
201 *op_gv = \&op_const; 234 *op_gv = \&op_const;
… …
221 if (!($op->flags & B::OPf_MOD)) { 254 if (!($op->flags & B::OPf_MOD)) {
222 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n"; 255 $source .= " if (SvGMAGICAL (sv)) sv = sv_mortalcopy (sv);\n";
223 } 256 }
224 257
225 $source .= " dSP;\n"; 258 $source .= " dSP;\n";
226 $source .= " XPUSHs (sv);\n"; 259 $source .= " PUSHs (sv);\n";
227 $source .= " PUTBACK;\n"; 260 $source .= " PUTBACK;\n";
228 $source .= " }\n"; 261 $source .= " }\n";
229 262
230 out_next; 263 out_next;
231 }; 264 };
232 265
233 *op_gvsv = sub { 266 *op_gvsv = sub {
234 $source .= " {\n"; 267 $source .= " {\n";
235 $source .= " dSP;\n"; 268 $source .= " dSP;\n";
236 $source .= " EXTEND (SP, 1);\n";
237 269
238 if ($op->private & B::OPpLVAL_INTRO) { 270 if ($op->private & B::OPpLVAL_INTRO) {
239 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n"; 271 $source .= " PUSHs (save_scalar ((GV *)${$op->sv}L));\n";
240 } else { 272 } else {
241 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n"; 273 $source .= " PUSHs (GvSV ((GV *)${$op->sv}L));\n";
… …
246 278
247 out_next; 279 out_next;
248 }; 280 };
249} 281}
250 282
283# does kill Crossfire/res2pm
251sub op_stringify { 284sub op_stringify {
252 $source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n"; 285 my $targ = $op->targ;
286
287 $source .= <<EOF;
288 {
289 dSP;
290 SV *targ = PAD_SV ((PADOFFSET)$targ);
291 sv_copypv (TARG, TOPs);
292 SETTARG;
293 PUTBACK;
294 }
295EOF
253 296
254 out_next; 297 out_next;
255} 298}
256 299
257sub op_and { 300sub op_and {
… …
290 out_next; 333 out_next;
291} 334}
292 335
293sub op_padsv { 336sub op_padsv {
294 my $flags = $op->flags; 337 my $flags = $op->flags;
295 my $target = $op->targ; 338 my $padofs = "(PADOFFSET)" . $op->targ;
296 339
297 $source .= <<EOF; 340 $source .= <<EOF;
298 { 341 {
299 dSP; 342 dSP;
300 XPUSHs (PAD_SV ((PADOFFSET)$target)); 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);
301 PUTBACK; 353 PUTBACK;
302EOF 354EOF
303 if ($op->flags & B::OPf_MOD) { 355
304 if ($op->private & B::OPpLVAL_INTRO) { 356 if (($flags & B::OPf_MOD) && ($op->private & B::OPpDEREF)) {
305 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n"; 357 $source .= " vivify_ref (sv, " . $op->private . " & OPpDEREF);\n";
306 } elsif ($op->private & B::OPpDEREF) {
307 my $deref = $op->private & B::OPpDEREF;
308 $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
309 }
310 } 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
311 $source .= <<EOF; 380 $source .= <<EOF;
381 SETs (right);
382 PUTBACK;
312 } 383 }
313EOF 384EOF
314 385
315 out_next; 386 out_next;
316} 387}
317 388
318# pattern const+ (or general push1) 389# pattern const+ (or general push1)
319# pattern pushmark return(?)
320# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 390# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
321 391
322# pattern const method_named
323sub op_method_named { 392sub op_method_named {
393 if ($insn->{follows_const}) {
324 $source .= <<EOF; 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;
325 { 418 {
326 static HV *last_stash; 419 static HV *last_stash;
327 static SV *last_res; 420 static SV *last_cv;
421 static U32 last_sub_generation;
328 422
329 SV *obj = *(PL_stack_base + TOPMARK + 1); 423 SV *obj = *(PL_stack_base + TOPMARK + 1);
330 424
331 printf ("todo: PL_subgeneration or somesuch\\n");
332 if (SvROK (obj) && SvOBJECT (SvRV (obj))) 425 if (!SvGMAGICAL (obj) && SvROK (obj) && SvOBJECT (SvRV (obj)))
333 { 426 {
334 dSP; 427 dSP;
335 HV *stash = SvSTASH (SvRV (obj)); 428 HV *stash = SvSTASH (SvRV (obj));
336 429
337 /* simple "polymorphic" inline cache */ 430 /* simple "polymorphic" inline cache */
338 if (stash == last_stash) 431 if (stash == last_stash
432 && PL_sub_generation == last_sub_generation)
339 { 433 {
340 XPUSHs (last_res); 434 PUSHs (last_cv);
341 PUTBACK; 435 PUTBACK;
342 } 436 }
343 else 437 else
344 { 438 {
345 PL_op = nextop;
346 nextop = Perl_pp_method_named (aTHX); 439 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
347 440
348 SPAGAIN; 441 SPAGAIN;
442 last_sub_generation = PL_sub_generation;
349 last_stash = stash; 443 last_stash = stash;
350 last_res = TOPs; 444 last_cv = TOPs;
351 } 445 }
352 } 446 }
353 else 447 else
354 { 448 {
355 /* error case usually */ 449 /* error case usually */
356 PL_op = nextop;
357 nextop = Perl_pp_method_named (aTHX); 450 PL_op = nextop; nextop = Perl_pp_method_named (aTHX);
358 } 451 }
359 } 452 }
360EOF 453EOF
454 }
361 455
362 out_next; 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;
363} 496}
364 497
365sub cv2c { 498sub cv2c {
366 my ($cv) = @_; 499 my ($cv) = @_;
367 500
501 local @ops;
502 local @op_loop;
503 local %op_regcomp;
504
368 my %opsseen; 505 my %opsseen;
369 my @todo = $cv->START; 506 my @todo = $cv->START;
507 my %op_target;
370 508
371 while (my $op = shift @todo) { 509 while (my $op = shift @todo) {
372 for (; $$op; $op = $op->next) { 510 for (; $$op; $op = $op->next) {
373 last if $opsseen{$$op}++; 511 last if $opsseen{$$op}++;
374 push @ops, $op; 512
375 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
376 if (B::class($op) eq "LOGOP") { 528 if ($class eq "LOGOP") {
377 push @todo, $op->other; 529 push @todo, $op->other;
378 } elsif ($name eq "subst" and ${ $op->pmreplstart }) { 530 $op_target{${$op->other}}++;
379 push @todo, $op->pmreplstart; 531
380 } elsif ($name =~ /^enter(loop|iter)$/) { 532 # regcomp/o patches ops at runtime, lets expect that
381# if ($] > 5.009) { 533 if ($name eq "regcomp" && $op->other->pmflags & B::PMf_KEEP) {
382# $labels{${$op->nextop}} = "NEXT"; 534 $op_target{${$op->first}}++;
383# $labels{${$op->lastop}} = "LAST"; 535 $op_regcomp{${$op->first}} = $op->next;
384# $labels{${$op->redoop}} = "REDO";
385# } else {
386# $labels{$op->nextop->seq} = "NEXT";
387# $labels{$op->lastop->seq} = "LAST";
388# $labels{$op->redoop->seq} = "REDO";
389# } 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;
390 } 553 }
391 } 554 }
392 } 555 }
393 556
557 $_->{bblock}++ for grep $op_target{${$_->{op}}}, @ops;
558
394 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;
395#define PERL_NO_GET_CONTEXT 644#define PERL_NO_GET_CONTEXT
645#define PERL_CORE
396 646
397//#define NDEBUG 1
398#include <assert.h> 647#include <assert.h>
399 648
400#include "EXTERN.h" 649#include "EXTERN.h"
401#include "perl.h" 650#include "perl.h"
402#include "XSUB.h" 651#include "XSUB.h"
403 652
404OP *%%%FUNC%%% (pTHX) 653#define RUNOPS_TILL(op) \\
405{ 654while (nextop != (op)) \\
406 register OP *nextop = (OP *)${$ops[0]}L; 655 { \\
407EOF 656 PERL_ASYNC_CHECK (); \\
657 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX); \\
658 }
408 659
409 while (@ops) { 660EOF
410 $op = shift @ops; 661 for (@source) {
411 $op_name = $op->name; 662 my $func = $uid++;
412 663 $_ =~ s/%%%FUNC%%%/$func/g;
413 $source .= "op_$$op: /* $op_name */\n"; 664 print FILE $_;
414 #$source .= "fprintf (stderr, \"$$op in op $op_name\\n\");\n";#d# 665 $_ = $func;
415 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
416
417 unless (exists $flag{noasync}{$op_name}) {
418 $source .= " PERL_ASYNC_CHECK ();\n";
419 }
420
421 if (my $can = __PACKAGE__->can ("op_$op_name")) {
422 $can->($op);
423 } elsif (exists $flag{unsafe}{$op_name}) {
424 $source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";
425 $source .= " return nextop;\n";
426 } elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$op_name}) {
427 $source .= " assert ((\"$op_name\", nextop == (OP *)$$op));\n";
428 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
429 $source .= " if (nextop == (OP *)${$op->other}L) goto op_${$op->other};\n";
430 $source .= " assert ((\"$op_name\", nextop == (OP *)${$op->next}));\n";
431 $source .= ${$op->next} ? " goto op_${$op->next};\n" : " return 0;\n";
432 } else {
433 out_linear;
434 }
435 } 666 }
436 667
437 $source .= "}\n";
438 #warn $source;
439
440 $source
441}
442
443sub source2ptr {
444 my ($source) = @_;
445
446 my $md5 = Digest::MD5::md5_hex $source;
447 $source =~ s/%%%FUNC%%%/Faster_$md5/;
448
449 my $stem = "/tmp/$md5";
450
451 unless (-e "$stem$_so") {
452 open FILE, ">:raw", "$stem.c";
453 print FILE $source;
454 close FILE; 668 close FILE;
455 system "$COMPILE -o $stem$_o $stem.c"; 669 system "$COMPILE -o $stem$_o $stem.c";
670 #d#unlink "$stem.c";
456 system "$LINK -o $stem$_so $stem$_o $LIBS"; 671 system "$LINK -o $stem$_so $stem$_o $LIBS";
457 } 672 unlink "$stem$_o";
458 673
459# warn $source;
460 my $so = DynaLoader::dl_load_file "$stem$_so" 674 my $so = DynaLoader::dl_load_file "$stem$_so"
461 or die "$stem$_so: $!"; 675 or die "$stem$_so: $!";
462 676
463 DynaLoader::dl_find_symbol $so, "Faster_$md5" 677 #unlink "$stem$_so";
464 or die "Faster_$md5: $!" 678
679 map +(DynaLoader::dl_find_symbol $so, $_), @source
465} 680}
681
682my %ignore;
466 683
467sub entersub { 684sub entersub {
468 my ($cv) = @_; 685 my ($cv) = @_;
469 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
470 eval { 694 eval {
471 my $source = cv2c $cv; 695 my @cv;
696 my @cv_source;
472 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
473 my $ptr = source2ptr $source; 714 my @ptr = source2ptr @cv_source;
474 715
716 for (0 .. $#cv) {
475 patch_cv $cv, $ptr; 717 patch_cv $cv[$_], $ptr[$_];
718 }
476 }; 719 };
477 720
478 warn $@ if $@; 721 if ($@) {
722 $ignore{$pkg}++;
723 warn $@;
724 }
479} 725}
480 726
481hook_entersub; 727hook_entersub;
482 728
4831; 7291;
484 730
485=back 731=back
486 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
487=head1 LIMITATIONS 764=head1 BUGS/LIMITATIONS
488 765
489Tainting 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)
490 789
491=head1 AUTHOR 790=head1 AUTHOR
492 791
493 Marc Lehmann <schmorp@schmorp.de> 792 Marc Lehmann <schmorp@schmorp.de>
494 http://home.schmorp.de/ 793 http://home.schmorp.de/

Diff Legend

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