perl-compiler/lib/B/Bytecode.pm

# B::Bytecode.pm - The bytecode compiler (.plc), loaded by ByteLoader
#
# Copyright (c) 1994-1999 Malcolm Beattie. All rights reserved.
# Copyright (c) 2003 Enache Adrian. All rights reserved.
# Copyright (c) 2008-2011 Reini Urban <rurban@cpan.org>. All rights reserved.
# Copyright (c) 2011-2013 cPanel Inc. All rights reserved.
# This module is free software; you can redistribute and/or modify
# it under the same terms as Perl itself.

# Reviving 5.6 support here is work in progress, and not yet enabled.
# So far the original is used instead, even if the list of failed tests
# is impressive: 3,6,8..10,12,15,16,18,25..28. Pretty broken.

package B::Bytecode;

our $VERSION = '1.14';

use 5.008;
use B qw( class main_cv main_root main_start
	  begin_av init_av end_av cstring comppadlist
	  OPf_SPECIAL OPf_STACKED OPf_MOD
	  OPpLVAL_INTRO SVf_READONLY SVf_ROK );
use B::Assembler qw(asm newasm endasm);

BEGIN {
  if ( $] < 5.009 ) {
    require B::Asmdata;
    B::Asmdata->import(qw(@specialsv_name @optype));
    eval q[
      sub SVp_NOK() {}; # unused
      sub SVf_NOK() {}; # unused
     ];
  }
  else {
    B->import(qw(SVp_NOK SVf_NOK @specialsv_name @optype));
  }
  if ( $] > 5.007 ) {
    B->import(qw(defstash curstash inc_gv dowarn
		 warnhook diehook SVt_PVGV
		 SVf_FAKE));
  } else {
    B->import(qw(walkoptree walksymtable));
  }
  if ($] > 5.017) {
    B->import('SVf_IsCOW') ;
  } else {
    eval q[
      sub SVf_IsCOW() {}; # unused
     ];
  }
  if ( $] >= 5.017005 ) {
    @B::PAD::ISA = ('B::AV');
  }
}
use strict;
use Config;
use B::Concise;

#################################################

my $PERL56  = ( $] <  5.008001 );
my $PERL510 = ( $] >= 5.009005 );
my $PERL512 = ( $] >= 5.011 );
#my $PERL514 = ( $] >= 5.013002 );
my $PERL518 = ( $] >= 5.017006 );
my $PERL520 = ( $] >= 5.019002 );
my $DEBUGGING = ($Config{ccflags} =~ m/-DDEBUGGING/);
our ($quiet, $includeall, $savebegins, $T_inhinc);
my ( $varix, $opix, %debug, %walked, %files, @cloop );
my %strtab  = ( 0, 0 );
my %svtab   = ( 0, 0 );
my %optab   = ( 0, 0 );
my %spectab = $PERL56 ? () : ( 0, 0 ); # we need the special Nullsv on 5.6 (?)
my $tix     = $PERL56 ? 0 : 1;
my %ops     = ( 0, 0 );
my @packages;    # list of packages to compile. 5.6 only

# sub asm ($;$$) { }
sub nice ($) { }
sub nice1 ($) { }

my %optype_enum;
my ($SVt_PVGV, $SVf_FAKE, $POK);
if ($PERL56) {
  sub dowarn {};
  $SVt_PVGV = 13;
  $SVf_FAKE = 0x00100000;
  $POK = 0x00040000 | 0x04000000;
  sub MAGICAL56 { $_[0]->FLAGS & 0x000E000 } #(SVs_GMG|SVs_SMG|SVs_RMG)
} else {
  no strict 'subs';
  $SVt_PVGV = SVt_PVGV;
  $SVf_FAKE = SVf_FAKE;
}

{ # block necessary for caller to work
  my $caller = caller;
  if ( $] > 5.017 and $] < 5.019004 and ($caller eq 'O' or $caller eq 'Od' )) {
    require XSLoader;
    XSLoader::load('B::C'); # for op->slabbed... workarounds
  }
}

for ( my $i = 0 ; $i < @optype ; $i++ ) {
  $optype_enum{ $optype[$i] } = $i;
}

BEGIN {
  my $ithreads = $Config::Config{'useithreads'} eq 'define';
  eval qq{
	sub ITHREADS() { $ithreads }
	sub VERSION() { $] }
    };
  die $@ if $@;
}

sub as_hex {$quiet ? undef : sprintf("0x%x",shift)}

#################################################

# This is for -S commented assembler output
sub op_flags {
  return '' if $quiet;
  # B::Concise::op_flags($_[0]); # too terse
  # common flags (see BASOP.op_flags in op.h)
  my ($x) = @_;
  my (@v);
  push @v, "WANT_VOID"   if ( $x & 3 ) == 1;
  push @v, "WANT_SCALAR" if ( $x & 3 ) == 2;
  push @v, "WANT_LIST"   if ( $x & 3 ) == 3;
  push @v, "KIDS"        if $x & 4;
  push @v, "PARENS"      if $x & 8;
  push @v, "REF"         if $x & 16;
  push @v, "MOD"         if $x & 32;
  push @v, "STACKED"     if $x & 64;
  push @v, "SPECIAL"     if $x & 128;
  return join( ",", @v );
}

# This is also for -S commented assembler output
sub sv_flags {
  return '' if $quiet or $B::Concise::VERSION < 0.74;    # or ($] == 5.010);
  return '' unless $debug{Comment};
  return 'B::SPECIAL' if $_[0]->isa('B::SPECIAL');
  return 'B::PADLIST' if $_[0]->isa('B::PADLIST');
  return 'B::NULL'    if $_[0]->isa('B::NULL');
  my ($sv) = @_;
  my %h;

  # TODO: Check with which Concise and B versions this works. 5.10.0 fails.
  # B::Concise 0.66 fails also
  sub B::Concise::fmt_line { return shift; }
  my $op = $ops{ $tix - 1 };
  if (ref $op and !$op->targ) { # targ assumes a valid curcv
    %h = B::Concise::concise_op( $op );
  }
  B::Concise::concise_sv( $_[0], \%h, 0 );
}

sub pvstring {
  my $pv = shift;
  defined($pv) ? cstring( $pv . "\0" ) : "\"\"";
}

sub pvix {
  my $str = pvstring shift;
  my $ix  = $strtab{$str};
  defined($ix) ? $ix : do {
    nice1 "-PV- $tix";
    B::Assembler::maxsvix($tix) if $debug{A};
    asm "newpv", $str;
    asm "stpv", $strtab{$str} = $tix;
    $tix++;
  }
}

