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 $stashpv = $op->stashpv;
 282     my $file = $op->file;
 283     my $line = $op->line;
 284     my $warnings = $op->warnings;
 285     my $warningsix = $warnings->objix;
 286     if ($debug_bc) {
 287         printf "# line %s:%d\n", $file, $line;
 288     }
 289     $op->B::OP::bytecode;
 290     printf <<"EOT", pvstring($op->label), pvstring($stashpv), $op->cop_seq, pvstring($file), $op->arybase;
 291 newpv %s
 292 cop_label
 293 newpv %s
 294 cop_stashpv
 295 cop_seq %d
 296 newpv %s
 297 cop_file
 298 cop_arybase %d
 299 cop_line $line
 300 cop_warnings $warningsix
 301 EOT
 302     $stash->bytecode;
 303 }
 304
 305 sub B::PMOP::bytecode {
 306     my $op = shift;
 307     my $replroot = $op->pmreplroot;
 308     my $replrootix = $replroot->objix;
 309     my $replstartix = $op->pmreplstart->objix;
 310     my $opname = $op->name;
 311     # pmnext is corrupt in some PMOPs (see misc.t for example)
 312     #my $pmnextix = $op->pmnext->objix;
 313
 314     if ($$replroot) {
 315         # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
 316         # argument to a split) stores a GV in op_pmreplroot instead
 317         # of a substitution syntax tree. We don't want to walk that...
 318         if ($opname eq "pushre") {
 319             $replroot->bytecode;
 320         } else {
 321             walkoptree($replroot, "bytecode");
 322         }
 323     }
 324     $op->B::LISTOP::bytecode;
 325     if ($opname eq "pushre") {
 326         printf "op_pmreplrootgv $replrootix\n";
 327     } else {
 328         print "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n";
 329     }
 330     my $re = pvstring($op->precomp);
 331     # op_pmnext omitted since a perl bug means it's sometime corrupt
 332     printf <<"EOT", $op->pmflags, $op->pmpermflags;
 333 op_pmflags 0x%x
 334 op_pmpermflags 0x%x
 335 newpv $re
 336 pregcomp
 337 EOT
 338 }
 339
 340 sub B::SV::bytecode {
 341     my $sv = shift;
 342     return if saved($sv);
 343     my $ix = $sv->objix;
 344     my $refcnt = $sv->REFCNT;
 345     my $flags = sprintf("0x%x", $sv->FLAGS);
 346     ldsv($ix);
 347     print "sv_refcnt $refcnt\nsv_flags $flags\n";
 348     mark_saved($sv);
 349 }
 350
 351 sub B::PV::bytecode {
 352     my $sv = shift;
 353     return if saved($sv);
 354     $sv->B::SV::bytecode;
 355     printf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK;
 356 }
 357
 358 sub B::IV::bytecode {
 359     my $sv = shift;
 360     return if saved($sv);
 361     my $iv = $sv->IVX;
 362     $sv->B::SV::bytecode;
 363     printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32";
 364 }
 365
 366 sub B::NV::bytecode {
 367     my $sv = shift;
 368     return if saved($sv);
 369     $sv->B::SV::bytecode;
 370     printf "xnv %s\n", $sv->NVX;
 371 }
 372
 373 sub B::RV::bytecode {
 374     my $sv = shift;
 375     return if saved($sv);
 376     my $rv = $sv->RV;
 377     my $rvix = $rv->objix;
 378     $rv->bytecode;
 379     $sv->B::SV::bytecode;
 380     print "xrv $rvix\n";
 381 }
 382
 383 sub B::PVIV::bytecode {
 384     my $sv = shift;
 385     return if saved($sv);
 386     my $iv = $sv->IVX;
 387     $sv->B::PV::bytecode;
 388     printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32";
 389 }
 390
 391 sub B::PVNV::bytecode {
 392     my $sv = shift;
 393     my $flag = shift || 0;
 394     # The $flag argument is passed through PVMG::bytecode by BM::bytecode
 395     # and AV::bytecode and indicates special handling. $flag = 1 is used by
 396     # BM::bytecode and means that we should ensure we save the whole B-M
 397     # table. It consists of 257 bytes (256 char array plus a final \0)
 398     # which follow the ordinary PV+\0 and the 257 bytes are *not* reflected
 399     # in SvCUR. $flag = 2 is used by AV::bytecode and means that we only
 400     # call SV::bytecode instead of saving PV and calling NV::bytecode since
 401     # PV/NV/IV stuff is different for AVs.
 402     return if saved($sv);
 403     if ($flag == 2) {
 404         $sv->B::SV::bytecode;
 405     } else {
 406         my $pv = $sv->PV;
 407         $sv->B::IV::bytecode;
 408         printf "xnv %s\n", $sv->NVX;
 409         if ($flag == 1) {
 410             $pv .= "\0" . $sv->TABLE;
 411             printf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257;
 412         } else {
 413             printf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK;
 414         }
 415     }
 416 }
 417
 418 sub B::PVMG::bytecode {
 419     my ($sv, $flag) = @_;
 420     # See B::PVNV::bytecode for an explanation of $flag.
 421     return if saved($sv);
 422     # XXX We assume SvSTASH is already saved and don't save it later ourselves
 423     my $stashix = $sv->SvSTASH->objix;
 424     my @mgchain = $sv->MAGIC;
 425     my (@mgobjix, $mg);
 426     #
 427     # We need to traverse the magic chain and get objix for each OBJ
 428     # field *before* we do B::PVNV::bytecode since objix overwrites
 429     # the sv register. However, we need to write the magic-saving
 430     # bytecode *after* B::PVNV::bytecode since sv isn't initialised
 431     # to refer to $sv until then.
 432     #
 433     @mgobjix = map($_->OBJ->objix, @mgchain);
 434     $sv->B::PVNV::bytecode($flag);
 435     print "xmg_stash $stashix\n";
 436     foreach $mg (@mgchain) {
 437         printf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n",
 438             cstring($mg->TYPE), shift(@mgobjix), pvstring($mg->PTR);
 439     }
 440 }
 441
 442 sub B::PVLV::bytecode {
 443     my $sv = shift;
 444     return if saved($sv);
 445     $sv->B::PVMG::bytecode;
 446     printf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE);
 447 xlv_targoff %d
 448 xlv_targlen %d
 449 xlv_type %s
 450 EOT
 451 }
 452
 453 sub B::BM::bytecode {
 454     my $sv = shift;
 455     return if saved($sv);
 456     # See PVNV::bytecode for an explanation of what the argument does
 457     $sv->B::PVMG::bytecode(1);
 458     printf "xbm_useful %d\nxbm_previous %d\nxbm_rare %d\n",
 459         $sv->USEFUL, $sv->PREVIOUS, $sv->RARE;
 460 }
 461
 462 sub B::GV::bytecode {
 463     my $gv = shift;
 464     return if saved($gv);
 465     my $ix = $gv->objix;
 466     mark_saved($gv);
 467     my $gvname = $gv->NAME;
 468     my $name = cstring($gv->STASH->NAME . "::" . $gvname);
 469     my $egv = $gv->EGV;
 470     my $egvix = $egv->objix;
 471     ldsv($ix);
 472     printf <<"EOT", $gv->FLAGS, $gv->GvFLAGS, $gv->LINE, pvstring($gv->FILE);
 473 sv_flags 0x%x
 474 xgv_flags 0x%x
 475 gp_line %d
 476 newpv %s
 477 gp_file
 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;
 488             my @subfield_names = qw(SV AV HV CV FORM IO);
 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;
 571     my @subfield_names = qw(ROOT START STASH GV PADLIST OUTSIDE);
 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     printf "newpv %s\nxcv_file\n", pvstring($cv->FILE);
 586     # Now save all the subfields (except for CvROOT which was handled
 587     # above) and CvSTART (now the initial element of @subfields).
 588     shift @subfields; # bye-bye CvSTART
 589     my $sv;
 590     foreach $sv (@subfields) {
 591         $sv->bytecode;
 592     }
 593 }
 594
 595 sub B::IO::bytecode {
 596     my $io = shift;
 597     return if saved($io);
 598     my $ix = $io->objix;
 599     my $top_gv = $io->TOP_GV;
 600     my $top_gvix = $top_gv->objix;
 601     my $fmt_gv = $io->FMT_GV;
 602     my $fmt_gvix = $fmt_gv->objix;
 603     my $bottom_gv = $io->BOTTOM_GV;
 604     my $bottom_gvix = $bottom_gv->objix;
 605
 606     $io->B::PVMG::bytecode;
 607     ldsv($ix);
 608     print "xio_top_gv $top_gvix\n";
 609     print "xio_fmt_gv $fmt_gvix\n";
 610     print "xio_bottom_gv $bottom_gvix\n";
 611     my $field;
 612     foreach $field (qw(TOP_NAME FMT_NAME BOTTOM_NAME)) {
 613         printf "newpv %s\nxio_%s\n", pvstring($io->$field()), lc($field);
 614     }
 615     foreach $field (qw(LINES PAGE PAGE_LEN LINES_LEFT SUBPROCESS)) {
 616         printf "xio_%s %d\n", lc($field), $io->$field();
 617     }
 618     printf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS;
 619     $top_gv->bytecode;
 620     $fmt_gv->bytecode;
 621     $bottom_gv->bytecode;
 622 }
 623
 624 sub B::SPECIAL::bytecode {
 625     # nothing extra needs doing
 626 }
 627
 628 sub bytecompile_object {
 629     my $sv;
 630     foreach $sv (@_) {
 631         svref_2object($sv)->bytecode;
 632     }
 633 }
 634
 635 sub B::GV::bytecodecv {
 636     my $gv = shift;
 637     my $cv = $gv->CV;
 638     if ($$cv && !saved($cv)) {
 639         if ($debug_cv) {
 640             warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
 641                          $gv->STASH->NAME, $gv->NAME, $$cv, $$gv);
 642         }
 643         $gv->bytecode;
 644     }
 645 }
 646
 647 sub bytecompile_main {
 648     my $curpad = (comppadlist->ARRAY)[1];
 649     my $curpadix = $curpad->objix;
 650     $curpad->bytecode;
 651     walkoptree(main_root, "bytecode");
 652     warn "done main program, now walking symbol table\n" if $debug_bc;
 653     my ($pack, %exclude);
 654     foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS strict vars
 655                       FileHandle Exporter Carp UNIVERSAL IO Fcntl Symbol
 656                       SelectSaver blib Cwd))
 657     {
 658         $exclude{$pack."::"} = 1;
 659     }
 660     no strict qw(vars refs);
 661     walksymtable(\%{"main::"}, "bytecodecv", sub {
 662         warn "considering $_[0]\n" if $debug_bc;
 663         return !defined($exclude{$_[0]});
 664     });
 665     if (!$module_only) {
 666         printf "main_root %d\n", main_root->objix;
 667         printf "main_start %d\n", main_start->objix;
 668         printf "curpad $curpadix\n";
 669         # XXX Do min_intro_pending and max_intro_pending matter?
 670     }
 671 }
 672
 673 sub prepare_assemble {
 674     my $newfh = IO::File->new_tmpfile;
 675     select($newfh);
 676     binmode $newfh;
 677     return $newfh;
 678 }
 679
 680 sub do_assemble {
 681     my $fh = shift;
 682     seek($fh, 0, 0); # rewind the temporary file
 683     assemble_fh($fh, sub { print OUT @_ });
 684 }
 685
 686 sub compile {
 687     my @options = @_;
 688     my ($option, $opt, $arg);
 689     open(OUT, ">&STDOUT");
 690     binmode OUT;
 691     select(OUT);
 692   OPTION:
 693     while ($option = shift @options) {
 694         if ($option =~ /^-(.)(.*)/) {
 695             $opt = $1;
 696             $arg = $2;
 697         } else {
 698             unshift @options, $option;
 699             last OPTION;
 700         }
 701         if ($opt eq "-" && $arg eq "-") {
 702             shift @options;
 703             last OPTION;
 704         } elsif ($opt eq "o") {
 705             $arg ||= shift @options;
 706             open(OUT, ">$arg") or return "$arg: $!\n";
 707             binmode OUT;
 708         } elsif ($opt eq "a") {
 709             $arg ||= shift @options;
 710             open(OUT, ">>$arg") or return "$arg: $!\n";
 711             binmode OUT;
 712         } elsif ($opt eq "D") {
 713             $arg ||= shift @options;
 714             foreach $arg (split(//, $arg)) {
 715                 if ($arg eq "b") {
 716                     $| = 1;
 717                     debug(1);
 718                 } elsif ($arg eq "o") {
 719                     B->debug(1);
 720                 } elsif ($arg eq "a") {
 721                     B::Assembler::debug(1);
 722                 } elsif ($arg eq "C") {
 723                     $debug_cv = 1;
 724                 }
 725             }
 726         } elsif ($opt eq "v") {
 727             $verbose = 1;
 728         } elsif ($opt eq "m") {
 729             $module_only = 1;
 730         } elsif ($opt eq "S") {
 731             $no_assemble = 1;
 732         } elsif ($opt eq "f") {
 733             $arg ||= shift @options;
 734             my $value = $arg !~ s/^no-//;
 735             $arg =~ s/-/_/g;
 736             my $ref = $optimise{$arg};
 737             if (defined($ref)) {
 738                 $$ref = $value;
 739             } else {
 740                 warn qq(ignoring unknown optimisation option "$arg"\n);
 741             }
 742         } elsif ($opt eq "O") {
 743             $arg = 1 if $arg eq "";
 744             my $ref;
 745             foreach $ref (values %optimise) {
 746                 $$ref = 0;
 747             }
 748             if ($arg >= 6) {
 749                 $strip_syntree = 1;
 750             }
 751             if ($arg >= 2) {
 752                 $bypass_nullops = 1;
 753             }
 754             if ($arg >= 1) {
 755                 $compress_nullops = 1;
 756                 $omit_seq = 1;
 757             }
 758         }
 759     }
 760     if (@options) {
 761         return sub {
 762             my $objname;
 763             my $newfh;
 764             $newfh = prepare_assemble() unless $no_assemble;
 765             foreach $objname (@options) {
 766                 eval "bytecompile_object(\\$objname)";
 767             }
 768             do_assemble($newfh) unless $no_assemble;
 769         }
 770     } else {
 771         return sub {
 772             my $newfh;
 773             $newfh = prepare_assemble() unless $no_assemble;
 774             bytecompile_main();
 775             do_assemble($newfh) unless $no_assemble;
 776         }
 777     }
 778 }
 779
 780 1;
 781
 782 __END__
 783
 784 =head1 NAME
 785
 786 B::Bytecode - Perl compiler's bytecode backend
 787
 788 =head1 SYNOPSIS
 789
 790         perl -MO=Bytecode[,OPTIONS] foo.pl
 791
 792 =head1 DESCRIPTION
 793
 794 This compiler backend takes Perl source and generates a
 795 platform-independent bytecode encapsulating code to load the
 796 internal structures perl uses to run your program. When the
 797 generated bytecode is loaded in, your program is ready to run,
 798 reducing the time which perl would have taken to load and parse
 799 your program into its internal semi-compiled form. That means that
 800 compiling with this backend will not help improve the runtime
 801 execution speed of your program but may improve the start-up time.
 802 Depending on the environment in which your program runs this may
 803 or may not be a help.
 804
 805 The resulting bytecode can be run with a special byteperl executable
 806 or (for non-main programs) be loaded via the C<byteload_fh> function
 807 in the F<B> module.
 808
 809 =head1 OPTIONS
 810
 811 If there are any non-option arguments, they are taken to be names of
 812 objects to be saved (probably doesn't work properly yet).  Without
 813 extra arguments, it saves the main program.
 814
 815 =over 4
 816
 817 =item B<-ofilename>
 818
 819 Output to filename instead of STDOUT.
 820
 821 =item B<-afilename>
 822
 823 Append output to filename.
 824
 825 =item B<-->
 826
 827 Force end of options.
 828
 829 =item B<-f>
 830
 831 Force optimisations on or off one at a time. Each can be preceded
 832 by B<no-> to turn the option off (e.g. B<-fno-compress-nullops>).
 833
 834 =item B<-fcompress-nullops>
 835
 836 Only fills in the necessary fields of ops which have
 837 been optimised away by perl's internal compiler.
 838
 839 =item B<-fomit-sequence-numbers>
 840
 841 Leaves out code to fill in the op_seq field of all ops
 842 which is only used by perl's internal compiler.
 843
 844 =item B<-fbypass-nullops>
 845
 846 If op->op_next ever points to a NULLOP, replaces the op_next field
 847 with the first non-NULLOP in the path of execution.
 848
 849 =item B<-fstrip-syntax-tree>
 850
 851 Leaves out code to fill in the pointers which link the internal syntax
 852 tree together. They're not needed at run-time but leaving them out
 853 will make it impossible to recompile or disassemble the resulting
 854 program.  It will also stop C<goto label> statements from working.
 855
 856 =item B<-On>
 857
 858 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
 859 B<-O1> sets B<-fcompress-nullops> B<-fomit-sequence numbers>.
 860 B<-O6> adds B<-fstrip-syntax-tree>.
 861
 862 =item B<-D>
 863
 864 Debug options (concatenated or separate flags like C<perl -D>).
 865
 866 =item B<-Do>
 867
 868 Prints each OP as it's processed.
 869
 870 =item B<-Db>
 871
 872 Print debugging information about bytecompiler progress.
 873
 874 =item B<-Da>
 875
 876 Tells the (bytecode) assembler to include source assembler lines
 877 in its output as bytecode comments.
 878
 879 =item B<-DC>
 880
 881 Prints each CV taken from the final symbol tree walk.
 882
 883 =item B<-S>
 884
 885 Output (bytecode) assembler source rather than piping it
 886 through the assembler and outputting bytecode.
 887
 888 =item B<-m>
 889
 890 Compile as a module rather than a standalone program. Currently this
 891 just means that the bytecodes for initialising C<main_start>,
 892 C<main_root> and C<curpad> are omitted.
 893
 894 =back
 895
 896 =head1 EXAMPLES
 897
 898     perl -MO=Bytecode,-O6,-o,foo.plc foo.pl
 899
 900     perl -MO=Bytecode,-S foo.pl > foo.S
 901     assemble foo.S > foo.plc
 902
 903 Note that C<assemble> lives in the C<B> subdirectory of your perl
 904 library directory. The utility called perlcc may also be used to
 905 help make use of this compiler.
 906
 907     perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm
 908
 909 =head1 BUGS
 910
 911 Plenty. Current status: experimental.
 912
 913 =head1 AUTHOR
 914
 915 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 916
 917 =cut