This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
B::Bytecode tweaks (from Simon Cozens <simon@brecon.co.uk>)
[perl5.git] / ext / B / B / Bytecode.pm
CommitLineData
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#
8package B::Bytecode;
9use strict;
10use Carp;
11use IO::File;
12
13use 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
17use B::Asmdata qw(@optype @specialsv_name);
18use B::Assembler qw(assemble_fh);
19
20my %optype_enum;
21my $i;
22for ($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 28sub POK () { SVf_POK|SVp_POK }
a798dbf2 29
4c1f658f 30# Following is SVf_IOK|SVp_IOK
a798dbf2 31# XXX Shouldn't be hardwired
4c1f658f 32sub IOK () { SVf_IOK|SVp_IOK }
a798dbf2
MB
33
34my ($verbose, $module_only, $no_assemble, $debug_bc, $debug_cv);
35my $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.
40my ($strip_syntree, $compress_nullops, $omit_seq, $bypass_nullops);
41my %optimise = (strip_syntax_tree => \$strip_syntree,
42 compress_nullops => \$compress_nullops,
43 omit_sequence_numbers => \$omit_seq,
44 bypass_nullops => \$bypass_nullops);
45
46my $nextix = 0;
47my %symtable; # maps object addresses to object indices.
48 # Filled in at allocation (newsv/newop) time.
49my %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
53my $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.
56my $opix = -1; # Ditto for the op register.
57
58sub ldsv {
59 my $ix = shift;
60 if ($ix != $svix) {
61 print "ldsv $ix\n";
62 $svix = $ix;
63 }
64}
65
66sub stsv {
67 my $ix = shift;
68 print "stsv $ix\n";
69 $svix = $ix;
70}
71
72sub set_svix {
73 $svix = shift;
74}
75
76sub ldop {
77 my $ix = shift;
78 if ($ix != $opix) {
79 print "ldop $ix\n";
80 $opix = $ix;
81 }
82}
83
84sub stop {
85 my $ix = shift;
86 print "stop $ix\n";
87 $opix = $ix;
88}
89
90sub set_opix {
91 $opix = shift;
92}
93
94sub pvstring {
95 my $str = shift;
96 if (defined($str)) {
97 return cstring($str . "\0");
98 } else {
99 return '""';
100 }
101}
102
103sub saved { $saved{${$_[0]}} }
104sub mark_saved { $saved{${$_[0]}} = 1 }
105sub unmark_saved { $saved{${$_[0]}} = 0 }
106
107sub debug { $debug_bc = shift }
108
109sub 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#
119sub 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
130sub B::SV::newix {
131 my ($sv, $ix) = @_;
132 printf "newsv %d\t# %s\n", $sv->FLAGS & 0xf, class($sv);
133 stsv($ix);
134}
135
136sub 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
144sub 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
157sub 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
165sub 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
174sub B::OP::walkoptree_debug {
175 my $op = shift;
176 warn(sprintf("walkoptree: %s\n", peekop($op)));
177}
178
179sub 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
204sub 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
213sub 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
220sub 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 229sub 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
236sub 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
252sub 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
261sub 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
270sub 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
279sub B::COP::bytecode {
280 my $op = shift;
11faa288 281 my $stashpv = $op->stashpv;
57843af0 282 my $file = $op->file;
a798dbf2 283 my $line = $op->line;
b295d113
TH
284 my $warnings = $op->warnings;
285 my $warningsix = $warnings->objix;
a798dbf2 286 if ($debug_bc) {
57843af0 287 printf "# line %s:%d\n", $file, $line;
a798dbf2
MB
288 }
289 $op->B::OP::bytecode;
11faa288 290 printf <<"EOT", pvstring($op->label), pvstring($stashpv), $op->cop_seq, pvstring($file), $op->arybase;
a798dbf2
MB
291newpv %s
292cop_label
11faa288
GS
293newpv %s
294cop_stashpv
a798dbf2 295cop_seq %d
57843af0
GS
296newpv %s
297cop_file
a798dbf2
MB
298cop_arybase %d
299cop_line $line
b295d113 300cop_warnings $warningsix
a798dbf2 301EOT
a798dbf2
MB
302}
303
304sub B::PMOP::bytecode {
305 my $op = shift;
306 my $replroot = $op->pmreplroot;
307 my $replrootix = $replroot->objix;
308 my $replstartix = $op->pmreplstart->objix;
3f872cb9 309 my $opname = $op->name;
a798dbf2
MB
310 # pmnext is corrupt in some PMOPs (see misc.t for example)
311 #my $pmnextix = $op->pmnext->objix;
312
313 if ($$replroot) {
314 # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
315 # argument to a split) stores a GV in op_pmreplroot instead
316 # of a substitution syntax tree. We don't want to walk that...
3f872cb9 317 if ($opname eq "pushre") {
a798dbf2
MB
318 $replroot->bytecode;
319 } else {
320 walkoptree($replroot, "bytecode");
321 }
322 }
323 $op->B::LISTOP::bytecode;
3f872cb9 324 if ($opname eq "pushre") {
a798dbf2
MB
325 printf "op_pmreplrootgv $replrootix\n";
326 } else {
327 print "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n";
328 }
329 my $re = pvstring($op->precomp);
330 # op_pmnext omitted since a perl bug means it's sometime corrupt
331 printf <<"EOT", $op->pmflags, $op->pmpermflags;
332op_pmflags 0x%x
333op_pmpermflags 0x%x
334newpv $re
335pregcomp
336EOT
337}
338
339sub B::SV::bytecode {
340 my $sv = shift;
341 return if saved($sv);
342 my $ix = $sv->objix;
343 my $refcnt = $sv->REFCNT;
344 my $flags = sprintf("0x%x", $sv->FLAGS);
345 ldsv($ix);
346 print "sv_refcnt $refcnt\nsv_flags $flags\n";
347 mark_saved($sv);
348}
349
350sub B::PV::bytecode {
351 my $sv = shift;
352 return if saved($sv);
353 $sv->B::SV::bytecode;
354 printf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK;
355}
356
357sub B::IV::bytecode {
358 my $sv = shift;
359 return if saved($sv);
360 my $iv = $sv->IVX;
361 $sv->B::SV::bytecode;
362 printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32";
363}
364
365sub B::NV::bytecode {
366 my $sv = shift;
367 return if saved($sv);
368 $sv->B::SV::bytecode;
369 printf "xnv %s\n", $sv->NVX;
370}
371
372sub B::RV::bytecode {
373 my $sv = shift;
374 return if saved($sv);
375 my $rv = $sv->RV;
376 my $rvix = $rv->objix;
377 $rv->bytecode;
378 $sv->B::SV::bytecode;
379 print "xrv $rvix\n";
380}
381
382sub B::PVIV::bytecode {
383 my $sv = shift;
384 return if saved($sv);
385 my $iv = $sv->IVX;
386 $sv->B::PV::bytecode;
387 printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32";
388}
389
390sub B::PVNV::bytecode {
9636a016
GS
391 my $sv = shift;
392 my $flag = shift || 0;
a798dbf2
MB
393 # The $flag argument is passed through PVMG::bytecode by BM::bytecode
394 # and AV::bytecode and indicates special handling. $flag = 1 is used by
395 # BM::bytecode and means that we should ensure we save the whole B-M
396 # table. It consists of 257 bytes (256 char array plus a final \0)
397 # which follow the ordinary PV+\0 and the 257 bytes are *not* reflected
398 # in SvCUR. $flag = 2 is used by AV::bytecode and means that we only
399 # call SV::bytecode instead of saving PV and calling NV::bytecode since
400 # PV/NV/IV stuff is different for AVs.
401 return if saved($sv);
402 if ($flag == 2) {
403 $sv->B::SV::bytecode;
404 } else {
405 my $pv = $sv->PV;
406 $sv->B::IV::bytecode;
407 printf "xnv %s\n", $sv->NVX;
408 if ($flag == 1) {
409 $pv .= "\0" . $sv->TABLE;
410 printf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257;
411 } else {
412 printf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK;
413 }
414 }
415}
416
417sub B::PVMG::bytecode {
418 my ($sv, $flag) = @_;
419 # See B::PVNV::bytecode for an explanation of $flag.
420 return if saved($sv);
421 # XXX We assume SvSTASH is already saved and don't save it later ourselves
422 my $stashix = $sv->SvSTASH->objix;
423 my @mgchain = $sv->MAGIC;
424 my (@mgobjix, $mg);
425 #
426 # We need to traverse the magic chain and get objix for each OBJ
427 # field *before* we do B::PVNV::bytecode since objix overwrites
428 # the sv register. However, we need to write the magic-saving
429 # bytecode *after* B::PVNV::bytecode since sv isn't initialised
430 # to refer to $sv until then.
431 #
432 @mgobjix = map($_->OBJ->objix, @mgchain);
433 $sv->B::PVNV::bytecode($flag);
434 print "xmg_stash $stashix\n";
435 foreach $mg (@mgchain) {
436 printf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n",
437 cstring($mg->TYPE), shift(@mgobjix), pvstring($mg->PTR);
438 }
439}
440
441sub B::PVLV::bytecode {
442 my $sv = shift;
443 return if saved($sv);
444 $sv->B::PVMG::bytecode;
445 printf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE);
446xlv_targoff %d
447xlv_targlen %d
448xlv_type %s
449EOT
450}
451
452sub B::BM::bytecode {
453 my $sv = shift;
454 return if saved($sv);
455 # See PVNV::bytecode for an explanation of what the argument does
456 $sv->B::PVMG::bytecode(1);
457 printf "xbm_useful %d\nxbm_previous %d\nxbm_rare %d\n",
458 $sv->USEFUL, $sv->PREVIOUS, $sv->RARE;
459}
460
461sub B::GV::bytecode {
462 my $gv = shift;
463 return if saved($gv);
464 my $ix = $gv->objix;
465 mark_saved($gv);
a798dbf2 466 ldsv($ix);
fc290457 467 printf <<"EOT", $gv->FLAGS, $gv->GvFLAGS;
a798dbf2
MB
468sv_flags 0x%x
469xgv_flags 0x%x
fc290457
GS
470EOT
471 my $refcnt = $gv->REFCNT;
472 printf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1;
473 return if $gv->is_empty;
474 printf <<"EOT", $gv->LINE, pvstring($gv->FILE);
a798dbf2 475gp_line %d
86162ee8
GS
476newpv %s
477gp_file
a798dbf2 478EOT
fc290457
GS
479 my $gvname = $gv->NAME;
480 my $name = cstring($gv->STASH->NAME . "::" . $gvname);
481 my $egv = $gv->EGV;
482 my $egvix = $egv->objix;
a798dbf2
MB
483 my $gvrefcnt = $gv->GvREFCNT;
484 printf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1;
485 if ($gvrefcnt > 1 && $ix != $egvix) {
486 print "gp_share $egvix\n";
487 } else {
488 if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
489 my $i;
b195d487 490 my @subfield_names = qw(SV AV HV CV FORM IO);
a798dbf2
MB
491 my @subfields = map($gv->$_(), @subfield_names);
492 my @ixes = map($_->objix, @subfields);
493 # Reset sv register for $gv
494 ldsv($ix);
495 for ($i = 0; $i < @ixes; $i++) {
496 printf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
497 }
498 # Now save all the subfields
499 my $sv;
500 foreach $sv (@subfields) {
501 $sv->bytecode;
502 }
503 }
504 }
505}
506
507sub B::HV::bytecode {
508 my $hv = shift;
509 return if saved($hv);
510 mark_saved($hv);
511 my $name = $hv->NAME;
512 my $ix = $hv->objix;
513 if (!$name) {
514 # It's an ordinary HV. Stashes have NAME set and need no further
515 # saving beyond the gv_stashpv that $hv->objix already ensures.
516 my @contents = $hv->ARRAY;
517 my ($i, @ixes);
518 for ($i = 1; $i < @contents; $i += 2) {
519 push(@ixes, $contents[$i]->objix);
520 }
521 for ($i = 1; $i < @contents; $i += 2) {
522 $contents[$i]->bytecode;
523 }
524 ldsv($ix);
525 for ($i = 0; $i < @contents; $i += 2) {
526 printf("newpv %s\nhv_store %d\n",
527 pvstring($contents[$i]), $ixes[$i / 2]);
528 }
529 printf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS;
530 }
531}
532
533sub B::AV::bytecode {
534 my $av = shift;
535 return if saved($av);
536 my $ix = $av->objix;
537 my $fill = $av->FILL;
538 my $max = $av->MAX;
539 my (@array, @ixes);
540 if ($fill > -1) {
541 @array = $av->ARRAY;
542 @ixes = map($_->objix, @array);
543 my $sv;
544 foreach $sv (@array) {
545 $sv->bytecode;
546 }
547 }
548 # See PVNV::bytecode for the meaning of the flag argument of 2.
549 $av->B::PVMG::bytecode(2);
550 # Recover sv register and set AvMAX and AvFILL to -1 (since we
551 # create an AV with NEWSV and SvUPGRADE rather than doing newAV
552 # which is what sets AvMAX and AvFILL.
553 ldsv($ix);
554 printf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS;
555 if ($fill > -1) {
556 my $elix;
557 foreach $elix (@ixes) {
558 print "av_push $elix\n";
559 }
560 } else {
561 if ($max > -1) {
562 print "av_extend $max\n";
563 }
564 }
565}
566
567sub B::CV::bytecode {
568 my $cv = shift;
569 return if saved($cv);
570 my $ix = $cv->objix;
571 $cv->B::PVMG::bytecode;
572 my $i;
b195d487 573 my @subfield_names = qw(ROOT START STASH GV PADLIST OUTSIDE);
a798dbf2
MB
574 my @subfields = map($cv->$_(), @subfield_names);
575 my @ixes = map($_->objix, @subfields);
576 # Save OP tree from CvROOT (first element of @subfields)
577 my $root = shift @subfields;
578 if ($$root) {
579 walkoptree($root, "bytecode");
580 }
581 # Reset sv register for $cv (since above ->objix calls stomped on it)
582 ldsv($ix);
583 for ($i = 0; $i < @ixes; $i++) {
584 printf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
585 }
fc290457 586 printf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->CvFLAGS;
57843af0 587 printf "newpv %s\nxcv_file\n", pvstring($cv->FILE);
a798dbf2
MB
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
597sub 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
626sub B::SPECIAL::bytecode {
627 # nothing extra needs doing
628}
629
630sub bytecompile_object {
631 my $sv;
632 foreach $sv (@_) {
633 svref_2object($sv)->bytecode;
634 }
635}
636
637sub 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
649sub 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);
595f3c5f 656 foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS strict vars
bc13eec9
GS
657 FileHandle Exporter Carp UNIVERSAL IO Fcntl Symbol warnings
658 attributes File::Spec SelectSaver blib Cwd))
a798dbf2
MB
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
675sub prepare_assemble {
676 my $newfh = IO::File->new_tmpfile;
677 select($newfh);
678 binmode $newfh;
679 return $newfh;
680}
681
682sub do_assemble {
683 my $fh = shift;
684 seek($fh, 0, 0); # rewind the temporary file
685 assemble_fh($fh, sub { print OUT @_ });
686}
687
688sub 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;
a07043ec
GS
710 } elsif ($opt eq "a") {
711 $arg ||= shift @options;
712 open(OUT, ">>$arg") or return "$arg: $!\n";
713 binmode OUT;
a798dbf2
MB
714 } elsif ($opt eq "D") {
715 $arg ||= shift @options;
716 foreach $arg (split(//, $arg)) {
717 if ($arg eq "b") {
718 $| = 1;
719 debug(1);
720 } elsif ($arg eq "o") {
721 B->debug(1);
722 } elsif ($arg eq "a") {
723 B::Assembler::debug(1);
724 } elsif ($arg eq "C") {
725 $debug_cv = 1;
726 }
727 }
728 } elsif ($opt eq "v") {
729 $verbose = 1;
730 } elsif ($opt eq "m") {
731 $module_only = 1;
732 } elsif ($opt eq "S") {
733 $no_assemble = 1;
734 } elsif ($opt eq "f") {
735 $arg ||= shift @options;
736 my $value = $arg !~ s/^no-//;
737 $arg =~ s/-/_/g;
738 my $ref = $optimise{$arg};
739 if (defined($ref)) {
740 $$ref = $value;
741 } else {
742 warn qq(ignoring unknown optimisation option "$arg"\n);
743 }
744 } elsif ($opt eq "O") {
745 $arg = 1 if $arg eq "";
746 my $ref;
747 foreach $ref (values %optimise) {
748 $$ref = 0;
749 }
750 if ($arg >= 6) {
751 $strip_syntree = 1;
752 }
753 if ($arg >= 2) {
754 $bypass_nullops = 1;
755 }
756 if ($arg >= 1) {
757 $compress_nullops = 1;
758 $omit_seq = 1;
759 }
760 }
761 }
762 if (@options) {
763 return sub {
764 my $objname;
765 my $newfh;
766 $newfh = prepare_assemble() unless $no_assemble;
767 foreach $objname (@options) {
768 eval "bytecompile_object(\\$objname)";
769 }
770 do_assemble($newfh) unless $no_assemble;
771 }
772 } else {
773 return sub {
774 my $newfh;
775 $newfh = prepare_assemble() unless $no_assemble;
776 bytecompile_main();
777 do_assemble($newfh) unless $no_assemble;
778 }
779 }
780}
781
7821;
7f20e9dd
GS
783
784__END__
785
786=head1 NAME
787
788B::Bytecode - Perl compiler's bytecode backend
789
790=head1 SYNOPSIS
791
1a52ab62 792 perl -MO=Bytecode[,OPTIONS] foo.pl
7f20e9dd
GS
793
794=head1 DESCRIPTION
795
1a52ab62
MB
796This compiler backend takes Perl source and generates a
797platform-independent bytecode encapsulating code to load the
798internal structures perl uses to run your program. When the
799generated bytecode is loaded in, your program is ready to run,
800reducing the time which perl would have taken to load and parse
801your program into its internal semi-compiled form. That means that
802compiling with this backend will not help improve the runtime
803execution speed of your program but may improve the start-up time.
804Depending on the environment in which your program runs this may
805or may not be a help.
806
807The resulting bytecode can be run with a special byteperl executable
808or (for non-main programs) be loaded via the C<byteload_fh> function
809in the F<B> module.
810
811=head1 OPTIONS
812
813If there are any non-option arguments, they are taken to be names of
814objects to be saved (probably doesn't work properly yet). Without
815extra arguments, it saves the main program.
816
817=over 4
818
819=item B<-ofilename>
820
821Output to filename instead of STDOUT.
822
a07043ec
GS
823=item B<-afilename>
824
825Append output to filename.
826
1a52ab62
MB
827=item B<-->
828
829Force end of options.
830
831=item B<-f>
832
833Force optimisations on or off one at a time. Each can be preceded
834by B<no-> to turn the option off (e.g. B<-fno-compress-nullops>).
835
836=item B<-fcompress-nullops>
837
838Only fills in the necessary fields of ops which have
839been optimised away by perl's internal compiler.
840
841=item B<-fomit-sequence-numbers>
842
843Leaves out code to fill in the op_seq field of all ops
844which is only used by perl's internal compiler.
845
846=item B<-fbypass-nullops>
847
848If op->op_next ever points to a NULLOP, replaces the op_next field
849with the first non-NULLOP in the path of execution.
850
851=item B<-fstrip-syntax-tree>
852
853Leaves out code to fill in the pointers which link the internal syntax
854tree together. They're not needed at run-time but leaving them out
855will make it impossible to recompile or disassemble the resulting
856program. It will also stop C<goto label> statements from working.
857
858=item B<-On>
859
860Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
861B<-O1> sets B<-fcompress-nullops> B<-fomit-sequence numbers>.
862B<-O6> adds B<-fstrip-syntax-tree>.
863
864=item B<-D>
865
866Debug options (concatenated or separate flags like C<perl -D>).
867
868=item B<-Do>
869
870Prints each OP as it's processed.
871
872=item B<-Db>
873
874Print debugging information about bytecompiler progress.
875
876=item B<-Da>
877
878Tells the (bytecode) assembler to include source assembler lines
879in its output as bytecode comments.
880
881=item B<-DC>
882
883Prints each CV taken from the final symbol tree walk.
884
885=item B<-S>
886
887Output (bytecode) assembler source rather than piping it
888through the assembler and outputting bytecode.
889
890=item B<-m>
891
892Compile as a module rather than a standalone program. Currently this
893just means that the bytecodes for initialising C<main_start>,
894C<main_root> and C<curpad> are omitted.
895
896=back
897
707102d0 898=head1 EXAMPLES
1a52ab62 899
e8edd1e6 900 perl -MO=Bytecode,-O6,-o,foo.plc foo.pl
1a52ab62 901
e8edd1e6
TH
902 perl -MO=Bytecode,-S foo.pl > foo.S
903 assemble foo.S > foo.plc
1a52ab62 904
e8edd1e6
TH
905Note that C<assemble> lives in the C<B> subdirectory of your perl
906library directory. The utility called perlcc may also be used to
907help make use of this compiler.
908
909 perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm
1a52ab62
MB
910
911=head1 BUGS
912
913Plenty. Current status: experimental.
7f20e9dd
GS
914
915=head1 AUTHOR
916
917Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
918
919=cut