sub B::OP::ix {
  my $op = shift;
  my $ix = $optab{$$op};
  defined($ix) ? $ix : do {
    nice "[" . $op->name . " $tix]";
    $ops{$tix} = $op;
    # Note: This left-shift 7 encoding of the optype has nothing to do with OCSHIFT
    # in opcode.pl
    # The counterpart is hardcoded in Byteloader/bytecode.h: BSET_newopx
    my $arg = $PERL56 ? $optype_enum{class($op)} : $op->size | $op->type << 7;
    my $opsize = $PERL56 ? '?' : $op->size;
    if (ref($op) eq 'B::OP') { # check wrong BASEOPs
      # [perl #80622] Introducing the entrytry hack, needed since 5.12,
      # fixed with 5.13.8 a425677
      #   ck_eval upgrades the UNOP entertry to a LOGOP, but B gets us just a
      #   B::OP (BASEOP).
      #   op->other points to the leavetry op, which is needed for the eval scope.
      if ($op->name eq 'entertry') {
	$opsize = $op->size + (2*$Config{ptrsize});
	$arg = $PERL56 ? $optype_enum{LOGOP} : $opsize | $optype_enum{LOGOP} << 7;
        warn "[perl #80622] Upgrading entertry from BASEOP to LOGOP...\n" unless $quiet;
        bless $op, 'B::LOGOP';
      } elsif ($op->name eq 'aelemfast') {
        if (0) {
          my $class = ITHREADS ? 'PADOP' : 'SVOP';
          my $type  = ITHREADS ? $optype_enum{PADOP} : $optype_enum{SVOP};
          $opsize = $op->size + $Config{ptrsize};
          $arg = $PERL56 ? $type : $opsize | $type << 7;
          warn "Upgrading aelemfast from BASEOP to $class...\n" unless $quiet;
          bless $op, "B::$class";
        }
      } elsif ($DEBUGGING) { # only needed when we want to check for new wrong BASEOP's
	if (eval "require Opcodes;") {
	  my $class = Opcodes::opclass($op->type);
	  if ($class > 0) {
	    my $classname = $optype[$class];
            if ($classname) {
              my $name = $op->name;
              warn "Upgrading $name BASEOP to $classname...\n"  unless $quiet;
              bless $op, "B::".$classname;
            }
	  }
	}
      }
    }
    B::Assembler::maxopix($tix) if $debug{A};
    asm "newopx", $arg, sprintf( "$arg=size:%s,type:%d", $opsize, $op->type );
    asm "stop", $tix if $PERL56;
    $optab{$$op} = $opix = $ix = $tix++;
    $op->bsave($ix);
    $ix;
  }
}

sub B::SPECIAL::ix {
  my $spec = shift;
  my $ix   = $spectab{$$spec};
  defined($ix) ? $ix : do {
    B::Assembler::maxsvix($tix) if $debug{A};
    nice "[SPECIAL $tix]";
    asm "ldspecsvx", $$spec, $specialsv_name[$$spec];
    asm "stsv", $tix if $PERL56;
    $spectab{$$spec} = $varix = $tix++;
  }
}

sub B::SV::ix {
  my $sv = shift;
  my $ix = $svtab{$$sv};
  defined($ix) ? $ix : do {
    nice '[' . class($sv) . " $tix]";
    B::Assembler::maxsvix($tix) if $debug{A};
    my $flags = $sv->FLAGS;
    my $type = $flags & 0xff; # SVTYPEMASK
    # Set TMP_on, MY_off, not to be tidied (test 48),
    # otherwise pad_tidy will set PADSTALE_on and assert. Since 5.16 TMP and STALE share the same bit.
    #if (ref $sv eq 'B::NULL' and $sv->REFCNT > 1 and $] >= 5.016) {
      # $flags |= 0x00020000;  # SvPADTMP_on
      # $flags &= ~0x00040000; # SvPADMY_off
    #}
    asm "newsvx", $flags,
     $debug{Comment} ? sprintf("type=%d,flags=0x%x,%s", $type, $flags, sv_flags($sv)) : '';
    asm "stsv", $tix if $PERL56;
    $svtab{$$sv} = $varix = $ix = $tix++;
    $sv->bsave($ix);
    $ix;
  }
}

sub B::PADLIST::ix {
  my $padl = shift;
  my $ix = $svtab{$$padl};
  defined($ix) ? $ix : do {
    nice '[' . class($padl) . " $tix]";
    B::Assembler::maxsvix($tix) if $debug{A};
    asm "newpadlx", 1;
    $svtab{$$padl} = $varix = $ix = $tix++;
    $padl->bsave($ix);
    $ix;
  }
}

sub B::GV::ix {
  my ( $gv, $desired ) = @_;
  my $ix = $svtab{$$gv};
  defined($ix) ? $ix : do {
    if ( $debug{G} and !$PERL510 ) {
      select *STDERR;
      eval "require B::Debug;";
      $gv->B::GV::debug;
      select *STDOUT;
    }
    if ( ( $PERL510 and $gv->isGV_with_GP )
      or ( !$PERL510 and !$PERL56 and $gv->GP ) )
    {    # only gv with gp
      my ( $svix, $avix, $hvix, $cvix, $ioix, $formix );
      # 510 without debugging misses B::SPECIAL::NAME
      my $name;
      if ( $PERL510
        and ( $gv->STASH->isa('B::SPECIAL') or $gv->isa('B::SPECIAL') ) )
      {
        $name = '_';
        nice '[GV] # "_"';
        return 0;
      }
      else {
        $name = $gv->STASH->NAME . "::"
          . ( class($gv) eq 'B::SPECIAL' ? '_' : $gv->NAME );
      }
      nice "[GV $tix]";
      B::Assembler::maxsvix($tix) if $debug{A};
      asm "gv_fetchpvx", cstring $name;
      asm "stsv", $tix if $PERL56;
      $svtab{$$gv} = $varix = $ix = $tix++;
      asm "sv_flags",  $gv->FLAGS, as_hex($gv->FLAGS);
      asm "sv_refcnt", $gv->REFCNT;
      asm "xgv_flags", $gv->GvFLAGS, as_hex($gv->GvFLAGS);

      asm "gp_refcnt", $gv->GvREFCNT;
      asm "load_glob", $ix if $name eq "CORE::GLOBAL::glob";
      return $ix
        unless $desired || desired $gv;
      $svix = $gv->SV->ix;
      $avix = $gv->AV->ix;
      $hvix = $gv->HV->ix;

      # XXX {{{{
      my $cv = $gv->CV;
      $cvix = $$cv && defined $files{ $cv->FILE } ? $cv->ix : 0;
      my $form = $gv->FORM;
      $formix = $$form && defined $files{ $form->FILE } ? $form->ix : 0;

      $ioix = $name !~ /STDOUT$/ ? $gv->IO->ix : 0;

      # }}}} XXX

      nice1 "-GP-", asm "ldsv", $varix = $ix, sv_flags($gv) unless $ix == $varix;
      asm "gp_sv", $svix, sv_flags( $gv->SV ) if $svix;
      asm "gp_av", $avix, sv_flags( $gv->AV ) if $avix;
      asm "gp_hv", $hvix, sv_flags( $gv->HV ) if $hvix;
      asm "gp_cv", $cvix, sv_flags( $gv->CV ) if $cvix;
      asm "gp_io", $ioix if $ioix;
      asm "gp_cvgen", $gv->CVGEN if $gv->CVGEN;
      asm "gp_form",  $formix if $formix;
      asm "gp_file",  pvix $gv->FILE;
      asm "gp_line",  $gv->LINE;
      asm "formfeed", $svix if $name eq "main::\cL";
    }
    else {
      nice "[GV $tix]";
      B::Assembler::maxsvix($tix) if $debug{A};
      asm "newsvx", $gv->FLAGS, $debug{Comment} ? sv_flags($gv) : '';
      asm "stsv", $tix if $PERL56;
      $svtab{$$gv} = $varix = $ix = $tix++;
      if ( !$PERL510 ) {
        asm "xgv_flags", $gv->GvFLAGS;  # GV_without_GP has no GvFlags
      }
      if ( !$PERL510 and !$PERL56 and $gv->STASH ) {
        my $stashix = $gv->STASH->ix;
        asm "xgv_stash", $stashix;
      }
      if ($PERL510 and $gv->FLAGS & 0x40000000) { # SVpbm_VALID
        my $bm = bless $gv, "B::BM";
        $bm->bsave($ix); # also saves magic
      } else {
        $gv->B::PVMG::bsave($ix);
      }
    }
    $ix;
  }
}

