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