This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
usurp GVOP slot for new PADOP (one small step to making optree
[perl5.git] / ext / B / B / Bytecode.pm
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          SVf_POK SVp_POK SVf_IOK SVp_IOK
16         );
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
28 sub POK () { SVf_POK|SVp_POK }
29
30 # Following is SVf_IOK|SVp_IOK
31 # XXX Shouldn't be hardwired
32 sub IOK () { SVf_IOK|SVp_IOK }
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;
196     printf "op_type %s\t# %d\n", "pp_" . $op->name, $type;
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
229 sub B::PADOP::bytecode {
230     my $op = shift;
231     my $padix = $op->padix;
232     $op->B::OP::bytecode;
233     print "op_padix $padix\n";
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->name eq "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::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;
286     my $warnings = $op->warnings;
287     my $warningsix = $warnings->objix;
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
300 cop_warnings $warningsix
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;
311     my $opname = $op->name;
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...
319         if ($opname eq "pushre") {
320             $replroot->bytecode;
321         } else {
322             walkoptree($replroot, "bytecode");
323         }
324     }
325     $op->B::LISTOP::bytecode;
326     if ($opname eq "pushre") {
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 {
393     my $sv = shift;
394     my $flag = shift || 0;
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);
473     printf <<"EOT", $gv->FLAGS, $gv->GvFLAGS, $gv->LINE;
474 sv_flags 0x%x
475 xgv_flags 0x%x
476 gp_line %d
477 EOT
478     my $refcnt = $gv->REFCNT;
479     printf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1;
480     my $gvrefcnt = $gv->GvREFCNT;
481     printf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1;
482     if ($gvrefcnt > 1 &&  $ix != $egvix) {
483         print "gp_share $egvix\n";
484     } else {
485         if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
486             my $i;
487             my @subfield_names = qw(SV AV HV CV FILEGV FORM IO);
488             my @subfields = map($gv->$_(), @subfield_names);
489             my @ixes = map($_->objix, @subfields);
490             # Reset sv register for $gv
491             ldsv($ix);
492             for ($i = 0; $i < @ixes; $i++) {
493                 printf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
494             }
495             # Now save all the subfields
496             my $sv;
497             foreach $sv (@subfields) {
498                 $sv->bytecode;
499             }
500         }
501     }
502 }
503
504 sub B::HV::bytecode {
505     my $hv = shift;
506     return if saved($hv);
507     mark_saved($hv);
508     my $name = $hv->NAME;
509     my $ix = $hv->objix;
510     if (!$name) {
511         # It's an ordinary HV. Stashes have NAME set and need no further
512         # saving beyond the gv_stashpv that $hv->objix already ensures.
513         my @contents = $hv->ARRAY;
514         my ($i, @ixes);
515         for ($i = 1; $i < @contents; $i += 2) {
516             push(@ixes, $contents[$i]->objix);
517         }
518         for ($i = 1; $i < @contents; $i += 2) {
519             $contents[$i]->bytecode;
520         }
521         ldsv($ix);
522         for ($i = 0; $i < @contents; $i += 2) {
523             printf("newpv %s\nhv_store %d\n",
524                    pvstring($contents[$i]), $ixes[$i / 2]);
525         }
526         printf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS;
527     }
528 }
529
530 sub B::AV::bytecode {
531     my $av = shift;
532     return if saved($av);
533     my $ix = $av->objix;
534     my $fill = $av->FILL;
535     my $max = $av->MAX;
536     my (@array, @ixes);
537     if ($fill > -1) {
538         @array = $av->ARRAY;
539         @ixes = map($_->objix, @array);
540         my $sv;
541         foreach $sv (@array) {
542             $sv->bytecode;
543         }
544     }
545     # See PVNV::bytecode for the meaning of the flag argument of 2.
546     $av->B::PVMG::bytecode(2);
547     # Recover sv register and set AvMAX and AvFILL to -1 (since we
548     # create an AV with NEWSV and SvUPGRADE rather than doing newAV
549     # which is what sets AvMAX and AvFILL.
550     ldsv($ix);
551     printf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS;
552     if ($fill > -1) {
553         my $elix;
554         foreach $elix (@ixes) {
555             print "av_push $elix\n";
556         }
557     } else {
558         if ($max > -1) {
559             print "av_extend $max\n";
560         }
561     }
562 }
563
564 sub B::CV::bytecode {
565     my $cv = shift;
566     return if saved($cv);
567     my $ix = $cv->objix;
568     $cv->B::PVMG::bytecode;
569     my $i;
570     my @subfield_names = qw(ROOT START STASH GV FILEGV PADLIST OUTSIDE);
571     my @subfields = map($cv->$_(), @subfield_names);
572     my @ixes = map($_->objix, @subfields);
573     # Save OP tree from CvROOT (first element of @subfields)
574     my $root = shift @subfields;
575     if ($$root) {
576         walkoptree($root, "bytecode");
577     }
578     # Reset sv register for $cv (since above ->objix calls stomped on it)
579     ldsv($ix);
580     for ($i = 0; $i < @ixes; $i++) {
581         printf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
582     }
583     printf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->FLAGS;
584     # Now save all the subfields (except for CvROOT which was handled
585     # above) and CvSTART (now the initial element of @subfields).
586     shift @subfields; # bye-bye CvSTART
587     my $sv;
588     foreach $sv (@subfields) {
589         $sv->bytecode;
590     }
591 }
592
593 sub B::IO::bytecode {
594     my $io = shift;
595     return if saved($io);
596     my $ix = $io->objix;
597     my $top_gv = $io->TOP_GV;
598     my $top_gvix = $top_gv->objix;
599     my $fmt_gv = $io->FMT_GV;
600     my $fmt_gvix = $fmt_gv->objix;
601     my $bottom_gv = $io->BOTTOM_GV;
602     my $bottom_gvix = $bottom_gv->objix;
603
604     $io->B::PVMG::bytecode;
605     ldsv($ix);
606     print "xio_top_gv $top_gvix\n";
607     print "xio_fmt_gv $fmt_gvix\n";
608     print "xio_bottom_gv $bottom_gvix\n";
609     my $field;
610     foreach $field (qw(TOP_NAME FMT_NAME BOTTOM_NAME)) {
611         printf "newpv %s\nxio_%s\n", pvstring($io->$field()), lc($field);
612     }
613     foreach $field (qw(LINES PAGE PAGE_LEN LINES_LEFT SUBPROCESS)) {
614         printf "xio_%s %d\n", lc($field), $io->$field();
615     }
616     printf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS;
617     $top_gv->bytecode;
618     $fmt_gv->bytecode;
619     $bottom_gv->bytecode;
620 }
621
622 sub B::SPECIAL::bytecode {
623     # nothing extra needs doing
624 }
625
626 sub bytecompile_object {
627     my $sv;
628     foreach $sv (@_) {
629         svref_2object($sv)->bytecode;
630     }
631 }
632
633 sub B::GV::bytecodecv {
634     my $gv = shift;
635     my $cv = $gv->CV;
636     if ($$cv && !saved($cv)) {
637         if ($debug_cv) {
638             warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
639                          $gv->STASH->NAME, $gv->NAME, $$cv, $$gv);
640         }
641         $gv->bytecode;
642     }
643 }
644
645 sub bytecompile_main {
646     my $curpad = (comppadlist->ARRAY)[1];
647     my $curpadix = $curpad->objix;
648     $curpad->bytecode;
649     walkoptree(main_root, "bytecode");
650     warn "done main program, now walking symbol table\n" if $debug_bc;
651     my ($pack, %exclude);
652     foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS strict vars
653                       FileHandle Exporter Carp UNIVERSAL IO Fcntl Symbol
654                       SelectSaver blib Cwd))
655     {
656         $exclude{$pack."::"} = 1;
657     }
658     no strict qw(vars refs);
659     walksymtable(\%{"main::"}, "bytecodecv", sub {
660         warn "considering $_[0]\n" if $debug_bc;
661         return !defined($exclude{$_[0]});
662     });
663     if (!$module_only) {
664         printf "main_root %d\n", main_root->objix;
665         printf "main_start %d\n", main_start->objix;
666         printf "curpad $curpadix\n";
667         # XXX Do min_intro_pending and max_intro_pending matter?
668     }
669 }
670
671 sub prepare_assemble {
672     my $newfh = IO::File->new_tmpfile;
673     select($newfh);
674     binmode $newfh;
675     return $newfh;
676 }
677
678 sub do_assemble {
679     my $fh = shift;
680     seek($fh, 0, 0); # rewind the temporary file
681     assemble_fh($fh, sub { print OUT @_ });
682 }
683
684 sub compile {
685     my @options = @_;
686     my ($option, $opt, $arg);
687     open(OUT, ">&STDOUT");
688     binmode OUT;
689     select(OUT);
690   OPTION:
691     while ($option = shift @options) {
692         if ($option =~ /^-(.)(.*)/) {
693             $opt = $1;
694             $arg = $2;
695         } else {
696             unshift @options, $option;
697             last OPTION;
698         }
699         if ($opt eq "-" && $arg eq "-") {
700             shift @options;
701             last OPTION;
702         } elsif ($opt eq "o") {
703             $arg ||= shift @options;
704             open(OUT, ">$arg") or return "$arg: $!\n";
705             binmode OUT;
706         } elsif ($opt eq "D") {
707             $arg ||= shift @options;
708             foreach $arg (split(//, $arg)) {
709                 if ($arg eq "b") {
710                     $| = 1;
711                     debug(1);
712                 } elsif ($arg eq "o") {
713                     B->debug(1);
714                 } elsif ($arg eq "a") {
715                     B::Assembler::debug(1);
716                 } elsif ($arg eq "C") {
717                     $debug_cv = 1;
718                 }
719             }
720         } elsif ($opt eq "v") {
721             $verbose = 1;
722         } elsif ($opt eq "m") {
723             $module_only = 1;
724         } elsif ($opt eq "S") {
725             $no_assemble = 1;
726         } elsif ($opt eq "f") {
727             $arg ||= shift @options;
728             my $value = $arg !~ s/^no-//;
729             $arg =~ s/-/_/g;
730             my $ref = $optimise{$arg};
731             if (defined($ref)) {
732                 $$ref = $value;
733             } else {
734                 warn qq(ignoring unknown optimisation option "$arg"\n);
735             }
736         } elsif ($opt eq "O") {
737             $arg = 1 if $arg eq "";
738             my $ref;
739             foreach $ref (values %optimise) {
740                 $$ref = 0;
741             }
742             if ($arg >= 6) {
743                 $strip_syntree = 1;
744             }
745             if ($arg >= 2) {
746                 $bypass_nullops = 1;
747             }
748             if ($arg >= 1) {
749                 $compress_nullops = 1;
750                 $omit_seq = 1;
751             }
752         }
753     }
754     if (@options) {
755         return sub {
756             my $objname;
757             my $newfh; 
758             $newfh = prepare_assemble() unless $no_assemble;
759             foreach $objname (@options) {
760                 eval "bytecompile_object(\\$objname)";
761             }
762             do_assemble($newfh) unless $no_assemble;
763         }
764     } else {
765         return sub {
766             my $newfh; 
767             $newfh = prepare_assemble() unless $no_assemble;
768             bytecompile_main();
769             do_assemble($newfh) unless $no_assemble;
770         }
771     }
772 }
773
774 1;
775
776 __END__
777
778 =head1 NAME
779
780 B::Bytecode - Perl compiler's bytecode backend
781
782 =head1 SYNOPSIS
783
784         perl -MO=Bytecode[,OPTIONS] foo.pl
785
786 =head1 DESCRIPTION
787
788 This compiler backend takes Perl source and generates a
789 platform-independent bytecode encapsulating code to load the
790 internal structures perl uses to run your program. When the
791 generated bytecode is loaded in, your program is ready to run,
792 reducing the time which perl would have taken to load and parse
793 your program into its internal semi-compiled form. That means that
794 compiling with this backend will not help improve the runtime
795 execution speed of your program but may improve the start-up time.
796 Depending on the environment in which your program runs this may
797 or may not be a help.
798
799 The resulting bytecode can be run with a special byteperl executable
800 or (for non-main programs) be loaded via the C<byteload_fh> function
801 in the F<B> module.
802
803 =head1 OPTIONS
804
805 If there are any non-option arguments, they are taken to be names of
806 objects to be saved (probably doesn't work properly yet).  Without
807 extra arguments, it saves the main program.
808
809 =over 4
810
811 =item B<-ofilename>
812
813 Output to filename instead of STDOUT.
814
815 =item B<-->
816
817 Force end of options.
818
819 =item B<-f>
820
821 Force optimisations on or off one at a time. Each can be preceded
822 by B<no-> to turn the option off (e.g. B<-fno-compress-nullops>).
823
824 =item B<-fcompress-nullops>
825
826 Only fills in the necessary fields of ops which have
827 been optimised away by perl's internal compiler.
828
829 =item B<-fomit-sequence-numbers>
830
831 Leaves out code to fill in the op_seq field of all ops
832 which is only used by perl's internal compiler.
833
834 =item B<-fbypass-nullops>
835
836 If op->op_next ever points to a NULLOP, replaces the op_next field
837 with the first non-NULLOP in the path of execution.
838
839 =item B<-fstrip-syntax-tree>
840
841 Leaves out code to fill in the pointers which link the internal syntax
842 tree together. They're not needed at run-time but leaving them out
843 will make it impossible to recompile or disassemble the resulting
844 program.  It will also stop C<goto label> statements from working.
845
846 =item B<-On>
847
848 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
849 B<-O1> sets B<-fcompress-nullops> B<-fomit-sequence numbers>.
850 B<-O6> adds B<-fstrip-syntax-tree>.
851
852 =item B<-D>
853
854 Debug options (concatenated or separate flags like C<perl -D>).
855
856 =item B<-Do>
857
858 Prints each OP as it's processed.
859
860 =item B<-Db>
861
862 Print debugging information about bytecompiler progress.
863
864 =item B<-Da>
865
866 Tells the (bytecode) assembler to include source assembler lines
867 in its output as bytecode comments.
868
869 =item B<-DC>
870
871 Prints each CV taken from the final symbol tree walk.
872
873 =item B<-S>
874
875 Output (bytecode) assembler source rather than piping it
876 through the assembler and outputting bytecode.
877
878 =item B<-m>
879
880 Compile as a module rather than a standalone program. Currently this
881 just means that the bytecodes for initialising C<main_start>,
882 C<main_root> and C<curpad> are omitted.
883
884 =back
885
886 =head1 EXAMPLES
887
888     perl -MO=Bytecode,-O6,-o,foo.plc foo.pl
889
890     perl -MO=Bytecode,-S foo.pl > foo.S
891     assemble foo.S > foo.plc
892
893 Note that C<assemble> lives in the C<B> subdirectory of your perl
894 library directory. The utility called perlcc may also be used to 
895 help make use of this compiler.
896
897     perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm
898
899 =head1 BUGS
900
901 Plenty. Current status: experimental.
902
903 =head1 AUTHOR
904
905 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
906
907 =cut