sub B::HV::ix {
  my $hv = shift;
  my $ix = $svtab{$$hv};
  defined($ix) ? $ix : do {
    my ( $ix, $i, @array );
    my $name = $hv->NAME;
    if ($name) {
      nice "[STASH $tix]";
      B::Assembler::maxsvix($tix) if $debug{A};
      asm "gv_stashpvx", cstring $name;
      asm "ldsv", $tix if $PERL56;
      asm "sv_flags", $hv->FLAGS, as_hex($hv->FLAGS);
      $svtab{$$hv} = $varix = $ix = $tix++;
      asm "xhv_name", pvix $name;

      # my $pmrootix = $hv->PMROOT->ix;	# XXX
      asm "ldsv", $varix = $ix unless $ix == $varix;
      # asm "xhv_pmroot", $pmrootix;	# XXX
    }
    else {
      nice "[HV $tix]";
      B::Assembler::maxsvix($tix) if $debug{A};
      asm "newsvx", $hv->FLAGS, $debug{Comment} ? sv_flags($hv) : '';
      asm "stsv", $tix if $PERL56;
      $svtab{$$hv} = $varix = $ix = $tix++;
      my $stashix = $hv->SvSTASH->ix;
      for ( @array = $hv->ARRAY ) {
        next if $i = not $i;
        $_ = $_->ix;
      }
      nice1 "-HV-", asm "ldsv", $varix = $ix unless $ix == $varix;
      ( $i = not $i ) ? asm( "newpv", pvstring $_) : asm( "hv_store", $_ )
        for @array;
      if ( VERSION < 5.009 ) {
        asm "xnv", $hv->NVX;
      }
      asm "xmg_stash", $stashix;
      asm( "xhv_riter", $hv->RITER ) if VERSION < 5.009;
    }
    asm "sv_refcnt", $hv->REFCNT;
    $ix;
  }
}

sub B::NULL::ix {
  my $sv = shift;
  $$sv ? $sv->B::SV::ix : 0;
}

sub B::NULL::opwalk { 0 }

#################################################

sub B::NULL::bsave {
  my ( $sv, $ix ) = @_;

  nice '-' . class($sv) . '-', asm "ldsv", $varix = $ix, sv_flags($sv)
    unless $ix == $varix;
  if ($PERL56) {
    asm "stsv", $ix;
  } else {
    asm "sv_refcnt", $sv->REFCNT;
  }
}

sub B::SV::bsave;
*B::SV::bsave = *B::NULL::bsave;

sub B::RV::bsave {
  my ( $sv, $ix ) = @_;
  my $rvix = $sv->RV->ix;
  $sv->B::NULL::bsave($ix);
  # RV with DEBUGGING already requires sv_flags before SvRV_set
  asm "sv_flags", $sv->FLAGS, as_hex($sv->FLAGS);
  asm "xrv", $rvix;
}

sub B::PV::bsave {
  my ( $sv, $ix ) = @_;
  $sv->B::NULL::bsave($ix);
  return unless $sv;
  if ($PERL56) {
    #$sv->B::SV::bsave;
    if ($sv->FLAGS & $POK) {
      asm  "newpv", pvstring $sv->PV;
      asm  "xpv";
    }
  } elsif ($PERL518 and (($sv->FLAGS & SVf_IsCOW) == SVf_IsCOW)) { # COW
    asm "newpv", pvstring $sv->PV;
    asm "xpvshared";
  } elsif ($PERL510 and (($sv->FLAGS & 0x09000000) == 0x09000000)) { # SHARED
    if ($sv->FLAGS & 0x40000000 and !($sv->FLAGS & 0x00008000)) { # pbm_VALID, !SCREAM
      asm "newpv", pvstring $sv->PVBM;
    } else {
      asm "newpv", pvstring $sv->PV;
    }
    asm "xpvshared";
  } elsif ($PERL510 and $sv->FLAGS & 0x40000000 and !($sv->FLAGS & 0x00008000)) { # pbm_VALID, !SCREAM
    asm "newpv", pvstring $sv->PVBM;
    asm "xpv";
  } else {
    asm "newpv", pvstring $sv->PV;
    asm "xpv";
  }
}

sub B::IV::bsave {
  my ( $sv, $ix ) = @_;
  return $sv->B::RV::bsave($ix)
    if $PERL512 and $sv->FLAGS & B::SVf_ROK;
  $sv->B::NULL::bsave($ix);
  if ($PERL56) {
    asm $sv->needs64bits ? "xiv64" : "xiv32", $sv->IVX;
  } else {
    asm "xiv", $sv->IVX;
  }
}

sub B::NV::bsave {
  my ( $sv, $ix ) = @_;
  $sv->B::NULL::bsave($ix);
  asm "xnv", sprintf "%.40g", $sv->NVX;
}

sub B::PVIV::bsave {
  my ( $sv, $ix ) = @_;
  if ($PERL56) {
    $sv->B::PV::bsave($ix);
  } else {
      $sv->POK ? $sv->B::PV::bsave($ix)
    : $sv->ROK ? $sv->B::RV::bsave($ix)
    :            $sv->B::NULL::bsave($ix);
  }
  if ($PERL510) { # See note below in B::PVNV::bsave
    return if $sv->isa('B::AV');
    return if $sv->isa('B::HV');
    return if $sv->isa('B::CV');
    return if $sv->isa('B::GV');
    return if $sv->isa('B::IO');
    return if $sv->isa('B::FM');
  }
  bwarn( sprintf( "PVIV sv:%s flags:0x%x", class($sv), $sv->FLAGS ) )
    if $debug{M};

  if ($PERL56) {
    my $iv = $sv->IVX;
    asm $sv->needs64bits ? "xiv64" : "xiv32", $iv;
  } else {
    # PVIV GV 8009, GV flags & (4000|8000) illegal (SVpgv_GP|SVp_POK)
    asm "xiv", !ITHREADS
      && (($sv->FLAGS & ($SVf_FAKE|SVf_READONLY)) == ($SVf_FAKE|SVf_READONLY))
         ? "0 # but true" : $sv->IVX;
  }
}

