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 }
 303
 304 sub B::PMOP::bytecode {
 305     my $op = shift;
 306     my $replroot = $op->pmreplroot;
 307     my $replrootix = $replroot->objix;
 308     my $replstartix = $op->pmreplstart->objix;
 309     my $opname = $op->name;
 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...
 317         if ($opname eq "pushre") {
 318             $replroot->bytecode;
 319         } else {
 320             walkoptree($replroot, "bytecode");
 321         }
 322     }
 323     $op->B::LISTOP::bytecode;
 324     if ($opname eq "pushre") {
 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;
 332 op_pmflags 0x%x
 333 op_pmpermflags 0x%x
 334 newpv $re
 335 pregcomp
 336 EOT
 337 }
 338
 339 sub 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
 350 sub 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
 357 sub 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
 365 sub 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
 372 sub 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
 382 sub 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
 390 sub B::PVNV::bytecode {
 391     my $sv = shift;
 392     my $flag = shift || 0;
 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
 417 sub 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
 441 sub 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);
 446 xlv_targoff %d
 447 xlv_targlen %d
 448 xlv_type %s
 449 EOT
 450 }
 451
 452 sub 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
 461 sub B::GV::bytecode {
 462     my $gv = shift;
 463     return if saved($gv);
 464     my $ix = $gv->objix;
 465     mark_saved($gv);
 466     my $gvname = $gv->NAME;
 467     my $name = cstring($gv->STASH->NAME . "::" . $gvname);
 468     my $egv = $gv->EGV;
 469     my $egvix = $egv->objix;
 470     ldsv($ix);
 471     printf <<"EOT", $gv->FLAGS, $gv->GvFLAGS, $gv->LINE, pvstring($gv->FILE);
 472 sv_flags 0x%x
 473 xgv_flags 0x%x
 474 gp_line %d
 475 newpv %s
 476 gp_file
 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 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 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     printf "newpv %s\nxcv_file\n", pvstring($cv->FILE);
 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 "a") {
 708             $arg ||= shift @options;
 709             open(OUT, ">>$arg") or return "$arg: $!\n";
 710             binmode OUT;
 711         } elsif ($opt eq "D") {
 712             $arg ||= shift @options;
 713             foreach $arg (split(//, $arg)) {
 714                 if ($arg eq "b") {
 715                     $| = 1;
 716                     debug(1);
 717                 } elsif ($arg eq "o") {
 718                     B->debug(1);
 719                 } elsif ($arg eq "a") {
 720                     B::Assembler::debug(1);
 721                 } elsif ($arg eq "C") {
 722                     $debug_cv = 1;
 723                 }
 724             }
 725         } elsif ($opt eq "v") {
 726             $verbose = 1;
 727         } elsif ($opt eq "m") {
 728             $module_only = 1;
 729         } elsif ($opt eq "S") {
 730             $no_assemble = 1;
 731         } elsif ($opt eq "f") {
 732             $arg ||= shift @options;
 733             my $value = $arg !~ s/^no-//;
 734             $arg =~ s/-/_/g;
 735             my $ref = $optimise{$arg};
 736             if (defined($ref)) {
 737                 $$ref = $value;
 738             } else {
 739                 warn qq(ignoring unknown optimisation option "$arg"\n);
 740             }
 741         } elsif ($opt eq "O") {
 742             $arg = 1 if $arg eq "";
 743             my $ref;
 744             foreach $ref (values %optimise) {
 745                 $$ref = 0;
 746             }
 747             if ($arg >= 6) {
 748                 $strip_syntree = 1;
 749             }
 750             if ($arg >= 2) {
 751                 $bypass_nullops = 1;
 752             }
 753             if ($arg >= 1) {
 754                 $compress_nullops = 1;
 755                 $omit_seq = 1;
 756             }
 757         }
 758     }
 759     if (@options) {
 760         return sub {
 761             my $objname;
 762             my $newfh;
 763             $newfh = prepare_assemble() unless $no_assemble;
 764             foreach $objname (@options) {
 765                 eval "bytecompile_object(\\$objname)";
 766             }
 767             do_assemble($newfh) unless $no_assemble;
 768         }
 769     } else {
 770         return sub {
 771             my $newfh;
 772             $newfh = prepare_assemble() unless $no_assemble;
 773             bytecompile_main();
 774             do_assemble($newfh) unless $no_assemble;
 775         }
 776     }
 777 }
 778
 779 1;
 780
 781 __END__
 782
 783 =head1 NAME
 784
 785 B::Bytecode - Perl compiler's bytecode backend
 786
 787 =head1 SYNOPSIS
 788
 789         perl -MO=Bytecode[,OPTIONS] foo.pl
 790
 791 =head1 DESCRIPTION
 792
 793 This compiler backend takes Perl source and generates a
 794 platform-independent bytecode encapsulating code to load the
 795 internal structures perl uses to run your program. When the
 796 generated bytecode is loaded in, your program is ready to run,
 797 reducing the time which perl would have taken to load and parse
 798 your program into its internal semi-compiled form. That means that
 799 compiling with this backend will not help improve the runtime
 800 execution speed of your program but may improve the start-up time.
 801 Depending on the environment in which your program runs this may
 802 or may not be a help.
 803
 804 The resulting bytecode can be run with a special byteperl executable
 805 or (for non-main programs) be loaded via the C<byteload_fh> function
 806 in the F<B> module.
 807
 808 =head1 OPTIONS
 809
 810 If there are any non-option arguments, they are taken to be names of
 811 objects to be saved (probably doesn't work properly yet).  Without
 812 extra arguments, it saves the main program.
 813
 814 =over 4
 815
 816 =item B<-ofilename>
 817
 818 Output to filename instead of STDOUT.
 819
 820 =item B<-afilename>
 821
 822 Append output to filename.
 823
 824 =item B<-->
 825
 826 Force end of options.
 827
 828 =item B<-f>
 829
 830 Force optimisations on or off one at a time. Each can be preceded
 831 by B<no-> to turn the option off (e.g. B<-fno-compress-nullops>).
 832
 833 =item B<-fcompress-nullops>
 834
 835 Only fills in the necessary fields of ops which have
 836 been optimised away by perl's internal compiler.
 837
 838 =item B<-fomit-sequence-numbers>
 839
 840 Leaves out code to fill in the op_seq field of all ops
 841 which is only used by perl's internal compiler.
 842
 843 =item B<-fbypass-nullops>
 844
 845 If op->op_next ever points to a NULLOP, replaces the op_next field
 846 with the first non-NULLOP in the path of execution.
 847
 848 =item B<-fstrip-syntax-tree>
 849
 850 Leaves out code to fill in the pointers which link the internal syntax
 851 tree together. They're not needed at run-time but leaving them out
 852 will make it impossible to recompile or disassemble the resulting
 853 program.  It will also stop C<goto label> statements from working.
 854
 855 =item B<-On>
 856
 857 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
 858 B<-O1> sets B<-fcompress-nullops> B<-fomit-sequence numbers>.
 859 B<-O6> adds B<-fstrip-syntax-tree>.
 860
 861 =item B<-D>
 862
 863 Debug options (concatenated or separate flags like C<perl -D>).
 864
 865 =item B<-Do>
 866
 867 Prints each OP as it's processed.
 868
 869 =item B<-Db>
 870
 871 Print debugging information about bytecompiler progress.
 872
 873 =item B<-Da>
 874
 875 Tells the (bytecode) assembler to include source assembler lines
 876 in its output as bytecode comments.
 877
 878 =item B<-DC>
 879
 880 Prints each CV taken from the final symbol tree walk.
 881
 882 =item B<-S>
 883
 884 Output (bytecode) assembler source rather than piping it
 885 through the assembler and outputting bytecode.
 886
 887 =item B<-m>
 888
 889 Compile as a module rather than a standalone program. Currently this
 890 just means that the bytecodes for initialising C<main_start>,
 891 C<main_root> and C<curpad> are omitted.
 892
 893 =back
 894
 895 =head1 EXAMPLES
 896
 897     perl -MO=Bytecode,-O6,-o,foo.plc foo.pl
 898
 899     perl -MO=Bytecode,-S foo.pl > foo.S
 900     assemble foo.S > foo.plc
 901
 902 Note that C<assemble> lives in the C<B> subdirectory of your perl
 903 library directory. The utility called perlcc may also be used to
 904 help make use of this compiler.
 905
 906     perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm
 907
 908 =head1 BUGS
 909
 910 Plenty. Current status: experimental.
 911
 912 =head1 AUTHOR
 913
 914 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 915
 916 =cut