Commit | Line | Data |
a798dbf2 |
1 | # Bytecode.pm |
2 | # |
3 | # Copyright (c) 1996-1998 Malcolm Beattie |
4 | # |
5 | # You may distribute under the terms of either the GNU General Public |
6 | # License or the Artistic License, as specified in the README file. |
7 | # |
8 | package B::Bytecode; |
059a8bb7 |
9 | |
a798dbf2 |
10 | use strict; |
11 | use Carp; |
059a8bb7 |
12 | use B qw(main_cv main_root main_start comppadlist |
4c1f658f |
13 | class peekop walkoptree svref_2object cstring walksymtable |
059a8bb7 |
14 | init_av begin_av end_av |
15 | SVf_POK SVp_POK SVf_IOK SVp_IOK SVf_NOK SVp_NOK |
16 | SVf_READONLY GVf_IMPORTED_AV GVf_IMPORTED_CV GVf_IMPORTED_HV |
17 | GVf_IMPORTED_SV SVTYPEMASK |
4c1f658f |
18 | ); |
a798dbf2 |
19 | use B::Asmdata qw(@optype @specialsv_name); |
059a8bb7 |
20 | use B::Assembler qw(newasm endasm assemble); |
a798dbf2 |
21 | |
22 | my %optype_enum; |
23 | my $i; |
24 | for ($i = 0; $i < @optype; $i++) { |
25 | $optype_enum{$optype[$i]} = $i; |
26 | } |
27 | |
28 | # Following is SVf_POK|SVp_POK |
29 | # XXX Shouldn't be hardwired |
4c1f658f |
30 | sub POK () { SVf_POK|SVp_POK } |
a798dbf2 |
31 | |
4c1f658f |
32 | # Following is SVf_IOK|SVp_IOK |
a798dbf2 |
33 | # XXX Shouldn't be hardwired |
4c1f658f |
34 | sub IOK () { SVf_IOK|SVp_IOK } |
a798dbf2 |
35 | |
059a8bb7 |
36 | # Following is SVf_NOK|SVp_NOK |
37 | # XXX Shouldn't be hardwired |
38 | sub NOK () { SVf_NOK|SVp_NOK } |
39 | |
40 | # nonexistant flags (see B::GV::bytecode for usage) |
41 | sub GVf_IMPORTED_IO () { 0; } |
42 | sub GVf_IMPORTED_FORM () { 0; } |
43 | |
44 | my ($verbose, $no_assemble, $debug_bc, $debug_cv); |
45 | my @packages; # list of packages to compile |
46 | |
47 | sub asm (@) { # print replacement that knows about assembling |
48 | if ($no_assemble) { |
49 | print @_; |
50 | } else { |
51 | my $buf = join '', @_; |
52 | assemble($_) for (split /\n/, $buf); |
53 | } |
54 | } |
55 | |
56 | sub asmf (@) { # printf replacement that knows about assembling |
57 | if ($no_assemble) { |
58 | printf shift(), @_; |
59 | } else { |
60 | my $format = shift; |
61 | my $buf = sprintf $format, @_; |
62 | assemble($_) for (split /\n/, $buf); |
63 | } |
64 | } |
a798dbf2 |
65 | |
66 | # Optimisation options. On the command line, use hyphens instead of |
67 | # underscores for compatibility with gcc-style options. We use |
68 | # underscores here because they are OK in (strict) barewords. |
059a8bb7 |
69 | my ($compress_nullops, $omit_seq, $bypass_nullops); |
70 | my %optimise = (compress_nullops => \$compress_nullops, |
a798dbf2 |
71 | omit_sequence_numbers => \$omit_seq, |
72 | bypass_nullops => \$bypass_nullops); |
73 | |
059a8bb7 |
74 | my $strip_syntree; # this is left here in case stripping the |
75 | # syntree ever becomes safe again |
76 | # -- BKS, June 2000 |
77 | |
a798dbf2 |
78 | my $nextix = 0; |
79 | my %symtable; # maps object addresses to object indices. |
80 | # Filled in at allocation (newsv/newop) time. |
059a8bb7 |
81 | |
a798dbf2 |
82 | my %saved; # maps object addresses (for SVish classes) to "saved yet?" |
83 | # flag. Set at FOO::bytecode time usually by SV::bytecode. |
84 | # Manipulated via saved(), mark_saved(), unmark_saved(). |
85 | |
059a8bb7 |
86 | my %strtable; # maps shared strings to object indices |
87 | # Filled in at allocation (pvix) time |
88 | |
a798dbf2 |
89 | my $svix = -1; # we keep track of when the sv register contains an element |
90 | # of the object table to avoid unnecessary repeated |
91 | # consecutive ldsv instructions. |
059a8bb7 |
92 | |
a798dbf2 |
93 | my $opix = -1; # Ditto for the op register. |
94 | |
95 | sub ldsv { |
96 | my $ix = shift; |
97 | if ($ix != $svix) { |
059a8bb7 |
98 | asm "ldsv $ix\n"; |
a798dbf2 |
99 | $svix = $ix; |
100 | } |
101 | } |
102 | |
103 | sub stsv { |
104 | my $ix = shift; |
059a8bb7 |
105 | asm "stsv $ix\n"; |
a798dbf2 |
106 | $svix = $ix; |
107 | } |
108 | |
109 | sub set_svix { |
110 | $svix = shift; |
111 | } |
112 | |
113 | sub ldop { |
114 | my $ix = shift; |
115 | if ($ix != $opix) { |
059a8bb7 |
116 | asm "ldop $ix\n"; |
a798dbf2 |
117 | $opix = $ix; |
118 | } |
119 | } |
120 | |
121 | sub stop { |
122 | my $ix = shift; |
059a8bb7 |
123 | asm "stop $ix\n"; |
a798dbf2 |
124 | $opix = $ix; |
125 | } |
126 | |
127 | sub set_opix { |
128 | $opix = shift; |
129 | } |
130 | |
131 | sub pvstring { |
132 | my $str = shift; |
133 | if (defined($str)) { |
134 | return cstring($str . "\0"); |
135 | } else { |
136 | return '""'; |
137 | } |
138 | } |
139 | |
059a8bb7 |
140 | sub nv { |
141 | # print full precision |
142 | my $str = sprintf "%.40f", $_[0]; |
143 | $str =~ s/0+$//; # remove trailing zeros |
144 | $str =~ s/\.$/.0/; |
145 | return $str; |
146 | } |
147 | |
a798dbf2 |
148 | sub saved { $saved{${$_[0]}} } |
149 | sub mark_saved { $saved{${$_[0]}} = 1 } |
150 | sub unmark_saved { $saved{${$_[0]}} = 0 } |
151 | |
152 | sub debug { $debug_bc = shift } |
153 | |
059a8bb7 |
154 | sub pvix { # save a shared PV (mainly for COPs) |
155 | return $strtable{$_[0]} if defined($strtable{$_[0]}); |
156 | asmf "newpv %s\n", pvstring($_[0]); |
157 | my $ix = $nextix++; |
158 | $strtable{$_[0]} = $ix; |
159 | asmf "stpv %d\n", $ix; |
160 | return $ix; |
161 | } |
162 | |
a798dbf2 |
163 | sub B::OBJECT::nyi { |
164 | my $obj = shift; |
165 | warn sprintf("bytecode save method for %s (0x%x) not yet implemented\n", |
166 | class($obj), $$obj); |
167 | } |
168 | |
169 | # |
170 | # objix may stomp on the op register (for op objects) |
171 | # or the sv register (for SV objects) |
172 | # |
173 | sub B::OBJECT::objix { |
174 | my $obj = shift; |
175 | my $ix = $symtable{$$obj}; |
176 | if (defined($ix)) { |
177 | return $ix; |
178 | } else { |
179 | $obj->newix($nextix); |
180 | return $symtable{$$obj} = $nextix++; |
181 | } |
182 | } |
183 | |
184 | sub B::SV::newix { |
185 | my ($sv, $ix) = @_; |
059a8bb7 |
186 | asmf "newsv %d\t# %s\n", $sv->FLAGS & SVTYPEMASK, class($sv); |
a798dbf2 |
187 | stsv($ix); |
188 | } |
189 | |
190 | sub B::GV::newix { |
191 | my ($gv, $ix) = @_; |
192 | my $gvname = $gv->NAME; |
193 | my $name = cstring($gv->STASH->NAME . "::" . $gvname); |
059a8bb7 |
194 | asm "gv_fetchpv $name\n"; |
a798dbf2 |
195 | stsv($ix); |
196 | } |
197 | |
198 | sub B::HV::newix { |
199 | my ($hv, $ix) = @_; |
200 | my $name = $hv->NAME; |
201 | if ($name) { |
202 | # It's a stash |
059a8bb7 |
203 | asmf "gv_stashpv %s\n", cstring($name); |
a798dbf2 |
204 | stsv($ix); |
205 | } else { |
206 | # It's an ordinary HV. Fall back to ordinary newix method |
207 | $hv->B::SV::newix($ix); |
208 | } |
209 | } |
210 | |
211 | sub B::SPECIAL::newix { |
212 | my ($sv, $ix) = @_; |
213 | # Special case. $$sv is not the address of the SV but an |
214 | # index into svspecialsv_list. |
059a8bb7 |
215 | asmf "ldspecsv $$sv\t# %s\n", $specialsv_name[$$sv]; |
a798dbf2 |
216 | stsv($ix); |
217 | } |
218 | |
219 | sub B::OP::newix { |
220 | my ($op, $ix) = @_; |
221 | my $class = class($op); |
222 | my $typenum = $optype_enum{$class}; |
059a8bb7 |
223 | croak("OP::newix: can't understand class $class") unless defined($typenum); |
224 | asm "newop $typenum\t# $class\n"; |
a798dbf2 |
225 | stop($ix); |
226 | } |
227 | |
228 | sub B::OP::walkoptree_debug { |
229 | my $op = shift; |
230 | warn(sprintf("walkoptree: %s\n", peekop($op))); |
231 | } |
232 | |
233 | sub B::OP::bytecode { |
234 | my $op = shift; |
235 | my $next = $op->next; |
236 | my $nextix; |
059a8bb7 |
237 | my $sibix = $op->sibling->objix unless $strip_syntree; |
a798dbf2 |
238 | my $ix = $op->objix; |
239 | my $type = $op->type; |
240 | |
241 | if ($bypass_nullops) { |
242 | $next = $next->next while $$next && $next->type == 0; |
243 | } |
244 | $nextix = $next->objix; |
245 | |
059a8bb7 |
246 | asmf "# %s\n", peekop($op) if $debug_bc; |
a798dbf2 |
247 | ldop($ix); |
059a8bb7 |
248 | asm "op_next $nextix\n"; |
249 | asm "op_sibling $sibix\n" unless $strip_syntree; |
250 | asmf "op_type %s\t# %d\n", "pp_" . $op->name, $type; |
251 | asmf("op_seq %d\n", $op->seq) unless $omit_seq; |
a798dbf2 |
252 | if ($type || !$compress_nullops) { |
059a8bb7 |
253 | asmf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n", |
a798dbf2 |
254 | $op->targ, $op->flags, $op->private; |
255 | } |
256 | } |
257 | |
258 | sub B::UNOP::bytecode { |
259 | my $op = shift; |
059a8bb7 |
260 | my $firstix = $op->first->objix unless $strip_syntree; |
a798dbf2 |
261 | $op->B::OP::bytecode; |
262 | if (($op->type || !$compress_nullops) && !$strip_syntree) { |
059a8bb7 |
263 | asm "op_first $firstix\n"; |
a798dbf2 |
264 | } |
265 | } |
266 | |
267 | sub B::LOGOP::bytecode { |
268 | my $op = shift; |
269 | my $otherix = $op->other->objix; |
270 | $op->B::UNOP::bytecode; |
059a8bb7 |
271 | asm "op_other $otherix\n"; |
a798dbf2 |
272 | } |
273 | |
274 | sub B::SVOP::bytecode { |
275 | my $op = shift; |
276 | my $sv = $op->sv; |
277 | my $svix = $sv->objix; |
278 | $op->B::OP::bytecode; |
059a8bb7 |
279 | asm "op_sv $svix\n"; |
a798dbf2 |
280 | $sv->bytecode; |
281 | } |
282 | |
7934575e |
283 | sub B::PADOP::bytecode { |
a798dbf2 |
284 | my $op = shift; |
7934575e |
285 | my $padix = $op->padix; |
a798dbf2 |
286 | $op->B::OP::bytecode; |
059a8bb7 |
287 | asm "op_padix $padix\n"; |
a798dbf2 |
288 | } |
289 | |
290 | sub B::PVOP::bytecode { |
291 | my $op = shift; |
292 | my $pv = $op->pv; |
293 | $op->B::OP::bytecode; |
294 | # |
295 | # This would be easy except that OP_TRANS uses a PVOP to store an |
296 | # endian-dependent array of 256 shorts instead of a plain string. |
297 | # |
3f872cb9 |
298 | if ($op->name eq "trans") { |
a798dbf2 |
299 | my @shorts = unpack("s256", $pv); # assembler handles endianness |
059a8bb7 |
300 | asm "op_pv_tr ", join(",", @shorts), "\n"; |
a798dbf2 |
301 | } else { |
059a8bb7 |
302 | asmf "newpv %s\nop_pv\n", pvstring($pv); |
a798dbf2 |
303 | } |
304 | } |
305 | |
306 | sub B::BINOP::bytecode { |
307 | my $op = shift; |
059a8bb7 |
308 | my $lastix = $op->last->objix unless $strip_syntree; |
a798dbf2 |
309 | $op->B::UNOP::bytecode; |
310 | if (($op->type || !$compress_nullops) && !$strip_syntree) { |
059a8bb7 |
311 | asm "op_last $lastix\n"; |
a798dbf2 |
312 | } |
313 | } |
314 | |
a798dbf2 |
315 | sub B::LISTOP::bytecode { |
316 | my $op = shift; |
059a8bb7 |
317 | my $children = $op->children unless $strip_syntree; |
a798dbf2 |
318 | $op->B::BINOP::bytecode; |
319 | if (($op->type || !$compress_nullops) && !$strip_syntree) { |
059a8bb7 |
320 | asm "op_children $children\n"; |
a798dbf2 |
321 | } |
322 | } |
323 | |
324 | sub B::LOOP::bytecode { |
325 | my $op = shift; |
326 | my $redoopix = $op->redoop->objix; |
327 | my $nextopix = $op->nextop->objix; |
328 | my $lastopix = $op->lastop->objix; |
329 | $op->B::LISTOP::bytecode; |
059a8bb7 |
330 | asm "op_redoop $redoopix\nop_nextop $nextopix\nop_lastop $lastopix\n"; |
a798dbf2 |
331 | } |
332 | |
333 | sub B::COP::bytecode { |
334 | my $op = shift; |
57843af0 |
335 | my $file = $op->file; |
a798dbf2 |
336 | my $line = $op->line; |
059a8bb7 |
337 | if ($debug_bc) { # do this early to aid debugging |
338 | asmf "# line %s:%d\n", $file, $line; |
339 | } |
340 | my $stashpv = $op->stashpv; |
b295d113 |
341 | my $warnings = $op->warnings; |
342 | my $warningsix = $warnings->objix; |
059a8bb7 |
343 | my $labelix = pvix($op->label); |
344 | my $stashix = pvix($stashpv); |
345 | my $fileix = pvix($file); |
346 | $warnings->bytecode; |
a798dbf2 |
347 | $op->B::OP::bytecode; |
059a8bb7 |
348 | asmf <<"EOT", $labelix, $stashix, $op->cop_seq, $fileix, $op->arybase; |
349 | cop_label %d |
350 | cop_stashpv %d |
a798dbf2 |
351 | cop_seq %d |
059a8bb7 |
352 | cop_file %d |
a798dbf2 |
353 | cop_arybase %d |
354 | cop_line $line |
b295d113 |
355 | cop_warnings $warningsix |
a798dbf2 |
356 | EOT |
a798dbf2 |
357 | } |
358 | |
359 | sub B::PMOP::bytecode { |
360 | my $op = shift; |
361 | my $replroot = $op->pmreplroot; |
362 | my $replrootix = $replroot->objix; |
363 | my $replstartix = $op->pmreplstart->objix; |
3f872cb9 |
364 | my $opname = $op->name; |
a798dbf2 |
365 | # pmnext is corrupt in some PMOPs (see misc.t for example) |
366 | #my $pmnextix = $op->pmnext->objix; |
367 | |
368 | if ($$replroot) { |
369 | # OP_PUSHRE (a mutated version of OP_MATCH for the regexp |
370 | # argument to a split) stores a GV in op_pmreplroot instead |
371 | # of a substitution syntax tree. We don't want to walk that... |
3f872cb9 |
372 | if ($opname eq "pushre") { |
a798dbf2 |
373 | $replroot->bytecode; |
374 | } else { |
375 | walkoptree($replroot, "bytecode"); |
376 | } |
377 | } |
378 | $op->B::LISTOP::bytecode; |
3f872cb9 |
379 | if ($opname eq "pushre") { |
059a8bb7 |
380 | asmf "op_pmreplrootgv $replrootix\n"; |
a798dbf2 |
381 | } else { |
059a8bb7 |
382 | asm "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n"; |
a798dbf2 |
383 | } |
384 | my $re = pvstring($op->precomp); |
385 | # op_pmnext omitted since a perl bug means it's sometime corrupt |
059a8bb7 |
386 | asmf <<"EOT", $op->pmflags, $op->pmpermflags; |
a798dbf2 |
387 | op_pmflags 0x%x |
388 | op_pmpermflags 0x%x |
389 | newpv $re |
390 | pregcomp |
391 | EOT |
392 | } |
393 | |
394 | sub B::SV::bytecode { |
395 | my $sv = shift; |
396 | return if saved($sv); |
397 | my $ix = $sv->objix; |
398 | my $refcnt = $sv->REFCNT; |
399 | my $flags = sprintf("0x%x", $sv->FLAGS); |
400 | ldsv($ix); |
059a8bb7 |
401 | asm "sv_refcnt $refcnt\nsv_flags $flags\n"; |
a798dbf2 |
402 | mark_saved($sv); |
403 | } |
404 | |
405 | sub B::PV::bytecode { |
406 | my $sv = shift; |
407 | return if saved($sv); |
408 | $sv->B::SV::bytecode; |
059a8bb7 |
409 | asmf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK; |
a798dbf2 |
410 | } |
411 | |
412 | sub B::IV::bytecode { |
413 | my $sv = shift; |
414 | return if saved($sv); |
415 | my $iv = $sv->IVX; |
416 | $sv->B::SV::bytecode; |
059a8bb7 |
417 | asmf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32" if $sv->FLAGS & IOK; # could be PVNV |
a798dbf2 |
418 | } |
419 | |
420 | sub B::NV::bytecode { |
421 | my $sv = shift; |
422 | return if saved($sv); |
423 | $sv->B::SV::bytecode; |
059a8bb7 |
424 | asmf "xnv %s\n", nv($sv->NVX); |
a798dbf2 |
425 | } |
426 | |
427 | sub B::RV::bytecode { |
428 | my $sv = shift; |
429 | return if saved($sv); |
430 | my $rv = $sv->RV; |
431 | my $rvix = $rv->objix; |
432 | $rv->bytecode; |
433 | $sv->B::SV::bytecode; |
059a8bb7 |
434 | asm "xrv $rvix\n"; |
a798dbf2 |
435 | } |
436 | |
437 | sub B::PVIV::bytecode { |
438 | my $sv = shift; |
439 | return if saved($sv); |
440 | my $iv = $sv->IVX; |
441 | $sv->B::PV::bytecode; |
059a8bb7 |
442 | asmf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32"; |
a798dbf2 |
443 | } |
444 | |
445 | sub B::PVNV::bytecode { |
9636a016 |
446 | my $sv = shift; |
447 | my $flag = shift || 0; |
a798dbf2 |
448 | # The $flag argument is passed through PVMG::bytecode by BM::bytecode |
449 | # and AV::bytecode and indicates special handling. $flag = 1 is used by |
450 | # BM::bytecode and means that we should ensure we save the whole B-M |
451 | # table. It consists of 257 bytes (256 char array plus a final \0) |
452 | # which follow the ordinary PV+\0 and the 257 bytes are *not* reflected |
453 | # in SvCUR. $flag = 2 is used by AV::bytecode and means that we only |
454 | # call SV::bytecode instead of saving PV and calling NV::bytecode since |
455 | # PV/NV/IV stuff is different for AVs. |
456 | return if saved($sv); |
457 | if ($flag == 2) { |
458 | $sv->B::SV::bytecode; |
459 | } else { |
460 | my $pv = $sv->PV; |
461 | $sv->B::IV::bytecode; |
059a8bb7 |
462 | asmf "xnv %s\n", nv($sv->NVX); |
a798dbf2 |
463 | if ($flag == 1) { |
464 | $pv .= "\0" . $sv->TABLE; |
059a8bb7 |
465 | asmf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257; |
a798dbf2 |
466 | } else { |
059a8bb7 |
467 | asmf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK; |
a798dbf2 |
468 | } |
469 | } |
470 | } |
471 | |
472 | sub B::PVMG::bytecode { |
473 | my ($sv, $flag) = @_; |
474 | # See B::PVNV::bytecode for an explanation of $flag. |
475 | return if saved($sv); |
476 | # XXX We assume SvSTASH is already saved and don't save it later ourselves |
477 | my $stashix = $sv->SvSTASH->objix; |
478 | my @mgchain = $sv->MAGIC; |
479 | my (@mgobjix, $mg); |
480 | # |
481 | # We need to traverse the magic chain and get objix for each OBJ |
482 | # field *before* we do B::PVNV::bytecode since objix overwrites |
483 | # the sv register. However, we need to write the magic-saving |
484 | # bytecode *after* B::PVNV::bytecode since sv isn't initialised |
485 | # to refer to $sv until then. |
486 | # |
487 | @mgobjix = map($_->OBJ->objix, @mgchain); |
488 | $sv->B::PVNV::bytecode($flag); |
059a8bb7 |
489 | asm "xmg_stash $stashix\n"; |
a798dbf2 |
490 | foreach $mg (@mgchain) { |
059a8bb7 |
491 | asmf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n", |
a798dbf2 |
492 | cstring($mg->TYPE), shift(@mgobjix), pvstring($mg->PTR); |
493 | } |
494 | } |
495 | |
496 | sub B::PVLV::bytecode { |
497 | my $sv = shift; |
498 | return if saved($sv); |
499 | $sv->B::PVMG::bytecode; |
059a8bb7 |
500 | asmf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE); |
a798dbf2 |
501 | xlv_targoff %d |
502 | xlv_targlen %d |
503 | xlv_type %s |
504 | EOT |
505 | } |
506 | |
507 | sub B::BM::bytecode { |
508 | my $sv = shift; |
509 | return if saved($sv); |
510 | # See PVNV::bytecode for an explanation of what the argument does |
511 | $sv->B::PVMG::bytecode(1); |
059a8bb7 |
512 | asmf "xbm_useful %d\nxbm_previous %d\nxbm_rare %d\n", |
a798dbf2 |
513 | $sv->USEFUL, $sv->PREVIOUS, $sv->RARE; |
514 | } |
515 | |
059a8bb7 |
516 | sub empty_gv { # is a GV empty except for imported stuff? |
517 | my $gv = shift; |
518 | |
519 | return 0 if ($gv->SV->FLAGS & SVTYPEMASK); # sv not SVt_NULL |
520 | my @subfield_names = qw(AV HV CV FORM IO); |
521 | @subfield_names = grep {; |
522 | no strict 'refs'; |
523 | !($gv->GvFLAGS & ${\"GVf_IMPORTED_$_"}->()) && ${$gv->$_()}; |
524 | } @subfield_names; |
525 | return scalar @subfield_names; |
526 | } |
527 | |
a798dbf2 |
528 | sub B::GV::bytecode { |
529 | my $gv = shift; |
530 | return if saved($gv); |
059a8bb7 |
531 | return unless grep { $_ eq $gv->STASH->NAME; } @packages; |
532 | return if $gv->NAME =~ m/^\(/; # ignore overloads - they'll be rebuilt |
a798dbf2 |
533 | my $ix = $gv->objix; |
534 | mark_saved($gv); |
a798dbf2 |
535 | ldsv($ix); |
059a8bb7 |
536 | asmf <<"EOT", $gv->FLAGS, $gv->GvFLAGS; |
a798dbf2 |
537 | sv_flags 0x%x |
538 | xgv_flags 0x%x |
fc290457 |
539 | EOT |
540 | my $refcnt = $gv->REFCNT; |
059a8bb7 |
541 | asmf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1; |
fc290457 |
542 | return if $gv->is_empty; |
059a8bb7 |
543 | asmf <<"EOT", $gv->LINE, pvix($gv->FILE); |
a798dbf2 |
544 | gp_line %d |
059a8bb7 |
545 | gp_file %d |
a798dbf2 |
546 | EOT |
fc290457 |
547 | my $gvname = $gv->NAME; |
548 | my $name = cstring($gv->STASH->NAME . "::" . $gvname); |
549 | my $egv = $gv->EGV; |
550 | my $egvix = $egv->objix; |
a798dbf2 |
551 | my $gvrefcnt = $gv->GvREFCNT; |
059a8bb7 |
552 | asmf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1; |
a798dbf2 |
553 | if ($gvrefcnt > 1 && $ix != $egvix) { |
059a8bb7 |
554 | asm "gp_share $egvix\n"; |
a798dbf2 |
555 | } else { |
556 | if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) { |
557 | my $i; |
b195d487 |
558 | my @subfield_names = qw(SV AV HV CV FORM IO); |
059a8bb7 |
559 | @subfield_names = grep {; |
560 | no strict 'refs'; |
561 | !($gv->GvFLAGS & ${\"GVf_IMPORTED_$_"}->()); |
562 | } @subfield_names; |
a798dbf2 |
563 | my @subfields = map($gv->$_(), @subfield_names); |
564 | my @ixes = map($_->objix, @subfields); |
565 | # Reset sv register for $gv |
566 | ldsv($ix); |
567 | for ($i = 0; $i < @ixes; $i++) { |
059a8bb7 |
568 | asmf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; |
a798dbf2 |
569 | } |
570 | # Now save all the subfields |
571 | my $sv; |
572 | foreach $sv (@subfields) { |
573 | $sv->bytecode; |
574 | } |
575 | } |
576 | } |
577 | } |
578 | |
579 | sub B::HV::bytecode { |
580 | my $hv = shift; |
581 | return if saved($hv); |
582 | mark_saved($hv); |
583 | my $name = $hv->NAME; |
584 | my $ix = $hv->objix; |
585 | if (!$name) { |
586 | # It's an ordinary HV. Stashes have NAME set and need no further |
587 | # saving beyond the gv_stashpv that $hv->objix already ensures. |
588 | my @contents = $hv->ARRAY; |
589 | my ($i, @ixes); |
590 | for ($i = 1; $i < @contents; $i += 2) { |
591 | push(@ixes, $contents[$i]->objix); |
592 | } |
593 | for ($i = 1; $i < @contents; $i += 2) { |
594 | $contents[$i]->bytecode; |
595 | } |
596 | ldsv($ix); |
597 | for ($i = 0; $i < @contents; $i += 2) { |
059a8bb7 |
598 | asmf("newpv %s\nhv_store %d\n", |
a798dbf2 |
599 | pvstring($contents[$i]), $ixes[$i / 2]); |
600 | } |
059a8bb7 |
601 | asmf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS; |
a798dbf2 |
602 | } |
603 | } |
604 | |
605 | sub B::AV::bytecode { |
606 | my $av = shift; |
607 | return if saved($av); |
608 | my $ix = $av->objix; |
609 | my $fill = $av->FILL; |
610 | my $max = $av->MAX; |
611 | my (@array, @ixes); |
612 | if ($fill > -1) { |
613 | @array = $av->ARRAY; |
614 | @ixes = map($_->objix, @array); |
615 | my $sv; |
616 | foreach $sv (@array) { |
617 | $sv->bytecode; |
618 | } |
619 | } |
620 | # See PVNV::bytecode for the meaning of the flag argument of 2. |
621 | $av->B::PVMG::bytecode(2); |
622 | # Recover sv register and set AvMAX and AvFILL to -1 (since we |
623 | # create an AV with NEWSV and SvUPGRADE rather than doing newAV |
624 | # which is what sets AvMAX and AvFILL. |
625 | ldsv($ix); |
059a8bb7 |
626 | asmf "sv_flags 0x%x\n", $av->FLAGS & ~SVf_READONLY; # SvREADONLY_off($av) in case PADCONST |
627 | asmf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS; |
a798dbf2 |
628 | if ($fill > -1) { |
629 | my $elix; |
630 | foreach $elix (@ixes) { |
059a8bb7 |
631 | asm "av_push $elix\n"; |
a798dbf2 |
632 | } |
633 | } else { |
634 | if ($max > -1) { |
059a8bb7 |
635 | asm "av_extend $max\n"; |
a798dbf2 |
636 | } |
637 | } |
059a8bb7 |
638 | asmf "sv_flags 0x%x\n", $av->FLAGS; # restore flags from above |
a798dbf2 |
639 | } |
640 | |
641 | sub B::CV::bytecode { |
642 | my $cv = shift; |
643 | return if saved($cv); |
059a8bb7 |
644 | return if ${$cv->GV} && ($cv->GV->GvFLAGS & GVf_IMPORTED_CV); |
645 | my $fileix = pvix($cv->FILE); |
a798dbf2 |
646 | my $ix = $cv->objix; |
647 | $cv->B::PVMG::bytecode; |
648 | my $i; |
b195d487 |
649 | my @subfield_names = qw(ROOT START STASH GV PADLIST OUTSIDE); |
a798dbf2 |
650 | my @subfields = map($cv->$_(), @subfield_names); |
651 | my @ixes = map($_->objix, @subfields); |
652 | # Save OP tree from CvROOT (first element of @subfields) |
653 | my $root = shift @subfields; |
654 | if ($$root) { |
655 | walkoptree($root, "bytecode"); |
656 | } |
657 | # Reset sv register for $cv (since above ->objix calls stomped on it) |
658 | ldsv($ix); |
659 | for ($i = 0; $i < @ixes; $i++) { |
059a8bb7 |
660 | asmf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; |
a798dbf2 |
661 | } |
059a8bb7 |
662 | asmf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->CvFLAGS; |
663 | asmf "xcv_file %d\n", $fileix; |
a798dbf2 |
664 | # Now save all the subfields (except for CvROOT which was handled |
665 | # above) and CvSTART (now the initial element of @subfields). |
666 | shift @subfields; # bye-bye CvSTART |
667 | my $sv; |
668 | foreach $sv (@subfields) { |
669 | $sv->bytecode; |
670 | } |
671 | } |
672 | |
673 | sub B::IO::bytecode { |
674 | my $io = shift; |
675 | return if saved($io); |
676 | my $ix = $io->objix; |
677 | my $top_gv = $io->TOP_GV; |
678 | my $top_gvix = $top_gv->objix; |
679 | my $fmt_gv = $io->FMT_GV; |
680 | my $fmt_gvix = $fmt_gv->objix; |
681 | my $bottom_gv = $io->BOTTOM_GV; |
682 | my $bottom_gvix = $bottom_gv->objix; |
683 | |
684 | $io->B::PVMG::bytecode; |
685 | ldsv($ix); |
059a8bb7 |
686 | asm "xio_top_gv $top_gvix\n"; |
687 | asm "xio_fmt_gv $fmt_gvix\n"; |
688 | asm "xio_bottom_gv $bottom_gvix\n"; |
a798dbf2 |
689 | my $field; |
690 | foreach $field (qw(TOP_NAME FMT_NAME BOTTOM_NAME)) { |
059a8bb7 |
691 | asmf "newpv %s\nxio_%s\n", pvstring($io->$field()), lc($field); |
a798dbf2 |
692 | } |
693 | foreach $field (qw(LINES PAGE PAGE_LEN LINES_LEFT SUBPROCESS)) { |
059a8bb7 |
694 | asmf "xio_%s %d\n", lc($field), $io->$field(); |
a798dbf2 |
695 | } |
059a8bb7 |
696 | asmf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS; |
a798dbf2 |
697 | $top_gv->bytecode; |
698 | $fmt_gv->bytecode; |
699 | $bottom_gv->bytecode; |
700 | } |
701 | |
702 | sub B::SPECIAL::bytecode { |
703 | # nothing extra needs doing |
704 | } |
705 | |
706 | sub bytecompile_object { |
059a8bb7 |
707 | for my $sv (@_) { |
a798dbf2 |
708 | svref_2object($sv)->bytecode; |
709 | } |
710 | } |
711 | |
712 | sub B::GV::bytecodecv { |
713 | my $gv = shift; |
714 | my $cv = $gv->CV; |
059a8bb7 |
715 | if ($$cv && !saved($cv) && !($gv->FLAGS & GVf_IMPORTED_CV)) { |
a798dbf2 |
716 | if ($debug_cv) { |
717 | warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n", |
718 | $gv->STASH->NAME, $gv->NAME, $$cv, $$gv); |
719 | } |
720 | $gv->bytecode; |
721 | } |
722 | } |
723 | |
059a8bb7 |
724 | sub save_call_queues { |
725 | if (begin_av()->isa("B::AV")) { # this is just to save 'use Foo;' calls |
726 | for my $cv (begin_av()->ARRAY) { |
727 | next unless grep { $_ eq $cv->STASH->NAME; } @packages; |
728 | my $op = $cv->START; |
729 | OPLOOP: |
730 | while ($$op) { |
731 | if ($op->name eq 'require') { # save any BEGIN that does a require |
732 | $cv->bytecode; |
733 | asmf "push_begin %d\n", $cv->objix; |
734 | last OPLOOP; |
735 | } |
736 | $op = $op->next; |
737 | } |
738 | } |
a798dbf2 |
739 | } |
059a8bb7 |
740 | if (init_av()->isa("B::AV")) { |
741 | for my $cv (init_av()->ARRAY) { |
742 | next unless grep { $_ eq $cv->STASH->NAME; } @packages; |
743 | $cv->bytecode; |
744 | asmf "push_init %d\n", $cv->objix; |
745 | } |
746 | } |
747 | if (end_av()->isa("B::AV")) { |
748 | for my $cv (end_av()->ARRAY) { |
749 | next unless grep { $_ eq $cv->STASH->NAME; } @packages; |
750 | $cv->bytecode; |
751 | asmf "push_end %d\n", $cv->objix; |
752 | } |
a798dbf2 |
753 | } |
754 | } |
755 | |
059a8bb7 |
756 | sub symwalk { |
757 | no strict 'refs'; |
758 | my $ok = 1 if grep { (my $name = $_[0]) =~ s/::$//; $_ eq $name;} @packages; |
759 | if (grep { /^$_[0]/; } @packages) { |
760 | walksymtable(\%{"$_[0]"}, "bytecodecv", \&symwalk, $_[0]); |
761 | } |
762 | warn "considering $_[0] ... " . ($ok ? "accepted\n" : "rejected\n") |
763 | if $debug_bc; |
764 | $ok; |
a798dbf2 |
765 | } |
766 | |
059a8bb7 |
767 | sub bytecompile_main { |
768 | my $curpad = (comppadlist->ARRAY)[1]; |
769 | my $curpadix = $curpad->objix; |
770 | $curpad->bytecode; |
771 | save_call_queues(); |
772 | walkoptree(main_root, "bytecode") unless ref(main_root) eq "B::NULL"; |
773 | warn "done main program, now walking symbol table\n" if $debug_bc; |
774 | if (@packages) { |
775 | no strict qw(refs); |
776 | walksymtable(\%{"main::"}, "bytecodecv", \&symwalk); |
777 | } else { |
778 | die "No packages requested for compilation!\n"; |
779 | } |
780 | asmf "main_root %d\n", main_root->objix; |
781 | asmf "main_start %d\n", main_start->objix; |
782 | asmf "curpad $curpadix\n"; |
783 | # XXX Do min_intro_pending and max_intro_pending matter? |
a798dbf2 |
784 | } |
785 | |
786 | sub compile { |
787 | my @options = @_; |
788 | my ($option, $opt, $arg); |
789 | open(OUT, ">&STDOUT"); |
790 | binmode OUT; |
059a8bb7 |
791 | select OUT; |
a798dbf2 |
792 | OPTION: |
793 | while ($option = shift @options) { |
794 | if ($option =~ /^-(.)(.*)/) { |
795 | $opt = $1; |
796 | $arg = $2; |
797 | } else { |
798 | unshift @options, $option; |
799 | last OPTION; |
800 | } |
801 | if ($opt eq "-" && $arg eq "-") { |
802 | shift @options; |
803 | last OPTION; |
804 | } elsif ($opt eq "o") { |
805 | $arg ||= shift @options; |
806 | open(OUT, ">$arg") or return "$arg: $!\n"; |
807 | binmode OUT; |
a07043ec |
808 | } elsif ($opt eq "a") { |
809 | $arg ||= shift @options; |
810 | open(OUT, ">>$arg") or return "$arg: $!\n"; |
811 | binmode OUT; |
a798dbf2 |
812 | } elsif ($opt eq "D") { |
813 | $arg ||= shift @options; |
814 | foreach $arg (split(//, $arg)) { |
815 | if ($arg eq "b") { |
816 | $| = 1; |
817 | debug(1); |
818 | } elsif ($arg eq "o") { |
819 | B->debug(1); |
820 | } elsif ($arg eq "a") { |
821 | B::Assembler::debug(1); |
822 | } elsif ($arg eq "C") { |
823 | $debug_cv = 1; |
824 | } |
825 | } |
826 | } elsif ($opt eq "v") { |
827 | $verbose = 1; |
a798dbf2 |
828 | } elsif ($opt eq "S") { |
829 | $no_assemble = 1; |
830 | } elsif ($opt eq "f") { |
831 | $arg ||= shift @options; |
832 | my $value = $arg !~ s/^no-//; |
833 | $arg =~ s/-/_/g; |
834 | my $ref = $optimise{$arg}; |
835 | if (defined($ref)) { |
836 | $$ref = $value; |
837 | } else { |
838 | warn qq(ignoring unknown optimisation option "$arg"\n); |
839 | } |
840 | } elsif ($opt eq "O") { |
841 | $arg = 1 if $arg eq ""; |
842 | my $ref; |
843 | foreach $ref (values %optimise) { |
844 | $$ref = 0; |
845 | } |
a798dbf2 |
846 | if ($arg >= 2) { |
847 | $bypass_nullops = 1; |
848 | } |
849 | if ($arg >= 1) { |
850 | $compress_nullops = 1; |
851 | $omit_seq = 1; |
852 | } |
d873810b |
853 | } elsif ($opt eq "u") { |
059a8bb7 |
854 | $arg ||= shift @options; |
855 | push @packages, $arg; |
856 | } else { |
857 | warn qq(ignoring unknown option "$opt$arg"\n); |
a798dbf2 |
858 | } |
859 | } |
059a8bb7 |
860 | if (! @packages) { |
861 | warn "No package specified for compilation, assuming main::\n"; |
862 | @packages = qw(main); |
863 | } |
a798dbf2 |
864 | if (@options) { |
059a8bb7 |
865 | die "Extraneous options left on B::Bytecode commandline: @options\n"; |
a798dbf2 |
866 | } else { |
059a8bb7 |
867 | return sub { |
868 | newasm(\&apr) unless $no_assemble; |
a798dbf2 |
869 | bytecompile_main(); |
059a8bb7 |
870 | endasm() unless $no_assemble; |
871 | }; |
a798dbf2 |
872 | } |
873 | } |
874 | |
059a8bb7 |
875 | sub apr { print @_; } |
876 | |
a798dbf2 |
877 | 1; |
7f20e9dd |
878 | |
879 | __END__ |
880 | |
881 | =head1 NAME |
882 | |
883 | B::Bytecode - Perl compiler's bytecode backend |
884 | |
885 | =head1 SYNOPSIS |
886 | |
1a52ab62 |
887 | perl -MO=Bytecode[,OPTIONS] foo.pl |
7f20e9dd |
888 | |
889 | =head1 DESCRIPTION |
890 | |
1a52ab62 |
891 | This compiler backend takes Perl source and generates a |
892 | platform-independent bytecode encapsulating code to load the |
893 | internal structures perl uses to run your program. When the |
894 | generated bytecode is loaded in, your program is ready to run, |
895 | reducing the time which perl would have taken to load and parse |
896 | your program into its internal semi-compiled form. That means that |
897 | compiling with this backend will not help improve the runtime |
898 | execution speed of your program but may improve the start-up time. |
899 | Depending on the environment in which your program runs this may |
900 | or may not be a help. |
901 | |
902 | The resulting bytecode can be run with a special byteperl executable |
903 | or (for non-main programs) be loaded via the C<byteload_fh> function |
904 | in the F<B> module. |
905 | |
906 | =head1 OPTIONS |
907 | |
908 | If there are any non-option arguments, they are taken to be names of |
909 | objects to be saved (probably doesn't work properly yet). Without |
910 | extra arguments, it saves the main program. |
911 | |
912 | =over 4 |
913 | |
914 | =item B<-ofilename> |
915 | |
916 | Output to filename instead of STDOUT. |
917 | |
a07043ec |
918 | =item B<-afilename> |
919 | |
920 | Append output to filename. |
921 | |
1a52ab62 |
922 | =item B<--> |
923 | |
924 | Force end of options. |
925 | |
926 | =item B<-f> |
927 | |
928 | Force optimisations on or off one at a time. Each can be preceded |
929 | by B<no-> to turn the option off (e.g. B<-fno-compress-nullops>). |
930 | |
931 | =item B<-fcompress-nullops> |
932 | |
933 | Only fills in the necessary fields of ops which have |
934 | been optimised away by perl's internal compiler. |
935 | |
936 | =item B<-fomit-sequence-numbers> |
937 | |
938 | Leaves out code to fill in the op_seq field of all ops |
939 | which is only used by perl's internal compiler. |
940 | |
941 | =item B<-fbypass-nullops> |
942 | |
943 | If op->op_next ever points to a NULLOP, replaces the op_next field |
944 | with the first non-NULLOP in the path of execution. |
945 | |
1a52ab62 |
946 | =item B<-On> |
947 | |
948 | Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. |
949 | B<-O1> sets B<-fcompress-nullops> B<-fomit-sequence numbers>. |
059a8bb7 |
950 | B<-O2> adds B<-fbypass-nullops>. |
1a52ab62 |
951 | |
952 | =item B<-D> |
953 | |
954 | Debug options (concatenated or separate flags like C<perl -D>). |
955 | |
956 | =item B<-Do> |
957 | |
958 | Prints each OP as it's processed. |
959 | |
960 | =item B<-Db> |
961 | |
962 | Print debugging information about bytecompiler progress. |
963 | |
964 | =item B<-Da> |
965 | |
966 | Tells the (bytecode) assembler to include source assembler lines |
967 | in its output as bytecode comments. |
968 | |
969 | =item B<-DC> |
970 | |
971 | Prints each CV taken from the final symbol tree walk. |
972 | |
973 | =item B<-S> |
974 | |
975 | Output (bytecode) assembler source rather than piping it |
976 | through the assembler and outputting bytecode. |
977 | |
d873810b |
978 | =item B<-upackage> |
059a8bb7 |
979 | |
980 | Stores package in the output. |
981 | |
1a52ab62 |
982 | =back |
983 | |
707102d0 |
984 | =head1 EXAMPLES |
1a52ab62 |
985 | |
d873810b |
986 | perl -MO=Bytecode,-O6,-ofoo.plc,-umain foo.pl |
1a52ab62 |
987 | |
d873810b |
988 | perl -MO=Bytecode,-S,-umain foo.pl > foo.S |
e8edd1e6 |
989 | assemble foo.S > foo.plc |
1a52ab62 |
990 | |
e8edd1e6 |
991 | Note that C<assemble> lives in the C<B> subdirectory of your perl |
992 | library directory. The utility called perlcc may also be used to |
993 | help make use of this compiler. |
994 | |
d873810b |
995 | perl -MO=Bytecode,-uFoo,-oFoo.pmc Foo.pm |
1a52ab62 |
996 | |
997 | =head1 BUGS |
998 | |
059a8bb7 |
999 | Output is still huge and there are still occasional crashes during |
1000 | either compilation or ByteLoading. Current status: experimental. |
7f20e9dd |
1001 | |
059a8bb7 |
1002 | =head1 AUTHORS |
7f20e9dd |
1003 | |
1004 | Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> |
059a8bb7 |
1005 | Benjamin Stuhl, C<sho_pi@hotmail.com> |
7f20e9dd |
1006 | |
1007 | =cut |