sub B::PVNV::bsave {
  my ( $sv, $ix ) = @_;
  $sv->B::PVIV::bsave($ix);
  if ($PERL510) {
    # getting back to PVMG
    return if $sv->isa('B::AV');
    return if $sv->isa('B::HV');
    return if $sv->isa('B::CV');
    return if $sv->isa('B::FM');
    return if $sv->isa('B::GV');
    return if $sv->isa('B::IO');

    # cop_seq range instead of a double. (IV, NV)
    unless ($sv->FLAGS & (SVf_NOK|SVp_NOK)) {
      asm "cop_seq_low", $sv->COP_SEQ_RANGE_LOW;
      asm "cop_seq_high", $sv->COP_SEQ_RANGE_HIGH;
      return;
    }
  }
  asm "xnv", sprintf "%.40g", $sv->NVX;
}

sub B::PVMG::domagic {
  my ( $sv, $ix ) = @_;
  nice1 '-MAGICAL-'; # no empty line before
  my @mglist = $sv->MAGIC;
  my ( @mgix, @namix );
  for (@mglist) {
    my $mg = $_;
    push @mgix, $_->OBJ->ix;
    push @namix, $mg->PTR->ix if $mg->LENGTH == B::HEf_SVKEY;
    $_ = $mg;
  }

  nice1 '-' . class($sv) . '-', asm "ldsv", $varix = $ix unless $ix == $varix;
  for (@mglist) {
    next unless ord($_->TYPE);
    asm "sv_magic", ord($_->TYPE), cstring $_->TYPE;
    asm "mg_obj",   shift @mgix; # D sets itself, see mg.c:mg_copy
    my $length = $_->LENGTH;
    if ( $length == B::HEf_SVKEY and !$PERL56) {
      asm "mg_namex", shift @namix;
    }
    elsif ($length) {
      asm "newpv", pvstring $_->PTR;
      $PERL56
        ? asm "mg_pv"
        : asm "mg_name";
    }
  }
}

sub B::PVMG::bsave {
  my ( $sv, $ix ) = @_;
  my $stashix = $sv->SvSTASH->ix;
  $sv->B::PVNV::bsave($ix);
  asm "xmg_stash", $stashix;
  # XXX added SV->MAGICAL to 5.6 for compat
  $sv->domagic($ix) if $PERL56 ? MAGICAL56($sv) : $sv->MAGICAL;
}

sub B::PVLV::bsave {
  my ( $sv, $ix ) = @_;
  my $targix = $sv->TARG->ix;
  $sv->B::PVMG::bsave($ix);
  asm "xlv_targ",    $targix unless $PERL56; # XXX really? xlv_targ IS defined
  asm "xlv_targoff", $sv->TARGOFF;
  asm "xlv_targlen", $sv->TARGLEN;
  asm "xlv_type",    $sv->TYPE;
}

sub B::BM::bsave {
  my ( $sv, $ix ) = @_;
  $sv->B::PVMG::bsave($ix);
  asm "xpv_cur",      $sv->CUR if $] > 5.008;
  asm "xbm_useful",   $sv->USEFUL;
  asm "xbm_previous", $sv->PREVIOUS;
  asm "xbm_rare",     $sv->RARE;
}

sub B::IO::bsave {
  my ( $io, $ix ) = @_;
  my $topix    = $io->TOP_GV->ix;
  my $fmtix    = $io->FMT_GV->ix;
  my $bottomix = $io->BOTTOM_GV->ix;
  $io->B::PVMG::bsave($ix);
  asm "xio_lines",       $io->LINES;
  asm "xio_page",        $io->PAGE;
  asm "xio_page_len",    $io->PAGE_LEN;
  asm "xio_lines_left",  $io->LINES_LEFT;
  asm "xio_top_name",    pvix $io->TOP_NAME;
  asm "xio_top_gv",      $topix;
  asm "xio_fmt_name",    pvix $io->FMT_NAME;
  asm "xio_fmt_gv",      $fmtix;
  asm "xio_bottom_name", pvix $io->BOTTOM_NAME;
  asm "xio_bottom_gv",   $bottomix;
  asm "xio_subprocess",  $io->SUBPROCESS unless $PERL510;
  asm "xio_type",        ord $io->IoTYPE;
  if ($PERL56) { # do not mess with PerlIO
    asm "xio_flags",       $io->IoFLAGS;
  } else {
    # XXX IOf_NOLINE off was added with 5.8, but not used (?)
    asm "xio_flags", ord($io->IoFLAGS) & ~32;		# XXX IOf_NOLINE 32
  }
  # issue93: restore std handles
  if (!$PERL56) {
    my $o = $io->object_2svref();
    eval "require ".ref($o).";";
    my $fd = $o->fileno();
    # use IO::Handle ();
    # my $fd = IO::Handle::fileno($o);
    bwarn( "io ix=$ix perlio no fileno for ".ref($o) ) if $fd < 0;
    my $i = 0;
    foreach (qw(stdin stdout stderr)) {
      if ($io->IsSTD($_) or $fd == -$i) { # negative stdout = error
	nice1 "-perlio_$_($fd)-";
	# bwarn( "io $ix perlio_$_($fd)" );
	asm "xio_flags",  $io->IoFLAGS;
	asm "xio_ifp",    $i;
      }
      $i++;
    }
  }
}

sub B::CV::bsave {
  my ( $cv, $ix ) = @_;
  my $stashix   = $cv->STASH->ix;
  my $gvix      = ($cv->GV and ref($cv->GV) ne 'B::SPECIAL') ? $cv->GV->ix : 0;
  my $padlistix = $cv->PADLIST->ix;
  my $outsideix = $cv->OUTSIDE->ix;
  my $startix   = $cv->START->opwalk;
  my $rootix    = $cv->ROOT->ix;
  # TODO 5.14 will need CvGV_set to add backref magic
  my $xsubanyix  = ($cv->CONST and !$PERL56) ? $cv->XSUBANY->ix : 0;

  $cv->B::PVMG::bsave($ix);
  asm "xcv_stash",       $stashix;
  asm "xcv_start",       $startix;
  asm "xcv_root",        $rootix;
  asm "xcv_xsubany",     $xsubanyix unless $PERL56;
  asm "xcv_padlist",     $padlistix;
  asm "xcv_outside",     $outsideix;
  asm "xcv_outside_seq", $cv->OUTSIDE_SEQ unless $PERL56;
  asm "xcv_depth",       $cv->DEPTH;
  # add the RC flag if there's no backref magic. eg END (48)
  my $cvflags = $cv->CvFLAGS;
  $cvflags |= 0x400 if $] >= 5.013 and !$cv->MAGIC;
  asm "xcv_flags",       $cvflags;
  if ($gvix) {
    asm "xcv_gv",        $gvix;
  } elsif ($] >= 5.018001 and $cv->NAME_HEK) { # ignore main_cv
    asm "xcv_name_hek",  pvix $cv->NAME_HEK;   # set name_hek for lexsub (#130)
  #} elsif ($] >= 5.017004) {                   # 5.18.0 empty name, missing B API
  #  asm "xcv_name_hek",  pvix "_";
  }
  asm "xcv_file",        pvix $cv->FILE if $cv->FILE;    # XXX AD
}

sub B::FM::bsave {
  my ( $form, $ix ) = @_;

  $form->B::CV::bsave($ix);
  asm "xfm_lines", $form->LINES;
}

sub B::PAD::bsave {
  my ( $av, $ix ) = @_;
  my @array = $av->ARRAY;
  $_ = $_->ix for @array; # save the elements
  $av->B::NULL::bsave($ix);
  # av_extend always allocs 3
  asm "av_extend", scalar @array if @array;
  asm "av_pushx", $_ for @array;
}

