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; |
9 | use strict; |
10 | use Carp; |
11 | use IO::File; |
12 | |
13 | use B qw(minus_c main_cv main_root main_start comppadlist |
14 | class peekop walkoptree svref_2object cstring walksymtable); |
15 | use B::Asmdata qw(@optype @specialsv_name); |
16 | use B::Assembler qw(assemble_fh); |
17 | |
18 | my %optype_enum; |
19 | my $i; |
20 | for ($i = 0; $i < @optype; $i++) { |
21 | $optype_enum{$optype[$i]} = $i; |
22 | } |
23 | |
24 | # Following is SVf_POK|SVp_POK |
25 | # XXX Shouldn't be hardwired |
26 | sub POK () { 0x04040000 } |
27 | |
28 | # Following is SVf_IOK|SVp_OK |
29 | # XXX Shouldn't be hardwired |
30 | sub IOK () { 0x01010000 } |
31 | |
32 | my ($verbose, $module_only, $no_assemble, $debug_bc, $debug_cv); |
33 | my $assembler_pid; |
34 | |
35 | # Optimisation options. On the command line, use hyphens instead of |
36 | # underscores for compatibility with gcc-style options. We use |
37 | # underscores here because they are OK in (strict) barewords. |
38 | my ($strip_syntree, $compress_nullops, $omit_seq, $bypass_nullops); |
39 | my %optimise = (strip_syntax_tree => \$strip_syntree, |
40 | compress_nullops => \$compress_nullops, |
41 | omit_sequence_numbers => \$omit_seq, |
42 | bypass_nullops => \$bypass_nullops); |
43 | |
44 | my $nextix = 0; |
45 | my %symtable; # maps object addresses to object indices. |
46 | # Filled in at allocation (newsv/newop) time. |
47 | my %saved; # maps object addresses (for SVish classes) to "saved yet?" |
48 | # flag. Set at FOO::bytecode time usually by SV::bytecode. |
49 | # Manipulated via saved(), mark_saved(), unmark_saved(). |
50 | |
51 | my $svix = -1; # we keep track of when the sv register contains an element |
52 | # of the object table to avoid unnecessary repeated |
53 | # consecutive ldsv instructions. |
54 | my $opix = -1; # Ditto for the op register. |
55 | |
56 | sub ldsv { |
57 | my $ix = shift; |
58 | if ($ix != $svix) { |
59 | print "ldsv $ix\n"; |
60 | $svix = $ix; |
61 | } |
62 | } |
63 | |
64 | sub stsv { |
65 | my $ix = shift; |
66 | print "stsv $ix\n"; |
67 | $svix = $ix; |
68 | } |
69 | |
70 | sub set_svix { |
71 | $svix = shift; |
72 | } |
73 | |
74 | sub ldop { |
75 | my $ix = shift; |
76 | if ($ix != $opix) { |
77 | print "ldop $ix\n"; |
78 | $opix = $ix; |
79 | } |
80 | } |
81 | |
82 | sub stop { |
83 | my $ix = shift; |
84 | print "stop $ix\n"; |
85 | $opix = $ix; |
86 | } |
87 | |
88 | sub set_opix { |
89 | $opix = shift; |
90 | } |
91 | |
92 | sub pvstring { |
93 | my $str = shift; |
94 | if (defined($str)) { |
95 | return cstring($str . "\0"); |
96 | } else { |
97 | return '""'; |
98 | } |
99 | } |
100 | |
101 | sub saved { $saved{${$_[0]}} } |
102 | sub mark_saved { $saved{${$_[0]}} = 1 } |
103 | sub unmark_saved { $saved{${$_[0]}} = 0 } |
104 | |
105 | sub debug { $debug_bc = shift } |
106 | |
107 | sub B::OBJECT::nyi { |
108 | my $obj = shift; |
109 | warn sprintf("bytecode save method for %s (0x%x) not yet implemented\n", |
110 | class($obj), $$obj); |
111 | } |
112 | |
113 | # |
114 | # objix may stomp on the op register (for op objects) |
115 | # or the sv register (for SV objects) |
116 | # |
117 | sub B::OBJECT::objix { |
118 | my $obj = shift; |
119 | my $ix = $symtable{$$obj}; |
120 | if (defined($ix)) { |
121 | return $ix; |
122 | } else { |
123 | $obj->newix($nextix); |
124 | return $symtable{$$obj} = $nextix++; |
125 | } |
126 | } |
127 | |
128 | sub B::SV::newix { |
129 | my ($sv, $ix) = @_; |
130 | printf "newsv %d\t# %s\n", $sv->FLAGS & 0xf, class($sv); |
131 | stsv($ix); |
132 | } |
133 | |
134 | sub B::GV::newix { |
135 | my ($gv, $ix) = @_; |
136 | my $gvname = $gv->NAME; |
137 | my $name = cstring($gv->STASH->NAME . "::" . $gvname); |
138 | print "gv_fetchpv $name\n"; |
139 | stsv($ix); |
140 | } |
141 | |
142 | sub B::HV::newix { |
143 | my ($hv, $ix) = @_; |
144 | my $name = $hv->NAME; |
145 | if ($name) { |
146 | # It's a stash |
147 | printf "gv_stashpv %s\n", cstring($name); |
148 | stsv($ix); |
149 | } else { |
150 | # It's an ordinary HV. Fall back to ordinary newix method |
151 | $hv->B::SV::newix($ix); |
152 | } |
153 | } |
154 | |
155 | sub B::SPECIAL::newix { |
156 | my ($sv, $ix) = @_; |
157 | # Special case. $$sv is not the address of the SV but an |
158 | # index into svspecialsv_list. |
159 | printf "ldspecsv $$sv\t# %s\n", $specialsv_name[$$sv]; |
160 | stsv($ix); |
161 | } |
162 | |
163 | sub B::OP::newix { |
164 | my ($op, $ix) = @_; |
165 | my $class = class($op); |
166 | my $typenum = $optype_enum{$class}; |
167 | croak "OP::newix: can't understand class $class" unless defined($typenum); |
168 | print "newop $typenum\t# $class\n"; |
169 | stop($ix); |
170 | } |
171 | |
172 | sub B::OP::walkoptree_debug { |
173 | my $op = shift; |
174 | warn(sprintf("walkoptree: %s\n", peekop($op))); |
175 | } |
176 | |
177 | sub B::OP::bytecode { |
178 | my $op = shift; |
179 | my $next = $op->next; |
180 | my $nextix; |
181 | my $sibix = $op->sibling->objix; |
182 | my $ix = $op->objix; |
183 | my $type = $op->type; |
184 | |
185 | if ($bypass_nullops) { |
186 | $next = $next->next while $$next && $next->type == 0; |
187 | } |
188 | $nextix = $next->objix; |
189 | |
190 | printf "# %s\n", peekop($op) if $debug_bc; |
191 | ldop($ix); |
192 | print "op_next $nextix\n"; |
193 | print "op_sibling $sibix\n" unless $strip_syntree; |
194 | printf "op_type %s\t# %d\n", $op->ppaddr, $type; |
195 | printf("op_seq %d\n", $op->seq) unless $omit_seq; |
196 | if ($type || !$compress_nullops) { |
197 | printf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n", |
198 | $op->targ, $op->flags, $op->private; |
199 | } |
200 | } |
201 | |
202 | sub B::UNOP::bytecode { |
203 | my $op = shift; |
204 | my $firstix = $op->first->objix; |
205 | $op->B::OP::bytecode; |
206 | if (($op->type || !$compress_nullops) && !$strip_syntree) { |
207 | print "op_first $firstix\n"; |
208 | } |
209 | } |
210 | |
211 | sub B::LOGOP::bytecode { |
212 | my $op = shift; |
213 | my $otherix = $op->other->objix; |
214 | $op->B::UNOP::bytecode; |
215 | print "op_other $otherix\n"; |
216 | } |
217 | |
218 | sub B::SVOP::bytecode { |
219 | my $op = shift; |
220 | my $sv = $op->sv; |
221 | my $svix = $sv->objix; |
222 | $op->B::OP::bytecode; |
223 | print "op_sv $svix\n"; |
224 | $sv->bytecode; |
225 | } |
226 | |
227 | sub B::GVOP::bytecode { |
228 | my $op = shift; |
229 | my $gv = $op->gv; |
230 | my $gvix = $gv->objix; |
231 | $op->B::OP::bytecode; |
232 | print "op_gv $gvix\n"; |
233 | $gv->bytecode; |
234 | } |
235 | |
236 | sub B::PVOP::bytecode { |
237 | my $op = shift; |
238 | my $pv = $op->pv; |
239 | $op->B::OP::bytecode; |
240 | # |
241 | # This would be easy except that OP_TRANS uses a PVOP to store an |
242 | # endian-dependent array of 256 shorts instead of a plain string. |
243 | # |
244 | if ($op->ppaddr eq "pp_trans") { |
245 | my @shorts = unpack("s256", $pv); # assembler handles endianness |
246 | print "op_pv_tr ", join(",", @shorts), "\n"; |
247 | } else { |
248 | printf "newpv %s\nop_pv\n", pvstring($pv); |
249 | } |
250 | } |
251 | |
252 | sub B::BINOP::bytecode { |
253 | my $op = shift; |
254 | my $lastix = $op->last->objix; |
255 | $op->B::UNOP::bytecode; |
256 | if (($op->type || !$compress_nullops) && !$strip_syntree) { |
257 | print "op_last $lastix\n"; |
258 | } |
259 | } |
260 | |
261 | sub B::CONDOP::bytecode { |
262 | my $op = shift; |
263 | my $trueix = $op->true->objix; |
264 | my $falseix = $op->false->objix; |
265 | $op->B::UNOP::bytecode; |
266 | print "op_true $trueix\nop_false $falseix\n"; |
267 | } |
268 | |
269 | sub B::LISTOP::bytecode { |
270 | my $op = shift; |
271 | my $children = $op->children; |
272 | $op->B::BINOP::bytecode; |
273 | if (($op->type || !$compress_nullops) && !$strip_syntree) { |
274 | print "op_children $children\n"; |
275 | } |
276 | } |
277 | |
278 | sub B::LOOP::bytecode { |
279 | my $op = shift; |
280 | my $redoopix = $op->redoop->objix; |
281 | my $nextopix = $op->nextop->objix; |
282 | my $lastopix = $op->lastop->objix; |
283 | $op->B::LISTOP::bytecode; |
284 | print "op_redoop $redoopix\nop_nextop $nextopix\nop_lastop $lastopix\n"; |
285 | } |
286 | |
287 | sub B::COP::bytecode { |
288 | my $op = shift; |
289 | my $stash = $op->stash; |
290 | my $stashix = $stash->objix; |
291 | my $filegv = $op->filegv; |
292 | my $filegvix = $filegv->objix; |
293 | my $line = $op->line; |
294 | if ($debug_bc) { |
295 | printf "# line %s:%d\n", $filegv->SV->PV, $line; |
296 | } |
297 | $op->B::OP::bytecode; |
298 | printf <<"EOT", pvstring($op->label), $op->cop_seq, $op->arybase; |
299 | newpv %s |
300 | cop_label |
301 | cop_stash $stashix |
302 | cop_seq %d |
303 | cop_filegv $filegvix |
304 | cop_arybase %d |
305 | cop_line $line |
306 | EOT |
307 | $filegv->bytecode; |
308 | $stash->bytecode; |
309 | } |
310 | |
311 | sub B::PMOP::bytecode { |
312 | my $op = shift; |
313 | my $replroot = $op->pmreplroot; |
314 | my $replrootix = $replroot->objix; |
315 | my $replstartix = $op->pmreplstart->objix; |
316 | my $ppaddr = $op->ppaddr; |
317 | # pmnext is corrupt in some PMOPs (see misc.t for example) |
318 | #my $pmnextix = $op->pmnext->objix; |
319 | |
320 | if ($$replroot) { |
321 | # OP_PUSHRE (a mutated version of OP_MATCH for the regexp |
322 | # argument to a split) stores a GV in op_pmreplroot instead |
323 | # of a substitution syntax tree. We don't want to walk that... |
324 | if ($ppaddr eq "pp_pushre") { |
325 | $replroot->bytecode; |
326 | } else { |
327 | walkoptree($replroot, "bytecode"); |
328 | } |
329 | } |
330 | $op->B::LISTOP::bytecode; |
331 | if ($ppaddr eq "pp_pushre") { |
332 | printf "op_pmreplrootgv $replrootix\n"; |
333 | } else { |
334 | print "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n"; |
335 | } |
336 | my $re = pvstring($op->precomp); |
337 | # op_pmnext omitted since a perl bug means it's sometime corrupt |
338 | printf <<"EOT", $op->pmflags, $op->pmpermflags; |
339 | op_pmflags 0x%x |
340 | op_pmpermflags 0x%x |
341 | newpv $re |
342 | pregcomp |
343 | EOT |
344 | } |
345 | |
346 | sub B::SV::bytecode { |
347 | my $sv = shift; |
348 | return if saved($sv); |
349 | my $ix = $sv->objix; |
350 | my $refcnt = $sv->REFCNT; |
351 | my $flags = sprintf("0x%x", $sv->FLAGS); |
352 | ldsv($ix); |
353 | print "sv_refcnt $refcnt\nsv_flags $flags\n"; |
354 | mark_saved($sv); |
355 | } |
356 | |
357 | sub B::PV::bytecode { |
358 | my $sv = shift; |
359 | return if saved($sv); |
360 | $sv->B::SV::bytecode; |
361 | printf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK; |
362 | } |
363 | |
364 | sub B::IV::bytecode { |
365 | my $sv = shift; |
366 | return if saved($sv); |
367 | my $iv = $sv->IVX; |
368 | $sv->B::SV::bytecode; |
369 | printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32"; |
370 | } |
371 | |
372 | sub B::NV::bytecode { |
373 | my $sv = shift; |
374 | return if saved($sv); |
375 | $sv->B::SV::bytecode; |
376 | printf "xnv %s\n", $sv->NVX; |
377 | } |
378 | |
379 | sub B::RV::bytecode { |
380 | my $sv = shift; |
381 | return if saved($sv); |
382 | my $rv = $sv->RV; |
383 | my $rvix = $rv->objix; |
384 | $rv->bytecode; |
385 | $sv->B::SV::bytecode; |
386 | print "xrv $rvix\n"; |
387 | } |
388 | |
389 | sub B::PVIV::bytecode { |
390 | my $sv = shift; |
391 | return if saved($sv); |
392 | my $iv = $sv->IVX; |
393 | $sv->B::PV::bytecode; |
394 | printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32"; |
395 | } |
396 | |
397 | sub B::PVNV::bytecode { |
398 | my ($sv, $flag) = @_; |
399 | # The $flag argument is passed through PVMG::bytecode by BM::bytecode |
400 | # and AV::bytecode and indicates special handling. $flag = 1 is used by |
401 | # BM::bytecode and means that we should ensure we save the whole B-M |
402 | # table. It consists of 257 bytes (256 char array plus a final \0) |
403 | # which follow the ordinary PV+\0 and the 257 bytes are *not* reflected |
404 | # in SvCUR. $flag = 2 is used by AV::bytecode and means that we only |
405 | # call SV::bytecode instead of saving PV and calling NV::bytecode since |
406 | # PV/NV/IV stuff is different for AVs. |
407 | return if saved($sv); |
408 | if ($flag == 2) { |
409 | $sv->B::SV::bytecode; |
410 | } else { |
411 | my $pv = $sv->PV; |
412 | $sv->B::IV::bytecode; |
413 | printf "xnv %s\n", $sv->NVX; |
414 | if ($flag == 1) { |
415 | $pv .= "\0" . $sv->TABLE; |
416 | printf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257; |
417 | } else { |
418 | printf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK; |
419 | } |
420 | } |
421 | } |
422 | |
423 | sub B::PVMG::bytecode { |
424 | my ($sv, $flag) = @_; |
425 | # See B::PVNV::bytecode for an explanation of $flag. |
426 | return if saved($sv); |
427 | # XXX We assume SvSTASH is already saved and don't save it later ourselves |
428 | my $stashix = $sv->SvSTASH->objix; |
429 | my @mgchain = $sv->MAGIC; |
430 | my (@mgobjix, $mg); |
431 | # |
432 | # We need to traverse the magic chain and get objix for each OBJ |
433 | # field *before* we do B::PVNV::bytecode since objix overwrites |
434 | # the sv register. However, we need to write the magic-saving |
435 | # bytecode *after* B::PVNV::bytecode since sv isn't initialised |
436 | # to refer to $sv until then. |
437 | # |
438 | @mgobjix = map($_->OBJ->objix, @mgchain); |
439 | $sv->B::PVNV::bytecode($flag); |
440 | print "xmg_stash $stashix\n"; |
441 | foreach $mg (@mgchain) { |
442 | printf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n", |
443 | cstring($mg->TYPE), shift(@mgobjix), pvstring($mg->PTR); |
444 | } |
445 | } |
446 | |
447 | sub B::PVLV::bytecode { |
448 | my $sv = shift; |
449 | return if saved($sv); |
450 | $sv->B::PVMG::bytecode; |
451 | printf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE); |
452 | xlv_targoff %d |
453 | xlv_targlen %d |
454 | xlv_type %s |
455 | EOT |
456 | } |
457 | |
458 | sub B::BM::bytecode { |
459 | my $sv = shift; |
460 | return if saved($sv); |
461 | # See PVNV::bytecode for an explanation of what the argument does |
462 | $sv->B::PVMG::bytecode(1); |
463 | printf "xbm_useful %d\nxbm_previous %d\nxbm_rare %d\n", |
464 | $sv->USEFUL, $sv->PREVIOUS, $sv->RARE; |
465 | } |
466 | |
467 | sub B::GV::bytecode { |
468 | my $gv = shift; |
469 | return if saved($gv); |
470 | my $ix = $gv->objix; |
471 | mark_saved($gv); |
472 | my $gvname = $gv->NAME; |
473 | my $name = cstring($gv->STASH->NAME . "::" . $gvname); |
474 | my $egv = $gv->EGV; |
475 | my $egvix = $egv->objix; |
476 | ldsv($ix); |
477 | printf <<"EOT", $gv->FLAGS, $gv->GvFLAGS, $gv->LINE; |
478 | sv_flags 0x%x |
479 | xgv_flags 0x%x |
480 | gp_line %d |
481 | EOT |
482 | my $refcnt = $gv->REFCNT; |
483 | printf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1; |
484 | my $gvrefcnt = $gv->GvREFCNT; |
485 | printf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1; |
486 | if ($gvrefcnt > 1 && $ix != $egvix) { |
487 | print "gp_share $egvix\n"; |
488 | } else { |
489 | if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) { |
490 | my $i; |
491 | my @subfield_names = qw(SV AV HV CV FILEGV FORM IO); |
492 | my @subfields = map($gv->$_(), @subfield_names); |
493 | my @ixes = map($_->objix, @subfields); |
494 | # Reset sv register for $gv |
495 | ldsv($ix); |
496 | for ($i = 0; $i < @ixes; $i++) { |
497 | printf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; |
498 | } |
499 | # Now save all the subfields |
500 | my $sv; |
501 | foreach $sv (@subfields) { |
502 | $sv->bytecode; |
503 | } |
504 | } |
505 | } |
506 | } |
507 | |
508 | sub B::HV::bytecode { |
509 | my $hv = shift; |
510 | return if saved($hv); |
511 | mark_saved($hv); |
512 | my $name = $hv->NAME; |
513 | my $ix = $hv->objix; |
514 | if (!$name) { |
515 | # It's an ordinary HV. Stashes have NAME set and need no further |
516 | # saving beyond the gv_stashpv that $hv->objix already ensures. |
517 | my @contents = $hv->ARRAY; |
518 | my ($i, @ixes); |
519 | for ($i = 1; $i < @contents; $i += 2) { |
520 | push(@ixes, $contents[$i]->objix); |
521 | } |
522 | for ($i = 1; $i < @contents; $i += 2) { |
523 | $contents[$i]->bytecode; |
524 | } |
525 | ldsv($ix); |
526 | for ($i = 0; $i < @contents; $i += 2) { |
527 | printf("newpv %s\nhv_store %d\n", |
528 | pvstring($contents[$i]), $ixes[$i / 2]); |
529 | } |
530 | printf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS; |
531 | } |
532 | } |
533 | |
534 | sub B::AV::bytecode { |
535 | my $av = shift; |
536 | return if saved($av); |
537 | my $ix = $av->objix; |
538 | my $fill = $av->FILL; |
539 | my $max = $av->MAX; |
540 | my (@array, @ixes); |
541 | if ($fill > -1) { |
542 | @array = $av->ARRAY; |
543 | @ixes = map($_->objix, @array); |
544 | my $sv; |
545 | foreach $sv (@array) { |
546 | $sv->bytecode; |
547 | } |
548 | } |
549 | # See PVNV::bytecode for the meaning of the flag argument of 2. |
550 | $av->B::PVMG::bytecode(2); |
551 | # Recover sv register and set AvMAX and AvFILL to -1 (since we |
552 | # create an AV with NEWSV and SvUPGRADE rather than doing newAV |
553 | # which is what sets AvMAX and AvFILL. |
554 | ldsv($ix); |
555 | printf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS; |
556 | if ($fill > -1) { |
557 | my $elix; |
558 | foreach $elix (@ixes) { |
559 | print "av_push $elix\n"; |
560 | } |
561 | } else { |
562 | if ($max > -1) { |
563 | print "av_extend $max\n"; |
564 | } |
565 | } |
566 | } |
567 | |
568 | sub B::CV::bytecode { |
569 | my $cv = shift; |
570 | return if saved($cv); |
571 | my $ix = $cv->objix; |
572 | $cv->B::PVMG::bytecode; |
573 | my $i; |
574 | my @subfield_names = qw(ROOT START STASH GV FILEGV PADLIST OUTSIDE); |
575 | my @subfields = map($cv->$_(), @subfield_names); |
576 | my @ixes = map($_->objix, @subfields); |
577 | # Save OP tree from CvROOT (first element of @subfields) |
578 | my $root = shift @subfields; |
579 | if ($$root) { |
580 | walkoptree($root, "bytecode"); |
581 | } |
582 | # Reset sv register for $cv (since above ->objix calls stomped on it) |
583 | ldsv($ix); |
584 | for ($i = 0; $i < @ixes; $i++) { |
585 | printf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; |
586 | } |
587 | printf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->FLAGS; |
588 | # Now save all the subfields (except for CvROOT which was handled |
589 | # above) and CvSTART (now the initial element of @subfields). |
590 | shift @subfields; # bye-bye CvSTART |
591 | my $sv; |
592 | foreach $sv (@subfields) { |
593 | $sv->bytecode; |
594 | } |
595 | } |
596 | |
597 | sub B::IO::bytecode { |
598 | my $io = shift; |
599 | return if saved($io); |
600 | my $ix = $io->objix; |
601 | my $top_gv = $io->TOP_GV; |
602 | my $top_gvix = $top_gv->objix; |
603 | my $fmt_gv = $io->FMT_GV; |
604 | my $fmt_gvix = $fmt_gv->objix; |
605 | my $bottom_gv = $io->BOTTOM_GV; |
606 | my $bottom_gvix = $bottom_gv->objix; |
607 | |
608 | $io->B::PVMG::bytecode; |
609 | ldsv($ix); |
610 | print "xio_top_gv $top_gvix\n"; |
611 | print "xio_fmt_gv $fmt_gvix\n"; |
612 | print "xio_bottom_gv $bottom_gvix\n"; |
613 | my $field; |
614 | foreach $field (qw(TOP_NAME FMT_NAME BOTTOM_NAME)) { |
615 | printf "newpv %s\nxio_%s\n", pvstring($io->$field()), lc($field); |
616 | } |
617 | foreach $field (qw(LINES PAGE PAGE_LEN LINES_LEFT SUBPROCESS)) { |
618 | printf "xio_%s %d\n", lc($field), $io->$field(); |
619 | } |
620 | printf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS; |
621 | $top_gv->bytecode; |
622 | $fmt_gv->bytecode; |
623 | $bottom_gv->bytecode; |
624 | } |
625 | |
626 | sub B::SPECIAL::bytecode { |
627 | # nothing extra needs doing |
628 | } |
629 | |
630 | sub bytecompile_object { |
631 | my $sv; |
632 | foreach $sv (@_) { |
633 | svref_2object($sv)->bytecode; |
634 | } |
635 | } |
636 | |
637 | sub B::GV::bytecodecv { |
638 | my $gv = shift; |
639 | my $cv = $gv->CV; |
640 | if ($$cv && !saved($cv)) { |
641 | if ($debug_cv) { |
642 | warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n", |
643 | $gv->STASH->NAME, $gv->NAME, $$cv, $$gv); |
644 | } |
645 | $gv->bytecode; |
646 | } |
647 | } |
648 | |
649 | sub bytecompile_main { |
650 | my $curpad = (comppadlist->ARRAY)[1]; |
651 | my $curpadix = $curpad->objix; |
652 | $curpad->bytecode; |
653 | walkoptree(main_root, "bytecode"); |
654 | warn "done main program, now walking symbol table\n" if $debug_bc; |
655 | my ($pack, %exclude); |
656 | foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS strict vars |
657 | FileHandle Exporter Carp UNIVERSAL IO Fcntl Symbol |
658 | SelectSaver blib Cwd)) |
659 | { |
660 | $exclude{$pack."::"} = 1; |
661 | } |
662 | no strict qw(vars refs); |
663 | walksymtable(\%{"main::"}, "bytecodecv", sub { |
664 | warn "considering $_[0]\n" if $debug_bc; |
665 | return !defined($exclude{$_[0]}); |
666 | }); |
667 | if (!$module_only) { |
668 | printf "main_root %d\n", main_root->objix; |
669 | printf "main_start %d\n", main_start->objix; |
670 | printf "curpad $curpadix\n"; |
671 | # XXX Do min_intro_pending and max_intro_pending matter? |
672 | } |
673 | } |
674 | |
675 | sub prepare_assemble { |
676 | my $newfh = IO::File->new_tmpfile; |
677 | select($newfh); |
678 | binmode $newfh; |
679 | return $newfh; |
680 | } |
681 | |
682 | sub do_assemble { |
683 | my $fh = shift; |
684 | seek($fh, 0, 0); # rewind the temporary file |
685 | assemble_fh($fh, sub { print OUT @_ }); |
686 | } |
687 | |
688 | sub compile { |
689 | my @options = @_; |
690 | my ($option, $opt, $arg); |
691 | open(OUT, ">&STDOUT"); |
692 | binmode OUT; |
693 | select(OUT); |
694 | OPTION: |
695 | while ($option = shift @options) { |
696 | if ($option =~ /^-(.)(.*)/) { |
697 | $opt = $1; |
698 | $arg = $2; |
699 | } else { |
700 | unshift @options, $option; |
701 | last OPTION; |
702 | } |
703 | if ($opt eq "-" && $arg eq "-") { |
704 | shift @options; |
705 | last OPTION; |
706 | } elsif ($opt eq "o") { |
707 | $arg ||= shift @options; |
708 | open(OUT, ">$arg") or return "$arg: $!\n"; |
709 | binmode OUT; |
710 | } elsif ($opt eq "D") { |
711 | $arg ||= shift @options; |
712 | foreach $arg (split(//, $arg)) { |
713 | if ($arg eq "b") { |
714 | $| = 1; |
715 | debug(1); |
716 | } elsif ($arg eq "o") { |
717 | B->debug(1); |
718 | } elsif ($arg eq "a") { |
719 | B::Assembler::debug(1); |
720 | } elsif ($arg eq "C") { |
721 | $debug_cv = 1; |
722 | } |
723 | } |
724 | } elsif ($opt eq "v") { |
725 | $verbose = 1; |
726 | } elsif ($opt eq "m") { |
727 | $module_only = 1; |
728 | } elsif ($opt eq "S") { |
729 | $no_assemble = 1; |
730 | } elsif ($opt eq "f") { |
731 | $arg ||= shift @options; |
732 | my $value = $arg !~ s/^no-//; |
733 | $arg =~ s/-/_/g; |
734 | my $ref = $optimise{$arg}; |
735 | if (defined($ref)) { |
736 | $$ref = $value; |
737 | } else { |
738 | warn qq(ignoring unknown optimisation option "$arg"\n); |
739 | } |
740 | } elsif ($opt eq "O") { |
741 | $arg = 1 if $arg eq ""; |
742 | my $ref; |
743 | foreach $ref (values %optimise) { |
744 | $$ref = 0; |
745 | } |
746 | if ($arg >= 6) { |
747 | $strip_syntree = 1; |
748 | } |
749 | if ($arg >= 2) { |
750 | $bypass_nullops = 1; |
751 | } |
752 | if ($arg >= 1) { |
753 | $compress_nullops = 1; |
754 | $omit_seq = 1; |
755 | } |
756 | } |
757 | } |
758 | if (@options) { |
759 | return sub { |
760 | my $objname; |
761 | my $newfh; |
762 | $newfh = prepare_assemble() unless $no_assemble; |
763 | foreach $objname (@options) { |
764 | eval "bytecompile_object(\\$objname)"; |
765 | } |
766 | do_assemble($newfh) unless $no_assemble; |
767 | } |
768 | } else { |
769 | return sub { |
770 | my $newfh; |
771 | $newfh = prepare_assemble() unless $no_assemble; |
772 | bytecompile_main(); |
773 | do_assemble($newfh) unless $no_assemble; |
774 | } |
775 | } |
776 | } |
777 | |
778 | 1; |