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

Comparing Faster/Faster.pm (file contents):
Revision 1.3 by root, Thu Mar 9 06:35:33 2006 UTC vs.
Revision 1.4 by root, Thu Mar 9 22:32:17 2006 UTC

… …
13=cut 13=cut
14 14
15package Faster; 15package Faster;
16 16
17use strict; 17use strict;
18use Config;
19use B ();
20use Digest::MD5 ();
21use DynaLoader ();
18 22
19BEGIN { 23BEGIN {
20 our $VERSION = '0.01'; 24 our $VERSION = '0.01';
21 25
22 require XSLoader; 26 require XSLoader;
23 XSLoader::load __PACKAGE__, $VERSION; 27 XSLoader::load __PACKAGE__, $VERSION;
24} 28}
25 29
26use B (); 30my $COMPILE = "$Config{cc} -c -I$Config{archlibexp}/CORE $Config{optimize} $Config{ccflags} $Config{cccdlflags}";
31my $LINK = "$Config{ld} $Config{ldflags} $Config{lddlflags} $Config{ccdlflags}";
32my $LIBS = "$Config{libs}";
33my $_o = $Config{_o};
34my $_so = ".so";
27 35
28our $source; 36our $source;
29our $label_next; 37our $label_next;
30our $label_last; 38our $label_last;
31our $label_redo; 39our $label_redo;
… …
45 leaveeval unsafe 53 leaveeval unsafe
46 entertry unsafe 54 entertry unsafe
47 substconst unsafe 55 substconst unsafe
48 formline unsafe 56 formline unsafe
49 grepstart unsafe 57 grepstart unsafe
58 require unsafe
59
60 pushmark noasync
61 padsv noasync
62 entersub noasync
63 aassign noasync
64 sassign noasync
65 rv2av noasync
66 nextstate noasync
67 gv noasync
68 gvsv noasync
69 add noasync
70 subtract noasync
71 multiply noasync
72 divide noasync
73 complement noasync
74 cond_expr noasync
75 and noasync
76 or noasync
77 not noasync
78 method_named noasync
79 preinc noasync
80 postinc noasync
81 predec noasync
82 postdec noasync
83 stub noasync
84 unstack noasync
85 leaveloop noasync
86 shift noasync
87 aelemA noasync
88 aelemfast noasync
50EOF 89EOF
51 my (undef, $op, @flags) = split /\s+/; 90 my (undef, $op, @flags) = split /\s+/;
52 91
53 undef $flag{$_}{$op} 92 undef $flag{$_}{$op}
54 for ("known", @flags); 93 for ("known", @flags);
55} 94}
56 95
57sub out_next { 96sub out_next {
58 my ($op) = @_; 97 my ($op) = @_;
59 98
60 $source .= " PL_op = (OP *)${$op->next}L;\n"; 99 $source .= " nextop = (OP *)${$op->next}L;\n";
61 $source .= " goto op_${$op->next};\n"; 100 $source .= " goto op_${$op->next};\n";
62} 101}
63 102
103sub callop {
104 my ($op) = @_;
105
106 my $name = $op->name;
107
108 $name eq "entersub"
109 ? "(PL_ppaddr [OP_ENTERSUB]) (aTHX)"
110 : "Perl_pp_$name (aTHX)"
111}
112
64sub op_nextstate { 113sub op_nextstate {
65 my ($op) = @_; 114 my ($op) = @_;
66 115
67 $source .= " PL_curcop = (COP *)PL_op;\n"; 116 $source .= " PL_curcop = (COP *)nextop;\n";
68 $source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n"; 117 $source .= " PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;\n";
69 $source .= " FREETMPS;\n"; 118 $source .= " FREETMPS;\n";
70 119
71 out_next $op; 120 out_next $op;
72} 121}
… …
91 140
92sub op_stringify { 141sub op_stringify {
93 my ($op) = @_; 142 my ($op) = @_;
94 143
95 $source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n"; 144 $source .= " { dSP; dTARGET; sv_copypv (TARG, TOPs); SETTARG; }\n";
145
146 out_next $op;
147}
148
149sub op_and {
150 my ($op) = @_;
151
152 $source .= <<EOF;
153 {
154 dSP;
155 if (SvTRUE (TOPs))
156 {
157 --SP;
158 PUTBACK;
159 nextop = (OP *)${$op->other}L;
160 goto op_${$op->other};
161 }
162
163 nextop = (OP *)${$op->next}L;
164 goto op_${$op->next};
165 }
166EOF
167}
168
169sub op_padsv {
170 my ($op) = @_;
171
172 my $flags = $op->flags;
173 my $target = $op->targ;
174
175 $source .= <<EOF;
176 {
177 dSP;
178 XPUSHs (PAD_SV ((PADOFFSET)$target));
179 PUTBACK;
180EOF
181 if ($op->flags & B::OPf_MOD) {
182 if ($op->private & B::OPpLVAL_INTRO) {
183 $source .= " SAVECLEARSV (PAD_SVl ((PADOFFSET)$target));\n";
184 } elsif ($op->private & B::OPpDEREF) {
185 my $deref = $op->private & B::OPpDEREF;
186 $source .= " Perl_vivify_ref (PAD_SVl ((PADOFFSET)$target), $deref);\n";
187 }
188 }
189 $source .= <<EOF;
190 }
191EOF
96 192
97 out_next $op; 193 out_next $op;
98} 194}
99 195
100# pattern const+ (or general push1) 196# pattern const+ (or general push1)
101# pattern pushmark return(?) 197# pattern pushmark return(?)
102# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign 198# pattern pushmark gv rv2av pushmark padsv+o.ä. aassign
103 199
104# pattern const method_named 200# pattern const method_named
105sub xop_method_named { 201sub op_method_named {
106 my ($op) = @_; 202 my ($op) = @_;
107
108 my $ppaddr = ppaddr $op->type;
109 203
110 $source .= <<EOF; 204 $source .= <<EOF;
111 { 205 {
112 dSP; 206 static HV *last_stash;
207 static SV *last_res;
113 208
209 SV *obj = *(PL_stack_base + TOPMARK + 1);
210
114 if (SvROK (TOPm1s) && SvOBJECT (SvRV (TOPm1s))) 211 if (SvROK (obj) && SvOBJECT (SvRV (obj)))
115 { 212 {
116 static SV *last_stash, SV *last_res; 213 dSP;
117 SV *stash = SvSTASH (SvRV (TOPm1s)); 214 HV *stash = SvSTASH (SvRV (obj));
118 215
119 // simple polymorphic inline cache 216 /* simple "polymorphic" inline cache */
120 if (stash == last_stash) 217 if (stash == last_stash)
121 { 218 {
122 dTARGET;
123 SETTARG (last_res); 219 XPUSHs (last_res);
220 PUTBACK;
124 } 221 }
125 else 222 else
126 { 223 {
127 PUTBACK; 224 PL_op = nextop;
128 ((PPFUNC)${ppaddr}L)(aTHX);\n"; 225 nextop = Perl_pp_method_named (aTHX);
226
129 SPAGAIN; 227 SPAGAIN;
130
131 last_stash = stash; 228 last_stash = stash;
132 last_res = TOPs; 229 last_res = TOPs;
133 } 230 }
134 } 231 }
232 else
233 {
234 /* error case usually */
235 PL_op = nextop;
236 nextop = Perl_pp_method_named (aTHX);
237 }
135 } 238 }
136EOF 239EOF
137 240
138 out_next $op; 241 out_next $op;
139} 242}
140 243
141sub entersub { 244sub cv2c {
142 my ($cv) = @_; 245 my ($cv) = @_;
143 246
144 my %opsseen; 247 my %opsseen;
145 my @ops; 248 my @ops;
146 my @todo = $cv->START; 249 my @todo = $cv->START;
… …
166# } 269# }
167 } 270 }
168 } 271 }
169 } 272 }
170 273
171 local $source; 274 local $source = <<EOF;
275#define PERL_NO_GET_CONTEXT
172 276
173 $source = "typedef OP *(*PPFUNC)(pTHX);\n\n"; 277#include <assert.h>
278
279#include "EXTERN.h"
280#include "perl.h"
281#include "XSUB.h"
282
283/*typedef OP *(*PPFUNC)(pTHX);*/
174 284
175 $source .= "OP *func (pTHX)\n{\n dTHX;\n"; 285OP *%%%FUNC%%% (pTHX)
286{
287 register OP *nextop = (OP *)${$ops[0]}L;
288EOF
176 289
177 for my $op (@ops) { 290 for my $op (@ops) {
178 my $name = $op->name; 291 my $name = $op->name;
179 my $ppaddr = ppaddr $op->type; 292 my $ppaddr = ppaddr $op->type;
180 293
181 $source .= "op_$$op: /* $name */\n"; 294 $source .= "op_$$op: /* $name */\n";
295 #$source .= "fprintf (stderr, \"$$op in op $name\\n\");\n";#d#
296 #$source .= "{ dSP; sv_dump (TOPs); }\n";#d#
297
298 unless (exists $flag{noasync}{$name}) {
299 $source .= " PERL_ASYNC_CHECK ();\n";
300 }
182 301
183 if (my $can = __PACKAGE__->can ("op_$name")) { 302 if (my $can = __PACKAGE__->can ("op_$name")) {
184 $can->($op); 303 $can->($op);
185 } elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) { 304 } elsif ("LOGOP" eq B::class $op or exists $flag{otherop}{$name}) {
186 $source .= " PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n"; 305 $source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
306 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
187 $source .= " if (PL_op == (OP *)${$op->other}L) goto op_${$op->other};\n"; 307 $source .= " if (nextop == (OP *)${$op->other}L) goto op_${$op->other};\n";
308 $source .= " assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#
188 $source .= " goto op_${$op->next};\n"; 309 $source .= " goto op_${$op->next};\n";
189 } elsif (exists $flag{unsafe}{$name}) { 310 } elsif (exists $flag{unsafe}{$name}) {
190 $source .= " return ((PPFUNC)${ppaddr}L)(aTHX);\n"; 311 $source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
312 $source .= " PL_op = nextop; return " . (callop $op) . ";\n";
191 } else { 313 } else {
192 $source .= " PL_op = ((PPFUNC)${ppaddr}L)(aTHX);\n"; 314 $source .= " assert ((\"$name\", nextop == (OP *)$$op));\n";#d#
315 $source .= " PL_op = nextop; nextop = " . (callop $op) . ";\n";
316 if ($name eq "entersub") {
317 $source .= <<EOF;
318while (nextop != (OP *)${$op->next})
319 {
320 PERL_ASYNC_CHECK ();
321 PL_op = nextop; nextop = (PL_op->op_ppaddr)(aTHX);
322 }
323EOF
324 }
325 $source .= " assert ((\"$name\", nextop == (OP *)${$op->next}));\n";#d#
193 $source .= " goto op_${$op->next};\n"; 326 $source .= " goto op_${$op->next};\n";
194 } 327 }
195 } 328 }
196 329
197 $source .= "}\n"; 330 $source .= "}\n";
198
199 print <<EOF;
200#include "EXTERN.h"
201#include "perl.h"
202#include "XSUB.h"
203EOF
204 print $source; 331 #warn $source;
332
333 $source
334}
335
336sub source2ptr {
337 my ($source) = @_;
338
339 my $md5 = Digest::MD5::md5_hex $source;
340 $source =~ s/%%%FUNC%%%/Faster_$md5/;
341
342 my $stem = "/tmp/$md5";
343
344 unless (-e "$stem$_so") {
345 open FILE, ">:raw", "$stem.c";
346 print FILE $source;
347 close FILE;
348 system "$COMPILE -o $stem$_o $stem.c";
349 system "$LINK -o $stem$_so $stem$_o $LIBS";
350 }
351
352# warn $source;
353 my $so = DynaLoader::dl_load_file "$stem$_so"
354 or die "$stem$_so: $!";
355
356 DynaLoader::dl_find_symbol $so, "Faster_$md5"
357 or die "Faster_$md5: $!"
358}
359
360sub entersub {
361 my ($cv) = @_;
362
363 eval {
364 my $source = cv2c $cv;
365
366 my $ptr = source2ptr $source;
367
368 patch_cv $cv, $ptr;
369 };
370
371 warn $@ if $@;
205} 372}
206 373
207hook_entersub; 374hook_entersub;
208 375
2091; 3761;

Diff Legend

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