sub B::AV::bsave {
  my ( $av, $ix ) = @_;
  if (!$PERL56 and $av->MAGICAL) {
    $av->B::PVMG::bsave($ix);
    for ($av->MAGIC) {
      return if $_->TYPE eq 'P'; # 'P' tied AV has no ARRAY/FETCHSIZE,..., test 16
      # but e.g. 'I' (@ISA) has
    }
  }
  my @array = $av->ARRAY;
  $_ = $_->ix for @array; # hack. walks the ->ix methods to save the elements
  my $stashix = $av->SvSTASH->ix;
  nice "-AV-",
    asm "ldsv", $varix = $ix, sv_flags($av) unless $ix == $varix;

  if ($PERL56) {
    # SvREADONLY_off($av) w PADCONST
    asm "sv_flags", $av->FLAGS & ~SVf_READONLY, as_hex($av->FLAGS);
    $av->domagic($ix) if MAGICAL56($av);
    asm "xav_flags", $av->AvFLAGS, as_hex($av->AvFLAGS);
    asm "xav_max", -1;
    asm "xav_fill", -1;
    if ($av->FILL > -1) {
      asm "av_push", $_ for @array;
    } else {
      asm "av_extend", $av->MAX if $av->MAX >= 0 and $av->{ref} ne 'PAD';
    }
    asm "sv_flags", $av->FLAGS if $av->FLAGS & SVf_READONLY; # restore flags
  } else {
    #$av->domagic($ix) if $av->MAGICAL; # XXX need tests for magic arrays
    asm "av_extend", $av->MAX if $av->MAX >= 0;
    asm "av_pushx", $_ for @array;
    if ( !$PERL510 ) {        # VERSION < 5.009
      asm "xav_flags", $av->AvFLAGS, as_hex($av->AvFLAGS);
    }
    # asm "xav_alloc", $av->AvALLOC if $] > 5.013002; # XXX new but not needed
  }
  asm "sv_refcnt", $av->REFCNT;
  asm "xmg_stash", $stashix;
}

sub B::PADLIST::bsave {
  my ( $padl, $ix ) = @_;
  my @array = $padl->ARRAY;
  bless $array[0], 'B::PAD';
  bless $array[1], 'B::PAD';
  my $ix0 = $array[0]->ix; # comppad_name
  my $ix1 = $array[1]->ix; # comppad syms

  nice "-PADLIST-",
    asm "ldsv", $varix = $ix unless $ix == $varix;
  asm "padl_name", $ix0;
  asm "padl_sym",  $ix1;
}

sub B::GV::desired {
  my $gv = shift;
  my ( $cv, $form );
  if ( $debug{Gall} and !$PERL510 ) {
    select *STDERR;
    eval "require B::Debug;";
    $gv->debug;
    select *STDOUT;
  }
  $files{ $gv->FILE } && $gv->LINE
    || ${ $cv   = $gv->CV }   && $files{ $cv->FILE }
    || ${ $form = $gv->FORM } && $files{ $form->FILE };
}

sub B::HV::bwalk {
  my $hv = shift;
  return if $walked{$$hv}++;
  my %stash = $hv->ARRAY;
  while ( my ( $k, $v ) = each %stash ) {
    if ( !$PERL56 and $v->SvTYPE == $SVt_PVGV ) {
      my $hash = $v->HV;
      if ( $$hash && $hash->NAME ) {
        $hash->bwalk;
      }
      # B since 5.13.6 (744aaba0598) pollutes our namespace. Keep it clean
      # XXX This fails if our source really needs any B constant
      unless ($] > 5.013005 and $hv->NAME eq 'B') {
	$v->ix(1) if desired $v;
      }
    }
    else {
      if ($] > 5.013005 and $hv->NAME eq 'B') { # see above. omit B prototypes
	return;
      }
      nice "[prototype $tix]";
      B::Assembler::maxsvix($tix) if $debug{A};
      asm "gv_fetchpvx", cstring ($hv->NAME . "::" . $k);
      $svtab{$$v} = $varix = $tix;
      # we need the sv_flags before, esp. for DEBUGGING asserts
      asm "sv_flags",  $v->FLAGS, as_hex($v->FLAGS);
      $v->bsave( $tix++ );
    }
  }
}

######################################################

sub B::OP::bsave_thin {
  my ( $op, $ix ) = @_;
  bwarn( B::peekop($op), ", ix: $ix" ) if $debug{o};
  my $next   = $op->next;
  my $nextix = $optab{$$next};
  $nextix = 0, push @cloop, $op unless defined $nextix;
  if ( $ix != $opix ) {
    nice '-' . $op->name . '-', asm "ldop", $opix = $ix;
  }
  asm "op_flags",   $op->flags, op_flags( $op->flags ) if $op->flags;
  asm "op_next",    $nextix;
  asm "op_targ",    $op->targ if $op->type and $op->targ;  # tricky
  asm "op_private", $op->private if $op->private;          # private concise flags?
  if ($] >= 5.017 and $op->can('slabbed')) {
    asm "op_slabbed", $op->slabbed if $op->slabbed;
    asm "op_savefree", $op->savefree if $op->savefree;
    asm "op_static", $op->static if $op->static;
    if ($] >= 5.019002 and $op->can('folded')) {
      asm "op_folded", $op->folded if $op->folded;
    }
  }
}

sub B::OP::bsave;
*B::OP::bsave = *B::OP::bsave_thin;

sub B::UNOP::bsave {
  my ( $op, $ix ) = @_;
  my $name    = $op->name;
  my $flags   = $op->flags;
  my $first   = $op->first;
  my $firstix = $name =~ /fl[io]p/

    # that's just neat
    || ( !ITHREADS && $name eq 'regcomp' )

    # trick for /$a/o in pp_regcomp
    || $name eq 'rv2sv'
    && $op->flags & OPf_MOD
    && $op->private & OPpLVAL_INTRO

    # change #18774 (localref) made my life hard (commit 82d039840b913b4)
    ? $first->ix
    : 0;

  # XXX Are there more new UNOP's with first?
  $firstix = $first->ix if $name eq 'require'; #issue 97
  $op->B::OP::bsave($ix);
  asm "op_first", $firstix;
}

sub B::BINOP::bsave {
  my ( $op, $ix ) = @_;
  if ( $op->name eq 'aassign' && $op->private & B::OPpASSIGN_HASH() ) {
    my $last   = $op->last;
    my $lastix = do {
      local *B::OP::bsave   = *B::OP::bsave_fat;
      local *B::UNOP::bsave = *B::UNOP::bsave_fat;
      $last->ix;
    };
    asm "ldop", $lastix unless $lastix == $opix;
    asm "op_targ", $last->targ;
    $op->B::OP::bsave($ix);
    asm "op_last", $lastix;
  }
  else {
    $op->B::OP::bsave($ix);
  }
}

# not needed if no pseudohashes

*B::BINOP::bsave = *B::OP::bsave if $PERL510;    #VERSION >= 5.009;

# deal with sort / formline

sub B::LISTOP::bsave {
  my ( $op, $ix ) = @_;
  bwarn( B::peekop($op), ", ix: $ix" ) if $debug{o};
  my $name = $op->name;
  sub blocksort() { OPf_SPECIAL | OPf_STACKED }
  if ( $name eq 'sort' && ( $op->flags & blocksort ) == blocksort ) {
    my $first    = $op->first;
    my $pushmark = $first->sibling;
    my $rvgv     = $pushmark->first;
    my $leave    = $rvgv->first;

    my $leaveix = $leave->ix;

    my $rvgvix = $rvgv->ix;
    asm "ldop", $rvgvix unless $rvgvix == $opix;
    asm "op_first", $leaveix;

    my $pushmarkix = $pushmark->ix;
    asm "ldop", $pushmarkix unless $pushmarkix == $opix;
    asm "op_first", $rvgvix;

    my $firstix = $first->ix;
    asm "ldop", $firstix unless $firstix == $opix;
    asm "op_sibling", $pushmarkix;

    $op->B::OP::bsave($ix);
    asm "op_first", $firstix;
  }
  elsif ( $name eq 'formline' ) {
    $op->B::UNOP::bsave_fat($ix);
  }
  elsif ( $name eq 'dbmopen' ) {
    require AnyDBM_File;
    $op->B::OP::bsave($ix);
  }
  else {
    $op->B::OP::bsave($ix);
  }
}

# fat versions

sub B::OP::bsave_fat {
  my ( $op, $ix ) = @_;
  my $siblix = $op->sibling->ix;

  $op->B::OP::bsave_thin($ix);
  asm "op_sibling", $siblix;

  # asm "op_seq", -1;			XXX don't allocate OPs piece by piece
}

sub B::UNOP::bsave_fat {
  my ( $op, $ix ) = @_;
  my $firstix = $op->first->ix;

  $op->B::OP::bsave($ix);
  asm "op_first", $firstix;
}

sub B::BINOP::bsave_fat {
  my ( $op, $ix ) = @_;
  my $last   = $op->last;
  my $lastix = $op->last->ix;
  bwarn( B::peekop($op), ", ix: $ix $last: $last, lastix: $lastix" )
    if $debug{o};
  if ( !$PERL510 && $op->name eq 'aassign' && $last->name eq 'null' ) {
    asm "ldop", $lastix unless $lastix == $opix;
    asm "op_targ", $last->targ;
  }

  $op->B::UNOP::bsave($ix);
  asm "op_last", $lastix;
}

sub B::LOGOP::bsave {
  my ( $op, $ix ) = @_;
  my $otherix = $op->other->ix;
  bwarn( B::peekop($op), ", ix: $ix" ) if $debug{o};

  $op->B::UNOP::bsave($ix);
  asm "op_other", $otherix;
}

sub B::PMOP::bsave {
  my ( $op, $ix ) = @_;
  my ( $rrop, $rrarg, $rstart );

  # my $pmnextix = $op->pmnext->ix;	# XXX
  bwarn( B::peekop($op), " ix: $ix" ) if $debug{M} or $debug{o};
  if (ITHREADS) {
    if ( $op->name eq 'subst' ) {
      $rrop   = "op_pmreplroot";
      $rrarg  = $op->pmreplroot->ix;
      $rstart = $op->pmreplstart->ix;
    }
    elsif ( $op->name eq 'pushre' ) {
      $rrarg = $op->pmreplroot;
      $rrop  = "op_pmreplrootpo";
    }
    $op->B::BINOP::bsave($ix);
    if ( !$PERL56 and $op->pmstashpv )
    {    # avoid empty stash? if (table) pre-compiled else re-compile
      if ( !$PERL510 ) {
        asm "op_pmstashpv", pvix $op->pmstashpv;
      }
      else {
        # XXX crash in 5.10, 5.11. Only used in OP_MATCH, with PMf_ONCE set
        if ( $op->name eq 'match' and $op->op_pmflags & 2) {
          asm "op_pmstashpv", pvix $op->pmstashpv;
        } else {
          bwarn("op_pmstashpv ignored") if $debug{M};
        }
      }
    }
    elsif ($PERL56) { # ignored
      ;
    }
    else {
      bwarn("op_pmstashpv main") if $debug{M};
      asm "op_pmstashpv", pvix "main" unless $PERL510;
    }
  } # ithreads
  else {
    $rrop  = "op_pmreplrootgv";
    $rrarg  = $op->pmreplroot->ix;
    $rstart = $op->pmreplstart->ix if $op->name eq 'subst';
    # 5.6 walks down the pmreplrootgv here
    # $op->pmreplroot->save($rrarg) unless $op->name eq 'pushre';
    my $stashix = $op->pmstash->ix unless $PERL56;
    $op->B::BINOP::bsave($ix);
    asm "op_pmstash", $stashix unless $PERL56;
  }

  asm $rrop, $rrarg if $rrop;
  asm "op_pmreplstart", $rstart if $rstart;

  if ( !$PERL510 ) {
    bwarn( "PMOP op_pmflags: ", $op->pmflags ) if $debug{M};
    asm "op_pmflags",     $op->pmflags;
    asm "op_pmpermflags", $op->pmpermflags;
    asm "op_pmdynflags",  $op->pmdynflags unless $PERL56;
    # asm "op_pmnext", $pmnextix;	# XXX broken
    # Special sequence: This is the arg for the next pregcomp
    asm "newpv", pvstring $op->precomp;
    asm "pregcomp";
  }
  elsif ($PERL510) {
    # Since PMf_BASE_SHIFT we need a U32, which is a new bytecode for
    # backwards compat
    asm "op_pmflags", $op->pmflags;
    bwarn("PMOP op_pmflags: ", $op->pmflags) if $debug{M};
    my $pv = $op->precomp;
    asm "newpv", pvstring $pv;
    asm "pregcomp";
    # pregcomp does not set the extflags correctly, just the pmflags
    asm "op_reflags", $op->reflags if $pv; # so overwrite the extflags
  }
}

sub B::SVOP::bsave {
  my ( $op, $ix ) = @_;
  my $svix = $op->sv->ix;

  $op->B::OP::bsave($ix);
  asm "op_sv", $svix;
}

sub B::PADOP::bsave {
  my ( $op, $ix ) = @_;

  $op->B::OP::bsave($ix);

  # XXX crashed in 5.11 (where, why?)
  #if ($PERL512) {
  asm "op_padix", $op->padix;
  #}
}

sub B::PVOP::bsave {
  my ( $op, $ix ) = @_;
  $op->B::OP::bsave($ix);
  return unless my $pv = $op->pv;

  if ( $op->name eq 'trans' ) {
    asm "op_pv_tr", join ',', length($pv) / 2, unpack( "s*", $pv );
  }
  else {
    asm "newpv", pvstring $pv;
    asm "op_pv";
  }
}

sub B::LOOP::bsave {
  my ( $op, $ix ) = @_;
  my $nextix = $op->nextop->ix;
  my $lastix = $op->lastop->ix;
  my $redoix = $op->redoop->ix;

  $op->B::BINOP::bsave($ix);
  asm "op_redoop", $redoix;
  asm "op_nextop", $nextix;
  asm "op_lastop", $lastix;
}

sub B::COP::bsave {
  my ( $cop, $ix ) = @_;
  my $warnix = $cop->warnings->ix;
  if (ITHREADS) {
    $cop->B::OP::bsave($ix);
    asm "cop_stashpv", pvix $cop->stashpv, $cop->stashpv;
    asm "cop_file",    pvix $cop->file,    $cop->file;
  }
  else {
    my $stashix = $cop->stash->ix;
    my $fileix  = $PERL56 ? pvix($cop->file) : $cop->filegv->ix(1);
    $cop->B::OP::bsave($ix);
    asm "cop_stash",  $stashix;
    asm "cop_filegv", $fileix;
  }
  asm "cop_label", pvix $cop->label, $cop->label if $cop->label;    # XXX AD
  asm "cop_seq", $cop->cop_seq;
  asm "cop_arybase", $cop->arybase unless $PERL510;
  asm "cop_line", $cop->line;
  asm "cop_warnings", $warnix;
  if ( !$PERL510 and !$PERL56 ) {
    asm "cop_io", $cop->io->ix;
  }
}

sub B::OP::opwalk {
  my $op = shift;
  my $ix = $optab{$$op};
  defined($ix) ? $ix : do {
    my $ix;
    my @oplist = ($PERL56 and $op->isa("B::COP"))
      ? () : $op->oplist; # 5.6 may be called by a COP
    push @cloop, undef;
    $ix = $_->ix while $_ = pop @oplist;
    #print "\n# rest of cloop\n";
    while ( $_ = pop @cloop ) {
      asm "ldop",    $optab{$$_};
      asm "op_next", $optab{ ${ $_->next } };
    }
    $ix;
  }
}

# Do run-time requires with -b savebegin and without -i includeall.
# Otherwise all side-effects of BEGIN blocks are already in the current
# compiled code.
# -b or !-i will have smaller code, but run-time access of dependent modules
# such as with python, where all modules are byte-compiled.
# With -i the behaviour is similar to the C or CC compiler, where everything
# is packed into one file.
# Redo only certain ops, such as push @INC ""; unshift @INC "" (TODO *INC)
# use/require defs and boot sections are already included.
sub save_begin {
  my $av;
  if ( ( $av = begin_av )->isa("B::AV") and $av->ARRAY) {
    nice '<push_begin>';
    if ($savebegins) {
      for ( $av->ARRAY ) {
        next unless $_->FILE eq $0;
        asm "push_begin", $_->ix;
      }
    }
    else {
      for ( $av->ARRAY ) {
        next unless $_->FILE eq $0;

        # XXX BEGIN { goto A while 1; A: }
        for ( my $op = $_->START ; $$op ; $op = $op->next ) {
	  # 1. push|unshift @INC, "libpath"
	  if ($op->name eq 'gv') {
            my $gv = class($op) eq 'SVOP'
                  ? $op->gv
                  : ( ( $_->PADLIST->ARRAY )[1]->ARRAY )[ $op->padix ];
	    nice1 '<gv '.$gv->NAME.'>' if $$gv;
            asm "incav", inc_gv->AV->ix if $$gv and $gv->NAME eq 'INC'; 
	  }
	  # 2. use|require
	  if (!$includeall) {
	    next unless $op->name eq 'require' ||
              # this kludge needed for tests
              $op->name eq 'gv' && do {
                my $gv = class($op) eq 'SVOP'
                  ? $op->gv
                  : ( ( $_->PADLIST->ARRAY )[1]->ARRAY )[ $op->padix ];
                $$gv && $gv->NAME =~ /use_ok|plan/;
              };
              nice1 '<require in BEGIN>';
              asm "push_begin", $_->ix if $_;
              last;
	   }
        }
      }
    }
  }
}

sub save_init_end {
  my $av;
  if ( ( $av = init_av )->isa("B::AV") and $av->ARRAY ) {
    nice '<push_init>';
    for ( $av->ARRAY ) {
      next unless $_->FILE eq $0;
      asm "push_init", $_->ix;
    }
  }
  if ( ( $av = end_av )->isa("B::AV") and $av->ARRAY ) {
    nice '<push_end>';
    for ( $av->ARRAY ) {
      next unless $_->FILE eq $0;
      asm "push_end", $_->ix;
    }
  }
}

################### perl 5.6 backport only ###################################

sub B::GV::bytecodecv {
  my $gv = shift;
  my $cv = $gv->CV;
  if ( $$cv && !( $gv->FLAGS & 0x80 ) ) { # GVf_IMPORTED_CV / && !saved($cv)
    if ($debug{cv}) {
      warn sprintf( "saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
        $gv->STASH->NAME, $gv->NAME, $$cv, $$gv );
    }
    $gv->bsave;
  }
}

sub symwalk {
  no strict 'refs';
  my $ok = 1
    if grep { ( my $name = $_[0] ) =~ s/::$//; $_ eq $name; } @packages;
  if ( grep { /^$_[0]/; } @packages ) {
    walksymtable( \%{"$_[0]"}, "desired", \&symwalk, $_[0] );
  }
  warn "considering $_[0] ... " . ( $ok ? "accepted\n" : "rejected\n" )
    if $debug{b};
  $ok;
}

################### end perl 5.6 backport ###################################

sub compile {
  my ( $head, $scan, $keep_syn, $module );
  my $cwd = '';
  $files{$0} = 1;
  $DB::single=1 if defined &DB::DB;
  # includeall mode (without require):
  if ($includeall) {
    # add imported symbols => values %INC
    $files{$_} = 1 for values %INC;
  }

  sub keep_syn {
    $keep_syn         = 1;
    *B::OP::bsave     = *B::OP::bsave_fat;
    *B::UNOP::bsave   = *B::UNOP::bsave_fat;
    *B::BINOP::bsave  = *B::BINOP::bsave_fat;
    *B::LISTOP::bsave = *B::LISTOP::bsave_fat;
  }
  sub bwarn { print STDERR "Bytecode.pm: @_\n" unless $quiet; }

  for (@_) {
    if (/^-q(q?)/) {
      $quiet = 1;
    }
    elsif (/^-S/) {
      $debug{Comment} = 1;
      $debug{-S} = 1;
      *newasm = *endasm = sub { };
      *asm = sub($;$$) {
        undef $_[2] if defined $_[2] and $quiet;
        ( defined $_[2] )
          ? print $_[0], " ", $_[1], "\t# ", $_[2], "\n"
          : print "@_\n";
      };
      *nice = sub ($) { print "\n# @_\n" unless $quiet; };
      *nice1 = sub ($) { print "# @_\n" unless $quiet; };
    }
    elsif (/^-v/) {
      warn "conflicting -q ignored" if $quiet;
      *nice = sub ($) { print "\n# @_\n"; print STDERR "@_\n" };
      *nice1 = sub ($) { print "# @_\n"; print STDERR "@_\n" };
    }
    elsif (/^-H/) {
      require ByteLoader;
      my $version = $ByteLoader::VERSION;
      $head = "#! $^X
use ByteLoader '$ByteLoader::VERSION';
";

      # Maybe: Fix the plc reader, if 'perl -MByteLoader <.plc>' is called
    }
    elsif (/^-k/) {
      keep_syn unless $PERL510;
    }
    elsif (/^-m/) {
      $module = 1;
    }
    elsif (/^-o(.*)$/) {
      open STDOUT, ">$1" or die "open $1: $!";
    }
    elsif (/^-F(.*)$/) {
      $files{$1} = 1;
    }
    elsif (/^-i/) {
      $includeall = 1;
    }
    elsif (/^-D(.*)$/) {
      $debug{$1}++;
    }
    elsif (/^-s(.*)$/) {
      $scan = length($1) ? $1 : $0;
    }
    elsif (/^-b/) {
      $savebegins = 1;
    } # this is here for the testsuite
    elsif (/^-TI/) {
      $T_inhinc = 1;
    }
    elsif (/^-TF(.*)/) {
      my $thatfile = $1;
      *B::COP::file = sub { $thatfile };
    }
    # Use -m instead for modules
    elsif (/^-u(.*)/ and $PERL56) {
      my $arg ||= $1;
      push @packages, $arg;
    }
    else {
      bwarn "Ignoring '$_' option";
    }
  }
  if ($scan) {
    my $f;
    if ( open $f, $scan ) {
      while (<$f>) {
        /^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1;
        /^#/ and next;
        if ( /\bgoto\b\s*[^&]/ && !$keep_syn ) {
          bwarn "keeping the syntax tree: \"goto\" op found";
          keep_syn;
        }
      }
    }
    else {
      bwarn "cannot rescan '$scan'";
    }
    close $f;
  }
  binmode STDOUT;
  return sub {
    if ($debug{-S}) {
      my $header = B::Assembler::gen_header_hash;
      asm sprintf("#%-10s\t","magic").sprintf("0x%x",$header->{magic});
      for (qw(archname blversion ivsize ptrsize byteorder longsize archflag
              perlversion)) {
	asm sprintf("#%-10s\t",$_).$header->{$_};
      }
    }
    print $head if $head;
    newasm sub { print @_ };

    nice '<incav>' if $T_inhinc;
    asm "incav", inc_gv->AV->ix if $T_inhinc;
    save_begin;
    #asm "incav", inc_gv->AV->ix if $T_inhinc;
    nice '<end_begin>';
    if (!$PERL56) {
      defstash->bwalk;
    } else {
      if ( !@packages ) {
        # support modules?
	@packages = qw(main);
      }
      for (@packages) {
	no strict qw(refs);
        #B::svref_2object( \%{"$_\::"} )->bwalk;
	walksymtable( \%{"$_\::"}, "bytecodecv", \&symwalk );
      }
      walkoptree( main_root, "bsave" ) unless ref(main_root) eq "B::NULL";
    }

    asm "signal", cstring "__WARN__"    # XXX
      if !$PERL56 and warnhook->ix;
    save_init_end;

    unless ($module) {
      nice '<main_start>';
      asm "main_start", $PERL56 ? main_start->ix : main_start->opwalk;
      #asm "main_start", main_start->opwalk;
      nice '<main_root>';
      asm "main_root",  main_root->ix;
      nice '<main_cv>';
      asm "main_cv",    main_cv->ix;
      nice '<curpad>';
      asm "curpad",     ( comppadlist->ARRAY )[1]->ix;
    }
    asm "dowarn", dowarn unless $PERL56;

    {
      no strict 'refs';
      nice "<DATA>";
      my $dh = $PERL56 ? *main::DATA : *{ defstash->NAME . "::DATA" };
      unless ( eof $dh ) {
        local undef $/;
        asm "data", ord 'D' if !$PERL56;
        print <$dh>;
      }
      else {
        asm "ret";
      }
    }

    endasm;
  }
}

1;

=head1 NAME

B::Bytecode - Perl compiler's bytecode backend

=head1 SYNOPSIS

B<perl -MO=Bytecode>[B<,-H>][B<,-o>I<script.plc>] I<script.pl>

=head1 DESCRIPTION

Compiles a Perl script into a bytecode format that could be loaded
later by the ByteLoader module and executed as a regular Perl script.
This saves time for the optree parsing and compilation and space for
the sourcecode in memory.

=head1 EXAMPLE

    $ perl -MO=Bytecode,-H,-ohi -e 'print "hi!\n"'
    $ perl hi
    hi!

=head1 OPTIONS

=over 4

=item B<-H>

Prepend a C<use ByteLoader VERSION;> line to the produced bytecode.
This way you will not need to add C<-MByteLoader> to your perl command-line.

=item B<-i> includeall

Include all used packages and its symbols. Does no run-time require from
BEGIN blocks (C<use> package).

This creates bigger and more independent code, but is more error prone and
does not support pre-compiled C<.pmc> modules.

It is highly recommended to use C<-i> together with C<-b> I<safebegin>.

=item B<-b> savebegin

Save all the BEGIN blocks.

Normally only BEGIN blocks that C<require>
other files (ex. C<use Foo;>) or push|unshift
to @INC are saved.

=item B<-k>

Keep the syntax tree - it is stripped by default.

=item B<-o>I<outfile>

Put the bytecode in <outfile> instead of dumping it to STDOUT.

=item B<-s>

Scan the script for C<# line ..> directives and for <goto LABEL>
expressions. When gotos are found keep the syntax tree.

=item B<-S>

Output assembler source rather than piping it through the assembler
and outputting bytecode.
Without C<-q> the assembler source is commented.

=item B<-m>

Compile to a F<.pmc> module rather than to a single standalone F<.plc> program.

Currently this just means that the bytecodes for initialising C<main_start>,
C<main_root>, C<main_cv> and C<curpad> are omitted.

=item B<-u>I<package>

"use package." Might be needed of the package is not automatically detected.

=item B<-F>I<file>

Include file. If not C<-i> define all symbols in the given included
source file. C<-i> would all included files,
C<-F> only a certain file - full path needed.

=item B<-q>

Be quiet.

=item B<-v>

Be verbose.

=item B<-TI>

Restore full @INC for running within the CORE testsuite.

=item B<-TF> I<cop file>

Set the COP file - for running within the CORE testsuite.

=item B<-Do>

OPs, prints each OP as it's processed

=item B<-DM>

Debugging flag for more verbose STDERR output.

B<M> for Magic and Matches.

=item B<-DG>

Debug GV's

=item B<-DA>

Set developer B<A>ssertions, to help find possible obj-indices out of range.

=back

=head1 KNOWN BUGS

=over 4

=item *

5.10 threaded fails with setting the wrong MATCH op_pmflags
5.10 non-threaded fails calling anoncode, ...

=item *

C<BEGIN { goto A: while 1; A: }> won't even compile.

=item *

C<?...?> and C<reset> do not work as expected.

=item *

variables in C<(?{ ... })> constructs are not properly scoped.

=item *

Scripts that use source filters will fail miserably.

=item *

Special GV's fail.

=back

=head1 NOTICE

There are also undocumented bugs and options.

=head1 AUTHORS

Originally written by Malcolm Beattie 1996 and
modified by Benjamin Stuhl <sho_pi@hotmail.com>.

Rewritten by Enache Adrian <enache@rdslink.ro>, 2003 a.d.

Enhanced by Reini Urban <rurban@cpan.org>, 2008-2012

=cut

# Local Variables:
#   mode: cperl
#   cperl-indent-level: 2
#   fill-column: 100
# End:
# vim: expandtab shiftwidth=2: